polyorb-2.8~20110207.orig/0000755000175000017500000000000011750740340014402 5ustar xavierxavierpolyorb-2.8~20110207.orig/README.DSA0000644000175000017500000000136011750740337015676 0ustar xavierxavierUsing PolyORB as DSA PCS ======================== PolyORB provides an application personality that implements a Partition Communication Subsystem for the Distributed Systems Annex of the Ada language, in conjunction with the GNAT compiler. In order to use this personality, you need to use matching releases of the compiler and middleware. The following combinations of releases are known to be compatible: GNAT version | PolyORB version --------------+----------------- GNAT Pro 6.0 | PolyORB 2.2 GNAT Pro 6.1 | PolyORB 2.3 GNAT GPL 2008 | PolyORB 2.4 GNAT Pro 6.2 | PolyORB 2.5 GNAT GPL 2009 | PoylORB GPL 2009 GNAT Pro 6.3 | PolyORB 2.6 GNAT GPL 2010 | PoylORB GPL 2010 GNAT Pro 6.4 | PolyORB 2.7 GNAT Pro 6.6 | PolyORB 2.8 (planned) polyorb-2.8~20110207.orig/doc/0000755000175000017500000000000011750740340015147 5ustar xavierxavierpolyorb-2.8~20110207.orig/doc/memoires/0000755000175000017500000000000011750740340016767 5ustar xavierxavierpolyorb-2.8~20110207.orig/doc/memoires/kaddour/0000755000175000017500000000000011750740340020420 5ustar xavierxavierpolyorb-2.8~20110207.orig/doc/memoires/kaddour/rapport.aux0000644000175000017500000002324011750740337022635 0ustar xavierxavier\relax \@writefile{toc}{\contentsline {chapter}{\numberline {1}Etat de l'art des Middlewares}{7}} \@writefile{lof}{\addvspace {10\p@ }} \@writefile{lot}{\addvspace {10\p@ }} \newlabel{chap:art}{{1}{7}} \@writefile{toc}{\contentsline {section}{\numberline {1.1}Jonathan}{7}} \@writefile{toc}{\contentsline {subsection}{\numberline {1.1.1}Introduction}{7}} \@writefile{lof}{\contentsline {figure}{\numberline {1.1}{\ignorespaces une liaison point \`a point}}{8}} \newlabel{fig:Jonathan}{{1.1}{8}} \@writefile{toc}{\contentsline {subsection}{\numberline {1.1.2}La s\'emantique des liaisons et des objets dans \\ Jonathan}{8}} \@writefile{toc}{\contentsline {subsubsection}{Les Objets liaison et les fabriques de liaisons}{8}} \@writefile{toc}{\contentsline {subsubsection}{Types et r\'ef\'erences}{8}} \@writefile{toc}{\contentsline {paragraph}{Les subrog\'es\nobreakspace {}:}{9}} \@writefile{toc}{\contentsline {subsection}{\numberline {1.1.3}Construction d'un ORB CORBA au-dessus du \\ noyau de Jonathan}{9}} \citation{Spring} \@writefile{toc}{\contentsline {subsubsection}{La personnalit\'e CORBA}{10}} \@writefile{toc}{\contentsline {subsubsection}{Une fabrique CORBA de liaisons de type flux}{10}} \@writefile{toc}{\contentsline {subsection}{\numberline {1.1.4}Conclusion}{10}} \@writefile{toc}{\contentsline {section}{\numberline {1.2}Quaterware\nobreakspace {}:\nobreakspace {}l'approche composant}{10}} \@writefile{toc}{\contentsline {subsection}{\numberline {1.2.1}Les composants de Quaterware}{11}} \@writefile{toc}{\contentsline {subsection}{\numberline {1.2.2}Composition d'un middleware}{11}} \@writefile{toc}{\contentsline {subsubsection}{Composition de CORBA}{12}} \@writefile{toc}{\contentsline {subsubsection}{Composition de RMI}{12}} \@writefile{toc}{\contentsline {subsubsection}{Composition de MPI}{12}} \citation{Reflexive} \@writefile{toc}{\contentsline {subsection}{\numberline {1.2.3}Conclusion}{13}} \@writefile{toc}{\contentsline {section}{\numberline {1.3}Middleware r\'eflexif}{13}} \@writefile{toc}{\contentsline {subsection}{\numberline {1.3.1}Principes g\'en\'eraux}{13}} \@writefile{toc}{\contentsline {subsection}{\numberline {1.3.2}L'architecture}{14}} \@writefile{lof}{\contentsline {figure}{\numberline {1.2}{\ignorespaces Structure globale du meta espace}}{15}} \newlabel{fig:reflexive}{{1.2}{15}} \@writefile{toc}{\contentsline {subsection}{\numberline {1.3.3}La biblioth\`eque de composants}{15}} \@writefile{toc}{\contentsline {subsection}{\numberline {1.3.4}Conclusion}{15}} \@writefile{toc}{\contentsline {chapter}{\numberline {2}Le protocole GIOP de CORBA}{17}} \@writefile{lof}{\addvspace {10\p@ }} \@writefile{lot}{\addvspace {10\p@ }} \@writefile{toc}{\contentsline {section}{\numberline {2.1}Introduction}{17}} \citation{Norme_Corba} \@writefile{toc}{\contentsline {section}{\numberline {2.2}Repr\'esentation commune de donn\'ees CDR}{18}} \newlabel{sec:CDR}{{2.2}{18}} \@writefile{toc}{\contentsline {section}{\numberline {2.3}Transfert de Messages GIOP}{19}} \@writefile{toc}{\contentsline {section}{\numberline {2.4}Formats de messages GIOP}{20}} \newlabel{sec:GIOP_messages}{{2.4}{20}} \@writefile{toc}{\contentsline {section}{\numberline {2.5}Le protocole IIOP (Internet Inter\discretionary {-}{}{}ORB Protocol)}{22}} \newlabel{sec:profil}{{2.5}{22}} \@writefile{toc}{\contentsline {chapter}{\numberline {3}Le Protocole SOAP}{25}} \@writefile{lof}{\addvspace {10\p@ }} \@writefile{lot}{\addvspace {10\p@ }} \@writefile{toc}{\contentsline {section}{\numberline {3.1}Introduction}{25}} \@writefile{toc}{\contentsline {section}{\numberline {3.2}Enveloppe de SOAP}{26}} \@writefile{toc}{\contentsline {paragraph}{Remarque}{26}} \@writefile{toc}{\contentsline {section}{\numberline {3.3}Corps du message SOAP Body}{26}} \@writefile{toc}{\contentsline {paragraph}{L'\'el\'ement Fault\nobreakspace {}:}{26}} \@writefile{toc}{\contentsline {section}{\numberline {3.4}Exemples de messages SOAP}{27}} \@writefile{toc}{\contentsline {paragraph}{Le message SOAP encapsul\'e dans une requ\^ete HTTP}{27}} \citation{XML} \@writefile{toc}{\contentsline {paragraph}{Le message SOAP encapsul\'e dans une r\'eponse HTTP}{28}} \@writefile{toc}{\contentsline {section}{\numberline {3.5}L'encodage}{28}} \@writefile{toc}{\contentsline {subsection}{\numberline {3.5.1}Types simples}{29}} \@writefile{toc}{\contentsline {subsection}{\numberline {3.5.2}Types compos\'es}{29}} \@writefile{toc}{\contentsline {paragraph}{Exemples\nobreakspace {}:}{29}} \@writefile{toc}{\contentsline {section}{\numberline {3.6}Conclusion}{30}} \@writefile{toc}{\contentsline {chapter}{\numberline {4}Le Middleware DROOPI}{31}} \@writefile{lof}{\addvspace {10\p@ }} \@writefile{lot}{\addvspace {10\p@ }} \@writefile{toc}{\contentsline {section}{\numberline {4.1}DROOPI : un middleware de plus?}{31}} \citation{TAO} \@writefile{toc}{\contentsline {section}{\numberline {4.2}Objectifs de DROOPI}{32}} \@writefile{toc}{\contentsline {section}{\numberline {4.3}Architecture g\'en\'erale}{32}} \@writefile{lof}{\contentsline {figure}{\numberline {4.1}{\ignorespaces Architecture de DROOPI}}{33}} \newlabel{fig:droopi-arch}{{4.1}{33}} \citation{POA} \@writefile{toc}{\contentsline {paragraph}{L'objet Request\nobreakspace {}:}{34}} \@writefile{toc}{\contentsline {section}{\numberline {4.4}Couche applicative}{34}} \citation{Design} \citation{Design} \@writefile{toc}{\contentsline {section}{\numberline {4.5}Quelques principes du Design appliqu\'es \`a DROOPI}{35}} \@writefile{toc}{\contentsline {subsection}{\numberline {4.5.1}Le motif Annotation}{35}} \@writefile{toc}{\contentsline {subsection}{\numberline {4.5.2}Le motif Composant ou chaine de responsabilit\'e}{35}} \@writefile{lof}{\contentsline {figure}{\numberline {4.2}{\ignorespaces Le motif \IeC {<<}Annotation\IeC {>>}}}{36}} \newlabel{fig:annotation}{{4.2}{36}} \@writefile{lof}{\contentsline {figure}{\numberline {4.3}{\ignorespaces Le motif \IeC {<<}\nobreakspace {}Component ou cha\IeC {\^\i }ne de responsabilit\'es\nobreakspace {}\IeC {>>}}}{37}} \newlabel{fig:components}{{4.3}{37}} \@writefile{toc}{\contentsline {chapter}{\numberline {5}Int\'egration de GIOP et SOAP dans DROOPI}{39}} \@writefile{lof}{\addvspace {10\p@ }} \@writefile{lot}{\addvspace {10\p@ }} \@writefile{toc}{\contentsline {section}{\numberline {5.1}Couche protocolaire g\'en\'erique}{39}} \newlabel{sec:couche-protocolaire}{{5.1}{39}} \@writefile{lof}{\contentsline {figure}{\numberline {5.1}{\ignorespaces La fonction transport.}}{40}} \newlabel{fig:fct_transport}{{5.1}{40}} \@writefile{lof}{\contentsline {figure}{\numberline {5.2}{\ignorespaces La fonction repr\'esentation.}}{40}} \newlabel{fig:fct_representation}{{5.2}{40}} \@writefile{lof}{\contentsline {figure}{\numberline {5.3}{\ignorespaces Fonction protocole.}}{41}} \newlabel{fig:fct_protocole}{{5.3}{41}} \@writefile{lof}{\contentsline {figure}{\numberline {5.4}{\ignorespaces Fonction Addressage.}}{42}} \newlabel{fig:fct_addressing}{{5.4}{42}} \@writefile{toc}{\contentsline {section}{\numberline {5.2}Description des classes}{42}} \@writefile{toc}{\contentsline {subsection}{\numberline {5.2.1}Asynchronous Evenement Source (AES)}{42}} \@writefile{toc}{\contentsline {subsection}{\numberline {5.2.2}Transport Access Point (TAP)}{42}} \@writefile{toc}{\contentsline {subsection}{\numberline {5.2.3}Transport Endpoint (TE)}{43}} \@writefile{lof}{\contentsline {figure}{\numberline {5.5}{\ignorespaces Framework de la couche protocolaire.}}{44}} \newlabel{fig:couche_protocolaire}{{5.5}{44}} \@writefile{toc}{\contentsline {subsection}{\numberline {5.2.4}Filter}{45}} \newlabel{sec:filter}{{5.2.4}{45}} \@writefile{toc}{\contentsline {subsection}{\numberline {5.2.5}Repr\'esentation}{45}} \@writefile{toc}{\contentsline {subsection}{\numberline {5.2.6}Protocole et Session}{45}} \newlabel{sub:protocole}{{5.2.6}{45}} \@writefile{toc}{\contentsline {section}{\numberline {5.3}Impl\'ementation de GIOP}{47}} \@writefile{toc}{\contentsline {subsection}{\numberline {5.3.1}Sc\'enario d'invocation}{47}} \@writefile{toc}{\contentsline {subsection}{\numberline {5.3.2}Les structures de donn\'ees}{48}} \@writefile{toc}{\contentsline {subsection}{\numberline {5.3.3}Initialisation de la pile}{48}} \@writefile{lof}{\contentsline {figure}{\numberline {5.6}{\ignorespaces Instanciation de la pile GIOP.}}{49}} \newlabel{fig:Pile_GIOP}{{5.6}{49}} \@writefile{toc}{\contentsline {subsection}{\numberline {5.3.4}Exemple d'impl\'ementation\nobreakspace {}:\nobreakspace {}le motif annotation}{50}} \@writefile{toc}{\contentsline {subsection}{\numberline {5.3.5}Conclusion}{50}} \@writefile{toc}{\contentsline {section}{\numberline {5.4}Impl\'ementation de SOAP}{51}} \@writefile{toc}{\contentsline {subsection}{\numberline {5.4.1}Sc\'enario d'invocation}{51}} \@writefile{toc}{\contentsline {subsection}{\numberline {5.4.2}Repr\'esentation des donn\'ees}{52}} \@writefile{toc}{\contentsline {subsection}{\numberline {5.4.3}Structures de donn\'ees}{52}} \@writefile{toc}{\contentsline {subsection}{\numberline {5.4.4}Initialisation de la pile}{53}} \@writefile{toc}{\contentsline {subsection}{\numberline {5.4.5}Conclusion}{53}} \@writefile{lof}{\contentsline {figure}{\numberline {5.7}{\ignorespaces Instanciation de la pile SOAP.}}{54}} \newlabel{fig:Pile_SOAP}{{5.7}{54}} \citation{GIOP} \citation{POA} \citation{Tasking} \@writefile{toc}{\contentsline {chapter}{Bibliographie}{57}} \bibcite{Reflexive}{1} \bibcite{XML}{2} \bibcite{GIOP}{3} \bibcite{Jonathan}{4} \bibcite{Roadmap}{5} \bibcite{HTTP}{6} \bibcite{POA}{7} \bibcite{Design}{8} \bibcite{Tutoriel_Corba}{9} \bibcite{Spring}{10} \bibcite{x-kernel}{11} \bibcite{DC_SOAP}{12} \bibcite{Norme_Corba}{13} \bibcite{Architecture_Droopi}{14} \bibcite{Droopi_Introduction}{15} \bibcite{Droopi_Introduction_2}{16} \bibcite{TAO}{17} \bibcite{Tasking}{18} \bibcite{Quaterware}{19} \bibcite{SOAP_aaron}{20} \bibcite{SOAP_Norme}{21} polyorb-2.8~20110207.orig/docs/0000755000175000017500000000000011750740340015332 5ustar xavierxavierpolyorb-2.8~20110207.orig/docs/echo.idl0000644000175000017500000000007211750740337016747 0ustar xavierxavierinterface Echo { string echoString (in string Mesg); }; polyorb-2.8~20110207.orig/docs/ada.kw0000755000175000017500000000065511750740337016441 0ustar xavierxavierwith while when use until type then terminate task tagged subtype separate select reverse reverse return requeue renames rem record range raise protected procedure private pragma package out others or of null not new mod loop limited is in if goto generic function for exit exception entry end elsif else do digits delta delay declare constant configuration case body begin array and all aliased access accept abstract abs abort polyorb-2.8~20110207.orig/docs/polyorb_ug.texi0000644000175000017500000072145511750740337020432 0ustar xavierxavier\input texinfo @c -*-texinfo-*- @c %**start of header @c oooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooo @c @c Style Guide @c @c 1. Always put a @noindent on the line before the first paragraph @c after any of these commands: @c @c @chapter @c @section @c @subsection @c @subsubsection @c @subsubsubsection @c @c @end smallexample @c @end itemize @c @end enumerate @c @c 2. DO NOT use @example. Use @smallexample instead. @c a) DO NOT use highlighting commands (@b{}, @i{}) inside an @smallexample @c context. These can interfere with the readability of the texi @c source file. Instead, use one of the following annotated @c @smallexample commands, and preprocess the texi file with the @c gentexifile tool (which generates appropriate highlighting): @c @smallexample @c ada @c @smallexample @c adanocomment @c @smallexample @c projectfile @c b) The "@c ada" markup will result in boldface for reserved words @c and italics for comments @c c) The "@c adanocomment" markup will result only in boldface for @c reserved words (comments are left alone) @c d) The "@c projectfile" markup is like "@c ada" except that the set @c of reserved words include the new reserved words for project files @c @c 3. Each @chapter, @section, @subsection, @subsubsection, etc. @c command must be preceded by two empty lines @c @c 4. The @item command should be on a line of its own if it is in an @c @itemize or @enumerate command. @c @c 5. DO NOT put trailing spaces at the end of a line. Such spaces will @c cause the document build to fail. @c @c 6. DO NOT use @cartouche for examples that are longer than around 10 lines. @c This command inhibits page breaks, so long examples in a @cartouche can @c lead to large, ugly patches of empty space on a page. @c @c 7. To add an entry to the bibliography, you must: @c * add it to polyorb_ug.bib @c This will generate the correct polyorb_ug_ref.texi file @c You may then cite the correct reference. @c @c oooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooo @c $Id: polyorb_ug.texi 166544 2010-11-03 15:36:23Z quinot $ @include svn.texi @setfilename polyorb_ug.info @settitle PolyORB User's Guide @set COPYRIGHT Copyright @copyright{} 2003-2010, Free Software Foundation @set AUTHORS1 Robert Duff, J@'er@^ome Hugues, Laurent Pautet, @set AUTHORS2 Thomas Quinot, Samuel Tardieu @setchapternewpage odd @syncodeindex fn cp @c %**end of header @titlepage @title PolyORB User's Guide @include polyorb_version.texi @subtitle Version @value{POLYORB_VERSION} @svndate $Date: 2010-11-03 16:36:23 +0100 (Wed, 03 Nov 2010) $ @subtitle @value{SVNDate} @author @value{AUTHORS1} @author @value{AUTHORS2} @page @vskip 0pt plus 1filll @value{COPYRIGHT} @noindent Permission is granted to copy, distribute and/or modify this document under the terms of the GNU Free Documentation License, Version 1.1 or any later version published by the Free Software Foundation; with the Invariant Sections being ``GNU Free Documentation License'', with the Front-Cover Texts being ``PolyORB User's Guide'', and with no Back-Cover Texts. A copy of the license is included in the section entitled ``GNU Free Documentation License''. @end titlepage @ifinfo @ifhtml @node Top, About This Guide,, @top PolyORB User's Guide @end ifhtml @ifnothtml @node Top, About This Guide, (dir), (dir) @top PolyORB User's Guide @end ifnothtml PolyORB User's Guide @include polyorb_version.texi Version @value{POLYORB_VERSION} $Date: 2010-11-03 16:36:23 +0100 (Wed, 03 Nov 2010) $ @value{AUTHORS1} @value{AUTHORS2} @value{COPYRIGHT} @noindent Permission is granted to copy, distribute and/or modify this document under the terms of the GNU Free Documentation License, Version 1.1 or any later version published by the Free Software Foundation; with the Invariant Sections being ``GNU Free Documentation License'', with the Front-Cover Texts being ``PolyORB User's Guide'', and with no Back-Cover Texts. A copy of the license is included in the section entitled ``GNU Free Documentation License''. @menu * About This Guide:: * Introduction to PolyORB:: * Installation:: * Overview of PolyORB personalities:: * Building an application with PolyORB:: * Tasking model in PolyORB:: * CORBA:: * RT-CORBA:: * DSA:: * MOMA:: * AWS:: * GIOP:: * SOAP:: * Tools:: * Performance considerations:: * Conformance to standards:: * References:: * GNU Free Documentation License:: * Index:: @detailmenu --- The Detailed Node Listing --- About This Guide * What This Guide Contains:: * Conventions:: Introduction to PolyORB * Introduction to distributed systems:: * Distribution models and middleware standards:: * The PolyORB generic middleware:: Installation * Supported Platforms:: * Build requirements:: * Build instructions:: * Additional instructions for cross platforms:: * Building the documentation and PolyORB's examples:: * Build Options:: * Compiler Tools and Run-Time libraries Options:: * Platform notes:: Overview of PolyORB personalities * Application personalities:: * CORBAoverview:: * DSAoverview:: * MOMAoverview:: * AWSoverview:: * Protocol personalities:: * GIOPoverview:: * SOAPoverview:: Configuration * Compile-time configuration:: * Run-time configuration:: * Setting up protocol personalities:: * Activating debugging traces:: * Tracing exceptions:: * polyorb.gpr:: * polyorb-config:: Tasking model in PolyORB * PolyORB Tasking runtimes:: * PolyORB ORB Tasking policies:: * PolyORB ORB Controller policies:: * PolyORB Tasking configuration:: CORBA * What you should know before Reading this section:: * Installing CORBA application personality:: * Usage of idlac:: * Resolving names in a CORBA application:: * Building a CORBA application with PolyORB:: * Configuring a CORBA application:: * PolyORB specific APIs:: * Implementation Notes:: RT-CORBA * What you should know before Reading this section2:: * Installing RT-CORBA:: * Configuring RT-CORBA:: * RTCORBA.PriorityMapping:: * RTCosScheduling Service:: DSA * Introduction to the Ada DSA:: * Partition Communication Subsystem:: * Most Features in One Example:: * A small example of a DSA application:: * Building a DSA application with PolyORB:: * Running a DSA application:: MOMA * What you should know before Reading this section4:: * Installing MOMA application personality:: * Package hierarchy:: GIOP * Installing GIOP protocol personality:: * GIOP Instances:: * Configuring the GIOP personality:: * Code sets:: SOAP * Installing SOAP protocol personality:: * Configuring the SOAP personality:: Tools * po_catref:: * po_names:: Conformance to standards * CORBA standards conformance:: * RT-CORBA standards conformance:: * CORBA-GIOP standards conformance:: * SOAP standards conformance:: @end detailmenu @end menu @end ifinfo @c ------------------------------------------------------------------- @contents @c ------------------------------------------------------------------- @node About This Guide @unnumbered About This Guide @c ------------------------------------------------------------------- @noindent This guide describes the use of PolyORB, a middleware that enables the construction of distributed Ada applications. It describes the features of the middleware and related APIs and tools, and details how to use them to build Ada applications. @menu * What This Guide Contains:: * Conventions:: @end menu @c ------------------------------------------------------------------- @node What This Guide Contains @unnumberedsec What This Guide Contains @c ------------------------------------------------------------------- @noindent This guide contains the following chapters: @itemize @bullet @item @ref{Introduction to PolyORB} provides a brief description of middleware and PolyORB's architecture. @item @ref{Installation} details how to configure and install PolyORB on your system. @item @ref{Overview of PolyORB personalities} enumerates the different personalities, or distribution mechanisms, PolyORB provides. @item @ref{Building an application with PolyORB} presents the different steps to build a distributed application using PolyORB. @item @ref{Tasking model in PolyORB} details the use of tasking constructs within PolyORB. @item @ref{CORBA} describes PolyORB's implementation of OMG's CORBA. @item @ref{RT-CORBA} describes PolyORB's implementation of RT-CORBA, the real-time extensions of OMG's CORBA. @item @ref{DSA} describes PolyORB's implementation of the Ada Distributed Systems Annex. @item @ref{MOMA} describes PolyORB's implementation of MOMA, the Message Oriented Middleware for Ada. @item @ref{AWS} describes the integration of the Ada Web Server (AWS) framework into PolyORB. @item @ref{GIOP} describes PolyORB's implementation of GIOP, the protocol defined as part of CORBA. @item @ref{SOAP} describes PolyORB's implementation of SOAP. @item @ref{Tools} describes PolyORB's tools. @item @ref{Conformance to standards} discusses the conformance of the PolyORB's personalities to the CORBA and SOAP standards. @item @ref{References} provides a list of useful references to complete this documentation. @item @ref{GNU Free Documentation License} contains the text of the license under which this document is being distributed. @end itemize @c ------------------------------------------------------------------- @node Conventions @unnumberedsec Conventions @cindex Conventions @cindex Typographical conventions @c ------------------------------------------------------------------- @noindent Following are examples of the typographical and graphic conventions used in this guide: @itemize @bullet @item @code{Functions}, @code{utility program names}, @code{standard names}, and @code{classes}. @item @samp{Option flags} @item @file{File Names}, @file{button names}, and @file{field names}. @item @var{Variables}. @item @emph{Emphasis}. @item [optional information or parameters] @item Examples are described by text @smallexample and then shown this way. @end smallexample @end itemize @noindent Commands that are entered by the user are preceded in this manual by the characters @w{``@code{$ }''} (dollar sign followed by space). If your system uses this sequence as a prompt, then the commands will appear exactly as you see them in the manual. If your system uses some other prompt, then the command will appear with the @code{$} replaced by whatever prompt you are using. Full file names are shown with the ``@code{/}'' character as the directory separator; e.g., @file{parent-dir/subdir/myfile.adb}. If you are using GNAT on a Windows platform, please note that the ``@code{\}'' character should be used instead. @c ------------------------------------------------------------------- @node Introduction to PolyORB @chapter Introduction to PolyORB @cindex PolyORB @c ------------------------------------------------------------------- @menu * Introduction to distributed systems:: * Distribution models and middleware standards:: * The PolyORB generic middleware:: @end menu @c ------------------------------------------------------------------- @node Introduction to distributed systems @section Introduction to distributed systems @c ------------------------------------------------------------------- A distributed system architecture comprises a network of computers and the software components that execute on those computers. Such architectures are commonly used to improve the performance, reliability, and reusability of complex applications. Typically, there is no shared address space available to remotely-located components (that is to say, components running on different nodes of the network), and therefore these components must communicate using some form of message-passing. @menu * Using OS Network Services:: * Using a Middleware Environment:: * Using a Distributed Language:: @end menu @node Using OS Network Services, Using a Middleware Environment, Introduction to distributed systems, Introduction to distributed systems @subsection Using OS Network Services There are several programming techniques for developing distributed applications. These applications have traditionally been developed using network programming interfaces such as sockets. Programmers have to perform explicit calls to operating system services, a task that can be tedious and error-prone. This includes initializing socket connections and determining peer location, marshalling and unmarshalling data structures, sending and receiving messages, debugging and testing several programs at the same time, and porting the application to several platforms to uncover subtle differences between various network interfaces. Of course, this communication code can be encapsulated in wrappers to reduce its complexity, but it is clear that most of it can be automatically generated. Message passing diverts developer's attention from the application domain. The query and reply scenario is a classical scheme in distributed applications; using message passing for such a scheme can be compared to only using the ``goto'' mechanism in a non-distributed application. This is considered unacceptable methodology in modern software engineering. A cleaner and more structured approach consists in using subprograms. In some respects, network programming can be compared to parallel programming. The user can decide to split his code into several pieces and to multiplex the execution of threads himself, using a table-driven model. The scheduling code ends up embedded in the user code. This solution is error-prone and fragile in regard to any future modification. Relying on an implementation of threads such as provided in a POSIX operating environment is a better solution. Relying on language primitives that support concurrency, such as Ada tasks, is best, as the underlying parallelism support is thus entirely abstracted. @node Using a Middleware Environment, Using a Distributed Language, Using OS Network Services, Introduction to distributed systems @subsection Using a Middleware Environment A middleware environment is intended to provide high level abstractions in order to easily develop user applications. Environments like CORBA or Distributed Computing Environment (DCE) provide a framework to develop client/server applications based on the Remote Procedure Call model (RPC). The RPC model is inspired by the query and reply scheme. In rough analogy to a regular procedure call, arguments are pushed onto a stream, along with some data specifying the remote procedure to be executed. The stream is transmitted over the network to the server. The server decodes the stream, performs the regular subprogram call locally, and then puts the output parameters into another stream, along with the exception (if any) raised by the subprogram execution. The server then sends this stream back to the caller. The caller decodes the stream and raises the exception locally if needed. CORBA provides the same enhancements to the remote procedure model that object-oriented languages provide to classical procedural languages. These enhancements include encapsulation, inheritance, type checking, and exceptions. These features are offered through an Interface Definition Language (IDL). The middleware communication framework provides all the machinery to perform, somewhat transparently, remote procedure calls or remote object method invocations. For instance, each CORBA interface communicates through an Object Request Broker (ORB). A communication subsystem such as an ORB is intended to allow applications to use objects without being aware of their underlying message-passing implementation. In addition. the user may also require a number of more complex services to develop his distributed application. Some of these services are indispensable, for example a location service that allows clients to reference remote services via high level names (as opposed to a low level addressing scheme involving transport-specific endpoint addresses such as IP addresses and port numbers). Other services provide domain-independent interfaces that are frequently used by distributed applications. If we return to the multi-threaded programming comparison, the middleware solution is close to what a POSIX library or a language like Esterel@footnote{@t{Esterel} is an imperative synchronous language designed for the specification and the development of reactive systems.} would provide for developing concurrent applications. A middleware framework like DCE is close to a POSIX library in terms of abstraction levels. Functionalities are very low-level and very complex. CORBA is closer to Esterel in terms of development process. The control part of the application can be specified in a description language. The developer then has to fill in automatically generated source code templates (stubs and skeletons) to build the computational part of the application. The distribution is a pre-compilation process and the distributed boundaries are always explicit. Using CORBA, the distributed part is written in IDL and the core of the application is written in a host language such as C++. @node Using a Distributed Language, , Using a Middleware Environment, Introduction to distributed systems @subsection Using a Distributed Language Rather than defining a new language like the CORBA IDL, an alternative is to extend an existing programming language with distributed features. The distributed object paradigm provides a more object-oriented approach to programming distributed systems. The notion of a distributed object is an extension to the abstract data type that allows the services provided in the type interface to be called independently of where the actual service is executed. When combined with object-oriented features such as inheritance and polymorphism, distributed objects offer a more dynamic and structured computational environment for distributed applications. The Distributed Systems Annex (DSA) of Ada defines several extensions that allow the user to write a distributed system entirely in Ada. The types of distributed objects, the services they provide, and the bodies of the remote methods to be executed are all defined in conventional Ada packages. The Ada model is analogous to the Java/RMI model. In both languages, the IDL is replaced by well-defined language constructs. Therefore, the language supports both remote procedure calls and remote object method invocations transparently, and the semantics of distribution are consistent with the rest of the language. A program written in such a language is intended to communicate with a program written in the same language, but this apparent restriction has several useful consequences. The language can provide more powerful features because it is not constrained by the common features available in all host languages. In Ada, the user will define a specification of remote services and implement them exactly as he would for ordinary, non-distributed services. His Ada environment will compile them to produce a stub file (on the caller side) and a skeleton file that automatically includes the body of the services (on the receiver side). Creating objects, obtaining or registering object references or adapting the object skeleton to the user object implementation are made transparent because the language environment has a full control over the development process. Comparing with multi-threaded programming once again, the language extension solution is equivalent to the solution adopted for tasking facilities in Ada. Writing a distributed application is as simple as writing a concurrent application: there is no binding consideration and no code to wrap. The language and its run-time system take care of most issues that would divert the programmer's attention from the application domain. @c ------------------------------------------------------------------- @node Distribution models and middleware standards @section Distribution models and middleware standards @c ------------------------------------------------------------------- @noindent Middleware provides a framework that hides the complex issues of distribution, and offers the programmer high-level abstractions that allow easy and transparent construction of distributed applications. A number of different standards exist for creating object-oriented distributed applications. These standards define two subsystems that enable interaction between application partitions: @itemize @bullet @item the API seen by the developer's applicative objects; @item the protocol used by the middleware environment to interact with other nodes in the distributed application. @end itemize @noindent Middleware implementations also offer programming guidelines and development tools to ease the construction of large heterogeneous distributed systems. Many issues typical to distributed programming may still arise: application architectural choice, configuration or deployment. Since there is no ``one size fits all'' architecture, choosing the adequate distribution middleware in its most appropriate configuration is a key design point that dramatically impacts the design and performance of an application. Consequently, applications need to rapidly tailor middleware to the specific distribution model they require. A distribution model is defined by the combination of distribution mechanisms made available to the application. Common examples of such mechanisms are Remote Procedure Call (RPC), Distributed Objects or Message Passing. A distribution infrastructure or middleware refers to software that supports one distribution model (or several), e.g.: OMG CORBA, Java Remote Method Invocation (RMI), the Distributed Systems Annex of Ada, Java Message Service (MOM). @c ------------------------------------------------------------------- @node The PolyORB generic middleware @section The PolyORB generic middleware @c ------------------------------------------------------------------- @noindent Typical middleware implementations for one platform support only one set of such interfaces, predefined configuration capabilities and cannot interoperate with other platforms. In addition to traditional middleware implementations, PolyORB provides an original architecture to enable support for multiple interoperating distribution models in a uniform canvas. PolyORB is a polymorphic, reusable infrastructure for building or prototyping new middleware adapted to specific application needs. It provides a set of components on top of which various instances can be elaborated. These instances (or personalities) are views on PolyORB facilities that are compliant to existing standards, either at the API level (application personality) or at the protocol level (protocol personality). These personalities are mutually exclusive views of the same architecture. The decoupling of application and protocol personalities, and the support for multiple simultaneous personalities within the same running middleware, are key features required for the construction of interoperable distributed applications. This allows PolyORB to communicate with middleware that implements different distribution standards: PolyORB provides middleware-to-middleware interoperability (M2M). PolyORB's modularity allows for easy extension and replacement of its core and personality components, in order to meet specific requirements. In this way, standard or application-specific personalities can be created in a streamlined process, from early stage prototyping to full-featured implementation. The PolyORB architecture also allows the automatic, just-in-time creation of proxies between incompatible environments. You may find additional technical literature on PolyORB, including research papers and implementation notes, on the project websites: @url{http://libre.adacore.com/libre/tools/polyorb/} and @url{http://polyorb.objectweb.org/}. @i{Note: PolyORB is the project formerly known as DROOPI, a Distributed Reusable Object-Oriented Polymorphic Infrastructure} @c ------------------------------------------------------------------- @node Installation @chapter Installation @c ------------------------------------------------------------------- @menu * Supported Platforms:: * Build requirements:: * Build instructions:: * Additional instructions for cross platforms:: * Building the documentation and PolyORB's examples:: * Build Options:: * Compiler Tools and Run-Time libraries Options:: * Platform notes:: @end menu @c ------------------------------------------------------------------- @node Supported Platforms @section Supported Platforms @c ------------------------------------------------------------------- @noindent PolyORB has been compiled and successfully tested on the following platforms: @itemize @bullet @item AIX @item FreeBSD @item HP-UX @item Linux @item MacOS X @item Solaris @item Tru64 @item VxWorks @item Windows @end itemize @noindent @emph{Note: PolyORB should compile and run on every target for which GNAT and the @code{GNAT.Sockets} package are available.} @c ------------------------------------------------------------------- @node Build requirements @section Build requirements @c ------------------------------------------------------------------- @noindent GNU tar is required to unpack PolyORB source packages. Ada compiler: @itemize @bullet @item GNAT Pro 6.0 or later @item GNAT GPL 2007 or later @item FSF GCC 4.3 or later @end itemize For builds for cross targets, both a native and a cross compiler are required, as some tools (like an IDL-to-Ada compiler) are meant for use on the build host. Optional: @itemize @bullet @item (Only for older versions of GNAT, and only if you want to build the CORBA application personality): A C++ compiler. The OMG IDL specification mandates that IDL source files be preprocessed according to standard C++ preprocessing rules. Newer versions of GNAT provide an integrated IDL preprocessor. This feature is detected and used automatically. However, for older versions of GNAT, PolyORB relies on an external preprocessor provided by a suitable C++ compiler. Please refer to the documentation of your particular version of GNAT to know if it supports this feature. @item XML/Ada (@url{http://libre.adacore.com/libre/tools/xmlada/}) if you want to build the SOAP protocol personality. @end itemize @noindent Note: per construction, the macro @command{configure} used to find your GNAT compiler looks first for the executable @command{gnatgcc}, then @command{adagcc} and finally @command{gcc} to find out which Ada compiler to use. You should be very careful with your path and executables if you have multiple GNAT versions installed. See the explanation below on the ADA environment variable if you need to override the default guess. @c ------------------------------------------------------------------- @node Build instructions @section Build instructions @c ------------------------------------------------------------------- @noindent To compile and install PolyORB, execute: @smallexample $ ./configure [some options] $ make $ make install @end smallexample @noindent This will install files in standard locations. If you want to choose a prefix other than @file{/usr/local}, give configure a @option{--prefix=whereveryouwant} argument. NOTE: you must use GNU make (version 3.80 or later) to build PolyORB. @c ------------------------------------------------------------------- @node Additional instructions for cross platforms @section Additional instructions for cross platforms @c ------------------------------------------------------------------- @noindent The @file{RANLIB} environment variable must be set to the path of the cross @file{ranlib} prior to running @file{configure} with the appropriate @code{--target} option. For example, for VxWorks 5 execute: @smallexample $ export RANLIB=ranlibppc $ ./configure --target=powerpc-wrs-vxworks [some options] $ make $ make install @end smallexample Only one PolyORB installation (native or cross) is currently possible with a given @code{--prefix}. If both a native and a cross installation are needed on the same machine, distinct prefixes must be used. Use @code{./configure --help} for a full list of available configuration switches. @c ------------------------------------------------------------------- @node Building the documentation and PolyORB's examples @section Building the documentation and PolyORB's examples @c ------------------------------------------------------------------- @noindent PolyORB's documentation and examples are built separately. To build the examples, run @command{make examples} in the root directory. The build process will only build examples that correspond to the personalities you configured. Note that some examples require the CORBA COS Naming and IR services to be enabled (using @command{--enable-corba-services="naming ir"} on the @command{configure} command line). Similarly, to build the documentation, run @command{make docs}. You may install PolyORB's documentation in a standard location using @command{make install}. @c ------------------------------------------------------------------- @node Build Options @section Build Options @c ------------------------------------------------------------------- @noindent Available options for the 'configure' script include: @itemize @bullet @item @option{--with-appli-perso="..."}: application personalities to build Available personalities: AWS, CORBA, DSA, MOMA e.g. @option{--with-appli-perso="corba moma"} to build both the CORBA and MOMA personalities @item @option{--with-proto-perso="..."}: protocol personalities to build Available personalities: GIOP, SOAP e.g. @option{--with-proto-perso="giop soap"} to build both the GIOP and SOAP personalities @item @option{--with-idl-compiler="..."}: select IDL compiler Available IDL compilers: iac (default), idlac e.g. @option{--with-idl-compiler=''iac''} to build iac @item @option{--with-corba-services="..."}: CORBA COS services to build Available services: event, ir, naming, notification, time e.g. @option{--with-corba-services="event naming"} to build only COS Event and COS Naming. @end itemize @noindent By default, only the CORBA and GIOP personalities are built, and no CORBA Services are built. @itemize @bullet @item @option{--with-openssl}: build SSL support and SSL dependent features, including the IIOP/SSLIOP personality @item @option{--help}: list all options available @item @option{--enable-shared}: build shared libraries. @item @option{--enable-debug}: enable debugging information generation and supplementary runtime checks. Note that this option has a significant space and time cost, and is not recommended for production use. @end itemize @c ------------------------------------------------------------------- @node Compiler Tools and Run-Time libraries Options @section Compiler, Tools and Run-Time libraries Options @c ------------------------------------------------------------------- @noindent The following environment variables can be used to override configure's guess at what compilers to use: @itemize @item @code{CC}: the C compiler @item @code{ADA}: the Ada compiler (e.g. gcc, gnatgcc or adagcc) @item @code{CXXCPP}, @code{CXXCPPFLAGS}: the preprocessor used by the IDL-to-Ada compiler (only when setting up the CORBA application personality). CORBA specifications require this preprocessor to be compatible with the preprocessing rules defined in the C++ programming language specifications. @end itemize @noindent For example, if you have two versions of GNAT installed and available in your @code{PATH}, and configure picks the wrong one, you can indicate what compiler should be used with the following (assuming Bourne shell syntax): @smallexample $ ADA=/path/to/good/compiler/gcc ./configure [options] @end smallexample PolyORB will be compiled with GNAT build host's configuration, including run-time library. You may override this setting using @code{ADA_INCLUDE_PATH} and @code{ADA_OBJECTS_PATH} environment variables. See GNAT User's Guide for more details. You can add specific build options to GNAT using the @code{EXTRA_GNATMAKE_FLAGS} variable: @smallexample $ EXTRA_GNATMAKE_FLAGS=--RTS=rts-sjlj ./configure [options] @end smallexample You can also pass compiler-only flags using the @code{ADAFLAGS} variable. NOTE: Developers building PolyORB from the version control repository will need to rebuild the configure script and other files. To do so, from the top-level source directory, run the support/reconfig script after each update from the repository. In addition to the requirements above, developers will need autoconf 2.57 or newer, automake 1.6.3 or newer, and libtool 1.5.8 or newer. @c ------------------------------------------------------------------- @node Platform notes @section Platform notes @c ------------------------------------------------------------------- @noindent Solaris (all versions): /usr/ucb/tr is not suitable to build PolyORB. Your PATH must be set to that tr(1) is /usr/bin/tr, /use/xpg4/bin/tr or GNU tr. @noindent Tru64 5.1A: The default maximal data segment size may not be sufficient to compile PolyORB. If a GNAT heap exhausted error message occurs during build, try raising this limit using: @smallexample ulimit -d unlimited @end smallexample @noindent AIX 5.2: PolyORB must be compiled with the -mminimal-toc compiler switch. This is taken care of automatically by the PolyORB configure script. The 'ulimit' command may be needed as for Tru64 (see above). @noindent HP-UX 11.00: The version of install(1) from /opt/imake/bin on HP-UX is not suitable for installing PolyORB. Make sure that /opt/imake/bin is not on the PATH when building and installing PolyORB. @c ------------------------------------------------------------------- @node Overview of PolyORB personalities @chapter Overview of PolyORB personalities @cindex Personalities @c ------------------------------------------------------------------- @noindent A personality is an instantiation of specific PolyORB components. It provides the mechanisms specified by a distribution model, e.g. an API, a code generator or a protocol stack. This section provides a brief overview of existing personalities. @emph{Note: some of these personalities are available only through PolyORB's repository.} @menu * Application personalities:: * Protocol personalities:: @end menu @c ------------------------------------------------------------------- @node Application personalities @section Application personalities @cindex Application personalities @c ------------------------------------------------------------------- @noindent Application personalities constitute the adaptation layer between application components and middleware. They provide APIs and/or a code generator to register application entities with PolyORB's core, and interoperate with the core to allow the exchange of requests with remote entities. @menu * CORBAoverview:: * DSAoverview:: * MOMAoverview:: * AWSoverview:: @end menu @c ------------------------------------------------------------------- @node CORBAoverview @subsection CORBA @cindex CORBA @cindex RT-CORBA @cindex CORBA, COS Services @c ------------------------------------------------------------------- @noindent CORBA is the OMG specification of a Distributed Object Computing (DOC) distribution model (@cite{[OMG04]}). It is now a well-known and well-established specification, used in a wide range of industrial applications. PolyORB provides a CORBA-compatible implementation based on a mapping of the IDL language version 1.2 described in @cite{[OMG01]} and CORBA core specifications. PolyORB also provides an implementation of various additional specifications described by the OMG, including @code{COS Services: COS Naming, Notification, Event, Time}, and additional specifications: @code{RT-CORBA}, @code{PortableInterceptors}, @code{DynamicAny}. @c ------------------------------------------------------------------- @node DSAoverview @subsection Distributed Systems Annex of Ada (DSA) @cindex DSA, Distributed Systems Annex @c ------------------------------------------------------------------- @noindent The Distributed Systems Annex of Ada (DSA) @cite{[ISO06]} is a normative part of the language specification. It was first introduced in the ``Ada 95'' revision of the language (@cite{[ISO95]}). It describes remote invocation schemes applied to most language constructs. @c ------------------------------------------------------------------- @node MOMAoverview @subsection Message Oriented Middleware for Ada (MOMA) @cindex MOMA, Message Oriented Middleware for Ada @c ------------------------------------------------------------------- @noindent MOMA (Message Oriented Middleware for Ada) provides message passing mechanisms. It is an Ada adaptation of Sun's Java Message Service (JMS) @cite{[SUN99]}, a standardized API for common message passing models. @c ------------------------------------------------------------------- @node AWSoverview @subsection Ada Web Server (AWS) @cindex AWS, Ada Web Server @c ------------------------------------------------------------------- @noindent The Web Server personality provides the same API as the Ada Web Server project (AWS) @cite{[Obr03]}. It allows for the implementation of web services, web server applications, or classical web pages. AWS-based servers allow the programmer to directly interact with incoming or outgoing @code{HTTP} and @code{SOAP} requests. @c ------------------------------------------------------------------- @node Protocol personalities @section Protocol personalities @cindex Protocol personality @c ------------------------------------------------------------------- @noindent Protocol personalities handle the mapping of requests (representing interactions between application entities) onto messages exchanged through a communication network, according to a specific protocol. @menu * GIOPoverview:: * SOAPoverview:: @end menu @c ------------------------------------------------------------------- @node GIOPoverview @subsection GIOP @cindex GIOP @c ------------------------------------------------------------------- @noindent GIOP is the transport layer of the CORBA specifications. GIOP is a generic protocol. This personality implements GIOP versions from 1.0 to 1.2 along with the CDR representation scheme to map data types between the neutral core layer and CDR streams. It also provides the following dedicated instances: @itemize @bullet @item IIOP supports synchronous request semantics over TCP/IP, @cindex IIOP @item IIOP/SSIOP supports synchronous request semantics using SSL sockets, @cindex SSLIOP @item MIOP instantiation of GIOP enables group communication over IP multicast, @cindex MIOP @item DIOP relies on UDP/IP communications to transmit one-way requests only. @cindex DIOP @end itemize @c ------------------------------------------------------------------- @node SOAPoverview @subsection SOAP @cindex SOAP @c ------------------------------------------------------------------- @noindent The SOAP protocol @cite{[W3C03]} enables the exchange of structured and typed information between peers. It is a self-describing XML document @cite{[W3C03]} that defines both its data and semantics. Basically, SOAP with @code{HTTP} bindings is used as a communication protocol for Web Services. @c ------------------------------------------------------------------- @node Building an application with PolyORB @chapter Building an application with PolyORB @cindex Configuration, PolyORB @c ------------------------------------------------------------------- @menu * Compile-time configuration:: * Run-time configuration:: * Setting up protocol personalities:: * Activating debugging traces:: * Tracing exceptions:: * polyorb.gpr:: * polyorb-config:: @end menu @c ------------------------------------------------------------------- @node Compile-time configuration @section Compile-time configuration @c ------------------------------------------------------------------- @noindent The user may configure some elements of a PolyORB application at compile-time. @menu * Tasking runtimes:: * Middleware tasking policies:: * Sample files:: @end menu @c ------------------------------------------------------------------- @node Tasking runtimes @subsection Tasking runtimes @c ------------------------------------------------------------------- @noindent PolyORB provides several tasking runtimes. The user may select the most appropriate one, depending on application requirements. The tasking runtimes determine the constructs PolyORB may use for its internal synchronizations. @itemize @bullet @item @code{No_Tasking}: There is no dependency on the Ada tasking runtime, middleware is mono-task. @item @code{Full_Tasking}: Middleware uses Ada tasking constructs, middleware can be configured for multi-tasking. @item @code{Ravenscar} : Middleware uses Ada tasking constructs, with the limitations of the Ravenscar profile @cite{[DB98]}. Middleware can be configured for multi-tasking. @cindex Ravenscar @end itemize @noindent See @ref{Tasking model in PolyORB} for more information on this point. @c ------------------------------------------------------------------- @node Middleware tasking policies @subsection Middleware tasking policies @c ------------------------------------------------------------------- @noindent PolyORB provides several tasking policies. A tasking policy defines how tasks are used by the middleware to process incoming requests. @itemize @bullet @item @code{No_Tasking}: There is only one task in middleware, processing all requests. @item @code{Thread_Per_Session}: One task monitors communication entities. One task is spawned for each active connection. This task handles all incoming requests on this connection. @item @code{Thread_Per_Request}: One task monitors communication entities. One task is spawned for each incoming request. @item @code{Thread_Pool}: A set of tasks cooperate to handle all incoming requests. @end itemize @noindent See @ref{Tasking model in PolyORB} for more information on this point. @c ------------------------------------------------------------------- @node Sample files @subsection Sample files @c ------------------------------------------------------------------- @noindent PolyORB provides a set of predefined setup packages. You must `with' one of them in your application node to activate the corresponding setup. @itemize @bullet @item @code{PolyORB.Setup.No_Tasking_Client}: a client node, without any tasking support, configured to use all protocol personalities built with PolyORB. Note that this configuration should not be used with multiple application tasks. @item @code{PolyORB.Setup.Thread_Pool_Client}: a client node, with tasking enabled, configured to use all protocol personalities built with PolyORB. This configuration places no restriction on the use of tasking by application code. Middleware tasking policy is @code{Thread_Pool}. @item @code{PolyORB.Setup.Ravenscar_TP_Server}: a server node, with tasking enabled, configured to use all protocol personalities built with PolyORB. Middleware tasking runtime follows Ravenscar's profile restrictions. Middleware tasking policy is @code{Thread_Pool}. @item @code{PolyORB.Setup.Thread_Per_Request_Server}: a server node, with tasking enabled, configured to use all protocol personalities built with PolyORB. Middleware tasking policy is @code{Thread_Per_Request}. @item @code{PolyORB.Setup.Thread_Per_Session_Server}: a server node, with tasking enabled, configured to use all protocol personalities built with PolyORB. Middleware tasking policy is @code{Thread_Per_Session}. @item @code{PolyORB.Setup.Thread_Pool_Server}: a server node, with tasking enabled, configured to use all protocol personalities built with PolyORB. Middleware tasking policy is @code{Thread_Pool}. @end itemize @noindent To use one of these configurations, add a dependency on one of these packages, for example, @code{with PolyORB.Setup.Thread_Pool_Server;}. The elaboration of the application (based on Ada rules) and the initialization of the partition (based on the application personalities mechanisms) will properly set up your application. @c ------------------------------------------------------------------- @node Run-time configuration @section Run-time configuration @c ------------------------------------------------------------------- @noindent The user may configure some elements of a PolyORB application at run time. Using the default configurations provided by PolyORB, the parameters are read in the following order: command line, environment variables, configuration file. PolyORB will use the first value that matches the searched parameter. @menu * Using a configuration file:: * Using environment variables:: * Using the command line:: * Using a source file:: @end menu @c ------------------------------------------------------------------- @node Using a configuration file @subsection Using a configuration file @cindex @file{polyorb.conf} @cindex @code{POLYORB_CONF} @c ------------------------------------------------------------------- @noindent A configuration file may be used to configure a PolyORB node. A sample configuration file may be found in @file{src/polyorb.conf}. The syntax of the configuration file is: @itemize @bullet @item empty lines and lines that have a '#' in column 1 are ignored; @item sections can be started by lines of the form @code{[ SECTION-NAME ]}; @item variable assignments can be performed by lines of the form @code{VARIABLE-NAME = VALUE}. Any variable assignment is local to a section. Assignments that occur before the first section declaration are relative to section [environment]. Section and variable names are case sensitive. Furthermore, each time a value starts with @code{"file:"}, the contents of the file are used instead. @end itemize @noindent Default search path for @file{polyorb.conf} is current directory. Environment variable @code{POLYORB_CONF} may be used to set up information on configuration file. PolyORB's configuration file allows the user to @enumerate @item enable/disable the output of debug information @item set up default reference on naming service @item select the default protocol personality @item set up each protocol personality @end enumerate @noindent The configuration file is read once when running a node, during initialization. Look in the sample configuration file @file{src/polyorb.conf} to see the available sections and variables. @c ------------------------------------------------------------------- @node Using environment variables @subsection Using environment variables @c ------------------------------------------------------------------- @noindent A variable @code{Var.Iable} in section @code{[Sec]} can be overridden by setting environment variable @code{"POLYORB_SEC_VAR_IABLE"}. @c ------------------------------------------------------------------- @node Using the command line @subsection Using the command line @c ------------------------------------------------------------------- @noindent PolyORB allows to set up configuration variables on the command line. The syntax is close to the one described in configuration files. A variable @code{Var.Iable} in section @code{[Sec]} can be overridden with flag @code{--polyorb---[=]}. @c ------------------------------------------------------------------- @node Using a source file @subsection Using a source file @c ------------------------------------------------------------------- @noindent Many embedded systems do not have a filesystem or a shell, so the previous run-time configuration methods cannot be used on these targets. On these platforms, a PolyORB node can also be configured using the API of package @code{PolyORB.Parameters.Static}. An example configuration file may be found in @file{examples/static/po_static_conf.ads}. An array of PolyORB parameters of type @code{Static_Parameters_Array} is first declared containing a list of pairs of Variable and Value strings. The syntax is close to the one described in configuration files. A variable @code{Var.Iable} in section @code{[Sec]} is specified as the pair of strings @code{"[sec]var.iable", ""}. There is no need to with this @file{po_static_conf.ads} in the application source code, the only requirement is that the array is exported with the external name "@code{__polyorbconf_optional}". This allows to modify PolyORB parameters without recompiling the application, just relinking it. For example: @smallexample $ gnatmake -c po_static_conf.ads `polyorb-config` $ gnatmake -b -l server.adb `polyorb-config` -largs po_static_conf.o @end smallexample Note the @code{-l} flag to gnatmake for linking only, and the need to specify to the linker the object file with the array using @code{-largs} if no package withs it. It should be noticed that this static array of parameters is read at elaboration time only, this API cannot be used to modify the PolyORB configuration at run-time. @c ------------------------------------------------------------------- @node Setting up protocol personalities @section Setting up protocol personalities @c ------------------------------------------------------------------- @noindent PolyORB allows the user to activate some of the available protocol personalities and to set up the preferred protocol. Protocol-specific parameters are defined in their respective sections. @menu * Activating/Deactivating protocol personalities:: * Configuring protocol personality preferences:: @end menu @c ------------------------------------------------------------------- @node Activating/Deactivating protocol personalities @subsection Activating/Deactivating protocol personalities @cindex Protocol personality, activation @c ------------------------------------------------------------------- @noindent Protocol activation is controlled by PolyORB's configuration file. The section @code{[access_points]} controls the initialization of @emph{access points}. An access point is a node entry point that may serve incoming requests. @smallexample [access_points] soap=enable iiop=enable diop=disable uipmc=disable @end smallexample @noindent This example activates SOAP and IIOP, but deactivates DIOP and MIOP. The section @code{[modules]} controls the activation/deactivation of some modules within PolyORB. It is used to enable @emph{bindings} to remote entities. @smallexample [modules] binding_data.soap=enable binding_data.iiop=enable binding_data.diop=disable binding_data.uipmc=disable @end smallexample @noindent This example enables the creation of bindings to remote objects using SOAP or IIOP. Objects cannot be reached using DIOP or UIPMC. @emph{Note: by default, all configured personalities are activated.} @c ------------------------------------------------------------------- @node Configuring protocol personality preferences @subsection Configuring protocol personality preferences @c ------------------------------------------------------------------- @noindent The user may affect a @emph{preference} to each protocol personality. The protocol with the higher preference will be selected among possible protocols to send a request to a remote node. See @code{polyorb.binding_data..preference} in section @code{[protocol]} to set up protocol's preference. Possible protocols are defined as the protocols available on the remote node, as advertised in its @emph{object reference}. @code{IOR} or @code{corbaloc} references may support multiple protocols; @code{URI} references support only one protocol. Each protocol supports a variety of configuration parameters, please refer to the protocols' sections for more details. @c ------------------------------------------------------------------- @node Activating debugging traces @section Activating debugging traces @cindex Debugging traces @c ------------------------------------------------------------------- @noindent To activate the output of debug information, you must first configure and compile PolyORB with debugging traces activated (which is the default, unless your build is configured with @command{--enable-debug-policy=ignore}). To output debugging traces on a selected package, create a configuration file with a @code{[log]} section and the name of the packages for which you want debug information: @smallexample # Sample configuration file, output debug for PolyORB.A_Package [log] polyorb.a_package=debug @end smallexample Note that some packages may not provide such information. See the sample configuration file @file{src/polyorb.conf} for the complete list of packages that provide traces. A default logging level may be specified using a line of the form @smallexample default= @end smallexample Time stamps may optionally be prepended to every generated trace. This is enabled using: @smallexample timestamp=true @end smallexample @c ------------------------------------------------------------------- @node Tracing exceptions @section Tracing exceptions @cindex Exceptions @c ------------------------------------------------------------------- @noindent To trace exception propagation in PolyORB's source code, activate debugging traces for package @code{PolyORB.Exceptions}. @c ------------------------------------------------------------------- @node polyorb.gpr @section @command{polyorb.gpr} @cindex @command{polyorb.gpr} @c ------------------------------------------------------------------- @noindent This section describes how to build your program using project files. An alternative method, using @command{polyorb-config}, is described in the following section. @command{polyorb-config} is intended primarily for Unix-like systems. The project-file method will work on all supported systems. To build your application, create a project file as usual. Import the @command{polyorb.gpr} project by putting @code{with "polyorb";} in your project file. Set the ADA_PROJECT_PATH environment variable to point to the directory containing @command{polyorb.cfg}, which is @command{/lib/gnat}. If SOAP is being used, ADA_PROJECT_PATH must also be set so we can find @command{xmlada.gpr}. If your project file is @command{my_proj.gpr}, you can build it by saying: @smallexample $ gnatmake -P my_proj @end smallexample See the GNAT User's Guide and the GNAT Reference Manual for more information on project files. @c ------------------------------------------------------------------- @node polyorb-config @section @command{polyorb-config} @cindex @command{polyorb-config} @c ------------------------------------------------------------------- @noindent @command{polyorb-config} returns path and library information on PolyORB's installation. It can be used on the @command{gnatmake} command line, like this: @smallexample $ gnatmake my_program.adb `polyorb-config` @end smallexample @smallexample @c XXX check consistency with corresponding man page NAME polyorb-config - script to get information about the installed version of PolyORB. SYNOPSIS polyorb-config [--prefix[=DIR]] [--exec-prefix[=DIR]] [--version|-v] [--config] [--libs] [--cflags] [--idls] [--help] DESCRIPTION polyorb-config is a tool that is used to determine the compiler and linker flags that should be used to compile and link programs that use PolyORB. OPTIONS polyorb-config accepts the following options: --prefix[=DIR] Output the directory in which PolyORB architecture-independent files are installed, or set this directory to DIR. --exec-prefix[=DIR] Output the directory in which PolyORB architecture-dependent files are installed, or set this directory to DIR. --version Print the currently installed version of PolyORB on the stan- dard output. --config Print the configuration of the currently installed version of PolyORB on the standard output. --libs Print the linker flags that are necessary to link a PolyORB program. --cflags Print the compiler flags that are necessary to compile a Poly- ORB program. --idls Output flags to set up path to CORBA's IDL for idlac. --with-appli-perso=P,P,P Restrict output to only those flags relevant to the listed applicative personalities. --with-proto-perso=P,P,P Restrict output to only those flags relevant to the listed protocol personalities. --with-corba-services=S,S,S Restrict output to only those flags relevant to the listed services. --help Print help message. @end smallexample @c ------------------------------------------------------------------- @node Tasking model in PolyORB @chapter Tasking model in PolyORB @cindex Tasking model @c ------------------------------------------------------------------- @menu * PolyORB Tasking runtimes:: * PolyORB ORB Tasking policies:: * PolyORB Tasking configuration:: * PolyORB ORB Controller policies:: * PolyORB ORB Controller configuration:: @end menu @c ------------------------------------------------------------------- @node PolyORB Tasking runtimes @section PolyORB Tasking runtimes @cindex Tasking runtime @c ------------------------------------------------------------------- @noindent PolyORB may use any of three different tasking runtimes to manage and synchronize tasks, if any. Tasking runtime capabilities are defined in the Ada Reference Manual @cite{[ISO06]}. The choice of a specific tasking runtime is a compile-time parameter, @ref{Tasking runtimes} for more details on their configuration. @c ------------------------------------------------------------------- @subsection Full tasking runtime @c ------------------------------------------------------------------- @noindent Full tasking runtime refers to the configuration in which there are dependencies on the tasking constructs defined in chapter 9 of @cite{[ISO06]}. It makes use of all capabilities defined in this section to manage and synchronize tasks. In this configuration, a PolyORB application must be compiled and linked with a tasking-capable Ada runtime. @c ------------------------------------------------------------------- @subsection No tasking runtime @c ------------------------------------------------------------------- @noindent No tasking runtime refers to the configuration in which there is no dependency on tasking constructs. Thus, no tasking is required. In this configuration, a PolyORB application may be compiled and linked with a tasking-capable Ada runtime or a no-tasking Ada runtime. @c ------------------------------------------------------------------- @subsection Ravenscar tasking runtime @cindex Ravenscar @c ------------------------------------------------------------------- @noindent Ravenscar tasking runtime refers to the configuration in which tasking constructs are compliant with the @emph{Ravenscar tasking restricted profile}. In this configuration, a PolyORB application may be compiled and linked with a tasking-capable Ada runtime or a Ravenscar Ada runtime. To configure tasking constructs used by PolyORB, one must instantiate the @code{PolyORB.Setup.Tasking.Ravenscar} generic package shown below to set up tasks and protected objects used by PolyORB core. @include polyorb-setup-tasking-ravenscar.ads.texi @c ------------------------------------------------------------------- @node PolyORB ORB Tasking policies @section PolyORB ORB Tasking policies @c ------------------------------------------------------------------- PolyORB ORB Tasking policies control the creation of tasks to process all middleware internal jobs, e.g. request processing, I/O monitoring. @noindent @i{Note: there is a dependency between ORB Tasking policies, and the runtime used, as detailed below.} @c ------------------------------------------------------------------- @subsection No Tasking @c ------------------------------------------------------------------- Under the No Tasking ORB policy, no tasks are created within the middleware instance: it uses the environment task to process all jobs. Note that this policy is not thread safe and is compatible with the No tasking runtime only. @c ------------------------------------------------------------------- @subsection Thread Pool @c ------------------------------------------------------------------- Under the Thread Pool ORB policy, the middleware creates a pool of threads during initialization of PolyORB. This pool processes all jobs. The number of tasks in the thread pool can be configured by three parameters in the @code{[tasking]} configuration section. @itemize @bullet @item @code{min_spare_threads} indicates the number of tasks created at startup. @item @code{max_spare_threads} is a ceiling. When a remote subprogram call is completed, its anonymous task is deallocated if the number of unused tasks already in the pool is greater than the ceiling. If not, then the task is queued in the pool. @item @code{max_threads} indicates the maximum number of tasks in the pool. @end itemize @xref{PolyORB Tasking configuration}, for more information on how to configure the number of tasks in the thread pool. @c ------------------------------------------------------------------- @subsection Thread Per Session @c ------------------------------------------------------------------- Under the Thread Per Session ORB policy, the middleware creates one task when a new session (one active connection) is opened. The task terminates when the session is closed. @c ------------------------------------------------------------------- @subsection Thread Per Request @c ------------------------------------------------------------------- Under the Thread Per Request ORB policy, the middleware creates one task per incoming request. The task terminates when the request is completed. @c ------------------------------------------------------------------- @node PolyORB Tasking configuration @section PolyORB Tasking configuration @c ------------------------------------------------------------------- @noindent The following parameters allow the user to set up some of the tasking parameters. @c check consistency with polyorb.conf @smallexample ############################################################################### # Parameters for tasking # [tasking] # Default storage size for all threads spawned by PolyORB #storage_size=262144 # Number of threads by Thread Pool tasking policy #min_spare_threads=4 #max_spare_threads=4 #max_threads=4 @end smallexample @c ------------------------------------------------------------------- @node PolyORB ORB Controller policies @section PolyORB ORB Controller policies @c ------------------------------------------------------------------- The PolyORB ORB Controller policies are responsible for the management of the global state of the middleware: they assign middleware internal jobs, or I/Os monitoring to middleware tasks. ORB Controller policies grant access to middleware internals and affect one action for each middleware task. They ensure that all tasks work concurrently in a thread-safe manner. @c ------------------------------------------------------------------- @subsection No Tasking @c ------------------------------------------------------------------- The No Tasking ORB Controller policy is dedicated to no-tasking middleware configurations; the middleware task executes the following loop: process internal jobs, then monitor I/Os. @c ------------------------------------------------------------------- @subsection Workers @c ------------------------------------------------------------------- The Workers ORB Controller policy is a simple controller policy: all tasks are equal, they may alternatively and randomly process requests or wait for I/O sources. @i{Note: this is the default configuration provided by PolyORB sample setup files, @xref{Sample files}.} @c ------------------------------------------------------------------- @subsection Half Sync/Half Async @c ------------------------------------------------------------------- The Half Sync/Half Async ORB Controller policy implements the ``Half Sync/Half Async'' design pattern: it discriminates between one thread dedicated to I/O monitoring that queue middleware jobs; another pool of threads dequeue jobs and process them. @i{Note: this pattern is well-suited to process computation-intensive requests.} @c ------------------------------------------------------------------- @subsection Leader/Followers @c ------------------------------------------------------------------- The Leader/Followers ORB Controller policy implements the ``Leader/Followers '' design pattern: multiple tasks take turns to monitor I/O sources and then process requests that occur on the event sources. @i{Note: this pattern is adapted to process a lot of light requests.} @c ------------------------------------------------------------------- @node PolyORB ORB Controller configuration @section PolyORB ORB Controller configuration @c ------------------------------------------------------------------- @noindent The following parameters allow the user to set up parameters for ORB Controllers. @c check consistency with polyorb.conf @smallexample ############################################################################### # Parameters for ORB Controllers # [orb_controller] # Interval between two polling actions on one monitor #polyorb.orb_controller.polling_interval=0 # Timeout when polling on one monitor #polyorb.orb_controller.polling_timeout=0 @end smallexample @c ------------------------------------------------------------------- @node CORBA @chapter CORBA @cindex CORBA @c ------------------------------------------------------------------- @menu * What you should know before Reading this section:: * Installing CORBA application personality:: * IDL-to-Ada compiler:: * Resolving names in a CORBA application:: * The CORBA Interface Repository:: * Building a CORBA application with PolyORB:: * Configuring a CORBA application:: * Implementation Notes:: * PolyORB specific APIs:: @end menu @c ------------------------------------------------------------------- @node What you should know before Reading this section @section What you should know before Reading this section @c ------------------------------------------------------------------- @noindent This section assumes that the reader is familiar with the CORBA specifications described in @cite{[OMG04]} and the @emph{IDL-to-Ada} mapping defined in @cite{[OMG01]}. @c ------------------------------------------------------------------- @node Installing CORBA application personality @section Installing CORBA application personality @c ------------------------------------------------------------------- @noindent Ensure PolyORB has been configured and then compiled with the CORBA application personality. See @ref{Building an application with PolyORB} for more details on how to check installed personalities. To build the CORBA application personality, @pxref{Installation}. @c ------------------------------------------------------------------- @node IDL-to-Ada compiler @section IDL-to-Ada compiler @c ------------------------------------------------------------------- @noindent PolyORB provides two IDL-to-Ada compilers: @enumerate @item @command{iac} is the new, optimized PolyORB IDL-to-Ada compiler. @item @command{idlac} is the legacy PolyORB IDL-to-Ada compiler, @end enumerate @menu * Usage of iac:: * Usage of idlac:: * Difference between idlac and iac:: @end menu @c ------------------------------------------------------------------- @node Usage of iac @subsection Usage of @command{iac} @cindex @command{iac} @c ------------------------------------------------------------------- @noindent @command{iac} is PolyORB's new IDL-to-Ada compiler. It supports many command line parameters to control code generation optimizations such as use of static hashing for deterministic request dispatching, and optimized GIOP marshalling for CORBA applications. @smallexample @c XXX check consistency with corresponding man page NAME iac - PolyORB's IDL-to-Ada compiler SYNOPSIS iac [options] file [-cppargs args...] DESCRIPTION iac is an IDL-to-Ada compiler, compliant with version 1.2 of the ``Ada Language Mapping Specification'' produced by the OMG. OPTIONS iac accepts the following options: @c The following needs to be kept in sync with the usage message printed @c by 'iac -h'. -h Print this help message, and do nothing else file is the name of the .idl file (.idl suffix optional) -E Preprocess only -k Keep temporary files -o DIR Output directory (DIR must exist) -p Produce source on standard output -q Quiet mode -dm Generate debug messages when analyzing scopes -df Dump the frontend tree (the IDL tree) -cppargs Pass arguments to the C++ preprocessor -I Shortcut -cppargs -I directory. Use this flag for the imported entities -nocpp Do not preprocess input -gnatW8 Use UTF-8 character encoding in Ada output. (Default is Latin-1.) - Generate code for one of the following languages: types Generate a list of all types present in the IDL file -p Print the list generated ada (default) Generate Ada source code -i Generate implementation packages -c Generate code for client side only -s Generate code for server side only -d Generate delegation package (defunct) -ir Generate code for interface repository -noir Do not generate code for interface repository (default) -hc Minimize CPU time in perfect hash tables in skels -hm Minimize memory use in perfect hash tables in skels This is the default. -rs Use the SII/SSI to handle requests -rd Use the DII/DSI to handle requests (default) -da Dump the Ada tree -db Generate only the package bodies -ds Generate only the package specs -dw Output the withed entities -dt Output tree warnings -di Generate code for imported entities idl Dump parsed IDL file -b n Base to output integer literals As a default (zero) use base from input -e Expand IDL Tree -df Dump IDL Tree (may be used in conjunction with -e to dump the expanded IDL tree) -di Output IDL code of imported entities (may be used in conjunction with -e to output the expanded IDL code) EXIT STATUS iac returns one of the following values upon exit: 0 Successful completion 1 Usage error 2 Illegal IDL specification @end smallexample @noindent @command{iac} creates several files : @itemize @bullet @item @code{myinterface.ads}, @code{myinterface.adb} : these files contain the mapping for user defined types (client and server side). @item @code{myinterface-impl.ads}, @code{myinterface-impl.adb} : these files are to be filled in by the user. They contain the implementation of the server. They are generated only if the -i flag is specified. @item @code{myinterface.ads}, @code{myinterface.adb} : these files contain the client stubs for the interface. @item @code{myinterface-skel.ads}, @code{myinterface-skel.adb} : these files contain the server-side skeletons for the interface. @item @code{myinterface-helper.ads}, @code{myinterface-helper.adb} : these files contain subprograms to marshal data into CORBA Any containers. @item @code{myinterface-ir_info.ads}, @code{myinterface-ir_info.adb} : these files contain code for registering IDL definitions in the CORBA Interface Repository. They are generated only if the @code{'-ir'} flag is specified. @item @code{myinterface-cdr.ads}, @code{myinterface-cdr.adb} : these files contain code for optimized CDR marshalling of GIOP messages. They are generated only if the @code{'-rs'} flag is specified. @end itemize @c ------------------------------------------------------------------- @node Usage of idlac @subsection Usage of @command{idlac} @cindex @command{idlac} @c ------------------------------------------------------------------- @noindent @command{idlac} is PolyORB's IDL-to-Ada compiler. @smallexample @c XXX check consistency with corresponding man page NAME idlac - PolyORB's IDL-to-Ada compiler SYNOPSIS idlac [-Edikpqv] [-[no]ir] [-gnatW8] [-o DIR] idl_file [-cppargs ...] DESCRIPTION idlac is an IDL-to-Ada compiler, compliant with version 1.2 of the ``Ada Language Mapping Specification'' produced by the OMG. OPTIONS idlac accepts the following options: -E Preprocess only. -d Generate delegation package. -i Generate implementation template. -s Generate server side code. -c Generate client side code. -k Keep temporary files. -p Produce source on standard output. -q Be quiet (default). -v Be verbose. -ir Generate code for interface repository. -noir Don't generate code for interface repository (default). -gnatW8 Use UTF8 character encoding -o DIR Specify output directory -cppargs ARGS Pass ARGS to the C++ preprocessor. -I dir Shortcut for -cppargs -I dir. EXIT STATUS idlac returns one of the following values upon exit: 0 Successful completion 1 Usage error 2 Illegal IDL specification @end smallexample @noindent @command{idlac} creates several files : @itemize @bullet @item @code{myinterface.ads}, @code{myinterface.adb} : these files contain the mapping for user defined types (client and server side). @item @code{myinterface-impl.ads}, @code{myinterface-impl.adb} : these files are to be filled in by the user. They contain the implementation of the server. They are generated only if the -i flag is specified. @item @code{myinterface.ads}, @code{myinterface.adb} : these files contain the client stubs for the interface. @item @code{myinterface-skel.ads}, @code{myinterface-skel.adb} : these files contain the server-side skeletons for the interface. @item @code{myinterface-helper.ads}, @code{myinterface-helper.adb} : these files contain subprograms to marshal data into CORBA Any containers. @item @code{myinterface-ir_info.ads}, @code{myinterface-ir_info.adb} : these files contain code for registering IDL definitions in the CORBA Interface Repository. They are generated only if the @code{'-ir'} flag is specified. @end itemize @c ------------------------------------------------------------------- @node Difference between idlac and iac @subsection Difference between idlac and iac @c ------------------------------------------------------------------- @noindent This section lists the main differences between @command{idlac} and @command{iac} @itemize @item @command{iac} is backward compatible with @command{idlac}, but lacks the following feature: @enumerate @item generation of delegation files. @end enumerate @end itemize @command{iac} implements additional name clash resolution rules. When the name of an IDL operation clashes with a primitive operation of Ada.Finalization.Controlled (of which CORBA.Object.Ref is a derived type), it is prefixed with "IDL_" in generated sources. @c ------------------------------------------------------------------- @node Resolving names in a CORBA application @section Resolving names in a CORBA application @c ------------------------------------------------------------------- @noindent PolyORB implements the CORBA COS Naming service. @menu * po_cos_naming:: * Registering the reference to the COS Naming server:: * Using the COS Naming:: @end menu @c ------------------------------------------------------------------- @node po_cos_naming @subsection @command{po_cos_naming} @cindex @command{po_cos_naming} @cindex @command{CORBA COS Naming} @c ------------------------------------------------------------------- @noindent @command{po_cos_naming} is a standalone server that supports the CORBA COS Naming specification. When launched, it returns its @code{IOR} and @code{corbaloc}, which can then be used by other CORBA applications. If you want @command{po_cos_naming} to return the same @code{IOR} or @code{corbaloc} at each startup, you must set a default listen port for the protocol personalities you use. See @ref{Configuring protocol personality preferences} for more details. @command{po_cos_naming} can output its @code{IOR} directly to a file using the @command{-file } flag. This, in conjonction with the @command{'file://'} naming scheme provided by @command{CORBA}, provides a convenient way to store initial references to the Naming Service. @smallexample Usage: po_cos_naming -file : output COS Naming IOR to 'filename' -help : print this help [PolyORB command line configuration variables] @end smallexample @c ------------------------------------------------------------------- @node Registering the reference to the COS Naming server @subsection Registering the reference to the COS Naming server @c ------------------------------------------------------------------- @noindent You have two ways to register the reference to the root context of the COS Naming server the application will use: @itemize @bullet @item Setting up the @code{name_service} entry in the @code{[corba]} section in your configuration file, @code{name_service} is the @code{IOR} or @code{corbaloc} of the COS Naming server to use. See @ref{Using a configuration file} for more details. @item Registering an initial reference using the @code{-ORBInitRef NamingService=} or @code{-ORBInitRef NamingService=} command-line argument. See the CORBA specifications for more details. @item Registering an initial reference for @code{NamingService} using the @code{CORBA.ORB.Register_Initial_Reference} function. See the CORBA specifications for more details. @end itemize @c ------------------------------------------------------------------- @node Using the COS Naming @subsection Using the COS Naming @c ------------------------------------------------------------------- @noindent PolyORB provides a helper package to manipulate the COS Naming in your applications. See @ref{PolyORB specific APIs} for more details. @c ------------------------------------------------------------------- @node The CORBA Interface Repository @section The CORBA Interface Repository @c ------------------------------------------------------------------- @noindent PolyORB implements the CORBA Interface Repository. @menu * po_ir:: * Using the Interface Repository:: @end menu @c ------------------------------------------------------------------- @node po_ir @subsection @command{po_ir} @cindex @command{po_ir} @c ------------------------------------------------------------------- @noindent @command{po_ir} is a standalone server that supports the CORBA Interface Repository. When launched, it returns its @code{IOR} and @code{corbaloc}, which can then be used by other CORBA applications. If you want @command{po_ir} to return the same @code{IOR} or @code{corbaloc} at each startup, you must set a default listen port for the protocol personalities you use. See @ref{Configuring protocol personality preferences} for more details. @c ------------------------------------------------------------------- @node Using the Interface Repository @subsection Using the Interface Repository @c ------------------------------------------------------------------- @noindent The IDL-to-Ada compiler generates a helper package that allows you to register all entities defined in your IDL specification in the Interface Repository. @c ------------------------------------------------------------------- @node Building a CORBA application with PolyORB @section Building a CORBA application with PolyORB @c ------------------------------------------------------------------- @menu * echo example:: * Other examples:: @end menu @c ------------------------------------------------------------------- @node echo example @subsection @code{echo} example @c ------------------------------------------------------------------- @noindent We consider building a simple ``Echo'' CORBA server and client. This application echoes a string. The source code for this example is located in the @file{examples/corba/echo} directory in the PolyORB distribution. This applications uses only basic elements of CORBA. To build this application, you need the following pieces of code: @enumerate @item IDL definition of an @code{echo} object @item Implementation code for the @code{echo} object @item Code for client and server nodes @end enumerate @c ------------------------------------------------------------------- @subsubsection IDL definition of an @code{echo} object @c ------------------------------------------------------------------- @noindent This interface defines an @code{echo} object with a unique method @code{echoString}. Per construction, this method returns its argument. @include echo.idl.texi @c ------------------------------------------------------------------- @subsubsection Implementation code for the @code{echo} object @c ------------------------------------------------------------------- @noindent Package @code{Echo.Impl} is an implementation of this interface. This implementation follows the @emph{IDL-to-Ada} mapping. @include echo-impl.ads.texi @include echo-impl.adb.texi @noindent @i{Note: @code{Echo.Impl} body requires a dependency on @code{Echo.Skel} to ensure the elaboration of skeleton code and the correct setup of PolyORB's internals.} @c ------------------------------------------------------------------- @subsubsection Test code for client and server nodes @c ------------------------------------------------------------------- @noindent Client and server code demonstrate how to make a remote invocation on a CORBA object, and how to set up an object on a server node. @emph{Note: the dependency on @code{PolyORB.Setup.Client} or @code{PolyORB.Setup.No_Tasking_Server} enforces compile-time configuration, @pxref{Sample files}.} @itemize @bullet @item Client code tests a simple remote invocation on an object. It is a no-tasking client. A reference to the object is built from a stringified reference (or @code{IOR}), which is passed on command line. @include client.adb.texi @item The server code sets up a no-tasking node. The object is registered to the @code{RootPOA}. Then an @code{IOR} reference is built to enable interaction with other nodes. @include server.adb.texi @end itemize @c ------------------------------------------------------------------- @subsubsection Compilation and execution @c ------------------------------------------------------------------- @noindent To compile this demo, @enumerate @item Process the IDL file with @command{idlac} (or @command{iac}) @smallexample $ idlac echo.idl @end smallexample @item Compile the client node @smallexample $ gnatmake client.adb `polyorb-config` @end smallexample @item Compile the server node @smallexample $ gnatmake server.adb `polyorb-config` @end smallexample @end enumerate @noindent Note the use of backticks (`). This means that @command{polyorb-config} is first executed, and then the command line is replaced with the output of the script, setting up library and include paths and library names. To run this demo: @itemize @bullet @item run @file{server}, the server outputs its IOR, a hexadecimal string with the IOR: prefix: @smallexample $ ./server Loading configuration from polyorb.conf No polyorb.conf configuration file. 'IOR:01534f410d00000049444c3[..]' @end smallexample @item In another shell, run @file{client}, passing cut-and-pasting the complete IOR on the command line: @smallexample $ ./client 'IOR:01534f410d00000049444c3[..]' Echoing string: " Hello Ada ! " I said : Hello Ada ! The object answered : Hello Ada ! @end smallexample @end itemize @c ------------------------------------------------------------------- @node Other examples @subsection Other examples @c ------------------------------------------------------------------- @noindent PolyORB provides other examples to test other CORBA features. These examples are located in the @file{example/corba} directory in the PolyORB distribution. @itemize @bullet @item @file{all_functions} tests CORBA parameter passing modes (@code{in}, @code{out}, ..); @item @file{all_types} tests CORBA types; @item @file{echo} is a simple CORBA demo; @item @file{random} is a random number generator; @item @file{send} tests MIOP specific API. @end itemize @c ------------------------------------------------------------------- @node Configuring a CORBA application @section Configuring a CORBA application @cindex Configuration, CORBA @c ------------------------------------------------------------------- @menu * Configuring PolyORB:: * Configuring GIOP protocol stack for PolyORB:: * Configuring Security services for PolyORB:: * Command line arguments:: @end menu @noindent To configure a CORBA application, you need to separately configure PolyORB and the GIOP protocol (or any other protocol personality you wish to use). @c ------------------------------------------------------------------- @node Configuring PolyORB @subsection Configuring PolyORB @c ------------------------------------------------------------------- @noindent Please refer to @ref{Building an application with PolyORB} for more information on PolyORB's configuration. @c ------------------------------------------------------------------- @node Configuring GIOP protocol stack for PolyORB @subsection Configuring GIOP protocol stack for PolyORB @c ------------------------------------------------------------------- @noindent The GIOP protocol is separated from the CORBA application personality. See @ref{Configuring the GIOP personality} for more information on GIOP's configuration. @c ------------------------------------------------------------------- @node Configuring Security services for PolyORB @subsection Configuring Security services for PolyORB @c ------------------------------------------------------------------- @noindent PolyORB provides support for some elements of the CORBA Security mechanisms. This sections lists the corresponding configuration parameters. @subsubsection Supported mechasnisms @noindent PolyORB provides support for the following security mechanisms: @enumerate @item SSL/TLS protected transport; @item GSSUP (user/password) authentication mechanism; @item identity assertion and backward trust evaluation. @end enumerate @subsubsection Compile-time configuration To enable security support, applications must `with' one of the predefined setup packages: @enumerate @item @code{PolyORB.Setup.Secure_Client} - for client side support only; @item @code{PolyORB.Setup.Secure_Server} - for both client and server side support. @end enumerate @subsubsection Run-time configuration @enumerate @item Capsule configuration This section details the configuration parameters for capsule configuration. @smallexample [security_manager] # List of sections for configure client's credentials #own_credentials=my_credentials # # Client requires integrity proteced messages #integrity_required=true # # Client requires confiodentiality protected messages #confidentiality_required=true # # Client requires security association to detect replay (not supported for now) #detect_replay_required=true # # Client requires security association to detect message sequence errors (not # supported for now) #detect_misordering_required=true # # Client requires target authentication #establish_trust_in_target_required=true # # Client requires client authentication (usually not applicable at all) #establish_trust_in_client_required=true # # (rare useful) #identity_assertion_required=true # # (rare useful) #delegation_by_client_required=true @end smallexample @item Credentials configuration This section details configuration parameters for defining a program's credentials. Depending on the mechanisms used for the transport and authentication layers, the credentials configuration section may define configuration only for one transport mechanism and/or one authentication mechanism. @smallexample #[my_credentials] # # TLS protected transport mechanism used as transport mechanism #transport_credentials_type=tls # # Connection method. Available methods: tls1, ssl3, ssl2 #tls.method=tls1 # # Certificate file name #tls.certificate_file=my.crt # # Certificate chain file name #tls.certificate_chain_file= # # Private key file name #tls.private_key_file=my.key # # Name of file, at which CA certificates for verification purposes are #located #tls.certificate_authority_file=root.crt # # Name of directory, at which CA certificates for verification #purposes are # located #tls.certificate_authority_path= # # List of available ciphers #tls.ciphers=ALL # # Verify peer certificate #tls.verify_peer=true # # Fail if client don't provide ceritificate (server only) #tls.verify_fail_if_no_peer_certificate=true # # GSSUP (user/password) mechanism as authentication mechanism #authentication_credentials_type=gssup # # User name #gssup.username=username@@domain # # User password #gssup.password=password # # Target name for which user/password pair is applicable #gssup.target_name=@@domain @end smallexample @item POA configuration This section details configuration parameters for defining security characteristics of objects managed by POA. The POA's name is used as the section name. @smallexample #[MySecurePOA] # # Unprotected invocations is allowed #unprotected_invocation_allowed=true # # Section name for configuration of used protected transport mechanism #(if any) #transport_mechanism=tlsiop # # Section name for configuration of used authentication mechanism (if #any) #authentication_mechanism=my_gssup # # Target require client authentication at authentication layer (in #addition # to authentication at transport layer) #authentication_required=true # # Name of file for backward trust evalutation rules #backward_trust_rules_file=file.btr # # Section name for configuration of authorization tokens authority #privilege_authorities= @end smallexample @item TLS protected transport mechanism configuration This section details configuration parameters for the TLS protected transport mechanism. The section name for mechanism configuration is defined in the POA configuration. @smallexample [tlsiop] # List of access points #addresses=127.0.0.1:3456 @end smallexample @item GSSUP authentication mechanism This section details configuration parameters for the GSSUP authentication mechanism. The section name for mechanism configuration is defined in the POA configuration. @smallexample #[my_gssup] # # Authentication mechanism #mechanism=gssup # # Target name #gssup.target_name=@@domain # # User name/password mapping file #gssup.passwd_file=passwd.pwd @end smallexample @end enumerate @c ------------------------------------------------------------------- @node Command line arguments @subsection Command line arguments @c ------------------------------------------------------------------- @noindent The CORBA specifications define a mechanism to pass command line arguments to your application, using the @code{CORBA::ORB:Init} method. For now, PolyORB supports the following list of arguments: @itemize @bullet @item @code{InitRef} to pass initial reference. @end itemize @c ------------------------------------------------------------------- @node Implementation Notes @section Implementation Notes @c ------------------------------------------------------------------- @menu * Tasking:: * Implementation of CORBA specifications:: * Additions to the CORBA specifications:: * Interface repository:: * Policy Domain Managers:: * Mapping of exceptions:: * Additional information to CORBA_Unknown:: * Internals packages:: @end menu @noindent PolyORB strives to support CORBA specifications as closely as possible. However, on rare occasions, the implementation adapts the specifications to actually enable its completion. This section provides information on the various modifications we made. @c ------------------------------------------------------------------- @node Tasking @subsection Tasking @c ------------------------------------------------------------------- @noindent PolyORB provides support for tasking and no-tasking, using configuration parameters. Please refer to @ref{Building an application with PolyORB} for more information on PolyORB's configuration. When selecting a tasking-capable runtime, ORB-related functions are thread safe, following the IDL-to-Ada mapping recommendations. @c ------------------------------------------------------------------- @node Implementation of CORBA specifications @subsection Implementation of CORBA specifications @c ------------------------------------------------------------------- @noindent In some cases, the CORBA specifications do not describe the semantics of the interface in sufficient detail. We add an @code{Implementation Notes} tag to the package specification to indicate the modifications or enhancements we made to the standard. In some cases, the IDL-to-Ada mapping specifications and the CORBA specifications conflict. We add an @code{Implementation Notes} tag to the package specification to indicate this issue. Whenever possible, PolyORB follows the CORBA specifications. @c ------------------------------------------------------------------- @node Additions to the CORBA specifications @subsection Additions to the CORBA specifications @c ------------------------------------------------------------------- @noindent In some cases, the specifications lack features that may be useful. We add an @code{Implementation Notes} tag to the package specification to detail the additions we made to the standard. In addition to the above, PolyORB follows some of the recommendations derived from the OMG Issues for Ada 2003 Revision Task Force mailing list (see @url{http://www.omg.org/issues/ada-rtf.html} for more information). @c ------------------------------------------------------------------- @node Interface repository @subsection Interface repository @c ------------------------------------------------------------------- @noindent @i{The documentation of the PolyORB's CORBA Interface Repository will appear in a future revision of PolyORB.} @c ------------------------------------------------------------------- @node Policy Domain Managers @subsection Policy Domain Managers @c ------------------------------------------------------------------- @noindent You have two ways to register the reference to the CORBA Policy Domain Manager the application will use: @itemize @bullet @item Setting up the @code{policy_domain_manager} entry in the @code{[corba]} section in your configuration file, @code{policy_domain_manager} is the @code{IOR} or @code{corbaloc} of the COS Naming server to use. See @ref{Using a configuration file} for more details. @item Registering an initial reference using the @code{-ORB InitRef PolyORBPolicyDomainManager=} or @code{-ORB InitRef PolyORBPolicyDomainManager=} command-line argument. See the CORBA specifications for more details. @item Registering an initial reference for @code{PolyORBPolicyDomainManager} using the @code{CORBA.ORB.Register_Initial_Reference} function. See the CORBA specifications for more details. @end itemize @c ------------------------------------------------------------------- @node Mapping of exceptions @subsection Mapping of exceptions @c ------------------------------------------------------------------- @noindent For each exception defined in the CORBA specifications, PolyORB provides the @code{Raise_} function, a utility function that raises the exception @code{}, along with its exception member. PolyORB also defines the @code{Get_Members} function (as defined in the IDL-to-Ada mapping) to provide accessors to retrieve information on the exception. In addition, for each exception defined in a user-defined IDL specification, the IDL-to-Ada compiler will generate a @code{Raise_} function in the Helper package. It is a utility function that raises the exception @code{}, along with its exception member. @c ------------------------------------------------------------------- @node Additional information to CORBA_Unknown @subsection Additional information to @code{CORBA::Unknown} @c ------------------------------------------------------------------- @cindex @code{CORBA::Unknown} @cindex CORBA, Server-side exception @noindent When a CORBA application raises an Ada exception that is not part of the IDL specifications, nor defined by the CORBA specifications, then this exception is translated into a @code{CORBA::UNKNOWN} exception. To help debugging CORBA applications, PolyORB supports a specific service context to the GIOP protocol personality that conveys exception information. When displaying exception information, server-side specific exception information is delimited by @i{``''} Here is an example from the @code{all_types} example provided by PolyORB. @smallexample Exception name: CORBA.UNKNOWN Message: 4F4D0001M Call stack traceback locations: 0x81d0425 0x81d0554 0x81d6d8c 0x81fd02b 0x81fc091 0x82eea12 0x83e4c22 0x807b69a 0xb7a15e3e @end smallexample Note that call stack tracebacks can be translated into symbolic form using the @code{addr2line} utility that comes with GNAT. @c ------------------------------------------------------------------- @node Internals packages @subsection Internals packages @c ------------------------------------------------------------------- @noindent PolyORB sometimes declares internal types and routines inside CORBA packages. These entities are gathered into an @code{Internals} child package. You should not use these functions: they are not portable, and may be changed in future releases. @c ------------------------------------------------------------------- @node PolyORB specific APIs @section PolyORB's specific APIs @c ------------------------------------------------------------------- @menu * PolyORB.CORBA_P.CORBALOC:: * PolyORB.CORBA_P.Naming_Tools:: * PolyORB.CORBA_P.Server_Tools:: @end menu @noindent PolyORB defines packages to help in the development of CORBA programs. @itemize @bullet @item @ref{PolyORB.CORBA_P.CORBALOC}: This package defines a helper function to build a @code{corbaloc} stringified reference from a CORBA object reference. @item @ref{PolyORB.CORBA_P.Naming_Tools}: This package defines helper functions to ease interaction with CORBA COS Naming. @item @ref{PolyORB.CORBA_P.Server_Tools}: This package defines helper functions to ease set up of a simple CORBA Server. @end itemize @page @node PolyORB.CORBA_P.CORBALOC @subsection @code{PolyORB.CORBA_P.CORBALOC} @cindex @code{PolyORB.CORBA_P.CORBALOC} @include polyorb-corba_p-corbaloc.ads.texi @page @node PolyORB.CORBA_P.Naming_Tools @subsection @code{PolyORB.CORBA_P.Naming_Tools} @cindex @code{PolyORB.CORBA_P.Naming_Tools} @include polyorb-corba_p-naming_tools.ads.texi @page @node PolyORB.CORBA_P.Server_Tools @subsection @code{PolyORB.CORBA_P.Server_Tools} @cindex @code{PolyORB.CORBA_P.Server_Tools} @include polyorb-corba_p-server_tools.ads.texi @c ------------------------------------------------------------------- @node RT-CORBA @chapter RT-CORBA @cindex RT-CORBA @c ------------------------------------------------------------------- @menu * What you should know before Reading this section2:: * Installing RT-CORBA:: * Configuring RT-CORBA:: * RTCORBA.PriorityMapping:: * RTCosScheduling Service:: @end menu @c ------------------------------------------------------------------- @node What you should know before Reading this section2 @section What you should know before Reading this section @c ------------------------------------------------------------------- @noindent This section assumes that the reader is familiar with the Real-Time CORBA specifications described in @cite{[OMG02a]} and @cite{[OMG03]}. @c ------------------------------------------------------------------- @node Installing RT-CORBA @section Installing RT-CORBA @c ------------------------------------------------------------------- @noindent The RT-CORBA library is installed as part of the installation of the CORBA personality. Note that you may have to select specific run-time options to enable full compliance with RT-CORBA specifications and ensure real time behavior. @c XXX TO BE COMPLETED @c ------------------------------------------------------------------- @node Configuring RT-CORBA @section Configuring RT-CORBA @c ------------------------------------------------------------------- @menu * PolyORB.RTCORBA_P.Setup:: @end menu @noindent This section details how to configure your application to use the RT-CORBA library. @c ------------------------------------------------------------------- @node PolyORB.RTCORBA_P.Setup @subsection @code{PolyORB.RTCORBA_P.Setup} @cindex @code{PolyORB.RTCORBA_P.Setup} @c ------------------------------------------------------------------- @noindent The RT-CORBA specifications mandate that the implementation provide a mechanism to set up some of its internals. The package @code{PolyORB.RTCORBA_P.Setup} provides an API to set up the @code{PriorityMapping} and @code{PriorityTransform} objects. @include polyorb-rtcorba_p-setup.ads.texi @c ------------------------------------------------------------------- @node RTCORBA.PriorityMapping @section @code{RTCORBA.PriorityMapping} @cindex @code{RTCORBA.PriorityMapping} @c ------------------------------------------------------------------- @noindent PolyORB provides different implementations of this specification: @itemize @bullet @item @code{RTCORBA.PriorityMapping.Direct} maps CORBA priorities directly to native priorities. If the CORBA priority is not in @code{System.Priority'Range}, then the mapping is not possible. @item @code{RTCORBA.PriorityMapping.Linear} maps each individual native priority to a contiguous range of CORBA priorities, so that the complete CORBA priority range is used up for the mapping. See @file{rtcorba-prioritymapping-linear.adb} for more details. @end itemize @c ------------------------------------------------------------------- @node RTCosScheduling Service @section RTCosScheduling Service @cindex RTCosScheduling Service @c ------------------------------------------------------------------- @menu * Overview:: * ClientScheduler:: * ServerScheduler:: @end menu @c ------------------------------------------------------------------- @node Overview @subsection Overview @c ------------------------------------------------------------------- @noindent PolyORB provides an implementation of the RTCosScheduling service defined in @cite{[OMG02a]}. PolyORB uses some permissions stated in the specifications to allow for easy configuration of @code{ClientScheduler} and @code{ServerScheduler}, defined in the following sections. Additional information on the use of the API may be found in the RTCosScheduling example in @file{examples/corba/rtcorba/rtcosscheduling}. @c ------------------------------------------------------------------- @node ClientScheduler @subsection @code{RTCosScheduling::ClientScheduler} @c ------------------------------------------------------------------- @noindent Client side @i{activities} are defined in a configuration file that can be loaded using @file{RTCosScheduling.ClientScheduler.Impl.Load_Configuration_File} On the client side, the user can set up @itemize @bullet @item current task priority, using registered @code{PriorityMapping} object. @end itemize @noindent This file has the following syntax, derived from PolyORB configuration file syntax: @smallexample # Name of the activity [activity activity1] # Activity priority, in RTCORBA.Priority'Range priority=10000 @end smallexample @noindent In this example, activity @code{activity1} is defined with priority @code{10'000}. @c ------------------------------------------------------------------- @node ServerScheduler @subsection @code{RTCosScheduling::ServerScheduler} @c ------------------------------------------------------------------- @noindent Server side @i{POAs} and @i{objects} are defined in a configuration file that can be loaded using @file{RTCosScheduling.ClientScheduler.Impl.Load_Configuration_File} On the server side, the user can set up @itemize @bullet @item object priority, using registered @code{PriorityMapping} object. @item all RT-CORBA-specific POA configuration parameters. @end itemize @noindent This file has the following syntax, derived from PolyORB configuration file syntax: @smallexample # Name of the object [object object1] # Object priority, in RTCORBA.Priority'Range priority=10000 @end smallexample @noindent In this example, object @code{object1} is defined with priority @code{10'000}. @smallexample # Name of the POA [poa poa1] # PriorityModelPolicy for POA priority_model=CLIENT_PROPAGATED default_priority=0 # not meaningful for CLIENT_PROPAGATED # Threadpools attached to POA threadpool_id=1 # Name of the POA [poa poa2] # PriorityModelPolicy for POA priority_model=SERVER_DECLARED default_priority=40 # Threadpools attached to POA threadpool_id=2 # Name of the POA [poa poa3] # POA with no defined policies @end smallexample @noindent In this example, Two POAs are defined: POA @code{poa1} will use the @code{CLIENT_PROPAGATED} PriorityModel Policy, default value is not meaningful for this configuration, @code{poa1} will use the Threadpool #1; POA @code{poa2} will use the @code{SERVER_DECLARED} PriorityModel Policy, default server priority is 40, @code{poa2} will use the Threadpool #2. Note that both policies are optional and can be omitted. @c ------------------------------------------------------------------- @node DSA @chapter Ada Distributed Systems Annex (DSA) @cindex DSA, Distributed Systems Annex @c ------------------------------------------------------------------- @menu * Introduction to the Ada DSA:: * Partition Communication Subsystem:: * Most Features in One Example:: * A small example of a DSA application:: * Building a DSA application with PolyORB:: * Running a DSA application:: @end menu @c ------------------------------------------------------------------- @node Introduction to the Ada DSA @section Introduction to the Ada DSA @c ------------------------------------------------------------------- A critical feature of the Distributed Systems Annex (DSA) is that it allows the user to develop his application the same way whether this application is going to be executed as several programs on a distributed system, or as a single program on a non-distributed system. The DSA has been designed to minimize the source changes needed to convert an ordinary non-distributed program into a distributed program. The simplest way to start with DSA is to develop the application on a non-distributed system. Of course, the design of the application should take into account the fact that some units are going to be accessed remotely. In order to write a distributed Ada program, it is necessary for the user to label by means of categorization pragmas some of library level compilation units of the application program. The units that require categorization are typically those that are called remotely, and those that provide the types used in remote invocations. In order to ensure that distributed execution is possible, these units are restricted to contain only a limited set of Ada constructs. For instance, if the distributed system has no shared memory, shared variables must be forbidden. To specify the nature of these restrictions, the DSA provides several categorization pragmas, each of which excludes some language constructs from the categorized package. Of course, the user can develop the non-distributed application with his usual software engineering environment. It is critical to note that the user needs no specialized tools to develop his/her distributed application. For instance, he can debug his application with the usual debugger. Note that a non-distributed program is not to be confused with a distributed application composed of only one program. The latter is built with the help of the configuration tool and includes the communication library. Once the non-distributed version of the program is complete, it has to be configured into separate partitions. This step is surprisingly simple, compared to that of developing the application itself. The configuration step consists of mapping sets of compilation units into individual partitions, and specifying the mapping between partitions and nodes in the computer network. This mapping is specified and managed by means of a gnatdist configuration. The distributed version of the user application should work as is, but even when a program can be built both as a non-distributed or a distributed program using the same source code, there may still be differences in program execution between the distributed and non-distributed versions. These differences are discussed in subsequent sections (see @ref{Pragma Asynchronous} and @ref{Pragma All_Calls_Remote}). Developing a non-distributed application in order to distribute it later is the natural approach for a novice. Of course, it is not always possible to write a distributed application as a non-distributed application. For instance, a client/server application does not belong to this category because several instances of the client can be active at the same time. It is very easy to develop such an application using PolyORB; we shall describe how to do this in the following sections. @menu * Architecture of a Distributed Ada Application:: * Categorization Pragmas:: * Pragma Declared Pure:: * Pragma Remote_Call_Interface:: * Pragma Remote_Types:: * Pragma Shared_Passive:: * More About Categorization Pragmas:: @end menu @c ------------------------------------------------------------------- @node Architecture of a Distributed Ada Application, Categorization Pragmas, Introduction to the Ada DSA, Introduction to the Ada DSA @subsection Architecture of a Distributed Ada Application @c ------------------------------------------------------------------- A distributed system is an interconnection of one or more processing nodes and zero or more storage nodes. A distributed program comprises one or more partitions. A partition is an aggregate of library units. Partitions communicate through shared data or RPCs. A passive partition has no thread of control. Only a passive partition can be configured on a storage node. An active partition has zero or more threads of control and has to be configured on a processing node. The library unit is the core component of a distributed Ada application. The user can explicitly assign library units to a partition. Partitioning is a post-compilation process. The user identifies interface packages at compile-time. These packages are categorized using pragmas. Each of these pragmas supports the use of one of the following classical paradigms: @itemize @bullet @item Remote subprograms: For the programmer, a remote subprogram call is similar to a regular subprogram call. Run-time binding using access-to-subprogram types can also be used with remote subprograms. These remote subprograms are declared in library units categorized as remote call interface (RCI). @item Distributed objects: Special-purpose access types can designate remote objects. When a primitive dispatching operation is invoked on an object designated by such a remote access, a remote call is performed transparently on the partition on which the object resides. The types of these distributed objects are declared in library units categorized as remote types (RT). @item Shared objects: Global data can be shared among active partitions, providing a repository similar to shared memory, a shared file system or a database. Entryless protected objects allow safe concurrent access and update of shared objects. This feature is orthogonal to the notion of distributed objects, which are only accessed through exported services. These shared objects are declared in library units categorized as shared passive (SP). @end itemize The remotely-called subprograms declared in a library unit categorized as remote call interface (RCI) or remote types (RT) may be either statically or dynamically bound. The partition on which a statically bound remote subprogram is executed can be determined before the call. This is a static remote subprogram call. In contrast, a remote method or a dereference of an access to remote subprogram are dynamically bound remote calls, because the partition on which the remote subprogram is executed is determined at runtime, by the actuals of the call. In the following example, Data_1 and Data_2 are shared passive (SP) library units. Data_1 is configured on a passive partition mapped on a storage node. Partition_1 and Partition_2 are active partitions. Note that under some circumstances, a partition, for instance Partition_2, can be duplicated. To be duplicated, Unit_2 and Unit_3 which are configured on Partition_2 have to provide only dynamically bound remote subprograms. Otherwise, a partition calling a remote subprogram on Unit_2 would not be able to statically determine where to perform the remote call between the two instances of Unit_2. @* @* @image{xe-arch.fig} @* @c ------------------------------------------------------------------- @node Categorization Pragmas, Pragma Declared Pure, Architecture of a Distributed Ada Application, Introduction to the Ada DSA @subsection Categorization Pragmas @c ------------------------------------------------------------------- Library units can be categorized according to the role they play in a distributed program. A categorization pragma is a library unit pragma that restricts the kinds of declarations that can appear in a library unit and possibly in its child units, as well as the legal semantic dependences that the categorized unit can have. There are several categorization pragmas: @itemize @bullet @item Remote_Call_Interface @item Remote_Types @item Shared_Passive @item Pure @end itemize The following paragraphs do not present the detailed semantics of these pragmas (formal details will be found in the Ada Reference Manual). Their purpose is to give the reader an intuitive overview of the purpose of these pragmas. If a library unit is not categorized, this unit is called a normal unit and plays no special role in the distributed application. Such a unit is duplicated on any partition in which it is mentioned. A parenthetical remark: to avoid the need for specific run-time libraries for the DSA, the notion of remote rendezvous does not exist in Ada: tasks cannot be invoked directly from one partition to another. Therefore, declarations of task types and general protected types with entries are not allowed in categorized Ada library units. @c ------------------------------------------------------------------- @node Pragma Declared Pure, Pragma Remote_Call_Interface, Categorization Pragmas, Introduction to the Ada DSA @subsection Pragma Declared Pure @c ------------------------------------------------------------------- This pragma is not specific to the Distributed Systems Annex. A pure package can appear in the context of any package, categorized or not. A pure package is a preelaborable package that does not contain variable data. It is particularly useful to define types, constants and subprograms shared by several categorized packages. In contrast, normal packages cannot appear in the context of categorized package declarations. Because a pure package has no state, it can be duplicated on several partitions. @c ------------------------------------------------------------------- @node Pragma Remote_Call_Interface, Pragma Remote_Types, Pragma Declared Pure, Introduction to the Ada DSA @subsection Pragma Remote_Call_Interface @c ------------------------------------------------------------------- @menu * Overview of Pragma Remote_Call_Interface:: * Regular Remote Subprograms (RCI):: * Remote Access to Subprograms (RAS):: * Remote Access to Class Wide Types (RACW):: * Summary of Pragma Remote_Call_Interface:: @end menu @c ------------------------------------------------------------------- @node Overview of Pragma Remote_Call_Interface, Regular Remote Subprograms (RCI), Pragma Remote_Call_Interface, Pragma Remote_Call_Interface @subsubsection Overview of Pragma Remote_Call_Interface @c ------------------------------------------------------------------- Library units categorized with this pragma declare subprograms that can be called and executed remotely. An RCI unit acts as a server for remote calls. There is no memory space shared between server and clients. A subprogram call that invokes one such subprogram is a classical RPC operation; it is a statically bound operation, because the compiler can determine the identity of the subprogram being called. Dynamically bound calls are provided through two mechanisms: @itemize @bullet @item The dereference of an access-to-subprogram value, i.e. a value whose type is a remote access-to-subprogram (RAS). @item A dispatching call whose controlling argument is an access-to-class-wide operand. The formal is a remote access-to-class-wide (RACW) type. These remote access types can be declared in RCI packages as well. @end itemize A remote access type (RAS or RACW) can be viewed as a fat pointer, that is to say a structure with a remote address and a local address (like an URL: @t{}://@-@t{}/@-@t{}). The remote address must denote the host of the partition on which the entity has been created; the local address describes the local memory address within the host. It is very unlikely that RCI units can be duplicated in the distributed system. An implementation may allow separate copies of a RCI unit as long as it ensures that the copies present a consistent state to all clients. In the general case, preserving consistency is very costly. For this reason, the implementation may require a RCI unit to be unique in the distributed system. @node Regular Remote Subprograms (RCI), Remote Access to Subprograms (RAS), Overview of Pragma Remote_Call_Interface, Pragma Remote_Call_Interface @subsubsection Regular Remote Subprograms (RCI) In the following example, a RCIBank offers several remote services: Balance, Transfer, Deposit and Withdraw. On the caller side, the bank client uses the stub files of unit RCIBank. On the receiver side, the bank receiver uses the skeleton files of unit RCIBank including the body of this package. @include types.ads.texi @include rcibank.ads.texi @include rciclient.adb.texi @node Remote Access to Subprograms (RAS), Remote Access to Class Wide Types (RACW), Regular Remote Subprograms (RCI), Pragma Remote_Call_Interface @subsubsection Remote Access to Subprograms (RAS) In the following example, several mirroring banks offer their services through the same database. Each bank registers a reference to each of its services with a central bank. A client of the central bank requests a service from one of the mirroring banks. To satisfy requests, the RCI unit RASBank defines Balance_Type, a remote access to subprogram. (Recall that an access type declared in a remote unit has to be either remote access to subprogram or remote access to class wide type). Note that to obtain a remote access to subprogram, the subprogram that delivers the remote access must be remote itself. Therefore, MirrorBank is a RCI library unit. @include rasbank.ads.texi In the code below, a mirroring bank registers its services to the central bank. @include mirrorbank.ads.texi @include mirrorbank.adb.texi In the code below, a central bank client asks for a mirroring bank and calls the Balance service of this bank by dereferencing a remote access type. @include bankclient.adb.texi @node Remote Access to Class Wide Types (RACW), Summary of Pragma Remote_Call_Interface, Remote Access to Subprograms (RAS), Pragma Remote_Call_Interface @subsubsection Remote Access to Class Wide Types (RACW) A bank client is now connected to a bank through a terminal. The bank wants to notify a connected client, by means of a message on its terminal, when another client transfers a given amount of money to its account. In the following example, a terminal is designed as a distributed object. Each bank client will register its terminal object to the bank server for further use. In the code below, Term_Type is the root type of the distributed terminal hierarchy. @include terminal.ads.texi In the code below, the RCI unit RACWBank defines Term_Access, a remote access to class wide type. Term_Access becomes a reference to a distributed object. In the next section, we will see how to derive and extend Term_Type, how to create a distributed object and how to use a reference to it. @include racwbank.ads.texi @node Summary of Pragma Remote_Call_Interface, , Remote Access to Class Wide Types (RACW), Pragma Remote_Call_Interface @subsubsection Summary of Pragma Remote_Call_Interface Remote call interface units: @itemize @bullet @item Allow subprograms to be called and executed remotely @item Allow statically bound remote calls (remote subprogram) @item Allow dynamically bound remote calls (remote access types) @item Forbid variables and non-remote access types @item Prevent specification from depending on normal units @end itemize @c ------------------------------------------------------------------- @node Pragma Remote_Types, Pragma Shared_Passive, Pragma Remote_Call_Interface, Introduction to the Ada DSA @subsection Pragma Remote_Types @c ------------------------------------------------------------------- @menu * Overview of Pragma Remote_Types:: * Distributed Object:: * Transmitting Dynamic Structure:: * Summary of Remote Types Units:: @end menu @node Overview of Pragma Remote_Types, Distributed Object, Pragma Remote_Types, Pragma Remote_Types @subsubsection Overview of Pragma Remote_Types Unlike RCI units, library units categorized with this pragma can define distributed objects and remote methods on them. Both RCI and RT units can define a remote access type as described above (RACW). A subprogram defined in a RT unit is not a remote subprogram. Unlike RCI units, a RT unit can be duplicated on several partitions, in which case all its entities are distinct. This unit is duplicated on each partition in which it is defined. @node Distributed Object, Transmitting Dynamic Structure, Overview of Pragma Remote_Types, Pragma Remote_Types @subsubsection Distributed Object If we want to implement the notification feature proposed in the previous section, we have to derive Term_Type. Such a derivation is possible in a remote types unit like NewTerminal (see below). Any object of type New_Term_Type becomes a distributed object and any reference to such an object becomes a fat pointer or a reference to a distributed object (see Term_Access declaration in @ref{Remote Access to Class Wide Types (RACW)}). @include newterminal.ads.texi In the code below, a client registers his name and his terminal with RACWBank. Therefore, when any payer transfers some money to him, RACWBank is able to notify the client of the transfer of funds. @include term1client.adb.texi In the code below, a second client, the payer, registers his terminal to the bank and executes a transfer to the first client. @include term2client.adb.texi In the code below, we describe the general design of Transfer. Classical operations of Withdraw and Deposit are performed. Then, RACWBank retrieves the terminal of the payee (if present) and invokes a dispatching operation by dereferencing a distributed object Term. The reference is examined at run-time, and the execution of this operation takes place on the partition on which the distributed object resides. @include racwbank.adb.texi @node Transmitting Dynamic Structure, Summary of Remote Types Units, Distributed Object, Pragma Remote_Types @subsubsection Transmitting Dynamic Structure @include stringarraystream.ads.texi Non-remote access types cannot be declared in the public part of a remote types unit. However, it is possible to define private non-remote access types as long as the user provides its marshalling procedures, that is to say the mechanism needed to place a value of the type into a communication stream. The code below describes how to transmit a linked structure. The package declaration provides a type definition of single-linked lists of unbounded strings. An implementation of the marshalling operations could be the following: @include stringarraystream.adb.texi @node Summary of Remote Types Units, , Transmitting Dynamic Structure, Pragma Remote_Types @subsubsection Summary of Remote Types Units Remote types units: @itemize @bullet @item Support the definition of distributed objects @item Allow dynamically bound remote calls (via remote access types) @item Allow non-remote access types (with marshalling subprograms) @item Cannot have a specification that depends on normal units @end itemize @c ------------------------------------------------------------------- @node Pragma Shared_Passive, More About Categorization Pragmas, Pragma Remote_Types, Introduction to the Ada DSA @subsection Pragma Shared_Passive @c ------------------------------------------------------------------- @menu * Overview of Pragma Shared_Passive:: * Shared and Protected Objects:: * Summary of Pragma Shared_Passive:: @end menu @node Overview of Pragma Shared_Passive, Shared and Protected Objects, Pragma Shared_Passive, Pragma Shared_Passive @subsubsection Overview of Pragma Shared_Passive The entities declared in such a categorized library unit are intended to be mapped on a virtual shared address space (file, memory, database). When two partitions use such a library unit, they can communicate by reading or writing the same variable in the shared unit. This supports the conventional shared variables paradigm. Entryless protected objects can be declared in these units, to provide an atomic access to shared data, thus implementing a simple transaction mechanism. When the address space is a file or a database, the user can take advantage of the persistency features provided by these storage nodes. @node Shared and Protected Objects, Summary of Pragma Shared_Passive, Overview of Pragma Shared_Passive, Pragma Shared_Passive @subsubsection Shared and Protected Objects In the code below, we define two kinds of shared objects. External_Synchronization requires that the different partitions updating this data synchronize to avoid conflicting operations on shared objects. Internal_Synchronization provides a way to get an atomic operation on shared objects. Note that only entryless protected types are allowed in a shared passive unit; synchronization must be done with protected procedures. @include sharedobjects.ads.texi @node Summary of Pragma Shared_Passive,, Shared and Protected Objects, Pragma Shared_Passive @subsubsection Summary of Pragma Shared_Passive Shared passive units: @itemize @bullet @item Allow direct access to data from different partitions @item Provide support for shared (distributed) memory @item Support memory protection by means of entryless protected objects @item Prevent specification from depending on normal units @end itemize @c ------------------------------------------------------------------- @node More About Categorization Pragmas, , Pragma Shared_Passive, Introduction to the Ada DSA @subsection More About Categorization Pragmas @c ------------------------------------------------------------------- @menu * Variables and Non-Remote Access Types:: * RPC Failures:: * Exceptions:: * Pragma Asynchronous:: * Pragma All_Calls_Remote:: * Generic Categorized Units :: * Categorization Unit Dependencies:: @end menu @node Variables and Non-Remote Access Types, RPC Failures, More About Categorization Pragmas, More About Categorization Pragmas @subsubsection Variables and Non-Remote Access Types In RT or RCI package declarations, variable declarations are forbidden, and non-remote access types are allowed as long as their marshalling subprograms are explicitly provided (see @ref{Transmitting Dynamic Structure}). @node RPC Failures, Exceptions, Variables and Non-Remote Access Types, More About Categorization Pragmas @subsubsection RPC Failures Calls are executed at most once: they are made exactly one time or they fail with an exception. When a communication error occurs, @i{System.RPC.Communication_Error} is raised. @node Exceptions, Pragma Asynchronous, RPC Failures, More About Categorization Pragmas @subsubsection Exceptions Any exception raised in a remote method or subprogram call is propagated back to the caller. Exception semantics are preserved in the regular Ada way. @include internal.ads.texi @include rempkg2.ads.texi @include rempkg1.ads.texi Let us say that RemPkg2, Internal and RemExcMain packages are on the same partition Partition_1 and that RemPkg1 is on partition Partition_2. @include rempkg2.adb.texi @include rempkg1.adb.texi @include remexcmain.adb.texi When RemPkg1.Subprogram on Partition_1 raises Internal.Exc, this exception is propagated back to Partition_2. As Internal.Exc is not defined on Partition_2, it is not possible to catch this exception without an exception handler @b{when others}. When this exception is reraised in RemPkg1.Subprogram, it is propagated back to Partition_1. But this time, Internal.Exc is visible and can be handled as we would in a single-partition Ada program. Of course, the exception message is also preserved. @c XXXX Schema ??? exceptions @node Pragma Asynchronous, Pragma All_Calls_Remote, Exceptions, More About Categorization Pragmas @subsubsection Pragma Asynchronous By default, a remote call is blocking: the caller waits until the remote call is complete and the output stream is received. Just like a normal (nonremote) call, the caller does not proceed until the call returns. By contrast, a remote subprogram labeled with pragma Asynchronous allows statically and dynamically bound remote calls to it to be executed asynchronously. A call to an asynchronous procedure doesn't wait for the completion of the remote call, and lets the caller continue its execution. The remote procedure must have only @b{in} parameters, and any exception raised during the execution of the remote procedure is lost. When pragma Asynchronous applies to a regular subprogram with @b{in} parameters, any call to this subprogram will be executed asynchronously. The following declaration of AsynchronousRCI.Asynchronous gives an example. @include asynchronousrci.ads.texi @include asynchronousrt.ads.texi A pragma Asynchronous may apply to a remote access-to-subprogram (RAS) type. An asynchronous RAS can be both asynchronous and synchronous depending on the designated subprogram. For instance, in the code below, remote call (1) is asynchronous but remote call (2) is synchronous. A pragma Asynchronous may apply to a RACW as well. In this case, the invocation of @b{any} method with @b{in} parameters is @i{always} performed asynchronously. Remote method invocation (3) is asynchronous but remote method invocation (4) is synchronous. @include asynchronousmain.adb.texi This feature supports the conventional message passing paradigm. The user must be aware that this paradigm, and asynchronous remote calls in particular, has several drawbacks: @itemize @bullet @item It violates the normal semantics of calls; the caller proceeds without awaiting the return. The semantics are more similar to a ``remote goto'' than a remote call @item It prevents easy development and debugging in a non-distributed context @item It can introduce race conditions @end itemize To illustrate the latter, let us take the following example: @include node2.ads.texi @include node2.adb.texi @include node1.ads.texi @include node1.adb.texi @include nondeterministic.adb.texi Let us say that Main is configured on Partition_0, Node1 on Partition_1 and Node2 on Partition_2. If Node1.Send and Node2.Send procedures were synchronous or if no latency was introduced during network communication, we would have the following RPC order: Main remotely calls Node1.Send which remotely calls Node2.Send which sets V to 1. Then, Main remotely calls Node2.Send and sets V to 2. Now, let us assume that both Send procedures are asynchronous and that the connection between Partition_1 and Partition_2 is very slow. The following scenario can very well occur. Main remotely calls Node1.Send and is unblocked. Immediately after this call, Main remotely calls Node2.Send and sets V to 2. Once this is done, the remote call to Node1.Send completes on Partition_1 and it remotely calls Node2.Send which sets V to 1. @node Pragma All_Calls_Remote, Generic Categorized Units , Pragma Asynchronous, More About Categorization Pragmas @subsubsection Pragma All_Calls_Remote A pragma All_Calls_Remote in a RCI unit forces remote procedure calls to be routed through the communication subsystem even for a local call. This eases the debugging of an application in a non-distributed situation that is very close to the distributed one, because the communication subsystem (including marshalling and unmarshalling procedures) can be exercised on a single node. In some circumstances, a non-distributed application can behave differently from an application distributed on only one partition. This can happen when both All_Calls_Remote and Asynchronous features are used at the same time (see @ref{Pragma Asynchronous} for an example). Another circumstance occurs when the marshalling operations raise an exception. In the following example, when unit ACRRCI is a All_@-Calls_@-Remote package, the program raises Program_Error. When unit ACRRCI is no longer a All_Calls_Remote package, then the program completes silently. @include acrrt.ads.texi @include acrrt.adb.texi @include acrrci.ads.texi @include acrrci.adb.texi @include acrmain.adb.texi @node Generic Categorized Units , Categorization Unit Dependencies, Pragma All_Calls_Remote, More About Categorization Pragmas @subsubsection Generic Categorized Units @include genericrci.ads.texi @include rciinstantiation.ads.texi @include normalinstantiation.ads.texi Generic units may be categorized. Instances do not automatically inherit the categorization of their generic units, but they can be categorized explicitly. If they are not, instances are normal compilation units. Like any other categorized unit, a categorized instance must be at the library level, and the restrictions of categorized units apply on instantiation (in particular on generic formal parameters). @node Categorization Unit Dependencies, , Generic Categorized Units , More About Categorization Pragmas @subsubsection Categorization Unit Dependencies Each categorization pragma has very specific visibility rules. As a general rule, RCI > RT > SP > Pure, where the comparison indicates allowed semantic dependencies. This means that a Remote_Types package can make visible in its specification only Remote_Types, Shared_Passive and Pure units. @c ------------------------------------------------------------------- @node Partition Communication Subsystem @section Partition Communication Subsystem @c ------------------------------------------------------------------- @menu * Marshalling and Unmarshalling Operations:: * Incorrect Remote Dispatching:: * Partition Ids:: * Concurrent Remote Calls:: * Consistency and Elaboration:: * Abortion and Termination:: @end menu @node Marshalling and Unmarshalling Operations, Incorrect Remote Dispatching, Partition Communication Subsystem, Partition Communication Subsystem @subsection Marshalling and Unmarshalling Operations The Partition Communication Subsystem (PCS) is the runtime library for distributed features. It marshals and unmarshals client and server requests into a data stream suitable for network transmission. Parameter streams are normally read and written using four attributes: @itemize @bullet @item Write: write an element into a stream, valid only for constrained types @item Read: read a constrained element from a stream @item Output: same as Write, but write discriminants or array bounds as well if needed @item Input: same as Read, but read discriminants or bounds from the stream (the Input attribute denotes a function) @end itemize An Ada compiler provides default 'Read and 'Write operations. But it is up to the implementation of the PCS to provide default 'Read and 'Write to ensure proper operation between heterogeneous architectures (see @ref{Heterogeneous System}). The user can override these operations, except for predefined types. Overriding with a custom version provides the user with a way to debug its application (even outside of the Distributed Systems Annex). On the other hand, remaining with the default implementation allows the user to take advantage of optimized and portable representations provided by the PCS. @include new_integers.ads.texi @include new_integers.adb.texi The language forces the user to provide Read and Write operations for non-remote access types. Transmitting an access value by dumping its content into a stream makes no sense when the value is going to be transmitted to another partition (with a different memory space). To transmit non-remote access types see @ref{Transmitting Dynamic Structure}. @node Incorrect Remote Dispatching, Partition Ids, Marshalling and Unmarshalling Operations, Partition Communication Subsystem @subsection Incorrect Remote Dispatching When a remote subprogram takes a class wide argument, there is a risk of using an object of a derived type that will not be clean enough to be transmitted. For example, given a type called Root_Type, if a remote procedure takes a Root_Type'Class as an argument, the user can call it with an instance of Derived_Type that is Root_Type enriched with a field of a task type. This will lead to a non-communicable type to be transmitted between partitions. To prevent this, paragraph E.4(18) of the Ada Reference Manual explains that any actual type used as parameter for a remote call whose formal type is a class wide type must be declared in the visible part of a Pure or Remote_Types package. This property also holds for remote functions returning class wide types. To summarize, the actual type used should have been eligible for being declared where the root type has been declared. If a `bad' object is given to a remote subprogram, @i{Program_Error} will be raised at the point of the call. @node Partition Ids, Concurrent Remote Calls, Incorrect Remote Dispatching, Partition Communication Subsystem @subsection Partition Ids U'Partition_ID identifies the partition where the unit U has been elaborated. For this purpose, the PCS provides an integer type Partition_ID to uniquely designate a partition. Note that a Partition_ID is represented as a universal integer, and has no meaning outside of the PCS. The RM requires that two partitions of a distributed program have different Partition_ID's at a given time. A Partition_ID may or may not be assigned statically (at compile or link time). A Partition_ID may or may not be related to the physical location of the partition. Partition_ID's can be used to check whether a RCI package is configured locally. @include check_pid.adb.texi @node Concurrent Remote Calls, Consistency and Elaboration, Partition Ids, Partition Communication Subsystem @subsection Concurrent Remote Calls It is not defined by the PCS specification whether one or more threads of control should be available to process incoming messages and to wait for their completion. But the PCS implementation is required to be reentrant, thereby allowing concurrent calls on it to service concurrent remote subprogram calls into the server partition. This means that at the implementation level the PCS manages a pool of helper tasks. This (apart from performance) is invisible to the user. @node Consistency and Elaboration, Abortion and Termination, Concurrent Remote Calls, Partition Communication Subsystem @subsection Consistency and Elaboration A library unit is consistent if the same version of its declaration is used in all units that reference it. This requirement applies as well to a unit that is referenced in several partitions of a distributed program. If a shared passive or RCI library unit U is included in some partition P, It is a bounded error to elaborate another partition P1 of a distributed program that that depends on a different version of U. As a result of this error, Program_Error can be raised in one or both partitions during elaboration. U'Version yields a string that identifies the version of the unit declaration and any unit declaration on which it depends. U'Version_Body yields a string that identifies the version of the unit body. These attributes are used by the PCS to verify the consistency of an application. After elaborating the library units, but prior to invoking the main subprogram, the PCS checks the RCI unit versions, and then accept any incoming RPC. To guarantee that it is safe to call receiving stubs, any incoming RPC is kept pending until the partition completes its elaboration. @node Abortion and Termination, , Consistency and Elaboration, Partition Communication Subsystem @subsection Abortion and Termination If a construct containing a remote call is aborted, the remote subprogram call is cancelled. Whether the execution of the remote subprogram is immediately aborted as a result of the cancellation is implementation defined. An active partition terminates when its environment task terminates. In other terms, a partition cannot terminate before the Ada program itself terminates. The standard termination mechanism applies, but can be extended with extra rules (see @ref{Partition Attribute Termination} for examples). @c ------------------------------------------------------------------- @node Most Features in One Example @section Most Features in One Example @c ------------------------------------------------------------------- The example shown on the following figure highlights most of the features of DSA. The system is based on a set of factories and workers and a storage. Each entity is a partition itself. A factory hires a worker from a pool of workers (hire - 1) and assigns a job (query - 2) to him. The worker performs the job and saves the result (reply - 3) in a storage common to all the factories. The worker notifies the factory of the end of his job (notify - 4). @* @* @image{full-ex.fig} @* When a worker has completed his job, the result must be saved in a common storage. To do this, we define a protected area in SP package Storage (see following code). An entryless protected object ensures atomic access to this area. @include storage.ads.texi Common is a Remote_Types package that defines most of the remote services of the above system (see following code). First, we define a way for the workers to signal the completion of his job. This callback mechanism is implemented using RAS Notify. @include common.ads.texi We define an abstract tagged type Worker which is intended to be the root type of the whole distributed objects hierarchy. Assign allows a factory to specify a job to a worker and a way for the worker to signal its employer the completion of this job. Any_Worker is a remote access to class wide type (RACW). In other words, it is a reference to a distributed object of any derived type from Worker class. Note that the two remote access types (Any_Worker and Notify) are declared as asynchronous. Therefore, any override of Assign will be executed asynchronously. To be asynchronous, an object of type Notify has to be a reference to an asynchronous procedure. NewWorker is derived from type Worker and Assign is overridden. @include newworkers.ads.texi The following code shows how to derive a second generation of workers NewNewWorker from the first generation NewWorker. As mentioned above, this RT package can be duplicated on several partitions to produce several types of workers and also several remote workers. @include newnewworkers.ads.texi In the following code, we define a unique place where workers wait for jobs. WorkerCity is a Remote_Call_Interface package with services to hire and free workers. Unlike Remote_Types packages, Remote_Call_Interface packages cannot be duplicated, and are assigned to one specific partition. @include workercity.ads.texi In order to use even more DSA features, Factory is defined as a generic RCI package (see sample above). Any instantiation defines a new factory (see sample above). To be RCI, this instantiation has to be categorized once again. @include factory.ads.texi @include newfactory.ads.texi @c ------------------------------------------------------------------- @node A small example of a DSA application @section A small example of a DSA application @c ------------------------------------------------------------------- In this section we will write a very simple client-server application using PolyORB DSA. The server will provide a @code{Remote Call Interface} composed of a single @code{Echo_String} function that will take a String and return it to the caller. Here is the code for the server: @file{server.ads}: @include dsa_server.ads.texi @file{server.adb}: @include dsa_server.adb.texi And here is the code for the client: @file{client.adb}: @include dsa_client.adb.texi @noindent For more details about the Distributed Systems Annex, see the Ada Reference Manual @cite{[ISO06]}. @c ------------------------------------------------------------------- @node Building a DSA application with PolyORB @section Building a DSA application with PolyORB @c ------------------------------------------------------------------- This section describes how to build a complete distributed Ada application using the PolyORB implementation of the DSA. @menu * Introduction to PolyORB/DSA:: * How to Configure a Distributed Application:: * Gnatdist Command Line Options:: * The Configuration Language:: * Partition Runtime Parameters:: * Gnatdist Internals:: * PolyORB PCS Internals:: * Remote Shell Notes:: @end menu @node Introduction to PolyORB/DSA, How to Configure a Distributed Application, Building a DSA application with PolyORB, Building a DSA application with PolyORB @subsection Introduction to PolyORB/DSA A distributed Ada application comprises a number of partitions which can be executed concurrently on the same machine or, and this is the interesting part, can be distributed on a network of machines. The way in which partitions communicate is described in Annex E of the Ada Reference Manual. A partition is a set of compilation units that are linked together to produce an executable binary. A distributed program comprises two or more communicating partitions. The Distributed Systems Annex (DSA) does not describe how a distributed application should be configured. It is up to the user to define what are the partitions in his program and on which machines they should be executed. The tool @t{po_gnatdist} and its configuration language allows the user to partition his program and to specify the machines on which the individual partitions are to execute. @t{po_gnatdist} reads a configuration file (whose syntax is described in section @ref{The Configuration Language}) and builds several executables, one for each partition. It also takes care of launching the different partitions (default) with parameters that can be specific to each partition. @node How to Configure a Distributed Application, Gnatdist Command Line Options, Introduction to PolyORB/DSA, Building a DSA application with PolyORB @subsection How to Configure a Distributed Application @itemize @bullet @item Write a non-distributed Ada application, to get familiar with the PolyORB environment. Use the categorization pragmas to specify the packages that can be called remotely. @item When this non-distributed application is working, write a configuration file that maps the user categorized packages onto specific partitions. This concerns particularly remote call interface and remote types packages. Specify the main procedure of the distributed application (see @ref{Partition Attribute Main}). @item Type `po_gnatdist @i{}'. @item Start the distributed application by invoking the start-up shell script or default Ada program (depending on the Starter option, see @ref{Pragma Starter}). @end itemize @node Gnatdist Command Line Options, The Configuration Language, How to Configure a Distributed Application, Building a DSA application with PolyORB @subsection Gnatdist Command Line Options @smallexample po_gnatdist [switches] configuration-file [list-of-partitions] @end smallexample @c We should add some explanations of the gnatdist specific flags @c -n, -M and on some particular mechanism (a spec without a body). The switches of @t{po_gnatdist} are, for the time being, exactly the same as those of gnatmake, with the addition of @t{--PCS}, which allows the user to override the default selection of distribution runtime library (PCS). By default @t{po_gnatdist} outputs a configuration report and the actions performed. The switch -n allows @t{po_gnatdist} to skip the first stage of recompilation of the non-distributed application. The names of all configuration files must have the suffix @t{.cfg}. There may be several configuration files for the same distributed application, as the user may want to use different distributed configurations depending on load and other characteristics of the computing environment. If a list of partitions is provided on the command line of the po_gnatdist command, only these partitions will be built. In the following configuration example, the user can type : @smallexample po_gnatdist @i{ } @end smallexample @node The Configuration Language, Partition Runtime Parameters, Gnatdist Command Line Options, Building a DSA application with PolyORB @subsection The Configuration Language The configuration language is @i{Ada-like}. As the capabilities of PolyORB will evolve, so will this configuration language. Most of the attributes and pragmas can be overridden at run-time by command line arguments or environment variables. @menu * Language Keywords:: * Pragmas and Representation Clauses:: * Configuration Declaration:: * Partition Declaration:: * Location Declaration:: * Partition Attribute Main:: * Pragma Starter:: * Pragma Name_Server:: * Pragma Boot_Location:: * Partition Attribute Self_Location:: * Partition Attribute Passive:: * Partition Attribute Data_Location:: * Partition Attribute Allow_Light_PCS:: * Pragma Priority:: * Partition Attribute Priority:: * Partition Attribute Host:: * Pragma Import:: * Partition Attribute Directory:: * Partition Attribute Command_Line:: * Partition Attribute Environment_Variables:: * Partition Attribute Termination:: * Partition Attribute Reconnection:: * Pragma Version:: * Partition Attribute Task_Pool:: * Partition Attribute ORB_Tasking_Policy:: * A Complete Example:: @end menu @node Language Keywords, Pragmas and Representation Clauses, The Configuration Language, The Configuration Language @subsubsection Language Keywords All the Ada keywords are reserved keywords of the configuration language. @t{po_gnatdist} generates full Ada code in order to build the different executables. To avoid naming conflicts between Ada and the configuration language, all the Ada keywords have been reserved even if they are not used in the configuration language. In addition, the following keywords are defined: @itemize @bullet @item @i{configuration} to encapsulate a configuration @item @i{partition} that is a predefined type to declare partitions @end itemize @node Pragmas and Representation Clauses, Configuration Declaration, Language Keywords, The Configuration Language @subsubsection Pragmas and Representation Clauses It is possible to modify the default behavior of the configuration via a pragma definition. @smallexample PRAGMA ::= @b{pragma} PRAGMA_NAME [(PRAGMA_ARGUMENTS)]; @end smallexample It is also possible to modify the default behavior of all the partitions via an attribute definition clause applied to the predefined type @b{Partition}. @smallexample REPRESENTATION_CLAUSE ::= @b{for} Partition'ATTRIBUTE_NAME @b{use} ATTRIBUTE_ARGUMENTS; @end smallexample It is also possible to modify the default behavior of a given partition via an attribute definition clause applied to the partition itself. @smallexample REPRESENTATION_CLAUSE ::= @b{for} PARTITION_IDENTIFIER'ATTRIBUTE_NAME @b{use} ATTRIBUTE_ARGUMENTS; @end smallexample When an attribute definition clause is applied to a given object of a predefined type, this overrides any attribute definition of the predefined type. In the next sections, attributes apply to a given object rather than to the predefined type. @node Configuration Declaration, Partition Declaration, Pragmas and Representation Clauses, The Configuration Language @subsubsection Configuration Declaration The distribution of one or several Ada programs is described by a single configuration unit. This configuration unit has a specification part and an optional body part. A configuration unit is declared as an Ada procedure would be. The keyword @b{configuration} is reserved for this purpose. @smallexample CONFIGURATION_UNIT ::= @b{configuration} IDENTIFIER @b{is} DECLARATIVE_PART [@b{begin} SEQUENCE_OF_STATEMENTS] @b{end} [IDENTIFIER]; @end smallexample @node Partition Declaration, Location Declaration, Configuration Declaration, The Configuration Language @subsubsection Partition Declaration In the declarative part, the user declares his partitions and can change their default behavior. @t{po_gnatdist} provides a predefined type @b{Partition}. The user can declare a list of partitions and can also initialize these partitions with an initial list of Ada units. @smallexample DECLARATIVE_PART ::= @{DECLARATIVE_ITEM@} DECLARATIVE_ITEM ::= PARTITION_DECLARATION | REPRESENTATION_CLAUSE | SUBPROGRAM_DECLARATION | PRAGMA SUBPROGRAM_DECLARATION ::= MAIN_PROCEDURE_DECLARATION | PROCEDURE_DECLARATION | FUNCTION_DECLARATION PARTITION_DECLARATION ::= DEFINING_IDENTIFIER_LIST : Partition [:= ENUMERATION_OF_ADA_UNITS]; DEFINING_IDENTIFIER_LIST ::= DEFINING_IDENTIFIER @{, DEFINING_IDENTIFIER@} STATEMENT ::= IDENTIFIER := ENUMERATION_OF_ADA_UNITS; SEQUENCE_OF_STATEMENTS ::= STATEMENT @{STATEMENT@} @end smallexample Once declared, a partition is an empty list of Ada units. The operator @b{":="} adds the Ada units list on the right side to the current list of Ada units that are already mapped to the partition. This is a non-destructive operation. Whether a unit is a relevant Ada unit or not is checked later on by the back-end of @t{po_gnatdist}. These assignments can occur in the declarative part as well as in the body part. @smallexample ENUMERATION_OF_ADA_UNITS ::= (@{ADA_UNIT @{, ADA_UNIT@}@}); @end smallexample @node Location Declaration, Partition Attribute Main, Partition Declaration, The Configuration Language @subsubsection Location Declaration There are several kinds of location in the configuration language. We shall present them in the next subsections, but here is a short overview of these locations: @itemize @bullet @item Boot_Location defines the network locations to use to communicate with the the boot server during the boot phase @item Self_Location defines the network locations to use by others to communicate with the current partition @item Data_Location defines the data storage location used by the current partition to map its shared passive units @end itemize A location is composed of a support name and a specific data for this support. For instance, a network location is composed of a protocol name like @i{tcp} and a protocol data like @i{:}. A storage location is composed of a storage support name like @i{dfs} (for Distributed File System) and a storage support data like a directory @i{/dfs/glade}. @smallexample LOCATION ::= ([Support_Name =>] STRING_LITERAL, [Support_Data =>] STRING_LITERAL) LOCATION_LIST ::= (LOCATION [,LOCATION)]) @end smallexample Note that a location may have an undefined or incomplete support data. In this case, the support is free to compute a support data. For instance, ("tcp", "") specifies that the protocol is used but that the protocol data @i{:} is to be determined by the protocol itself. A location or a list of locations can be can be concatenated into a single string to be used as a command line option or an environment variable (see @ref{Partition Runtime Parameters}). If a partition wants to communicate with another partition once the location list of the latter is known, the caller will use the first location of the callee whose protocol is locally available. For instance, if a callee exports three locations ("N1", "D1"), ("N2", "D2") and ("N3", "D3"), a caller with protocols N2 and N3 locally available will try to communicate with the callee using the protocol of name N2 and of specific data D2. @node Partition Attribute Main, Pragma Starter, Location Declaration, The Configuration Language @subsubsection Partition Attribute Main Basically, the distributed system annex (DSA) helps the user in building a distributed application from a non-distributed application (Of course, this is not the only possible model offered by DSA). The user can design, implement and test his application in a non-distributed environment, and then should be able to switch from the non-distributed case to a distributed case. As mentioned before, this two-phase design approach has several advantages. In a non-distributed case, the user executes only one main executable possibly with a name corresponding to the main unit name of his application. With @t{po_gnatdist}, in a distributed case, a main executable with a name corresponding to the main unit name is responsible for starting the entire distributed application. Therefore, the user can start his application the same way he used to do in the non-distributed case. For this reason, the configuration language provides a way to declare the main procedure of the non-distributed application. @smallexample MAIN_PROCEDURE_IDENTIFIER ::= ADA_UNIT MAIN_PROCEDURE_DECLARATION ::= @b{procedure} MAIN_PROCEDURE_IDENTIFIER @b{is in} PARTITION_IDENTIFIER; @end smallexample In this case, the partition in which the main procedure has been mapped is called the main partition. It includes in its code a call to this main procedure. The main partition has an additional specific role, because the boot server is located on it (see @ref{PolyORB PCS Internals}). The main procedures for the other partitions have a null body. However, the user can also modify this behavior by providing an alternate main procedure. To do this, an alternate main subprogram has to be declared and assigned to the partition Main attribute. @smallexample PROCEDURE_DECLARATION ::= @b{procedure} PROCEDURE_IDENTIFIER; REPRESENTATION_CLAUSE ::= @b{for} PARTITION_IDENTIFIER'Main @b{use} PROCEDURE_IDENTIFIER; @end smallexample @node Pragma Starter, Pragma Name_Server, Partition Attribute Main, The Configuration Language @subsubsection Pragma Starter As a default, the main executable is a full Ada starter procedure. That means that it launches all the other partitions from an Ada program. The pragma Starter allows the user to ask for one starter or another. When the partition host is not statically defined (see @ref{Partition Attribute Host}), the starter subprogram will ask for it interactively when it is executed. @smallexample CONVENTION_LITERAL ::= Ada | Shell | None PRAGMA ::= @b{pragma} Starter ([Convention =>] CONVENTION_LITERAL); @end smallexample @itemize @bullet @item The default method consists in launching partitions from the main partition Ada subprogram using a remote shell (see below). @item The user may ask for a Shell script that starts the different partitions one at a time on the appropriate remote machines, using a remote shell. As the Ada starter, the Shell script starter ask for partition hosts interactively when a partition host is not already defined. Having a textual shell script allows the user to edit it and to modify it easily. @item The user may ask for a None starter. In this case, it is up to the user to launch the different partitions. @end itemize @subsubsection Pragma Remote_Shell When pragma Starter is Ada or Shell, the main partition launches the other partitions. The remote shell used as a default is determined during PolyORB configuration and installation. It is either rsh, remsh or the argument passed to --with-rshcmd=[ARG]. The pragma Remote_Shell allows the user to override the default. @smallexample PRAGMA ::= @b{pragma} Remote_Shell ([Command =>] STRING_LITERAL, [Options =>] STRING_LITERAL); @end smallexample The Command parameter indicates the name of the remote shell command name and the Options parameter corresponds to the additional flags to pass to the remote shell command. @node Pragma Name_Server, Pragma Boot_Location, Pragma Starter, The Configuration Language @subsubsection Pragma Name_Server @smallexample NAME_SERVER_LITERAL ::= Embedded | Standalone PRAGMA ::= @b{pragma} Name_Server ([Name_Server_Kind =>] NAME_SERVER_LITERAL); @end smallexample By default, partitions in a PolyORB/DSA application rely on an external, stand-alone name server launched by the user, and whose location is retrieved from runtime configuration. A pragma Name_Server with parameter Embedded can be used to request the PCS to instead set up a name server within the main partition. If the Ada starter is used, the location of the name server is passed automatically to slave partitions. @node Pragma Boot_Location, Partition Attribute Self_Location, Pragma Name_Server, The Configuration Language @subsubsection Pragma Boot_Location When a partition starts executing, one of the first steps consists in a connection to the boot server. This pragma provides one or more locations in order to get a connection with the boot server. @smallexample PRAGMA ::= PRAGMA_WITH_NAME_AND_DATA | PRAGMA_WITH_LOCATION | PRAGMA_WITH_LOCATION_LIST PRAGMA_WITH_NAME_AND_DATA ::= @b{pragma} Boot_Location ([Protocol_Name =>] STRING_LITERAL, [Protocol_Data =>] STRING_LITERAL); PRAGMA_WITH_LOCATION ::= @b{pragma} Boot_Location ([Location =>] LOCATION); PRAGMA_WITH_LOCATION_LIST ::= @b{pragma} Boot_Location ([Locations =>] LOCATION_LIST); @end smallexample This boot server location can be concatenated into a single string to be used as a command line option or an environment variable (see @ref{Partition Runtime Parameters}). @b{Note: pragma Boot_Server is now obsolete. It is recommended to use pragma Boot_Location. This wording is more consistent with the rest of the configuration language (see Self_Location @ref{Partition Option self_location} and Data_Location @ref{Partition Option data_location}).} @node Partition Attribute Self_Location, Partition Attribute Passive, Pragma Boot_Location, The Configuration Language @subsubsection Partition Attribute Self_Location Except for the boot partition on which the boot server is located, a partition is reachable through a dynamically computed location (for instance, the partition looks for a free port when the protocol is tcp). The user may want such a partition to be reachable from a given location, especially if the user wants to make this partition a boot mirror. To do so, he can force the partition location with self_location feature. @smallexample REPRESENTATION_CLAUSE ::= @b{for} PARTITION_IDENTIFIER'Self_Location @b{use} LOCATION; | @b{for} PARTITION_IDENTIFIER'Self_Location @b{use} LOCATION_LIST; @end smallexample If the attribute definition clause applies to the predefined type @b{Partition}, the locations have to be incomplete. Otherwise, all the partitions would be reachable through the same locations, which is definitively not recommended. When an attribute self_location definition clause applies to a given partition, the protocol units needed for this partition are linked in the executable. By default, when the self_location attribute is not redefined, the default protocol used by the partition and loaded in its executable is the @i{tcp} protocol. @node Partition Attribute Passive, Partition Attribute Data_Location, Partition Attribute Self_Location, The Configuration Language @subsubsection Partition Attribute Passive By default, a partition is an active partition. This attribute allows to define a passive partition. In this case, @t{po_gnatdist} checks that only shared passive units are mapped on the partition. As this partition cannot register itself, its location is hard-coded in all the partitions that depend on its shared passive units. @smallexample REPRESENTATION_CLAUSE ::= @b{for} PARTITION_IDENTIFIER'Passive @b{use} BOOLEAN_LITERAL; @end smallexample @node Partition Attribute Data_Location, Partition Attribute Allow_Light_PCS, Partition Attribute Passive, The Configuration Language @subsubsection Partition Attribute Data_Location Shared passive units can be mapped on passive or active partitions. In both cases, it is possible to choose the data storage support and to configure it with the specific data of a location. @smallexample REPRESENTATION_CLAUSE ::= @b{for} PARTITION_IDENTIFIER'Data_Location @b{use} LOCATION; | @b{for} PARTITION_IDENTIFIER'Data_Location @b{use} LOCATION_LIST; @end smallexample When an attribute data_location definition clause applies to a given partition, the data storage support units needed for this partition are linked in the executable. By default, when the data_location attribute is not redefined, the default storage support used by the partition and loaded in its executable is the @i{dfs} support. @i{dfs}, Distributed File System, is a storage support available as soon as files can be shared between partitions. It is not possible to map the different shared passive units of a given partition on different data storage locations. PolyORB requires all the shared passive units of a given partition to be mapped on the same storage support. When the attribute data_location applied to a partition is a list of locations, all the storage support units needed for this partition are linked in the executable. By default, only the first one is activated. The user can choose to change the activated support by another one specified in the location list. This can be done using the partition option data_location (see @ref{Partition Option data_location}). As passive partitions cannot be activated, it is not possible to provide a location list as a data_location attribute. It is not possible to change dynamically its location either. @node Partition Attribute Allow_Light_PCS, Pragma Priority, Partition Attribute Data_Location, The Configuration Language @subsubsection Partition Attribute Allow_Light_PCS On some circumstances, @t{po_gnatdist} can detect that a partition does not need the full PCS functionalities. This occurs in particular when the partition does use any task, any RCI unit or any RACW object. Therefore, the partition does not receive any message that is not a reply to a previous request. In this case, the PCS does not drag in the tasking library and a light PCS is linked in the partition executable. This specific configuration is automatically determined by @t{po_gnatdist} with the ALI file information. This optimization can be inappropriate especially when the user wants to use the "Distributed Shared Memory" storage support which runs Li and Hudak's algorithm. In this case, messages are exchanged without being replies to previously sent requests and the normal PCS should be linked instead of the light one. Note also that @t{po_gnatdist} cannot know for sure that the DSM storage support assigned at configuration time is used at run-time. The user can configure this optimization with the following attribute. @smallexample REPRESENTATION_CLAUSE ::= @b{for} PARTITION_IDENTIFIER'Allow_Light_PCS @b{use} BOOLEAN_LITERAL; @end smallexample @node Pragma Priority, Partition Attribute Priority, Partition Attribute Allow_Light_PCS, The Configuration Language @subsubsection Pragma Priority It might be necessary for real-time applications to get control over the priority at which a remote procedure call is executed. By default, the PCS sends the priority of the client to the server which sets the priority of an anonymous task to this value. The pragma Priority allows to decide which priority policy should apply in the distributed application. @smallexample PRIORITY_POLICY_LITERAL ::= Server_Declared | Client_Propagated PRAGMA ::= @b{pragma} Priority ([Policy =>] PRIORITY_POLICY_LITERAL); @end smallexample @itemize @bullet @item The default policy Client_Propagated consists in propagating the client priority to the server. @item The policy Server_Declared consists in executing the remote procedure call at a priority specific to the partition. This priority can be set using the partition attribute Priority. @end itemize @node Partition Attribute Priority, Partition Attribute Host, Pragma Priority, The Configuration Language @subsubsection Partition Attribute Priority This attribute allows to set the priority at which level a remote procedure call is executed on a server when the priority policy is Server_Declared. By default, the default priority of the anonymous task is the default task priority. @smallexample REPRESENTATION_CLAUSE ::= @b{for} PARTITION_IDENTIFIER'Priority @b{use} INTEGER_LITERAL; @end smallexample @node Partition Attribute Host, Pragma Import, Partition Attribute Priority, The Configuration Language @subsubsection Partition Attribute Host Logical nodes (or partitions) can be mapped onto physical nodes. The host-name can be either a static or dynamic value. In case of a static value, the expression is a string literal. In case of a dynamic value, the representation clause argument is a function that accepts a string as parameter and that returns a string value. When the function is called, the partition name is passed as parameter and the host-name is returned. @smallexample FUNCTION_DECLARATION ::= @b{function} FUNCTION_IDENTIFIER (PARAMETER_IDENTIFIER : [@b{in}] String) @b{return} String; REPRESENTATION_CLAUSE ::= @b{for} PARTITION_IDENTIFIER'Host @b{use} STRING_LITERAL; | @b{for} PARTITION_IDENTIFIER'Host @b{use} FUNCTION_IDENTIFIER; @end smallexample The signature of the function must be the following : it takes a string parameter which corresponds to a partition name. It returns a string parameter which corresponds to the host-name. The function that returns the host-name can be an Ada function (default) or a shell script. A pragma Import is used to import a function defined in Ada or in Shell (see @ref{Pragma Import}). This function is called on the main partition by the PCS to launch a given partition on a given logical node. In case of load balancing, the function can return the most appropriate among a set of hosts. @node Pragma Import, Partition Attribute Directory, Partition Attribute Host, The Configuration Language @subsubsection Pragma Import Two kinds of subprograms are allowed in the configuration language. A main procedure is used as a partition Main attribute and a function is used as a partition Host attribute. @smallexample PROCEDURE_DECLARATION ::= @b{procedure} PROCEDURE_IDENTIFIER; FUNCTION_DECLARATION ::= @b{function} FUNCTION_IDENTIFIER (PARAMETER_IDENTIFIER : [@b{in}] String) @b{return} String; @end smallexample The function can be an Ada function (default) or a shell script. To import a shell script, the pragma Import must be used: @smallexample PRAGMA ::= @b{pragma} Import ([Entity =>] FUNCTION_IDENTIFIER, [Convention =>] CONVENTION_LITERAL, [External_Name =>] STRING_LITERAL); @b{pragma} Import (Best_Node, Shell, "best-node"); @end smallexample In this case, the PCS invokes the shell script with the partition name as a command line argument. The shell script is supposed to return the partition host-name (see @ref{Partition Attribute Host}). @node Partition Attribute Directory, Partition Attribute Command_Line, Pragma Import, The Configuration Language @subsubsection Partition Attribute Directory Directory allows the user to specify in which directory the partition executable is stored. This can be useful in heterogeneous systems when the user wants to store executables for the same target in a given directory. Specifying the directory is also useful if the partition executable is not directly visible from the user environment. For instance, when a remote command like @b{rsh} is invoked, the executable directory has to be present in the user path. If the Directory attribute has been specified, the executable full name is used. @smallexample REPRESENTATION_CLAUSE ::= @b{for} PARTITION_IDENTIFIER'Directory @b{use} STRING_LITERAL; @end smallexample @node Partition Attribute Command_Line, Partition Attribute Environment_Variables, Partition Attribute Directory, The Configuration Language @subsubsection Partition Attribute Command_Line The user may want to pass arguments on the command line of a partition. However, when a partition is launched automatically by the main partition, the partition command line includes only PolyORB arguments. To add arguments on the command line, the user can take advantage of the following attribute. @smallexample REPRESENTATION_CLAUSE ::= @b{for} PARTITION_IDENTIFIER'Command_Line @b{use} STRING_LITERAL; @end smallexample @node Partition Attribute Environment_Variables, Partition Attribute Termination, Partition Attribute Command_Line, The Configuration Language @subsubsection Partition Attribute Environment_Variables The attribute Environment_Variables allows the user to specify a list of environment variables that should be passed from the main partition to slave partitions when using a generated (shell or Ada) launcher. This attribute can be applied to all partitions by defining it for the predefined type @b{Partition}, or to a specific partition. Note that in the latter case, the list does not replace the default one but instead complements it (i.e. variables specified for @b{Partition} are passed in addition to the partition specific ones). Use of this features requires that remote nodes provide the POSIX env(1) command. @smallexample STRING_LITERAL_LIST ::= STRING_LITERAL | STRING_LITERAL@b{,} STRING_LITERAL_LIST REPRESENTATION_CLAUSE ::= @b{for} PARTITION_IDENTIFIER'Environment_Variables @b{use (}STRING_LITERAL_LIST@b{);} @end smallexample @node Partition Attribute Termination, Partition Attribute Reconnection, Partition Attribute Environment_Variables, The Configuration Language @subsubsection Partition Attribute Termination The Ada Reference Manual does not provide any specific rule to handle global termination of a distributed application (see @ref{Abortion and Termination}). In PolyORB/DSA, by default, a set of partitions terminates when each partition can terminate and when no message remains to be delivered. A distributed algorithm that checks for this global condition is activated periodically by the main boot server. @smallexample TERMINATION_LITERAL ::= Global_Termination | Local_Termination | Deferred_Termination REPRESENTATION_CLAUSE ::= @b{for} PARTITION_IDENTIFIER'Termination @b{use} TERMINATION_LITERAL; @end smallexample @itemize @bullet @item When a partition is configured with the global termination policy, it terminates as soon as the main boot server sends a signal to do so. The main boot server checks periodically whether the application can terminate. When all partitions are ready to terminate, the main boot server sends to each partition a termination request. The global termination policy is the default policy. @item The deferred termination policy is very similar to the global termination. The only difference is that when a partition with a deferred termination policy receives a termination request, it just ignores it. This policy allows a partition to run forever without preventing a set of partitions from terminating. @item When a partition is configured with the local termination policy, it terminates as soon as the classical Ada termination is detected by the partition. It means that this partition does not wait for the termination request of the main boot server. @end itemize @c GARLIC-specific @c In any case, when the boot partition dies (and when no alternate boot @c partition can elected, see @ref{The GARLIC PCS}), all the @c partitions die, whatever their termination policy might be. Note first, @c that a partition cannot execute without a boot partition. Second, when @c the user wants to kill his non-distributed application, he kills the @c main program. Enforcing the mechanism described above ensures that @c killing the main partition automatically kills all the partitions, that @c is to say the whole distributed application. @node Partition Attribute Reconnection, Pragma Version, Partition Attribute Termination, The Configuration Language @subsubsection Partition Attribute Reconnection When no RCI package is configured on a partition, such a partition can be launched several times without any problem. When one or more RCI packages are configured on a partition, such a partition cannot be launched more than once. If this partition were to be launched repeatedly, it would not be possible to decide which partition instance should execute a remote procedure call. When a partition crashes or is stopped, one may want to restart this partition and possibly restore its state - with Shared_Passive packages, for instance. In such a situation, the partition is already known to other partitions and possibly marked as a dead partition. Several policies can be selected: @smallexample RECONNECTION_LITERAL ::= Reject_On_Restart | Fail_Until_Restart | Block_Until_Restart REPRESENTATION_CLAUSE ::= @b{for} PARTITION_IDENTIFIER'Reconnection @b{use} RECONNECTION_LITERAL; @end smallexample @itemize @bullet @item When this partition is configured with the Reject_On_Restart reconnection policy, the dead partition is kept dead and any attempt to restart it fails. Any remote call to a subprogram located on this partition results in a Communication_Error exception. The Reject_On_Restart policy is the default policy. @item When this partition is configured with the Fail_Until_Restart reconnection policy, the dead partition can be restarted. Any remote call to a subprogram located on this partition results in an exception Communication_Error as long as this partition has not been restarted. As soon as the partition is restarted, remote calls to this partition are executed normally. @item When this partition is configured with the Block_Until_Restart reconnection policy, the dead partition partition can be restarted. Any remote call to a subprogram located on this partition is suspended until the partition is restarted. As soon as the partition is restarted, remote calls to this partition are executed normally. The suspended remote procedure calls to this partition are resumed. @end itemize @node Pragma Version, Partition Attribute Task_Pool, Partition Attribute Reconnection, The Configuration Language @subsubsection Pragma Version A library unit is consistent if the same version of its declaration is used throughout (see @ref{Consistency and Elaboration}). It can be useful to deactivate these checks, especially when the user wants to be able to update a server without updating a client. @smallexample PRAGMA ::= @b{pragma} Version ([Check =>] BOOLEAN_LITERAL); @end smallexample @node Partition Attribute Task_Pool, Partition Attribute ORB_Tasking_Policy, Pragma Version, The Configuration Language @subsubsection Partition Attribute Task_Pool When multiple remote subprogram calls occur on the same partition, they are handled by several anonymous tasks. These tasks can be allocated dynamically or re-used from a pool of (preallocated) tasks. When a remote subprogram call is completed, the anonymous task can be deallocated or queued in a pool in order to be re-used for further remote subprogram calls. The number of tasks in the anonymous tasks pool can be configured by means of three independent parameters. @itemize @bullet @item The task pool minimum size indicates the number of anonymous tasks preallocated and always available in the PCS. Preallocating anonymous tasks can be useful in real-time systems to prevent task dynamic allocation. @item The task pool high size is a ceiling. When a remote subprogram call is completed, its anonymous task is deallocated if the number of tasks already in the pool is greater than the ceiling. If not, then the task is queued in the pool. @item The task pool maximum size indicates the maximum number of anonymous tasks in the PCS. In other words, it provides a way to limit the number of remote calls in the PCS. When a RPC request is received, if the number of active remote calls is greater than the task pool maximum size, then the request is kept pending until an anonymous task completes its own remote call and becomes available. @end itemize @smallexample REPRESENTATION_CLAUSE ::= @b{for} PARTITION_IDENTIFIER'Task_Pool @b{use} TASK_POOL_SIZE_ARRAY; TASK_POOL_SIZE_ARRAY ::= (NATURAL_LITERAL, @i{-- Task Pool Minimum Size} NATURAL_LITERAL, @i{-- Task Pool High Size} NATURAL_LITERAL); @i{-- Task Pool Maximum Size} @end smallexample In order to have only one active remote call at a time, the task pool configuration is declared as follows: @smallexample @b{for} Partition'Task_Pool @b{use} (0, 0, 1); @end smallexample @node Partition Attribute ORB_Tasking_Policy, A Complete Example, Partition Attribute Task_Pool, The Configuration Language @subsubsection Partition Attribute ORB_Tasking_Policy By default, the Thread_Pool ORB tasking policy is used for all partitions. This attribute allows selection of an alternate policy among those provided by PolyORB (see @ref{PolyORB ORB Tasking policies}) for each partition. @smallexample ORB_TASKING_POLICY_LITERAL ::= Thread_Pool | Thread_Per_Session | Thread_Per_Request REPRESENTATION_CLAUSE ::= @b{for} PARTITION_IDENTIFIER'ORB_Tasking_Policy @b{use} ORB_TASKING_POLICY_LITERAL; @end smallexample @i{Note: @ref{Partition Attribute Task_Pool} has no effect when another policy than Thread_Pool is activated.} @node A Complete Example, , Partition Attribute ORB_Tasking_Policy, The Configuration Language @subsubsection A Complete Example Almost every keyword and construct defined in the configuration language has been used in the following sample configuration file. @include myconfig.cfg.texi @enumerate @item @b{Line 01} Typically, after having created the following configuration file the user types: @smallexample po_gnatdist myconfig.cfg @end smallexample If the user wants to build only some partitions then he will list the partitions to build on the @t{po_gnatdist} command line as follows: @smallexample po_gnatdist myconfig.cfg partition_2 partition_3 @end smallexample The name of the file prefix must be the same as the name of the configuration unit, in this example @t{myconfig.cfg}. The file suffix must be @t{cfg}. For a given distributed application the user can have as many different configuration files as desired. @item @b{Line 04} Partition 1 contains no RCI package. However, it will contain the main procedure of the distributed application, called @i{Master_Procedure} in this example. If the line @i{procedure Master_Procedure is in Partition_1;} was missing, Partition 1 would be completely empty. This is forbidden, because a partition has to contain at least one library unit. @t{po_gnatdist} produces an executable with the name of @i{Master_Procedure} which will start the various partitions on their host machines in the background. The main partition is launched in foreground. Note that by killing this main procedure the whole distributed application is terminated. @item @b{Line 08} Specify the host on which to run partition 2. @item @b{Line 12} Use the value returned by a program to figure out at execution time the name of the host on which partition 3 should execute. For instance, execute the shell script @t{best-node} which takes the partition name as parameter and returns a string giving the name of the machine on which partition_3 should be launched. @item @b{Line 14} Partition 4 contains one RCI package RCI_B5 No host is specified for this partition. The startup script will ask for it interactively when it is executed. @item @b{Line 16} Specify the directory in which the executable of partition partition_1 will be stored. @item @b{Line 17} Specify the directory in which all the partition executables will be stored (except partition_1, see @ref{Pragmas and Representation Clauses}). Default is the current directory. @item @b{Line 20} Specify the partition main subprogram to use in a given partition. @item @b{Line 22} Specify a reconnection policy in case of a crash of Partition_3. Any attempt to reconnect to Partition_3 when this partition is dead will be blocked until Partition_3 restarts. By default, any restart is rejected (Reject_On_Restart). Another policy is to raise Communication_Error on any reconnection attempt until Partition_3 has been restarted. @item @b{Line 23} Specify additional arguments to pass on the command line when a given partition is launched. @item @b{Line 24} Specify a termination mechanism for partition_4. The default is to compute a global distributed termination. When Local_Termination is specified a partition terminates as soon as local termination is detected (standard Ada termination). @item @b{Line 26} Specify the kind of startup method the user wants. There are 3 possibilities: Shell, Ada and None. Specifying @i{Shell} builds a shell script. All the partitions will be launched from a shell script. If @i{Ada} is chosen, then the main Ada procedure itself is used to launch the various partitions. If method @i{None} is chosen, then no launch method is used and the user must start each partition manually. If no starter is given, then an Ada starter will be used. In this example, Partition_2, Partitions_3 and Partition_4 will be started from Partition_1 (ie from the Ada procedure Master_Procedure). @item @b{Line 30} Specify the use of a particular boot server. @item @b{Line 32} It is a bounded error to elaborate a partition of a distributed program that contains a compilation unit that depends on a different version of the declaration of an RCI library unit than the one included in the partition to which the RCI library unit was assigned. When the pragma Version is set to False, no consistency check is performed. @item @b{Line 34} The configuration body is optional. The user may have fully described his configuration in the declaration part. @item @b{Line 35} Partition 2 contains two RCI packages RCI_B2 and RCI_B4 and a normal package. A normal package is not categorized. @item @b{Line 36} Partition 3 contains one RCI package RCI_B3 @end enumerate @node Partition Runtime Parameters, Gnatdist Internals, The Configuration Language, Building a DSA application with PolyORB @subsection Partition Runtime Parameters @noindent You can adjust some parameters of your DSA applications using the PolyORB configuration file, @file{polyorb.conf}. The parameters relevant to the Ada Distributed Systems Annex are specified in the @code{[dsa]} section. See @ref{Run-time configuration} for complete documentation of PolyORB's runtime configuration facilities. @table @code @item name_service = [IOR/corbaloc] You can set this parameter instead of the environment variable @code{POLYORB_DSA_NAME_SERVICE}. Though if you use a Starter, ensure that this parameter is set for all the partitions, as this is not done automatically as for the @code{POLYORB_DSA_NAME_SERVICE} environment variable. @item max_failed_requests = [integer] Each partition will attempt a given number of requests to the name server before failing. This allows some time for every partition to register in the name server. @item delay_between_failed_requests = [duration in milliseconds] As above, only this specifies the delay between requests. @item termination_initiator = [true/false] Is this partition a termination initiator. @item termination_policy = [global_termination/deferred_termination/local_termination] The termination policy for this partition. @item tm_time_between_waves = [duration in milliseconds] The delay between termination waves. @item tm_time_before_start = [duration in milliseconds] The delay before the termination manager starts sending waves. @item detach = [true/false] If true, the partition will be detached. @item rsh_options = [string] Options passed to the rsh command when using the module polyorb.dsa_p-remote_launch @item rsh_command = [string] Which command should the module polyorb.dsa_p-remote_launch use to spawn remote programs. @end table @node Gnatdist Internals, PolyORB PCS Internals, Partition Runtime Parameters, Building a DSA application with PolyORB @subsection Gnatdist Internals Here is what goes on in @t{po_gnatdist} when building a distributed application: @itemize @bullet @item Each compilation unit in the program is compiled into an object module (as for non distributed applications). This is achieved by calling gnatmake on the sources of the various partitions. @item Stubs and skeletons are compiled into object modules (these are pieces of code that allow a partition running on machine A to communicate with a partition running on machine B). Several timestamp checks are performed to avoid useless code recompilation and stub generation. @item @t{po_gnatdist} performs a number of consistency checks. For instance it checks that all packages marked as remote call interface (RCI) and shared passive (SP) are mapped onto partitions. It also checks that a RCI or SP package is mapped onto only one partition. @item Finally, the executables for each partition in the program are created. The code to launch partitions is embedded in the main partition except if another option has been specified (see @ref{Pragma Starter}). In this case, a shell script (or nothing) is generated to start the partitions on the appropriate machines. This is specially useful when one wants to write client / server applications where the number of instances of the partition is unknown. @end itemize All Gnatdist intermediate files (object files, etc) are stored under a common directory named "dsa". The user may remove this whole directory and its content when he does not intend to rebuild his distributed applications. @node PolyORB PCS Internals, Remote Shell Notes, Gnatdist Internals, Building a DSA application with PolyORB @subsection PolyORB PCS Internals This section provides notes on the PolyORB implementation of the DSA PCS. Some of these features are not configurable by the user. @menu * Application startup * Heterogeneous System:: * Allocating Partition Ids:: * Executing Concurrent Remote Calls:: * Priority Inheritance:: * Remote Call Abortion:: @end menu @node Application Startup, Heterogeneous System, PolyORB PCS Internals, PolyORB PCS Internals @subsubsection Application Startup A name server needs to be started prior to starting any application partition. Once the name server is started, its location must be passed to all partitions as the @t{name_service} runtime parameter in the @t{[dsa]} section of the configuration. When using an Ada starter, it is sufficient to pass the name server location to the starter, and it will be propagated automatically to all partitions. Upon elaboration, each partition registers its RCI packages with the name server. Once this is done, remote calls to RCI subprograms can proceed. Partitions cache the replies from the name server so that during the course of normal execution, inter-partition calls only involve the caller and callee partitions (not the name server). RCI units can then act as ``clearinghouses'' for other partitions to exchange RACWs and set up dynamic communication paths. @node Heterogeneous System, Allocating Partition Ids, Application Startup, PolyORB PCS Internals @subsubsection Heterogeneous System The GNAT environment provides default stream attributes, except for non-remote access types (see @ref{Transmitting Dynamic Structure} and @ref{Marshalling and Unmarshalling Operations}). The implementation of the default attributes of predefined types can be found in @i{System.Stream_Attributes} (s-stratt.adb). The PolyORB PCS provides alternative data representations by default to ensure portability of the data stream across partitions executing on heterogeneous architectures. Users may override these representation aspects by configuring the protocol personality of their choice. @node Allocating Partition Ids, Executing Concurrent Remote Calls, Heterogeneous System, PolyORB PCS Internals @subsubsection Allocating Partition Ids The Partition_ID is allocated dynamically, at run-time. Each partition connects to a Partition ID Server which is located on the boot server and asks for a free Partition_ID. The advantage of this approach is that it supports easily client / server solution (client partitions may be duplicated, they will obtain different Partition Ids). There is no need to recompile or relink all the partitions when a new partition is added to the system. The Partition_ID is not tied in any way to a specific protocol or to a specific location. @node Executing Concurrent Remote Calls, Priority Inheritance, Allocating Partition Ids, PolyORB PCS Internals @subsubsection Executing Concurrent Remote Calls When multiple remote subprogram calls occur on the same partition, they are handled by several anonymous tasks. The number of tasks in the anonymous tasks pool can be configured by three figures (see @ref{Partition Attribute Task_Pool}). Therefore, the user may have to synchronize global data in the Remote_Call_Interface or Remote_Types unit to preserve concurrent access on data. If the user want to suppress the multiple requests features, he can force the configuration of the anonymous tasks pool to (0 | 1, 0 | 1, 1). That means that there will be at most one anonymous task running at a time. @node Priority Inheritance, Remote Call Abortion, Executing Concurrent Remote Calls, PolyORB PCS Internals @subsubsection Priority Inheritance @c Is this implemented in PolyORB/DSA??? It is compiler-dependent whether the caller priority is preserved during a remote procedure call. In fact, it can be unsafe to rely on priorities, because two partitions may have different priority ranges and policies. Nevertheless, PolyORB preserves the caller priority. This priority is marshaled and unmarshaled during the remote procedure call and the priority of the anonymous task on the server is set to the caller priority. This default policy can be modified by using pragma Priority @ref{Pragma Priority} and partition attribute Priority @ref{Partition Attribute Priority}. @node Remote Call Abortion, , Priority Inheritance, PolyORB PCS Internals @subsubsection Remote Call Abortion When a remote procedure call is aborted, PolyORB will abort the calling task on the caller side. It will also try to abort the remote anonymous task performing the remote call, unless runtime parameter @code{abortable_rpcs} in section @code{[tasking]} is set False on the server. @c ------------------------------------------------------------------- @node Running a DSA application @section Running a DSA application @c ------------------------------------------------------------------- By default @command{po_gnatdist} will use the Ada starter. So if you have not specified @code{pragma Starter (None);} in the @command{po_gnatdist} configuration file, you should have a starter in your build directory, named after the main procedure defined in the configuration file. In this case you just have to run this program. If you don't want to use the Starter and have specified @code{pragma Starter (None);} in your configuration file, then you should have, in your Partition'Directory, one binary for each of your partitions. You'll have to start each of these programs manually. In both cases you must specify a name server for your application. You can use for example the one included in PolyORB: @file{po_cos_naming}. When running this name server it will output its IOR URI named @code{POLYORB_CORBA_NAME_SERVICE}. Just ensure that you set the global environment variable @code{POLYORB_DSA_NAME_SERVICE} to an IOR URI referencing the running name server. When using the @file{po_cos_naming} name server just set @code{POLYORB_DSA_NAME_SERVICE} environment variable to the first value output for @code{POLYORB_DSA_NAME_SERVICE} before launching each DSA partition. Here is a small trace output that demonstrates the setup @smallexample polyorb/examples/dsa/echo% ../../../tools/po_cos_naming/po_cos_naming& polyorb/examples/dsa/echo% POLYORB_CORBA_NAME_SERVICE=''....'' polyorb/examples/dsa/echo% export POLYORB_DSA_NAME_SERVICE=''...'' polyorb/examples/dsa/echo% ./client The client has started! Thus spake my server upon me:Hi! @end smallexample @c ------------------------------------------------------------------- @node MOMA @chapter MOMA @cindex MOMA, Message Oriented Middleware for Ada @c ------------------------------------------------------------------- @menu * What you should know before Reading this section4:: * Installing MOMA application personality:: * Package hierarchy:: @end menu @c ------------------------------------------------------------------- @node What you should know before Reading this section4 @section What you should know before Reading this section @c ------------------------------------------------------------------- @noindent This section assumes that the reader is familiar with the JMS specifications described in @cite{[SUN99]}. MOMA is a thick adaptation of the JMS specification to the Ada programming language, preserving most of the JMS concepts. @c ------------------------------------------------------------------- @node Installing MOMA application personality @section Installing MOMA application personality @c ------------------------------------------------------------------- @noindent Ensure PolyORB has been configured and then compiled with the MOMA application personality. See @ref{Building an application with PolyORB} for more details on how to check installed personalities. To build the MOMA application personality, @pxref{Installation}. @c ------------------------------------------------------------------- @node Package hierarchy @section Package hierarchy @c ------------------------------------------------------------------- @noindent Packages installed in @file{$INSTALL_DIR/include/polyorb/moma} hold the MOMA API. MOMA is built around two distinct sets of packages: @enumerate @item @file{MOMA.*} hold the public MOMA library, all the constructs the user may use. @item @file{POLYORB.MOMA_P.*} hold the private MOMA library, these packages shall not be used when building your application. @end enumerate @c ------------------------------------------------------------------- @node AWS @chapter Ada Web Server (AWS) @cindex AWS, Ada Web Server @c ------------------------------------------------------------------- @noindent @i{The documentation of this personality will appear in a future revision of PolyORB.} @c ------------------------------------------------------------------- @node GIOP @chapter GIOP @cindex GIOP @c ------------------------------------------------------------------- @menu * Installing GIOP protocol personality:: * GIOP Instances:: * Configuring the GIOP personality:: * Code sets:: @end menu @c ------------------------------------------------------------------- @node Installing GIOP protocol personality @section Installing GIOP protocol personality @c ------------------------------------------------------------------- @noindent Ensure PolyORB has been configured and then compiled with the GIOP protocol personality. See @ref{Building an application with PolyORB} for more details on how to check installed personalities. To enable configuration of the GIOP protocol personality, @pxref{Installation}. @c ------------------------------------------------------------------- @node GIOP Instances @section GIOP Instances @c ------------------------------------------------------------------- @noindent GIOP is a generic protocol that can be instantiated for multiple transport stacks. PolyORB provides three different instances. @menu * IIOP:: * SSLIOP:: * DIOP:: * MIOP:: @end menu @c ------------------------------------------------------------------- @node IIOP @subsection IIOP @cindex IIOP @c ------------------------------------------------------------------- @noindent Internet Inter-ORB Protocol (IIOP) is the default protocol defined by the CORBA specifications. It is a TCP/IP, IPv4, based protocol that supports the full semantics of CORBA requests. @c ------------------------------------------------------------------- @node SSLIOP @subsection SSLIOP @cindex SSLIOP @c ------------------------------------------------------------------- @noindent The SSLIOP protocol provides transport layer security for transmitted requests. Its provides encryption of GIOP requests. To build the SSLIOP, it is required to activate SSL-related features when building PolyORB. See @option{--with-openssl} in @ref{Installation} for more details. Enabling security is completely transparent to a preexisting application, it is also possible to phase in secure communications by allowing incoming requests which are unsecured. @c ------------------------------------------------------------------- @node DIOP @subsection DIOP @cindex DIOP @c ------------------------------------------------------------------- @noindent Datagram Inter-ORB Protocol (DIOP) is a specialization of GIOP for the UDP/IP protocol stack. It supports only asynchronous (@code{oneway}) requests. This protocol is specific to PolyORB. DIOP 1.0 is a mapping of GIOP on top of UDP/IP. DIOP 1.0 uses GIOP 1.2 message format. @c ------------------------------------------------------------------- @node MIOP @subsection MIOP @cindex MIOP @c ------------------------------------------------------------------- @noindent Unreliable Multicast Inter-ORB Protocol (MIOP) @cite{[OMG02b]} is a specialization of GIOP for IP/multicast protocol stack. It supports only asynchronous (@code{oneway}) requests. @c ------------------------------------------------------------------- @node Configuring the GIOP personality @section Configuring the GIOP personality @cindex Configuration, GIOP @c ------------------------------------------------------------------- @noindent The GIOP personality is configured using a configuration file. See @ref{Using a configuration file} for more details. Here is a summary of available parameters for each instance of GIOP. @menu * Common configuration parameters:: * IIOP Configuration Parameters:: * SSLIOP Configuration Parameters:: * DIOP Configuration Parameters:: * MIOP Configuration Parameters:: @end menu @c ------------------------------------------------------------------- @node Common configuration parameters @subsection Common configuration parameters @cindex GIOP @c ------------------------------------------------------------------- @noindent This section details configuration parameters common to all GIOP instances. @smallexample ############################################################################### # GIOP parameters # [giop] ############################################################### # Native code sets # # Available char data code sets: # 16#00010001# ISO 8859-1:1987; Latin Alphabet No. 1 # 16#05010001# X/Open UTF-8; UCS Transformation Format 8 (UTF-8) # # Available wchar data code sets: # 16#00010100# ISO/IEC 10646-1:1993; UCS-2, Level 1 # 16#00010109# ISO/IEC 10646-1:1993; # UTF-16, UCS Transformation Format 16-bit form # #giop.native_char_code_set=16#00010001# #giop.native_wchar_code_set=16#00010100# # # The following parameters force the inclusion of fallback code sets # as supported conversion code sets. This is required to enable # interoperability with ORBs whose code sets negotiation support is # broken. See PolyORB's Users Guide for additional information. # #giop.add_char_fallback_code_set=false #giop.add_wchar_fallback_code_set=false @end smallexample @c ------------------------------------------------------------------- @node IIOP Configuration Parameters @subsection IIOP Configuration Parameters @c ------------------------------------------------------------------- @c check consistency with polyorb.conf @smallexample ############################################################################### # IIOP parameters # [iiop] ############################################################### # IIOP Global Settings # Preference level for IIOP #polyorb.binding_data.iiop.preference=0 # IIOP's default address #polyorb.protocols.iiop.default_addr=127.0.0.1 # IIOP's default port #polyorb.protocols.iiop.default_port=2809 # IIOP's alternate addresses #polyorb.protocols.iiop.alternate_listen_addresses=127.0.0.1:2810 127.0.0.1:2820 # Default GIOP/IIOP Version #polyorb.protocols.iiop.giop.default_version.major=1 #polyorb.protocols.iiop.giop.default_version.minor=2 ############################################################### # IIOP 1.2 specific parameters # Set to True to enable IIOP 1.2 #polyorb.protocols.iiop.giop.1.2.enable=true # Set to True to send a locate message prior to the request #polyorb.protocols.iiop.giop.1.2.locate_then_request=true # Maximum message size before fragmenting request #polyorb.protocols.iiop.giop.1.2.max_message_size=1000 ############################################################### # IIOP 1.1 specific parameters # Set to True to enable IIOP 1.1 #polyorb.protocols.iiop.giop.1.1.enable=true # Set to True to send a locate message prior to the request #polyorb.protocols.iiop.giop.1.1.locate_then_request=true # Maximum message size before fragmenting request #polyorb.protocols.iiop.giop.1.1.max_message_size=1000 ############################################################### # IIOP 1.0 specific parameters # Set to True to enable IIOP 1.0 #polyorb.protocols.iiop.giop.1.0.enable=true # Set to True to send a locate message prior to the request #polyorb.protocols.iiop.giop.1.0.locate_then_request=true @end smallexample @c ------------------------------------------------------------------- @node SSLIOP Configuration Parameters @subsection SSLIOP Configuration Parameters @c ------------------------------------------------------------------- @menu * Ciphers name:: * SSLIOP Parameters:: @end menu @c ------------------------------------------------------------------- @node Ciphers name @subsubsection Ciphers name @c ------------------------------------------------------------------- PolyORB's SSLIOP uses the OpenSSL library to support all ciphers recommended by CORBA 3.0.3. The OpenSSL library uses specific names for ciphers. The table below contains CORBA-recommended cipher names and their OpenSSL equivalents: @multitable @columnfractions .6 .4 @item CORBA recommended ciphers @tab OpenSSL equivalent @item TLS_RSA_WITH_RC4_128_MD5 @tab RC4-MD5 @item SSL_RSA_WITH_RC4_128_MD5 @tab RC4-MD5 @item TLS_DHE_DSS_WITH_DES_CBC_SHA @tab EDH-DSS-CBC-SHA @item SSL_DHE_DSS_WITH_DES_CBC_SHA @tab EDH-DSS-CBC-SHA @item TLS_RSA_EXPORT_WITH_RC4_40_MD5 @tab EXP-RC4-MD5 @item SSL_RSA_EXPORT_WITH_RC4_40_MD5 @tab EXP-RC4-MD5 @item TLS_DHE_DSS_EXPORT_WITH_DES40_CBC_SHA @tab EXP-EDH-DSS-DES-CBC-SHA @item SSL_DHE_DSS_EXPORT_WITH_DES40_CBC_SHA @tab EXP-EDH-DSS-DES-CBC-SHA @end multitable @c ------------------------------------------------------------------- @node SSLIOP Parameters @subsubsection SSLIOP Parameters @c ------------------------------------------------------------------- @c check consistency with polyorb.conf @smallexample ############################################################################### # SSLIOP parameters # [ssliop] ############################################################### # SSLIOP Global Settings # SSLIOP's default port #polyorb.protocols.ssliop.default_port=2810 # If no SSLIOP default address is provide, PolyORB reuses IIOP's # address # Private Key file name #polyorb.protocols.ssliop.privatekeyfile=privkey.pem # Certificate file name #polyorb.protocols.ssliop.certificatefile=cert.pem # Trusted CA certificates file #polyorb.protocols.ssliop.cafile=cacert.pem # Trusted CA certificates path #polyorb.protocols.ssliop.capath=demoCA/certs # Disable unprotected invocations #polyorb.protocols.ssliop.disable_unprotected_invocations=true ############################################################### # Peer certificate verification mode # Verify peer certificate #polyorb.protocols.ssliop.verify=false # Fail if client did not return certificate. (server side option) #polyorb.protocols.ssliop.verify_fail_if_no_peer_cert=false # Request client certificate only once. (server side option) #polyorb.protocols.ssliop.verify_client_once=false @end smallexample @c ------------------------------------------------------------------- @node DIOP Configuration Parameters @subsection DIOP Configuration Parameters @c ------------------------------------------------------------------- @c check consistency with polyorb.conf @smallexample ############################################################### # DIOP Global Settings # Preference level for DIOP #polyorb.binding_data.diop.preference=0 # DIOP's default address #polyorb.protocols.diop.default_addr=127.0.0.1 # DIOP's default port #polyorb.protocols.diop.default_port=12345 # Default GIOP/DIOP Version #polyorb.protocols.diop.giop.default_version.major=1 #polyorb.protocols.diop.giop.default_version.minor=2 ############################################################### # DIOP 1.2 specific parameters # Set to True to enable DIOP 1.2 #polyorb.protocols.diop.giop.1.2.enable=true # Maximum message size #polyorb.protocols.diop.giop.1.2.max_message_size=1000 ############################################################### # DIOP 1.1 specific parameters # Set to True to enable DIOP 1.1 #polyorb.protocols.diop.giop.1.1.enable=true # Maximum message size #polyorb.protocols.diop.giop.1.1.max_message_size=1000 ############################################################### # DIOP 1.0 specific parameters # Set to True to enable DIOP 1.0 #polyorb.protocols.diop.giop.1.0.enable=true @end smallexample @c ------------------------------------------------------------------- @node MIOP Configuration Parameters @subsection MIOP Configuration Parameters @c ------------------------------------------------------------------- @c check consistency with polyorb.conf @smallexample ############################################################################### # MIOP parameters # [miop] ############################################################### # MIOP Global Settings # Preference level for MIOP #polyorb.binding_data.uipmc.preference=0 # Maximum message size #polyorb.miop.max_message_size=6000 # Time To Leave parameter #polyorb.miop.ttl=15 # Multicast address to use # These two parameters must be set explicitly, no default value is provided. # If either parameter is unset, the MIOP access point is disabled. #polyorb.miop.multicast_addr= #polyorb.miop.multicast_port= # Set to True to enable MIOP #polyorb.protocols.miop.giop.1.2.enable=false # Maximum message size #polyorb.protocols.miop.giop.1.2.max_message_size=1000 @end smallexample @c ------------------------------------------------------------------- @node Code sets @section Code sets @cindex Code sets, GIOP @c ------------------------------------------------------------------- @noindent This sections details the various steps required to add support for new character code sets to PolyORB's GIOP personality. Please refer to the CORBA specifications (@cite{[OMG04]}), par. 13.10 for more details on this topic. @menu * Supported code sets:: * Incompatibility in code set support:: * Adding support for new code sets:: * Character data Converter:: * Converters factories:: * Registering new code sets:: @end menu @c ------------------------------------------------------------------- @node Supported code sets @subsection Supported code sets @c ------------------------------------------------------------------- @noindent PolyORB supports the following list of code sets: @enumerate @item Available char data code sets: @enumerate @item 16#00010001# ISO 8859-1:1987; Latin Alphabet No. 1 @item 16#05010001# X/Open UTF-8; UCS Transformation Format 8 (UTF-8) @end enumerate @item Available wchar data code sets: @enumerate @item 16#00010100# ISO/IEC 10646-1:1993; UCS-2, Level 1 @item 16#00010109# ISO/IEC 10646-1:1993; UTF-16, UCS Transformation Format 16-bit form @end enumerate @end enumerate @c ------------------------------------------------------------------- @node Incompatibility in code set support @subsection Incompatibility in code set support @c ------------------------------------------------------------------- @noindent Some ORBs report incompatiblity in code sets because fallback converters are not explicitly present in the reference. To work around this issue, you may use the following parameters: @smallexample [giop] giop.add_char_fallback_code_set=true giop.add_wchar_fallback_code_set=true @end smallexample @c ------------------------------------------------------------------- @node Adding support for new code sets @subsection Adding support for new code sets @c ------------------------------------------------------------------- PolyORB allows users to extend the set of supported native character code sets. Adding support for new character code set consists of the following steps: @enumerate @item Developing sets of Converters - special objects that do marshalling/unmarshalling operations of character data. At least two Converters are required: for direct marshalling character data in native code set and for marshalling/unmarshalling character data in fallback character code set (UTF-8 for char data and UTF-16 for wchar data). Additional Converters may be developed for marshalling character data in conversion code set. @item Developing converter factory subprogram for each Converter. @item Registering native code set, its native and fallback converters and optional conversion char sets and its converters. @end enumerate @c ------------------------------------------------------------------- @node Character data Converter @subsection Character data Converter @c ------------------------------------------------------------------- Character data converters do direct marshalling/unmarshalling of character data (char or wchar - depending on @code{Converter}) into/from PolyORB's buffer. This allows to minimize the speed penalty on character data marshalling. Character data Converters for char data have the following API (from @file{PolyORB.GIOP_P.Code_Sets.Converters} package: @smallexample type Converter is abstract tagged private; procedure Marshall (C : Converter; Buffer : access Buffers.Buffer_Type; Data : Types.Char; Error : in out Errors.Error_Container) is abstract; procedure Marshall (C : Converter; Buffer : access Buffers.Buffer_Type; Data : Types.String; Error : in out Errors.Error_Container) is abstract; procedure Unmarshall (C : Converter; Buffer : access Buffers.Buffer_Type; Data : out Types.Char; Error : in out Errors.Error_Container) is abstract; procedure Unmarshall (C : Converter; Buffer : access Buffers.Buffer_Type; Data : out Types.String; Error : in out Errors.Error_Container) is abstract; @end smallexample The Marshall subprograms do marshalling of one character or string of characters into the buffer. The Unmarshall subprograms do unmarshalling of one character or string of characters from the buffer. @i{Note: Depending on the item size of the data (char/wchar) and GIOP version, marshalling/unmarshalling algorithms may vary. In some situations marshalling of string is not equivalent to marshalling its length and marshalling one by one each character. Please refere to GIOP specifications for more details.} If marshalling/unmarshalling fails, subprograms must set the Error parameter to the corresponding error, usually @code{Data_Conversion_E}. @i{Note: We recommend to always use the Data_Conversion_E error code with Minor status 1.} All @code{Converters} (native, fallback and conversion) have similar APIs. Wchar data converters differ only in parameter type. @c ------------------------------------------------------------------- @node Converters factories @subsection Converters factories @c ------------------------------------------------------------------- To create new converters, PolyORB uses special factory subprograms with the following profile: @smallexample function Factory return Converter_Access; @end smallexample or @smallexample function Factory return Wide_Converter_Access; @end smallexample This function must allocate a new @code{Converter} and initialize its state. @c ------------------------------------------------------------------- @node Registering new code sets @subsection Registering new code sets @c ------------------------------------------------------------------- Registering new native character data code sets begins from registering new native character data code sets and its native and fallback @code{Converters}. This is done using @code{Register_Native_Code_Set}: @smallexample procedure Register_Native_Code_Set (Code_Set : Code_Set_Id; Native : Converter_Factory; Fallback : Converter_Factory); @end smallexample or @smallexample procedure Register_Native_Code_Set (Code_Set : Code_Set_Id; Native : Wide_Converter_Factory; Fallback : Wide_Converter_Factory); @end smallexample If you have additional conversion code sets Converters you may register it by calling Register_Conversion_Code_Set subprogram: @smallexample procedure Register_Conversion_Code_Set (Native : Code_Set_Id; Conversion : Code_Set_Id; Factory : Converter_Factory); @end smallexample or @smallexample procedure Register_Conversion_Code_Set (Native : Code_Set_Id; Conversion : Code_Set_Id; Factory : Wide_Converter_Factory); @end smallexample Note: because of incompatibility in the support of code sets negotiation in some ORB's it is recommend to recognize two boolean PolyORB's parameters: @smallexample [giop] giop.add_char_fallback_code_set=false giop.add_wchar_fallback_code_set=false @end smallexample and also register a fallback Converter as conversion Converter if the corresponding parameter is set to True. Finally, define your preferred native character data code sets by parameters (only integer code sets codes now supported): @smallexample [giop] giop.native_char_code_set=16#00010001# giop.native_wchar_code_set=16#00010100# @end smallexample @c ------------------------------------------------------------------- @node SOAP @chapter SOAP @cindex SOAP @c ------------------------------------------------------------------- @menu * Installing SOAP protocol personality:: * Configuring the SOAP personality:: @end menu @c ------------------------------------------------------------------- @node Installing SOAP protocol personality @section Installing SOAP protocol personality @c ------------------------------------------------------------------- @noindent Ensure PolyORB has been configured and then compiled with the SOAP protocol personality. See @ref{Building an application with PolyORB} for more details on how to check installed personalities. To enable configuration of the SOAP application personality, @pxref{Installation}. @c ------------------------------------------------------------------- @node Configuring the SOAP personality @section Configuring the SOAP personality @c ------------------------------------------------------------------- @noindent The SOAP personality is configured using a configuration file. See @ref{Using a configuration file} for more details. Here is a summary of available parameters for each instance of SOAP. @smallexample ############################################################################### # SOAP parameters # [soap] ############################################################### # SOAP Global Settings # Preference level for SOAP #polyorb.binding_data.soap.preference=0 # SOAP's default address #polyorb.protocols.soap.default_addr=127.0.0.1 # SOAP's default port #polyorb.protocols.soap.default_port=8080 @end smallexample @c ------------------------------------------------------------------- @node Tools @chapter Tools @c ------------------------------------------------------------------- @menu * po_catref:: * po_dumpir:: * po_names:: @end menu @c ------------------------------------------------------------------- @node po_catref @section @command{po_catref} @cindex @command{po_catref} @c ------------------------------------------------------------------- @noindent @command{po_catref} is a utility for viewing the components of a stringified reference (CORBA IOR, corbaloc or URI). The reference's components include references to access an object through multiple protocols (e.g. CORBA IIOP, SOAP) and configuration parameters associated with a reference (e.g. GIOP Service Contexts). @smallexample Usage: po_catref @end smallexample @noindent @i{Note: @command{po_catref} can only process protocols PolyORB has been configured with.} @c ------------------------------------------------------------------- @node po_dumpir @section @command{po_dumpir} @cindex @command{po_dumpir} @c ------------------------------------------------------------------- @noindent @command{po_dumpir} is a utility for viewing the content of an instance of the CORBA Interface Repository. @smallexample Usage: po_dumpir @end smallexample @noindent @i{Note: @command{po_dumpir} will be compiled and installed only if the CORBA personality and the @file{ir} service is compiled. Please see @ref{Building an application with PolyORB} for more details on how to set up PolyORB.} @c ------------------------------------------------------------------- @node po_names @section @command{po_names} @cindex @command{po_names} @c ------------------------------------------------------------------- @noindent @command{po_names} is a stand-alone name server. It has an interface similar to CORBA COS Naming, without dragging in any dependencies on CORBA mechanisms. This name server is to be used when the CORBA application personality is not required, e.g. with the DSA or MOMA application personalities. @c ------------------------------------------------------------------- @node Performance considerations @appendix Performance considerations @c ------------------------------------------------------------------- @noindent This section discusses performance when using PolyORB. Many elements can be configured, @xref{Building an application with PolyORB}. By carefully selecting them, you can increase the throughput of your application. We review some parameters that can impact performance. @itemize @bullet @item @b{Build options}: @itemize @bullet @item For production use, you should not build PolyORB with debug activated. @end itemize @item @b{Tasking policies}: @itemize @bullet @item You should carefully select the tasking policy to reduce dynamic ressource allocation (tasks, entry points, etc.). @xref{Tasking model in PolyORB}. @end itemize @item @b{Transport parameters}: @itemize @bullet @item Setting @code{tcp.nodelay} to false will disable Nagle buffering. @end itemize @item @b{GIOP parameters}: @itemize @bullet @item Setting @code{polyorb.protocols.iiop.giop.1.X.locate_then_request}, where @code{X} is the GIOP version in use, to false will disable @code{Locate_Message}, reducing the number of requests exchanged, @item Increasing @code{polyorb.protocols.iiop.giop.1.X.max_message_size}, where @code{X} is the GIOP version in use, will reduce GIOP fragmentation, reducing middleware processing. @end itemize @end itemize @c ------------------------------------------------------------------- @node Conformance to standards @appendix Conformance to standards @c ------------------------------------------------------------------- @menu * CORBA standards conformance:: * RT-CORBA standards conformance:: * CSIv2 standards conformance:: * CORBA-GIOP standards conformance:: * SOAP standards conformance:: @end menu @c ------------------------------------------------------------------- @node CORBA standards conformance @section CORBA standards conformance @c ------------------------------------------------------------------- @noindent The OMG defines a CORBA-compliant ORB as an implementation of the CORBA specifications that supports CORBA Core and one mapping of CORBA's IDL. Here is a summary of PolyORB's conformance issues with the latest CORBA specifications (revision 3.0, formal/02-06-01). @menu * CORBA IDL-to-Ada mapping:: * CORBA Core:: * CORBA Interoperability:: * CORBA Interworking:: * CORBA Quality Of Service:: * CORBA COS Services:: * CORBA Specialized services:: @end menu @c ------------------------------------------------------------------- @node CORBA IDL-to-Ada mapping @subsection CORBA IDL-to-Ada mapping @cindex CORBA IDL-to-Ada mapping @c ------------------------------------------------------------------- @noindent PolyORB supports the IDL-to-Ada specification @cite{[OMG01]}, with the following limitations in both the CORBA API and the IDL-to-Ada compiler @code{idlac}: @itemize @bullet @item no support for abstract interfaces, object-by-value, context data; @item no support for CORBA Components; @item implemented API may present some divergences with current mapping. @end itemize @i{Note: generated code is constrained by the limitations of the Ada compiler used. Please refer to its documentation for more information.} Conforming to documentation requirements from section 4.11 of the IDL-to-Ada specification @cite{[OMG01]}, note that PolyORB's implementation of CORBA is @i{tasking-safe}. The use of the CORBA personality on typical GNAT runtimes is @i{task-blocking}, unless specified in platform notes. @c ------------------------------------------------------------------- @node CORBA Core @subsection CORBA Core @c ------------------------------------------------------------------- @noindent This set encompasses chapters 1-11. Chapters 3 to 11 are normative. @itemize @bullet @item Chapter 3 describes OMG IDL syntax and semantics. See @ref{CORBA IDL-to-Ada mapping} for a description of non-implemented features; @item Chapter 4 describes the ORB Interface. @noindent PolyORB partially supports this chapter. @c XXX TO BE EXPANDED, note there are some differences between ORB Core and @c IDL-to-Ada mapping !} @item Chapter 5 describes Value Type Semantics. @noindent PolyORB does not support this chapter. @item Chapter 6 describes Abstract Interface Semantics. @noindent PolyORB does not support this chapter. @item Chapter 7 describes Dynamic Invocation Interface (DII) @noindent PolyORB supports only the following methods: @code{Create_Request}, @code{Invoke} and @code{Delete}. @item Chapter 8 describes Dynamic Skeleton Interface (DSI) @noindent PolyORB partially supports this chapter: this interface is fully implemented except for context data. @item Chapter 9 describes Dynamic Management of Any Values @noindent PolyORB partially supports this chapter: this interface is fully implemented except for object references and value types. @item Chapter 10 describes The Interface Repository @noindent PolyORB supports this chapter, except for the @code{ExtValueDef} interface, and all CORBA CCM related interfaces. @item Chapter 11 describes The Portable Object Adapter @noindent PolyORB supports this chapter with the following limitations: @itemize @bullet @item the @code{USE_SERVANT_MANAGER} policy is partially supported: the @code{ServantLocator} object is not implemented; @item support for @code{SINGLE_THREAD} policy is incomplete, reentrant calls may not work; @item @code{Wait_For_Completion} and @code{Etherealize_Objects} are not taken into account in @code{PortableServer.POAManager}; @item the @code{PortableServer.POAManagerFactory} API is not implemented. @end itemize @end itemize @c ------------------------------------------------------------------- @node CORBA Interoperability @subsection CORBA Interoperability @c ------------------------------------------------------------------- @noindent This set encompasses chapters 12-16. @itemize @bullet @item See @ref{CORBA-GIOP standards conformance} for more information on this point. @end itemize @c ------------------------------------------------------------------- @node CORBA Interworking @subsection CORBA Interworking @c ------------------------------------------------------------------- @noindent This set encompasses chapters 17-21. @itemize @bullet @item Chapters 17 to 20 describe interoperability with Microsoft's COM/DCOM. @noindent PolyORB provides no support for these chapters. @item Chapter 21 describes @code{PortableInterceptor}. @noindent PolyORB provides partial support for this chapter. @end itemize @c ------------------------------------------------------------------- @node CORBA Quality Of Service @subsection CORBA Quality Of Service @c ------------------------------------------------------------------- @noindent This set encompasses chapters 22-24. @itemize @bullet @item Chapter 22 describes CORBA Messaging @item Chapter 23 describes Fault Tolerant CORBA @item Chapter 24 describes Secure Interoperability. @end itemize @noindent PolyORB provides no support for these chapters. @c ------------------------------------------------------------------- @node CORBA COS Services @subsection CORBA COS Services @cindex CORBA, COS Services @c ------------------------------------------------------------------- @noindent COS Services are specifications of high level services that are optional extensions to the CORBA specification. They provide helper packages to build distributed applications. PolyORB implements the following COS Services: @c XXX should indicate version for each COS @itemize @bullet @item COS Event and TypedEvent; @item COS Naming; @item COS Notification; @item COS Time; @end itemize @c ------------------------------------------------------------------- @node CORBA Specialized services @subsection CORBA Specialized services @cindex CORBA, Specialized services @c ------------------------------------------------------------------- @noindent PolyORB supports the following specialized services: @itemize @bullet @item Unreliable Multicast (MIOP), proposed 1.0 specification @cite{[OMG02b]}. @cindex MIOP @item RT-CORBA extensions, see @ref{RT-CORBA} for more information on this point. @item CORBA security extensions, see @cite{[OMG]} for more information on this point. @end itemize @c ------------------------------------------------------------------- @node RT-CORBA standards conformance @section RT-CORBA standards conformance @c ------------------------------------------------------------------- @noindent RT-CORBA specifications rely on the CORBA application personality; the same issues and implementation notes apply. In addition, here is a list of issues with the implementation of RT-CORBA static @cite{[OMG02a]} and dynamic scheduling @cite{[OMG03]} specifications. @itemize @bullet @item RT-CORBA static and dynamic scheduling (Chapter 2) Chapter 2 is common to these two specifications. It describes key mechanisms of RT-CORBA that are common to both specifications. PolyORB partially implements this chapter from section 2.1 up to section 2.10. PolyORB does not provide support for all connection-related policies. See implementation notes in the different package specifications for more details. @item RT-CORBA static scheduling (Chapter 3) PolyORB supports this chapter. @item RT-CORBA dynamic scheduling (Chapter 3) PolyORB does not support this chapter. @end itemize @c ------------------------------------------------------------------- @node CSIv2 standards conformance @section CSIv2 standards conformance @c ------------------------------------------------------------------- @noindent PolyORB supports IIOP/SSL. @c ------------------------------------------------------------------- @node CORBA-GIOP standards conformance @section CORBA/GIOP standards conformance @c ------------------------------------------------------------------- @noindent GIOP supports part of the CORBA Interoperability specification, from chapters 12 to 16 of CORBA specifications. Chapter 12 defines general concepts about ORB interoperability. It defines an @emph{interoperbility-compliant ORB} as an ORB that supports: @itemize @bullet @item API that supports the construction of request-level inter-ORB bridges, Dynamic Invocation Interface, Dynamic Skeleton Interface and the object identity operations described in the Interface Repository. See @ref{CORBA standards conformance} for more details. @item IIOP protocol as defined in chapter 15. @end itemize @noindent Support for other components is optional. @itemize @bullet @item Chapter 13 describes the ORB Interoperability Architecture. PolyORB fully supports this chapter. @item Chapter 14 describes how to build Inter-ORB Bridges. PolyORB fully supports this chapter. @item Chapter 15 describes the General Inter-ORB Protocol (GIOP). PolyORB supports GIOP version 1.0 to 1.2, the CDR representation scheme. Support for IOR and @code{corbaloc} addressing mechanisms is supported in the CORBA personality, see @ref{CORBA} for more details. PolyORB does not support the optional IIOP IOR Profile Components, Bi-directional GIOP. PolyORB also does not support fragmentation in GIOP 1.1. @item Chapter 16 describes the DCE ESIOP protocol. PolyORB does not support this optional chapter. @end itemize @c XXX SSLIOP @c ------------------------------------------------------------------- @node SOAP standards conformance @section SOAP standards conformance @c ------------------------------------------------------------------- @noindent @i{The documentation of the SOAP standards conformance of PolyORB will appear in a future revision of PolyORB.} @c ------------------------------------------------------------------- @node References @appendix References @c ------------------------------------------------------------------- @enumerate @include polyorb_ug_ref.texi @end enumerate @c ------------------------------------------------------------------- @c GNU's FDL @include gfdl.texi @c ------------------------------------------------------------------- @node Index @unnumbered Index @c ------------------------------------------------------------------- @printindex cp @bye polyorb-2.8~20110207.orig/docs/OMG_TAGS0000644000175000017500000000242611750740337016527 0ustar xavierxavierThis file lists the OMG tag assignments held by the PolyORB open source middleware. To update contact information or request new tag assignments, contact tag-request@omg.org / andrew@omg.org. For details, see the "Frequently Asked Questions regarding OMG tag value allocation" at http://doc.omg.org/ptc/99-02-01. Official, up-to-date tags lists are published at: http://doc.omg.org/standard-tags http://doc.omg.org/vendor-tags ----------------------------------------------------------------------------- Holder: PolyORB Open Source middleware Contact: Thomas Quinot Email: URL: Last update: 2nd August 2007 Status: Current 256 profile tags 0x504f0000 - 0x504f00ff ("PO\x00\x00" - "PO\x00\xff") 256 service tags 0x504f0000 - 0x504f00ff ("PO\x00\x00" - "PO\x00\xff") 256 component IDs 0x504f0000 - 0x504f00ff ("PO\x00\x00" - "PO\x00\xff") 16 VMCIDs 0x504f0xxx - 0x504ffxxx ("PO\x00\x00" - "PO\xff\xff") 16 ORB type IDs 0x504f0000 - 0x504f000f ("PO\x00\x00" - "PO\x00\x0f") ----------------------------------------------------------------------------- These tag ranges are used to create constants in the following units: profile tags PolyORB.Binding_Data service tags PolyORB.QoS.Service_Contexts polyorb-2.8~20110207.orig/docs/cfg.kw0000755000175000017500000000065511750740337016453 0ustar xavierxavierabort abs abstract accept access aliased all and array begin body case configuration constant declare delay delta digits do else elsif end entry exception exit for function generic goto if in is limited loop mod new not null of or others out package pragma private procedure protected raise range record rem renames requeue return reverse reverse select separate subtype tagged task terminate then type until use when while with polyorb-2.8~20110207.orig/docs/glade-sources0000644000175000017500000003340111750740337020021 0ustar xavierxavierwith RCI; with Ada.Text_IO; procedure Check_PID is begin if RCI'Partition_ID = Check_PID'Partition_ID then Ada.Text_IO.Put_Line ("package RCI is configured locally"); else Ada.Text_IO.Put_Line ("package RCI is configured remotely"); end if; end Check_PID; package Types is pragma Pure; type Customer_Type is new String; type Password_Type is new String; end Types; with Types; use Types; package RCIBank is pragma Remote_Call_Interface; function Balance (Customer : in Customer_Type; Password : in Password_Type) return Integer; procedure Transfer (Payer : in Customer_Type; Password : in Password_Type; Amount : in Positive; Payee : in Customer_Type); procedure Deposit (Customer : in Customer_Type; Amount : in Positive); procedure Withdraw (Customer : in Customer_Type; Password : in Password_Type; Amount : in out Positive); end RCIBank; with Types; use Types; package RASBank is pragma Remote_Call_Interface; type Balance_Type is access function (Customer : in Customer_Type; Password : in Password_Type) return Integer; procedure Register (Balance : in Balance_Type); function Get_Balance return Balance_Type; -- [...] Other services end RASBank; with Types; use Types; package MirrorBank is pragma Remote_Call_Interface; function Balance (Customer : in Customer_Type; Password : in Password_Type) return Integer; -- [...] Other services end MirrorBank; with RASBank, Types; use RASBank, Types; package body MirrorBank is function Balance (Customer : in Customer_Type; Password : in Password_Type) return Integer is begin return Something; end Balance; begin -- Register a dynamically bound remote subprogram (Balance) -- through a statically bound remote subprogram (Register) Register (Balance'Access); -- [...] Register other services end MirrorBank; with Types; use Types; with RCIBank; use RCIBank; procedure RCIClient is B : Integer; C : Customer_Type := "rich"; P : Password_Type := "xxxx"; begin B := Balance (C, P); end RCIClient; with Types; use Types; with RASBank; use RASBank; procedure BankClient is B : Integer; C : Customer_Type := "rich"; P : Password_Type := "xxxx"; begin -- Through a statically bound remote subprogram (Get_Balance), get -- a dynamically bound remote subprogram. Dereference it to -- perform a dynamic invocation. B := Get_Balance.all (C, P); end BankClient; with Types; use Types; package Terminal is pragma Pure; type Term_Type is abstract tagged limited private; procedure Notify (MyTerm : access Term_Type; Payer : in Customer_Type; Amount : in Integer) is abstract; private type Term_Type is abstract tagged limited null record; end Terminal; with Terminal, Types; use Terminal, Types; package RACWBank is pragma Remote_Call_Interface; type Term_Access is access all Term_Type'Class; procedure Register (MyTerm : in Term_Access; Customer : in Customer_Type; Password : in Password_Type); -- [...] Other services end RACWBank; with Types, Terminal; use Types, Terminal; package NewTerminal is pragma Remote_Types; type New_Term_Type is new Term_Type with null record; procedure Notify (MyTerm : access New_Term_Type; Payer : in Customer_Type; Amount : in Integer); function Current return Term_Access; end NewTerminal; with NewTerminal, RACWBank, Types; use NewTerminal, RACWBank, Types; procedure Term1Client is MyTerm : Term_Access := Current; Customer : Customer_Type := "poor"; Password : Password_Type := "yyyy"; begin Register (MyTerm, Customer, Password); -- [...] Execute other things end Term1Client; with NewTerminal, RACWBank, Types; use NewTerminal, RACWBank, Types; procedure Term2Client is MyTerm : Term_Access := Current; Payer : Customer_Type := "rich"; Password : Password_Type := "xxxx"; Payee : Customer_Type := "poor"; begin Register (MyTerm, Payer, Password); Transfer (Payer, Password, 100, Payee); end Term2Client; with Types; use Types; package body RACWBank is procedure Register (MyTerm : in Term_Access; Customer : in Customer_Type; Password : in Password_Type) is begin Insert_In_Local_Table (MyTerm, Customer); end Register; procedure Transfer (Payer : in Customer_Type; Password : in Password_Type; Amount : in Positive; Payee : in Customer_Type) is -- Find Customer terminal. Term : Term_Access := Find_In_Local_Table (Payee); begin Withdraw (Payer, Amount); Deposit (Payee, Amount); if Term /= null then -- Notify on Payee terminal. Notify (Term, Payer, Amount); end if; end Transfer; -- [...] Other services end RACWBank; with Ada.Streams; use Ada.Streams; package StringArrayStream is pragma Remote_Types; type List is private; procedure Append (L : access List; O : in String); function Delete (L : access List) return String; private type String_Access is access String; type Node; type List is access Node; type Node is record Content : String_Access; Next : List; end record; procedure Read (S : access Root_Stream_Type'Class; L : out List); procedure Write (S : access Root_Stream_Type'Class; L : in List); for List'Read use Read; for List'Write use Write; end StringArrayStream; package body StringArrayStream is procedure Read (S : access Root_Stream_Type'Class; L : out List) is begin if Boolean'Input (S) then L := new Node; L.Content := new String'(String'Input (S)); List'Read (S, L.Next); else L := null; end if; end Read; procedure Write (S : access Root_Stream_Type'Class; L : in List) is begin if L = null then Boolean'Output (S, False); else Boolean'Output (S, True); String'Output (S, L.Content.all); List'Write (S, L.Next); end if; end Write; -- [...] Other services end StringArrayStream; package SharedObjects is pragma Shared_Passive; Max : Positive := 10; type Index_Type is range 1 .. Max; type Rate_Type is new Float; type Rates_Type is array (Index_Type) of Rate_Type; External_Synchronization : Rates_Type; protected Internal_Synchronization is procedure Set (Index : in Index_Type; Rate : in Rate_Type); procedure Get (Index : in Index_Type; Rate : out Rate_Type); private Rates : Rates_Type; end Internal_Synchronization; end SharedObjects; package Storage is pragma Shared_Passive; protected Queue is procedure Insert (Q, R : Integer); procedure Remove (Q : in Integer; R : out Integer); private -- Other declarations end Queue; end Storage; with Storage; use Storage; package Common is pragma Remote_Types; type Notify is access procedure (Q : Integer); pragma Asynchronous (Notify); type Worker is abstract tagged limited private; procedure Assign (W : access Worker; Q : in Integer; N : in Notify) is abstract; type Any_Worker is access all Worker'Class; pragma Asynchronous (Any_Worker); private type Worker is abstract tagged limited null record; end Common; with Common, Storage; use Common, Storage; package NewWorkers is pragma Remote_Types; type NewWorker is new Worker with private; procedure Assign (W : access NewWorker; Q : Integer; N : Notify); private type NewWorker is new Worker with record NewField : Field_Type; -- [...] Other fields end record; end NewWorkers; with Common, Storage, NewWorkers; use Common, Storage, NewWorkers; package NewNewWorkers is pragma Remote_Types; type NewNewWorker is new NewWorker with private; procedure Assign (W : access NewNewWorker; Q : Integer; N : Notify); private type NewNewWorker is new NewWorker with record NewField : Field_Type; -- [...] Other fields end record; end NewNewWorkers; with Common; use Common; package WorkerCity is pragma Remote_Call_Interface; procedure Insert (W : in Any_Worker); procedure Remove (W : out Any_Worker); end WorkerCity; with Storage; use Storage; generic package Factory is pragma Remote_Call_Interface; procedure Notify (Q : Integer); pragma Asynchronous (Notify); end Factory; with Factory; package NewFactory is new Factory; pragma Remote_Call_Interface (NewFactory); package Internal is Exc : exception; end Internal; package RemPkg1 is pragma Remote_Call_Interface; procedure Subprogram; end RemPkg1; with Internal, Ada.Exceptions; use Ada.Exceptions; package body RemPkg1 is procedure Subprogram is begin Raise_Exception (Internal.Exc'Identity, "Message"); end Subprogram; end RemPkg1; package RemPkg2 is pragma Remote_Call_Interface; procedure Subprogram; end RemPkg2; with RemPkg1, Ada.Exceptions; use Ada.Exceptions; package body RemPkg2 is procedure Subprogram is begin RemPkg1.Subprogram; exception when E : others => Raise_Exception (Exception_Identity (E), Exception_Message (E)); end Subprogram; end RemPkg2; with Ada.Text_IO, Ada.Exceptions; use Ada.Text_IO, Ada.Exceptions; with RemPkg2, Internal; procedure RemExcMain is begin RemPkg2.Subprogram; exception when E : Internal.Exc => Put_Line (Exception_Message (E)); -- Output "Message" end RemExcMain; with Node1, Node2; procedure NonDeterministic is begin Node1.Send (1); Node2.Send (2); end NonDeterministic; package Node1 is pragma Remote_Call_Interface; procedure Send (X : Integer); pragma Asynchronous (Send); end Node1; package Node2 is pragma Remote_Call_Interface; procedure Send (X : Integer); pragma Asynchronous (Send); end Node2; with Node2; package body Node1 is procedure Send (X : Integer) is begin Node2.Send (X); end Send; end Node1; package body Node2 is V : Integer := 0; procedure Send (X : Integer) is begin V := X; end Send; end Node2; package AsynchronousRT is pragma Remote_Types; type Object is tagged limited private; type AsynchronousRACW is access all Object'Class; pragma Asynchronous (AsynchronousRACW); procedure Asynchronous (X : Object); procedure Synchronous (X : in out Object); function Create return AsynchronousRACW; private type Object is tagged limited null record; end AsynchronousRT; package AsynchronousRCI is pragma Remote_Call_Interface; procedure Asynchronous (X : Integer); pragma Asynchronous (Asynchronous); procedure Synchronous (X : Integer); type AsynchronousRAS is access procedure (X : Integer); pragma Asynchronous (AsynchronousRAS); end AsynchronousRCI; with AsynchronousRCI, AsynchronousRT; use AsynchronousRCI, AsynchronousRT; procedure AsynchronousMain is RAS : AsynchronousRAS; RACW : AsynchronousRACW := Create; begin -- Asynchronous Dynamically Bound Remote Call (1) RAS := AsynchronousRCI.Asynchronous'Access; RAS (0); -- Abbrev for RAS.all (0) -- Synchronous Dynamically Bound Remote Call (2) RAS := AsynchronousRCI.Synchronous'Access; RAS (0); -- Asynchronous Dynamically Bound Remote Call (3) Asynchronous (RACW.all); -- Synchronous Dynamically Bound Remote Call (4) Synchronous (RACW.all); end AsynchronousMain; generic package GenericRCI is pragma Remote_Call_Interface; procedure P; end GenericRCI; with GenericRCI; package RCIInstantiation is new GenericRCI; pragma Remote_Call_Interface (RCIInstantiation); with GenericRCI; package NormalInstantiation is new GenericRCI; package Pure is pragma Pure; Max : constant := 9; type My_Integer is new Integer range -Max .. Max; type Remote_Object is abstract tagged limited private; procedure Primitive_Operation (Object : access Remote_Object; My_Int : My_Integer) is abstract; private type Remote_Object is abstract tagged limited null record; end Pure; package body New_Integers is procedure Read (S : access Root_Stream_Type'Class; V : out New_Integer) is B : String := String'Input (S); begin V := New_Integer'Value (B); end Read; procedure Write (S : access Root_Stream_Type'Class; V : in New_Integer) is begin String'Output (S, New_Integer'Image (V)); end Write; end New_Integers; with Ada.Streams; use Ada.Streams; package New_Integers is pragma Pure; type New_Integer is new Integer; procedure Read (S : access Root_Stream_Type'Class; V : out New_Integer); procedure Write (S : access Root_Stream_Type'Class; V : in New_Integer); for New_Integer'Read use Read; for New_Integer'Write use Write; end New_Integers; with ACRRT; use ACRRT; package ACRRCI is pragma Remote_Call_Interface; pragma All_Calls_Remote; procedure P (X : T); end ACRRCI; package body ACRRCI is procedure P (X : T) is begin null; end P; end ACRRCI; with Ada.Streams; use Ada.Streams; package ACRRT is pragma Remote_Types; type T is private; private type T is new Integer; procedure Read (S : access Root_Stream_Type'Class; X : out T); procedure Write (S : access Root_Stream_Type'Class; X : in T); for T'Read use Read; for T'Write use Write; end ACRRT; package body ACRRT is procedure Read (S : access Root_Stream_Type'Class; X : out T) is begin raise Program_Error; end Read; procedure Write (S : access Root_Stream_Type'Class; X : in T) is begin raise Program_Error; end Write; end ACRRT; with ACRRCI, ACRRT; procedure ACRMain is X : ACRRT.T; begin ACRRCI.P (X); end ACRMain; polyorb-2.8~20110207.orig/docs/echo-impl-spec.ads0000644000175000017500000000044211750740337020636 0ustar xavierxavierwith CORBA; with PortableServer; package Echo.Impl is type Object is new PortableServer.Servant_Base with null record; type Object_Acc is access Object; function EchoString (Self : access Object; Mesg : in CORBA.String) return CORBA.String; end Echo.Impl; polyorb-2.8~20110207.orig/docs/full-ex.fig0000644000175000017500000000655011750740337017411 0ustar xavierxavier#FIG 3.2 Portrait Center Metric Letter 100.00 Single -2 1200 2 6 2444 479 2935 643 4 1 0 0 0 2 9 0.0000 4 105 420 2689 602 Storage\001 -6 1 1 0 2 0 7 10 0 12 0.000 1 0.0000 725 1379 491 1145 725 1379 1216 1379 1 3 0 2 0 7 10 0 12 0.000 1 0.0000 1707 2034 491 491 1707 2034 2198 2034 1 1 0 2 0 7 10 0 12 0.000 0 0.0000 4654 1379 491 1145 4654 1379 5145 1379 1 3 0 2 0 7 10 0 12 0.000 0 0.0000 3672 2034 491 491 3672 2034 4163 2034 1 3 0 2 0 7 10 0 12 0.000 0 0.0000 3672 724 491 491 3672 724 4163 724 2 4 0 2 0 7 10 0 12 0.000 0 0 4 0 0 5 3017 2525 2362 2525 2362 234 3017 234 3017 2525 2 1 4 2 0 7 4 0 -1 6.000 0 0 -1 1 0 2 0 0 1.00 60.00 120.00 2051 2187 2689 1707 2 1 0 2 0 7 4 0 -1 0.000 0 0 -1 1 0 2 0 0 1.00 60.00 120.00 807 561 1707 2034 2 1 1 2 0 7 0 0 -1 6.000 0 0 -1 0 0 1 1707 1952 2 1 1 2 0 7 5 0 -1 6.000 0 0 -1 1 0 2 0 0 1.00 60.00 120.00 1379 2198 805 1551 2 1 0 2 0 7 4 0 -1 0.000 0 0 -1 1 0 2 0 0 1.00 60.00 120.00 4572 561 3672 2034 2 1 1 2 0 7 0 0 -1 6.000 0 0 -1 0 0 1 3672 1952 2 1 1 2 0 7 5 0 -1 6.000 0 0 -1 1 0 2 0 0 1.00 60.00 120.00 3999 2198 4573 1551 2 2 0 2 0 7 2 0 20 0.000 0 0 -1 0 0 5 4736 1789 4040 1789 4040 2034 4736 2034 4736 1789 2 1 4 2 0 7 4 0 -1 6.000 0 0 -1 1 0 2 0 0 1.00 60.00 120.00 3355 2180 2689 1543 2 2 0 2 0 7 2 0 20 0.000 0 0 -1 0 0 5 2321 1870 3058 1870 3058 2116 2321 2116 2321 1870 2 4 0 2 0 7 2 0 20 0.000 0 0 4 0 0 5 1134 724 316 724 316 397 1134 397 1134 724 2 4 0 2 0 7 2 0 20 0.000 0 0 4 0 0 5 4081 2402 3263 2402 3263 2075 4081 2075 4081 2402 2 1 0 2 0 7 4 0 -1 0.000 0 0 -1 1 0 2 0 0 1.00 60.00 120.00 1707 970 1707 1543 2 1 0 2 0 7 4 0 -1 0.000 0 0 -1 0 1 2 0 0 1.00 60.00 120.00 1216 1052 1379 888 2 4 0 2 0 7 4 0 20 0.000 0 0 4 0 0 5 4081 602 3263 602 3263 275 4081 275 4081 602 2 2 0 2 0 7 2 0 20 0.000 0 0 -1 0 0 5 4367 766 3672 766 3672 1011 4367 1011 4367 766 2 2 0 2 0 7 2 0 20 0.000 0 0 -1 0 0 5 4572 1257 3876 1257 3876 1502 4572 1502 4572 1257 2 4 0 2 0 7 4 0 20 0.000 0 0 4 0 0 5 2116 2361 1298 2361 1298 2034 2116 2034 2116 2361 2 2 0 2 0 7 2 0 20 0.000 0 0 -1 0 0 5 2321 438 3058 438 3058 684 2321 684 2321 438 2 1 0 2 0 7 4 0 -1 0.000 0 0 -1 1 0 2 0 0 1.00 60.00 120.00 2034 888 2362 1052 3 0 0 2 0 7 4 0 -1 0.000 0 1 0 7 0 0 1.00 60.00 120.00 807 561 643 724 807 888 643 1052 807 1216 643 1379 807 1543 0.000 1.000 1.000 1.000 1.000 1.000 0.000 3 0 0 2 0 7 0 0 -1 0.000 0 1 0 7 0 0 1.00 60.00 120.00 4572 561 4736 724 4572 888 4736 1052 4572 1216 4736 1379 4572 1543 0.000 1.000 1.000 1.000 1.000 1.000 0.000 3 0 0 2 0 7 4 0 -1 0.000 0 1 0 4 0 0 1.00 60.00 120.00 3672 602 3876 848 4245 848 4572 561 0.000 1.000 1.000 0.000 4 1 0 0 0 2 9 0.0000 4 120 495 4408 1952 Notify (4)\001 4 1 0 0 0 2 9 0.0000 4 120 465 2689 2034 Reply (3)\001 4 1 0 0 0 2 9 0.0000 4 105 585 725 2688 A_Factory\001 4 1 0 0 0 2 9 0.0000 4 120 555 1707 2688 A_Worker\001 4 1 0 0 0 2 9 0.0000 4 90 375 2689 2688 Passive\001 4 1 0 0 0 2 9 0.0000 4 120 555 3672 2688 A_Worker\001 4 1 0 0 0 2 9 0.0000 4 105 585 4654 2688 A_Factory\001 4 1 0 0 0 2 9 0.0000 4 105 660 725 602 NewFactory\001 4 1 0 0 0 2 9 0.0000 4 90 675 3672 2279 NewWorkers\001 4 1 0 0 0 2 9 0.0000 4 90 525 1707 888 Partitions\001 4 1 0 0 0 2 9 0.0000 4 120 630 3672 479 WorkerCity\001 4 1 0 0 0 2 9 0.0000 4 105 405 4040 929 Hire (1)\001 4 1 0 0 0 2 9 0.0000 4 120 480 4245 1420 Query (2)\001 4 1 0 0 0 2 9 0.0000 4 90 675 1707 2239 NewWorkers\001 polyorb-2.8~20110207.orig/docs/svn.texi0000644000175000017500000000034211750740337017040 0ustar xavierxavier@tex % Process an SVN Date: keyword \gdef\svn$Date: #1 #2${\set SVNDate {#1} \catcode`\$\active\relax} % Front-end to the above, first setting '$' catcode to \math \gdef\svndate{\catcode`\$3\relax\expandafter\svn} @end tex polyorb-2.8~20110207.orig/docs/echo-impl-body.adb0000644000175000017500000000110611750740337020616 0ustar xavierxavierwith Ada.Text_IO; with Echo.Skel; pragma Warnings (Off, Echo.Skel); -- No entity from Echo.Skel is referenced. package body Echo.Impl is ---------------- -- EchoString -- ---------------- function EchoString (Self : access Object; Mesg : in CORBA.String) return CORBA.String is pragma Warnings (Off); pragma Unreferenced (Self); pragma Warnings (On); begin Ada.Text_IO.Put_Line ("Echoing string: « " & CORBA.To_Standard_String (Mesg) & " »"); return Mesg; end EchoString; end Echo.Impl; polyorb-2.8~20110207.orig/docs/idl.kw0000755000175000017500000000011311750740337016451 0ustar xavierxaviermodule typedef struct sequence enum interface exception void in out raises polyorb-2.8~20110207.orig/docs/polyorb_dg.texi0000644000175000017500000010076711750740337020406 0ustar xavierxavier\input texinfo @c load conversion file for TeX format @c start of the header @setfilename polyorb_dg.info @settitle PolyORB Developer's Guide @documentlanguage en @documentencoding US-ASCII @syncodeindex fn cp @c end of the header @copying Here shall lie the licence of this document @end copying @titlepage @title PolyORB Developer's Guide @author Thomas Vergnaud @page @vskip 0pt plus 1filll @insertcopying @end titlepage @contents @ifnottex @node Top @top PolyORB Developer's Guide @insertcopying @end ifnottex @menu * About this guide:: * Introduction:: * Main packages:: * Application personalities:: * Protocol layer:: * Neutral layer:: * Services:: * Coding rules:: * GNU Free Documentation License:: @end menu @c ------------------------------------------------------------------- @node About this guide @unnumbered About this guide @c ------------------------------------------------------------------- @noindent This guide aims at giving you some information about the PolyORB global structure, in order to help find your way though the packages. It also gives you hints on how to build protocol or application personalities. @node Introduction @chapter Introduction @cindex Introduction PolyORB aims at providing a uniform solution to build distributed applications. To do so, the architecture of PolyORB allows for providing multiple middleware behaviors, both on the application side (e.g. CORBA, Distributed Systems Annex of Ada 95) and protocol side (e.g. GIOP, SOAP). Those behaviors are implemented by ``personalities'', which can be viewed as interfaces between networks or applications and the PolyORB core. Through them, PolyORB behaves as if it were a particular middleware implementation. Personalities mainly use or extend mechanisms that are provided by the PolyORB core, and thus adapt them to implement specific implementations. As the PolyORB core provides the basis of all what personalities provide, it is called ``neutral core''. What is very special in the PolyORB architecture, is that there can be multiple application and protocol personalities in the same configuration. Thus, PolyORB is said to have a ``schizophrenic architecture''. @cindex schizophrenic architecture The architecture of a PolyORB personalisation is made of three layers: @itemize @bullet @item the application personalities; @item the neutral layer; @item the protocol personalities. @end itemize Above the application personalities lie the user applications; the protocol personalities directly rely on the network. Actually, one can view three sublayers within the neutral layer. At the very heart of the layer, there is the neutral core, which is nearly a middleware implementation in itself. Above and below the neutral inner core lie the mechanisms to operate with the personalities. @node Main packages @chapter Main packages As PolyORB is a rather big program, here is a short description of the main packages, in order to help you find what functionality you search. All these packages are located in @code{src/}. @c ------------------- @section Tool packages Those packages provide various tools and facilities, which can be used by all other PolyORB packages. @subsection @code{PolyORB.Calendar} A calendar implementation that works with all tasking policies. See @ref{calendar} for details. @subsection @code{PolyORB.Log} Logging facility. Provides a unified means for other units to output debugging, diagnostics and error messages. @subsection @code{PolyORB.Utils.Chained_Lists} Generic chain list facility with generic iterator. @subsection @code{PolyORB.Utils.Dynamic_Tables}, @code{PolyORB.Utils.Htables.*} Functions to handle arrays of variable size, and hash tables. @subsection @code{PolyORB.Utils.Simple_Flags} Utility functions to provide binary flag sets. @subsection @code{PolyORB.Utils.Strings.Lists}, @code{PolyORB.Utils.Strings} Handling of dynamic string allocation and chained lists of strings. @subsection @code{PolyORB.Sequences.*} @{Bounded,unbounded@} variable length arrays (cf. CORBA.Sequences.) Notionally based on Ada.Strings.Unbounded. @subsection @code{PolyORB.Dynamic_Dict} Efficient dictionnary of key-value pairs. @subsection @code{PolyORB.Utils.Random} A random number generator, which is meant to replace Ada.Numerics.Discrete_Random. @subsection @code{PolyORB.Fixed_Point} A package to represent fixed point numbers. @c -------------------------------- @section Configuration packages Those packages support the main configuration functionalities of PolyORB. @subsection @code{PolyORB.Configuration} User control of various middleware aspects is implemented through a generic configuration framework. At start-up, PolyORB will search for various configuration files, containing application profiles. See 'polyorb.conf' for a detail of PolyORB generic configuration, 'moma/*.conf' for MOMA specific configuration files. @subsection @code{PolyORB.Initialization} Software modules manager for initialization of the middleware. Each module is registered with this package, indicating its dependencies. Initialization is performed as a topological sort of the dependency lattice. A check is performed to control consistency of the tree. @subsection @code{PolyORB.Tasking.*} Tasking runtime, support full tasking, ravenscar tasking subset and no tasking modes. Provides advanced mutexes, mutexes, watchers, r/w locks abstractions. @subsection @code{PolyORB.Setup.*} Handle the initialization of a PolyORB node. @subsection @code{PolyORB.Parameters.*} Facilities to read and handle configuration parameters. Among other things, those packages are used to manage the configuration file @code{polyorb.conf}. @c ------------------------ @section Data manipulation packages Those package gather all functions and definitions concerning the data handled within the neutral layer. @subsection @code{PolyORB.Types} Base data types used throughout PolyORB. @subsection @code{PolyORB.Any.*} Neutral, self-descriptive data representation. See @ref{any types} for details. @c ------------------------- @section Architectural packages Those packages do not correspond to functional parts of PolyORB: they provide architectural components. @subsection @code{PolyORB.Annotations} The Annotation pattern, which allows clients of a data structure to independently enrich it, thus decoupling data extension from type extension. @subsection @code{PolyORB.Components} The Component pattern, which allows objects to exchange synchronous messages through connections, thus decoupling behaviour profiles from Ada typing. @subsection @code{PolyORB.Smart_Pointers} The smart pointers are used to reproduce a garbage collecting process. @c ----------- @section Application layer framework and support functionalities @subsection @code{PolyORB.Call_Back} Interceptor for request processing completion signalling. @subsection @code{PolyORB.Obj_Adapters} The abstract interface of object adapters in PolyORB. @subsection @code{PolyORB.Poa} The base class for all Portable Object Adapter implementations (generic hierarchical object adapters modeled after the CORBA POA.) @subsection @code{PolyORB.Poa_Types} Base data structures handled by PolyORB.POA. @subsection @code{PolyORB.Poa_Policies} Children of this unit define various policy objects that can be used to customise the behaviour of portable object adapters. @subsection @code{PolyORB.Servants}, @code{PolyORB.Minimal_Servants} Base class for all application objects. @c ----------------------------- @section Neutral Core @subsection @code{PolyORB.Orb} The core component: provides the global ORB activities scheduler, as well as registries for personality components (binding object factories, transport access points, object adapters). @subsection @code{PolyORB.Requests} The central data structure in PolyORB: an object representing a method invocation request to be executed by an object in a way that is independent of the application and protocol personalities. @subsection @code{PolyORB.References} Object reference management. @subsection @code{PolyORB.References.Binding} Client-side binding factory. Either binds directly or creates a binding to a remote object. @subsection @code{PolyORB.Scheduler} Coordinates the scheduling policies for the tasks that have been created by the ORB. @subsection @code{PolyORB.Jobs} A Job is anything that can keep a task busy (like a Runnable in Java). This unit declares an abstract Job type, and a means to maintain job queues. @c ------------- @section Protocol layer framework and support functionalities @subsection @code{PolyORB.Opaque.Chunk_Pools}, @code{PolyORB.Opaque}, @code{PolyORB.Buffers} Manage memory buffers for various purposes @subsection @code{PolyORB.Utils.Buffers}, @code{PolyORB.Utils.Text.Buffers} Utilities for buffer access. @subsection @code{PolyORB.Filters} Framework for layered components that form a protocol stack. Each filter transmits SDUs (service data units) from its lower layer to its upper layer, and can perform some processing on the SDU and its associated data. The lowest layer is a polyorb.filters.sockets.socket_filter, which does not receive SDUs from a lower layer but directly from the ORB engine. The uppermost layer is a Session, which does not actually transmits SDUs to an upper layer but takes action based on received SDUs. @subsection @code{PolyORB.Transport} The abstraction of access points and end points in the transport service. An access point is an entity that has an address, to which other nodes can connect. An end point is an entity that represents an established connection with an access point, and can be used to exchange information. @subsection @code{PolyORB.Transport.Sockets} A concrete implementation of the classes defined in PolyORB.Transport, based on TCP sockets. @subsection @code{PolyORB.Representations} The abstraction of a method to represent data in a form suitable for transmission. Children of this unit are expected to derive the PolyORB.Representations.Representation abstract type into a concrete type implementing one representation mechanism. @subsection @code{PolyORB.Protocols} The abstraction of a remote invocation protocol. To be derived by concrete personalities. A Protocol is a factory of Session. A Session is the actual object that implements one particular protocols. Protocols are factories of Sessions, and are used as parts of binding object factories. @subsection @code{PolyORB.Binding_Data} Client-side remote binding object factories. @c --------- @section Socket manipulation Those package handle low-level operations. @subsection @code{PolyORB.Sockets.*} Socket management. Protocol personalities are placed between those packages and the lower part of the neutral layer. @subsection @code{PolyORB.Asynch_Ev.*} Asynchronous event sources objects, which can trigger asynchronous ORB activities to react to external stimuli. @node Application personalities @chapter Application personalities @noindent Application personalities constitute the application layer, which is the upper part of PolyORB. Application personalities act as an interface between user applications and inner middleware (i.e. the neutral layer, @ref{Neutral layer}). The client part consists of forwarding the requests made by the application to the proper neutral primitives. The server part of a personality mainly consists of a set of servants that handle requests. Two kinds of servants are integrated into PolyORB: ``normal servants'' and minimal servants. @section Setting a ``normal'' servant Servants are components (@pxref{components}) that receive requests, do some work on them, and then may return an answer. @subsection Creating a servant The type @dfn{Servant} is defined in @code{PolyORB.Servants}, and is an abstract type, which must be derived to create a concrete servant type that will handle the requests sent to the application managed by your personality. Along with this type, you must write a @code{Execute_Servant} function that will receive messages, do some work, and then return another message. Basically, two kinds of messages are associated to servants: @code{Execute_Request} and @code{Executed_Request}, which are defined in @code{PolyORB.Servants.Interface}. Thus, the body of @code{Execute_Servant} should test if the incoming message is of type @code{Execute_Request}, and return a message of type @code{Executed_Request}. An @code{Execute_Request} message contains the request to handle, and a profile, from which comes the request, in order to know who sent the request. An @code{Executed_Request} message just contains the answer (the type of which is also @code{Request}). @subsection Registering a servant Once you have created a servant, you have to register it to the Neutral layer so that it can be receive requests from clients. The registering of a servant involves the @acronym{POA} (Portable Object Adapter, @pxref{object adapter}), which is concept coming from @acronym{CORBA}. Assuming you have created a POA called @code{The_POA} and you want to register a servant called @code{The_Servant}, you have to type something like this: @example PolyORB.POA.Basic_POA.Set_Servant (PolyORB.POA.Basic_POA.Basic_Obj_Adapter (The_POA.all)'Access, The_Servant'Unchecked_Access, Error); @end example By doing this, you associated @code{The_Servant} to @code{The_POA}. Now you just have to know which reference must be used to reach @code{The_Servant}, in order to communicate it to the clients. This is done by getting the ID @code{The_POA} assigned to @code{The_Servant}, and then creating a corresponding reference: @example declare Servant_Id : Object_Id_Access; The_Reference : PolyORB.References.Ref; begin Servant_To_Id (PolyORB.POA.Basic_POA.Basic_Obj_Adapter (The_POA.all)'Access, The_Servant'Unchecked_Access, Servant_Id, Error); if not PolyORB.Exceptions.Found (Error) then Create_Reference (The_ORB, Servant_Id, "", The_Reference); end if; end; @end example And then you just have to convert the reference into an IOR, URI, or whatever you wish (@pxref{references}). @section Setting a minimal servant @anchor{minimal servants} Minimal servants are alternative to classical servants. As their name suggests, they offer less flexibility than normal servants; however they are easier to set up, as they are some sort of pre-defined servants. Minimal servants are provided by the packages @code{PolyORB.Minimal_Servant} and @code{PolyORB.Minimal_Servant.Tools}. As for normal servants, you first have to create a concrete type by deriving type @code{Servant}. You also have to write the specification of a procedure named @code{Invoke}, that more or less corresponds to @code{Execute_Servant}. @code{Invoke} receives an access to the request, reads it and then puts the response in it while @code{Execute_Request} receives a message containing a request and returns another message containing a request (which should be the one which has been received, carrying the results). Then you just have to call @code{Initiate_Servant}, which associates your minimal servant to the object adapter (@pxref{object adapter}) set in the ORB. Minimal servants actually provide a simple way to easily set up servants without bothering about object adapter configuration. The main consequence is that a minimal servant is always referenced to the root object adapter, while using normal servants let you reference your servant to an object adapter you created yourself and then set in the object adapter arborescence. @subsection Managing the arguments When your servant receives a request, it must get all information in order to correctly handle the request. Method name is simply retrieved by reading the corresponding field inside the request. In order to retrieve the arguments, you have to call the procedure @code{Arguments} of the package @code{PolyORB.Requests}. Indeed, the argument list carried by the request contains both @code{in} and @code{out} arguments; you only want to get the @code{in} ones. @code{Arguments} is called with the request, a freshly created NV-List containing the signature of the arguments you are expecting, and two parameters indicating how to handle the argument list: @code{Identification} and @code{Can_Extend}. @code{Identification} allows for dealing with the different ways of handling argument lists, corresponding to different middleware paradigms. For example, in CORBA middleware, arguments are identified by their position, while in Web middleware they are identified by their name. So, for a Web personality, the order in which the personality handles the parameters does not matter. Depending on how the applications handle arguments, you can specify how the neutral layer should consider the argument lists. @code{Can_Extend} is meant to indicate wether @code{Arguments} can add arguments to your list or not. This is useful for personalities that do not know which arguments they are supposed to receive. This is the case for a web personality: indeed, in this middleware paradigm, the server reads all the arguments the client sends to it, and then looks if there is anything interesting; in @acronym{CORBA}, client and server follow an IDL contract, so all received arguments should be expected, and there should be no extra ones. @section Invoking a request Invoking a request implies three mechanisms: @enumerate @item create a request; @item send it through the ORB; @item receive and analyse the answer (if the personality is based on a request/answer mechanism). @end enumerate All those operations are handled by the package @code{PolyORB.Requests}. @subsection Creating a new request Before sending a request to anybody, the application personality has to create a new one. This is done by calling @code{Create_Request} located in the package @code{PolyORB.Requests}. The main parameters are: @itemize @item the neutral reference of the targeted object; @item the name of the operation you want to invoke @item a list containing all the arguments sent to the object; @item a list describing the signature of the data expected as return, and an optional other for the possible exceptions; @end itemize See @ref{references} for information about how to get a neutral reference to an object. The list of arguments is built using functions associated to @code{NV-List}s @pxref{nvlists}. Note that the argument list has to actually contain the arguments the application wants to send, while the return and exception lists only contain the signature of the expected data. @subsection Sending a request through the ORB Sending a request is very easy: you just have to call the @code{Invoke} procedure located in package @code{PolyORB.Requests}. Calling @code{Invoke} will pause your application, waiting for getting the request back with an answer. @subsection Handling the answer When the request comes back from the server, the field @code{Result} contains the answer to the request. @section Object adapter @anchor{object adapter} The concept of Object Adapter comes from the @acronym{CORBA} specifications. An object adapter manages the servants in order to send incoming requests to the proper one. Several packages gather the functions associated with the object adapters: they are named @code{PolyORB.Obj_Adapter.*} and @code{PolyORB.POA.*}. Two kinds of object adapters are presently defined within PolyORB: the Simple Object Adapter, defined in @code{PolyORB.Obj_Adapter.Simple}, and the Portable Object Adapter (POA), defined in packages @code{PolyORB.POA.*}.xs @subsection Simple Object Adapter The @acronym{SOA} only allows for basic registering and unregistering servants: servants are registered using @code{Export} and unregistered using @code{Unexport}. Thus it fits well for basic needs; minimal servants rely on the SOA (see @pxref{minimal servants}). An SOA can be created and destroyed using procedures @code{Create} and @code{Destroy}. @subsection Portable Object Adapter The @acronym{POA} behaves like what is specified in @acronym{CORBA}. POA are organized as a tree, with a root POA. You can create POAs and attach them to another one. Each POA has a name, which is used to retrieve it in the tree. Each POA is associated with certain policies, that drive its behaviour. @subsubsection Basic POA A @acronym{POA} implementation is located in @code{PolyORB.POA.Basic_POA}. This means that you may create other kinds of POA for special purposes. In order to be used in place of an SOA, the basic POA offers the same interface as SOA. It also offers the interface specified in @acronym{CORBA}. @subsubsection POA policies A POA is managed following policies, that define how to manage servants, etc. The available policies are those that are defined in @acronym{CORBA}. They are located in @code{PolyORB.POA_Policies.*} @node Protocol layer @chapter Protocol personalities Protocol personalities handle the communications with other nodes. All files concerning a protocol personality are usually put in a subdirectory of @code{src/}: @code{src/soap/} for the SOAP personality, etc. Creating a protocol personality is basically creating subpackages that implement concrete functions from abstract ones declared in the neutral layer. On an architectural point of view, a protocol personality is a stack of filters, like a stack of layers in OSI norms. When a protocol personality receives a request, it has to create a neutral request, as an application personality would do (@pxref{Application personalities}), but without including the request parameters. Indeed, as some protocols do not indicate the structure of the arguments, the protocol personality has to wait for a description of the arguments coming from the application personality (which is the only one supposed to know what is expected, according to the request name). When the argument description comes back through the neutral layer, then the personality can extract (unmarshal) the arguments, and send them. @section Reference management As PolyORB can handle several protocols, references are actually sets of several @dfn{profiles}, one for each protocol. Moreover, a profile must be printable according all available reference syntaxes (URI, IOR, etc.). A profile is identified by a @dfn{tag}, which is associated to a string prefix that characterizes the stringified version of the profile (i.e. ``IOR:'' for IORs) and functions to get a the profile from a string, and vice-versa. In order to be usable, a protocol personality has to provide functions to manage its profiles, and register them to the neutral layer. To do so, you have to create a subpackage of @code{PolyORB.Binding_Data}, which will contain concrete implementations of the abstract procedure and functions declared in @code{PolyORB.Binding_Data}. The functions provided by this package will be called by the neutral layer in order to make conversion between profiles and printable strings. To specify the functions that deal with references, the package must call the @code{Register} procedures located in packages @code{PolyORB.References.*}, giving them the profile tag, the stringifying and destringifying functions, etc. The call to those procedures must be handled by the PolyORB Initialization facility. To do so, you simple have to create a procedure that will contain all the calls to the registering procedures, and specify that this procedure should be called when the module is initialized by PolyORB. So you should write something like: @example procedure body Initialize is begin -- calling the registering procedures end Initialize; begin Register_Module (Module_Info' (Name => +"binding_data.my_proto_perso", Conflicts => Empty, Depends => +"sockets", Provides => +"binding_factories", Implicit => False, Init => Initialize'Access)); end PolyORB.Binding_Data.My_Proto_Perso; @end example @section Architecture of a protocol personality As said before, a protocol personality is mainly a stack of filters exchanging information. The filter stack relies on an access point. An access point is associated to a socket (@code{PolyORB.Socket}, @code{PolyORB.Transport.*}). PolyORB allows to create TCP-related access points (@code{PolyORB.Utils.TCP_Access_Points}) or UDP-related access points (@code{PolyORB.Utils.UDP_Access_Points}). The filter stack is built using @code{Chain_Factories} located in @code{PolyORB.Filters}. The access points is then registered to the ORB, using @code{Register_Access_Point}. @section Protocol functionalities A protocol personality provides functionalities to perform various operations concerning the requests. To do so, you have to create a subpackage @code{PolyORB.Protocols.My_Proto_Perso}, which contains concrete implementations of the abstract procedures declared in @code{PolyORB.Protocols}. @node Neutral layer @chapter Neutral layer @noindent The Neutral Layer is actually the inner middleware in itself. It offers several services and mechanisms to personalities. @section References @anchor{references} @cindex references @noindent @dfn{References} are used to identify an object, a resource, or whatever you may call it in the middleware paradigm you plan to implement. References generation and conversions are handled by the package @code{PolyORB.References} and its subpackages. Given a string representing an IOR, URI, Corbaloc, etc.@:, @code{PolyORB.References} provides the procedure @code{String_To_Object} that converts the string into a reference. The symmetric operation is implemented in subpackages @code{PolyORB.References.IOR}, @code{PolyORB.References.URI}, etc@. Each subpackage provides a function called @code{Object_To_String} that returns a representation of the reference using IOR, URI, etc@. @section Components @anchor{components} @section Any types and associates @anchor{any types} Data that are exchanged between client and server are transported in what are called @dfn{Any types}. Any types can carry various data types: integer, string, etc.@: An Any type associates raw data to a @dfn{TypeCode}, which indicates the nature of the data. @subsection Any types All usefull functions dealing with Any types are located in package @code{PolyORB.Any}. @code{PolyORB.Any} provides functions to compare Any types, get their TypeCode (in order to know what kind of data extract from them), build them and extract data from them, etc.@: TypeCode are predefined for simple data types: Long, String, etc.@: So @code{PolyORB.Any} provides @code{To_Any} functions to build Any types from simple data types (integer, string, etc.), and symmetrically provides @code{From_Any} functions to extract data from an Any type. Complex types are a little more tricky: indeed, you have to create an appropriate @dfn{TypeCode}, then create an Any type with this TypeCode, and then store your data into it. The specification of the package describes the right way for creating such complex Any types. Here is a small example (adapted from @code{SOAP.Types} in the Web personality). Let's suppose we want to create an array of long integers. We first have to declare a new TypeCode, using the stereotype @code{TC_Array}. @example Ar_Type : PolyORB.Any.TypeCode.Object := PolyORB.Any.TypeCode.TC_Array; @end example Then, as indicated in the specification, we have to store the size of the array and then the type of the data we want to store. @example PolyORB.Any.TypeCode.Add_Parameter (Ar_Type, PolyORB.Any.To_Any (PolyORB.Types.Unsigned_Long (Size_Of_The_Array_To_Store))); PolyORB.Any.TypeCode.Add_Parameter (Ar_Type, To_Any (PolyORB.Any.TypeCode.TC_Long)); @end example We then have a proper TypeCode; we have to create an Any with this TypeCode: @example Ar : PolyORB.Any.Any := PolyORB.Any.Get_Empty_Any_Aggregate (Ar_Type); @end example Finally we store the array into the Any: @example for K in The_Array'Range loop PolyORB.Any.Add_Aggregate_Element (Ar, To_Any (The_Array (K))); end loop; @end example In order to retrieve data from an Any, we first get the TypeCode of the Any: @example Kind_Of_Any : constant PolyORB.Any.TCKind := PolyORB.Any.TypeCode.Kind (PolyORB.Any.Get_Unwound_Type (The_Any)); @end example Considering this is an array, we then have to extract its size and the type of data: @example if Kind_Of_Any = Tk_Array then declare use PolyORB.Types; Number_Of_Elements : constant Unsigned_Long := Unsigned_Long (PolyORB.Any.TypeCode.Length (PolyORB.Any.Get_Type (The_Any))); Element_Type : constant PolyORB.Any.TypeCode.Object := PolyORB.Any.TypeCode.Content_Type (PolyORB.Any.Get_Type (Item)); The_Array : array (1 .. Integer (Number_Of_Elements)) of Element_Type; @end example Finally, we retrieve all element one by one: @example begin for Index in 1 .. Number_Of_Elements loop The_Array (Index) := From_Any (PolyORB.Any.Get_Aggregate_Element (The_Any, Element_Type, PolyORB.Types.Unsigned_Long (Index - 1))); end loop; end; end if; @end example @subsection Named Values @anchor{named values} @dfn{Named Values} are data structure associating an Any type and a string representing the data name. Named Values transport data along with a type (provided by the Any type) and a name (stored in the string), thus allowing to fully identify data. Functions to handle Named Values are provided by @code{PolyORB.Any}. @subsection NV-Lists @anchor{nvlists} @cindex nv-lists @dfn{NV-List} stands for ``Named Value List''. This directly comes from the @acronym{CORBA} specifications. All data transferred across layers are put in NV-Lists. The package @code{PolyORB.Any.NVLists} provides primitives to handle NV-Lists. Before using a NV-List, you must create it using @code{Create}; then you can add NamedValues or Any types using @code{Add_Item} (in fact, adding an Any type will result in building a Named Value an adding it to the NV-List). When you have finished using the NV-List, you destroy it using @code{Free}. @node Services @chapter Services PolyORB contains several packages offering services to developer. @section Exceptions @anchor{exceptions} PolyORB introduces its own system of exceptions, which should be used instead of Ada exceptions. PolyORB exceptions are defined in @code{PolyORB.Exceptions}. they basically consist of an out parameter passed to procedures. This may appear obsolete compared to Ada mechanism; the main advantage of this approach is that it increases performances compared to Ada exceptions. @section Logging facility The package @code{PolyORB.Log} provides a facility to display messages on screen, typically for debugging purposes. You can use this package this way: @example with PolyORB.Log; package body MyPackage is use PolyORB.Log; package L is new PolyORB.Log.Facility_Log ("my.facility"); procedure O (Message : in Standard.String; Level : Log_Level := Debug) renames L.Output; ... pragma Debug (O ("hello there!")); @end example The parameter @code{Level} indicates the default logging level, allowing for a hierarchy in messages. Usually this is set to @code{Debug}. See @code{polyorb-log.ads} for the list of possible log levels. When the application is launched, the logging facility looks for a file named @code{polyorb.conf} in the current directory. This file should contain lines indicating from which log level messages should be logged. The reference @code{polyorb.conf} file is located in the src/ subdirectory. So you just have to copy it into your execution directory and add the required lines. In our example, you should add @example my.facility=debug @end example indicating that all messages of higher importance than ``debug'' should be displayed. If you did not add a line for your logging facility, then ``notice'' is used as a default value. @section Calendar @anchor{calendar} Due to PolyORB configurability towards tasking policies, there are restrictions regarding which package to use to get the time. Thus, Ravenscar compliant applications cannot use @code{Ada.Calendar}. In the other hand, systematically relying on @code{Ada.Real_Time} to get the time may uselessly use the memory. You should use the package @code{PolyORB.Calendar}, which provides the primitives of @code{Ada.Calendar}, and the implementation of which depends on the tasking policy. @node Coding rules @chapter Coding rules You should follow a few coding rules, in order to preserve harmony in the code. Basically, you must follow the GNAT coding style, and a few others that are mentioned in a file named @code{CODING_GUIDELINES}, located in the @code{doc/} subdirectory. @include gfdl.texi @bye polyorb-2.8~20110207.orig/docs/polyorb_ug.bib0000644000175000017500000000554211750740337020205 0ustar xavierxavier@STRING{sun = {{SUN}} } @Book{ corba, title = {{The Common Object Request Broker:} Architecture and Specification, revision 3.0.3}, author = {OMG}, publisher = {OMG}, year = {2004}, month = mar, note = {OMG Technical Document formal/2004-03-12} } @Book{ csiv2, title = {Common Secure Interoperability (CSIv2)}, author = {OMG}, publisher = {OMG} } @Book{ corba-ada-mapping1.2:2001, author = {OMG}, title = {Ada Language Mapping Specification, v1.2}, publisher = {OMG}, year = {2001}, month = oct, note = {OMG Technical Document formal/2001-10-42} } @Book{ rt-corba1.1:2002, author = {OMG}, title = {Real-Time CORBA Specification, static scheduling, v1.1}, publisher = {OMG}, year = {2002}, month = apr, note = {OMG Technical Document formal/2002-08-02} } @Book{ rt-corba2.0:2003, author = {OMG}, title = {Real-Time CORBA Specification, dynamic scheduling, v2.0}, publisher = {OMG}, year = {2003}, month = apr, note = {OMG Technical Document formal/2003-11-01} } @Book{ miop, author = {OMG}, publisher = {OMG}, title = {unreliable {M}ulticast {I}nter{ORB} {P}rotocol specification}, year = {2002}, note = {OMG Technical Document ptc/03-01-11} } @Book{ ada-rm95, title = {{Information Technology -- Programming Languages -- Ada}}, author = {ISO}, publisher = {ISO}, year = 1995, month = feb, note = "ISO/IEC/ANSI 8652:1995" } @Book{ ada-rm, title = {{Information Technology -- Programming Languages -- Ada}}, author = {ISO}, publisher = {ISO}, year = 2006, month = nov, note = "ISO/IEC 8652:1995 with Technical Corrigendum 1 and Amendment 1 (``Ada 2005'')" } @Misc{ jms, author = sun, year = 1999, title = {{Java Message Service}}, text = "Sun Microsystems, Java Message Service, http:/java.sun.com/jms" } @Misc{ aws, title = {{Ada Web Server (AWS) 1.3}}, author = {P. Obry}, year = {2003}, text = {\url{http://libre.adacore.com/aws/}} } @Manual{ glade_ug, title = {{GLADE User's Guide r 1.54}}, year = {2006}, month = feb, url = {\url{https://libre2.adacore.com/polyorb/}} } @Manual{ soap12primer, title = {{Simple Object Access Protocol (SOAP) 1.2: primer}}, organization = {W3C}, year = {2003}, month = {june}, note = {W3C recommandation}, url = {\url{http://www.w3.org/TR/soap12-part0/}} } @Manual{ xml, title = {{Extensible Markup Language (XML) 1.0}}, organization = {W3C}, year = 2000, month = oct, note = {W3C recommandation}, url = {\url{http://www.w3.org/TR/REC-xml/}} } @InProceedings{ burns98ravenscar, author = {B. Dobbing and A. Burns}, title = {{The Ravenscar tasking profile for high integrity real-time programs}}, booktitle = {Proceedings of SigAda'98}, year = 1998, address = {Washington, DC, USA}, month = nov } polyorb-2.8~20110207.orig/docs/texinfo.bst0000644000175000017500000005325611750740337017541 0ustar xavierxavier% texinfo.bst from the % BibTeX standard bibliography style `alpha' % $Id$ % version 0.99a for BibTeX versions 0.99a or later, LaTeX version 2.09. % Copyright (C) 1985, all rights reserved. % Copying of this file is authorized only if either % (1) you make absolutely no changes to your copy, including name, or % (2) if you do make changes, you name it something other than % btxbst.doc, plain.bst, unsrt.bst, alpha.bst, and abbrv.bst. % This restriction helps ensure that all standard styles are identical. % The file btxbst.doc has the documentation for this style. ENTRY { address author booktitle chapter edition editor howpublished institution journal key month note number organization pages publisher school series title type volume year } {} { label extra.label sort.label } INTEGERS { output.state before.all mid.sentence after.sentence after.block } FUNCTION {init.state.consts} { #0 'before.all := #1 'mid.sentence := #2 'after.sentence := #3 'after.block := } STRINGS { s t } FUNCTION {output.nonnull} { 's := output.state mid.sentence = { ", " * write$ } { output.state after.block = { add.period$ write$ newline$ } { output.state before.all = 'write$ { add.period$ " " * write$ } if$ } if$ mid.sentence 'output.state := } if$ s } FUNCTION {output} { duplicate$ empty$ 'pop$ 'output.nonnull if$ } FUNCTION {output.check} { 't := duplicate$ empty$ { pop$ "empty " t * " in " * cite$ * warning$ } 'output.nonnull if$ } FUNCTION {output.bibitem} { newline$ "@item [" write$ label write$ "]" write$ newline$ "" before.all 'output.state := } FUNCTION {fin.entry} { add.period$ write$ newline$ } FUNCTION {new.block} { output.state before.all = 'skip$ { after.block 'output.state := } if$ } FUNCTION {new.sentence} { output.state after.block = 'skip$ { output.state before.all = 'skip$ { after.sentence 'output.state := } if$ } if$ } FUNCTION {not} { { #0 } { #1 } if$ } FUNCTION {and} { 'skip$ { pop$ #0 } if$ } FUNCTION {or} { { pop$ #1 } 'skip$ if$ } FUNCTION {new.block.checka} { empty$ 'skip$ 'new.block if$ } FUNCTION {new.block.checkb} { empty$ swap$ empty$ and 'skip$ 'new.block if$ } FUNCTION {new.sentence.checka} { empty$ 'skip$ 'new.sentence if$ } FUNCTION {new.sentence.checkb} { empty$ swap$ empty$ and 'skip$ 'new.sentence if$ } FUNCTION {field.or.null} { duplicate$ empty$ { pop$ "" } 'skip$ if$ } FUNCTION {emphasize} { duplicate$ empty$ { pop$ "" } { "@cite@[" swap$ * "@]" * } if$ } INTEGERS { nameptr namesleft numnames } FUNCTION {format.names} { 's := #1 'nameptr := s num.names$ 'numnames := numnames 'namesleft := { namesleft #0 > } { s nameptr "{ff~}{vv~}{ll}{, jj}" format.name$ 't := nameptr #1 > { namesleft #1 > { ", " * t * } { numnames #2 > { "," * } 'skip$ if$ t "others" = { " et~al." * } { " and " * t * } if$ } if$ } 't if$ nameptr #1 + 'nameptr := namesleft #1 - 'namesleft := } while$ } FUNCTION {format.authors} { author empty$ { "" } { author format.names } if$ } FUNCTION {format.editors} { editor empty$ { "" } { editor format.names editor num.names$ #1 > { ", editors" * } { ", editor" * } if$ } if$ } FUNCTION {format.title} { title empty$ { "" } { title "t" change.case$ } if$ } FUNCTION {n.dashify} { 't := "" { t empty$ not } { t #1 #1 substring$ "-" = { t #1 #2 substring$ "--" = not { "--" * t #2 global.max$ substring$ 't := } { { t #1 #1 substring$ "-" = } { "-" * t #2 global.max$ substring$ 't := } while$ } if$ } { t #1 #1 substring$ * t #2 global.max$ substring$ 't := } if$ } while$ } FUNCTION {format.date} { year empty$ { month empty$ { "" } { "there's a month but no year in " cite$ * warning$ month } if$ } { month empty$ 'year { month " " * year * } if$ } if$ } FUNCTION {format.btitle} { title emphasize } FUNCTION {tie.or.space.connect} { duplicate$ text.length$ #3 < { "~" } { " " } if$ swap$ * * } FUNCTION {either.or.check} { empty$ 'pop$ { "can't use both " swap$ * " fields in " * cite$ * warning$ } if$ } FUNCTION {format.bvolume} { volume empty$ { "" } { "volume" volume tie.or.space.connect series empty$ 'skip$ { " of " * series emphasize * } if$ "volume and number" number either.or.check } if$ } FUNCTION {format.number.series} { volume empty$ { number empty$ { series field.or.null } { output.state mid.sentence = { "number" } { "Number" } if$ number tie.or.space.connect series empty$ { "there's a number but no series in " cite$ * warning$ } { " in " * series * } if$ } if$ } { "" } if$ } FUNCTION {format.edition} { edition empty$ { "" } { output.state mid.sentence = { edition "l" change.case$ " edition" * } { edition "t" change.case$ " edition" * } if$ } if$ } INTEGERS { multiresult } FUNCTION {multi.page.check} { 't := #0 'multiresult := { multiresult not t empty$ not and } { t #1 #1 substring$ duplicate$ "-" = swap$ duplicate$ "," = swap$ "+" = or or { #1 'multiresult := } { t #2 global.max$ substring$ 't := } if$ } while$ multiresult } FUNCTION {format.pages} { pages empty$ { "" } { pages multi.page.check { "pages" pages n.dashify tie.or.space.connect } { "page" pages tie.or.space.connect } if$ } if$ } FUNCTION {format.vol.num.pages} { volume field.or.null number empty$ 'skip$ { "(" number * ")" * * volume empty$ { "there's a number but no volume in " cite$ * warning$ } 'skip$ if$ } if$ pages empty$ 'skip$ { duplicate$ empty$ { pop$ format.pages } { ":" * pages n.dashify * } if$ } if$ } FUNCTION {format.chapter.pages} { chapter empty$ 'format.pages { type empty$ { "chapter" } { type "l" change.case$ } if$ chapter tie.or.space.connect pages empty$ 'skip$ { ", " * format.pages * } if$ } if$ } FUNCTION {format.in.ed.booktitle} { booktitle empty$ { "" } { editor empty$ { "In " booktitle emphasize * } { "In " format.editors * ", " * booktitle emphasize * } if$ } if$ } FUNCTION {empty.misc.check} { author empty$ title empty$ howpublished empty$ month empty$ year empty$ note empty$ and and and and and key empty$ not and { "all relevant fields are empty in " cite$ * warning$ } 'skip$ if$ } FUNCTION {format.thesis.type} { type empty$ 'skip$ { pop$ type "t" change.case$ } if$ } FUNCTION {format.tr.number} { type empty$ { "Technical Report" } 'type if$ number empty$ { "t" change.case$ } { number tie.or.space.connect } if$ } FUNCTION {format.article.crossref} { key empty$ { journal empty$ { "need key or journal for " cite$ * " to crossref " * crossref * warning$ "" } { "In @cite@[" journal * "@]" * } if$ } { "In " key * } if$ " @bibcite{" * crossref * "}" * } FUNCTION {format.crossref.editor} { editor #1 "{vv~}{ll}" format.name$ editor num.names$ duplicate$ #2 > { pop$ " et~al." * } { #2 < 'skip$ { editor #2 "{ff }{vv }{ll}{ jj}" format.name$ "others" = { " et~al." * } { " and " * editor #2 "{vv~}{ll}" format.name$ * } if$ } if$ } if$ } FUNCTION {format.book.crossref} { volume empty$ { "empty volume in " cite$ * "'s crossref of " * crossref * warning$ "In " } { "Volume" volume tie.or.space.connect " of " * } if$ editor empty$ editor field.or.null author field.or.null = or { key empty$ { series empty$ { "need editor, key, or series for " cite$ * " to crossref " * crossref * warning$ "" * } { "@cite@[" * series * "@]" * } if$ } { key * } if$ } { format.crossref.editor * } if$ " @bibcite{" * crossref * "}" * } FUNCTION {format.incoll.inproc.crossref} { editor empty$ editor field.or.null author field.or.null = or { key empty$ { booktitle empty$ { "need editor, key, or booktitle for " cite$ * " to crossref " * crossref * warning$ "" } { "In @cite@[" booktitle * "@]" * } if$ } { "In " key * } if$ } { "In " format.crossref.editor * } if$ " @bibcite{" * crossref * "}" * } FUNCTION {article} { output.bibitem format.authors "author" output.check new.block format.title "title" output.check new.block crossref missing$ { journal emphasize "journal" output.check format.vol.num.pages output format.date "year" output.check } { format.article.crossref output.nonnull format.pages output } if$ new.block note output fin.entry } FUNCTION {book} { output.bibitem author empty$ { format.editors "author and editor" output.check } { format.authors output.nonnull crossref missing$ { "author and editor" editor either.or.check } 'skip$ if$ } if$ new.block format.btitle "title" output.check crossref missing$ { format.bvolume output new.block format.number.series output new.sentence publisher "publisher" output.check address output } { new.block format.book.crossref output.nonnull } if$ format.edition output format.date "year" output.check new.block note output fin.entry } FUNCTION {booklet} { output.bibitem format.authors output new.block format.title "title" output.check howpublished address new.block.checkb howpublished output address output format.date output new.block note output fin.entry } FUNCTION {inbook} { output.bibitem author empty$ { format.editors "author and editor" output.check } { format.authors output.nonnull crossref missing$ { "author and editor" editor either.or.check } 'skip$ if$ } if$ new.block format.btitle "title" output.check crossref missing$ { format.bvolume output format.chapter.pages "chapter and pages" output.check new.block format.number.series output new.sentence publisher "publisher" output.check address output } { format.chapter.pages "chapter and pages" output.check new.block format.book.crossref output.nonnull } if$ format.edition output format.date "year" output.check new.block note output fin.entry } FUNCTION {incollection} { output.bibitem format.authors "author" output.check new.block format.title "title" output.check new.block crossref missing$ { format.in.ed.booktitle "booktitle" output.check format.bvolume output format.number.series output format.chapter.pages output new.sentence publisher "publisher" output.check address output format.edition output format.date "year" output.check } { format.incoll.inproc.crossref output.nonnull format.chapter.pages output } if$ new.block note output fin.entry } FUNCTION {inproceedings} { output.bibitem format.authors "author" output.check new.block format.title "title" output.check new.block crossref missing$ { format.in.ed.booktitle "booktitle" output.check format.bvolume output format.number.series output format.pages output address empty$ { organization publisher new.sentence.checkb organization output publisher output format.date "year" output.check } { address output.nonnull format.date "year" output.check new.sentence organization output publisher output } if$ } { format.incoll.inproc.crossref output.nonnull format.pages output } if$ new.block note output fin.entry } FUNCTION {conference} { inproceedings } FUNCTION {manual} { output.bibitem author empty$ { organization empty$ 'skip$ { organization output.nonnull address output } if$ } { format.authors output.nonnull } if$ new.block format.btitle "title" output.check author empty$ { organization empty$ { address new.block.checka address output } 'skip$ if$ } { organization address new.block.checkb organization output address output } if$ format.edition output format.date output new.block note output fin.entry } FUNCTION {mastersthesis} { output.bibitem format.authors "author" output.check new.block format.title "title" output.check new.block "Master's thesis" format.thesis.type output.nonnull school "school" output.check address output format.date "year" output.check new.block note output fin.entry } FUNCTION {misc} { output.bibitem format.authors output title howpublished new.block.checkb format.title output howpublished new.block.checka howpublished output format.date output new.block note output fin.entry empty.misc.check } FUNCTION {phdthesis} { output.bibitem format.authors "author" output.check new.block format.btitle "title" output.check new.block "PhD thesis" format.thesis.type output.nonnull school "school" output.check address output format.date "year" output.check new.block note output fin.entry } FUNCTION {proceedings} { output.bibitem editor empty$ { organization output } { format.editors output.nonnull } if$ new.block format.btitle "title" output.check format.bvolume output format.number.series output address empty$ { editor empty$ { publisher new.sentence.checka } { organization publisher new.sentence.checkb organization output } if$ publisher output format.date "year" output.check } { address output.nonnull format.date "year" output.check new.sentence editor empty$ 'skip$ { organization output } if$ publisher output } if$ new.block note output fin.entry } FUNCTION {techreport} { output.bibitem format.authors "author" output.check new.block format.title "title" output.check new.block format.tr.number output.nonnull institution "institution" output.check address output format.date "year" output.check new.block note output fin.entry } FUNCTION {unpublished} { output.bibitem format.authors "author" output.check new.block format.title "title" output.check new.block note "note" output.check format.date output fin.entry } FUNCTION {default.type} { misc } MACRO {jan} {"January"} MACRO {feb} {"February"} MACRO {mar} {"March"} MACRO {apr} {"April"} MACRO {may} {"May"} MACRO {jun} {"June"} MACRO {jul} {"July"} MACRO {aug} {"August"} MACRO {sep} {"September"} MACRO {oct} {"October"} MACRO {nov} {"November"} MACRO {dec} {"December"} MACRO {acmcs} {"ACM Computing Surveys"} MACRO {acta} {"Acta Informatica"} MACRO {cacm} {"Communications of the ACM"} MACRO {ibmjrd} {"IBM Journal of Research and Development"} MACRO {ibmsj} {"IBM Systems Journal"} MACRO {ieeese} {"IEEE Transactions on Software Engineering"} MACRO {ieeetc} {"IEEE Transactions on Computers"} MACRO {ieeetcad} {"IEEE Transactions on Computer-Aided Design of Integrated Circuits"} MACRO {ipl} {"Information Processing Letters"} MACRO {jacm} {"Journal of the ACM"} MACRO {jcss} {"Journal of Computer and System Sciences"} MACRO {scp} {"Science of Computer Programming"} MACRO {sicomp} {"SIAM Journal on Computing"} MACRO {tocs} {"ACM Transactions on Computer Systems"} MACRO {tods} {"ACM Transactions on Database Systems"} MACRO {tog} {"ACM Transactions on Graphics"} MACRO {toms} {"ACM Transactions on Mathematical Software"} MACRO {toois} {"ACM Transactions on Office Information Systems"} MACRO {toplas} {"ACM Transactions on Programming Languages and Systems"} MACRO {tcs} {"Theoretical Computer Science"} READ FUNCTION {sortify} { purify$ "l" change.case$ } INTEGERS { len } FUNCTION {chop.word} { 's := 'len := s #1 len substring$ = { s len #1 + global.max$ substring$ } 's if$ } INTEGERS { et.al.char.used } FUNCTION {initialize.et.al.char.used} { #0 'et.al.char.used := } EXECUTE {initialize.et.al.char.used} FUNCTION {format.lab.names} { 's := s num.names$ 'numnames := numnames #1 > { numnames #4 > { #3 'namesleft := } { numnames 'namesleft := } if$ #1 'nameptr := "" { namesleft #0 > } { nameptr numnames = { s nameptr "{ff }{vv }{ll}{ jj}" format.name$ "others" = { "{\etalchar{+}}" * #1 'et.al.char.used := } { s nameptr "{v{}}{l{}}" format.name$ * } if$ } { s nameptr "{v{}}{l{}}" format.name$ * } if$ nameptr #1 + 'nameptr := namesleft #1 - 'namesleft := } while$ numnames #4 > { "{\etalchar{+}}" * #1 'et.al.char.used := } 'skip$ if$ } { s #1 "{v{}}{l{}}" format.name$ duplicate$ text.length$ #2 < { pop$ s #1 "{ll}" format.name$ #3 text.prefix$ } 'skip$ if$ } if$ } FUNCTION {author.key.label} { author empty$ { key empty$ { cite$ #1 #3 substring$ } { key #3 text.prefix$ } if$ } { author format.lab.names } if$ } FUNCTION {author.editor.key.label} { author empty$ { editor empty$ { key empty$ { cite$ #1 #3 substring$ } { key #3 text.prefix$ } if$ } { editor format.lab.names } if$ } { author format.lab.names } if$ } FUNCTION {author.key.organization.label} { author empty$ { key empty$ { organization empty$ { cite$ #1 #3 substring$ } { "The " #4 organization chop.word #3 text.prefix$ } if$ } { key #3 text.prefix$ } if$ } { author format.lab.names } if$ } FUNCTION {editor.key.organization.label} { editor empty$ { key empty$ { organization empty$ { cite$ #1 #3 substring$ } { "The " #4 organization chop.word #3 text.prefix$ } if$ } { key #3 text.prefix$ } if$ } { editor format.lab.names } if$ } FUNCTION {calc.label} { type$ "book" = type$ "inbook" = or 'author.editor.key.label { type$ "proceedings" = 'editor.key.organization.label { type$ "manual" = 'author.key.organization.label 'author.key.label if$ } if$ } if$ duplicate$ year field.or.null purify$ #-1 #2 substring$ * 'label := year field.or.null purify$ #-1 #4 substring$ * sortify 'sort.label := } FUNCTION {sort.format.names} { 's := #1 'nameptr := "" s num.names$ 'numnames := numnames 'namesleft := { namesleft #0 > } { nameptr #1 > { " " * } 'skip$ if$ s nameptr "{vv{ } }{ll{ }}{ ff{ }}{ jj{ }}" format.name$ 't := nameptr numnames = t "others" = and { "et al" * } { t sortify * } if$ nameptr #1 + 'nameptr := namesleft #1 - 'namesleft := } while$ } FUNCTION {sort.format.title} { 't := "A " #2 "An " #3 "The " #4 t chop.word chop.word chop.word sortify #1 global.max$ substring$ } FUNCTION {author.sort} { author empty$ { key empty$ { "to sort, need author or key in " cite$ * warning$ "" } { key sortify } if$ } { author sort.format.names } if$ } FUNCTION {author.editor.sort} { author empty$ { editor empty$ { key empty$ { "to sort, need author, editor, or key in " cite$ * warning$ "" } { key sortify } if$ } { editor sort.format.names } if$ } { author sort.format.names } if$ } FUNCTION {author.organization.sort} { author empty$ { organization empty$ { key empty$ { "to sort, need author, organization, or key in " cite$ * warning$ "" } { key sortify } if$ } { "The " #4 organization chop.word sortify } if$ } { author sort.format.names } if$ } FUNCTION {editor.organization.sort} { editor empty$ { organization empty$ { key empty$ { "to sort, need editor, organization, or key in " cite$ * warning$ "" } { key sortify } if$ } { "The " #4 organization chop.word sortify } if$ } { editor sort.format.names } if$ } FUNCTION {presort} { calc.label sort.label " " * type$ "book" = type$ "inbook" = or 'author.editor.sort { type$ "proceedings" = 'editor.organization.sort { type$ "manual" = 'author.organization.sort 'author.sort if$ } if$ } if$ * " " * year field.or.null sortify * " " * title field.or.null sort.format.title * #1 entry.max$ substring$ 'sort.key$ := } ITERATE {presort} SORT STRINGS { longest.label last.sort.label next.extra } INTEGERS { longest.label.width last.extra.num } FUNCTION {initialize.longest.label} { "" 'longest.label := #0 int.to.chr$ 'last.sort.label := "" 'next.extra := #0 'longest.label.width := #0 'last.extra.num := } FUNCTION {forward.pass} { last.sort.label sort.label = { last.extra.num #1 + 'last.extra.num := last.extra.num int.to.chr$ 'extra.label := } { "a" chr.to.int$ 'last.extra.num := "" 'extra.label := sort.label 'last.sort.label := } if$ } FUNCTION {reverse.pass} { next.extra "b" = { "a" 'extra.label := } 'skip$ if$ label extra.label * 'label := label width$ longest.label.width > { label 'longest.label := label width$ 'longest.label.width := } 'skip$ if$ extra.label 'next.extra := } EXECUTE {initialize.longest.label} ITERATE {forward.pass} REVERSE {reverse.pass} FUNCTION {begin.bib} { et.al.char.used { "\newcommand{\etalchar}[1]{$^{#1}$}" write$ newline$ } 'skip$ if$ % preamble$ empty$ % 'skip$ % { preamble$ write$ newline$ } % if$ "@c \begin@[thebibliography@]@[" longest.label * "@]" * write$ newline$ } EXECUTE {begin.bib} EXECUTE {init.state.consts} ITERATE {call.type$} FUNCTION {end.bib} { newline$ "@c \end@[thebibliography@]" write$ newline$ } EXECUTE {end.bib} polyorb-2.8~20110207.orig/docs/CODING_GUIDELINES0000644000175000017500000001107611750740337017743 0ustar xavierxavier-- CODING GUIDELINES for the PolyORB project -- $Id: CODING_GUIDELINES 123095 2008-03-18 17:28:57Z quinot $ First read the file CONTRIBUTING for legal instructions for contributors. The Ada 95 Quality & Style Guide is included by reference. Code layout should follow the usual GNAT practice. Every package that can be declared Pure shall, then: every package that can be Preelaborate shall, then: every package that can have an Elaborate_Body pragma shall, then: every package that cannot or need not have any of the above shall have a comment that explains why. Each file should start with the standard PolyORB copyright header, then a blank line, then a comment that documents its purpose, followed by a blank line. The PolyORB copyright header might be adapted for copyrighted specs or code from third party. If a package body needs to explicitly execute some code for its initialization, this MUST NOT be done in the elaboration code. Instead, a parameterless procedure Initialize must be declared containing the necessary initialization code, and this procedure should be registered with the initialization procedure, PolyORB.Initialization. Direct use of tasking runtime or any constructs that would drag tasking in its dependencies is explicitly prohibited. All concurrent programming is to be performed using PolyORB.Tasking.* API. This also applies to C code, which may not call the pthreads library directly. No dependencies on personality specific code are allowed anywhere except in units implementing this specific personality. All the code shall be compilable with pragma Profile (Ravenscar), except for code dedicated to very specific functions such as concurrent constructions. This should be clearly indicated in package name and source code. The code shall not produce warnings when compiled with -gnatwa -gnatyg. Any use of pragma Warnings (Off) shall be documented by a comment. Usage of Ada 2005 features is restricted as follows: * The following Ada 2005 features are allowed: - use of Ada.Directories - use of Ada.Containers and children thereof - raise EXC with STR - Object.Method notation - anonymous access components and objects - use of "overriding" and "not overriding" indicators * All other Ada 2005 features are prohibited. In particular, the code must be compatible with application components using Ada 95 and Ada 2005 alike. * In addition to the restrictions above, there is a general requirement that PolyORB can be compiled with any GNAT version that is listed as supported in the PolyORB User's Guide. When necessary, tag the code with - 'XXX' to indicate dubious code. - 'WAG:Y.ZZ' to indicate constructs used to work around a behavior in GNAT version Y.ZZ (the intent of these markers is to allow such work-arounds to be removed once version Y.ZZ is not listed anymore as supported for building PolyORB). - 'Implementation note:' to indicate modifications to a 'should be' implementation to work around specific problems. Whenever possible, do not add new exceptions or exception handlers to PolyORB's neutral core and protocol personalities. Instead, use error handling mechanisms provided by PolyORB.Exceptions. Header box should be up to date whenever necessary: - Copyright date information is either - x where x is year of code's creation, - y - z where y is year of code's creation and z is year of last modification, if y /= z. By code's creation, we mean the date the code was first created and checked in in PolyORB repository. If packages are renamed, merged, copyright years must remain consistent with package content. - Some packages require specific adjustments to take into account references to specifications (e.g. CORBA related packages) or other projects (e.g. AWS) Always update the MANIFEST file and any makefile.am when the source tree is modified. Always update (or create if necessary) README file for each example. New features and incompatible changes shall be documented in the features-XXX file pertaining to the upcoming release. These files document what *new* features are present in a given release. A valid tracking number must be included for every new feature. Any change in name or semantics of a configuration variable must be considered an incompatible change. Any new configuration variable must be documented as a new feature, and also added to the example src/polyorb.conf file. Major new features must also be included in the FEATURES file, which gives an overview of what PolyORB provides. Any modification to NEWS must be propagated to the PolyORB User's guide to ensure consistency. polyorb-2.8~20110207.orig/docs/polyorb-config.10000644000175000017500000000353111750740337020355 0ustar xavierxavier.TH POLYORB-CONFIG 1 "April 26, 2007" "PolyORB team" "PolyORB documentation" .SH NAME polyorb-config - script to get information about the installed version of PolyORB. .SH SYNOPSIS .B polyorb-config [--prefix[=DIR]] [--exec-prefix[=DIR]] [--version|-v] [--config] [--libs] [--cflags] [--idls] [--help] .SH DESCRIPTION \fIpolyorb-config\fP is a tool that is used to determine the compiler and linker flags that should be used to compile and link programs that use \fIPolyORB\fP. .SH OPTIONS .l \fIpolyorb-config\fP accepts the following options: .TP 8 .B \-\-prefix[=DIR] Output the directory in which PolyORB architecture-independent files are installed, or set this directory to DIR. .TP 8 .B \-\-exec\-prefix[=DIR] Output the directory in which PolyORB architecture-dependent files are installed, or set this directory to DIR. .TP 8 .B \-\-version|\-v Print the currently installed version of \fIPolyORB\fP on the standard output. .TP 8 .B \-\-config Print the configuration of the currently installed version of \fIPolyORB\fP on the standard output. .TP 8 .B \-\-libs Print the linker flags that are necessary to link a \fIPolyORB\fP program. .TP 8 .B \-\-cflags Print the compiler flags that are necessary to compile a \fIPolyORB\fP program. .TP 8 .B \-\-idls Print the flags to set up path to CORBA's IDL for idlac. .TP 8 .B \-\-with-appli-perso=P,P,P Restrict output to only those flags relevant to the listed applicative personalities. .TP 8 .B \-\-with-proto-perso=P,P,P Restrict output to only those flags relevant to the listed protocol personalities. .TP 8 .B \-\-with-corba-services=S,S,S Restrict output to only those flags relevant to the listed services. .TP 8 .B \-\-help Print help message. .SH AUTHORS The \fIPolyORB\fP team, polyorb-devel@lists.adacore.com. .SH SEE ALSO .br The \fIPolyORB\fP WWW page, .B http://libre.adacore.com/polyorb/ .b polyorb-2.8~20110207.orig/docs/CONTRIBUTING0000644000175000017500000000272611750740337017201 0ustar xavierxavier-- LEGAL INSTRUCTIONS for contributors to PolyORB -- $Id: CONTRIBUTING 37320 2006-02-01 19:59:56Z quinot $ The copyright in any contribution to PolyORB must be assigned to the Free Software Foundation prior to checkin. Each contributor must fill out the form below and email it to the Free Software Foundation. The FSF will then send back a copyright assignment document and instructions to the contributor. ====================================================================== Please email the following information to fsf-records@gnu.org, and we will send you the assignment form for your past and future changes. Please use your full legal name (in ASCII characters) as the subject line of the message. ---------------------------------------------------------------------- REQUEST: SEND FORM FOR PAST AND FUTURE CHANGES [What is the name of the program or package you're contributing to?] The PolyORB middleware components [Did you copy any files or text written by someone else in these changes? Even if that material is free software, we need to know about it.] [Do you have an employer who might have a basis to claim to own your changes? Do you attend a school which might make such a claim?] [For the copyright registration, what country are you a citizen of?] [What year were you born?] [Please write your email address here.] [Please write your postal address here.] [Which files have you changed so far, and which new files have you written so far?] polyorb-2.8~20110207.orig/docs/polyorb.70000644000175000017500000000160311750740337017116 0ustar xavierxavier.TH POLYORB 7 "December 1, 2003" "PolyORB team" "PolyORB documentation" .SH NAME PolyORB \- A schizophrenic middleware .SH ENVIRONMENT .B PolyORB recognizes the following environment variable: .HP .B POLYORB_CONF is the name of a configuration file (by default the current directory ). This file contains on each line an assignment of the form .IR VARIABLE=VALUE . This assignment is only taken in account if no environment variable with the name .I VARIABLE exists. .PP Any environment variable may contain a value looking like .RI file: path . In this case, the content of the file designated by .I path (if it exists) will be used as the value for the corresponding variable. .SH BUGS Report any bugs to polyorb-bugs@lists.adacore.com. .SH AUTHORS The \fIPolyORB\fP team, polyorb-devel@lists.adacore.com/ .SH SEE ALSO .br The \fIPolyORB\fP WWW page, .B http://libre.adacore.com/polyorb/ .b polyorb-2.8~20110207.orig/docs/corba-arch.fig0000644000175000017500000000623511750740337020036 0ustar xavierxavier#FIG 3.2 Portrait Center Metric A4 100.00 Single -2 1200 2 6 450 972 4743 2597 6 605 972 2307 1398 2 4 0 1 0 0 0 0 -1 0.000 0 0 3 0 0 5 2307 1398 2307 972 605 972 605 1398 2307 1398 4 0 0 0 0 0 7 0.0000 4 97 832 1040 1207 Client (language A)\001 -6 6 2848 972 4589 1398 2 4 0 1 0 0 0 0 -1 0.000 0 0 3 0 0 5 4569 1398 4569 972 2867 972 2867 1398 4569 1398 4 0 0 0 0 0 7 0.0000 4 97 1534 2951 1207 Object implementation (language B)\001 -6 6 450 2326 4743 2597 2 2 0 2 0 30 0 0 20 0.000 0 0 -1 0 0 5 489 2365 4705 2365 4705 2558 489 2558 489 2365 4 0 0 0 0 0 7 0.0000 4 90 1773 1710 2487 CORBA Bus (inter ORB communication)\001 -6 2 1 0 1 0 0 0 0 -1 0.000 0 0 -1 1 0 2 2 1 1.00 60.00 120.00 759 1398 759 1591 2 1 0 1 0 0 0 0 -1 0.000 0 0 -1 1 0 2 2 1 1.00 60.00 120.00 2113 1398 2113 1591 2 1 0 1 0 0 0 0 -1 0.000 0 0 -1 0 1 2 2 1 1.00 60.00 120.00 4395 1398 4395 1591 2 1 0 1 0 0 0 0 -1 0.000 0 0 -1 0 1 2 2 1 1.00 60.00 120.00 3041 1398 3041 1591 2 1 0 1 0 0 0 0 -1 0.000 0 0 -1 1 0 2 2 1 1.00 60.00 120.00 1456 2249 1456 2365 2 1 0 1 0 0 0 0 -1 0.000 0 0 -1 1 0 2 2 1 1.00 60.00 120.00 3738 2365 3738 2249 2 2 0 1 0 0 0 0 -1 0.000 0 0 -1 0 0 5 450 1591 1069 1591 1069 2249 450 2249 450 1591 2 2 0 1 0 0 0 0 -1 0.000 0 0 -1 0 0 5 1146 1591 1765 1591 1765 2249 1146 2249 1146 1591 2 2 0 1 0 0 0 0 -1 0.000 0 0 -1 0 0 5 1842 1591 2461 1591 2461 2249 1842 2249 1842 1591 2 2 0 1 0 0 0 0 -1 0.000 0 0 -1 0 0 5 2732 1591 3351 1591 3351 2249 2732 2249 2732 1591 2 2 0 1 0 0 0 0 -1 0.000 0 0 -1 0 0 5 3428 1591 4047 1591 4047 2249 3428 2249 3428 1591 2 2 0 1 0 0 0 0 -1 0.000 0 0 -1 0 0 5 4124 1591 4743 1591 4743 2249 4124 2249 4124 1591 2 1 0 1 0 0 0 0 -1 0.000 0 0 -1 1 0 2 2 1 1.00 60.00 120.00 1069 1939 1146 1939 2 1 0 1 0 0 0 0 -1 0.000 0 0 -1 1 0 2 2 1 1.00 60.00 120.00 1842 1939 1765 1939 2 1 0 1 0 0 0 0 -1 0.000 0 0 -1 1 0 2 2 1 1.00 60.00 120.00 3428 1939 3351 1939 2 1 0 1 0 0 0 0 -1 0.000 0 0 -1 1 0 2 2 1 1.00 60.00 120.00 4047 1939 4124 1939 4 1 0 0 0 0 7 0.0000 4 97 387 759 1881 Dynamic\001 4 1 0 0 0 0 7 0.0000 4 71 445 759 2004 Invocation\001 4 1 0 0 0 0 7 0.0000 4 71 232 2152 2004 Stubs\001 4 1 0 0 0 0 7 0.0000 4 71 174 3041 1881 IDL\001 4 1 0 0 0 0 7 0.0000 4 71 367 3041 2004 Skeleton\001 4 1 0 0 0 0 7 0.0000 4 71 219 3738 1881 ORB\001 4 1 0 0 0 0 7 0.0000 4 71 374 3738 2004 Interface\001 4 1 0 0 0 0 7 0.0000 4 97 277 4434 1881 Object\001 4 1 0 0 0 0 7 0.0000 4 97 342 4434 2004 Adapter\001 4 1 0 0 0 0 7 0.0000 4 71 219 1456 1881 ORB\001 4 1 0 0 0 0 7 0.0000 4 71 374 1456 2004 Interface\001 4 1 0 0 0 0 7 0.0000 4 71 174 2152 1881 IDL\001 -6 6 1881 508 3274 895 2 4 0 1 0 0 0 0 -1 0.000 0 0 3 0 0 5 3274 895 3274 508 1881 508 1881 895 3274 895 4 1 0 0 0 0 7 0.0000 4 97 741 2577 724 IDL specification\001 -6 2 1 1 1 0 0 0 0 -1 4.000 0 0 -1 1 0 2 2 1 1.00 60.00 120.00 2577 895 2384 1591 2 1 1 1 0 0 0 0 -1 4.000 0 0 -1 1 0 2 2 1 1.00 60.00 120.00 2577 895 2809 1591 2 1 0 4 0 0 0 0 -1 0.000 0 0 -1 0 0 4 4627 469 4937 469 4937 1475 4627 1475 2 1 0 4 0 0 0 0 -1 0.000 0 0 -1 0 0 4 4627 1514 4937 1514 4937 2636 4627 2636 4 1 0 0 0 26 7 1.5708 4 96 1064 4898 2075 Libs and generated\001 4 1 0 0 0 26 7 1.5708 4 77 554 4898 966 User code\001 polyorb-2.8~20110207.orig/docs/myconfig.cfg0000644000175000017500000000264011750740337017636 0ustar xavierxavierconfiguration MyConfig is Partition_1 : Partition := (); procedure Master_Procedure is in Partition_1; Partition_2, Partition_3 : Partition; for Partition_2'Host use "foo.bar.com"; function Best_Node (Partition_Name : String) return String; pragma Import (Shell, Best_Node, "best-node"); for Partition_3'Host use Best_Node; Partition_4 : Partition := (RCI_B5); for Partition_1'Directory use "/usr/you/test/bin"; for Partition'Directory use "bin"; procedure Another_Main; for Partition_3'Main use Another_Main; for Partition_3'Reconnection use Block_Until_Restart; for Partition_4'Command_Line use "-v"; for Partition_4'Termination use Local_Termination; pragma Starter (Convention => Ada); pragma Boot_Server (Protocol_Name => "tcp", Protocol_Data => "`hostname`:`unused-port`"); pragma Version (False); begin Partition_2 := (RCI_B2, RCI_B4, Normal); Partition_3 := (RCI_B3); end MyConfig; polyorb-2.8~20110207.orig/docs/polyorb_ug_ref.tex0000644000175000017500000000012611750740337021076 0ustar xavierxavier\input btxmac \nocite{*} \bibliographystyle{texinfo} \bibliography{polyorb_ug} \bye polyorb-2.8~20110207.orig/docs/idlac.10000644000175000017500000000257311750740337016505 0ustar xavierxavier.TH IDLAC 1 "March 23, 2005" "PolyORB team" "PolyORB documentation" .SH NAME idlac \- PolyORB's IDL-to-Ada compiler .SH SYNOPSIS .B idlac [-Edikpqv] [-[no]ir] [-gnatW8] [-o DIR] idl_file [-cppargs ...] .SH DESCRIPTION \fIidlac\fP is an IDL-to-Ada compiler, compliant with version 1.2 of the "Ada Language Mapping Specification" produced by the OMG. .SH OPTIONS .l \fIidlac\fP accepts the following options: .TP 8 .B \-E Preprocess only. .TP 8 .B \-d Generate delegation package. .TP 8 .B \-i Generate implementation template. .TP 8 .B \-s Generate server side code. .TP 8 .B \-c Generate client side code. .TP 8 .B \-k Keep temporary files. .TP 8 .B \-p Produce source on standard output. .TP 8 .B \-q Be quiet (default). .TP 8 .B \-v Be verbose. .TP 8 .B \-ir Generate code for interface repository. .TP 8 .B \-noir Don't generate code for interface repository (default). .TP 8 .B \-gnatW8 Use UTF8 character encoding. .TP 8 .B \-o DIR Specify output directory. .TP 8 .B \-cppargs ARGS Pass ARGS to the C++ preprocessor. .TP 8 .B \-I dir Shortcut for -cppargs -I dir. .SH EXIT STATUS \fIidlac\fP returns one of the following values upon exit: .TP .B 0 Successful completion .TP .B 1 Usage error .TP .B 2 Illegal IDL specification .SH AUTHORS The \fIPolyORB\fP team, polyorb-devel@lists.adacore.com. .SH SEE ALSO .br The \fIPolyORB\fP WWW page, .B http://libre.adacore.com/polyorb/ .b polyorb-2.8~20110207.orig/docs/po_names.10000644000175000017500000000103011750740337017215 0ustar xavierxavier.TH PO_NAMES 1 "December 1, 2003" "PolyORB team" "PolyORB documentation" .SH NAME po_names \- PolyORB name server .SH SYNOPSIS .B po_names .SH DESCRIPTION .B po_names is an implementation of CORBA CosNaming service built on top of .B PolyORB. .SH ENVIRONMENT .B po_names uses the .I POLYORB_CONF environment variable. See .BR polyorb (7) for more information. .SH AUTHORS The \fIPolyORB\fP team, polyorb-devel@lists.adacore.com. .SH SEE ALSO .BR polyorb (7) .br The \fIPolyORB\fP WWW page, .B http://libre.adacore.com/polyorb/ .b polyorb-2.8~20110207.orig/docs/xe-arch.fig0000644000175000017500000000373211750740337017363 0ustar xavierxavier#FIG 3.2 Portrait Center Metric A4 100.00 Single -2 1200 2 2 2 0 2 -1 7 0 0 -1 0.000 0 0 -1 0 0 5 1800 2250 2925 2250 2925 2925 1800 2925 1800 2250 2 2 0 2 -1 7 0 0 -1 0.000 0 0 -1 0 0 5 3600 2250 4725 2250 4725 2925 3600 2925 3600 2250 2 1 0 2 -1 7 0 0 -1 0.000 0 0 -1 0 0 2 463 3600 4961 3600 2 1 0 2 0 7 0 0 -1 0.000 0 0 -1 0 0 2 900 1350 900 1575 2 1 0 2 0 7 0 0 -1 0.000 0 0 -1 0 0 2 4500 1350 4500 1575 2 1 0 2 0 7 0 0 -1 0.000 0 0 -1 0 0 2 900 3150 900 3600 2 1 0 2 0 7 0 0 -1 0.000 0 0 -1 0 0 2 4500 3150 4500 3600 2 2 0 2 -1 7 0 0 -1 0.000 0 0 -1 0 0 5 675 2250 1582 2250 1582 2925 675 2925 675 2250 2 2 0 2 -1 7 0 0 -1 0.000 0 0 -1 0 0 5 450 1575 3150 1575 3150 3150 450 3150 450 1575 2 2 0 2 -1 7 0 0 -1 0.000 0 0 -1 0 0 5 3375 1575 4961 1575 4961 3150 3375 3150 3375 1575 2 2 0 2 -1 7 0 0 -1 0.000 0 0 -1 0 0 5 675 675 1575 675 1575 1125 675 1125 675 675 2 2 0 2 -1 7 0 0 -1 0.000 0 0 -1 0 0 5 450 450 4961 450 4961 1350 450 1350 450 450 4 0 0 0 0 2 11 0.0000 4 150 480 900 900 Data_1\001 4 0 0 0 0 2 11 0.0000 4 150 450 900 2475 Unit_1\001 4 0 0 0 0 2 11 0.0000 4 150 480 900 2700 Data_2\001 4 0 0 0 0 2 11 0.0000 4 150 675 2025 2475 Unit_2 (*)\001 4 0 -1 0 0 2 11 0.0000 4 150 675 2025 2700 Unit_3 (*)\001 4 0 0 0 0 2 11 0.0000 4 150 675 3825 2475 Unit_2 (*)\001 4 0 0 0 0 2 11 0.0000 4 150 675 3825 2700 Unit_3 (*)\001 4 0 0 0 0 2 11 0.0000 4 150 1125 675 1800 Processing Node\001 4 0 0 0 0 2 11 0.0000 4 150 1125 3600 1800 Processing Node\001 4 0 0 0 0 2 11 0.0000 4 150 765 3600 2160 Partition_2\001 4 2 0 0 0 2 11 0.0000 4 150 765 2925 2160 Partition_2\001 4 0 0 0 0 2 11 0.0000 4 150 765 675 2160 Partition_1\001 4 1 0 0 0 2 11 0.0000 4 105 570 2700 3375 Network\001 4 0 0 0 0 2 11 0.0000 4 150 1170 1800 1125 Passive_Partition\001 4 0 0 0 0 2 11 0.0000 4 150 930 1800 675 Storage Node\001 4 0 0 0 0 2 11 0.0000 4 150 1185 3600 1125 * Shared Memory\001 4 0 0 0 0 2 11 0.0000 4 105 735 3600 900 * Database\001 4 0 0 0 0 2 11 0.0000 4 105 390 3600 675 * File\001 polyorb-2.8~20110207.orig/docs/polyorb_version.texi.in0000644000175000017500000000004711750740337022074 0ustar xavierxavier@set POLYORB_VERSION @POLYORB_VERSION@ polyorb-2.8~20110207.orig/docs/Makefile.am0000644000175000017500000002016611750740337017401 0ustar xavierxavierinfo_TEXINFOS = polyorb_ug.texi polyorb_dg.texi man_MANS = po_names.1 idlac.1 iac.1 polyorb-config.1 polyorb.7 SUFFIXES = .idl .ads .adb .sed .pdf .texi .txt .info .html FIG2DEV=fig2dev FIGFILES=\ xe-arch.fig\ full-ex.fig\ corba-arch.fig FIG_PDFFILES = $(FIGFILES:=.pdf) FIG_EPSFILES = $(FIGFILES:=.eps) FIG_PNGFILES = $(FIGFILES:=.png) FIG_TXTFILES = $(FIGFILES:=.txt) # Ada sources from GLADE UG GLADE_ADAFILES=\ check_pid.adb\ acrrt.adb\ acrrt.ads\ acrrci.adb\ acrrci.ads\ acrmain.adb\ rcibank.ads\ terminal.ads\ types.ads\ rasbank.ads\ racwbank.ads\ mirrorbank.ads\ mirrorbank.adb\ bankclient.adb\ term1client.adb\ term2client.adb\ racwbank.adb\ newterminal.ads\ stringarraystream.ads\ stringarraystream.adb\ sharedobjects.ads\ storage.ads\ common.ads\ newworkers.ads\ newnewworkers.ads\ workercity.ads\ factory.ads\ newfactory.ads\ internal.ads\ rempkg1.ads\ rempkg1.adb\ rempkg2.ads\ rempkg2.adb\ remexcmain.adb\ node1.ads\ node1.adb\ node2.ads\ node2.adb\ nondeterministic.adb\ asynchronousrt.ads\ asynchronousrci.ads\ asynchronousmain.adb\ genericrci.ads\ rciinstantiation.ads\ rciclient.adb\ normalinstantiation.ads\ new_integers.ads\ new_integers.adb $(GLADE_ADAFILES): glade-sources gnatchop -w $< GLADE_TEXIFILES1= $(GLADE_ADAFILES:=.texi) GLADE_TEXIFILES2 = $(GLADE_TEXIFILES1) GLADE_TEXIFILES = $(GLADE_TEXIFILES1) myconfig.cfg.texi polyorb_ug_TEXINFOS = polyorb_ug_ref.texi \ polyorb-corba_p-corbaloc.ads.texi \ polyorb-corba_p-server_tools.ads.texi \ polyorb-corba_p-naming_tools.ads.texi \ polyorb-rtcorba_p-setup.ads.texi \ polyorb-setup-tasking-ravenscar.ads.texi \ echo.idl.texi \ echo-impl.ads.texi \ echo-impl.adb.texi \ server.adb.texi \ client.adb.texi \ dsa_client.adb.texi \ dsa_server.ads.texi \ dsa_server.adb.texi \ dsa_echo-cfg.ads.texi \ $(GLADE_TEXIFILES) # # Rules to build specific files for PolyORB User's Guide # polyorb-corba_p-corbaloc.ads: $(top_srcdir)/src/corba/polyorb-corba_p-corbaloc.ads cp -f $< . polyorb-corba_p-naming_tools.ads: $(top_srcdir)/idls/cos/naming/polyorb-corba_p-naming_tools.ads cp -f $< . polyorb-corba_p-server_tools.ads: $(top_srcdir)/src/corba/polyorb-corba_p-server_tools.ads cp -f $< . polyorb-rtcorba_p-setup.ads: $(top_srcdir)/src/corba/rtcorba/polyorb-rtcorba_p-setup.ads cp -f $< . polyorb-setup-tasking-ravenscar.ads: $(top_srcdir)/src/setup/polyorb-setup-tasking-ravenscar.ads cp -f $< . echo.idl: $(top_srcdir)/examples/corba/echo/echo.idl cp -f $< . echo-impl.ads: $(top_srcdir)/examples/corba/echo/echo-impl.ads cp -f $< . echo-impl.adb: $(top_srcdir)/examples/corba/echo/echo-impl.adb cp -f $< . client.adb: $(top_srcdir)/examples/corba/echo/client.adb cp -f $< . server.adb: $(top_srcdir)/examples/corba/echo/server.adb cp -f $< . dsa_client.adb: $(top_srcdir)/examples/dsa/echo/client.adb cp -f $< ./dsa_client.adb dsa_server.ads: $(top_srcdir)/examples/dsa/echo/server.ads cp -f $< ./dsa_server.ads dsa_server.adb: $(top_srcdir)/examples/dsa/echo/server.adb cp -f $< ./dsa_server.adb dsa_echo-cfg.ads: $(top_srcdir)/examples/dsa/echo/echo.cfg cp -f $< ./dsa_echo-cfg.ads polyorb_ug_ref.texi: polyorb_ug_ref.bbl @${SED} -e 's/~/ /g' \ -e 's/\\[-`'\''"c^]//g' \ -e 's/\\emdash */---/g' \ -e 's/metapost/MetaPost/g' \ -e 's/\\MF/Metafont/g' \ -e 's/\\METAFONT/METAFONT/g' \ -e 's/\\TUB/TUGboat/g' \ -e 's/\\LaTeX/La@TeX/g' \ -e 's/\\AMSTEX/AMS@TeX/g' \ -e 's/\\AmSTeX/AMS@TeX/g' \ -e 's/\\TeX/@TeX/g' \ -e 's/\\noopsort{[^}]*}//g' \ -e 's/[{}\]//g' \ -e 's/@\[/{/g' \ -e 's/@\]/}/g' \ -e 's/@TeX/@TeX{}/g' \ $< >$@ polyorb_ug_ref.bbl: polyorb_ug_ref.aux -bibtex polyorb_ug_ref polyorb_ug_ref.aux: polyorb_ug_ref.tex polyorb_ug.bib rm -f polyorb_ug_ref.bbl -tex '\nonstopmode \input $<' # # Generic rules to build the documentation in specific formats # # Cancel built-in implicit rules, we replace them later on %.html: %.texi %.info: %.texi %.txt: %.texi %.pdf: %.texi %.dvi: %.texi # The PolyORB User's Guide texi file does not provide Up links in @node # commands, but we want to force generation of all documentation anyway. %.html: ${srcdir}/%.texi ${polyorb_ug_TEXINFOS} $(FIG_PNGFILES) -${MAKEINFO} -o $@ --force --html --number-sections $< cp *.png $@ %.info: ${srcdir}/%.texi ${polyorb_ug_TEXINFOS} -${MAKEINFO} -o $@ --force --no-split --number-sections $< %.txt : ${srcdir}/%.texi ${polyorb_ug_TEXINFOS} -${MAKEINFO} -o $@ --force --no-split --plaintext --ifinfo --number-sections $< # Don't use -o $@ for PDF because it causes the doc build to be done in # a temporary directory, and Kpathsea doesn't know about PDF images. %.pdf: ${srcdir}/%.texi ${polyorb_ug_TEXINFOS} $(FIG_PDFFILES) -${TEXI2DVI} --pdf $< # Setting the environment variable TEX to "tex" is needed on Windows, # to work around a problem with Cygwin. # Otherwise, we get an error like this: # ---! /var/lib/texmf/web2c/etex.fmt was written by pdfetex # (Fatal format file error; I'm stymied) # /usr/bin/texi2dvi: texinfo.tex appears to be broken, quitting. #See: http://www.mail-archive.com/bug-automake@gnu.org/msg00546.html %.dvi: ${srcdir}/%.texi ${polyorb_ug_TEXINFOS} $(FIG_EPSFILES) TEX=tex \ TEXINPUTS="$(am__TEXINFO_TEX_DIR)$(PATH_SEPARATOR)$$TEXINPUTS" \ MAKEINFO='$(MAKEINFO) $(AM_MAKEINFOFLAGS) $(MAKEINFOFLAGS) -I $(srcdir)' \ $(TEXI2DVI) $< # # Texi generation from .ads files # %.sed: %.kw $(top_srcdir)/support/gensedfile $< $@ %.ads.texi: %.ads ada.sed $(top_srcdir)/support/gentexifile AWK="${AWK}" SED="${SED}" $(top_srcdir)/support/gentexifile $< NOGROUP %.adb.texi: %.adb ada.sed $(top_srcdir)/support/gentexifile AWK="${AWK}" SED="${SED}" $(top_srcdir)/support/gentexifile $< NOGROUP %.cfg.texi: %.cfg cfg.sed $(top_srcdir)/support/gentexifile AWK="${AWK}" SED="${SED}" $(top_srcdir)/support/gentexifile $< NOGROUP %.idl.texi: %.idl idl.sed $(top_srcdir)/support/gentexifile AWK="${AWK}" SED="${SED}" $(top_srcdir)/support/gentexifile $< # # Figures # %.fig.eps: %.fig $(FIG2DEV) -L eps $< $@ %.fig.pdf: %.fig $(FIG2DEV) -L pdf $< $@ %.fig.png: %.fig $(FIG2DEV) -L png $< $@ # # Local rules # all-local: MANIFEST clean-local: maintainer-clean -@${RM} -f polyorb_ug.pdf polyorb_ug.txt polyorb_ug.info \ polyorb_ug_ref.aux polyorb_ug_ref.bbl polyorb_ug_ref.blg \ polyorb_ug_ref.dvi polyorb_ug_ref.log \ ${polyorb_ug_TEXINFOS} \ polyorb_dg.pdf polyorb_dg.txt polyorb_dg.info \ idl.sed ada.sed cfg.sed *.ads *.adb *.idl -@${RM} -fr polyorb_ug.html polyorb_dg.html polyorb_ug_toc.html # Note: the target below can be invoked locally from the doc build dir, # in which case it will install the locally built documentation, or from # the top-level Makefile with doc_build_dir pointing to the doc source # directory, to install pre-built documentation. install-data-local: $(INSTALL) -d $(datadir)/doc/polyorb $(INSTALL) -d $(datadir)/doc/polyorb/info $(INSTALL) -d $(datadir)/doc/polyorb/ps $(INSTALL) -d $(datadir)/doc/polyorb/pdf $(INSTALL) -d $(datadir)/doc/polyorb/txt $(INSTALL) -d $(datadir)/doc/polyorb/html $(INSTALL) -d $(datadir)/doc/polyorb/html/polyorb_ug for fmt in info ps pdf txt; \ do \ $(INSTALL_DATA) $(doc_build_dir)polyorb_ug.$$fmt $(datadir)/doc/polyorb/$$fmt/; \ done for f in polyorb_ug.html/*.html; \ do \ $(INSTALL_DATA) $(doc_build_dir)$$f $(datadir)/doc/polyorb/html/polyorb_ug; \ done $(INSTALL) -d $(datadir)/gps/plug-ins/ $(INSTALL_DATA) $(srcdir)/polyorb_gps.xml $(datadir)/gps/plug-ins/ MANIFEST: polyorb_ug.info polyorb_ug.html polyorb_ug.pdf polyorb_ug.ps polyorb_ug.txt \ polyorb_dg.info polyorb_dg.html polyorb_dg.pdf polyorb_dg.txt polyorb_dg.ps -${RM} -f MANIFEST echo polyorb_ug.info >> MANIFEST echo polyorb_ug.ps >> MANIFEST echo polyorb_ug.pdf >> MANIFEST echo polyorb_ug.txt >> MANIFEST echo polyorb_ug.html/* | tr ' ' '\012' >> MANIFEST release: all -${RM} -rf polyorb-doc mkdir -p polyorb-doc/polyorb_ug.html for f in `cat MANIFEST`; do \ ln $$f polyorb-doc/$$f; \ done ln MANIFEST polyorb-doc/MANIFEST tar cvzf polyorb-doc.tar.gz polyorb-doc -${RM} -rf polyorb-doc debug: @echo "polyorb_ug_TEXINFOS=${polyorb_ug_TEXINFOS}" @echo "FIG_PDFFILES=${FIG_PDFFILES}" polyorb-2.8~20110207.orig/docs/PROBLEM-REPORT-FORM0000644000175000017500000000327111750740337020140 0ustar xavierxavierPlease use the form below to submit any bug or problem report on the public or GPL versions of PolyORB to the developers and the user community. Complete the form and send it to polyorb-users@lists.adacore.com or polyorb-bugs@lists.adacore.com. Supported customers of AdaCore should use the standard reporting procedure and contact AdaCore directly to report issues. Replace/remove all the explanatory text in brackets before mailing. Please send this form as ASCII text only. Do _not_ send it as an attachment, or as tar'ed, compressed and/or uuencoded text. And limit line lengths to less than 80 characters. PLEASE make your Subject: line as descriptive as possible. Subjects like "PolyORB bug" or "bug report" are not helpful! 8<----------8<----------8<----------8<----------8<----------8<----------8<---- POLYORB VERSION: [Please provide the complete output of "polyorb-config --version".] HOST MACHINE and OPERATING SYSTEM: COMPILER VERSION [Please provide the complete version string from "gnatls -v".] [Note: if you build from the repository, please also include autoconf and automake versions: "autoconf --version", "automake --version"] DESCRIPTION: [Detailed description of problem. Don't just say " doesn't work, here's a fix," explain what your program does to get to the state. ] REPEAT BY: [What you did to get the error; include test program or session transcript if at all possible; detail your application topology if it uses several nodes, and describe the expected results; include the configuration file you use, after stripping all comments; include all information regarding any other middleware you use. ] SAMPLE FIX/WORKAROUND: [If available] polyorb-2.8~20110207.orig/docs/gfdl.texi0000644000175000017500000004421511750740337017155 0ustar xavierxavier@node GNU Free Documentation License @appendix GNU Free Documentation License @cindex GNU Free Documentation License @cindex License, GNU Free Documentation @cindex Free Documentation License, GNU @c GNU Free Documentation License @noindent Version 1.1, March 2000 @sp 1 @noindent Copyright @copyright{} 2000 Free Software Foundation, Inc. @* 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA @sp 1 @noindent Everyone is permitted to copy and distribute verbatim copies of this license document, but changing it is not allowed. @heading 0. PREAMBLE The purpose of this License is to make a manual, textbook, or other written document ``free'' in the sense of freedom: to assure everyone the effective freedom to copy and redistribute it, with or without modifying it, either commercially or noncommercially. Secondarily, this License preserves for the author and publisher a way to get credit for their work, while not being considered responsible for modifications made by others. This License is a kind of ``copyleft'', which means that derivative works of the document must themselves be free in the same sense. It complements the GNU General Public License, which is a copyleft license designed for free software. We have designed this License in order to use it for manuals for free software, because free software needs free documentation: a free program should come with manuals providing the same freedoms that the software does. But this License is not limited to software manuals; it can be used for any textual work, regardless of subject matter or whether it is published as a printed book. We recommend this License principally for works whose purpose is instruction or reference. @heading 1. APPLICABILITY AND DEFINITIONS This License applies to any manual or other work that contains a notice placed by the copyright holder saying it can be distributed under the terms of this License. The ``Document'', below, refers to any such manual or work. Any member of the public is a licensee, and is addressed as ``you''. A ``Modified Version'' of the Document means any work containing the Document or a portion of it, either copied verbatim, or with modifications and/or translated into another language. A ``Secondary Section'' is a named appendix or a front-matter section of the Document that deals exclusively with the relationship of the publishers or authors of the Document to the Document's overall subject (or to related matters) and contains nothing that could fall directly within that overall subject. (For example, if the Document is in part a textbook of mathematics, a Secondary Section may not explain any mathematics.) The relationship could be a matter of historical connection with the subject or with related matters, or of legal, commercial, philosophical, ethical or political position regarding them. The ``Invariant Sections'' are certain Secondary Sections whose titles are designated, as being those of Invariant Sections, in the notice that says that the Document is released under this License. The ``Cover Texts'' are certain short passages of text that are listed, as Front-Cover Texts or Back-Cover Texts, in the notice that says that the Document is released under this License. A ``Transparent'' copy of the Document means a machine-readable copy, represented in a format whose specification is available to the general public, whose contents can be viewed and edited directly and straightforwardly with generic text editors or (for images composed of pixels) generic paint programs or (for drawings) some widely available drawing editor, and that is suitable for input to text formatters or for automatic translation to a variety of formats suitable for input to text formatters. A copy made in an otherwise Transparent file format whose markup has been designed to thwart or discourage subsequent modification by readers is not Transparent. A copy that is not ``Transparent'' is called ``Opaque''. Examples of suitable formats for Transparent copies include plain ASCII without markup, Texinfo input format, LaTeX input format, SGML or XML using a publicly available DTD, and standard-conforming simple HTML designed for human modification. Opaque formats include PostScript, PDF, proprietary formats that can be read and edited only by proprietary word processors, SGML or XML for which the DTD and/or processing tools are not generally available, and the machine-generated HTML produced by some word processors for output purposes only. The ``Title Page'' means, for a printed book, the title page itself, plus such following pages as are needed to hold, legibly, the material this License requires to appear in the title page. For works in formats which do not have any title page as such, ``Title Page'' means the text near the most prominent appearance of the work's title, preceding the beginning of the body of the text. @heading 2. VERBATIM COPYING You may copy and distribute the Document in any medium, either commercially or noncommercially, provided that this License, the copyright notices, and the license notice saying this License applies to the Document are reproduced in all copies, and that you add no other conditions whatsoever to those of this License. You may not use technical measures to obstruct or control the reading or further copying of the copies you make or distribute. However, you may accept compensation in exchange for copies. If you distribute a large enough number of copies you must also follow the conditions in section 3. You may also lend copies, under the same conditions stated above, and you may publicly display copies. @heading 3. COPYING IN QUANTITY If you publish printed copies of the Document numbering more than 100, and the Document's license notice requires Cover Texts, you must enclose the copies in covers that carry, clearly and legibly, all these Cover Texts: Front-Cover Texts on the front cover, and Back-Cover Texts on the back cover. Both covers must also clearly and legibly identify you as the publisher of these copies. The front cover must present the full title with all words of the title equally prominent and visible. You may add other material on the covers in addition. Copying with changes limited to the covers, as long as they preserve the title of the Document and satisfy these conditions, can be treated as verbatim copying in other respects. If the required texts for either cover are too voluminous to fit legibly, you should put the first ones listed (as many as fit reasonably) on the actual cover, and continue the rest onto adjacent pages. If you publish or distribute Opaque copies of the Document numbering more than 100, you must either include a machine-readable Transparent copy along with each Opaque copy, or state in or with each Opaque copy a publicly-accessible computer-network location containing a complete Transparent copy of the Document, free of added material, which the general network-using public has access to download anonymously at no charge using public-standard network protocols. If you use the latter option, you must take reasonably prudent steps, when you begin distribution of Opaque copies in quantity, to ensure that this Transparent copy will remain thus accessible at the stated location until at least one year after the last time you distribute an Opaque copy (directly or through your agents or retailers) of that edition to the public. It is requested, but not required, that you contact the authors of the Document well before redistributing any large number of copies, to give them a chance to provide you with an updated version of the Document. @heading 4. MODIFICATIONS You may copy and distribute a Modified Version of the Document under the conditions of sections 2 and 3 above, provided that you release the Modified Version under precisely this License, with the Modified Version filling the role of the Document, thus licensing distribution and modification of the Modified Version to whoever possesses a copy of it. In addition, you must do these things in the Modified Version: @enumerate A @item Use in the Title Page (and on the covers, if any) a title distinct from that of the Document, and from those of previous versions (which should, if there were any, be listed in the History section of the Document). You may use the same title as a previous version if the original publisher of that version gives permission. @item List on the Title Page, as authors, one or more persons or entities responsible for authorship of the modifications in the Modified Version, together with at least five of the principal authors of the Document (all of its principal authors, if it has less than five). @item State on the Title page the name of the publisher of the Modified Version, as the publisher. @item Preserve all the copyright notices of the Document. @item Add an appropriate copyright notice for your modifications adjacent to the other copyright notices. @item Include, immediately after the copyright notices, a license notice giving the public permission to use the Modified Version under the terms of this License, in the form shown in the Addendum below. @item Preserve in that license notice the full lists of Invariant Sections and required Cover Texts given in the Document's license notice. @item Include an unaltered copy of this License. @item Preserve the section entitled ``History'', and its title, and add to it an item stating at least the title, year, new authors, and publisher of the Modified Version as given on the Title Page. If there is no section entitled ``History'' in the Document, create one stating the title, year, authors, and publisher of the Document as given on its Title Page, then add an item describing the Modified Version as stated in the previous sentence. @item Preserve the network location, if any, given in the Document for public access to a Transparent copy of the Document, and likewise the network locations given in the Document for previous versions it was based on. These may be placed in the ``History'' section. You may omit a network location for a work that was published at least four years before the Document itself, or if the original publisher of the version it refers to gives permission. @item In any section entitled ``Acknowledgements'' or ``Dedications'', preserve the section's title, and preserve in the section all the substance and tone of each of the contributor acknowledgements and/or dedications given therein. @item Preserve all the Invariant Sections of the Document, unaltered in their text and in their titles. Section numbers or the equivalent are not considered part of the section titles. @item Delete any section entitled ``Endorsements''. Such a section may not be included in the Modified Version. @item Do not retitle any existing section as ``Endorsements'' or to conflict in title with any Invariant Section. @end enumerate If the Modified Version includes new front-matter sections or appendices that qualify as Secondary Sections and contain no material copied from the Document, you may at your option designate some or all of these sections as invariant. To do this, add their titles to the list of Invariant Sections in the Modified Version's license notice. These titles must be distinct from any other section titles. You may add a section entitled ``Endorsements'', provided it contains nothing but endorsements of your Modified Version by various parties -- for example, statements of peer review or that the text has been approved by an organization as the authoritative definition of a standard. You may add a passage of up to five words as a Front-Cover Text, and a passage of up to 25 words as a Back-Cover Text, to the end of the list of Cover Texts in the Modified Version. Only one passage of Front-Cover Text and one of Back-Cover Text may be added by (or through arrangements made by) any one entity. If the Document already includes a cover text for the same cover, previously added by you or by arrangement made by the same entity you are acting on behalf of, you may not add another; but you may replace the old one, on explicit permission from the previous publisher that added the old one. The author(s) and publisher(s) of the Document do not by this License give permission to use their names for publicity for or to assert or imply endorsement of any Modified Version. @heading 5. COMBINING DOCUMENTS You may combine the Document with other documents released under this License, under the terms defined in section 4 above for modified versions, provided that you include in the combination all of the Invariant Sections of all of the original documents, unmodified, and list them all as Invariant Sections of your combined work in its license notice. The combined work need only contain one copy of this License, and multiple identical Invariant Sections may be replaced with a single copy. If there are multiple Invariant Sections with the same name but different contents, make the title of each such section unique by adding at the end of it, in parentheses, the name of the original author or publisher of that section if known, or else a unique number. Make the same adjustment to the section titles in the list of Invariant Sections in the license notice of the combined work. In the combination, you must combine any sections entitled ``History'' in the various original documents, forming one section entitled ``History''; likewise combine any sections entitled ``Acknowledgements'', and any sections entitled ``Dedications''. You must delete all sections entitled ``Endorsements.'' Heading 6. COLLECTIONS OF DOCUMENTS You may make a collection consisting of the Document and other documents released under this License, and replace the individual copies of this License in the various documents with a single copy that is included in the collection, provided that you follow the rules of this License for verbatim copying of each of the documents in all other respects. You may extract a single document from such a collection, and distribute it individually under this License, provided you insert a copy of this License into the extracted document, and follow this License in all other respects regarding verbatim copying of that document. @heading 7. AGGREGATION WITH INDEPENDENT WORKS A compilation of the Document or its derivatives with other separate and independent documents or works, in or on a volume of a storage or distribution medium, does not as a whole count as a Modified Version of the Document, provided no compilation copyright is claimed for the compilation. Such a compilation is called an ``aggregate'', and this License does not apply to the other self-contained works thus compiled with the Document, on account of their being thus compiled, if they are not themselves derivative works of the Document. If the Cover Text requirement of section 3 is applicable to these copies of the Document, then if the Document is less than one quarter of the entire aggregate, the Document's Cover Texts may be placed on covers that surround only the Document within the aggregate. Otherwise they must appear on covers around the whole aggregate. @heading 8. TRANSLATION Translation is considered a kind of modification, so you may distribute translations of the Document under the terms of section 4. Replacing Invariant Sections with translations requires special permission from their copyright holders, but you may include translations of some or all Invariant Sections in addition to the original versions of these Invariant Sections. You may include a translation of this License provided that you also include the original English version of this License. In case of a disagreement between the translation and the original English version of this License, the original English version will prevail. @heading 9. TERMINATION You may not copy, modify, sublicense, or distribute the Document except as expressly provided for under this License. Any other attempt to copy, modify, sublicense or distribute the Document is void, and will automatically terminate your rights under this License. However, parties who have received copies, or rights, from you under this License will not have their licenses terminated so long as such parties remain in full compliance. @heading 10. FUTURE REVISIONS OF THIS LICENSE The Free Software Foundation may publish new, revised versions of the GNU Free Documentation License from time to time. Such new versions will be similar in spirit to the present version, but may differ in detail to address new problems or concerns. See http://www.gnu.org/copyleft/. Each version of the License is given a distinguishing version number. If the Document specifies that a particular numbered version of this License ``or any later version'' applies to it, you have the option of following the terms and conditions either of that specified version or of any later version that has been published (not as a draft) by the Free Software Foundation. If the Document does not specify a version number of this License, you may choose any version ever published (not as a draft) by the Free Software Foundation. @heading ADDENDUM: How to use this License for your documents To use this License in a document you have written, include a copy of the License in the document and put the following copyright and license notices just after the title page: @quotation Copyright (c) YEAR YOUR NAME. @* Permission is granted to copy, distribute and/or modify this document under the terms of the GNU Free Documentation License, Version 1.1 or any later version published by the Free Software Foundation; with the Invariant Sections being LIST THEIR TITLES, with the Front-Cover Texts being LIST, and with the Back-Cover Texts being LIST. A copy of the license is included in the section entitled ``GNU Free Documentation License''. @end quotation If you have no Invariant Sections, write ``with no Invariant Sections'' instead of saying which ones are invariant. If you have no Front-Cover Texts, write ``no Front-Cover Texts'' instead of ``Front-Cover Texts being LIST''; likewise for Back-Cover Texts. If your document contains nontrivial examples of program code, we recommend releasing these examples in parallel under your choice of free software license, such as the GNU General Public License, to permit their use in free software. polyorb-2.8~20110207.orig/docs/iac.10000644000175000017500000000515311750740337016162 0ustar xavierxavier.TH IAC 1 "April 26, 2007" "PolyORB team" "PolyORB documentation" .SH NAME iac \- PolyORB's IDL-to-Ada compiler .SH SYNOPSIS .B iac opts file [-cppargs args] .SH DESCRIPTION \fIiac\fP is an IDL-to-Ada compiler, compliant with version 1.2 of the "Ada Language Mapping Specification" produced by the OMG. .SH OPTIONS .l \fIiac\fP accepts the following options: .TP 8 .B \-E Preprocess only. .B \-k Keep temporary files. .TP 8 .B \-p Produce source on standard output. .TP 8 .B \-o DIR Specify output directory. .TP 8 .B \-dm Generate debug messages when analyzing scopes .TP 8 .B \-df Dump the frontend tree (the IDL tree) .TP 8 .B \-cppargs ARGS Pass ARGS to the C++ preprocessor. .TP 8 .B \-I dir Shortcut for -cppargs -I dir. .TP 8 .B \-nocpp Do not preprocess input .TP 8 .B \- Generate code for a supported language .TP 8 .B types Generate a list of all types present in the IDL file .TP 8 \&\fB \-p Print the list generate .TP 8 .B ada Generate Ada source code .TP 8 \&\fB \-i Generate implementation template. .TP 8 \&\fB \-c Generate client side code. .TP 8 \&\fB \-s Generate server side code. .TP 8 \&\fB \-d Generate delegation package. (defunct) .TP 8 \&\fB \-ir Generate code for interface repository.(defunct) .TP 8 \&\fB \-noir Don't generate code for interface repository (default). .TP 8 \&\fB \-hc Using perfect minimal hash tables in skeletons and minimize CPU time .TP 8 \&\fB \-hm Using perfect minimal hash tables in skeletons and minimize memory space .TP 8 \&\fB \-rs Use the SII/SSI to handle requests .TP 8 \&\fB \-rd Use the DII/DSI to handle requests (default) .TP 8 \&\fB \-da Dump the Ada tree .TP 8 \&\fB \-db Generate only the package bodies .TP 8 \&\fB \-ds Generate only the package specs .TP 8 \&\fB \-dw Output the withed entities .TP 8 \&\fB \-dt Output tree warnings .TP 8 \&\fB \-di Generate code for imported entities .TP 8 .B idl Dump parsed IDL file .TP 8 \&\fB \-b n Base to output integer literal As a default (zero) use base from input .TP 8 \&\fB \-e Expand IDL Tree .TP 8 \&\fB \-df Dump IDL Tree (may be used in conjunction with -e to dump the expanded IDL tree) .TP 8 \&\fB \-di Output IDL code of imported entities (may be used in conjunction with -e to output the expanded IDL code) .SH EXIT STATUS \fIiac\fP returns one of the following values upon exit: .TP .B 0 Successful completion .TP .B 1 Usage error .TP .B 2 Illegal IDL specification .SH AUTHORS The \fIPolyORB\fP team, polyorb-devel@lists.adacore.com. .SH SEE ALSO .br The \fIPolyORB\fP WWW page, .B http://libre.adacore.com/polyorb/ .b polyorb-2.8~20110207.orig/docs/server.adb0000644000175000017500000000716011750740337017322 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- S E R V E R -- -- -- -- B o d y -- -- -- -- Copyright (C) 2002-2007, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with Ada.Text_IO; with CORBA.Impl; with CORBA.Object; with CORBA.ORB; with PortableServer.POA.Helper; with PortableServer.POAManager; with Echo.Impl; with PolyORB.CORBA_P.CORBALOC; -- Setup server node: use no tasking default configuration with PolyORB.Setup.No_Tasking_Server; pragma Warnings (Off, PolyORB.Setup.No_Tasking_Server); procedure Server is begin declare Argv : CORBA.ORB.Arg_List := CORBA.ORB.Command_Line_Arguments; begin CORBA.ORB.Init (CORBA.ORB.To_CORBA_String ("ORB"), Argv); declare Root_POA : PortableServer.POA.Local_Ref; Ref : CORBA.Object.Ref; Obj : constant CORBA.Impl.Object_Ptr := new Echo.Impl.Object; begin -- Retrieve Root POA Root_POA := PortableServer.POA.Helper.To_Local_Ref (CORBA.ORB.Resolve_Initial_References (CORBA.ORB.To_CORBA_String ("RootPOA"))); PortableServer.POAManager.Activate (PortableServer.POA.Get_The_POAManager (Root_POA)); -- Set up new object Ref := PortableServer.POA.Servant_To_Reference (Root_POA, PortableServer.Servant (Obj)); -- Output IOR Ada.Text_IO.Put_Line ("'" & CORBA.To_Standard_String (CORBA.Object.Object_To_String (Ref)) & "'"); Ada.Text_IO.New_Line; -- Output corbaloc Ada.Text_IO.Put_Line ("'" & CORBA.To_Standard_String (PolyORB.CORBA_P.CORBALOC.Object_To_Corbaloc (Ref)) & "'"); -- Launch the server CORBA.ORB.Run; end; end; end Server; polyorb-2.8~20110207.orig/docs/polyorb_gps.xml0000644000175000017500000000110311750740337020414 0ustar xavierxavier share/doc/polyorb /Help/PolyORB html/polyorb_ug/index.html PolyORB User's Guide GNAT /Help/PolyORB/PolyORB User's Guide polyorb-2.8~20110207.orig/docs/client.adb0000644000175000017500000000704311750740337017272 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- C L I E N T -- -- -- -- B o d y -- -- -- -- Copyright (C) 2002-2004 Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by ACT Europe. -- -- (email: sales@act-europe.fr) -- -- -- ------------------------------------------------------------------------------ -- echo client. with Ada.Command_Line; with Ada.Text_IO; with CORBA.ORB; with Echo; with PolyORB.Setup.Client; pragma Warnings (Off, PolyORB.Setup.Client); with PolyORB.Utils.Report; procedure Client is use Ada.Command_Line; use Ada.Text_IO; use PolyORB.Utils.Report; Sent_Msg, Rcvd_Msg : CORBA.String; myecho : Echo.Ref; begin New_Test ("Echo client"); CORBA.ORB.Initialize ("ORB"); if Argument_Count /= 1 then Put_Line ("usage : client |-i"); return; end if; -- Getting the CORBA.Object CORBA.ORB.String_To_Object (CORBA.To_CORBA_String (Ada.Command_Line.Argument (1)), myecho); -- Checking if it worked if Echo.Is_Nil (myecho) then Put_Line ("main : cannot invoke on a nil reference"); return; end if; -- Sending message Sent_Msg := CORBA.To_CORBA_String (Standard.String'("Hello Ada !")); Rcvd_Msg := Echo.echoString (myecho, Sent_Msg); -- Printing result Put_Line ("I said : " & CORBA.To_Standard_String (Sent_Msg)); Put_Line ("The object answered : " & CORBA.To_Standard_String (Rcvd_Msg)); End_Report; exception when E : CORBA.Transient => declare Memb : CORBA.System_Exception_Members; begin CORBA.Get_Members (E, Memb); Put ("received exception transient, minor"); Put (CORBA.Unsigned_Long'Image (Memb.Minor)); Put (", completion status: "); Put_Line (CORBA.Completion_Status'Image (Memb.Completed)); End_Report; end; end Client; polyorb-2.8~20110207.orig/contrib/0000755000175000017500000000000011750740340016042 5ustar xavierxavierpolyorb-2.8~20110207.orig/contrib/automake/0000755000175000017500000000000011750740340017650 5ustar xavierxavierpolyorb-2.8~20110207.orig/contrib/automake/README0000644000175000017500000000022711750740337020537 0ustar xavierxavierpolyorb.m4 ---------- $Id: //droopi/main/contrib/automake/README#1 $ Automake's macro for PolyORB. Contributed by: Vadim Godunko polyorb-2.8~20110207.orig/contrib/automake/polyorb.m40000644000175000017500000000367011750740337021614 0ustar xavierxavier# Automake macro for PolyORB. # # Contributed to PolyORB by Vadim Godunko # See README for more details dnl ########################################################################## dnl AM_PATH_POLYORB([MINIMUM-VERSION [, ACTION-IF-FOUND dnl [, [ACTION-IF-NOT-FOUND]]]) dnl Look for PolyORB, then define POLYORB_ADAFLAGS, POLYORB_LIBS and dnl POLYORB_IDLFLAGS AC_DEFUN([AM_PATH_POLYORB], [ AC_ARG_WITH(polyorb-prefix, AC_HELP_STRING([--with-polyorb-prefix=PREFIX], [Prefix where PolyORB is installed (optional)]), [polyorb_config_prefix="$withval"], [polyorb_config_prefix=""]) min_polyorb_version=ifelse([$1], , 1.2, $1) min_polyorb_major_version=`echo $min_polyorb_version | \ sed 's/\([[0-9]]*\).\([[0-9]]*\)/\1/'` min_polyorb_minor_version=`echo $min_polyorb_version | \ sed 's/\([[0-9]]*\).\([[0-9]]*\)/\2/'` AS_IF([test x$polyorb_config_prefix != x], [POLYORB_CONFIG=$polyorb_config_prefix/bin/polyorb-config]) AC_PATH_PROG(POLYORB_CONFIG, polyorb-config, no) AS_IF([test "$POLYORB_CONFIG" != "no"], [AC_MSG_CHECKING([for PolyORB - version >= $min_polyorb_version]) POLYORB_ADAFLAGS=`$POLYORB_CONFIG --cflags` POLYORB_LIBS=`$POLYORB_CONFIG --libs` POLYORB_IDLFLAGS=`$POLYORB_CONFIG --idls` polyorb_major_version=`$POLYORB_CONFIG --version | \ sed 's/PolyORB \([[0-9]]*\).\([[0-9]]*\).*/\1/'` polyorb_minor_version=`$POLYORB_CONFIG --version | \ sed 's/PolyORB \([[0-9]]*\).\([[0-9]]*\).*/\2/'` AS_IF([test $polyorb_major_version -gt $min_polyorb_major_version -o \( $polyorb_major_version -eq $min_polyorb_major_version -a $polyorb_minor_version -ge $min_polyorb_minor_version \)], [AC_MSG_RESULT(yes) ifelse([$2], , :, [$2])], [AC_MSG_RESULT(no) ifelse([$3], , :, [$3])])], [$3]) AC_SUBST(POLYORB_ADAFLAGS) AC_SUBST(POLYORB_LIBS) AC_SUBST(POLYORB_IDLFLAGS) ]) polyorb-2.8~20110207.orig/contrib/README0000644000175000017500000000036311750740337016732 0ustar xavierxavierREADME for the PolyORB contrib directory ---------------------------------------- $Id: //droopi/main/contrib/README#1 $ This directory contains various contributions or updates for PolyORB. See README in each sub-directory for more details. polyorb-2.8~20110207.orig/contrib/idlac_wrapper/0000755000175000017500000000000011750740340020656 5ustar xavierxavierpolyorb-2.8~20110207.orig/contrib/idlac_wrapper/README0000644000175000017500000000121411750740337021542 0ustar xavierxavieridlac_wrapper script -------------------- $Id: //droopi/main/contrib/idlac_wrapper/README#1 $ PolyORB's IDL to Ada compiler (called idlac) always overwrites existing files with new generated files. This is acceptable for PolyORB's examples and small programs. But for larger IDL files, this implies hundreds of files will be overwritten and then recompiled. This recompilation may take a long time. This scripts is a wrapper around idlac. It runs idlac in a separate directory, compare the generated files with existing ones and overwrite only modified files. Thus, it reduces the compilation time. Contributed by: Vadim Godunko polyorb-2.8~20110207.orig/contrib/idlac_wrapper/idlac_wrapper.in0000755000175000017500000000313511750740337024035 0ustar xavierxavier#!/bin/sh # # idlac_wrapper # $Id: idlac_wrapper.in 114962 2007-08-29 16:47:09Z duff $ # @configure_input@ # # Contributed to PolyORB by Vadim Godunko # See README for more details. # tmp="idlac_wrapper.$$" trap "rm -rf ${tmp}" 0 1 2 3 15 SED=@SED@ IDLAC=idlac verbose=false while [ $# -ne 0 ]; do case "$1" in --idlac=*) IDLAC=`echo "$1" | ${SED} 's/^--idlac=//'` shift ;; --verbose) verbose=true shift ;; -v) verbose=true shift ;; *) args="${args} `echo "$1" | ${SED} 's/./\\\\&/g'`" shift ;; esac done ( ## Create temporary directory mkdir ${tmp} || exit $? ## Execute idlac if "$verbose"; then echo "${IDLAC} -o ${tmp} ${args}" fi eval "${IDLAC} -o ${tmp} ${args}" || exit $? ## Replace existing files only if actually changed; move newly-created ## files, and remove files in other case for file in ${tmp}/*.ad[sb]; do ofile=`basename ${file}` if [ -r ${ofile} ]; then if cmp ${file} ${ofile} > /dev/null; then echo "${IDLAC}: not modified: ${PWD}/${ofile}" rm -f ${file} else echo "${IDLAC}: updated: ${PWD}/${ofile}" mv -f ${file} ${ofile} fi else if "$verbose"; then # This is the usual case; don't print message unless --verbose # flag was given echo "${IDLAC}: created: ${PWD}/${ofile}" fi mv -f ${file} ${ofile} fi done ) polyorb-2.8~20110207.orig/contrib/local_sockets/0000755000175000017500000000000011750740340020667 5ustar xavierxavierpolyorb-2.8~20110207.orig/contrib/local_sockets/README0000644000175000017500000000147711750740337021566 0ustar xavierxavierLocal Sockets API ----------------- $Id: //droopi/main/contrib/local_sockets/README#2 $ This directory contains the following files and directories : - protocol : contains the sources of the local transport API "local_sockets", a instance of the GIOP protocol using this transport and the PolyORB initialization files with this protocol - test : contains a test of a CORBA client and server interacting with this protocol (intended to be run on Linux) - test_sockets : contains a simple test that allows simple exchange of information between a client and server using some primitives inspired from GNAT.Sockets. Contributed by the IST-ASSERT Project, by * Laurent Pautet, Telecom Paris * Khaled Barbaria, Telecom Paris For more information on the IST-ASSERT project please visit http://www.assert-online.org/ polyorb-2.8~20110207.orig/contrib/local_sockets/test_sockets/0000755000175000017500000000000011750740340023401 5ustar xavierxavierpolyorb-2.8~20110207.orig/contrib/local_sockets/test_sockets/test_ls_pkg.adb0000644000175000017500000001145411750740337026402 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- T E S T _ L S _ P K G -- -- -- -- B o d y -- -- -- -- Copyright (C) 2005 Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with Ravenscar_Setup; pragma Warnings (Off, Ravenscar_Setup); pragma Elaborate_All (Ravenscar_Setup); with PolyORB.ORB.Thread_Pool; pragma Warnings (Off, PolyORB.ORB.Thread_Pool); pragma Elaborate_All (PolyORB.ORB.Thread_Pool); with PolyORB.ORB_Controller.Workers; pragma Warnings (Off, PolyORB.ORB_Controller.Workers); pragma Elaborate_All (PolyORB.ORB_Controller.Workers); with PolyORB.Representations.CDR.Common; use PolyORB.Representations.CDR.Common; with PolyORB.Initialization; use PolyORB.Initialization; with PolyORB.Local_Sockets; use PolyORB.Local_Sockets; with Ada.Text_IO; use Ada.Text_IO; with PolyORB.Buffers; use PolyORB.Buffers; with Ada.Text_IO; with Ada.Streams; with PolyORB.Types; with Ada.Real_Time; use Ada.Real_Time; package body Test_LS_Pkg is Initialized : Boolean := False; task Server; task Client; ------------ -- Server -- ------------ task body Server is Address : Local_Socket_Addr; Server : constant Local_Socket_Access := new Local_Socket_Type; Socket : constant Local_Socket_Access := new Local_Socket_Type; begin Put_Line ("Server : enter "); if not Initialized then PolyORB.Initialization.Initialize_World; Initialized := True; end if; Create_Socket (Server.all); Listen_Socket (Server.all); Accept_Socket (Server.all, Socket.all, Address); Put_Line ("Server : My connecting port is : " & Integer (Address.LPort)'Img); declare B : constant Buffer_Access := new Buffer_Type; Size : Ada.Streams.Stream_Element_Count := Ada.Streams.Stream_Element_Count (4); S : PolyORB.Types.Long; begin Put_Line ("Server : Expecting the client message"); Read (Socket, B, Size); Rewind (B); S := Unmarshall (B); Put_Line ("Server : Received, " & S'Img); end; end Server; ------------ -- Client -- ------------ task body Client is Address : Local_Socket_Addr; Socket : constant Local_Socket_Access := new Local_Socket_Type; begin Put_Line ("Client : enter "); delay until Clock + Milliseconds (2000); if not Initialized then PolyORB.Initialization.Initialize_World; Initialized := True; end if; Create_Socket (Socket.all); Address.LPort := 1; Put_Line ("Client, about to connect"); Connect_Socket (Socket.all, Address); Put_Line ("Client, Connected!"); -- Send a string to the Server declare B : constant Buffer_Access := new Buffer_Type; begin Marshall (B, PolyORB.Types.Long (20050720)); Put_Line ("about to send a Buffer of length" & Length (B)'Img); Write (Socket, B); end; end Client; end Test_LS_Pkg; polyorb-2.8~20110207.orig/contrib/local_sockets/test_sockets/ravenscar_setup.ads0000644000175000017500000000450711750740337027312 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- R A V E N S C A R _ S E T U P -- -- -- -- S p e c -- -- -- -- Copyright (C) 2003-2005 Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with System; with PolyORB.Setup.Tasking.Ravenscar; package Ravenscar_Setup is new PolyORB.Setup.Tasking.Ravenscar ( Number_Of_Application_Tasks => 10, Number_Of_System_Tasks => 10, Number_Of_Conditions => 50, Number_Of_Mutexes => 50, Task_Priority => System.Default_Priority, Storage_Size => 20_000); polyorb-2.8~20110207.orig/contrib/local_sockets/test_sockets/Makefile.common0000644000175000017500000000216111750740337026336 0ustar xavierxavier#ADB =??? EXE= $(patsubst %.adb,%, $(ADB)) ORK_EXE= $(patsubst %.adb,%.ork, $(ADB)) #srcdir= path/to/polyorb/src #ork_srcdir= path/to/polyorb_compiled_for_ORK/src # Need to precise the PolyORB src directory path (put it in srcdir) # ork_srcdir is used if you want to compile for ORK, compile PolyORB # for ORK platforms and initialize this variable with the src # directory of PolyORB compiled for ORK ADAFLAGS+= -g -O2 -gnatfy -gnatoa -fstack-check -gnatwae GNATMAKE = gnatmake ORK_GNATMAKE = i386-ork-gnatmake INCLUDE = -I../protocol -I$(srcdir) ORK_INCLUDE = -I. -I../ -I../../protocol -I../../../ork/ork_common/ \ -I$(ork_srcdir) LARGS= ORK_LARGS = -largs -k -specs ork_specs all: #compile ork_compile @-echo "make compile : Compile for Linux" @-echo "make ork_compile : Compile for ORK" compile :${ADB} ${GNATMAKE} ${INCLUDE} ${ADB} -cargs ${ADAFLAGS} ${LARGS} ork_compile : ${ORK_EXE} %.ork:%.adb ${ORK_GNATMAKE} -o $@ $< ${ORK_INCLUDE} -cargs ${ADAFLAGS} ${ORK_LARGS} force: clean: @-rm -f *.ali *.o *~ b~* *.gz *helper* *skel* *echo.ad* GNAT* distclean: clean @-rm -f $(EXE) ${ORK_EXE} polyorb-2.8~20110207.orig/contrib/local_sockets/test_sockets/test_ls_pkg.ads0000644000175000017500000000411311750740337026415 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- T E S T _ L S _ P K G -- -- -- -- S p e c -- -- -- -- Copyright (C) 2005 Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ package Test_LS_Pkg is pragma Elaborate_Body; end Test_LS_Pkg; polyorb-2.8~20110207.orig/contrib/local_sockets/test_sockets/test_ls.adb0000644000175000017500000000415611750740337025542 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- T E S T _ L S -- -- -- -- B o d y -- -- -- -- Copyright (C) 2005 Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with Test_LS_Pkg; pragma Warnings (Off, Test_LS_Pkg); procedure Test_LS is begin null; end Test_LS; polyorb-2.8~20110207.orig/contrib/local_sockets/test_sockets/gnat.adc0000644000175000017500000000002211750740337025003 0ustar xavierxavierpragma Ravenscar; polyorb-2.8~20110207.orig/contrib/local_sockets/test_sockets/Makefile0000644000175000017500000000005211750740337025044 0ustar xavierxavierADB = test_ls.adb include Makefile.common polyorb-2.8~20110207.orig/contrib/local_sockets/protocol/0000755000175000017500000000000011750740340022530 5ustar xavierxavier././@LongLink0000000000000000000000000000014700000000000011567 Lustar rootrootpolyorb-2.8~20110207.orig/contrib/local_sockets/protocol/polyorb-transport-connected-local_sockets.adbpolyorb-2.8~20110207.orig/contrib/local_sockets/protocol/polyorb-transport-connected-local_sockets.a0000644000175000017500000002014611750740337033206 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- POLYORB.TRANSPORT.CONNECTED.LOCAL_SOCKETS -- -- -- -- B o d y -- -- -- -- Copyright (C) 2005 Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with PolyORB.Asynch_Ev.Local_Sockets; with PolyORB.Log; with PolyORB.Local_Sockets; package body PolyORB.Transport.Connected.Local_Sockets is use Ada.Streams; use PolyORB.Asynch_Ev; use PolyORB.Asynch_Ev.Local_Sockets; use PolyORB.Log; use PolyORB.Tasking.Mutexes; use PolyORB.Local_Sockets; package L is new PolyORB.Log.Facility_Log ("polyorb.transport.connected.ls"); procedure O (Message : in String; Level : Log_Level := Debug) renames L.Output; function C (Level : Log_Level := Debug) return Boolean renames L.Enabled; pragma Unreferenced (C); -- For conditional pragma Debug ----------------------- -- Accept_Connection -- ----------------------- procedure Accept_Connection (TAP : Local_Socket_Access_Point; TE : out Transport_Endpoint_Access) is New_Socket : Local_Socket_Type; New_Address : Local_Socket_Addr; begin pragma Debug (O ("Accept_Connection: enter")); TE := new Local_Socket_Endpoint; Accept_Socket (Server => TAP.Socket.all, Socket => New_Socket, Address => New_Address); Create (Local_Socket_Endpoint (TE.all), New_Socket); -- Local_Socket_Endpoint(TE.all).Socket := TAP.Socket; -- Create (Local_Socket_Endpoint (TE.all), -- Local_Socket_Endpoint(TE.all).Socket.all ); -- Local_Socket_Endpoint(TE.all).Socket.addr := Address_Of (TAP.Socket); pragma Debug (O ("Accept_Connection: leave")); end Accept_Connection; ---------------- -- Address_Of -- ---------------- function Address_Of (SAP : Local_Socket_Access_Point) return Local_Socket_Addr is begin return Address_Of (SAP.Socket.all); end Address_Of; ------------ -- Create -- ------------ procedure Create (SAP : in out Local_Socket_Access_Point; Socket : Local_Socket_Type; Address : in out Local_Socket_Addr) is begin pragma Debug (O ("Create :enter")); Listen_Socket (Socket); SAP.Socket := new Local_Socket_Type; SAP.Socket.all := Socket; Address := Address_Of (SAP.Socket.all); -- Listen_Socket (Socket); -- SAP.Socket.all := Copy (Socket); -- Address := Address_Of (SAP.Socket); pragma Debug (O ("Create: SAP.Socket.Port" & Address_Of (SAP.Socket.all). LPort'Img)); pragma Debug (O ("Create :leave")); end Create; ----------- -- Image -- ----------- function Image (TAP : Local_Socket_Access_Point) return String is begin return "TAP : Addr = " & TAP.Addr.LPort'Img & "Socket" & PolyORB.Local_Sockets.Address_Of (TAP.Socket.all).LPort'Img; end Image; ------------------------- -- Create_Event_Source -- ------------------------- function Create_Event_Source (TAP : access Local_Socket_Access_Point) return Asynch_Ev_Source_Access is use PolyORB.Annotations; Ev_Src : constant Asynch_Ev_Source_Access := Create_Event_Source (TAP.Socket); begin Set_Note (Notepad_Of (Ev_Src).all, AES_Note'(Annotations.Note with Handler => TAP.Handler'Access)); return Ev_Src; end Create_Event_Source; ------------ -- Create -- ------------ procedure Create (TE : in out Local_Socket_Endpoint; S : Local_Socket_Type) is begin TE.Socket := new Local_Socket_Type'(S); Create (TE.Mutex); end Create; ------------------------- -- Create_Event_Source -- ------------------------- function Create_Event_Source (TE : access Local_Socket_Endpoint) return Asynch_Ev_Source_Access is use PolyORB.Annotations; Ev_Src : constant Asynch_Ev_Source_Access := Create_Event_Source (TE.Socket); begin Set_Note (Notepad_Of (Ev_Src).all, AES_Note'(Annotations.Note with Handler => TE.Handler'Access)); return Ev_Src; end Create_Event_Source; ----------------------- -- Is_Data_Available -- ----------------------- function Is_Data_Available (TE : Local_Socket_Endpoint; N : Natural) return Boolean is begin pragma Debug (O ("Is data available : enter ")); return Is_Data_Available (TE.Socket, N); end Is_Data_Available; ---------- -- Read -- ---------- procedure Read (TE : in out Local_Socket_Endpoint; Buffer : Buffers.Buffer_Access; Size : in out Stream_Element_Count; Error : out Errors.Error_Container) is use PolyORB.Errors; begin -- Must read all data in one call pragma Debug (O ("Wanted:" & Size'Img)); PolyORB.Local_Sockets.Read (TE.Socket, Buffer, Size); pragma Debug (O ("Got:" & PolyORB.Buffers.Length (Buffer)'Img)); exception when others => Throw (Error, Unknown_E, System_Exception_Members' (Minor => 0, Completed => Completed_Maybe)); end Read; ----------- -- Write -- ----------- procedure Write (TE : in out Local_Socket_Endpoint; Buffer : Buffers.Buffer_Access; Error : out Errors.Error_Container) is use PolyORB.Errors; begin PolyORB.Local_Sockets.Write (TE.Socket, Buffer); pragma Debug (O ("Written:" & PolyORB.Buffers.Length (Buffer)'Img)); -- pragma Assert (Size = PolyORB.Buffers.Length (Buffer)); exception when others => Throw (Error, Unknown_E, System_Exception_Members' (Minor => 0, Completed => Completed_Maybe)); end Write; ----------- -- Close -- ----------- procedure Close (TE : access Local_Socket_Endpoint) is begin if TE.Closed then return; end if; TE.Closed := True; Close (TE.Socket); TE.Socket := null; end Close; ------------- -- Destroy -- ------------- procedure Destroy (TE : in out Local_Socket_Endpoint) is begin Connected.Destroy (Connected_Transport_Endpoint (TE)); end Destroy; end PolyORB.Transport.Connected.Local_Sockets; ././@LongLink0000000000000000000000000000014700000000000011567 Lustar rootrootpolyorb-2.8~20110207.orig/contrib/local_sockets/protocol/polyorb-transport-connected-local_sockets.adspolyorb-2.8~20110207.orig/contrib/local_sockets/protocol/polyorb-transport-connected-local_sockets.a0000644000175000017500000001143111750740337033203 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- POLYORB.TRANSPORT.CONNECTED.LOCAL_SOCKETS -- -- -- -- S p e c -- -- -- -- Copyright (C) 2005 Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with PolyORB.Local_Sockets; with PolyORB.Tasking.Mutexes; package PolyORB.Transport.Connected.Local_Sockets is pragma Elaborate_Body; use PolyORB.Local_Sockets; type Local_Socket_Access_Point is new Connected_Transport_Access_Point with private; -- Local_Socket_Access; Addr : Local_Socket_Addr; end record; Type -- Local_Socket_Access_Point is new -- Connected_Transport_Access_Point with private; A listening -- transport service access point as a listening stream-oriented -- socket. procedure Create (SAP : in out Local_Socket_Access_Point; Socket : Local_Socket_Type; Address : in out Local_Socket_Addr); -- Initialise SAP: bind Socket to Address, listen on it, -- and set up the corresponding Socket_Access_Point. -- XXX -- On entry, Address.Port may be Any_Port, in which case the system -- will assign an available port number itself. On return, -- Address is always set to the actual address used. function Create_Event_Source (TAP : access Local_Socket_Access_Point) return Asynch_Ev.Asynch_Ev_Source_Access; procedure Accept_Connection (TAP : Local_Socket_Access_Point; TE : out Transport_Endpoint_Access); function Address_Of (SAP : Local_Socket_Access_Point) return Local_Socket_Addr; type Local_Socket_Endpoint is new Connected_Transport_Endpoint with private; -- An opened transport endpoint as a connected stream-oriented -- socket. procedure Create (TE : in out Local_Socket_Endpoint; S : Local_Socket_Type); function Create_Event_Source (TE : access Local_Socket_Endpoint) return Asynch_Ev.Asynch_Ev_Source_Access; function Is_Data_Available (TE : Local_Socket_Endpoint; N : Natural) return Boolean; function Image (TAP : Local_Socket_Access_Point) return String; procedure Read (TE : in out Local_Socket_Endpoint; Buffer : Buffers.Buffer_Access; Size : in out Ada.Streams.Stream_Element_Count; Error : out Errors.Error_Container); procedure Write (TE : in out Local_Socket_Endpoint; Buffer : Buffers.Buffer_Access; Error : out Errors.Error_Container); procedure Close (TE : access Local_Socket_Endpoint); procedure Destroy (TE : in out Local_Socket_Endpoint); private type Local_Socket_Access_Point is new Connected_Transport_Access_Point with record Socket : Local_Socket_Access; Addr : Local_Socket_Addr; end record; type Local_Socket_Endpoint is new Connected_Transport_Endpoint with record Socket : Local_Socket_Access; Addr : Local_Socket_Addr; Mutex : Tasking.Mutexes.Mutex_Access; end record; end PolyORB.Transport.Connected.Local_Sockets; polyorb-2.8~20110207.orig/contrib/local_sockets/protocol/polyorb-setup-access_points-ls.ads0000644000175000017500000000416111750740337031324 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . S E T U P . A C C E S S _ P O I N T S . L S -- -- -- -- S p e c -- -- -- -- Copyright (C) 2005 Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ package PolyORB.Setup.Access_Points.LS is pragma Elaborate_Body; end PolyORB.Setup.Access_Points.LS; polyorb-2.8~20110207.orig/contrib/local_sockets/protocol/polyorb-binding_data-giop-local_sockets.adb0000644000175000017500000003062511750740337033062 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- POLYORB.BINDING_DATA.GIOP.LOCAL_SOCKETS -- -- -- -- B o d y -- -- -- -- Copyright (C) 2005-2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with Ada.Streams; with PolyORB.Binding_Objects; with PolyORB.Filters; with PolyORB.Initialization; with PolyORB.Log; with PolyORB.ORB; with PolyORB.Parameters; with PolyORB.Protocols.GIOP.Local_Sockets; with PolyORB.References.IOR; with PolyORB.Setup; with PolyORB.Transport.Connected.Local_Sockets; with PolyORB.Utils.Strings; with PolyORB.Representations.CDR.Common; package body PolyORB.Binding_Data.GIOP.Local_Sockets is use Ada.Streams; use PolyORB.GIOP_P.Tagged_Components; use PolyORB.Log; use PolyORB.Objects; use PolyORB.References.IOR; use PolyORB.Transport.Connected.Local_Sockets; use PolyORB.Types; use PolyORB.Representations.CDR.Common; package L is new PolyORB.Log.Facility_Log ("polyorb.binding_data.giop.ls"); procedure O (Message : in Standard.String; Level : Log_Level := Debug) renames L.Output; function C (Level : Log_Level := Debug) return Boolean renames L.Enabled; pragma Unreferenced (C); -- For conditional pragma Debug Preference : Profile_Preference; -- Global variable: the preference to be returned -- by Get_Profile_Preference for LS profiles. ------------------ -- Bind_Profile -- ------------------ -- Factories Pro : aliased PolyORB.Protocols.GIOP.Local_Sockets.Local_Sockets_Protocol; LS_Factories : constant Filters.Factory_Array := (0 => Pro'Access); procedure Bind_Profile (Profile : LS_Profile_Type; The_ORB : Components.Component_Access; BO_Ref : out Smart_Pointers.Ref; Error : out Errors.Error_Container) is pragma Unreferenced (Error); use PolyORB.Components; use PolyORB.Errors; use PolyORB.Filters; use PolyORB.Protocols; use PolyORB.Protocols.GIOP; use PolyORB.Protocols.GIOP.Local_Sockets; use PolyORB.ORB; TE : constant Transport.Transport_Endpoint_Access := new Local_Socket_Endpoint; S : Local_Socket_Type; begin pragma Debug (O ("Bind LS profile: enter")); Set_Address (S, Profile.Address); Create (Local_Socket_Endpoint (TE.all), S); Set_Allocation_Class (TE.all, Dynamic); Binding_Objects.Setup_Binding_Object (ORB.ORB_Access (The_ORB), TE, LS_Factories, ORB.Client, BO_Ref); pragma Debug (O ("Bind LS profile: leave")); end Bind_Profile; ----------------------- -- Duplicate_Profile -- ----------------------- function Duplicate_Profile (P : LS_Profile_Type) return Profile_Access is use PolyORB.Objects; Result : constant Profile_Access := new LS_Profile_Type; TResult : LS_Profile_Type renames LS_Profile_Type (Result.all); PP : LS_Profile_Type renames P; begin TResult.Version_Major := PP.Version_Major; TResult.Version_Minor := PP.Version_Minor; TResult.Object_Id := new Object_Id'(PP.Object_Id.all); TResult.Address := PP.Address; TResult.Components := Deep_Copy (PP.Components); return Result; end Duplicate_Profile; --------------------- -- Get_Profile_Tag -- --------------------- function Get_Profile_Tag (Profile : LS_Profile_Type) return Profile_Tag is pragma Unreferenced (Profile); begin return Tag_Internet_IOP; -- XXX ??? end Get_Profile_Tag; ---------------------------- -- Get_Profile_Preference -- ---------------------------- function Get_Profile_Preference (Profile : LS_Profile_Type) return Profile_Preference is pragma Unreferenced (Profile); begin return Preference; end Get_Profile_Preference; -------------------- -- Create_Factory -- -------------------- procedure Create_Factory (PF : out LS_Profile_Factory; TAP : Transport.Transport_Access_Point_Access; ORB : Components.Component_Access) is pragma Unreferenced (ORB); begin pragma Debug (O ("TAP :" & Image (Local_Socket_Access_Point (TAP.all)))); PF.Address := Address_Of (Local_Socket_Access_Point (TAP.all)); pragma Debug (O ("Create factory :" & PF.Address.LPort'Img)); end Create_Factory; -------------------- -- Create_Profile -- -------------------- function Create_Profile (PF : access LS_Profile_Factory; Oid : Objects.Object_Id) return Profile_Access is Result : constant Profile_Access := new LS_Profile_Type; TResult : LS_Profile_Type renames LS_Profile_Type (Result.all); begin pragma Debug (O ("Create_Profile: enter")); TResult.Version_Major := LS_Version_Major; TResult.Version_Minor := LS_Version_Minor; TResult.Object_Id := new Object_Id'(Oid); TResult.Address := PF.Address; TResult.Components := Null_Tagged_Component_List; pragma Debug (O ("Create_Profile: leave")); return Result; end Create_Profile; ---------------------- -- Is_Local_Profile -- ---------------------- function Is_Local_Profile (PF : access LS_Profile_Factory; P : access Profile_Type'Class) return Boolean is begin return P.all in LS_Profile_Type and then LS_Profile_Type (P.all).Address = PF.Address; end Is_Local_Profile; ------------------------------ -- Marshall_LS_Profile_Body -- ------------------------------ procedure Marshall_LS_Profile_Body (Buf : access Buffer_Type; Profile : Profile_Access) is GIOP_Profile : GIOP_Profile_Type'Class renames GIOP_Profile_Type'Class (Profile.all); Profile_Body : Buffer_Access := new Buffer_Type; begin pragma Debug (O ("Common_Marshall_Profile_Body: enter")); -- A Profile Body is an encapsulation Start_Encapsulation (Profile_Body); -- Version Marshall (Profile_Body, GIOP_Profile.Version_Major); Marshall (Profile_Body, GIOP_Profile.Version_Minor); pragma Debug (O (" Version = " & GIOP_Profile.Version_Major'Img & "." & GIOP_Profile.Version_Minor'Img)); -- Marshalling of a Socket Marshall_Latin_1_String (Profile_Body, PolyORB.Types.To_PolyORB_String (LS_Profile_Type (Profile.all).Address.LPort'Img)); pragma Debug (O (" Address = " & LS_Profile_Type (Profile.all).Address.LPort'Img)); -- Marshalling the object id Marshall (Profile_Body, Stream_Element_Array (GIOP_Profile.Object_Id.all)); -- Marshalling the tagged components Marshall_Tagged_Component (Profile_Body, GIOP_Profile.Components); -- Marshalling the Profile_Body into IOR Marshall (Buf, Encapsulate (Profile_Body)); Release (Profile_Body); pragma Debug (O ("Common_Marshall_Profile_Body: leave")); end Marshall_LS_Profile_Body; ------------------------------------- -- Unmarshall_LS_Profile_Body -- ------------------------------------- function Unmarshall_LS_Profile_Body (Buffer : access Buffer_Type) return Profile_Access is Result : constant Profile_Access := new LS_Profile_Type; TResult : GIOP_Profile_Type'Class renames GIOP_Profile_Type'Class (Result.all); Profile_Body : aliased Encapsulation := Unmarshall (Buffer); Profile_Buffer : Buffer_Access := new Buffers.Buffer_Type; begin pragma Debug (O ("Common_Unmarshall_Profile_Body: enter")); -- A Profile Body is an encapsulation Decapsulate (Profile_Body'Access, Profile_Buffer); TResult.Version_Major := Unmarshall (Profile_Buffer); TResult.Version_Minor := Unmarshall (Profile_Buffer); pragma Debug (O (" Version = " & TResult.Version_Major'Img & "." & TResult.Version_Minor'Img)); -- Unmarshalling the socket declare LPort_Image : constant Types.String := Unmarshall_Latin_1_String (Profile_Buffer); begin pragma Debug (O (" Address = " & To_String (LPort_Image))); LS_Profile_Type (Result.all).Address.LPort := Port'Value (To_String (LPort_Image)); end; -- Unmarshalling the object id declare Str : aliased constant Stream_Element_Array := Unmarshall (Profile_Buffer); begin TResult.Object_Id := new Object_Id'(Object_Id (Str)); end; -- Unmarshalling tagged components TResult.Components := Unmarshall_Tagged_Component (Profile_Buffer); Release (Profile_Buffer); pragma Debug (O ("Unmarshall_LS_Profile_body: leave")); return Result; end Unmarshall_LS_Profile_Body; ----------- -- Image -- ----------- function Image (Prof : LS_Profile_Type) return String is begin return "LS profile: Address = " & Prof.Address.LPort'Img & ", Object_Id : " & PolyORB.Objects.Image (Prof.Object_Id.all); end Image; ----------- -- Image -- ----------- function Image (Prof : LS_Profile_Factory) return String is begin return "LS profile Factory : Address = " & Prof.Address.LPort'Img; end Image; ------------ -- Get_OA -- ------------ function Get_OA (Profile : LS_Profile_Type) return PolyORB.Smart_Pointers.Entity_Ptr is pragma Unreferenced (Profile); begin return PolyORB.Smart_Pointers.Entity_Ptr (PolyORB.ORB.Object_Adapter (PolyORB.Setup.The_ORB)); end Get_OA; ---------------- -- Initialize -- ---------------- procedure Initialize; procedure Initialize is Preference_Offset : constant String := PolyORB.Parameters.Get_Conf (Section => "lsiop", Key => "polyorb.binding_data.lsiop.preference", Default => "0"); begin Preference := Preference_Default + Profile_Preference'Value (Preference_Offset); Register (Tag_Internet_IOP, Marshall_LS_Profile_Body'Access, Unmarshall_LS_Profile_Body'Access); end Initialize; use PolyORB.Initialization; use PolyORB.Initialization.String_Lists; use PolyORB.Utils.Strings; begin Register_Module (Module_Info' (Name => +"binding_data.lsiop", Conflicts => Empty, Depends => +"local_sockets", Provides => +"binding_factories", Implicit => False, Init => Initialize'Access, Shutdown => null)); end PolyORB.Binding_Data.GIOP.Local_Sockets; polyorb-2.8~20110207.orig/contrib/local_sockets/protocol/polyorb-local_sockets.adb0000644000175000017500000004242311750740337027524 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . L O C A L _ S O C K E T S -- -- -- -- B o d y -- -- -- -- Copyright (C) 2005-2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with Ada.Streams; with PolyORB.Initialization; with PolyORB.Buffers; with PolyORB.Utils.Strings; with PolyORB.Utils.Chained_Lists; with PolyORB.Opaque; with PolyORB.Log; package body PolyORB.Local_Sockets is use PolyORB.Log; use PolyORB.Buffers; use PolyORB.Opaque; package L is new PolyORB.Log.Facility_Log ("polyorb.local_sockets"); procedure O (Message : in String; Level : Log_Level := Debug) renames L.Output; function C (Level : Log_Level := Debug) return Boolean renames L.Enabled; pragma Unreferenced (C); -- For conditional pragma Debug Initialized : Boolean := False; Sockets_Array : array (1 .. Channel_Number) of Local_Socket_Access; ------------------------- -- Create_Local_Socket -- ------------------------- function Create_Local_Socket return Local_Socket_Access is Socket_Ptr : constant Local_Socket_Access := new Local_Socket_Type; begin pragma Debug (O ("Create local socket : enter")); if not Initialized then Initialize; end if; -- Find a free channel for J in Sockets_Array'Range loop if not Sockets_Array (J).all.Used then Sockets_Array (J).Used := True; Socket_Ptr.Addr.LPort := Port (J); return Socket_Ptr; end if; end loop; raise Program_Error; pragma Debug (O ("Create local socket : leave")); return null; end Create_Local_Socket; ---------- -- Copy -- ---------- function Copy (S : Local_Socket_Type) return Local_Socket_Type is Result : Local_Socket_Type; begin Channel (Result) := Channel (S); Result.Addr := S.Addr; Result.Connecting_Port := S.Connecting_Port; Result.Selector := S.Selector; return Result; end Copy; ---------------- -- Get_Socket -- ---------------- function Get_Socket (Addr : Local_Socket_Addr) return Local_Socket_Type is begin return Sockets_Array (Integer (Addr.LPort)).all; end Get_Socket; ---------- -- Read -- ---------- procedure Read (Socket : Local_Socket_Access; Buffer : PolyORB.Buffers.Buffer_Access; Size : in out Ada.Streams.Stream_Element_Count) is use Ada.Streams; I : Integer := Integer (Sockets_Array (Integer (Socket.Addr.LPort)).Connecting_Port); begin pragma Assert (Initialized); if Sockets_Array (I).Connecting_Only then pragma Debug (O ("The socket" & I'Img & " is dedicated to accept connections")); I := Integer (Sockets_Array (I).Connecting_Port); pragma Assert (I /= 0); end if; pragma Debug (O ("Read on the socket number :" & I'Img)); PTM.Enter (Sockets_Array (I).My_Mutex); PTCV.Wait (Sockets_Array (I).Not_Empty_Condition, Sockets_Array (I).My_Mutex); declare Data : Opaque_Pointer; Buffer_Size : constant Stream_Element_Offset := Length (Buffer); begin Rewind (Sockets_Array (I).Shared); Set_Initial_Position (Sockets_Array (I).Shared, 0); Extract_Data (Sockets_Array (I).Shared, Data, Size + Length (Buffer), True); Release_Contents (Buffer.all); Initialize_Buffer (Buffer, Buffer_Size + Size, Data, Little_Endian, 0); Set_CDR_Position (Buffer, Buffer_Size); if Length (Sockets_Array (I).Shared) = Length (Buffer) then pragma Debug (O ("no more data")); PTCV.Signal (Sockets_Array (I).Not_Full_Condition); Sockets_Array (I).Empty_Buffer := True; Sockets_Array (I).Full_Buffer := False; Release_Contents (Sockets_Array (I).Shared.all); Sockets_Array (I).Shared := null; end if; if Sockets_Array (I).Selector /= null then PTM.Enter (Sockets_Array (I).Selector.Mutex); PTCV.Signal (Sockets_Array (I).Selector.CV); PTM.Leave (Sockets_Array (I).Selector.Mutex); end if; end; PTM.Leave (Sockets_Array (I).My_Mutex); end Read; ------------------- -- Create_Socket -- ------------------- procedure Create_Socket (Socket : in out Local_Socket_Type) is S_Access : constant Local_Socket_Access := Create_Local_Socket; begin Socket := S_Access.all; end Create_Socket; ------------------- -- Accept_Socket -- ------------------- procedure Accept_Socket (Server : Local_Socket_Type; Socket : out Local_Socket_Type; Address : out Local_Socket_Addr) is Index : constant Integer := Integer (Server.Addr.LPort); begin PTM.Enter (Sockets_Array (Index).My_Mutex); if Sockets_Array (Index).Connecting_Port = 0 then Create_Socket (Socket); Sockets_Array (Index).Connecting_Port := Socket.Addr.LPort; end if; Socket.Connecting_Port := Sockets_Array (Index).Connecting_Port; Socket.Addr.LPort := Server.Addr.LPort; Socket.Selector := Sockets_Array (Index).Selector; Address := Address_Of (Socket); PTCV.Signal (Sockets_Array (Index).Is_Connected); PTM.Leave (Sockets_Array (Index).My_Mutex); if Sockets_Array (Index).Selector /= null then PTM.Enter (Sockets_Array (Index).Selector.Mutex); PTCV.Signal (Sockets_Array (Index).Selector.CV); PTM.Leave (Sockets_Array (Index).Selector.Mutex); end if; end Accept_Socket; -------------------- -- Connect_Socket -- -------------------- procedure Connect_Socket (Socket : Local_Socket_Type; Server : in out Local_Socket_Addr) is Index : constant Integer := Integer (Server.LPort); begin pragma Assert (Index /= 0); -- XXX should ensure that the server is already set up ! PTM.Enter (Sockets_Array (Index).My_Mutex); Sockets_Array (Integer (Socket.Addr.LPort)).Connecting_Port := Sockets_Array (Index).Connecting_Port; PTCV.Signal (Sockets_Array (Index).Is_Connected); pragma Debug (O ("THE SOCKET IS CONNECTED NOW" & Sockets_Array (Index).Connecting_Port'Img)); pragma Assert (Sockets_Array (Index).Connecting_Port /= 0); Sockets_Array (Integer (Server.LPort)).Selector := Sockets_Array (Index).Selector; if Sockets_Array (Index).Selector /= null then PTM.Enter (Sockets_Array (Index).Selector.Mutex); PTCV.Signal (Sockets_Array (Index).Selector.CV); PTM.Leave (Sockets_Array (Index).Selector.Mutex); end if; end Connect_Socket; ------------------- -- Listen_Socket -- ------------------- procedure Listen_Socket (Socket : Local_Socket_Type) is Index : constant Integer := Integer (Socket.Addr.LPort); begin Sockets_Array (Index).Connecting_Only := True; end Listen_Socket; ----------------------- -- Is_Data_Available -- ----------------------- function Is_Data_Available (S : Local_Socket_Access; N : Natural) return Boolean is begin if S /= null and then Sockets_Array (Integer (S.all.Connecting_Port)).Shared /= null then return Integer (Length (Sockets_Array (Integer (S.all.Connecting_Port)).Shared)) >= N; end if; return False; end Is_Data_Available; ----------- -- Write -- ----------- procedure Write (Socket : in Local_Socket_Access; Buffer : in PolyORB.Buffers.Buffer_Access) is I : Integer := Integer (Socket.Addr.LPort); begin if not Initialized then Initialize; end if; I := Integer (Sockets_Array (I).Connecting_Port); PTM.Enter (Sockets_Array (I).My_Mutex); while Sockets_Array (I).Full_Buffer loop -- no place in the buffer PTCV.Wait (Sockets_Array (I).Not_Full_Condition, Sockets_Array (I).My_Mutex); end loop; -- Put the data Sockets_Array (I).Shared := Copy (Buffer); -- The buffer is no longer full Sockets_Array (I).Empty_Buffer := False; Sockets_Array (I).Full_Buffer := True; PTCV.Signal (Sockets_Array (I).Not_Empty_Condition); PTM.Leave (Sockets_Array (I).My_Mutex); pragma Debug (O ("written On : " & I'Img)); if Sockets_Array (I).Selector /= null then pragma Debug (O ("Signal an event to the selctor")); PTM.Enter (Sockets_Array (I).Selector.Mutex); PTCV.Signal (Sockets_Array (I).Selector.CV); PTM.Leave (Sockets_Array (I).Selector.Mutex); else pragma Debug (O ("The socket" & I'Img & " is not controlled!!!")); null; end if; end Write; ------------ -- Close -- ------------ procedure Close (Socket : in out Local_Socket_Access) is begin PTM.Enter (Sockets_Array (Integer (Socket.Addr.LPort)).My_Mutex); Socket.Used := False; Socket.Selector := null; Release_Contents (Channel (Socket.all).Shared.all); PTM.Leave (Sockets_Array (Integer (Socket.Addr.LPort)).My_Mutex); end Close; ---------------- -- Address_Of -- ---------------- function Address_Of (S : Local_Socket_Type) return Local_Socket_Addr is begin return S.Addr; end Address_Of; ----------------- -- Set_Address -- ----------------- procedure Set_Address (S : in out Local_Socket_Type; Addr : Local_Socket_Addr) is begin S.Addr := Addr; end Set_Address; ----------- -- Image -- ----------- function Image (S : Local_Socket_Type) return String is begin return ("SOCKET, Port = " & Integer (S.Addr.LPort)'Img & "Connecting_port = " & Integer (S.Connecting_Port)'Img); end Image; ----------------- -- GlobalImage -- ----------------- procedure GlobalImage is begin for I in Sockets_Array'Range loop pragma Debug (O (Image (Sockets_Array (I).all))); null; end loop; end GlobalImage; ----------- -- Empty -- ----------- procedure Empty (Item : in out Local_Socket_Set_Type) is begin Deallocate (Item); end Empty; --------- -- Set -- --------- procedure Set (Item : in out Local_Socket_Set_Type; Socket : in Local_Socket_Access) is begin pragma Debug (O ("Set : Enter")); if Socket = null then raise Program_Error; end if; Append (Item, Socket); pragma Debug (O ("Set : Leave")); end Set; ------------ -- Is_Set -- ------------ function Is_Set (Item : Local_Socket_Set_Type; Socket : Local_Socket_Access) return Boolean is use Local_Socket_Lists; It : Iterator := First (Item); begin while not Last (It) loop if Value (It).all.all = Socket.all then return True; end if; Next (It); end loop; return False; end Is_Set; ----------- -- Clear -- ----------- procedure Clear (Item : in out Local_Socket_Set_Type; Socket : in Local_Socket_Access) is begin Remove (Item, Socket); end Clear; ---------- -- Copy -- ---------- procedure Copy (Source : Local_Socket_Set_Type; Target : in out Local_Socket_Set_Type) is begin Target := Duplicate (Source); end Copy; --------------------- -- Create_Selector -- --------------------- procedure Create_Selector (Selector : out Local_Selector_Type) is Result : Local_Selector_Type; begin PTM.Create (Result.Mutex); PTCV.Create (Result.CV); Selector := Result; pragma Debug (O ("Selector created")); end Create_Selector; -------------------- -- Close_Selector -- -------------------- procedure Close_Selector (Selector : in out Local_Selector_Type) is begin Empty (Selector.Set); PTM.Destroy (Selector.Mutex); PTCV.Destroy (Selector.CV); end Close_Selector; -------------------- -- Check_Selector -- -------------------- procedure Check_Selector (Selector : in out Local_Selector_Type; R_Socket_Set : in out Local_Socket_Set_Type; Status : out Selector_Status; Timeout : in Standard.Duration := Forever) is pragma Unreferenced (Timeout); use Local_Socket_Lists; use type Ada.Streams.Stream_Element_Offset; -- XXX need some optimizations It : Local_Socket_Lists.Iterator := First (R_Socket_Set); begin pragma Debug (O ("Check_Selector : Enter")); pragma Debug (O ("going to listen on " & Length (R_Socket_Set)'Img & " socket(s)")); It := First (R_Socket_Set); while not Local_Socket_Lists.Last (It) loop Local_Socket_Lists.Next (It); end loop; PTM.Enter (Selector.Mutex); It := First (R_Socket_Set); while not Local_Socket_Lists.Last (It) loop if Value (It).all = null then raise Program_Error; end if; if Value (It).all.Shared /= null and then Length (Value (It).all.Shared) > 0 then Status := Completed; PTM.Leave (Selector.Mutex); return; end if; Local_Socket_Lists.Next (It); end loop; It := First (R_Socket_Set); while not Local_Socket_Lists.Last (It) loop Sockets_Array (Integer (Address_Of (Value (It).all.all).LPort)). Selector := Selector'Unrestricted_Access; Local_Socket_Lists.Next (It); end loop; PTCV.Wait (Selector.CV, Selector.Mutex); pragma Debug (O ("Selector : An Event is Detected")); It := First (R_Socket_Set); while not Local_Socket_Lists.Last (It) loop Value (It).all.Selector := null; Local_Socket_Lists.Next (It); end loop; PTM.Leave (Selector.Mutex); pragma Debug (O ("Check_Selector : Leave")); end Check_Selector; -------------------- -- Abort_Selector -- -------------------- procedure Abort_Selector (Selector : in Local_Selector_Type) is begin pragma Debug (O ("about to abort Selector ")); PTM.Enter (Selector.Mutex); PTCV.Signal (Selector.CV); PTM.Leave (Selector.Mutex); end Abort_Selector; ---------------- -- Initialize -- ---------------- procedure Initialize is begin if not Initialized then for I in Sockets_Array'Range loop Sockets_Array (I) := new Local_Socket_Type; Sockets_Array (I).Addr.LPort := Port (I); PTM.Create (Sockets_Array (I).My_Mutex); PTCV.Create (Sockets_Array (I).Not_Full_Condition); PTCV.Create (Sockets_Array (I).Not_Empty_Condition); PTCV.Create (Sockets_Array (I).Is_Connected); end loop; end if; Initialized := True; end Initialize; use PolyORB.Initialization; use PolyORB.Initialization.String_Lists; use PolyORB.Utils.Strings; begin Register_Module (Module_Info' (Name => +"local_sockets", Conflicts => Empty, Depends => +"tasking.mutexes" & "tasking.threads" & "tasking.condition_variables", Provides => Empty, Implicit => False, Init => Initialize'Access, Shutdown => null)); end PolyORB.Local_Sockets; polyorb-2.8~20110207.orig/contrib/local_sockets/protocol/polyorb-local_sockets.ads0000644000175000017500000001712311750740337027544 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . L O C A L _ S O C K E T S -- -- -- -- S p e c -- -- -- -- Copyright (C) 2005 Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with Ada.Streams; with PolyORB.Buffers; with PolyORB.Tasking.Mutexes; with PolyORB.Tasking.Condition_Variables; with PolyORB.Utils.Chained_Lists; package PolyORB.Local_Sockets is -- This package contains some functionalities similar to those of -- GNAT.Sockets. The communications are simulated by some -- Ravenscar compilant synchronization primitives offered by PolyORB. Channel_Number : constant Natural := 10; procedure Initialize; package PTCV renames PolyORB.Tasking.Condition_Variables; package PTM renames PolyORB.Tasking.Mutexes; type Port is new Integer range 0 .. Channel_Number; type Local_Socket_Addr is record LPort : Port; end record; ----------------------- -- Local_Socket_Type -- ----------------------- type Local_Socket_Type is private; type Local_Socket_Access is access Local_Socket_Type; function Create_Local_Socket return Local_Socket_Access; function Copy (S : Local_Socket_Type) return Local_Socket_Type; function Get_Socket (Addr : Local_Socket_Addr) return Local_Socket_Type; procedure Read (Socket : Local_Socket_Access; Buffer : PolyORB.Buffers.Buffer_Access; Size : in out Ada.Streams.Stream_Element_Count); procedure Create_Socket (Socket : in out Local_Socket_Type); procedure Accept_Socket (Server : Local_Socket_Type; Socket : out Local_Socket_Type; Address : out Local_Socket_Addr); -- Extract the first connection request on the queue of pending -- connections, creates a new connected socket with mostly the -- same properties as Server, and allocates a new socket. The -- returned Address is filled in with the address of the -- connection. procedure Connect_Socket (Socket : Local_Socket_Type; Server : in out Local_Socket_Addr); -- Make a connection to another socket which has the address of -- Server. procedure Listen_Socket (Socket : Local_Socket_Type); -- To accept connections, a socket is first created with -- Create_Socket, function Is_Data_Available (S : Local_Socket_Access; N : Natural) return Boolean; procedure Write (Socket : in Local_Socket_Access; Buffer : in PolyORB.Buffers.Buffer_Access); procedure Close (Socket : in out Local_Socket_Access); function Address_Of (S : Local_Socket_Type) return Local_Socket_Addr; pragma Inline (Address_Of); procedure Set_Address (S : in out Local_Socket_Type; Addr : Local_Socket_Addr); pragma Inline (Set_Address); function Image (S : Local_Socket_Type) return String; procedure GlobalImage; --------------------------- -- Local_Socket_Set_Type -- --------------------------- type Local_Socket_Set_Type is limited private; procedure Empty (Item : in out Local_Socket_Set_Type); -- Remove all Sockets from Item and deallocate internal data procedure Set (Item : in out Local_Socket_Set_Type; Socket : in Local_Socket_Access); -- Insert Socket into Item function Is_Set (Item : Local_Socket_Set_Type; Socket : Local_Socket_Access) return Boolean; -- Return True iff Socket is present in Item procedure Clear (Item : in out Local_Socket_Set_Type; Socket : in Local_Socket_Access); -- Remove Socket from Item procedure Copy (Source : Local_Socket_Set_Type; Target : in out Local_Socket_Set_Type); ------------------------- -- Local_Selector_Type -- ------------------------- type Local_Selector_Type is limited private; procedure Create_Selector (Selector : out Local_Selector_Type); procedure Close_Selector (Selector : in out Local_Selector_Type); -- Close Selector and all internal descriptors associated type Selector_Status is (Completed, Expired, Aborted); Forever : constant := Duration (Integer'Last) * 1.0; -- This procedure provides the same functionnalty than the -- GNAT.Sockets one : it blocks until an event happens in a set of -- channels. procedure Check_Selector (Selector : in out Local_Selector_Type; R_Socket_Set : in out Local_Socket_Set_Type; Status : out Selector_Status; Timeout : in Standard.Duration := Forever); procedure Abort_Selector (Selector : in Local_Selector_Type); -- Send an abort signal to the selector. private type Channel is tagged record Empty_Buffer : Boolean := True; Full_Buffer : Boolean := False; IO_V : aliased PolyORB.Buffers.Iovec; My_Mutex : PTM.Mutex_Access; Not_Full_Condition, Not_Empty_Condition : PTCV.Condition_Access; Shared : PolyORB.Buffers.Buffer_Access; Connecting_Only : Boolean := False; end record; type Local_Selector_Type_Access is access Local_Selector_Type; type Local_Socket_Type is new Channel with record Used : Boolean := False; Addr : Local_Socket_Addr; Connected : Boolean := False; Is_Connected : PTCV.Condition_Access; Connecting_Port : Port := Port (0); Selector : Local_Selector_Type_Access; end record; package Local_Socket_Lists is new PolyORB.Utils.Chained_Lists ( Local_Socket_Access); type Local_Socket_Set_Type is new Local_Socket_Lists.List; type Local_Selector_Type is record Set : Local_Socket_Set_Type; Mutex : PTM.Mutex_Access; CV : PTCV.Condition_Access; end record; end PolyORB.Local_Sockets; polyorb-2.8~20110207.orig/contrib/local_sockets/protocol/polyorb-setup-access_points-ls.adb0000644000175000017500000001305511750740337031305 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . S E T U P . A C C E S S _ P O I N T S . L S -- -- -- -- B o d y -- -- -- -- Copyright (C) 2005-2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with PolyORB.Binding_Data.GIOP.Local_Sockets; with PolyORB.Protocols.GIOP.Local_Sockets; with PolyORB.Transport.Connected.Local_Sockets; with PolyORB.Components; with PolyORB.Filters.Slicers; with PolyORB.Initialization; with PolyORB.ORB; with PolyORB.Protocols; with PolyORB.Setup; with PolyORB.Utils.Strings; with PolyORB.Log; with PolyORB.Local_Sockets; pragma Elaborate_All (PolyORB.Local_Sockets); package body PolyORB.Setup.Access_Points.LS is use PolyORB.Binding_Data.GIOP.Local_Sockets; use PolyORB.Filters; use PolyORB.Filters.Slicers; use PolyORB.ORB; use PolyORB.Transport.Connected.Local_Sockets; use PolyORB.Log; use PolyORB.Local_Sockets; package L is new PolyORB.Log.Facility_Log ("polyorb.setup-access-points.ls"); procedure O (Message : in Standard.String; Level : Log_Level := Debug) renames L.Output; function C (Level : Log_Level := Debug) return Boolean renames L.Enabled; pragma Unreferenced (C); -- For conditional pragma Debug type LS_Access_Point_Info is record Socket : Local_Socket_Access; SAP : PolyORB.Transport.Transport_Access_Point_Access; PF : PolyORB.Binding_Data.Profile_Factory_Access; end record; LS_Access_Point : LS_Access_Point_Info := (Socket => null, SAP => new Local_Socket_Access_Point, PF => new LS_Profile_Factory); Sli : aliased Slicer_Factory; Pro : aliased Protocols.GIOP.Local_Sockets.Local_Sockets_Protocol; LS_Factories : aliased Filters.Factory_Array := (0 => Sli'Access, 1 => Pro'Access); ------------------------ -- Initialize_Sockets -- ------------------------- procedure Initialize_Socket (DAP : in out LS_Access_Point_Info); procedure Initialize_Socket (DAP : in out LS_Access_Point_Info) is Addr : Local_Socket_Addr; use PolyORB.Transport; use PolyORB.Transport.Connected.Local_Sockets; use PolyORB.Binding_Data; use PolyORB.Binding_Data.GIOP.Local_Sockets; Tmp : constant Local_Socket_Access := Create_Local_Socket; begin DAP.Socket := Tmp; if DAP.SAP = null then DAP.SAP := new Local_Socket_Access_Point; end if; Create (Local_Socket_Access_Point (DAP.SAP.all), DAP.Socket.all, Addr); if DAP.PF /= null then Create_Factory (LS_Profile_Factory (DAP.PF.all), DAP.SAP, Components.Component_Access (Setup.The_ORB)); end if; pragma Debug (O ("Ls_Profile_Factory : Image " & Image (LS_Profile_Factory (DAP.PF.all)))); end Initialize_Socket; ------------------------------ -- Initialize_Access_Points -- ------------------------------ procedure Initialize_Access_Points; procedure Initialize_Access_Points is use PolyORB.Transport.Connected.Local_Sockets; begin Initialize_Socket (LS_Access_Point); Register_Access_Point (ORB => The_ORB, TAP => LS_Access_Point.SAP, Chain => LS_Factories'Access, PF => LS_Access_Point.PF); end Initialize_Access_Points; use PolyORB.Initialization; use PolyORB.Initialization.String_Lists; use PolyORB.Utils.Strings; begin Register_Module (Module_Info' (Name => +"access_points.lsiop", Conflicts => String_Lists.Empty, Depends => +"orb" & "protocols.giop.lsiop" & "local_sockets", Provides => String_Lists.Empty, Implicit => False, Init => Initialize_Access_Points'Access, Shutdown => null)); end PolyORB.Setup.Access_Points.LS; polyorb-2.8~20110207.orig/contrib/local_sockets/protocol/polyorb-binding_data-giop-local_sockets.ads0000644000175000017500000001014211750740337033073 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- POLYORB.BINDING_DATA.GIOP.LOCAL_SOCKETS -- -- -- -- S p e c -- -- -- -- Copyright (C) 2005 Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with PolyORB.Buffers; with PolyORB.Types; with PolyORB.Local_Sockets; package PolyORB.Binding_Data.GIOP.Local_Sockets is use PolyORB.Buffers; type LS_Profile_Type is new GIOP_Profile_Type with private; type LS_Profile_Factory is new GIOP_Profile_Factory with private; function Create_Profile (PF : access LS_Profile_Factory; Oid : Objects.Object_Id) return Profile_Access; function Duplicate_Profile (P : LS_Profile_Type) return Profile_Access; function Is_Local_Profile (PF : access LS_Profile_Factory; P : access Profile_Type'Class) return Boolean; procedure Bind_Profile (Profile : LS_Profile_Type; The_ORB : Components.Component_Access; BO_Ref : out Smart_Pointers.Ref; Error : out Errors.Error_Container); function Get_Profile_Tag (Profile : LS_Profile_Type) return Profile_Tag; pragma Inline (Get_Profile_Tag); function Get_Profile_Preference (Profile : LS_Profile_Type) return Profile_Preference; pragma Inline (Get_Profile_Preference); procedure Create_Factory (PF : out LS_Profile_Factory; TAP : Transport.Transport_Access_Point_Access; ORB : Components.Component_Access); procedure Marshall_LS_Profile_Body (Buf : access Buffer_Type; Profile : Profile_Access); function Unmarshall_LS_Profile_Body (Buffer : access Buffer_Type) return Profile_Access; function Image (Prof : LS_Profile_Type) return String; function Image (Prof : LS_Profile_Factory) return String; function Get_OA (Profile : LS_Profile_Type) return PolyORB.Smart_Pointers.Entity_Ptr; pragma Inline (Get_OA); private use PolyORB.Local_Sockets; LS_Version_Major : constant Types.Octet := 1; LS_Version_Minor : constant Types.Octet := 0; type LS_Profile_Type is new GIOP_Profile_Type with record -- Socket information Address : Local_Socket_Addr; end record; type LS_Profile_Factory is new GIOP_Profile_Factory with record Address : Local_Socket_Addr; end record; end PolyORB.Binding_Data.GIOP.Local_Sockets; polyorb-2.8~20110207.orig/contrib/local_sockets/protocol/polyorb-asynch_ev-local_sockets.ads0000644000175000017500000000707311750740337031524 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . A S Y N C H _ E V . L O C A L _ S O C K E T S -- -- -- -- S p e c -- -- -- -- Copyright (C) 2005 Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with PolyORB.Local_Sockets; with PolyORB.Utils.Chained_Lists; package PolyORB.Asynch_Ev.Local_Sockets is pragma Elaborate_Body; type Local_Event_Monitor is new Asynch_Ev_Monitor with private; procedure Create (AEM : out Local_Event_Monitor); procedure Destroy (AEM : in out Local_Event_Monitor); type Local_Event_Source is new Asynch_Ev_Source with private; procedure Register_Source (AEM : access Local_Event_Monitor; AES : Asynch_Ev_Source_Access; Success : out Boolean); procedure Unregister_Source (AEM : in out Local_Event_Monitor; AES : Asynch_Ev_Source_Access); function Check_Sources (AEM : access Local_Event_Monitor; Timeout : Duration) return AES_Array; procedure Abort_Check_Sources (AEM : Local_Event_Monitor); function Create_Event_Source (Socket : PolyORB.Local_Sockets.Local_Socket_Access) return Asynch_Ev_Source_Access; function AEM_Factory_Of (AES : Local_Event_Source) return AEM_Factory; private type Local_Event_Source is new Asynch_Ev_Source with record Socket : PolyORB.Local_Sockets.Local_Socket_Access; end record; package Source_Lists is new PolyORB.Utils.Chained_Lists ( Asynch_Ev_Source_Access, Doubly_Chained => True); type Local_Event_Monitor is new Asynch_Ev_Monitor with record Selector : PolyORB.Local_Sockets.Local_Selector_Type; Monitored_Set : PolyORB.Local_Sockets.Local_Socket_Set_Type; Sources : Source_Lists.List; end record; end PolyORB.Asynch_Ev.Local_Sockets; polyorb-2.8~20110207.orig/contrib/local_sockets/protocol/polyorb-protocols-giop-local_sockets.ads0000644000175000017500000000461011750740337032517 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- POLYORB.PROTOCOLS.GIOP.LOCAL_SOCKETS -- -- -- -- S p e c -- -- -- -- Copyright (C) 2005 Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ package PolyORB.Protocols.GIOP.Local_Sockets is type Local_Sockets_Protocol is new GIOP_Protocol with private; procedure Create (Proto : access Local_Sockets_Protocol; Session : out Filter_Access); private type Local_Sockets_Protocol is new GIOP_Protocol with null record; Local_Sockets_Conf : aliased GIOP_Conf; end PolyORB.Protocols.GIOP.Local_Sockets; polyorb-2.8~20110207.orig/contrib/local_sockets/protocol/polyorb-asynch_ev-local_sockets.adb0000644000175000017500000001704711750740337031505 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . A S Y N C H _ E V . L O C A L _ S O C K E T S -- -- -- -- B o d y -- -- -- -- Copyright (C) 2005 Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with PolyORB.Utils.Chained_Lists; with PolyORB.Log; package body PolyORB.Asynch_Ev.Local_Sockets is use PolyORB.Log; use PolyORB.Local_Sockets; package L is new PolyORB.Log.Facility_Log ("polyorb.asynch_ev.local_sockets"); procedure O (Message : in String; Level : Log_Level := Debug) renames L.Output; function C (Level : Log_Level := Debug) return Boolean renames L.Enabled; pragma Unreferenced (C); -- For conditional pragma Debug ------------ -- Create -- ------------ procedure Create (AEM : out Local_Event_Monitor) is begin Empty (AEM.Monitored_Set); Create_Selector (AEM.Selector); end Create; ------------- -- Destroy -- ------------- procedure Destroy (AEM : in out Local_Event_Monitor) is begin Empty (AEM.Monitored_Set); Close_Selector (AEM.Selector); end Destroy; --------------------- -- Register_Source -- --------------------- procedure Register_Source (AEM : access Local_Event_Monitor; AES : Asynch_Ev_Source_Access; Success : out Boolean) is begin pragma Debug (O ("Register_Source: enter")); Success := False; if AES.all not in Local_Event_Source then pragma Debug (O ("Register_Source: leave")); return; end if; Set (AEM.Monitored_Set, Local_Event_Source (AES.all).Socket); Source_Lists.Append (AEM.Sources, AES); pragma Debug (O ("Register_Source: Sources'Length:=" & Integer'Image (Source_Lists.Length (AEM.Sources)))); AES.Monitor := Asynch_Ev_Monitor_Access (AEM); Success := True; pragma Debug (O ("Register_Source: leave")); end Register_Source; ----------------------- -- Unregister_Source -- ----------------------- procedure Unregister_Source (AEM : in out Local_Event_Monitor; AES : Asynch_Ev_Source_Access) is begin pragma Debug (O ("Unregister_Source: enter")); Clear (AEM.Monitored_Set, Local_Event_Source (AES.all).Socket); Source_Lists.Remove (AEM.Sources, AES); pragma Debug (O ("Unregister_Source: Sources'Length:=" & Integer'Image (Source_Lists.Length (AEM.Sources)))); pragma Debug (O ("Unregister_Source: leave")); end Unregister_Source; ------------------- -- Check_Sources -- ------------------- function Check_Sources (AEM : access Local_Event_Monitor; Timeout : Duration) return AES_Array is use Source_Lists; Result : AES_Array (1 .. Length (AEM.Sources)); Last : Integer := 0; T : constant Duration := Timeout; -- XXX questionnable R_Set : Local_Socket_Set_Type; Status : Selector_Status; begin pragma Debug (O ("Check_Sources: enter")); Copy (Source => AEM.Monitored_Set, Target => R_Set); pragma Debug (O (Integer'Image (Source_Lists.Length (AEM.Sources)))); Check_Selector (Selector => AEM.Selector, R_Socket_Set => R_Set, Status => Status, Timeout => T); pragma Debug (O ("Selector returned status " & Selector_Status'Image (Status))); if Status = Completed then declare It : Source_Lists.Iterator := First (AEM.Sources); begin while not Source_Lists.Last (It) loop pragma Debug (O ("Iterate over source list")); declare S : Asynch_Ev_Source_Access renames Value (It).all; Sock : Local_Socket_Access renames Local_Event_Source (S.all).Socket; begin if Is_Set (R_Set, Sock) then Last := Last + 1; Result (Last) := S; Clear (AEM.Monitored_Set, Sock); Remove (AEM.Sources, It); else Next (It); end if; end; end loop; end; pragma Assert (Last >= Result'First); end if; -- Free the storage space associated with our socket sets. PolyORB.Local_Sockets.Empty (R_Set); pragma Debug (O ("Check_Sources: end")); return Result (1 .. Last); end Check_Sources; ------------------------- -- Abort_Check_Sources -- ------------------------- procedure Abort_Check_Sources (AEM : Local_Event_Monitor) is begin Abort_Selector (AEM.Selector); end Abort_Check_Sources; ------------------------- -- Create_Event_Source -- ------------------------- function Create_Event_Source (Socket : PolyORB.Local_Sockets.Local_Socket_Access) return Asynch_Ev_Source_Access is Result : constant Asynch_Ev_Source_Access := new Local_Event_Source; begin Local_Event_Source (Result.all).Socket := Socket; return Result; end Create_Event_Source; ------------------------------- -- Create_Local_Event_Monitor -- ------------------------------- function Create_Local_Event_Monitor return Asynch_Ev_Monitor_Access; function Create_Local_Event_Monitor return Asynch_Ev_Monitor_Access is begin return new Local_Event_Monitor; end Create_Local_Event_Monitor; -------------------- -- AEM_Factory_Of -- -------------------- function AEM_Factory_Of (AES : Local_Event_Source) return AEM_Factory is pragma Warnings (Off); pragma Unreferenced (AES); pragma Warnings (On); begin return Create_Local_Event_Monitor'Access; end AEM_Factory_Of; end PolyORB.Asynch_Ev.Local_Sockets; polyorb-2.8~20110207.orig/contrib/local_sockets/protocol/polyorb-protocols-giop-local_sockets.adb0000644000175000017500000000640311750740337032500 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- POLYORB.PROTOCOLS.GIOP.LOCAL_SOCKETS -- -- -- -- B o d y -- -- -- -- Copyright (C) 2005-2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with PolyORB.Initialization; with PolyORB.Utils.Strings; package body PolyORB.Protocols.GIOP.Local_Sockets is ------------ -- Create -- ------------ procedure Create (Proto : access Local_Sockets_Protocol; Session : out Filter_Access) is begin PolyORB.Protocols.GIOP.Create (GIOP_Protocol (Proto.all)'Access, Session); GIOP_Session (Session.all).Conf := Local_Sockets_Conf'Access; end Create; ---------------- -- Initialize -- ---------------- procedure Initialize; procedure Initialize is begin PolyORB.Protocols.GIOP.Initialize (Local_Sockets_Conf'Access, GIOP_Version'(Major => 1, Minor => 2), PolyORB.Requests.Sync_With_Transport, False, "lsiop", "polyorb.protocols.giop.lsiop"); end Initialize; use PolyORB.Initialization; use PolyORB.Initialization.String_Lists; use PolyORB.Utils.Strings; begin Register_Module (Module_Info' (Name => +"protocols.giop.lsiop", Conflicts => Empty, Depends => +"protocols.giop.giop_1_2", Provides => Empty, Implicit => False, Init => Initialize'Access, Shutdown => null)); end PolyORB.Protocols.GIOP.Local_Sockets; polyorb-2.8~20110207.orig/contrib/local_sockets/protocol/polyorb-setup-ls.ads0000644000175000017500000000412511750740337026471 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . S E T U P . L S -- -- -- -- S p e c -- -- -- -- Copyright (C) 2005 Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ package PolyORB.Setup.LS is pragma Elaborate_Body; end PolyORB.Setup.LS; polyorb-2.8~20110207.orig/contrib/local_sockets/protocol/polyorb-setup-ls.adb0000644000175000017500000000533711750740337026456 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . S E T U P . L S -- -- -- -- B o d y -- -- -- -- Copyright (C) 2005-2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ pragma Warnings (Off); with PolyORB.Protocols.GIOP.GIOP_1_2; pragma Warnings (On); with PolyORB.Initialization; with PolyORB.Utils.Strings; package body PolyORB.Setup.LS is ---------------- -- Initialize -- ---------------- procedure Initialize; procedure Initialize is begin null; end Initialize; use PolyORB.Initialization; use PolyORB.Initialization.String_Lists; use PolyORB.Utils.Strings; begin Register_Module (Module_Info' (Name => +"setup.lsiop", Conflicts => Empty, Depends => +"protocols.giop.giop_1_2", Provides => Empty, Implicit => False, Init => Initialize'Access, Shutdown => null)); end PolyORB.Setup.LS; polyorb-2.8~20110207.orig/contrib/local_sockets/test/0000755000175000017500000000000011750740340021646 5ustar xavierxavierpolyorb-2.8~20110207.orig/contrib/local_sockets/test/test_client_server.adb0000644000175000017500000000514011750740337026227 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- T E S T _ C L I E N T _ S E R V E R -- -- -- -- B o d y -- -- -- -- Copyright (C) 2005 Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with LS_Setup; pragma Warnings (Off, LS_Setup); pragma Elaborate_All (LS_Setup); with PolyORB.Tasking.Threads; with PolyORB.Initialization; with Test_Client_Server_Pkg; use Test_Client_Server_Pkg; with Ada.Real_Time; use Ada.Real_Time; ------------------------ -- Test_Client_Server -- ------------------------ procedure Test_Client_Server is begin PolyORB.Initialization.Initialize_World; PolyORB.Tasking.Threads.Create_Task (Test_Client_Server_Pkg.Server'Access); delay until Clock + Milliseconds (500); PolyORB.Tasking.Threads.Create_Task (Client'Access); end Test_Client_Server; polyorb-2.8~20110207.orig/contrib/local_sockets/test/echo-impl.ads0000644000175000017500000000474111750740337024230 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- E C H O . I M P L -- -- -- -- S p e c -- -- -- -- Copyright (C) 2002-2005 Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with CORBA; with PortableServer; package Echo.Impl is -- My own implementation of echo object. -- This is simply used to define the operations. type Object is new PortableServer.Servant_Base with null record; type Object_Acc is access Object; procedure PrintString (Self : access Object; Mesg : in CORBA.String); function EchoString (Self : access Object; Mesg : in CORBA.String) return CORBA.String; end Echo.Impl; polyorb-2.8~20110207.orig/contrib/local_sockets/test/echo.idl0000644000175000017500000000014711750740337023266 0ustar xavierxavierinterface Echo { string echoString (in string Mesg); oneway void printString (in string Mesg); }; polyorb-2.8~20110207.orig/contrib/local_sockets/test/ls_setup.adb0000644000175000017500000000674311750740337024174 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- L S _ S E T U P -- -- -- -- B o d y -- -- -- -- Copyright (C) 2005 Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with Ravenscar_Setup; pragma Warnings (Off, Ravenscar_Setup); pragma Elaborate_All (Ravenscar_Setup); with PolyORB.Log.Stderr; pragma Warnings (Off, PolyORB.Log.Stderr); pragma Elaborate_All (PolyORB.Log.Stderr); with PolyORB.ORB.Thread_Pool; pragma Warnings (Off, PolyORB.ORB.Thread_Pool); pragma Elaborate_All (PolyORB.ORB.Thread_Pool); with PolyORB.ORB_Controller.Workers; pragma Warnings (Off, PolyORB.ORB_Controller.Workers); pragma Elaborate_All (PolyORB.ORB_Controller.Workers); with PolyORB.Setup.OA.Basic_POA; pragma Warnings (Off, PolyORB.Setup.OA.Basic_POA); pragma Elaborate_All (PolyORB.Setup.OA.Basic_POA); with PolyORB.Setup.OA.Basic_POA; pragma Warnings (Off, PolyORB.Setup.OA.Basic_POA); pragma Elaborate_All (PolyORB.Setup.OA.Basic_POA); with PolyORB.Setup.LS; pragma Elaborate_All (PolyORB.Setup.LS); pragma Warnings (Off, PolyORB.Setup.LS); with PolyORB.Setup.Access_Points.LS; pragma Elaborate_All (PolyORB.Setup.Access_Points.LS); pragma Warnings (Off, PolyORB.Setup.Access_Points.LS); with PolyORB.Local_Sockets; pragma Elaborate_All (PolyORB.Local_Sockets); pragma Warnings (Off, PolyORB.Local_Sockets); with PolyORB.Binding_Data.GIOP.Local_Sockets; pragma Elaborate_All (PolyORB.Binding_Data.GIOP.Local_Sockets); pragma Warnings (Off, PolyORB.Binding_Data.GIOP.Local_Sockets); with PolyORB.Binding_Data.GIOP; pragma Elaborate_All (PolyORB.Binding_Data.GIOP); pragma Warnings (Off, PolyORB.Binding_Data.GIOP); package body LS_Setup is begin null; end LS_Setup; polyorb-2.8~20110207.orig/contrib/local_sockets/test/ravenscar_setup.ads0000644000175000017500000000450611750740337025556 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- R A V E N S C A R _ S E T U P -- -- -- -- S p e c -- -- -- -- Copyright (C) 2003-2005 Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with System; with PolyORB.Setup.Tasking.Ravenscar; package Ravenscar_Setup is new PolyORB.Setup.Tasking.Ravenscar (Number_Of_Application_Tasks => 10, Number_Of_System_Tasks => 10, Number_Of_Conditions => 50, Number_Of_Mutexes => 50, Task_Priority => System.Default_Priority, Storage_Size => 20_000); polyorb-2.8~20110207.orig/contrib/local_sockets/test/gnat.adc0000644000175000017500000000005711750740337023260 0ustar xavierxavier pragma Ravenscar; pragma Restrictions(No_IO); polyorb-2.8~20110207.orig/contrib/local_sockets/test/echo-impl.adb0000644000175000017500000000566711750740337024217 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- E C H O . I M P L -- -- -- -- B o d y -- -- -- -- Copyright (C) 2005 Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with Ada.Text_IO; with Echo.Skel; pragma Warnings (Off, Echo.Skel); package body Echo.Impl is ----------------- -- PrintString -- ----------------- procedure PrintString (Self : access Object; Mesg : in CORBA.String) is pragma Warnings (Off); pragma Unreferenced (Self); pragma Warnings (On); begin Ada.Text_IO.Put_Line ("server : Printing string: « " & CORBA.To_Standard_String (Mesg) & " »"); end PrintString; ---------------- -- EchoString -- ---------------- function EchoString (Self : access Object; Mesg : in CORBA.String) return CORBA.String is pragma Warnings (Off); pragma Unreferenced (Self); pragma Warnings (On); begin Put_Line ("server Echoing string: « " & CORBA.To_Standard_String (Mesg) & " »"); return Mesg; end EchoString; end Echo.Impl; polyorb-2.8~20110207.orig/contrib/local_sockets/test/polyorb-log-ork_serial.adb0000644000175000017500000000204411750740337026721 0ustar xavierxavierwith Kernel.Peripherals; with Kernel.Serial_Output; with PolyORB.Utils.Strings; with PolyORB.Initialization; package body PolyORB.Log.ORK_Serial is -------------- -- Put_Line -- -------------- procedure Put_Line (S : String); procedure Put_Line (S : String) is begin Kernel.Serial_Output.Put_Line (S); end Put_Line; ---------------- -- Initialize -- ---------------- procedure Initialize; procedure Initialize is begin -- Initialize ORK serial line Kernel.Serial_Output.Init_Serial_Line (Kernel.Peripherals.Serial_Port_1); PolyORB.Log.Internals.Log_Hook := Put_Line'Access; end Initialize; use PolyORB.Initialization; use PolyORB.Initialization.String_Lists; use PolyORB.Utils.Strings; begin Register_Module (Module_Info' (Name => +"log.ork", Conflicts => Empty, Depends => Empty, Provides => +"log", Implicit => True, Init => Initialize'Access, Shutdown => null)); end PolyORB.Log.ORK_serial; polyorb-2.8~20110207.orig/contrib/local_sockets/test/ls_setup_ork.adb0000644000175000017500000000705711750740337025046 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- L S _ S E T U P _ O R K -- -- -- -- B o d y -- -- -- -- Copyright (C) 2005 Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with Kernel.Serial_Output; use Kernel.Serial_Output; with Kernel.Peripherals; use Kernel.Peripherals; with Ravenscar_Setup; pragma Warnings (Off, Ravenscar_Setup); pragma Elaborate_All (Ravenscar_Setup); with PolyORB.Log.ORK_Serial; pragma Warnings (Off, PolyORB.Log.ORK_Serial); pragma Elaborate_All (PolyORB.Log.ORK_Serial); with PolyORB.ORB.Thread_Pool; pragma Warnings (Off, PolyORB.ORB.Thread_Pool); pragma Elaborate_All (PolyORB.ORB.Thread_Pool); with PolyORB.ORB_Controller.Workers; pragma Warnings (Off, PolyORB.ORB_Controller.Workers); pragma Elaborate_All (PolyORB.ORB_Controller.Workers); with PolyORB.Setup.OA.Basic_POA; pragma Warnings (Off, PolyORB.Setup.OA.Basic_POA); pragma Elaborate_All (PolyORB.Setup.OA.Basic_POA); with PolyORB.Setup.OA.Basic_POA; pragma Warnings (Off, PolyORB.Setup.OA.Basic_POA); pragma Elaborate_All (PolyORB.Setup.OA.Basic_POA); with PolyORB.Setup.LS; pragma Elaborate_All (PolyORB.Setup.LS); pragma Warnings (Off, PolyORB.Setup.LS); with PolyORB.Setup.Access_Points.LS; pragma Elaborate_All (PolyORB.Setup.Access_Points.LS); pragma Warnings (Off, PolyORB.Setup.Access_Points.LS); with PolyORB.Binding_Data.GIOP.Local_Sockets; pragma Elaborate_All (PolyORB.Binding_Data.GIOP.Local_Sockets); pragma Warnings (Off, PolyORB.Binding_Data.GIOP.Local_Sockets); with PolyORB.Binding_Data.GIOP; pragma Elaborate_All (PolyORB.Binding_Data.GIOP); pragma Warnings (Off, PolyORB.Binding_Data.GIOP); package body LS_Setup_ORK is begin Kernel.Serial_Output.Init_Serial_Line (Kernel.Peripherals.Serial_Port_1); end LS_Setup_ORK; polyorb-2.8~20110207.orig/contrib/local_sockets/test/Makefile0000644000175000017500000000277711750740337023331 0ustar xavierxavierADB =test_client_server.adb OADB=test_client_server_ork.adb EXE= $(patsubst %.adb,%, $(ADB)) ORK_EXE= $(patsubst %.adb,%.ork, $(OADB)) #srcdir= path/to/polyorb/src #ork_srcdir= path/to/polyorb_compiled_for_ORK/src # Need to precise the PolyORB src directory path (put it in srcdir) # ork_srcdir is used if you want to compile for ORK, compile PolyORB # for ORK platforms and initialize this variable with the src # directory of PolyORB compiled for ORK giopdir=$(srcdir)/giop corbadir=$(srcdir)/corba ork_giopdir=$(ork_srcdir)/giop ork_corbadir=$(ork_srcdir)/corba GNATFLAGS = -g -O2 -gnatfy -gnatoa -fstack-check -gnatwa #-a GNATMAKE = gnatmake ORK_GNATMAKE = i386-ork-gnatmake INCLUDE = -I../protocol -I$(srcdir) -I$(giopdir) -I$(corbadir) \ -L$(srcdir)/.libs -L$(giopdir)/.libs -L$(corbadir)/.libs ORK_INCLUDE = -I../protocol \ -I$(ork_srcdir) -I$(ork_giopdir) -I$(ork_corbadir) \ -L$(ork_srcdir)/.libs -L$(ork_giopdir)/.libs -L$(ork_corbadir)/.libs LARGS= ORK_LARGS = -largs -k -specs ork_specs CMD = ${GNATMAKE} ${GNATFLAGS} ${INCLUDE} all: #compile ork_compile @-echo "make compile : Compile for Linux" @-echo "make ork_compile : Compile for ORK" compile :${ADB} echo-skel.ads ${CMD} ${ADB} ${LARGS} ork_compile : echo-skel.ads ${ORK_EXE} %.ork:%.adb ${ORK_GNATMAKE} -o $@ $< ${GNATFLAGS} ${ORK_INCLUDE} ${ORK_LARGS} echo-skel.ads : echo.idl idlac echo.idl force: clean: @-rm -f *.ali *.o *~ b~* *.gz *helper* *skel* *echo.ad* GNAT* distclean: clean @-rm -f $(EXE) ${ORK_EXE} polyorb-2.8~20110207.orig/contrib/local_sockets/test/test_client_server_pkg.ads0000644000175000017500000000434711750740337027121 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- T E S T _ C L I E N T _ S E R V E R _ P K G -- -- -- -- S p e c -- -- -- -- Copyright (C) 2005 Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ package Test_Client_Server_Pkg is pragma Elaborate_Body; procedure Server; procedure Client; type Data is record Str : String (1 .. 1024); Last : Integer; end record; end Test_Client_Server_Pkg; polyorb-2.8~20110207.orig/contrib/local_sockets/test/polyorb.conf0000644000175000017500000000002711750740337024210 0ustar xavierxavier[log] polyorb.ls=debug polyorb-2.8~20110207.orig/contrib/local_sockets/test/ls_setup.ads0000644000175000017500000000410311750740337024201 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- L S _ S E T U P -- -- -- -- S p e c -- -- -- -- Copyright (C) 2005 Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ package LS_Setup is pragma Elaborate_Body; end LS_Setup; polyorb-2.8~20110207.orig/contrib/local_sockets/test/ls_setup_ork.ads0000644000175000017500000000411311750740337025055 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- L S _ S E T U P _ O R K -- -- -- -- S p e c -- -- -- -- Copyright (C) 2005 Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ package LS_Setup_ORK is pragma Elaborate_Body; end LS_Setup_ORK; polyorb-2.8~20110207.orig/contrib/local_sockets/test/polyorb-log-ork_serial.ads0000644000175000017500000000013211750740337026736 0ustar xavierxavierpackage PolyORB.Log.ORK_Serial is pragma Elaborate_Body; end PolyORB.Log.ORK_Serial; polyorb-2.8~20110207.orig/contrib/local_sockets/test/test_client_server_pkg.adb0000644000175000017500000001122311750740337027067 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- T E S T _ C L I E N T _ S E R V E R _ P K G -- -- -- -- B o d y -- -- -- -- Copyright (C) 2005-2007, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with Ada.Real_Time; use Ada.Real_Time; with Echo; with Echo.Impl; with PortableServer.POA.Helper; with PortableServer.POAManager; with CORBA.Impl; with CORBA.Object; with CORBA.ORB; with Ada.Exceptions; package body Test_Client_Server_Pkg is The_IOR : Data; Initialized : Boolean := False; ------------ -- Client -- ------------ procedure Client is Sent_Msg : CORBA.String; begin while not Initialized loop delay until Clock + Milliseconds (100); end loop; -- Getting the CORBA.Object declare myecho : Echo.Ref; begin CORBA.ORB.String_To_Object (CORBA.To_CORBA_String (The_IOR.Str (1 .. The_IOR.Last)), myecho); Put_Line ("Client: Got the reference"); Put_Line (The_IOR.Str (1 .. The_IOR.Last)); -- Checking if it worked if Echo.Is_Nil (myecho) then Put_Line ("main : cannot invoke on a nil reference"); end if; -- Sending message Sent_Msg := CORBA.To_CORBA_String (Standard.String'("Hello Ada !")); Put_Line ("I said : " & CORBA.To_Standard_String (Sent_Msg)); for I in 1 .. 3 loop Put_Line (I'Img); Echo.printString (myecho, Sent_Msg); Put_Line ("print_String is Invoked!"); end loop; end; end Client; ------------ -- Server -- ------------ procedure Server is begin CORBA.ORB.Initialize ("ORB"); Put_Line ("ORB : initialized"); declare Root_POA : PortableServer.POA.Ref; Ref : CORBA.Object.Ref; Obj : constant CORBA.Impl.Object_Ptr := new Echo.Impl.Object; begin -- Retrieve Root POA Root_POA := PortableServer.POA.Helper.To_Local_Ref (CORBA.ORB.Resolve_Initial_References (CORBA.ORB.To_CORBA_String ("RootPOA"))); PortableServer.POAManager.Activate (PortableServer.POA.Get_The_POAManager (Root_POA)); -- Set up new object Ref := PortableServer.POA.Servant_To_Reference (Root_POA, PortableServer.Servant (Obj)); -- Send the IOR declare Tmp : String := CORBA.To_Standard_String (CORBA.Object.Object_To_String (Ref)); begin The_IOR.Last := Tmp'Length; The_IOR.Str (1 .. Tmp'Length) := Tmp (Tmp'First .. Tmp'Last); end; end; Put_Line ("running the ORB"); Initialized := True; CORBA.ORB.Run; end Server; begin null; exception when E : others => Put_Line (Ada.Exceptions.Exception_Information (E)); end Test_Client_Server_Pkg; polyorb-2.8~20110207.orig/contrib/local_sockets/test/test_client_server_ork.adb0000644000175000017500000000515111750740337027104 0ustar xavierxavier----------------------------------------------------------------------------- -- -- -- POLYORB COMPONENTS -- -- -- -- T E S T _ C L I E N T _ S E R V E R -- -- -- -- B o d y -- -- -- -- Copyright (C) 2005 Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with LS_Setup_ORK; pragma Warnings (Off, LS_Setup_ORK); pragma Elaborate_All (LS_Setup_ORK); with PolyORB.Tasking.Threads; with PolyORB.Initialization; with Test_Client_Server_Pkg; use Test_Client_Server_Pkg; with Ada.Real_Time; use Ada.Real_Time; ------------------------ -- Test_Client_Server -- ------------------------ procedure Test_Client_Server is begin PolyORB.Initialization.Initialize_World; PolyORB.Tasking.Threads.Create_Task (Test_Client_Server_Pkg.Server'Access); delay until Clock + Milliseconds (500); PolyORB.Tasking.Threads.Create_Task (Client'Access); end Test_Client_Server; polyorb-2.8~20110207.orig/README0000644000175000017500000001570411750740337015277 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- Copyright (C) 1999-2011, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ This is the README file for PolyORB version @polyorb_version@. The home page of the project is located at http://libre.adacore.com/polyorb/ This is where you can find news about the project, new releases, and pointers to several documents and papers related to PolyORB. What is PolyORB? ---------------- PolyORB is a polymorphic, reusable infrastructure for building object-oriented distributed systems. Middleware environments are software libraries that hide the complex issues of distribution and provide the programmer with high-level abstractions that allow easy and transparent construction of distributed applications. A number of different standards exist for creating object-oriented distributed applications. These standards define two things: * the interface seen by the developer's applicative objects; * the protocol used by the middleware environment to talk to other nodes in the distributed application. Usually, middleware for one platform supports only one set of such interfaces, and cannot interoperate with other platforms. A polymorphic middleware allows the existence of several different implementations of each of these aspects to be used within the same middleware framework. In addition, PolyORB allows such different personalities to coexist in the same instance of the running middleware; it decouples the personality presented to applications on one side ("application personality"), and the personality presented to other middleware on the other side ("protocol personality"). Multiple implementations of each personalisable aspect can coexist within the same instance of the running middleware: unlike previous generic middleware, PolyORB is actually schizophrenic. The decoupling of application and protocol personalities, and the support for multiple simultaneous personalities within the same running middleware are key features required for the construction of interoperable distributed applications. This allows PolyORB to communicate with middleware that implement different distribution standards: PolyORB provides middleware-to-middleware interoperability. The PolyORB architecture also permits the automatic, just-in-time creation of proxies between incompatible environments (although this feature is not implemented yet). PolyORB can be used in Ada 95 and Ada 2005 applications alike. It is implemented in Ada 2005 and C. Installation ------------ See INSTALL file for more details on supported platforms and installation process. Documentation overview ---------------------- README : This file, first instructions. INSTALL : Detail PolyORB installation process. NEWS : Detail updates between PolyORB's releases. Includes listing of new features, fixed bugs and incompatible changes in each release. FEATURES : List PolyORB's features. src/ROADMAP : Overview of PolyORB source code. docs/* : Documents describing PolyORB internals, including PolyORB User's Guide. Usage of PolyORB ---------------- See the PolyORB User's Guide for more details on PolyORB usage. Bug reports ----------- If you find a bug or would like to submit patches, please do so indicating the release you use. We accept patch files. To produce such a patch file, put your files in the PolyORB directory and our files in the directory PolyORB.orig, and use the following command: diff --recursive --context PolyORB.orig PolyORB > patch_file If your diff version do not understand the --recursive or --context option, please use the GNU diffutils package which may be found on any GNU archive (e.g. ftp://ftp.lip6.fr/pub/gnu/). Note that unified diff files (-u option of GNU diff) are also welcomed. Unsupported users may directly send their patches and bug report via e-mail at the address polyorb-bugs@lists.adacore.com or seek community support through the public mailing list: polyorb-users@lists.adacore.com Please use the Problem Report Form in docs/PROBLEM-REPORT-FORM. Please include the complete output of "polyorb-config --version" in any problem report. If you are interested in becoming a supported PolyORB user, you should send an email to sales@adacore.com. Mailing-lists ------------- The mailing-list PolyORB-Users serves as a informal forum for technical discussions about PolyORB among users. You can subscribe to this list and browse the archive at the URL: http://lists.adacore.com/mailman/listinfo/polyorb-users Contributors: ------------- PolyORB has been developed since January, 1999 by the following contributors: * Dmitriy Anisimkov * Nicolas Archambault * Fabien Azavant * Benjamin Bagland * Khaled Barbaria * Nikolay Boshnakov * Reto Buerki * Emmanuel Chavane * Karim Chine * Jean-Marie Cottin * Olivier Delalleau * Cyril Domercq * Robert Duff * Michael Friess * Nicolas Fritsch * Jeremy Gibbons * Vadim Godunko * Jerome Guitton * Jerome Hugues * Mejdi Kaddour * Fabrice Kordon * Narinder Kumar * Laurent Kubler * Stéphane Lanarre * Lionel Litty * Vincent Niebel * Pascal Obry * Pablo Oliveira * Pierre Palatin * Bertrand Paquet * Laurent Pautet * Sebastien Ponce * Thomas Quinot * Nicolas Roche * Jerome Roussel * Selvaratnam Senthuran * Nicolas Setton * Frank Singhoff * Samuel Tardieu * Santiago Urueña-Pascual * Thomas Vergnaud * Florian Villoing * Guillaume Wisniewski * Thomas Wolf * Bechir Zalila polyorb-2.8~20110207.orig/features-230000644000175000017500000000676211750740337016406 0ustar xavierxavier======================================================== PolyORB 2.3 NEW FEATURES LIST Current as of Aug 03, 2007 ======================================================== Copyright (c) 2007, AdaCore This file contains a complete list of new features in version 2.3 of PolyORB. See also file NEWS for various information about this release. An ISO date (YYYY-MM-DD) appears in parentheses after the description line. This date shows the implementation date of the feature. Any 2.3w wavefront subsequent to this date will contain the indicated feature, as will any subsequent releases. NF-23-G803-009 Official OMG tags assigned to PolyORB (2007-08-02) PolyORB has received official OMG profile tags, service tags, component IDs, vendor minor code IDs and ORB type IDs from the OMG. Note that users who rely on PolyORB-specific features across partitions in an application (including all users of the DSA application personality) will have to upgrade all partitions at the same time so that they use a consistent set of tags. NF-23-G627-011 Remove unused libraries from polyorb-config output (2007-03-14) The implementation libraries for CORBA Common Object Services, libpolyorb-corba-cos-*-impl, are usually not needed in user applications (only the client stubs are). They have therefore been removed from the command line produced by the polyorb-config utility. Applications that use these libraries now need to have explicit linker arguments for them. NF-23-G405-030 Improved representation of union typecodes (2007-07-09) The internal representation of union typecodes has been improved. Its memory footprint has been reduced, and the marshalling and unmarshalling of unions are now more efficient. NF-23-G329-021 Setting default log level (2007-03-29) A default log level setting can now be specified in the PolyORB runtime configuration (polyorb.conf, command line, or environment), which is applied to all facilities for which an explicit log level has not been provided. NF-23-G214-008 Implementation of OMG Issue 5232 (2007-02-14) The OMG deprecated the use of anonymous type in IDL, but did not update CORBA IDL files. The issue 5232 has been filed by the OMG to fix this issue, and is now implemented in PolyORB. As a consequence, the following IDL files have been updated: idls/Interop/CONV_FRAME.idl and idls/Interop/IOP.idl. Any user code that depends on these IDL specifications might require an update. NF-23-G130-013 Extended syntax for port binding parameters (2007-01-31) The configuration parameters indicating what port a server should bind to have now an extended syntax. If a single port number is specified, only that precise value will be used. If the port is already bound by another process, partition startup will fail. If a port range of the form "NNNN-MMMM" is specified, the ORB will iterate over the range until an available port is found. Note that the default behaviour for a single port number specification has changed, since we used to always iterate until an available port was found. The new syntax allows explicit control over this behaviour. This provides a means of ensuring that a server does not unexpectedly bind to a different port than the one specified in runtime configuration parameters. NF-23-FC18-009 No C++ compiler is required with recent GNAT (2007-04-26) New versions of the GNAT compiler now provide an IDL preprocessor. When this feature is present, no external C++ compiler is required to process OMG IDL files. polyorb-2.8~20110207.orig/ANNOUNCE0000644000175000017500000002534411750740337015551 0ustar xavierxavierAnnouncing the release of PolyORB 2.0r ====================================== The PolyORB team is proud to announce the release of PolyORB 2.0r (http://polyorb.objectweb.org/ and http://libre.adacore.com/polyorb/). This new major release of PolyORB comes as the conclusion of a series of extensive reviews and reorganisations of the middleware components, improving the architecture's performances and flexibility. Development has taken place in both the generic core and the various application and protocol personalities. This release contains the PolyORB generic middleware and its CORBA and MOMA instances. In addition to the 1.x branch, it includes: * extended support for CORBA and GIOP specifications: bounded strings, SSLIOP, DynamicAny, RT-CORBA 1.x; * reduction of the memory footprint and increased performance. The architecture has also been reviewed and reorganized, leading to the following enhancements: * support for multiple scheduling policies (Thread Pool, Leader/Followers, Half Sync/Half Async patterns), * better modularity of the code, allowing for precise tuning of the architecture to support new distribution mechanisms and Quality of Service (QoS) policies (e.g. RT-CORBA, SSLIOP), * the core of PolyORB has been formally modelled, several configurations have been formally verified, providing increasing confidence in the code, * the determinism of the RT-CORBA implementation has been validated on Solaris (using TCP/IP), and ORK and MarTE OS (protocol-less tests). See the NEWS file for an exhaustive list of changes. Other instantiations of PolyORB are available in the public PolyORB repository for testing purposes. Available instantiations include DSA (Distributed System Annex) and AWS (Ada Web Server). PolyORB is primarily developed by Jérôme Hugues, Thomas Vergnaud, Khaled Barbaria and Laurent Pautet (Télécom Paris), and Thomas Quinot (AdaCore). Fabrice Kordon (LIP6) also participates in the project. Vadim Godunko regularly contributes by submitting patches. ---------------------------------------------------------------------- Announcing the release of PolyORB 1.2r ====================================== The PolyORB team is proud to announce the release of PolyORB 1.2r (http://polyorb.objectweb.org/ and http://libre.adacore.com/polyorb/). This release contains a CORBA-compliant instantiation of the PolyORB generic middleware. This release is not supported by AdaCore. Release 1.2r is a stable snapshot of the PolyORB generic middleware implementing the new features described below. In addition to PolyORB 1.1r (2004-06-07), it includes: * extended support for CORBA and GIOP specifications, * support for CORBA PortableInterceptors, * support for RT-CORBA 1.1, * fixes for several bugs and memory leaks, * new personality: MOMA, the Message Oriented Middleware for Ada Other instantiations of PolyORB are available in the public PolyORB CVS repository for testing purposes. Available instantiations include DSA (Distributed System Annex) and AWS (Ada Web Server). PolyORB is primarily developed by Jérôme Hugues, Thomas Vergnaud, Khaled Barbaria and Laurent Pautet (Télécom Paris), and Thomas Quinot (AdaCore). Fabrice Kordon (LIP6) also participates in the project. Vadim Godunko regularly contributes by submitting patches. ---------------------------------------------------------------------- Announcing the release of PolyORB 1.1r ====================================== The PolyORB team is proud to announce the release of PolyORB 1.1r (http://libre.act-europe.fr/polyorb/). This release contains a CORBA-compliant instantiation of the PolyORB generic middleware. This release is not supported by ACT. Release 1.1r is a stable snapshot of the PolyORB generic middleware implementing the new features described below. In addition to PolyORB 1.0p (2003-06-16), it includes: * a significant increase in performance: from 30% up to 40% depending on the configuration, * fixes for several bugs and memory leaks, * extended support for CORBA and GIOP specifications, * the PolyORB User's Guide, * the MIOP/UIPMC protocol stack, Unreliable Multicast Inter-ORB Protocol, following the OMG standard, * the DIOP protocol stack, Datagram-based Inter-ORB Protocol, a specialization of GIOP for oneway requests, Other instantiations of PolyORB are available in the public PolyORB CVS repository for testing purposes. Available instantiations include DSA (Distributed System Annex), MOMA (Message Oriented Middleware for Ada) and AWS (Ada Web Server). PolyORB is primarily developed by Jérôme Hugues, Thomas Vergnaud, and Laurent Pautet (Télécom Paris), and Thomas Quinot (ACT Europe). Fabrice Kordon (LIP6) also participates in the project. Vadim Godunko regularly contributes by submitting patches. ---------------------------------------------------------------------- Announcing the release of PolyORB 1.0p ====================================== Ada Core Technologies, ACT Europe, and the PolyORB team are proud to announce the first public release of PolyORB: PolyORB 1.0p (http://libre.adacore.com/polyorb/). This release contains a CORBA-compliant instantiation of the PolyORB generic middleware. It includes: * an IDL to Ada 95 compiler, * implementations of the Portable Object Adapter (POA), Dynamic Skeleton Interface (DSI), Dynamic Invocation Interface (DII), and Interface Repository (IR), * implementations of the COS Naming, COS Event and COS Time services, * implementations of GIOP 1.0, 1.1, and 1.2. This CORBA implementation can be configured for full tasking, Ravenscar tasking or no tasking runtime, depending on the level of desired functionality for the application, and on the resource constraints for the target. This release should be considered as a stable implementation of CORBA middleware over PolyORB. Other instantiations of PolyORB are available in the public PolyORB CVS repository for testing purposes. They will be included in future releases. PolyORB is primarily developed by Jérôme Hugues, Thomas Vergnaud, and Laurent Pautet (Télécom Paris), and Thomas Quinot (ACT Europe). Fabrice Kordon (LIP6) also participates in the project. ---------------------------------------------------------------------- POLYORB Distributed applications and middleware --------------------------------------- PolyORB aims at providing a uniform solution to build distributed applications; relying either on industrial-strength middleware standards such as CORBA, the Distributed System Annex of Ada 95, distribution programming paradigms such as Web Services, Message Oriented Middleware (MOM), or to implement application-specific middleware. Middleware provides a framework that hides the complex issues of distribution, and offers the programmer high-level abstractions that allow easy and transparent construction of distributed applications. A number of different standards exist for creating object-oriented distributed applications. These standards define two subsystems that enable interaction between application partitions: * the API seen by the developer's applicative objects; * the protocol used by the middleware environment to interact with other nodes in the distributed application. Middleware implementations also offer programming guidelines as well as development tools to ease the construction of large heterogeneous distributed systems. Many issues typical to distributed programming may still arise: application architectural choice, configuration or deployment. Since there is no "one size fits all" architecture, choosing the adequate distribution middleware in its most appropriate configuration is a key design point that dramatically impacts the design and performance of an application. Consequently, applications need to rapidly tailor middleware to the specific distribution model they require. A distribution model is defined by the combination of distribution mechanisms made available to the application. Common examples of such mechanisms are Remote Procedure Call (RPC), Distributed Objects or Message Passing. A distribution infrastructure or middleware refers to software that supports one (or several) distribution model, e.g.: OMG CORBA, Java Remote Method Invocation (RMI), the Distributed System Annex of Ada 95, Java Message Service (MOM). PolyORB: a generic middleware with an instance per distribution model --------------------------------------------------------------------- Typical middleware implementations for one platform support only one set of such interfaces, pre-defined configuration capabilities and cannot interoperate with other platforms. In addition to traditional middleware implementations, PolyORB proposes an original architecture to enable support for multiple interoperating distribution models in a uniform canvas. PolyORB is a polymorphic, reusable infrastructure for building or prototyping new middleware adapted to specific application needs. It provides a set of components on top of which various instances can be elaborated. These instances (or personalities) are views on PolyORB facilities that are compliant to existing standards, either at the API level (application personality) or at the protocol level (protocol personality). These personalities are mutually exclusive views of the same architecture. The decoupling of application and protocol personalities, and the support for multiple simultaneous personalities within the same running middleware, are key features required for the construction of interoperable distributed applications. This allows PolyORB to communicate with middleware that implement different distribution standards: PolyORB provides middleware-to-middleware interoperability (M2M). PolyORB's modularity allows for easy extension and replacement of its core and personality components, in order to meet specific requirements. In this way, standard or application-specific personalities can be created in a streamlined process, from early stage prototyping to full-featured implementation. The PolyORB architecture also allows the automatic, just-in-time creation of proxies between incompatible environments. PolyORB currently supports the following personalities (in the main development branch, available through CVS access): * application personalities: CORBA, Distributed System Annex of Ada 95 (DSA), MOMA - MOM for Ada. Interaction between CORBA and DSA partitions has been successfully tested; * protocol personalities: SOAP, GIOP (CORBA generic protocol layer) and the following instantiations: IIOP (over TCP/IP), DIOP (over UDP/IP for oneway requests), and MIOP/UIPMC (group communication over multicast/IP) * under development: Web Services personality, an adaptation of the AWS API to PolyORB. Note: PolyORB is the project formerly known as DROOPI, a Distributed Reusable Object-Oriented Polymorphic Infrastructure. polyorb-2.8~20110207.orig/examples/0000755000175000017500000000000011750740340016220 5ustar xavierxavierpolyorb-2.8~20110207.orig/examples/corba/0000755000175000017500000000000011750740340017306 5ustar xavierxavierpolyorb-2.8~20110207.orig/examples/corba/all_types/0000755000175000017500000000000011750740340021302 5ustar xavierxavierpolyorb-2.8~20110207.orig/examples/corba/all_types/README0000644000175000017500000000266611750740337022202 0ustar xavierxavierREADME for the PolyORB all_types example ---------------------------------------- $Id: README 33963 2002-11-06 22:38:19Z quinot $ This demo tests marshalling unmarshalling functions. Three executables are provided - server : a CORBA server application, provides echo functions where types are CORBA defined types. - client : a CORBA client application, built to interact with 'server', test all CORBA types. - client_moma : a MOMA client application, built to interact with 'server'. It tests string type. It is a demonstration of ORB/MOM interoperability. * To run these tests : 1) client/server test : - launch server - launch client using the IOR string output by server as an argument The client will interact with the server, doing several tests. The different results are displayed on the client side. 2) client_moma/server test: - launch 'server' - launch a MOMA message_pool node, for example example/moma/server - launch 'client_moma' using the IOR string output by the all_types server as first argument, IOR string output by MOMA message_pool node as second argument Here is the demo scenario : - 'client_moma' will first build a MExecute message - 'client_moma' sends it to the server as an RPC - 'server' will send the response back to 'client_moma' - a call back component will bounce the response to the message_pool If the MOMA node is set to persistent, the received messages will be stored into different files. polyorb-2.8~20110207.orig/examples/corba/all_types/Makefile.local0000644000175000017500000000015011750740337024035 0ustar xavierxavier${current_dir}all_types.idl-stamp: idlac_flags := -ir ${test_target}: ${current_dir}all_types.idl-stamp polyorb-2.8~20110207.orig/examples/corba/all_types/client_moma.adb0000644000175000017500000001062111750740337024247 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- C L I E N T _ M O M A -- -- -- -- B o d y -- -- -- -- Copyright (C) 2002-2004 Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by ACT Europe. -- -- (email: sales@act-europe.fr) -- -- -- ------------------------------------------------------------------------------ -- Testing MOMA client, interaction with ORB server 'all_types'. with Ada.Command_Line; with Ada.Text_IO; with PolyORB.Initialization; with PolyORB.Setup.Thread_Pool_Server; pragma Warnings (Off, PolyORB.Setup.Thread_Pool_Server); -- XXX this package should be renamed to PolyORB.Setup.Thread_Pool_Node ... with MOMA.Message_Producers; with MOMA.Messages; with MOMA.Messages.MExecutes; with MOMA.Types; procedure Client_MOMA is use Ada.Command_Line; use Ada.Text_IO; use MOMA.Message_Producers; use MOMA.Messages; use MOMA.Messages.MExecutes; use MOMA.Types; MOMA2ORB_Producer : MOMA.Message_Producers.Message_Producer; -------------------------- -- Execute Message Test -- -------------------------- procedure Test_MExecute; procedure Test_MExecute is MExecute_Message_Sent : MOMA.Messages.MExecutes.MExecute; Method_Name : Map_Element; Return_1 : Map_Element; Arg_1 : Map_Element; Parameter_Map : Map; begin -- Create new Text Message Put_Line ("Formatting message."); MExecute_Message_Sent := Create_Execute_Message; Method_Name := (Name => To_MOMA_String ("method"), Value => To_Any (To_MOMA_String ("echoString"))); Return_1 := (Name => To_MOMA_String ("return_1"), Value => To_Any (To_MOMA_String (""))); Arg_1 := (Name => To_MOMA_String ("arg_1"), Value => To_Any (To_MOMA_String ("Hi Mom !"))); Append (Parameter_Map, Method_Name); Append (Parameter_Map, Return_1); Append (Parameter_Map, Arg_1); Set_Parameter (MExecute_Message_Sent, Parameter_Map); Put_Line ("Sending message."); Send (MOMA2ORB_Producer, MExecute_Message_Sent); Put_Line ("Message sent."); end Test_MExecute; -------------------- -- Main procedure -- -------------------- begin PolyORB.Initialization.Initialize_World; -- Argument check. if Argument_Count /= 2 then Put_Line ("usage : client_moma \"); Put_Line (" "); return; end if; -- Create Message Producer associated to the ORB object. MOMA2ORB_Producer := Create_Producer (To_MOMA_String (Argument (1)), To_MOMA_String (Argument (2))); -- Testing MExecute. Test_MExecute; end Client_MOMA; polyorb-2.8~20110207.orig/examples/corba/all_types/dynclient.adb0000644000175000017500000014717511750740337023770 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- D Y N C L I E N T -- -- -- -- B o d y -- -- -- -- Copyright (C) 2002-2005 Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- all_types dynamic client pragma Style_Checks (Off); with Ada.Command_Line; with Ada.Text_IO; with CORBA; use CORBA; with CORBA.Object; with CORBA.Object.Helper; with CORBA.Context; with CORBA.Request; with CORBA.NVList; with CORBA.ContextList; with CORBA.ExceptionList; with CORBA.ORB; with PolyORB.Utils.Report; with all_types; use all_types; with all_types.Helper; with PolyORB.CORBA_P.Naming_Tools; use PolyORB.CORBA_P.Naming_Tools; with PolyORB.Setup.Client; pragma Warnings (Off, PolyORB.Setup.Client); procedure DynClient is use PolyORB.Utils.Report; pragma Warnings (Off); Myall_Types : CORBA.Object.Ref; One_Shot : constant Boolean := Ada.Command_Line.Argument_Count /= 2 or else Boolean'Value (Ada.Command_Line.Argument (2)); ----------------- -- EchoBoolean -- ----------------- function EchoBoolean (Self : CORBA.Object.Ref; Arg : CORBA.Boolean) return CORBA.Boolean is Operation_Name : CORBA.Identifier := To_CORBA_String ("echoBoolean"); Arg_Name : CORBA.Identifier := To_CORBA_String ("arg"); Request : CORBA.Request.Object; Ctx : constant CORBA.Context.Ref := CORBA.Context.Nil_Ref; Arg_List : CORBA.NVList.Ref; Result_Name : CORBA.String := To_CORBA_String ("Result"); Result : CORBA.NamedValue; begin -- creating the argument list CORBA.ORB.Create_List (0, Arg_List); CORBA.NVList.Add_Item (Arg_List, Arg_Name, To_Any (Arg), CORBA.ARG_IN); -- setting the result type Result := (Name => Identifier (Result_Name), Argument => Internals.Get_Empty_Any (CORBA.TC_Boolean), Arg_Modes => 0); -- creating a request CORBA.Object.Create_Request (Self, Ctx, Operation_Name, Arg_List, Result, Request, 0); -- sending message CORBA.Request.Invoke (Request, 0); -- getting the answer return From_Any (Result.Argument); end EchoBoolean; --------------- -- EchoShort -- --------------- function EchoShort (Self : CORBA.Object.Ref; Arg : CORBA.Short) return CORBA.Short is Operation_Name : CORBA.Identifier := To_CORBA_String ("echoShort"); Arg_Name : CORBA.Identifier := To_CORBA_String ("arg"); Request : CORBA.Request.Object; Ctx : constant CORBA.Context.Ref := CORBA.Context.Nil_Ref; Argument : CORBA.Any; Arg_List : CORBA.NVList.Ref; Result : CORBA.NamedValue; Result_Name : CORBA.String := To_CORBA_String ("Result"); begin -- creating the argument list CORBA.ORB.Create_List (0, Arg_List); Argument := CORBA.To_Any (Arg); CORBA.NVList.Add_Item (Arg_List, Arg_Name, Argument, CORBA.ARG_IN); -- setting the result type Result := (Name => Identifier (Result_Name), Argument => Internals.Get_Empty_Any (CORBA.TC_Short), Arg_Modes => 0); -- creating a request CORBA.Object.Create_Request (Self, Ctx, Operation_Name, Arg_List, Result, Request, 0); -- sending message CORBA.Request.Invoke (Request, 0); -- getting the answer return From_Any (Result.Argument); end EchoShort; -------------- -- EchoLong -- -------------- function EchoLong (Self : CORBA.Object.Ref; Arg : CORBA.Long) return CORBA.Long is Operation_Name : CORBA.Identifier := To_CORBA_String ("echoLong"); Arg_Name : CORBA.Identifier := To_CORBA_String ("arg"); Request : CORBA.Request.Object; Ctx : constant CORBA.Context.Ref := CORBA.Context.Nil_Ref; Argument : CORBA.Any; Arg_List : CORBA.NVList.Ref; Result : CORBA.NamedValue; Result_Name : CORBA.String := To_CORBA_String ("Result"); begin -- creating the argument list CORBA.ORB.Create_List (0, Arg_List); Argument := CORBA.To_Any (Arg); CORBA.NVList.Add_Item (Arg_List, Arg_Name, Argument, CORBA.ARG_IN); -- setting the result type Result := (Name => Identifier (Result_Name), Argument => Internals.Get_Empty_Any (CORBA.TC_Long), Arg_Modes => 0); -- creating a request CORBA.Object.Create_Request (Self, Ctx, Operation_Name, Arg_List, Result, Request, 0); -- sending message CORBA.Request.Invoke (Request, 0); -- getting the answer return From_Any (Result.Argument); end EchoLong; ---------------- -- EchoUShort -- ---------------- function EchoUShort (Self : CORBA.Object.Ref; Arg : CORBA.Unsigned_Short) return CORBA.Unsigned_Short is Operation_Name : CORBA.Identifier := To_CORBA_String ("echoUShort"); Arg_Name : CORBA.Identifier := To_CORBA_String ("arg"); Request : CORBA.Request.Object; Ctx : constant CORBA.Context.Ref := CORBA.Context.Nil_Ref; Argument : CORBA.Any; Arg_List : CORBA.NVList.Ref; Result : CORBA.NamedValue; Result_Name : CORBA.String := To_CORBA_String ("Result"); begin -- creating the argument list CORBA.ORB.Create_List (0, Arg_List); Argument := CORBA.To_Any (Arg); CORBA.NVList.Add_Item (Arg_List, Arg_Name, Argument, CORBA.ARG_IN); -- setting the result type Result := (Name => Identifier (Result_Name), Argument => Internals.Get_Empty_Any (CORBA.TC_Unsigned_Short), Arg_Modes => 0); -- creating a request CORBA.Object.Create_Request (Self, Ctx, Operation_Name, Arg_List, Result, Request, 0); -- sending message CORBA.Request.Invoke (Request, 0); -- getting the answer return From_Any (Result.Argument); end EchoUShort; --------------- -- EchoULong -- --------------- function EchoULong (Self : CORBA.Object.Ref; Arg : CORBA.Unsigned_Long) return CORBA.Unsigned_Long is Operation_Name : CORBA.Identifier := To_CORBA_String ("echoULong"); Arg_Name : CORBA.Identifier := To_CORBA_String ("arg"); Request : CORBA.Request.Object; Ctx : constant CORBA.Context.Ref := CORBA.Context.Nil_Ref; Argument : CORBA.Any; Arg_List : CORBA.NVList.Ref; Result : CORBA.NamedValue; Result_Name : CORBA.String := To_CORBA_String ("Result"); begin -- creating the argument list CORBA.ORB.Create_List (0, Arg_List); Argument := CORBA.To_Any (Arg); CORBA.NVList.Add_Item (Arg_List, Arg_Name, Argument, CORBA.ARG_IN); -- setting the result type Result := (Name => Identifier (Result_Name), Argument => Internals.Get_Empty_Any (CORBA.TC_Unsigned_Long), Arg_Modes => 0); -- creating a request CORBA.Object.Create_Request (Self, Ctx, Operation_Name, Arg_List, Result, Request, 0); -- sending message CORBA.Request.Invoke (Request, 0); -- getting the answer return From_Any (Result.Argument); end EchoULong; --------------- -- EchoFloat -- --------------- function EchoFloat (Self : CORBA.Object.Ref; Arg : CORBA.Float) return CORBA.Float is Operation_Name : CORBA.Identifier := To_CORBA_String ("echoFloat"); Arg_Name : CORBA.Identifier := To_CORBA_String ("arg"); Request : CORBA.Request.Object; Ctx : constant CORBA.Context.Ref := CORBA.Context.Nil_Ref; Argument : CORBA.Any; Arg_List : CORBA.NVList.Ref; Result : CORBA.NamedValue; Result_Name : CORBA.String := To_CORBA_String ("Result"); begin -- creating the argument list CORBA.ORB.Create_List (0, Arg_List); Argument := CORBA.To_Any (Arg); CORBA.NVList.Add_Item (Arg_List, Arg_Name, Argument, CORBA.ARG_IN); -- setting the result type Result := (Name => Identifier (Result_Name), Argument => Internals.Get_Empty_Any (CORBA.TC_Float), Arg_Modes => 0); -- creating a request CORBA.Object.Create_Request (Self, Ctx, Operation_Name, Arg_List, Result, Request, 0); -- sending message CORBA.Request.Invoke (Request, 0); -- getting the answer return From_Any (Result.Argument); end EchoFloat; ---------------- -- EchoDouble -- ---------------- function EchoDouble (Self : CORBA.Object.Ref; Arg : CORBA.Double) return CORBA.Double is Operation_Name : CORBA.Identifier := To_CORBA_String ("echoDouble"); Arg_Name : CORBA.Identifier := To_CORBA_String ("arg"); Request : CORBA.Request.Object; Ctx : constant CORBA.Context.Ref := CORBA.Context.Nil_Ref; Argument : CORBA.Any; Arg_List : CORBA.NVList.Ref; Result : CORBA.NamedValue; Result_Name : CORBA.String := To_CORBA_String ("Result"); begin -- creating the argument list CORBA.ORB.Create_List (0, Arg_List); Argument := CORBA.To_Any (Arg); CORBA.NVList.Add_Item (Arg_List, Arg_Name, Argument, CORBA.ARG_IN); -- setting the result type Result := (Name => Identifier (Result_Name), Argument => Internals.Get_Empty_Any (CORBA.TC_Double), Arg_Modes => 0); -- creating a request CORBA.Object.Create_Request (Self, Ctx, Operation_Name, Arg_List, Result, Request, 0); -- sending message CORBA.Request.Invoke (Request, 0); -- getting the answer return From_Any (Result.Argument); end EchoDouble; -------------- -- EchoChar -- -------------- function EchoChar (Self : CORBA.Object.Ref; Arg : CORBA.Char) return CORBA.Char is Operation_Name : CORBA.Identifier := To_CORBA_String ("echoChar"); Arg_Name : CORBA.Identifier := To_CORBA_String ("arg"); Request : CORBA.Request.Object; Ctx : constant CORBA.Context.Ref := CORBA.Context.Nil_Ref; Argument : CORBA.Any; Arg_List : CORBA.NVList.Ref; Result : CORBA.NamedValue; Result_Name : CORBA.String := To_CORBA_String ("Result"); begin -- creating the argument list CORBA.ORB.Create_List (0, Arg_List); Argument := CORBA.To_Any (Arg); CORBA.NVList.Add_Item (Arg_List, Arg_Name, Argument, CORBA.ARG_IN); -- setting the result type Result := (Name => Identifier (Result_Name), Argument => Internals.Get_Empty_Any (CORBA.TC_Char), Arg_Modes => 0); -- creating a request CORBA.Object.Create_Request (Self, Ctx, Operation_Name, Arg_List, Result, Request, 0); -- sending message CORBA.Request.Invoke (Request, 0); -- getting the answer return From_Any (Result.Argument); end EchoChar; --------------- -- EchoOctet -- --------------- function EchoOctet (Self : CORBA.Object.Ref; Arg : CORBA.Octet) return CORBA.Octet is Operation_Name : CORBA.Identifier := To_CORBA_String ("echoOctet"); Arg_Name : CORBA.Identifier := To_CORBA_String ("arg"); Request : CORBA.Request.Object; Ctx : constant CORBA.Context.Ref := CORBA.Context.Nil_Ref; Argument : CORBA.Any; Arg_List : CORBA.NVList.Ref; Result : CORBA.NamedValue; Result_Name : CORBA.String := To_CORBA_String ("Result"); begin -- creating the argument list CORBA.ORB.Create_List (0, Arg_List); Argument := CORBA.To_Any (Arg); CORBA.NVList.Add_Item (Arg_List, Arg_Name, Argument, CORBA.ARG_IN); -- setting the result type Result := (Name => Identifier (Result_Name), Argument => Internals.Get_Empty_Any (CORBA.TC_Octet), Arg_Modes => 0); -- creating a request CORBA.Object.Create_Request (Self, Ctx, Operation_Name, Arg_List, Result, Request, 0); -- sending message CORBA.Request.Invoke (Request, 0); -- getting the answer return From_Any (Result.Argument); end EchoOctet; ---------------- -- EchoString -- ---------------- function EchoString (Self : CORBA.Object.Ref; Arg : CORBA.String) return CORBA.String is Operation_Name : CORBA.Identifier := To_CORBA_String ("echoString"); Arg_Name : CORBA.Identifier := To_CORBA_String ("arg"); Request : CORBA.Request.Object; Ctx : constant CORBA.Context.Ref := CORBA.Context.Nil_Ref; Argument : CORBA.Any; Arg_List : CORBA.NVList.Ref; Result : CORBA.NamedValue; Result_Name : CORBA.String := To_CORBA_String ("Result"); begin -- creating the argument list CORBA.ORB.Create_List (0, Arg_List); Argument := CORBA.To_Any (Arg); CORBA.NVList.Add_Item (Arg_List, Arg_Name, Argument, CORBA.ARG_IN); -- setting the result type Result := (Name => Identifier (Result_Name), Argument => Internals.Get_Empty_Any (CORBA.TC_String), Arg_Modes => 0); -- creating a request CORBA.Object.Create_Request (Self, Ctx, Operation_Name, Arg_List, Result, Request, 0); -- sending message CORBA.Request.Invoke (Request, 0); -- getting the answer return From_Any (Result.Argument); end EchoString; ------------- -- EchoRef -- ------------- function EchoRef (Self : CORBA.Object.Ref; Arg : CORBA.Object.Ref) return CORBA.Object.Ref is Operation_Name : CORBA.Identifier := To_CORBA_String ("echoRef"); Arg_Name : CORBA.Identifier := To_CORBA_String ("arg"); Request : CORBA.Request.Object; Ctx : constant CORBA.Context.Ref := CORBA.Context.Nil_Ref; Argument : CORBA.Any; Arg_List : CORBA.NVList.Ref; Result : CORBA.NamedValue; Result_Name : CORBA.String := To_CORBA_String ("Result"); begin -- creating the argument list CORBA.ORB.Create_List (0, Arg_List); Argument := CORBA.Object.Helper.To_Any (Arg); CORBA.NVList.Add_Item (Arg_List, Arg_Name, Argument, CORBA.ARG_IN); -- setting the result type Result := (Name => Identifier (Result_Name), Argument => Internals.Get_Empty_Any (CORBA.Object.Helper.TC_Object), Arg_Modes => 0); -- creating a request CORBA.Object.Create_Request (Self, Ctx, Operation_Name, Arg_List, Result, Request, 0); -- sending message CORBA.Request.Invoke (Request, 0); -- getting the answer return CORBA.Object.Helper.From_Any (Result.Argument); end EchoRef; --------------- -- EchoColor -- --------------- function EchoColor (Self : CORBA.Object.Ref; Arg : all_types.Color) return all_types.Color is Operation_Name : CORBA.Identifier := To_CORBA_String ("echoColor"); Arg_Name : CORBA.Identifier := To_CORBA_String ("arg"); Request : CORBA.Request.Object; Ctx : constant CORBA.Context.Ref := CORBA.Context.Nil_Ref; Argument : CORBA.Any; Arg_List : CORBA.NVList.Ref; Result : CORBA.NamedValue; Result_Name : CORBA.String := To_CORBA_String ("Result"); begin -- creating the argument list CORBA.ORB.Create_List (0, Arg_List); Argument := all_types.Helper.To_Any (Arg); CORBA.NVList.Add_Item (Arg_List, Arg_Name, Argument, CORBA.ARG_IN); -- setting the result type Result := (Name => Identifier (Result_Name), Argument => Internals.Get_Empty_Any (all_types.Helper.TC_Color), Arg_Modes => 0); -- creating a request CORBA.Object.Create_Request (Self, Ctx, Operation_Name, Arg_List, Result, Request, 0); -- sending message CORBA.Request.Invoke (Request, 0); -- getting the answer return all_types.Helper.From_Any (Result.Argument); end EchoColor; --------------- -- EchoMoney -- --------------- function EchoMoney (Self : CORBA.Object.Ref; Arg : all_types.Money) return all_types.Money is Operation_Name : CORBA.Identifier := To_CORBA_String ("echoMoney"); Arg_Name : CORBA.Identifier := To_CORBA_String ("arg"); Request : CORBA.Request.Object; Ctx : constant CORBA.Context.Ref := CORBA.Context.Nil_Ref; Argument : CORBA.Any; Arg_List : CORBA.NVList.Ref; Result : CORBA.NamedValue; Result_Name : CORBA.String := To_CORBA_String ("Result"); begin -- creating the argument list CORBA.ORB.Create_List (0, Arg_List); Argument := all_types.Helper.To_Any (Arg); CORBA.NVList.Add_Item (Arg_List, Arg_Name, Argument, CORBA.ARG_IN); -- setting the result type Result := (Name => Identifier (Result_Name), Argument => Internals.Get_Empty_Any (all_types.Helper.TC_Money), Arg_Modes => 0); -- creating a request CORBA.Object.Create_Request (Self, Ctx, Operation_Name, Arg_List, Result, Request, 0); -- sending message CORBA.Request.Invoke (Request, 0); -- getting the answer return all_types.Helper.From_Any (Result.Argument); end EchoMoney; --------------- -- EchoArray -- --------------- function EchoArray (Self : CORBA.Object.Ref; Arg : all_types.Simple_Array) return all_types.Simple_Array is Operation_Name : CORBA.Identifier := To_CORBA_String ("echoArray"); Arg_Name : CORBA.Identifier := To_CORBA_String ("arg"); Request : CORBA.Request.Object; Ctx : constant CORBA.Context.Ref := CORBA.Context.Nil_Ref; Argument : CORBA.Any; Arg_List : CORBA.NVList.Ref; Result : CORBA.NamedValue; Result_Name : CORBA.String := To_CORBA_String ("Result"); begin -- creating the argument list CORBA.ORB.Create_List (0, Arg_List); Argument := all_types.Helper.To_Any (Arg); CORBA.NVList.Add_Item (Arg_List, Arg_Name, Argument, CORBA.ARG_IN); -- setting the result type Result := (Name => Identifier (Result_Name), Argument => Internals.Get_Empty_Any (all_types.Helper.TC_Simple_Array), Arg_Modes => 0); -- creating a request CORBA.Object.Create_Request (Self, Ctx, Operation_Name, Arg_List, Result, Request, 0); -- sending message CORBA.Request.Invoke (Request, 0); -- getting the answer return all_types.Helper.From_Any (Result.Argument); end EchoArray; ---------------- -- EchoMatrix -- ---------------- function EchoMatrix (Self : CORBA.Object.Ref; Arg : all_types.Matrix) return all_types.Matrix is Operation_Name : CORBA.Identifier := To_CORBA_String ("echoMatrix"); Arg_Name : CORBA.Identifier := To_CORBA_String ("arg"); Request : CORBA.Request.Object; Ctx : constant CORBA.Context.Ref := CORBA.Context.Nil_Ref; Argument : CORBA.Any; Arg_List : CORBA.NVList.Ref; Result : CORBA.NamedValue; Result_Name : CORBA.String := To_CORBA_String ("Result"); begin -- creating the argument list CORBA.ORB.Create_List (0, Arg_List); Argument := all_types.Helper.To_Any (Arg); CORBA.NVList.Add_Item (Arg_List, Arg_Name, Argument, CORBA.ARG_IN); -- setting the result type Result := (Name => Identifier (Result_Name), Argument => Internals.Get_Empty_Any (all_types.Helper.TC_Matrix), Arg_Modes => 0); -- creating a request CORBA.Object.Create_Request (Self, Ctx, Operation_Name, Arg_List, Result, Request, 0); -- sending message CORBA.Request.Invoke (Request, 0); -- getting the answer return all_types.Helper.From_Any (Result.Argument); end EchoMatrix; ------------------- -- EchoBigMatrix -- ------------------- function EchoBigMatrix (Self : CORBA.Object.Ref; Arg : all_types.BigMatrix) return all_types.BigMatrix is Operation_Name : CORBA.Identifier := To_CORBA_String ("echoBigMatrix"); Arg_Name : CORBA.Identifier := To_CORBA_String ("arg"); Request : CORBA.Request.Object; Ctx : constant CORBA.Context.Ref := CORBA.Context.Nil_Ref; Argument : CORBA.Any; Arg_List : CORBA.NVList.Ref; Result : CORBA.NamedValue; Result_Name : CORBA.String := To_CORBA_String ("Result"); begin -- creating the argument list CORBA.ORB.Create_List (0, Arg_List); Argument := all_types.Helper.To_Any (Arg); CORBA.NVList.Add_Item (Arg_List, Arg_Name, Argument, CORBA.ARG_IN); -- setting the result type Result := (Name => Identifier (Result_Name), Argument => Internals.Get_Empty_Any (all_types.Helper.TC_BigMatrix), Arg_Modes => 0); -- creating a request CORBA.Object.Create_Request (Self, Ctx, Operation_Name, Arg_List, Result, Request, 0); -- sending message CORBA.Request.Invoke (Request, 0); -- getting the answer return all_types.Helper.From_Any (Result.Argument); end EchoBigMatrix; ---------------- -- EchoStruct -- ---------------- function EchoStruct (Self : CORBA.Object.Ref; Arg : all_types.Simple_Struct) return all_types.Simple_Struct is Operation_Name : CORBA.Identifier := To_CORBA_String ("echoStruct"); Arg_Name : CORBA.Identifier := To_CORBA_String ("arg"); Request : CORBA.Request.Object; Ctx : constant CORBA.Context.Ref := CORBA.Context.Nil_Ref; Argument : CORBA.Any; Arg_List : CORBA.NVList.Ref; Result : CORBA.NamedValue; Result_Name : CORBA.String := To_CORBA_String ("Result"); begin -- creating the argument list CORBA.ORB.Create_List (0, Arg_List); Argument := all_types.Helper.To_Any (Arg); CORBA.NVList.Add_Item (Arg_List, Arg_Name, Argument, CORBA.ARG_IN); -- setting the result type Result := (Name => Identifier (Result_Name), Argument => Internals.Get_Empty_Any (all_types.Helper.TC_Simple_Struct), Arg_Modes => 0); -- creating a request CORBA.Object.Create_Request (Self, Ctx, Operation_Name, Arg_List, Result, Request, 0); -- sending message CORBA.Request.Invoke (Request, 0); -- getting the answer return all_types.Helper.From_Any (Result.Argument); end EchoStruct; --------------------- -- EchoArrayStruct -- --------------------- function EchoArrayStruct (Self : CORBA.Object.Ref; Arg : all_types.array_struct) return all_types.array_struct is Operation_Name : CORBA.Identifier := To_CORBA_String ("echoArrayStruct"); Arg_Name : CORBA.Identifier := To_CORBA_String ("arg"); Request : CORBA.Request.Object; Ctx : constant CORBA.Context.Ref := CORBA.Context.Nil_Ref; Argument : CORBA.Any; Arg_List : CORBA.NVList.Ref; Result : CORBA.NamedValue; Result_Name : CORBA.String := To_CORBA_String ("Result"); begin -- creating the argument list CORBA.ORB.Create_List (0, Arg_List); Argument := all_types.Helper.To_Any (Arg); CORBA.NVList.Add_Item (Arg_List, Arg_Name, Argument, CORBA.ARG_IN); -- setting the result type Result := (Name => Identifier (Result_Name), Argument => Internals.Get_Empty_Any (all_types.Helper.TC_array_struct), Arg_Modes => 0); -- creating a request CORBA.Object.Create_Request (Self, Ctx, Operation_Name, Arg_List, Result, Request, 0); -- sending message CORBA.Request.Invoke (Request, 0); -- getting the answer return all_types.Helper.From_Any (Result.Argument); end EchoArrayStruct; --------------- -- EchoUnion -- --------------- function EchoUnion (Self : CORBA.Object.Ref; Arg : all_types.myUnion) return all_types.myUnion is Operation_Name : CORBA.Identifier := To_CORBA_String ("echoUnion"); Arg_Name : CORBA.Identifier := To_CORBA_String ("arg"); Request : CORBA.Request.Object; Ctx : constant CORBA.Context.Ref := CORBA.Context.Nil_Ref; Argument : CORBA.Any; Arg_List : CORBA.NVList.Ref; Result : CORBA.NamedValue; Result_Name : CORBA.String := To_CORBA_String ("Result"); begin -- creating the argument list CORBA.ORB.Create_List (0, Arg_List); Argument := all_types.Helper.To_Any (Arg); CORBA.NVList.Add_Item (Arg_List, Arg_Name, Argument, CORBA.ARG_IN); -- setting the result type Result := (Name => Identifier (Result_Name), Argument => Internals.Get_Empty_Any (all_types.Helper.TC_Myunion), Arg_Modes => 0); -- creating a request CORBA.Object.Create_Request (Self, Ctx, Operation_Name, Arg_List, Result, Request, 0); -- sending message CORBA.Request.Invoke (Request, 0); -- getting the answer return all_types.Helper.From_Any (Result.Argument); end EchoUnion; ------------------------- -- EchoUnionEnumSwitch -- ------------------------- function EchoUnionEnumSwitch (Self : CORBA.Object.Ref; Arg : all_types.myUnionEnumSwitch) return all_types.myUnionEnumSwitch is Operation_Name : CORBA.Identifier := To_CORBA_String ("echoUnionEnumSwitch"); Arg_Name : CORBA.Identifier := To_CORBA_String ("arg"); Request : CORBA.Request.Object; Ctx : constant CORBA.Context.Ref := CORBA.Context.Nil_Ref; Argument : CORBA.Any; Arg_List : CORBA.NVList.Ref; Result : CORBA.NamedValue; Result_Name : CORBA.String := To_CORBA_String ("Result"); begin -- creating the argument list CORBA.ORB.Create_List (0, Arg_List); Argument := all_types.Helper.To_Any (Arg); CORBA.NVList.Add_Item (Arg_List, Arg_Name, Argument, CORBA.ARG_IN); -- setting the result type Result := (Name => Identifier (Result_Name), Argument => Internals.Get_Empty_Any (all_types.Helper.TC_MyunionEnumSwitch), Arg_Modes => 0); -- creating a request CORBA.Object.Create_Request (Self, Ctx, Operation_Name, Arg_List, Result, Request, 0); -- sending message CORBA.Request.Invoke (Request, 0); -- getting the answer return all_types.Helper.From_Any (Result.Argument); end EchoUnionEnumSwitch; ------------------- -- EchoUsequence -- ------------------- function EchoUsequence (Self : CORBA.Object.Ref; Arg : all_types.U_sequence) return all_types.U_sequence is Operation_Name : CORBA.Identifier := To_CORBA_String ("echoUsequence"); Arg_Name : CORBA.Identifier := To_CORBA_String ("arg"); Request : CORBA.Request.Object; Ctx : constant CORBA.Context.Ref := CORBA.Context.Nil_Ref; Argument : CORBA.Any; Arg_List : CORBA.NVList.Ref; Result : CORBA.NamedValue; Result_Name : CORBA.String := To_CORBA_String ("Result"); begin -- creating the argument list CORBA.ORB.Create_List (0, Arg_List); Argument := all_types.Helper.To_Any (Arg); CORBA.NVList.Add_Item (Arg_List, Arg_Name, Argument, CORBA.ARG_IN); -- setting the result type Result := (Name => Identifier (Result_Name), Argument => Internals.Get_Empty_Any (all_types.Helper.TC_U_sequence), Arg_Modes => 0); -- creating a request CORBA.Object.Create_Request (Self, Ctx, Operation_Name, Arg_List, Result, Request, 0); -- sending message CORBA.Request.Invoke (Request, 0); -- getting the answer return all_types.Helper.From_Any (Result.Argument); end EchoUsequence; ------------------- -- EchoBsequence -- ------------------- function EchoBsequence (Self : CORBA.Object.Ref; Arg : all_types.B_sequence) return all_types.B_sequence is Operation_Name : CORBA.Identifier := To_CORBA_String ("echoBsequence"); Arg_Name : CORBA.Identifier := To_CORBA_String ("arg"); Request : CORBA.Request.Object; Ctx : constant CORBA.Context.Ref := CORBA.Context.Nil_Ref; Argument : CORBA.Any; Arg_List : CORBA.NVList.Ref; Result : CORBA.NamedValue; Result_Name : CORBA.String := To_CORBA_String ("Result"); begin -- creating the argument list CORBA.ORB.Create_List (0, Arg_List); Argument := all_types.Helper.To_Any (Arg); CORBA.NVList.Add_Item (Arg_List, Arg_Name, Argument, CORBA.ARG_IN); -- setting the result type Result := (Name => Identifier (Result_Name), Argument => Internals.Get_Empty_Any (all_types.Helper.TC_B_sequence), Arg_Modes => 0); -- creating a request CORBA.Object.Create_Request (Self, Ctx, Operation_Name, Arg_List, Result, Request, 0); -- sending message CORBA.Request.Invoke (Request, 0); -- getting the answer return all_types.Helper.From_Any (Result.Argument); end EchoBsequence; ----------------- -- Set_MyColor -- ----------------- procedure Set_MyColor (Self : CORBA.Object.Ref; Arg : all_types.Color) is Operation_Name : CORBA.Identifier := To_CORBA_String ("_set_myColor"); Arg_Name : CORBA.Identifier := To_CORBA_String ("arg"); Request : CORBA.Request.Object; Ctx : constant CORBA.Context.Ref := CORBA.Context.Nil_Ref; Argument : CORBA.Any; Arg_List : CORBA.NVList.Ref; Result : CORBA.NamedValue; Result_Name : CORBA.String := To_CORBA_String ("Result"); begin -- creating the argument list CORBA.ORB.Create_List (0, Arg_List); Argument := all_types.Helper.To_Any (Arg); CORBA.NVList.Add_Item (Arg_List, Arg_Name, Argument, CORBA.ARG_IN); -- setting the result type Result := (Name => Identifier (Result_Name), Argument => Internals.Get_Empty_Any (CORBA.TC_Void), Arg_Modes => 0); -- creating a request CORBA.Object.Create_Request (Self, Ctx, Operation_Name, Arg_List, Result, Request, 0); -- sending message CORBA.Request.Invoke (Request, 0); end Set_MyColor; ----------------- -- Get_MyColor -- ----------------- function Get_MyColor (Self : CORBA.Object.Ref) return all_types.Color is Operation_Name : CORBA.Identifier := To_CORBA_String ("_get_myColor"); Request : CORBA.Request.Object; Ctx : constant CORBA.Context.Ref := CORBA.Context.Nil_Ref; Arg_List : CORBA.NVList.Ref; Result : CORBA.NamedValue; Result_Name : CORBA.String := To_CORBA_String ("Result"); begin -- creating the argument list CORBA.ORB.Create_List (0, Arg_List); -- setting the result type Result := (Name => Identifier (Result_Name), Argument => Internals.Get_Empty_Any (all_types.Helper.TC_Color), Arg_Modes => 0); -- creating a request CORBA.Object.Create_Request (Self, Ctx, Operation_Name, Arg_List, Result, Request, 0); -- sending message CORBA.Request.Invoke (Request, 0); -- getting the answer return all_types.Helper.From_Any (Result.Argument); end Get_MyColor; ----------------- -- Get_Counter -- ----------------- function Get_Counter (Self : CORBA.Object.Ref) return CORBA.Long is Operation_Name : CORBA.Identifier := To_CORBA_String ("_get_Counter"); Request : CORBA.Request.Object; Ctx : constant CORBA.Context.Ref := CORBA.Context.Nil_Ref; Arg_List : CORBA.NVList.Ref; Result : CORBA.NamedValue; Result_Name : CORBA.String := To_CORBA_String ("Result"); begin -- creating the argument list CORBA.ORB.Create_List (0, Arg_List); -- setting the result type Result := (Name => Identifier (Result_Name), Argument => Internals.Get_Empty_Any (CORBA.TC_Long), Arg_Modes => 0); -- creating a request CORBA.Object.Create_Request (Self, Ctx, Operation_Name, Arg_List, Result, Request, 0); -- sending message CORBA.Request.Invoke (Request, 0); -- getting the answer return From_Any (Result.Argument); end Get_Counter; ------------------- -- TestException -- ------------------- procedure TestException (Self : CORBA.Object.Ref; Arg : CORBA.Long) is Operation_Name : CORBA.Identifier := To_CORBA_String ("testException"); Arg_Name : CORBA.Identifier := To_CORBA_String ("arg"); Request : CORBA.Request.Object; Ctx : constant CORBA.Context.Ref := CORBA.Context.Nil_Ref; Argument : CORBA.Any; Arg_List : CORBA.NVList.Ref; Excp_List : CORBA.ExceptionList.Ref; Result_Name : CORBA.String := To_CORBA_String ("Result"); Result : CORBA.NamedValue; begin -- creating the argument list CORBA.ORB.Create_List (0, Arg_List); Argument := CORBA.To_Any (Arg); CORBA.NVList.Add_Item (Arg_List, Arg_Name, Argument, CORBA.ARG_IN); -- creating the exception list CORBA.ORB.Create_List (Excp_List); CORBA.ExceptionList.Add (Excp_List, all_types.Helper.TC_My_Exception); -- setting the result type Result := (Name => Identifier (Result_Name), Argument => Internals.Get_Empty_Any (CORBA.TC_Void), Arg_Modes => 0); -- creating a request CORBA.Object.Create_Request (Self, Ctx, Operation_Name, Arg_List, Result, Excp_List, CORBA.ContextList.Nil_Ref, Request, 0); -- sending message CORBA.Request.Invoke (Request, 0); end TestException; -------------------------- -- TestUnknownException -- -------------------------- procedure TestUnknownException (Self : CORBA.Object.Ref; Arg : CORBA.Long) is Operation_Name : CORBA.Identifier := To_CORBA_String ("testUnknownException"); Arg_Name : CORBA.Identifier := To_CORBA_String ("arg"); Request : CORBA.Request.Object; Ctx : constant CORBA.Context.Ref := CORBA.Context.Nil_Ref; Argument : CORBA.Any; Arg_List : CORBA.NVList.Ref; Excp_List : CORBA.ExceptionList.Ref; Result_Name : CORBA.String := To_CORBA_String ("Result"); Result : CORBA.NamedValue; begin -- creating the argument list CORBA.ORB.Create_List (0, Arg_List); Argument := CORBA.To_Any (Arg); CORBA.NVList.Add_Item (Arg_List, Arg_Name, Argument, CORBA.ARG_IN); -- creating the exception list CORBA.ORB.Create_List (Excp_List); CORBA.ExceptionList.Add (Excp_List, all_types.Helper.TC_My_Exception); -- setting the result type Result := (Name => Identifier (Result_Name), Argument => Internals.Get_Empty_Any (CORBA.TC_Void), Arg_Modes => 0); -- creating a request CORBA.Object.Create_Request (Self, Ctx, Operation_Name, Arg_List, Result, Excp_List, CORBA.ContextList.Nil_Ref, Request, 0); -- sending message CORBA.Request.Invoke (Request, 0); end TestUnknownException; begin New_Test ("CORBA Types"); CORBA.ORB.Initialize ("ORB"); if Ada.Command_Line.Argument_Count < 1 then Ada.Text_IO.Put_Line ("usage : client [oneshot]"); return; end if; if Ada.Command_Line.Argument (1) = "-i" then Myall_Types := Locate ("all_types"); else Myall_Types := Locate (Ada.Command_Line.Argument (1)); end if; loop -- boolean Output ("test boolean", EchoBoolean (Myall_Types, True)); -- short Output ("test short", EchoShort (Myall_Types, 123) = 123); -- long Output ("test long", EchoLong (Myall_Types, 456) = 456); -- unsigned_short Output ("test unsigned_short", EchoUShort (Myall_Types, 456) = 456); -- unsigned_long Output ("test unsigned_long", EchoULong (Myall_Types, 123) = 123); -- float Output ("test float", EchoFloat (Myall_Types, 2.7) = 2.7); -- double Output ("test double", EchoDouble (Myall_Types, 3.14) = 3.14); -- char Output ("test char", EchoChar (Myall_Types, 'A') = 'A'); -- octet Output ("test octet", EchoOctet (Myall_Types, 5) = 5); -- string Output ("test string", To_Standard_String (EchoString (Myall_Types, To_CORBA_String ("hello"))) = "hello"); -- CORBA.Object.Ref declare X : CORBA.Object.Ref; begin X := EchoRef (Myall_Types, Myall_Types); Output ("test self reference", EchoLong (X, 31337) = 31337); end; -- enum Output ("test enum", EchoColor (Myall_Types, all_types.Blue) = all_types.Blue); -- fixed -- Output ("test fixed point", -- EchoMoney (Myall_Types, 6423.50) = 6423.50 -- and then EchoMoney (Myall_Types, 0.0) = 0.0 -- and then EchoMoney (Myall_Types, 3.14) = 3.14); -- array declare X : constant all_types.simple_array := (2, 3, 5, 7, 11); begin Output ("test simple array", EchoArray (Myall_Types, X) = X); end; declare M : constant all_types.matrix := ((165, 252, 375), (377, 145, 222), (202, 477, 147)); begin Output ("test multi-dimensional array", EchoMatrix (Myall_Types, M) = M); end; -- struct declare Test_Struct : constant all_types.simple_struct := (123, To_CORBA_String ("Hello world!")); begin Output ("test struct", EchoStruct (Myall_Types, Test_Struct) = Test_Struct); end; declare Test_Struct : constant array_struct := (A => (0, 1, 2, 3, 4, 5, 6, 7, 8, 9), B => 65533); begin Output ("test array struct", EchoArrayStruct (Myall_Types, Test_Struct) = Test_Struct); end; -- union declare Test_Unions : constant array (0 .. 3) of myUnion := ((Switch => 0, Unknown => 987), (Switch => 1, Counter => 1212), (Switch => 2, Flag => True), (Switch => 3, Hue => Green)); Pass : Boolean := True; begin for I in Test_Unions'Range loop Pass := Pass and then EchoUnion (Myall_Types, Test_Unions (I)) = Test_Unions (I); exit when not Pass; end loop; Output ("test union", Pass); end; declare Test_Unions : constant array (Integer range <>) of myUnionEnumSwitch := ((Switch => Red, Foo => 31337), (Switch => Green, Bar => 534), (Switch => Blue, Baz => CORBA.To_CORBA_String ("grümpf"))); Pass : Boolean := True; begin for I in Test_Unions'Range loop Pass := Pass and then EchoUnionEnumSwitch (Myall_Types, Test_Unions (I)) = Test_Unions (I); exit when not Pass; end loop; Output ("test union with enum switch", Pass); end; -- Unbounded sequences declare X : U_sequence := U_sequence (IDL_SEQUENCE_Short.Null_sequence); begin X := X & 1 & 2 & 3 & 4 & 5; Output ("test unbounded sequence", EchoUsequence (Myall_Types, X) = X); end; -- Bounded sequences declare X : B_sequence := B_sequence (IDL_SEQUENCE_10_short.Null_sequence); begin X := X & 1 & 2 & 3 & 4 & 5 & 6; Output ("test bounded sequence", EchoBsequence (Myall_Types, X) = X); end; -- Attributes Set_MyColor (Myall_Types, Green); Output ("test attribute", Get_MyColor (Myall_Types) = Green); declare Counter_First_Value : constant CORBA.Long := get_Counter (Myall_Types); Counter_Second_Value : constant CORBA.Long := get_Counter (Myall_Types); begin Output ("test read-only attribute", Counter_Second_Value = Counter_First_Value + 1); end; -- Exceptions declare Ok : Boolean; begin Ok := False; declare Member : UnknownUserException_Members; Actual_Member : My_Exception_Members; begin testException (Myall_Types, 2485); exception when E : UnknownUserException => Get_Members (E, Member); Actual_Member := all_types.Helper.From_Any (Member.IDL_Exception); Ok := (Actual_Member.Info = 2485); when others => null; end; Output ("test user exception", Ok); end; declare Ok : Boolean; begin Ok := False; begin testUnknownException (Myall_Types, 2485); exception when CORBA.UNKNOWN => Ok := True; when others => null; end; Output ("test unknown exception", Ok); end; exit when One_Shot; end loop; End_Report; end DynClient; polyorb-2.8~20110207.orig/examples/corba/all_types/all_types-impl.adb0000644000175000017500000002427611750740337024726 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- A L L _ T Y P E S . I M P L -- -- -- -- B o d y -- -- -- -- Copyright (C) 2002-2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with Ada.Text_IO; with Ada.Wide_Text_IO; with CORBA.ORB; with all_types.Skel; pragma Warnings (Off, all_types.Skel); with all_types.Helper; package body all_types.Impl is pragma Warnings (Off); type IDL_Exception_Members_Ptr is access all CORBA.IDL_Exception_Members'Class; function echoBoolean (Self : access Object; arg : CORBA.Boolean) return CORBA.Boolean is begin return arg; end echoBoolean; function echoShort (Self : access Object; arg : CORBA.Short) return CORBA.Short is begin return arg; end echoShort; function echoLong (Self : access Object; arg : CORBA.Long) return CORBA.Long is begin return arg; end echoLong; function echoUShort (Self : access Object; arg : CORBA.Unsigned_Short) return CORBA.Unsigned_Short is begin return arg; end echoUShort; function echoULong (Self : access Object; arg : CORBA.Unsigned_Long) return CORBA.Unsigned_Long is begin return arg; end echoULong; function echoULLong (Self : access Object; arg : CORBA.Unsigned_Long_Long) return CORBA.Unsigned_Long_Long is begin return arg; end echoULLong; function echoFloat (Self : access Object; arg : CORBA.Float) return CORBA.Float is begin return arg; end echoFloat; function echoDouble (Self : access Object; arg : CORBA.Double) return CORBA.Double is begin return arg; end echoDouble; function echoChar (Self : access Object; arg : CORBA.Char) return CORBA.Char is begin return arg; end echoChar; function echoWChar (Self : access Object; arg : CORBA.Wchar) return CORBA.Wchar is begin return arg; end echoWChar; function echoOctet (Self : access Object; arg : CORBA.Octet) return CORBA.Octet is begin return arg; end echoOctet; function echoString (Self : access Object; arg : CORBA.String) return CORBA.String is begin Ada.Text_IO.Put_Line ("Unbounded standard string: « " & CORBA.To_Standard_String (arg) & " »"); return arg; end echoString; function echoWString (Self : access Object; arg : CORBA.Wide_String) return CORBA.Wide_String is begin Ada.Wide_Text_IO.Put_Line ("Unbounded wide string: « " & CORBA.To_Standard_Wide_String (arg) & " »"); return arg; end echoWString; function echoRef (Self : access Object; arg : all_types.Ref) return all_types.Ref'Class is begin return arg; end echoRef; function echoObject (Self : access Object; arg : CORBA.Object.Ref) return CORBA.Object.Ref is begin return arg; end echoObject; function echoOtherAllTypes (Self : access Object; arg : all_types.otherAllTypes) return all_types.otherAllTypes'Class is begin return arg; end echoOtherAllTypes; function echoOtherObject (Self : access Object; arg : all_types.otherObject) return all_types.otherObject is begin return arg; end echoOtherObject; function echoBoundedStr (Self : access Object; arg : all_types.BoundedStr) return all_types.BoundedStr is begin Ada.Text_IO.Put_Line ("Bounded standard string: « " & Bounded_String_12.To_String (Bounded_String_12.Bounded_String (arg)) & " »"); return arg; end echoBoundedStr; function echoBoundedWStr (Self : access Object; arg : all_types.BoundedWStr) return all_types.BoundedWStr is begin Ada.Wide_Text_IO.Put_Line ("Bounded wide string: « " & Bounded_Wide_String_11.To_Wide_String (Bounded_Wide_String_11.Bounded_Wide_String (arg)) & " »"); return arg; end echoBoundedWStr; function echoColor (Self : access Object; arg : Color) return Color is begin if Arg'Valid then Ada.Text_IO.Put_Line ("echoColor: " & arg'Img); else Ada.Text_IO.Put_Line ("echoColor: "); end if; return arg; end echoColor; function echoRainbow (Self : access Object; arg : Rainbow) return Rainbow is begin return arg; end echoRainbow; function echoMoney (Self : access Object; Arg : Money) return Money is begin Ada.Text_IO.Put_Line ("echoMoney: " & Arg'Img); return Arg; end echoMoney; function echoArray (Self : access Object; Arg : simple_array) return simple_array is begin return Arg; end echoArray; function echoMatrix (Self : access Object; arg : matrix) return matrix is begin return arg; end echoMatrix; function echoBigMatrix (Self : access Object; arg : bigmatrix) return bigmatrix is begin return arg; end echoBigMatrix; function echoNestedArray (Self : access Object; Arg : nested_array) return nested_array is begin return Arg; end echoNestedArray; function echoSixteenKb (Self : access Object; arg : sixteenKb) return sixteenKb is begin return arg; end echoSixteenKb; procedure testException (Self : access Object; info : CORBA.Long; why : CORBA.String) is begin all_types.Helper.Raise_my_exception (my_exception_Members'(Info => info, why => why)); end testException; procedure testUnknownException (Self : access Object; arg : CORBA.Long) is begin raise Constraint_Error; end testUnknownException; procedure testSystemException (Self : access Object; arg : CORBA.Long) is begin CORBA.Raise_Bad_Param (CORBA.Default_Sys_Member); end testSystemException; function echoStruct (Self : access Object; arg : simple_struct) return simple_struct is begin return arg; end echoStruct; function echoArrayStruct (Self : access Object; arg : array_struct) return array_struct is begin return arg; end echoArrayStruct; function echoNestedStruct (Self : access Object; arg : nested_struct) return nested_struct is begin return arg; end echoNestedStruct; function echoUnion (Self : access Object; arg : myUnion) return myUnion is begin return arg; end echoUnion; function echoUnionEnumSwitch (Self : access Object; arg : myUnionEnumSwitch) return myUnionEnumSwitch is begin return arg; end echoUnionEnumSwitch; function echoNoMemberUnion (Self : access Object; arg : noMemberUnion) return noMemberUnion is begin return arg; end echoNoMemberUnion; function echoUsequence (Self : access Object; arg : U_sequence) return U_sequence is use IDL_SEQUENCE_short; begin Ada.Text_IO.Put_Line ("echoUsequence: len =" & Length (arg)'Img); return arg; end echoUsequence; function echoBsequence (Self : access Object; arg : B_sequence) return B_sequence is begin return arg; end echoBsequence; function echoUnionSequence (Self : access Object; arg : unionSequence) return unionSequence is begin return arg; end echoUnionSequence; function echoAny (Self : access Object; Arg : CORBA.Any) return CORBA.Any is begin return Arg; end echoAny; procedure set_MyColor (Self : access Object; arg : Color) is begin Self.Attr_My_Color := arg; end set_MyColor; function get_myColor (Self : access Object) return Color is begin return Self.Attr_My_Color; end get_myColor; function get_Counter (Self : access Object) return CORBA.Long is use CORBA; begin Self.Attr_Counter := Self.Attr_Counter + 1; return Self.Attr_Counter; end get_Counter; procedure StopServer (Self : access Object) is begin CORBA.ORB.Shutdown (Wait_For_Completion => False); end StopServer; end all_types.Impl; polyorb-2.8~20110207.orig/examples/corba/all_types/test.out0000644000175000017500000000402711750740337023023 0ustar xavierxaviertest not null...............................................: PASSED test string.................................................: PASSED test boolean................................................: PASSED test short..................................................: PASSED test long...................................................: PASSED test unsigned_short.........................................: PASSED test unsigned_long..........................................: PASSED test float..................................................: PASSED test double.................................................: PASSED test char...................................................: PASSED test octet..................................................: PASSED test enum...................................................: PASSED test unbounded sequence.....................................: PASSED test bounded sequence.......................................: PASSED test fixed point............................................: FAILED test struct.................................................: PASSED test self reference.........................................: PASSED test self reference consistency.............................: PASSED test self reference typedef.................................: PASSED test object.................................................: PASSED test object typedef.........................................: PASSED test union..................................................: PASSED test union with enum switch.................................: PASSED test simple array...........................................: PASSED test multi-dimensional array................................: PASSED test big multi-dimensional array............................: FAILED test attribute..............................................: PASSED test read-only attribute....................................: PASSED test user exception.........................................: PASSED test unknown exception......................................: PASSED polyorb-2.8~20110207.orig/examples/corba/all_types/all_types.idl0000644000175000017500000000720511750740337024002 0ustar xavierxavierinterface all_types { // Simple types // ------------ boolean echoBoolean(in boolean arg) ; short echoShort(in short arg) ; long echoLong(in long arg) ; unsigned short echoUShort(in unsigned short arg) ; unsigned long echoULong(in unsigned long arg) ; unsigned long long echoULLong(in unsigned long long arg) ; float echoFloat(in float arg) ; double echoDouble(in double arg) ; char echoChar(in char arg) ; wchar echoWChar(in wchar arg) ; octet echoOctet (in octet arg) ; string echoString (in string arg) ; wstring echoWString (in wstring arg) ; all_types echoRef (in all_types arg); Object echoObject (in Object arg); typedef all_types otherAllTypes; typedef Object otherObject; otherAllTypes echoOtherAllTypes (in otherAllTypes arg); otherObject echoOtherObject (in otherObject arg); // Bounded strings // =============== typedef string<12> BoundedStr; BoundedStr echoBoundedStr (in BoundedStr arg); typedef wstring<11> BoundedWStr; BoundedWStr echoBoundedWStr (in BoundedWStr arg); // Enum // ---- enum Color { Red, Green, Blue }; Color echoColor (in Color arg); // Array of enum typedef Color Rainbow[7]; Rainbow echoRainbow (in Rainbow arg); // Exceptions // ---------- exception my_exception { long info; string why; }; void testException (in long info, in string why) raises (my_exception); void testUnknownException (in long arg); void testSystemException (in long arg); // Unions // ------ union myUnion switch (long) { case 1: long Counter; case 2: boolean Flag; case 3: Color Hue; default: long Unknown; }; myUnion echoUnion (in myUnion arg); union myUnionEnumSwitch switch (Color) { case Red: long foo; case Green: short bar; case Blue: string baz; }; myUnionEnumSwitch echoUnionEnumSwitch (in myUnionEnumSwitch arg); union noMemberUnion switch (boolean) { case FALSE: long falseVal; }; noMemberUnion echoNoMemberUnion (in noMemberUnion arg); // Arrays // ------ typedef long simple_array[5]; simple_array echoArray (in simple_array arg); // Multi-dimensional arrays // ------------------------ typedef long matrix[3][3]; matrix echoMatrix (in matrix arg); typedef long bigmatrix[30][15]; bigmatrix echoBigMatrix (in bigmatrix arg); // Nested arrays // ------------- typedef simple_array nested_array[3]; nested_array echoNestedArray (in nested_array arg); // Big arrays // ---------- typedef long sixteenKb[64][64]; sixteenKb echoSixteenKb (in sixteenKb arg); // Structs // ------- struct simple_struct { long a; string s; }; simple_struct echoStruct (in simple_struct arg); struct array_struct { long a[10]; unsigned short b; }; array_struct echoArrayStruct (in array_struct arg); struct composite_struct { fixed<12,3> fixedMember; sequence > seqseqMember; long double matrixMember[3][4]; }; struct nested_struct { simple_struct ns; }; nested_struct echoNestedStruct (in nested_struct arg); // Sequences // --------- typedef sequence U_sequence; U_sequence echoUsequence (in U_sequence arg); typedef sequence B_sequence; B_sequence echoBsequence (in B_sequence arg); typedef sequence unionSequence; unionSequence echoUnionSequence (in unionSequence arg); // Fixed point // ----------- typedef fixed<18,2> Money; Money echoMoney (in Money arg); // Any // --- any echoAny (in any arg); // Attributes // ---------- readonly attribute long Counter; attribute Color myColor; void StopServer (); // Shut down server }; polyorb-2.8~20110207.orig/examples/corba/all_types/local.gpr0000644000175000017500000000076711750740337023126 0ustar xavierxavierwith "polyorb", "polyorb_test_common"; project local is Dir := external ("Test_Dir"); Obj_Dir := PolyORB_Test_Common.Build_Dir & Dir; for Object_Dir use Obj_Dir; for Source_Dirs use (Obj_Dir, PolyORB_Test_Common.Source_Dir & Dir); package Compiler is for Default_Switches ("Ada") use PolyORB_Test_Common.Compiler'Default_Switches ("Ada"); end Compiler; for Main use ("client.adb", "server.adb", "dynclient.adb", "client_moma.adb", "ir_server.adb"); end local; polyorb-2.8~20110207.orig/examples/corba/all_types/all_types-impl.ads0000644000175000017500000001510311750740337024734 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- A L L _ T Y P E S . I M P L -- -- -- -- S p e c -- -- -- -- Copyright (C) 2002-2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with CORBA; with CORBA.Object; with PortableServer; package all_types.Impl is -- This is simply used to define the operations. type Object is new PortableServer.Servant_Base with record Attr_My_Color : Color := Blue; Attr_Counter : CORBA.Long := 0; end record; function echoBoolean (Self : access Object; arg : CORBA.Boolean) return CORBA.Boolean; function echoShort (Self : access Object; arg : CORBA.Short) return CORBA.Short; function echoLong (Self : access Object; arg : CORBA.Long) return CORBA.Long; function echoUShort (Self : access Object; arg : CORBA.Unsigned_Short) return CORBA.Unsigned_Short; function echoULong (Self : access Object; arg : CORBA.Unsigned_Long) return CORBA.Unsigned_Long; function echoULLong (Self : access Object; arg : CORBA.Unsigned_Long_Long) return CORBA.Unsigned_Long_Long; function echoFloat (Self : access Object; arg : CORBA.Float) return CORBA.Float; function echoDouble (Self : access Object; arg : CORBA.Double) return CORBA.Double; function echoChar (Self : access Object; arg : CORBA.Char) return CORBA.Char; function echoWChar (Self : access Object; arg : CORBA.Wchar) return CORBA.Wchar; function echoOctet (Self : access Object; arg : CORBA.Octet) return CORBA.Octet; function echoString (Self : access Object; arg : CORBA.String) return CORBA.String; function echoWString (Self : access Object; arg : CORBA.Wide_String) return CORBA.Wide_String; function echoRef (Self : access Object; arg : all_types.Ref) return all_types.Ref'Class; function echoObject (Self : access Object; arg : CORBA.Object.Ref) return CORBA.Object.Ref; function echoOtherAllTypes (Self : access Object; arg : all_types.otherAllTypes) return all_types.otherAllTypes'Class; function echoOtherObject (Self : access Object; arg : all_types.otherObject) return all_types.otherObject; function echoBoundedStr (Self : access Object; arg : all_types.BoundedStr) return all_types.BoundedStr; function echoBoundedWStr (Self : access Object; arg : all_types.BoundedWStr) return all_types.BoundedWStr; function echoColor (Self : access Object; arg : Color) return Color; function echoRainbow (Self : access Object; arg : Rainbow) return Rainbow; function echoArray (Self : access Object; Arg : simple_array) return simple_array; function echoMatrix (Self : access Object; arg : matrix) return matrix; function echoBigMatrix (Self : access Object; arg : bigmatrix) return bigmatrix; function echoNestedArray (Self : access Object; Arg : nested_array) return nested_array; function echoSixteenKb (Self : access Object; arg : sixteenKb) return sixteenKb; procedure testException (Self : access Object; info : CORBA.Long; why : CORBA.String); procedure testUnknownException (Self : access Object; arg : CORBA.Long); procedure testSystemException (Self : access Object; arg : CORBA.Long); function echoStruct (Self : access Object; arg : simple_struct) return simple_struct; function echoArrayStruct (Self : access Object; arg : array_struct) return array_struct; function echoNestedStruct (Self : access Object; arg : nested_struct) return nested_struct; function echoUnion (Self : access Object; arg : myUnion) return myUnion; function echoUnionEnumSwitch (Self : access Object; arg : myUnionEnumSwitch) return myUnionEnumSwitch; function echoNoMemberUnion (Self : access Object; arg : noMemberUnion) return noMemberUnion; function echoUsequence (Self : access Object; arg : U_sequence) return U_sequence; function echoBsequence (Self : access Object; arg : B_sequence) return B_sequence; function echoUnionSequence (Self : access Object; arg : unionSequence) return unionSequence; function echoMoney (Self : access Object; Arg : Money) return Money; function echoAny (Self : access Object; Arg : CORBA.Any) return CORBA.Any; procedure set_MyColor (Self : access Object; arg : Color); function get_myColor (Self : access Object) return Color; function get_Counter (Self : access Object) return CORBA.Long; procedure StopServer (Self : access Object); end all_types.Impl; polyorb-2.8~20110207.orig/examples/corba/all_types/server.adb0000644000175000017500000001044611750740337023273 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- S E R V E R -- -- -- -- B o d y -- -- -- -- Copyright (C) 2002-2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with Ada.Text_IO; with GNAT.Command_Line; use GNAT.Command_Line; -- with GNAT.Exception_Traces; use GNAT.Exception_Traces; with PolyORB.CORBA_P.CORBALOC; with PolyORB.CORBA_P.Server_Tools; with PolyORB.Setup.No_Tasking_Server; pragma Warnings (Off, PolyORB.Setup.No_Tasking_Server); -- with PolyORB.Setup.Ravenscar_TP_Server; -- pragma Warnings (Off, PolyORB.Setup.Ravenscar_TP_Server); -- with PolyORB.Setup.Thread_Pool_Server; -- pragma Warnings (Off, PolyORB.Setup.Thread_Pool_Server); with PolyORB.CORBA_P.Naming_Tools; use PolyORB.CORBA_P.Naming_Tools; with CORBA; with CORBA.Impl; with CORBA.Object; with CORBA.ORB; with PortableServer; with all_types.Impl; procedure Server is use PolyORB.CORBA_P.Server_Tools; Ref : CORBA.Object.Ref; Register_Server : Boolean := False; -- Use_Delegate : Boolean := False; begin -- Trace_On (Every_Raise); Ada.Text_IO.Put_Line ("Server starting."); CORBA.ORB.Initialize ("ORB"); -- Parse command line loop case Getopt ("d s") is when ASCII.NUL => exit; -- when 'd' => Use_Delegate := True; when 's' => Register_Server := True; when others => raise Program_Error; end case; end loop; -- Should we use the Delegate or the regular version? declare Obj : constant CORBA.Impl.Object_Ptr := new all_types.Impl.Object; begin Initiate_Servant (PortableServer.Servant (Obj), Ref); -- Note that Ref is a smart pointer to a Reference_Info, *not* -- to a CORBA.Impl.Object. end; -- If the server is to be registered, check whether there is a name -- given on the command line, use "echo" otherwise. if Register_Server then declare Name : constant String := Get_Argument; begin if Name = "" then Register ("all_types", Ref); else Register (Name, Ref); end if; end; end if; -- Print IOR so that we can give it to a client Ada.Text_IO.Put_Line ("'" & CORBA.To_Standard_String (CORBA.Object.Object_To_String (Ref)) & "'"); Ada.Text_IO.Put_Line ("'" & CORBA.To_Standard_String (PolyORB.CORBA_P.CORBALOC.Object_To_Corbaloc (Ref)) & "'"); -- Launch the server Initiate_Server; end Server; polyorb-2.8~20110207.orig/examples/corba/all_types/client.adb0000644000175000017500000005312211750740337023241 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- C L I E N T -- -- -- -- B o d y -- -- -- -- Copyright (C) 2002-2011, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- All_Types client with Ada.Command_Line; use Ada.Command_Line; with Ada.Exceptions; with Ada.Text_IO; with CORBA; use CORBA; with CORBA.Object; with CORBA.ORB; with all_types.Impl; with all_types.Helper; use all_types, all_types.Helper; with PolyORB.Utils.Report; with PolyORB.Setup.No_Tasking_Server; pragma Warnings (Off, PolyORB.Setup.No_Tasking_Server); with PolyORB.CORBA_P.Server_Tools; use PolyORB.CORBA_P.Server_Tools; with PolyORB.CORBA_P.Naming_Tools; use PolyORB.CORBA_P.Naming_Tools; procedure Client is use PolyORB.Utils.Report; Myall_types : all_types.Ref; Ok : Boolean; Howmany : Integer := 1; Sequence_Length : Integer := 5; Test_Unions : constant array (Integer range <>) of myUnionEnumSwitch := ((Switch => Red, Foo => 31337), (Switch => Green, Bar => 534), (Switch => Blue, Baz => CORBA.To_CORBA_String ("grümpf"))); type Test_Type is (All_Tests, Long_Only, Sequence_Only, UnionSequence_Only); What : Test_Type := All_Tests; Is_Local : Boolean := False; begin New_Test ("CORBA Types"); CORBA.ORB.Initialize ("ORB"); if Argument_Count < 1 then Ada.Text_IO.Put_Line ("Usage: client " & "[howmany [what [seq-length]]]"); Ada.Text_IO.Put ("where is one of:"); for J in Test_Type'Range loop Ada.Text_IO.Put (" " & J'Img); end loop; return; end if; if Argument_Count >= 2 then Howmany := Integer'Value (Argument (2)); end if; if Argument_Count >= 3 then begin What := Test_Type'Value (Argument (3)); exception when Constraint_Error => What := All_Tests; end; case What is when Sequence_Only | UnionSequence_Only => if Argument_Count > 3 then Sequence_Length := Integer'Value (Argument (4)); end if; when others => null; end case; end if; if Argument (1) = "-i" then Myall_types := To_Ref (Locate ("all_types")); elsif Argument (1) = "local" then Initiate_Servant (new all_types.Impl.Object, Myall_types); Activate_Server; Is_Local := True; else Myall_types := To_Ref (Locate (Argument (1))); end if; if all_types.Is_Nil (Myall_types) then Ada.Text_IO.Put_Line ("main : cannot invoke on a nil reference"); return; end if; Output ("test not null", not all_types.Is_Nil (Myall_types)); for Iterations in 1 .. Howmany loop if What = All_Tests or else What = Long_Only then declare L : constant Unsigned_Long := echoULong (Myall_types, 123); begin if What = Long_Only then pragma Assert (L = 123); goto End_Of_Loop; -- We are only doing an echoULong call, and we are -- interested in getting it as fast as possible. end if; Output ("test unsigned_long", L = 123); end; end if; if What = All_Tests or else What = Sequence_Only then declare X : U_sequence := To_Sequence (Sequence_Length); begin for J in 1 .. Sequence_Length loop Replace_Element (X, J, CORBA.Short (J)); end loop; declare Res : constant U_sequence := echoUsequence (Myall_types, X); begin if What = Sequence_Only then pragma Assert (Res = X); goto End_Of_Loop; end if; Output ("test unbounded sequence (length" & Sequence_Length'Img & ")", Res = X); end; exception when others => Output ("test unbounded sequence", False); end; end if; if What = All_Tests or else What = UnionSequence_Only then declare X : UnionSequence := To_Sequence (Sequence_Length); begin for J in 1 .. Sequence_Length loop Replace_Element (X, J, Test_Unions (Test_Unions'First + J mod Test_Unions'Length)); end loop; declare Res : constant UnionSequence := echoUnionSequence (Myall_types, X); begin if What = UnionSequence_Only then pragma Assert (Res = X); goto End_Of_Loop; end if; Output ("test sequence of unions (length" & Sequence_Length'Img & ")", Res = X); end; exception when others => Output ("test sequence of unions", False); end; end if; begin Output ("test string", To_Standard_String (echoString (Myall_types, To_CORBA_String ("hello distributed world"))) = "hello distributed world"); exception when others => Output ("test string", False); end; begin Output ("test wstring", To_Standard_Wide_String (echoWString (Myall_types, To_CORBA_Wide_String ("hello distributed world"))) = "hello distributed world"); exception when E : CORBA.Marshal => declare Member : CORBA.Marshal_Members; begin CORBA.Get_Members (E, Member); Output ("test wstring", Member.Minor = OMGVMCID + 5); end; when E : CORBA.Inv_Objref => declare Member : CORBA.Inv_Objref_Members; begin CORBA.Get_Members (E, Member); Output ("test wstring", Member.Minor = 2); end; when others => Output ("test wstring", False); end; begin Output ("test boolean", echoBoolean (Myall_types, True)); exception when others => Output ("test boolean", False); end; begin Output ("test short", echoShort (Myall_types, 123) = 123); exception when others => Output ("test short", False); end; begin Output ("test long", echoLong (Myall_types, 456) = 456); exception when others => Output ("test long", False); end; begin Output ("test unsigned_short", echoUShort (Myall_types, 456) = 456); exception when others => Output ("test unsigned_short", False); end; Output ("test unsigned long long", echoULLong (Myall_types, 9_192_631_770) = 9_192_631_770); Output ("test float", echoFloat (Myall_types, 2.7) = 2.7); Output ("test double", echoDouble (Myall_types, 1.5) = 1.5); begin Output ("test char", echoChar (Myall_types, 'A') = 'A'); exception when others => Output ("test char", False); end; begin Output ("test wchar", echoWChar (Myall_types, 'A') = 'A'); exception when E : CORBA.Marshal => declare Member : CORBA.Marshal_Members; begin CORBA.Get_Members (E, Member); Output ("test wchar", Member.Minor = OMGVMCID + 5); end; when E : CORBA.Inv_Objref => declare Member : CORBA.Inv_Objref_Members; begin CORBA.Get_Members (E, Member); Output ("test wchar", Member.Minor = 2); end; when others => Output ("test wchar", False); end; Output ("test octet", echoOctet (Myall_types, 5) = 5); begin Output ("test enum", echoColor (Myall_types, Blue) = Blue); exception when others => Output ("test enum", False); end; declare X_Color : Color; X_Octet : CORBA.Octet; for X_Octet'Address use X_Color'Address; pragma Import (Ada, X_Octet); Success : Boolean := False; begin X_Color := Color'Last; X_Octet := X_Octet + 1; -- From this point on, X_Color has an invalid representation begin Success := echoColor (Myall_types, X_Color) = X_Color; -- No exception raised: invalid value was copied verbatim and -- was not checked, success. exception when CORBA.MARSHAL => Success := True; when CORBA.UNKNOWN => -- For the local case, we MAY raise CONSTRAINT_ERROR on the -- servant side, which is mapped back to CORBA.UNKNOWN on the -- caller side. Success := Is_Local; when E : others => Ada.Text_IO.Put_Line (Ada.Exceptions.Exception_Information (E)); Success := False; end; Output ("test enum invalid rep", Success); end; declare X : Rainbow; begin for J in X'Range loop X (J) := Color'Val (J mod (Color'Pos (Color'Last) + 1)); end loop; Output ("test array of enum", echoRainbow (Myall_types, X) = X); exception when others => Output ("test array of enum", False); end; -- Bounded sequences declare X : constant B_sequence := B_sequence (IDL_SEQUENCE_10_short.To_Sequence (IDL_SEQUENCE_10_short.Element_Array'(1, 2, 3, 4, 5))); begin Output ("test bounded sequence", echoBsequence (Myall_types, X) = X); exception when others => Output ("test bounded sequence", False); end; -- Fixed point declare X : constant array (1 .. 4) of Money := (0.0, 6423.50, 3.14, -27.18); begin Ok := True; for J in X'Range loop if X (J) /= echoMoney (Myall_types, X (J)) then Ok := False; end if; end loop; Output ("test fixed point", Ok); exception when others => Output ("test fixed point", False); end; -- Any declare X1 : constant CORBA.Unsigned_Long := 1234; Y1 : CORBA.Unsigned_Long; X2 : BoundedStr := BoundedStr (Bounded_String_12.Null_Bounded_String); Y2 : BoundedStr; begin Y1 := From_Any (echoAny (Myall_types, To_Any (X1))); Output ("test any", Y1 = X1); for Index in 1 .. 12 loop X2 := X2 & Character'Val (Character'Pos ('A') + Index - 1); end loop; Y2 := All_Types.Helper.From_Any (echoAny (Myall_types, All_Types.Helper.To_Any (X2))); Output ("test any", Y2 = X2); exception when others => Output ("test any", False); end; -- Structs declare Test_Struct : constant simple_struct := (123, To_CORBA_String ("Hello world!")); begin Output ("test struct", echoStruct (Myall_types, Test_Struct) = Test_Struct); exception when others => Output ("test struct", False); end; declare Struct : constant simple_struct := (123, To_CORBA_String ("Hello world!")); Test_Struct : nested_struct; begin Test_Struct.ns := Struct; Output ("test nested struct", echoNestedStruct (Myall_types, Test_Struct) = Test_Struct); exception when others => Output ("test nested struct", False); end; -- Refs declare X : all_types.Ref; begin X := all_types.Ref (echoRef (Myall_types, Myall_types)); Output ("test self reference", True); for I in 1 .. 47 loop X := all_types.Ref (echoRef (X, X)); end loop; Output ("test self reference consistency", echoLong (X, 31337) = 31337); X := all_types.Ref (echoOtherAllTypes (X, X)); Output ("test self reference typedef", echoLong (X, 31337) = 31337); X := all_types.Helper.To_Ref (echoObject (X, CORBA.Object.Ref (X))); Output ("test object", echoLong (X, 23459) = 23459); X := all_types.Helper.To_Ref (echoOtherObject (X, CORBA.Object.Ref (X))); Output ("test object typedef", echoLong (X, 34563) = 34563); exception when others => Output ("refs", False); end; -- Unions declare Test_Unions : constant array (Integer range <>) of myUnion := ((Switch => 0, Unknown => 987), (Switch => 1, Counter => 1212), (Switch => 2, Flag => True), (Switch => 3, Hue => Green)); Pass : Boolean; begin for J in Test_Unions'Range loop Pass := echoUnion (Myall_types, Test_Unions (J)) = Test_Unions (J); Output ("test union" & Test_Unions (J).Switch'Img, Pass); end loop; exception when others => Output ("test union", False); end; declare Pass : Boolean; begin for J in Test_Unions'Range loop begin Pass := echoUnionEnumSwitch (Myall_types, Test_Unions (J)) = Test_Unions (J); Output ("test union with enum switch " & Test_Unions (J).Switch'Img, Pass); exception when others => Output ("test union with enum switch " & Test_Unions (J).Switch'Img, False); end; end loop; end; declare X : constant noMemberUnion (True) := (Switch => True); begin Output ("test union with no member for label", echoNoMemberUnion (Myall_types, X) = X); exception when others => Output ("test union with no member for label", False); end; -- Arrays declare X : constant simple_array := (2, 3, 5, 7, 11); begin Output ("test simple array", echoArray (Myall_types, X) = X); exception when others => Output ("test simple array", False); end; declare M : constant matrix := ((165, 252, 375), (377, 145, 222), (202, 477, 147)); begin Output ("test multi-dimensional array", echoMatrix (Myall_types, M) = M); exception when others => Output ("test multi-dimensional array", False); end; declare B : bigmatrix; begin for I in B'Range (1) loop for J in B'Range (2) loop B (I, J) := Long ((I + 1) * (J + 2)); end loop; end loop; Output ("test big multi-dimensional array", echoBigMatrix (Myall_types, B) = B); exception when others => Output ("test big multi-dimensional array", False); end; declare X : constant nested_array := ((2, 3, 5, 7, 11), (13, 17, 19, 23, 31), (43, 59, 67, 83, 94)); begin Output ("test nested array", echoNestedArray (Myall_types, X) = X); exception when others => Output ("test nested array", False); end; declare B : sixteenKb; begin for I in B'Range (1) loop for J in B'Range (2) loop B (I, J) := Long ((I + 1) * (J + 2)); end loop; end loop; Output ("test huge (16 Kb) multi-dimensional array", echoSixteenKb (Myall_types, B) = B); exception when others => Output ("test huge (16 Kb) multi-dimensional array", False); end; -- Attributes begin Set_myColor (Myall_types, Green); Output ("test attribute", Get_myColor (Myall_types) = Green); exception when others => Output ("test attribute", False); end; begin declare Counter_First_Value : constant CORBA.Long := Get_Counter (Myall_types); Counter_Second_Value : constant CORBA.Long := Get_Counter (Myall_types); begin Output ("test read-only attribute", Counter_Second_Value = Counter_First_Value + 1); end; exception when others => Output ("test read-only attribute", False); end; -- Bounded strings declare X : BoundedStr := BoundedStr (Bounded_String_12.Null_Bounded_String); begin for Index in 1 .. 12 loop X := X & Character'Val (Character'Pos ('a') + Index - 1); end loop; Output ("test bounded string", echoBoundedStr (Myall_types, X) = X); exception when others => Output ("test bounded string", False); end; -- Bounded wide strings declare X : BoundedWStr := BoundedWStr (Bounded_Wide_String_11.Null_Bounded_Wide_String); begin for Index in 1 .. 8 loop X := X & Wide_Character'Val (Wide_Character'Pos ('a') + Index - 1); end loop; Output ("test bounded wide string", echoBoundedWStr (Myall_types, X) = X); exception when E : CORBA.Marshal => declare Member : CORBA.Marshal_Members; begin CORBA.Get_Members (E, Member); Output ("test bounded wstring", Member.Minor = OMGVMCID + 5); end; when E : CORBA.Inv_Objref => declare Member : CORBA.Inv_Objref_Members; begin CORBA.Get_Members (E, Member); Output ("test bounded wstring", Member.Minor = 2); end; when others => Output ("test bounded wstring", False); end; -- Exceptions Ok := False; declare Member : my_exception_Members; begin testException (Myall_types, 2485, To_CORBA_String ("pouet")); exception when E : my_exception => Ada.Text_IO.Put_Line (Ada.Exceptions.Exception_Information (E)); Get_Members (E, Member); Ok := Member.info = 2485 and then To_Standard_String (Member.why) = "pouet"; when E : others => Ada.Text_IO.Put_Line (Ada.Exceptions.Exception_Information (E)); end; Output ("test user exception", Ok); Ok := False; begin testUnknownException (Myall_types, 2485); exception when E : CORBA.Unknown => Ok := True; Ada.Text_IO.Put_Line (Ada.Exceptions.Exception_Information (E)); when others => null; end; Output ("test unknown exception", Ok); Ok := False; begin testSystemException (Myall_types, 2485); exception when CORBA.Bad_Param => Ok := True; when E : others => Ada.Text_IO.Put_Line (Ada.Exceptions.Exception_Information (E)); end; Output ("test system exception", Ok); <> null; end loop; if What /= All_Tests then Output ("test " & What'Img & " iterated" & Howmany'Img & " times", True); end if; begin StopServer (Myall_types); Ok := True; exception when others => Ok := False; raise; end; Output ("shut down server", Ok); End_Report; end Client; polyorb-2.8~20110207.orig/examples/corba/all_types/ir_server.adb0000644000175000017500000000435711750740337023771 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- I R _ S E R V E R -- -- -- -- B o d y -- -- -- -- Copyright (C) 2002 Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by ACT Europe. -- -- (email: sales@act-europe.fr) -- -- -- ------------------------------------------------------------------------------ with PolyORB.CORBA_P.Server_Tools; with Server; with all_types.IR_Info; procedure IR_Server is begin PolyORB.CORBA_P.Server_Tools.Initiate_Server_Hook := all_types.IR_Info.Register_IR_Info'Access; Server; end IR_Server; polyorb-2.8~20110207.orig/examples/corba/secure_echo/0000755000175000017500000000000011750740340021572 5ustar xavierxavierpolyorb-2.8~20110207.orig/examples/corba/secure_echo/tls_gssup_example.in0000644000175000017500000000141511750740337025667 0ustar xavierxavier#!/bin/sh rm -rf .ca mkdir .ca touch .ca/index.txt echo "01" > .ca/serial openssl genrsa -out root.key 2048 openssl req -new -x509 -key root.key -out root.crt \ -config ./ca_openssl.conf openssl genrsa -out polyorb.key 2048 openssl req -new -key polyorb.key -out polyorb.req \ -config ./polyorb_openssl.conf echo -e "y\ny" | openssl ca -keyfile root.key -cert root.crt \ -in polyorb.req -out polyorb.crt \ -config ./ca_openssl.conf || true rm -rf .ca trap "killall server client; rm -f ior" 0 1 2 3 15 POLYORB_CONF=tls_gssup.conf ./server | tee ior & j=0 while [ $j -lt 20 ]; do [ -f ior ] && [ `wc -l ior | cut -d ' ' -f 1` -ne 0 ] && break sleep 1 j=`expr $j + 1` done POLYORB_CONF=tls_gssup.conf ./client `cat ior | head -n 1 | cut -d "'" -f 2` polyorb-2.8~20110207.orig/examples/corba/secure_echo/polyorb_openssl.conf0000644000175000017500000000023511750740337025700 0ustar xavierxavier[req] default_bits = 2048 distinguished_name = user_distinguished_name prompt = no [user_distinguished_name] O = PolyORB Development Team CN = PolyORB User polyorb-2.8~20110207.orig/examples/corba/secure_echo/echo-impl.ads0000644000175000017500000000460511750740337024153 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- E C H O . I M P L -- -- -- -- S p e c -- -- -- -- Copyright (C) 2002-2008, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with CORBA; with PortableServer; package Echo.Impl is -- My own implementation of echo object. -- This is simply used to define the operations. type Object is new PortableServer.Servant_Base with null record; type Object_Acc is access Object; function EchoString (Self : access Object; Mesg : CORBA.String) return CORBA.String; end Echo.Impl; polyorb-2.8~20110207.orig/examples/corba/secure_echo/echo.idl0000644000175000017500000000007211750740337023207 0ustar xavierxavierinterface Echo { string echoString (in string Mesg); }; polyorb-2.8~20110207.orig/examples/corba/secure_echo/tls_gssup.conf.in0000644000175000017500000000132011750740337025073 0ustar xavierxavier[security_manager] own_credentials=tls_gssup_credentials establish_trust_in_target_required=true [access_points] diop=disable [tls_gssup_credentials] transport_credentials_type=tls authentication_credentials_type=gssup tls.method=tls1 tls.ciphers=ALL tls.verify_peer=true tls.verify_fail_if_no_peer_certificate=true tls.private_key_file=polyorb.key tls.certificate_file=polyorb.crt tls.certificate_authority_file=root.crt gssup.username=user gssup.password=password gssup.target_name=@domain [tlsiop] [gssup_authentication] mechanism=gssup gssup.target_name=@domain gssup.passwd_file=@srcdir@/passwd.pwd [My_POA] transport_mechanism=tlsiop authentication_mechanism=gssup_authentication authentication_required=true polyorb-2.8~20110207.orig/examples/corba/secure_echo/gssup.conf.in0000644000175000017500000000062111750740337024214 0ustar xavierxavier[security_manager] own_credentials=gssup_credentials [access_points] diop=disable [gssup_credentials] authentication_credentials_type=gssup gssup.username=user gssup.password=password gssup.target_name=@domain [gssup_authentication] mechanism=gssup gssup.target_name=@domain gssup.passwd_file=@srcdir@/passwd.pwd [My_POA] authentication_mechanism=gssup_authentication authentication_required=true polyorb-2.8~20110207.orig/examples/corba/secure_echo/Makefile.local0000644000175000017500000000013511750740337024330 0ustar xavierxavier${current_dir}echo.idl-stamp: idlac_flags := -d ${test_target}: ${current_dir}echo.idl-stamp polyorb-2.8~20110207.orig/examples/corba/secure_echo/client.ads0000644000175000017500000000403111750740337023545 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- C L I E N T -- -- -- -- S p e c -- -- -- -- Copyright (C) 2006-2007, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ procedure Client; polyorb-2.8~20110207.orig/examples/corba/secure_echo/passwd.pwd0000644000175000017500000000001611750740337023612 0ustar xavierxavieruser:password polyorb-2.8~20110207.orig/examples/corba/secure_echo/gssup_example.in0000644000175000017500000000140511750740337025004 0ustar xavierxavier#!/bin/sh rm -rf .ca mkdir .ca touch .ca/index.txt echo "01" > .ca/serial openssl genrsa -out root.key 2048 openssl req -new -x509 -key root.key -out root.crt \ -config ./ca_openssl.conf openssl genrsa -out polyorb.key 2048 openssl req -new -key polyorb.key -out polyorb.req \ -config ./polyorb_openssl.conf echo -e "y\ny" | openssl ca -keyfile root.key -cert root.crt \ -in polyorb.req -out polyorb.crt \ -config ./ca_openssl.conf || true rm -rf .ca trap "killall server client; rm -f ior" 0 1 2 3 15 POLYORB_CONF=gssup.conf ./server | tee ior & j=0 while [ $j -lt 20 ]; do [ -f ior ] && [ `wc -l ior | cut -d ' ' -f 1` -ne 0 ] && break sleep 1 j=`expr $j + 1` done POLYORB_CONF=gssup.conf ./client `cat ior | head -n 1 | cut -d "'" -f 2` polyorb-2.8~20110207.orig/examples/corba/secure_echo/server.ads0000644000175000017500000000403111750740337023575 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- S E R V E R -- -- -- -- S p e c -- -- -- -- Copyright (C) 2006-2007, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ procedure Server; polyorb-2.8~20110207.orig/examples/corba/secure_echo/ca_openssl.conf0000644000175000017500000000060311750740337024574 0ustar xavierxavier[req] default_bits = 2048 distinguished_name = ca_distinguished_name prompt = no [ca_distinguished_name] O = PolyORB's Development Team CN = PolyORB's Certificate Authority [ca] default_ca = ca dir = .ca new_certs_dir = $dir serial = $dir/serial database = $dir/index.txt default_days = 365 default_md = md5 policy = policy [policy] polyorb-2.8~20110207.orig/examples/corba/secure_echo/tls.conf.in0000644000175000017500000000064511750740337023663 0ustar xavierxavier[security_manager] own_credentials=tls_credentials establish_trust_in_target_required=true [access_points] diop=disable [tls_credentials] transport_credentials_type=tls tls.method=tls1 tls.ciphers=ALL tls.verify_peer=true tls.verify_fail_if_no_peer_certificate=true tls.private_key_file=polyorb.key tls.certificate_file=polyorb.crt tls.certificate_authority_file=root.crt [tlsiop] [My_POA] transport_mechanism=tlsiop polyorb-2.8~20110207.orig/examples/corba/secure_echo/echo-impl.adb0000644000175000017500000000576111750740337024136 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- E C H O . I M P L -- -- -- -- B o d y -- -- -- -- Copyright (C) 2002-2008, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with Ada.Command_Line; with Ada.Text_IO; with CORBA.ORB; with Echo.Skel; pragma Warnings (Off, Echo.Skel); -- No entity from Echo.Skel is referenced. package body Echo.Impl is ---------------- -- EchoString -- ---------------- function EchoString (Self : access Object; Mesg : CORBA.String) return CORBA.String is pragma Warnings (Off); pragma Unreferenced (Self); pragma Warnings (On); myEcho : Ref; begin if Ada.Command_Line.Argument_Count = 1 then Ada.Text_IO.Put_Line ("Forwarding string: « " & CORBA.To_Standard_String (Mesg) & " »"); CORBA.ORB.String_To_Object (CORBA.To_CORBA_String (Ada.Command_Line.Argument (1)), myEcho); return echoString (myEcho, Mesg); else Ada.Text_IO.Put_Line ("Echoing string: « " & CORBA.To_Standard_String (Mesg) & " »"); return Mesg; end if; end EchoString; end Echo.Impl; polyorb-2.8~20110207.orig/examples/corba/secure_echo/local.gpr0000644000175000017500000000070211750740337023403 0ustar xavierxavierwith "polyorb", "polyorb_test_common"; project local is Dir := external ("Test_Dir"); Obj_Dir := PolyORB_Test_Common.Build_Dir & Dir; for Object_Dir use Obj_Dir; for Source_Dirs use (Obj_Dir, PolyORB_Test_Common.Source_Dir & Dir); package Compiler is for Default_Switches ("Ada") use PolyORB_Test_Common.Compiler'Default_Switches ("Ada"); end Compiler; for Main use ("client.adb", "server.adb"); end local; polyorb-2.8~20110207.orig/examples/corba/secure_echo/server.adb0000644000175000017500000001030111750740337023551 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- S E R V E R -- -- -- -- B o d y -- -- -- -- Copyright (C) 2002-2007, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with Ada.Exceptions; with Ada.Text_IO; with CORBA.Impl; with CORBA.Object; with CORBA.ORB; with CORBA.Policy; with PortableServer.POA.Helper; with PortableServer.POAManager; with Echo.Impl; -- Setup server node: use no tasking default configuration with PolyORB.Setup.Thread_Pool_Server; pragma Warnings (Off, PolyORB.Setup.Thread_Pool_Server); with PolyORB.Setup.Secure_Client; pragma Warnings (Off, PolyORB.Setup.Secure_Client); with PolyORB.Setup.Secure_Server; pragma Warnings (Off, PolyORB.Setup.Secure_Server); procedure Server is begin declare Argv : CORBA.ORB.Arg_List := CORBA.ORB.Command_Line_Arguments; begin CORBA.ORB.Init (CORBA.ORB.To_CORBA_String ("ORB"), Argv); declare Root_POA : PortableServer.POA.Local_Ref; My_POA : PortableServer.POA.Local_Ref; Ref : CORBA.Object.Ref; Obj : constant CORBA.Impl.Object_Ptr := new Echo.Impl.Object; begin -- Retrieve Root POA Root_POA := PortableServer.POA.Helper.To_Local_Ref (CORBA.ORB.Resolve_Initial_References (CORBA.ORB.To_CORBA_String ("RootPOA"))); PortableServer.POAManager.Activate (PortableServer.POA.Get_The_POAManager (Root_POA)); -- Create My POA declare Policies : CORBA.Policy.PolicyList; begin My_POA := PortableServer.POA.Local_Ref (PortableServer.POA.Create_POA (Root_POA, CORBA.To_CORBA_String ("My_POA"), PortableServer.POA.Get_The_POAManager (Root_POA), Policies)); end; -- Set up new object Ref := PortableServer.POA.Servant_To_Reference (My_POA, PortableServer.Servant (Obj)); -- Output IOR Ada.Text_IO.Put_Line ("'" & CORBA.To_Standard_String (CORBA.Object.Object_To_String (Ref)) & "'"); Ada.Text_IO.New_Line; -- Launch the server CORBA.ORB.Run; end; end; exception when E : others => Ada.Text_IO.Put_Line (Ada.Exceptions.Exception_Information (E)); CORBA.ORB.Shutdown (False); raise; end Server; polyorb-2.8~20110207.orig/examples/corba/secure_echo/tls_example.in0000644000175000017500000000140111750740337024441 0ustar xavierxavier#!/bin/sh rm -rf .ca mkdir .ca touch .ca/index.txt echo "01" > .ca/serial openssl genrsa -out root.key 2048 openssl req -new -x509 -key root.key -out root.crt \ -config ./ca_openssl.conf openssl genrsa -out polyorb.key 2048 openssl req -new -key polyorb.key -out polyorb.req \ -config ./polyorb_openssl.conf echo -e "y\ny" | openssl ca -keyfile root.key -cert root.crt \ -in polyorb.req -out polyorb.crt \ -config ./ca_openssl.conf || true rm -rf .ca trap "killall server client; rm -f ior" 0 1 2 3 15 POLYORB_CONF=tls.conf ./server | tee ior & j=0 while [ $j -lt 20 ]; do [ -f ior ] && [ `wc -l ior | cut -d ' ' -f 1` -ne 0 ] && break sleep 1 j=`expr $j + 1` done POLYORB_CONF=tls.conf ./client `cat ior | head -n 1 | cut -d "'" -f 2` polyorb-2.8~20110207.orig/examples/corba/secure_echo/client.adb0000644000175000017500000001740511750740337023535 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- C L I E N T -- -- -- -- B o d y -- -- -- -- Copyright (C) 2002-2007, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- echo client. with Ada.Command_Line; with Ada.Exceptions; with Ada.Text_IO; with CORBA.ORB; with Echo; with PolyORB.Setup.Thread_Pool_Server; pragma Warnings (Off, PolyORB.Setup.Thread_Pool_Server); with PolyORB.Utils.Report; with PortableServer.POA; pragma Warnings (Off, PortableServer.POA); with PolyORB.Setup.Secure_Client; pragma Warnings (Off, PolyORB.Setup.Secure_Client); with Ada.Characters.Handling; with Ada.Streams; with CORBA.Object; with PolyORB.Binding_Data; with PolyORB.Binding_Data_QoS; with PolyORB.QoS.Tagged_Components; with PolyORB.References; procedure Client is use Ada.Command_Line; use Ada.Text_IO; use PolyORB.Utils.Report; use Ada.Characters.Handling; use Ada.Streams; task type Thread is entry Run (My_Ref : Echo.Ref); end Thread; procedure Put (Item : Ada.Streams.Stream_Element_Array); To_Hex_Digit : constant array (Stream_Element range 0 .. 15) of Character := (0 => '0', 1 => '1', 2 => '2', 3 => '3', 4 => '4', 5 => '5', 6 => '6', 7 => '7', 8 => '8', 9 => '9', 10 => 'A', 11 => 'B', 12 => 'C', 13 => 'D', 14 => 'E', 15 => 'F'); --------- -- Put -- --------- procedure Put (Item : Ada.Streams.Stream_Element_Array) is First : Stream_Element_Offset := Item'First; Last : Stream_Element_Offset; Tail : Stream_Element_Offset := 0; begin while First <= Item'Last loop Last := First + 16; Put (" "); if Last > Item'Last then Tail := Last - Item'Last; Last := Item'Last; end if; for J in First .. Last loop Put (' '); Put (To_Hex_Digit (Item (J) / 16)); Put (To_Hex_Digit (Item (J) mod 16)); end loop; for J in 1 .. Tail loop Put (" "); end loop; Put (" "); for J in First .. Last loop if Is_Graphic (Character'Val (Item (J))) then Put (Character'Val (Item (J))); else Put ('.'); end if; end loop; New_Line; First := Last + 1; end loop; end Put; Calls : Positive := 1; Threads : Positive := 1; task body Thread is Ref : Echo.Ref; Sent_Msg, Rcvd_Msg : CORBA.String; begin select accept Run (My_Ref : Echo.Ref) do Ref := My_Ref; end Run; or terminate; end select; for J in 1 .. Calls loop begin -- Sending message Sent_Msg := CORBA.To_CORBA_String (Standard.String'("Hello Ada !")); Rcvd_Msg := Echo.echoString (Ref, Sent_Msg); -- Printing result Put_Line ("I said : " & CORBA.To_Standard_String (Sent_Msg)); Put_Line ("The object answered : " & CORBA.To_Standard_String (Rcvd_Msg)); exception when E : others => Put_Line (Ada.Exceptions.Exception_Information (E)); end; end loop; end Thread; begin New_Test ("Echo client"); CORBA.ORB.Initialize ("ORB"); if Argument_Count < 1 then Put_Line ("usage : client " & " [] []"); return; end if; if Argument_Count >= 2 then Calls := Positive'Value (Argument (2)); end if; if Argument_Count >= 3 then Threads := Positive'Value (Argument (3)); end if; declare myecho : Echo.Ref; Aux : array (Positive range 1 .. Threads) of Thread; begin -- Getting the CORBA.Object CORBA.ORB.String_To_Object (CORBA.To_CORBA_String (Ada.Command_Line.Argument (1)), myecho); declare use PolyORB.Binding_Data; use PolyORB.Binding_Data_QoS; use PolyORB.QoS; use PolyORB.QoS.Tagged_Components; use PolyORB.QoS.Tagged_Components.GIOP_Tagged_Component_Lists; use PolyORB.References; Profiles : constant Profile_Array := Profiles_Of (CORBA.Object.Internals.To_PolyORB_Ref (CORBA.Object.Ref (myecho))); QoS : QoS_GIOP_Tagged_Components_Parameter_Access; Iter : Iterator; begin for J in Profiles'Range loop Put_Line (Profile_Tag'Image (Get_Profile_Tag (Profiles (J).all))); QoS := QoS_GIOP_Tagged_Components_Parameter_Access (Get_Profile_QoS (Profiles (J), GIOP_Tagged_Components)); if QoS /= null then Iter := First (QoS.Components); while not Last (Iter) loop Put_Line (Component_Id'Image (Value (Iter).Tag)); Put (Value (Iter).Data.all); Next (Iter); end loop; end if; end loop; end; -- Checking if it worked if Echo.Is_Nil (myecho) then Put_Line ("main : cannot invoke on a nil reference"); return; end if; for J in Aux'Range loop Aux (J).Run (myecho); end loop; end; CORBA.ORB.Shutdown (False); End_Report; exception when E : CORBA.Transient => declare Memb : CORBA.System_Exception_Members; begin CORBA.Get_Members (E, Memb); Put ("received exception transient, minor"); Put (CORBA.Unsigned_Long'Image (Memb.Minor)); Put (", completion status: "); Put_Line (CORBA.Completion_Status'Image (Memb.Completed)); End_Report; end; CORBA.ORB.Shutdown (False); when E : others => Ada.Text_IO.Put_Line (Ada.Exceptions.Exception_Information (E)); CORBA.ORB.Shutdown (False); end Client; polyorb-2.8~20110207.orig/examples/corba/echo/0000755000175000017500000000000011750740340020224 5ustar xavierxavierpolyorb-2.8~20110207.orig/examples/corba/echo/delegated_server.ads0000644000175000017500000000516611750740337024237 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- D E L E G A T E D _ S E R V E R -- -- -- -- S p e c -- -- -- -- Copyright (C) 2002-2008, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by ACT Europe. -- -- (email: sales@act-europe.fr) -- -- -- ------------------------------------------------------------------------------ with CORBA.Object; with Echo.Delegate; package Delegated_Server is function Echo_With_Delegation (Self : access Integer; Mesg : CORBA.String) return CORBA.String; -- Function that will be called when a delegation is used. Note that -- the Self integer has no meaning here, but a Self is mandatory. package Delegated is new Echo.Delegate (Wrapped => Integer, echoString => Echo_With_Delegation); -- The package Echo.Delegate is instantiated, with the dummy Integer -- type as the "real" type. Dummy : aliased Integer; -- A dummy "object" end Delegated_Server; polyorb-2.8~20110207.orig/examples/corba/echo/echo-impl.ads0000644000175000017500000000460511750740337022605 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- E C H O . I M P L -- -- -- -- S p e c -- -- -- -- Copyright (C) 2002-2008, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by ACT Europe. -- -- (email: sales@act-europe.fr) -- -- -- ------------------------------------------------------------------------------ with CORBA; with PortableServer; package Echo.Impl is -- My own implementation of echo object. -- This is simply used to define the operations. type Object is new PortableServer.Servant_Base with null record; type Object_Acc is access Object; function EchoString (Self : access Object; Mesg : CORBA.String) return CORBA.String; end Echo.Impl; polyorb-2.8~20110207.orig/examples/corba/echo/echo.idl0000644000175000017500000000007211750740337021641 0ustar xavierxavierinterface Echo { string echoString (in string Mesg); }; polyorb-2.8~20110207.orig/examples/corba/echo/dynserver.adb0000644000175000017500000000730111750740337022724 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- D Y N S E R V E R -- -- -- -- B o d y -- -- -- -- Copyright (C) 2004-2007, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- echo dynamic server, using the Dynamic Skeleton Interface (DSI) with Ada.Text_IO; with CORBA.Impl; with CORBA.Object; with CORBA.ORB; with PortableServer.POA.Helper; with PortableServer.POAManager; with PolyORB.CORBA_P.CORBALOC; with Echo_DynImpl; -- Setup server node: use no tasking default configuration with PolyORB.Setup.No_Tasking_Server; pragma Warnings (Off, PolyORB.Setup.No_Tasking_Server); procedure DynServer is begin declare Argv : CORBA.ORB.Arg_List := CORBA.ORB.Command_Line_Arguments; begin CORBA.ORB.Init (CORBA.ORB.To_CORBA_String ("ORB"), Argv); declare Root_POA : PortableServer.POA.Local_Ref; Ref : CORBA.Object.Ref; Obj : constant CORBA.Impl.Object_Ptr := new Echo_DynImpl.Object; begin -- Retrieve Root POA Root_POA := PortableServer.POA.Helper.To_Local_Ref (CORBA.ORB.Resolve_Initial_References (CORBA.ORB.To_CORBA_String ("RootPOA"))); PortableServer.POAManager.Activate (PortableServer.POA.Get_The_POAManager (Root_POA)); -- Set up new object Ref := PortableServer.POA.Servant_To_Reference (Root_POA, PortableServer.Servant (Obj)); -- Output IOR Ada.Text_IO.Put_Line ("'" & CORBA.To_Standard_String (CORBA.Object.Object_To_String (Ref)) & "'"); Ada.Text_IO.New_Line; -- Output corbaloc Ada.Text_IO.Put_Line ("'" & CORBA.To_Standard_String (PolyORB.CORBA_P.CORBALOC.Object_To_Corbaloc (Ref)) & "'"); -- Launch the server CORBA.ORB.Run; end; end; end DynServer; polyorb-2.8~20110207.orig/examples/corba/echo/echo_dynimpl.ads0000644000175000017500000000456011750740337023402 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- E C H O _ D Y N I M P L -- -- -- -- S p e c -- -- -- -- Copyright (C) 2004-2008, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by ACT Europe. -- -- (email: sales@act-europe.fr) -- -- -- ------------------------------------------------------------------------------ -- Implementation of a dynamic servant, using the Dynamic Skeleton -- Interface (DSI). with CORBA.ServerRequest; with PortableServer; package Echo_DynImpl is type Object is new PortableServer.DynamicImplementation with null record; procedure Invoke (Self : access Object; Request : CORBA.ServerRequest.Object_Ptr); end Echo_DynImpl; polyorb-2.8~20110207.orig/examples/corba/echo/soap_message0000644000175000017500000000075511750740337022632 0ustar xavierxavier Hello Ada ! polyorb-2.8~20110207.orig/examples/corba/echo/Makefile.local0000644000175000017500000000013511750740337022762 0ustar xavierxavier${current_dir}echo.idl-stamp: idlac_flags := -d ${test_target}: ${current_dir}echo.idl-stamp polyorb-2.8~20110207.orig/examples/corba/echo/dynclient.adb0000644000175000017500000001150511750740337022675 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- D Y N C L I E N T -- -- -- -- B o d y -- -- -- -- Copyright (C) 2002-2007, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- echo dynamic client, using the Dynamic Invocation Interface (DII) with Ada.Command_Line; with Ada.Text_IO; with CORBA.Object; with CORBA.Context; with CORBA.Request; with CORBA.NVList; with CORBA.ORB; with PolyORB.Setup.Client; pragma Warnings (Off, PolyORB.Setup.Client); with PolyORB.Utils.Report; procedure DynClient is use Ada.Text_IO; use PolyORB.Utils.Report; use CORBA; myecho : CORBA.Object.Ref; ------------- -- Do_Test -- ------------- procedure Do_Test; procedure Do_Test is Sent_Msg : constant CORBA.String := To_CORBA_String ("Hello Dynamic World"); Operation_Name : constant CORBA.Identifier := To_CORBA_String ("echoString"); Arg_Name : constant CORBA.Identifier := To_CORBA_String ("Mesg"); Request : CORBA.Request.Object; Ctx : CORBA.Context.Ref; Argument : CORBA.Any; Arg_List : CORBA.NVList.Ref; Result : CORBA.NamedValue; Result_Name : constant CORBA.String := To_CORBA_String ("Result"); Recv_Msg : CORBA.String; begin -- Creating the argument list CORBA.ORB.Create_List (0, Arg_List); Argument := CORBA.To_Any (Sent_Msg); CORBA.NVList.Add_Item (Arg_List, Arg_Name, Argument, CORBA.ARG_IN); -- Setting the result type Result := (Name => CORBA.Identifier (Result_Name), Argument => Internals.Get_Empty_Any (CORBA.TC_String), Arg_Modes => 0); -- Creating a request CORBA.Object.Create_Request (myecho, Ctx, Operation_Name, Arg_List, Result, Request, 0); -- Sending message CORBA.Request.Invoke (Request, 0); -- Getting the answer Recv_Msg := From_Any (Result.Argument); -- Printing the result Put_Line ("I said : " & CORBA.To_Standard_String (Sent_Msg)); Put_Line ("The object answered : " & CORBA.To_Standard_String (Recv_Msg)); end Do_Test; Iter : Natural := 1; begin New_Test ("Echo dynamic client using the DII"); CORBA.ORB.Initialize ("ORB"); if Ada.Command_Line.Argument_Count < 1 then Put_Line ("usage : dynclient [niter]"); return; end if; -- Getting a reference on the CORBA object CORBA.ORB.String_To_Object (To_CORBA_String (Ada.Command_Line.Argument (1)), myecho); if Ada.Command_Line.Argument_Count > 1 then Iter := Integer'Value (Ada.Command_Line.Argument (2)); end if; for J in 1 .. Iter loop Do_Test; end loop; End_Report; end DynClient; polyorb-2.8~20110207.orig/examples/corba/echo/echo-impl.adb0000644000175000017500000000510511750740337022560 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- E C H O . I M P L -- -- -- -- B o d y -- -- -- -- Copyright (C) 2002-2008, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by ACT Europe. -- -- (email: sales@act-europe.fr) -- -- -- ------------------------------------------------------------------------------ with Ada.Text_IO; with Echo.Skel; pragma Warnings (Off, Echo.Skel); -- No entity from Echo.Skel is referenced. package body Echo.Impl is ---------------- -- EchoString -- ---------------- function EchoString (Self : access Object; Mesg : CORBA.String) return CORBA.String is pragma Warnings (Off); pragma Unreferenced (Self); pragma Warnings (On); begin Ada.Text_IO.Put_Line ("Echoing string: « " & CORBA.To_Standard_String (Mesg) & " »"); return Mesg; end EchoString; end Echo.Impl; polyorb-2.8~20110207.orig/examples/corba/echo/delegated_server.adb0000644000175000017500000000447711750740337024222 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- D E L E G A T E D _ S E R V E R -- -- -- -- B o d y -- -- -- -- Copyright (C) 2002-2008, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by ACT Europe. -- -- (email: sales@act-europe.fr) -- -- -- ------------------------------------------------------------------------------ package body Delegated_Server is function Echo_With_Delegation (Self : access Integer; Mesg : CORBA.String) return CORBA.String is begin return CORBA.To_CORBA_String (CORBA.To_Standard_String (Mesg) & " (via delegation)"); end Echo_With_Delegation; end Delegated_Server; polyorb-2.8~20110207.orig/examples/corba/echo/echo_dynimpl.adb0000644000175000017500000000736211750740337023364 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- E C H O _ D Y N I M P L -- -- -- -- B o d 8 -- -- -- -- Copyright (C) 2004-2008, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with CORBA.NVList; with CORBA.ORB; package body Echo_DynImpl is ------------ -- Invoke -- ------------ procedure Invoke (Self : access Object; Request : CORBA.ServerRequest.Object_Ptr) is pragma Unreferenced (Self); Operation : constant Standard.String := CORBA.To_Standard_String (CORBA.ServerRequest.Operation (Request.all)); begin if Operation = "echoString" then declare Mesg : CORBA.String; Arg_Name_Mesg : constant CORBA.Identifier := CORBA.To_CORBA_String ("Mesg"); Argument_Mesg : constant CORBA.Any := CORBA.To_Any (Mesg); Result : CORBA.String; Argument_Result : CORBA.Any; Arg_List : CORBA.NVList.Ref; begin -- Create argument list CORBA.ORB.Create_List (0, Arg_List); CORBA.NVList.Add_Item (Arg_List, Arg_Name_Mesg, Argument_Mesg, CORBA.ARG_IN); CORBA.ServerRequest.Arguments (Request, Arg_List); begin -- Convert arguments from their Any Mesg := CORBA.From_Any (Argument_Mesg); -- Actual implementation of the echoString function: -- simply return the argument Result := Mesg; end; -- Set Result Argument_Result := CORBA.To_Any (Result); CORBA.ServerRequest.Set_Result (Request, Argument_Result); return; end; end if; CORBA.Raise_Bad_Operation (CORBA.Default_Sys_Member); end Invoke; end Echo_DynImpl; polyorb-2.8~20110207.orig/examples/corba/echo/local.gpr0000644000175000017500000000074411750740337022043 0ustar xavierxavierwith "polyorb", "polyorb_test_common"; project local is Dir := external ("Test_Dir"); Obj_Dir := PolyORB_Test_Common.Build_Dir & Dir; for Object_Dir use Obj_Dir; for Source_Dirs use (Obj_Dir, PolyORB_Test_Common.Source_Dir & Dir); package Compiler is for Default_Switches ("Ada") use PolyORB_Test_Common.Compiler'Default_Switches ("Ada"); end Compiler; for Main use ("client.adb", "server.adb", "dynclient.adb", "dynserver.adb"); end local; polyorb-2.8~20110207.orig/examples/corba/echo/server.adb0000644000175000017500000000716011750740337022214 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- S E R V E R -- -- -- -- B o d y -- -- -- -- Copyright (C) 2002-2007, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with Ada.Text_IO; with CORBA.Impl; with CORBA.Object; with CORBA.ORB; with PortableServer.POA.Helper; with PortableServer.POAManager; with Echo.Impl; with PolyORB.CORBA_P.CORBALOC; -- Setup server node: use no tasking default configuration with PolyORB.Setup.No_Tasking_Server; pragma Warnings (Off, PolyORB.Setup.No_Tasking_Server); procedure Server is begin declare Argv : CORBA.ORB.Arg_List := CORBA.ORB.Command_Line_Arguments; begin CORBA.ORB.Init (CORBA.ORB.To_CORBA_String ("ORB"), Argv); declare Root_POA : PortableServer.POA.Local_Ref; Ref : CORBA.Object.Ref; Obj : constant CORBA.Impl.Object_Ptr := new Echo.Impl.Object; begin -- Retrieve Root POA Root_POA := PortableServer.POA.Helper.To_Local_Ref (CORBA.ORB.Resolve_Initial_References (CORBA.ORB.To_CORBA_String ("RootPOA"))); PortableServer.POAManager.Activate (PortableServer.POA.Get_The_POAManager (Root_POA)); -- Set up new object Ref := PortableServer.POA.Servant_To_Reference (Root_POA, PortableServer.Servant (Obj)); -- Output IOR Ada.Text_IO.Put_Line ("'" & CORBA.To_Standard_String (CORBA.Object.Object_To_String (Ref)) & "'"); Ada.Text_IO.New_Line; -- Output corbaloc Ada.Text_IO.Put_Line ("'" & CORBA.To_Standard_String (PolyORB.CORBA_P.CORBALOC.Object_To_Corbaloc (Ref)) & "'"); -- Launch the server CORBA.ORB.Run; end; end; end Server; polyorb-2.8~20110207.orig/examples/corba/echo/client.adb0000644000175000017500000000704311750740337022164 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- C L I E N T -- -- -- -- B o d y -- -- -- -- Copyright (C) 2002-2004 Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by ACT Europe. -- -- (email: sales@act-europe.fr) -- -- -- ------------------------------------------------------------------------------ -- echo client. with Ada.Command_Line; with Ada.Text_IO; with CORBA.ORB; with Echo; with PolyORB.Setup.Client; pragma Warnings (Off, PolyORB.Setup.Client); with PolyORB.Utils.Report; procedure Client is use Ada.Command_Line; use Ada.Text_IO; use PolyORB.Utils.Report; Sent_Msg, Rcvd_Msg : CORBA.String; myecho : Echo.Ref; begin New_Test ("Echo client"); CORBA.ORB.Initialize ("ORB"); if Argument_Count /= 1 then Put_Line ("usage : client |-i"); return; end if; -- Getting the CORBA.Object CORBA.ORB.String_To_Object (CORBA.To_CORBA_String (Ada.Command_Line.Argument (1)), myecho); -- Checking if it worked if Echo.Is_Nil (myecho) then Put_Line ("main : cannot invoke on a nil reference"); return; end if; -- Sending message Sent_Msg := CORBA.To_CORBA_String (Standard.String'("Hello Ada !")); Rcvd_Msg := Echo.echoString (myecho, Sent_Msg); -- Printing result Put_Line ("I said : " & CORBA.To_Standard_String (Sent_Msg)); Put_Line ("The object answered : " & CORBA.To_Standard_String (Rcvd_Msg)); End_Report; exception when E : CORBA.Transient => declare Memb : CORBA.System_Exception_Members; begin CORBA.Get_Members (E, Memb); Put ("received exception transient, minor"); Put (CORBA.Unsigned_Long'Image (Memb.Minor)); Put (", completion status: "); Put_Line (CORBA.Completion_Status'Image (Memb.Completed)); End_Report; end; end Client; polyorb-2.8~20110207.orig/examples/corba/README0000644000175000017500000000106311750740337020174 0ustar xavierxavierREADME for the PolyORB CORBA examples ------------------------------------- $Id: README 113586 2007-07-16 16:42:17Z duff $ This directory contains CORBA examples. all_functions/ : tests CORBA method invocations, all_types/ : tests CORBA types, echo/ : simple echo program, random/ : random test, see http://www.random.org/corba.html for more details. send/ : test MIOP implementation secure_echo/ : simple echo program with enabled security and a set of demonstration configuration files polyorb-2.8~20110207.orig/examples/corba/all_functions/0000755000175000017500000000000011750740340022146 5ustar xavierxavierpolyorb-2.8~20110207.orig/examples/corba/all_functions/README0000644000175000017500000000163711750740337023043 0ustar xavierxavierREADME for the PolyORB all_types example ---------------------------------------- $Id: README 132810 2008-11-27 14:08:19Z quinot $ This demo tests the processing for various argument passing modes, both in the case where network communication is involved and in the case of local calls. Three executables are provided - server : a CORBA server application, provides various functions that receive and return values. - client : a CORBA client application, built to interact with 'server', test various combinations of argument modes - dynclient : same, using the DII * To run these tests : 1) client/server test : - launch server - launch client using the IOR string output by server as an argument The client will interact with the server, doing several tests. The different results are displayed on the client side. 2) local test : - launch 'server local' - the server runs the tests within the same partition polyorb-2.8~20110207.orig/examples/corba/all_functions/Makefile.local0000644000175000017500000000015411750740337024705 0ustar xavierxavier${current_dir}all_functions.idl-stamp: idlac_flags := ${test_target}: ${current_dir}all_functions.idl-stamp polyorb-2.8~20110207.orig/examples/corba/all_functions/all_functions.idl0000644000175000017500000000256111750740337025512 0ustar xavierxavierinterface all_functions { // attributes attribute short the_attribute ; readonly attribute short the_readonly_attribute ; // procedures void void_proc() ; void in_proc(in short a, in short b, in short c) ; void out_proc(out short a, out short b, out short c) ; void out_in_proc (out short a, in long b) ; void inout_proc(inout short a, inout short b) ; void in_out_proc(in short a, in short b, out short c, out short d) ; void in_inout_proc(in short a, inout short b, in short c, inout short d) ; void out_inout_proc(out short a, inout short b, inout short c, out short d) ; void in_out_inout_proc(in short a, out short b, inout short c) ; // functions short void_fun() ; short in_fun(in short a, in short b, in short c) ; short out_fun(out short a, out short b, out short c) ; short inout_fun(inout short a, inout short b) ; short in_out_fun(in short a, in short b, out short c, out short d) ; short in_inout_fun(in short a, inout short b, in short c, inout short d) ; short out_inout_fun(out short a, inout short b, inout short c, out short d) ; short in_out_inout_fun(in short a, out short b, inout short c) ; // oneway procedures oneway void oneway_void_proc() ; oneway void oneway_in_proc(in short a, in short b) ; short oneway_checker() ; // Shut down server void StopServer (); }; polyorb-2.8~20110207.orig/examples/corba/all_functions/dynclient.adb0000644000175000017500000014527411750740337024632 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- D Y N C L I E N T -- -- -- -- B o d y -- -- -- -- Copyright (C) 2002-2008, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with Ada.Command_Line; with Ada.Text_IO; -- with Ada.Exceptions; with CORBA; use CORBA; with CORBA.Object; with CORBA.Context; with CORBA.Request; with CORBA.NVList; with CORBA.ORB; with PolyORB.Utils.Report; with PolyORB.Setup.Client; pragma Warnings (Off, PolyORB.Setup.Client); procedure Dynclient is use PolyORB.Utils.Report; IOR : CORBA.String; Myall_Functions : CORBA.Object.Ref; I, J, K, L, M : CORBA.Short; Ok : Boolean; function Get_The_Attribute return CORBA.Short; function Get_The_Attribute return CORBA.Short is Operation_Name : constant CORBA.Identifier := To_CORBA_String ("_get_the_attribute"); Request : CORBA.Request.Object; Ctx : CORBA.Context.Ref; Arg_List : CORBA.NVList.Ref; Result_Name : constant CORBA.String := To_CORBA_String ("Result"); Result : CORBA.NamedValue; begin -- creating the argument list CORBA.ORB.Create_List (0, Arg_List); -- setting the result type Result := (Name => Identifier (Result_Name), Argument => Internals.Get_Empty_Any (CORBA.TC_Short), Arg_Modes => 0); -- creating a request CORBA.Object.Create_Request (Myall_Functions, Ctx, Operation_Name, Arg_List, Result, Request, 0); -- sending message CORBA.Request.Invoke (Request, 0); -- getting the answer return From_Any (Result.Argument); end Get_The_Attribute; procedure Set_The_Attribute (To : CORBA.Short); procedure Set_The_Attribute (To : CORBA.Short) is Operation_Name : constant CORBA.Identifier := To_CORBA_String ("_set_the_attribute"); Arg_Name_To : constant CORBA.Identifier := To_CORBA_String ("to"); Request : CORBA.Request.Object; Ctx : CORBA.Context.Ref; Argument : CORBA.Any; Arg_List : CORBA.NVList.Ref; Result : CORBA.NamedValue; Result_Name : constant CORBA.String := To_CORBA_String ("Result"); begin -- creating the argument list CORBA.ORB.Create_List (0, Arg_List); Argument := CORBA.To_Any (To); CORBA.NVList.Add_Item (Arg_List, Arg_Name_To, Argument, CORBA.ARG_IN); -- setting the result type Result := (Name => Identifier (Result_Name), Argument => Internals.Get_Empty_Any (CORBA.TC_Void), Arg_Modes => 0); -- creating a request CORBA.Object.Create_Request (Myall_Functions, Ctx, Operation_Name, Arg_List, Result, Request, 0); -- sending message CORBA.Request.Invoke (Request, 0); end Set_The_Attribute; function Get_The_Readonly_Attribute return CORBA.Short; function Get_The_Readonly_Attribute return CORBA.Short is Operation_Name : constant CORBA.Identifier := To_CORBA_String ("_get_the_readonly_attribute"); Request : CORBA.Request.Object; Ctx : CORBA.Context.Ref; Arg_List : CORBA.NVList.Ref; Result : CORBA.NamedValue; Result_Name : constant CORBA.String := To_CORBA_String ("Result"); begin -- creating the argument list CORBA.ORB.Create_List (0, Arg_List); -- setting the result type Result := (Name => Identifier (Result_Name), Argument => Internals.Get_Empty_Any (CORBA.TC_Short), Arg_Modes => 0); -- creating a request CORBA.Object.Create_Request (Myall_Functions, Ctx, Operation_Name, Arg_List, Result, Request, 0); -- sending message CORBA.Request.Invoke (Request, 0); -- getting the answer return From_Any (Result.Argument); end Get_The_Readonly_Attribute; procedure Void_Proc; procedure Void_Proc is Operation_Name : constant CORBA.Identifier := To_CORBA_String ("void_proc"); Request : CORBA.Request.Object; Ctx : CORBA.Context.Ref; Arg_List : CORBA.NVList.Ref; Result : CORBA.NamedValue; Result_Name : constant CORBA.String := To_CORBA_String ("Result"); begin -- creating the argument list CORBA.ORB.Create_List (0, Arg_List); -- setting the result type Result := (Name => Identifier (Result_Name), Argument => Internals.Get_Empty_Any (CORBA.TC_Void), Arg_Modes => 0); -- creating a request CORBA.Object.Create_Request (Myall_Functions, Ctx, Operation_Name, Arg_List, Result, Request, 0); -- sending message CORBA.Request.Invoke (Request, 0); end Void_Proc; procedure In_Proc (A, B, C : CORBA.Short); procedure In_Proc (A, B, C : CORBA.Short) is Operation_Name : constant CORBA.Identifier := To_CORBA_String ("in_proc"); Arg_Name_A : constant CORBA.Identifier := To_CORBA_String ("a"); Arg_Name_B : constant CORBA.Identifier := To_CORBA_String ("b"); Arg_Name_C : constant CORBA.Identifier := To_CORBA_String ("c"); Request : CORBA.Request.Object; Ctx : CORBA.Context.Ref; Argument_A : constant CORBA.Any := CORBA.To_Any (A); Argument_B : constant CORBA.Any := CORBA.To_Any (B); Argument_C : constant CORBA.Any := CORBA.To_Any (C); Arg_List : CORBA.NVList.Ref; Result : CORBA.NamedValue; Result_Name : constant CORBA.String := To_CORBA_String ("Result"); begin -- creating the argument list CORBA.ORB.Create_List (0, Arg_List); CORBA.NVList.Add_Item (Arg_List, Arg_Name_A, Argument_A, CORBA.ARG_IN); CORBA.NVList.Add_Item (Arg_List, Arg_Name_B, Argument_B, CORBA.ARG_IN); CORBA.NVList.Add_Item (Arg_List, Arg_Name_C, Argument_C, CORBA.ARG_IN); -- setting the result type Result := (Name => Identifier (Result_Name), Argument => Internals.Get_Empty_Any (CORBA.TC_Void), Arg_Modes => 0); -- creating a request CORBA.Object.Create_Request (Myall_Functions, Ctx, Operation_Name, Arg_List, Result, Request, 0); -- sending message CORBA.Request.Invoke (Request, 0); end In_Proc; -- procedure Out_Proc (Self : CORBA.Object.Ref; -- A, B, C : out CORBA.Short); -- procedure Out_Proc (Self : CORBA.Object.Ref; -- A, B, C : out CORBA.Short) is -- Operation_Name : CORBA.Identifier := To_CORBA_String ("out_proc"); -- Request : CORBA.Request.Object; -- Ctx : CORBA.Context.Ref; -- Arg_List : CORBA.NVList.Ref; -- Result : CORBA.NamedValue; -- Result_Name : CORBA.String := To_CORBA_String ("Result"); -- begin -- -- creating an empty argument list -- CORBA.ORB.Create_List (0, Arg_List); -- -- setting the result type -- Result := (Name => Identifier (Result_Name), -- Argument => Get_Empty_Any (CORBA.TC_Void), -- Arg_Modes => 0); -- -- creating a request -- CORBA.Object.Create_Request (Myall_Functions, -- Ctx, -- Operation_Name, -- Arg_List, -- Result, -- Request, -- 0); -- -- adding some arguments to the request -- CORBA.Request.Add_Arg (Request, -- CORBA.TC_Short, -- A'Address, -- CORBA.Short'Size, -- CORBA.ARG_OUT); -- CORBA.Request.Add_Arg (Request, -- CORBA.TC_Short, -- B'Address, -- CORBA.Short'Size, -- CORBA.ARG_OUT); -- CORBA.Request.Add_Arg (Request, -- CORBA.TC_Short, -- C'Address, -- CORBA.Short'Size, -- CORBA.ARG_OUT); -- -- sending message -- CORBA.Request.Invoke (Request, 0); -- end Out_Proc; -- procedure Inout_Proc (Self : CORBA.Object.Ref; -- A, B : in out CORBA.Short); -- procedure Inout_Proc (Self : CORBA.Object.Ref; -- A, B : in out CORBA.Short) is -- Operation_Name : CORBA.Identifier := To_CORBA_String ("inout_proc"); -- Arg_Name_A : CORBA.Identifier := To_CORBA_String ("a"); -- Arg_Name_B : CORBA.Identifier := To_CORBA_String ("b"); -- Request : CORBA.Request.Object; -- Ctx : CORBA.Context.Ref; -- Arg_List : CORBA.NVList.Ref; -- Result : CORBA.NamedValue; -- Result_Name : CORBA.String := To_CORBA_String ("Result"); -- begin -- -- creating the argument list -- CORBA.ORB.Create_List (0, Arg_List); -- CORBA.NVList.Add_Item (Arg_List, -- Arg_Name_A, -- CORBA.TC_Short, -- A'Address, -- CORBA.Short'Size, -- CORBA.ARG_INOUT); -- CORBA.NVList.Add_Item (Arg_List, -- Arg_Name_B, -- CORBA.TC_Short, -- B'Address, -- CORBA.Short'Size, -- CORBA.ARG_INOUT); -- -- setting the result type -- Result := (Name => Identifier (Result_Name), -- Argument => Get_Empty_Any (CORBA.TC_Void), -- Arg_Modes => 0); -- -- creating a request -- CORBA.Object.Create_Request (Myall_Functions, -- Ctx, -- Operation_Name, -- Arg_List, -- Result, -- Request, -- 0); -- -- sending message -- CORBA.Request.Invoke (Request, 0); -- end Inout_Proc; procedure In_Out_Proc (A, B : CORBA.Short; C, D : out CORBA.Short); procedure In_Out_Proc (A, B : CORBA.Short; C, D : out CORBA.Short) is Operation_Name : constant CORBA.Identifier := To_CORBA_String ("in_out_proc"); Arg_Name_A : constant CORBA.Identifier := To_CORBA_String ("a"); Arg_Name_B : constant CORBA.Identifier := To_CORBA_String ("b"); Arg_Name_C : constant CORBA.Identifier := To_CORBA_String ("c"); Arg_Name_D : constant CORBA.Identifier := To_CORBA_String ("d"); Request : CORBA.Request.Object; Ctx : CORBA.Context.Ref; Argument_A : constant CORBA.Any := CORBA.To_Any (A); Argument_B : constant CORBA.Any := CORBA.To_Any (B); pragma Warnings (Off); -- C and D are referenced before they have a value. Argument_C : constant CORBA.Any := CORBA.To_Any (C); Argument_D : constant CORBA.Any := CORBA.To_Any (D); pragma Warnings (On); Arg_List : CORBA.NVList.Ref; Result : CORBA.NamedValue; Result_Name : constant CORBA.String := To_CORBA_String ("Result"); begin -- creating the argument list CORBA.ORB.Create_List (0, Arg_List); CORBA.NVList.Add_Item (Arg_List, Arg_Name_A, Argument_A, CORBA.ARG_IN); CORBA.NVList.Add_Item (Arg_List, Arg_Name_B, Argument_B, CORBA.ARG_IN); CORBA.NVList.Add_Item (Arg_List, Arg_Name_C, Argument_C, CORBA.ARG_OUT); CORBA.NVList.Add_Item (Arg_List, Arg_Name_D, Argument_D, CORBA.ARG_OUT); -- setting the result type Result := (Name => Identifier (Result_Name), Argument => Internals.Get_Empty_Any (CORBA.TC_Void), Arg_Modes => 0); -- creating a request CORBA.Object.Create_Request (Myall_Functions, Ctx, Operation_Name, Arg_List, Result, Request, 0); -- sending message CORBA.Request.Invoke (Request, 0); -- get out arguments C := CORBA.From_Any (Argument_C); D := CORBA.From_Any (Argument_D); end In_Out_Proc; procedure In_Inout_Proc (A : CORBA.Short; B : in out CORBA.Short; C : CORBA.Short; D : in out CORBA.Short); procedure In_Inout_Proc (A : CORBA.Short; B : in out CORBA.Short; C : CORBA.Short; D : in out CORBA.Short) is Operation_Name : constant CORBA.Identifier := To_CORBA_String ("in_inout_proc"); Arg_Name_A : constant CORBA.Identifier := To_CORBA_String ("a"); Arg_Name_B : constant CORBA.Identifier := To_CORBA_String ("b"); Arg_Name_C : constant CORBA.Identifier := To_CORBA_String ("c"); Arg_Name_D : constant CORBA.Identifier := To_CORBA_String ("d"); Request : CORBA.Request.Object; Ctx : CORBA.Context.Ref; Argument_A : constant CORBA.Any := CORBA.To_Any (A); Argument_B : constant CORBA.Any := CORBA.To_Any (B); Argument_C : constant CORBA.Any := CORBA.To_Any (C); Argument_D : constant CORBA.Any := CORBA.To_Any (D); Arg_List : CORBA.NVList.Ref; Result : CORBA.NamedValue; Result_Name : constant CORBA.String := To_CORBA_String ("Result"); begin -- creating the argument list CORBA.ORB.Create_List (0, Arg_List); CORBA.NVList.Add_Item (Arg_List, Arg_Name_A, Argument_A, CORBA.ARG_IN); CORBA.NVList.Add_Item (Arg_List, Arg_Name_B, Argument_B, CORBA.ARG_INOUT); CORBA.NVList.Add_Item (Arg_List, Arg_Name_C, Argument_C, CORBA.ARG_IN); CORBA.NVList.Add_Item (Arg_List, Arg_Name_D, Argument_D, CORBA.ARG_INOUT); -- setting the result type Result := (Name => Identifier (Result_Name), Argument => Internals.Get_Empty_Any (CORBA.TC_Void), Arg_Modes => 0); -- creating a request CORBA.Object.Create_Request (Myall_Functions, Ctx, Operation_Name, Arg_List, Result, Request, 0); -- sending message CORBA.Request.Invoke (Request, 0); -- get out arguments B := CORBA.From_Any (Argument_B); D := CORBA.From_Any (Argument_D); end In_Inout_Proc; -- procedure Out_Inout_Proc (Self : CORBA.Object.Ref; -- A : out CORBA.Short; -- B : in out CORBA.Short; -- C : in out CORBA.Short; -- D : out CORBA.Short); -- procedure Out_Inout_Proc (Self : CORBA.Object.Ref; -- A : out CORBA.Short; -- B : in out CORBA.Short; -- C : in out CORBA.Short; -- D : out CORBA.Short) -- is -- Operation_Name : CORBA.Identifier := To_CORBA_String ("out_inout_proc"); -- Arg_Name_A : CORBA.Identifier := To_CORBA_String ("a"); -- Arg_Name_B : CORBA.Identifier := To_CORBA_String ("b"); -- Arg_Name_C : CORBA.Identifier := To_CORBA_String ("c"); -- Arg_Name_D : CORBA.Identifier := To_CORBA_String ("d"); -- Request : CORBA.Request.Object; -- Ctx : CORBA.Context.Ref; -- Arg_List : CORBA.NVList.Ref; -- Result : CORBA.NamedValue; -- Result_Name : CORBA.String := To_CORBA_String ("Result"); -- begin -- -- creating the argument list -- CORBA.ORB.Create_List (0, Arg_List); -- CORBA.NVList.Add_Item (Arg_List, -- Arg_Name_A, -- CORBA.TC_Short, -- A'Address, -- CORBA.Short'Size, -- CORBA.ARG_OUT); -- CORBA.NVList.Add_Item (Arg_List, -- Arg_Name_B, -- CORBA.TC_Short, -- B'Address, -- CORBA.Short'Size, -- CORBA.ARG_INOUT); -- CORBA.NVList.Add_Item (Arg_List, -- Arg_Name_C, -- CORBA.TC_Short, -- C'Address, -- CORBA.Short'Size, -- CORBA.ARG_INOUT); -- CORBA.NVList.Add_Item (Arg_List, -- Arg_Name_D, -- CORBA.TC_Short, -- D'Address, -- CORBA.Short'Size, -- CORBA.ARG_OUT); -- -- setting the result type -- Result := (Name => Identifier (Result_Name), -- Argument => Get_Empty_Any (CORBA.TC_Void), -- Arg_Modes => 0); -- -- creating a request -- CORBA.Object.Create_Request (Myall_Functions, -- Ctx, -- Operation_Name, -- Arg_List, -- Result, -- Request, -- 0); -- -- sending message -- CORBA.Request.Invoke (Request, 0); -- end Out_Inout_Proc; procedure In_Out_Inout_Proc (A : CORBA.Short; B : out CORBA.Short; C : in out CORBA.Short); procedure In_Out_Inout_Proc (A : CORBA.Short; B : out CORBA.Short; C : in out CORBA.Short) is Operation_Name : constant CORBA.Identifier := To_CORBA_String ("in_out_inout_proc"); Arg_Name_A : constant CORBA.Identifier := To_CORBA_String ("a"); Arg_Name_B : constant CORBA.Identifier := To_CORBA_String ("b"); Arg_Name_C : constant CORBA.Identifier := To_CORBA_String ("c"); Request : CORBA.Request.Object; Ctx : CORBA.Context.Ref; Argument_A : constant CORBA.Any := CORBA.To_Any (A); pragma Warnings (Off); -- B is referenced before it has a value. Argument_B : constant CORBA.Any := CORBA.To_Any (B); pragma Warnings (On); Argument_C : constant CORBA.Any := CORBA.To_Any (C); Arg_List : CORBA.NVList.Ref; Result : CORBA.NamedValue; Result_Name : constant CORBA.String := To_CORBA_String ("Result"); begin -- creating the argument list CORBA.ORB.Create_List (0, Arg_List); CORBA.NVList.Add_Item (Arg_List, Arg_Name_A, Argument_A, CORBA.ARG_IN); CORBA.NVList.Add_Item (Arg_List, Arg_Name_B, Argument_B, CORBA.ARG_OUT); CORBA.NVList.Add_Item (Arg_List, Arg_Name_C, Argument_C, CORBA.ARG_INOUT); -- setting the result type Result := (Name => Identifier (Result_Name), Argument => Internals.Get_Empty_Any (CORBA.TC_Void), Arg_Modes => 0); -- creating a request CORBA.Object.Create_Request (Myall_Functions, Ctx, Operation_Name, Arg_List, Result, Request, 0); -- sending message CORBA.Request.Invoke (Request, 0); -- get out arguments B := CORBA.From_Any (Argument_B); C := CORBA.From_Any (Argument_C); end In_Out_Inout_Proc; function Void_Fun return CORBA.Short; function Void_Fun return CORBA.Short is Operation_Name : constant CORBA.Identifier := To_CORBA_String ("void_fun"); Request : CORBA.Request.Object; Ctx : CORBA.Context.Ref; Arg_List : CORBA.NVList.Ref; Result : CORBA.NamedValue; Result_Name : constant CORBA.String := To_CORBA_String ("Result"); begin -- creating the argument list CORBA.ORB.Create_List (0, Arg_List); -- setting the result type Result := (Name => Identifier (Result_Name), Argument => Internals.Get_Empty_Any (CORBA.TC_Short), Arg_Modes => 0); -- creating a request CORBA.Object.Create_Request (Myall_Functions, Ctx, Operation_Name, Arg_List, Result, Request, 0); -- sending message CORBA.Request.Invoke (Request, 0); -- getting the answer return From_Any (Result.Argument); end Void_Fun; function In_Fun (A, B, C : CORBA.Short) return CORBA.Short; function In_Fun (A, B, C : CORBA.Short) return CORBA.Short is Operation_Name : constant CORBA.Identifier := To_CORBA_String ("in_fun"); Arg_Name_A : constant CORBA.Identifier := To_CORBA_String ("a"); Arg_Name_B : constant CORBA.Identifier := To_CORBA_String ("b"); Arg_Name_C : constant CORBA.Identifier := To_CORBA_String ("c"); Request : CORBA.Request.Object; Ctx : CORBA.Context.Ref; Argument_A : constant CORBA.Any := CORBA.To_Any (A); Argument_B : constant CORBA.Any := CORBA.To_Any (B); Argument_C : constant CORBA.Any := CORBA.To_Any (C); Arg_List : CORBA.NVList.Ref; Result : CORBA.NamedValue; Result_Name : constant CORBA.String := To_CORBA_String ("Result"); begin -- creating the argument list CORBA.ORB.Create_List (0, Arg_List); CORBA.NVList.Add_Item (Arg_List, Arg_Name_A, Argument_A, CORBA.ARG_IN); CORBA.NVList.Add_Item (Arg_List, Arg_Name_B, Argument_B, CORBA.ARG_IN); CORBA.NVList.Add_Item (Arg_List, Arg_Name_C, Argument_C, CORBA.ARG_IN); -- setting the result type Result := (Name => Identifier (Result_Name), Argument => Internals.Get_Empty_Any (CORBA.TC_Short), Arg_Modes => 0); -- creating a request CORBA.Object.Create_Request (Myall_Functions, Ctx, Operation_Name, Arg_List, Result, Request, 0); -- sending message CORBA.Request.Invoke (Request, 0); -- getting the answer return From_Any (Result.Argument); end In_Fun; procedure Out_Fun (A, B, C, Returns : out CORBA.Short); procedure Out_Fun (A, B, C, Returns : out CORBA.Short) is Operation_Name : constant CORBA.Identifier := To_CORBA_String ("out_fun"); Arg_Name_A : constant CORBA.Identifier := To_CORBA_String ("a"); Arg_Name_B : constant CORBA.Identifier := To_CORBA_String ("b"); Arg_Name_C : constant CORBA.Identifier := To_CORBA_String ("c"); Request : CORBA.Request.Object; Ctx : CORBA.Context.Ref; pragma Warnings (Off); -- A, B, and C are referenced before they have a value. Argument_A : constant CORBA.Any := CORBA.To_Any (A); Argument_B : constant CORBA.Any := CORBA.To_Any (B); Argument_C : constant CORBA.Any := CORBA.To_Any (C); pragma Warnings (On); Arg_List : CORBA.NVList.Ref; Result : CORBA.NamedValue; Result_Name : constant CORBA.String := To_CORBA_String ("Result"); begin -- creating the argument list CORBA.ORB.Create_List (0, Arg_List); CORBA.NVList.Add_Item (Arg_List, Arg_Name_A, Argument_A, CORBA.ARG_OUT); CORBA.NVList.Add_Item (Arg_List, Arg_Name_B, Argument_B, CORBA.ARG_OUT); CORBA.NVList.Add_Item (Arg_List, Arg_Name_C, Argument_C, CORBA.ARG_OUT); -- Set the result type Result := (Name => Identifier (Result_Name), Argument => Internals.Get_Empty_Any (CORBA.TC_Short), Arg_Modes => 0); -- Create a request CORBA.Object.Create_Request (Myall_Functions, Ctx, Operation_Name, Arg_List, Result, Request, 0); -- Send the request CORBA.Request.Invoke (Request, 0); -- Get out arguments A := CORBA.From_Any (Argument_A); B := CORBA.From_Any (Argument_B); C := CORBA.From_Any (Argument_C); Returns := From_Any (Result.Argument); end Out_Fun; procedure Inout_Fun (A, B : in out CORBA.Short; Returns : out CORBA.Short); procedure Inout_Fun (A, B : in out CORBA.Short; Returns : out CORBA.Short) is Operation_Name : constant CORBA.Identifier := To_CORBA_String ("inout_fun"); Arg_Name_A : constant CORBA.Identifier := To_CORBA_String ("a"); Arg_Name_B : constant CORBA.Identifier := To_CORBA_String ("b"); Request : CORBA.Request.Object; Ctx : CORBA.Context.Ref; Argument_A : constant CORBA.Any := CORBA.To_Any (A); Argument_B : constant CORBA.Any := CORBA.To_Any (B); Arg_List : CORBA.NVList.Ref; Result : CORBA.NamedValue; Result_Name : constant CORBA.String := To_CORBA_String ("Result"); begin -- creating the argument list CORBA.ORB.Create_List (0, Arg_List); CORBA.NVList.Add_Item (Arg_List, Arg_Name_A, Argument_A, CORBA.ARG_INOUT); CORBA.NVList.Add_Item (Arg_List, Arg_Name_B, Argument_B, CORBA.ARG_INOUT); -- setting the result type Result := (Name => Identifier (Result_Name), Argument => Internals.Get_Empty_Any (CORBA.TC_Short), Arg_Modes => 0); -- creating a request CORBA.Object.Create_Request (Myall_Functions, Ctx, Operation_Name, Arg_List, Result, Request, 0); -- sending message CORBA.Request.Invoke (Request, 0); -- get out arguments A := CORBA.From_Any (Argument_A); B := CORBA.From_Any (Argument_B); Returns := From_Any (Result.Argument); end Inout_Fun; procedure In_Out_Fun (A, B : CORBA.Short; C, D, Returns : out CORBA.Short); procedure In_Out_Fun (A, B : CORBA.Short; C, D, Returns : out CORBA.Short) is Operation_Name : constant CORBA.Identifier := To_CORBA_String ("in_out_fun"); Arg_Name_A : constant CORBA.Identifier := To_CORBA_String ("a"); Arg_Name_B : constant CORBA.Identifier := To_CORBA_String ("b"); Arg_Name_C : constant CORBA.Identifier := To_CORBA_String ("c"); Arg_Name_D : constant CORBA.Identifier := To_CORBA_String ("d"); Request : CORBA.Request.Object; Ctx : CORBA.Context.Ref; Argument_A : constant CORBA.Any := CORBA.To_Any (A); Argument_B : constant CORBA.Any := CORBA.To_Any (B); pragma Warnings (Off); -- C and D are referenced before they have a value. Argument_C : constant CORBA.Any := CORBA.To_Any (C); Argument_D : constant CORBA.Any := CORBA.To_Any (D); pragma Warnings (On); Arg_List : CORBA.NVList.Ref; Result : CORBA.NamedValue; Result_Name : constant CORBA.String := To_CORBA_String ("Result"); begin -- creating the argument list CORBA.ORB.Create_List (0, Arg_List); CORBA.NVList.Add_Item (Arg_List, Arg_Name_A, Argument_A, CORBA.ARG_IN); CORBA.NVList.Add_Item (Arg_List, Arg_Name_B, Argument_B, CORBA.ARG_IN); CORBA.NVList.Add_Item (Arg_List, Arg_Name_C, Argument_C, CORBA.ARG_OUT); CORBA.NVList.Add_Item (Arg_List, Arg_Name_D, Argument_D, CORBA.ARG_OUT); -- setting the result type Result := (Name => Identifier (Result_Name), Argument => Internals.Get_Empty_Any (CORBA.TC_Short), Arg_Modes => 0); -- creating a request CORBA.Object.Create_Request (Myall_Functions, Ctx, Operation_Name, Arg_List, Result, Request, 0); -- sending message CORBA.Request.Invoke (Request, 0); -- get out arguments C := CORBA.From_Any (Argument_C); D := CORBA.From_Any (Argument_D); Returns := From_Any (Result.Argument); end In_Out_Fun; procedure In_Inout_Fun (A : CORBA.Short; B : in out CORBA.Short; C : CORBA.Short; D : in out CORBA.Short; Returns : out CORBA.Short); procedure In_Inout_Fun (A : CORBA.Short; B : in out CORBA.Short; C : CORBA.Short; D : in out CORBA.Short; Returns : out CORBA.Short) is Operation_Name : constant CORBA.Identifier := To_CORBA_String ("in_inout_fun"); Arg_Name_A : constant CORBA.Identifier := To_CORBA_String ("a"); Arg_Name_B : constant CORBA.Identifier := To_CORBA_String ("b"); Arg_Name_C : constant CORBA.Identifier := To_CORBA_String ("c"); Arg_Name_D : constant CORBA.Identifier := To_CORBA_String ("d"); Request : CORBA.Request.Object; Ctx : CORBA.Context.Ref; Argument_A : constant CORBA.Any := CORBA.To_Any (A); Argument_B : constant CORBA.Any := CORBA.To_Any (B); Argument_C : constant CORBA.Any := CORBA.To_Any (C); Argument_D : constant CORBA.Any := CORBA.To_Any (D); Arg_List : CORBA.NVList.Ref; Result : CORBA.NamedValue; Result_Name : constant CORBA.String := To_CORBA_String ("Result"); begin -- creating the argument list CORBA.ORB.Create_List (0, Arg_List); CORBA.NVList.Add_Item (Arg_List, Arg_Name_A, Argument_A, CORBA.ARG_IN); CORBA.NVList.Add_Item (Arg_List, Arg_Name_B, Argument_B, CORBA.ARG_INOUT); CORBA.NVList.Add_Item (Arg_List, Arg_Name_C, Argument_C, CORBA.ARG_IN); CORBA.NVList.Add_Item (Arg_List, Arg_Name_D, Argument_D, CORBA.ARG_INOUT); -- setting the result type Result := (Name => Identifier (Result_Name), Argument => Internals.Get_Empty_Any (CORBA.TC_Short), Arg_Modes => 0); -- creating a request CORBA.Object.Create_Request (Myall_Functions, Ctx, Operation_Name, Arg_List, Result, Request, 0); -- sending message CORBA.Request.Invoke (Request, 0); -- get out arguments B := CORBA.From_Any (Argument_B); D := CORBA.From_Any (Argument_D); Returns := From_Any (Result.Argument); end In_Inout_Fun; procedure Out_Inout_Fun (A : out CORBA.Short; B : in out CORBA.Short; C : in out CORBA.Short; D : out CORBA.Short; Returns : out CORBA.Short); procedure Out_Inout_Fun (A : out CORBA.Short; B : in out CORBA.Short; C : in out CORBA.Short; D : out CORBA.Short; Returns : out CORBA.Short) is Operation_Name : constant CORBA.Identifier := To_CORBA_String ("out_inout_fun"); Arg_Name_A : constant CORBA.Identifier := To_CORBA_String ("a"); Arg_Name_B : constant CORBA.Identifier := To_CORBA_String ("b"); Arg_Name_C : constant CORBA.Identifier := To_CORBA_String ("c"); Arg_Name_D : constant CORBA.Identifier := To_CORBA_String ("d"); Request : CORBA.Request.Object; Ctx : CORBA.Context.Ref; pragma Warnings (Off); -- A and D are referenced before they have a value Argument_A : constant CORBA.Any := CORBA.To_Any (A); Argument_D : constant CORBA.Any := CORBA.To_Any (D); pragma Warnings (On); Argument_B : constant CORBA.Any := CORBA.To_Any (B); Argument_C : constant CORBA.Any := CORBA.To_Any (C); Arg_List : CORBA.NVList.Ref; Result : CORBA.NamedValue; Result_Name : constant CORBA.String := To_CORBA_String ("Result"); begin -- creating the argument list CORBA.ORB.Create_List (0, Arg_List); CORBA.NVList.Add_Item (Arg_List, Arg_Name_A, Argument_A, CORBA.ARG_OUT); CORBA.NVList.Add_Item (Arg_List, Arg_Name_B, Argument_B, CORBA.ARG_INOUT); CORBA.NVList.Add_Item (Arg_List, Arg_Name_C, Argument_C, CORBA.ARG_INOUT); CORBA.NVList.Add_Item (Arg_List, Arg_Name_D, Argument_D, CORBA.ARG_OUT); -- setting the result type Result := (Name => Identifier (Result_Name), Argument => Internals.Get_Empty_Any (CORBA.TC_Short), Arg_Modes => 0); -- creating a request CORBA.Object.Create_Request (Myall_Functions, Ctx, Operation_Name, Arg_List, Result, Request, 0); -- sending message CORBA.Request.Invoke (Request, 0); -- get out arguments A := CORBA.From_Any (Argument_A); B := CORBA.From_Any (Argument_B); C := CORBA.From_Any (Argument_C); D := CORBA.From_Any (Argument_D); Returns := From_Any (Result.Argument); end Out_Inout_Fun; procedure In_Out_Inout_Fun (A : CORBA.Short; B : out CORBA.Short; C : in out CORBA.Short; Returns : out CORBA.Short); procedure In_Out_Inout_Fun (A : CORBA.Short; B : out CORBA.Short; C : in out CORBA.Short; Returns : out CORBA.Short) is Operation_Name : constant CORBA.Identifier := To_CORBA_String ("in_out_inout_fun"); Arg_Name_A : constant CORBA.Identifier := To_CORBA_String ("a"); Arg_Name_B : constant CORBA.Identifier := To_CORBA_String ("b"); Arg_Name_C : constant CORBA.Identifier := To_CORBA_String ("c"); Request : CORBA.Request.Object; Ctx : CORBA.Context.Ref; Argument_A : constant CORBA.Any := CORBA.To_Any (A); pragma Warnings (Off); -- B is referenced before it has a value. Argument_B : constant CORBA.Any := CORBA.To_Any (B); pragma Warnings (On); Argument_C : constant CORBA.Any := CORBA.To_Any (C); Arg_List : CORBA.NVList.Ref; Result : CORBA.NamedValue; Result_Name : constant CORBA.String := To_CORBA_String ("Result"); begin -- creating the argument list CORBA.ORB.Create_List (0, Arg_List); CORBA.NVList.Add_Item (Arg_List, Arg_Name_A, Argument_A, CORBA.ARG_IN); CORBA.NVList.Add_Item (Arg_List, Arg_Name_B, Argument_B, CORBA.ARG_OUT); CORBA.NVList.Add_Item (Arg_List, Arg_Name_C, Argument_C, CORBA.ARG_INOUT); -- setting the result type Result := (Name => Identifier (Result_Name), Argument => Internals.Get_Empty_Any (CORBA.TC_Short), Arg_Modes => 0); -- creating a request CORBA.Object.Create_Request (Myall_Functions, Ctx, Operation_Name, Arg_List, Result, Request, 0); -- sending message CORBA.Request.Invoke (Request, 0); -- get out arguments B := CORBA.From_Any (Argument_B); C := CORBA.From_Any (Argument_C); Returns := From_Any (Result.Argument); end In_Out_Inout_Fun; procedure Oneway_Void_Proc; procedure Oneway_Void_Proc is Operation_Name : constant CORBA.Identifier := To_CORBA_String ("oneway_void_proc"); Request : CORBA.Request.Object; Ctx : CORBA.Context.Ref; Arg_List : CORBA.NVList.Ref; Result : CORBA.NamedValue; Result_Name : constant CORBA.String := To_CORBA_String ("Result"); begin -- creating the argument list CORBA.ORB.Create_List (0, Arg_List); -- setting the result type Result := (Name => Identifier (Result_Name), Argument => Internals.Get_Empty_Any (CORBA.TC_Void), Arg_Modes => 0); -- creating a request CORBA.Object.Create_Request (Myall_Functions, Ctx, Operation_Name, Arg_List, Result, Request, 2); -- value for Sync_With_Transport -- sending message CORBA.Request.Invoke (Request, 0); end Oneway_Void_Proc; procedure Oneway_In_Proc (A, B : CORBA.Short); procedure Oneway_In_Proc (A, B : CORBA.Short) is Operation_Name : constant CORBA.Identifier := To_CORBA_String ("oneway_in_proc"); Arg_Name_A : constant CORBA.Identifier := To_CORBA_String ("a"); Arg_Name_B : constant CORBA.Identifier := To_CORBA_String ("b"); Request : CORBA.Request.Object; Ctx : CORBA.Context.Ref; Argument_A : constant CORBA.Any := CORBA.To_Any (A); Argument_B : constant CORBA.Any := CORBA.To_Any (B); Arg_List : CORBA.NVList.Ref; Result : CORBA.NamedValue; Result_Name : constant CORBA.String := To_CORBA_String ("Result"); begin -- creating the argument list CORBA.ORB.Create_List (0, Arg_List); CORBA.NVList.Add_Item (Arg_List, Arg_Name_A, Argument_A, CORBA.ARG_IN); CORBA.NVList.Add_Item (Arg_List, Arg_Name_B, Argument_B, CORBA.ARG_IN); -- setting the result type Result := (Name => Identifier (Result_Name), Argument => Internals.Get_Empty_Any (CORBA.TC_Void), Arg_Modes => 0); -- creating a request CORBA.Object.Create_Request (Myall_Functions, Ctx, Operation_Name, Arg_List, Result, Request, 2); -- value for Sync_With_Transport -- sending message CORBA.Request.Invoke (Request, 0); end Oneway_In_Proc; function Oneway_Checker return CORBA.Short; function Oneway_Checker return CORBA.Short is Operation_Name : constant CORBA.Identifier := To_CORBA_String ("oneway_checker"); Request : CORBA.Request.Object; Ctx : CORBA.Context.Ref; Arg_List : CORBA.NVList.Ref; Result : CORBA.NamedValue; Result_Name : constant CORBA.String := To_CORBA_String ("Result"); begin -- creating the argument list CORBA.ORB.Create_List (0, Arg_List); -- setting the result type Result := (Name => Identifier (Result_Name), Argument => Internals.Get_Empty_Any (CORBA.TC_Short), Arg_Modes => 0); -- creating a request CORBA.Object.Create_Request (Myall_Functions, Ctx, Operation_Name, Arg_List, Result, Request, 0); -- sending message CORBA.Request.Invoke (Request, 0); -- getting the answer return From_Any (Result.Argument); end Oneway_Checker; begin New_Test ("Different invocation modes"); CORBA.ORB.Initialize ("ORB"); if Ada.Command_Line.Argument_Count < 1 then Ada.Text_IO.Put_Line ("usage : client "); return; end if; -- transforms the Ada string into CORBA.String IOR := CORBA.To_CORBA_String (Ada.Command_Line.Argument (1)); -- getting the CORBA.Object CORBA.ORB.String_To_Object (IOR, Myall_Functions); Set_The_Attribute (24); Output ("test attribute", Get_The_Attribute = 24); Output ("test readonly attribute", Get_The_Readonly_Attribute = 18); begin Ok := True; Void_Proc; exception when others => Ok := False; end; Output ("test void procedure", Ok); begin In_Proc (1, 2, 3); Ok := True; exception when others => Ok := False; end; Output ("test in param procedure", Ok); begin Ok := False; -- Out_Proc (Myall_Functions, I, J, K); -- Ok := (I = 10) and then (J = 11) and then (K = 12); exception when others => Ok := False; end; Output ("test out param procedure", Ok); begin Ok := False; I := 2; J := 3; -- Inout_Proc (Myall_Functions, I, J); -- Ok := (I = 3 and then J = 4); exception when others => Ok := False; end; Output ("test in out param procedure", Ok); begin Ok := False; I := 1; J := 2; In_Out_Proc (1, 2, I, J); Ok := (I = 3 and then J = 4); exception when others => Ok := False; end; Output ("test in and out param procedure", Ok); begin Ok := False; I := -4; J := -5; In_Inout_Proc (1, I, 3, J); Ok := (I = 36) and then (J = 40); exception when others => Ok := False; end; Output ("test in and inout param procedure", Ok); begin Ok := False; I := -11; J := -21; K := -31; L := -41; -- Out_Inout_Proc (Myall_Functions, I, J, K, L); -- Ok := (I = 45) and then (J = 46) and then (K = 47) and then (L = 48); exception when others => Ok := False; end; Output ("test inout and out param procedure", Ok); begin Ok := False; I := 78; J := 79; In_Out_Inout_Proc (1, I, J); Ok := (I = -54) and then (J = 80); exception when others => Ok := False; end; Output ("test in and out and inout param procedure", Ok); Output ("test void function", Void_Fun = 3); Output ("test in param function", In_Fun (1, 2, 3) = 7); begin Ok := False; I := 1; J := 2; K := 3; L := 4; Out_Fun (I, J, K, L); Ok := (I = 5) and then (J = 6) and then (K = 7) and then (L = 10); exception when others => Ok := False; end; Output ("test out param function", Ok); begin Ok := False; I := 1; J := 2; K := 3; Inout_Fun (I, J, L); Ok := (I = 2) and then (J = 3) and then (L = 5); exception when others => Ok := False; end; Output ("test inout param function", Ok); begin Ok := False; I := 10; J := 11; In_Out_Fun (1, 2, I, J, K); Ok := (I = 2) and then (J = 1) and then (K = 3); exception when others => Ok := False; end; Output ("test in and out param function", Ok); begin Ok := False; I := -1; J := -2; K := -3; In_Inout_Fun (-1, I, -2, J, K); Ok := (I = -2) and then (J = -4) and then (K = -6); exception when others => Ok := False; end; Output ("test in and inout param function", Ok); begin Ok := False; I := -1; J := -2; K := -3; L := -4; M := -5; Out_Inout_Fun (I, J, K, L, M); Ok := (I = -2) and then (J = -1) and then (K = -2) and then (L = -3) and then (M = -7); exception when others => Ok := False; end; Output ("test out and inout param function", Ok); begin Ok := False; I := -1; J := -2; K := -3; In_Out_Inout_Fun (85, I, J, K); Ok := (I = 86) and then (J = 83) and then (K = -1); exception when others => Ok := False; end; Output ("test in and out and inout param function", Ok); begin Oneway_Void_Proc; delay 0.5; Ok := Oneway_Checker = 1; if Ok then delay 1.0; Ok := Oneway_Checker = 2; end if; exception when others => Ok := False; end; Output ("test void one way procedure", Ok); begin Oneway_In_Proc (10, 20); delay 0.5; Ok := Oneway_Checker = 10; if Ok then delay 1.0; Ok := Oneway_Checker = 20; end if; exception when others => Ok := False; end; Output ("test in param one way procedure", Ok); End_Report; end Dynclient; polyorb-2.8~20110207.orig/examples/corba/all_functions/run_tests.adb0000644000175000017500000001603311750740337024655 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- R U N _ T E S T S -- -- -- -- B o d y -- -- -- -- Copyright (C) 2002-2008, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with CORBA; use CORBA; with all_functions; use all_functions; with PolyORB.Utils.Report; procedure Run_Tests (MyObj : all_functions.Ref) is use PolyORB.Utils.Report; I, J, K, L, M : CORBA.Short; Ok : Boolean; begin New_Test ("Different invocation modes"); Output ("test not nil reference", not Is_Nil (MyObj)); -- Set_The_Attribute (MyObj, 24); -- Output ("test attribute", Get_The_Attribute (MyObj) = 24); -- Output ("test readonly attribute", -- Get_The_Readonly_Attribute (MyObj) = 18); begin Ok := True; void_proc (MyObj); exception when others => Ok := False; end; Output ("test void procedure", Ok); begin in_proc (MyObj, 1, 2, 3); Ok := True; exception when others => Ok := False; end; Output ("test in param procedure", Ok); begin Ok := False; out_proc (MyObj, I, J, K); Ok := (I = 10) and then (J = 11) and then (K = 12); exception when others => null; end; Output ("test out param procedure", Ok); begin Ok := False; out_in_proc (MyObj, I, 41); Ok := I = 42; exception when others => null; end; Output ("test out in param procedure", Ok); begin Ok := False; I := 2; J := 3; inout_proc (MyObj, I, J); Ok := (I = 3 and then J = 4); exception when others => null; end; Output ("test in out param procedure", Ok); begin Ok := False; I := 1; J := 2; in_out_proc (MyObj, 1, 2, I, J); Ok := (I = 3 and then J = 4); exception when others => null; end; Output ("test in and out param procedure", Ok); begin Ok := False; I := -4; J := -5; in_inout_proc (MyObj, 1, I, 3, J); Ok := (I = 36) and then (J = 40); exception when others => null; end; Output ("test in and inout param procedure", Ok); begin I := -11; J := 123; K := 456; L := -41; out_inout_proc (MyObj, I, J, K, L); Ok := (I = 111) and then (J = 457) and then (K = 124) and then (L = 999); exception when others => null; end; Output ("test inout and out param procedure", Ok); begin Ok := False; I := 78; J := 79; in_out_inout_proc (MyObj, 1, I, J); Ok := (I = -54) and then (J = 80); exception when others => null; end; Output ("test in and out and inout param procedure", Ok); Output ("test void function", void_fun (MyObj) = 3); Output ("test in param function", in_fun (MyObj, 1, 2, 3) = 7); begin Ok := False; I := 1; J := 2; K := 3; L := 4; out_fun (MyObj, I, J, K, L); Ok := (I = 5) and then (J = 6) and then (K = 7) and then (L = 10); exception when others => null; end; Output ("test out param function", Ok); begin Ok := False; I := 1; J := 2; K := 3; inout_fun (MyObj, I, J, L); Ok := (I = 2) and then (J = 3) and then (L = 5); exception when others => null; end; Output ("test inout param function", Ok); begin Ok := False; I := 10; J := 11; in_out_fun (MyObj, 1, 2, I, J, K); Ok := (I = 2) and then (J = 1) and then (K = 3); exception when others => null; end; Output ("test in and out param function", Ok); begin Ok := False; I := -1; J := -2; K := -3; in_inout_fun (MyObj, -1, I, -2, J, K); Ok := (I = -2) and then (J = -4) and then (K = -6); exception when others => null; end; Output ("test in and inout param function", Ok); begin Ok := False; I := -1; J := -2; K := -3; L := -4; M := -5; out_inout_fun (MyObj, I, J, K, L, M); Ok := (I = -2) and then (J = -1) and then (K = -2) and then (L = -3) and then (M = -7); exception when others => null; end; Output ("test out and inout param function", Ok); begin Ok := False; I := -1; J := -2; K := -3; in_out_inout_fun (MyObj, 85, I, J, K); Ok := (I = 86) and then (J = 83) and then (K = -1); exception when others => null; end; Output ("test in and out and inout param function", Ok); begin oneway_void_proc (MyObj); delay 0.5; Ok := oneway_checker (MyObj) = 1; if Ok then delay 1.0; Ok := oneway_checker (MyObj) = 2; end if; exception when others => Ok := False; end; Output ("test void one way procedure", Ok); declare S : Short; begin oneway_in_proc (MyObj, 10, 20); delay 0.5; S := oneway_checker (MyObj); Ok := S = 10; if Ok then delay 1.0; S := oneway_checker (MyObj); Ok := S = 20; end if; exception when others => Ok := False; end; Output ("test in param one way procedure", Ok); begin StopServer (MyObj); Ok := True; exception when others => Ok := False; raise; end; Output ("shut down server", Ok); End_Report; end Run_Tests; polyorb-2.8~20110207.orig/examples/corba/all_functions/test.out0000644000175000017500000000244011750740337023664 0ustar xavierxaviertest not nil reference......................................: PASSED test void procedure.........................................: PASSED test in param procedure.....................................: PASSED test out param procedure....................................: PASSED test in out param procedure.................................: PASSED test in and out param procedure.............................: PASSED test in and inout param procedure...........................: PASSED test inout and out param procedure..........................: PASSED test in and out and inout param procedure...................: PASSED test void function..........................................: PASSED test in param function......................................: PASSED test out param function.....................................: PASSED test inout param function...................................: PASSED test in and out param function..............................: PASSED test in and inout param function............................: PASSED test out and inout param function...........................: PASSED test in and out and inout param function....................: PASSED test void one way procedure.................................: PASSED test in param one way procedure.............................: PASSED polyorb-2.8~20110207.orig/examples/corba/all_functions/all_functions-impl.adb0000644000175000017500000002174611750740337026435 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- A L L _ F U N C T I O N S . I M P L -- -- -- -- B o d y -- -- -- -- Copyright (C) 2002-2008, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with all_functions.Skel; pragma Warnings (Off, all_functions.Skel); with CORBA.ORB; package body all_functions.Impl is use CORBA; -- WAG:5.03 Oneway_Value : CORBA.Short := 0; function Get_the_attribute (Self : access Object) return CORBA.Short is begin return Self.Attribute; end Get_the_attribute; procedure Set_the_attribute (Self : access Object; To : CORBA.Short) is begin Self.Attribute := To; end Set_the_attribute; function Get_the_readonly_attribute (Self : access Object) return CORBA.Short is pragma Warnings (Off); pragma Unreferenced (Self); pragma Warnings (On); begin return 18; end Get_the_readonly_attribute; procedure void_proc (Self : access Object) is pragma Warnings (Off); pragma Unreferenced (Self); pragma Warnings (On); begin null; end void_proc; procedure in_proc (Self : access Object; a : CORBA.Short; b : CORBA.Short; c : CORBA.Short) is pragma Warnings (Off); pragma Unreferenced (Self, a, b, c); pragma Warnings (On); begin null; end in_proc; procedure out_in_proc (Self : access Object; a : out CORBA.Short; b : CORBA.Long) is pragma Unreferenced (Self); begin a := CORBA.Short (b) + 1; end out_in_proc; procedure out_proc (Self : access Object; a : out CORBA.Short; b : out CORBA.Short; c : out CORBA.Short) is pragma Warnings (Off); pragma Unreferenced (Self); pragma Warnings (On); begin a := 10; b := 11; c := 12; end out_proc; procedure inout_proc (Self : access Object; a : in out CORBA.Short; b : in out CORBA.Short) is pragma Warnings (Off); pragma Unreferenced (Self); pragma Warnings (On); begin a := a + 1; b := b + 1; end inout_proc; procedure in_out_proc (Self : access Object; a : CORBA.Short; b : CORBA.Short; c : out CORBA.Short; d : out CORBA.Short) is pragma Warnings (Off); pragma Unreferenced (Self, a, b); pragma Warnings (On); begin c := 3; d := 4; end in_out_proc; procedure in_inout_proc (Self : access Object; a : CORBA.Short; b : in out CORBA.Short; c : CORBA.Short; d : in out CORBA.Short) is pragma Warnings (Off); pragma Unreferenced (Self, a, c); pragma Warnings (On); begin b := 36; d := 40; end in_inout_proc; procedure out_inout_proc (Self : access Object; a : out CORBA.Short; b : in out CORBA.Short; c : in out CORBA.Short; d : out CORBA.Short) is pragma Warnings (Off); pragma Unreferenced (Self); pragma Warnings (On); Entry_B : constant CORBA.Short := B; Entry_C : constant CORBA.Short := C; begin a := 111; b := Entry_C + 1; c := Entry_B + 1; d := 999; end out_inout_proc; procedure in_out_inout_proc (Self : access Object; a : CORBA.Short; b : out CORBA.Short; c : in out CORBA.Short) is pragma Warnings (Off); pragma Unreferenced (Self, a); pragma Warnings (On); begin b := -54; c := c + 1; end in_out_inout_proc; function void_fun (Self : access Object) return CORBA.Short is pragma Warnings (Off); pragma Unreferenced (Self); pragma Warnings (On); begin return 3; end void_fun; function in_fun (Self : access Object; a : CORBA.Short; b : CORBA.Short; c : CORBA.Short) return CORBA.Short is pragma Warnings (Off); pragma Unreferenced (Self, a, b, c); pragma Warnings (On); begin return 7; end in_fun; procedure out_fun (Self : access Object; a : out CORBA.Short; b : out CORBA.Short; c : out CORBA.Short; Returns : out CORBA.Short) is pragma Warnings (Off); pragma Unreferenced (Self); pragma Warnings (On); begin a := 5; b := 6; c := 7; Returns := 10; end out_fun; procedure inout_fun (Self : access Object; a : in out CORBA.Short; b : in out CORBA.Short; Returns : out CORBA.Short) is pragma Warnings (Off); pragma Unreferenced (Self); pragma Warnings (On); begin a := a + 1; b := b + 1; Returns := a + b; end inout_fun; procedure in_out_fun (Self : access Object; a : CORBA.Short; b : CORBA.Short; c : out CORBA.Short; d : out CORBA.Short; Returns : out CORBA.Short) is pragma Warnings (Off); pragma Unreferenced (Self); pragma Warnings (On); begin c := b; d := a; Returns := a + b; end in_out_fun; procedure in_inout_fun (Self : access Object; a : CORBA.Short; b : in out CORBA.Short; c : CORBA.Short; d : in out CORBA.Short; Returns : out CORBA.Short) is pragma Warnings (Off); pragma Unreferenced (Self); pragma Warnings (On); begin b := b + a; d := d + c; Returns := b + d; end in_inout_fun; procedure out_inout_fun (Self : access Object; a : out CORBA.Short; b : in out CORBA.Short; c : in out CORBA.Short; d : out CORBA.Short; Returns : out CORBA.Short) is pragma Warnings (Off); pragma Unreferenced (Self); pragma Warnings (On); begin a := b; b := b + 1; d := c; c := c + 1; Returns := a + b + c + d + 1; end out_inout_fun; procedure in_out_inout_fun (Self : access Object; a : CORBA.Short; b : out CORBA.Short; c : in out CORBA.Short; Returns : out CORBA.Short) is pragma Warnings (Off); pragma Unreferenced (Self); pragma Warnings (On); begin b := a + 1; c := a + c; Returns := -1; end in_out_inout_fun; procedure oneway_void_proc (Self : access Object) is pragma Warnings (Off); pragma Unreferenced (Self); pragma Warnings (On); begin Oneway_Value := 1; delay 1.0; Oneway_Value := 2; end oneway_void_proc; procedure oneway_in_proc (Self : access Object; a : CORBA.Short; b : CORBA.Short) is pragma Warnings (Off); pragma Unreferenced (Self); pragma Warnings (On); begin Oneway_Value := a; delay 1.0; Oneway_Value := b; end oneway_in_proc; function oneway_checker (Self : access Object) return CORBA.Short is pragma Warnings (Off); pragma Unreferenced (Self); pragma Warnings (On); begin return Oneway_Value; end oneway_checker; procedure StopServer (Self : access Object) is pragma Warnings (Off); pragma Unreferenced (Self); pragma Warnings (On); begin CORBA.ORB.Shutdown (Wait_For_Completion => False); end StopServer; end all_functions.Impl; polyorb-2.8~20110207.orig/examples/corba/all_functions/all_functions-impl.ads0000644000175000017500000001252211750740337026446 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- A L L _ F U N C T I O N S . I M P L -- -- -- -- S p e c -- -- -- -- Copyright (C) 2002-2008, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with PortableServer; package all_functions.Impl is -- My own implementation of all_functions object. -- This is simply used to define the operations. type Object is new PortableServer.Servant_Base with private; type Object_Acc is access all Object; function Get_the_attribute (Self : access Object) return CORBA.Short; procedure Set_the_attribute (Self : access Object; To : CORBA.Short); function Get_the_readonly_attribute (Self : access Object) return CORBA.Short; procedure void_proc (Self : access Object); procedure in_proc (Self : access Object; a : CORBA.Short; b : CORBA.Short; c : CORBA.Short); procedure out_proc (Self : access Object; a : out CORBA.Short; b : out CORBA.Short; c : out CORBA.Short); procedure out_in_proc (Self : access Object; a : out CORBA.Short; b : CORBA.Long); procedure inout_proc (Self : access Object; a : in out CORBA.Short; b : in out CORBA.Short); procedure in_out_proc (Self : access Object; a : CORBA.Short; b : CORBA.Short; c : out CORBA.Short; d : out CORBA.Short); procedure in_inout_proc (Self : access Object; a : CORBA.Short; b : in out CORBA.Short; c : CORBA.Short; d : in out CORBA.Short); procedure out_inout_proc (Self : access Object; a : out CORBA.Short; b : in out CORBA.Short; c : in out CORBA.Short; d : out CORBA.Short); procedure in_out_inout_proc (Self : access Object; a : CORBA.Short; b : out CORBA.Short; c : in out CORBA.Short); function void_fun (Self : access Object) return CORBA.Short; function in_fun (Self : access Object; a : CORBA.Short; b : CORBA.Short; c : CORBA.Short) return CORBA.Short; procedure out_fun (Self : access Object; a : out CORBA.Short; b : out CORBA.Short; c : out CORBA.Short; Returns : out CORBA.Short); procedure inout_fun (Self : access Object; a : in out CORBA.Short; b : in out CORBA.Short; Returns : out CORBA.Short); procedure in_out_fun (Self : access Object; a : CORBA.Short; b : CORBA.Short; c : out CORBA.Short; d : out CORBA.Short; Returns : out CORBA.Short); procedure in_inout_fun (Self : access Object; a : CORBA.Short; b : in out CORBA.Short; c : CORBA.Short; d : in out CORBA.Short; Returns : out CORBA.Short); procedure out_inout_fun (Self : access Object; a : out CORBA.Short; b : in out CORBA.Short; c : in out CORBA.Short; d : out CORBA.Short; Returns : out CORBA.Short); procedure in_out_inout_fun (Self : access Object; a : CORBA.Short; b : out CORBA.Short; c : in out CORBA.Short; Returns : out CORBA.Short); procedure oneway_void_proc (Self : access Object); procedure oneway_in_proc (Self : access Object; a : CORBA.Short; b : CORBA.Short); function oneway_checker (Self : access Object) return CORBA.Short; procedure StopServer (Self : access Object); private type Object is new PortableServer.Servant_Base with record Attribute : CORBA.Short; end record; end all_functions.Impl; polyorb-2.8~20110207.orig/examples/corba/all_functions/local.gpr0000644000175000017500000000072311750740337023762 0ustar xavierxavierwith "polyorb", "polyorb_test_common"; project local is Dir := external ("Test_Dir"); Obj_Dir := PolyORB_Test_Common.Build_Dir & Dir; for Object_Dir use Obj_Dir; for Source_Dirs use (Obj_Dir, PolyORB_Test_Common.Source_Dir & Dir); package Compiler is for Default_Switches ("Ada") use PolyORB_Test_Common.Compiler'Default_Switches ("Ada"); end Compiler; for Main use ("client.adb", "server.adb", "dynclient.adb"); end local; polyorb-2.8~20110207.orig/examples/corba/all_functions/server.adb0000644000175000017500000000605411750740337024137 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- S E R V E R -- -- -- -- B o d y -- -- -- -- Copyright (C) 2002-2008, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with all_functions.Impl; with all_functions.Helper; with CORBA; with CORBA.Object; with CORBA.ORB; with PolyORB.CORBA_P.Server_Tools; use PolyORB.CORBA_P.Server_Tools; with PolyORB.CORBA_P.CORBALOC; with PolyORB.Setup.Thread_Pool_Server; pragma Warnings (Off, PolyORB.Setup.Thread_Pool_Server); -- Note : the server must execute two tasks concurrently to pass oneway tests with Ada.Command_Line; with Ada.Text_IO; with Run_Tests; procedure Server is Ref : CORBA.Object.Ref; begin CORBA.ORB.Initialize ("ORB"); Initiate_Servant (new all_functions.Impl.Object, Ref); Ada.Text_IO.Put_Line ("'" & CORBA.To_Standard_String (CORBA.Object.Object_To_String (Ref)) & "'"); Ada.Text_IO.Put_Line ("'" & CORBA.To_Standard_String (PolyORB.CORBA_P.CORBALOC.Object_To_Corbaloc (Ref)) & "'"); Initiate_Server (Start_New_Task => True); if Ada.Command_Line.Argument_Count = 1 and then Ada.Command_Line.Argument (1) = "local" then Run_Tests (all_functions.Helper.To_Ref (Ref)); end if; end Server; polyorb-2.8~20110207.orig/examples/corba/all_functions/client.adb0000644000175000017500000000511211750740337024101 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- C L I E N T -- -- -- -- B o d y -- -- -- -- Copyright (C) 2002-2008, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with Ada.Command_Line; with Ada.Text_IO; with CORBA; use CORBA; with CORBA.ORB; with all_functions; use all_functions; with PolyORB.Setup.Client; pragma Warnings (Off, PolyORB.Setup.Client); with Run_Tests; procedure Client is MyObj : all_functions.Ref; begin CORBA.ORB.Initialize ("ORB"); if Ada.Command_Line.Argument_Count < 1 then Ada.Text_IO.Put_Line ("Usage: client "); return; end if; CORBA.ORB.String_To_Object (CORBA.To_CORBA_String (Ada.Command_Line.Argument (1)), MyObj); Run_Tests (MyObj); end Client; polyorb-2.8~20110207.orig/examples/corba/rtcorba/0000755000175000017500000000000011750740340020742 5ustar xavierxavierpolyorb-2.8~20110207.orig/examples/corba/rtcorba/server_declared/0000755000175000017500000000000011750740340024073 5ustar xavierxavierpolyorb-2.8~20110207.orig/examples/corba/rtcorba/server_declared/echo-impl.ads0000644000175000017500000000502711750740337026453 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- E C H O . I M P L -- -- -- -- S p e c -- -- -- -- Copyright (C) 2002-2008, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by ACT Europe. -- -- (email: sales@act-europe.fr) -- -- -- ------------------------------------------------------------------------------ with CORBA; with PortableServer; with RTCORBA; package Echo.Impl is -- My own implementation of echo object. -- This is simply used to define the operations. type Object is new PortableServer.Servant_Base with record Priority : RTCORBA.Priority; end record; type Object_Acc is access Object; function EchoString (Self : access Object; Mesg : CORBA.String) return CORBA.String; Echo_Objects : Objects; function Echoers (Self : access Object) return Objects; end Echo.Impl; polyorb-2.8~20110207.orig/examples/corba/rtcorba/server_declared/echo.idl0000644000175000017500000000015711750740337025514 0ustar xavierxavierinterface Echo { string echoString (in string Mesg); typedef Object Objects[3]; Objects echoers(); }; polyorb-2.8~20110207.orig/examples/corba/rtcorba/server_declared/Makefile.local0000644000175000017500000000013211750740337026626 0ustar xavierxavier${current_dir}echo.idl-stamp: idlac_flags := ${test_target}: ${current_dir}echo.idl-stamp polyorb-2.8~20110207.orig/examples/corba/rtcorba/server_declared/echo-impl.adb0000644000175000017500000001023411750740337026426 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- E C H O . I M P L -- -- -- -- B o d y -- -- -- -- Copyright (C) 2002-2008, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by ACT Europe. -- -- (email: sales@act-europe.fr) -- -- -- ------------------------------------------------------------------------------ with Ada.Dynamic_Priorities; with Ada.Text_IO; with Echo.Skel; pragma Warnings (Off, Echo.Skel); -- No entity from Echo.Skel is referenced. with RTCORBA.PriorityMapping; with PolyORB.RTCORBA_P.Setup; with PolyORB.Utils.Report; with System; package body Echo.Impl is ---------------- -- EchoString -- ---------------- function EchoString (Self : access Object; Mesg : CORBA.String) return CORBA.String is use Ada.Dynamic_Priorities; use Ada.Text_IO; use RTCORBA; Ada_Priority : constant System.Any_Priority := Get_Priority; Rounded_Priority : RTCORBA.NativePriority; CORBA_Priority : RTCORBA.Priority; Ok : Boolean; begin RTCORBA.PriorityMapping.To_CORBA (PolyORB.RTCORBA_P.Setup.Get_Priority_Mapping.all, RTCORBA.NativePriority (Ada_Priority), CORBA_Priority, Ok); if not Ok then raise Program_Error; end if; RTCORBA.PriorityMapping.To_Native (PolyORB.RTCORBA_P.Setup.Get_Priority_Mapping.all, Self.Priority, Rounded_Priority, Ok); if not Ok then raise Program_Error; end if; Put_Line ("In echo servant, running thread at " & "Ada native priority" & System.Any_Priority'Image (Ada_Priority) & ", CORBA priority (approximation)" & RTCORBA.Priority'Image (CORBA_Priority)); -- Test wether execution priority matches setup priority PolyORB.Utils.Report.Output ("Execution priority conformant with set up priority", Rounded_Priority = RTCORBA.NativePriority (Ada_Priority)); if Rounded_Priority /= RTCORBA.NativePriority (Ada_Priority) then CORBA.Raise_Internal (CORBA.System_Exception_Members'(Minor => 0, Completed => CORBA.Completed_No)); end if; return Mesg; end EchoString; ------------- -- Echoers -- ------------- function Echoers (Self : access Object) return Objects is pragma Unreferenced (Self); begin return Echo_Objects; end Echoers; end Echo.Impl; polyorb-2.8~20110207.orig/examples/corba/rtcorba/server_declared/local.gpr0000644000175000017500000000070211750740337025704 0ustar xavierxavierwith "polyorb", "polyorb_test_common"; project local is Dir := external ("Test_Dir"); Obj_Dir := PolyORB_Test_Common.Build_Dir & Dir; for Object_Dir use Obj_Dir; for Source_Dirs use (Obj_Dir, PolyORB_Test_Common.Source_Dir & Dir); package Compiler is for Default_Switches ("Ada") use PolyORB_Test_Common.Compiler'Default_Switches ("Ada"); end Compiler; for Main use ("server.adb", "client.adb"); end local; polyorb-2.8~20110207.orig/examples/corba/rtcorba/server_declared/server.adb0000644000175000017500000003575211750740337026073 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- S E R V E R -- -- -- -- B o d y -- -- -- -- Copyright (C) 2004-2007, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with Ada.Exceptions; with Ada.Text_IO; with CORBA.Impl; with CORBA.Object; with CORBA.ORB; with CORBA.Policy; with PortableServer.POA.Helper; with PortableServer.POAManager; with RTCORBA.RTORB.Helper; with RTCORBA.PriorityMapping.Linear; with RTCORBA.PriorityModelPolicy; with RTCORBA.ThreadpoolPolicy; with RTPortableServer.POA.Helper; with PolyORB.RTCORBA_P.Setup; with Echo.Impl; with PolyORB.Utils.Report; -- Begin of PolyORB's setup with PolyORB.ORB.Thread_Pool; pragma Warnings (Off, PolyORB.ORB.Thread_Pool); with PolyORB.ORB_Controller.Half_Sync_Half_Async; pragma Warnings (Off, PolyORB.ORB_Controller.Half_Sync_Half_Async); with PolyORB.Request_Scheduler.Servant_Lane; pragma Warnings (Off, PolyORB.Request_Scheduler.Servant_Lane); with PolyORB.Tasking.Profiles.Full_Tasking.Threads.Dynamic_Priorities; pragma Warnings (Off, PolyORB.Tasking.Profiles.Full_Tasking.Threads.Dynamic_Priorities); with PolyORB.Tasking.Profiles.Full_Tasking.Threads; pragma Warnings (Off, PolyORB.Tasking.Profiles.Full_Tasking.Threads); with PolyORB.Tasking.Profiles.Full_Tasking.Threads.Annotations; pragma Warnings (Off, PolyORB.Tasking.Profiles.Full_Tasking.Threads.Annotations); with PolyORB.Tasking.Profiles.Full_Tasking.Mutexes; pragma Warnings (Off, PolyORB.Tasking.Profiles.Full_Tasking.Mutexes); with PolyORB.Tasking.Profiles.Full_Tasking.Condition_Variables; pragma Warnings (Off, PolyORB.Tasking.Profiles.Full_Tasking.Condition_Variables); with PolyORB.Setup.Base; pragma Warnings (Off, PolyORB.Setup.Base); with PolyORB.Setup.OA.Basic_RT_POA; pragma Warnings (Off, PolyORB.Setup.OA.Basic_RT_POA); with PolyORB.Setup.IIOP; pragma Warnings (Off, PolyORB.Setup.IIOP); with PolyORB.Setup.Access_Points.IIOP; pragma Warnings (Off, PolyORB.Setup.Access_Points.IIOP); with PolyORB.GIOP_P.Tagged_Components.Policies.Priority_Model_Policy; pragma Warnings (Off, PolyORB.GIOP_P.Tagged_Components.Policies.Priority_Model_Policy); -- End of PolyORB's setup procedure Server is use Ada.Text_IO; use CORBA.ORB; use CORBA.Policy.IDL_SEQUENCE_Policy; use PortableServer; use PortableServer.POA; use RTCORBA; use RTCORBA.RTORB; use PolyORB.Utils.Report; Priority_Mapping : RTCORBA.PriorityMapping.Linear.Object; begin CORBA.ORB.Initialize ("ORB"); -- Setting up default Priority Mapping for this node PolyORB.RTCORBA_P.Setup.Set_Priority_Mapping (Priority_Mapping); Output ("ORB is configured", True); New_Test ("SERVER_DECLARED server"); declare RT_ORB : RTCORBA.RTORB.Local_Ref; Root_POA : PortableServer.POA.Local_Ref; -- Variables for Child_POA #1 Obj_Server_1 : constant CORBA.Impl.Object_Ptr := new Echo.Impl.Object; Priority_Model_Policy_Ref_1 : RTCORBA.PriorityModelPolicy.Local_Ref; Thread_Pool_Id_1 : RTCORBA.ThreadpoolId; Thread_Pool_Policy_Ref_1 : RTCORBA.ThreadpoolPolicy.Local_Ref; Policies_1 : CORBA.Policy.PolicyList; Child_POA_Server_1 : RTPortableServer.POA.Local_Ref; Ref_Server_1 : CORBA.Object.Ref; Default_Priority_1 : constant RTCORBA.Priority := 10_000; -- Variables for Child_POA #2 Obj_Server_2 : constant CORBA.Impl.Object_Ptr := new Echo.Impl.Object; Priority_Model_Policy_Ref_2 : RTCORBA.PriorityModelPolicy.Local_Ref; Thread_Pool_Id_2 : RTCORBA.ThreadpoolId; Thread_Pool_Policy_Ref_2 : RTCORBA.ThreadpoolPolicy.Local_Ref; Policies_2 : CORBA.Policy.PolicyList; Child_POA_Server_2 : RTPortableServer.POA.Local_Ref; Ref_Server_2 : CORBA.Object.Ref; Default_Priority_2 : constant RTCORBA.Priority := 20_000; -- Variables for Child_POA #3 Obj_Server_3 : constant CORBA.Impl.Object_Ptr := new Echo.Impl.Object; Lanes : RTCORBA.ThreadpoolLanes; Priority_Model_Policy_Ref_3 : RTCORBA.PriorityModelPolicy.Local_Ref; Thread_Pool_Id_3 : RTCORBA.ThreadpoolId; Thread_Pool_Policy_Ref_3 : RTCORBA.ThreadpoolPolicy.Local_Ref; Policies_3 : CORBA.Policy.PolicyList; Child_POA_Server_3 : RTPortableServer.POA.Local_Ref; Ref_Server_3 : CORBA.Object.Ref; No_Implicit_Activation_Policy : constant CORBA.Policy.Ref := CORBA.Policy.Ref (Create_Implicit_Activation_Policy (NO_IMPLICIT_ACTIVATION)); begin -- Retrieve RT ORB RT_ORB := RTCORBA.RTORB.Helper.To_Local_Ref (Resolve_Initial_References (To_CORBA_String ("RTORB"))); Output ("Retrieved reference on RT ORB", True); -- Retrieve Root POA Root_POA := PortableServer.POA.Helper.To_Local_Ref (CORBA.ORB.Resolve_Initial_References (CORBA.ORB.To_CORBA_String ("RootPOA"))); PortableServer.POAManager.Activate (PortableServer.POA.Get_The_POAManager (Root_POA)); Output ("Retrieved and activated Root POA", True); -- Test #1 New_Test ("Setting up Child_POA #1"); -- Create SERVER_DECLARED PriorityModel policy Priority_Model_Policy_Ref_1 := Create_Priority_Model_Policy (RT_ORB, SERVER_DECLARED, Default_Priority_1); Output ("SERVER_DECLARED policy declared", True); -- Create Threadpool Thread_Pool_Id_1 := RTCORBA.RTORB.Create_Threadpool (RT_ORB, Stacksize => 262_144, Static_Threads => 2, Dynamic_Threads => 0, Default_Priority => Default_Priority_1, Allow_Request_Buffering => False, Max_Buffered_Requests => 1, Max_Request_Buffer_Size => 0); Output ("Thread Pool created with id" & RTCORBA.ThreadpoolId'Image (Thread_Pool_Id_1), True); -- Construct Thread Pool policy from previous threadpool Thread_Pool_Policy_Ref_1 := RTCORBA.RTORB.Create_Threadpool_Policy (RT_ORB, Thread_Pool_Id_1); Output ("Create Threadpool policy", True); -- Create Child POA with SERVER_DECLARED priority model policy Append (Policies_1, CORBA.Policy.Ref (Priority_Model_Policy_Ref_1)); Append (Policies_1, CORBA.Policy.Ref (Thread_Pool_Policy_Ref_1)); Child_POA_Server_1 := RTPortableServer.POA.Helper.To_Local_Ref (PortableServer.POA.Create_POA (Root_POA, CORBA.To_CORBA_String ("Child_POA_Server_1"), PortableServer.POA.Get_The_POAManager (Root_POA), Policies_1)); Output ("Create Child POA with these policies", True); -- Set up new object and attach it to Child_POA Echo.Impl.Object (Obj_Server_1.all).Priority := Default_Priority_1; Ref_Server_1 := PortableServer.POA.Servant_To_Reference (PortableServer.POA.Local_Ref (Child_POA_Server_1), PortableServer.Servant (Obj_Server_1)); Output ("Implicit activation of an object with these policies", True); -- Test #2 New_Test ("Setting up Child_POA #2"); -- Create SERVER_DECLARED PriorityModel policy Priority_Model_Policy_Ref_2 := Create_Priority_Model_Policy (RT_ORB, SERVER_DECLARED, Default_Priority_2); Output ("SERVER_DECLARED policy declared", True); -- Create Threadpool Thread_Pool_Id_2 := RTCORBA.RTORB.Create_Threadpool (RT_ORB, Stacksize => 262_144, Static_Threads => 2, Dynamic_Threads => 0, Default_Priority => Default_Priority_2, Allow_Request_Buffering => True, Max_Buffered_Requests => 1, Max_Request_Buffer_Size => 0); Output ("Thread Pool created with id" & RTCORBA.ThreadpoolId'Image (Thread_Pool_Id_2), True); -- Construct Thread Pool policy from previous threadpool Thread_Pool_Policy_Ref_2 := RTCORBA.RTORB.Create_Threadpool_Policy (RT_ORB, Thread_Pool_Id_2); Output ("Create Threadpool policy", True); -- Create Child POA with SERVER_DECLARED priority model policy Append (Policies_2, CORBA.Policy.Ref (Priority_Model_Policy_Ref_2)); Append (Policies_2, CORBA.Policy.Ref (Thread_Pool_Policy_Ref_2)); Child_POA_Server_2 := RTPortableServer.POA.Helper.To_Local_Ref (PortableServer.POA.Create_POA (Root_POA, CORBA.To_CORBA_String ("Child_POA_Server_2"), PortableServer.POA.Get_The_POAManager (Root_POA), Policies_2)); Output ("Create Child POA with these policies", True); -- Set up new object and attach it to Child_POA Echo.Impl.Object (Obj_Server_2.all).Priority := Default_Priority_2; Ref_Server_2 := PortableServer.POA.Servant_To_Reference (PortableServer.POA.Local_Ref (Child_POA_Server_2), PortableServer.Servant (Obj_Server_2)); Output ("Implicit activation of an object with these policies", True); -- Test #3 New_Test ("Setting up Child_POA #3"); -- Create SERVER_DECLARED PriorityModel policy Priority_Model_Policy_Ref_3 := Create_Priority_Model_Policy (RT_ORB, SERVER_DECLARED, Default_Priority_2); Output ("SERVER_DECLARED policy declared", True); -- Create Lanes Append (Lanes, RTCORBA.ThreadpoolLane'(Lane_Priority => Default_Priority_1, Static_Threads => 2, Dynamic_Threads => 0)); Append (Lanes, RTCORBA.ThreadpoolLane'(Lane_Priority => Default_Priority_2, Static_Threads => 2, Dynamic_Threads => 0)); -- Create Threadpool Thread_Pool_Id_3 := RTCORBA.RTORB.Create_Threadpool_With_Lanes (RT_ORB, Stacksize => 262_144, Lanes => Lanes, Allow_Borrowing => False, Allow_Request_Buffering => False, Max_Buffered_Requests => 1, Max_Request_Buffer_Size => 0); Output ("Thread Pool created with id" & RTCORBA.ThreadpoolId'Image (Thread_Pool_Id_3), True); -- Construct Thread Pool policy from previous threadpool Thread_Pool_Policy_Ref_3 := RTCORBA.RTORB.Create_Threadpool_Policy (RT_ORB, Thread_Pool_Id_3); Output ("Create Threadpool policy", True); -- Create Child POA with SERVER_DECLARED priority model policy Append (Policies_3, CORBA.Policy.Ref (Priority_Model_Policy_Ref_3)); Append (Policies_3, CORBA.Policy.Ref (Thread_Pool_Policy_Ref_3)); Append (Policies_3, No_Implicit_Activation_Policy); Child_POA_Server_3 := RTPortableServer.POA.Helper.To_Local_Ref (PortableServer.POA.Create_POA (Root_POA, CORBA.To_CORBA_String ("Child_POA_Server_3"), PortableServer.POA.Get_The_POAManager (Root_POA), Policies_3)); Output ("Create Child POA with these policies", True); -- Set up new object and attach it to Child_POA Echo.Impl.Object (Obj_Server_3.all).Priority := Default_Priority_2; declare Oid : constant PortableServer.ObjectId := RTPortableServer.POA.Activate_Object_With_Priority (Child_POA_Server_3, PortableServer.Servant (Obj_Server_3), Default_Priority_2); begin Output ("Activate_Object_With_Priority did not raise exception", True); -- Call Servant_To_Reference Ref_Server_3 := PortableServer.POA.Id_To_Reference (PortableServer.POA.Local_Ref (Child_POA_Server_3), Oid); -- Building array of objects for client processing Echo.Impl.Echo_Objects (0) := Ref_Server_1; Echo.Impl.Echo_Objects (1) := Ref_Server_2; Echo.Impl.Echo_Objects (2) := Ref_Server_3; -- Output object IORs Put_Line ("IOR of object #1, at RTCORBA priority" & RTCORBA.Priority'Image (Default_Priority_1)); New_Line; Put_Line ("'" & CORBA.To_Standard_String (CORBA.Object.Object_To_String (Ref_Server_1)) & "'"); New_Line; Put_Line ("IOR of object #2, at RTCORBA priority" & RTCORBA.Priority'Image (Default_Priority_2)); New_Line; Put_Line ("'" & CORBA.To_Standard_String (CORBA.Object.Object_To_String (Ref_Server_2)) & "'"); New_Line; Put_Line ("IOR of object #3, at RTCORBA priority" & RTCORBA.Priority'Image (Default_Priority_2)); New_Line; Put_Line ("'" & CORBA.To_Standard_String (CORBA.Object.Object_To_String (Ref_Server_3)) & "'"); New_Line; -- Run ORB Output ("Server is running", True); New_Line; CORBA.ORB.Run; end; end; End_Report; exception when E : others => New_Line; Put_Line ("Got exception: " & Ada.Exceptions.Exception_Information (E)); Output ("Test failed", False); End_Report; end Server; polyorb-2.8~20110207.orig/examples/corba/rtcorba/server_declared/client.adb0000644000175000017500000001173311750740337026034 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- C L I E N T -- -- -- -- B o d y -- -- -- -- Copyright (C) 2002-2004 Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by ACT Europe. -- -- (email: sales@act-europe.fr) -- -- -- ------------------------------------------------------------------------------ -- echo client. with Ada.Command_Line; with Ada.Text_IO; with CORBA.ORB; with Echo.Helper; -- Begin of PolyORB's setup with PolyORB.ORB.Thread_Pool; pragma Warnings (Off, PolyORB.ORB.Thread_Pool); with PolyORB.Setup.Server; pragma Warnings (Off, PolyORB.Setup.Server); with PolyORB.ORB_Controller.Half_Sync_Half_Async; pragma Warnings (Off, PolyORB.ORB_Controller.Half_Sync_Half_Async); with PolyORB.Tasking.Profiles.Full_Tasking.Threads.Dynamic_Priorities; pragma Warnings (Off, PolyORB.Tasking.Profiles.Full_Tasking.Threads.Dynamic_Priorities); with PolyORB.Tasking.Profiles.Full_Tasking.Threads; pragma Warnings (Off, PolyORB.Tasking.Profiles.Full_Tasking.Threads); with PolyORB.Tasking.Profiles.Full_Tasking.Threads.Annotations; pragma Warnings (Off, PolyORB.Tasking.Profiles.Full_Tasking.Threads.Annotations); with PolyORB.Tasking.Profiles.Full_Tasking.Mutexes; pragma Warnings (Off, PolyORB.Tasking.Profiles.Full_Tasking.Mutexes); with PolyORB.Tasking.Profiles.Full_Tasking.Condition_Variables; pragma Warnings (Off, PolyORB.Tasking.Profiles.Full_Tasking.Condition_Variables); with PolyORB.QoS.Priority; pragma Warnings (Off, PolyORB.QoS.Priority); -- End of PolyORB's setup with PolyORB.Utils.Report; procedure Client is use Ada.Command_Line; use Ada.Text_IO; use PolyORB.Utils.Report; Sent_Msg, Rcvd_Msg : CORBA.String; -- pragma Unreferenced (Rcvd_Msg); pragma Warnings (Off, Rcvd_Msg); -- WAG:5.02 DB08-008 -- Assigned but never read myecho : Echo.Ref; Echo_Objects : Echo.Objects; begin New_Test ("SERVER_DECLARED client"); CORBA.ORB.Initialize ("ORB"); if Argument_Count /= 1 then Put_Line ("usage : client |-i"); return; end if; -- Getting the CORBA.Object CORBA.ORB.String_To_Object (CORBA.To_CORBA_String (Ada.Command_Line.Argument (1)), myecho); -- Checking if it worked if Echo.Is_Nil (myecho) then Put_Line ("main : cannot invoke on a nil reference"); return; end if; -- Retrieving echo objects Echo_Objects := Echo.echoers (myecho); for J in Echo_Objects'Range loop -- Sending message Sent_Msg := CORBA.To_CORBA_String (Standard.String'("Hello Ada !")); begin Rcvd_Msg := Echo.echoString (Echo.Helper.To_Ref (Echo_Objects (J)), Sent_Msg); Output ("Execution on servant #" & Integer'Image (J), True); exception when others => Output ("Execution on servant #" & Integer'Image (J), False); end; end loop; End_Report; exception when E : CORBA.Transient => declare Memb : CORBA.System_Exception_Members; begin CORBA.Get_Members (E, Memb); Put ("received exception transient, minor"); Put (CORBA.Unsigned_Long'Image (Memb.Minor)); Put (", completion status: "); Put_Line (CORBA.Completion_Status'Image (Memb.Completed)); End_Report; end; end Client; polyorb-2.8~20110207.orig/examples/corba/rtcorba/client_propagated/0000755000175000017500000000000011750740340024426 5ustar xavierxavierpolyorb-2.8~20110207.orig/examples/corba/rtcorba/client_propagated/echo-impl.ads0000644000175000017500000000460411750740337027006 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- E C H O . I M P L -- -- -- -- S p e c -- -- -- -- Copyright (C) 2002-2008, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by ACT Europe. -- -- (email: sales@act-europe.fr) -- -- -- ------------------------------------------------------------------------------ with CORBA; with PortableServer; package Echo.Impl is -- My own implementation of echo object. -- This is simply used to define the operations. type Object is new PortableServer.Servant_Base with null record; type Object_Acc is access Object; function EchoString (Self : access Object; Mesg : CORBA.String) return CORBA.Short; end Echo.Impl; polyorb-2.8~20110207.orig/examples/corba/rtcorba/client_propagated/echo.idl0000644000175000017500000000007111750740337026042 0ustar xavierxavierinterface Echo { short echoString (in string Mesg); }; polyorb-2.8~20110207.orig/examples/corba/rtcorba/client_propagated/Makefile.local0000644000175000017500000000013211750740337027161 0ustar xavierxavier${current_dir}echo.idl-stamp: idlac_flags := ${test_target}: ${current_dir}echo.idl-stamp polyorb-2.8~20110207.orig/examples/corba/rtcorba/client_propagated/echo-impl.adb0000644000175000017500000000657311750740337026774 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- E C H O . I M P L -- -- -- -- B o d y -- -- -- -- Copyright (C) 2002-2008, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by ACT Europe. -- -- (email: sales@act-europe.fr) -- -- -- ------------------------------------------------------------------------------ with Ada.Dynamic_Priorities; with Ada.Text_IO; with Echo.Skel; pragma Warnings (Off, Echo.Skel); -- No entity from Echo.Skel is referenced. with RTCORBA.PriorityMapping; with PolyORB.RTCORBA_P.Setup; with System; package body Echo.Impl is ---------------- -- EchoString -- ---------------- function EchoString (Self : access Object; Mesg : CORBA.String) return CORBA.Short is pragma Warnings (Off); pragma Unreferenced (Self); pragma Warnings (On); use Ada.Dynamic_Priorities; use Ada.Text_IO; Ada_Priority : constant System.Any_Priority := Get_Priority; CORBA_Priority : RTCORBA.Priority; Ok : Boolean; begin RTCORBA.PriorityMapping.To_CORBA (PolyORB.RTCORBA_P.Setup.Get_Priority_Mapping.all, RTCORBA.NativePriority (Ada_Priority), CORBA_Priority, Ok); if not Ok then raise Program_Error; end if; Put_Line ("In echo servant, running thread at " & "Ada native priority" & System.Any_Priority'Image (Ada_Priority) & ", CORBA priority (approximation)" & RTCORBA.Priority'Image (CORBA_Priority)); Put_Line ("Echoing string: « " & CORBA.To_Standard_String (Mesg) & " »"); return CORBA.Short (CORBA_Priority); end EchoString; end Echo.Impl; polyorb-2.8~20110207.orig/examples/corba/rtcorba/client_propagated/local.gpr0000644000175000017500000000070211750740337026237 0ustar xavierxavierwith "polyorb", "polyorb_test_common"; project local is Dir := external ("Test_Dir"); Obj_Dir := PolyORB_Test_Common.Build_Dir & Dir; for Object_Dir use Obj_Dir; for Source_Dirs use (Obj_Dir, PolyORB_Test_Common.Source_Dir & Dir); package Compiler is for Default_Switches ("Ada") use PolyORB_Test_Common.Compiler'Default_Switches ("Ada"); end Compiler; for Main use ("client.adb", "server.adb"); end local; polyorb-2.8~20110207.orig/examples/corba/rtcorba/client_propagated/server.adb0000644000175000017500000002213711750740337026417 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- S E R V E R -- -- -- -- B o d y -- -- -- -- Copyright (C) 2004-2007, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with Ada.Exceptions; with Ada.Text_IO; with CORBA.Impl; with CORBA.Object; with CORBA.ORB; with CORBA.Policy; with PortableServer.POA.Helper; with PortableServer.POAManager; with RTCORBA.RTORB.Helper; with RTCORBA.PriorityMapping.Linear; with RTCORBA.PriorityModelPolicy; with RTCORBA.ThreadpoolPolicy; with RTPortableServer.POA.Helper; with PolyORB.RTCORBA_P.Setup; with Echo.Impl; with PolyORB.Utils.Report; -- Begin of PolyORB's setup with PolyORB.ORB.Thread_Pool; pragma Warnings (Off, PolyORB.ORB.Thread_Pool); with PolyORB.ORB_Controller.Half_Sync_Half_Async; pragma Warnings (Off, PolyORB.ORB_Controller.Half_Sync_Half_Async); with PolyORB.Request_Scheduler.Servant_Lane; pragma Warnings (Off, PolyORB.Request_Scheduler.Servant_Lane); with PolyORB.Tasking.Profiles.Full_Tasking.Threads.Dynamic_Priorities; pragma Warnings (Off, PolyORB.Tasking.Profiles.Full_Tasking.Threads.Dynamic_Priorities); with PolyORB.Tasking.Profiles.Full_Tasking.Threads; pragma Warnings (Off, PolyORB.Tasking.Profiles.Full_Tasking.Threads); with PolyORB.Tasking.Profiles.Full_Tasking.Threads.Annotations; pragma Warnings (Off, PolyORB.Tasking.Profiles.Full_Tasking.Threads.Annotations); with PolyORB.Tasking.Profiles.Full_Tasking.Mutexes; pragma Warnings (Off, PolyORB.Tasking.Profiles.Full_Tasking.Mutexes); with PolyORB.Tasking.Profiles.Full_Tasking.Condition_Variables; pragma Warnings (Off, PolyORB.Tasking.Profiles.Full_Tasking.Condition_Variables); with PolyORB.Setup.Base; pragma Warnings (Off, PolyORB.Setup.Base); with PolyORB.Setup.OA.Basic_RT_POA; pragma Warnings (Off, PolyORB.Setup.OA.Basic_RT_POA); with PolyORB.Setup.IIOP; pragma Warnings (Off, PolyORB.Setup.IIOP); with PolyORB.Setup.Access_Points.IIOP; pragma Warnings (Off, PolyORB.Setup.Access_Points.IIOP); with PolyORB.GIOP_P.Tagged_Components.Policies.Priority_Model_Policy; pragma Warnings (Off, PolyORB.GIOP_P.Tagged_Components.Policies.Priority_Model_Policy); -- End of PolyORB's setup procedure Server is use Ada.Text_IO; use CORBA.ORB; use CORBA.Policy.IDL_SEQUENCE_Policy; use PortableServer; use PortableServer.POA; use RTCORBA; use RTCORBA.RTORB; use PolyORB.Utils.Report; Priority_Mapping : RTCORBA.PriorityMapping.Linear.Object; begin CORBA.ORB.Initialize ("ORB"); -- Setting up default Priority Mapping for this node PolyORB.RTCORBA_P.Setup.Set_Priority_Mapping (Priority_Mapping); Output ("ORB is configured", True); New_Test ("CLIENT_PROPAGATED server"); declare use RTCORBA.IDL_SEQUENCE_RTCORBA_ThreadpoolLane; RT_ORB : RTCORBA.RTORB.Local_Ref; Root_POA : PortableServer.POA.Local_Ref; -- Variables for Child_POA #1 Obj_Server_1 : constant CORBA.Impl.Object_Ptr := new Echo.Impl.Object; Priority_Model_Policy_Ref_1 : RTCORBA.PriorityModelPolicy.Local_Ref; Thread_Pool_Id_1 : RTCORBA.ThreadpoolId; Lanes : RTCORBA.ThreadpoolLanes; Thread_Pool_Policy_Ref_1 : RTCORBA.ThreadpoolPolicy.Local_Ref; Policies_1 : CORBA.Policy.PolicyList; Child_POA_Server_1 : RTPortableServer.POA.Local_Ref; Ref_Server_1 : CORBA.Object.Ref; Base_Priority : constant RTCORBA.Priority := 0; Default_Priority_1 : constant RTCORBA.Priority := 10_000; Default_Priority_2 : constant RTCORBA.Priority := 20_000; begin -- Retrieve RT ORB RT_ORB := RTCORBA.RTORB.Helper.To_Local_Ref (Resolve_Initial_References (To_CORBA_String ("RTORB"))); Output ("Retrieved reference on RT ORB", True); -- Retrieve Root POA Root_POA := PortableServer.POA.Helper.To_Local_Ref (CORBA.ORB.Resolve_Initial_References (CORBA.ORB.To_CORBA_String ("RootPOA"))); PortableServer.POAManager.Activate (PortableServer.POA.Get_The_POAManager (Root_POA)); Output ("Retrieved and activated Root POA", True); New_Test ("Setting up Child_POA #1"); -- Create CLIENT_PROPAGATED PriorityModel policy Priority_Model_Policy_Ref_1 := Create_Priority_Model_Policy (RT_ORB, CLIENT_PROPAGATED, Base_Priority); Output ("CLIENT_PROPAGATED policy declared", True); -- Create Lanes Append (Lanes, RTCORBA.ThreadpoolLane'(Lane_Priority => Base_Priority, Static_Threads => 2, Dynamic_Threads => 0)); Append (Lanes, RTCORBA.ThreadpoolLane'(Lane_Priority => Default_Priority_1, Static_Threads => 2, Dynamic_Threads => 0)); Append (Lanes, RTCORBA.ThreadpoolLane'(Lane_Priority => Default_Priority_2, Static_Threads => 2, Dynamic_Threads => 0)); Output ("Lanes created", True); -- Construct Thread Pool policy from previous threadpool Thread_Pool_Id_1 := Create_Threadpool_With_Lanes (RT_ORB, Stacksize => 262_144, Lanes => Lanes, Allow_Borrowing => False, Allow_Request_Buffering => False, Max_Buffered_Requests => 1, Max_Request_Buffer_Size => 0); Thread_Pool_Policy_Ref_1 := RTCORBA.RTORB.Create_Threadpool_Policy (RT_ORB, Thread_Pool_Id_1); Output ("Create Threadpool policy", True); -- Create Child POA with CLIENT_PROPAGATED priority model policy Append (Policies_1, CORBA.Policy.Ref (Priority_Model_Policy_Ref_1)); Append (Policies_1, CORBA.Policy.Ref (Thread_Pool_Policy_Ref_1)); Child_POA_Server_1 := RTPortableServer.POA.Helper.To_Local_Ref (PortableServer.POA.Create_POA (Root_POA, CORBA.To_CORBA_String ("Child_POA_Server_1"), PortableServer.POA.Get_The_POAManager (Root_POA), Policies_1)); Output ("Create Child POA with these policies", True); -- Set up new object and attach it to Child_POA Ref_Server_1 := PortableServer.POA.Servant_To_Reference (PortableServer.POA.Local_Ref (Child_POA_Server_1), PortableServer.Servant (Obj_Server_1)); Output ("Implicit activation of an object with these policies", True); -- Output object IOR Put_Line ("IOR of object #1, attached to thread pool with 3 lanes " & "with priorities" & RTCORBA.Priority'Image (Base_Priority) & "," & RTCORBA.Priority'Image (Default_Priority_1) & "," & RTCORBA.Priority'Image (Default_Priority_2)); New_Line; Put_Line ("'" & CORBA.To_Standard_String (CORBA.Object.Object_To_String (Ref_Server_1)) & "'"); New_Line; -- Launch the server Output ("Server is running", True); New_Line; CORBA.ORB.Run; end; End_Report; exception when E : others => New_Line; Put_Line ("Got exception: " & Ada.Exceptions.Exception_Information (E)); Output ("Test failed", False); End_Report; end Server; polyorb-2.8~20110207.orig/examples/corba/rtcorba/client_propagated/client.adb0000644000175000017500000002222611750740337026366 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- C L I E N T -- -- -- -- B o d y -- -- -- -- Copyright (C) 2002-2007, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with Ada.Command_Line; with Ada.Dynamic_Priorities; with Ada.Exceptions; with Ada.Text_IO; with CORBA.ORB; with Echo; with RTCORBA.Current.Helper; with RTCORBA.PriorityMapping.Linear; with PolyORB.RTCORBA_P.Setup; -- Begin of PolyORB's setup with PolyORB.ORB.Thread_Pool; pragma Warnings (Off, PolyORB.ORB.Thread_Pool); with PolyORB.Setup.Server; pragma Warnings (Off, PolyORB.Setup.Server); with PolyORB.ORB_Controller.Half_Sync_Half_Async; pragma Warnings (Off, PolyORB.ORB_Controller.Half_Sync_Half_Async); with PolyORB.Tasking.Profiles.Full_Tasking.Threads.Dynamic_Priorities; pragma Warnings (Off, PolyORB.Tasking.Profiles.Full_Tasking.Threads.Dynamic_Priorities); with PolyORB.Tasking.Profiles.Full_Tasking.Threads; pragma Warnings (Off, PolyORB.Tasking.Profiles.Full_Tasking.Threads); with PolyORB.Tasking.Profiles.Full_Tasking.Threads.Annotations; pragma Warnings (Off, PolyORB.Tasking.Profiles.Full_Tasking.Threads.Annotations); with PolyORB.Tasking.Profiles.Full_Tasking.Mutexes; pragma Warnings (Off, PolyORB.Tasking.Profiles.Full_Tasking.Mutexes); with PolyORB.Tasking.Profiles.Full_Tasking.Condition_Variables; pragma Warnings (Off, PolyORB.Tasking.Profiles.Full_Tasking.Condition_Variables); with PolyORB.QoS.Priority; pragma Warnings (Off, PolyORB.QoS.Priority); -- End of PolyORB's setup with PolyORB.Utils.Report; procedure Client is use Ada.Command_Line; use Ada.Dynamic_Priorities; use Ada.Text_IO; use CORBA; use CORBA.ORB; use RTCORBA; use PolyORB.Utils.Report; Priority_Mapping : RTCORBA.PriorityMapping.Linear.Object; Sent_Msg : CORBA.String; Running_Priority : CORBA.Short; Rounded_Priority : RTCORBA.Priority; Ok : Boolean; myecho : Echo.Ref; begin -- Note: per construction of this test, client and server must use -- the same PriorityMapping construct to ensure results consistency. if Argument_Count /= 1 then Put_Line ("usage : client |-i"); return; end if; New_Test ("CLIENT_PROPAGATED client"); CORBA.ORB.Initialize ("ORB"); -- Setting up default Priority Mapping for this node PolyORB.RTCORBA_P.Setup.Set_Priority_Mapping (Priority_Mapping); -- Getting the CORBA Object CORBA.ORB.String_To_Object (CORBA.To_CORBA_String (Ada.Command_Line.Argument (1)), myecho); -- Checking if it worked if Echo.Is_Nil (myecho) then Put_Line ("main : cannot invoke on a nil reference"); return; end if; -- Test #0, invocation without setting client's priority -- Sending message Sent_Msg := CORBA.To_CORBA_String (Standard.String'("Hello Ada !")); Running_Priority := Echo.echoString (myecho, Sent_Msg); -- Printing result Put_Line ("I said : " & CORBA.To_Standard_String (Sent_Msg)); Put_Line ("Request executed at priority:" & CORBA.Short'Image (Running_Priority)); Output ("Running priority is correct", Running_Priority = CORBA.Short (0)); -- Note: per construction of this test, 0 the expected result of -- the mapping of the CORBA priority onto the native priority as -- defined on the server side. declare Current : constant RTCORBA.Current.Local_Ref := RTCORBA.Current.Helper.To_Local_Ref (Resolve_Initial_References (To_CORBA_String ("RTCurrent"))); Client_Priority_1 : constant RTCORBA.Priority := 10_000; Client_Priority_2 : constant RTCORBA.Priority := 20_000; begin -- Set up client priority Output ("Retrieve reference on RTCurrent", True); declare Priority : RTCORBA.Priority; pragma Unreferenced (Priority); begin Priority := RTCORBA.Current.Get_The_Priority (Current); Output ("Retrieve RTCurrent priority raised no exception", False); exception when CORBA.Initialize => Output ("Retrieve unset RTCurrent priority raised " & "CORBA.Initialize", True); end; -- Test #1, invocation with priority Client_Priority_1 RTCORBA.Current.Set_The_Priority (Current, Client_Priority_1); Output ("Set RTCurrent priority", True); Output ("New RTCurrent priority =" & Client_Priority_1'Img & " :", RTCORBA.Current.Get_The_Priority (Current) = Client_Priority_1); -- Computing rounded priority RTCORBA.PriorityMapping.To_CORBA (PolyORB.RTCORBA_P.Setup.Get_Priority_Mapping.all, RTCORBA.NativePriority (Get_Priority), Rounded_Priority, Ok); if not Ok then raise Program_Error; end if; -- Sending message Sent_Msg := CORBA.To_CORBA_String (Standard.String'("Hello Ada !")); Running_Priority := Echo.echoString (myecho, Sent_Msg); -- Printing result Put_Line ("I said : " & CORBA.To_Standard_String (Sent_Msg)); Put_Line ("Request executed at priority:" & CORBA.Short'Image (Running_Priority)); -- Test running Priority is compatible with our priority -- Implementation Note: this test relies on the fact that -- client and server nodes are homogeneous. Output ("Running priority is correct", Running_Priority = CORBA.Short (Rounded_Priority)); -- Test #2, invocation with priority Client_Priority_2 RTCORBA.Current.Set_The_Priority (Current, Client_Priority_2); Output ("Set RTCurrent priority", True); Output ("New RTCurrent priority =" & Client_Priority_2'Img & " :", RTCORBA.Current.Get_The_Priority (Current) = Client_Priority_2); -- Computing rounded priority RTCORBA.PriorityMapping.To_CORBA (PolyORB.RTCORBA_P.Setup.Get_Priority_Mapping.all, RTCORBA.NativePriority (Get_Priority), Rounded_Priority, Ok); if not Ok then raise Program_Error; end if; -- Sending message Sent_Msg := CORBA.To_CORBA_String (Standard.String'("Hello Ada !")); Running_Priority := Echo.echoString (myecho, Sent_Msg); -- Printing result Put_Line ("I said : " & CORBA.To_Standard_String (Sent_Msg)); Put_Line ("Request executed at priority:" & CORBA.Short'Image (Running_Priority)); -- Test running Priority is compatible with our priority -- Implementation Note: this test relies on the fact that -- client and server nodes are homogeneous. Output ("Running priority is correct", Running_Priority = CORBA.Short (Rounded_Priority)); exception when E : others => New_Line; Put_Line ("Got exception: " & Ada.Exceptions.Exception_Information (E)); Output ("FATAL Error", False); raise; end; End_Report; CORBA.ORB.Shutdown (False); exception when E : CORBA.Transient => declare Memb : CORBA.System_Exception_Members; begin CORBA.Get_Members (E, Memb); Put ("received exception transient, minor"); Put (CORBA.Unsigned_Long'Image (Memb.Minor)); Put (", completion status: "); Put_Line (CORBA.Completion_Status'Image (Memb.Completed)); End_Report; end; end Client; polyorb-2.8~20110207.orig/examples/corba/rtcorba/dhb/0000755000175000017500000000000011750740340021477 5ustar xavierxavierpolyorb-2.8~20110207.orig/examples/corba/rtcorba/dhb/dhb-worker-impl.ads0000644000175000017500000000577511750740337025217 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- D H B . W O R K E R . I M P L -- -- -- -- S p e c -- -- -- -- Copyright (C) 2006-2008, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with CORBA; with PortableServer; with RTCORBA; package DHB.Worker.Impl is type Object is new PortableServer.Servant_Base with private; type Object_Ptr is access all Object'Class; procedure Do_Some_Work (Self : access Object; Kilo_Whetstone : DHB.KWIPS); procedure Do_Some_Work_With_Payload (Self : access Object; Kilo_Whetstone : DHB.KWIPS; Payload : DHB.Worker.U_sequence); function Get_KWIPS (Self : access Object) return DHB.KWIPS; procedure Ping (Self : access Object; Data : CORBA.Unsigned_Long); function Round_Trip (Self : access Object; Data : CORBA.Unsigned_Long) return CORBA.Unsigned_Long; function Round_Trip_With_Payload (Self : access Object; Data : DHB.Worker.U_sequence) return DHB.Worker.U_sequence; function Running_Priority (Self : access Object) return RTCORBA.Priority; private type Object is new PortableServer.Servant_Base with null record; end DHB.Worker.Impl; polyorb-2.8~20110207.orig/examples/corba/rtcorba/dhb/whetstone.adb0000644000175000017500000001277011750740337024204 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- W H E T S T O N E -- -- -- -- B o d y -- -- -- -- Copyright (C) 2006-2008, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with Ada.Numerics.Elementary_Functions; with Ada.Real_Time; package body Whetstone is KWIPS : Positive := 1; --------------------- -- Small_Whetstone -- --------------------- procedure Small_Whetstone (Kilo_Whets : Positive) is use Ada.Numerics.Elementary_Functions; T : constant := 0.499975; -- Values from the original Algol T1 : constant := 0.50025; -- Whetstone program and the T2 : constant := 2.0; -- Pascal SmallWhetstone program N8 : constant := 10; -- Loop iteration count for module 8 N9 : constant := 7; -- Loop iteration count for module 9 Value : constant := 0.941377; -- Value calculated in main loop Tolerance : constant := 0.00001; -- Determined by interval arithmetic I : Integer; IJ : Integer := 1; IK : Integer := 2; IL : Integer := 3; Y : constant Float := 1.0; -- Constant within loop Z : Float; Sum : Float := 0.0; -- Accumulates value of Z subtype Index is Integer range 1 .. N9; E1 : array (Index) of Float; -- Processing of Small_Whetstone begin here begin for Outer_Loop_Var in 1 .. Kilo_Whets loop -- Clear array for Loop_Var in E1'Range loop E1 (Loop_Var) := 0.0; end loop; -- Module 6: Integer arithmetic IJ := (IK - IJ) * (IL - IK); IK := IL - (IK - IJ); IL := (IL - IK) * (IK + IL); E1 (IL - 1) := Float (IJ + IK + IL); E1 (IK - 1) := Sin (Float (IL)); -- Module 8: Procedure calls Z := E1 (4); for Inner_Loop_Var in 1 .. N8 loop declare Xtemp : constant Float := T * (Z + Y * Float (Inner_Loop_Var)); Ytemp : constant Float := T * (Xtemp + Y + Z); begin Z := (Xtemp + Ytemp) / T2; end; end loop; -- Second version of Module 6: IJ := IL - (IL - 3) * IK; IL := (IL - IK) * (IK - IJ); IK := (IL - IK) * IK; E1 (IL - 1) := Float (IJ + IK + IL); E1 (IK + 1) := abs (Cos (Z)); -- Module 9: Array references I := 1; while I <= N9 loop E1 (IJ) := E1 (IK); E1 (IK) := E1 (IL); E1 (I) := E1 (IJ); I := I + 1; end loop; -- Module 11: Standard mathematical functions Z := Sqrt (Exp (Log (E1 (N9)) / T1)); Sum := Sum + Z; -- Check the current value of the loop computation if abs (Z - Value) > Tolerance then Sum := 2.0 * Sum; -- Forces error at end IJ := IJ + 1; -- Prevents optimization end if; end loop; -- Self-validation check if abs (Sum / Float (Kilo_Whets) - Value) > Tolerance * Float (Kilo_Whets) then raise Program_Error; end if; end Small_Whetstone; ------------------- -- Compute_KWIPS -- ------------------- function Compute_KWIPS return Positive is use Ada.Real_Time; Start_Time : Ada.Real_Time.Time; End_Time : Ada.Real_Time.Time; begin if KWIPS /= 1 then return KWIPS; end if; Start_Time := Ada.Real_Time.Clock; for J in 1 .. 10_000 loop Small_Whetstone (1); end loop; End_Time := Ada.Real_Time.Clock; KWIPS := Positive (To_Time_Span (10_000.0) / (End_Time - Start_Time)); return KWIPS; end Compute_KWIPS; end Whetstone; polyorb-2.8~20110207.orig/examples/corba/rtcorba/dhb/constants.ads0000644000175000017500000000420011750740337024206 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- C O N S T A N T S -- -- -- -- S p e c -- -- -- -- Copyright (C) 2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ package Constants is -- Verbose : constant Boolean := False; Verbose : constant Boolean := True; end Constants; polyorb-2.8~20110207.orig/examples/corba/rtcorba/dhb/dyn_dict.ads0000644000175000017500000000416611750740337024002 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- D Y N _ D I C T -- -- -- -- S p e c -- -- -- -- Copyright (C) 2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ package Dyn_Dict is procedure Test_Register (Stamp : Standard.String; How_Many : Natural); end Dyn_Dict; polyorb-2.8~20110207.orig/examples/corba/rtcorba/dhb/client_common.adb0000644000175000017500000001342211750740337025005 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- C L I E N T _ C O M M O N -- -- -- -- B o d y -- -- -- -- Copyright (C) 2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with Ada.Calendar; with Ada.Exceptions; with Ada.Real_Time; with Ada.Text_IO; with GNAT.Calendar.Time_IO; with CORBA.ORB; with RTCORBA.PriorityMapping.Linear; with PolyORB.RTCORBA_P.Setup; with PolyORB.Utils.Report; with Dyn_Dict; with DHB; with Periodic_Clients; with Sporadic_Clients; with Whetstone; package body Client_Common is ---------------- -- Run_Client -- ---------------- procedure Run_Client is use Ada.Real_Time; use PolyORB.Utils.Report; Worker_String_Ref : constant CORBA.String := CORBA.To_CORBA_String ("file://worker.ior"); Background_Worker_String_Ref : constant CORBA.String := CORBA.To_CORBA_String ("file://background_worker.ior"); Priority_Mapping : RTCORBA.PriorityMapping.Linear.Object; Timestamp : constant String := GNAT.Calendar.Time_IO.Image (Ada.Calendar.Clock, "%s") & "-"; begin New_Test ("DHB client"); CORBA.ORB.Initialize ("ORB"); -- Setting up default Priority Mapping for this node PolyORB.RTCORBA_P.Setup.Set_Priority_Mapping (Priority_Mapping); -- Timestamp Output ("Timestamp: " & Timestamp, True); -- Computing node KWIPS Output ("This node KWIPS =" & Positive'Image (Whetstone.Compute_KWIPS), True); -- Computing error on the clock Output ("Clock error=" & Duration'Image (To_Duration (Clock - Clock)), True); -- Local Test #1 Dyn_Dict.Test_Register (Timestamp, 1_000); delay 1.0; -- Periodic Test #1 Periodic_Clients.Run_Test_1 ((1 => Periodic_Clients.Periodic_Task_Information' (Id => 0, Worker_String_Ref => Worker_String_Ref, Client_Priority => RTCORBA.Priority'(10_000), Client_Workload => 10, Initial_Server_Workload => DHB.KWIPS'(10), Server_Workload_Increment => DHB.KWIPS'(100), Period => Ada.Real_Time.To_Time_Span (0.1)), 2 => Periodic_Clients.Periodic_Task_Information' (Id => 1, Worker_String_Ref => Worker_String_Ref, Client_Priority => RTCORBA.Priority'(10_000), Client_Workload => 10, Initial_Server_Workload => DHB.KWIPS'(10), Server_Workload_Increment => DHB.KWIPS'(100), Period => Ada.Real_Time.To_Time_Span (0.05)))); delay 1.0; -- Periodic Test #2 Periodic_Clients.Run_Test_2 (Worker_String_Ref); delay 1.0; -- Sporadic Test #1 Sporadic_Clients.Run_Test_1 (Stamp => Timestamp, Worker_String_Ref => Worker_String_Ref, How_Many => 1_000); delay 1.0; -- Sporadic Test #1b Sporadic_Clients.Run_Test_1b (Stamp => Timestamp, Worker_String_Ref => Worker_String_Ref, Worker_Priority => 1_000, Background_Worker_String_Ref => Background_Worker_String_Ref, Background_Worker_Priority => 10_000, How_Many => 1_000); delay 1.0; -- Sporadic Test #2 Sporadic_Clients.Run_Test_2 (Stamp => Timestamp, Worker_String_Ref => Worker_String_Ref, How_Many => 1_000); delay 1.0; -- Sporadic Test #3 Sporadic_Clients.Run_Test_3 (Stamp => Timestamp, Worker_String_Ref => Worker_String_Ref, How_Many => 10, Iterations => 3); End_Report; CORBA.ORB.Shutdown (Wait_For_Completion => False); exception when E : others => Output ("Got exception !", False); Ada.Text_IO.Put_Line (Ada.Exceptions.Exception_Information (E)); end Run_Client; end Client_Common; polyorb-2.8~20110207.orig/examples/corba/rtcorba/dhb/dhb.idl0000644000175000017500000000405211750740337022735 0ustar xavierxavierimport ::RTCORBA; module DHB { // This module is derived from the Distributed Hartstone // benchmarks. It is used to bench PolyORB internals. typedef unsigned long KWIPS; // Represent the number of Kilo Whetstone Instruction Per Second interface Worker { // A Worker is a remote entity that performs some work on behalf // of a client entity. This interface defines functions that serve // to measure some metrics of the underlying ORB. typedef sequence U_sequence; void Do_Some_Work (in KWIPS Kilo_Whetstone); // Worker performs Kilo_Whestone operations void Do_Some_Work_With_Payload (in KWIPS Kilo_Whetstone, in U_sequence Payload); // Worker performs Kilo_Whestone operations + transmit some Payload KWIPS Get_KWIPS (); // Return the number of Kilo Whetstone Instruction Per Seconds // that the worker can provide RTCORBA::Priority Running_Priority (); // Return the running priority of the servant unsigned long Round_Trip (in unsigned long data); // Round trip with data as payload, simply return data U_sequence Round_Trip_With_Payload (in U_sequence Payload); // Round trip with some more payload, simply return Payload oneway void Ping (in unsigned long data); // Ping the remote node }; interface Worker_Factory { // A factory of Workers Worker Create (); void Destroy (in Worker The_Worker); }; interface Background_Worker { // A Background_Worker is a remote entity that performs some work // in background. KWIPS Get_KWIPS (); // Return the number of Kilo Whetstone Instruction Per Seconds // that the worker can provide oneway void Do_Background_Work (in KWIPS Kilo_Whetstone, in RTCORBA::Priority Priority); boolean Is_Working (); // Return true iff Background_Worker is acutally performing some work }; interface Background_Worker_Factory { // A factory of Background_Workers Background_Worker Create (); void Destroy (in Background_Worker The_Worker); }; }; polyorb-2.8~20110207.orig/examples/corba/rtcorba/dhb/whetstone.ads0000644000175000017500000000625311750740337024224 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- W H E T S T O N E -- -- -- -- S p e c -- -- -- -- Copyright (C) 2006-2008, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- XXX: propagate Copyright notice wherever required package Whetstone is procedure Small_Whetstone (Kilo_Whets : Positive); pragma Inline (Small_Whetstone); -- Performs the computational workload of a Hartstone task. The -- computation is a scaled-down version of the one performed by the -- full Whetstone benchmark program. An exception is raised if the -- computation fails to satisfy an internal consistency check. -- This procedure does not return any "result" from its -- computation; its sole function is to give a Hartstone task -- something to do. function Compute_KWIPS return Positive; -- Computes the raw speed of the Small_Whetstone benchmark, in the -- absence of tasking, by determining how many thousands of -- Whetstone instructions (Kilo-Whetstones) per second it can -- execute. Raw speed is expressed in Kilo-Whetstone Instructions -- Per Second (KWIPS). The performance of the Hartstone task set -- will be measured against this non-tasking computation. -- -- Note: the result is cached, any successive call will directly -- return the result computed at the first call. end Whetstone; polyorb-2.8~20110207.orig/examples/corba/rtcorba/dhb/periodic_clients.adb0000644000175000017500000002427011750740337025501 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P E R I O D I C _ C L I E N T S -- -- -- -- B o d y -- -- -- -- Copyright (C) 2006-2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with Ada.Dynamic_Priorities; with Ada.Exceptions; with Ada.Text_IO; with CORBA.Object.Policies; with CORBA.ORB; with CORBA.Policy; with RTCORBA.Current.Helper; with RTCORBA.PriorityMapping; with PolyORB.RTCORBA_P.Setup; with PolyORB.Tasking.Condition_Variables; with PolyORB.Tasking.Mutexes; with PolyORB.Tasking.Threads; with PolyORB.Utils.Report; with Constants; with DHB.Worker; with Whetstone; package body Periodic_Clients is use Ada.Text_IO; use PolyORB.Utils.Report; use DHB; use PolyORB.Tasking.Mutexes; use PolyORB.Tasking.Condition_Variables; Number_Of_Tasks : Natural := 0; Tasks_Initialized : Natural := 0; Initialization_Mutex : Mutex_Access; Initialization_CV : Condition_Access; Alarm_Mutex : Mutex_Access; Alarm_CV : Condition_Access; Missed_Deadline_Workload : DHB.KWIPS := DHB.KWIPS'Last; Missed_Deadline : Boolean := False; type Periodic_Runnable is new PolyORB.Tasking.Threads.Runnable with record Info : Periodic_Task_Information; end record; --------- -- Run -- --------- procedure Run (R : not null access Periodic_Runnable); procedure Run (R : not null access Periodic_Runnable) is use Ada.Real_Time; use CORBA; use CORBA.ORB; use RTCORBA; Worker : DHB.Worker.Ref; Next_Top : Time; Server_Workload : DHB.KWIPS := R.Info.Initial_Server_Workload; Current : constant RTCORBA.Current.Local_Ref := RTCORBA.Current.Helper.To_Local_Ref (Resolve_Initial_References (To_CORBA_String ("RTCurrent"))); Running_Priority : RTCORBA.Priority; Rounded_Priority : RTCORBA.Priority; Ok : Boolean := True; Inconsistent_Policies : CORBA.Policy.PolicyList; begin -- Getting the CORBA.Object CORBA.ORB.String_To_Object (R.Info.Worker_String_Ref, Worker); -- Checking if it worked if DHB.Worker.Is_Nil (Worker) then Output ("main : cannot invoke on a nil reference", False); return; end if; CORBA.Object.Policies.Validate_Connection (CORBA.Object.Ref (Worker), Inconsistent_Policies, Ok); if not Ok then Put_Line ("No connection possible, exiting."); return; end if; -- Set up client's RT-CORBA Priority RTCORBA.Current.Set_The_Priority (Current, R.Info.Client_Priority); if Constants.Verbose then Output ("Set RTCurrent priority to " & RTCORBA.Priority'Image (R.Info.Client_Priority), True); end if; -- Computing rounded priority RTCORBA.PriorityMapping.To_CORBA (PolyORB.RTCORBA_P.Setup.Get_Priority_Mapping.all, RTCORBA.NativePriority (Ada.Dynamic_Priorities.Get_Priority), Rounded_Priority, Ok); if not Ok then raise Program_Error; end if; -- Check Worker's priority is correct Output ("Getting running priority", True); Running_Priority := DHB.Worker.Running_Priority (Worker); if Constants.Verbose then Output ("Running priority is correct", Running_Priority = Rounded_Priority); Output ("Initialization completed, waiting", True); end if; Enter (Initialization_Mutex); Tasks_Initialized := Tasks_Initialized + 1; Wait (Initialization_CV, Initialization_Mutex); Leave (Initialization_Mutex); if Constants.Verbose then Output ("Begin test", True); end if; -- Do some work periodically, increasing server workload, until -- a deadline is missed. Next_Top := Ada.Real_Time.Clock; loop Whetstone.Small_Whetstone (R.Info.Client_Workload); DHB.Worker.Do_Some_Work (Worker, Server_Workload); Next_Top := Next_Top + R.Info.Period; exit when Missed_Deadline or else Next_Top - Clock <= To_Time_Span (0.0); Server_Workload := Server_Workload + R.Info.Server_Workload_Increment; delay until Next_Top; end loop; -- Print result if Constants.Verbose then Output ("Missed deadline by task" & Natural'Image (R.Info.Id) & " for Server_Workload =" & DHB.KWIPS'Image (Server_Workload) & " KWIPS", True); end if; Enter (Alarm_Mutex); Missed_Deadline_Workload := DHB.KWIPS'Min (Missed_Deadline_Workload, Server_Workload); Missed_Deadline := True; Signal (Alarm_CV); Leave (Alarm_Mutex); exception when E : others => Output ("Got exception !", False); Ada.Text_IO.Put_Line (Ada.Exceptions.Exception_Information (E)); end Run; ---------------- -- Run_Test_1 -- ---------------- procedure Run_Test_1 (PTA : Periodic_Task_Array) is use PolyORB.Tasking.Threads; use Ada.Real_Time; Next_Top : Time := Clock; begin New_Test ("Periodic Test #1"); Put_Line ("Description: Spawn N tasks, increase communication jitter " & "until one task misses its deadline"); -- Initialize Create (Alarm_Mutex); Create (Alarm_CV); Create (Initialization_Mutex); Create (Initialization_CV); -- Spawn all tasks Enter (Alarm_Mutex); Number_Of_Tasks := PTA'Length; Leave (Alarm_Mutex); for J in PTA'Range loop declare New_Periodic_Task : constant Runnable_Access := new Periodic_Runnable; begin Periodic_Runnable (New_Periodic_Task.all).Info := PTA (J); declare T : constant Thread_Access := Run_In_Task (TF => Get_Thread_Factory, Name => "", Default_Priority => 15, Storage_Size => 0, R => New_Periodic_Task); pragma Unreferenced (T); begin null; end; end; end loop; -- Wait for all tasks to be initialized while Tasks_Initialized < Number_Of_Tasks loop Next_Top := Clock + To_Time_Span (0.5); delay until Next_Top; end loop; Enter (Initialization_Mutex); Broadcast (Initialization_CV); Leave (Initialization_Mutex); -- Wait for all tasks completing Enter (Alarm_Mutex); Wait (Alarm_CV, Alarm_Mutex); Leave (Alarm_Mutex); Output ("Missing deadline for workload = " & KWIPS'Image (Missed_Deadline_Workload), True); end Run_Test_1; ---------------- -- Run_Test_2 -- ---------------- procedure Run_Test_2 (Worker_String_Ref : CORBA.String) is use Ada.Real_Time; use CORBA; use CORBA.ORB; use RTCORBA; use DHB.Worker; Worker : DHB.Worker.Ref; Next_Top : Time; Float_Period : constant Duration := 0.1; Period : constant Time_Span := To_Time_Span (Float_Period); Seq : U_sequence := U_sequence (IDL_SEQUENCE_unsigned_long.Null_Sequence); begin New_Test ("Periodic Test #2"); Put_Line ("Description: Invoke Do_Some_Work_With_Payload with an " & "increasing payload until this operation takes more than" & Duration'Image (Float_Period) & "s"); -- Getting the CORBA.Object CORBA.ORB.String_To_Object (Worker_String_Ref, Worker); -- Checking if it worked if DHB.Worker.Is_Nil (Worker) then Output ("main : cannot invoke on a nil reference", False); end if; if Constants.Verbose then Output ("Begin test", True); end if; -- Do some work periodically, increasing server workload, until -- a deadline is missed. Next_Top := Ada.Real_Time.Clock; loop DHB.Worker.Do_Some_Work_With_Payload (Worker, DHB.KWIPS'(0), Seq); Next_Top := Next_Top + Period; exit when Next_Top < Clock; Seq := Seq & To_Sequence (1024); delay until Next_Top; end loop; Output ("BandWidth: " & Float'Image (Float (Length (Seq)) * Float (CORBA.Unsigned_Long'Size) / Float (Float_Period)), True); end Run_Test_2; end Periodic_Clients; polyorb-2.8~20110207.orig/examples/corba/rtcorba/dhb/Makefile.local0000644000175000017500000000035611750740337024242 0ustar xavierxavier${current_dir}dhb.idl-stamp: idlac_flags :=-I${top_srcdir}/idls/RTCORBA -I${top_srcdir}/idls/CORBA_IDL -I${top_srcdir}/idls/CORBA_PIDL -I${top_srcdir}/idls/cos/time -I${top_srcdir}/idls/Interop ${test_target}: ${current_dir}dhb.idl-stamp polyorb-2.8~20110207.orig/examples/corba/rtcorba/dhb/dhb-worker-impl.adb0000644000175000017500000001237011750740337025163 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- D H B . W O R K E R . I M P L -- -- -- -- B o d y -- -- -- -- Copyright (C) 2006-2008, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with Ada.Dynamic_Priorities; with Ada.Text_IO; with System; with RTCORBA.PriorityMapping; with PolyORB.RTCORBA_P.Setup; with Constants; with DHB.Worker.Skel; pragma Warnings (Off); -- Compiler wants Elaborate_All, but that causes cycles pragma Elaborate (DHB.Worker.Skel); pragma Warnings (On); pragma Warnings (Off, DHB.Worker.Skel); with Whetstone; package body DHB.Worker.Impl is ------------------ -- Do_Some_Work -- ------------------ procedure Do_Some_Work (Self : access Object; Kilo_Whetstone : DHB.KWIPS) is pragma Unreferenced (Self); begin Whetstone.Small_Whetstone (Positive (Kilo_Whetstone)); end Do_Some_Work; ------------------------------- -- Do_Some_Work_With_Payload -- ------------------------------- procedure Do_Some_Work_With_Payload (Self : access Object; Kilo_Whetstone : DHB.KWIPS; Payload : DHB.Worker.U_sequence) is pragma Unreferenced (Self); pragma Unreferenced (Payload); use type CORBA.Short; begin if Kilo_Whetstone > 0 then Whetstone.Small_Whetstone (Positive (Kilo_Whetstone)); end if; end Do_Some_Work_With_Payload; --------------- -- Get_KWIPS -- --------------- function Get_KWIPS (Self : access Object) return DHB.KWIPS is pragma Unreferenced (Self); begin return KWIPS (Whetstone.Compute_KWIPS); end Get_KWIPS; ---------- -- Ping -- ---------- procedure Ping (Self : access Object; Data : CORBA.Unsigned_Long) is pragma Unreferenced (Self); pragma Unreferenced (Data); begin null; end Ping; ---------------- -- Round_Trip -- ---------------- function Round_Trip (Self : access Object; Data : CORBA.Unsigned_Long) return CORBA.Unsigned_Long is pragma Unreferenced (Self); begin return Data; end Round_Trip; ----------------------------- -- Round_Trip_With_Payload -- ----------------------------- function Round_Trip_With_Payload (Self : access Object; Data : DHB.Worker.U_sequence) return DHB.Worker.U_sequence is pragma Unreferenced (Self); begin return Data; end Round_Trip_With_Payload; ---------------------- -- Running_Priority -- ---------------------- function Running_Priority (Self : access Object) return RTCORBA.Priority is pragma Unreferenced (Self); use Ada.Dynamic_Priorities; use Ada.Text_IO; Ada_Priority : constant System.Any_Priority := Get_Priority; CORBA_Priority : RTCORBA.Priority; Ok : Boolean; begin RTCORBA.PriorityMapping.To_CORBA (PolyORB.RTCORBA_P.Setup.Get_Priority_Mapping.all, RTCORBA.NativePriority (Ada_Priority), CORBA_Priority, Ok); if not Ok then raise Program_Error; end if; if Constants.Verbose then Put_Line ("In Worker servant, running thread at " & "Ada native priority" & System.Any_Priority'Image (Ada_Priority) & ", CORBA priority (approximation)" & RTCORBA.Priority'Image (CORBA_Priority)); end if; return CORBA_Priority; end Running_Priority; end DHB.Worker.Impl; polyorb-2.8~20110207.orig/examples/corba/rtcorba/dhb/utils.ads0000644000175000017500000000445611750740337023347 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- U T I L S -- -- -- -- S p e c -- -- -- -- Copyright (C) 2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with CORBA.Object; with PolyORB.Utils.Report; pragma Elaborate_All (PolyORB.Utils.Report); package Utils is package Duration_Stats is new PolyORB.Utils.Report.Statistics (Duration); use Duration_Stats; procedure Put_Ref (Filename : String; Ref : CORBA.Object.Ref'Class); end Utils; polyorb-2.8~20110207.orig/examples/corba/rtcorba/dhb/server_common.adb0000644000175000017500000002556211750740337025045 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- S E R V E R _ C O M M O N -- -- -- -- B o d y -- -- -- -- Copyright (C) 2006-2007, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with Ada.Text_IO; with CORBA.Impl; with CORBA.Object; with CORBA.ORB; with CORBA.Policy; with PortableServer.POA.Helper; with PortableServer.POAManager; with RTCORBA.RTORB.Helper; with RTCORBA.PriorityMapping.Linear; with RTCORBA.PriorityModelPolicy; with RTCORBA.ThreadpoolPolicy; with RTPortableServer.POA.Helper; with PolyORB.RTCORBA_P.Setup; with PolyORB.Utils.Report; with DHB.Worker; with DHB.Worker_Factory.Helper; with DHB.Worker_Factory.Impl; with DHB.Background_Worker_Factory.Helper; with DHB.Background_Worker_Factory.Impl; with DHB.Background_Worker.Impl; pragma Warnings (Off, DHB.Background_Worker.Impl); with Utils; with Whetstone; package body Server_Common is ---------------- -- Run_Server -- ---------------- procedure Run_Server is use Ada.Text_IO; use CORBA.ORB; use CORBA.Policy.IDL_Sequence_Policy; use PortableServer; use PortableServer.POA; use RTCORBA; use RTCORBA.RTORB; use PolyORB.Utils.Report; Priority_Mapping : RTCORBA.PriorityMapping.Linear.Object; begin CORBA.ORB.Initialize ("ORB"); -- Setting up default Priority Mapping for this node PolyORB.RTCORBA_P.Setup.Set_Priority_Mapping (Priority_Mapping); Output ("ORB is configured", True); Output ("Node KWIPS =" & Positive'Image (Whetstone.Compute_KWIPS), True); declare use RTCORBA.IDL_SEQUENCE_RTCORBA_ThreadpoolLane; RT_ORB : RTCORBA.RTORB.Local_Ref; Root_POA : PortableServer.POA.Local_Ref; -- Variables for Child_POA Priority_Model_Policy_Ref : RTCORBA.PriorityModelPolicy.Local_Ref; Thread_Pool_Id : RTCORBA.ThreadpoolId; Lanes : RTCORBA.ThreadpoolLanes; Thread_Pool_Policy_Ref : RTCORBA.ThreadpoolPolicy.Local_Ref; Policies : CORBA.Policy.PolicyList; Child_POA : RTPortableServer.POA.Local_Ref; Base_Priority : constant RTCORBA.Priority := 1_000; Default_Priority : constant RTCORBA.Priority := 10_000; Default_Priority_2 : constant RTCORBA.Priority := 20_000; Worker_Factory_Object : constant CORBA.Impl.Object_Ptr := new DHB.Worker_Factory.Impl.Object; Worker_Factory_Ref : DHB.Worker_Factory.Ref; Worker_Ref : DHB.Worker.Ref; Background_Worker_Factory_Object : constant CORBA.Impl.Object_Ptr := new DHB.Background_Worker_Factory.Impl.Object; Background_Worker_Factory_Ref : DHB.Background_Worker_Factory.Ref; Background_Worker_Ref : DHB.Background_Worker.Ref; begin -- Retrieve RT ORB RT_ORB := RTCORBA.RTORB.Helper.To_Local_Ref (Resolve_Initial_References (To_CORBA_String ("RTORB"))); Output ("Retrieved reference on RTORB", True); -- Retrieve Root POA Root_POA := PortableServer.POA.Helper.To_Local_Ref (CORBA.ORB.Resolve_Initial_References (CORBA.ORB.To_CORBA_String ("RootPOA"))); PortableServer.POAManager.Activate (PortableServer.POA.Get_The_POAManager (Root_POA)); Output ("Retrieved and activated Root POA", True); New_Test ("Setting up Child_POA #1"); -- Create CLIENT_PROPAGATED PriorityModel policy Priority_Model_Policy_Ref := Create_Priority_Model_Policy (RT_ORB, CLIENT_PROPAGATED, Base_Priority); Output ("CLIENT_PROPAGATED policy declared", True); -- Create Lanes Append (Lanes, RTCORBA.ThreadpoolLane'(Lane_Priority => Base_Priority, Static_Threads => 2, Dynamic_Threads => 0)); Append (Lanes, RTCORBA.ThreadpoolLane'(Lane_Priority => Default_Priority, Static_Threads => 2, Dynamic_Threads => 0)); Append (Lanes, RTCORBA.ThreadpoolLane'(Lane_Priority => Default_Priority_2, Static_Threads => 2, Dynamic_Threads => 0)); Output ("Lanes created", True); -- Construct Thread Pool policy from previous threadpool Thread_Pool_Id := Create_Threadpool_With_Lanes (RT_ORB, Stacksize => 262_144, Lanes => Lanes, Allow_Borrowing => False, Allow_Request_Buffering => False, Max_Buffered_Requests => 1, Max_Request_Buffer_Size => 0); Thread_Pool_Policy_Ref := RTCORBA.RTORB.Create_Threadpool_Policy (RT_ORB, Thread_Pool_Id); Output ("Create Threadpool policy", True); -- Create Child POA with CLIENT_PROPAGATED priority model policy Append (Policies, CORBA.Policy.Ref (Priority_Model_Policy_Ref)); Append (Policies, CORBA.Policy.Ref (Thread_Pool_Policy_Ref)); Child_POA := RTPortableServer.POA.Helper.To_Local_Ref (PortableServer.POA.Create_POA (Root_POA, CORBA.To_CORBA_String ("Child_POA"), PortableServer.POA.Get_The_POAManager (Root_POA), Policies)); Output ("Create Child POA with these policies", True); -- Set up Worker_Factory object and attach it to Child_POA DHB.Worker_Factory.Impl.Initialize (DHB.Worker_Factory.Impl.Object (Worker_Factory_Object.all)'Access, Child_POA); Worker_Factory_Ref := DHB.Worker_Factory.Helper.To_Ref (PortableServer.POA.Servant_To_Reference (PortableServer.POA.Local_Ref (Child_POA), PortableServer.Servant (Worker_Factory_Object))); Output ("Set up Worker_Factory", True); -- Output information on lanes Put_Line ("IOR of Worker factory, attached to thread pool with 3 lanes " & "with priorities:"); Put_Line ("-" & RTCORBA.Priority'Image (Base_Priority)); Put_Line ("-" & RTCORBA.Priority'Image (Default_Priority)); Put_Line ("-" & RTCORBA.Priority'Image (Default_Priority_2)); -- Output object IOR New_Line; Put_Line ("Worker_Factory IOR:"); Put_Line ("'" & CORBA.To_Standard_String (CORBA.Object.Object_To_String (Worker_Factory_Ref)) & "'"); New_Line; -- Create a Worker Worker_Ref := DHB.Worker_Factory.Create (DHB.Worker_Factory.Helper.To_Ref (Worker_Factory_Ref)); Output ("Set up Worker", True); New_Line; Put_Line ("Worker IOR:"); Put_Line ("'" & CORBA.To_Standard_String (CORBA.Object.Object_To_String (Worker_Ref)) & "'"); New_Line; Utils.Put_Ref ("worker.ior", Worker_Ref); Put_Line ("Ready."); -- Set up Background_Worker_Factory object and attach it to Child_POA DHB.Background_Worker_Factory.Impl.Initialize (DHB.Background_Worker_Factory.Impl.Object (Background_Worker_Factory_Object.all)'Access, Child_POA); Background_Worker_Factory_Ref := DHB.Background_Worker_Factory.Helper.To_Ref (PortableServer.POA.Servant_To_Reference (PortableServer.POA.Local_Ref (Child_POA), PortableServer.Servant (Background_Worker_Factory_Object))); Output ("Set up Background_Worker_Factory", True); -- Output information on lanes Put_Line ("IOR of Worker factory, attached to thread pool with 3 lanes " & "with priorities:"); Put_Line ("-" & RTCORBA.Priority'Image (Base_Priority)); Put_Line ("-" & RTCORBA.Priority'Image (Default_Priority)); Put_Line ("-" & RTCORBA.Priority'Image (Default_Priority_2)); -- Output object IOR New_Line; Put_Line ("Background_Worker_Factory IOR:"); Put_Line ("'" & CORBA.To_Standard_String (CORBA.Object.Object_To_String (Background_Worker_Factory_Ref)) & "'"); New_Line; -- Create a Background_Worker Background_Worker_Ref := DHB.Background_Worker_Factory.Create (DHB.Background_Worker_Factory.Helper.To_Ref (Background_Worker_Factory_Ref)); Output ("Set up Background_Worker", True); New_Line; Put_Line ("Background_Worker IOR:"); Put_Line ("'" & CORBA.To_Standard_String (CORBA.Object.Object_To_String (Background_Worker_Ref)) & "'"); New_Line; Utils.Put_Ref ("background_worker.ior", Background_Worker_Ref); -- Launch the server CORBA.ORB.Run; end; end Run_Server; end Server_Common; polyorb-2.8~20110207.orig/examples/corba/rtcorba/dhb/client_common.ads0000644000175000017500000000411611750740337025026 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- C L I E N T _ C O M M O N -- -- -- -- S p e c -- -- -- -- Copyright (C) 2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ package Client_Common is procedure Run_Client; end Client_Common; polyorb-2.8~20110207.orig/examples/corba/rtcorba/dhb/polyorb-setup-rtcorba.adb0000644000175000017500000001163111750740337026435 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . S E T U P . R T C O R B A -- -- -- -- B o d y -- -- -- -- Copyright (C) 2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with PolyORB.Log.Stderr; pragma Elaborate_All (PolyORB.Log.Stderr); pragma Warnings (Off, PolyORB.Log.Stderr); with PolyORB.ORB.Thread_Pool; pragma Elaborate_All (PolyORB.ORB.Thread_Pool); pragma Warnings (Off, PolyORB.ORB.Thread_Pool); -- with PolyORB.ORB_Controller.Half_Sync_Half_Async; -- pragma Warnings (Off, PolyORB.ORB_Controller.Half_Sync_Half_Async); -- pragma Elaborate_All (PolyORB.ORB_Controller.Half_Sync_Half_Async); with PolyORB.ORB_Controller.Workers; pragma Warnings (Off, PolyORB.ORB_Controller.Workers); pragma Elaborate_All (PolyORB.ORB_Controller.Workers); with PolyORB.Tasking.Profiles.Full_Tasking.Threads.Dynamic_Priorities; pragma Elaborate_All (PolyORB.Tasking.Profiles.Full_Tasking.Threads.Dynamic_Priorities); pragma Warnings (Off, PolyORB.Tasking.Profiles.Full_Tasking.Threads.Dynamic_Priorities); with PolyORB.Tasking.Profiles.Full_Tasking.Threads; pragma Elaborate_All (PolyORB.Tasking.Profiles.Full_Tasking.Threads); pragma Warnings (Off, PolyORB.Tasking.Profiles.Full_Tasking.Threads); with PolyORB.Tasking.Profiles.Full_Tasking.Threads.Annotations; pragma Elaborate_All (PolyORB.Tasking.Profiles.Full_Tasking.Threads.Annotations); pragma Warnings (Off, PolyORB.Tasking.Profiles.Full_Tasking.Threads.Annotations); with PolyORB.Tasking.Profiles.Full_Tasking.Mutexes; pragma Elaborate_All (PolyORB.Tasking.Profiles.Full_Tasking.Mutexes); pragma Warnings (Off, PolyORB.Tasking.Profiles.Full_Tasking.Mutexes); with PolyORB.Tasking.Profiles.Full_Tasking.Condition_Variables; pragma Elaborate_All (PolyORB.Tasking.Profiles.Full_Tasking.Condition_Variables); pragma Warnings (Off, PolyORB.Tasking.Profiles.Full_Tasking.Condition_Variables); with PolyORB.Parameters.File; pragma Warnings (Off, PolyORB.Parameters.File); pragma Elaborate_All (PolyORB.Parameters.File); with PolyORB.References.File; pragma Warnings (Off, PolyORB.References.File); pragma Elaborate_All (PolyORB.References.File); with PolyORB.QoS.Priority; pragma Elaborate_All (PolyORB.QoS.Priority); pragma Warnings (Off, PolyORB.QoS.Priority); with PolyORB.Request_Scheduler.Servant_Lane; pragma Elaborate_All (PolyORB.Request_Scheduler.Servant_Lane); pragma Warnings (Off, PolyORB.Request_Scheduler.Servant_Lane); with PolyORB.Setup.OA.Basic_RT_POA; pragma Warnings (Off, PolyORB.Setup.OA.Basic_RT_POA); pragma Elaborate_All (PolyORB.Setup.OA.Basic_RT_POA); with PolyORB.Setup.IIOP; pragma Elaborate_All (PolyORB.Setup.IIOP); pragma Warnings (Off, PolyORB.Setup.IIOP); with PolyORB.Setup.Access_Points.IIOP; pragma Elaborate_All (PolyORB.Setup.Access_Points.IIOP); pragma Warnings (Off, PolyORB.Setup.Access_Points.IIOP); with PolyORB.GIOP_P.Tagged_Components.Policies.Priority_Model_Policy; pragma Elaborate_All (PolyORB.GIOP_P.Tagged_Components.Policies.Priority_Model_Policy); pragma Warnings (Off, PolyORB.GIOP_P.Tagged_Components.Policies.Priority_Model_Policy); package body PolyORB.Setup.RTCORBA is end PolyORB.Setup.RTCORBA; polyorb-2.8~20110207.orig/examples/corba/rtcorba/dhb/dhb-worker_factory-impl.adb0000644000175000017500000000640011750740337026707 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- D H B . W O R K E R _ F A C T O R Y . I M P L -- -- -- -- B o d y -- -- -- -- Copyright (C) 2006-2008, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with CORBA.Impl; with DHB.Worker.Helper; with DHB.Worker.Impl; with DHB.Worker_Factory.Skel; pragma Warnings (Off); -- Compiler wants Elaborate_All, but that causes cycles pragma Elaborate (DHB.Worker_Factory.Skel); pragma Warnings (On); pragma Warnings (Off, DHB.Worker_Factory.Skel); with PortableServer.POA; package body DHB.Worker_Factory.Impl is ------------ -- Create -- ------------ function Create (Self : access Object) return DHB.Worker.Ref is Object : constant CORBA.Impl.Object_Ptr := new DHB.Worker.Impl.Object; begin return DHB.Worker.Helper.To_Ref (PortableServer.POA.Servant_To_Reference (PortableServer.POA.Local_Ref (Self.RT_POA), PortableServer.Servant (Object))); end Create; ------------- -- Destroy -- ------------- procedure Destroy (Self : access Object; The_Worker : DHB.Worker.Ref) is pragma Unreferenced (Self, The_Worker); begin raise Program_Error; end Destroy; ---------------- -- Initialize -- ---------------- procedure Initialize (Self : access Object; RT_POA : RTPortableServer.POA.Local_Ref) is begin Self.RT_POA := RT_POA; end Initialize; end DHB.Worker_Factory.Impl; polyorb-2.8~20110207.orig/examples/corba/rtcorba/dhb/dhb-background_worker-impl.ads0000644000175000017500000000520511750740337027402 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- D H B . B A C K G R O U N D _ W O R K E R . I M P L -- -- -- -- S p e c -- -- -- -- Copyright (C) 2006-2008, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with CORBA; with PortableServer; with RTCORBA; package DHB.Background_Worker.Impl is type Object is new PortableServer.Servant_Base with private; type Object_Ptr is access all Object'Class; function Get_KWIPS (Self : access Object) return DHB.KWIPS; procedure Do_Background_Work (Self : access Object; Kilo_Whetstone : DHB.KWIPS; Priority : RTCORBA.Priority); function Is_Working (Self : access Object) return CORBA.Boolean; private type Object is new PortableServer.Servant_Base with record Running : CORBA.Boolean := False; end record; end DHB.Background_Worker.Impl; polyorb-2.8~20110207.orig/examples/corba/rtcorba/dhb/dhb-background_worker-impl.adb0000644000175000017500000001170211750740337027360 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- D H B . B A C K G R O U N D _ W O R K E R . I M P L -- -- -- -- B o d y -- -- -- -- Copyright (C) 2006-2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with Ada.Text_IO; with RTCORBA.PriorityMapping; with PolyORB.RTCORBA_P.Setup; with PolyORB.Tasking.Threads; with Constants; with DHB.Background_Worker.Skel; pragma Warnings (Off); -- Compiler wants Elaborate_All, but that causes cycles pragma Elaborate (DHB.Background_Worker.Skel); pragma Warnings (On); pragma Warnings (Off, DHB.Background_Worker.Skel); with Whetstone; package body DHB.Background_Worker.Impl is use Ada.Text_IO; use PolyORB.Tasking.Threads; type Background_Work_Runnable is new PolyORB.Tasking.Threads.Runnable with record Kilo_Whetstone : DHB.KWIPS; BG_Worker : Object_Ptr := null; end record; --------- -- Run -- --------- procedure Run (R : not null access Background_Work_Runnable); procedure Run (R : not null access Background_Work_Runnable) is begin if Constants.Verbose then Put_Line ("Run: enter, doing" & DHB.KWIPS'Image (R.Kilo_Whetstone)); end if; R.BG_Worker.Running := CORBA.Boolean'(True); Whetstone.Small_Whetstone (Integer (R.Kilo_Whetstone)); R.BG_Worker.Running := CORBA.Boolean'(False); R.BG_Worker := null; if Constants.Verbose then Put_Line ("Run: leave"); end if; end Run; --------------- -- Get_KWIPS -- --------------- function Get_KWIPS (Self : access Object) return DHB.KWIPS is pragma Unreferenced (Self); begin return KWIPS (Whetstone.Compute_KWIPS); end Get_KWIPS; ------------------------ -- Do_Background_Work -- ------------------------ procedure Do_Background_Work (Self : access Object; Kilo_Whetstone : DHB.KWIPS; Priority : RTCORBA.Priority) is Ada_Priority : RTCORBA.NativePriority; Ok : Boolean; New_Background_Worker : constant Runnable_Access := new Background_Work_Runnable; begin if Self.Running then return; end if; RTCORBA.PriorityMapping.To_Native (PolyORB.RTCORBA_P.Setup.Get_Priority_Mapping.all, Priority, Ada_Priority, Ok); if not Ok then raise Program_Error; end if; Background_Work_Runnable (New_Background_Worker.all).Kilo_Whetstone := Kilo_Whetstone; Background_Work_Runnable (New_Background_Worker.all).BG_Worker := Object_Ptr (Self); declare T : constant Thread_Access := Run_In_Task (TF => Get_Thread_Factory, Name => "", Default_Priority => Integer (Ada_Priority), Storage_Size => 0, R => New_Background_Worker); pragma Unreferenced (T); begin null; end; end Do_Background_Work; ---------------- -- Is_Working -- ---------------- function Is_Working (Self : access Object) return CORBA.Boolean is begin return Self.Running; end Is_Working; end DHB.Background_Worker.Impl; polyorb-2.8~20110207.orig/examples/corba/rtcorba/dhb/rtcorba_iiop_server.adb0000644000175000017500000000436211750740337026224 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- R T C O R B A _ I I O P _ S E R V E R -- -- -- -- B o d y -- -- -- -- Copyright (C) 2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with PolyORB.Setup.RTCORBA; pragma Elaborate_All (PolyORB.Setup.RTCORBA); pragma Warnings (Off, PolyORB.Setup.RTCORBA); with Server_Common; procedure RTCORBA_IIOP_Server is begin Server_Common.Run_Server; end RTCORBA_IIOP_Server; polyorb-2.8~20110207.orig/examples/corba/rtcorba/dhb/dhb-worker_factory-impl.ads0000644000175000017500000000520711750740337026734 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- D H B . W O R K E R _ F A C T O R Y . I M P L -- -- -- -- S p e c -- -- -- -- Copyright (C) 2006-2008, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with DHB.Worker; with PortableServer; with RTPortableServer.POA; package DHB.Worker_Factory.Impl is type Object is new PortableServer.Servant_Base with private; type Object_Ptr is access all Object'Class; function Create (Self : access Object) return DHB.Worker.Ref; procedure Destroy (Self : access Object; The_Worker : DHB.Worker.Ref); procedure Initialize (Self : access Object; RT_POA : RTPortableServer.POA.Local_Ref); private type Object is new PortableServer.Servant_Base with record RT_POA : RTPortableServer.POA.Local_Ref; end record; end DHB.Worker_Factory.Impl; polyorb-2.8~20110207.orig/examples/corba/rtcorba/dhb/polyorb-setup-rtcorba.ads0000644000175000017500000000413711750740337026461 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . S E T U P . R T C O R B A -- -- -- -- S p e c -- -- -- -- Copyright (C) 2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ package PolyORB.Setup.RTCORBA is pragma Elaborate_Body; end PolyORB.Setup.RTCORBA; polyorb-2.8~20110207.orig/examples/corba/rtcorba/dhb/dyn_dict.adb0000644000175000017500000001101511750740337023750 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- D Y N _ D I C T -- -- -- -- B o d y -- -- -- -- Copyright (C) 2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with Ada.Text_IO; with Ada.Real_Time; with Utils; with PolyORB.Dynamic_Dict; with PolyORB.Utils.Report; with PolyORB.Utils.Strings; package body Dyn_Dict is use Ada.Real_Time; use Ada.Text_IO; use Utils; use Utils.Duration_Stats; use PolyORB.Utils.Report; use PolyORB.Utils.Strings; package My_Dict is new PolyORB.Dynamic_Dict (Value => String_Ptr); ------------------- -- Test_Register -- ------------------- procedure Test_Register (Stamp : Standard.String; How_Many : Natural) is Key_Root : constant String := "Key"; Value_Root : constant String := "Root"; T0, T1, T2 : Ada.Real_Time.Time; Results : Stat_Vector (1 .. How_Many); begin New_Test ("Perfact Dynamic Hash Table"); Put_Line ("Description: test O (n), amortized O (1) register time, " & "O (1) lookup time"); for J in 1 .. How_Many loop declare Count : constant String := Natural'Image (J); Key : constant String := Key_Root & Count (Count'First + 1 .. Count'Last); Value : constant String := Value_Root & Count (Count'First + 1 .. Count'Last); begin T0 := Clock; My_Dict.Register (Key, +Value); T1 := Clock; T2 := Clock; Results (J) := To_Duration (T1 - T0 - (T2 - T1)); end; end loop; Analyse_Vector (Results, Stamp & "dyn_dict_register"); for J in 1 .. How_Many loop declare Count : constant String := Natural'Image (J); Key : constant String := Key_Root & Count (Count'First + 1 .. Count'Last); Value : constant String := Value_Root & Count (Count'First + 1 .. Count'Last); Content : String_Ptr; begin T0 := Clock; Content := My_Dict.Lookup (Key, Default => null); T1 := Clock; T2 := Clock; Results (J) := To_Duration (T1 - T0 - (T2 - T1)); if Content = null or else Value /= Content.all then Output ("Regression occured for key " & Key & " at stage #" & Integer'Image (How_Many), False); raise Program_Error; end if; end; end loop; Analyse_Vector (Results, Stamp & "dyn_dict_lookup"); Output ("Test completed", True); end Test_Register; end Dyn_Dict; polyorb-2.8~20110207.orig/examples/corba/rtcorba/dhb/utils.adb0000644000175000017500000000464611750740337023327 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- U T I L S -- -- -- -- B o d y -- -- -- -- Copyright (C) 2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with Ada.Text_IO; package body Utils is use Ada.Text_IO; ------------- -- Put_Ref -- ------------- procedure Put_Ref (Filename : String; Ref : CORBA.Object.Ref'Class) is File : File_Type; begin Create (File, Out_File, Filename); Put_Line (File, CORBA.To_Standard_String (CORBA.Object.Object_To_String (Ref))); Close (File); end Put_Ref; end Utils; polyorb-2.8~20110207.orig/examples/corba/rtcorba/dhb/periodic_clients.ads0000644000175000017500000000531211750740337025516 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P E R I O D I C _ C L I E N T S -- -- -- -- S p e c -- -- -- -- Copyright (C) 2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with Ada.Real_Time; with CORBA; with RTCORBA; with DHB; package Periodic_Clients is type Periodic_Task_Information is record Id : Natural; Worker_String_Ref : CORBA.String; Client_Priority : RTCORBA.Priority; Client_Workload : Positive; Initial_Server_Workload : DHB.KWIPS; Server_Workload_Increment : DHB.KWIPS; Period : Ada.Real_Time.Time_Span; end record; type Periodic_Task_Array is array (Positive range <>) of Periodic_Task_Information; procedure Run_Test_1 (PTA : Periodic_Task_Array); procedure Run_Test_2 (Worker_String_Ref : CORBA.String); end Periodic_Clients; polyorb-2.8~20110207.orig/examples/corba/rtcorba/dhb/local.gpr0000644000175000017500000000073411750740337023315 0ustar xavierxavierwith "polyorb", "polyorb_test_common"; project local is Dir := external ("Test_Dir"); Obj_Dir := PolyORB_Test_Common.Build_Dir & Dir; for Object_Dir use Obj_Dir; for Source_Dirs use (Obj_Dir, PolyORB_Test_Common.Source_Dir & Dir); package Compiler is for Default_Switches ("Ada") use PolyORB_Test_Common.Compiler'Default_Switches ("Ada"); end Compiler; for Main use ("rtcorba_iiop_client.adb", "rtcorba_iiop_server.adb"); end local; polyorb-2.8~20110207.orig/examples/corba/rtcorba/dhb/server_common.ads0000644000175000017500000000411611750740337025056 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- S E R V E R _ C O M M O N -- -- -- -- S p e c -- -- -- -- Copyright (C) 2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ package Server_Common is procedure Run_Server; end Server_Common; polyorb-2.8~20110207.orig/examples/corba/rtcorba/dhb/dhb-background_worker_factory-impl.adb0000644000175000017500000000657111750740337031117 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- D H B . B A C K G R O U N D _ W O R K E R _ F A C T O R Y . I M P L -- -- -- -- B o d y -- -- -- -- Copyright (C) 2006-2008, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with CORBA.Impl; with DHB.Background_Worker.Helper; with DHB.Background_Worker.Impl; with DHB.Background_Worker_Factory.Skel; pragma Warnings (Off); -- Compiler wants Elaborate_All, but that causes cycles pragma Elaborate (DHB.Background_Worker_Factory.Skel); pragma Warnings (On); pragma Warnings (Off, DHB.Background_Worker_Factory.Skel); with PortableServer.POA; package body DHB.Background_Worker_Factory.Impl is ------------ -- Create -- ------------ function Create (Self : access Object) return DHB.Background_Worker.Ref is Object : constant CORBA.Impl.Object_Ptr := new DHB.Background_Worker.Impl.Object; begin return DHB.Background_Worker.Helper.To_Ref (PortableServer.POA.Servant_To_Reference (PortableServer.POA.Local_Ref (Self.RT_POA), PortableServer.Servant (Object))); end Create; ------------- -- Destroy -- ------------- procedure Destroy (Self : access Object; The_Worker : DHB.Background_Worker.Ref) is pragma Unreferenced (Self, The_Worker); begin raise Program_Error; end Destroy; ---------------- -- Initialize -- ---------------- procedure Initialize (Self : access Object; RT_POA : RTPortableServer.POA.Local_Ref) is begin Self.RT_POA := RT_POA; end Initialize; end DHB.Background_Worker_Factory.Impl; polyorb-2.8~20110207.orig/examples/corba/rtcorba/dhb/sporadic_clients.adb0000644000175000017500000002641511750740337025512 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- S P O R A D I C _ C L I E N T S -- -- -- -- B o d y -- -- -- -- Copyright (C) 2006-2008, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with Ada.Real_Time; with Ada.Text_IO; with CORBA.ORB; with CORBA.Object.Policies; with CORBA.Policy; with RTCORBA.Current.Helper; with DHB.Background_Worker; with DHB.Worker; with Utils; with PolyORB.Types; with PolyORB.Utils.Report; package body Sporadic_Clients is use Ada.Real_Time; use Ada.Text_IO; use CORBA; use Utils; use Utils.Duration_Stats; use PolyORB.Utils.Report; ---------------- -- Run_Test_1 -- ---------------- procedure Run_Test_1 (Stamp : Standard.String; Worker_String_Ref : CORBA.String; How_Many : Positive) is Worker : DHB.Worker.Ref; Ok : Boolean := True; T0, T1, T2 : Ada.Real_Time.Time; Results : Stat_Vector (1 .. How_Many); Inconsistent_Policies : CORBA.Policy.PolicyList; begin New_Test ("Sporadic Test #1"); Put_Line ("Description: Compute the Round Trip Time of a simple two-way " & "request:"); Put_Line ("Call DHB.Worker.Round_Trip" & Integer'Image (How_Many) & " times"); -- Getting the Worker object CORBA.ORB.String_To_Object (Worker_String_Ref, Worker); -- Checking if it worked if DHB.Worker.Is_Nil (Worker) then Put_Line ("Cannot invoke on a nil reference, exiting."); return; end if; CORBA.Object.Policies.Validate_Connection (CORBA.Object.Ref (Worker), Inconsistent_Policies, Ok); if not Ok then Put_Line ("No connection possible, exiting."); return; end if; -- Processing test for J in 1 .. How_Many loop T0 := Clock; Ok := Ok and (DHB.Worker.Round_Trip (Worker, 1234) = 1234); T1 := Clock; T2 := Clock; Results (J) := To_Duration (T1 - T0 - (T2 - T1)); end loop; Analyse_Vector (Results (Results'First + 1 .. Results'Last), Stamp & "sporadic_test_1"); -- Do not take into account first value, it is biased by -- connection configuration. Output ("Test completed", True); end Run_Test_1; ---------------- -- Run_Test_1b -- ---------------- procedure Run_Test_1b (Stamp : Standard.String; Worker_String_Ref : CORBA.String; Worker_Priority : RTCORBA.Priority; Background_Worker_String_Ref : CORBA.String; Background_Worker_Priority : RTCORBA.Priority; How_Many : Positive) is use type DHB.KWIPS; Worker : DHB.Worker.Ref; Background_Worker : DHB.Background_Worker.Ref; Ok : Boolean := True; T0, T1, T2 : Ada.Real_Time.Time; Results : Stat_Vector (1 .. How_Many); Kilo_WIPS : DHB.KWIPS; Current : constant RTCORBA.Current.Local_Ref := RTCORBA.Current.Helper.To_Local_Ref (CORBA.ORB.Resolve_Initial_References (CORBA.ORB.To_CORBA_String ("RTCurrent"))); begin New_Test ("Sporadic Test #1b"); Put_Line ("Description: Compute the Round Trip Time of a simple two-way " & "request with perturbation from a Background_Worker:"); Put_Line ("Call DHB.Worker.Round_Trip" & Integer'Image (How_Many) & " times"); CORBA.ORB.String_To_Object (Worker_String_Ref, Worker); CORBA.ORB.String_To_Object (Background_Worker_String_Ref, Background_Worker); -- Get Background_Worker KWIPS Kilo_WIPS := DHB.Background_Worker.Get_KWIPS (Background_Worker); Output ("Background_Worker'KWIPS:" & DHB.KWIPS'Image (Kilo_WIPS), True); -- Set up Worker's RT-CORBA Priority RTCORBA.Current.Set_The_Priority (Current, Worker_Priority); -- Run Background Worker DHB.Background_Worker.Do_Background_Work (Background_Worker, Kilo_WIPS * 4, Background_Worker_Priority); -- Run Worker test for J in 1 .. How_Many loop T0 := Clock; Ok := Ok and (DHB.Worker.Round_Trip (Worker, 1234) = 1234); T1 := Clock; T2 := Clock; Results (J) := To_Duration (T1 - T0 - (T2 - T1)); end loop; Output ("Done", Ok); Analyse_Vector (Results (Results'First + 1 .. Results'Last), Stamp & "sporadic_test_1b"); -- Do not take into account first value, it is biased by -- connection configuration. Output ("Test completed", True); end Run_Test_1b; ---------------- -- Run_Test_2 -- ---------------- procedure Run_Test_2 (Stamp : Standard.String; Worker_String_Ref : CORBA.String; How_Many : Positive) is Worker : DHB.Worker.Ref; T0, T1, T2 : Ada.Real_Time.Time; Results : Stat_Vector (1 .. How_Many); Ok : Boolean; Inconsistent_Policies : CORBA.Policy.PolicyList; begin New_Test ("Sporadic Test #2"); Put_Line ("Description: Compute the Round Trip Time of a simple oneway " & "request:"); Put_Line ("Call DHB.Worker.Ping" & Integer'Image (How_Many) & " times"); -- Getting the Worker object CORBA.ORB.String_To_Object (Worker_String_Ref, Worker); -- Checking if it worked if DHB.Worker.Is_Nil (Worker) then Put_Line ("Cannot invoke on a nil reference, exiting."); return; end if; CORBA.Object.Policies.Validate_Connection (CORBA.Object.Ref (Worker), Inconsistent_Policies, Ok); if not Ok then Put_Line ("No connection possible, exiting."); return; end if; -- Processing test for J in 1 .. How_Many loop T0 := Clock; DHB.Worker.Ping (Worker, 1234); T1 := Clock; T2 := Clock; Results (J) := To_Duration (T1 - T0 - (T2 - T1)); end loop; Analyse_Vector (Results (Results'First + 1 .. Results'Last), Stamp & "sporadic_test_2"); -- Do not take into account first value, it is biased by -- connection configuration. Output ("Test completed", True); end Run_Test_2; ---------------- -- Run_Test_3 -- ---------------- procedure Run_Test_3 (Stamp : Standard.String; Worker_String_Ref : CORBA.String; How_Many : Positive; Iterations : Natural) is use type DHB.Worker.U_sequence; Worker : DHB.Worker.Ref; Ok : Boolean := True; Inconsistent_Policies : CORBA.Policy.PolicyList; T0, T1, T2 : Ada.Real_Time.Time; Results : Stat_Vector (1 .. How_Many); Seq : DHB.Worker.U_sequence := DHB.Worker.U_sequence (DHB.Worker.IDL_SEQUENCE_unsigned_long.Null_Sequence); BW : Stat_Vector (1 .. Iterations); RTT : Float; begin New_Test ("Sporadic Test #3"); Put_Line ("Description: Compute the Bandwidth of the middleware:"); Put_Line ("Call DHB.Worker.Round_Trip_With_Payload" & Integer'Image (How_Many) & " times, " & "increasing the payload"); -- Getting the Worker object CORBA.ORB.String_To_Object (Worker_String_Ref, Worker); -- Checking if it worked if DHB.Worker.Is_Nil (Worker) then Put_Line ("Cannot invoke on a nil reference, exiting."); return; end if; CORBA.Object.Policies.Validate_Connection (CORBA.Object.Ref (Worker), Inconsistent_Policies, Ok); if not Ok then Put_Line ("No connection possible, exiting."); return; end if; -- Processing test for J in 0 .. Iterations loop for K in 1 .. How_Many loop T0 := Clock; Ok := Ok and (DHB.Worker.Round_Trip_With_Payload (Worker, Seq) = Seq); T1 := Clock; T2 := Clock; Results (K) := To_Duration (T1 - T0 - (T2 - T1)); end loop; declare Results2 : Stat_Vector renames Results (Results'First + 1 .. Results'Last); -- Do not take into account first value, it is biased by -- connection configuration. begin if DHB.Worker.Length (Seq) = 0 then RTT := Avg (Results2); Put_Line ("RTT :" & Float'Image (RTT)); Put_Line ("(Payload, Bandwidth (b/s))"); Seq := DHB.Worker.To_Sequence (1024); else Put_Line (Integer'Image (DHB.Worker.Length (Seq)) & Float'Image (Float (DHB.Worker.Length (Seq)) * Float (CORBA.Unsigned_Long'Size) * 2.0 / (Avg (Results2) - RTT))); BW (J) := Duration (Float (DHB.Worker.Length (Seq)) * Float (CORBA.Unsigned_Long'Size) * 2.0 / (Avg (Results2) - RTT)); end if; Analyse_Vector (Results2, Stamp & "sporadic_test_3_" & PolyORB.Types.Trimmed_Image (PolyORB.Types.Long_Long (J))); end; Seq := Seq & Seq; end loop; Analyse_Vector (BW, Stamp & "sporadic_test_3_bw"); Output ("Test completed", True); end Run_Test_3; end Sporadic_Clients; polyorb-2.8~20110207.orig/examples/corba/rtcorba/dhb/dhb-background_worker_factory-impl.ads0000644000175000017500000000527611750740337031141 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- D H B . B A C K G R O U N D _ W O R K E R _ F A C T O R Y . I M P L -- -- -- -- S p e c -- -- -- -- Copyright (C) 2006-2008, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with DHB.Background_Worker; with PortableServer; with RTPortableServer.POA; package DHB.Background_Worker_Factory.Impl is type Object is new PortableServer.Servant_Base with private; type Object_Ptr is access all Object'Class; function Create (Self : access Object) return DHB.Background_Worker.Ref; procedure Destroy (Self : access Object; The_Worker : DHB.Background_Worker.Ref); procedure Initialize (Self : access Object; RT_POA : RTPortableServer.POA.Local_Ref); private type Object is new PortableServer.Servant_Base with record RT_POA : RTPortableServer.POA.Local_Ref; end record; end DHB.Background_Worker_Factory.Impl; polyorb-2.8~20110207.orig/examples/corba/rtcorba/dhb/rtcorba_iiop_client.adb0000644000175000017500000000436211750740337026174 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- R T C O R B A _ I I O P _ C L I E N T -- -- -- -- B o d y -- -- -- -- Copyright (C) 2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with PolyORB.Setup.RTCORBA; pragma Elaborate_All (PolyORB.Setup.RTCORBA); pragma Warnings (Off, PolyORB.Setup.RTCORBA); with Client_Common; procedure RTCORBA_IIOP_Client is begin Client_Common.Run_Client; end RTCORBA_IIOP_Client; polyorb-2.8~20110207.orig/examples/corba/rtcorba/dhb/sporadic_clients.ads0000644000175000017500000000557711750740337025541 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- S P O R A D I C _ C L I E N T S -- -- -- -- S p e c -- -- -- -- Copyright (C) 2006-2008, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with CORBA; with RTCORBA; package Sporadic_Clients is procedure Run_Test_1 (Stamp : Standard.String; Worker_String_Ref : CORBA.String; How_Many : Positive); procedure Run_Test_1b (Stamp : Standard.String; Worker_String_Ref : CORBA.String; Worker_Priority : RTCORBA.Priority; Background_Worker_String_Ref : CORBA.String; Background_Worker_Priority : RTCORBA.Priority; How_Many : Positive); procedure Run_Test_2 (Stamp : Standard.String; Worker_String_Ref : CORBA.String; How_Many : Positive); procedure Run_Test_3 (Stamp : Standard.String; Worker_String_Ref : CORBA.String; How_Many : Positive; Iterations : Natural); end Sporadic_Clients; polyorb-2.8~20110207.orig/examples/corba/rtcorba/rtcosscheduling/0000755000175000017500000000000011750740340024142 5ustar xavierxavierpolyorb-2.8~20110207.orig/examples/corba/rtcorba/rtcosscheduling/echo-impl.ads0000644000175000017500000000460411750740337026522 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- E C H O . I M P L -- -- -- -- S p e c -- -- -- -- Copyright (C) 2002-2008, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by ACT Europe. -- -- (email: sales@act-europe.fr) -- -- -- ------------------------------------------------------------------------------ with CORBA; with PortableServer; package Echo.Impl is -- My own implementation of echo object. -- This is simply used to define the operations. type Object is new PortableServer.Servant_Base with null record; type Object_Acc is access Object; function EchoString (Self : access Object; Mesg : CORBA.String) return CORBA.Short; end Echo.Impl; polyorb-2.8~20110207.orig/examples/corba/rtcorba/rtcosscheduling/echo.idl0000644000175000017500000000007111750740337025556 0ustar xavierxavierinterface Echo { short echoString (in string Mesg); }; polyorb-2.8~20110207.orig/examples/corba/rtcorba/rtcosscheduling/Makefile.local0000644000175000017500000000013211750740337026675 0ustar xavierxavier${current_dir}echo.idl-stamp: idlac_flags := ${test_target}: ${current_dir}echo.idl-stamp polyorb-2.8~20110207.orig/examples/corba/rtcorba/rtcosscheduling/server_scheduling.conf0000644000175000017500000000074211750740337030535 0ustar xavierxavier# Name of the object [object object1] # Object priority, in RTCORBA.Priority'Range priority=20000 # Name of the POA [poa poa1] # PriorityModelPolicy for POA priority_model=SERVER_DECLARED default_priority=40 # Threadpools attached to POA threadpool_id=0 # Name of the POA [poa poa2] # PriorityModelPolicy for POA priority_model=CLIENT_PROPAGATED default_priority=0 # Threadpools attached to POA threadpool_id=0 # Name of the POA [poa poa3] # POA with no defined policies polyorb-2.8~20110207.orig/examples/corba/rtcorba/rtcosscheduling/echo-impl.adb0000644000175000017500000000677711750740337026516 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- E C H O . I M P L -- -- -- -- B o d y -- -- -- -- Copyright (C) 2002-2008, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by ACT Europe. -- -- (email: sales@act-europe.fr) -- -- -- ------------------------------------------------------------------------------ with Ada.Dynamic_Priorities; with Ada.Text_IO; with Echo.Skel; pragma Warnings (Off); -- Compiler wants Elaborate_All, but that causes cycles pragma Elaborate (Echo.Skel); pragma Warnings (On); pragma Warnings (Off, Echo.Skel); -- No entity from Echo.Skel is referenced. with RTCORBA.PriorityMapping; with PolyORB.RTCORBA_P.Setup; with System; package body Echo.Impl is ---------------- -- EchoString -- ---------------- function EchoString (Self : access Object; Mesg : CORBA.String) return CORBA.Short is pragma Warnings (Off); pragma Unreferenced (Self); pragma Warnings (On); use Ada.Dynamic_Priorities; use Ada.Text_IO; Ada_Priority : constant System.Any_Priority := Get_Priority; CORBA_Priority : RTCORBA.Priority; Ok : Boolean; begin RTCORBA.PriorityMapping.To_CORBA (PolyORB.RTCORBA_P.Setup.Get_Priority_Mapping.all, RTCORBA.NativePriority (Ada_Priority), CORBA_Priority, Ok); if not Ok then raise Program_Error; end if; Put_Line ("In echo servant, running thread at " & "Ada native priority" & System.Any_Priority'Image (Ada_Priority) & ", CORBA priority (approximation)" & RTCORBA.Priority'Image (CORBA_Priority)); Put_Line ("Echoing string: « " & CORBA.To_Standard_String (Mesg) & " »"); return CORBA.Short (CORBA_Priority); end EchoString; end Echo.Impl; polyorb-2.8~20110207.orig/examples/corba/rtcorba/rtcosscheduling/local.gpr0000644000175000017500000000070211750740337025753 0ustar xavierxavierwith "polyorb", "polyorb_test_common"; project local is Dir := external ("Test_Dir"); Obj_Dir := PolyORB_Test_Common.Build_Dir & Dir; for Object_Dir use Obj_Dir; for Source_Dirs use (Obj_Dir, PolyORB_Test_Common.Source_Dir & Dir); package Compiler is for Default_Switches ("Ada") use PolyORB_Test_Common.Compiler'Default_Switches ("Ada"); end Compiler; for Main use ("client.adb", "server.adb"); end local; polyorb-2.8~20110207.orig/examples/corba/rtcorba/rtcosscheduling/client_scheduling.conf0000644000175000017500000000004411750740337030500 0ustar xavierxavier[activity activity1] priority=10000 polyorb-2.8~20110207.orig/examples/corba/rtcorba/rtcosscheduling/server.adb0000644000175000017500000002446411750740337026140 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- S E R V E R -- -- -- -- B o d y -- -- -- -- Copyright (C) 2005-2007, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with Ada.Exceptions; with Ada.Text_IO; with CORBA.Impl; with CORBA.Object; with CORBA.ORB; with CORBA.Policy; with PortableServer.POA.Helper; with PortableServer.POAManager; with RTCORBA.RTORB.Helper; with RTCORBA.PriorityMapping.Linear; with RTPortableServer.POA.Helper; with RTCosScheduling.ServerScheduler.Impl; with PolyORB.RTCORBA_P.Setup; with Echo.Impl; with PolyORB.Utils.Report; with PolyORB.Smart_Pointers; -- Begin of PolyORB's setup with PolyORB.Log.Stderr; pragma Warnings (Off, PolyORB.Log.Stderr); pragma Elaborate_All (PolyORB.Log.Stderr); with PolyORB.ORB.Thread_Pool; pragma Warnings (Off, PolyORB.ORB.Thread_Pool); pragma Elaborate_All (PolyORB.ORB.Thread_Pool); with PolyORB.ORB_Controller.Half_Sync_Half_Async; pragma Warnings (Off, PolyORB.ORB_Controller.Half_Sync_Half_Async); pragma Elaborate_All (PolyORB.ORB_Controller.Half_Sync_Half_Async); with PolyORB.Request_Scheduler.Servant_Lane; pragma Warnings (Off, PolyORB.Request_Scheduler.Servant_Lane); pragma Elaborate_All (PolyORB.Request_Scheduler.Servant_Lane); with PolyORB.Tasking.Profiles.Full_Tasking.Threads.Dynamic_Priorities; pragma Elaborate_All (PolyORB.Tasking.Profiles.Full_Tasking.Threads.Dynamic_Priorities); pragma Warnings (Off, PolyORB.Tasking.Profiles.Full_Tasking.Threads.Dynamic_Priorities); with PolyORB.Tasking.Profiles.Full_Tasking.Threads; pragma Elaborate_All (PolyORB.Tasking.Profiles.Full_Tasking.Threads); pragma Warnings (Off, PolyORB.Tasking.Profiles.Full_Tasking.Threads); with PolyORB.Tasking.Profiles.Full_Tasking.Threads.Annotations; pragma Elaborate_All (PolyORB.Tasking.Profiles.Full_Tasking.Threads.Annotations); pragma Warnings (Off, PolyORB.Tasking.Profiles.Full_Tasking.Threads.Annotations); with PolyORB.Tasking.Profiles.Full_Tasking.Mutexes; pragma Elaborate_All (PolyORB.Tasking.Profiles.Full_Tasking.Mutexes); pragma Warnings (Off, PolyORB.Tasking.Profiles.Full_Tasking.Mutexes); with PolyORB.Tasking.Profiles.Full_Tasking.Condition_Variables; pragma Elaborate_All (PolyORB.Tasking.Profiles.Full_Tasking.Condition_Variables); pragma Warnings (Off, PolyORB.Tasking.Profiles.Full_Tasking.Condition_Variables); with PolyORB.Parameters.File; pragma Warnings (Off, PolyORB.Parameters.File); pragma Elaborate_All (PolyORB.Parameters.File); with PolyORB.Setup.OA.Basic_RT_POA; pragma Warnings (Off, PolyORB.Setup.OA.Basic_RT_POA); pragma Elaborate_All (PolyORB.Setup.OA.Basic_RT_POA); with PolyORB.Setup.IIOP; pragma Elaborate_All (PolyORB.Setup.IIOP); pragma Warnings (Off, PolyORB.Setup.IIOP); with PolyORB.Setup.Access_Points.IIOP; pragma Elaborate_All (PolyORB.Setup.Access_Points.IIOP); pragma Warnings (Off, PolyORB.Setup.Access_Points.IIOP); with PolyORB.GIOP_P.Tagged_Components.Policies.Priority_Model_Policy; pragma Elaborate_All (PolyORB.GIOP_P.Tagged_Components.Policies.Priority_Model_Policy); pragma Warnings (Off, PolyORB.GIOP_P.Tagged_Components.Policies.Priority_Model_Policy); -- End of PolyORB's setup procedure Server is use Ada.Text_IO; use CORBA.ORB; use PortableServer; use PortableServer.POA; use RTCORBA; use RTCORBA.RTORB; use PolyORB.Utils.Report; Priority_Mapping : RTCORBA.PriorityMapping.Linear.Object; begin CORBA.ORB.Initialize ("ORB"); New_Test ("RTCosScheduling server"); -- Setting up default Priority Mapping for this node PolyORB.RTCORBA_P.Setup.Set_Priority_Mapping (Priority_Mapping); Output ("ORB is configured", True); declare RT_ORB : RTCORBA.RTORB.Local_Ref; Root_POA : PortableServer.POA.Local_Ref; Obj_Server_1 : constant CORBA.Impl.Object_Ptr := new Echo.Impl.Object; Thread_Pool_Id_1 : RTCORBA.ThreadpoolId; Lanes : RTCORBA.ThreadpoolLanes; No_Policy : CORBA.Policy.PolicyList; Child_POA_Server_1 : RTPortableServer.POA.Local_Ref; Child_POA_Server_2 : RTPortableServer.POA.Local_Ref; pragma Unreferenced (Child_POA_Server_2); -- Child_POA_Server_2 is assigned a value, but not used Ref_Server_1 : CORBA.Object.Ref; Base_Priority : constant RTCORBA.Priority := 1_000; Default_Priority_1 : constant RTCORBA.Priority := 10_000; Default_Priority_2 : constant RTCORBA.Priority := 20_000; -- ServerScheduler object Server_Scheduler_Object : constant RTCosScheduling.ServerScheduler.Impl.Object_Ptr := new RTCosScheduling.ServerScheduler.Impl.Object; Server_Scheduler : RTCosScheduling.ServerScheduler.Local_Ref; begin -- Retrieve RT ORB RT_ORB := RTCORBA.RTORB.Helper.To_Local_Ref (Resolve_Initial_References (To_CORBA_String ("RTORB"))); Output ("Retrieved reference on RT ORB", True); -- Retrieve Root POA Root_POA := PortableServer.POA.Helper.To_Local_Ref (CORBA.ORB.Resolve_Initial_References (CORBA.ORB.To_CORBA_String ("RootPOA"))); PortableServer.POAManager.Activate (PortableServer.POA.Get_The_POAManager (Root_POA)); Output ("Retrieved and activated Root POA", True); -- Create Lanes Append (Lanes, RTCORBA.ThreadpoolLane'(Lane_Priority => Base_Priority, Static_Threads => 2, Dynamic_Threads => 0)); Append (Lanes, RTCORBA.ThreadpoolLane'(Lane_Priority => Default_Priority_1, Static_Threads => 2, Dynamic_Threads => 0)); Append (Lanes, RTCORBA.ThreadpoolLane'(Lane_Priority => Default_Priority_2, Static_Threads => 2, Dynamic_Threads => 0)); Output ("Lanes created", True); -- Construct Thread Pool policy from previous threadpool Thread_Pool_Id_1 := Create_Threadpool_With_Lanes (RT_ORB, Stacksize => 262_144, Lanes => Lanes, Allow_Borrowing => False, Allow_Request_Buffering => False, Max_Buffered_Requests => 1, Max_Request_Buffer_Size => 0); Output ("Create Threadpool #" & RTCORBA.ThreadpoolId'Image (Thread_Pool_Id_1), True); -- Set up ServerScheduler RTCosScheduling.ServerScheduler.Set (Server_Scheduler, PolyORB.Smart_Pointers.Entity_Ptr (Server_Scheduler_Object)); Output ("ServerScheduler created", True); -- Reading configuration file RTCosScheduling.ServerScheduler.Impl.Load_Configuration_File ("server_scheduling.conf"); Output ("Read configuration file", True); -- Creating POA from poa1 New_Test ("Setting up poa1"); Child_POA_Server_1 := RTPortableServer.POA.Helper.To_Local_Ref (RTCosScheduling.ServerScheduler.Create_POA (Server_Scheduler, Root_POA, CORBA.To_CORBA_String ("poa1"), PortableServer.POA.Get_The_POAManager (Root_POA), No_Policy)); Output ("Create Child POA with poa1 data", True); -- Creating POA from poa2 New_Test ("Setting up poa2"); Child_POA_Server_2 := RTPortableServer.POA.Helper.To_Local_Ref (RTCosScheduling.ServerScheduler.Create_POA (Server_Scheduler, Root_POA, CORBA.To_CORBA_String ("poa2"), PortableServer.POA.Get_The_POAManager (Root_POA), No_Policy)); Output ("Create Child POA with poa2 data", True); -- Set up new object and attach it to Child_POA Ref_Server_1 := PortableServer.POA.Servant_To_Reference (PortableServer.POA.Local_Ref (Child_POA_Server_1), PortableServer.Servant (Obj_Server_1)); Output ("Implicit activation of an object with these policies", True); -- Set up object1 New_Test ("Setting up object1"); RTCosScheduling.ServerScheduler.Schedule_Object (Server_Scheduler, Ref_Server_1, CORBA.To_CORBA_String ("object1")); New_Line; Put_Line ("'" & CORBA.To_Standard_String (CORBA.Object.Object_To_String (Ref_Server_1)) & "'"); New_Line; -- Run the ORB CORBA.ORB.Run; end; End_Report; exception when E : others => New_Line; Put_Line ("Got exception: " & Ada.Exceptions.Exception_Information (E)); Output ("Test failed", False); End_Report; end Server; polyorb-2.8~20110207.orig/examples/corba/rtcorba/rtcosscheduling/client.adb0000644000175000017500000002043211750740337026077 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- C L I E N T -- -- -- -- B o d y -- -- -- -- Copyright (C) 2005-2007, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with Ada.Command_Line; with Ada.Dynamic_Priorities; with Ada.Exceptions; with Ada.Text_IO; with CORBA.ORB; with Echo; with RTCORBA.Current.Helper; with RTCORBA.PriorityMapping.Linear; with RTCosScheduling.ClientScheduler.Impl; with PolyORB.RTCORBA_P.Setup; with PolyORB.Smart_Pointers; -- Begin of PolyORB's setup with PolyORB.ORB.Thread_Pool; pragma Elaborate_All (PolyORB.ORB.Thread_Pool); pragma Warnings (Off, PolyORB.ORB.Thread_Pool); with PolyORB.Setup.Server; pragma Elaborate_All (PolyORB.Setup.Server); pragma Warnings (Off, PolyORB.Setup.Server); with PolyORB.ORB_Controller.Half_Sync_Half_Async; pragma Warnings (Off, PolyORB.ORB_Controller.Half_Sync_Half_Async); pragma Elaborate_All (PolyORB.ORB_Controller.Half_Sync_Half_Async); with PolyORB.Tasking.Profiles.Full_Tasking.Threads.Dynamic_Priorities; pragma Elaborate_All (PolyORB.Tasking.Profiles.Full_Tasking.Threads.Dynamic_Priorities); pragma Warnings (Off, PolyORB.Tasking.Profiles.Full_Tasking.Threads.Dynamic_Priorities); with PolyORB.Tasking.Profiles.Full_Tasking.Threads; pragma Elaborate_All (PolyORB.Tasking.Profiles.Full_Tasking.Threads); pragma Warnings (Off, PolyORB.Tasking.Profiles.Full_Tasking.Threads); with PolyORB.Tasking.Profiles.Full_Tasking.Threads.Annotations; pragma Elaborate_All (PolyORB.Tasking.Profiles.Full_Tasking.Threads.Annotations); pragma Warnings (Off, PolyORB.Tasking.Profiles.Full_Tasking.Threads.Annotations); with PolyORB.Tasking.Profiles.Full_Tasking.Mutexes; pragma Elaborate_All (PolyORB.Tasking.Profiles.Full_Tasking.Mutexes); pragma Warnings (Off, PolyORB.Tasking.Profiles.Full_Tasking.Mutexes); with PolyORB.Tasking.Profiles.Full_Tasking.Condition_Variables; pragma Elaborate_All (PolyORB.Tasking.Profiles.Full_Tasking.Condition_Variables); pragma Warnings (Off, PolyORB.Tasking.Profiles.Full_Tasking.Condition_Variables); with PolyORB.QoS.Priority; pragma Elaborate_All (PolyORB.QoS.Priority); pragma Warnings (Off, PolyORB.QoS.Priority); -- End of PolyORB's setup with PolyORB.Utils.Report; procedure Client is use Ada.Command_Line; use Ada.Dynamic_Priorities; use Ada.Text_IO; use CORBA; use CORBA.ORB; use RTCORBA; use PolyORB.Utils.Report; Priority_Mapping : RTCORBA.PriorityMapping.Linear.Object; Sent_Msg : CORBA.String; Running_Priority : CORBA.Short; myecho : Echo.Ref; Native_Rounded_Priority : RTCORBA.NativePriority; Rounded_Priority : RTCORBA.Priority; Ok : Boolean; begin CORBA.ORB.Initialize ("ORB"); if Argument_Count /= 1 then Put_Line ("usage : client "); return; end if; New_Test ("RTCosScheduling client"); -- Setting up default Priority Mapping for this node PolyORB.RTCORBA_P.Setup.Set_Priority_Mapping (Priority_Mapping); Output ("ORB is configured", True); -- Getting the CORBA Object CORBA.ORB.String_To_Object (CORBA.To_CORBA_String (Ada.Command_Line.Argument (1)), myecho); -- Checking if it worked if Echo.Is_Nil (myecho) then Put_Line ("main : cannot invoke on a nil reference"); return; end if; -- Test #0, invocation without setting client's priority -- Sending message Sent_Msg := CORBA.To_CORBA_String (Standard.String'("Hello Ada !")); Running_Priority := Echo.echoString (myecho, Sent_Msg); -- Printing result Put_Line ("I said : " & CORBA.To_Standard_String (Sent_Msg)); Put_Line ("Request executed at priority:" & CORBA.Short'Image (Running_Priority)); -- Computing rounded priority RTCORBA.PriorityMapping.To_Native (PolyORB.RTCORBA_P.Setup.Get_Priority_Mapping.all, 20_000, Native_Rounded_Priority, Ok); if not Ok then raise Program_Error; end if; RTCORBA.PriorityMapping.To_CORBA (PolyORB.RTCORBA_P.Setup.Get_Priority_Mapping.all, Native_Rounded_Priority, Rounded_Priority, Ok); if not Ok then raise Program_Error; end if; Output ("Running priority is correct", Running_Priority = CORBA.Short (Rounded_Priority)); -- Test #1, invocation using ClientScheduler information declare Current : constant RTCORBA.Current.Local_Ref := RTCORBA.Current.Helper.To_Local_Ref (Resolve_Initial_References (To_CORBA_String ("RTCurrent"))); Client_Scheduler_Object : constant RTCosScheduling.ClientScheduler.Impl.Object_Ptr := new RTCosScheduling.ClientScheduler.Impl.Object; Client_Scheduler : RTCosScheduling.ClientScheduler.Local_Ref; begin RTCosScheduling.ClientScheduler.Set (Client_Scheduler, PolyORB.Smart_Pointers.Entity_Ptr (Client_Scheduler_Object)); Output ("ClientScheduler created", True); -- Reading configuration file RTCosScheduling.ClientScheduler.Impl.Load_Configuration_File ("client_scheduling.conf"); Output ("Read configuration file", True); -- Set up activity1 RTCosScheduling.ClientScheduler.Schedule_Activity (Client_Scheduler, CORBA.To_CORBA_String ("activity1")); Output ("Retrieve RTCurrent priority raised no exception", RTCORBA.Current.Get_The_Priority (Current) = 10_000); -- Sending message Sent_Msg := CORBA.To_CORBA_String (Standard.String'("Hello Ada !")); Running_Priority := Echo.echoString (myecho, Sent_Msg); -- Printing result Put_Line ("I said : " & CORBA.To_Standard_String (Sent_Msg)); Put_Line ("Request executed at priority:" & CORBA.Short'Image (Running_Priority)); -- Test running Priority is compatible with our priority -- Implementation Note: this test relies on the fact that -- client and server nodes are homogeneous. -- Computing rounded priority RTCORBA.PriorityMapping.To_CORBA (PolyORB.RTCORBA_P.Setup.Get_Priority_Mapping.all, RTCORBA.NativePriority (Get_Priority), Rounded_Priority, Ok); if not Ok then raise Program_Error; end if; Output ("Running priority is correct", Running_Priority = CORBA.Short (Rounded_Priority)); end; End_Report; CORBA.ORB.Shutdown (False); exception when E : others => Put_Line ("Got exception: " & Ada.Exceptions.Exception_Information (E)); End_Report; end Client; polyorb-2.8~20110207.orig/examples/corba/thread_pool_tester/0000755000175000017500000000000011750740340023174 5ustar xavierxavierpolyorb-2.8~20110207.orig/examples/corba/thread_pool_tester/conditions.adb0000644000175000017500000000451611750740337026031 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- C O N D I T I O N S -- -- -- -- B o d y -- -- -- -- Copyright (C) 2008, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ package body Conditions is procedure Create_Conditions (Count : Natural) is begin Condition_Variables := new Condition_Array (0 .. Count - 1); for J in Condition_Variables'Range loop Create (Condition_Variables (J)); end loop; Create (Mutex); end Create_Conditions; end Conditions; polyorb-2.8~20110207.orig/examples/corba/thread_pool_tester/Makefile.local0000644000175000017500000000013411750740337025731 0ustar xavierxavier${current_dir}svc.idl-stamp: idlac_flags := -ir ${test_target}: ${current_dir}svc.idl-stamp polyorb-2.8~20110207.orig/examples/corba/thread_pool_tester/transient_tasks.ads0000644000175000017500000000475111750740337027116 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- T R A N S I E N T _ T A S K S -- -- -- -- S p e c -- -- -- -- Copyright (C) 2008, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ generic with procedure Transient_Processing (Id : Natural) is <>; package Transient_Tasks is task type Transient_Task is entry Start (Id : Natural); entry Enter; entry Quit; end Transient_Task; type Transient_Task_Array is array (Natural range <>) of Transient_Task; type Transient_Task_Array_Access is access all Transient_Task_Array; Transient_Tasks : Transient_Task_Array_Access; procedure Start (Count : Natural); end Transient_Tasks; polyorb-2.8~20110207.orig/examples/corba/thread_pool_tester/transient_tasks.adb0000644000175000017500000000602611750740337027072 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- T R A N S I E N T _ T A S K S -- -- -- -- B o d y -- -- -- -- Copyright (C) 2008, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with Ada.Text_IO; use Ada.Text_IO; package body Transient_Tasks is task body Transient_Task is My_Id : Natural; begin accept Start (Id : Natural) do My_Id := Id; end Start; Put_Line ("Transient" & My_Id'Img & ": enter"); Transient_Task_Loop : loop select accept Quit do Put_Line ("Transient" & My_Id'Img & ": leave"); end Quit; exit Transient_Task_Loop; or accept Enter do Put_Line ("Transient" & My_Id'Img & ": going transient"); end Enter; Transient_Processing (My_Id); Put_Line ("Transient" & My_Id'Img & ": going dormant"); end select; end loop Transient_Task_Loop; end Transient_Task; procedure Start (Count : Natural) is begin Transient_Tasks := new Transient_Task_Array (0 .. Count - 1); for J in Transient_Tasks'Range loop Transient_Tasks (J).Start (J); end loop; end Start; end Transient_Tasks; polyorb-2.8~20110207.orig/examples/corba/thread_pool_tester/shell.ads0000644000175000017500000000432411750740337025005 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- S H E L L -- -- -- -- S p e c -- -- -- -- Copyright (C) 2008, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ generic type Command_Type is (<>); with procedure Handle_Command (Command : Command_Type; Argument : String) is <>; package Shell is Exit_Shell : exception; procedure Interact; end Shell; polyorb-2.8~20110207.orig/examples/corba/thread_pool_tester/conditions.ads0000644000175000017500000000502111750740337026042 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- C O N D I T I O N S -- -- -- -- S p e c -- -- -- -- Copyright (C) 2008, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with PolyORB.Tasking.Mutexes; use PolyORB.Tasking.Mutexes; with PolyORB.Tasking.Condition_Variables; use PolyORB.Tasking.Condition_Variables; package Conditions is type Condition_Array is array (Natural range <>) of Condition_Access; type Condition_Array_Access is access all Condition_Array; Condition_Variables : Condition_Array_Access; Mutex : Mutex_Access; procedure Create_Conditions (Count : Natural); -- Initialize Condition_Variables by creating Count condition variables end Conditions; polyorb-2.8~20110207.orig/examples/corba/thread_pool_tester/svc-impl.ads0000644000175000017500000000536611750740337025437 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- S V C . I M P L -- -- -- -- S p e c -- -- -- -- Copyright (C) 2008, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ pragma Style_Checks ("NM32766"); --------------------------------------------------- -- This file has been generated automatically from -- svc.idl -- by IAC (IDL to Ada Compiler) 2.5.0w (rev. 127820). --------------------------------------------------- with PortableServer; with CORBA; pragma Elaborate_All (CORBA); package Svc.Impl is type Object is new PortableServer.Servant_Base with private; type Object_Ptr is access all Object'Class; procedure Wait (Self : not null access Object; Cond_Id : CORBA.Short); private type Object is new PortableServer.Servant_Base with record -- Insert components to hold the state of the implementation object null; end record; end Svc.Impl; polyorb-2.8~20110207.orig/examples/corba/thread_pool_tester/shell.adb0000644000175000017500000000572611750740337024773 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- S H E L L -- -- -- -- B o d y -- -- -- -- Copyright (C) 2008, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with Ada.Text_IO; use Ada.Text_IO; package body Shell is procedure Interact is Line : String (1 .. 80); Last : Integer; Space : Integer; Command : Command_Type; begin Main_Loop : loop begin Get_Command : loop Put ("> "); Get_Line (Line, Last); Space := 1; while Space <= Last and then Line (Space) /= ' ' loop Space := Space + 1; end loop; begin Command := Command_Type'Value (Line (1 .. Space - 1)); exit Get_Command; exception when Constraint_Error => Put_Line ("?"); end; end loop Get_Command; Handle_Command (Command, Line (Space + 1 .. Last)); end; end loop Main_Loop; exception when Exit_Shell => null; end Interact; end Shell; polyorb-2.8~20110207.orig/examples/corba/thread_pool_tester/svc-impl.adb0000644000175000017500000000531611750740337025411 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- S V C . I M P L -- -- -- -- B o d y -- -- -- -- Copyright (C) 2008, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with Svc.Skel; pragma Unreferenced (Svc.Skel); with Ada.Text_IO; use Ada.Text_IO; with Conditions; use Conditions; with PolyORB.Tasking.Condition_Variables; use PolyORB.Tasking.Condition_Variables; with PolyORB.Tasking.Mutexes; use PolyORB.Tasking.Mutexes; package body Svc.Impl is ---------- -- Wait -- ---------- procedure Wait (Self : not null access Object; Cond_Id : CORBA.Short) is pragma Unreferenced (Self); begin Put_Line ("Wait: enter, Cond_Id =" & Cond_Id'Img); Enter (Mutex); Wait (Condition_Variables (Natural (Cond_Id)), Mutex); Leave (Mutex); Put_Line ("Wait: leave, Cond_Id =" & Cond_Id'Img); end Wait; end Svc.Impl; polyorb-2.8~20110207.orig/examples/corba/thread_pool_tester/polyorb.conf0000644000175000017500000000003111750740337025531 0ustar xavierxavier[tasking] max_threads=10 polyorb-2.8~20110207.orig/examples/corba/thread_pool_tester/local.gpr0000644000175000017500000000070211750740337025005 0ustar xavierxavierwith "polyorb", "polyorb_test_common"; project local is Dir := external ("Test_Dir"); Obj_Dir := PolyORB_Test_Common.Build_Dir & Dir; for Object_Dir use Obj_Dir; for Source_Dirs use (Obj_Dir, PolyORB_Test_Common.Source_Dir & Dir); package Compiler is for Default_Switches ("Ada") use PolyORB_Test_Common.Compiler'Default_Switches ("Ada"); end Compiler; for Main use ("client.adb", "server.adb"); end local; polyorb-2.8~20110207.orig/examples/corba/thread_pool_tester/server.adb0000644000175000017500000001643211750740337025166 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- S E R V E R -- -- -- -- B o d y -- -- -- -- Copyright (C) 2008-2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with Ada.Exceptions; use Ada.Exceptions; with Ada.Text_IO; use Ada.Text_IO; with GNAT.OS_Lib; use GNAT.OS_Lib; with CORBA.ORB; use CORBA; use CORBA.ORB; with PortableServer.POA; with PortableServer.POAManager; with PolyORB.Tasking.Condition_Variables; use PolyORB.Tasking.Condition_Variables; with PolyORB.CORBA_P.Server_Tools; use PolyORB.CORBA_P.Server_Tools; with PolyORB.ORB; use PolyORB.ORB; with PolyORB.Setup.Thread_Pool_Server; pragma Unreferenced (PolyORB.Setup.Thread_Pool_Server); with PolyORB.Asynch_Ev; use PolyORB.Asynch_Ev; with PolyORB.ORB.Thread_Pool; use PolyORB.ORB.Thread_Pool; with PolyORB.ORB_Controller; use PolyORB.ORB_Controller; with PolyORB.Requests; with PolyORB.Task_Info; use PolyORB.Task_Info; with Svc.Impl; with Conditions; use Conditions; with Shell; with Transient_Tasks; procedure Server is Svc_Ref : Svc.Ref; Count : Integer; type Transient_Info_Array is array (Natural range <>) of aliased PolyORB.Requests.Request; type Transient_Info_Array_Access is access all Transient_Info_Array; Transient_Infos : Transient_Info_Array_Access; procedure Transient_Processing (Id : Natural) is begin Transient_Infos (Id).Completed := False; Put_Line ("Server transient" & Id'Img & ": enter"); PolyORB.ORB.Run (PolyORB.Setup.The_ORB, Request => Transient_Infos (Id)'Unchecked_Access, May_Exit => True); Put_Line ("Server transient" & Id'Img & ": leave"); end Transient_Processing; package Server_Tasks is new Transient_Tasks; use Server_Tasks; Servers : Transient_Task_Array_Access renames Server_Tasks.Transient_Tasks; type Command_Type is (Signal, Status, Add, Del, Quit); procedure Handle_Command (Command : Command_Type; Argument : String); package Server_Shell is new Shell (Command_Type); procedure Handle_Command (Command : Command_Type; Argument : String) is begin case Command is when Quit => raise Server_Shell.Exit_Shell; when Signal => if Argument = "all" then for J in Condition_Variables'Range loop Signal (Condition_Variables (J)); end loop; else declare Condition : Natural; begin Condition := Natural'Value (Argument); Signal (Condition_Variables (Condition)); exception when Constraint_Error => Put_Line ("bad condition id: " & Argument); end; end if; when Status => declare function Status (O : access ORB_Controller) return String; pragma Import (Ada, Status, "polyorb__orb_controller__status"); begin Put_Line (Status (ORB_Controller (PolyORB.Setup.The_ORB.ORB_Controller.all)'Access)); end; when Add => Servers (Natural'Value (Argument)).Enter; when Del => declare Id : constant Natural := Natural'Value (Argument); TI : Task_Info renames Transient_Infos (Id).Requesting_Task.all; begin Enter_ORB_Critical_Section (PolyORB.Setup.The_ORB.ORB_Controller); Put_Line ("awaking transient task" & Id'Img & " from " & State (TI)'Img); Transient_Infos (Id).Completed := True; case State (TI) is when Idle => Signal (Condition (TI)); when Blocked => Abort_Check_Sources (Selector (TI).all); when others => null; end case; Leave_ORB_Critical_Section (PolyORB.Setup.The_ORB.ORB_Controller); end; end case; end Handle_Command; begin Put_Line ("Server: enter"); CORBA.ORB.Initialize ("ORB"); PortableServer.POAManager.Activate (PortableServer.POA.Get_The_POAManager (Get_Root_POA)); Put_Line ("Server: ORB initialized"); Put_Line ("min spare threads:" & Get_Minimum_Spare_Threads'Img); Put_Line ("max spare threads:" & Get_Maximum_Spare_Threads'Img); Put_Line ("max threads: " & Get_Maximum_Threads'Img); Count := Get_Maximum_Threads; Conditions.Create_Conditions (Count); Put_Line ("Server:" & Natural'Image (Condition_Variables'Length) & " CVs created"); Transient_Infos := new Transient_Info_Array (0 .. Count - 1); Server_Tasks.Start (Count); Put_Line ("Server:" & Natural'Image (Condition_Variables'Length) & " transient tasks created"); Initiate_Servant (new Svc.Impl.Object, Svc_Ref); Put_Line ("Server: servant initialized"); declare IOR_File : File_Type; begin Create (IOR_File, Out_File, "svc.ior"); Put_Line (IOR_File, To_Standard_String (Object_To_String (Svc_Ref))); Close (IOR_File); end; Put_Line ("IOR written to svc.ior"); Server_Shell.Interact; CORBA.ORB.Shutdown (Wait_For_Completion => False); Put_Line ("Server: leave"); GNAT.OS_Lib.OS_Exit (0); exception when E : others => Put_Line ("Server main loop got exception: " & Ada.Exceptions.Exception_Information (E)); end Server; polyorb-2.8~20110207.orig/examples/corba/thread_pool_tester/client.adb0000644000175000017500000001006011750740337025125 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- C L I E N T -- -- -- -- B o d y -- -- -- -- Copyright (C) 2008, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with Ada.Text_IO; use Ada.Text_IO; with GNAT.OS_Lib; use GNAT.OS_Lib; with CORBA.ORB; use CORBA; use CORBA.ORB; with PolyORB.Setup.Thread_Pool_Server; pragma Unreferenced (PolyORB.Setup.Thread_Pool_Server); with PolyORB.ORB.Thread_Pool; use PolyORB.ORB.Thread_Pool; with Svc; with Shell; with Transient_Tasks; procedure Client is Svc_Ref : Svc.Ref; Count : Integer; procedure Transient_Processing (Id : Natural) is begin Svc.Wait (Svc_Ref, CORBA.Short (Id)); end Transient_Processing; package Client_Tasks is new Transient_Tasks; use Client_Tasks; Clients : Transient_Task_Array_Access renames Client_Tasks.Transient_Tasks; type Command_Type is (Call, Quit); procedure Handle_Command (Command : Command_Type; Argument : String); package Client_Shell is new Shell (Command_Type); procedure Handle_Command (Command : Command_Type; Argument : String) is begin case Command is when Quit => raise Client_Shell.Exit_Shell; when Call => Clients (Natural'Value (Argument)).Enter; end case; end Handle_Command; begin Put_Line ("Client: enter"); CORBA.ORB.Initialize ("ORB"); Put_Line ("min spare threads:" & Get_Minimum_Spare_Threads'Img); Put_Line ("max spare threads:" & Get_Maximum_Spare_Threads'Img); Put_Line ("max threads: " & Get_Maximum_Threads'Img); Count := Get_Maximum_Threads; Put_Line ("Client: ORB initialized"); Count := Count * 2; Client_Tasks.Start (Count); Put_Line ("Client:" & Natural'Image (Clients'Length) & " tasks created"); declare IOR_File : File_Type; IOR : String (1 .. 1024); Last : Integer; begin Open (IOR_File, In_File, "svc.ior"); Get_Line (IOR_File, IOR, Last); Close (IOR_File); String_To_Object (To_CORBA_String (IOR (1 .. Last)), Svc_Ref); end; Put_Line ("IOR read from svc.ior"); Client_Shell.Interact; CORBA.ORB.Shutdown (Wait_For_Completion => False); Put_Line ("Client: leave"); GNAT.OS_Lib.OS_Exit (0); end Client; polyorb-2.8~20110207.orig/examples/corba/thread_pool_tester/svc.idl0000644000175000017500000000014211750740337024464 0ustar xavierxavierinterface Svc { void Wait (in short Cond_Id); // Wait on the indicated condition variable }; polyorb-2.8~20110207.orig/examples/corba/random/0000755000175000017500000000000011750740340020566 5ustar xavierxavierpolyorb-2.8~20110207.orig/examples/corba/random/Makefile.local0000644000175000017500000000013611750740337023325 0ustar xavierxavier${current_dir}random.idl-stamp: idlac_flags := ${test_target}: ${current_dir}random.idl-stamp polyorb-2.8~20110207.orig/examples/corba/random/random-impl.adb0000644000175000017500000000600311750740337023462 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- R A N D O M . I M P L -- -- -- -- B o d y -- -- -- -- Copyright (C) 2002 Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by ACT Europe. -- -- (email: sales@act-europe.fr) -- -- -- ------------------------------------------------------------------------------ with Ada.Numerics.Discrete_Random; with Random.Skel; pragma Warnings (Off, Random.Skel); -- No entity from Random.Skel is referenced. package body Random.Impl is type l48 is range 0 .. 2 ** 31 - 1; package l48_Random is new Ada.Numerics.Discrete_Random (l48); l48_Gen : l48_Random.Generator; function lrand48 (Self : access Object) return CORBA.Long is begin pragma Warnings (Off); pragma Unreferenced (Self); pragma Warnings (On); return CORBA.Long (l48_Random.Random (l48_Gen)); end lrand48; type m48 is range -2 ** 31 .. 2 ** 31 - 1; package m48_Random is new Ada.Numerics.Discrete_Random (m48); m48_Gen : m48_Random.Generator; function mrand48 (Self : access Object) return CORBA.Long is begin pragma Warnings (Off); pragma Unreferenced (Self); pragma Warnings (On); return CORBA.Long (m48_Random.Random (m48_Gen)); end mrand48; begin l48_Random.Reset (l48_Gen); m48_Random.Reset (m48_Gen); end Random.Impl; polyorb-2.8~20110207.orig/examples/corba/random/random.idl0000644000175000017500000000054311750740337022550 0ustar xavierxavier// This interface was copied from http://random.org/corba.html, where you can // also find the current IOR of the server. // See client.cc for details. // IDL interface Random { // return non-negative long integer in the interval [0, 2^31) long lrand48(); // return signed long integer in the interval [-2^31, 2^31) long mrand48(); }; polyorb-2.8~20110207.orig/examples/corba/random/random-impl.ads0000644000175000017500000000450411750740337023507 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- R A N D O M . I M P L -- -- -- -- S p e c -- -- -- -- Copyright (C) 2002 Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by ACT Europe. -- -- (email: sales@act-europe.fr) -- -- -- ------------------------------------------------------------------------------ with CORBA; with PortableServer; package Random.Impl is type Object is new PortableServer.Servant_Base with null record; type Object_Acc is access Object; function lrand48 (Self : access Object) return CORBA.Long; function mrand48 (Self : access Object) return CORBA.Long; end Random.Impl; polyorb-2.8~20110207.orig/examples/corba/random/local.gpr0000644000175000017500000000070211750740337022377 0ustar xavierxavierwith "polyorb", "polyorb_test_common"; project local is Dir := external ("Test_Dir"); Obj_Dir := PolyORB_Test_Common.Build_Dir & Dir; for Object_Dir use Obj_Dir; for Source_Dirs use (Obj_Dir, PolyORB_Test_Common.Source_Dir & Dir); package Compiler is for Default_Switches ("Ada") use PolyORB_Test_Common.Compiler'Default_Switches ("Ada"); end Compiler; for Main use ("client.adb", "server.adb"); end local; polyorb-2.8~20110207.orig/examples/corba/random/server.adb0000644000175000017500000000506611750740337022561 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- S E R V E R -- -- -- -- B o d y -- -- -- -- Copyright (C) 2002 Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by ACT Europe. -- -- (email: sales@act-europe.fr) -- -- -- ------------------------------------------------------------------------------ -- Random Server. with Random.Impl; with CORBA; with CORBA.Object; with CORBA.ORB; with PolyORB.Setup.No_Tasking_Server; pragma Warnings (Off, PolyORB.Setup.No_Tasking_Server); with PolyORB.CORBA_P.Server_Tools; with Ada.Text_IO; procedure Server is use PolyORB.CORBA_P.Server_Tools; Ref : CORBA.Object.Ref; begin CORBA.ORB.Initialize ("ORB"); Initiate_Servant (new Random.Impl.Object, Ref); Ada.Text_IO.Put_Line ("'" & CORBA.To_Standard_String (CORBA.Object.Object_To_String (Ref)) & "'"); Initiate_Server; end Server; polyorb-2.8~20110207.orig/examples/corba/random/client.adb0000644000175000017500000000675111750740337022533 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- C L I E N T -- -- -- -- B o d y -- -- -- -- Copyright (C) 2002-2004 Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by ACT Europe. -- -- (email: sales@act-europe.fr) -- -- -- ------------------------------------------------------------------------------ -- Random client. with Ada.Command_Line; with Ada.Text_IO; use Ada.Text_IO; with CORBA; use CORBA; with CORBA.ORB; with Random; with PolyORB.Setup.Client; pragma Warnings (Off, PolyORB.Setup.Client); with PolyORB.Utils.Report; procedure Client is use PolyORB.Utils.Report; IOR : CORBA.String; myRandom : Random.Ref; Result : CORBA.Long; begin New_Test ("CORBA Random"); CORBA.ORB.Initialize ("ORB"); if Ada.Command_Line.Argument_Count < 1 then Put_Line ("usage : client "); return; end if; -- transforms the Ada string into CORBA.String IOR := CORBA.To_CORBA_String (Ada.Command_Line.Argument (1)); -- getting the CORBA.Object CORBA.ORB.String_To_Object (IOR, myRandom); -- checking if it worked if Random.Is_Nil (myRandom) then Put_Line ("main : cannot invoke on a nil reference"); return; end if; Put_Line ("Here are some true random numbers:"); for I in 1 .. 10 loop Result := Random.lrand48 (myRandom); Put (CORBA.Long'Image (Result) & " "); end loop; New_Line; End_Report; exception when E : CORBA.Transient => declare Memb : System_Exception_Members; begin Get_Members (E, Memb); Put ("received exception transient, minor"); Put (Unsigned_Long'Image (Memb.Minor)); Put (", completion status: "); Put_Line (Completion_Status'Image (Memb.Completed)); End_Report; end; end Client; polyorb-2.8~20110207.orig/examples/corba/send/0000755000175000017500000000000011750740340020237 5ustar xavierxavierpolyorb-2.8~20110207.orig/examples/corba/send/interop/0000755000175000017500000000000011750740340021717 5ustar xavierxavierpolyorb-2.8~20110207.orig/examples/corba/send/interop/tao/0000755000175000017500000000000011750740340022502 5ustar xavierxavierpolyorb-2.8~20110207.orig/examples/corba/send/interop/tao/listener.cpp0000644000175000017500000000623111750740337025043 0ustar xavierxavier#include "Printer.h" #include "ace/Get_Opt.h" ACE_RCSID (Printer, listener, "listener.cpp") static char* conf[] = {"", "-ORBsvcconf", "server.conf"}; static int nb_conf_param = 3; static const char* groupURL_file = "groupURL"; bool print_ior = false; int main (int argc, char *argv[]) { ACE_TRY_NEW_ENV { conf[0] = argv[0]; CORBA::ORB_var orb = CORBA::ORB_init (nb_conf_param, conf, "" ACE_ENV_ARG_PARAMETER); ACE_TRY_CHECK; CORBA::Object_var poa_object = orb->resolve_initial_references("RootPOA" ACE_ENV_ARG_PARAMETER); ACE_TRY_CHECK; PortableServer::POA_var root_poa = PortableServer::POA::_narrow (poa_object.in () ACE_ENV_ARG_PARAMETER); ACE_TRY_CHECK; if (CORBA::is_nil (root_poa.in ())) ACE_ERROR_RETURN ((LM_ERROR, " (%P|%t) Panic: nil RootPOA\n"), 1); PortableServer::POAManager_var poa_manager = root_poa->the_POAManager (ACE_ENV_SINGLE_ARG_PARAMETER); ACE_TRY_CHECK; switch (argc) { case 1: break; case 2: if (strcmp (argv[1], "-v") == 0) { print_ior = true; break; } default: cout << "usage: " << argv[0] << " [-v]" << "\n"; return 1; } // Get the group IOR. FILE *input_file= ACE_OS::fopen (groupURL_file, "r"); if (input_file == 0) ACE_ERROR_RETURN ((LM_ERROR, "Cannot open intput file for reading IOR: %s", groupURL_file), 1); char groupURL[1000]; int i = 0; int k; while ((k = ACE_OS::fgetc (input_file)) > 32) { groupURL[i++] = k; } groupURL[i] = 0; ACE_OS::fclose (input_file); CORBA::String_var ior = CORBA::string_dup (groupURL); CORBA::Object_var group1 = orb->string_to_object (ior.in () ACE_ENV_ARG_PARAMETER); ACE_TRY_CHECK; cout << "Group IOR : '" << ior.in () << "'\n"; PortableServer::ObjectId_var id = root_poa->create_id_for_reference (group1.in () ACE_ENV_ARG_PARAMETER); ACE_TRY_CHECK; // Create and activate an instance of our servant. Printer server_impl (orb.in (), 0); root_poa->activate_object_with_id (id.in (), &server_impl ACE_ENV_ARG_PARAMETER); ACE_TRY_CHECK; if (print_ior) { Test::Printer_var server = server_impl._this (ACE_ENV_SINGLE_ARG_PARAMETER); ACE_TRY_CHECK; cout << "Object IOR : '" << orb->object_to_string (server.in () ACE_ENV_ARG_PARAMETER) << "'\n"; } poa_manager->activate (ACE_ENV_SINGLE_ARG_PARAMETER); ACE_TRY_CHECK; orb->run (ACE_ENV_SINGLE_ARG_PARAMETER); ACE_TRY_CHECK; ACE_DEBUG ((LM_DEBUG, "(%P|%t) server - event loop finished\n")); root_poa->destroy (1, 1 ACE_ENV_ARG_PARAMETER); ACE_TRY_CHECK; orb->destroy (ACE_ENV_SINGLE_ARG_PARAMETER); ACE_TRY_CHECK; } ACE_CATCHANY { ACE_PRINT_EXCEPTION (ACE_ANY_EXCEPTION, "Exception caught:"); return 1; } ACE_ENDTRY; return 0; } polyorb-2.8~20110207.orig/examples/corba/send/interop/tao/Makefile.bor0000644000175000017500000000022511750740337024730 0ustar xavierxavier# # Makefile.bor,v 1.2 2002/01/13 20:00:13 fhunleth Exp # MAKEFILES = server.bor client.bor !include <$(ACE_ROOT)\include\makeinclude\recurse.bor> polyorb-2.8~20110207.orig/examples/corba/send/interop/tao/README0000644000175000017500000000152311750740337023371 0ustar xavierxavierInteroperability with TAO's MIOP stack -------------------------------------- $Id: //droopi/main/examples/corba/send/interop/tao/README#3 $ TAO must be installed and configured, environement variables $ACE_ROOT et $TAO_ROOT set. Compile with 'make'. To run the test; Create a server : ./listener [-v] Multicast group is defined in file groupURL. options : -v ouputs object(s IOR, to be used with two-way calls. To run a client test : ./send ior [mode] ior is object reference, either a corbaloc or an ior mode = s | l | tws | twl s : print string l : print long tws : two way call, echo string twl : two way call, echo long TO ensure interoperability between TAO and PolyORB (as of 9/18/2003) Modify TAG_UIPMC in polyorb-binding_data.ads, Tag_Group giop/polyorb-giop_p-tagged_components.ads. Source files provide correct values, see comments polyorb-2.8~20110207.orig/examples/corba/send/interop/tao/server.conf.xml0000644000175000017500000000112011750740337025456 0ustar xavierxavier polyorb-2.8~20110207.orig/examples/corba/send/interop/tao/client.conf.xml0000644000175000017500000000061711750740337025440 0ustar xavierxavier polyorb-2.8~20110207.orig/examples/corba/send/interop/tao/groupURL0000644000175000017500000000007211750740337024151 0ustar xavierxaviercorbaloc:miop:1.0@1.0-TestDomain-5506/239.239.239.18:5678 polyorb-2.8~20110207.orig/examples/corba/send/interop/tao/Makefile0000644000175000017500000015626211750740337024164 0ustar xavierxavier#---------------------------------------------------------------------------- # Local macros #---------------------------------------------------------------------------- ifndef TAO_ROOT TAO_ROOT = $(ACE_ROOT)/TAO endif # ! TAO_ROOT vpath %.idl ../../ IDL_FILES = print IDL_SRC = printC.cpp printS.cpp BIN_UNCHECKED = send listener SRC = $(addsuffix .cpp, $(BIN) Printer) $(IDL_SRC) SEND_OBJS = send.o printC.o LISTENER_OBJS = listener.o Printer.o $(IDL_SRC:.cpp=.o) TAO_IDLFLAGS += -Ge 1 #---------------------------------------------------------------------------- # Include macros and targets #---------------------------------------------------------------------------- include $(ACE_ROOT)/include/makeinclude/wrapper_macros.GNU include $(ACE_ROOT)/include/makeinclude/macros.GNU include $(TAO_ROOT)/rules.tao.GNU #### If the TAO orbsvcs library wasn't built with sufficient components, #### don't try to build here. TAO_ORBSVCS := $(shell sh $(ACE_ROOT)/bin/ace_components --orbsvcs) ifeq (PortableGroup,$(findstring PortableGroup,$(TAO_ORBSVCS))) BIN = $(BIN_UNCHECKED) endif # PortableGroup include $(ACE_ROOT)/include/makeinclude/rules.common.GNU include $(ACE_ROOT)/include/makeinclude/rules.nonested.GNU include $(ACE_ROOT)/include/makeinclude/rules.local.GNU include $(TAO_ROOT)/taoconfig.mk #---------------------------------------------------------------------------- # Local targets #---------------------------------------------------------------------------- .PRECIOUS: $(foreach ext, $(IDL_EXT), print$(ext)) listener: $(addprefix $(VDIR),$(LISTENER_OBJS)) $(LINK.cc) $(LDFLAGS) -o $@ $^ -lTAO_PortableGroup $(TAO_SRVR_LIBS) $(POSTLINK) send: $(addprefix $(VDIR),$(SEND_OBJS)) $(LINK.cc) $(LDFLAGS) -o $@ $^ $(TAO_CLNT_LIBS) $(POSTLINK) realclean: clean -$(RM) $(foreach ext, $(IDL_EXT), print$(ext)) # DO NOT DELETE THIS LINE -- g++dep uses it. # DO NOT PUT ANYTHING AFTER THIS LINE, IT WILL GO AWAY. .obj/send.o .obj/send.so .shobj/send.o .shobj/send.so: send.cpp printC.h \ $(TAO_ROOT)/tao/corba.h \ $(ACE_ROOT)/ace/pre.h \ $(ACE_ROOT)/ace/post.h \ $(ACE_ROOT)/ace/ace_wchar.h \ $(ACE_ROOT)/ace/ace_wchar.inl \ $(TAO_ROOT)/tao/corbafwd.h \ $(ACE_ROOT)/ace/CDR_Base.h \ $(ACE_ROOT)/ace/Basic_Types.h \ $(ACE_ROOT)/ace/ACE_export.h \ $(ACE_ROOT)/ace/Basic_Types.i \ $(ACE_ROOT)/ace/Default_Constants.h \ $(ACE_ROOT)/ace/CDR_Base.inl \ $(TAO_ROOT)/tao/orbconf.h \ $(ACE_ROOT)/ace/Global_Macros.h \ $(ACE_ROOT)/ace/OS_Export.h \ $(TAO_ROOT)/tao/TAO_Export.h \ $(ACE_ROOT)/ace/OS_Memory.h \ $(ACE_ROOT)/ace/OS_Errno.h \ $(ACE_ROOT)/ace/OS_Errno.inl \ $(ACE_ROOT)/ace/OS_Memory.inl \ $(TAO_ROOT)/tao/corbafwd.i \ $(TAO_ROOT)/tao/Typecode.h \ $(ACE_ROOT)/ace/Hash_Map_Manager_T.h \ $(ACE_ROOT)/ace/Functor.h \ $(ACE_ROOT)/ace/ACE.h \ $(ACE_ROOT)/ace/OS.h \ $(ACE_ROOT)/ace/OS_Dirent.h \ $(ACE_ROOT)/ace/OS_Dirent.inl \ $(ACE_ROOT)/ace/OS_String.h \ $(ACE_ROOT)/ace/OS_String.inl \ $(ACE_ROOT)/ace/OS_TLI.h \ $(ACE_ROOT)/ace/OS_TLI.inl \ $(ACE_ROOT)/ace/Time_Value.h \ $(ACE_ROOT)/ace/Time_Value.inl \ $(ACE_ROOT)/ace/Min_Max.h \ $(ACE_ROOT)/ace/streams.h \ $(ACE_ROOT)/ace/Trace.h \ $(ACE_ROOT)/ace/OS.i \ $(ACE_ROOT)/ace/Flag_Manip.h \ $(ACE_ROOT)/ace/Flag_Manip.i \ $(ACE_ROOT)/ace/Handle_Ops.h \ $(ACE_ROOT)/ace/Handle_Ops.i \ $(ACE_ROOT)/ace/Lib_Find.h \ $(ACE_ROOT)/ace/Lib_Find.i \ $(ACE_ROOT)/ace/Init_ACE.h \ $(ACE_ROOT)/ace/Init_ACE.i \ $(ACE_ROOT)/ace/Sock_Connect.h \ $(ACE_ROOT)/ace/Sock_Connect.i \ $(ACE_ROOT)/ace/ACE.i \ $(ACE_ROOT)/ace/Functor.i \ $(ACE_ROOT)/ace/Functor_T.h \ $(ACE_ROOT)/ace/Functor_T.i \ $(ACE_ROOT)/ace/Functor_T.cpp \ $(ACE_ROOT)/ace/Log_Msg.h \ $(ACE_ROOT)/ace/Log_Priority.h \ $(ACE_ROOT)/ace/OS_Log_Msg_Attributes.h \ $(ACE_ROOT)/ace/OS_Log_Msg_Attributes.inl \ $(ACE_ROOT)/ace/Hash_Map_Manager_T.i \ $(ACE_ROOT)/ace/Synch.h \ $(ACE_ROOT)/ace/Synch.i \ $(ACE_ROOT)/ace/Synch_T.h \ $(ACE_ROOT)/ace/Synch_T.i \ $(ACE_ROOT)/ace/Thread.h \ $(ACE_ROOT)/ace/Thread_Adapter.h \ $(ACE_ROOT)/ace/Base_Thread_Adapter.h \ $(ACE_ROOT)/ace/Base_Thread_Adapter.inl \ $(ACE_ROOT)/ace/Thread_Adapter.inl \ $(ACE_ROOT)/ace/Thread.i \ $(ACE_ROOT)/ace/Synch_T.cpp \ $(ACE_ROOT)/ace/Hash_Map_Manager_T.cpp \ $(ACE_ROOT)/ace/Service_Config.h \ $(ACE_ROOT)/ace/Unbounded_Queue.h \ $(ACE_ROOT)/ace/Node.h \ $(ACE_ROOT)/ace/Node.cpp \ $(ACE_ROOT)/ace/Unbounded_Queue.inl \ $(ACE_ROOT)/ace/Unbounded_Queue.cpp \ $(ACE_ROOT)/ace/Malloc_Base.h \ $(ACE_ROOT)/ace/Unbounded_Set.h \ $(ACE_ROOT)/ace/Unbounded_Set.inl \ $(ACE_ROOT)/ace/Unbounded_Set.cpp \ $(ACE_ROOT)/ace/SString.h \ $(ACE_ROOT)/ace/SStringfwd.h \ $(ACE_ROOT)/ace/String_Base.h \ $(ACE_ROOT)/ace/String_Base_Const.h \ $(ACE_ROOT)/ace/String_Base.i \ $(ACE_ROOT)/ace/String_Base.cpp \ $(ACE_ROOT)/ace/Malloc.h \ $(ACE_ROOT)/ace/Malloc.i \ $(ACE_ROOT)/ace/Malloc_T.h \ $(ACE_ROOT)/ace/Malloc_Allocator.h \ $(ACE_ROOT)/ace/Malloc_Allocator.i \ $(ACE_ROOT)/ace/Free_List.h \ $(ACE_ROOT)/ace/Free_List.i \ $(ACE_ROOT)/ace/Free_List.cpp \ $(ACE_ROOT)/ace/Malloc_T.i \ $(ACE_ROOT)/ace/Malloc_T.cpp \ $(ACE_ROOT)/ace/Memory_Pool.h \ $(ACE_ROOT)/ace/Event_Handler.h \ $(ACE_ROOT)/ace/Event_Handler.i \ $(ACE_ROOT)/ace/Signal.h \ $(ACE_ROOT)/ace/Signal.i \ $(ACE_ROOT)/ace/Mem_Map.h \ $(ACE_ROOT)/ace/Mem_Map.i \ $(ACE_ROOT)/ace/SV_Semaphore_Complex.h \ $(ACE_ROOT)/ace/SV_Semaphore_Simple.h \ $(ACE_ROOT)/ace/SV_Semaphore_Simple.i \ $(ACE_ROOT)/ace/SV_Semaphore_Complex.i \ $(ACE_ROOT)/ace/Memory_Pool.i \ $(ACE_ROOT)/ace/Auto_Ptr.h \ $(ACE_ROOT)/ace/Auto_Ptr.i \ $(ACE_ROOT)/ace/Auto_Ptr.cpp \ $(ACE_ROOT)/ace/SString.i \ $(ACE_ROOT)/ace/XML_Svc_Conf.h \ $(ACE_ROOT)/ace/Service_Config.i \ $(ACE_ROOT)/ace/Reactor.h \ $(ACE_ROOT)/ace/Handle_Set.h \ $(ACE_ROOT)/ace/Handle_Set.i \ $(ACE_ROOT)/ace/Timer_Queue.h \ $(ACE_ROOT)/ace/Timer_Queue_T.h \ $(ACE_ROOT)/ace/Test_and_Set.h \ $(ACE_ROOT)/ace/Test_and_Set.i \ $(ACE_ROOT)/ace/Test_and_Set.cpp \ $(ACE_ROOT)/ace/Timer_Queue_T.i \ $(ACE_ROOT)/ace/Timer_Queue_T.cpp \ $(ACE_ROOT)/ace/Reactor.i \ $(ACE_ROOT)/ace/Reactor_Impl.h \ $(ACE_ROOT)/ace/Svc_Conf_Tokens.h \ $(TAO_ROOT)/tao/Exception.h \ $(ACE_ROOT)/ace/CORBA_macros.h \ $(ACE_ROOT)/ace/Exception_Macros.h \ $(ACE_ROOT)/ace/iosfwd.h \ $(TAO_ROOT)/tao/Exception.i \ $(TAO_ROOT)/tao/Pseudo_VarOut_T.h \ $(TAO_ROOT)/tao/Pseudo_VarOut_T.inl \ $(TAO_ROOT)/tao/Pseudo_VarOut_T.cpp \ $(TAO_ROOT)/tao/Typecode.i \ $(TAO_ROOT)/tao/Any_Impl_T.h \ $(TAO_ROOT)/tao/Any.h \ $(ACE_ROOT)/ace/CDR_Stream.h \ $(ACE_ROOT)/ace/Message_Block.h \ $(ACE_ROOT)/ace/Message_Block.i \ $(ACE_ROOT)/ace/Message_Block_T.h \ $(ACE_ROOT)/ace/Message_Block_T.i \ $(ACE_ROOT)/ace/Message_Block_T.cpp \ $(ACE_ROOT)/ace/CDR_Stream.i \ $(TAO_ROOT)/tao/Object.h \ $(TAO_ROOT)/tao/Policy_ForwardC.h \ $(TAO_ROOT)/tao/Sequence.h \ $(TAO_ROOT)/tao/Managed_Types.h \ $(TAO_ROOT)/tao/Managed_Types.i \ $(TAO_ROOT)/tao/Sequence.i \ $(TAO_ROOT)/tao/Sequence_T.h \ $(TAO_ROOT)/tao/Sequence_T.i \ $(TAO_ROOT)/tao/Sequence_T.cpp \ $(TAO_ROOT)/tao/Environment.h \ $(TAO_ROOT)/tao/Environment.i \ $(TAO_ROOT)/tao/CDR.h \ $(TAO_ROOT)/tao/CDR.i \ $(TAO_ROOT)/tao/Objref_VarOut_T.h \ $(TAO_ROOT)/tao/varbase.h \ $(TAO_ROOT)/tao/Objref_VarOut_T.inl \ $(TAO_ROOT)/tao/Objref_VarOut_T.cpp \ $(TAO_ROOT)/tao/Seq_Var_T.h \ $(TAO_ROOT)/tao/Seq_Var_T.inl \ $(TAO_ROOT)/tao/Seq_Var_T.cpp \ $(TAO_ROOT)/tao/Seq_Out_T.h \ $(TAO_ROOT)/tao/Seq_Out_T.inl \ $(TAO_ROOT)/tao/Seq_Out_T.cpp \ $(TAO_ROOT)/tao/Policy_ForwardC.i \ $(TAO_ROOT)/tao/Object_KeyC.h \ $(TAO_ROOT)/tao/Object_KeyC.i \ $(TAO_ROOT)/tao/IOP_IORC.h \ $(TAO_ROOT)/tao/OctetSeqC.h \ $(TAO_ROOT)/tao/OctetSeqC.i \ $(TAO_ROOT)/tao/VarOut_T.h \ $(TAO_ROOT)/tao/VarOut_T.inl \ $(TAO_ROOT)/tao/VarOut_T.cpp \ $(TAO_ROOT)/tao/IOP_IORC.i \ $(TAO_ROOT)/tao/Object.i \ $(TAO_ROOT)/tao/Any.i \ $(TAO_ROOT)/tao/Any_Impl_T.inl \ $(TAO_ROOT)/tao/Any_Impl_T.cpp \ $(TAO_ROOT)/tao/Marshal.h \ $(TAO_ROOT)/tao/Marshal.i \ $(TAO_ROOT)/tao/debug.h \ $(TAO_ROOT)/tao/Any_Basic_Impl_T.h \ $(TAO_ROOT)/tao/Any_Basic_Impl_T.inl \ $(TAO_ROOT)/tao/Any_Basic_Impl_T.cpp \ $(TAO_ROOT)/tao/Any_Special_Impl_T.h \ $(TAO_ROOT)/tao/Any_Special_Impl_T.inl \ $(TAO_ROOT)/tao/Any_Special_Impl_T.cpp \ $(TAO_ROOT)/tao/Any_Special_Basic_Impl_T.h \ $(TAO_ROOT)/tao/Any_Special_Basic_Impl_T.inl \ $(TAO_ROOT)/tao/Any_Special_Basic_Impl_T.cpp \ $(TAO_ROOT)/tao/Any_Array_Impl_T.h \ $(TAO_ROOT)/tao/Any_Array_Impl_T.inl \ $(TAO_ROOT)/tao/Any_Array_Impl_T.cpp \ $(TAO_ROOT)/tao/Any_Dual_Impl_T.h \ $(TAO_ROOT)/tao/Any_Dual_Impl_T.inl \ $(TAO_ROOT)/tao/Any_Dual_Impl_T.cpp \ $(TAO_ROOT)/tao/NVList.h \ $(TAO_ROOT)/tao/NVList.i \ $(TAO_ROOT)/tao/LocalObject.h \ $(TAO_ROOT)/tao/LocalObject.i \ $(TAO_ROOT)/tao/Principal.h \ $(TAO_ROOT)/tao/Principal.i \ $(TAO_ROOT)/tao/ORB.h \ $(TAO_ROOT)/tao/ServicesC.h \ $(TAO_ROOT)/tao/ServicesC.i \ $(TAO_ROOT)/tao/CORBA_String.h \ $(TAO_ROOT)/tao/CORBA_String.inl \ $(TAO_ROOT)/tao/ObjectIdListC.h \ $(TAO_ROOT)/tao/ObjectIdListC.i \ $(TAO_ROOT)/tao/objectid.h \ $(TAO_ROOT)/tao/PolicyC.h \ $(TAO_ROOT)/tao/CurrentC.h \ $(TAO_ROOT)/tao/CurrentC.i \ $(TAO_ROOT)/tao/Remote_Object_Proxy_Impl.h \ $(TAO_ROOT)/tao/Object_Proxy_Impl.h \ $(TAO_ROOT)/tao/PolicyC.i \ $(TAO_ROOT)/tao/ORB.i \ $(TAO_ROOT)/tao/BoundsC.h \ $(TAO_ROOT)/tao/BoundsC.i \ $(TAO_ROOT)/tao/DomainC.h \ $(TAO_ROOT)/tao/DomainC.i \ $(TAO_ROOT)/tao/WrongTransactionC.h \ $(TAO_ROOT)/tao/WrongTransactionC.i \ $(TAO_ROOT)/tao/Array_VarOut_T.h \ $(TAO_ROOT)/tao/Array_VarOut_T.inl \ $(TAO_ROOT)/tao/Array_VarOut_T.cpp \ $(TAO_ROOT)/tao/StringSeqC.h \ $(TAO_ROOT)/tao/StringSeqC.i \ $(TAO_ROOT)/tao/PortableInterceptorC.h \ $(TAO_ROOT)/tao/PI_ForwardC.h \ $(TAO_ROOT)/tao/PI_ForwardC.i \ $(TAO_ROOT)/tao/DynamicC.h \ $(TAO_ROOT)/tao/DynamicC.i \ $(TAO_ROOT)/tao/Messaging_SyncScopeC.h \ $(TAO_ROOT)/tao/Messaging_SyncScopeC.i \ $(TAO_ROOT)/tao/IOPC.h \ $(TAO_ROOT)/tao/IOP_CodecC.h \ $(TAO_ROOT)/tao/IOP_CodecC.i \ $(TAO_ROOT)/tao/IOPC.i \ $(TAO_ROOT)/tao/PortableInterceptorC.i \ printC.i \ $(ACE_ROOT)/ace/Get_Opt.h \ $(ACE_ROOT)/ace/Containers.h \ $(ACE_ROOT)/ace/Containers.i \ $(ACE_ROOT)/ace/Containers_T.h \ $(ACE_ROOT)/ace/Array_Base.h \ $(ACE_ROOT)/ace/Array_Base.inl \ $(ACE_ROOT)/ace/Array_Base.cpp \ $(ACE_ROOT)/ace/Containers_T.i \ $(ACE_ROOT)/ace/Containers_T.cpp \ $(ACE_ROOT)/ace/Get_Opt.i .obj/listener.o .obj/listener.so .shobj/listener.o .shobj/listener.so: listener.cpp Printer.h \ $(ACE_ROOT)/ace/pre.h \ printS.h printC.h \ $(TAO_ROOT)/tao/corba.h \ $(ACE_ROOT)/ace/post.h \ $(ACE_ROOT)/ace/ace_wchar.h \ $(ACE_ROOT)/ace/ace_wchar.inl \ $(TAO_ROOT)/tao/corbafwd.h \ $(ACE_ROOT)/ace/CDR_Base.h \ $(ACE_ROOT)/ace/Basic_Types.h \ $(ACE_ROOT)/ace/ACE_export.h \ $(ACE_ROOT)/ace/Basic_Types.i \ $(ACE_ROOT)/ace/Default_Constants.h \ $(ACE_ROOT)/ace/CDR_Base.inl \ $(TAO_ROOT)/tao/orbconf.h \ $(ACE_ROOT)/ace/Global_Macros.h \ $(ACE_ROOT)/ace/OS_Export.h \ $(TAO_ROOT)/tao/TAO_Export.h \ $(ACE_ROOT)/ace/OS_Memory.h \ $(ACE_ROOT)/ace/OS_Errno.h \ $(ACE_ROOT)/ace/OS_Errno.inl \ $(ACE_ROOT)/ace/OS_Memory.inl \ $(TAO_ROOT)/tao/corbafwd.i \ $(TAO_ROOT)/tao/Typecode.h \ $(ACE_ROOT)/ace/Hash_Map_Manager_T.h \ $(ACE_ROOT)/ace/Functor.h \ $(ACE_ROOT)/ace/ACE.h \ $(ACE_ROOT)/ace/OS.h \ $(ACE_ROOT)/ace/OS_Dirent.h \ $(ACE_ROOT)/ace/OS_Dirent.inl \ $(ACE_ROOT)/ace/OS_String.h \ $(ACE_ROOT)/ace/OS_String.inl \ $(ACE_ROOT)/ace/OS_TLI.h \ $(ACE_ROOT)/ace/OS_TLI.inl \ $(ACE_ROOT)/ace/Time_Value.h \ $(ACE_ROOT)/ace/Time_Value.inl \ $(ACE_ROOT)/ace/Min_Max.h \ $(ACE_ROOT)/ace/streams.h \ $(ACE_ROOT)/ace/Trace.h \ $(ACE_ROOT)/ace/OS.i \ $(ACE_ROOT)/ace/Flag_Manip.h \ $(ACE_ROOT)/ace/Flag_Manip.i \ $(ACE_ROOT)/ace/Handle_Ops.h \ $(ACE_ROOT)/ace/Handle_Ops.i \ $(ACE_ROOT)/ace/Lib_Find.h \ $(ACE_ROOT)/ace/Lib_Find.i \ $(ACE_ROOT)/ace/Init_ACE.h \ $(ACE_ROOT)/ace/Init_ACE.i \ $(ACE_ROOT)/ace/Sock_Connect.h \ $(ACE_ROOT)/ace/Sock_Connect.i \ $(ACE_ROOT)/ace/ACE.i \ $(ACE_ROOT)/ace/Functor.i \ $(ACE_ROOT)/ace/Functor_T.h \ $(ACE_ROOT)/ace/Functor_T.i \ $(ACE_ROOT)/ace/Functor_T.cpp \ $(ACE_ROOT)/ace/Log_Msg.h \ $(ACE_ROOT)/ace/Log_Priority.h \ $(ACE_ROOT)/ace/OS_Log_Msg_Attributes.h \ $(ACE_ROOT)/ace/OS_Log_Msg_Attributes.inl \ $(ACE_ROOT)/ace/Hash_Map_Manager_T.i \ $(ACE_ROOT)/ace/Synch.h \ $(ACE_ROOT)/ace/Synch.i \ $(ACE_ROOT)/ace/Synch_T.h \ $(ACE_ROOT)/ace/Synch_T.i \ $(ACE_ROOT)/ace/Thread.h \ $(ACE_ROOT)/ace/Thread_Adapter.h \ $(ACE_ROOT)/ace/Base_Thread_Adapter.h \ $(ACE_ROOT)/ace/Base_Thread_Adapter.inl \ $(ACE_ROOT)/ace/Thread_Adapter.inl \ $(ACE_ROOT)/ace/Thread.i \ $(ACE_ROOT)/ace/Synch_T.cpp \ $(ACE_ROOT)/ace/Hash_Map_Manager_T.cpp \ $(ACE_ROOT)/ace/Service_Config.h \ $(ACE_ROOT)/ace/Unbounded_Queue.h \ $(ACE_ROOT)/ace/Node.h \ $(ACE_ROOT)/ace/Node.cpp \ $(ACE_ROOT)/ace/Unbounded_Queue.inl \ $(ACE_ROOT)/ace/Unbounded_Queue.cpp \ $(ACE_ROOT)/ace/Malloc_Base.h \ $(ACE_ROOT)/ace/Unbounded_Set.h \ $(ACE_ROOT)/ace/Unbounded_Set.inl \ $(ACE_ROOT)/ace/Unbounded_Set.cpp \ $(ACE_ROOT)/ace/SString.h \ $(ACE_ROOT)/ace/SStringfwd.h \ $(ACE_ROOT)/ace/String_Base.h \ $(ACE_ROOT)/ace/String_Base_Const.h \ $(ACE_ROOT)/ace/String_Base.i \ $(ACE_ROOT)/ace/String_Base.cpp \ $(ACE_ROOT)/ace/Malloc.h \ $(ACE_ROOT)/ace/Malloc.i \ $(ACE_ROOT)/ace/Malloc_T.h \ $(ACE_ROOT)/ace/Malloc_Allocator.h \ $(ACE_ROOT)/ace/Malloc_Allocator.i \ $(ACE_ROOT)/ace/Free_List.h \ $(ACE_ROOT)/ace/Free_List.i \ $(ACE_ROOT)/ace/Free_List.cpp \ $(ACE_ROOT)/ace/Malloc_T.i \ $(ACE_ROOT)/ace/Malloc_T.cpp \ $(ACE_ROOT)/ace/Memory_Pool.h \ $(ACE_ROOT)/ace/Event_Handler.h \ $(ACE_ROOT)/ace/Event_Handler.i \ $(ACE_ROOT)/ace/Signal.h \ $(ACE_ROOT)/ace/Signal.i \ $(ACE_ROOT)/ace/Mem_Map.h \ $(ACE_ROOT)/ace/Mem_Map.i \ $(ACE_ROOT)/ace/SV_Semaphore_Complex.h \ $(ACE_ROOT)/ace/SV_Semaphore_Simple.h \ $(ACE_ROOT)/ace/SV_Semaphore_Simple.i \ $(ACE_ROOT)/ace/SV_Semaphore_Complex.i \ $(ACE_ROOT)/ace/Memory_Pool.i \ $(ACE_ROOT)/ace/Auto_Ptr.h \ $(ACE_ROOT)/ace/Auto_Ptr.i \ $(ACE_ROOT)/ace/Auto_Ptr.cpp \ $(ACE_ROOT)/ace/SString.i \ $(ACE_ROOT)/ace/XML_Svc_Conf.h \ $(ACE_ROOT)/ace/Service_Config.i \ $(ACE_ROOT)/ace/Reactor.h \ $(ACE_ROOT)/ace/Handle_Set.h \ $(ACE_ROOT)/ace/Handle_Set.i \ $(ACE_ROOT)/ace/Timer_Queue.h \ $(ACE_ROOT)/ace/Timer_Queue_T.h \ $(ACE_ROOT)/ace/Test_and_Set.h \ $(ACE_ROOT)/ace/Test_and_Set.i \ $(ACE_ROOT)/ace/Test_and_Set.cpp \ $(ACE_ROOT)/ace/Timer_Queue_T.i \ $(ACE_ROOT)/ace/Timer_Queue_T.cpp \ $(ACE_ROOT)/ace/Reactor.i \ $(ACE_ROOT)/ace/Reactor_Impl.h \ $(ACE_ROOT)/ace/Svc_Conf_Tokens.h \ $(TAO_ROOT)/tao/Exception.h \ $(ACE_ROOT)/ace/CORBA_macros.h \ $(ACE_ROOT)/ace/Exception_Macros.h \ $(ACE_ROOT)/ace/iosfwd.h \ $(TAO_ROOT)/tao/Exception.i \ $(TAO_ROOT)/tao/Pseudo_VarOut_T.h \ $(TAO_ROOT)/tao/Pseudo_VarOut_T.inl \ $(TAO_ROOT)/tao/Pseudo_VarOut_T.cpp \ $(TAO_ROOT)/tao/Typecode.i \ $(TAO_ROOT)/tao/Any_Impl_T.h \ $(TAO_ROOT)/tao/Any.h \ $(ACE_ROOT)/ace/CDR_Stream.h \ $(ACE_ROOT)/ace/Message_Block.h \ $(ACE_ROOT)/ace/Message_Block.i \ $(ACE_ROOT)/ace/Message_Block_T.h \ $(ACE_ROOT)/ace/Message_Block_T.i \ $(ACE_ROOT)/ace/Message_Block_T.cpp \ $(ACE_ROOT)/ace/CDR_Stream.i \ $(TAO_ROOT)/tao/Object.h \ $(TAO_ROOT)/tao/Policy_ForwardC.h \ $(TAO_ROOT)/tao/Sequence.h \ $(TAO_ROOT)/tao/Managed_Types.h \ $(TAO_ROOT)/tao/Managed_Types.i \ $(TAO_ROOT)/tao/Sequence.i \ $(TAO_ROOT)/tao/Sequence_T.h \ $(TAO_ROOT)/tao/Sequence_T.i \ $(TAO_ROOT)/tao/Sequence_T.cpp \ $(TAO_ROOT)/tao/Environment.h \ $(TAO_ROOT)/tao/Environment.i \ $(TAO_ROOT)/tao/CDR.h \ $(TAO_ROOT)/tao/CDR.i \ $(TAO_ROOT)/tao/Objref_VarOut_T.h \ $(TAO_ROOT)/tao/varbase.h \ $(TAO_ROOT)/tao/Objref_VarOut_T.inl \ $(TAO_ROOT)/tao/Objref_VarOut_T.cpp \ $(TAO_ROOT)/tao/Seq_Var_T.h \ $(TAO_ROOT)/tao/Seq_Var_T.inl \ $(TAO_ROOT)/tao/Seq_Var_T.cpp \ $(TAO_ROOT)/tao/Seq_Out_T.h \ $(TAO_ROOT)/tao/Seq_Out_T.inl \ $(TAO_ROOT)/tao/Seq_Out_T.cpp \ $(TAO_ROOT)/tao/Policy_ForwardC.i \ $(TAO_ROOT)/tao/Object_KeyC.h \ $(TAO_ROOT)/tao/Object_KeyC.i \ $(TAO_ROOT)/tao/IOP_IORC.h \ $(TAO_ROOT)/tao/OctetSeqC.h \ $(TAO_ROOT)/tao/OctetSeqC.i \ $(TAO_ROOT)/tao/VarOut_T.h \ $(TAO_ROOT)/tao/VarOut_T.inl \ $(TAO_ROOT)/tao/VarOut_T.cpp \ $(TAO_ROOT)/tao/IOP_IORC.i \ $(TAO_ROOT)/tao/Object.i \ $(TAO_ROOT)/tao/Any.i \ $(TAO_ROOT)/tao/Any_Impl_T.inl \ $(TAO_ROOT)/tao/Any_Impl_T.cpp \ $(TAO_ROOT)/tao/Marshal.h \ $(TAO_ROOT)/tao/Marshal.i \ $(TAO_ROOT)/tao/debug.h \ $(TAO_ROOT)/tao/Any_Basic_Impl_T.h \ $(TAO_ROOT)/tao/Any_Basic_Impl_T.inl \ $(TAO_ROOT)/tao/Any_Basic_Impl_T.cpp \ $(TAO_ROOT)/tao/Any_Special_Impl_T.h \ $(TAO_ROOT)/tao/Any_Special_Impl_T.inl \ $(TAO_ROOT)/tao/Any_Special_Impl_T.cpp \ $(TAO_ROOT)/tao/Any_Special_Basic_Impl_T.h \ $(TAO_ROOT)/tao/Any_Special_Basic_Impl_T.inl \ $(TAO_ROOT)/tao/Any_Special_Basic_Impl_T.cpp \ $(TAO_ROOT)/tao/Any_Array_Impl_T.h \ $(TAO_ROOT)/tao/Any_Array_Impl_T.inl \ $(TAO_ROOT)/tao/Any_Array_Impl_T.cpp \ $(TAO_ROOT)/tao/Any_Dual_Impl_T.h \ $(TAO_ROOT)/tao/Any_Dual_Impl_T.inl \ $(TAO_ROOT)/tao/Any_Dual_Impl_T.cpp \ $(TAO_ROOT)/tao/NVList.h \ $(TAO_ROOT)/tao/NVList.i \ $(TAO_ROOT)/tao/LocalObject.h \ $(TAO_ROOT)/tao/LocalObject.i \ $(TAO_ROOT)/tao/Principal.h \ $(TAO_ROOT)/tao/Principal.i \ $(TAO_ROOT)/tao/ORB.h \ $(TAO_ROOT)/tao/ServicesC.h \ $(TAO_ROOT)/tao/ServicesC.i \ $(TAO_ROOT)/tao/CORBA_String.h \ $(TAO_ROOT)/tao/CORBA_String.inl \ $(TAO_ROOT)/tao/ObjectIdListC.h \ $(TAO_ROOT)/tao/ObjectIdListC.i \ $(TAO_ROOT)/tao/objectid.h \ $(TAO_ROOT)/tao/PolicyC.h \ $(TAO_ROOT)/tao/CurrentC.h \ $(TAO_ROOT)/tao/CurrentC.i \ $(TAO_ROOT)/tao/Remote_Object_Proxy_Impl.h \ $(TAO_ROOT)/tao/Object_Proxy_Impl.h \ $(TAO_ROOT)/tao/PolicyC.i \ $(TAO_ROOT)/tao/ORB.i \ $(TAO_ROOT)/tao/BoundsC.h \ $(TAO_ROOT)/tao/BoundsC.i \ $(TAO_ROOT)/tao/DomainC.h \ $(TAO_ROOT)/tao/DomainC.i \ $(TAO_ROOT)/tao/WrongTransactionC.h \ $(TAO_ROOT)/tao/WrongTransactionC.i \ $(TAO_ROOT)/tao/Array_VarOut_T.h \ $(TAO_ROOT)/tao/Array_VarOut_T.inl \ $(TAO_ROOT)/tao/Array_VarOut_T.cpp \ $(TAO_ROOT)/tao/StringSeqC.h \ $(TAO_ROOT)/tao/StringSeqC.i \ $(TAO_ROOT)/tao/PortableInterceptorC.h \ $(TAO_ROOT)/tao/PI_ForwardC.h \ $(TAO_ROOT)/tao/PI_ForwardC.i \ $(TAO_ROOT)/tao/DynamicC.h \ $(TAO_ROOT)/tao/DynamicC.i \ $(TAO_ROOT)/tao/Messaging_SyncScopeC.h \ $(TAO_ROOT)/tao/Messaging_SyncScopeC.i \ $(TAO_ROOT)/tao/IOPC.h \ $(TAO_ROOT)/tao/IOP_CodecC.h \ $(TAO_ROOT)/tao/IOP_CodecC.i \ $(TAO_ROOT)/tao/IOPC.i \ $(TAO_ROOT)/tao/PortableInterceptorC.i \ printC.i \ $(TAO_ROOT)/tao/PortableServer/PortableServer.h \ $(TAO_ROOT)/tao/PortableServer/portableserver_export.h \ $(TAO_ROOT)/tao/PortableServer/PortableServerC.h \ $(TAO_ROOT)/tao/PortableServer/PortableServerC.i \ $(TAO_ROOT)/tao/PortableServer/Servant_Base.h \ $(TAO_ROOT)/tao/Abstract_Servant_Base.h \ $(ACE_ROOT)/ace/Atomic_Op.h \ $(ACE_ROOT)/ace/Atomic_Op_T.h \ $(ACE_ROOT)/ace/Atomic_Op_T.i \ $(ACE_ROOT)/ace/Atomic_Op_T.cpp \ $(ACE_ROOT)/ace/Atomic_Op.i \ $(TAO_ROOT)/tao/PortableServer/Servant_Base.i \ $(TAO_ROOT)/tao/PortableServer/Collocated_Object.h \ $(TAO_ROOT)/tao/PortableServer/Collocated_Object.i \ $(TAO_ROOT)/tao/PortableServer/ThruPOA_Object_Proxy_Impl.h \ $(TAO_ROOT)/tao/PortableServer/Direct_Object_Proxy_Impl.h \ printS_T.h printS_T.i printS_T.cpp printS.i \ $(ACE_ROOT)/ace/Get_Opt.h \ $(ACE_ROOT)/ace/Containers.h \ $(ACE_ROOT)/ace/Containers.i \ $(ACE_ROOT)/ace/Containers_T.h \ $(ACE_ROOT)/ace/Array_Base.h \ $(ACE_ROOT)/ace/Array_Base.inl \ $(ACE_ROOT)/ace/Array_Base.cpp \ $(ACE_ROOT)/ace/Containers_T.i \ $(ACE_ROOT)/ace/Containers_T.cpp \ $(ACE_ROOT)/ace/Get_Opt.i .obj/Printer.o .obj/Printer.so .shobj/Printer.o .shobj/Printer.so: Printer.cpp Printer.h \ $(ACE_ROOT)/ace/pre.h \ printS.h printC.h \ $(TAO_ROOT)/tao/corba.h \ $(ACE_ROOT)/ace/post.h \ $(ACE_ROOT)/ace/ace_wchar.h \ $(ACE_ROOT)/ace/ace_wchar.inl \ $(TAO_ROOT)/tao/corbafwd.h \ $(ACE_ROOT)/ace/CDR_Base.h \ $(ACE_ROOT)/ace/Basic_Types.h \ $(ACE_ROOT)/ace/ACE_export.h \ $(ACE_ROOT)/ace/Basic_Types.i \ $(ACE_ROOT)/ace/Default_Constants.h \ $(ACE_ROOT)/ace/CDR_Base.inl \ $(TAO_ROOT)/tao/orbconf.h \ $(ACE_ROOT)/ace/Global_Macros.h \ $(ACE_ROOT)/ace/OS_Export.h \ $(TAO_ROOT)/tao/TAO_Export.h \ $(ACE_ROOT)/ace/OS_Memory.h \ $(ACE_ROOT)/ace/OS_Errno.h \ $(ACE_ROOT)/ace/OS_Errno.inl \ $(ACE_ROOT)/ace/OS_Memory.inl \ $(TAO_ROOT)/tao/corbafwd.i \ $(TAO_ROOT)/tao/Typecode.h \ $(ACE_ROOT)/ace/Hash_Map_Manager_T.h \ $(ACE_ROOT)/ace/Functor.h \ $(ACE_ROOT)/ace/ACE.h \ $(ACE_ROOT)/ace/OS.h \ $(ACE_ROOT)/ace/OS_Dirent.h \ $(ACE_ROOT)/ace/OS_Dirent.inl \ $(ACE_ROOT)/ace/OS_String.h \ $(ACE_ROOT)/ace/OS_String.inl \ $(ACE_ROOT)/ace/OS_TLI.h \ $(ACE_ROOT)/ace/OS_TLI.inl \ $(ACE_ROOT)/ace/Time_Value.h \ $(ACE_ROOT)/ace/Time_Value.inl \ $(ACE_ROOT)/ace/Min_Max.h \ $(ACE_ROOT)/ace/streams.h \ $(ACE_ROOT)/ace/Trace.h \ $(ACE_ROOT)/ace/OS.i \ $(ACE_ROOT)/ace/Flag_Manip.h \ $(ACE_ROOT)/ace/Flag_Manip.i \ $(ACE_ROOT)/ace/Handle_Ops.h \ $(ACE_ROOT)/ace/Handle_Ops.i \ $(ACE_ROOT)/ace/Lib_Find.h \ $(ACE_ROOT)/ace/Lib_Find.i \ $(ACE_ROOT)/ace/Init_ACE.h \ $(ACE_ROOT)/ace/Init_ACE.i \ $(ACE_ROOT)/ace/Sock_Connect.h \ $(ACE_ROOT)/ace/Sock_Connect.i \ $(ACE_ROOT)/ace/ACE.i \ $(ACE_ROOT)/ace/Functor.i \ $(ACE_ROOT)/ace/Functor_T.h \ $(ACE_ROOT)/ace/Functor_T.i \ $(ACE_ROOT)/ace/Functor_T.cpp \ $(ACE_ROOT)/ace/Log_Msg.h \ $(ACE_ROOT)/ace/Log_Priority.h \ $(ACE_ROOT)/ace/OS_Log_Msg_Attributes.h \ $(ACE_ROOT)/ace/OS_Log_Msg_Attributes.inl \ $(ACE_ROOT)/ace/Hash_Map_Manager_T.i \ $(ACE_ROOT)/ace/Synch.h \ $(ACE_ROOT)/ace/Synch.i \ $(ACE_ROOT)/ace/Synch_T.h \ $(ACE_ROOT)/ace/Synch_T.i \ $(ACE_ROOT)/ace/Thread.h \ $(ACE_ROOT)/ace/Thread_Adapter.h \ $(ACE_ROOT)/ace/Base_Thread_Adapter.h \ $(ACE_ROOT)/ace/Base_Thread_Adapter.inl \ $(ACE_ROOT)/ace/Thread_Adapter.inl \ $(ACE_ROOT)/ace/Thread.i \ $(ACE_ROOT)/ace/Synch_T.cpp \ $(ACE_ROOT)/ace/Hash_Map_Manager_T.cpp \ $(ACE_ROOT)/ace/Service_Config.h \ $(ACE_ROOT)/ace/Unbounded_Queue.h \ $(ACE_ROOT)/ace/Node.h \ $(ACE_ROOT)/ace/Node.cpp \ $(ACE_ROOT)/ace/Unbounded_Queue.inl \ $(ACE_ROOT)/ace/Unbounded_Queue.cpp \ $(ACE_ROOT)/ace/Malloc_Base.h \ $(ACE_ROOT)/ace/Unbounded_Set.h \ $(ACE_ROOT)/ace/Unbounded_Set.inl \ $(ACE_ROOT)/ace/Unbounded_Set.cpp \ $(ACE_ROOT)/ace/SString.h \ $(ACE_ROOT)/ace/SStringfwd.h \ $(ACE_ROOT)/ace/String_Base.h \ $(ACE_ROOT)/ace/String_Base_Const.h \ $(ACE_ROOT)/ace/String_Base.i \ $(ACE_ROOT)/ace/String_Base.cpp \ $(ACE_ROOT)/ace/Malloc.h \ $(ACE_ROOT)/ace/Malloc.i \ $(ACE_ROOT)/ace/Malloc_T.h \ $(ACE_ROOT)/ace/Malloc_Allocator.h \ $(ACE_ROOT)/ace/Malloc_Allocator.i \ $(ACE_ROOT)/ace/Free_List.h \ $(ACE_ROOT)/ace/Free_List.i \ $(ACE_ROOT)/ace/Free_List.cpp \ $(ACE_ROOT)/ace/Malloc_T.i \ $(ACE_ROOT)/ace/Malloc_T.cpp \ $(ACE_ROOT)/ace/Memory_Pool.h \ $(ACE_ROOT)/ace/Event_Handler.h \ $(ACE_ROOT)/ace/Event_Handler.i \ $(ACE_ROOT)/ace/Signal.h \ $(ACE_ROOT)/ace/Signal.i \ $(ACE_ROOT)/ace/Mem_Map.h \ $(ACE_ROOT)/ace/Mem_Map.i \ $(ACE_ROOT)/ace/SV_Semaphore_Complex.h \ $(ACE_ROOT)/ace/SV_Semaphore_Simple.h \ $(ACE_ROOT)/ace/SV_Semaphore_Simple.i \ $(ACE_ROOT)/ace/SV_Semaphore_Complex.i \ $(ACE_ROOT)/ace/Memory_Pool.i \ $(ACE_ROOT)/ace/Auto_Ptr.h \ $(ACE_ROOT)/ace/Auto_Ptr.i \ $(ACE_ROOT)/ace/Auto_Ptr.cpp \ $(ACE_ROOT)/ace/SString.i \ $(ACE_ROOT)/ace/XML_Svc_Conf.h \ $(ACE_ROOT)/ace/Service_Config.i \ $(ACE_ROOT)/ace/Reactor.h \ $(ACE_ROOT)/ace/Handle_Set.h \ $(ACE_ROOT)/ace/Handle_Set.i \ $(ACE_ROOT)/ace/Timer_Queue.h \ $(ACE_ROOT)/ace/Timer_Queue_T.h \ $(ACE_ROOT)/ace/Test_and_Set.h \ $(ACE_ROOT)/ace/Test_and_Set.i \ $(ACE_ROOT)/ace/Test_and_Set.cpp \ $(ACE_ROOT)/ace/Timer_Queue_T.i \ $(ACE_ROOT)/ace/Timer_Queue_T.cpp \ $(ACE_ROOT)/ace/Reactor.i \ $(ACE_ROOT)/ace/Reactor_Impl.h \ $(ACE_ROOT)/ace/Svc_Conf_Tokens.h \ $(TAO_ROOT)/tao/Exception.h \ $(ACE_ROOT)/ace/CORBA_macros.h \ $(ACE_ROOT)/ace/Exception_Macros.h \ $(ACE_ROOT)/ace/iosfwd.h \ $(TAO_ROOT)/tao/Exception.i \ $(TAO_ROOT)/tao/Pseudo_VarOut_T.h \ $(TAO_ROOT)/tao/Pseudo_VarOut_T.inl \ $(TAO_ROOT)/tao/Pseudo_VarOut_T.cpp \ $(TAO_ROOT)/tao/Typecode.i \ $(TAO_ROOT)/tao/Any_Impl_T.h \ $(TAO_ROOT)/tao/Any.h \ $(ACE_ROOT)/ace/CDR_Stream.h \ $(ACE_ROOT)/ace/Message_Block.h \ $(ACE_ROOT)/ace/Message_Block.i \ $(ACE_ROOT)/ace/Message_Block_T.h \ $(ACE_ROOT)/ace/Message_Block_T.i \ $(ACE_ROOT)/ace/Message_Block_T.cpp \ $(ACE_ROOT)/ace/CDR_Stream.i \ $(TAO_ROOT)/tao/Object.h \ $(TAO_ROOT)/tao/Policy_ForwardC.h \ $(TAO_ROOT)/tao/Sequence.h \ $(TAO_ROOT)/tao/Managed_Types.h \ $(TAO_ROOT)/tao/Managed_Types.i \ $(TAO_ROOT)/tao/Sequence.i \ $(TAO_ROOT)/tao/Sequence_T.h \ $(TAO_ROOT)/tao/Sequence_T.i \ $(TAO_ROOT)/tao/Sequence_T.cpp \ $(TAO_ROOT)/tao/Environment.h \ $(TAO_ROOT)/tao/Environment.i \ $(TAO_ROOT)/tao/CDR.h \ $(TAO_ROOT)/tao/CDR.i \ $(TAO_ROOT)/tao/Objref_VarOut_T.h \ $(TAO_ROOT)/tao/varbase.h \ $(TAO_ROOT)/tao/Objref_VarOut_T.inl \ $(TAO_ROOT)/tao/Objref_VarOut_T.cpp \ $(TAO_ROOT)/tao/Seq_Var_T.h \ $(TAO_ROOT)/tao/Seq_Var_T.inl \ $(TAO_ROOT)/tao/Seq_Var_T.cpp \ $(TAO_ROOT)/tao/Seq_Out_T.h \ $(TAO_ROOT)/tao/Seq_Out_T.inl \ $(TAO_ROOT)/tao/Seq_Out_T.cpp \ $(TAO_ROOT)/tao/Policy_ForwardC.i \ $(TAO_ROOT)/tao/Object_KeyC.h \ $(TAO_ROOT)/tao/Object_KeyC.i \ $(TAO_ROOT)/tao/IOP_IORC.h \ $(TAO_ROOT)/tao/OctetSeqC.h \ $(TAO_ROOT)/tao/OctetSeqC.i \ $(TAO_ROOT)/tao/VarOut_T.h \ $(TAO_ROOT)/tao/VarOut_T.inl \ $(TAO_ROOT)/tao/VarOut_T.cpp \ $(TAO_ROOT)/tao/IOP_IORC.i \ $(TAO_ROOT)/tao/Object.i \ $(TAO_ROOT)/tao/Any.i \ $(TAO_ROOT)/tao/Any_Impl_T.inl \ $(TAO_ROOT)/tao/Any_Impl_T.cpp \ $(TAO_ROOT)/tao/Marshal.h \ $(TAO_ROOT)/tao/Marshal.i \ $(TAO_ROOT)/tao/debug.h \ $(TAO_ROOT)/tao/Any_Basic_Impl_T.h \ $(TAO_ROOT)/tao/Any_Basic_Impl_T.inl \ $(TAO_ROOT)/tao/Any_Basic_Impl_T.cpp \ $(TAO_ROOT)/tao/Any_Special_Impl_T.h \ $(TAO_ROOT)/tao/Any_Special_Impl_T.inl \ $(TAO_ROOT)/tao/Any_Special_Impl_T.cpp \ $(TAO_ROOT)/tao/Any_Special_Basic_Impl_T.h \ $(TAO_ROOT)/tao/Any_Special_Basic_Impl_T.inl \ $(TAO_ROOT)/tao/Any_Special_Basic_Impl_T.cpp \ $(TAO_ROOT)/tao/Any_Array_Impl_T.h \ $(TAO_ROOT)/tao/Any_Array_Impl_T.inl \ $(TAO_ROOT)/tao/Any_Array_Impl_T.cpp \ $(TAO_ROOT)/tao/Any_Dual_Impl_T.h \ $(TAO_ROOT)/tao/Any_Dual_Impl_T.inl \ $(TAO_ROOT)/tao/Any_Dual_Impl_T.cpp \ $(TAO_ROOT)/tao/NVList.h \ $(TAO_ROOT)/tao/NVList.i \ $(TAO_ROOT)/tao/LocalObject.h \ $(TAO_ROOT)/tao/LocalObject.i \ $(TAO_ROOT)/tao/Principal.h \ $(TAO_ROOT)/tao/Principal.i \ $(TAO_ROOT)/tao/ORB.h \ $(TAO_ROOT)/tao/ServicesC.h \ $(TAO_ROOT)/tao/ServicesC.i \ $(TAO_ROOT)/tao/CORBA_String.h \ $(TAO_ROOT)/tao/CORBA_String.inl \ $(TAO_ROOT)/tao/ObjectIdListC.h \ $(TAO_ROOT)/tao/ObjectIdListC.i \ $(TAO_ROOT)/tao/objectid.h \ $(TAO_ROOT)/tao/PolicyC.h \ $(TAO_ROOT)/tao/CurrentC.h \ $(TAO_ROOT)/tao/CurrentC.i \ $(TAO_ROOT)/tao/Remote_Object_Proxy_Impl.h \ $(TAO_ROOT)/tao/Object_Proxy_Impl.h \ $(TAO_ROOT)/tao/PolicyC.i \ $(TAO_ROOT)/tao/ORB.i \ $(TAO_ROOT)/tao/BoundsC.h \ $(TAO_ROOT)/tao/BoundsC.i \ $(TAO_ROOT)/tao/DomainC.h \ $(TAO_ROOT)/tao/DomainC.i \ $(TAO_ROOT)/tao/WrongTransactionC.h \ $(TAO_ROOT)/tao/WrongTransactionC.i \ $(TAO_ROOT)/tao/Array_VarOut_T.h \ $(TAO_ROOT)/tao/Array_VarOut_T.inl \ $(TAO_ROOT)/tao/Array_VarOut_T.cpp \ $(TAO_ROOT)/tao/StringSeqC.h \ $(TAO_ROOT)/tao/StringSeqC.i \ $(TAO_ROOT)/tao/PortableInterceptorC.h \ $(TAO_ROOT)/tao/PI_ForwardC.h \ $(TAO_ROOT)/tao/PI_ForwardC.i \ $(TAO_ROOT)/tao/DynamicC.h \ $(TAO_ROOT)/tao/DynamicC.i \ $(TAO_ROOT)/tao/Messaging_SyncScopeC.h \ $(TAO_ROOT)/tao/Messaging_SyncScopeC.i \ $(TAO_ROOT)/tao/IOPC.h \ $(TAO_ROOT)/tao/IOP_CodecC.h \ $(TAO_ROOT)/tao/IOP_CodecC.i \ $(TAO_ROOT)/tao/IOPC.i \ $(TAO_ROOT)/tao/PortableInterceptorC.i \ printC.i \ $(TAO_ROOT)/tao/PortableServer/PortableServer.h \ $(TAO_ROOT)/tao/PortableServer/portableserver_export.h \ $(TAO_ROOT)/tao/PortableServer/PortableServerC.h \ $(TAO_ROOT)/tao/PortableServer/PortableServerC.i \ $(TAO_ROOT)/tao/PortableServer/Servant_Base.h \ $(TAO_ROOT)/tao/Abstract_Servant_Base.h \ $(ACE_ROOT)/ace/Atomic_Op.h \ $(ACE_ROOT)/ace/Atomic_Op_T.h \ $(ACE_ROOT)/ace/Atomic_Op_T.i \ $(ACE_ROOT)/ace/Atomic_Op_T.cpp \ $(ACE_ROOT)/ace/Atomic_Op.i \ $(TAO_ROOT)/tao/PortableServer/Servant_Base.i \ $(TAO_ROOT)/tao/PortableServer/Collocated_Object.h \ $(TAO_ROOT)/tao/PortableServer/Collocated_Object.i \ $(TAO_ROOT)/tao/PortableServer/ThruPOA_Object_Proxy_Impl.h \ $(TAO_ROOT)/tao/PortableServer/Direct_Object_Proxy_Impl.h \ printS_T.h printS_T.i printS_T.cpp printS.i .obj/printC.o .obj/printC.so .shobj/printC.o .shobj/printC.so: printC.cpp printC.h \ $(TAO_ROOT)/tao/corba.h \ $(ACE_ROOT)/ace/pre.h \ $(ACE_ROOT)/ace/post.h \ $(ACE_ROOT)/ace/ace_wchar.h \ $(ACE_ROOT)/ace/ace_wchar.inl \ $(TAO_ROOT)/tao/corbafwd.h \ $(ACE_ROOT)/ace/CDR_Base.h \ $(ACE_ROOT)/ace/Basic_Types.h \ $(ACE_ROOT)/ace/ACE_export.h \ $(ACE_ROOT)/ace/Basic_Types.i \ $(ACE_ROOT)/ace/Default_Constants.h \ $(ACE_ROOT)/ace/CDR_Base.inl \ $(TAO_ROOT)/tao/orbconf.h \ $(ACE_ROOT)/ace/Global_Macros.h \ $(ACE_ROOT)/ace/OS_Export.h \ $(TAO_ROOT)/tao/TAO_Export.h \ $(ACE_ROOT)/ace/OS_Memory.h \ $(ACE_ROOT)/ace/OS_Errno.h \ $(ACE_ROOT)/ace/OS_Errno.inl \ $(ACE_ROOT)/ace/OS_Memory.inl \ $(TAO_ROOT)/tao/corbafwd.i \ $(TAO_ROOT)/tao/Typecode.h \ $(ACE_ROOT)/ace/Hash_Map_Manager_T.h \ $(ACE_ROOT)/ace/Functor.h \ $(ACE_ROOT)/ace/ACE.h \ $(ACE_ROOT)/ace/OS.h \ $(ACE_ROOT)/ace/OS_Dirent.h \ $(ACE_ROOT)/ace/OS_Dirent.inl \ $(ACE_ROOT)/ace/OS_String.h \ $(ACE_ROOT)/ace/OS_String.inl \ $(ACE_ROOT)/ace/OS_TLI.h \ $(ACE_ROOT)/ace/OS_TLI.inl \ $(ACE_ROOT)/ace/Time_Value.h \ $(ACE_ROOT)/ace/Time_Value.inl \ $(ACE_ROOT)/ace/Min_Max.h \ $(ACE_ROOT)/ace/streams.h \ $(ACE_ROOT)/ace/Trace.h \ $(ACE_ROOT)/ace/OS.i \ $(ACE_ROOT)/ace/Flag_Manip.h \ $(ACE_ROOT)/ace/Flag_Manip.i \ $(ACE_ROOT)/ace/Handle_Ops.h \ $(ACE_ROOT)/ace/Handle_Ops.i \ $(ACE_ROOT)/ace/Lib_Find.h \ $(ACE_ROOT)/ace/Lib_Find.i \ $(ACE_ROOT)/ace/Init_ACE.h \ $(ACE_ROOT)/ace/Init_ACE.i \ $(ACE_ROOT)/ace/Sock_Connect.h \ $(ACE_ROOT)/ace/Sock_Connect.i \ $(ACE_ROOT)/ace/ACE.i \ $(ACE_ROOT)/ace/Functor.i \ $(ACE_ROOT)/ace/Functor_T.h \ $(ACE_ROOT)/ace/Functor_T.i \ $(ACE_ROOT)/ace/Functor_T.cpp \ $(ACE_ROOT)/ace/Log_Msg.h \ $(ACE_ROOT)/ace/Log_Priority.h \ $(ACE_ROOT)/ace/OS_Log_Msg_Attributes.h \ $(ACE_ROOT)/ace/OS_Log_Msg_Attributes.inl \ $(ACE_ROOT)/ace/Hash_Map_Manager_T.i \ $(ACE_ROOT)/ace/Synch.h \ $(ACE_ROOT)/ace/Synch.i \ $(ACE_ROOT)/ace/Synch_T.h \ $(ACE_ROOT)/ace/Synch_T.i \ $(ACE_ROOT)/ace/Thread.h \ $(ACE_ROOT)/ace/Thread_Adapter.h \ $(ACE_ROOT)/ace/Base_Thread_Adapter.h \ $(ACE_ROOT)/ace/Base_Thread_Adapter.inl \ $(ACE_ROOT)/ace/Thread_Adapter.inl \ $(ACE_ROOT)/ace/Thread.i \ $(ACE_ROOT)/ace/Synch_T.cpp \ $(ACE_ROOT)/ace/Hash_Map_Manager_T.cpp \ $(ACE_ROOT)/ace/Service_Config.h \ $(ACE_ROOT)/ace/Unbounded_Queue.h \ $(ACE_ROOT)/ace/Node.h \ $(ACE_ROOT)/ace/Node.cpp \ $(ACE_ROOT)/ace/Unbounded_Queue.inl \ $(ACE_ROOT)/ace/Unbounded_Queue.cpp \ $(ACE_ROOT)/ace/Malloc_Base.h \ $(ACE_ROOT)/ace/Unbounded_Set.h \ $(ACE_ROOT)/ace/Unbounded_Set.inl \ $(ACE_ROOT)/ace/Unbounded_Set.cpp \ $(ACE_ROOT)/ace/SString.h \ $(ACE_ROOT)/ace/SStringfwd.h \ $(ACE_ROOT)/ace/String_Base.h \ $(ACE_ROOT)/ace/String_Base_Const.h \ $(ACE_ROOT)/ace/String_Base.i \ $(ACE_ROOT)/ace/String_Base.cpp \ $(ACE_ROOT)/ace/Malloc.h \ $(ACE_ROOT)/ace/Malloc.i \ $(ACE_ROOT)/ace/Malloc_T.h \ $(ACE_ROOT)/ace/Malloc_Allocator.h \ $(ACE_ROOT)/ace/Malloc_Allocator.i \ $(ACE_ROOT)/ace/Free_List.h \ $(ACE_ROOT)/ace/Free_List.i \ $(ACE_ROOT)/ace/Free_List.cpp \ $(ACE_ROOT)/ace/Malloc_T.i \ $(ACE_ROOT)/ace/Malloc_T.cpp \ $(ACE_ROOT)/ace/Memory_Pool.h \ $(ACE_ROOT)/ace/Event_Handler.h \ $(ACE_ROOT)/ace/Event_Handler.i \ $(ACE_ROOT)/ace/Signal.h \ $(ACE_ROOT)/ace/Signal.i \ $(ACE_ROOT)/ace/Mem_Map.h \ $(ACE_ROOT)/ace/Mem_Map.i \ $(ACE_ROOT)/ace/SV_Semaphore_Complex.h \ $(ACE_ROOT)/ace/SV_Semaphore_Simple.h \ $(ACE_ROOT)/ace/SV_Semaphore_Simple.i \ $(ACE_ROOT)/ace/SV_Semaphore_Complex.i \ $(ACE_ROOT)/ace/Memory_Pool.i \ $(ACE_ROOT)/ace/Auto_Ptr.h \ $(ACE_ROOT)/ace/Auto_Ptr.i \ $(ACE_ROOT)/ace/Auto_Ptr.cpp \ $(ACE_ROOT)/ace/SString.i \ $(ACE_ROOT)/ace/XML_Svc_Conf.h \ $(ACE_ROOT)/ace/Service_Config.i \ $(ACE_ROOT)/ace/Reactor.h \ $(ACE_ROOT)/ace/Handle_Set.h \ $(ACE_ROOT)/ace/Handle_Set.i \ $(ACE_ROOT)/ace/Timer_Queue.h \ $(ACE_ROOT)/ace/Timer_Queue_T.h \ $(ACE_ROOT)/ace/Test_and_Set.h \ $(ACE_ROOT)/ace/Test_and_Set.i \ $(ACE_ROOT)/ace/Test_and_Set.cpp \ $(ACE_ROOT)/ace/Timer_Queue_T.i \ $(ACE_ROOT)/ace/Timer_Queue_T.cpp \ $(ACE_ROOT)/ace/Reactor.i \ $(ACE_ROOT)/ace/Reactor_Impl.h \ $(ACE_ROOT)/ace/Svc_Conf_Tokens.h \ $(TAO_ROOT)/tao/Exception.h \ $(ACE_ROOT)/ace/CORBA_macros.h \ $(ACE_ROOT)/ace/Exception_Macros.h \ $(ACE_ROOT)/ace/iosfwd.h \ $(TAO_ROOT)/tao/Exception.i \ $(TAO_ROOT)/tao/Pseudo_VarOut_T.h \ $(TAO_ROOT)/tao/Pseudo_VarOut_T.inl \ $(TAO_ROOT)/tao/Pseudo_VarOut_T.cpp \ $(TAO_ROOT)/tao/Typecode.i \ $(TAO_ROOT)/tao/Any_Impl_T.h \ $(TAO_ROOT)/tao/Any.h \ $(ACE_ROOT)/ace/CDR_Stream.h \ $(ACE_ROOT)/ace/Message_Block.h \ $(ACE_ROOT)/ace/Message_Block.i \ $(ACE_ROOT)/ace/Message_Block_T.h \ $(ACE_ROOT)/ace/Message_Block_T.i \ $(ACE_ROOT)/ace/Message_Block_T.cpp \ $(ACE_ROOT)/ace/CDR_Stream.i \ $(TAO_ROOT)/tao/Object.h \ $(TAO_ROOT)/tao/Policy_ForwardC.h \ $(TAO_ROOT)/tao/Sequence.h \ $(TAO_ROOT)/tao/Managed_Types.h \ $(TAO_ROOT)/tao/Managed_Types.i \ $(TAO_ROOT)/tao/Sequence.i \ $(TAO_ROOT)/tao/Sequence_T.h \ $(TAO_ROOT)/tao/Sequence_T.i \ $(TAO_ROOT)/tao/Sequence_T.cpp \ $(TAO_ROOT)/tao/Environment.h \ $(TAO_ROOT)/tao/Environment.i \ $(TAO_ROOT)/tao/CDR.h \ $(TAO_ROOT)/tao/CDR.i \ $(TAO_ROOT)/tao/Objref_VarOut_T.h \ $(TAO_ROOT)/tao/varbase.h \ $(TAO_ROOT)/tao/Objref_VarOut_T.inl \ $(TAO_ROOT)/tao/Objref_VarOut_T.cpp \ $(TAO_ROOT)/tao/Seq_Var_T.h \ $(TAO_ROOT)/tao/Seq_Var_T.inl \ $(TAO_ROOT)/tao/Seq_Var_T.cpp \ $(TAO_ROOT)/tao/Seq_Out_T.h \ $(TAO_ROOT)/tao/Seq_Out_T.inl \ $(TAO_ROOT)/tao/Seq_Out_T.cpp \ $(TAO_ROOT)/tao/Policy_ForwardC.i \ $(TAO_ROOT)/tao/Object_KeyC.h \ $(TAO_ROOT)/tao/Object_KeyC.i \ $(TAO_ROOT)/tao/IOP_IORC.h \ $(TAO_ROOT)/tao/OctetSeqC.h \ $(TAO_ROOT)/tao/OctetSeqC.i \ $(TAO_ROOT)/tao/VarOut_T.h \ $(TAO_ROOT)/tao/VarOut_T.inl \ $(TAO_ROOT)/tao/VarOut_T.cpp \ $(TAO_ROOT)/tao/IOP_IORC.i \ $(TAO_ROOT)/tao/Object.i \ $(TAO_ROOT)/tao/Any.i \ $(TAO_ROOT)/tao/Any_Impl_T.inl \ $(TAO_ROOT)/tao/Any_Impl_T.cpp \ $(TAO_ROOT)/tao/Marshal.h \ $(TAO_ROOT)/tao/Marshal.i \ $(TAO_ROOT)/tao/debug.h \ $(TAO_ROOT)/tao/Any_Basic_Impl_T.h \ $(TAO_ROOT)/tao/Any_Basic_Impl_T.inl \ $(TAO_ROOT)/tao/Any_Basic_Impl_T.cpp \ $(TAO_ROOT)/tao/Any_Special_Impl_T.h \ $(TAO_ROOT)/tao/Any_Special_Impl_T.inl \ $(TAO_ROOT)/tao/Any_Special_Impl_T.cpp \ $(TAO_ROOT)/tao/Any_Special_Basic_Impl_T.h \ $(TAO_ROOT)/tao/Any_Special_Basic_Impl_T.inl \ $(TAO_ROOT)/tao/Any_Special_Basic_Impl_T.cpp \ $(TAO_ROOT)/tao/Any_Array_Impl_T.h \ $(TAO_ROOT)/tao/Any_Array_Impl_T.inl \ $(TAO_ROOT)/tao/Any_Array_Impl_T.cpp \ $(TAO_ROOT)/tao/Any_Dual_Impl_T.h \ $(TAO_ROOT)/tao/Any_Dual_Impl_T.inl \ $(TAO_ROOT)/tao/Any_Dual_Impl_T.cpp \ $(TAO_ROOT)/tao/NVList.h \ $(TAO_ROOT)/tao/NVList.i \ $(TAO_ROOT)/tao/LocalObject.h \ $(TAO_ROOT)/tao/LocalObject.i \ $(TAO_ROOT)/tao/Principal.h \ $(TAO_ROOT)/tao/Principal.i \ $(TAO_ROOT)/tao/ORB.h \ $(TAO_ROOT)/tao/ServicesC.h \ $(TAO_ROOT)/tao/ServicesC.i \ $(TAO_ROOT)/tao/CORBA_String.h \ $(TAO_ROOT)/tao/CORBA_String.inl \ $(TAO_ROOT)/tao/ObjectIdListC.h \ $(TAO_ROOT)/tao/ObjectIdListC.i \ $(TAO_ROOT)/tao/objectid.h \ $(TAO_ROOT)/tao/PolicyC.h \ $(TAO_ROOT)/tao/CurrentC.h \ $(TAO_ROOT)/tao/CurrentC.i \ $(TAO_ROOT)/tao/Remote_Object_Proxy_Impl.h \ $(TAO_ROOT)/tao/Object_Proxy_Impl.h \ $(TAO_ROOT)/tao/PolicyC.i \ $(TAO_ROOT)/tao/ORB.i \ $(TAO_ROOT)/tao/BoundsC.h \ $(TAO_ROOT)/tao/BoundsC.i \ $(TAO_ROOT)/tao/DomainC.h \ $(TAO_ROOT)/tao/DomainC.i \ $(TAO_ROOT)/tao/WrongTransactionC.h \ $(TAO_ROOT)/tao/WrongTransactionC.i \ $(TAO_ROOT)/tao/Array_VarOut_T.h \ $(TAO_ROOT)/tao/Array_VarOut_T.inl \ $(TAO_ROOT)/tao/Array_VarOut_T.cpp \ $(TAO_ROOT)/tao/StringSeqC.h \ $(TAO_ROOT)/tao/StringSeqC.i \ $(TAO_ROOT)/tao/PortableInterceptorC.h \ $(TAO_ROOT)/tao/PI_ForwardC.h \ $(TAO_ROOT)/tao/PI_ForwardC.i \ $(TAO_ROOT)/tao/DynamicC.h \ $(TAO_ROOT)/tao/DynamicC.i \ $(TAO_ROOT)/tao/Messaging_SyncScopeC.h \ $(TAO_ROOT)/tao/Messaging_SyncScopeC.i \ $(TAO_ROOT)/tao/IOPC.h \ $(TAO_ROOT)/tao/IOP_CodecC.h \ $(TAO_ROOT)/tao/IOP_CodecC.i \ $(TAO_ROOT)/tao/IOPC.i \ $(TAO_ROOT)/tao/PortableInterceptorC.i \ printC.i \ $(TAO_ROOT)/tao/Stub.h \ $(TAO_ROOT)/tao/MProfile.h \ $(TAO_ROOT)/tao/MProfile.i \ $(TAO_ROOT)/tao/ORB_Core.h \ $(TAO_ROOT)/tao/Policy_Manager.h \ $(TAO_ROOT)/tao/Policy_Set.h \ $(TAO_ROOT)/tao/Policy_Set.i \ $(TAO_ROOT)/tao/Policy_Manager.i \ $(TAO_ROOT)/tao/Resource_Factory.h \ $(ACE_ROOT)/ace/Service_Object.h \ $(ACE_ROOT)/ace/Shared_Object.h \ $(ACE_ROOT)/ace/Shared_Object.i \ $(ACE_ROOT)/ace/DLL.h \ $(ACE_ROOT)/ace/Service_Object.i \ $(TAO_ROOT)/tao/CONV_FRAMEC.h \ $(TAO_ROOT)/tao/CONV_FRAMEC.i \ $(TAO_ROOT)/tao/params.h \ $(TAO_ROOT)/tao/params.i \ $(TAO_ROOT)/tao/TAO_Singleton_Manager.h \ $(TAO_ROOT)/tao/TAO_Singleton_Manager.inl \ $(TAO_ROOT)/tao/TAO_Singleton.h \ $(TAO_ROOT)/tao/TAO_Singleton.inl \ $(TAO_ROOT)/tao/TAO_Singleton.cpp \ $(ACE_ROOT)/ace/Object_Manager.h \ $(ACE_ROOT)/ace/Object_Manager.i \ $(ACE_ROOT)/ace/Managed_Object.h \ $(ACE_ROOT)/ace/Managed_Object.i \ $(ACE_ROOT)/ace/Managed_Object.cpp \ $(TAO_ROOT)/tao/Adapter.h \ $(TAO_ROOT)/tao/Adapter.i \ $(TAO_ROOT)/tao/PolicyFactory_Registry.h \ $(ACE_ROOT)/ace/Map_Manager.h \ $(ACE_ROOT)/ace/Map_Manager.i \ $(ACE_ROOT)/ace/Map_Manager.cpp \ $(TAO_ROOT)/tao/Parser_Registry.h \ $(TAO_ROOT)/tao/Parser_Registry.i \ $(TAO_ROOT)/tao/Service_Callbacks.h \ $(TAO_ROOT)/tao/Service_Callbacks.i \ $(TAO_ROOT)/tao/Fault_Tolerance_Service.h \ $(TAO_ROOT)/tao/Fault_Tolerance_Service.i \ $(TAO_ROOT)/tao/Cleanup_Func_Registry.h \ $(ACE_ROOT)/ace/Array_Base.h \ $(ACE_ROOT)/ace/Array_Base.inl \ $(ACE_ROOT)/ace/Array_Base.cpp \ $(TAO_ROOT)/tao/Cleanup_Func_Registry.inl \ $(TAO_ROOT)/tao/Object_Ref_Table.h \ $(TAO_ROOT)/tao/Interceptor_List.h \ $(TAO_ROOT)/tao/Interceptor_List.inl \ $(TAO_ROOT)/tao/PICurrent.h \ $(TAO_ROOT)/tao/PICurrent.inl \ $(ACE_ROOT)/ace/Thread_Manager.h \ $(ACE_ROOT)/ace/Thread_Exit.h \ $(ACE_ROOT)/ace/Thread_Control.h \ $(ACE_ROOT)/ace/Thread_Control.inl \ $(ACE_ROOT)/ace/Containers.h \ $(ACE_ROOT)/ace/Containers.i \ $(ACE_ROOT)/ace/Containers_T.h \ $(ACE_ROOT)/ace/Containers_T.i \ $(ACE_ROOT)/ace/Containers_T.cpp \ $(ACE_ROOT)/ace/Singleton.h \ $(ACE_ROOT)/ace/Singleton.i \ $(ACE_ROOT)/ace/Singleton.cpp \ $(ACE_ROOT)/ace/Framework_Component.h \ $(ACE_ROOT)/ace/Framework_Component.inl \ $(ACE_ROOT)/ace/Framework_Component_T.h \ $(ACE_ROOT)/ace/Framework_Component_T.inl \ $(ACE_ROOT)/ace/Framework_Component_T.cpp \ $(ACE_ROOT)/ace/Thread_Manager.i \ $(TAO_ROOT)/tao/ORB_Core.i \ $(TAO_ROOT)/tao/ORB_Core_Auto_Ptr.h \ $(TAO_ROOT)/tao/ORB_Core_Auto_Ptr.inl \ $(TAO_ROOT)/tao/Stub.i \ $(TAO_ROOT)/tao/Invocation.h \ $(TAO_ROOT)/tao/Synch_Reply_Dispatcher.h \ $(TAO_ROOT)/tao/Reply_Dispatcher.h \ $(TAO_ROOT)/tao/Reply_Dispatcher.i \ $(TAO_ROOT)/tao/LF_Invocation_Event.h \ $(TAO_ROOT)/tao/LF_Event.h \ $(TAO_ROOT)/tao/LF_Event.inl \ $(TAO_ROOT)/tao/LF_Invocation_Event.inl \ $(TAO_ROOT)/tao/GIOP_Message_Version.h \ $(TAO_ROOT)/tao/GIOP_Message_Version.inl \ $(TAO_ROOT)/tao/operation_details.h \ $(TAO_ROOT)/tao/Service_Context.h \ $(TAO_ROOT)/tao/Service_Context.inl \ $(TAO_ROOT)/tao/target_specification.h \ $(TAO_ROOT)/tao/target_specification.i \ $(TAO_ROOT)/tao/operation_details.i \ $(TAO_ROOT)/tao/Transport.h \ $(TAO_ROOT)/tao/Transport_Descriptor_Interface.h \ $(TAO_ROOT)/tao/Transport_Descriptor_Interface.inl \ $(TAO_ROOT)/tao/Transport_Cache_Manager.h \ $(TAO_ROOT)/tao/Cache_Entries.h \ $(ACE_ROOT)/ace/Recyclable.h \ $(ACE_ROOT)/ace/Recyclable.inl \ $(TAO_ROOT)/tao/Cache_Entries.inl \ $(TAO_ROOT)/tao/Transport_Cache_Manager.inl \ $(TAO_ROOT)/tao/Transport_Timer.h \ $(TAO_ROOT)/tao/Incoming_Message_Queue.h \ $(TAO_ROOT)/tao/Pluggable_Messaging_Utils.h \ $(TAO_ROOT)/tao/Pluggable_Messaging_Utils.i \ $(TAO_ROOT)/tao/Incoming_Message_Queue.inl \ $(TAO_ROOT)/tao/Synch_Refcountable.h \ $(ACE_ROOT)/ace/Refcountable.h \ $(ACE_ROOT)/ace/Refcountable.inl \ $(TAO_ROOT)/tao/Synch_Refcountable.inl \ $(TAO_ROOT)/tao/Transport.inl \ $(TAO_ROOT)/tao/Invocation.i \ $(TAO_ROOT)/tao/PortableInterceptor.h \ $(TAO_ROOT)/tao/RequestInfo_Util.h \ $(TAO_ROOT)/tao/ClientRequestInfo_i.h \ $(TAO_ROOT)/tao/ClientRequestInfo_i.inl \ $(TAO_ROOT)/tao/ClientInterceptorAdapter.h \ $(TAO_ROOT)/tao/ClientInterceptorAdapter.inl .obj/printS.o .obj/printS.so .shobj/printS.o .shobj/printS.so: printS.cpp printS.h printC.h \ $(TAO_ROOT)/tao/corba.h \ $(ACE_ROOT)/ace/pre.h \ $(ACE_ROOT)/ace/post.h \ $(ACE_ROOT)/ace/ace_wchar.h \ $(ACE_ROOT)/ace/ace_wchar.inl \ $(TAO_ROOT)/tao/corbafwd.h \ $(ACE_ROOT)/ace/CDR_Base.h \ $(ACE_ROOT)/ace/Basic_Types.h \ $(ACE_ROOT)/ace/ACE_export.h \ $(ACE_ROOT)/ace/Basic_Types.i \ $(ACE_ROOT)/ace/Default_Constants.h \ $(ACE_ROOT)/ace/CDR_Base.inl \ $(TAO_ROOT)/tao/orbconf.h \ $(ACE_ROOT)/ace/Global_Macros.h \ $(ACE_ROOT)/ace/OS_Export.h \ $(TAO_ROOT)/tao/TAO_Export.h \ $(ACE_ROOT)/ace/OS_Memory.h \ $(ACE_ROOT)/ace/OS_Errno.h \ $(ACE_ROOT)/ace/OS_Errno.inl \ $(ACE_ROOT)/ace/OS_Memory.inl \ $(TAO_ROOT)/tao/corbafwd.i \ $(TAO_ROOT)/tao/Typecode.h \ $(ACE_ROOT)/ace/Hash_Map_Manager_T.h \ $(ACE_ROOT)/ace/Functor.h \ $(ACE_ROOT)/ace/ACE.h \ $(ACE_ROOT)/ace/OS.h \ $(ACE_ROOT)/ace/OS_Dirent.h \ $(ACE_ROOT)/ace/OS_Dirent.inl \ $(ACE_ROOT)/ace/OS_String.h \ $(ACE_ROOT)/ace/OS_String.inl \ $(ACE_ROOT)/ace/OS_TLI.h \ $(ACE_ROOT)/ace/OS_TLI.inl \ $(ACE_ROOT)/ace/Time_Value.h \ $(ACE_ROOT)/ace/Time_Value.inl \ $(ACE_ROOT)/ace/Min_Max.h \ $(ACE_ROOT)/ace/streams.h \ $(ACE_ROOT)/ace/Trace.h \ $(ACE_ROOT)/ace/OS.i \ $(ACE_ROOT)/ace/Flag_Manip.h \ $(ACE_ROOT)/ace/Flag_Manip.i \ $(ACE_ROOT)/ace/Handle_Ops.h \ $(ACE_ROOT)/ace/Handle_Ops.i \ $(ACE_ROOT)/ace/Lib_Find.h \ $(ACE_ROOT)/ace/Lib_Find.i \ $(ACE_ROOT)/ace/Init_ACE.h \ $(ACE_ROOT)/ace/Init_ACE.i \ $(ACE_ROOT)/ace/Sock_Connect.h \ $(ACE_ROOT)/ace/Sock_Connect.i \ $(ACE_ROOT)/ace/ACE.i \ $(ACE_ROOT)/ace/Functor.i \ $(ACE_ROOT)/ace/Functor_T.h \ $(ACE_ROOT)/ace/Functor_T.i \ $(ACE_ROOT)/ace/Functor_T.cpp \ $(ACE_ROOT)/ace/Log_Msg.h \ $(ACE_ROOT)/ace/Log_Priority.h \ $(ACE_ROOT)/ace/OS_Log_Msg_Attributes.h \ $(ACE_ROOT)/ace/OS_Log_Msg_Attributes.inl \ $(ACE_ROOT)/ace/Hash_Map_Manager_T.i \ $(ACE_ROOT)/ace/Synch.h \ $(ACE_ROOT)/ace/Synch.i \ $(ACE_ROOT)/ace/Synch_T.h \ $(ACE_ROOT)/ace/Synch_T.i \ $(ACE_ROOT)/ace/Thread.h \ $(ACE_ROOT)/ace/Thread_Adapter.h \ $(ACE_ROOT)/ace/Base_Thread_Adapter.h \ $(ACE_ROOT)/ace/Base_Thread_Adapter.inl \ $(ACE_ROOT)/ace/Thread_Adapter.inl \ $(ACE_ROOT)/ace/Thread.i \ $(ACE_ROOT)/ace/Synch_T.cpp \ $(ACE_ROOT)/ace/Hash_Map_Manager_T.cpp \ $(ACE_ROOT)/ace/Service_Config.h \ $(ACE_ROOT)/ace/Unbounded_Queue.h \ $(ACE_ROOT)/ace/Node.h \ $(ACE_ROOT)/ace/Node.cpp \ $(ACE_ROOT)/ace/Unbounded_Queue.inl \ $(ACE_ROOT)/ace/Unbounded_Queue.cpp \ $(ACE_ROOT)/ace/Malloc_Base.h \ $(ACE_ROOT)/ace/Unbounded_Set.h \ $(ACE_ROOT)/ace/Unbounded_Set.inl \ $(ACE_ROOT)/ace/Unbounded_Set.cpp \ $(ACE_ROOT)/ace/SString.h \ $(ACE_ROOT)/ace/SStringfwd.h \ $(ACE_ROOT)/ace/String_Base.h \ $(ACE_ROOT)/ace/String_Base_Const.h \ $(ACE_ROOT)/ace/String_Base.i \ $(ACE_ROOT)/ace/String_Base.cpp \ $(ACE_ROOT)/ace/Malloc.h \ $(ACE_ROOT)/ace/Malloc.i \ $(ACE_ROOT)/ace/Malloc_T.h \ $(ACE_ROOT)/ace/Malloc_Allocator.h \ $(ACE_ROOT)/ace/Malloc_Allocator.i \ $(ACE_ROOT)/ace/Free_List.h \ $(ACE_ROOT)/ace/Free_List.i \ $(ACE_ROOT)/ace/Free_List.cpp \ $(ACE_ROOT)/ace/Malloc_T.i \ $(ACE_ROOT)/ace/Malloc_T.cpp \ $(ACE_ROOT)/ace/Memory_Pool.h \ $(ACE_ROOT)/ace/Event_Handler.h \ $(ACE_ROOT)/ace/Event_Handler.i \ $(ACE_ROOT)/ace/Signal.h \ $(ACE_ROOT)/ace/Signal.i \ $(ACE_ROOT)/ace/Mem_Map.h \ $(ACE_ROOT)/ace/Mem_Map.i \ $(ACE_ROOT)/ace/SV_Semaphore_Complex.h \ $(ACE_ROOT)/ace/SV_Semaphore_Simple.h \ $(ACE_ROOT)/ace/SV_Semaphore_Simple.i \ $(ACE_ROOT)/ace/SV_Semaphore_Complex.i \ $(ACE_ROOT)/ace/Memory_Pool.i \ $(ACE_ROOT)/ace/Auto_Ptr.h \ $(ACE_ROOT)/ace/Auto_Ptr.i \ $(ACE_ROOT)/ace/Auto_Ptr.cpp \ $(ACE_ROOT)/ace/SString.i \ $(ACE_ROOT)/ace/XML_Svc_Conf.h \ $(ACE_ROOT)/ace/Service_Config.i \ $(ACE_ROOT)/ace/Reactor.h \ $(ACE_ROOT)/ace/Handle_Set.h \ $(ACE_ROOT)/ace/Handle_Set.i \ $(ACE_ROOT)/ace/Timer_Queue.h \ $(ACE_ROOT)/ace/Timer_Queue_T.h \ $(ACE_ROOT)/ace/Test_and_Set.h \ $(ACE_ROOT)/ace/Test_and_Set.i \ $(ACE_ROOT)/ace/Test_and_Set.cpp \ $(ACE_ROOT)/ace/Timer_Queue_T.i \ $(ACE_ROOT)/ace/Timer_Queue_T.cpp \ $(ACE_ROOT)/ace/Reactor.i \ $(ACE_ROOT)/ace/Reactor_Impl.h \ $(ACE_ROOT)/ace/Svc_Conf_Tokens.h \ $(TAO_ROOT)/tao/Exception.h \ $(ACE_ROOT)/ace/CORBA_macros.h \ $(ACE_ROOT)/ace/Exception_Macros.h \ $(ACE_ROOT)/ace/iosfwd.h \ $(TAO_ROOT)/tao/Exception.i \ $(TAO_ROOT)/tao/Pseudo_VarOut_T.h \ $(TAO_ROOT)/tao/Pseudo_VarOut_T.inl \ $(TAO_ROOT)/tao/Pseudo_VarOut_T.cpp \ $(TAO_ROOT)/tao/Typecode.i \ $(TAO_ROOT)/tao/Any_Impl_T.h \ $(TAO_ROOT)/tao/Any.h \ $(ACE_ROOT)/ace/CDR_Stream.h \ $(ACE_ROOT)/ace/Message_Block.h \ $(ACE_ROOT)/ace/Message_Block.i \ $(ACE_ROOT)/ace/Message_Block_T.h \ $(ACE_ROOT)/ace/Message_Block_T.i \ $(ACE_ROOT)/ace/Message_Block_T.cpp \ $(ACE_ROOT)/ace/CDR_Stream.i \ $(TAO_ROOT)/tao/Object.h \ $(TAO_ROOT)/tao/Policy_ForwardC.h \ $(TAO_ROOT)/tao/Sequence.h \ $(TAO_ROOT)/tao/Managed_Types.h \ $(TAO_ROOT)/tao/Managed_Types.i \ $(TAO_ROOT)/tao/Sequence.i \ $(TAO_ROOT)/tao/Sequence_T.h \ $(TAO_ROOT)/tao/Sequence_T.i \ $(TAO_ROOT)/tao/Sequence_T.cpp \ $(TAO_ROOT)/tao/Environment.h \ $(TAO_ROOT)/tao/Environment.i \ $(TAO_ROOT)/tao/CDR.h \ $(TAO_ROOT)/tao/CDR.i \ $(TAO_ROOT)/tao/Objref_VarOut_T.h \ $(TAO_ROOT)/tao/varbase.h \ $(TAO_ROOT)/tao/Objref_VarOut_T.inl \ $(TAO_ROOT)/tao/Objref_VarOut_T.cpp \ $(TAO_ROOT)/tao/Seq_Var_T.h \ $(TAO_ROOT)/tao/Seq_Var_T.inl \ $(TAO_ROOT)/tao/Seq_Var_T.cpp \ $(TAO_ROOT)/tao/Seq_Out_T.h \ $(TAO_ROOT)/tao/Seq_Out_T.inl \ $(TAO_ROOT)/tao/Seq_Out_T.cpp \ $(TAO_ROOT)/tao/Policy_ForwardC.i \ $(TAO_ROOT)/tao/Object_KeyC.h \ $(TAO_ROOT)/tao/Object_KeyC.i \ $(TAO_ROOT)/tao/IOP_IORC.h \ $(TAO_ROOT)/tao/OctetSeqC.h \ $(TAO_ROOT)/tao/OctetSeqC.i \ $(TAO_ROOT)/tao/VarOut_T.h \ $(TAO_ROOT)/tao/VarOut_T.inl \ $(TAO_ROOT)/tao/VarOut_T.cpp \ $(TAO_ROOT)/tao/IOP_IORC.i \ $(TAO_ROOT)/tao/Object.i \ $(TAO_ROOT)/tao/Any.i \ $(TAO_ROOT)/tao/Any_Impl_T.inl \ $(TAO_ROOT)/tao/Any_Impl_T.cpp \ $(TAO_ROOT)/tao/Marshal.h \ $(TAO_ROOT)/tao/Marshal.i \ $(TAO_ROOT)/tao/debug.h \ $(TAO_ROOT)/tao/Any_Basic_Impl_T.h \ $(TAO_ROOT)/tao/Any_Basic_Impl_T.inl \ $(TAO_ROOT)/tao/Any_Basic_Impl_T.cpp \ $(TAO_ROOT)/tao/Any_Special_Impl_T.h \ $(TAO_ROOT)/tao/Any_Special_Impl_T.inl \ $(TAO_ROOT)/tao/Any_Special_Impl_T.cpp \ $(TAO_ROOT)/tao/Any_Special_Basic_Impl_T.h \ $(TAO_ROOT)/tao/Any_Special_Basic_Impl_T.inl \ $(TAO_ROOT)/tao/Any_Special_Basic_Impl_T.cpp \ $(TAO_ROOT)/tao/Any_Array_Impl_T.h \ $(TAO_ROOT)/tao/Any_Array_Impl_T.inl \ $(TAO_ROOT)/tao/Any_Array_Impl_T.cpp \ $(TAO_ROOT)/tao/Any_Dual_Impl_T.h \ $(TAO_ROOT)/tao/Any_Dual_Impl_T.inl \ $(TAO_ROOT)/tao/Any_Dual_Impl_T.cpp \ $(TAO_ROOT)/tao/NVList.h \ $(TAO_ROOT)/tao/NVList.i \ $(TAO_ROOT)/tao/LocalObject.h \ $(TAO_ROOT)/tao/LocalObject.i \ $(TAO_ROOT)/tao/Principal.h \ $(TAO_ROOT)/tao/Principal.i \ $(TAO_ROOT)/tao/ORB.h \ $(TAO_ROOT)/tao/ServicesC.h \ $(TAO_ROOT)/tao/ServicesC.i \ $(TAO_ROOT)/tao/CORBA_String.h \ $(TAO_ROOT)/tao/CORBA_String.inl \ $(TAO_ROOT)/tao/ObjectIdListC.h \ $(TAO_ROOT)/tao/ObjectIdListC.i \ $(TAO_ROOT)/tao/objectid.h \ $(TAO_ROOT)/tao/PolicyC.h \ $(TAO_ROOT)/tao/CurrentC.h \ $(TAO_ROOT)/tao/CurrentC.i \ $(TAO_ROOT)/tao/Remote_Object_Proxy_Impl.h \ $(TAO_ROOT)/tao/Object_Proxy_Impl.h \ $(TAO_ROOT)/tao/PolicyC.i \ $(TAO_ROOT)/tao/ORB.i \ $(TAO_ROOT)/tao/BoundsC.h \ $(TAO_ROOT)/tao/BoundsC.i \ $(TAO_ROOT)/tao/DomainC.h \ $(TAO_ROOT)/tao/DomainC.i \ $(TAO_ROOT)/tao/WrongTransactionC.h \ $(TAO_ROOT)/tao/WrongTransactionC.i \ $(TAO_ROOT)/tao/Array_VarOut_T.h \ $(TAO_ROOT)/tao/Array_VarOut_T.inl \ $(TAO_ROOT)/tao/Array_VarOut_T.cpp \ $(TAO_ROOT)/tao/StringSeqC.h \ $(TAO_ROOT)/tao/StringSeqC.i \ $(TAO_ROOT)/tao/PortableInterceptorC.h \ $(TAO_ROOT)/tao/PI_ForwardC.h \ $(TAO_ROOT)/tao/PI_ForwardC.i \ $(TAO_ROOT)/tao/DynamicC.h \ $(TAO_ROOT)/tao/DynamicC.i \ $(TAO_ROOT)/tao/Messaging_SyncScopeC.h \ $(TAO_ROOT)/tao/Messaging_SyncScopeC.i \ $(TAO_ROOT)/tao/IOPC.h \ $(TAO_ROOT)/tao/IOP_CodecC.h \ $(TAO_ROOT)/tao/IOP_CodecC.i \ $(TAO_ROOT)/tao/IOPC.i \ $(TAO_ROOT)/tao/PortableInterceptorC.i \ printC.i \ $(TAO_ROOT)/tao/PortableServer/PortableServer.h \ $(TAO_ROOT)/tao/PortableServer/portableserver_export.h \ $(TAO_ROOT)/tao/PortableServer/PortableServerC.h \ $(TAO_ROOT)/tao/PortableServer/PortableServerC.i \ $(TAO_ROOT)/tao/PortableServer/Servant_Base.h \ $(TAO_ROOT)/tao/Abstract_Servant_Base.h \ $(ACE_ROOT)/ace/Atomic_Op.h \ $(ACE_ROOT)/ace/Atomic_Op_T.h \ $(ACE_ROOT)/ace/Atomic_Op_T.i \ $(ACE_ROOT)/ace/Atomic_Op_T.cpp \ $(ACE_ROOT)/ace/Atomic_Op.i \ $(TAO_ROOT)/tao/PortableServer/Servant_Base.i \ $(TAO_ROOT)/tao/PortableServer/Collocated_Object.h \ $(TAO_ROOT)/tao/PortableServer/Collocated_Object.i \ $(TAO_ROOT)/tao/PortableServer/ThruPOA_Object_Proxy_Impl.h \ $(TAO_ROOT)/tao/PortableServer/Direct_Object_Proxy_Impl.h \ printS_T.h printS_T.i printS_T.cpp printS.i \ $(TAO_ROOT)/tao/PortableServer/Object_Adapter.h \ $(TAO_ROOT)/tao/PortableServer/Key_Adapters.h \ $(ACE_ROOT)/ace/Map_T.h \ $(ACE_ROOT)/ace/Pair_T.h \ $(ACE_ROOT)/ace/Pair_T.i \ $(ACE_ROOT)/ace/Pair_T.cpp \ $(ACE_ROOT)/ace/Map_Manager.h \ $(ACE_ROOT)/ace/Map_Manager.i \ $(ACE_ROOT)/ace/Map_Manager.cpp \ $(ACE_ROOT)/ace/Active_Map_Manager.h \ $(ACE_ROOT)/ace/Active_Map_Manager.i \ $(ACE_ROOT)/ace/Active_Map_Manager_T.h \ $(ACE_ROOT)/ace/Active_Map_Manager_T.i \ $(ACE_ROOT)/ace/Active_Map_Manager_T.cpp \ $(ACE_ROOT)/ace/Map_T.i \ $(ACE_ROOT)/ace/Map_T.cpp \ $(TAO_ROOT)/tao/PortableServer/Key_Adapters.i \ $(TAO_ROOT)/tao/PortableServer/poa_macros.h \ $(TAO_ROOT)/tao/PortableServer/Active_Object_Map.h \ $(TAO_ROOT)/tao/Server_Strategy_Factory.h \ $(ACE_ROOT)/ace/Service_Object.h \ $(ACE_ROOT)/ace/Shared_Object.h \ $(ACE_ROOT)/ace/Shared_Object.i \ $(ACE_ROOT)/ace/DLL.h \ $(ACE_ROOT)/ace/Service_Object.i \ $(TAO_ROOT)/tao/PortableServer/Active_Object_Map.i \ $(TAO_ROOT)/tao/Adapter.h \ $(TAO_ROOT)/tao/Adapter.i \ $(TAO_ROOT)/tao/PortableServer/Default_Policy_Validator.h \ $(TAO_ROOT)/tao/Policy_Validator.h \ $(TAO_ROOT)/tao/PortableServer/POA_Policy_Set.h \ $(TAO_ROOT)/tao/PortableServer/POA_Policies.h \ $(TAO_ROOT)/tao/PortableServer/POA_Policies.i \ $(TAO_ROOT)/tao/Policy_Set.h \ $(TAO_ROOT)/tao/Policy_Set.i \ $(TAO_ROOT)/tao/PortableServer/POA_Policy_Set.i \ $(TAO_ROOT)/tao/PortableServer/Object_Adapter.i \ $(TAO_ROOT)/tao/PortableServer/Operation_Table.h \ $(TAO_ROOT)/tao/TAO_Singleton.h \ $(TAO_ROOT)/tao/TAO_Singleton.inl \ $(TAO_ROOT)/tao/TAO_Singleton.cpp \ $(ACE_ROOT)/ace/Object_Manager.h \ $(ACE_ROOT)/ace/Object_Manager.i \ $(ACE_ROOT)/ace/Managed_Object.h \ $(ACE_ROOT)/ace/Managed_Object.i \ $(ACE_ROOT)/ace/Managed_Object.cpp \ $(TAO_ROOT)/tao/TAO_Singleton_Manager.h \ $(TAO_ROOT)/tao/TAO_Singleton_Manager.inl \ $(ACE_ROOT)/ace/Hash_Map_Manager.h \ $(TAO_ROOT)/tao/TAO_Server_Request.h \ $(TAO_ROOT)/tao/Tagged_Profile.h \ $(TAO_ROOT)/tao/GIOPC.h \ $(TAO_ROOT)/tao/GIOPC.i \ $(TAO_ROOT)/tao/Tagged_Profile.i \ $(TAO_ROOT)/tao/Service_Context.h \ $(TAO_ROOT)/tao/Service_Context.inl \ $(TAO_ROOT)/tao/PICurrent.h \ $(ACE_ROOT)/ace/Array_Base.h \ $(ACE_ROOT)/ace/Array_Base.inl \ $(ACE_ROOT)/ace/Array_Base.cpp \ $(TAO_ROOT)/tao/PICurrent.inl \ $(TAO_ROOT)/tao/TAO_Server_Request.i \ $(TAO_ROOT)/tao/ORB_Core.h \ $(TAO_ROOT)/tao/Policy_Manager.h \ $(TAO_ROOT)/tao/Policy_Manager.i \ $(TAO_ROOT)/tao/Resource_Factory.h \ $(TAO_ROOT)/tao/CONV_FRAMEC.h \ $(TAO_ROOT)/tao/CONV_FRAMEC.i \ $(TAO_ROOT)/tao/params.h \ $(TAO_ROOT)/tao/params.i \ $(TAO_ROOT)/tao/PolicyFactory_Registry.h \ $(TAO_ROOT)/tao/Parser_Registry.h \ $(TAO_ROOT)/tao/Parser_Registry.i \ $(TAO_ROOT)/tao/Service_Callbacks.h \ $(TAO_ROOT)/tao/Service_Callbacks.i \ $(TAO_ROOT)/tao/Fault_Tolerance_Service.h \ $(TAO_ROOT)/tao/Fault_Tolerance_Service.i \ $(TAO_ROOT)/tao/Cleanup_Func_Registry.h \ $(TAO_ROOT)/tao/Cleanup_Func_Registry.inl \ $(TAO_ROOT)/tao/Object_Ref_Table.h \ $(TAO_ROOT)/tao/Interceptor_List.h \ $(TAO_ROOT)/tao/Interceptor_List.inl \ $(ACE_ROOT)/ace/Thread_Manager.h \ $(ACE_ROOT)/ace/Thread_Exit.h \ $(ACE_ROOT)/ace/Thread_Control.h \ $(ACE_ROOT)/ace/Thread_Control.inl \ $(ACE_ROOT)/ace/Containers.h \ $(ACE_ROOT)/ace/Containers.i \ $(ACE_ROOT)/ace/Containers_T.h \ $(ACE_ROOT)/ace/Containers_T.i \ $(ACE_ROOT)/ace/Containers_T.cpp \ $(ACE_ROOT)/ace/Singleton.h \ $(ACE_ROOT)/ace/Singleton.i \ $(ACE_ROOT)/ace/Singleton.cpp \ $(ACE_ROOT)/ace/Framework_Component.h \ $(ACE_ROOT)/ace/Framework_Component.inl \ $(ACE_ROOT)/ace/Framework_Component_T.h \ $(ACE_ROOT)/ace/Framework_Component_T.inl \ $(ACE_ROOT)/ace/Framework_Component_T.cpp \ $(ACE_ROOT)/ace/Thread_Manager.i \ $(TAO_ROOT)/tao/ORB_Core.i \ $(TAO_ROOT)/tao/Profile.h \ $(TAO_ROOT)/tao/Tagged_Components.h \ $(TAO_ROOT)/tao/Tagged_Components.i \ $(TAO_ROOT)/tao/GIOP_Message_Version.h \ $(TAO_ROOT)/tao/GIOP_Message_Version.inl \ $(TAO_ROOT)/tao/Profile.i \ $(TAO_ROOT)/tao/Stub.h \ $(TAO_ROOT)/tao/MProfile.h \ $(TAO_ROOT)/tao/MProfile.i \ $(TAO_ROOT)/tao/ORB_Core_Auto_Ptr.h \ $(TAO_ROOT)/tao/ORB_Core_Auto_Ptr.inl \ $(TAO_ROOT)/tao/Stub.i \ $(TAO_ROOT)/tao/IFR_Client_Adapter.h \ $(TAO_ROOT)/tao/PortableInterceptor.h \ $(TAO_ROOT)/tao/RequestInfo_Util.h \ $(TAO_ROOT)/tao/PortableServer/ServerRequestInfo.h \ $(TAO_ROOT)/tao/PortableServer/ServerRequestInfo.inl \ $(TAO_ROOT)/tao/PortableServer/ServerInterceptorAdapter.h \ $(TAO_ROOT)/tao/PortableServer/ServerInterceptorAdapter.inl \ $(ACE_ROOT)/ace/Dynamic_Service.h \ $(ACE_ROOT)/ace/Dynamic_Service_Base.h \ $(ACE_ROOT)/ace/Dynamic_Service.i \ $(ACE_ROOT)/ace/Dynamic_Service.cpp # IF YOU PUT ANYTHING HERE IT WILL GO AWAY polyorb-2.8~20110207.orig/examples/corba/send/interop/tao/send.cpp0000644000175000017500000000443311750740337024151 0ustar xavierxavier#include "printC.h" #include "ace/Get_Opt.h" ACE_RCSID(Printer, send, "send.cpp") static char* conf[] = {"", "-ORBsvcconf", "client.conf"}; static int nb_conf_param = 3; enum mode {S, L, TWS, TWL}; int main (int argc, char *argv[]) { mode curr_mode = S; conf[0] = argv[0]; ACE_TRY_NEW_ENV { CORBA::ORB_var orb = CORBA::ORB_init (nb_conf_param, conf, "" ACE_ENV_ARG_PARAMETER); ACE_TRY_CHECK; switch (argc) { case 2: break; case 3: if (strcmp(argv[2], "s") == 0) { curr_mode = S; break; } else if (strcmp(argv[2], "l") == 0) { curr_mode = L; break; } else if (strcmp(argv[2], "tws") == 0) { curr_mode = TWS; break; } else if (strcmp(argv[2], "twl") == 0) { curr_mode = TWL; break; } default: cout << "usage: " << argv[0] << " ior [s|l|tws|twl]" << "\n"; return 1; } CORBA::Object_var tmp = orb->string_to_object(argv[1] ACE_ENV_ARG_PARAMETER); ACE_TRY_CHECK; /* Do an unchecked narrow since there's no way to do an is_a on * a multicast reference (yet...). */ Test::Printer_var p = Test::Printer::_unchecked_narrow (tmp.in () ACE_ENV_ARG_PARAMETER); ACE_TRY_CHECK; if (CORBA::is_nil (p.in ())) { ACE_ERROR_RETURN ((LM_DEBUG, "Nil Test::Printer reference <%s>\n", argv[1]), 1); } switch (curr_mode) { case S: p->printString ("Hello multicast world !" ACE_ENV_ARG_PARAMETER); ACE_TRY_CHECK; break; case L: p->printLong (42 ACE_ENV_ARG_PARAMETER); ACE_TRY_CHECK; break; case TWS: { #define STR_TEST "Hello multicast world !" char* str = p->echoString (STR_TEST ACE_ENV_ARG_PARAMETER); if (strcmp (str, STR_TEST) != 0) cout << "Echo string failed" << "\n"; ACE_TRY_CHECK; break; } case TWL: { #define K 42 CORBA::Long l = p->echoLong (K ACE_ENV_ARG_PARAMETER); if (l != K) cout << "Echo long failed" << "\n"; ACE_TRY_CHECK; break; } } orb->destroy (ACE_ENV_SINGLE_ARG_PARAMETER); ACE_TRY_CHECK; } ACE_CATCHANY { ACE_PRINT_EXCEPTION (ACE_ANY_EXCEPTION, "Exception caught:"); return 1; } ACE_ENDTRY; return 0; } polyorb-2.8~20110207.orig/examples/corba/send/interop/tao/Printer.h0000644000175000017500000000234411750740337024307 0ustar xavierxavier #ifndef PRINTER_H #define PRINTER_H #include "ace/pre.h" #include "printS.h" #if defined (_MSC_VER) # if (_MSC_VER >= 1200) # pragma warning(push) # endif /* _MSC_VER >= 1200 */ # pragma warning (disable:4250) #endif /* _MSC_VER */ class Printer : public virtual POA_Test::Printer , public virtual PortableServer::RefCountServantBase { public: /// Constructor Printer (CORBA::ORB_ptr orb, int instance); // = The skeleton methods virtual void printLong (CORBA::Long K ACE_ENV_ARG_DECL) ACE_THROW_SPEC ((CORBA::SystemException)); virtual void printString (const char * Mesg ACE_ENV_ARG_DECL) ACE_THROW_SPEC ((CORBA::SystemException)); virtual CORBA::Long echoLong (CORBA::Long K ACE_ENV_ARG_DECL) ACE_THROW_SPEC ((CORBA::SystemException)); virtual char* echoString (const char * Mesg ACE_ENV_ARG_DECL) ACE_THROW_SPEC ((CORBA::SystemException)); private: /// Use an ORB reference to convert strings to objects and shutdown /// the application. CORBA::ORB_var orb_; /// The instance number. (Useful when debugging multiple servants) int instance_; }; #if defined(_MSC_VER) && (_MSC_VER >= 1200) # pragma warning(pop) #endif /* _MSC_VER */ #include "ace/post.h" #endif /* PRINTER_H */ polyorb-2.8~20110207.orig/examples/corba/send/interop/tao/Printer.cpp0000644000175000017500000000165211750740337024643 0ustar xavierxavier#include "Printer.h" ACE_RCSID(Printer, Printer, "Printer.cpp, Bertrand Paquet") Printer::Printer (CORBA::ORB_ptr orb, int instance) : orb_ (CORBA::ORB::_duplicate (orb)), instance_ (instance) {} void Printer::printLong (CORBA::Long K ACE_ENV_ARG_DECL_NOT_USED) ACE_THROW_SPEC ((CORBA::SystemException)) { cout << "Received Long : " << K << "\n"; } void Printer::printString (const char * Msg ACE_ENV_ARG_DECL_NOT_USED) ACE_THROW_SPEC ((CORBA::SystemException)) { cout << "Received String : " << Msg << "\n"; } CORBA::Long Printer::echoLong (CORBA::Long K ACE_ENV_ARG_DECL_NOT_USED) ACE_THROW_SPEC ((CORBA::SystemException)) { cout << "Echo Long : " << K << "\n"; return K; } char* Printer::echoString (const char * Msg ACE_ENV_ARG_DECL_NOT_USED) ACE_THROW_SPEC ((CORBA::SystemException)) { char * z = new char[strlen(Msg)]; cout << "Echo String : " << Msg << "\n"; strcpy (z, Msg); return z; } polyorb-2.8~20110207.orig/examples/corba/send/interop/tao/server.bor0000644000175000017500000000115111750740337024520 0ustar xavierxavier# # server.bor,v 1.2 2002/01/13 20:00:13 fhunleth Exp # NAME = server TAO_IDL = $(CORE_BINDIR)\tao_idl -g $(CORE_BINDIR)\gperf.exe -Ge 1 OBJFILES = \ $(OBJDIR)\TestC.obj \ $(OBJDIR)\TestS.obj \ $(OBJDIR)\McastHello.obj \ $(OBJDIR)\server.obj CFLAGS = \ $(ACE_CFLAGS) \ $(TAO_CFLAGS) \ $(TAO_PORTABLESERVER_CFLAGS) LIBFILES = \ $(ACE_LIB) \ $(TAO_LIB) \ $(TAO_PORTABLESERVER_LIB) IDLFILES = \ $(IDLDIR)\Test.idl CPPDIR = . IDLDIR = . !include <$(ACE_ROOT)\include\makeinclude\build_exe.bor> # # IDL Build rules # $(IDLDIR)\TestS.cpp $(IDLDIR)\TestC.cpp: $(IDLDIR)\Test.idl $(TAO_IDL) $** polyorb-2.8~20110207.orig/examples/corba/send/interop/tao/server.conf0000644000175000017500000000050011750740337024660 0ustar xavierxavierdynamic UIPMC_Factory Service_Object * TAO_PortableGroup:_make_TAO_UIPMC_Protocol_Factory() "" static Resource_Factory "-ORBProtocolFactory IIOP_Factory -ORBProtocolFactory UIPMC_Factory" #static PortableGroup_Loader "" dynamic PortableGroup_Loader Service_Object * TAO_PortableGroup:_make_TAO_PortableGroup_Loader() "" polyorb-2.8~20110207.orig/examples/corba/send/interop/tao/client.conf0000644000175000017500000000027411750740337024640 0ustar xavierxavierdynamic UIPMC_Factory Service_Object * TAO_PortableGroup:_make_TAO_UIPMC_Protocol_Factory() "" static Resource_Factory "-ORBProtocolFactory IIOP_Factory -ORBProtocolFactory UIPMC_Factory" polyorb-2.8~20110207.orig/examples/corba/send/interop/tao/client.bor0000644000175000017500000000077111750740337024477 0ustar xavierxavier# # client.bor,v 1.2 2002/01/13 20:00:13 fhunleth Exp # NAME = client TAO_IDL = $(CORE_BINDIR)\tao_idl -g $(CORE_BINDIR)\gperf.exe -Ge 1 OBJFILES = \ $(OBJDIR)\TestC.obj \ $(OBJDIR)\client.obj CFLAGS = \ $(ACE_CFLAGS) \ $(TAO_CFLAGS) LIBFILES = \ $(ACE_LIB) \ $(TAO_LIB) IDLFILES = \ $(IDLDIR)\Test.idl CPPDIR = . IDLDIR = . !include <$(ACE_ROOT)\include\makeinclude\build_exe.bor> # # IDL Build rules # $(IDLDIR)\TestS.cpp $(IDLDIR)\TestC.cpp: $(IDLDIR)\Test.idl $(TAO_IDL) $** polyorb-2.8~20110207.orig/examples/corba/send/print.idl0000644000175000017500000000052011750740337022070 0ustar xavierxaviermodule Test { interface Printer { oneway void printString (in string Mesg); oneway void printLong (in long K); string echoString (in string K); long echoLong (in long K); }; interface Controller { Printer Get_Printer (); void StopServer (); // Shut down server boolean test_OK (); }; }; polyorb-2.8~20110207.orig/examples/corba/send/Makefile.local0000644000175000017500000000013711750740337022777 0ustar xavierxavier${current_dir}print.idl-stamp: idlac_flags := -d ${test_target}: ${current_dir}print.idl-stamp polyorb-2.8~20110207.orig/examples/corba/send/test-printer-impl.adb0000644000175000017500000000766211750740337024327 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- T E S T . P R I N T E R . I M P L -- -- -- -- B o d y -- -- -- -- Copyright (C) 2002-2008, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with Ada.Text_IO; with Test.Printer.Skel; pragma Warnings (Off, Test.Printer.Skel); package body Test.Printer.Impl is Var_PrintString_Called : Natural := 0; Var_PrintLong_Called : Natural := 0; ----------------- -- PrintString -- ----------------- procedure PrintString (Self : access Object; Mesg : CORBA.String) is pragma Unreferenced (Self); begin Ada.Text_IO.Put_Line ("Printing string: «" & CORBA.To_Standard_String (Mesg) & "»"); Var_PrintString_Called := Var_PrintString_Called + 1; end PrintString; --------------- -- PrintLong -- --------------- procedure PrintLong (Self : access Object; K : CORBA.Long) is pragma Unreferenced (Self); begin Ada.Text_IO.Put_Line ("Printing Long: " & CORBA.Long'Image (K)); Var_PrintLong_Called := Var_PrintLong_Called + 1; end PrintLong; ---------------- -- EchoString -- ---------------- function EchoString (Self : access Object; Mesg : CORBA.String) return CORBA.String is pragma Unreferenced (Self); begin Ada.Text_IO.Put_Line ("Echoing : " & CORBA.To_Standard_String (Mesg)); return Mesg; end EchoString; -------------- -- EchoLong -- -------------- function EchoLong (Self : access Object; K : CORBA.Long) return CORBA.Long is pragma Unreferenced (Self); begin Ada.Text_IO.Put_Line ("Echoing : " & CORBA.Long'Image (K)); return K; end EchoLong; ------------------------ -- PrintString_Called -- ------------------------ function PrintString_Called return Natural is begin return Var_Printstring_Called; end PrintString_Called; ---------------------- -- PrintLong_Called -- ---------------------- function PrintLong_Called return Natural is begin return Var_PrintLong_Called; end PrintLong_Called; end Test.Printer.Impl; polyorb-2.8~20110207.orig/examples/corba/send/listener.adb0000644000175000017500000001361311750740337022546 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- L I S T E N E R -- -- -- -- B o d y -- -- -- -- Copyright (C) 2003-2008, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with Ada.Text_IO; with PolyORB.Setup.No_Tasking_Server; pragma Warnings (Off, PolyORB.Setup.No_Tasking_Server); -- Note: this test relies on the fact that the server is mono -- tasking, see Test.Printer.Impl for more details. with CORBA.Object; with CORBA.ORB; with CORBA.Impl; with CORBA.Policy; with PortableServer.POA.GOA; with PolyORB.CORBA_P.CORBALOC; with PolyORB.CORBA_P.Server_Tools; with Test.Controller.Impl; with Test.Printer.Impl; with Test.Printer.Helper; procedure Listener is use CORBA.ORB; use PortableServer; use PortableServer.POA.GOA; use PolyORB.CORBA_P.Server_Tools; procedure Print_List (List : IDs); -- Output each elements of List ---------------- -- Print_List -- ---------------- procedure Print_List (List : IDs) is use Sequence_IDs; begin Ada.Text_IO.Put_Line ("Group length :" & Integer'Image (Length (List))); Ada.Text_IO.Put_Line ("Objects in group :"); for J in 1 .. Length (List) loop Ada.Text_IO.Put_Line (Integer'Image (J) & " - " & PortableServer.ObjectId_To_String (Get_Element (List, J))); end loop; Ada.Text_IO.New_Line; end Print_List; Group_Id : constant Standard.String := "corbaloc:miop:1.0@1.0-TestDomain-5506/239.239.239.18:5678"; begin CORBA.ORB.Initialize ("ORB"); declare use CORBA.Impl; Ref1, Ref2, Ref3, Ref4 : CORBA.Object.Ref; Group : CORBA.Object.Ref; Policies : CORBA.Policy.PolicyList; GOA : constant PortableServer.POA.GOA.Ref := PortableServer.POA.GOA.To_Ref (PortableServer.POA.Create_POA (Get_Root_POA, CORBA.To_CORBA_String ("RootGOA"), PortableServer.POA.Get_The_POAManager (Get_Root_POA), Policies)); Obj1 : constant CORBA.Impl.Object_Ptr := new Test.Printer.Impl.Object; Obj2 : constant CORBA.Impl.Object_Ptr := new Test.Printer.Impl.Object; Obj3 : constant CORBA.Impl.Object_Ptr := new Test.Printer.Impl.Object; Oid1 : constant PortableServer.ObjectId := Servant_To_Id (GOA, PortableServer.Servant (Obj1)); Oid2 : constant PortableServer.ObjectId := Servant_To_Id (GOA, PortableServer.Servant (Obj2)); Oid3 : constant PortableServer.ObjectId := Servant_To_Id (GOA, PortableServer.Servant (Obj3)); Controller_Obj : constant CORBA.Impl.Object_Ptr := new Test.Controller.Impl.Object; begin Initiate_Servant (PortableServer.Servant (Obj1), Ref1); Initiate_Servant (PortableServer.Servant (Obj2), Ref2); Initiate_Servant (PortableServer.Servant (Obj3), Ref3); Initiate_Servant (PortableServer.Servant (Controller_Obj), Ref4); CORBA.ORB.String_To_Object (CORBA.To_CORBA_String (Group_Id), Group); Associate_Reference_With_Id (GOA, Group, Oid1); Associate_Reference_With_Id (GOA, Group, Oid2); Associate_Reference_With_Id (GOA, Group, Oid3); Print_List (Reference_To_Ids (GOA, Group)); Ada.Text_IO.Put_Line ("IOR of the test controller '" & CORBA.To_Standard_String (Object_To_String (Ref4)) & "'"); Ada.Text_IO.New_Line; Test.Controller.Impl.Set_Printer (Test.Controller.Impl.Object (Controller_Obj.all)'Access, Test.Printer.Helper.Unchecked_To_Ref (Group)); Test.Controller.Impl.Set_Group_Size (Test.Controller.Impl.Object (Controller_Obj.all)'Access, Length (Reference_To_Ids (GOA, Group))); Ada.Text_IO.Put_Line ("Group IOR: '" & CORBA.To_Standard_String (Object_To_String (Group)) & "'"); Ada.Text_IO.New_Line; Ada.Text_IO.Put_Line ("Group corbaloc: '" & CORBA.To_Standard_String (PolyORB.CORBA_P.CORBALOC.Object_To_Corbaloc (Group)) & "'"); Ada.Text_IO.New_Line; -- Launch the server Initiate_Server; end; end Listener; polyorb-2.8~20110207.orig/examples/corba/send/test-controller-impl.adb0000644000175000017500000000643211750740337025021 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- T E S T . C O N T R O L L E R . I M P L -- -- -- -- B o d y -- -- -- -- Copyright (C) 2008, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with CORBA.ORB; with Test.Controller.Skel; pragma Warnings (Off, Test.Controller.Skel); with Test.Printer.Impl; package body Test.Controller.Impl is ----------------- -- Get_Printer -- ----------------- function Get_Printer (Self : access Object) return Test.Printer.Ref is begin return Self.Printer; end Get_Printer; ----------------- -- Set_Printer -- ----------------- procedure Set_Printer (Self : access Object; Printer : Test.Printer.Ref) is begin Self.Printer := Printer; end Set_Printer; -------------------- -- Set_Group_Size -- -------------------- procedure Set_Group_Size (Self : access Object; Size : Natural) is begin Self.Group_Size := Size; end Set_Group_Size; ---------------- -- StopServer -- ---------------- procedure StopServer (Self : access Object) is pragma Unreferenced (Self); begin CORBA.ORB.Shutdown (Wait_For_Completion => False); end StopServer; ------------- -- Test_OK -- ------------- function Test_OK (Self : access Object) return CORBA.Boolean is begin return Test.Printer.Impl.PrintString_Called = Self.Group_Size and then Test.Printer.Impl.PrintLong_Called = Self.Group_Size; end Test_OK; end Test.Controller.Impl; polyorb-2.8~20110207.orig/examples/corba/send/polyorb.conf0000644000175000017500000000075411750740337022610 0ustar xavierxavier############################################################################### # PolyORB configuration file for the CORBA/MIOP example [miop] ############################################################### # MIOP Global Settings # Multicast address to use # # Note: these two parameters must be set explicitly, no default value # is provided. If either parameter is unset, the MIOP access point is # disabled. polyorb.miop.multicast_addr=239.239.239.18 polyorb.miop.multicast_port=5678 polyorb-2.8~20110207.orig/examples/corba/send/send.adb0000644000175000017500000001103311750740337021644 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- S E N D -- -- -- -- B o d y -- -- -- -- Copyright (C) 2003-2008, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with Ada.Command_Line; with Ada.Text_IO; with CORBA.ORB; with Test.Printer; with Test.Controller; with PolyORB.Setup.Client; pragma Warnings (Off, PolyORB.Setup.Client); with PolyORB.Utils.Report; procedure Send is use Ada.Command_Line; use Ada.Text_IO; use PolyORB.Utils.Report; Ok : Boolean := False; begin CORBA.ORB.Initialize ("ORB"); New_Test ("CORBA/MIOP"); -- Parse command line if Argument_Count /= 1 then Put_Line ("usage : ./send "); return; end if; declare Sent_Msg : constant Standard.String := "Hello Multicast world !"; The_Controller : Test.Controller.Ref; Printer : Test.Printer.Ref; begin CORBA.ORB.String_To_Object (CORBA.To_CORBA_String (Ada.Command_Line.Argument (1)), The_Controller); Printer := Test.Controller.Get_Printer (The_Controller); -- Check reference is correct if Test.Printer.Is_Nil (Printer) then Put_Line ("main : cannot invoke on a nil reference"); return; end if; -- Send messages Test.Printer.printString (Printer, CORBA.To_CORBA_String (Sent_Msg)); Output ("Sending CORBA.String", True); Test.Printer.printLong (Printer, CORBA.Long (1234)); Output ("Sending CORBA.Long", True); Output ("Previous tests went OK on the server side", Test.Controller.Test_OK (The_Controller)); declare Result : CORBA.String; pragma Unreferenced (Result); begin Result := Test.Printer.EchoString (Printer, CORBA.To_CORBA_String (Sent_Msg)); Output ("Calling function with return value raised an exception", False); exception when others => Output ("Calling function with return value raised an exception", True); end; begin Test.Controller.StopServer (The_Controller); Ok := True; exception when others => Ok := False; raise; end; Output ("Shut down server(s)", Ok); exception when E : CORBA.Transient => declare Memb : CORBA.System_Exception_Members; begin CORBA.Get_Members (E, Memb); Put ("received exception transient, minor"); Put (CORBA.Unsigned_Long'Image (Memb.Minor)); Put (", completion status: "); Put_Line (CORBA.Completion_Status'Image (Memb.Completed)); end; end; End_Report; end Send; polyorb-2.8~20110207.orig/examples/corba/send/test-printer-impl.ads0000644000175000017500000000525211750740337024341 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- T E S T . P R I N T E R . I M P L -- -- -- -- S p e c -- -- -- -- Copyright (C) 2002-2008, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with CORBA; with PortableServer; package Test.Printer.Impl is type Object is new PortableServer.Servant_Base with private; type Object_Acc is access Object; procedure PrintString (Self : access Object; Mesg : CORBA.String); procedure PrintLong (Self : access Object; K : CORBA.Long); function EchoString (Self : access Object; Mesg : CORBA.String) return CORBA.String; function EchoLong (Self : access Object; K : CORBA.Long) return CORBA.Long; function PrintString_Called return Natural; function PrintLong_Called return Natural; private type Object is new PortableServer.Servant_Base with null record; end Test.Printer.Impl; polyorb-2.8~20110207.orig/examples/corba/send/local.gpr0000644000175000017500000000070211750740337022050 0ustar xavierxavierwith "polyorb", "polyorb_test_common"; project local is Dir := external ("Test_Dir"); Obj_Dir := PolyORB_Test_Common.Build_Dir & Dir; for Object_Dir use Obj_Dir; for Source_Dirs use (Obj_Dir, PolyORB_Test_Common.Source_Dir & Dir); package Compiler is for Default_Switches ("Ada") use PolyORB_Test_Common.Compiler'Default_Switches ("Ada"); end Compiler; for Main use ("send.adb", "listener.adb"); end local; polyorb-2.8~20110207.orig/examples/corba/send/test-controller-impl.ads0000644000175000017500000000521611750740337025041 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- T E S T . C O N T R O L L E R . I M P L -- -- -- -- S p e c -- -- -- -- Copyright (C) 2008, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with CORBA; with PortableServer; package Test.Controller.Impl is type Object is new PortableServer.Servant_Base with private; function Get_Printer (Self : access Object) return Test.Printer.Ref; procedure Set_Printer (Self : access Object; Printer : Test.Printer.Ref); procedure Set_Group_Size (Self : access Object; Size : Natural); procedure StopServer (Self : access Object); function Test_OK (Self : access Object) return CORBA.Boolean; private type Object is new PortableServer.Servant_Base with record Printer : Test.Printer.Ref; Group_Size : Natural := 0; end record; end Test.Controller.Impl; polyorb-2.8~20110207.orig/examples/moma/0000755000175000017500000000000011750740340017151 5ustar xavierxavierpolyorb-2.8~20110207.orig/examples/moma/password.conf0000644000175000017500000000014411750740337021667 0ustar xavierxavier[user_1] name=Ada password=Lovelace class=user [user_2] name=Byron password=Lord class=admin polyorb-2.8~20110207.orig/examples/moma/router.adb0000644000175000017500000000660311750740337021154 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- R O U T E R -- -- -- -- B o d y -- -- -- -- Copyright (C) 2002-2004 Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by ACT Europe. -- -- (email: sales@act-europe.fr) -- -- -- ------------------------------------------------------------------------------ -- Sample MOMA router with Ada.Command_Line; with Ada.Text_IO; with PolyORB.Setup.No_Tasking_Server; pragma Warnings (Off, PolyORB.Setup.No_Tasking_Server); with MOMA.Configuration.Server; with MOMA.References; with MOMA.Runtime; with MOMA.Types; procedure Router is use Ada.Command_Line; use Ada.Text_IO; use MOMA.Configuration; use MOMA.Configuration.Server; use MOMA.Types; Other_Router : MOMA.Types.Ref := MOMA.Types.Nil_Ref; Router : MOMA.Types.Ref; begin -- Argument check if Argument_Count < 1 or else Argument_Count > 2 then Put_Line ("usage : router [IOR]"); Put_Line ("where :"); Put_Line ("-- 'router_id' is a the id of the router"); Put_Line ("-- 'IOR' is the IOR of another router"); return; end if; -- Initialize MOMA MOMA.Runtime.Initialize; -- Find reference to other router if needed if Argument_Count = 2 then MOMA.References.String_To_Reference (Ada.Command_Line.Argument (2), Other_Router); end if; -- Create one router and output its reference MOMA.Configuration.Server.Create_Router (To_MOMA_String (Ada.Command_Line.Argument (1)), Router, Other_Router); Put_Line ("Router IOR :"); Put_Line (MOMA.References.Reference_To_IOR_String (Router)); -- Run the server MOMA.Runtime.Start; end Router; polyorb-2.8~20110207.orig/examples/moma/README0000644000175000017500000000433111750740337020040 0ustar xavierxavierREADME for the PolyORB MOMA example ----------------------------------- $Id: README 34277 2003-01-06 11:08:39Z hugues $ This demo displays first possibilities of MOMA. The server setups one message pool according to data found in 'destinations.conf'. The only pertinent parameter is 'persistent' that determine whether persistence is to be used or not. The client sends and receives messages to the message pool created. All message types are tested. To test persistence, you must setup a persistent destination, then I) To run the PTP test, without using a naming service : - launch the server : ./server, it will output its IOR string. - run the client to store messages : ./client stor pool - kill the server, then re-launch it - run the client to retrieve messages : ./client retr pool or directly, if you do not want to test persistence. - run the client : ./client full pool II) To run the PTP test, using a naming service : - launch the server with the IOR string of the Naming Service : ./server IOR:... , it will output its IOR string. - run the client to store messages : ./client stor naming - run the client to retrieve messages : ./client retr naming or directly, if you do not want to test persistence. - run the client : ./client full pool III) To run the PTP test, using call-backs : - launch the server : ./server, it will output its IOR string. - run the client : ./clien_call_back IV) To run the Pub/Sub test (necessarily without a naming service) : - edit destinations.conf to set persistency to none, as currently all pools use the same filenames to store persistent messages - launch n message pools (= servers) : ./server n times, it will output its IOR string IOR_Pk (k = 1..n) - launch p routers : ./router r1, it will output its IOR string IOR_R1 ./router rj IOR_R1, it will output its IOR string IOR_R2 (j = 2..p) - subscribe some pools to the test topic using some routers : ./client sub IOR_Pk IOR_Rj, where k in 1..n, j in 1..p - send once the test messages to the test topic : ./client stor topic IOR_Rj, where j in 1..p - retrieve the test messages from any pool subscribed to the test topic : ./client retr pool IOR_Pk, where k in 1..n is the index of a subscribed pool polyorb-2.8~20110207.orig/examples/moma/Makefile.local0000644000175000017500000000000011750740337021676 0ustar xavierxavierpolyorb-2.8~20110207.orig/examples/moma/client_call_back_procedures.ads0000644000175000017500000000716211750740337025342 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- C L I E N T _ C A L L _ B A C K _ P R O C E D U R E S -- -- -- -- S p e c -- -- -- -- Copyright (C) 2002-2004 Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by ACT Europe. -- -- (email: sales@act-europe.fr) -- -- -- ------------------------------------------------------------------------------ -- Procedures for call_back test client with MOMA.Messages; with MOMA.Message_Producers; with MOMA.Message_Consumers; with MOMA.Message_Handlers; with MOMA.Types; with PolyORB.Annotations; package Client_Call_Back_Procedures is use MOMA.Message_Producers; use MOMA.Message_Consumers; use MOMA.Message_Handlers; type Byte_Test_Note is new PolyORB.Annotations.Note with record Byte_Value : MOMA.Types.Byte; Proceed : Boolean; end record; function Get_Byte_Value (Message : MOMA.Messages.Message'Class) return MOMA.Types.Byte; -- The following procedures also set the Proceed Boolean to True -- to allow the client to proceed with next test. procedure Handle_Then_Notify (Handler : access Message_Handler; Message : MOMA.Messages.Message'Class); -- Handle the message, compare its Id with current Byte_Value in -- Call_Back_Byte_test and set the behavior to Notify. procedure Notify_And_Receive (Handler : access Message_Handler); -- Receive notified message, compare its Id with current Byte_Value in -- Call_Back_Byte_test. Does not change behavior. procedure Notify_Then_Handle (Handler : access Message_Handler); -- Change the behavior to Handle. function Receive_MByte (MOMA_Consumer : Message_Consumer) return MOMA.Types.Byte; procedure Send_MByte (MOMA_Producer : Message_Producer; Id : MOMA.Types.Byte); procedure Set_Byte_Test_Note (Handler : access Message_Handler; Proceed : Boolean; Byte_Value : MOMA.Types.Byte); end Client_Call_Back_Procedures; polyorb-2.8~20110207.orig/examples/moma/test.out0000644000175000017500000000160111750740337020665 0ustar xavierxavierInitilisation...............................................: PASSED Testing Any Message ........................................: FAILED Testing Byte/Boolean Message ...............................: PASSED Testing Byte/Byte Message ..................................: PASSED Testing Byte/Char Message ..................................: PASSED Testing Byte/Double Message ................................: PASSED Testing Byte/Float Message .................................: PASSED Testing Byte/Short Message .................................: PASSED Testing Byte/Long Message ..................................: PASSED Testing Byte/Unsigned_Long Message .........................: PASSED Testing Byte/Unsigned_Short Message ........................: PASSED Testing Map Message ........................................: FAILED Testing Text Message .......................................: PASSED polyorb-2.8~20110207.orig/examples/moma/producer.conf0000644000175000017500000000025711750740337021655 0ustar xavierxavier[producer] log=true # log = true | false log-level=1 # log-level = 1 .. 3 connection-limit=42 # maximum number of connection # XXX check conformity with whole architecrture polyorb-2.8~20110207.orig/examples/moma/client_call_back_procedures.adb0000644000175000017500000001300711750740337025314 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- C L I E N T _ C A L L _ B A C K _ P R O C E D U R E S -- -- -- -- B o d y -- -- -- -- Copyright (C) 2002-2007, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with MOMA.Messages.MBytes; with PolyORB.Utils.Report; package body Client_Call_Back_Procedures is use MOMA.Messages; use MOMA.Messages.MBytes; use MOMA.Types; use PolyORB.Annotations; use PolyORB.Utils.Report; -------------------- -- Get_Byte_Value -- -------------------- function Get_Byte_Value (Message : MOMA.Messages.Message'Class) return MOMA.Types.Byte is MByte_Message_Rcvd : MOMA.Messages.MBytes.MByte; begin if Message in MOMA.Messages.MBytes.MByte then MByte_Message_Rcvd := MOMA.Messages.MBytes.MByte (Message); else raise Program_Error; end if; return Get_Byte (MByte_Message_Rcvd); end Get_Byte_Value; ------------------------ -- Handle_Then_Notify -- ------------------------ procedure Handle_Then_Notify (Handler : access Message_Handler; Message : MOMA.Messages.Message'Class) is Data : Byte_Test_Note; Id : constant Byte := Get_Byte_Value (Message); Ok : Boolean := False; begin Output ("Handling message ", True); Get_Call_Back_Data (Handler, Data); Ok := Id = Data.Byte_Value; Data.Proceed := True; Set_Call_Back_Data (Handler, Data); Output ("Retrieved message " & MOMA.Types.Byte'Image (Id), Ok); Set_Behavior (Handler, Notify); end Handle_Then_Notify; ------------------------ -- Notify_And_Receive -- ------------------------ procedure Notify_And_Receive (Handler : access Message_Handler) is Data : Byte_Test_Note; Id : constant Byte := Receive_MByte (Get_Consumer (Handler)); Ok : Boolean := False; begin Output ("Notified", True); Get_Call_Back_Data (Handler, Data); Ok := Id = Data.Byte_Value; Data.Proceed := True; Set_Call_Back_Data (Handler, Data); Output ("Retrieved message " & MOMA.Types.Byte'Image (Id), Ok); end Notify_And_Receive; ------------------------ -- Notify_Then_Handle -- ------------------------ procedure Notify_Then_Handle (Handler : access Message_Handler) is Data : Byte_Test_Note; begin Output ("Notified", True); Get_Call_Back_Data (Handler, Data); Data.Proceed := True; Set_Call_Back_Data (Handler, Data); Set_Behavior (Handler, Handle); end Notify_Then_Handle; ------------------- -- Receive_MByte -- ------------------- function Receive_MByte (MOMA_Consumer : Message_Consumer) return MOMA.Types.Byte is MOMA_Message_Temp : constant MOMA.Messages.Message'Class := Receive (MOMA_Consumer); begin return Get_Byte_Value (MOMA_Message_Temp); end Receive_MByte; ---------------- -- Send_MByte -- ---------------- procedure Send_MByte (MOMA_Producer : Message_Producer; Id : MOMA.Types.Byte) is MByte_Message_Sent : MOMA.Messages.MBytes.MByte := Create_Byte_Message; begin Set_Byte (MByte_Message_Sent, Id); Send (MOMA_Producer, MByte_Message_Sent); Output ("Send message #" & Id'Img, True); end Send_MByte; ------------------------ -- Set_Byte_Test_Note -- ------------------------ procedure Set_Byte_Test_Note (Handler : access Message_Handler; Proceed : Boolean; Byte_Value : MOMA.Types.Byte) is begin Set_Call_Back_Data (Handler, Byte_Test_Note'(Note with Byte_Value => Byte_Value, Proceed => Proceed)); end Set_Byte_Test_Note; end Client_Call_Back_Procedures; polyorb-2.8~20110207.orig/examples/moma/client_call_back.adb0000644000175000017500000001774611750740337023077 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- C L I E N T _ C A L L _ B A C K -- -- -- -- B o d y -- -- -- -- Copyright (C) 2002-2005 Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- Sample MOMA client with Message_Handler call_backs with Ada.Command_Line; with Ada.Text_IO; with Client_Call_Back_Procedures; with PolyORB.Setup.Thread_Pool_Server; pragma Warnings (Off, PolyORB.Setup.Thread_Pool_Server); with MOMA.Connection_Factories; with MOMA.Connections; with MOMA.Sessions; with MOMA.Destinations; with MOMA.Message_Producers; with MOMA.Message_Consumers; with MOMA.Message_Handlers; with MOMA.References; with MOMA.Runtime; with MOMA.Types; with PolyORB.Utils.Report; procedure Client_Call_Back is use Ada.Command_Line; use Ada.Text_IO; use Client_Call_Back_Procedures; use MOMA.Connection_Factories; use MOMA.Sessions; use MOMA.Connections; use MOMA.Destinations; use MOMA.Message_Producers; use MOMA.Message_Consumers; use MOMA.Message_Handlers; use MOMA.Types; use PolyORB.Utils.Report; Pool_Ref : MOMA.Types.Ref := MOMA.Types.Nil_Ref; MOMA_Factory : Connection_Factory; MOMA_Connection : MOMA.Connections.Connection; MOMA_Session : MOMA.Sessions.Session; MOMA_Dest_Pool : MOMA.Destinations.Destination; MOMA_Producer : MOMA.Message_Producers.Message_Producer; MOMA_Consumer : MOMA.Message_Consumers.Message_Consumer; MOMA_Consumer_Acc : MOMA.Message_Consumers.Message_Consumer_Acc; MOMA_Handler_Acc : MOMA.Message_Handlers.Message_Handler_Acc; MOMA_Handler : MOMA.Message_Handlers.Message_Handler; -- pragma Unreferenced (MOMA_Handler); pragma Warnings (Off, MOMA_Handler); -- WAG:5.02 DB08-008 -- Assigned but never read Message_Id : MOMA.Types.Byte; ---------- -- Wait -- ---------- procedure Wait; procedure Wait is Data : Byte_Test_Note; begin Get_Call_Back_Data (MOMA_Handler_Acc, Data); while not Data.Proceed loop delay 0.5; Get_Call_Back_Data (MOMA_Handler_Acc, Data); end loop; Data.Proceed := False; Set_Call_Back_Data (MOMA_Handler_Acc, Data); end Wait; -------------------- -- Main Procedure -- -------------------- begin -- Argument check if Argument_Count /= 1 then Put_Line ("usage : client_call_back "); return; end if; -- Initialize MOMA MOMA.Runtime.Initialize; -- Get a reference on the message pool to use. MOMA.References.String_To_Reference (Ada.Command_Line.Argument (1), Pool_Ref); -- Initialize the connection factory -- (should be done by the administrator). MOMA.Connection_Factories.Create (MOMA_Factory, Pool_Ref); -- Create connection using Connection Factory. MOMA_Connection := MOMA.Connections.Create_Connection (MOMA_Factory); -- Initialize the destination -- (should be usually done by the administrator). -- Note : in this example the destination and the provider are -- references to the same object (Pool_Ref). This will probably -- change later. MOMA_Dest_Pool := MOMA.Destinations.Create_Destination (To_MOMA_String ("queue1"), Pool_Ref); -- Create Session MOMA_Session := Create_Session (MOMA_Connection, False, 1); -- Create Message Producer associated to the Session MOMA_Producer := Create_Producer (MOMA_Session, MOMA_Dest_Pool); -- Create Message Consumer associated to the Session MOMA_Consumer_Acc := Create_Consumer (MOMA_Session, MOMA_Dest_Pool); MOMA_Consumer := MOMA_Consumer_Acc.all; MOMA_Handler_Acc := Create_Handler (MOMA_Session, MOMA_Consumer_Acc); MOMA_Handler := MOMA_Handler_Acc.all; -- Initialization is completed Output ("Initialization", True); -- Test #1 Set_Byte_Test_Note (MOMA_Handler_Acc, Byte_Value => MOMA.Types.Byte (1), Proceed => False); Set_Handler (MOMA_Handler_Acc, Handle_Then_Notify'Access); Set_Notifier (MOMA_Handler_Acc, Notify_And_Receive'Access); Set_Behavior (MOMA_Handler_Acc, Handle); Output ("Set behavior and procedures", True); Send_MByte (MOMA_Producer, 1); -- Message 1 is handled. -- Behavior is set to Notify by current Handle procedure. Wait; Output ("Test #1", True); -- Test #2 Set_Behavior (MOMA_Handler_Acc, Notify); Set_Byte_Test_Note (MOMA_Handler_Acc, Byte_Value => MOMA.Types.Byte (2), Proceed => False); Send_MByte (MOMA_Producer, 2); -- Message 2 is notified and received. Wait; Output ("Test #2", True); -- Test #3 Set_Notifier (MOMA_Handler_Acc, MOMA.Message_Handlers.Template_Notifier'Access); Send_MByte (MOMA_Producer, 3); -- Message 3 is notified and not received Output ("Test #3", True); -- Test #4 Set_Notifier (MOMA_Handler_Acc, Notify_Then_Handle'Access); Send_MByte (MOMA_Producer, 4); -- Message 4 is notified and not received. Behavior is set to -- Handle by current Notify procedure. Wait; Output ("Test #4", True); -- Test #5 Set_Byte_Test_Note (MOMA_Handler_Acc, Byte_Value => MOMA.Types.Byte (5), Proceed => False); Send_MByte (MOMA_Producer, 5); -- Message 5 is handled. -- Behavior is set to Notify by current Handle procedure. Wait; Output ("Test #5", True); -- Test #6 Set_Behavior (MOMA_Handler_Acc, None); Send_MByte (MOMA_Producer, 6); -- No call_back actions are defined for Message 6 Output ("Test #6", True); -- Test #7 Message_Id := Receive_MByte (MOMA_Consumer); Output ("Receive message" & MOMA.Types.Byte'Image (Message_Id), Message_Id = MOMA.Types.Byte (3)); Message_Id := Receive_MByte (MOMA_Consumer); Output ("Receive message" & MOMA.Types.Byte'Image (Message_Id), Message_Id = MOMA.Types.Byte (4)); Message_Id := Receive_MByte (MOMA_Consumer); Output ("Receive message" & MOMA.Types.Byte'Image (Message_Id), Message_Id = MOMA.Types.Byte (6)); -- XXX should destroy all structures here ! Output ("Test #7", True); End_Report; end Client_Call_Back; polyorb-2.8~20110207.orig/examples/moma/consumer.conf0000644000175000017500000000032411750740337021660 0ustar xavierxavier[consumer] #server_ior=1234 log=true # log = true | false log-level=1 # log-level = 1 .. 3 default_username=John_Doe default-password=plop default-time-to-live=42 default-priority=1 default-persistence=false polyorb-2.8~20110207.orig/examples/moma/local.gpr0000644000175000017500000000075011750740337020765 0ustar xavierxavierwith "polyorb", "polyorb_test_common"; project local is Dir := external ("Test_Dir"); Obj_Dir := PolyORB_Test_Common.Build_Dir & Dir; for Object_Dir use Obj_Dir; for Source_Dirs use (Obj_Dir, PolyORB_Test_Common.Source_Dir & Dir); package Compiler is for Default_Switches ("Ada") use PolyORB_Test_Common.Compiler'Default_Switches ("Ada"); end Compiler; for Main use ("client.adb", "server.adb", "router.adb", "client_call_back.adb"); end local; polyorb-2.8~20110207.orig/examples/moma/destinations.conf0000644000175000017500000000011211750740337022524 0ustar xavierxavier[destination 1] type=queue name=example1 persistent=none #persistent=file polyorb-2.8~20110207.orig/examples/moma/server.adb0000644000175000017500000000661311750740337021143 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- S E R V E R -- -- -- -- B o d y -- -- -- -- Copyright (C) 2002-2005 Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- Sample MOMA server with Ada.Command_Line; with Ada.Text_IO; with PolyORB.Setup.No_Tasking_Server; pragma Warnings (Off, PolyORB.Setup.No_Tasking_Server); with MOMA.Configuration.Server; with MOMA.References; with MOMA.Runtime; with MOMA.Types; procedure Server is use Ada.Command_Line; use Ada.Text_IO; use MOMA.Configuration; use MOMA.Configuration.Server; use MOMA.Types; MOMA_Ref : MOMA.Types.Ref; Pool_1 : Message_Pool; begin -- Initialize MOMA MOMA.Runtime.Initialize; -- Argument check if Argument_Count > 1 then Put_Line ("usage : server [Naming_Service_IOR]"); return; end if; -- Load Configuration File. Load_Configuration_File ("destinations.conf"); -- Get information about destination #1 Pool_1 := Get_Message_Pool (1); -- Create one message pool Create_Message_Pool (Pool_1, MOMA_Ref); -- Outputs its reference Put_Line ("'" & MOMA.References.Reference_To_IOR_String (MOMA_Ref) & "'"); -- Register reference to naming service begin if Argument_Count = 1 then MOMA.References.Initialize_Naming_Service (Ada.Command_Line.Argument (1)); MOMA.References.Register_Name ("Pool_1", MOMA_Ref); end if; exception when others => Put_Line ("Could not initialise Message Pool"); end; -- Run the server MOMA.Runtime.Start; end Server; polyorb-2.8~20110207.orig/examples/moma/client.adb0000644000175000017500000004043211750740337021110 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- C L I E N T -- -- -- -- B o d y -- -- -- -- Copyright (C) 2002-2007, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- Sample MOMA client with Ada.Command_Line; with Ada.Text_IO; with PolyORB.Setup.No_Tasking_Server; pragma Warnings (Off, PolyORB.Setup.No_Tasking_Server); -- XXX do not change Tasking model for now, otherwise there is a risk -- of a race condition between producer and consumer ... with MOMA.Connection_Factories; with MOMA.Connections; with MOMA.Sessions; with MOMA.Destinations; with MOMA.Message_Producers; with MOMA.Message_Consumers; with MOMA.Messages; with MOMA.Messages.MAnys; with MOMA.Messages.MBytes; with MOMA.Messages.MMaps; with MOMA.Messages.MTexts; with MOMA.References; with MOMA.Runtime; with MOMA.Types; with PolyORB.Utils.Report; procedure Client is use Ada.Command_Line; use Ada.Text_IO; use MOMA.Connection_Factories; use MOMA.Sessions; use MOMA.Connections; use MOMA.Destinations; use MOMA.Message_Producers; use MOMA.Message_Consumers; use MOMA.Messages; use MOMA.Types; use PolyORB.Utils.Report; Naming_StringRef : MOMA.Types.String; Pool_Ref : MOMA.Types.Ref := MOMA.Types.Nil_Ref; Pool_StringRef : MOMA.Types.String; Router_Ref : MOMA.Types.Ref := MOMA.Types.Nil_Ref; Router_StringRef : MOMA.Types.String; MOMA_Factory : Connection_Factory; MOMA_Connection : MOMA.Connections.Connection; MOMA_Session : MOMA.Sessions.Session; MOMA_Dest_Router : MOMA.Destinations.Destination; MOMA_Dest_Pool : MOMA.Destinations.Destination; MOMA_Producer : MOMA.Message_Producers.Message_Producer; MOMA_Consumer : MOMA.Message_Consumers.Message_Consumer; MOMA_Consumer_Acc : MOMA.Message_Consumers.Message_Consumer_Acc; Ok : Standard.Boolean; type Scenario_T is (Full, Stor, Retr, Sub, Unsub); Scenario : Scenario_T; type Kind_T is (Naming, Pool, Topic); Kind : Kind_T; --------------- -- Test_MAny -- --------------- procedure Test_MAny; -- Test MAny message procedure Test_MAny is use MOMA.Messages.MAnys; MAny_Message_Sent : MOMA.Messages.MAnys.MAny; MAny_Message_Rcvd : MOMA.Messages.MAnys.MAny; begin -- Create new Any Message MAny_Message_Sent := Create_Any_Message; Set_Any (MAny_Message_Sent, To_Any (To_MOMA_String ("Hi MOM !"))); if Scenario in Full .. Stor then -- Send Any Message Send (MOMA_Producer, MAny_Message_Sent); end if; if Scenario = Full or else Scenario = Retr then -- Get Any Message declare MOMA_Message_Temp : constant MOMA.Messages.Message'Class := Receive (MOMA_Consumer); begin if MOMA_Message_Temp in MOMA.Messages.MAnys.MAny then MAny_Message_Rcvd := MOMA.Messages.MAnys.MAny (MOMA_Message_Temp); else raise Program_Error; end if; end; Ok := Get_Payload (MAny_Message_Sent) = Get_Payload (MAny_Message_Rcvd); Output ("Testing Any Message ", Ok); end if; end Test_MAny; ---------------- -- Test_MByte -- ---------------- procedure Test_MByte; -- Test MByte message procedure Test_MByte is use MOMA.Messages.MBytes; MByte_Message_Sent : MOMA.Messages.MBytes.MByte; MByte_Message_Rcvd : MOMA.Messages.MBytes.MByte; procedure Send_Receive_MByte (Test_Name : String); procedure Send_Receive_MByte (Test_Name : String) is begin if Scenario in Full .. Stor then -- Send Byte message Send (MOMA_Producer, MByte_Message_Sent); end if; if Scenario = Full or else Scenario = Retr then -- Get Byte Message declare MOMA_Message_Temp : constant MOMA.Messages.Message'Class := Receive (MOMA_Consumer); begin if MOMA_Message_Temp in MOMA.Messages.MBytes.MByte then MByte_Message_Rcvd := MOMA.Messages.MBytes.MByte (MOMA_Message_Temp); else raise Program_Error; end if; end; Ok := Get_Payload (MByte_Message_Sent) = Get_Payload (MByte_Message_Rcvd); Output ("Testing " & Test_Name & " Message ", Ok); end if; end Send_Receive_MByte; begin -- Create new Byte Message MByte_Message_Sent := Create_Byte_Message; -- Byte/Boolean Test Set_Boolean (MByte_Message_Sent, MOMA.Types.Boolean'(True)); Send_Receive_MByte ("Byte/Boolean"); -- Byte/Byte Test Set_Byte (MByte_Message_Sent, MOMA.Types.Byte (42)); Send_Receive_MByte ("Byte/Byte"); -- Byte/Char Test Set_Char (MByte_Message_Sent, MOMA.Types.Char (Character'('A'))); Send_Receive_MByte ("Byte/Char"); -- Byte/Double Test Set_Double (MByte_Message_Sent, MOMA.Types.Double (42.0)); Send_Receive_MByte ("Byte/Double"); -- Byte/Float Test Set_Float (MByte_Message_Sent, MOMA.Types.Float (42.0)); Send_Receive_MByte ("Byte/Float"); -- Byte/Short Test Set_Short (MByte_Message_Sent, MOMA.Types.Short (3)); Send_Receive_MByte ("Byte/Short"); -- Byte/Long Test Set_Long (MByte_Message_Sent, MOMA.Types.Long (21)); Send_Receive_MByte ("Byte/Long"); -- Byte/Unsigned_Long Test Set_Unsigned_Long (MByte_Message_Sent, MOMA.Types.Unsigned_Long (12345)); Send_Receive_MByte ("Byte/Unsigned_Long"); -- Byte/Unsigned_Short Test Set_Unsigned_Short (MByte_Message_Sent, MOMA.Types.Unsigned_Short (123)); Send_Receive_MByte ("Byte/Unsigned_Short"); end Test_MByte; --------------- -- Test_MMap -- --------------- procedure Test_MMap; -- Test MMap message procedure Test_MMap is use MOMA.Messages.MMaps; MMap_Message_Sent : MOMA.Messages.MMaps.MMap; MMap_Message_Rcvd : MOMA.Messages.MMaps.MMap; Element_1 : Map_Element; Element_2 : Map_Element; My_Map : Map; begin Element_1 := (Name => To_MOMA_String ("name"), Value => To_Any (To_MOMA_String ("John Doe"))); Element_2 := (Name => To_MOMA_String ("age"), Value => To_Any (MOMA.Types.Short (42))); Append (My_Map, Element_1); Append (My_Map, Element_2); -- Create new Map Message MMap_Message_Sent := Create_Map_Message; Set_Map (MMap_Message_Sent, My_Map); if Scenario in Full .. Stor then -- Send Map Message Send (MOMA_Producer, MMap_Message_Sent); end if; if Scenario = Full or else Scenario = Retr then -- Get Map Message declare MOMA_Message_Temp : constant MOMA.Messages.Message'Class := Receive (MOMA_Consumer); begin if MOMA_Message_Temp in MOMA.Messages.MMaps.MMap then MMap_Message_Rcvd := MOMA.Messages.MMaps.MMap (MOMA_Message_Temp); else raise Program_Error; end if; end; Ok := Get_Map (MMap_Message_Sent) = Get_Map (MMap_Message_Rcvd); Output ("Testing Map Message ", Ok); end if; end Test_MMap; ---------------- -- Test_MText -- ---------------- procedure Test_MText; -- Test MText message procedure Test_MText is use MOMA.Messages.MTexts; MText_Message_Sent : MOMA.Messages.MTexts.MText; MText_Message_Rcvd : MOMA.Messages.MTexts.MText; begin -- Create new Text Message MText_Message_Sent := Create_Text_Message; Set_Text (MText_Message_Sent, To_MOMA_String ("Hi MOM !")); if Scenario in Full .. Stor then -- Send Text Message Send (MOMA_Producer, MText_Message_Sent); end if; if Scenario = Full or else Scenario = Retr then -- Get Text Message declare MOMA_Message_Temp : constant MOMA.Messages.Message'Class := Receive (MOMA_Consumer); begin if MOMA_Message_Temp in MOMA.Messages.MTexts.MText then MText_Message_Rcvd := MOMA.Messages.MTexts.MText (MOMA_Message_Temp); else raise Program_Error; end if; end; -- Print results Ok := Get_Text (MText_Message_Sent) = Get_Text (MText_Message_Rcvd); Output ("Testing Text Message ", Ok); end if; end Test_MText; --------------- -- Put_Usage -- --------------- procedure Put_Usage; procedure Put_Usage is begin Put_Line ("usage : client "); Put_Line (" where is in {full, stor, retr}"); Put_Line (" - full : full demo, send and receive messages"); Put_Line (" - stor : only send messages"); Put_Line (" - retr : only retrieve messages"); Put_Line (" where is in {pool, naming}"); Put_Line (" - pool : is the IOR of a message pool"); Put_Line (" - naming : is the IOR of a naming service"); New_Line; Put_Line ("or : client stor topic "); Put_Line (" where is the IOR of a router"); New_Line; Put_Line ("or : client "); Put_Line (" shortcut for client full pool "); New_Line; Put_Line ("or : client "); Put_Line (" where is in (sub, unsub)"); Put_Line (" is the IOR of the message pool to sub / unsub"); Put_Line (" is the IOR of a router"); New_Line; Put_Line ("{stor, retr} scenarios are to test persistency"); end Put_Usage; --------------------- -- Check_Arguments -- --------------------- function Check_Arguments return Boolean; function Check_Arguments return Boolean is Arg1 : String renames Ada.Command_Line.Argument (1); begin if Argument_Count = 1 then Scenario := Full; Kind := Pool; Pool_StringRef := To_MOMA_String (Arg1); return True; end if; if Argument_Count /= 3 then return False; end if; declare Arg2 : String renames Ada.Command_Line.Argument (2); Arg3 : String renames Ada.Command_Line.Argument (3); begin if Arg1 = "full" then Scenario := Full; elsif Arg1 = "stor" then Scenario := Stor; elsif Arg1 = "retr" then Scenario := Retr; elsif Arg1 = "sub" then Scenario := Sub; Kind := Topic; return True; elsif Arg1 = "unsub" then Scenario := Unsub; Kind := Topic; return True; else return False; end if; if Arg2 = "pool" then Kind := Pool; Pool_StringRef := To_MOMA_String (Arg3); elsif Arg2 = "naming" then Kind := Naming; Naming_StringRef := To_MOMA_String (Arg3); elsif Arg2 = "topic" then Kind := Topic; Router_StringRef := To_MOMA_String (Arg3); Pool_StringRef := To_MOMA_String (Arg2); if Arg1 /= "stor" then return False; end if; else return False; end if; end; return True; end Check_Arguments; -- Start of processing for Client begin -- Argument check if not (Check_Arguments) then Put_Usage; return; end if; -- Initialize MOMA MOMA.Runtime.Initialize; -- Get a reference on the message pool to use case Kind is when Pool => MOMA.References.String_To_Reference (To_Standard_String (Pool_StringRef), Pool_Ref); when Naming => MOMA.References.Initialize_Naming_Service (To_Standard_String (Naming_StringRef)); Pool_Ref := MOMA.References.Locate ("Pool_1"); Kind := Pool; when Topic => MOMA.References.String_To_Reference (To_Standard_String (Router_StringRef), Router_Ref); if Scenario = Sub or else Scenario = Unsub then MOMA.References.String_To_Reference (To_Standard_String (Pool_StringRef), Pool_Ref); end if; end case; -- Initialize the connection factory -- (should be done by the administrator). MOMA.Connection_Factories.Create (MOMA_Factory, Pool_Ref); -- Create connection using Connection Factory MOMA_Connection := MOMA.Connections.Create_Connection (MOMA_Factory); -- Initialize the destination -- (should be usually done by the administrator). -- Note : in this example the destination and the provider are -- references to the same object (Pool_Ref). This will probably -- change later. if Pool_Ref /= Nil_Ref then MOMA_Dest_Pool := MOMA.Destinations.Create_Destination (To_MOMA_String ("queue1"), Pool_Ref, MOMA.Types.Pool); end if; if Router_Ref /= Nil_Ref then MOMA_Dest_Router := MOMA.Destinations.Create_Destination (To_MOMA_String ("Test"), Router_Ref, MOMA.Types.Topic); end if; -- Create Session MOMA_Session := Create_Session (MOMA_Connection, False, 1); -- Create Message Producer associated to the Session if Kind = Pool then MOMA_Producer := Create_Producer (MOMA_Session, MOMA_Dest_Pool); elsif Kind = Topic then MOMA_Producer := Create_Producer (MOMA_Session, MOMA_Dest_Router); end if; -- Create Message Consumer associated to the Session MOMA_Consumer_Acc := Create_Consumer (MOMA_Session, MOMA_Dest_Pool); MOMA_Consumer := MOMA_Consumer_Acc.all; -- Subscribe / Unsubscribe to the "Test" topic if Kind = Topic then if Scenario = Sub then MOMA.Sessions.Subscribe (MOMA_Dest_Router, MOMA_Dest_Pool); elsif Scenario = Unsub then MOMA.Sessions.Unsubscribe (MOMA_Dest_Router, MOMA_Dest_Pool); end if; end if; -- Initialization is completed Output ("Initialization", True); -- Testing MAny messages Test_MAny; -- Testing MByte messages Test_MByte; -- Testing MMap messages Test_MMap; -- Testing MText messages Test_MText; End_Report; -- XXX should destroy all structures here ! end Client; polyorb-2.8~20110207.orig/examples/README0000644000175000017500000000215411750740337017110 0ustar xavierxavierREADME for the PolyORB examples directory ----------------------------------------- $Id: README 119921 2007-12-06 19:47:15Z duff $ To build the examples, follow the instructions in the PolyORB User's Guide. * Directories : This directory contains a few demonstration of PolyORB's capabilities. It is organized around PolyORB application personnalities aws/ : AWS demos, bbs/ : Interoperability demo between CORBA and DSA middleware, corba/ : CORBA demos, dsa/ : Ada 95 Distributed System Annex demos, moma/ : MOMA demo, polyorb/ : simple demo using PolyORB's neutral core layer. * Interoperability demo : XXX To be written. * SOAP demo : To specificaly test SOAP protocol personality, you can use the "Generic SOAP client" at http://soapclient.com/soapmsg.html (c) SQLData System Inc. And provide the following inputs : Server address : the full path to your object, e.g. 137.194.162.29:8080/1;sys;pf=1032965896 SOAPAction : the method to execute, e.g. echoString SOAPMessage : the complete SOAP message, see examples/corba/echo/soap_message We provide SOAP Messages for some tests. polyorb-2.8~20110207.orig/examples/static/0000755000175000017500000000000011750740340017507 5ustar xavierxavierpolyorb-2.8~20110207.orig/examples/static/README0000644000175000017500000000221511750740337020375 0ustar xavierxavierREADME for the static configuration examples directory ------------------------------------------------------ $Id: README 122725 2008-03-05 22:45:18Z uruena $ This directory contains a sample static configuration file named 'po_static_conf.ads'. To test this configuration method, just copy this file to another PolyORB example, for example the CORBA echo test: $ cp po_static_conf.ads ../corba/echo/ Then, go to that directory $ cd ../corba/echo/ and execute: $ idlac echo.idl $ gnatmake -c po_static_conf.ads `polyorb-config` $ gnatmake server `polyorb-config` -largs po_static_conf.o You can then edit the file 'po_static_conf.ads' to modify some PolyORB parameter of the executable. After that you must compile again that configuration file: $ gnatmake -c po_static_conf.ads `polyorb-config` and then just relink the application without recompiling any application sources: $ gnatmake -l server `polyorb-config` -largs po_static_conf.o Note that you must also specify the option -b to rebind the application because the file 'b~server.ali' is required for relinking, but it is usually removed by gnatmake after the compilation. polyorb-2.8~20110207.orig/examples/static/po_static_conf.ads0000644000175000017500000000660411750740337023206 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O _ S T A T I C _ C O N F -- -- -- -- S p e c -- -- -- -- Copyright (C) 2008, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with PolyORB.Parameters.Static; use PolyORB.Parameters.Static; -- Static configuration of PolyORB package PO_Static_Conf is -- Strings can be completely static (no need to import memory management -- symbols), or dynamic to ease editing. -- Parameters uipmc : aliased constant String := "[access_points]uipmc"; srp : aliased constant String := "[access_points]srp"; -- Values enable : aliased constant String := "enable"; disable : aliased constant String := "disable"; -- Each line can easily commented out during development to test -- different configuration options. Static_Parameters : constant Static_Parameter_Array := ( -- Parameters for tasking -- (new String'("[tasking]max_threads"), new String'("25")), -- Enable/Disable access points -- (new String'("[access_points]iiop"), disable'Access), -- (srp'Access, enable'Access), (uipmc'Access, disable'Access), -- This MUST be the last element of the array: (null, null) ); -- The package and variables can have any name, but the array must be -- exported with the following Convetion and External name: pragma Export (Convention => Ada, Entity => Static_Parameters, External_Name => "__PolyORB_static_parameters"); end PO_Static_Conf; polyorb-2.8~20110207.orig/examples/dsa/0000755000175000017500000000000011750740340016767 5ustar xavierxavierpolyorb-2.8~20110207.orig/examples/dsa/echo/0000755000175000017500000000000011750740340017705 5ustar xavierxavierpolyorb-2.8~20110207.orig/examples/dsa/echo/server.ads0000644000175000017500000000016611750740337021715 0ustar xavierxavierpackage Server is pragma Remote_Call_Interface; function Echo_String (S : String) return String; end Server; polyorb-2.8~20110207.orig/examples/dsa/echo/echo.cfg0000644000175000017500000000066711750740337021323 0ustar xavierxavierconfiguration Echo is pragma Name_Server (Embedded); -- We declare a server partition that executes the server package ... Server_Partition : partition := (Server); -- ... and a client partition that executes the client main procedure Client_Partition : partition; procedure Client is in Client_Partition; -- The partitions' executables should be put in ./bin for Partition'Directory use "bin"; end Echo; polyorb-2.8~20110207.orig/examples/dsa/echo/echo_standalone.cfg0000644000175000017500000000072311750740337023524 0ustar xavierxavierconfiguration Echo is pragma Name_Server (Standalone); pragma Starter (None); -- We declare a server partition that executes the server package ... Server_Partition : partition := (Server); -- ... and a client partition that executes the client main procedure Client_Partition : partition; procedure Client is in Client_Partition; -- The partitions' executables should be put in ./bin for Partition'Directory use "bin"; end Echo; polyorb-2.8~20110207.orig/examples/dsa/echo/server.adb0000644000175000017500000000021711750740337021671 0ustar xavierxavierpackage body Server is function Echo_String (S : String) return String is begin return S; end Echo_String; end Server; polyorb-2.8~20110207.orig/examples/dsa/echo/client.adb0000644000175000017500000000452411750740337021646 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- C L I E N T -- -- -- -- B o d y -- -- -- -- Copyright (C) 2011, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with Ada.Exceptions; with Ada.Text_IO; use Ada.Text_IO; with Server; procedure Client is begin Put_Line ("The client has started!"); Put ("Thus spake my server upon me:"); Put_Line (Server.Echo_String ("Hi!")); exception when E : others => Put_Line ("Got " & Ada.Exceptions.Exception_Information (E)); end Client; polyorb-2.8~20110207.orig/examples/dsa/echo/echo_mcast.cfg0000644000175000017500000000072211750740337022502 0ustar xavierxavierconfiguration Echo is pragma Name_Server (Multicast); pragma Starter (None); -- We declare a server partition that executes the server package ... Server_Partition : partition := (Server); -- ... and a client partition that executes the client main procedure Client_Partition : partition; procedure Client is in Client_Partition; -- The partitions' executables should be put in ./bin for Partition'Directory use "bin"; end Echo; polyorb-2.8~20110207.orig/examples/dsa/README0000644000175000017500000000114411750740337017655 0ustar xavierxavierThis directory contains the following examples for the Ada Distributed Systems Annex: - echo Simple client/server ping - demo Demo of passing complex data types between client and server - bank A client/server application with one server and multiple instances of the client partition - connections Multiple servers and multiple clients, each server has a single receiving task and blocks waiting for clients; clients use asynchronous send operations - mailboxes Same as "connections" but implemented in Ada 2005 using an RACW with designating an interface implemented by the server task. polyorb-2.8~20110207.orig/examples/dsa/demo/0000755000175000017500000000000011750740340017713 5ustar xavierxavierpolyorb-2.8~20110207.orig/examples/dsa/demo/noproc.adb0000644000175000017500000000406311750740337021674 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- N O P R O C -- -- -- -- B o d y -- -- -- -- Copyright (C) 2009, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ procedure Noproc is begin null; end Noproc; polyorb-2.8~20110207.orig/examples/dsa/demo/sp.ads0000644000175000017500000000432311750740337021036 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- S P -- -- -- -- S p e c -- -- -- -- Copyright (C) 2002-2009, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ package SP is pragma Shared_Passive; Shared_Integer : Integer; type Shared_Record_T is record I : Integer; B : Boolean; end record; Shared_Record : Shared_Record_T; end SP; polyorb-2.8~20110207.orig/examples/dsa/demo/rt.ads0000644000175000017500000000575111750740337021047 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- R T -- -- -- -- S p e c -- -- -- -- Copyright (C) 2002-2009, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with Ada.Streams; use Ada.Streams; package RT is pragma Remote_Types; type Obj is abstract tagged limited private; procedure Method (Self : Obj) is abstract; procedure Method2 (Self : Obj; N : Integer) is abstract; procedure Method3 (Self : Obj; Other : Obj) is abstract; function Tekitoa (Self : Obj) return String is abstract; type RACW is access all Obj'Class; type Limited_Data is limited private; procedure Read (S : access Root_Stream_Type'Class; V : out Limited_Data); procedure Write (S : access Root_Stream_Type'Class; V : Limited_Data); for Limited_Data'Read use Read; for Limited_Data'Write use Write; procedure Show (Name : String; X : Limited_Data); private type Obj is abstract tagged limited null record; type Limited_Data is limited record Value : Integer := 0; end record; for Limited_Data'Size use Integer'Size; for Limited_Data use record Value at 0 range 0 .. Integer'Size - 1; end record; end RT; polyorb-2.8~20110207.orig/examples/dsa/demo/rci.adb0000644000175000017500000001442311750740337021152 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- R C I -- -- -- -- B o d y -- -- -- -- Copyright (C) 2002-2009, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with Ada.Text_IO; use Ada.Text_IO; with System.Address_Image; with Ada.Real_Time; use Ada.Real_Time; package body RCI is type String_Ptr is access all String; type Real_Obj is new RT.Obj with record Name : String_Ptr; end record; type Real_Obj_Ptr is access Real_Obj; procedure Method (Self : Real_Obj); procedure Method2 (Self : Real_Obj; N : Integer); procedure Method3 (Self : Real_Obj; Other : Real_Obj); function Tekitoa (Self : Real_Obj) return String; procedure Method (Self : Real_Obj) is begin Put_Line ("Method1 called on " & System.Address_Image (Self'Address)); end Method; procedure Method2 (Self : Real_Obj; N : Integer) is begin Put_Line ("Method2 (" & N'Img & ") called on " & System.Address_Image (Self'Address)); end Method2; procedure Method3 (Self : Real_Obj; Other : Real_Obj) is begin Put_Line ("Method2 (" & System.Address_Image (Other'Address) & ") called on " & System.Address_Image (Self'Address)); end Method3; function Tekitoa (Self : Real_Obj) return String is begin Put_Line ("I am " & Self.Name.all); return Self.Name.all; end Tekitoa; procedure My_Proc (X : Integer; Y : in out Predicate; Z : out Trit) is begin Y := Y and then Predicate (X = 0); Z := 1; end My_Proc; function My_Func (S : String) return Color is begin return Color'Value (S); end My_Func; function Get_Obj (Name : String) return RT.RACW is P : Real_Obj_Ptr; begin if Name = "" then return null; else P := new Real_Obj; P.Name := new String'(Name); return RT.RACW (P); end if; end Get_Obj; function echoVector (V : Vector) return Vector is begin Put_Line ("Got vector" & Integer'Image (V'First) & " .." & Integer'Image (V'Last) & ":"); for J in V'Range loop Put (Integer'Image (V (J))); end loop; New_Line; return V; end echoVector; function echoTranspose (M : Matrix) return Matrix is begin Put_Line ("Got matrix:"); Put_Line ("Ranges of M : (" & Integer'Image (M'First (1)) & ".." & Integer'Image (M'Last (1)) & ", " & Integer'Image (M'First (2)) & ".." & Integer'Image (M'Last (2)) & ")"); for J in M'Range (1) loop for K in M'Range (2) loop Put (" " & Float'Image (M (J, K))); end loop; New_Line; end loop; return Matrices.Transpose (M); end echoTranspose; function echoString (S : String) return String is begin Put_Line ("Thus spake my client unto me: «" & S & "»."); return S; end echoString; function getRAS return echo_RAS is Func : constant echo_RAS := echoString'Access; begin Put_Line (Func.all ("Checking local (bypass) RAS call")); return Func; end getRAS; procedure Check_Back_RAS (Func : echo_RAS; S : String) is begin Put_Line (Func.all ("Cheking RAS sent back by client: " & S)); end Check_Back_RAS; function echoString_Delayed (S : String; Seconds : Integer) return String is begin delay until Clock + To_Time_Span (Duration (Seconds)); return echoString (S); end echoString_Delayed; function Modulus2 (Z : Complex) return Float is begin return Z.Re * Z.Re + Z.Im * Z.Im; end Modulus2; Cookie : Integer := 0; function echoC_4_5 (X : C_4_5) return C_4_5 is begin return X; end echoC_4_5; function Get_Cookie return Integer is begin return Cookie; end Get_Cookie; procedure Delayed_Set_Cookie (Cookie : Integer) is begin delay until Clock + Milliseconds (2_000); RCI.Cookie := Cookie; end Delayed_Set_Cookie; procedure Raise_Program_Error is begin raise Program_Error; end Raise_Program_Error; procedure Raise_Visible is begin raise Visible; end Raise_Visible; procedure Raise_Invisible is Invisible : exception; begin raise Invisible; end Raise_Invisible; procedure Add (X : Integer; To : in out RT.Limited_Data) is To_Val : Integer; for To_Val'Address use To'Address; pragma Import (Ada, To_Val); begin To_Val := To_Val + X; end Add; end RCI; polyorb-2.8~20110207.orig/examples/dsa/demo/matrices.adb0000644000175000017500000000451211750740337022202 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- M A T R I C E S -- -- -- -- B o d y -- -- -- -- Copyright (C) 2003-2009, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ package body Matrices is function Transpose (M : Matrix) return Matrix is Res : Matrix (M'Range (2), M'Range (1)); begin for J in M'Range (1) loop for K in M'Range (2) loop Res (K, J) := M (J, K); end loop; end loop; return Res; end Transpose; end Matrices; polyorb-2.8~20110207.orig/examples/dsa/demo/rci.ads0000644000175000017500000000722311750740337021173 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- R C I -- -- -- -- S p e c -- -- -- -- Copyright (C) 2002-2009, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with Matrices; use Matrices; with RT; package RCI is pragma Remote_Call_Interface; -- pragma All_Calls_Remote; type Color is (Red, Green, Blue); type Hue is new Color; -- Expanded to: type hueB is new Color; subtype hue is hueB; subtype Tint is Color; type Predicate is new Boolean; subtype Predicate2 is Predicate; type Predicate3 is new Predicate; subtype Predicate4 is Predicate3; type Trit is range 0 .. 2; procedure My_Proc (X : Integer; Y : in out Predicate; Z : out Trit); function My_Func (S : String) return Color; function Get_Obj (Name : String) return RT.RACW; type Vector is array (Integer range <>) of Integer; function echoVector (V : Vector) return Vector; function echoTranspose (M : Matrix) return Matrix; function echoString (S : String) return String; type echo_RAS is access function (S : String) return String; function getRAS return echo_RAS; procedure Check_Back_RAS (Func : echo_RAS; S : String); function echoString_Delayed (S : String; Seconds : Integer) return String; type Complex is record Re, Im : Float; end record; function Modulus2 (Z : Complex) return Float; type C_4_5 is array (0 .. 3, 0 .. 4) of Complex; function echoC_4_5 (X : C_4_5) return C_4_5; procedure Add (X : Integer; To : in out RT.Limited_Data); -- type Parameterless_RAS is access procedure; function Get_Cookie return Integer; procedure Delayed_Set_Cookie (Cookie : Integer); pragma Asynchronous (Delayed_Set_Cookie); Visible : exception; procedure Raise_Program_Error; procedure Raise_Visible; procedure Raise_Invisible; end RCI; polyorb-2.8~20110207.orig/examples/dsa/demo/client_main.adb0000644000175000017500000001470511750740337022662 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- C L I E N T _ M A I N -- -- -- -- B o d y -- -- -- -- Copyright (C) 2002-2009, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with Ada.Exceptions; with Ada.Text_IO; use Ada.Text_IO; with Ada.Real_Time; use Ada.Real_Time; with RCI; with RT; with SP; with Matrices; with System.RPC; procedure Client_Main is S : constant String := "Hello DSA world!"; RAS : RCI.echo_RAS; procedure Try_RACW (Name : String); procedure Try_RACW (Name : String) is use type RT.RACW; Obj : RT.RACW; begin Put_Line ("Trying RACW with Name = """ & Name & """"); Obj := RCI.Get_Obj (Name); if Obj = null then Put_Line ("Got null!"); else Put_Line ("Got not null: " & RT.Tekitoa (Obj.all) & " is alive!"); end if; end Try_RACW; Z : constant RCI.Complex := (Re => 2.0, Im => 3.0); begin SP.Shared_Integer := 42; Put_Line ("I said: " & S); Put_Line ("The server (on partition" & System.RPC.Partition_ID'Image (RCI'Partition_Id) & ") replied: " & RCI.echoString (S)); RAS := RCI.echoString'Access; Put_Line ("Obtained RAS on client"); Put_Line ("through RAS: " & RAS (S & " (RASI)")); Put_Line ("through RAS: " & RAS.all (S & " (RASE)")); RCI.Check_Back_RAS (RAS, "RAS taken on client"); RAS := RCI.getRAS; Put_Line ("Obtained RAS-from-server"); Put_Line ("through RAS-from-server: " & RAS (S & " (RASS)")); RCI.Check_Back_RAS (RAS, "RAS taken on server"); Try_RACW (""); Try_RACW ("Elvis"); declare use type RCI.Vector; V : constant RCI.Vector := (3 => 111, 4 => 222, 5 => 333); begin Put_Line ("V passed? " & Boolean'Image (V = RCI.echoVector (V))); end; Put_Line ("|2 + 3i|^2 = " & Float'Image (RCI.Modulus2 (Z))); declare use type RCI.C_4_5; Matrix : RCI.C_4_5; begin for J in Matrix'Range (1) loop for K in Matrix'Range (2) loop Matrix (J, K) := (Re => 1.0 / Float (J), Im => 1.0 / Float (K)); end loop; end loop; Put_Line ("Constrained matrix passed? " & Boolean'Image (Matrix = RCI.echoC_4_5 (Matrix))); end; declare use Matrices; M : Matrix (8 .. 10, 3 .. 11); begin for J in M'Range (1) loop for K in M'Range (2) loop M (J, K) := Float (J) + 0.01 * Float (K); end loop; end loop; Put_Line ("Sending matrix:"); for J in M'Range (1) loop for K in M'Range (2) loop Put (" " & Float'Image (M (J, K))); end loop; New_Line; end loop; declare M_Prime : constant Matrix := RCI.echoTranspose (M); begin Put_Line ("Ranges of M : (" & Integer'Image (M'First (1)) & ".." & Integer'Image (M'Last (1)) & ", " & Integer'Image (M'First (2)) & ".." & Integer'Image (M'Last (2)) & ")"); Put_Line ("Ranges of M': (" & Integer'Image (M_Prime'First (1)) & ".." & Integer'Image (M_Prime'Last (1)) & ", " & Integer'Image (M_Prime'First (2)) & ".." & Integer'Image (M_Prime'Last (2)) & ")"); Put_Line ("Unconstrained matrix passed? " & Boolean'Image (M = Transpose (M_Prime))); end; end; declare L : RT.Limited_Data; begin RT.Show ("L1", L); RCI.Add (123000, To => L); RT.Show ("L2", L); RCI.Add (456, To => L); RT.Show ("L3", L); end; declare C : constant Integer := RCI.Get_Cookie; begin Put_Line ("Cookie value:" & Integer'Image (C)); RCI.Delayed_Set_Cookie (C + 1); end; delay until Clock + Milliseconds (500); Put_Line ("Cookie value after 0.5 s:" & Integer'Image (RCI.Get_Cookie)); delay until Clock + Milliseconds (2_500); Put_Line ("Cookie value after 3 s:" & Integer'Image (RCI.Get_Cookie)); begin Put ("Raise_Program_Error: "); RCI.Raise_Program_Error; Put_Line ("no exception."); exception when E : others => Put_Line ("raised " & Ada.Exceptions.Exception_Information (E)); end; begin Put ("Raise_Visible: "); RCI.Raise_Visible; Put_Line ("no exception."); exception when E : others => Put_Line ("raised " & Ada.Exceptions.Exception_Information (E)); end; begin Put ("Raise_Invisible: "); RCI.Raise_Invisible; Put_Line ("no exception."); exception when E : others => Put_Line ("raised " & Ada.Exceptions.Exception_Information (E)); end; end Client_Main; polyorb-2.8~20110207.orig/examples/dsa/demo/testbed.cfg0000644000175000017500000000053411750740337022036 0ustar xavierxavier-- Configuration file for use of DSA example with gnatdist -- $Id: testbed.cfg 142910 2009-04-16 14:40:01Z quinot $ configuration Testbed is pragma Starter (None); ServerP : Partition := (Rci); ClientP : Partition := (SP); procedure Noproc is in ServerP; procedure Client_Main; for ClientP'Main use Client_Main; end Testbed; polyorb-2.8~20110207.orig/examples/dsa/demo/matrices.ads0000644000175000017500000000426511750740337022230 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- M A T R I C E S -- -- -- -- S p e c -- -- -- -- Copyright (C) 2003-2009, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ package Matrices is pragma Pure; type Matrix is array (Integer range <>, Integer range <>) of Float; function Transpose (M : Matrix) return Matrix; end Matrices; polyorb-2.8~20110207.orig/examples/dsa/connections/0000755000175000017500000000000011750740340021311 5ustar xavierxavierpolyorb-2.8~20110207.orig/examples/dsa/connections/connect.cfg0000644000175000017500000000100711750740337023427 0ustar xavierxavierconfiguration Connect is pragma Starter (None); Hub_Partition : Partition := (Hub); procedure Hub_Main is in Hub_Partition; for Hub_Partition'Termination use Deferred_Termination; Server_Partition : Partition; procedure Server; for Server_Partition'Main use Server; for Server_Partition'Termination use Deferred_Termination; Client_Partition : Partition; procedure Client; for Client_Partition'Main use Client; for Client_Partition'Termination use Local_Termination; end Connect; polyorb-2.8~20110207.orig/examples/dsa/connections/hub_main.adb0000644000175000017500000000406711750740337023560 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- H U B _ M A I N -- -- -- -- B o d y -- -- -- -- Copyright (C) 2009, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ procedure Hub_Main is begin null; end Hub_Main; polyorb-2.8~20110207.orig/examples/dsa/connections/listeners.adb0000644000175000017500000000502011750740337023774 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- L I S T E N E R S -- -- -- -- B o d y -- -- -- -- Copyright (C) 2009, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with Ada.Text_IO; use Ada.Text_IO; package body Listeners is task body Listener_Task is My_Id : Integer; begin accept Start (Id : Integer) do My_Id := Id; end Start; loop accept Process_Message (Message : String) do Put_Line ("Got message: " & Message); end Process_Message; end loop; end Listener_Task; procedure Send (X : Active_Listener; Message : String) is begin X.T.Process_Message (Message); end Send; end Listeners; polyorb-2.8~20110207.orig/examples/dsa/connections/listeners.ads0000644000175000017500000000473511750740337024031 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- L I S T E N E R S -- -- -- -- S p e c -- -- -- -- Copyright (C) 2009, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with Connections; package Listeners is task type Listener_Task is entry Start (Id : Integer); entry Process_Message (Message : String); end Listener_Task; type Listener_Task_Acc is access Listener_Task; type Active_Listener (T : access Listener_Task) is new Connections.Connection_Listener with null record; procedure Send (X : Active_Listener; Message : String); type Active_Listener_Acc is access Active_Listener; end Listeners; polyorb-2.8~20110207.orig/examples/dsa/connections/hub.adb0000644000175000017500000000457711750740337022562 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- H U B -- -- -- -- B o d y -- -- -- -- Copyright (C) 2009, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ package body Hub is All_Listeners : array (0 .. 7) of Connections.Connection; procedure Register_Listener (Id : Integer; Ptr : Connections.Connection) is begin All_Listeners (Id) := Ptr; end Register_Listener; function Get_Listener (Id : Integer) return Connections.Connection is begin return All_Listeners (Id); end Get_Listener; end Hub; polyorb-2.8~20110207.orig/examples/dsa/connections/hub.ads0000644000175000017500000000434611750740337022575 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- H U B -- -- -- -- S p e c -- -- -- -- Copyright (C) 2009, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with Connections; package Hub is pragma Remote_Call_Interface; procedure Register_Listener (Id : Integer; Ptr : Connections.Connection); function Get_Listener (Id : Integer) return Connections.Connection; end Hub; polyorb-2.8~20110207.orig/examples/dsa/connections/connections.ads0000644000175000017500000000460711750740337024341 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- C O N N E C T I O N S -- -- -- -- S p e c -- -- -- -- Copyright (C) 2009, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ package Connections is pragma Remote_Types; type Connection_Listener is abstract tagged limited private; procedure Send (Target : Connection_Listener; Message : String) is abstract; type Connection is access all Connection_Listener'Class; pragma Asynchronous (Connection); private type Connection_Listener is abstract tagged limited null record; end Connections; polyorb-2.8~20110207.orig/examples/dsa/connections/server.adb0000644000175000017500000000471611750740337023305 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- S E R V E R -- -- -- -- B o d y -- -- -- -- Copyright (C) 2009, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with Ada.Command_Line; use Ada.Command_Line; with Connections; with Hub; with Listeners; use Listeners; procedure Server is My_Id : constant Integer := Integer'Value (Argument (1)); Myself_T : constant Listener_Task_Acc := new Listener_Task; Myself : constant Active_Listener_Acc := new Active_Listener (Myself_T); begin Myself.T.Start (My_Id); Hub.Register_Listener (Id => My_Id, Ptr => Connections.Connection (Myself)); end Server; polyorb-2.8~20110207.orig/examples/dsa/connections/client.adb0000644000175000017500000000441011750740337023244 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- C L I E N T -- -- -- -- B o d y -- -- -- -- Copyright (C) 2009, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with Ada.Command_Line; use Ada.Command_Line; with Hub; with Connections; procedure Client is Target : Connections.Connection; begin Target := Hub.Get_Listener (Integer'Value (Argument (1))); Connections.Send (Target.all, Argument (2)); end Client; polyorb-2.8~20110207.orig/examples/dsa/mailboxes/0000755000175000017500000000000011750740340020752 5ustar xavierxavierpolyorb-2.8~20110207.orig/examples/dsa/mailboxes/mailboxes-active.ads0000644000175000017500000000445111750740337024711 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- M A I L B O X E S . A C T I V E -- -- -- -- S p e c -- -- -- -- Copyright (C) 2009, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ package Mailboxes.Active is task type Active_Mailbox is new Mailbox with entry Start (Id : Integer); entry Send_Message (Message : Message_Type); end Active_Mailbox; type Active_Mailbox_Acc is access all Active_Mailbox; -- Local access type end Mailboxes.Active; polyorb-2.8~20110207.orig/examples/dsa/mailboxes/mail.cfg0000644000175000017500000000100111750740337022353 0ustar xavierxavierconfiguration Mail is pragma Starter (None); Hub_Partition : Partition := (Hub); procedure Hub_Main is in Hub_Partition; for Hub_Partition'Termination use Deferred_Termination; Server_Partition : Partition; procedure Server; for Server_Partition'Main use Server; for Server_Partition'Termination use Deferred_Termination; Client_Partition : Partition; procedure Client; for Client_Partition'Main use Client; for Client_Partition'Termination use Local_Termination; end Mail; polyorb-2.8~20110207.orig/examples/dsa/mailboxes/hub_main.adb0000644000175000017500000000406711750740337023221 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- H U B _ M A I N -- -- -- -- B o d y -- -- -- -- Copyright (C) 2009, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ procedure Hub_Main is begin null; end Hub_Main; polyorb-2.8~20110207.orig/examples/dsa/mailboxes/mailboxes.ads0000644000175000017500000000455611750740337023446 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- M A I L B O X E S -- -- -- -- S p e c -- -- -- -- Copyright (C) 2009, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ package Mailboxes is pragma Remote_Types; subtype Message_Type is String; type Mailbox is limited interface; procedure Send_Message (Recipient : access Mailbox; Message : Message_Type) is abstract; type Remote_Mailbox is access all Mailbox'Class; pragma Asynchronous (Remote_Mailbox); -- Remote access to mailbox end Mailboxes; polyorb-2.8~20110207.orig/examples/dsa/mailboxes/hub.adb0000644000175000017500000000460111750740337022207 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- H U B -- -- -- -- B o d y -- -- -- -- Copyright (C) 2009, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ package body Hub is All_Mailboxes : array (0 .. 7) of Mailboxes.Remote_Mailbox; procedure Register_Mailbox (Id : Integer; Ptr : Mailboxes.Remote_Mailbox) is begin All_Mailboxes (Id) := Ptr; end Register_Mailbox; function Get_Mailbox (Id : Integer) return Mailboxes.Remote_Mailbox is begin return All_Mailboxes (Id); end Get_Mailbox; end Hub; polyorb-2.8~20110207.orig/examples/dsa/mailboxes/hub.ads0000644000175000017500000000434611750740337022236 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- H U B -- -- -- -- S p e c -- -- -- -- Copyright (C) 2009, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with Mailboxes; package Hub is pragma Remote_Call_Interface; procedure Register_Mailbox (Id : Integer; Ptr : Mailboxes.Remote_Mailbox); function Get_Mailbox (Id : Integer) return Mailboxes.Remote_Mailbox; end Hub; polyorb-2.8~20110207.orig/examples/dsa/mailboxes/mailboxes-active.adb0000644000175000017500000000475111750740337024673 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- M A I L B O X E S . A C T I V E -- -- -- -- B o d y -- -- -- -- Copyright (C) 2009, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with Ada.Text_IO; use Ada.Text_IO; package body Mailboxes.Active is task body Active_Mailbox is My_Id : Integer; begin accept Start (Id : Integer) do My_Id := Id; end Start; Put_Line ("Active_Mailbox #" & My_Id'Img & " starting"); loop accept Send_Message (Message : Message_Type) do Put_Line ("... got message: " & Message); end Send_Message; end loop; end Active_Mailbox; end Mailboxes.Active; polyorb-2.8~20110207.orig/examples/dsa/mailboxes/server.adb0000644000175000017500000000463511750740337022746 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- S E R V E R -- -- -- -- B o d y -- -- -- -- Copyright (C) 2009, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with Ada.Command_Line; use Ada.Command_Line; with Mailboxes.Active; with Hub; procedure Server is My_Id : constant Integer := Integer'Value (Argument (1)); My_Mailbox : Mailboxes.Active.Active_Mailbox_Acc := new Mailboxes.Active.Active_Mailbox; begin My_Mailbox.Start (My_Id); Hub.Register_Mailbox (Id => My_Id, Ptr => Mailboxes.Remote_Mailbox (My_Mailbox)); end Server; polyorb-2.8~20110207.orig/examples/dsa/mailboxes/client.adb0000644000175000017500000000437611750740337022720 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- C L I E N T -- -- -- -- B o d y -- -- -- -- Copyright (C) 2009, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with Ada.Command_Line; use Ada.Command_Line; with Hub; with Mailboxes; procedure Client is Target : Mailboxes.Remote_Mailbox; begin Target := Hub.Get_Mailbox (Integer'Value (Argument (1))); Target.Send_Message (Argument (2)); end Client; polyorb-2.8~20110207.orig/examples/dsa/bank/0000755000175000017500000000000011750740340017702 5ustar xavierxavierpolyorb-2.8~20110207.orig/examples/dsa/bank/simcity.cfg0000644000175000017500000000206411750740337022054 0ustar xavierxavierconfiguration Simcity is pragma Version (False); -- Don't want to check 'Version. pragma Starter (None); -- Bank_Client and Bank_Server are launched manually. pragma Boot_Location ("tcp", "localhost:5557"); -- Bank_Server service has to be mapped on a given host and a given -- port. Bank_Server : Partition := (Server); -- There is only one RCI package. Note that this RCI package is similar -- to Bank package with only the limited features allowed to a client. Bank_Client : Partition; for Bank_Client'Termination use Local_Termination; -- A client should not wait for the termination of the whole -- distributed application to terminate. procedure Manager is in Bank_Server; procedure Client; for Bank_Client'Main use Client; -- The main subprogram of partition Bank_Client is not a dummy one. -- The zip filter works only on 32 bits machines, don't -- try it on Digital Unix/Alpha. -- Channel_1 : Channel := (Bank_Client, Bank_Server); -- for Channel_1'Filter use "zip"; end Simcity; polyorb-2.8~20110207.orig/examples/dsa/bank/bank.ads0000644000175000017500000000205211750740337021313 0ustar xavierxavierwith Types; use Types; with Server; use Server; package Bank is function Balance (Customer : in Customer_Type; Password : in Password_Type) return Integer; procedure Create (Customer : in Customer_Type; Password : in Password_Type; Deposit : in Positive); procedure Deposit (Customer : in Customer_Type; Amount : in Positive); procedure Register (Terminal : in Terminal_Access; Customer : in Customer_Type; Password : in Password_Type); procedure Transfer (Donator : in Customer_Type; Password : in Password_Type; Amount : in Positive; Customer : in Customer_Type); procedure Withdraw (Customer : in Customer_Type; Password : in Password_Type; Amount : in Positive); function Is_Activated (ID : Customer_ID) return Boolean; function Get_Customer (ID : Customer_ID) return Customer_Type; function Get_Password (ID : Customer_ID) return Password_Type; function Get_Balance (ID : Customer_ID) return Integer; end Bank; polyorb-2.8~20110207.orig/examples/dsa/bank/bank.adb0000644000175000017500000001717211750740337021303 0ustar xavierxavierwith Text_IO; use Text_IO; with Types; use Types; with Server; use Server; with Alarm; use Alarm; package body Bank is Null_Customer : constant Customer_Type := ""; type Customer_Access is access Customer_Type; type Password_Access is access Password_Type; type ID_Type is range 0 .. N_Customer_IDs; Null_ID : Customer_ID := 0; First_ID : Customer_ID := 1; Last_ID : Customer_ID := N_Customer_IDs; function Find (Customer : in Customer_Type) return Customer_ID; protected type Account_Type is function Balance return Integer; function Check (Password : in Password_Type) return Boolean; function Customer return Customer_Type; procedure Deposit (Amount : in Integer); procedure Initialize (Customer : in Customer_Type; Password : in Password_Type; Deposit : in Positive; Available : out Boolean); function Password return Password_Type; procedure Register (Terminal : in Terminal_Access); function Terminal return Terminal_Access; private My_Customer : Customer_Access; My_Password : Password_Access; My_Balance : Integer := 0; My_Terminal : Terminal_Access := null; end Account_Type; ------------------ -- Account_Type -- ------------------ protected body Account_Type is function Balance return Integer is begin return My_Balance; end Balance; function Check (Password : in Password_Type) return Boolean is begin return My_Password /= null and then My_Password.all = Password; end Check; function Customer return Customer_Type is begin if My_Customer = null then return Null_Customer; else return My_Customer.all; end if; end Customer; procedure Deposit (Amount : in Integer) is begin My_Balance := My_Balance + Amount; end Deposit; procedure Initialize (Customer : in Customer_Type; Password : in Password_Type; Deposit : in Positive; Available : out Boolean) is begin if Customer = Null_Customer then raise Wrong_Customer; end if; if My_Customer = null then My_Customer := new Customer_Type'(Customer); My_Password := new Password_Type'(Password); My_Balance := Deposit; Available := True; else Available := False; end if; end Initialize; function Password return Password_Type is begin if My_Customer = null then return ""; else return My_Password.all; end if; end Password; procedure Register (Terminal : in Terminal_Access) is begin My_Terminal := Terminal; end Register; function Terminal return Terminal_Access is begin return My_Terminal; end Terminal; end Account_Type; Accounts : array (First_ID .. Last_ID) of Account_Type; ------------- -- Balance -- ------------- function Balance (Customer : Customer_Type; Password : Password_Type) return Integer is ID : Customer_ID := Find (Customer); Balance : Integer := 0; begin if ID = Null_ID then raise Wrong_Customer; end if; if Accounts (ID).Check (Password) then return Accounts (ID).Balance; else raise Wrong_Password; end if; end Balance; ------------ -- Create -- ------------ procedure Create (Customer : in Customer_Type; Password : in Password_Type; Deposit : in Positive) is Done : Boolean; begin if Find (Customer) /= Null_ID then raise Wrong_Customer; end if; for N in Accounts'range loop Accounts (N).Initialize (Customer, Password, Deposit, Done); if Done then return; end if; end loop; raise No_More_IDs; end Create; --------------- -- Deposit -- --------------- procedure Deposit (Customer : in Customer_Type; Amount : in Positive) is ID : Customer_ID := Find (Customer); begin if ID = Null_ID then raise Wrong_Customer; end if; Accounts (ID).Deposit (Amount); end Deposit; ----------- -- Find -- ----------- function Find (Customer : Customer_Type) return Customer_ID is begin for N in Accounts'range loop if Accounts (N).Customer = Customer then return N; end if; end loop; return Null_ID; end Find; ------------------ -- Get_Customer -- ------------------ function Get_Customer (ID : Customer_ID) return Customer_Type is begin return Accounts (ID).Customer; end Get_Customer; ------------------ -- Get_Password -- ------------------ function Get_Password (ID : Customer_ID) return Password_Type is begin return Accounts (ID).Password; end Get_Password; ----------------- -- Get_Balance -- ----------------- function Get_Balance (ID : Customer_ID) return Integer is begin return Accounts (ID).Balance; end Get_Balance; ------------------ -- Is_Activated -- ------------------ function Is_Activated (ID : Customer_ID) return Boolean is Customer : Customer_Type := Accounts (ID).Customer; begin return Customer /= Null_Customer; end Is_Activated; -------------- -- Register -- -------------- procedure Register (Terminal : in Terminal_Access; Customer : in Customer_Type; Password : in Password_Type) is ID : Customer_ID := Find (Customer); begin if ID = Null_ID then raise Wrong_Customer; end if; if Accounts (ID).Check (Password) then Accounts (ID).Register (Terminal); else raise Wrong_Password; end if; end Register; --------------- -- Transfert -- --------------- procedure Transfer (Donator : in Customer_Type; Password : in Password_Type; Amount : in Positive; Customer : in Customer_Type) is ID_1 : Customer_ID := Find (Donator); ID_2 : Customer_ID := Find (Customer); Term : Terminal_Access; Ok : Boolean := False; begin if ID_1 = Null_ID then raise Wrong_Donator; end if; if ID_2 = Null_ID then raise Wrong_Customer; end if; if Accounts (ID_1).Check (Password) then Accounts (ID_1).Deposit (-Amount); Accounts (ID_2).Deposit (Amount); Term := Accounts (ID_2).Terminal; if Term /= null then begin Notify (Term, Donator, Amount); Ok := True; exception when others => null; end; end if; if not Ok then New_Line; New_Line; Put_Line ("=> Warning: couldn't notify client of a transfer"); New_Line; end if; else raise Wrong_Password; end if; end Transfer; ---------------- -- Withdraw -- ---------------- procedure Withdraw (Customer : in Customer_Type; Password : in Password_Type; Amount : in Positive) is ID : Customer_ID := Find (Customer); begin if ID = Null_ID then raise Wrong_Customer; end if; if Accounts (ID).Check (Password) then Accounts (ID).Deposit (-Amount); else raise Wrong_Password; end if; end Withdraw; end Bank; polyorb-2.8~20110207.orig/examples/dsa/bank/manager.adb0000644000175000017500000001200411750740337021767 0ustar xavierxavierwith Bank; use Bank; with Types; use Types; with Text_IO; use Text_IO; procedure Manager is function Get_Password return Password_Type; function Get_Customer return Customer_Type; function Get_Deposit return Integer; function Get_Customer return Customer_Type is C : Customer_Type (1 .. 16); L : Natural; begin Put ("Customer : "); Get_Line (String (C), L); return C (1 .. L); end Get_Customer; function Get_Password return Password_Type is P : Password_Type (1 .. 8); L : Natural; begin Put ("Password : "); Get_Line (String (P), L); return P (1 .. L); end Get_Password; function Get_Deposit return Integer is D : String (1 .. 8); L : Natural; begin Put ("Deposit : "); Get_Line (String (D), L); return Integer'Value (D (1 .. L)); end Get_Deposit; Request : String (1 .. 16); Length : Natural; Shortcut : Character; begin loop New_Line; Put_Line ("Menu :"); New_Line; Put_Line (" Create"); Put_Line (" Load"); Put_Line (" Print"); Put_Line (" Quit"); Put_Line (" Save"); New_Line; Put ("Request : "); Get_Line (Request, Length); New_Line; if Length > 0 then Shortcut := Request (1); exit when Shortcut = 'Q' or Shortcut = 'q'; case Shortcut is when 'P' | 'p' => Put_Line ("=> Print"); New_Line; for ID in Customer_ID (1) .. Customer_ID (N_Customer_IDs) loop if Is_Activated (ID) then Put (" Customer : "); Put_Line (String (Get_Customer (ID))); Put (" Password : "); Put_Line (String (Get_Password (ID))); Put (" Balance : "); Put_Line (Integer'Image (Get_Balance (ID))); New_Line; end if; end loop; when 'S' | 's' => Put_Line ("=> Save"); New_Line; declare Name : String (1 .. 11); Last : Natural; File : File_Type; begin loop Put ("Filename : "); Get_Line (Name, Last); if Last > 0 then begin Create (File, Out_File, Name (1 .. Last)); exit; exception when others => Put_Line ("File not created"); end; end if; end loop; for ID in Customer_ID (1) .. Customer_ID (N_Customer_IDs) loop if Is_Activated (ID) then Put_Line (File, String (Get_Customer (ID))); Put_Line (File, String (Get_Password (ID))); Put_Line (File, Integer'Image (Get_Balance (ID))); Put_Line (File, "--"); end if; end loop; Close (File); end; when 'C' | 'c' => Put_Line ("=> Create"); begin Create (Get_Customer, Get_Password, Get_Deposit); exception when Wrong_Customer => Put_Line ("Customer already exists"); when Wrong_Password => Put_Line ("Illegal password"); end; when 'L' | 'l' => Put_Line ("=> Load"); declare S1, S2, S3 : String (1 .. 16); L1, L2, L3 : Natural; Name : String (1 .. 11); Last : Natural; File : File_Type; begin loop Put ("Filename : "); Get_Line (Name, Last); if Last > 0 then begin Open (File, In_File, Name (1 .. Last)); exit; exception when others => Put_Line ("File doesn't exist"); end; end if; end loop; while not End_Of_File (File) loop Get_Line (File, S1, L1); Get_Line (File, S2, L2); Get_Line (File, S3, L3); Create (Customer_Type (S1 (1 .. L1)), Password_Type (S2 (1 .. L2)), Integer'Value (S3 (1 .. L3))); Get_Line (File, S1, L1); -- Comments end loop; Close (File); end; when others => Put_Line ("Illegal operation"); end case; end if; end loop; end Manager; polyorb-2.8~20110207.orig/examples/dsa/bank/README0000644000175000017500000000362411750740337020575 0ustar xavierxavierThis example describes a way to develop client / server applications. To provide advanced features, in this example, we had a mechanism of notification. There are three main ada units in this bank example. The "bank" that manages the client accounts, a "manager" which loads the accounts from a small database and provides some utilities and clients which modify their accounts and transfer money from their account to the account of someone else. This is always the same executable for the different clients, but of course, they don't get the same partition id in order to differentiate them. To proove this, the bank server notifies a customer when its account has been granted with money by another customer. -- To play with this example, you can do the following : % gnatdist simcity Open (at least) 3 sessions. [On session 1, starts the scenario, load "example" database and print the account status] % bank_server Menu : Create Load Print Quit Save Request : l => Load Filename : example Menu : Create Load Print Quit Save Request : p => Print Customer : poor Password : xxxx Customer : 25 Customer : middle Password : yyyy Customer : 250 Customer : rich Password : zzzz Customer : 2500 Menu : Create Load Print Quit Save [On session 2, start the poor client] % bank_client Customer : poor Password : xxxx Balance : 25 Menu : Balance Deposit Transfer Withdraw Request : [On session 3, start the rich client and transfer money from rich to poor] % bank_client Customer : rich Password : zzzz Balance : 2500 Menu : Balance Deposit Transfer Withdraw Request : t => Transfer Amount : 1000 Customer : poor Balance : 1500 Menu : Balance Deposit Transfer Withdraw [and then you will realize that on session 2, poor has been notified of the donation] => Receive 1000 from rich polyorb-2.8~20110207.orig/examples/dsa/bank/server.ads0000644000175000017500000000142311750740337021707 0ustar xavierxavierwith Types; use Types; with Alarm; use Alarm; package Server is pragma Remote_Call_Interface; type Terminal_Access is access all Terminal_Type'Class; procedure Register (Terminal : in Terminal_Access; Customer : in Customer_Type; Password : in Password_Type); function Balance (Customer : in Customer_Type; Password : in Password_Type) return Integer; procedure Deposit (Customer : in Customer_Type; Amount : in Positive); procedure Withdraw (Customer : in Customer_Type; Password : in Password_Type; Amount : in Positive); procedure Transfer (Donator : in Customer_Type; Password : in Password_Type; Amount : in Positive; Customer : in Customer_Type); end Server; polyorb-2.8~20110207.orig/examples/dsa/bank/notify.ads0000644000175000017500000000051111750740337021706 0ustar xavierxavierwith Types; use Types; package Alarm is pragma Pure; type Terminal_Type is abstract tagged limited private; procedure Notify (Terminal : access Grant_Type; Donator : in Customer_Type; Amount : in Integer) is abstract; private type Grant_Type is abstract tagged limited null record; end Notify; polyorb-2.8~20110207.orig/examples/dsa/bank/alarm.ads0000644000175000017500000000051611750740337021477 0ustar xavierxavierwith Types; use Types; package Alarm is pragma Pure; type Terminal_Type is abstract tagged limited private; procedure Notify (Terminal : access Terminal_Type; Donator : in Customer_Type; Amount : in Integer) is abstract; private type Terminal_Type is abstract tagged limited null record; end Alarm; polyorb-2.8~20110207.orig/examples/dsa/bank/example0000644000175000017500000000007011750740337021263 0ustar xavierxavierpoor xxxx 25 -- middle yyyy 250 -- rich zzzz 2500 -- polyorb-2.8~20110207.orig/examples/dsa/bank/terminal.ads0000644000175000017500000000015111750740337022211 0ustar xavierxavierwith Message; use Message; package Terminal is My_Terminal : aliased Alarm_Terminal; end Terminal; polyorb-2.8~20110207.orig/examples/dsa/bank/message.adb0000644000175000017500000000065211750740337022007 0ustar xavierxavierwith Types; use Types; with Text_Io; use Text_Io; with Alarm; use Alarm; package body Message is procedure Notify (Terminal : access Alarm_Terminal; Donator : in Customer_Type; Amount : in Integer) is begin New_Line; New_Line; Put ("=> Receive"); Put (Integer'Image (Amount)); Put (" from "); Put (String (Donator)); New_Line; end Notify; end Message; polyorb-2.8~20110207.orig/examples/dsa/bank/server.adb0000644000175000017500000000204311750740337021665 0ustar xavierxavierwith Bank; use Bank; package body Server is function Balance (Customer : in Customer_Type; Password : in Password_Type) return Integer is begin return Bank.Balance (Customer, Password); end Balance; procedure Deposit (Customer : in Customer_Type; Amount : in Positive) is begin Bank.Deposit (Customer, Amount); end Deposit; procedure Register (Terminal : in Terminal_Access; Customer : in Customer_Type; Password : in Password_Type) is begin Bank.Register (Terminal, Customer, Password); end Register; procedure Transfer (Donator : in Customer_Type; Password : in Password_Type; Amount : in Positive; Customer : in Customer_Type) is begin Bank.Transfer (Donator, Password, Amount, Customer); end Transfer; procedure Withdraw (Customer : in Customer_Type; Password : in Password_Type; Amount : in Positive) is begin Bank.Withdraw (Customer, Password, Amount); end Withdraw; end Server; polyorb-2.8~20110207.orig/examples/dsa/bank/message.ads0000644000175000017500000000044611750740337022031 0ustar xavierxavierwith Alarm; use Alarm; with Types; use Types; package Message is pragma Remote_Types; type Alarm_Terminal is new Terminal_Type with null record; procedure Notify (Terminal : access Alarm_Terminal; Donator : in Customer_Type; Amount : in Integer); end Message; polyorb-2.8~20110207.orig/examples/dsa/bank/client.adb0000644000175000017500000000612611750740337021643 0ustar xavierxavierwith Server; use Server; with Types; use Types; with Text_IO; use Text_IO; with Message; use Message; with Terminal; use Terminal; procedure Client is function Get_Password return Password_Type; function Get_Customer return Customer_Type; function Get_Customer return Customer_Type is C : Customer_Type (1 .. 16); L : Natural; begin Put ("Customer : "); Get_Line (String (C), L); return C (1 .. L); end Get_Customer; function Get_Password return Password_Type is P : Password_Type (1 .. 8); L : Natural; begin Put ("Password : "); Get_Line (String (P), L); return P (1 .. L); end Get_Password; Customer : Customer_Type := Get_Customer; Password : Password_Type := Get_Password; Request : String (1 .. 16); Length : Natural; Balance : Integer; Shortcut : Character; Amount : Integer; begin Register (My_Terminal'Access, Customer, Password); loop New_Line; Balance := Server.Balance (Customer, Password); Put_Line ("Balance :" & Integer'Image (Balance)); New_Line; Put_Line ("Menu :"); New_Line; Put_Line (" Balance"); Put_Line (" Deposit"); Put_Line (" Quit"); Put_Line (" Transfer"); Put_Line (" Withdraw"); New_Line; Put ("Request : "); Get_Line (Request, Length); New_Line; if Length > 0 then Shortcut := Request (1); case Shortcut is when 'B' | 'b' => null; when 'D' | 'd' => Put_Line ("=> Deposit"); New_Line; Put (" Amount : "); Get_Line (Request, Length); Amount := Integer'Value (Request (1 .. Length)); Deposit (Customer, Amount); when 'T' | 't' => Put_Line ("=> Transfer"); New_Line; Put (" Amount : "); Get_Line (Request, Length); Amount := Integer'Value (Request (1 .. Length)); Put (" Customer : "); Get_Line (Request, Length); begin Transfer (Customer, Password, Amount, Customer_Type (Request (1 .. Length))); exception when Wrong_Donator => Put ("Wrong Donator "); Put_Line (Request (1 .. Length)); end; when 'W' | 'w' => Put_Line ("=> Withdraw"); New_Line; Put (" Amount : "); Get_Line (Request, Length); Amount := Integer'Value (Request (1 .. Length)); Withdraw (Customer, Password, Amount); when 'Q' | 'q'=> exit; when others => Put_Line ("Illegal operation"); end case; end if; end loop; exception when Wrong_Customer => Put ("Wrong customer "); Put_Line (String (Customer)); when Wrong_Password => Put ("Wrong Password "); Put_Line (String (Password)); end Client; polyorb-2.8~20110207.orig/examples/dsa/bank/types.ads0000644000175000017500000000052411750740337021546 0ustar xavierxavierpackage Types is pragma Pure; N_Customer_IDs : constant := 20; type Customer_ID is range 0 .. N_Customer_IDs; subtype Customer_Type is String; subtype Password_Type is String; Wrong_Password : exception; Wrong_Customer : exception; Wrong_Donator : exception; No_More_IDs : exception; end Types; polyorb-2.8~20110207.orig/examples/polyorb/0000755000175000017500000000000011750740340017706 5ustar xavierxavierpolyorb-2.8~20110207.orig/examples/polyorb/polyorb-test_object_soa.adb0000644000175000017500000001747711750740337025237 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . T E S T _ O B J E C T _ S O A -- -- -- -- B o d y -- -- -- -- Copyright (C) 2002-2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with Ada.Exceptions; with Ada.Text_IO; with PolyORB.Any.NVList; with PolyORB.Tasking.Threads; package body PolyORB.Test_Object_SOA is use Ada.Text_IO; use PolyORB.Any; use PolyORB.Requests; -------------------------------------- -- Application part of the servant. -- -------------------------------------- function waitAndEchoString (O : My_Object; S : Types.String; T : Types.Long) return Types.String is pragma Warnings (Off); pragma Unreferenced (O); pragma Warnings (On); begin Put_Line ("waitAndEchoString is being executed with arguments " & To_Standard_String (S) & Integer'Image (Integer (T))); -- delay (Duration (T)); -- XXX Relative delay forbidden under pragma Ravenscar. return S; end waitAndEchoString; function echoString (O : My_Object; S : Types.String) return Types.String is pragma Warnings (Off); pragma Unreferenced (O); pragma Warnings (On); begin Put_Line ("echoString is being executed with argument: " & To_Standard_String (S)); return S; end echoString; function echoInteger (O : My_Object; I : Types.Long) return Types.Long is pragma Warnings (Off); pragma Unreferenced (O); pragma Warnings (On); begin Put_Line ("Echo_Integer is being executed with argument" & Types.Long'Image (I)); return I; end echoInteger; -------------------------------------------------------------- -- "Middleware glue" that should be generated automatically -- -------------------------------------------------------------- function Execute_Servant (Obj : not null access My_Object; Req : Requests.Request_Access) return Boolean is use PolyORB.Any.NVList; use PolyORB.Any.NVList.Internals; use PolyORB.Any.NVList.Internals.NV_Lists; It : Iterator := First (List_Of (Req.Args).all); begin Put_Line ("Handle Message : enter"); Put_Line ("The server is executing the request:" & PolyORB.Requests.Image (Req.all)); if Req.Operation.all = "echoString" then declare echoString_Arg : constant Types.String := From_Any (Value (It).Argument); begin Put_Line ("Echoing in task " & PolyORB.Tasking.Threads.Image (PolyORB.Tasking.Threads.Current_Task)); Req.Result.Argument := To_Any (echoString (Obj.all, echoString_Arg)); Put_Line ("Result: " & Image (Req.Result)); end; elsif Req.Operation.all = "waitAndEchoString" then declare Arg1, Arg2 : Element_Access; begin Arg1 := Value (It); Next (It); Arg2 := Value (It); Req.Result.Argument := To_Any (waitAndEchoString (Obj.all, From_Any (Arg1.Argument), From_Any (Arg2.Argument))); Put_Line ("Result: " & Image (Req.Result)); end; elsif Req.Operation.all = "echoInteger" then declare echoInteger_Arg : constant Types.Long := From_Any (Value (It).Argument); begin Req.Result.Argument := To_Any (echoInteger (Obj.all, echoInteger_Arg)); Put_Line ("Result: " & Image (Req.Result)); end; else raise Program_Error; end if; return True; exception when E : others => Put_Line ("Handle_Message: Got exception " & Ada.Exceptions.Exception_Information (E)); raise; end Execute_Servant; function Get_Parameter_Profile (Method : String) return Any.NVList.Ref; function Get_Result_Profile (Method : String) return Any.Any; function Get_Parameter_Profile (Method : String) return Any.NVList.Ref is use Any.NVList; Result : Any.NVList.Ref; begin Any.NVList.Create (Result); Put_Line ("Parameter profile for " & Method & " requested."); if Method = "echoString" then Add_Item (Result, (Name => To_PolyORB_String ("S"), Argument => Get_Empty_Any (TypeCode.TC_String), Arg_Modes => ARG_IN)); elsif Method = "echoInteger" then Add_Item (Result, (Name => To_PolyORB_String ("I"), Argument => Get_Empty_Any (TypeCode.TC_Long), Arg_Modes => ARG_IN)); elsif Method = "waitAndEchoString" then Add_Item (Result, (Name => To_PolyORB_String ("S"), Argument => Get_Empty_Any (TypeCode.TC_String), Arg_Modes => ARG_IN)); Add_Item (Result, (Name => To_PolyORB_String ("I"), Argument => Get_Empty_Any (TypeCode.TC_Long), Arg_Modes => ARG_IN)); else raise Program_Error; end if; return Result; end Get_Parameter_Profile; function Get_Result_Profile (Method : String) return Any.Any is begin Put_Line ("Result profile for " & Method & " requested."); if Method = "echoString" then return Get_Empty_Any (TypeCode.TC_String); elsif Method = "echoInteger" then return Get_Empty_Any (TypeCode.TC_Long); elsif Method = "waitAndEchoString" then return Get_Empty_Any (TypeCode.TC_String); else raise Program_Error; end if; end Get_Result_Profile; function If_Desc return Obj_Adapters.Simple.Interface_Description is begin return (PP_Desc => Get_Parameter_Profile'Access, RP_Desc => Get_Result_Profile'Access); end If_Desc; end PolyORB.Test_Object_SOA; polyorb-2.8~20110207.orig/examples/polyorb/polyorb-test-thread_pool_poa.adb0000644000175000017500000000520311750740337026164 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . T E S T . T H R E A D _ P O O L _ P O A -- -- -- -- B o d y -- -- -- -- Copyright (C) 2002-2005 Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- Set up a test server with the Thread_Pool tasking policy. with PolyORB.Initialization; with PolyORB.Setup.Test_SOA; with PolyORB.Setup.Test_POA; with PolyORB.ORB.Thread_Pool; pragma Warnings (Off, PolyORB.ORB.Thread_Pool); with PolyORB.ORB_Controller.Workers; pragma Warnings (Off, PolyORB.ORB_Controller.Workers); with PolyORB.Setup.Tasking.Full_Tasking; pragma Warnings (Off, PolyORB.Setup.Tasking.Full_Tasking); procedure PolyORB.Test.Thread_Pool_POA is begin PolyORB.Initialization.Initialize_World; PolyORB.Setup.Test_POA.Initialize_Test_Object; PolyORB.Setup.Test_SOA.Run_Test; end PolyORB.Test.Thread_Pool_POA; polyorb-2.8~20110207.orig/examples/polyorb/README0000644000175000017500000000033611750740337020576 0ustar xavierxavierREADME for the PolyORB examples ------------------------------------- $Id: README 35435 2003-12-09 21:04:54Z hugues $ This directory contains examples of servants built directly on top of the PolyORB neutral core layer. polyorb-2.8~20110207.orig/examples/polyorb/Makefile.local0000644000175000017500000000000011750740337022433 0ustar xavierxavierpolyorb-2.8~20110207.orig/examples/polyorb/polyorb-test.ads0000644000175000017500000000414611750740337023055 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . T E S T -- -- -- -- S p e c -- -- -- -- Copyright (C) 2002 Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by ACT Europe. -- -- (email: sales@act-europe.fr) -- -- -- ------------------------------------------------------------------------------ -- Root unit for all unit tests. package PolyORB.Test is pragma Pure; end PolyORB.Test; polyorb-2.8~20110207.orig/examples/polyorb/polyorb-test_object_poa.adb0000644000175000017500000001245711750740337025225 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . T E S T _ O B J E C T _ P O A -- -- -- -- B o d y -- -- -- -- Copyright (C) 2002-2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with Ada.Exceptions; with Ada.Text_IO; with PolyORB.Any; with PolyORB.Any.NVList; with PolyORB.Errors; package body PolyORB.Test_Object_POA is use Ada.Text_IO; use PolyORB.Any; use PolyORB.Requests; -------------------------------------- -- Application part of the servant. -- -------------------------------------- function echoString (O : My_Object; S : PolyORB.Types.String) return PolyORB.Types.String is pragma Warnings (Off); pragma Unreferenced (O); pragma Warnings (On); begin Put_Line ("echoString is being executed with argument: " & PolyORB.Types.To_Standard_String (S)); return S; end echoString; function echoInteger (O : My_Object; I : PolyORB.Types.Long) return PolyORB.Types.Long is pragma Warnings (Off); pragma Unreferenced (O); pragma Warnings (On); begin Put_Line ("Echo_Integer is being executed with argument" & I'Img); return I; end echoInteger; -------------------------------------------------------------- -- "Middleware glue" that should be generated automatically -- -------------------------------------------------------------- function Execute_Servant (Obj : not null access My_Object; Req : Requests.Request_Access) return Boolean is use PolyORB.Any.NVList; use PolyORB.Any.NVList.Internals; use PolyORB.Any.NVList.Internals.NV_Lists; use PolyORB.Errors; use PolyORB.Types; Args : PolyORB.Any.NVList.Ref; Error : Error_Container; begin Put_Line ("Handle Message : enter"); Put_Line ("The server is executing the request:" & PolyORB.Requests.Image (Req.all)); Create (Args); if Req.Operation.all = "echoString" then Add_Item (Args, (Name => To_PolyORB_String ("S"), Argument => Get_Empty_Any (TypeCode.TC_String), Arg_Modes => PolyORB.Any.ARG_IN)); Arguments (Req, Args, Error); if Found (Error) then raise Program_Error; -- XXX We should do something more constructive end if; Req.Result.Argument := To_Any (echoString (Obj.all, From_Any (Value (First (List_Of (Args).all)).Argument))); Put_Line ("Result: " & Image (Req.Result)); elsif Req.Operation.all = "echoInteger" then Add_Item (Args, (Name => To_PolyORB_String ("I"), Argument => Get_Empty_Any (TypeCode.TC_Long), Arg_Modes => PolyORB.Any.ARG_IN)); Arguments (Req, Args, Error); if Found (Error) then raise Program_Error; -- XXX We should do something more constructive end if; Req.Result.Argument := To_Any (echoInteger (Obj.all, From_Any (Value (First (List_Of (Args).all)).Argument))); Put_Line ("Result: " & Image (Req.Result)); else raise Program_Error; end if; return True; exception when E : others => Put_Line ("Handle_Message: Got exception " & Ada.Exceptions.Exception_Information (E)); raise; end Execute_Servant; end PolyORB.Test_Object_POA; polyorb-2.8~20110207.orig/examples/polyorb/polyorb-test-no_tasking_poa.adb0000644000175000017500000000516411750740337026026 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . T E S T . N O _ T A S K I N G _ P O A -- -- -- -- B o d y -- -- -- -- Copyright (C) 2002-2004 Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by ACT Europe. -- -- (email: sales@act-europe.fr) -- -- -- ------------------------------------------------------------------------------ -- Setup a test server with no tasking at all. with PolyORB.Initialization; with PolyORB.Setup.Test_SOA; with PolyORB.Setup.Test_POA; with PolyORB.ORB.No_Tasking; pragma Warnings (Off, PolyORB.ORB.No_Tasking); with PolyORB.ORB_Controller.No_Tasking; pragma Warnings (Off, PolyORB.ORB_Controller.No_Tasking); with PolyORB.Setup.Tasking.No_Tasking; pragma Warnings (Off, PolyORB.Setup.Tasking.No_Tasking); procedure PolyORB.Test.No_Tasking_POA is begin PolyORB.Initialization.Initialize_World; PolyORB.Setup.Test_POA.Initialize_Test_Object; PolyORB.Setup.Test_SOA.Run_Test; end PolyORB.Test.No_Tasking_POA; polyorb-2.8~20110207.orig/examples/polyorb/polyorb-test-no_tasking.adb0000644000175000017500000000510011750740337025155 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . T E S T . N O _ T A S K I N G -- -- -- -- B o d y -- -- -- -- Copyright (C) 2002-2004 Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by ACT Europe. -- -- (email: sales@act-europe.fr) -- -- -- ------------------------------------------------------------------------------ -- Setup a test server with no tasking at all. with PolyORB.Initialization; with PolyORB.Setup.Test_SOA; with PolyORB.ORB.No_Tasking; pragma Warnings (Off, PolyORB.ORB.No_Tasking); with PolyORB.ORB_Controller.No_Tasking; pragma Warnings (Off, PolyORB.ORB_Controller.No_Tasking); with PolyORB.Setup.Tasking.No_Tasking; pragma Warnings (Off, PolyORB.Setup.Tasking.No_Tasking); procedure PolyORB.Test.No_Tasking is use PolyORB.Setup.Test_SOA; begin PolyORB.Initialization.Initialize_World; Initialize_Test_Object; Run_Test; end PolyORB.Test.No_Tasking; polyorb-2.8~20110207.orig/examples/polyorb/polyorb-setup-test_soa.ads0000644000175000017500000000526311750740337025056 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . S E T U P . T E S T _ S O A -- -- -- -- S p e c -- -- -- -- Copyright (C) 2002 Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by ACT Europe. -- -- (email: sales@act-europe.fr) -- -- -- ------------------------------------------------------------------------------ -- Set up a test ORB. with PolyORB.References; with PolyORB.Smart_Pointers; pragma Warnings (Off, PolyORB.Smart_Pointers); -- The dependency and pragma above should not be necessary -- (because of the dependency and pragma on PolyORB.References, -- which has Smart_Pointers in its closure). They are necessary to -- work around a bug in GNAT 3.15. package PolyORB.Setup.Test_SOA is pragma Elaborate_Body; procedure Initialize_Test_Object; -- Create the test object implementation. My_Ref : PolyORB.References.Ref; -- Object reference designating the created test object. procedure Run_Test; -- Execute the test server. end PolyORB.Setup.Test_SOA; polyorb-2.8~20110207.orig/examples/polyorb/polyorb-setup-test.ads0000644000175000017500000000417511750740337024215 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . S E T U P . T E S T -- -- -- -- S p e c -- -- -- -- Copyright (C) 2002 Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by ACT Europe. -- -- (email: sales@act-europe.fr) -- -- -- ------------------------------------------------------------------------------ -- Root unit for all unit tests. package PolyORB.Setup.Test is pragma Preelaborate; end PolyORB.Setup.Test; polyorb-2.8~20110207.orig/examples/polyorb/polyorb-test_object_poa.ads0000644000175000017500000000517611750740337025246 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . T E S T _ O B J E C T _ P O A -- -- -- -- S p e c -- -- -- -- Copyright (C) 2002-2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- A simple test server object that uses the POA. with PolyORB.Requests; with PolyORB.Servants; with PolyORB.Types; package PolyORB.Test_Object_POA is pragma Elaborate_Body; type My_Object is new PolyORB.Servants.Servant with null record; function echoString (O : My_Object; S : PolyORB.Types.String) return PolyORB.Types.String; function echoInteger (O : My_Object; I : PolyORB.Types.Long) return PolyORB.Types.Long; overriding function Execute_Servant (Obj : not null access My_Object; Req : Requests.Request_Access) return Boolean; end PolyORB.Test_Object_POA; polyorb-2.8~20110207.orig/examples/polyorb/polyorb-test-thread_pool.adb0000644000175000017500000000512011750740337025323 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . T E S T . T H R E A D _ P O O L -- -- -- -- B o d y -- -- -- -- Copyright (C) 2002-2005 Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- Set up a test server with the Thread_Pool tasking policy. with PolyORB.Initialization; with PolyORB.Setup.Test_SOA; with PolyORB.ORB.Thread_Pool; pragma Warnings (Off, PolyORB.ORB.Thread_Pool); with PolyORB.ORB_Controller.Workers; pragma Warnings (Off, PolyORB.ORB_Controller.Workers); with PolyORB.Setup.Tasking.Full_Tasking; pragma Warnings (Off, PolyORB.Setup.Tasking.Full_Tasking); procedure PolyORB.Test.Thread_Pool is use PolyORB.Setup.Test_SOA; begin PolyORB.Initialization.Initialize_World; Initialize_Test_Object; Run_Test; end PolyORB.Test.Thread_Pool; polyorb-2.8~20110207.orig/examples/polyorb/polyorb-setup-test_poa.adb0000644000175000017500000001176111750740337025032 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . S E T U P . T E S T _ P O A -- -- -- -- B o d y -- -- -- -- Copyright (C) 2002-2005 Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- A variant of the test setup that uses a POA instead of an SOA. with Ada.Exceptions; with Ada.Text_IO; with PolyORB.Test_Object_POA; with PolyORB.Errors; with PolyORB.Obj_Adapters; with PolyORB.Objects; with PolyORB.Servants; with PolyORB.ORB; with PolyORB.POA; with PolyORB.POA.Basic_POA; with PolyORB.POA_Config; with PolyORB.POA_Config.Root_POA; with PolyORB.POA_Manager; with PolyORB.POA_Types; with PolyORB.References; with PolyORB.References.IOR; with PolyORB.Types; with PolyORB.Setup.Test_SOA; package body PolyORB.Setup.Test_POA is use Ada.Text_IO; use PolyORB.Errors; use PolyORB.ORB; use PolyORB.POA.Basic_POA; use PolyORB.Test_Object_POA; use PolyORB.Setup.Test_SOA; My_Servant : PolyORB.Servants.Servant_Access; Obj_Adapter : PolyORB.POA_Types.Obj_Adapter_Access; ---------------------------- -- Initialize_Test_Object -- ---------------------------- procedure Initialize_Test_Object is My_Id : Objects.Object_Id_Access; URI : PolyORB.Types.String; Error : Error_Container; begin Put_Line ("Initializing OA configuration... "); PolyORB.POA_Config.Set_Configuration (new PolyORB.POA_Config.Root_POA.Root_POA_Configuration); Put_Line ("Creating object adapter... "); Obj_Adapter := new POA.Basic_POA.Basic_Obj_Adapter; POA.Basic_POA.Create (Basic_Obj_Adapter (Obj_Adapter.all)'Access); -- Create object adapter Set_Object_Adapter (The_ORB, PolyORB.Obj_Adapters.Obj_Adapter_Access (Obj_Adapter)); -- Link object adapter with ORB. My_Servant := new PolyORB.Test_Object_POA.My_Object; -- Create application server object. PolyORB.POA_Manager.Activate (PolyORB.POA_Manager.POAManager_Access (PolyORB.POA_Manager.Entity_Of (POA.Obj_Adapter (Obj_Adapter.all).POA_Manager)), Error); PolyORB.Obj_Adapters.Export (Obj_Adapters.Obj_Adapter_Access (Obj_Adapter), My_Servant, null, My_Id, Error); -- Register it with the POA. if Found (Error) then raise Program_Error; end if; Put_Line ("Registered object: " & PolyORB.Objects.Image (My_Id.all)); Create_Reference (The_ORB, My_Id, "IDL:Echo:1.0", My_Ref); -- Obtain object reference. Put_Line ("Reference is : " & References.Image (My_Ref)); PolyORB.POA_Types.Oid_To_Rel_URI (Obj_Adapter, My_Id, URI, Error); if Found (Error) then raise Program_Error; end if; Put_Line ("URI is : " & PolyORB.Types.To_Standard_String (URI)); begin Put_Line ("IOR is : " & PolyORB.References.IOR.Object_To_String (My_Ref)); exception when E : others => Put_Line ("Warning: Object_To_String raised:"); Put_Line (Ada.Exceptions.Exception_Information (E)); end; Put_Line (" done."); end Initialize_Test_Object; end PolyORB.Setup.Test_POA; polyorb-2.8~20110207.orig/examples/polyorb/polyorb-setup-test_poa.ads0000644000175000017500000000431711750740337025052 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . S E T U P . T E S T _ P O A -- -- -- -- S p e c -- -- -- -- Copyright (C) 2002 Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by ACT Europe. -- -- (email: sales@act-europe.fr) -- -- -- ------------------------------------------------------------------------------ -- A variant of the test setup that uses a POA instead of -- an SOA. package PolyORB.Setup.Test_POA is pragma Elaborate_Body; procedure Initialize_Test_Object; end PolyORB.Setup.Test_POA; polyorb-2.8~20110207.orig/examples/polyorb/polyorb-setup-test_soa.adb0000644000175000017500000001366311750740337025040 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . S E T U P . T E S T _ S O A -- -- -- -- B o d y -- -- -- -- Copyright (C) 2002-2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- Set up a test ORB. with Ada.Exceptions; with Ada.Text_IO; with PolyORB.Any.ExceptionList; with PolyORB.Any.NVList; with PolyORB.Components; with PolyORB.Errors; with PolyORB.Obj_Adapters.Simple; with PolyORB.Objects; with PolyORB.ORB.Iface; with PolyORB.References.IOR; with PolyORB.Requests; with PolyORB.Servants; with PolyORB.Types; with PolyORB.Utils.Report; -- Our application object. with PolyORB.Test_Object_SOA; package body PolyORB.Setup.Test_SOA is use Ada.Text_IO; use PolyORB.Errors; use PolyORB.Objects; use PolyORB.ORB; use PolyORB.Utils.Report; Obj_Adapter : Obj_Adapters.Obj_Adapter_Access; My_Servant : Servants.Servant_Access; ---------------------------- -- Initialize_Test_Object -- ---------------------------- procedure Initialize_Test_Object is My_Id : Object_Id_Access; Error : Error_Container; begin ---------------------------------- -- Create simple object adapter -- ---------------------------------- Obj_Adapter := new Obj_Adapters.Simple.Simple_Obj_Adapter; Obj_Adapters.Create (Obj_Adapter); -- Create object adapter Set_Object_Adapter (The_ORB, Obj_Adapter); -- Link object adapter with ORB. Output ("Created object adapter", True); My_Servant := new Test_Object_SOA.My_Object; -- Create application server object. Obj_Adapters.Export (Obj_Adapter, My_Servant, null, My_Id, Error); -- Register it with the SOA. if Found (Error) then raise Program_Error; end if; Obj_Adapters.Simple.Set_Interface_Description (Obj_Adapters.Simple.Simple_Obj_Adapter (Obj_Adapter.all), My_Id, Test_Object_SOA.If_Desc); -- Set object description. Create_Reference (The_ORB, My_Id, "IDL:Echo:1.0", My_Ref); Output ("Registered object: " & Image (My_Id.all), True); Put_Line ("Reference is : " & References.Image (My_Ref)); begin Put_Line ("IOR is : " & PolyORB.References.IOR.Object_To_String (My_Ref)); exception when E : others => Put_Line ("Warning: Object_To_String raised:"); Put_Line (Ada.Exceptions.Exception_Information (E)); end; end Initialize_Test_Object; -------------- -- Run_Test -- -------------- procedure Run_Test is begin --------------------------------------- -- Create a local request to the ORB -- --------------------------------------- declare use PolyORB.Any; use PolyORB.Any.NVList; use PolyORB.Components; use PolyORB.ORB.Iface; use PolyORB.Requests; use PolyORB.Types; Req : Request_Access; Args : Any.NVList.Ref; Result : Any.NamedValue; procedure Create_echoString_Request (Arg1 : String); procedure Create_echoString_Request (Arg1 : String) is begin Create (Args); Add_Item (Args, To_PolyORB_String ("echoString"), To_Any (Arg1), ARG_IN); Create_Request (My_Ref, "echoString", Args, Result, PolyORB.Any.ExceptionList.Nil_Ref, Req); Output ("Created servant request", True); Emit_No_Reply (Component_Access (The_ORB), Queue_Request'(Request => Req, Requestor => null)); end Create_echoString_Request; begin for J in 1 .. 4 loop Create_echoString_Request ("request number" & J'Img); end loop; -- Execute the ORB main loop Run (The_ORB, Request => Req, May_Exit => True); End_Report; end; end Run_Test; end PolyORB.Setup.Test_SOA; polyorb-2.8~20110207.orig/examples/polyorb/local.gpr0000644000175000017500000000105411750740337021520 0ustar xavierxavierwith "polyorb", "polyorb_test_common"; project local is Dir := external ("Test_Dir"); Obj_Dir := PolyORB_Test_Common.Build_Dir & Dir; for Object_Dir use Obj_Dir; for Source_Dirs use (Obj_Dir, PolyORB_Test_Common.Source_Dir & Dir); package Compiler is for Default_Switches ("Ada") use PolyORB_Test_Common.Compiler'Default_Switches ("Ada"); end Compiler; for Main use ("polyorb-test-no_tasking.adb", "polyorb-test-thread_pool.adb", "polyorb-test-no_tasking_poa.adb", "polyorb-test-thread_pool_poa.adb"); end local; polyorb-2.8~20110207.orig/examples/polyorb/polyorb-test_object_soa.ads0000644000175000017500000000557311750740337025252 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . T E S T _ O B J E C T _ S O A -- -- -- -- S p e c -- -- -- -- Copyright (C) 2002-2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- A simple test server object that uses the SOA. with PolyORB.Obj_Adapters.Simple; with PolyORB.Requests; with PolyORB.Servants; with PolyORB.Types; package PolyORB.Test_Object_SOA is pragma Elaborate_Body; use PolyORB.Types; type My_Object is new PolyORB.Servants.Servant with null record; function waitAndEchoString (O : My_Object; S : Types.String; T : Types.Long) return Types.String; function echoString (O : My_Object; S : Types.String) return Types.String; function echoInteger (O : My_Object; I : Types.Long) return Types.Long; overriding function Execute_Servant (Obj : not null access My_Object; Req : Requests.Request_Access) return Boolean; function If_Desc return Obj_Adapters.Simple.Interface_Description; pragma Inline (If_Desc); end PolyORB.Test_Object_SOA; polyorb-2.8~20110207.orig/examples/bbs/0000755000175000017500000000000011750740340016766 5ustar xavierxavierpolyorb-2.8~20110207.orig/examples/bbs/common.idl0000644000175000017500000000042311750740337020755 0ustar xavierxaviermodule DSA_Common { interface Penpal_Type; interface Penpal_Type { #pragma ID DSA_Common::Penpal_Type "DSA:COMMON.PENPAL_TYPE:1.0" void initialize (in string Name); string name_of (); void new_message (in string Sender, in string Message); }; }; polyorb-2.8~20110207.orig/examples/bbs/bbs.cfg0000644000175000017500000000121511750740337020222 0ustar xavierxavierconfiguration BBS is pragma Starter (None); pragma Boot_Server ("tcp", "localhost:4161"); SimpleP : Partition := (); procedure Simple; for SimpleP'Main use Simple; for SimpleP'Termination use Local_Termination; ServerP : Partition := (Server); procedure Do_Nothing is in ServerP; for ServerP'Termination use Deferred_Termination; ProxyP : Partition := (); procedure Proxy_Main; for ProxyP'Main use Proxy_Main; for ProxyP'Termination use Local_Termination; EvolutedP : Partition := (); procedure Evoluted; for EvolutedP'Main use Evoluted; for EvolutedP'Termination use Local_Termination; end BBS; polyorb-2.8~20110207.orig/examples/bbs/common.ads0000644000175000017500000000661211750740337020762 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- C O M M O N -- -- -- -- S p e c -- -- -- -- Copyright (C) 2002-2008, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by ACT Europe. -- -- (email: sales@act-europe.fr) -- -- -- ------------------------------------------------------------------------------ with Ada.Streams; package Common is pragma Remote_Types; type Penpal_Type is tagged limited private; -- One particular person procedure Initialize (Penpal : in out Penpal_Type; Name : String); -- Initialize a Penpal name. This will raise Sender_Error if the -- Name is empty. You must register this penpal to get new incoming -- messages. function Name_Of (Penpal : access Penpal_Type) return String; -- Return the name of a Penpal, or raise Sender_Error if the name -- has not been set. procedure New_Message (Sender : String; Recipient : access Penpal_Type; Message : String); -- This procedure will be called when the penpal has registered itself -- and a new message arrives on the BBS. Sender_Error or Message_Error -- will be raised if Sender or Message are empty. private type String_Access is access String; type Penpal_Type is tagged limited record Name : String_Access; end record; -- Legality stuff that allows a penpal name to be transferred over the -- network if needed. procedure Read (Stream : access Ada.Streams.Root_Stream_Type'Class; Penpal : out String_Access); procedure Write (Stream : access Ada.Streams.Root_Stream_Type'Class; Penpal : String_Access); for String_Access'Read use Read; for String_Access'Write use Write; end Common; polyorb-2.8~20110207.orig/examples/bbs/Makefile.local0000644000175000017500000000026611750740337021531 0ustar xavierxavier${current_dir}bbs.idl-stamp: idlac_flags := ${test_target}: ${current_dir}bbs.idl-stamp ${current_dir}common.idl-stamp: idlac_flags := ${test_target}: ${current_dir}common.idl-stamp polyorb-2.8~20110207.orig/examples/bbs/server.ads0000644000175000017500000000720611750740337021000 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- S E R V E R -- -- -- -- S p e c -- -- -- -- Copyright (C) 2002-2008, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by ACT Europe. -- -- (email: sales@act-europe.fr) -- -- -- ------------------------------------------------------------------------------ with Common; use Common; package Server is pragma Remote_Call_Interface; -- This package can be called remotely procedure Post_Message (Sender : String; Message : String); -- Add a message to the BBS service. Sender_Error will be raised if the -- sender's name is empty, Message_Error if the message is empty. function Number_Of_Messages return Natural; -- Return a number of messages that were posted to the BBS function Get_Sender (N : Positive) return String; -- Return the name of the sender of a particular message. No_Such_Message -- will be raised if there is no such message. function Get_Message (N : Positive) return String; -- Return the content of a particular message. No_Such_Message will be -- raised if there is no such message. type Penpal_Pointer is access all Penpal_Type'Class; -- A Penpal_Pointer can designated any descendent of the Penpal_Type type procedure Register (Penpal : Penpal_Pointer); -- Register a penpal in the connected users database. Sender_Error will -- be raised if the penpal has not been correctly initialized. If a -- penpal with this name has been registered already, then it will be -- replaced with the new one (to cover the case where a penpal moves -- to another machine for example). function Get_Penpal (Name : String) return Penpal_Pointer; -- Return the object representing a penpal of a given type, or raise -- No_Such_Penpal if no penpal by this name has been registered. procedure Broadcast (Sender : String; Message : String); -- Broadcast a message to every registered penpal end Server; polyorb-2.8~20110207.orig/examples/bbs/simplep.adb0000644000175000017500000000433111750740337021116 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- S I M P L E P -- -- -- -- B o d y -- -- -- -- Copyright (C) 2002 Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by ACT Europe. -- -- (email: sales@act-europe.fr) -- -- -- ------------------------------------------------------------------------------ with PolyORB.Initialization; with PolyORB.Setup.Client; pragma Warnings (Off, PolyORB.Setup.Client); with Simple; procedure SimpleP is begin PolyORB.Initialization.Initialize_World; Simple; end SimpleP; polyorb-2.8~20110207.orig/examples/bbs/ir_serverp.adb0000644000175000017500000000525211750740337021630 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- I R _ S E R V E R P -- -- -- -- B o d y -- -- -- -- Copyright (C) 2002 Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by ACT Europe. -- -- (email: sales@act-europe.fr) -- -- -- ------------------------------------------------------------------------------ with Server; with Do_Nothing; pragma Warnings (Off, Server); with PolyORB.If_Descriptors; with PolyORB.If_Descriptors.CORBA_IR; with PolyORB.POA_Config.Proxies; pragma Warnings (Off, PolyORB.POA_Config.Proxies); with PolyORB.ORB; with PolyORB.Setup; with PolyORB.Initialization; pragma Warnings (Off); with PolyORB.Setup.Thread_Pool_Server; with PolyORB.POA_Config.RACWs; pragma Warnings (On); procedure Ir_Serverp is begin Do_Nothing; PolyORB.Initialization.Initialize_World; PolyORB.If_Descriptors.Default_If_Descriptor := new PolyORB.If_Descriptors.CORBA_IR.IR_If_Descriptor; PolyORB.ORB.Run (PolyORB.Setup.The_ORB, May_Poll => True); end Ir_Serverp; polyorb-2.8~20110207.orig/examples/bbs/utils.ads0000644000175000017500000000515511750740337020633 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- U T I L S -- -- -- -- S p e c -- -- -- -- Copyright (C) 2002 Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by ACT Europe. -- -- (email: sales@act-europe.fr) -- -- -- ------------------------------------------------------------------------------ package Utils is -- This package contains some utilities that will be used throughout -- the whole system. function Integer_To_String (I : Integer) return String; -- Return the image of an integer function String_To_Integer (S : String) return Integer; -- Return the integer corresponding to a string, or raise -- Constraint_Error if we have a malformed integer. function Get_Line (Prompt : String := "") return String; -- Input a line on standard input, using Prompt as a prompt if not empty. -- Will raise Ada.IO_Exceptions.End_Error if control-D is pressed. end Utils; polyorb-2.8~20110207.orig/examples/bbs/evolutedp_corba.adb0000644000175000017500000000746111750740337022631 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- E V O L U T E D P _ C O R B A -- -- -- -- B o d y -- -- -- -- Copyright (C) 2002 Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by ACT Europe. -- -- (email: sales@act-europe.fr) -- -- -- ------------------------------------------------------------------------------ with Ada.Command_Line; use Ada.Command_Line; with Ada.Text_IO; use Ada.Text_IO; with Exceptions; use Exceptions; with Evoluted_CORBA; use Evoluted_CORBA; with DSA_Server; with DSA_Server.Helper; with DSA_Common.Penpal_Type.Impl; with PolyORB.CORBA_P.Naming_Tools; with PolyORB.CORBA_P.Server_Tools; with CORBA; use CORBA; with CORBA.ORB; with PolyORB.Setup.Thread_Pool_Server; pragma Warnings (Off, PolyORB.Setup.Thread_Pool_Server); procedure EvolutedP_CORBA is -- This program is launched using: evoluted "pseudo" procedure Usage; -- Print usage ----------- -- Usage -- ----------- procedure Usage is begin Put_Line ("Usage: evoluted ""nickname"""); Set_Exit_Status (1); end Usage; begin CORBA.ORB.Initialize ("ORB"); PolyORB.CORBA_P.Server_Tools.Initiate_Server (Start_New_Task => True); My_Server := DSA_Server.Helper.To_Ref (PolyORB.CORBA_P.Naming_Tools.Locate ("server.RCI")); if DSA_Server.Is_Nil (My_Server) then Ada.Text_IO.Put_Line ("main : cannot invoke on a nil reference"); return; end if; if Argument_Count = 1 then declare use DSA_Common.Penpal_Type.Impl; use DSA_Server; Penpal_Ref : Penpal_Pointer; begin Ada.Text_IO.Put_Line ("Initializing local penpal..."); Initialize (Penpal'Access, To_CORBA_String (Argument (1))); PolyORB.CORBA_P.Server_Tools.Initiate_Servant (Penpal'Access, Penpal_Ref); Ada.Text_IO.Put_Line (" registering..."); Register (My_Server, Penpal_Ref); Ada.Text_IO.Put_Line (" done."); Mainloop; end; else Usage; Set_Exit_Status (1); end if; exception when Sender_Error => Put_Line ("Invalid nickname"); Set_Exit_Status (2); end EvolutedP_CORBA; polyorb-2.8~20110207.orig/examples/bbs/evoluted_corba.ads0000644000175000017500000000446211750740337022470 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- E V O L U T E D _ C O R B A -- -- -- -- S p e c -- -- -- -- Copyright (C) 2002-2008, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with DSA_Common.Penpal_Type.Impl; with DSA_Server; package Evoluted_CORBA is My_Server : DSA_Server.Ref; -- The server. Penpal : aliased DSA_Common.Penpal_Type.Impl.Object; -- The penpal representing the user procedure Mainloop; -- Enter the mainloop end Evoluted_CORBA; polyorb-2.8~20110207.orig/examples/bbs/serverp.adb0000644000175000017500000000463611750740337021143 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- S E R V E R P -- -- -- -- B o d y -- -- -- -- Copyright (C) 2002 Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by ACT Europe. -- -- (email: sales@act-europe.fr) -- -- -- ------------------------------------------------------------------------------ with Server; with Do_Nothing; pragma Warnings (Off, Server); with PolyORB.ORB; with PolyORB.Setup; with PolyORB.Initialization; pragma Warnings (Off); with PolyORB.Setup.Thread_Pool_Server; with PolyORB.POA_Config.RACWs; pragma Warnings (On); procedure Serverp is begin Do_Nothing; PolyORB.Initialization.Initialize_World; PolyORB.ORB.Run (PolyORB.Setup.The_ORB, May_Poll => True); end Serverp; polyorb-2.8~20110207.orig/examples/bbs/evoluted_pkg.adb0000644000175000017500000001567311750740337022150 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- E V O L U T E D _ P K G -- -- -- -- B o d y -- -- -- -- Copyright (C) 2002-2008, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by ACT Europe. -- -- (email: sales@act-europe.fr) -- -- -- ------------------------------------------------------------------------------ with Ada.Characters.Handling; use Ada.Characters.Handling; with Ada.IO_Exceptions; with Ada.Text_IO; use Ada.Text_IO; with Exceptions; use Exceptions; with Server; use Server; with Utils; use Utils; package body Evoluted_Pkg is Want_To_Quit : Boolean := False; -- Set this to True if you want to leave the program procedure Cmd_Help; -- HELP command procedure Cmd_Post; -- POST command procedure Cmd_Quit; -- QUIT command procedure Cmd_Read; -- READ command procedure Cmd_Page; -- PAGE commend type Command is access procedure; type String_Access is access String; type Binding is record Command_Name : String_Access; Real_Command : Command; Help_String : String_Access; end record; Commands : constant array (Positive range <>) of Binding := ((Command_Name => new String'("help"), Real_Command => Cmd_Help'Access, Help_String => new String'("List of commands (this screen)")), (Command_Name => new String'("post"), Real_Command => Cmd_Post'Access, Help_String => new String'("Post a message to the BBS")), (Command_Name => new String'("quit"), Real_Command => Cmd_Quit'Access, Help_String => new String'("Quit the program")), (Command_Name => new String'("read"), Real_Command => Cmd_Read'Access, Help_String => new String'("Read messages posted on the BBS")), (Command_Name => new String'("page"), Real_Command => Cmd_Page'Access, Help_String => new String' ("Send a private message to a connected user."))); -------------- -- Cmd_Help -- -------------- procedure Cmd_Help is begin Put_Line ("List of commands:"); for I in Commands'Range loop Put_Line (Commands (I).Command_Name.all & ": " & Commands (I).Help_String.all); end loop; end Cmd_Help; -------------- -- Cmd_Post -- -------------- procedure Cmd_Post is begin Post_Message (Sender => Name_Of (Penpal'Access), Message => Get_Line (" Message> ")); exception when Message_Error => Put_Line ("Invalid message"); when Ada.IO_Exceptions.End_Error => Put_Line ("Control-D pressed, aborting post operation"); end Cmd_Post; -------------- -- Cmd_Page -- -------------- procedure Cmd_Page is begin New_Message (Sender => Name_Of (Penpal'Access), Recipient => Get_Penpal (Get_Line (" Penpal> ")), Message => Get_Line (" Message> ")); exception when Message_Error => Put_Line ("Invalid message"); when Ada.IO_Exceptions.End_Error => Put_Line ("Control-D pressed, aborting post operation"); end Cmd_Page; -------------- -- Cmd_Quit -- -------------- procedure Cmd_Quit is begin Want_To_Quit := True; end Cmd_Quit; -------------- -- Cmd_Read -- -------------- procedure Cmd_Read is begin for I in 1 .. Number_Of_Messages loop Put_Line ("Message " & Integer_To_String (I) & ": <" & Get_Sender (I) & "> " & Get_Message (I)); end loop; end Cmd_Read; -------------- -- Mainloop -- -------------- procedure Mainloop is Found : Boolean; begin loop New_Line; declare Command : constant String := To_Lower (Get_Line ("Command (type ""help"" if needed)> ")); begin Found := False; for I in Commands'Range loop if Commands (I) .Command_Name.all = Command then Found := True; Commands (I) .Real_Command.all; exit; end if; end loop; if Command /= "" and then not Found then Put_Line ("Unknown command, type ""help"" for help"); end if; end; if Want_To_Quit then Put_Line ("Exiting"); exit; end if; end loop; exception when Ada.IO_Exceptions.End_Error => Put_Line ("Control-D pressed, exiting"); end Mainloop; protected body Received_Counter is procedure Set_Expected (N : Integer) is begin Expected := N; end Set_Expected; procedure Message_Received is begin Expected := Expected - 1; if Expected = 0 then Put_Line ("Recv done."); end if; end Message_Received; entry Wait_For_Completion when Expected = 0 is begin null; end Wait_For_Completion; end Received_Counter; procedure New_Message (Sender : String; Recipient : access Instrumented_Penpal; Message : String) is begin Received_Counter.Message_Received; Common.New_Message (Sender, Penpal_Type (Recipient.all)'Access, Message); end New_Message; end Evoluted_Pkg; polyorb-2.8~20110207.orig/examples/bbs/dsa_common-penpal_type-impl.ads0000644000175000017500000000515011750740337025062 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- D S A _ C O M M O N . P E N P A L _ T Y P E . I M P L -- -- -- -- S p e c -- -- -- -- Copyright (C) 2002-2008, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by ACT Europe. -- -- (email: sales@act-europe.fr) -- -- -- ------------------------------------------------------------------------------ with CORBA; with PortableServer; package DSA_Common.Penpal_Type.Impl is type Object is new PortableServer.Servant_Base with private; type Object_Ptr is access all Object'Class; procedure Initialize (Self : access Object; Name : CORBA.String); function Name_Of (Self : access Object) return CORBA.String; procedure New_Message (Self : access Object; Sender : CORBA.String; Message : CORBA.String); private type Object is new PortableServer.Servant_Base with record Name : CORBA.String; end record; end DSA_Common.Penpal_Type.Impl; polyorb-2.8~20110207.orig/examples/bbs/do_nothing.adb0000644000175000017500000000431711750740337021601 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- D O _ N O T H I N G -- -- -- -- B o d y -- -- -- -- Copyright (C) 2002 Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by ACT Europe. -- -- (email: sales@act-europe.fr) -- -- -- ------------------------------------------------------------------------------ with Ada.Text_IO; use Ada.Text_IO; procedure Do_Nothing is -- This procedure does nothing, as the server has no main subprogram begin Put_Line ("Server partition starting"); end Do_Nothing; polyorb-2.8~20110207.orig/examples/bbs/client-controller0000755000175000017500000001063411750740337022365 0ustar xavierxavier#! /bin/sh # A simple script to launch an automated test run. # Highly dependant on the local setup. # $Id: client-controller 34164 2002-12-04 01:18:53Z quinot $ ab_names=/infres/shalmaneser/quinot/projects/droopi/cos/naming/ab_names serverp=/infres/shalmaneser/quinot/projects/droopi/examples/bbs/serverp serverp_conf=/infres/shalmaneser/quinot/projects/droopi/examples/bbs/serverp.conf evolutedp=/infres/ir10/astre/quinot/polyorb-sparc/build/examples/bbs/evolutedp evolutedp_conf=/infres/shalmaneser/quinot/projects/droopi/examples/bbs/evolutedp.conf output=/infres/shalmaneser/quinot/polyorb-output Revolutedp_pids="" sol8_hosts=valjean:cosette:fadette:roland:isengrin:candide:fracasse:donjuan:chimene:elvire:gavroche:lantier:folcoche:quasimodo: #cyrano: sol9_hosts=nadja:blizzard:aurelien:goriot:esmeralda:esmeralda2:rodrigue:vautrin:arsene:javert: hosts=$sol8_hosts nhosts=`echo $hosts | tr -cd : | wc -c` size=100 count=100 cli_per_host=1 nmax=$nhosts ulimit -c unlimited kill=false broadcast="" while getopts bks:c:n:N: opt; do case "$opt" in k) kill=true ;; b) broadcast="-b" ;; s) size=$OPTARG ;; c) count=$OPTARG ;; N) cli_per_host=$OPTARG ;; n) nmax=$OPTARG ;; *) echo "invalid parameter"; exit 1;; esac done if [ "$nmax" -gt `expr "$nhosts" '*' "$cli_per_host"` ]; then echo "Too many total clients ($nhosts hosts, $cli_per_host clients each". exit 1 fi if $kill; then IFS=: for h in $hosts; do if [ "$h" != "" ]; then echo $h rsh $h "/usr/ucb/ps axuw|grep 'quinot.*$evolutedp' | grep -v grep \ | awk '{print \$2}' | xargs kill -9 2> /dev/null || echo ---" fi done ps axw|grep "tail -f /tmp/cli"|awk '{print $1}'|xargs kill 2> /dev/null exit 0 fi now=`date +"%F_%T" | tr -d :` output=$output/$now mkdir $output ( echo "output=$output" echo "size=$size" echo "count=$count" echo "nmax=$nmax" echo "cli_per_host=$cli_per_host" if [ "$brodcast" = "-b" ]; then echo "broadcast=true" else echo "broadcast=false" fi ) > $output/00PARAMETERS echo "000 init" sed "s/^/ /" $output/00PARAMETERS cp $ab_names_conf $serverp_conf $evolutedp_conf $output 2> /dev/null || true trap 'echo kill $ab_names_pid $serverp_pid $Revolutedp_pids; kill -9 $ab_names_pid $serverp_pid $Revolutedp_pids; exit' 0 2 15 echo "001 Starting name server..." touch $output/ab_names.out POLYORB_CONF=$ab_names_conf $ab_names > $output/ab_names.out 2> /dev/null & ab_names_pid=$! while ! grep POLYORB_CORBA_NAMING_IOR $output/ab_names.out; do sleep 5 done . $output/ab_names.out export POLYORB_CORBA_NAMING_IOR echo "002 Starting server partition..." POLYORB_CONF=$serverp_conf $serverp > $output/serverp.out 2>&1 & serverp_pid=$! sleep 5 clinumber=0 hostnumber=0 while [ "$hostnumber" -lt "$nhosts" -a "$clinumber" -lt "$nmax" ]; do eval `echo $hosts | sed 's/^\([^:]*\):\(.*\)$/host=\1;hosts=\2/'` ping -c 2 $host > /dev/null || continue cli_thishost=0 while [ "$cli_thishost" -lt "$cli_per_host" -a "$clinumber" -lt "$nmax" ]; do ctl=/tmp/cli${clinumber}_ctl rm -f $ctl mkfifo $ctl cliout=$output/cli$clinumber-$host touch $cliout cliouts="$cliouts $cliout" echo `expr 100 + $clinumber`" Starting client $clinumber on $host" sh -c "tail -f $ctl | rsh $host \"ulimit -c unlimited;TERM=dumb \ POLYORB_CORBA_NAMING_IOR=$POLYORB_CORBA_NAMING_IOR \ POLYORB_CONF=$evolutedp_conf \ LD_LIBRARY_PATH=/usr/local/lib \ $evolutedp $broadcast -n $nmax -c $count -s $size TEST_$clinumber 2>&1 \" \ >> $cliout" & Revolutedp_pids="$Revolutedp_pids $!" eval "cli_host_$clinumber=$h" clinumber=`expr $clinumber + 1` cli_thishost=`expr $cli_thishost + 1` done done echo "200 Waiting for clients to become ready." retries=0 while [ "`grep -L Ready $cliouts`" != "" -a "$retries" -lt 60 ]; do retries=`expr $retries + 1` sleep 2 done if [ "$retries" -ge 60 ]; then echo "222 Timed out" $0 -k exit 1 fi echo "201 GO!" date i=0 while [ $i -lt $clinumber ]; do echo "" > /tmp/cli${i}_ctl & i=`expr $i + 1` done date echo "202 Waiting for clients to complete." while true; do if [ "`grep -L 'Elapsed :' $cliouts`" = "" ]; then echo "555 Success." echo OK > $output/98STATUS break fi if egrep -i 'Raised|STORAGE|ASSERT' $cliouts > /dev/null; then echo "666 Exception." echo FAIL > $output/98STATUS break fi sleep 5 done date echo "888 Completed, cleaning up." $0 -k polyorb-2.8~20110207.orig/examples/bbs/exceptions.ads0000644000175000017500000000430011750740337021643 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- E X C E P T I O N S -- -- -- -- S p e c -- -- -- -- Copyright (C) 2002 Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by ACT Europe. -- -- (email: sales@act-europe.fr) -- -- -- ------------------------------------------------------------------------------ package Exceptions is pragma Pure; Sender_Error : exception; Message_Error : exception; No_Such_Message : exception; No_Such_Penpal : exception; end Exceptions; polyorb-2.8~20110207.orig/examples/bbs/evoluted_corba.adb0000644000175000017500000001461511750740337022450 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- E V O L U T E D _ C O R B A -- -- -- -- B o d y -- -- -- -- Copyright (C) 2002 Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by ACT Europe. -- -- (email: sales@act-europe.fr) -- -- -- ------------------------------------------------------------------------------ with Ada.Characters.Handling; use Ada.Characters.Handling; with Ada.IO_Exceptions; with Ada.Text_IO; use Ada.Text_IO; with Exceptions; use Exceptions; with Utils; use Utils; with CORBA; package body Evoluted_CORBA is Want_To_Quit : Boolean := False; -- Set this to True if you want to leave the program procedure Cmd_Help; -- HELP command procedure Cmd_Post; -- POST command procedure Cmd_Quit; -- QUIT command procedure Cmd_Read; -- READ command procedure Cmd_Page; -- READ command type Command is access procedure; type String_Access is access String; type Binding is record Command_Name : String_Access; Real_Command : Command; Help_String : String_Access; end record; Commands : constant array (Positive range <>) of Binding := ((Command_Name => new String'("help"), Real_Command => Cmd_Help'Access, Help_String => new String'("List of commands (this screen)")), (Command_Name => new String'("post"), Real_Command => Cmd_Post'Access, Help_String => new String'("Post a message to the BBS")), (Command_Name => new String'("quit"), Real_Command => Cmd_Quit'Access, Help_String => new String'("Quit the program")), (Command_Name => new String'("read"), Real_Command => Cmd_Read'Access, Help_String => new String'("Read messages posted on the BBS")), (Command_Name => new String'("page"), Real_Command => Cmd_Page'Access, Help_String => new String' ("Send a private message to a connected user."))); -------------- -- Cmd_Help -- -------------- procedure Cmd_Help is begin Put_Line ("List of commands:"); for I in Commands'Range loop Put_Line (Commands (I).Command_Name.all & ": " & Commands (I).Help_String.all); end loop; end Cmd_Help; -------------- -- Cmd_Post -- -------------- procedure Cmd_Post is use DSA_Common.Penpal_Type.Impl; begin DSA_Server.Post_Message (Self => My_Server, Sender => Name_Of (Penpal'Access), Message => CORBA.To_CORBA_String (Get_Line (" Message> "))); exception when Message_Error => Put_Line ("Invalid message"); when Ada.IO_Exceptions.End_Error => Put_Line ("Control-D pressed, aborting post operation"); end Cmd_Post; -------------- -- Cmd_Quit -- -------------- procedure Cmd_Quit is begin Want_To_Quit := True; end Cmd_Quit; -------------- -- Cmd_Read -- -------------- procedure Cmd_Read is use DSA_Server; begin for I in 1 .. Number_Of_Messages (My_Server) loop Put_Line ("Message " & Integer_To_String (Integer (I)) & ": <" & CORBA.To_Standard_String (Get_Sender (My_Server, I)) & "> " & CORBA.To_Standard_String (Get_Message (My_Server, I))); end loop; end Cmd_Read; -------------- -- Cmd_Read -- -------------- procedure Cmd_Page is use DSA_Common.Penpal_Type; use DSA_Common.Penpal_Type.Impl; begin new_message (Self => DSA_Server.Get_Penpal (My_Server, CORBA.To_CORBA_String (Get_Line ("Penpal> "))), Sender => Name_Of (Penpal'Access), Message => CORBA.To_CORBA_String (Get_Line ("Message> "))); end Cmd_Page; -------------- -- Mainloop -- -------------- procedure Mainloop is Found : Boolean; begin loop New_Line; declare Command : constant String := To_Lower (Get_Line ("Command (type ""help"" if needed)> ")); begin Found := False; for I in Commands'Range loop if Commands (I) .Command_Name.all = Command then Found := True; Commands (I) .Real_Command.all; exit; end if; end loop; if Command /= "" and then not Found then Put_Line ("Unknown command, type ""help"" for help"); end if; end; if Want_To_Quit then Put_Line ("Exiting"); exit; end if; end loop; exception when Ada.IO_Exceptions.End_Error => Put_Line ("Control-D pressed, exiting"); end Mainloop; end Evoluted_CORBA; polyorb-2.8~20110207.orig/examples/bbs/dsa_common-penpal_type-impl.adb0000644000175000017500000000602711750740337025045 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- D S A _ C O M M O N . P E N P A L _ T Y P E . I M P L -- -- -- -- B o d y -- -- -- -- Copyright (C) 2002-2008, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by ACT Europe. -- -- (email: sales@act-europe.fr) -- -- -- ------------------------------------------------------------------------------ with Ada.Text_IO; with DSA_Common.Penpal_Type.Skel; pragma Warnings (Off, DSA_Common.Penpal_Type.Skel); package body DSA_Common.Penpal_Type.Impl is procedure Initialize (Self : access Object; Name : CORBA.String) is begin Self.Name := Name; end Initialize; function Name_Of (Self : access Object) return CORBA.String is begin return Self.Name; end Name_Of; procedure New_Message (Self : access Object; Sender : CORBA.String; Message : CORBA.String) is pragma Unreferenced (Self); use CORBA; A_Sender : constant String := To_Standard_String (Sender); A_Message : constant String := To_Standard_String (Message); begin -- if A_Sender = "" then -- raise Sender_Error; -- elsif A_Message = "" then -- raise Message_Error; -- else Ada.Text_IO.Put_Line ("New message: <" & A_Sender & "> " & A_Message); -- end if; end New_Message; end DSA_Common.Penpal_Type.Impl; polyorb-2.8~20110207.orig/examples/bbs/utils.adb0000644000175000017500000000562511750740337020614 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- U T I L S -- -- -- -- B o d y -- -- -- -- Copyright (C) 2002 Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by ACT Europe. -- -- (email: sales@act-europe.fr) -- -- -- ------------------------------------------------------------------------------ with Ada.Text_IO; use Ada.Text_IO; package body Utils is -------------- -- Get_Line -- -------------- function Get_Line (Prompt : String := "") return String is Line : String (1 .. 256); Last : Natural; begin Put (Prompt); Get_Line (Line, Last); return Line (1 .. Last); end Get_Line; ----------------------- -- Integer_To_String -- ----------------------- function Integer_To_String (I : Integer) return String is Image : constant String := Integer'Image (I); begin if Image (1) = ' ' then return Image (2 .. Image'Last); else return Image; end if; end Integer_To_String; ----------------------- -- String_To_Integer -- ----------------------- function String_To_Integer (S : String) return Integer is begin return Integer'Value (S); end String_To_Integer; end Utils; polyorb-2.8~20110207.orig/examples/bbs/bbs.idl0000644000175000017500000000074611750740337020243 0ustar xavierxavier#include "common.idl" interface DSA_Server { #pragma ID DSA_Server "DSA:Server:878a82d5" void Post_Message (in string Sender, in string Message); long Number_Of_Messages (); string Get_Sender (in long N); string Get_Message (in long N); typedef ::DSA_Common::Penpal_Type Penpal_Pointer; void Register (in ::DSA_Server::Penpal_Pointer Penpal); ::DSA_Server::Penpal_Pointer Get_Penpal (in string Name); void Broadcast (in string Sender, in string Message); }; polyorb-2.8~20110207.orig/examples/bbs/simple.adb0000644000175000017500000000734311750740337020744 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- S I M P L E -- -- -- -- B o d y -- -- -- -- Copyright (C) 2002-2008, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by ACT Europe. -- -- (email: sales@act-europe.fr) -- -- -- ------------------------------------------------------------------------------ with Ada.Command_Line; use Ada.Command_Line; with Ada.Text_IO; use Ada.Text_IO; with Exceptions; use Exceptions; with Server; use Server; with Utils; use Utils; -- This client lets someone post a simple message to the BBS or retrieve -- all the messages that have been posted on the BBS. -- -- Syntax: simple post "pseudo" "message" -- add a message onto the BBS -- simple read -- get the messages from the BBS procedure Simple is procedure Post (Sender : String; Message : String); -- Post a message procedure Read; -- Read messages procedure Usage; -- Print usage ---------- -- Post -- ---------- procedure Post (Sender : String; Message : String) is begin Post_Message (Sender, Message); exception when Sender_Error => Put_Line ("Invalid sender name"); Set_Exit_Status (2); when Message_Error => Put_Line ("Invalid message"); Set_Exit_Status (3); end Post; ---------- -- Read -- ---------- procedure Read is begin for I in 1 .. Number_Of_Messages loop Put_Line ("Message " & Integer_To_String (I) & ": <" & Get_Sender (I) & "> " & Get_Message (I)); end loop; end Read; ----------- -- Usage -- ----------- procedure Usage is begin Put_Line ("Usage: simple post ""nickname"" ""message"""); Put_Line (" or simple read"); Set_Exit_Status (1); end Usage; begin if Argument_Count = 1 and then Argument (1) = "read" then Read; elsif Argument_Count = 3 and then Argument (1) = "post" then Post (Argument (2), Argument (3)); else Usage; end if; end Simple; polyorb-2.8~20110207.orig/examples/bbs/evolutedp.adb0000644000175000017500000000471711750740337021464 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- E V O L U T E D P -- -- -- -- B o d y -- -- -- -- Copyright (C) 2002 Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by ACT Europe. -- -- (email: sales@act-europe.fr) -- -- -- ------------------------------------------------------------------------------ with PolyORB.Initialization; with PolyORB.Setup.Thread_Pool_Server; -- We have RACWs: better initialize some TSAPs! -- We also have a main loop, so we need parallel processing: -- use a thread pool. pragma Warnings (Off, PolyORB.Setup.Thread_Pool_Server); with PolyORB.POA_Config.RACWs; pragma Warnings (Off, PolyORB.POA_Config.RACWs); with Evoluted; procedure EvolutedP is begin PolyORB.Initialization.Initialize_World; Evoluted; end EvolutedP; polyorb-2.8~20110207.orig/examples/bbs/local.gpr0000644000175000017500000000102211750740337020573 0ustar xavierxavierwith "polyorb", "polyorb_test_common"; project local is Dir := external ("Test_Dir"); Obj_Dir := PolyORB_Test_Common.Build_Dir & Dir; for Object_Dir use Obj_Dir; for Source_Dirs use (Obj_Dir, PolyORB_Test_Common.Source_Dir & Dir); package Compiler is for Default_Switches ("Ada") use PolyORB_Test_Common.Compiler'Default_Switches ("Ada"); end Compiler; for Main use ("ir_evolutedp.adb", "ir_serverp.adb", "evolutedp_corba.adb", "simplep.adb", "evolutedp.adb", "serverp.adb"); end local; polyorb-2.8~20110207.orig/examples/bbs/evoluted.adb0000644000175000017500000001545511750740337021305 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- E V O L U T E D -- -- -- -- B o d y -- -- -- -- Copyright (C) 2002-2003 Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by ACT Europe. -- -- (email: sales@act-europe.fr) -- -- -- ------------------------------------------------------------------------------ -- Evoluted BBS client with Ada.Command_Line; use Ada.Command_Line; with Ada.Exceptions; with Ada.Text_IO; use Ada.Text_IO; with Ada.Calendar; use Ada.Calendar; with Exceptions; use Exceptions; with Evoluted_Pkg; use Evoluted_Pkg; with Server; use Server; with Common; with Utils; with PolyORB.Dynamic_Dict; with GNAT.Command_Line; use GNAT.Command_Line; with GNAT.OS_Lib; procedure Evoluted is -- This program is launched using: evoluted "pseudo" procedure Usage; -- Print usage package Penpals_Cache is new PolyORB.Dynamic_Dict (Penpal_Pointer); function Cache_Get_Penpal (P : String) return Penpal_Pointer; function Cache_Get_Penpal (P : String) return Penpal_Pointer is PP : Penpal_Pointer := Penpals_Cache.Lookup (P, null); begin if PP = null then PP := Get_Penpal (P); Penpals_Cache.Register (P, PP); end if; return PP; end Cache_Get_Penpal; ----------- -- Usage -- ----------- procedure Usage is begin Put_Line ("Usage: evoluted ""nickname"""); Set_Exit_Status (1); end Usage; Is_Test : Boolean := False; Test_Broadcast : Boolean := False; Message_Count : Integer := 100; Message_Size : Integer := 100; Nmax : Integer; Expected_Messages : Integer; type String_Ptr is access String; Payload : String_Ptr; Start : Time; function Image (I : Integer) return String; function Image (I : Integer) return String is S : constant String := Integer'Image (I); First : Integer := S'First; begin if S (First) = ' ' then First := First + 1; end if; return S (First .. S'Last); end Image; begin loop case Getopt ("b c: n: s:") is when ASCII.NUL => exit; when 'b' => Test_Broadcast := True; when 'c' => Message_Count := Integer'Value (Parameter); when 'n' => Nmax := Integer'Value (Parameter); Is_Test := True; when 's' => Message_Size := Integer'Value (Parameter); when others => raise Program_Error; end case; end loop; declare Penpal_Name : constant String := Get_Argument; begin if Penpal_Name'Length = 0 then Usage; GNAT.OS_Lib.OS_Exit (1); end if; Put ("Initializing local penpal..."); Initialize (Penpal, Penpal_Name); Put (" registering..."); Register (Penpal'Access); Put_Line (" done."); if not Is_Test then Mainloop; GNAT.OS_Lib.OS_Exit (0); end if; ---------------------------- -- Automated test section -- ---------------------------- Expected_Messages := Nmax * Message_Count; if Test_Broadcast then Expected_Messages := Expected_Messages * 2; end if; Received_Counter.Set_Expected (Expected_Messages); Payload := new String'(1 .. Message_Size => 'X'); Put_Line ("Expecting" & Expected_Messages'Img & " messages."); declare Dummy : constant String := Utils.Get_Line ("Ready>"); pragma Unreferenced (Dummy); begin null; end; Start := Clock; for K in 0 .. Message_Count - 1 loop declare Iter : constant String := Integer'Image (K); begin if Test_Broadcast then Post_Message (Sender => Name_Of (Penpal'Access), Message => "B" & Iter & ":" & Penpal_Name & ":" & Payload.all); end if; for J in 0 .. Nmax - 1 loop declare To : constant String := "TEST_" & Image (J); begin Common.New_Message (Sender => Name_Of (Penpal'Access), Recipient => Cache_Get_Penpal (To), Message => "P" & Iter & ":" & Penpal_Name & ":" & To & ":" & Payload.all); end; end loop; exception when E : others => Put_Line ("Raised exception in iteration" & Integer'Image (K) & ": " & Ada.Exceptions.Exception_Information (E)); GNAT.OS_Lib.OS_Exit (1); end; end loop; Ada.Text_IO.Put_Line ("Send done."); Received_Counter.Wait_For_Completion; declare Elapsed : constant Duration := Clock - Start; begin Put_Line ("Elapsed :" & Duration'Image (Elapsed)); end; exception when E : others => Put_Line (Ada.Exceptions.Exception_Information (E)); end; delay 5.0; GNAT.OS_Lib.OS_Exit (0); exception when Sender_Error => Put_Line ("Invalid nickname"); Set_Exit_Status (2); end Evoluted; polyorb-2.8~20110207.orig/examples/bbs/stats/0000755000175000017500000000000011750740340020124 5ustar xavierxavierpolyorb-2.8~20110207.orig/examples/bbs/stats/collate-stats0000755000175000017500000000304511750740337022641 0ustar xavierxavier#! /bin/sh # $Id: collate-stats 34142 2002-12-02 15:56:01Z quinot $ output=/infres/shalmaneser/quinot/polyorb-output force=false all=false while getopts fa opt; do case $opt in f) force=true ;; a) all=true ;; *) echo "Usage: $0 [-fa]"; exit 1 ;; esac done shift `expr $OPTIND - 1` get_threads() { t=4 if [ -f "$d/$1.conf" ]; then tconf=`grep ^polyorb.orb.thread_pool.threads "$d/evolutedp.conf"` if [ "$tconf" != "" ]; then t=`echo $tconf | sed "s/^.*=//"` fi fi echo "$1_thr=$t" } if [ "$#" = 0 ]; then set -- $output/* fi for d in "$@"; do if [ ! -d $d ]; then continue; fi if $force || [ ! -f $d/99RESULTS ]; then cp $d/00PARAMETERS $d/99RESULTS . $d/00PARAMETERS ( get_threads serverp get_threads evolutedp for f in $d/cli*; do sed -n '/.*Elapsed *: \([0-9]*\.[0-9]*\)$/s//\1/p' < $f done | awk 'BEGIN { sup = 0; inf = 0; } { sum += $1; sqsum += $1 * $1; if (sup == 0 || $1 > sup) sup = $1; if (inf == 0 ||$1 < inf) inf = $1; } END { if (sum > 0 && NR == '"$nmax"') { print "status=OK" avg = sum / NR; printf "inf=%.12g\nsup=%.12g\nmoy=%.12g\nect=%.12g\n", inf, sup, (sum / NR), sqrt(sqsum/NR - (avg * avg)) } else { print "status=FAILED"; } }' ) >> $d/99RESULTS fi if $all || grep status=OK $d/99RESULTS > /dev/null; then cat $d/99RESULTS echo "----------" fi done polyorb-2.8~20110207.orig/examples/bbs/stats/siz2data0000755000175000017500000000013211750740337021575 0ustar xavierxavier#! /bin/sh tr = ' ' | awk '/Elapsed/ { time = $3 } /siz/ { print $2 " " time }' polyorb-2.8~20110207.orig/examples/bbs/stats/stats2data0000755000175000017500000000165311750740337022137 0ustar xavierxavier#! /bin/sh # This outputs elapsed = f(nmax) # params # nmax # ethr # siz while getopts t:p: opt; do case "$opt" in t) tag="$OPTARG" ;; p) param="$OPTARG" ;; *) echo "Usage: $0 [ -t TAG ] [ -p PARAM ]"; exit 1 ;; esac done case "x$param" in x|xnmax) param=nmax ;; xethr|xsiz) param=$param ;; *) echo "bad param"; exit 1 ;; esac if [ "$tag" != "" ]; then tag="_$tag" fi tr '=' ' ' | awk ' BEGIN { param = "'"$param"'" } /^nmax/ { nmax=$2 } /^moy/ { moy=$2 } /^siz/ { siz=$2 } /^coun/ { cnt=$2 } /^evolutedp_thr/ { ethr=$2 } /^ect/ { ect = $2; if (ethr == 0) ethr = 4; fn = sprintf ("data'"$tag"'_%diter", cnt); if (param != "nmax") fn = (fn sprintf ("_%dcli", nmax)); if (param != "ethr") fn = (fn sprintf ("_%dthr", ethr)); if (param != "siz") fn = (fn sprintf ("_%dbytes", siz)); printf "%.12g %.12g %.12g\n", '"$param"', moy, ect >> fn }' polyorb-2.8~20110207.orig/examples/bbs/stats/doplot0000755000175000017500000000050611750740337021362 0ustar xavierxavier#! /bin/sh #set data style yerrorbars plot_one() { cat <<__EOF__ | gnuplot set term postscript eps color set data style linespoint set output "$2" plot "$1" __EOF__ } for data in data*; do ps=`echo $data | sed s/data/plot/`.ps if [ ! "$ps" -nt "$data" ]; then echo "$data -> $ps" plot_one $data $ps fi done polyorb-2.8~20110207.orig/examples/bbs/ir_evolutedp.adb0000644000175000017500000000475411750740337022157 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- I R _ E V O L U T E D P -- -- -- -- B o d y -- -- -- -- Copyright (C) 2002 Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by ACT Europe. -- -- (email: sales@act-europe.fr) -- -- -- ------------------------------------------------------------------------------ with PolyORB.CORBA_P.Server_Tools; with EvolutedP_CORBA; with DSA_Server.IR_Info; with DSA_Common.Penpal_Type.IR_Info; procedure IR_Evolutedp is procedure Register_IR_Info; procedure Register_IR_Info is begin DSA_Common.Penpal_Type.IR_Info.Register_IR_Info; DSA_Server.IR_Info.Register_IR_Info; end Register_IR_Info; begin PolyORB.CORBA_P.Server_Tools.Initiate_Server_Hook := Register_IR_Info'Unrestricted_Access; EvolutedP_CORBA; end IR_Evolutedp; polyorb-2.8~20110207.orig/examples/bbs/server.adb0000644000175000017500000002576411750740337020770 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- S E R V E R -- -- -- -- B o d y -- -- -- -- Copyright (C) 2002-2008, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by ACT Europe. -- -- (email: sales@act-europe.fr) -- -- -- ------------------------------------------------------------------------------ with Ada.Characters.Handling; use Ada.Characters.Handling; with Ada.Text_IO; use Ada.Text_IO; with Exceptions; use Exceptions; with System.RPC; with Utils; use Utils; package body Server is type String_Access is access String; type Message; type Message_Access is access Message; type Message is record Sender : String_Access; Content : String_Access; Next_Message : Message_Access; end record; protected Message_Board is procedure Add_Message (Sender : String; Content : String); -- Add a message to the message board. Sender_Error and Message_Error -- will be raised if the sender or the message are empty. function Messages_Count return Natural; -- Number of messages in the message board function Get_Sender (N : Positive) return String; -- Sender of a particular message (No_Such_Message will be raised if -- there is no such message). function Get_Message (N : Positive) return String; -- Content of a particular message (No_Such_Message will be raised if -- there is no such message). private function Get (N : Positive) return Message_Access; -- Get a message, and raise No_Such_Message if it does not exist Messages : Message_Access := null; Count : Natural := 0; end Message_Board; -- Message_Board is a protected structure (we will not have concurrent -- calls) in which messages are stored. The messages are stored in reverse -- order. This is totally *inefficient*, but well, this is a toy program :) type Penpal_Node; type Penpal_List is access Penpal_Node; type Penpal_Node is record Name : String_Access; Penpal : Penpal_Pointer; Next_Penpal : Penpal_List; end record; type Penpal_Array is array (Positive range <>) of Penpal_Node; -- List of penpals with their names. The Next_Penpal field will have -- no meaning though. protected Penpals_Handler is procedure Add (Penpal : Penpal_Pointer); -- Add a Penpal to the list, raise Sender_Error if the penpal has not -- been initialized. function Lookup (Name : String) return Penpal_Pointer; -- Lookup a penpal in the list, or raise No_Such_Penpal if no penpal -- by this name has been registered. function Get_List return Penpal_Array; -- Return the list of registered penpals private function Lookup (Name : String) return Penpal_List; -- Lookup a penpal by its name, and return null if no such penpal -- has been registered; Penpals : Penpal_List := null; Count : Natural := 0; end Penpals_Handler; --------------- -- Broadcast -- --------------- procedure Broadcast (Sender : String; Message : String) is Penpals : constant Penpal_Array := Penpals_Handler.Get_List; begin Put_Line ("Sending a broadcast to " & Integer_To_String (Penpals'Length) & " registered clients:"); for I in Penpals'Range loop begin Put (" Trying to contact <" & Penpals (I).Name.all & ">... "); Flush; New_Message (Sender => Sender, Recipient => Penpals (I).Penpal, Message => Message); Put_Line ("OK"); exception when System.RPC.Communication_Error => -- This penpal is probably dead, ignore the error... Put_Line ("fail"); end; end loop; end Broadcast; ----------------- -- Get_Message -- ----------------- function Get_Message (N : Positive) return String is begin return Message_Board.Get_Message (N); end Get_Message; ---------------- -- Get_Penpal -- ---------------- function Get_Penpal (Name : String) return Penpal_Pointer is begin return Penpals_Handler.Lookup (Name); end Get_Penpal; ---------------- -- Get_Sender -- ---------------- function Get_Sender (N : Positive) return String is begin return Message_Board.Get_Sender (N); end Get_Sender; ------------------- -- Message_Board -- ------------------- protected body Message_Board is ----------------- -- Add_Message -- ----------------- procedure Add_Message (Sender : String; Content : String) is begin if Sender = "" then raise Sender_Error; elsif Content = "" then raise Message_Error; else Messages := new Message'(Sender => new String'(Sender), Content => new String'(Content), Next_Message => Messages); Count := Count + 1; end if; end Add_Message; --------- -- Get -- --------- function Get (N : Positive) return Message_Access is Current : Message_Access := Messages; begin if N > Count then raise No_Such_Message; end if; for I in N + 1 .. Count loop Current := Current.Next_Message; end loop; return Current; end Get; ----------------- -- Get_Message -- ----------------- function Get_Message (N : Positive) return String is begin return Get (N) .Content.all; end Get_Message; ---------------- -- Get_Sender -- ---------------- function Get_Sender (N : Positive) return String is begin return Get (N) .Sender.all; end Get_Sender; -------------------- -- Messages_Count -- -------------------- function Messages_Count return Natural is begin return Count; end Messages_Count; end Message_Board; ------------------------ -- Number_Of_Messages -- ------------------------ function Number_Of_Messages return Natural is begin return Message_Board.Messages_Count; end Number_Of_Messages; --------------------- -- Penpals_Handler -- --------------------- protected body Penpals_Handler is --------- -- Add -- --------- procedure Add (Penpal : Penpal_Pointer) is Name : constant String := Name_Of (Penpal); Current : Penpal_List := Lookup (Name); begin if Current = null then Penpals := new Penpal_Node'(Name => new String'(Name), Penpal => Penpal, Next_Penpal => Penpals); Count := Count + 1; else Current.Penpal := Penpal; end if; end Add; -------------- -- Get_List -- -------------- function Get_List return Penpal_Array is Result : Penpal_Array (1 .. Count); Current : Penpal_List := Penpals; begin for I in 1 .. Count loop Result (I) := Current.all; -- Since the Next_Penpal has no meaning here, clear it Result (I) .Next_Penpal := null; Current := Current.Next_Penpal; end loop; return Result; end Get_List; ------------ -- Lookup -- ------------ function Lookup (Name : String) return Penpal_Pointer is Current : constant Penpal_List := Lookup (Name); begin if Current = null then raise No_Such_Penpal; else return Current.Penpal; end if; end Lookup; ------------ -- Lookup -- ------------ function Lookup (Name : String) return Penpal_List is Current : Penpal_List := Penpals; Low_Name : constant String := To_Lower (Name); begin while Current /= null loop begin if To_Lower (Current.Name.all) = Low_Name then return Current; end if; exception when System.RPC.Communication_Error => -- The given name is unreachable, don't give it, return -- null instead. return null; end; Current := Current.Next_Penpal; end loop; return null; end Lookup; end Penpals_Handler; ------------------ -- Post_Message -- ------------------ procedure Post_Message (Sender : String; Message : String) is begin -- Add the message to the message board Put_Line ("Posting a message from <" & Sender & ">: """ & Message & """"); Message_Board.Add_Message (Sender, Message); -- For each registered client, send it the message Broadcast (Sender, Message); end Post_Message; -------------- -- Register -- -------------- procedure Register (Penpal : Penpal_Pointer) is begin Put_Line ("Registering a new penpal <" & Name_Of (Penpal) & ">"); Penpals_Handler.Add (Penpal); end Register; end Server; polyorb-2.8~20110207.orig/examples/bbs/evoluted_pkg.ads0000644000175000017500000000537111750740337022163 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- E V O L U T E D _ P K G -- -- -- -- S p e c -- -- -- -- Copyright (C) 2002-2008, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by ACT Europe. -- -- (email: sales@act-europe.fr) -- -- -- ------------------------------------------------------------------------------ with Common; use Common; package Evoluted_Pkg is ---------------------------------------------- -- Global variables for automatic test mode -- ---------------------------------------------- protected Received_Counter is procedure Set_Expected (N : Integer); procedure Message_Received; entry Wait_For_Completion; private Expected : Integer := 0; end Received_Counter; type Instrumented_Penpal is new Penpal_Type with null record; procedure New_Message (Sender : String; Recipient : access Instrumented_Penpal; Message : String); Penpal : aliased Instrumented_Penpal; -- The penpal representing the user procedure Mainloop; -- Enter the mainloop end Evoluted_Pkg; polyorb-2.8~20110207.orig/examples/bbs/common.adb0000644000175000017500000000717311750740337020744 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- C O M M O N -- -- -- -- B o d y -- -- -- -- Copyright (C) 2002-2008, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by ACT Europe. -- -- (email: sales@act-europe.fr) -- -- -- ------------------------------------------------------------------------------ with Ada.Text_IO; use Ada.Text_IO; with Exceptions; use Exceptions; package body Common is ---------------- -- Initialize -- ---------------- procedure Initialize (Penpal : in out Penpal_Type; Name : String) is begin if Name = "" then raise Sender_Error; end if; Penpal.Name := new String'(Name); end Initialize; ------------- -- Name_Of -- ------------- function Name_Of (Penpal : access Penpal_Type) return String is begin if Penpal.Name = null then raise Sender_Error; else return Penpal.Name.all; end if; end Name_Of; ----------------- -- New_Message -- ----------------- procedure New_Message (Sender : String; Recipient : access Penpal_Type; Message : String) is pragma Warnings (Off); pragma Unreferenced (Recipient); pragma Warnings (On); begin if Sender = "" then raise Sender_Error; elsif Message = "" then raise Message_Error; else Put_Line ("New message: <" & Sender & "> " & Message); end if; end New_Message; ---------- -- Read -- ---------- procedure Read (Stream : access Ada.Streams.Root_Stream_Type'Class; Penpal : out String_Access) is begin -- No need to use this raise Program_Error; end Read; ----------- -- Write -- ----------- procedure Write (Stream : access Ada.Streams.Root_Stream_Type'Class; Penpal : String_Access) is begin -- No need to use this raise Program_Error; end Write; end Common; polyorb-2.8~20110207.orig/examples/aws/0000755000175000017500000000000011750740340017012 5ustar xavierxavierpolyorb-2.8~20110207.orig/examples/aws/README0000644000175000017500000000101411750740337017674 0ustar xavierxavierExamples using the AWS application personality ---------------------------------------------- client_web client_soap where MUST be an URI, as AWS only handles URIs. So entering an IOR or a corbaloc will not work. server instantiates two servants: - one for the classical web - another for web services Keep in mind that a web server only accepts a few method names (get, post, etc.); so the web server will raise an exception if another method is invoked. The soap server will accept any method name. polyorb-2.8~20110207.orig/examples/aws/Makefile.local0000644000175000017500000000000011750740337021537 0ustar xavierxavierpolyorb-2.8~20110207.orig/examples/aws/client_soap.adb0000644000175000017500000000654511750740337022002 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- C L I E N T _ S O A P -- -- -- -- B o d y -- -- -- -- Copyright (C) 2003 Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by ACT Europe. -- -- (email: sales@act-europe.fr) -- -- -- ------------------------------------------------------------------------------ with Ada.Command_Line; use Ada.Command_Line; with Ada.Text_IO; use Ada.Text_IO; with AWS.Server; with SOAP.Client; with SOAP.Parameters; with SOAP.Types; with SOAP.Message.Payload; with SOAP.Message.Response; with PolyORB.Setup.No_Tasking_Server; pragma Warnings (Off, PolyORB.Setup.No_Tasking_Server); procedure Client_SOAP is use SOAP.Types; use SOAP.Client; use SOAP.Parameters; begin Put_Line ("client: initializing PolyORB"); AWS.Server.Initialization; Put_Line ("client: initialized"); if Argument_Count < 1 then Put_Line ("usage : client "); return; else declare P_Set : SOAP.Parameters.List := +SOAP.Types.S ("Hello, SOAP world!", "Mesg"); P : SOAP.Message.Payload.Object := SOAP.Message.Payload.Build ("echoString", P_Set); R : constant SOAP.Message.Response.Object'Class := SOAP.Client.Call (Ada.Command_Line.Argument (1), P); Rep : constant SOAP.Parameters.List := SOAP.Message.Parameters (R); Response : constant String := SOAP.Parameters.Get (Rep, "result"); begin Put_Line ("Client: sent SOAP request to " & Ada.Command_Line.Argument (1)); Put_Line ("Client: the server answered " & Response); end; end if; end Client_SOAP; polyorb-2.8~20110207.orig/examples/aws/local.gpr0000644000175000017500000000073111750740337020625 0ustar xavierxavierwith "polyorb", "polyorb_test_common"; project local is Dir := external ("Test_Dir"); Obj_Dir := PolyORB_Test_Common.Build_Dir & Dir; for Object_Dir use Obj_Dir; for Source_Dirs use (Obj_Dir, PolyORB_Test_Common.Source_Dir & Dir); package Compiler is for Default_Switches ("Ada") use PolyORB_Test_Common.Compiler'Default_Switches ("Ada"); end Compiler; for Main use ("server.adb", "client_soap.adb", "client_web.adb"); end local; polyorb-2.8~20110207.orig/examples/aws/client_web.adb0000644000175000017500000000610011750740337021600 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- C L I E N T _ W E B -- -- -- -- B o d y -- -- -- -- Copyright (C) 2003 Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by ACT Europe. -- -- (email: sales@act-europe.fr) -- -- -- ------------------------------------------------------------------------------ with Ada.Command_Line; use Ada.Command_Line; with Ada.Text_IO; use Ada.Text_IO; with AWS.Client; with AWS.Response; with AWS.Server; with PolyORB.Setup.No_Tasking_Server; pragma Warnings (Off, PolyORB.Setup.No_Tasking_Server); procedure Client_Web is begin Put_Line ("client: initializing PolyORB"); AWS.Server.Initialization; Put_Line ("client: initialized"); if Argument_Count < 1 then Put_Line ("usage : client "); return; else declare use AWS.Client; use AWS.Response; Connection : HTTP_Connection; Res : AWS.Response.Data; begin Create (Connection, Ada.Command_Line.Argument (1)); Get (Connection, Res, Ada.Command_Line.Argument (1) & "?Mesg=Hello, Web world!"); Close (Connection); Put_Line ("Client: sent Web request to " & Ada.Command_Line.Argument (1)); Put_Line ("Client: the server answered " & AWS.Response.Message_Body (Res)); end; end if; end Client_Web; polyorb-2.8~20110207.orig/examples/aws/server.adb0000644000175000017500000001250211750740337020776 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- S E R V E R -- -- -- -- B o d y -- -- -- -- Copyright (C) 2003 Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by ACT Europe. -- -- (email: sales@act-europe.fr) -- -- -- ------------------------------------------------------------------------------ with Ada.Text_IO; use Ada.Text_IO; with AWS.Server; with SOAP.Types; with SOAP.Parameters; with SOAP.Message; with SOAP.Message.Payload; with SOAP.Message.Response; with AWS.Server.Servants; with AWS.Status; with AWS.Response; with AWS.Parameters; with PolyORB.Setup.No_Tasking_Server; pragma Warnings (Off, PolyORB.Setup.No_Tasking_Server); with PolyORB.References.IOR; with PolyORB.References.URI; procedure Server is function Callback (Request : in AWS.Status.Data) return AWS.Response.Data; function Callback (Request : in AWS.Status.Data) return AWS.Response.Data is use AWS.Status; use AWS.Response; begin if Is_SOAP (Request) then declare use SOAP.Types; use SOAP.Parameters; use SOAP.Message; use SOAP.Message.Payload; SOAP_Object : SOAP.Message.Payload.Object := AWS.Status.Payload (Request); P_List : SOAP.Parameters.List := Parameters (SOAP_Object); Mesg : constant String := SOAP.Parameters.Get (P_List, "Mesg"); R : SOAP.Message.Response.Object; RP : SOAP.Parameters.List; begin Put_Line ("Server: " & Natural'Image (Argument_Count (P_List)) & " SOAP parameters"); Put_Line ("Server: method is " & Procedure_Name (SOAP_Object)); Put_Line ("Server: echoing """ & Mesg & """"); R := SOAP.Message.Response.From (SOAP_Object); RP := +S (Mesg, "result"); SOAP.Message.Set_Parameters (R, RP); return AWS.Response.Build (R); end; else declare P_List : constant AWS.Parameters.List := AWS.Status.Parameters (D => Request); Mesg : constant String := AWS.Parameters.Get (P_List, "Mesg"); begin Put_Line ("Server: the request is a web one"); Put_Line ("Server: echoing """ & Mesg & """"); return AWS.Response.Build ("text/html", Mesg); end; end if; end Callback; begin Put_Line ("initializing PolyORB"); AWS.Server.Initialization; Put_Line ("initialized"); declare SOAP_Server : AWS.Server.Servants.SOAP_Servant; Web_Server : AWS.Server.Servants.Web_Servant; begin Put_Line ("starting servers"); AWS.Server.Start (SOAP_Server, "soap_server", Max_Connection => 1, Callback => Callback'Unrestricted_Access); AWS.Server.Start (Web_Server, "web_server", Max_Connection => 1, Callback => Callback'Unrestricted_Access); Put_Line ("servers started"); Put_Line ("SOAP_Server:"); Put_Line (PolyORB.References.URI.Object_To_String (AWS.Server.Get_Server_Reference (SOAP_Server))); Put_Line ((PolyORB.References.IOR.Object_To_String (AWS.Server.Get_Server_Reference (SOAP_Server)))); Put_Line ("Web_Server:"); Put_Line (PolyORB.References.URI.Object_To_String (AWS.Server.Get_Server_Reference (Web_Server))); Put_Line ((PolyORB.References.IOR.Object_To_String (AWS.Server.Get_Server_Reference (Web_Server)))); AWS.Server.Run; end; end Server; polyorb-2.8~20110207.orig/testsuite/0000755000175000017500000000000011750740340016433 5ustar xavierxavierpolyorb-2.8~20110207.orig/testsuite/corba/0000755000175000017500000000000011750740340017521 5ustar xavierxavierpolyorb-2.8~20110207.orig/testsuite/corba/domainmanager/0000755000175000017500000000000011750740340022323 5ustar xavierxavierpolyorb-2.8~20110207.orig/testsuite/corba/domainmanager/test000/0000755000175000017500000000000011750740340023522 5ustar xavierxavierpolyorb-2.8~20110207.orig/testsuite/corba/domainmanager/test000/Makefile.local0000644000175000017500000000013211750740340026247 0ustar xavierxavier${current_dir}test.idl-stamp: idlac_flags := ${test_target}: ${current_dir}test.idl-stamp polyorb-2.8~20110207.orig/testsuite/corba/domainmanager/test000/corba-domainmanager-skel.adb0000644000175000017500000001772711750740340031032 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- C O R B A . D O M A I N M A N A G E R . S K E L -- -- -- -- B o d y -- -- -- -- Copyright (C) 2007-2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ pragma Style_Checks ("NM32766"); with PolyORB.Utils.Strings; with PolyORB.Initialization; pragma Elaborate_All (PolyORB.Initialization); with PolyORB.QoS.Exception_Informations; with CORBA.Policy.Helper; with CORBA.Policy; with CORBA.Helper; with PolyORB.Any; with PolyORB.CORBA_P.Domain_Management; with PolyORB.CORBA_P.IR_Hooks; with CORBA.Object.Helper; with CORBA.ORB; with CORBA.NVList; with PolyORB.Std; with CORBA.ServerRequest; with CORBA.DomainManager.Impl; with CORBA; pragma Elaborate_All (CORBA); with PortableServer; pragma Elaborate_All (PortableServer); with PolyORB.CORBA_P.Exceptions; package body CORBA.DomainManager.Skel is -- Skeleton subprograms function Servant_Is_A (Obj : PortableServer.Servant) return Boolean; function Servant_Is_A (Obj : PortableServer.Servant) return Boolean is begin return Obj.all in CORBA.DomainManager.Impl.Object'Class; end Servant_Is_A; Is_A_Arg_Name_Ü_Type_Id : constant CORBA.Identifier := CORBA.To_CORBA_String ("Type_Id"); get_domain_policy_Arg_Name_Ü_policy_type : constant CORBA.Identifier := CORBA.To_CORBA_String ("policy_type"); procedure Invoke (Self : PortableServer.Servant; Request : CORBA.ServerRequest.Object_Ptr) is Operation : constant PolyORB.Std.String := CORBA.To_Standard_String (CORBA.ServerRequest.Operation (Request.all)); Arg_List_Ü : CORBA.NVList.Ref; begin CORBA.ORB.Create_List (0, Arg_List_Ü); if Operation = "_is_a" then declare Type_Id : CORBA.String; Arg_Any_Ü_Type_Id : constant CORBA.Any := CORBA.To_Any (Type_Id); Result_Ü : CORBA.Boolean; begin CORBA.NVList.Add_Item (Arg_List_Ü, Is_A_Arg_Name_Ü_Type_Id, Arg_Any_Ü_Type_Id, CORBA.ARG_IN); CORBA.ServerRequest.Arguments (Request, Arg_List_Ü); begin -- Convert arguments from their Any Type_Id := CORBA.From_Any (Arg_Any_Ü_Type_Id); -- Call implementation Result_Ü := CORBA.DomainManager.Is_A (CORBA.To_Standard_String (Type_Id)); end; -- Set Result CORBA.ServerRequest.Set_Result (Request, CORBA.To_Any (Result_Ü)); end; elsif Operation = "_non_existent" or else Operation = "_not_existent" then CORBA.ServerRequest.Arguments (Request, Arg_List_Ü); CORBA.ServerRequest.Set_Result (Request, CORBA.To_Any (CORBA.Boolean'(False))); elsif Operation = "_interface" then CORBA.ServerRequest.Arguments (Request, Arg_List_Ü); CORBA.ServerRequest.Set_Result (Request, CORBA.Object.Helper.To_Any (CORBA.Object.Ref (PolyORB.CORBA_P.IR_Hooks.Get_Interface_Definition (CORBA.To_CORBA_String (Repository_Id))))); elsif Operation = "_domain_managers" then CORBA.ServerRequest.Arguments (Request, Arg_List_Ü); CORBA.ServerRequest.Set_Result (Request, PolyORB.CORBA_P.Domain_Management.Get_Domain_Managers (Self)); elsif Operation = "get_domain_policy" then declare Argument_Ü_policy_type : CORBA.PolicyType; pragma Warnings (Off, Argument_Ü_policy_type); Arg_CC_Ü_policy_type : aliased PolyORB.Any.Content'Class := CORBA.Wrap (CORBA.Unsigned_Long (Argument_Ü_policy_type)'Unrestricted_Access); Arg_Any_Ü_policy_type : constant CORBA.Any := CORBA.Internals.Get_Wrapper_Any (CORBA.Helper.TC_PolicyType, Arg_CC_Ü_policy_type'Unchecked_Access); Result_Ü : CORBA.Policy.Ref; pragma Warnings (Off, Result_Ü); Arg_CC_Ü_Result_Ü : aliased PolyORB.Any.Content'Class := CORBA.Object.Helper.Wrap (CORBA.Object.Ref (Result_Ü)'Unrestricted_Access); Arg_Any_Ü_Result_Ü : constant CORBA.Any := CORBA.Internals.Get_Wrapper_Any (CORBA.Policy.Helper.TC_Policy, Arg_CC_Ü_Result_Ü'Unchecked_Access); begin CORBA.NVList.Add_Item (Arg_List_Ü, get_domain_policy_Arg_Name_Ü_policy_type, Arg_Any_Ü_policy_type, CORBA.ARG_IN); CORBA.ServerRequest.Arguments (Request, Arg_List_Ü); begin Result_Ü := CORBA.DomainManager.Impl.get_domain_policy (CORBA.DomainManager.Impl.Object'Class (Self.all)'Access, Argument_Ü_policy_type); end; CORBA.ServerRequest.Set_Result (Request, Arg_Any_Ü_Result_Ü); return; end; else CORBA.Raise_Bad_Operation (CORBA.Default_Sys_Member); end if; exception when E : others => CORBA.ServerRequest.Set_Exception (Request, PolyORB.CORBA_P.Exceptions.System_Exception_To_Any (E)); PolyORB.QoS.Exception_Informations.Set_Exception_Information (Request.all, E); end Invoke; procedure Deferred_Initialization is begin PortableServer.Internals.Register_Skeleton (CORBA.DomainManager.Repository_Id, Servant_Is_A'Access, Is_A'Access, Invoke'Access); end Deferred_Initialization; begin declare use PolyORB.Initialization; use PolyORB.Initialization.String_Lists; use PolyORB.Utils.Strings; begin Register_Module (Module_Info' (Name => +"CORBA.DomainManager.Skel", Conflicts => PolyORB.Initialization.String_Lists.Empty, Depends => PolyORB.Initialization.String_Lists.Empty , Provides => PolyORB.Initialization.String_Lists.Empty, Implicit => False, Init => Deferred_Initialization'Access, Shutdown => null)); end; end CORBA.DomainManager.Skel; polyorb-2.8~20110207.orig/testsuite/corba/domainmanager/test000/test-echo-impl.ads0000644000175000017500000000040511750740340027044 0ustar xavierxavier with PortableServer; package Test.Echo.Impl is type Object is new PortableServer.Servant_Base with private; type Object_Ptr is access all Object'Class; private type Object is new PortableServer.Servant_Base with null record; end Test.Echo.Impl; polyorb-2.8~20110207.orig/testsuite/corba/domainmanager/test000/corba-domainmanager-impl.adb0000644000175000017500000000513411750740340031022 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- C O R B A . D O M A I N M A N A G E R . I M P L -- -- -- -- B o d y -- -- -- -- Copyright (C) 2005-2008, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with CORBA.DomainManager.Skel; pragma Warnings (Off, CORBA.DomainManager.Skel); package body CORBA.DomainManager.Impl is ----------------------- -- Get_Domain_Policy -- ----------------------- function Get_Domain_Policy (Self : access Object; Policy_Type : CORBA.PolicyType) return CORBA.Policy.Ref is pragma Unreferenced (Self); pragma Unreferenced (Policy_Type); Result : CORBA.Policy.Ref; begin CORBA.Raise_Inv_Policy (CORBA.Default_Sys_Member); return Result; end Get_Domain_Policy; end CORBA.DomainManager.Impl; polyorb-2.8~20110207.orig/testsuite/corba/domainmanager/test000/corba-domainmanager-skel.ads0000644000175000017500000000502211750740340031034 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- C O R B A . D O M A I N M A N A G E R . S K E L -- -- -- -- S p e c -- -- -- -- Copyright (C) 2007-2008, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the CORBA Specification, and adapted -- -- for use with PolyORB. The copyright notice above, and the license -- -- provisions that follow apply solely to the contents neither explicitly -- -- nor implicitly specified by the CORBA Specification defined by the OMG. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ pragma Style_Checks ("NM32766"); package CORBA.DomainManager.Skel is pragma Elaborate_Body; end CORBA.DomainManager.Skel; polyorb-2.8~20110207.orig/testsuite/corba/domainmanager/test000/local.gpr0000644000175000017500000000070211750740340025325 0ustar xavierxavierwith "polyorb", "polyorb_test_common"; project local is Dir := external ("Test_Dir"); Obj_Dir := PolyORB_Test_Common.Build_Dir & Dir; for Object_Dir use Obj_Dir; for Source_Dirs use (Obj_Dir, PolyORB_Test_Common.Source_Dir & Dir); package Compiler is for Default_Switches ("Ada") use PolyORB_Test_Common.Compiler'Default_Switches ("Ada"); end Compiler; for Main use ("server.adb", "client.adb"); end local; polyorb-2.8~20110207.orig/testsuite/corba/domainmanager/test000/test.idl0000644000175000017500000000016611750740340025176 0ustar xavierxavier import ::CORBA; module Test { interface DomainManager : CORBA::DomainManager { }; interface Echo { }; }; polyorb-2.8~20110207.orig/testsuite/corba/domainmanager/test000/server.adb0000644000175000017500000000672511750740340025512 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- S E R V E R -- -- -- -- B o d y -- -- -- -- Copyright (C) 2005-2007, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with Ada.Text_IO; with CORBA.Object; with CORBA.ORB; with PolyORB.CORBA_P.Server_Tools; with PortableServer.POA.Helper; with PortableServer.POAManager; with Test.DomainManager.Impl; with Test.DomainManager.Skel; pragma Warnings (Off, Test.DomainManager.Skel); with Test.Echo.Impl; with Test.Echo.Skel; pragma Warnings (Off, Test.Echo.Skel); with PolyORB.Setup.No_Tasking_Server; pragma Warnings (Off, PolyORB.Setup.No_Tasking_Server); procedure Server is Ref : CORBA.Object.Ref; begin CORBA.ORB.Initialize ("ORB"); PortableServer.POAManager.Activate (PortableServer.POA.Get_The_POAManager (PortableServer.POA.Helper.To_Local_Ref (CORBA.ORB.Resolve_Initial_References (CORBA.ORB.To_CORBA_String ("RootPOA"))))); declare Obj : constant Test.DomainManager.Impl.Object_Ptr := new Test.DomainManager.Impl.Object; Ref : CORBA.Object.Ref; begin PolyORB.CORBA_P.Server_Tools.Initiate_Servant (PortableServer.Servant (Obj), Ref); CORBA.ORB.Register_Initial_Reference (CORBA.ORB.To_CORBA_String ("PolyORBPolicyDomainManager"), Ref); end; declare Obj : constant Test.Echo.Impl.Object_Ptr := new Test.Echo.Impl.Object; begin PolyORB.CORBA_P.Server_Tools.Initiate_Servant (PortableServer.Servant (Obj), Ref); Ada.Text_IO.Put_Line (''' & CORBA.To_Standard_String (CORBA.Object.Object_To_String (Ref)) & '''); end; CORBA.ORB.Run; end Server; polyorb-2.8~20110207.orig/testsuite/corba/domainmanager/test000/corba-domainmanager-impl.ads0000644000175000017500000000550411750740340031044 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- C O R B A . D O M A I N M A N A G E R . I M P L -- -- -- -- S p e c -- -- -- -- Copyright (C) 2005-2008, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the CORBA Specification, and adapted -- -- for use with PolyORB. The copyright notice above, and the license -- -- provisions that follow apply solely to the contents neither explicitly -- -- nor implicitly specified by the CORBA Specification defined by the OMG. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with CORBA.Policy; with PortableServer; package CORBA.DomainManager.Impl is type Object is new PortableServer.Servant_Base with private; type Object_Ptr is access all Object'Class; function Get_Domain_Policy (Self : access Object; Policy_Type : CORBA.PolicyType) return CORBA.Policy.Ref; private type Object is new PortableServer.Servant_Base with null record; end CORBA.DomainManager.Impl; polyorb-2.8~20110207.orig/testsuite/corba/domainmanager/test000/test-domainmanager-impl.ads0000644000175000017500000000445711750740340030743 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- T E S T . D O M A I N M A N A G E R . I M P L -- -- -- -- S p e c -- -- -- -- Copyright (C) 2005 Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with CORBA.DomainManager.Impl; package Test.DomainManager.Impl is type Object is new CORBA.DomainManager.Impl.Object with private; type Object_Ptr is access all Object'Class; private type Object is new CORBA.DomainManager.Impl.Object with null record; end Test.DomainManager.Impl; polyorb-2.8~20110207.orig/testsuite/corba/domainmanager/test000/client.adb0000644000175000017500000000636511750740340025462 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- C L I E N T -- -- -- -- B o d y -- -- -- -- Copyright (C) 2005-2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with Ada.Command_Line; with CORBA.DomainManager; with CORBA.Object.Policies; with CORBA.ORB; with PolyORB.Setup.Client; pragma Warnings (Off, PolyORB.Setup.Client); with PolyORB.Utils.Report; procedure Client is Ref : CORBA.Object.Ref; M : CORBA.DomainManager.DomainManagersList; begin PolyORB.Utils.Report.New_Test ("CORBA::DomainManager"); CORBA.ORB.Initialize ("ORB"); CORBA.ORB.String_To_Object (CORBA.To_CORBA_String (Ada.Command_Line.Argument (1)), Ref); begin M := CORBA.Object.Policies.Get_Domain_Managers (Ref); PolyORB.Utils.Report.Output ("Getting domain managers list", True); exception when others => PolyORB.Utils.Report.Output ("Getting domain managers list", False); end; PolyORB.Utils.Report.Output ("Domain managers list not empty", CORBA.DomainManager.IDL_SEQUENCE_DomainManager.Length (M) /= 0); begin PolyORB.Utils.Report.Output ("Domain manager not null", not CORBA.DomainManager.Is_Nil (CORBA.DomainManager.IDL_SEQUENCE_DomainManager.Get_Element (M, 1))); exception when others => PolyORB.Utils.Report.Output ("Domain manager not null", False); end; PolyORB.Utils.Report.End_Report; end Client; polyorb-2.8~20110207.orig/testsuite/corba/portableinterceptor/0000755000175000017500000000000011750740340023610 5ustar xavierxavierpolyorb-2.8~20110207.orig/testsuite/corba/portableinterceptor/test000/0000755000175000017500000000000011750740340025007 5ustar xavierxavier././@LongLink0000000000000000000000000000015200000000000011563 Lustar rootrootpolyorb-2.8~20110207.orig/testsuite/corba/portableinterceptor/test000/test000_idl-orbinitializer-impl.adspolyorb-2.8~20110207.orig/testsuite/corba/portableinterceptor/test000/test000_idl-orbinitializer-imp0000644000175000017500000000527611750740340032602 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- T E S T 0 0 0 _ I D L . O R B I N I T I A L I Z E R . I M P L -- -- -- -- S p e c -- -- -- -- Copyright (C) 2004-2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with PortableInterceptor.ORBInitializer.Impl; with PortableInterceptor.ORBInitInfo; package Test000_Idl.ORBInitializer.Impl is type Object is new PortableInterceptor.ORBInitializer.Impl.Object with private; type Object_Ptr is access all Object'Class; function Is_A (Self : not null access Object; Logical_Type_Id : Standard.String) return Boolean; private type Object is new PortableInterceptor.ORBInitializer.Impl.Object with null record; -- Derived from PortableInterceptor::ORBInitializer. procedure Post_Init (Self : access Object; Info : PortableInterceptor.ORBInitInfo.Local_Ref); end Test000_Idl.ORBInitializer.Impl; ././@LongLink0000000000000000000000000000015100000000000011562 Lustar rootrootpolyorb-2.8~20110207.orig/testsuite/corba/portableinterceptor/test000/test000_idl-testinterface-impl.adspolyorb-2.8~20110207.orig/testsuite/corba/portableinterceptor/test000/test000_idl-testinterface-impl0000644000175000017500000000522411750740340032561 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- T E S T 0 0 0 _ I D L . T E S T I N T E R F A C E . I M P L -- -- -- -- S p e c -- -- -- -- Copyright (C) 2004-2008, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by ACT Europe. -- -- (email: sales@act-europe.fr) -- -- -- ------------------------------------------------------------------------------ with PortableServer; package Test000_Idl.TestInterface.Impl is type Object is new PortableServer.Servant_Base with private; type Object_Ptr is access all Object'Class; procedure Proc (Self : access Object); procedure Process_Normal (Self : access Object); procedure Raise_Exception (Self : access Object); procedure Init (Self : access Object; Name : String); private type Process_State is (Normal, Raise_Exception); type Object is new PortableServer.Servant_Base with record Name : CORBA.String; State : Process_State := Normal; end record; end Test000_Idl.TestInterface.Impl; polyorb-2.8~20110207.orig/testsuite/corba/portableinterceptor/test000/Makefile.local0000644000175000017500000000015011750740340027534 0ustar xavierxavier${current_dir}test000_idl.idl-stamp: idlac_flags := ${test_target}: ${current_dir}test000_idl.idl-stamp ././@LongLink0000000000000000000000000000015500000000000011566 Lustar rootrootpolyorb-2.8~20110207.orig/testsuite/corba/portableinterceptor/test000/test000_idl-serverinterceptor-impl.adspolyorb-2.8~20110207.orig/testsuite/corba/portableinterceptor/test000/test000_idl-serverinterceptor-0000644000175000017500000000745711750740340032636 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- T E S T 0 0 0 _ I D L . S E R V E R I N T E R C E P T O R . I M P L -- -- -- -- S p e c -- -- -- -- Copyright (C) 2004-2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with CORBA; with PortableInterceptor.ServerRequestInfo; with PortableInterceptor.ServerRequestInterceptor.Impl; package Test000_Idl.ServerInterceptor.Impl is type Object is new PortableInterceptor.ServerRequestInterceptor.Impl.Object with private; type Object_Ptr is access all Object'Class; procedure Init (Self : access Object; Name : Standard.String); procedure Set_Behavior (Self : access Object; Point : Server_Interception_Point; Behavior : Interceptor_Behavior); procedure Enable (Self : access Object); procedure Disable (Self : access Object); function Is_A (Self : not null access Object; Logical_Type_Id : Standard.String) return Boolean; private type State_Array is array (Server_Interception_Point) of Interceptor_Behavior; type Object is new PortableInterceptor.ServerRequestInterceptor.Impl.Object with record Name : CORBA.String; State : State_Array; Active : Boolean; end record; -- Derived from Interceptor. function Get_Name (Self : access Object) return CORBA.String; -- Derived from ServerRequestInterceptor. procedure Receive_Request_Service_Contexts (Self : access Object; RI : PortableInterceptor.ServerRequestInfo.Local_Ref); procedure Receive_Request (Self : access Object; RI : PortableInterceptor.ServerRequestInfo.Local_Ref); procedure Send_Reply (Self : access Object; RI : PortableInterceptor.ServerRequestInfo.Local_Ref); procedure Send_Exception (Self : access Object; RI : PortableInterceptor.ServerRequestInfo.Local_Ref); procedure Send_Other (Self : access Object; RI : PortableInterceptor.ServerRequestInfo.Local_Ref); end Test000_Idl.ServerInterceptor.Impl; polyorb-2.8~20110207.orig/testsuite/corba/portableinterceptor/test000/test000_globals.adb0000644000175000017500000001305111750740340030361 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- T E S T 0 0 0 _ G L O B A L S -- -- -- -- B o d y -- -- -- -- Copyright (C) 2004-2008, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by ACT Europe. -- -- (email: sales@act-europe.fr) -- -- -- ------------------------------------------------------------------------------ with Ada.Text_IO; with PolyORB.Utils.Chained_Lists; package body Test000_Globals is package Log_Lists is new PolyORB.Utils.Chained_Lists (Log_Record); Log : Log_Lists.List; --------------- -- Clear_Log -- --------------- procedure Clear_Log is begin Log := Log_Lists.Empty; end Clear_Log; --------------------------------- -- Disable_Client_Interceptors -- --------------------------------- procedure Disable_Client_Interceptors is begin Test000_Idl.ClientInterceptor.Disable (Client_A); Test000_Idl.ClientInterceptor.Disable (Client_B); Test000_Idl.ClientInterceptor.Disable (Client_C); end Disable_Client_Interceptors; --------------------------------- -- Disable_Server_Interceptors -- --------------------------------- procedure Disable_Server_Interceptors is begin Test000_Idl.ServerInterceptor.Disable (Server_A); Test000_Idl.ServerInterceptor.Disable (Server_B); Test000_Idl.ServerInterceptor.Disable (Server_C); end Disable_Server_Interceptors; -------------------------------- -- Enable_Client_Interceptors -- -------------------------------- procedure Enable_Client_Interceptors is begin Test000_Idl.ClientInterceptor.Enable (Client_A); Test000_Idl.ClientInterceptor.Enable (Client_B); Test000_Idl.ClientInterceptor.Enable (Client_C); end Enable_Client_Interceptors; -------------------------------- -- Enable_Server_Interceptors -- -------------------------------- procedure Enable_Server_Interceptors is begin Test000_Idl.ServerInterceptor.Enable (Server_A); Test000_Idl.ServerInterceptor.Enable (Server_B); Test000_Idl.ServerInterceptor.Enable (Server_C); end Enable_Server_Interceptors; ------------- -- Get_Log -- ------------- function Get_Log return Log_Array is Result : Log_Array (1 .. Log_Lists.Length (Log)); begin for J in Result'Range loop Result (J) := Log_Lists.Element (Log, J - 1).all; end loop; return Result; end Get_Log; --------------- -- Log_Point -- --------------- procedure Log_Point (Name : String) is begin Log_Lists.Append (Log, (Object, Name (Name'First))); end Log_Point; --------------- -- Log_Point -- --------------- procedure Log_Point (Name : String; Point : Test000_Idl.ClientInterceptor.Client_Interception_Point) is begin Log_Lists.Append (Log, (Client, Name (Name'First), Point)); end Log_Point; --------------- -- Log_Point -- --------------- procedure Log_Point (Name : String; Point : Test000_Idl.ServerInterceptor.Server_Interception_Point) is begin Log_Lists.Append (Log, (Server, Name (Name'First), Point)); end Log_Point; ------------ -- Output -- ------------ procedure Output (Log : Log_Array) is use Ada.Text_IO; begin for J in Log'Range loop Put (Log_Source'Image (Log (J).Source)); Put (' '); Put (Log (J).Name); Put (' '); case Log (J).Source is when Client => Put (Test000_Idl.ClientInterceptor.Client_Interception_Point'Image (Log (J).Client_Point)); when Server => Put (Test000_Idl.ServerInterceptor.Server_Interception_Point'Image (Log (J).Server_Point)); when Object => null; end case; New_Line; end loop; end Output; end Test000_Globals; polyorb-2.8~20110207.orig/testsuite/corba/portableinterceptor/test000/test000_idl.idl0000644000175000017500000000273311750740340027535 0ustar xavierxavier import ::PortableInterceptor; module Test000_Idl { interface TestInterface { exception TestException {}; void Proc () raises (TestException); // Special operations for setting up client behavior. void Process_Normal (); void Raise_Exception (); }; enum Interceptor_Behavior { Do_Nothing, Raise_Exception, Forward}; local interface ClientInterceptor : PortableInterceptor::ClientRequestInterceptor { enum Client_Interception_Point { Client_Send_Request, Client_Send_Poll, Client_Receive_Reply, Client_Receive_Exception, Client_Receive_Other}; void Set_Behavior ( in Client_Interception_Point Point, in Interceptor_Behavior Behavior); void Enable (); void Disable (); }; local interface ServerInterceptor : PortableInterceptor::ServerRequestInterceptor { enum Server_Interception_Point { Server_Receive_Request_Service_Contexts, Server_Receive_Request, Server_Send_Reply, Server_Send_Exception, Server_Send_Other}; void Set_Behavior ( in Server_Interception_Point Point, in Interceptor_Behavior Behavior); void Enable (); void Disable (); }; local interface ORBInitializer : PortableInterceptor::ORBInitializer { }; }; ././@LongLink0000000000000000000000000000015500000000000011566 Lustar rootrootpolyorb-2.8~20110207.orig/testsuite/corba/portableinterceptor/test000/test000_idl-clientinterceptor-impl.adspolyorb-2.8~20110207.orig/testsuite/corba/portableinterceptor/test000/test000_idl-clientinterceptor-0000644000175000017500000000743711750740340032604 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- T E S T 0 0 0 _ I D L . C L I E N T I N T E R C E P T O R . I M P L -- -- -- -- S p e c -- -- -- -- Copyright (C) 2004-2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with CORBA; with PortableInterceptor.ClientRequestInfo; with PortableInterceptor.ClientRequestInterceptor.Impl; package Test000_Idl.ClientInterceptor.Impl is type Object is new PortableInterceptor.ClientRequestInterceptor.Impl.Object with private; type Object_Ptr is access all Object'Class; procedure Init (Self : access Object; Name : Standard.String); procedure Set_Behavior (Self : access Object; Point : Client_Interception_Point; Behavior : Interceptor_Behavior); procedure Enable (Self : access Object); procedure Disable (Self : access Object); function Is_A (Self : not null access Object; Logical_Type_Id : Standard.String) return Boolean; private type State_Array is array (Client_Interception_Point) of Interceptor_Behavior; type Object is new PortableInterceptor.ClientRequestInterceptor.Impl.Object with record Name : CORBA.String; State : State_Array; Active : Boolean; end record; -- Derived from Interceptor. function Get_Name (Self : access Object) return CORBA.String; -- Derived from ClientRequestInterceptor. procedure Send_Request (Self : access Object; RI : PortableInterceptor.ClientRequestInfo.Local_Ref); procedure Send_Poll (Self : access Object; RI : PortableInterceptor.ClientRequestInfo.Local_Ref); procedure Receive_Reply (Self : access Object; RI : PortableInterceptor.ClientRequestInfo.Local_Ref); procedure Receive_Exception (Self : access Object; RI : PortableInterceptor.ClientRequestInfo.Local_Ref); procedure Receive_Other (Self : access Object; RI : PortableInterceptor.ClientRequestInfo.Local_Ref); end Test000_Idl.ClientInterceptor.Impl; polyorb-2.8~20110207.orig/testsuite/corba/portableinterceptor/test000/test000.adb0000644000175000017500000004202011750740340026654 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- T E S T 0 0 0 -- -- -- -- B o d y -- -- -- -- Copyright (C) 2004 Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by ACT Europe. -- -- (email: sales@act-europe.fr) -- -- -- ------------------------------------------------------------------------------ with CORBA; with CORBA.Object; with CORBA.ORB; with PortableInterceptor.ORBInitializer.Register; with PortableInterceptor.ORBInitializer.Initialize_All; with PortableServer; with PolyORB.CORBA_P.Server_Tools; with PolyORB.Setup.Thread_Pool_Server; pragma Warnings (Off, PolyORB.Setup.Thread_Pool_Server); with PolyORB.Tasking.Threads; pragma Warnings (Off, PolyORB.Tasking.Threads); with PolyORB.Smart_Pointers; with PolyORB.Utils.Report; use PolyORB.Utils.Report; with Test000_Globals; use Test000_Globals; with Test000_Idl; use Test000_Idl; with Test000_Idl.ClientInterceptor; use Test000_Idl.ClientInterceptor; with Test000_Idl.ServerInterceptor; use Test000_Idl.ServerInterceptor; with Test000_Idl.TestInterface; with Test000_Idl.TestInterface.Impl; with Test000_Idl.TestInterface.Helper; with Test000_Idl.ORBInitializer; with Test000_Idl.ORBInitializer.Impl; procedure Test000 is procedure Init_Test; procedure Init_Test is use PolyORB.CORBA_P.Server_Tools; begin CORBA.ORB.Initialize ("ORB"); declare Ptr : constant Test000_Idl.ORBInitializer.Impl.Object_Ptr := new Test000_Idl.ORBInitializer.Impl.Object; Ref : Test000_Idl.ORBInitializer.Local_Ref; begin Test000_Idl.ORBInitializer.Set (Ref, PolyORB.Smart_Pointers.Entity_Ptr (Ptr)); PortableInterceptor.ORBInitializer.Register (PortableInterceptor.ORBInitializer.Local_Ref (Ref)); end; PortableInterceptor.ORBInitializer.Initialize_All; Initiate_Server (True); end Init_Test; begin New_Test ("Interceptor Flow"); Init_Test; declare use PolyORB.CORBA_P.Server_Tools; Ptr : Test000_Idl.TestInterface.Impl.Object_Ptr; Ref : CORBA.Object.Ref; begin Ptr := new Test000_Idl.TestInterface.Impl.Object; Test000_Idl.TestInterface.Impl.Init (Ptr, "1"); Initiate_Servant (PortableServer.Servant (Ptr), Ref); Test000_Globals.Object_1 := Test000_Idl.TestInterface.Helper.To_Ref (Ref); end; -- Client Scenario 1: normal processing. Test000_Globals.Clear_Log; Test000_Globals.Enable_Client_Interceptors; declare Log : constant Log_Array := ((Client, 'A', Client_Send_Request), (Client, 'B', Client_Send_Request), (Client, 'C', Client_Send_Request), (Object, '1'), (Client, 'C', Client_Receive_Reply), (Client, 'B', Client_Receive_Reply), (Client, 'A', Client_Receive_Reply)); begin Test000_Idl.TestInterface.Proc (Test000_Globals.Object_1); if Get_Log = Log then Output ("Client Scenario 1", True); else Output ("Client Scenario 1", False); end if; exception when others => Output ("Client Scenario 1", False); end; Test000_Globals.Disable_Client_Interceptors; -- Client Scenario 2: exception arrives from server. Test000_Globals.Clear_Log; Test000_Idl.TestInterface.Raise_Exception (Test000_Globals.Object_1); Test000_Globals.Enable_Client_Interceptors; declare Log : constant Log_Array := ((Client, 'A', Client_Send_Request), (Client, 'B', Client_Send_Request), (Client, 'C', Client_Send_Request), (Object, '1'), (Client, 'C', Client_Receive_Exception), (Client, 'B', Client_Receive_Exception), (Client, 'A', Client_Receive_Exception)); begin Test000_Idl.TestInterface.Proc (Test000_Globals.Object_1); Output ("Client Scenario 2", False); exception when Test000_Idl.TestInterface.TestException => if Get_Log = Log then Output ("Client Scenario 2", True); else Output ("Client Scenario 2", False); end if; when others => Output ("Client Scenario 2", False); end; Test000_Globals.Disable_Client_Interceptors; Test000_Idl.TestInterface.Process_Normal (Test000_Globals.Object_1); -- Client Scenario 3: B.send_request raises exception. Test000_Globals.Clear_Log; Test000_Idl.ClientInterceptor.Set_Behavior (Test000_Globals.Client_B, Client_Send_Request, Raise_Exception); Test000_Globals.Enable_Client_Interceptors; declare Log : constant Log_Array := ((Client, 'A', Client_Send_Request), (Client, 'B', Client_Send_Request), (Client, 'A', Client_Receive_Exception)); begin Test000_Idl.TestInterface.Proc (Test000_Globals.Object_1); Output ("Client Scenario 3", False); exception when CORBA.No_Permission => if Get_Log = Log then Output ("Client Scenario 3", True); else Output ("Client Scenario 3", False); end if; when others => Output ("Client Scenario 3", False); end; Test000_Globals.Disable_Client_Interceptors; Test000_Idl.ClientInterceptor.Set_Behavior (Test000_Globals.Client_B, Client_Send_Request, Do_Nothing); -- Client Scenario 4: B.receive_reply raises exception. Test000_Globals.Clear_Log; Test000_Idl.ClientInterceptor.Set_Behavior (Test000_Globals.Client_B, Client_Receive_Reply, Raise_Exception); Test000_Globals.Enable_Client_Interceptors; declare Log : constant Log_Array := ((Client, 'A', Client_Send_Request), (Client, 'B', Client_Send_Request), (Client, 'C', Client_Send_Request), (Object, '1'), (Client, 'C', Client_Receive_Reply), (Client, 'B', Client_Receive_Reply), (Client, 'A', Client_Receive_Exception)); begin Test000_Idl.TestInterface.Proc (Test000_Globals.Object_1); Output ("Client Scenario 4", False); exception when CORBA.No_Permission => if Get_Log = Log then Output ("Client Scenario 4", True); else Output ("Client Scenario 4", False); end if; when others => Output ("Client Scenario 4", False); end; Test000_Globals.Disable_Client_Interceptors; Test000_Idl.ClientInterceptor.Set_Behavior (Test000_Globals.Client_B, Client_Receive_Reply, Do_Nothing); -- Client Scenario 5: exception arrives from server and -- B.receive_exception raise another exception. Test000_Globals.Clear_Log; Test000_Idl.TestInterface.Raise_Exception (Test000_Globals.Object_1); Test000_Idl.ClientInterceptor.Set_Behavior (Test000_Globals.Client_B, Client_Receive_Exception, Raise_Exception); Test000_Globals.Enable_Client_Interceptors; declare Log : constant Log_Array := ((Client, 'A', Client_Send_Request), (Client, 'B', Client_Send_Request), (Client, 'C', Client_Send_Request), (Object, '1'), (Client, 'C', Client_Receive_Exception), (Client, 'B', Client_Receive_Exception), (Client, 'A', Client_Receive_Exception)); begin Test000_Idl.TestInterface.Proc (Test000_Globals.Object_1); Output ("Client Scenario 5", False); exception when CORBA.No_Permission => if Get_Log = Log then Output ("Client Scenario 5", True); else Output ("Client Scenario 5", False); end if; when others => Output ("Client Scenario 5", False); end; Test000_Globals.Disable_Client_Interceptors; Test000_Idl.ClientInterceptor.Set_Behavior (Test000_Globals.Client_B, Client_Receive_Exception, Do_Nothing); Test000_Idl.TestInterface.Process_Normal (Test000_Globals.Object_1); -- Server Scenario 1: normal execution. Test000_Globals.Clear_Log; Test000_Globals.Enable_Server_Interceptors; declare Log : constant Log_Array := ((Server, 'A', Server_Receive_Request_Service_Contexts), (Server, 'B', Server_Receive_Request_Service_Contexts), (Server, 'C', Server_Receive_Request_Service_Contexts), (Server, 'A', Server_Receive_Request), (Server, 'B', Server_Receive_Request), (Server, 'C', Server_Receive_Request), (Object, '1'), (Server, 'C', Server_Send_Reply), (Server, 'B', Server_Send_Reply), (Server, 'A', Server_Send_Reply)); begin Test000_Idl.TestInterface.Proc (Test000_Globals.Object_1); if Get_Log = Log then Output ("Server Scenario 1", True); else Output ("Server Scenario 1", False); end if; exception when others => Output ("Server Scenario 1", False); end; Test000_Globals.Disable_Server_Interceptors; -- Server Scenario 2: exception. Test000_Globals.Clear_Log; Test000_Idl.TestInterface.Raise_Exception (Test000_Globals.Object_1); Test000_Globals.Enable_Server_Interceptors; declare Log : constant Log_Array := ((Server, 'A', Server_Receive_Request_Service_Contexts), (Server, 'B', Server_Receive_Request_Service_Contexts), (Server, 'C', Server_Receive_Request_Service_Contexts), (Server, 'A', Server_Receive_Request), (Server, 'B', Server_Receive_Request), (Server, 'C', Server_Receive_Request), (Object, '1'), (Server, 'C', Server_Send_Exception), (Server, 'B', Server_Send_Exception), (Server, 'A', Server_Send_Exception)); begin Test000_Idl.TestInterface.Proc (Test000_Globals.Object_1); Output ("Server Scenario 2", False); exception when Test000_Idl.TestInterface.TestException => if Get_Log = Log then Output ("Server Scenario 2", True); else Output ("Server Scenario 2", False); end if; when others => Output ("Server Scenario 2", False); end; Test000_Globals.Disable_Server_Interceptors; Test000_Idl.TestInterface.Process_Normal (Test000_Globals.Object_1); -- Server Scenario 3: exception. Test000_Globals.Clear_Log; Test000_Idl.ServerInterceptor.Set_Behavior (Test000_Globals.Server_B, Server_Receive_Request_Service_Contexts, Raise_Exception); Test000_Globals.Enable_Server_Interceptors; declare Log : constant Log_Array := ((Server, 'A', Server_Receive_Request_Service_Contexts), (Server, 'B', Server_Receive_Request_Service_Contexts), (Server, 'A', Server_Send_Exception)); begin Test000_Idl.TestInterface.Proc (Test000_Globals.Object_1); Output ("Server Scenario 3", False); exception when CORBA.No_Permission => if Get_Log = Log then Output ("Server Scenario 3", True); else Output ("Server Scenario 3", False); end if; when others => Output ("Server Scenario 3", False); end; Test000_Globals.Disable_Server_Interceptors; Test000_Idl.ServerInterceptor.Set_Behavior (Test000_Globals.Server_B, Server_Receive_Request_Service_Contexts, Do_Nothing); -- Server Scenario 4: B.Receive_Request raise exception. Test000_Globals.Clear_Log; Test000_Idl.ServerInterceptor.Set_Behavior (Test000_Globals.Server_B, Server_Receive_Request, Raise_Exception); Test000_Globals.Enable_Server_Interceptors; declare Log : constant Log_Array := ((Server, 'A', Server_Receive_Request_Service_Contexts), (Server, 'B', Server_Receive_Request_Service_Contexts), (Server, 'C', Server_Receive_Request_Service_Contexts), (Server, 'A', Server_Receive_Request), (Server, 'B', Server_Receive_Request), (Server, 'C', Server_Send_Exception), (Server, 'B', Server_Send_Exception), (Server, 'A', Server_Send_Exception)); begin Test000_Idl.TestInterface.Proc (Test000_Globals.Object_1); Output ("Server Scenario 4", False); exception when CORBA.No_Permission => if Get_Log = Log then Output ("Server Scenario 4", True); else Output ("Server Scenario 4", False); end if; when others => Output ("Server Scenario 4", False); end; Test000_Globals.Disable_Server_Interceptors; Test000_Idl.ServerInterceptor.Set_Behavior (Test000_Globals.Server_B, Server_Receive_Request, Do_Nothing); -- Server Scenario 5: B.Send_Reply raise exception. Test000_Globals.Clear_Log; Test000_Idl.ServerInterceptor.Set_Behavior (Test000_Globals.Server_B, Server_Send_Reply, Raise_Exception); Test000_Globals.Enable_Server_Interceptors; declare Log : constant Log_Array := ((Server, 'A', Server_Receive_Request_Service_Contexts), (Server, 'B', Server_Receive_Request_Service_Contexts), (Server, 'C', Server_Receive_Request_Service_Contexts), (Server, 'A', Server_Receive_Request), (Server, 'B', Server_Receive_Request), (Server, 'C', Server_Receive_Request), (Object, '1'), (Server, 'C', Server_Send_Reply), (Server, 'B', Server_Send_Reply), (Server, 'A', Server_Send_Exception)); begin Test000_Idl.TestInterface.Proc (Test000_Globals.Object_1); Output ("Server Scenario 5", False); exception when CORBA.No_Permission => if Get_Log = Log then Output ("Server Scenario 5", True); else Output ("Server Scenario 5", False); end if; when others => Output ("Server Scenario 5", False); end; Test000_Globals.Disable_Server_Interceptors; Test000_Idl.ServerInterceptor.Set_Behavior (Test000_Globals.Server_B, Server_Send_Reply, Do_Nothing); -- Server Scenario 6: target raise exception and B.Send_Exception -- raise another exception. Test000_Globals.Clear_Log; Test000_Idl.TestInterface.Raise_Exception (Test000_Globals.Object_1); Test000_Idl.ServerInterceptor.Set_Behavior (Test000_Globals.Server_B, Server_Send_Exception, Raise_Exception); Test000_Globals.Enable_Server_Interceptors; declare Log : constant Log_Array := ((Server, 'A', Server_Receive_Request_Service_Contexts), (Server, 'B', Server_Receive_Request_Service_Contexts), (Server, 'C', Server_Receive_Request_Service_Contexts), (Server, 'A', Server_Receive_Request), (Server, 'B', Server_Receive_Request), (Server, 'C', Server_Receive_Request), (Object, '1'), (Server, 'C', Server_Send_Exception), (Server, 'B', Server_Send_Exception), (Server, 'A', Server_Send_Exception)); begin Test000_Idl.TestInterface.Proc (Test000_Globals.Object_1); Output ("Server Scenario 6", False); exception when CORBA.No_Permission => if Get_Log = Log then Output ("Server Scenario 6", True); else Output ("Server Scenario 6", False); end if; when others => Output ("Server Scenario 6", False); end; Test000_Globals.Disable_Server_Interceptors; Test000_Idl.ServerInterceptor.Set_Behavior (Test000_Globals.Server_B, Server_Send_Exception, Do_Nothing); Test000_Idl.TestInterface.Process_Normal (Test000_Globals.Object_1); End_Report; CORBA.ORB.Shutdown (False); end Test000; ././@LongLink0000000000000000000000000000015500000000000011566 Lustar rootrootpolyorb-2.8~20110207.orig/testsuite/corba/portableinterceptor/test000/test000_idl-clientinterceptor-impl.adbpolyorb-2.8~20110207.orig/testsuite/corba/portableinterceptor/test000/test000_idl-clientinterceptor-0000644000175000017500000001611011750740340032570 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- T E S T 0 0 0 _ I D L . C L I E N T I N T E R C E P T O R . I M P L -- -- -- -- B o d y -- -- -- -- Copyright (C) 2004-2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with PortableInterceptor.Interceptor; with PortableInterceptor.ClientRequestInterceptor; with Test000_Globals; package body Test000_Idl.ClientInterceptor.Impl is ------------- -- Disable -- ------------- procedure Disable (Self : access Object) is begin Self.Active := False; end Disable; ------------ -- Enable -- ------------ procedure Enable (Self : access Object) is begin Self.Active := True; end Enable; -------------- -- Get_Name -- -------------- function Get_Name (Self : access Object) return CORBA.String is begin return Self.Name; end Get_Name; ---------- -- Init -- ---------- procedure Init (Self : access Object; Name : Standard.String) is begin Self.Name := CORBA.To_CORBA_String (Name); Self.State := (others => Do_Nothing); Self.Active := False; end Init; ---------- -- Is_A -- ---------- function Is_A (Self : not null access Object; Logical_Type_Id : Standard.String) return Boolean is pragma Unreferenced (Self); begin return CORBA.Is_Equivalent (Logical_Type_Id, Test000_Idl.ClientInterceptor.Repository_Id) or else CORBA.Is_Equivalent (Logical_Type_Id, PortableInterceptor.ClientRequestInterceptor.Repository_Id) or else CORBA.Is_Equivalent (Logical_Type_Id, PortableInterceptor.Interceptor.Repository_Id) or else CORBA.Is_Equivalent (Logical_Type_Id, "IDL:omg.org/CORBA/Object:1.0"); end Is_A; ----------------------- -- Receive_Exception -- ----------------------- procedure Receive_Exception (Self : access Object; RI : PortableInterceptor.ClientRequestInfo.Local_Ref) is pragma Unreferenced (RI); begin if not Self.Active then return; end if; Test000_Globals.Log_Point (CORBA.To_Standard_String (Self.Name), Client_Receive_Exception); case Self.State (Client_Receive_Exception) is when Do_Nothing => null; when Raise_Exception => CORBA.Raise_No_Permission (CORBA.Default_Sys_Member); when others => raise Program_Error; end case; end Receive_Exception; ------------------- -- Receive_Other -- ------------------- procedure Receive_Other (Self : access Object; RI : PortableInterceptor.ClientRequestInfo.Local_Ref) is pragma Unreferenced (RI); begin if not Self.Active then return; end if; Test000_Globals.Log_Point (CORBA.To_Standard_String (Self.Name), Client_Receive_Other); case Self.State (Client_Receive_Other) is when Do_Nothing => null; when others => raise Program_Error; end case; end Receive_Other; ------------------- -- Receive_Reply -- ------------------- procedure Receive_Reply (Self : access Object; RI : PortableInterceptor.ClientRequestInfo.Local_Ref) is pragma Unreferenced (RI); begin if not Self.Active then return; end if; Test000_Globals.Log_Point (CORBA.To_Standard_String (Self.Name), Client_Receive_Reply); case Self.State (Client_Receive_Reply) is when Do_Nothing => null; when Raise_Exception => CORBA.Raise_No_Permission (CORBA.Default_Sys_Member); when others => raise Program_Error; end case; end Receive_Reply; ------------------ -- Send_Request -- ------------------ procedure Send_Request (Self : access Object; RI : PortableInterceptor.ClientRequestInfo.Local_Ref) is pragma Unreferenced (RI); begin if not Self.Active then return; end if; Test000_Globals.Log_Point (CORBA.To_Standard_String (Self.Name), Client_Send_Request); case Self.State (Client_Send_Request) is when Do_Nothing => null; when Raise_Exception => CORBA.Raise_No_Permission (CORBA.Default_Sys_Member); when others => raise Program_Error; end case; end Send_Request; --------------- -- Send_Poll -- --------------- procedure Send_Poll (Self : access Object; RI : PortableInterceptor.ClientRequestInfo.Local_Ref) is pragma Unreferenced (RI); begin if not Self.Active then return; end if; Test000_Globals.Log_Point (CORBA.To_Standard_String (Self.Name), Client_Send_Poll); case Self.State (Client_Send_Poll) is when Do_Nothing => null; when others => raise Program_Error; end case; end Send_Poll; ------------------ -- Set_Behavior -- ------------------ procedure Set_Behavior (Self : access Object; Point : Client_Interception_Point; Behavior : Interceptor_Behavior) is begin Self.State (Point) := Behavior; end Set_Behavior; end Test000_Idl.ClientInterceptor.Impl; ././@LongLink0000000000000000000000000000015100000000000011562 Lustar rootrootpolyorb-2.8~20110207.orig/testsuite/corba/portableinterceptor/test000/test000_idl-testinterface-impl.adbpolyorb-2.8~20110207.orig/testsuite/corba/portableinterceptor/test000/test000_idl-testinterface-impl0000644000175000017500000000632711750740340032566 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- T E S T 0 0 0 _ I D L . T E S T I N T E R F A C E . I M P L -- -- -- -- B o d y -- -- -- -- Copyright (C) 2004-2008, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with Test000_Idl.TestInterface.Helper; with Test000_Idl.TestInterface.Skel; pragma Warnings (Off, Test000_Idl.TestInterface.Skel); with Test000_Globals; package body Test000_Idl.TestInterface.Impl is ---------- -- Init -- ---------- procedure Init (Self : access Object; Name : String) is begin Self.Name := CORBA.To_CORBA_String (Name); end Init; ---------- -- Proc -- ---------- procedure Proc (Self : access Object) is begin Test000_Globals.Log_Point (CORBA.To_Standard_String (Self.Name)); if Self.State = Normal then null; else Test000_Idl.TestInterface.Helper.Raise_TestException (TestException_Members' (CORBA.IDL_Exception_Members with null record)); end if; end Proc; -------------------- -- Process_Normal -- -------------------- procedure Process_Normal (Self : access Object) is begin Self.State := Normal; end Process_Normal; --------------------- -- Raise_Exception -- --------------------- procedure Raise_Exception (Self : access Object) is begin Self.State := Raise_Exception; end Raise_Exception; end Test000_Idl.TestInterface.Impl; polyorb-2.8~20110207.orig/testsuite/corba/portableinterceptor/test000/test000_globals.ads0000644000175000017500000000714111750740340030405 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- T E S T 0 0 0 _ G L O B A L S -- -- -- -- S p e c -- -- -- -- Copyright (C) 2004-2008, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by ACT Europe. -- -- (email: sales@act-europe.fr) -- -- -- ------------------------------------------------------------------------------ with Test000_Idl.ClientInterceptor; with Test000_Idl.ServerInterceptor; with Test000_Idl.TestInterface; package Test000_Globals is Client_A : Test000_Idl.ClientInterceptor.Local_Ref; Client_B : Test000_Idl.ClientInterceptor.Local_Ref; Client_C : Test000_Idl.ClientInterceptor.Local_Ref; Server_A : Test000_Idl.ServerInterceptor.Local_Ref; Server_B : Test000_Idl.ServerInterceptor.Local_Ref; Server_C : Test000_Idl.ServerInterceptor.Local_Ref; Object_1 : Test000_Idl.TestInterface.Ref; procedure Enable_Client_Interceptors; procedure Disable_Client_Interceptors; procedure Enable_Server_Interceptors; procedure Disable_Server_Interceptors; type Log_Source is (Client, Object, Server); type Log_Record (Source : Log_Source := Object) is record Name : Character; case Source is when Object => null; when Client => Client_Point : Test000_Idl.ClientInterceptor.Client_Interception_Point; when Server => Server_Point : Test000_Idl.ServerInterceptor.Server_Interception_Point; end case; end record; type Log_Array is array (Positive range <>) of Log_Record; procedure Log_Point (Name : String); procedure Log_Point (Name : String; Point : Test000_Idl.ClientInterceptor.Client_Interception_Point); procedure Log_Point (Name : String; Point : Test000_Idl.ServerInterceptor.Server_Interception_Point); procedure Clear_Log; function Get_Log return Log_Array; procedure Output (Log : Log_Array); end Test000_Globals; ././@LongLink0000000000000000000000000000015500000000000011566 Lustar rootrootpolyorb-2.8~20110207.orig/testsuite/corba/portableinterceptor/test000/test000_idl-serverinterceptor-impl.adbpolyorb-2.8~20110207.orig/testsuite/corba/portableinterceptor/test000/test000_idl-serverinterceptor-0000644000175000017500000001654211750740340032631 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- T E S T 0 0 0 _ I D L . S E R V E R I N T E R C E P T O R . I M P L -- -- -- -- B o d y -- -- -- -- Copyright (C) 2004-2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with PortableInterceptor.Interceptor; with Test000_Globals; package body Test000_Idl.ServerInterceptor.Impl is ------------- -- Disable -- ------------- procedure Disable (Self : access Object) is begin Self.Active := False; end Disable; ------------ -- Enable -- ------------ procedure Enable (Self : access Object) is begin Self.Active := True; end Enable; -------------- -- Get_Name -- -------------- function Get_Name (Self : access Object) return CORBA.String is begin return Self.Name; end Get_Name; ---------- -- Init -- ---------- procedure Init (Self : access Object; Name : Standard.String) is begin Self.Name := CORBA.To_CORBA_String (Name); Self.State := (others => Do_Nothing); Self.Active := False; end Init; ---------- -- Is_A -- ---------- function Is_A (Self : not null access Object; Logical_Type_Id : Standard.String) return Boolean is pragma Unreferenced (Self); begin return CORBA.Is_Equivalent (Logical_Type_Id, Test000_Idl.ServerInterceptor.Repository_Id) or else CORBA.Is_Equivalent (Logical_Type_Id, PortableInterceptor.ServerRequestInterceptor.Repository_Id) or else CORBA.Is_Equivalent (Logical_Type_Id, PortableInterceptor.Interceptor.Repository_Id) or else CORBA.Is_Equivalent (Logical_Type_Id, "IDL:omg.org/CORBA/Object:1.0"); end Is_A; --------------------- -- Receive_Request -- --------------------- procedure Receive_Request (Self : access Object; RI : PortableInterceptor.ServerRequestInfo.Local_Ref) is pragma Unreferenced (RI); begin if not Self.Active then return; end if; Test000_Globals.Log_Point (CORBA.To_Standard_String (Self.Name), Server_Receive_Request); case Self.State (Server_Receive_Request) is when Do_Nothing => null; when Raise_Exception => CORBA.Raise_No_Permission (CORBA.Default_Sys_Member); when others => raise Program_Error; end case; end Receive_Request; -------------------------------------- -- Receive_Request_Service_Contexts -- -------------------------------------- procedure Receive_Request_Service_Contexts (Self : access Object; RI : PortableInterceptor.ServerRequestInfo.Local_Ref) is pragma Unreferenced (RI); begin if not Self.Active then return; end if; Test000_Globals.Log_Point (CORBA.To_Standard_String (Self.Name), Server_Receive_Request_Service_Contexts); case Self.State (Server_Receive_Request_Service_Contexts) is when Do_Nothing => null; when Raise_Exception => CORBA.Raise_No_Permission (CORBA.Default_Sys_Member); when others => raise Program_Error; end case; end Receive_Request_Service_Contexts; -------------------- -- Send_Exception -- -------------------- procedure Send_Exception (Self : access Object; RI : PortableInterceptor.ServerRequestInfo.Local_Ref) is pragma Unreferenced (RI); begin if not Self.Active then return; end if; Test000_Globals.Log_Point (CORBA.To_Standard_String (Self.Name), Server_Send_Exception); case Self.State (Server_Send_Exception) is when Do_Nothing => null; when Raise_Exception => CORBA.Raise_No_Permission (CORBA.Default_Sys_Member); when others => raise Program_Error; end case; end Send_Exception; ---------------- -- Send_Other -- ---------------- procedure Send_Other (Self : access Object; RI : PortableInterceptor.ServerRequestInfo.Local_Ref) is pragma Unreferenced (RI); begin if not Self.Active then return; end if; Test000_Globals.Log_Point (CORBA.To_Standard_String (Self.Name), Server_Send_Other); case Self.State (Server_Send_Other) is when Do_Nothing => null; when Raise_Exception => CORBA.Raise_No_Permission (CORBA.Default_Sys_Member); when others => raise Program_Error; end case; end Send_Other; ---------------- -- Send_Reply -- ---------------- procedure Send_Reply (Self : access Object; RI : PortableInterceptor.ServerRequestInfo.Local_Ref) is pragma Unreferenced (RI); begin if not Self.Active then return; end if; Test000_Globals.Log_Point (CORBA.To_Standard_String (Self.Name), Server_Send_Reply); case Self.State (Server_Send_Reply) is when Do_Nothing => null; when Raise_Exception => CORBA.Raise_No_Permission (CORBA.Default_Sys_Member); when others => raise Program_Error; end case; end Send_Reply; ------------------ -- Set_Behavior -- ------------------ procedure Set_Behavior (Self : access Object; Point : Server_Interception_Point; Behavior : Interceptor_Behavior) is begin Self.State (Point) := Behavior; end Set_Behavior; end Test000_Idl.ServerInterceptor.Impl; polyorb-2.8~20110207.orig/testsuite/corba/portableinterceptor/test000/local.gpr0000644000175000017500000000066511750740340026622 0ustar xavierxavierwith "polyorb", "polyorb_test_common"; project local is Dir := external ("Test_Dir"); Obj_Dir := PolyORB_Test_Common.Build_Dir & Dir; for Object_Dir use Obj_Dir; for Source_Dirs use (Obj_Dir, PolyORB_Test_Common.Source_Dir & Dir); package Compiler is for Default_Switches ("Ada") use PolyORB_Test_Common.Compiler'Default_Switches ("Ada"); end Compiler; for Main use ("test000.adb"); end local; ././@LongLink0000000000000000000000000000015200000000000011563 Lustar rootrootpolyorb-2.8~20110207.orig/testsuite/corba/portableinterceptor/test000/test000_idl-orbinitializer-impl.adbpolyorb-2.8~20110207.orig/testsuite/corba/portableinterceptor/test000/test000_idl-orbinitializer-imp0000644000175000017500000001441311750740340032573 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- T E S T 0 0 0 _ I D L . O R B I N I T I A L I Z E R . I M P L -- -- -- -- B o d y -- -- -- -- Copyright (C) 2004-2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with CORBA; with PortableInterceptor.ClientRequestInterceptor; with PortableInterceptor.ServerRequestInterceptor; with PolyORB.Smart_Pointers; with Test000_Idl.ClientInterceptor.Impl; with Test000_Idl.ServerInterceptor.Impl; with Test000_Globals; package body Test000_Idl.ORBInitializer.Impl is ---------- -- Is_A -- ---------- function Is_A (Self : not null access Object; Logical_Type_Id : Standard.String) return Boolean is pragma Unreferenced (Self); begin return CORBA.Is_Equivalent (Logical_Type_Id, Test000_Idl.ORBInitializer.Repository_Id) or else CORBA.Is_Equivalent (Logical_Type_Id, PortableInterceptor.ORBInitializer.Repository_Id) or else CORBA.Is_Equivalent (Logical_Type_Id, "IDL:omg.org/CORBA/Object:1.0"); end Is_A; --------------- -- Post_Init -- --------------- procedure Post_Init (Self : access Object; Info : PortableInterceptor.ORBInitInfo.Local_Ref) is pragma Unreferenced (Self); Client_A_Ptr : constant Test000_Idl.ClientInterceptor.Impl.Object_Ptr := new Test000_Idl.ClientInterceptor.Impl.Object; Client_B_Ptr : constant Test000_Idl.ClientInterceptor.Impl.Object_Ptr := new Test000_Idl.ClientInterceptor.Impl.Object; Client_C_Ptr : constant Test000_Idl.ClientInterceptor.Impl.Object_Ptr := new Test000_Idl.ClientInterceptor.Impl.Object; Server_A_Ptr : constant Test000_Idl.ServerInterceptor.Impl.Object_Ptr := new Test000_Idl.ServerInterceptor.Impl.Object; Server_B_Ptr : constant Test000_Idl.ServerInterceptor.Impl.Object_Ptr := new Test000_Idl.ServerInterceptor.Impl.Object; Server_C_Ptr : constant Test000_Idl.ServerInterceptor.Impl.Object_Ptr := new Test000_Idl.ServerInterceptor.Impl.Object; begin Test000_Idl.ClientInterceptor.Impl.Init (Client_A_Ptr, "A"); Test000_Idl.ClientInterceptor.Impl.Init (Client_B_Ptr, "B"); Test000_Idl.ClientInterceptor.Impl.Init (Client_C_Ptr, "C"); Test000_Idl.ClientInterceptor.Set (Test000_Globals.Client_A, PolyORB.Smart_Pointers.Entity_Ptr (Client_A_Ptr)); Test000_Idl.ClientInterceptor.Set (Test000_Globals.Client_B, PolyORB.Smart_Pointers.Entity_Ptr (Client_B_Ptr)); Test000_Idl.ClientInterceptor.Set (Test000_Globals.Client_C, PolyORB.Smart_Pointers.Entity_Ptr (Client_C_Ptr)); Test000_Globals.Disable_Client_Interceptors; PortableInterceptor.ORBInitInfo.Add_Client_Request_Interceptor (Info, PortableInterceptor.ClientRequestInterceptor.Local_Ref (Test000_Globals.Client_A)); PortableInterceptor.ORBInitInfo.Add_Client_Request_Interceptor (Info, PortableInterceptor.ClientRequestInterceptor.Local_Ref (Test000_Globals.Client_B)); PortableInterceptor.ORBInitInfo.Add_Client_Request_Interceptor (Info, PortableInterceptor.ClientRequestInterceptor.Local_Ref (Test000_Globals.Client_C)); Test000_Idl.ServerInterceptor.Impl.Init (Server_A_Ptr, "A"); Test000_Idl.ServerInterceptor.Impl.Init (Server_B_Ptr, "B"); Test000_Idl.ServerInterceptor.Impl.Init (Server_C_Ptr, "C"); Test000_Idl.ServerInterceptor.Set (Test000_Globals.Server_A, PolyORB.Smart_Pointers.Entity_Ptr (Server_A_Ptr)); Test000_Idl.ServerInterceptor.Set (Test000_Globals.Server_B, PolyORB.Smart_Pointers.Entity_Ptr (Server_B_Ptr)); Test000_Idl.ServerInterceptor.Set (Test000_Globals.Server_C, PolyORB.Smart_Pointers.Entity_Ptr (Server_C_Ptr)); Test000_Globals.Disable_Server_Interceptors; PortableInterceptor.ORBInitInfo.Add_Server_Request_Interceptor (Info, PortableInterceptor.ServerRequestInterceptor.Local_Ref (Test000_Globals.Server_A)); PortableInterceptor.ORBInitInfo.Add_Server_Request_Interceptor (Info, PortableInterceptor.ServerRequestInterceptor.Local_Ref (Test000_Globals.Server_B)); PortableInterceptor.ORBInitInfo.Add_Server_Request_Interceptor (Info, PortableInterceptor.ServerRequestInterceptor.Local_Ref (Test000_Globals.Server_C)); end Post_Init; end Test000_Idl.ORBInitializer.Impl; polyorb-2.8~20110207.orig/testsuite/corba/portableinterceptor/test003/0000755000175000017500000000000011750740340025012 5ustar xavierxavierpolyorb-2.8~20110207.orig/testsuite/corba/portableinterceptor/test003/test003.adb0000644000175000017500000001626411750740340026675 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- T E S T 0 0 3 -- -- -- -- B o d y -- -- -- -- Copyright (C) 2004-2007, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with CORBA.IDL_SEQUENCES; with CORBA.ORB; with IOP.Codec; with IOP.CodecFactory.Helper; with PolyORB.Buffers; -- For Host_Order with PolyORB.Utils.Report; with PolyORB.Setup.No_Tasking_Server; pragma Warnings (Off, PolyORB.Setup.No_Tasking_Server); procedure Test003 is use CORBA; use CORBA.IDL_SEQUENCES; use IOP; use PolyORB.Utils.Report; Argv : CORBA.ORB.Arg_List := CORBA.ORB.Command_Line_Arguments; Factory : IOP.CodecFactory.Local_Ref; Codec : IOP.Codec.Local_Ref; BE_Stream : OctetSeq; LE_Stream : OctetSeq; begin CORBA.ORB.Init (CORBA.ORB.To_CORBA_String ("ORB"), Argv); New_Test ("IOP::CodecFactory and IOP::Codec operations"); begin Factory := IOP.CodecFactory.Helper.To_Local_Ref (CORBA.ORB.Resolve_Initial_References (CORBA.ORB.To_CORBA_String ("CodecFactory"))); Output ("Getting CodecFactory from Resolve_Initial_References", True); exception when others => Output ("Getting CodecFactory from Resolve_Initial_References", False); end; begin Codec := IOP.CodecFactory.Create_Codec (Factory, (255, 0, 0)); Output ("Rasing UnknownEncoding for invalid encoding method", False); exception when IOP.CodecFactory.UnknownEncoding => Output ("Rasing UnknownEncoding for invalid encoding method", True); when others => Output ("Rasing UnknownEncoding for invalid encoding method", False); end; begin Codec := IOP.CodecFactory.Create_Codec (Factory, (Encoding_CDR_Encaps, 0, 0)); Output ("Rasing UnknownEncoding for invalid encoding version", False); exception when IOP.CodecFactory.UnknownEncoding => Output ("Rasing UnknownEncoding for invalid encoding version", True); when others => Output ("Rasing UnknownEncoding for invalid encoding version", False); end; begin Codec := IOP.CodecFactory.Create_Codec (Factory, (Encoding_CDR_Encaps, 1, 2)); Output ("Create codec for known encoding and version", True); exception when others => Output ("Create codec for known encoding and version", False); end; -- This is unsigned long (1), big endian -- Bytes marked '16#AA#' are padding Append (BE_Stream, 16#00#); Append (BE_Stream, 16#AA#); Append (BE_Stream, 16#AA#); Append (BE_Stream, 16#AA#); Append (BE_Stream, 16#00#); Append (BE_Stream, 16#00#); Append (BE_Stream, 16#00#); Append (BE_Stream, 16#01#); -- This is unsigned long (1), little endian -- Bytes marked '16#AA#' are padding Append (LE_Stream, 16#01#); Append (LE_Stream, 16#AA#); Append (LE_Stream, 16#AA#); Append (LE_Stream, 16#AA#); Append (LE_Stream, 16#01#); Append (LE_Stream, 16#00#); Append (LE_Stream, 16#00#); Append (LE_Stream, 16#00#); declare Data : Any; begin Data := IOP.Codec.Decode_Value (Codec, BE_Stream, CORBA.TC_Unsigned_Long); Output ("IOP::Codec::Decode_Value (big endian)", Unsigned_Long'(From_Any (Data)) = 1); exception when others => Output ("IOP::Codec::Decode_Value (big endian)", False); end; declare Data : Any; begin Data := IOP.Codec.Decode_Value (Codec, LE_Stream, CORBA.TC_Unsigned_Long); Output ("IOP::Codec::Decode_Value (little endian)", Unsigned_Long'(From_Any (Data)) = 1); exception when others => Output ("IOP::Codec::Decode_Value (little endian)", False); end; declare Data : constant Any := To_Any (Unsigned_Long'(1)); Stream : OctetSeq; Exp_Stream : OctetSeq; use PolyORB.Buffers; begin Stream := IOP.Codec.Encode_Value (Codec, Data); case Host_Order is when Little_Endian => Exp_Stream := LE_Stream; when Big_Endian => Exp_Stream := BE_Stream; end case; -- Compare Seq with Exp_Stream, ignoring padding bytes (marked as 16#AA# -- in Exp_Stream). declare use CORBA.IDL_SEQUENCES.IDL_SEQUENCE_Octet; Bytes : constant Element_Array := To_Element_Array (Stream); Exp_Bytes : constant Element_Array := To_Element_Array (Exp_Stream); Ok : Boolean; begin if Bytes'First = Exp_Bytes'First and then Bytes'Last = Exp_Bytes'Last then Ok := True; for J in Bytes'Range loop if Exp_Bytes (J) /= 16#AA# and then Bytes (J) /= Exp_Bytes (J) then Ok := False; end if; end loop; else Ok := False; end if; Output ("IOP::Codec::Encode_Value", Ok); end; exception when others => Output ("IOP::Codec::Encode_Value", False); end; declare Data : constant Any := To_Any (Unsigned_Long'(1)); Stream : OctetSeq; begin Stream := IOP.Codec.Encode (Codec, Data); Output ("IOP::Codec::Encode and IOP::Codec::Decode", IOP.Codec.Decode (Codec, Stream) = Data); exception when others => Output ("IOP::Codec::Encode and IOP::Codec::Decode", False); end; End_Report; end Test003; polyorb-2.8~20110207.orig/testsuite/corba/portableinterceptor/test003/Makefile.local0000644000175000017500000000000011750740340027531 0ustar xavierxavierpolyorb-2.8~20110207.orig/testsuite/corba/portableinterceptor/test003/local.gpr0000644000175000017500000000066511750740340026625 0ustar xavierxavierwith "polyorb", "polyorb_test_common"; project local is Dir := external ("Test_Dir"); Obj_Dir := PolyORB_Test_Common.Build_Dir & Dir; for Object_Dir use Obj_Dir; for Source_Dirs use (Obj_Dir, PolyORB_Test_Common.Source_Dir & Dir); package Compiler is for Default_Switches ("Ada") use PolyORB_Test_Common.Compiler'Default_Switches ("Ada"); end Compiler; for Main use ("test003.adb"); end local; polyorb-2.8~20110207.orig/testsuite/corba/portableinterceptor/test002/0000755000175000017500000000000011750740340025011 5ustar xavierxavier././@LongLink0000000000000000000000000000015200000000000011563 Lustar rootrootpolyorb-2.8~20110207.orig/testsuite/corba/portableinterceptor/test002/test002_client_interceptor-impl.adbpolyorb-2.8~20110207.orig/testsuite/corba/portableinterceptor/test002/test002_client_interceptor-imp0000644000175000017500000001137011750740340032676 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- T E S T 0 0 2 _ C L I E N T _ I N T E R C E P T O R . I M P L -- -- -- -- B o d y -- -- -- -- Copyright (C) 2004-2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with CORBA; with PortableInterceptor.Interceptor; with PortableInterceptor.ClientRequestInterceptor; with PortableInterceptor.Current; with PolyORB.Utils.Report; with Test002_Globals; package body Test002_Client_Interceptor.Impl is use CORBA; use CORBA.TypeCode; use PolyORB.Utils.Report; use PortableInterceptor.ClientRequestInfo; use PortableInterceptor.Current; use Test002_Globals; ---------- -- Is_A -- ---------- function Is_A (Self : not null access Object; Logical_Type_Id : Standard.String) return Boolean is pragma Unreferenced (Self); begin return CORBA.Is_Equivalent (Logical_Type_Id, Test002_Client_Interceptor.Repository_Id) or else CORBA.Is_Equivalent (Logical_Type_Id, PortableInterceptor.ClientRequestInterceptor.Repository_Id) or else CORBA.Is_Equivalent (Logical_Type_Id, PortableInterceptor.Interceptor.Repository_Id) or else CORBA.Is_Equivalent (Logical_Type_Id, "IDL:omg.org/CORBA/Object:1.0"); end Is_A; ------------------- -- Receive_Reply -- ------------------- procedure Receive_Reply (Self : access Object; RI : PortableInterceptor.ClientRequestInfo.Local_Ref) is pragma Unreferenced (Self); Aux : Any; begin Aux := Get_Slot (RI, Test_Slot); if Get_Type (Aux) /= TC_Long then Output ("Slot value is unchanged in CRSC after invocation", False); elsif From_Any (Aux) /= Long (10) then Output ("Slot value is unchanged in CRSC after invocation", False); else Output ("Slot value is unchanged in CRSC after invocation", True); end if; Set_Slot (PI_Current, Test_Slot, To_Any (Long (14))); exception when others => Output ("Slot value is unchanged in CRSC after invocation", False); end Receive_Reply; ------------------ -- Send_Request -- ------------------ procedure Send_Request (Self : access Object; RI : PortableInterceptor.ClientRequestInfo.Local_Ref) is pragma Unreferenced (Self); Aux : Any; begin Aux := Get_Slot (RI, Test_Slot); if Get_Type (Aux) /= TC_Long then Output ("Slot value correctly copied from CTSC to CRSC", False); elsif From_Any (Aux) /= Long (10) then Output ("Slot value correctly copied from CTSC to CRSC", False); else Output ("Slot value correctly copied from CTSC to CRSC", True); end if; Set_Slot (PI_Current, Test_Slot, To_Any (Long (12))); exception when others => Output ("Slot value correctly copied from CTSC to CRSC", False); end Send_Request; end Test002_Client_Interceptor.Impl; ././@LongLink0000000000000000000000000000015200000000000011563 Lustar rootrootpolyorb-2.8~20110207.orig/testsuite/corba/portableinterceptor/test002/test002_server_interceptor-impl.adbpolyorb-2.8~20110207.orig/testsuite/corba/portableinterceptor/test002/test002_server_interceptor-imp0000644000175000017500000001664111750740340032734 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- T E S T 0 0 2 _ S E R V E R _ I N T E R C E P T O R . I M P L -- -- -- -- B o d y -- -- -- -- Copyright (C) 2004-2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with CORBA; with PortableInterceptor.Current; with PortableInterceptor.Interceptor; with PortableInterceptor.ServerRequestInterceptor; with PolyORB.Utils.Report; with Test002_Globals; package body Test002_Server_Interceptor.Impl is use CORBA; use CORBA.TypeCode; use PolyORB.Utils.Report; use PortableInterceptor.Current; use PortableInterceptor.ServerRequestInfo; use Test002_Globals; ---------- -- Is_A -- ---------- function Is_A (Self : not null access Object; Logical_Type_Id : Standard.String) return Boolean is pragma Unreferenced (Self); begin return CORBA.Is_Equivalent (Logical_Type_Id, Test002_Server_Interceptor.Repository_Id) or else CORBA.Is_Equivalent (Logical_Type_Id, PortableInterceptor.ServerRequestInterceptor.Repository_Id) or else CORBA.Is_Equivalent (Logical_Type_Id, PortableInterceptor.Interceptor.Repository_Id) or else CORBA.Is_Equivalent (Logical_Type_Id, "IDL:omg.org/CORBA/Object:1.0"); end Is_A; -------------------------------------- -- Receive_Request_Service_Contexts -- -------------------------------------- procedure Receive_Request_Service_Contexts (Self : access Object; RI : PortableInterceptor.ServerRequestInfo.Local_Ref) is pragma Unreferenced (Self); Aux : Any; begin begin Aux := Get_Slot (RI, Test_Slot); if Get_Type (Aux) /= TC_Null then Output ("Uninitialized SRSC slot value", False); else Output ("Uninitialized SRSC slot value", True); end if; exception when others => Output ("Uninitialized SRSC slot value", False); end; begin Set_Slot (RI, Test_Slot, To_Any (Long (16))); begin Aux := Get_Slot (RI, Test_Slot); if Get_Type (Aux) /= TC_Long then Output ("Setting SRSC slot value", False); elsif From_Any (Aux) /= Long (16) then Output ("Setting SRSC slot value", False); else Output ("Setting SRSC slot value", True); end if; end; exception when others => Output ("Setting SRSC slot value", False); end; -- Preparing for test of correctly copied SRSC to STSC Set_Slot (PI_Current, Test_Slot, To_Any (Long (18))); end Receive_Request_Service_Contexts; --------------------- -- Receive_Request -- --------------------- procedure Receive_Request (Self : access Object; RI : PortableInterceptor.ServerRequestInfo.Local_Ref) is pragma Unreferenced (Self); Aux : Any; begin begin Aux := Get_Slot (PI_Current, Test_Slot); if Get_Type (Aux) /= TC_Long then Output ("Slot value correctly copied from SRSC to STSC", False); elsif From_Any (Aux) /= Long (16) then Output ("Slot value correctly copied from SRSC to STSC", False); else Output ("Slot value correctly copied from SRSC to STSC", True); end if; exception when others => Output ("Slot value correctly copied from SRSC to STSC", False); end; begin Aux := Get_Slot (RI, Test_Slot); if Get_Type (Aux) /= TC_Long then Output ("Slot value is unchanged in SRSC", False); elsif From_Any (Aux) /= Long (16) then Output ("Slot value is unchanged in SRSC", False); else Output ("Slot value is unchanged in SRSC", True); end if; exception when others => Output ("Slot value is unchanged in SRSC", False); end; -- Preparing for test of passing STSC to servant manager Set_Slot (PI_Current, Test_Slot, To_Any (Long (20))); end Receive_Request; ---------------- -- Send_Reply -- ---------------- procedure Send_Reply (Self : access Object; RI : PortableInterceptor.ServerRequestInfo.Local_Ref) is pragma Unreferenced (Self); Aux : Any; begin begin Aux := Get_Slot (PI_Current, Test_Slot); if Get_Type (Aux) /= TC_Long then Output ("Slot value correctly passed to send point in STSC", False); elsif From_Any (Aux) /= Long (22) then Output ("Slot value correctly passed to send point in STSC", False); else Output ("Slot value correctly passed to send point in STSC", True); end if; exception when others => Output ("Slot value correctly passed to send point in STSC", False); end; begin Aux := Get_Slot (RI, Test_Slot); if Get_Type (Aux) /= TC_Long then Output ("Slot value correctly copied from STSC to SRSC", False); elsif From_Any (Aux) /= Long (22) then Output ("Slot value correctly copied from STSC to SRSC", False); else Output ("Slot value correctly copied from STSC to SRSC", True); end if; exception when others => Output ("Slot value correctly copied from STSC to SRSC", False); end; -- Setting to STSC slot value another value Set_Slot (PI_Current, Test_Slot, To_Any (Long (24))); end Send_Reply; end Test002_Server_Interceptor.Impl; ././@LongLink0000000000000000000000000000014700000000000011567 Lustar rootrootpolyorb-2.8~20110207.orig/testsuite/corba/portableinterceptor/test002/test002_orb_initializer-impl.adbpolyorb-2.8~20110207.orig/testsuite/corba/portableinterceptor/test002/test002_orb_initializer-impl.a0000644000175000017500000001015111750740340032556 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- T E S T 0 0 2 _ O R B _ I N I T I A L I Z E R . I M P L -- -- -- -- B o d y -- -- -- -- Copyright (C) 2004-2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with CORBA; with PortableInterceptor.ClientRequestInterceptor; with PortableInterceptor.ORBInitializer; with PortableInterceptor.ServerRequestInterceptor; with PolyORB.Smart_Pointers; with Test002_Globals; with Test002_Client_Interceptor.Impl; with Test002_Server_Interceptor.Impl; package body Test002_ORB_Initializer.Impl is use PortableInterceptor.ORBInitInfo; use Test002_Globals; ---------- -- Is_A -- ---------- function Is_A (Self : not null access Object; Logical_Type_Id : Standard.String) return Boolean is pragma Unreferenced (Self); begin return CORBA.Is_Equivalent (Logical_Type_Id, Test002_ORB_Initializer.Repository_Id) or else CORBA.Is_Equivalent (Logical_Type_Id, PortableInterceptor.ORBInitializer.Repository_Id) or else CORBA.Is_Equivalent (Logical_Type_Id, "IDL:omg.org/CORBA/Object:1.0"); end Is_A; --------------- -- Post_Init -- --------------- procedure Post_Init (Self : access Object; Info : PortableInterceptor.ORBInitInfo.Local_Ref) is pragma Unreferenced (Self); Client_Ptr : constant Test002_Client_Interceptor.Impl.Object_Ptr := new Test002_Client_Interceptor.Impl.Object; Server_Ptr : constant Test002_Server_Interceptor.Impl.Object_Ptr := new Test002_Server_Interceptor.Impl.Object; begin Test_Slot := Allocate_Slot_Id (Info); Test002_Client_Interceptor.Set (Test002_Globals.Client, PolyORB.Smart_Pointers.Entity_Ptr (Client_Ptr)); PortableInterceptor.ORBInitInfo.Add_Client_Request_Interceptor (Info, PortableInterceptor.ClientRequestInterceptor.Local_Ref (Test002_Globals.Client)); Test002_Server_Interceptor.Set (Test002_Globals.Server, PolyORB.Smart_Pointers.Entity_Ptr (Server_Ptr)); PortableInterceptor.ORBInitInfo.Add_Server_Request_Interceptor (Info, PortableInterceptor.ServerRequestInterceptor.Local_Ref (Test002_Globals.Server)); end Post_Init; end Test002_ORB_Initializer.Impl; polyorb-2.8~20110207.orig/testsuite/corba/portableinterceptor/test002/Makefile.local0000644000175000017500000000016411750740340027543 0ustar xavierxavier${current_dir}test002_interface.idl-stamp: idlac_flags := ${test_target}: ${current_dir}test002_interface.idl-stamp polyorb-2.8~20110207.orig/testsuite/corba/portableinterceptor/test002/test002_interface.idl0000644000175000017500000000056511750740340030732 0ustar xavierxavier import ::PortableInterceptor; interface Test002_Interface { void Proc (); }; local interface Test002_Client_Interceptor : PortableInterceptor::ClientRequestInterceptor { }; local interface Test002_Server_Interceptor : PortableInterceptor::ServerRequestInterceptor { }; local interface Test002_ORB_Initializer : PortableInterceptor::ORBInitializer { }; polyorb-2.8~20110207.orig/testsuite/corba/portableinterceptor/test002/test002_interface-impl.adb0000644000175000017500000000632111750740340031643 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- T E S T 0 0 2 _ I N T E R F A C E . I M P L -- -- -- -- B o d y -- -- -- -- Copyright (C) 2004 Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by ACT Europe. -- -- (email: sales@act-europe.fr) -- -- -- ------------------------------------------------------------------------------ with PolyORB.Utils.Report; with PortableInterceptor.Current; with Test002_Interface.Skel; pragma Warnings (Off, Test002_Interface.Skel); with Test002_Globals; package body Test002_Interface.Impl is use CORBA; use CORBA.TypeCode; use PolyORB.Utils.Report; use PortableInterceptor.Current; use Test002_Globals; ---------- -- Proc -- ---------- procedure Proc (Self : access Object) is pragma Unreferenced (Self); Aux : Any; begin begin Aux := Get_Slot (PI_Current, Test_Slot); if Get_Type (Aux) /= TC_Long then Output ("Slot value correctly passed to servant STSC", False); elsif From_Any (Aux) /= Long (20) then Output ("Slot value correctly passed to servant STSC", False); else Output ("Slot value correctly passed to servant STSC", True); end if; exception when others => Output ("Slot value correctly passed to servant STSC", False); end; -- Preparing for test of passing STSC to send interception -- point and coping STSC to SRSC. Set_Slot (PI_Current, Test_Slot, To_Any (Long (22))); end Proc; end Test002_Interface.Impl; polyorb-2.8~20110207.orig/testsuite/corba/portableinterceptor/test002/test002_interface-impl.ads0000644000175000017500000000450611750740340031667 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- T E S T 0 0 2 _ I N T E R F A C E . I M P L -- -- -- -- S p e c -- -- -- -- Copyright (C) 2004 Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by ACT Europe. -- -- (email: sales@act-europe.fr) -- -- -- ------------------------------------------------------------------------------ with PortableServer; package Test002_Interface.Impl is type Object is new PortableServer.Servant_Base with private; type Object_Ptr is access all Object'Class; procedure Proc (Self : access Object); private type Object is new PortableServer.Servant_Base with null record; end Test002_Interface.Impl; ././@LongLink0000000000000000000000000000014700000000000011567 Lustar rootrootpolyorb-2.8~20110207.orig/testsuite/corba/portableinterceptor/test002/test002_orb_initializer-impl.adspolyorb-2.8~20110207.orig/testsuite/corba/portableinterceptor/test002/test002_orb_initializer-impl.a0000644000175000017500000000527111750740340032565 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- T E S T 0 0 2 _ O R B _ I N I T I A L I Z E R . I M P L -- -- -- -- S p e c -- -- -- -- Copyright (C) 2004-2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with PortableInterceptor.ORBInitInfo; with PortableInterceptor.ORBInitializer.Impl; package Test002_ORB_Initializer.Impl is type Object is new PortableInterceptor.ORBInitializer.Impl.Object with private; type Object_Ptr is access all Object'Class; private type Object is new PortableInterceptor.ORBInitializer.Impl.Object with null record; function Is_A (Self : not null access Object; Logical_Type_Id : Standard.String) return Boolean; -- Derived from PortableInterceptor::ORBInitializer procedure Post_Init (Self : access Object; Info : PortableInterceptor.ORBInitInfo.Local_Ref); end Test002_ORB_Initializer.Impl; polyorb-2.8~20110207.orig/testsuite/corba/portableinterceptor/test002/test002_globals.ads0000644000175000017500000000461011750740340030407 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- T E S T 0 0 2 _ G L O B A L S -- -- -- -- S p e c -- -- -- -- Copyright (C) 2004 Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by ACT Europe. -- -- (email: sales@act-europe.fr) -- -- -- ------------------------------------------------------------------------------ with PortableInterceptor; with PortableInterceptor.Current; with Test002_Client_Interceptor; with Test002_Server_Interceptor; package Test002_Globals is PI_Current : PortableInterceptor.Current.Local_Ref; Test_Slot : PortableInterceptor.SlotId; Client : Test002_Client_Interceptor.Local_Ref; Server : Test002_Server_Interceptor.Local_Ref; end Test002_Globals; polyorb-2.8~20110207.orig/testsuite/corba/portableinterceptor/test002/local.gpr0000644000175000017500000000066511750740340026624 0ustar xavierxavierwith "polyorb", "polyorb_test_common"; project local is Dir := external ("Test_Dir"); Obj_Dir := PolyORB_Test_Common.Build_Dir & Dir; for Object_Dir use Obj_Dir; for Source_Dirs use (Obj_Dir, PolyORB_Test_Common.Source_Dir & Dir); package Compiler is for Default_Switches ("Ada") use PolyORB_Test_Common.Compiler'Default_Switches ("Ada"); end Compiler; for Main use ("test002.adb"); end local; ././@LongLink0000000000000000000000000000015200000000000011563 Lustar rootrootpolyorb-2.8~20110207.orig/testsuite/corba/portableinterceptor/test002/test002_client_interceptor-impl.adspolyorb-2.8~20110207.orig/testsuite/corba/portableinterceptor/test002/test002_client_interceptor-imp0000644000175000017500000000555211750740340032703 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- T E S T 0 0 2 _ C L I E N T _ I N T E R C E P T O R . I M P L -- -- -- -- S p e c -- -- -- -- Copyright (C) 2004-2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with PortableInterceptor.ClientRequestInfo; with PortableInterceptor.ClientRequestInterceptor.Impl; package Test002_Client_Interceptor.Impl is type Object is new PortableInterceptor.ClientRequestInterceptor.Impl.Object with private; type Object_Ptr is access all Object'Class; private type Object is new PortableInterceptor.ClientRequestInterceptor.Impl.Object with null record; function Is_A (Self : not null access Object; Logical_Type_Id : Standard.String) return Boolean; -- Derived from ClientRequestInterceptor procedure Send_Request (Self : access Object; RI : PortableInterceptor.ClientRequestInfo.Local_Ref); procedure Receive_Reply (Self : access Object; RI : PortableInterceptor.ClientRequestInfo.Local_Ref); end Test002_Client_Interceptor.Impl; ././@LongLink0000000000000000000000000000015200000000000011563 Lustar rootrootpolyorb-2.8~20110207.orig/testsuite/corba/portableinterceptor/test002/test002_server_interceptor-impl.adspolyorb-2.8~20110207.orig/testsuite/corba/portableinterceptor/test002/test002_server_interceptor-imp0000644000175000017500000000576411750740340032740 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- T E S T 0 0 2 _ S E R V E R _ I N T E R C E P T O R . I M P L -- -- -- -- S p e c -- -- -- -- Copyright (C) 2004-2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with PortableInterceptor.ServerRequestInfo; with PortableInterceptor.ServerRequestInterceptor.Impl; package Test002_Server_Interceptor.Impl is type Object is new PortableInterceptor.ServerRequestInterceptor.Impl.Object with private; type Object_Ptr is access all Object'Class; private type Object is new PortableInterceptor.ServerRequestInterceptor.Impl.Object with null record; function Is_A (Self : not null access Object; Logical_Type_Id : Standard.String) return Boolean; -- Derived from ServerRequestInterceptor procedure Receive_Request_Service_Contexts (Self : access Object; RI : PortableInterceptor.ServerRequestInfo.Local_Ref); procedure Receive_Request (Self : access Object; RI : PortableInterceptor.ServerRequestInfo.Local_Ref); procedure Send_Reply (Self : access Object; RI : PortableInterceptor.ServerRequestInfo.Local_Ref); end Test002_Server_Interceptor.Impl; polyorb-2.8~20110207.orig/testsuite/corba/portableinterceptor/test002/test002.adb0000644000175000017500000001275411750740340026673 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- T E S T 0 0 2 -- -- -- -- B o d y -- -- -- -- Copyright (C) 2004 Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by ACT Europe. -- -- (email: sales@act-europe.fr) -- -- -- ------------------------------------------------------------------------------ -- CTSC - Client side Thread Scope PICurrent -- CRSC - Client side Request Scope PICurrent -- STSC - Server side Thread Scope PICurrent -- SRSC - Server side Request Scope PICurrent with CORBA.Object; with CORBA.ORB; with PortableInterceptor.Current.Helper; with PortableInterceptor.ORBInitializer.Initialize_All; with PortableInterceptor.ORBInitializer.Register; with PolyORB.CORBA_P.Server_Tools; with PolyORB.Setup.Thread_Pool_Server; pragma Warnings (Off, PolyORB.Setup.Thread_Pool_Server); with PolyORB.Smart_Pointers; with PolyORB.Utils.Report; with Test002_Globals; with Test002_ORB_Initializer.Impl; with Test002_Interface.Helper; with Test002_Interface.Impl; procedure Test002 is use CORBA; use CORBA.TypeCode; use PolyORB.Utils.Report; use PortableInterceptor; use PortableInterceptor.Current; use Test002_Globals; Test_Object : Test002_Interface.Ref; procedure Init_Test; procedure Init_Test is use PolyORB.CORBA_P.Server_Tools; Ref : CORBA.Object.Ref; begin CORBA.ORB.Initialize ("ORB"); declare Ptr : constant Test002_ORB_Initializer.Impl.Object_Ptr := new Test002_ORB_Initializer.Impl.Object; Ref : Test002_ORB_Initializer.Local_Ref; begin Test002_ORB_Initializer.Set (Ref, PolyORB.Smart_Pointers.Entity_Ptr (Ptr)); PortableInterceptor.ORBInitializer.Register (PortableInterceptor.ORBInitializer.Local_Ref (Ref)); end; PortableInterceptor.ORBInitializer.Initialize_All; Initiate_Servant (new Test002_Interface.Impl.Object, Ref); Test_Object := Test002_Interface.Helper.To_Ref (Ref); PI_Current := PortableInterceptor.Current.Helper.To_Local_Ref (CORBA.ORB.Resolve_Initial_References (CORBA.ORB.To_CORBA_String ("PICurrent"))); Initiate_Server (True); end Init_Test; begin Init_Test; New_Test ("PICurrent Thread and Request Scopes Slots"); declare Aux : Any; begin Aux := Get_Slot (PI_Current, Test_Slot); if Get_Type (Aux) /= TC_Null then Output ("Uninitialized CTSC slot value (a)", False); else Output ("Uninitialized CTSC slot value", True); end if; exception when others => Output ("Uninitialized CTSC slot value (b)", False); end; begin Set_Slot (PI_Current, Test_Slot, To_Any (Long (10))); declare Aux : Any; begin Aux := Get_Slot (PI_Current, Test_Slot); if Get_Type (Aux) /= TC_Long then Output ("Setting CTSC slot value", False); elsif From_Any (Aux) /= Long (10) then Output ("Setting CTSC slot value", False); else Output ("Setting CTSC slot value", True); end if; end; exception when others => Output ("Setting CTSC slot value", False); end; Test002_Interface.Proc (Test_Object); declare Aux : Any; begin Aux := Get_Slot (PI_Current, Test_Slot); if Get_Type (Aux) /= TC_Long then Output ("Slot value is unchanged in CTSC after invocation", False); elsif From_Any (Aux) /= Long (10) then Output ("Slot value is unchanged in CTSC after invocation", False); else Output ("Slot value is unchanged in CTSC after invocation", True); end if; exception when others => Output ("Slot value is unchanged in CTSC after invocation", False); end; End_Report; CORBA.ORB.Shutdown (True); end Test002; polyorb-2.8~20110207.orig/testsuite/corba/portableinterceptor/test004/0000755000175000017500000000000011750740340025013 5ustar xavierxavier././@LongLink0000000000000000000000000000015100000000000011562 Lustar rootrootpolyorb-2.8~20110207.orig/testsuite/corba/portableinterceptor/test004/test-serverorbinitializer-impl.adbpolyorb-2.8~20110207.orig/testsuite/corba/portableinterceptor/test004/test-serverorbinitializer-impl0000644000175000017500000000646711750740340033144 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- T E S T . S E R V E R O R B I N I T I A L I Z E R . I M P L -- -- -- -- B o d y -- -- -- -- Copyright (C) 2005-2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with CORBA.Impl; with PortableInterceptor.IORInterceptor; with Test.IORInterceptor.Impl; package body Test.ServerORBInitializer.Impl is ---------- -- Is_A -- ---------- function Is_A (Self : not null access Object; Logical_Type_Id : Standard.String) return Boolean is pragma Unreferenced (Self); begin return CORBA.Is_Equivalent (Logical_Type_Id, Test.ServerORBInitializer.Repository_Id) or else CORBA.Is_Equivalent (Logical_Type_Id, PortableInterceptor.ORBInitializer.Repository_Id) or else CORBA.Is_Equivalent (Logical_Type_Id, "IDL:omg.org/CORBA/Object:1.0"); end Is_A; --------------- -- Post_Init -- --------------- procedure Post_Init (Self : access Object; Info : PortableInterceptor.ORBInitInfo.Local_Ref) is pragma Unreferenced (Self); IOR_Ref : PortableInterceptor.IORInterceptor.Local_Ref; IOR_Ptr : Test.IORInterceptor.Impl.Object_Ptr; begin IOR_Ptr := new Test.IORInterceptor.Impl.Object; PortableInterceptor.IORInterceptor.Set (IOR_Ref, CORBA.Impl.Object_Ptr (IOR_Ptr)); PortableInterceptor.ORBInitInfo.Add_IOR_Interceptor (Info, IOR_Ref); end Post_Init; end Test.ServerORBInitializer.Impl; polyorb-2.8~20110207.orig/testsuite/corba/portableinterceptor/test004/test-demo-impl.ads0000644000175000017500000000447211750740340030353 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- T E S T . D E M O . I M P L -- -- -- -- S p e c -- -- -- -- Copyright (C) 2005 Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with PortableServer; package Test.Demo.Impl is type Object is new PortableServer.Servant_Base with private; type Object_Ptr is access all Object'Class; procedure shutdown (Self : access Object); private type Object is new PortableServer.Servant_Base with null record; end Test.Demo.Impl; polyorb-2.8~20110207.orig/testsuite/corba/portableinterceptor/test004/test-iorinterceptor-impl.adb0000644000175000017500000000737011750740340032456 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- T E S T . I O R I N T E R C E P T O R . I M P L -- -- -- -- B o d y -- -- -- -- Copyright (C) 2005-2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with CORBA.ORB; with IOP.Codec; with IOP.CodecFactory.Helper; with PortableInterceptor.Interceptor; package body Test.IORInterceptor.Impl is -------------------------- -- Establish_Components -- -------------------------- procedure Establish_Components (Self : access Object; Info : PortableInterceptor.IORInfo.Local_Ref) is pragma Unreferenced (Self); Factory : IOP.CodecFactory.Local_Ref; Codec : IOP.Codec.Local_Ref; Version : constant CORBA.Any := CORBA.To_Any (CORBA.Unsigned_Long'(123456789)); begin Factory := IOP.CodecFactory.Helper.To_Local_Ref (CORBA.ORB.Resolve_Initial_References (CORBA.ORB.To_CORBA_String ("CodecFactory"))); Codec := IOP.CodecFactory.Create_Codec (Factory, (IOP.Encoding_CDR_Encaps, 1, 2)); PortableInterceptor.IORInfo.Add_IOR_Component (Info, (IOP.Tag_ORB_Type, IOP.ComponentData (IOP.Codec.Encode_Value (Codec, Version)))); end Establish_Components; ---------- -- Is_A -- ---------- function Is_A (Self : not null access Object; Logical_Type_Id : Standard.String) return Boolean is pragma Unreferenced (Self); begin return CORBA.Is_Equivalent (Logical_Type_Id, Test.IORInterceptor.Repository_Id) or else CORBA.Is_Equivalent (Logical_Type_Id, PortableInterceptor.IORInterceptor.Repository_Id) or else CORBA.Is_Equivalent (Logical_Type_Id, PortableInterceptor.Interceptor.Repository_Id) or else CORBA.Is_Equivalent (Logical_Type_Id, "IDL:omg.org/CORBA/Object:1.0"); end Is_A; end Test.IORInterceptor.Impl; polyorb-2.8~20110207.orig/testsuite/corba/portableinterceptor/test004/Makefile.local0000644000175000017500000000013211750740340027540 0ustar xavierxavier${current_dir}test.idl-stamp: idlac_flags := ${test_target}: ${current_dir}test.idl-stamp polyorb-2.8~20110207.orig/testsuite/corba/portableinterceptor/test004/test-iorinterceptor-impl.ads0000644000175000017500000000520011750740340032465 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- T E S T . I O R I N T E R C E P T O R . I M P L -- -- -- -- S p e c -- -- -- -- Copyright (C) 2005-2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with PortableInterceptor.IORInfo; with PortableInterceptor.IORInterceptor.Impl; package Test.IORInterceptor.Impl is type Object is new PortableInterceptor.IORInterceptor.Impl.Object with private; type Object_Ptr is access all Object'Class; private type Object is new PortableInterceptor.IORInterceptor.Impl.Object with null record; function Is_A (Self : not null access Object; Logical_Type_Id : Standard.String) return Boolean; procedure Establish_Components (Self : access Object; Info : PortableInterceptor.IORInfo.Local_Ref); end Test.IORInterceptor.Impl; ././@LongLink0000000000000000000000000000014600000000000011566 Lustar rootrootpolyorb-2.8~20110207.orig/testsuite/corba/portableinterceptor/test004/test-clientinterceptor-impl.adspolyorb-2.8~20110207.orig/testsuite/corba/portableinterceptor/test004/test-clientinterceptor-impl.ad0000644000175000017500000000526011750740340032775 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- T E S T . C L I E N T I N T E R C E P T O R . I M P L -- -- -- -- S p e c -- -- -- -- Copyright (C) 2005-2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with PortableInterceptor.ClientRequestInfo; with PortableInterceptor.ClientRequestInterceptor.Impl; package Test.ClientInterceptor.Impl is type Object is new PortableInterceptor.ClientRequestInterceptor.Impl.Object with private; type Object_Ptr is access all Object'Class; private type Object is new PortableInterceptor.ClientRequestInterceptor.Impl.Object with null record; function Is_A (Self : not null access Object; Logical_Type_Id : Standard.String) return Boolean; procedure Send_Request (Self : access Object; RI : PortableInterceptor.ClientRequestInfo.Local_Ref); end Test.ClientInterceptor.Impl; polyorb-2.8~20110207.orig/testsuite/corba/portableinterceptor/test004/test-demo-impl.adb0000644000175000017500000000452011750740340030324 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- T E S T . D E M O . I M P L -- -- -- -- B o d y -- -- -- -- Copyright (C) 2005 Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with CORBA.ORB; with Test.Demo.Skel; pragma Warnings (Off, Test.Demo.Skel); package body Test.Demo.Impl is -------------- -- shutdown -- -------------- procedure shutdown (Self : access Object) is pragma Unreferenced (Self); begin CORBA.ORB.Shutdown (False); end shutdown; end Test.Demo.Impl; ././@LongLink0000000000000000000000000000015100000000000011562 Lustar rootrootpolyorb-2.8~20110207.orig/testsuite/corba/portableinterceptor/test004/test-clientorbinitializer-impl.adspolyorb-2.8~20110207.orig/testsuite/corba/portableinterceptor/test004/test-clientorbinitializer-impl0000644000175000017500000000520211750740340033076 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- T E S T . C L I E N T O R B I N I T I A L I Z E R . I M P L -- -- -- -- S p e c -- -- -- -- Copyright (C) 2005-2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with PortableInterceptor.ORBInitInfo; with PortableInterceptor.ORBInitializer.Impl; package Test.ClientORBInitializer.Impl is type Object is new PortableInterceptor.ORBInitializer.Impl.Object with private; type Object_Ptr is access all Object'Class; private type Object is new PortableInterceptor.ORBInitializer.Impl.Object with null record; function Is_A (Self : not null access Object; Logical_Type_Id : Standard.String) return Boolean; procedure Post_Init (Self : access Object; Info : PortableInterceptor.ORBInitInfo.Local_Ref); end Test.ClientORBInitializer.Impl; ././@LongLink0000000000000000000000000000014600000000000011566 Lustar rootrootpolyorb-2.8~20110207.orig/testsuite/corba/portableinterceptor/test004/test-clientinterceptor-impl.adbpolyorb-2.8~20110207.orig/testsuite/corba/portableinterceptor/test004/test-clientinterceptor-impl.ad0000644000175000017500000001224411750740340032775 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- T E S T . C L I E N T I N T E R C E P T O R . I M P L -- -- -- -- B o d y -- -- -- -- Copyright (C) 2005-2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with Ada.Exceptions; with Ada.Text_IO; with CONV_FRAME.Helper; with CORBA.IDL_SEQUENCES; with CORBA.ORB; with IOP.Codec; with IOP.CodecFactory.Helper; with PortableInterceptor.Interceptor; with PolyORB.Utils.Report; package body Test.ClientInterceptor.Impl is ---------- -- Is_A -- ---------- function Is_A (Self : not null access Object; Logical_Type_Id : Standard.String) return Boolean is pragma Unreferenced (Self); begin return CORBA.Is_Equivalent (Logical_Type_Id, Test.ClientInterceptor.Repository_Id) or else CORBA.Is_Equivalent (Logical_Type_Id, PortableInterceptor.ClientRequestInterceptor.Repository_Id) or else CORBA.Is_Equivalent (Logical_Type_Id, PortableInterceptor.Interceptor.Repository_Id) or else CORBA.Is_Equivalent (Logical_Type_Id, "IDL:omg.org/CORBA/Object:1.0"); end Is_A; ------------------ -- Send_Request -- ------------------ procedure Send_Request (Self : access Object; RI : PortableInterceptor.ClientRequestInfo.Local_Ref) is pragma Unreferenced (Self); use type CORBA.Unsigned_Long; Factory : IOP.CodecFactory.Local_Ref; Codec : IOP.Codec.Local_Ref; begin Factory := IOP.CodecFactory.Helper.To_Local_Ref (CORBA.ORB.Resolve_Initial_References (CORBA.ORB.To_CORBA_String ("CodecFactory"))); Codec := IOP.CodecFactory.Create_Codec (Factory, (IOP.Encoding_CDR_Encaps, 1, 2)); begin PolyORB.Utils.Report.Output ("Added tagged component present in IOR", CORBA.Unsigned_Long' (CORBA.From_Any (IOP.Codec.Decode_Value (Codec, CORBA.IDL_SEQUENCES.OctetSeq (PortableInterceptor.ClientRequestInfo.Get_Effective_Component (RI, IOP.Tag_ORB_Type).Component_Data), CORBA.TC_Unsigned_Long))) = 123456789); exception when E : others => PolyORB.Utils.Report.Output ("Added tagged component present in IOR", False); Ada.Text_IO.Put_Line (Ada.Exceptions.Exception_Information (E)); end; declare Info : CONV_FRAME.CodeSetComponentInfo; pragma Warnings (Off, Info); begin Info := CONV_FRAME.Helper.From_Any (IOP.Codec.Decode_Value (Codec, CORBA.IDL_SEQUENCES.OctetSeq (PortableInterceptor.ClientRequestInfo.Get_Effective_Component (RI, IOP.Tag_Code_Sets).Component_Data), CONV_FRAME.Helper.TC_CodeSetComponentInfo)); PolyORB.Utils.Report.Output ("TAG_CODE_SETS component present and unmarshalled", True); exception when E : others => PolyORB.Utils.Report.Output ("TAG_CODE_SETS component present and unmarshalled ", False); Ada.Text_IO.Put_Line (Ada.Exceptions.Exception_Information (E)); end; end Send_Request; end Test.ClientInterceptor.Impl; ././@LongLink0000000000000000000000000000015100000000000011562 Lustar rootrootpolyorb-2.8~20110207.orig/testsuite/corba/portableinterceptor/test004/test-clientorbinitializer-impl.adbpolyorb-2.8~20110207.orig/testsuite/corba/portableinterceptor/test004/test-clientorbinitializer-impl0000644000175000017500000000657211750740340033111 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- T E S T . C L I E N T O R B I N I T I A L I Z E R . I M P L -- -- -- -- B o d y -- -- -- -- Copyright (C) 2005-2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with CORBA.Impl; with PortableInterceptor.ClientRequestInterceptor; with Test.ClientInterceptor.Impl; package body Test.ClientORBInitializer.Impl is ---------- -- Is_A -- ---------- function Is_A (Self : not null access Object; Logical_Type_Id : Standard.String) return Boolean is pragma Unreferenced (Self); begin return CORBA.Is_Equivalent (Logical_Type_Id, Test.ClientORBInitializer.Repository_Id) or else CORBA.Is_Equivalent (Logical_Type_Id, PortableInterceptor.ORBInitializer.Repository_Id) or else CORBA.Is_Equivalent (Logical_Type_Id, "IDL:omg.org/CORBA/Object:1.0"); end Is_A; --------------- -- Post_Init -- --------------- procedure Post_Init (Self : access Object; Info : PortableInterceptor.ORBInitInfo.Local_Ref) is pragma Unreferenced (Self); Client_Ref : PortableInterceptor.ClientRequestInterceptor.Local_Ref; Client_Ptr : Test.ClientInterceptor.Impl.Object_Ptr; begin Client_Ptr := new Test.ClientInterceptor.Impl.Object; PortableInterceptor.ClientRequestInterceptor.Set (Client_Ref, CORBA.Impl.Object_Ptr (Client_Ptr)); PortableInterceptor.ORBInitInfo.Add_Client_Request_Interceptor (Info, Client_Ref); end Post_Init; end Test.ClientORBInitializer.Impl; ././@LongLink0000000000000000000000000000015100000000000011562 Lustar rootrootpolyorb-2.8~20110207.orig/testsuite/corba/portableinterceptor/test004/test-serverorbinitializer-impl.adspolyorb-2.8~20110207.orig/testsuite/corba/portableinterceptor/test004/test-serverorbinitializer-impl0000644000175000017500000000520411750740340033130 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- T E S T . S E R V E R O R B I N I T I A L I Z E R . I M P L -- -- -- -- S p e c -- -- -- -- Copyright (C) 2005-2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with PortableInterceptor.ORBInitializer.Impl; with PortableInterceptor.ORBInitInfo; package Test.ServerORBInitializer.Impl is type Object is new PortableInterceptor.ORBInitializer.Impl.Object with private; type Object_Ptr is access all Object'Class; private type Object is new PortableInterceptor.ORBInitializer.Impl.Object with null record; function Is_A (Self : not null access Object; Logical_Type_Id : Standard.String) return Boolean; procedure Post_Init (Self : access Object; Info : PortableInterceptor.ORBInitInfo.Local_Ref); end Test.ServerORBInitializer.Impl; polyorb-2.8~20110207.orig/testsuite/corba/portableinterceptor/test004/local.gpr0000644000175000017500000000070211750740340026616 0ustar xavierxavierwith "polyorb", "polyorb_test_common"; project local is Dir := external ("Test_Dir"); Obj_Dir := PolyORB_Test_Common.Build_Dir & Dir; for Object_Dir use Obj_Dir; for Source_Dirs use (Obj_Dir, PolyORB_Test_Common.Source_Dir & Dir); package Compiler is for Default_Switches ("Ada") use PolyORB_Test_Common.Compiler'Default_Switches ("Ada"); end Compiler; for Main use ("server.adb", "client.adb"); end local; polyorb-2.8~20110207.orig/testsuite/corba/portableinterceptor/test004/test.idl0000644000175000017500000000076211750740340026471 0ustar xavierxavier import ::PortableInterceptor; module Test { interface Demo { void shutdown (); }; local interface IORInterceptor : PortableInterceptor::IORInterceptor { }; local interface ClientInterceptor : PortableInterceptor::ClientRequestInterceptor { }; local interface ClientORBInitializer : PortableInterceptor::ORBInitializer { }; local interface ServerORBInitializer : PortableInterceptor::ORBInitializer { }; }; polyorb-2.8~20110207.orig/testsuite/corba/portableinterceptor/test004/server.adb0000644000175000017500000001033311750740340026771 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- S E R V E R -- -- -- -- B o d y -- -- -- -- Copyright (C) 2005-2007, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with Ada.Text_IO; with CORBA.Impl; with CORBA.Object; with CORBA.ORB; with CORBA.Policy; with PortableInterceptor.ORBInitializer.Initialize_All; with PortableInterceptor.ORBInitializer.Register; with PortableServer.POA.Helper; with PortableServer.POAManager; with PolyORB.Setup.No_Tasking_Server; pragma Warnings (Off, PolyORB.Setup.No_Tasking_Server); with Test.Demo.Impl; with Test.ServerORBInitializer.Impl; procedure Server is begin -- Initialize ORB declare Argv : CORBA.ORB.Arg_List := CORBA.ORB.Command_Line_Arguments; begin CORBA.ORB.Init (CORBA.ORB.To_CORBA_String ("ORB"), Argv); end; -- Register Interceptors declare Ptr : constant Test.ServerORBInitializer.Impl.Object_Ptr := new Test.ServerORBInitializer.Impl.Object; Ref : PortableInterceptor.ORBInitializer.Local_Ref; begin PortableInterceptor.ORBInitializer.Set (Ref, CORBA.Impl.Object_Ptr (Ptr)); PortableInterceptor.ORBInitializer.Register (Ref); PortableInterceptor.ORBInitializer.Initialize_All; end; -- Create POA and object reference declare Root_POA : PortableServer.POA.Local_Ref; My_POA : PortableServer.POA.Local_Ref; Policies : CORBA.Policy.PolicyList; Ref : CORBA.Object.Ref; Obj : constant CORBA.Impl.Object_Ptr := new Test.Demo.Impl.Object; begin -- Retrieve Root POA Root_POA := PortableServer.POA.Helper.To_Local_Ref (CORBA.ORB.Resolve_Initial_References (CORBA.ORB.To_CORBA_String ("RootPOA"))); PortableServer.POAManager.Activate (PortableServer.POA.Get_The_POAManager (Root_POA)); -- Create My POA My_POA := PortableServer.POA.Local_Ref (PortableServer.POA.Create_POA (Root_POA, CORBA.To_CORBA_String ("My_POA"), PortableServer.POA.Get_The_POAManager (Root_POA), Policies)); -- Set up new object Ref := PortableServer.POA.Servant_To_Reference (My_POA, PortableServer.Servant (Obj)); Ada.Text_IO.Put_Line ("'" & CORBA.To_Standard_String (CORBA.Object.Object_To_String (Ref)) & "'"); -- Launch the server CORBA.ORB.Run; end; end Server; polyorb-2.8~20110207.orig/testsuite/corba/portableinterceptor/test004/client.adb0000644000175000017500000000642211750740340026745 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- C L I E N T -- -- -- -- B o d y -- -- -- -- Copyright (C) 2005 Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with Ada.Command_Line; with CORBA.Impl; with CORBA.ORB; with PolyORB.Utils.Report; with PortableInterceptor.ORBInitializer.Initialize_All; with PortableInterceptor.ORBInitializer.Register; with PolyORB.Setup.Client; pragma Warnings (Off, PolyORB.Setup.Client); with Test.ClientORBInitializer.Impl; with Test.Demo; procedure Client is begin PolyORB.Utils.Report.New_Test ("Adding and retrieving tagged components"); -- Initialize ORB declare Argv : CORBA.ORB.Arg_List := CORBA.ORB.Command_Line_Arguments; begin CORBA.ORB.Init (CORBA.ORB.To_CORBA_String ("ORB"), Argv); end; -- Register Interceptors declare Ptr : constant Test.ClientORBInitializer.Impl.Object_Ptr := new Test.ClientORBInitializer.Impl.Object; Ref : PortableInterceptor.ORBInitializer.Local_Ref; begin PortableInterceptor.ORBInitializer.Set (Ref, CORBA.Impl.Object_Ptr (Ptr)); PortableInterceptor.ORBInitializer.Register (Ref); PortableInterceptor.ORBInitializer.Initialize_All; end; declare Ref : Test.Demo.Ref; begin CORBA.ORB.String_To_Object (CORBA.To_CORBA_String (Ada.Command_Line.Argument (1)), Ref); Test.Demo.shutdown (Ref); end; PolyORB.Utils.Report.End_Report; end Client; polyorb-2.8~20110207.orig/testsuite/corba/portableinterceptor/test001/0000755000175000017500000000000011750740340025010 5ustar xavierxavier././@LongLink0000000000000000000000000000015400000000000011565 Lustar rootrootpolyorb-2.8~20110207.orig/testsuite/corba/portableinterceptor/test001/test001_client_request_info_tests.adbpolyorb-2.8~20110207.orig/testsuite/corba/portableinterceptor/test001/test001_client_request_info_te0000644000175000017500000003176211750740340032755 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- T E S T 0 0 1 _ C L I E N T _ R E Q U E S T _ I N F O _ T E S T S -- -- -- -- B o d y -- -- -- -- Copyright (C) 2004-2008, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with CORBA.Object; with CORBA.Policy; with IOP; with Test001_Interface.Helper; package body Test001_Client_Request_Info_Tests is use CORBA; use CORBA.Object; use CORBA.TypeCode; use PortableInterceptor.ClientRequestInfo; use Test001_Globals; use Test001_Interface; use Test001_Interface.Helper; -------------------------------------- -- Test_Add_Request_Service_Context -- -------------------------------------- procedure Test_Add_Request_Service_Context (Point : Client_Interception_Point; Info : PortableInterceptor.ClientRequestInfo.Local_Ref) is Operation : constant String := "add_request_service_context"; Valid : constant Boolean := Point = Send_Request; begin Add_Request_Service_Context (Info, Test_Request_Context, False); if Valid then Output (Point, Operation, True); else Output (Point, Operation, False); end if; exception when E : Bad_Inv_Order => declare Members : System_Exception_Members; begin Get_Members (E, Members); if not Valid and then Members.Minor = OMGVMCID + 14 then Output (Point, Operation, True); else Output (Point, Operation, False); end if; end; when others => Output (Point, Operation, False); end Test_Add_Request_Service_Context; ---------------------------- -- Test_Effective_Profile -- ---------------------------- procedure Test_Effective_Profile (Point : Client_Interception_Point; Info : PortableInterceptor.ClientRequestInfo.Local_Ref) is use type IOP.ProfileId; Operation : constant String := "effective_profile"; Profile : IOP.TaggedProfile; begin Profile := Get_Effective_Profile (Info); if Profile.Tag /= IOP.Tag_Internet_IOP then Output (Point, Operation, False); else Output (Point, Operation, True); end if; exception when others => Output (Point, Operation, False); end Test_Effective_Profile; --------------------------- -- Test_Effective_Target -- --------------------------- procedure Test_Effective_Target (Point : Client_Interception_Point; Info : PortableInterceptor.ClientRequestInfo.Local_Ref) is Operation : constant String := "effective_target"; Obj : CORBA.Object.Ref; begin Obj := Get_Effective_Target (Info); if Is_Equivalent (Obj, Test001_Globals.Test_Object) then Output (Point, Operation, True); else Output (Point, Operation, False); end if; exception when others => Output (Point, Operation, False); end Test_Effective_Target; ---------------------------------- -- Test_Get_Effective_Component -- ---------------------------------- procedure Test_Get_Effective_Component (Point : Client_Interception_Point; Info : PortableInterceptor.ClientRequestInfo.Local_Ref) is use type IOP.ComponentId; Operation : constant String := "get_effective_component"; Valid : constant Boolean := Point /= Send_Poll; Aux : IOP.TaggedComponent; begin begin Aux := Get_Effective_Component (Info, IOP.Tag_Code_Sets); if not Valid then Output (Point, Operation, False); return; elsif Aux.Tag /= IOP.Tag_Code_Sets then Output (Point, Operation, False); return; end if; exception when E : Bad_Inv_Order => declare Members : System_Exception_Members; begin Get_Members (E, Members); if Valid or else Members.Minor /= OMGVMCID + 14 then Output (Point, Operation, False); return; end if; end; when others => Output (Point, Operation, False); return; end; begin Aux := Get_Effective_Component (Info, IOP.Tag_Null_Tag); Output (Point, Operation, False); exception when E : Bad_Param => declare Members : System_Exception_Members; begin Get_Members (E, Members); if Members.Minor = OMGVMCID + 28 then Output (Point, Operation, True); else Output (Point, Operation, False); end if; end; when others => Output (Point, Operation, False); end; end Test_Get_Effective_Component; ----------------------------------- -- Test_Get_Effective_Components -- ----------------------------------- procedure Test_Get_Effective_Components (Point : Client_Interception_Point; Info : PortableInterceptor.ClientRequestInfo.Local_Ref) is use type IOP.ComponentId; Operation : constant String := "get_effective_components"; Valid : constant Boolean := Point /= Send_Poll; Aux : IOP.TaggedComponentSeq; begin begin Aux := Get_Effective_Components (Info, IOP.Tag_Code_Sets); if not Valid then Output (Point, Operation, False); return; elsif IOP.Length (Aux) /= 1 then Output (Point, Operation, False); return; elsif IOP.Get_Element (Aux, 1).Tag /= IOP.Tag_Code_Sets then Output (Point, Operation, False); return; end if; exception when E : Bad_Inv_Order => declare Members : System_Exception_Members; begin Get_Members (E, Members); if Valid or else Members.Minor /= OMGVMCID + 14 then Output (Point, Operation, False); return; end if; end; when others => Output (Point, Operation, False); return; end; begin Aux := Get_Effective_Components (Info, IOP.Tag_Null_Tag); Output (Point, Operation, False); exception when E : Bad_Param => declare Members : System_Exception_Members; begin Get_Members (E, Members); if Members.Minor = OMGVMCID + 28 then Output (Point, Operation, True); else Output (Point, Operation, False); end if; end; when others => Output (Point, Operation, False); end; end Test_Get_Effective_Components; ----------------------------- -- Test_Get_Request_Policy -- ----------------------------- procedure Test_Get_Request_Policy (Point : Client_Interception_Point; Info : PortableInterceptor.ClientRequestInfo.Local_Ref) is Operation : constant String := "get_request_policy"; Valid : constant Boolean := Point /= Send_Poll; Pol : CORBA.Policy.Ref; -- pragma Unreferenced (Pol); pragma Warnings (Off, Pol); -- WAG:5.02 DB08-008 -- Assigned but never read begin -- XXX Functionality test not implemented Pol := Get_Request_Policy (Info, 1); if not Valid then Output (Point, Operation, False); else Output (Point, Operation, True); end if; exception when E : Inv_Policy => declare Members : System_Exception_Members; begin Get_Members (E, Members); if Valid and then Members.Minor = OMGVMCID + 2 then Output (Point, Operation, True, " (INV_POLICY)"); else Output (Point, Operation, False); end if; end; when E : Bad_Inv_Order => declare Members : System_Exception_Members; begin Get_Members (E, Members); if not Valid and then Members.Minor = OMGVMCID + 14 then Output (Point, Operation, True); else Output (Point, Operation, False); end if; end; when others => Output (Point, Operation, False); end Test_Get_Request_Policy; ----------------------------- -- Test_Received_Exception -- ----------------------------- procedure Test_Received_Exception (Point : Client_Interception_Point; Info : PortableInterceptor.ClientRequestInfo.Local_Ref) is Operation : constant String := "received_exception"; Valid : constant Boolean := Point = Receive_Exception; Exc : Any; begin Exc := Get_Received_Exception (Info); if not Valid then Output (Point, Operation, False); elsif Get_Type (Exc) /= TC_Test_Exception then Output (Point, Operation, False); else Output (Point, Operation, True); end if; exception when E : Bad_Inv_Order => declare Members : System_Exception_Members; begin Get_Members (E, Members); if not Valid and then Members.Minor = OMGVMCID + 14 then Output (Point, Operation, True); else Output (Point, Operation, False); end if; end; when others => Output (Point, Operation, False); end Test_Received_Exception; -------------------------------- -- Test_Received_Exception_Id -- -------------------------------- procedure Test_Received_Exception_Id (Point : Client_Interception_Point; Info : PortableInterceptor.ClientRequestInfo.Local_Ref) is Operation : constant String := "received_exception_id"; Valid : constant Boolean := Point = Receive_Exception; Id : RepositoryId; begin Id := Get_Received_Exception_Id (Info); if Id /= Test_Exception_Repository_Id then Output (Point, Operation, False); else Output (Point, Operation, True); end if; exception when E : Bad_Inv_Order => declare Members : System_Exception_Members; begin Get_Members (E, Members); if not Valid and then Members.Minor = OMGVMCID + 14 then Output (Point, Operation, True); else Output (Point, Operation, False); end if; end; when others => Output (Point, Operation, False); end Test_Received_Exception_Id; ----------------- -- Test_Target -- ----------------- procedure Test_Target (Point : Client_Interception_Point; Info : PortableInterceptor.ClientRequestInfo.Local_Ref) is Operation : constant String := "target"; Obj : CORBA.Object.Ref; begin Obj := Get_Target (Info); if Is_Equivalent (Obj, Test001_Globals.Test_Object) then Output (Point, Operation, True); else Output (Point, Operation, False); end if; exception when others => Output (Point, Operation, False); end Test_Target; end Test001_Client_Request_Info_Tests; polyorb-2.8~20110207.orig/testsuite/corba/portableinterceptor/test001/test001_globals.adb0000644000175000017500000000554311750740340030372 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- T E S T 0 0 1 _ G L O B A L S -- -- -- -- B o d y -- -- -- -- Copyright (C) 2004-2008, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by ACT Europe. -- -- (email: sales@act-europe.fr) -- -- -- ------------------------------------------------------------------------------ with Ada.Characters.Handling; with PolyORB.Utils.Report; package body Test001_Globals is ----------- -- Image -- ----------- function Image (Value : Interception_Point) return String is begin return Ada.Characters.Handling.To_Lower (Interception_Point'Image (Value)); end Image; ------------ -- Output -- ------------ procedure Output (Point : Interception_Point; Operation : String; Status : Boolean; Comment : String := "") is begin if Point in Client_Interception_Point then PolyORB.Utils.Report.Output ("[" & Image (Point) & "] CRI::" & Operation & Comment, Status); else PolyORB.Utils.Report.Output ("[" & Image (Point) & "] SRI::" & Operation & Comment, Status); end if; end Output; end Test001_Globals; polyorb-2.8~20110207.orig/testsuite/corba/portableinterceptor/test001/test001_interface-impl.ads0000644000175000017500000000461111750740340031662 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- T E S T 0 0 1 _ I N T E R F A C E . I M P L -- -- -- -- S p e c -- -- -- -- Copyright (C) 2004-2008, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by ACT Europe. -- -- (email: sales@act-europe.fr) -- -- -- ------------------------------------------------------------------------------ with CORBA; with PortableServer; package Test001_Interface.Impl is type Object is new PortableServer.Servant_Base with private; type Object_Ptr is access all Object'Class; function Func (Self : access Object; Value : CORBA.Long) return CORBA.Long; private type Object is new PortableServer.Servant_Base with null record; end Test001_Interface.Impl; ././@LongLink0000000000000000000000000000015200000000000011563 Lustar rootrootpolyorb-2.8~20110207.orig/testsuite/corba/portableinterceptor/test001/test001_server_interceptor-impl.adbpolyorb-2.8~20110207.orig/testsuite/corba/portableinterceptor/test001/test001_server_interceptor-imp0000644000175000017500000002343311750740340032727 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- T E S T 0 0 1 _ S E R V E R _ I N T E R C E P T O R . I M P L -- -- -- -- B o d y -- -- -- -- Copyright (C) 2004-2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with CORBA.Object; with PortableInterceptor.Helper; with PortableInterceptor.Interceptor; with Test001_Globals; with Test001_Request_Info_Tests; with Test001_Server_Request_Info_Tests; package body Test001_Server_Interceptor.Impl is use Test001_Globals; use Test001_Request_Info_Tests; use Test001_Server_Request_Info_Tests; procedure Test_Interception_Point (Point : Server_Interception_Point; Info : PortableInterceptor.ServerRequestInfo.Local_Ref); ---------- -- Is_A -- ---------- function Is_A (Self : not null access Object; Logical_Type_Id : Standard.String) return Boolean is pragma Unreferenced (Self); begin return CORBA.Is_Equivalent (Logical_Type_Id, Test001_Server_Interceptor.Repository_Id) or else CORBA.Is_Equivalent (Logical_Type_Id, PortableInterceptor.ServerRequestInterceptor.Repository_Id) or else CORBA.Is_Equivalent (Logical_Type_Id, PortableInterceptor.Interceptor.Repository_Id) or else CORBA.Is_Equivalent (Logical_Type_Id, "IDL:omg.org/CORBA/Object:1.0"); end Is_A; --------------------- -- Receive_Request -- --------------------- procedure Receive_Request (Self : access Object; RI : PortableInterceptor.ServerRequestInfo.Local_Ref) is pragma Unreferenced (Self); begin Test_Interception_Point (Receive_Request, RI); if Forward_Location then Forward_Location := False; PortableInterceptor.Helper.Raise_ForwardRequest (PortableInterceptor.ForwardRequest_Members' (Forward => CORBA.Object.Ref (Test_Forward_Object))); end if; end Receive_Request; -------------------------------------- -- Receive_Request_Service_Contexts -- -------------------------------------- procedure Receive_Request_Service_Contexts (Self : access Object; RI : PortableInterceptor.ServerRequestInfo.Local_Ref) is pragma Unreferenced (Self); begin Test_Interception_Point (Receive_Request_Service_Contexts, RI); end Receive_Request_Service_Contexts; -------------------- -- Send_Exception -- -------------------- procedure Send_Exception (Self : access Object; RI : PortableInterceptor.ServerRequestInfo.Local_Ref) is pragma Unreferenced (Self); begin Test_Interception_Point (Send_Exception, RI); end Send_Exception; ---------------- -- Send_Other -- ---------------- procedure Send_Other (Self : access Object; RI : PortableInterceptor.ServerRequestInfo.Local_Ref) is pragma Unreferenced (Self); begin Test_Interception_Point (Send_Other, RI); end Send_Other; ---------------- -- Send_Reply -- ---------------- procedure Send_Reply (Self : access Object; RI : PortableInterceptor.ServerRequestInfo.Local_Ref) is pragma Unreferenced (Self); begin Test_Interception_Point (Send_Reply, RI); end Send_Reply; ----------------------------- -- Test_Interception_Point -- ----------------------------- procedure Test_Interception_Point (Point : Server_Interception_Point; Info : PortableInterceptor.ServerRequestInfo.Local_Ref) is begin if not Test001_Globals.Enable_Test_Point (Point) then -- Test_Request_Id must be always called at -- Receive_Request_Service_Contexts point, -- because it store actual request_id. if Point = Receive_Request_Service_Contexts then begin Test_Request_Id (Point, Info, True); exception when others => Output (Point, "request_id", False); end; end if; return; end if; begin Test_Request_Id (Point, Info); exception when others => Output (Point, "request_id", False); end; begin Test_Operation (Point, Info); exception when others => Output (Point, "operation", False); end; begin Test_Arguments (Point, Info); exception when others => Output (Point, "arguments", False); end; begin Test_Exceptions (Point, Info); exception when others => Output (Point, "exceptions", False); end; begin Test_Contexts (Point, Info); exception when others => Output (Point, "contexts", False); end; begin Test_Operation_Context (Point, Info); exception when others => Output (Point, "operation_context", False); end; begin Test_Result (Point, Info); exception when others => Output (Point, "result", False); end; begin Test_Response_Expected (Point, Info); exception when others => Output (Point, "response_expected", False); end; begin Test_Sync_Scope (Point, Info); exception when others => Output (Point, "sync_scope", False); end; begin Test_Reply_Status (Point, Info); exception when others => Output (Point, "reply_status", False); end; begin Test_Forward_Reference (Point, Info); exception when others => Output (Point, "forward_reference", False); end; begin Test_Get_Slot (Point, Info); exception when others => Output (Point, "get_slot", False); end; begin Test_Get_Request_Service_Context (Point, Info); exception when others => Output (Point, "get_request_service_context", False); end; begin Test_Get_Reply_Service_Context (Point, Info); exception when others => Output (Point, "get_reply_service_context", False); end; begin Test_Sending_Exception (Point, Info); exception when others => Output (Point, "sending_exception", False); end; begin Test_Object_Id (Point, Info); exception when others => Output (Point, "object_id", False); end; begin Test_Adapter_Id (Point, Info); exception when others => Output (Point, "adapter_id", False); end; begin Test_Server_Id (Point, Info); exception when others => Output (Point, "server_id", False); end; begin Test_ORB_Id (Point, Info); exception when others => Output (Point, "ORB_id", False); end; begin Test_Adapter_Name (Point, Info); exception when others => Output (Point, "adapter_name", False); end; begin Test_Target_Most_Derived_Interface (Point, Info); exception when others => Output (Point, "target_most_derived_interface", False); end; begin Test_Get_Server_Policy (Point, Info); exception when others => Output (Point, "get_server_policy", False); end; begin Test_Set_Slot (Point, Info); exception when others => Output (Point, "set_slot", False); end; begin Test_Target_Is_A (Point, Info); exception when others => Output (Point, "target_is_a", False); end; begin Test_Add_Reply_Service_Context (Point, Info); exception when others => Output (Point, "add_reply_service_context", False); end; end Test_Interception_Point; end Test001_Server_Interceptor.Impl; polyorb-2.8~20110207.orig/testsuite/corba/portableinterceptor/test001/test001_globals.ads0000644000175000017500000000676511750740340030422 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- T E S T 0 0 1 _ G L O B A L S -- -- -- -- S p e c -- -- -- -- Copyright (C) 2004-2008, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with CORBA; with IOP.Codec; with PortableInterceptor; with Test001_Interface; package Test001_Globals is Pass_Not_Implemented : Boolean := True; -- Iff set to True then all non implemented tests successfully passed. type Interception_Point is (Send_Request, Send_Poll, Receive_Reply, Receive_Exception, Receive_Other, Receive_Request_Service_Contexts, Receive_Request, Send_Reply, Send_Exception, Send_Other); subtype Client_Interception_Point is Interception_Point range Send_Request .. Receive_Other; subtype Server_Interception_Point is Interception_Point range Receive_Request_Service_Contexts .. Send_Other; Test_Object : Test001_Interface.Ref; Test_ObjectId : PortableInterceptor.ObjectId; Test_Forward_Object : Test001_Interface.Ref; Test_Codec : IOP.Codec.Local_Ref; Test_Request_Context : IOP.ServiceContext; Test_Reply_Context : IOP.ServiceContext; Test_Client_Request_Id : CORBA.Unsigned_Long; Test_Server_Request_Id : CORBA.Unsigned_Long; -- Test behavior switches Raise_Test_Exception : Boolean := False; Forward_Location : Boolean := False; Enable_Test_Point : array (Interception_Point) of Boolean := (others => False); function Image (Value : Interception_Point) return String; procedure Output (Point : Interception_Point; Operation : String; Status : Boolean; Comment : String := ""); end Test001_Globals; polyorb-2.8~20110207.orig/testsuite/corba/portableinterceptor/test001/Makefile.local0000644000175000017500000000016411750740340027542 0ustar xavierxavier${current_dir}test001_interface.idl-stamp: idlac_flags := ${test_target}: ${current_dir}test001_interface.idl-stamp ././@LongLink0000000000000000000000000000014700000000000011567 Lustar rootrootpolyorb-2.8~20110207.orig/testsuite/corba/portableinterceptor/test001/test001_orb_initializer-impl.adbpolyorb-2.8~20110207.orig/testsuite/corba/portableinterceptor/test001/test001_orb_initializer-impl.a0000644000175000017500000001176411750740340032567 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- T E S T 0 0 1 _ O R B _ I N I T I A L I Z E R . I M P L -- -- -- -- B o d y -- -- -- -- Copyright (C) 2004-2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with CORBA.Impl; with PolyORB.Utils.Report; with IOP.Codec; with IOP.CodecFactory; with PortableInterceptor.ClientRequestInterceptor; with PortableInterceptor.ORBInitializer; with PortableInterceptor.ServerRequestInterceptor; with Test001_Client_Interceptor.Impl; with Test001_Globals; with Test001_Server_Interceptor.Impl; package body Test001_ORB_Initializer.Impl is ---------- -- Is_A -- ---------- function Is_A (Self : not null access Object; Logical_Type_Id : Standard.String) return Boolean is pragma Unreferenced (Self); begin return CORBA.Is_Equivalent (Logical_Type_Id, Test001_ORB_Initializer.Repository_Id) or else CORBA.Is_Equivalent (Logical_Type_Id, PortableInterceptor.ORBInitializer.Repository_Id) or else CORBA.Is_Equivalent (Logical_Type_Id, "IDL:omg.org/CORBA/Object:1.0"); end Is_A; --------------- -- Post_Init -- --------------- procedure Post_Init (Self : access Object; Info : PortableInterceptor.ORBInitInfo.Local_Ref) is pragma Unreferenced (Self); Client_Ref : PortableInterceptor.ClientRequestInterceptor.Local_Ref; Client_Ptr : Test001_Client_Interceptor.Impl.Object_Ptr; Server_Ref : PortableInterceptor.ServerRequestInterceptor.Local_Ref; Server_Ptr : Test001_Server_Interceptor.Impl.Object_Ptr; Factory : IOP.CodecFactory.Local_Ref; begin PolyORB.Utils.Report.New_Test ("ORBInitInfo Interface"); Client_Ptr := new Test001_Client_Interceptor.Impl.Object; PortableInterceptor.ClientRequestInterceptor.Set (Client_Ref, CORBA.Impl.Object_Ptr (Client_Ptr)); PortableInterceptor.ORBInitInfo.Add_Client_Request_Interceptor (Info, Client_Ref); Server_Ptr := new Test001_Server_Interceptor.Impl.Object; PortableInterceptor.ServerRequestInterceptor.Set (Server_Ref, CORBA.Impl.Object_Ptr (Server_Ptr)); PortableInterceptor.ORBInitInfo.Add_Server_Request_Interceptor (Info, Server_Ref); begin Factory := PortableInterceptor.ORBInitInfo.Get_Codec_Factory (Info); Test001_Globals.Test_Codec := IOP.CodecFactory.Create_Codec (Factory, (IOP.Encoding_CDR_Encaps, 1, 2)); PolyORB.Utils.Report.Output ("[post_init] ORBInitInfo::codec_factory", True); exception when others => PolyORB.Utils.Report.Output ("[post_init] ORBInitInfo::codec_factory", False); end; Test001_Globals.Test_Request_Context := (654321, IOP.ContextData (IOP.Codec.Encode_Value (Test001_Globals.Test_Codec, CORBA.To_Any (CORBA.Unsigned_Long'(1))))); Test001_Globals.Test_Reply_Context := (765432, IOP.ContextData (IOP.Codec.Encode_Value (Test001_Globals.Test_Codec, CORBA.To_Any (CORBA.Unsigned_Long'(2))))); end Post_Init; end Test001_ORB_Initializer.Impl; polyorb-2.8~20110207.orig/testsuite/corba/portableinterceptor/test001/test001_interface.idl0000644000175000017500000000104011750740340030715 0ustar xavierxavier import ::PortableInterceptor; //module Test001_Idl { // interface Test001_Interface { exception Test_Exception {}; // void Proc () // raises (Test_Exception); long Func (in long Value) raises (Test_Exception); }; local interface Test001_Client_Interceptor : PortableInterceptor::ClientRequestInterceptor {}; local interface Test001_Server_Interceptor : PortableInterceptor::ServerRequestInterceptor {}; local interface Test001_ORB_Initializer : PortableInterceptor::ORBInitializer {}; //}; polyorb-2.8~20110207.orig/testsuite/corba/portableinterceptor/test001/test001.adb0000644000175000017500000001326711750740340026671 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- T E S T 0 0 1 -- -- -- -- B o d y -- -- -- -- Copyright (C) 2004-2007, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with CORBA.ORB; with PortableInterceptor.ORBInitializer.Register; with PortableInterceptor.ORBInitializer.Initialize_All; with PortableServer.POA.Helper; with PolyORB.CORBA_P.Server_Tools; with PolyORB.Smart_Pointers; with PolyORB.Utils.Report; with PolyORB.Setup.Thread_Pool_Server; pragma Warnings (Off, PolyORB.Setup.Thread_Pool_Server); with Test001_Globals; with Test001_Interface.Helper; with Test001_Interface.Impl; with Test001_ORB_Initializer.Impl; procedure Test001 is use Test001_Globals; Aux : CORBA.Long; pragma Warnings (Off, Aux); begin CORBA.ORB.Initialize ("ORB"); declare Ptr : constant Test001_ORB_Initializer.Impl.Object_Ptr := new Test001_ORB_Initializer.Impl.Object; Ref : PortableInterceptor.ORBInitializer.Local_Ref; begin PortableInterceptor.ORBInitializer.Set (Ref, PolyORB.Smart_Pointers.Entity_Ptr (Ptr)); PortableInterceptor.ORBInitializer.Register (Ref); end; PortableInterceptor.ORBInitializer.Initialize_All; PolyORB.CORBA_P.Server_Tools.Initiate_Server (True); declare Root_POA : PortableServer.POA.Local_Ref; begin Root_POA := PortableServer.POA.Helper.To_Local_Ref (CORBA.ORB.Resolve_Initial_References (CORBA.ORB.To_CORBA_String ("RootPOA"))); declare Id : constant PortableServer.ObjectId := PortableServer.POA.Activate_Object (Root_POA, new Test001_Interface.Impl.Object); begin Test_ObjectId := PortableInterceptor.ObjectId (Id); Test_Object := Test001_Interface.Helper.To_Ref (PortableServer.POA.Id_To_Reference (Root_POA, Id)); end; declare Id : constant PortableServer.ObjectId := PortableServer.POA.Activate_Object (Root_POA, new Test001_Interface.Impl.Object); begin Test_Forward_Object := Test001_Interface.Helper.To_Ref (PortableServer.POA.Id_To_Reference (Root_POA, Id)); end; end; PolyORB.Utils.Report.New_Test ("Request Information"); -- Scenario 1: normal flow -- Client.Send_Request => Server.Receive_Request_Service_Contexts => -- Server.Receive_Request => Server.Send_Reply => Client.Receive_Reply Enable_Test_Point (Send_Request) := True; Enable_Test_Point (Receive_Request_Service_Contexts) := True; Enable_Test_Point (Receive_Request) := True; Enable_Test_Point (Send_Reply) := True; Enable_Test_Point (Receive_Reply) := True; Aux := Test001_Interface.Func (Test_Object, 10); Enable_Test_Point (Send_Request) := False; Enable_Test_Point (Receive_Request_Service_Contexts) := False; Enable_Test_Point (Receive_Request) := False; Enable_Test_Point (Send_Reply) := False; Enable_Test_Point (Receive_Reply) := False; -- Scenario 2: exception flow -- Server.Send_Exception => Client.Receive_Exception Enable_Test_Point (Send_Exception) := True; Enable_Test_Point (Receive_Exception) := True; Raise_Test_Exception := True; begin Aux := Test001_Interface.Func (Test_Object, 10); exception when Test001_Interface.Test_Exception => null; end; Enable_Test_Point (Send_Exception) := False; Enable_Test_Point (Receive_Exception) := False; Raise_Test_Exception := False; -- Scenario 3: location forwarding flow -- Server.Send_Other => Client.Receive_Other Enable_Test_Point (Send_Other) := True; Enable_Test_Point (Receive_Other) := True; Forward_Location := True; Aux := Test001_Interface.Func (Test_Object, 10); Enable_Test_Point (Send_Other) := False; Enable_Test_Point (Receive_Other) := False; PolyORB.Utils.Report.End_Report; CORBA.ORB.Shutdown (False); end Test001; ././@LongLink0000000000000000000000000000015200000000000011563 Lustar rootrootpolyorb-2.8~20110207.orig/testsuite/corba/portableinterceptor/test001/test001_client_interceptor-impl.adbpolyorb-2.8~20110207.orig/testsuite/corba/portableinterceptor/test001/test001_client_interceptor-imp0000644000175000017500000002223411750740340032675 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- T E S T 0 0 1 _ C L I E N T _ I N T E R C E P T O R . I M P L -- -- -- -- B o d y -- -- -- -- Copyright (C) 2004-2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with CORBA; with PortableInterceptor.ClientRequestInterceptor; with PortableInterceptor.Interceptor; with Test001_Client_Request_Info_Tests; with Test001_Globals; with Test001_Request_Info_Tests; package body Test001_Client_Interceptor.Impl is use Test001_Client_Request_Info_Tests; use Test001_Globals; use Test001_Request_Info_Tests; procedure Test_Interception_Point (Point : Client_Interception_Point; Info : PortableInterceptor.ClientRequestInfo.Local_Ref); ---------- -- Is_A -- ---------- function Is_A (Self : not null access Object; Logical_Type_Id : Standard.String) return Boolean is pragma Unreferenced (Self); begin return CORBA.Is_Equivalent (Logical_Type_Id, Test001_Client_Interceptor.Repository_Id) or else CORBA.Is_Equivalent (Logical_Type_Id, PortableInterceptor.ClientRequestInterceptor.Repository_Id) or else CORBA.Is_Equivalent (Logical_Type_Id, PortableInterceptor.Interceptor.Repository_Id) or else CORBA.Is_Equivalent (Logical_Type_Id, "IDL:omg.org/CORBA/Object:1.0"); end Is_A; ----------------------- -- Receive_Exception -- ----------------------- procedure Receive_Exception (Self : access Object; RI : PortableInterceptor.ClientRequestInfo.Local_Ref) is pragma Unreferenced (Self); begin Test_Interception_Point (Receive_Exception, RI); end Receive_Exception; ------------------- -- Receive_Other -- ------------------- procedure Receive_Other (Self : access Object; RI : PortableInterceptor.ClientRequestInfo.Local_Ref) is pragma Unreferenced (Self); begin Test_Interception_Point (Receive_Other, RI); end Receive_Other; ------------------- -- Receive_Reply -- ------------------- procedure Receive_Reply (Self : access Object; RI : PortableInterceptor.ClientRequestInfo.Local_Ref) is pragma Unreferenced (Self); begin Test_Interception_Point (Receive_Reply, RI); end Receive_Reply; --------------- -- Send_Poll -- --------------- procedure Send_Poll (Self : access Object; RI : PortableInterceptor.ClientRequestInfo.Local_Ref) is pragma Unreferenced (Self); begin Test_Interception_Point (Send_Poll, RI); end Send_Poll; ------------------ -- Send_Request -- ------------------ procedure Send_Request (Self : access Object; RI : PortableInterceptor.ClientRequestInfo.Local_Ref) is pragma Unreferenced (Self); begin Test_Interception_Point (Send_Request, RI); end Send_Request; ----------------------------- -- Test_Interception_Point -- ----------------------------- procedure Test_Interception_Point (Point : Client_Interception_Point; Info : PortableInterceptor.ClientRequestInfo.Local_Ref) is begin if not Test001_Globals.Enable_Test_Point (Point) then -- Test_Request_Id must be always called at Send_Request point, -- because it store actual request_id. if Point = Send_Request then begin Test_Request_Id (Point, Info, True); exception when others => Output (Point, "request_id", False); end; end if; return; end if; begin Test_Request_Id (Point, Info); exception when others => Output (Point, "request_id", False); end; begin Test_Operation (Point, Info); exception when others => Output (Point, "operation", False); end; begin Test_Arguments (Point, Info); exception when others => Output (Point, "arguments", False); end; begin Test_Exceptions (Point, Info); exception when others => Output (Point, "exceptions", False); end; begin Test_Contexts (Point, Info); exception when others => Output (Point, "contexts", False); end; begin Test_Operation_Context (Point, Info); exception when others => Output (Point, "operation_context", False); end; begin Test_Result (Point, Info); exception when others => Output (Point, "result", False); end; begin Test_Response_Expected (Point, Info); exception when others => Output (Point, "response_expected", False); end; begin Test_Sync_Scope (Point, Info); exception when others => Output (Point, "sync_scope", False); end; begin Test_Reply_Status (Point, Info); exception when others => Output (Point, "reply_status", False); end; begin Test_Forward_Reference (Point, Info); exception when others => Output (Point, "forward_reference", False); end; begin Test_Get_Slot (Point, Info); exception when others => Output (Point, "get_slot", False); end; begin Test_Get_Request_Service_Context (Point, Info); exception when others => Output (Point, "get_request_service_context", False); end; begin Test_Get_Reply_Service_Context (Point, Info); exception when others => Output (Point, "get_reply_service_context", False); end; begin Test_Target (Point, Info); exception when others => Output (Point, "target", False); end; begin Test_Effective_Target (Point, Info); exception when others => Output (Point, "effective_target", False); end; begin Test_Effective_Profile (Point, Info); exception when others => Output (Point, "effective_profile", False); end; begin Test_Received_Exception (Point, Info); exception when others => Output (Point, "received_exception", False); end; begin Test_Received_Exception_Id (Point, Info); exception when others => Output (Point, "received_exception_id", False); end; begin Test_Get_Effective_Component (Point, Info); exception when others => Output (Point, "get_effective_component", False); end; begin Test_Get_Effective_Components (Point, Info); exception when others => Output (Point, "get_effective_components", False); end; begin Test_Get_Request_Policy (Point, Info); exception when others => Output (Point, "get_request_policy", False); end; begin Test_Add_Request_Service_Context (Point, Info); exception when others => Output (Point, "add_request_service_context", False); end; end Test_Interception_Point; end Test001_Client_Interceptor.Impl; ././@LongLink0000000000000000000000000000015400000000000011565 Lustar rootrootpolyorb-2.8~20110207.orig/testsuite/corba/portableinterceptor/test001/test001_client_request_info_tests.adspolyorb-2.8~20110207.orig/testsuite/corba/portableinterceptor/test001/test001_client_request_info_te0000644000175000017500000000707711750740340032757 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- T E S T 0 0 1 _ C L I E N T _ R E Q U E S T _ I N F O _ T E S T S -- -- -- -- S p e c -- -- -- -- Copyright (C) 2004-2008, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by ACT Europe. -- -- (email: sales@act-europe.fr) -- -- -- ------------------------------------------------------------------------------ with PortableInterceptor.ClientRequestInfo; with Test001_Globals; package Test001_Client_Request_Info_Tests is procedure Test_Target (Point : Test001_Globals.Client_Interception_Point; Info : PortableInterceptor.ClientRequestInfo.Local_Ref); procedure Test_Effective_Target (Point : Test001_Globals.Client_Interception_Point; Info : PortableInterceptor.ClientRequestInfo.Local_Ref); procedure Test_Effective_Profile (Point : Test001_Globals.Client_Interception_Point; Info : PortableInterceptor.ClientRequestInfo.Local_Ref); procedure Test_Received_Exception (Point : Test001_Globals.Client_Interception_Point; Info : PortableInterceptor.ClientRequestInfo.Local_Ref); procedure Test_Received_Exception_Id (Point : Test001_Globals.Client_Interception_Point; Info : PortableInterceptor.ClientRequestInfo.Local_Ref); procedure Test_Get_Effective_Component (Point : Test001_Globals.Client_Interception_Point; Info : PortableInterceptor.ClientRequestInfo.Local_Ref); procedure Test_Get_Effective_Components (Point : Test001_Globals.Client_Interception_Point; Info : PortableInterceptor.ClientRequestInfo.Local_Ref); procedure Test_Get_Request_Policy (Point : Test001_Globals.Client_Interception_Point; Info : PortableInterceptor.ClientRequestInfo.Local_Ref); procedure Test_Add_Request_Service_Context (Point : Test001_Globals.Client_Interception_Point; Info : PortableInterceptor.ClientRequestInfo.Local_Ref); end Test001_Client_Request_Info_Tests; ././@LongLink0000000000000000000000000000015400000000000011565 Lustar rootrootpolyorb-2.8~20110207.orig/testsuite/corba/portableinterceptor/test001/test001_server_request_info_tests.adbpolyorb-2.8~20110207.orig/testsuite/corba/portableinterceptor/test001/test001_server_request_info_te0000644000175000017500000003176111750740340033004 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- T E S T 0 0 1 _ S E R V E R _ R E Q U E S T _ I N F O _ T E S T S -- -- -- -- B o d y -- -- -- -- Copyright (C) 2004-2008, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with CORBA.Policy; with Test001_Interface.Helper; with Test001_Server_Interceptor; package body Test001_Server_Request_Info_Tests is use CORBA; use CORBA.TypeCode; use PortableInterceptor; use PortableInterceptor.ServerRequestInfo; use Test001_Globals; use Test001_Interface.Helper; --------------------- -- Test_Adapter_Id -- --------------------- procedure Test_Adapter_Id (Point : Server_Interception_Point; Info : PortableInterceptor.ServerRequestInfo.Local_Ref) is pragma Unreferenced (Info); Operation : constant String := "adapter_id"; begin -- XXX Not yet implemented in ServerRequestInfo Output (Point, Operation, Pass_Not_Implemented, " (NO TEST)"); end Test_Adapter_Id; ----------------------- -- Test_Adapter_Name -- ----------------------- procedure Test_Adapter_Name (Point : Server_Interception_Point; Info : PortableInterceptor.ServerRequestInfo.Local_Ref) is pragma Unreferenced (Info); Operation : constant String := "adapter_name"; begin -- XXX Not yet implemented in ServerRequestInfo Output (Point, Operation, Pass_Not_Implemented, " (NO TEST)"); end Test_Adapter_Name; ------------------------------------ -- Test_Add_Reply_Service_Context -- ------------------------------------ procedure Test_Add_Reply_Service_Context (Point : Server_Interception_Point; Info : PortableInterceptor.ServerRequestInfo.Local_Ref) is Operation : constant String := "add_reply_service_context"; begin Add_Reply_Service_Context (Info, Test_Reply_Context, True); Output (Point, Operation, True); exception when others => Output (Point, Operation, False); end Test_Add_Reply_Service_Context; ---------------------------- -- Test_Get_Server_Policy -- ---------------------------- procedure Test_Get_Server_Policy (Point : Server_Interception_Point; Info : PortableInterceptor.ServerRequestInfo.Local_Ref) is Operation : constant String := "get_server_policy"; Pol : CORBA.Policy.Ref; -- pragma Unreferenced (Pol); pragma Warnings (Off, Pol); -- WAG:5.02 DB08-008 -- Assigned but never read begin -- XXX Functionality test not implemented Pol := Get_Server_Policy (Info, 1); Output (Point, Operation, True); exception when E : Inv_Policy => declare Members : System_Exception_Members; begin Get_Members (E, Members); if Members.Minor = OMGVMCID + 3 then Output (Point, Operation, True, " (INV_POLICY)"); else Output (Point, Operation, False); end if; end; when others => Output (Point, Operation, False); end Test_Get_Server_Policy; -------------------- -- Test_Object_Id -- -------------------- procedure Test_Object_Id (Point : Server_Interception_Point; Info : PortableInterceptor.ServerRequestInfo.Local_Ref) is Operation : constant String := "object_id"; Valid : constant Boolean := Point /= Receive_Request_Service_Contexts; begin declare Aux : constant ObjectId := Get_Object_Id (Info); begin if not Valid then Output (Point, Operation, False); elsif Aux /= Test_ObjectId then Output (Point, Operation, False); else Output (Point, Operation, True); end if; end; exception when E : Bad_Inv_Order => declare Members : System_Exception_Members; begin Get_Members (E, Members); if not Valid and then Members.Minor = OMGVMCID + 14 then Output (Point, Operation, True); else Output (Point, Operation, False); end if; end; when E : No_Resources => declare Members : System_Exception_Members; begin Get_Members (E, Members); if Valid and then (Point = Send_Exception or else Point = Send_Other) and then Members.Minor = OMGVMCID + 1 then Output (Point, Operation, True, " (NO_RESOURCES)"); else Output (Point, Operation, False); end if; end; when others => Output (Point, Operation, False); end Test_Object_Id; ----------------- -- Test_ORB_Id -- ----------------- procedure Test_ORB_Id (Point : Server_Interception_Point; Info : PortableInterceptor.ServerRequestInfo.Local_Ref) is Operation : constant String := "orb_id"; Valid : constant Boolean := Point /= Receive_Request_Service_Contexts; Aux : ORBId; -- pragma Unreferenced (Aux); pragma Warnings (Off, Aux); -- WAG:5.02 DB08-008 -- Assigned but never read begin -- XXX Functionality test not implemented Aux := Get_ORB_Id (Info); Output (Point, Operation, False); exception when E : Bad_Inv_Order => declare Members : System_Exception_Members; begin Get_Members (E, Members); if not Valid and then Members.Minor = OMGVMCID + 14 then Output (Point, Operation, True); else Output (Point, Operation, False); end if; end; when others => Output (Point, Operation, False); end Test_ORB_Id; ---------------------------- -- Test_Sending_Exception -- ---------------------------- procedure Test_Sending_Exception (Point : Server_Interception_Point; Info : PortableInterceptor.ServerRequestInfo.Local_Ref) is Operation : constant String := "sending_exception"; Valid : constant Boolean := Point = Send_Exception; Exc : Any; begin Exc := Get_Sending_Exception (Info); if not Valid then Output (Point, Operation, False); elsif Get_Type (Exc) /= TC_Test_Exception then Output (Point, Operation, False); else Output (Point, Operation, True); end if; exception when E : Bad_Inv_Order => declare Members : System_Exception_Members; begin Get_Members (E, Members); if not Valid and then Members.Minor = OMGVMCID + 14 then Output (Point, Operation, True); else Output (Point, Operation, False); end if; end; when others => Output (Point, Operation, False); end Test_Sending_Exception; -------------------- -- Test_Server_Id -- -------------------- procedure Test_Server_Id (Point : Server_Interception_Point; Info : PortableInterceptor.ServerRequestInfo.Local_Ref) is Operation : constant String := "server_id"; Valid : constant Boolean := Point /= Receive_Request_Service_Contexts; Aux : ServerId; -- pragma Unreferenced (Aux); pragma Warnings (Off, Aux); -- WAG:5.02 DB08-008 -- Assigned but never read begin -- XXX Functionality test not implemented Aux := Get_Server_Id (Info); Output (Point, Operation, False); exception when E : Bad_Inv_Order => declare Members : System_Exception_Members; begin Get_Members (E, Members); if not Valid and then Members.Minor = OMGVMCID + 14 then Output (Point, Operation, True); else Output (Point, Operation, False); end if; end; when others => Output (Point, Operation, False); end Test_Server_Id; ------------------- -- Test_Set_Slot -- ------------------- procedure Test_Set_Slot (Point : Server_Interception_Point; Info : PortableInterceptor.ServerRequestInfo.Local_Ref) is Operation : constant String := "set_slot"; begin Set_Slot (Info, 100, CORBA.Internals.Get_Empty_Any (TC_Null)); -- Operation must raise InvalidSlot exception because slot is not -- allocated. The slot allocation, Get_Slot/Set_Slot Requests and -- PICurrent operations tested in test002. Output (Point, Operation, False); exception when InvalidSlot => Output (Point, Operation, True); when others => Output (Point, Operation, False); end Test_Set_Slot; ---------------------- -- Test_Target_Is_A -- ---------------------- procedure Test_Target_Is_A (Point : Server_Interception_Point; Info : PortableInterceptor.ServerRequestInfo.Local_Ref) is Operation : constant String := "target_is_a"; Valid : constant Boolean := Point = Receive_Request; Aux : Boolean; begin Aux := Target_Is_A (Info, To_CORBA_String (Test001_Interface.Repository_Id)); if not Valid then Output (Point, Operation, False); elsif not Aux then Output (Point, Operation, False); elsif Target_Is_A (Info, To_CORBA_String (Test001_Server_Interceptor.Repository_Id)) then Output (Point, Operation, False); else Output (Point, Operation, True); end if; exception when E : Bad_Inv_Order => declare Members : System_Exception_Members; begin Get_Members (E, Members); if not Valid and then Members.Minor = OMGVMCID + 14 then Output (Point, Operation, True); else Output (Point, Operation, False); end if; end; when others => Output (Point, Operation, False); end Test_Target_Is_A; ---------------------------------------- -- Test_Target_Most_Derived_Interface -- ---------------------------------------- procedure Test_Target_Most_Derived_Interface (Point : Server_Interception_Point; Info : PortableInterceptor.ServerRequestInfo.Local_Ref) is Operation : constant String := "target_most_derived_interface"; Valid : constant Boolean := Point = Receive_Request; Aux : RepositoryId; begin Aux := Get_Target_Most_Derived_Interface (Info); if not Valid then Output (Point, Operation, False); elsif Aux /= Test001_Interface.Repository_Id then Output (Point, Operation, False); else Output (Point, Operation, True); end if; exception when E : Bad_Inv_Order => declare Members : System_Exception_Members; begin Get_Members (E, Members); if not Valid and then Members.Minor = OMGVMCID + 14 then Output (Point, Operation, True); else Output (Point, Operation, False); end if; end; when others => Output (Point, Operation, False); end Test_Target_Most_Derived_Interface; end Test001_Server_Request_Info_Tests; ././@LongLink0000000000000000000000000000015200000000000011563 Lustar rootrootpolyorb-2.8~20110207.orig/testsuite/corba/portableinterceptor/test001/test001_server_interceptor-impl.adspolyorb-2.8~20110207.orig/testsuite/corba/portableinterceptor/test001/test001_server_interceptor-imp0000644000175000017500000000636511750740340032734 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- T E S T 0 0 1 _ S E R V E R _ I N T E R C E P T O R . I M P L -- -- -- -- S p e c -- -- -- -- Copyright (C) 2004-2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with PortableInterceptor.ServerRequestInfo; with PortableInterceptor.ServerRequestInterceptor.Impl; package Test001_Server_Interceptor.Impl is type Object is new PortableInterceptor.ServerRequestInterceptor.Impl.Object with private; type Object_Ptr is access all Object'Class; private type Object is new PortableInterceptor.ServerRequestInterceptor.Impl.Object with null record; function Is_A (Self : not null access Object; Logical_Type_Id : Standard.String) return Boolean; -- Derived from PortableInterceptor::ServerRequestInterceptor procedure Receive_Request_Service_Contexts (Self : access Object; RI : PortableInterceptor.ServerRequestInfo.Local_Ref); procedure Receive_Request (Self : access Object; RI : PortableInterceptor.ServerRequestInfo.Local_Ref); procedure Send_Reply (Self : access Object; RI : PortableInterceptor.ServerRequestInfo.Local_Ref); procedure Send_Exception (Self : access Object; RI : PortableInterceptor.ServerRequestInfo.Local_Ref); procedure Send_Other (Self : access Object; RI : PortableInterceptor.ServerRequestInfo.Local_Ref); end Test001_Server_Interceptor.Impl; polyorb-2.8~20110207.orig/testsuite/corba/portableinterceptor/test001/test001_request_info_tests.ads0000644000175000017500000001030211750740340032702 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- T E S T 0 0 1 _ R E Q U E S T _ I N F O _ T E S T S -- -- -- -- S p e c -- -- -- -- Copyright (C) 2004-2008, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with PortableInterceptor.RequestInfo; with Test001_Globals; package Test001_Request_Info_Tests is procedure Test_Request_Id (Point : Test001_Globals.Interception_Point; Info : PortableInterceptor.RequestInfo.Local_Ref'Class; Suppress : Boolean := False); procedure Test_Operation (Point : Test001_Globals.Interception_Point; Info : PortableInterceptor.RequestInfo.Local_Ref'Class); procedure Test_Arguments (Point : Test001_Globals.Interception_Point; Info : PortableInterceptor.RequestInfo.Local_Ref'Class); procedure Test_Exceptions (Point : Test001_Globals.Interception_Point; Info : PortableInterceptor.RequestInfo.Local_Ref'Class); procedure Test_Contexts (Point : Test001_Globals.Interception_Point; Info : PortableInterceptor.RequestInfo.Local_Ref'Class); procedure Test_Operation_Context (Point : Test001_Globals.Interception_Point; Info : PortableInterceptor.RequestInfo.Local_Ref'Class); procedure Test_Result (Point : Test001_Globals.Interception_Point; Info : PortableInterceptor.RequestInfo.Local_Ref'Class); procedure Test_Response_Expected (Point : Test001_Globals.Interception_Point; Info : PortableInterceptor.RequestInfo.Local_Ref'Class); procedure Test_Sync_Scope (Point : Test001_Globals.Interception_Point; Info : PortableInterceptor.RequestInfo.Local_Ref'Class); procedure Test_Reply_Status (Point : Test001_Globals.Interception_Point; Info : PortableInterceptor.RequestInfo.Local_Ref'Class); procedure Test_Forward_Reference (Point : Test001_Globals.Interception_Point; Info : PortableInterceptor.RequestInfo.Local_Ref'Class); procedure Test_Get_Slot (Point : Test001_Globals.Interception_Point; Info : PortableInterceptor.RequestInfo.Local_Ref'Class); procedure Test_Get_Request_Service_Context (Point : Test001_Globals.Interception_Point; Info : PortableInterceptor.RequestInfo.Local_Ref'Class); procedure Test_Get_Reply_Service_Context (Point : Test001_Globals.Interception_Point; Info : PortableInterceptor.RequestInfo.Local_Ref'Class); end Test001_Request_Info_Tests; ././@LongLink0000000000000000000000000000015200000000000011563 Lustar rootrootpolyorb-2.8~20110207.orig/testsuite/corba/portableinterceptor/test001/test001_client_interceptor-impl.adspolyorb-2.8~20110207.orig/testsuite/corba/portableinterceptor/test001/test001_client_interceptor-imp0000644000175000017500000000631711750740340032701 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- T E S T 0 0 1 _ C L I E N T _ I N T E R C E P T O R . I M P L -- -- -- -- S p e c -- -- -- -- Copyright (C) 2004-2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with PortableInterceptor.ClientRequestInfo; with PortableInterceptor.ClientRequestInterceptor.Impl; package Test001_Client_Interceptor.Impl is type Object is new PortableInterceptor.ClientRequestInterceptor.Impl.Object with private; type Object_Ptr is access all Object'Class; private type Object is new PortableInterceptor.ClientRequestInterceptor.Impl.Object with null record; function Is_A (Self : not null access Object; Logical_Type_Id : Standard.String) return Boolean; -- Derived from ClientRequestInterceptor procedure Send_Request (Self : access Object; RI : PortableInterceptor.ClientRequestInfo.Local_Ref); procedure Send_Poll (Self : access Object; RI : PortableInterceptor.ClientRequestInfo.Local_Ref); procedure Receive_Reply (Self : access Object; RI : PortableInterceptor.ClientRequestInfo.Local_Ref); procedure Receive_Exception (Self : access Object; RI : PortableInterceptor.ClientRequestInfo.Local_Ref); procedure Receive_Other (Self : access Object; RI : PortableInterceptor.ClientRequestInfo.Local_Ref); end Test001_Client_Interceptor.Impl; polyorb-2.8~20110207.orig/testsuite/corba/portableinterceptor/test001/local.gpr0000644000175000017500000000066511750740340026623 0ustar xavierxavierwith "polyorb", "polyorb_test_common"; project local is Dir := external ("Test_Dir"); Obj_Dir := PolyORB_Test_Common.Build_Dir & Dir; for Object_Dir use Obj_Dir; for Source_Dirs use (Obj_Dir, PolyORB_Test_Common.Source_Dir & Dir); package Compiler is for Default_Switches ("Ada") use PolyORB_Test_Common.Compiler'Default_Switches ("Ada"); end Compiler; for Main use ("test001.adb"); end local; polyorb-2.8~20110207.orig/testsuite/corba/portableinterceptor/test001/test001_request_info_tests.adb0000644000175000017500000005507311750740340032677 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- T E S T 0 0 1 _ R E Q U E S T _ I N F O _ T E S T S -- -- -- -- B o d y -- -- -- -- Copyright (C) 2004-2008, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with CORBA.Object; with CORBA.Repository_Root; with Dynamic; with IOP; with Messaging; with Test001_Interface.Helper; package body Test001_Request_Info_Tests is use CORBA; use CORBA.Repository_Root; use CORBA.TypeCode; use Dynamic; use IOP; use Messaging; use PortableInterceptor; use PortableInterceptor.RequestInfo; use Test001_Globals; use Test001_Interface.Helper; -------------------- -- Test_Arguments -- -------------------- procedure Test_Arguments (Point : Interception_Point; Info : PortableInterceptor.RequestInfo.Local_Ref'Class) is Operation : constant String := "arguments"; Valid : constant Boolean := Point = Send_Request or else Point = Receive_Reply or else Point = Receive_Request or else Point = Send_Reply; Args : ParameterList; begin Args := Get_Arguments (Info); if not Valid then Output (Point, Operation, False); elsif Length (Args) /= 1 then Output (Point, Operation, False); elsif Get_Type (Get_Element (Args, 1).Argument) /= TC_Long then Output (Point, Operation, False); elsif From_Any (Get_Element (Args, 1).Argument) /= Long'(10) then Output (Point, Operation, False); elsif Get_Element (Args, 1).Mode /= PARAM_IN then Output (Point, Operation, False); else Output (Point, Operation, True); end if; exception when E : No_Resources => declare Members : System_Exception_Members; begin Get_Members (E, Members); if Valid and then Members.Minor = OMGVMCID + 1 then Output (Point, Operation, True, " (NO_RESOURCES)"); else Output (Point, Operation, False); end if; end; when E : Bad_Inv_Order => declare Members : System_Exception_Members; begin Get_Members (E, Members); if not Valid and then Members.Minor = OMGVMCID + 14 then Output (Point, Operation, True); else Output (Point, Operation, False); end if; end; when others => Output (Point, Operation, False); end Test_Arguments; ------------------- -- Test_Contexts -- ------------------- procedure Test_Contexts (Point : Interception_Point; Info : PortableInterceptor.RequestInfo.Local_Ref'Class) is Operation : constant String := "contexts"; Valid : constant Boolean := Point /= Send_Poll and then Point /= Receive_Request_Service_Contexts; Cont : ContextList; -- pragma Unreferenced (Cont); pragma Warnings (Off, Cont); -- WAG:5.02 DB08-008 -- Assigned but never read begin -- XXX Functionality test not implemented Cont := Get_Contexts (Info); if not Valid then Output (Point, Operation, False); else Output (Point, Operation, True); end if; exception when E : No_Resources => declare Members : System_Exception_Members; begin Get_Members (E, Members); if Valid and then Members.Minor = OMGVMCID + 1 then Output (Point, Operation, True, " (NO_RESOURCES)"); else Output (Point, Operation, False); end if; end; when E : Bad_Inv_Order => declare Members : System_Exception_Members; begin Get_Members (E, Members); if not Valid and then Members.Minor = OMGVMCID + 14 then Output (Point, Operation, True); else Output (Point, Operation, False); end if; end; when others => Output (Point, Operation, False); end Test_Contexts; --------------------- -- Test_Exceptions -- --------------------- procedure Test_Exceptions (Point : Interception_Point; Info : PortableInterceptor.RequestInfo.Local_Ref'Class) is Operation : constant String := "exceptions"; Valid : constant Boolean := Point /= Send_Poll and Point /= Receive_Request_Service_Contexts; Excs : ExceptionList; begin Excs := Get_Exceptions (Info); if not Valid then Output (Point, Operation, False); elsif Length (Excs) /= 1 then Output (Point, Operation, False); elsif Get_Element (Excs, 1) /= TC_Test_Exception then Output (Point, Operation, False); else Output (Point, Operation, True); end if; exception when E : No_Resources => declare Members : System_Exception_Members; begin Get_Members (E, Members); if Valid and then Members.Minor = OMGVMCID + 1 then Output (Point, Operation, True, " (NO_RESOURCES)"); else Output (Point, Operation, False); end if; end; when E : Bad_Inv_Order => declare Members : System_Exception_Members; begin Get_Members (E, Members); if not Valid and then Members.Minor = OMGVMCID + 14 then Output (Point, Operation, True); else Output (Point, Operation, False); end if; end; when others => Output (Point, Operation, False); end Test_Exceptions; ---------------------------- -- Test_Forward_Reference -- ---------------------------- procedure Test_Forward_Reference (Point : Interception_Point; Info : PortableInterceptor.RequestInfo.Local_Ref'Class) is Operation : constant String := "forward_reference"; Valid : constant Boolean := (Point = Receive_Other or else Point = Send_Other) and then Get_Reply_Status (Info) = Location_Forward; Obj : CORBA.Object.Ref; begin Obj := Get_Forward_Reference (Info); if Valid and then CORBA.Object.Is_Equivalent (Obj, Test_Forward_Object) then Output (Point, Operation, True); else Output (Point, Operation, False); end if; exception when E : Bad_Inv_Order => declare Members : System_Exception_Members; begin Get_Members (E, Members); if not Valid and then Members.Minor = OMGVMCID + 14 then Output (Point, Operation, True); else Output (Point, Operation, False); end if; end; when others => Output (Point, Operation, False); end Test_Forward_Reference; ------------------------------------ -- Test_Get_Reply_Service_Context -- ------------------------------------ procedure Test_Get_Reply_Service_Context (Point : Interception_Point; Info : PortableInterceptor.RequestInfo.Local_Ref'Class) is Operation : constant String := "get_reply_service_context"; Valid : constant Boolean := Point /= Send_Request and then Point /= Send_Poll and then Point /= Receive_Request_Service_Contexts and then Point /= Receive_Request; Context : IOP.ServiceContext; begin begin Context := Get_Reply_Service_Context (Info, 123456); Output (Point, Operation, False); return; exception when E : Bad_Inv_Order => declare Members : System_Exception_Members; begin Get_Members (E, Members); if Valid or else Members.Minor /= OMGVMCID + 14 then Output (Point, Operation, False); return; end if; end; when E : Bad_Param => declare Members : System_Exception_Members; begin Get_Members (E, Members); if not Valid or else Members.Minor /= OMGVMCID + 26 then Output (Point, Operation, False); return; end if; end; when others => Output (Point, Operation, False); return; end; if Point = Receive_Reply or else Point = Receive_Exception or else Point = Receive_Other then begin Context := Get_Reply_Service_Context (Info, Test_Reply_Context.Context_Id); if Context /= Test_Reply_Context then Output (Point, Operation, False); return; end if; exception when others => Output (Point, Operation, False); return; end; end if; Output (Point, Operation, True); end Test_Get_Reply_Service_Context; -------------------------------------- -- Test_Get_Request_Service_Context -- -------------------------------------- procedure Test_Get_Request_Service_Context (Point : Interception_Point; Info : PortableInterceptor.RequestInfo.Local_Ref'Class) is Operation : constant String := "get_request_service_context"; Valid : constant Boolean := Point /= Send_Poll; Context : IOP.ServiceContext; begin begin Context := Get_Request_Service_Context (Info, 123456); Output (Point, Operation, False); return; exception when E : Bad_Inv_Order => declare Members : System_Exception_Members; begin Get_Members (E, Members); if Valid or else Members.Minor /= OMGVMCID + 14 then Output (Point, Operation, False); return; end if; end; when E : Bad_Param => declare Members : System_Exception_Members; begin Get_Members (E, Members); if not Valid or else Members.Minor /= OMGVMCID + 26 then Output (Point, Operation, False); return; end if; end; when others => Output (Point, Operation, False); return; end; if Point = Receive_Request_Service_Contexts or else Point = Receive_Request then begin Context := Get_Request_Service_Context (Info, Test_Request_Context.Context_Id); if Context /= Test_Request_Context then Output (Point, Operation, False); return; end if; exception when others => Output (Point, Operation, False); return; end; end if; Output (Point, Operation, True); end Test_Get_Request_Service_Context; ------------------- -- Test_Get_Slot -- ------------------- procedure Test_Get_Slot (Point : Interception_Point; Info : PortableInterceptor.RequestInfo.Local_Ref'Class) is Operation : constant String := "get_slot"; Val : Any; -- pragma Unreferenced (Val); pragma Warnings (Off, Val); -- WAG:5.02 DB08-008 -- Assigned but never read begin Val := Get_Slot (Info, 100); -- Operation must raise InvalidSlot exception because slot is not -- allocated. The slot allocation, Get_Slot/Set_Slot Requests and -- PICurrent operations tested in test002. Output (Point, Operation, False); exception when InvalidSlot => Output (Point, Operation, True); when others => Output (Point, Operation, False); end Test_Get_Slot; -------------------- -- Test_Operation -- -------------------- procedure Test_Operation (Point : Interception_Point; Info : PortableInterceptor.RequestInfo.Local_Ref'Class) is Operation : constant String := "operation"; begin if Get_Operation (Info) = "Func" then Output (Point, Operation, True); else Output (Point, Operation, False); end if; exception when others => Output (Point, Operation, False); end Test_Operation; ---------------------------- -- Test_Operation_Context -- ---------------------------- procedure Test_Operation_Context (Point : Interception_Point; Info : PortableInterceptor.RequestInfo.Local_Ref'Class) is Operation : constant String := "operation_context"; Valid : constant Boolean := Point /= Send_Poll and then (Point = Receive_Request or Point = Send_Reply); Cont : RequestContext; -- pragma Unreferenced (Cont); pragma Warnings (Off, Cont); -- WAG:5.02 DB08-008 -- Assigned but never read begin -- XXX Functionality test not implemented Cont := Get_Operation_Context (Info); if not Valid then Output (Point, Operation, False); else Output (Point, Operation, True); end if; exception when E : No_Resources => declare Members : System_Exception_Members; begin Get_Members (E, Members); if Valid and then Members.Minor = OMGVMCID + 1 then Output (Point, Operation, True, " (NO_RESOURCES)"); else Output (Point, Operation, False); end if; end; when E : Bad_Inv_Order => declare Members : System_Exception_Members; begin Get_Members (E, Members); if not Valid and then Members.Minor = OMGVMCID + 14 then Output (Point, Operation, True); else Output (Point, Operation, False); end if; end; when others => Output (Point, Operation, False); end Test_Operation_Context; --------------------- -- Test_Request_Id -- --------------------- procedure Test_Request_Id (Point : Interception_Point; Info : PortableInterceptor.RequestInfo.Local_Ref'Class; Suppress : Boolean := False) is Operation : constant String := "request_id"; Aux : CORBA.Unsigned_Long; begin Aux := Get_Request_Id (Info); if Point in Client_Interception_Point then if Point = Send_Request then Test_Client_Request_Id := Aux; if not Suppress then Output (Point, Operation, True); end if; else Output (Point, Operation, Test_Client_Request_Id = Aux); end if; else -- Point in Server_Interception_Point if Point = Receive_Request_Service_Contexts then Test_Server_Request_Id := Aux; if not Suppress then Output (Point, Operation, True); end if; else Output (Point, Operation, Test_Server_Request_Id = Aux); end if; end if; exception when others => Output (Point, Operation, False); end Test_Request_Id; ----------------------- -- Test_Reply_Status -- ----------------------- procedure Test_Reply_Status (Point : Interception_Point; Info : PortableInterceptor.RequestInfo.Local_Ref'Class) is Operation : constant String := "reply_status"; Valid : constant Boolean := Point /= Send_Request and then Point /= Send_Poll and then Point /= Receive_Request_Service_Contexts and then Point /= Receive_Request; Stat : ReplyStatus; begin -- XXX This is only return value validity test Stat := Get_Reply_Status (Info); if not Valid then Output (Point, Operation, False); elsif Point = Receive_Reply and then Stat /= Successful then Output (Point, Operation, False); elsif Point = Receive_Exception and then (Stat /= PortableInterceptor.System_Exception and then Stat /= PortableInterceptor.User_Exception) then Output (Point, Operation, False); elsif Point = Receive_Other and then (Stat /= Successful and then Stat /= Location_Forward and then Stat /= Transport_Retry and then Stat /= PortableInterceptor.Unknown) then Output (Point, Operation, False); elsif Point = Send_Reply and then Stat /= Successful then Output (Point, Operation, False); elsif Point = Send_Exception and then (Stat /= PortableInterceptor.System_Exception and then Stat /= PortableInterceptor.User_Exception) then Output (Point, Operation, False); elsif Point = Send_Other and then (Stat /= Successful and then Stat /= Location_Forward and then Stat /= PortableInterceptor.Unknown) then Output (Point, Operation, False); else Output (Point, Operation, True); end if; exception when E : Bad_Inv_Order => declare Members : System_Exception_Members; begin Get_Members (E, Members); if not Valid and then Members.Minor = OMGVMCID + 14 then Output (Point, Operation, True); else Output (Point, Operation, False); end if; end; when others => Output (Point, Operation, False); end Test_Reply_Status; ----------------- -- Test_Result -- ----------------- procedure Test_Result (Point : Interception_Point; Info : PortableInterceptor.RequestInfo.Local_Ref'Class) is Operation : constant String := "result"; Valid : constant Boolean := Point = Receive_Reply or Point = Send_Reply; Res : Any; begin Res := Get_Result (Info); if not Valid then Output (Point, Operation, False); elsif Get_Type (Res) /= TC_Long then Output (Point, Operation, False); elsif From_Any (Res) /= Long'(12) then Output (Point, Operation, False); else Output (Point, Operation, True); end if; exception when E : No_Resources => declare Members : System_Exception_Members; begin Get_Members (E, Members); if Valid and then Members.Minor = OMGVMCID + 1 then Output (Point, Operation, True, " (NO_RESOURCES)"); else Output (Point, Operation, False); end if; end; when E : Bad_Inv_Order => declare Members : System_Exception_Members; begin Get_Members (E, Members); if not Valid and then Members.Minor = OMGVMCID + 14 then Output (Point, Operation, True); else Output (Point, Operation, False); end if; end; when others => Output (Point, Operation, False); end Test_Result; ---------------------------- -- Test_Response_Expected -- ---------------------------- procedure Test_Response_Expected (Point : Interception_Point; Info : PortableInterceptor.RequestInfo.Local_Ref'Class) is Operation : constant String := "response_expected"; begin -- The operation is not oneway: a response is always expected if Get_Response_Expected (Info) then Output (Point, Operation, True); else Output (Point, Operation, False); end if; exception when others => Output (Point, Operation, False); end Test_Response_Expected; --------------------- -- Test_Sync_Scope -- --------------------- procedure Test_Sync_Scope (Point : Interception_Point; Info : PortableInterceptor.RequestInfo.Local_Ref'Class) is Operation : constant String := "sync_scope"; Valid : constant Boolean := Point /= Send_Poll; Aux : SyncScope; begin Aux := Get_Sync_Scope (Info); -- We test only non oneway operation, thus Sync_Scope always -- will be Sync_With_Target if Valid and then Aux = Sync_With_Target then Output (Point, Operation, True); else Output (Point, Operation, False); end if; exception when E : Bad_Inv_Order => declare Members : System_Exception_Members; begin Get_Members (E, Members); if not Valid and then Members.Minor = OMGVMCID + 14 then Output (Point, Operation, True); else Output (Point, Operation, False); end if; end; when others => Output (Point, Operation, False); end Test_Sync_Scope; end Test001_Request_Info_Tests; ././@LongLink0000000000000000000000000000014700000000000011567 Lustar rootrootpolyorb-2.8~20110207.orig/testsuite/corba/portableinterceptor/test001/test001_orb_initializer-impl.adspolyorb-2.8~20110207.orig/testsuite/corba/portableinterceptor/test001/test001_orb_initializer-impl.a0000644000175000017500000000520011750740340032553 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- T E S T 0 0 1 _ O R B _ I N I T I A L I Z E R . I M P L -- -- -- -- S p e c -- -- -- -- Copyright (C) 2004-2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with PortableInterceptor.ORBInitializer.Impl; with PortableInterceptor.ORBInitInfo; package Test001_ORB_Initializer.Impl is type Object is new PortableInterceptor.ORBInitializer.Impl.Object with private; type Object_Ptr is access all Object'Class; function Is_A (Self : not null access Object; Logical_Type_Id : Standard.String) return Boolean; private type Object is new PortableInterceptor.ORBInitializer.Impl.Object with null record; procedure Post_Init (Self : access Object; Info : PortableInterceptor.ORBInitInfo.Local_Ref); end Test001_ORB_Initializer.Impl; ././@LongLink0000000000000000000000000000015400000000000011565 Lustar rootrootpolyorb-2.8~20110207.orig/testsuite/corba/portableinterceptor/test001/test001_server_request_info_tests.adspolyorb-2.8~20110207.orig/testsuite/corba/portableinterceptor/test001/test001_server_request_info_te0000644000175000017500000000753611750740340033007 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- T E S T 0 0 1 _ S E R V E R _ R E Q U E S T _ I N F O _ T E S T S -- -- -- -- S p e c -- -- -- -- Copyright (C) 2004-2008, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by ACT Europe. -- -- (email: sales@act-europe.fr) -- -- -- ------------------------------------------------------------------------------ with PortableInterceptor.ServerRequestInfo; with Test001_Globals; package Test001_Server_Request_Info_Tests is procedure Test_Sending_Exception (Point : Test001_Globals.Server_Interception_Point; Info : PortableInterceptor.ServerRequestInfo.Local_Ref); procedure Test_Object_Id (Point : Test001_Globals.Server_Interception_Point; Info : PortableInterceptor.ServerRequestInfo.Local_Ref); procedure Test_Adapter_Id (Point : Test001_Globals.Server_Interception_Point; Info : PortableInterceptor.ServerRequestInfo.Local_Ref); procedure Test_Server_Id (Point : Test001_Globals.Server_Interception_Point; Info : PortableInterceptor.ServerRequestInfo.Local_Ref); procedure Test_ORB_Id (Point : Test001_Globals.Server_Interception_Point; Info : PortableInterceptor.ServerRequestInfo.Local_Ref); procedure Test_Adapter_Name (Point : Test001_Globals.Server_Interception_Point; Info : PortableInterceptor.ServerRequestInfo.Local_Ref); procedure Test_Target_Most_Derived_Interface (Point : Test001_Globals.Server_Interception_Point; Info : PortableInterceptor.ServerRequestInfo.Local_Ref); procedure Test_Get_Server_Policy (Point : Test001_Globals.Server_Interception_Point; Info : PortableInterceptor.ServerRequestInfo.Local_Ref); procedure Test_Set_Slot (Point : Test001_Globals.Server_Interception_Point; Info : PortableInterceptor.ServerRequestInfo.Local_Ref); procedure Test_Target_Is_A (Point : Test001_Globals.Server_Interception_Point; Info : PortableInterceptor.ServerRequestInfo.Local_Ref); procedure Test_Add_Reply_Service_Context (Point : Test001_Globals.Server_Interception_Point; Info : PortableInterceptor.ServerRequestInfo.Local_Ref); end Test001_Server_Request_Info_Tests; polyorb-2.8~20110207.orig/testsuite/corba/portableinterceptor/test001/test001_interface-impl.adb0000644000175000017500000000503111750740340031636 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- T E S T 0 0 1 _ I N T E R F A C E . I M P L -- -- -- -- B o d y -- -- -- -- Copyright (C) 2004-2008, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with Test001_Globals; with Test001_Interface.Skel; pragma Warnings (Off, Test001_Interface.Skel); package body Test001_Interface.Impl is use type CORBA.Long; ---------- -- Func -- ---------- function Func (Self : access Object; Value : CORBA.Long) return CORBA.Long is pragma Unreferenced (Self); begin if Test001_Globals.Raise_Test_Exception then raise Test_Exception; else return Value + 2; end if; end Func; end Test001_Interface.Impl; polyorb-2.8~20110207.orig/testsuite/corba/portableserver/0000755000175000017500000000000011750740340022560 5ustar xavierxavierpolyorb-2.8~20110207.orig/testsuite/corba/portableserver/echo-impl.ads0000644000175000017500000000525411750740340025134 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- E C H O . I M P L -- -- -- -- S p e c -- -- -- -- Copyright (C) 2003-2008, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by ACT Europe. -- -- (email: sales@act-europe.fr) -- -- -- ------------------------------------------------------------------------------ with CORBA; with PortableServer; package Echo.Impl is -- My own implementation of echo object. -- This is simply used to define the operations. type Object is new PortableServer.Servant_Base with record Msg : CORBA.String; end record; type Object_Acc is access Object; function EchoString (Self : access Object; Mesg : CORBA.String) return CORBA.String; function EchoString_Reentrant (Self : access Object; Mesg : CORBA.String) return CORBA.String; function EchoString_Wait (Self : access Object; Mesg : CORBA.String) return CORBA.String; end Echo.Impl; polyorb-2.8~20110207.orig/testsuite/corba/portableserver/echo.idl0000644000175000017500000000051611750740340024172 0ustar xavierxavier import ::PortableServer; interface Echo { string echoString (in string Mesg); string echoString_reentrant (in string Mesg); string echoString_wait (in string Mesg); }; local interface Test_NullActivator : PortableServer::ServantActivator { }; local interface Test_SimpleActivator : PortableServer::ServantActivator { }; polyorb-2.8~20110207.orig/testsuite/corba/portableserver/test_simpleactivator-impl.adb0000644000175000017500000001046411750740340030441 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- T E S T _ S I M P L E A C T I V A T O R . I M P L -- -- -- -- B o d y -- -- -- -- Copyright (C) 2005-2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with CORBA.Impl; with PortableServer.POA; with PortableServer.ServantManager; with Echo.Impl; with Test_ServantActivator; package body Test_SimpleActivator.Impl is ----------------- -- Etherealize -- ----------------- procedure Etherealize (Self : access Object; Oid : PortableServer.ObjectId; Adapter : PortableServer.POA_Forward.Ref; Serv : PortableServer.Servant; Cleanup_In_Progress : CORBA.Boolean; Remaining_Activations : CORBA.Boolean) is pragma Unreferenced (Self, Oid, Adapter, Serv); pragma Unreferenced (Cleanup_In_Progress, Remaining_Activations); begin Test_ServantActivator.Simple_Activator_Etherealize_Called := True; end Etherealize; --------------- -- Incarnate -- --------------- function Incarnate (Self : access Object; Oid : PortableServer.ObjectId; Adapter : PortableServer.POA_Forward.Ref) return PortableServer.Servant is pragma Unreferenced (Self); Obj : constant CORBA.Impl.Object_Ptr := new Echo.Impl.Object; package Convert is new PortableServer.POA_Forward.Convert (PortableServer.POA.Local_Ref); POA : constant PortableServer.POA.Local_Ref := Convert.To_Ref (Adapter); begin Test_ServantActivator.Simple_Activator_Incarnate_Called := True; PortableServer.POA.Activate_Object_With_Id (POA, Oid, PortableServer.Servant (Obj)); return PortableServer.Servant (Obj); end Incarnate; ---------- -- Is_A -- ---------- function Is_A (Self : not null access Object; Logical_Type_Id : Standard.String) return Boolean is pragma Unreferenced (Self); begin return CORBA.Is_Equivalent (Logical_Type_Id, Test_SimpleActivator.Repository_Id) or else CORBA.Is_Equivalent (Logical_Type_Id, PortableServer.ServantActivator.Repository_Id) or else CORBA.Is_Equivalent (Logical_Type_Id, PortableServer.ServantManager.Repository_Id) or else CORBA.Is_Equivalent (Logical_Type_Id, "IDL:omg.org/CORBA/Object:1.0"); end Is_A; end Test_SimpleActivator.Impl; polyorb-2.8~20110207.orig/testsuite/corba/portableserver/Makefile.local0000644000175000017500000000026411750740340025313 0ustar xavierxavier${current_dir}echo.idl-stamp: idlac_flags := ${test_target}: ${current_dir}echo.idl-stamp ${current_dir}test.idl-stamp: idlac_flags := ${test_target}: ${current_dir}test.idl-stamp polyorb-2.8~20110207.orig/testsuite/corba/portableserver/test_simpleactivator-impl.ads0000644000175000017500000000611411750740340030457 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- T E S T _ S I M P L E A C T I V A T O R . I M P L -- -- -- -- S p e c -- -- -- -- Copyright (C) 2005-2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- Simple activator that creates a servant on demand with CORBA; with PortableServer.ServantActivator.Impl; package Test_SimpleActivator.Impl is type Object is new PortableServer.ServantActivator.Impl.Object with private; type Object_Ptr is access all Object'Class; private type Object is new PortableServer.ServantActivator.Impl.Object with null record; function Is_A (Self : not null access Object; Logical_Type_Id : Standard.String) return Boolean; function Incarnate (Self : access Object; Oid : PortableServer.ObjectId; Adapter : PortableServer.POA_Forward.Ref) return PortableServer.Servant; procedure Etherealize (Self : access Object; Oid : PortableServer.ObjectId; Adapter : PortableServer.POA_Forward.Ref; Serv : PortableServer.Servant; Cleanup_In_Progress : CORBA.Boolean; Remaining_Activations : CORBA.Boolean); end Test_SimpleActivator.Impl; polyorb-2.8~20110207.orig/testsuite/corba/portableserver/test_servantactivator.adb0000644000175000017500000002203311750740340027666 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- T E S T _ S E R V A N T A C T I V A T O R -- -- -- -- B o d y -- -- -- -- Copyright (C) 2003-2007, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with CORBA.ORB; with CORBA.Policy; with PortableServer.POA.Helper; with PolyORB.Smart_Pointers; with PolyORB.Utils.Report; with Echo.Helper; with Test_NullActivator.Impl; with Test_SimpleActivator.Impl; package body Test_ServantActivator is use CORBA; use PolyORB.Utils.Report; ------------------------------- -- Run_Test_ServantActivator -- ------------------------------- procedure Run_Test_ServantActivator is use CORBA.Policy.IDL_SEQUENCE_Policy; use PortableServer.POA; Null_Activator_Obj : constant Test_NullActivator.Impl.Object_Ptr := new Test_NullActivator.Impl.Object; Null_Activator : Test_NullActivator.Local_Ref; Simple_Activator_Obj : constant Test_SimpleActivator.Impl.Object_Ptr := new Test_SimpleActivator.Impl.Object; Simple_Activator : Test_SimpleActivator.Local_Ref; Root_POA : constant PortableServer.POA.Local_Ref := PortableServer.POA.Helper.To_Local_Ref (CORBA.ORB.Resolve_Initial_References (CORBA.ORB.To_CORBA_String ("RootPOA"))); Policies : CORBA.Policy.PolicyList; Implicit_Activation_Policy : constant CORBA.Policy.Ref := CORBA.Policy.Ref (Create_Implicit_Activation_Policy (PortableServer.NO_IMPLICIT_ACTIVATION)); Id_Assignment_Policy : constant CORBA.Policy.Ref := CORBA.Policy.Ref (Create_Id_Assignment_Policy (PortableServer.USER_ID)); Request_Processing_Policy : constant CORBA.Policy.Ref := CORBA.Policy.Ref (Create_Request_Processing_Policy (PortableServer.USE_SERVANT_MANAGER)); Child_POA : PortableServer.POA.Local_Ref; Child_POA2 : PortableServer.POA.Local_Ref; begin New_Test ("Servant Activator"); -- Create POA policies list Append (Policies, Implicit_Activation_Policy); Append (Policies, Id_Assignment_Policy); Append (Policies, Request_Processing_Policy); -- Register a Child POA Child_POA := PortableServer.POA.Local_Ref (PortableServer.POA.Create_POA (Root_POA, CORBA.To_CORBA_String ("Child_POA"), PortableServer.POA.Get_The_POAManager (Root_POA), Policies)); Output ("Created child POA", True); -- Look for a non existent servant whitout ServantActivator; declare Obj_Ref : constant Echo.Ref := Echo.Helper.To_Ref (Create_Reference_With_Id (Child_POA, PortableServer.String_To_ObjectId ("dead"), To_CORBA_String (Echo.Repository_Id))); Result : CORBA.String; pragma Unreferenced (Result); -- To kill "variable "Result" is assigned but never read" warning begin pragma Warnings (Off); -- WAG:GCC3.4.3 Result := Echo.echoString (Obj_Ref, To_CORBA_String ("Hello Ada World !")); pragma Warnings (On); -- WAG:GCC3.4.3 -- XXX This is to kill warning "pragma Unreferenced given -- for "Result"" Output ("Non existant object found !", False); exception when CORBA.Object_Not_Exist => Output ("Non existant object not found", True); end; -- Set Null Servant Activator Test_NullActivator.Set (Null_Activator, PolyORB.Smart_Pointers.Entity_Ptr (Null_Activator_Obj)); PortableServer.POA.Set_Servant_Manager (Child_POA, Null_Activator); -- Test Null Servant Activator Incarnate primitive is called declare Obj_Ref : constant Echo.Ref := Echo.Helper.To_Ref (Create_Reference_With_Id (Child_POA, PortableServer.String_To_ObjectId ("dead"), To_CORBA_String (Echo.Repository_Id))); Result : CORBA.String; pragma Unreferenced (Result); -- To kill "variable "Result" is assigned but never read" warning begin pragma Warnings (Off); -- WAG:GCC3.4.3 Result := Echo.echoString (Obj_Ref, To_CORBA_String ("Hello Ada World !")); pragma Warnings (On); -- WAG:GCC3.4.3 -- XXX This is to kill warning "pragma Unreferenced given -- for "Result"" exception when CORBA.Object_Not_Exist => Output ("Null Activator called", Null_Activator_Incarnate_Called); end; -- Register a second Child POA Child_POA2 := PortableServer.POA.Local_Ref (PortableServer.POA.Create_POA (Root_POA, CORBA.To_CORBA_String ("Child_POA2"), PortableServer.POA.Get_The_POAManager (Root_POA), Policies)); Output ("Created child POA", True); -- Look for a non existent servant whitout ServantActivator; declare Obj_Ref : constant Echo.Ref := Echo.Helper.To_Ref (Create_Reference_With_Id (Child_POA2, PortableServer.String_To_ObjectId ("dead"), To_CORBA_String (Echo.Repository_Id))); Result : CORBA.String; pragma Unreferenced (Result); -- To kill "variable "Result" is assigned but never read" warning begin pragma Warnings (Off); -- WAG:GCC3.4.3 Result := Echo.echoString (Obj_Ref, To_CORBA_String ("Hello Ada World !")); pragma Warnings (On); -- WAG:GCC3.4.3 -- XXX This is to kill warning "pragma Unreferenced given -- for "Result"" Output ("Non existant object found !", False); exception when CORBA.Object_Not_Exist => Output ("Non existant object not found", True); end; -- Set Simple Servant Activator Test_SimpleActivator.Set (Simple_Activator, PolyORB.Smart_Pointers.Entity_Ptr (Simple_Activator_Obj)); PortableServer.POA.Set_Servant_Manager (Child_POA2, Simple_Activator); -- Test Simple Servant Activator Incarnate primitive is called declare Obj_Ref : constant Echo.Ref := Echo.Helper.To_Ref (Create_Reference_With_Id (Child_POA2, PortableServer.String_To_ObjectId ("dead"), To_CORBA_String (Echo.Repository_Id))); Result : CORBA.String; pragma Unreferenced (Result); -- To kill "variable "Result" is assigned but never read" warning begin pragma Warnings (Off); -- WAG:GCC3.4.3 Result := Echo.echoString (Obj_Ref, To_CORBA_String ("Hello Ada World !")); pragma Warnings (On); -- WAG:GCC3.4.3 -- XXX This is to kill warning "pragma Unreferenced given -- for "Result"" Output ("Simple Activator called", Simple_Activator_Incarnate_Called); Deactivate_Object (Child_POA2, Reference_To_Id (Child_POA2, Obj_Ref)); Output ("Etherealize called", Simple_Activator_Etherealize_Called); exception when CORBA.Object_Not_Exist => Output ("No servant created !", False); end; end Run_Test_ServantActivator; end Test_ServantActivator; polyorb-2.8~20110207.orig/testsuite/corba/portableserver/test-impl.ads0000644000175000017500000000445411750740340025176 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- T E S T . I M P L -- -- -- -- S p e c -- -- -- -- Copyright (C) 2005 Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with PortableServer; package Test.Impl is type Object is new PortableServer.Servant_Base with private; type Object_Ptr is access all Object'Class; procedure Proc (Self : access Object); private type Object is new PortableServer.Servant_Base with null record; end Test.Impl; polyorb-2.8~20110207.orig/testsuite/corba/portableserver/test_nullactivator-impl.ads0000644000175000017500000000526611750740340030147 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- T E S T _ N U L L A C T I V A T O R . I M P L -- -- -- -- S p e c -- -- -- -- Copyright (C) 2005-2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- Activator that does nothing with PortableServer.ServantActivator.Impl; package Test_NullActivator.Impl is type Object is new PortableServer.ServantActivator.Impl.Object with private; type Object_Ptr is access all Object'Class; private type Object is new PortableServer.ServantActivator.Impl.Object with null record; function Is_A (Self : not null access Object; Logical_Type_Id : Standard.String) return Boolean; function Incarnate (Self : access Object; Oid : PortableServer.ObjectId; Adapter : PortableServer.POA_Forward.Ref) return PortableServer.Servant; end Test_NullActivator.Impl; polyorb-2.8~20110207.orig/testsuite/corba/portableserver/test_adapteractivator.ads0000644000175000017500000000554611750740340027657 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- T E S T _ A D A P T E R A C T I V A T O R -- -- -- -- S p e c -- -- -- -- Copyright (C) 2003 Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by ACT Europe. -- -- (email: sales@act-europe.fr) -- -- -- ------------------------------------------------------------------------------ with CORBA; with PortableServer.AdapterActivator; package Test_AdapterActivator is -- Adapter that does nothing type NullAdapter_Ref is new PortableServer.AdapterActivator.Ref with null record; type NullAdapter_Access is access all NullAdapter_Ref; function Unknown_Adapter (Self : NullAdapter_Ref; Parent : PortableServer.POA_Forward.Ref; Name : CORBA.String) return Boolean; -- Simple adapter that creates a POA on demand type SimpleAdapter_Ref is new PortableServer.AdapterActivator.Ref with null record; type SimpleAdapter_Access is access all SimpleAdapter_Ref; function Unknown_Adapter (Self : SimpleAdapter_Ref; Parent : PortableServer.POA_Forward.Ref; Name : CORBA.String) return Boolean; procedure Run_Test_AdapterActivator; end Test_AdapterActivator; polyorb-2.8~20110207.orig/testsuite/corba/portableserver/test_mypoa.ads0000644000175000017500000000442411750740340025441 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- T E S T _ M Y P O A -- -- -- -- S p e c -- -- -- -- Copyright (C) 2003-2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with CORBA.Object; with PortableServer.POA; package Test_MyPOA is type My_POA_Ref is new PortableServer.POA.Local_Ref with null record; function To_Ref (Self : CORBA.Object.Ref'Class) return My_POA_Ref; procedure Run_Test_MyPOA; end Test_MyPOA; polyorb-2.8~20110207.orig/testsuite/corba/portableserver/echo-impl.adb0000644000175000017500000000627611750740340025120 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- E C H O . I M P L -- -- -- -- B o d y -- -- -- -- Copyright (C) 2003-2008, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by ACT Europe. -- -- (email: sales@act-europe.fr) -- -- -- ------------------------------------------------------------------------------ with CORBA.ORB; with Echo.Skel; pragma Warnings (Off, Echo.Skel); -- No entity from Echo.Skel is referenced. package body Echo.Impl is ---------------- -- EchoString -- ---------------- function EchoString (Self : access Object; Mesg : CORBA.String) return CORBA.String is pragma Warnings (Off); pragma Unreferenced (Self); pragma Warnings (On); begin return Mesg; end EchoString; --------------------- -- EchoString_Wait -- --------------------- function EchoString_Wait (Self : access Object; Mesg : CORBA.String) return CORBA.String is pragma Warnings (Off); pragma Unreferenced (Self); pragma Warnings (On); begin delay 3.0; return Mesg; end EchoString_Wait; -------------------------- -- EchoString_Reentrant -- -------------------------- function EchoString_Reentrant (Self : access Object; Mesg : CORBA.String) return CORBA.String is pragma Unreferenced (Self); Ref : Echo.Ref; begin CORBA.ORB.String_To_Object (Mesg, Ref); return Echo.echoString (Ref, Mesg); end EchoString_Reentrant; end Echo.Impl; polyorb-2.8~20110207.orig/testsuite/corba/portableserver/test000.adb0000644000175000017500000000611711750740340024434 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- T E S T 0 0 0 -- -- -- -- B o d y -- -- -- -- Copyright (C) 2003-2005 Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- XXX should test POA self destruction with Ada.Exceptions; with Ada.Text_IO; with CORBA.ORB; with PolyORB.CORBA_P.Server_Tools; with PolyORB.Utils.Report; with Test_AdapterActivator; with Test_ServantActivator; with Test_MyPOA; with Test000_Setup; procedure Test000 is use Ada.Exceptions; use Ada.Text_IO; use PolyORB.CORBA_P.Server_Tools; use PolyORB.Utils.Report; use Test_AdapterActivator; use Test_ServantActivator; use Test_MyPOA; use Test000_Setup; begin Init_Test; Test_Root_POA; Test_POAManager; Test_Single_Thread_Policy; Test_Main_Thread_Policy; Test_Conversion (Get_Root_POA); Test_POA_Creation; Test_POA_API; Test_POA_Hierarchy; Run_Test_AdapterActivator; Run_Test_ServantActivator; Run_Test_MyPOA; Test_OID; End_Report; CORBA.ORB.Shutdown (False); exception when E : others => Put_Line ("Got exception " & Exception_Name (E) & " : " & Exception_Message (E)); Output ("END TESTS", False); CORBA.ORB.Shutdown (False); end Test000; polyorb-2.8~20110207.orig/testsuite/corba/portableserver/test001.adb0000644000175000017500000001261111750740340024431 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- T E S T 0 0 1 -- -- -- -- B o d y -- -- -- -- Copyright (C) 2004-2008, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by ACT Europe. -- -- (email: sales@act-europe.fr) -- -- -- ------------------------------------------------------------------------------ with PolyORB.Setup.No_Tasking_Server; pragma Warnings (Off, PolyORB.Setup.No_Tasking_Server); with CORBA.Object; with CORBA.ORB; with CORBA.Impl; with CORBA.Policy; with PortableServer.POA.GOA; with PolyORB.CORBA_P.Server_Tools; with PolyORB.Utils.Report; with Echo.Impl; procedure Test001 is use PortableServer; use PortableServer.POA.GOA; use PolyORB.CORBA_P.Server_Tools; use PolyORB.Utils.Report; begin New_Test ("GOA"); CORBA.ORB.Initialize ("ORB"); declare use CORBA.Impl; Ignored_Ref : CORBA.Object.Ref; pragma Warnings (Off, Ignored_Ref); -- WAGCC4.2: kill warning on use of Ignored_Ref pragma Unreferenced (Ignored_Ref); -- Just passed to Initiate_Servant. Group : CORBA.Object.Ref; Policies : CORBA.Policy.PolicyList; GOA : constant PortableServer.POA.GOA.Ref := PortableServer.POA.GOA.To_Ref (PortableServer.POA.Create_POA (Get_Root_POA, CORBA.To_CORBA_String ("RootGOA"), PortableServer.POA.Get_The_POAManager (Get_Root_POA), Policies)); Obj1 : constant CORBA.Impl.Object_Ptr := new Echo.Impl.Object; Obj2 : constant CORBA.Impl.Object_Ptr := new Echo.Impl.Object; Obj3 : constant CORBA.Impl.Object_Ptr := new Echo.Impl.Object; Oid1 : constant PortableServer.ObjectId := Servant_To_Id (GOA, PortableServer.Servant (Obj1)); Oid2 : constant PortableServer.ObjectId := Servant_To_Id (GOA, PortableServer.Servant (Obj2)); Oid3 : constant PortableServer.ObjectId := Servant_To_Id (GOA, PortableServer.Servant (Obj3)); begin Initiate_Servant (PortableServer.Servant (Obj1), Ignored_Ref); Initiate_Servant (PortableServer.Servant (Obj2), Ignored_Ref); Initiate_Servant (PortableServer.Servant (Obj3), Ignored_Ref); CORBA.ORB.String_To_Object (CORBA.To_CORBA_String ("corbaloc:miop:1.0@1.0-TestDomain-5506/239.239.239.18:5678"), Group); Associate_Reference_With_Id (GOA, Group, Oid1); Associate_Reference_With_Id (GOA, Group, Oid2); Associate_Reference_With_Id (GOA, Group, Oid3); Output ("Added 3 servants to Group", True); Output ("Group'Length is correct", Length (Reference_To_Ids (GOA, Group)) = 3); Disassociate_Reference_With_Id (GOA, Group, Oid1); Output ("Removed 1 servant from Group", True); Disassociate_Reference_With_Id (GOA, Group, Oid2); Disassociate_Reference_With_Id (GOA, Group, Oid3); Output ("Group'Length is correct", Length (Reference_To_Ids (GOA, Group)) = 0); Associate_Reference_With_Id (GOA, Group, Oid1); Associate_Reference_With_Id (GOA, Group, Oid2); Output ("Added 2 servants to Group", True); Output ("Group'Length is correct", Length (Reference_To_Ids (GOA, Group)) = 2); declare Obj4 : constant CORBA.Impl.Object_Ptr := new Echo.Impl.Object; Oid : constant PortableServer.ObjectId := Create_Id_For_Reference (GOA, Group); begin Activate_Object_With_Id (GOA, Oid, PortableServer.Servant (Obj4)); Output ("Activate one Object with Id", True); end; Output ("Group'Length is correct", Length (Reference_To_Ids (GOA, Group)) = 3); End_Report; end; end Test001; polyorb-2.8~20110207.orig/testsuite/corba/portableserver/test_servantactivator.ads0000644000175000017500000000455411750740340027717 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- T E S T _ S E R V A N T A C T I V A T O R -- -- -- -- S p e c -- -- -- -- Copyright (C) 2003-2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ package Test_ServantActivator is procedure Run_Test_ServantActivator; -- Global variables for reporting result of ServantManagers execution Null_Activator_Incarnate_Called : Boolean := False; Simple_Activator_Incarnate_Called : Boolean := False; Simple_Activator_Etherealize_Called : Boolean := False; end Test_ServantActivator; polyorb-2.8~20110207.orig/testsuite/corba/portableserver/test000_setup.ads0000644000175000017500000001171511750740340025675 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- T E S T 0 0 0 _ S E T U P -- -- -- -- S p e c -- -- -- -- Copyright (C) 2003-2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with PortableServer.POA; with Echo; package Test000_Setup is use PortableServer; use PortableServer.Internals; use PortableServer.POA; ----------------------- -- Utility functions -- ----------------------- procedure Init_Test; -- Initialize test. procedure Attach_Servant (To_POA : PortableServer.POA.Local_Ref; Obj_Ref : out Echo.Ref); -- Attach an 'Echo' servant to 'To_POA' POA. procedure Invoke_On_Servant (Obj_Ref : Echo.Ref; Reentrant : Boolean := False; Verbose : Boolean := True); function Invoke_On_Servant (Obj_Ref : Echo.Ref) return Boolean; -- Invoke on Servant 'Obj_Ref'. ------------------------ -- POA Test functions -- ------------------------ procedure Test_Root_POA; -- Test Root_POA. procedure Test_POAManager; -- Test POA Manager behavior. procedure Test_Single_Thread_Policy; -- Test POA Single_Thread Thread Policy. procedure Test_Main_Thread_Policy; -- Test POA Main_Thread Thread Policy. procedure Test_Conversion (POA : PortableServer.POA.Local_Ref); -- Test Conversion functions under POA's configuration. function Create_POA_With_Policies (Tp : ThreadPolicyValue; Lp : LifespanPolicyValue; Up : IdUniquenessPolicyValue; Ap : IdAssignmentPolicyValue; Ip : ImplicitActivationPolicyValue; Sp : ServantRetentionPolicyValue; Rp : RequestProcessingPolicyValue) return PortableServer.POA.Local_Ref; -- Regiter a Child POA of the RootPOA with the given policies. function Create_And_Destroy_POA (Tp : ThreadPolicyValue; Lp : LifespanPolicyValue; Up : IdUniquenessPolicyValue; Ap : IdAssignmentPolicyValue; Ip : ImplicitActivationPolicyValue; Sp : ServantRetentionPolicyValue; Rp : RequestProcessingPolicyValue) return Boolean; -- Create and destroy a POA, return 'True' if the operation was -- succesful. function Policies_Image (Tp : ThreadPolicyValue; Lp : LifespanPolicyValue; Up : IdUniquenessPolicyValue; Ap : IdAssignmentPolicyValue; Ip : ImplicitActivationPolicyValue; Sp : ServantRetentionPolicyValue; Rp : RequestProcessingPolicyValue) return String; -- Image of this policies list. function Are_Policies_Valid (Tp : ThreadPolicyValue; Lp : LifespanPolicyValue; Up : IdUniquenessPolicyValue; Ap : IdAssignmentPolicyValue; Ip : ImplicitActivationPolicyValue; Sp : ServantRetentionPolicyValue; Rp : RequestProcessingPolicyValue) return Boolean; -- Return 'True' iff this policies list is an acceptable -- configuration for a CORBA POA. procedure Test_POA_Creation; -- Test PortableServer accepts only valid POA policies combination, procedure Test_POA_API; -- Test full POA API. procedure Test_POA_Hierarchy; -- Tests on POA trees procedure Test_OID; -- Tests on OID end Test000_Setup; polyorb-2.8~20110207.orig/testsuite/corba/portableserver/test_globals.ads0000644000175000017500000000501211750740340025731 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- T E S T _ G L O B A L S -- -- -- -- S p e c -- -- -- -- Copyright (C) 2005-2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with PortableServer.POA; with PortableServer.Current; with Test; package Test_Globals is Test_POA : PortableServer.POA.Local_Ref; Test_Id : PortableServer.ObjectId; Test_Current : PortableServer.Current.Local_Ref; Test_Servant : PortableServer.Servant; Test_Reference : Test.Ref; Get_POA_Success : Boolean := False; Get_Object_Id_Success : Boolean := False; Get_Reference_Success : Boolean := False; Get_Servant_Success : Boolean := False; end Test_Globals; polyorb-2.8~20110207.orig/testsuite/corba/portableserver/test_mypoa.adb0000644000175000017500000000727711750740340025431 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- T E S T _ M Y P O A -- -- -- -- B o d y -- -- -- -- Copyright (C) 2003-2007, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with CORBA.Impl; with CORBA.ORB; with CORBA.Policy; with PortableServer.POA.Helper; with PolyORB.Utils.Report; with Echo.Helper; with Echo.Impl; package body Test_MyPOA is use CORBA; use PolyORB.Utils.Report; ------------ -- To_Ref -- ------------ function To_Ref (Self : CORBA.Object.Ref'Class) return My_POA_Ref is Result : My_POA_Ref; begin Set (Result, CORBA.Object.Entity_Of (Self)); return Result; end To_Ref; ---------------- -- Test_MyPOA -- ---------------- procedure Run_Test_MyPOA is MyPOA : My_POA_Ref; Root_POA : constant PortableServer.POA.Local_Ref := PortableServer.POA.Helper.To_Local_Ref (CORBA.ORB.Resolve_Initial_References (CORBA.ORB.To_CORBA_String ("RootPOA"))); Policies : CORBA.Policy.PolicyList; Obj : constant CORBA.Impl.Object_Ptr := new Echo.Impl.Object; Obj_Ref : Echo.Ref; begin New_Test ("User defined child of POA"); MyPOA := To_Ref (PortableServer.POA.Create_POA (Root_POA, To_CORBA_String ("My_POA"), PortableServer.POA.Get_The_POAManager (Root_POA), Policies)); Output ("Attach user defined child of POA", True); Obj_Ref := Echo.Helper.To_Ref (PortableServer.POA.Servant_To_Reference (PortableServer.POA.Local_Ref (MyPOA), PortableServer.Servant (Obj))); Output ("Attach servant", True); Output ("Test invocation on servant", "Hello Ada World !" = To_Standard_String (Echo.echoString (Obj_Ref, To_CORBA_String ("Hello Ada World !")))); end Run_Test_MyPOA; end Test_MyPOA; polyorb-2.8~20110207.orig/testsuite/corba/portableserver/test_adapteractivator.adb0000644000175000017500000001462211750740340027631 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- T E S T _ A D A P T E R A C T I V A T O R -- -- -- -- B o d y -- -- -- -- Copyright (C) 2003-2007, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with CORBA.ORB; with CORBA.Policy; with PortableServer.POA.Helper; with PolyORB.Utils.Report; package body Test_AdapterActivator is use PolyORB.Utils.Report; --------------------- -- Unknown_Adapter -- --------------------- Null_Activator_Called : Boolean := False; function Unknown_Adapter (Self : NullAdapter_Ref; Parent : PortableServer.POA_Forward.Ref; Name : CORBA.String) return Boolean is pragma Unreferenced (Self, Parent, Name); begin Null_Activator_Called := True; return False; end Unknown_Adapter; Meta_Child_POA : PortableServer.POA.Local_Ref; -- pragma Unreferenced (Meta_Child_POA); pragma Warnings (Off, Meta_Child_POA); -- WAG:5.02 DB08-008 -- Assigned but never read Simple_Activator_Called : Boolean := False; function Unknown_Adapter (Self : SimpleAdapter_Ref; Parent : PortableServer.POA_Forward.Ref; Name : CORBA.String) return Boolean is pragma Unreferenced (Self); package Convert is new PortableServer.POA_Forward.Convert (PortableServer.POA.Local_Ref); Policies : CORBA.Policy.PolicyList; POA : constant PortableServer.POA.Local_Ref := Convert.To_Ref (Parent); begin Simple_Activator_Called := True; Meta_Child_POA := PortableServer.POA.Local_Ref (PortableServer.POA.Create_POA (POA, Name, PortableServer.POA.Get_The_POAManager (POA), Policies)); return True; end Unknown_Adapter; ------------------------------- -- Run_Test_AdapterActivator -- ------------------------------- procedure Run_Test_AdapterActivator is NullAdapter : constant NullAdapter_Access := new NullAdapter_Ref; SimpleAdapter : constant SimpleAdapter_Access := new SimpleAdapter_Ref; Policies : CORBA.Policy.PolicyList; Root_POA : constant PortableServer.POA.Local_Ref := PortableServer.POA.Helper.To_Local_Ref (CORBA.ORB.Resolve_Initial_References (CORBA.ORB.To_CORBA_String ("RootPOA"))); Child_POA : PortableServer.POA.Local_Ref; Foo_POA : PortableServer.POA.Local_Ref; -- pragma Unreferenced (Foo_POA); pragma Warnings (Off, Foo_POA); -- WAG:5.02 DB08-008 -- Assigned but never read begin New_Test ("Adapter Activator"); -- Register a Child POA Child_POA := PortableServer.POA.Local_Ref (PortableServer.POA.Create_POA (Root_POA, CORBA.To_CORBA_String ("Child_POA"), PortableServer.POA.Get_The_POAManager (Root_POA), Policies)); Output ("Created child POA", True); -- Look for a non existent child POA without AdapterActivator begin Foo_POA := PortableServer.POA.Local_Ref (PortableServer.POA.Find_POA (Child_POA, CORBA.To_CORBA_String ("Foo"), True)); Output ("Non existent POA found !", False); exception when PortableServer.POA.AdapterNonExistent => Output ("Non existent POA not found", True); end; -- Set Null Adapter Activator PortableServer.POA.Set_The_Activator (Child_POA, NullAdapter); -- Look for a non existent child POA with Null AdapterActivator begin Foo_POA := PortableServer.POA.Local_Ref (PortableServer.POA.Find_POA (Child_POA, CORBA.To_CORBA_String ("Foo"), True)); exception when PortableServer.POA.AdapterNonExistent => Output ("Null_Adapter did nothing ", True); end; Output ("Null Unknown_Adapter invoked", Null_Activator_Called); -- Set Simple Adapter Activator PortableServer.POA.Set_The_Activator (Child_POA, SimpleAdapter); -- Look for a non existent child POA with Simple AdapterActivator Foo_POA := PortableServer.POA.Local_Ref (PortableServer.POA.Find_POA (Child_POA, CORBA.To_CORBA_String ("Foo"), True)); Output ("Simple Unknown_Adapter invoked", Simple_Activator_Called); -- Simple check Foo_POA := PortableServer.POA.Local_Ref (PortableServer.POA.Find_POA (Child_POA, CORBA.To_CORBA_String ("Foo"), True)); PortableServer.POA.Destroy (Child_POA, False, False); end Run_Test_AdapterActivator; end Test_AdapterActivator; polyorb-2.8~20110207.orig/testsuite/corba/portableserver/test_job.adb0000644000175000017500000000531511750740340025045 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- T E S T _ J O B -- -- -- -- B o d y -- -- -- -- Copyright (C) 2003 Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by ACT Europe. -- -- (email: sales@act-europe.fr) -- -- -- ------------------------------------------------------------------------------ with CORBA; with PolyORB.Utils.Report; package body Test_Job is procedure Run_Job is begin PolyORB.Utils.Report.Output ("Invocation on servant finished", "Hello Ada World !" = CORBA.To_Standard_String (Echo.echoString (Global_Obj_Ref, CORBA.To_CORBA_String ("Hello Ada World !")))); end Run_Job; procedure Run_Job_Wait is begin PolyORB.Utils.Report.Output ("Invocation on servant finished", "Hello Ada World !" = CORBA.To_Standard_String (Echo.echoString_wait (Global_Obj_Ref, CORBA.To_CORBA_String ("Hello Ada World !")))); end Run_Job_Wait; end Test_Job; polyorb-2.8~20110207.orig/testsuite/corba/portableserver/test_nullactivator-impl.adb0000644000175000017500000000634711750740340030127 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- T E S T _ N U L L A C T I V A T O R . I M P L -- -- -- -- B o d y -- -- -- -- Copyright (C) 2005-2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with CORBA; with PortableServer.ServantManager; with Test_ServantActivator; package body Test_NullActivator.Impl is --------------- -- Incarnate -- --------------- function Incarnate (Self : access Object; Oid : PortableServer.ObjectId; Adapter : PortableServer.POA_Forward.Ref) return PortableServer.Servant is pragma Unreferenced (Self, Oid, Adapter); begin Test_ServantActivator.Null_Activator_Incarnate_Called := True; return null; end Incarnate; ---------- -- Is_A -- ---------- function Is_A (Self : not null access Object; Logical_Type_Id : Standard.String) return Boolean is pragma Unreferenced (Self); begin return CORBA.Is_Equivalent (Logical_Type_Id, Test_NullActivator.Repository_Id) or else CORBA.Is_Equivalent (Logical_Type_Id, PortableServer.ServantActivator.Repository_Id) or else CORBA.Is_Equivalent (Logical_Type_Id, PortableServer.ServantManager.Repository_Id) or else CORBA.Is_Equivalent (Logical_Type_Id, "IDL:omg.org/CORBA/Object:1.0"); end Is_A; end Test_NullActivator.Impl; polyorb-2.8~20110207.orig/testsuite/corba/portableserver/test000_setup.adb0000644000175000017500000016057211750740340025662 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- T E S T 0 0 0 _ S E T U P -- -- -- -- B o d y -- -- -- -- Copyright (C) 2003-2008, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- XXX should test POA self destruction with Ada.Exceptions; with Ada.Text_IO; with PolyORB.CORBA_P.Server_Tools; with PolyORB.Log; with PolyORB.Utils.Report; with PolyORB.Setup.Thread_Pool_Server; pragma Warnings (Off, PolyORB.Setup.Thread_Pool_Server); with PolyORB.Tasking.Threads; with CORBA.Impl; with CORBA.Object; with CORBA.ORB; with CORBA.Policy; with PortableServer.POA.Helper; with PortableServer.POAManager; with Echo.Helper; with Echo.Impl; with Test_Job; package body Test000_Setup is use Ada.Text_IO; use Ada.Exceptions; use CORBA; use PortableServer.POAManager; use PolyORB.CORBA_P.Server_Tools; use PolyORB.Log; use PolyORB.Utils.Report; package L is new PolyORB.Log.Facility_Log ("test000"); procedure O (Message : Standard.String; Level : PolyORB.Log.Log_Level := PolyORB.Log.Debug) renames L.Output; function C (Level : Log_Level := Debug) return Boolean renames L.Enabled; pragma Unreferenced (C); -- For conditional pragma Debug --------------- -- Init_Test -- --------------- procedure Init_Test is begin -- ORB Initialization. CORBA.ORB.Initialize ("ORB"); -- Run the ORB instance in a separated task. Initiate_Server (True); Output ("ORB initialized", True); end Init_Test; -------------------- -- Attach_Servant -- -------------------- procedure Attach_Servant (To_POA : PortableServer.POA.Local_Ref; Obj_Ref : out Echo.Ref) is Obj : constant CORBA.Impl.Object_Ptr := new Echo.Impl.Object; begin Obj_Ref := Echo.Helper.To_Ref (PortableServer.POA.Servant_To_Reference (To_POA, PortableServer.Servant (Obj))); Output ("Attach servant to POA " & To_Standard_String (Get_The_Name (To_POA)), True); end Attach_Servant; ----------------------- -- Invoke_On_Servant -- ----------------------- procedure Invoke_On_Servant (Obj_Ref : Echo.Ref; Reentrant : Boolean := False; Verbose : Boolean := True) is begin if Reentrant then declare IOR : constant CORBA.String := CORBA.Object.Object_To_String (Obj_Ref); begin if Verbose then Output ("Invocation on reentrant servant", IOR = Echo.echoString_reentrant (Obj_Ref, IOR)); end if; end; else if Verbose then Output ("Invocation on created servant", "Hello Ada World !" = To_Standard_String (Echo.echoString (Obj_Ref, To_CORBA_String ("Hello Ada World !")))); end if; end if; end Invoke_On_Servant; function Invoke_On_Servant (Obj_Ref : Echo.Ref) return Boolean is begin return "Hello Ada World !" = To_Standard_String (Echo.echoString (Obj_Ref, To_CORBA_String ("Hello Ada World !"))); end Invoke_On_Servant; ------------------- -- Test_Root_POA -- ------------------- procedure Test_Root_POA is Root_POA : PortableServer.POA.Local_Ref; Obj_Ref : Echo.Ref; begin New_Test ("RootPOA"); Root_POA := PortableServer.POA.Helper.To_Local_Ref (CORBA.ORB.Resolve_Initial_References (CORBA.ORB.To_CORBA_String ("RootPOA"))); Output ("Get Root_POA reference", True); Attach_Servant (Root_POA, Obj_Ref); Invoke_On_Servant (Obj_Ref); end Test_Root_POA; --------------------- -- Test_POAManager -- --------------------- procedure Test_POAManager is use CORBA.Policy.IDL_SEQUENCE_Policy; Policies : CORBA.Policy.PolicyList; Thread_Policy : constant CORBA.Policy.Ref := CORBA.Policy.Ref (Create_Thread_Policy (PortableServer.ORB_CTRL_MODEL)); Root_POA : constant PortableServer.POA.Local_Ref := PortableServer.POA.Helper.To_Local_Ref (CORBA.ORB.Resolve_Initial_References (CORBA.ORB.To_CORBA_String ("RootPOA"))); Child_POA_Manager : PortableServer.POAManager.Local_Ref; Child_POA : PortableServer.POA.Local_Ref; Obj_Ref : Echo.Ref; begin New_Test ("POAManager"); -- Construct POA Policy List. Append (Policies, Thread_Policy); -- Register a Child POA. Child_POA := PortableServer.POA.Local_Ref (PortableServer.POA.Create_POA (Root_POA, To_CORBA_String ("Child_POA"), Child_POA_Manager, Policies)); Output ("Created child POA", True); Activate (PortableServer.POA.Get_The_POAManager (Child_POA)); Output ("POA is now active", True); -- Test invocation on a servant attached to this Child POA. Attach_Servant (Child_POA, Obj_Ref); Invoke_On_Servant (Obj_Ref); -- Now the POAManager will hold requests. Hold_Requests (PortableServer.POA.Get_The_POAManager (Child_POA), False); Output ("POA will hold requests, no request invocation", True); Activate (PortableServer.POA.Get_The_POAManager (Child_POA)); Output ("POA is now active", True); -- POAManager state sanity check Output ("POA State Correct ", Get_State (PortableServer.POA.Get_The_POAManager (Child_POA)) = PortableServer.POAManager.ACTIVE); -- Now the POAManager will hold requests, we also invoke a request -- to test POAManager queue. Hold_Requests (PortableServer.POA.Get_The_POAManager (Child_POA), False); Output ("POA will hold requests, request invocation", True); -- POAManager state sanity check Output ("POA State Correct ", Get_State (PortableServer.POA.Get_The_POAManager (Child_POA)) = PortableServer.POAManager.HOLDING); Test_Job.Global_Obj_Ref := Obj_Ref; PolyORB.Tasking.Threads.Create_Task (Test_Job.Run_Job'Access); delay 0.1; -- Delay to provoke a context switch so that invocation -- actually begins before executing the next statement. Output ("Invocation on servant began", True); Activate (PortableServer.POA.Get_The_POAManager (Child_POA)); Output ("POA is now active", True); -- POAManager state sanity check Output ("POA State Correct ", Get_State (PortableServer.POA.Get_The_POAManager (Child_POA)) = PortableServer.POAManager.ACTIVE); -- (dirty) Synchronization point. delay 5.0; Output ("Waiting for end of POAManager 'HOLDING' tests", True); -- Now the POAManager will discard requests. Discard_Requests (PortableServer.POA.Get_The_POAManager (Child_POA), False); -- POAManager state sanity check Output ("POA State Correct ", Get_State (PortableServer.POA.Get_The_POAManager (Child_POA)) = PortableServer.POAManager.DISCARDING); Output ("POA will discard requests", True); begin Invoke_On_Servant (Obj_Ref); Output ("Invoke raised exception", False); exception when CORBA.Transient => Output ("Invoke raised exception", True); when E : others => Put_Line ("Got exception " & Exception_Name (E) & " : " & Exception_Message (E)); raise; end; Activate (PortableServer.POA.Get_The_POAManager (Child_POA)); Output ("POA has been reactived", True); -- POAManager state sanity check Output ("POA State Correct ", Get_State (PortableServer.POA.Get_The_POAManager (Child_POA)) = PortableServer.POAManager.ACTIVE); Invoke_On_Servant (Obj_Ref); -- Now the POAManager is deactivated Deactivate (PortableServer.POA.Get_The_POAManager (Child_POA), False, False); -- POAManager state sanity check Output ("POA State Correct ", Get_State (PortableServer.POA.Get_The_POAManager (Child_POA)) = PortableServer.POAManager.INACTIVE); begin Activate (PortableServer.POA.Get_The_POAManager (Child_POA)); Output ("Activate raised exception", False); exception when PortableServer.POAManager.AdapterInactive => Output ("Activate raised exception", True); when E : others => Put_Line ("Got exception " & Exception_Name (E) & " : " & Exception_Message (E)); raise; end; Destroy (Child_POA, True, True); Output ("POA has been destroyed", True); end Test_POAManager; ------------------------------- -- Test_Single_Thread_Policy -- ------------------------------- procedure Test_Single_Thread_Policy is use CORBA.Policy.IDL_SEQUENCE_Policy; Policies : CORBA.Policy.PolicyList; Thread_Policy : constant CORBA.Policy.Ref := CORBA.Policy.Ref (Create_Thread_Policy (PortableServer.SINGLE_THREAD_MODEL)); Root_POA : constant PortableServer.POA.Local_Ref := PortableServer.POA.Helper.To_Local_Ref (CORBA.ORB.Resolve_Initial_References (CORBA.ORB.To_CORBA_String ("RootPOA"))); Child_POA : PortableServer.POA.Local_Ref; Obj_Ref, Obj_Ref2 : Echo.Ref; begin New_Test ("Single Thread Policy"); -- Construct POA Policy List. Append (Policies, Thread_Policy); -- Register a Child POA. Child_POA := PortableServer.POA.Local_Ref (PortableServer.POA.Create_POA (Root_POA, To_CORBA_String ("Child_POA"), PortableServer.POA.Get_The_POAManager (Root_POA), Policies)); Output ("Created child POA with Single Thread policy", True); -- Test the call is reentrant. -- XXX note that this test may or may not work, see -- PolyORB.POA_Policies.Thread_Policy.Single_Thread for more -- details. Attach_Servant (Child_POA, Obj_Ref); -- Invoke_On_Servant (Obj_Ref, True); -- Test multiple calls on the same servant. Test_Job.Global_Obj_Ref := Obj_Ref; PolyORB.Tasking.Threads.Create_Task (Test_Job.Run_Job_Wait'Access); delay 0.01; PolyORB.Tasking.Threads.Create_Task (Test_Job.Run_Job_Wait'Access); delay 0.01; -- Delay to provoke a context switch so that invocation -- actually begins before executing the next statement. -- (dirty) Synchronization point. delay 10.0; Output ("Waiting for the end of multiple calls", True); Attach_Servant (Child_POA, Obj_Ref2); Invoke_On_Servant (Obj_Ref2); -- (dirty) Synchronization point. delay 10.0; Output ("Waiting for end of Single Thread tests", True); Destroy (Child_POA, True, True); Output ("POA has been destroyed", True); end Test_Single_Thread_Policy; ----------------------------- -- Test_Main_Thread_Policy -- ----------------------------- procedure Test_Main_Thread_Policy is use CORBA.Policy.IDL_SEQUENCE_Policy; Policies : CORBA.Policy.PolicyList; Thread_Policy : constant CORBA.Policy.Ref := CORBA.Policy.Ref (Create_Thread_Policy (PortableServer.MAIN_THREAD_MODEL)); Root_POA : constant PortableServer.POA.Local_Ref := PortableServer.POA.Helper.To_Local_Ref (CORBA.ORB.Resolve_Initial_References (CORBA.ORB.To_CORBA_String ("RootPOA"))); Child_POA : PortableServer.POA.Local_Ref; Obj_Ref, Obj_Ref2 : Echo.Ref; begin New_Test ("Main Thread Policy"); -- Construct POA Policy List. Append (Policies, Thread_Policy); -- Register a Child POA. Child_POA := PortableServer.POA.Local_Ref (PortableServer.POA.Create_POA (Root_POA, To_CORBA_String ("Child_POA"), PortableServer.POA.Get_The_POAManager (Root_POA), Policies)); Output ("Created child POA with Main Thread policy", True); Attach_Servant (Child_POA, Obj_Ref); Invoke_On_Servant (Obj_Ref); -- Test multiple calls on the same servant. Test_Job.Global_Obj_Ref := Obj_Ref; PolyORB.Tasking.Threads.Create_Task (Test_Job.Run_Job_Wait'Access); delay 0.01; PolyORB.Tasking.Threads.Create_Task (Test_Job.Run_Job_Wait'Access); delay 0.01; -- Delay to provoke a context switch so that invocation -- actually begins before executing the next statement. Attach_Servant (Child_POA, Obj_Ref2); Invoke_On_Servant (Obj_Ref2); -- (dirty) Synchronization point. delay 10.0; Output ("Waiting for end of Main Thread tests", True); Destroy (Child_POA, True, True); Output ("POA has been destroyed", True); end Test_Main_Thread_Policy; --------------------- -- Test_Conversion -- --------------------- procedure Test_Conversion (POA : PortableServer.POA.Local_Ref) is Servant : constant PortableServer.Servant := new Echo.Impl.Object; begin New_Test ("Conversions"); -- XXX these tests should test consistency between converted -- entities !! declare Obj_Ref : constant CORBA.Object.Ref := PortableServer.POA.Servant_To_Reference (POA, Servant); begin Output ("Servant_To_Reference", True); declare Oid : constant ObjectId := Reference_To_Id (POA, Obj_Ref); pragma Unreferenced (Oid); begin Output ("Reference_To_Id", True); end; declare Servant : constant PortableServer.Servant := Reference_To_Servant (POA, Obj_Ref); pragma Unreferenced (Servant); begin Output ("Reference_To_Servant", True); end; end; declare Oid : constant ObjectId := Servant_To_Id (POA, Servant); begin Output ("Servant_To_Id", True); declare Servant : constant PortableServer.Servant := Id_To_Servant (POA, Oid); pragma Unreferenced (Servant); begin Output ("Id_To_Servant", True); end; declare Obj_Ref : constant CORBA.Object.Ref := Id_To_Reference (POA, Oid); pragma Unreferenced (Obj_Ref); begin Output ("Id_To_Reference", True); end; end; end Test_Conversion; ------------------------------ -- Create_POA_With_Policies -- ------------------------------ function Create_POA_With_Policies (Tp : ThreadPolicyValue; Lp : LifespanPolicyValue; Up : IdUniquenessPolicyValue; Ap : IdAssignmentPolicyValue; Ip : ImplicitActivationPolicyValue; Sp : ServantRetentionPolicyValue; Rp : RequestProcessingPolicyValue) return PortableServer.POA.Local_Ref is use CORBA.Policy.IDL_SEQUENCE_Policy; Policies : CORBA.Policy.PolicyList; Thread_Policy : constant CORBA.Policy.Ref := CORBA.Policy.Ref (Create_Thread_Policy (Tp)); Lifespan_Policy : constant CORBA.Policy.Ref := CORBA.Policy.Ref (Create_Lifespan_Policy (Lp)); Id_Uniqueness_Policy : constant CORBA.Policy.Ref := CORBA.Policy.Ref (Create_Id_Uniqueness_Policy (Up)); Id_Assignment_Policy : constant CORBA.Policy.Ref := CORBA.Policy.Ref (Create_Id_Assignment_Policy (Ap)); Implicit_Activation_Policy : constant CORBA.Policy.Ref := CORBA.Policy.Ref (Create_Implicit_Activation_Policy (Ip)); Servant_Retention_Policy : constant CORBA.Policy.Ref := CORBA.Policy.Ref (Create_Servant_Retention_Policy (Sp)); Request_Processing_Policy : constant CORBA.Policy.Ref := CORBA.Policy.Ref (Create_Request_Processing_Policy (Rp)); Root_POA : constant PortableServer.POA.Local_Ref := PortableServer.POA.Helper.To_Local_Ref (CORBA.ORB.Resolve_Initial_References (CORBA.ORB.To_CORBA_String ("RootPOA"))); Child_POA : PortableServer.POA.Local_Ref; begin Append (Policies, Thread_Policy); Append (Policies, Lifespan_Policy); Append (Policies, Id_Uniqueness_Policy); Append (Policies, Id_Assignment_Policy); Append (Policies, Implicit_Activation_Policy); Append (Policies, Servant_Retention_Policy); Append (Policies, Request_Processing_Policy); Child_POA := PortableServer.POA.Local_Ref (PortableServer.POA.Create_POA (Root_POA, To_CORBA_String ("Child_POA"), PortableServer.POA.Get_The_POAManager (Root_POA), Policies)); return Child_POA; end Create_POA_With_Policies; -------------------- -- Policies_Image -- -------------------- function Policies_Image (Tp : ThreadPolicyValue; Lp : LifespanPolicyValue; Up : IdUniquenessPolicyValue; Ap : IdAssignmentPolicyValue; Ip : ImplicitActivationPolicyValue; Sp : ServantRetentionPolicyValue; Rp : RequestProcessingPolicyValue) return String is begin return " " & Tp'Img & " " & Lp'Img & " " & Up'Img & " " & Ap'Img & " " & Ip'Img & " " & Sp'Img & " " & Rp'Img & " "; end Policies_Image; ------------------------ -- Are_Policies_Valid -- ------------------------ function Are_Policies_Valid (Tp : ThreadPolicyValue; Lp : LifespanPolicyValue; Up : IdUniquenessPolicyValue; Ap : IdAssignmentPolicyValue; Ip : ImplicitActivationPolicyValue; Sp : ServantRetentionPolicyValue; Rp : RequestProcessingPolicyValue) return Boolean is pragma Unreferenced (Tp, Lp); begin if (Up = UNIQUE_ID and then Sp = NON_RETAIN) or else (Sp = NON_RETAIN and then not (Rp = USE_DEFAULT_SERVANT or else Rp = USE_SERVANT_MANAGER)) or else (Ip = IMPLICIT_ACTIVATION and then not (Ap = SYSTEM_ID and then Sp = RETAIN)) or else (Rp = USE_ACTIVE_OBJECT_MAP_ONLY and then Sp /= RETAIN) or else (Rp = USE_DEFAULT_SERVANT and then Up /= MULTIPLE_ID) then return False; else return True; end if; end Are_Policies_Valid; ---------------------------- -- Create_And_Destroy_POA -- ---------------------------- function Create_And_Destroy_POA (Tp : ThreadPolicyValue; Lp : LifespanPolicyValue; Up : IdUniquenessPolicyValue; Ap : IdAssignmentPolicyValue; Ip : ImplicitActivationPolicyValue; Sp : ServantRetentionPolicyValue; Rp : RequestProcessingPolicyValue) return Boolean is Test_POA : PortableServer.POA.Local_Ref; begin Test_POA := Create_POA_With_Policies (Tp, Lp, Up, Ap, Ip, Sp, Rp); PortableServer.POA.Destroy (Test_POA, False, False); return Are_Policies_Valid (Tp, Lp, Up, Ap, Ip, Sp, Rp); exception when E : PortableServer.POA.InvalidPolicy => if Are_Policies_Valid (Tp, Lp, Up, Ap, Ip, Sp, Rp) then -- If policies are valid, then there is a problem. New_Line; Put_Line ("Got exception " & Exception_Name (E) & " : " & Exception_Message (E)); Put_Line ("Valid ? " & Boolean'Image (Are_Policies_Valid (Tp, Lp, Up, Ap, Ip, Sp, Rp))); Put_Line (Policies_Image (Tp, Lp, Up, Ap, Ip, Sp, Rp)); end if; return not Are_Policies_Valid (Tp, Lp, Up, Ap, Ip, Sp, Rp); when E : others => Output ("Fatal Error, got exception ", False); Put_Line (Ada.Exceptions.Exception_Information (E)); return False; end Create_And_Destroy_POA; ----------------------- -- Test_POA_Creation -- ----------------------- procedure Test_POA_Creation is Result : Boolean := True; begin New_Test ("POA Creation"); for Tp in ThreadPolicyValue'Range loop for Lp in LifespanPolicyValue'Range loop for Up in IdUniquenessPolicyValue'Range loop for Ap in IdAssignmentPolicyValue'Range loop for Ip in ImplicitActivationPolicyValue'Range loop for Sp in ServantRetentionPolicyValue'Range loop for Rp in RequestProcessingPolicyValue'Range loop pragma Debug (O (" ")); pragma Debug (O ("Testing: " & Policies_Image (Tp, Lp, Up, Ap, Ip, Sp, Rp))); Result := Result and Create_And_Destroy_POA (Tp, Lp, Up, Ap, Ip, Sp, Rp); if not Result then Put_Line (Policies_Image (Tp, Lp, Up, Ap, Ip, Sp, Rp)); exit; end if; end loop; end loop; end loop; end loop; end loop; end loop; end loop; Output ("Test_POA_Creation", Result); end Test_POA_Creation; ---------------------------------- -- Test_POA_Activation_Policies -- ---------------------------------- type Result_Vector is record Implicit_Activation : Boolean := True; Get_Type_Id : Boolean := True; Activation_No_Id : Boolean := True; Unique_Activation_No_Id : Boolean := True; Deactivation_No_Id : Boolean := True; Activation_Id : Boolean := True; Unique_Activation_Id : Boolean := True; Deactivation_Id : Boolean := True; Default_Servant_No_Id : Boolean := True; Default_Servant_Id : Boolean := True; Fatal : Boolean := False; end record; function Test_POA_Activation_Policies (POA : PortableServer.POA.Local_Ref) return Result_Vector; -- Test Servant Activation Policies under POA's configuration. function Test_POA_Activation_Policies (POA : PortableServer.POA.Local_Ref) return Result_Vector is Result : Result_Vector; Temp : Boolean; begin -- -- Servant_To_Refence implicitly activates servant. -- pragma Debug (O (" ==> Implicit Activation sub test <==")); declare Servant : constant PortableServer.Servant := new Echo.Impl.Object; Obj_Ref : Echo.Ref; begin -- Call Servant_To_Reference. begin Obj_Ref := Echo.Helper.To_Ref (PortableServer.POA.Servant_To_Reference (POA, Servant)); exception when PortableServer.POA.WrongPolicy => pragma Debug (O ("Servant_To_Reference failed on WrongPolicy")); Result.Implicit_Activation := False; when PortableServer.POA.ServantNotActive => pragma Debug (O ("Servant_To_Reference failed on " & "ServantNotActive")); Result.Implicit_Activation := False; when E : others => pragma Debug (O ("Got exception " & Exception_Name (E) & " : " & Exception_Message (E))); Result.Fatal := True; end; -- Try to Invoke on the Reference we built. begin Temp := Invoke_On_Servant (Obj_Ref); if not Temp then pragma Debug (O ("FATAL: invocation failed")); Result.Fatal := True; end if; exception when CORBA.Inv_Objref => pragma Debug (O ("Implicit_Activation: Invoke failed")); Result.Implicit_Activation := False; when E : others => pragma Debug (O ("Got exception " & Exception_Name (E) & " : " & Exception_Message (E))); Result.Fatal := True; end; exception when E : others => pragma Debug (O ("FATAL: Got exception @0 " & Exception_Name (E))); Result.Fatal := True; end; -- -- Explicitly Activate servant with No Id. -- pragma Debug (O (" ==> Explicit Activation System Id sub test <==")); declare Servant : constant PortableServer.Servant := new Echo.Impl.Object; Obj_Ref : Echo.Ref; begin declare -- Explicit Object Activation with no supplied Id Oid : constant ObjectId := PortableServer.POA.Activate_Object (POA, Servant); begin -- Call Servant_To_Reference Obj_Ref := Echo.Helper.To_Ref (PortableServer.POA.Servant_To_Reference (POA, Servant)); -- Try to invoke on the Object Ref we created from the Servant Temp := Invoke_On_Servant (Obj_Ref); if not Temp then pragma Debug (O ("FATAL: Invoke_On_Servant failed")); Result.Fatal := True; end if; -- Repository Id sanity check Temp := Echo.Repository_Id = Get_Type_Id (Reference_To_Servant (POA, Obj_Ref)); if not Temp then pragma Debug (O ("Get_Type_Id failed")); Result.Get_Type_Id := False; end if; -- Activate twice the same Object begin declare Oid2 : constant ObjectId := PortableServer.POA.Activate_Object (POA, Servant); begin Result.Unique_Activation_No_Id := False; -- Try to invoke on the Servant with new Oid declare Obj_Ref2 : constant Echo.Ref := Echo.Helper.To_Ref (Id_To_Reference (POA, Oid2)); begin Temp := Invoke_On_Servant (Obj_Ref2); if not Temp then pragma Debug (O ("FATAL: Invoke_On_Servant failed")); Result.Fatal := True; end if; end; end; exception when PortableServer.POA.ServantAlreadyActive => null; end; -- Deactivate Object begin PortableServer.POA.Deactivate_Object (POA, Oid); exception when E : others => pragma Debug (O ("Got exception " & Exception_Name (E) & " : " & Exception_Message (E))); pragma Debug (O ("Deactivation_No_Id failed")); Result.Deactivation_No_Id := False; end; begin Temp := Invoke_On_Servant (Obj_Ref); pragma Debug (O ("FATAL: Did an invocation on a 'should-not-be'" & " activated servant !!")); Result.Fatal := True; exception when others => null; end; -- Activate Object With Id we get from the POA begin PortableServer.POA.Activate_Object_With_Id (POA, Oid, Servant); exception when others => pragma Debug (O ("FATAL: Reactivation with Id failed")); Result.Fatal := True; end; begin Temp := Invoke_On_Servant (Obj_Ref); exception when E : others => pragma Debug (O ("Got exception " & Exception_Name (E) & " : " & Exception_Message (E))); pragma Debug (O ("FATAL: Invoke_On_Servant " & "raised an exception")); Result.Fatal := True; end; -- Deactivate Object begin PortableServer.POA.Deactivate_Object (POA, Oid); exception when E : others => pragma Debug (O ("Got exception " & Exception_Name (E) & " : " & Exception_Message (E))); pragma Debug (O ("Deactivation_No_Id failed")); Result.Deactivation_No_Id := False; end; begin Temp := Invoke_On_Servant (Obj_Ref); pragma Debug (O ("FATAL: Did an invocation on a 'should-not-be'" & " activated servant !!")); Result.Fatal := True; exception when others => null; end; end; exception when E : others => pragma Debug (O ("Got exception " & Exception_Name (E) & " : " & Exception_Message (E))); pragma Debug (O ("Activation_No_Id failed")); Result.Activation_No_Id := False; pragma Debug (O ("Reactivation_Id failed")); pragma Debug (O ("Deactivation_No_Id failed")); Result.Deactivation_No_Id := False; Result.Unique_Activation_No_Id := False; end; -- -- Explicitly Activate servant with User Id. -- pragma Debug (O (" ==> Explicit Activation User Id sub test <==")); declare Servant : constant PortableServer.Servant := new Echo.Impl.Object; Obj_Ref : Echo.Ref; Oid : constant ObjectId := PortableServer.String_To_ObjectId ("dead"); begin -- Explicit Object Activation with User supplied Object_Id. PortableServer.POA.Activate_Object_With_Id (POA, Oid, Servant); -- Repository Id sanity check Temp := Echo.Repository_Id = Get_Type_Id (Reference_To_Servant (POA, Obj_Ref)); if not Temp then pragma Debug (O ("Get_Type_Id failed")); Result.Get_Type_Id := False; end if; -- Test Servant to Id integrity. declare Oid2 : constant ObjectId := PortableServer.POA.Servant_To_Id (POA, Servant); begin if Oid /= Oid2 then Result.Fatal := True; pragma Debug (O (PortableServer.ObjectId_To_String (Oid))); pragma Debug (O (PortableServer.ObjectId_To_String (Oid2))); -- Having Oid /= Oid2 is valid when using MULTIPLE_ID end if; end; -- Call Servant_To_Reference. Obj_Ref := Echo.Helper.To_Ref (PortableServer.POA.Servant_To_Reference (POA, Servant)); -- Try to invoke on the Ref we created from the Servant Temp := Invoke_On_Servant (Obj_Ref); if not Temp then pragma Debug (O ("FATAL: Invoke_On_Servant failed")); Result.Fatal := True; end if; -- Deactivate Object begin PortableServer.POA.Deactivate_Object (POA, Oid); exception when E : others => pragma Debug (O ("Got exception " & Exception_Name (E) & " : " & Exception_Message (E))); pragma Debug (O ("Deactivaion_Id failed")); Result.Deactivation_Id := False; end; begin Temp := Invoke_On_Servant (Obj_Ref); pragma Debug (O ("FATAL: Invoke_On_Servant raised no exception")); Result.Fatal := True; exception when others => null; end; -- Try to invoke on a Ref created from the User's Oid declare Obj_Ref2 : constant Echo.Ref := Echo.Helper.To_Ref (Create_Reference_With_Id (POA, Oid, To_CORBA_String (Echo.Repository_Id))); Temp_Oid : constant PortableServer.ObjectId := PortableServer.POA.Activate_Object (POA, Reference_To_Servant (POA, Obj_Ref2)); pragma Unreferenced (Temp_Oid); begin -- Repository Id sanity check Temp := Echo.Repository_Id = Get_Type_Id (Reference_To_Servant (POA, Obj_Ref2)); if not Temp then pragma Debug (O ("Get_Type_Id failed")); Result.Get_Type_Id := False; end if; Temp := Invoke_On_Servant (Obj_Ref2); exception when E : others => pragma Debug (O ("Got exception " & Exception_Name (E) & " : " & Exception_Message (E))); pragma Debug (O ("FATAL: Invoke_On_Servant " & "raised an exception")); Result.Fatal := True; end; -- Activate twice the same Object with the same Id. begin PortableServer.POA.Activate_Object_With_Id (POA, Oid, Servant); PortableServer.POA.Activate_Object_With_Id (POA, Oid, Servant); Result.Unique_Activation_Id := False; exception when PortableServer.POA.ServantAlreadyActive => null; end; exception when E : others => pragma Debug (O ("Got exception " & Exception_Name (E) & " " & Exception_Message (E))); pragma Debug (O ("Activation_Id failed")); Result.Activation_Id := False; pragma Debug (O ("Deactivaion_Id failed")); Result.Deactivation_Id := False; Result.Unique_Activation_Id := False; end; -- -- Default servant tests -- pragma Debug (O (" ==> Default servant test <==")); declare Servant : constant PortableServer.Servant := new Echo.Impl.Object; Temp : Boolean; begin -- Default Servant should be null begin declare Servant2 : constant PortableServer.Servant := Get_Servant (POA); pragma Unreferenced (Servant2); begin pragma Debug (O ("FATAL: Get Servant raised no exception")); Result.Fatal := True; end; exception when PortableServer.POA.NoServant => null; end; -- Test Set_Sevant begin Set_Servant (POA, Servant); exception when PortableServer.POA.WrongPolicy => raise; when E : others => pragma Debug (O ("Got exception A" & Exception_Name (E) & " " & Exception_Message (E))); Result.Fatal := True; end; -- Sanity check Temp := Servant = Get_Servant (POA); if not Temp then pragma Debug (O ("FATAL: Default Servant check failed")); Result.Fatal := True; end if; -- Test invocation on default servant with System Id begin declare Obj_Ref2 : constant Echo.Ref := Echo.Helper.To_Ref (Create_Reference (POA, To_CORBA_String (Echo.Repository_Id))); begin Temp := Invoke_On_Servant (Obj_Ref2); if not Temp then pragma Debug (O ("FATAL: Invoke_On_Servant failed")); Result.Fatal := True; end if; end; exception when CORBA.Bad_Param => Result.Default_Servant_No_Id := False; pragma Debug (O ("Default_Servant_No_Id failed")); end; -- Test invocation on default servant with User Id begin declare Obj_Ref2 : constant Echo.Ref := Echo.Helper.To_Ref (Create_Reference_With_Id (POA, PortableServer.String_To_ObjectId ("dead"), To_CORBA_String (Echo.Repository_Id))); begin Temp := Invoke_On_Servant (Obj_Ref2); if not Temp then pragma Debug (O ("FATAL: Invoke_On_Servant failed")); Result.Fatal := True; end if; end; exception when CORBA.Bad_Param => Result.Default_Servant_Id := False; pragma Debug (O ("Default_Servant_Id failed")); end; exception when PortableServer.POA.WrongPolicy => Result.Default_Servant_Id := False; pragma Debug (O ("Default_Servant_Id failed")); Result.Default_Servant_No_Id := False; pragma Debug (O ("Default_Servant_No_Id failed")); when E : others => pragma Debug (O ("Got exception B" & Exception_Name (E) & " " & Exception_Message (E))); Result.Fatal := True; end; -- End of tests return Result; exception when E : others => pragma Debug (Put_Line ("Got exception @end " & Exception_Name (E) & " " & Exception_Message (E))); Result.Fatal := True; return Result; end Test_POA_Activation_Policies; -------------------- -- Analyze_Result -- -------------------- function Analyze_Result (Result : Result_Vector; Tp : ThreadPolicyValue; Lp : LifespanPolicyValue; Up : IdUniquenessPolicyValue; Ap : IdAssignmentPolicyValue; Ip : ImplicitActivationPolicyValue; Sp : ServantRetentionPolicyValue; Rp : RequestProcessingPolicyValue) return Boolean; function Analyze_Result (Result : Result_Vector; Tp : ThreadPolicyValue; Lp : LifespanPolicyValue; Up : IdUniquenessPolicyValue; Ap : IdAssignmentPolicyValue; Ip : ImplicitActivationPolicyValue; Sp : ServantRetentionPolicyValue; Rp : RequestProcessingPolicyValue) return Boolean is pragma Unreferenced (Tp, Lp); begin if Result.Fatal then Output ("Result.Fatal", True); return False; end if; if Result.Implicit_Activation and then (Sp /= RETAIN or Ip /= IMPLICIT_ACTIVATION) then Output ("Result.Implicit_Activation", True); return False; end if; if not Result.Get_Type_Id then Output ("Result.Get_Type_Id", True); return False; end if; if Result.Activation_No_Id and then Ap /= SYSTEM_ID and then Sp /= RETAIN then Output ("Resuilt.Activation_No_Id", True); return False; end if; if Result.Unique_Activation_No_Id and then Up /= UNIQUE_ID then Output ("Result.Unique_Activation_No_Id", True); return False; end if; if Result.Deactivation_No_Id and then not Result.Activation_No_Id and then Sp /= RETAIN then Output ("Result.Deactivation_No_Id", True); return False; end if; if Result.Activation_Id and then Sp /= RETAIN then Output ("Result.Activation_Id", True); return False; end if; if Result.Unique_Activation_Id and then Up /= UNIQUE_ID then Output ("Result.Unique_Activation_Id", True); return False; end if; if Result.Deactivation_Id and then not Result.Activation_Id and then Sp /= RETAIN then Output ("Result.Deactivation_Id", True); return False; end if; if Result.Default_Servant_No_Id and then Rp /= USE_DEFAULT_SERVANT and then Ap /= SYSTEM_ID then Output ("Result.Use_Default_Servant_No_Id", True); return False; end if; if Result.Default_Servant_Id and then Rp /= USE_DEFAULT_SERVANT and then Ap /= USER_ID then Output ("Result.Use_Default_Servant_Id", True); return False; end if; return True; end Analyze_Result; ------------------ -- Test_POA_API -- ------------------ procedure Test_POA_API is Test_POA : PortableServer.POA.Local_Ref; Result : Boolean := True; Temp : Boolean; begin New_Test ("POA API"); for Lp in LifespanPolicyValue'Range loop for Up in IdUniquenessPolicyValue'Range loop for Ap in IdAssignmentPolicyValue'Range loop for Ip in ImplicitActivationPolicyValue'Range loop for Sp in ServantRetentionPolicyValue'Range loop for Rp in USE_ACTIVE_OBJECT_MAP_ONLY .. USE_DEFAULT_SERVANT loop if Are_Policies_Valid (ORB_CTRL_MODEL, Lp, Up, Ap, Ip, Sp, Rp) then pragma Debug (O (" ")); pragma Debug (O ("Testing: " & Policies_Image (ORB_CTRL_MODEL, Lp, Up, Ap, Ip, Sp, Rp))); Test_POA := Create_POA_With_Policies (ORB_CTRL_MODEL, Lp, Up, Ap, Ip, Sp, Rp); Temp := Analyze_Result (Test_POA_Activation_Policies (Test_POA), ORB_CTRL_MODEL, Lp, Up, Ap, Ip, Sp, Rp); PortableServer.POA.Destroy (Test_POA, False, False); Result := Result and Temp; if not Temp then null; pragma Debug (O ("Not Ok")); end if; end if; end loop; end loop; end loop; end loop; end loop; end loop; Output ("Test_POA_API", Result); end Test_POA_API; ------------------------ -- Test_POA_Hierarchy -- ------------------------ procedure Test_POA_Hierarchy is Policies : CORBA.Policy.PolicyList; Root_POA : constant PortableServer.POA.Local_Ref := PortableServer.POA.Helper.To_Local_Ref (CORBA.ORB.Resolve_Initial_References (CORBA.ORB.To_CORBA_String ("RootPOA"))); Child_POA : PortableServer.POA.Local_Ref; Huey_POA, Dewey_POA, Louie_POA : PortableServer.POA.Local_Ref; -- pragma Unreferenced (Huey_POA, Louie_POA); pragma Warnings (Off, Huey_POA); -- WAG:5.02 DB08-008 pragma Warnings (Off, Louie_POA); -- WAG:5.02 DB08-008 -- Assigned but never read begin New_Test ("POA Hierarchy"); -- Register Children POA Child_POA := PortableServer.POA.Local_Ref (PortableServer.POA.Create_POA (Root_POA, To_CORBA_String ("Child_POA"), PortableServer.POA.Get_The_POAManager (Root_POA), Policies)); Huey_POA := PortableServer.POA.Local_Ref (PortableServer.POA.Create_POA (Child_POA, To_CORBA_String ("Huey_POA"), PortableServer.POA.Get_The_POAManager (Root_POA), Policies)); Dewey_POA := PortableServer.POA.Local_Ref (PortableServer.POA.Create_POA (Child_POA, To_CORBA_String ("Dewey_POA"), PortableServer.POA.Get_The_POAManager (Root_POA), Policies)); Louie_POA := PortableServer.POA.Local_Ref (PortableServer.POA.Create_POA (Dewey_POA, To_CORBA_String ("Louie_POA"), PortableServer.POA.Get_The_POAManager (Root_POA), Policies)); Output ("Registred POA tree", True); -- Test Find_POA declare Huey_2 : PortableServer.POA.Local_Ref; -- pragma Unreferenced (Huey_2); pragma Warnings (Off, Huey_2); -- WAG:5.02 DB08-008 -- Assigned but never read begin Huey_2 := PortableServer.POA.Local_Ref (PortableServer.POA.Find_POA (Child_POA, To_CORBA_String ("Huey_POA"), False)); Output ("Find_POA on an existent POA", True); end; declare Donald : PortableServer.POA.Local_Ref; -- pragma Unreferenced (Donald); pragma Warnings (Off, Donald); -- WAG:5.02 DB08-008 -- Assigned but never read begin Donald := PortableServer.POA.Local_Ref (PortableServer.POA.Find_POA (Child_POA, To_CORBA_String ("Donald_POA"), True)); exception when PortableServer.POA.AdapterNonExistent => Output ("Find_POA on a non existent POA", True); end; -- Test Get_The_Children declare use PortableServer.IDL_SEQUENCE_PortableServer_POA_Forward; Children : constant PortableServer.POAList := PortableServer.POA.Get_The_Children (Child_POA); Children_Array : constant Element_Array := To_Element_Array (Children); begin if Children_Array'Length /= 2 then raise Program_Error; end if; for J in Children_Array'Range loop Output ("Found child: " & CORBA.To_Standard_String (PortableServer.POA.Get_The_Name (PortableServer.POA.Convert.To_Ref (Children_Array (J)))), True); end loop; end; Destroy (Child_POA, True, True); Output ("Destroy POA tree", True); end Test_POA_Hierarchy; -------------- -- Test_OID -- -------------- procedure Test_OID is use CORBA.Policy; use CORBA.Policy.IDL_SEQUENCE_Policy; Root_POA : constant PortableServer.POA.Local_Ref := PortableServer.POA.Helper.To_Local_Ref (CORBA.ORB.Resolve_Initial_References (CORBA.ORB.To_CORBA_String ("RootPOA"))); My_POA, My_Child_POA : PortableServer.POA.Local_Ref; My_POA_Manager, My_Child_POA_Manager : PortableServer.POAManager.Local_Ref; Success : Boolean; begin New_Test ("OID"); declare Policies : CORBA.Policy.PolicyList; Lifespan_Policy : constant CORBA.Policy.Ref := CORBA.Policy.Ref (Create_Lifespan_Policy (PERSISTENT)); Id_Assignment_Policy : constant CORBA.Policy.Ref := CORBA.Policy.Ref (Create_Id_Assignment_Policy (USER_ID)); Implicit_Activation_Policy : constant CORBA.Policy.Ref := CORBA.Policy.Ref (Create_Implicit_Activation_Policy (NO_IMPLICIT_ACTIVATION)); Request_Processing_Policy : constant CORBA.Policy.Ref := CORBA.Policy.Ref (Create_Request_Processing_Policy (USE_SERVANT_MANAGER)); begin Append (Policies, Lifespan_Policy); Append (Policies, Id_Assignment_Policy); Append (Policies, Implicit_Activation_Policy); Append (Policies, Request_Processing_Policy); My_POA := PortableServer.POA.Local_Ref (PortableServer.POA.Create_POA (Root_POA, CORBA.To_CORBA_String ("Child"), My_POA_Manager, Policies)); PortableServer.POAManager.Activate (PortableServer.POA.Get_The_POAManager (My_POA)); Output ("Created POA Child_POA", True); My_Child_POA := PortableServer.POA.Local_Ref (PortableServer.POA.Create_POA (My_POA, CORBA.To_CORBA_String ("My_POA"), My_Child_POA_Manager, Policies)); PortableServer.POAManager.Activate (PortableServer.POA.Get_The_POAManager (My_Child_POA)); Output ("Created POA Child_POA/My_POA", True); end; declare Srv : constant Echo.Impl.Object_Acc := new Echo.Impl.Object; Srv2 : constant Echo.Impl.Object_Acc := new Echo.Impl.Object; Id : constant PortableServer.ObjectId := PortableServer.String_To_ObjectId ("123"); Ref : CORBA.Object.Ref; begin PortableServer.POA.Activate_Object_With_Id (My_Child_POA, Id, PortableServer.Servant (Srv)); Output ("Activate_Object_With_Id", True); Ref := Servant_To_Reference (My_Child_POA, PortableServer.Servant (Srv)); Output ("Servant_To_Reference", True); begin declare Id : constant PortableServer.ObjectId := Reference_To_Id (Root_POA, Ref); pragma Unreferenced (Id); begin Output ("Reference_To_Id raised " & "PortableServer.POA.WrongAdapter", False); end; exception when PortableServer.POA.WrongAdapter => Output ("Reference_To_Id raised " & "PortableServer.POA.WrongAdapter", True); when E : others => Output ("Reference_To_Id raised wrong exception: " & Ada.Exceptions.Exception_Name (E), False); end; begin PortableServer.POA.Activate_Object_With_Id (My_Child_POA, Id, PortableServer.Servant (Srv)); Output ("Activate_Object_With_Id: same Id, Servant " & "raised ServantAlreadyActive", False); exception when PortableServer.POA.ServantAlreadyActive => Output ("Activate_Object_With_Id: same Id, Servant " & "raised ServantAlreadyActive", True); end; begin PortableServer.POA.Activate_Object_With_Id (My_Child_POA, Id, PortableServer.Servant (Srv2)); Output ("Activate_Object_With_Id with the same Id " & "raised no exception", False); exception when PortableServer.POA.ObjectAlreadyActive => Output ("Activate_Object_With_Id with the same Id " & "raised ObjectAlreadyActive", True); end; Ref := Servant_To_Reference (My_Child_POA, PortableServer.Servant (Srv)); Output ("Servant_To_Reference", True); begin declare Id : constant PortableServer.ObjectId := Reference_To_Id (Root_POA, Ref); pragma Unreferenced (Id); begin Output ("Reference_To_Id raised " & "PortableServer.POA.WrongAdapter", False); end; exception when PortableServer.POA.WrongAdapter => Output ("Reference_To_Id raised " & "PortableServer.POA.WrongAdapter", True); when E : others => Output ("Reference_To_Id raised wrong exception: " & Ada.Exceptions.Exception_Name (E), False); end; declare Oid : constant PortableServer.ObjectId := Reference_To_Id (My_Child_POA, Ref); begin Output ("Reference_To_Id raised no exception", True); Ada.Text_IO.Put_Line ("OID: " & PortableServer.ObjectId_To_String (Oid)); Output ("OID is correct", Id = Oid); exception when others => Output ("Reference_To_Id raised an exception", False); end; end; -- Set up My_POA with MULTIPLE_ID policy declare Id_Uniqueness : constant CORBA.Policy.Ref := CORBA.Policy.Ref (PortableServer.POA.Create_Id_Uniqueness_Policy (PortableServer.MULTIPLE_ID)); Id_Assignment : constant CORBA.Policy.Ref := CORBA.Policy.Ref (PortableServer.POA.Create_Id_Assignment_Policy (PortableServer.USER_ID)); Activation : constant CORBA.Policy.Ref := CORBA.Policy.Ref (PortableServer.POA.Create_Implicit_Activation_Policy (PortableServer.NO_IMPLICIT_ACTIVATION)); Processing : constant CORBA.Policy.Ref := CORBA.Policy.Ref (PortableServer.POA.Create_Request_Processing_Policy (PortableServer.USE_DEFAULT_SERVANT)); Policies : CORBA.Policy.PolicyList; begin PortableServer.POAManager.Activate (PortableServer.POA.Get_The_POAManager (Root_POA)); CORBA.Policy.IDL_SEQUENCE_Policy.Append (Policies, Id_Uniqueness); CORBA.Policy.IDL_SEQUENCE_Policy.Append (Policies, Id_Assignment); CORBA.Policy.IDL_SEQUENCE_Policy.Append (Policies, Activation); CORBA.Policy.IDL_SEQUENCE_Policy.Append (Policies, Processing); My_POA := PortableServer.POA.Local_Ref (PortableServer.POA.Create_POA (Root_POA, CORBA.To_CORBA_String ("My_POA_2"), PortableServer.POA.Get_The_POAManager (Root_POA), Policies)); PortableServer.POA.Set_Servant (My_POA, new Echo.Impl.Object); end; declare Oid_1 : PortableServer.ObjectId; My_Ref : CORBA.Object.Ref; begin PortableServer.Append (Oid_1, CORBA.Octet'(1)); My_Ref := PortableServer.POA.Create_Reference_With_Id (My_POA, Oid_1, CORBA.To_CORBA_String (Echo.Repository_Id)); Oid_1 := PortableServer.POA.Reference_To_Id (My_POA, My_Ref); Success := True; exception when E : others => Put_Line ("POA::reference_to_id test raised " & Ada.Exceptions.Exception_Information (E)); Success := False; end; PolyORB.Utils.Report.Output ("Reference_To_Id (multiple id)", Success); end Test_OID; end Test000_Setup; polyorb-2.8~20110207.orig/testsuite/corba/portableserver/local.gpr0000644000175000017500000000072311750740340024366 0ustar xavierxavierwith "polyorb", "polyorb_test_common"; project local is Dir := external ("Test_Dir"); Obj_Dir := PolyORB_Test_Common.Build_Dir & Dir; for Object_Dir use Obj_Dir; for Source_Dirs use (Obj_Dir, PolyORB_Test_Common.Source_Dir & Dir); package Compiler is for Default_Switches ("Ada") use PolyORB_Test_Common.Compiler'Default_Switches ("Ada"); end Compiler; for Main use ("test000.adb", "test001.adb", "test002.adb"); end local; polyorb-2.8~20110207.orig/testsuite/corba/portableserver/test_job.ads0000644000175000017500000000421011750740340025057 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- T E S T _ J O B -- -- -- -- S p e c -- -- -- -- Copyright (C) 2003 Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by ACT Europe. -- -- (email: sales@act-europe.fr) -- -- -- ------------------------------------------------------------------------------ with Echo; package Test_Job is procedure Run_Job; procedure Run_Job_Wait; Global_Obj_Ref : Echo.Ref; end Test_Job; polyorb-2.8~20110207.orig/testsuite/corba/portableserver/test.idl0000644000175000017500000000005111750740340024225 0ustar xavierxavier interface Test { void proc (); }; polyorb-2.8~20110207.orig/testsuite/corba/portableserver/test-impl.adb0000644000175000017500000000767311750740340025163 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- T E S T . I M P L -- -- -- -- B o d y -- -- -- -- Copyright (C) 2005-2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with PortableServer.Current; with PortableServer.POA; with Test.Skel; pragma Warnings (Off, Test.Skel); with Test_Globals; package body Test.Impl is use CORBA.Object; use PortableServer; use PortableServer.Current; use PortableServer.POA; use Test_Globals; ---------- -- Proc -- ---------- procedure Proc (Self : access Object) is pragma Unreferenced (Self); begin -- PortableServer::Current::get_poa test declare Aux : PortableServer.POA.Local_Ref; begin begin Aux := PortableServer.POA.Convert.To_Ref (Get_POA (Test_Current)); if not Is_Equivalent (Test_POA, Aux) then Get_POA_Success := False; end if; exception when others => Get_POA_Success := False; end; end; -- PortableServer::Current::get_reference test declare Aux : CORBA.Object.Ref; begin Aux := Get_Reference (Test_Current); if not Is_Equivalent (Aux, Test_Reference) then Get_Reference_Success := False; end if; exception when others => Get_Reference_Success := False; end; -- PortableServer::Current::get_servant test declare Aux : PortableServer.Servant; begin Aux := Get_Servant (Test_Current); if Aux /= Test_Servant then Get_Servant_Success := False; end if; exception when others => Get_Servant_Success := False; end; -- PortableServer::Current::get_object_id test declare Aux : PortableServer.ObjectId; begin Aux := Get_Object_Id (Test_Current); if Aux /= Test_Id then Get_Object_Id_Success := False; end if; exception when others => Get_Object_Id_Success := False; end; end Proc; end Test.Impl; polyorb-2.8~20110207.orig/testsuite/corba/portableserver/test002.adb0000644000175000017500000001517511750740340024442 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- T E S T 0 0 2 -- -- -- -- B o d y -- -- -- -- Copyright (C) 2005-2007, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with CORBA.ORB; with CORBA.Object; with CORBA.Policy; with PortableServer.Current.Helper; with PortableServer.POA.Helper; with PortableServer.POAManager; with Test.Helper; with Test.Impl; with Test_Globals; with PolyORB.Setup.No_Tasking_Server; pragma Warnings (Off, PolyORB.Setup.No_Tasking_Server); with PolyORB.Utils.Report; procedure Test002 is use PolyORB.Utils.Report; use PortableServer.Current; use Test; use Test_Globals; procedure Test_Get_POA; procedure Test_Get_Reference; procedure Test_Get_Object_Id; procedure Test_Get_Servant; ------------------ -- Test_Get_POA -- ------------------ procedure Test_Get_POA is pragma Warnings (On); -- WAG:GCC3.4.4 Aux : PortableServer.POA.Local_Ref; pragma Unreferenced (Aux); pragma Warnings (Off); -- WAG:GCC3.4.4 begin Aux := PortableServer.POA.Convert.To_Ref (Get_POA (Test_Current)); Get_POA_Success := False; exception when PortableServer.Current.NoContext => null; when others => Get_POA_Success := False; end Test_Get_POA; ------------------------ -- Test_Get_Reference -- ------------------------ procedure Test_Get_Reference is pragma Warnings (On); -- WAG:GCC3.4.4 Aux : CORBA.Object.Ref; pragma Unreferenced (Aux); pragma Warnings (Off); -- WAG:GCC3.4.4 begin Aux := Get_Reference (Test_Current); Get_Reference_Success := False; exception when NoContext => null; when others => Get_Reference_Success := False; end Test_Get_Reference; ------------------------ -- Test_Get_Object_Id -- ------------------------ procedure Test_Get_Object_Id is pragma Warnings (On); -- WAG:GCC3.4.4 Aux : PortableServer.ObjectId; pragma Unreferenced (Aux); pragma Warnings (Off); -- WAG:GCC3.4.4 begin Aux := Get_Object_Id (Test_Current); Get_Object_Id_Success := False; exception when NoContext => null; when others => Get_Object_Id_Success := False; end Test_Get_Object_Id; ---------------------- -- Test_Get_Servant -- ---------------------- procedure Test_Get_Servant is Aux : PortableServer.Servant; pragma Unreferenced (Aux); begin Aux := Get_Servant (Test_Current); Get_Servant_Success := False; exception when NoContext => null; when others => Get_Servant_Success := False; end Test_Get_Servant; begin New_Test ("PortableServer::Current operations"); declare Argv : CORBA.ORB.Arg_List := CORBA.ORB.Command_Line_Arguments; begin CORBA.ORB.Init (CORBA.ORB.To_CORBA_String ("ORB"), Argv); end; declare Root_POA : PortableServer.POA.Local_Ref; Policies : CORBA.Policy.PolicyList; begin -- Retrieve Root POA Root_POA := PortableServer.POA.Helper.To_Local_Ref (CORBA.ORB.Resolve_Initial_References (CORBA.ORB.To_CORBA_String ("RootPOA"))); Test_POA := PortableServer.POA.Local_Ref (PortableServer.POA.Create_POA (Root_POA, CORBA.To_CORBA_String ("TestPOA"), PortableServer.POA.Get_The_POAManager (Root_POA), Policies)); PortableServer.POAManager.Activate (PortableServer.POA.Get_The_POAManager (Root_POA)); -- Set up new object Test_Servant := new Test.Impl.Object; Test_Id := PortableServer.POA.Activate_Object (Test_POA, Test_Servant); Test_Reference := Test.Helper.To_Ref (PortableServer.POA.Servant_To_Reference (Test_POA, Test_Servant)); end; -- Retrieve POA Current begin Test_Current := PortableServer.Current.Helper.To_Local_Ref (CORBA.ORB.Resolve_Initial_References (CORBA.ORB.To_CORBA_String ("POACurrent"))); exception when others => null; end; Output ("Retrieve PortableServer::Current", not Is_Nil (Test_Current)); -- Reset test state Get_POA_Success := True; Get_Reference_Success := True; Get_Object_Id_Success := True; Get_Servant_Success := True; Test_Get_POA; Test_Get_Reference; Test_Get_Object_Id; Test_Get_Servant; proc (Test_Reference); Test_Get_POA; Test_Get_Reference; Test_Get_Object_Id; Test_Get_Servant; Output ("PortableServer::Current::get_poa", Get_POA_Success); Output ("PortableServer::Current::get_reference", Get_Reference_Success); Output ("PortableServer::Current::get_object_id", Get_Object_Id_Success); Output ("PortableServer::Current::get_servant", Get_Servant_Success); End_Report; end Test002; polyorb-2.8~20110207.orig/testsuite/corba/location_forwarding/0000755000175000017500000000000011750740340023553 5ustar xavierxavierpolyorb-2.8~20110207.orig/testsuite/corba/location_forwarding/test000/0000755000175000017500000000000011750740340024752 5ustar xavierxavierpolyorb-2.8~20110207.orig/testsuite/corba/location_forwarding/test000/test_servantactivator-impl.adb0000644000175000017500000000656011750740340033026 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- T E S T _ S E R V A N T A C T I V A T O R . I M P L -- -- -- -- B o d y -- -- -- -- Copyright (C) 2005-2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with CORBA.Object; with PortableServer.Helper; with PortableServer.ServantManager; with Test_Globals; package body Test_ServantActivator.Impl is --------------- -- Incarnate -- --------------- function Incarnate (Self : access Object; Oid : PortableServer.ObjectId; Adapter : PortableServer.POA_Forward.Ref) return PortableServer.Servant is pragma Unreferenced (Self, Oid, Adapter); begin PortableServer.Helper.Raise_ForwardRequest (PortableServer.ForwardRequest_Members' (Forward_Reference => CORBA.Object.Ref (Test_Globals.Object_1))); return null; end Incarnate; ---------- -- Is_A -- ---------- function Is_A (Self : not null access Object; Logical_Type_Id : Standard.String) return Boolean is pragma Unreferenced (Self); begin return CORBA.Is_Equivalent (Logical_Type_Id, Test_ServantActivator.Repository_Id) or else CORBA.Is_Equivalent (Logical_Type_Id, PortableServer.ServantActivator.Repository_Id) or else CORBA.Is_Equivalent (Logical_Type_Id, PortableServer.ServantManager.Repository_Id) or else CORBA.Is_Equivalent (Logical_Type_Id, "IDL:omg.org/CORBA/Object:1.0"); end Is_A; end Test_ServantActivator.Impl; polyorb-2.8~20110207.orig/testsuite/corba/location_forwarding/test000/Makefile.local0000644000175000017500000000015611750740340027505 0ustar xavierxavier${current_dir}test_interface.idl-stamp: idlac_flags := ${test_target}: ${current_dir}test_interface.idl-stamp polyorb-2.8~20110207.orig/testsuite/corba/location_forwarding/test000/test_interface-impl.adb0000644000175000017500000000475711750740340031375 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- T E S T _ I N T E R F A C E . I M P L -- -- -- -- B o d y -- -- -- -- Copyright (C) 2004-2008, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with Test_Interface.Skel; pragma Warnings (Off, Test_Interface.Skel); package body Test_Interface.Impl is ---------- -- Init -- ---------- procedure Init (Self : access Object; Name : String) is begin Self.Name := CORBA.To_CORBA_String (Name); end Init; ---------- -- Name -- ---------- function Name (Self : access Object) return CORBA.String is begin return Self.Name; end Name; end Test_Interface.Impl; polyorb-2.8~20110207.orig/testsuite/corba/location_forwarding/test000/test_servantactivator-impl.ads0000644000175000017500000000520711750740340033044 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- T E S T _ S E R V A N T A C T I V A T O R . I M P L -- -- -- -- S p e c -- -- -- -- Copyright (C) 2005-2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with PortableServer.ServantActivator.Impl; package Test_ServantActivator.Impl is type Object is new PortableServer.ServantActivator.Impl.Object with private; type Object_Ptr is access all Object'Class; private type Object is new PortableServer.ServantActivator.Impl.Object with null record; function Is_A (Self : not null access Object; Logical_Type_Id : Standard.String) return Boolean; function Incarnate (Self : access Object; Oid : PortableServer.ObjectId; Adapter : PortableServer.POA_Forward.Ref) return PortableServer.Servant; end Test_ServantActivator.Impl; polyorb-2.8~20110207.orig/testsuite/corba/location_forwarding/test000/test_interface.idl0000644000175000017500000000023611750740340030444 0ustar xavierxavier import ::PortableServer; interface Test_Interface { string Name (); }; local interface Test_ServantActivator : PortableServer::ServantActivator { }; polyorb-2.8~20110207.orig/testsuite/corba/location_forwarding/test000/test000.adb0000644000175000017500000001450311750740340026624 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- T E S T 0 0 0 -- -- -- -- B o d y -- -- -- -- Copyright (C) 2004-2007, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with Ada.Exceptions; with Ada.Text_IO; with CORBA.Object; with CORBA.ORB; with CORBA.Policy; with PolyORB.Setup.Thread_Pool_Server; pragma Warnings (Off, PolyORB.Setup.Thread_Pool_Server); with PolyORB.Utils.Report; with PolyORB.Smart_Pointers; with PortableServer.POA.Helper; with PortableServer.POAManager; with Test_Globals; with Test_Interface.Helper; with Test_Interface.Impl; with Test_ServantActivator.Impl; procedure Test000 is Root_POA : PortableServer.POA.Local_Ref; My_POA : PortableServer.POA.Local_Ref; begin PolyORB.Utils.Report.New_Test ("Local ServantActivator Location Forwarding"); CORBA.ORB.Initialize ("ORB"); Root_POA := PortableServer.POA.Helper.To_Local_Ref (CORBA.ORB.Resolve_Initial_References (CORBA.ORB.To_CORBA_String ("RootPOA"))); PortableServer.POAManager.Activate (PortableServer.POA.Get_The_POAManager (Root_POA)); declare use CORBA.Policy.IDL_SEQUENCE_Policy; Implicit_Activation_Policy : constant CORBA.Policy.Ref := CORBA.Policy.Ref (PortableServer.POA.Create_Implicit_Activation_Policy (PortableServer.NO_IMPLICIT_ACTIVATION)); Id_Assignment_Policy : constant CORBA.Policy.Ref := CORBA.Policy.Ref (PortableServer.POA.Create_Id_Assignment_Policy (PortableServer.USER_ID)); Request_Processing_Policy : constant CORBA.Policy.Ref := CORBA.Policy.Ref (PortableServer.POA.Create_Request_Processing_Policy (PortableServer.USE_SERVANT_MANAGER)); Policies : CORBA.Policy.PolicyList; Obj : constant Test_ServantActivator.Impl.Object_Ptr := new Test_ServantActivator.Impl.Object; Ref : Test_ServantActivator.Local_Ref; begin Append (Policies, Implicit_Activation_Policy); Append (Policies, Id_Assignment_Policy); Append (Policies, Request_Processing_Policy); My_POA := PortableServer.POA.Local_Ref (PortableServer.POA.Create_POA (Root_POA, CORBA.To_CORBA_String ("My_POA"), PortableServer.POA.Get_The_POAManager (Root_POA), Policies)); Test_ServantActivator.Set (Ref, PolyORB.Smart_Pointers.Entity_Ptr (Obj)); PortableServer.POA.Set_Servant_Manager (My_POA, Ref); PortableServer.POAManager.Activate (PortableServer.POA.Get_The_POAManager (My_POA)); end; declare Ptr : Test_Interface.Impl.Object_Ptr; begin Ptr := new Test_Interface.Impl.Object; Test_Interface.Impl.Init (Ptr, "Hello, world!"); declare Id : constant PortableServer.ObjectId := PortableServer.POA.Activate_Object (Root_POA, PortableServer.Servant (Ptr)); pragma Warnings (Off, Id); begin Test_Globals.Object_1 := Test_Interface.Helper.To_Ref (PortableServer.POA.Servant_To_Reference (Root_POA, PortableServer.Servant (Ptr))); end; end; declare Ref : constant CORBA.Object.Ref := PortableServer.POA.Create_Reference_With_Id (My_POA, PortableServer.String_To_ObjectId ("dead"), CORBA.To_CORBA_String (Test_Interface.Repository_Id)); begin Test_Globals.Object_2 := Test_Interface.Helper.To_Ref (Ref); end; for J in 1 .. 10 loop declare use type CORBA.String; begin if Test_Interface.Name (Test_Globals.Object_2) = "Hello, world!" then PolyORB.Utils.Report.Output ("ServantManager location forwarding (pass" & Integer'Image (J) & ")", True); else PolyORB.Utils.Report.Output ("ServantManager location forwarding (pass" & Integer'Image (J) & ")", False); end if; exception when others => PolyORB.Utils.Report.Output ("ServantManager location forwarding (pass" & Integer'Image (J) & ")", False); end; end loop; CORBA.ORB.Shutdown (False); PolyORB.Utils.Report.End_Report; exception when E : others => PolyORB.Utils.Report.Output ("Got fatal exception ", False); Ada.Text_IO.Put_Line (Ada.Exceptions.Exception_Information (E)); CORBA.ORB.Shutdown (False); PolyORB.Utils.Report.End_Report; end Test000; polyorb-2.8~20110207.orig/testsuite/corba/location_forwarding/test000/test_globals.ads0000644000175000017500000000421511750740340030127 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- T E S T _ G L O B A L S -- -- -- -- S p e c -- -- -- -- Copyright (C) 2004 Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by ACT Europe. -- -- (email: sales@act-europe.fr) -- -- -- ------------------------------------------------------------------------------ with Test_Interface; package Test_Globals is Object_1 : Test_Interface.Ref; Object_2 : Test_Interface.Ref; end Test_Globals; polyorb-2.8~20110207.orig/testsuite/corba/location_forwarding/test000/local.gpr0000644000175000017500000000066511750740340026565 0ustar xavierxavierwith "polyorb", "polyorb_test_common"; project local is Dir := external ("Test_Dir"); Obj_Dir := PolyORB_Test_Common.Build_Dir & Dir; for Object_Dir use Obj_Dir; for Source_Dirs use (Obj_Dir, PolyORB_Test_Common.Source_Dir & Dir); package Compiler is for Default_Switches ("Ada") use PolyORB_Test_Common.Compiler'Default_Switches ("Ada"); end Compiler; for Main use ("test000.adb"); end local; polyorb-2.8~20110207.orig/testsuite/corba/location_forwarding/test000/test_interface-impl.ads0000644000175000017500000000472411750740340031410 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- T E S T _ I N T E R F A C E . I M P L -- -- -- -- S p e c -- -- -- -- Copyright (C) 2004-2008, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by ACT Europe. -- -- (email: sales@act-europe.fr) -- -- -- ------------------------------------------------------------------------------ with CORBA; with PortableServer; package Test_Interface.Impl is type Object is new PortableServer.Servant_Base with private; type Object_Ptr is access all Object'Class; function Name (Self : access Object) return CORBA.String; procedure Init (Self : access Object; Name : String); private type Object is new PortableServer.Servant_Base with record Name : CORBA.String; end record; end Test_Interface.Impl; polyorb-2.8~20110207.orig/testsuite/corba/location_forwarding/test001/0000755000175000017500000000000011750740340024753 5ustar xavierxavierpolyorb-2.8~20110207.orig/testsuite/corba/location_forwarding/test001/test001_client.adb0000644000175000017500000000636611750740340030174 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- T E S T 0 0 1 _ C L I E N T -- -- -- -- B o d y -- -- -- -- Copyright (C) 2004 Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by ACT Europe. -- -- (email: sales@act-europe.fr) -- -- -- ------------------------------------------------------------------------------ with Ada.Command_Line; with CORBA.ORB; with PolyORB.Setup.Client; pragma Warnings (Off, PolyORB.Setup.Client); with PolyORB.Utils.Report; with Test_Interface; procedure Test001_Client is Object : Test_Interface.Ref; begin PolyORB.Utils.Report.New_Test ("GIOP ServantActivator Location Forwarding"); CORBA.ORB.Initialize ("ORB"); CORBA.ORB.String_To_Object (CORBA.To_CORBA_String (Ada.Command_Line.Argument (1)), Object); for J in 1 .. 10 loop declare use type CORBA.String; begin if Test_Interface.Name (Object) = "Hello, world!" then PolyORB.Utils.Report.Output ("ServantManager location forwarding (pass" & Integer'Image (J) & ")", True); else PolyORB.Utils.Report.Output ("ServantManager location forwarding (pass" & Integer'Image (J) & ")", False); end if; exception when others => PolyORB.Utils.Report.Output ("ServantManager location forwarding (pass" & Integer'Image (J) & ")", False); end; end loop; CORBA.ORB.Shutdown (False); PolyORB.Utils.Report.End_Report; end Test001_Client; polyorb-2.8~20110207.orig/testsuite/corba/location_forwarding/test001/test_servantactivator-impl.adb0000644000175000017500000000656111750740340033030 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- T E S T _ S E R V A N T A C T I V A T O R . I M P L -- -- -- -- B o d y -- -- -- -- Copyright (C) 2005-2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with CORBA.Object; with PortableServer.Helper; with PortableServer.ServantManager; with Test_Globals; package body Test_ServantActivator.Impl is --------------- -- Incarnate -- --------------- function Incarnate (Self : access Object; Oid : PortableServer.ObjectId; Adapter : PortableServer.POA_Forward.Ref) return PortableServer.Servant is pragma Unreferenced (Self, Oid, Adapter); begin PortableServer.Helper.Raise_ForwardRequest (PortableServer.ForwardRequest_Members' (Forward_Reference => CORBA.Object.Ref (Test_Globals.Object_1))); return null; end Incarnate; ---------- -- Is_A -- ---------- function Is_A (Self : not null access Object; Logical_Type_Id : Standard.String) return Boolean is pragma Unreferenced (Self); begin return CORBA.Is_Equivalent (Logical_Type_Id, Test_ServantActivator.Repository_Id) or else CORBA.Is_Equivalent (Logical_Type_Id, PortableServer.ServantActivator.Repository_Id) or else CORBA.Is_Equivalent (Logical_Type_Id, PortableServer.ServantManager.Repository_Id) or else CORBA.Is_Equivalent (Logical_Type_Id, "IDL:omg.org/CORBA/Object:1.0"); end Is_A; end Test_ServantActivator.Impl; polyorb-2.8~20110207.orig/testsuite/corba/location_forwarding/test001/Makefile.local0000644000175000017500000000015611750740340027506 0ustar xavierxavier${current_dir}test_interface.idl-stamp: idlac_flags := ${test_target}: ${current_dir}test_interface.idl-stamp polyorb-2.8~20110207.orig/testsuite/corba/location_forwarding/test001/test_interface-impl.adb0000644000175000017500000000475711750740340031376 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- T E S T _ I N T E R F A C E . I M P L -- -- -- -- B o d y -- -- -- -- Copyright (C) 2004-2008, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with Test_Interface.Skel; pragma Warnings (Off, Test_Interface.Skel); package body Test_Interface.Impl is ---------- -- Init -- ---------- procedure Init (Self : access Object; Name : String) is begin Self.Name := CORBA.To_CORBA_String (Name); end Init; ---------- -- Name -- ---------- function Name (Self : access Object) return CORBA.String is begin return Self.Name; end Name; end Test_Interface.Impl; polyorb-2.8~20110207.orig/testsuite/corba/location_forwarding/test001/test001_server.adb0000644000175000017500000001255011750740340030214 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- T E S T 0 0 1 _ S E R V E R -- -- -- -- B o d y -- -- -- -- Copyright (C) 2004-2007, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with Ada.Text_IO; with CORBA.Object; with CORBA.ORB; with CORBA.Policy; with PolyORB.Setup.Thread_Pool_Server; pragma Warnings (Off, PolyORB.Setup.Thread_Pool_Server); with PortableServer.POA.Helper; with PortableServer.POAManager; with PolyORB.Smart_Pointers; with Test_Globals; with Test_Interface.Helper; with Test_Interface.Impl; with Test_ServantActivator.Impl; procedure Test001_Server is begin CORBA.ORB.Initialize ("ORB"); declare Root_POA : PortableServer.POA.Local_Ref; My_POA : PortableServer.POA.Local_Ref; use CORBA.Policy.IDL_SEQUENCE_Policy; Implicit_Activation_Policy : constant CORBA.Policy.Ref := CORBA.Policy.Ref (PortableServer.POA.Create_Implicit_Activation_Policy (PortableServer.NO_IMPLICIT_ACTIVATION)); Id_Assignment_Policy : constant CORBA.Policy.Ref := CORBA.Policy.Ref (PortableServer.POA.Create_Id_Assignment_Policy (PortableServer.USER_ID)); Request_Processing_Policy : constant CORBA.Policy.Ref := CORBA.Policy.Ref (PortableServer.POA.Create_Request_Processing_Policy (PortableServer.USE_SERVANT_MANAGER)); Policies : CORBA.Policy.PolicyList; Obj : constant Test_ServantActivator.Impl.Object_Ptr := new Test_ServantActivator.Impl.Object; Ref : Test_ServantActivator.Local_Ref; begin Root_POA := PortableServer.POA.Helper.To_Local_Ref (CORBA.ORB.Resolve_Initial_References (CORBA.ORB.To_CORBA_String ("RootPOA"))); PortableServer.POAManager.Activate (PortableServer.POA.Get_The_POAManager (Root_POA)); Append (Policies, Implicit_Activation_Policy); Append (Policies, Id_Assignment_Policy); Append (Policies, Request_Processing_Policy); My_POA := PortableServer.POA.Local_Ref (PortableServer.POA.Create_POA (Root_POA, CORBA.To_CORBA_String ("My_POA"), PortableServer.POA.Get_The_POAManager (Root_POA), Policies)); Test_ServantActivator.Set (Ref, PolyORB.Smart_Pointers.Entity_Ptr (Obj)); PortableServer.POA.Set_Servant_Manager (My_POA, Ref); PortableServer.POAManager.Activate (PortableServer.POA.Get_The_POAManager (My_POA)); declare Ptr : Test_Interface.Impl.Object_Ptr; begin Ptr := new Test_Interface.Impl.Object; Test_Interface.Impl.Init (Ptr, "Hello, world!"); declare Id : constant PortableServer.ObjectId := PortableServer.POA.Activate_Object (Root_POA, PortableServer.Servant (Ptr)); pragma Warnings (Off, Id); begin Test_Globals.Object_1 := Test_Interface.Helper.To_Ref (PortableServer.POA.Servant_To_Reference (Root_POA, PortableServer.Servant (Ptr))); end; end; declare Ref : constant CORBA.Object.Ref := PortableServer.POA.Create_Reference_With_Id (My_POA, PortableServer.String_To_ObjectId ("dead"), CORBA.To_CORBA_String (Test_Interface.Repository_Id)); begin Test_Globals.Object_2 := Test_Interface.Helper.To_Ref (Ref); Ada.Text_IO.Put_Line ("'" & CORBA.To_Standard_String (CORBA.ORB.Object_To_String (Ref)) & "'"); CORBA.ORB.Run; end; end; end Test001_Server; polyorb-2.8~20110207.orig/testsuite/corba/location_forwarding/test001/test_servantactivator-impl.ads0000644000175000017500000000520711750740340033045 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- T E S T _ S E R V A N T A C T I V A T O R . I M P L -- -- -- -- S p e c -- -- -- -- Copyright (C) 2005-2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with PortableServer.ServantActivator.Impl; package Test_ServantActivator.Impl is type Object is new PortableServer.ServantActivator.Impl.Object with private; type Object_Ptr is access all Object'Class; private type Object is new PortableServer.ServantActivator.Impl.Object with null record; function Is_A (Self : not null access Object; Logical_Type_Id : Standard.String) return Boolean; function Incarnate (Self : access Object; Oid : PortableServer.ObjectId; Adapter : PortableServer.POA_Forward.Ref) return PortableServer.Servant; end Test_ServantActivator.Impl; polyorb-2.8~20110207.orig/testsuite/corba/location_forwarding/test001/test_interface.idl0000644000175000017500000000023611750740340030445 0ustar xavierxavier import ::PortableServer; interface Test_Interface { string Name (); }; local interface Test_ServantActivator : PortableServer::ServantActivator { }; polyorb-2.8~20110207.orig/testsuite/corba/location_forwarding/test001/test_globals.ads0000644000175000017500000000421511750740340030130 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- T E S T _ G L O B A L S -- -- -- -- S p e c -- -- -- -- Copyright (C) 2004 Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by ACT Europe. -- -- (email: sales@act-europe.fr) -- -- -- ------------------------------------------------------------------------------ with Test_Interface; package Test_Globals is Object_1 : Test_Interface.Ref; Object_2 : Test_Interface.Ref; end Test_Globals; polyorb-2.8~20110207.orig/testsuite/corba/location_forwarding/test001/local.gpr0000644000175000017500000000072211750740340026560 0ustar xavierxavierwith "polyorb", "polyorb_test_common"; project local is Dir := external ("Test_Dir"); Obj_Dir := PolyORB_Test_Common.Build_Dir & Dir; for Object_Dir use Obj_Dir; for Source_Dirs use (Obj_Dir, PolyORB_Test_Common.Source_Dir & Dir); package Compiler is for Default_Switches ("Ada") use PolyORB_Test_Common.Compiler'Default_Switches ("Ada"); end Compiler; for Main use ("test001_server.adb", "test001_client.adb"); end local; polyorb-2.8~20110207.orig/testsuite/corba/location_forwarding/test001/test_interface-impl.ads0000644000175000017500000000472411750740340031411 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- T E S T _ I N T E R F A C E . I M P L -- -- -- -- S p e c -- -- -- -- Copyright (C) 2004-2008, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by ACT Europe. -- -- (email: sales@act-europe.fr) -- -- -- ------------------------------------------------------------------------------ with CORBA; with PortableServer; package Test_Interface.Impl is type Object is new PortableServer.Servant_Base with private; type Object_Ptr is access all Object'Class; function Name (Self : access Object) return CORBA.String; procedure Init (Self : access Object; Name : String); private type Object is new PortableServer.Servant_Base with record Name : CORBA.String; end record; end Test_Interface.Impl; polyorb-2.8~20110207.orig/testsuite/corba/interop/0000755000175000017500000000000011750740340021201 5ustar xavierxavierpolyorb-2.8~20110207.orig/testsuite/corba/interop/java/0000755000175000017500000000000011750740340022122 5ustar xavierxavierpolyorb-2.8~20110207.orig/testsuite/corba/interop/java/README0000644000175000017500000000167211750740340023010 0ustar xavierxavierREADME for the PolyORB CORBA interoperability tests --------------------------------------------------- $Id: //droopi/main/examples/corba/all_types/interop/java/README#4 $ * Compatibility PolyORB has been (partially) successfully tested with - OpenORB 1.3.0 - Jonathan 3.0 alpha 10 * Compilation To compile these examples, you need to edit the makefile Makefile. to setup: - Java SDK and JRE; - Path to ORB jar files. Currently, the sources only compile for Jonathan, compiling for OpenORB requires little adaptation of implementation files. * Run the tests Type make run_dynserver -f Makefile. to run the DSI server; make run_dynclient -f Makefile. to run the DII client; The object IOR is stored in the `IOR` file and read _from this file_ by clients. * Compatibility note - OpenORB: the IDL file has been modified to accomodate bug in compilation process... - Jonathan: the union Java code seems buggy. polyorb-2.8~20110207.orig/testsuite/corba/interop/java/OpenORB/0000755000175000017500000000000011750740340023366 5ustar xavierxavierpolyorb-2.8~20110207.orig/testsuite/corba/interop/java/OpenORB/Makefile.OpenORB0000644000175000017500000000452511750740340026277 0ustar xavierxavier####################################################################### # $Id$ ####################################################################### # Shell setup DEL = rm -rf ####################################################################### # Java SDK and RE # (configured for Blackdown Java on Linux, v 1.4.1-01) JAVA = java JAVAC = javac CLASSPATH_FLAG = -classpath CLASSPATH = $(ORB_CLASSPATH):.:./..:./../common OPTIONS = -d . COMPILE = $(JAVAC) $(CLASSPATH_FLAG) $(CLASSPATH) $(OPTIONS) RUN = $(JAVA) $(CLASSPATH_FLAG) $(CLASSPATH) $(ORB_OPTIONS) ####################################################################### # Configuration for OpenORB 1.3.0 #OPENORB_JARPATH = OPENORB_JARPATH = $HOME/local/OpenORB-1.3.0/lib OPENORB = $(OPENORB_JARPATH)/openorb-1.3.0.jar OPENORB_TOOLS = $(OPENORB_JARPATH)/openorb_tools-1.3.0.jar LOGKIT = $(OPENORB_JARPATH)/logkit.jar AVALON = $(OPENORB_JARPATH)/avalon-framework.jar OPENORB_CLASSPATH = $(OPENORB):$(OPENORB_TOOLS):$(LOGKIT):$(AVALON):$(GENERATED_FILES) OPENORB_OPTIONS = OPENORB_GENERATED_FILES = ./generated OPENORB_IDL = $(RUN) org.openorb.compiler.IdlCompiler ####################################################################### # Generic rules .SUFFIXES: .SUFFIXES: .java .class .SUFFIXES: .idl .java.class: $(COMPILE) $< .idl: $(IDL) $< ####################################################################### # Define the ORB for which this makefile is configured # For OpenORB 1.3.0 ORB_CLASSPATH = $(OPENORB_CLASSPATH) ORB_OPTIONS = $(OPENORB_OPTIONS) GENERATED_FILES = $(OPENORB_GENERATED_FILES) IDL = $(OPENORB_IDL) ####################################################################### CLASS_FILES = DynSkeleton.class DynServer.class \ DynClient.class all: class idl : $(IDL_FILE:.idl=) DynClient.class: ../common/DynClient.java $(COMPILE) ../common/DynClient.java DynServer.class: ../common/DynServer.java $(COMPILE) ../common/DynServer.java DynSkeleton.class: ../common/DynSkeleton.java $(COMPILE) ../common/DynSkeleton.java class : $(CLASS_FILES:.java=.class) run_dynserver : DynServer.class $(RUN) DynServer run_dynclient : DynClient.class $(RUN) DynClient clean: $(DEL) *~ *\# IOR $(DEL) *.class veryclean: clean $(DEL) $(GENERATED_FILES) polyorb-2.8~20110207.orig/testsuite/corba/interop/java/Jonathan/0000755000175000017500000000000011750740340023664 5ustar xavierxavierpolyorb-2.8~20110207.orig/testsuite/corba/interop/java/Jonathan/Makefile.Jonathan0000644000175000017500000000524211750740340027070 0ustar xavierxavier####################################################################### # $Id$ ####################################################################### # Shell setup DEL = rm -rf ####################################################################### # Java SDK and RE # (configured for Blackdown Java on Linux, v 1.4.1-01) JAVA = java JAVAC = javac CLASSPATH_FLAG = -classpath CLASSPATH = $(ORB_CLASSPATH):.:./.. OPTIONS = -d . COMPILE = $(JAVAC) $(CLASSPATH_FLAG) $(CLASSPATH) $(OPTIONS) RUN = $(JAVA) $(CLASSPATH_FLAG) $(CLASSPATH) $(ORB_OPTIONS) ####################################################################### # Configuration for Jonathan 3.0 alpha 10 #JONATHAN_JARPATH = JONATHAN_JARPATH = $HOME/local/Jonathan_3_0_a10/libs JONATHAN = $(JONATHAN_JARPATH)/Jonathan_3_0_a10.jar KILIM = $(JONATHAN_JARPATH)/kilim.jar KILIM_TOOLS = $(JONATHAN_JARPATH)/kilim-tools.jar NANOXML = $(JONATHAN_JARPATH)/nanoxml-lite-2.2.1.jar JONATHAN_CLASSPATH =$(JONATHAN):$(KILIM):$(KILIM_TOOLS):$(NANOXML) JONATHAN_OPTION = \ -Dorg.omg.CORBA.ORBClass=org.objectweb.david.libs.binding.orbs.iiop.IIOPORB \ -Dorg.omg.CORBA.ORBSingletonClass=org.objectweb.david.libs.binding.orbs.ORBSingletonClass \ -Ddavid.naming.default_method=2 \ -Ddavid.naming.default_file=ns.ior JONATHAN_GENERATED_FILES = ./idl JONATHAN_IDL = $(RUN) org.objectweb.david.tools.idlcompiler.Idl2Java -p idl -poa ####################################################################### # Generic rules .SUFFIXES: .SUFFIXES: .java .class .SUFFIXES: .idl .java.class: $(COMPILE) $< .idl: $(IDL) $< ####################################################################### # Define the ORB for which this makefile is configured ORB_CLASSPATH = $(JONATHAN_CLASSPATH) ORB_OPTIONS = $(JONATHAN_OPTIONS) GENERATED_FILES = $(JONATHAN_GENERATED_FILES) IDL = $(JONATHAN_IDL) ####################################################################### IDL_FILE = all_types.idl CLASS_FILES = DynSkeleton.class DynServer.class \ DynClient.class all: class idl : $(IDL_FILE:.idl=) class : $(CLASS_FILES:.java=.class) DynClient.class: ../common/DynClient.java $(COMPILE) ../common/DynClient.java DynServer.class: ../common/DynServer.java $(COMPILE) ../common/DynServer.java DynSkeleton.class: ../common/DynSkeleton.java $(COMPILE) ../common/DynSkeleton.java run_server : Server.class $(RUN) Server run_client : Client.class $(RUN) Client run_dynserver : DynServer.class $(RUN) DynServer run_dynclient : DynClient.class $(RUN) DynClient clean: $(DEL) *~ *\# IOR $(DEL) *.class veryclean: clean $(DEL) $(GENERATED_FILES) polyorb-2.8~20110207.orig/testsuite/corba/interop/java/common/0000755000175000017500000000000011750740340023412 5ustar xavierxavierpolyorb-2.8~20110207.orig/testsuite/corba/interop/java/common/DynClient.java0000644000175000017500000000303211750740340026144 0ustar xavierxavier// Java DII 'echoULong' client, cf all_types.idl for more details. public class DynClient { public static void main( String [] args ) { org.omg.CORBA.ORB orb = org.omg.CORBA.ORB.init( args, null ) ; org.omg.CORBA.Object obj = null ; // Read the IOR from the `IOR` file. try { java.io.FileInputStream file = new java.io.FileInputStream( "IOR" ); java.io.InputStreamReader input = new java.io.InputStreamReader( file ); java.io.BufferedReader reader = new java.io.BufferedReader( input ); String ref = reader.readLine(); obj = orb.string_to_object( ref ) ; } catch ( java.io.IOException ex ) { ex.printStackTrace( ) ; System.exit( 0 ); } boolean pass = true; // Call the `unsigned long echoULong (unsigned long arg)` method. for (int j = 0; j < 10000; j++) { org.omg.CORBA.Request req = obj._request( "echoULong" ); org.omg.CORBA.Any param1 = req.add_in_arg( ); param1.insert_ulong( 123 ); org.omg.CORBA.TypeCode tc_return = orb.get_primitive_tc( org.omg.CORBA.TCKind.tk_ulong ); req.set_return_type( tc_return ); req.invoke(); java.lang.Exception exception = req.env().exception(); if ( exception != null ) { System.out.println ("Got an exception !"); return; } org.omg.CORBA.Any result = req.return_value(); pass = pass & (result.extract_ulong () == (long) 123); } // Output the result. System.out.println (pass); } } polyorb-2.8~20110207.orig/testsuite/corba/interop/java/common/Alltypes.java0000644000175000017500000000507711750740340026063 0ustar xavierxavierimport idl.*; public class Alltypes extends idl.all_typesPOA { public boolean echoBoolean(boolean arg) { return arg; } public short echoShort(short arg) { return arg; } public int echoLong(int arg) { return arg; } public short echoUShort(short arg) { return arg; } public int echoULong(int arg) { return arg; } public float echoFloat(float arg) { return arg; } public double echoDouble(double arg) { return arg; } public char echoChar(char arg) { return arg; } public byte echoOctet(byte arg) { return arg; } public String echoString(String arg) { return arg; } public idl.all_types echoRef(idl.all_types arg) { return arg; } public org.omg.CORBA.Object echoObject(org.omg.CORBA.Object arg) { return arg; } public idl.all_typesPackage.Color echoColor(idl.all_typesPackage.Color arg) { return arg; } public void testException(int arg) throws idl.all_typesPackage.my_exception { throw new idl.all_typesPackage.my_exception(arg); } public void testUnknownException(int arg) { int i = 2; int j = 0; int k = i/j; } public idl.all_typesPackage.myUnion echoUnion(idl.all_typesPackage.myUnion arg) { return arg; } public idl.all_typesPackage.myUnionEnumSwitch echoUnionEnumSwitch(idl.all_typesPackage.myUnionEnumSwitch arg) { return arg; } public int[] echoArray(int[] arg) { return arg; } public int[][] echoMatrix(int[][] arg) { return arg; } public int[][] echoBigMatrix(int[][] arg) { return arg; } public idl.all_typesPackage.simple_struct echoStruct(idl.all_typesPackage.simple_struct arg) { return arg; } public idl.all_typesPackage.array_struct echoArrayStruct(idl.all_typesPackage.array_struct arg) { return arg; } public idl.all_typesPackage.nested_struct echoNestedStruct(idl.all_typesPackage.nested_struct arg) { return arg; } public short[] echoUsequence(short[] arg) { return arg; } public short[] echoBsequence(short[] arg) { return arg; } public java.math.BigDecimal echoMoney(java.math.BigDecimal arg) { return arg; } int global_counter = 0; public int Counter() { return global_counter ++; } idl.all_typesPackage.Color global_color; public idl.all_typesPackage.Color myColor() { return global_color; } public void myColor(idl.all_typesPackage.Color value) { global_color = value; } } polyorb-2.8~20110207.orig/testsuite/corba/interop/java/common/Client.java0000644000175000017500000001242611750740340025500 0ustar xavierxavier// Java All Types static client, cf all_types.idl for more details public class Client { public static void main( String [] args ) { org.omg.CORBA.ORB orb = org.omg.CORBA.ORB.init( args, null ) ; org.omg.CORBA.Object obj = null ; // Read the IOR from the `IOR` file. try { java.io.FileInputStream file = new java.io.FileInputStream( "IOR" ); java.io.InputStreamReader input = new java.io.InputStreamReader( file ); java.io.BufferedReader reader = new java.io.BufferedReader( input ); String ref = reader.readLine(); obj = orb.string_to_object( ref ) ; } catch ( java.io.IOException ex ) { ex.printStackTrace( ) ; System.exit( 0 ); } boolean pass; // Narrow object reference. idl.all_types ato = idl.all_typesHelper.narrow (obj); // String type. String my_string = "Hello distributed World in Java"; System.out.println ("echoString " + my_string.equals(ato.echoString (my_string))); // Simple scalar types. int res; for (int i = 0; i < 10000; i++) res = ato.echoULong (456); System.out.println ("echoBoolean " + ato.echoBoolean (true)); System.out.println ("echoShort " + ((short) 123 == ato.echoShort ((short) 123))); System.out.println ("echoLong " + (456 == ato.echoLong (456))); System.out.println ("echoULong " + (456 == ato.echoULong (456))); System.out.println ("echoUShort " + ((short) 123 == ato.echoUShort ((short) 123))); System.out.println ("echoFloat " + ((float) 2.7 == ato.echoFloat ((float) 2.7))); System.out.println ("echoDouble " + (1.5 == ato.echoDouble (1.5))); System.out.println ("echoChar " + ('A' == ato.echoChar ('A'))); System.out.println ("echoOctet " + ((byte) 5 == ato.echoOctet ((byte) 5))); // Enum type. idl.all_typesPackage.Color col = idl.all_typesPackage.Color.Blue; System.out.println ("echoColor " + (idl.all_typesPackage.Color.Blue == ato.echoColor (col))); // Unbounded sequence. short u_seq[] = { 1, 2, 3, 4}; short res_u_seq[] = ato.echoUsequence (u_seq); pass = true; for (int i = 0; i < 4; i++) pass = pass & (res_u_seq[i] == u_seq[i]); System.out.println ("echoUsequence " + pass); // Bounded sequence. short b_seq[] = { 1, 2, 3, 4}; short res_b_seq[] = ato.echoUsequence (b_seq); pass = true; for (int i = 0; i < 4; i++) pass = pass & (res_b_seq[i] == b_seq[i]); System.out.println ("echoBsequence " + pass); // Simple struct. idl.all_typesPackage.simple_struct simple_s = new idl.all_typesPackage.simple_struct (123, "Hello World!\n"); idl.all_typesPackage.simple_struct res_simple_s = ato.echoStruct (simple_s); pass = (simple_s.a == res_simple_s.a) && (simple_s.s.equals(res_simple_s.s)); System.out.println ("echoStruct " + pass); // Nested struct. idl.all_typesPackage.nested_struct nested_s = new idl.all_typesPackage.nested_struct (simple_s); idl.all_typesPackage.nested_struct res_nested_s = ato.echoNestedStruct (nested_s); pass = (nested_s.ns.a == res_nested_s.ns.a) && (nested_s.ns.s.equals (res_nested_s.ns.s)); System.out.println ("echoNestedStruct " + pass); // Object ref. idl.all_types res_obj = ato.echoRef (ato); // pass = org.omg.CORBA.portable.Delegate.is_equivalent(res_obj, ato); // XXX how to test this ? System.out.println ("echoRef " + true); // Union. idl.all_typesPackage.myUnion union_t = new idl.all_typesPackage.myUnion(); union_t.Counter (4331); // idl.all_typesPackage.myUnion res_union_t = ato.echoUnion (union_t); // System.out.println ("echoUnion " + (res_union_t.Counter() == 4331)); // Union switch. idl.all_typesPackage.myUnionEnumSwitch union_es_t = new idl.all_typesPackage.myUnionEnumSwitch(); union_es_t.foo (4331); // idl.all_typesPackage.myUnionEnumSwitch res_union_es_t // = ato.echoUnionEnumSwitch (union_es_t); //System.out.println ("echoUnionEnumSwitch " + (res_union_es_t.foo() == 4331)); // Simple array. int simple_a[] = {1, 2, 3, 4, 5}; int res_simple_a[] = ato.echoArray(simple_a); pass = true; for (int i = 0; i < 5 ; i++) pass = pass && (simple_a[i] == res_simple_a[i]); System.out.println ("echoArray " + pass); // Multi-dimensionnal array. int multi_a[][] = { {1, 2, 3}, {4, 5, 6}, {7, 8, 9}}; int res_multi_a[][] = ato.echoMatrix (multi_a); pass = true; for (int i = 0; i < 3; i++) for (int j = 0; j < 3; j++) pass = pass && (multi_a[i][j] == res_multi_a [i][j]); System.out.println ("echoMatrix " + pass); // Attributes. ato.myColor (idl.all_typesPackage.Color.Blue); System.out.println ("Attributes " + (idl.all_typesPackage.Color.Blue == ato.myColor())); // Read Only attributes. int v1 = ato.Counter (); int v2 = ato.Counter (); System.out.println ("RO Attributes " + (v1 + 1 == v2)); // User exception. try { ato.testException (2845); } catch (idl.all_typesPackage.my_exception ex) { System.out.println ("User exception " + (ex.info == 2845)); } // System exception. try { ato.testUnknownException (2485); } catch (org.omg.CORBA.UNKNOWN es) { System.out.println ("System exception " + true); } } } polyorb-2.8~20110207.orig/testsuite/corba/interop/java/common/DynServer.java0000644000175000017500000000413311750740340026177 0ustar xavierxavier// Generic DSI Server. public class DynServer { public static void main( String args[] ) { org.omg.CORBA.ORB orb = org.omg.CORBA.ORB.init( args, null ); org.omg.CORBA.Object objPoa = null; org.omg.PortableServer.POA rootPOA = null; try { objPoa = orb.resolve_initial_references( "RootPOA" ); } catch ( org.omg.CORBA.ORBPackage.InvalidName ex ) { System.out.println( "Couldn't find RootPOA!" ); System.exit( 1 ); } rootPOA = org.omg.PortableServer.POAHelper.narrow( objPoa ); DynSkeleton skeleton = new DynSkeleton( orb ); byte[] servantId = null ; try { servantId = rootPOA.activate_object( skeleton ); } catch ( org.omg.PortableServer.POAPackage.WrongPolicy ex ) { ex.printStackTrace(); } catch ( org.omg.PortableServer.POAPackage.ServantAlreadyActive ex ) { ex.printStackTrace(); } org.omg.CORBA.Object obj = null ; try { obj = rootPOA.id_to_reference( servantId ); } catch ( org.omg.PortableServer.POAPackage.WrongPolicy ex ) { ex.printStackTrace(); } catch ( org.omg.PortableServer.POAPackage.ObjectNotActive ex ) { ex.printStackTrace(); } String reference = orb.object_to_string( obj ); try { java.io.FileOutputStream file = new java.io.FileOutputStream( "IOR" ); java.io.PrintStream pfile = new java.io.PrintStream( file ); pfile.println( reference ); file.close(); System.out.println (reference); } catch ( java.io.IOException ex ) { System.out.println( "File error" ); } try { rootPOA.the_POAManager().activate(); System.out.println( "The server is ready..." ); orb.run(); } catch ( Exception ex ) { ex.printStackTrace(); } } } polyorb-2.8~20110207.orig/testsuite/corba/interop/java/common/all_types.idl0000644000175000017500000000510011750740340026074 0ustar xavierxavierinterface all_types { // Simple types // ------------ boolean echoBoolean(in boolean arg) ; short echoShort(in short arg) ; long echoLong(in long arg) ; unsigned short echoUShort(in unsigned short arg) ; unsigned long echoULong(in unsigned long arg) ; float echoFloat(in float arg) ; double echoDouble(in double arg) ; char echoChar(in char arg) ; octet echoOctet (in octet arg) ; string echoString (in string arg) ; all_types echoRef (in all_types arg); Object echoObject (in Object arg); // typedef all_types otherAllTypes; // typedef Object otherObject; // otherAllTypes echoOtherAllTypes (in otherAllTypes arg); // otherObject echoOtherObject (in otherObject arg); // Enum // ---- enum Color { Red, Green, Blue }; Color echoColor (in Color arg); // Exceptions // ---------- exception my_exception {long info;}; void testException (in long arg) raises (my_exception); void testUnknownException (in long arg); // Unions // ------ union myUnion switch (long) { case 1: long Counter; case 2: boolean Flag; case 3: Color Hue; default: long Unknown; }; myUnion echoUnion (in myUnion arg); union myUnionEnumSwitch switch (Color) { case Red: long foo; case Green: short bar; case Blue: string baz; }; myUnionEnumSwitch echoUnionEnumSwitch (in myUnionEnumSwitch arg); // Arrays // ------ typedef long simple_array[5]; simple_array echoArray (in simple_array arg); // Multi-dimensional arrays // ------------------------ typedef long matrix[3][3]; matrix echoMatrix (in matrix arg); typedef long bigmatrix[30][15]; bigmatrix echoBigMatrix (in bigmatrix arg); // Structs // ------- struct simple_struct { long a; string s; }; simple_struct echoStruct (in simple_struct arg); struct array_struct { long a[10]; unsigned short b; }; array_struct echoArrayStruct (in array_struct arg); struct composite_struct { fixed<12,3> fixedMember; sequence > seqseqMember; long double matrixMember[3][4]; }; struct nested_struct { simple_struct ns; }; nested_struct echoNestedStruct (in nested_struct arg); // Sequences // --------- typedef sequence U_sequence; U_sequence echoUsequence (in U_sequence arg); typedef sequence B_sequence; B_sequence echoBsequence (in B_sequence arg); // Fixed point // ----------- typedef fixed<18,2> Money; Money echoMoney (in Money arg); // Attributes // ---------- readonly attribute long Counter; attribute Color myColor; }; polyorb-2.8~20110207.orig/testsuite/corba/interop/java/common/DynSkeleton.java0000644000175000017500000000210111750740340026506 0ustar xavierxavier// DSI Server that supports the `unsigned long echoULong (unsigned long var)` method. public class DynSkeleton extends org.omg.PortableServer.DynamicImplementation { public String[ ] _all_interfaces( org.omg.PortableServer.POA poa, byte [] objectId ) { String[] _ids_list = { "IDL:all_types:1.0" }; return _ids_list; } private org.omg.CORBA.ORB m_orb; public DynSkeleton( org.omg.CORBA.ORB orb ) { m_orb = orb; } public void invoke ( org.omg.CORBA.ServerRequest request ) { String operation = request.operation(); if ( operation.equals( "echoULong" ) ) { org.omg.CORBA.NVList argList = m_orb.create_list( 0 ); org.omg.CORBA.Any arg0 = m_orb.create_any(); arg0.type( m_orb.get_primitive_tc( org.omg.CORBA.TCKind.tk_ulong ) ); argList.add_value( "", arg0, org.omg.CORBA.ARG_IN.value ); request.arguments( argList ); request.set_result( arg0 ); } else throw new org.omg.CORBA.BAD_OPERATION(); } } polyorb-2.8~20110207.orig/testsuite/corba/interop/java/common/Server.java0000644000175000017500000000305211750740340025523 0ustar xavierxavier// Java All Types static server, cf all_types.idl for more details import idl.*; public class Server { public static void main( String args[] ) { org.omg.CORBA.ORB orb = org.omg.CORBA.ORB.init( args, null ); org.omg.CORBA.Object objPoa = null; org.omg.PortableServer.POA rootPOA = null; try { objPoa = orb.resolve_initial_references( "RootPOA" ); } catch ( org.omg.CORBA.ORBPackage.InvalidName ex ) { System.out.println( "Couldn't find RootPOA!" ); System.exit( 1 ); } rootPOA = org.omg.PortableServer.POAHelper.narrow( objPoa ); Alltypes at_obj = new Alltypes(); try { org.omg.CORBA.Object obj = at_obj._this( orb ); String reference = orb.object_to_string( obj ); try { java.io.FileOutputStream file = new java.io.FileOutputStream( "IOR" ); java.io.PrintStream pfile = new java.io.PrintStream( file ); pfile.println( reference ); file.close(); } catch ( java.io.IOException ex ) { System.out.println( "File error" ); } rootPOA.the_POAManager().activate(); System.out.println( "The server is ready..." ); orb.run(); } catch ( java.lang.Exception ex ) { System.out.println( "An exception has been intercepted" ); ex.printStackTrace(); } } } polyorb-2.8~20110207.orig/testsuite/corba/interop/cpp/0000755000175000017500000000000011750740340021763 5ustar xavierxavierpolyorb-2.8~20110207.orig/testsuite/corba/interop/cpp/TAO/0000755000175000017500000000000011750740340022406 5ustar xavierxavierpolyorb-2.8~20110207.orig/testsuite/corba/interop/cpp/TAO/dynserver_mt_TAO.cc0000644000175000017500000001150211750740340026140 0ustar xavierxavier// $Id: //droopi/main/testsuite/corba/interop/cpp/TAO/dynserver_mt_TAO.cc#2 $ // DSI server, implements echoULong method. It uses TAO's worker thread pool. // NOTE: this server will compile only with TAO #include #include #include #include "ace/pre.h" #include "tao/DynamicInterface/Dynamic_Implementation.h" #include "tao/DynamicInterface/Server_Request.h" #include "tao/PortableServer/PortableServer.h" #include "tao/corba.h" #include "ace/Task.h" #include "ace/post.h" #include "tao/AnyTypeCode/NVList.h" #include "tao/AnyTypeCode/SystemExceptionA.h" #include "tao/AnyTypeCode/TypeCode.h" #include "tao/AnyTypeCode/TypeCode_Constants.h" using namespace std; using namespace CORBA; class MyDynImpl : public PortableServer::DynamicImplementation, public PortableServer::RefCountServantBase { public: void invoke(CORBA::ServerRequest_ptr request); virtual char* _primary_interface(const PortableServer::ObjectId&, PortableServer::POA_ptr); }; CORBA::ORB_var orb; ////////////////////////////////////////////////////////////////////////// // Worker thread implementation class Worker : public ACE_Task_Base { public: Worker (CORBA::ORB_ptr orb); virtual int svc (void); private: CORBA::ORB_var orb_; }; Worker::Worker (CORBA::ORB_ptr orb) : orb_ (CORBA::ORB::_duplicate (orb)) { } int Worker::svc (void) { ACE_DECLARE_NEW_CORBA_ENV; ACE_TRY { this->orb_->run (ACE_ENV_SINGLE_ARG_PARAMETER); ACE_TRY_CHECK; } ACE_CATCHANY { } ACE_ENDTRY; return 0; } ////////////////////////////////////////////////////////////////////////// void MyDynImpl::invoke(CORBA::ServerRequest_ptr request) { try { if (ACE_OS::strcmp ("_is_a", request->operation ()) == 0) { CORBA::NVList_ptr list; orb->create_list (0, list); CORBA::Any type_id; type_id._tao_set_typecode (CORBA::_tc_string); list->add_value ("type_id", type_id, CORBA::ARG_IN); request->arguments (list); CORBA::NamedValue_ptr nv = list->item (0); const char *arg; *(nv->value ()) >>= arg; CORBA::Boolean type_matches = 0; if (strcmp (arg, "IDL:all_types:1.0") == 0 || strcmp (arg, "IDL:omg.org/CORBA/Object:1.0") == 0 || strcmp (arg, "") == 0) type_matches = 1; CORBA::Any result; result <<= CORBA::Any::from_boolean (type_matches); request->set_result (result); return; } else if ( strcmp("echoULong", request->operation()) == 0) { CORBA::NVList_ptr args; orb->create_list(0, args); CORBA::Any a; a._tao_set_typecode (CORBA::_tc_ulong); args->add_value("", a, CORBA::ARG_IN); request->arguments(args); CORBA::ULong x; *(args->item(0)->value()) >>= x; CORBA::Any* result = new CORBA::Any(); *result <<= x; request->set_result(*result); delete result; } else { throw CORBA::BAD_OPERATION(0, CORBA::COMPLETED_NO); } } catch(CORBA::SystemException& ex){ std::cout << "I'll be back" << std::endl; // CORBA::Any a; // a <<= ex; // request->set_exception(a); } catch(...){ std::cout << "echo_dsiimpl: MyDynImpl::invoke - caught an unknown exception." << endl; CORBA::Any a; a <<= CORBA::UNKNOWN(0, CORBA::COMPLETED_NO); request->set_exception(a); } } char* MyDynImpl::_primary_interface(const PortableServer::ObjectId&, PortableServer::POA_ptr) { return CORBA::string_dup("IDL:all_types:1.0"); } ////////////////////////////////////////////////////////////////////////// // main function int main(int argc, char** argv) { // Creating a simple server try { orb = CORBA::ORB_init(argc, argv); std::cerr << "@@1" << std::endl; CORBA::Object_var obj = orb->resolve_initial_references("RootPOA"); std::cerr << "@@2" << std::endl; PortableServer::POA_var poa = PortableServer::POA::_narrow(obj.in ()); std::cerr << "@@3" << std::endl; MyDynImpl* myallt = new MyDynImpl(); std::cerr << "@@4" << std::endl; PortableServer::ObjectId_var myalltid = poa->activate_object(myallt); std::cerr << "@@5" << std::endl; obj = poa->id_to_reference (myalltid.in ()); std::cerr << "@@6" << std::endl; CORBA::String_var sior(orb->object_to_string(obj.in ())); cerr << "'" << (char*) sior << "'" << endl; myallt->_remove_ref(); PortableServer::POAManager_var pman = poa->the_POAManager(); pman->activate(); std::cerr << "Server ready" << std::endl; Worker worker (orb.in ()); if (worker.activate (THR_NEW_LWP | THR_JOINABLE, 4) != 0) ACE_ERROR_RETURN ((LM_ERROR, "Cannot activate client threads\n"), 1); worker.thr_mgr ()->wait (); } catch(...) { cerr << "fatal error : exception raised by the server" << endl; } return EXIT_SUCCESS; } polyorb-2.8~20110207.orig/testsuite/corba/interop/cpp/TAO/Makefile.TAO0000644000175000017500000000451711750740340024477 0ustar xavierxavier####################################################################### # Shell setup DEL = rm -f ####################################################################### # C/C++ compiler to use CXX = g++ -D__USE_TAO__ LD = g++ ####################################################################### # Setup for TAO 1.5.6 #TAO_PATH = TAO_PATH = /usr/local/packages/TAO-1.5.6 TAO_BIN = $(TAO_PATH)/bin TAO_INC = $(TAO_PATH)/include TAO_LIBPATH = $(TAO_PATH)/lib TAO_LIB = -lTAO_DynamicInterface -lTAO_Strategies -lTAO_PortableServer -lTAO # IDL Compiler setup IDL = $(TAO_BIN)/tao_idl IDL_FLAGS = ####################################################################### # Makefile configured for TA0 1.5.1 (+ACE 5.5.1) CXXFLAGS = -c -Wall -I$(TAO_PATH) -I$(TAO_INC) -g LD_FLAGS = -g LIBS = -L$(TAO_LIBPATH) -L $(TAO_PATH)/TAO/tao $(TAO_LIB) -pthread PROG= all_types_dynclient all_types_dynserver dynserver_mt_TAO all: $(PROG) all_types_client: all_types_client.o all_typesC.o $(LD) all_types_client.o all_typesC.o $(LD_FLAGS) $(LIBS) -o all_types_client server: server.o all_typesS.o $(LD) server.o all_typesS.o $(LD_FLAGS) $(LIBS) -o server all_types_dynserver: all_types_dynserver.o $(LD) all_types_dynserver.o $(LD_FLAGS) $(LIBS) -o all_types_dynserver dynserver_mt_TAO: dynserver_mt_TAO.o $(LD) dynserver_mt_TAO.o $(LD_FLAGS) $(LIBS) -o dynserver_mt_TAO all_types_dynclient: all_types_dynclient.o $(LD) all_types_dynclient.o $(LD_FLAGS) $(LIBS) -o all_types_dynclient all_types_dynclient.o: ../common/all_types_dynclient.cc $(CXX) $(CXXFLAGS) ../common/all_types_dynclient.cc all_types_dynserver.o: ../common/all_types_dynserver.cc $(CXX) $(CXXFLAGS) ../common/all_types_dynserver.cc all_types_client.o: all_types_client.cc all_typesC.h all_typesS.cpp $(CXX) $(CXXFLAGS) all_types_client.cc server.o: all_typesS.cpp server.cc all_types_imp.cc $(CXX) $(CXXFLAGS) server.cc all_typesS.o: all_typesC.h all_typesS.cpp $(CXX) $(CXXFLAGS) all_typesS.cpp all_typesC.o: all_typesC.h all_typesC.cpp $(CXX) $(CXXFLAGS) all_typesC.cpp all_typesC.h all_typesS.cpp: all_types.idl $(IDL) $(IDL_FLAGS) all_types.idl clean: $(DEL) *.o *~ $(DEL) $(PROG) distclean: clean $(DEL) all_typesC.cpp all_typesC.h all_typesC.i all_typesS.cpp \ all_typesS.h all_typesS.i all_typesS_T.cpp all_typesS_T.h \ all_typesS_T.i polyorb-2.8~20110207.orig/testsuite/corba/interop/cpp/README0000644000175000017500000000071011750740340022641 0ustar xavierxavierREADME for the PolyORB CORBA interoperability tests --------------------------------------------------- $Id: //droopi/main/examples/corba/all_types/interop/cpp/README#2 $ * Compilation edit the makefile corresponding the ORB you want to use, and setup: - C/C++ compiler, be careful to use the correct version of the GNU C++ compiler if required. - IDL compiler. - Path to libraries and include files. - compile using 'make -f Makefile.' polyorb-2.8~20110207.orig/testsuite/corba/interop/cpp/omniORB/0000755000175000017500000000000011750740340023270 5ustar xavierxavierpolyorb-2.8~20110207.orig/testsuite/corba/interop/cpp/omniORB/Makefile.omniORB0000644000175000017500000000552611750740340026244 0ustar xavierxavier####################################################################### # Shell setup DEL = rm -f ####################################################################### # C/C++ compiler to use CXX = g++ -D__USE_OMNIORB__ LD = g++ ####################################################################### # Setup for omniORB 4.1.2 # OMNIORB_PATH = OMNIORB_PATH = /usr/local/packages/omniORB-4.1.2 OMNIORB_BIN = $(OMNIORB_PATH)/bin OMNIORB_INC = $(OMNIORB_PATH)/include OMNIORB_LIBPATH = $(OMNIORB_PATH)/lib OMNIORB_LIB = -lomniORB4 -lomnithread -lomniDynamic4 # IDL Compiler setup IDL = $(OMNIORB_BIN)/omniidl IDL_FLAGS = -bcxx ####################################################################### # Makefile configured for omniORB 4.0.6 CXXFLAGS = -c -Wall -I$(OMNIORB_INC) -g -I./ LD_FLAGS = -g LIBS = -L$(OMNIORB_LIBPATH) $(OMNIORB_LIB) -pthread PROG= all_types_dynclient all_types_dynserver all_types_client all_types_server all_functions_client all: $(PROG) all_types_dynserver: all_types_dynserver.o $(LD) all_types_dynserver.o $(LD_FLAGS) $(LIBS) -o all_types_dynserver all_types_dynclient: all_types_dynclient.o $(LD) all_types_dynclient.o $(LD_FLAGS) $(LIBS) -o all_types_dynclient all_types_dynclient.o: ../common/all_types_dynclient.cc $(CXX) $(CXXFLAGS) ../common/all_types_dynclient.cc all_types_dynserver.o: ../common/all_types_dynserver.cc $(CXX) $(CXXFLAGS) ../common/all_types_dynserver.cc all_functions_client: all_functionsSK.o all_functions_client.o $(LD) all_functions_client.o all_functionsSK.o $(LD_FLAGS) $(LIBS) -o all_functions_client all_functions_client.o: ../common/all_functions_client.cc $(CXX) $(CXXFLAGS) ../common/all_functions_client.cc all_functionsSK.o: all_functions.hh $(CXX) $(CXXFLAGS) all_functionsSK.cc all_functions.hh: ../../../../../examples/corba/all_functions/all_functions.idl $(IDL) $(IDL_FLAGS) ../../../../../examples/corba/all_functions/all_functions.idl all_types_client: all_types_client.o all_typesSK.o $(LD) all_types_client.o all_typesSK.o $(LD_FLAGS) $(LIBS) -o all_types_client all_types_server: all_types_server.o all_typesSK.o $(LD) all_types_server.o all_typesSK.o $(LD_FLAGS) $(LIBS) -o all_types_server all_types_client.o: ../common/all_types_client.cc all_types.hh all_typesSK.cc $(CXX) $(CXXFLAGS) ../common/all_types_client.cc all_types_server.o: all_types.hh all_typesSK.cc ../common/all_types_server.cc ../common/all_types_imp.cc $(CXX) $(CXXFLAGS) ../common/all_types_server.cc all_typesSK.o: all_types.hh all_typesSK.cc $(CXX) $(CXXFLAGS) all_typesSK.cc all_types.hh all_typesSK.cc: ../../../../../examples/corba/all_types/all_types.idl $(IDL) $(IDL_FLAGS) ../../../../../examples/corba/all_types/all_types.idl clean: $(DEL) *.o *~ $(DEL) $(PROG) distclean: clean $(DEL) all_types.hh all_typesSK.cc all_functions.hh all_functionsSK.cc polyorb-2.8~20110207.orig/testsuite/corba/interop/cpp/common/0000755000175000017500000000000011750740340023253 5ustar xavierxavierpolyorb-2.8~20110207.orig/testsuite/corba/interop/cpp/common/all_types_dynserver.cc0000644000175000017500000001033311750740340027657 0ustar xavierxavier// $Id: //droopi/main/testsuite/corba/interop/cpp/common/all_types_dynserver.cc#2 $ // DSI server, implements echoULong method #include #include #include #ifdef __USE_TAO__ #include "tao/DynamicInterface/Dynamic_Implementation.h" #include "tao/DynamicInterface/Server_Request.h" #include "tao/PortableServer/PortableServer.h" #include "tao/corba.h" #include "tao/SystemException.h" #include "tao/AnyTypeCode/NVList.h" #include "tao/AnyTypeCode/SystemExceptionA.h" #include "tao/AnyTypeCode/TypeCode.h" #include "tao/AnyTypeCode/TypeCode_Constants.h" #endif #ifdef __USE_OMNIORB__ #include #endif #ifdef __USE_MICO__ #include #endif using namespace std; using namespace CORBA; class MyDynImpl : public PortableServer::DynamicImplementation, public PortableServer::RefCountServantBase { public: void invoke(CORBA::ServerRequest_ptr request); virtual char* _primary_interface(const PortableServer::ObjectId&, PortableServer::POA_ptr); }; CORBA::ORB_var orb; void MyDynImpl::invoke(CORBA::ServerRequest_ptr request) { try { if (strcmp ("_is_a", request->operation ()) == 0) { CORBA::NVList_ptr list; orb->create_list (0, list); // XXX It seems there is a subtle difference in the way // anys are handled. This makes the compiler happy, but // is it correct ? CORBA::Any type_id; #ifdef __USE_TAO__ type_id._tao_set_typecode (CORBA::_tc_string); #endif #if defined (__USE_OMNIORB__) || (__USE_MICO__) type_id.replace(CORBA::_tc_string, 0); #endif list->add_value ("type_id", type_id, CORBA::ARG_IN); request->arguments (list); CORBA::NamedValue_ptr nv = list->item (0); const char *arg; *(nv->value ()) >>= arg; CORBA::Boolean type_matches = 0; if (strcmp (arg, "IDL:all_types:1.0") == 0 || strcmp (arg, "IDL:omg.org/CORBA/Object:1.0") == 0 || strcmp (arg, "") == 0) type_matches = 1; CORBA::Any result; result <<= CORBA::Any::from_boolean (type_matches); request->set_result (result); return; } else if ( strcmp("echoULong", request->operation()) == 0) { CORBA::NVList_ptr args; orb->create_list(0, args); // XXX See comment above CORBA::Any a; #ifdef __USE_TAO__ a._tao_set_typecode (CORBA::_tc_ulong); #endif #if defined (__USE_OMNIORB__) || (__USE_MICO__) a.replace(CORBA::_tc_ulong, 0); #endif args->add_value("", a, CORBA::ARG_IN); request->arguments(args); CORBA::ULong x; *(args->item(0)->value()) >>= x; CORBA::Any* result = new CORBA::Any(); *result <<= x; request->set_result(*result); delete result; } else { std::cout << "bad operation :" << request->operation() << endl; throw CORBA::BAD_OPERATION(0, CORBA::COMPLETED_NO); } } catch(CORBA::SystemException& ex){ std::cout << "MyDynImpl::invoke - caught an system exception." << endl; #if defined (__USE_OMNIORB__) || (__USE_MICO__) // XXX it seems there is no <<= operator for SystemException, only for children of it CORBA::Any a; a <<= ex; request->set_exception(a); #endif } catch(...){ std::cout << "MyDynImpl::invoke - caught an unknown exception." << endl; CORBA::Any a; a <<= CORBA::UNKNOWN(0, CORBA::COMPLETED_NO); request->set_exception(a); } } char* MyDynImpl::_primary_interface(const PortableServer::ObjectId&, PortableServer::POA_ptr) { return CORBA::string_dup("IDL:all_types:1.0"); } int main(int argc, char** argv) { // Creating a simple server try { orb = CORBA::ORB_init(argc, argv); CORBA::Object_var obj = orb->resolve_initial_references("RootPOA"); PortableServer::POA_var poa = PortableServer::POA::_narrow(obj.in ()); MyDynImpl* myallt = new MyDynImpl(); PortableServer::ObjectId_var myalltid = poa->activate_object(myallt); obj = poa->id_to_reference (myalltid.in ()); CORBA::String_var sior(orb->object_to_string(obj.in ())); cerr << "'" << (char*) sior << "'" << endl << endl; myallt->_remove_ref(); PortableServer::POAManager_var pman = poa->the_POAManager(); pman->activate(); orb->run(); } catch(...) { cerr << "fatal error : exception raised by the server" << endl; } return EXIT_SUCCESS; } polyorb-2.8~20110207.orig/testsuite/corba/interop/cpp/common/all_functions_client.cc0000644000175000017500000000162211750740340027761 0ustar xavierxavier#include #include #include "report.cc" #ifdef __USE_OMNIORB__ #include #endif #ifdef __USE_MICO__ #include #endif using namespace std; int main(int argc, char* argv[]) { if (argc != 2) { printf("Usage : mico-client \n"); } string ior = argv[1]; CORBA::ORB_var _orb = CORBA::ORB_init(argc, argv); CORBA::Object_var obj = _orb->string_to_object(ior.c_str()); all_functions_var allfunc = all_functions::_narrow(obj); new_test ("Different invocation modes"); if (CORBA::is_nil(allfunc)) { cerr << "can't access object" << endl; exit (1); } allfunc->oneway_void_proc(); sleep(1); bool ok = (allfunc->oneway_checker() == 1); if (ok) { sleep(5); ok = (allfunc->oneway_checker() == 2); } output ("test void one way procedure", ok); end_report (); } polyorb-2.8~20110207.orig/testsuite/corba/interop/cpp/common/report.cc0000644000175000017500000000105611750740340025077 0ustar xavierxavier#include #include using namespace std; const int MAX = 60; bool passed = true; void output(char *s, bool pass) { char Line[MAX + 1]; unsigned int len = strlen(s); unsigned int i; for (i = 0 ; i < sizeof Line - 1; i++) Line [i] = (i < len) ? s [i] : '.'; Line [sizeof Line - 1] = '\0'; cout << Line << (pass ? " : PASSED" : " : FAILED") << endl; passed = passed && pass; } void new_test (char *s) { cout << "==> Begin test " << s << "<==" << endl; } void end_report () { output ("END TESTS", passed); } polyorb-2.8~20110207.orig/testsuite/corba/interop/cpp/common/all_types_client.cc0000644000175000017500000002260111750740340027115 0ustar xavierxavier#include "report.cc" #ifdef __USE_OMNIORB__ #include #endif #ifdef __USE_MICO__ #include #endif //#define DEBUG #define BOOLEAN #define SHORT #define LONG #define USHORT #define ULONG #define FLOAT #define DOUBLE #define CHAR #define OCTET #define STRING #define ENUM #define BSEQ #define USEQ #define ARRAY #define MATRIX #define BIGMATRIX #define STRUCT #define ARRAY_STRUCT #define UNION #define ATTRIBUTE #define OBJECT #define MONEY #define EXCEPTION static void test(all_types_ptr p) { new_test ("CORBA Types"); output("testing not null", !p->_is_nil ()); // type simple { bool Pass; //boolean #ifdef BOOLEAN Pass = (p->echoBoolean(true) == true); output("testing Boolean", Pass); #endif //short #ifdef SHORT Pass = (p->echoShort(123) == 123); output("testing Short", Pass); #endif //long #ifdef LONG Pass = (p->echoLong(456) == 456); output("testing Long", Pass); #endif //ushort #ifdef USHORT Pass = (p->echoUShort(456) == 456); output("testing UShort", Pass); #endif //ulong #ifdef ULONG Pass = (p->echoULong(123) == 123); output("testing ULong", Pass); #endif //float #ifdef FLOAT Pass = (p->echoFloat(2.7) == (float)2.7); output("testing Float", Pass); #endif //double #ifdef DOUBLE Pass = (p->echoDouble(1.5) == 1.5); output("testing Double", Pass); #endif //char #ifdef CHAR Pass = (p->echoChar('A') == 'A'); output( "testing Char", Pass); #endif //Octet #ifdef OCTET Pass = (p->echoOctet(5) == 5); output("testing Octet", Pass); #endif //String #ifdef STRING Pass = !strcmp(p->echoString("hello"), "hello"); output("testing String", Pass); #endif } // type complexe : { // Enum #ifdef ENUM bool Pass; Pass = (p->echoColor(all_types::Blue) == all_types::Blue); output("testing Enum", Pass); #endif } // Sequence { #ifdef USEQ CORBA::Short Tab[] = { 16, 32, 64, 128, 257 }; all_types::U_sequence X (5, 5, Tab); all_types::U_sequence Y; bool Pass = 1; Y = *p->echoUsequence(X); Pass &= Y.length() == X.length(); #ifdef DEBUG output("comparing the length" , Pass); #endif for (unsigned int i = 0 ; Pass && i < X.length() ; i++) { Pass &= (X[i] == Y[i]); #ifdef DEBUG cerr << X[i] << "==" << Y[i] << endl; #endif } output("testing Sequence", Pass); #endif } // Sequence { #ifdef BSEQ all_types::B_sequence X; all_types::B_sequence Y; bool Pass = 1; X.length(5); for (int i = 0; i < 5; i++) X[i] = i; Y = *p->echoBsequence(X); Pass &= Y.length() == X.length(); output("comparing the length", Pass); for (unsigned int i = 0 ; Pass && i < X.length() ; i++) { Pass &= (X[i] == Y[i]); #ifdef DEBUG cerr << X[i] << "==" << Y[i] << endl; #endif } output("testing Bounded Sequence", Pass); #endif } // simple array { #ifdef ARRAY all_types::simple_array A = { 2, 3, 5, 7, 11 }; all_types::simple_array_var B = p->echoArray(A); bool Pass = 1; for (int i = 0; i <= 4; i++) { Pass &= (A[i] == ((CORBA::Long*)B)[i]); #ifdef DEBUG cerr << A[i] << B[i] << endl; #endif } output("testing Simple Array", Pass); #endif } // matrix #ifdef MATRIX { all_types::matrix A = { { 0xfe, 0xe1, 0x5a }, { 0xde, 0xad, 0xa5 }, { 0xbe, 0xef, 0x88 } }; all_types::matrix_var B = p->echoMatrix(A); bool Pass = 1; for (int i = 0; i < 3; i++) { for (int j = 0; j < 3 ; j++) Pass &= (A[i][j] == ((CORBA::Long(*)[3])B)[i][j]); } output("testing Matrix", Pass); } #endif // big matrix #ifdef BIGMATRIX { all_types::bigmatrix A; all_types::bigmatrix_var B; bool Pass = true; for (int i = 0; i < 30; i++) for (int j = 0; j < 15; j++) A[i][j] = ((i + 1) * (j + 2)); B = p->echoBigMatrix(A); for (int i = 0; i < 30; i++) for (int j = 0; j < 15; j++) Pass &= (A[i][j] == ((CORBA::Long(*)[15])B)[i][j]); output("testing big matrix", Pass); } #endif // structure #ifdef STRUCT { struct all_types::simple_struct Test_Struct; struct all_types::simple_struct Copy_Struct; bool Pass = false; Test_Struct.a = 123; Test_Struct.s = "foobar"; Copy_Struct = *p->echoStruct (Test_Struct); Pass = ((Copy_Struct.a == Test_Struct.a) && !strcmp (Copy_Struct.s, Test_Struct.s)); output("testing Struct", Pass); } #endif // array struct #ifdef ARRAY_STRUCT { struct all_types::array_struct Test_Struct; struct all_types::array_struct Copy_Struct; bool Pass = 1; int i; for (i = 0 ; i < 10 ; i++) Test_Struct.a[i] = 3 * i + 7; Test_Struct.b = 12345; Copy_Struct = p->echoArrayStruct (Test_Struct); for (i = 0 ; i < 10 ; i++) Pass &= (Test_Struct.a[i] == Copy_Struct.a[i]); Pass &= (Copy_Struct.b == Test_Struct.b); output("test array struct", Pass); } #endif // Union #ifdef UNION { all_types::myUnion Test_Unions[4]; all_types::myUnion Copy_Union; Test_Unions [0].Unknown (987); Test_Unions [1].Counter (123); Test_Unions [2].Flag (1); Test_Unions [3].Hue (all_types::Red); bool Pass = 1; int i; for (i = 0 ; i < 4 ; i++) { Copy_Union = p->echoUnion (Test_Unions [i]); if (!(Pass &= Copy_Union._d () == Test_Unions [i]._d ())) break; switch (Copy_Union._d ()) { case 1: Pass &= Copy_Union.Counter () == Test_Unions [i].Counter (); break; case 2: Pass &= Copy_Union.Flag () == Test_Unions [i].Flag (); break; case 3: Pass &= Copy_Union.Hue () == Test_Unions [i].Hue (); break; default: Pass &= Copy_Union.Unknown () == Test_Unions [i].Unknown (); break; } if (!Pass) break; } output("test union", Pass); } #endif // Union Switch #ifdef UNION_SWITCH { all_types::myUnionEnumSwitch Test_UnionES[4]; all_types::myUnionEnumSwitch Copy_UnionES; Test_UnionES[0].Unknown (987); Test_UnionES[1].Counter (123); Test_UnionES[2].Flag (1); Test_UnionES[3].Hue (all_types::Red); // := ((Switch => Red, Foo => 31337), // (Switch => Green, Bar => 534), // (Switch => Blue, Baz => CORBA.To_CORBA_String ("grümpf"))); bool Pass : Boolean := True; // for I in Test_Unions'Range loop // Pass := Pass // and then echoUnionEnumSwitch (Myall_types, Test_Unions (I)) // = Test_Unions (I); // exit when not Pass; // end loop; // Output ("test union with enum switch", Pass); // end; } #endif // attribute #ifdef ATTRIBUTE { bool Pass; p->myColor(all_types::Green); Pass = (p->myColor() == all_types::Green); output("test attribute", Pass); CORBA::Long Counter_First_Value = p->Counter(); CORBA::Long Counter_Second_Value = p->Counter(); output("test read-only attribute", Counter_Second_Value == Counter_First_Value + 1); } #endif // object #ifdef OBJECT { all_types_var X; X = all_types::_narrow(p->echoRef(p)); output("test self reference", X->echoLong(17) == 17); for(int i = 0; i<15;i++) X = all_types::_narrow(p->echoRef(p)); output("test self reference constistency", X->echoLong(1743) == 1743); X = p->echoOtherAllTypes(X); output("test self reference typedef", X->echoLong(176767) == 176767); X = all_types::_narrow(p->echoObject(p->echoRef(p))); output("test object", X->echoLong(17123) == 17123); X = all_types::_narrow(p->echoOtherObject(p->echoRef(p))); output("test object typedef", X->echoLong(17123) == 17123); } #endif // money #ifdef MONEY { output("test fixed point", p->echoMoney("43.21") == "43.21"); } #endif // exeption #ifdef EXCEPTION { bool Pass = 0; try { p->testException (2485); } catch (all_types::my_exception& ex) { Pass = (ex.info == 2485); #ifdef DEBUG cerr << "info sur l'exception : " << ex.info << endl; #endif output("test user exception", Pass); } Pass = 0; try { p->testUnknownException(1); } catch (CORBA::UNKNOWN &e) { // Nothing Pass = 1; } output("test unknown exception", Pass); } #endif end_report(); } int main(int argc, char** argv) { try { CORBA::ORB_var orb = CORBA::ORB_init(argc, argv); if (argc != 2) { cerr << "wrong number of param." << endl; exit(EXIT_FAILURE); } CORBA::Object_var obj = orb->string_to_object(argv[1]); all_types_var alltref = all_types::_narrow(obj); if (CORBA::is_nil(alltref)) { cerr << "can't access object" << endl; exit(EXIT_FAILURE); } test(alltref); orb->destroy(); } catch(CORBA::COMM_FAILURE& ex) { cerr << "Caught system exception COMM_FAILURE -- unable to contact the object" << endl; } catch(CORBA::SystemException&) { cerr << "Caught a CORBA::SystemException" << endl; } catch(CORBA::Exception&) { cerr << "Caught CORBA::Exception" << endl; } catch(...) { cerr << "Caught unknown error" << endl; } return 0; } polyorb-2.8~20110207.orig/testsuite/corba/interop/cpp/common/all_types_imp.cc0000644000175000017500000001070511750740340026426 0ustar xavierxavier class all_types_i : public POA_all_types, public PortableServer::RefCountServantBase { public: inline all_types_i() {tmp = 0; tmpColor = all_types::Green;}; virtual ~all_types_i() {}; CORBA::Boolean echoBoolean(CORBA::Boolean arg) {return arg;}; CORBA::Short echoShort(CORBA::Short arg) {return arg;}; CORBA::Long echoLong(CORBA::Long arg) {return arg;}; CORBA::UShort echoUShort(CORBA::UShort arg) {return arg;}; CORBA::ULong echoULong(CORBA::ULong arg) {return arg;}; CORBA::Float echoFloat(CORBA::Float arg) {return arg;}; CORBA::Double echoDouble(CORBA::Double arg) {return arg;}; CORBA::Char echoChar(CORBA::Char arg) {return arg;}; CORBA::Octet echoOctet(CORBA::Octet arg) {return arg;}; all_types::Color echoColor(all_types::Color arg) {return arg;}; char* echoString(const char* arg) { return string_dup(arg); }; all_types::U_sequence* echoUsequence(const all_types::U_sequence& arg) { all_types::U_sequence *t = new all_types::U_sequence(arg); return t; }; all_types::B_sequence* echoBsequence(const all_types::B_sequence& arg) { all_types::B_sequence *t = new all_types::B_sequence(arg); return t; } all_types::unionSequence* echoUnionSequence(const all_types::unionSequence& arg) { all_types::unionSequence *t = new all_types::unionSequence(arg); return t; } all_types::simple_array_slice* echoArray(const all_types::simple_array arg) { return all_types::simple_array_dup(arg); }; all_types::matrix_slice* echoMatrix(const all_types::matrix arg) { return all_types::matrix_dup(arg); }; all_types::bigmatrix_slice* echoBigMatrix(const all_types::bigmatrix arg) { return all_types::bigmatrix_dup(arg); }; all_types::simple_struct* echoStruct(const all_types::simple_struct & arg) { all_types::simple_struct* t = new all_types::simple_struct(arg); return t; }; all_types::array_struct echoArrayStruct(const all_types::array_struct & arg) { return (all_types::array_struct) arg; }; all_types::nested_struct* echoNestedStruct(const all_types::nested_struct & arg) { all_types::nested_struct* t = new all_types::nested_struct(arg); return t; }; all_types::myUnion echoUnion(const all_types::myUnion & arg) { return arg; } all_types::myUnionEnumSwitch* echoUnionEnumSwitch(const all_types::myUnionEnumSwitch & arg) { return (all_types::myUnionEnumSwitch*) &arg; } all_types::noMemberUnion echoNoMemberUnion(const all_types::noMemberUnion& arg) { return (all_types::noMemberUnion) arg; } CORBA::Long Counter() {return ++tmp;}; all_types::Color myColor() {return tmpColor;}; void myColor(all_types::Color arg) {tmpColor = arg;}; void testException(CORBA::Long arg) { CORBA::UserException *u = new all_types::my_exception(arg); u->_raise(); }; void testUnknownException(CORBA::Long arg) { throw 666; }; _objref_all_types* echoRef( _objref_all_types* arg) {return arg;}; CORBA::Object_ptr echoObject(CORBA::Object_ptr arg) { if (CORBA::is_nil (arg)) return all_types::_nil(); else { CORBA::Object_ptr grouik; grouik = arg->_duplicate(arg); return grouik; } } all_types::otherAllTypes_ptr echoOtherAllTypes(all_types::otherAllTypes_ptr arg) { return arg; } all_types::otherObject_ptr echoOtherObject(all_types::otherObject_ptr arg) { if (CORBA::is_nil (arg)) return all_types::_nil(); else { CORBA::Object_ptr grouik; grouik = arg->_duplicate(arg); return grouik; } } all_types::Money echoMoney(const all_types::Money& arg) { return arg; } CORBA::ULongLong echoULLong(CORBA::ULongLong arg) { return arg; } CORBA::WChar echoWChar(CORBA::WChar arg) { return arg; } CORBA::WChar* echoWString(const CORBA::WChar* arg) { return NULL; } char* echoBoundedStr(const char* arg) { return string_dup(arg); } CORBA::WChar* echoBoundedWStr(const CORBA::WChar* arg) { return NULL; } all_types::Color* echoRainbow(const all_types::Color* arg) { return NULL; } void testSystemException(CORBA::Long arg) { } CORBA::Long (* echoNestedArray(const CORBA::Long (* arg)[5]))[5] { return NULL; } CORBA::Long (* echoSixteenKb(const CORBA::Long (* arg)[64]))[64] { return NULL; } void StopServer() { } private: CORBA::Long tmp; all_types::Color tmpColor; }; polyorb-2.8~20110207.orig/testsuite/corba/interop/cpp/common/all_types_dynclient.cc0000644000175000017500000000432511750740340027633 0ustar xavierxavier// $Id: //droopi/main/testsuite/corba/interop/cpp/common/all_types_dynclient.cc#2 $ // DII client, makes multiple calls to echoULong method #include #include #include "report.cc" #ifdef __USE_TAO__ #include "tao/DynamicInterface/Request.h" #include "tao/corba.h" #include "tao/AnyTypeCode/Any.h" #include "tao/AnyTypeCode/TypeCode_Constants.h" #include "tao/AnyTypeCode/TypeCode_Constants.h" #endif #ifdef __USE_OMNIORB__ #include "omniORB4/CORBA.h" #endif #ifdef __USE_MICO__ #include #endif using namespace std; using namespace CORBA; static void test(CORBA::Object_var p) { int Pass = 1; for (int i = 0; i < 1000; i++) { CORBA::ULong arg = 234; CORBA::Request_var req1 = p->_request("echoULong"); req1->add_in_arg() <<= arg; req1->set_return_type(CORBA::_tc_ulong); req1->invoke(); if ( req1->exceptions() != NULL && req1->exceptions()->count() > 0) { cerr<< "all_types_dynclient: An exception was thrown!" << endl; return; } CORBA::ULong ret1; req1->return_value() >>= ret1; Pass &= (ret1 == 234); } output ("testing ULong (1000 times)", Pass); end_report(); } int main(int argc, char** argv) { try { CORBA::ORB_var orb = CORBA::ORB_init(argc, argv); if (argc != 2) { cerr << "wrong number of param." << endl; exit(EXIT_FAILURE); } CORBA::Object_var obj = orb->string_to_object(argv[1]); if (CORBA::is_nil(obj.in ())) { cerr << "can't access object" << endl; exit(EXIT_FAILURE); } test(obj); orb->destroy(); } catch(CORBA::COMM_FAILURE&) { cerr << "Caught system exception COMM_FAILURE -- unable to contact the object" << endl; } catch(CORBA::SystemException& ex) { #if defined (__USE_TAO__) || (__USE_MICO__) cerr << "Caught a CORBA::SystemException: " << ex << endl; #endif #if defined (__USE_OMNIORB__) cerr << "Caught a CORBA::SystemException: " << endl; #endif } catch(CORBA::Exception&) { cerr << "Caught CORBA::Exception" << endl; } catch(...) { cerr << "Caught unknown error" << endl; } return 0; } polyorb-2.8~20110207.orig/testsuite/corba/interop/cpp/common/all_types_server.cc0000644000175000017500000000201011750740340027135 0ustar xavierxavier#include #include #include "all_types.hh" #include using namespace std; using namespace CORBA; // implementation of the tests #include "all_types_imp.cc" int main(int argc, char** argv) { // Creating a simple server // See omniorb documentation for explanations try { CORBA::ORB_var orb = CORBA::ORB_init(argc, argv); CORBA::Object_var obj = orb->resolve_initial_references("RootPOA"); PortableServer::POA_var poa = PortableServer::POA::_narrow(obj); all_types_i* myallt = new all_types_i(); PortableServer::ObjectId_var myalltid = poa->activate_object(myallt); obj = myallt->_this(); CORBA::String_var sior(orb->object_to_string(obj)); cerr << "'" << (char*) sior << "'" << endl; myallt->_remove_ref(); PortableServer::POAManager_var pman = poa->the_POAManager(); pman->activate(); orb->run(); } catch(...) { cerr << "fatal error : exception reached by ther server" << endl; } return EXIT_SUCCESS; } polyorb-2.8~20110207.orig/testsuite/corba/interop/cpp/MICO/0000755000175000017500000000000011750740340022512 5ustar xavierxavierpolyorb-2.8~20110207.orig/testsuite/corba/interop/cpp/MICO/Makefile.MICO0000644000175000017500000000455711750740340024713 0ustar xavierxavier####################################################################### # Shell setup DEL = rm -f ####################################################################### # C/C++ compiler to use CXX = g++ -D__USE_MICO__ LD = g++ ####################################################################### # Setup for mico 2.3.11 # MICO_PATH = MICO_PATH = /usr/local/packages/mico-2.3.12 MICO_BIN = $(MICO_PATH)/bin MICO_INC = $(MICO_PATH)/include MICO_LIBPATH = $(MICO_PATH)/lib MICO_LIB = -lmico2.3.12 # IDL Compiler setup IDL = $(MICO_BIN)/idl ####################################################################### # Makefile configured for mico 2.3.11 CXXFLAGS = -I. -I$(MICO_INC) -c -Wall -g LD_FLAGS = -g LIBS = -rdynamic -L$(MICO_LIBPATH) $(MICO_LIB) -ldl -lm -lssl -lpthread IDL_FLAGS = --poa PROG= all_types_dynclient all_types_dynserver all_functions_client all: $(PROG) all_types_dynserver: all_types_dynserver.o $(LD) all_types_dynserver.o $(LD_FLAGS) $(LIBS) -o all_types_dynserver all_types_dynclient: all_types_dynclient.o $(LD) all_types_dynclient.o $(LD_FLAGS) $(LIBS) -o all_types_dynclient all_types_dynclient.o: ../common/all_types_dynclient.cc $(CXX) $(CXXFLAGS) ../common/all_types_dynclient.cc all_types_dynserver.o: ../common/all_types_dynserver.cc $(CXX) $(CXXFLAGS) ../common/all_types_dynserver.cc all_functions_client: all_functions.o all_functions_client.o $(LD) $(LDFLAGS) all_functions_client.o all_functions.o $(LD_FLAGS) $(LIBS) -o all_functions_client all_functions_client.o: ../common/all_functions_client.cc $(CXX) $(CXXFLAGS) ../common/all_functions_client.cc all_functions.o: all_functions.h $(CXX) $(CXXFLAGS) all_functions.cc all_functions.h: ../../../../../examples/corba/all_functions/all_functions.idl $(IDL) $(IDL_FLAGS) ../../../../../examples/corba/all_functions/all_functions.idl all_types_client: all_types.o all_types_client.o $(LD) $(LDFLAGS) all_types_client.o all_types.o $(LD_FLAGS) $(LIBS) -o all_types_client all_types_client.o: ../common/all_types_client.cc $(CXX) $(CXXFLAGS) ../common/all_types_client.cc all_types.o: all_types.h $(CXX) $(CXXFLAGS) all_types.cc all_types.h: ../../../../../examples/corba/all_types/all_types.idl $(IDL) $(IDL_FLAGS) ../../../../../examples/corba/all_types/all_types.idl clean: $(DEL) *.o *~ $(PROG) all_functions.* all_types.* polyorb-2.8~20110207.orig/testsuite/corba/local/0000755000175000017500000000000011750740340020613 5ustar xavierxavierpolyorb-2.8~20110207.orig/testsuite/corba/local/Makefile.local0000644000175000017500000000000011750740340023332 0ustar xavierxavierpolyorb-2.8~20110207.orig/testsuite/corba/local/test000.adb0000644000175000017500000000705211750740340022466 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- T E S T 0 0 0 -- -- -- -- B o d y -- -- -- -- Copyright (C) 2004-2007, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with CORBA.Object; with CORBA.ORB; with PortableServer.POA.Helper; with PolyORB.Setup.No_Tasking_Server; pragma Warnings (Off, PolyORB.Setup.No_Tasking_Server); with PolyORB.Utils.Report; use PolyORB.Utils.Report; procedure Test000 is POA : PortableServer.POA.Local_Ref; begin CORBA.ORB.Initialize ("ORB"); begin declare Int : constant CORBA.Object.Ref'Class := CORBA.Object.Get_Interface (CORBA.Object.Ref (POA)); pragma Warnings (Off); pragma Unreferenced (Int); pragma Warnings (On); begin Output ("Test on uninitialized ref", False); end; exception when CORBA.Inv_Objref => Output ("Test on uninitialized ref", True); when others => Output ("Test on uninitialized ref", False); end; POA := PortableServer.POA.Helper.To_Local_Ref (CORBA.ORB.Resolve_Initial_References (CORBA.ORB.To_CORBA_String ("RootPOA"))); begin declare Int : constant CORBA.Object.Ref'Class := CORBA.Object.Get_Interface (CORBA.Object.Ref (POA)); pragma Warnings (Off); pragma Unreferenced (Int); pragma Warnings (On); begin Output ("Test on initialized ref", False); end; exception when CORBA.No_Implement => Output ("Test on initialized ref", True); when others => Output ("Test on initialized ref", False); end; End_Report; exception when others => Output ("Unexpected exception", False); End_Report; end Test000; polyorb-2.8~20110207.orig/testsuite/corba/local/local.gpr0000644000175000017500000000066511750740340022426 0ustar xavierxavierwith "polyorb", "polyorb_test_common"; project local is Dir := external ("Test_Dir"); Obj_Dir := PolyORB_Test_Common.Build_Dir & Dir; for Object_Dir use Obj_Dir; for Source_Dirs use (Obj_Dir, PolyORB_Test_Common.Source_Dir & Dir); package Compiler is for Default_Switches ("Ada") use PolyORB_Test_Common.Compiler'Default_Switches ("Ada"); end Compiler; for Main use ("test000.adb"); end local; polyorb-2.8~20110207.orig/testsuite/corba/all_exceptions/0000755000175000017500000000000011750740340022532 5ustar xavierxavierpolyorb-2.8~20110207.orig/testsuite/corba/all_exceptions/Makefile.local0000644000175000017500000000015611750740340025265 0ustar xavierxavier${current_dir}all_exceptions.idl-stamp: idlac_flags := ${test_target}: ${current_dir}all_exceptions.idl-stamp polyorb-2.8~20110207.orig/testsuite/corba/all_exceptions/all_exceptions-impl.adb0000644000175000017500000002535411750740340027163 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- A L L _ E X C E P T I O N S . I M P L -- -- -- -- B o d y -- -- -- -- Copyright (C) 2004-2005 Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with all_exceptions.Skel; pragma Warnings (Off, all_exceptions.Skel); package body all_exceptions.Impl is procedure Unknown_exception_test (Self : access Object) is pragma Unreferenced (Self); begin raise Constraint_Error; end Unknown_exception_test; procedure Bad_Param_exception_test (Self : access Object) is pragma Unreferenced (Self); Member : CORBA.Bad_Param_Members; begin Member := (Minor => 1, Completed => CORBA.Completed_Maybe); CORBA.Raise_Bad_Param (Member); end Bad_Param_exception_test; procedure No_Memory_exception_test (Self : access Object) is pragma Unreferenced (Self); Member : CORBA.No_Memory_Members; begin Member := (Minor => 102, Completed => CORBA.Completed_Yes); CORBA.Raise_No_Memory (Member); end No_Memory_exception_test; procedure Imp_Limit_exception_test (Self : access Object) is pragma Unreferenced (Self); Member : CORBA.Imp_Limit_Members; begin Member := (Minor => 103, Completed => CORBA.Completed_Yes); CORBA.Raise_Imp_Limit (Member); end Imp_Limit_exception_test; procedure Comm_Failure_exception_test (Self : access Object) is pragma Unreferenced (Self); Member : CORBA.Comm_Failure_Members; begin Member := (Minor => 104, Completed => CORBA.Completed_Yes); CORBA.Raise_Comm_Failure (Member); end Comm_Failure_exception_test; procedure Inv_Objref_exception_test (Self : access Object) is pragma Unreferenced (Self); Member : CORBA.Inv_Objref_Members; begin Member := (Minor => 105, Completed => CORBA.Completed_Yes); CORBA.Raise_Inv_Objref (Member); end Inv_Objref_exception_test; procedure No_Permission_exception_test (Self : access Object) is pragma Unreferenced (Self); Member : CORBA.No_Permission_Members; begin Member := (Minor => 106, Completed => CORBA.Completed_Yes); CORBA.Raise_No_Permission (Member); end No_Permission_exception_test; procedure Internal_exception_test (Self : access Object) is pragma Unreferenced (Self); Member : CORBA.Internal_Members; begin Member := (Minor => 107, Completed => CORBA.Completed_Yes); CORBA.Raise_Internal (Member); end Internal_exception_test; procedure Marshal_exception_test (Self : access Object) is pragma Unreferenced (Self); Member : CORBA.Marshal_Members; begin Member := (Minor => 108, Completed => CORBA.Completed_Yes); CORBA.Raise_Marshal (Member); end Marshal_exception_test; procedure Initialization_Failure_exception_test (Self : access Object) is pragma Unreferenced (Self); Member : CORBA.Initialization_Failure_Members; begin Member := (Minor => 109, Completed => CORBA.Completed_Yes); CORBA.Raise_Initialization_Failure (Member); end Initialization_Failure_exception_test; procedure No_Implement_exception_test (Self : access Object) is pragma Unreferenced (Self); Member : CORBA.No_Implement_Members; begin Member := (Minor => 110, Completed => CORBA.Completed_Yes); CORBA.Raise_No_Implement (Member); end No_Implement_exception_test; procedure Bad_Typecode_exception_test (Self : access Object) is pragma Unreferenced (Self); Member : CORBA.Bad_Typecode_Members; begin Member := (Minor => 111, Completed => CORBA.Completed_Yes); CORBA.Raise_Bad_TypeCode (Member); end Bad_Typecode_exception_test; procedure Bad_Operation_exception_test (Self : access Object) is pragma Unreferenced (Self); Member : CORBA.Bad_Operation_Members; begin Member := (Minor => 112, Completed => CORBA.Completed_Yes); CORBA.Raise_Bad_Operation (Member); end Bad_Operation_exception_test; procedure No_Resources_exception_test (Self : access Object) is pragma Unreferenced (Self); Member : CORBA.No_Resources_Members; begin Member := (Minor => 113, Completed => CORBA.Completed_Yes); CORBA.Raise_No_Resources (Member); end No_Resources_exception_test; procedure No_Response_exception_test (Self : access Object) is pragma Unreferenced (Self); Member : CORBA.No_Response_Members; begin Member := (Minor => 114, Completed => CORBA.Completed_Yes); CORBA.Raise_No_Response (Member); end No_Response_exception_test; procedure Persist_Store_exception_test (Self : access Object) is pragma Unreferenced (Self); Member : CORBA.Persist_Store_Members; begin Member := (Minor => 115, Completed => CORBA.Completed_Yes); CORBA.Raise_Persist_Store (Member); end Persist_Store_exception_test; procedure Bad_Inv_Order_exception_test (Self : access Object) is pragma Unreferenced (Self); Member : CORBA.Bad_Inv_Order_Members; begin Member := (Minor => 116, Completed => CORBA.Completed_Yes); CORBA.Raise_Bad_Inv_Order (Member); end Bad_Inv_Order_exception_test; procedure Transient_exception_test (Self : access Object) is pragma Unreferenced (Self); Member : CORBA.Transient_Members; begin Member := (Minor => 117, Completed => CORBA.Completed_Yes); CORBA.Raise_Transient (Member); end Transient_exception_test; procedure Free_Mem_exception_test (Self : access Object) is pragma Unreferenced (Self); Member : CORBA.Free_Mem_Members; begin Member := (Minor => 118, Completed => CORBA.Completed_Yes); CORBA.Raise_Free_Mem (Member); end Free_Mem_exception_test; procedure Inv_Ident_exception_test (Self : access Object) is pragma Unreferenced (Self); Member : CORBA.Inv_Ident_Members; begin Member := (Minor => 119, Completed => CORBA.Completed_Yes); CORBA.Raise_Inv_Ident (Member); end Inv_Ident_exception_test; procedure Inv_Flag_exception_test (Self : access Object) is pragma Unreferenced (Self); Member : CORBA.Inv_Flag_Members; begin Member := (Minor => 120, Completed => CORBA.Completed_Yes); CORBA.Raise_Inv_Flag (Member); end Inv_Flag_exception_test; procedure Intf_Repos_exception_test (Self : access Object) is pragma Unreferenced (Self); Member : CORBA.Intf_Repos_Members; begin Member := (Minor => 121, Completed => CORBA.Completed_Yes); CORBA.Raise_Intf_Repos (Member); end Intf_Repos_exception_test; procedure Bad_Context_exception_test (Self : access Object) is pragma Unreferenced (Self); Member : CORBA.Bad_Context_Members; begin Member := (Minor => 122, Completed => CORBA.Completed_Yes); CORBA.Raise_Bad_Context (Member); end Bad_Context_exception_test; procedure Obj_Adapter_exception_test (Self : access Object) is pragma Unreferenced (Self); Member : CORBA.Obj_Adapter_Members; begin Member := (Minor => 123, Completed => CORBA.Completed_Yes); CORBA.Raise_Obj_Adapter (Member); end Obj_Adapter_exception_test; procedure Data_Conversion_exception_test (Self : access Object) is pragma Unreferenced (Self); Member : CORBA.Data_Conversion_Members; begin Member := (Minor => 124, Completed => CORBA.Completed_Yes); CORBA.Raise_Data_Conversion (Member); end Data_Conversion_exception_test; procedure Object_Not_Exist_exception_test (Self : access Object) is pragma Unreferenced (Self); Member : CORBA.Object_Not_Exist_Members; begin Member := (Minor => 125, Completed => CORBA.Completed_Yes); CORBA.Raise_Object_Not_Exist (Member); end Object_Not_Exist_exception_test; procedure Transaction_Required_exception_test (Self : access Object) is pragma Unreferenced (Self); Member : CORBA.Transaction_Required_Members; begin Member := (Minor => 126, Completed => CORBA.Completed_Yes); CORBA.Raise_Transaction_Required (Member); end Transaction_Required_exception_test; procedure Transaction_Rolledback_exception_test (Self : access Object) is pragma Unreferenced (Self); Member : CORBA.Transaction_Rolledback_Members; begin Member := (Minor => 127, Completed => CORBA.Completed_Yes); CORBA.Raise_Transaction_Rolledback (Member); end Transaction_Rolledback_exception_test; procedure Invalid_Transaction_exception_test (Self : access Object) is pragma Unreferenced (Self); Member : CORBA.Invalid_Transaction_Members; begin Member := (Minor => 128, Completed => CORBA.Completed_Yes); CORBA.Raise_Invalid_Transaction (Member); end Invalid_Transaction_exception_test; end all_exceptions.Impl; polyorb-2.8~20110207.orig/testsuite/corba/all_exceptions/all_exceptions.idl0000644000175000017500000000226711750740340026244 0ustar xavierxavierinterface all_exceptions { void Unknown_exception_test (); void Bad_Param_exception_test (); void No_Memory_exception_test (); void Imp_Limit_exception_test (); void Comm_Failure_exception_test (); void Inv_Objref_exception_test (); void No_Permission_exception_test (); void Internal_exception_test (); void Marshal_exception_test (); void Initialization_Failure_exception_test (); void No_Implement_exception_test (); void Bad_Typecode_exception_test (); void Bad_Operation_exception_test (); void No_Resources_exception_test (); void No_Response_exception_test (); void Persist_Store_exception_test (); void Bad_Inv_Order_exception_test (); void Transient_exception_test (); void Free_Mem_exception_test (); void Inv_Ident_exception_test (); void Inv_Flag_exception_test (); void Intf_Repos_exception_test (); void Bad_Context_exception_test (); void Obj_Adapter_exception_test (); void Data_Conversion_exception_test (); void Object_Not_Exist_exception_test (); void Transaction_Required_exception_test (); void Transaction_Rolledback_exception_test (); void Invalid_Transaction_exception_test (); }; polyorb-2.8~20110207.orig/testsuite/corba/all_exceptions/all_exceptions-impl.ads0000644000175000017500000001043411750740340027175 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- A L L _ E X C E P T I O N S . I M P L -- -- -- -- S p e c -- -- -- -- Copyright (C) 2004 Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by ACT Europe. -- -- (email: sales@act-europe.fr) -- -- -- ------------------------------------------------------------------------------ with PortableServer; package all_exceptions.Impl is type Object is new PortableServer.Servant_Base with private; type Object_Ptr is access all Object; procedure Unknown_exception_test (Self : access Object); procedure Bad_Param_exception_test (Self : access Object); procedure No_Memory_exception_test (Self : access Object); procedure Imp_Limit_exception_test (Self : access Object); procedure Comm_Failure_exception_test (Self : access Object); procedure Inv_Objref_exception_test (Self : access Object); procedure No_Permission_exception_test (Self : access Object); procedure Internal_exception_test (Self : access Object); procedure Marshal_exception_test (Self : access Object); procedure Initialization_Failure_exception_test (Self : access Object); procedure No_Implement_exception_test (Self : access Object); procedure Bad_Typecode_exception_test (Self : access Object); procedure Bad_Operation_exception_test (Self : access Object); procedure No_Resources_exception_test (Self : access Object); procedure No_Response_exception_test (Self : access Object); procedure Persist_Store_exception_test (Self : access Object); procedure Bad_Inv_Order_exception_test (Self : access Object); procedure Transient_exception_test (Self : access Object); procedure Free_Mem_exception_test (Self : access Object); procedure Inv_Ident_exception_test (Self : access Object); procedure Inv_Flag_exception_test (Self : access Object); procedure Intf_Repos_exception_test (Self : access Object); procedure Bad_Context_exception_test (Self : access Object); procedure Obj_Adapter_exception_test (Self : access Object); procedure Data_Conversion_exception_test (Self : access Object); procedure Object_Not_Exist_exception_test (Self : access Object); procedure Transaction_Required_exception_test (Self : access Object); procedure Transaction_Rolledback_exception_test (Self : access Object); procedure Invalid_Transaction_exception_test (Self : access Object); private type Object is new PortableServer.Servant_Base with null record; end all_exceptions.Impl; polyorb-2.8~20110207.orig/testsuite/corba/all_exceptions/local.gpr0000644000175000017500000000070211750740340024335 0ustar xavierxavierwith "polyorb", "polyorb_test_common"; project local is Dir := external ("Test_Dir"); Obj_Dir := PolyORB_Test_Common.Build_Dir & Dir; for Object_Dir use Obj_Dir; for Source_Dirs use (Obj_Dir, PolyORB_Test_Common.Source_Dir & Dir); package Compiler is for Default_Switches ("Ada") use PolyORB_Test_Common.Compiler'Default_Switches ("Ada"); end Compiler; for Main use ("server.adb", "client.adb"); end local; polyorb-2.8~20110207.orig/testsuite/corba/all_exceptions/server.adb0000644000175000017500000000553711750740340024522 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- S E R V E R -- -- -- -- B o d y -- -- -- -- Copyright (C) 2004 Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by ACT Europe. -- -- (email: sales@act-europe.fr) -- -- -- ------------------------------------------------------------------------------ with Ada.Text_IO; with CORBA.Impl; with CORBA.Object; with CORBA.ORB; with PortableServer; with all_exceptions; with all_exceptions.Impl; with PolyORB.CORBA_P.Server_Tools; with PolyORB.Setup.No_Tasking_Server; pragma Warnings (Off, PolyORB.Setup.No_Tasking_Server); procedure Server is use PolyORB.CORBA_P.Server_Tools; begin Ada.Text_IO.Put_Line ("Server starting."); CORBA.ORB.Initialize ("ORB"); declare Obj : constant CORBA.Impl.Object_Ptr := new all_exceptions.Impl.Object; Ref : CORBA.Object.Ref; begin Initiate_Servant (PortableServer.Servant (Obj), Ref); -- Print IOR so that we can give it to a client Ada.Text_IO.Put_Line ("'" & CORBA.To_Standard_String (CORBA.Object.Object_To_String (Ref)) & "'"); -- Launch the server Initiate_Server; end; end Server; polyorb-2.8~20110207.orig/testsuite/corba/all_exceptions/client.adb0000644000175000017500000003263311750740340024467 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- C L I E N T -- -- -- -- B o d y -- -- -- -- Copyright (C) 2004-2005 Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with Ada.Command_Line; with Ada.Text_IO; with CORBA.ORB; with PolyORB.Utils.Report; with all_exceptions; use all_exceptions; with PolyORB.Setup.Client; pragma Warnings (Off, PolyORB.Setup.Client); procedure Client is use CORBA; use PolyORB.Utils.Report; IOR : CORBA.String; MyAll_Exceptions : all_exceptions.Ref; Ok : Boolean; begin New_Test ("CORBA Exceptions"); CORBA.ORB.Initialize ("ORB"); if Ada.Command_Line.Argument_Count < 1 then Ada.Text_IO.Put_Line ("usage : client "); return; end if; IOR := CORBA.To_CORBA_String (Ada.Command_Line.Argument (1)); ORB.String_To_Object (IOR, MyAll_Exceptions); Output ("test not nil reference", not Is_Nil (MyAll_Exceptions)); begin Ok := False; Unknown_exception_test (MyAll_Exceptions); exception when Unknown => Ok := True; when others => null; end; Output ("test Unknown exception", Ok); declare Member : Bad_Param_Members; begin Ok := False; Bad_Param_exception_test (MyAll_Exceptions); exception when E : Bad_Param => CORBA.Get_Members (E, Member); Ok := (Member.Completed = Completed_Maybe) and then (Member.Minor = (1 or CORBA.OMGVMCID)); when others => null; end; Output ("test Bad_Param exception", Ok); declare Member : No_Memory_Members; begin Ok := False; No_Memory_exception_test (MyAll_Exceptions); exception when E : No_Memory => CORBA.Get_Members (E, Member); Ok := (Member.Completed = Completed_Yes) and then (Member.Minor = 102); when others => null; end; Output ("test No_Memory exception", Ok); declare Member : Imp_Limit_Members; begin Ok := False; Imp_Limit_exception_test (MyAll_Exceptions); exception when E : Imp_Limit => CORBA.Get_Members (E, Member); Ok := (Member.Completed = Completed_Yes) and then (Member.Minor = 103); when others => null; end; Output ("test Imp_Limit exception", Ok); declare Member : Inv_Objref_Members; begin Ok := False; Inv_Objref_exception_test (MyAll_Exceptions); exception when E : Inv_Objref => CORBA.Get_Members (E, Member); Ok := (Member.Completed = Completed_Yes) and then (Member.Minor = 105); when others => null; end; Output ("test Inv_Objref exception", Ok); declare Member : No_Permission_Members; begin Ok := False; No_Permission_exception_test (MyAll_Exceptions); exception when E : No_Permission => CORBA.Get_Members (E, Member); Ok := (Member.Completed = Completed_Yes) and then (Member.Minor = 106); when others => null; end; Output ("test No_Permission exception", Ok); declare Member : Internal_Members; begin Ok := False; Internal_exception_test (MyAll_Exceptions); exception when E : Internal => CORBA.Get_Members (E, Member); Ok := (Member.Completed = Completed_Yes) and then (Member.Minor = 107); when others => null; end; Output ("test Internal exception", Ok); declare Member : Marshal_Members; begin Ok := False; Marshal_exception_test (MyAll_Exceptions); exception when Unknown => Ok := True; when E : Marshal => CORBA.Get_Members (E, Member); Ok := (Member.Completed = Completed_Yes) and then (Member.Minor = 108); when others => null; end; Output ("test Marshal (or Unknown) exception", Ok); declare Member : Initialization_Failure_Members; begin Ok := False; Initialization_Failure_exception_test (MyAll_Exceptions); exception when E : Initialization_Failure => CORBA.Get_Members (E, Member); Ok := (Member.Completed = Completed_Yes) and then (Member.Minor = 109); when others => null; end; Output ("test Initialization_Failure exception", Ok); declare Member : No_Implement_Members; begin Ok := False; No_Implement_exception_test (MyAll_Exceptions); exception when E : No_Implement => CORBA.Get_Members (E, Member); Ok := (Member.Completed = Completed_Yes) and then (Member.Minor = 110); when others => null; end; Output ("test No_Implement exception", Ok); declare Member : Bad_Typecode_Members; begin Ok := False; Bad_Typecode_exception_test (MyAll_Exceptions); exception when E : Bad_TypeCode => CORBA.Get_Members (E, Member); Ok := (Member.Completed = Completed_Yes) and then (Member.Minor = 111); when others => null; end; Output ("test Bad_Typecode exception", Ok); declare Member : Bad_Operation_Members; begin Ok := False; Bad_Operation_exception_test (MyAll_Exceptions); exception when E : Bad_Operation => CORBA.Get_Members (E, Member); Ok := (Member.Completed = Completed_Yes) and then (Member.Minor = 112); when others => null; end; Output ("test Bad_Operation exception", Ok); declare Member : No_Resources_Members; begin Ok := False; No_Resources_exception_test (MyAll_Exceptions); exception when Unknown => Ok := True; when E : No_Resources => CORBA.Get_Members (E, Member); Ok := (Member.Completed = Completed_Yes) and then (Member.Minor = 113); when others => null; end; Output ("test No_Resources (or Unknown) exception", Ok); declare Member : No_Response_Members; begin Ok := False; No_Response_exception_test (MyAll_Exceptions); exception when Unknown => Ok := True; when E : No_Response => CORBA.Get_Members (E, Member); Ok := (Member.Completed = Completed_Yes) and then (Member.Minor = 114); when others => null; end; Output ("test No_Response (or Unknown) exception", Ok); declare Member : Persist_Store_Members; begin Ok := False; Persist_Store_exception_test (MyAll_Exceptions); exception when E : Persist_Store => CORBA.Get_Members (E, Member); Ok := (Member.Completed = Completed_Yes) and then (Member.Minor = 115); when others => null; end; Output ("test Persist_Store exception", Ok); declare Member : Bad_Inv_Order_Members; begin Ok := False; Bad_Inv_Order_exception_test (MyAll_Exceptions); exception when E : Bad_Inv_Order => CORBA.Get_Members (E, Member); Ok := (Member.Completed = Completed_Yes) and then (Member.Minor = 116); when others => null; end; Output ("test Bad_Inv_Order exception", Ok); declare Member : Free_Mem_Members; begin Ok := False; Free_Mem_exception_test (MyAll_Exceptions); exception when E : Free_Mem => CORBA.Get_Members (E, Member); Ok := (Member.Completed = Completed_Yes) and then (Member.Minor = 118); when others => null; end; Output ("test Free_Mem exception", Ok); declare Member : Inv_Ident_Members; begin Ok := False; Inv_Ident_exception_test (MyAll_Exceptions); exception when E : Inv_Ident => CORBA.Get_Members (E, Member); Ok := (Member.Completed = Completed_Yes) and then (Member.Minor = 119); when others => null; end; Output ("test Inv_Ident exception", Ok); declare Member : Inv_Flag_Members; begin Ok := False; Inv_Flag_exception_test (MyAll_Exceptions); exception when E : Inv_Flag => CORBA.Get_Members (E, Member); Ok := (Member.Completed = Completed_Yes) and then (Member.Minor = 120); when others => null; end; Output ("test Inv_Flag exception", Ok); declare Member : Intf_Repos_Members; begin Ok := False; Intf_Repos_exception_test (MyAll_Exceptions); exception when E : Intf_Repos => CORBA.Get_Members (E, Member); Ok := (Member.Completed = Completed_Yes) and then (Member.Minor = 121); when others => null; end; Output ("test Intf_Repos exception", Ok); declare Member : Bad_Context_Members; begin Ok := False; Bad_Context_exception_test (MyAll_Exceptions); exception when E : Bad_Context => CORBA.Get_Members (E, Member); Ok := (Member.Completed = Completed_Yes) and then (Member.Minor = 122); when others => null; end; Output ("test Bad_Context exception", Ok); declare Member : Obj_Adapter_Members; begin Ok := False; Obj_Adapter_exception_test (MyAll_Exceptions); exception when E : Obj_Adapter => CORBA.Get_Members (E, Member); Ok := (Member.Completed = Completed_Yes) and then (Member.Minor = 123); when others => null; end; Output ("test Obj_Adapter exception", Ok); declare Member : Data_Conversion_Members; begin Ok := False; Data_Conversion_exception_test (MyAll_Exceptions); exception when E : Data_Conversion => CORBA.Get_Members (E, Member); Ok := (Member.Completed = Completed_Yes) and then (Member.Minor = 124); when others => null; end; Output ("test Data_Conversion exception", Ok); declare Member : Object_Not_Exist_Members; begin Ok := False; Object_Not_Exist_exception_test (MyAll_Exceptions); exception when E : Object_Not_Exist => CORBA.Get_Members (E, Member); Ok := (Member.Completed = Completed_Yes) and then (Member.Minor = 125); when others => null; end; Output ("test Object_Not_Exist exception", Ok); declare Member : Transaction_Required_Members; begin Ok := False; Transaction_Required_exception_test (MyAll_Exceptions); exception when E : Transaction_Required => CORBA.Get_Members (E, Member); Ok := (Member.Completed = Completed_Yes) and then (Member.Minor = 126); when others => null; end; Output ("test Transaction_Required exception", Ok); declare Member : Transaction_Rolledback_Members; begin Ok := False; Transaction_Rolledback_exception_test (MyAll_Exceptions); exception when E : Transaction_Rolledback => CORBA.Get_Members (E, Member); Ok := (Member.Completed = Completed_Yes) and then (Member.Minor = 127); when others => null; end; Output ("test Transaction_Rolledback exception", Ok); declare Member : Invalid_Transaction_Members; begin Ok := False; Invalid_Transaction_exception_test (MyAll_Exceptions); exception when Unknown => Ok := True; when E : Invalid_Transaction => CORBA.Get_Members (E, Member); Ok := (Member.Completed = Completed_Yes) and then (Member.Minor = 128); when others => null; end; Output ("test Invalid_Transaction (or Unknown) exception", Ok); End_Report; end Client; polyorb-2.8~20110207.orig/testsuite/corba/orb_init/0000755000175000017500000000000011750740340021326 5ustar xavierxavierpolyorb-2.8~20110207.orig/testsuite/corba/orb_init/Makefile.local0000644000175000017500000000000011750740340024045 0ustar xavierxavierpolyorb-2.8~20110207.orig/testsuite/corba/orb_init/test000.adb0000644000175000017500000001165011750740340023200 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- T E S T 0 0 0 -- -- -- -- B o d y -- -- -- -- Copyright (C) 2004 Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by ACT Europe. -- -- (email: sales@act-europe.fr) -- -- -- ------------------------------------------------------------------------------ with CORBA.ORB; with PolyORB.Setup.No_Tasking_Server; pragma Warnings (Off, PolyORB.Setup.No_Tasking_Server); with PolyORB.Utils.Report; use PolyORB.Utils.Report; procedure Test000 is use CORBA.ORB; use CORBA; begin New_Test ("ORB_Init"); -- Test 1 declare Argv : Arg_List := Command_Line_Arguments; begin CORBA.ORB.Init (To_CORBA_String ("ORB"), Argv); Output ("Default initialisation", True); end; -- Test 2: Initialisation with bad suffix declare Argv : Arg_List; begin Append (Argv, To_CORBA_String ("-ORBtoto")); Append (Argv, To_CORBA_String ("truc")); CORBA.ORB.Init (To_CORBA_String ("ORB"), Argv); Output ("Initialisation with bad suffix", False); exception when CORBA.Bad_Param => Output ("Initialisation with bad suffix", True); end; -- Test 3: Initialisation with bad reference declare Argv : Arg_List; begin Append (Argv, To_CORBA_String ("-ORBInitRef")); Append (Argv, To_CORBA_String ("truc=bidule")); CORBA.ORB.Init (To_CORBA_String ("ORB"), Argv); Output ("Initialisation with bad reference", False); exception when CORBA.Bad_Param => Output ("Initialisation with bad reference", True); end; -- Test 4: Initial reference set up declare Argv : Arg_List; begin Append (Argv, To_CORBA_String ("-ORBInitRef")); Append (Argv, To_CORBA_String ("truc=corbaloc:miop:1.0@1.0-TestDomain-5506/239.239.239.18:5678")); Append (Argv, To_CORBA_String ("foo")); CORBA.ORB.Init (To_CORBA_String ("ORB"), Argv); Output ("Initial reference set up", True); Output ("Length is correct", Length (Argv) = 1); end; -- Test 5: Initialisation with no reference declare Argv : Arg_List; begin Append (Argv, To_CORBA_String ("-ORBInitRef")); Append (Argv, To_CORBA_String ("truc")); CORBA.ORB.Init (To_CORBA_String ("ORB"), Argv); Output ("Initialisation with no reference", False); exception when CORBA.Bad_Param => Output ("Initialisation with no reference", True); end; -- Test 6: Initialisation with no parameter declare Argv : Arg_List; begin Append (Argv, To_CORBA_String ("-ORBInitRef")); CORBA.ORB.Init (To_CORBA_String ("ORB"), Argv); Output ("Initialisation with no parameter", False); exception when CORBA.Bad_Param => Output ("Initialisation with no parameter", True); end; -- Test 7: Initial reference set up declare Argv : Arg_List; begin Append (Argv, To_CORBA_String ("-ORBInitReftr=corbaloc:miop:1.0@1.0-T-5/239.239.239.18:58")); CORBA.ORB.Init (To_CORBA_String ("ORB"), Argv); Output ("Initial reference set up", True); Output ("Length is correct", Length (Argv) = 0); end; End_Report; end Test000; polyorb-2.8~20110207.orig/testsuite/corba/orb_init/local.gpr0000644000175000017500000000066511750740340023141 0ustar xavierxavierwith "polyorb", "polyorb_test_common"; project local is Dir := external ("Test_Dir"); Obj_Dir := PolyORB_Test_Common.Build_Dir & Dir; for Object_Dir use Obj_Dir; for Source_Dirs use (Obj_Dir, PolyORB_Test_Common.Source_Dir & Dir); package Compiler is for Default_Switches ("Ada") use PolyORB_Test_Common.Compiler'Default_Switches ("Ada"); end Compiler; for Main use ("test000.adb"); end local; polyorb-2.8~20110207.orig/testsuite/corba/rtcorba/0000755000175000017500000000000011750740340021155 5ustar xavierxavierpolyorb-2.8~20110207.orig/testsuite/corba/rtcorba/rtpoa/0000755000175000017500000000000011750740340022302 5ustar xavierxavierpolyorb-2.8~20110207.orig/testsuite/corba/rtcorba/rtpoa/echo-impl.ads0000644000175000017500000000460511750740340024655 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- E C H O . I M P L -- -- -- -- S p e c -- -- -- -- Copyright (C) 2002-2008, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by ACT Europe. -- -- (email: sales@act-europe.fr) -- -- -- ------------------------------------------------------------------------------ with CORBA; with PortableServer; package Echo.Impl is -- My own implementation of echo object. -- This is simply used to define the operations. type Object is new PortableServer.Servant_Base with null record; type Object_Acc is access Object; function EchoString (Self : access Object; Mesg : CORBA.String) return CORBA.String; end Echo.Impl; polyorb-2.8~20110207.orig/testsuite/corba/rtcorba/rtpoa/echo.idl0000644000175000017500000000007211750740340023711 0ustar xavierxavierinterface Echo { string echoString (in string Mesg); }; polyorb-2.8~20110207.orig/testsuite/corba/rtcorba/rtpoa/Makefile.local0000644000175000017500000000013211750740340025027 0ustar xavierxavier${current_dir}echo.idl-stamp: idlac_flags := ${test_target}: ${current_dir}echo.idl-stamp polyorb-2.8~20110207.orig/testsuite/corba/rtcorba/rtpoa/echo-impl.adb0000644000175000017500000000510511750740340024630 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- E C H O . I M P L -- -- -- -- B o d y -- -- -- -- Copyright (C) 2002-2008, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by ACT Europe. -- -- (email: sales@act-europe.fr) -- -- -- ------------------------------------------------------------------------------ with Ada.Text_IO; with Echo.Skel; pragma Warnings (Off, Echo.Skel); -- No entity from Echo.Skel is referenced. package body Echo.Impl is ---------------- -- EchoString -- ---------------- function EchoString (Self : access Object; Mesg : CORBA.String) return CORBA.String is pragma Warnings (Off); pragma Unreferenced (Self); pragma Warnings (On); begin Ada.Text_IO.Put_Line ("Echoing string: « " & CORBA.To_Standard_String (Mesg) & " »"); return Mesg; end EchoString; end Echo.Impl; polyorb-2.8~20110207.orig/testsuite/corba/rtcorba/rtpoa/test000.adb0000644000175000017500000005734611750740340024170 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- T E S T 0 0 0 -- -- -- -- B o d y -- -- -- -- Copyright (C) 2004-2007, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with Ada.Exceptions; with Ada.Text_IO; with CORBA.Impl; with CORBA.Object; with CORBA.ORB; with CORBA.Policy; with PortableServer.POA.Helper; with PortableServer.POAManager; with RTCORBA.RTORB.Helper; with RTCORBA.PriorityMapping.Linear; with RTCORBA.PriorityModelPolicy; with RTCORBA.ThreadpoolPolicy; with RTPortableServer.POA.Helper; with PolyORB.RTCORBA_P.Setup; with Echo.Impl; with PolyORB.Utils.Report; -- Begin of PolyORB's setup with PolyORB.ORB.Thread_Pool; pragma Warnings (Off, PolyORB.ORB.Thread_Pool); with PolyORB.ORB_Controller.Workers; pragma Warnings (Off, PolyORB.ORB_Controller.Workers); with PolyORB.Request_Scheduler.Servant_Lane; pragma Warnings (Off, PolyORB.Request_Scheduler.Servant_Lane); with PolyORB.Setup.Tasking.Full_Tasking; pragma Warnings (Off, PolyORB.Setup.Tasking.Full_Tasking); with PolyORB.Setup.Base; pragma Warnings (Off, PolyORB.Setup.Base); with PolyORB.Setup.OA.Basic_RT_POA; pragma Warnings (Off, PolyORB.Setup.OA.Basic_RT_POA); with PolyORB.Setup.IIOP; pragma Warnings (Off, PolyORB.Setup.IIOP); with PolyORB.Setup.Access_Points.IIOP; pragma Warnings (Off, PolyORB.Setup.Access_Points.IIOP); with PolyORB.GIOP_P.Tagged_Components.Policies.Priority_Model_Policy; pragma Warnings (Off, PolyORB.GIOP_P.Tagged_Components.Policies.Priority_Model_Policy); -- End of PolyORB's setup procedure Test000 is use Ada.Text_IO; use CORBA.ORB; use PortableServer; use PortableServer.POA; use RTCORBA; use RTCORBA.RTORB; use PolyORB.Utils.Report; Priority_Mapping : RTCORBA.PriorityMapping.Linear.Object; begin CORBA.ORB.Initialize ("ORB"); -- Setting up default Priority Mapping for this node PolyORB.RTCORBA_P.Setup.Set_Priority_Mapping (Priority_Mapping); declare use CORBA.Policy.IDL_SEQUENCE_Policy; RT_ORB : RTCORBA.RTORB.Local_Ref; Root_POA : PortableServer.POA.Local_Ref; procedure Test_SERVER_DECLARED_1; procedure Test_SERVER_DECLARED_2; procedure Test_CLIENT_PROPAGATED_1; procedure Test_CLIENT_PROPAGATED_2; ---------------------------- -- Test_SERVER_DECLARED_1 -- ---------------------------- procedure Test_SERVER_DECLARED_1 is Obj_Server : constant CORBA.Impl.Object_Ptr := new Echo.Impl.Object; Priority_Model_Policy_Ref_Server : RTCORBA.PriorityModelPolicy.Local_Ref; Child_POA_Server : RTPortableServer.POA.Local_Ref; Policies_Server : CORBA.Policy.PolicyList; Ref_Server : CORBA.Object.Ref; begin New_Test ("SERVER_DECLARED POA #1"); -- Set up SERVER_DECLARED priority model policy Priority_Model_Policy_Ref_Server := Create_Priority_Model_Policy (RT_ORB, SERVER_DECLARED, 10000); Output ("SERVER_DECLARED policy declared", True); -- Create Child POA with SERVER_DECLARED priority model policy Append (Policies_Server, CORBA.Policy.Ref (Priority_Model_Policy_Ref_Server)); Child_POA_Server := RTPortableServer.POA.Helper.To_Local_Ref (PortableServer.POA.Create_POA (Root_POA, CORBA.To_CORBA_String ("Child_POA_Server"), PortableServer.POA.Get_The_POAManager (Root_POA), Policies_Server)); -- Set up new object and attach it to Child_POA Ref_Server := PortableServer.POA.Servant_To_Reference (PortableServer.POA.Local_Ref (Child_POA_Server), PortableServer.Servant (Obj_Server)); Output ("Implicit activation of an object with SERVER_DECLARED " & "policy", True); -- Output object IOR New_Line; Put_Line ("'" & CORBA.To_Standard_String (CORBA.Object.Object_To_String (Ref_Server)) & "'"); New_Line; -- Create reference with priority begin declare Obj_Ref2 : constant CORBA.Object.Ref := RTPortableServer.POA.Create_Reference_With_Priority (Child_POA_Server, CORBA.To_CORBA_String (Echo.Repository_Id), 10000); pragma Unreferenced (Obj_Ref2); begin Output ("Create_Reference_With_Priority raised an exception", False); end; exception when PortableServer.POA.WrongPolicy => Output ("Create_Reference_With_Priority raised an exception", True); end; -- Create reference with id and priority begin declare Oid : constant PortableServer.ObjectId := PortableServer.String_To_ObjectId ("dead"); Obj_Ref2 : constant CORBA.Object.Ref := RTPortableServer.POA.Create_Reference_With_Id_And_Priority (Child_POA_Server, Oid, CORBA.To_CORBA_String (Echo.Repository_Id), 10000); pragma Unreferenced (Obj_Ref2); begin Output ("Create_Reference_With_Id_And_Priority raised an exception", False); end; exception when PortableServer.POA.WrongPolicy => Output ("Create_Reference_With_Id_And_Priority raised an exception", True); end; -- Activate servant with priority begin declare Obj2 : constant CORBA.Impl.Object_Ptr := new Echo.Impl.Object; Oid : constant PortableServer.ObjectId := RTPortableServer.POA.Activate_Object_With_Priority (Child_POA_Server, PortableServer.Servant (Obj2), 10000); pragma Unreferenced (Oid); begin Output ("Activate_Object_With_Priority raised no exception", False); end; exception when PortableServer.POA.WrongPolicy => Output ("Activate_Object_With_Priority raised an exception", True); end; -- Activate servant with id and priority begin declare Obj2 : constant CORBA.Impl.Object_Ptr := new Echo.Impl.Object; Oid : constant PortableServer.ObjectId := PortableServer.String_To_ObjectId ("dead"); begin RTPortableServer.POA.Activate_Object_With_Id_And_Priority (Child_POA_Server, Oid, PortableServer.Servant (Obj2), 10000); Output ("Activate_Object_With_Id_And_Priority raised no exception", False); end; exception when PortableServer.POA.WrongPolicy => Output ("Activate_Object_With_Id_And_Priority raised no exception", True); end; Destroy (PortableServer.POA.Local_Ref (Child_POA_Server), False, False); Output ("All tests done", True); end Test_SERVER_DECLARED_1; ---------------------------- -- Test_SERVER_DECLARED_2 -- ---------------------------- procedure Test_SERVER_DECLARED_2 is Obj_Server : constant CORBA.Impl.Object_Ptr := new Echo.Impl.Object; Priority_Model_Policy_Ref_Server : RTCORBA.PriorityModelPolicy.Local_Ref; Child_POA_Server : RTPortableServer.POA.Local_Ref; Policies_Server : CORBA.Policy.PolicyList; Ref_Server : CORBA.Object.Ref; Thread_Pool_Id : RTCORBA.ThreadpoolId; Thread_Pool_Policy_Ref : RTCORBA.ThreadpoolPolicy.Local_Ref; No_Implicit_Activation_Policy : constant CORBA.Policy.Ref := CORBA.Policy.Ref (Create_Implicit_Activation_Policy (NO_IMPLICIT_ACTIVATION)); begin New_Test ("SERVER_DECLARED POA #2"); -- Set up SERVER_DECLARED priority model policy Priority_Model_Policy_Ref_Server := Create_Priority_Model_Policy (RT_ORB, SERVER_DECLARED, 12000); Output ("SERVER_DECLARED policy declared", True); -- Create Threadpool Thread_Pool_Id := RTCORBA.RTORB.Create_Threadpool (RT_ORB, Stacksize => 262_144, Static_Threads => 2, Dynamic_Threads => 0, Default_Priority => 12000, Allow_Request_Buffering => False, Max_Buffered_Requests => 1, Max_Request_Buffer_Size => 0); Output ("Thread Pool created with id" & RTCORBA.ThreadpoolId'Image (Thread_Pool_Id), True); -- Construct Thread Pool policy from previous threadpool Thread_Pool_Policy_Ref := RTCORBA.RTORB.Create_Threadpool_Policy (RT_ORB, Thread_Pool_Id); Output ("Create Threadpool policy", True); -- Create Child POA with SERVER_DECLARED priority model policy -- and NO_IMPLICIT_ACTIVATION activation policy Append (Policies_Server, CORBA.Policy.Ref (Priority_Model_Policy_Ref_Server)); Append (Policies_Server, CORBA.Policy.Ref (Thread_Pool_Policy_Ref)); Append (Policies_Server, No_Implicit_Activation_Policy); Output ("NO_IMPLICIT_ACTIVATION policy declared", True); Child_POA_Server := RTPortableServer.POA.Helper.To_Local_Ref (PortableServer.POA.Create_POA (Root_POA, CORBA.To_CORBA_String ("Child_POA_Server"), PortableServer.POA.Get_The_POAManager (Root_POA), Policies_Server)); Output ("Created child POA with SERVER_DECLARED policy", True); -- Set up new object and attach it to Child_POA begin Ref_Server := PortableServer.POA.Servant_To_Reference (PortableServer.POA.Local_Ref (Child_POA_Server), PortableServer.Servant (Obj_Server)); Output ("Created object with SERVER_DECLARED policy " & "raised no exception", False); exception when PortableServer.POA.ServantNotActive => Output ("Created object with SERVER_DECLARED policy " & "raised PortableServer.POA.ServantNotActive", True); end; -- Create reference with priority begin declare Obj_Ref2 : constant CORBA.Object.Ref := RTPortableServer.POA.Create_Reference_With_Priority (Child_POA_Server, CORBA.To_CORBA_String (Echo.Repository_Id), 7); pragma Unreferenced (Obj_Ref2); begin Output ("Create_Reference_With_Priority raised an exception", False); end; exception when CORBA.Bad_Param => Output ("Create_Reference_With_Priority raised an exception", True); end; -- Create reference begin declare Obj_Ref2 : constant CORBA.Object.Ref := RTPortableServer.POA.Create_Reference_With_Priority (Child_POA_Server, CORBA.To_CORBA_String (Echo.Repository_Id), 12000); begin Output ("Create_Reference_With_Priority raised no exception", True); -- Output object IOR New_Line; Put_Line ("'" & CORBA.To_Standard_String (CORBA.Object.Object_To_String (Obj_Ref2)) & "'"); New_Line; end; exception when others => Output ("Create_Reference_With_Priority raised no exception", False); raise; end; -- Activate servant with priority begin declare Obj2 : constant CORBA.Impl.Object_Ptr := new Echo.Impl.Object; Oid : constant PortableServer.ObjectId := RTPortableServer.POA.Activate_Object_With_Priority (Child_POA_Server, PortableServer.Servant (Obj2), 12000); begin Output ("Activate_Object_With_Priority did not raise exception", True); -- Call Servant_To_Reference Ref_Server := PortableServer.POA.Id_To_Reference (PortableServer.POA.Local_Ref (Child_POA_Server), Oid); -- Output object IOR New_Line; Put_Line ("'" & CORBA.To_Standard_String (CORBA.Object.Object_To_String (Ref_Server)) & "'"); New_Line; end; exception when PortableServer.POA.WrongPolicy => Output ("Activate_Object_With_Priority raise exception", False); end; Destroy (PortableServer.POA.Local_Ref (Child_POA_Server), False, False); Output ("All tests done", True); end Test_SERVER_DECLARED_2; ------------------------------ -- Test_CLIENT_PROPAGATED_1 -- ------------------------------ procedure Test_CLIENT_PROPAGATED_1 is Obj_Client : constant CORBA.Impl.Object_Ptr := new Echo.Impl.Object; Priority_Model_Policy_Ref_Client : RTCORBA.PriorityModelPolicy.Local_Ref; Child_POA_Client : RTPortableServer.POA.Local_Ref; Policies_Client : CORBA.Policy.PolicyList; Ref_Client : CORBA.Object.Ref; begin New_Test ("CLIENT_PROPAGATED POA #1"); -- Set up CLIENT_PROPAGATED priority model policy Priority_Model_Policy_Ref_Client := Create_Priority_Model_Policy (RT_ORB, CLIENT_PROPAGATED, 14000); Output ("CLIENT_PROPAGATED policy declared", True); -- Create Child POA with CLIENT_PROPAGATED priority model policy Append (Policies_Client, CORBA.Policy.Ref (Priority_Model_Policy_Ref_Client)); Child_POA_Client := RTPortableServer.POA.Helper.To_Local_Ref (PortableServer.POA.Create_POA (Root_POA, CORBA.To_CORBA_String ("Child_POA_Client"), PortableServer.POA.Get_The_POAManager (Root_POA), Policies_Client)); Output ("Created child POA with CLIENT_PROPAGATED policy", True); -- Set up new object and attach it to Child_POA Ref_Client := PortableServer.POA.Servant_To_Reference (PortableServer.POA.Local_Ref (Child_POA_Client), PortableServer.Servant (Obj_Client)); Output ("Implicit activation of an object with CLIENT_PROPAGATED " & "policy", True); -- Output object IOR New_Line; Put_Line ("'" & CORBA.To_Standard_String (CORBA.Object.Object_To_String (Ref_Client)) & "'"); New_Line; -- Create reference begin declare Obj_Ref2 : constant CORBA.Object.Ref := RTPortableServer.POA.Create_Reference_With_Priority (Child_POA_Client, CORBA.To_CORBA_String (Echo.Repository_Id), 7); pragma Unreferenced (Obj_Ref2); begin Output ("Create_Reference_With_Priority raised an exception", False); end; exception when PortableServer.POA.WrongPolicy => Output ("Create_Reference_With_Priority raised an exception", True); end; -- Activate servant with priority begin declare Obj2 : constant CORBA.Impl.Object_Ptr := new Echo.Impl.Object; Oid : constant PortableServer.ObjectId := RTPortableServer.POA.Activate_Object_With_Priority (Child_POA_Client, PortableServer.Servant (Obj2), 7); pragma Unreferenced (Oid); begin Output ("Activate_Object_With_Priority raised no exception", False); end; exception when PortableServer.POA.WrongPolicy => Output ("Activate_Object_With_Priority raised an exception", True); end; -- Activate servant with id & priority begin declare Obj2 : constant CORBA.Impl.Object_Ptr := new Echo.Impl.Object; Oid : constant PortableServer.ObjectId := PortableServer.String_To_ObjectId ("dead"); begin RTPortableServer.POA.Activate_Object_With_Id_And_Priority (Child_POA_Client, Oid, PortableServer.Servant (Obj2), 7); Output ("Activate_Object_With_id_and_Priority raised no exception", False); end; exception when PortableServer.POA.WrongPolicy => Output ("Activate_Object_With_id_and_Priority raised no exception", True); end; Destroy (PortableServer.POA.Local_Ref (Child_POA_Client), False, False); Output ("All tests done", True); end Test_CLIENT_PROPAGATED_1; ------------------------------ -- Test_CLIENT_PROPAGATED_2 -- ------------------------------ procedure Test_CLIENT_PROPAGATED_2 is Obj_Client : constant CORBA.Impl.Object_Ptr := new Echo.Impl.Object; Priority_Model_Policy_Ref_Client : RTCORBA.PriorityModelPolicy.Local_Ref; Child_POA_Client : RTPortableServer.POA.Local_Ref; Policies_Client : CORBA.Policy.PolicyList; Ref_Client : CORBA.Object.Ref; -- pragma Unreferenced (Ref_Client); pragma Warnings (Off, Ref_Client); -- WAG:5.02 DB08-008 -- Assigned but never read No_Implicit_Activation_Policy : constant CORBA.Policy.Ref := CORBA.Policy.Ref (Create_Implicit_Activation_Policy (NO_IMPLICIT_ACTIVATION)); begin New_Test ("CLIENT_PROPAGATED POA #2"); -- Set up CLIENT_PROPAGATED priority model policy Priority_Model_Policy_Ref_Client := Create_Priority_Model_Policy (RT_ORB, CLIENT_PROPAGATED, 8); Output ("CLIENT_PROPAGATED policy declared", True); -- Create Child POA with CLIENT_PROPAGATED priority model policy -- and NO_IMPLICIT_ACTIVATION activation policy Append (Policies_Client, CORBA.Policy.Ref (Priority_Model_Policy_Ref_Client)); Append (Policies_Client, No_Implicit_Activation_Policy); Output ("NO_IMPLICIT_ACTIVATION policy declared", True); Child_POA_Client := RTPortableServer.POA.Helper.To_Local_Ref (PortableServer.POA.Create_POA (Root_POA, CORBA.To_CORBA_String ("Child_POA_Client"), PortableServer.POA.Get_The_POAManager (Root_POA), Policies_Client)); Output ("Created child POA with CLIENT_PROPAGATED policy", True); -- Set up new object and attach it to Child_POA begin Ref_Client := PortableServer.POA.Servant_To_Reference (PortableServer.POA.Local_Ref (Child_POA_Client), PortableServer.Servant (Obj_Client)); Output ("Creating object with CLIENT_PROPAGATED policy " & "raised no exception", False); exception when PortableServer.POA.ServantNotActive => Output ("Created object with CLIENT_PROPAGATED policy " & "raised PortableServer.POA.ServantNotActive", True); end; -- Activate servant with priority begin declare Oid : constant PortableServer.ObjectId := RTPortableServer.POA.Activate_Object_With_Priority (Child_POA_Client, PortableServer.Servant (Obj_Client), 8); pragma Unreferenced (Oid); begin Output ("Activate_Object_With_Priority did not raise exception", False); end; exception when PortableServer.POA.WrongPolicy => Output ("Activate_Object_With_Priority raise exception", True); end; Destroy (PortableServer.POA.Local_Ref (Child_POA_Client), False, False); Output ("All tests done", True); end Test_CLIENT_PROPAGATED_2; begin New_Test ("RTPOA"); -- Retrieve RT ORB RT_ORB := RTCORBA.RTORB.Helper.To_Local_Ref (Resolve_Initial_References (To_CORBA_String ("RTORB"))); Output ("Retrieved reference on RT ORB", True); -- Retrieve Root POA Root_POA := PortableServer.POA.Helper.To_Local_Ref (CORBA.ORB.Resolve_Initial_References (CORBA.ORB.To_CORBA_String ("RootPOA"))); PortableServer.POAManager.Activate (PortableServer.POA.Get_The_POAManager (Root_POA)); Output ("Retrieved and activated Root POA", True); Test_SERVER_DECLARED_1; Test_SERVER_DECLARED_2; Test_CLIENT_PROPAGATED_1; Test_CLIENT_PROPAGATED_2; End_Report; end; exception when E : others => New_Line; Put_Line ("Got exception: " & Ada.Exceptions.Exception_Information (E)); Output ("Test failed", False); End_Report; end Test000; polyorb-2.8~20110207.orig/testsuite/corba/rtcorba/rtpoa/local.gpr0000644000175000017500000000066511750740340024115 0ustar xavierxavierwith "polyorb", "polyorb_test_common"; project local is Dir := external ("Test_Dir"); Obj_Dir := PolyORB_Test_Common.Build_Dir & Dir; for Object_Dir use Obj_Dir; for Source_Dirs use (Obj_Dir, PolyORB_Test_Common.Source_Dir & Dir); package Compiler is for Default_Switches ("Ada") use PolyORB_Test_Common.Compiler'Default_Switches ("Ada"); end Compiler; for Main use ("test000.adb"); end local; polyorb-2.8~20110207.orig/testsuite/corba/rtcorba/rtorb/0000755000175000017500000000000011750740340022305 5ustar xavierxavierpolyorb-2.8~20110207.orig/testsuite/corba/rtcorba/rtorb/echo-impl.ads0000644000175000017500000000460511750740340024660 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- E C H O . I M P L -- -- -- -- S p e c -- -- -- -- Copyright (C) 2002-2008, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by ACT Europe. -- -- (email: sales@act-europe.fr) -- -- -- ------------------------------------------------------------------------------ with CORBA; with PortableServer; package Echo.Impl is -- My own implementation of echo object. -- This is simply used to define the operations. type Object is new PortableServer.Servant_Base with null record; type Object_Acc is access Object; function EchoString (Self : access Object; Mesg : CORBA.String) return CORBA.String; end Echo.Impl; polyorb-2.8~20110207.orig/testsuite/corba/rtcorba/rtorb/echo.idl0000644000175000017500000000007211750740340023714 0ustar xavierxavierinterface Echo { string echoString (in string Mesg); }; polyorb-2.8~20110207.orig/testsuite/corba/rtcorba/rtorb/Makefile.local0000644000175000017500000000013211750740340025032 0ustar xavierxavier${current_dir}echo.idl-stamp: idlac_flags := ${test_target}: ${current_dir}echo.idl-stamp polyorb-2.8~20110207.orig/testsuite/corba/rtcorba/rtorb/echo-impl.adb0000644000175000017500000000510511750740340024633 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- E C H O . I M P L -- -- -- -- B o d y -- -- -- -- Copyright (C) 2002-2008, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by ACT Europe. -- -- (email: sales@act-europe.fr) -- -- -- ------------------------------------------------------------------------------ with Ada.Text_IO; with Echo.Skel; pragma Warnings (Off, Echo.Skel); -- No entity from Echo.Skel is referenced. package body Echo.Impl is ---------------- -- EchoString -- ---------------- function EchoString (Self : access Object; Mesg : CORBA.String) return CORBA.String is pragma Warnings (Off); pragma Unreferenced (Self); pragma Warnings (On); begin Ada.Text_IO.Put_Line ("Echoing string: « " & CORBA.To_Standard_String (Mesg) & " »"); return Mesg; end EchoString; end Echo.Impl; polyorb-2.8~20110207.orig/testsuite/corba/rtcorba/rtorb/test000.adb0000644000175000017500000002632711750740340024166 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- T E S T 0 0 0 -- -- -- -- B o d y -- -- -- -- Copyright (C) 2004-2007, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with Ada.Exceptions; with Ada.Text_IO; with CORBA.Impl; with CORBA.Object; with CORBA.ORB; with CORBA.Policy; with PortableServer.POA.Helper; with PortableServer.POAManager; with RTCORBA.RTORB.Helper; with RTCORBA.PriorityMapping.Linear; with RTCORBA.PriorityModelPolicy; with RTCORBA.ThreadpoolPolicy; with RTPortableServer.POA.Helper; with PolyORB.RTCORBA_P.Setup; with Echo.Impl; with PolyORB.Utils.Report; -- Begin of PolyORB's setup with PolyORB.ORB.Thread_Per_Session; pragma Warnings (Off, PolyORB.ORB.Thread_Per_Session); with PolyORB.ORB_Controller.Workers; pragma Warnings (Off, PolyORB.ORB_Controller.Workers); with PolyORB.Request_Scheduler.Servant_Lane; pragma Warnings (Off, PolyORB.Request_Scheduler.Servant_Lane); with PolyORB.Setup.Tasking.Full_Tasking; pragma Warnings (Off, PolyORB.Setup.Tasking.Full_Tasking); with PolyORB.Setup.Base; pragma Warnings (Off, PolyORB.Setup.Base); with PolyORB.Setup.OA.Basic_RT_POA; pragma Warnings (Off, PolyORB.Setup.OA.Basic_RT_POA); with PolyORB.Setup.IIOP; pragma Warnings (Off, PolyORB.Setup.IIOP); with PolyORB.Setup.Access_Points.IIOP; pragma Warnings (Off, PolyORB.Setup.Access_Points.IIOP); with PolyORB.GIOP_P.Tagged_Components.Policies.Priority_Model_Policy; pragma Warnings (Off, PolyORB.GIOP_P.Tagged_Components.Policies.Priority_Model_Policy); -- End of PolyORB's setup procedure Test000 is use Ada.Text_IO; use CORBA.ORB; use CORBA.Policy.IDL_SEQUENCE_Policy; use PortableServer; use PortableServer.POA; use RTCORBA; use RTCORBA.RTORB; use PolyORB.Utils.Report; Priority_Mapping : RTCORBA.PriorityMapping.Linear.Object; begin CORBA.ORB.Initialize ("ORB"); -- Setting up default Priority Mapping for this node PolyORB.RTCORBA_P.Setup.Set_Priority_Mapping (Priority_Mapping); Output ("ORB is configured", True); New_Test ("RTORB"); declare RT_ORB : RTCORBA.RTORB.Local_Ref; Root_POA : PortableServer.POA.Local_Ref; begin -- Retrieve RT ORB RT_ORB := RTCORBA.RTORB.Helper.To_Local_Ref (Resolve_Initial_References (To_CORBA_String ("RTORB"))); Output ("Retrieved reference on RT ORB", True); -- Retrieve Root POA Root_POA := PortableServer.POA.Helper.To_Local_Ref (CORBA.ORB.Resolve_Initial_References (CORBA.ORB.To_CORBA_String ("RootPOA"))); PortableServer.POAManager.Activate (PortableServer.POA.Get_The_POAManager (Root_POA)); Output ("Retrieved and activated Root POA", True); -- Test simple Thread Pool New_Test ("Thread_Pool #1"); declare Thread_Pool_Id : RTCORBA.ThreadpoolId; Thread_Pool_Policy : RTCORBA.ThreadpoolPolicy.Local_Ref; -- pragma Unreferenced (Thread_Pool_Policy); pragma Warnings (Off, Thread_Pool_Policy); -- WAG:5.02 DB08-008 -- Assigned but never read begin Thread_Pool_Id := RTCORBA.RTORB.Create_Threadpool (RT_ORB, Stacksize => 262_144, Static_Threads => 2, Dynamic_Threads => 0, Default_Priority => 10, Allow_Request_Buffering => False, Max_Buffered_Requests => 1, Max_Request_Buffer_Size => 0); Output ("Thread Pool created with id" & RTCORBA.ThreadpoolId'Image (Thread_Pool_Id), True); -- Construct Thread Pool policy from previous threadpool Thread_Pool_Policy := RTCORBA.RTORB.Create_Threadpool_Policy (RT_ORB, Thread_Pool_Id); Output ("Create threadpool policy from valid ThreadpoolId", True); Destroy_Threadpool (RT_ORB, Thread_Pool_Id); Output ("Destroy threadpool", True); -- Construct Thread Pool policy from invalid threadpool declare Thread_Pool_2 : RTCORBA.ThreadpoolPolicy.Local_Ref; -- pragma Unreferenced (Thread_Pool_2); pragma Warnings (Off, Thread_Pool_2); -- WAG:5.02 DB08-008 -- Assigned but never read begin Thread_Pool_2 := RTCORBA.RTORB.Create_Threadpool_Policy (RT_ORB, Thread_Pool_Id + 1); Output ("Create threadpool policy from invalid ThreadpoolId", False); exception when RTCORBA.RTORB.InvalidThreadpool => Output ("Create threadpool policy from invalid ThreadpoolId", True); end; end; -- Test simple Thread Pool with lanes New_Test ("Thread_Pool #2"); declare use IDL_SEQUENCE_RTCORBA_ThreadpoolLane; Lane1 : constant ThreadpoolLane := ThreadpoolLane'(Lane_Priority => 3, Static_Threads => 2, Dynamic_Threads => 0); Lane2 : constant ThreadpoolLane := ThreadpoolLane'(Lane_Priority => 4, Static_Threads => 4, Dynamic_Threads => 0); Lanes : ThreadpoolLanes; Thread_Pool_Id : RTCORBA.ThreadpoolId; Thread_Pool_Policy : RTCORBA.ThreadpoolPolicy.Local_Ref; -- pragma Unreferenced (Thread_Pool_Policy); pragma Warnings (Off, Thread_Pool_Policy); -- WAG:5.02 DB08-008 -- Assigned but never read begin Append (Lanes, Lane1); Append (Lanes, Lane2); Thread_Pool_Id := Create_Threadpool_With_Lanes (RT_ORB, Stacksize => 262_144, Lanes => Lanes, Allow_Borrowing => False, Allow_Request_Buffering => False, Max_Buffered_Requests => 1, Max_Request_Buffer_Size => 0); Output ("Thread Pool created with id" & RTCORBA.ThreadpoolId'Image (Thread_Pool_Id), True); Thread_Pool_Policy := RTCORBA.RTORB.Create_Threadpool_Policy (RT_ORB, Thread_Pool_Id); Output ("Create threadpool with lanes", True); Destroy_Threadpool (RT_ORB, Thread_Pool_Id); Output ("Destroy threadpool with lanes", True); end; New_Test ("SERVER_DECLARED POA #1"); -- Set up SERVER_DECLARED priority model policy declare Obj_Server : constant CORBA.Impl.Object_Ptr := new Echo.Impl.Object; Priority_Model_Policy_Ref : RTCORBA.PriorityModelPolicy.Local_Ref; Thread_Pool_Id : RTCORBA.ThreadpoolId; Thread_Pool_Policy_Ref : RTCORBA.ThreadpoolPolicy.Local_Ref; Policies : CORBA.Policy.PolicyList; Child_POA_Server : RTPortableServer.POA.Local_Ref; Ref_Server : CORBA.Object.Ref; begin -- Create SERVER_DECLARED PriorityModel policy Priority_Model_Policy_Ref := Create_Priority_Model_Policy (RT_ORB, SERVER_DECLARED, 10000); Output ("SERVER_DECLARED policy declared", True); -- Create Threadpool Thread_Pool_Id := RTCORBA.RTORB.Create_Threadpool (RT_ORB, Stacksize => 262_144, Static_Threads => 2, Dynamic_Threads => 0, Default_Priority => 10, Allow_Request_Buffering => False, Max_Buffered_Requests => 1, Max_Request_Buffer_Size => 0); Output ("Thread Pool created with id" & RTCORBA.ThreadpoolId'Image (Thread_Pool_Id), True); -- Construct Thread Pool policy from previous threadpool Thread_Pool_Policy_Ref := RTCORBA.RTORB.Create_Threadpool_Policy (RT_ORB, Thread_Pool_Id); Output ("Create Threadpool policy", True); -- Create Child POA with SERVER_DECLARED priority model policy Append (Policies, CORBA.Policy.Ref (Priority_Model_Policy_Ref)); Append (Policies, CORBA.Policy.Ref (Thread_Pool_Policy_Ref)); Child_POA_Server := RTPortableServer.POA.Helper.To_Local_Ref (PortableServer.POA.Create_POA (Root_POA, CORBA.To_CORBA_String ("Child_POA_Server"), PortableServer.POA.Get_The_POAManager (Root_POA), Policies)); Output ("Create Child POA with these policies", True); -- Set up new object and attach it to Child_POA Ref_Server := PortableServer.POA.Servant_To_Reference (PortableServer.POA.Local_Ref (Child_POA_Server), PortableServer.Servant (Obj_Server)); Output ("Implicit activation of an object with these policies", True); -- Output object IOR New_Line; Put_Line ("'" & CORBA.To_Standard_String (CORBA.Object.Object_To_String (Ref_Server)) & "'"); New_Line; Destroy_Threadpool (RT_ORB, Thread_Pool_Id); Output ("Destroy threadpool", True); Destroy (PortableServer.POA.Local_Ref (Child_POA_Server), False, False); Output ("Destroy Child_POA", True); end; end; End_Report; exception when E : others => New_Line; Put_Line ("Got exception: " & Ada.Exceptions.Exception_Information (E)); Output ("Test failed", False); End_Report; end Test000; polyorb-2.8~20110207.orig/testsuite/corba/rtcorba/rtorb/local.gpr0000644000175000017500000000066511750740340024120 0ustar xavierxavierwith "polyorb", "polyorb_test_common"; project local is Dir := external ("Test_Dir"); Obj_Dir := PolyORB_Test_Common.Build_Dir & Dir; for Object_Dir use Obj_Dir; for Source_Dirs use (Obj_Dir, PolyORB_Test_Common.Source_Dir & Dir); package Compiler is for Default_Switches ("Ada") use PolyORB_Test_Common.Compiler'Default_Switches ("Ada"); end Compiler; for Main use ("test000.adb"); end local; polyorb-2.8~20110207.orig/testsuite/corba/rtcorba/rtcurrent/0000755000175000017500000000000011750740340023205 5ustar xavierxavierpolyorb-2.8~20110207.orig/testsuite/corba/rtcorba/rtcurrent/Makefile.local0000644000175000017500000000000011750740340025724 0ustar xavierxavierpolyorb-2.8~20110207.orig/testsuite/corba/rtcorba/rtcurrent/rtcurrent.adb0000644000175000017500000001123011750740340025702 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- R T C U R R E N T -- -- -- -- B o d y -- -- -- -- Copyright (C) 2003-2007, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with Ada.Exceptions; with Ada.Text_IO; with CORBA.ORB; with RTCORBA.Current.Helper; with RTCORBA.PriorityMapping.Linear; with PolyORB.RTCORBA_P.Setup; with PolyORB.ORB.Thread_Pool; pragma Warnings (Off, PolyORB.ORB.Thread_Pool); with PolyORB.Setup.Server; pragma Warnings (Off, PolyORB.Setup.Server); with PolyORB.ORB_Controller.Workers; pragma Warnings (Off, PolyORB.ORB_Controller.Workers); with PolyORB.Tasking.Profiles.Full_Tasking.Threads.Annotations; pragma Warnings (Off, PolyORB.Tasking.Profiles.Full_Tasking.Threads.Annotations); with PolyORB.Tasking.Profiles.Full_Tasking.Threads.Dynamic_Priorities; pragma Warnings (Off, PolyORB.Tasking.Profiles.Full_Tasking.Threads.Dynamic_Priorities); with PolyORB.Tasking.Profiles.Full_Tasking.Threads; pragma Warnings (Off, PolyORB.Tasking.Profiles.Full_Tasking.Threads); with PolyORB.Tasking.Profiles.Full_Tasking.Mutexes; pragma Warnings (Off, PolyORB.Tasking.Profiles.Full_Tasking.Mutexes); with PolyORB.Tasking.Profiles.Full_Tasking.Condition_Variables; pragma Warnings (Off, PolyORB.Tasking.Profiles.Full_Tasking.Condition_Variables); with PolyORB.Utils.Report; procedure RTCurrent is use Ada.Text_IO; use CORBA.ORB; use RTCORBA; use PolyORB.Utils.Report; Priority_Mapping : RTCORBA.PriorityMapping.Linear.Object; begin CORBA.ORB.Initialize ("ORB"); -- Setting up default Priority Mapping for this node PolyORB.RTCORBA_P.Setup.Set_Priority_Mapping (Priority_Mapping); New_Test ("RTCurrent"); declare Current : constant RTCORBA.Current.Local_Ref := RTCORBA.Current.Helper.To_Local_Ref (Resolve_Initial_References (To_CORBA_String ("RTCurrent"))); begin Output ("Retrieve reference on RTCurrent", True); declare Priority : RTCORBA.Priority; pragma Unreferenced (Priority); begin Priority := RTCORBA.Current.Get_The_Priority (Current); Output ("Retrieve RTCurrent priority raised no exception", False); exception when CORBA.Initialize => Output ("Retrieve unset RTCurrent priority raised " & "CORBA.Initialize", True); end; RTCORBA.Current.Set_The_Priority (Current, 42); Output ("Set RTCurrent priority", True); Output ("New RTCurrent priority = 42 :", RTCORBA.Current.Get_The_Priority (Current) = 42); End_Report; exception when E : others => New_Line; Put_Line ("Got exception: " & Ada.Exceptions.Exception_Information (E)); Output ("FATAL Error", False); End_Report; end; CORBA.ORB.Shutdown (False); end RTCurrent; polyorb-2.8~20110207.orig/testsuite/corba/rtcorba/rtcurrent/local.gpr0000644000175000017500000000066711750740340025022 0ustar xavierxavierwith "polyorb", "polyorb_test_common"; project local is Dir := external ("Test_Dir"); Obj_Dir := PolyORB_Test_Common.Build_Dir & Dir; for Object_Dir use Obj_Dir; for Source_Dirs use (Obj_Dir, PolyORB_Test_Common.Source_Dir & Dir); package Compiler is for Default_Switches ("Ada") use PolyORB_Test_Common.Compiler'Default_Switches ("Ada"); end Compiler; for Main use ("rtcurrent.adb"); end local; polyorb-2.8~20110207.orig/testsuite/corba/harness/0000755000175000017500000000000011750740340021164 5ustar xavierxavierpolyorb-2.8~20110207.orig/testsuite/corba/harness/server_thread_pool_hahs.adb0000644000175000017500000000477011750740340026535 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- S E R V E R _ T H R E A D _ P O O L _ H A H S -- -- -- -- B o d y -- -- -- -- Copyright (C) 2004 Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by ACT Europe. -- -- (email: sales@act-europe.fr) -- -- -- ------------------------------------------------------------------------------ with Server_Common; with PolyORB.ORB.Thread_Pool; pragma Warnings (Off, PolyORB.ORB.Thread_Pool); with PolyORB.Setup.Server; pragma Warnings (Off, PolyORB.Setup.Server); with PolyORB.Setup.Tasking.Full_Tasking; pragma Warnings (Off, PolyORB.Setup.Tasking.Full_Tasking); with PolyORB.ORB_Controller.Half_Sync_Half_Async; pragma Warnings (Off, PolyORB.ORB_Controller.Half_Sync_Half_Async); procedure Server_Thread_Pool_HAHS is begin Server_Common.Launch_Server; end Server_Thread_Pool_HAHS; polyorb-2.8~20110207.orig/testsuite/corba/harness/server_thread_per_request.adb0000644000175000017500000000436711750740340027121 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- S E R V E R _ T H R E A D _ P E R _ R E Q U E S T -- -- -- -- B o d y -- -- -- -- Copyright (C) 2004 Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by ACT Europe. -- -- (email: sales@act-europe.fr) -- -- -- ------------------------------------------------------------------------------ with Server_Common; with PolyORB.Setup.Thread_Per_Request_Server; pragma Warnings (Off, PolyORB.Setup.Thread_Per_Request_Server); procedure Server_Thread_Per_Request is begin Server_Common.Launch_Server; end Server_Thread_Per_Request; polyorb-2.8~20110207.orig/testsuite/corba/harness/client_common.adb0000644000175000017500000000274011750740340024465 0ustar xavierxavierwith Ada.Command_Line; with Ada.Real_Time; with Ada.Text_IO; with CORBA.ORB; with PolyORB.Utils.Report; with Harness; package body Client_Common is ------------------- -- Launch_Client -- ------------------- procedure Launch_Client is use Ada.Real_Time; use CORBA; use PolyORB.Utils.Report; use Harness; IOR : CORBA.String; MyHarness : Harness.Ref; Ok : Boolean := True; T0, T1, T2 : Time; Delta1 : Duration; How_Many : Integer; begin New_Test ("Harness"); CORBA.ORB.Initialize ("ORB"); if Ada.Command_Line.Argument_Count < 1 then Ada.Text_IO.Put_Line ("usage : client [how_many]"); return; end if; IOR := CORBA.To_CORBA_String (Ada.Command_Line.Argument (1)); ORB.String_To_Object (IOR, MyHarness); Output ("test not nil reference", not Is_Nil (MyHarness)); if Ada.Command_Line.Argument_Count = 2 then How_Many := Integer'Value (Ada.Command_Line.Argument (2)); else How_Many := 1_000; end if; T0 := Clock; for J in 1 .. How_Many loop Ok := Ok and (echoULong (MyHarness, 1234) = 1234); end loop; T1 := Clock; T2 := Clock; Output ("Test success", Ok); Delta1 := To_Duration (T1 - T0 - (T2 - T1)); Ada.Text_IO.Put_Line ("Time: " & Duration'Image (Delta1) & "s"); End_Report; end Launch_Client; end Client_Common; polyorb-2.8~20110207.orig/testsuite/corba/harness/Makefile.local0000644000175000017500000000014011750740340023710 0ustar xavierxavier${current_dir}harness.idl-stamp: idlac_flags := ${test_target}: ${current_dir}harness.idl-stamp polyorb-2.8~20110207.orig/testsuite/corba/harness/harness.idl0000644000175000017500000000011111750740340023312 0ustar xavierxavierinterface Harness { unsigned long echoULong(in unsigned long arg) ; }; polyorb-2.8~20110207.orig/testsuite/corba/harness/server_no_tasking.adb0000644000175000017500000000432711750740340025364 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- S E R V E R _ N O _ T A S K I N G -- -- -- -- B o d y -- -- -- -- Copyright (C) 2004 Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by ACT Europe. -- -- (email: sales@act-europe.fr) -- -- -- ------------------------------------------------------------------------------ with Server_Common; with PolyORB.Setup.No_Tasking_Server; pragma Warnings (Off, PolyORB.Setup.No_Tasking_Server); procedure Server_No_Tasking is begin Server_Common.Launch_Server; end Server_No_Tasking; polyorb-2.8~20110207.orig/testsuite/corba/harness/server_common.adb0000644000175000017500000000564611750740340024525 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- S E R V E R _ C O M M O N -- -- -- -- B o d y -- -- -- -- Copyright (C) 2004 Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by ACT Europe. -- -- (email: sales@act-europe.fr) -- -- -- ------------------------------------------------------------------------------ with Ada.Text_IO; with CORBA.Impl; with CORBA.Object; with CORBA.ORB; with PortableServer; with Harness.Impl; with PolyORB.CORBA_P.Server_Tools; package body Server_Common is ------------------- -- Launch_Server -- ------------------- procedure Launch_Server is use PolyORB.CORBA_P.Server_Tools; begin Ada.Text_IO.Put_Line ("Server starting."); CORBA.ORB.Initialize ("ORB"); declare Obj : constant CORBA.Impl.Object_Ptr := new Harness.Impl.Object; Ref : CORBA.Object.Ref; begin Initiate_Servant (PortableServer.Servant (Obj), Ref); -- Print IOR so that we can give it to a client Ada.Text_IO.Put_Line ("'" & CORBA.To_Standard_String (CORBA.Object.Object_To_String (Ref)) & "'"); -- Launch the server Initiate_Server; end; end Launch_Server; end Server_Common; polyorb-2.8~20110207.orig/testsuite/corba/harness/client_common.ads0000644000175000017500000000412111750740340024501 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- C L I E N T _ C O M M O N -- -- -- -- S p e c -- -- -- -- Copyright (C) 2004 Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by ACT Europe. -- -- (email: sales@act-europe.fr) -- -- -- ------------------------------------------------------------------------------ package Client_Common is procedure Launch_Client; end Client_Common; polyorb-2.8~20110207.orig/testsuite/corba/harness/server_thread_pool_lf.adb0000644000175000017500000000475411750740340026215 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- S E R V E R _ T H R E A D _ P O O L _ L F -- -- -- -- B o d y -- -- -- -- Copyright (C) 2004-2011, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with Server_Common; with PolyORB.ORB.Thread_Pool; pragma Warnings (Off, PolyORB.ORB.Thread_Pool); with PolyORB.Setup.Server; pragma Warnings (Off, PolyORB.Setup.Server); with PolyORB.Setup.Tasking.Full_Tasking; pragma Warnings (Off, PolyORB.Setup.Tasking.Full_Tasking); with PolyORB.ORB_Controller.Leader_Followers; pragma Warnings (Off, PolyORB.ORB_Controller.Leader_Followers); procedure Server_Thread_Pool_LF is begin Server_Common.Launch_Server; end Server_Thread_Pool_LF; polyorb-2.8~20110207.orig/testsuite/corba/harness/local.adb0000644000175000017500000000675311750740340022741 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- L O C A L -- -- -- -- B o d y -- -- -- -- Copyright (C) 2004-2005 Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with Ada.Command_Line; with Ada.Real_Time; with Ada.Text_IO; with CORBA.Impl; with CORBA.ORB; with PortableServer; with PolyORB.Utils.Report; with Harness.Impl; with PolyORB.CORBA_P.Server_Tools; with PolyORB.Setup.Thread_Pool_Server; pragma Warnings (Off, PolyORB.Setup.Thread_Pool_Server); procedure Local is use Ada.Real_Time; use CORBA; use PolyORB.Utils.Report; use Harness; use PolyORB.CORBA_P.Server_Tools; begin New_Test ("Harness"); CORBA.ORB.Initialize ("ORB"); Output ("Initialization", True); declare Obj : constant CORBA.Impl.Object_Ptr := new Harness.Impl.Object; Ref : Harness.Ref; Ok : Boolean := True; T0, T1, T2 : Time; Delta1 : Duration; How_Many : Integer := 1_000; begin Initiate_Servant (PortableServer.Servant (Obj), Ref); Initiate_Server (True); if Ada.Command_Line.Argument_Count >= 1 then begin How_Many := Integer'Value (Ada.Command_Line.Argument (1)); exception when others => null; end; end if; T0 := Clock; for J in 1 .. How_Many loop Ok := Ok and (echoULong (Ref, 1234) = 1234); end loop; T1 := Clock; T2 := Clock; Output ("Test success", Ok); Delta1 := To_Duration (T1 - T0 - (T2 - T1)); Ada.Text_IO.Put_Line ("Time: " & Duration'Image (Delta1) & "s"); CORBA.ORB.Shutdown (Wait_For_Completion => False); End_Report; end; end Local; polyorb-2.8~20110207.orig/testsuite/corba/harness/server_thread_pool.adb0000644000175000017500000000433311750740340025525 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- S E R V E R _ T H R E A D _ P O O L -- -- -- -- B o d y -- -- -- -- Copyright (C) 2004 Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by ACT Europe. -- -- (email: sales@act-europe.fr) -- -- -- ------------------------------------------------------------------------------ with Server_Common; with PolyORB.Setup.Thread_Pool_Server; pragma Warnings (Off, PolyORB.Setup.Thread_Pool_Server); procedure Server_Thread_Pool is begin Server_Common.Launch_Server; end Server_Thread_Pool; polyorb-2.8~20110207.orig/testsuite/corba/harness/harness-impl.ads0000644000175000017500000000442011750740340024257 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- H A R N E S S . I M P L -- -- -- -- S p e c -- -- -- -- Copyright (C) 2004-2008, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by ACT Europe. -- -- (email: sales@act-europe.fr) -- -- -- ------------------------------------------------------------------------------ with CORBA; with PortableServer; package Harness.Impl is type Object is new PortableServer.Servant_Base with null record; function echoULong (Self : access Object; arg : CORBA.Unsigned_Long) return CORBA.Unsigned_Long; end Harness.Impl; polyorb-2.8~20110207.orig/testsuite/corba/harness/local.gpr0000644000175000017500000000124111750740340022766 0ustar xavierxavierwith "polyorb", "polyorb_test_common"; project local is Dir := external ("Test_Dir"); Obj_Dir := PolyORB_Test_Common.Build_Dir & Dir; for Object_Dir use Obj_Dir; for Source_Dirs use (Obj_Dir, PolyORB_Test_Common.Source_Dir & Dir); package Compiler is for Default_Switches ("Ada") use PolyORB_Test_Common.Compiler'Default_Switches ("Ada"); end Compiler; for Main use ("server_no_tasking.adb", "server_thread_pool.adb", "server_thread_pool_hahs.adb", "server_thread_pool_lf.adb", "server_thread_per_request.adb", "server_thread_per_session.adb", "client.adb", "local.adb"); end local; polyorb-2.8~20110207.orig/testsuite/corba/harness/server_common.ads0000644000175000017500000000412111750740340024531 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- S E R V E R _ C O M M O N -- -- -- -- S p e c -- -- -- -- Copyright (C) 2004 Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by ACT Europe. -- -- (email: sales@act-europe.fr) -- -- -- ------------------------------------------------------------------------------ package Server_Common is procedure Launch_Server; end Server_Common; polyorb-2.8~20110207.orig/testsuite/corba/harness/harness-impl.adb0000644000175000017500000000456511750740340024250 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- A L L _ T Y P E S . I M P L -- -- -- -- B o d y -- -- -- -- Copyright (C) 2002-2008, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by ACT Europe. -- -- (email: sales@act-europe.fr) -- -- -- ------------------------------------------------------------------------------ with Harness.Skel; pragma Warnings (Off, Harness.Skel); package body Harness.Impl is --------------- -- echoULong -- --------------- function echoULong (Self : access Object; arg : CORBA.Unsigned_Long) return CORBA.Unsigned_Long is pragma Unreferenced (Self); begin return arg; end echoULong; end Harness.Impl; polyorb-2.8~20110207.orig/testsuite/corba/harness/server_thread_per_session.adb0000644000175000017500000000436711750740340027114 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- S E R V E R _ T H R E A D _ P E R _ S E S S I O N -- -- -- -- B o d y -- -- -- -- Copyright (C) 2004 Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by ACT Europe. -- -- (email: sales@act-europe.fr) -- -- -- ------------------------------------------------------------------------------ with Server_Common; with PolyORB.Setup.Thread_Per_Session_Server; pragma Warnings (Off, PolyORB.Setup.Thread_Per_Session_Server); procedure Server_Thread_Per_Session is begin Server_Common.Launch_Server; end Server_Thread_Per_Session; polyorb-2.8~20110207.orig/testsuite/corba/harness/client.adb0000644000175000017500000000425411750740340023117 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- C L I E N T -- -- -- -- B o d y -- -- -- -- Copyright (C) 2004 Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by ACT Europe. -- -- (email: sales@act-europe.fr) -- -- -- ------------------------------------------------------------------------------ with PolyORB.Setup.Client; pragma Warnings (Off, PolyORB.Setup.Client); with Client_Common; procedure Client is begin Client_Common.Launch_Client; end Client; polyorb-2.8~20110207.orig/testsuite/corba/cos/0000755000175000017500000000000011750740340020305 5ustar xavierxavierpolyorb-2.8~20110207.orig/testsuite/corba/cos/event/0000755000175000017500000000000011750740340021426 5ustar xavierxavierpolyorb-2.8~20110207.orig/testsuite/corba/cos/event/typedtest_interface-impl.adb0000644000175000017500000000603311750740340027104 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- T Y P E D T E S T_I N T E R F A C E. I M P L -- -- -- -- B o d y -- -- -- -- Copyright (C) 2003-2008, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by ACT Europe. -- -- (email: sales@act-europe.fr) -- -- -- ------------------------------------------------------------------------------ with Ada.Text_IO; with TypedTest_Interface; with TypedTest_Interface.Skel; pragma Warnings (Off, TypedTest_Interface.Skel); with TypedTest_Interface.Helper; pragma Warnings (Off, TypedTest_Interface.Helper); with PolyORB.CORBA_P.Server_Tools; package body TypedTest_Interface.Impl is use PortableServer; use PolyORB.CORBA_P.Server_Tools; function EchoString (Self : access Object; Mesg : CORBA.String) return CORBA.String is pragma Warnings (Off); pragma Unreferenced (Self); pragma Warnings (On); begin Ada.Text_IO.Put_Line ("Echoing string: « " & CORBA.To_Standard_String (Mesg) & " »"); return Mesg; end EchoString; function Create return CORBA.Impl.Object_Ptr is TypedTest_Int : Object_Ptr; My_Ref : TypedTest_Interface.Ref; begin TypedTest_Int := new Object; Initiate_Servant (Servant (TypedTest_Int), My_Ref); return CORBA.Impl.Object_Ptr (TypedTest_Int); end Create; end TypedTest_Interface.Impl; polyorb-2.8~20110207.orig/testsuite/corba/cos/event/auto_print.adb0000644000175000017500000000673011750740340024270 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- A U T O _ P R I N T -- -- -- -- B o d y -- -- -- -- Copyright (C) 2003 Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by ACT Europe. -- -- (email: sales@act-europe.fr) -- -- -- ------------------------------------------------------------------------------ with Ada.Exceptions; with Ada.Text_IO; with CosEventComm.PushConsumer.Impl; package body Auto_Print is use Ada.Text_IO; use Ada.Exceptions; use CORBA; use CosEventComm.PushConsumer.Impl; --------------------------- -- Ensure_Initialization -- --------------------------- T_Initialized : Boolean := False; procedure Ensure_Initialization is begin if T_Initialized then return; end if; Create (Session_Mutex); Create (Session_Taken); T_Initialized := True; end Ensure_Initialization; ------------------------- -- Thread Auto_Display -- ------------------------- procedure Auto_Display is Got_Msg : CORBA.Boolean; Msg : CORBA.Any; Ptr : PushConsumer.Impl.Object_Ptr; begin Ptr := PushConsumer.Impl.Object_Ptr (A_S); Enter (Session_Mutex); Signal (Session_Taken); Leave (Session_Mutex); Put_Line ("AutoDisplay setup"); loop exit when EndDisplay; delay 0.1; Try_Pull (Ptr, Got_Msg, Msg); if Got_Msg then Ada.Text_IO.Put_Line (To_Standard_String (From_Any (Msg))); end if; end loop; EndDisplay := False; exception when E : others => Ada.Text_IO.Put_Line ("raised "& Exception_Name (E)); Ada.Text_IO.Put_Line (Exception_Message (E)); Ada.Text_IO.Put_Line (Exception_Information (E)); end Auto_Display; end Auto_Print; polyorb-2.8~20110207.orig/testsuite/corba/cos/event/typedtest_interface.idl0000644000175000017500000000011111750740340026156 0ustar xavierxavierinterface TypedTest_Interface { string echoString (in string Mesg); }; polyorb-2.8~20110207.orig/testsuite/corba/cos/event/test_event.adb0000644000175000017500000005662311750740340024272 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- T E S T _ E V E N T -- -- -- -- B o d y -- -- -- -- Copyright (C) 2001-2008, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- Test PolyORB COS event capabilities. with Ada.Command_Line; with Ada.Exceptions; with Ada.Text_IO; with CORBA.Impl; with CORBA.Object; with CORBA.ORB; with PortableServer; with CosNaming.BindingIterator; with CosNaming.NamingContext.Impl; with CosNaming.NamingContext.Helper; with CosEventChannelAdmin.ConsumerAdmin; with CosEventChannelAdmin.EventChannel.Impl; with CosEventChannelAdmin.EventChannel.Helper; with CosEventChannelAdmin.SupplierAdmin; with CosEventChannelAdmin.ProxyPullConsumer; with CosEventChannelAdmin.ProxyPullSupplier; with CosEventChannelAdmin.ProxyPushConsumer; with CosEventChannelAdmin.ProxyPushSupplier; with CosEventComm.PullConsumer.Helper; with CosEventComm.PullConsumer.Impl; with CosEventComm.PullSupplier.Helper; with CosEventComm.PullSupplier.Impl; with CosEventComm.PushConsumer.Helper; with CosEventComm.PushConsumer.Impl; with CosEventComm.PushSupplier.Helper; with CosEventComm.PushSupplier.Impl; with PolyORB.CORBA_P.Server_Tools; with PolyORB.Tasking.Condition_Variables; with PolyORB.Tasking.Mutexes; with PolyORB.Tasking.Threads; with PolyORB.Setup.Thread_Pool_Server; pragma Warnings (Off, PolyORB.Setup.Thread_Pool_Server); with Auto_Print; -- Auxiliary code to output pushconsumer incoming messages. with Menu; -- From COS Naming, provide text interface. procedure Test_Event is use Ada.Exceptions; use Auto_Print; use Menu; use PortableServer; use CosNaming; use CosEventChannelAdmin; use CosEventComm; use CosEventComm.PushConsumer.Impl; use PolyORB.CORBA_P.Server_Tools; use PolyORB.Tasking.Condition_Variables; use PolyORB.Tasking.Mutexes; use PolyORB.Tasking.Threads; type Command is (Help, Quit, Run, Sleep, Connect, Consume, TryConsume, Produce, AutoDisplay, Create); Syntax_Error : exception; Help_Messages : constant array (Command) of String_Access := (Help => +(ASCII.HT & "print this message"), Quit => +(ASCII.HT & "quit this shell"), Run => +(ASCII.HT & "run "), Sleep => +(ASCII.HT & "sleep "), Create => +(ASCII.HT & "create "), Connect => +(ASCII.HT & "connect to "), Consume => +(ASCII.HT & "consume in "), TryConsume => +("tryconsume in "), AutoDisplay => +("autodisplay "), Produce => +(ASCII.HT & "produce in [ times]")); type Entity_Kind is (K_Channel, K_PullConsumer, K_PullSupplier, K_PushConsumer, K_PushSupplier); Image : constant array (Entity_Kind) of CosNaming.Istring := (K_Channel => CosNaming.To_CORBA_String (K_Channel'Img), K_PullConsumer => CosNaming.To_CORBA_String (K_PullConsumer'Img), K_PullSupplier => CosNaming.To_CORBA_String (K_PullSupplier'Img), K_PushConsumer => CosNaming.To_CORBA_String (K_PushConsumer'Img), K_PushSupplier => CosNaming.To_CORBA_String (K_PushSupplier'Img)); Ctx : NamingContext.Ref; -------------------- -- Connect_Entity -- -------------------- procedure Connect_Entity (Entity : CORBA.Object.Ref; Kind : Entity_Kind; Channel : EventChannel.Ref); procedure Connect_Entity (Entity : CORBA.Object.Ref; Kind : Entity_Kind; Channel : EventChannel.Ref) is O : CORBA.Impl.Object_Ptr; begin case Kind is when K_PullConsumer => declare A : ConsumerAdmin.Ref; P : ProxyPullSupplier.Ref; E : PullConsumer.Ref; begin A := EventChannel.for_consumers (Channel); P := ConsumerAdmin.obtain_pull_supplier (A); E := PullConsumer.Helper.To_Ref (Entity); Reference_To_Servant (E, Servant (O)); PullConsumer.Impl.Connect_Proxy_Pull_Supplier (PullConsumer.Impl.Object_Ptr (O), P); end; when K_PullSupplier => declare A : SupplierAdmin.Ref; P : ProxyPullConsumer.Ref; E : PullSupplier.Ref; begin A := EventChannel.for_suppliers (Channel); P := SupplierAdmin.obtain_pull_consumer (A); E := PullSupplier.Helper.To_Ref (Entity); Reference_To_Servant (E, Servant (O)); PullSupplier.Impl.Connect_Proxy_Pull_Consumer (PullSupplier.Impl.Object_Ptr (O), P); end; when K_PushConsumer => declare A : ConsumerAdmin.Ref; P : ProxyPushSupplier.Ref; E : PushConsumer.Ref; begin A := EventChannel.for_consumers (Channel); P := ConsumerAdmin.obtain_push_supplier (A); E := PushConsumer.Helper.To_Ref (Entity); Reference_To_Servant (E, Servant (O)); PushConsumer.Impl.Connect_Proxy_Push_Supplier (PushConsumer.Impl.Object_Ptr (O), P); end; when K_PushSupplier => declare A : SupplierAdmin.Ref; P : ProxyPushConsumer.Ref; E : PushSupplier.Ref; begin A := EventChannel.for_suppliers (Channel); P := SupplierAdmin.obtain_push_consumer (A); E := PushSupplier.Helper.To_Ref (Entity); Reference_To_Servant (E, Servant (O)); PushSupplier.Impl.Connect_Proxy_Push_Consumer (PushSupplier.Impl.Object_Ptr (O), P); end; when K_Channel => raise Syntax_Error; end case; end Connect_Entity; ------------------- -- Consume_Event -- ------------------- function Consume_Event (Entity : CORBA.Object.Ref; Kind : Entity_Kind) return String; function Consume_Event (Entity : CORBA.Object.Ref; Kind : Entity_Kind) return String is O : CORBA.Impl.Object_Ptr; A : CORBA.Any; begin case Kind is when K_PullConsumer => declare C : PullConsumer.Ref; begin C := PullConsumer.Helper.To_Ref (Entity); Reference_To_Servant (C, Servant (O)); A := PullConsumer.Impl.Pull (PullConsumer.Impl.Object_Ptr (O)); return To_Standard_String (From_Any (A)); end; when K_PushConsumer => declare C : PushConsumer.Ref; begin C := PushConsumer.Helper.To_Ref (Entity); Reference_To_Servant (C, Servant (O)); A := PushConsumer.Impl.Pull (PushConsumer.Impl.Object_Ptr (O)); return To_Standard_String (From_Any (A)); end; when others => null; end case; return ""; end Consume_Event; ----------------------- -- Try_Consume_Event -- ----------------------- function Try_Consume_Event (Entity : CORBA.Object.Ref; Kind : Entity_Kind) return String; function Try_Consume_Event (Entity : CORBA.Object.Ref; Kind : Entity_Kind) return String is O : CORBA.Impl.Object_Ptr; A : CORBA.Any; B : CORBA.Boolean; begin case Kind is when K_PullConsumer => declare C : PullConsumer.Ref; begin C := PullConsumer.Helper.To_Ref (Entity); Reference_To_Servant (C, Servant (O)); PullConsumer.Impl.Try_Pull (PullConsumer.Impl.Object_Ptr (O), B, A); if B then return To_Standard_String (From_Any (A)); else return "Nothing to consume!!!"; end if; end; when K_PushConsumer => declare C : PushConsumer.Ref; begin C := PushConsumer.Helper.To_Ref (Entity); Reference_To_Servant (C, Servant (O)); PushConsumer.Impl.Try_Pull (PushConsumer.Impl.Object_Ptr (O), B, A); if B then return To_Standard_String (From_Any (A)); else return "Nothing to consume!!!"; end if; end; when others => null; end case; return ""; end Try_Consume_Event; ------------------- -- Create_Entity -- ------------------- procedure Create_Entity (Entity : out CORBA.Object.Ref; Kind : Entity_Kind); procedure Create_Entity (Entity : out CORBA.Object.Ref; Kind : Entity_Kind) is begin case Kind is when K_Channel => declare R : EventChannel.Ref; begin Servant_To_Reference (Servant (EventChannel.Impl.Create), R); Entity := CORBA.Object.Ref (R); end; when K_PullConsumer => declare R : PullConsumer.Ref; begin Servant_To_Reference (Servant (PullConsumer.Impl.Create), R); Entity := CORBA.Object.Ref (R); end; when K_PullSupplier => declare R : PullSupplier.Ref; begin Servant_To_Reference (Servant (PullSupplier.Impl.Create), R); Entity := CORBA.Object.Ref (R); end; when K_PushConsumer => declare R : PushConsumer.Ref; begin Servant_To_Reference (Servant (PushConsumer.Impl.Create), R); Entity := CORBA.Object.Ref (R); end; when K_PushSupplier => declare R : PushSupplier.Ref; begin Servant_To_Reference (Servant (PushSupplier.Impl.Create), R); Entity := CORBA.Object.Ref (R); end; end case; end Create_Entity; ----------------- -- Find_Entity -- ----------------- procedure Find_Entity (Name : String_Access; Entity : out CORBA.Object.Ref; Kind : out Entity_Kind); procedure Find_Entity (Name : String_Access; Entity : out CORBA.Object.Ref; Kind : out Entity_Kind) is Iter : BindingIterator.Ref; B : Binding; BL : BindingList; BI : BindingIterator_Forward.Ref; Id : constant CosNaming.Istring := CosNaming.To_CORBA_String (Name.all); Done : CORBA.Boolean; NC : NameComponent; begin NamingContext.list (Ctx, 0, BL, BI); Iter := BindingIterator.Convert_Forward.To_Ref (BI); loop BindingIterator.next_one (Iter, B, Done); exit when not Done; NC := Get_Element (B.binding_name, 1); if NC.id = Id then for K in Image'Range loop if NC.kind = Image (K) then Kind := K; Entity := NamingContext.resolve (Ctx, B.binding_name); return; end if; end loop; raise Syntax_Error; end if; end loop; raise NamingContext.NotFound; end Find_Entity; ------------------- -- Produce_Event -- ------------------- procedure Produce_Event (Entity : CORBA.Object.Ref; Kind : Entity_Kind; Event : String_Access; Times : Natural); procedure Produce_Event (Entity : CORBA.Object.Ref; Kind : Entity_Kind; Event : String_Access; Times : Natural) is O : CORBA.Impl.Object_Ptr; A : constant CORBA.Any := To_Any (To_CORBA_String (Event.all)); begin case Kind is when K_PullSupplier => declare S : PullSupplier.Ref; begin S := PullSupplier.Helper.To_Ref (Entity); Reference_To_Servant (S, Servant (O)); Ada.Text_IO.New_Line; for J in 1 .. Times loop PullSupplier.Impl.Push (PullSupplier.Impl.Object_Ptr (O), A); Ada.Text_IO.Put ("."); end loop; Ada.Text_IO.New_Line; end; when K_PushSupplier => declare S : PushSupplier.Ref; begin S := PushSupplier.Helper.To_Ref (Entity); Reference_To_Servant (S, Servant (O)); Ada.Text_IO.New_Line; for J in 1 .. Times loop PushSupplier.Impl.Push (PushSupplier.Impl.Object_Ptr (O), A); Ada.Text_IO.Put ("."); end loop; Ada.Text_IO.New_Line; end; when others => null; end case; end Produce_Event; ------------- -- To_Name -- ------------- function To_Name (S : String_Access; K : Entity_Kind) return Name; function To_Name (S : String_Access; K : Entity_Kind) return Name is Element : NameComponent; Result : Name; begin Element.id := CosNaming.To_CORBA_String (S.all); Element.kind := CosNaming.To_CORBA_String (K'Img); Append (Result, Element); return Result; end To_Name; ------------------ -- Display_Help -- ------------------ procedure Display_Help; procedure Display_Help is begin for C in Help_Messages'Range loop Ada.Text_IO.Put_Line (C'Img & ASCII.HT & ASCII.HT & Help_Messages (C).all); if C = Create then Ada.Text_IO.Put (ASCII.HT & " in"); for E in Entity_Kind'Range loop declare I : constant String := Entity_Kind'Image (E); begin Ada.Text_IO.Put (' ' & I (3 .. I'Last)); end; end loop; Ada.Text_IO.New_Line; end if; end loop; Ada.Text_IO.New_Line; end Display_Help; -------------- -- Exit_All -- -------------- procedure Exit_All; procedure Exit_All is begin CORBA.ORB.Shutdown (False); end Exit_All; --------------- -- Main_Loop -- --------------- procedure Main_Loop; procedure Main_Loop is Argc : Natural; Entity : CORBA.Object.Ref; Channel : EventChannel.Ref; Kind : Entity_Kind; begin loop Argc := Count; if Argc > 0 and then Argument (1)(Argument (1)'First) /= '#' then begin case Command'Value (Argument (1).all) is when Help => Display_Help; when Quit => Exit_All; exit; when Create => if Argc /= 3 then raise Syntax_Error; end if; Kind := Entity_Kind'Value ("K_" & Argument (2).all); declare EK : Entity_Kind; begin Find_Entity (Argument (3), Entity, EK); if EK /= Kind then Ada.Text_IO.Put_Line ("entity " & Argument (3).all & " is a " & EK'Img); raise Syntax_Error; end if; exception when NamingContext.NotFound => Create_Entity (Entity, Kind); NamingContext.bind (Ctx, To_Name (Argument (3), Kind), Entity); end; when Connect => if Argc /= 4 or else Argument (3).all /= "to" then raise Syntax_Error; end if; Find_Entity (Argument (4), Entity, Kind); if Kind /= K_Channel then raise Syntax_Error; end if; Channel := EventChannel.Helper.To_Ref (Entity); Find_Entity (Argument (2), Entity, Kind); Connect_Entity (Entity, Kind, Channel); when Consume => if Argc /= 3 or else Argument (2).all /= "in" then raise Syntax_Error; end if; Find_Entity (Argument (3), Entity, Kind); Ada.Text_IO.Put_Line (Consume_Event (Entity, Kind)); when TryConsume => if Argc /= 3 or else Argument (2).all /= "in" then raise Syntax_Error; end if; Find_Entity (Argument (3), Entity, Kind); Ada.Text_IO.Put_Line (Try_Consume_Event (Entity, Kind)); when Produce => if (Argc /= 4 and then Argc /= 6) or else Argument (3).all /= "in" then raise Syntax_Error; end if; declare N : Natural := 1; begin if Argc = 6 then if Argument (6).all = "times" then N := Natural'Value (Argument (5).all); else raise Syntax_Error; end if; end if; Find_Entity (Argument (4), Entity, Kind); Produce_Event (Entity, Kind, Argument (2), N); end; when Run => if Argc /= 2 then raise Syntax_Error; end if; Set_Input (Argument (2)); when Sleep => if Argc /= 2 then raise Syntax_Error; end if; declare N : constant Natural := Natural'Value (Argument (2).all); begin delay Duration (N); end; when AutoDisplay => if Argc /= 2 then raise Syntax_Error; end if; declare Item : String (1 .. 255); Last : Natural; C : PushConsumer.Ref; O : CORBA.Impl.Object_Ptr; begin Find_Entity (Argument (2), Entity, Kind); if Kind /= K_PushConsumer then Ada.Text_IO.Put_Line ("Can be called only with a PushConsumer"); else C := PushConsumer.Helper.To_Ref (Entity); Reference_To_Servant (C, Servant (O)); Ensure_Initialization; Enter (Session_Mutex); A_S := O; Create_Task (Auto_Display'Access); Wait (Session_Taken, Session_Mutex); Leave (Session_Mutex); Ada.Text_IO.Get_Line (Item, Last); EndDisplay := True; end if; end; end case; exception when Syntax_Error => Ada.Text_IO.Put_Line ("syntax error"); when E : others => Ada.Text_IO.Put_Line ("raise "& Exception_Name (E)); Ada.Text_IO.Put_Line (Exception_Message (E)); Ada.Text_IO.Put_Line (Exception_Information (E)); end; end if; end loop; end Main_Loop; -- main procedure begins here. begin CORBA.ORB.Initialize ("ORB"); Initiate_Server (True); if Ada.Command_Line.Argument_Count = 0 then -- Test_Event is used in interactive mode. if Count ("enter naming IOR [otherwise create one]: ") = 0 then Servant_To_Reference (Servant (NamingContext.Impl.Create), Ctx); Ada.Text_IO.Put_Line (CORBA.To_Standard_String (CORBA.Object.Object_To_String (CORBA.Object.Ref (Ctx)))); else declare Obj : CORBA.Object.Ref; begin CORBA.ORB.String_To_Object (CORBA.To_CORBA_String (Argument (1).all), Obj); Ctx := NamingContext.Helper.To_Ref (Obj); end; end if; Display_Help; Main_Loop; else -- Test_Event is used in batch mode. if Ada.Command_Line.Argument_Count /= 2 then Ada.Text_IO.New_Line; Ada.Text_IO.Put_Line ("usage: test_event [ ]"); Exit_All; end if; declare Obj : CORBA.Object.Ref; begin CORBA.ORB.String_To_Object (CORBA.To_CORBA_String (Ada.Command_Line.Argument (1)), Obj); Ctx := NamingContext.Helper.To_Ref (Obj); end; Set_Input (+Ada.Command_Line.Argument (2)); Main_Loop; end if; end Test_Event; polyorb-2.8~20110207.orig/testsuite/corba/cos/event/README0000644000175000017500000000231211750740340022304 0ustar xavierxavierREADME for PolyORB's COS Event Service --------------------------------------- $Id: //droopi/main/testsuite/corba/cos/event/README#2 $ PolyORB provides a default implementation of the CORBA COS Event Service. This directory contains tests for this implementation. 1. Generic COS Event test ========================= test_event tests the functionnalities of generic COS Event Service. test_event can be started in - interactive mode, an online help details the various commande ./test_event - batch mode, ./test_event script_file is a text file containing the same commands as in interactive mode, see online help or supplier.cmd file for more details. 2. Typed Event service ====================== typedtest_event tests the functionnalities of CosTyped Event Service. typedtest_event can be started in - interactive mode, an online help details the various commande ./typedtest_event - batch mode, ./typedtest_event Two scripts are provided for testing: * typedevent_singleclient.cmd Simple case of one pushconsumer and one pull supplier * typedevent_multipleclient.cmd Stress test involving 20 PushSuppliers and 20 PullConsumers polyorb-2.8~20110207.orig/testsuite/corba/cos/event/Makefile.local0000644000175000017500000000017011750740340024155 0ustar xavierxavier${current_dir}typedtest_interface.idl-stamp: idlac_flags := ${test_target}: ${current_dir}typedtest_interface.idl-stamp polyorb-2.8~20110207.orig/testsuite/corba/cos/event/auto_print.ads0000644000175000017500000000533011750740340024304 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- A U T O _ P R I N T -- -- -- -- S p e c -- -- -- -- Copyright (C) 2003 Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by ACT Europe. -- -- (email: sales@act-europe.fr) -- -- -- ------------------------------------------------------------------------------ with CosEventComm; with CORBA.Impl; with PolyORB.Tasking.Mutexes; with PolyORB.Tasking.Condition_Variables; package Auto_Print is use CosEventComm; use PolyORB.Tasking.Condition_Variables; use PolyORB.Tasking.Mutexes; procedure Auto_Display; procedure Ensure_Initialization; pragma Inline (Ensure_Initialization); -- Ensure that the Mutexes are initialized Session_Mutex : Mutex_Access; Session_Taken : Condition_Access; -- Synchornisation of task initialization. EndDisplay : Boolean := False; A_S : CORBA.Impl.Object_Ptr := null; -- This variable is used to initialize the threads local variable. -- it is used to replace the 'accept' statement. end Auto_Print; polyorb-2.8~20110207.orig/testsuite/corba/cos/event/typedtest_event.adb0000644000175000017500000005602211750740340025331 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- T Y P E D T E S T _ E V E N T -- -- -- -- B o d y -- -- -- -- Copyright (C) 2003-2008, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- Test PolyORB COS Typed event capabilities. with Ada.Command_Line; with Ada.Exceptions; with Ada.Text_IO; with CORBA; with CORBA.Impl; with CORBA.Object; with CORBA.ORB; with CosEventChannelAdmin.ProxyPullConsumer; with CosEventChannelAdmin.ProxyPullConsumer.Impl; with CosEventChannelAdmin.ProxyPushSupplier; with CosEventChannelAdmin.ProxyPushSupplier.Impl; with CosEventComm.PullConsumer.Helper; with CosEventComm.PullConsumer.Impl; with CosEventComm.PullSupplier.Helper; with CosEventComm.PushConsumer.Helper; with CosEventComm.PushSupplier.Helper; with CosEventComm.PushSupplier.Impl; with CosNaming.BindingIterator; with CosNaming.NamingContext.Impl; with CosNaming.NamingContext.Helper; with CosTypedEventChannelAdmin; with CosTypedEventChannelAdmin.TypedConsumerAdmin; with CosTypedEventChannelAdmin.TypedConsumerAdmin.Impl; with CosTypedEventChannelAdmin.TypedEventChannel.Impl; with CosTypedEventChannelAdmin.TypedEventChannel.Helper; with CosTypedEventChannelAdmin.TypedProxyPullSupplier; with CosTypedEventChannelAdmin.TypedProxyPullSupplier.Impl; with CosTypedEventChannelAdmin.TypedProxyPushConsumer; with CosTypedEventChannelAdmin.TypedProxyPushConsumer.Impl; with CosTypedEventChannelAdmin.TypedSupplierAdmin; with CosTypedEventChannelAdmin.TypedSupplierAdmin.Impl; with CosTypedEventComm.TypedPullSupplier.Helper; with CosTypedEventComm.TypedPullSupplier.Impl; with CosTypedEventComm.TypedPushConsumer.Helper; with CosTypedEventComm.TypedPushConsumer.Impl; with Menu; -- From COS Naming, provide text interface. with PortableServer; with PolyORB.CORBA_P.Server_Tools; with PolyORB.Setup.Thread_Pool_Server; pragma Warnings (Off, PolyORB.Setup.Thread_Pool_Server); with GNAT.OS_Lib; with TypedTest_Interface; with TypedTest_Interface.Helper; with TypedTest_Interface.Impl; -- Mutually Agreed Interface between Consumers and Suppliers procedure TypedTest_Event is use Ada.Exceptions; use CORBA; use Menu; use CosEventChannelAdmin; use CosEventComm; use CosEventComm.PullConsumer.Impl; use CosEventComm.PushSupplier.Impl; use CosNaming; use CosTypedEventChannelAdmin; use CosTypedEventChannelAdmin.TypedEventChannel.Impl; use CosTypedEventComm; use CosTypedEventComm.TypedPushConsumer.Impl; use CosTypedEventComm.TypedPullSupplier.Impl; use PortableServer; use PolyORB.CORBA_P.Server_Tools; type Command is (Help, Quit, Run, Sleep, Get_Typed_Object, Connect, Create); Syntax_Error : exception; Help_Messages : constant array (Command) of String_Access := (Help => +(ASCII.HT & "print this message"), Quit => +(ASCII.HT & "quit this shell"), Run => +(ASCII.HT & "run "), Sleep => +(ASCII.HT & "sleep "), Create => +(ASCII.HT & "create "), Get_Typed_Object => +(ASCII.HT & "get_typed_object on " & " from "), Connect => +(ASCII.HT & "connect to ")); type Entity_Kind is (K_Channel, K_PullConsumer, K_PullSupplier, K_PushConsumer, K_PushSupplier); Image : constant array (Entity_Kind) of CosNaming.Istring := (K_Channel => CosNaming.To_CORBA_String (K_Channel'Img), K_PullConsumer => CosNaming.To_CORBA_String (K_PullConsumer'Img), K_PullSupplier => CosNaming.To_CORBA_String (K_PullSupplier'Img), K_PushConsumer => CosNaming.To_CORBA_String (K_PushConsumer'Img), K_PushSupplier => CosNaming.To_CORBA_String (K_PushSupplier'Img)); Ctx : NamingContext.Ref; -------------------- -- Connect_Entity -- -------------------- procedure Connect_Entity (Entity : CORBA.Object.Ref; Kind : Entity_Kind; Channel : TypedEventChannel.Ref); procedure Connect_Entity (Entity : CORBA.Object.Ref; Kind : Entity_Kind; Channel : TypedEventChannel.Ref) is O : CORBA.Impl.Object_Ptr; begin case Kind is when K_PullSupplier => declare A : TypedSupplierAdmin.Ref; P : ProxyPullConsumer.Ref; E : TypedPullSupplier.Ref; NE : PullSupplier.Ref; Create_Ptr : TypedEventChannel.Impl.Interface_Ptr; RID : CORBA.String; begin E := TypedPullSupplier.Helper.To_Ref (Entity); Reference_To_Servant (E, Servant (O)); Create_Ptr := TypedTest_Interface.Impl.Create'Access; RID := CORBA.To_CORBA_String (Standard.String'(TypedTest_Interface.Repository_Id)); TypedPullSupplier.Impl.SetInterface_Ptr (TypedPullSupplier.Impl.Object_Ptr (O), Create_Ptr); A := TypedEventChannel.for_suppliers (Channel); Reference_To_Servant (A, Servant (O)); P := TypedSupplierAdmin.Impl.obtain_typed_pull_consumer (TypedSupplierAdmin.Impl.Object_Ptr (O), CosTypedEventChannelAdmin.Key (RID)); Reference_To_Servant (P, Servant (O)); NE := PullSupplier.Helper.To_Ref (Entity); ProxyPullConsumer.Impl.Connect_Pull_Supplier (ProxyPullConsumer.Impl.Object_Ptr (O), NE); end; when K_PushConsumer => declare A : TypedConsumerAdmin.Ref; P : ProxyPushSupplier.Ref; E : TypedPushConsumer.Ref; NE : PushConsumer.Ref; Create_Ptr : TypedEventChannel.Impl.Interface_Ptr; RID : CORBA.String; begin E := TypedPushConsumer.Helper.To_Ref (Entity); Reference_To_Servant (E, Servant (O)); Create_Ptr := TypedTest_Interface.Impl.Create'Access; RID := CORBA.To_CORBA_String (Standard.String'(TypedTest_Interface.Repository_Id)); TypedPushConsumer.Impl.SetInterface_Ptr (TypedPushConsumer.Impl.Object_Ptr (O), Create_Ptr); A := TypedEventChannel.for_consumers (Channel); Reference_To_Servant (A, Servant (O)); P := TypedConsumerAdmin.Impl.obtain_typed_push_supplier (TypedConsumerAdmin.Impl.Object_Ptr (O), CosTypedEventChannelAdmin.Key (RID)); Reference_To_Servant (P, Servant (O)); NE := PushConsumer.Helper.To_Ref (Entity); ProxyPushSupplier.Impl.Connect_Push_Consumer (ProxyPushSupplier.Impl.Object_Ptr (O), NE); end; when others => raise Syntax_Error; end case; end Connect_Entity; ----------------------------- -- Get_Typed_Object_Entity -- ----------------------------- procedure Get_Typed_Object_Entity (Entity : CORBA.Object.Ref; Kind : Entity_Kind; Channel : TypedEventChannel.Ref); procedure Get_Typed_Object_Entity (Entity : CORBA.Object.Ref; Kind : Entity_Kind; Channel : TypedEventChannel.Ref) is O : CORBA.Impl.Object_Ptr; begin case Kind is when K_PullConsumer => declare A : TypedConsumerAdmin.Ref; P : TypedProxyPullSupplier.Ref; E : PullConsumer.Ref; RID : CORBA.String; T : CORBA.Object.Ref; TI : TypedTest_Interface.Ref; SendMsg, RecMsg : CORBA.String; begin A := TypedEventChannel.for_consumers (Channel); RID := CORBA.To_CORBA_String (Standard.String'(TypedTest_Interface.Repository_Id)); Reference_To_Servant (A, Servant (O)); P := TypedConsumerAdmin.Impl.obtain_typed_pull_supplier (TypedConsumerAdmin.Impl.Object_Ptr (O), CosTypedEventChannelAdmin.Key (RID)); E := PullConsumer.Helper.To_Ref (Entity); Reference_To_Servant (P, Servant (O)); TypedProxyPullSupplier.Impl.Connect_Pull_Consumer (TypedProxyPullSupplier.Impl.Object_Ptr (O), E); T := TypedProxyPullSupplier.Impl.Get_Typed_Supplier (TypedProxyPullSupplier.Impl.Object_Ptr (O)); TI := TypedTest_Interface.Helper.To_Ref (T); Ada.Text_IO.Put_Line ("Calling operations defined in Mutually" & " Agreed Interface"); Reference_To_Servant (TI, Servant (O)); SendMsg := CORBA.To_CORBA_String (Standard.String'("Hello to TestInterface")); RecMsg := TypedTest_Interface.Impl.EchoString (TypedTest_Interface.Impl.Object_Ptr (O), SendMsg); Ada.Text_IO.Put_Line ("Msg from Test Interface : "& CORBA.To_Standard_String (RecMsg)); end; when K_PushSupplier => declare A : TypedSupplierAdmin.Ref; P : TypedProxyPushConsumer.Ref; E : PushSupplier.Ref; RID : CORBA.String; T : CORBA.Object.Ref; TI : TypedTest_Interface.Ref; SendMsg, RecMsg : CORBA.String; begin A := TypedEventChannel.for_suppliers (Channel); RID := CORBA.To_CORBA_String (Standard.String'(TypedTest_Interface.Repository_Id)); Reference_To_Servant (A, Servant (O)); P := TypedSupplierAdmin.Impl.obtain_typed_push_consumer (TypedSupplierAdmin.Impl.Object_Ptr (O), CosTypedEventChannelAdmin.Key (RID)); E := PushSupplier.Helper.To_Ref (Entity); Reference_To_Servant (P, Servant (O)); TypedProxyPushConsumer.Impl.Connect_Push_Supplier (TypedProxyPushConsumer.Impl.Object_Ptr (O), E); T := TypedProxyPushConsumer.Impl.Get_Typed_Consumer (TypedProxyPushConsumer.Impl.Object_Ptr (O)); TI := TypedTest_Interface.Helper.To_Ref (T); Ada.Text_IO.Put_Line ("Calling operations defined in Mutually" & " Agreed Interface"); Reference_To_Servant (TI, Servant (O)); SendMsg := CORBA.To_CORBA_String (Standard.String'("Hello to TestInterface")); RecMsg := TypedTest_Interface.Impl.EchoString (TypedTest_Interface.Impl.Object_Ptr (O), SendMsg); Ada.Text_IO.Put_Line ("Msg from Test Interface : "& CORBA.To_Standard_String (RecMsg)); end; when others => raise Syntax_Error; end case; end Get_Typed_Object_Entity; ------------------- -- Create_Entity -- ------------------- procedure Create_Entity (Entity : out CORBA.Object.Ref; Kind : Entity_Kind); procedure Create_Entity (Entity : out CORBA.Object.Ref; Kind : Entity_Kind) is begin case Kind is when K_Channel => declare R : TypedEventChannel.Ref; begin Servant_To_Reference (Servant (TypedEventChannel.Impl.Create), R); Entity := CORBA.Object.Ref (R); end; when K_PullConsumer => declare R : PullConsumer.Ref; begin Servant_To_Reference (Servant (PullConsumer.Impl.Create), R); Entity := CORBA.Object.Ref (R); end; when K_PushSupplier => declare R : PushSupplier.Ref; begin Servant_To_Reference (Servant (PushSupplier.Impl.Create), R); Entity := CORBA.Object.Ref (R); end; when K_PullSupplier => declare R : TypedPullSupplier.Ref; RID : CORBA.String; Create_Ptr : TypedEventChannel.Impl.Interface_Ptr; begin Servant_To_Reference (Servant (TypedPullSupplier.Impl.Create), R); Create_Ptr := TypedTest_Interface.Impl.Create'Access; RID := CORBA.To_CORBA_String (Standard.String'(TypedTest_Interface.Repository_Id)); TypedEventChannel.Impl.Register (CosTypedEventChannelAdmin.Key (RID), Create_Ptr); Entity := CORBA.Object.Ref (R); end; when K_PushConsumer => declare R : TypedPushConsumer.Ref; RID : CORBA.String; Create_Ptr : TypedEventChannel.Impl.Interface_Ptr; begin Servant_To_Reference (Servant (TypedPushConsumer.Impl.Create), R); Create_Ptr := TypedTest_Interface.Impl.Create'Access; RID := CORBA.To_CORBA_String (Standard.String'(TypedTest_Interface.Repository_Id)); TypedEventChannel.Impl.Register (CosTypedEventChannelAdmin.Key (RID), Create_Ptr); Entity := CORBA.Object.Ref (R); end; end case; end Create_Entity; ----------------- -- Find_Entity -- ----------------- procedure Find_Entity (Name : String_Access; Entity : out CORBA.Object.Ref; Kind : out Entity_Kind); procedure Find_Entity (Name : String_Access; Entity : out CORBA.Object.Ref; Kind : out Entity_Kind) is Iter : BindingIterator.Ref; B : Binding; BL : BindingList; BI : BindingIterator_Forward.Ref; Id : constant CosNaming.Istring := CosNaming.To_CORBA_String (Name.all); Done : CORBA.Boolean; NC : NameComponent; begin NamingContext.list (Ctx, 0, BL, BI); Iter := BindingIterator.Convert_Forward.To_Ref (BI); loop BindingIterator.next_one (Iter, B, Done); exit when not Done; NC := Get_Element (B.binding_name, 1); if NC.id = Id then for K in Image'Range loop if NC.kind = Image (K) then Kind := K; Entity := NamingContext.resolve (Ctx, B.binding_name); return; end if; end loop; raise Syntax_Error; end if; end loop; raise NamingContext.NotFound; end Find_Entity; ------------- -- To_Name -- ------------- function To_Name (S : String_Access; K : Entity_Kind) return Name; function To_Name (S : String_Access; K : Entity_Kind) return Name is Element : NameComponent; Result : Name; begin Element.id := CosNaming.To_CORBA_String (S.all); Element.kind := CosNaming.To_CORBA_String (K'Img); Append (Result, Element); return Result; end To_Name; ------------------ -- Display_Help -- ------------------ procedure Display_Help; procedure Display_Help is begin for C in Help_Messages'Range loop Ada.Text_IO.Put_Line (C'Img & ASCII.HT & ASCII.HT & Help_Messages (C).all); if C = Create then Ada.Text_IO.Put (ASCII.HT & " in"); for E in Entity_Kind'Range loop declare I : constant String := Entity_Kind'Image (E); begin Ada.Text_IO.Put (' ' & I (3 .. I'Last)); end; end loop; Ada.Text_IO.New_Line; end if; end loop; Ada.Text_IO.New_Line; end Display_Help; -------------- -- Exit_All -- -------------- procedure Exit_All; procedure Exit_All is begin GNAT.OS_Lib.OS_Exit (1); end Exit_All; --------------- -- Main_Loop -- --------------- procedure Main_Loop; procedure Main_Loop is Argc : Natural; Entity : CORBA.Object.Ref; Channel : TypedEventChannel.Ref; Kind : Entity_Kind; begin loop Argc := Count; if Argc > 0 and then Argument (1)(Argument (1)'First) /= '#' then begin case Command'Value (Argument (1).all) is when Help => Display_Help; when Quit => Exit_All; when Create => if Argc /= 3 then raise Syntax_Error; end if; Kind := Entity_Kind'Value ("K_" & Argument (2).all); declare EK : Entity_Kind; begin Find_Entity (Argument (3), Entity, EK); if EK /= Kind then Ada.Text_IO.Put_Line ("entity " & Argument (3).all & " is a " & EK'Img); raise Syntax_Error; end if; exception when NamingContext.NotFound => Create_Entity (Entity, Kind); NamingContext.bind (Ctx, To_Name (Argument (3), Kind), Entity); end; when Connect => if Argc /= 4 or else Argument (3).all /= "to" then raise Syntax_Error; end if; Find_Entity (Argument (4), Entity, Kind); if Kind /= K_Channel then raise Syntax_Error; end if; Channel := TypedEventChannel.Helper.To_Ref (Entity); Find_Entity (Argument (2), Entity, Kind); Connect_Entity (Entity, Kind, Channel); when Get_Typed_Object => if Argc /= 5 or else Argument (2).all /= "on" or else Argument (4).all /= "from" then raise Syntax_Error; end if; Find_Entity (Argument (5), Entity, Kind); if Kind /= K_Channel then raise Syntax_Error; end if; Channel := TypedEventChannel.Helper.To_Ref (Entity); Find_Entity (Argument (3), Entity, Kind); Get_Typed_Object_Entity (Entity, Kind, Channel); when Run => if Argc /= 2 then raise Syntax_Error; end if; Set_Input (Argument (2)); when Sleep => if Argc /= 2 then raise Syntax_Error; end if; declare N : constant Natural := Natural'Value (Argument (2).all); begin delay Duration (N); end; end case; exception when Syntax_Error => Ada.Text_IO.Put_Line ("syntax error"); when E : others => Ada.Text_IO.Put_Line ("raise "& Exception_Name (E)); Ada.Text_IO.Put_Line (Exception_Message (E)); Ada.Text_IO.Put_Line (Exception_Information (E)); end; end if; end loop; end Main_Loop; -- main procedure begins here. begin CORBA.ORB.Initialize ("ORB"); Initiate_Server (True); if Ada.Command_Line.Argument_Count = 0 then -- Test_Event is used in interactive mode. if Count ("enter naming IOR [otherwise create one]: ") = 0 then Servant_To_Reference (Servant (NamingContext.Impl.Create), Ctx); Ada.Text_IO.Put_Line (CORBA.To_Standard_String (CORBA.Object.Object_To_String (CORBA.Object.Ref (Ctx)))); else declare Obj : CORBA.Object.Ref; begin CORBA.ORB.String_To_Object (CORBA.To_CORBA_String (Argument (1).all), Obj); Ctx := NamingContext.Helper.To_Ref (Obj); end; end if; Display_Help; Main_Loop; else -- Test_Event is used in batch mode. if Ada.Command_Line.Argument_Count /= 2 then Ada.Text_IO.New_Line; Ada.Text_IO.Put_Line ("usage: test_event [ ]"); Exit_All; end if; declare Obj : CORBA.Object.Ref; begin CORBA.ORB.String_To_Object (CORBA.To_CORBA_String (Ada.Command_Line.Argument (1)), Obj); Ctx := NamingContext.Helper.To_Ref (Obj); end; Set_Input (+Ada.Command_Line.Argument (2)); Main_Loop; end if; end TypedTest_Event; polyorb-2.8~20110207.orig/testsuite/corba/cos/event/consumer.cmd0000644000175000017500000000030011750740340023737 0ustar xavierxaviercreate channel c create pushconsumer psc create pullconsumer plc connect psc to c connect plc to c sleep 3 consume in psc sleep 6 consume in plc sleep 6 consume in psc sleep 6 consume in plc polyorb-2.8~20110207.orig/testsuite/corba/cos/event/typedevent_multipleclient.cmd0000644000175000017500000000562011750740340027417 0ustar xavierxavier#Creation of TypedEvent Channel create channel c #Creation of a TypedPushConsumer create pushconsumer psc #Connection of TypedPushConsumer to TypedEventChannel connect psc to c #Creation of multiple PushSuppliers create pushsupplier pss1 create pushsupplier pss2 create pushsupplier pss3 create pushsupplier pss4 create pushsupplier pss5 create pushsupplier pss6 create pushsupplier pss7 create pushsupplier pss8 create pushsupplier pss9 create pushsupplier pss10 create pushsupplier pss11 create pushsupplier pss12 create pushsupplier pss13 create pushsupplier pss14 create pushsupplier pss15 create pushsupplier pss16 create pushsupplier pss17 create pushsupplier pss18 create pushsupplier pss19 create pushsupplier pss20 #Connect Multiple PushSuppliers to the same TypedPush Consumer #Call operations defined in Mutually Agreed Interface get_typed_object on pss1 from c get_typed_object on pss2 from c get_typed_object on pss3 from c get_typed_object on pss4 from c get_typed_object on pss5 from c get_typed_object on pss6 from c get_typed_object on pss7 from c get_typed_object on pss8 from c get_typed_object on pss9 from c get_typed_object on pss10 from c get_typed_object on pss11 from c get_typed_object on pss12 from c get_typed_object on pss13 from c get_typed_object on pss14 from c get_typed_object on pss15 from c get_typed_object on pss16 from c get_typed_object on pss17 from c get_typed_object on pss18 from c get_typed_object on pss19 from c get_typed_object on pss20 from c #Creation of a TypedPullSupplier create pullsupplier pls #Connection of TypedPullSupplier to TypedEventChannel connect pls to c #Creation of multiple PullConsumers create pullconsumer plc1 create pullconsumer plc2 create pullconsumer plc3 create pullconsumer plc4 create pullconsumer plc5 create pullconsumer plc6 create pullconsumer plc7 create pullconsumer plc8 create pullconsumer plc9 create pullconsumer plc10 create pullconsumer plc11 create pullconsumer plc12 create pullconsumer plc13 create pullconsumer plc14 create pullconsumer plc15 create pullconsumer plc16 create pullconsumer plc17 create pullconsumer plc18 create pullconsumer plc19 create pullconsumer plc20 #Connect multiple PullConsumers to same TypedPull Supplier #Call operations defined in Mutually Agreed Interface get_typed_object on plc1 from c get_typed_object on plc2 from c get_typed_object on plc3 from c get_typed_object on plc4 from c get_typed_object on plc5 from c get_typed_object on plc6 from c get_typed_object on plc7 from c get_typed_object on plc8 from c get_typed_object on plc9 from c get_typed_object on plc10 from c get_typed_object on plc11 from c get_typed_object on plc12 from c get_typed_object on plc13 from c get_typed_object on plc14 from c get_typed_object on plc15 from c get_typed_object on plc16 from c get_typed_object on plc17 from c get_typed_object on plc18 from c get_typed_object on plc19 from c get_typed_object on plc20 from c #Quit the test quit polyorb-2.8~20110207.orig/testsuite/corba/cos/event/typedevent_singleclient.cmd0000644000175000017500000000127011750740340027042 0ustar xavierxavier#Creation of TypedEvent Channel create channel c #Creation of a TypedPushConsumer create pushconsumer psc #Connection of TypedPushConsumer to TypedEventChannel connect psc to c #Creation of a PushSupplier create pushsupplier pss #Connect PushSupplier to TypedPush Consumer #Call operations defined in Mutually Agreed Interface get_typed_object on pss from c #Creation of a TypedPullSupplier create pullsupplier pls #Connection of TypedPullSupplier to TypedEventChannel connect pls to c #Creation of a PullConsumer create pullconsumer plc #Connect PullConsumer to TypedPull Supplier #Call operations defined in Mutually Agreed Interface get_typed_object on plc from c #Quit the test quit polyorb-2.8~20110207.orig/testsuite/corba/cos/event/supplier.cmd0000644000175000017500000000041011750740340023751 0ustar xavierxaviercreate channel c create pushsupplier pss create pullsupplier pls connect pss to c connect pls to c sleep 6 produce "running test 1" in pss sleep 6 produce "running test 2" in pss sleep 6 produce "running test 3" in pls sleep 6 produce "running test 4" in pls quit polyorb-2.8~20110207.orig/testsuite/corba/cos/event/local.gpr0000644000175000017500000000074411750740340023237 0ustar xavierxavierwith "polyorb", "polyorb_test_common", "polyorb_cos_event"; project local is Dir := external ("Test_Dir"); Obj_Dir := PolyORB_Test_Common.Build_Dir & Dir; for Object_Dir use Obj_Dir; for Source_Dirs use (Obj_Dir, PolyORB_Test_Common.Source_Dir & Dir); package Compiler is for Default_Switches ("Ada") use PolyORB_Test_Common.Compiler'Default_Switches ("Ada"); end Compiler; for Main use ("test_event.adb", "typedtest_event.adb"); end local; polyorb-2.8~20110207.orig/testsuite/corba/cos/event/typedtest_interface-impl.ads0000644000175000017500000000466311750740340027134 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- T Y P E D T E S T_I N T E R F A C E. I M P L -- -- -- -- S p e c -- -- -- -- Copyright (C) 2003-2008, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by ACT Europe. -- -- (email: sales@act-europe.fr) -- -- -- ------------------------------------------------------------------------------ with CORBA; with CORBA.Impl; with PortableServer; package TypedTest_Interface.Impl is type Object is new PortableServer.Servant_Base with record Msg : CORBA.String; end record; type Object_Ptr is access all Object; function EchoString (Self : access Object; Mesg : CORBA.String) return CORBA.String; function Create return CORBA.Impl.Object_Ptr; end TypedTest_Interface.Impl; polyorb-2.8~20110207.orig/testsuite/corba/cos/ir/0000755000175000017500000000000011750740340020717 5ustar xavierxavierpolyorb-2.8~20110207.orig/testsuite/corba/cos/ir/Makefile.local0000644000175000017500000000000011750740340023436 0ustar xavierxavierpolyorb-2.8~20110207.orig/testsuite/corba/cos/ir/local.gpr0000644000175000017500000000070211750740340022522 0ustar xavierxavierwith "polyorb", "polyorb_test_common"; project local is Dir := external ("Test_Dir"); Obj_Dir := PolyORB_Test_Common.Build_Dir & Dir; for Object_Dir use Obj_Dir; for Source_Dirs use (Obj_Dir, PolyORB_Test_Common.Source_Dir & Dir); package Compiler is for Default_Switches ("Ada") use PolyORB_Test_Common.Compiler'Default_Switches ("Ada"); end Compiler; for Main use ("server.adb", "client.adb"); end local; polyorb-2.8~20110207.orig/testsuite/corba/cos/ir/server.adb0000644000175000017500000000606011750740340022677 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- S E R V E R -- -- -- -- B o d y -- -- -- -- Copyright (C) 1999-2004 Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by ACT Europe. -- -- (email: sales@act-europe.fr) -- -- -- ------------------------------------------------------------------------------ with Ada.Text_IO; with CORBA.Object; with CORBA.ORB; with CORBA.Repository_Root.IRObject.Impl; with CORBA.Repository_Root.Contained.Impl; with CORBA.Repository_Root.Repository.Impl; with CORBA.Repository_Root; with PortableServer; with PolyORB.CORBA_P.Server_Tools; with PolyORB.Setup.No_Tasking_Server; pragma Warnings (Off, PolyORB.Setup.No_Tasking_Server); procedure Server is use CORBA.Repository_Root; use PolyORB.CORBA_P.Server_Tools; begin CORBA.ORB.Initialize ("ORB"); declare Ref : CORBA.Object.Ref; Repo : constant Repository.Impl.Object_Ptr := new Repository.Impl.Object; begin Repository.Impl.Init (Repo, IRObject.Impl.Object_Ptr (Repo), dk_Repository, Contained.Impl.Contained_Seq.Null_Sequence); Initiate_Servant (PortableServer.Servant (Repo), Ref); Ada.Text_IO.Put_Line ("'" & CORBA.To_Standard_String (CORBA.Object.Object_To_String (Ref)) & "'"); Initiate_Server; end; end Server; polyorb-2.8~20110207.orig/testsuite/corba/cos/ir/client.adb0000644000175000017500000001520611750740340022651 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- C L I E N T -- -- -- -- B o d y -- -- -- -- Copyright (C) 1999-2007, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with Ada.Command_Line; with Ada.Text_IO; with CORBA.ORB; with CORBA.Repository_Root; with CORBA.Repository_Root.PrimitiveDef; with CORBA.Repository_Root.Repository; with CORBA.Repository_Root.InterfaceDef; with CORBA.Repository_Root.OperationDef; with CORBA.Repository_Root.IDLType; with CORBA.Repository_Root.ModuleDef; with PolyORB.Setup.Client; pragma Warnings (Off, PolyORB.Setup.Client); with PolyORB.Utils.Report; procedure Client is use Ada.Text_IO; use CORBA; use CORBA.Repository_Root; use PolyORB.Utils.Report; IOR : CORBA.String; Myrep : Repository.Ref; begin New_Test ("InterfaceRepository"); CORBA.ORB.Initialize ("ORB"); if Ada.Command_Line.Argument_Count = 1 then IOR := CORBA.To_CORBA_String (Ada.Command_Line.Argument (1)); CORBA.ORB.String_To_Object (IOR, Myrep); else Put_Line ("Usage: client "); return; end if; -- Checking if it worked if Repository.Is_Nil (Myrep) then Put_Line ("main : cannot invoke on a nil reference"); return; end if; -- Creating a module declare Mod1 : ModuleDef_Forward.Ref; Int1 : InterfaceDef_Forward.Ref; Op1 : OperationDef.Ref; pragma Warnings (Off, Op1); -- Op1 is assigned but never read Id : RepositoryId; Name : Identifier; Version : VersionSpec; package IDS renames IDL_SEQUENCE_CORBA_InterfaceDef_Forward; begin Id := To_CORBA_String ("idl:toto:1.1"); Name := To_CORBA_String ("toto"); Version := To_CORBA_String ("1.1"); Mod1 := Repository.create_module (Myrep, Id, Name, Version); Output ("Create_Module", True); Id := To_CORBA_String ("idl:toto/titi:1.0"); Name := To_CORBA_String ("titi"); Version := To_CORBA_String ("1.0"); Int1 := ModuleDef.create_interface (ModuleDef.Convert_Forward.To_Ref (Mod1), Id, Name, Version, InterfaceDefSeq (IDS.Null_Sequence), False); Output ("Create_Interface", True); declare package PDS renames IDL_SEQUENCE_CORBA_ParameterDescription; package EDS renames IDL_SEQUENCE_CORBA_ExceptionDef_Forward; package CIS renames IDL_SEQUENCE_CORBA_ContextIdentifier; Mem : ParDescriptionSeq := ParDescriptionSeq (PDS.Null_Sequence); Exc : constant ExceptionDefSeq := ExceptionDefSeq (EDS.Null_Sequence); Con : constant ContextIdSeq := ContextIdSeq (CIS.Null_Sequence); Memb : ParameterDescription; Prim : CORBA.Repository_Root.PrimitiveDef_Forward.Ref; begin -- Create the members Name := To_CORBA_String ("oper1"); Memb := (Name => Name, IDL_Type => TC_Long, Type_Def => IDLType.Convert_Forward.To_Forward (IDLType.Ref (PrimitiveDef.Convert_Forward.To_Ref (Repository.get_primitive (Myrep, pk_long)))), Mode => PARAM_IN); PDS.Append (PDS.Sequence (Mem), Memb); Name := To_CORBA_String ("oper2"); Memb := (Name => Name, IDL_Type => TC_Long, Type_Def => IDLType.Convert_Forward.To_Forward (IDLType.Ref (PrimitiveDef.Convert_Forward.To_Ref (Repository.get_primitive (Myrep, pk_long)))), Mode => PARAM_IN); PDS.Append (PDS.Sequence (Mem), Memb); -- Create the operation Id := To_CORBA_String ("idl:toto/titi/myop:1.1"); Name := To_CORBA_String ("myop"); Version := To_CORBA_String ("1.1"); Prim := Repository.get_primitive (Myrep, pk_long); Output ("Get_Primitive", True); Op1 := InterfaceDef.create_operation (InterfaceDef.Convert_Forward. To_Ref (Int1), Id, Name, Version, IDLType.Ref (PrimitiveDef.Convert_Forward.To_Ref (Prim)), OP_NORMAL, Mem, Exc, Con); Output ("Create_Operation", True); end; end; End_Report; exception when E : CORBA.Bad_Param => declare Memb : System_Exception_Members; begin Get_Members (E, Memb); Put ("received Bad_Param exception, minor"); Put_Line (Unsigned_Long'Image (Memb.Minor)); end; end Client; polyorb-2.8~20110207.orig/testsuite/corba/cos/notification/0000755000175000017500000000000011750740340022773 5ustar xavierxavierpolyorb-2.8~20110207.orig/testsuite/corba/cos/notification/auto_print.adb0000644000175000017500000000673011750740340025635 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- A U T O _ P R I N T -- -- -- -- B o d y -- -- -- -- Copyright (C) 2003 Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by ACT Europe. -- -- (email: sales@act-europe.fr) -- -- -- ------------------------------------------------------------------------------ with Ada.Exceptions; with Ada.Text_IO; with CosEventComm.PushConsumer.Impl; package body Auto_Print is use Ada.Text_IO; use Ada.Exceptions; use CORBA; use CosEventComm.PushConsumer.Impl; --------------------------- -- Ensure_Initialization -- --------------------------- T_Initialized : Boolean := False; procedure Ensure_Initialization is begin if T_Initialized then return; end if; Create (Session_Mutex); Create (Session_Taken); T_Initialized := True; end Ensure_Initialization; ------------------------- -- Thread Auto_Display -- ------------------------- procedure Auto_Display is Got_Msg : CORBA.Boolean; Msg : CORBA.Any; Ptr : PushConsumer.Impl.Object_Ptr; begin Ptr := PushConsumer.Impl.Object_Ptr (A_S); Enter (Session_Mutex); Signal (Session_Taken); Leave (Session_Mutex); Put_Line ("AutoDisplay setup"); loop exit when EndDisplay; delay 0.1; Try_Pull (Ptr, Got_Msg, Msg); if Got_Msg then Ada.Text_IO.Put_Line (To_Standard_String (From_Any (Msg))); end if; end loop; EndDisplay := False; exception when E : others => Ada.Text_IO.Put_Line ("raised "& Exception_Name (E)); Ada.Text_IO.Put_Line (Exception_Message (E)); Ada.Text_IO.Put_Line (Exception_Information (E)); end Auto_Display; end Auto_Print; polyorb-2.8~20110207.orig/testsuite/corba/cos/notification/README0000644000175000017500000000317211750740340023656 0ustar xavierxavierREADME for PolyORB's COS Notification Service --------------------------------------- PolyORB provides a default implementation of the CORBA COS Notification Service. 1. The executable test_notification tests the functionnalities of generic Cos Notification Service test_event can be started in - interactive mode, an online help details the various commande ./test_notification - batch mode, ./test_notification script_file is a text file containing the same commands as in interactive mode, see online help or comments in script file for more details. There are following scripts for testing : testanypull_multiple.cmd : Tests a scenario consisting of a single untyped pull supplier and different types of push and pull consumers testanypush_multiple.cmd : Tests a scenario consisting of a single untyped push supplier and different types of push and pull consumers teststructuredpush_multiple.cmd : Tests a scenario consisting of a single structured push supplier and different types of push and pull consumers teststructuredpull_multiple.cmd : Tests a scenario consisting of a single structured pull supplier and different types of push and pull consumers testsequencepull_multiple.cmd : Tests a scenario consisting of a single sequence pull supplier and different types of push and pull consumers testsequencepush_multiple.cmd : Tests a scenario consisting of a single sequence push supplier and different types of push and pull consumers polyorb-2.8~20110207.orig/testsuite/corba/cos/notification/Makefile.local0000644000175000017500000000000011750740340025512 0ustar xavierxavierpolyorb-2.8~20110207.orig/testsuite/corba/cos/notification/testanypush_multiple.cmd0000644000175000017500000000133111750740340027760 0ustar xavierxavier#Create Channel create channel c #Creation Phase #Create an untyped PushSupplier create pullsupplier pss #Create untyped Consumer create pushconsumer psc create pullconsumer plc #Create Structured Consumer create structuredpushconsumer pstc create structuredpullconsumer pslc #Create Sequence Consumer create sequencepushconsumer psqsc create sequencepullconsumer psqlc #Connection Phase connect pss to c connect psc to c connect plc to c connect pstc to c connect pslc to c connect psqsc to c connect psqlc to c #Production Phase produce "any push event " in pss #Consumption Phase consume in psc consume in plc tryconsume in plc consume in pstc consume in pslc tryconsume in pslc consume in psqsc consume in psqlc polyorb-2.8~20110207.orig/testsuite/corba/cos/notification/auto_print.ads0000644000175000017500000000533011750740340025651 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- A U T O _ P R I N T -- -- -- -- S p e c -- -- -- -- Copyright (C) 2003 Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by ACT Europe. -- -- (email: sales@act-europe.fr) -- -- -- ------------------------------------------------------------------------------ with CosEventComm; with CORBA.Impl; with PolyORB.Tasking.Mutexes; with PolyORB.Tasking.Condition_Variables; package Auto_Print is use CosEventComm; use PolyORB.Tasking.Condition_Variables; use PolyORB.Tasking.Mutexes; procedure Auto_Display; procedure Ensure_Initialization; pragma Inline (Ensure_Initialization); -- Ensure that the Mutexes are initialized Session_Mutex : Mutex_Access; Session_Taken : Condition_Access; -- Synchornisation of task initialization. EndDisplay : Boolean := False; A_S : CORBA.Impl.Object_Ptr := null; -- This variable is used to initialize the threads local variable. -- it is used to replace the 'accept' statement. end Auto_Print; polyorb-2.8~20110207.orig/testsuite/corba/cos/notification/testsequencepull_multiple.cmd0000644000175000017500000000135111750740340031000 0ustar xavierxavier#Create Channel create channel c #Creation Phase #Create a Sequence PullSupplier create sequencepullsupplier pls #Create untyped Consumer create pushconsumer psc create pullconsumer plc #Create Structured Consumer create structuredpushconsumer pstc create structuredpullconsumer pslc #Create Sequence Consumer create sequencepushconsumer psqsc create sequencepullconsumer psqlc #Connection Phase connect pls to c connect psc to c connect plc to c connect pstc to c connect pslc to c connect psqsc to c connect psqlc to c #Production Phase produce "sequence pull event : 1" in pls #Consumption Phase consume in psc consume in plc tryconsume in plc consume in pstc consume in pslc tryconsume in pslc consume in psqsc consume in psqlc polyorb-2.8~20110207.orig/testsuite/corba/cos/notification/testanypull_multiple.cmd0000644000175000017500000000140011750740340027752 0ustar xavierxavier#Create Channel create channel c #Creation Phase #Create an untyped PullSupplier create pullsupplier pls #Create untyped Consumer create pushconsumer psc create pullconsumer plc #Create Structured Consumer create structuredpushconsumer pstc create structuredpullconsumer pslc #Create Sequence Consumer create sequencepushconsumer psqsc create sequencepullconsumer psqlc #Connection Phase connect pls to c connect psc to c connect plc to c connect pstc to c connect pslc to c connect psqsc to c connect psqlc to c #Production Phase produce "any pull event : 1" in pls produce "any pull event : 2" in pls #Consumption Phase consume in psc consume in plc tryconsume in plc consume in pstc consume in pslc tryconsume in pslc consume in psqsc consume in psqlc polyorb-2.8~20110207.orig/testsuite/corba/cos/notification/testsequencepush_multiple.cmd0000644000175000017500000000127711750740340031012 0ustar xavierxavier#Create Channel create channel c #Creation Phase #Create a Sequence PushSupplier create sequencepushsupplier pss #Create untyped Consumer create pushconsumer psc create pullconsumer plc #Create Structured Consumer create structuredpushconsumer pstc create structuredpullconsumer pslc #Create Sequence Consumer create sequencepushconsumer psqsc create sequencepullconsumer psqlc #Connection Phase connect pss to c connect psc to c connect plc to c connect pstc to c connect pslc to c connect psqsc to c connect psqlc to c #Production Phase produce "sequence push event" in pss #Consumption Phase consume in psc consume in plc consume in pstc consume in pslc consume in psqsc consume in psqlc polyorb-2.8~20110207.orig/testsuite/corba/cos/notification/test_notification.adb0000644000175000017500000023415311750740340027200 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- T E S T _ N O T I F I C A T I O N -- -- -- -- B o d y -- -- -- -- Copyright (C) 2003-2008, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- Test PolyORB COS notification capabilities. with Ada.Command_Line; with Ada.Exceptions; with Ada.Text_IO; with Ada.Integer_Text_IO; with CORBA; with CORBA.Impl; with CORBA.Object; with CORBA.ORB; with PortableServer; with CosNaming.BindingIterator; with CosNaming.NamingContext.Impl; with CosNaming.NamingContext.Helper; with CosNotification; with CosNotification.Helper; with CosNotifyChannelAdmin; with CosNotifyChannelAdmin.ConsumerAdmin; with CosNotifyChannelAdmin.SupplierAdmin; with CosNotifyChannelAdmin.EventChannel.Helper; with CosNotifyChannelAdmin.EventChannelFactory; with CosNotifyChannelAdmin.EventChannelFactory.Impl; with CosNotifyChannelAdmin.ProxyConsumer; with CosNotifyChannelAdmin.ProxySupplier; with CosNotifyChannelAdmin.ProxyPullConsumer.Helper; with CosNotifyChannelAdmin.ProxyPushConsumer.Helper; with CosNotifyChannelAdmin.ProxyPullSupplier.Helper; with CosNotifyChannelAdmin.ProxyPushSupplier.Helper; with CosNotifyChannelAdmin.SequenceProxyPullConsumer.Helper; with CosNotifyChannelAdmin.SequenceProxyPushConsumer.Helper; with CosNotifyChannelAdmin.SequenceProxyPullSupplier.Helper; with CosNotifyChannelAdmin.SequenceProxyPushSupplier.Helper; with CosNotifyChannelAdmin.StructuredProxyPullConsumer.Helper; with CosNotifyChannelAdmin.StructuredProxyPushConsumer.Helper; with CosNotifyChannelAdmin.StructuredProxyPullSupplier.Helper; with CosNotifyChannelAdmin.StructuredProxyPushSupplier.Helper; with CosNotifyComm.PullConsumer.Helper; with CosNotifyComm.PullConsumer.Impl; with CosNotifyComm.PushConsumer.Helper; with CosNotifyComm.PushConsumer.Impl; with CosNotifyComm.PullSupplier.Helper; with CosNotifyComm.PullSupplier.Impl; with CosNotifyComm.PushSupplier.Helper; with CosNotifyComm.PushSupplier.Impl; with CosNotifyComm.SequencePullConsumer.Helper; with CosNotifyComm.SequencePullConsumer.Impl; with CosNotifyComm.SequencePushConsumer.Helper; with CosNotifyComm.SequencePushConsumer.Impl; with CosNotifyComm.SequencePullSupplier.Helper; with CosNotifyComm.SequencePullSupplier.Impl; with CosNotifyComm.SequencePushSupplier.Helper; with CosNotifyComm.SequencePushSupplier.Impl; with CosNotifyComm.StructuredPullConsumer.Helper; with CosNotifyComm.StructuredPullConsumer.Impl; with CosNotifyComm.StructuredPushConsumer.Helper; with CosNotifyComm.StructuredPushConsumer.Impl; with CosNotifyComm.StructuredPullSupplier.Helper; with CosNotifyComm.StructuredPullSupplier.Impl; with CosNotifyComm.StructuredPushSupplier.Helper; with CosNotifyComm.StructuredPushSupplier.Impl; with PolyORB.CORBA_P.Server_Tools; with PolyORB.Any; with PolyORB.Tasking.Condition_Variables; with PolyORB.Tasking.Mutexes; with PolyORB.Tasking.Threads; with PolyORB.Setup.Thread_Pool_Server; pragma Warnings (Off, PolyORB.Setup.Thread_Pool_Server); with Auto_Print; -- Auxiliary code to output pushconsumer incoming messages. with Menu; -- From COS Naming, provide text interface. procedure Test_Notification is use Ada.Exceptions; use Ada.Integer_Text_IO; use Auto_Print; use Menu; use PortableServer; use CORBA; use CosNaming; use CosNotification; use CosNotifyChannelAdmin; use CosNotifyComm; use CosNotifyComm.PushConsumer.Impl; use IDL_SEQUENCE_CosNotifyChannelAdmin_AdminID; use IDL_SEQUENCE_CosNotifyChannelAdmin_ChannelID; use IDL_SEQUENCE_CosNotifyChannelAdmin_ProxyID; use IDL_SEQUENCE_CosNotification_Property; use IDL_SEQUENCE_CosNotification_PropertyError; use IDL_SEQUENCE_CosNotification_NamedPropertyRange; use IDL_SEQUENCE_CosNotification_StructuredEvent; use PolyORB.Any; use PolyORB.CORBA_P.Server_Tools; use PolyORB.Tasking.Condition_Variables; use PolyORB.Tasking.Mutexes; use PolyORB.Tasking.Threads; type Command is (Help, Quit, Run, Sleep, Connect, Consume, TryConsume, Produce, AutoDisplay, Create); Syntax_Error : exception; Help_Messages : constant array (Command) of String_Access := (Help => +(ASCII.HT & "print this message"), Quit => +(ASCII.HT & "quit this shell"), Run => +(ASCII.HT & "run "), Sleep => +(ASCII.HT & "sleep "), Create => +(ASCII.HT & "create "), Connect => +(ASCII.HT & "connect to "), Consume => +(ASCII.HT & "consume in "), TryConsume => +("tryconsume in "), AutoDisplay => +("autodisplay "), Produce => +(ASCII.HT & "produce in [ times]")); type Entity_Kind is (K_Channel, K_PullConsumer, K_PullSupplier, K_PushConsumer, K_PushSupplier, K_SequencePullConsumer, K_SequencePullSupplier, K_SequencePushConsumer, K_SequencePushSupplier, K_StructuredPullConsumer, K_StructuredPullSupplier, K_StructuredPushConsumer, K_StructuredPushSupplier); Image : constant array (Entity_Kind) of CosNaming.Istring := (K_Channel => CosNaming.To_CORBA_String (K_Channel'Img), K_PullConsumer => CosNaming.To_CORBA_String (K_PullConsumer'Img), K_PullSupplier => CosNaming.To_CORBA_String (K_PullSupplier'Img), K_PushConsumer => CosNaming.To_CORBA_String (K_PushConsumer'Img), K_PushSupplier => CosNaming.To_CORBA_String (K_PushSupplier'Img), K_SequencePullConsumer => CosNaming.To_CORBA_String (K_SequencePullConsumer'Img), K_SequencePullSupplier => CosNaming.To_CORBA_String (K_SequencePullSupplier'Img), K_SequencePushConsumer => CosNaming.To_CORBA_String (K_SequencePushConsumer'Img), K_SequencePushSupplier => CosNaming.To_CORBA_String (K_SequencePushSupplier'Img), K_StructuredPushConsumer => CosNaming.To_CORBA_String (K_StructuredPushConsumer'Img), K_StructuredPushSupplier => CosNaming.To_CORBA_String (K_StructuredPushSupplier'Img), K_StructuredPullConsumer => CosNaming.To_CORBA_String (K_StructuredPullConsumer'Img), K_StructuredPullSupplier => CosNaming.To_CORBA_String (K_StructuredPullSupplier'Img)); Ctx : NamingContext.Ref; -------------------- -- Connect_Entity -- -------------------- procedure Connect_Entity (Entity : CORBA.Object.Ref; Kind : Entity_Kind; Channel : CosNotifyChannelAdmin.EventChannel.Ref); procedure Connect_Entity (Entity : CORBA.Object.Ref; Kind : Entity_Kind; Channel : CosNotifyChannelAdmin.EventChannel.Ref) is O : CORBA.Impl.Object_Ptr; begin case Kind is when K_PullConsumer => declare A : CosNotifyChannelAdmin.ConsumerAdmin.Ref; E : CosNotifyComm.PullConsumer.Ref; P : CosNotifyChannelAdmin.ProxySupplier.Ref; PP_Ref : CosNotifyChannelAdmin.ProxyPullSupplier.Ref; Ctype : constant CosNotifyChannelAdmin.ClientType := ANY_EVENT; CID : CosNotifyChannelAdmin.AdminID; PID : CosNotifyChannelAdmin.ProxyID; My_Op : constant CosNotifyChannelAdmin.InterFilterGroupOperator := AND_OP; begin CosNotifyChannelAdmin.EventChannel. new_for_consumers (Channel, My_Op, CID, A); -- There are 2 methods for creating a consumer/supplier admin -- one is used here and the other is used for pushconsumer CID := CosNotifyChannelAdmin.ConsumerAdmin.Get_MyID (A); Ada.Text_IO.Put ("The ID of consumer admin is : "); Ada.Integer_Text_IO.Put (Integer (CID), 3); Ada.Text_IO.New_Line; CosNotifyChannelAdmin.ConsumerAdmin. obtain_notification_pull_supplier (A, Ctype, PID, P); PP_Ref := CosNotifyChannelAdmin.ProxyPullSupplier.Helper.To_Ref (P); E := CosNotifyComm.PullConsumer.Helper.To_Ref (Entity); Reference_To_Servant (E, Servant (O)); PullConsumer.Impl.Connect_Any_Proxy_Pull_Supplier (PullConsumer.Impl.Object_Ptr (O), PP_Ref); end; when K_PushConsumer => declare A : CosNotifyChannelAdmin.ConsumerAdmin.Ref; E : CosNotifyComm.PushConsumer.Ref; P : CosNotifyChannelAdmin.ProxySupplier.Ref; PP_Ref : CosNotifyChannelAdmin.ProxyPushSupplier.Ref; Ctype : constant CosNotifyChannelAdmin.ClientType := ANY_EVENT; CID : CosNotifyChannelAdmin.AdminID; PID : CosNotifyChannelAdmin.ProxyID; begin A := CosNotifyChannelAdmin.EventChannel. Get_default_consumer_admin (Channel); -- There are 2 methods for creating a consumer/supplier admin -- one is used here and the other is used for pullconsumer CID := CosNotifyChannelAdmin.ConsumerAdmin.Get_MyID (A); Ada.Text_IO.Put ("The ID of consumer admin is : "); Ada.Integer_Text_IO.Put (Integer (CID), 3); Ada.Text_IO.New_Line; CosNotifyChannelAdmin.ConsumerAdmin. obtain_notification_push_supplier (A, Ctype, PID, P); PP_Ref := CosNotifyChannelAdmin.ProxyPushSupplier.Helper.To_Ref (P); E := CosNotifyComm.PushConsumer.Helper.To_Ref (Entity); Reference_To_Servant (E, Servant (O)); PushConsumer.Impl.Connect_Any_Proxy_Push_Supplier (PushConsumer.Impl.Object_Ptr (O), PP_Ref); end; when K_PullSupplier => declare A : CosNotifyChannelAdmin.SupplierAdmin.Ref; E : CosNotifyComm.PullSupplier.Ref; P : CosNotifyChannelAdmin.ProxyConsumer.Ref; PP_Ref : CosNotifyChannelAdmin.ProxyPullConsumer.Ref; Ctype : constant CosNotifyChannelAdmin.ClientType := ANY_EVENT; PID : CosNotifyChannelAdmin.ProxyID; SID : CosNotifyChannelAdmin.AdminID; My_Op : constant CosNotifyChannelAdmin.InterFilterGroupOperator := AND_OP; begin CosNotifyChannelAdmin.EventChannel. new_for_suppliers (Channel, My_Op, SID, A); -- There are 2 methods for creating a consumer/supplier admin -- one is used here and the other is used for pushsupplier SID := CosNotifyChannelAdmin.SupplierAdmin.Get_MyID (A); Ada.Text_IO.Put ("The ID of supplier admin is : "); Ada.Integer_Text_IO.Put (Integer (SID), 3); Ada.Text_IO.New_Line; CosNotifyChannelAdmin.SupplierAdmin. obtain_notification_pull_consumer (A, Ctype, PID, P); PP_Ref := CosNotifyChannelAdmin.ProxyPullConsumer.Helper.To_Ref (P); E := CosNotifyComm.PullSupplier.Helper.To_Ref (Entity); Reference_To_Servant (E, Servant (O)); PullSupplier.Impl.Connect_Any_Proxy_Pull_Consumer (PullSupplier.Impl.Object_Ptr (O), PP_Ref); end; when K_PushSupplier => declare A : CosNotifyChannelAdmin.SupplierAdmin.Ref; E : CosNotifyComm.PushSupplier.Ref; P : CosNotifyChannelAdmin.ProxyConsumer.Ref; PP_Ref : CosNotifyChannelAdmin.ProxyPushConsumer.Ref; Ctype : constant CosNotifyChannelAdmin.ClientType := ANY_EVENT; PID : CosNotifyChannelAdmin.ProxyID; SID : CosNotifyChannelAdmin.AdminID; begin A := CosNotifyChannelAdmin.EventChannel. Get_default_supplier_admin (Channel); -- There are 2 methods for creating a consumer/supplier admin -- one is used here and the other is used for pullsupplier SID := CosNotifyChannelAdmin.SupplierAdmin.Get_MyID (A); Ada.Text_IO.Put ("The ID of supplier admin is : "); Ada.Integer_Text_IO.Put (Integer (SID), 3); Ada.Text_IO.New_Line; CosNotifyChannelAdmin.SupplierAdmin. obtain_notification_push_consumer (A, Ctype, PID, P); PP_Ref := CosNotifyChannelAdmin.ProxyPushConsumer.Helper.To_Ref (P); E := CosNotifyComm.PushSupplier.Helper.To_Ref (Entity); Reference_To_Servant (E, Servant (O)); PushSupplier.Impl.Connect_Any_Proxy_Push_Consumer (PushSupplier.Impl.Object_Ptr (O), PP_Ref); end; when K_SequencePullConsumer => declare A : CosNotifyChannelAdmin.ConsumerAdmin.Ref; E : CosNotifyComm.SequencePullConsumer.Ref; P : CosNotifyChannelAdmin.ProxySupplier.Ref; PP_Ref : CosNotifyChannelAdmin.SequenceProxyPullSupplier.Ref; Ctype : constant CosNotifyChannelAdmin.ClientType := SEQUENCE_EVENT; CID : CosNotifyChannelAdmin.AdminID; PID : CosNotifyChannelAdmin.ProxyID; My_Op : constant CosNotifyChannelAdmin.InterFilterGroupOperator := AND_OP; begin CosNotifyChannelAdmin.EventChannel. new_for_consumers (Channel, My_Op, CID, A); -- There are 2 methods for creating a consumer/supplier admin -- one is used here and the other is used for pushconsumer CID := CosNotifyChannelAdmin.ConsumerAdmin.Get_MyID (A); Ada.Text_IO.Put ("The ID of consumer admin is : "); Ada.Integer_Text_IO.Put (Integer (CID), 3); Ada.Text_IO.New_Line; CosNotifyChannelAdmin.ConsumerAdmin. obtain_notification_pull_supplier (A, Ctype, PID, P); PP_Ref := CosNotifyChannelAdmin.SequenceProxyPullSupplier. Helper.To_Ref (P); E := CosNotifyComm.SequencePullConsumer.Helper.To_Ref (Entity); Reference_To_Servant (E, Servant (O)); SequencePullConsumer.Impl.Connect_Sequence_Proxy_Pull_Supplier (SequencePullConsumer.Impl.Object_Ptr (O), PP_Ref); end; when K_SequencePullSupplier => declare A : CosNotifyChannelAdmin.SupplierAdmin.Ref; E : CosNotifyComm.SequencePullSupplier.Ref; P : CosNotifyChannelAdmin.ProxyConsumer.Ref; PP_Ref : CosNotifyChannelAdmin.SequenceProxyPullConsumer.Ref; Ctype : constant CosNotifyChannelAdmin.ClientType := SEQUENCE_EVENT; PID : CosNotifyChannelAdmin.ProxyID; SID : CosNotifyChannelAdmin.AdminID; My_Op : constant CosNotifyChannelAdmin.InterFilterGroupOperator := AND_OP; begin CosNotifyChannelAdmin.EventChannel. new_for_suppliers (Channel, My_Op, SID, A); -- There are 2 methods for creating a consumer/supplier admin -- one is used here and the other is used for pullsupplier SID := CosNotifyChannelAdmin.SupplierAdmin.Get_MyID (A); Ada.Text_IO.Put ("The ID of supplier admin is : "); Ada.Integer_Text_IO.Put (Integer (SID), 3); Ada.Text_IO.New_Line; CosNotifyChannelAdmin.SupplierAdmin. obtain_notification_pull_consumer (A, Ctype, PID, P); PP_Ref := CosNotifyChannelAdmin.SequenceProxyPullConsumer. Helper.To_Ref (P); E := CosNotifyComm.SequencePullSupplier.Helper.To_Ref (Entity); Reference_To_Servant (E, Servant (O)); SequencePullSupplier.Impl.Connect_Sequence_Proxy_Pull_Consumer (SequencePullSupplier.Impl.Object_Ptr (O), PP_Ref); end; when K_SequencePushConsumer => declare A : CosNotifyChannelAdmin.ConsumerAdmin.Ref; E : CosNotifyComm.SequencePushConsumer.Ref; P : CosNotifyChannelAdmin.ProxySupplier.Ref; PP_Ref : CosNotifyChannelAdmin.SequenceProxyPushSupplier.Ref; Ctype : constant CosNotifyChannelAdmin.ClientType := SEQUENCE_EVENT; CID : CosNotifyChannelAdmin.AdminID; PID : CosNotifyChannelAdmin.ProxyID; My_Op : constant CosNotifyChannelAdmin.InterFilterGroupOperator := AND_OP; begin CosNotifyChannelAdmin.EventChannel. new_for_consumers (Channel, My_Op, CID, A); -- There are 2 methods for creating a consumer/supplier admin -- one is used here and the other is used for pushconsumer CID := CosNotifyChannelAdmin.ConsumerAdmin.Get_MyID (A); Ada.Text_IO.Put ("The ID of consumer admin is : "); Ada.Integer_Text_IO.Put (Integer (CID), 3); Ada.Text_IO.New_Line; CosNotifyChannelAdmin.ConsumerAdmin. obtain_notification_push_supplier (A, Ctype, PID, P); PP_Ref := CosNotifyChannelAdmin.SequenceProxyPushSupplier. Helper.To_Ref (P); E := CosNotifyComm.SequencePushConsumer. Helper.To_Ref (Entity); Reference_To_Servant (E, Servant (O)); SequencePushConsumer.Impl. Connect_Sequence_Proxy_Push_Supplier (SequencePushConsumer.Impl.Object_Ptr (O), PP_Ref); end; when K_SequencePushSupplier => declare A : CosNotifyChannelAdmin.SupplierAdmin.Ref; E : CosNotifyComm.SequencePushSupplier.Ref; P : CosNotifyChannelAdmin.ProxyConsumer.Ref; PP_Ref : CosNotifyChannelAdmin.SequenceProxyPushConsumer.Ref; Ctype : constant CosNotifyChannelAdmin.ClientType := SEQUENCE_EVENT; PID : CosNotifyChannelAdmin.ProxyID; SID : CosNotifyChannelAdmin.AdminID; My_Op : constant CosNotifyChannelAdmin.InterFilterGroupOperator := AND_OP; begin CosNotifyChannelAdmin.EventChannel. new_for_suppliers (Channel, My_Op, SID, A); -- There are 2 methods for creating a consumer/supplier admin -- one is used here and the other is used for pullsupplier SID := CosNotifyChannelAdmin.SupplierAdmin.Get_MyID (A); Ada.Text_IO.Put ("The ID of supplier admin is : "); Ada.Integer_Text_IO.Put (Integer (SID), 3); Ada.Text_IO.New_Line; CosNotifyChannelAdmin.SupplierAdmin. obtain_notification_push_consumer (A, Ctype, PID, P); PP_Ref := CosNotifyChannelAdmin.SequenceProxyPushConsumer. Helper.To_Ref (P); E := CosNotifyComm.SequencePushSupplier. Helper.To_Ref (Entity); Reference_To_Servant (E, Servant (O)); SequencePushSupplier.Impl. Connect_Sequence_Proxy_Push_Consumer (SequencePushSupplier.Impl.Object_Ptr (O), PP_Ref); end; when K_StructuredPullConsumer => declare A : CosNotifyChannelAdmin.ConsumerAdmin.Ref; E : CosNotifyComm.StructuredPullConsumer.Ref; P : CosNotifyChannelAdmin.ProxySupplier.Ref; PP_Ref : CosNotifyChannelAdmin.StructuredProxyPullSupplier.Ref; Ctype : constant CosNotifyChannelAdmin.ClientType := STRUCTURED_EVENT; CID : CosNotifyChannelAdmin.AdminID; PID : CosNotifyChannelAdmin.ProxyID; My_Op : constant CosNotifyChannelAdmin.InterFilterGroupOperator := AND_OP; begin CosNotifyChannelAdmin.EventChannel. new_for_consumers (Channel, My_Op, CID, A); -- There are 2 methods for creating a consumer/supplier admin -- one is used here and the other is used for pushconsumer CID := CosNotifyChannelAdmin.ConsumerAdmin.Get_MyID (A); Ada.Text_IO.Put ("The ID of consumer admin is : "); Ada.Integer_Text_IO.Put (Integer (CID), 3); Ada.Text_IO.New_Line; CosNotifyChannelAdmin.ConsumerAdmin. obtain_notification_pull_supplier (A, Ctype, PID, P); PP_Ref := CosNotifyChannelAdmin.StructuredProxyPullSupplier. Helper.To_Ref (P); E := CosNotifyComm.StructuredPullConsumer. Helper.To_Ref (Entity); Reference_To_Servant (E, Servant (O)); StructuredPullConsumer.Impl. Connect_Structured_Proxy_Pull_Supplier (StructuredPullConsumer.Impl.Object_Ptr (O), PP_Ref); end; when K_StructuredPullSupplier => declare A : CosNotifyChannelAdmin.SupplierAdmin.Ref; E : CosNotifyComm.StructuredPullSupplier.Ref; P : CosNotifyChannelAdmin.ProxyConsumer.Ref; PP_Ref : CosNotifyChannelAdmin.StructuredProxyPullConsumer.Ref; Ctype : constant CosNotifyChannelAdmin.ClientType := STRUCTURED_EVENT; PID : CosNotifyChannelAdmin.ProxyID; SID : CosNotifyChannelAdmin.AdminID; My_Op : constant CosNotifyChannelAdmin.InterFilterGroupOperator := AND_OP; begin CosNotifyChannelAdmin.EventChannel. new_for_suppliers (Channel, My_Op, SID, A); -- There are 2 methods for creating a consumer/supplier admin -- one is used here and the other is used for pullsupplier SID := CosNotifyChannelAdmin.SupplierAdmin.Get_MyID (A); Ada.Text_IO.Put ("The ID of supplier admin is : "); Ada.Integer_Text_IO.Put (Integer (SID), 3); Ada.Text_IO.New_Line; CosNotifyChannelAdmin.SupplierAdmin. obtain_notification_pull_consumer (A, Ctype, PID, P); PP_Ref := CosNotifyChannelAdmin.StructuredProxyPullConsumer. Helper.To_Ref (P); E := CosNotifyComm.StructuredPullSupplier. Helper.To_Ref (Entity); Reference_To_Servant (E, Servant (O)); StructuredPullSupplier.Impl. Connect_Structured_Proxy_Pull_Consumer (StructuredPullSupplier.Impl.Object_Ptr (O), PP_Ref); end; when K_StructuredPushConsumer => declare A : CosNotifyChannelAdmin.ConsumerAdmin.Ref; E : CosNotifyComm.StructuredPushConsumer.Ref; P : CosNotifyChannelAdmin.ProxySupplier.Ref; PP_Ref : CosNotifyChannelAdmin.StructuredProxyPushSupplier.Ref; Ctype : constant CosNotifyChannelAdmin.ClientType := STRUCTURED_EVENT; CID : CosNotifyChannelAdmin.AdminID; PID : CosNotifyChannelAdmin.ProxyID; My_Op : constant CosNotifyChannelAdmin.InterFilterGroupOperator := AND_OP; begin CosNotifyChannelAdmin.EventChannel. new_for_consumers (Channel, My_Op, CID, A); -- There are 2 methods for creating a consumer/supplier admin -- one is used here and the other is used for pushconsumer CID := CosNotifyChannelAdmin.ConsumerAdmin.Get_MyID (A); Ada.Text_IO.Put ("The ID of consumer admin is : "); Ada.Integer_Text_IO.Put (Integer (CID), 3); Ada.Text_IO.New_Line; CosNotifyChannelAdmin.ConsumerAdmin. obtain_notification_push_supplier (A, Ctype, PID, P); PP_Ref := CosNotifyChannelAdmin.StructuredProxyPushSupplier. Helper.To_Ref (P); E := CosNotifyComm.StructuredPushConsumer. Helper.To_Ref (Entity); Reference_To_Servant (E, Servant (O)); StructuredPushConsumer.Impl. Connect_Structured_Proxy_Push_Supplier (StructuredPushConsumer.Impl.Object_Ptr (O), PP_Ref); end; when K_StructuredPushSupplier => declare A : CosNotifyChannelAdmin.SupplierAdmin.Ref; E : CosNotifyComm.StructuredPushSupplier.Ref; P : CosNotifyChannelAdmin.ProxyConsumer.Ref; PP_Ref : CosNotifyChannelAdmin.StructuredProxyPushConsumer.Ref; Ctype : constant CosNotifyChannelAdmin.ClientType := STRUCTURED_EVENT; PID : CosNotifyChannelAdmin.ProxyID; SID : CosNotifyChannelAdmin.AdminID; My_Op : constant CosNotifyChannelAdmin.InterFilterGroupOperator := AND_OP; begin CosNotifyChannelAdmin.EventChannel. new_for_suppliers (Channel, My_Op, SID, A); -- There are 2 methods for creating a consumer/supplier admin -- one is used here and the other is used for pullsupplier SID := CosNotifyChannelAdmin.SupplierAdmin.Get_MyID (A); Ada.Text_IO.Put ("The ID of supplier admin is : "); Ada.Integer_Text_IO.Put (Integer (SID), 3); Ada.Text_IO.New_Line; CosNotifyChannelAdmin.SupplierAdmin. obtain_notification_push_consumer (A, Ctype, PID, P); PP_Ref := CosNotifyChannelAdmin.StructuredProxyPushConsumer. Helper.To_Ref (P); E := CosNotifyComm.StructuredPushSupplier. Helper.To_Ref (Entity); Reference_To_Servant (E, Servant (O)); StructuredPushSupplier.Impl. Connect_Structured_Proxy_Push_Consumer (StructuredPushSupplier.Impl.Object_Ptr (O), PP_Ref); end; when K_Channel => raise Syntax_Error; end case; end Connect_Entity; ------------------- -- Consume_Event -- ------------------- procedure Consume_Event (Entity : CORBA.Object.Ref; Kind : Entity_Kind); procedure Consume_Event (Entity : CORBA.Object.Ref; Kind : Entity_Kind) is O : CORBA.Impl.Object_Ptr; A : CORBA.Any; begin case Kind is when K_PullConsumer => declare C : CosNotifyComm.PullConsumer.Ref; Notification : CosNotification.StructuredEvent; begin C := CosNotifyComm.PullConsumer.Helper.To_Ref (Entity); Reference_To_Servant (C, Servant (O)); A := CosNotifyComm.PullConsumer.Impl.Pull (PullConsumer.Impl.Object_Ptr (O)); declare Tc : constant CORBA.TypeCode.Object := CORBA.Get_Type (A); MyKind : constant CORBA.TCKind := CORBA.TypeCode.Kind (Tc); begin if MyKind = PolyORB.Any.Tk_Struct then Ada.Text_IO.Put_Line ("TypeCode Kind : Tk_Struct"); Notification := CosNotification.Helper.From_Any (A); Ada.Text_IO.Put_Line (CORBA.To_Standard_String (CORBA.From_Any (Notification.remainder_of_body))); elsif MyKind = PolyORB.Any.Tk_String then Ada.Text_IO.Put_Line ("TypeCode Kind : String"); Ada.Text_IO.Put_Line (CORBA.To_Standard_String (From_Any (A))); else Ada.Text_IO.Put_Line ("Error : Event type Not Known"); end if; end; end; when K_PushConsumer => declare C : CosNotifyComm.PushConsumer.Ref; Notification : CosNotification.StructuredEvent; begin C := CosNotifyComm.PushConsumer.Helper.To_Ref (Entity); Reference_To_Servant (C, Servant (O)); A := CosNotifyComm.PushConsumer.Impl.Pull (PushConsumer.Impl.Object_Ptr (O)); declare Tc : constant CORBA.TypeCode.Object := CORBA.Get_Type (A); MyKind : constant CORBA.TCKind := CORBA.TypeCode.Kind (Tc); begin if MyKind = PolyORB.Any.Tk_Struct then Ada.Text_IO.Put_Line ("TypeCode Kind : Tk_Struct"); Notification := CosNotification.Helper.From_Any (A); Ada.Text_IO.Put_Line (CORBA.To_Standard_String (CORBA.From_Any (Notification.remainder_of_body))); elsif MyKind = PolyORB.Any.Tk_String then Ada.Text_IO.Put_Line ("TypeCode Kind : String"); Ada.Text_IO.Put_Line (CORBA.To_Standard_String (From_Any (A))); else Ada.Text_IO.Put_Line ("Error : Event type Not Known"); end if; end; end; when K_SequencePushConsumer => declare C : CosNotifyComm.SequencePushConsumer.Ref; Notification : CosNotification.StructuredEvent; MyDomainName : CORBA.String; MyTypeName : CORBA.String; MyName : CORBA.String; MyBody : CORBA.Any; MyStructEvent_Seq : CosNotification.EventBatch; SeqLen : Integer; begin C := CosNotifyComm.SequencePushConsumer.Helper.To_Ref (Entity); Reference_To_Servant (C, Servant (O)); MyStructEvent_Seq := CosNotifyComm.SequencePushConsumer.Impl. Pull (SequencePushConsumer.Impl.Object_Ptr (O)); SeqLen := Length (MyStructEvent_Seq); for Index in 1 .. SeqLen loop Notification := Get_Element (MyStructEvent_Seq, Index); Ada.Text_IO.Put_Line ("Main components of structured event"); MyDomainName := Notification.header.fixed_header.event_type.domain_name; Ada.Text_IO.Put ("My Domain : "); Ada.Text_IO.Put (CORBA.To_Standard_String (MyDomainName)); Ada.Text_IO.New_Line; MyTypeName := Notification.header.fixed_header.event_type.type_name; Ada.Text_IO.Put ("My Type : "); Ada.Text_IO.Put (CORBA.To_Standard_String (MyTypeName)); Ada.Text_IO.New_Line; MyName := Notification.header.fixed_header.event_name; Ada.Text_IO.Put ("My Name : "); Ada.Text_IO.Put (CORBA.To_Standard_String (MyName)); Ada.Text_IO.New_Line; MyBody := Notification.remainder_of_body; Ada.Text_IO.Put ("Event Body : "); Ada.Text_IO.Put (CORBA.To_Standard_String (CORBA.From_Any (MyBody))); Ada.Text_IO.New_Line; end loop; end; when K_SequencePullConsumer => declare C : CosNotifyComm.SequencePullConsumer.Ref; Notification : CosNotification.StructuredEvent; MyDomainName : CORBA.String; MyTypeName : CORBA.String; MyName : CORBA.String; MyBody : CORBA.Any; MyStructEvent_Seq : CosNotification.EventBatch; SeqLen : Integer; Num_Event : constant CORBA.Long := 2; begin C := CosNotifyComm.SequencePullConsumer.Helper.To_Ref (Entity); Reference_To_Servant (C, Servant (O)); MyStructEvent_Seq := CosNotifyComm.SequencePullConsumer.Impl.Pull (SequencePullConsumer.Impl.Object_Ptr (O), Num_Event); SeqLen := Length (MyStructEvent_Seq); for Index in 1 .. SeqLen loop Notification := Get_Element (MyStructEvent_Seq, Index); Ada.Text_IO.Put_Line ("Main components of structured event"); MyDomainName := Notification.header.fixed_header.event_type.domain_name; Ada.Text_IO.Put ("My Domain : "); Ada.Text_IO.Put (CORBA.To_Standard_String (MyDomainName)); Ada.Text_IO.New_Line; MyTypeName := Notification.header.fixed_header.event_type.type_name; Ada.Text_IO.Put ("My Type : "); Ada.Text_IO.Put (CORBA.To_Standard_String (MyTypeName)); Ada.Text_IO.New_Line; MyName := Notification.header.fixed_header.event_name; Ada.Text_IO.Put ("My Name : "); Ada.Text_IO.Put (CORBA.To_Standard_String (MyName)); Ada.Text_IO.New_Line; MyBody := Notification.remainder_of_body; Ada.Text_IO.Put ("Event Body : "); Ada.Text_IO.Put (CORBA.To_Standard_String (CORBA.From_Any (MyBody))); Ada.Text_IO.New_Line; end loop; end; when K_StructuredPullConsumer => declare C : CosNotifyComm.StructuredPullConsumer.Ref; Notification : CosNotification.StructuredEvent; MyDomainName : CORBA.String; MyTypeName : CORBA.String; MyName : CORBA.String; MyBody : CORBA.Any; begin C := CosNotifyComm.StructuredPullConsumer. Helper.To_Ref (Entity); Reference_To_Servant (C, Servant (O)); Notification := CosNotifyComm.StructuredPullConsumer.Impl.Pull (StructuredPullConsumer.Impl.Object_Ptr (O)); Ada.Text_IO.Put_Line ("Main components of structured event"); MyDomainName := Notification.header.fixed_header.event_type.domain_name; Ada.Text_IO.Put ("My Domain : "); Ada.Text_IO.Put (CORBA.To_Standard_String (MyDomainName)); Ada.Text_IO.New_Line; MyTypeName := Notification.header.fixed_header.event_type.type_name; Ada.Text_IO.Put ("My Type : "); Ada.Text_IO.Put (CORBA.To_Standard_String (MyTypeName)); Ada.Text_IO.New_Line; MyName := Notification.header.fixed_header.event_name; Ada.Text_IO.Put ("My Name : "); Ada.Text_IO.Put (CORBA.To_Standard_String (MyName)); Ada.Text_IO.New_Line; MyBody := Notification.remainder_of_body; Ada.Text_IO.Put ("Event Body : "); Ada.Text_IO.Put (CORBA.To_Standard_String (CORBA.From_Any (MyBody))); Ada.Text_IO.New_Line; end; when K_StructuredPushConsumer => declare C : CosNotifyComm.StructuredPushConsumer.Ref; Notification : CosNotification.StructuredEvent; MyDomainName : CORBA.String; MyTypeName : CORBA.String; MyName : CORBA.String; MyBody : CORBA.Any; begin C := CosNotifyComm.StructuredPushConsumer. Helper.To_Ref (Entity); Reference_To_Servant (C, Servant (O)); Notification := CosNotifyComm.StructuredPushConsumer.Impl.Pull (StructuredPushConsumer.Impl.Object_Ptr (O)); Ada.Text_IO.Put_Line ("Main components of structured event"); MyDomainName := Notification.header.fixed_header.event_type.domain_name; Ada.Text_IO.Put ("My Domain : "); Ada.Text_IO.Put (CORBA.To_Standard_String (MyDomainName)); Ada.Text_IO.New_Line; MyTypeName := Notification.header.fixed_header.event_type.type_name; Ada.Text_IO.Put ("My Type : "); Ada.Text_IO.Put (CORBA.To_Standard_String (MyTypeName)); Ada.Text_IO.New_Line; MyName := Notification.header.fixed_header.event_name; Ada.Text_IO.Put ("My Name : "); Ada.Text_IO.Put (CORBA.To_Standard_String (MyName)); Ada.Text_IO.New_Line; MyBody := Notification.remainder_of_body; Ada.Text_IO.Put ("Event Body : "); Ada.Text_IO.Put (CORBA.To_Standard_String (CORBA.From_Any (MyBody))); Ada.Text_IO.New_Line; end; when others => null; end case; end Consume_Event; ----------------------- -- Try_Consume_Event -- ----------------------- procedure Try_Consume_Event (Entity : CORBA.Object.Ref; Kind : Entity_Kind); procedure Try_Consume_Event (Entity : CORBA.Object.Ref; Kind : Entity_Kind) is O : CORBA.Impl.Object_Ptr; A : CORBA.Any; B : CORBA.Boolean; Notification : CosNotification.StructuredEvent; begin case Kind is when K_PullConsumer => declare C : CosNotifyComm.PullConsumer.Ref; begin C := CosNotifyComm.PullConsumer.Helper.To_Ref (Entity); Reference_To_Servant (C, Servant (O)); CosNotifyComm.PullConsumer.Impl.Try_Pull (CosNotifyComm.PullConsumer.Impl.Object_Ptr (O), B, A); if B then declare Tc : constant CORBA.TypeCode.Object := CORBA.Get_Type (A); MyKind : constant CORBA.TCKind := CORBA.TypeCode.Kind (Tc); begin if MyKind = PolyORB.Any.Tk_Struct then Ada.Text_IO.Put_Line ("TypeCode Kind : Tk_Struct"); Notification := CosNotification.Helper.From_Any (A); Ada.Text_IO.Put_Line (CORBA.To_Standard_String (CORBA.From_Any (Notification.remainder_of_body))); elsif MyKind = PolyORB.Any.Tk_String then Ada.Text_IO.Put_Line ("TypeCode Kind : String"); Ada.Text_IO.Put_Line (CORBA.To_Standard_String (From_Any (A))); else Ada.Text_IO.Put_Line ("Error : Event type Not Known"); end if; end; else Ada.Text_IO.Put_Line ("Nothing to consume!!!"); end if; end; when K_PushConsumer => declare C : CosNotifyComm.PushConsumer.Ref; begin C := CosNotifyComm.PushConsumer.Helper.To_Ref (Entity); Reference_To_Servant (C, Servant (O)); CosNotifyComm.PushConsumer.Impl.Try_Pull (CosNotifyComm.PushConsumer.Impl.Object_Ptr (O), B, A); if B then declare Tc : constant CORBA.TypeCode.Object := CORBA.Get_Type (A); MyKind : constant CORBA.TCKind := CORBA.TypeCode.Kind (Tc); begin if MyKind = PolyORB.Any.Tk_Struct then Ada.Text_IO.Put_Line ("TypeCode Kind : Tk_Struct"); Notification := CosNotification.Helper.From_Any (A); Ada.Text_IO.Put_Line (CORBA.To_Standard_String (CORBA.From_Any (Notification.remainder_of_body))); elsif MyKind = PolyORB.Any.Tk_String then Ada.Text_IO.Put_Line ("TypeCode Kind : String"); Ada.Text_IO.Put_Line (CORBA.To_Standard_String (From_Any (A))); else Ada.Text_IO.Put_Line ("Error : Event type Not Known"); end if; end; else Ada.Text_IO.Put_Line ("Nothing to consume!!!"); end if; end; when K_SequencePushConsumer => declare C : CosNotifyComm.SequencePushConsumer.Ref; Notification : CosNotification.StructuredEvent; MyDomainName : CORBA.String; MyTypeName : CORBA.String; MyName : CORBA.String; MyBody : CORBA.Any; MyStructEvent_Seq : CosNotification.EventBatch; SeqLen : Integer; begin C := CosNotifyComm.SequencePushConsumer.Helper.To_Ref (Entity); Reference_To_Servant (C, Servant (O)); CosNotifyComm.SequencePushConsumer.Impl.Try_Pull (SequencePushConsumer.Impl.Object_Ptr (O), B, MyStructEvent_Seq); if B then SeqLen := Length (MyStructEvent_Seq); for Index in 1 .. SeqLen loop Notification := Get_Element (MyStructEvent_Seq, Index); Ada.Text_IO.Put_Line ("Main components of structured event"); MyDomainName := Notification.header.fixed_header.event_type.domain_name; Ada.Text_IO.Put ("My Domain : "); Ada.Text_IO.Put (CORBA.To_Standard_String (MyDomainName)); Ada.Text_IO.New_Line; MyTypeName := Notification.header.fixed_header.event_type.type_name; Ada.Text_IO.Put ("My Type : "); Ada.Text_IO.Put (CORBA.To_Standard_String (MyTypeName)); Ada.Text_IO.New_Line; MyName := Notification.header.fixed_header.event_name; Ada.Text_IO.Put ("My Name : "); Ada.Text_IO.Put (CORBA.To_Standard_String (MyName)); Ada.Text_IO.New_Line; MyBody := Notification.remainder_of_body; Ada.Text_IO.Put ("Event Body : "); Ada.Text_IO.Put (CORBA.To_Standard_String (CORBA.From_Any (MyBody))); Ada.Text_IO.New_Line; end loop; else Ada.Text_IO.Put_Line ("Nothing to consume!!!"); end if; end; when K_SequencePullConsumer => declare C : CosNotifyComm.SequencePullConsumer.Ref; Notification : CosNotification.StructuredEvent; MyDomainName : CORBA.String; MyTypeName : CORBA.String; MyName : CORBA.String; MyBody : CORBA.Any; MyStructEvent_Seq : CosNotification.EventBatch; SeqLen : Integer; Num_Event : constant CORBA.Long := 2; begin C := CosNotifyComm.SequencePullConsumer.Helper.To_Ref (Entity); Reference_To_Servant (C, Servant (O)); CosNotifyComm.SequencePullConsumer.Impl.Try_Pull (SequencePullConsumer.Impl.Object_Ptr (O), Num_Event, B, MyStructEvent_Seq); if B then SeqLen := Length (MyStructEvent_Seq); for Index in 1 .. SeqLen loop Notification := Get_Element (MyStructEvent_Seq, Index); Ada.Text_IO.Put_Line ("Main components of structured event"); MyDomainName := Notification.header.fixed_header.event_type.domain_name; Ada.Text_IO.Put ("My Domain : "); Ada.Text_IO.Put (CORBA.To_Standard_String (MyDomainName)); Ada.Text_IO.New_Line; MyTypeName := Notification.header.fixed_header.event_type.type_name; Ada.Text_IO.Put ("My Type : "); Ada.Text_IO.Put (CORBA.To_Standard_String (MyTypeName)); Ada.Text_IO.New_Line; MyName := Notification.header.fixed_header.event_name; Ada.Text_IO.Put ("My Name : "); Ada.Text_IO.Put (CORBA.To_Standard_String (MyName)); Ada.Text_IO.New_Line; MyBody := Notification.remainder_of_body; Ada.Text_IO.Put ("Event Body : "); Ada.Text_IO.Put (CORBA.To_Standard_String (CORBA.From_Any (MyBody))); Ada.Text_IO.New_Line; end loop; else Ada.Text_IO.Put_Line ("Nothing to consume!!!"); end if; end; when K_StructuredPullConsumer => declare C : CosNotifyComm.StructuredPullConsumer.Ref; Notification : CosNotification.StructuredEvent; MyDomainName : CORBA.String; MyTypeName : CORBA.String; MyName : CORBA.String; MyBody : CORBA.Any; begin C := CosNotifyComm.StructuredPullConsumer. Helper.To_Ref (Entity); Reference_To_Servant (C, Servant (O)); CosNotifyComm.StructuredPullConsumer.Impl.Try_Pull (StructuredPullConsumer.Impl.Object_Ptr (O), B, Notification); if B then Ada.Text_IO.Put_Line ("Main components of structured event"); MyDomainName := Notification.header.fixed_header.event_type.domain_name; Ada.Text_IO.Put ("My Domain : "); Ada.Text_IO.Put (CORBA.To_Standard_String (MyDomainName)); Ada.Text_IO.New_Line; MyTypeName := Notification.header.fixed_header.event_type.type_name; Ada.Text_IO.Put ("My Type : "); Ada.Text_IO.Put (CORBA.To_Standard_String (MyTypeName)); Ada.Text_IO.New_Line; MyName := Notification.header.fixed_header.event_name; Ada.Text_IO.Put ("My Name : "); Ada.Text_IO.Put (CORBA.To_Standard_String (MyName)); Ada.Text_IO.New_Line; MyBody := Notification.remainder_of_body; Ada.Text_IO.Put ("Event Body : "); Ada.Text_IO.Put (CORBA.To_Standard_String (CORBA.From_Any (MyBody))); Ada.Text_IO.New_Line; else Ada.Text_IO.Put_Line ("Nothing to consume!!!"); end if; end; when K_StructuredPushConsumer => declare C : CosNotifyComm.StructuredPushConsumer.Ref; Notification : CosNotification.StructuredEvent; MyDomainName : CORBA.String; MyTypeName : CORBA.String; MyName : CORBA.String; MyBody : CORBA.Any; begin C := CosNotifyComm.StructuredPushConsumer. Helper.To_Ref (Entity); Reference_To_Servant (C, Servant (O)); CosNotifyComm.StructuredPushConsumer.Impl.Try_Pull (StructuredPushConsumer.Impl.Object_Ptr (O), B, Notification); if B then Ada.Text_IO.Put_Line ("Main components of structured event"); MyDomainName := Notification.header.fixed_header.event_type.domain_name; Ada.Text_IO.Put ("My Domain : "); Ada.Text_IO.Put (CORBA.To_Standard_String (MyDomainName)); Ada.Text_IO.New_Line; MyTypeName := Notification.header.fixed_header.event_type.type_name; Ada.Text_IO.Put ("My Type : "); Ada.Text_IO.Put (CORBA.To_Standard_String (MyTypeName)); Ada.Text_IO.New_Line; MyName := Notification.header.fixed_header.event_name; Ada.Text_IO.Put ("My Name : "); Ada.Text_IO.Put (CORBA.To_Standard_String (MyName)); Ada.Text_IO.New_Line; MyBody := Notification.remainder_of_body; Ada.Text_IO.Put ("Event Body : "); Ada.Text_IO.Put (CORBA.To_Standard_String (CORBA.From_Any (MyBody))); Ada.Text_IO.New_Line; else Ada.Text_IO.Put_Line ("Nothing to consume!!!"); end if; end; when others => null; end case; end Try_Consume_Event; ------------------- -- Create_Entity -- ------------------- procedure Create_Entity (Entity : out CORBA.Object.Ref; Kind : Entity_Kind); procedure Create_Entity (Entity : out CORBA.Object.Ref; Kind : Entity_Kind) is begin case Kind is when K_Channel => declare F : CosNotifyChannelAdmin.EventChannelFactory.Ref; R : CosNotifyChannelAdmin.EventChannel.Ref; Id : CosNotifyChannelAdmin.ChannelID; Initial_Admin : CosNotification.AdminProperties; Initial_QoS : CosNotification.QoSProperties; MyProp : CosNotification.Property; MyPropName : CORBA.String; begin Servant_To_Reference (Servant (EventChannelFactory.Impl.Create), F); MyPropName := To_CORBA_String ("MaxConsumers"); MyProp := (CosNotification.PropertyName (MyPropName), To_Any (CORBA.Long (10))); Append (Initial_Admin, MyProp); MyPropName := To_CORBA_String ("MaxSuppliers"); MyProp := (CosNotification.PropertyName (MyPropName), To_Any (CORBA.Long (10))); Append (Initial_Admin, MyProp); EventChannelFactory.create_channel (F, Initial_QoS, Initial_Admin, Id, R); Entity := CORBA.Object.Ref (R); end; when K_PullConsumer => declare R : CosNotifyComm.PullConsumer.Ref; begin Servant_To_Reference (Servant (CosNotifyComm.PullConsumer.Impl.Create), R); Entity := CORBA.Object.Ref (R); end; when K_PullSupplier => declare R : CosNotifyComm.PullSupplier.Ref; begin Servant_To_Reference (Servant (CosNotifyComm.PullSupplier.Impl.Create), R); Entity := CORBA.Object.Ref (R); end; when K_PushConsumer => declare R : CosNotifyComm.PushConsumer.Ref; begin Servant_To_Reference (Servant (CosNotifyComm.PushConsumer.Impl.Create), R); Entity := CORBA.Object.Ref (R); end; when K_PushSupplier => declare R : CosNotifyComm.PushSupplier.Ref; begin Servant_To_Reference (Servant (CosNotifyComm.PushSupplier.Impl.Create), R); Entity := CORBA.Object.Ref (R); end; when K_SequencePullConsumer => declare R : CosNotifyComm.SequencePullConsumer.Ref; begin Servant_To_Reference (Servant (CosNotifyComm.SequencePullConsumer.Impl.Create), R); Entity := CORBA.Object.Ref (R); end; when K_SequencePullSupplier => declare R : CosNotifyComm.SequencePullSupplier.Ref; begin Servant_To_Reference (Servant (CosNotifyComm.SequencePullSupplier.Impl.Create), R); Entity := CORBA.Object.Ref (R); end; when K_SequencePushConsumer => declare R : CosNotifyComm.SequencePushConsumer.Ref; begin Servant_To_Reference (Servant (CosNotifyComm.SequencePushConsumer.Impl.Create), R); Entity := CORBA.Object.Ref (R); end; when K_SequencePushSupplier => declare R : CosNotifyComm.SequencePushSupplier.Ref; begin Servant_To_Reference (Servant (CosNotifyComm.SequencePushSupplier.Impl.Create), R); Entity := CORBA.Object.Ref (R); end; when K_StructuredPullConsumer => declare R : CosNotifyComm.StructuredPullConsumer.Ref; begin Servant_To_Reference (Servant (CosNotifyComm.StructuredPullConsumer.Impl.Create), R); Entity := CORBA.Object.Ref (R); end; when K_StructuredPullSupplier => declare R : CosNotifyComm.StructuredPullSupplier.Ref; begin Servant_To_Reference (Servant (CosNotifyComm.StructuredPullSupplier.Impl.Create), R); Entity := CORBA.Object.Ref (R); end; when K_StructuredPushConsumer => declare R : CosNotifyComm.StructuredPushConsumer.Ref; begin Servant_To_Reference (Servant (CosNotifyComm.StructuredPushConsumer.Impl.Create), R); Entity := CORBA.Object.Ref (R); end; when K_StructuredPushSupplier => declare R : CosNotifyComm.StructuredPushSupplier.Ref; begin Servant_To_Reference (Servant (CosNotifyComm.StructuredPushSupplier.Impl.Create), R); Entity := CORBA.Object.Ref (R); end; end case; end Create_Entity; ----------------- -- Find_Entity -- ----------------- procedure Find_Entity (Name : String_Access; Entity : out CORBA.Object.Ref; Kind : out Entity_Kind); procedure Find_Entity (Name : String_Access; Entity : out CORBA.Object.Ref; Kind : out Entity_Kind) is Iter : BindingIterator.Ref; B : Binding; BL : BindingList; BI : BindingIterator_Forward.Ref; Id : constant CosNaming.Istring := CosNaming.To_CORBA_String (Name.all); Done : CORBA.Boolean; NC : NameComponent; begin NamingContext.list (Ctx, 0, BL, BI); Iter := BindingIterator.Convert_Forward.To_Ref (BI); loop BindingIterator.next_one (Iter, B, Done); exit when not Done; NC := Get_Element (B.binding_name, 1); if NC.id = Id then for K in Image'Range loop if NC.kind = Image (K) then Kind := K; Entity := NamingContext.resolve (Ctx, B.binding_name); return; end if; end loop; raise Syntax_Error; end if; end loop; raise NamingContext.NotFound; end Find_Entity; ------------------- -- Produce_Event -- ------------------- procedure Produce_Event (Entity : CORBA.Object.Ref; Kind : Entity_Kind; Event : String_Access; Times : Natural); procedure Produce_Event (Entity : CORBA.Object.Ref; Kind : Entity_Kind; Event : String_Access; Times : Natural) is O : CORBA.Impl.Object_Ptr; A : constant CORBA.Any := CORBA.To_Any (To_CORBA_String (Event.all)); begin case Kind is when K_PullSupplier => declare S : CosNotifyComm.PullSupplier.Ref; begin S := CosNotifyComm.PullSupplier.Helper.To_Ref (Entity); Reference_To_Servant (S, Servant (O)); Ada.Text_IO.New_Line; for J in 1 .. Times loop CosNotifyComm.PullSupplier.Impl.Push (CosNotifyComm.PullSupplier.Impl.Object_Ptr (O), A); Ada.Text_IO.Put ("."); end loop; Ada.Text_IO.New_Line; end; when K_PushSupplier => declare S : CosNotifyComm.PushSupplier.Ref; begin S := CosNotifyComm.PushSupplier.Helper.To_Ref (Entity); Reference_To_Servant (S, Servant (O)); Ada.Text_IO.New_Line; for J in 1 .. Times loop CosNotifyComm.PushSupplier.Impl.Push (CosNotifyComm.PushSupplier.Impl.Object_Ptr (O), A); Ada.Text_IO.Put ("."); end loop; Ada.Text_IO.New_Line; end; when K_SequencePullSupplier => declare S : CosNotifyComm.SequencePullSupplier.Ref; MyEventHeader : CosNotification.EventHeader; MyFixedEventHeader : CosNotification.FixedEventHeader; MyOpt_HeaderFields : CosNotification.OptionalHeaderFields; MyEventType : CosNotification.EventType; MyFilterableEventBody : CosNotification.FilterableEventBody; MyRemainder_Of_Body : constant CORBA.Any := A; MyStructuredEvent1 : CosNotification.StructuredEvent; MyStructuredEvent2 : CosNotification.StructuredEvent; MyStructEvent_Seq : CosNotification.EventBatch; begin S := CosNotifyComm.SequencePullSupplier.Helper.To_Ref (Entity); Reference_To_Servant (S, Servant (O)); -- Fill the details of the first structured event and -- append it to the sequence MyEventType.domain_name := To_CORBA_String ("Telecommunications"); MyEventType.type_name := To_CORBA_String ("Communication_Alarm"); MyFixedEventHeader.event_type := MyEventType; MyFixedEventHeader.event_name := To_CORBA_String ("MobileEvent"); MyEventHeader := (MyFixedEventHeader, MyOpt_HeaderFields); MyStructuredEvent1.header := MyEventHeader; MyStructuredEvent1.filterable_data := MyFilterableEventBody; MyStructuredEvent1.remainder_of_body := MyRemainder_Of_Body; Append (MyStructEvent_Seq, MyStructuredEvent1); -- Fill the details of the second structured event and -- append it to the sequence MyEventType.domain_name := To_CORBA_String ("Automobile"); MyEventType.type_name := To_CORBA_String ("Process_Control"); MyFixedEventHeader.event_type := MyEventType; MyFixedEventHeader.event_name := To_CORBA_String ("InventoryEvent"); MyEventHeader := (MyFixedEventHeader, MyOpt_HeaderFields); MyStructuredEvent2.header := MyEventHeader; MyStructuredEvent2.filterable_data := MyFilterableEventBody; MyStructuredEvent2.remainder_of_body := MyRemainder_Of_Body; Append (MyStructEvent_Seq, MyStructuredEvent2); Ada.Text_IO.New_Line; for J in 1 .. Times loop CosNotifyComm.SequencePullSupplier.Impl.Push (CosNotifyComm.SequencePullSupplier.Impl.Object_Ptr (O), MyStructEvent_Seq); Ada.Text_IO.Put ("."); end loop; Ada.Text_IO.New_Line; end; when K_SequencePushSupplier => declare S : CosNotifyComm.SequencePushSupplier.Ref; MyEventHeader : CosNotification.EventHeader; MyFixedEventHeader : CosNotification.FixedEventHeader; MyOpt_HeaderFields : CosNotification.OptionalHeaderFields; MyEventType : CosNotification.EventType; MyFilterableEventBody : CosNotification.FilterableEventBody; MyRemainder_Of_Body : constant CORBA.Any := A; MyStructuredEvent1 : CosNotification.StructuredEvent; MyStructuredEvent2 : CosNotification.StructuredEvent; MyStructEvent_Seq : CosNotification.EventBatch; begin S := CosNotifyComm.SequencePushSupplier.Helper.To_Ref (Entity); Reference_To_Servant (S, Servant (O)); -- Fill the details of the first structured event and -- append it to the sequence MyEventType.domain_name := To_CORBA_String ("Telecommunications"); MyEventType.type_name := To_CORBA_String ("Communication_Alarm"); MyFixedEventHeader.event_type := MyEventType; MyFixedEventHeader.event_name := To_CORBA_String ("MobileEvent"); MyEventHeader := (MyFixedEventHeader, MyOpt_HeaderFields); MyStructuredEvent1.header := MyEventHeader; MyStructuredEvent1.filterable_data := MyFilterableEventBody; MyStructuredEvent1.remainder_of_body := MyRemainder_Of_Body; Append (MyStructEvent_Seq, MyStructuredEvent1); -- Fill the details of the second structured event and -- append it to the sequence MyEventType.domain_name := To_CORBA_String ("Automobile"); MyEventType.type_name := To_CORBA_String ("Process_Control"); MyFixedEventHeader.event_type := MyEventType; MyFixedEventHeader.event_name := To_CORBA_String ("InventoryEvent"); MyEventHeader := (MyFixedEventHeader, MyOpt_HeaderFields); MyStructuredEvent2.header := MyEventHeader; MyStructuredEvent2.filterable_data := MyFilterableEventBody; MyStructuredEvent2.remainder_of_body := MyRemainder_Of_Body; Append (MyStructEvent_Seq, MyStructuredEvent2); Ada.Text_IO.New_Line; for J in 1 .. Times loop CosNotifyComm.SequencePushSupplier.Impl.Push (CosNotifyComm.SequencePushSupplier.Impl.Object_Ptr (O), MyStructEvent_Seq); Ada.Text_IO.Put ("."); end loop; Ada.Text_IO.New_Line; end; when K_StructuredPullSupplier => declare S : CosNotifyComm.StructuredPullSupplier.Ref; MyEventHeader : CosNotification.EventHeader; MyFixedEventHeader : CosNotification.FixedEventHeader; MyOpt_HeaderFields : CosNotification.OptionalHeaderFields; MyEventType : CosNotification.EventType; MyFilterableEventBody : CosNotification.FilterableEventBody; MyRemainder_Of_Body : constant CORBA.Any := A; MyStructuredEvent : CosNotification.StructuredEvent; begin S := CosNotifyComm.StructuredPullSupplier. Helper.To_Ref (Entity); Reference_To_Servant (S, Servant (O)); MyEventType.domain_name := To_CORBA_String ("Avionics"); MyEventType.type_name := To_CORBA_String ("Engine_Alarm"); MyFixedEventHeader.event_type := MyEventType; MyFixedEventHeader.event_name := To_CORBA_String ("TempratureEvent"); MyEventHeader := (MyFixedEventHeader, MyOpt_HeaderFields); MyStructuredEvent.header := MyEventHeader; MyStructuredEvent.filterable_data := MyFilterableEventBody; MyStructuredEvent.remainder_of_body := MyRemainder_Of_Body; Ada.Text_IO.New_Line; for J in 1 .. Times loop CosNotifyComm.StructuredPullSupplier.Impl.Push (CosNotifyComm.StructuredPullSupplier.Impl.Object_Ptr (O), MyStructuredEvent); Ada.Text_IO.Put ("."); end loop; Ada.Text_IO.New_Line; end; when K_StructuredPushSupplier => declare S : CosNotifyComm.StructuredPushSupplier.Ref; MyEventHeader : CosNotification.EventHeader; MyFixedEventHeader : CosNotification.FixedEventHeader; MyOpt_HeaderFields : CosNotification.OptionalHeaderFields; MyEventType : CosNotification.EventType; MyFilterableEventBody : CosNotification.FilterableEventBody; MyRemainder_Of_Body : constant CORBA.Any := A; MyStructuredEvent : CosNotification.StructuredEvent; begin S := CosNotifyComm.StructuredPushSupplier. Helper.To_Ref (Entity); Reference_To_Servant (S, Servant (O)); MyEventType.domain_name := To_CORBA_String ("Telecommunications"); MyEventType.type_name := To_CORBA_String ("Communication_Alarm"); MyFixedEventHeader.event_type := MyEventType; MyFixedEventHeader.event_name := To_CORBA_String ("MobileEvent"); MyEventHeader := (MyFixedEventHeader, MyOpt_HeaderFields); MyStructuredEvent.header := MyEventHeader; MyStructuredEvent.filterable_data := MyFilterableEventBody; MyStructuredEvent.remainder_of_body := MyRemainder_Of_Body; Ada.Text_IO.New_Line; for J in 1 .. Times loop CosNotifyComm.StructuredPushSupplier.Impl.Push (CosNotifyComm.StructuredPushSupplier.Impl.Object_Ptr (O), MyStructuredEvent); Ada.Text_IO.Put ("."); end loop; Ada.Text_IO.New_Line; end; when others => null; end case; end Produce_Event; ------------- -- To_Name -- ------------- function To_Name (S : String_Access; K : Entity_Kind) return Name; function To_Name (S : String_Access; K : Entity_Kind) return Name is Element : NameComponent; Result : Name; begin Element.id := CosNaming.To_CORBA_String (S.all); Element.kind := CosNaming.To_CORBA_String (K'Img); Append (Result, Element); return Result; end To_Name; ------------------ -- Display_Help -- ------------------ procedure Display_Help; procedure Display_Help is begin for C in Help_Messages'Range loop Ada.Text_IO.Put_Line (C'Img & ASCII.HT & ASCII.HT & Help_Messages (C).all); if C = Create then Ada.Text_IO.Put (ASCII.HT & " in"); for E in Entity_Kind'Range loop declare I : constant String := Entity_Kind'Image (E); begin Ada.Text_IO.Put (' ' & I (3 .. I'Last)); end; end loop; Ada.Text_IO.New_Line; end if; end loop; Ada.Text_IO.New_Line; end Display_Help; -------------- -- Exit_All -- -------------- procedure Exit_All; procedure Exit_All is begin CORBA.ORB.Shutdown (False); end Exit_All; --------------- -- Main_Loop -- --------------- procedure Main_Loop; procedure Main_Loop is Argc : Natural; Entity : CORBA.Object.Ref; Channel : CosNotifyChannelAdmin.EventChannel.Ref; Kind : Entity_Kind; begin loop Argc := Count; if Argc > 0 and then Argument (1)(Argument (1)'First) /= '#' then begin case Command'Value (Argument (1).all) is when Help => Display_Help; when Quit => Exit_All; exit; when Create => if Argc /= 3 then raise Syntax_Error; end if; Kind := Entity_Kind'Value ("K_" & Argument (2).all); declare EK : Entity_Kind; begin Find_Entity (Argument (3), Entity, EK); if EK /= Kind then Ada.Text_IO.Put_Line ("entity " & Argument (3).all & " is a " & EK'Img); raise Syntax_Error; end if; exception when NamingContext.NotFound => Create_Entity (Entity, Kind); NamingContext.bind (Ctx, To_Name (Argument (3), Kind), Entity); end; when Connect => if Argc /= 4 or else Argument (3).all /= "to" then raise Syntax_Error; end if; Find_Entity (Argument (4), Entity, Kind); if Kind /= K_Channel then raise Syntax_Error; end if; Channel := EventChannel.Helper.To_Ref (Entity); Find_Entity (Argument (2), Entity, Kind); Connect_Entity (Entity, Kind, Channel); when Consume => if Argc /= 3 or else Argument (2).all /= "in" then raise Syntax_Error; end if; Find_Entity (Argument (3), Entity, Kind); Consume_Event (Entity, Kind); when TryConsume => if Argc /= 3 or else Argument (2).all /= "in" then raise Syntax_Error; end if; Find_Entity (Argument (3), Entity, Kind); Try_Consume_Event (Entity, Kind); when Produce => if (Argc /= 4 and then Argc /= 6) or else Argument (3).all /= "in" then raise Syntax_Error; end if; declare N : Natural := 1; begin if Argc = 6 then if Argument (6).all = "times" then N := Natural'Value (Argument (5).all); else raise Syntax_Error; end if; end if; Find_Entity (Argument (4), Entity, Kind); Produce_Event (Entity, Kind, Argument (2), N); end; when Run => if Argc /= 2 then raise Syntax_Error; end if; Set_Input (Argument (2)); when Sleep => if Argc /= 2 then raise Syntax_Error; end if; declare N : constant Natural := Natural'Value (Argument (2).all); begin delay Duration (N); end; when AutoDisplay => if Argc /= 2 then raise Syntax_Error; end if; declare Item : String (1 .. 255); Last : Natural; C : PushConsumer.Ref; O : CORBA.Impl.Object_Ptr; begin Find_Entity (Argument (2), Entity, Kind); if Kind /= K_PushConsumer then Ada.Text_IO.Put_Line ("Can be called only with a PushConsumer"); else C := PushConsumer.Helper.To_Ref (Entity); Reference_To_Servant (C, Servant (O)); Ensure_Initialization; Enter (Session_Mutex); A_S := O; Create_Task (Auto_Display'Access); Wait (Session_Taken, Session_Mutex); Leave (Session_Mutex); Ada.Text_IO.Get_Line (Item, Last); EndDisplay := True; end if; end; end case; exception when Syntax_Error => Ada.Text_IO.Put_Line ("syntax error"); when E : others => Ada.Text_IO.Put_Line ("raise "& Exception_Name (E)); Ada.Text_IO.Put_Line (Exception_Message (E)); Ada.Text_IO.Put_Line (Exception_Information (E)); end; end if; end loop; end Main_Loop; -- main procedure begins here. begin CORBA.ORB.Initialize ("ORB"); Initiate_Server (True); if Ada.Command_Line.Argument_Count = 0 then -- Test_Notification is used in interactive mode. if Count ("enter naming IOR [otherwise create one]: ") = 0 then Servant_To_Reference (Servant (NamingContext.Impl.Create), Ctx); Ada.Text_IO.Put_Line (CORBA.To_Standard_String (CORBA.Object.Object_To_String (CORBA.Object.Ref (Ctx)))); else declare Obj : CORBA.Object.Ref; begin CORBA.ORB.String_To_Object (CORBA.To_CORBA_String (Argument (1).all), Obj); Ctx := NamingContext.Helper.To_Ref (Obj); end; end if; Display_Help; Main_Loop; else -- Test_Notification is used in batch mode. if Ada.Command_Line.Argument_Count /= 2 then Ada.Text_IO.New_Line; Ada.Text_IO.Put_Line ("usage: test_notification [ ]"); Exit_All; end if; declare Obj : CORBA.Object.Ref; begin CORBA.ORB.String_To_Object (CORBA.To_CORBA_String (Ada.Command_Line.Argument (1)), Obj); Ctx := NamingContext.Helper.To_Ref (Obj); end; Set_Input (+Ada.Command_Line.Argument (2)); Main_Loop; end if; end Test_Notification; polyorb-2.8~20110207.orig/testsuite/corba/cos/notification/testanypush_single.cmd0000644000175000017500000000066011750740340027412 0ustar xavierxavier#Create Channel create channel c #Creation Phase #Create an untyped PushSupplier create pushsupplier pss #Create untyped Consumer create pushconsumer psc create pullconsumer plc #Connection Phase connect pss to c connect psc to c connect plc to c #Production Phase produce "any push event : 1" in pss produce "any push event : 2" in pss #Consumption Phase consume in psc consume in plc tryconsume in psc tryconsume in plc polyorb-2.8~20110207.orig/testsuite/corba/cos/notification/testsequencepull_single.cmd0000644000175000017500000000060311750740340030425 0ustar xavierxavier#Create Channel create channel c #Creation Phase #Create a Sequence PullSupplier create sequencepullsupplier pls #Create untyped Consumer create sequencepushconsumer psc create sequencepullconsumer plc #Connection Phase connect pls to c connect psc to c connect plc to c #Production Phase produce "sequence pull event : 1" in pls #Consumption Phase consume in psc consume in plc ././@LongLink0000000000000000000000000000014700000000000011567 Lustar rootrootpolyorb-2.8~20110207.orig/testsuite/corba/cos/notification/teststructpushsupplier_multipleconsumer.cmdpolyorb-2.8~20110207.orig/testsuite/corba/cos/notification/teststructpushsupplier_multipleconsumer.c0000644000175000017500000000077011750740340033542 0ustar xavierxaviercreate channel c #Creation Phase create structuredpushsupplier psts create pullconsumer psc1 create pushconsumer psc2 create sequencepushconsumer psc3 create structuredpullconsumer psc4 create structuredpushconsumer psc5 #Connection Phase connect psts to c connect psc1 to c connect psc2 to c connect psc3 to c connect psc4 to c connect psc5 to c #Production Phase produce "structured push event" in psts #Consumption Phase consume in psc1 consume in psc2 consume in psc3 consume in psc4 consume in psc5 polyorb-2.8~20110207.orig/testsuite/corba/cos/notification/teststructuredpull_single.cmd0000644000175000017500000000061511750740340031024 0ustar xavierxavier#Create Channel create channel c #Creation Phase #Create a Structured PullSupplier create structuredpullsupplier pls #Create untyped Consumer create structuredpushconsumer psc create structuredpullconsumer plc #Connection Phase connect pls to c connect psc to c connect plc to c #Production Phase produce "structured pull event : 1" in pls #Consumption Phase consume in psc consume in plc polyorb-2.8~20110207.orig/testsuite/corba/cos/notification/local.gpr0000644000175000017500000000073311750740340024602 0ustar xavierxavierwith "polyorb", "polyorb_test_common", "polyorb_cos_notification"; project local is Dir := external ("Test_Dir"); Obj_Dir := PolyORB_Test_Common.Build_Dir & Dir; for Object_Dir use Obj_Dir; for Source_Dirs use (Obj_Dir, PolyORB_Test_Common.Source_Dir & Dir); package Compiler is for Default_Switches ("Ada") use PolyORB_Test_Common.Compiler'Default_Switches ("Ada"); end Compiler; for Main use ("test_notification.adb"); end local; polyorb-2.8~20110207.orig/testsuite/corba/cos/notification/teststructuredpush_multiple.cmd0000644000175000017500000000130511750740340031376 0ustar xavierxavier#Create Channel create channel c #Creation Phase #Create a Structured PushSupplier create structuredpushsupplier pss #Create untyped Consumer create pushconsumer psc create pullconsumer plc #Create Structured Consumer create structuredpushconsumer pstc create structuredpullconsumer pslc #Create Sequence Consumer create sequencepushconsumer psqsc create sequencepullconsumer psqlc #Connection Phase connect pss to c connect psc to c connect plc to c connect pstc to c connect pslc to c connect psqsc to c connect psqlc to c #Production Phase produce "structured push event" in pss #Consumption Phase consume in psc consume in plc consume in pstc consume in pslc consume in psqsc consume in psqlc polyorb-2.8~20110207.orig/testsuite/corba/cos/notification/testanypullsupplier_multipleconsumer.cmd0000644000175000017500000000074411750740340033324 0ustar xavierxaviercreate channel c #Creation Phase create pullsupplier pls create pullconsumer psc1 create pushconsumer psc2 create sequencepushconsumer psc3 create structuredpullconsumer psc4 create structuredpushconsumer psc5 #Connection Phase connect pls to c connect psc1 to c connect psc2 to c connect psc3 to c connect psc4 to c connect psc5 to c #Production Phase produce "any pull event" in pls #Consumption Phase consume in psc1 consume in psc2 consume in psc3 consume in psc4 consume in psc5 polyorb-2.8~20110207.orig/testsuite/corba/cos/notification/teststructuredpull_multiple.cmd0000644000175000017500000000130511750740340031373 0ustar xavierxavier#Create Channel create channel c #Creation Phase #Create a Structured PullSupplier create structuredpullsupplier pls #Create untyped Consumer create pushconsumer psc create pullconsumer plc #Create Structured Consumer create structuredpushconsumer pstc create structuredpullconsumer pslc #Create Sequence Consumer create sequencepushconsumer psqsc create sequencepullconsumer psqlc #Connection Phase connect pls to c connect psc to c connect plc to c connect pstc to c connect pslc to c connect psqsc to c connect psqlc to c #Production Phase produce "structured pull event" in pls #Consumption Phase consume in psc consume in plc consume in pstc consume in pslc consume in psqsc consume in psqlc polyorb-2.8~20110207.orig/testsuite/corba/cos/naming/0000755000175000017500000000000011750740340021556 5ustar xavierxavierpolyorb-2.8~20110207.orig/testsuite/corba/cos/naming/Makefile.local0000644000175000017500000000000011750740340024275 0ustar xavierxavierpolyorb-2.8~20110207.orig/testsuite/corba/cos/naming/test_naming_corba.adb0000644000175000017500000001553311750740340025713 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- T E S T _ N A M I N G _ C O R B A -- -- -- -- B o d y -- -- -- -- Copyright (C) 2002-2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- Testing Naming client. Use the CORBA COS Naming API. -- Designed to interact with others implementation of -- the CORBA Naming Service with Ada.Command_Line; with Ada.Text_IO; with PolyORB.Setup.Client; pragma Warnings (Off, PolyORB.Setup.Client); with CORBA.Object; with CORBA.ORB; with CosNaming.NamingContext; with CosNaming.NamingContextExt; with PolyORB.Utils.Report; procedure Test_Naming_CORBA is use Ada.Command_Line; use Ada.Text_IO; use CORBA.Object; use CosNaming; use CosNaming.NamingContext; use CosNaming.NamingContextExt; use PolyORB.Utils.Report; begin New_Test ("CORBA COS Naming"); -- Initialization CORBA.ORB.Initialize ("ORB"); if Argument_Count < 1 then Put_Line ("usage : test_naming_corba "); return; end if; -- -- Test 1 : bind 1 object, lookup and then destroy -- declare Obj_Name : CosNaming.Name; Rcvd_Ref : CORBA.Object.Ref; pragma Unreferenced (Rcvd_Ref); Root_Context : CosNaming.NamingContext.Ref; begin New_Test ("Bind 1 object, lookup and then destroy"); CORBA.ORB.String_To_Object (CORBA.To_CORBA_String (Ada.Command_Line.Argument (1)), Root_Context); Output ("Retrieve Root_Context", True); Append (Obj_Name, NameComponent'(id => To_CORBA_String ("object1"), kind => To_CORBA_String (""))); bind (Root_Context, Obj_Name, CORBA.Object.Ref (Root_Context)); Output ("Bind Object", True); begin bind (Root_Context, Obj_Name, CORBA.Object.Ref (Root_Context)); Output ("Bind Object (raise Already Bound)", False); exception when CosNaming.NamingContext.AlreadyBound => Output ("Bind Object (raise Already Bound)", True); when others => Output ("Bind Object (raise Already Bound)", False); end; Rcvd_Ref := resolve (Root_Context, Obj_Name); Output ("Resolve Object", True); rebind (Root_Context, Obj_Name, CORBA.Object.Ref (Root_Context)); Output ("Rebind Object", True); unbind (Root_Context, Obj_Name); Output ("Unbind Object", True); begin Rcvd_Ref := resolve (Root_Context, Obj_Name); Output ("Resolve unbound reference raise NotFound", False); exception when CosNaming.NamingContext.NotFound => Output ("Resolve unbound reference raise NotFound", True); end; end; -- -- Test 2 : bind 1 object, lookup and then destroy -- declare Obj_Name : CosNaming.Name; Rcvd_Ref : CORBA.Object.Ref; pragma Unreferenced (Rcvd_Ref); Root_Context : CosNaming.NamingContextExt.Ref; begin New_Test ("NamingContextExt tests"); CORBA.ORB.String_To_Object (CORBA.To_CORBA_String (Ada.Command_Line.Argument (1)), Root_Context); Output ("Retrieve Root_Context", True); Append (Obj_Name, NameComponent'(id => To_CORBA_String ("object1"), kind => To_CORBA_String ("id1"))); Append (Obj_Name, NameComponent'(id => To_CORBA_String ("object2"), kind => To_CORBA_String (""))); Append (Obj_Name, NameComponent'(id => To_CORBA_String ("object3"), kind => To_CORBA_String ("id3"))); declare The_String : constant String := To_String (CosNaming.NamingContextExt.To_String (Root_Context, Obj_Name)); begin Output ("NamingContextExt::To_String", The_String = "object1.id1/object2/object3.id3"); end; declare Obj_Name2 : constant CosNaming.Name := To_Name (Root_Context, CosNaming.NamingContextExt.To_String (Root_Context, Obj_Name)); begin Output ("NamingContextExt::To_Name", Obj_Name2 = Obj_Name); end; declare The_String : constant String := CosNaming.NamingContextExt.To_String (CosNaming.NamingContextExt.To_Url (Root_Context, CosNaming.NamingContextExt.To_CORBA_String (":myhost.mydomain.com"), CosNaming.NamingContextExt.To_CORBA_String ("ppp/ppp"))); begin Output ("NamingContextExt::To_Url", The_String = "%3amyhost.mydomain.com/ppp%2fppp"); end; end; End_Report; exception when E : CORBA.Transient => declare Memb : CORBA.System_Exception_Members; begin CORBA.Get_Members (E, Memb); Put ("received exception transient, minor"); Put (CORBA.Unsigned_Long'Image (Memb.Minor)); Put (", completion status: "); Put_Line (CORBA.Completion_Status'Image (Memb.Completed)); End_Report; end; end Test_Naming_CORBA; polyorb-2.8~20110207.orig/testsuite/corba/cos/naming/local.gpr0000644000175000017500000000067711750740340023374 0ustar xavierxavierwith "polyorb", "polyorb_test_common"; project local is Dir := external ("Test_Dir"); Obj_Dir := PolyORB_Test_Common.Build_Dir & Dir; for Object_Dir use Obj_Dir; for Source_Dirs use (Obj_Dir, PolyORB_Test_Common.Source_Dir & Dir); package Compiler is for Default_Switches ("Ada") use PolyORB_Test_Common.Compiler'Default_Switches ("Ada"); end Compiler; for Main use ("test_naming_corba.adb"); end local; polyorb-2.8~20110207.orig/testsuite/corba/cos/time/0000755000175000017500000000000011750740340021243 5ustar xavierxavierpolyorb-2.8~20110207.orig/testsuite/corba/cos/time/Makefile.local0000644000175000017500000000000011750740340023762 0ustar xavierxavierpolyorb-2.8~20110207.orig/testsuite/corba/cos/time/test_time.adb0000644000175000017500000000774011750740340023720 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- T E S T _ T I M E -- -- -- -- B o d y -- -- -- -- Copyright (C) 2001-2008, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with Ada.Text_IO; with CORBA.Impl; with CORBA.ORB; with PortableServer; with CosTime.TimeService.Impl; with CosTime.TIO; with CosTime.UTO; with TimeBase; with PolyORB.CORBA_P.Server_Tools; with PolyORB.Setup.Thread_Pool_Server; pragma Warnings (Off, PolyORB.Setup.Thread_Pool_Server); with PolyORB.Utils.Report; procedure Test_Time is use Ada.Text_IO; use CosTime; use CosTime.TimeService; use CosTime.TIO; use CosTime.UTO; use TimeBase; use PolyORB.Utils.Report; Ref : CosTime.TimeService.Ref; UTO1, UTO2 : UTO.Ref; TIO1 : TIO.Ref; ------------- -- Display -- ------------- procedure Display (Time : TIO.Ref); procedure Display (Time : TIO.Ref) is IT : constant IntervalT := Get_time_interval (Time); begin Put_Line ("Lower bound:" & TimeT'Image (IT.lower_bound)); Put_Line ("Upper bound:" & TimeT'Image (IT.upper_bound)); end Display; ------------- -- Display -- ------------- procedure Display (Time : UTO.Ref); procedure Display (Time : UTO.Ref) is begin Put_Line ("Time: " & TimeT'Image (Get_time (Time))); Put_Line ("Inaccuracy:" & InaccuracyT'Image (Get_inaccuracy (Time))); Put_Line ("Tdf: " & TdfT'Image (Get_tdf (Time))); end Display; begin New_Test ("CORBA COS Time"); CORBA.ORB.Initialize ("ORB"); PolyORB.CORBA_P.Server_Tools.Initiate_Server (True); declare Obj : constant CORBA.Impl.Object_Ptr := new CosTime.TimeService.Impl.Object; begin PolyORB.CORBA_P.Server_Tools.Initiate_Servant (PortableServer.Servant (Obj), Ref); end; UTO1 := universal_time (Ref); Display (UTO1); Output ("Fetch UTO", True); Put_Line ("Waiting for 3 seconds"); delay 3.0; UTO2 := universal_time (Ref); Display (UTO2); Output ("Fetch UTO", True); Put_Line ("Interval is"); TIO1 := TIO.Convert_Forward.To_Ref (time_to_interval (UTO1, UTO2)); Display (TIO1); End_Report; end Test_Time; polyorb-2.8~20110207.orig/testsuite/corba/cos/time/local.gpr0000644000175000017500000000071311750740340023050 0ustar xavierxavierwith "polyorb", "polyorb_test_common", "polyorb_cos_time"; project local is Dir := external ("Test_Dir"); Obj_Dir := PolyORB_Test_Common.Build_Dir & Dir; for Object_Dir use Obj_Dir; for Source_Dirs use (Obj_Dir, PolyORB_Test_Common.Source_Dir & Dir); package Compiler is for Default_Switches ("Ada") use PolyORB_Test_Common.Compiler'Default_Switches ("Ada"); end Compiler; for Main use ("test_time.adb"); end local; polyorb-2.8~20110207.orig/testsuite/corba/performance/0000755000175000017500000000000011750740340022022 5ustar xavierxavierpolyorb-2.8~20110207.orig/testsuite/corba/performance/java/0000755000175000017500000000000011750740340022743 5ustar xavierxavierpolyorb-2.8~20110207.orig/testsuite/corba/performance/java/benchsServer.java0000644000175000017500000001063011750740340026237 0ustar xavierxavier//--------------------------------------------------------------------------// // // // POLYORB COMPONENTS // // // // b e n c h s S e r v e r // // // // J A V A // // // // Copyright (C) 2009, Free Software Foundation, Inc. // // // // PolyORB is free software; you can redistribute it and/or modify it // // under terms of the GNU General Public License as published by the Free // // Software Foundation; either version 2, or (at your option) any later // // version. PolyORB is distributed in the hope that it will be useful, // // but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- // // TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public // // License for more details. You should have received a copy of the GNU // // General Public License distributed with PolyORB; see file COPYING. If // // not, write to the Free Software Foundation, 51 Franklin Street, Fifth // // Floor, Boston, MA 02111-1301, USA. // // // // // // PolyORB is maintained by AdaCore // // (email: sales@adacore.com) // // // //--------------------------------------------------------------------------// import org.omg.CORBA.*; import org.omg.PortableServer.*; class benchsImpl extends benchsPOA { private ORB orb; private short data = 123; public void setORB (ORB orb_val) { orb = orb_val; } public short noParameter () { return data; } public void azerty () { } public boolean echoBoolean (boolean arg) { return arg; } public short echoShort (short arg) { return arg; } public int echoLong (int arg) { return arg; } public float echoFloat (float arg) { return arg; } public double echoDouble (double arg) { return arg; } public char echoChar (char arg) { return arg; } public char echoWChar (char arg) { return arg; } public String echoString (String arg) { return arg; } public String echoWstring (String arg) { return arg; } public benchsPackage.Color echoColor (benchsPackage.Color arg) { return arg; } public benchsPackage.Color[] echoRainbow (benchsPackage.Color[] arg) { return arg; } public benchsPackage.myUnion echoUnion (benchsPackage.myUnion arg) { return arg; } public benchsPackage.myUnionEnumSwitch echoUnionEnumSwitch (benchsPackage.myUnionEnumSwitch arg) { return arg; } public benchsPackage.simple_struct echoStruct (benchsPackage.simple_struct arg) { return arg; } public benchsPackage.array_struct echoArrayStruct (benchsPackage.array_struct arg) { return arg; } public int[][] echoSixteenKb (int[][] arg) { return arg; } public benchsPackage.nested_struct echoNestedStruct (benchsPackage.nested_struct arg) { return arg; } public short[] echoUsequence (short[] arg) { return arg; } public void StopServer () { orb.shutdown(false); } } public class benchsServer { public static void main (String args[]) { try { ORB orb = ORB.init (args, null); POA poa = POAHelper.narrow (orb.resolve_initial_references ("RootPOA")); poa.the_POAManager ().activate (); benchsImpl impl = new benchsImpl (); impl.setORB (orb); benchs ref = benchsHelper.narrow (poa.servant_to_reference (impl)); System.out.println (orb.object_to_string (ref)); System.out.println ("benchServer ready and waiting..."); orb.run (); } catch (Exception e) { System.err.println ("ERROR: " + e); e.printStackTrace (System.out); } System.out.println ("benchServer Exiting..."); } } polyorb-2.8~20110207.orig/testsuite/corba/performance/java/Makefile0000644000175000017500000000055411750740340024407 0ustar xavierxavier all: idlj -fall benchs.idl javac benchsServer.java benchsPackage/*.java # orbd -ORBInitialPort 1050 -ORBInitialHost localhost java benchsServer -ORBInitialPort 1050 -ORBInitialHost localhost clean: rm -rf *.class \ benchsHelper.java \ benchs.java \ benchsPOA.java \ benchsHolder.java \ benchsOperations.java \ _benchsStub.java \ benchsPackage polyorb-2.8~20110207.orig/testsuite/corba/performance/java/benchs.idl0000644000175000017500000001101511750740340024675 0ustar xavierxavier//--------------------------------------------------------------------------// // // // POLYORB COMPONENTS // // // // B E N C H S // // // // I D L // // // // Copyright (C) 2009, Free Software Foundation, Inc. // // // // PolyORB is free software; you can redistribute it and/or modify it // // under terms of the GNU General Public License as published by the Free // // Software Foundation; either version 2, or (at your option) any later // // version. PolyORB is distributed in the hope that it will be useful, // // but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- // // TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public // // License for more details. You should have received a copy of the GNU // // General Public License distributed with PolyORB; see file COPYING. If // // not, write to the Free Software Foundation, 51 Franklin Street, Fifth // // Floor, Boston, MA 02111-1301, USA. // // // // As a special exception, if other files instantiate generics from this // // unit, or you link this unit with other files to produce an executable, // // this unit does not by itself cause the resulting executable to be // // covered by the GNU General Public License. This exception does not // // however invalidate any other reasons why the executable file might be // // covered by the GNU Public License. // // // // PolyORB is maintained by AdaCore // // (email: sales@adacore.com) // // // //--------------------------------------------------------------------------// // This IDL file is used to benchmarks CORBA application. Each // function is expected to return a value equal to its parameter. It // allows one to evaluate the impact of parameter // marshalling/unmarshalling on ORB performance. interface benchs { // fonction without parameter short noParameter (); // procedure with variable name length void azerty (); // fonction with one parameter // Simple types boolean echoBoolean(in boolean arg) ; short echoShort(in short arg) ; long echoLong(in long arg) ; float echoFloat(in float arg) ; double echoDouble(in double arg) ; char echoChar(in char arg) ; wchar echoWChar(in wchar arg) ; string echoString (in string arg) ; wstring echoWstring (in wstring arg) ; // Enum enum Color { Red, Green, Blue }; Color echoColor (in Color arg); // Array of enum typedef Color Rainbow[7]; Rainbow echoRainbow (in Rainbow arg); // Unions union myUnion switch (long) { case 1: long Counter; case 2: boolean Flag; case 3: Color Hue; default: long Unknown; }; myUnion echoUnion (in myUnion arg); union myUnionEnumSwitch switch (Color) { case Red: long foo; case Green: short bar; case Blue: string baz; }; myUnionEnumSwitch echoUnionEnumSwitch (in myUnionEnumSwitch arg); // Structs struct simple_struct { long a; string s; }; simple_struct echoStruct (in simple_struct arg); struct array_struct { long a[10]; unsigned short b; }; array_struct echoArrayStruct (in array_struct arg); // Big arrays // ---------- typedef long sixteenKb[64][64]; sixteenKb echoSixteenKb (in sixteenKb arg); // struct composite_struct { // fixed<12,3> fixedMember; // sequence > seqseqMember; // long double matrixMember[3][4]; // }; struct nested_struct { simple_struct ns; }; nested_struct echoNestedStruct (in nested_struct arg); // Sequences typedef sequence U_sequence; U_sequence echoUsequence (in U_sequence arg); // stop the server void StopServer (); }; polyorb-2.8~20110207.orig/testsuite/corba/performance/benchs-impl.adb0000644000175000017500000002032111750740340024671 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- B E N C H S . I M P L -- -- -- -- B o d y -- -- -- -- Copyright (C) 2007-2008, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with CORBA.ORB; with Benchs.Skel; pragma Warnings (Off, benchs.Skel); package body benchs.Impl is function NoParameter (Self : access Object) return CORBA.Short is begin return Self.Data; end NoParameter; procedure Azerty (Self : access Object) is pragma Unreferenced (Self); begin null; end Azerty; procedure AzertyAzerty (Self : access Object) is pragma Unreferenced (Self); begin null; end AzertyAzerty; procedure AzertyAzertyAzerty (Self : access Object) is pragma Unreferenced (Self); begin null; end AzertyAzertyAzerty; procedure AzertyAzertyAzertyAzerty (Self : access Object) is pragma Unreferenced (Self); begin null; end AzertyAzertyAzertyAzerty; procedure AzertyAzertyAzertyAzertyAzerty (Self : access Object) is pragma Unreferenced (Self); begin null; end AzertyAzertyAzertyAzertyAzerty; procedure AzertyAzertyAzertyAzertyAzertyAzerty (Self : access Object) is pragma Unreferenced (Self); begin null; end AzertyAzertyAzertyAzertyAzertyAzerty; procedure AzertyAzertyAzertyAzertyAzertyAzertyAzerty (Self : access Object) is pragma Unreferenced (Self); begin null; end AzertyAzertyAzertyAzertyAzertyAzertyAzerty; procedure AzertyAzertyAzertyAzertyAzertyAzertyAzertyAzerty (Self : access Object) is pragma Unreferenced (Self); begin null; end AzertyAzertyAzertyAzertyAzertyAzertyAzertyAzerty; procedure AzertyAzertyAzertyAzertyAzertyAzertyAzertyAzertyAzerty (Self : access Object) is pragma Unreferenced (Self); begin null; end AzertyAzertyAzertyAzertyAzertyAzertyAzertyAzertyAzerty; procedure AzertyAzertyAzertyAzertyAzertyAzertyAzertyAzertyAzertyAzerty (Self : access Object) is pragma Unreferenced (Self); begin null; end AzertyAzertyAzertyAzertyAzertyAzertyAzertyAzertyAzertyAzerty; function echoBoolean (Self : access Object; arg : CORBA.Boolean) return CORBA.Boolean is pragma Unreferenced (Self); begin return arg; end echoBoolean; function echoShort (Self : access Object; arg : CORBA.Short) return CORBA.Short is pragma Unreferenced (Self); begin return arg; end echoShort; function echoLong (Self : access Object; arg : CORBA.Long) return CORBA.Long is pragma Unreferenced (Self); begin return arg; end echoLong; function echoUShort (Self : access Object; arg : CORBA.Unsigned_Short) return CORBA.Unsigned_Short is pragma Unreferenced (Self); begin return arg; end echoUShort; function echoULong (Self : access Object; arg : CORBA.Unsigned_Long) return CORBA.Unsigned_Long is pragma Unreferenced (Self); begin return arg; end echoULong; function echoULLong (Self : access Object; arg : CORBA.Unsigned_Long_Long) return CORBA.Unsigned_Long_Long is pragma Unreferenced (Self); begin return arg; end echoULLong; function echoFloat (Self : access Object; arg : CORBA.Float) return CORBA.Float is pragma Unreferenced (Self); begin return arg; end echoFloat; function echoDouble (Self : access Object; arg : CORBA.Double) return CORBA.Double is pragma Unreferenced (Self); begin return arg; end echoDouble; function echoChar (Self : access Object; arg : CORBA.Char) return CORBA.Char is pragma Unreferenced (Self); begin return arg; end echoChar; function echoWChar (Self : access Object; arg : CORBA.Wchar) return CORBA.Wchar is pragma Unreferenced (Self); begin return arg; end echoWChar; function echoOctet (Self : access Object; arg : CORBA.Octet) return CORBA.Octet is pragma Unreferenced (Self); begin return arg; end echoOctet; function echoString (Self : access Object; arg : CORBA.String) return CORBA.String is pragma Unreferenced (Self); begin return arg; end echoString; function echoWString (Self : access Object; arg : CORBA.Wide_String) return CORBA.Wide_String is pragma Unreferenced (Self); begin return arg; end echoWString; function echoColor (Self : access Object; arg : Color) return Color is pragma Unreferenced (Self); begin return arg; end echoColor; function echoRainbow (Self : access Object; arg : Rainbow) return Rainbow is pragma Unreferenced (Self); begin return arg; end echoRainbow; function echoStruct (Self : access Object; arg : simple_struct) return simple_struct is pragma Unreferenced (Self); begin return arg; end echoStruct; function echoArrayStruct (Self : access Object; arg : array_struct) return array_struct is pragma Unreferenced (Self); begin return arg; end echoArrayStruct; function echoSixteenKb (Self : access Object; arg : sixteenKb) return sixteenKb is pragma Unreferenced (Self); begin return arg; end echoSixteenKb; function echoNestedStruct (Self : access Object; arg : nested_struct) return nested_struct is pragma Unreferenced (Self); begin return arg; end echoNestedStruct; function echoUnion (Self : access Object; arg : myUnion) return myUnion is pragma Unreferenced (Self); begin return arg; end echoUnion; function echoUnionEnumSwitch (Self : access Object; arg : myUnionEnumSwitch) return myUnionEnumSwitch is pragma Unreferenced (Self); begin return arg; end echoUnionEnumSwitch; function echoUsequence (Self : access Object; arg : U_sequence) return U_sequence is pragma Unreferenced (Self); begin return arg; end echoUsequence; procedure StopServer (Self : access Object) is pragma Unreferenced (Self); begin CORBA.ORB.Shutdown (Wait_For_Completion => False); end StopServer; end Benchs.Impl; polyorb-2.8~20110207.orig/testsuite/corba/performance/README0000644000175000017500000000333211750740340022703 0ustar xavierxavierREADME for PolyORB benchmarking =============================== This file details the organization of the benchmark suite for the PolyORB/CORBA personality. I. Compiling tests ------------------ 1/ Editing Makefile to set compilation options and IDL-to-Ada compiler name and flags. For iac, it is recommended to use "-hc -rs" for maximum performance. Note: it is assumed PolyORB tools (idlac, iac, polyorb-config) and gnatmake are in the PATH. 2/ Edit bench_utils, if required, to configure benchmark timeouts and threshold (see bench_utils.ads for details). 2/ Compile II. Running tests ----------------- 1/ Run server_no_tasking and then client with server's IOR 2/ After the test completes, a set of .data files store the performance measurements for each test. See bench_utils.ads for its format. 3/ A GNUPlot script is available and allow for turning the performance measures into a graph, run it with "gnuplot print_data.gnuplot". If a performance decrease is measured, the corresponding test is flagged as failed. This can be reported by e.g. PolyORB test driver to detect any performance regression For more details on types tested, see benchs.idl III. Directory structure ------------------------ benchs.idl : IDL benchs-impl.ad? : implementation files for benchs.idl methods bench_utils.ad? : utility functions to do some benchmarking on functions client.adb : client of benchs.idl Makefile : compilation of tests polyorb.conf : parameter tuning of the application print_data.gnuplot: GNUPlot script to display value server_common.ad? : common routines to set up a benchs server server_no_tasking.adb : server using the no tasking profile of PolyORB server_thread_pool.adb: server using a threadpool polyorb-2.8~20110207.orig/testsuite/corba/performance/Makefile.local0000644000175000017500000000013611750740340024553 0ustar xavierxavier${current_dir}benchs.idl-stamp: idlac_flags := ${test_target}: ${current_dir}benchs.idl-stamp polyorb-2.8~20110207.orig/testsuite/corba/performance/benchs-impl.ads0000644000175000017500000001241011750740340024712 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- B E N C H S . I M P L -- -- -- -- S p e c -- -- -- -- Copyright (C) 2007-2008, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with CORBA; with PortableServer; package Benchs.Impl is type Object is new PortableServer.Servant_Base with private; function NoParameter (Self : access Object) return CORBA.Short; procedure Azerty (Self : access Object); procedure Azertyazerty (Self : access Object); procedure Azertyazertyazerty (Self : access Object); procedure Azertyazertyazertyazerty (Self : access Object); procedure Azertyazertyazertyazertyazerty (Self : access Object); procedure Azertyazertyazertyazertyazertyazerty (Self : access Object); procedure Azertyazertyazertyazertyazertyazertyazerty (Self : access Object); procedure Azertyazertyazertyazertyazertyazertyazertyazerty (Self : access Object); procedure Azertyazertyazertyazertyazertyazertyazertyazertyazerty (Self : access Object); procedure Azertyazertyazertyazertyazertyazertyazertyazertyazertyazerty (Self : access Object); function echoBoolean (Self : access Object; arg : CORBA.Boolean) return CORBA.Boolean; function echoShort (Self : access Object; arg : CORBA.Short) return CORBA.Short; function echoLong (Self : access Object; arg : CORBA.Long) return CORBA.Long; function echoUShort (Self : access Object; arg : CORBA.Unsigned_Short) return CORBA.Unsigned_Short; function echoULong (Self : access Object; arg : CORBA.Unsigned_Long) return CORBA.Unsigned_Long; function echoULLong (Self : access Object; arg : CORBA.Unsigned_Long_Long) return CORBA.Unsigned_Long_Long; function echoFloat (Self : access Object; arg : CORBA.Float) return CORBA.Float; function echoDouble (Self : access Object; arg : CORBA.Double) return CORBA.Double; function echoChar (Self : access Object; arg : CORBA.Char) return CORBA.Char; function echoWChar (Self : access Object; arg : CORBA.Wchar) return CORBA.Wchar; function echoOctet (Self : access Object; arg : CORBA.Octet) return CORBA.Octet; function echoString (Self : access Object; arg : CORBA.String) return CORBA.String; function echoWString (Self : access Object; arg : CORBA.Wide_String) return CORBA.Wide_String; function echoColor (Self : access Object; arg : Color) return Color; function echoRainbow (Self : access Object; arg : Rainbow) return Rainbow; function echoUnion (Self : access Object; arg : myUnion) return myUnion; function echoUnionEnumSwitch (Self : access Object; arg : myUnionEnumSwitch) return myUnionEnumSwitch; function echoStruct (Self : access Object; arg : simple_struct) return simple_struct; function echoArrayStruct (Self : access Object; arg : array_struct) return array_struct; function echoSixteenKb (Self : access Object; arg : sixteenKb) return sixteenKb; function echoNestedStruct (Self : access Object; arg : nested_struct) return nested_struct; function echoUsequence (Self : access Object; arg : U_sequence) return U_sequence; procedure StopServer (Self : access Object); private type Object is new PortableServer.Servant_Base with record Data : CORBA.Short := 123; end record; end Benchs.Impl; polyorb-2.8~20110207.orig/testsuite/corba/performance/server_no_tasking.adb0000644000175000017500000000432711750740340026222 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- S E R V E R _ N O _ T A S K I N G -- -- -- -- B o d y -- -- -- -- Copyright (C) 2007, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with Server_Common; with PolyORB.Setup.No_Tasking_Server; pragma Warnings (Off, PolyORB.Setup.No_Tasking_Server); procedure Server_No_Tasking is begin Server_Common.Launch_Server; end Server_No_Tasking; polyorb-2.8~20110207.orig/testsuite/corba/performance/bench_utils.ads0000644000175000017500000000660311750740340025017 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- B E N C H _ U T I L S -- -- -- -- S p e c -- -- -- -- Copyright (C) 2007, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ package Bench_Utils is generic Test_Name : String; with procedure Test; procedure Run_Test; -- Run_Test will run Test for a limited amount of time, set by -- Test_Duration. Run_Test will run as many time as possible Test. -- -- To analyse the ouput and allow for regression tracking, -- Run_Test will store all results in a file, named -- "Test_Name.data". -- -- Its format is as follows, suitable for processing by GNUPlot: -- -- Date of the run Time to execute Test Number of time Test was run -- 07/09/10:12h55 8.22551E-01 1 -- -- The Threshold value is a percentage value that controls the -- allowed difference between the current performance and the -- latest one. -- -- If there is an overrun, the test is marked as failed, -- the output string is as follows: -- -- Performance decreased, old value was 224....................: FAILED Test_Duration : Integer := 10; -- Test_Duration is, in second, the maximum amount of time allowed -- to run test. Run_Test will stop when the execution of N -- occurences of Test overruns this value. Threshold : Float := 0.00; -- Controls the allowed performance difference between the current -- run, and the previous one. The test fails if -- -- Old_Value - New_Value > Threshold * New_Value end Bench_Utils; polyorb-2.8~20110207.orig/testsuite/corba/performance/server_common.adb0000644000175000017500000000551411750740340025355 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- S E R V E R _ C O M M O N -- -- -- -- B o d y -- -- -- -- Copyright (C) 2007, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with Ada.Text_IO; with PolyORB.CORBA_P.Server_Tools; with CORBA.Impl; with CORBA.Object; with CORBA.ORB; with PortableServer; with Benchs.Impl; package body Server_Common is procedure Launch_Server is use PolyORB.CORBA_P.Server_Tools; Ref : CORBA.Object.Ref; begin Ada.Text_IO.Put_Line ("Server starting."); CORBA.ORB.Initialize ("ORB"); declare Obj : constant CORBA.Impl.Object_Ptr := new benchs.Impl.Object; begin Initiate_Servant (PortableServer.Servant (Obj), Ref); end; -- Print IOR so that we can give it to a client Ada.Text_IO.Put_Line ("'" & CORBA.To_Standard_String (CORBA.Object.Object_To_String (Ref)) & "'"); -- Launch the server Initiate_Server; end Launch_Server; end Server_Common; polyorb-2.8~20110207.orig/testsuite/corba/performance/benchs.idl0000644000175000017500000000377211750740340023767 0ustar xavierxavier// This IDL file is used to benchmarks CORBA application. Each // function is expected to return a value equal to its parameter. It // allows one to evaluate the impact of parameter // marshalling/unmarshalling on ORB performance. interface benchs { // fonction without parameter short noParameter (); // procedure with variable name length void azerty (); // fonction with one parameter // Simple types boolean echoBoolean(in boolean arg) ; short echoShort(in short arg) ; long echoLong(in long arg) ; float echoFloat(in float arg) ; double echoDouble(in double arg) ; char echoChar(in char arg) ; wchar echoWChar(in wchar arg) ; string echoString (in string arg) ; // Enum enum Color { Red, Green, Blue }; Color echoColor (in Color arg); // Array of enum typedef Color Rainbow[7]; Rainbow echoRainbow (in Rainbow arg); // Unions union myUnion switch (long) { case 1: long Counter; case 2: boolean Flag; case 3: Color Hue; default: long Unknown; }; myUnion echoUnion (in myUnion arg); union myUnionEnumSwitch switch (Color) { case Red: long foo; case Green: short bar; case Blue: string baz; }; myUnionEnumSwitch echoUnionEnumSwitch (in myUnionEnumSwitch arg); // Structs struct simple_struct { long a; string s; }; simple_struct echoStruct (in simple_struct arg); struct array_struct { long a[10]; unsigned short b; }; array_struct echoArrayStruct (in array_struct arg); // Big arrays // ---------- typedef long sixteenKb[64][64]; sixteenKb echoSixteenKb (in sixteenKb arg); struct composite_struct { fixed<12,3> fixedMember; sequence > seqseqMember; long double matrixMember[3][4]; }; struct nested_struct { simple_struct ns; }; nested_struct echoNestedStruct (in nested_struct arg); // Sequences typedef sequence U_sequence; U_sequence echoUsequence (in U_sequence arg); // stop the server void StopServer (); }; polyorb-2.8~20110207.orig/testsuite/corba/performance/server_thread_pool.adb0000644000175000017500000000433311750740340026363 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- S E R V E R _ T H R E A D _ P O O L -- -- -- -- B o d y -- -- -- -- Copyright (C) 2007, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with Server_Common; with PolyORB.Setup.Thread_Pool_Server; pragma Warnings (Off, PolyORB.Setup.Thread_Pool_Server); procedure Server_Thread_Pool is begin Server_Common.Launch_Server; end Server_Thread_Pool; polyorb-2.8~20110207.orig/testsuite/corba/performance/print_data.gnuplot0000644000175000017500000000203511750740340025561 0ustar xavierxavierset terminal png small set output 'data.png' set title 'Benchs PolyORB/CORBA' set key outside top set key box set autoscale set xlabel 'date' set ylabel 'Number of requests' plot 'Azerty.data' using 3 title 'azerty' with lines, \ 'echoBoolean.data' using 3 title 'boolean' with lines, \ 'echoChar.data' using 3 title 'char' with lines, \ 'echoColor.data' using 3 title 'color' with lines, \ 'echoDouble.data' using 3 title 'double' with lines, \ 'echoFloat.data' using 3 title 'float' with lines, \ 'echoLong.data' using 3 title 'long' with lines, \ 'echoRainbow.data' using 3 title 'rainbow' with lines, \ 'echoShort.data' using 3 title 'short' with lines, \ 'echoSixteenKb.data' using 3 title '16kB' with lines, \ 'echoString.data' using 3 title 'string' with lines, \ 'echoStruct.data' using 3 title 'struct' with lines, \ 'echoUnion.data' using 3 title 'union' with lines, \ 'echoUsequence.data' using 3 title 'usequence' with lines, \ 'echoWchar.data' using 3 title 'wchar' with lines, \ 'NoParameter.data' using 3 title 'noparameter' with lines polyorb-2.8~20110207.orig/testsuite/corba/performance/bench_utils.adb0000644000175000017500000001324111750740340024772 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- B E N C H _ U T I L S -- -- -- -- B o d y -- -- -- -- Copyright (C) 2007-2009, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with Ada.Calendar; with GNAT.IO_Aux; with Ada.Exceptions; with Ada.Real_Time; with Ada.Text_IO; with PolyORB.Utils.Report; with GNAT.Calendar.Time_IO; with GNAT.Regpat; package body Bench_Utils is use Ada.Text_IO; use Ada.Real_Time; use PolyORB.Utils.Report; -------------- -- Run_Test -- -------------- procedure Run_Test is Test_Filename : constant String := Test_Name & ".data"; D1, D2, D3 : Time; D : Duration; Fd : File_Type; Request_Sent_In_Previous_Test : Natural := 0; Line : String (1 .. 1_024); Last : Integer; begin New_Test ("CORBA : " & Test_Name & " function"); if GNAT.IO_Aux.File_Exists (Test_Filename) then Open (Fd, In_File, Test_Filename); while not End_Of_File (Fd) loop Get_Line (Fd, Line, Last); -- Fetch value from previous test run declare use GNAT.Regpat; Regexp : constant String := "([[:ascii:]]+) ([[:ascii:]]+) ([[:ascii:]]+)"; Matches : Match_Array (0 .. 3); begin Match (Compile (Regexp), Line (Line'First .. Last), Matches); Request_Sent_In_Previous_Test := Natural'Value (Line (Matches (3).First .. Matches (3).Last)); end; end loop; -- We completed read from File, we now reopen it in Append -- mode to addd result from the next run. Close (Fd); Open (Fd, Append_File, Test_Filename); else -- Create new data file Create (Fd, Out_File, Test_Filename); Request_Sent_In_Previous_Test := 0; end if; declare Cpt : Natural := 0; X : Integer := 0; begin -- Run test during at least Test_Duration begin D1 := Clock; while True loop Test; Cpt := Cpt + 1; D2 := Clock; X := Integer (To_Duration (D2 - D1)); if (((Cpt + 1) * X) / Cpt) >= Test_Duration then exit; end if; end loop; exception when E : others => Put_Line ("Got exception: " & Ada.Exceptions.Exception_Information (E)); Output (Test_Name, False); Close (Fd); return; end; D2 := Clock; D3 := Clock; D := To_Duration (D2 - (D3 - D2) - D1); -- The test was successful Output (Test_Name, True); -- Process test benchs -- 1/ Print the execution time average and the number of -- executed requests Put_Line (Fd, GNAT.Calendar.Time_IO.Image (Ada.Calendar.Clock, "%y/%m/%d:%Hh%M") & " " & Float'Image (Float (D) / Float (Cpt)) & " " & Natural'Image (Cpt)); Put_Line (GNAT.Calendar.Time_IO.Image (Ada.Calendar.Clock, "%y/%m/%d:%Hh%M") & " " & Float'Image (Float (D) / Float (Cpt)) & " " & Natural'Image (Cpt)); Close (Fd); -- 2/ Test performance against previous value if Float (Request_Sent_In_Previous_Test) - Float (Cpt) > Threshold * Float (Cpt) then Output ("Performance decreased, old value was" & Natural'Image (Request_Sent_In_Previous_Test), False); end if; end; end Run_Test; end Bench_Utils; polyorb-2.8~20110207.orig/testsuite/corba/performance/local.gpr0000644000175000017500000000071511750740340023631 0ustar xavierxavierwith "polyorb", "polyorb_test_common"; project local is Dir := external ("Test_Dir"); Obj_Dir := PolyORB_Test_Common.Build_Dir & Dir; for Object_Dir use Obj_Dir; for Source_Dirs use (Obj_Dir, PolyORB_Test_Common.Source_Dir & Dir); package Compiler is for Default_Switches ("Ada") use PolyORB_Test_Common.Compiler'Default_Switches ("Ada"); end Compiler; for Main use ("server_no_tasking.adb", "client.adb"); end local; polyorb-2.8~20110207.orig/testsuite/corba/performance/server_common.ads0000644000175000017500000000412111750740340025367 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- S E R V E R _ C O M M O N -- -- -- -- S p e c -- -- -- -- Copyright (C) 2007, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ package Server_Common is procedure Launch_Server; end Server_Common; polyorb-2.8~20110207.orig/testsuite/corba/performance/client.adb0000644000175000017500000001742511750740340023761 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- C L I E N T -- -- -- -- B o d y -- -- -- -- Copyright (C) 2007, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with Ada.Command_Line; with Ada.Text_IO; with CORBA.ORB; with benchs; with Bench_Utils; with PolyORB.Setup.Client; pragma Warnings (Off, PolyORB.Setup.Client); with PolyORB.Utils.Report; procedure Client is use Ada.Command_Line; use Ada.Text_IO; use benchs; use Bench_Utils; use CORBA; use PolyORB.Utils.Report; B : SixteenKb; X : U_sequence := U_sequence (IDL_SEQUENCE_short.Null_Sequence); Ref : benchs.Ref; --------------------- -- Run_NoParameter -- --------------------- procedure Run_NoParameter is R : CORBA.Short; pragma Unreferenced (R); begin R := benchs.NoParameter (Ref); end Run_NoParameter; procedure Run_Azerty is begin benchs.Azerty (Ref); end Run_Azerty; procedure Run_echoBoolean is R : Boolean; pragma Unreferenced (R); begin R := benchs.echoBoolean (Ref, True); end Run_echoBoolean; procedure Run_echoShort is R : CORBA.Short; pragma Unreferenced (R); begin R := benchs.echoShort (Ref, 123); end Run_echoShort; procedure Run_echoLong is R : CORBA.Long; pragma Unreferenced (R); begin R := benchs.echoLong (Ref, 123); end Run_echoLong; procedure Run_echoFloat is R : CORBA.Float; pragma Unreferenced (R); begin R := benchs.echoFloat (Ref, 12.3); end Run_echoFloat; procedure Run_echoDouble is R : CORBA.Double; pragma Unreferenced (R); begin R := benchs.echoDouble (Ref, 12.3); end Run_echoDouble; procedure Run_echoChar is R : CORBA.Char; pragma Unreferenced (R); begin R := benchs.echoChar (Ref, 'A'); end Run_echoChar; procedure Run_echoWchar is R : CORBA.Wchar; pragma Unreferenced (R); begin R := benchs.echoWchar (Ref, 'A'); end Run_echoWchar; procedure Run_echoString is R : CORBA.String; pragma Unreferenced (R); begin R := benchs.echoString (Ref, CORBA.To_CORBA_String ("Hello World !")); end Run_echoString; procedure Run_echoColor is R : benchs.Color; pragma Unreferenced (R); begin R := benchs.echoColor (Ref, benchs.Blue); end Run_echoColor; procedure Run_echoRainbow is R, X : benchs.Rainbow; pragma Unreferenced (R); begin for J in X'Range loop X (J) := benchs.Color'Val (J mod (benchs.Color'Pos (benchs.Color'Last) + 1)); end loop; R := benchs.echoRainbow (Ref, X); end Run_echoRainbow; procedure Run_echoUnion is Test_Unions : constant array (Integer range <>) of benchs.myUnion := ((Switch => 0, Unknown => 987), (Switch => 1, Counter => 1212), (Switch => 2, Flag => True), (Switch => 3, Hue => benchs.Green)); Pass : Boolean := True; begin for J in Test_Unions'Range loop Pass := (benchs.echoUnion (Ref, Test_Unions (J)) = Test_Unions (J)) and Pass; end loop; end Run_echoUnion; procedure Run_echoStruct is Test_Struct : constant benchs.simple_struct := (123, CORBA.To_CORBA_String ("Hello world!")); R : benchs.simple_struct; pragma Unreferenced (R); begin R := benchs.echoStruct (Ref, Test_Struct); end Run_echoStruct; procedure Run_EchoSixteenKb is begin B := Benchs.EchoSixteenKb (Ref, B); end Run_EchoSixteenKb; procedure Run_EchoUsequence is begin X := Benchs.EchoUsequence (Ref, X); end Run_EchoUsequence; procedure Test_NoParameter is new Run_Test ("NoParameter", Run_NoParameter); procedure Test_Azerty is new Run_Test ("Azerty", Run_Azerty); procedure Test_Boolean is new Run_Test ("echoBoolean", Run_EchoBoolean); procedure Test_Short is new Run_Test ("echoShort", Run_EchoShort); procedure Test_Long is new Run_Test ("echoLong", Run_EchoLong); procedure Test_Float is new Run_Test ("echoFloat", Run_EchoFloat); procedure Test_Double is new Run_Test ("echoDouble", Run_EchoDouble); procedure Test_Char is new Run_Test ("echoChar", Run_EchoChar); procedure Test_Wchar is new Run_Test ("echoWchar", Run_EchoWchar); procedure Test_String is new Run_Test ("echoString", Run_EchoString); procedure Test_Color is new Run_Test ("echoColor", Run_EchoColor); procedure Test_Rainbow is new Run_Test ("echoRainbow", Run_EchoRainbow); procedure Test_Union is new Run_Test ("echoUnion", Run_EchoUnion); procedure Test_Struct is new Run_Test ("echoStruct", Run_EchoStruct); procedure Test_SixteenKb is new Run_Test ("echoSixteenKb", Run_EchoSixteenKb); procedure Test_Usequence is new Run_Test ("echoUsequence", Run_EchoUsequence); IOR : CORBA.String; begin if Argument_Count > 2 then Ada.Text_IO.Put_Line ("usage : client [bench_duration]"); return; end if; IOR := To_CORBA_String (Argument (1)); if Argument_Count = 2 then -- Overwrite default test duration Test_Duration := Integer'Value (Argument (2)); end if; CORBA.ORB.Initialize ("ORB"); CORBA.ORB.String_To_Object (IOR, Ref); if benchs.Is_Nil (Ref) then Ada.Text_IO.Put_Line ("main : cannot invoke on a nil reference"); return; end if; -- Precompute a few constants for the tests for I in B'Range (1) loop for J in B'Range (2) loop B (I, J) := Long ((I + 1) * (J + 2)); end loop; end loop; for J in 1 .. 2 ** 14 loop X := X & CORBA.Short (J); end loop; -- Launch all tests Test_NoParameter; Test_Azerty; Test_Boolean; Test_Short; Test_Long; Test_Float; Test_Double; Test_Char; Test_Wchar; Test_String; Test_Struct; Test_Color; Test_Rainbow; Test_Union; Test_SixteenKb; Test_Usequence; -- Stop the server Stopserver (Ref); End_Report; end Client; polyorb-2.8~20110207.orig/testsuite/corba/shutdown/0000755000175000017500000000000011750740340021374 5ustar xavierxavierpolyorb-2.8~20110207.orig/testsuite/corba/shutdown/test001_client.adb0000644000175000017500000000414711750740340024610 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- T E S T 0 0 0 _ C L I E N T -- -- -- -- B o d y -- -- -- -- Copyright (C) 2002-2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with Test_Client; procedure Test001_Client is begin Test_Client (True); end Test001_Client; polyorb-2.8~20110207.orig/testsuite/corba/shutdown/Makefile.local0000644000175000017500000000015511750740340024126 0ustar xavierxavier{current_dir}test_interface.idl-stamp: idlac_flags := ${test_target}: ${current_dir}test_interface.idl-stamp polyorb-2.8~20110207.orig/testsuite/corba/shutdown/test_interface-impl.adb0000644000175000017500000001036711750740340026011 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- T E S T _ I N T E R F A C E . I M P L -- -- -- -- B o d y -- -- -- -- Copyright (C) 2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with Ada.Exceptions; with Ada.Finalization; with Ada.Text_IO; use Ada.Text_IO; with CORBA.ORB; pragma Elaborate_All (CORBA.ORB); with PolyORB.Utils.Report; use PolyORB.Utils.Report; pragma Elaborate_All (PolyORB.Utils.Report); with Test_Interface.Skel; pragma Warnings (Off, Test_Interface.Skel); package body Test_Interface.Impl is Request_In_Progress : Boolean := False; Request_Completed : Boolean := False; task Killer_Task is entry Do_Shutdown (Wait : Boolean); end Killer_Task; task body Killer_Task is Wait_For_Completion : Boolean; Got_Exception : Boolean := False; begin accept Do_Shutdown (Wait : Boolean) do Wait_For_Completion := Wait; end Do_Shutdown; Output ("Shutting down, Wait = " & Wait_For_Completion'Img, True); begin CORBA.ORB.Shutdown (Wait_For_Completion); exception when E : others => Output ("Unexpected exception " & Ada.Exceptions.Exception_Name (E), False); Put_Line (Ada.Exceptions.Exception_Information (E)); Got_Exception := True; end; if Got_Exception then null; elsif Wait_For_Completion then Output ("Shutdown completed with wait", Request_Completed and not Request_In_Progress); else Output ("Shutdown completed without wait", Request_In_Progress and not Request_Completed); end if; end Killer_Task; procedure Trigger_Server_Shutdown (Self : access Object; Wait : Boolean) is pragma Unreferenced (Self); begin Request_In_Progress := True; Killer_Task.Do_Shutdown (Wait); Output ("Triggered server shutdown", True); delay 0.5; Request_In_Progress := False; Request_Completed := True; end Trigger_Server_Shutdown; type Witness is new Ada.Finalization.Controlled with null record; procedure Finalize (X : in out Witness) is pragma Unreferenced (X); begin Output ("Client has terminated", Client_Terminated); Output ("Witnessing completion and finalization", Request_Completed and not Request_In_Progress); End_Report; end Finalize; A_Witness : Witness; pragma Unreferenced (A_Witness); end Test_Interface.Impl; polyorb-2.8~20110207.orig/testsuite/corba/shutdown/test_client.adb0000644000175000017500000000604511750740340024366 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- T E S T 0 0 0 _ C L I E N T -- -- -- -- B o d y -- -- -- -- Copyright (C) 2002-2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with Ada.Exceptions; with CORBA.ORB; with PolyORB.Utils.Report; use PolyORB.Utils.Report; with PolyORB.CORBA_P.Server_Tools; use PolyORB.CORBA_P.Server_Tools; with PolyORB.Setup.Thread_Pool_Server; pragma Warnings (Off, PolyORB.Setup.Thread_Pool_Server); with Test_Interface; with Test_Interface.Impl; use Test_Interface.Impl; procedure Test_Client (Wait : Boolean) is Ref : Test_Interface.Ref; begin New_Test ("Test_Client: Wait = " & Wait'Img); CORBA.ORB.Initialize ("ORB"); -- Set up local server in separate task Initiate_Servant (new Test_Interface.Impl.Object, Ref); Initiate_Server (Start_New_Task => True); -- Checking if it worked if Test_Interface.Is_Nil (Ref) then Output ("cannot invoke on a nil reference", False); return; end if; Test_Interface.Trigger_Server_Shutdown (Ref, Wait); Client_Terminated := True; exception when E : others => Output ("Unexpected exception " & Ada.Exceptions.Exception_Information (E), False); End_Report; end Test_Client; polyorb-2.8~20110207.orig/testsuite/corba/shutdown/test_interface.idl0000644000175000017500000000045511750740340025071 0ustar xavierxavierinterface Test_Interface { void trigger_server_shutdown (in boolean wait); // Have a dedicated server task call Shutdown with the given value // for Wait_For_Completion. This method does not return immediately, // so if the Shutdown call is waits for completion, it will be blocked. }; polyorb-2.8~20110207.orig/testsuite/corba/shutdown/test000_client.adb0000644000175000017500000000415011750740340024601 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- T E S T 0 0 0 _ C L I E N T -- -- -- -- B o d y -- -- -- -- Copyright (C) 2002-2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with Test_Client; procedure Test000_Client is begin Test_Client (False); end Test000_Client; polyorb-2.8~20110207.orig/testsuite/corba/shutdown/local.gpr0000644000175000017500000000072211750740340023201 0ustar xavierxavierwith "polyorb", "polyorb_test_common"; project local is Dir := external ("Test_Dir"); Obj_Dir := PolyORB_Test_Common.Build_Dir & Dir; for Object_Dir use Obj_Dir; for Source_Dirs use (Obj_Dir, PolyORB_Test_Common.Source_Dir & Dir); package Compiler is for Default_Switches ("Ada") use PolyORB_Test_Common.Compiler'Default_Switches ("Ada"); end Compiler; for Main use ("test000_client.adb", "test001_client.adb"); end local; polyorb-2.8~20110207.orig/testsuite/corba/shutdown/test_interface-impl.ads0000644000175000017500000000503211750740340026023 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- T E S T _ I N T E R F A C E . I M P L -- -- -- -- S p e c -- -- -- -- Copyright (C) 2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ pragma Style_Checks ("NM32766"); with PortableServer; package Test_Interface.Impl is type Object is new PortableServer.Servant_Base with private; type Object_Ptr is access all Object'Class; procedure Trigger_Server_Shutdown (Self : access Object; Wait : Boolean); Client_Terminated : Boolean := False; private type Object is new PortableServer.Servant_Base with record -- Insert components to hold the state -- of the implementation object. null; end record; end Test_Interface.Impl; polyorb-2.8~20110207.orig/testsuite/corba/object/0000755000175000017500000000000011750740340020767 5ustar xavierxavierpolyorb-2.8~20110207.orig/testsuite/corba/object/test000/0000755000175000017500000000000011750740340022166 5ustar xavierxavierpolyorb-2.8~20110207.orig/testsuite/corba/object/test000/Makefile.local0000644000175000017500000000015611750740340024721 0ustar xavierxavier${current_dir}test_interface.idl-stamp: idlac_flags := ${test_target}: ${current_dir}test_interface.idl-stamp polyorb-2.8~20110207.orig/testsuite/corba/object/test000/test_interface-impl.adb0000644000175000017500000000646511750740340026607 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- T E S T _ I N T E R F A C E . I M P L -- -- -- -- B o d y -- -- -- -- Copyright (C) 2006-2007, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with Ada.Exceptions; with Ada.Text_IO; use Ada.Text_IO; with GNAT.OS_Lib; with CORBA.ORB; with PortableServer.POA; with PortableServer.POA.Helper; with Test_Interface.Skel; pragma Warnings (Off, Test_Interface.Skel); package body Test_Interface.Impl is function get_invalid_ref (Self : access Object) return Test_Interface.Ref'Class is pragma Unreferenced (Self); Root_POA : PortableServer.POA.Local_Ref; Result : Test_Interface.Ref; begin Root_POA := PortableServer.POA.Helper.To_Local_Ref (CORBA.ORB.Resolve_Initial_References (CORBA.ORB.To_CORBA_String ("RootPOA"))); declare use PortableServer; use PortableServer.POA; begin Set (Result, CORBA.Object.Object_Of (Servant_To_Reference (Root_POA, new Object))); Deactivate_Object (Root_POA, Reference_To_Id (Root_POA, Result)); end; return Result; exception when E : others => Put_Line ("get_invalid_ref: server side exception " & Ada.Exceptions.Exception_Information (E)); raise; end get_invalid_ref; procedure terminate_server (Self : access Object) is pragma Unreferenced (Self); begin GNAT.OS_Lib.OS_Exit (0); end terminate_server; end Test_Interface.Impl; polyorb-2.8~20110207.orig/testsuite/corba/object/test000/test_interface.idl0000644000175000017500000000024711750740340025662 0ustar xavierxavierinterface Test_Interface { Test_Interface get_invalid_ref (); // Return a reference that points to a non-existing object oneway void terminate_server (); }; polyorb-2.8~20110207.orig/testsuite/corba/object/test000/test000_client.adb0000644000175000017500000000771011750740340025400 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- T E S T 0 0 0 _ C L I E N T -- -- -- -- B o d y -- -- -- -- Copyright (C) 2002-2008, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with Ada.Command_Line; with Ada.Exceptions; with Ada.Text_IO; with CORBA.ORB; with PolyORB.Setup.Client; pragma Warnings (Off, PolyORB.Setup.Client); with PolyORB.Utils.Report; use PolyORB.Utils.Report; with Test_Interface; procedure Test000_Client is use Ada.Command_Line; use Ada.Text_IO; IOR : constant String := Ada.Command_Line.Argument (1); Ref, Invalid_Ref : Test_Interface.Ref; Got_Comm_Failure : Boolean; begin New_Test ("Test000_Client"); CORBA.ORB.Initialize ("ORB"); if Argument_Count /= 1 then Put_Line ("usage : client |-i"); return; end if; -- Getting the CORBA.Object CORBA.ORB.String_To_Object (CORBA.To_CORBA_String (IOR), Ref); -- Checking if it worked if Test_Interface.Is_Nil (Ref) then Put_Line ("main : cannot invoke on a nil reference"); return; end if; -- Sending message Output ("Non_Existent on valid server ref", not Test_Interface.Non_Existent (Ref)); Invalid_Ref := Test_Interface.Ref (Test_Interface.Get_Invalid_Ref (Ref)); Output ("Non_Existent on invalid server ref", Test_Interface.Non_Existent (Invalid_Ref)); Test_Interface.Terminate_Server (Ref); Got_Comm_Failure := False; declare B : Boolean; pragma Unreferenced (B); begin B := Test_Interface.Non_Existent (Ref); exception when CORBA.Comm_Failure => Got_Comm_Failure := True; end; Output ("Non_Existent on dead server gets COMM_FAILURE", Got_Comm_Failure); End_Report; exception when E : others => declare Memb : CORBA.System_Exception_Members; begin CORBA.Get_Members (E, Memb); Put_Line ("received exception " & Ada.Exceptions.Exception_Name (E) & ", minor" & Memb.Minor'Img & ", completion status: " & Memb.Completed'Img); Output ("Unexpected exception", False); End_Report; end; end Test000_Client; polyorb-2.8~20110207.orig/testsuite/corba/object/test000/local.gpr0000644000175000017500000000072211750740340023773 0ustar xavierxavierwith "polyorb", "polyorb_test_common"; project local is Dir := external ("Test_Dir"); Obj_Dir := PolyORB_Test_Common.Build_Dir & Dir; for Object_Dir use Obj_Dir; for Source_Dirs use (Obj_Dir, PolyORB_Test_Common.Source_Dir & Dir); package Compiler is for Default_Switches ("Ada") use PolyORB_Test_Common.Compiler'Default_Switches ("Ada"); end Compiler; for Main use ("test000_client.adb", "test000_server.adb"); end local; polyorb-2.8~20110207.orig/testsuite/corba/object/test000/test_interface-impl.ads0000644000175000017500000000506711750740340026625 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- T E S T _ I N T E R F A C E . I M P L -- -- -- -- S p e c -- -- -- -- Copyright (C) 2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ pragma Style_Checks ("NM32766"); with PortableServer; package Test_Interface.Impl is type Object is new PortableServer.Servant_Base with private; type Object_Ptr is access all Object'Class; function get_invalid_ref (Self : access Object) return Test_Interface.Ref'Class; procedure terminate_server (Self : access Object); private type Object is new PortableServer.Servant_Base with record -- Insert components to hold the state -- of the implementation object. null; end record; end Test_Interface.Impl; polyorb-2.8~20110207.orig/testsuite/corba/object/test000/test000_server.adb0000644000175000017500000000716311750740340025432 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- T E S T 0 0 0 _ S E R V E R -- -- -- -- B o d y -- -- -- -- Copyright (C) 2002-2007, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with Ada.Text_IO; use Ada.Text_IO; with CORBA.Impl; with CORBA.Object; with CORBA.ORB; with PortableServer; with PortableServer.POA; with PortableServer.POA.Helper; with PortableServer.POAManager; with PolyORB.CORBA_P.Server_Tools; with Test_Interface.Impl; -- Setup server node: use no tasking default configuration with PolyORB.Setup.No_Tasking_Server; pragma Warnings (Off, PolyORB.Setup.No_Tasking_Server); procedure Test000_Server is begin CORBA.ORB.Initialize ("ORB"); begin declare Root_POA : PortableServer.POA.Local_Ref; Obj : constant CORBA.Impl.Object_Ptr := new Test_Interface.Impl.Object; Ref : CORBA.Object.Ref; Res : Boolean; pragma Unreferenced (Res); begin begin -- This should raise Inv_Objref Res := CORBA.Object.Non_Existent (Ref); raise Program_Error; exception when CORBA.Inv_Objref => null; end; -- Retrieve Root POA Root_POA := PortableServer.POA.Helper.To_Local_Ref (CORBA.ORB.Resolve_Initial_References (CORBA.ORB.To_CORBA_String ("RootPOA"))); PortableServer.POAManager.Activate (PortableServer.POA.Get_The_POAManager (Root_POA)); PolyORB.CORBA_P.Server_Tools.Initiate_Servant (PortableServer.Servant (Obj), Ref); Res := CORBA.Object.Non_Existent (Ref); Put_Line ("'" & CORBA.To_Standard_String (CORBA.Object.Object_To_String (Ref)) & "'"); CORBA.ORB.Run; end; end; end Test000_Server; polyorb-2.8~20110207.orig/testsuite/corba/benchs/0000755000175000017500000000000011750740340020763 5ustar xavierxavierpolyorb-2.8~20110207.orig/testsuite/corba/benchs/test000/0000755000175000017500000000000011750740340022162 5ustar xavierxavierpolyorb-2.8~20110207.orig/testsuite/corba/benchs/test000/test-activator-impl.adb0000644000175000017500000000664511750740340026555 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- T E S T . A C T I V A T O R . I M P L -- -- -- -- B o d y -- -- -- -- Copyright (C) 2005-2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with CORBA; with PortableServer.POA.Helper; with PortableServer.ServantManager; with Test.Echo.Impl; package body Test.Activator.Impl is --------------- -- Incarnate -- --------------- function Incarnate (Self : access Object; Oid : PortableServer.ObjectId; Adapter : PortableServer.POA_Forward.Ref) return PortableServer.Servant is pragma Unreferenced (Self); Srv : constant Test.Echo.Impl.Object_Ptr := new Test.Echo.Impl.Object; begin PortableServer.POA.Activate_Object_With_Id (PortableServer.POA.Helper.To_Local_Ref (Adapter), Oid, PortableServer.Servant (Srv)); return PortableServer.Servant (Srv); end Incarnate; ---------- -- Is_A -- ---------- function Is_A (Self : not null access Object; Logical_Type_Id : Standard.String) return Boolean is pragma Unreferenced (Self); begin return CORBA.Is_Equivalent (Logical_Type_Id, Test.Activator.Repository_Id) or else CORBA.Is_Equivalent (Logical_Type_Id, PortableServer.ServantActivator.Repository_Id) or else CORBA.Is_Equivalent (Logical_Type_Id, PortableServer.ServantManager.Repository_Id) or else CORBA.Is_Equivalent (Logical_Type_Id, "IDL:omg.org/CORBA/Object:1.0"); end Is_A; end Test.Activator.Impl; polyorb-2.8~20110207.orig/testsuite/corba/benchs/test000/Makefile.local0000644000175000017500000000013211750740340024707 0ustar xavierxavier${current_dir}test.idl-stamp: idlac_flags := ${test_target}: ${current_dir}test.idl-stamp polyorb-2.8~20110207.orig/testsuite/corba/benchs/test000/test-factory-impl.ads0000644000175000017500000000503411750740340026240 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- T E S T . F A C T O R Y . I M P L -- -- -- -- S p e c -- -- -- -- Copyright (C) 2005-2008, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with CORBA; with PortableServer; package Test.Factory.Impl is type Object is new PortableServer.Servant_Base with private; type Object_Ptr is access all Object'Class; procedure Preallocate (Self : access Object; Count : CORBA.Long); function Create_References (Self : access Object; Count : CORBA.Long) return Test.Factory.EchoSequence; procedure Shutdown (Self : access Object); private type Object is new PortableServer.Servant_Base with null record; end Test.Factory.Impl; polyorb-2.8~20110207.orig/testsuite/corba/benchs/test000/test-activator-impl.ads0000644000175000017500000000525111750740340026566 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- T E S T . A C T I V A T O R . I M P L -- -- -- -- S p e c -- -- -- -- Copyright (C) 2005-2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with PortableServer.ServantActivator.Impl; package Test.Activator.Impl is type Object is new PortableServer.ServantActivator.Impl.Object with private; type Object_Ptr is access all Object'Class; function Incarnate (Self : access Object; Oid : PortableServer.ObjectId; Adapter : PortableServer.POA_Forward.Ref) return PortableServer.Servant; private type Object is new PortableServer.ServantActivator.Impl.Object with null record; function Is_A (Self : not null access Object; Logical_Type_Id : Standard.String) return Boolean; end Test.Activator.Impl; polyorb-2.8~20110207.orig/testsuite/corba/benchs/test000/test-factory-impl.adb0000644000175000017500000000611611750740340026221 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- T E S T . F A C T O R Y . I M P L -- -- -- -- B o d y -- -- -- -- Copyright (C) 2005-2008, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with CORBA.ORB; with Test_Support; with Test.Factory.Skel; pragma Warnings (Off, Test.Factory.Skel); package body Test.Factory.Impl is ----------------------- -- Create_References -- ----------------------- function Create_References (Self : access Object; Count : CORBA.Long) return Test.Factory.EchoSequence is pragma Unreferenced (Self); Result : Test.Factory.EchoSequence; begin for J in 1 .. Natural (Count) loop Append (Result, Test_Support.To_Object_Reference (J)); end loop; return Result; end Create_References; ----------------- -- Preallocate -- ----------------- procedure Preallocate (Self : access Object; Count : CORBA.Long) is pragma Unreferenced (Self); begin Test_Support.Preallocate (Natural (Count)); end Preallocate; -------------- -- Shutdown -- -------------- procedure Shutdown (Self : access Object) is pragma Unreferenced (Self); begin CORBA.ORB.Shutdown (False); end Shutdown; end Test.Factory.Impl; polyorb-2.8~20110207.orig/testsuite/corba/benchs/test000/test-echo-impl.ads0000644000175000017500000000460411750740340025511 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- T E S T . E C H O . I M P L -- -- -- -- S p e c -- -- -- -- Copyright (C) 2005-2008, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with CORBA; with PortableServer; package Test.Echo.Impl is type Object is new PortableServer.Servant_Base with private; type Object_Ptr is access all Object'Class; function Echo_String (Self : access Object; Value : CORBA.String) return CORBA.String; private type Object is new PortableServer.Servant_Base with null record; end Test.Echo.Impl; polyorb-2.8~20110207.orig/testsuite/corba/benchs/test000/test-echo-impl.adb0000644000175000017500000000457511750740340025477 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- T E S T . E C H O . I M P L -- -- -- -- B o d y -- -- -- -- Copyright (C) 2005-2008, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with Test.Echo.Skel; pragma Warnings (Off, Test.Echo.Skel); package body Test.Echo.Impl is ----------------- -- Echo_String -- ----------------- function Echo_String (Self : access Object; Value : CORBA.String) return CORBA.String is pragma Unreferenced (Self); begin return Value; end Echo_String; end Test.Echo.Impl; polyorb-2.8~20110207.orig/testsuite/corba/benchs/test000/test_support.adb0000644000175000017500000001405611750740340025413 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- T E S T _ S U P P O R T -- -- -- -- B o d y -- -- -- -- Copyright (C) 2005-2008, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with Ada.Text_IO; with CORBA.IDL_SEQUENCES; with CORBA.Impl; with CORBA.Object; with CORBA.ORB; with CORBA.Policy; with PortableServer.POA.Helper; with Test.Activator.Impl; with Test.Echo.Helper; with Test.Echo.Impl; with Test.Factory.Impl; package body Test_Support is function To_ObjectId (Item : Wide_String) return PortableServer.ObjectId; My_POA : PortableServer.POA.Local_Ref; ---------------- -- Initialize -- ---------------- procedure Initialize is Root_POA : constant PortableServer.POA.Local_Ref := PortableServer.POA.Helper.To_Local_Ref (CORBA.ORB.Resolve_Initial_References (CORBA.ORB.To_CORBA_String ("RootPOA"))); Policies : CORBA.Policy.PolicyList; begin CORBA.Policy.IDL_SEQUENCE_Policy.Append (Policies, CORBA.Policy.Ref (PortableServer.POA.Create_Lifespan_Policy (PortableServer.PERSISTENT))); CORBA.Policy.IDL_SEQUENCE_Policy.Append (Policies, CORBA.Policy.Ref (PortableServer.POA.Create_Id_Assignment_Policy (PortableServer.USER_ID))); CORBA.Policy.IDL_SEQUENCE_Policy.Append (Policies, CORBA.Policy.Ref (PortableServer.POA.Create_Implicit_Activation_Policy (PortableServer.NO_IMPLICIT_ACTIVATION))); CORBA.Policy.IDL_SEQUENCE_Policy.Append (Policies, CORBA.Policy.Ref (PortableServer.POA.Create_Request_Processing_Policy (PortableServer.USE_SERVANT_MANAGER))); My_POA := PortableServer.POA.Local_Ref (PortableServer.POA.Create_POA (Root_POA, CORBA.To_CORBA_String ("Ring_POA"), PortableServer.POA.Get_The_POAManager (Root_POA), Policies)); declare Obj : constant Test.Activator.Impl.Object_Ptr := new Test.Activator.Impl.Object; Ref : Test.Activator.Local_Ref; begin Test.Activator.Set (Ref, CORBA.Impl.Object_Ptr (Obj)); PortableServer.POA.Set_Servant_Manager (My_POA, Ref); end; declare Srv : constant Test.Factory.Impl.Object_Ptr := new Test.Factory.Impl.Object; Ref : constant CORBA.Object.Ref := PortableServer.POA.Servant_To_Reference (Root_POA, PortableServer.Servant (Srv)); begin Ada.Text_IO.Put_Line ("'" & CORBA.To_Standard_String (CORBA.ORB.Object_To_String (Ref)) & "'"); end; end Initialize; ----------------- -- Preallocate -- ----------------- procedure Preallocate (Count : Natural) is begin for J in 1 .. Count loop declare Srv : constant Test.Echo.Impl.Object_Ptr := new Test.Echo.Impl.Object; begin PortableServer.POA.Activate_Object_With_Id (My_POA, To_ObjectId (Integer'Wide_Image (J)), PortableServer.Servant (Srv)); end; end loop; end Preallocate; ----------------- -- To_ObjectId -- ----------------- function To_ObjectId (Item : Wide_String) return PortableServer.ObjectId is use CORBA.IDL_SEQUENCES.IDL_SEQUENCE_Octet; Result : PortableServer.ObjectId; begin for J in Item'Range loop Append (CORBA.IDL_SEQUENCES.IDL_SEQUENCE_Octet.Sequence (Result), CORBA.Octet (Wide_Character'Pos (Item (J)) / 256)); Append (CORBA.IDL_SEQUENCES.IDL_SEQUENCE_Octet.Sequence (Result), CORBA.Octet (Wide_Character'Pos (Item (J)) mod 256)); end loop; return Result; end To_ObjectId; ------------------------- -- To_Object_Reference -- ------------------------- function To_Object_Reference (Id : Natural) return Test.Echo.Ref is begin return Test.Echo.Helper.To_Ref (PortableServer.POA.Create_Reference_With_Id (My_POA, To_ObjectId (Natural'Wide_Image (Id)), CORBA.To_CORBA_String (Test.Echo.Repository_Id))); end To_Object_Reference; end Test_Support; polyorb-2.8~20110207.orig/testsuite/corba/benchs/test000/local.gpr0000644000175000017500000000070211750740340023765 0ustar xavierxavierwith "polyorb", "polyorb_test_common"; project local is Dir := external ("Test_Dir"); Obj_Dir := PolyORB_Test_Common.Build_Dir & Dir; for Object_Dir use Obj_Dir; for Source_Dirs use (Obj_Dir, PolyORB_Test_Common.Source_Dir & Dir); package Compiler is for Default_Switches ("Ada") use PolyORB_Test_Common.Compiler'Default_Switches ("Ada"); end Compiler; for Main use ("server.adb", "client.adb"); end local; polyorb-2.8~20110207.orig/testsuite/corba/benchs/test000/test_support.ads0000644000175000017500000000432011750740340025425 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- T E S T _ S U P P O R T -- -- -- -- S p e c -- -- -- -- Copyright (C) 2005-2008, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with Test.Echo; package Test_Support is procedure Initialize; procedure Preallocate (Count : Natural); function To_Object_Reference (Id : Natural) return Test.Echo.Ref; end Test_Support; polyorb-2.8~20110207.orig/testsuite/corba/benchs/test000/test.idl0000644000175000017500000000061311750740340023633 0ustar xavierxavier import ::PortableServer; module Test { interface Echo { string Echo_String (in string Value); }; interface _Factory { typedef sequence EchoSequence; void Preallocate (in long Count); EchoSequence Create_References (in long Count); void Shutdown (); }; local interface Activator : PortableServer::ServantActivator { }; }; polyorb-2.8~20110207.orig/testsuite/corba/benchs/test000/server.adb0000644000175000017500000000540711750740340024146 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- S E R V E R -- -- -- -- B o d y -- -- -- -- Copyright (C) 2005-2007, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with CORBA.ORB; with PortableServer.POA.Helper; with PortableServer.POAManager; with PolyORB.Setup.Thread_Pool_Server; pragma Warnings (Off, PolyORB.Setup.Thread_Pool_Server); with Test_Support; procedure Server is begin declare Argv : CORBA.ORB.Arg_List := CORBA.ORB.Command_Line_Arguments; begin CORBA.ORB.Init (CORBA.ORB.To_CORBA_String ("ORB"), Argv); end; declare Root_POA : constant PortableServer.POA.Local_Ref := PortableServer.POA.Helper.To_Local_Ref (CORBA.ORB.Resolve_Initial_References (CORBA.ORB.To_CORBA_String ("RootPOA"))); begin PortableServer.POAManager.Activate (PortableServer.POA.Get_The_POAManager (Root_POA)); end; Test_Support.Initialize; end Server; polyorb-2.8~20110207.orig/testsuite/corba/benchs/test000/client.adb0000644000175000017500000001421711750740340024115 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- C L I E N T -- -- -- -- B o d y -- -- -- -- Copyright (C) 2005-2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with Ada.Calendar; with Ada.Command_Line; with Ada.Text_IO; with CORBA.ORB; with Test.Echo; with Test.Factory; with PolyORB.Setup.Client; pragma Warnings (Off, PolyORB.Setup.Client); with PolyORB.Utils.Report; procedure Client is use Ada.Calendar; use Ada.Command_Line; use Ada.Text_IO; use PolyORB.Utils.Report; Requests_To_Send : constant Integer := 10_000; Preallocated_Objects : CORBA.Long := 100; Total_Objects : CORBA.Long := 150; procedure Usage; ----------- -- Usage -- ----------- procedure Usage is begin Put_Line ("Usage:"); Put_Line (" client [prealloc] [total]"); end Usage; begin if Argument_Count /= 3 and then Argument_Count /= 1 then Usage; return; end if; if Argument_Count = 3 then Preallocated_Objects := CORBA.Long'Value (Argument (2)); Total_Objects := CORBA.Long'Value (Argument (3)); end if; New_Test ("Object Activation Benchmarks"); declare Argv : CORBA.ORB.Arg_List := CORBA.ORB.Command_Line_Arguments; begin CORBA.ORB.Init (CORBA.ORB.To_CORBA_String ("ORB"), Argv); end; declare Factory : Test.Factory.Ref; Start, Finish : Time; Sequence : Test.Factory.EchoSequence; Aux : CORBA.String; pragma Warnings (Off, Aux); begin CORBA.ORB.String_To_Object (CORBA.To_CORBA_String (Argument (1)), Factory); Start := Clock; Test.Factory.Preallocate (Factory, Preallocated_Objects); Finish := Clock; Put_Line ("Time to initialize" & CORBA.Long'Image (Preallocated_Objects) & " objects: " & Duration'Image (Finish - Start)); Output ("Object initialization", True); Sequence := Test.Factory.Create_References (Factory, Preallocated_Objects); Start := Clock; for J in 1 .. Test.Factory.Length (Sequence) loop Aux := Test.Echo.Echo_String (Test.Factory.Get_Element (Sequence, J), CORBA.To_CORBA_String ("AAAA")); end loop; Finish := Clock; Put_Line ("Time to process one request/servant, with" & CORBA.Long'Image (Preallocated_Objects) & " servants:" & Duration'Image (Finish - Start)); Put_Line ("Mean value:" & Duration'Image ((Finish - Start) / Test.Factory.Length (Sequence))); Output ("Bench #1", True); -- Create one reference for next bench. -- Also finalize the references created for previous bench, to ensure -- that the associated binding objects (protocol stack and transport -- endpoints) are torn down. This is necessary to start from a clean -- situation and provide a meaningful measurement for the 2nd test. Sequence := Test.Factory.Create_References (Factory, 1); Start := Clock; for J in 1 .. Requests_To_Send loop Aux := Test.Echo.Echo_String (Test.Factory.Get_Element (Sequence, 1), CORBA.To_CORBA_String ("AAAA")); end loop; Finish := Clock; Put_Line ("Time to process" & Integer'Image (Requests_To_Send) & " requests on one servant:" & Duration'Image (Finish - Start)); Put_Line ("Mean value:" & Duration'Image ((Finish - Start) / Requests_To_Send)); Output ("Bench #2", True); Sequence := Test.Factory.Create_References (Factory, Total_Objects); Start := Clock; for J in 1 .. Test.Factory.Length (Sequence) loop Aux := Test.Echo.Echo_String (Test.Factory.Get_Element (Sequence, J), CORBA.To_CORBA_String ("AAAA")); end loop; Finish := Clock; Put_Line ("Time to process one request/servant, with" & CORBA.Long'Image (Total_Objects) & " servants:" & Duration'Image (Finish - Start)); Put_Line ("Mean value:" & Duration'Image ((Finish - Start) / Test.Factory.Length (Sequence))); Output ("Bench #3", True); End_Report; CORBA.ORB.Shutdown (False); end; end Client; polyorb-2.8~20110207.orig/testsuite/corba/code_sets/0000755000175000017500000000000011750740340021471 5ustar xavierxavierpolyorb-2.8~20110207.orig/testsuite/corba/code_sets/test000/0000755000175000017500000000000011750740340022670 5ustar xavierxavierpolyorb-2.8~20110207.orig/testsuite/corba/code_sets/test000/Makefile.local0000644000175000017500000000015611750740340025423 0ustar xavierxavier${current_dir}test_interface.idl-stamp: idlac_flags := ${test_target}: ${current_dir}test_interface.idl-stamp polyorb-2.8~20110207.orig/testsuite/corba/code_sets/test000/test_interface-impl.adb0000644000175000017500000000457711750740340027313 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- T E S T _ I N T E R F A C E . I M P L -- -- -- -- B o d y -- -- -- -- Copyright (C) 2004-2008, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with Test_Interface.Skel; pragma Warnings (Off, Test_Interface.Skel); package body Test_Interface.Impl is --------- -- Put -- --------- procedure Put (Self : access Object; Value : CORBA.Wide_String) is pragma Unreferenced (Self); pragma Unreferenced (Value); begin raise Program_Error; end Put; end Test_Interface.Impl; ././@LongLink0000000000000000000000000000015100000000000011562 Lustar rootrootpolyorb-2.8~20110207.orig/testsuite/corba/code_sets/test000/polyorb-giop_p-code_sets-converters-test.adspolyorb-2.8~20110207.orig/testsuite/corba/code_sets/test000/polyorb-giop_p-code_sets-converters-test0000644000175000017500000000421411750740340032670 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- POLYORB.GIOP_P.CODE_SETS.CONVERTERS.TEST -- -- -- -- S p e c -- -- -- -- Copyright (C) 2004 Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by ACT Europe. -- -- (email: sales@act-europe.fr) -- -- -- ------------------------------------------------------------------------------ package PolyORB.GIOP_P.Code_Sets.Converters.Test is pragma Elaborate_Body (Test); end PolyORB.GIOP_P.Code_Sets.Converters.Test; polyorb-2.8~20110207.orig/testsuite/corba/code_sets/test000/test_interface.idl0000644000175000017500000000010011750740340026350 0ustar xavierxavier interface Test_Interface { void Put (in wstring Value); }; ././@LongLink0000000000000000000000000000015100000000000011562 Lustar rootrootpolyorb-2.8~20110207.orig/testsuite/corba/code_sets/test000/polyorb-giop_p-code_sets-converters-test.adbpolyorb-2.8~20110207.orig/testsuite/corba/code_sets/test000/polyorb-giop_p-code_sets-converters-test0000644000175000017500000000742311750740340032675 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- POLYORB.GIOP_P.CODE_SETS.CONVERTERS.TEST -- -- -- -- B o d y -- -- -- -- Copyright (C) 2004-2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with PolyORB.Initialization; with PolyORB.Utils.Strings; package body PolyORB.GIOP_P.Code_Sets.Converters.Test is procedure Initialize; function Create_UCS2_Native_Converter return Wide_Converter_Access; function Create_UCS2_UTF16_Converter return Wide_Converter_Access; ---------------------------------- -- Create_UCS2_Native_Converter -- ---------------------------------- function Create_UCS2_Native_Converter return Wide_Converter_Access is begin return new UCS2_Native_Wide_Converter; end Create_UCS2_Native_Converter; --------------------------------- -- Create_UCS2_UTF16_Converter -- --------------------------------- function Create_UCS2_UTF16_Converter return Wide_Converter_Access is begin return new UCS2_UTF16_Wide_Converter; end Create_UCS2_UTF16_Converter; ---------------- -- Initialize -- ---------------- procedure Initialize is begin Register_Native_Code_Set (16#00040001#, -- KS C5601:1987; Korean Hangul and Hanja Graphic Characters Create_UCS2_Native_Converter'Access, Create_UCS2_UTF16_Converter'Access); -- We intentionnaly use wrong converters to reduce code -- complexity: we only test Codeset_Incompatible exception end Initialize; begin declare use PolyORB.Initialization; use PolyORB.Initialization.String_Lists; use PolyORB.Utils.Strings; begin Register_Module (Module_Info' (Name => +"code_sets.converters.test", Conflicts => Empty, Depends => +"code_sets.converters", Provides => Empty, Implicit => False, Init => Initialize'Access, Shutdown => null)); end; end PolyORB.GIOP_P.Code_Sets.Converters.Test; polyorb-2.8~20110207.orig/testsuite/corba/code_sets/test000/local.gpr0000644000175000017500000000070211750740340024473 0ustar xavierxavierwith "polyorb", "polyorb_test_common"; project local is Dir := external ("Test_Dir"); Obj_Dir := PolyORB_Test_Common.Build_Dir & Dir; for Object_Dir use Obj_Dir; for Source_Dirs use (Obj_Dir, PolyORB_Test_Common.Source_Dir & Dir); package Compiler is for Default_Switches ("Ada") use PolyORB_Test_Common.Compiler'Default_Switches ("Ada"); end Compiler; for Main use ("server.adb", "client.adb"); end local; polyorb-2.8~20110207.orig/testsuite/corba/code_sets/test000/test_interface-impl.ads0000644000175000017500000000456211750740340027326 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- T E S T _ I N T E R F A C E . I M P L -- -- -- -- S p e c -- -- -- -- Copyright (C) 2004-2008, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by ACT Europe. -- -- (email: sales@act-europe.fr) -- -- -- ------------------------------------------------------------------------------ with CORBA; with PortableServer; package Test_Interface.Impl is type Object is new PortableServer.Servant_Base with private; type Object_Ptr is access all Object'Class; procedure Put (Self : access Object; Value : CORBA.Wide_String); private type Object is new PortableServer.Servant_Base with null record; end Test_Interface.Impl; polyorb-2.8~20110207.orig/testsuite/corba/code_sets/test000/server.adb0000644000175000017500000000634411750740340024655 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- S E R V E R -- -- -- -- B o d y -- -- -- -- Copyright (C) 2004-2007, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with Ada.Text_IO; with CORBA.Impl; with CORBA.Object; with CORBA.ORB; with PortableServer.POA.Helper; with PortableServer.POAManager; with PolyORB.Setup.No_Tasking_Server; pragma Warnings (Off, PolyORB.Setup.No_Tasking_Server); with PolyORB.GIOP_P.Code_Sets.Converters.Test; pragma Warnings (Off, PolyORB.GIOP_P.Code_Sets.Converters.Test); with Test_Interface.Impl; procedure Server is Argv : CORBA.ORB.Arg_List := CORBA.ORB.Command_Line_Arguments; Root_POA : PortableServer.POA.Local_Ref; Ref : CORBA.Object.Ref; begin CORBA.ORB.Init (CORBA.ORB.To_CORBA_String ("ORB"), Argv); Root_POA := PortableServer.POA.Helper.To_Local_Ref (CORBA.ORB.Resolve_Initial_References (CORBA.ORB.To_CORBA_String ("RootPOA"))); PortableServer.POAManager.Activate (PortableServer.POA.Get_The_POAManager (Root_POA)); declare Obj : constant CORBA.Impl.Object_Ptr := new Test_Interface.Impl.Object; begin Ref := PortableServer.POA.Servant_To_Reference (Root_POA, PortableServer.Servant (Obj)); end; Ada.Text_IO.Put_Line ("'" & CORBA.To_Standard_String (CORBA.Object.Object_To_String (Ref)) & "'"); Ada.Text_IO.New_Line; CORBA.ORB.Run; end Server; polyorb-2.8~20110207.orig/testsuite/corba/code_sets/test000/client.adb0000644000175000017500000000566011750740340024625 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- C L I E N T -- -- -- -- B o d y -- -- -- -- Copyright (C) 2004-2007, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with Ada.Command_Line; with Ada.Exceptions; with CORBA.ORB; with PolyORB.Utils.Report; with PolyORB.Setup.Client; pragma Warnings (Off, PolyORB.Setup.Client); with Test_Interface; procedure Client is use PolyORB.Utils.Report; Argv : CORBA.ORB.Arg_List := CORBA.ORB.Command_Line_Arguments; Ref : Test_Interface.Ref; begin CORBA.ORB.Init (CORBA.ORB.To_CORBA_String ("ORB"), Argv); CORBA.ORB.String_To_Object (CORBA.To_CORBA_String (Ada.Command_Line.Argument (1)), Ref); New_Test ("Raising CODESET_INCOMPATIBLE exception"); begin Test_Interface.Put (Ref, CORBA.To_CORBA_Wide_String ("Test")); Output ("Raising CODESET_INCOMPATIBLE", False); exception when CORBA.Codeset_Incompatible => Output ("Raising CODESET_INCOMPATIBLE", True); when E : others => Output ("Raising " & Ada.Exceptions.Exception_Information (E), False); end; End_Report; end Client; polyorb-2.8~20110207.orig/testsuite/testsuite.py0000755000175000017500000000763211750740340021051 0ustar xavierxavier#!/usr/bin/env python """ %prog [OPTIONS] [TEST_PATH] Run the PolyORB testsuite To run only core tests: %prog core/ To run a single example: %prog examples/corba-all_functions/ALL_FUNCTIONS_4/test.py See %prog -h for more help. """ from gnatpython.env import Env from gnatpython.fileutils import mkdir, rm from gnatpython.main import Main from gnatpython.mainloop import (MainLoop, add_mainloop_options, generate_collect_result, generate_run_testcase) from gnatpython.testdriver import add_run_test_options from gnatpython.reports import ReportDiff from glob import glob import logging import os DEFAULT_TIMEOUT = 60 logger = logging.getLogger('polyorb.testsuite') def main(): """Run the testsuite and generate reports""" # Parse the command lines options m = Main(add_targets_options=True) add_mainloop_options(m) add_run_test_options(m) m.add_option('--diffs', dest='diffs', action='store_true', default=False, help='show diffs on stdout') m.add_option("--old-result-dir", type="string", default=None, help="Old result dir (to generate the report)") m.add_option('-b', '--build-dir', dest='build_dir', help='separate PolyORB build directory') m.add_option('--testsuite-src-dir', dest='testsuite_src_dir', help='path to polyorb testsuite sources') m.add_option('--coverage', dest='coverage', action='store_true', default=False, help='generate coverage information') m.parse_args() # Various files needed or created by the testsuite results_file = m.options.output_dir + '/results' report_file = m.options.output_dir + '/report' if not m.options.failed_only: rm(m.options.output_dir, True) mkdir(m.options.output_dir) # Add current directory in PYTHONPATH (to find test_utils.py) env = Env() env.add_search_path('PYTHONPATH', os.path.join(os.getcwd(), 'tests')) # Generate the discs list for test.opt parsing # Always add 'ALL' common_discs = Env().discriminants with open(m.options.output_dir + '/discs', 'w') as f_disk: f_disk.write(", ".join(common_discs)) # Expand ~ and ~user contructions for user PATH if m.options.build_dir is None: m.options.build_dir = os.path.join(os.getcwd(), os.pardir) else: m.options.build_dir = os.path.expanduser(m.options.build_dir) if m.options.testsuite_src_dir is None: m.options.testsuite_src_dir = os.path.join(os.getcwd()) else: m.options.testsuite_src_dir = os.path.expanduser( m.options.testsuite_src_dir) # Compute the test list if m.args: test_glob = m.args[0] else: test_glob = None test_list = filter_list('./tests/*/*/*/test.py', test_glob) collect_result = generate_collect_result( m.options.output_dir, results_file, m.options.diffs) run_testcase = generate_run_testcase('tests/run-test.py', common_discs, m.options) os.environ['TEST_CONFIG'] = os.path.join(os.getcwd(), 'env.dump') env.options = m.options env.log_dir = os.path.join(os.getcwd(), 'log') env.store(os.environ['TEST_CONFIG']) MainLoop(test_list, run_testcase, collect_result, m.options.mainloop_jobs) # Generate the report file ReportDiff(m.options.output_dir, m.options.old_result_dir).txt_image(report_file) def filter_list(pattern, run_test=""): """Compute the list of test matching pattern If run_test is not null, run only tests containing run_test """ test_list = [os.path.dirname(p) for p in glob(pattern)] if not run_test: test_list.append("tests/always_fail") return test_list else: run_test = run_test.replace('test.py', '') return [t for t in test_list if run_test.rstrip('/') in t] if __name__ == "__main__": main() polyorb-2.8~20110207.orig/testsuite/README0000644000175000017500000000311111750740340017307 0ustar xavierxavierREADME for the PolyORB testsuite -------------------------------- This file details the organization of PolyORB's test suite. * Directory structure acats/ : source for the Distributed System Annex test suite, from the ACATS suite, corba/ : source for the CORBA test suite, core/ : source for the PolyORB's core test suite, scenarios/ : scenarios to be executed when running the test suite, utils/ : tools used to run the test suite. * Preparing PolyORB to run the test suite 1/ Build PolyORB Refer to PolyORB User's Guide for more information. We suppose you build PolyORB in $build_dir. 2/ Build PolyORB's examples $ make examples 3/ Build the test suite $ make testsuite Note: some tests are not built by default: they require the installation of third-party middleware, and adaptation of the makefiles. See corba/interop/cpp/README and corba/interop/java/README for more details. * Run the test suite Note: GNATPython is required to run the testsuite. To install it, run: svn checkout svn://scm.forge.open-do.org/scmrepos/svn/gnatpython/trunk gnatpython export PYTHONPATH=/path/to/gnatpython $ make run_tests or $ ./testsuite -j N --diff All results are stored in the 'out' directory by default and log in the 'log' directory. To run only the corba tests: ./testsuite.py -j N --diff corba To run the all_exceptions corba tests ./testsuite.py -j N --diff corba/all_exceptions/ And to run a specific test CORBA_ALL_EXCEPTIONS_0 ./testsuite.py -j N --diff corba/all_exceptions/CORBA_ALL_EXCEPTIONS_0 A report is created in out/report. See ./testsuite.py -h for more help polyorb-2.8~20110207.orig/testsuite/ssl-cert.conf0000644000175000017500000000045411750740340021041 0ustar xavierxavier[req] default_bits = 512 default_keyfile = privkey.pem distinguished_name = req_distinguished_name prompt = no [req_distinguished_name] O = PolyORB's Development Team CN = PolyORB Test Suite emailAddress = polyorb-devel@lists.adacore.com polyorb-2.8~20110207.orig/testsuite/dsa/0000755000175000017500000000000011750740340017202 5ustar xavierxavierpolyorb-2.8~20110207.orig/testsuite/dsa/abortion/0000755000175000017500000000000011750740340021017 5ustar xavierxavierpolyorb-2.8~20110207.orig/testsuite/dsa/abortion/app.cfg0000644000175000017500000000045211750740340022261 0ustar xavierxavierconfiguration App is pragma STARTER (None); pragma NAME_SERVER (Standalone); Server_P : partition := (RCI); Client_P : partition; procedure Server is in Server_P; procedure Client; for Client_P'Main use Client; for partition'termination use Local_Termination; end App; polyorb-2.8~20110207.orig/testsuite/dsa/abortion/rci.adb0000644000175000017500000001011511750740340022242 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- R C I -- -- -- -- B o d y -- -- -- -- Copyright (C) 2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with Ada.Finalization; with Ada.Text_IO; use Ada.Text_IO; package body RCI is task Keep_Alive is entry Allow_Terminate; end Keep_Alive; task body Keep_Alive is begin accept Allow_Terminate; end Keep_Alive; protected Barrier is entry Wait; -- First call is passing, subsequent block for ever function Blocked_Calls return Natural; private Passing : Boolean := True; end Barrier; protected body Barrier is entry Wait when Passing is begin Passing := False; end Wait; function Blocked_Calls return Natural is begin return Wait'Count; end Blocked_Calls; end Barrier; type Witness (Call_Id : Integer) is new Ada.Finalization.Limited_Controlled with record Completed : Boolean := False; end record; procedure Initialize (X : in out Witness); procedure Finalize (X : in out Witness); procedure Initialize (X : in out Witness) is begin Put_Line ("call" & X.Call_Id'Img & " started"); end Initialize; procedure Finalize (X : in out Witness) is begin Put_Line ("call" & X.Call_Id'Img & " terminated, completed = " & X.Completed'Img); end Finalize; procedure Block_On_Entry (Call_Id : Integer) is W : Witness (Call_Id); begin Barrier.Wait; W.Completed := True; end Block_On_Entry; function Blocked_Calls return Natural is begin Put_Line ("Blocked_Calls: enter"); return Barrier.Blocked_Calls; end Blocked_Calls; procedure Allow_Terminate is begin Keep_Alive.Allow_Terminate; end Allow_Terminate; type Pkg_Witness is new Ada.Finalization.Limited_Controlled with null record; procedure Initialize (X : in out Pkg_Witness); procedure Finalize (X : in out Pkg_Witness); procedure Initialize (X : in out Pkg_Witness) is begin Put_Line ("Pkg_Witness: initialize"); end Initialize; procedure Finalize (X : in out Pkg_Witness) is begin Put_Line ("Pkg_Witness: finalize"); end Finalize; PW : Pkg_Witness; end RCI; polyorb-2.8~20110207.orig/testsuite/dsa/abortion/rci.ads0000644000175000017500000000500611750740340022266 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- R C I -- -- -- -- S p e c -- -- -- -- Copyright (C) 2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ package RCI is pragma Remote_Call_Interface; procedure Block_On_Entry (Call_Id : Integer); -- Subprogram that returns on first call and then always blocks forever function Blocked_Calls return Natural; -- Return count of tasks blocked on the above procedure Allow_Terminate; -- Allow server to terminate (once all calls to Block_On_Entry are -- cancelled). Until this is called, an application task exists -- that prevents local termination of the server partition. end RCI; polyorb-2.8~20110207.orig/testsuite/dsa/abortion/server.adb0000644000175000017500000000416011750740340022776 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- S E R V E R -- -- -- -- B o d y -- -- -- -- Copyright (C) 2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with Ada.Text_IO; use Ada.Text_IO; procedure Server is begin Put_Line ("Server started"); end Server; polyorb-2.8~20110207.orig/testsuite/dsa/abortion/client.adb0000644000175000017500000001040211750740340022742 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- C L I E N T -- -- -- -- B o d y -- -- -- -- Copyright (C) 2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with Ada.Text_IO; use Ada.Text_IO; with RCI; with GNAT.OS_Lib; procedure Client is task Monitor is entry Call (Call_Id : Integer); entry Check; entry Kill; end Monitor; task body Monitor is My_Call_Id : Natural; begin loop select accept Call (Call_Id : Integer) do My_Call_Id := Call_Id; end Call; delay 0.1; Put_Line ("Call" & My_Call_Id'Img & " in progress (blocked):" & RCI.Blocked_Calls'Img); or accept Check do Put_Line ("Monitor: checking blocked calls"); Put_Line ("Calls blocked:" & RCI.Blocked_Calls'Img); end Check; or accept Kill do null; end Kill; delay 0.1; RCI.Allow_Terminate; GNAT.OS_Lib.OS_Exit (0); end select; end loop; end Monitor; procedure Do_Call (Call_Id : Integer; S : String) is begin Put_Line ("Call" & Call_Id'Img & ": " & S); select delay 0.5; Put_Line ("Call" & Call_Id'Img & " timed out"); then abort RCI.Block_On_Entry (Call_Id); end select; end Do_Call; Num_Calls : constant := 7; -- Vary this constant and observe behaviour to identify memory leaks begin Put_Line ("Client started"); -- Call 1: sanity check. The call returns normally, -- the timeout does not trigger. Do_Call (1, "passing"); -- Calls 1001 .. 10xx: Aborted calls -- Call blocks, timeout triggers, request is cancelled. -- For each call the monitor must report 1 blocked call -- (previous calls have been cancelled). for J in 1001 .. 1000 + Num_Calls loop Put_Line ("Call" & J'Img & ": block and abort call"); Monitor.Call (J); Do_Call (J, "blocking"); end loop; -- Sanity check: no call remains blocked Put_Line ("Client idle"); Monitor.Check; -- Call 3: blocking/terminating -- Call blocks, partition terminates and disconnects. -- The server must abort and clean up the request, -- and then cleanly terminate. Put_Line ("Call 3: block and terminate partition"); Monitor.Kill; Do_Call (3, "blocking/terminating"); end Client; polyorb-2.8~20110207.orig/testsuite/tests/0000755000175000017500000000000011750740340017575 5ustar xavierxavierpolyorb-2.8~20110207.orig/testsuite/tests/convert_scenario.py0000755000175000017500000000720211750740340023516 0ustar xavierxavier#!/usr/bin/env python import os import re import sys from gnatpython.fileutils import mkdir, cd CLIENT_SERVER_TEMPLATE = """ from test_utils import * import sys if not client_server(r'%(client_cmd)s', r'%(client_conf)s', r'%(server_cmd)s', r'%(server_conf)s'): sys.exit(1) """ LOCAL_TEMPLATE = """ from test_utils import * import sys if not local(r'%(command)s', r'%(conf)s'): sys.exit(1) """ SCENARIO_SECTION = 'scenario' TEST_SECTION = 'test' CLIENT_SECTION = 'client' SERVER_SECTION = 'server' def parse_scenario(filename): """Parse a scenario file and create the corresponding test directories""" scenario = open(filename) test_dict = {} current_section = SCENARIO_SECTION current_test = "" for line in scenario: if line.startswith('['): test_name = re.match(r'\[(.*) (.*)\]', line) if test_name: current_section = test_name.group(1) current_test = test_name.group(2) if current_section == TEST_SECTION: test_dict[current_test] = {} elif current_section != SCENARIO_SECTION: # Do not parse scenario section. line_def = re.match(r'(.*)=(.*)', line) if line_def: left = line_def.group(1) right = line_def.group(2) if not current_section in test_dict[current_test]: test_dict[current_test][current_section] = {} test_dict[current_test][current_section][left] = right scenario.close() full_name = os.path.basename(filename) sep = full_name.find('-') parent_dir = full_name[:sep] mkdir(parent_dir) scenario_dir = full_name[sep + 1:-5] mkdir(os.path.join(parent_dir, scenario_dir)) cd(os.path.join(parent_dir, scenario_dir)) for test_name in test_dict: test_type = test_dict[test_name][TEST_SECTION]['type'] if test_type == 'client_server': mkdir(test_name) f = open(os.path.join(test_name, 'test.py'), 'w') f.write(CLIENT_SERVER_TEMPLATE % {'client_cmd' : test_dict[test_name][CLIENT_SECTION]['command'], 'client_conf' : test_dict[test_name][CLIENT_SECTION].get('config_file', ''), 'server_cmd' : test_dict[test_name][SERVER_SECTION]['command'], 'server_conf' : test_dict[test_name][SERVER_SECTION].get('config_file', ''), }) f.close() if 'expected_failure' in test_dict[test_name][TEST_SECTION]: f = open(os.path.join(test_name, 'test.opt'), 'w') f.write('ALL XFAIL\n') f.close() elif test_type == 'local': mkdir(test_name) f = open(os.path.join(test_name, 'test.py'), 'w') f.write(LOCAL_TEMPLATE % {'command' : test_dict[test_name][TEST_SECTION]['command'], 'conf' : test_dict[test_name][TEST_SECTION].get('config_file', '') }) f.close() if 'expected_failure' in test_dict[test_name][TEST_SECTION]: f = open(os.path.join(test_name, 'test.opt'), 'w') f.write('ALL XFAIL\n') f.close() else: print 'unknown type for test: ' + test_name if __name__ == "__main__": parse_scenario(sys.argv[1]) polyorb-2.8~20110207.orig/testsuite/tests/corba/0000755000175000017500000000000011750740340020663 5ustar xavierxavierpolyorb-2.8~20110207.orig/testsuite/tests/corba/domainmanager/0000755000175000017500000000000011750740340023465 5ustar xavierxavierpolyorb-2.8~20110207.orig/testsuite/tests/corba/domainmanager/DOMAINMANAGER_0/0000755000175000017500000000000011750740340025646 5ustar xavierxavierpolyorb-2.8~20110207.orig/testsuite/tests/corba/domainmanager/DOMAINMANAGER_0/test.py0000644000175000017500000000026511750740340027202 0ustar xavierxavier from test_utils import * import sys if not client_server(r'corba/domainmanager/test000/client', r'', r'corba/domainmanager/test000/server', r''): fail() polyorb-2.8~20110207.orig/testsuite/tests/corba/portableinterceptor/0000755000175000017500000000000011750740340024752 5ustar xavierxavierpolyorb-2.8~20110207.orig/testsuite/tests/corba/portableinterceptor/CORBA_PORTABLEINTERCEPTOR_2/0000755000175000017500000000000011750740340031030 5ustar xavierxavier././@LongLink0000000000000000000000000000015000000000000011561 Lustar rootrootpolyorb-2.8~20110207.orig/testsuite/tests/corba/portableinterceptor/CORBA_PORTABLEINTERCEPTOR_2/test.pypolyorb-2.8~20110207.orig/testsuite/tests/corba/portableinterceptor/CORBA_PORTABLEINTERCEPTOR_2/test0000644000175000017500000000016311750740340031732 0ustar xavierxavier from test_utils import * import sys if not local(r'corba/portableinterceptor/test002/test002', r''): fail() polyorb-2.8~20110207.orig/testsuite/tests/corba/portableinterceptor/CORBA_PORTABLEINTERCEPTOR_4/0000755000175000017500000000000011750740340031032 5ustar xavierxavier././@LongLink0000000000000000000000000000015000000000000011561 Lustar rootrootpolyorb-2.8~20110207.orig/testsuite/tests/corba/portableinterceptor/CORBA_PORTABLEINTERCEPTOR_4/test.pypolyorb-2.8~20110207.orig/testsuite/tests/corba/portableinterceptor/CORBA_PORTABLEINTERCEPTOR_4/test0000644000175000017500000000030111750740340031726 0ustar xavierxavier from test_utils import * import sys if not client_server(r'corba/portableinterceptor/test004/client', r'', r'corba/portableinterceptor/test004/server', r''): fail() polyorb-2.8~20110207.orig/testsuite/tests/corba/portableinterceptor/CORBA_PORTABLEINTERCEPTOR_3/0000755000175000017500000000000011750740340031031 5ustar xavierxavier././@LongLink0000000000000000000000000000015000000000000011561 Lustar rootrootpolyorb-2.8~20110207.orig/testsuite/tests/corba/portableinterceptor/CORBA_PORTABLEINTERCEPTOR_3/test.pypolyorb-2.8~20110207.orig/testsuite/tests/corba/portableinterceptor/CORBA_PORTABLEINTERCEPTOR_3/test0000644000175000017500000000016311750740340031733 0ustar xavierxavier from test_utils import * import sys if not local(r'corba/portableinterceptor/test003/test003', r''): fail() polyorb-2.8~20110207.orig/testsuite/tests/corba/portableinterceptor/CORBA_PORTABLEINTERCEPTOR_0/0000755000175000017500000000000011750740340031026 5ustar xavierxavier././@LongLink0000000000000000000000000000015000000000000011561 Lustar rootrootpolyorb-2.8~20110207.orig/testsuite/tests/corba/portableinterceptor/CORBA_PORTABLEINTERCEPTOR_0/test.pypolyorb-2.8~20110207.orig/testsuite/tests/corba/portableinterceptor/CORBA_PORTABLEINTERCEPTOR_0/test0000644000175000017500000000016311750740340031730 0ustar xavierxavier from test_utils import * import sys if not local(r'corba/portableinterceptor/test000/test000', r''): fail() polyorb-2.8~20110207.orig/testsuite/tests/corba/portableinterceptor/CORBA_PORTABLEINTERCEPTOR_1/0000755000175000017500000000000011750740340031027 5ustar xavierxavier././@LongLink0000000000000000000000000000015100000000000011562 Lustar rootrootpolyorb-2.8~20110207.orig/testsuite/tests/corba/portableinterceptor/CORBA_PORTABLEINTERCEPTOR_1/test.optpolyorb-2.8~20110207.orig/testsuite/tests/corba/portableinterceptor/CORBA_PORTABLEINTERCEPTOR_1/test0000644000175000017500000000001211750740340031722 0ustar xavierxavierALL XFAIL ././@LongLink0000000000000000000000000000015000000000000011561 Lustar rootrootpolyorb-2.8~20110207.orig/testsuite/tests/corba/portableinterceptor/CORBA_PORTABLEINTERCEPTOR_1/test.pypolyorb-2.8~20110207.orig/testsuite/tests/corba/portableinterceptor/CORBA_PORTABLEINTERCEPTOR_1/test0000644000175000017500000000016311750740340031731 0ustar xavierxavier from test_utils import * import sys if not local(r'corba/portableinterceptor/test001/test001', r''): fail() polyorb-2.8~20110207.orig/testsuite/tests/corba/portableserver/0000755000175000017500000000000011750740340023722 5ustar xavierxavierpolyorb-2.8~20110207.orig/testsuite/tests/corba/portableserver/PORTABLESERVER_2/0000755000175000017500000000000011750740340026302 5ustar xavierxavierpolyorb-2.8~20110207.orig/testsuite/tests/corba/portableserver/PORTABLESERVER_2/test.py0000644000175000017500000000014611750740340027634 0ustar xavierxavier from test_utils import * import sys if not local(r'corba/portableserver/test002', r''): fail() polyorb-2.8~20110207.orig/testsuite/tests/corba/portableserver/PORTABLESERVER_0/0000755000175000017500000000000011750740340026300 5ustar xavierxavierpolyorb-2.8~20110207.orig/testsuite/tests/corba/portableserver/PORTABLESERVER_0/test.py0000644000175000017500000000014611750740340027632 0ustar xavierxavier from test_utils import * import sys if not local(r'corba/portableserver/test000', r''): fail() polyorb-2.8~20110207.orig/testsuite/tests/corba/portableserver/PORTABLESERVER_1/0000755000175000017500000000000011750740340026301 5ustar xavierxavierpolyorb-2.8~20110207.orig/testsuite/tests/corba/portableserver/PORTABLESERVER_1/test.py0000644000175000017500000000014611750740340027633 0ustar xavierxavier from test_utils import * import sys if not local(r'corba/portableserver/test001', r''): fail() polyorb-2.8~20110207.orig/testsuite/tests/corba/location_forwarding/0000755000175000017500000000000011750740340024715 5ustar xavierxavierpolyorb-2.8~20110207.orig/testsuite/tests/corba/location_forwarding/LOCATION_FORWARDING_1/0000755000175000017500000000000011750740340030067 5ustar xavierxavierpolyorb-2.8~20110207.orig/testsuite/tests/corba/location_forwarding/LOCATION_FORWARDING_1/test.py0000644000175000017500000000032111750740340031414 0ustar xavierxavier from test_utils import * import sys if not client_server(r'corba/location_forwarding/test001/test001_client', r'', r'corba/location_forwarding/test001/test001_server', r''): fail() polyorb-2.8~20110207.orig/testsuite/tests/corba/location_forwarding/LOCATION_FORWARDING_0/0000755000175000017500000000000011750740340030066 5ustar xavierxavierpolyorb-2.8~20110207.orig/testsuite/tests/corba/location_forwarding/LOCATION_FORWARDING_0/test.py0000644000175000017500000000016311750740340031417 0ustar xavierxavier from test_utils import * import sys if not local(r'corba/location_forwarding/test000/test000', r''): fail() polyorb-2.8~20110207.orig/testsuite/tests/corba/interop/0000755000175000017500000000000011750740340022343 5ustar xavierxavierpolyorb-2.8~20110207.orig/testsuite/tests/corba/interop/CORBA_INTEROP_4/0000755000175000017500000000000011750740340024614 5ustar xavierxavierpolyorb-2.8~20110207.orig/testsuite/tests/corba/interop/CORBA_INTEROP_4/test.opt0000644000175000017500000000001211750740340026310 0ustar xavierxavierALL XFAIL polyorb-2.8~20110207.orig/testsuite/tests/corba/interop/CORBA_INTEROP_4/test.py0000644000175000017500000000030511750740340026143 0ustar xavierxavier from test_utils import * import sys if not client_server(r'corba/interop/cpp/omniORB/all_functions_client', r'', r'../examples/corba/all_functions/server', r''): fail() polyorb-2.8~20110207.orig/testsuite/tests/corba/interop/CORBA_INTEROP_2/0000755000175000017500000000000011750740340024612 5ustar xavierxavierpolyorb-2.8~20110207.orig/testsuite/tests/corba/interop/CORBA_INTEROP_2/test.opt0000644000175000017500000000001211750740340026306 0ustar xavierxavierALL XFAIL polyorb-2.8~20110207.orig/testsuite/tests/corba/interop/CORBA_INTEROP_2/test.py0000644000175000017500000000030311750740340026137 0ustar xavierxavier from test_utils import * import sys if not client_server(r'corba/interop/cpp/TAO/all_types_dynclient', r'', r'corba/interop/cpp/TAO/all_types_dynserver', r''): fail() polyorb-2.8~20110207.orig/testsuite/tests/corba/interop/CORBA_INTEROP_3/0000755000175000017500000000000011750740340024613 5ustar xavierxavierpolyorb-2.8~20110207.orig/testsuite/tests/corba/interop/CORBA_INTEROP_3/test.opt0000644000175000017500000000001211750740340026307 0ustar xavierxavierALL XFAIL polyorb-2.8~20110207.orig/testsuite/tests/corba/interop/CORBA_INTEROP_3/test.py0000644000175000017500000000027511750740340026150 0ustar xavierxavier from test_utils import * import sys if not client_server(r'corba/interop/cpp/omniORB/all_types_client', r'', r'../examples/corba/all_types/server', r''): fail() polyorb-2.8~20110207.orig/testsuite/tests/corba/interop/CORBA_INTEROP_0/0000755000175000017500000000000011750740340024610 5ustar xavierxavierpolyorb-2.8~20110207.orig/testsuite/tests/corba/interop/CORBA_INTEROP_0/test.opt0000644000175000017500000000001211750740340026304 0ustar xavierxavierALL XFAIL polyorb-2.8~20110207.orig/testsuite/tests/corba/interop/CORBA_INTEROP_0/test.py0000644000175000017500000000030511750740340026137 0ustar xavierxavier from test_utils import * import sys if not client_server(r'corba/interop/cpp/MICO/all_types_dynclient', r'', r'corba/interop/cpp/MICO/all_types_dynserver', r''): fail() polyorb-2.8~20110207.orig/testsuite/tests/corba/interop/CORBA_INTEROP_5/0000755000175000017500000000000011750740340024615 5ustar xavierxavierpolyorb-2.8~20110207.orig/testsuite/tests/corba/interop/CORBA_INTEROP_5/test.opt0000644000175000017500000000001211750740340026311 0ustar xavierxavierALL XFAIL polyorb-2.8~20110207.orig/testsuite/tests/corba/interop/CORBA_INTEROP_5/test.py0000644000175000017500000000032011750740340026141 0ustar xavierxavier from test_utils import * import sys if not client_server(r'corba/interop/cpp/TAO/all_types_dynclient', r'', r'../examples/corba/all_types/server', r'broken_codesets.conf'): fail() polyorb-2.8~20110207.orig/testsuite/tests/corba/interop/CORBA_INTEROP_1/0000755000175000017500000000000011750740340024611 5ustar xavierxavierpolyorb-2.8~20110207.orig/testsuite/tests/corba/interop/CORBA_INTEROP_1/test.opt0000644000175000017500000000001211750740340026305 0ustar xavierxavierALL XFAIL polyorb-2.8~20110207.orig/testsuite/tests/corba/interop/CORBA_INTEROP_1/test.py0000644000175000017500000000031311750740340026137 0ustar xavierxavier from test_utils import * import sys if not client_server(r'corba/interop/cpp/omniORB/all_types_dynclient', r'', r'corba/interop/cpp/omniORB/all_types_dynserver', r''): fail() polyorb-2.8~20110207.orig/testsuite/tests/corba/local/0000755000175000017500000000000011750740340021755 5ustar xavierxavierpolyorb-2.8~20110207.orig/testsuite/tests/corba/local/LOCAL_0/0000755000175000017500000000000011750740340023026 5ustar xavierxavierpolyorb-2.8~20110207.orig/testsuite/tests/corba/local/LOCAL_0/test.py0000644000175000017500000000013511750740340024356 0ustar xavierxavier from test_utils import * import sys if not local(r'corba/local/test000', r''): fail() polyorb-2.8~20110207.orig/testsuite/tests/corba/rtcorba-rtpoa/0000755000175000017500000000000011750740340023442 5ustar xavierxavierpolyorb-2.8~20110207.orig/testsuite/tests/corba/rtcorba-rtpoa/RTPOA_0/0000755000175000017500000000000011750740340024546 5ustar xavierxavierpolyorb-2.8~20110207.orig/testsuite/tests/corba/rtcorba-rtpoa/RTPOA_0/test.py0000644000175000017500000000014511750740340026077 0ustar xavierxavier from test_utils import * import sys if not local(r'corba/rtcorba/rtpoa/test000', r''): fail() polyorb-2.8~20110207.orig/testsuite/tests/corba/all_exceptions/0000755000175000017500000000000011750740340023674 5ustar xavierxavierpolyorb-2.8~20110207.orig/testsuite/tests/corba/all_exceptions/CORBA_ALL_EXCEPTIONS_2/0000755000175000017500000000000011750740340027174 5ustar xavierxavierpolyorb-2.8~20110207.orig/testsuite/tests/corba/all_exceptions/CORBA_ALL_EXCEPTIONS_2/test.py0000644000175000017500000000030111750740340030517 0ustar xavierxavier from test_utils import * import sys if not client_server(r'corba/all_exceptions/client', r'giop_1_1.conf', r'corba/all_exceptions/server', r'giop_1_1.conf'): fail() polyorb-2.8~20110207.orig/testsuite/tests/corba/all_exceptions/CORBA_ALL_EXCEPTIONS_3/0000755000175000017500000000000011750740340027175 5ustar xavierxavierpolyorb-2.8~20110207.orig/testsuite/tests/corba/all_exceptions/CORBA_ALL_EXCEPTIONS_3/test.py0000644000175000017500000000030111750740340030520 0ustar xavierxavier from test_utils import * import sys if not client_server(r'corba/all_exceptions/client', r'giop_1_2.conf', r'corba/all_exceptions/server', r'giop_1_2.conf'): fail() polyorb-2.8~20110207.orig/testsuite/tests/corba/all_exceptions/CORBA_ALL_EXCEPTIONS_0/0000755000175000017500000000000011750740340027172 5ustar xavierxavierpolyorb-2.8~20110207.orig/testsuite/tests/corba/all_exceptions/CORBA_ALL_EXCEPTIONS_0/test.py0000644000175000017500000000024711750740340030526 0ustar xavierxavier from test_utils import * import sys if not client_server(r'corba/all_exceptions/client', r'', r'corba/all_exceptions/server', r''): fail() polyorb-2.8~20110207.orig/testsuite/tests/corba/all_exceptions/CORBA_ALL_EXCEPTIONS_1/0000755000175000017500000000000011750740340027173 5ustar xavierxavierpolyorb-2.8~20110207.orig/testsuite/tests/corba/all_exceptions/CORBA_ALL_EXCEPTIONS_1/test.py0000644000175000017500000000030111750740340030516 0ustar xavierxavier from test_utils import * import sys if not client_server(r'corba/all_exceptions/client', r'giop_1_0.conf', r'corba/all_exceptions/server', r'giop_1_0.conf'): fail() polyorb-2.8~20110207.orig/testsuite/tests/corba/orb_init/0000755000175000017500000000000011750740340022470 5ustar xavierxavierpolyorb-2.8~20110207.orig/testsuite/tests/corba/orb_init/ORB_INIT_0/0000755000175000017500000000000011750740340024154 5ustar xavierxavierpolyorb-2.8~20110207.orig/testsuite/tests/corba/orb_init/ORB_INIT_0/test.py0000644000175000017500000000014011750740340025500 0ustar xavierxavier from test_utils import * import sys if not local(r'corba/orb_init/test000', r''): fail() polyorb-2.8~20110207.orig/testsuite/tests/corba/harness/0000755000175000017500000000000011750740340022326 5ustar xavierxavierpolyorb-2.8~20110207.orig/testsuite/tests/corba/harness/CORBA_HARNESS_7/0000755000175000017500000000000011750740340024565 5ustar xavierxavierpolyorb-2.8~20110207.orig/testsuite/tests/corba/harness/CORBA_HARNESS_7/test.py0000644000175000017500000000013511750740340026115 0ustar xavierxavier from test_utils import * import sys if not local(r'corba/harness/local', r''): fail() polyorb-2.8~20110207.orig/testsuite/tests/corba/harness/CORBA_HARNESS_6/0000755000175000017500000000000011750740340024564 5ustar xavierxavierpolyorb-2.8~20110207.orig/testsuite/tests/corba/harness/CORBA_HARNESS_6/test.py0000644000175000017500000000025211750740340026114 0ustar xavierxavier from test_utils import * import sys if not client_server(r'corba/harness/client', r'', r'corba/harness/server_thread_pool_hahs', r''): fail() polyorb-2.8~20110207.orig/testsuite/tests/corba/harness/CORBA_HARNESS_5/0000755000175000017500000000000011750740340024563 5ustar xavierxavierpolyorb-2.8~20110207.orig/testsuite/tests/corba/harness/CORBA_HARNESS_5/test.py0000644000175000017500000000025011750740340026111 0ustar xavierxavier from test_utils import * import sys if not client_server(r'corba/harness/client', r'', r'corba/harness/server_thread_pool_lf', r''): fail() polyorb-2.8~20110207.orig/testsuite/tests/corba/harness/CORBA_HARNESS_0/0000755000175000017500000000000011750740340024556 5ustar xavierxavierpolyorb-2.8~20110207.orig/testsuite/tests/corba/harness/CORBA_HARNESS_0/test.py0000644000175000017500000000024411750740340026107 0ustar xavierxavier from test_utils import * import sys if not client_server(r'corba/harness/client', r'', r'corba/harness/server_no_tasking', r''): fail() polyorb-2.8~20110207.orig/testsuite/tests/corba/harness/CORBA_HARNESS_2/0000755000175000017500000000000011750740340024560 5ustar xavierxavierpolyorb-2.8~20110207.orig/testsuite/tests/corba/harness/CORBA_HARNESS_2/test.py0000644000175000017500000000025411750740340026112 0ustar xavierxavier from test_utils import * import sys if not client_server(r'corba/harness/client', r'', r'corba/harness/server_thread_per_request', r''): fail() polyorb-2.8~20110207.orig/testsuite/tests/corba/harness/CORBA_HARNESS_3/0000755000175000017500000000000011750740340024561 5ustar xavierxavierpolyorb-2.8~20110207.orig/testsuite/tests/corba/harness/CORBA_HARNESS_3/test.py0000644000175000017500000000025411750740340026113 0ustar xavierxavier from test_utils import * import sys if not client_server(r'corba/harness/client', r'', r'corba/harness/server_thread_per_session', r''): fail() polyorb-2.8~20110207.orig/testsuite/tests/corba/harness/CORBA_HARNESS_1/0000755000175000017500000000000011750740340024557 5ustar xavierxavierpolyorb-2.8~20110207.orig/testsuite/tests/corba/harness/CORBA_HARNESS_1/test.py0000644000175000017500000000024511750740340026111 0ustar xavierxavier from test_utils import * import sys if not client_server(r'corba/harness/client', r'', r'corba/harness/server_thread_pool', r''): fail() polyorb-2.8~20110207.orig/testsuite/tests/corba/performance/0000755000175000017500000000000011750740340023164 5ustar xavierxavierpolyorb-2.8~20110207.orig/testsuite/tests/corba/performance/CORBA_PERFORMANCE_0/0000755000175000017500000000000011750740340026052 5ustar xavierxavierpolyorb-2.8~20110207.orig/testsuite/tests/corba/performance/CORBA_PERFORMANCE_0/test.opt0000644000175000017500000000001211750740340027546 0ustar xavierxavierALL XFAIL polyorb-2.8~20110207.orig/testsuite/tests/corba/performance/CORBA_PERFORMANCE_0/test.py0000644000175000017500000000031411750740340027401 0ustar xavierxavier from test_utils import * import sys if not client_server(r'corba/performance/client', r'performance.conf', r'corba/performance/server_no_tasking', r'performance.conf'): fail() polyorb-2.8~20110207.orig/testsuite/tests/corba/shutdown/0000755000175000017500000000000011750740340022536 5ustar xavierxavierpolyorb-2.8~20110207.orig/testsuite/tests/corba/shutdown/SHUTDOWN_1/0000755000175000017500000000000011750740340024231 5ustar xavierxavierpolyorb-2.8~20110207.orig/testsuite/tests/corba/shutdown/SHUTDOWN_1/test.opt0000644000175000017500000000001211750740340025725 0ustar xavierxavierALL XFAIL polyorb-2.8~20110207.orig/testsuite/tests/corba/shutdown/SHUTDOWN_1/test.py0000644000175000017500000000014711750740340025564 0ustar xavierxavier from test_utils import * import sys if not local(r'corba/shutdown/test001_client', r''): fail() polyorb-2.8~20110207.orig/testsuite/tests/corba/shutdown/SHUTDOWN_0/0000755000175000017500000000000011750740340024230 5ustar xavierxavierpolyorb-2.8~20110207.orig/testsuite/tests/corba/shutdown/SHUTDOWN_0/test.py0000644000175000017500000000014711750740340025563 0ustar xavierxavier from test_utils import * import sys if not local(r'corba/shutdown/test000_client', r''): fail() polyorb-2.8~20110207.orig/testsuite/tests/corba/rtcorba-rtorb/0000755000175000017500000000000011750740340023445 5ustar xavierxavierpolyorb-2.8~20110207.orig/testsuite/tests/corba/rtcorba-rtorb/RTORB_0/0000755000175000017500000000000011750740340024554 5ustar xavierxavierpolyorb-2.8~20110207.orig/testsuite/tests/corba/rtcorba-rtorb/RTORB_0/test.py0000644000175000017500000000014511750740340026105 0ustar xavierxavier from test_utils import * import sys if not local(r'corba/rtcorba/rtorb/test000', r''): fail() polyorb-2.8~20110207.orig/testsuite/tests/corba/object/0000755000175000017500000000000011750740340022131 5ustar xavierxavierpolyorb-2.8~20110207.orig/testsuite/tests/corba/object/OBJECT_0/0000755000175000017500000000000011750740340023316 5ustar xavierxavierpolyorb-2.8~20110207.orig/testsuite/tests/corba/object/OBJECT_0/test.py0000644000175000017500000000026711750740340024654 0ustar xavierxavier from test_utils import * import sys if not client_server(r'corba/object/test000/test000_client', r'', r'corba/object/test000/test000_server', r''): fail() polyorb-2.8~20110207.orig/testsuite/tests/corba/benchs/0000755000175000017500000000000011750740340022125 5ustar xavierxavierpolyorb-2.8~20110207.orig/testsuite/tests/corba/benchs/CORBA_BENCHS_0/0000755000175000017500000000000011750740340024214 5ustar xavierxavierpolyorb-2.8~20110207.orig/testsuite/tests/corba/benchs/CORBA_BENCHS_0/test.py0000644000175000017500000000024711750740340025550 0ustar xavierxavier from test_utils import * import sys if not client_server(r'corba/benchs/test000/client', r'', r'corba/benchs/test000/server', r''): fail() polyorb-2.8~20110207.orig/testsuite/tests/corba/rtcorba-rtcurrent/0000755000175000017500000000000011750740340024345 5ustar xavierxavierpolyorb-2.8~20110207.orig/testsuite/tests/corba/rtcorba-rtcurrent/RTCURRENT_0/0000755000175000017500000000000011750740340026154 5ustar xavierxavierpolyorb-2.8~20110207.orig/testsuite/tests/corba/rtcorba-rtcurrent/RTCURRENT_0/test.py0000644000175000017500000000015311750740340027504 0ustar xavierxavier from test_utils import * import sys if not local(r'corba/rtcorba/rtcurrent/rtcurrent', r''): fail() polyorb-2.8~20110207.orig/testsuite/tests/corba/code_sets/0000755000175000017500000000000011750740340022633 5ustar xavierxavierpolyorb-2.8~20110207.orig/testsuite/tests/corba/code_sets/CODE_SETS_0/0000755000175000017500000000000011750740340024422 5ustar xavierxavierpolyorb-2.8~20110207.orig/testsuite/tests/corba/code_sets/CODE_SETS_0/test.py0000644000175000017500000000030611750740340025752 0ustar xavierxavier from test_utils import * import sys if not client_server(r'corba/code_sets/test000/client', r'', r'corba/code_sets/test000/server', r'code_sets_000_server.conf'): fail() polyorb-2.8~20110207.orig/testsuite/tests/corba/code_sets/CODE_SETS_1/0000755000175000017500000000000011750740340024423 5ustar xavierxavierpolyorb-2.8~20110207.orig/testsuite/tests/corba/code_sets/CODE_SETS_1/test.py0000644000175000017500000000033711750740340025757 0ustar xavierxavier from test_utils import * import sys if not client_server(r'corba/code_sets/test000/client', r'code_sets_000_client.conf', r'corba/code_sets/test000/server', r'code_sets_000_server.conf'): fail() polyorb-2.8~20110207.orig/testsuite/tests/confs/0000755000175000017500000000000011750740340020705 5ustar xavierxavierpolyorb-2.8~20110207.orig/testsuite/tests/confs/giop_1_2.conf0000644000175000017500000000046311750740340023156 0ustar xavierxavier# PolyORB configuration file: GIOP 1.2 profile # $Id$ [iiop] polyorb.protocols.iiop.giop.default_version.major=1 polyorb.protocols.iiop.giop.default_version.minor=2 [access_points] srp=disable soap=disable iiop=enable [modules] binding_data.srp=disable binding_data.soap=disable binding_data.iiop=enable polyorb-2.8~20110207.orig/testsuite/tests/confs/broken_codesets.conf0000644000175000017500000000053611750740340024731 0ustar xavierxavier[giop] # The following parameters force the inclusion of fallback code sets # as supported conversion code sets. This is required to enable # interoperability with ORBs whose code sets negotiation support is # broken. See PolyORB's Users Guide for additional information. # giop.add_char_fallback_code_set=true giop.add_wchar_fallback_code_set=true polyorb-2.8~20110207.orig/testsuite/tests/confs/ssliop.conf0000644000175000017500000000117711750740340023073 0ustar xavierxavier# # PolyORB's configuration file: SSLIOP protocol # $Id$ [access_points] srp=disable soap=disable diop=disable uipmc=disable iiop=enable iiop.ssliop=enable [modules] binding_data.srp=disable binding_data.soap=disable binding_data.diop=disable binding_data.uipmc=disable binding_data.iiop=enable binding_data.iiop.ssliop=enable [ssliop] polyorb.protocols.ssliop.privatekeyfile=privkey.pem polyorb.protocols.ssliop.certificatefile=cert.pem polyorb.protocols.ssliop.cafile=cert.pem polyorb.protocols.ssliop.disable_unprotected_invocations=true polyorb.protocols.ssliop.verify=true polyorb.protocols.ssliop.verify_fail_if_no_peer_cert=true polyorb-2.8~20110207.orig/testsuite/tests/confs/giop_1_1.conf0000644000175000017500000000046311750740340023155 0ustar xavierxavier# PolyORB configuration file: GIOP 1.1 profile # $Id$ [iiop] polyorb.protocols.iiop.giop.default_version.major=1 polyorb.protocols.iiop.giop.default_version.minor=1 [access_points] srp=disable soap=disable iiop=enable [modules] binding_data.srp=disable binding_data.soap=disable binding_data.iiop=enable polyorb-2.8~20110207.orig/testsuite/tests/confs/soap.conf0000644000175000017500000000041711750740340022520 0ustar xavierxavier# PolyORB's configuration file: SOAP profile # $Id$ [access_points] srp=disable soap=enable iiop=disable diop=disable miop=disable [modules] binding_data.srp=disable binding_data.soap=enable binding_data.iiop=disable binding_data.diop=disable binding_data.miop=disable polyorb-2.8~20110207.orig/testsuite/tests/confs/code_sets_000_client.conf0000644000175000017500000000010211750740340025432 0ustar xavierxavier [iiop] polyorb.protocols.iiop.giop.1.2.locate_then_request=false polyorb-2.8~20110207.orig/testsuite/tests/confs/code_sets_000_server.conf0000644000175000017500000000006011750740340025465 0ustar xavierxavier [giop] giop.native_wchar_code_set=16#00040001# polyorb-2.8~20110207.orig/testsuite/tests/confs/performance.conf0000644000175000017500000000055311750740340024060 0ustar xavierxavier############################################################################### # PolyORB configuration file for benchmarking CORBA application [iiop] polyorb.protocols.iiop.giop.1.2.locate_then_request=false # Disable Locate messages polyorb.protocols.iiop.giop.1.2.max_message_size=1000000 # Increase to a very big value to limit the effect of fragmentation polyorb-2.8~20110207.orig/testsuite/tests/confs/miop.conf0000644000175000017500000000075411750740340022526 0ustar xavierxavier############################################################################### # PolyORB configuration file for the CORBA/MIOP example [miop] ############################################################### # MIOP Global Settings # Multicast address to use # # Note: these two parameters must be set explicitly, no default value # is provided. If either parameter is unset, the MIOP access point is # disabled. polyorb.miop.multicast_addr=239.239.239.18 polyorb.miop.multicast_port=5678 polyorb-2.8~20110207.orig/testsuite/tests/confs/giop.conf0000644000175000017500000000030111750740340022504 0ustar xavierxavier# PolyORB's configuration file: GIOP profile # $Id$ [access_points] srp=disable soap=disable iiop=enable [modules] binding_data.srp=disable binding_data.soap=disable binding_data.iiop=enable polyorb-2.8~20110207.orig/testsuite/tests/confs/giop_1_0.conf0000644000175000017500000000046311750740340023154 0ustar xavierxavier# PolyORB configuration file: GIOP 1.0 profile # $Id$ [iiop] polyorb.protocols.iiop.giop.default_version.major=1 polyorb.protocols.iiop.giop.default_version.minor=0 [access_points] srp=disable soap=disable iiop=enable [modules] binding_data.srp=disable binding_data.soap=disable binding_data.iiop=enable polyorb-2.8~20110207.orig/testsuite/tests/examples/0000755000175000017500000000000011750740340021413 5ustar xavierxavierpolyorb-2.8~20110207.orig/testsuite/tests/examples/corba-rtcorba-client_propagated/0000755000175000017500000000000011750740340027615 5ustar xavierxavier././@LongLink0000000000000000000000000000016000000000000011562 Lustar rootrootpolyorb-2.8~20110207.orig/testsuite/tests/examples/corba-rtcorba-client_propagated/RTCORBA_CLIENT_PROPAGATED_0/polyorb-2.8~20110207.orig/testsuite/tests/examples/corba-rtcorba-client_propagated/RTCORBA_CLIENT_PR0000755000175000017500000000000011750740340032271 5ustar xavierxavier././@LongLink0000000000000000000000000000016700000000000011571 Lustar rootrootpolyorb-2.8~20110207.orig/testsuite/tests/examples/corba-rtcorba-client_propagated/RTCORBA_CLIENT_PROPAGATED_0/test.pypolyorb-2.8~20110207.orig/testsuite/tests/examples/corba-rtcorba-client_propagated/RTCORBA_CLIENT_PR0000644000175000017500000000032511750740340032273 0ustar xavierxavier from test_utils import * import sys if not client_server(r'../examples/corba/rtcorba/client_propagated/client', r'', r'../examples/corba/rtcorba/client_propagated/server', r''): fail() polyorb-2.8~20110207.orig/testsuite/tests/examples/moma/0000755000175000017500000000000011750740340022344 5ustar xavierxavierpolyorb-2.8~20110207.orig/testsuite/tests/examples/moma/MOMA_0/0000755000175000017500000000000011750740340023314 5ustar xavierxavierpolyorb-2.8~20110207.orig/testsuite/tests/examples/moma/MOMA_0/test.opt0000644000175000017500000000001211750740340025010 0ustar xavierxavierALL XFAIL polyorb-2.8~20110207.orig/testsuite/tests/examples/moma/MOMA_0/test.py0000644000175000017500000000023711750740340024647 0ustar xavierxavier from test_utils import * import sys if not client_server(r'../examples/moma/client', r'', r'../examples/moma/server', r''): fail() polyorb-2.8~20110207.orig/testsuite/tests/examples/moma/MOMA_1/0000755000175000017500000000000011750740340023315 5ustar xavierxavierpolyorb-2.8~20110207.orig/testsuite/tests/examples/moma/MOMA_1/test.opt0000644000175000017500000000001211750740340025011 0ustar xavierxavierALL XFAIL polyorb-2.8~20110207.orig/testsuite/tests/examples/moma/MOMA_1/test.py0000644000175000017500000000025111750740340024644 0ustar xavierxavier from test_utils import * import sys if not client_server(r'../examples/moma/client_call_back', r'', r'../examples/moma/server', r''): fail() polyorb-2.8~20110207.orig/testsuite/tests/examples/corba-send/0000755000175000017500000000000011750740340023430 5ustar xavierxavierpolyorb-2.8~20110207.orig/testsuite/tests/examples/corba-send/CORBA_MIOP_0/0000755000175000017500000000000011750740340025321 5ustar xavierxavierpolyorb-2.8~20110207.orig/testsuite/tests/examples/corba-send/CORBA_MIOP_0/test.py0000644000175000017500000000027511750740340026656 0ustar xavierxavier from test_utils import * import sys if not client_server(r'../examples/corba/send/send', r'miop.conf', r'../examples/corba/send/listener', r'miop.conf'): fail() polyorb-2.8~20110207.orig/testsuite/tests/examples/corba-all_types/0000755000175000017500000000000011750740340024473 5ustar xavierxavierpolyorb-2.8~20110207.orig/testsuite/tests/examples/corba-all_types/ALL_TYPES_5/0000755000175000017500000000000011750740340026313 5ustar xavierxavierpolyorb-2.8~20110207.orig/testsuite/tests/examples/corba-all_types/ALL_TYPES_5/test.py0000644000175000017500000000054511750740340027650 0ustar xavierxavier from test_utils import * import sys r1, r2 = ( client_server( r'../examples/corba/all_types/client', r'giop_1_0.conf', r'../examples/corba/all_types/server', r'giop_1_0.conf'), local( r'../examples/corba/all_types/client', r'giop_1_0.conf', args=['local'])) if not r1 or not r2: fail() polyorb-2.8~20110207.orig/testsuite/tests/examples/corba-all_types/ALL_TYPES_2/0000755000175000017500000000000011750740340026310 5ustar xavierxavierpolyorb-2.8~20110207.orig/testsuite/tests/examples/corba-all_types/ALL_TYPES_2/test.opt0000644000175000017500000000001211750740340030004 0ustar xavierxavierALL XFAIL polyorb-2.8~20110207.orig/testsuite/tests/examples/corba-all_types/ALL_TYPES_2/test.py0000644000175000017500000000026311750740340027642 0ustar xavierxavier from test_utils import * import sys if not client_server( r'../examples/corba/all_types/dynclient', r'', r'../examples/corba/all_types/server', r''): fail() polyorb-2.8~20110207.orig/testsuite/tests/examples/corba-all_types/ALL_TYPES_7/0000755000175000017500000000000011750740340026315 5ustar xavierxavierpolyorb-2.8~20110207.orig/testsuite/tests/examples/corba-all_types/ALL_TYPES_7/test.py0000644000175000017500000000054611750740340027653 0ustar xavierxavier from test_utils import * import sys r1, r2 = ( client_server( r'../examples/corba/all_types/client', r'giop_1_2.conf', r'../examples/corba/all_types/server', r'giop_1_2.conf'), local( r'../examples/corba/all_types/client', r'giop_1_2.conf', args=['local'])) if not r1 or not r2: fail() polyorb-2.8~20110207.orig/testsuite/tests/examples/corba-all_types/ALL_TYPES_4/0000755000175000017500000000000011750740340026312 5ustar xavierxavierpolyorb-2.8~20110207.orig/testsuite/tests/examples/corba-all_types/ALL_TYPES_4/test.opt0000644000175000017500000000001211750740340030006 0ustar xavierxavierALL XFAIL polyorb-2.8~20110207.orig/testsuite/tests/examples/corba-all_types/ALL_TYPES_4/test.py0000644000175000017500000000053711750740340027650 0ustar xavierxavier from test_utils import * import sys r1, r2 = ( client_server( r'../examples/corba/all_types/client', r'ssliop.conf', r'../examples/corba/all_types/server', r'ssliop.conf'), local( r'../examples/corba/all_types/client', r'ssliop.conf', args=['local'])) if not r1 or not r2: fail() polyorb-2.8~20110207.orig/testsuite/tests/examples/corba-all_types/ALL_TYPES_3/0000755000175000017500000000000011750740340026311 5ustar xavierxavierpolyorb-2.8~20110207.orig/testsuite/tests/examples/corba-all_types/ALL_TYPES_3/test.opt0000644000175000017500000000001211750740340030005 0ustar xavierxavierALL XFAIL polyorb-2.8~20110207.orig/testsuite/tests/examples/corba-all_types/ALL_TYPES_3/test.py0000644000175000017500000000032611750740340027643 0ustar xavierxavier from test_utils import * import sys if not client_server( r'../examples/corba/all_types/dynclient', r'soap.conf', r'../examples/corba/all_types/server', r'soap.conf'): fail() polyorb-2.8~20110207.orig/testsuite/tests/examples/corba-all_types/ALL_TYPES_1/0000755000175000017500000000000011750740340026307 5ustar xavierxavierpolyorb-2.8~20110207.orig/testsuite/tests/examples/corba-all_types/ALL_TYPES_1/test.opt0000644000175000017500000000001211750740340030003 0ustar xavierxavierALL XFAIL polyorb-2.8~20110207.orig/testsuite/tests/examples/corba-all_types/ALL_TYPES_1/test.py0000644000175000017500000000052011750740340027635 0ustar xavierxavier from test_utils import * import sys r1, r2 = ( client_server( r'../examples/corba/all_types/client', r'soap.conf', r'../examples/corba/all_types/server', r'soap.conf'), local( r'../examples/corba/all_types/client', r'soap.conf', args=['local'])) if not r1 or not r2: fail() polyorb-2.8~20110207.orig/testsuite/tests/examples/corba-all_types/ALL_TYPES_0/0000755000175000017500000000000011750740340026306 5ustar xavierxavierpolyorb-2.8~20110207.orig/testsuite/tests/examples/corba-all_types/ALL_TYPES_0/test.py0000644000175000017500000000042711750740340027642 0ustar xavierxavier from test_utils import * import sys r1, r2 = ( client_server(r'../examples/corba/all_types/client', r'', r'../examples/corba/all_types/server', r''), local(r'../examples/corba/all_types/client', r'', args=['local'])) if not r1 or not r2: fail() polyorb-2.8~20110207.orig/testsuite/tests/examples/corba-all_types/ALL_TYPES_6/0000755000175000017500000000000011750740340026314 5ustar xavierxavierpolyorb-2.8~20110207.orig/testsuite/tests/examples/corba-all_types/ALL_TYPES_6/test.py0000644000175000017500000000054511750740340027651 0ustar xavierxavier from test_utils import * import sys r1, r2 = ( client_server( r'../examples/corba/all_types/client', r'giop_1_1.conf', r'../examples/corba/all_types/server', r'giop_1_1.conf'), local( r'../examples/corba/all_types/client', r'giop_1_1.conf', args=['local'])) if not r1 or not r2: fail() polyorb-2.8~20110207.orig/testsuite/tests/examples/corba-echo/0000755000175000017500000000000011750740340023415 5ustar xavierxavierpolyorb-2.8~20110207.orig/testsuite/tests/examples/corba-echo/ECHO_3/0000755000175000017500000000000011750740340024355 5ustar xavierxavierpolyorb-2.8~20110207.orig/testsuite/tests/examples/corba-echo/ECHO_3/test.py0000644000175000017500000000030011750740340025677 0ustar xavierxavier from test_utils import * import sys if not client_server(r'../examples/corba/echo/dynclient', r'soap.conf', r'../examples/corba/echo/server', r'soap.conf'): fail() polyorb-2.8~20110207.orig/testsuite/tests/examples/corba-echo/ECHO_6/0000755000175000017500000000000011750740340024360 5ustar xavierxavierpolyorb-2.8~20110207.orig/testsuite/tests/examples/corba-echo/ECHO_6/test.py0000644000175000017500000000030511750740340025707 0ustar xavierxavier from test_utils import * import sys if not client_server(r'../examples/corba/echo/client', r'giop_1_1.conf', r'../examples/corba/echo/server', r'giop_1_1.conf'): fail() polyorb-2.8~20110207.orig/testsuite/tests/examples/corba-echo/ECHO_4/0000755000175000017500000000000011750740340024356 5ustar xavierxavierpolyorb-2.8~20110207.orig/testsuite/tests/examples/corba-echo/ECHO_4/test.py0000644000175000017500000000026111750740340025706 0ustar xavierxavier from test_utils import * import sys if not client_server(r'../examples/corba/echo/dynclient', r'', r'../examples/corba/echo/dynserver', r''): fail() polyorb-2.8~20110207.orig/testsuite/tests/examples/corba-echo/ECHO_1/0000755000175000017500000000000011750740340024353 5ustar xavierxavierpolyorb-2.8~20110207.orig/testsuite/tests/examples/corba-echo/ECHO_1/test.py0000644000175000017500000000027511750740340025710 0ustar xavierxavier from test_utils import * import sys if not client_server(r'../examples/corba/echo/client', r'soap.conf', r'../examples/corba/echo/server', r'soap.conf'): fail() polyorb-2.8~20110207.orig/testsuite/tests/examples/corba-echo/ECHO_2/0000755000175000017500000000000011750740340024354 5ustar xavierxavierpolyorb-2.8~20110207.orig/testsuite/tests/examples/corba-echo/ECHO_2/test.py0000644000175000017500000000025611750740340025710 0ustar xavierxavier from test_utils import * import sys if not client_server(r'../examples/corba/echo/dynclient', r'', r'../examples/corba/echo/server', r''): fail() polyorb-2.8~20110207.orig/testsuite/tests/examples/corba-echo/ECHO_0/0000755000175000017500000000000011750740340024352 5ustar xavierxavierpolyorb-2.8~20110207.orig/testsuite/tests/examples/corba-echo/ECHO_0/test.py0000644000175000017500000000025311750740340025703 0ustar xavierxavier from test_utils import * import sys if not client_server(r'../examples/corba/echo/client', r'', r'../examples/corba/echo/server', r''): fail() polyorb-2.8~20110207.orig/testsuite/tests/examples/corba-echo/ECHO_5/0000755000175000017500000000000011750740340024357 5ustar xavierxavierpolyorb-2.8~20110207.orig/testsuite/tests/examples/corba-echo/ECHO_5/test.py0000644000175000017500000000030511750740340025706 0ustar xavierxavier from test_utils import * import sys if not client_server(r'../examples/corba/echo/client', r'giop_1_0.conf', r'../examples/corba/echo/server', r'giop_1_0.conf'): fail() polyorb-2.8~20110207.orig/testsuite/tests/examples/corba-echo/ECHO_7/0000755000175000017500000000000011750740340024361 5ustar xavierxavierpolyorb-2.8~20110207.orig/testsuite/tests/examples/corba-echo/ECHO_7/test.py0000644000175000017500000000030511750740340025710 0ustar xavierxavier from test_utils import * import sys if not client_server(r'../examples/corba/echo/client', r'giop_1_2.conf', r'../examples/corba/echo/server', r'giop_1_2.conf'): fail() polyorb-2.8~20110207.orig/testsuite/tests/examples/corba-all_functions/0000755000175000017500000000000011750740340025337 5ustar xavierxavierpolyorb-2.8~20110207.orig/testsuite/tests/examples/corba-all_functions/ALL_FUNCTIONS_6/0000755000175000017500000000000011750740340027624 5ustar xavierxavierpolyorb-2.8~20110207.orig/testsuite/tests/examples/corba-all_functions/ALL_FUNCTIONS_6/test.py0000644000175000017500000000032711750740340031157 0ustar xavierxavier from test_utils import * import sys if not client_server(r'../examples/corba/all_functions/client', r'giop_1_2.conf', r'../examples/corba/all_functions/server', r'giop_1_2.conf'): fail() polyorb-2.8~20110207.orig/testsuite/tests/examples/corba-all_functions/ALL_FUNCTIONS_3/0000755000175000017500000000000011750740340027621 5ustar xavierxavierpolyorb-2.8~20110207.orig/testsuite/tests/examples/corba-all_functions/ALL_FUNCTIONS_3/test.opt0000644000175000017500000000001211750740340031315 0ustar xavierxavierALL XFAIL polyorb-2.8~20110207.orig/testsuite/tests/examples/corba-all_functions/ALL_FUNCTIONS_3/test.py0000644000175000017500000000032211750740340031147 0ustar xavierxavier from test_utils import * import sys if not client_server(r'../examples/corba/all_functions/dynclient', r'soap.conf', r'../examples/corba/all_functions/server', r'soap.conf'): fail() polyorb-2.8~20110207.orig/testsuite/tests/examples/corba-all_functions/ALL_FUNCTIONS_5/0000755000175000017500000000000011750740340027623 5ustar xavierxavierpolyorb-2.8~20110207.orig/testsuite/tests/examples/corba-all_functions/ALL_FUNCTIONS_5/test.py0000644000175000017500000000032711750740340031156 0ustar xavierxavier from test_utils import * import sys if not client_server(r'../examples/corba/all_functions/client', r'giop_1_1.conf', r'../examples/corba/all_functions/server', r'giop_1_1.conf'): fail() polyorb-2.8~20110207.orig/testsuite/tests/examples/corba-all_functions/ALL_FUNCTIONS_4/0000755000175000017500000000000011750740340027622 5ustar xavierxavierpolyorb-2.8~20110207.orig/testsuite/tests/examples/corba-all_functions/ALL_FUNCTIONS_4/test.py0000644000175000017500000000032711750740340031155 0ustar xavierxavier from test_utils import * import sys if not client_server(r'../examples/corba/all_functions/client', r'giop_1_0.conf', r'../examples/corba/all_functions/server', r'giop_1_0.conf'): fail() polyorb-2.8~20110207.orig/testsuite/tests/examples/corba-all_functions/ALL_FUNCTIONS_1/0000755000175000017500000000000011750740340027617 5ustar xavierxavierpolyorb-2.8~20110207.orig/testsuite/tests/examples/corba-all_functions/ALL_FUNCTIONS_1/test.opt0000644000175000017500000000001211750740340031313 0ustar xavierxavierALL XFAIL polyorb-2.8~20110207.orig/testsuite/tests/examples/corba-all_functions/ALL_FUNCTIONS_1/test.py0000644000175000017500000000031711750740340031151 0ustar xavierxavier from test_utils import * import sys if not client_server(r'../examples/corba/all_functions/client', r'soap.conf', r'../examples/corba/all_functions/server', r'soap.conf'): fail() polyorb-2.8~20110207.orig/testsuite/tests/examples/corba-all_functions/ALL_FUNCTIONS_0/0000755000175000017500000000000011750740340027616 5ustar xavierxavierpolyorb-2.8~20110207.orig/testsuite/tests/examples/corba-all_functions/ALL_FUNCTIONS_0/test.py0000644000175000017500000000027511750740340031153 0ustar xavierxavier from test_utils import * import sys if not client_server(r'../examples/corba/all_functions/client', r'', r'../examples/corba/all_functions/server', r''): fail() polyorb-2.8~20110207.orig/testsuite/tests/examples/corba-all_functions/ALL_FUNCTIONS_2/0000755000175000017500000000000011750740340027620 5ustar xavierxavierpolyorb-2.8~20110207.orig/testsuite/tests/examples/corba-all_functions/ALL_FUNCTIONS_2/test.opt0000644000175000017500000000001211750740340031314 0ustar xavierxavierALL XFAIL polyorb-2.8~20110207.orig/testsuite/tests/examples/corba-all_functions/ALL_FUNCTIONS_2/test.py0000644000175000017500000000030011750740340031142 0ustar xavierxavier from test_utils import * import sys if not client_server(r'../examples/corba/all_functions/dynclient', r'', r'../examples/corba/all_functions/server', r''): fail() polyorb-2.8~20110207.orig/testsuite/tests/examples/polyorb/0000755000175000017500000000000011750740340023101 5ustar xavierxavierpolyorb-2.8~20110207.orig/testsuite/tests/examples/polyorb/POLYORB_CORE_0/0000755000175000017500000000000011750740340025256 5ustar xavierxavierpolyorb-2.8~20110207.orig/testsuite/tests/examples/polyorb/POLYORB_CORE_0/test.py0000644000175000017500000000016511750740340026611 0ustar xavierxavier from test_utils import * import sys if not local(r'../examples/polyorb/polyorb-test-no_tasking', r''): fail() polyorb-2.8~20110207.orig/testsuite/tests/examples/polyorb/POLYORB_CORE_1/0000755000175000017500000000000011750740340025257 5ustar xavierxavierpolyorb-2.8~20110207.orig/testsuite/tests/examples/polyorb/POLYORB_CORE_1/test.py0000644000175000017500000000017111750740340026607 0ustar xavierxavier from test_utils import * import sys if not local(r'../examples/polyorb/polyorb-test-no_tasking_poa', r''): fail() polyorb-2.8~20110207.orig/testsuite/tests/examples/polyorb/POLYORB_CORE_3/0000755000175000017500000000000011750740340025261 5ustar xavierxavierpolyorb-2.8~20110207.orig/testsuite/tests/examples/polyorb/POLYORB_CORE_3/test.py0000644000175000017500000000017211750740340026612 0ustar xavierxavier from test_utils import * import sys if not local(r'../examples/polyorb/polyorb-test-thread_pool_poa', r''): fail() polyorb-2.8~20110207.orig/testsuite/tests/examples/polyorb/POLYORB_CORE_2/0000755000175000017500000000000011750740340025260 5ustar xavierxavierpolyorb-2.8~20110207.orig/testsuite/tests/examples/polyorb/POLYORB_CORE_2/test.py0000644000175000017500000000016611750740340026614 0ustar xavierxavier from test_utils import * import sys if not local(r'../examples/polyorb/polyorb-test-thread_pool', r''): fail() polyorb-2.8~20110207.orig/testsuite/tests/examples/corba-random/0000755000175000017500000000000011750740340023757 5ustar xavierxavierpolyorb-2.8~20110207.orig/testsuite/tests/examples/corba-random/CORBA_RANDOM_1/0000755000175000017500000000000011750740340026065 5ustar xavierxavierpolyorb-2.8~20110207.orig/testsuite/tests/examples/corba-random/CORBA_RANDOM_1/test.py0000644000175000017500000000030111750740340027410 0ustar xavierxavier from test_utils import * import sys if not client_server(r'../examples/corba/random/client', r'soap.conf', r'../examples/corba/random/server', r'soap.conf'): fail() polyorb-2.8~20110207.orig/testsuite/tests/examples/corba-random/CORBA_RANDOM_0/0000755000175000017500000000000011750740340026064 5ustar xavierxavierpolyorb-2.8~20110207.orig/testsuite/tests/examples/corba-random/CORBA_RANDOM_0/test.py0000644000175000017500000000025711750740340027421 0ustar xavierxavier from test_utils import * import sys if not client_server(r'../examples/corba/random/client', r'', r'../examples/corba/random/server', r''): fail() polyorb-2.8~20110207.orig/testsuite/tests/examples/corba-secure_echo/0000755000175000017500000000000011750740340024763 5ustar xavierxavierpolyorb-2.8~20110207.orig/testsuite/tests/examples/corba-secure_echo/CORBA_SECURE_ECHO_1/0000755000175000017500000000000011750740340027675 5ustar xavierxavierpolyorb-2.8~20110207.orig/testsuite/tests/examples/corba-secure_echo/CORBA_SECURE_ECHO_1/test.opt0000644000175000017500000000001211750740340031371 0ustar xavierxavierALL XFAIL polyorb-2.8~20110207.orig/testsuite/tests/examples/corba-secure_echo/CORBA_SECURE_ECHO_1/test.py0000644000175000017500000000016311750740340031226 0ustar xavierxavier from test_utils import * import sys if not local(r'../examples/corba/secure_echo/tls_example', r''): fail() polyorb-2.8~20110207.orig/testsuite/tests/examples/corba-secure_echo/CORBA_SECURE_ECHO_0/0000755000175000017500000000000011750740340027674 5ustar xavierxavierpolyorb-2.8~20110207.orig/testsuite/tests/examples/corba-secure_echo/CORBA_SECURE_ECHO_0/test.opt0000644000175000017500000000001211750740340031370 0ustar xavierxavierALL XFAIL polyorb-2.8~20110207.orig/testsuite/tests/examples/corba-secure_echo/CORBA_SECURE_ECHO_0/test.py0000644000175000017500000000016511750740340031227 0ustar xavierxavier from test_utils import * import sys if not local(r'../examples/corba/secure_echo/gssup_example', r''): fail() polyorb-2.8~20110207.orig/testsuite/tests/examples/corba-secure_echo/CORBA_SECURE_ECHO_2/0000755000175000017500000000000011750740340027676 5ustar xavierxavierpolyorb-2.8~20110207.orig/testsuite/tests/examples/corba-secure_echo/CORBA_SECURE_ECHO_2/test.opt0000644000175000017500000000001211750740340031372 0ustar xavierxavierALL XFAIL polyorb-2.8~20110207.orig/testsuite/tests/examples/corba-secure_echo/CORBA_SECURE_ECHO_2/test.py0000644000175000017500000000017111750740340031226 0ustar xavierxavier from test_utils import * import sys if not local(r'../examples/corba/secure_echo/tls_gssup_example', r''): fail() polyorb-2.8~20110207.orig/testsuite/tests/examples/corba-rtcorba-server_declared/0000755000175000017500000000000011750740340027262 5ustar xavierxavier././@LongLink0000000000000000000000000000015400000000000011565 Lustar rootrootpolyorb-2.8~20110207.orig/testsuite/tests/examples/corba-rtcorba-server_declared/RTCORBA_SERVER_DECLARED_0/polyorb-2.8~20110207.orig/testsuite/tests/examples/corba-rtcorba-server_declared/RTCORBA_SERVER_DECL0000755000175000017500000000000011750740340032154 5ustar xavierxavier././@LongLink0000000000000000000000000000016300000000000011565 Lustar rootrootpolyorb-2.8~20110207.orig/testsuite/tests/examples/corba-rtcorba-server_declared/RTCORBA_SERVER_DECLARED_0/test.pypolyorb-2.8~20110207.orig/testsuite/tests/examples/corba-rtcorba-server_declared/RTCORBA_SERVER_DECL0000644000175000017500000000027611750740340032163 0ustar xavierxavier from test_utils import * import sys if not client_server(r'../examples/corba/echo/client', r'', r'../examples/corba/rtcorba/server_declared/server', r''): fail() ././@LongLink0000000000000000000000000000015400000000000011565 Lustar rootrootpolyorb-2.8~20110207.orig/testsuite/tests/examples/corba-rtcorba-server_declared/RTCORBA_SERVER_DECLARED_1/polyorb-2.8~20110207.orig/testsuite/tests/examples/corba-rtcorba-server_declared/RTCORBA_SERVER_DECL0000755000175000017500000000000011750740340032154 5ustar xavierxavier././@LongLink0000000000000000000000000000016300000000000011565 Lustar rootrootpolyorb-2.8~20110207.orig/testsuite/tests/examples/corba-rtcorba-server_declared/RTCORBA_SERVER_DECLARED_1/test.pypolyorb-2.8~20110207.orig/testsuite/tests/examples/corba-rtcorba-server_declared/RTCORBA_SERVER_DECL0000644000175000017500000000032111750740340032152 0ustar xavierxavier from test_utils import * import sys if not client_server(r'../examples/corba/rtcorba/server_declared/client', r'', r'../examples/corba/rtcorba/server_declared/server', r''): fail() polyorb-2.8~20110207.orig/testsuite/tests/examples/corba-rtcorba-dhb/0000755000175000017500000000000011750740340024666 5ustar xavierxavierpolyorb-2.8~20110207.orig/testsuite/tests/examples/corba-rtcorba-dhb/RTCORBA_DHB_0/0000755000175000017500000000000011750740340026656 5ustar xavierxavierpolyorb-2.8~20110207.orig/testsuite/tests/examples/corba-rtcorba-dhb/RTCORBA_DHB_0/test.opt0000644000175000017500000000001211750740340030352 0ustar xavierxavierALL XFAIL polyorb-2.8~20110207.orig/testsuite/tests/examples/corba-rtcorba-dhb/RTCORBA_DHB_0/test.py0000644000175000017500000000032311750740340030205 0ustar xavierxavier from test_utils import * import sys if not client_server(r'../examples/corba/rtcorba/dhb/rtcorba_iiop_client', r'', r'../examples/corba/rtcorba/dhb/rtcorba_iiop_server', r''): fail() polyorb-2.8~20110207.orig/testsuite/tests/examples/corba-rtcorba-rtcosscheduling/0000755000175000017500000000000011750740340027331 5ustar xavierxavier././@LongLink0000000000000000000000000000015400000000000011565 Lustar rootrootpolyorb-2.8~20110207.orig/testsuite/tests/examples/corba-rtcorba-rtcosscheduling/RTCORBA_RTCOSSCHEDULING_0/polyorb-2.8~20110207.orig/testsuite/tests/examples/corba-rtcorba-rtcosscheduling/RTCORBA_RTCOSSCHEDU0000755000175000017500000000000011750740340032214 5ustar xavierxavier././@LongLink0000000000000000000000000000016400000000000011566 Lustar rootrootpolyorb-2.8~20110207.orig/testsuite/tests/examples/corba-rtcorba-rtcosscheduling/RTCORBA_RTCOSSCHEDULING_0/test.optpolyorb-2.8~20110207.orig/testsuite/tests/examples/corba-rtcorba-rtcosscheduling/RTCORBA_RTCOSSCHEDU0000644000175000017500000000001211750740340032207 0ustar xavierxavierALL XFAIL ././@LongLink0000000000000000000000000000016300000000000011565 Lustar rootrootpolyorb-2.8~20110207.orig/testsuite/tests/examples/corba-rtcorba-rtcosscheduling/RTCORBA_RTCOSSCHEDULING_0/test.pypolyorb-2.8~20110207.orig/testsuite/tests/examples/corba-rtcorba-rtcosscheduling/RTCORBA_RTCOSSCHEDU0000644000175000017500000000032111750740340032212 0ustar xavierxavier from test_utils import * import sys if not client_server(r'../examples/corba/rtcorba/rtcosscheduling/client', r'', r'../examples/corba/rtcorba/rtcosscheduling/server', r''): fail() polyorb-2.8~20110207.orig/testsuite/tests/test_utils.py0000644000175000017500000001525611750740340022357 0ustar xavierxavier#!/usr/bin/env python """test utils This module is imported by all testcase. It parse the command lines options and provide some useful functions. You should never call this module directly. To run a single testcase, use ./testsuite.py NAME_OF_TESTCASE """ from gnatpython.env import Env from gnatpython.ex import Run, STDOUT from gnatpython.fileutils import FileUtilsError, mkdir from subprocess import Popen, PIPE import os import re import sys POLYORB_CONF = "POLYORB_CONF" RLIMIT = int(os.environ['RLIMIT']) TEST_NAME = os.environ['TEST_NAME'] # Restore testsuite environment Env().restore(os.environ['TEST_CONFIG']) # If POLYORB_TEST_VERBOSE is set to true, then output more data VERBOSE = Env().options.verbose # set by testsuite.py # All executable tests path are relative to PolyORB testsuite dir BASE_DIR = os.path.join(Env().options.build_dir, 'testsuite') # Conf dir are in tests/conf CONF_DIR = os.path.join(Env().options.testsuite_src_dir, 'tests', 'confs') EXE_EXT = Env().target.os.exeext OUTPUT_FILENAME = os.path.join(Env().log_dir, TEST_NAME) try: if not os.path.isdir(os.path.dirname(OUTPUT_FILENAME)): mkdir(os.path.dirname(OUTPUT_FILENAME)) except FileUtilsError: # Ignore errors, multiple tests can be run in parallel pass def assert_exists(filename): """Assert that the given filename exists""" assert os.path.exists(filename), "%s not found" % filename def terminate(handle): """Terminate safely a process spawned using Popen""" if sys.platform.startswith('win'): try: handle.terminate() except WindowsError: # We got a WindowsError exception. This might occurs when we try to # terminate a process that is already dead. In that case we check # if the process is still alive. If yes we reraise the exception. # Otherwise we ignore it. if handle.poll() is None: # Process is still not terminated so reraise the exception raise else: handle.terminate() def client_server(client_cmd, client_conf, server_cmd, server_conf): """Run a client server testcase Run server_cmd and extract the IOR string. Run client_cmd with the server IOR string Check for "END TESTS................ PASSED" if found return True """ print "Running client %s (config=%s)\nserver %s (config=%s)" % ( client_cmd, client_conf, server_cmd, server_conf) client = os.path.join(BASE_DIR, client_cmd + EXE_EXT) server = os.path.join(BASE_DIR, server_cmd + EXE_EXT) # Check that files exist assert_exists(client) assert_exists(server) for conf_file in (server_conf, client_conf): if conf_file: assert_exists(os.path.join(CONF_DIR, conf_file)) server_env = os.environ.copy() if server_conf: server_env[POLYORB_CONF] = os.path.join(CONF_DIR, server_conf) try: # Run the server command and retrieve the IOR string p_cmd_server = ['rlimit', str(RLIMIT), server] server_handle = Popen(p_cmd_server, stdout=PIPE, env=server_env) if VERBOSE: print 'RUN: POLYORB_CONF=%s %s' % \ (server_conf, " ".join(p_cmd_server)) while True: line = server_handle.stdout.readline() if "IOR:" in line: IOR_str = re.match(r".*(IOR:[a-z0-9]+)['|\n\r]", line).groups()[0] break # Remove eol and ' IOR_str = IOR_str.strip() print IOR_str # Run the client with the IOR argument p_cmd_client = [client, IOR_str] if client_conf: client_env = os.environ.copy() client_env[POLYORB_CONF] = os.path.join(CONF_DIR, client_conf) print 'RUN: POLYORB_CONF=%s %s' % \ (client_conf, " ".join(p_cmd_client)) else: client_env = None print "RUN: %s" % " ".join(p_cmd_client) Run(make_run_cmd([client, IOR_str], Env().options.coverage), output=OUTPUT_FILENAME + 'server', error=STDOUT, timeout=RLIMIT, env=client_env) for elmt in [client, server]: if Env().options.coverage: run_coverage_analysis(elmt) except Exception, e: print e finally: terminate(server_handle) return _check_output(OUTPUT_FILENAME + 'server', 'server') def local(cmd, config_file, args=None): """Run a local test Execute the given command. Check for "END TESTS................ PASSED" if found return True PARAMETERS: cmd: the command to execute config_file: to set POLYORB_CONF args: list of additional parameters """ args = args or [] print "Running %s %s (config=%s)" % (cmd, " ".join(args), config_file) if config_file: assert_exists(os.path.join(CONF_DIR, config_file)) os.environ[POLYORB_CONF] = config_file command = os.path.join(BASE_DIR, cmd + EXE_EXT) assert_exists(command) p_cmd = [command] + args if VERBOSE: if config_file: print 'RUN: POLYORB_CONF=%s %s' % (config_file, " ".join(p_cmd)) else: print 'RUN: %s' % " ".join(p_cmd) Run(make_run_cmd(p_cmd, Env().options.coverage), output=OUTPUT_FILENAME + 'local', error=STDOUT, timeout=RLIMIT) if Env().options.coverage: run_coverage_analysis(command) return _check_output(OUTPUT_FILENAME + 'local', 'local') def _check_output(output_file, test_name): """Check that END TESTS....... PASSED is contained in the output""" if os.path.exists(output_file): test_outfile = open(output_file) test_out = test_outfile.read() test_outfile.close() if re.search(r"END TESTS.*PASSED", test_out): print "%s PASSED" % test_name return True else: print test_out return False def make_run_cmd(cmd, coverage=False): """Create a command line for Run in function of coverage Returns command and arguments list """ L = [] if coverage: L.extend(['xcov', '--run', '--target=i386-linux', '-o', cmd[0] + '.trace', cmd[0]]) if len(cmd) > 1: L.append('-eargs') L.extend(cmd[1:]) else: L.extend(cmd) return L def run_coverage_analysis(command): """Run xcov with appropriate arguments to retrieve coverage information Returns an object of type run """ return Run(['xcov', '--coverage=branch', '--annotate=report', command + ".trace"], output=OUTPUT_FILENAME + '.trace', error=STDOUT, timeout=RLIMIT) def fail(): print "TEST FAILED" sys.exit(1) polyorb-2.8~20110207.orig/testsuite/tests/cos/0000755000175000017500000000000011750740340020361 5ustar xavierxavierpolyorb-2.8~20110207.orig/testsuite/tests/cos/ir/0000755000175000017500000000000011750740340020773 5ustar xavierxavierpolyorb-2.8~20110207.orig/testsuite/tests/cos/ir/IR_0/0000755000175000017500000000000011750740340021524 5ustar xavierxavierpolyorb-2.8~20110207.orig/testsuite/tests/cos/ir/IR_0/test.py0000644000175000017500000000022711750740340023056 0ustar xavierxavier from test_utils import * import sys if not client_server(r'corba/cos/ir/client', r'', r'corba/cos/ir/server', r''): fail() polyorb-2.8~20110207.orig/testsuite/tests/cos/naming/0000755000175000017500000000000011750740340021632 5ustar xavierxavierpolyorb-2.8~20110207.orig/testsuite/tests/cos/naming/NAMING_0/0000755000175000017500000000000011750740340023022 5ustar xavierxavierpolyorb-2.8~20110207.orig/testsuite/tests/cos/naming/NAMING_0/test.py0000644000175000017500000000026711750740340024360 0ustar xavierxavier from test_utils import * import sys if not client_server(r'corba/cos/naming/test_naming_corba', r'', r'../tools/po_cos_naming/po_cos_naming', r''): fail() polyorb-2.8~20110207.orig/testsuite/tests/cos/time/0000755000175000017500000000000011750740340021317 5ustar xavierxavierpolyorb-2.8~20110207.orig/testsuite/tests/cos/time/TIME_0/0000755000175000017500000000000011750740340022274 5ustar xavierxavierpolyorb-2.8~20110207.orig/testsuite/tests/cos/time/TIME_0/test.py0000644000175000017500000000014211750740340023622 0ustar xavierxavier from test_utils import * import sys if not local(r'corba/cos/time/test_time', r''): fail() polyorb-2.8~20110207.orig/testsuite/tests/core/0000755000175000017500000000000011750740340020525 5ustar xavierxavierpolyorb-2.8~20110207.orig/testsuite/tests/core/obj_adapters/0000755000175000017500000000000011750740340023162 5ustar xavierxavierpolyorb-2.8~20110207.orig/testsuite/tests/core/obj_adapters/OA_0/0000755000175000017500000000000011750740340023700 5ustar xavierxavierpolyorb-2.8~20110207.orig/testsuite/tests/core/obj_adapters/OA_0/test.py0000644000175000017500000000014311750740340025227 0ustar xavierxavier from test_utils import * import sys if not local(r'core/obj_adapters/test000', r''): fail() polyorb-2.8~20110207.orig/testsuite/tests/core/obj_adapters/OA_1/0000755000175000017500000000000011750740340023701 5ustar xavierxavierpolyorb-2.8~20110207.orig/testsuite/tests/core/obj_adapters/OA_1/test.py0000644000175000017500000000014311750740340025230 0ustar xavierxavier from test_utils import * import sys if not local(r'core/obj_adapters/test001', r''): fail() polyorb-2.8~20110207.orig/testsuite/tests/core/fixed_point/0000755000175000017500000000000011750740340023035 5ustar xavierxavierpolyorb-2.8~20110207.orig/testsuite/tests/core/fixed_point/FIXED_0/0000755000175000017500000000000011750740340024113 5ustar xavierxavierpolyorb-2.8~20110207.orig/testsuite/tests/core/fixed_point/FIXED_0/test.py0000644000175000017500000000014211750740340025441 0ustar xavierxavier from test_utils import * import sys if not local(r'core/fixed_point/test000', r''): fail() polyorb-2.8~20110207.orig/testsuite/tests/core/tasking/0000755000175000017500000000000011750740340022165 5ustar xavierxavierpolyorb-2.8~20110207.orig/testsuite/tests/core/tasking/TASK_3/0000755000175000017500000000000011750740340023151 5ustar xavierxavierpolyorb-2.8~20110207.orig/testsuite/tests/core/tasking/TASK_3/test.py0000644000175000017500000000013611750740340024502 0ustar xavierxavier from test_utils import * import sys if not local(r'core/tasking/test003', r''): fail() polyorb-2.8~20110207.orig/testsuite/tests/core/tasking/TASK_2/0000755000175000017500000000000011750740340023150 5ustar xavierxavierpolyorb-2.8~20110207.orig/testsuite/tests/core/tasking/TASK_2/test.py0000644000175000017500000000013611750740340024501 0ustar xavierxavier from test_utils import * import sys if not local(r'core/tasking/test002', r''): fail() polyorb-2.8~20110207.orig/testsuite/tests/core/tasking/TASK_1/0000755000175000017500000000000011750740340023147 5ustar xavierxavierpolyorb-2.8~20110207.orig/testsuite/tests/core/tasking/TASK_1/test.py0000644000175000017500000000013611750740340024500 0ustar xavierxavier from test_utils import * import sys if not local(r'core/tasking/test001', r''): fail() polyorb-2.8~20110207.orig/testsuite/tests/core/tasking/TASK_0/0000755000175000017500000000000011750740340023146 5ustar xavierxavierpolyorb-2.8~20110207.orig/testsuite/tests/core/tasking/TASK_0/test.py0000644000175000017500000000013611750740340024477 0ustar xavierxavier from test_utils import * import sys if not local(r'core/tasking/test000', r''): fail() polyorb-2.8~20110207.orig/testsuite/tests/core/poa/0000755000175000017500000000000011750740340021304 5ustar xavierxavierpolyorb-2.8~20110207.orig/testsuite/tests/core/poa/POA_0/0000755000175000017500000000000011750740340022142 5ustar xavierxavierpolyorb-2.8~20110207.orig/testsuite/tests/core/poa/POA_0/test.py0000644000175000017500000000013211750740340023467 0ustar xavierxavier from test_utils import * import sys if not local(r'core/poa/test000', r''): fail() polyorb-2.8~20110207.orig/testsuite/tests/core/random/0000755000175000017500000000000011750740340022005 5ustar xavierxavierpolyorb-2.8~20110207.orig/testsuite/tests/core/random/RANDOM_0/0000755000175000017500000000000011750740340023204 5ustar xavierxavierpolyorb-2.8~20110207.orig/testsuite/tests/core/random/RANDOM_0/test.py0000644000175000017500000000013511750740340024534 0ustar xavierxavier from test_utils import * import sys if not local(r'core/random/test000', r''): fail() polyorb-2.8~20110207.orig/testsuite/tests/core/chained_lists/0000755000175000017500000000000011750740340023336 5ustar xavierxavierpolyorb-2.8~20110207.orig/testsuite/tests/core/chained_lists/CHAINED_LIST_0/0000755000175000017500000000000011750740340025443 5ustar xavierxavierpolyorb-2.8~20110207.orig/testsuite/tests/core/chained_lists/CHAINED_LIST_0/test.py0000644000175000017500000000014411750740340026773 0ustar xavierxavier from test_utils import * import sys if not local(r'core/chained_lists/test000', r''): fail() polyorb-2.8~20110207.orig/testsuite/tests/core/initialization/0000755000175000017500000000000011750740340023554 5ustar xavierxavierpolyorb-2.8~20110207.orig/testsuite/tests/core/initialization/INIT_4/0000755000175000017500000000000011750740340024542 5ustar xavierxavierpolyorb-2.8~20110207.orig/testsuite/tests/core/initialization/INIT_4/test.py0000644000175000017500000000014511750740340026073 0ustar xavierxavier from test_utils import * import sys if not local(r'core/initialization/test004', r''): fail() polyorb-2.8~20110207.orig/testsuite/tests/core/initialization/INIT_0/0000755000175000017500000000000011750740340024536 5ustar xavierxavierpolyorb-2.8~20110207.orig/testsuite/tests/core/initialization/INIT_0/test.py0000644000175000017500000000014511750740340026067 0ustar xavierxavier from test_utils import * import sys if not local(r'core/initialization/test000', r''): fail() polyorb-2.8~20110207.orig/testsuite/tests/core/initialization/INIT_2/0000755000175000017500000000000011750740340024540 5ustar xavierxavierpolyorb-2.8~20110207.orig/testsuite/tests/core/initialization/INIT_2/test.py0000644000175000017500000000014511750740340026071 0ustar xavierxavier from test_utils import * import sys if not local(r'core/initialization/test002', r''): fail() polyorb-2.8~20110207.orig/testsuite/tests/core/initialization/INIT_3/0000755000175000017500000000000011750740340024541 5ustar xavierxavierpolyorb-2.8~20110207.orig/testsuite/tests/core/initialization/INIT_3/test.py0000644000175000017500000000014511750740340026072 0ustar xavierxavier from test_utils import * import sys if not local(r'core/initialization/test003', r''): fail() polyorb-2.8~20110207.orig/testsuite/tests/core/initialization/INIT_1/0000755000175000017500000000000011750740340024537 5ustar xavierxavierpolyorb-2.8~20110207.orig/testsuite/tests/core/initialization/INIT_1/test.py0000644000175000017500000000014511750740340026070 0ustar xavierxavier from test_utils import * import sys if not local(r'core/initialization/test001', r''): fail() polyorb-2.8~20110207.orig/testsuite/tests/core/uri_encoding/0000755000175000017500000000000011750740340023172 5ustar xavierxavierpolyorb-2.8~20110207.orig/testsuite/tests/core/uri_encoding/URI_ENCODING_0/0000755000175000017500000000000011750740340025316 5ustar xavierxavierpolyorb-2.8~20110207.orig/testsuite/tests/core/uri_encoding/URI_ENCODING_0/test.py0000644000175000017500000000014311750740340026645 0ustar xavierxavier from test_utils import * import sys if not local(r'core/uri_encoding/test000', r''): fail() polyorb-2.8~20110207.orig/testsuite/tests/core/dynamic_dict/0000755000175000017500000000000011750740340023154 5ustar xavierxavierpolyorb-2.8~20110207.orig/testsuite/tests/core/dynamic_dict/DYNAMIC_DICT_0/0000755000175000017500000000000011750740340025262 5ustar xavierxavierpolyorb-2.8~20110207.orig/testsuite/tests/core/dynamic_dict/DYNAMIC_DICT_0/test.py0000644000175000017500000000014311750740340026611 0ustar xavierxavier from test_utils import * import sys if not local(r'core/dynamic_dict/test000', r''): fail() polyorb-2.8~20110207.orig/testsuite/tests/core/sync_policies/0000755000175000017500000000000011750740340023370 5ustar xavierxavierpolyorb-2.8~20110207.orig/testsuite/tests/core/sync_policies/CORE_SYNC_POLICIES_0/0000755000175000017500000000000011750740340026462 5ustar xavierxavierpolyorb-2.8~20110207.orig/testsuite/tests/core/sync_policies/CORE_SYNC_POLICIES_0/test.py0000644000175000017500000000025611750740340030016 0ustar xavierxavier from test_utils import * import sys if not client_server(r'core/sync_policies/client', r'', r'core/sync_policies/server_no_tasking', r''): fail() polyorb-2.8~20110207.orig/testsuite/tests/always_fail/0000755000175000017500000000000011750740340022070 5ustar xavierxavierpolyorb-2.8~20110207.orig/testsuite/tests/always_fail/test.opt0000644000175000017500000000001211750740340023564 0ustar xavierxavierALL XFAIL polyorb-2.8~20110207.orig/testsuite/tests/always_fail/test.py0000644000175000017500000000017311750740340023422 0ustar xavierxavierfrom test_utils import * import sys local(os.path.join(os.path.pardir, 'polyorb-config'), '', args=['--version']) fail() polyorb-2.8~20110207.orig/testsuite/tests/run-test.py0000644000175000017500000000375611750740340021743 0ustar xavierxavier#!/usr/bin/env python """Usage: run-test [options] test_dir Run a test located in test_dir """ from gnatpython.main import Main from gnatpython.testdriver import TestRunner, add_run_test_options import os import sys class TestPolyORB(TestRunner): def compute_cmd_line(self, filesize_limit=36000): """Compute command line Increase maximum execution time (the original max execution time is used by the test to run the server process, wait 10 more seconds to allow the server process to be killed). """ # Pass original max execution time to the test os.environ["RLIMIT"] = self.opt_results['RLIMIT'] os.environ["TEST_NAME"] = self.test # And add 10 more seconds for rlimit self.opt_results["RLIMIT"] = str(int(self.opt_results['RLIMIT']) + 10) return TestRunner.compute_cmd_line(self, filesize_limit) def apply_output_filter(self, str_list): """Check that at least a server or local test has passed Failed if test_utils.fail() has been called ("TEST FAILED" written) """ if str_list and 'TEST FAILED' in str_list: return str_list if 'server PASSED' in str_list or 'local PASSED' in str_list: # Test ok return [] else: # No PASSED ! return str_list def main(): """Run a test""" m = Main(add_targets_options=True) add_run_test_options(m) m.parse_args() if not m.args: sys.exit("Error: 1 argument expected. See -h") if m.options.restricted_discs is not None: m.options.restricted_discs = m.options.restricted_discs.split(',') t = TestPolyORB( m.args[0], m.options.discs, m.options.output_dir, m.options.tmp, m.options.enable_cleanup, m.options.restricted_discs, len(m.args) > 1 and m.args[1:] or None, m.options.failed_only, m.options.timeout) t.execute() if __name__ == '__main__': main() polyorb-2.8~20110207.orig/testsuite/core/0000755000175000017500000000000011750740340017363 5ustar xavierxavierpolyorb-2.8~20110207.orig/testsuite/core/obj_adapters/0000755000175000017500000000000011750740340022020 5ustar xavierxavierpolyorb-2.8~20110207.orig/testsuite/core/obj_adapters/Makefile.local0000644000175000017500000000000011750740340024537 0ustar xavierxavierpolyorb-2.8~20110207.orig/testsuite/core/obj_adapters/test_servant.adb0000644000175000017500000001220611750740340025212 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- T E S T _ S E R V A N T -- -- -- -- B o d y -- -- -- -- Copyright (C) 2003-2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with PolyORB.Any; with PolyORB.Any.NVList; with PolyORB.Obj_Adapters; package body Test_Servant is use PolyORB.Any; use PolyORB.Requests; use PolyORB.Types; function echoInteger (O : My_Servant; I : PolyORB.Types.Long) return PolyORB.Types.Long; -- Actual function implemented by the servant. function Get_Parameter_Profile (Method : String) return PolyORB.Any.NVList.Ref; function Get_Result_Profile (Method : String) return PolyORB.Any.Any; -- Accessors to servant interface. ----------------- -- echoInteger -- ----------------- function echoInteger (O : My_Servant; I : PolyORB.Types.Long) return PolyORB.Types.Long is pragma Warnings (Off); pragma Unreferenced (O); pragma Warnings (On); begin return I; end echoInteger; --------------------- -- Execute_Servant -- --------------------- function Execute_Servant (S : not null access My_Servant; Req : PolyORB.Requests.Request_Access) return Boolean is use PolyORB.Any.NVList; use PolyORB.Any.NVList.Internals; use PolyORB.Any.NVList.Internals.NV_Lists; begin if Req.Operation.all = "echoInteger" then declare echoInteger_Arg : constant PolyORB.Types.Long := From_Any (Value (First (List_Of (Req.Args).all)).Argument); begin Req.Result.Argument := To_Any (echoInteger (S.all, echoInteger_Arg)); end; else raise Program_Error; end if; return True; end Execute_Servant; --------------------------- -- Get_Parameter_Profile -- --------------------------- function Get_Parameter_Profile (Method : String) return PolyORB.Any.NVList.Ref is Result : PolyORB.Any.NVList.Ref; begin PolyORB.Any.NVList.Create (Result); if Method = "echoInteger" then PolyORB.Any.NVList.Add_Item (Result, (Name => To_PolyORB_String ("I"), Argument => Get_Empty_Any (TypeCode.TC_Long), Arg_Modes => ARG_IN)); else raise Program_Error; end if; return Result; end Get_Parameter_Profile; ------------------------ -- Get_Result_Profile -- ------------------------ function Get_Result_Profile (Method : String) return PolyORB.Any.Any is begin if Method = "echoInteger" then return PolyORB.Any.Get_Empty_Any (TypeCode.TC_Long); else raise Program_Error; end if; end Get_Result_Profile; ------------- -- If_Desc -- ------------- function If_Desc return PolyORB.Obj_Adapters.Simple.Interface_Description is begin return (PP_Desc => Get_Parameter_Profile'Access, RP_Desc => Get_Result_Profile'Access); end If_Desc; --------- -- "=" -- --------- function "=" (Left, Right : My_Servant) return Standard.Boolean is begin if Left.Nb = Right.Nb and then Left.Name = Right.Name then return True; end if; return False; end "="; end Test_Servant; polyorb-2.8~20110207.orig/testsuite/core/obj_adapters/test_common.adb0000644000175000017500000001017711750740340025025 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- T E S T _ C O M M O N -- -- -- -- B o d y -- -- -- -- Copyright (C) 2003-2005 Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with PolyORB.Errors; with PolyORB.Objects; with PolyORB.References.IOR; with PolyORB.Servants; with PolyORB.Setup; with PolyORB.Types; with PolyORB.ORB; with PolyORB.Utils.Report; with Test_Servant; package body Test_Common is use PolyORB.Errors; use PolyORB.Objects; use PolyORB.ORB; use PolyORB.Setup; use PolyORB.Types; use PolyORB.Utils.Report; use Test_Servant; -------------------- -- Test_Simple_OA -- -------------------- procedure Test_Simple_OA (Obj_Adapter : PolyORB.Obj_Adapters.Obj_Adapter_Access) is S1 : My_Servant_Access; My_Id : Object_Id_Access; My_Ref : PolyORB.References.Ref; Error : Error_Container; begin -- Create object adapter. PolyORB.Obj_Adapters.Create (Obj_Adapter); -- Link object adapter with ORB. Set_Object_Adapter (The_ORB, Obj_Adapter); Output ("Created Object Adapter", True); -- Create Servant. S1 := new My_Servant; S1.Nb := 1; S1.Name := To_PolyORB_String ("Servant1"); Output ("Servant Created", True); PolyORB.Obj_Adapters.Export (Obj_Adapter, PolyORB.Servants.Servant_Access (S1), null, My_Id, Error); -- Register it with the SOA. if Found (Error) then raise Program_Error; end if; Create_Reference (The_ORB, My_Id, "POLYORB:TEST_SERVANT:1.0", My_Ref); -- Obtain object reference. Output ("Registered object", True); declare IOR : constant String := PolyORB.References.IOR.Object_To_String (My_Ref); pragma Warnings (Off); pragma Unreferenced (IOR); pragma Warnings (On); begin Output ("IOR created", True); end; PolyORB.Obj_Adapters.Unexport (Obj_Adapter, My_Id, Error); if Found (Error) then raise Program_Error; end if; Output ("Unregistered object", True); -- Destroy object adapter PolyORB.Obj_Adapters.Destroy (Obj_Adapter); Output ("Destroyed Object Adapter", True); end Test_Simple_OA; end Test_Common; polyorb-2.8~20110207.orig/testsuite/core/obj_adapters/test000.adb0000644000175000017500000000564111750740340023675 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- T E S T 0 0 0 -- -- -- -- B o d y -- -- -- -- Copyright (C) 2003-2005 Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with Ada.Exceptions; with Ada.Text_IO; with PolyORB.Initialization; with PolyORB.Utils.Report; with PolyORB.ORB.No_Tasking; pragma Warnings (Off, PolyORB.ORB.No_Tasking); with PolyORB.ORB_Controller.Workers; pragma Warnings (Off, PolyORB.ORB_Controller.Workers); with PolyORB.Setup.Tasking.No_Tasking; pragma Warnings (Off, PolyORB.Setup.Tasking.No_Tasking); with PolyORB.Obj_Adapters.Simple; -- OA to be tested with Test_Common; procedure Test000 is use Ada.Text_IO; use Ada.Exceptions; use PolyORB.Obj_Adapters.Simple; begin PolyORB.Initialization.Initialize_World; Test_Common.Test_Simple_OA (new Simple_Obj_Adapter); PolyORB.Utils.Report.End_Report; exception when E : others => Put_Line ("Got exception " & Exception_Name (E) & " : " & Exception_Message (E)); PolyORB.Utils.Report.Output ("END TESTS", False); end Test000; polyorb-2.8~20110207.orig/testsuite/core/obj_adapters/test001.adb0000644000175000017500000000603611750740340023675 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- T E S T 0 0 1 -- -- -- -- B o d y -- -- -- -- Copyright (C) 2003-2005 Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with Ada.Exceptions; with Ada.Text_IO; with PolyORB.Initialization; with PolyORB.Utils.Report; with PolyORB.ORB.No_Tasking; pragma Warnings (Off, PolyORB.ORB.No_Tasking); with PolyORB.ORB_Controller.Workers; pragma Warnings (Off, PolyORB.ORB_Controller.Workers); with PolyORB.Setup.Tasking.No_Tasking; pragma Warnings (Off, PolyORB.Setup.Tasking.No_Tasking); with PolyORB.POA.Basic_POA; with PolyORB.POA_Config.Root_POA; -- OA to be tested with Test_Common; procedure Test001 is use Ada.Text_IO; use Ada.Exceptions; use PolyORB.POA.Basic_POA; begin PolyORB.Initialization.Initialize_World; PolyORB.POA_Config.Set_Configuration (new PolyORB.POA_Config.Root_POA.Root_POA_Configuration); Test_Common.Test_Simple_OA (new Basic_Obj_Adapter); PolyORB.Utils.Report.End_Report; exception when E : others => Put_Line ("Got exception " & Exception_Name (E) & " : " & Exception_Message (E)); PolyORB.Utils.Report.Output ("END TESTS", False); end Test001; polyorb-2.8~20110207.orig/testsuite/core/obj_adapters/test_servant.ads0000644000175000017500000000524511750740340025240 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- T E S T _ S E R V A N T -- -- -- -- S p e c -- -- -- -- Copyright (C) 2003-2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with PolyORB.Servants; with PolyORB.Types; with PolyORB.Obj_Adapters.Simple; with PolyORB.Requests; package Test_Servant is type My_Servant is new PolyORB.Servants.Servant with record Nb : Integer; Name : PolyORB.Types.String; end record; type My_Servant_Access is access all My_Servant; overriding function Execute_Servant (S : not null access My_Servant; Req : PolyORB.Requests.Request_Access) return Boolean; function If_Desc return PolyORB.Obj_Adapters.Simple.Interface_Description; pragma Inline (If_Desc); function "=" (Left, Right : My_Servant) return Standard.Boolean; end Test_Servant; polyorb-2.8~20110207.orig/testsuite/core/obj_adapters/local.gpr0000644000175000017500000000070411750740340023625 0ustar xavierxavierwith "polyorb", "polyorb_test_common"; project local is Dir := external ("Test_Dir"); Obj_Dir := PolyORB_Test_Common.Build_Dir & Dir; for Object_Dir use Obj_Dir; for Source_Dirs use (Obj_Dir, PolyORB_Test_Common.Source_Dir & Dir); package Compiler is for Default_Switches ("Ada") use PolyORB_Test_Common.Compiler'Default_Switches ("Ada"); end Compiler; for Main use ("test000.adb", "test001.adb"); end local; polyorb-2.8~20110207.orig/testsuite/core/obj_adapters/test_common.ads0000644000175000017500000000424711750740340025047 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- T E S T _ C O M M O N -- -- -- -- S p e c -- -- -- -- Copyright (C) 2003 Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by ACT Europe. -- -- (email: sales@act-europe.fr) -- -- -- ------------------------------------------------------------------------------ with PolyORB.Obj_Adapters; package Test_Common is procedure Test_Simple_OA (Obj_Adapter : PolyORB.Obj_Adapters.Obj_Adapter_Access); end Test_Common; polyorb-2.8~20110207.orig/testsuite/core/fixed_point/0000755000175000017500000000000011750740340021673 5ustar xavierxavierpolyorb-2.8~20110207.orig/testsuite/core/fixed_point/Makefile.local0000644000175000017500000000000011750740340024412 0ustar xavierxavierpolyorb-2.8~20110207.orig/testsuite/core/fixed_point/test000.adb0000644000175000017500000000635711750740340023555 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- T E S T 0 0 0 -- -- -- -- B o d y -- -- -- -- Copyright (C) 2002-2003 Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by ACT Europe. -- -- (email: sales@act-europe.fr) -- -- -- ------------------------------------------------------------------------------ with Ada.Exceptions; with PolyORB.Fixed_Point; use PolyORB.Fixed_Point; with Ada.Text_IO; use Ada.Text_IO; with PolyORB.Utils.Report; use PolyORB.Utils.Report; procedure Test000 is type Megabucks is delta 0.01 digits 15; package Megabucks_Conv is new PolyORB.Fixed_Point.Fixed_Point_Conversion (Megabucks); use Megabucks_Conv; Values : constant array (Integer range <>) of Megabucks := (0.0, 0.01, 0.05, 1.23, -1.0, 12345.67, 123456.78, -0.01, 9999.99, 99999.99); Hex_Digit : constant array (Nibble) of Character := "0123456789abcdef"; begin for I in Values'Range loop begin declare R : constant Nibbles := Fixed_To_Nibbles (Values (I)); begin Put (Values (I)'Img & " ->"); for J in R'Range loop Put (" " & Hex_Digit (R (J))); end loop; Put_Line (""); Output ("test " & Megabucks'Image (Values (I)), Values (I) = Nibbles_To_Fixed (R)); end; exception when E : others => Put_Line (Ada.Exceptions.Exception_Information (E)); Output ("test " & Megabucks'Image (Values (I)), False); end; end loop; End_Report; end Test000; polyorb-2.8~20110207.orig/testsuite/core/fixed_point/local.gpr0000644000175000017500000000066511750740340023506 0ustar xavierxavierwith "polyorb", "polyorb_test_common"; project local is Dir := external ("Test_Dir"); Obj_Dir := PolyORB_Test_Common.Build_Dir & Dir; for Object_Dir use Obj_Dir; for Source_Dirs use (Obj_Dir, PolyORB_Test_Common.Source_Dir & Dir); package Compiler is for Default_Switches ("Ada") use PolyORB_Test_Common.Compiler'Default_Switches ("Ada"); end Compiler; for Main use ("test000.adb"); end local; polyorb-2.8~20110207.orig/testsuite/core/tasking/0000755000175000017500000000000011750740340021023 5ustar xavierxavierpolyorb-2.8~20110207.orig/testsuite/core/tasking/test003.adb0000644000175000017500000000542711750740340022705 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- T E S T 0 0 3 -- -- -- -- B o d y -- -- -- -- Copyright (C) 2002-2003 Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by ACT Europe. -- -- (email: sales@act-europe.fr) -- -- -- ------------------------------------------------------------------------------ -- Advanced mutexes testsuite. with PolyORB.Initialization; with PolyORB.Tasking.Profiles.Full_Tasking.Threads; pragma Warnings (Off, PolyORB.Tasking.Profiles.Full_Tasking.Threads); with PolyORB.Tasking.Profiles.Full_Tasking.Threads.Dynamic_Priorities; pragma Warnings (Off, PolyORB.Tasking.Profiles.Full_Tasking.Threads.Dynamic_Priorities); with PolyORB.Tasking.Profiles.Full_Tasking.Mutexes; pragma Warnings (Off, PolyORB.Tasking.Profiles.Full_Tasking.Mutexes); with PolyORB.Tasking.Profiles.Full_Tasking.Condition_Variables; pragma Warnings (Off, PolyORB.Tasking.Profiles.Full_Tasking.Condition_Variables); with Test003_Common; procedure Test003 is use Test003_Common; begin PolyORB.Initialization.Initialize_World; Initialize_Test; Test_AM; end Test003; polyorb-2.8~20110207.orig/testsuite/core/tasking/Makefile.local0000644000175000017500000000000011750740340023542 0ustar xavierxavierpolyorb-2.8~20110207.orig/testsuite/core/tasking/ravenscar_setup.ads0000644000175000017500000000412311750740340024720 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- R A V E N S C A R _ S E T U P -- -- -- -- S p e c -- -- -- -- Copyright (C) 2003 Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by ACT Europe. -- -- (email: sales@act-europe.fr) -- -- -- ------------------------------------------------------------------------------ package Ravenscar_Setup is pragma Elaborate_Body; end Ravenscar_Setup; polyorb-2.8~20110207.orig/testsuite/core/tasking/test003_common.ads0000644000175000017500000000421711750740340024272 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- T E S T 0 0 3 _ C O M M O N -- -- -- -- S p e c -- -- -- -- Copyright (C) 2002 Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by ACT Europe. -- -- (email: sales@act-europe.fr) -- -- -- ------------------------------------------------------------------------------ package Test003_Common is procedure Initialize_Test; -- Initialize test. procedure Test_AM; -- XXX end Test003_Common; polyorb-2.8~20110207.orig/testsuite/core/tasking/test002_common.adb0000644000175000017500000001140611750740340024246 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- T E S T 0 0 2 _ C O M M O N -- -- -- -- B o d y -- -- -- -- Copyright (C) 2002-2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with PolyORB.Utils.Report; with PolyORB.Tasking.Threads; with PolyORB.Tasking.Condition_Variables; with PolyORB.Tasking.Mutexes; package body Test002_Common is use PolyORB.Tasking.Threads; use PolyORB.Tasking.Condition_Variables; use PolyORB.Tasking.Mutexes; use PolyORB.Utils.Report; My_Thread_Factory : Thread_Factory_Access; Number_Of_Tasks : constant Integer := 4; -- Number of tasks to be created subtype Task_Index is Integer range 1 .. Number_Of_Tasks; type Generic_Runnable is new Runnable with record Id : Natural; P : Parameterless_Procedure; end record; procedure Run (R : not null access Generic_Runnable); type Generic_Runnable_Arr is array (Task_Index) of Runnable_Access; R : Generic_Runnable_Arr; Global_CV : Condition_Access; -- CV shared by different threads. -- XXX Check thread safety ! Task_Waiting : Natural := 0; -- Number of tasks waiting --------------------- -- Initialize_Test -- --------------------- procedure Initialize_Test is begin My_Thread_Factory := Get_Thread_Factory; Create (Global_CV); end Initialize_Test; --------- -- Run -- --------- procedure Run (R : not null access Generic_Runnable) is begin R.P.all; end Run; --------------- -- Wait_Task -- --------------- procedure Wait_Task; procedure Wait_Task is My_Mutex : Mutex_Access; begin Create (My_Mutex); Enter (My_Mutex); Task_Waiting := Task_Waiting + 1; Wait (Global_CV, My_Mutex); Output ("End task: " & Image (Get_Current_Thread_Id (My_Thread_Factory)), True); Task_Waiting := Task_Waiting - 1; Leave (My_Mutex); end Wait_Task; ------------- -- Test_CV -- ------------- procedure Test_CV is begin New_Test ("Condition Variables"); for J in Task_Index'Range loop R (J) := new Generic_Runnable; Generic_Runnable (R (J).all).P := Wait_Task'Access; declare T : constant Thread_Access := Run_In_Task (TF => My_Thread_Factory, R => R (J)); pragma Unreferenced (T); begin null; end; end loop; Output ("Wait before testing", True); delay 4.0; Output ("All task waiting", Task_Waiting = Task_Index'Last); Signal (Global_CV); delay 4.0; Output ("One task awaken", Task_Waiting = Task_Index'Last - 1); Signal (Global_CV); delay 4.0; Output ("Another task awaken", Task_Waiting = Task_Index'Last - 2); Broadcast (Global_CV); delay 4.0; Output ("Broadcast: all tasks are awaken", Task_Waiting = 0); End_Report; end Test_CV; end Test002_Common; polyorb-2.8~20110207.orig/testsuite/core/tasking/test001_common.adb0000644000175000017500000001152211750740340024244 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- T E S T 0 0 1 _ C O M M O N -- -- -- -- B o d y -- -- -- -- Copyright (C) 2002-2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with PolyORB.Utils.Report; with PolyORB.Tasking.Threads; with System; package body Test001_Common is use PolyORB.Tasking.Threads; use PolyORB.Utils.Report; My_Thread_Factory : Thread_Factory_Access; type Generic_Runnable is new Runnable with record P : Parameterless_Procedure; end record; procedure Run (R : not null access Generic_Runnable); procedure Test_Task; -- Body of the task procedure Test_Task2; -- Body of the task --------------------- -- Initialize_Test -- --------------------- procedure Initialize_Test is begin My_Thread_Factory := Get_Thread_Factory; end Initialize_Test; --------- -- Run -- --------- procedure Run (R : not null access Generic_Runnable) is begin R.P.all; end Run; --------------- -- Test_Task -- --------------- procedure Test_Task is begin delay 1.0; end Test_Task; ---------------- -- Test_Task2 -- ---------------- procedure Test_Task2 is begin delay 10.0; end Test_Task2; ------------------------ -- Test_Task_Creation -- ------------------------ procedure Test_Task_Creation (Nb_Of_Tasks : Natural := 1000) is begin New_Test ("Create " & Natural'Image (Nb_Of_Tasks) & " tasks"); for J in 1 .. Nb_Of_Tasks loop declare R : constant Runnable_Access := new Generic_Runnable; begin Generic_Runnable (R.all).P := Test_Task'Access; declare T : constant Thread_Access := Run_In_Task (TF => My_Thread_Factory, R => R); pragma Unreferenced (T); begin null; end; end; end loop; Output ("Done", True); end Test_Task_Creation; -------------------------- -- Test_Task_Priorities -- -------------------------- procedure Test_Task_Priorities is P_In : constant System.Any_Priority := 3; P_Out : System.Any_Priority; R : constant Runnable_Access := new Generic_Runnable; begin New_Test ("Task priority manipulation"); Generic_Runnable (R.all).P := Test_Task2'Access; declare T : constant Thread_Access := Run_In_Task (TF => My_Thread_Factory, Name => "", Default_Priority => 10, R => R); begin Output ("Wait a while", True); delay 1.0; -- It is required to wait some time before modifying the priority Set_Priority (My_Thread_Factory, Get_Thread_Id (T), P_In); delay 1.0; P_Out := Get_Priority (My_Thread_Factory, Get_Thread_Id (T)); Output ("Test priority" & P_Out'Img, P_In = P_Out); end; end Test_Task_Priorities; end Test001_Common; polyorb-2.8~20110207.orig/testsuite/core/tasking/ravenscar_setup.adb0000644000175000017500000000540111750740340024677 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- R A V E N S C A R _ S E T U P -- -- -- -- B o d y -- -- -- -- Copyright (C) 2003 Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by ACT Europe. -- -- (email: sales@act-europe.fr) -- -- -- ------------------------------------------------------------------------------ with System; with PolyORB.Tasking.Profiles.Ravenscar.Threads; with PolyORB.Tasking.Profiles.Ravenscar.Mutexes; with PolyORB.Tasking.Profiles.Ravenscar.Condition_Variables; package body Ravenscar_Setup is pragma Warnings (Off); -- No direct reference on these packages: they initializes hooks -- for the tasking runtime. package Threads_Package is new PolyORB.Tasking.Profiles.Ravenscar.Threads (4, 20, System.Default_Priority); package Conditions_Package is new PolyORB.Tasking.Profiles.Ravenscar.Condition_Variables (Threads_Package, 1_000); package Mutexes_Package is new PolyORB.Tasking.Profiles.Ravenscar.Mutexes (Threads_Package, 1_000); pragma Warnings (On); end Ravenscar_Setup; polyorb-2.8~20110207.orig/testsuite/core/tasking/test000.adb0000644000175000017500000000573711750740340022706 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- T E S T 0 0 0 -- -- -- -- B o d y -- -- -- -- Copyright (C) 2002-2008, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- Run the tests for the Full_Tasking profile with PolyORB.Initialization; with PolyORB.Utils.Report; with PolyORB.Tasking.Profiles.Full_Tasking.Threads; pragma Warnings (Off, PolyORB.Tasking.Profiles.Full_Tasking.Threads); with PolyORB.Tasking.Profiles.Full_Tasking.Threads.Dynamic_Priorities; pragma Warnings (Off, PolyORB.Tasking.Profiles.Full_Tasking.Threads.Dynamic_Priorities); with PolyORB.Tasking.Profiles.Full_Tasking.Mutexes; pragma Warnings (Off, PolyORB.Tasking.Profiles.Full_Tasking.Mutexes); with PolyORB.Tasking.Profiles.Full_Tasking.Condition_Variables; pragma Warnings (Off, PolyORB.Tasking.Profiles.Full_Tasking.Condition_Variables); with PolyORB.Parameters.File; pragma Warnings (Off, PolyORB.Parameters.File); with Test000_Common; procedure Test000 is use Test000_Common; begin PolyORB.Initialization.Initialize_World; Initialize; Test_Threads; Test_Synchronisations; Test_Mutexes; PolyORB.Utils.Report.End_Report; end Test000; polyorb-2.8~20110207.orig/testsuite/core/tasking/test001.adb0000644000175000017500000000674611750740340022710 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- T E S T 0 0 1 -- -- -- -- B o d y -- -- -- -- Copyright (C) 2002-2005 Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- Thread testsuite with Ada.Command_Line; with Ada.Exceptions; with Ada.Text_IO; with PolyORB.Tasking.Profiles.Full_Tasking.Threads; pragma Warnings (Off, PolyORB.Tasking.Profiles.Full_Tasking.Threads); with PolyORB.Tasking.Profiles.Full_Tasking.Threads.Dynamic_Priorities; pragma Warnings (Off, PolyORB.Tasking.Profiles.Full_Tasking.Threads.Dynamic_Priorities); with PolyORB.Tasking.Profiles.Full_Tasking.Mutexes; pragma Warnings (Off, PolyORB.Tasking.Profiles.Full_Tasking.Mutexes); with PolyORB.Tasking.Profiles.Full_Tasking.Condition_Variables; pragma Warnings (Off, PolyORB.Tasking.Profiles.Full_Tasking.Condition_Variables); with PolyORB.Initialization; with PolyORB.Utils.Report; with Test001_Common; procedure Test001 is use Ada.Command_Line; use Ada.Exceptions; use Ada.Text_IO; use PolyORB.Utils.Report; use Test001_Common; Nb_Of_Tasks : Natural := 1000; begin if Ada.Command_Line.Argument_Count = 1 then begin Nb_Of_Tasks := Natural'Value (Ada.Command_Line.Argument (1)); exception when others => null; end; end if; PolyORB.Initialization.Initialize_World; Initialize_Test; Test_Task_Creation (Nb_Of_Tasks); Test_Task_Priorities; End_Report; exception when E : others => Output ("FATAL Error, exception raised", False); New_Line; Put_Line ("Got " & Exception_Name (E) & " " & Exception_Message (E)); End_Report; end Test001; polyorb-2.8~20110207.orig/testsuite/core/tasking/test000_common.adb0000644000175000017500000007655211750740340024261 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- T E S T 0 0 0 _ C O M M O N -- -- -- -- B o d y -- -- -- -- Copyright (C) 2002-2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with Ada.Real_Time; with Ada.Exceptions; with PolyORB.Tasking.Threads; with PolyORB.Tasking.Advanced_Mutexes; with PolyORB.Tasking.Mutexes; with PolyORB.Tasking.Condition_Variables; with PolyORB.Log; with PolyORB.Utils.Report; package body Test000_Common is use Ada.Exceptions; use PolyORB.Log; use PolyORB.Tasking.Threads; package PTMX renames PolyORB.Tasking.Advanced_Mutexes; package PTCV renames PolyORB.Tasking.Condition_Variables; package PTM renames PolyORB.Tasking.Mutexes; package PTT renames PolyORB.Tasking.Threads; package L is new PolyORB.Log.Facility_Log ("polyorb.tasking.test"); procedure O (Message : String; Level : Log_Level := Debug) renames L.Output; function C (Level : Log_Level := Debug) return Boolean renames L.Enabled; pragma Unreferenced (C); -- For conditional pragma Debug procedure Tempo (Time_In_Seconds : Float := Delay_Used); -- Wait for Time_In_Seconds seconds. ---------------------------------------------- -- Types and variables used in Thread tests -- ---------------------------------------------- My_Thread_Factory : PTT.Thread_Factory_Access; procedure Test_1; -- Main procedure of the tasks of the first Thread test. -- Test that the good number of tasks are created. procedure Test_2; -- Main procedure of the tasks of the second Thread test. -- Test Get_Current_Thread. --------------------------------------------- -- Types and variables used in Mutex tests -- --------------------------------------------- My_Mutex : PTMX.Adv_Mutex_Access; procedure Task_Test_Mutexes (Id : Integer); -- Main procedure for the tasks of the Mutex tests. --------------------------------------------------- -- Types and Variables for Test_Synchronisations -- --------------------------------------------------- My_SCondition : PTCV.Condition_Access; My_SMutex : PTM.Mutex_Access; My_SBoolean : Boolean; -- Boolean used for the tests, in association with My_SCondition procedure Task_Test_Synchronisations (Id : Integer); -- Main procedure for the tasks of the synchro tests. -- It is adapted from the the monitor test. Use_Broadcast : constant Boolean := True; procedure Signal; -- Signal all the task waiting on M_SCondition. -- Two implementations are provided for it: -- * one uses Broadcast (My_SCondition); -- * one uses Signal (My_SCondition). ------------------------------------------- -- Types and variables used in all tests -- ------------------------------------------- subtype Task_Index is Integer range 1 .. Number_Of_Tasks; type Generic_Run is new PTT.Runnable with record Id : Task_Index; P : PTT.Parameterless_Procedure; end record; -- Simple generic Runnable, that use a access to procedure -- for its main procedure procedure Run (R : not null access Generic_Run); -- Call to R.P.all Ok : Boolean := True; pragma Volatile (Ok); J : Integer := 0; pragma Volatile (J); -- (On the following code, packages with a private Mutex are used to -- emulate protected object. The reason is is build this way -- is that it is based on tests that used protected objects, -- so we wanted to minimalize the changes). package Synchro is -- Protected object used to synchronize the tasks of the test. -- We assume that test number go increasingly, from 0. -- Tests can wait on a test number; if the internal number of -- Synchro is superior, the waiting test continue is execution. procedure Initialize; procedure Wait (Version : Integer); -- Await until Synchro.Version >= Synchro procedure Signal (Version : Integer); -- Change the Version number. If Version < Synchro.Version, -- a assertion failure occurs. procedure Reset; -- Set the Version number to 0. -- The followings are common barrier facilities : procedure Simple_Wait; -- Simple wait (barrier type). procedure Reset_Simple_Wait; -- Reset the barrier procedure Simple_Release; -- Signal the barrier. private Passing : Boolean := True; Signaled : Boolean := False; My_Version : Integer := 0; Await_Count : Integer := 0; Internal_Condition : PTCV.Condition_Access; Internal_Mutex : PTM.Mutex_Access; end Synchro; package Synchro_Joiner is -- Protected object used to synchronize the test driver with the end -- of a test. -- When all the tasks of the test have called Signal_End, -- the tasks blocking on Join are freed. procedure Initialize; procedure Join; procedure Signal_End; private Passing : Boolean := False; Number_Ended : Natural := 0; Internal_Mutex : PTM.Mutex_Access; Internal_Condition : PTCV.Condition_Access; end Synchro_Joiner; package Counter is -- Synchronized counter. procedure Increase; procedure Initialize; function Get return Integer; procedure Reset; private Internal_Mutex : PTM.Mutex_Access; Count : Natural := 0; pragma Atomic (Count); end Counter; type Runnable_Arr is array (Task_Index) of Runnable_Access; R : Runnable_Arr; type Identified_Runnable_Main_Procedure is access procedure (Id : Integer); type Identified_Runnable is new PTT.Runnable with record Id : Integer; P : Identified_Runnable_Main_Procedure; end record; procedure Run (R : not null access Identified_Runnable); type Id_Runnable_Arr is array (Task_Index) of Runnable_Access; Id_R : Id_Runnable_Arr; ------------- -- Counter -- ------------- package body Counter is ----------------- -- Counter.Get -- ----------------- function Get return Integer is begin return Count; end Get; ---------------------- -- Counter.Increase -- ---------------------- procedure Increase is begin PTM.Enter (Internal_Mutex); Count := Count + 1; PTM.Leave (Internal_Mutex); end Increase; ------------------------ -- Counter.Initialize -- ------------------------ procedure Initialize is begin PTM.Create (Internal_Mutex); end Initialize; ------------------- -- Counter.Reset -- ------------------- procedure Reset is begin PTM.Enter (Internal_Mutex); Count := 0; PTM.Leave (Internal_Mutex); end Reset; end Counter; --------------- -- End_Tests -- --------------- procedure End_Tests is begin PolyORB.Utils.Report.Output ("END TESTS", True); end End_Tests; ---------------- -- Initialize -- ---------------- procedure Initialize is begin My_Thread_Factory := PTT.Get_Thread_Factory; PTM.Create (My_SMutex); PTCV.Create (My_SCondition); Counter.Initialize; Synchro_Joiner.Initialize; Synchro.Initialize; end Initialize; --------- -- Run -- --------- procedure Run (R : not null access Generic_Run) is begin R.P.all; end Run; procedure Run (R : not null access Identified_Runnable) is begin R.P.all (R.Id); end Run; ------------ -- Signal -- ------------ procedure Signal is begin if Use_Broadcast then PTCV.Broadcast (My_SCondition); else for J in Task_Index'Range loop PTCV.Signal (My_SCondition); end loop; end if; end Signal; ------------- -- Synchro -- ------------- package body Synchro is ------------------------ -- Synchro.Initialize -- ------------------------ procedure Initialize is begin PTM.Create (Internal_Mutex); PTCV.Create (Internal_Condition); end Initialize; ------------------- -- Synchro.Reset -- ------------------- procedure Reset is begin PTM.Enter (Internal_Mutex); My_Version := 0; Passing := True; Signaled := False; PTM.Leave (Internal_Mutex); end Reset; ------------------------------- -- Synchro.Reset_Simple_Wait -- ------------------------------- procedure Reset_Simple_Wait is begin PTM.Enter (Internal_Mutex); Signaled := False; PTCV.Broadcast (Internal_Condition); PTM.Leave (Internal_Mutex); end Reset_Simple_Wait; -------------------- -- Synchro.Signal -- -------------------- procedure Signal (Version : Integer) is begin PTM.Enter (Internal_Mutex); pragma Assert (Version > My_Version); My_Version := Version; if Await_Count /= 0 then Passing := False; PTCV.Broadcast (Internal_Condition); end if; PTM.Leave (Internal_Mutex); end Signal; ---------------------------- -- Synchro.Simple_Release -- ---------------------------- procedure Simple_Release is begin PTM.Enter (Internal_Mutex); Signaled := True; PTCV.Broadcast (Internal_Condition); PTM.Leave (Internal_Mutex); end Simple_Release; ------------------------- -- Synchro.Simple_Wait -- ------------------------- procedure Simple_Wait is begin PTM.Enter (Internal_Mutex); while not Signaled loop PTCV.Wait (Internal_Condition, Internal_Mutex); end loop; PTM.Leave (Internal_Mutex); end Simple_Wait; ------------------ -- Synchro.Wait -- ------------------ procedure Wait (Version : Integer) is begin PTM.Enter (Internal_Mutex); while My_Version < Version loop -- Real_Wait : while not Passing loop PTCV.Wait (Internal_Condition, Internal_Mutex); end loop; if My_Version < Version then Await_Count := Await_Count + 1; while Passing loop PTCV.Wait (Internal_Condition, Internal_Mutex); end loop; Await_Count := Await_Count - 1; if Await_Count = 0 then Passing := True; PTCV.Broadcast (Internal_Condition); end if; end if; end loop; PTM.Leave (Internal_Mutex); end Wait; end Synchro; -------------------- -- Synchro_Joiner -- -------------------- package body Synchro_Joiner is ------------------------------- -- Synchro_Joiner.Initialize -- ------------------------------- procedure Initialize is begin PTM.Create (Internal_Mutex); PTCV.Create (Internal_Condition); end Initialize; ------------------------- -- Synchro_Joiner.Join -- ------------------------- procedure Join is begin PTM.Enter (Internal_Mutex); while not Passing loop PTCV.Wait (Internal_Condition, Internal_Mutex); end loop; Number_Ended := Number_Ended - Number_Of_Tasks; Passing := False; PTM.Leave (Internal_Mutex); end Join; ------------------------------- -- Synchro_Joiner.Signal_End -- ------------------------------- procedure Signal_End is begin PTM.Enter (Internal_Mutex); Number_Ended := Number_Ended + 1; Passing := Number_Ended >= Number_Of_Tasks; PTCV.Broadcast (Internal_Condition); PTM.Leave (Internal_Mutex); end Signal_End; end Synchro_Joiner; -------------------------------- -- Task_Test_Synchronisations -- -------------------------------- procedure Task_Test_Synchronisations (Id : Integer) is use PolyORB.Tasking.Mutexes; use PolyORB.Tasking.Condition_Variables; begin O ("task " & Integer'Image (Id) & " begins Synchronisation tests "); Synchro.Simple_Wait; Synchro.Wait (1); -- Test the mutual exclusion. -- Every tasks try to take the mutex to change J. -- If two tasks take it at the same time, one will -- see J with a different value that the one she -- assigned. O ("task " & Integer'Image (Id) & " begins test on mutual exclusion "); begin Enter (My_SMutex); O ("task " & Integer'Image (Id) & " is in the mutex"); J := Id; Tempo; Ok := Ok and then (J = Id); O ("task " & Integer'Image (Id) & " will leave in the mutex"); Leave (My_SMutex); exception when Exc : others => Ok := False; O ("task " & Integer'Image (Id) & " EXCEPTION RAISED ! " & Exception_Name (Exc) & " : " & Exception_Message (Exc)); end; Synchro_Joiner.Signal_End; Synchro.Wait (2); -- Test that a call to Wait free the mutex -- Every task change J, then Wait on My_Condition. -- When all of them are waiting, they are released. O ("task " & Integer'Image (Id) & " tests that a call to Wait free the mutex"); begin Enter (My_SMutex); O ("task " & Integer'Image (Id) & " is in the mutex"); J := Id; Synchro_Joiner.Signal_End; while not My_SBoolean loop O ("task " & Integer'Image (Id) & " will wait"); Wait (My_SCondition, My_SMutex); end loop; if J = Id then Counter.Increase; end if; O ("task " & Integer'Image (Id) & " will leave the mutex"); Leave (My_SMutex); exception when Exc : others => Ok := False; O ("task " & Integer'Image (Id) & " EXCEPTION RAISED ! " & Exception_Name (Exc) & " : " & Exception_Message (Exc)); end; Synchro_Joiner.Signal_End; Synchro.Wait (3); -- Test that a call to Wait on a condition set to -- True is not blocking, and don't free the lock. O ("task " & Integer'Image (Id) & " will make a dumb test"); begin Enter (My_SMutex); O ("task " & Integer'Image (Id) & " will wait"); J := Id; while not My_SBoolean loop O ("task " & Integer'Image (Id) & " should not be here"); pragma Assert (False); Wait (My_SCondition, My_SMutex); end loop; Ok := Ok and then (J = Id); O ("task " & Integer'Image (Id) & " will leave the mutex"); Leave (My_SMutex); exception when Exc : others => Ok := False; O ("task " & Integer'Image (Id) & " EXCEPTION RAISED ! " & Exception_Name (Exc) & " : " & Exception_Message (Exc)); end; Synchro_Joiner.Signal_End; Synchro.Wait (4); -- Test that a call to Wait outside a critical session -- raise an exception. O ("task " & Integer'Image (Id) & " begins another dumb test"); begin Ok := True; -- Wait (My_Monitor.all, My_Condition'Access); -- Should not be reached : -- Ok := False; exception when Exc : others => O ("task " & Integer'Image (Id) & " EXCEPTION RAISED ! " & Exception_Name (Exc) & " : " & Exception_Message (Exc)); null; end; Synchro_Joiner.Signal_End; Synchro.Wait (5); -- Test that the section after the wait is done in mutual exclusion O ("task " & Integer'Image (Id) & " begins test of mutual exclusion after wait "); begin Enter (My_SMutex); O ("task " & Integer'Image (Id) & " enters mutex "); Synchro_Joiner.Signal_End; while not My_SBoolean loop O ("task " & Integer'Image (Id) & " will wait"); Wait (My_SCondition, My_SMutex); end loop; J := Id; Tempo; Ok := Ok and then (J = Id); O ("task " & Integer'Image (Id) & " will leave mutex "); Leave (My_SMutex); exception when Exc : others => Ok := False; O ("task " & Integer'Image (Id) & " EXCEPTION RAISED ! " & Exception_Name (Exc) & " : " & Exception_Message (Exc)); end; Synchro_Joiner.Signal_End; Synchro.Wait (6); -- Same test, but with a Wait condition already fulfilled O ("task " & Integer'Image (Id) & " will do a dumb test"); begin Enter (My_SMutex); O ("task " & Integer'Image (Id) & " enters mutex"); Synchro_Joiner.Signal_End; while not My_SBoolean loop O ("task " & Integer'Image (Id) & " will wait "); Wait (My_SCondition, My_SMutex); end loop; J := Id; Tempo; Ok := Ok and then (J = Id); O ("task " & Integer'Image (Id) & " will leave the mutex "); Leave (My_SMutex); exception when Exc : others => Ok := False; O ("task " & Integer'Image (Id) & " EXCEPTION RAISED ! " & Exception_Name (Exc) & " : " & Exception_Message (Exc)); end; Synchro.Wait (7); Synchro_Joiner.Signal_End; exception when Exc : others => Ok := False; O ("task " & Integer'Image (Id) & " EXCEPTION RAISED ! " & Exception_Name (Exc) & " : " & Exception_Message (Exc)); end Task_Test_Synchronisations; ----------------------- -- Task_Test_Mutexes -- ----------------------- procedure Task_Test_Mutexes (Id : Integer) is begin Synchro.Simple_Wait; Synchro.Wait (1); -- Test that the mutual exclusion is assured by Adv Mutexes. begin PTMX.Enter (My_Mutex); J := Id; Tempo; Ok := Ok and then (J = Id); PTMX.Leave (My_Mutex); exception when Exc : others => Ok := False; O ("task " & Integer'Image (Id) & " EXCEPTION RAISED ! " & Exception_Name (Exc) & " : " & Exception_Message (Exc)); end; Synchro_Joiner.Signal_End; Synchro.Wait (2); -- Same test, except that the main task also try to get the mutex. begin PTMX.Enter (My_Mutex); J := Id; Tempo; Ok := Ok and then (J = Id); PTMX.Leave (My_Mutex); exception when Exc : others => Ok := False; O ("task " & Integer'Image (Id) & " EXCEPTION RAISED ! " & Exception_Name (Exc) & " : " & Exception_Message (Exc)); end; Synchro_Joiner.Signal_End; Synchro.Wait (3); -- Same test, except that the tasks enter several times in the critical -- section. begin PTMX.Enter (My_Mutex); J := Id; Tempo; Ok := Ok and then (J = Id); PTMX.Enter (My_Mutex); Tempo; Ok := Ok and then (J = Id); PTMX.Leave (My_Mutex); Tempo; Ok := Ok and then (J = Id); PTMX.Leave (My_Mutex); exception when Exc : others => Ok := False; O ("task " & Integer'Image (Id) & " EXCEPTION RAISED ! " & Exception_Name (Exc) & " : " & Exception_Message (Exc)); end; Synchro_Joiner.Signal_End; exception when Exc : others => Ok := False; O ("task " & Integer'Image (Id) & " EXCEPTION RAISED ! " & Exception_Name (Exc) & " : " & Exception_Message (Exc)); end Task_Test_Mutexes; ----------- -- Tempo -- ----------- procedure Tempo (Time_In_Seconds : Float := Delay_Used) is use Ada.Real_Time; S : constant Time := Clock; begin delay until S + Milliseconds (Integer (1_000.0 * Time_In_Seconds)); end Tempo; ------------ -- Test_1 -- ------------ procedure Test_1 is begin Tempo; Counter.Increase; Tempo; Synchro_Joiner.Signal_End; exception when Exc : others => O ("task test 1" & " EXCEPTION RAISED ! " & Exception_Name (Exc) & " : " & Exception_Message (Exc)); null; end Test_1; Acc : PTT.Thread_Id; pragma Atomic (Acc); ------------ -- Test_2 -- ------------ procedure Test_2 is begin Acc := Get_Current_Thread_Id (My_Thread_Factory); Tempo; if Acc = Get_Current_Thread_Id (My_Thread_Factory) then Counter.Increase; end if; Synchro_Joiner.Signal_End; exception when Exc : others => O ("task test 2" & " EXCEPTION RAISED ! " & Exception_Name (Exc) & " : " & Exception_Message (Exc)); Counter.Increase; Counter.Increase; end Test_2; --------------------------- -- Test_Synchronisations -- --------------------------- procedure Test_Synchronisations is use PolyORB.Tasking.Mutexes; use PolyORB.Tasking.Condition_Variables; begin PolyORB.Utils.Report.New_Test ("Synchronisations"); begin My_SBoolean := False; for J in Task_Index'Range loop Id_R (J) := new Identified_Runnable; Identified_Runnable (Id_R (J).all).Id := J; Identified_Runnable (Id_R (J).all).P := Task_Test_Synchronisations'Access; declare T : constant Thread_Access := Run_In_Task (TF => My_Thread_Factory, R => Id_R (J)); pragma Unreferenced (T); begin null; end; end loop; exception when Exc : others => O ("main task " & " EXCEPTION RAISED ! " & Exception_Name (Exc) & " : " & Exception_Message (Exc)); Ok := False; end; PolyORB.Utils.Report.Output ("retest threads before synchro tests", Ok); Synchro.Reset; Counter.Reset; Synchro.Simple_Release; Synchro.Signal (1); Synchro_Joiner.Join; PolyORB.Utils.Report.Output ("test mutual exclusion", Ok); Ok := True; Synchro.Signal (2); Synchro_Joiner.Join; Enter (My_SMutex); My_SBoolean := True; Signal; Leave (My_SMutex); Synchro_Joiner.Join; Ok := Counter.Get = 1; PolyORB.Utils.Report.Output ("test the mutex is unlocked on Wait", Ok); Counter.Reset; Ok := True; Synchro.Signal (3); Synchro_Joiner.Join; PolyORB.Utils.Report.Output ("test that a Wait on True is not blocking", Ok); Counter.Reset; Ok := True; Synchro.Signal (4); Synchro_Joiner.Join; PolyORB.Utils.Report.Output ("test that Wait outside the monitor raise an exception", Ok); Counter.Reset; Ok := True; Enter (My_SMutex); My_SBoolean := False; Leave (My_SMutex); Synchro.Signal (5); Synchro_Joiner.Join; Enter (My_SMutex); My_SBoolean := True; Signal; Leave (My_SMutex); Synchro_Joiner.Join; PolyORB.Utils.Report.Output ("test the mutual exclusion after a Wait", Ok); Counter.Reset; Ok := True; Synchro.Signal (6); Synchro_Joiner.Join; Signal; Synchro.Signal (7); Synchro_Joiner.Join; PolyORB.Utils.Report.Output ("same test with a condition already fulfilled", Ok); Counter.Reset; Ok := True; Synchro.Reset_Simple_Wait; end Test_Synchronisations; ------------------ -- Test_Mutexes -- ------------------ procedure Test_Mutexes is Id : constant Integer := -1; begin PolyORB.Utils.Report.New_Test ("Mutexes"); PTMX.Create (My_Mutex); Synchro.Reset; Counter.Reset; begin for J in Task_Index'Range loop Id_R (J) := new Identified_Runnable; Identified_Runnable (Id_R (J).all).Id := J; Identified_Runnable (Id_R (J).all).P := Task_Test_Mutexes'Access; declare T : constant Thread_Access := Run_In_Task (TF => My_Thread_Factory, R => Id_R (J)); pragma Unreferenced (T); begin null; end; end loop; exception when Exc : others => O ("main task " & " EXCEPTION RAISED ! " & Exception_Name (Exc) & " : " & Exception_Message (Exc)); Ok := False; end; PolyORB.Utils.Report.Output ("retest threads before Adv mutex tests", Ok); Synchro.Simple_Release; Synchro.Signal (1); Synchro_Joiner.Join; PolyORB.Utils.Report.Output ("test mutual exclusion for Adv mutex", Ok); Ok := True; Synchro.Signal (2); begin PTMX.Enter (My_Mutex); J := Id; Tempo; Ok := Ok and then (J = Id); PTMX.Leave (My_Mutex); exception when Exc : others => O ("main task " & " EXCEPTION RAISED ! " & Exception_Name (Exc) & " : " & Exception_Message (Exc)); Ok := False; end; Synchro_Joiner.Join; PolyORB.Utils.Report.Output ("same test, with the main task involved", Ok); Ok := True; Synchro.Signal (3); begin PTMX.Enter (My_Mutex); J := Id; Tempo; Ok := Ok and then (J = Id); PTMX.Enter (My_Mutex); Tempo; Ok := Ok and then (J = Id); PTMX.Leave (My_Mutex); Tempo; Ok := Ok and then (J = Id); PTMX.Leave (My_Mutex); exception when Exc : others => Ok := False; O ("main task " & " EXCEPTION RAISED ! " & Exception_Name (Exc) & " : " & Exception_Message (Exc)); end; Synchro_Joiner.Join; PolyORB.Utils.Report.Output ("same test, with Enter called several times", Ok); Ok := True; exception when Exc : others => Ok := False; O ("main task " & " EXCEPTION RAISED ! " & Exception_Name (Exc) & " : " & Exception_Message (Exc)); raise; end Test_Mutexes; ------------------ -- Test_Threads -- ------------------ procedure Test_Threads is Thr_Ok : Boolean; begin PolyORB.Utils.Report.New_Test ("Thread manipulation"); Synchro.Reset; Counter.Reset; begin for J in Task_Index'Range loop R (J) := new Generic_Run; Generic_Run (R (J).all).Id := J; Generic_Run (R (J).all).P := Test_1'Access; declare T : constant Thread_Access := Run_In_Task (TF => My_Thread_Factory, R => R (J)); pragma Unreferenced (T); begin null; end; end loop; Thr_Ok := True; exception when Exc : others => Thr_Ok := False; O ("main task " & " EXCEPTION RAISED ! " & Exception_Name (Exc) & " : " & Exception_Message (Exc)); end; Synchro_Joiner.Join; Thr_Ok := (Counter.Get = Number_Of_Tasks) and then Thr_Ok; PolyORB.Utils.Report.Output ("test that the expected number of tasks is created", Thr_Ok); Counter.Reset; begin for J in Task_Index'Range loop R (J) := new Generic_Run; Generic_Run (R (J).all).Id := J; Generic_Run (R (J).all).P := Test_2'Access; declare T : constant Thread_Access := Run_In_Task (TF => My_Thread_Factory, R => R (J)); pragma Unreferenced (T); begin null; end; end loop; Synchro_Joiner.Join; Thr_Ok := True; exception when Exc : others => Thr_Ok := False; O ("main task " & " EXCEPTION RAISED ! " & Exception_Name (Exc) & " : " & Exception_Message (Exc)); end; Thr_Ok := (Counter.Get >= 1) and then Thr_Ok; PolyORB.Utils.Report.Output ("test Get_Current_Thread", Thr_Ok); end Test_Threads; end Test000_Common; polyorb-2.8~20110207.orig/testsuite/core/tasking/test000_common.ads0000644000175000017500000000607111750740340024267 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- T E S T 0 0 0 _ C O M M O N -- -- -- -- S p e c -- -- -- -- Copyright (C) 2002-2008, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- Main tests procedure for the tasking package. -- This package does NOT register the tasking profile, with PolyORB.Parameters; pragma Elaborate_All (PolyORB.Parameters); package Test000_Common is use PolyORB.Parameters; Number_Of_Tasks : constant Integer := Get_Conf ("test", "tasking.number_of_tasks", 2); -- Number of tasks used in the tests. Delay_Used : constant Float := Float (Get_Conf ("test", "tasking.delay_used", 1)); -- Some delay are used in the test (between 1 and 4 per task per tests). -- This constant is the time they wait, in seconds. --------------------- -- Test procedures -- --------------------- procedure Initialize; -- Initialize the package. procedure Test_Threads; -- Test the thread fonctionnalities. procedure Test_Synchronisations; -- Test the POSIX-like synchronisations objects. -- Based on Test_Monitors. procedure Test_Mutexes; -- Test the mutexes functionnalities. procedure End_Tests; -- Signal the end of the tests. end Test000_Common; polyorb-2.8~20110207.orig/testsuite/core/tasking/test000r.adb0000644000175000017500000000463711750740340023066 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- T E S T 0 0 0 R -- -- -- -- B o d y -- -- -- -- Copyright (C) 2003-2008, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- Run the tests for the Ravenscar profile with PolyORB.Initialization; with PolyORB.Utils.Report; with Test000_Common; with Ravenscar_Setup; pragma Warnings (Off, Ravenscar_Setup); procedure Test000R is use Test000_Common; begin PolyORB.Initialization.Initialize_World; Initialize; Test_Threads; Test_Synchronisations; Test_Mutexes; PolyORB.Utils.Report.End_Report; end Test000R; polyorb-2.8~20110207.orig/testsuite/core/tasking/test003_common.adb0000644000175000017500000001103311750740340024243 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- T E S T 0 0 3 _ C O M M O N -- -- -- -- B o d y -- -- -- -- Copyright (C) 2002-2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with PolyORB.Utils.Report; with PolyORB.Tasking.Threads; with PolyORB.Tasking.Advanced_Mutexes; package body Test003_Common is use PolyORB.Tasking.Threads; use PolyORB.Tasking.Advanced_Mutexes; use PolyORB.Utils.Report; My_Thread_Factory : Thread_Factory_Access; Number_Of_Tasks : constant Integer := 4; -- Number of tasks to be created subtype Task_Index is Integer range 1 .. Number_Of_Tasks; type Generic_Runnable is new Runnable with record Id : Natural; P : Parameterless_Procedure; end record; procedure Run (R : not null access Generic_Runnable); type Generic_Runnable_Arr is array (Task_Index) of Runnable_Access; R : Generic_Runnable_Arr; Global_AM : Adv_Mutex_Access; Round : Natural := Task_Index'Last; --------------------- -- Initialize_Test -- --------------------- procedure Initialize_Test is begin My_Thread_Factory := Get_Thread_Factory; Create (Global_AM); end Initialize_Test; --------- -- Run -- --------- procedure Run (R : not null access Generic_Runnable) is begin R.P.all; end Run; --------------- -- Wait_Task -- --------------- procedure Wait_Task; procedure Wait_Task is begin Output ("Enter task: " & Image (Get_Current_Thread_Id (My_Thread_Factory)), True); Enter (Global_AM); Output ("Task " & Image (Get_Current_Thread_Id (My_Thread_Factory)) & " entered AM.", True); delay 1.0; Enter (Global_AM); Output ("Task " & Image (Get_Current_Thread_Id (My_Thread_Factory)) & " entered AM (2).", True); Round := Round - 1; Leave (Global_AM); Leave (Global_AM); Output ("End task: " & Image (Get_Current_Thread_Id (My_Thread_Factory)), True); end Wait_Task; ------------- -- Test_AM -- ------------- procedure Test_AM is begin New_Test ("Tasks entering/leaving Advanced Mutex"); for J in Task_Index'Range loop R (J) := new Generic_Runnable; Generic_Runnable (R (J).all).P := Wait_Task'Access; declare T : constant Thread_Access := Run_In_Task (TF => My_Thread_Factory, R => R (J)); pragma Unreferenced (T); begin null; end; end loop; delay 1.5 * Task_Index'Last; Output ("All tasks entered and left AM", Round = 0); End_Report; end Test_AM; end Test003_Common; polyorb-2.8~20110207.orig/testsuite/core/tasking/test002_common.ads0000644000175000017500000000421711750740340024271 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- T E S T 0 0 2 _ C O M M O N -- -- -- -- S p e c -- -- -- -- Copyright (C) 2002 Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by ACT Europe. -- -- (email: sales@act-europe.fr) -- -- -- ------------------------------------------------------------------------------ package Test002_Common is procedure Initialize_Test; -- Initialize test. procedure Test_CV; -- XXX end Test002_Common; polyorb-2.8~20110207.orig/testsuite/core/tasking/test001_common.ads0000644000175000017500000000446311750740340024273 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- T E S T 0 0 1 _ C O M M O N -- -- -- -- S p e c -- -- -- -- Copyright (C) 2002-2003 Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by ACT Europe. -- -- (email: sales@act-europe.fr) -- -- -- ------------------------------------------------------------------------------ package Test001_Common is procedure Initialize_Test; -- Initialize test. procedure Test_Task_Creation (Nb_Of_Tasks : Natural := 1000); -- Create 'Nb_Of_Tasks' tasks that wait 1s then exit. procedure Test_Task_Priorities; -- Test Task priority management. end Test001_Common; polyorb-2.8~20110207.orig/testsuite/core/tasking/local.gpr0000644000175000017500000000074211750740340022632 0ustar xavierxavierwith "polyorb", "polyorb_test_common"; project local is Dir := external ("Test_Dir"); Obj_Dir := PolyORB_Test_Common.Build_Dir & Dir; for Object_Dir use Obj_Dir; for Source_Dirs use (Obj_Dir, PolyORB_Test_Common.Source_Dir & Dir); package Compiler is for Default_Switches ("Ada") use PolyORB_Test_Common.Compiler'Default_Switches ("Ada"); end Compiler; for Main use ("test000.adb", "test001.adb", "test002.adb", "test003.adb"); end local; polyorb-2.8~20110207.orig/testsuite/core/tasking/test002.adb0000644000175000017500000000543211750740340022700 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- T E S T 0 0 2 -- -- -- -- B o d y -- -- -- -- Copyright (C) 2002-2003 Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by ACT Europe. -- -- (email: sales@act-europe.fr) -- -- -- ------------------------------------------------------------------------------ -- Condition variables testsuite. with PolyORB.Initialization; with PolyORB.Tasking.Profiles.Full_Tasking.Threads; pragma Warnings (Off, PolyORB.Tasking.Profiles.Full_Tasking.Threads); with PolyORB.Tasking.Profiles.Full_Tasking.Threads.Dynamic_Priorities; pragma Warnings (Off, PolyORB.Tasking.Profiles.Full_Tasking.Threads.Dynamic_Priorities); with PolyORB.Tasking.Profiles.Full_Tasking.Mutexes; pragma Warnings (Off, PolyORB.Tasking.Profiles.Full_Tasking.Mutexes); with PolyORB.Tasking.Profiles.Full_Tasking.Condition_Variables; pragma Warnings (Off, PolyORB.Tasking.Profiles.Full_Tasking.Condition_Variables); with Test002_Common; procedure Test002 is use Test002_Common; begin PolyORB.Initialization.Initialize_World; Initialize_Test; Test_CV; end Test002; polyorb-2.8~20110207.orig/testsuite/core/poa/0000755000175000017500000000000011750740340020142 5ustar xavierxavierpolyorb-2.8~20110207.orig/testsuite/core/poa/Makefile.local0000644000175000017500000000000011750740340022661 0ustar xavierxavierpolyorb-2.8~20110207.orig/testsuite/core/poa/test_servant.adb0000644000175000017500000000533111750740340023335 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- T E S T _ S E R V A N T -- -- -- -- B o d y -- -- -- -- Copyright (C) 2002-2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ package body Test_Servant is use PolyORB.Types; --------------------- -- Execute_Servant -- --------------------- function Execute_Servant (S : not null access My_Servant; Req : PolyORB.Requests.Request_Access) return Boolean is pragma Unreferenced (S, Req); begin -- This dummy servant absorbs all requests and returns them as executed return True; end Execute_Servant; ---------- -- Left -- ---------- function "=" (Left, Right : My_Servant) return Standard.Boolean is begin if Left.Nb = Right.Nb and then Left.Name = Right.Name then return True; end if; return False; end "="; end Test_Servant; polyorb-2.8~20110207.orig/testsuite/core/poa/test000.adb0000644000175000017500000003724711750740340022026 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- T E S T 0 0 0 -- -- -- -- B o d y -- -- -- -- Copyright (C) 2002-2005 Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with Ada.Exceptions; with Ada.Text_IO; with PolyORB.POA_Types; with PolyORB.POA_Manager; with PolyORB.POA_Policies; with PolyORB.POA_Config.Minimum; with PolyORB.Errors; with PolyORB.Initialization; with PolyORB.Servants; with PolyORB.Types; with PolyORB.Utils.Report; with PolyORB.Setup.Base; pragma Warnings (Off, PolyORB.Setup.Base); with PolyORB.ORB.No_Tasking; pragma Warnings (Off, PolyORB.ORB.No_Tasking); with PolyORB.ORB_Controller.Workers; pragma Warnings (Off, PolyORB.ORB_Controller.Workers); with PolyORB.Setup.Tasking.No_Tasking; pragma Warnings (Off, PolyORB.Setup.Tasking.No_Tasking); with PolyORB.POA.Basic_POA; -- POA to be tested with Test_Servant; procedure Test000 is use Ada.Text_IO; use Ada.Exceptions; use PolyORB.Errors; use PolyORB.Types; use PolyORB.Utils.Report; ------------------- -- Test_Root_POA -- ------------------- procedure Test_Root_POA; -- Test the construction/destruction of the ROOT POA. procedure Test_Root_POA is Root_POA : constant PolyORB.POA.Obj_Adapter_Access := new PolyORB.POA.Basic_POA.Basic_Obj_Adapter; begin PolyORB.POA_Config.Set_Configuration (new PolyORB.POA_Config.Minimum.Minimum_Configuration); -- Root POA creation PolyORB.POA.Create (Root_POA); Output ("RootPOA creation", True); -- Root POA destruction PolyORB.POA.Destroy (Root_POA); Output ("RootPOA destruction", True); exception when others => Output ("RootPOA creation/destruction", False); raise; end Test_Root_POA; -------------------- -- Test_Child_POA -- -------------------- procedure Test_Child_POA; -- Test the construction/destruction of the ROOT POAs. procedure Test_Child_POA is use PolyORB.POA; use PolyORB.POA_Manager; use PolyORB.POA_Policies; use PolyORB.POA_Policies.Policy_Lists; Root_POA : constant PolyORB.POA.Obj_Adapter_Access := new PolyORB.POA.Basic_POA.Basic_Obj_Adapter; OA1, OA2, OA3 : Obj_Adapter_Access; Policies : PolicyList; PM1 : POAManager_Access; Ok : Boolean := False; Error : Error_Container; begin -- Root POA creation. PolyORB.POA.Create (Root_POA); -- Construct policy list. Append (Policies, Policy_Access (Root_POA.Thread_Policy)); Append (Policies, Policy_Access (Root_POA.Lifespan_Policy)); PM1 := POAManager_Access (Entity_Of (Root_POA.POA_Manager)); -- POA1 Creation. PolyORB.POA.Create_POA (Root_POA, "POA1", PM1, Policies, OA1, Error); if Found (Error) then raise Program_Error; end if; -- POA2 Creation. PolyORB.POA.Create_POA (OA1, "POA2", null, Policies, OA2, Error); if Found (Error) then raise Program_Error; end if; -- POA3 Creation. PolyORB.POA.Create_POA (OA1, "POA3", PM1, Policies, OA3, Error); if Found (Error) then raise Program_Error; end if; Output ("Child POA construction", True); PolyORB.POA.Create_POA (OA1, "POA3", PM1, Policies, OA2, Error); if Found (Error) then Ok := True; else Ok := False; end if; Output ("Raised Adapter_Already_Exists", Ok); Ok := False; if OA1.POA_Manager = OA3.POA_Manager then Ok := True; end if; Output ("Same POA Manager", Ok); Ok := False; if OA1.POA_Manager /= OA2.POA_Manager then Ok := True; end if; Output ("Implicit creation of a POA Manager", Ok); -- POA recursive destruction. PolyORB.POA.Destroy (Root_POA); Output ("POA recursive destruction", True); end Test_Child_POA; -------------------------- -- Test_Activate_Object -- -------------------------- procedure Test_Activate_Object; -- Test simple activation/deactivation of an object. procedure Test_Activate_Object is use PolyORB.POA; use Test_Servant; S1 : My_Servant_Access; Ok : Boolean := False; Error : Error_Container; begin S1 := new My_Servant; S1.Nb := 1; S1.Name := To_PolyORB_String ("Servant1"); declare Root_POA : constant PolyORB.POA.Obj_Adapter_Access := new PolyORB.POA.Basic_POA.Basic_Obj_Adapter; Id1 : PolyORB.POA_Types.Unmarshalled_Oid; begin PolyORB.POA.Create (Root_POA); Activate_Object (Root_POA, PolyORB.Servants.Servant_Access (S1), null, Id1, Error); if Found (Error) then raise Program_Error; end if; Output ("Servant activation", True); Deactivate_Object (Root_POA, PolyORB.POA_Types.U_Oid_To_Oid (Id1), Error); if Found (Error) then raise Program_Error; end if; Output ("Servant deactivation", True); Deactivate_Object (Root_POA, PolyORB.POA_Types.U_Oid_To_Oid (Id1), Error); if Found (Error) then Ok := True; Catch (Error); else Ok := False; end if; Output ("Raised Object_Not_Active", Ok); PolyORB.POA.Destroy (Root_POA); end; declare Root_POA : constant PolyORB.POA.Obj_Adapter_Access := new PolyORB.POA.Basic_POA.Basic_Obj_Adapter; Id1 : PolyORB.POA_Types.Unmarshalled_Oid; Id2 : PolyORB.POA_Types.Unmarshalled_Oid; begin PolyORB.POA.Create (Root_POA); Activate_Object (Root_POA, PolyORB.Servants.Servant_Access (S1), null, Id1, Error); if Found (Error) then raise Program_Error; end if; Activate_Object (Root_POA, PolyORB.Servants.Servant_Access (S1), null, Id2, Error); if Found (Error) then Output ("Raised Servant_Already_Active", True); Catch (Error); else Output ("Raised Servant_Already_Active", False); end if; PolyORB.POA.Destroy (Root_POA); end; end Test_Activate_Object; ---------------------------------- -- Test_Activate_Object_With_Id -- ---------------------------------- -- XXX not implemented in PolyORB !! -- procedure Test_Activate_Object_With_Id; -- procedure Test_Activate_Object_With_Id -- is -- use Test_Servant; -- begin -- declare -- use PolyORB.POA; -- use PolyORB.POA.Basic_POA; -- OA1 : Obj_Adapter_Access; -- S1, S2 : My_Servant_Access; -- begin -- S1 := new My_Servant; -- S1.Nb := 1; -- S1.Name := To_PolyORB_String ("Servant1"); -- S2 := new My_Servant; -- S2.Nb := 2; -- S2.Name := To_PolyORB_String ("Servant2"); -- declare -- use PolyORB.POA; -- OA1 : Obj_Adapter_Access := Create_Root_POA; -- Id1 : PolyORB.POA_Types.Object_Id -- := Activate_Object (OA1.all'Access, -- PolyORB.Servants.Servant_Access (S1)); -- begin -- Deactivate_Object (OA1.all'Access, Id1); -- Activate_Object_With_Id (OA1.all'Access, -- PolyORB.Servants.Servant_Access (S1), -- Id1); -- Destroy (OA1, True, True); -- end; -- declare -- use PolyORB.POA; -- OA1 : Obj_Adapter_Access := Create_Root_POA; -- Id1 : PolyORB.POA_Types.Object_Id -- := Activate_Object (OA1.all'Access, -- PolyORB.Servants.Servant_Access (S1)); -- begin -- Activate_Object_With_Id (OA1.all'Access, -- PolyORB.Servants.Servant_Access (S2), -- Id1); -- Destroy (OA1, True, True); -- exception -- when Object_Already_Active => -- null; -- end; -- declare -- use PolyORB.POA; -- OA1 : Obj_Adapter_Access := Create_Root_POA; -- pragma Warnings (Off); -- Id1 : PolyORB.POA_Types.Object_Id -- := Activate_Object (OA1.all'Access, -- PolyORB.Servants.Servant_Access (S1)); -- pragma Warnings (On); -- Id2 : PolyORB.POA_Types.Object_Id -- := Activate_Object (OA1.all'Access, -- PolyORB.Servants.Servant_Access (S2)); -- begin -- Deactivate_Object (OA1.all'Access, Id2); -- Activate_Object_With_Id (OA1.all'Access, -- PolyORB.Servants.Servant_Access (S1), -- Id2); -- Destroy (OA1, True, True); -- exception -- when Servant_Already_Active => -- null; -- end; -- exception -- when others => -- null; -- end; -- end Test_Activate_Object_With_Id; ------------------------ -- Test_Servant_To_Id -- ------------------------ procedure Test_Servant_To_Id; -- Test Servant_To_Id functions. procedure Test_Servant_To_Id is use type PolyORB.POA_Types.Unmarshalled_Oid; use PolyORB.POA; use Test_Servant; S1 : My_Servant_Access; Root_POA : Obj_Adapter_Access; Error : Error_Container; Id1 : PolyORB.POA_Types.Unmarshalled_Oid; Id2 : PolyORB.POA_Types.Object_Id_Access; begin S1 := new My_Servant; S1.Nb := 1; S1.Name := To_PolyORB_String ("Servant1"); begin Root_POA := new PolyORB.POA.Basic_POA.Basic_Obj_Adapter; PolyORB.POA.Create (Root_POA); Activate_Object (Root_POA, PolyORB.Servants.Servant_Access (S1), null, Id1, Error); if Found (Error) then raise Program_Error; end if; Servant_To_Id (Root_POA, PolyORB.Servants.Servant_Access (S1), Id2, Error); if Found (Error) then raise Program_Error; end if; PolyORB.POA.Destroy (Root_POA); Output ("Servant_To_Id", True); end; end Test_Servant_To_Id; ------------------------ -- Test_Id_To_Servant -- ------------------------ procedure Test_Id_To_Servant; procedure Test_Id_To_Servant is use type PolyORB.POA_Types.Unmarshalled_Oid; use PolyORB.POA; use Test_Servant; S1 : My_Servant_Access; S2 : My_Servant_Access; Error : Error_Container; begin S1 := new My_Servant; S1.Nb := 1; S1.Name := To_PolyORB_String ("Servant1"); declare Root_POA : Obj_Adapter_Access; Id1 : PolyORB.POA_Types.Unmarshalled_Oid; begin Root_POA := new PolyORB.POA.Basic_POA.Basic_Obj_Adapter; PolyORB.POA.Create (Root_POA); Activate_Object (Root_POA, PolyORB.Servants.Servant_Access (S1), null, Id1, Error); if Found (Error) then raise Program_Error; end if; Id_To_Servant (Root_POA, PolyORB.POA_Types.U_Oid_To_Oid (Id1), PolyORB.Servants.Servant_Access (S2), Error); if Found (Error) then raise Program_Error; end if; if S1 /= S2 then Output ("Id_to_Servant", False); else Output ("Id_to_Servant", True); end if; PolyORB.POA.Destroy (Root_POA); end; declare Root_POA : Obj_Adapter_Access; Id1 : PolyORB.POA_Types.Unmarshalled_Oid; begin Root_POA := new PolyORB.POA.Basic_POA.Basic_Obj_Adapter; PolyORB.POA.Create (Root_POA); Activate_Object (Root_POA, PolyORB.Servants.Servant_Access (S1), null, Id1, Error); if Found (Error) then raise Program_Error; end if; Deactivate_Object (Root_POA, PolyORB.POA_Types.U_Oid_To_Oid (Id1), Error); if Found (Error) then raise Program_Error; end if; Id_To_Servant (Root_POA, PolyORB.POA_Types.U_Oid_To_Oid (Id1), PolyORB.Servants.Servant_Access (S2), Error); if Found (Error) then Output ("Got error", True); Catch (Error); else Output ("Got error", False); end if; PolyORB.POA.Destroy (Root_POA); end; end Test_Id_To_Servant; begin PolyORB.Initialization.Initialize_World; Test_Root_POA; Test_Child_POA; Test_Activate_Object; -- Test_Activate_Object_With_Id; Test_Servant_To_Id; Test_Id_To_Servant; End_Report; exception when E : others => Put_Line ("Got exception " & Exception_Name (E) & " : " & Exception_Message (E)); Output ("END TESTS", False); end Test000; polyorb-2.8~20110207.orig/testsuite/core/poa/test_servant.ads0000644000175000017500000000502311750740340023354 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- T E S T _ S E R V A N T -- -- -- -- S p e c -- -- -- -- Copyright (C) 2002-2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with PolyORB.Requests; with PolyORB.Servants; with PolyORB.Types; package Test_Servant is type My_Servant is new PolyORB.Servants.Servant with record Nb : Integer; Name : PolyORB.Types.String; end record; type My_Servant_Access is access all My_Servant; overriding function Execute_Servant (S : not null access My_Servant; Req : PolyORB.Requests.Request_Access) return Boolean; function "=" (Left, Right : My_Servant) return Standard.Boolean; end Test_Servant; polyorb-2.8~20110207.orig/testsuite/core/poa/local.gpr0000644000175000017500000000066511750740340021755 0ustar xavierxavierwith "polyorb", "polyorb_test_common"; project local is Dir := external ("Test_Dir"); Obj_Dir := PolyORB_Test_Common.Build_Dir & Dir; for Object_Dir use Obj_Dir; for Source_Dirs use (Obj_Dir, PolyORB_Test_Common.Source_Dir & Dir); package Compiler is for Default_Switches ("Ada") use PolyORB_Test_Common.Compiler'Default_Switches ("Ada"); end Compiler; for Main use ("test000.adb"); end local; polyorb-2.8~20110207.orig/testsuite/core/random/0000755000175000017500000000000011750740340020643 5ustar xavierxavierpolyorb-2.8~20110207.orig/testsuite/core/random/Makefile.local0000644000175000017500000000000011750740340023362 0ustar xavierxavierpolyorb-2.8~20110207.orig/testsuite/core/random/test000.adb0000644000175000017500000000463411750740340022521 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- T E S T 0 0 0 -- -- -- -- B o d y -- -- -- -- Copyright (C) 2003 Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by ACT Europe. -- -- (email: sales@act-europe.fr) -- -- -- ------------------------------------------------------------------------------ with Ada.Text_IO; with PolyORB.Utils.Random; with PolyORB.Utils.Report; procedure Test000 is use Ada.Text_IO; use PolyORB.Utils.Random; use PolyORB.Utils.Report; G : aliased PolyORB.Utils.Random.Generator; begin New_Test ("Pseudo-random generator"); Reset (G'Access, 42); for J in 1 .. 10 loop Put_Line (Random (G'Access)'Img); end loop; End_Report; end Test000; polyorb-2.8~20110207.orig/testsuite/core/random/local.gpr0000644000175000017500000000066511750740340022456 0ustar xavierxavierwith "polyorb", "polyorb_test_common"; project local is Dir := external ("Test_Dir"); Obj_Dir := PolyORB_Test_Common.Build_Dir & Dir; for Object_Dir use Obj_Dir; for Source_Dirs use (Obj_Dir, PolyORB_Test_Common.Source_Dir & Dir); package Compiler is for Default_Switches ("Ada") use PolyORB_Test_Common.Compiler'Default_Switches ("Ada"); end Compiler; for Main use ("test000.adb"); end local; polyorb-2.8~20110207.orig/testsuite/core/chained_lists/0000755000175000017500000000000011750740340022174 5ustar xavierxavierpolyorb-2.8~20110207.orig/testsuite/core/chained_lists/Makefile.local0000644000175000017500000000000011750740340024713 0ustar xavierxavierpolyorb-2.8~20110207.orig/testsuite/core/chained_lists/test000.adb0000644000175000017500000001072611750740340024051 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- T E S T 0 0 0 -- -- -- -- B o d y -- -- -- -- Copyright (C) 2008-2009, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with PolyORB.Utils.Chained_Lists; with PolyORB.Utils.Report; procedure Test000 is use PolyORB.Utils.Report; package Ls is new PolyORB.Utils.Chained_Lists (Integer, Doubly_Chained => True); use Ls; type A is array (Integer range <>) of Integer; function To_Array (L : List) return A; function To_Array (L : List) return A is Result : A (1 .. Length (L)); Index : Integer := Result'First; It : Iterator := First (L); begin while not Last (It) loop Result (Index) := Value (It).all; Index := Index + 1; Next (It); end loop; if Index /= Result'Last + 1 then raise Program_Error; end if; return Result; end To_Array; L1, L2, L3, L4 : List; Int : Integer; It : Iterator; begin Output ("empty", To_Array (L1)'Length = 0); Append (L1, 123); Output ("single L1", To_Array (L1) = (1 => 123)); Prepend (L2, 456); Output ("single L2", To_Array (L2) = (1 => 456)); Prepend (L1, 666); Output ("double L1", To_Array (L1) = (1 => 666, 2 => 123)); Append (L2, 789); Output ("double L2", To_Array (L2) = (1 => 456, 2 => 789)); L3 := L1 & 999 & 456 & 789; -- L3 is now a copy of L1 Output ("concat", To_Array (L3) = (666, 123, 999, 456, 789)); It := First (L3); while not (Last (It) or else Value (It).all = 999) loop Next (It); end loop; Output ("scan", Value (It).all = 999); Remove (L3, It); -- Note, L1 now has dangling pointers Output ("remove", To_Array (L3) = (666, 123, 456, 789)); Output ("remove iterator", Value (It).all = 456); L4 := Duplicate (L3); Element (L4, 1).all := 321; Append (L4, 555); Output ("duplicate", To_Array (L3) = (666, 123, 456, 789) and then To_Array (L4) = (666, 321, 456, 789, 555)); Extract_First (L4, Int); Output ("extract first", Int = 666 and then To_Array (L4) = (321, 456, 789, 555)); declare function Range_400_499 (X : Integer) return Boolean; function Range_400_499 (X : Integer) return Boolean is begin return X in 400 .. 499; end Range_400_499; procedure Remove is new Ls.Remove_G (Range_400_499); begin Remove (L3, All_Occurrences => True); Output ("remove multiple", To_Array (L3) = (666, 123, 789)); end; -- Deallocate (L1); -- Copied into L3, and then elements removed from L3 Deallocate (L2); Deallocate (L3); Deallocate (L4); End_Report; end Test000; polyorb-2.8~20110207.orig/testsuite/core/chained_lists/local.gpr0000644000175000017500000000066511750740340024007 0ustar xavierxavierwith "polyorb", "polyorb_test_common"; project local is Dir := external ("Test_Dir"); Obj_Dir := PolyORB_Test_Common.Build_Dir & Dir; for Object_Dir use Obj_Dir; for Source_Dirs use (Obj_Dir, PolyORB_Test_Common.Source_Dir & Dir); package Compiler is for Default_Switches ("Ada") use PolyORB_Test_Common.Compiler'Default_Switches ("Ada"); end Compiler; for Main use ("test000.adb"); end local; polyorb-2.8~20110207.orig/testsuite/core/initialization/0000755000175000017500000000000011750740340022412 5ustar xavierxavierpolyorb-2.8~20110207.orig/testsuite/core/initialization/test003.adb0000644000175000017500000000652311750740340024272 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- T E S T 0 0 3 -- -- -- -- B o d y -- -- -- -- Copyright (C) 2003-2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with Ada.Text_IO; with PolyORB.Initialization; with PolyORB.Utils.Report; with PolyORB.Utils.Strings; procedure Test003 is use Ada.Text_IO; use PolyORB.Initialization; use PolyORB.Initialization.String_Lists; use PolyORB.Utils.Report; use PolyORB.Utils.Strings; generic Name : String; procedure Init; procedure Init is begin Put_Line ("Initializing module " & Name); end Init; procedure Init_Foo is new Init ("foo"); procedure Init_Bar is new Init ("bar"); Empty_List : String_Lists.List; begin Register_Module (Module_Info' (Name => +"bar", Depends => Empty_List & "foo", Conflicts => Empty_List, Provides => Empty_List, Implicit => False, Init => Init_Bar'Unrestricted_Access, Shutdown => null)); Register_Module (Module_Info' (Name => +"foo", Depends => Empty_List & "bar", Conflicts => Empty_List, Provides => Empty_List, Implicit => False, Init => Init_Foo'Unrestricted_Access, Shutdown => null)); Initialize_World; Output ("Test initialization #3", False); exception when Program_Error => Output ("Test initialization #3", True); End_Report; when others => Output ("Test initialization #3", False); end Test003; polyorb-2.8~20110207.orig/testsuite/core/initialization/Makefile.local0000644000175000017500000000000011750740340025131 0ustar xavierxavierpolyorb-2.8~20110207.orig/testsuite/core/initialization/test000.adb0000644000175000017500000000753611750740340024274 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- T E S T 0 0 0 -- -- -- -- B o d y -- -- -- -- Copyright (C) 2002-2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with Ada.Text_IO; with PolyORB.Initialization; with PolyORB.Utils.Strings; with PolyORB.Utils.Report; procedure Test000 is use Ada.Text_IO; use PolyORB.Initialization; use PolyORB.Initialization.String_Lists; use PolyORB.Utils.Report; use PolyORB.Utils.Strings; generic Name : String; procedure Init; procedure Init is begin Put_Line ("Initializing module " & Name); end Init; procedure Init_Foo is new Init ("foo"); procedure Init_Bar is new Init ("bar"); procedure Init_Bazooka is new Init ("bazooka"); procedure Init_Fred is new Init ("fred"); Empty_List : String_Lists.List; begin Register_Module (Module_Info' (Name => +"foo", Conflicts => Empty_List, Depends => Empty_List, Provides => Empty_List, Implicit => False, Init => Init_Foo'Unrestricted_Access, Shutdown => null)); Register_Module (Module_Info' (Name => +"bar", Depends => Empty_List & "foo" & "baz", Conflicts => Empty_List, Provides => Empty_List, Implicit => False, Init => Init_Bar'Unrestricted_Access, Shutdown => null)); Register_Module (Module_Info' (Name => +"bazooka", Depends => Empty_List, Conflicts => Empty_List, Provides => Empty_List & "baz", Implicit => False, Init => Init_Bazooka'Unrestricted_Access, Shutdown => null)); Register_Module (Module_Info' (Name => +"fred", Depends => Empty_List & "bar" & "foo", Conflicts => Empty_List & "bazaar", Provides => Empty_List, Implicit => False, Init => Init_Fred'Unrestricted_Access, Shutdown => null)); Initialize_World; Output ("Test initialization #0", True); End_Report; end Test000; polyorb-2.8~20110207.orig/testsuite/core/initialization/test001.adb0000644000175000017500000001040711750740340024264 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- T E S T 0 0 1 -- -- -- -- B o d y -- -- -- -- Copyright (C) 2002-2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with Ada.Text_IO; with PolyORB.Initialization; with PolyORB.Utils.Strings; with PolyORB.Utils.Report; procedure Test001 is use Ada.Text_IO; use PolyORB.Initialization; use PolyORB.Initialization.String_Lists; use PolyORB.Utils.Report; use PolyORB.Utils.Strings; generic Name : String; procedure Init; procedure Init is begin Put_Line ("Initializing module " & Name); end Init; procedure Init_Foo is new Init ("foo"); procedure Init_Bar is new Init ("bar"); procedure Init_Bazooka is new Init ("bazooka"); procedure Init_Fred is new Init ("fred"); Empty_List : String_Lists.List; begin Register_Module (Module_Info' (Name => +"foo", Conflicts => Empty_List, Depends => Empty_List, Provides => Empty_List, Implicit => False, Init => Init_Foo'Unrestricted_Access, Shutdown => null)); Register_Module (Module_Info' (Name => +"bazaar", Conflicts => Empty_List, Depends => Empty_List, Provides => Empty_List, Implicit => False, Init => Init_Foo'Unrestricted_Access, Shutdown => null)); Register_Module (Module_Info' (Name => +"bar", Depends => Empty_List & "foo" & "baz", Conflicts => Empty_List, Provides => Empty_List, Implicit => False, Init => Init_Bar'Unrestricted_Access, Shutdown => null)); Register_Module (Module_Info' (Name => +"bazooka", Depends => Empty_List, Conflicts => Empty_List, Provides => Empty_List & "baz", Implicit => False, Init => Init_Bazooka'Unrestricted_Access, Shutdown => null)); Register_Module (Module_Info' (Name => +"fred", Depends => Empty_List & "bar" & "foo", Conflicts => Empty_List & "bazaar", Provides => Empty_List, Implicit => False, Init => Init_Fred'Unrestricted_Access, Shutdown => null)); Initialize_World; Output ("Test initialization #1", False); exception when Program_Error => Output ("Test initialization #1", True); End_Report; when others => Output ("Test initialization #1", False); end Test001; polyorb-2.8~20110207.orig/testsuite/core/initialization/test004.adb0000644000175000017500000000643011750740340024270 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- T E S T 0 0 4 -- -- -- -- B o d y -- -- -- -- Copyright (C) 2003-2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with Ada.Text_IO; with PolyORB.Initialization; with PolyORB.Utils.Report; with PolyORB.Utils.Strings; procedure Test004 is use Ada.Text_IO; use PolyORB.Initialization; use PolyORB.Initialization.String_Lists; use PolyORB.Utils.Report; use PolyORB.Utils.Strings; generic Name : String; procedure Init; procedure Init is begin Put_Line ("Initializing module " & Name); end Init; procedure Init_Bar is new Init ("bar"); Empty_List : String_Lists.List; begin Register_Module (Module_Info' (Name => +"bar", Depends => Empty_List, Conflicts => Empty_List, Provides => Empty_List, Implicit => False, Init => Init_Bar'Unrestricted_Access, Shutdown => null)); Register_Module (Module_Info' (Name => +"bar", Depends => Empty_List, Conflicts => Empty_List, Provides => Empty_List, Implicit => False, Init => Init_Bar'Unrestricted_Access, Shutdown => null)); Initialize_World; Output ("Test initialization #4", False); exception when Program_Error => Output ("Test initialization #4", True); End_Report; when others => Output ("Test initialization #4", False); end Test004; polyorb-2.8~20110207.orig/testsuite/core/initialization/local.gpr0000644000175000017500000000076111750740340024222 0ustar xavierxavierwith "polyorb", "polyorb_test_common"; project local is Dir := external ("Test_Dir"); Obj_Dir := PolyORB_Test_Common.Build_Dir & Dir; for Object_Dir use Obj_Dir; for Source_Dirs use (Obj_Dir, PolyORB_Test_Common.Source_Dir & Dir); package Compiler is for Default_Switches ("Ada") use PolyORB_Test_Common.Compiler'Default_Switches ("Ada"); end Compiler; for Main use ("test000.adb", "test001.adb", "test002.adb", "test003.adb", "test004.adb"); end local; polyorb-2.8~20110207.orig/testsuite/core/initialization/test002.adb0000644000175000017500000000730111750740340024264 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- T E S T 0 0 2 -- -- -- -- B o d y -- -- -- -- Copyright (C) 2002-2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with Ada.Text_IO; with PolyORB.Initialization; with PolyORB.Utils.Report; with PolyORB.Utils.Strings; procedure Test002 is use Ada.Text_IO; use PolyORB.Initialization; use PolyORB.Initialization.String_Lists; use PolyORB.Utils.Report; use PolyORB.Utils.Strings; generic Name : String; procedure Init; procedure Init is begin Put_Line ("Initializing module " & Name); end Init; procedure Init_Bar is new Init ("bar"); procedure Init_Bazooka is new Init ("bazooka"); procedure Init_Fred is new Init ("fred"); Empty_List : String_Lists.List; begin Register_Module (Module_Info' (Name => +"bar", Depends => Empty_List & "foo" & "baz", Conflicts => Empty_List, Provides => Empty_List, Implicit => False, Init => Init_Bar'Unrestricted_Access, Shutdown => null)); Register_Module (Module_Info' (Name => +"bazooka", Depends => Empty_List, Conflicts => Empty_List, Provides => Empty_List & "baz", Implicit => False, Init => Init_Bazooka'Unrestricted_Access, Shutdown => null)); Register_Module (Module_Info' (Name => +"fred", Depends => Empty_List & "bar" & "foo", Conflicts => Empty_List & "bazaar", Provides => Empty_List, Implicit => False, Init => Init_Fred'Unrestricted_Access, Shutdown => null)); Initialize_World; Output ("Test initialization #2", False); exception when Program_Error => Output ("Test initialization #2", True); End_Report; when others => Output ("Test initialization #2", False); end Test002; polyorb-2.8~20110207.orig/testsuite/core/uri_encoding/0000755000175000017500000000000011750740340022030 5ustar xavierxavierpolyorb-2.8~20110207.orig/testsuite/core/uri_encoding/Makefile.local0000644000175000017500000000000011750740340024547 0ustar xavierxavierpolyorb-2.8~20110207.orig/testsuite/core/uri_encoding/test000.adb0000644000175000017500000000707411750740340023707 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- T E S T 0 0 0 -- -- -- -- B o d y -- -- -- -- Copyright (C) 2005 Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with PolyORB.Utils.Report; procedure Test000 is use PolyORB.Utils; use PolyORB.Utils.Report; begin New_Test ("URI encoding & decoding"); -- The following tests are detailled in CORBA Naming Service -- Specification, v1.3, par 2.5.3.5. Output ("a.b/c.d -> " & URI_Encode ("a.b/c.d", Also_Escape => " "), URI_Encode ("a.b/c.d", Also_Escape => " ") = "a.b/c.d"); Output (".b/c.d -> " & URI_Encode (".b/c.d", Also_Escape => " "), URI_Encode (".b/c.d", Also_Escape => " ") = "%3ca%3e.b/c.d"); Output ("a.b/ c.d -> " & URI_Encode ("a.b/ c.d", Also_Escape => " "), URI_Encode ("a.b/ c.d", Also_Escape => " ") = "a.b/%20%20c.d"); Output ("a%b/c%d -> " & URI_Encode ("a%b/c%d", Also_Escape => " "), URI_Encode ("a%b/c%d", Also_Escape => " ") = "a%25b/c%25d"); Output ("a\\b/c.d -> " & URI_Encode ("a\\b/c.d", Also_Escape => " "), URI_Encode ("a\\b/c.d", Also_Escape => " ") = "a%5c%5cb/c.d"); Output ("a.b/c.d -> " & URI_Decode ("a.b/c.d"), URI_Decode ("a.b/c.d") = "a.b/c.d"); Output ("%3ca%3e.b/c.d -> " & URI_Decode ("%3ca%3e.b/c.d"), URI_Decode ("%3ca%3e.b/c.d") = ".b/c.d"); Output ("a.b/%20%20c.d -> " & URI_Decode ("a.b/%20%20c.d"), URI_Decode ("a.b/%20%20c.d") = "a.b/ c.d"); Output ("a%25b/c%25d -> " & URI_Decode ("a%25b/c%25d"), URI_Decode ("a%25b/c%25d") = "a%b/c%d"); Output ("a%5c%5cb/c.d -> " & URI_Decode ("a%5c%5cb/c.d"), URI_Decode ("a%5c%5cb/c.d") = "a\\b/c.d"); End_Report; end Test000; polyorb-2.8~20110207.orig/testsuite/core/uri_encoding/local.gpr0000644000175000017500000000066511750740340023643 0ustar xavierxavierwith "polyorb", "polyorb_test_common"; project local is Dir := external ("Test_Dir"); Obj_Dir := PolyORB_Test_Common.Build_Dir & Dir; for Object_Dir use Obj_Dir; for Source_Dirs use (Obj_Dir, PolyORB_Test_Common.Source_Dir & Dir); package Compiler is for Default_Switches ("Ada") use PolyORB_Test_Common.Compiler'Default_Switches ("Ada"); end Compiler; for Main use ("test000.adb"); end local; polyorb-2.8~20110207.orig/testsuite/core/any/0000755000175000017500000000000011750740340020152 5ustar xavierxavierpolyorb-2.8~20110207.orig/testsuite/core/any/Makefile.local0000644000175000017500000000000011750740340022671 0ustar xavierxavierpolyorb-2.8~20110207.orig/testsuite/core/any/test000.adb0000644000175000017500000000541411750740340022025 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- T E S T 0 0 0 -- -- -- -- B o d y -- -- -- -- Copyright (C) 2003 Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by ACT Europe. -- -- (email: sales@act-europe.fr) -- -- -- ------------------------------------------------------------------------------ with PolyORB.Any; with PolyORB.Initialization; with PolyORB.Types; with PolyORB.Utils.Report; with PolyORB.Setup.Client; pragma Warnings (Off, PolyORB.Setup.Client); procedure Test000 is use PolyORB.Any; use PolyORB.Utils.Report; use PolyORB.Types; procedure Simple_Test; ----------------- -- Simple_Test -- ----------------- procedure Simple_Test is A : Any; Initial_Value : constant PolyORB.Types.Short := PolyORB.Types.Short (2); Value : PolyORB.Types.Short; begin A := To_Any (PolyORB.Types.Short (2)); Value := From_Any (A); Output ("Any: Short", Value = Initial_Value); end Simple_Test; begin PolyORB.Initialization.Initialize_World; Simple_Test; End_Report; end Test000; polyorb-2.8~20110207.orig/testsuite/core/any/local.gpr0000644000175000017500000000066511750740340021765 0ustar xavierxavierwith "polyorb", "polyorb_test_common"; project local is Dir := external ("Test_Dir"); Obj_Dir := PolyORB_Test_Common.Build_Dir & Dir; for Object_Dir use Obj_Dir; for Source_Dirs use (Obj_Dir, PolyORB_Test_Common.Source_Dir & Dir); package Compiler is for Default_Switches ("Ada") use PolyORB_Test_Common.Compiler'Default_Switches ("Ada"); end Compiler; for Main use ("test000.adb"); end local; polyorb-2.8~20110207.orig/testsuite/core/dynamic_dict/0000755000175000017500000000000011750740340022012 5ustar xavierxavierpolyorb-2.8~20110207.orig/testsuite/core/dynamic_dict/Makefile.local0000644000175000017500000000000011750740340024531 0ustar xavierxavierpolyorb-2.8~20110207.orig/testsuite/core/dynamic_dict/test000.adb0000644000175000017500000001650211750740340023665 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- T E S T 0 0 0 -- -- -- -- B o d y -- -- -- -- Copyright (C) 2002-2005 Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by ACT Europe. -- -- (email: sales@act-europe.fr) -- -- -- ------------------------------------------------------------------------------ with PolyORB.Dynamic_Dict; with PolyORB.Utils.Report; with PolyORB.Utils.Strings; procedure Test000 is use PolyORB.Utils.Report; use PolyORB.Utils.Strings; package My_Dict is new PolyORB.Dynamic_Dict (Value => String_Ptr); --------------------- -- Test_Regression -- --------------------- procedure Test_Regression; -- This particular configuration raised an exception. procedure Test_Regression is Values : constant array (Positive range <>) of String_Ptr := (+"tasking.profiles.full_tasking.threads", +"tasking.threads", +"tasking.profiles.full_tasking.mutexes", +"tasking.mutexes", +"tasking.profiles.full_tasking.condition_variables", +"tasking.condition_variables", +"exceptions.stack", +"exceptions", +"smart_pointers", +"binding_data.iiop", +"protocols.giop", +"orb.thread_pool", +"orb.tasking_policy", +"orb.threads_init", +"orb.tasking_policy_init", +"orb", +"corba.orb", +"corba.initial_references", +"tcp_access_points.corba", +"tcp_access_points.srp", +"tasking.soft_links", +"soft_links"); Result : String_Ptr; begin for J in Values'Range loop My_Dict.Register (Values (J).all, +"foo"); for K in Values'First .. J loop Result := My_Dict.Lookup (Values (K).all, Default => null); if Result = null or else Result.all /= "foo" then Output ("Regression occured for key " & Values (K).all & " at stage #" & Integer'Image (J), False); raise Program_Error; end if; end loop; end loop; for J in Values'Range loop My_Dict.Unregister (Values (J).all); end loop; Output ("Check no exception is raised", True); exception when others => Output ("Check no exception is raised", False); end Test_Regression; ------------------- -- Test_Register -- ------------------- procedure Test_Register (How_Many : Natural); procedure Test_Register (How_Many : Natural) is Key_Root : constant String := "Key"; Value_Root : constant String := "Root"; procedure Test_Lookup (How_Many : Natural); procedure Test_Lookup (How_Many : Natural) is Key_Root : constant String := "Key"; Value_Root : constant String := "Root"; begin for J in 1 .. How_Many loop declare Count : constant String := Natural'Image (J); Key : constant String := Key_Root & Count (Count'First + 1 .. Count'Last); Content : constant String_Ptr := My_Dict.Lookup (Key, Default => null); Value : constant String := Value_Root & Count (Count'First + 1 .. Count'Last); begin if Content = null or else Value /= Content.all then Output ("Regression occured for key " & Key & " at stage #" & Integer'Image (How_Many), False); raise Program_Error; end if; end; end loop; end Test_Lookup; begin for J in 1 .. How_Many loop declare Count : constant String := Natural'Image (J); Key : constant String := Key_Root & Count (Count'First + 1 .. Count'Last); Value : constant String := Value_Root & Count (Count'First + 1 .. Count'Last); begin My_Dict.Register (Key, +Value); Test_Lookup (J); end; end loop; Output ("Register", True); end Test_Register; ------------------- -- Test_For_Each -- ------------------- procedure Test_For_Each; -- Test for generic key/value associations iterator subtype Indices is Integer range 1 .. 64; type Bool_Arr is array (Indices) of Boolean; Seen : Bool_Arr := (others => False); function Value_For (J : Indices) return String; function Value_For (J : Indices) return String is begin return "-->" & J'Img & "<--"; end Value_For; procedure Check_Association (K : String; V : String_Ptr); procedure Check_Association (K : String; V : String_Ptr) is J : Indices; begin J := Indices'Value (K); if V.all /= Value_For (J) then Output ("Invalid association:" & K & " => " & V.all, False); elsif Seen (J) then Output ("Key" & K & "already seen", False); else Seen (J) := True; end if; exception when others => Output ("invalid key: " & K, False); end Check_Association; procedure Test_For_Each is Val : array (Indices) of String_Ptr; begin My_Dict.Reset; for J in Val'Range loop My_Dict.Register (J'Img, +Value_For (J)); end loop; My_Dict.For_Each (Check_Association'Access); Output ("test For_Each", Seen = Bool_Arr'(others => True)); end Test_For_Each; begin Output ("Initialization", True); Test_Register (500); Test_Regression; Test_For_Each; End_Report; end Test000; polyorb-2.8~20110207.orig/testsuite/core/dynamic_dict/local.gpr0000644000175000017500000000066511750740340023625 0ustar xavierxavierwith "polyorb", "polyorb_test_common"; project local is Dir := external ("Test_Dir"); Obj_Dir := PolyORB_Test_Common.Build_Dir & Dir; for Object_Dir use Obj_Dir; for Source_Dirs use (Obj_Dir, PolyORB_Test_Common.Source_Dir & Dir); package Compiler is for Default_Switches ("Ada") use PolyORB_Test_Common.Compiler'Default_Switches ("Ada"); end Compiler; for Main use ("test000.adb"); end local; polyorb-2.8~20110207.orig/testsuite/core/naming/0000755000175000017500000000000011750740340020634 5ustar xavierxavierpolyorb-2.8~20110207.orig/testsuite/core/naming/Makefile.local0000644000175000017500000000000011750740340023353 0ustar xavierxavierpolyorb-2.8~20110207.orig/testsuite/core/naming/test000.adb0000644000175000017500000000726611750740340022516 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- T E S T 0 0 0 -- -- -- -- B o d y -- -- -- -- Copyright (C) 2002-2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- Testing naming client. Use the CORBA COS Naming API. with Ada.Command_Line; use Ada.Command_Line; with Ada.Text_IO; use Ada.Text_IO; with PolyORB.Setup.Client; pragma Warnings (Off, PolyORB.Setup.Client); with PolyORB.Initialization; with PolyORB.References; with PolyORB.Services.Naming.NamingContext.Client; with PolyORB.Services.Naming.NamingContext.Helper; procedure Test000 is use PolyORB.References; use PolyORB.Services.Naming; use PolyORB.Services.Naming.NamingContext; use PolyORB.Services.Naming.NamingContext.Client; use PolyORB.Services.Naming.NamingContext.Helper; Ref_Context : PolyORB.References.Ref; begin -- Initialization PolyORB.Initialization.Initialize_World; if Argument_Count < 1 then Put_Line ("usage : test_naming_generic "); return; end if; String_To_Object (Ada.Command_Line.Argument (1), Ref_Context); -- -- Test 1 : bind 1 object, lookup and then destroy -- declare Obj_Name : PolyORB.Services.Naming.Name; Rcvd_Ref : PolyORB.References.Ref; -- pragma Unreferenced (Rcvd_Ref); pragma Warnings (Off, Rcvd_Ref); -- WAG:5.02 DB08-008 -- Assigned but never read Root_Context : constant PolyORB.Services.Naming.NamingContext.Ref := To_Ref (Ref_Context); begin Append (Obj_Name, NameComponent'(id => To_PolyORB_String ("object1"), kind => To_PolyORB_String (""))); Bind (Root_Context, Obj_Name, Ref_Context); Rcvd_Ref := Resolve (Root_Context, Obj_Name); Unbind (Root_Context, Obj_Name); Rcvd_Ref := Resolve (Root_Context, Obj_Name); end; end Test000; polyorb-2.8~20110207.orig/testsuite/core/naming/local.gpr0000644000175000017500000000066511750740340022447 0ustar xavierxavierwith "polyorb", "polyorb_test_common"; project local is Dir := external ("Test_Dir"); Obj_Dir := PolyORB_Test_Common.Build_Dir & Dir; for Object_Dir use Obj_Dir; for Source_Dirs use (Obj_Dir, PolyORB_Test_Common.Source_Dir & Dir); package Compiler is for Default_Switches ("Ada") use PolyORB_Test_Common.Compiler'Default_Switches ("Ada"); end Compiler; for Main use ("test000.adb"); end local; polyorb-2.8~20110207.orig/testsuite/core/sync_policies/0000755000175000017500000000000011750740340022226 5ustar xavierxavierpolyorb-2.8~20110207.orig/testsuite/core/sync_policies/Makefile.local0000644000175000017500000000000011750740340024745 0ustar xavierxavierpolyorb-2.8~20110207.orig/testsuite/core/sync_policies/server_no_tasking.adb0000644000175000017500000000465411750740340026431 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- S E R V E R _ N O _ T A S K I N G -- -- -- -- B o d y -- -- -- -- Copyright (C) 2002-2008, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- Setup a test server with no tasking at all. with PolyORB.Initialization; with PolyORB.ORB; with PolyORB.Setup.No_Tasking_Server; pragma Warnings (Off, PolyORB.Setup.No_Tasking_Server); with Server_Common; procedure Server_No_Tasking is begin PolyORB.Initialization.Initialize_World; Server_Common.Initialize_Test_Object; PolyORB.ORB.Run (PolyORB.Setup.The_ORB, May_Exit => False); end Server_No_Tasking; polyorb-2.8~20110207.orig/testsuite/core/sync_policies/ping_object.adb0000644000175000017500000000754311750740340025172 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P I N G _ O B J E C T -- -- -- -- B o d y -- -- -- -- Copyright (C) 2002-2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with Ada.Exceptions; with Ada.Text_IO; with PolyORB.Any; with PolyORB.Any.NVList; with PolyORB.Types; with PolyORB.Errors; package body Ping_Object is use Ada.Text_IO; use PolyORB.Any; use PolyORB.Requests; Count : Natural := 0; -- Count number of invocations --------------------- -- Execute_Servant -- --------------------- function Execute_Servant (Obj : not null access My_Object; Req : PolyORB.Requests.Request_Access) return Boolean is pragma Unreferenced (Obj); use PolyORB.Any.NVList; use PolyORB.Any.NVList.Internals; use PolyORB.Any.NVList.Internals.NV_Lists; use PolyORB.Errors; use PolyORB.Types; Args : PolyORB.Any.NVList.Ref; Error : Error_Container; begin Put_Line ("The server is executing the request:" & PolyORB.Requests.Image (Req.all)); Create (Args); if Req.all.Operation.all = "ping" then Add_Item (Args, (Name => To_PolyORB_String ("S"), Argument => Get_Empty_Any (TypeCode.TC_String), Arg_Modes => PolyORB.Any.ARG_IN)); Arguments (Req, Args, Error); if Found (Error) then raise Program_Error; -- XXX We should do something more constructive end if; -- Actual implementation of the echoString function: -- simply return the argument Count := Count + 1; Put_Line ("Pong !" & Count'Img); Req.Result.Argument := To_Any (Get_Empty_Any (TypeCode.TC_Void)); else raise Program_Error; end if; return True; exception when E : others => Put_Line ("Handle_Message: Got exception " & Ada.Exceptions.Exception_Information (E)); raise; end Execute_Servant; end Ping_Object; polyorb-2.8~20110207.orig/testsuite/core/sync_policies/server_common.adb0000644000175000017500000001061111750740340025553 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- S E R V E R _ C O M M O N -- -- -- -- B o d y -- -- -- -- Copyright (C) 2002-2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with Ada.Exceptions; with Ada.Text_IO; with PolyORB.Errors; with PolyORB.Obj_Adapters; with PolyORB.Objects; with PolyORB.Servants; with PolyORB.ORB; with PolyORB.POA; with PolyORB.POA_Manager; with PolyORB.POA_Types; with PolyORB.References; with PolyORB.References.IOR; with PolyORB.Types; with PolyORB.Setup; with Ping_Object; package body Server_Common is use Ada.Text_IO; use PolyORB.Errors; use PolyORB.Objects; use PolyORB.ORB; use PolyORB.POA; use PolyORB.Setup; use PolyORB.References; use Ping_Object; My_Servant : PolyORB.Servants.Servant_Access; My_Ref : PolyORB.References.Ref; ---------------------------- -- Initialize_Test_Object -- ---------------------------- procedure Initialize_Test_Object is My_Id : PolyORB.Objects.Object_Id_Access; Error : Error_Container; Obj_Adapter : constant PolyORB.Obj_Adapters.Obj_Adapter_Access := PolyORB.ORB.Object_Adapter (PolyORB.Setup.The_ORB); URI : PolyORB.Types.String; begin PolyORB.POA_Manager.Activate (PolyORB.POA_Manager.POAManager_Access (PolyORB.POA_Manager.Entity_Of (PolyORB.POA.Obj_Adapter (Obj_Adapter.all).POA_Manager)), Error); My_Servant := new Ping_Object.My_Object; -- Create application server object PolyORB.Obj_Adapters.Export (Obj_Adapter, My_Servant, null, My_Id, Error); -- Register it with the POA if Found (Error) then raise Program_Error; end if; Put_Line ("Registered object: " & PolyORB.Objects.Image (My_Id.all)); Create_Reference (The_ORB, My_Id, "IDL:Ping:1.0", My_Ref); -- Obtain object reference PolyORB.POA_Types.Oid_To_Rel_URI (PolyORB.POA_Types.Obj_Adapter (Obj_Adapter.all)'Access, My_Id, URI, Error); Put_Line ("Reference is : " & PolyORB.References.Image (My_Ref)); Put_Line ("URI is : " & PolyORB.Types.To_Standard_String (URI)); begin Put_Line ("IOR is : " & PolyORB.References.IOR.Object_To_String (My_Ref)); exception when E : others => Put_Line ("Warning: Object_To_String raised:"); Put_Line (Ada.Exceptions.Exception_Information (E)); end; Put_Line (" done."); end Initialize_Test_Object; end Server_Common; polyorb-2.8~20110207.orig/testsuite/core/sync_policies/local.gpr0000644000175000017500000000071511750740340024035 0ustar xavierxavierwith "polyorb", "polyorb_test_common"; project local is Dir := external ("Test_Dir"); Obj_Dir := PolyORB_Test_Common.Build_Dir & Dir; for Object_Dir use Obj_Dir; for Source_Dirs use (Obj_Dir, PolyORB_Test_Common.Source_Dir & Dir); package Compiler is for Default_Switches ("Ada") use PolyORB_Test_Common.Compiler'Default_Switches ("Ada"); end Compiler; for Main use ("client.adb", "server_no_tasking.adb"); end local; polyorb-2.8~20110207.orig/testsuite/core/sync_policies/server_common.ads0000644000175000017500000000416511750740340025603 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- S E R V E R _ C O M M O N -- -- -- -- S p e c -- -- -- -- Copyright (C) 2002-2004 Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by ACT Europe. -- -- (email: sales@act-europe.fr) -- -- -- ------------------------------------------------------------------------------ package Server_Common is pragma Elaborate_Body; procedure Initialize_Test_Object; end Server_Common; polyorb-2.8~20110207.orig/testsuite/core/sync_policies/ping_object.ads0000644000175000017500000000451311750740340025205 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P I N G _ O B J E C T -- -- -- -- S p e c -- -- -- -- Copyright (C) 2002-2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with PolyORB.Requests; with PolyORB.Servants; package Ping_Object is pragma Elaborate_Body; type My_Object is new PolyORB.Servants.Servant with null record; overriding function Execute_Servant (Obj : not null access My_Object; Req : PolyORB.Requests.Request_Access) return Boolean; end Ping_Object; polyorb-2.8~20110207.orig/testsuite/core/sync_policies/client.adb0000644000175000017500000001060111750740340024152 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- C L I E N T -- -- -- -- B o d y -- -- -- -- Copyright (C) 2004-2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with Ada.Command_Line; with Ada.Text_IO; with PolyORB.Any.ExceptionList; with PolyORB.Any.NVList; with PolyORB.Components; with PolyORB.Initialization; with PolyORB.ORB.Iface; with PolyORB.References; with PolyORB.Requests; with PolyORB.Types; with PolyORB.Setup.Client; pragma Warnings (Off, PolyORB.Setup.Client); with PolyORB.Utils.Report; procedure Client is use Ada.Text_IO; use PolyORB.Utils.Report; ------------------- -- Issue_Request -- ------------------- procedure Issue_Request (Obj_Ref : PolyORB.References.Ref; Req_Flags : PolyORB.Requests.Flags); procedure Issue_Request (Obj_Ref : PolyORB.References.Ref; Req_Flags : PolyORB.Requests.Flags) is use PolyORB.Any; use PolyORB.Any.NVList; use PolyORB.Components; use PolyORB.ORB.Iface; use PolyORB.Requests; use PolyORB.Types; Req : Request_Access; Args : PolyORB.Any.NVList.Ref; Result : PolyORB.Any.NamedValue; begin Create (Args); Add_Item (Args, To_PolyORB_String ("ping"), To_Any (To_PolyORB_String ("ping !")), ARG_IN); Create_Request (Obj_Ref, "ping", Args, Result, PolyORB.Any.ExceptionList.Nil_Ref, Req, Req_Flags); Output ("Created servant request with flag" & PolyORB.Requests.Flags'Image (Req_Flags), True); Emit_No_Reply (Component_Access (PolyORB.Setup.The_ORB), Queue_Request'(Request => Req, Requestor => null)); PolyORB.ORB.Run (PolyORB.Setup.The_ORB, Request => Req, May_Exit => True); end Issue_Request; begin New_Test ("Request synchronization policies"); PolyORB.Initialization.Initialize_World; if Ada.Command_Line.Argument_Count < 1 then Put_Line ("usage : client "); return; end if; declare Obj_Ref : PolyORB.References.Ref; begin PolyORB.References.String_To_Object (Ada.Command_Line.Argument (1), Obj_Ref); Issue_Request (Obj_Ref, PolyORB.Requests.Sync_None); Issue_Request (Obj_Ref, PolyORB.Requests.Sync_With_Transport); Issue_Request (Obj_Ref, PolyORB.Requests.Sync_With_Server); Issue_Request (Obj_Ref, PolyORB.Requests.Sync_With_Target); end; End_Report; end Client; polyorb-2.8~20110207.orig/testsuite/idls/0000755000175000017500000000000011750740340017366 5ustar xavierxavierpolyorb-2.8~20110207.orig/testsuite/idls/types013/0000755000175000017500000000000011750740340020756 5ustar xavierxavierpolyorb-2.8~20110207.orig/testsuite/idls/types013/test.out0000644000175000017500000000060111750740340022463 0ustar xavierxavierBOOLEAN := True SHORT := True LONG := True USHORT := True ULONG := True ULONGLONG := True FLOAT := True DOUBLE := True CHAR := True WCHAR := True OCTET := True STRING := True WSTRING := True OBJECT := True TYPECODE := True ALIAS := True ENUM := True ARRAY_T := True EXCEPT := True VOID := True UNION := True STRUCT := True FIXED := True SEQUENCE := True LONGDOUBLE := True ANY := True polyorb-2.8~20110207.orig/testsuite/idls/types013/tin.idl0000644000175000017500000000570111750740340022245 0ustar xavierxavierinterface tin { // Simple types // ------------ boolean echoBoolean(in boolean arg) ; short echoShort(in short arg) ; long echoLong(in long arg) ; unsigned short echoUShort(in unsigned short arg) ; unsigned long echoULong(in unsigned long arg) ; unsigned long long echoULLong(in unsigned long long arg) ; float echoFloat(in float arg) ; double echoDouble(in double arg) ; char echoChar(in char arg) ; wchar echoWChar(in wchar arg) ; octet echoOctet (in octet arg) ; string echoString (in string arg) ; wstring echoWString (in wstring arg) ; tin echoRef (in tin arg); Object echoObject (in Object arg); typedef tin otherAllTypes; typedef Object otherObject; otherAllTypes echoOtherAllTypes (in otherAllTypes arg); otherObject echoOtherObject (in otherObject arg); // Enum // ---- enum Color { Red, Green, Blue }; Color echoColor (in Color arg); // Array of enum typedef Color Rainbow[7]; Rainbow echoRainbow (in Rainbow arg); // Exceptions // ---------- exception my_exception {long info;}; void testException (in long arg) raises (my_exception); void testUnknownException (in long arg); void testSystemException (in long arg); // Unions // ------ union myUnion switch (long) { case 1: long Counter; case 2: boolean Flag; case 3: Color Hue; default: long Unknown; }; myUnion echoUnion (in myUnion arg); union myUnionEnumSwitch switch (Color) { case Red: long foo; case Green: short bar; case Blue: string baz; }; myUnionEnumSwitch echoUnionEnumSwitch (in myUnionEnumSwitch arg); // Arrays // ------ typedef long simple_array[5]; simple_array echoArray (in simple_array arg); // Multi-dimensional arrays // ------------------------ typedef long matrix[3][3]; matrix echoMatrix (in matrix arg); typedef long bigmatrix[30][15]; bigmatrix echoBigMatrix (in bigmatrix arg); // Big arrays // ---------- typedef long sixteenKb[64][64]; sixteenKb echoSixteenKb (in sixteenKb arg); // Structs // ------- struct simple_struct { long a; string s; }; simple_struct echoStruct (in simple_struct arg); struct array_struct { long a[10]; unsigned short b; }; array_struct echoArrayStruct (in array_struct arg); struct composite_struct { fixed<12,3> fixedMember; sequence > seqseqMember; long double matrixMember[3][4]; }; struct nested_struct { simple_struct ns; }; nested_struct echoNestedStruct (in nested_struct arg); // Sequences // --------- typedef sequence U_sequence; U_sequence echoUsequence (in U_sequence arg); typedef sequence B_sequence; B_sequence echoBsequence (in B_sequence arg); // Fixed point // ----------- typedef fixed<18,2> Money; Money echoMoney (in Money arg); // Attributes // ---------- readonly attribute long Counter; attribute Color myColor; void StopServer (); // Shut down server }; polyorb-2.8~20110207.orig/testsuite/idls/test034/0000755000175000017500000000000011750740340020574 5ustar xavierxavierpolyorb-2.8~20110207.orig/testsuite/idls/test034/test.out0000644000175000017500000001641411750740340022312 0ustar xavierxaviertypedef struct Orange44 { struct Sultana44 { sequence, 18>, 13>> GaliaMelon44[15]; } Turnip44; } LoganBerry44; typedef struct Lemon45 { struct Banana45 { sequence, 11>, 7>> Apple45; } Carrots45; } BlackCherry45; typedef struct Kiwi45 { struct GalaApple45 { sequence, 19>>, 12> Celeriac45[6]; } Cauliflower45; } Corriander45; typedef struct Parsley46 { struct Peach46 { sequence, 9>>, 7> Corn46; } Squash46; } YellowPepper46; typedef struct Sharanfruit47 { struct BeefTomatoes47 { sequence, 2>>> RedPepper47[5]; } FrenchBeans47; } Radish47; typedef struct Cress48 { struct Lettuce48 { sequence, 3>>> Tarragon48; } Mangetout48; } BambooShoot48; typedef struct Zucchini49 { struct Plum49 { sequence>, 3>, 17> Shallots49[6]; } KidneyBean49; } ButterBean49; typedef struct Bayleaf50 { struct WhiteCabbage50 { sequence, 6>, 18> Celery50; } Aniseed50; } Dill50; typedef struct Mango51 { struct PassionFruit51 { sequence>, 11>> Rhubarb51[7]; } Pumpkin51; } WaterMelon51; typedef struct Potato51 { struct ChineseLeaves51 { sequence> RedCabbage51; } Broadbeans51; } Record51; typedef struct Blueberry52 { struct Basil52 { sequence Peanuts52[5]; } CoxPippin52; } Blackberry52; typedef struct Rasin53 { struct Artichokes53 { struct Peanutsquash53 { double Damsons53[2]; } CherryTomatoes53; } GreenGrapes53; } CookingApple53; typedef struct Peppercorn54 { struct Cherry54 { struct Okra54 { unsigned short Beetroot54; } Radish54[16]; } Papaya54; } Susander54; typedef struct Pear55 { struct LimaBean55 { struct Blackcurrant55 { sequence Plantain55; } Pineapple55; } Mangosteen55; } RedPepper55; typedef struct Uglifruit56 { struct Walnuts56 { struct Pomegranate56 { sequence Sweedes56[5]; } Kumquats56[14]; } Fennell56; } Waterchestnut56; typedef struct Cassava57 { struct Cress57 { struct Lettuce57 { sequence Tarragon57[11]; } Mangetout57; } BambooShoot57; } Melon57; typedef struct Strawberry58 { struct Daikan58 { struct Avocado58 { sequence ButterBean58; } Cloves58[14]; } Mustard58; } BreadFruit58; typedef struct HazelNut59 { struct CrabApple59 { struct Lentil59 { sequence GoldenDelicous59; } Fig59; } RedOnion59; } Cinnamon59; typedef struct Plum60 { struct Onion60 { struct Tofu60 { sequence> Runnerbean60[1]; } Sweetcorn60[16]; } Shallots60; } KidneyBean60; typedef struct Tangarine61 { struct BrazilNut61 { struct Brocoli61 { sequence> Prunes61[8]; } GrannySmith61; } SweetPotato61; } Billberries61; typedef struct Almonds62 { struct Oregano62 { struct Asparagus62 { sequence> GardenPeas62; } Dill62[8]; } Beansprout62; } Guava62; typedef struct Parsnip63 { struct Orange63 { struct Sultana63 { sequence> GaliaMelon63; } Turnip63; } LoganBerry63; } Celery63; typedef struct BlackEyedBeans64 { struct Ginger64 { struct Starfruit64 { sequence, 3> BlackCherry64[7]; } Cucumber64[6]; } Apricots64; } Leek64; typedef struct Lime65 { struct Mango65 { struct PassionFruit65 { sequence, 3> Rhubarb65[2]; } Pumpkin65; } WaterMelon65; } Dates65; typedef struct Banana66 { struct PentlandDell65 { struct Homeguard65 { sequence, 13> Record65; } KingEdward65[3]; } Apple66; } Carrots66; interface idlServer { exception LoganBerry44Excpt { LoganBerry44 ex1; }; attribute LoganBerry44 LoganBerry44Attr; LoganBerry44 LoganBerry44Op(in LoganBerry44 p1, out LoganBerry44 p2, inout LoganBerry44 p3) raises (idlServer::LoganBerry44Excpt); exception Orange44Excpt { Orange44 ex1; }; attribute Orange44 Orange44Attr; Orange44 Orange44Op(in Orange44 p1, out Orange44 p2, inout Orange44 p3) raises (idlServer::Orange44Excpt); exception Sultana44Excpt { Orange44::Sultana44 ex1; }; attribute Orange44::Sultana44 Sultana44Attr; Orange44::Sultana44 Sultana44Op(in Orange44::Sultana44 p1, out Orange44::Sultana44 p2, inout Orange44::Sultana44 p3) raises (idlServer::Sultana44Excpt); exception BlackCherry45Excpt { BlackCherry45 ex1; }; attribute BlackCherry45 BlackCherry45Attr; BlackCherry45 BlackCherry45Op(in BlackCherry45 p1, out BlackCherry45 p2, inout BlackCherry45 p3) raises (idlServer::BlackCherry45Excpt); exception Lemon45Excpt { Lemon45 ex1; }; attribute Lemon45 Lemon45Attr; Lemon45 Lemon45Op(in Lemon45 p1, out Lemon45 p2, inout Lemon45 p3) raises (idlServer::Lemon45Excpt); exception Banana45Excpt { Lemon45::Banana45 ex1; }; attribute Lemon45::Banana45 Banana45Attr; Lemon45::Banana45 Banana45Op(in Lemon45::Banana45 p1, out Lemon45::Banana45 p2, inout Lemon45::Banana45 p3) raises (idlServer::Banana45Excpt); exception Corriander45Excpt { Corriander45 ex1; }; attribute Corriander45 Corriander45Attr; Corriander45 Corriander45Op(in Corriander45 p1, out Corriander45 p2, inout Corriander45 p3) raises (idlServer::Corriander45Excpt); exception Kiwi45Excpt { Kiwi45 ex1; }; attribute Kiwi45 Kiwi45Attr; Kiwi45 Kiwi45Op(in Kiwi45 p1, out Kiwi45 p2, inout Kiwi45 p3) raises (idlServer::Kiwi45Excpt); exception GalaApple45Excpt { Kiwi45::GalaApple45 ex1; }; attribute Kiwi45::GalaApple45 GalaApple45Attr; Kiwi45::GalaApple45 GalaApple45Op(in Kiwi45::GalaApple45 p1, out Kiwi45::GalaApple45 p2, inout Kiwi45::GalaApple45 p3) raises (idlServer::GalaApple45Excpt); exception YellowPepper46Excpt { YellowPepper46 ex1; }; attribute YellowPepper46 YellowPepper46Attr; YellowPepper46 YellowPepper46Op(in YellowPepper46 p1, out YellowPepper46 p2, inout YellowPepper46 p3) raises (idlServer::YellowPepper46Excpt); exception Parsley46Excpt { Parsley46 ex1; }; attribute Parsley46 Parsley46Attr; Parsley46 Parsley46Op(in Parsley46 p1, out Parsley46 p2, inout Parsley46 p3) raises (idlServer::Parsley46Excpt); exception Peach46Excpt { Parsley46::Peach46 ex1; }; attribute Parsley46::Peach46 Peach46Attr; Parsley46::Peach46 Peach46Op(in Parsley46::Peach46 p1, out Parsley46::Peach46 p2, inout Parsley46::Peach46 p3) raises (idlServer::Peach46Excpt); exception Radish47Excpt { Radish47 ex1; }; attribute Radish47 Radish47Attr; Radish47 Radish47Op(in Radish47 p1, out Radish47 p2, inout Radish47 p3) raises (idlServer::Radish47Excpt); exception Sharanfruit47Excpt { Sharanfruit47 ex1; }; attribute Sharanfruit47 Sharanfruit47Attr; Sharanfruit47 Sharanfruit47Op(in Sharanfruit47 p1, out Sharanfruit47 p2, inout Sharanfruit47 p3) raises (idlServer::Sharanfruit47Excpt); exception BeefTomatoes47Excpt { Sharanfruit47::BeefTomatoes47 ex1; }; attribute Sharanfruit47::BeefTomatoes47 BeefTomatoes47Attr; Sharanfruit47::BeefTomatoes47 BeefTomatoes47Op(in Sharanfruit47::BeefTomatoes47 p1, out Sharanfruit47::BeefTomatoes47 p2, inout Sharanfruit47::BeefTomatoes47 p3) raises (idlServer::BeefTomatoes47Excpt); exception BambooShoot48Excpt { BambooShoot48 ex1; }; attribute BambooShoot48 BambooShoot48Attr; BambooShoot48 BambooShoot48Op(in BambooShoot48 p1, out BambooShoot48 p2, inout BambooShoot48 p3) raises (idlServer::BambooShoot48Excpt); }; polyorb-2.8~20110207.orig/testsuite/idls/idl15031/0000755000175000017500000000000011750740340020530 5ustar xavierxavierpolyorb-2.8~20110207.orig/testsuite/idls/idl15031/test.out0000644000175000017500000000017711750740340022245 0ustar xavierxaviertypedef short TempType; module M { typedef string ArgType; struct S { M::ArgType a1; M::ArgType a2; TempType temp; }; }; polyorb-2.8~20110207.orig/testsuite/idls/idl15031/tin.idl0000644000175000017500000000054711750740340022022 0ustar xavierxaviertypedef short TempType; // Scope of TempType begins here module M { typedef string ArgType; // Scope of ArgType begins here struct S { ::M::ArgType a1; // Nothing introduced here M::ArgType a2; // M introduced here ::TempType temp; // Nothing introduced here }; // Scope of (introduced) M ends here // ... }; // Scope of ArgType ends here polyorb-2.8~20110207.orig/testsuite/idls/idl15025/0000755000175000017500000000000011750740340020533 5ustar xavierxavierpolyorb-2.8~20110207.orig/testsuite/idls/idl15025/test.out0000644000175000017500000000035511750740340022246 0ustar xavierxaviermodule M { typedef long ArgType; typedef M::ArgType AType; interface B { typedef string ArgType; M::B::ArgType opb(in M::AType i); }; }; module N { typedef char ArgType; interface Y : M::B { void opy(in M::B::ArgType i); }; }; polyorb-2.8~20110207.orig/testsuite/idls/idl15025/tin.idl0000644000175000017500000000044211750740340022017 0ustar xavierxaviermodule M { typedef long ArgType; typedef ArgType AType; // line l1 interface B { typedef string ArgType; // line l3 ArgType opb(in AType i); // line l2 }; }; module N { typedef char ArgType; // line l4 interface Y : M::B { void opy(in ArgType i); // line l5 }; }; polyorb-2.8~20110207.orig/testsuite/idls/aif_b01/0000755000175000017500000000000011750740340020567 5ustar xavierxavierpolyorb-2.8~20110207.orig/testsuite/idls/aif_b01/test.out0000644000175000017500000000011511750740340022274 0ustar xavierxavierabstract interface AbsInf { short op(); }; interface Itfderiv : AbsInf { }; polyorb-2.8~20110207.orig/testsuite/idls/aif_b01/tin.idl0000644000175000017500000000043211750740340022052 0ustar xavierxavier//testgroup abstract interface //tsref "IDL" //tgdescr "Testing features of the abstract interface construct" //testsubgroup basic //tsgdescr "Testing basic features of the abstract interface construct" abstract interface AbsInf { short op(); }; interface Itfderiv: AbsInf { }; polyorb-2.8~20110207.orig/testsuite/idls/idl02034/0000755000175000017500000000000011750740340020527 5ustar xavierxavierpolyorb-2.8~20110207.orig/testsuite/idls/idl02034/test.out0000644000175000017500000000007211750740340022236 0ustar xavierxaviertin.idl:3:19: expected token iac: 1 error(s) polyorb-2.8~20110207.orig/testsuite/idls/idl02034/tin.idl0000644000175000017500000000026411750740340022015 0ustar xavierxaviermodule M { typedef Long Foo; // Error: keyword is long not Long typedef boolean BOOLEAN; // Error: BOOLEAN collides with // the keyword boolean; }; polyorb-2.8~20110207.orig/testsuite/idls/test033/0000755000175000017500000000000011750740340020573 5ustar xavierxavierpolyorb-2.8~20110207.orig/testsuite/idls/test033/test.out0000644000175000017500000001255111750740340022307 0ustar xavierxaviertypedef enum Sharanfruit22 { BeefTomatoes22, RedPepper22, FrenchBeans22 } Radish22; typedef sequence> Tarragon23[15]; typedef struct Zucchini24 { struct Plum24 { sequence> Shallots24; } KidneyBean24; } ButterBean24; typedef struct Bayleaf25 { struct WhiteCabbage25 { sequence>, 7> Celery25[10]; } Aniseed25; } Dill25; typedef struct Mango26 { struct PassionFruit26 { sequence>, 19> Rhubarb26; } Pumpkin26; } WaterMelon26; typedef struct Potato26 { struct ChineseLeaves26 { sequence>> RedCabbage26[12]; } Broadbeans26; } Record26; typedef struct Blueberry27 { struct Basil27 { sequence>> Peanuts27; } CoxPippin27; } Blackberry27; typedef struct Raspberry28 { struct Peppercorn28 { sequence, 9>, 7> Papaya28[4]; } Susander28; } Grapefruit28; typedef struct Elderberry29 { struct RedGrapes29 { sequence, 5>, 3> Melon29; } BeechNut29; } Kumquats29; typedef struct CrabApple30 { struct Lentil30 { sequence, 3>> GoldenDelicous30[17]; } Fig30; } RedOnion30; typedef struct Mushroom31 { struct Almonds31 { sequence, 6>> Beansprout31; } Guava31; } Runnerbean31; typedef struct Cabbage32 { struct Coconut32 { sequence>, 15> Dates32[11]; } Lychees32; } Cucumber32; typedef struct KerrsPinks32 { struct Wilja32 { sequence>, 14> BritishQueens32; } Balmoral32; } GoldenWonder32; typedef struct PricklyPear33 { struct VineTomatoes33 { sequence, 11>>> GreenPepper33[5]; } Scallion33; } Currant33; typedef struct Artichokes34 { struct Peanutsquash34 { sequence, 16>>> Damsons34; } CherryTomatoes34; } GreenGrapes34; typedef struct Chickpea35 { struct Uglifruit35 { sequence>, 4>, 5> Fennell35[14]; } Waterchestnut35; } Beetroot35; typedef struct JuniperBerries36 { struct GooseBerry36 { sequence>, 11>, 7> Cinnamon36; } EggPlant36; } Cloves36; typedef struct BrazilNut37 { struct Brocoli37 { sequence>, 14>> Prunes37[13]; } GrannySmith37; } SweetPotato37; typedef struct Mint38 { struct BlackEyedBeans38 { sequence>, 16>> Apricots38; } Leek38; } GardenPeas38; typedef struct Cara38 { struct Rooster38 { sequence>>, 8> Cultra38[8]; } MarisPiper38; } KingEdward38; typedef struct Chayato39 { struct KiwanoMelon39 { sequence>>, 3> IcebergLettuce39; } Tomato39; } PippinApple39; typedef struct Eddo40 { struct Chives40 { sequence>>> CookingApple40[7]; } Mullberry40; } Yam40; typedef struct LimaBean41 { struct Blackcurrant41 { sequence>>> Plantain41; } Pineapple41; } Mangosteen41; typedef struct Thyme42 { struct Strawberry42 { sequence, 3>, 2>, 14> Mustard42[13]; } BreadFruit42; } Sweedes42; typedef struct RowanBerry43 { struct CantelopeMelon43 { sequence, 2>, 4>, 3> Billberries43; } LolloRossa43; } Sweetcorn43; interface idlServer { exception Radish22Excpt { Radish22 ex1; }; attribute Radish22 Radish22Attr; Radish22 Radish22Op(in Radish22 p1, out Radish22 p2, inout Radish22 p3) raises (idlServer::Radish22Excpt); exception Sharanfruit22Excpt { Sharanfruit22 ex1; }; attribute Sharanfruit22 Sharanfruit22Attr; Sharanfruit22 Sharanfruit22Op(in Sharanfruit22 p1, out Sharanfruit22 p2, inout Sharanfruit22 p3) raises (idlServer::Sharanfruit22Excpt); exception Tarragon23Excpt { Tarragon23 ex1; }; attribute Tarragon23 Tarragon23Attr; Tarragon23 Tarragon23Op(in Tarragon23 p1, out Tarragon23 p2, inout Tarragon23 p3) raises (idlServer::Tarragon23Excpt); exception ButterBean24Excpt { ButterBean24 ex1; }; attribute ButterBean24 ButterBean24Attr; ButterBean24 ButterBean24Op(in ButterBean24 p1, out ButterBean24 p2, inout ButterBean24 p3) raises (idlServer::ButterBean24Excpt); exception Zucchini24Excpt { Zucchini24 ex1; }; attribute Zucchini24 Zucchini24Attr; Zucchini24 Zucchini24Op(in Zucchini24 p1, out Zucchini24 p2, inout Zucchini24 p3) raises (idlServer::Zucchini24Excpt); exception Plum24Excpt { Zucchini24::Plum24 ex1; }; attribute Zucchini24::Plum24 Plum24Attr; Zucchini24::Plum24 Plum24Op(in Zucchini24::Plum24 p1, out Zucchini24::Plum24 p2, inout Zucchini24::Plum24 p3) raises (idlServer::Plum24Excpt); exception Dill25Excpt { Dill25 ex1; }; attribute Dill25 Dill25Attr; Dill25 Dill25Op(in Dill25 p1, out Dill25 p2, inout Dill25 p3) raises (idlServer::Dill25Excpt); exception Bayleaf25Excpt { Bayleaf25 ex1; }; attribute Bayleaf25 Bayleaf25Attr; Bayleaf25 Bayleaf25Op(in Bayleaf25 p1, out Bayleaf25 p2, inout Bayleaf25 p3) raises (idlServer::Bayleaf25Excpt); exception WhiteCabbage25Excpt { Bayleaf25::WhiteCabbage25 ex1; }; attribute Bayleaf25::WhiteCabbage25 WhiteCabbage25Attr; Bayleaf25::WhiteCabbage25 WhiteCabbage25Op(in Bayleaf25::WhiteCabbage25 p1, out Bayleaf25::WhiteCabbage25 p2, inout Bayleaf25::WhiteCabbage25 p3) raises (idlServer::WhiteCabbage25Excpt); }; polyorb-2.8~20110207.orig/testsuite/idls/Makefile.ada0000644000175000017500000000050411750740340021551 0ustar xavierxavierSHELL = /bin/sh GNATFLAGS = -g -gnatwA GNATINCLUDE = -I`gnatls -v | grep adainclude | sed 's/ *//g'` FLAGS = -I. $(GNATINCLUDE) all : stubs force: stubs: gnatmake $(GNATFLAGS) *.adb $(FLAGS) `polyorb-config` clean: @-rm -f *.ali *.o @-rm -f GNAT* *~ @-rm -f core* @-rm -f b~* polyorb-2.8~20110207.orig/testsuite/idls/idl15033/0000755000175000017500000000000011750740340020532 5ustar xavierxavierpolyorb-2.8~20110207.orig/testsuite/idls/idl15033/test.out0000644000175000017500000000011011750740340022232 0ustar xavierxaviertin.idl:13:10: "I" conflicts with scoped name at line 7 iac: 1 error(s) polyorb-2.8~20110207.orig/testsuite/idls/idl15033/tin.idl0000644000175000017500000000051711750740340022021 0ustar xavierxaviermodule M { typedef long ArgType; const long I = 10; interface A { struct S { struct T { ArgType x[I]; // ArgType and I introduced } m; }; struct U { long I; // OK, I is not a type name }; enum I { I1, I2 }; // Error: I redefined }; // Potential scope of ArgType and I ends here }; polyorb-2.8~20110207.orig/testsuite/idls/test010/0000755000175000017500000000000011750740340020566 5ustar xavierxavierpolyorb-2.8~20110207.orig/testsuite/idls/test010/test.out0000644000175000017500000000043111750740340022274 0ustar xavierxaviermodule Apple { module BlackCherry { typedef short Carrots; }; typedef long Carrots; module BlackCherry { typedef float Starfruit; }; }; interface idlServer { void Rhubarb(in Apple::Carrots p1, out Apple::BlackCherry::Carrots p2, inout Apple::BlackCherry::Starfruit p3); }; polyorb-2.8~20110207.orig/testsuite/idls/vb_d05/0000755000175000017500000000000011750740340020445 5ustar xavierxavierpolyorb-2.8~20110207.orig/testsuite/idls/vb_d05/test.out0000644000175000017500000000057311750740340022162 0ustar xavierxaviertypedef sequence LongSeq; valuetype LongSeqValue LongSeq; valuetype AnyValue any; union FixU switch (long) { case 1 : long x; case 2 : short v; }; valuetype FixUValue FixU; typedef sequence StringSeq; valuetype StringSeqValue StringSeq; union VarU switch (boolean) { case TRUE : string strMbr; case FALSE : StringSeq strseqMbr; }; valuetype VarUValue VarU; polyorb-2.8~20110207.orig/testsuite/idls/vb_d05/tin.idl0000644000175000017500000000070511750740340021733 0ustar xavierxavier// IDL-Spec for testgroup: valuetype // Purpose: basic features of valuetype typedef sequence LongSeq; valuetype LongSeqValue LongSeq; valuetype AnyValue any; union FixU switch (long) { case 1: long x; case 2: short v; }; valuetype FixUValue FixU; typedef sequence StringSeq; valuetype StringSeqValue StringSeq; union VarU switch (boolean) { case TRUE: string strMbr; case FALSE: StringSeq strseqMbr; }; valuetype VarUValue VarU; polyorb-2.8~20110207.orig/testsuite/idls/test024/0000755000175000017500000000000011750740340020573 5ustar xavierxavierpolyorb-2.8~20110207.orig/testsuite/idls/test024/test.out0000644000175000017500000000402511750740340022304 0ustar xavierxaviertypedef sequence GrannySmith; typedef sequence BrazilNut[13]; typedef sequence SweetPotato; typedef sequence Tangarine[15]; typedef sequence Billberries; typedef sequence CantelopeMelon[10]; typedef sequence LolloRossa; typedef sequence RowanBerry[19]; interface idlServer { exception GrannySmithExcpt { GrannySmith ex1; }; attribute GrannySmith GrannySmithAttr; GrannySmith GrannySmithOp(in GrannySmith p1, out GrannySmith p2, inout GrannySmith p3) raises (idlServer::GrannySmithExcpt); exception BrazilNutExcpt { BrazilNut ex1; }; attribute BrazilNut BrazilNutAttr; BrazilNut BrazilNutOp(in BrazilNut p1, out BrazilNut p2, inout BrazilNut p3) raises (idlServer::BrazilNutExcpt); exception SweetPotatoExcpt { SweetPotato ex1; }; attribute SweetPotato SweetPotatoAttr; SweetPotato SweetPotatoOp(in SweetPotato p1, out SweetPotato p2, inout SweetPotato p3) raises (idlServer::SweetPotatoExcpt); exception TangarineExcpt { Tangarine ex1; }; attribute Tangarine TangarineAttr; Tangarine TangarineOp(in Tangarine p1, out Tangarine p2, inout Tangarine p3) raises (idlServer::TangarineExcpt); exception BillberriesExcpt { Billberries ex1; }; attribute Billberries BillberriesAttr; Billberries BillberriesOp(in Billberries p1, out Billberries p2, inout Billberries p3) raises (idlServer::BillberriesExcpt); exception CantelopeMelonExcpt { CantelopeMelon ex1; }; attribute CantelopeMelon CantelopeMelonAttr; CantelopeMelon CantelopeMelonOp(in CantelopeMelon p1, out CantelopeMelon p2, inout CantelopeMelon p3) raises (idlServer::CantelopeMelonExcpt); exception LolloRossaExcpt { LolloRossa ex1; }; attribute LolloRossa LolloRossaAttr; LolloRossa LolloRossaOp(in LolloRossa p1, out LolloRossa p2, inout LolloRossa p3) raises (idlServer::LolloRossaExcpt); exception RowanBerryExcpt { RowanBerry ex1; }; attribute RowanBerry RowanBerryAttr; RowanBerry RowanBerryOp(in RowanBerry p1, out RowanBerry p2, inout RowanBerry p3) raises (idlServer::RowanBerryExcpt); }; polyorb-2.8~20110207.orig/testsuite/idls/inherit002/0000755000175000017500000000000011750740340021252 5ustar xavierxavierpolyorb-2.8~20110207.orig/testsuite/idls/inherit002/tin.idl0000644000175000017500000000040311750740340022533 0ustar xavierxaviermodule m { interface int1 { short op1(); attribute long attr1, attr11; }; interface int2 { short op2(); attribute long attr2, attr22; }; interface int3 : int1, int2 { short op3(); attribute long attr3, attr33; }; }; polyorb-2.8~20110207.orig/testsuite/idls/test017/0000755000175000017500000000000011750740340020575 5ustar xavierxavierpolyorb-2.8~20110207.orig/testsuite/idls/test017/test.out0000644000175000017500000000101511750740340022302 0ustar xavierxavierorb.idl:66:05: warning: semicolon expected CORBA_InterfaceRepository.idl:10:05: warning: semicolon expected iac: 2 warning(s) import ::CORBA; typedef long Apple; typedef struct Banana { short Orange; float Rhubarb; } PassionFruit; interface idlServer { struct TypeCode { char Mango; char Watermelon; }; idlServer::TypeCode Lime(in idlServer::TypeCode p1, out idlServer::TypeCode p2, inout idlServer::TypeCode p3); CORBA::TypeCode BlueBerry(in CORBA::TypeCode p1, out CORBA::TypeCode p2, inout CORBA::TypeCode p3); }; polyorb-2.8~20110207.orig/testsuite/idls/ada0015/0000755000175000017500000000000011750740340020421 5ustar xavierxavierpolyorb-2.8~20110207.orig/testsuite/idls/ada0015/tin.idl0000644000175000017500000000024611750740340021707 0ustar xavierxaviertypedef float New_Float; module m1 { interface int1 { attribute New_Float attr1; readonly attribute boolean bool1; }; }; typedef boolean New_Boolean; polyorb-2.8~20110207.orig/testsuite/idls/idl02031/0000755000175000017500000000000011750740340020524 5ustar xavierxavierpolyorb-2.8~20110207.orig/testsuite/idls/idl02031/test.out0000644000175000017500000000007211750740340022233 0ustar xavierxaviertin.idl:3:23: expected token iac: 1 error(s) polyorb-2.8~20110207.orig/testsuite/idls/idl02031/tin.idl0000644000175000017500000000033611750740340022012 0ustar xavierxaviermodule M { interface thing { attribute boolean abstract; // error: abstract collides with // keyword abstract attribute boolean _abstract; // ok: abstract is an identifier }; }; polyorb-2.8~20110207.orig/testsuite/idls/vti_avb02/0000755000175000017500000000000011750740340021162 5ustar xavierxavierpolyorb-2.8~20110207.orig/testsuite/idls/vti_avb02/test.out0000644000175000017500000000027711750740340022700 0ustar xavierxavierabstract valuetype AbsVal1 { short op1_1(); long op1_2(); }; abstract valuetype AbsVal2 { short op2_1(); long op2_2(); }; abstract valuetype AbsVal3 : AbsVal1, AbsVal2 { short op3(); }; polyorb-2.8~20110207.orig/testsuite/idls/vti_avb02/tin.idl0000644000175000017500000000046311750740340022451 0ustar xavierxavier//testsubgroup abstract valuetype as base class //tsgdescr "Testing the abstract valuetype as base class" abstract valuetype AbsVal1 { short op1_1(); long op1_2(); }; abstract valuetype AbsVal2 { short op2_1(); long op2_2(); }; abstract valuetype AbsVal3: AbsVal1, AbsVal2{ short op3(); }; polyorb-2.8~20110207.orig/testsuite/idls/ada0010/0000755000175000017500000000000011750740340020414 5ustar xavierxavierpolyorb-2.8~20110207.orig/testsuite/idls/ada0010/tin.idl0000644000175000017500000000054711750740340021706 0ustar xavierxavier// Test interface code generation interface Inter1 { attribute float Attr1; // Float type declaration attribute boolean Attr2; // boolean type declaration readonly attribute long Attr3; // readonly attribute attribute long long Attr4; string Name (in short code); // operation declaration void SName (in short code, in string str); }; polyorb-2.8~20110207.orig/testsuite/idls/idl07053/0000755000175000017500000000000011750740340020535 5ustar xavierxavierpolyorb-2.8~20110207.orig/testsuite/idls/idl07053/test.out0000644000175000017500000000012011750740340022236 0ustar xavierxaviertin.idl:5:09: "make_it_so" conflicts with declaration at line 2 iac: 1 error(s) polyorb-2.8~20110207.orig/testsuite/idls/idl07053/tin.idl0000644000175000017500000000020211750740340022013 0ustar xavierxavierinterface A { void make_it_so(); }; interface B: A { short make_it_so(in long times); // Error: redefinition of make_it_so }; polyorb-2.8~20110207.orig/testsuite/idls/ada0021/0000755000175000017500000000000011750740340020416 5ustar xavierxavierpolyorb-2.8~20110207.orig/testsuite/idls/ada0021/tin.idl0000644000175000017500000000041311750740340021700 0ustar xavierxavier// Extracted from a mail of Khaled (March 22, 2005) module First { typedef string name; }; module Second { typedef First::name name; typedef name X; interface foo { name some_function (); name some_function2 (in name n); }; }; polyorb-2.8~20110207.orig/testsuite/idls/ada0022/0000755000175000017500000000000011750740340020417 5ustar xavierxavierpolyorb-2.8~20110207.orig/testsuite/idls/ada0022/tin.idl0000644000175000017500000001641211750740340021707 0ustar xavierxavier// Extracted from a mail of Khaled (March 22, 2005) module First { typedef boolean MyBoolean; typedef short MyShort; typedef long MyLong; typedef long long MyLongLong; typedef unsigned short MyUnsignedShort; typedef unsigned long MyUnsignedLong; typedef unsigned long long MyUnsignedLongLong; typedef float MyFloat; typedef double MyDouble; typedef octet MyOctet; typedef char MyCharacter; typedef wchar MyWideCharacter; typedef string MyString; typedef wstring MyWideString; typedef Object MyObject; typedef fixed <10,5> MyFixed; typedef double MyVector[4]; typedef double MyMatrix[4][4]; typedef sequence MySequence; typedef sequence MyBoundedSequence; interface MyInterface { }; enum MyEnum { Red, Green, Blue }; union MyUnion switch (long) { case 1: boolean boolean_value; case 2: short short_value; case 3: long long_value; case 4: long long long_long_value; case 5: unsigned short unsigned_short_value; case 6: unsigned long unsigned_long_value; case 7: unsigned long long unsigned_long_long_value; case 8: float float_value; case 9: double double_value; case 10: octet octet_value; case 11: char char_value; case 12: wchar wchar_value; case 13: string string_value; case 14: wstring wstring_value; case 15: Object object_value; case 16: MyVector vector_value; case 17: MyMatrix matrix_value; case 18: MySequence sequence_value; case 19: MyBoundedSequence bounded_sequence_value; //PolyORB:WAidlac: // case 20: MyInterface interface_value; case 21: MyEnum enum_value; default: boolean unknown; }; }; module Second { typedef First::MyBoolean MyBoolean; typedef MyBoolean AnotherBoolean; typedef First::MyShort MyShort; typedef MyShort AnotherShort; typedef First::MyLong MyLong; typedef MyLong AnotherLong; typedef First::MyLongLong MyLongLong; typedef MyLongLong AnotherLongLong; typedef First::MyUnsignedShort MyUnsignedShort; typedef MyUnsignedShort AnotherUnsignedShort; typedef First::MyUnsignedLong MyUnsignedLong; typedef MyUnsignedLong AnotherUnsignedLong; typedef First::MyUnsignedLongLong MyUnsignedLongLong; typedef MyUnsignedLongLong AnotherUnsignedLongLong; typedef First::MyFloat MyFloat; typedef MyFloat AnotherFloat; typedef First::MyDouble MyDouble; typedef MyDouble AnotherDouble; typedef First::MyOctet MyOctet; typedef MyOctet AnotherOctet; typedef First::MyCharacter MyCharacter; typedef MyCharacter AnotherCharacter; typedef First::MyWideCharacter MyWideCharacter; typedef MyWideCharacter AnotherWideCharacter; typedef First::MyString MyString; typedef MyString AnotherString; typedef First::MyWideString MyWideString; typedef MyWideString AnotherWideString; //PolyORB:WAidlac: // typedef First::MyObject MyObject; // typedef MyObject AnotherObject; typedef First::MyFixed MyFixed; typedef MyFixed AnotherFixed; typedef First::MyVector MyVector; typedef MyVector AnotherVector; typedef First::MyMatrix MyMatrix; typedef MyMatrix AnotherMatrix; typedef First::MySequence MySequence; typedef MySequence AnotherSequence; typedef First::MyBoundedSequence MyBoundedSequence; typedef MyBoundedSequence AnotherBoundedSequence; typedef First::MyInterface MyInterface; typedef MyInterface AnotherInterface; typedef First::MyEnum MyEnum; typedef MyEnum AnotherEnum; typedef First::MyUnion MyUnion; typedef MyUnion AnotherUnion; typedef MyBoolean MyBooleanArray[2]; typedef MyBooleanArray AnotherBooleanArray; interface Foo { AnotherBoolean boolean_operation (inout AnotherBoolean boolean_value); AnotherShort short_operation (inout AnotherShort short_value); AnotherLong long_operation (inout AnotherLong long_value); AnotherLongLong long_long_operation (inout AnotherLong long_long_value); AnotherUnsignedShort unsigned_short_operation (inout AnotherUnsignedShort unsigned_short_value); AnotherUnsignedLong unsigned_long_operation (inout AnotherUnsignedLong unsigned_long_value); AnotherUnsignedLongLong unsigned_long_long_operation (inout AnotherUnsignedLongLong unsigned_long_long_value); AnotherFloat float_operation (inout AnotherFloat float_value); AnotherDouble double_operation (inout AnotherDouble double_value); AnotherOctet octet_operation (inout AnotherOctet octet_value); AnotherCharacter character_operation (inout AnotherCharacter character_value); AnotherWideCharacter wide_character_operation (inout AnotherWideCharacter wide_character_value); AnotherString string_operation (inout AnotherString string_value); AnotherWideString wide_string_operation (inout AnotherWideString wide_string_value); //PolyORB:WAidlac: // AnotherObject object_operation (inout AnotherObject object_value); AnotherFixed fixed_operation (inout AnotherFixed fixed_value); AnotherMatrix matrix_operation (inout AnotherMatrix matrix_value); AnotherEnum enum_operation (inout AnotherEnum enum_value); AnotherSequence sequence_operation (inout AnotherSequence sequence_value); AnotherBoundedSequence bounded_sequence__operation (inout AnotherBoundedSequence bounded_sequence_value); AnotherInterface interface_operation (inout AnotherInterface interface_value); AnotherVector vector_operation (inout AnotherVector vector_value); AnotherUnion union_operation (inout AnotherUnion union_value); MyBooleanArray boolean_array_operation (inout MyBooleanArray value); AnotherBooleanArray another_boolean_array_operation (inout AnotherBooleanArray value); }; }; module Third { typedef First::MyOctet MyOctet[2]; typedef MyOctet OtherOctet; typedef MyOctet MyOctetArray[2]; typedef First::MyInterface MyInterface[2]; typedef MyInterface OtherInterface; typedef MyInterface MyInterfaceArray[2]; typedef First::MyObject MyObject[2]; typedef MyObject OtherObject; typedef MyObject MyObjectArray[2]; interface Foo : Second::Foo { MyOctetArray x_octet_operation (inout MyOctetArray value); MyInterfaceArray x_interface_operation (inout MyInterfaceArray value); MyObjectArray x_object_operation (inout MyObjectArray value); }; }; polyorb-2.8~20110207.orig/testsuite/idls/compile_files.sh0000755000175000017500000000130211750740340022533 0ustar xavierxavier# !/bin/sh # This script test the Ada code generation of IAC. After executing # IAC on a file (or on many files), it compiles the generated code # The test is considered successful if the Ada code is generates and # if it compiles correctly if [ -d $1 ]; then DIR=$1; FILES=`ls $DIR/*.idl| awk 'BEGIN{FS="/"}{print $NF;exit}'` else DIR=`dirname $1`; FILES=`basename $1` fi cd $DIR # Generates code in a temporary directory TMP=.tmp_rep/ LOG=log.test mkdir $TMP cd $TMP # compile generated code cp ../../Makefile.ada ./Makefile > /dev/null for i in $FILES; do iac -ada -i ../$i done make > /dev/null 2>$LOG CODE=$? if [ $CODE != 0 ]; then cat $LOG fi; cd .. rm -rf $TMP exit $CODE polyorb-2.8~20110207.orig/testsuite/idls/idl15012/0000755000175000017500000000000011750740340020527 5ustar xavierxavierpolyorb-2.8~20110207.orig/testsuite/idls/idl15012/test.out0000644000175000017500000000023111750740340022233 0ustar xavierxaviertin.idl:10:13: multiple declarations of "string_t" tin.idl:10:13: found declaration at line 6 tin.idl:10:13: found declaration at line 2 iac: 1 error(s) polyorb-2.8~20110207.orig/testsuite/idls/idl15012/tin.idl0000644000175000017500000000036311750740340022015 0ustar xavierxavierinterface A { typedef string<128> string_t; }; interface B { typedef string<256> string_t; }; interface C: A, B { attribute string_t Title; // Error: Ambiguous attribute A::string_t Name; // OK attribute B::string_t City; // OK }; polyorb-2.8~20110207.orig/testsuite/idls/test036/0000755000175000017500000000000011750740340020576 5ustar xavierxavierpolyorb-2.8~20110207.orig/testsuite/idls/test036/test.out0000644000175000017500000001012111750740340022301 0ustar xavierxaviertypedef struct Peanutsquash90 { struct PepinoMelon90 { struct Pear90 { sequence, 18>>> Mangosteen90[13]; } Grapefruit90[15]; } Damsons90; } CherryTomatoes90; typedef struct Cherry91 { struct Sharanfruit91 { struct BeefTomatoes91 { sequence>>> RedPepper91[11]; } FrenchBeans91; } Radish91; } Papaya91; typedef struct Blackcurrant92 { struct Okra92 { struct Cassava92 { sequence, 7>>> BambooShoot92; } Beetroot92[10]; } Plantain92; } Pineapple92; typedef struct Walnuts93 { struct Elderberry93 { struct RedGrapes93 { sequence>>> Melon93; } BeechNut93; } Kumquats93; } Fennell93; typedef struct Lettuce94 { struct Pomegranate94 { struct HazelNut94 { sequence>, 6>, 9> RedOnion94[7]; } Sweedes94[4]; } Tarragon94; } Mangetout94; typedef struct Daikan95 { struct JuniperBerries95 { struct GooseBerry95 { sequence, 5>, 3>, 9> Cinnamon95[3]; } EggPlant95; } Cloves95; } Mustard95; typedef struct Lentil96 { struct Avocado96 { struct Tangarine96 { sequence>, 17>, 6> SweetPotato96; } ButterBean96[6]; } GoldenDelicous96; } Fig96; typedef struct Onion97 { struct RowanBerry97 { struct CantelopeMelon97 { sequence, 18>, 15>, 11> Billberries97; } LolloRossa97; } Sweetcorn97; } Shallots97; typedef struct Brocoli98 { struct Tofu98 { struct Parsnip98 { sequence>, 14>> LoganBerry98[11]; } Runnerbean98[5]; } Prunes98; } GrannySmith98; typedef struct Oregano99 { struct Bayleaf99 { struct WhiteCabbage99 { sequence, 16>, 4>> Celery99[5]; } Aniseed99; } Dill99; } Beansprout99; interface idlServer { exception CherryTomatoes90Excpt { CherryTomatoes90 ex1; }; attribute CherryTomatoes90 CherryTomatoes90Attr; CherryTomatoes90 CherryTomatoes90Op(in CherryTomatoes90 p1, out CherryTomatoes90 p2, inout CherryTomatoes90 p3) raises (idlServer::CherryTomatoes90Excpt); exception Peanutsquash90Excpt { Peanutsquash90 ex1; }; attribute Peanutsquash90 Peanutsquash90Attr; Peanutsquash90 Peanutsquash90Op(in Peanutsquash90 p1, out Peanutsquash90 p2, inout Peanutsquash90 p3) raises (idlServer::Peanutsquash90Excpt); exception PepinoMelon90Excpt { Peanutsquash90::PepinoMelon90 ex1; }; attribute Peanutsquash90::PepinoMelon90 PepinoMelon90Attr; Peanutsquash90::PepinoMelon90 PepinoMelon90Op(in Peanutsquash90::PepinoMelon90 p1, out Peanutsquash90::PepinoMelon90 p2, inout Peanutsquash90::PepinoMelon90 p3) raises (idlServer::PepinoMelon90Excpt); exception Pear90Excpt { Peanutsquash90::PepinoMelon90::Pear90 ex1; }; attribute Peanutsquash90::PepinoMelon90::Pear90 Pear90Attr; Peanutsquash90::PepinoMelon90::Pear90 Pear90Op(in Peanutsquash90::PepinoMelon90::Pear90 p1, out Peanutsquash90::PepinoMelon90::Pear90 p2, inout Peanutsquash90::PepinoMelon90::Pear90 p3) raises (idlServer::Pear90Excpt); exception Papaya91Excpt { Papaya91 ex1; }; attribute Papaya91 Papaya91Attr; Papaya91 Papaya91Op(in Papaya91 p1, out Papaya91 p2, inout Papaya91 p3) raises (idlServer::Papaya91Excpt); exception Cherry91Excpt { Cherry91 ex1; }; attribute Cherry91 Cherry91Attr; Cherry91 Cherry91Op(in Cherry91 p1, out Cherry91 p2, inout Cherry91 p3) raises (idlServer::Cherry91Excpt); exception Sharanfruit91Excpt { Cherry91::Sharanfruit91 ex1; }; attribute Cherry91::Sharanfruit91 Sharanfruit91Attr; Cherry91::Sharanfruit91 Sharanfruit91Op(in Cherry91::Sharanfruit91 p1, out Cherry91::Sharanfruit91 p2, inout Cherry91::Sharanfruit91 p3) raises (idlServer::Sharanfruit91Excpt); exception BeefTomatoes91Excpt { Cherry91::Sharanfruit91::BeefTomatoes91 ex1; }; attribute Cherry91::Sharanfruit91::BeefTomatoes91 BeefTomatoes91Attr; Cherry91::Sharanfruit91::BeefTomatoes91 BeefTomatoes91Op(in Cherry91::Sharanfruit91::BeefTomatoes91 p1, out Cherry91::Sharanfruit91::BeefTomatoes91 p2, inout Cherry91::Sharanfruit91::BeefTomatoes91 p3) raises (idlServer::BeefTomatoes91Excpt); }; polyorb-2.8~20110207.orig/testsuite/idls/echo/0000755000175000017500000000000011750740340020304 5ustar xavierxavierpolyorb-2.8~20110207.orig/testsuite/idls/echo/echo-impl.ads0000644000175000017500000000131111750740340022646 0ustar xavierxavier------------------------------------------------- -- This file has been generated automatically -- by IDLAC (http://libre.act-europe.fr/polyorb/) ------------------------------------------------- pragma Style_Checks (Off); with CORBA; with PortableServer; package Echo.Impl is type Object is new PortableServer.Servant_Base with private; type Object_Ptr is access all Object'Class; function echoString (Self : access Object; Mesg : in CORBA.String) return CORBA.String; private type Object is new PortableServer.Servant_Base with record -- Insert components to hold the state -- of the implementation object. null; end record; end Echo.Impl; polyorb-2.8~20110207.orig/testsuite/idls/echo/echo.idl0000644000175000017500000000007211750740340021713 0ustar xavierxavierinterface Echo { string echoString (in string Mesg); }; polyorb-2.8~20110207.orig/testsuite/idls/echo/echo-impl.adb0000644000175000017500000000121711750740340022632 0ustar xavierxavier------------------------------------------------- -- This file has been generated automatically -- by IDLAC (http://libre.act-europe.fr/polyorb/) ------------------------------------------------- pragma Style_Checks (Off); with CORBA; with Echo.Skel; pragma Elaborate (Echo.Skel); pragma Warnings (Off, Echo.Skel); package body Echo.Impl is function echoString (Self : access Object; Mesg : in CORBA.String) return CORBA.String is Result : CORBA.String; begin -- Insert implementation of echoString Result := CORBA.To_CORBA_String ("Hello Ada!"); return Result; end echoString; end Echo.Impl; polyorb-2.8~20110207.orig/testsuite/idls/echo/Makefile0000644000175000017500000000073611750740340021752 0ustar xavierxavierSHELL = /bin/sh GNATCHOP = gnatchop GNATFLAGS = -g -O2 -gnatfy -gnatwae -gnatpn GNATMAKE = gnatmake all: server client force: server: force echo-skel.ads $(GNATMAKE) server.adb `polyorb-config` client: force echo-skel.ads $(GNATMAKE) client.adb `polyorb-config` echo-skel.ads: echo.idl iac -ada echo.idl > iac.ada $(GNATCHOP) -w iac.ada clean: @-rm -f *.o *.ali *ir_info* @-rm -f client server *skel* *helper* *idl_file* @-rm -f echo.ad* iac.ada GNAT* *~ polyorb-2.8~20110207.orig/testsuite/idls/echo/server.adb0000644000175000017500000000637211750740340022272 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- S E R V E R -- -- -- -- B o d y -- -- -- -- Copyright (C) 2002-2003 Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by ACT Europe. -- -- (email: sales@act-europe.fr) -- -- -- ------------------------------------------------------------------------------ -- $Id: server.adb 2804 2003-12-09 22:20:10Z hugues $ with Ada.Text_IO; with CORBA.Impl; with CORBA.Object; with CORBA.ORB; with PortableServer.POA; with PortableServer.POAManager; with Echo.Impl; -- Setup server node: use no tasking default configuration with PolyORB.Setup.No_Tasking_Server; pragma Elaborate_All (PolyORB.Setup.No_Tasking_Server); pragma Warnings (Off, PolyORB.Setup.No_Tasking_Server); procedure Server is begin CORBA.ORB.Initialize ("ORB"); declare Root_POA : PortableServer.POA.Ref; Ref : CORBA.Object.Ref; Obj : constant CORBA.Impl.Object_Ptr := new Echo.Impl.Object; begin -- Retrieve Root POA Root_POA := PortableServer.POA.To_Ref (CORBA.ORB.Resolve_Initial_References (CORBA.ORB.To_CORBA_String ("RootPOA"))); PortableServer.POAManager.Activate (PortableServer.POA.Get_The_POAManager (Root_POA)); -- Set up new object Ref := PortableServer.POA.Servant_To_Reference (Root_POA, PortableServer.Servant (Obj)); -- Output IOR Ada.Text_IO.Put_Line ("'" & CORBA.To_Standard_String (CORBA.Object.Object_To_String (Ref)) & "'"); -- Launch the server CORBA.ORB.Run; end; end Server; polyorb-2.8~20110207.orig/testsuite/idls/echo/client.adb0000644000175000017500000000713611750740340022241 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- C L I E N T -- -- -- -- B o d y -- -- -- -- Copyright (C) 2002-2004 Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by ACT Europe. -- -- (email: sales@act-europe.fr) -- -- -- ------------------------------------------------------------------------------ -- echo client. -- $Id: //droopi/main/examples/corba/echo/client.adb#7 $ with Ada.Command_Line; with Ada.Text_IO; with CORBA.ORB; with Echo; with PolyORB.Setup.Client; pragma Warnings (Off, PolyORB.Setup.Client); with PolyORB.Utils.Report; procedure Client is use Ada.Command_Line; use Ada.Text_IO; use PolyORB.Utils.Report; Sent_Msg, Rcvd_Msg : CORBA.String; myecho : Echo.Ref; begin New_Test ("Echo client"); CORBA.ORB.Initialize ("ORB"); if Argument_Count /= 1 then Put_Line ("usage : client |-i"); return; end if; -- Getting the CORBA.Object CORBA.ORB.String_To_Object (CORBA.To_CORBA_String (Ada.Command_Line.Argument (1)), myecho); -- Checking if it worked if Echo.Is_Nil (myecho) then Put_Line ("main : cannot invoke on a nil reference"); return; end if; -- Sending message Sent_Msg := CORBA.To_CORBA_String (Standard.String'("Hello Ada !")); Rcvd_Msg := Echo.echoString (myecho, Sent_Msg); -- Printing result Put_Line ("I said : " & CORBA.To_Standard_String (Sent_Msg)); Put_Line ("The object answered : " & CORBA.To_Standard_String (Rcvd_Msg)); End_Report; exception when E : CORBA.Transient => declare Memb : CORBA.System_Exception_Members; begin CORBA.Get_Members (E, Memb); Put ("received exception transient, minor"); Put (CORBA.Unsigned_Long'Image (Memb.Minor)); Put (", completion status: "); Put_Line (CORBA.Completion_Status'Image (Memb.Completed)); End_Report; end; end Client; polyorb-2.8~20110207.orig/testsuite/idls/test027/0000755000175000017500000000000011750740340020576 5ustar xavierxavierpolyorb-2.8~20110207.orig/testsuite/idls/test027/test.out0000644000175000017500000000370311750740340022311 0ustar xavierxaviertypedef sequence, 18> Melon; typedef sequence> Elderberry[13]; typedef sequence> Fennell; typedef sequence, 7> Chickpea[10]; typedef sequence, 19> Plantain; typedef sequence> LimaBean[6]; typedef sequence> RedPepper; typedef sequence, 9> Sharanfruit[7]; interface idlServer { exception MelonExcpt { Melon ex1; }; attribute Melon MelonAttr; Melon MelonOp(in Melon p1, out Melon p2, inout Melon p3) raises (idlServer::MelonExcpt); exception ElderberryExcpt { Elderberry ex1; }; attribute Elderberry ElderberryAttr; Elderberry ElderberryOp(in Elderberry p1, out Elderberry p2, inout Elderberry p3) raises (idlServer::ElderberryExcpt); exception FennellExcpt { Fennell ex1; }; attribute Fennell FennellAttr; Fennell FennellOp(in Fennell p1, out Fennell p2, inout Fennell p3) raises (idlServer::FennellExcpt); exception ChickpeaExcpt { Chickpea ex1; }; attribute Chickpea ChickpeaAttr; Chickpea ChickpeaOp(in Chickpea p1, out Chickpea p2, inout Chickpea p3) raises (idlServer::ChickpeaExcpt); exception PlantainExcpt { Plantain ex1; }; attribute Plantain PlantainAttr; Plantain PlantainOp(in Plantain p1, out Plantain p2, inout Plantain p3) raises (idlServer::PlantainExcpt); exception LimaBeanExcpt { LimaBean ex1; }; attribute LimaBean LimaBeanAttr; LimaBean LimaBeanOp(in LimaBean p1, out LimaBean p2, inout LimaBean p3) raises (idlServer::LimaBeanExcpt); exception RedPepperExcpt { RedPepper ex1; }; attribute RedPepper RedPepperAttr; RedPepper RedPepperOp(in RedPepper p1, out RedPepper p2, inout RedPepper p3) raises (idlServer::RedPepperExcpt); exception SharanfruitExcpt { Sharanfruit ex1; }; attribute Sharanfruit SharanfruitAttr; Sharanfruit SharanfruitOp(in Sharanfruit p1, out Sharanfruit p2, inout Sharanfruit p3) raises (idlServer::SharanfruitExcpt); }; polyorb-2.8~20110207.orig/testsuite/idls/sequences01/0000755000175000017500000000000011750740340021522 5ustar xavierxavierpolyorb-2.8~20110207.orig/testsuite/idls/sequences01/test15.idl0000644000175000017500000000023511750740340023341 0ustar xavierxaviermodule Test15 { union U switch (long) { case 0 : boolean value1; default : boolean value2; }; typedef sequence OU; }; polyorb-2.8~20110207.orig/testsuite/idls/local/0000755000175000017500000000000011750740340020460 5ustar xavierxavierpolyorb-2.8~20110207.orig/testsuite/idls/local/local4.idl0000644000175000017500000000010511750740340022324 0ustar xavierxavierinterface A {}; local interface B {}; local interface C : A, B {}; polyorb-2.8~20110207.orig/testsuite/idls/local/local1.idl0000644000175000017500000000002711750740340022324 0ustar xavierxavierlocal interface A {}; polyorb-2.8~20110207.orig/testsuite/idls/local/local2.idl0000644000175000017500000000005311750740340022324 0ustar xavierxavierinterface A {}; local interface B : A {}; polyorb-2.8~20110207.orig/testsuite/idls/local/local3.idl0000644000175000017500000000006111750740340022324 0ustar xavierxavierlocal interface A {}; local interface B : A {}; polyorb-2.8~20110207.orig/testsuite/idls/local/local5.idl0000644000175000017500000000005311750740340022327 0ustar xavierxavierlocal interface A {}; interface B : A {}; polyorb-2.8~20110207.orig/testsuite/idls/types003/0000755000175000017500000000000011750740340020755 5ustar xavierxavierpolyorb-2.8~20110207.orig/testsuite/idls/types003/test.out0000644000175000017500000000011111750740340022456 0ustar xavierxavierOBJECT := True STRING := True ULONG := True TYPECODE := True ANY := True polyorb-2.8~20110207.orig/testsuite/idls/types003/tin.idl0000644000175000017500000000007011750740340022236 0ustar xavierxavierinterface tin { object echoobject (in object arg); }; polyorb-2.8~20110207.orig/testsuite/idls/types004/0000755000175000017500000000000011750740340020756 5ustar xavierxavierpolyorb-2.8~20110207.orig/testsuite/idls/types004/test.out0000644000175000017500000000010711750740340022464 0ustar xavierxavierWCHAR := True ARRAY_T := True ULONG := True STRING := True ANY := True polyorb-2.8~20110207.orig/testsuite/idls/types004/tin.idl0000644000175000017500000000006311750740340022241 0ustar xavierxavierinterface tin { typedef wchar Alexandrin[12]; }; polyorb-2.8~20110207.orig/testsuite/idls/idlac003/0000755000175000017500000000000011750740340020665 5ustar xavierxavierpolyorb-2.8~20110207.orig/testsuite/idls/idlac003/tin.idl0000644000175000017500000000006111750740340022146 0ustar xavierxavierinterface bar { typedef boolean array[10]; }; polyorb-2.8~20110207.orig/testsuite/idls/iac004/0000755000175000017500000000000011750740340020346 5ustar xavierxavierpolyorb-2.8~20110207.orig/testsuite/idls/iac004/test.out0000644000175000017500000000017611750740340022062 0ustar xavierxaviertin.idl:2:17: "M" conflicts with declaration at line 1 tin.idl:6:10: "i" conflicts with declaration at line 5 iac: 2 error(s) polyorb-2.8~20110207.orig/testsuite/idls/iac004/tin.idl0000644000175000017500000000042311750740340021631 0ustar xavierxaviermodule M { typedef short M; // Error: M is the name of the module in the scope // of which the typedef is. interface I { void i (in short j); // Error: i clashes with the interface name I void a (in short a); // No clash since a is an operation }; }; polyorb-2.8~20110207.orig/testsuite/idls/vb_d04/0000755000175000017500000000000011750740340020444 5ustar xavierxavierpolyorb-2.8~20110207.orig/testsuite/idls/vb_d04/test.out0000644000175000017500000000007611750740340022157 0ustar xavierxaviervaluetype StringValue string; valuetype WStringValue wstring; polyorb-2.8~20110207.orig/testsuite/idls/vb_d04/tin.idl0000644000175000017500000000021411750740340021725 0ustar xavierxavier// IDL-Spec for testgroup: valuetype // Purpose: basic features of valuetype valuetype StringValue string; valuetype WStringValue wstring; polyorb-2.8~20110207.orig/testsuite/idls/README0000644000175000017500000000331311750740340020246 0ustar xavierxavier1) To run tests: ---------------- Execute ./autotest.sh in the testsuite directory. Note that autotest.sh expects PolyORB to be installed, and iac and polyorb-config to be in your PATH variable. 2) To add a new test: --------------------- - Create a directory () and put all the IDL files needed for the test in this directory. - Add a line in the MANIFEST file corresponding to the test: [/]: There are 4 test categories: 1 - IDL tree tests. In this case the line added to the MANIFEST file must be in the form: /:idl_frontend is the valid IDL file. The test directory must contain a file 'test.out' that contains the expected output. 2 - IDL errors tests: In this case the line added to the MANIFEST file must be in the form: /:idl_errors is the erroneous IDL file. The test directory must contain a file 'test.out' that contains the expected error message. 3 - Ada Backend tests: In this case the line added to the MANIFEST file must be in one of these 2 forms: a - /:ada_backend In this case Ada code (stubs, skels and dummy impls) is generated from and then compiled. b - :ada_backend In this case Ada code (stubs, skels and dummy impls) is generated from all IDL files in and then compiled. 4 - Types Backend tests: In this case the line added to the MANIFEST file must be in the form: /:types_backend is the valid IDL file. The test directory must contain a file 'test.out' that contains the expected output. polyorb-2.8~20110207.orig/testsuite/idls/test011/0000755000175000017500000000000011750740340020567 5ustar xavierxavierpolyorb-2.8~20110207.orig/testsuite/idls/test011/test.out0000644000175000017500000000026711750740340022304 0ustar xavierxavierinterface idlServer { const long Apple = 4; typedef float Banana; exception Orange { short Starfruit; }; attribute char Lychees; void Lemon(); }; interface emptyInterface { }; polyorb-2.8~20110207.orig/testsuite/idls/iac005/0000755000175000017500000000000011750740340020347 5ustar xavierxavierpolyorb-2.8~20110207.orig/testsuite/idls/iac005/test.out0000644000175000017500000000022311750740340022054 0ustar xavierxaviertin.idl:6:20: \u may only be used in wide characters and strings tin.idl:10:17: \u may only be used in wide characters and strings iac: 2 error(s) polyorb-2.8~20110207.orig/testsuite/idls/iac005/tin.idl0000644000175000017500000000042311750740340021632 0ustar xavierxavierconst long x = 0x9 + 0xf; const long y = 12 + 3 * 6 - (x / 2); enum T {AT, BT, CT}; const string s1 = "toto"; const string s2 = L"t\uccccti"; const wstring s3 = "t\uccccti"; const wstring s4 = L"t\uccccti"; const char c1 = 'a'; const wchar c2 = L'b'; const char c3 = '\u41'; polyorb-2.8~20110207.orig/testsuite/idls/iac005/t.idl0000644000175000017500000000003111750740340021276 0ustar xavierxavierconst char c3 = L'\u41'; polyorb-2.8~20110207.orig/testsuite/idls/iac007/0000755000175000017500000000000011750740340020351 5ustar xavierxavierpolyorb-2.8~20110207.orig/testsuite/idls/iac007/tin.idl0000644000175000017500000000016211750740340021634 0ustar xavierxavierconst long c1 = "a"; const long c2 = 1 + "a"; const octet c3 = -1; const unsigned long c4 = (4294967295 * 2) / 2; polyorb-2.8~20110207.orig/testsuite/idls/test012/0000755000175000017500000000000011750740340020570 5ustar xavierxavierpolyorb-2.8~20110207.orig/testsuite/idls/test012/test.out0000644000175000017500000000052411750740340022301 0ustar xavierxavierinterface Banana; struct Corn { short Eddo; Banana Yam; long Rasin; float Peach; }; interface Banana; interface Apple { attribute Banana Peanuts; }; interface Banana { void Orange(in Banana p1); void Basil(out Banana p1); void VineTomatoes(inout Banana p1); }; interface idlServer : Apple, Banana { idlServer Lemon(in Corn p1); }; polyorb-2.8~20110207.orig/testsuite/idls/test045/0000755000175000017500000000000011750740340020576 5ustar xavierxavierpolyorb-2.8~20110207.orig/testsuite/idls/test045/test.out0000644000175000017500000000337611750740340022317 0ustar xavierxaviertypedef struct GreenPepper { sequence YellowPepper; sequence CoxPippin[3]; sequence Banana; sequence Currant[3]; sequence Tomato; sequence Celeriac[3]; sequence Corriander; sequence Broadbeans[3]; sequence BritishQueens; sequence GoldenWonder[3]; sequence MarisPiper; sequence Apple[3]; sequence BlackCherry; sequence Pumpkin[3]; sequence Dates; sequence Cucumber[3]; sequence Leek; sequence GaliaMelon[3]; sequence LoganBerry; sequence Aniseed[3]; sequence Beansprout; sequence Runnerbean[3]; sequence GrannySmith; sequence Billberries[3]; sequence Sweetcorn; sequence KidneyBean[3]; sequence GoldenDelicous; sequence RedOnion[3]; sequence EggPlant; sequence Mustard[3]; sequence Sweedes; sequence Mangetout[3]; sequence Melon; sequence Kumquats[3]; sequence Waterchestnut; sequence Plantain[3]; string Mangosteen; string FrenchBeans[3]; string<3> Papaya; string<3> Grapefruit[3]; } Peanutsquash[3]; interface idlServer { exception PeanutsquashExcpt { Peanutsquash ex1; }; attribute Peanutsquash PeanutsquashAttr; Peanutsquash PeanutsquashOp(in Peanutsquash p1, out Peanutsquash p2, inout Peanutsquash p3) raises (idlServer::PeanutsquashExcpt); exception GreenPepperExcpt { GreenPepper ex1; }; attribute GreenPepper GreenPepperAttr; GreenPepper GreenPepperOp(in GreenPepper p1, out GreenPepper p2, inout GreenPepper p3) raises (idlServer::GreenPepperExcpt); }; polyorb-2.8~20110207.orig/testsuite/idls/vt_m02/0000755000175000017500000000000011750740340020475 5ustar xavierxavierpolyorb-2.8~20110207.orig/testsuite/idls/vt_m02/test.out0000644000175000017500000000075411750740340022213 0ustar xavierxavierinterface Itf { }; struct FixStct { long longMbr; }; struct VarStct { string stringMbr; }; const short n = 9; union FixU switch (boolean) { case TRUE : long longMbr; case FALSE : short shortMbr; }; union VarU switch (short) { case 1 : string stringMbr; default : any anyMbr; }; valuetype Val { typedef short Ar[9]; public Val::Ar ArMbr; public any anyMbr; public Itf ItfMbr; public FixStct FixStctMbr; public VarStct VarStctMbr; public FixU FixUMbr; public VarU VarUMbr; }; polyorb-2.8~20110207.orig/testsuite/idls/vt_m02/tin.idl0000644000175000017500000000111411750740340021756 0ustar xavierxavier// IDL-Spec for testgroup: valuetype // Purpose: Member of type 'any' in valuetype interface Itf {}; struct FixStct { long longMbr; }; struct VarStct { string stringMbr; }; const short n=9; union FixU switch (boolean) { case TRUE: long longMbr; case FALSE: short shortMbr; }; union VarU switch (short) { case 1: string stringMbr; default: any anyMbr; }; valuetype Val { //state typedef short Ar[n]; public Ar ArMbr; public any anyMbr; public Itf ItfMbr; public FixStct FixStctMbr; public VarStct VarStctMbr; public FixU FixUMbr; public VarU VarUMbr; }; polyorb-2.8~20110207.orig/testsuite/idls/harness/0000755000175000017500000000000011750740340021031 5ustar xavierxavierpolyorb-2.8~20110207.orig/testsuite/idls/harness/server_thread_pool_hahs.adb0000644000175000017500000000532511750740340026377 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- S E R V E R _ T H R E A D _ P O O L _ H A H S -- -- -- -- B o d y -- -- -- -- Copyright (C) 2004 Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by ACT Europe. -- -- (email: sales@act-europe.fr) -- -- -- ------------------------------------------------------------------------------ with Server_Common; with PolyORB.ORB.Thread_Pool; pragma Elaborate_All (PolyORB.ORB.Thread_Pool); pragma Warnings (Off, PolyORB.ORB.Thread_Pool); with PolyORB.Setup.Server; pragma Elaborate_All (PolyORB.Setup.Server); pragma Warnings (Off, PolyORB.Setup.Server); with PolyORB.Setup.Tasking.Full_Tasking; pragma Elaborate_All (PolyORB.Setup.Tasking.Full_Tasking); pragma Warnings (Off, PolyORB.Setup.Tasking.Full_Tasking); with PolyORB.ORB_Controller.Half_Sync_Half_Async; pragma Warnings (Off, PolyORB.ORB_Controller.Half_Sync_Half_Async); pragma Elaborate_All (PolyORB.ORB_Controller.Half_Sync_Half_Async); procedure Server_Thread_Pool_HAHS is begin Server_Common.Launch_Server; end Server_Thread_Pool_HAHS; polyorb-2.8~20110207.orig/testsuite/idls/harness/server_thread_per_request.adb0000644000175000017500000000436711750740340026766 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- S E R V E R _ T H R E A D _ P E R _ R E Q U E S T -- -- -- -- B o d y -- -- -- -- Copyright (C) 2004 Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by ACT Europe. -- -- (email: sales@act-europe.fr) -- -- -- ------------------------------------------------------------------------------ with Server_Common; with PolyORB.Setup.Thread_Per_Request_Server; pragma Warnings (Off, PolyORB.Setup.Thread_Per_Request_Server); procedure Server_Thread_Per_Request is begin Server_Common.Launch_Server; end Server_Thread_Per_Request; polyorb-2.8~20110207.orig/testsuite/idls/harness/client_common.adb0000644000175000017500000000267511750740340024341 0ustar xavierxavierwith Ada.Command_Line; with Ada.Real_Time; with Ada.Text_IO; with CORBA.ORB; with PolyORB.Utils.Report; with Harness; package body Client_Common is ------------------- -- Launch_Client -- ------------------- procedure Launch_Client is use Ada.Real_Time; use CORBA; use PolyORB.Utils.Report; use Harness; IOR : CORBA.String; MyHarness : Harness.Ref; Ok : Boolean := True; T0, T1 : Time; Delta1 : Duration; How_Many : Integer; begin New_Test ("Harness"); CORBA.ORB.Initialize ("ORB"); if Ada.Command_Line.Argument_Count < 1 then Ada.Text_IO.Put_Line ("usage : client [how_many]"); return; end if; IOR := CORBA.To_CORBA_String (Ada.Command_Line.Argument (1)); ORB.String_To_Object (IOR, MyHarness); Output ("test not nil reference", not Is_Nil (MyHarness)); if Ada.Command_Line.Argument_Count = 2 then How_Many := Integer'Value (Ada.Command_Line.Argument (2)); else How_Many := 1_000; end if; T0 := Clock; for J in 1 .. How_Many loop Ok := Ok and (echoULong (MyHarness, 1234) = 1234); end loop; T1 := Clock; Output ("Test success", Ok); Delta1 := To_Duration (T1 - T0); Ada.Text_IO.Put_Line ("Time: " & Duration'Image (Delta1) & "s"); End_Report; end Launch_Client; end Client_Common; polyorb-2.8~20110207.orig/testsuite/idls/harness/harness.idl0000644000175000017500000000011111750740340023157 0ustar xavierxavierinterface Harness { unsigned long echoULong(in unsigned long arg) ; }; polyorb-2.8~20110207.orig/testsuite/idls/harness/server_no_tasking.adb0000644000175000017500000000432711750740340025231 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- S E R V E R _ N O _ T A S K I N G -- -- -- -- B o d y -- -- -- -- Copyright (C) 2004 Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by ACT Europe. -- -- (email: sales@act-europe.fr) -- -- -- ------------------------------------------------------------------------------ with Server_Common; with PolyORB.Setup.No_Tasking_Server; pragma Warnings (Off, PolyORB.Setup.No_Tasking_Server); procedure Server_No_Tasking is begin Server_Common.Launch_Server; end Server_No_Tasking; polyorb-2.8~20110207.orig/testsuite/idls/harness/server_common.adb0000644000175000017500000000574511750740340024372 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- S E R V E R _ C O M M O N -- -- -- -- B o d y -- -- -- -- Copyright (C) 2004 Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by ACT Europe. -- -- (email: sales@act-europe.fr) -- -- -- ------------------------------------------------------------------------------ -- $Id: server_common.adb 6558 2004-06-21 10:24:28Z hugues $ with Ada.Text_IO; with CORBA.Impl; with CORBA.Object; with CORBA.ORB; with PortableServer; with Harness.Impl; with PolyORB.CORBA_P.Server_Tools; package body Server_Common is ------------------- -- Launch_Server -- ------------------- procedure Launch_Server is use PolyORB.CORBA_P.Server_Tools; begin Ada.Text_IO.Put_Line ("Server starting."); CORBA.ORB.Initialize ("ORB"); declare Obj : constant CORBA.Impl.Object_Ptr := new Harness.Impl.Object; Ref : CORBA.Object.Ref; begin Initiate_Servant (PortableServer.Servant (Obj), Ref); -- Print IOR so that we can give it to a client Ada.Text_IO.Put_Line ("'" & CORBA.To_Standard_String (CORBA.Object.Object_To_String (Ref)) & "'"); -- Launch the server Initiate_Server; end; end Launch_Server; end Server_Common; polyorb-2.8~20110207.orig/testsuite/idls/harness/client_common.ads0000644000175000017500000000412111750740340024346 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- C L I E N T _ C O M M O N -- -- -- -- S p e c -- -- -- -- Copyright (C) 2004 Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by ACT Europe. -- -- (email: sales@act-europe.fr) -- -- -- ------------------------------------------------------------------------------ package Client_Common is procedure Launch_Client; end Client_Common; polyorb-2.8~20110207.orig/testsuite/idls/harness/server_thread_pool_lf.adb0000644000175000017500000000530511750740340026053 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- S E R V E R _ T H R E A D _ P O O L _ H A H S -- -- -- -- B o d y -- -- -- -- Copyright (C) 2004 Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by ACT Europe. -- -- (email: sales@act-europe.fr) -- -- -- ------------------------------------------------------------------------------ with Server_Common; with PolyORB.ORB.Thread_Pool; pragma Elaborate_All (PolyORB.ORB.Thread_Pool); pragma Warnings (Off, PolyORB.ORB.Thread_Pool); with PolyORB.Setup.Server; pragma Elaborate_All (PolyORB.Setup.Server); pragma Warnings (Off, PolyORB.Setup.Server); with PolyORB.Setup.Tasking.Full_Tasking; pragma Elaborate_All (PolyORB.Setup.Tasking.Full_Tasking); pragma Warnings (Off, PolyORB.Setup.Tasking.Full_Tasking); with PolyORB.ORB_Controller.Leader_Followers; pragma Warnings (Off, PolyORB.ORB_Controller.Leader_Followers); pragma Elaborate_All (PolyORB.ORB_Controller.Leader_Followers); procedure Server_Thread_Pool_LF is begin Server_Common.Launch_Server; end Server_Thread_Pool_LF; polyorb-2.8~20110207.orig/testsuite/idls/harness/Makefile0000644000175000017500000000120511750740340022467 0ustar xavierxavierSHELL = /bin/sh GNATCHOP = gnatchop GNATFLAGS = -g -O2 -gnatfy -gnatwae -gnatpn GNATMAKE = gnatmake all: servers client force: servers: force harness-skel.ads $(GNATMAKE) server*.adb -I../../../../perforce/cos/naming/ `polyorb-config` client: force harness-skel.ads $(GNATMAKE) client.adb -I../../../../perforce/cos/naming/ `polyorb-config` harness-skel.ads: harness.idl iac -ada harness.idl > iac.ada $(GNATCHOP) -w iac.ada clean: @-rm -f *.o *.ali *ir_info* @-rm -f client server_no_tasking *skel* *helper* *idl_file* @-rm -f harness.ad* iac.ada GNAT* *~ @-rm -f server*_tasking2 s*request s*pool s*session s*lf s*hahs polyorb-2.8~20110207.orig/testsuite/idls/harness/server_no_tasking2.adb0000644000175000017500000000524311750740340025311 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- S E R V E R _ N O _ T A S K I N G 2 -- -- -- -- B o d y -- -- -- -- Copyright (C) 2004 Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by ACT Europe. -- -- (email: sales@act-europe.fr) -- -- -- ------------------------------------------------------------------------------ with Server_Common; with PolyORB.ORB.No_Tasking; pragma Warnings (Off, PolyORB.ORB.No_Tasking); pragma Elaborate_All (PolyORB.ORB.No_Tasking); with PolyORB.ORB_Controller.No_Tasking; pragma Warnings (Off, PolyORB.ORB_Controller.No_Tasking); pragma Elaborate_All (PolyORB.ORB_Controller.No_Tasking); with PolyORB.Setup.Server; pragma Elaborate_All (PolyORB.Setup.Server); pragma Warnings (Off, PolyORB.Setup.Server); with PolyORB.Setup.Tasking.No_Tasking; pragma Warnings (Off, PolyORB.Setup.Tasking.No_Tasking); pragma Elaborate_All (PolyORB.Setup.Tasking.No_Tasking); procedure Server_No_Tasking2 is begin Server_Common.Launch_Server; end Server_No_Tasking2; polyorb-2.8~20110207.orig/testsuite/idls/harness/server_thread_pool.adb0000644000175000017500000000433311750740340025372 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- S E R V E R _ T H R E A D _ P O O L -- -- -- -- B o d y -- -- -- -- Copyright (C) 2004 Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by ACT Europe. -- -- (email: sales@act-europe.fr) -- -- -- ------------------------------------------------------------------------------ with Server_Common; with PolyORB.Setup.Thread_Pool_Server; pragma Warnings (Off, PolyORB.Setup.Thread_Pool_Server); procedure Server_Thread_Pool is begin Server_Common.Launch_Server; end Server_Thread_Pool; polyorb-2.8~20110207.orig/testsuite/idls/harness/harness-impl.ads0000644000175000017500000000451611750740340024132 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- H A R N E S S . I M P L -- -- -- -- S p e c -- -- -- -- Copyright (C) 2004-2008, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by ACT Europe. -- -- (email: sales@act-europe.fr) -- -- -- ------------------------------------------------------------------------------ -- $Id: harness-impl.ads 6558 2004-06-21 10:24:28Z hugues $ with CORBA; with PortableServer; package Harness.Impl is type Object is new PortableServer.Servant_Base with null record; function echoULong (Self : access Object; arg : CORBA.Unsigned_Long) return CORBA.Unsigned_Long; end Harness.Impl; polyorb-2.8~20110207.orig/testsuite/idls/harness/server_common.ads0000644000175000017500000000412111750740340024376 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- S E R V E R _ C O M M O N -- -- -- -- S p e c -- -- -- -- Copyright (C) 2004 Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by ACT Europe. -- -- (email: sales@act-europe.fr) -- -- -- ------------------------------------------------------------------------------ package Server_Common is procedure Launch_Server; end Server_Common; polyorb-2.8~20110207.orig/testsuite/idls/harness/harness-impl.adb0000644000175000017500000000472411750740340024112 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- A L L _ T Y P E S . I M P L -- -- -- -- B o d y -- -- -- -- Copyright (C) 2002-2008, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by ACT Europe. -- -- (email: sales@act-europe.fr) -- -- -- ------------------------------------------------------------------------------ -- $Id: harness-impl.adb 6558 2004-06-21 10:24:28Z hugues $ with Harness.Skel; pragma Elaborate (Harness.Skel); pragma Warnings (Off, Harness.Skel); package body Harness.Impl is --------------- -- echoULong -- --------------- function echoULong (Self : access Object; arg : CORBA.Unsigned_Long) return CORBA.Unsigned_Long is pragma Unreferenced (Self); begin return arg; end echoULong; end Harness.Impl; polyorb-2.8~20110207.orig/testsuite/idls/harness/server_thread_per_session.adb0000644000175000017500000000436711750740340026761 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- S E R V E R _ T H R E A D _ P E R _ S E S S I O N -- -- -- -- B o d y -- -- -- -- Copyright (C) 2004 Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by ACT Europe. -- -- (email: sales@act-europe.fr) -- -- -- ------------------------------------------------------------------------------ with Server_Common; with PolyORB.Setup.Thread_Per_Session_Server; pragma Warnings (Off, PolyORB.Setup.Thread_Per_Session_Server); procedure Server_Thread_Per_Session is begin Server_Common.Launch_Server; end Server_Thread_Per_Session; polyorb-2.8~20110207.orig/testsuite/idls/harness/client.adb0000644000175000017500000000434411750740340022764 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- C L I E N T -- -- -- -- B o d y -- -- -- -- Copyright (C) 2004 Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by ACT Europe. -- -- (email: sales@act-europe.fr) -- -- -- ------------------------------------------------------------------------------ -- $Id: client.adb 6571 2004-06-24 09:39:02Z hugues $ with PolyORB.Setup.Client; pragma Warnings (Off, PolyORB.Setup.Client); with Client_Common; procedure Client is begin Client_Common.Launch_Client; end Client; polyorb-2.8~20110207.orig/testsuite/idls/test026/0000755000175000017500000000000011750740340020575 5ustar xavierxavierpolyorb-2.8~20110207.orig/testsuite/idls/test026/test.out0000644000175000017500000000371011750740340022306 0ustar xavierxaviertypedef sequence, 18> GoldenDelicous; typedef sequence> CrabApple[13]; typedef sequence> Cinnamon; typedef sequence, 7> JuniperBerries[10]; typedef sequence, 19> Mustard; typedef sequence> Thyme[6]; typedef sequence> Tarragon; typedef sequence, 9> Cress[7]; interface idlServer { exception GoldenDelicousExcpt { GoldenDelicous ex1; }; attribute GoldenDelicous GoldenDelicousAttr; GoldenDelicous GoldenDelicousOp(in GoldenDelicous p1, out GoldenDelicous p2, inout GoldenDelicous p3) raises (idlServer::GoldenDelicousExcpt); exception CrabAppleExcpt { CrabApple ex1; }; attribute CrabApple CrabAppleAttr; CrabApple CrabAppleOp(in CrabApple p1, out CrabApple p2, inout CrabApple p3) raises (idlServer::CrabAppleExcpt); exception CinnamonExcpt { Cinnamon ex1; }; attribute Cinnamon CinnamonAttr; Cinnamon CinnamonOp(in Cinnamon p1, out Cinnamon p2, inout Cinnamon p3) raises (idlServer::CinnamonExcpt); exception JuniperBerriesExcpt { JuniperBerries ex1; }; attribute JuniperBerries JuniperBerriesAttr; JuniperBerries JuniperBerriesOp(in JuniperBerries p1, out JuniperBerries p2, inout JuniperBerries p3) raises (idlServer::JuniperBerriesExcpt); exception MustardExcpt { Mustard ex1; }; attribute Mustard MustardAttr; Mustard MustardOp(in Mustard p1, out Mustard p2, inout Mustard p3) raises (idlServer::MustardExcpt); exception ThymeExcpt { Thyme ex1; }; attribute Thyme ThymeAttr; Thyme ThymeOp(in Thyme p1, out Thyme p2, inout Thyme p3) raises (idlServer::ThymeExcpt); exception TarragonExcpt { Tarragon ex1; }; attribute Tarragon TarragonAttr; Tarragon TarragonOp(in Tarragon p1, out Tarragon p2, inout Tarragon p3) raises (idlServer::TarragonExcpt); exception CressExcpt { Cress ex1; }; attribute Cress CressAttr; Cress CressOp(in Cress p1, out Cress p2, inout Cress p3) raises (idlServer::CressExcpt); }; polyorb-2.8~20110207.orig/testsuite/idls/types005/0000755000175000017500000000000011750740340020757 5ustar xavierxavierpolyorb-2.8~20110207.orig/testsuite/idls/types005/test.out0000644000175000017500000000006611750740340022471 0ustar xavierxavierENUM := True STRING := True ULONG := True ANY := True polyorb-2.8~20110207.orig/testsuite/idls/types005/tin.idl0000644000175000017500000000006711750740340022246 0ustar xavierxavierinterface tin { enum Color { Red, Blue, Green }; }; polyorb-2.8~20110207.orig/testsuite/idls/va_f02/0000755000175000017500000000000011750740340020443 5ustar xavierxavierpolyorb-2.8~20110207.orig/testsuite/idls/va_f02/test.out0000644000175000017500000000015411750740340022153 0ustar xavierxaviervaluetype AVal; valuetype BVal { public AVal Mbr; }; valuetype AVal : BVal { }; valuetype CVal : AVal { }; polyorb-2.8~20110207.orig/testsuite/idls/va_f02/tin.idl0000644000175000017500000000031011750740340021721 0ustar xavierxavier//testsubgroup forward //tsgdescr "Testing forward declaration for the valuetype construct" valuetype AVal; valuetype BVal { public AVal Mbr; }; valuetype AVal:BVal {}; valuetype CVal:AVal {}; polyorb-2.8~20110207.orig/testsuite/idls/test013/0000755000175000017500000000000011750740340020571 5ustar xavierxavierpolyorb-2.8~20110207.orig/testsuite/idls/test013/test.out0000644000175000017500000000055611750740340022307 0ustar xavierxavierinterface Banana { const float Apple = 2.34E+1; typedef long Dates; exception Orange { short Starfruit; }; }; interface idlServer : Banana { const short Apple = 5; typedef struct Dates { char Dill; } Oregano; exception Orange { float Aniseed; double Bayleaf; }; void Lemon(in idlServer::Dates p1, inout Banana::Dates p2) raises (idlServer::Orange); }; polyorb-2.8~20110207.orig/testsuite/idls/idl15032/0000755000175000017500000000000011750740340020531 5ustar xavierxavierpolyorb-2.8~20110207.orig/testsuite/idls/idl15032/test.out0000644000175000017500000000026311750740340022242 0ustar xavierxaviertin.idl:13:20: "ArgType" conflicts with scoped name at line 8 tin.idl:14:10: "I" conflicts with scoped name at line 8 tin.idl:21:10: "ArgType" not declared in "A" iac: 3 error(s) polyorb-2.8~20110207.orig/testsuite/idls/idl15032/tin.idl0000644000175000017500000000124411750740340022016 0ustar xavierxaviermodule M { typedef long ArgType; const long I = 10; typedef short Y; interface A { struct S { struct T { ArgType x[I]; // ArgType and I introduced long y; // a new y is defined, the existing Y // is not used } m; }; typedef string ArgType; // Error: ArgType redefined enum I { I1, I2 }; // Error: I redefined typedef short Y; // OK }; // Potential scope of ArgType and I ends here interface B : A { typedef long ArgType; // OK, redefined in derived interface struct S { // OK, redefined in derived interface ArgType x; // x is a long A::ArgType y; // y is a string }; }; }; polyorb-2.8~20110207.orig/testsuite/idls/test025/0000755000175000017500000000000011750740340020574 5ustar xavierxavierpolyorb-2.8~20110207.orig/testsuite/idls/test025/test.out0000644000175000017500000000351211750740340022305 0ustar xavierxaviertypedef sequence Sweetcorn; typedef sequence Onion[13]; typedef sequence> Shallots; typedef sequence> Plum[15]; typedef sequence, 11> KidneyBean; typedef sequence, 7> Zucchini[10]; typedef sequence> ButterBean; typedef sequence> Avocado[6]; interface idlServer { exception SweetcornExcpt { Sweetcorn ex1; }; attribute Sweetcorn SweetcornAttr; Sweetcorn SweetcornOp(in Sweetcorn p1, out Sweetcorn p2, inout Sweetcorn p3) raises (idlServer::SweetcornExcpt); exception OnionExcpt { Onion ex1; }; attribute Onion OnionAttr; Onion OnionOp(in Onion p1, out Onion p2, inout Onion p3) raises (idlServer::OnionExcpt); exception ShallotsExcpt { Shallots ex1; }; attribute Shallots ShallotsAttr; Shallots ShallotsOp(in Shallots p1, out Shallots p2, inout Shallots p3) raises (idlServer::ShallotsExcpt); exception PlumExcpt { Plum ex1; }; attribute Plum PlumAttr; Plum PlumOp(in Plum p1, out Plum p2, inout Plum p3) raises (idlServer::PlumExcpt); exception KidneyBeanExcpt { KidneyBean ex1; }; attribute KidneyBean KidneyBeanAttr; KidneyBean KidneyBeanOp(in KidneyBean p1, out KidneyBean p2, inout KidneyBean p3) raises (idlServer::KidneyBeanExcpt); exception ZucchiniExcpt { Zucchini ex1; }; attribute Zucchini ZucchiniAttr; Zucchini ZucchiniOp(in Zucchini p1, out Zucchini p2, inout Zucchini p3) raises (idlServer::ZucchiniExcpt); exception ButterBeanExcpt { ButterBean ex1; }; attribute ButterBean ButterBeanAttr; ButterBean ButterBeanOp(in ButterBean p1, out ButterBean p2, inout ButterBean p3) raises (idlServer::ButterBeanExcpt); exception AvocadoExcpt { Avocado ex1; }; attribute Avocado AvocadoAttr; Avocado AvocadoOp(in Avocado p1, out Avocado p2, inout Avocado p3) raises (idlServer::AvocadoExcpt); }; polyorb-2.8~20110207.orig/testsuite/idls/header-sort0000755000175000017500000000032211750740340021526 0ustar xavierxavier#!/bin/sh n=0 for i in `cat MANIFEST`; do \ grep -H -- '^ -- .* --' $i >log1; \ sort log1 >log2; \ diff log1 log2; \ if [ "$?" != "0" ]; then n=`expr $n + 1` fi done rm log1 log2 exit $n polyorb-2.8~20110207.orig/testsuite/idls/idl15023/0000755000175000017500000000000011750740340020531 5ustar xavierxavierpolyorb-2.8~20110207.orig/testsuite/idls/idl15023/test.out0000644000175000017500000000011411750740340022235 0ustar xavierxaviertin.idl:7:20: "inner1" conflicts with scoped name at line 6 iac: 1 error(s) polyorb-2.8~20110207.orig/testsuite/idls/idl15023/tin.idl0000644000175000017500000000030311750740340022011 0ustar xavierxaviermodule M { module Inner1 { typedef string S1; }; module Inner2{ typedef Inner1::S1 S2; // Inner1 introduced typedef string inner1; // Error typedef string S1; // OK }; }; polyorb-2.8~20110207.orig/testsuite/idls/anon_types001/0000755000175000017500000000000011750740340021766 5ustar xavierxavierpolyorb-2.8~20110207.orig/testsuite/idls/anon_types001/tin.idl0000644000175000017500000000117111750740340023252 0ustar xavierxavierinterface int1 { typedef sequence> MySeq; MySeq echoMySeq (in MySeq data); struct MyStruct { long memb1; sequence memb2; short memb3[5]; string<3> memb4; wstring<12> memb5; fixed<12,3> fixedMember; }; MyStruct echoMyStruct (in MyStruct data); union MyUnion switch (long) { case 1: long Counter; case 2: sequence Flag; case 3: sequence> Hue; case 5: fixed<14,6> fixedElement; default: long Unknown[7]; }; MyUnion echoMyUnion (in MyUnion data); typedef sequence myType[3]; }; polyorb-2.8~20110207.orig/testsuite/idls/ir001/0000755000175000017500000000000011750740340020221 5ustar xavierxavierpolyorb-2.8~20110207.orig/testsuite/idls/ir001/tin.idl0000644000175000017500000000135411750740340021510 0ustar xavierxaviermodule m { interface f; enum Color { Red, Green, Blue }; union myUnionEnumSwitch switch (Color) { case Red: long foo; case Green: short bar; case Blue: string baz; }; interface f { typedef long long1; typedef long long_array[5]; typedef long long_arr[5][8][11][13][24]; typedef long_array long_array2; readonly attribute long Counter; attribute long Counter_2; long1 echolong (in long arg); boolean echoBoolean(in boolean arg); }; interface g { typedef long g_long1; readonly attribute long g_Counter; attribute long g_Counter_2; g_long1 g_echolong (in long arg); boolean g_echoBoolean(in boolean arg); }; interface h : f, g { }; }; polyorb-2.8~20110207.orig/testsuite/idls/local001/0000755000175000017500000000000011750740340020701 5ustar xavierxavierpolyorb-2.8~20110207.orig/testsuite/idls/local001/tin.idl0000644000175000017500000000021211750740340022160 0ustar xavierxaviermodule m { local interface LocInt { long op1 (in long var1, inout short var2, out string var3); attribute long MyAttr; }; }; polyorb-2.8~20110207.orig/testsuite/idls/test009/0000755000175000017500000000000011750740340020576 5ustar xavierxavierpolyorb-2.8~20110207.orig/testsuite/idls/test009/test.out0000644000175000017500000000046211750740340022310 0ustar xavierxaviertypedef long Apple; typedef long Banana; typedef long Carrots; typedef long Lemon; typedef long BlackCherry; typedef long Starfruit; typedef long Rhubarb; interface idlServer { void PassionFruit(in Apple p1, in Banana p2, in Carrots p3, in Lemon p4, in BlackCherry p5, in Starfruit p6, in Rhubarb p7); }; polyorb-2.8~20110207.orig/testsuite/idls/test021/0000755000175000017500000000000011750740340020570 5ustar xavierxavierpolyorb-2.8~20110207.orig/testsuite/idls/test021/test.out0000644000175000017500000000134011750740340022276 0ustar xavierxaviermodule LoganBerry { module BlackCherry { typedef octet Starfruit; }; module Parsnip { typedef char Ginger; module Celery { struct Lychees { LoganBerry::Parsnip::Ginger Apricots; }; struct WhiteCabbage { LoganBerry::Parsnip::Ginger Apricots; }; }; }; interface Apple { typedef long Orange; exception Mint { long GardenPeas; }; }; interface Banana : LoganBerry::Apple { typedef LoganBerry::Apple::Orange GaliaMelon; void Sultana(); }; }; interface Carrots : LoganBerry::Apple { typedef float Turnip; }; interface idlServer : LoganBerry::Banana, Carrots { typedef char Orange; attribute LoganBerry::Parsnip::Celery::WhiteCabbage Aniseed; void Bayleaf(in LoganBerry::Banana::GaliaMelon p1, out long Aniseed); }; polyorb-2.8~20110207.orig/testsuite/idls/test028/0000755000175000017500000000000011750740340020577 5ustar xavierxavierpolyorb-2.8~20110207.orig/testsuite/idls/test028/test.out0000644000175000017500000000405011750740340022306 0ustar xavierxaviertypedef sequence, 18> Papaya; typedef sequence> Raspberry[13]; typedef sequence> Damsons; typedef sequence, 7> Artichokes[10]; typedef sequence, 19> CookingApple; typedef sequence, 6> GreenChilly[9]; typedef sequence, 7>> YellowPepper; typedef sequence>> Blueberry[3]; interface idlServer { exception PapayaExcpt { Papaya ex1; }; attribute Papaya PapayaAttr; Papaya PapayaOp(in Papaya p1, out Papaya p2, inout Papaya p3) raises (idlServer::PapayaExcpt); exception RaspberryExcpt { Raspberry ex1; }; attribute Raspberry RaspberryAttr; Raspberry RaspberryOp(in Raspberry p1, out Raspberry p2, inout Raspberry p3) raises (idlServer::RaspberryExcpt); exception DamsonsExcpt { Damsons ex1; }; attribute Damsons DamsonsAttr; Damsons DamsonsOp(in Damsons p1, out Damsons p2, inout Damsons p3) raises (idlServer::DamsonsExcpt); exception ArtichokesExcpt { Artichokes ex1; }; attribute Artichokes ArtichokesAttr; Artichokes ArtichokesOp(in Artichokes p1, out Artichokes p2, inout Artichokes p3) raises (idlServer::ArtichokesExcpt); exception CookingAppleExcpt { CookingApple ex1; }; attribute CookingApple CookingAppleAttr; CookingApple CookingAppleOp(in CookingApple p1, out CookingApple p2, inout CookingApple p3) raises (idlServer::CookingAppleExcpt); exception GreenChillyExcpt { GreenChilly ex1; }; attribute GreenChilly GreenChillyAttr; GreenChilly GreenChillyOp(in GreenChilly p1, out GreenChilly p2, inout GreenChilly p3) raises (idlServer::GreenChillyExcpt); exception YellowPepperExcpt { YellowPepper ex1; }; attribute YellowPepper YellowPepperAttr; YellowPepper YellowPepperOp(in YellowPepper p1, out YellowPepper p2, inout YellowPepper p3) raises (idlServer::YellowPepperExcpt); exception BlueberryExcpt { Blueberry ex1; }; attribute Blueberry BlueberryAttr; Blueberry BlueberryOp(in Blueberry p1, out Blueberry p2, inout Blueberry p3) raises (idlServer::BlueberryExcpt); }; polyorb-2.8~20110207.orig/testsuite/idls/inherit004/0000755000175000017500000000000011750740340021254 5ustar xavierxavierpolyorb-2.8~20110207.orig/testsuite/idls/inherit004/tin.idl0000644000175000017500000000203011750740340022533 0ustar xavierxaviermodule m { interface int1 { short op1(); attribute long attr1, attr11; typedef string myType1; const long myConstant1 = 1; exception myException1 {}; struct myStruct1 { long a; short b; }; union myUnion1 switch (long) { case 1: case 3: long counter; case 2: boolean flag; default: long unknown; }; enum Color {Red, Green, Blue}; }; interface int2 { short op2(); attribute long attr2, attr22; typedef string myType2; const long myConstant2 = 2; exception myException2 {}; struct myStruct2 { long e; short f; }; union myUnion2 switch (long) { case 1: long counter; case 2: boolean flag; case 4: string name; default: long unknown; }; enum Week {Monday, Tuesday, Wednesday, Thursday, Friday, Saturday, Sunday}; }; interface int3 : int1, int2 { short op3(); attribute long attr3, attr33; typedef string myType3; const long myConstant3 = 3; exception myException3 {}; }; }; polyorb-2.8~20110207.orig/testsuite/idls/types010/0000755000175000017500000000000011750740340020753 5ustar xavierxavierpolyorb-2.8~20110207.orig/testsuite/idls/types010/test.out0000644000175000017500000000005111750740340022457 0ustar xavierxavierSTRING := True ULONG := True ANY := True polyorb-2.8~20110207.orig/testsuite/idls/types010/tin.idl0000644000175000017500000000007011750740340022234 0ustar xavierxavierinterface tin { string echostring (in string arg); }; polyorb-2.8~20110207.orig/testsuite/idls/pp-idl0000755000175000017500000000102311750740340020475 0ustar xavierxavier#!/bin/sh # Pretty Print an idl file by # 1) removing useless blanks # 2) removing comments # 3) removing preprocessor directives BASE=`basename $0` FILE=/tmp/$BASE.$$ if [ $# = 0 ]; then cat >$FILE else FILE=$1 fi sed ' /^#/d /:.*arning/d s,^[ /]\*.*$,,g s,\t, ,g s,//.*,,g s,/\*.*\*/,,g s,\([^: ]\):$,\1 :,g s,( ,(,g s, ),),g s, *, ,g s, $,,g /^ *$/d ' $FILE | awk ' BEGIN{l=" "} {if ($0 == "{") {print l " {"; l=" "} else {if (l != " ") {print l}; l=$0}} END{if (l != "") {print l}}' if [ $# = 0 ]; then rm $FILE fi polyorb-2.8~20110207.orig/testsuite/idls/abstract001/0000755000175000017500000000000011750740340021412 5ustar xavierxavierpolyorb-2.8~20110207.orig/testsuite/idls/abstract001/tin.idl0000644000175000017500000000021511750740340022674 0ustar xavierxaviermodule m { abstract interface AbsInt { long op1 (in long var1, inout short var2, out string var3); attribute long MyAttr; }; }; polyorb-2.8~20110207.orig/testsuite/idls/list_types.sh0000755000175000017500000000025611750740340022127 0ustar xavierxavier# !/bin/sh # This script tests the Types backend of IAC DIR=`dirname $1` FILE=`basename $1` RESULT="`basename $1 .idl`.typ" cd $DIR iac-types $FILE cat $RESULT rm $RESULT polyorb-2.8~20110207.orig/testsuite/idls/types001/0000755000175000017500000000000011750740340020753 5ustar xavierxavierpolyorb-2.8~20110207.orig/testsuite/idls/types001/test.out0000644000175000017500000000043411750740340022464 0ustar xavierxavierBOOLEAN := True SHORT := True LONG := True USHORT := True ULONG := True ULONGLONG := True FLOAT := True DOUBLE := True CHAR := True WCHAR := True OCTET := True STRING := True WSTRING := True LONGDOUBLE := True OBJECT := True TYPECODE := True ANY := True VOID := True LONGLONG := True polyorb-2.8~20110207.orig/testsuite/idls/types001/tin.idl0000644000175000017500000000135511750740340022243 0ustar xavierxavierinterface tin { boolean echoBoolean(in boolean arg) ; short echoShort(in short arg) ; long echoLong(in long arg) ; unsigned short echoUShort(in unsigned short arg) ; unsigned long echoULong(in unsigned long arg) ; unsigned long long echoULLong(in unsigned long long arg) ; float echoFloat(in float arg) ; double echoDouble(in double arg) ; char echoChar(in char arg) ; wchar echoWChar(in wchar arg) ; octet echoOctet (in octet arg) ; string echoString (in string arg) ; wstring echoWString (in wstring arg) ; long double echolongdouble (in long double arg); object echoObject (in object arg); any echoany (in any arg); void echovoid (in long arg); long long echolonglong (in long long arg); }; polyorb-2.8~20110207.orig/testsuite/idls/test042/0000755000175000017500000000000011750740340020573 5ustar xavierxavierpolyorb-2.8~20110207.orig/testsuite/idls/test042/test.out0000644000175000017500000000105011750740340022277 0ustar xavierxavierstruct Avocado { float ButterBean; }; struct GalaApple { float ButterBean[6], ChestNut, Currant[43], CoxPippin, Chervil, Scallion[23], Tomato[8]; }; interface idlServer { exception AvocadoExcpt { Avocado ex1; }; attribute Avocado AvocadoAttr; Avocado AvocadoOp(in Avocado p1, out Avocado p2, inout Avocado p3) raises (idlServer::AvocadoExcpt); exception GalaAppleExcpt { GalaApple ex1; }; attribute GalaApple GalaAppleAttr; GalaApple GalaAppleOp(in GalaApple p1, out GalaApple p2, inout GalaApple p3) raises (idlServer::GalaAppleExcpt); }; polyorb-2.8~20110207.orig/testsuite/idls/types006/0000755000175000017500000000000011750740340020760 5ustar xavierxavierpolyorb-2.8~20110207.orig/testsuite/idls/types006/test.out0000644000175000017500000000012411750740340022465 0ustar xavierxavierEXCEPT := True STRING := True ULONG := True LONG := True DOUBLE := True ANY := True polyorb-2.8~20110207.orig/testsuite/idls/types006/tin.idl0000644000175000017500000000010611750740340022241 0ustar xavierxavierinterface tin { exception my_exception {long info; double occ;}; }; polyorb-2.8~20110207.orig/testsuite/idls/local003/0000755000175000017500000000000011750740340020703 5ustar xavierxavierpolyorb-2.8~20110207.orig/testsuite/idls/local003/tin.idl0000644000175000017500000000156311750740340022174 0ustar xavierxaviermodule Test { local interface L { }; exception X { L ref_value; }; struct S { long long_value; L ref_value; }; union U switch (long) { case 0: L ref_value; case 1: long long_value; default: boolean bool_value; }; typedef L LT; typedef S ST; typedef U UT; typedef sequence LUS; typedef sequence LBS; typedef L LA[5]; typedef sequence SUS; typedef sequence SBS; typedef S SA[5]; typedef sequence LTUS; typedef sequence LTBS; typedef LT LTA[5]; typedef sequence STUS; typedef sequence STBS; typedef ST STA[5]; typedef sequence UUS; typedef sequence UBS; typedef U UA[5]; typedef sequence UTUS; typedef sequence UTBS; typedef UT UTA[5]; }; polyorb-2.8~20110207.orig/testsuite/idls/iac003/0000755000175000017500000000000011750740340020345 5ustar xavierxavierpolyorb-2.8~20110207.orig/testsuite/idls/iac003/test.out0000644000175000017500000000023111750740340022051 0ustar xavierxaviertin.idl:10:13: multiple declarations of "string_t" tin.idl:10:13: found declaration at line 6 tin.idl:10:13: found declaration at line 2 iac: 1 error(s) polyorb-2.8~20110207.orig/testsuite/idls/iac003/tin.idl0000644000175000017500000000036311750740340021633 0ustar xavierxavierinterface A { typedef string<128> string_t; }; interface B { typedef string<256> string_t; }; interface C: A, B { attribute string_t Title; // Error: Ambiguous attribute A::string_t Name; // OK attribute B::string_t City; // OK }; polyorb-2.8~20110207.orig/testsuite/idls/import001/0000755000175000017500000000000011750740340021121 5ustar xavierxavierpolyorb-2.8~20110207.orig/testsuite/idls/import001/int2.idl0000644000175000017500000000014511750740340022467 0ustar xavierxavierimport ::int1; interface int2 { typedef int1::type1 type2; type2 op2 (inout string arg); }; polyorb-2.8~20110207.orig/testsuite/idls/import001/int1.idl0000644000175000017500000000011211750740340022460 0ustar xavierxavierinterface int1 { typedef long type1; type1 op1 (in short data); }; polyorb-2.8~20110207.orig/testsuite/idls/import001/int3.idl0000644000175000017500000000022211750740340022464 0ustar xavierxavierimport ::int2; import ::int1; interface int3 { typedef int2::type2 type3; type3 op3 (out boolean bool); typedef int1::type1 type33; }; polyorb-2.8~20110207.orig/testsuite/idls/test022/0000755000175000017500000000000011750740340020571 5ustar xavierxavierpolyorb-2.8~20110207.orig/testsuite/idls/test022/test.out0000644000175000017500000000341211750740340022301 0ustar xavierxaviertypedef sequence LoganBerry; typedef sequence Parsnip[13]; typedef sequence Celery; typedef sequence WhiteCabbage[15]; typedef sequence Aniseed; typedef sequence Bayleaf[10]; typedef sequence Dill; typedef sequence Oregano[19]; interface idlServer { exception LoganBerryExcpt { LoganBerry ex1; }; attribute LoganBerry LoganBerryAttr; LoganBerry LoganBerryOp(in LoganBerry p1, out LoganBerry p2, inout LoganBerry p3) raises (idlServer::LoganBerryExcpt); exception ParsnipExcpt { Parsnip ex1; }; attribute Parsnip ParsnipAttr; Parsnip ParsnipOp(in Parsnip p1, out Parsnip p2, inout Parsnip p3) raises (idlServer::ParsnipExcpt); exception CeleryExcpt { Celery ex1; }; attribute Celery CeleryAttr; Celery CeleryOp(in Celery p1, out Celery p2, inout Celery p3) raises (idlServer::CeleryExcpt); exception WhiteCabbageExcpt { WhiteCabbage ex1; }; attribute WhiteCabbage WhiteCabbageAttr; WhiteCabbage WhiteCabbageOp(in WhiteCabbage p1, out WhiteCabbage p2, inout WhiteCabbage p3) raises (idlServer::WhiteCabbageExcpt); exception AniseedExcpt { Aniseed ex1; }; attribute Aniseed AniseedAttr; Aniseed AniseedOp(in Aniseed p1, out Aniseed p2, inout Aniseed p3) raises (idlServer::AniseedExcpt); exception BayleafExcpt { Bayleaf ex1; }; attribute Bayleaf BayleafAttr; Bayleaf BayleafOp(in Bayleaf p1, out Bayleaf p2, inout Bayleaf p3) raises (idlServer::BayleafExcpt); exception DillExcpt { Dill ex1; }; attribute Dill DillAttr; Dill DillOp(in Dill p1, out Dill p2, inout Dill p3) raises (idlServer::DillExcpt); exception OreganoExcpt { Oregano ex1; }; attribute Oregano OreganoAttr; Oregano OreganoOp(in Oregano p1, out Oregano p2, inout Oregano p3) raises (idlServer::OreganoExcpt); }; polyorb-2.8~20110207.orig/testsuite/idls/ada0013/0000755000175000017500000000000011750740340020417 5ustar xavierxavierpolyorb-2.8~20110207.orig/testsuite/idls/ada0013/tin.idl0000644000175000017500000000033711750740340021706 0ustar xavierxaviermodule mod1 { typedef boolean bool; interface Int1 { typedef float New_Float; enum Color {Red, Blue, Green}; attribute New_Float Real_Number; attribute Color couleur; attribute bool b1; }; }; polyorb-2.8~20110207.orig/testsuite/idls/iac-types0000755000175000017500000000023411750740340021211 0ustar xavierxavierINCLUDES= FILENAME= for i in $*; do case $i in -I*) INCLUDES="$INCLUDES $i";; -*) ;; *) FILENAME="$i";; esac; done iac $INCLUDES -types $FILENAME polyorb-2.8~20110207.orig/testsuite/idls/test007/0000755000175000017500000000000011750740340020574 5ustar xavierxavierpolyorb-2.8~20110207.orig/testsuite/idls/test007/test.out0000644000175000017500000000117711750740340022312 0ustar xavierxaviermodule Apple { struct BlackCherry { octet Carrots; Object Lemon; }; enum Starfruit { Rhubarb, PassionFruit, Pumpkin, Mango }; typedef sequence WaterMelon; }; typedef any BlackEyedBeans; typedef unsigned long Dates; union Cabbage switch (char) { case 'a' : double Coconut; default : float Lychees; }; const boolean Cucumber = TRUE; const boolean Ginger = FALSE; interface idlServer { exception Asparagus { Dates Leek; }; readonly attribute string Mint; void GardenPeas(out BlackEyedBeans p1, inout BlackEyedBeans p2) raises (idlServer::Asparagus); oneway void Banana(in BlackEyedBeans p1) context ("Orange"); }; polyorb-2.8~20110207.orig/testsuite/idls/vb_d03/0000755000175000017500000000000011750740340020443 5ustar xavierxavierpolyorb-2.8~20110207.orig/testsuite/idls/vb_d03/test.out0000644000175000017500000000007611750740340022156 0ustar xavierxaviertypedef long LongArray[2][3]; valuetype ArrayValue LongArray; polyorb-2.8~20110207.orig/testsuite/idls/vb_d03/tin.idl0000644000175000017500000000021511750740340021725 0ustar xavierxavier// IDL-Spec for testgroup: valuetype // Purpose: basic features of valuetype typedef long LongArray[2][3]; valuetype ArrayValue LongArray; polyorb-2.8~20110207.orig/testsuite/idls/test003/0000755000175000017500000000000011750740340020570 5ustar xavierxavierpolyorb-2.8~20110207.orig/testsuite/idls/test003/test.out0000644000175000017500000000073311750740340022303 0ustar xavierxavierconst long Apple = 0; const short Banana = 253; const long Carrots = 94873; const unsigned long Lemon = 4294967295; const long BlackCherry = 0; const long Starfruit = 10; const long PassionFruit = 342391; const unsigned long Orange = 4294967295; const long Dates = 74565; const long Pumpkin = 11259375; const long Mango = 11259375; const long WaterMelon = 1000418; const long Lime = 123051; const unsigned long Coconut = 4294967295; interface idlServer { void Lychees(); }; polyorb-2.8~20110207.orig/testsuite/idls/expansion01/0000755000175000017500000000000011750740340021533 5ustar xavierxavierpolyorb-2.8~20110207.orig/testsuite/idls/expansion01/expansion.idl0000644000175000017500000000016311750740340024231 0ustar xavierxavierinterface test_array { union u switch (short) { case 1: long e1; case 2: short e2[15][16]; }; }; polyorb-2.8~20110207.orig/testsuite/idls/test002/0000755000175000017500000000000011750740340020567 5ustar xavierxavierpolyorb-2.8~20110207.orig/testsuite/idls/test002/test.out0000644000175000017500000000211211750740340022273 0ustar xavierxavierstruct Avocado { float and; double and_eq; unsigned long auto; short bitand; unsigned short bitor; char bool; boolean break; octet catch; float class; double compl; long const_cast; unsigned long continue; short delete; unsigned short do; char dynamic_cast; boolean else; octet explicit; float extern; long for; unsigned long friend; short goto; unsigned short if; octet int; boolean mutable; float namespace; double new; long not; unsigned long not_eq; short operator; unsigned short or; char or_eq; boolean protected; double register; long reinterpret_cast; unsigned long return; short signed; unsigned short sizeof; char static; octet static_cast; boolean template; float this; double throw; short type_id; unsigned short typename; char using; octet virtual; boolean volatile; float wchar_t; double while; long xor; unsigned long xor_eq; }; interface idlServer { exception AvocadoExcpt { Avocado ex1; }; attribute Avocado AvocadoAttr; Avocado AvocadoOp(in Avocado p1, out Avocado p2, inout Avocado p3) raises (idlServer::AvocadoExcpt); }; polyorb-2.8~20110207.orig/testsuite/idls/test052/0000755000175000017500000000000011750740340020574 5ustar xavierxavierpolyorb-2.8~20110207.orig/testsuite/idls/test052/test.out0000644000175000017500000000211011750740340022276 0ustar xavierxavierunion Broadbeans switch (enum Fennell { UgliFruit, Chickpea, Waterchestnut, Cress, BambooShoot, BeechNut, KidneyBean, Onion, Sweetcorn, LolloRossa, CantelopeMelon, Zucchini, Shallots }) { case Broadbeans::UgliFruit : float ButterBean; case Broadbeans::Chickpea : unsigned long Fig; case Broadbeans::Waterchestnut : double Cinnamon; case Broadbeans::BambooShoot : long BreadFruit; case Broadbeans::BeechNut : long Tarragon; case Broadbeans::Sweetcorn : unsigned short Pineapple; case Broadbeans::LolloRossa : unsigned short RedPepper; case Broadbeans::CantelopeMelon : char Radish; }; interface idlServer { exception BroadbeansExcpt { Broadbeans ex1; }; attribute Broadbeans BroadbeansAttr; Broadbeans BroadbeansOp(in Broadbeans p1, out Broadbeans p2, inout Broadbeans p3) raises (idlServer::BroadbeansExcpt); exception FennellExcpt { Broadbeans::Fennell ex1; }; attribute Broadbeans::Fennell FennellAttr; Broadbeans::Fennell FennellOp(in Broadbeans::Fennell p1, out Broadbeans::Fennell p2, inout Broadbeans::Fennell p3) raises (idlServer::FennellExcpt); }; polyorb-2.8~20110207.orig/testsuite/idls/va_t01/0000755000175000017500000000000011750740340020460 5ustar xavierxavierpolyorb-2.8~20110207.orig/testsuite/idls/va_t01/test.out0000644000175000017500000000027111750740340022170 0ustar xavierxaviervaluetype AVal { typedef long TypeLong; public AVal::TypeLong Mbr1; }; valuetype BVal : AVal { public AVal::TypeLong Mbr2; }; valuetype CVal : BVal { public AVal::TypeLong Mbr3; }; polyorb-2.8~20110207.orig/testsuite/idls/va_t01/tin.idl0000644000175000017500000000043611750740340021747 0ustar xavierxavier//testsubgroup typedef_inheritance //tsgdescr "Testing scope of typedef declarations with the valuetype inheritance" valuetype AVal { typedef long TypeLong; public TypeLong Mbr1; }; valuetype BVal : AVal { public TypeLong Mbr2; }; valuetype CVal : BVal { public TypeLong Mbr3; }; polyorb-2.8~20110207.orig/testsuite/idls/local002/0000755000175000017500000000000011750740340020702 5ustar xavierxavierpolyorb-2.8~20110207.orig/testsuite/idls/local002/tin.idl0000644000175000017500000000042211750740340022164 0ustar xavierxaviermodule m { local interface LocInt { long op1 (in long var1, inout short var2, out string var3); attribute long MyAttr; }; local interface LocInt2 : LocInt{ long op2 (in long var1, inout short var2, out string var3); attribute long MyAttr2; }; }; polyorb-2.8~20110207.orig/testsuite/idls/parse_file.sh0000755000175000017500000000016611750740340022041 0ustar xavierxavier#!/bin/sh # This script parse an IDL file DIR=`dirname $1` FILE=`basename $1` cd $DIR iac-idl -I../corba_idl $FILE polyorb-2.8~20110207.orig/testsuite/idls/vti_si02/0000755000175000017500000000000011750740340021025 5ustar xavierxavierpolyorb-2.8~20110207.orig/testsuite/idls/vti_si02/test.out0000644000175000017500000000023211750740340022532 0ustar xavierxavierinterface Itf { short op1(); long op2(); }; abstract valuetype AbsVal supports Itf { short op3(); }; valuetype Val : AbsVal { public short shrMbr; }; polyorb-2.8~20110207.orig/testsuite/idls/vti_si02/tin.idl0000644000175000017500000000043211750740340022310 0ustar xavierxavier//testsubgroup a valuetype supporting an interface //tsgdescr "Testing a (abstract) valuetype supporting an interface" interface Itf { short op1(); long op2(); }; abstract valuetype AbsVal supports Itf { short op3(); }; valuetype Val: AbsVal { public short shrMbr; }; polyorb-2.8~20110207.orig/testsuite/idls/corba_idl/0000755000175000017500000000000011750740340021304 5ustar xavierxavierpolyorb-2.8~20110207.orig/testsuite/idls/corba_idl/CORBA_StandardExceptions.idl0000644000175000017500000000732511750740340026515 0ustar xavierxavier// File: CORBA_StandardExceptions.idl // CORBA 3.0, Chapter 4 //PolyORB:NI: const unsigned long OMGVMCID = 0x4f4d0000; #define ex_body {unsigned long minor; completion_status completed;} enum completion_status {COMPLETED_YES, COMPLETED_NO, COMPLETED_MAYBE}; enum exception_type { NO_EXCEPTION, USER_EXCEPTION, SYSTEM_EXCEPTION}; exception UNKNOWN ex_body; // the unknown exception exception BAD_PARAM ex_body; // an invalid parameter was // passed exception NO_MEMORY ex_body; // dynamic memory allocation // failure exception IMP_LIMIT ex_body; // violated implementation // limit exception COMM_FAILURE ex_body; // communication failure exception INV_OBJREF ex_body; // invalid object reference exception NO_PERMISSION ex_body; // no permission for // attempted op. exception INTERNAL ex_body; // ORB internal error exception MARSHAL ex_body; // error marshaling // param/result exception INITIALIZE ex_body; // ORB initialization failure exception NO_IMPLEMENT ex_body; // operation implementation // unavailable exception BAD_TYPECODE ex_body; // bad typecode exception BAD_OPERATION ex_body; // invalid operation exception NO_RESOURCES ex_body; // insufficient resources // for req. exception NO_RESPONSE ex_body; // response to req. not yet // available exception PERSIST_STORE ex_body; // persistent storage failure exception BAD_INV_ORDER ex_body; // routine invocations // out of order exception TRANSIENT ex_body; // transient failure - reissue // request exception FREE_MEM ex_body; // cannot free memory exception INV_IDENT ex_body; // invalid identifier syntax exception INV_FLAG ex_body; // invalid flag was specified exception INTF_REPOS ex_body; // error accessing interface // repository exception BAD_CONTEXT ex_body; // error processing context // object exception OBJ_ADAPTER ex_body; // failure detected by object // adapter exception DATA_CONVERSION ex_body; // data conversion error exception OBJECT_NOT_EXIST ex_body; // non-existent object, // delete reference exception TRANSACTION_REQUIRED ex_body; // transaction required exception TRANSACTION_ROLLEDBACK ex_body; // transaction rolled back exception INVALID_TRANSACTION ex_body; // invalid transaction exception INV_POLICY ex_body; // invalid policy exception CODESET_INCOMPATIBLE ex_body; // incompatible code set exception REBIND ex_body; // rebind needed exception TIMEOUT ex_body; // operation timed out exception TRANSACTION_UNAVAILABLE ex_body; // no transaction exception TRANSACTION_MODE ex_body; // invalid transaction mode exception BAD_QOS ex_body; // bad quality of service polyorb-2.8~20110207.orig/testsuite/idls/corba_idl/CORBA_Context.idl0000644000175000017500000000201711750740340024330 0ustar xavierxavier// File: CORBA_Context.idl // From CORBA 3.0, Chapter 4 //PolyORB:NI: Context is not actually implemented. Context API is provided //by CORBA personality, but do nothing. interface Context { // PIDL void set_one_value ( in Identifier prop_name, // property name to add in string value // property value to add ); void set_values ( in NVList values // property values to be changed ); void get_values ( in Identifier start_scope, // search scope in Flags op_flags, // operation flags in Identifier prop_name, // name of property(s) to retrieve out NVList values // requested property(s) ); void delete_values ( in Identifier prop_name // name of property(s) to delete ); void create_child ( in Identifier ctx_name, // name of context object out Context child_ctx // newly created context object ); void delete ( in Flags del_flags // flags controlling deletion ); }; polyorb-2.8~20110207.orig/testsuite/idls/corba_idl/CORBA_NVList.idl0000644000175000017500000000133211750740340024062 0ustar xavierxavier// File: CORBA_NVList.idl // CORBA 3.0, Chapter 7 interface NVList { // PIDL //PolyORB:NI: void add_item ( //PolyORB:NI: in Identifier item_name, // name of item //PolyORB:NI: in TypeCode item_type, // item datatype //PolyORB:NI: in OpaqueValue value, // item value //PolyORB:NI: in long value_len, // length of item value //PolyORB:NI: in Flags item_flags // item flags //PolyORB:NI: ); void free ( ); void free_memory ( ); void get_count ( out long count // number of entries in the list ); }; polyorb-2.8~20110207.orig/testsuite/idls/corba_idl/CORBA_TypeCode.idl0000644000175000017500000000617311750740340024427 0ustar xavierxavier// File CORBA_TypeCode.idl // CORBA 3.0 Chapter 4 #ifdef _PRE_3_0_COMPILER_ #pragma prefix "omg.org" #else typeprefix CORBA "omg.org"; #endif enum TCKind { tk_null, tk_void, tk_short, tk_long, tk_ushort, tk_ulong, tk_float, tk_double, tk_boolean, tk_char, tk_octet, tk_any, tk_TypeCode,tk_Principal, tk_objref, tk_struct, tk_union, tk_enum, tk_string, tk_sequence,tk_array, tk_alias, tk_except, tk_longlong,tk_ulonglong, tk_longdouble, tk_wchar, tk_wstring, tk_fixed, tk_value, tk_value_box, tk_native, tk_abstract_interface, tk_local_interface, tk_component, tk_home, tk_event }; typedef short ValueModifier; const ValueModifier VM_NONE = 0; const ValueModifier VM_CUSTOM = 1; const ValueModifier VM_ABSTRACT = 2; const ValueModifier VM_TRUNCATABLE = 3; interface TypeCode { exception Bounds {}; exception BadKind {}; // for all TypeCode kinds boolean equal (in TypeCode tc); boolean equivalent (in TypeCode tc); TypeCode get_compact_typecode(); TCKind kind (); // for tk_objref, tk_struct, tk_union, tk_enum, tk_alias, // tk_value, tk_value_box, tk_native, tk_abstract_interface // and tk_except RepositoryId id () raises (BadKind); // for tk_objref, tk_struct, tk_union, tk_enum, tk_alias, // tk_value, tk_value_box, tk_native, tk_abstract_interface // and tk_except Identifier name () raises (BadKind); // for tk_struct, tk_union, tk_enum, tk_value, // and tk_except unsigned long member_count () raises (BadKind); Identifier member_name (in unsigned long index) raises (BadKind, Bounds); // for tk_struct, tk_union, tk_value, and tk_except TypeCode member_type (in unsigned long index) raises (BadKind, Bounds); // for tk_union any member_label (in unsigned long index) raises (BadKind, Bounds); TypeCode discriminator_type () raises (BadKind); long default_index () raises (BadKind); // for tk_string, tk_sequence, and tk_array unsigned long length () raises (BadKind); // for tk_sequence, tk_array, tk_value_box, and tk_alias TypeCode content_type () raises (BadKind); // for tk_fixed unsigned short fixed_digits() raises (BadKind); short fixed_scale() raises (BadKind); // for tk_value Visibility member_visibility(in unsigned long index) raises(BadKind, Bounds); ValueModifier type_modifier() raises(BadKind); TypeCode concrete_base_type() raises(BadKind); }; polyorb-2.8~20110207.orig/testsuite/idls/corba_idl/CORBA_Current.idl0000644000175000017500000000020111750740340024317 0ustar xavierxavier// File: CORBA_Current.idl // CORBA 3.0, Chapter 4 // interface for the Current object local interface Current { }; polyorb-2.8~20110207.orig/testsuite/idls/corba_idl/CORBA_ServerRequest.idl0000644000175000017500000000054011750740340025522 0ustar xavierxavier// File: ServerRequest.idl // CORBA 3.0, Chapter 8 interface ServerRequest { // PIDL readonly attribute Identifier operation; void arguments (inout NVList nv); Context ctx(); void set_result (in any val); void set_exception(in any val); }; polyorb-2.8~20110207.orig/testsuite/idls/corba_idl/CORBA_ORB_init.idl0000644000175000017500000000071111750740340024350 0ustar xavierxavier// File: CORBA_ORB_init.idl // CORBA 3.0, Chapter 4 // Note: This PIDL does not compile. Don't even try. // It defines an operation not in an interface, which is illegal. // As a result, this file is not "included" anywhere. // It is included for completeness' sake. // PIDL module CORBA { typedef string ORBid; typedef sequence arg_list; ORB ORB_init (inout arg_list argv, in ORBid orb_identifier); }; polyorb-2.8~20110207.orig/testsuite/idls/corba_idl/CORBA_ValueBase.idl0000644000175000017500000000024711750740340024556 0ustar xavierxavier// File: CORBA_ValueBase.idl // CORBA 3.0, Chapter 5 //PolyORB:NI: valuetype ValueBase{ //PIDL //PolyORB:NI: ValueDef get_value_def(); //PolyORB:NI: }; polyorb-2.8~20110207.orig/testsuite/idls/corba_idl/CORBA_ORB.idl0000644000175000017500000002002311750740340023323 0ustar xavierxavier// File CORBA_ORB.idl // CORBA 3.0, Chapter 4 //PolyORB:NI: typedef sequence RequestSeq; native AbstractBase; typedef unsigned short ServiceType; typedef unsigned long ServiceOption; typedef unsigned long ServiceDetailType; const ServiceType Security = 1; struct ServiceDetail { ServiceDetailType service_detail_type; sequence service_detail; }; struct ServiceInformation { sequence service_options; sequence service_details; }; //PolyORB:NI: native ValueFactory; typedef string ORBid; interface ORB { // PIDL typedef string ObjectId; typedef sequence ObjectIdList; exception InvalidName {}; //PolyORB:NI: ORBid id(); string object_to_string ( in Object obj ); Object string_to_object ( in string str ); // Dynamic Invocation related operations void create_list ( in long count, out NVList new_list ); //PolyORB:NI: void create_operation_list ( //PolyORB:NI: in OperationDef oper, //PolyORB:NI: out NVList new_list //PolyORB:NI: ); void get_default_context ( out Context ctx ); //PolyORB:NI: void send_multiple_requests_oneway( //PolyORB:NI: in RequestSeq req //PolyORB:NI: ); //PolyORB:NI: //PolyORB:NI: void send_multiple_requests_deferred( //PolyORB:NI: in RequestSeq req //PolyORB:NI: ); //PolyORB:NI: //PolyORB:NI: boolean poll_next_response(); //PolyORB:NI: //PolyORB:NI: void get_next_response( //PolyORB:NI: out Request req //PolyORB:NI: ) raises (WrongTransaction); // Service information operations boolean get_service_information ( in ServiceType service_type, out ServiceInformation service_information ); ObjectIdList list_initial_services (); // Initial reference operation Object resolve_initial_references ( in ObjectId identifier ) raises (InvalidName); // Type code creation operations //PolyORB:NI: TypeCode create_struct_tc ( //PolyORB:NI: in RepositoryId id, //PolyORB:NI: in Identifier name, //PolyORB:NI: in StructMemberSeq members //PolyORB:NI: ); //PolyORB:NI: //PolyORB:NI: TypeCode create_union_tc ( //PolyORB:NI: in RepositoryId id, //PolyORB:NI: in Identifier name, //PolyORB:NI: in TypeCode discriminator_type, //PolyORB:NI: in UnionMemberSeq members //PolyORB:NI: ); //PolyORB:NI: //PolyORB:NI: TypeCode create_enum_tc ( //PolyORB:NI: in RepositoryId id, //PolyORB:NI: in Identifier name, //PolyORB:NI: in EnumMemberSeq members //PolyORB:NI: ); TypeCode create_alias_tc ( in RepositoryId id, in Identifier name, in TypeCode original_type ); //PolyORB:NI: TypeCode create_exception_tc ( //PolyORB:NI: in RepositoryId id, //PolyORB:NI: in Identifier name, //PolyORB:NI: in StructMemberSeq members //PolyORB:NI: ); TypeCode create_interface_tc ( in RepositoryId id, in Identifier name ); TypeCode create_string_tc ( in unsigned long bound ); TypeCode create_wstring_tc ( in unsigned long bound ); TypeCode create_fixed_tc ( in unsigned short digits, in short scale ); TypeCode create_sequence_tc ( in unsigned long bound, in TypeCode element_type ); TypeCode create_recursive_sequence_tc( // deprecated in unsigned long bound, in unsigned long offset ); TypeCode create_array_tc ( in unsigned long length, in TypeCode element_type ); //PolyORB:NI: TypeCode create_value_tc ( //PolyORB:NI: in RepositoryId id, //PolyORB:NI: in Identifier name, //PolyORB:NI: in ValueModifier type_modifier, //PolyORB:NI: in TypeCode concrete_base, //PolyORB:NI: in ValueMemberSeq members //PolyORB:NI: ); //PolyORB:NI: //PolyORB:NI: TypeCode create_value_box_tc ( //PolyORB:NI: in RepositoryId id, //PolyORB:NI: in Identifier name, //PolyORB:NI: in TypeCode boxed_type //PolyORB:NI: ); TypeCode create_native_tc ( in RepositoryId id, in Identifier name ); //PolyORB:NI: TypeCode create_recursive_tc( //PolyORB:NI: in RepositoryId id //PolyORB:NI: ); //PolyORB:NI: //PolyORB:NI: TypeCode create_abstract_interface_tc( //PolyORB:NI: in RepositoryId id, //PolyORB:NI: in Identifier name //PolyORB:NI: ); //PolyORB:NI: //PolyORB:NI: TypeCode create_local_interface_tc( //PolyORB:NI: in RepositoryId id, //PolyORB:NI: in Identifier name //PolyORB:NI: ); //PolyORB:NI: //PolyORB:NI: TypeCode create_component_tc ( //PolyORB:NI: in RepositoryId id, //PolyORB:NI: in Identifier name //PolyORB:NI: ); //PolyORB:NI: //PolyORB:NI: TypeCode create_home_tc ( //PolyORB:NI: in RepositoryId id, //PolyORB:NI: in Identifier name //PolyORB:NI: ); //PolyORB:NI: //PolyORB:NI: TypeCode create_event_tc ( //PolyORB:NI: in RepositoryId id, //PolyORB:NI: in Identifier name, //PolyORB:NI: in ValueModifier type_modifier, //PolyORB:NI: in TypeCode concrete_base, //PolyORB:NI: in ValueMemberSeq members //PolyORB:NI: ); // Thread related operations boolean work_pending( ); void perform_work(); void run(); void shutdown( in boolean wait_for_completion ); //PolyORB:NI: void destroy(); // Policy related operations Policy create_policy( in PolicyType type, in any val ) raises (PolicyError); //PolyORB:NI: // Dynamic Any related operations deprecated and removed //PolyORB:NI: // from primary list of ORB operations //PolyORB:NI: //PolyORB:NI: // Value factory operations //PolyORB:NI: //PolyORB:NI: ValueFactory register_value_factory( //PolyORB:NI: in RepositoryId id, //PolyORB:NI: in ValueFactory _factory //PolyORB:NI: ); //PolyORB:NI: //PolyORB:NI: void unregister_value_factory( //PolyORB:NI: in RepositoryId id); //PolyORB:NI: //PolyORB:NI: ValueFactory lookup_value_factory( //PolyORB:NI: in RepositoryId id); // Portable Interceptor related operations void register_initial_reference( in ObjectId id, in Object obj ) raises (InvalidName); }; polyorb-2.8~20110207.orig/testsuite/idls/corba_idl/CORBA_DomainManager.idl0000644000175000017500000000112011750740340025400 0ustar xavierxavier// File: CORBA_DomainManager.idl // CORBA 3.0, Chapter 4 interface DomainManager { Policy get_domain_policy ( in PolicyType policy_type ); }; //PolyORB:NI: const PolicyType SecConstruction = 11; //PolyORB:NI: //PolyORB:NI: interface ConstructionPolicy: Policy { //PolyORB:NI: void make_domain_manager( //PolyORB:NI: in CORBA::InterfaceDef object_type, //PolyORB:NI: in boolean constr_policy //PolyORB:NI: ); //PolyORB:NI: }; typedef sequence DomainManagersList; polyorb-2.8~20110207.orig/testsuite/idls/corba_idl/CORBA_Stream.idl0000644000175000017500000003027411750740340024145 0ustar xavierxavier// File: CORBA_Stream.idl // CORBA 3.0, Chapter 5 typedef sequence AnySeq; typedef sequence BooleanSeq; typedef sequence CharSeq; typedef sequence WCharSeq; typedef sequence OctetSeq; typedef sequence ShortSeq; typedef sequence UShortSeq; typedef sequence LongSeq; typedef sequence ULongSeq; typedef sequence LongLongSeq; typedef sequence ULongLongSeq; typedef sequence FloatSeq; typedef sequence DoubleSeq; typedef sequence LongDoubleSeq; typedef sequence StringSeq; typedef sequence WStringSeq; //PolyORB:NI: exception BadFixedValue { //PolyORB:NI: unsigned long offset; //PolyORB:NI: }; //PolyORB:NI: //PolyORB:NI: abstract valuetype DataOutputStream { //PolyORB:NI: void write_any (in any value); //PolyORB:NI: void write_boolean (in boolean value); //PolyORB:NI: void write_char (in char value); //PolyORB:NI: void write_wchar (in wchar value); //PolyORB:NI: void write_octet (in octet value); //PolyORB:NI: void write_short (in short value); //PolyORB:NI: void write_ushort (in unsigned short value); //PolyORB:NI: void write_long (in long value); //PolyORB:NI: void write_ulong (in unsigned long value); //PolyORB:NI: void write_longlong (in long long value); //PolyORB:NI: void write_ulonglong (in unsigned long long value); //PolyORB:NI: void write_float (in float value); //PolyORB:NI: void write_double (in double value); //PolyORB:NI: void write_longdouble (in long double value); //PolyORB:NI: void write_string (in string value); //PolyORB:NI: void write_wstring (in wstring value); //PolyORB:NI: void write_Object (in Object value); //PolyORB:NI: void write_Abstract (in AbstractBase value); //PolyORB:NI: void write_Value (in ValueBase value); //PolyORB:NI: void write_TypeCode (in TypeCode value); //PolyORB:NI: void write_any_array (in AnySeq seq, //PolyORB:NI: in unsigned long offset, //PolyORB:NI: in unsigned long length); //PolyORB:NI: void write_boolean_array (in BooleanSeq seq, //PolyORB:NI: in unsigned long offset, //PolyORB:NI: in unsigned long length); //PolyORB:NI: void write_char_array (in CharSeq seq, //PolyORB:NI: in unsigned long offset, //PolyORB:NI: in unsigned long length); //PolyORB:NI: void write_wchar_array (in WCharSeq seq, //PolyORB:NI: in unsigned long offset, //PolyORB:NI: in unsigned long length); //PolyORB:NI: void write_octet_array (in OctetSeq seq, //PolyORB:NI: in unsigned long offset, //PolyORB:NI: in unsigned long length); //PolyORB:NI: void write_short_array (in ShortSeq seq, //PolyORB:NI: in unsigned long offset, //PolyORB:NI: in unsigned long length); //PolyORB:NI: void write_ushort_array (in UShortSeq seq, //PolyORB:NI: in unsigned long offset, //PolyORB:NI: in unsigned long length); //PolyORB:NI: void write_long_array (in LongSeq seq, //PolyORB:NI: in unsigned long offset, //PolyORB:NI: in unsigned long length); //PolyORB:NI: void write_ulong_array (in ULongSeq seq, //PolyORB:NI: in unsigned long offset, //PolyORB:NI: in unsigned long length); //PolyORB:NI: void write_ulonglong_array (in ULongLongSeq seq, //PolyORB:NI: in unsigned long offset, //PolyORB:NI: in unsigned long length); //PolyORB:NI: void write_longlong_array (in LongLongSeq seq, //PolyORB:NI: in unsigned long offset, //PolyORB:NI: in unsigned long length); //PolyORB:NI: void write_float_array (in FloatSeq seq, //PolyORB:NI: in unsigned long offset, //PolyORB:NI: in unsigned long length); //PolyORB:NI: void write_double_array (in DoubleSeq seq, //PolyORB:NI: in unsigned long offset, //PolyORB:NI: in unsigned long length); //PolyORB:NI: void write_long_double_array( //PolyORB:NI: in LongDoubleSeq seq, //PolyORB:NI: in unsigned long offset, //PolyORB:NI: in unsigned long length); //PolyORB:NI: void write_fixed ( //PolyORB:NI: in any fixed_value //PolyORB:NI: ) raises (BadFixedValue); //PolyORB:NI: void write_fixed_array ( //PolyORB:NI: in AnySeq seq, //PolyORB:NI: in unsigned long offset, //PolyORB:NI: in unsigned long length //PolyORB:NI: ) raises (BadFixedValue); //PolyORB:NI: }; //PolyORB:NI: //PolyORB:NI: abstract valuetype DataInputStream { //PolyORB:NI: any read_any(); //PolyORB:NI: boolean read_boolean(); //PolyORB:NI: char read_char(); //PolyORB:NI: wchar read_wchar(); //PolyORB:NI: octet read_octet(); //PolyORB:NI: short read_short(); //PolyORB:NI: unsigned short read_ushort(); //PolyORB:NI: long read_long(); //PolyORB:NI: unsigned long read_ulong(); //PolyORB:NI: long long read_longlong(); //PolyORB:NI: unsigned long long read_ulonglong(); //PolyORB:NI: float read_float(); //PolyORB:NI: double read_double(); //PolyORB:NI: long double read_longdouble(); //PolyORB:NI: string read_string(); //PolyORB:NI: wstring read_wstring(); //PolyORB:NI: Object read_Object(); //PolyORB:NI: AbstractBase read_Abstract(); //PolyORB:NI: ValueBase read_Value(); //PolyORB:NI: TypeCode read_TypeCode(); //PolyORB:NI: //PolyORB:NI: void read_any_array ( //PolyORB:NI: inout AnySeq seq, //PolyORB:NI: in unsigned long offset, //PolyORB:NI: in unsigned long length); //PolyORB:NI: void read_boolean_array ( //PolyORB:NI: inout BooleanSeq seq, //PolyORB:NI: in unsigned long offset, //PolyORB:NI: in unsigned long length); //PolyORB:NI: void read_char_array ( //PolyORB:NI: inout CharSeq seq, //PolyORB:NI: in unsigned long offset, //PolyORB:NI: in unsigned long length); //PolyORB:NI: void read_wchar_array ( //PolyORB:NI: inout WCharSeq seq, //PolyORB:NI: in unsigned long offset, //PolyORB:NI: in unsigned long length); //PolyORB:NI: void read_octet_array ( //PolyORB:NI: inout OctetSeq seq, //PolyORB:NI: in unsigned long offset, //PolyORB:NI: in unsigned long length); //PolyORB:NI: void read_short_array ( //PolyORB:NI: inout ShortSeq seq, //PolyORB:NI: in unsigned long offset, //PolyORB:NI: in unsigned long length); //PolyORB:NI: void read_ushort_array ( //PolyORB:NI: inout UShortSeq seq, //PolyORB:NI: in unsigned long offset, //PolyORB:NI: in unsigned long length); //PolyORB:NI: void read_long_array ( //PolyORB:NI: inout LongSeq seq, //PolyORB:NI: in unsigned long offset, //PolyORB:NI: in unsigned long length); //PolyORB:NI: void read_ulong_array ( //PolyORB:NI: inout ULongSeq seq, //PolyORB:NI: in unsigned long offset, //PolyORB:NI: in unsigned long length); //PolyORB:NI: void read_ulonglong_array ( //PolyORB:NI: inout ULongLongSeq seq, //PolyORB:NI: in unsigned long offset, //PolyORB:NI: in unsigned long length); //PolyORB:NI: void read_longlong_array ( //PolyORB:NI: inout LongLongSeq seq, //PolyORB:NI: in unsigned long offset, //PolyORB:NI: in unsigned long length); //PolyORB:NI: void read_float_array ( //PolyORB:NI: inout FloatSeq seq, //PolyORB:NI: in unsigned long offset, //PolyORB:NI: in unsigned long length); //PolyORB:NI: void read_double_array ( //PolyORB:NI: inout DoubleSeq seq, //PolyORB:NI: in unsigned long offset, //PolyORB:NI: in unsigned long length); //PolyORB:NI: void read_long_double_array( //PolyORB:NI: inout DoubleSeq seq, //PolyORB:NI: in unsigned long offset, //PolyORB:NI: in unsigned long length); //PolyORB:NI: any read_fixed ( //PolyORB:NI: in unsigned short digits, //PolyORB:NI: in short scale //PolyORB:NI: ) raises (BadFixedValue); //PolyORB:NI: void read_fixed_array ( //PolyORB:NI: inout AnySeq seq, //PolyORB:NI: in unsigned long offset, //PolyORB:NI: in unsigned long length, //PolyORB:NI: in unsigned short digits, //PolyORB:NI: in short scale //PolyORB:NI: ) raises (BadFixedValue); //PolyORB:NI: }; polyorb-2.8~20110207.orig/testsuite/idls/corba_idl/CORBA_InterfaceRepository.idl0000644000175000017500000007634411750740340026722 0ustar xavierxavier// File: CORBA_InterfaceRepository.idl // CORBA 3.0, Chapter 10 #ifdef _PRE_3_0_COMPILER_ #pragma prefix "omg.org" #else typeprefix CORBA "omg.org"; #endif typedef string ScopedName; typedef string RepositoryId; enum DefinitionKind { dk_none, dk_all, dk_Attribute, dk_Constant, dk_Exception, dk_Interface, dk_Module, dk_Operation, dk_Typedef, dk_Alias, dk_Struct, dk_Union, dk_Enum, dk_Primitive, dk_String, dk_Sequence, dk_Array, dk_Repository, dk_Wstring, dk_Fixed, dk_Value, dk_ValueBox, dk_ValueMember, dk_Native, dk_AbstractInterface, dk_LocalInterface, dk_Component, dk_Home, dk_Factory, dk_Finder, dk_Emits, dk_Publishes, dk_Consumes, dk_Provides, dk_Uses, dk_Event }; interface IRObject { // read interface readonly attribute DefinitionKind def_kind; // write interface void destroy (); }; typedef string VersionSpec; interface Contained : IRObject { // read/write interface attribute RepositoryId id; attribute Identifier name; attribute VersionSpec version; // read interface readonly attribute Container defined_in; readonly attribute ScopedName absolute_name; readonly attribute Repository containing_repository; struct Description { DefinitionKind kind; any value; }; Description describe (); // write interface void move ( in Container new_container, in Identifier new_name, in VersionSpec new_version ); }; interface ModuleDef; interface ConstantDef; interface IDLType; interface StructDef; interface UnionDef; interface EnumDef; interface AliasDef; interface ExceptionDef; interface NativeDef; interface InterfaceDef; typedef sequence InterfaceDefSeq; interface ValueDef; typedef sequence ValueDefSeq; interface ValueBoxDef; interface AbstractInterfaceDef; typedef sequence AbstractInterfaceDefSeq; interface LocalInterfaceDef; typedef sequence LocalInterfaceDefSeq; interface ExtInterfaceDef; typedef sequence ExtInterfaceDefSeq; //PolyORB:NI: interface ExtValueDef; //PolyORB:NI: typedef sequence ExtValueDefSeq; interface ExtAbstractInterfaceDef; typedef sequence ExtAbstractInterfaceDefSeq; interface ExtLocalInterfaceDef; typedef sequence ExtLocalInterfaceDefSeq; typedef sequence ContainedSeq; struct StructMember { Identifier name; TypeCode type; IDLType type_def; }; typedef sequence StructMemberSeq; struct Initializer { StructMemberSeq members; Identifier name; }; typedef sequence InitializerSeq; struct UnionMember { Identifier name; any label; TypeCode type; IDLType type_def; }; struct ExceptionDescription { Identifier name; RepositoryId id; RepositoryId defined_in; VersionSpec version; TypeCode type; }; typedef sequence ExcDescriptionSeq; struct ExtInitializer { StructMemberSeq members; ExcDescriptionSeq exceptions; Identifier name; }; typedef sequence ExtInitializerSeq; typedef sequence UnionMemberSeq; typedef sequence EnumMemberSeq; interface Container : IRObject { // read interface Contained lookup ( in ScopedName search_name); ContainedSeq contents ( in DefinitionKind limit_type, in boolean exclude_inherited ); ContainedSeq lookup_name ( in Identifier search_name, in long levels_to_search, in DefinitionKind limit_type, in boolean exclude_inherited ); struct Description { Contained contained_object; DefinitionKind kind; any value; }; typedef sequence DescriptionSeq; DescriptionSeq describe_contents ( in DefinitionKind limit_type, in boolean exclude_inherited, in long max_returned_objs ); // write interface ModuleDef create_module ( in RepositoryId id, in Identifier name, in VersionSpec version ); ConstantDef create_constant ( in RepositoryId id, in Identifier name, in VersionSpec version, in IDLType type, in any value ); StructDef create_struct ( in RepositoryId id, in Identifier name, in VersionSpec version, in StructMemberSeq members ); UnionDef create_union ( in RepositoryId id, in Identifier name, in VersionSpec version, in IDLType discriminator_type, in UnionMemberSeq members ); EnumDef create_enum ( in RepositoryId id, in Identifier name, in VersionSpec version, in EnumMemberSeq members ); AliasDef create_alias ( in RepositoryId id, in Identifier name, in VersionSpec version, in IDLType original_type ); InterfaceDef create_interface ( in RepositoryId id, in Identifier name, in VersionSpec version, in InterfaceDefSeq base_interfaces, in boolean is_abstract ); ValueDef create_value( in RepositoryId id, in Identifier name, in VersionSpec version, in boolean is_custom, in boolean is_abstract, in ValueDef base_value, in boolean is_truncatable, in ValueDefSeq abstract_base_values, in InterfaceDefSeq supported_interfaces, in InitializerSeq initializers ); ValueBoxDef create_value_box( in RepositoryId id, in Identifier name, in VersionSpec version, in IDLType original_type_def ); ExceptionDef create_exception( in RepositoryId id, in Identifier name, in VersionSpec version, in StructMemberSeq members ); NativeDef create_native( in RepositoryId id, in Identifier name, in VersionSpec version ); AbstractInterfaceDef create_abstract_interface ( in RepositoryId id, in Identifier name, in VersionSpec version, in AbstractInterfaceDefSeq base_interfaces ); LocalInterfaceDef create_local_interface ( in RepositoryId id, in Identifier name, in VersionSpec version, in InterfaceDefSeq base_interfaces ); //PolyORB:NI: ExtValueDef create_ext_value ( //PolyORB:NI: in RepositoryId id, //PolyORB:NI: in Identifier name, //PolyORB:NI: in VersionSpec version, //PolyORB:NI: in boolean is_custom, //PolyORB:NI: in boolean is_abstract, //PolyORB:NI: in ValueDef base_value, //PolyORB:NI: in boolean is_truncatable, //PolyORB:NI: in ValueDefSeq abstract_base_values, //PolyORB:NI: in InterfaceDefSeq supported_interfaces, //PolyORB:NI: in ExtInitializerSeq initializers //PolyORB:NI: ); }; interface IDLType : IRObject { readonly attribute TypeCode type; }; enum PrimitiveKind { pk_null, pk_void, pk_short, pk_long, pk_ushort, pk_ulong, pk_float, pk_double, pk_boolean, pk_char, pk_octet, pk_any, pk_TypeCode, pk_Principal, pk_string, pk_objref, pk_longlong,pk_ulonglong, pk_longdouble, pk_wchar, pk_wstring, pk_value_base }; interface Repository : Container { // read interface Contained lookup_id (in RepositoryId search_id); TypeCode get_canonical_typecode (in TypeCode tc); PrimitiveDef get_primitive (in PrimitiveKind kind); // write interface StringDef create_string (in unsigned long bound); WstringDef create_wstring (in unsigned long bound); SequenceDef create_sequence (in unsigned long bound, in IDLType element_type ); ArrayDef create_array (in unsigned long length, in IDLType element_type ); FixedDef create_fixed (in unsigned short digits, in short scale ); }; interface ModuleDef : Container, Contained { }; struct ModuleDescription { Identifier name; RepositoryId id; RepositoryId defined_in; VersionSpec version; }; interface ConstantDef : Contained { readonly attribute TypeCode type; attribute IDLType type_def; attribute any value; }; struct ConstantDescription { Identifier name; RepositoryId id; RepositoryId defined_in; VersionSpec version; TypeCode type; any value; }; interface TypedefDef : Contained, IDLType { }; struct TypeDescription { Identifier name; RepositoryId id; RepositoryId defined_in; VersionSpec version; TypeCode type; }; interface StructDef : TypedefDef, Container { attribute StructMemberSeq members; }; interface UnionDef : TypedefDef, Container { readonly attribute TypeCode discriminator_type; attribute IDLType discriminator_type_def; attribute UnionMemberSeq members; }; interface EnumDef : TypedefDef { attribute EnumMemberSeq members; }; interface AliasDef : TypedefDef { attribute IDLType original_type_def; }; interface NativeDef : TypedefDef { }; interface PrimitiveDef: IDLType { readonly attribute PrimitiveKind kind; }; interface StringDef : IDLType { attribute unsigned long bound; }; interface WstringDef : IDLType { attribute unsigned long bound; }; interface FixedDef : IDLType { attribute unsigned short digits; attribute short scale; }; interface SequenceDef : IDLType { attribute unsigned long bound; readonly attribute TypeCode element_type; attribute IDLType element_type_def; }; interface ArrayDef : IDLType { attribute unsigned long length; readonly attribute TypeCode element_type; attribute IDLType element_type_def; }; interface ExceptionDef : Contained, Container { readonly attribute TypeCode type; attribute StructMemberSeq members; }; enum AttributeMode {ATTR_NORMAL, ATTR_READONLY}; interface AttributeDef : Contained { readonly attribute TypeCode type; attribute IDLType type_def; attribute AttributeMode mode; }; struct AttributeDescription { Identifier name; RepositoryId id; RepositoryId defined_in; VersionSpec version; TypeCode type; AttributeMode mode; }; struct ExtAttributeDescription { Identifier name; RepositoryId id; RepositoryId defined_in; VersionSpec version; TypeCode type; AttributeMode mode; ExcDescriptionSeq get_exceptions; ExcDescriptionSeq put_exceptions; }; interface ExtAttributeDef : AttributeDef { // read/write interface attribute ExcDescriptionSeq get_exceptions; attribute ExcDescriptionSeq set_exceptions; // read interface ExtAttributeDescription describe_attribute (); }; enum OperationMode {OP_NORMAL, OP_ONEWAY}; enum ParameterMode {PARAM_IN, PARAM_OUT, PARAM_INOUT}; struct ParameterDescription { Identifier name; TypeCode type; IDLType type_def; ParameterMode mode; }; typedef sequence ParDescriptionSeq; typedef Identifier ContextIdentifier; typedef sequence ContextIdSeq; typedef sequence ExceptionDefSeq; interface OperationDef : Contained { readonly attribute TypeCode result; attribute IDLType result_def; attribute ParDescriptionSeq params; attribute OperationMode mode; attribute ContextIdSeq contexts; attribute ExceptionDefSeq exceptions; }; struct OperationDescription { Identifier name; RepositoryId id; RepositoryId defined_in; VersionSpec version; TypeCode result; OperationMode mode; ContextIdSeq contexts; ParDescriptionSeq parameters; ExcDescriptionSeq exceptions; }; typedef sequence RepositoryIdSeq; typedef sequence OpDescriptionSeq; typedef sequence AttrDescriptionSeq; typedef sequence ExtAttrDescriptionSeq; interface InterfaceDef : Container, Contained, IDLType { // read/write interface attribute InterfaceDefSeq base_interfaces; attribute boolean is_abstract; // read interface boolean is_a (in RepositoryId interface_id ); struct FullInterfaceDescription { Identifier name; RepositoryId id; RepositoryId defined_in; VersionSpec version; OpDescriptionSeq operations; AttrDescriptionSeq attributes; RepositoryIdSeq base_interfaces; TypeCode type; boolean is_abstract; }; FullInterfaceDescription describe_interface(); // write interface AttributeDef create_attribute ( in RepositoryId id, in Identifier name, in VersionSpec version, in IDLType type, in AttributeMode mode ); OperationDef create_operation ( in RepositoryId id, in Identifier name, in VersionSpec version, in IDLType result, in OperationMode mode, in ParDescriptionSeq params, in ExceptionDefSeq exceptions, in ContextIdSeq contexts ); }; struct InterfaceDescription { Identifier name; RepositoryId id; RepositoryId defined_in; VersionSpec version; RepositoryIdSeq base_interfaces; boolean is_abstract; }; interface InterfaceAttrExtension { // read interface struct ExtFullInterfaceDescription { Identifier name; RepositoryId id; RepositoryId defined_in; VersionSpec version; OpDescriptionSeq operations; ExtAttrDescriptionSeq attributes; RepositoryIdSeq base_interfaces; TypeCode type; }; ExtFullInterfaceDescription describe_ext_interface (); // write interface ExtAttributeDef create_ext_attribute ( in RepositoryId id, in Identifier name, in VersionSpec version, in IDLType type, in AttributeMode mode, in ExceptionDefSeq get_exceptions, in ExceptionDefSeq set_exceptions ); }; interface ExtInterfaceDef : InterfaceDef, InterfaceAttrExtension {}; typedef short Visibility; const Visibility PRIVATE_MEMBER = 0; const Visibility PUBLIC_MEMBER = 1; struct ValueMember { Identifier name; RepositoryId id; RepositoryId defined_in; VersionSpec version; TypeCode type; IDLType type_def; Visibility access; }; typedef sequence ValueMemberSeq; interface ValueMemberDef : Contained { readonly attribute TypeCode type; attribute IDLType type_def; attribute Visibility access; }; interface ValueDef : Container, Contained, IDLType { // read/write interface attribute InterfaceDefSeq supported_interfaces; attribute InitializerSeq initializers; attribute ValueDef base_value; attribute ValueDefSeq abstract_base_values; attribute boolean is_abstract; attribute boolean is_custom; attribute boolean is_truncatable; // read interface boolean is_a(in RepositoryId id); struct FullValueDescription { Identifier name; RepositoryId id; boolean is_abstract; boolean is_custom; RepositoryId defined_in; VersionSpec version; OpDescriptionSeq operations; AttrDescriptionSeq attributes; ValueMemberSeq members; InitializerSeq initializers; RepositoryIdSeq supported_interfaces; RepositoryIdSeq abstract_base_values; boolean is_truncatable; RepositoryId base_value; TypeCode type; }; FullValueDescription describe_value(); ValueMemberDef create_value_member( in RepositoryId id, in Identifier name, in VersionSpec version, in IDLType type, in Visibility access ); AttributeDef create_attribute( in RepositoryId id, in Identifier name, in VersionSpec version, in IDLType type, in AttributeMode mode ); OperationDef create_operation ( in RepositoryId id, in Identifier name, in VersionSpec version, in IDLType result, in OperationMode mode, in ParDescriptionSeq params, in ExceptionDefSeq exceptions, in ContextIdSeq contexts ); }; struct ValueDescription { Identifier name; RepositoryId id; boolean is_abstract; boolean is_custom; RepositoryId defined_in; VersionSpec version; RepositoryIdSeq supported_interfaces; RepositoryIdSeq abstract_base_values; boolean is_truncatable; RepositoryId base_value; }; //PolyORB:WAidlac: idlac/ALM for interface function which return interface // itself generates an Ada function which return Ref. // By Ada rules this function is a primitive operation // of Ref and should be overridden for each child type. // idlac doesn't generate this override function, so // code generated for ExtValueDef is wrong. //PolyORB:IL: interface ExtValueDef : ValueDef { //PolyORB:IL: // read/write interface //PolyORB:IL: attribute ExtInitializerSeq ext_initializers; //PolyORB:IL: // read interface //PolyORB:IL: struct ExtFullValueDescription { //PolyORB:IL: Identifier name; //PolyORB:IL: RepositoryId id; //PolyORB:IL: boolean is_abstract; //PolyORB:IL: boolean is_custom; //PolyORB:IL: RepositoryId defined_in; //PolyORB:IL: VersionSpec version; //PolyORB:IL: OpDescriptionSeq operations; //PolyORB:IL: ExtAttrDescriptionSeq attributes; //PolyORB:IL: ValueMemberSeq members; //PolyORB:IL: ExtInitializerSeq initializers; //PolyORB:IL: RepositoryIdSeq supported_interfaces; //PolyORB:IL: RepositoryIdSeq abstract_base_values; //PolyORB:IL: boolean is_truncatable; //PolyORB:IL: RepositoryId base_value; //PolyORB:IL: TypeCode type; //PolyORB:IL: }; //PolyORB:IL: ExtFullValueDescription describe_ext_value (); //PolyORB:IL: // write interface //PolyORB:IL: ExtAttributeDef create_ext_attribute ( //PolyORB:IL: in RepositoryId id, //PolyORB:IL: in Identifier name, //PolyORB:IL: in VersionSpec version, //PolyORB:IL: in IDLType type, //PolyORB:IL: in AttributeMode mode, //PolyORB:IL: in ExceptionDefSeq get_exceptions, //PolyORB:IL: in ExceptionDefSeq set_exceptions //PolyORB:IL: ); //PolyORB:IL: }; interface ValueBoxDef : TypedefDef { attribute IDLType original_type_def; }; interface AbstractInterfaceDef : InterfaceDef { }; interface ExtAbstractInterfaceDef : AbstractInterfaceDef, InterfaceAttrExtension { }; interface LocalInterfaceDef : InterfaceDef { }; interface ExtLocalInterfaceDef : LocalInterfaceDef, InterfaceAttrExtension { }; #ifdef _COMPONENT_REPOSITORY_ //PolyORB:NI: module ComponentIR { //PolyORB:NI: typeprefix ComponentIR "omg.org"; //PolyORB:NI: interface ComponentDef; //PolyORB:NI: interface HomeDef; //PolyORB:NI: interface EventDef : ExtValueDef {}; //PolyORB:NI: interface Container{ //PolyORB:NI: ComponentDef create_component ( //PolyORB:NI: in RepositoryId id, //PolyORB:NI: in Identifier name, //PolyORB:NI: in VersionSpec version, //PolyORB:NI: in ComponentDef base_component, //PolyORB:NI: in InterfaceDefSeq supports_interfaces //PolyORB:NI: ); //PolyORB:NI: HomeDef create_home ( //PolyORB:NI: in RepositoryId id, //PolyORB:NI: in Identifier name, //PolyORB:NI: in VersionSpec version, //PolyORB:NI: in HomeDef base_home, //PolyORB:NI: in ComponentDef managed_component, //PolyORB:NI: in InterfaceDefSeq supports_interfaces, //PolyORB:NI: in ValueDef primary_key //PolyORB:NI: ); //PolyORB:NI: EventDef create_event ( //PolyORB:NI: in RepositoryId id, //PolyORB:NI: in Identifier name, //PolyORB:NI: in VersionSpec version, //PolyORB:NI: in boolean is_custom, //PolyORB:NI: in boolean is_abstract, //PolyORB:NI: in ValueDef base_value, //PolyORB:NI: in boolean is_truncatable, //PolyORB:NI: in ValueDefSeq abstract_base_values, //PolyORB:NI: in InterfaceDefSeq supported_interfaces, //PolyORB:NI: in ExtInitializerSeq initializers //PolyORB:NI: ); //PolyORB:NI: }; //PolyORB:NI: interface ModuleDef : CORBA::ModuleDef, Container{}; //PolyORB:NI: interface Repository : CORBA::Repository, Container{}; //PolyORB:NI: interface ProvidesDef : Contained { //PolyORB:NI: attribute InterfaceDef interface_type; //PolyORB:NI: }; //PolyORB:NI: struct ProvidesDescription { //PolyORB:NI: Identifier name; //PolyORB:NI: RepositoryId id; //PolyORB:NI: RepositoryId defined_in; //PolyORB:NI: VersionSpec version; //PolyORB:NI: RepositoryId interface_type; //PolyORB:NI: }; //PolyORB:NI: interface UsesDef : Contained { //PolyORB:NI: attribute InterfaceDef interface_type; //PolyORB:NI: attribute boolean is_multiple; //PolyORB:NI: }; //PolyORB:NI: struct UsesDescription { //PolyORB:NI: Identifier name; //PolyORB:NI: RepositoryId id; //PolyORB:NI: RepositoryId defined_in; //PolyORB:NI: VersionSpec version; //PolyORB:NI: RepositoryId interface_type; //PolyORB:NI: boolean is_multiple; //PolyORB:NI: }; //PolyORB:NI: interface EventPortDef : Contained { //PolyORB:NI: // read/write interface //PolyORB:NI: attribute EventDef event; //PolyORB:NI: // read interface //PolyORB:NI: boolean is_a (in RepositoryId event_id); //PolyORB:NI: }; //PolyORB:NI: struct EventPortDescription { //PolyORB:NI: Identifier name; //PolyORB:NI: RepositoryId id; //PolyORB:NI: RepositoryId defined_in; //PolyORB:NI: VersionSpec version; //PolyORB:NI: RepositoryId event; //PolyORB:NI: }; //PolyORB:NI: interface EmitsDef : EventPortDef {}; //PolyORB:NI: interface PublishesDef : EventPortDef {}; //PolyORB:NI: interface ConsumesDef : EventPortDef {}; //PolyORB:NI: interface ComponentDef : ExtInterfaceDef { //PolyORB:NI: // read/write interface //PolyORB:NI: attribute ComponentDef base_component; //PolyORB:NI: attribute InterfaceDefSeq supported_interfaces; //PolyORB:NI: // write interface //PolyORB:NI: ProvidesDef create_provides ( //PolyORB:NI: in RepositoryId id, //PolyORB:NI: in Identifier name, //PolyORB:NI: in VersionSpec version, //PolyORB:NI: in InterfaceDef interface_type //PolyORB:NI: ); //PolyORB:NI: UsesDef create_uses ( //PolyORB:NI: in RepositoryId id, //PolyORB:NI: in Identifier name, //PolyORB:NI: in VersionSpec version, //PolyORB:NI: in InterfaceDef interface_type, //PolyORB:NI: in boolean is_multiple //PolyORB:NI: ); //PolyORB:NI: EmitsDef create_emits ( //PolyORB:NI: in RepositoryId id, //PolyORB:NI: in Identifier name, //PolyORB:NI: in VersionSpec version, //PolyORB:NI: in EventDef event //PolyORB:NI: ); //PolyORB:NI: PublishesDef create_publishes ( //PolyORB:NI: in RepositoryId id, //PolyORB:NI: in Identifier name, //PolyORB:NI: in VersionSpec version, //PolyORB:NI: in EventDef event //PolyORB:NI: ); //PolyORB:NI: ConsumesDef create_consumes ( //PolyORB:NI: in RepositoryId id, //PolyORB:NI: in Identifier name, //PolyORB:NI: in VersionSpec version, //PolyORB:NI: in EventDef event //PolyORB:NI: ); //PolyORB:NI: }; //PolyORB:NI: typedef sequence //PolyORB:NI: ProvidesDescriptionSeq; //PolyORB:NI: typedef sequence UsesDescriptionSeq; //PolyORB:NI: typedef sequence //PolyORB:NI: EventPortDescriptionSeq; //PolyORB:NI: struct ComponentDescription { //PolyORB:NI: Identifier name; //PolyORB:NI: RepositoryId id; //PolyORB:NI: RepositoryId defined_in; //PolyORB:NI: VersionSpec version; //PolyORB:NI: RepositoryId base_component; //PolyORB:NI: RepositoryIdSeq supported_interfaces; //PolyORB:NI: ProvidesDescriptionSeq provided_interfaces; //PolyORB:NI: UsesDescriptionSeq used_interfaces; //PolyORB:NI: EventPortDescriptionSeq emits_events; //PolyORB:NI: EventPortDescriptionSeq publishes_events; //PolyORB:NI: EventPortDescriptionSeq consumes_events; //PolyORB:NI: ExtAttrDescriptionSeq attributes; //PolyORB:NI: TypeCode type; //PolyORB:NI: }; //PolyORB:NI: interface FactoryDef : OperationDef {}; //PolyORB:NI: interface FinderDef : OperationDef {}; //PolyORB:NI: interface HomeDef : ExtInterfaceDef { //PolyORB:NI: // read/write interface //PolyORB:NI: attribute HomeDef base_home; //PolyORB:NI: attribute InterfaceDefSeq supported_interfaces; //PolyORB:NI: attribute ComponentDef managed_component; //PolyORB:NI: attribute ValueDef primary_key; //PolyORB:NI: // write interface //PolyORB:NI: FactoryDef create_factory ( //PolyORB:NI: in RepositoryId id, //PolyORB:NI: in Identifier name, //PolyORB:NI: in VersionSpec version, //PolyORB:NI: in ParDescriptionSeq params, //PolyORB:NI: in ExceptionDefSeq exceptions //PolyORB:NI: ); //PolyORB:NI: FinderDef create_finder ( //PolyORB:NI: in RepositoryId id, //PolyORB:NI: in Identifier name, //PolyORB:NI: in VersionSpec version, //PolyORB:NI: in ParDescriptionSeq params, //PolyORB:NI: in ExceptionDefSeq exceptions //PolyORB:NI: ); //PolyORB:NI: }; //PolyORB:NI: struct HomeDescription { //PolyORB:NI: Identifier name; //PolyORB:NI: RepositoryId id; //PolyORB:NI: RepositoryId defined_in; //PolyORB:NI: VersionSpec version; //PolyORB:NI: RepositoryId base_home; //PolyORB:NI: RepositoryId managed_component; //PolyORB:NI: ValueDescription primary_key; //PolyORB:NI: OpDescriptionSeq factories; //PolyORB:NI: OpDescriptionSeq finders; //PolyORB:NI: OpDescriptionSeq operations; //PolyORB:NI: ExtAttrDescriptionSeq attributes; //PolyORB:NI: TypeCode type; //PolyORB:NI: }; //PolyORB:NI: }; #endif polyorb-2.8~20110207.orig/testsuite/idls/corba_idl/orb.idl0000644000175000017500000001471111750740340022564 0ustar xavierxavier// File: orb.idl // From CORBA 3.0 // PolyORB Notes: // NI - Not Implemented // IL - Implementation Limitation #ifndef _ORB_IDL_ #define _ORB_IDL_ //PolyORB:WAidlac: For now, idlac supports typeprefix statement only //inside a scoped_name. This definition has been moved inside the //CORBA module. //#ifdef _PRE_3_0_COMPILER_ //#pragma prefix "omg.org" //#else //typeprefix CORBA "omg.org" //#endif //PolyORB:WAidlac:end #ifdef _PRE_3_0_COMPILER_ #ifdef _NO_LOCAL_ #define local #endif #endif // This module brings together many files defining the CORBA module // (It really ought to be called CORBA.idl, but that's history.) // This file includes only the "real" interfaces that are included // in the "orb.idl" interface supplied by every ORB and that can be // brought into an IDL compilation by "import ::CORBA" // or in pre-3.0 IDL compilers by the include directive // "#include ". module CORBA { //PolyORB:WAidlac: For now, idlac supports typeprefix statement only //inside a scoped_name. This definition has been moved inside the //CORBA module. #ifdef _PRE_3_0_COMPILER_ #pragma prefix "omg.org" #else typeprefix CORBA "omg.org"; #endif //PolyORB:WAidlac:end // The following forward references list *all* the interfaces and valuetypes // defined in the CORBA module. This serves two purposes: documentation // and compilability. Documentation is nice: since some of the interfaces // must be declared as forward references, it is more consistent to // declare them all. // // As far as compilability, it might be possible to avoid having to declare // many of the forward reference by rearranging the order of the interface // declarations, but there's no reason to do bother doing that. After all, // that's the reason for the design of forward references. Doing a forward // reference allows the definition order to be relatively logical.In // particular, it allows the "include"s to be done in chapter order // (almost), the only exception being the InterfaceRepository (Chapter 10). // It contains some data definitions needed by Chapter 4 interfaces. // The other reason not to try to rearrange the order is that it's hard. // Forward references, alphabetically //PolyORB:NI: interface ConstructionPolicy; // Chapter 4, CORBA_DomainManager.idl local interface Current; // Chapter 4, CORBA_Current.idl interface DomainManager; // Chapter 4, CORBA_DomainManager.idl interface Policy; // Chapter 4, CORBA_Policy.idl //PolyORB:NI: local interface PollableSet; // Chapter 7, CORBA_Pollable.idl //PolyORB:NI: abstract valuetype CustomMarshal; // Chapter 5, CORBA_valuetype.idl //PolyORB:NI: abstract valuetype DataInputStream; // Chapter 5, CORBA_Stream.idl //PolyORB:NI: abstract valuetype DataOutputStream; // Chapter 5, CORBA_Stream.idl // Forward references to Chapter 10, CORBA_InterfaceRepository.idl //PolyORB:IL: interface AbstractInterfaceDef; //PolyORB:IL: interface AliasDef; interface ArrayDef; interface AttributeDef; //PolyORB:IL: interface ConstantDef; interface Contained; interface Container; //PolyORB:IL: interface EnumDef; //PolyORB:IL: interface ExceptionDef; //PolyORB:IL: interface ExtInterfaceDef; //PolyORB:NI: interface ExtValueDef; //PolyORB:IL: interface ExtAbstractInterfaceDef; //PolyORB:IL: interface ExtLocalInterfaceDef; interface FixedDef; //PolyORB:IL: interface IDLType; //PolyORB:IL: interface InterfaceDef; interface IRObject; //PolyORB:IL: interface LocalInterfaceDef; //PolyORB:IL: interface ModuleDef; //PolyORB:IL: interface NativeDef; interface OperationDef; interface PrimitiveDef; interface Repository; interface SequenceDef; interface StringDef; //PolyORB:IL: interface StructDef; interface TypeCode; interface TypedefDef; //PolyORB:IL: interface UnionDef; //PolyORB:IL: interface ValueDef; //PolyORB:IL: interface ValueBoxDef; interface ValueMemberDef; interface WstringDef; typedef string Identifier; // Chapter 3: IDL Syntax and Semantics #include // Chapter 4: ORB Interface #include #include #include // Chapter 7: Pollable //PolyORB:NI:#include // Chapter 10: The Interface Repository #include // more Chapter 4: ORB Interface // CORBA_TypeCode.idl depends on CORBA_InterfaceRepository.idl #include // Chapter 5: Value Type Semantics //PolyORB:NI:#include #include //---------------------------------------------------------------------------- //PolyORB:AB: This code is copied from CORBA Pseudo IDL specification, //primary because it define some entities, required for CORBA Services; //and for completeness. // The "define" fakes out the compiler to let it compile the "Context" // interface and references to it even though "context" is a keyword #define Context CContext // The "define" fakes out the compiler to let it compile the "Object" // interface and references to it even though "Object" is a keyword #define Object OObject // The "define" fakes out the compiler to let it compile the "ValueBase" // valuetype and references to it even though "ValueBase" is a keyword #define ValueBase VValueBase // Forward references, alphabetically interface Context; // Chapter 7, CORBA_Context.idl interface NVList; // Chapter 7, CORBA_NVList.idl interface Object; // Chapter 4, CORBA_Object.idl interface ORB; // Chapter 4, CORBA_ORB.idl interface Request; // Chapter 7, CORBA_Request.idl interface ServerRequest; // Chapter 8, CORBA_ServerRequest.idl //PolyORB:NI: valuetype ValueBase; // Chapter 4, CORBA_ValueBase.idl typedef unsigned long Flags; // Chapter 4: ORB Interface #include #include //PolyORB:NI:// Chapter 5: Value Type Semantics //PolyORB:NI:#include // Chapter 7: Dynamic Invocation Interface #include #include #include //PolyORB:NI:// Chapter 8: Dynamic Skeleton Interface #include //PolyORB:AE: //---------------------------------------------------------------------------- }; #endif polyorb-2.8~20110207.orig/testsuite/idls/corba_idl/CORBA_Policy.idl0000644000175000017500000000156011750740340024145 0ustar xavierxavier// File: CORBA_Policy.idl // CORBA 3.0, Chapter 4 typedef unsigned long PolicyType; // Basic IDL definition interface Policy { readonly attribute PolicyType policy_type; Policy copy(); void destroy(); }; typedef sequence PolicyList; typedef sequence PolicyTypeSeq; //PolyORB:WACORBA: InvalidPolicies defined in CORBA 3.0.3 specification //but not defined in OMG IDL files exception InvalidPolicies { sequence indices; }; //PolyORB:WACORBA: typedef short PolicyErrorCode; exception PolicyError {PolicyErrorCode reason;}; const PolicyErrorCode BAD_POLICY = 0; const PolicyErrorCode UNSUPPORTED_POLICY = 1; const PolicyErrorCode BAD_POLICY_TYPE = 2; const PolicyErrorCode BAD_POLICY_VALUE = 3; const PolicyErrorCode UNSUPPORTED_POLICY_VALUE = 4; polyorb-2.8~20110207.orig/testsuite/idls/corba_idl/CORBA_Object.idl0000644000175000017500000000347711750740340024125 0ustar xavierxavier// File: CORBA_Object.idl // CORBA 3.0, Chapter 4 //PIDL struct NamedValue { Identifier name; // argument name any argument; // argument long len; // length/count of argument value Flags arg_modes; // argument mode flags }; enum SetOverrideType {SET_OVERRIDE, ADD_OVERRIDE}; interface Object { // PIDL InterfaceDef get_interface (); boolean is_nil(); Object duplicate (); void release (); boolean is_a ( in string logical_type_id ); boolean non_existent(); boolean is_equivalent ( in Object other_object ); unsigned long hash( in unsigned long maximum ); void create_request ( in Context ctx, in Identifier operation, in NVList arg_list, inout NamedValue result, out Request request, in Flags req_flag ); Policy get_policy ( in PolicyType policy_type ); DomainManagersList get_domain_managers (); Object set_policy_overrides( in PolicyList policies, in SetOverrideType set_add ) raises(InvalidPolicies); Policy get_client_policy( in PolicyType type ); PolicyList get_policy_overrides( in PolicyTypeSeq types ); //PolyORB:NI: boolean validate_connection( //PolyORB:NI: out PolicyList inconsistent_policies //PolyORB:NI: ); //PolyORB:NI: Object get_component (); }; polyorb-2.8~20110207.orig/testsuite/idls/corba_idl/CORBA_Request.idl0000644000175000017500000000224111750740340024333 0ustar xavierxavier// File: CORBA_Request.idl // CORBA 3.0, Chapter 7 //PolyORB:NI: native OpaqueValue; interface Request { // PIDL //PolyORB:NI: void add_arg ( //PolyORB:NI: in Identifier name, // argument name //PolyORB:NI: in TypeCode arg_type, // argument datatype //PolyORB:NI: in OpaqueValue value, // argument value to be added //PolyORB:NI: in long len, // length/count of argument value //PolyORB:NI: in Flags arg_flags // argument flags //PolyORB:NI: ); void invoke ( in Flags invoke_flags // invocation flags ); void delete (); //PolyORB:NI: void send ( //PolyORB:NI: in Flags invoke_flags // invocation flags //PolyORB:NI: ); //PolyORB:NI: //PolyORB:NI: void get_response () raises (WrongTransaction); //PolyORB:NI: //PolyORB:NI: boolean poll_response(); //PolyORB:NI: //PolyORB:NI: Object sendp(); //PolyORB:NI: //PolyORB:NI: void prepare(in Object p); //PolyORB:NI: //PolyORB:NI: void sendc(in Object handler); }; polyorb-2.8~20110207.orig/testsuite/idls/vt_b01/0000755000175000017500000000000011750740340020461 5ustar xavierxavierpolyorb-2.8~20110207.orig/testsuite/idls/vt_b01/test.out0000644000175000017500000000016011750740340022166 0ustar xavierxaviervaluetype Val { public long longMbr; public short shtMbr; factory init(in long longMbr, in short shrMbr); }; polyorb-2.8~20110207.orig/testsuite/idls/vt_b01/tin.idl0000644000175000017500000000032711750740340021747 0ustar xavierxavier// IDL-Spec for testgroup: valuetype // Purpose: Classes for a Valuetype valuetype Val { //state public long longMbr; public short shtMbr; // initializer factory init(in long longMbr, in short shrMbr); }; polyorb-2.8~20110207.orig/testsuite/idls/MANIFEST0000644000175000017500000001133511750740340020522 0ustar xavierxavier# Tests from Ada backend ada0009/name_clashing.idl:ada_backend ada0010/tin.idl:ada_backend ada0011/tin.idl:ada_backend ada0012/tin.idl:ada_backend ada0013/tin.idl:ada_backend ada0014/tin.idl:ada_backend ada0015/tin.idl:ada_backend ada0016/tin.idl:ada_backend ada0017/tin.idl:ada_backend ada0018/tin.idl:ada_backend ada0019/tin.idl:ada_backend ada0020/tin.idl:ada_backend ada0021/tin.idl:ada_backend ada0022/tin.idl:ada_backend ir001/tin.idl:ada_backend anon_types001/tin.idl:ada_backend attr001/tin.idl:ada_backend chicken-egg/chicken.idl:ada_backend circular:ada_backend forward01/forward.idl:ada_backend forward02/forward.idl:ada_backend forward03/forward.idl:ada_backend inherit001/tin.idl:ada_backend inherit002/tin.idl:ada_backend inherit003/tin.idl:ada_backend inherit004/tin.idl:ada_backend inherit005/tin.idl:ada_backend local001/tin.idl:ada_backend local002/tin.idl:ada_backend local003/tin.idl:ada_backend abstract001/tin.idl:ada_backend import001:ada_backend sequences01/test15.idl:ada_backend expansion01/expansion.idl:ada_backend expansion02/expansion.idl:ada_backend expansion03/expansion.idl:ada_backend max_values/tin.idl:ada_backend reserved_words/tin.idl:ada_backend #echo/echo.idl #harness/harness.idl # Tests from CORBA 2.6 Chapter 3 idl02030/tin.idl:idl_errors idl15001/tin.idl:idl_errors idl15011/tin.idl:idl_frontend idl15012/tin.idl:idl_errors idl15021/tin.idl:idl_errors idl15022/tin.idl:idl_errors idl15023/tin.idl:idl_errors idl15024/tin.idl:idl_errors idl15025/tin.idl:idl_frontend idl15031/tin.idl:idl_frontend idl15032/tin.idl:idl_errors idl15033/tin.idl:idl_errors idl15034/tin.idl:idl_frontend idl07040/tin.idl:idl_errors idl07051/tin.idl:idl_errors idl07052/tin.idl:idl_errors idl07053/tin.idl:idl_errors # Tests from IAC some are redundant with those above #iac001/tin.idl #iac002/tin.idl #iac003/tin.idl #iac004/tin.idl #iac005/tin.idl # Tests from vsorb test001/tin.idl:idl_frontend test002/tin.idl:idl_frontend test003/tin.idl:idl_frontend test004/tin.idl:idl_frontend test005/tin.idl:idl_frontend test006/tin.idl:idl_frontend test007/tin.idl:idl_frontend test008/tin.idl:idl_frontend test009/tin.idl:idl_frontend test010/tin.idl:idl_frontend test011/tin.idl:idl_frontend test012/tin.idl:idl_frontend test013/tin.idl:idl_frontend test014/tin.idl:idl_frontend test015/tin.idl:idl_frontend test016/tin.idl:idl_frontend test017/tin.idl:idl_frontend test018/tin.idl:idl_frontend test019/tin.idl:idl_frontend test020/tin.idl:idl_frontend test021/tin.idl:idl_frontend test022/tin.idl:idl_frontend test023/tin.idl:idl_frontend test024/tin.idl:idl_frontend test025/tin.idl:idl_frontend test026/tin.idl:idl_frontend test027/tin.idl:idl_frontend test028/tin.idl:idl_frontend test029/tin.idl:idl_frontend test030/tin.idl:idl_frontend test031/tin.idl:idl_frontend test032/tin.idl:idl_frontend test033/tin.idl:idl_frontend test034/tin.idl:idl_frontend test035/tin.idl:idl_frontend test036/tin.idl:idl_frontend test037/tin.idl:idl_frontend test038/tin.idl:idl_frontend test039/tin.idl:idl_frontend test040/tin.idl:idl_frontend test041/tin.idl:idl_frontend test042/tin.idl:idl_frontend test043/tin.idl:idl_frontend test044/tin.idl:idl_frontend test045/tin.idl:idl_frontend test046/tin.idl:idl_frontend test047/tin.idl:idl_frontend test048/tin.idl:idl_frontend test049/tin.idl:idl_frontend test050/tin.idl:idl_frontend test051/tin.idl:idl_frontend test052/tin.idl:idl_frontend test053/tin.idl:idl_frontend test054/tin.idl:idl_frontend test055/tin.idl:idl_frontend #aif_b01/tin.idl #aif_p01/tin.idl #avt_b01/tin.idl #avt_p01/tin.idl va_f01/tin.idl:idl_frontend va_f02/tin.idl:idl_frontend va_t01/tin.idl:idl_frontend va_t02/tin.idl:idl_frontend va_t03/tin.idl:idl_frontend va_t04/tin.idl:idl_frontend vb_b01/tin.idl:idl_frontend vb_d01/tin.idl:idl_frontend vb_d02/tin.idl:idl_frontend vb_d03/tin.idl:idl_frontend vb_d04/tin.idl:idl_frontend vb_d05/tin.idl:idl_frontend vb_e01/tin.idl:idl_frontend vb_p01/tin.idl:idl_frontend vb_p02/tin.idl:idl_frontend vb_p03/tin.idl:idl_frontend vt_b01/tin.idl:idl_frontend vt_e01/tin.idl:idl_frontend vt_i01/tin.idl:idl_frontend vt_m01/tin.idl:idl_frontend vt_m02/tin.idl:idl_frontend vt_o01/tin.idl:idl_frontend vt_p01/tin.idl:idl_frontend vti_avb01/tin.idl:idl_frontend vti_avb02/tin.idl:idl_frontend vti_si01/tin.idl:idl_frontend vti_si02/tin.idl:idl_frontend vti_si03/tin.idl:idl_frontend vti_vb01/tin.idl:idl_frontend #corba/orb.idl types001/tin.idl:types_backend types002/tin.idl:types_backend types003/tin.idl:types_backend types004/tin.idl:types_backend types005/tin.idl:types_backend types006/tin.idl:types_backend types007/tin.idl:types_backend types008/tin.idl:types_backend types009/tin.idl:types_backend types010/tin.idl:types_backend types011/tin.idl:types_backend types012/tin.idl:types_backend types013/tin.idl:types_backend types014/tin.idl:types_backend polyorb-2.8~20110207.orig/testsuite/idls/types014/0000755000175000017500000000000011750740340020757 5ustar xavierxavierpolyorb-2.8~20110207.orig/testsuite/idls/types014/tan.idl0000644000175000017500000000005311750740340022231 0ustar xavierxavierinterface tan { typedef wstring word; }; polyorb-2.8~20110207.orig/testsuite/idls/types014/test.out0000644000175000017500000000012411750740340022464 0ustar xavierxavierWSTRING := True ULONG := True ALIAS := True STRING := True VOID := True ANY := True polyorb-2.8~20110207.orig/testsuite/idls/types014/tin.idl0000644000175000017500000000010611750740340022240 0ustar xavierxavier#include "tan.idl" interface tin { void foo (in tan::word arg); }; polyorb-2.8~20110207.orig/testsuite/idls/idlac000/0000755000175000017500000000000011750740340020662 5ustar xavierxavierpolyorb-2.8~20110207.orig/testsuite/idls/idlac000/tin.idl0000644000175000017500000000006411750740340022146 0ustar xavierxaviermodule M { interface I { }; typedef I S2; }; polyorb-2.8~20110207.orig/testsuite/idls/ada0011/0000755000175000017500000000000011750740340020415 5ustar xavierxavierpolyorb-2.8~20110207.orig/testsuite/idls/ada0011/tin.idl0000644000175000017500000000017011750740340021677 0ustar xavierxavierinterface Inter2 { typedef float New_Float; attribute New_Float attr1; New_Float ConvertNew (in float N); }; polyorb-2.8~20110207.orig/testsuite/idls/forward01/0000755000175000017500000000000011750740340021173 5ustar xavierxavierpolyorb-2.8~20110207.orig/testsuite/idls/forward01/forward.idl0000644000175000017500000000052111750740340023327 0ustar xavierxavierinterface toto {}; interface titi { typedef toto toto2; toto2 getToto2(); toto getToto(); }; module Test000 { interface X0 {}; typedef X0 Y0; interface X1 {}; union Y1 switch (long) { case 1: X1 field1; }; interface X2 {}; union Y2 switch (long) { case 1: struct Nested { X2 field2; } fieldNest; }; }; polyorb-2.8~20110207.orig/testsuite/idls/idl15011/0000755000175000017500000000000011750740340020526 5ustar xavierxavierpolyorb-2.8~20110207.orig/testsuite/idls/idl15011/test.out0000644000175000017500000000016411750740340022237 0ustar xavierxavierinterface A { exception E { long L; }; void f() raises (A::E); }; interface B : A { void g() raises (A::E); }; polyorb-2.8~20110207.orig/testsuite/idls/idl15011/tin.idl0000644000175000017500000000016411750740340022013 0ustar xavierxavierinterface A { exception E { long L; }; void f() raises(E); }; interface B: A { void g() raises(E); }; polyorb-2.8~20110207.orig/testsuite/idls/avt_p01/0000755000175000017500000000000011750740340020640 5ustar xavierxavierpolyorb-2.8~20110207.orig/testsuite/idls/avt_p01/test.out0000644000175000017500000000030211750740340022343 0ustar xavierxavierabstract valuetype AbsVal { AbsVal op1(in AbsVal inPara, inout AbsVal ioPara, out AbsVal outPara); }; interface Itf { AbsVal op2(in AbsVal inPara, inout AbsVal ioPara, out AbsVal outPara); }; polyorb-2.8~20110207.orig/testsuite/idls/avt_p01/tin.idl0000644000175000017500000000050411750740340022123 0ustar xavierxavier// testsubgroup abstract valuetype as operation parameter // tsgdescr "Testing the abstract valuetype as operation parameter" abstract valuetype AbsVal { AbsVal op1(in AbsVal inPara, inout AbsVal ioPara, out AbsVal outPara); }; interface Itf { AbsVal op2(in AbsVal inPara, inout AbsVal ioPara, out AbsVal outPara); }; polyorb-2.8~20110207.orig/testsuite/idls/circular/0000755000175000017500000000000011750740340021172 5ustar xavierxavierpolyorb-2.8~20110207.orig/testsuite/idls/circular/test_typedef_2.idl0000644000175000017500000000012611750740340024603 0ustar xavierxavier module Test_Typedef_2 { interface X; interface X {}; typedef X Y; }; polyorb-2.8~20110207.orig/testsuite/idls/circular/test_struct_1.idl0000644000175000017500000000012611750740340024466 0ustar xavierxavier module Test_Struct_1 { interface X { }; struct Y { X a; }; }; polyorb-2.8~20110207.orig/testsuite/idls/circular/test_exception_1.idl0000644000175000017500000000013311750740340025136 0ustar xavierxavier module Test_Exception_1 { interface X {}; exception Y { X a; }; }; polyorb-2.8~20110207.orig/testsuite/idls/circular/test_sequence_2.idl0000644000175000017500000000014111750740340024750 0ustar xavierxavier module Test_Sequence_2 { interface X; interface X { }; typedef sequence Y; }; polyorb-2.8~20110207.orig/testsuite/idls/circular/test_array_11.idl0000644000175000017500000000016311750740340024342 0ustar xavierxavier module Test_Array_1 { interface X; typedef X y[4]; interface X { typedef X X2[12]; }; }; polyorb-2.8~20110207.orig/testsuite/idls/circular/test_exception_2.idl0000644000175000017500000000015511750740340025143 0ustar xavierxavier module Test_Exception_2 { interface X; interface X {}; exception Y { X a; }; }; polyorb-2.8~20110207.orig/testsuite/idls/circular/test_struct_2.idl0000644000175000017500000000012611750740340024467 0ustar xavierxavier module Test_Struct_2 { interface X { }; struct Y { X a; }; }; polyorb-2.8~20110207.orig/testsuite/idls/circular/test_array_2.idl0000644000175000017500000000012711750740340024262 0ustar xavierxavier module Test_Array_2 { interface X; interface X {}; typedef X y[4]; }; polyorb-2.8~20110207.orig/testsuite/idls/circular/test_typedef_1.idl0000644000175000017500000000010411750740340024576 0ustar xavierxavier module Test_Typedef_1 { interface X {}; typedef X Y; }; polyorb-2.8~20110207.orig/testsuite/idls/circular/test_sequence_1.idl0000644000175000017500000000011711750740340024752 0ustar xavierxavier module Test_Sequence_1 { interface X { }; typedef sequence Y; }; polyorb-2.8~20110207.orig/testsuite/idls/circular/test_array_1.idl0000644000175000017500000000010511750740340024255 0ustar xavierxavier module Test_Array_1 { interface X {}; typedef X y[4]; }; polyorb-2.8~20110207.orig/testsuite/idls/attr001/0000755000175000017500000000000011750740340020561 5ustar xavierxavierpolyorb-2.8~20110207.orig/testsuite/idls/attr001/tin.idl0000644000175000017500000000055311750740340022050 0ustar xavierxavierinterface MyInt { exception e1 {}; exception e2 {}; exception e3 {}; exception e4 {}; readonly attribute long a1, a2 raises (e1); attribute long a3, a4 getraises (e1, e2); attribute long a5, a6 setraises (e3, e4); attribute long a7, a8 getraises (e1, e2) setraises (e3, e4); readonly attribute long a9, a10 raises (e1, e2, e3, e4); }; polyorb-2.8~20110207.orig/testsuite/idls/idlac004/0000755000175000017500000000000011750740340020666 5ustar xavierxavierpolyorb-2.8~20110207.orig/testsuite/idls/idlac004/tin.idl0000644000175000017500000000010411750740340022145 0ustar xavierxavierinterface I0 { typedef boolean foo; typedef foo array[10]; }; polyorb-2.8~20110207.orig/testsuite/idls/test048/0000755000175000017500000000000011750740340020601 5ustar xavierxavierpolyorb-2.8~20110207.orig/testsuite/idls/test048/test.out0000644000175000017500000000104611750740340022312 0ustar xavierxavierunion Broadbeans switch (short) { default : float ButterBean; case 28 : double Cinnamon; case 57 : long BreadFruit; case 9875 : short BambooShoot; case 7667 : unsigned long Fennell; case 2213 : unsigned short Pineapple; case 12 : char Radish; case 7 : boolean Damsons; case 23 : octet Mullberry; }; interface idlServer { exception BroadbeansExcpt { Broadbeans ex1; }; attribute Broadbeans BroadbeansAttr; Broadbeans BroadbeansOp(in Broadbeans p1, out Broadbeans p2, inout Broadbeans p3) raises (idlServer::BroadbeansExcpt); }; polyorb-2.8~20110207.orig/testsuite/idls/iac002/0000755000175000017500000000000011750740340020344 5ustar xavierxavierpolyorb-2.8~20110207.orig/testsuite/idls/iac002/tin.idl0000644000175000017500000000016411750740340021631 0ustar xavierxavierinterface A { exception E { long L; }; void f() raises(E); }; interface B: A { void g() raises(E); }; polyorb-2.8~20110207.orig/testsuite/idls/test055/0000755000175000017500000000000011750740340020577 5ustar xavierxavierpolyorb-2.8~20110207.orig/testsuite/idls/test055/test.out0000644000175000017500000000026511750740340022312 0ustar xavierxavierorb.idl:66:05: warning: semicolon expected CORBA_InterfaceRepository.idl:10:05: warning: semicolon expected iac: 2 warning(s) import ::CORBA::ORB; module p { typedef long plop; }; polyorb-2.8~20110207.orig/testsuite/idls/test055/tin.idl0000644000175000017500000000014211750740340022060 0ustar xavierxavier// Requested by JH on Mon, 14 Nov 2005 import ::CORBA::ORB; module p { typedef long plop; }; polyorb-2.8~20110207.orig/testsuite/idls/test044/0000755000175000017500000000000011750740340020575 5ustar xavierxavierpolyorb-2.8~20110207.orig/testsuite/idls/test044/test.out0000644000175000017500000000270711750740340022313 0ustar xavierxaviertypedef struct Avocado { unsigned long ButterBean; } Apple; typedef struct Banana { float ButterBean[6], ChestNut, Currant[43], CoxPippin, Chervil, Scallion[23], Tomato[8]; } Peanut, Satsuma[3], RedChilly, Celeriac; interface idlServer { exception AppleExcpt { Apple ex1; }; attribute Apple AppleAttr; Apple AppleOp(in Apple p1, out Apple p2, inout Apple p3) raises (idlServer::AppleExcpt); exception AvocadoExcpt { Avocado ex1; }; attribute Avocado AvocadoAttr; Avocado AvocadoOp(in Avocado p1, out Avocado p2, inout Avocado p3) raises (idlServer::AvocadoExcpt); exception PeanutExcpt { Peanut ex1; }; attribute Peanut PeanutAttr; Peanut PeanutOp(in Peanut p1, out Peanut p2, inout Peanut p3) raises (idlServer::PeanutExcpt); exception SatsumaExcpt { Satsuma ex1; }; attribute Satsuma SatsumaAttr; Satsuma SatsumaOp(in Satsuma p1, out Satsuma p2, inout Satsuma p3) raises (idlServer::SatsumaExcpt); exception RedChillyExcpt { RedChilly ex1; }; attribute RedChilly RedChillyAttr; RedChilly RedChillyOp(in RedChilly p1, out RedChilly p2, inout RedChilly p3) raises (idlServer::RedChillyExcpt); exception CeleriacExcpt { Celeriac ex1; }; attribute Celeriac CeleriacAttr; Celeriac CeleriacOp(in Celeriac p1, out Celeriac p2, inout Celeriac p3) raises (idlServer::CeleriacExcpt); exception BananaExcpt { Banana ex1; }; attribute Banana BananaAttr; Banana BananaOp(in Banana p1, out Banana p2, inout Banana p3) raises (idlServer::BananaExcpt); }; polyorb-2.8~20110207.orig/testsuite/idls/idl07052/0000755000175000017500000000000011750740340020534 5ustar xavierxavierpolyorb-2.8~20110207.orig/testsuite/idls/idl07052/test.out0000644000175000017500000000022611750740340022244 0ustar xavierxaviertin.idl:8:13: multiple declarations of "string_t" tin.idl:8:13: found declaration at line 5 tin.idl:8:13: found declaration at line 2 iac: 1 error(s) polyorb-2.8~20110207.orig/testsuite/idls/idl07052/tin.idl0000644000175000017500000000037211750740340022022 0ustar xavierxavierinterface A { typedef string<128> string_t; }; interface B { typedef string<256> string_t; }; interface C: A, B { attribute string_t Title; // Error: string_t ambiguous attribute A::string_t Name; // OK attribute B::string_t City; // OK }; polyorb-2.8~20110207.orig/testsuite/idls/test037/0000755000175000017500000000000011750740340020577 5ustar xavierxavierpolyorb-2.8~20110207.orig/testsuite/idls/test037/test.out0000644000175000017500000000770411750740340022317 0ustar xavierxaviertypedef struct HazelNut114 { struct CrabApple114 { struct Lentil114 { sequence>, 18>> GoldenDelicous114[13]; } Fig114; } RedOnion114; } Cinnamon114; typedef struct Plum115 { struct Onion115 { struct Tofu115 { sequence, 11>, 7>> Runnerbean115; } Sweetcorn115[10]; } Shallots115; } KidneyBean115; typedef struct Tangarine116 { struct BrazilNut116 { struct Brocoli116 { sequence>, 19>> Prunes116; } GrannySmith116; } SweetPotato116; } Billberries116; typedef struct Almonds117 { struct Oregano117 { struct Asparagus117 { sequence, 12>>, 6> GardenPeas117[9]; } Dill117[7]; } Beansprout117; } Guava117; typedef struct Parsnip118 { struct Orange118 { struct Sultana118 { sequence>>, 2> GaliaMelon118[5]; } Turnip118; } LoganBerry118; } Celery118; typedef struct BlackEyedBeans119 { struct Ginger119 { struct Starfruit119 { sequence, 9>>, 3> BlackCherry119; } Cucumber119[17]; } Apricots119; } Leek119; typedef struct Lime120 { struct Mango120 { struct PassionFruit120 { sequence>>, 6> Rhubarb120; } Pumpkin120; } WaterMelon120; } Dates120; typedef struct Banana121 { struct PentlandDell120 { struct Homeguard120 { sequence, 6>>> Record120[18]; } KingEdward120[15]; } Apple121; } Carrots121; typedef struct Pimpernel121 { struct KerrsPinks121 { struct Wilja121 { sequence>>> BritishQueens121[7]; } Balmoral121; } GoldenWonder121; } Cultra121; interface idlServer { exception Cinnamon114Excpt { Cinnamon114 ex1; }; attribute Cinnamon114 Cinnamon114Attr; Cinnamon114 Cinnamon114Op(in Cinnamon114 p1, out Cinnamon114 p2, inout Cinnamon114 p3) raises (idlServer::Cinnamon114Excpt); exception HazelNut114Excpt { HazelNut114 ex1; }; attribute HazelNut114 HazelNut114Attr; HazelNut114 HazelNut114Op(in HazelNut114 p1, out HazelNut114 p2, inout HazelNut114 p3) raises (idlServer::HazelNut114Excpt); exception CrabApple114Excpt { HazelNut114::CrabApple114 ex1; }; attribute HazelNut114::CrabApple114 CrabApple114Attr; HazelNut114::CrabApple114 CrabApple114Op(in HazelNut114::CrabApple114 p1, out HazelNut114::CrabApple114 p2, inout HazelNut114::CrabApple114 p3) raises (idlServer::CrabApple114Excpt); exception Lentil114Excpt { HazelNut114::CrabApple114::Lentil114 ex1; }; attribute HazelNut114::CrabApple114::Lentil114 Lentil114Attr; HazelNut114::CrabApple114::Lentil114 Lentil114Op(in HazelNut114::CrabApple114::Lentil114 p1, out HazelNut114::CrabApple114::Lentil114 p2, inout HazelNut114::CrabApple114::Lentil114 p3) raises (idlServer::Lentil114Excpt); exception KidneyBean115Excpt { KidneyBean115 ex1; }; attribute KidneyBean115 KidneyBean115Attr; KidneyBean115 KidneyBean115Op(in KidneyBean115 p1, out KidneyBean115 p2, inout KidneyBean115 p3) raises (idlServer::KidneyBean115Excpt); exception Plum115Excpt { Plum115 ex1; }; attribute Plum115 Plum115Attr; Plum115 Plum115Op(in Plum115 p1, out Plum115 p2, inout Plum115 p3) raises (idlServer::Plum115Excpt); exception Onion115Excpt { Plum115::Onion115 ex1; }; attribute Plum115::Onion115 Onion115Attr; Plum115::Onion115 Onion115Op(in Plum115::Onion115 p1, out Plum115::Onion115 p2, inout Plum115::Onion115 p3) raises (idlServer::Onion115Excpt); exception Tofu115Excpt { Plum115::Onion115::Tofu115 ex1; }; attribute Plum115::Onion115::Tofu115 Tofu115Attr; Plum115::Onion115::Tofu115 Tofu115Op(in Plum115::Onion115::Tofu115 p1, out Plum115::Onion115::Tofu115 p2, inout Plum115::Onion115::Tofu115 p3) raises (idlServer::Tofu115Excpt); exception Billberries116Excpt { Billberries116 ex1; }; attribute Billberries116 Billberries116Attr; Billberries116 Billberries116Op(in Billberries116 p1, out Billberries116 p2, inout Billberries116 p3) raises (idlServer::Billberries116Excpt); }; polyorb-2.8~20110207.orig/testsuite/idls/test046/0000755000175000017500000000000011750740340020577 5ustar xavierxavierpolyorb-2.8~20110207.orig/testsuite/idls/test046/test.out0000644000175000017500000001061511750740340022312 0ustar xavierxaviertypedef struct Avocado { struct Mango { float ButterBean; struct Starfruit { double Cinnamon; struct Dates { long BreadFruit; struct Lime { short BambooShoot; struct Leek { unsigned long Fennell; struct Ginger { unsigned short Pineapple; struct Mint { char Radish; struct GardenPeas { boolean Damsons; struct Sultana { octet Mullberry; } Mint; } Asparagus; } Parsnip; } Celery; } Aniseed; } Pumpkin; } Tofu; } Onion; } Plum; } Banana; interface idlServer { exception BananaExcpt { Banana ex1; }; attribute Banana BananaAttr; Banana BananaOp(in Banana p1, out Banana p2, inout Banana p3) raises (idlServer::BananaExcpt); exception AvocadoExcpt { Avocado ex1; }; attribute Avocado AvocadoAttr; Avocado AvocadoOp(in Avocado p1, out Avocado p2, inout Avocado p3) raises (idlServer::AvocadoExcpt); exception MangoExcpt { Avocado::Mango ex1; }; attribute Avocado::Mango MangoAttr; Avocado::Mango MangoOp(in Avocado::Mango p1, out Avocado::Mango p2, inout Avocado::Mango p3) raises (idlServer::MangoExcpt); exception StarfruitExcpt { Avocado::Mango::Starfruit ex1; }; attribute Avocado::Mango::Starfruit StarfruitAttr; Avocado::Mango::Starfruit StarfruitOp(in Avocado::Mango::Starfruit p1, out Avocado::Mango::Starfruit p2, inout Avocado::Mango::Starfruit p3) raises (idlServer::StarfruitExcpt); exception DatesExcpt { Avocado::Mango::Starfruit::Dates ex1; }; attribute Avocado::Mango::Starfruit::Dates DatesAttr; Avocado::Mango::Starfruit::Dates DatesOp(in Avocado::Mango::Starfruit::Dates p1, out Avocado::Mango::Starfruit::Dates p2, inout Avocado::Mango::Starfruit::Dates p3) raises (idlServer::DatesExcpt); exception LimeExcpt { Avocado::Mango::Starfruit::Dates::Lime ex1; }; attribute Avocado::Mango::Starfruit::Dates::Lime LimeAttr; Avocado::Mango::Starfruit::Dates::Lime LimeOp(in Avocado::Mango::Starfruit::Dates::Lime p1, out Avocado::Mango::Starfruit::Dates::Lime p2, inout Avocado::Mango::Starfruit::Dates::Lime p3) raises (idlServer::LimeExcpt); exception LeekExcpt { Avocado::Mango::Starfruit::Dates::Lime::Leek ex1; }; attribute Avocado::Mango::Starfruit::Dates::Lime::Leek LeekAttr; Avocado::Mango::Starfruit::Dates::Lime::Leek LeekOp(in Avocado::Mango::Starfruit::Dates::Lime::Leek p1, out Avocado::Mango::Starfruit::Dates::Lime::Leek p2, inout Avocado::Mango::Starfruit::Dates::Lime::Leek p3) raises (idlServer::LeekExcpt); exception GingerExcpt { Avocado::Mango::Starfruit::Dates::Lime::Leek::Ginger ex1; }; attribute Avocado::Mango::Starfruit::Dates::Lime::Leek::Ginger GingerAttr; Avocado::Mango::Starfruit::Dates::Lime::Leek::Ginger GingerOp(in Avocado::Mango::Starfruit::Dates::Lime::Leek::Ginger p1, out Avocado::Mango::Starfruit::Dates::Lime::Leek::Ginger p2, inout Avocado::Mango::Starfruit::Dates::Lime::Leek::Ginger p3) raises (idlServer::GingerExcpt); exception MintExcpt { Avocado::Mango::Starfruit::Dates::Lime::Leek::Ginger::Mint ex1; }; attribute Avocado::Mango::Starfruit::Dates::Lime::Leek::Ginger::Mint MintAttr; Avocado::Mango::Starfruit::Dates::Lime::Leek::Ginger::Mint MintOp(in Avocado::Mango::Starfruit::Dates::Lime::Leek::Ginger::Mint p1, out Avocado::Mango::Starfruit::Dates::Lime::Leek::Ginger::Mint p2, inout Avocado::Mango::Starfruit::Dates::Lime::Leek::Ginger::Mint p3) raises (idlServer::MintExcpt); exception GardenPeasExcpt { Avocado::Mango::Starfruit::Dates::Lime::Leek::Ginger::Mint::GardenPeas ex1; }; attribute Avocado::Mango::Starfruit::Dates::Lime::Leek::Ginger::Mint::GardenPeas GardenPeasAttr; Avocado::Mango::Starfruit::Dates::Lime::Leek::Ginger::Mint::GardenPeas GardenPeasOp(in Avocado::Mango::Starfruit::Dates::Lime::Leek::Ginger::Mint::GardenPeas p1, out Avocado::Mango::Starfruit::Dates::Lime::Leek::Ginger::Mint::GardenPeas p2, inout Avocado::Mango::Starfruit::Dates::Lime::Leek::Ginger::Mint::GardenPeas p3) raises (idlServer::GardenPeasExcpt); exception SultanaExcpt { Avocado::Mango::Starfruit::Dates::Lime::Leek::Ginger::Mint::GardenPeas::Sultana ex1; }; attribute Avocado::Mango::Starfruit::Dates::Lime::Leek::Ginger::Mint::GardenPeas::Sultana SultanaAttr; Avocado::Mango::Starfruit::Dates::Lime::Leek::Ginger::Mint::GardenPeas::Sultana SultanaOp(in Avocado::Mango::Starfruit::Dates::Lime::Leek::Ginger::Mint::GardenPeas::Sultana p1, out Avocado::Mango::Starfruit::Dates::Lime::Leek::Ginger::Mint::GardenPeas::Sultana p2, inout Avocado::Mango::Starfruit::Dates::Lime::Leek::Ginger::Mint::GardenPeas::Sultana p3) raises (idlServer::SultanaExcpt); }; polyorb-2.8~20110207.orig/testsuite/idls/types012/0000755000175000017500000000000011750740340020755 5ustar xavierxavierpolyorb-2.8~20110207.orig/testsuite/idls/types012/test.out0000644000175000017500000000021311750740340022461 0ustar xavierxavierUNION := True LONG := True STRING := True ULONG := True CHAR := True SHORT := True OCTET := True DOUBLE := True USHORT := True ANY := True polyorb-2.8~20110207.orig/testsuite/idls/types012/tin.idl0000644000175000017500000000025211750740340022240 0ustar xavierxavierinterface tin { union myUnion switch (char) { case 'a': short Com1; case 'B': octet Com2; case 'Z': double Com3; default : unsigned short ComD; }; }; polyorb-2.8~20110207.orig/testsuite/idls/types009/0000755000175000017500000000000011750740340020763 5ustar xavierxavierpolyorb-2.8~20110207.orig/testsuite/idls/types009/test.out0000644000175000017500000000007111750740340022471 0ustar xavierxavierWSTRING := True ULONG := True STRING := True ANY := True polyorb-2.8~20110207.orig/testsuite/idls/types009/tin.idl0000644000175000017500000000007311750740340022247 0ustar xavierxavierinterface tin { wstring echowstring (in wstring arg); }; polyorb-2.8~20110207.orig/testsuite/idls/test014/0000755000175000017500000000000011750740340020572 5ustar xavierxavierpolyorb-2.8~20110207.orig/testsuite/idls/test014/test.out0000644000175000017500000000127311750740340022305 0ustar xavierxavierinterface Apple { const long Lemon = 3; typedef long Pumpkin; exception Oregano { long Sultana; }; }; interface Banana : Apple { const short Lemon = 3; typedef short Pumpkin; exception Oregano { short Sultana; }; }; interface Carrots : Apple { const float Lemon = 4.5; typedef float Pumpkin; exception Oregano { float Sultana; }; }; interface Dates : Banana, Carrots { const char Lemon = '6'; typedef char Pumpkin; exception Oregano { char Sultana; }; }; interface idlServer : Dates { typedef short Melon[3]; void Lemon(in idlServer::Melon p1, inout Apple::Pumpkin p2, inout Banana::Pumpkin p3, inout Carrots::Pumpkin p4, inout Dates::Pumpkin p5) raises (Carrots::Oregano); }; polyorb-2.8~20110207.orig/testsuite/idls/test005/0000755000175000017500000000000011750740340020572 5ustar xavierxavierpolyorb-2.8~20110207.orig/testsuite/idls/test005/test.out0000644000175000017500000000326611750740340022311 0ustar xavierxavierconst float Apple = 2.0E-1; const float Banana = 2.0E+2; const float Carrots = 2.0E+2; const float Lemon = 2.0E+2; const float BlackCherry = 2.0E+2; const float Starfruit = 2.0E-4; const float Rhubarb = 2.0E-4; const float PassionFruit = 1.0E+3; const float Pumpkin = 1.0E+3; const float Mango = 1.0E+3; const float WaterMelon = 1.0E+3; const float Lime = 1.0E-3; const float Dates = 1.0E-3; const float Coconut = 1.0; const float Lychees = 1.0E+3; const float Cabbage = 1.0E+3; const float Cucumber = 1.0E+3; const float Ginger = 1.0E+3; const float Apricots = 1.0E-3; const float BlackEyedBeans = 1.0E-3; const float Leek = 1.2; const float Mint = 1.2E+3; const float GardenPeas = 1.2E+3; const float Asparagus = 1.2E+3; const float GaliaMelon = 1.2E+3; const float Sultana = 1.2E-3; const float Turnip = 1.2E-3; const double Orange = 2.0E-1; const double LoganBerry = 2.0E+2; const double Parsnip = 2.0E+2; const double Celery = 2.0E+2; const double WhiteCabbage = 2.0E+2; const double Aniseed = 2.0E-4; const double Bayleaf = 2.0E-4; const double Dill = 1.0E+3; const double Oregano = 1.0E+3; const double Beansprout = 1.0E+3; const double Almonds = 1.0E+3; const double Guava = 1.0E-3; const double Mushroom = 1.0E-3; const double Runnerbean = 1.0; const double Tofu = 1.0E+3; const double Prunes = 1.0E+3; const double Brocoli = 1.0E+3; const double GrannySmith = 1.0E+3; const double BrazilNut = 1.0E-3; const double SweetPotato = 1.0E-3; const double Onion = 1.2; const double Tangarine = 1.2E+3; const double Billberries = 1.2E+3; const double CantelopeMelon = 1.2E+3; const double LolloRossa = 1.2E+3; const double RowanBerry = 1.2E-3; const double Sweetcorn = 1.2E-3; interface idlServer { void Plum(); }; polyorb-2.8~20110207.orig/testsuite/idls/test_errors.sh0000755000175000017500000000015011750740340022274 0ustar xavierxavier#!/bin/sh # This script parse an IDL file DIR=`dirname $1` FILE=`basename $1` cd $DIR iac -idl $FILE polyorb-2.8~20110207.orig/testsuite/idls/test030/0000755000175000017500000000000011750740340020570 5ustar xavierxavierpolyorb-2.8~20110207.orig/testsuite/idls/test030/test.out0000644000175000017500000001017311750740340022302 0ustar xavierxaviertypedef sequence>> Zucchini1[18]; typedef sequence>> RedOnion1; typedef sequence, 13>> JuniperBerries1[15]; typedef sequence, 7>, 10> Tarragon1; typedef sequence, 19>, 12> Elderberry1[6]; typedef sequence>>> Plantain1; typedef sequence, 9>>> Sharanfruit1[7]; typedef sequence>>, 2> Damsons1; typedef sequence, 3>>, 9> Eddo1[3]; typedef sequence>, 17>, 6> CoxPippin1; typedef sequence>>> KiwanoMelon1[18]; typedef sequence, 11>, 7>> RedCabbage1; typedef sequence>, 14>, 11> Pimpernel1[5]; typedef sequence>>, 16> BlackCherry2; typedef sequence, 5>, 14>, 2> Cucumber2; interface idlServer { exception Zucchini1Excpt { Zucchini1 ex1; }; attribute Zucchini1 Zucchini1Attr; Zucchini1 Zucchini1Op(in Zucchini1 p1, out Zucchini1 p2, inout Zucchini1 p3) raises (idlServer::Zucchini1Excpt); exception RedOnion1Excpt { RedOnion1 ex1; }; attribute RedOnion1 RedOnion1Attr; RedOnion1 RedOnion1Op(in RedOnion1 p1, out RedOnion1 p2, inout RedOnion1 p3) raises (idlServer::RedOnion1Excpt); exception JuniperBerries1Excpt { JuniperBerries1 ex1; }; attribute JuniperBerries1 JuniperBerries1Attr; JuniperBerries1 JuniperBerries1Op(in JuniperBerries1 p1, out JuniperBerries1 p2, inout JuniperBerries1 p3) raises (idlServer::JuniperBerries1Excpt); exception Tarragon1Excpt { Tarragon1 ex1; }; attribute Tarragon1 Tarragon1Attr; Tarragon1 Tarragon1Op(in Tarragon1 p1, out Tarragon1 p2, inout Tarragon1 p3) raises (idlServer::Tarragon1Excpt); exception Elderberry1Excpt { Elderberry1 ex1; }; attribute Elderberry1 Elderberry1Attr; Elderberry1 Elderberry1Op(in Elderberry1 p1, out Elderberry1 p2, inout Elderberry1 p3) raises (idlServer::Elderberry1Excpt); exception Plantain1Excpt { Plantain1 ex1; }; attribute Plantain1 Plantain1Attr; Plantain1 Plantain1Op(in Plantain1 p1, out Plantain1 p2, inout Plantain1 p3) raises (idlServer::Plantain1Excpt); exception Sharanfruit1Excpt { Sharanfruit1 ex1; }; attribute Sharanfruit1 Sharanfruit1Attr; Sharanfruit1 Sharanfruit1Op(in Sharanfruit1 p1, out Sharanfruit1 p2, inout Sharanfruit1 p3) raises (idlServer::Sharanfruit1Excpt); exception Damsons1Excpt { Damsons1 ex1; }; attribute Damsons1 Damsons1Attr; Damsons1 Damsons1Op(in Damsons1 p1, out Damsons1 p2, inout Damsons1 p3) raises (idlServer::Damsons1Excpt); exception Eddo1Excpt { Eddo1 ex1; }; attribute Eddo1 Eddo1Attr; Eddo1 Eddo1Op(in Eddo1 p1, out Eddo1 p2, inout Eddo1 p3) raises (idlServer::Eddo1Excpt); exception CoxPippin1Excpt { CoxPippin1 ex1; }; attribute CoxPippin1 CoxPippin1Attr; CoxPippin1 CoxPippin1Op(in CoxPippin1 p1, out CoxPippin1 p2, inout CoxPippin1 p3) raises (idlServer::CoxPippin1Excpt); exception KiwanoMelon1Excpt { KiwanoMelon1 ex1; }; attribute KiwanoMelon1 KiwanoMelon1Attr; KiwanoMelon1 KiwanoMelon1Op(in KiwanoMelon1 p1, out KiwanoMelon1 p2, inout KiwanoMelon1 p3) raises (idlServer::KiwanoMelon1Excpt); exception RedCabbage1Excpt { RedCabbage1 ex1; }; attribute RedCabbage1 RedCabbage1Attr; RedCabbage1 RedCabbage1Op(in RedCabbage1 p1, out RedCabbage1 p2, inout RedCabbage1 p3) raises (idlServer::RedCabbage1Excpt); exception Pimpernel1Excpt { Pimpernel1 ex1; }; attribute Pimpernel1 Pimpernel1Attr; Pimpernel1 Pimpernel1Op(in Pimpernel1 p1, out Pimpernel1 p2, inout Pimpernel1 p3) raises (idlServer::Pimpernel1Excpt); exception BlackCherry2Excpt { BlackCherry2 ex1; }; attribute BlackCherry2 BlackCherry2Attr; BlackCherry2 BlackCherry2Op(in BlackCherry2 p1, out BlackCherry2 p2, inout BlackCherry2 p3) raises (idlServer::BlackCherry2Excpt); exception Cucumber2Excpt { Cucumber2 ex1; }; attribute Cucumber2 Cucumber2Attr; Cucumber2 Cucumber2Op(in Cucumber2 p1, out Cucumber2 p2, inout Cucumber2 p3) raises (idlServer::Cucumber2Excpt); }; polyorb-2.8~20110207.orig/testsuite/idls/max_values/0000755000175000017500000000000011750740340021532 5ustar xavierxavierpolyorb-2.8~20110207.orig/testsuite/idls/max_values/tin.idl0000644000175000017500000000206111750740340023015 0ustar xavierxavier// Test for the minimum and maximum values of integer literals module max_values { typedef long Integer; typedef long Natural; typedef long Positive; typedef short Integer_8; typedef short Integer_16; typedef long Integer_32; typedef long long Integer_64; // Max values for integer litterals const Integer INTEGER_MIN = -2147483648; const Integer INTEGER_MAX = 2147483647; const Integer_8 INTEGER_8_MIN = -128; const Integer_8 INTEGER_8_MAX = 127; const Integer_16 INTEGER_16_MIN = -32768; const Integer_16 INTEGER_16_MAX = 32767; const Integer_32 INTEGER_32_MIN = -2147483648; const Integer_32 INTEGER_32_MAX = 2147483647; const Integer_64 INTEGER_64_MIN = -9223372036854775808; const Integer_64 INTEGER_64_MAX = 9223372036854775807; const Natural NATURAL_MIN = 0; const Natural NATURAL_MAX = 2147483647; const Positive POSITIVE_MIN = 1; const Positive POSITIVE_MAX = 2147483647; }; polyorb-2.8~20110207.orig/testsuite/idls/test023/0000755000175000017500000000000011750740340020572 5ustar xavierxavierpolyorb-2.8~20110207.orig/testsuite/idls/test023/test.out0000644000175000017500000000341511750740340022305 0ustar xavierxaviertypedef sequence Beansprout; typedef sequence Almonds[13]; typedef sequence Guava; typedef sequence Mushroom[15]; typedef sequence Runnerbean; typedef sequence Tofu[10]; typedef sequence Prunes; typedef sequence Brocoli[19]; interface idlServer { exception BeansproutExcpt { Beansprout ex1; }; attribute Beansprout BeansproutAttr; Beansprout BeansproutOp(in Beansprout p1, out Beansprout p2, inout Beansprout p3) raises (idlServer::BeansproutExcpt); exception AlmondsExcpt { Almonds ex1; }; attribute Almonds AlmondsAttr; Almonds AlmondsOp(in Almonds p1, out Almonds p2, inout Almonds p3) raises (idlServer::AlmondsExcpt); exception GuavaExcpt { Guava ex1; }; attribute Guava GuavaAttr; Guava GuavaOp(in Guava p1, out Guava p2, inout Guava p3) raises (idlServer::GuavaExcpt); exception MushroomExcpt { Mushroom ex1; }; attribute Mushroom MushroomAttr; Mushroom MushroomOp(in Mushroom p1, out Mushroom p2, inout Mushroom p3) raises (idlServer::MushroomExcpt); exception RunnerbeanExcpt { Runnerbean ex1; }; attribute Runnerbean RunnerbeanAttr; Runnerbean RunnerbeanOp(in Runnerbean p1, out Runnerbean p2, inout Runnerbean p3) raises (idlServer::RunnerbeanExcpt); exception TofuExcpt { Tofu ex1; }; attribute Tofu TofuAttr; Tofu TofuOp(in Tofu p1, out Tofu p2, inout Tofu p3) raises (idlServer::TofuExcpt); exception PrunesExcpt { Prunes ex1; }; attribute Prunes PrunesAttr; Prunes PrunesOp(in Prunes p1, out Prunes p2, inout Prunes p3) raises (idlServer::PrunesExcpt); exception BrocoliExcpt { Brocoli ex1; }; attribute Brocoli BrocoliAttr; Brocoli BrocoliOp(in Brocoli p1, out Brocoli p2, inout Brocoli p3) raises (idlServer::BrocoliExcpt); }; polyorb-2.8~20110207.orig/testsuite/idls/vt_p01/0000755000175000017500000000000011750740340020477 5ustar xavierxavierpolyorb-2.8~20110207.orig/testsuite/idls/vt_p01/test.out0000644000175000017500000000034611750740340022212 0ustar xavierxaviervaluetype Val { public short ShortMbr; attribute Val ValAttr; Val op1(in Val inPara, inout Val ioPara, out Val outPara); }; interface Inf { attribute Val ValAttr; Val op2(in Val inPara, inout Val ioPara, out Val outPara); }; polyorb-2.8~20110207.orig/testsuite/idls/vt_p01/tin.idl0000644000175000017500000000064111750740340021764 0ustar xavierxavier// IDL-Spec for testgroup: valuetype // Purpose: Valuetype as operation parameter and attribute in a valuetype, // valuetype as operation parameter and attribute in an interface valuetype Val { public short ShortMbr; attribute Val ValAttr; Val op1(in Val inPara, inout Val ioPara, out Val outPara); }; interface Inf { attribute Val ValAttr; Val op2(in Val inPara, inout Val ioPara, out Val outPara); }; polyorb-2.8~20110207.orig/testsuite/idls/idl15034/0000755000175000017500000000000011750740340020533 5ustar xavierxavierpolyorb-2.8~20110207.orig/testsuite/idls/idl15034/test.out0000644000175000017500000000017011750740340022241 0ustar xavierxaviertypedef long ArgType; module M { struct S { ArgType x; }; typedef string ArgType; struct T { M::ArgType y; }; }; polyorb-2.8~20110207.orig/testsuite/idls/idl15034/tin.idl0000644000175000017500000000026611750740340022023 0ustar xavierxaviertypedef long ArgType; module M { struct S { ArgType x; // x is a long }; typedef string ArgType; // OK! struct T { ArgType y; // Ugly but OK, y is a string }; }; polyorb-2.8~20110207.orig/testsuite/idls/cmp-words0000755000175000017500000000074011750740340021230 0ustar xavierxavier#!/usr/bin/perl $opt = @ARGV [1]; open (IDLAC, "idlac.out") || die "Erreur d'ouverture de idlac.out"; @Tab1 = ; @Tab2 = ; $LastTab1 = $#Tab1; $LastTab2 = $#Tab2; $i2 = 0; for ($i1=0; $i1 <= $LastTab1;$i1++) { while ((@Tab1[$i1] ne @Tab2[$i2]) and ($i2<= $LastTab2)) { $i2++; } if ($i2> $LastTab2) { die ("iac: @Tab1[$i1]"); } if ($opt eq "-v") { print "iac:$Tab1[$i1]\n"; print "idlac:$Tab2[$i2]\n"; } } polyorb-2.8~20110207.orig/testsuite/idls/test020/0000755000175000017500000000000011750740340020567 5ustar xavierxavierpolyorb-2.8~20110207.orig/testsuite/idls/test020/test.out0000644000175000017500000000351211750740340022300 0ustar xavierxavierorb.idl:66:05: warning: semicolon expected CORBA_InterfaceRepository.idl:10:05: warning: semicolon expected iac: 2 warning(s) import ::CORBA; enum EggPlant { Banana, Carrots, Lemon, BlackCherry, Starfruit, Rhubarb }; typedef sequence Plum[18]; typedef struct Zucchini { short Pumpkin; } Avocado; union Lentil switch (long) { case 23 : octet Lime; case -25 : Avocado Coconut; default : short Lychees; }; interface siiServer { attribute float Cucumber; attribute double Ginger; attribute long Apricots; attribute unsigned long BlackEyedBeans; attribute short Leek; attribute unsigned short Mint; attribute char GardenPeas; attribute boolean Fig; attribute octet Asparagus; attribute string GaliaMelon; attribute string<23> Sultana; attribute CORBA::OObject Turnip; attribute any Orange; attribute CORBA::TypeCode LoganBerry; readonly attribute float Parsnip; readonly attribute double Celery; readonly attribute long WhiteCabbage; readonly attribute unsigned long Aniseed; readonly attribute short Bayleaf; readonly attribute unsigned short Dill; readonly attribute char Oregano; readonly attribute boolean Beansprout; readonly attribute octet Almonds; readonly attribute string Guava; readonly attribute string<25> Mushroom; readonly attribute CORBA::OObject Runnerbean; readonly attribute any Tofu; readonly attribute CORBA::TypeCode Prunes; attribute EggPlant GrannySmith; attribute Plum SweetPotato; attribute Zucchini Billberries; attribute Avocado LolloRossa; attribute Lentil Sweetcorn; readonly attribute EggPlant Shallots; readonly attribute Plum KidneyBean; readonly attribute Zucchini ButterBean; readonly attribute Avocado GoldenDelicous; readonly attribute Lentil CrabApple; attribute long RedOnion, HazelNut, Cinnamon, GooseBerry; attribute EggPlant JuniperBerries, Cloves, Daikan, Mustard; }; polyorb-2.8~20110207.orig/testsuite/idls/types011/0000755000175000017500000000000011750740340020754 5ustar xavierxavierpolyorb-2.8~20110207.orig/testsuite/idls/types011/test.out0000644000175000017500000000010411750740340022457 0ustar xavierxavierLONG := True ALIAS := True STRING := True ULONG := True ANY := True polyorb-2.8~20110207.orig/testsuite/idls/types011/tin.idl0000644000175000017500000000005311750740340022236 0ustar xavierxavierinterface tin { typedef long My_Long; }; polyorb-2.8~20110207.orig/testsuite/idls/test051/0000755000175000017500000000000011750740340020573 5ustar xavierxavierpolyorb-2.8~20110207.orig/testsuite/idls/test051/test.out0000644000175000017500000000052611750740340022306 0ustar xavierxavierunion Broadbeans switch (boolean) { case TRUE : float ButterBean; case FALSE : unsigned long Fennell; }; interface idlServer { exception BroadbeansExcpt { Broadbeans ex1; }; attribute Broadbeans BroadbeansAttr; Broadbeans BroadbeansOp(in Broadbeans p1, out Broadbeans p2, inout Broadbeans p3) raises (idlServer::BroadbeansExcpt); }; polyorb-2.8~20110207.orig/testsuite/idls/vt_m01/0000755000175000017500000000000011750740340020474 5ustar xavierxavierpolyorb-2.8~20110207.orig/testsuite/idls/vt_m01/test.out0000644000175000017500000000133511750740340022206 0ustar xavierxaviervaluetype Val { private short shtMbr; public unsigned short ushtMbr; public long longMbr; private unsigned long ulongMbr; private long long longlongMbr; public unsigned long long ulonglongMbr; public boolean boolMbr; private octet octetMbr; public char charMbr; private wchar wcharMbr; public float floatMbr; private double doubleMbr; public string stringMbr; private wstring wstringMbr; factory create_publ(in unsigned short ushtM, in long longM, in unsigned long long ulonglongM, in boolean boolM, in char charM, in float floatM, in string stringM); factory create_private(in short shtM, in unsigned long ulongM, in long long longlongM, in octet octetM, in wchar wcharM, in double doubleM, in wstring wstringM); }; polyorb-2.8~20110207.orig/testsuite/idls/vt_m01/tin.idl0000644000175000017500000000215611750740340021764 0ustar xavierxavier// IDL-Spec for testgroup: valuetype // Purpose: Data member in a valuetype valuetype Val { //state private short shtMbr; public unsigned short ushtMbr; public long longMbr; private unsigned long ulongMbr; private long long longlongMbr; public unsigned long long ulonglongMbr; public boolean boolMbr; private octet octetMbr; public char charMbr; private wchar wcharMbr; public float floatMbr; private double doubleMbr; public string stringMbr; private wstring wstringMbr; //initializer factory create_publ(in unsigned short ushtM, in long longM, in unsigned long long ulonglongM, in boolean boolM, in char charM, in float floatM, in string stringM); factory create_private(in short shtM, in unsigned long ulongM, in long long longlongM, in octet octetM, in wchar wcharM, in double doubleM, in wstring wstringM); }; polyorb-2.8~20110207.orig/testsuite/idls/idl07040/0000755000175000017500000000000011750740340020531 5ustar xavierxavierpolyorb-2.8~20110207.orig/testsuite/idls/idl07040/test.out0000644000175000017500000000013111750740340022234 0ustar xavierxaviertin.idl:3:03: interface cannot inherit from a forward-declared interface iac: 1 error(s) polyorb-2.8~20110207.orig/testsuite/idls/idl07040/tin.idl0000644000175000017500000000014511750740340022015 0ustar xavierxaviermodule Example { interface base; // Forward declaration interface derived : base {}; // Error }; polyorb-2.8~20110207.orig/testsuite/idls/test050/0000755000175000017500000000000011750740340020572 5ustar xavierxavierpolyorb-2.8~20110207.orig/testsuite/idls/test050/test.out0000644000175000017500000000105311750740340022301 0ustar xavierxavierunion Broadbeans switch (char) { case 'a' : float ButterBean; case 'z' : double Cinnamon; default : long BreadFruit; case '!' : short BambooShoot; case '\000' : unsigned long Fennell; case 'S' : unsigned short Pineapple; case 'R' : char Radish; case 's' : boolean Damsons; case 'E' : octet Mullberry; }; interface idlServer { exception BroadbeansExcpt { Broadbeans ex1; }; attribute Broadbeans BroadbeansAttr; Broadbeans BroadbeansOp(in Broadbeans p1, out Broadbeans p2, inout Broadbeans p3) raises (idlServer::BroadbeansExcpt); }; polyorb-2.8~20110207.orig/testsuite/idls/vb_d01/0000755000175000017500000000000011750740340020441 5ustar xavierxavierpolyorb-2.8~20110207.orig/testsuite/idls/vb_d01/test.out0000644000175000017500000000023311750740340022147 0ustar xavierxaviervaluetype LongValue long; typedef float FloatType; valuetype FloatValue FloatType; enum EnumType { eval1, eval2, eval3 }; valuetype EnumValue EnumType; polyorb-2.8~20110207.orig/testsuite/idls/vb_d01/tin.idl0000644000175000017500000000035511750740340021730 0ustar xavierxavier// IDL-Spec for testgroup: valuetype // Purpose: Value Box for simple types and enums valuetype LongValue long; typedef float FloatType; valuetype FloatValue FloatType; enum EnumType {eval1, eval2, eval3}; valuetype EnumValue EnumType; polyorb-2.8~20110207.orig/testsuite/idls/reserved_words/0000755000175000017500000000000011750740340022423 5ustar xavierxavierpolyorb-2.8~20110207.orig/testsuite/idls/reserved_words/tin.idl0000644000175000017500000000333711750740340023715 0ustar xavierxavier// This test ensures that the IDL to Ada compiler does not generate // code that conflicts with Ada reserved words. // Per the IDL-to-Ada mapping rules, all such words should be prefixed // by "IDL_" module ada_reserved_words { // Here is the list of Ada 2005 reserved key words, per Ada2005 RM, 2.9 // abort else new return // abs elsif not reverse // abstract end null // accept entry select // access exception of separate // aliased exit or subtype // all others synchronized // and for out // array function overriding tagged // at task // generic package terminate // begin goto pragma then // body private type // if procedure // case in protected until // constant interface use // is raise // declare range when // delay limited record while // delta loop rem with // digits renames // do mod requeue xor enum kw {abort, else, new, return, abs, elsif, not, reverse, end, null, accept, entry, select, access, of, separate, aliased, exit, or, subtype, all, others, synchronized, and, for, array, function, overriding, tagged, at, task, generic, package, terminate, begin, goto, pragma, then, body, type, if, procedure, protected, until, constant, use, is, raise, declare, range, when, delay, limited, record, while, delta, loop, rem, with, digits,renames, do, mod, requeue, xor}; // The following are Ada reserved words that are also IDL reserved // words, we prefix them with '_' so that the IDL-to-Ada compiler // accepts these declarations. enum kw2 { _abstract, _exception, _out, _private, _case, _in, _interface}; }; polyorb-2.8~20110207.orig/testsuite/idls/vti_si03/0000755000175000017500000000000011750740340021026 5ustar xavierxavierpolyorb-2.8~20110207.orig/testsuite/idls/vti_si03/test.out0000644000175000017500000000021511750740340022534 0ustar xavierxavierabstract interface AbsItf { short op1(); }; interface Itfderiv : AbsItf { short op2(); }; valuetype Val supports AbsItf { short op3(); }; polyorb-2.8~20110207.orig/testsuite/idls/vti_si03/tin.idl0000644000175000017500000000044511750740340022315 0ustar xavierxavier//testsubgroup a valuetype supporting an interface //tsgdescr "Testing a valuetype supporting (and interface derived from) an abstract interface" abstract interface AbsItf { short op1(); }; interface Itfderiv: AbsItf { short op2(); }; valuetype Val supports AbsItf { short op3(); }; polyorb-2.8~20110207.orig/testsuite/idls/idlac001/0000755000175000017500000000000011750740340020663 5ustar xavierxavierpolyorb-2.8~20110207.orig/testsuite/idls/idlac001/tin.idl0000644000175000017500000000016411750740340022150 0ustar xavierxavierinterface Echo { typedef sequence echoSeq; string echoString (in string Mesg); echoSeq echoers(); }; polyorb-2.8~20110207.orig/testsuite/idls/va_t03/0000755000175000017500000000000011750740340020462 5ustar xavierxavierpolyorb-2.8~20110207.orig/testsuite/idls/va_t03/test.out0000644000175000017500000000054711750740340022200 0ustar xavierxaviervaluetype ShortValue short; struct FixS { long longMbr; }; valuetype FixSvalue FixS; typedef ShortValue TestType; interface Intf { attribute TestType IntfAttr; void op1(in TestType p); }; valuetype BaseVal { typedef FixSvalue TestType; public BaseVal::TestType BaseValMbr; void op2(in BaseVal::TestType p); }; valuetype Val : BaseVal supports Intf { }; polyorb-2.8~20110207.orig/testsuite/idls/va_t03/tin.idl0000644000175000017500000000072011750740340021745 0ustar xavierxavier//testsubgroup typedef_inheritance //tsgdescr "Testing scope of typedef declarations with the valuetype inheritance" valuetype ShortValue short; struct FixS { long longMbr; }; valuetype FixSvalue FixS; typedef ShortValue TestType; interface Intf { attribute TestType IntfAttr; void op1(in TestType p); }; valuetype BaseVal { typedef FixSvalue TestType; public TestType BaseValMbr; void op2(in TestType p); }; valuetype Val:BaseVal supports Intf { }; polyorb-2.8~20110207.orig/testsuite/idls/test040/0000755000175000017500000000000011750740340020571 5ustar xavierxavierpolyorb-2.8~20110207.orig/testsuite/idls/test040/test.out0000644000175000017500000000106011750740340022276 0ustar xavierxavierstruct KidneyBean { long BlackCherry; sequence PassionFruit; }; struct Shallots { struct Aniseed { sequence Tofu; float Apricots; short Guava; } KidneyBean, Brocoli; enum Runnerbean { WhiteCabbage, Mushroom, Tomato, Almonds, Orange } Bayleaf; }; interface idlServer { exception GoldenDelicous { Shallots CantelopeMelon; KidneyBean RowanBerry; }; attribute Shallots Plum; attribute KidneyBean Zucchini; Shallots Avocado(in KidneyBean p1, out KidneyBean p2, inout Shallots p3) raises (idlServer::GoldenDelicous); }; polyorb-2.8~20110207.orig/testsuite/idls/test018/0000755000175000017500000000000011750740340020576 5ustar xavierxavierpolyorb-2.8~20110207.orig/testsuite/idls/test018/test.out0000644000175000017500000000026511750740340022311 0ustar xavierxaviertypedef any Apple; typedef struct Banana { any Orange; any Rhubarb; } PassionFruit; interface idlServer { any Lime(in any p1, out any p2, inout any p3); attribute any Lemon; }; polyorb-2.8~20110207.orig/testsuite/idls/avt_b01/0000755000175000017500000000000011750740340020622 5ustar xavierxavierpolyorb-2.8~20110207.orig/testsuite/idls/avt_b01/test.out0000644000175000017500000000005411750740340022331 0ustar xavierxavierabstract valuetype AbsVal { short op(); }; polyorb-2.8~20110207.orig/testsuite/idls/avt_b01/tin.idl0000644000175000017500000000021311750740340022102 0ustar xavierxavier//testsubgroup basic //tsgdescr "Testing basic features of the abstract valuetype construct" abstract valuetype AbsVal { short op(); }; polyorb-2.8~20110207.orig/testsuite/idls/test029/0000755000175000017500000000000011750740340020600 5ustar xavierxavierpolyorb-2.8~20110207.orig/testsuite/idls/test029/test.out0000644000175000017500000000404311750740340022311 0ustar xavierxaviertypedef sequence, 18>, 13> Scallion; typedef sequence>, 15> KiwanoMelon[11]; typedef sequence>> Celeriac; typedef sequence, 19>> Clementine[12]; typedef sequence>, 6> Record; typedef sequence, 9>, 7> KerrsPinks[4]; typedef sequence, 5>> MarisPiper; typedef sequence>> Banana1[3]; interface idlServer { exception ScallionExcpt { Scallion ex1; }; attribute Scallion ScallionAttr; Scallion ScallionOp(in Scallion p1, out Scallion p2, inout Scallion p3) raises (idlServer::ScallionExcpt); exception KiwanoMelonExcpt { KiwanoMelon ex1; }; attribute KiwanoMelon KiwanoMelonAttr; KiwanoMelon KiwanoMelonOp(in KiwanoMelon p1, out KiwanoMelon p2, inout KiwanoMelon p3) raises (idlServer::KiwanoMelonExcpt); exception CeleriacExcpt { Celeriac ex1; }; attribute Celeriac CeleriacAttr; Celeriac CeleriacOp(in Celeriac p1, out Celeriac p2, inout Celeriac p3) raises (idlServer::CeleriacExcpt); exception ClementineExcpt { Clementine ex1; }; attribute Clementine ClementineAttr; Clementine ClementineOp(in Clementine p1, out Clementine p2, inout Clementine p3) raises (idlServer::ClementineExcpt); exception RecordExcpt { Record ex1; }; attribute Record RecordAttr; Record RecordOp(in Record p1, out Record p2, inout Record p3) raises (idlServer::RecordExcpt); exception KerrsPinksExcpt { KerrsPinks ex1; }; attribute KerrsPinks KerrsPinksAttr; KerrsPinks KerrsPinksOp(in KerrsPinks p1, out KerrsPinks p2, inout KerrsPinks p3) raises (idlServer::KerrsPinksExcpt); exception MarisPiperExcpt { MarisPiper ex1; }; attribute MarisPiper MarisPiperAttr; MarisPiper MarisPiperOp(in MarisPiper p1, out MarisPiper p2, inout MarisPiper p3) raises (idlServer::MarisPiperExcpt); exception Banana1Excpt { Banana1 ex1; }; attribute Banana1 Banana1Attr; Banana1 Banana1Op(in Banana1 p1, out Banana1 p2, inout Banana1 p3) raises (idlServer::Banana1Excpt); }; polyorb-2.8~20110207.orig/testsuite/idls/va_t04/0000755000175000017500000000000011750740340020463 5ustar xavierxavierpolyorb-2.8~20110207.orig/testsuite/idls/va_t04/test.out0000644000175000017500000000061211750740340022172 0ustar xavierxaviermodule M { typedef long TestType1; typedef M::TestType1 TestType2; valuetype ValA { typedef string TestType1; M::ValA::TestType1 op1(in M::TestType2 i); }; valuetype ValB { M::TestType1 op1(in M::TestType2 i); }; }; module N { typedef char TestType1; valuetype ValC : M::ValA { void op2(in M::ValA::TestType1 i); }; valuetype ValD : M::ValB { void op2(in N::TestType1 i); }; }; polyorb-2.8~20110207.orig/testsuite/idls/va_t04/tin.idl0000644000175000017500000000074611750740340021756 0ustar xavierxavier//testsubgroup typedef_inheritance //tsgdescr "Testing scope of typedef declarations with the valuetype inheritance" module M { typedef long TestType1; typedef TestType1 TestType2; valuetype ValA { typedef string TestType1; TestType1 op1(in TestType2 i); }; valuetype ValB { TestType1 op1(in TestType2 i); }; }; module N { typedef char TestType1; valuetype ValC : M::ValA { void op2(in TestType1 i); }; valuetype ValD : M::ValB { void op2(in TestType1 i); }; }; polyorb-2.8~20110207.orig/testsuite/idls/ada0009/0000755000175000017500000000000011750740340020424 5ustar xavierxavierpolyorb-2.8~20110207.orig/testsuite/idls/ada0009/name_clashing.idl0000644000175000017500000000547111750740340023715 0ustar xavierxavier/* Test for the same type (fixed, sequence or bounded string) defined more than one in the same scope. */ module Test_Name_Clashing { typedef fixed<12, 3> fixed_1; typedef fixed<12, 3> fixed_2; typedef fixed<12, 3> fixed_3; typedef fixed<8, 5> fixed_4; typedef fixed<8, 5> fixed_5; typedef fixed<8, 5> fixed_6; typedef sequence unbounded_seq_1; typedef sequence unbounded_seq_2; typedef sequence unbounded_seq_3; typedef sequence unbounded_seq_4; typedef sequence unbounded_seq_5; typedef sequence unbounded_seq_6; typedef sequence bounded_seq_1; typedef sequence bounded_seq_2; typedef sequence bounded_seq_3; typedef sequence bounded_seq_4; typedef sequence bounded_seq_5; typedef sequence bounded_seq_6; typedef string<14> bounded_string_1; typedef string<14> bounded_string_2; typedef string<14> bounded_string_3; typedef string<20> bounded_string_4; typedef string<20> bounded_string_5; typedef string<20> bounded_string_6; typedef wstring<15> bounded_wide_string_1; typedef wstring<15> bounded_wide_string_2; typedef wstring<15> bounded_wide_string_3; typedef wstring<25> bounded_wide_string_4; typedef wstring<25> bounded_wide_string_5; typedef wstring<25> bounded_wide_string_6; /* We redefine the same types inside the interface to verify that the indexes are recomputed. */ interface i { typedef fixed<12, 3> fixed_1; typedef fixed<12, 3> fixed_2; typedef fixed<12, 3> fixed_3; typedef fixed<8, 5> fixed_4; typedef fixed<8, 5> fixed_5; typedef fixed<8, 5> fixed_6; typedef sequence unbounded_seq_1; typedef sequence unbounded_seq_2; typedef sequence unbounded_seq_3; typedef sequence unbounded_seq_4; typedef sequence unbounded_seq_5; typedef sequence unbounded_seq_6; typedef sequence bounded_seq_1; typedef sequence bounded_seq_2; typedef sequence bounded_seq_3; typedef sequence bounded_seq_4; typedef sequence bounded_seq_5; typedef sequence bounded_seq_6; typedef string<14> bounded_string_1; typedef string<14> bounded_string_2; typedef string<14> bounded_string_3; typedef string<20> bounded_string_4; typedef string<20> bounded_string_5; typedef string<20> bounded_string_6; typedef wstring<15> bounded_wide_string_1; typedef wstring<15> bounded_wide_string_2; typedef wstring<15> bounded_wide_string_3; typedef wstring<25> bounded_wide_string_4; typedef wstring<25> bounded_wide_string_5; typedef wstring<25> bounded_wide_string_6; }; }; polyorb-2.8~20110207.orig/testsuite/idls/test053/0000755000175000017500000000000011750740340020575 5ustar xavierxavierpolyorb-2.8~20110207.orig/testsuite/idls/test053/test.out0000644000175000017500000000166211750740340022312 0ustar xavierxaviertypedef long Apple; union Broadbeans switch (Apple) { case 521 : float ButterBean; case 298 : double Cinnamon; case 57 : long BreadFruit; case 2436 : long Tarragon; case 9875 : short BambooShoot; default : short BeechNut; case 7667 : unsigned long Fennell; case 765 : unsigned long Beetroot; case 12 : unsigned short Pineapple; case 98 : unsigned short RedPepper; case 76 : char Radish; case 67 : char Susander; case 75 : boolean Damsons; case 125 : boolean GreenGrapes; case 23 : octet Mullberry; case 72 : octet Corn; }; interface idlServer { exception AppleExcpt { Apple ex1; }; attribute Apple AppleAttr; Apple AppleOp(in Apple p1, out Apple p2, inout Apple p3) raises (idlServer::AppleExcpt); exception BroadbeansExcpt { Broadbeans ex1; }; attribute Broadbeans BroadbeansAttr; Broadbeans BroadbeansOp(in Broadbeans p1, out Broadbeans p2, inout Broadbeans p3) raises (idlServer::BroadbeansExcpt); }; polyorb-2.8~20110207.orig/testsuite/idls/autotest.sh0000755000175000017500000000020511750740340021572 0ustar xavierxavier#!/bin/sh n=0 for i in `grep -v '^#' MANIFEST`; do ./run-test.sh $i if [ $? != 0 ]; then n=`expr $n + 1` fi done exit $n polyorb-2.8~20110207.orig/testsuite/idls/forward03/0000755000175000017500000000000011750740340021175 5ustar xavierxavierpolyorb-2.8~20110207.orig/testsuite/idls/forward03/forward.idl0000644000175000017500000000026511750740340023336 0ustar xavierxavierinterface TestService3 { typedef struct foo { TestService3 myRef; } myStruct; typedef sequence test_services_type; test_services_type getStructs(); }; polyorb-2.8~20110207.orig/testsuite/idls/ada0018/0000755000175000017500000000000011750740340020424 5ustar xavierxavierpolyorb-2.8~20110207.orig/testsuite/idls/ada0018/tin.idl0000644000175000017500000000033111750740340021705 0ustar xavierxaviermodule m1 { typedef boolean b1; interface i1 { typedef float t1; }; interface i2 { attribute i1::t1 attr1; attribute m1::b1 bool; }; interface i3 { typedef i1::t1 new_float; }; }; polyorb-2.8~20110207.orig/testsuite/idls/test049/0000755000175000017500000000000011750740340020602 5ustar xavierxavierpolyorb-2.8~20110207.orig/testsuite/idls/test049/test.out0000644000175000017500000000106011750740340022307 0ustar xavierxavierunion Broadbeans switch (unsigned short) { case 521 : float ButterBean; case 298 : double Cinnamon; case 57 : long BreadFruit; case 9875 : short BambooShoot; case 7667 : unsigned long Fennell; case 12 : unsigned short Pineapple; case 76 : char Radish; case 23 : boolean Damsons; default : octet Mullberry; }; interface idlServer { exception BroadbeansExcpt { Broadbeans ex1; }; attribute Broadbeans BroadbeansAttr; Broadbeans BroadbeansOp(in Broadbeans p1, out Broadbeans p2, inout Broadbeans p3) raises (idlServer::BroadbeansExcpt); }; polyorb-2.8~20110207.orig/testsuite/idls/expansion02/0000755000175000017500000000000011750740340021534 5ustar xavierxavierpolyorb-2.8~20110207.orig/testsuite/idls/expansion02/expansion.idl0000644000175000017500000000013411750740340024230 0ustar xavierxavierinterface test_array { exception e { long f1; short f2[45][21][10]; }; }; polyorb-2.8~20110207.orig/testsuite/idls/ada0016/0000755000175000017500000000000011750740340020422 5ustar xavierxavierpolyorb-2.8~20110207.orig/testsuite/idls/ada0016/tin.idl0000644000175000017500000000017711750740340021713 0ustar xavierxavierinterface i1{ typedef float New_Float, Tab_Float [10]; attribute float val1, val2, tab_val; attribute Tab_Float tab; }; polyorb-2.8~20110207.orig/testsuite/idls/iac001/0000755000175000017500000000000011750740340020343 5ustar xavierxavierpolyorb-2.8~20110207.orig/testsuite/idls/iac001/test.out0000644000175000017500000000026011750740340022051 0ustar xavierxaviertin.idl:2:20: expected token tin.idl:6:05: bad casing of "mylong" declared at line 5 tin.idl:7:28: "thething" conflicts with scoped name at line 7 iac: 3 error(s) polyorb-2.8~20110207.orig/testsuite/idls/iac001/tin.idl0000644000175000017500000000044211750740340021627 0ustar xavierxaviermodule M { typedef long Long; // Error: Long clashes with keyword long typedef long TheThing; interface I { typedef long MyLong; myLong op1( // Error: inconsistent capitalization in TheThing thething // Error: TheThing clashes with thething ); }; }; polyorb-2.8~20110207.orig/testsuite/idls/test054/0000755000175000017500000000000011750740340020576 5ustar xavierxavierpolyorb-2.8~20110207.orig/testsuite/idls/test054/test.out0000644000175000017500000000173711750740340022316 0ustar xavierxavierunion Broadbeans switch (long) { case 521 : struct Avocado { float ButterBean; } Banana; case 45 : struct GalaApple { float ButterBean, ChestNut, Currant, CoxPippin, Chervil, Scallion, Tomato; } Orange; case 72 : octet Corn; }; interface idlServer { exception BroadbeansExcpt { Broadbeans ex1; }; attribute Broadbeans BroadbeansAttr; Broadbeans BroadbeansOp(in Broadbeans p1, out Broadbeans p2, inout Broadbeans p3) raises (idlServer::BroadbeansExcpt); exception AvocadoExcpt { Broadbeans::Avocado ex1; }; attribute Broadbeans::Avocado AvocadoAttr; Broadbeans::Avocado AvocadoOp(in Broadbeans::Avocado p1, out Broadbeans::Avocado p2, inout Broadbeans::Avocado p3) raises (idlServer::AvocadoExcpt); exception GalaAppleExcpt { Broadbeans::GalaApple ex1; }; attribute Broadbeans::GalaApple GalaAppleAttr; Broadbeans::GalaApple GalaAppleOp(in Broadbeans::GalaApple p1, out Broadbeans::GalaApple p2, inout Broadbeans::GalaApple p3) raises (idlServer::GalaAppleExcpt); }; polyorb-2.8~20110207.orig/testsuite/idls/idl15024/0000755000175000017500000000000011750740340020532 5ustar xavierxavierpolyorb-2.8~20110207.orig/testsuite/idls/idl15024/test.out0000644000175000017500000000031311750740340022237 0ustar xavierxaviertin.idl:3:15: "E3" conflicts with declaration at line 2 tin.idl:12:10: multiple declarations of "E2" tin.idl:12:10: found declaration at line 2 tin.idl:12:10: found declaration at line 7 iac: 2 error(s) polyorb-2.8~20110207.orig/testsuite/idls/idl15024/tin.idl0000644000175000017500000000066711750740340022027 0ustar xavierxavierinterface A { enum E { E1, E2, E3 }; // line 1 enum BadE { E3, E4, E5 }; // Error: E3 is already introduced // into the A scope in line 1 above }; interface C { enum AnotherE { E1, E2, E3 }; }; interface D : C, A { union U switch ( E ) { case A::E1 : boolean b;// OK. case E2 : long l; // Error: E2 is ambiguous (notwithstanding // the switch type specification!!) }; }; polyorb-2.8~20110207.orig/testsuite/idls/vt_e01/0000755000175000017500000000000011750740340020464 5ustar xavierxavierpolyorb-2.8~20110207.orig/testsuite/idls/vt_e01/test.out0000644000175000017500000000031411750740340022172 0ustar xavierxaviervaluetype Val { public short ShortMbr; exception ValExcpt { Val ex1; }; Val op1() raises (Val::ValExcpt); }; interface Inf { exception ValExcpt { Val ex1; }; Val op2() raises (Inf::ValExcpt); }; polyorb-2.8~20110207.orig/testsuite/idls/vt_e01/tin.idl0000644000175000017500000000044511750740340021753 0ustar xavierxavier// IDL-Spec for testgroup: valuetype // Purpose: Valuetype as member in an exception, valuetype Val { public short ShortMbr; exception ValExcpt { Val ex1; }; Val op1() raises(ValExcpt); }; interface Inf { exception ValExcpt { Val ex1; }; Val op2() raises(ValExcpt); }; polyorb-2.8~20110207.orig/testsuite/idls/test008/0000755000175000017500000000000011750740340020575 5ustar xavierxavierpolyorb-2.8~20110207.orig/testsuite/idls/test008/test.out0000644000175000017500000000047111750740340022307 0ustar xavierxaviertypedef float Apple; typedef double Carrots; typedef long BlackCherry; typedef short Rhubarb; interface idlServer { typedef unsigned long Pumpkin; typedef unsigned short WaterMelon; typedef char Dates; typedef boolean Lychees; Apple GardenPeas(in Apple p1, out BlackCherry p2, inout idlServer::Dates p3); }; polyorb-2.8~20110207.orig/testsuite/idls/vb_b01/0000755000175000017500000000000011750740340020437 5ustar xavierxavierpolyorb-2.8~20110207.orig/testsuite/idls/vb_b01/test.out0000644000175000017500000000003411750740340022144 0ustar xavierxaviervaluetype ShortValue short; polyorb-2.8~20110207.orig/testsuite/idls/vb_b01/tin.idl0000644000175000017500000000015211750740340021721 0ustar xavierxavier// IDL-Spec for testgroup: valuetype // Purpose: basic features of valuetype valuetype ShortValue short; polyorb-2.8~20110207.orig/testsuite/idls/types008/0000755000175000017500000000000011750740340020762 5ustar xavierxavierpolyorb-2.8~20110207.orig/testsuite/idls/types008/test.out0000644000175000017500000000007011750740340022467 0ustar xavierxavierNATIVE := True STRING := True ULONG := True ANY := True polyorb-2.8~20110207.orig/testsuite/idls/types008/tin.idl0000644000175000017500000000004511750740340022245 0ustar xavierxavierinterface tin { native hello; }; polyorb-2.8~20110207.orig/testsuite/idls/test043/0000755000175000017500000000000011750740340020574 5ustar xavierxavierpolyorb-2.8~20110207.orig/testsuite/idls/test043/test.out0000644000175000017500000000140511750740340022304 0ustar xavierxaviertypedef struct Avocado { float ButterBean; float Fig[3]; double Cinnamon; double Cloves[3]; long BreadFruit; long Tarragon[3]; short BambooShoot; short BeechNut[3]; unsigned long Fennell; unsigned long Beetroot[3]; unsigned short Pineapple; unsigned short RedPepper[3]; char Radish; char Susander[3]; boolean Damsons; boolean GreenGrapes[3]; octet Mullberry; octet Corn[3]; } Banana; interface idlServer { exception BananaExcpt { Banana ex1; }; attribute Banana BananaAttr; Banana BananaOp(in Banana p1, out Banana p2, inout Banana p3) raises (idlServer::BananaExcpt); exception AvocadoExcpt { Avocado ex1; }; attribute Avocado AvocadoAttr; Avocado AvocadoOp(in Avocado p1, out Avocado p2, inout Avocado p3) raises (idlServer::AvocadoExcpt); }; polyorb-2.8~20110207.orig/testsuite/idls/test016/0000755000175000017500000000000011750740340020574 5ustar xavierxavierpolyorb-2.8~20110207.orig/testsuite/idls/test016/test.out0000644000175000017500000000153111750740340022304 0ustar xavierxavierinterface idlServer { void Bayleaf(); float BlackCherry(in float p1, out float p2, inout float p3); double Starfruit(in double p1, out double p2, inout double p3); long Rhubarb(in long p1, out long p2, inout long p3); short PassionFruit(in short p1, out short p2, inout short p3); unsigned long Pumpkin(in unsigned long p1, out unsigned long p2, inout unsigned long p3); unsigned short Mango(in unsigned short p1, out unsigned short p2, inout unsigned short p3); char WaterMelon(in char p1, out char p2, inout char p3); boolean Lime(in boolean p1, out boolean p2, inout boolean p3); octet Dates(in octet p1, out octet p2, inout octet p3); Object Coconut(in Object p1, out Object p2, inout Object p3); string Lychees(in string p1, out string p2, inout string p3); string<20> Cabbage(in string<23> p1, out string<38> p2, inout string<44> p3); }; polyorb-2.8~20110207.orig/testsuite/idls/forward02/0000755000175000017500000000000011750740340021174 5ustar xavierxavierpolyorb-2.8~20110207.orig/testsuite/idls/forward02/forward.idl0000644000175000017500000000016711750740340023336 0ustar xavierxavierinterface TestService { typedef sequence test_services_type; test_services_type getChildren(); }; polyorb-2.8~20110207.orig/testsuite/idls/idl02030/0000755000175000017500000000000011750740340020523 5ustar xavierxavierpolyorb-2.8~20110207.orig/testsuite/idls/idl02030/test.out0000644000175000017500000000025611750740340022236 0ustar xavierxaviertin.idl:8:29: expected token tin.idl:4:13: "thing" conflicts with declaration at line 3 tin.idl:6:14: "foo" conflicts with scoped name at line 6 iac: 3 error(s) polyorb-2.8~20110207.orig/testsuite/idls/idl02030/tin.idl0000644000175000017500000000047211750740340022012 0ustar xavierxaviermodule M { typedef long Foo; const long thing = 1; interface thing { // error: reuse of identifier void doit ( in Foo foo // error: Foo and foo collide and refer to different things ); readonly attribute long Attribute; // error: Attribute collides with keyword attribute }; }; polyorb-2.8~20110207.orig/testsuite/idls/types007/0000755000175000017500000000000011750740340020761 5ustar xavierxavierpolyorb-2.8~20110207.orig/testsuite/idls/types007/test.out0000644000175000017500000000023711750740340022473 0ustar xavierxavierSTRUCT := True STRING := True ULONG := True FIXED := True USHORT := True SHORT := True SEQUENCE := True WSTRING := True CHAR := True ALIAS := True ANY := True polyorb-2.8~20110207.orig/testsuite/idls/types007/tin.idl0000644000175000017500000000017711750740340022252 0ustar xavierxavierinterface tin { struct example { fixed<12,5> fixedMember; sequence Seq; }; typedef char character; }; polyorb-2.8~20110207.orig/testsuite/idls/ada0020/0000755000175000017500000000000011750740340020415 5ustar xavierxavierpolyorb-2.8~20110207.orig/testsuite/idls/ada0020/tin.idl0000644000175000017500000000020611750740340021677 0ustar xavierxaviermodule m { interface i1 { typedef string t; }; interface i2 { typedef i1::t t; typedef t toto; }; }; polyorb-2.8~20110207.orig/testsuite/idls/test038/0000755000175000017500000000000011750740340020600 5ustar xavierxavierpolyorb-2.8~20110207.orig/testsuite/idls/test038/test.out0000644000175000017500000001012511750740340022307 0ustar xavierxaviertypedef struct GooseBerry138 { struct HazelNut138 { struct Onion138 { struct RowanBerry138 { sequence LolloRossa138; } Sweetcorn138; } RedOnion138[18]; } Cinnamon138; } EggPlant138; typedef struct GooseBerry139 { struct HazelNut139 { struct CrabApple139 { struct Lentil139 { sequence GoldenDelicous139; } Fig139; } RedOnion139; } Cinnamon139; } EggPlant139; typedef struct CrabApple140 { struct Lentil140 { struct CantelopeMelon140 { struct Sultana140 { sequence GaliaMelon140[13]; } Billberries140[15]; } GoldenDelicous140[11]; } Fig140; } RedOnion140; typedef struct CrabApple141 { struct Lentil141 { struct Avocado141 { struct Oregano141 { sequence Dill141[10]; } ButterBean141[19]; } GoldenDelicous141; } Fig141; } RedOnion141; typedef struct Lentil142 { struct Avocado142 { struct Tangarine142 { struct BrazilNut142 { sequence GrannySmith142[6]; } SweetPotato142; } ButterBean142[9]; } GoldenDelicous142; } Fig142; typedef struct Lentil143 { struct Avocado143 { struct Zucchini143 { struct Plum143 { sequence Shallots143[4]; } KidneyBean143; } ButterBean143; } GoldenDelicous143; } Fig143; typedef struct Zucchini144 { struct Plum144 { struct Brocoli144 { struct BlackEyedBeans144 { sequence Apricots144; } Prunes144[5]; } Shallots144[3]; } KidneyBean144; } ButterBean144; interface idlServer { exception EggPlant138Excpt { EggPlant138 ex1; }; attribute EggPlant138 EggPlant138Attr; EggPlant138 EggPlant138Op(in EggPlant138 p1, out EggPlant138 p2, inout EggPlant138 p3) raises (idlServer::EggPlant138Excpt); exception GooseBerry138Excpt { GooseBerry138 ex1; }; attribute GooseBerry138 GooseBerry138Attr; GooseBerry138 GooseBerry138Op(in GooseBerry138 p1, out GooseBerry138 p2, inout GooseBerry138 p3) raises (idlServer::GooseBerry138Excpt); exception HazelNut138Excpt { GooseBerry138::HazelNut138 ex1; }; attribute GooseBerry138::HazelNut138 HazelNut138Attr; GooseBerry138::HazelNut138 HazelNut138Op(in GooseBerry138::HazelNut138 p1, out GooseBerry138::HazelNut138 p2, inout GooseBerry138::HazelNut138 p3) raises (idlServer::HazelNut138Excpt); exception Onion138Excpt { GooseBerry138::HazelNut138::Onion138 ex1; }; attribute GooseBerry138::HazelNut138::Onion138 Onion138Attr; GooseBerry138::HazelNut138::Onion138 Onion138Op(in GooseBerry138::HazelNut138::Onion138 p1, out GooseBerry138::HazelNut138::Onion138 p2, inout GooseBerry138::HazelNut138::Onion138 p3) raises (idlServer::Onion138Excpt); exception RowanBerry138Excpt { GooseBerry138::HazelNut138::Onion138::RowanBerry138 ex1; }; attribute GooseBerry138::HazelNut138::Onion138::RowanBerry138 RowanBerry138Attr; GooseBerry138::HazelNut138::Onion138::RowanBerry138 RowanBerry138Op(in GooseBerry138::HazelNut138::Onion138::RowanBerry138 p1, out GooseBerry138::HazelNut138::Onion138::RowanBerry138 p2, inout GooseBerry138::HazelNut138::Onion138::RowanBerry138 p3) raises (idlServer::RowanBerry138Excpt); exception EggPlant139Excpt { EggPlant139 ex1; }; attribute EggPlant139 EggPlant139Attr; EggPlant139 EggPlant139Op(in EggPlant139 p1, out EggPlant139 p2, inout EggPlant139 p3) raises (idlServer::EggPlant139Excpt); exception GooseBerry139Excpt { GooseBerry139 ex1; }; attribute GooseBerry139 GooseBerry139Attr; GooseBerry139 GooseBerry139Op(in GooseBerry139 p1, out GooseBerry139 p2, inout GooseBerry139 p3) raises (idlServer::GooseBerry139Excpt); exception HazelNut139Excpt { GooseBerry139::HazelNut139 ex1; }; attribute GooseBerry139::HazelNut139 HazelNut139Attr; GooseBerry139::HazelNut139 HazelNut139Op(in GooseBerry139::HazelNut139 p1, out GooseBerry139::HazelNut139 p2, inout GooseBerry139::HazelNut139 p3) raises (idlServer::HazelNut139Excpt); exception CrabApple139Excpt { GooseBerry139::HazelNut139::CrabApple139 ex1; }; attribute GooseBerry139::HazelNut139::CrabApple139 CrabApple139Attr; GooseBerry139::HazelNut139::CrabApple139 CrabApple139Op(in GooseBerry139::HazelNut139::CrabApple139 p1, out GooseBerry139::HazelNut139::CrabApple139 p2, inout GooseBerry139::HazelNut139::CrabApple139 p3) raises (idlServer::CrabApple139Excpt); }; polyorb-2.8~20110207.orig/testsuite/idls/test035/0000755000175000017500000000000011750740340020575 5ustar xavierxavierpolyorb-2.8~20110207.orig/testsuite/idls/test035/test.out0000644000175000017500000001312011750740340022302 0ustar xavierxaviertypedef struct Pimpernel66 { struct KerrsPinks66 { struct Wilja66 { sequence, 18> BritishQueens66; } Balmoral66; } GoldenWonder66; } Cultra66; typedef struct ChineseLeaves67 { struct Clementine67 { struct Chestnut67 { sequence> Currant67[15]; } Corriander67[11]; } RedCabbage67; } Broadbeans67; typedef struct RedChilly68 { struct Chayato68 { struct KiwanoMelon68 { sequence> IcebergLettuce68[10]; } Tomato68; } PippinApple68; } Celeriac68; typedef struct VineTomatoes69 { struct Chervil69 { struct GreenChilly69 { sequence, 19>> Yam69; } Blackberry69[12]; } GreenPepper69; } Scallion69; typedef struct Satsuma70 { struct Parsley70 { struct Peach70 { sequence, 9>> Corn70; } Squash70; } YellowPepper70; } Peanuts70; typedef struct Chives71 { struct Rasin71 { struct Cherry71 { sequence>, 7> Radish71[4]; } GreenGrapes71[2]; } CookingApple71; } Mullberry71; typedef struct PepinoMelon72 { struct Raspberry72 { struct Peppercorn72 { sequence>, 3> Papaya72[9]; } Susander72; } Grapefruit72; } Damsons72; typedef struct BeefTomatoes73 { struct Pear73 { struct Walnuts73 { sequence>, 3> Kumquats73; } Mangosteen73[17]; } RedPepper73; } FrenchBeans73; typedef struct Okra74 { struct Chickpea74 { struct Uglifruit74 { sequence>, 6> Fennell74; } Waterchestnut74; } Beetroot74; } Plantain74; typedef struct RedGrapes75 { struct Cassava75 { struct Daikan75 { sequence>> Cloves75[18]; } BambooShoot75[15]; } Melon75; } BeechNut75; typedef struct Pomegranate76 { struct Thyme76 { struct Strawberry76 { sequence>> Mustard76[7]; } BreadFruit76; } Sweedes76; } Tarragon76; typedef struct GooseBerry77 { struct HazelNut77 { struct Onion77 { sequence>> Sweetcorn77; } RedOnion77[14]; } Cinnamon77; } EggPlant77; typedef struct Avocado78 { struct Zucchini78 { struct Plum78 { sequence>> Shallots78; } KidneyBean78; } ButterBean78; } GoldenDelicous78; typedef struct CantelopeMelon79 { struct Tangarine79 { struct Oregano79 { sequence, 2>, 16> Dill79[4]; } SweetPotato79[5]; } Billberries79; } LolloRossa79; typedef struct Tofu80 { struct Mushroom80 { struct Almonds80 { sequence, 14>, 2> Beansprout80[11]; } Guava80; } Runnerbean80; } Prunes80; typedef struct WhiteCabbage81 { struct Parsnip81 { struct Ginger81 { sequence, 14>, 13> Cucumber81; } LoganBerry81[1]; } Celery81; } Aniseed81; typedef struct Asparagus82 { struct Mint82 { struct BlackEyedBeans82 { sequence, 16>, 8> Apricots82; } Leek82; } GardenPeas82; } GaliaMelon82; typedef struct Coconut83 { struct Lime83 { struct PentlandDell82 { sequence, 5>> KingEdward82[3]; } WaterMelon83[7]; } Dates83; } Lychees83; typedef struct Starfruit84 { struct Lemon84 { struct Banana84 { sequence, 6>> Apple84[5]; } Carrots84; } BlackCherry84; } Rhubarb84; typedef struct Rooster84 { struct Pimpernel84 { struct Clementine84 { sequence, 2>> Corriander84; } GoldenWonder84[14]; } Cultra84; } MarisPiper84; typedef struct Homeguard85 { struct Potato85 { struct ChineseLeaves85 { sequence, 13>> RedCabbage85; } Broadbeans85; } Record85; } BritishQueens85; typedef struct GalaApple86 { struct RedChilly86 { struct Chervil86 { sequence>, 4> Blackberry86[3]; } PippinApple86[2]; } Celeriac86; } Cauliflower86; typedef struct Chestnut87 { struct PricklyPear87 { struct VineTomatoes87 { sequence>>, 18> GreenPepper87[2]; } Scallion87; } Currant87; } IcebergLettuce87; typedef struct Basil88 { struct Satsuma88 { struct Rasin88 { sequence, 7>>, 17> GreenGrapes88; } YellowPepper88[5]; } Peanuts88; } CoxPippin88; typedef struct GreenChilly89 { struct Eddo89 { struct Chives89 { sequence>>, 3> CookingApple89; } Mullberry89; } Yam89; } Corn89; interface idlServer { exception Cultra66Excpt { Cultra66 ex1; }; attribute Cultra66 Cultra66Attr; Cultra66 Cultra66Op(in Cultra66 p1, out Cultra66 p2, inout Cultra66 p3) raises (idlServer::Cultra66Excpt); exception Pimpernel66Excpt { Pimpernel66 ex1; }; attribute Pimpernel66 Pimpernel66Attr; Pimpernel66 Pimpernel66Op(in Pimpernel66 p1, out Pimpernel66 p2, inout Pimpernel66 p3) raises (idlServer::Pimpernel66Excpt); exception KerrsPinks66Excpt { Pimpernel66::KerrsPinks66 ex1; }; attribute Pimpernel66::KerrsPinks66 KerrsPinks66Attr; Pimpernel66::KerrsPinks66 KerrsPinks66Op(in Pimpernel66::KerrsPinks66 p1, out Pimpernel66::KerrsPinks66 p2, inout Pimpernel66::KerrsPinks66 p3) raises (idlServer::KerrsPinks66Excpt); exception Wilja66Excpt { Pimpernel66::KerrsPinks66::Wilja66 ex1; }; attribute Pimpernel66::KerrsPinks66::Wilja66 Wilja66Attr; Pimpernel66::KerrsPinks66::Wilja66 Wilja66Op(in Pimpernel66::KerrsPinks66::Wilja66 p1, out Pimpernel66::KerrsPinks66::Wilja66 p2, inout Pimpernel66::KerrsPinks66::Wilja66 p3) raises (idlServer::Wilja66Excpt); exception Broadbeans67Excpt { Broadbeans67 ex1; }; attribute Broadbeans67 Broadbeans67Attr; Broadbeans67 Broadbeans67Op(in Broadbeans67 p1, out Broadbeans67 p2, inout Broadbeans67 p3) raises (idlServer::Broadbeans67Excpt); }; polyorb-2.8~20110207.orig/testsuite/idls/test031/0000755000175000017500000000000011750740340020571 5ustar xavierxavierpolyorb-2.8~20110207.orig/testsuite/idls/test031/test.out0000644000175000017500000001020211750740340022274 0ustar xavierxaviertypedef sequence, 18>>, 18> Parsnip2[13]; typedef sequence, 11>>> Prunes2; typedef sequence>, 7>> Plum2[10]; typedef sequence>>, 12> EggPlant2; typedef sequence>, 9>, 7> Mustard2; typedef sequence>, 4>> Elderberry2[2]; typedef sequence>, 3>> RedPepper2; typedef sequence>>, 9> Artichokes2[3]; typedef sequence, 6>, 6>, 18> KiwanoMelon2[15]; typedef sequence>>> BritishQueens2; typedef sequence>>> Starfruit3[7]; typedef sequence, 11>>> Parsnip3[5]; typedef sequence, 16>> Billberries3; typedef sequence, 5>, 14>, 2> GooseBerry3[11]; typedef sequence Elderberry3[14]; interface idlServer { exception Parsnip2Excpt { Parsnip2 ex1; }; attribute Parsnip2 Parsnip2Attr; Parsnip2 Parsnip2Op(in Parsnip2 p1, out Parsnip2 p2, inout Parsnip2 p3) raises (idlServer::Parsnip2Excpt); exception Prunes2Excpt { Prunes2 ex1; }; attribute Prunes2 Prunes2Attr; Prunes2 Prunes2Op(in Prunes2 p1, out Prunes2 p2, inout Prunes2 p3) raises (idlServer::Prunes2Excpt); exception Plum2Excpt { Plum2 ex1; }; attribute Plum2 Plum2Attr; Plum2 Plum2Op(in Plum2 p1, out Plum2 p2, inout Plum2 p3) raises (idlServer::Plum2Excpt); exception EggPlant2Excpt { EggPlant2 ex1; }; attribute EggPlant2 EggPlant2Attr; EggPlant2 EggPlant2Op(in EggPlant2 p1, out EggPlant2 p2, inout EggPlant2 p3) raises (idlServer::EggPlant2Excpt); exception Mustard2Excpt { Mustard2 ex1; }; attribute Mustard2 Mustard2Attr; Mustard2 Mustard2Op(in Mustard2 p1, out Mustard2 p2, inout Mustard2 p3) raises (idlServer::Mustard2Excpt); exception Elderberry2Excpt { Elderberry2 ex1; }; attribute Elderberry2 Elderberry2Attr; Elderberry2 Elderberry2Op(in Elderberry2 p1, out Elderberry2 p2, inout Elderberry2 p3) raises (idlServer::Elderberry2Excpt); exception RedPepper2Excpt { RedPepper2 ex1; }; attribute RedPepper2 RedPepper2Attr; RedPepper2 RedPepper2Op(in RedPepper2 p1, out RedPepper2 p2, inout RedPepper2 p3) raises (idlServer::RedPepper2Excpt); exception Artichokes2Excpt { Artichokes2 ex1; }; attribute Artichokes2 Artichokes2Attr; Artichokes2 Artichokes2Op(in Artichokes2 p1, out Artichokes2 p2, inout Artichokes2 p3) raises (idlServer::Artichokes2Excpt); exception KiwanoMelon2Excpt { KiwanoMelon2 ex1; }; attribute KiwanoMelon2 KiwanoMelon2Attr; KiwanoMelon2 KiwanoMelon2Op(in KiwanoMelon2 p1, out KiwanoMelon2 p2, inout KiwanoMelon2 p3) raises (idlServer::KiwanoMelon2Excpt); exception BritishQueens2Excpt { BritishQueens2 ex1; }; attribute BritishQueens2 BritishQueens2Attr; BritishQueens2 BritishQueens2Op(in BritishQueens2 p1, out BritishQueens2 p2, inout BritishQueens2 p3) raises (idlServer::BritishQueens2Excpt); exception Starfruit3Excpt { Starfruit3 ex1; }; attribute Starfruit3 Starfruit3Attr; Starfruit3 Starfruit3Op(in Starfruit3 p1, out Starfruit3 p2, inout Starfruit3 p3) raises (idlServer::Starfruit3Excpt); exception Parsnip3Excpt { Parsnip3 ex1; }; attribute Parsnip3 Parsnip3Attr; Parsnip3 Parsnip3Op(in Parsnip3 p1, out Parsnip3 p2, inout Parsnip3 p3) raises (idlServer::Parsnip3Excpt); exception Billberries3Excpt { Billberries3 ex1; }; attribute Billberries3 Billberries3Attr; Billberries3 Billberries3Op(in Billberries3 p1, out Billberries3 p2, inout Billberries3 p3) raises (idlServer::Billberries3Excpt); exception GooseBerry3Excpt { GooseBerry3 ex1; }; attribute GooseBerry3 GooseBerry3Attr; GooseBerry3 GooseBerry3Op(in GooseBerry3 p1, out GooseBerry3 p2, inout GooseBerry3 p3) raises (idlServer::GooseBerry3Excpt); exception Elderberry3Excpt { Elderberry3 ex1; }; attribute Elderberry3 Elderberry3Attr; Elderberry3 Elderberry3Op(in Elderberry3 p1, out Elderberry3 p2, inout Elderberry3 p3) raises (idlServer::Elderberry3Excpt); }; polyorb-2.8~20110207.orig/testsuite/idls/chicken-egg/0000755000175000017500000000000011750740340021532 5ustar xavierxavierpolyorb-2.8~20110207.orig/testsuite/idls/chicken-egg/chicken.idl0000644000175000017500000000016211750740340023627 0ustar xavierxavier#ifndef CHICKEN #define CHICKEN interface Chicken; #include "egg.idl" interface Chicken { Egg lay(); }; #endif polyorb-2.8~20110207.orig/testsuite/idls/chicken-egg/egg.idl0000644000175000017500000000015611750740340022770 0ustar xavierxavier#ifndef EGG #define EGG interface Egg; #include "chicken.idl" interface Egg { Chicken hatch(); }; #endif polyorb-2.8~20110207.orig/testsuite/idls/inherit003/0000755000175000017500000000000011750740340021253 5ustar xavierxavierpolyorb-2.8~20110207.orig/testsuite/idls/inherit003/tin.idl0000644000175000017500000000075511750740340022546 0ustar xavierxaviermodule m { interface int1 { short op1(); attribute long attr1, attr11; typedef string myType1; const long myConstant1 = 1; exception myException1 {}; struct myStruct1 { long a; short b; }; union myUnion1 switch (long) { case 1: case 3: long counter; case 2: boolean flag; default: long unknown; }; enum Color {Red, Green, Blue}; }; interface int2 : int1{ short op2(); attribute long attr2, attr22; }; }; polyorb-2.8~20110207.orig/testsuite/idls/inherit005/0000755000175000017500000000000011750740340021255 5ustar xavierxavierpolyorb-2.8~20110207.orig/testsuite/idls/inherit005/tin.idl0000644000175000017500000000607711750740340022553 0ustar xavierxaviermodule m { interface int1 { short op1(); attribute long attr1, attr11; typedef string myType1; const long myConstant1 = 1; exception myException1 {}; struct myStruct1 { long a; short b; }; union myUnion1 switch (long) { case 1: case 3: long counter; case 2: boolean flag; default: long unknown; }; enum Color {Red, Green, Blue}; }; interface int2 { short op2(); attribute long attr2, attr22; typedef string myType2; const long myConstant2 = 2; exception myException2 {}; struct myStruct2 { long e; short f; }; union myUnion2 switch (long) { case 1: long counter; case 2: boolean flag; case 4: string name; default: long unknown; }; enum Week {Monday, Tuesday, Wednesday, Thursday, Friday, Saturday, Sunday}; }; interface int3 : int1, int2 { short op3(); attribute long attr3, attr33; typedef string myType3; const long myConstant3 = 3; exception myException3 {}; }; interface int4 { short op4(); attribute long attr4, attr44; typedef string myType4; const long myConstant4 = 4; exception myException4 {}; }; interface int5 { short op5(); attribute long attr5; typedef string myType5; const long myConstant5 = 5; exception myException5 {}; }; interface int6 : int4, int5 { short op6(); attribute long attr6, attr66; typedef string myType6; const long myConstant6 = 6; exception myException6 {}; }; interface int7 : int3, int6 { short op7(); attribute long attr7, attr77; typedef string myType7; const long myConstant7 = 7; exception myException7 {}; }; interface int8 : int2 { short op8(); attribute long attr8, attr88; typedef string myType8; const long myConstant8 = 8; exception myException8 {}; }; interface int9 : int6 { short op9(); attribute long attr9, attr99; typedef string myType9; const long myConstant9 = 9; exception myException9 {}; }; interface int10 : int1, int9, int8 { short op10(); // The type myType1 is redefined, so, no subtype shall be generated typedef string myType1000, myType1; // The constant myConstant2 is redefined, so, no renaming constant shall // be generated const short myConstant2 = 10; // The exception myException5 is redefined, so, no renaming exception shall // be generated exception myException5 {long data;}; // The three followin entities are redefined, so, no subtypes shall be // generated. struct myStruct1 { long C; short D; }; union myUnion1 switch (short) { case 1: short counter; case 2: case 3: string name; default: long unknown; }; enum Color {Yellow, White, Black}; attribute long attr10, attr100; typedef string myType10; const long myConstant10 = 10; exception myException10 {}; // The entities myStruct2, myUnion2, and Week are not redefined, so, // subtypes must be generated }; }; polyorb-2.8~20110207.orig/testsuite/idls/va_f01/0000755000175000017500000000000011750740340020442 5ustar xavierxavierpolyorb-2.8~20110207.orig/testsuite/idls/va_f01/test.out0000644000175000017500000000013411750740340022150 0ustar xavierxaviervaluetype AVal; valuetype BVal { public AVal Mbr; }; valuetype AVal { public BVal Mbr; }; polyorb-2.8~20110207.orig/testsuite/idls/va_f01/tin.idl0000644000175000017500000000027411750740340021731 0ustar xavierxavier//testsubgroup forward //tsgdescr "Testing forward declaration for the valuetype construct" valuetype AVal; valuetype BVal { public AVal Mbr; }; valuetype AVal { public BVal Mbr; }; polyorb-2.8~20110207.orig/testsuite/idls/vb_p02/0000755000175000017500000000000011750740340020456 5ustar xavierxavierpolyorb-2.8~20110207.orig/testsuite/idls/vb_p02/test.out0000644000175000017500000000156111750740340022171 0ustar xavierxavierenum EnumType { eval1, eval2, eval3 }; valuetype EnumValue EnumType; struct VarS { string strMbr; }; valuetype VarSValue VarS; struct FixS { long longMbr; short shortMbr; }; valuetype FixSValue FixS; typedef long LongArray[2][3]; valuetype ArrayValue LongArray; valuetype StringValue string; interface Intf { attribute EnumValue EnumAttr; attribute VarSValue VarSAttr; attribute FixSValue FixSAttr; attribute ArrayValue ArrayAttr; attribute StringValue StringAttr; EnumValue op1(in EnumValue inp, inout EnumValue inoutp, out EnumValue outp); VarSValue op2(in VarSValue inp, inout VarSValue inoutp, out VarSValue outp); FixSValue op3(in FixSValue inp, inout FixSValue inoutp, out FixSValue outp); ArrayValue op4(in ArrayValue inp, inout ArrayValue inoutp, out ArrayValue outp); StringValue op5(in StringValue inp, inout StringValue inoutp, out StringValue outp); }; polyorb-2.8~20110207.orig/testsuite/idls/vb_p02/tin.idl0000644000175000017500000000171211750740340021743 0ustar xavierxavier// IDL-Spec for testgroup: valuetype // Purpose: basic features of valuetype enum EnumType {eval1, eval2, eval3}; valuetype EnumValue EnumType; struct VarS { string strMbr; }; valuetype VarSValue VarS; struct FixS { long longMbr; short shortMbr; }; valuetype FixSValue FixS; typedef long LongArray[2][3]; valuetype ArrayValue LongArray; valuetype StringValue string; interface Intf { attribute EnumValue EnumAttr; attribute VarSValue VarSAttr; attribute FixSValue FixSAttr; attribute ArrayValue ArrayAttr; attribute StringValue StringAttr; EnumValue op1(in EnumValue inp,inout EnumValue inoutp,out EnumValue outp); VarSValue op2(in VarSValue inp,inout VarSValue inoutp,out VarSValue outp); FixSValue op3(in FixSValue inp,inout FixSValue inoutp,out FixSValue outp); ArrayValue op4(in ArrayValue inp,inout ArrayValue inoutp,out ArrayValue outp); StringValue op5(in StringValue inp,inout StringValue inoutp,out StringValue outp); }; polyorb-2.8~20110207.orig/testsuite/idls/test019/0000755000175000017500000000000011750740340020577 5ustar xavierxavierpolyorb-2.8~20110207.orig/testsuite/idls/test019/test.out0000644000175000017500000000276511750740340022321 0ustar xavierxavierenum Sweetcorn { Banana, Carrots, Lemon, BlackCherry, Starfruit, Rhubarb }; exception Mangetout { }; exception Cress { unsigned long Plum; }; exception BambooShoot { float Plum; double KidneyBean; long Zucchini; unsigned long ButterBean; short Avocado; unsigned short GoldenDelicous; char Lentil; boolean Fig; octet CrabApple; string RedOnion; string<23> HazelNut; Object Cinnamon; any GooseBerry; }; typedef struct Guava { float Sultana; } Runnerbean; union BrazilNut switch (long) { case 23 : Runnerbean Parsnip; case -25 : long Celery; default : short WhiteCabbage; }; exception Cassava { Guava Oregano; Runnerbean Almonds; Guava Mushroom[3]; Runnerbean Tofu[1]; }; exception Melon { BrazilNut SweetPotato; BrazilNut Orange[2]; sequence Tangarine; sequence GardenPeas[4]; sequence CantelopeMelon; Sweetcorn Apple; Sweetcorn Onion[5]; }; interface idlServer { exception RedGrapes { float Plum[34]; double KidneyBean[12]; long Zucchini[3]; unsigned long ButterBean[6]; short Avocado[1]; unsigned short GoldenDelicous[32]; char Lentil[9]; boolean Fig[2]; octet CrabApple[13]; string RedOnion[2]; string<15> HazelNut[1]; Object Cinnamon[6]; any GooseBerry[2]; }; void JuniperBerries(in long p1, out Sweetcorn p2, inout octet p3) raises (Mangetout); void Daikan() raises (Cress, idlServer::RedGrapes); void Thyme() raises (Cress, idlServer::RedGrapes); void Lettuce() raises (Mangetout, Cress, BambooShoot, Cassava, Melon, idlServer::RedGrapes); }; polyorb-2.8~20110207.orig/testsuite/idls/vb_p03/0000755000175000017500000000000011750740340020457 5ustar xavierxavierpolyorb-2.8~20110207.orig/testsuite/idls/vb_p03/test.out0000644000175000017500000000173211750740340022172 0ustar xavierxaviertypedef sequence LongSeq; valuetype LongSeqValue LongSeq; valuetype AnyValue any; union FixU switch (long) { case 1 : long x; case 2 : short v; }; valuetype FixUValue FixU; typedef sequence StringSeq; valuetype StringSeqValue StringSeq; union VarU switch (boolean) { case TRUE : string strMbr; case FALSE : StringSeq strseqMbr; }; valuetype VarUValue VarU; interface Intf { attribute LongSeqValue LongSeqAttr; attribute AnyValue AnyAttr; attribute FixUValue FixUAttr; attribute StringSeqValue StringSeqAttr; attribute VarUValue VarUAttr; LongSeqValue op1(in LongSeqValue inp, inout LongSeqValue inoutp, out LongSeqValue outp); AnyValue op2(in AnyValue inp, inout AnyValue inoutp, out AnyValue outp); FixUValue op3(in FixUValue inp, inout FixUValue inoutp, out FixUValue outp); StringSeqValue op4(in StringSeqValue inp, inout StringSeqValue inoutp, out StringSeqValue outp); VarUValue op5(in VarUValue inp, inout VarUValue inoutp, out VarUValue outp); }; polyorb-2.8~20110207.orig/testsuite/idls/vb_p03/tin.idl0000644000175000017500000000205711750740340021747 0ustar xavierxavier// IDL-Spec for testgroup: valuetype // Purpose: basic features of valuetype typedef sequence LongSeq; valuetype LongSeqValue LongSeq; valuetype AnyValue any; union FixU switch (long) { case 1: long x; case 2: short v; }; valuetype FixUValue FixU; typedef sequence StringSeq; valuetype StringSeqValue StringSeq; union VarU switch (boolean) { case TRUE: string strMbr; case FALSE: StringSeq strseqMbr; }; valuetype VarUValue VarU; interface Intf { attribute LongSeqValue LongSeqAttr; attribute AnyValue AnyAttr; attribute FixUValue FixUAttr; attribute StringSeqValue StringSeqAttr; attribute VarUValue VarUAttr; LongSeqValue op1(in LongSeqValue inp,inout LongSeqValue inoutp,out LongSeqValue outp); AnyValue op2(in AnyValue inp,inout AnyValue inoutp,out AnyValue outp); FixUValue op3(in FixUValue inp,inout FixUValue inoutp,out FixUValue outp); StringSeqValue op4(in StringSeqValue inp,inout StringSeqValue inoutp,out StringSeqValue outp); VarUValue op5(in VarUValue inp,inout VarUValue inoutp,out VarUValue outp); }; polyorb-2.8~20110207.orig/testsuite/idls/test015/0000755000175000017500000000000011750740340020573 5ustar xavierxavierpolyorb-2.8~20110207.orig/testsuite/idls/test015/test.out0000644000175000017500000000027411750740340022306 0ustar xavierxavierconst long Lime = 3; interface Apple { typedef float Cress[3]; void Pumpkin(in Apple::Cress p1); }; interface Banana { const long Lime = 40; }; interface idlServer : Banana, Apple { }; polyorb-2.8~20110207.orig/testsuite/idls/idl15021/0000755000175000017500000000000011750740340020527 5ustar xavierxavierpolyorb-2.8~20110207.orig/testsuite/idls/idl15021/test.out0000644000175000017500000000017611750740340022243 0ustar xavierxaviertin.idl:2:17: "M" conflicts with declaration at line 1 tin.idl:6:10: "i" conflicts with declaration at line 5 iac: 2 error(s) polyorb-2.8~20110207.orig/testsuite/idls/idl15021/tin.idl0000644000175000017500000000044011750740340022011 0ustar xavierxaviermodule M { typedef short M; // Error: M is the name of the module in the scope // of which the typedef is. interface I { void i (in short j); // Error: i clashes with the interface name I void a (in short a); // No clash since a is an operation }; }; polyorb-2.8~20110207.orig/testsuite/idls/test041/0000755000175000017500000000000011750740340020572 5ustar xavierxavierpolyorb-2.8~20110207.orig/testsuite/idls/test041/test.out0000644000175000017500000000101711750740340022301 0ustar xavierxaviertypedef sequence YellowPepper; typedef sequence CoxPippin[4]; interface idlServer { exception YellowPepperExcpt { YellowPepper ex1; }; attribute YellowPepper YellowPepperAttr; YellowPepper YellowPepperOp(in YellowPepper p1, out YellowPepper p2, inout YellowPepper p3) raises (idlServer::YellowPepperExcpt); exception CoxPippinExcpt { CoxPippin ex1; }; attribute CoxPippin CoxPippinAttr; CoxPippin CoxPippinOp(in CoxPippin p1, out CoxPippin p2, inout CoxPippin p3) raises (idlServer::CoxPippinExcpt); }; polyorb-2.8~20110207.orig/testsuite/idls/iac006/0000755000175000017500000000000011750740340020350 5ustar xavierxavierpolyorb-2.8~20110207.orig/testsuite/idls/iac006/test.out0000644000175000017500000000047011750740340022061 0ustar xavierxaviertin.idl:1:12: value not in range of type of "long" tin.idl:2:19: invalid operand types for operator "+" tin.idl:3:13: value not in range of type of "octet" tin.idl:4:38: value not in range of type of "long" or "unsigned long" tin.idl:5:33: value not in range of type of "long" or "unsigned long" iac: 5 error(s) polyorb-2.8~20110207.orig/testsuite/idls/iac006/tin.idl0000644000175000017500000000024411750740340021634 0ustar xavierxavierconst long c1 = "a"; const long c2 = 1 + "a"; const octet c3 = -1; const unsigned long c4 = (4294967295 * 2) / 2; const unsigned long c5 = (65536 * 65536) / 65536; polyorb-2.8~20110207.orig/testsuite/idls/vb_p01/0000755000175000017500000000000011750740340020455 5ustar xavierxavierpolyorb-2.8~20110207.orig/testsuite/idls/vb_p01/test.out0000644000175000017500000000023211750740340022162 0ustar xavierxaviervaluetype ShortValue short; interface Intf { attribute ShortValue s; ShortValue op(in ShortValue inp, inout ShortValue inoutp, out ShortValue outp); }; polyorb-2.8~20110207.orig/testsuite/idls/vb_p01/tin.idl0000644000175000017500000000035211750740340021741 0ustar xavierxavier// IDL-Spec for testgroup: valuetype // Purpose: basic features of valuetype valuetype ShortValue short; interface Intf { attribute ShortValue s; ShortValue op(in ShortValue inp,inout ShortValue inoutp,out ShortValue outp); }; polyorb-2.8~20110207.orig/testsuite/idls/iac-idl0000755000175000017500000000026411750740340020620 0ustar xavierxavier#!/bin/sh INCLUDES= FILENAME= for i in $*; do case $i in -I*) INCLUDES="$INCLUDES $i";; -*) ;; *) FILENAME="$i";; esac; done iac $INCLUDES -idl -b 10 $FILENAME | pp-idl polyorb-2.8~20110207.orig/testsuite/idls/types002/0000755000175000017500000000000011750740340020754 5ustar xavierxavierpolyorb-2.8~20110207.orig/testsuite/idls/types002/test.out0000644000175000017500000000012511750740340022462 0ustar xavierxavierVALUE := True STRING := True ULONG := True SHORT := True BOOLEAN := True ANY := True polyorb-2.8~20110207.orig/testsuite/idls/types002/tin.idl0000644000175000017500000000007311750740340022240 0ustar xavierxaviervaluetype tin { boolean echoBoolean (in boolean arg); }; polyorb-2.8~20110207.orig/testsuite/idls/test004/0000755000175000017500000000000011750740340020571 5ustar xavierxavierpolyorb-2.8~20110207.orig/testsuite/idls/test004/test.out0000644000175000017500000000046211750740340022303 0ustar xavierxaviertypedef long Apple; typedef long Banana; typedef long Carrots; typedef long Lemon; typedef long BlackCherry; typedef long Starfruit; typedef long Rhubarb; interface idlServer { void PassionFruit(in Apple p1, in Banana p2, in Carrots p3, in Lemon p4, in BlackCherry p5, in Starfruit p6, in Rhubarb p7); }; polyorb-2.8~20110207.orig/testsuite/idls/vb_d02/0000755000175000017500000000000011750740340020442 5ustar xavierxavierpolyorb-2.8~20110207.orig/testsuite/idls/vb_d02/test.out0000644000175000017500000000020611750740340022150 0ustar xavierxavierstruct VarS { string strMbr; }; valuetype VarSvalue VarS; struct FixS { long longMbr; short shortMbr; }; valuetype FixSvalue FixS; polyorb-2.8~20110207.orig/testsuite/idls/vb_d02/tin.idl0000644000175000017500000000032711750740340021730 0ustar xavierxavier// IDL-Spec for testgroup: valuetype // Purpose: basic features of valuetype struct VarS { string strMbr; }; valuetype VarSvalue VarS; struct FixS { long longMbr; short shortMbr; }; valuetype FixSvalue FixS; polyorb-2.8~20110207.orig/testsuite/idls/ada0019/0000755000175000017500000000000011750740340020425 5ustar xavierxavierpolyorb-2.8~20110207.orig/testsuite/idls/ada0019/tin.idl0000644000175000017500000000015511750740340021712 0ustar xavierxavierinterface TestService2 { typedef short index_type; TestService2 getChild(in index_type index); }; polyorb-2.8~20110207.orig/testsuite/idls/vti_vb01/0000755000175000017500000000000011750740340021020 5ustar xavierxavierpolyorb-2.8~20110207.orig/testsuite/idls/vti_vb01/test.out0000644000175000017500000000042411750740340022530 0ustar xavierxaviervaluetype Val1 { public long longMbr; public short shtMbr; short op(); factory init(in long longMbr, in short shtMbr); }; valuetype Val2 : Val1 { public any anyMbr; factory init(in long longMbr, in short shtMbr, in any anyMbr); }; valuetype Val3 : truncatable Val1 { }; polyorb-2.8~20110207.orig/testsuite/idls/vti_vb01/tin.idl0000644000175000017500000000066011750740340022306 0ustar xavierxavier//testsubgroup valuetype as base class //tsgdescr "Testing the concrete valuetype as base class" valuetype Val1 { //state public long longMbr; public short shtMbr; short op(); // initializer factory init(in long longMbr, in short shtMbr); }; valuetype Val2:Val1 { //state public any anyMbr; // initializer factory init(in long longMbr, in short shtMbr, in any anyMbr); }; valuetype Val3: truncatable Val1 {}; polyorb-2.8~20110207.orig/testsuite/idls/expansion03/0000755000175000017500000000000011750740340021535 5ustar xavierxavierpolyorb-2.8~20110207.orig/testsuite/idls/expansion03/expansion.idl0000644000175000017500000000026011750740340024231 0ustar xavierxavierinterface test_array { typedef sequence seq; struct s { long m1; short m2[3], m3, m4[2]; sequence > m5[6]; seq m6[2]; }; }; polyorb-2.8~20110207.orig/testsuite/idls/idl07051/0000755000175000017500000000000011750740340020533 5ustar xavierxavierpolyorb-2.8~20110207.orig/testsuite/idls/idl07051/test.out0000644000175000017500000000022311750740340022240 0ustar xavierxaviertin.idl:10:11: multiple declarations of "L1" tin.idl:10:11: found declaration at line 2 tin.idl:10:11: found declaration at line 6 iac: 1 error(s) polyorb-2.8~20110207.orig/testsuite/idls/idl07051/tin.idl0000644000175000017500000000041111750740340022013 0ustar xavierxavierinterface A { typedef long L1; short opA(in L1 l_1); }; interface B { typedef short L1; L1 opB(in long l); }; interface C: B, A { typedef L1 L2; // Error: L1 ambiguous typedef A::L1 L3; // A::L1 is OK B::L1 opC(in L3 l_3); // all OK no ambiguities }; polyorb-2.8~20110207.orig/testsuite/idls/run-test.sh0000755000175000017500000000324211750740340021507 0ustar xavierxavier# !/bin/sh # This script runs the test given to the command line and displays the # result # There are 4 test categories : # 1 - Frontend tests : IDL tree tests # 2 - IDL errors tests # 3 - Ada Backend tests : Single File tests and multi files tests # 4 - Types Backend tests # The test category is given in the command line : # run_test.sh : # The test name TEST_NAME=`echo $1 | awk 'BEGIN { FS=":"}{print $1} '` # The test category TEST_CATEGORY=`echo $1 | awk 'BEGIN { FS=":"}{print $2} '` # Setting environment variables DIR=`dirname $0` PATH=$PWD:$PWD/$DIR:$PATH if [ -d $TEST_NAME ]; then DIR=$TEST_NAME; else DIR=`dirname $TEST_NAME`; fi # Copy the test script corresponding to the test category TEST_SCRIPT= TEST_MSG= if [ x$TEST_CATEGORY = xada_backend ]; then TEST_SCRIPT=compile_files.sh; elif [ x$TEST_CATEGORY = xidl_frontend ]; then TEST_SCRIPT=parse_file.sh; elif [ x$TEST_CATEGORY = xidl_errors ]; then TEST_SCRIPT=test_errors.sh; elif [ x$TEST_CATEGORY = xtypes_backend ]; then TEST_SCRIPT=list_types.sh; else echo "$1 : Invalid test category !"; exit 1; fi # Execute the script LOG=/tmp/$TEST.log ./$TEST_SCRIPT $TEST_NAME >$LOG 2>&1 cd $DIR; if [ -f "test.out" ]; then diff test.out $LOG #> /dev/null else test ! -s $LOG fi CODE=$? if [ $CODE != 0 ]; then echo "$TEST_NAME FAILED" | awk '{printf ("%-30s%20s\n", $1, $2)}' echo "--------------- expected output ------------------" if [ -f "test.out" ]; then cat test.out fi echo "---------------- actual output -------------------" cat $LOG echo "--------------------------------------------------" else echo "$TEST_NAME : PASSED"; fi; rm $LOG exit $CODE polyorb-2.8~20110207.orig/testsuite/idls/idlac002/0000755000175000017500000000000011750740340020664 5ustar xavierxavierpolyorb-2.8~20110207.orig/testsuite/idls/idlac002/tin.idl0000644000175000017500000000016411750740340022151 0ustar xavierxavierinterface Echo { typedef Object echoSeq[3]; string echoString (in string Mesg); echoSeq echoers(); }; polyorb-2.8~20110207.orig/testsuite/idls/aif_p01/0000755000175000017500000000000011750740340020605 5ustar xavierxavierpolyorb-2.8~20110207.orig/testsuite/idls/aif_p01/test.out0000644000175000017500000000024011750740340022311 0ustar xavierxavierabstract interface AbsInf { short op1(); }; interface Inf { AbsInf op2(in AbsInf inp, inout AbsInf iop, out AbsInf outp); }; interface Itfderiv : AbsInf { }; polyorb-2.8~20110207.orig/testsuite/idls/aif_p01/tin.idl0000644000175000017500000000066611750740340022101 0ustar xavierxavier//testgroup abstract interface //tsref "IDL" //tgdescr "Testing features of the abstract interface construct" //testsubgroup abstract interface as operation parameter and attribute //tsgdescr "Testing the abstract interface construct used as operation parameter and attribute" abstract interface AbsInf { short op1(); }; interface Inf { AbsInf op2(in AbsInf inp,inout AbsInf iop,out AbsInf outp); }; interface Itfderiv: AbsInf { }; polyorb-2.8~20110207.orig/testsuite/idls/test047/0000755000175000017500000000000011750740340020600 5ustar xavierxavierpolyorb-2.8~20110207.orig/testsuite/idls/test047/test.out0000644000175000017500000000142111750740340022306 0ustar xavierxaviertypedef string Apple; typedef string<39> Banana; typedef union Broadbeans switch (long) { case 1042 : float ButterBean; case 306 : double Cinnamon; case -57 : long BreadFruit; case 9877 : short BambooShoot; case -7667 : unsigned long Fennell; case 11 : unsigned short Pineapple; case 76 : char Radish; case 75 : boolean Damsons; default : octet Mullberry; } Orange; interface idlServer { exception BroadbeansExcpt { Broadbeans ex1; }; attribute Broadbeans BroadbeansAttr; Broadbeans BroadbeansOp(in Broadbeans p1, out Broadbeans p2, inout Broadbeans p3) raises (idlServer::BroadbeansExcpt); exception OrangeExcpt { Orange ex1; }; attribute Orange OrangeAttr; Orange OrangeOp(in Orange p1, out Orange p2, inout Orange p3) raises (idlServer::OrangeExcpt); }; polyorb-2.8~20110207.orig/testsuite/idls/va_t02/0000755000175000017500000000000011750740340020461 5ustar xavierxavierpolyorb-2.8~20110207.orig/testsuite/idls/va_t02/test.out0000644000175000017500000000133411750740340022172 0ustar xavierxaviervaluetype ShortValue short; valuetype LongValue long; typedef ShortValue TestType; abstract valuetype ValA { void op1(in TestType p); }; abstract valuetype ValB { typedef LongValue TestType; void op2(in ValB::TestType p); }; valuetype ValC { typedef string TestType; public ValC::TestType Mbr3; void op3(in ValC::TestType p); }; valuetype ValD : ValC { public ValC::TestType Mbr4; void op4(in ValC::TestType p); }; valuetype ValE : ValD, ValB, ValA { typedef TestType ShortType; typedef ValB::TestType LongType; typedef ValC::TestType StringType; typedef ValC::TestType StringType2; void op5(in ValE::ShortType p); void op6(in ValE::LongType p); void op7(in ValE::StringType p); void op8(in ValE::StringType2 p); }; polyorb-2.8~20110207.orig/testsuite/idls/va_t02/tin.idl0000644000175000017500000000143711750740340021752 0ustar xavierxavier//testsubgroup typedef_inheritance //tsgdescr "Testing scope of typedef declarations with the valuetype inheritance" valuetype ShortValue short; valuetype LongValue long; typedef ShortValue TestType; abstract valuetype ValA { void op1(in TestType p); }; abstract valuetype ValB { typedef LongValue TestType; void op2(in TestType p); }; valuetype ValC { typedef string TestType; public TestType Mbr3; void op3(in TestType p); }; valuetype ValD:ValC { public TestType Mbr4; void op4(in TestType p); }; valuetype ValE:ValD,ValB,ValA { typedef ::TestType ShortType; typedef ValB::TestType LongType; typedef ValC::TestType StringType; typedef ValD::TestType StringType2; void op5(in ShortType p); void op6(in LongType p); void op7(in StringType p); void op8(in StringType2 p); }; polyorb-2.8~20110207.orig/testsuite/idls/ada0012/0000755000175000017500000000000011750740340020416 5ustar xavierxavierpolyorb-2.8~20110207.orig/testsuite/idls/ada0012/tin.idl0000644000175000017500000000023411750740340021701 0ustar xavierxavierinterface EnumTests { enum Color {Red, Blue, Green}; const Color Rouge = Red; attribute Color attr_enum; Color modif_enum (inout Color C); }; polyorb-2.8~20110207.orig/testsuite/idls/test001/0000755000175000017500000000000011750740340020566 5ustar xavierxavierpolyorb-2.8~20110207.orig/testsuite/idls/test001/test.out0000644000175000017500000000211011750740340022270 0ustar xavierxaviertypedef float abcdefghijklmnopqrstuvwxyz_12343567890; typedef long ABCDEFGHIJKLMNOPQRSTUVWXYZ; typedef short xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx1; typedef long xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx2; typedef double xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx3; typedef char xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx4; interface idlServer { xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx4 aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa(in xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx4 p1, out xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx2 p2, inout xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx3 p3); }; polyorb-2.8~20110207.orig/testsuite/idls/vti_si01/0000755000175000017500000000000011750740340021024 5ustar xavierxavierpolyorb-2.8~20110207.orig/testsuite/idls/vti_si01/test.out0000644000175000017500000000014511750740340022534 0ustar xavierxavierinterface Itf { short op1(); long op2(); }; valuetype Val supports Itf { public short shtMber; }; polyorb-2.8~20110207.orig/testsuite/idls/vti_si01/tin.idl0000644000175000017500000000033111750740340022305 0ustar xavierxavier//testsubgroup a valuetype supporting an interface //tsgdescr "Testing a valuetype supporting an interface" interface Itf { short op1(); long op2(); }; valuetype Val supports Itf { public short shtMber; }; polyorb-2.8~20110207.orig/testsuite/idls/idl15001/0000755000175000017500000000000011750740340020525 5ustar xavierxavierpolyorb-2.8~20110207.orig/testsuite/idls/idl15001/test.out0000644000175000017500000000026011750740340022233 0ustar xavierxaviertin.idl:2:20: expected token tin.idl:6:05: bad casing of "mylong" declared at line 5 tin.idl:7:28: "thething" conflicts with scoped name at line 7 iac: 3 error(s) polyorb-2.8~20110207.orig/testsuite/idls/idl15001/tin.idl0000644000175000017500000000044111750740340022010 0ustar xavierxaviermodule M { typedef long Long; // Error: Long clashes with keyword long typedef long TheThing; interface I { typedef long MyLong; myLong op1( // Error: inconsistent capitalization in TheThing thething // Error: TheThing clashes with thething ); }; }; polyorb-2.8~20110207.orig/testsuite/idls/vt_i01/0000755000175000017500000000000011750740340020470 5ustar xavierxavierpolyorb-2.8~20110207.orig/testsuite/idls/vt_i01/test.out0000644000175000017500000000023411750740340022177 0ustar xavierxaviervaluetype Val { public Val ValMbr; }; struct S { Val valstctMbr; }; union U switch (long) { case 1 : long x; case 2 : Val v; default : S strMbr; }; polyorb-2.8~20110207.orig/testsuite/idls/vt_i01/tin.idl0000644000175000017500000000034411750740340021755 0ustar xavierxavier// IDL-Spec for testgroup: valuetype // Purpose: Valuetype as Member valuetype Val { public Val ValMbr; }; struct S { Val valstctMbr; }; union U switch (long) { case 1: long x; case 2: Val v; default: S strMbr; }; polyorb-2.8~20110207.orig/testsuite/idls/ada0017/0000755000175000017500000000000011750740340020423 5ustar xavierxavierpolyorb-2.8~20110207.orig/testsuite/idls/ada0017/tin.idl0000644000175000017500000000052711750740340021713 0ustar xavierxavierinterface i1 { typedef string new_string; typedef float New_Float; typedef new_string n2, tab[4][2]; typedef float f33 [120], f45 [4][5][6]; attribute string str; attribute new_string S; void min (in New_Float f1); float Add (inout New_Float f1, in float f2); New_Float minus (in float f1, in float f2, out float r); }; polyorb-2.8~20110207.orig/testsuite/idls/inherit001/0000755000175000017500000000000011750740340021251 5ustar xavierxavierpolyorb-2.8~20110207.orig/testsuite/idls/inherit001/tin.idl0000644000175000017500000000026011750740340022533 0ustar xavierxaviermodule m { interface int1 { short op1(); attribute long attr1, attr11; }; interface int2 : int1 { short op2(); attribute long attr2, attr22; }; }; polyorb-2.8~20110207.orig/testsuite/idls/ada0014/0000755000175000017500000000000011750740340020420 5ustar xavierxavierpolyorb-2.8~20110207.orig/testsuite/idls/ada0014/tin.idl0000644000175000017500000000033611750740340021706 0ustar xavierxaviermodule _module { module m11 { interface I111 { attribute float value; }; }; }; module m2 { interface I21 { typedef boolean new_bool; new_bool is_greater (in float f1, in float f2); }; }; polyorb-2.8~20110207.orig/testsuite/idls/vb_e01/0000755000175000017500000000000011750740340020442 5ustar xavierxavierpolyorb-2.8~20110207.orig/testsuite/idls/vb_e01/test.out0000644000175000017500000000240711750740340022155 0ustar xavierxaviervaluetype ShortValue short; valuetype LongValue long; typedef float FloatType; valuetype FloatValue FloatType; enum EnumType { eval1, eval2, eval3 }; valuetype EnumValue EnumType; struct VarS { string strMbr; }; valuetype VarSvalue VarS; struct FixS { long longMbr; short shortMbr; }; valuetype FixSvalue FixS; typedef long LongArray[2][3]; valuetype ArrayValue LongArray; valuetype StringValue string; valuetype WStringValue wstring; typedef sequence LongSeq; valuetype LongSeqValue LongSeq; valuetype AnyValue any; union FixU switch (long) { case 1 : long x; case 2 : short v; }; valuetype FixUValue FixU; typedef sequence StringSeq; valuetype StringSeqValue StringSeq; union VarU switch (boolean) { case TRUE : string strMbr; case FALSE : StringSeq strseqMbr; }; valuetype VarUValue VarU; interface Inf { exception ValExcpt { ShortValue ex_ShortValue; LongValue ex_LongValue; FloatValue ex_FloatValue; EnumValue ex_EnumValue; VarSvalue ex_VarSvalue; FixSvalue ex_FixSvalue; ArrayValue ex_ArrayValue; StringValue ex_StringValue; WStringValue ex_WStringValue; LongSeqValue ex_LongSeqValue; AnyValue ex_AnyValue; FixUValue ex_FixUValue; StringSeqValue ex_StringSeqValue; VarUValue ex_VarUValue; }; ShortValue op2() raises (Inf::ValExcpt); }; polyorb-2.8~20110207.orig/testsuite/idls/vb_e01/tin.idl0000644000175000017500000000253211750740340021730 0ustar xavierxavier// IDL-Spec for testgroup: value box // Purpose: Value box as member in an exception, valuetype ShortValue short; valuetype LongValue long; typedef float FloatType; valuetype FloatValue FloatType; enum EnumType {eval1, eval2, eval3}; valuetype EnumValue EnumType; struct VarS { string strMbr; }; valuetype VarSvalue VarS; struct FixS { long longMbr; short shortMbr; }; valuetype FixSvalue FixS; typedef long LongArray[2][3]; valuetype ArrayValue LongArray; valuetype StringValue string; valuetype WStringValue wstring; typedef sequence LongSeq; valuetype LongSeqValue LongSeq; valuetype AnyValue any; union FixU switch (long) { case 1: long x; case 2: short v; }; valuetype FixUValue FixU; typedef sequence StringSeq; valuetype StringSeqValue StringSeq; union VarU switch (boolean) { case TRUE: string strMbr; case FALSE: StringSeq strseqMbr; }; valuetype VarUValue VarU; interface Inf { exception ValExcpt { ShortValue ex_ShortValue; LongValue ex_LongValue; FloatValue ex_FloatValue; EnumValue ex_EnumValue; VarSvalue ex_VarSvalue; FixSvalue ex_FixSvalue; ArrayValue ex_ArrayValue; StringValue ex_StringValue; WStringValue ex_WStringValue; LongSeqValue ex_LongSeqValue; AnyValue ex_AnyValue; FixUValue ex_FixUValue; StringSeqValue ex_StringSeqValue; VarUValue ex_VarUValue; }; ShortValue op2() raises(ValExcpt); }; polyorb-2.8~20110207.orig/testsuite/idls/vti_avb01/0000755000175000017500000000000011750740340021161 5ustar xavierxavierpolyorb-2.8~20110207.orig/testsuite/idls/vti_avb01/test.out0000644000175000017500000000026311750740340022672 0ustar xavierxavierabstract valuetype AbsVal1 { short op1(); }; abstract valuetype AbsVal2 { long op2(); }; valuetype Val : AbsVal1, AbsVal2 { public any anyMbr; factory init(in any anyMbr); }; polyorb-2.8~20110207.orig/testsuite/idls/vti_avb01/tin.idl0000644000175000017500000000047711750740340022455 0ustar xavierxavier//testsubgroup abstract valuetype as base class //tsgdescr "Testing the abstract valuetype as base class" abstract valuetype AbsVal1 { short op1(); }; abstract valuetype AbsVal2 { long op2(); }; valuetype Val:AbsVal1, AbsVal2 { //state public any anyMbr; // initializer factory init(in any anyMbr); }; polyorb-2.8~20110207.orig/testsuite/idls/idl15022/0000755000175000017500000000000011750740340020530 5ustar xavierxavierpolyorb-2.8~20110207.orig/testsuite/idls/idl15022/test.out0000644000175000017500000000015611750740340022242 0ustar xavierxaviermodule M { module Inner1 { typedef string S1; }; module Inner2 { typedef string inner1; }; }; polyorb-2.8~20110207.orig/testsuite/idls/idl15022/tin.idl0000644000175000017500000000016411750740340022015 0ustar xavierxaviermodule M { module Inner1 { typedef string S1; }; module Inner2 { typedef string inner1; // OK }; }; polyorb-2.8~20110207.orig/testsuite/idls/vt_o01/0000755000175000017500000000000011750740340020476 5ustar xavierxavierpolyorb-2.8~20110207.orig/testsuite/idls/vt_o01/test.out0000644000175000017500000000004011750740340022200 0ustar xavierxaviervaluetype Val { short op(); }; polyorb-2.8~20110207.orig/testsuite/idls/vt_o01/tin.idl0000644000175000017500000000015211750740340021760 0ustar xavierxavier// IDL-Spec for testgroup: valuetype // Purpose: Operation in valuetype valuetype Val { short op(); }; polyorb-2.8~20110207.orig/testsuite/idls/test006/0000755000175000017500000000000011750740340020573 5ustar xavierxavierpolyorb-2.8~20110207.orig/testsuite/idls/test006/test.out0000644000175000017500000000065211750740340022306 0ustar xavierxavierconst string Apple = "abcdefghijklmnopqrstuvwxyz"; const string Banana = "ABCDEFGHIJKLMNOPQRSTUVWXYZ"; const string Carrots = "0123456789"; const string Lemon = "!#$%&()*+,-./:;<;>@[]^ _`{|}~"; const string BlackCherry = "  \?'""; const string Starfruit = "377ÿ"; const string PassionFruit = "ffÿ"; const string Orange = "abcdefghijklmnopqrstuvwxyz"; const string Dates = "a B"; interface idlServer { void Pumpkin(); }; polyorb-2.8~20110207.orig/testsuite/idls/test039/0000755000175000017500000000000011750740340020601 5ustar xavierxavierpolyorb-2.8~20110207.orig/testsuite/idls/test039/test.out0000644000175000017500000001013211750740340022306 0ustar xavierxaviertypedef struct WhiteCabbage163 { struct Parsnip163 { struct Orange163 { struct Sultana163 { sequence, 18> GaliaMelon163; } Turnip163; } LoganBerry163; } Celery163; } Aniseed163; typedef struct Orange164 { struct Sultana164 { struct Coconut164 { struct Wilja163 { sequence> BritishQueens163[13]; } Dates164[15]; } GaliaMelon164[11]; } Turnip164; } LoganBerry164; typedef struct Orange165 { struct Sultana165 { struct Asparagus165 { struct PentlandDell164 { sequence>> KingEdward164[7]; } GardenPeas165[10]; } GaliaMelon165; } Turnip165; } LoganBerry165; typedef struct Sultana166 { struct Asparagus166 { struct Lime166 { struct Mango166 { sequence, 19>> Pumpkin166[12]; } WaterMelon166; } GardenPeas166[6]; } GaliaMelon166; } Turnip166; typedef struct Sultana167 { struct Asparagus167 { struct Mint167 { struct BlackEyedBeans167 { sequence>> Apricots167[7]; } Leek167; } GardenPeas167; } GaliaMelon167; } Turnip167; typedef struct Mint168 { struct BlackEyedBeans168 { struct PassionFruit168 { struct ChineseLeaves167 { sequence, 2>> RedCabbage167; } Rhubarb168[5]; } Apricots168[3]; } Leek168; } GardenPeas168; typedef struct Mint169 { struct BlackEyedBeans169 { struct Ginger169 { struct Pimpernel168 { sequence>> GoldenWonder168; } Cucumber169[9]; } Apricots169; } Leek169; } GardenPeas169; interface idlServer { exception Aniseed163Excpt { Aniseed163 ex1; }; attribute Aniseed163 Aniseed163Attr; Aniseed163 Aniseed163Op(in Aniseed163 p1, out Aniseed163 p2, inout Aniseed163 p3) raises (idlServer::Aniseed163Excpt); exception WhiteCabbage163Excpt { WhiteCabbage163 ex1; }; attribute WhiteCabbage163 WhiteCabbage163Attr; WhiteCabbage163 WhiteCabbage163Op(in WhiteCabbage163 p1, out WhiteCabbage163 p2, inout WhiteCabbage163 p3) raises (idlServer::WhiteCabbage163Excpt); exception Parsnip163Excpt { WhiteCabbage163::Parsnip163 ex1; }; attribute WhiteCabbage163::Parsnip163 Parsnip163Attr; WhiteCabbage163::Parsnip163 Parsnip163Op(in WhiteCabbage163::Parsnip163 p1, out WhiteCabbage163::Parsnip163 p2, inout WhiteCabbage163::Parsnip163 p3) raises (idlServer::Parsnip163Excpt); exception Orange163Excpt { WhiteCabbage163::Parsnip163::Orange163 ex1; }; attribute WhiteCabbage163::Parsnip163::Orange163 Orange163Attr; WhiteCabbage163::Parsnip163::Orange163 Orange163Op(in WhiteCabbage163::Parsnip163::Orange163 p1, out WhiteCabbage163::Parsnip163::Orange163 p2, inout WhiteCabbage163::Parsnip163::Orange163 p3) raises (idlServer::Orange163Excpt); exception Sultana163Excpt { WhiteCabbage163::Parsnip163::Orange163::Sultana163 ex1; }; attribute WhiteCabbage163::Parsnip163::Orange163::Sultana163 Sultana163Attr; WhiteCabbage163::Parsnip163::Orange163::Sultana163 Sultana163Op(in WhiteCabbage163::Parsnip163::Orange163::Sultana163 p1, out WhiteCabbage163::Parsnip163::Orange163::Sultana163 p2, inout WhiteCabbage163::Parsnip163::Orange163::Sultana163 p3) raises (idlServer::Sultana163Excpt); exception LoganBerry164Excpt { LoganBerry164 ex1; }; attribute LoganBerry164 LoganBerry164Attr; LoganBerry164 LoganBerry164Op(in LoganBerry164 p1, out LoganBerry164 p2, inout LoganBerry164 p3) raises (idlServer::LoganBerry164Excpt); exception Orange164Excpt { Orange164 ex1; }; attribute Orange164 Orange164Attr; Orange164 Orange164Op(in Orange164 p1, out Orange164 p2, inout Orange164 p3) raises (idlServer::Orange164Excpt); exception Sultana164Excpt { Orange164::Sultana164 ex1; }; attribute Orange164::Sultana164 Sultana164Attr; Orange164::Sultana164 Sultana164Op(in Orange164::Sultana164 p1, out Orange164::Sultana164 p2, inout Orange164::Sultana164 p3) raises (idlServer::Sultana164Excpt); exception Coconut164Excpt { Orange164::Sultana164::Coconut164 ex1; }; attribute Orange164::Sultana164::Coconut164 Coconut164Attr; Orange164::Sultana164::Coconut164 Coconut164Op(in Orange164::Sultana164::Coconut164 p1, out Orange164::Sultana164::Coconut164 p2, inout Orange164::Sultana164::Coconut164 p3) raises (idlServer::Coconut164Excpt); }; polyorb-2.8~20110207.orig/testsuite/idls/test032/0000755000175000017500000000000011750740340020572 5ustar xavierxavierpolyorb-2.8~20110207.orig/testsuite/idls/test032/test.out0000644000175000017500000000656311750740340022314 0ustar xavierxaviertypedef struct Orange19 { long Sultana19; float GaliaMelon19; boolean Turnip19; } LoganBerry19; typedef struct Lemon20 { octet Banana20; unsigned short Apple20[3]; char Carrots20; } BlackCherry20; typedef struct Lime6 { char WaterMelon6[13]; } Coconut6[15]; typedef struct BlackEyedBeans6 { sequence> Apricots6[11]; } Mint6[7]; typedef struct Lettuce6 { sequence>> Tarragon6; } Mangetout6; typedef struct Blueberry6 { sequence, 19>, 12> CoxPippin6; } Chervil6[6]; typedef struct Sultana7 { sequence, 7>, 4> GaliaMelon7; } Turnip7; interface TestServer { exception LoganBerry19Excpt { LoganBerry19 ex1; }; attribute LoganBerry19 LoganBerry19Attr; LoganBerry19 LoganBerry19Op(in LoganBerry19 p1, out LoganBerry19 p2, inout LoganBerry19 p3) raises (TestServer::LoganBerry19Excpt); exception Orange19Excpt { Orange19 ex1; }; attribute Orange19 Orange19Attr; Orange19 Orange19Op(in Orange19 p1, out Orange19 p2, inout Orange19 p3) raises (TestServer::Orange19Excpt); exception BlackCherry20Excpt { BlackCherry20 ex1; }; attribute BlackCherry20 BlackCherry20Attr; BlackCherry20 BlackCherry20Op(in BlackCherry20 p1, out BlackCherry20 p2, inout BlackCherry20 p3) raises (TestServer::BlackCherry20Excpt); exception Lemon20Excpt { Lemon20 ex1; }; attribute Lemon20 Lemon20Attr; Lemon20 Lemon20Op(in Lemon20 p1, out Lemon20 p2, inout Lemon20 p3) raises (TestServer::Lemon20Excpt); exception Coconut6Excpt { Coconut6 ex1; }; attribute Coconut6 Coconut6Attr; Coconut6 Coconut6Op(in Coconut6 p1, out Coconut6 p2, inout Coconut6 p3) raises (TestServer::Coconut6Excpt); exception Lime6Excpt { Lime6 ex1; }; attribute Lime6 Lime6Attr; Lime6 Lime6Op(in Lime6 p1, out Lime6 p2, inout Lime6 p3) raises (TestServer::Lime6Excpt); exception Mint6Excpt { Mint6 ex1; }; attribute Mint6 Mint6Attr; Mint6 Mint6Op(in Mint6 p1, out Mint6 p2, inout Mint6 p3) raises (TestServer::Mint6Excpt); exception BlackEyedBeans6Excpt { BlackEyedBeans6 ex1; }; attribute BlackEyedBeans6 BlackEyedBeans6Attr; BlackEyedBeans6 BlackEyedBeans6Op(in BlackEyedBeans6 p1, out BlackEyedBeans6 p2, inout BlackEyedBeans6 p3) raises (TestServer::BlackEyedBeans6Excpt); exception Mangetout6Excpt { Mangetout6 ex1; }; attribute Mangetout6 Mangetout6Attr; Mangetout6 Mangetout6Op(in Mangetout6 p1, out Mangetout6 p2, inout Mangetout6 p3) raises (TestServer::Mangetout6Excpt); exception Lettuce6Excpt { Lettuce6 ex1; }; attribute Lettuce6 Lettuce6Attr; Lettuce6 Lettuce6Op(in Lettuce6 p1, out Lettuce6 p2, inout Lettuce6 p3) raises (TestServer::Lettuce6Excpt); exception Chervil6Excpt { Chervil6 ex1; }; attribute Chervil6 Chervil6Attr; Chervil6 Chervil6Op(in Chervil6 p1, out Chervil6 p2, inout Chervil6 p3) raises (TestServer::Chervil6Excpt); exception Blueberry6Excpt { Blueberry6 ex1; }; attribute Blueberry6 Blueberry6Attr; Blueberry6 Blueberry6Op(in Blueberry6 p1, out Blueberry6 p2, inout Blueberry6 p3) raises (TestServer::Blueberry6Excpt); exception Turnip7Excpt { Turnip7 ex1; }; attribute Turnip7 Turnip7Attr; Turnip7 Turnip7Op(in Turnip7 p1, out Turnip7 p2, inout Turnip7 p3) raises (TestServer::Turnip7Excpt); exception Sultana7Excpt { Sultana7 ex1; }; attribute Sultana7 Sultana7Attr; Sultana7 Sultana7Op(in Sultana7 p1, out Sultana7 p2, inout Sultana7 p3) raises (TestServer::Sultana7Excpt); }; polyorb-2.8~20110207.orig/testsuite/acats/0000755000175000017500000000000011750740340017526 5ustar xavierxavierpolyorb-2.8~20110207.orig/testsuite/acats/CXE4002/0000755000175000017500000000000011750740340020453 5ustar xavierxavierpolyorb-2.8~20110207.orig/testsuite/acats/CXE4002/cxe4002_common.ads0000644000175000017500000000062011750740340023577 0ustar xavierxavierpragma Style_Checks (Off); package CXE4002_Common is pragma Pure; -- types for parameters passed between partitions type Little_Number is range 0..7; type Integer_Vector is array (2..11) of Integer; subtype Description is String (1..10); type Record_Data is record Part_No : Integer; Cost : Float; Name : Description; end record; end CXE4002_Common; polyorb-2.8~20110207.orig/testsuite/acats/CXE4002/cxe4002_part_a1.adb0000644000175000017500000000641311750740340023623 0ustar xavierxavierpragma Style_Checks (Off); pragma Warnings (Off); ----------------------------------------------------------------------------- with Report; with CXE4002_Common; package body CXE4002_Part_A1 is function "+"(X,Y : Little_Number) return Little_Number renames CXE4002_Common."+"; function "-"(X,Y : Little_Number) return Little_Number renames CXE4002_Common."-"; function "="(X,Y : Little_Number) return Boolean renames CXE4002_Common."="; -- simple integer and float tests procedure Check_In (Little : in Little_Number; Real : in Float; Int : in Integer) is begin if Little /= 1 or Real /= 2.0 or Int /= 3 then Report.Failed ("incorrect value in mode IN integer and float test"); else null; Report.Comment ("mode in integer and float test"); end if; end Check_In; procedure Set_Out (Little : out Little_Number; Real : out Float; Int : out Integer) is begin Report.Comment ("mode out little, integer and float test"); Little := 4; Real := -123.0; Int := -789; end Set_Out; procedure Decr (Little : in out Little_Number; Real : in out Float; Int : in out Integer) is begin if Little /= 6 or Real /= 2.0 or Int /= -1 then Report.Failed ("mode IN OUT parameters did not have the " & " correct value upon entry"); end if; Little := Little - 1; Real := Real - 1.0; Int := Int - 1; end Decr; -- Record tests function Current_Record (Name : Description) return Record_Data is begin if Name /= "1234567890" then Report.Failed ("string parameter did not have the correct value" & " upon entry"); end if; return (1, 198.0, Name); end Current_Record; procedure Update_Record (Old_Data : in Record_Data; New_Data : out Record_Data) is begin New_Data.Part_No := Old_Data.Part_No + 2; New_Data.Cost := Old_Data.Cost * 2.0; New_Data.Name := "ABCDEFGHIJ"; end Update_Record; -- vector operation tests function "+" (A, B : in Integer_Vector) return Integer_Vector is Result : Integer_Vector; begin for I in Integer_Vector'Range loop Result (I) := A(I) + B(I); end loop; return Result; end "+"; procedure Incr_Vector (X : in out Integer_Vector) is begin for I in Integer_Vector'Range loop X (I) := X (I) + 1; end loop; end Incr_Vector; -- remote call test procedure Call_With_4 (T : Integer) is begin if T /= 4 then Report.Failed ("expected 4 but received" & Integer'Image (T)); end if; end; --------- partition termination coordination ---------- -- use a task to prevent the partition from completing its execution -- until the main procedure in partition B tells it to quit. task Wait_For_Quit is entry Can_Quit; entry Quit; end Wait_For_Quit; task body Wait_For_Quit is begin accept Can_Quit; accept Quit; Report.Result; end Wait_For_Quit; procedure Can_Quit is begin Wait_For_Quit.Can_Quit; end Can_Quit; procedure Quit is begin Wait_For_Quit.Quit; end Quit; end CXE4002_Part_A1; polyorb-2.8~20110207.orig/testsuite/acats/CXE4002/cxe4002_a.adb0000644000175000017500000000100311750740340022502 0ustar xavierxavierpragma Warnings (Off); pragma Style_Checks (Off); ----------------------------------------------------------------------------- with CXE4002_Common; with CXE4002_Part_A1; with CXE4002_Part_A2; with Report; procedure CXE4002_A is begin -- this partition is a server that deals with calls -- from CXE4002_B. Report.Test ("CXE4002_A", "Parameter passing across partitions (server)"); CXE4002_Part_A1.Can_Quit; -- OK to quit now. -- Report.Result is called in the body of CXE4002_Part_A1. end CXE4002_A; polyorb-2.8~20110207.orig/testsuite/acats/CXE4002/Makefile.local0000644000175000017500000000000011750740340023172 0ustar xavierxavierpolyorb-2.8~20110207.orig/testsuite/acats/CXE4002/cxe4002_part_a1.ads0000644000175000017500000000265411750740340023647 0ustar xavierxavierpragma Style_Checks (Off); ----------------------------------------------------------------------------- with CXE4002_Common; package CXE4002_Part_A1 is pragma Remote_Call_Interface; -- for convenience, rename the imported types used for parameters subtype Little_Number is CXE4002_Common.Little_Number; subtype Integer_Vector is CXE4002_Common.Integer_Vector; subtype Description is CXE4002_Common.Description; subtype Record_Data is CXE4002_Common.Record_Data; -- simple integer and float tests procedure Check_In (Little : in Little_Number; Real : in Float; Int : in Integer); procedure Set_Out (Little : out Little_Number; Real : out Float; Int : out Integer); procedure Decr (Little : in out Little_Number; Real : in out Float; Int : in out Integer); -- record tests function Current_Record (Name : Description) return Record_Data; procedure Update_Record (Old_Data : in Record_Data; New_Data : out Record_Data); -- array tests function "+"(A, B : in Integer_Vector) return Integer_Vector; procedure Incr_Vector (X : in out Integer_Vector); -- access test support procedure Call_With_4 (T : Integer); -- coordination of test termination across partitions procedure Can_Quit; procedure Quit; end CXE4002_Part_A1; polyorb-2.8~20110207.orig/testsuite/acats/CXE4002/part2.adb0000644000175000017500000000040011750740340022145 0ustar xavierxavierwith PolyORB.Initialization; pragma Warnings (Off); with PolyORB.POA_Config.RACWs; with PolyORB.Setup.Thread_Pool_Server; pragma Warnings (On); with CXE4002_B; procedure Part2 is begin PolyORB.Initialization.Initialize_World; CXE4002_B; end Part2; polyorb-2.8~20110207.orig/testsuite/acats/CXE4002/part1.adb0000644000175000017500000000037711750740340022161 0ustar xavierxavierwith PolyORB.Initialization; pragma Warnings (Off); with PolyORB.POA_Config.RACWs; with PolyORB.Setup.Thread_Pool_Server; pragma Warnings (On); with CXE4002_A; procedure Part1 is begin PolyORB.Initialization.Initialize_World; CXE4002_A; end Part1; polyorb-2.8~20110207.orig/testsuite/acats/CXE4002/cxe4002_part_a2.ads0000644000175000017500000000117411750740340023644 0ustar xavierxavierpragma Style_Checks (Off); ----------------------------------------------------------------------------- package CXE4002_Part_A2 is -- This package supports the remote access tests pragma Remote_Call_Interface; procedure Call_With_2 (T : Integer); procedure Call_With_3 (T : Integer); procedure Mixed_1 (X : in Integer; Y : out Integer; Z : in out Integer); procedure Mixed_2 (X : in Integer; Y : out Integer; Z : in out Integer); type Remote_Proc is access procedure (X : Integer); type Remote_Proc_Mixed is access procedure (A : in Integer; B : out Integer; C : in out Integer); end CXE4002_Part_A2; polyorb-2.8~20110207.orig/testsuite/acats/CXE4002/cxe4002_b.adb0000644000175000017500000001120211750740340022505 0ustar xavierxavierpragma Style_Checks (Off); ----------------------------------------------------------------------------- with CXE4002_Common; with CXE4002_Part_A1; with CXE4002_Part_A2; with Report; procedure CXE4002_B is function "="(L,R : CXE4002_Common.Integer_Vector) return Boolean renames CXE4002_Common."="; function "+"(L,R : CXE4002_Common.Integer_Vector) return CXE4002_Common.Integer_Vector renames CXE4002_Part_A1."+"; function "="(L,R : CXE4002_Common.Little_Number) return Boolean renames CXE4002_Common."="; use type CXE4002_Common.Record_Data; begin Report.Test ("CXE4002_B", "Parameter passing across partitions"); -- make sure partitioning is performed if CXE4002_Part_A1'Partition_ID = CXE4002_B'Partition_ID then Report.Failed ("Partitioning Error - CXE4002_Part_A1 and CXE4002_B" & " are in the same partition."); end if; -- do the tests -- simple IN parameter test CXE4002_Part_A1.Check_In (1, 2.0, 3); -- simple OUT and IN OUT parameter test declare A : CXE4002_Common.Little_Number; B : Float; C : Integer; begin CXE4002_Part_A1.Set_Out (A, B, C); if A /= 4 or B /= -123.0 or C /= -789 then Report.Failed ("OUT parameters not set properly"); end if; A := 6; B := 2.0; C := -1; CXE4002_Part_A1.Decr (A, B, C); if A = 5 and B = 1.0 and C = -2 then null; -- Report.Comment ("finished simple parameter passing"); else Report.Failed ("IN OUT parameters not returned properly"); end if; end; -- do the record type tests now declare I_Data : CXE4002_Common.Record_Data; begin I_Data := CXE4002_Part_A1.Current_Record ("1234567890"); if I_Data /= (1, 198.0, "1234567890") then Report.Failed ("composite function result not the expected value"); end if; CXE4002_Part_A1.Update_Record ((22, 33.0, "abcdefghij"), I_Data); if I_Data.Part_No /= 24 then Report.Failed ("OUT parameter Part_No component has wrong value"); end if; if I_Data.Cost /= 66.0 then Report.Failed ("OUT parameter Cost component has wrong value"); end if; if I_Data.Name /= "ABCDEFGHIJ" then Report.Failed ("OUT parameter Name component has wrong value"); else null; -- Report.Comment ("OUT parameter tests"); end if; end; -- do the array type tests now declare Ones : constant CXE4002_Common.Integer_Vector := (others => 1); Twos : constant CXE4002_Common.Integer_Vector := (others => 2); Fives : constant CXE4002_Common.Integer_Vector := (others => 5); Result : CXE4002_Common.Integer_Vector := (others => 0); begin Result := (Twos + Ones) + Twos; if Result = Fives then null; -- Report.Comment ("array parameter and function result"); else Report.Failed ("incorrect array parameters and/or" & " array function results"); end if; Result := Ones; CXE4002_Part_A1.Incr_Vector (Result); if Result /= Twos then Report.Failed ("incorrect array IN OUT parameter"); end if; end; -- access to remote subprogram tests -- here we make sure the correct procedure is called by having -- several procedures with the same parameter profile but each -- procedure expects a different value to be passed to it as is -- indicated by the procedure name. declare P2, P3, P4 : CXE4002_Part_A2.Remote_Proc; begin P2 := CXE4002_Part_A2.Call_With_2'Access; P3 := CXE4002_Part_A2.Call_With_3'Access; P4 := CXE4002_Part_A1.Call_With_4'Access; -- try two different procedures from the same RCI package P2(2); P3(3); -- try a procedure that is in a different RCI package P4(4); end; -- access to remote subprogram tests with mixed parameters. -- make sure the pointer is used. declare M1 : CXE4002_Part_A2.Remote_Proc_Mixed; M2 : CXE4002_Part_A2.Remote_Proc_Mixed; T : CXE4002_Part_A2.Remote_Proc_Mixed; D, E : Integer := 33; begin T := CXE4002_Part_A2.Mixed_1'Access; if Report.Ident_Int (1) = 1 then M1 := T; M2 := CXE4002_Part_A2.Mixed_2'Access; else -- not executed M2 := T; M1 := CXE4002_Part_A2.Mixed_2'Access; end if; E := 30; M1(20, D, E); if D /= 25 or E /= 35 then Report.Failed ("OUT parameters from Mixed 1 are not the" & " expected values"); end if; E := 300; D := 100; M2 (200, D, E); if D /= 250 or E /= 350 then Report.Failed ("OUT parameters from Mixed 2 are not the" & " expected values"); end if; end; -- finish up CXE4002_Part_A1.Quit; Report.Result; end CXE4002_B; polyorb-2.8~20110207.orig/testsuite/acats/CXE4002/local.gpr0000644000175000017500000000070011750740340022254 0ustar xavierxavierwith "polyorb", "polyorb_test_common"; project local is Dir := external ("Test_Dir"); Obj_Dir := PolyORB_Test_Common.Build_Dir & Dir; for Object_Dir use Obj_Dir; for Source_Dirs use (Obj_Dir, PolyORB_Test_Common.Source_Dir & Dir); package Compiler is for Default_Switches ("Ada") use PolyORB_Test_Common.Compiler'Default_Switches ("Ada"); end Compiler; for Main use ("part1.adb", "part2.adb"); end local; polyorb-2.8~20110207.orig/testsuite/acats/CXE4002/cxe4002_part_a2.adb0000644000175000017500000000177311750740340023630 0ustar xavierxavierpragma Style_Checks (Off); ----------------------------------------------------------------------------- with Report; package body CXE4002_Part_A2 is procedure Call_With_2 (T : Integer) is begin if T /= 2 then Report.Failed ("expected 2 but received" & Integer'Image (T)); end if; end; procedure Call_With_3 (T : Integer) is begin if T /= 3 then Report.Failed ("expected 3 but received" & Integer'Image (T)); end if; end; procedure Mixed_1 (X : in Integer; Y : out Integer; Z : in out Integer) is begin if X /= 20 or Z /= 30 then Report.Failed ("Mixed_1 IN parameters are not the expected value"); end if; Y := 25; Z := 35; end Mixed_1; procedure Mixed_2 (X : in Integer; Y : out Integer; Z : in out Integer) is begin if X /= 200 or Z /= 300 then Report.Failed ("Mixed_2 IN parameters are not the expected value"); end if; Y := 250; Z := 350; end Mixed_2; end CXE4002_Part_A2; polyorb-2.8~20110207.orig/testsuite/acats/CXE2001/0000755000175000017500000000000011750740340020450 5ustar xavierxavierpolyorb-2.8~20110207.orig/testsuite/acats/CXE2001/Makefile.local0000644000175000017500000000000011750740340023167 0ustar xavierxavierpolyorb-2.8~20110207.orig/testsuite/acats/CXE2001/cxe2001_a.adb0000644000175000017500000000562111750740340022506 0ustar xavierxavierpragma Style_Checks (Off); ----------------------------------------------------------------------------- -- -- main procedure for partition A (and the test) -- with CXE2001_Part_B; with CXE2001_Shared; with System.RPC; with Report; procedure CXE2001_A is use type System.RPC.Partition_ID; begin Report.Test ("CXE2001_A", "Access to shared passive data from active" & " partitions"); -- make sure partitioning is performed correctly if CXE2001_A'Partition_ID = CXE2001_Part_B'Partition_ID then Report.Failed ("Partitioning Error - CXE2001_A and CXE2001_Part_B" & " are in the same partition."); end if; -- It doesn't really matter which partition the shared data is placed in -- so we don't check that it is in a particular partition. -- check the shared data access CXE2001_Shared.Shared_Data := Report.Ident_Int(42); if CXE2001_Shared.Shared_Data /= 42 then Report.Failed ("direct assignment to shared data failed"); end if; CXE2001_Part_B.Set_Shared_Data (Report.Ident_Int(45)); case CXE2001_Shared.Shared_Data is when 42 => Report.Failed ("remote access to the shared data failed"); when 45 => null; -- expected result -- Report.Comment ("remote access to shared passive data"); when others => Report.Failed ("unexpected value in shared data (1)" & Integer'Image (CXE2001_Shared.Shared_Data)); end case; -- check the protected object access declare V : Integer := CXE2001_Shared.Shared_Counter.Value; begin if V /= 0 then Report.Failed ("initial value of shared protected value is" & Integer'Image (V)); end if; -- manipulate the protected object directly CXE2001_Shared.Shared_Counter.Increment; if CXE2001_Shared.Shared_Counter.Value /= 1 then Report.Failed ("incorrect shared passive protected object value 1"); end if; CXE2001_Shared.Shared_Counter.Increment; if CXE2001_Shared.Shared_Counter.Value /= 2 then Report.Failed ("incorrect shared passive protected object value 2"); end if; CXE2001_Shared.Shared_Counter.Increment; if CXE2001_Shared.Shared_Counter.Value /= 3 then Report.Failed ("incorrect shared passive protected object value 3"); end if; -- manipulate the protected object from the other partition CXE2001_Part_B.Increment_Counter; V := CXE2001_Shared.Shared_Counter.Value; if V = 3 then Report.Failed ("shared passive protected object appears " & "to be copied"); elsif V = 4 then null; -- Report.Comment ("remote access to shared passive protected" & -- " object"); else Report.Failed ("unexpected value in shared data (2)" & Integer'Image (V)); end if; end; -- finish up CXE2001_Part_B.Test_Finished; Report.Result; end CXE2001_A; polyorb-2.8~20110207.orig/testsuite/acats/CXE2001/part2.adb0000644000175000017500000000057211750740340022154 0ustar xavierxavierwith PolyORB.Initialization; with PolyORB.POA_Config.RACWs; with PolyORB.Setup.Thread_Pool_Server; with CXE2001_B; with CXE2001_Part_B; pragma Warnings (Off, PolyORB.POA_Config.RACWs); pragma Warnings (Off, PolyORB.Setup.Thread_Pool_Server); pragma Warnings (Off, CXE2001_Part_B); procedure Part2 is begin PolyORB.Initialization.Initialize_World; CXE2001_B; end Part2; polyorb-2.8~20110207.orig/testsuite/acats/CXE2001/cxe2001_b.adb0000644000175000017500000000110511750740340022500 0ustar xavierxavierpragma Style_Checks (Off); pragma Warnings (Off); ----------------------------------------------------------------------------- -- -- main procedure for partition B -- with CXE2001_Part_B; with CXE2001_Shared; with Report; procedure CXE2001_B is begin -- The body of package CXE2001_Part_B contains a task that is elaborated -- and will prevent the partition from completing until a Test_Finished -- call arrives from partition A. Report.Test ("CXE2001_B", "Access to shared passive data from active" & " partitions (server)"); end CXE2001_B; polyorb-2.8~20110207.orig/testsuite/acats/CXE2001/cxe2001_shared.adb0000644000175000017500000000057311750740340023535 0ustar xavierxavierpragma Style_Checks (Off); ----------------------------------------------------------------------------- package body CXE2001_Shared is protected body Shared_Counter is procedure Increment is begin Count := Count + 1; end Increment; function Value return Integer is begin return Count; end Value; end Shared_Counter; end CXE2001_Shared; polyorb-2.8~20110207.orig/testsuite/acats/CXE2001/part1.adb0000644000175000017500000000047611750740340022156 0ustar xavierxavierwith PolyORB.Initialization; with PolyORB.POA_Config.RACWs; with PolyORB.Setup.Thread_Pool_Server; pragma Warnings (Off, PolyORB.POA_Config.RACWs); pragma Warnings (Off, PolyORB.Setup.Thread_Pool_Server); with CXE2001_A; procedure Part1 is begin PolyORB.Initialization.Initialize_World; CXE2001_A; end Part1; polyorb-2.8~20110207.orig/testsuite/acats/CXE2001/cxe2001_part_b.adb0000644000175000017500000000127311750740340023534 0ustar xavierxavierpragma Style_Checks (Off); ----------------------------------------------------------------------------- with Report; with CXE2001_Shared; package body CXE2001_Part_B is task Keep_Partition_Alive is entry Quit; end Keep_Partition_Alive; task body Keep_Partition_Alive is begin accept Quit; end Keep_Partition_Alive; procedure Test_Finished is begin Keep_Partition_Alive.Quit; Report.Result; end Test_Finished; procedure Set_Shared_Data (Value : Integer) is begin CXE2001_Shared.Shared_Data := Value; end Set_Shared_Data; procedure Increment_Counter is begin CXE2001_Shared.Shared_Counter.Increment; end Increment_Counter; end CXE2001_Part_B; polyorb-2.8~20110207.orig/testsuite/acats/CXE2001/local.gpr0000644000175000017500000000070011750740340022251 0ustar xavierxavierwith "polyorb", "polyorb_test_common"; project local is Dir := external ("Test_Dir"); Obj_Dir := PolyORB_Test_Common.Build_Dir & Dir; for Object_Dir use Obj_Dir; for Source_Dirs use (Obj_Dir, PolyORB_Test_Common.Source_Dir & Dir); package Compiler is for Default_Switches ("Ada") use PolyORB_Test_Common.Compiler'Default_Switches ("Ada"); end Compiler; for Main use ("part1.adb", "part2.adb"); end local; polyorb-2.8~20110207.orig/testsuite/acats/CXE2001/cxe2001_shared.ads0000644000175000017500000000054611750740340023556 0ustar xavierxavierpragma Style_Checks (Off); ----------------------------------------------------------------------------- package CXE2001_Shared is pragma Shared_Passive; Shared_Data : Integer := 35; protected Shared_Counter is procedure Increment; function Value return Integer; private Count : Integer := 0; end Shared_Counter; end CXE2001_Shared; polyorb-2.8~20110207.orig/testsuite/acats/CXE2001/cxe2001_part_b.ads0000644000175000017500000000044411750740340023554 0ustar xavierxavierpragma Style_Checks (Off); ----------------------------------------------------------------------------- package CXE2001_Part_B is pragma Remote_Call_Interface; procedure Test_Finished; procedure Set_Shared_Data (Value : Integer); procedure Increment_Counter; end CXE2001_Part_B; polyorb-2.8~20110207.orig/testsuite/acats/CXE4006/0000755000175000017500000000000011750740340020457 5ustar xavierxavierpolyorb-2.8~20110207.orig/testsuite/acats/CXE4006/cxe4006_normal.ads0000644000175000017500000000067111750740340023615 0ustar xavierxavier ----------------------------------------------------------------------------- with CXE4006_Common; use CXE4006_Common; package CXE4006_Normal is type Normal_Spec_Tagged_Type is new CXE4006_Common.Root_Tagged_Type with null record; procedure Single_Controlling_Operand ( RTT : in out Normal_Spec_Tagged_Type; Test_Number : in Integer; Callee : out Type_Decl_Location); end CXE4006_Normal; polyorb-2.8~20110207.orig/testsuite/acats/CXE4006/cxe4006_a.adb0000644000175000017500000000070411750740340022521 0ustar xavierxavier ----------------------------------------------------------------------------- with CXE4006_Common; with CXE4006_Part_A1; with CXE4006_Part_A2; with Report; procedure CXE4006_A is begin -- this partition is a server that deals with calls -- from CXE4006_B. Report.Test ("CXE4006_A", "Remote dispatching calls (server)"); CXE4006_Part_A1.Can_Quit; -- OK to quit now. -- Report.Result is called in the body of CXE4006_Part_A1. end CXE4006_A; polyorb-2.8~20110207.orig/testsuite/acats/CXE4006/cxe4006_part_a2.ads0000644000175000017500000000142411750740340023652 0ustar xavierxavier ----------------------------------------------------------------------------- with CXE4006_Common; use CXE4006_Common; with CXE4006_Part_A1; package CXE4006_Part_A2 is pragma Remote_Call_Interface; subtype String_20 is String (1..20); -- tagged types that can be passed between partitions type A2_Tagged_Type is new Root_Tagged_Type with record A2_Component : String_20; end record; procedure Single_Controlling_Operand ( RTT : in out A2_Tagged_Type; Test_Number : in Integer; Callee : out Type_Decl_Location); -- pass thru procedure procedure Call_B ( X : in out Root_Tagged_Type'Class; Test_Number : in Integer; Callee : out Type_Decl_Location); end CXE4006_Part_A2; polyorb-2.8~20110207.orig/testsuite/acats/CXE4006/Makefile.local0000644000175000017500000000000011750740340023176 0ustar xavierxavierpolyorb-2.8~20110207.orig/testsuite/acats/CXE4006/cxe4006_part_a1.ads0000644000175000017500000000214211750740340023647 0ustar xavierxavier ----------------------------------------------------------------------------- with CXE4006_Common; use CXE4006_Common; package CXE4006_Part_A1 is pragma Remote_Call_Interface; -- coordination of test termination across partitions procedure Can_Quit; procedure Quit; -- tagged types that can be passed between partitions type A1_Tagged_Type_1 is new Root_Tagged_Type with record A1_1_Component : Character := ' '; end record; procedure Single_Controlling_Operand ( RTT : in out A1_Tagged_Type_1; Test_Number : in Integer; Callee : out Type_Decl_Location); type A1_Tagged_Type_2 is new A1_Tagged_Type_1 with record A1_2_Component : Float; end record; procedure Single_Controlling_Operand ( RTT : in out A1_Tagged_Type_2; Test_Number : in Integer; Callee : out Type_Decl_Location); ---------- procedure Make_Dispatching_Call_With ( X : in out Root_Tagged_Type'Class; Test_Number : in Integer; Callee : out Type_Decl_Location); end CXE4006_Part_A1; polyorb-2.8~20110207.orig/testsuite/acats/CXE4006/cxe4006_normal.adb0000644000175000017500000000045511750740340023574 0ustar xavierxavier package body CXE4006_Normal is procedure Single_Controlling_Operand ( RTT : in out Normal_Spec_Tagged_Type; Test_Number : in Integer; Callee : out Type_Decl_Location) is begin Callee := Normal_Spec; end Single_Controlling_Operand; end CXE4006_Normal; polyorb-2.8~20110207.orig/testsuite/acats/CXE4006/cxe4006_common.ads0000644000175000017500000000176111750740340023616 0ustar xavierxavier package CXE4006_Common is pragma Pure; -- controls progress output from the tests. The value of this -- flag does not affect whether or not the test passes. Verbose : constant Boolean := False; -- exception to signify that the test number or object -- was not a one of the expected values Failed_Check : exception; -- instances of types derived from Root_Tagged_Type. -- Used to identify the routine that received the dispatching call. type Type_Decl_Location is ( Common_Spec, Part_A1_1_Spec, Part_A1_2_Spec, Part_A2_Spec, Part_B_Spec, Part_B_Body, Normal_Spec); -- root tagged type for remote access to class wide type test type Root_Tagged_Type is tagged record Common_Record_Field : Integer := 1234; end record; procedure Single_Controlling_Operand ( RTT : in out Root_Tagged_Type; Test_Number : in Integer; Callee : out Type_Decl_Location); end CXE4006_Common; polyorb-2.8~20110207.orig/testsuite/acats/CXE4006/part2.adb0000644000175000017500000000035011750740340022155 0ustar xavierxavierwith PolyORB.Initialization; with PolyORB.POA_Config.RACWs; with PolyORB.Setup.Thread_Pool_Server; with CXE4006_Part_B; with CXE4006_B; procedure Part2 is begin PolyORB.Initialization.Initialize_World; CXE4006_B; end Part2; polyorb-2.8~20110207.orig/testsuite/acats/CXE4006/cxe4006_part_a1.adb0000644000175000017500000000565511750740340023642 0ustar xavierxavier ----------------------------------------------------------------------------- with Report; with CXE4006_Part_A2; with CXE4006_Part_B; with CXE4006_Normal; package body CXE4006_Part_A1 is --------- partition termination coordination ---------- -- use a task to prevent the partition from completing its execution -- until the main procedure in partition B tells it to quit, and to insure -- that Report.Result is not called until after the partition is started. task Wait_For_Quit is entry Can_Quit; entry Quit; end Wait_For_Quit; task body Wait_For_Quit is begin accept Can_Quit; accept Quit; Report.Result; end Wait_For_Quit; procedure Can_Quit is begin Wait_For_Quit.Can_Quit; end Can_Quit; procedure Quit is begin Wait_For_Quit.Quit; end Quit; ---------- procedure Single_Controlling_Operand ( RTT : in out A1_Tagged_Type_1; Test_Number : in Integer; Callee : out Type_Decl_Location) is Expected : Integer := 0; begin case Test_Number is when 1002 => Expected := 110; when 2002 => Expected := 210; when others => Report.Failed ("CXE4006_Part_A1(1) bad test number" & Integer'Image (Test_Number)); end case; if RTT.Common_Record_Field /= Expected then Report.Failed ("CXE4006_Part_A1(1) expected" & Integer'Image (Expected) & " but received" & Integer'Image (RTT.Common_Record_Field) & " in test" & Integer'Image (Test_Number)); end if; RTT.Common_Record_Field := Expected + 6; Callee := Part_A1_1_Spec; end Single_Controlling_Operand; procedure Single_Controlling_Operand ( RTT : in out A1_Tagged_Type_2; Test_Number : in Integer; Callee : out Type_Decl_Location) is Expected : Integer := 0; begin case Test_Number is when 1003 => Expected := 120; when 2003 => Expected := 220; when others => Report.Failed ("CXE4006_Part_A1(2) bad test number" & Integer'Image (Test_Number)); end case; if RTT.Common_Record_Field /= Expected then Report.Failed ("CXE4006_Part_A1(2) expected" & Integer'Image (Expected) & " but received" & Integer'Image (RTT.Common_Record_Field) & " in test" & Integer'Image (Test_Number)); end if; RTT.Common_Record_Field := Expected + 7; Callee := Part_A1_2_Spec; end Single_Controlling_Operand; ---------- procedure Make_Dispatching_Call_With ( X : in out Root_Tagged_Type'Class; Test_Number : in Integer; Callee : out Type_Decl_Location) is begin Single_Controlling_Operand (X, Test_Number, Callee); end Make_Dispatching_Call_With; end CXE4006_Part_A1; polyorb-2.8~20110207.orig/testsuite/acats/CXE4006/cxe4006_common.adb0000644000175000017500000000123311750740340023567 0ustar xavierxavier --- -- This package is pure so it cannot depend upon Report --- package body CXE4006_Common is procedure Single_Controlling_Operand ( RTT : in out Root_Tagged_Type; Test_Number : in Integer; Callee : out Type_Decl_Location) is Expected : Integer; begin case Test_Number is when 1001 => Expected := 100; when 2001 => Expected := 200; when others => raise Failed_Check; end case; if RTT.Common_Record_Field /= Expected then raise Failed_Check; end if; RTT.Common_Record_Field := Expected + 5; Callee := Common_Spec; end Single_Controlling_Operand; end CXE4006_Common; polyorb-2.8~20110207.orig/testsuite/acats/CXE4006/part1.adb0000644000175000017500000000044211750740340022156 0ustar xavierxavierwith PolyORB.Initialization; with PolyORB.POA_Config.RACWs; with PolyORB.Setup.Thread_Pool_Server; -- with PolyORB.DSA_P.Partitions; with CXE4006_Part_A1; with CXE4006_Part_A2; with CXE4006_A; procedure Part1 is begin PolyORB.Initialization.Initialize_World; CXE4006_A; end Part1; polyorb-2.8~20110207.orig/testsuite/acats/CXE4006/cxe4006_part_b.ads0000644000175000017500000000125211750740340023570 0ustar xavierxavier ----------------------------------------------------------------------------- with CXE4006_Common; use CXE4006_Common; with CXE4006_Part_A1; package CXE4006_Part_B is pragma Remote_Call_Interface; -- tagged types that can be passed between partitions type B_Tagged_Type is new Root_Tagged_Type with null record; procedure Single_Controlling_Operand ( RTT : in out B_Tagged_Type; Test_Number : in Integer; Callee : out Type_Decl_Location); procedure Wrapped_Around ( X : in out Root_Tagged_Type'Class; Test_Number : in Integer; Callee : out Type_Decl_Location); end CXE4006_Part_B; polyorb-2.8~20110207.orig/testsuite/acats/CXE4006/cxe4006_part_a2.adb0000644000175000017500000000347111750740340023635 0ustar xavierxavier ----------------------------------------------------------------------------- with Report; with CXE4006_Part_B; with CXE4006_Normal; package body CXE4006_Part_A2 is procedure Single_Controlling_Operand ( RTT : in out A2_Tagged_Type; Test_Number : in Integer; Callee : out Type_Decl_Location) is Expected : Integer := 0; Expected_String : String_20; begin case Test_Number is when 1004 => Expected := 130; Expected_String := "12345678901234567890"; when 2004 => Expected := 230; Expected_String := "24680135790987654321"; when others => Report.Failed ("CXE4006_Part_A2 bad test number" & Integer'Image (Test_Number)); end case; if RTT.Common_Record_Field /= Expected then Report.Failed ("CXE4006_Part_A2 expected" & Integer'Image (Expected) & " but received" & Integer'Image (RTT.Common_Record_Field) & " in test" & Integer'Image (Test_Number)); end if; if RTT.A2_Component /= Expected_String then Report.Failed ("CXE4006_Part_A2 expected '" & Expected_String & "' but received '" & RTT.A2_Component & "' in test" & Integer'Image (Test_Number)); end if; RTT.Common_Record_Field := Expected + 8; Callee := Part_A2_Spec; end Single_Controlling_Operand; -- pass thru procedure procedure Call_B ( X : in out Root_Tagged_Type'Class; Test_Number : in Integer; Callee : out Type_Decl_Location) is begin CXE4006_Part_B.Wrapped_Around (X, Test_Number, Callee); end Call_B; end CXE4006_Part_A2; polyorb-2.8~20110207.orig/testsuite/acats/CXE4006/local.gpr0000644000175000017500000000070011750740340022260 0ustar xavierxavierwith "polyorb", "polyorb_test_common"; project local is Dir := external ("Test_Dir"); Obj_Dir := PolyORB_Test_Common.Build_Dir & Dir; for Object_Dir use Obj_Dir; for Source_Dirs use (Obj_Dir, PolyORB_Test_Common.Source_Dir & Dir); package Compiler is for Default_Switches ("Ada") use PolyORB_Test_Common.Compiler'Default_Switches ("Ada"); end Compiler; for Main use ("part1.adb", "part2.adb"); end local; polyorb-2.8~20110207.orig/testsuite/acats/CXE4006/cxe4006_b.adb0000644000175000017500000002023011750740340022516 0ustar xavierxavier ----------------------------------------------------------------------------- with CXE4006_Common; use CXE4006_Common; with CXE4006_Normal; with CXE4006_Part_A1; with CXE4006_Part_A2; with CXE4006_Part_B; with Report; procedure CXE4006_B is ----------------------- -- -- Service Routine procedure Start_Test (Test_Number : Integer) is begin if Verbose then Report.Comment ("starting test" & Integer'Image (Test_Number)); end if; end Start_Test; ----------------------- -- -- Check that calls can be made to remote procedures when a -- dispatching call is made where the controlling operand -- designates a type declared in a remote call interface package. procedure Dispatching_Test is Root_Obj : CXE4006_Common.Root_Tagged_Type; A1_1_Obj : CXE4006_Part_A1.A1_Tagged_Type_1; A1_2_Obj : CXE4006_Part_A1.A1_Tagged_Type_2; A2_Obj : CXE4006_Part_A2.A2_Tagged_Type; B_Obj : CXE4006_Part_B.B_Tagged_Type; Callee : Type_Decl_Location; begin if Verbose then Report.Comment ("starting dispatching test"); end if; Start_Test (1001); -- not remote Root_Obj.Common_Record_Field := 100; Single_Controlling_Operand ( Root_Tagged_Type'Class(Root_Obj), 1001, Callee); if Root_Obj.Common_Record_Field /= 105 then Report.Failed ("test 1001 expected 105 received" & Integer'Image (Root_Obj.Common_Record_Field)); end if; if Callee /= Common_Spec then Report.Failed ("test 1001 callee was " & Type_Decl_Location'Image (Callee)); end if; Start_Test (1002); -- remote A1_1_Obj.Common_Record_Field := 110; Single_Controlling_Operand ( Root_Tagged_Type'Class(A1_1_Obj), 1002, Callee); if A1_1_Obj.Common_Record_Field /= 116 then Report.Failed ("test 1002 expected 116 received" & Integer'Image (A1_1_Obj.Common_Record_Field)); end if; if Callee /= Part_A1_1_Spec then Report.Failed ("test 1002 callee was " & Type_Decl_Location'Image (Callee)); end if; Start_Test (1003); -- remote A1_2_Obj.Common_Record_Field := 120; Single_Controlling_Operand ( Root_Tagged_Type'Class(A1_2_Obj), 1003, Callee); if A1_2_Obj.Common_Record_Field /= 127 then Report.Failed ("test 1003 expected 127 received" & Integer'Image (A1_2_Obj.Common_Record_Field)); end if; if Callee /= Part_A1_2_Spec then Report.Failed ("test 1003 callee was " & Type_Decl_Location'Image (Callee)); end if; Start_Test (1004); -- remote A2_Obj.Common_Record_Field := 130; A2_Obj.A2_Component := "12345678901234567890"; Single_Controlling_Operand ( Root_Tagged_Type'Class(A2_Obj), 1004, Callee); if A2_Obj.Common_Record_Field /= 138 then Report.Failed ("test 1004 expected 138 received" & Integer'Image (A2_Obj.Common_Record_Field)); end if; if Callee /= Part_A2_Spec then Report.Failed ("test 1004 callee was " & Type_Decl_Location'Image (Callee)); end if; Start_Test (1005); B_Obj.Common_Record_Field := 140; Single_Controlling_Operand ( Root_Tagged_Type'Class(B_Obj), 1005, Callee); if B_Obj.Common_Record_Field /= 149 then Report.Failed ("test 1005 expected 149 received" & Integer'Image (B_Obj.Common_Record_Field)); end if; if Callee /= Part_B_Spec then Report.Failed ("test 1005 callee was " & Type_Decl_Location'Image (Callee)); end if; exception when others => Report.Failed ("unexpected exception in Dispatching_Test"); end Dispatching_Test; ----------------------- -- -- Check that tagged types can be passed between partitions -- when passed as a class-wide type. procedure Class_Wide_Test is Root_Obj : CXE4006_Common.Root_Tagged_Type; A1_1_Obj : CXE4006_Part_A1.A1_Tagged_Type_1; A1_2_Obj : CXE4006_Part_A1.A1_Tagged_Type_2; A2_Obj : CXE4006_Part_A2.A2_Tagged_Type; B_Obj : CXE4006_Part_B.B_Tagged_Type; Callee : Type_Decl_Location; begin if Verbose then Report.Comment ("starting class wide test"); end if; Start_Test (2001); Root_Obj.Common_Record_Field := 200; CXE4006_Part_A2.Call_B (Root_Obj, 2001, Callee); if Root_Obj.Common_Record_Field /= 205 then Report.Failed ("test 2001 expected 205 received" & Integer'Image (Root_Obj.Common_Record_Field)); end if; if Callee /= Common_Spec then Report.Failed ("test 2001 callee was " & Type_Decl_Location'Image (Callee)); end if; Start_Test (2002); A1_1_Obj.Common_Record_Field := 210; CXE4006_Part_A2.Call_B (A1_1_Obj, 2002, Callee); if A1_1_Obj.Common_Record_Field /= 216 then Report.Failed ("test 2002 expected 216 received" & Integer'Image (A1_1_Obj.Common_Record_Field)); end if; if Callee /= Part_A1_1_Spec then Report.Failed ("test 2002 callee was " & Type_Decl_Location'Image (Callee)); end if; Start_Test (2003); -- remote A1_2_Obj.Common_Record_Field := 220; CXE4006_Part_A2.Call_B (A1_2_Obj, 2003, Callee); if A1_2_Obj.Common_Record_Field /= 227 then Report.Failed ("test 2003 expected 227 received" & Integer'Image (A1_2_Obj.Common_Record_Field)); end if; if Callee /= Part_A1_2_Spec then Report.Failed ("test 2003 callee was " & Type_Decl_Location'Image (Callee)); end if; Start_Test (2004); -- remote A2_Obj.Common_Record_Field := 230; A2_Obj.A2_Component := "24680135790987654321"; CXE4006_Part_A2.Call_B (A2_Obj, 2004, Callee); if A2_Obj.Common_Record_Field /= 238 then Report.Failed ("test 2004 expected 238 received" & Integer'Image (A2_Obj.Common_Record_Field)); end if; if Callee /= Part_A2_Spec then Report.Failed ("test 2004 callee was " & Type_Decl_Location'Image (Callee)); end if; Start_Test (2005); B_Obj.Common_Record_Field := 240; CXE4006_Part_A2.Call_B (B_Obj, 2005, Callee); if B_Obj.Common_Record_Field /= 249 then Report.Failed ("test 2005 expected 249 received" & Integer'Image (B_Obj.Common_Record_Field)); end if; if Callee /= Part_B_Spec then Report.Failed ("test 2005 callee was " & Type_Decl_Location'Image (Callee)); end if; end Class_Wide_Test; ----------------------- -- -- In a remote subprogram call with a formal parameter of a -- class-wide type, check that Program_Error is raised if the -- actual parameter identifies a tagged type not declared in a -- pure, shared passive, or the visible part of a remote types or -- remote call interface package. procedure Class_Wide_Exception_Test is Normal_Obj : CXE4006_Normal.Normal_Spec_Tagged_Type; Callee : Type_Decl_Location; begin if Verbose then Report.Comment ("starting class wide exception test"); end if; CXE4006_Part_A2.Call_B (Normal_Obj, 3001, Callee); Report.Failed ("Program_Error expected but did not occur - test 3001"); exception when Program_Error => -- expected exception if Verbose then Report.Comment ("Program_Error raised as expected - test 3001"); end if; when others => Report.Failed ("Program_Error expected but some other exception" & " was raised instead - test 3001"); end Class_Wide_Exception_Test; ----------------------- begin -- CXE4006_B Report.Test ("CXE4006_B", "Remote dispatching calls"); -- make sure partitioning was performed correctly if CXE4006_Part_A1'Partition_ID = CXE4006_B'Partition_ID then Report.Failed ("Partitioning Error - CXE4006_Part_A1 and CXE4006_B" & " are in the same partition."); end if; if CXE4006_Part_A2'Partition_ID = CXE4006_B'Partition_ID then Report.Failed ("Partitioning Error - CXE4006_Part_A2 and CXE4006_B" & " are in the same partition."); end if; if CXE4006_Part_B'Partition_ID /= CXE4006_B'Partition_ID then Report.Failed ("Partitioning Error - CXE4006_Part_B and CXE4006_B" & " are not in the same partition."); end if; -- do the tests Dispatching_Test; Class_Wide_Test; Class_Wide_Exception_Test; -- finish up CXE4006_Part_A1.Quit; Report.Result; end CXE4006_B; polyorb-2.8~20110207.orig/testsuite/acats/CXE4006/cxe4006_part_b.adb0000644000175000017500000000602411750740340023551 0ustar xavierxavier ----------------------------------------------------------------------------- with CXE4006_Part_A1; with CXE4006_Part_A2; with CXE4006_Normal; with Report; with Ada.Tags; use type Ada.Tags.Tag; package body CXE4006_Part_B is type B_Body_Tagged_Type is new CXE4006_Common.Root_Tagged_Type with null record; Root_Obj : CXE4006_Common.Root_Tagged_Type; A1_1_Obj : CXE4006_Part_A1.A1_Tagged_Type_1; A1_2_Obj : CXE4006_Part_A1.A1_Tagged_Type_2; A2_Obj : CXE4006_Part_A2.A2_Tagged_Type; B_Obj : CXE4006_Part_B.B_Tagged_Type; B_Body_Obj : CXE4006_Part_B.B_Body_Tagged_Type; Normal_Obj : CXE4006_Normal.Normal_Spec_Tagged_Type; procedure Single_Controlling_Operand ( RTT : in out B_Tagged_Type; Test_Number : in Integer; Callee : out Type_Decl_Location) is Expected : Integer := 0; begin case Test_Number is when 1005 => Expected := 140; when 2005 => Expected := 240; when others => Report.Failed ("CXE4006_Part_A2 bad test number" & Integer'Image (Test_Number)); end case; if RTT.Common_Record_Field /= Expected then Report.Failed ("CXE4006_Part_B expected" & Integer'Image (Expected) & " but received" & Integer'Image (RTT.Common_Record_Field) & " in test" & Integer'Image (Test_Number)); end if; RTT.Common_Record_Field := Expected + 9; Callee := Part_B_Spec; end Single_Controlling_Operand; -- this procedure will pass all the parameters along to -- partition A CXE4006_Part_A1.Make_Dispatching_Call_With. -- Prior to making the call, the tag of X is checked to make -- sure it is correct. procedure Wrapped_Around ( X : in out Root_Tagged_Type'Class; Test_Number : in Integer; Callee : out Type_Decl_Location) is Good_Tag : Boolean := False; begin if Verbose then Report.Comment ("wrap around test number" & Integer'Image (Test_Number)); end if; case Test_Number is when 2001 => Good_Tag := X'Tag = CXE4006_Common.Root_Tagged_Type'Tag; when 2002 => Good_Tag := X'Tag = CXE4006_Part_A1.A1_Tagged_Type_1'Tag; when 2003 => Good_Tag := X'Tag = CXE4006_Part_A1.A1_Tagged_Type_2'Tag; when 2004 => Good_Tag := X'Tag = CXE4006_Part_A2.A2_Tagged_Type'Tag; when 2005 => Good_Tag := X'Tag = CXE4006_Part_B.B_Tagged_Type'Tag; when 3001 => Report.Failed ("test 3001 call should not have been made"); return; -- just to avoid extra error messages when others => Report.Failed ("bad test number in wrap around" & Integer'Image (Test_Number)); end case; if not Good_Tag then Report.Failed ("unexpected tag value in wrap around test" & Integer'Image (Test_Number)); end if; CXE4006_Part_A1.Make_Dispatching_Call_With (X, Test_Number, Callee); end Wrapped_Around; end CXE4006_Part_B; polyorb-2.8~20110207.orig/testsuite/acats/CXE1001/0000755000175000017500000000000011750740340020447 5ustar xavierxavierpolyorb-2.8~20110207.orig/testsuite/acats/CXE1001/cxe1001_p.adb0000644000175000017500000000056111750740340022521 0ustar xavierxavierpragma Style_Checks (Off); ------------------------------------------------------------------------ -- The following are the two library level declarations who's Partition_ID -- attributes are to be checked with Report; -- procedure CXE1001_P is -- Note: This module is not declared-pure begin Report.Comment ("Executing Procedure CXE1001_P"); end CXE1001_P; polyorb-2.8~20110207.orig/testsuite/acats/CXE1001/Makefile.local0000644000175000017500000000000011750740340023166 0ustar xavierxavierpolyorb-2.8~20110207.orig/testsuite/acats/CXE1001/part2.adb0000644000175000017500000000036411750740340022152 0ustar xavierxavierpragma Warnings (Off); with PolyORB.Setup.Client; with PolyORB.POA_Config.RACWs; pragma Warnings (On); with PolyORB.Initialization; with CXE1001_B; procedure Part2 is begin PolyORB.Initialization.Initialize_World; CXE1001_B; end Part2; polyorb-2.8~20110207.orig/testsuite/acats/CXE1001/cxe1001_q.adb0000644000175000017500000000027311750740340022522 0ustar xavierxavierpragma Style_Checks (Off); with Report; -- procedure CXE1001_Q is -- Note: This module is not declared-pure begin Report.Comment ("Executing Procedure CXE1001_Q"); end CXE1001_Q; polyorb-2.8~20110207.orig/testsuite/acats/CXE1001/part1.adb0000644000175000017500000000040011750740340022140 0ustar xavierxavierpragma Warnings (Off); with PolyORB.Setup.Thread_Pool_Server; with PolyORB.POA_Config.RACWs; pragma Warnings (On); with PolyORB.Initialization; with CXE1001_A; procedure Part1 is begin PolyORB.Initialization.Initialize_World; CXE1001_A; end Part1; polyorb-2.8~20110207.orig/testsuite/acats/CXE1001/local.gpr0000644000175000017500000000070011750740340022250 0ustar xavierxavierwith "polyorb", "polyorb_test_common"; project local is Dir := external ("Test_Dir"); Obj_Dir := PolyORB_Test_Common.Build_Dir & Dir; for Object_Dir use Obj_Dir; for Source_Dirs use (Obj_Dir, PolyORB_Test_Common.Source_Dir & Dir); package Compiler is for Default_Switches ("Ada") use PolyORB_Test_Common.Compiler'Default_Switches ("Ada"); end Compiler; for Main use ("part1.adb", "part2.adb"); end local; polyorb-2.8~20110207.orig/testsuite/acats/CXE1001/cxe1001_b.adb0000644000175000017500000000206711750740340022506 0ustar xavierxavierpragma Style_Checks (Off); ------------------------------------------------------------------------ with Report; with System; with CXE1001_P; -- a procedure who's ID is to be checked with CXE1001_Q; -- a procedure who's ID is to be checked procedure CXE1001_B is type Hold_Partition_ID is range System.Min_Int..System.Max_Int; P_ID : Hold_Partition_ID; Q_ID : Hold_Partition_ID; begin Report.Test ("CXE1001_B", "Check Partition IDs. " & "-- This is the SECOND PARTITION"); CXE1001_P; CXE1001_Q; P_ID := CXE1001_P'Partition_ID; Q_ID := CXE1001_Q'Partition_ID; if P_ID /= Q_ID then Report.Failed ("Partition IDs of the procedures in this " & "partition are not the same"); end if; Report.Special_Action ("Partition ID of SECOND Partition is: " & Hold_Partition_ID'image(P_ID) & ". Check that this is different from that " & "of the FIRST partition"); Report.Result; end CXE1001_B; polyorb-2.8~20110207.orig/testsuite/acats/CXE1001/cxe1001_a.adb0000644000175000017500000000261011750740340022477 0ustar xavierxavierpragma Warnings (Off); pragma Style_Checks (Off); ------------------------------------------------------------------------ with Report; with CXE1001_P; -- a procedure who's ID is to be checked with CXE1001_Q; -- a procedure who's ID is to be checked with System; procedure CXE1001_A is type Hold_Partition_ID is range System.Min_Int..System.Max_Int; P_ID : Hold_Partition_ID; Q_ID : Hold_Partition_ID; Main_ID : Hold_Partition_ID := CXE1001_A'Partition_ID; begin Report.Test ("CXE1001_A", "Check Partition IDs. " & "-- This is the FIRST PARTITION"); CXE1001_P; CXE1001_Q; P_ID := CXE1001_P'Partition_ID; Q_ID := CXE1001_Q'Partition_ID; if P_ID /= Q_ID then Report.Failed ("Partition IDs of the procedures in this " & "partition are not the same"); end if; if P_ID /= Main_ID then Report.Failed ("Partition ID of main not same as procedure " & "in partition" & Hold_Partition_ID'Image (Main_ID) & Hold_Partition_ID'Image (P_ID) ); end if; Report.Special_Action ("Partition ID of FIRST Partition is: " & Hold_Partition_ID'image(P_ID) & ". Check that this is different from that " & "of the SECOND partition"); Report.Result; end CXE1001_A; polyorb-2.8~20110207.orig/testsuite/acats/CXE4001/0000755000175000017500000000000011750740340020452 5ustar xavierxavierpolyorb-2.8~20110207.orig/testsuite/acats/CXE4001/Makefile.local0000644000175000017500000000000011750740340023171 0ustar xavierxavierpolyorb-2.8~20110207.orig/testsuite/acats/CXE4001/cxe4001_partition_a.ads0000644000175000017500000000064211750740340024622 0ustar xavierxavierpragma Style_Checks (Off); package CXE4001_Partition_A is pragma Remote_Call_Interface; -- these procedures are the control actions for each test procedure Predefined_Simple; procedure Userdefined_Simple; procedure Invisible_Simple; procedure Invisible_Complex_1; procedure Invisible_Complex_2; -- service routine for Invisible_Complex test procedure Raise_Invisible; end CXE4001_Partition_A; polyorb-2.8~20110207.orig/testsuite/acats/CXE4001/part2.adb0000644000175000017500000000040011750740340022144 0ustar xavierxavierwith PolyORB.Initialization; pragma Warnings (Off); with PolyORB.POA_Config.RACWs; with PolyORB.Setup.Thread_Pool_Server; pragma Warnings (On); with CXE4001_B; procedure Part2 is begin PolyORB.Initialization.Initialize_World; CXE4001_B; end Part2; polyorb-2.8~20110207.orig/testsuite/acats/CXE4001/cxe4001_a.adb0000644000175000017500000000175511750740340022516 0ustar xavierxavierpragma Style_Checks (Off); pragma Warnings (Off); ----------------------------------------------------------------------------- with CXE4001_Partition_A; with CXE4001_Partition_B; with Report; with System.RPC; procedure CXE4001_A is begin Report.Test ("CXE4001_A", "Exception handling across partitions"); delay 2.0; -- XXX @@ allow other part'n to start (actually should -- wait for it to become ready! -- make sure partitioning is performed if CXE4001_Partition_A'Partition_ID = CXE4001_Partition_B'Partition_ID then Report.Failed ("Partitioning Error - CXE4001_Partition_A and " & "CXE4001_Partition_B are in the same partition."); end if; -- now do the tests CXE4001_Partition_A.Predefined_Simple; CXE4001_Partition_A.Userdefined_Simple; CXE4001_Partition_A.Invisible_Simple; CXE4001_Partition_A.Invisible_Complex_1; CXE4001_Partition_A.Invisible_Complex_2; -- all done CXE4001_Partition_B.Finished; Report.Result; end CXE4001_A; polyorb-2.8~20110207.orig/testsuite/acats/CXE4001/part1.adb0000644000175000017500000000040011750740340022143 0ustar xavierxavierwith PolyORB.Initialization; pragma Warnings (Off); with PolyORB.POA_Config.RACWs; with PolyORB.Setup.Thread_Pool_Server; pragma Warnings (On); with CXE4001_A; procedure Part1 is begin PolyORB.Initialization.Initialize_World; CXE4001_A; end Part1; polyorb-2.8~20110207.orig/testsuite/acats/CXE4001/cxe4001_partition_b.ads0000644000175000017500000000050511750740340024621 0ustar xavierxavierpragma Style_Checks (Off); package CXE4001_Partition_B is pragma Remote_Call_Interface; procedure Raise_Program_Error; procedure Raise_Visible_Exception; procedure Raise_Invisible_Exception; procedure Call_A_Raise_Invisible_1; procedure Call_A_Raise_Invisible_2; procedure Finished; end CXE4001_Partition_B; polyorb-2.8~20110207.orig/testsuite/acats/CXE4001/cxe4001_partition_b.adb0000644000175000017500000000314111750740340024577 0ustar xavierxavierpragma Style_Checks (Off); pragma Warnings (Off); ----------------------------------------------------------------------------- with CXE4001_Decl_Pure; with CXE4001_Partition_A; with Report; package body CXE4001_Partition_B is procedure Raise_Program_Error is begin raise Program_Error; end Raise_Program_Error; procedure Raise_Visible_Exception is begin raise CXE4001_Decl_Pure.Visible_User_Defined_Exception; end Raise_Visible_Exception; procedure Raise_Invisible_Exception is Invisible : exception; begin raise Invisible; end Raise_Invisible_Exception; procedure Call_A_Raise_Invisible_1 is begin CXE4001_Partition_A.Raise_Invisible; Report.Failed ("exception propagation in Call_A_Raise_Invisible_1"); end Call_A_Raise_Invisible_1; -- Call_A_Raise_Invisible_2 differs from *_1 in that it handles the -- invisible exception and then re-raises it. procedure Call_A_Raise_Invisible_2 is begin CXE4001_Partition_A.Raise_Invisible; Report.Failed ("exception propagation in Call_A_Raise_Invisible_2"); exception when others => raise; -- re-raise the invisible exception end Call_A_Raise_Invisible_2; -- the following task is used to keep this partition from -- completing until partition A informs it that the test is -- finished. This is done by calling the Finished procedure -- in the specification of this package. task Coordinate_Completion is entry Finished; end Coordinate_Completion; task body Coordinate_Completion is begin accept Finished; Report.Result; end Coordinate_Completion; procedure Finished is begin Coordinate_Completion.Finished; end Finished; end CXE4001_Partition_B; polyorb-2.8~20110207.orig/testsuite/acats/CXE4001/cxe4001_decl_pure.ads0000644000175000017500000000053611750740340024255 0ustar xavierxavierpragma Style_Checks (Off); package CXE4001_Decl_Pure is pragma Pure; Visible_User_Defined_Exception : exception; -- The setting of the following flag affects how much output is -- produced when the test runs. This output can be used to help -- debug problems with the test. Verbose : constant Boolean := False; end CXE4001_Decl_Pure; polyorb-2.8~20110207.orig/testsuite/acats/CXE4001/cxe4001_partition_a.adb0000644000175000017500000001004611750740340024600 0ustar xavierxavierpragma Style_Checks (Off); ----------------------------------------------------------------------------- with CXE4001_Decl_Pure; with CXE4001_Partition_B; with Report; with System.RPC; package body CXE4001_Partition_A is -- the following exception is only defined in partition A Exception_Local_To_A : exception; procedure Predefined_Simple is begin if CXE4001_Decl_Pure.Verbose then Report.Comment ("Check that a predefined exception can be raised" & " in one partition and handled in another"); end if; CXE4001_Partition_B.Raise_Program_Error; Report.Failed ("Predefined exception was not propagated across partitions"); exception when Program_Error => null; -- passed when System.RPC.Communication_Error => Report.Failed ("Communication_Error occurred"); when others => Report.Failed ("Wrong exception was propagated across partitions (1)"); end Predefined_Simple; procedure Userdefined_Simple is begin if CXE4001_Decl_Pure.Verbose then Report.Comment ("Check that an exception declared in a shared " & " package can be raised in one partition and" & " handled in another"); end if; CXE4001_Partition_B.Raise_Visible_Exception; Report.Failed ("Shared exception was not propagated across partitions"); exception when CXE4001_Decl_Pure.Visible_User_Defined_Exception => null; -- passed when System.RPC.Communication_Error => Report.Failed ("Communication_Error occurred"); when others => Report.Failed ("Wrong exception was propagated across partitions (2)"); end Userdefined_Simple; procedure Invisible_Simple is begin if CXE4001_Decl_Pure.Verbose then Report.Comment ("Check that an exception declared in another" & " partition can be handled with an 'others'" & " exception handler"); end if; CXE4001_Partition_B.Raise_Invisible_Exception; Report.Failed ("Invisible exception was not propagated across partitions"); exception when System.RPC.Communication_Error => Report.Failed ("Communication_Error occurred"); when others => null; -- passed end Invisible_Simple; procedure Invisible_Complex_1 is begin if CXE4001_Decl_Pure.Verbose then Report.Comment ("Check that an exception declared in this partition" & " and not visible to the other partition is properly" & " handled when it propagates from this partition," & " through the other partition, and back to this" & " partition."); end if; CXE4001_Partition_B.Call_A_Raise_Invisible_1; Report.Failed ("Local exception was not propagated across partitions"); exception when Exception_Local_To_A => null; -- passed when System.RPC.Communication_Error => Report.Failed ("Communication_Error occurred"); when others => Report.Failed ("Wrong exception was propagated across partitions (3)"); end Invisible_Complex_1; procedure Invisible_Complex_2 is begin if CXE4001_Decl_Pure.Verbose then Report.Comment ("Check that an exception declared in this partition" & " and not visible to the other partition is properly" & " handled when it propagates from this partition," & " is handled and then re-raised in the other" & " partition, and propagated back to this" & " partition."); end if; CXE4001_Partition_B.Call_A_Raise_Invisible_2; Report.Failed ("Local re-raised exception was not propagated" & " across partitions"); exception when Exception_Local_To_A => null; -- passed when System.RPC.Communication_Error => Report.Failed ("Communication_Error occurred"); when others => Report.Failed ("Wrong exception was propagated across partitions (4)"); end Invisible_Complex_2; -- service routine for Invisible_Complex test procedure Raise_Invisible is begin -- Report.Comment ("Round-trip call complete. "); raise Exception_Local_To_A; end Raise_Invisible; end CXE4001_Partition_A; polyorb-2.8~20110207.orig/testsuite/acats/CXE4001/local.gpr0000644000175000017500000000070011750740340022253 0ustar xavierxavierwith "polyorb", "polyorb_test_common"; project local is Dir := external ("Test_Dir"); Obj_Dir := PolyORB_Test_Common.Build_Dir & Dir; for Object_Dir use Obj_Dir; for Source_Dirs use (Obj_Dir, PolyORB_Test_Common.Source_Dir & Dir); package Compiler is for Default_Switches ("Ada") use PolyORB_Test_Common.Compiler'Default_Switches ("Ada"); end Compiler; for Main use ("part1.adb", "part2.adb"); end local; polyorb-2.8~20110207.orig/testsuite/acats/CXE4001/cxe4001_b.adb0000644000175000017500000000112111750740340022502 0ustar xavierxavierpragma Style_Checks (Off); pragma Warnings (Off); ----------------------------------------------------------------------------- with CXE4001_Partition_B; with CXE4001_Partition_A; with Report; with System.RPC; procedure CXE4001_B is begin Report.Test ("CXE4001_B", "Server partition of exception handling test"); if CXE4001_Partition_A'Partition_ID = CXE4001_Partition_B'Partition_ID then Report.Failed ("Partitioning Error - 1 and Part_B are in the" & " same partition."); end if; -- Report.Result is called in the body of CXE4001_Partition_B. end CXE4001_B; polyorb-2.8~20110207.orig/testsuite/acats/CXE4005/0000755000175000017500000000000011750740340020456 5ustar xavierxavierpolyorb-2.8~20110207.orig/testsuite/acats/CXE4005/cxe4005_part_a1.adb0000644000175000017500000000414111750740340023625 0ustar xavierxavier ----------------------------------------------------------------------------- with Report; with CXE4005_Part_A2; with CXE4005_Part_B; with CXE4005_Normal; with CXE4005_Remote_Types; package body CXE4005_Part_A1 is Root_Obj : aliased CXE4005_Common.Root_Tagged_Type; RT_Obj : aliased CXE4005_Remote_Types.RT_Tagged_Type; Normal_Obj : aliased CXE4005_Normal.Cant_Use_In_Remote_Call; --------- partition termination coordination ---------- -- use a task to prevent the partition from completing its execution -- until the main procedure in partition B tells it to quit, and to insure -- that Report.Result is not called until after the partition is started. task Wait_For_Quit is entry Can_Quit; entry Quit; end Wait_For_Quit; task body Wait_For_Quit is begin accept Can_Quit; accept Quit; Report.Result; end Wait_For_Quit; procedure Can_Quit is begin Wait_For_Quit.Can_Quit; end Can_Quit; procedure Quit is begin Wait_For_Quit.Quit; end Quit; ---------- function Get_RACWT (Which_Type : Type_Selection) return CXE4005_Part_A1.RACWT is begin case Which_Type is when Common_Spec => return Root_Obj'Access; when RT_Spec => return RT_Obj'Access; when B_Body => return null; when Normal_Spec => return Normal_Obj'Access; end case; end Get_RACWT; procedure Takes_Class_Wide (X : CXE4005_Common.Open_Tagged_Type'Class) is begin CXE4005_Common.Open_Op(X); end Takes_Class_Wide; package Nested is type Body_Open_Tagged_Type is new CXE4005_Common.Open_Tagged_Type with null record; end Nested; function Return_Open_Tagged_Type_Class return CXE4005_Common.Open_Tagged_Type'Class is -- Return an object of a type not visible to the B partition. Obj : Nested.Body_Open_Tagged_Type; begin return Obj; end Return_Open_Tagged_Type_Class; begin Set_Serial_Number (Root_Tagged_Type(Root_Obj)'Access, 101); Set_Serial_Number (Root_Tagged_Type(RT_Obj)'Access, 106); -- no 107 object Set_Serial_Number (Root_Tagged_Type(Normal_Obj)'Access, 108); end CXE4005_Part_A1; polyorb-2.8~20110207.orig/testsuite/acats/CXE4005/cxe4005_normal.adb0000644000175000017500000000176011750740340023572 0ustar xavierxavier with Report; package body CXE4005_Normal is procedure Single_Controlling_Operand ( RTT : access Cant_Use_In_Remote_Call; Test_Number : in Integer; Obj_SN : out Integer) is begin Report.Failed ("Call made where type is declared in a normal " & "package. Test number " & Integer'Image (Test_Number)); Obj_SN := Serial_Number(RTT); end Single_Controlling_Operand; procedure Dual_Controlling_Operands ( RTT1 : access Cant_Use_In_Remote_Call; RTT2 : access Cant_Use_In_Remote_Call; Test_Number : in Integer; Obj_SN1 : out Integer; Obj_SN2 : out Integer) is begin Report.Failed ("Call made where type is declared in a normal " & "package. Test number " & Integer'Image (Test_Number)); Obj_SN1 := Serial_Number(RTT1); Obj_SN2 := Serial_Number(RTT2); end Dual_Controlling_Operands; end CXE4005_Normal; polyorb-2.8~20110207.orig/testsuite/acats/CXE4005/Makefile.local0000644000175000017500000000000011750740340023175 0ustar xavierxavierpolyorb-2.8~20110207.orig/testsuite/acats/CXE4005/cxe4005_a.adb0000644000175000017500000000070711750740340022522 0ustar xavierxavier ----------------------------------------------------------------------------- with CXE4005_Common; with CXE4005_Part_A1; with CXE4005_Part_A2; with Report; procedure CXE4005_A is begin -- this partition is a server that deals with calls -- from CXE4005_B. Report.Test ("CXE4005_A", "Remote dispatching calls (server)"); CXE4005_Part_A1.Can_Quit; -- OK to quit now. -- Report.Result is called in the body of CXE4005_Part_A1. end CXE4005_A; polyorb-2.8~20110207.orig/testsuite/acats/CXE4005/part2.adb0000644000175000017500000000035011750740340022154 0ustar xavierxavierwith PolyORB.Initialization; with PolyORB.POA_Config.RACWs; with PolyORB.Setup.Thread_Pool_Server; with CXE4005_Part_B; with CXE4005_B; procedure Part2 is begin PolyORB.Initialization.Initialize_World; CXE4005_B; end Part2; polyorb-2.8~20110207.orig/testsuite/acats/CXE4005/cxe4005_part_a1.ads0000644000175000017500000000130511750740340023645 0ustar xavierxavier ----------------------------------------------------------------------------- with CXE4005_Common; use CXE4005_Common; package CXE4005_Part_A1 is pragma Remote_Call_Interface; type RACWT is access all CXE4005_Common.Root_Tagged_Type'Class; -- provide remote access values to other partitions function Get_RACWT (Which_Type : Type_Selection) return CXE4005_Part_A1.RACWT; -- for checking E.4(18);6.0. procedure Takes_Class_Wide (X : CXE4005_Common.Open_Tagged_Type'Class); function Return_Open_Tagged_Type_Class return CXE4005_Common.Open_Tagged_Type'Class; -- coordination of test termination across partitions procedure Can_Quit; procedure Quit; end CXE4005_Part_A1; polyorb-2.8~20110207.orig/testsuite/acats/CXE4005/cxe4005_remote_types.adb0000644000175000017500000000202311750740340025012 0ustar xavierxavier package body CXE4005_Remote_Types is -- -- The serial number for all objects of RT_Tagged_Type will contain -- a 6 as the least significant digit. Make sure the correct object -- is passed to these routines. -- procedure Single_Controlling_Operand ( RTT : access RT_Tagged_Type; Test_Number : in Integer; Obj_SN : out Integer) is begin Obj_SN := Serial_Number(RTT); if Serial_Number(RTT) mod 10 /= 6 then raise Wrong_Object; end if; end Single_Controlling_Operand; procedure Dual_Controlling_Operands ( RTT1 : access RT_Tagged_Type; RTT2 : access RT_Tagged_Type; Test_Number : in Integer; Obj_SN1 : out Integer; Obj_SN2 : out Integer) is begin Obj_SN1 := Serial_Number(RTT1); Obj_SN2 := Serial_Number(RTT2); if Serial_Number(RTT1) mod 10 /= 6 or Serial_Number(RTT2) mod 10 /= 6 then raise Wrong_Object; end if; end Dual_Controlling_Operands; end CXE4005_Remote_Types; polyorb-2.8~20110207.orig/testsuite/acats/CXE4005/cxe4005_normal.ads0000644000175000017500000000136511750740340023614 0ustar xavierxavier ----------------------------------------------------------------------------- with CXE4005_Common; package CXE4005_Normal is type Cant_Use_In_Remote_Call is new CXE4005_Common.Root_Tagged_Type with null record; procedure Single_Controlling_Operand ( RTT : access Cant_Use_In_Remote_Call; Test_Number : in Integer; Obj_SN : out Integer); procedure Dual_Controlling_Operands ( RTT1 : access Cant_Use_In_Remote_Call; RTT2 : access Cant_Use_In_Remote_Call; Test_Number : in Integer; Obj_SN1 : out Integer; Obj_SN2 : out Integer); type Open_But_Not_For_Export is new CXE4005_Common.Open_Tagged_Type with null record; end CXE4005_Normal; polyorb-2.8~20110207.orig/testsuite/acats/CXE4005/cxe4005_common.ads0000644000175000017500000000335411750740340023614 0ustar xavierxavier package CXE4005_Common is pragma Pure; -- controls progress output from the tests. Verbose : constant Boolean := False; -- exception to signify that the serial number of an object -- was not a one of the expected values for that type Wrong_Object : exception; -- identification of where a type is declared and where -- an access type was evaluated that refers to an object -- of that type. type Type_Selection is (Common_Spec, -- xx1 RT_Spec, -- xx6 B_Body, -- xx7 Normal_Spec); -- xx8 type Access_Evaluation is (A1, -- 1xx A2, -- 2xx B); -- 3xx -- root tagged type for remote access to class wide type test type Root_Tagged_Type is tagged limited private; procedure Single_Controlling_Operand ( RTT : access Root_Tagged_Type; Test_Number : in Integer; Obj_SN : out Integer); procedure Dual_Controlling_Operands ( RTT1 : access Root_Tagged_Type; RTT2 : access Root_Tagged_Type; Test_Number : in Integer; Obj_SN1 : out Integer; Obj_SN2 : out Integer); procedure Set_Serial_Number ( RTT : access Root_Tagged_Type; Sn : in Integer); function Serial_Number (RTT : access Root_Tagged_Type) return Integer; type Open_Tagged_Type is tagged record Field : Integer; end record; procedure Open_Op (OTT : Open_Tagged_Type); private type Root_Tagged_Type is tagged limited record Serial_Number : Integer := 123; end record; end CXE4005_Common; polyorb-2.8~20110207.orig/testsuite/acats/CXE4005/part1.adb0000644000175000017500000000044211750740340022155 0ustar xavierxavierwith PolyORB.Initialization; with PolyORB.POA_Config.RACWs; with PolyORB.Setup.Thread_Pool_Server; -- with PolyORB.DSA_P.Partitions; with CXE4005_Part_A1; with CXE4005_Part_A2; with CXE4005_A; procedure Part1 is begin PolyORB.Initialization.Initialize_World; CXE4005_A; end Part1; polyorb-2.8~20110207.orig/testsuite/acats/CXE4005/cxe4005_part_a2.ads0000644000175000017500000000055611750740340023655 0ustar xavierxavier ----------------------------------------------------------------------------- with CXE4005_Common; use CXE4005_Common; with CXE4005_Part_A1; package CXE4005_Part_A2 is pragma Remote_Call_Interface; -- provide remote access values to other partitions function Get_RACWT (Which_Type : Type_Selection) return CXE4005_Part_A1.RACWT; end CXE4005_Part_A2; polyorb-2.8~20110207.orig/testsuite/acats/CXE4005/cxe4005_part_b.adb0000644000175000017500000000253111750740340023546 0ustar xavierxavier ----------------------------------------------------------------------------- with CXE4005_Part_A1; with CXE4005_Part_A2; with CXE4005_Normal; with CXE4005_Remote_Types; with Report; package body CXE4005_Part_B is type Not_Available_For_Remote_Call is new CXE4005_Common.Root_Tagged_Type with null record; Root_Obj : aliased CXE4005_Common.Root_Tagged_Type; RT_Obj : aliased CXE4005_Remote_Types.RT_Tagged_Type; Local_Only_Obj : aliased Not_Available_For_Remote_Call; Normal_Obj : aliased CXE4005_Normal.Cant_Use_In_Remote_Call; -- provide access to a remote access value function Get_RACWT (Which_Type : Type_Selection) return CXE4005_Part_A1.RACWT is begin case Which_Type is when Common_Spec => return Root_Obj'Access; when RT_Spec => return RT_Obj'Access; when B_Body => return Local_Only_Obj'Access; when Normal_Spec => return Normal_Obj'Access; end case; end Get_RACWT; begin CXE4005_Common.Set_Serial_Number ( Root_Tagged_Type(Root_Obj)'Access , 301); CXE4005_Common.Set_Serial_Number ( Root_Tagged_Type(RT_Obj)'Access , 306); CXE4005_Common.Set_Serial_Number ( Root_Tagged_Type(Local_Only_Obj)'Access , 307); CXE4005_Common.Set_Serial_Number ( Root_Tagged_Type(Normal_Obj)'Access , 308); end CXE4005_Part_B; polyorb-2.8~20110207.orig/testsuite/acats/CXE4005/cxe4005_b.adb0000644000175000017500000002317411750740340022526 0ustar xavierxavier ----------------------------------------------------------------------------- with CXE4005_Common; use CXE4005_Common; with CXE4005_Normal; with CXE4005_Part_A1; with CXE4005_Part_A2; with CXE4005_Part_B; with Report; procedure CXE4005_B is -- table of remote access values to all the objects of interest. -- Given this table, we can select a remote access value based upon -- the type of the object and where the access attribute was evaluated. type Pointer_Table_Type is array (Access_Evaluation, Type_Selection) of CXE4005_Part_A1.RACWT; Pointers : Pointer_Table_Type; -- table of serial numbers for the objects used in the Pointers table. -- Note that the serial numbers follow the convention that the hundreds -- place indicates the package where the object is declared and the -- least significant digit indicates the type of the object. type Object_SN_Table_Type is array (Access_Evaluation, Type_Selection) of Integer; Objects : Object_SN_Table_Type := ( A1 => (101, 106, 107, 108), A2 => (201, 206, 207, 208), B => (301, 306, 307, 308)); Test_Number : Integer := 100; begin -- CXE4005_B Report.Test ("CXE4005_B", "Remote dispatching calls"); -- make sure partitioning was performed correctly if CXE4005_Part_A1'Partition_ID = CXE4005_B'Partition_ID then Report.Failed ("Partitioning Error - CXE4005_Part_A1 and CXE4005_B" & " are in the same partition."); end if; if CXE4005_Part_A2'Partition_ID = CXE4005_B'Partition_ID then Report.Failed ("Partitioning Error - CXE4005_Part_A2 and CXE4005_B" & " are in the same partition."); end if; if CXE4005_Part_B'Partition_ID /= CXE4005_B'Partition_ID then Report.Failed ("Partitioning Error - CXE4005_Part_B and CXE4005_B" & " are not in the same partition."); end if; -- initialize the table of all access values for TS in Type_Selection loop Pointers (A1, TS) := CXE4005_Part_A1.Get_RACWT (TS); Pointers (A2, TS) := CXE4005_Part_A2.Get_RACWT (TS); Pointers (B, TS) := CXE4005_Part_B.Get_RACWT (TS); end loop; -- Check the legal calls -- This is done by calling Single_Controlling_Operand with -- all the legal remote access to class wide type values we have -- in the Pointers table and check that the serial number of the object -- reported back is the expected value. -- Dual_Controlling_Operands is also called with both operands -- being the same. declare SN1 : Integer; SN2 : Integer; begin for AE in Access_Evaluation loop for TS in Common_Spec .. RT_Spec loop Test_Number := Test_Number + 1; if Verbose then Report.Comment ("Test" & Integer'Image (Test_Number) & " Object SN" & Integer'Image (Objects (AE, TS))); end if; Single_Controlling_Operand (Pointers (AE, TS), Test_Number, SN1); if SN1 /= Objects (AE, TS) then Report.Failed ("Wrong object used in test number" & Integer'Image (Test_Number) & " Expected" & Integer'Image (Objects (AE, TS)) & " Received" & Integer'Image (SN1) & " Single_Controlling_Operands SN" ); end if; Dual_Controlling_Operands (Pointers (AE, TS), Pointers (AE, TS), Test_Number, SN1, SN2); if SN1 /= Objects (AE, TS) then Report.Failed ("Wrong object used in test number" & Integer'Image (Test_Number) & " Expected" & Integer'Image (Objects (AE, TS)) & " Received" & Integer'Image (SN1) & " Dual_Controlling_Operands SN1" ); end if; if SN2 /= Objects (AE, TS) then Report.Failed ("Wrong object used in test number" & Integer'Image (Test_Number) & " Expected" & Integer'Image (Objects (AE, TS)) & " Received" & Integer'Image (SN2) & " Dual_Controlling_Operands SN2" ); end if; end loop; end loop; exception when others => Report.Failed ("Unexpected exception during test" & Integer'Image (Test_Number)); end; -- Check that Program_Error is raised if the tag of the actual -- parameter identifies a tagged type declared in a normal package. -- E.4(18);6.0 declare X : CXE4005_Normal.Open_But_Not_For_Export; begin X.Field := 1; CXE4005_Part_A1.Takes_Class_Wide ( CXE4005_Common.Open_Tagged_Type'Class(X)); Report.Failed ("Program_Error not raised when remote call is" & " made passing a class-wide object where the" & " type was declared in a" & " normal package"); exception when Program_Error => -- expected exception if Verbose then Report.Comment ("Program_Error raised as expected" & " when a remote call is made passing a class" & " wide object where the type was declared in" & " a normal package"); end if; when others => Report.Failed ("Incorrect exception raised." & " Program_Error was expected" & " when remote call is made passing a class" & " wide object where the type was declared in" & " a normal package"); end; -- Check that Program_Error is raised if the tag of the actual -- parameter identifies a tagged type declared in the body of a -- remote call interface package. begin CXE4005_Part_A1.Takes_Class_Wide (CXE4005_Part_A1. Return_Open_Tagged_Type_Class); Report.Failed ("Program_Error not raised when remote access to" & " class wide type designated type declared in a" & " package body"); exception when Program_Error => -- expected exception if Verbose then Report.Comment ("Program_Error raised as expected" & " when remote access to" & " class wide type designated type declared in a" & " package body"); end if; when others => Report.Failed ("Incorrect exception raised." & " Program_Error was expected" & " when remote access to" & " class wide type designated type declared in a" & " package body"); end; -- Check that in a dispatching call with two controlling operands -- where the two remote access-to-class-wide values originated -- from Access attribute_references in different partitions that -- Constraint_Error is raised. declare SN1 : Integer; SN2 : Integer; begin Test_Number := 400; Dual_Controlling_Operands (Pointers (A1, Common_Spec), Pointers (B, Common_Spec), Test_Number, SN1, SN2); Report.Failed ("Constraint_Error not raised when remote access to" & " class wide type originated from different partitions"); exception when Constraint_Error => -- expected exception if Verbose then Report.Comment ("Constraint_Error raised as expected" & " when remote access to" & " class wide type originated from different partitions"); end if; when others => Report.Failed ("Incorrect exception raised." & " Constraint_Error was expected"); end; -- Check that in a dispatching call with two controlling operands -- where the two remote access-to-class-wide values originated -- from Access attribute_references in the same partition but -- different RCI packages that no exception is raised. declare SN1 : Integer; SN2 : Integer; begin Test_Number := 500; Dual_Controlling_Operands (Pointers (A1, Common_Spec), Pointers (A2, Common_Spec), Test_Number, SN1, SN2); if SN1 /= Objects (A1, Common_Spec) then Report.Failed ("Wrong object used in test number" & Integer'Image (Test_Number) & " Expected" & Integer'Image (Objects (A1, Common_Spec)) & " Received" & Integer'Image (SN1) & " Dual_Controlling_Operands SN1" ); end if; if SN2 /= Objects (A2, Common_Spec) then Report.Failed ("Wrong object used in test number" & Integer'Image (Test_Number) & " Expected" & Integer'Image (Objects (A2, Common_Spec)) & " Received" & Integer'Image (SN2) & " Dual_Controlling_Operands SN2" ); end if; if Verbose then Report.Comment ("Two controlling operands from different RCI" & " packages within the same partition ok"); end if; exception when others => Report.Failed ("Two controlling operands from different RCI" & " packages within the same partition" & " resulted in an unexpected exception"); end; -- finish up CXE4005_Part_A1.Quit; Report.Result; end CXE4005_B; polyorb-2.8~20110207.orig/testsuite/acats/CXE4005/cxe4005_part_b.ads0000644000175000017500000000055411750740340023572 0ustar xavierxavier ----------------------------------------------------------------------------- with CXE4005_Common; use CXE4005_Common; with CXE4005_Part_A1; package CXE4005_Part_B is pragma Remote_Call_Interface; -- provide remote access values to other partitions function Get_RACWT (Which_Type : Type_Selection) return CXE4005_Part_A1.RACWT; end CXE4005_Part_B; polyorb-2.8~20110207.orig/testsuite/acats/CXE4005/local.gpr0000644000175000017500000000070011750740340022257 0ustar xavierxavierwith "polyorb", "polyorb_test_common"; project local is Dir := external ("Test_Dir"); Obj_Dir := PolyORB_Test_Common.Build_Dir & Dir; for Object_Dir use Obj_Dir; for Source_Dirs use (Obj_Dir, PolyORB_Test_Common.Source_Dir & Dir); package Compiler is for Default_Switches ("Ada") use PolyORB_Test_Common.Compiler'Default_Switches ("Ada"); end Compiler; for Main use ("part1.adb", "part2.adb"); end local; polyorb-2.8~20110207.orig/testsuite/acats/CXE4005/cxe4005_remote_types.ads0000644000175000017500000000122411750740340025035 0ustar xavierxavier ----------------------------------------------------------------------------- with CXE4005_Common; use CXE4005_Common; package CXE4005_Remote_Types is pragma Remote_Types; type RT_Tagged_Type is new Root_Tagged_Type with null record; procedure Single_Controlling_Operand ( RTT : access RT_Tagged_Type; Test_Number : in Integer; Obj_SN : out Integer); procedure Dual_Controlling_Operands ( RTT1 : access RT_Tagged_Type; RTT2 : access RT_Tagged_Type; Test_Number : in Integer; Obj_SN1 : out Integer; Obj_SN2 : out Integer); end CXE4005_Remote_Types; polyorb-2.8~20110207.orig/testsuite/acats/CXE4005/cxe4005_part_a2.adb0000644000175000017500000000167211750740340023634 0ustar xavierxavier ----------------------------------------------------------------------------- with Report; with CXE4005_Part_B; with CXE4005_Normal; with CXE4005_Remote_Types; package body CXE4005_Part_A2 is Root_Obj : aliased CXE4005_Common.Root_Tagged_Type; RT_Obj : aliased CXE4005_Remote_Types.RT_Tagged_Type; Normal_Obj : aliased CXE4005_Normal.Cant_Use_In_Remote_Call; function Get_RACWT (Which_Type : Type_Selection) return CXE4005_Part_A1.RACWT is begin case Which_Type is when Common_Spec => return Root_Obj'Access; when RT_Spec => return RT_Obj'Access; when B_Body => return null; when Normal_Spec => return Normal_Obj'Access; end case; end Get_RACWT; begin Set_Serial_Number (Root_Tagged_Type(Root_Obj)'Access , 201); Set_Serial_Number (Root_Tagged_Type(RT_Obj)'Access , 206); -- no 207 object Set_Serial_Number (Root_Tagged_Type(Normal_Obj)'Access , 208); end CXE4005_Part_A2; polyorb-2.8~20110207.orig/testsuite/acats/CXE4005/cxe4005_common.adb0000644000175000017500000000334311750740340023571 0ustar xavierxavier --- -- This package is pure so it cannot depend upon Report --- package body CXE4005_Common is Op_Is_Zero : exception; -- All objects that do not have an overriding definition of -- Single_Controlling_Operand and Dual_Controlling_Operands -- have a serial number with the least significant digit in -- the range from 1 to 5. -- If a wrong object is passed to these -- routines then the exception Wrong_Object is raised. procedure Single_Controlling_Operand ( RTT : access Root_Tagged_Type; Test_Number : in Integer; Obj_SN : out Integer) is begin Obj_SN := Serial_Number(RTT); if RTT.Serial_Number mod 10 not in 1..5 then raise Wrong_Object; end if; end Single_Controlling_Operand; procedure Dual_Controlling_Operands ( RTT1 : access Root_Tagged_Type; RTT2 : access Root_Tagged_Type; Test_Number : in Integer; Obj_SN1 : out Integer; Obj_SN2 : out Integer) is begin Obj_SN1 := RTT1.Serial_Number; Obj_SN2 := RTT2.Serial_Number; if RTT1.Serial_Number mod 10 not in 1..5 then raise Wrong_Object; end if; if RTT2.Serial_Number mod 10 not in 1..5 then raise Wrong_Object; end if; end Dual_Controlling_Operands; procedure Set_Serial_Number ( RTT : access Root_Tagged_Type; Sn : in Integer) is begin RTT.Serial_Number := Sn; end Set_Serial_Number; function Serial_Number (RTT : access Root_Tagged_Type) return Integer is begin return RTT.Serial_Number; end Serial_Number; procedure Open_Op (OTT : Open_Tagged_Type) is begin if OTT.Field = 0 then raise Op_Is_Zero; end if; end Open_Op; end CXE4005_Common; polyorb-2.8~20110207.orig/testsuite/acats/support/0000755000175000017500000000000011750740340021242 5ustar xavierxavierpolyorb-2.8~20110207.orig/testsuite/acats/support/impdef.adb0000644000175000017500000000155111750740340023160 0ustar xavierxavier --==================================================================-- package body ImpDef is -- NOTE: These are example bodies. It is expected that implementors -- will write their own versions of these routines. --=====-=====-=====-=====-=====-=====-=====-=====-=====-=====-=====-=====-- -- The time required to execute this procedure must be greater than the -- time slice unit on implementations which use time slicing. For -- implementations which do not use time slicing the body can be null. Procedure Exceed_Time_Slice is T : Integer := 0; Loop_Max : constant Integer := 4_000; begin for I in 1..Loop_Max loop T := Report.Ident_Int (1) * Report.Ident_Int (2); end loop; end Exceed_Time_Slice; --=====-=====-=====-=====-=====-=====-=====-=====-=====-=====-=====-=====-- end ImpDef; polyorb-2.8~20110207.orig/testsuite/acats/support/impdef-annex_e.ads0000644000175000017500000000453611750740340024622 0ustar xavierxavier-- IMPDEFE.A -- -- Grant of Unlimited Rights -- -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687 and -- F08630-91-C-0015, the U.S. Government obtained unlimited rights in the -- software and documentation contained herein. Unlimited rights are -- defined in DFAR 252.227-7013(a)(19). By making this public release, -- the Government intends to confer upon all recipients unlimited rights -- equal to those held by the Government. These rights include rights to -- use, duplicate, release or disclose the released technical data and -- computer software in whole or in part, in any manner and for any purpose -- whatsoever, and to have or permit others to do so. -- -- DISCLAIMER -- -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A -- PARTICULAR PURPOSE OF SAID MATERIAL. --* -- -- DESCRIPTION: -- This package provides tailorable entities for a particular -- implementation. Each entity may be modified to suit the needs -- of the implementation. Default values are provided to act as -- a guide. -- -- The entities in this package are those which are used exclusively -- in tests for Annex E (Distributed Systems). -- -- APPLICABILITY CRITERIA: -- This package is only required for implementations validating the -- Distributed Systems Annex. -- -- CHANGE HISTORY: -- 29 Jan 96 SAIC Initial version for ACVC 2.1. -- --! package ImpDef.Annex_E is --=====-=====-=====-=====-=====-=====-=====-=====-=====-=====-=====-=====-- -- The Max_RPC_Call_Time value is the longest time a test needs to wait for -- an RPC to complete. Included in this time is the time for the called -- procedure to make a task entry call where the task is ready to accept -- the call. Max_RPC_Call_Time : constant Duration := 2.0; -- ^^^ --- MODIFY HERE AS NEEDED --=====-=====-=====-=====-=====-=====-=====-=====-=====-=====-=====-=====-- end ImpDef.Annex_E; polyorb-2.8~20110207.orig/testsuite/acats/support/report.ads0000644000175000017500000001044711750740340023254 0ustar xavierxavierpragma Style_Checks (Off); PACKAGE REPORT IS SUBTYPE FILE_NUM IS INTEGER RANGE 1..5; -- THE REPORT ROUTINES. PROCEDURE TEST -- THIS ROUTINE MUST BE INVOKED AT THE -- START OF A TEST, BEFORE ANY OF THE -- OTHER REPORT ROUTINES ARE INVOKED. -- IT SAVES THE TEST NAME AND OUTPUTS THE -- NAME AND DESCRIPTION. ( NAME : STRING; -- TEST NAME, E.G., "C23001A-AB". DESCR : STRING -- BRIEF DESCRIPTION OF TEST, E.G., -- "UPPER/LOWER CASE EQUIVALENCE IN " & -- "IDENTIFIERS". ); PROCEDURE FAILED -- OUTPUT A FAILURE MESSAGE. SHOULD BE -- INVOKED SEPARATELY TO REPORT THE -- FAILURE OF EACH SUBTEST WITHIN A TEST. ( DESCR : STRING -- BRIEF DESCRIPTION OF WHAT FAILED. -- SHOULD BE PHRASED AS: -- "(FAILED BECAUSE) ...REASON...". ); PROCEDURE NOT_APPLICABLE -- OUTPUT A NOT-APPLICABLE MESSAGE. -- SHOULD BE INVOKED SEPARATELY TO REPORT -- THE NON-APPLICABILITY OF EACH SUBTEST -- WITHIN A TEST. ( DESCR : STRING -- BRIEF DESCRIPTION OF WHAT IS -- NOT-APPLICABLE. SHOULD BE PHRASED AS: -- "(NOT-APPLICABLE BECAUSE)...REASON...". ); PROCEDURE SPECIAL_ACTION -- OUTPUT A MESSAGE DESCRIBING SPECIAL -- ACTIONS TO BE TAKEN. -- SHOULD BE INVOKED SEPARATELY TO GIVE -- EACH SPECIAL ACTION. ( DESCR : STRING -- BRIEF DESCRIPTION OF ACTION TO BE -- TAKEN. ); PROCEDURE COMMENT -- OUTPUT A COMMENT MESSAGE. ( DESCR : STRING -- THE MESSAGE. ); PROCEDURE RESULT; -- THIS ROUTINE MUST BE INVOKED AT THE -- END OF A TEST. IT OUTPUTS A MESSAGE -- INDICATING WHETHER THE TEST AS A -- WHOLE HAS PASSED, FAILED, IS -- NOT-APPLICABLE, OR HAS TENTATIVELY -- PASSED PENDING SPECIAL ACTIONS. -- THE DYNAMIC VALUE ROUTINES. -- EVEN WITH STATIC ARGUMENTS, THESE FUNCTIONS WILL HAVE DYNAMIC -- RESULTS. FUNCTION IDENT_INT -- AN IDENTITY FUNCTION FOR TYPE INTEGER. ( X : INTEGER -- THE ARGUMENT. ) RETURN INTEGER; -- X. FUNCTION IDENT_CHAR -- AN IDENTITY FUNCTION FOR TYPE -- CHARACTER. ( X : CHARACTER -- THE ARGUMENT. ) RETURN CHARACTER; -- X. FUNCTION IDENT_WIDE_CHAR -- AN IDENTITY FUNCTION FOR TYPE -- WIDE_CHARACTER. ( X : WIDE_CHARACTER -- THE ARGUMENT. ) RETURN WIDE_CHARACTER; -- X. FUNCTION IDENT_BOOL -- AN IDENTITY FUNCTION FOR TYPE BOOLEAN. ( X : BOOLEAN -- THE ARGUMENT. ) RETURN BOOLEAN; -- X. FUNCTION IDENT_STR -- AN IDENTITY FUNCTION FOR TYPE STRING. ( X : STRING -- THE ARGUMENT. ) RETURN STRING; -- X. FUNCTION IDENT_WIDE_STR -- AN IDENTITY FUNCTION FOR TYPE WIDE_STRING. ( X : WIDE_STRING -- THE ARGUMENT. ) RETURN WIDE_STRING; -- X. FUNCTION EQUAL -- A RECURSIVE EQUALITY FUNCTION FOR TYPE -- INTEGER. ( X, Y : INTEGER -- THE ARGUMENTS. ) RETURN BOOLEAN; -- X = Y. -- OTHER UTILITY ROUTINES. FUNCTION LEGAL_FILE_NAME -- A FUNCTION TO GENERATE LEGAL EXTERNAL -- FILE NAMES. ( X : FILE_NUM := 1; -- DETERMINES FIRST CHARACTER OF NAME. NAM : STRING := "" -- DETERMINES REST OF NAME. ) RETURN STRING; -- THE GENERATED NAME. FUNCTION TIME_STAMP -- A FUNCTION TO GENERATE THE TIME AND -- DATE TO PLACE IN THE OUTPUT OF AN ACVC -- TEST. RETURN STRING; -- THE TIME AND DATE. END REPORT; polyorb-2.8~20110207.orig/testsuite/acats/support/report.adb0000644000175000017500000002266211750740340023235 0ustar xavierxavierpragma Style_Checks (Off); pragma Warnings (Off); WITH TEXT_IO, CALENDAR; USE TEXT_IO, CALENDAR; PRAGMA ELABORATE (TEXT_IO, CALENDAR); PACKAGE BODY REPORT IS TYPE STATUS IS (PASS, FAIL, DOES_NOT_APPLY, ACTION_REQUIRED, UNKNOWN); TYPE TIME_INTEGER IS RANGE 0 .. 86_400; TEST_STATUS : STATUS := FAIL; MAX_NAME_LEN : CONSTANT := 15; -- MAXIMUM TEST NAME LENGTH. TEST_NAME : STRING (1..MAX_NAME_LEN); NO_NAME : CONSTANT STRING (1..7) := "NO_NAME"; TEST_NAME_LEN : INTEGER RANGE 0..MAX_NAME_LEN := 0; ACVC_VERSION : CONSTANT STRING := "2.1"; -- VERSION OF ACVC BEING RUN (X.XX). PROCEDURE PUT_MSG (MSG : STRING) IS -- WRITE MESSAGE. LONG MESSAGES ARE FOLDED (AND INDENTED). MAX_LEN : CONSTANT INTEGER RANGE 50..150 := 72; -- MAXIMUM -- OUTPUT LINE LENGTH. INDENT : CONSTANT INTEGER := TEST_NAME_LEN + 9; -- AMOUNT TO -- INDENT CONTINUATION LINES. I : INTEGER := 0; -- CURRENT INDENTATION. M : INTEGER := MSG'FIRST; -- START OF MESSAGE SLICE. N : INTEGER; -- END OF MESSAGE SLICE. BEGIN LOOP IF I + (MSG'LAST-M+1) > MAX_LEN THEN N := M + (MAX_LEN-I) - 1; IF MSG (N) /= ' ' THEN WHILE N >= M AND THEN MSG (N+1) /= ' ' LOOP N := N - 1; END LOOP; IF N < M THEN N := M + (MAX_LEN-I) - 1; END IF; END IF; ELSE N := MSG'LAST; END IF; SET_COL (STANDARD_OUTPUT, TEXT_IO.COUNT (I+1)); PUT_LINE (STANDARD_OUTPUT, MSG (M..N)); I := INDENT; M := N + 1; WHILE M <= MSG'LAST AND THEN MSG (M) = ' ' LOOP M := M + 1; END LOOP; EXIT WHEN M > MSG'LAST; END LOOP; END PUT_MSG; FUNCTION TIME_STAMP RETURN STRING IS TIME_NOW : CALENDAR.TIME; YEAR, MONTH, DAY, HOUR, MINUTE, SECOND : TIME_INTEGER := 1; FUNCTION CONVERT (NUMBER : TIME_INTEGER) RETURN STRING IS STR : STRING (1..2) := (OTHERS => '0'); DEC_DIGIT : CONSTANT STRING := "0123456789"; NUM : TIME_INTEGER := NUMBER; BEGIN IF NUM = 0 THEN RETURN STR; ELSE NUM := NUM MOD 100; STR (2) := DEC_DIGIT (INTEGER (NUM MOD 10 + 1)); NUM := NUM / 10; STR (1) := DEC_DIGIT (INTEGER (NUM + 1)); RETURN STR; END IF; END CONVERT; BEGIN TIME_NOW := CALENDAR.CLOCK; SPLIT (TIME_NOW, YEAR_NUMBER (YEAR), MONTH_NUMBER (MONTH), DAY_NUMBER (DAY), DAY_DURATION (SECOND)); HOUR := SECOND / 3600; SECOND := SECOND MOD 3600; MINUTE := SECOND / 60; SECOND := SECOND MOD 60; RETURN (CONVERT (TIME_INTEGER (YEAR)) & "-" & CONVERT (TIME_INTEGER (MONTH)) & "-" & CONVERT (TIME_INTEGER (DAY)) & " " & CONVERT (TIME_INTEGER (HOUR)) & ":" & CONVERT (TIME_INTEGER (MINUTE)) & ":" & CONVERT (TIME_INTEGER (SECOND))); END TIME_STAMP; PROCEDURE TEST (NAME : STRING; DESCR : STRING) IS BEGIN TEST_STATUS := PASS; IF NAME'LENGTH <= MAX_NAME_LEN THEN TEST_NAME_LEN := NAME'LENGTH; ELSE TEST_NAME_LEN := MAX_NAME_LEN; END IF; TEST_NAME (1..TEST_NAME_LEN) := NAME (NAME'FIRST .. NAME'FIRST+TEST_NAME_LEN-1); PUT_MSG (""); PUT_MSG (",.,. " & TEST_NAME (1..TEST_NAME_LEN) & " " & "ACVC " & ACVC_VERSION & " " & TIME_STAMP); PUT_MSG ("---- " & TEST_NAME (1..TEST_NAME_LEN) & " " & DESCR & "."); END TEST; PROCEDURE COMMENT (DESCR : STRING) IS BEGIN PUT_MSG (" - " & TEST_NAME (1..TEST_NAME_LEN) & " " & DESCR & "."); END COMMENT; PROCEDURE FAILED (DESCR : STRING) IS BEGIN TEST_STATUS := FAIL; PUT_MSG (" * " & TEST_NAME (1..TEST_NAME_LEN) & " " & DESCR & "."); END FAILED; PROCEDURE NOT_APPLICABLE (DESCR : STRING) IS BEGIN IF TEST_STATUS = PASS OR TEST_STATUS = ACTION_REQUIRED THEN TEST_STATUS := DOES_NOT_APPLY; END IF; PUT_MSG (" + " & TEST_NAME (1..TEST_NAME_LEN) & " " & DESCR & "."); END NOT_APPLICABLE; PROCEDURE SPECIAL_ACTION (DESCR : STRING) IS BEGIN IF TEST_STATUS = PASS THEN TEST_STATUS := ACTION_REQUIRED; END IF; PUT_MSG (" ! " & TEST_NAME (1..TEST_NAME_LEN) & " " & DESCR & "."); END SPECIAL_ACTION; PROCEDURE RESULT IS BEGIN CASE TEST_STATUS IS WHEN PASS => PUT_MSG ("==== " & TEST_NAME (1..TEST_NAME_LEN) & " PASSED ============================."); WHEN DOES_NOT_APPLY => PUT_MSG ("++++ " & TEST_NAME (1..TEST_NAME_LEN) & " NOT-APPLICABLE ++++++++++++++++++++."); WHEN ACTION_REQUIRED => PUT_MSG ("!!!! " & TEST_NAME (1..TEST_NAME_LEN) & " TENTATIVELY PASSED !!!!!!!!!!!!!!!!."); PUT_MSG ("!!!! " & (1..TEST_NAME_LEN => ' ') & " SEE '!' COMMENTS FOR SPECIAL NOTES!!"); WHEN OTHERS => PUT_MSG ("**** " & TEST_NAME (1..TEST_NAME_LEN) & " FAILED ****************************."); END CASE; TEST_STATUS := FAIL; TEST_NAME_LEN := NO_NAME'LENGTH; TEST_NAME (1..TEST_NAME_LEN) := NO_NAME; END RESULT; FUNCTION IDENT_INT (X : INTEGER) RETURN INTEGER IS BEGIN IF EQUAL (X, X) THEN -- ALWAYS EQUAL. RETURN X; -- ALWAYS EXECUTED. END IF; RETURN 0; -- NEVER EXECUTED. END IDENT_INT; FUNCTION IDENT_CHAR (X : CHARACTER) RETURN CHARACTER IS BEGIN IF EQUAL (CHARACTER'POS(X), CHARACTER'POS(X)) THEN -- ALWAYS -- EQUAL. RETURN X; -- ALWAYS EXECUTED. END IF; RETURN '0'; -- NEVER EXECUTED. END IDENT_CHAR; FUNCTION IDENT_WIDE_CHAR (X : WIDE_CHARACTER) RETURN WIDE_CHARACTER IS BEGIN IF EQUAL (WIDE_CHARACTER'POS(X), WIDE_CHARACTER'POS(X)) THEN -- ALWAYS EQUAL. RETURN X; -- ALWAYS EXECUTED. END IF; RETURN '0'; -- NEVER EXECUTED. END IDENT_WIDE_CHAR; FUNCTION IDENT_BOOL (X : BOOLEAN) RETURN BOOLEAN IS BEGIN IF EQUAL (BOOLEAN'POS(X), BOOLEAN'POS(X)) THEN -- ALWAYS -- EQUAL. RETURN X; -- ALWAYS EXECUTED. END IF; RETURN FALSE; -- NEVER EXECUTED. END IDENT_BOOL; FUNCTION IDENT_STR (X : STRING) RETURN STRING IS BEGIN IF EQUAL (X'LENGTH, X'LENGTH) THEN -- ALWAYS EQUAL. RETURN X; -- ALWAYS EXECUTED. END IF; RETURN ""; -- NEVER EXECUTED. END IDENT_STR; FUNCTION IDENT_WIDE_STR (X : WIDE_STRING) RETURN WIDE_STRING IS BEGIN IF EQUAL (X'LENGTH, X'LENGTH) THEN -- ALWAYS EQUAL. RETURN X; -- ALWAYS EXECUTED. END IF; RETURN ""; -- NEVER EXECUTED. END IDENT_WIDE_STR; FUNCTION EQUAL (X, Y : INTEGER) RETURN BOOLEAN IS REC_LIMIT : CONSTANT INTEGER RANGE 1..100 := 3; -- RECURSION -- LIMIT. Z : BOOLEAN; -- RESULT. BEGIN IF X < 0 THEN IF Y < 0 THEN Z := EQUAL (-X, -Y); ELSE Z := FALSE; END IF; ELSIF X > REC_LIMIT THEN Z := EQUAL (REC_LIMIT, Y-X+REC_LIMIT); ELSIF X > 0 THEN Z := EQUAL (X-1, Y-1); ELSE Z := Y = 0; END IF; RETURN Z; EXCEPTION WHEN OTHERS => RETURN X = Y; END EQUAL; FUNCTION LEGAL_FILE_NAME (X : FILE_NUM := 1; NAM : STRING := "") RETURN STRING IS SUFFIX : STRING (2..6); BEGIN IF NAM = "" THEN SUFFIX := TEST_NAME(3..7); ELSE SUFFIX := NAM(3..7); END IF; CASE X IS WHEN 1 => RETURN ('X' & SUFFIX); WHEN 2 => RETURN ('Y' & SUFFIX); WHEN 3 => RETURN ('Z' & SUFFIX); WHEN 4 => RETURN ('V' & SUFFIX); WHEN 5 => RETURN ('W' & SUFFIX); END CASE; END LEGAL_FILE_NAME; BEGIN TEST_NAME_LEN := NO_NAME'LENGTH; TEST_NAME (1..TEST_NAME_LEN) := NO_NAME; END REPORT; polyorb-2.8~20110207.orig/testsuite/acats/support/impdef.ads0000644000175000017500000003470511750740340023210 0ustar xavierxavier-- IMPDEF.A -- -- Grant of Unlimited Rights -- -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687 and -- F08630-91-C-0015, the U.S. Government obtained unlimited rights in the -- software and documentation contained herein. Unlimited rights are -- defined in DFAR 252.227-7013(a)(19). By making this public release, -- the Government intends to confer upon all recipients unlimited rights -- equal to those held by the Government. These rights include rights to -- use, duplicate, release or disclose the released technical data and -- computer software in whole or in part, in any manner and for any purpose -- whatsoever, and to have or permit others to do so. -- -- DISCLAIMER -- -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A -- PARTICULAR PURPOSE OF SAID MATERIAL. --* -- -- DESCRIPTION: -- This package provides tailorable entities for a particular -- implementation. Each entity may be modified to suit the needs -- of the implementation. Default values are provided to act as -- a guide. -- -- The entities in this package are those which are used in at least -- one core test. Entities which are used exclusively in tests for -- annexes C-H are located in annex-specific child units of this package. -- -- CHANGE HISTORY: -- 12 DEC 93 SAIC Initial PreRelease version -- 02 DEC 94 SAIC Second PreRelease version -- 16 May 95 SAIC Added constants specific to tests of the random -- number generator. -- 16 May 95 SAIC Added Max_RPC_Call_Time constant. -- 17 Jul 95 SAIC Added Non_State_String constant. -- 21 Aug 95 SAIC Created from existing IMPSPEC.ADA and IMPBODY.ADA -- files. -- 30 Oct 95 SAIC Added external name string constants. -- 24 Jan 96 SAIC Added alignment constants. -- 29 Jan 96 SAIC Moved entities not used in core tests into annex- -- specific child packages. Adjusted commentary. -- Renamed Validating_System_Programming_Annex to -- Validating_Annex_C. Added similar Validating_Annex_? -- constants for the other non-core annexes (D-H). -- 01 Mar 96 SAIC Added external name string constants. -- 21 Mar 96 SAIC Added external name string constants. -- 02 May 96 SAIC Removed constants for draft test CXA5014, which was -- removed from the tentative ACVC 2.1 suite. -- Added constants for use with FXACA00. -- 06 Jun 96 SAIC Added constants for wide character test files. -- 11 Dec 96 SAIC Updated constants for wide character test files. -- 13 Dec 96 SAIC Added Address_Value_IO -- --! with Report; with Ada.Text_IO; with System.Storage_Elements; package ImpDef is --=====-=====-=====-=====-=====-=====-=====-=====-=====-=====-=====-=====-- -- The following boolean constants indicate whether this validation will -- include any of annexes C-H. The values of these booleans affect the -- behavior of the test result reporting software. -- -- True means the associated annex IS included in the validation. -- False means the associated annex is NOT included. Validating_Annex_C : constant Boolean := True; -- ^^^^^ --- MODIFY HERE AS NEEDED Validating_Annex_D : constant Boolean := True; -- ^^^^^ --- MODIFY HERE AS NEEDED Validating_Annex_E : constant Boolean := True; -- ^^^^^ --- MODIFY HERE AS NEEDED Validating_Annex_F : constant Boolean := True; -- ^^^^^ --- MODIFY HERE AS NEEDED Validating_Annex_G : constant Boolean := True; -- ^^^^^ --- MODIFY HERE AS NEEDED Validating_Annex_H : constant Boolean := True; -- ^^^^^ --- MODIFY HERE AS NEEDED --=====-=====-=====-=====-=====-=====-=====-=====-=====-=====-=====-=====-- -- This is the minimum time required to allow another task to get -- control. It is expected that the task is on the Ready queue. -- A duration of 0.0 would normally be sufficient but some number -- greater than that is expected. Minimum_Task_Switch : constant Duration := 0.1; -- ^^^ --- MODIFY HERE AS NEEDED --=====-=====-=====-=====-=====-=====-=====-=====-=====-=====-=====-=====-- -- This is the time required to activate another task and allow it -- to run to its first accept statement. We are considering a simple task -- with very few Ada statements before the accept. An implementation is -- free to specify a delay of several seconds, or even minutes if need be. -- The main effect of specifying a longer delay than necessary will be an -- extension of the time needed to run the associated tests. Switch_To_New_Task : constant Duration := 1.0; -- ^^^ -- MODIFY HERE AS NEEDED --=====-=====-=====-=====-=====-=====-=====-=====-=====-=====-=====-=====-- -- This is the time which will clear the queues of other tasks -- waiting to run. It is expected that this will be about five -- times greater than Switch_To_New_Task. Clear_Ready_Queue : constant Duration := 5.0; -- ^^^ --- MODIFY HERE AS NEEDED --=====-=====-=====-=====-=====-=====-=====-=====-=====-=====-=====-=====-- -- Some implementations will boot with the time set to 1901/1/1/0.0 -- When a delay of Delay_For_Time_Past is given, the implementation -- guarantees that a subsequent call to Ada.Calendar.Time_Of(1901,1,1) -- will yield a time that has already passed (for example, when used in -- a delay_until statement). Delay_For_Time_Past : constant Duration := 0.1; -- ^^^ --- MODIFY HERE AS NEEDED --=====-=====-=====-=====-=====-=====-=====-=====-=====-=====-=====-=====-- -- Minimum time interval between calls to the time dependent Reset -- procedures in Float_Random and Discrete_Random packages that is -- guaranteed to initiate different sequences. See RM A.5.2(45). Time_Dependent_Reset : constant Duration := 0.3; -- ^^^ --- MODIFY HERE AS NEEDED --=====-=====-=====-=====-=====-=====-=====-=====-=====-=====-=====-=====-- -- Test CXA5013 will loop, trying to generate the required sequence -- of random numbers. If the RNG is faulty, the required sequence -- will never be generated. Delay_Per_Random_Test is a time-out value -- which allows the test to run for a period of time after which the -- test is failed if the required sequence has not been produced. -- This value should be the time allowed for the test to run before it -- times out. It should be long enough to allow multiple (independent) -- runs of the testing code, each generating up to 1000 random -- numbers. Delay_Per_Random_Test : constant Duration := 1.0; -- ^^^ --- MODIFY HERE AS NEEDED --=====-=====-=====-=====-=====-=====-=====-=====-=====-=====-=====-=====-- -- The time required to execute this procedure must be greater than the -- time slice unit on implementations which use time slicing. For -- implementations which do not use time slicing the body can be null. procedure Exceed_Time_Slice; --=====-=====-=====-=====-=====-=====-=====-=====-=====-=====-=====-=====-- -- This constant must not depict a random number generator state value. -- Using this string in a call to function Value from either the -- Discrete_Random or Float_Random packages will result in -- Constraint_Error (expected result in test CXA5012). Non_State_String : constant String := "By No Means A State"; -- MODIFY HERE AS NEEDED --- ^^^^^^^^^^^^^^^^^^^ --=====-=====-=====-=====-=====-=====-=====-=====-=====-=====-=====-=====-- -- This string constant must be a legal external tag value as used by -- CD10001 for the type Some_Tagged_Type in the representation -- specification for the value of 'External_Tag. External_Tag_Value : constant String := "implementation_defined"; -- MODIFY HERE AS NEEDED --- ^^^^^^^^^^^^^^^^^^^^^^ --=====-=====-=====-=====-=====-=====-=====-=====-=====-=====-=====-=====-- -- The following address constant must be a valid address to locate -- the C program CD30005_1. It is shown here as a named number; -- the implementation may choose to type the constant as appropriate. CD30005_1_Foreign_Address : constant System.Address:= System.Storage_Elements.To_Address ( 16#0000_0000# ); -- MODIFY HERE AS REQUIRED --- ^^^^^^^^^^^^^ --=====-=====-=====-=====-=====-=====-=====-=====-=====-=====-=====-=====-- -- The following string constant must be the external name resulting -- from the C compilation of CD30005_1. The string will be used as an -- argument to pragma Import. CD30005_1_External_Name : constant String := "CD30005_1"; -- MODIFY HERE AS NEEDED --- ^^^^^^^^^ --=====-=====-=====-=====-=====-=====-=====-=====-=====-=====-=====-=====-- -- The following constants should represent the largest default alignment -- value and the largest alignment value supported by the linker. -- See RM 13.3(35). Max_Default_Alignment : constant := 0; -- ^ --- MODIFY HERE AS NEEDED Max_Linker_Alignment : constant := 0; -- ^ --- MODIFY HERE AS NEEDED --=====-=====-=====-=====-=====-=====-=====-=====-=====-=====-=====-=====-- -- The following string constants must be the external names resulting -- from the C compilation of CXB30130.C and CXB30131.C. The strings -- will be used as arguments to pragma Import. CXB30130_External_Name : constant String := "CXB30130"; -- MODIFY HERE AS NEEDED --- ^^^^^^^^ CXB30131_External_Name : constant String := "CXB30131"; -- MODIFY HERE AS NEEDED --- ^^^^^^^^ --=====-=====-=====-=====-=====-=====-=====-=====-=====-=====-=====-=====-- -- The following string constants must be the external names resulting -- from the COBOL compilation of CXB40090.CBL, CXB40091.CBL, and -- CXB40092.CBL. The strings will be used as arguments to pragma Import. CXB40090_External_Name : constant String := "CXB40090"; -- MODIFY HERE AS NEEDED --- ^^^^^^^^ CXB40091_External_Name : constant String := "CXB40091"; -- MODIFY HERE AS NEEDED --- ^^^^^^^^ CXB40092_External_Name : constant String := "CXB40092"; -- MODIFY HERE AS NEEDED --- ^^^^^^^^ --=====-=====-=====-=====-=====-=====-=====-=====-=====-=====-=====-=====-- -- The following string constants must be the external names resulting -- from the Fortran compilation of CXB50040.FTN, CXB50041.FTN, -- CXB50050.FTN, and CXB50051.FTN. -- -- The strings will be used as arguments to pragma Import. -- -- Note that the use of these four string constants will be split between -- two tests, CXB5004 and CXB5005. CXB50040_External_Name : constant String := "CXB50040"; -- MODIFY HERE AS NEEDED --- ^^^^^^^^ CXB50041_External_Name : constant String := "CXB50041"; -- MODIFY HERE AS NEEDED --- ^^^^^^^^ CXB50050_External_Name : constant String := "CXB50050"; -- MODIFY HERE AS NEEDED --- ^^^^^^^^ CXB50051_External_Name : constant String := "CXB50051"; -- MODIFY HERE AS NEEDED --- ^^^^^^^^ --=====-=====-=====-=====-=====-=====-=====-=====-=====-=====-=====-=====-- -- The following constants have been defined for use with the -- representation clause in FXACA00 of type Sales_Record_Type. -- -- Char_Bits should be an integer at least as large as the number -- of bits needed to hold a character in an array. -- A value of 6 * Char_Bits will be used in a representation clause -- to reserve space for a six character string. -- -- Next_Storage_Slot should indicate the next storage unit in the record -- representation clause that does not overlap the storage designated for -- the six character string. Char_Bits : constant := 8; -- MODIFY HERE AS NEEDED ---^ Next_Storage_Slot : constant := 6; -- MODIFY HERE AS NEEDED ---^ --=====-=====-=====-=====-=====-=====-=====-=====-=====-=====-=====-=====-- -- The following string constant must be the path name for the .AW -- files that will be processed by the Wide Character processor to -- create the C250001 and C250002 tests. The Wide Character processor -- will expect to find the files to process at this location. Test_Path_Root : constant String := "/data/ftp/public/AdaIC/testing/acvc/95acvc/"; -- ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ --- MODIFY HERE AS NEEDED -- The following two strings must not be modified unless the .AW file -- names have been changed. The Wide Character processor will use -- these strings to find the .AW files used in creating the C250001 -- and C250002 tests. Wide_Character_Test : constant String := Test_Path_Root & "c250001"; Upper_Latin_Test : constant String := Test_Path_Root & "c250002"; --=====-=====-=====-=====-=====-=====-=====-=====-=====-=====-=====-=====-- -- The following instance of Integer_IO or Modular_IO must be supplied -- in order for test CD72A02 to compile correctly. -- Depending on the choice of base type used for the type -- System.Storage_Elements.Integer_Address; one of the two instances will -- be correct. Comment out the incorrect instance. --M package Address_Value_IO is --M new Ada.Text_IO.Integer_IO(System.Storage_Elements.Integer_Address); package Address_Value_IO is new Ada.Text_IO.Modular_IO(System.Storage_Elements.Integer_Address); --=====-=====-=====-=====-=====-=====-=====-=====-=====-=====-=====-=====-- end ImpDef; polyorb-2.8~20110207.orig/src/0000755000175000017500000000000011750740340015171 5ustar xavierxavierpolyorb-2.8~20110207.orig/src/polyorb-obj_adapter_qos.adb0000644000175000017500000001100311750740340022454 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . O B J _ A D A P T E R _ Q O S -- -- -- -- B o d y -- -- -- -- Copyright (C) 2005 Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with PolyORB.Annotations; package body PolyORB.Obj_Adapter_QoS is type Object_Adapter_QoS_Note is new Annotations.Note with record QoS : PolyORB.QoS.QoS_Parameters; end record; procedure Destroy (N : in out Object_Adapter_QoS_Note); Empty_Object_Adapter_QoS_Note : constant Object_Adapter_QoS_Note := (Annotations.Note with QoS => (others => null)); ------------- -- Destroy -- ------------- procedure Destroy (N : in out Object_Adapter_QoS_Note) is begin for J in PolyORB.QoS.QoS_Kind loop PolyORB.QoS.Release (N.QoS (J)); end loop; end Destroy; ---------------------------- -- Get_Object_Adapter_QoS -- ---------------------------- function Get_Object_Adapter_QoS (OA : access PolyORB.Obj_Adapters.Obj_Adapter'Class) return PolyORB.QoS.QoS_Parameters is Note : Object_Adapter_QoS_Note; begin PolyORB.Annotations.Get_Note (PolyORB.Obj_Adapters.Notepad_Of (OA).all, Note, Empty_Object_Adapter_QoS_Note); return Note.QoS; end Get_Object_Adapter_QoS; function Get_Object_Adapter_QoS (OA : access PolyORB.Obj_Adapters.Obj_Adapter'Class; Kind : PolyORB.QoS.QoS_Kind) return PolyORB.QoS.QoS_Parameter_Access is Note : Object_Adapter_QoS_Note; begin PolyORB.Annotations.Get_Note (PolyORB.Obj_Adapters.Notepad_Of (OA).all, Note, Empty_Object_Adapter_QoS_Note); return Note.QoS (Kind); end Get_Object_Adapter_QoS; ---------------------------- -- Set_Object_Adapter_QoS -- ---------------------------- procedure Set_Object_Adapter_QoS (OA : access PolyORB.Obj_Adapters.Obj_Adapter'Class; QoS : PolyORB.QoS.QoS_Parameters) is Note : Object_Adapter_QoS_Note; begin Note.QoS := QoS; PolyORB.Annotations.Set_Note (PolyORB.Obj_Adapters.Notepad_Of (OA).all, Note); end Set_Object_Adapter_QoS; procedure Set_Object_Adapter_QoS (OA : access PolyORB.Obj_Adapters.Obj_Adapter'Class; Kind : PolyORB.QoS.QoS_Kind; QoS : PolyORB.QoS.QoS_Parameter_Access) is Note : Object_Adapter_QoS_Note; begin PolyORB.Annotations.Get_Note (PolyORB.Obj_Adapters.Notepad_Of (OA).all, Note, Empty_Object_Adapter_QoS_Note); Note.QoS (Kind) := QoS; PolyORB.Annotations.Set_Note (PolyORB.Obj_Adapters.Notepad_Of (OA).all, Note); end Set_Object_Adapter_QoS; end PolyORB.Obj_Adapter_QoS; polyorb-2.8~20110207.orig/src/polyorb-binding_data-local.adb0000644000175000017500000001216511750740340023025 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . B I N D I N G _ D A T A . L O C A L -- -- -- -- B o d y -- -- -- -- Copyright (C) 2001-2011, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ package body PolyORB.Binding_Data.Local is use PolyORB.Objects; ------------- -- Release -- ------------- procedure Release (P : in out Local_Profile_Type) is begin Free (P.Object_Id); end Release; -------------------------- -- Create_Local_Profile -- -------------------------- procedure Create_Local_Profile (Oid : Objects.Object_Id; P : out Local_Profile_Type) is begin P.Object_Id := new Object_Id'(Oid); P.Known_Local := True; pragma Assert (P.Object_Id /= null); end Create_Local_Profile; ------------------ -- Is_Colocated -- ------------------ function Is_Colocated (Left : Local_Profile_Type; Right : Profile_Type'Class) return Boolean is pragma Unreferenced (Left); begin return Right in Local_Profile_Type'Class; end Is_Colocated; ----------------------- -- Duplicate_Profile -- ----------------------- function Duplicate_Profile (P : Local_Profile_Type) return Profile_Access is Result : constant Profile_Access := new Local_Profile_Type; TResult : Local_Profile_Type renames Local_Profile_Type (Result.all); begin TResult.Object_Id := new Object_Id'(P.Object_Id.all); TResult.Known_Local := True; return Result; end Duplicate_Profile; ------------------ -- Bind_Profile -- ------------------- procedure Bind_Profile (Profile : access Local_Profile_Type; The_ORB : Components.Component_Access; QoS : PolyORB.QoS.QoS_Parameters; BO_Ref : out Smart_Pointers.Ref; Error : out Errors.Error_Container) is pragma Unreferenced (Profile, The_ORB, QoS, BO_Ref, Error); begin raise Program_Error; -- May not happen currently, because the local case -- is handled specially in PolyORB.References.Bind, -- but could be implemented as (mostly): -- Servant := Components.Component_Access -- (Find_Servant -- (Object_Adapter (Local_ORB), Profile.Object_Id)); -- Set (BO_Ref, Servant_To_Binding_Object (Servant)); end Bind_Profile; --------------------- -- Get_Profile_Tag -- --------------------- function Get_Profile_Tag (Profile : Local_Profile_Type) return Profile_Tag is pragma Warnings (Off); pragma Unreferenced (Profile); pragma Warnings (On); begin return Tag_Local; end Get_Profile_Tag; ---------------------------- -- Get_Profile_Preference -- ---------------------------- function Get_Profile_Preference (Profile : Local_Profile_Type) return Profile_Preference is pragma Warnings (Off); pragma Unreferenced (Profile); pragma Warnings (On); begin return Profile_Preference'Last; -- A local profile is always preferred to any other. end Get_Profile_Preference; ----------- -- Image -- ----------- function Image (Prof : Local_Profile_Type) return String is begin return "Object_Id: " & PolyORB.Objects.Image (Prof.Object_Id.all); end Image; end PolyORB.Binding_Data.Local; polyorb-2.8~20110207.orig/src/polyorb-transport-datagram.ads0000644000175000017500000000774711750740340023177 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . T R A N S P O R T . D A T A G R A M -- -- -- -- S p e c -- -- -- -- Copyright (C) 2003-2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- Abstract datagram transport service access points and transport endpoints. with PolyORB.Transport.Handlers; package PolyORB.Transport.Datagram is use PolyORB.Asynch_Ev; ------------------ -- Access Point -- ------------------ type Datagram_Transport_Access_Point is abstract new Transport_Access_Point with private; type Datagram_Transport_Access_Point_Access is access all Datagram_Transport_Access_Point'Class; --------------- -- End Point -- --------------- type Datagram_Transport_Endpoint is abstract new Transport_Endpoint with private; type Datagram_Transport_Endpoint_Access is access all Datagram_Transport_Endpoint'Class; function Handle_Message (TE : not null access Datagram_Transport_Endpoint; Msg : Components.Message'Class) return Components.Message'Class; function Create_Endpoint (TAP : access Datagram_Transport_Access_Point) return Datagram_Transport_Endpoint_Access; -- This function create an Endpoint on the same socket -- This allow to receive data to datagram socket private ---------------------------------------------------- -- Connectionless transport service access points -- ---------------------------------------------------- type Datagram_TAP_AES_Event_Handler is new Handlers.TAP_AES_Event_Handler with null record; procedure Handle_Event (H : access Datagram_TAP_AES_Event_Handler); type Datagram_Transport_Access_Point is abstract new Transport_Access_Point with record Handler : aliased Datagram_TAP_AES_Event_Handler; end record; ---------------------------------------- -- Connectionless transport endpoints -- ---------------------------------------- subtype Datagram_TE_AES_Event_Handler is Handlers.TE_AES_Event_Handler; type Datagram_Transport_Endpoint is abstract new Transport_Endpoint with null record; -- Only datagram in endpoints have a Handler. end PolyORB.Transport.Datagram; polyorb-2.8~20110207.orig/src/polyorb-poa_policies-request_processing_policy-use_servant_manager.ads0000644000175000017500000000707411750740340033353 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- POLYORB.POA_POLICIES.REQUEST_PROCESSING_POLICY.USE_SERVANT_MANAGER -- -- -- -- S p e c -- -- -- -- Copyright (C) 2003-2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ package PolyORB.POA_Policies.Request_Processing_Policy.Use_Servant_Manager is type Use_Servant_Manager_Policy is new RequestProcessingPolicy with null record; type Use_Servant_Manager_Policy_Access is access all Use_Servant_Manager_Policy; function Create return Use_Servant_Manager_Policy_Access; procedure Check_Compatibility (Self : Use_Servant_Manager_Policy; Other_Policies : AllPolicies; Error : in out PolyORB.Errors.Error_Container); function Policy_Id (Self : Use_Servant_Manager_Policy) return String; procedure Id_To_Servant (Self : Use_Servant_Manager_Policy; OA : PolyORB.POA_Types.Obj_Adapter_Access; U_Oid : Unmarshalled_Oid; Servant : out Servants.Servant_Access; Error : in out PolyORB.Errors.Error_Container); procedure Set_Servant (Self : Use_Servant_Manager_Policy; OA : PolyORB.POA_Types.Obj_Adapter_Access; Servant : Servants.Servant_Access; Error : in out PolyORB.Errors.Error_Container); procedure Get_Servant (Self : Use_Servant_Manager_Policy; OA : PolyORB.POA_Types.Obj_Adapter_Access; Servant : out Servants.Servant_Access; Error : in out PolyORB.Errors.Error_Container); procedure Ensure_Servant_Manager (Self : Use_Servant_Manager_Policy; Error : in out PolyORB.Errors.Error_Container); end PolyORB.POA_Policies.Request_Processing_Policy.Use_Servant_Manager; polyorb-2.8~20110207.orig/src/polyorb-orb_controller-leader_followers.adb0000644000175000017500000003655411750740340025715 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- POLYORB.ORB_CONTROLLER.LEADER_FOLLOWERS -- -- -- -- B o d y -- -- -- -- Copyright (C) 2004-2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with Ada.Tags; with PolyORB.Annotations; with PolyORB.Asynch_Ev; with PolyORB.Initialization; with PolyORB.Tasking.Threads.Annotations; with PolyORB.Utils.Strings; package body PolyORB.ORB_Controller.Leader_Followers is use PolyORB.Annotations; use PolyORB.Asynch_Ev; use PolyORB.Jobs; use PolyORB.Task_Info; use PolyORB.Tasking.Condition_Variables; use PolyORB.Tasking.Threads; use PolyORB.Tasking.Threads.Annotations; -- Declaration of LF_Task_Note needs documentation??? type LF_Task_Note is new PolyORB.Annotations.Note with record TI : Thread_Id; Job : Job_Access; end record; ------------------- -- Register_Task -- ------------------- procedure Register_Task (O : access ORB_Controller_Leader_Followers; TI : PTI.Task_Info_Access) is begin pragma Debug (C1, O1 ("Register_Task (LF): enter")); Register_Task (ORB_Controller (O.all)'Access, TI); Set_Note (Get_Current_Thread_Notepad.all, LF_Task_Note'(Note with TI => Id (TI.all), Job => null)); pragma Debug (C1, O1 ("Register_Task (LF): leave")); end Register_Task; --------------------- -- Disable_Polling -- --------------------- procedure Disable_Polling (O : access ORB_Controller_Leader_Followers; M : PAE.Asynch_Ev_Monitor_Access) is AEM_Index : constant Natural := Index (O.all, M); begin -- Force all tasks currently waiting on this monitor to abort if O.AEM_Infos (AEM_Index).TI /= null then pragma Debug (C1, O1 ("Disable_Polling: Aborting polling task")); PTI.Request_Abort_Polling (O.AEM_Infos (AEM_Index).TI.all); PolyORB.Asynch_Ev.Abort_Check_Sources (Selector (O.AEM_Infos (AEM_Index).TI.all).all); pragma Debug (C1, O1 ("Disable_Polling: waiting abort is complete")); O.AEM_Infos (AEM_Index).Polling_Abort_Counter := O.AEM_Infos (AEM_Index).Polling_Abort_Counter + 1; Wait (O.AEM_Infos (AEM_Index).Polling_Completed, O.ORB_Lock); O.AEM_Infos (AEM_Index).Polling_Abort_Counter := O.AEM_Infos (AEM_Index).Polling_Abort_Counter - 1; pragma Debug (C1, O1 ("Disable_Polling: aborting done")); end if; end Disable_Polling; -------------------- -- Enable_Polling -- -------------------- procedure Enable_Polling (O : access ORB_Controller_Leader_Followers; M : PAE.Asynch_Ev_Monitor_Access) is AEM_Index : constant Natural := Index (O.all, M); begin pragma Debug (C1, O1 ("Enable_Polling")); if O.AEM_Infos (AEM_Index).Polling_Abort_Counter = 0 then -- Allocate one task to poll on AES Try_Allocate_One_Task (O, Allow_Transient => True); end if; end Enable_Polling; ------------------ -- Notify_Event -- ------------------ procedure Notify_Event (O : access ORB_Controller_Leader_Followers; E : Event) is use type PRS.Request_Scheduler_Access; begin pragma Debug (C1, O1 ("Notify_Event: " & Event_Kind'Image (E.Kind))); case E.Kind is when End_Of_Check_Sources => declare AEM_Index : constant Natural := Index (O.all, E.On_Monitor); begin -- A task completed polling on a monitor pragma Debug (C1, O1 ("End of check sources on monitor #" & Natural'Image (AEM_Index) & Ada.Tags.External_Tag (O.AEM_Infos (AEM_Index).Monitor.all'Tag))); -- Reset TI O.AEM_Infos (AEM_Index).TI := null; if O.AEM_Infos (AEM_Index).Polling_Abort_Counter > 0 then -- This task has been aborted by one or more tasks, -- we broadcast them. Broadcast (O.AEM_Infos (AEM_Index).Polling_Completed); end if; end; when Event_Sources_Added => declare AEM_Index : Natural := Index (O.all, E.Add_In_Monitor); begin if AEM_Index = 0 then -- This monitor was not yet registered, register it pragma Debug (C1, O1 ("Adding new monitor")); for J in O.AEM_Infos'Range loop if O.AEM_Infos (J).Monitor = null then O.AEM_Infos (J).Monitor := E.Add_In_Monitor; AEM_Index := J; exit; end if; end loop; end if; pragma Debug (C1, O1 ("Added monitor at index:" & AEM_Index'Img & " " & Ada.Tags.External_Tag (O.AEM_Infos (AEM_Index).Monitor.all'Tag))); if O.AEM_Infos (AEM_Index).TI /= null and then not O.AEM_Infos (AEM_Index).Polling_Scheduled then -- No task is currently polling, allocate one O.AEM_Infos (AEM_Index).Polling_Scheduled := True; Try_Allocate_One_Task (O, Allow_Transient => True); end if; end; when Event_Sources_Deleted => -- An AES has been removed from monitored AES list null; when Job_Completed => -- A task has completed the execution of a job null; when ORB_Shutdown => -- ORB shutdown has been requested O.Shutdown := True; -- Awake all idle tasks Awake_All_Idle_Tasks (O.Idle_Tasks); -- Unblock blocked tasks for J in O.AEM_Infos'Range loop if O.AEM_Infos (J).TI /= null then PTI.Request_Abort_Polling (O.AEM_Infos (J).TI.all); PolyORB.Asynch_Ev.Abort_Check_Sources (Selector (O.AEM_Infos (J).TI.all).all); end if; end loop; when Queue_Event_Job => declare Note : LF_Task_Note; begin Get_Note (Get_Current_Thread_Notepad.all, Note); if Note.TI = E.By_Task and then Note.Job = null then -- Queue event directly into task attribute Set_Note (Get_Current_Thread_Notepad.all, LF_Task_Note'(Annotations.Note with TI => E.By_Task, Job => E.Event_Job)); else -- Queue event to main job queue PJ.Queue_Job (O.Job_Queue, E.Event_Job); Try_Allocate_One_Task (O, Allow_Transient => True); end if; end; when Queue_Request_Job => declare Job_Queued : Boolean := False; begin if O.RS /= null then Leave_ORB_Critical_Section (O); Job_Queued := PRS.Try_Queue_Request_Job (O.RS, E.Request_Job, E.Target); Enter_ORB_Critical_Section (O); end if; if not Job_Queued then -- Default : Queue event to main job queue declare Note : LF_Task_Note; -- Need documentation??? begin Get_Note (Get_Current_Thread_Notepad.all, Note); if Note.TI = Current_Task and then Note.Job = null then -- Queue event directly into task attribute -- What if TI is a transient task and the request -- is an upcall??? pragma Debug (C1, O1 ("Queue request in task area")); Set_Note (Get_Current_Thread_Notepad.all, LF_Task_Note'(Annotations.Note with TI => Note.TI, Job => E.Request_Job)); else PJ.Queue_Job (O.Job_Queue, E.Request_Job); Try_Allocate_One_Task (O, Allow_Transient => not Is_Upcall (E.Request_Job.all)); -- We don't want the ORB to borrow a transient task to -- make an upcall to application code, because this -- could take a long time or even deadlock. end if; end; end if; end; when Request_Result_Ready => -- A Request has been completed and a response is available. We -- must forward it to requesting task. We ensure this task will -- stop its current action and ask for rescheduling. Reschedule_Task (O, E.Requesting_Task); when Idle_Awake => -- A task has left Idle state Remove_Idle_Task (O.Idle_Tasks, E.Awakened_Task); when Task_Registered => null; when Task_Unregistered => Note_Task_Unregistered (O); end case; pragma Debug (C2, O2 (Status (O.all))); end Notify_Event; ------------------- -- Schedule_Task -- ------------------- procedure Schedule_Task (O : access ORB_Controller_Leader_Followers; TI : PTI.Task_Info_Access) is Note : LF_Task_Note; -- Needs documentation??? function Is_Schedulable (J : PJ.Job'Class) return Boolean; -- True if J is schedulable for this task (i.e. not an upcall job -- if the task is transient). -------------------- -- Is_Schedulable -- -------------------- function Is_Schedulable (J : PJ.Job'Class) return Boolean is begin return TI.Kind = Permanent or else not Is_Upcall (J); end Is_Schedulable; -- Start of processing for Schedule_Task begin pragma Debug (C1, O1 ("Schedule_Task " & PTI.Image (TI.all) & ": enter")); if State (TI.all) = Terminated then pragma Debug (C1, O1 ("Schedule_Task: task is terminated")); return; end if; Set_State_Unscheduled (O.Summary, TI.all); Get_Note (Get_Current_Thread_Notepad.all, Note); -- Recompute TI status if Exit_Condition (TI.all) or else (O.Shutdown and then not Has_Pending_Job (O) and then TI.Kind = Permanent) then Set_State_Terminated (O.Summary, TI.all); pragma Debug (C1, O1 ("Task is now terminated")); pragma Debug (C2, O2 (Status (O.all))); return; end if; declare Job : Job_Access; begin if Note.Job /= null then Job := Note.Job; Set_Note (Get_Current_Thread_Notepad.all, LF_Task_Note'(Annotations.Note with TI => Note.TI, Job => null)); else Job := PJ.Fetch_Job (O.Job_Queue, Is_Schedulable'Access); end if; if Job /= null then Set_State_Running (O.Summary, TI.all, Job); return; end if; end; declare AEM_Index : constant Natural := Need_Polling_Task (O); begin if AEM_Index > 0 then O.AEM_Infos (AEM_Index).Polling_Scheduled := False; O.AEM_Infos (AEM_Index).TI := TI; Set_State_Blocked (O.Summary, TI.all, O.AEM_Infos (AEM_Index).Monitor, O.AEM_Infos (AEM_Index).Polling_Timeout); pragma Debug (C1, O1 ("Task is now blocked on monitor" & Natural'Image (AEM_Index) & " " & Ada.Tags.External_Tag (O.AEM_Infos (AEM_Index).Monitor.all'Tag))); pragma Debug (C2, O2 (Status (O.all))); return; end if; end; Set_State_Idle (O.Summary, TI.all, Insert_Idle_Task (O.Idle_Tasks, TI), O.ORB_Lock); pragma Debug (C1, O1 ("Task is now idle")); pragma Debug (C2, O2 (Status (O.all))); end Schedule_Task; ------------ -- Create -- ------------ function Create (OCF : ORB_Controller_Leader_Followers_Factory) return ORB_Controller_Access is pragma Unreferenced (OCF); OC : ORB_Controller_Leader_Followers_Access; RS : PRS.Request_Scheduler_Access; begin PRS.Create (RS); OC := new ORB_Controller_Leader_Followers (RS); Initialize (ORB_Controller (OC.all)); return ORB_Controller_Access (OC); end Create; ---------------- -- Initialize -- ---------------- procedure Initialize; procedure Initialize is begin Register_ORB_Controller_Factory (OCF); end Initialize; use PolyORB.Initialization; use PolyORB.Initialization.String_Lists; use PolyORB.Utils.Strings; begin Register_Module (Module_Info' (Name => +"orb_controller.leader_followers", Conflicts => +"orb.no_tasking", Depends => +"tasking.condition_variables" & "tasking.mutexes" & "request_scheduler?", Provides => +"orb_controller!", Implicit => False, Init => Initialize'Access, Shutdown => null)); end PolyORB.ORB_Controller.Leader_Followers; polyorb-2.8~20110207.orig/src/corba/0000755000175000017500000000000011750740340016257 5ustar xavierxavierpolyorb-2.8~20110207.orig/src/corba/polyorb-corba_p-policy.ads0000644000175000017500000000554711750740340023351 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . C O R B A _ P . P O L I C Y -- -- -- -- S p e c -- -- -- -- Copyright (C) 2003-2009, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with CORBA; with PolyORB.Smart_Pointers.Controlled_Entities; package PolyORB.CORBA_P.Policy is package PSPCE renames PolyORB.Smart_Pointers.Controlled_Entities; type Policy_Object_Type is new PSPCE.Entity with private; type Policy_Object_Ptr is access all Policy_Object_Type'Class; function Get_Policy_Type (Self : Policy_Object_Type) return CORBA.PolicyType; procedure Set_Policy_Type (Self : in out Policy_Object_Type; Policy : CORBA.PolicyType); function Get_Policy_Value (Self : Policy_Object_Type) return CORBA.Any; procedure Set_Policy_Value (Self : in out Policy_Object_Type; Value : CORBA.Any); private type Policy_Object_Type is new PSPCE.Entity with record Policy : CORBA.PolicyType; Value : CORBA.Any; end record; end PolyORB.CORBA_P.Policy; polyorb-2.8~20110207.orig/src/corba/portableserver-servantlocator-impl.ads0000644000175000017500000000700111750740340026010 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O R T A B L E S E R V E R . S E R V A N T L O C A T O R . I M P L -- -- -- -- S p e c -- -- -- -- Copyright (C) 2005-2010, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the CORBA Specification, and adapted -- -- for use with PolyORB. The copyright notice above, and the license -- -- provisions that follow apply solely to the contents neither explicitly -- -- nor implicitly specified by the CORBA Specification defined by the OMG. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with PortableServer.ServantManager.Impl; package PortableServer.ServantLocator.Impl is type Object is new PortableServer.ServantManager.Impl.Object with private; type Object_Ptr is access all Object'Class; procedure Preinvoke (Self : access Object; Oid : PortableServer.ObjectId; Adapter : PortableServer.POA_Forward.Ref; Operation : CORBA.Identifier; The_Cookie : out PortableServer.ServantLocator.Cookie; Returns : out PortableServer.Servant); procedure Postinvoke (Self : access Object; Oid : PortableServer.ObjectId; Adapter : PortableServer.POA_Forward.Ref; Operation : CORBA.Identifier; The_Cookie : PortableServer.ServantLocator.Cookie; The_Servant : PortableServer.Servant); private type Object is new PortableServer.ServantManager.Impl.Object with null record; function Is_A (Self : not null access Object; Logical_Type_Id : Standard.String) return Boolean; end PortableServer.ServantLocator.Impl; polyorb-2.8~20110207.orig/src/corba/corba-fixed_point.ads0000644000175000017500000001062411750740337022355 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- C O R B A . F I X E D _ P O I N T -- -- -- -- S p e c -- -- -- -- Copyright (C) 2001-2008, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the CORBA Specification, and adapted -- -- for use with PolyORB. The copyright notice above, and the license -- -- provisions that follow apply solely to the contents neither explicitly -- -- nor implicitly specified by the CORBA Specification defined by the OMG. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- This unit provides generic helper routines for fixed point numeric types with Ada.Streams; with PolyORB.Any; with PolyORB.Types; generic type F is delta <> digits <>; package CORBA.Fixed_Point is function To_Any (Item : F) return Any; function From_Any (Item : Any) return F; function Wrap (X : access F) return PolyORB.Any.Content'Class; private use type PolyORB.Types.Unsigned_Long; Fixed_Content_Count : constant PolyORB.Types.Unsigned_Long := (F'Digits + 2) / 2; type F_Ptr is access all F; subtype F_Repr is Ada.Streams.Stream_Element_Array (0 .. Ada.Streams.Stream_Element_Offset (Fixed_Content_Count - 1)); type Fixed_Content is new PolyORB.Any.Aggregate_Content with record V : F_Ptr; Repr_Cache : F_Repr; -- We cache a representation of a fixed point value as an array of -- BCD octets, similar to the CDR encoding. This allows efficient -- access to these octets as aggregate elements. Modifications to -- the cache are reflected to V.all upon setting the last element of -- the array. end record; function Clone (ACC : Fixed_Content; Into : PolyORB.Any.Content_Ptr := null) return PolyORB.Any.Content_Ptr; procedure Finalize_Value (ACC : in out Fixed_Content); function Get_Aggregate_Element (ACC : not null access Fixed_Content; TC : PolyORB.Any.TypeCode.Object_Ptr; Index : PolyORB.Types.Unsigned_Long; Mech : not null access PolyORB.Any.Mechanism) return PolyORB.Any.Content'Class; procedure Set_Aggregate_Element (ACC : in out Fixed_Content; TC : PolyORB.Any.TypeCode.Object_Ptr; Index : PolyORB.Types.Unsigned_Long; From_C : in out PolyORB.Any.Any_Container'Class); function Get_Aggregate_Count (ACC : Fixed_Content) return PolyORB.Types.Unsigned_Long; procedure Set_Aggregate_Count (ACC : in out Fixed_Content; Count : PolyORB.Types.Unsigned_Long); end CORBA.Fixed_Point; polyorb-2.8~20110207.orig/src/corba/portableserver-poa-goa.ads0000644000175000017500000000663611750740340023343 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O R T A B L E S E R V E R . P O A . G O A -- -- -- -- S p e c -- -- -- -- Copyright (C) 2003-2008, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the CORBA Specification, and adapted -- -- for use with PolyORB. The copyright notice above, and the license -- -- provisions that follow apply solely to the contents neither explicitly -- -- nor implicitly specified by the CORBA Specification defined by the OMG. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with CORBA.Object; package PortableServer.POA.GOA is type Ref is new PortableServer.POA.Local_Ref with null record; function To_Ref (Self : CORBA.Object.Ref'Class) return Ref; ---------------------- -- Group management -- ---------------------- function Create_Id_For_Reference (Self : Ref; The_Ref : CORBA.Object.Ref) return PortableServer.ObjectId; -- raises (NotAGroupObject); -- create a new objectid and associate it with group The_Ref function Reference_To_Ids (Self : Ref; The_Ref : CORBA.Object.Ref) return IDs; -- raises (NotAGroupObject); -- user must free all object_id in list procedure Associate_Reference_With_Id (Self : Ref; Ref : CORBA.Object.Ref; Oid : PortableServer.ObjectId); -- raises(NotAGroupObject); procedure Disassociate_Reference_With_Id (Self : Ref; Ref : CORBA.Object.Ref; Oid : PortableServer.ObjectId); -- raises(NotAGroupObject); end PortableServer.POA.GOA; polyorb-2.8~20110207.orig/src/corba/corba-request.adb0000644000175000017500000002014011750740340021500 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- C O R B A . R E Q U E S T -- -- -- -- B o d y -- -- -- -- Copyright (C) 2001-2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- The CORBA Dynamic Invocation Interface. with PolyORB.CORBA_P.Exceptions; with PolyORB.CORBA_P.Interceptors_Hooks; with PolyORB.Errors.Helper; with PolyORB.Initialization; with PolyORB.QoS.Addressing_Modes; with PolyORB.References; with PolyORB.Request_QoS; with PolyORB.Smart_Pointers; with PolyORB.Utils.Strings; with CORBA.Object; package body CORBA.Request is procedure Default_Invoke (Request : access PolyORB.Requests.Request; Flags : PolyORB.Requests.Flags); -- Default request invocation subprogram -------------------- -- Create_Request -- -------------------- procedure Create_Request (Self : CORBA.AbstractBase.Ref; Ctx : CORBA.Context.Ref; Operation : Identifier; Arg_List : CORBA.NVList.Ref; Result : in out NamedValue; Request : out Object; Req_Flags : Flags) is pragma Unreferenced (Ctx); pragma Unreferenced (Req_Flags); PResult : PolyORB.Any.NamedValue := (Name => PolyORB.Types.Identifier (Result.Name), Argument => PolyORB.Any.Any (Result.Argument), Arg_Modes => PolyORB.Any.Flags (Result.Arg_Modes)); begin PolyORB.Requests.Setup_Request (Req => Request.The_Request, Target => CORBA.Object.Internals.To_PolyORB_Ref (CORBA.Object.Ref (AbstractBase.Ref'Class (Self))), Operation => To_Standard_String (Operation), Arg_List => NVList.Internals.To_PolyORB_Ref (Arg_List), Result => PResult, Req_Flags => PolyORB.Requests.Default_Flags); -- For now, we use the default flags??? end Create_Request; procedure Create_Request (Self : CORBA.AbstractBase.Ref; Ctx : CORBA.Context.Ref; Operation : Identifier; Arg_List : CORBA.NVList.Ref; Result : in out NamedValue; Exc_List : ExceptionList.Ref; Ctxt_List : ContextList.Ref; Request : out CORBA.Request.Object; Req_Flags : Flags) is pragma Unreferenced (Ctx, Ctxt_List); pragma Unreferenced (Req_Flags); PResult : PolyORB.Any.NamedValue := (Name => PolyORB.Types.Identifier (Result.Name), Argument => PolyORB.Any.Any (Result.Argument), Arg_Modes => PolyORB.Any.Flags (Result.Arg_Modes)); begin PolyORB.Requests.Setup_Request (Req => Request.The_Request, Target => CORBA.Object.Internals.To_PolyORB_Ref (CORBA.Object.Ref (AbstractBase.Ref'Class (Self))), Operation => To_Standard_String (Operation), Arg_List => CORBA.NVList.Internals.To_PolyORB_Ref (Arg_List), Result => PResult, Exc_List => CORBA.ExceptionList.Internals.To_PolyORB_Ref (Exc_List), Req_Flags => PolyORB.Requests.Default_Flags); -- For now, we use the default flags??? end Create_Request; -------------------- -- Default_Invoke -- -------------------- procedure Default_Invoke (Request : access PolyORB.Requests.Request; Flags : PolyORB.Requests.Flags) is use type PolyORB.Any.TypeCode.Local_Ref; begin loop PolyORB.Requests.Invoke (Request, Flags); exit when PolyORB.Any.Is_Empty (Request.Exception_Info) or else (PolyORB.Any.Get_Type (Request.Exception_Info) /= PolyORB.Errors.Helper.TC_ForwardRequest and then PolyORB.Any.Get_Type (Request.Exception_Info) /= PolyORB.Errors.Helper.TC_NeedsAddressingMode); -- Prepare request for new target if PolyORB.Any.Get_Type (Request.Exception_Info) = PolyORB.Errors.Helper.TC_ForwardRequest then -- Location forwarding declare Members : constant PolyORB.Errors.ForwardRequest_Members := PolyORB.Errors.Helper.From_Any (Request.Exception_Info); Ref : PolyORB.References.Ref; begin PolyORB.References.Set (Ref, PolyORB.Smart_Pointers.Entity_Of (Members.Forward_Reference)); PolyORB.Requests.Reset_Request (Request.all); Request.Target := Ref; end; else -- GIOP Addressing Mode change declare use PolyORB.QoS; use PolyORB.QoS.Addressing_Modes; use PolyORB.Request_QoS; Members : constant PolyORB.Errors.NeedsAddressingMode_Members := PolyORB.Errors.Helper.From_Any (Request.Exception_Info); begin PolyORB.Requests.Reset_Request (Request.all); Add_Request_QoS (Request.all, GIOP_Addressing_Mode, new QoS_GIOP_Addressing_Mode_Parameter' (Kind => GIOP_Addressing_Mode, Mode => Members.Mode)); end; end if; end loop; end Default_Invoke; ------------ -- Invoke -- ------------ procedure Invoke (Self : in out Object; Invoke_Flags : Flags := 0) is begin PolyORB.CORBA_P.Interceptors_Hooks.Client_Invoke (Self.The_Request'Access, PolyORB.Requests.Flags (Invoke_Flags)); PolyORB.CORBA_P.Exceptions.Request_Raise_Occurrence (Self.The_Request); end Invoke; ------------ -- Delete -- ------------ procedure Delete (Self : in out Object) is begin null; end Delete; ---------------- -- Initialize -- ---------------- procedure Initialize; procedure Initialize is begin PolyORB.CORBA_P.Interceptors_Hooks.Client_Invoke := Default_Invoke'Access; end Initialize; use PolyORB.Initialization; use PolyORB.Initialization.String_Lists; use PolyORB.Utils.Strings; begin Register_Module (Module_Info' (Name => +"corba.request", Conflicts => Empty, Depends => Empty, Provides => Empty, Implicit => False, Init => Initialize'Access, Shutdown => null)); end CORBA.Request; polyorb-2.8~20110207.orig/src/corba/portableserver-servantactivator.ads0000644000175000017500000000644711750740340025417 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O R T A B L E S E R V E R . S E R V A N T A C T I V A T O R -- -- -- -- S p e c -- -- -- -- Copyright (C) 2001-2008, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the CORBA Specification, and adapted -- -- for use with PolyORB. The copyright notice above, and the license -- -- provisions that follow apply solely to the contents neither explicitly -- -- nor implicitly specified by the CORBA Specification defined by the OMG. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with CORBA; with PortableServer.ServantManager; package PortableServer.ServantActivator is type Local_Ref is new PortableServer.ServantManager.Local_Ref with private; function Incarnate (Self : Local_Ref; Oid : PortableServer.ObjectId; Adapter : PortableServer.POA_Forward.Ref) return PortableServer.Servant; procedure Etherealize (Self : Local_Ref; Oid : PortableServer.ObjectId; Adapter : PortableServer.POA_Forward.Ref; Serv : PortableServer.Servant; Cleanup_In_Progress : CORBA.Boolean; Remaining_Activations : CORBA.Boolean); Repository_Id : constant Standard.String := "IDL:omg.org/PortableServer/ServantActivator:1.0"; private type Local_Ref is new PortableServer.ServantManager.Local_Ref with null record; end PortableServer.ServantActivator; polyorb-2.8~20110207.orig/src/corba/portableserver-adapteractivator.adb0000644000175000017500000000473711750740340025334 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O R T A B L E S E R V E R . A D A P T E R A C T I V A T O R -- -- -- -- B o d y -- -- -- -- Copyright (C) 2001-2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ package body PortableServer.AdapterActivator is --------------------- -- Unknown_Adapter -- --------------------- function Unknown_Adapter (Self : Ref; Parent : PortableServer.POA_Forward.Ref; Name : CORBA.String) return Boolean is pragma Unreferenced (Self); pragma Unreferenced (Parent); pragma Unreferenced (Name); begin return False; end Unknown_Adapter; end PortableServer.AdapterActivator; polyorb-2.8~20110207.orig/src/corba/corba-policy.adb0000644000175000017500000000476511750740337021334 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- C O R B A . P O L I C Y -- -- -- -- B o d y -- -- -- -- Copyright (C) 2003-2007, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with PolyORB.CORBA_P.Policy; package body CORBA.Policy is use PolyORB.CORBA_P.Policy; --------------------- -- Get_Policy_Type -- --------------------- function Get_Policy_Type (Self : Ref) return PolicyType is begin return Get_Policy_Type (Policy_Object_Type (Entity_Of (Self).all)); end Get_Policy_Type; ---------- -- Copy -- ---------- function Copy (Self : Ref'Class) return Ref'Class is begin return Self; end Copy; end CORBA.Policy; polyorb-2.8~20110207.orig/src/corba/portableserver-servantactivator.adb0000644000175000017500000000651611750740340025373 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O R T A B L E S E R V E R . S E R V A N T A C T I V A T O R -- -- -- -- B o d y -- -- -- -- Copyright (C) 2003-2005 Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with PortableServer.ServantActivator.Impl; package body PortableServer.ServantActivator is --------------- -- Incarnate -- --------------- function Incarnate (Self : Local_Ref; Oid : PortableServer.ObjectId; Adapter : PortableServer.POA_Forward.Ref) return PortableServer.Servant is begin if CORBA.Object.Is_Nil (CORBA.Object.Ref (Self)) then CORBA.Raise_Inv_Objref (CORBA.Default_Sys_Member); end if; return Impl.Incarnate (Impl.Object_Ptr (Entity_Of (Self)), Oid, Adapter); end Incarnate; ----------------- -- Etherealize -- ----------------- procedure Etherealize (Self : Local_Ref; Oid : PortableServer.ObjectId; Adapter : PortableServer.POA_Forward.Ref; Serv : PortableServer.Servant; Cleanup_In_Progress : CORBA.Boolean; Remaining_Activations : CORBA.Boolean) is begin if CORBA.Object.Is_Nil (CORBA.Object.Ref (Self)) then CORBA.Raise_Inv_Objref (CORBA.Default_Sys_Member); end if; Impl.Etherealize (Impl.Object_Ptr (Entity_Of (Self)), Oid, Adapter, Serv, Cleanup_In_Progress, Remaining_Activations); end Etherealize; end PortableServer.ServantActivator; polyorb-2.8~20110207.orig/src/corba/corba-serverrequest.ads0000644000175000017500000000641511750740340022761 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- C O R B A . S E R V E R R E Q U E S T -- -- -- -- S p e c -- -- -- -- Copyright (C) 2001-2008, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the CORBA Specification, and adapted -- -- for use with PolyORB. The copyright notice above, and the license -- -- provisions that follow apply solely to the contents neither explicitly -- -- nor implicitly specified by the CORBA Specification defined by the OMG. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- Mapping for the standard ServerRequest interface with PolyORB.Requests; with CORBA.NVList; package CORBA.ServerRequest is pragma Elaborate_Body; -- interface ServerRequest { // PIDL -- readonly attribute Identifier operation; -- void arguments (inout NVList nv); -- Context ctx(); -- void set_result (in any val); -- void set_exception(in any val); -- }; subtype Object is PolyORB.Requests.Request; subtype Object_Ptr is PolyORB.Requests.Request_Access; function Operation (O : Object) return Identifier; procedure Arguments (O : access Object; NV : in out NVList.Ref); -- function Ctx return Context; procedure Set_Result (O : access Object; Val : Any); procedure Set_Exception (Obj : access Object; Val : Any); end CORBA.ServerRequest; polyorb-2.8~20110207.orig/src/corba/polyorb-sequences-bounded-corba_helper.adb0000644000175000017500000000707411750740340026457 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- POLYORB.SEQUENCES.BOUNDED.CORBA_HELPER -- -- -- -- B o d y -- -- -- -- Copyright (C) 2003-2007, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- Any conversion subprograms for bounded sequences package body PolyORB.Sequences.Bounded.CORBA_Helper is ------------------------------ -- Element_From_Any_Wrapper -- ------------------------------ function Element_From_Any_Wrapper (Item : PolyORB.Any.Any) return Element is begin return Element_From_Any (CORBA.Any (Item)); end Element_From_Any_Wrapper; ---------------------------- -- Element_To_Any_Wrapper -- ---------------------------- function Element_To_Any_Wrapper (Item : Element) return PolyORB.Any.Any is begin return PolyORB.Any.Any (Element_To_Any (Item)); end Element_To_Any_Wrapper; -------------- -- From_Any -- -------------- function From_Any (Item : CORBA.Any) return Sequence is begin return Neutral_Helper.From_Any (PolyORB.Any.Any (Item)); end From_Any; ---------------- -- Initialize -- ---------------- procedure Initialize (Element_TC, Sequence_TC : CORBA.TypeCode.Object) is use CORBA.TypeCode.Internals; begin Neutral_Helper.Initialize (Element_TC => To_PolyORB_Object (Element_TC), Sequence_TC => To_PolyORB_Object (Sequence_TC)); end Initialize; ------------ -- To_Any -- ------------ function To_Any (Item : Sequence) return CORBA.Any is begin return CORBA.Any (Neutral_Helper.To_Any (Item)); end To_Any; ---------- -- Wrap -- ---------- function Wrap (X : access Sequence) return PolyORB.Any.Content'Class renames Neutral_Helper.Wrap; end PolyORB.Sequences.Bounded.CORBA_Helper; polyorb-2.8~20110207.orig/src/corba/portableserver-threadpolicy.adb0000644000175000017500000001400411750740340024452 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O R T A B L E S E R V E R . T H R E A D P O L I C Y -- -- -- -- B o d y -- -- -- -- Copyright (C) 2003-2007, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with PolyORB.CORBA_P.Policy; with PolyORB.CORBA_P.Policy_Management; with PortableServer.Helper; with PolyORB.Initialization; with PolyORB.Smart_Pointers; with PolyORB.Utils.Strings; package body PortableServer.ThreadPolicy is use CORBA; use CORBA.Policy; use CORBA.TypeCode; use PortableServer.Helper; use PolyORB.CORBA_P.Policy; use PolyORB.CORBA_P.Policy_Management; function Create_ThreadPolicy (The_Type : CORBA.PolicyType; Value : CORBA.Any) return CORBA.Policy.Ref; ------------ -- To_Ref -- ------------ function To_Ref (The_Ref : CORBA.Object.Ref'Class) return Ref is begin if The_Ref not in CORBA.Policy.Ref'Class or else Get_Policy_Type (CORBA.Policy.Ref (The_Ref)) /= THREAD_POLICY_ID then CORBA.Raise_Bad_Param (CORBA.Default_Sys_Member); end if; declare Entity : constant PolyORB.Smart_Pointers.Entity_Ptr := new Policy_Object_Type; Result : Ref; begin Set_Policy_Type (Policy_Object_Type (Entity.all), THREAD_POLICY_ID); Set_Policy_Value (Policy_Object_Type (Entity.all), Get_Policy_Value (Policy_Object_Type (Entity_Of (CORBA.Policy.Ref (The_Ref)).all))); CORBA.Policy.Set (CORBA.Policy.Ref (Result), Entity); return Result; end; end To_Ref; --------------- -- Get_Value -- --------------- function Get_Value (Self : Ref) return PortableServer.ThreadPolicyValue is begin return From_Any (Get_Policy_Value (Policy_Object_Type (Entity_Of (CORBA.Policy.Ref (Self)).all))); end Get_Value; ------------------------- -- Create_ThreadPolicy -- ------------------------- function Create_ThreadPolicy (The_Type : CORBA.PolicyType; Value : CORBA.Any) return CORBA.Policy.Ref is begin pragma Assert (The_Type = THREAD_POLICY_ID); if Get_Type (Value) /= TC_ThreadPolicyValue then Raise_PolicyError ((Reason => BAD_POLICY_TYPE)); end if; declare Position : constant CORBA.Unsigned_Long := CORBA.From_Any (CORBA.Internals.Get_Aggregate_Element (Value, CORBA.TC_Unsigned_Long, CORBA.Unsigned_Long (0))); begin if Position > ThreadPolicyValue'Pos (ThreadPolicyValue'Last) then Raise_PolicyError ((Reason => BAD_POLICY_VALUE)); end if; end; declare Result : CORBA.Policy.Ref; Entity : constant PolyORB.Smart_Pointers.Entity_Ptr := new Policy_Object_Type; begin Set_Policy_Type (Policy_Object_Type (Entity.all), The_Type); Set_Policy_Value (Policy_Object_Type (Entity.all), Value); CORBA.Policy.Set (Result, Entity); return Result; end; end Create_ThreadPolicy; ----------------------------- -- Deferred_Initialization -- ----------------------------- procedure Deferred_Initialization; procedure Deferred_Initialization is begin Register (The_Type => THREAD_POLICY_ID, POA_Level => True, Factory => Create_ThreadPolicy'Access, System_Default => Create_ThreadPolicy (THREAD_POLICY_ID, To_Any (ORB_CTRL_MODEL))); end Deferred_Initialization; use PolyORB.Initialization; use PolyORB.Initialization.String_Lists; use PolyORB.Utils.Strings; begin Register_Module (Module_Info' (Name => +"portableserver.threadpolicy", Conflicts => Empty, Depends => +"PortableServer.Helper", Provides => Empty, Implicit => False, Init => Deferred_Initialization'Access, Shutdown => null)); end PortableServer.ThreadPolicy; polyorb-2.8~20110207.orig/src/corba/polyorb-corba_p-servantactivator.adb0000644000175000017500000001331611750740340025421 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . C O R B A _ P . S E R V A N T A C T I V A T O R -- -- -- -- B o d y -- -- -- -- Copyright (C) 2003-2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with CORBA.Impl; with CORBA.Object; package body PolyORB.CORBA_P.ServantActivator is ------------ -- Create -- ------------ procedure Create (Self : out PPT.ServantActivator_Access; SA : PortableServer.ServantActivator.Local_Ref'Class) is Activator : constant Object_Ptr := new Object; begin Self := new CORBA_ServantActivator; Activator.SA := PortableServer.ServantActivator.Local_Ref (SA); Set (CORBA_ServantActivator (Self.all), PolyORB.Smart_Pointers.Entity_Ptr (Activator)); end Create; ------------------------- -- Get_Servant_Manager -- ------------------------- function Get_Servant_Manager (Self : CORBA_ServantActivator) return PortableServer.ServantActivator.Local_Ref'Class is Activator : constant Object_Ptr := Object_Ptr (Entity_Of (Self)); begin return Activator.SA; end Get_Servant_Manager; --------------- -- Incarnate -- --------------- procedure Incarnate (Self : access CORBA_ServantActivator; Oid : PPT.Object_Id; Adapter : access PPT.Obj_Adapter'Class; Returns : out PolyORB.Servants.Servant_Access; Error : in out PolyORB.Errors.Error_Container) is use type PortableServer.Servant; CORBA_POA : PortableServer.POA_Forward.Ref; CORBA_Servant : PortableServer.Servant; Activator : constant PortableServer.ServantActivator.Local_Ref'Class := Get_Servant_Manager (Self.all); begin PortableServer.POA_Forward.Set (CORBA_POA, PolyORB.Smart_Pointers.Entity_Ptr (Adapter)); begin CORBA_Servant := PortableServer.ServantActivator.Incarnate (Activator, PortableServer.Internals.To_PortableServer_ObjectId (Oid), CORBA_POA); exception when E : PortableServer.ForwardRequest => declare Members : PortableServer.ForwardRequest_Members; begin PortableServer.Get_Members (E, Members); Error.Kind := PolyORB.Errors.ForwardRequest_E; Error.Member := new PolyORB.Errors.ForwardRequest_Members' (Forward_Reference => PolyORB.Smart_Pointers.Ref (CORBA.Object.Internals.To_PolyORB_Ref (Members.Forward_Reference))); end; end; if CORBA_Servant = null then Returns := null; else Returns := PortableServer.To_PolyORB_Servant (CORBA_Servant); end if; end Incarnate; ----------------- -- Etherealize -- ----------------- procedure Etherealize (Self : access CORBA_ServantActivator; Oid : PPT.Object_Id; Adapter : access PPT.Obj_Adapter'Class; Serv : PolyORB.Servants.Servant_Access; Cleanup_In_Progress : Boolean; Remaining_Activations : Boolean) is CORBA_POA : PortableServer.POA_Forward.Ref; POA_Servant : constant PortableServer.Servant := PortableServer.Servant (CORBA.Impl.Internals.To_CORBA_Servant (Serv)); Activator : constant PortableServer.ServantActivator.Local_Ref'Class := Get_Servant_Manager (Self.all); begin PortableServer.POA_Forward.Set (CORBA_POA, PolyORB.Smart_Pointers.Entity_Ptr (Adapter)); PortableServer.ServantActivator.Etherealize (Activator, PortableServer.Internals.To_PortableServer_ObjectId (Oid), CORBA_POA, POA_Servant, Cleanup_In_Progress, Remaining_Activations); end Etherealize; end PolyORB.CORBA_P.ServantActivator; polyorb-2.8~20110207.orig/src/corba/corba-forward.ads0000644000175000017500000000630211750740337021507 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- C O R B A . F O R W A R D -- -- -- -- S p e c -- -- -- -- Copyright (C) 2001-2008, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the CORBA Specification, and adapted -- -- for use with PolyORB. The copyright notice above, and the license -- -- provisions that follow apply solely to the contents neither explicitly -- -- nor implicitly specified by the CORBA Specification defined by the OMG. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with CORBA.Object; generic package CORBA.Forward is pragma Elaborate_Body; type Ref is new CORBA.Object.Ref with null record; -- A forward reference to some object -- Package Convert is instantiated once the real (full) reference type -- declaration has been encountered. generic type Ref_Type is new CORBA.Object.Ref with private; -- The full reference type corresponding to this forward type package Convert is -- Conversion between the forward reference type Ref and the full -- reference type Ref_Type. function From_Forward (The_Forward : Ref) return Ref_Type; function To_Ref (The_Forward : Ref) return Ref_Type renames From_Forward; function To_Forward (The_Ref : Ref_Type) return Ref; end Convert; end CORBA.Forward; polyorb-2.8~20110207.orig/src/corba/polyorb-corba_p-domain_management.adb0000644000175000017500000000542311750740340025465 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . C O R B A _ P . D O M A I N _ M A N A G E M E N T -- -- -- -- B o d y -- -- -- -- Copyright (C) 2005-2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with CORBA.DomainManager.Helper; with CORBA.Impl; with PolyORB.Servants; package body PolyORB.CORBA_P.Domain_Management is ------------------------- -- Get_Domain_Managers -- ------------------------- function Get_Domain_Managers (Servant : PortableServer.Servant) return CORBA.Any is Notepad : constant PolyORB.Annotations.Notepad_Access := PolyORB.Servants.Notepad_Of (CORBA.Impl.To_PolyORB_Servant (CORBA.Impl.Object (Servant.all)'Access)); Note : Domain_Manager_Note; begin PolyORB.Annotations.Get_Note (Notepad.all, Note, Empty_Domain_Manager_Note); return CORBA.DomainManager.Helper.To_Any (Note.Domain_Managers); end Get_Domain_Managers; end PolyORB.CORBA_P.Domain_Management; polyorb-2.8~20110207.orig/src/corba/portableserver-poa-helper.ads0000644000175000017500000001515211750740340024045 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O R T A B L E S E R V E R . P O A . H E L P E R -- -- -- -- S p e c -- -- -- -- Copyright (C) 2004-2008, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the CORBA Specification, and adapted -- -- for use with PolyORB. The copyright notice above, and the license -- -- provisions that follow apply solely to the contents neither explicitly -- -- nor implicitly specified by the CORBA Specification defined by the OMG. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ ------------------------------------------------- -- This file has been generated automatically -- by IDLAC version 2.3.0w. -- -- Do NOT hand-modify this file, as your -- changes will be lost when you re-run the -- IDL to Ada compiler. ------------------------------------------------- pragma Style_Checks ("NM32766"); with CORBA; pragma Elaborate_All (CORBA); with CORBA.Object; package PortableServer.POA.Helper is function Unchecked_To_Local_Ref (The_Ref : CORBA.Object.Ref'Class) return PortableServer.POA.Local_Ref; function To_Local_Ref (The_Ref : CORBA.Object.Ref'Class) return PortableServer.POA.Local_Ref; TC_POA : CORBA.TypeCode.Object; TC_AdapterAlreadyExists : CORBA.TypeCode.Object; function From_Any (Item : CORBA.Any) return PortableServer.POA.AdapterAlreadyExists_Members; function To_Any (Item : PortableServer.POA.AdapterAlreadyExists_Members) return CORBA.Any; procedure Raise_AdapterAlreadyExists (Members : AdapterAlreadyExists_Members); pragma No_Return (Raise_AdapterAlreadyExists); TC_AdapterNonExistent : CORBA.TypeCode.Object; function From_Any (Item : CORBA.Any) return PortableServer.POA.AdapterNonExistent_Members; function To_Any (Item : PortableServer.POA.AdapterNonExistent_Members) return CORBA.Any; procedure Raise_AdapterNonExistent (Members : AdapterNonExistent_Members); pragma No_Return (Raise_AdapterNonExistent); TC_InvalidPolicy : CORBA.TypeCode.Object; function From_Any (Item : CORBA.Any) return PortableServer.POA.InvalidPolicy_Members; function To_Any (Item : PortableServer.POA.InvalidPolicy_Members) return CORBA.Any; procedure Raise_InvalidPolicy (Members : InvalidPolicy_Members); pragma No_Return (Raise_InvalidPolicy); TC_NoServant : CORBA.TypeCode.Object; function From_Any (Item : CORBA.Any) return PortableServer.POA.NoServant_Members; function To_Any (Item : PortableServer.POA.NoServant_Members) return CORBA.Any; procedure Raise_NoServant (Members : NoServant_Members); pragma No_Return (Raise_NoServant); TC_ObjectAlreadyActive : CORBA.TypeCode.Object; function From_Any (Item : CORBA.Any) return PortableServer.POA.ObjectAlreadyActive_Members; function To_Any (Item : PortableServer.POA.ObjectAlreadyActive_Members) return CORBA.Any; procedure Raise_ObjectAlreadyActive (Members : in ObjectAlreadyActive_Members); pragma No_Return (Raise_ObjectAlreadyActive); TC_ObjectNotActive : CORBA.TypeCode.Object; function From_Any (Item : CORBA.Any) return PortableServer.POA.ObjectNotActive_Members; function To_Any (Item : PortableServer.POA.ObjectNotActive_Members) return CORBA.Any; procedure Raise_ObjectNotActive (Members : in ObjectNotActive_Members); pragma No_Return (Raise_ObjectNotActive); TC_ServantAlreadyActive : CORBA.TypeCode.Object; function From_Any (Item : CORBA.Any) return PortableServer.POA.ServantAlreadyActive_Members; function To_Any (Item : PortableServer.POA.ServantAlreadyActive_Members) return CORBA.Any; procedure Raise_ServantAlreadyActive (Members : ServantAlreadyActive_Members); pragma No_Return (Raise_ServantAlreadyActive); TC_ServantNotActive : CORBA.TypeCode.Object; function From_Any (Item : CORBA.Any) return PortableServer.POA.ServantNotActive_Members; function To_Any (Item : PortableServer.POA.ServantNotActive_Members) return CORBA.Any; procedure Raise_ServantNotActive (Members : ServantNotActive_Members); pragma No_Return (Raise_ServantNotActive); TC_WrongAdapter : CORBA.TypeCode.Object; function From_Any (Item : CORBA.Any) return PortableServer.POA.WrongAdapter_Members; function To_Any (Item : PortableServer.POA.WrongAdapter_Members) return CORBA.Any; procedure Raise_WrongAdapter (Members : WrongAdapter_Members); pragma No_Return (Raise_WrongAdapter); TC_WrongPolicy : CORBA.TypeCode.Object; function From_Any (Item : CORBA.Any) return PortableServer.POA.WrongPolicy_Members; function To_Any (Item : PortableServer.POA.WrongPolicy_Members) return CORBA.Any; procedure Raise_WrongPolicy (Members : WrongPolicy_Members); pragma No_Return (Raise_WrongPolicy); end PortableServer.POA.Helper; polyorb-2.8~20110207.orig/src/corba/corba-nvlist.adb0000644000175000017500000001231411750740337021341 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- C O R B A . N V L I S T -- -- -- -- B o d y -- -- -- -- Copyright (C) 2001-2007, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ package body CORBA.NVList is -------------- -- Add_Item -- -------------- procedure Add_Item (Self : Ref; Item_Name : Identifier; Item : CORBA.Any; Item_Flags : Flags) is begin PolyORB.Any.NVList.Add_Item (Internals.To_PolyORB_Ref (Self), PolyORB.Types.Identifier (Item_Name), PolyORB.Any.Any (Item), PolyORB.Any.Flags (Item_Flags)); end Add_Item; procedure Add_Item (Self : Ref; Item : CORBA.NamedValue) is begin Add_Item (Self, Item.Name, Item.Argument, Item.Arg_Modes); end Add_Item; --------------- -- Get_Count -- --------------- function Get_Count (Self : Ref) return CORBA.Long is begin return CORBA.Long (PolyORB.Any.NVList.Get_Count (Internals.To_PolyORB_Ref (Self))); end Get_Count; ---------- -- Free -- ---------- procedure Free (Self : Ref) is pragma Warnings (Off); pragma Unreferenced (Self); pragma Warnings (On); begin null; end Free; ---------------- -- Initialize -- ---------------- procedure Initialize (Self : in out Ref) is Res : PolyORB.Any.NVList.Ref; begin CORBA.AbstractBase.Initialize (CORBA.AbstractBase.Ref (Self)); PolyORB.Any.NVList.Create (Res); Set (Self, PolyORB.Any.NVList.Entity_Of (Res)); end Initialize; package body Internals is -------------------- -- Clone_Out_Args -- -------------------- procedure Clone_Out_Args (Self : Ref) is use PolyORB.Any.NVList.Internals; use PolyORB.Any.NVList.Internals.NV_Lists; It : Iterator; begin It := First (List_Of (To_PolyORB_Ref (Self)).all); while not Last (It) loop declare use PolyORB.Any; NV : PolyORB.Any.NamedValue renames Value (It).all; begin if NV.Arg_Modes = PolyORB.Any.ARG_OUT or else NV.Arg_Modes = PolyORB.Any.ARG_INOUT then NV.Argument := Copy_Any (NV.Argument); end if; end; Next (It); end loop; end Clone_Out_Args; ---------- -- Item -- ---------- function Item (Self : Ref; Index : CORBA.Long) return CORBA.NamedValue is use PolyORB.Any.NVList.Internals; use PolyORB.Any.NVList.Internals.NV_Lists; begin return To_CORBA_NV (Element (List_Of (To_PolyORB_Ref (Self)).all, Integer (Index)).all); end Item; ------------------ -- To_CORBA_Ref -- ------------------ function To_CORBA_Ref (Self : PolyORB.Any.NVList.Ref) return Ref is Res : Ref; begin Set (Res, PolyORB.Any.NVList.Entity_Of (Self)); return Res; end To_CORBA_Ref; -------------------- -- To_PolyORB_Ref -- -------------------- function To_PolyORB_Ref (Self : Ref) return PolyORB.Any.NVList.Ref is Res : PolyORB.Any.NVList.Ref; begin PolyORB.Any.NVList.Set (Res, Entity_Of (Self)); return Res; end To_PolyORB_Ref; end Internals; end CORBA.NVList; polyorb-2.8~20110207.orig/src/corba/polyorb-sequences-bounded-corba_helper.ads0000644000175000017500000000637411750740340026502 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- POLYORB.SEQUENCES.BOUNDED.CORBA_HELPER -- -- -- -- S p e c -- -- -- -- Copyright (C) 2003-2007, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- Any conversion subprograms for bounded sequences with CORBA; with PolyORB.Any; with PolyORB.Sequences.Bounded.Helper; pragma Elaborate_All (PolyORB.Sequences.Bounded.Helper); generic with function Element_From_Any (Item : CORBA.Any) return Element; with function Element_To_Any (Item : Element) return CORBA.Any; with function Element_Wrap (X : access Element) return PolyORB.Any.Content'Class; package PolyORB.Sequences.Bounded.CORBA_Helper is function From_Any (Item : CORBA.Any) return Sequence; function To_Any (Item : Sequence) return CORBA.Any; function Wrap (X : access Sequence) return PolyORB.Any.Content'Class; procedure Initialize (Element_TC, Sequence_TC : CORBA.TypeCode.Object); private function Element_From_Any_Wrapper (Item : PolyORB.Any.Any) return Element; function Element_To_Any_Wrapper (Item : Element) return PolyORB.Any.Any; -- Helpers operating on PolyORB Any's, constructed from the formal helpers -- operating on CORBA Any's. package Neutral_Helper is new PolyORB.Sequences.Bounded.Helper (Element_From_Any => Element_From_Any_Wrapper, Element_To_Any => Element_To_Any_Wrapper, Element_Wrap => Element_Wrap); end PolyORB.Sequences.Bounded.CORBA_Helper; polyorb-2.8~20110207.orig/src/corba/portableinterceptor/0000755000175000017500000000000011750740340022346 5ustar xavierxavier././@LongLink0000000000000000000000000000015000000000000011561 Lustar rootrootpolyorb-2.8~20110207.orig/src/corba/portableinterceptor/portableinterceptor-iorinterceptor_3_0-impl.adspolyorb-2.8~20110207.orig/src/corba/portableinterceptor/portableinterceptor-iorinterceptor_3_0-impl.0000644000175000017500000000652011750740340033107 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- PORTABLEINTERCEPTOR.IORINTERCEPTOR_3_0.IMPL -- -- -- -- S p e c -- -- -- -- Copyright (C) 2004-2010, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the CORBA Specification, and adapted -- -- for use with PolyORB. The copyright notice above, and the license -- -- provisions that follow apply solely to the contents neither explicitly -- -- nor implicitly specified by the CORBA Specification defined by the OMG. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with PortableInterceptor.IORInterceptor.Impl; package PortableInterceptor.IORInterceptor_3_0.Impl is type Object is new PortableInterceptor.IORInterceptor.Impl.Object with private; type Object_Ptr is access all Object'Class; procedure Components_Established (Self : access Object; Info : PortableInterceptor.IORInfo.Local_Ref); procedure Adapter_Manager_State_Changed (Self : access Object; Id : AdapterManagerId; State : AdapterState); -- procedure Adapter_State_Changed -- (Self : access Object; -- Templates : ObjectReferenceTemplate.Abstract_Value_Ref; -- State : PortableInterceptor.AdapterState); function Is_A (Self : not null access Object; Logical_Type_Id : Standard.String) return Boolean; private type Object is new PortableInterceptor.IORInterceptor.Impl.Object with null record; end PortableInterceptor.IORInterceptor_3_0.Impl; polyorb-2.8~20110207.orig/src/corba/portableinterceptor/polyorb-corba_p-interceptors_policies.ads0000644000175000017500000000445511750740340032546 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- POLYORB.CORBA_P.INTERCEPTORS_POLICIES -- -- -- -- S p e c -- -- -- -- Copyright (C) 2004-2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with CORBA; with PortableInterceptor.PolicyFactory; package PolyORB.CORBA_P.Interceptors_Policies is procedure Register_Policy_Factory (IDL_Type : CORBA.PolicyType; Policy_Factory : PortableInterceptor.PolicyFactory.Local_Ref); end PolyORB.CORBA_P.Interceptors_Policies; ././@LongLink0000000000000000000000000000015600000000000011567 Lustar rootrootpolyorb-2.8~20110207.orig/src/corba/portableinterceptor/portableinterceptor-clientrequestinterceptor-impl.adbpolyorb-2.8~20110207.orig/src/corba/portableinterceptor/portableinterceptor-clientrequestinterceptor0000644000175000017500000001032111750740340033521 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- PORTABLEINTERCEPTOR.CLIENTREQUESTINTERCEPTOR.IMPL -- -- -- -- B o d y -- -- -- -- Copyright (C) 2004-2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with CORBA; with PortableInterceptor.Interceptor; package body PortableInterceptor.ClientRequestInterceptor.Impl is ---------- -- Is_A -- ---------- function Is_A (Self : not null access Object; Logical_Type_Id : String) return Boolean is pragma Unreferenced (Self); begin return CORBA.Is_Equivalent (Logical_Type_Id, PortableInterceptor.ClientRequestInterceptor.Repository_Id) or else CORBA.Is_Equivalent (Logical_Type_Id, PortableInterceptor.Interceptor.Repository_Id) or else CORBA.Is_Equivalent (Logical_Type_Id, "IDL:omg.org/CORBA/Object:1.0"); end Is_A; ----------------------- -- Receive_Exception -- ----------------------- procedure Receive_Exception (Self : access Object; RI : PortableInterceptor.ClientRequestInfo.Local_Ref) is pragma Unreferenced (Self); pragma Unreferenced (RI); begin null; end Receive_Exception; ------------------- -- Receive_Other -- ------------------- procedure Receive_Other (Self : access Object; RI : PortableInterceptor.ClientRequestInfo.Local_Ref) is pragma Unreferenced (Self); pragma Unreferenced (RI); begin null; end Receive_Other; ------------------- -- Receive_Reply -- ------------------- procedure Receive_Reply (Self : access Object; RI : PortableInterceptor.ClientRequestInfo.Local_Ref) is pragma Unreferenced (Self); pragma Unreferenced (RI); begin null; end Receive_Reply; --------------- -- Send_Poll -- --------------- procedure Send_Poll (Self : access Object; RI : PortableInterceptor.ClientRequestInfo.Local_Ref) is pragma Unreferenced (Self); pragma Unreferenced (RI); begin null; end Send_Poll; ------------------ -- Send_Request -- ------------------ procedure Send_Request (Self : access Object; RI : PortableInterceptor.ClientRequestInfo.Local_Ref) is pragma Unreferenced (Self); pragma Unreferenced (RI); begin null; end Send_Request; end PortableInterceptor.ClientRequestInterceptor.Impl; polyorb-2.8~20110207.orig/src/corba/portableinterceptor/portableinterceptor-requestinfo-impl.ads0000644000175000017500000001100211750740340032421 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- PORTABLEINTERCEPTOR.REQUESTINFO.IMPL -- -- -- -- S p e c -- -- -- -- Copyright (C) 2004-2010, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the CORBA Specification, and adapted -- -- for use with PolyORB. The copyright notice above, and the license -- -- provisions that follow apply solely to the contents neither explicitly -- -- nor implicitly specified by the CORBA Specification defined by the OMG. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with CORBA.Local; with Dynamic; with Messaging; with PolyORB.Requests; package PortableInterceptor.RequestInfo.Impl is type Object is new CORBA.Local.Object with private; type Object_Ptr is access all Object'Class; function Get_Request_Id (Self : access Object) return CORBA.Unsigned_Long; function Get_Operation (Self : access Object) return CORBA.String; function Get_Arguments (Self : access Object) return Dynamic.ParameterList; function Get_Exceptions (Self : access Object) return Dynamic.ExceptionList; function Get_Contexts (Self : access Object) return Dynamic.ContextList; function Get_Operation_Context (Self : access Object) return Dynamic.RequestContext; function Get_Result (Self : access Object) return CORBA.Any; function Get_Response_Expected (Self : access Object) return CORBA.Boolean; function Get_Sync_Scope (Self : access Object) return Messaging.SyncScope; function Get_Reply_Status (Self : access Object) return ReplyStatus; function Get_Forward_Reference (Self : access Object) return CORBA.Object.Ref; function Get_Slot (Self : access Object; Id : SlotId) return CORBA.Any; function Get_Request_Service_Context (Self : access Object; Id : IOP.ServiceId) return IOP.ServiceContext; function Get_Reply_Service_Context (Self : access Object; Id : IOP.ServiceId) return IOP.ServiceContext; function Is_A (Self : not null access Object; Logical_Type_Id : String) return Boolean; procedure Init (Self : access Object; Request : PolyORB.Requests.Request_Access; Request_Id : CORBA.Unsigned_Long); -- Implementation Note: This procedure initialize a RequestInfo -- object. It is specific to PolyORB. You should not use it. private type Object is new CORBA.Local.Object with record Request : PolyORB.Requests.Request_Access; Request_Id : CORBA.Unsigned_Long; end record; end PortableInterceptor.RequestInfo.Impl; ././@LongLink0000000000000000000000000000014700000000000011567 Lustar rootrootpolyorb-2.8~20110207.orig/src/corba/portableinterceptor/portableinterceptor-clientrequestinfo-impl.adspolyorb-2.8~20110207.orig/src/corba/portableinterceptor/portableinterceptor-clientrequestinfo-impl.a0000644000175000017500000001275511750740340033311 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- PORTABLEINTERCEPTOR.CLIENTREQUESTINFO.IMPL -- -- -- -- S p e c -- -- -- -- Copyright (C) 2004-2010, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the CORBA Specification, and adapted -- -- for use with PolyORB. The copyright notice above, and the license -- -- provisions that follow apply solely to the contents neither explicitly -- -- nor implicitly specified by the CORBA Specification defined by the OMG. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with PolyORB.CORBA_P.Interceptors; with PolyORB.Requests; with Dynamic; with Messaging; with PortableInterceptor.RequestInfo.Impl; package PortableInterceptor.ClientRequestInfo.Impl is type Object is new PortableInterceptor.RequestInfo.Impl.Object with private; type Object_Ptr is access all Object'Class; function Get_Target (Self : access Object) return CORBA.Object.Ref; function Get_Effective_Target (Self : access Object) return CORBA.Object.Ref; function Get_Effective_Profile (Self : access Object) return IOP.TaggedProfile; function Get_Received_Exception (Self : access Object) return CORBA.Any; function Get_Received_Exception_Id (Self : access Object) return CORBA.RepositoryId; function Get_Effective_Component (Self : access Object; Id : IOP.ComponentId) return IOP.TaggedComponent; function Get_Effective_Components (Self : access Object; Id : IOP.ComponentId) return IOP.TaggedComponentSeq; function Get_Request_Policy (Self : access Object; IDL_Type : CORBA.PolicyType) return CORBA.Policy.Ref; procedure Add_Request_Service_Context (Self : access Object; Service_Context : IOP.ServiceContext; Replace : CORBA.Boolean); function Is_A (Self : not null access Object; Logical_Type_Id : String) return Boolean; procedure Init (Self : access Object; Point : PolyORB.CORBA_P.Interceptors.Client_Interception_Point; Request : PolyORB.Requests.Request_Access; Request_Id : CORBA.Unsigned_Long; Target : CORBA.Object.Ref); -- Implementation Note: This procedure initialize a ClientRequestInfo -- object. It is specific to PolyORB. You should not use it. private type Object is new PortableInterceptor.RequestInfo.Impl.Object with record Point : PolyORB.CORBA_P.Interceptors.Client_Interception_Point; Target : CORBA.Object.Ref; Request : PolyORB.Requests.Request_Access; end record; -- Derived from RequestInfo function Get_Arguments (Self : access Object) return Dynamic.ParameterList; function Get_Exceptions (Self : access Object) return Dynamic.ExceptionList; function Get_Contexts (Self : access Object) return Dynamic.ContextList; function Get_Operation_Context (Self : access Object) return Dynamic.RequestContext; function Get_Result (Self : access Object) return CORBA.Any; function Get_Sync_Scope (Self : access Object) return Messaging.SyncScope; function Get_Reply_Status (Self : access Object) return ReplyStatus; function Get_Forward_Reference (Self : access Object) return CORBA.Object.Ref; function Get_Request_Service_Context (Self : access Object; Id : IOP.ServiceId) return IOP.ServiceContext; function Get_Reply_Service_Context (Self : access Object; Id : IOP.ServiceId) return IOP.ServiceContext; end PortableInterceptor.ClientRequestInfo.Impl; ././@LongLink0000000000000000000000000000015600000000000011567 Lustar rootrootpolyorb-2.8~20110207.orig/src/corba/portableinterceptor/portableinterceptor-serverrequestinterceptor-impl.adspolyorb-2.8~20110207.orig/src/corba/portableinterceptor/portableinterceptor-serverrequestinterceptor0000644000175000017500000000704611750740340033563 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- PORTABLEINTERCEPTOR.SERVERREQUESTINTERCEPTOR.IMPL -- -- -- -- S p e c -- -- -- -- Copyright (C) 2004-2010, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the CORBA Specification, and adapted -- -- for use with PolyORB. The copyright notice above, and the license -- -- provisions that follow apply solely to the contents neither explicitly -- -- nor implicitly specified by the CORBA Specification defined by the OMG. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with PortableInterceptor.ServerRequestInfo; with PortableInterceptor.Interceptor.Impl; package PortableInterceptor.ServerRequestInterceptor.Impl is type Object is new PortableInterceptor.Interceptor.Impl.Object with private; type Object_Ptr is access all Object'Class; procedure Receive_Request_Service_Contexts (Self : access Object; RI : PortableInterceptor.ServerRequestInfo.Local_Ref); procedure Receive_Request (Self : access Object; RI : PortableInterceptor.ServerRequestInfo.Local_Ref); procedure Send_Reply (Self : access Object; RI : PortableInterceptor.ServerRequestInfo.Local_Ref); procedure Send_Exception (Self : access Object; RI : PortableInterceptor.ServerRequestInfo.Local_Ref); procedure Send_Other (Self : access Object; RI : PortableInterceptor.ServerRequestInfo.Local_Ref); function Is_A (Self : not null access Object; Logical_Type_Id : Standard.String) return Boolean; private type Object is new PortableInterceptor.Interceptor.Impl.Object with null record; end PortableInterceptor.ServerRequestInterceptor.Impl; ././@LongLink0000000000000000000000000000015600000000000011567 Lustar rootrootpolyorb-2.8~20110207.orig/src/corba/portableinterceptor/portableinterceptor-orbinitializer-initialize_all.adbpolyorb-2.8~20110207.orig/src/corba/portableinterceptor/portableinterceptor-orbinitializer-initializ0000644000175000017500000000433611750740340033404 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- PORTABLEINTERCEPTOR.ORBINITIALIZER.INITIALIZE_ALL -- -- -- -- B o d y -- -- -- -- Copyright (C) 2004 Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by ACT Europe. -- -- (email: sales@act-europe.fr) -- -- -- ------------------------------------------------------------------------------ with PolyORB.CORBA_P.Interceptors; procedure PortableInterceptor.ORBInitializer.Initialize_All is begin PolyORB.CORBA_P.Interceptors.Call_ORB_Initializers; end PortableInterceptor.ORBInitializer.Initialize_All; ././@LongLink0000000000000000000000000000015000000000000011561 Lustar rootrootpolyorb-2.8~20110207.orig/src/corba/portableinterceptor/portableinterceptor-orbinitializer-register.adspolyorb-2.8~20110207.orig/src/corba/portableinterceptor/portableinterceptor-orbinitializer-register.0000644000175000017500000000520711750740340033310 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- PORTABLEINTERCEPTOR.ORBINITIALIZER.REGISTER -- -- -- -- S p e c -- -- -- -- Copyright (C) 2004-2008, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the CORBA Specification, and adapted -- -- for use with PolyORB. The copyright notice above, and the license -- -- provisions that follow apply solely to the contents neither explicitly -- -- nor implicitly specified by the CORBA Specification defined by the OMG. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- This subprogram is derived from CORBA 3.0 specifications, section -- 21.7.3.1 "Mappings of register_orb_initializer Operation". procedure PortableInterceptor.ORBInitializer.Register (Init : PortableInterceptor.ORBInitializer.Local_Ref); polyorb-2.8~20110207.orig/src/corba/portableinterceptor/portableinterceptor-requestinfo-impl.adb0000644000175000017500000003115311750740340032411 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- PORTABLEINTERCEPTOR.REQUESTINFO.IMPL -- -- -- -- B o d y -- -- -- -- Copyright (C) 2004-2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with CORBA.Object; with CORBA.Repository_Root; with PolyORB.Annotations; with PolyORB.Any.ExceptionList; with PolyORB.Any.NVList; with PolyORB.CORBA_P.Codec_Utils; with PolyORB.CORBA_P.Exceptions; with PolyORB.CORBA_P.Interceptors_Slots; with PolyORB.Errors.Helper; with PolyORB.QoS.Service_Contexts; with PolyORB.References; with PolyORB.Request_QoS; with PolyORB.Smart_Pointers; package body PortableInterceptor.RequestInfo.Impl is use Dynamic; use PolyORB.CORBA_P.Codec_Utils; use PolyORB.QoS; use PolyORB.QoS.Service_Contexts; use PolyORB.Request_QoS; function To_CORBA_ParameterMode (Mode : PolyORB.Any.Flags) return CORBA.Repository_Root.ParameterMode; -- Convert PolyORB parameter mode flag to CORBA::ParameterMode. ------------------- -- Get_Arguments -- ------------------- function Get_Arguments (Self : access Object) return ParameterList is use PolyORB.Any.NVList.Internals; use PolyORB.Any.NVList.Internals.NV_Lists; Result : ParameterList; Iter : Iterator := First (List_Of (Self.Request.Args).all); begin while not Last (Iter) loop declare Arg : constant Element_Access := Value (Iter); begin Append (Result, Parameter' (CORBA.Any (Arg.Argument), To_CORBA_ParameterMode (Arg.Arg_Modes))); Next (Iter); end; end loop; return Result; end Get_Arguments; ------------------ -- Get_Contexts -- ------------------ function Get_Contexts (Self : access Object) return Dynamic.ContextList is pragma Unreferenced (Self); Result : Dynamic.ContextList; begin raise Program_Error; return Result; end Get_Contexts; -------------------- -- Get_Exceptions -- -------------------- function Get_Exceptions (Self : access Object) return ExceptionList is use PolyORB.Any.ExceptionList; Result : ExceptionList; begin for J in 1 .. Get_Count (Self.Request.Exc_List) loop Append (Result, CORBA.TypeCode.Internals.To_CORBA_Object (Item (Self.Request.Exc_List, J))); end loop; return Result; end Get_Exceptions; --------------------------- -- Get_Forward_Reference -- --------------------------- function Get_Forward_Reference (Self : access Object) return CORBA.Object.Ref is begin if Get_Reply_Status (Object_Ptr (Self)) /= Location_Forward then CORBA.Raise_Bad_Inv_Order (CORBA.Bad_Inv_Order_Members'(Minor => 14, Completed => CORBA.Completed_No)); end if; declare Members : constant PolyORB.Errors.ForwardRequest_Members := PolyORB.Errors.Helper.From_Any (Self.Request.Exception_Info); Ref : PolyORB.References.Ref; begin PolyORB.References.Set (Ref, PolyORB.Smart_Pointers.Entity_Of (Members.Forward_Reference)); return CORBA.Object.Internals.To_CORBA_Ref (Ref); end; end Get_Forward_Reference; ------------------- -- Get_Operation -- ------------------- function Get_Operation (Self : access Object) return CORBA.String is begin return CORBA.To_CORBA_String (Self.Request.Operation.all); end Get_Operation; --------------------------- -- Get_Operation_Context -- --------------------------- function Get_Operation_Context (Self : access Object) return Dynamic.RequestContext is pragma Unreferenced (Self); Result : Dynamic.RequestContext; begin raise Program_Error; return Result; end Get_Operation_Context; ------------------------------- -- Get_Reply_Service_Context -- ------------------------------- function Get_Reply_Service_Context (Self : access Object; Id : IOP.ServiceId) return IOP.ServiceContext is use Service_Context_Lists; use type Service_Id; SCP : constant QoS_GIOP_Service_Contexts_Parameter_Access := QoS_GIOP_Service_Contexts_Parameter_Access (Extract_Reply_Parameter (GIOP_Service_Contexts, Self.Request.all)); Iter : Iterator; begin if SCP /= null then Iter := First (SCP.Service_Contexts); while not Last (Iter) loop if Value (Iter).Context_Id = Service_Id (Id) then return (Id, IOP.ContextData (CORBA.IDL_SEQUENCES.IDL_SEQUENCE_Octet.To_Sequence (CORBA.IDL_SEQUENCES.IDL_SEQUENCE_octet.To_Element_Array (To_Sequence (Value (Iter).Context_Data.all))))); end if; Next (Iter); end loop; end if; CORBA.Raise_Bad_Param (CORBA.Bad_Param_Members'(Minor => 26, Completed => CORBA.Completed_No)); end Get_Reply_Service_Context; ---------------------- -- Get_Reply_Status -- ---------------------- function Get_Reply_Status (Self : access Object) return PortableInterceptor.ReplyStatus is begin if PolyORB.Any.Is_Empty (Self.Request.Exception_Info) then return Successful; elsif PolyORB.CORBA_P.Exceptions.Is_System_Exception (Self.Request.Exception_Info) then return System_Exception; elsif PolyORB.CORBA_P.Exceptions.Is_Forward_Request (Self.Request.Exception_Info) then return Location_Forward; elsif PolyORB.CORBA_P.Exceptions.Is_Needs_Addressing_Mode (Self.Request.Exception_Info) then return Transport_Retry; else return User_Exception; end if; end Get_Reply_Status; -------------------- -- Get_Request_Id -- -------------------- function Get_Request_Id (Self : access Object) return CORBA.Unsigned_Long is begin return Self.Request_Id; end Get_Request_Id; --------------------------------- -- Get_Request_Service_Context -- --------------------------------- function Get_Request_Service_Context (Self : access Object; Id : IOP.ServiceId) return IOP.ServiceContext is use Service_Context_Lists; use type Service_Id; SCP : constant QoS_GIOP_Service_Contexts_Parameter_Access := QoS_GIOP_Service_Contexts_Parameter_Access (Extract_Request_Parameter (GIOP_Service_Contexts, Self.Request.all)); Iter : Iterator; begin if SCP /= null then Iter := First (SCP.Service_Contexts); while not Last (Iter) loop if Value (Iter).Context_Id = Service_Id (Id) then return (Id, IOP.ContextData (CORBA.IDL_SEQUENCES.IDL_SEQUENCE_Octet.To_Sequence (CORBA.IDL_SEQUENCES.IDL_SEQUENCE_octet.To_Element_Array (To_Sequence (Value (Iter).Context_Data.all))))); end if; Next (Iter); end loop; end if; CORBA.Raise_Bad_Param (CORBA.Bad_Param_Members'(Minor => 26, Completed => CORBA.Completed_No)); end Get_Request_Service_Context; --------------------------- -- Get_Response_Expected -- --------------------------- function Get_Response_Expected (Self : access Object) return CORBA.Boolean is use PolyORB.Requests; use PolyORB.Requests.Unsigned_Long_Flags; begin if Is_Set (Sync_None, Self.Request.Req_Flags) or else Is_Set (Sync_With_Transport, Self.Request.Req_Flags) then return False; elsif Is_Set (Sync_With_Server, Self.Request.Req_Flags) or else Is_Set (Sync_With_Target, Self.Request.Req_Flags) then return True; else raise Program_Error; end if; end Get_Response_Expected; ---------------- -- Get_Result -- ---------------- function Get_Result (Self : access Object) return CORBA.Any is begin return CORBA.Any (Self.Request.Result.Argument); end Get_Result; -------------- -- Get_Slot -- -------------- function Get_Slot (Self : access Object; Id : SlotId) return CORBA.Any is use PolyORB.Annotations; use PolyORB.CORBA_P.Interceptors_Slots; Note : Slots_Note; begin Get_Note (Self.Request.Notepad, Note, Invalid_Slots_Note); return Get_Slot (Note, Id); end Get_Slot; -------------------- -- Get_Sync_Scope -- -------------------- function Get_Sync_Scope (Self : access Object) return Messaging.SyncScope is use PolyORB.Requests; use PolyORB.Requests.Unsigned_Long_Flags; begin if Is_Set (Sync_None, Self.Request.Req_Flags) then return Messaging.Sync_None; elsif Is_Set (Sync_With_Transport, Self.Request.Req_Flags) then return Messaging.Sync_With_Transport; elsif Is_Set (Sync_With_Server, Self.Request.Req_Flags) then return Messaging.Sync_With_Server; elsif Is_Set (Sync_With_Target, Self.Request.Req_Flags) then return Messaging.Sync_With_Target; else raise Program_Error; end if; end Get_Sync_Scope; ---------- -- Is_A -- ---------- function Is_A (Self : not null access Object; Logical_Type_Id : String) return Boolean is pragma Unreferenced (Self); begin return CORBA.Is_Equivalent (Logical_Type_Id, PortableInterceptor.RequestInfo.Repository_Id) or else CORBA.Is_Equivalent (Logical_Type_Id, "IDL:omg.org/CORBA/Object:1.0"); end Is_A; ---------- -- Init -- ---------- procedure Init (Self : access Object; Request : PolyORB.Requests.Request_Access; Request_Id : CORBA.Unsigned_Long) is begin Self.Request := Request; Self.Request_Id := Request_Id; end Init; ---------------------------- -- To_CORBA_ParameterMode -- ---------------------------- function To_CORBA_ParameterMode (Mode : PolyORB.Any.Flags) return CORBA.Repository_Root.ParameterMode is use type PolyORB.Any.Flags; begin if Mode = PolyORB.Any.ARG_IN then return CORBA.Repository_Root.PARAM_IN; elsif Mode = PolyORB.Any.ARG_OUT then return CORBA.Repository_Root.PARAM_OUT; elsif Mode = PolyORB.Any.ARG_INOUT then return CORBA.Repository_Root.PARAM_INOUT; else -- PolyORB.Any.IN_COPY_VALUE and others raise Program_Error; end if; end To_CORBA_ParameterMode; end PortableInterceptor.RequestInfo.Impl; ././@LongLink0000000000000000000000000000014700000000000011567 Lustar rootrootpolyorb-2.8~20110207.orig/src/corba/portableinterceptor/portableinterceptor-serverrequestinfo-impl.adspolyorb-2.8~20110207.orig/src/corba/portableinterceptor/portableinterceptor-serverrequestinfo-impl.a0000644000175000017500000001277111750740340033337 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- PORTABLEINTERCEPTOR.SERVERREQUESTINFO.IMPL -- -- -- -- S p e c -- -- -- -- Copyright (C) 2004-2010, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the CORBA Specification, and adapted -- -- for use with PolyORB. The copyright notice above, and the license -- -- provisions that follow apply solely to the contents neither explicitly -- -- nor implicitly specified by the CORBA Specification defined by the OMG. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with CORBA; with CORBA.Policy; with PolyORB.Binding_Data; with PolyORB.CORBA_P.Interceptors; with PolyORB.Requests; with PortableServer; with Dynamic; with PortableInterceptor.RequestInfo.Impl; package PortableInterceptor.ServerRequestInfo.Impl is type Object is new PortableInterceptor.RequestInfo.Impl.Object with private; type Object_Ptr is access all Object'Class; -- Initialize object implementation. procedure Init (Self : access Object; Point : PolyORB.CORBA_P.Interceptors.Server_Interception_Point; Servant : PortableServer.Servant; Request : PolyORB.Requests.Request_Access; Request_Id : CORBA.Unsigned_Long; Profile : PolyORB.Binding_Data.Profile_Access; Args_Present : Boolean); function Get_Sending_Exception (Self : access Object) return CORBA.Any; function Get_Server_Id (Self : access Object) return ServerId; function Get_ORB_Id (Self : access Object) return ORBId; function Get_Adapter_Name (Self : access Object) return AdapterName; function Get_Object_Id (Self : access Object) return ObjectId; function Get_Adapter_Id (Self : access Object) return CORBA.IDL_SEQUENCES.OctetSeq; function Get_Target_Most_Derived_Interface (Self : access Object) return CORBA.RepositoryId; function Get_Server_Policy (Self : access Object; A_Type : CORBA.PolicyType) return CORBA.Policy.Ref; procedure Set_Slot (Self : access Object; Id : PortableInterceptor.SlotId; Data : CORBA.Any); function Target_Is_A (Self : access Object; Id : CORBA.RepositoryId) return CORBA.Boolean; procedure Add_Reply_Service_Context (Self : access Object; Service_Context : IOP.ServiceContext; Replace : CORBA.Boolean); function Is_A (Self : not null access Object; Logical_Type_Id : Standard.String) return Boolean; private type Object is new PortableInterceptor.RequestInfo.Impl.Object with record Point : PolyORB.CORBA_P.Interceptors.Server_Interception_Point; Servant : PortableServer.Servant; Request : PolyORB.Requests.Request_Access; Profile : PolyORB.Binding_Data.Profile_Access; Args_Present : Boolean; end record; -- Derived from RequestInfo. function Get_Arguments (Self : access Object) return Dynamic.ParameterList; function Get_Exceptions (Self : access Object) return Dynamic.ExceptionList; function Get_Contexts (Self : access Object) return Dynamic.ContextList; function Get_Operation_Context (Self : access Object) return Dynamic.RequestContext; function Get_Result (Self : access Object) return CORBA.Any; function Get_Reply_Status (Self : access Object) return ReplyStatus; function Get_Forward_Reference (Self : access Object) return CORBA.Object.Ref; function Get_Reply_Service_Context (Self : access Object; Id : IOP.ServiceId) return IOP.ServiceContext; end PortableInterceptor.ServerRequestInfo.Impl; polyorb-2.8~20110207.orig/src/corba/portableinterceptor/portableinterceptor-interceptor-impl.adb0000644000175000017500000000563211750740340032406 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- PORTABLEINTERCEPTOR.INTERCEPTOR.IMPL -- -- -- -- B o d y -- -- -- -- Copyright (C) 2004-2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ package body PortableInterceptor.Interceptor.Impl is ------------- -- Destroy -- ------------- procedure Destroy (Self : access Object) is pragma Unreferenced (Self); begin null; end Destroy; -------------- -- Get_Name -- -------------- function Get_Name (Self : access Object) return CORBA.String is pragma Unreferenced (Self); begin return CORBA.To_CORBA_String (""); end Get_Name; ---------- -- Is_A -- ---------- function Is_A (Self : not null access Object; Logical_Type_Id : String) return Boolean is pragma Unreferenced (Self); begin return CORBA.Is_Equivalent (Logical_Type_Id, PortableInterceptor.Interceptor.Repository_Id) or else CORBA.Is_Equivalent (Logical_Type_Id, "IDL:omg.org/CORBA/Object:1.0"); end Is_A; end PortableInterceptor.Interceptor.Impl; polyorb-2.8~20110207.orig/src/corba/portableinterceptor/polyorb-corba_p-interceptors.adb0000644000175000017500000011722711750740340030640 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . C O R B A _ P . I N T E R C E P T O R S -- -- -- -- B o d y -- -- -- -- Copyright (C) 2004-2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with CORBA.Object; with PolyORB.Annotations; with PolyORB.Any; with PolyORB.Binding_Data; with PolyORB.CORBA_P.Exceptions; with PolyORB.CORBA_P.Interceptors_Hooks; with PolyORB.CORBA_P.Interceptors_Slots; with PolyORB.Errors.Helper; with PolyORB.Exceptions; with PolyORB.Initialization; with PolyORB.POA; with PolyORB.QoS.Addressing_Modes; with PolyORB.QoS.Service_Contexts; with PolyORB.References; with PolyORB.Requests; with PolyORB.Request_QoS; with PolyORB.Smart_Pointers.Controlled_Entities; with PolyORB.Tasking.Mutexes; with PolyORB.Tasking.Threads.Annotations; with PolyORB.Utils.Chained_Lists; with PolyORB.Utils.Strings; with PortableServer; with PortableInterceptor.ClientRequestInfo; with PortableInterceptor.ClientRequestInfo.Impl; with PortableInterceptor.IORInfo.Impl; with PortableInterceptor.IORInterceptor_3_0.Helper; with PortableInterceptor.ORBInitInfo.Impl; with PortableInterceptor.ServerRequestInfo; with PortableInterceptor.ServerRequestInfo.Impl; package body PolyORB.CORBA_P.Interceptors is use PolyORB.Annotations; use PolyORB.CORBA_P.Interceptors_Slots; use PolyORB.QoS.Service_Contexts; use PolyORB.Requests.Unsigned_Long_Flags; use PolyORB.Tasking.Mutexes; use PolyORB.Tasking.Threads.Annotations; use type PolyORB.Any.TypeCode.Local_Ref; package PSPCE renames PolyORB.Smart_Pointers.Controlled_Entities; -- Client Interceptors function "=" (Left, Right : PortableInterceptor.ClientRequestInterceptor.Local_Ref) return Boolean; package ClientRequestInterceptor_Lists is new PolyORB.Utils.Chained_Lists (PortableInterceptor.ClientRequestInterceptor.Local_Ref); All_Client_Interceptors : ClientRequestInterceptor_Lists.List; procedure Client_Invoke (Request : access PolyORB.Requests.Request; Flags : PolyORB.Requests.Flags); function Create_Client_Request_Info (Request : PolyORB.Requests.Request_Access; Request_Id : CORBA.Unsigned_Long; Point : Client_Interception_Point; Target : CORBA.Object.Ref) return PortableInterceptor.ClientRequestInfo.Local_Ref; generic with procedure Operation (Self : PortableInterceptor.ClientRequestInterceptor.Local_Ref; Info : PortableInterceptor.ClientRequestInfo.Local_Ref); procedure Call_Client_Request_Interceptor_Operation (Self : PortableInterceptor.ClientRequestInterceptor.Local_Ref; Info : PortableInterceptor.ClientRequestInfo.Local_Ref; Forward : Boolean; Excp_Inf : in out PolyORB.Any.Any); -- Server interceptors type Server_Interceptor_Note is new PolyORB.Annotations.Note with record Servant : PortableServer.Servant; Profile : PolyORB.Binding_Data.Profile_Access; Request_Id : CORBA.Unsigned_Long; Last_Interceptor : Natural; Exception_Info : PolyORB.Any.Any; Intermediate_Called : Boolean; end record; function "=" (Left, Right : PortableInterceptor.ServerRequestInterceptor.Local_Ref) return Boolean; package ServerRequestInterceptor_Lists is new PolyORB.Utils.Chained_Lists (PortableInterceptor.ServerRequestInterceptor.Local_Ref); All_Server_Interceptors : ServerRequestInterceptor_Lists.List; procedure Server_Invoke (Servant : access PSPCE.Entity'Class; Request : access PolyORB.Requests.Request; Profile : PolyORB.Binding_Data.Profile_Access); procedure Server_Intermediate (Request : access PolyORB.Requests.Request; From_Arguments : Boolean); function Create_Server_Request_Info (Servant : PortableServer.Servant; Request : PolyORB.Requests.Request_Access; Request_Id : CORBA.Unsigned_Long; Profile : PolyORB.Binding_Data.Profile_Access; Point : Server_Interception_Point; Args_Present : Boolean) return PortableInterceptor.ServerRequestInfo.Local_Ref; generic with procedure Operation (Self : PortableInterceptor.ServerRequestInterceptor.Local_Ref; Info : PortableInterceptor.ServerRequestInfo.Local_Ref); procedure Call_Server_Request_Interceptor_Operation (Self : PortableInterceptor.ServerRequestInterceptor.Local_Ref; Info : PortableInterceptor.ServerRequestInfo.Local_Ref; Forward : Boolean; Excp_Inf : in out PolyORB.Any.Any); -- IOR interceptors function "=" (Left, Right : PortableInterceptor.IORInterceptor.Local_Ref) return Boolean; package IORInterceptor_Lists is new PolyORB.Utils.Chained_Lists (PortableInterceptor.IORInterceptor.Local_Ref); All_IOR_Interceptors : IORInterceptor_Lists.List; procedure POA_Create (POA : PolyORB.POA.Obj_Adapter_Access; Error : in out PolyORB.Errors.Error_Container); -- ORB_Initializers function "=" (Left, Right : PortableInterceptor.ORBInitializer.Local_Ref) return Boolean; package Initializer_Ref_Lists is new PolyORB.Utils.Chained_Lists (PortableInterceptor.ORBInitializer.Local_Ref); All_Initializer_Refs : Initializer_Ref_Lists.List; -- Internal subprograms function To_PolyORB_ForwardRequest_Members_Any (Members : PortableInterceptor.ForwardRequest_Members) return PolyORB.Any.Any; pragma Inline (To_PolyORB_ForwardRequest_Members_Any); -- Converting PortableInterceptor::ForwardRequest_Members into -- PolyORB internal representation. -- Request_Id generation support Request_Id_Counter : CORBA.Unsigned_Long := 0; Request_Id_Mutex : Mutex_Access := null; function Allocate_Request_Id return CORBA.Unsigned_Long; -- Allocate unused Request_Id --------- -- "=" -- --------- function "=" (Left, Right : PortableInterceptor.ClientRequestInterceptor.Local_Ref) return Boolean is begin return CORBA.Object.Is_Equivalent (CORBA.Object.Ref (Left), Right); end "="; --------- -- "=" -- --------- function "=" (Left, Right : PortableInterceptor.IORInterceptor.Local_Ref) return Boolean is begin return CORBA.Object.Is_Equivalent (CORBA.Object.Ref (Left), Right); end "="; --------- -- "=" -- --------- function "=" (Left, Right : PortableInterceptor.ORBInitializer.Local_Ref) return Boolean is begin return CORBA.Object.Is_Equivalent (CORBA.Object.Ref (Left), Right); end "="; --------- -- "=" -- --------- function "=" (Left, Right : PortableInterceptor.ServerRequestInterceptor.Local_Ref) return Boolean is begin return CORBA.Object.Is_Equivalent (CORBA.Object.Ref (Left), Right); end "="; ------------------------------------ -- Add_Client_Request_Interceptor -- ------------------------------------ procedure Add_Client_Request_Interceptor (Interceptor : PortableInterceptor.ClientRequestInterceptor.Local_Ref) is begin ClientRequestInterceptor_Lists.Append (All_Client_Interceptors, Interceptor); end Add_Client_Request_Interceptor; ------------------------- -- Add_IOR_Interceptor -- ------------------------- procedure Add_IOR_Interceptor (Interceptor : PortableInterceptor.IORInterceptor.Local_Ref) is begin IORInterceptor_Lists.Append (All_IOR_Interceptors, Interceptor); end Add_IOR_Interceptor; ------------------------------------ -- Add_Server_Request_Interceptor -- ------------------------------------ procedure Add_Server_Request_Interceptor (Interceptor : PortableInterceptor.ServerRequestInterceptor.Local_Ref) is begin ServerRequestInterceptor_Lists.Append (All_Server_Interceptors, Interceptor); end Add_Server_Request_Interceptor; ------------------------- -- Allocate_Request_Id -- ------------------------- function Allocate_Request_Id return CORBA.Unsigned_Long is use type CORBA.Unsigned_Long; Result : CORBA.Unsigned_Long; begin Enter (Request_Id_Mutex); Result := Request_Id_Counter; Request_Id_Counter := Request_Id_Counter + 1; Leave (Request_Id_Mutex); return Result; end Allocate_Request_Id; ----------------------------------------------- -- Call_Client_Request_Interceptor_Operation -- ----------------------------------------------- procedure Call_Client_Request_Interceptor_Operation (Self : PortableInterceptor.ClientRequestInterceptor.Local_Ref; Info : PortableInterceptor.ClientRequestInfo.Local_Ref; Forward : Boolean; Excp_Inf : in out PolyORB.Any.Any) is begin Operation (Self, Info); exception when E : CORBA.Unknown | CORBA.Bad_Param | CORBA.No_Memory | CORBA.Imp_Limit | CORBA.Comm_Failure | CORBA.Inv_Objref | CORBA.No_Permission | CORBA.Internal | CORBA.Marshal | CORBA.Initialize | CORBA.No_Implement | CORBA.Bad_TypeCode | CORBA.Bad_Operation | CORBA.No_Resources | CORBA.No_Response | CORBA.Persist_Store | CORBA.Bad_Inv_Order | CORBA.Transient | CORBA.Free_Mem | CORBA.Inv_Ident | CORBA.Inv_Flag | CORBA.Intf_Repos | CORBA.Bad_Context | CORBA.Obj_Adapter | CORBA.Data_Conversion | CORBA.Object_Not_Exist | CORBA.Transaction_Required | CORBA.Transaction_Rolledback | CORBA.Invalid_Transaction | CORBA.Inv_Policy | CORBA.Codeset_Incompatible | CORBA.Rebind | CORBA.Timeout | CORBA.Transaction_Unavailable | CORBA.Transaction_Mode | CORBA.Bad_Qos => Excp_Inf := PolyORB.CORBA_P.Exceptions.System_Exception_To_Any (E); when E : PortableInterceptor.ForwardRequest => -- If forwarding at this interception point is allowed then -- convert PortableInterceptor::ForwardRequest to -- PolyORB::ForwardRequest. if Forward then declare Members : PortableInterceptor.ForwardRequest_Members; begin PolyORB.Exceptions.User_Get_Members (E, Members); Excp_Inf := To_PolyORB_ForwardRequest_Members_Any (Members); end; else raise; end if; end Call_Client_Request_Interceptor_Operation; --------------------------- -- Call_ORB_Initializers -- --------------------------- procedure Call_ORB_Initializers is use Initializer_Ref_Lists; Info_Ptr : constant PortableInterceptor.ORBInitInfo.Impl.Object_Ptr := new PortableInterceptor.ORBInitInfo.Impl.Object; Info_Ref : PortableInterceptor.ORBInitInfo.Local_Ref; begin PortableInterceptor.ORBInitInfo.Impl.Init (Info_Ptr); PortableInterceptor.ORBInitInfo.Set (Info_Ref, PolyORB.Smart_Pointers.Entity_Ptr (Info_Ptr)); declare Iter : Iterator := First (All_Initializer_Refs); begin while not Last (Iter) loop PortableInterceptor.ORBInitializer.Pre_Init (Value (Iter).all, Info_Ref); Next (Iter); end loop; end; declare Iter : Iterator := First (All_Initializer_Refs); begin while not Last (Iter) loop PortableInterceptor.ORBInitializer.Post_Init (Value (Iter).all, Info_Ref); Next (Iter); end loop; end; -- Mark in ORBInitInfo the fact of initialization complete. This is -- required for raise exceptions on all ORBInitInfo operations if some -- of Interceptors cache ORBInitInfo reference. PortableInterceptor.ORBInitInfo.Impl.Post_Init_Done (Info_Ptr); end Call_ORB_Initializers; ----------------------------------------------- -- Call_Server_Request_Interceptor_Operation -- ----------------------------------------------- procedure Call_Server_Request_Interceptor_Operation (Self : PortableInterceptor.ServerRequestInterceptor.Local_Ref; Info : PortableInterceptor.ServerRequestInfo.Local_Ref; Forward : Boolean; Excp_Inf : in out PolyORB.Any.Any) is begin Operation (Self, Info); exception when E : CORBA.Unknown | CORBA.Bad_Param | CORBA.No_Memory | CORBA.Imp_Limit | CORBA.Comm_Failure | CORBA.Inv_Objref | CORBA.No_Permission | CORBA.Internal | CORBA.Marshal | CORBA.Initialize | CORBA.No_Implement | CORBA.Bad_TypeCode | CORBA.Bad_Operation | CORBA.No_Resources | CORBA.No_Response | CORBA.Persist_Store | CORBA.Bad_Inv_Order | CORBA.Transient | CORBA.Free_Mem | CORBA.Inv_Ident | CORBA.Inv_Flag | CORBA.Intf_Repos | CORBA.Bad_Context | CORBA.Obj_Adapter | CORBA.Data_Conversion | CORBA.Object_Not_Exist | CORBA.Transaction_Required | CORBA.Transaction_Rolledback | CORBA.Invalid_Transaction | CORBA.Inv_Policy | CORBA.Codeset_Incompatible | CORBA.Rebind | CORBA.Timeout | CORBA.Transaction_Unavailable | CORBA.Transaction_Mode | CORBA.Bad_Qos => Excp_Inf := PolyORB.CORBA_P.Exceptions.System_Exception_To_Any (E); when E : PortableInterceptor.ForwardRequest => -- If forwarding at this interception point is allowed then -- convert PortableInterceptor::ForwardRequest to -- PolyORB::ForwardRequest. if Forward then declare Members : PortableInterceptor.ForwardRequest_Members; begin PolyORB.Exceptions.User_Get_Members (E, Members); Excp_Inf := To_PolyORB_ForwardRequest_Members_Any (Members); end; else raise; end if; end Call_Server_Request_Interceptor_Operation; ------------------- -- Client_Invoke -- ------------------- procedure Client_Invoke (Request : access PolyORB.Requests.Request; Flags : PolyORB.Requests.Flags) is use ClientRequestInterceptor_Lists; use type PolyORB.Any.TypeCode.Object; use type PolyORB.Requests.Request_Access; procedure Call_Send_Request is new Call_Client_Request_Interceptor_Operation (PortableInterceptor.ClientRequestInterceptor.Send_Request); procedure Call_Receive_Reply is new Call_Client_Request_Interceptor_Operation (PortableInterceptor.ClientRequestInterceptor.Receive_Reply); procedure Call_Receive_Exception is new Call_Client_Request_Interceptor_Operation (PortableInterceptor.ClientRequestInterceptor.Receive_Exception); procedure Call_Receive_Other is new Call_Client_Request_Interceptor_Operation (PortableInterceptor.ClientRequestInterceptor.Receive_Other); Req_Id : constant CORBA.Unsigned_Long := Allocate_Request_Id; Target : constant CORBA.Object.Ref := CORBA.Object.Internals.To_CORBA_Ref (Request.Target); TSC : Slots_Note; Index : Natural; begin -- Getting thread scope slots information (allocating thread scope -- slots if it is not allocated), and make "logical copy" and place it -- in the request. Get_Note (Get_Current_Thread_Notepad.all, TSC, Invalid_Slots_Note); if not Is_Allocated (TSC) then Allocate_Slots (TSC); end if; loop Set_Note (Request.Notepad, TSC); Rebuild_Request_Service_Contexts (Request.all); Index := Length (All_Client_Interceptors); -- Call Send_Request on all interceptors. for J in 0 .. Index - 1 loop Call_Send_Request (Element (All_Client_Interceptors, J).all, Create_Client_Request_Info (Request.all'Unchecked_Access, Req_Id, Send_Request, Target), True, Request.Exception_Info); -- If got system or ForwardRequest exception then avoid call -- Send_Request on other Interceptors. if not PolyORB.Any.Is_Empty (Request.Exception_Info) then Index := J; exit; end if; end loop; Rebuild_Request_QoS_Parameters (Request.all); -- Avoid operation invocation if interceptor raise system -- exception. if Index = Length (All_Client_Interceptors) then PolyORB.Requests.Invoke (Request, Flags); -- Restore request scope slots, because it may be changed -- during invocation. Set_Note (Request.Notepad, TSC); end if; Rebuild_Request_Service_Contexts (Request.all); Rebuild_Reply_Service_Contexts (Request.all); for J in reverse 0 .. Index - 1 loop if not PolyORB.Any.Is_Empty (Request.Exception_Info) then if PolyORB.Any.Get_Type (Request.Exception_Info) = PolyORB.Errors.Helper.TC_ForwardRequest or else PolyORB.Any.Get_Type (Request.Exception_Info) = PolyORB.Errors.Helper.TC_NeedsAddressingMode then Call_Receive_Other (Element (All_Client_Interceptors, J).all, Create_Client_Request_Info (Request.all'Unchecked_Access, Req_Id, Receive_Other, Target), True, Request.Exception_Info); else Call_Receive_Exception (Element (All_Client_Interceptors, J).all, Create_Client_Request_Info (Request.all'Unchecked_Access, Req_Id, Receive_Exception, Target), True, Request.Exception_Info); end if; else if Is_Set (Requests.Sync_With_Server, Request.Req_Flags) or else Is_Set (Requests.Sync_With_Target, Request.Req_Flags) then -- A reply is expected Call_Receive_Reply (Element (All_Client_Interceptors, J).all, Create_Client_Request_Info (Request.all'Unchecked_Access, Req_Id, Receive_Reply, Target), False, Request.Exception_Info); else Call_Receive_Other (Element (All_Client_Interceptors, J).all, Create_Client_Request_Info (Request.all'Unchecked_Access, Req_Id, Receive_Other, Target), True, Request.Exception_Info); end if; end if; end loop; exit when PolyORB.Any.Is_Empty (Request.Exception_Info) or else (PolyORB.Any.Get_Type (Request.Exception_Info) /= PolyORB.Errors.Helper.TC_ForwardRequest and then PolyORB.Any.Get_Type (Request.Exception_Info) /= PolyORB.Errors.Helper.TC_NeedsAddressingMode); -- XXX Reinvocation is possible iff request sync_scope is -- Sync_With_Server or Sync_With_Target. May be we add -- pragma Assert here? if PolyORB.Any.Get_Type (Request.Exception_Info) = PolyORB.Errors.Helper.TC_ForwardRequest then -- Reinvocation. Extract object reference from ForwardRequest -- exception and reinitialize request. declare Members : constant PolyORB.Errors.ForwardRequest_Members := PolyORB.Errors.Helper.From_Any (Request.Exception_Info); Ref : PolyORB.References.Ref; begin PolyORB.References.Set (Ref, Smart_Pointers.Entity_Of (Members.Forward_Reference)); PolyORB.Requests.Reset_Request (Request.all); end; else -- Reinvocation. Set requested GIOP addressing mode and -- reinitialize request. declare use PolyORB.QoS; use PolyORB.QoS.Addressing_Modes; use PolyORB.Request_QoS; Members : constant PolyORB.Errors.NeedsAddressingMode_Members := PolyORB.Errors.Helper.From_Any (Request.Exception_Info); begin PolyORB.Requests.Reset_Request (Request.all); Add_Request_QoS (Request.all, GIOP_Addressing_Mode, new QoS_GIOP_Addressing_Mode_Parameter' (Kind => GIOP_Addressing_Mode, Mode => Members.Mode)); end; end if; end loop; -- Restoring thread scope slots. Set_Note (Get_Current_Thread_Notepad.all, TSC); end Client_Invoke; -------------------------------- -- Create_Client_Request_Info -- -------------------------------- function Create_Client_Request_Info (Request : PolyORB.Requests.Request_Access; Request_Id : CORBA.Unsigned_Long; Point : Client_Interception_Point; Target : CORBA.Object.Ref) return PortableInterceptor.ClientRequestInfo.Local_Ref is Info_Ptr : constant PortableInterceptor.ClientRequestInfo.Impl.Object_Ptr := new PortableInterceptor.ClientRequestInfo.Impl.Object; Info_Ref : PortableInterceptor.ClientRequestInfo.Local_Ref; begin PortableInterceptor.ClientRequestInfo.Impl.Init (Info_Ptr, Point, Request, Request_Id, Target); PortableInterceptor.ClientRequestInfo.Set (Info_Ref, PolyORB.Smart_Pointers.Entity_Ptr (Info_Ptr)); return Info_Ref; end Create_Client_Request_Info; -------------------------------- -- Create_Server_Request_Info -- -------------------------------- function Create_Server_Request_Info (Servant : PortableServer.Servant; Request : PolyORB.Requests.Request_Access; Request_Id : CORBA.Unsigned_Long; Profile : PolyORB.Binding_Data.Profile_Access; Point : Server_Interception_Point; Args_Present : Boolean) return PortableInterceptor.ServerRequestInfo.Local_Ref is Info_Ptr : constant PortableInterceptor.ServerRequestInfo.Impl.Object_Ptr := new PortableInterceptor.ServerRequestInfo.Impl.Object; Info_Ref : PortableInterceptor.ServerRequestInfo.Local_Ref; begin PortableInterceptor.ServerRequestInfo.Impl.Init (Info_Ptr, Point, Servant, Request, Request_Id, Profile, Args_Present); PortableInterceptor.ServerRequestInfo.Set (Info_Ref, PolyORB.Smart_Pointers.Entity_Ptr (Info_Ptr)); return Info_Ref; end Create_Server_Request_Info; ------------------------------------------ -- Is_Client_Request_Interceptor_Exists -- ------------------------------------------ function Is_Client_Request_Interceptor_Exists (Name : String) return Boolean is Iter : ClientRequestInterceptor_Lists.Iterator := ClientRequestInterceptor_Lists.First (All_Client_Interceptors); begin if Name = "" then return False; end if; while not ClientRequestInterceptor_Lists.Last (Iter) loop if CORBA.To_Standard_String (PortableInterceptor.ClientRequestInterceptor.Get_Name (ClientRequestInterceptor_Lists.Value (Iter).all)) = Name then return True; end if; ClientRequestInterceptor_Lists.Next (Iter); end loop; return False; end Is_Client_Request_Interceptor_Exists; ------------------------------- -- Is_IOR_Interceptor_Exists -- ------------------------------- function Is_IOR_Interceptor_Exists (Name : String) return Boolean is Iter : IORInterceptor_Lists.Iterator := IORInterceptor_Lists.First (All_IOR_Interceptors); begin if Name = "" then return False; end if; while not IORInterceptor_Lists.Last (Iter) loop if CORBA.To_Standard_String (PortableInterceptor.IORInterceptor.Get_Name (IORInterceptor_Lists.Value (Iter).all)) = Name then return True; end if; IORInterceptor_Lists.Next (Iter); end loop; return False; end Is_IOR_Interceptor_Exists; ------------------------------------------ -- Is_Server_Request_Interceptor_Exists -- ------------------------------------------ function Is_Server_Request_Interceptor_Exists (Name : String) return Boolean is Iter : ServerRequestInterceptor_Lists.Iterator := ServerRequestInterceptor_Lists.First (All_Server_Interceptors); begin if Name = "" then return False; end if; while not ServerRequestInterceptor_Lists.Last (Iter) loop if CORBA.To_Standard_String (PortableInterceptor.ServerRequestInterceptor.Get_Name (ServerRequestInterceptor_Lists.Value (Iter).all)) = Name then return True; end if; ServerRequestInterceptor_Lists.Next (Iter); end loop; return False; end Is_Server_Request_Interceptor_Exists; ---------------- -- POA_Create -- ---------------- procedure POA_Create (POA : PolyORB.POA.Obj_Adapter_Access; Error : in out PolyORB.Errors.Error_Container) is Iter : IORInterceptor_Lists.Iterator; Info : PortableInterceptor.IORInfo.Local_Ref; Info_Obj : constant PortableInterceptor.IORInfo.Impl.Object_Ptr := new PortableInterceptor.IORInfo.Impl.Object; begin -- Creating and initializing IOR Info object. PortableInterceptor.IORInfo.Impl.Init (Info_Obj, POA); PortableInterceptor.IORInfo.Set (Info, PolyORB.Smart_Pointers.Entity_Ptr (Info_Obj)); -- Call Establish_Components on all registered IOR interceptors. Iter := IORInterceptor_Lists.First (All_IOR_Interceptors); while not IORInterceptor_Lists.Last (Iter) loop begin PortableInterceptor.IORInterceptor.Establish_Components (IORInterceptor_Lists.Value (Iter).all, Info); exception when others => null; end; IORInterceptor_Lists.Next (Iter); end loop; -- Call Components_Established on all registered IOR interceptors -- with version 3.0. Iter := IORInterceptor_Lists.First (All_IOR_Interceptors); while not IORInterceptor_Lists.Last (Iter) loop if PortableInterceptor.IORInterceptor.Is_A (IORInterceptor_Lists.Value (Iter).all, PortableInterceptor.IORInterceptor_3_0.Repository_Id) then begin PortableInterceptor.IORInterceptor_3_0.Components_Established (PortableInterceptor.IORInterceptor_3_0.Helper.To_Local_Ref (IORInterceptor_Lists.Value (Iter).all), Info); exception when others => PolyORB.Errors.Throw (Error, PolyORB.Errors.Obj_Adapter_E, PolyORB.Errors.System_Exception_Members' (Minor => 6, Completed => PolyORB.Errors.Completed_No)); return; end; end if; IORInterceptor_Lists.Next (Iter); end loop; end POA_Create; ------------------------------ -- Register_ORB_Initializer -- ------------------------------ procedure Register_ORB_Initializer (Init : PortableInterceptor.ORBInitializer.Local_Ref) is use Initializer_Ref_Lists; begin Append (All_Initializer_Refs, Init); end Register_ORB_Initializer; ------------------------- -- Server_Intermediate -- ------------------------- procedure Server_Intermediate (Request : access PolyORB.Requests.Request; From_Arguments : Boolean) is use ServerRequestInterceptor_Lists; procedure Call_Receive_Request is new Call_Server_Request_Interceptor_Operation (PortableInterceptor.ServerRequestInterceptor.Receive_Request); Note : Server_Interceptor_Note; Break_Invocation : Boolean := False; It : Iterator := First (All_Server_Interceptors); begin PolyORB.Annotations.Get_Note (Request.Notepad, Note); if not Note.Intermediate_Called then Note.Intermediate_Called := True; while not Last (It) loop Call_Receive_Request (Value (It).all, Create_Server_Request_Info (Note.Servant, Request.all'Unchecked_Access, Note.Request_Id, Note.Profile, Receive_Request, From_Arguments), True, Note.Exception_Info); if not PolyORB.Any.Is_Empty (Note.Exception_Info) then -- Exception information can't be saved in Request, -- because skeleton replace it to CORBA.UNKNOWN -- exception. Break_Invocation := True; exit; end if; Next (It); end loop; end if; Rebuild_Reply_QoS_Parameters (Request.all); PolyORB.Annotations.Set_Note (Request.Notepad, Note); if Break_Invocation then -- XXX Is this valid for PolyORB::ForwardRequest? PolyORB.CORBA_P.Exceptions.Raise_From_Any (Note.Exception_Info); end if; end Server_Intermediate; ------------------- -- Server_Invoke -- ------------------- procedure Server_Invoke (Servant : access PSPCE.Entity'Class; Request : access PolyORB.Requests.Request; Profile : PolyORB.Binding_Data.Profile_Access) is use ServerRequestInterceptor_Lists; use type PolyORB.Any.TypeCode.Object; package PISRI renames PortableInterceptor.ServerRequestInterceptor; procedure Call_Receive_Request_Service_Contexts is new Call_Server_Request_Interceptor_Operation (PISRI.Receive_Request_Service_Contexts); procedure Call_Send_Reply is new Call_Server_Request_Interceptor_Operation (PISRI.Send_Reply); procedure Call_Send_Exception is new Call_Server_Request_Interceptor_Operation (PISRI.Send_Exception); procedure Call_Send_Other is new Call_Server_Request_Interceptor_Operation (PISRI.Send_Other); RSC : Slots_Note; Empty_Any : PolyORB.Any.Any; Skip_Invocation : Boolean := False; Note : Server_Interceptor_Note := (PolyORB.Annotations.Note with Servant => PortableServer.Servant (Servant), Profile => Profile, Request_Id => Allocate_Request_Id, Last_Interceptor => Length (All_Server_Interceptors), Exception_Info => Empty_Any, Intermediate_Called => False); begin -- Allocating thread request scope slots. Storing it in the request. Allocate_Slots (RSC); Set_Note (Request.Notepad, RSC); Rebuild_Request_Service_Contexts (Request.all); for J in 0 .. Note.Last_Interceptor - 1 loop Call_Receive_Request_Service_Contexts (Element (All_Server_Interceptors, J).all, Create_Server_Request_Info (null, Request.all'Unchecked_Access, Note.Request_Id, Profile, Receive_Request_Service_Contexts, False), True, Request.Exception_Info); -- If got system or ForwardRequest exception then avoid call -- Receive_Request_Service_Contexts on other Interceptors. if not PolyORB.Any.Is_Empty (Request.Exception_Info) then Note.Last_Interceptor := J; Skip_Invocation := True; exit; end if; end loop; Rebuild_Reply_QoS_Parameters (Request.all); -- Copy ing request scope slots to thread scope slots Get_Note (Request.Notepad, RSC); Set_Note (Get_Current_Thread_Notepad.all, RSC); -- Saving in request information for calling intermediate -- interception point. Set_Note (Request.Notepad, Note); if not Skip_Invocation then PortableServer.Invoke (PortableServer.DynamicImplementation'Class (Servant.all)'Access, Request.all'Unchecked_Access); -- Redispatch end if; Get_Note (Request.Notepad, Note); if not PolyORB.Any.Is_Empty (Note.Exception_Info) then -- If a system exception or ForwardRequest exception will be -- raised in Receive_Request interception point then replace -- Request exception information, because it may be replaced -- in skeleton. Request.Exception_Info := Note.Exception_Info; end if; -- Retrieve thread scope slots and copy it back to request -- scope slots. Get_Note (Get_Current_Thread_Notepad.all, RSC); Set_Note (Request.Notepad, RSC); for J in reverse 0 .. Note.Last_Interceptor - 1 loop if not PolyORB.Any.Is_Empty (Request.Exception_Info) then if PolyORB.Any.Get_Type (Request.Exception_Info) = PolyORB.Errors.Helper.TC_ForwardRequest or else PolyORB.Any.Get_Type (Request.Exception_Info) = PolyORB.Errors.Helper.TC_NeedsAddressingMode then Call_Send_Other (Element (All_Server_Interceptors, J).all, Create_Server_Request_Info (null, Request.all'Unchecked_Access, Note.Request_Id, Profile, Send_Other, True), True, Request.Exception_Info); else Call_Send_Exception (Element (All_Server_Interceptors, J).all, Create_Server_Request_Info (null, Request.all'Unchecked_Access, Note.Request_Id, Profile, Send_Exception, True), True, Request.Exception_Info); end if; else if Is_Set (Requests.Sync_With_Server, Request.Req_Flags) or else Is_Set (Requests.Sync_With_Target, Request.Req_Flags) then -- A reply is expected Call_Send_Reply (Element (All_Server_Interceptors, J).all, Create_Server_Request_Info (null, Request.all'Unchecked_Access, Note.Request_Id, Profile, Send_Reply, True), False, Request.Exception_Info); else Call_Send_Other (Element (All_Server_Interceptors, J).all, Create_Server_Request_Info (null, Request.all'Unchecked_Access, Note.Request_Id, Profile, Send_Other, True), True, Request.Exception_Info); end if; end if; end loop; Rebuild_Reply_QoS_Parameters (Request.all); end Server_Invoke; ------------------------------------------- -- To_PolyORB_ForwardRequest_Members_Any -- ------------------------------------------- function To_PolyORB_ForwardRequest_Members_Any (Members : PortableInterceptor.ForwardRequest_Members) return PolyORB.Any.Any is begin return PolyORB.Errors.Helper.To_Any (PolyORB.Errors.ForwardRequest_Members' (Forward_Reference => PolyORB.Smart_Pointers.Ref (CORBA.Object.Internals.To_PolyORB_Ref (Members.Forward)))); end To_PolyORB_ForwardRequest_Members_Any; ---------------- -- Initialize -- ---------------- procedure Initialize; procedure Initialize is begin PolyORB.CORBA_P.Interceptors_Hooks.Client_Invoke := Client_Invoke'Access; PolyORB.CORBA_P.Interceptors_Hooks.Server_Invoke := Server_Invoke'Access; PolyORB.CORBA_P.Interceptors_Hooks.Server_Intermediate := Server_Intermediate'Access; PolyORB.CORBA_P.Interceptors_Hooks.POA_Create := POA_Create'Access; Create (Request_Id_Mutex, "polyorb.corba_p.interceptors.request_id_mutex"); end Initialize; use PolyORB.Initialization; use PolyORB.Initialization.String_Lists; use PolyORB.Utils.Strings; begin Register_Module (Module_Info' (Name => +"polyorb.corba_p.interceptors", Conflicts => Empty, Depends => +"corba.request" & "portableserver", Provides => Empty, Implicit => False, Init => Initialize'Access, Shutdown => null)); end PolyORB.CORBA_P.Interceptors; polyorb-2.8~20110207.orig/src/corba/portableinterceptor/portableinterceptor-orbinitinfo-impl.ads0000644000175000017500000001067111750740340032412 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- PORTABLEINTERCEPTOR.ORBINITINFO.IMPL -- -- -- -- S p e c -- -- -- -- Copyright (C) 2004-2010, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the CORBA Specification, and adapted -- -- for use with PolyORB. The copyright notice above, and the license -- -- provisions that follow apply solely to the contents neither explicitly -- -- nor implicitly specified by the CORBA Specification defined by the OMG. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with CORBA.Local; package PortableInterceptor.ORBInitInfo.Impl is pragma Elaborate_Body; type Object is new CORBA.Local.Object with private; type Object_Ptr is access all Object'Class; procedure Init (Self : access Object); procedure Post_Init_Done (Self : access Object); -- Called once the initialization is complete. It is required for -- raising exception in case of call object operations after -- initialization complete. XXX reword this comment function Get_Arguments (Self : access Object) return CORBA.IDL_SEQUENCES.StringSeq; function Get_ORB_Id (Self : access Object) return CORBA.String; function Get_Codec_Factory (Self : access Object) return IOP.CodecFactory.Local_Ref; procedure Register_Initial_Reference (Self : access Object; Id : PortableInterceptor.ORBInitInfo.ObjectId; Obj : CORBA.Object.Ref); function Resolve_Initial_References (Self : access Object; Id : PortableInterceptor.ORBInitInfo.ObjectId) return CORBA.Object.Ref; procedure Add_Client_Request_Interceptor (Self : access Object; Interceptor : PortableInterceptor.ClientRequestInterceptor.Local_Ref); procedure Add_Server_Request_Interceptor (Self : access Object; Interceptor : PortableInterceptor.ServerRequestInterceptor.Local_Ref); procedure Add_IOR_Interceptor (Self : access Object; Interceptor : PortableInterceptor.IORInterceptor.Local_Ref); function Allocate_Slot_Id (Self : access Object) return PortableInterceptor.SlotId; procedure Register_Policy_Factory (Self : access Object; IDL_Type : CORBA.PolicyType; Policy_Factory : PortableInterceptor.PolicyFactory.Local_Ref); function Is_A (Self : not null access Object; Logical_Type_Id : String) return Boolean; private type Object is new CORBA.Local.Object with record Post_Init_Done : Boolean := False; end record; end PortableInterceptor.ORBInitInfo.Impl; polyorb-2.8~20110207.orig/src/corba/portableinterceptor/portableinterceptor-orbinitinfo-impl.adb0000644000175000017500000002436411750740340032375 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- PORTABLEINTERCEPTOR.ORBINITINFO.IMPL -- -- -- -- B o d y -- -- -- -- Copyright (C) 2004-2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with PolyORB.CORBA_P.Interceptors; with PolyORB.CORBA_P.Interceptors_Policies; with PolyORB.CORBA_P.Interceptors_Slots; with PolyORB.CORBA_P.Initial_References; with IOP.CodecFactory.Helper; with PortableInterceptor.ORBInitInfo.Helper; package body PortableInterceptor.ORBInitInfo.Impl is ------------------------------------ -- Add_Client_Request_Interceptor -- ------------------------------------ procedure Add_Client_Request_Interceptor (Self : access Object; Interceptor : PortableInterceptor.ClientRequestInterceptor.Local_Ref) is begin if Self.Post_Init_Done then CORBA.Raise_Object_Not_Exist (CORBA.Default_Sys_Member); end if; declare Name : constant String := CORBA.To_Standard_String (PortableInterceptor.ClientRequestInterceptor.Get_Name (Interceptor)); begin if Name /= "" then if PolyORB.CORBA_P.Interceptors. Is_Client_Request_Interceptor_Exists (Name) then Helper.Raise_DuplicateName (DuplicateName_Members'(Name => CORBA.To_CORBA_String (Name))); end if; end if; end; PolyORB.CORBA_P.Interceptors.Add_Client_Request_Interceptor (Interceptor); end Add_Client_Request_Interceptor; ------------------------- -- Add_IOR_Interceptor -- ------------------------- procedure Add_IOR_Interceptor (Self : access Object; Interceptor : PortableInterceptor.IORInterceptor.Local_Ref) is begin if Self.Post_Init_Done then CORBA.Raise_Object_Not_Exist (CORBA.Default_Sys_Member); end if; declare Name : constant String := CORBA.To_Standard_String (PortableInterceptor.IORInterceptor.Get_Name (Interceptor)); begin if Name /= "" then if PolyORB.CORBA_P.Interceptors.Is_IOR_Interceptor_Exists (Name) then Helper.Raise_DuplicateName (DuplicateName_Members'(Name => CORBA.To_CORBA_String (Name))); end if; end if; end; PolyORB.CORBA_P.Interceptors.Add_IOR_Interceptor (Interceptor); end Add_IOR_Interceptor; ------------------------------------ -- Add_Server_Request_Interceptor -- ------------------------------------ procedure Add_Server_Request_Interceptor (Self : access Object; Interceptor : PortableInterceptor.ServerRequestInterceptor.Local_Ref) is begin if Self.Post_Init_Done then CORBA.Raise_Object_Not_Exist (CORBA.Default_Sys_Member); end if; declare Name : constant String := CORBA.To_Standard_String (PortableInterceptor.ServerRequestInterceptor.Get_Name (Interceptor)); begin if Name /= "" then if PolyORB.CORBA_P.Interceptors. Is_Server_Request_Interceptor_Exists (Name) then Helper.Raise_DuplicateName (DuplicateName_Members'(Name => CORBA.To_CORBA_String (Name))); end if; end if; end; PolyORB.CORBA_P.Interceptors.Add_Server_Request_Interceptor (Interceptor); end Add_Server_Request_Interceptor; ---------------------- -- Allocate_Slot_Id -- ---------------------- function Allocate_Slot_Id (Self : access Object) return PortableInterceptor.SlotId is begin if Self.Post_Init_Done then CORBA.Raise_Object_Not_Exist (CORBA.Default_Sys_Member); end if; return PolyORB.CORBA_P.Interceptors_Slots.Allocate_Slot_Id; end Allocate_Slot_Id; ------------------- -- Get_Arguments -- ------------------- function Get_Arguments (Self : access Object) return CORBA.IDL_SEQUENCES.StringSeq is pragma Unreferenced (Self); Result : CORBA.IDL_SEQUENCES.StringSeq; begin raise Program_Error; return Result; end Get_Arguments; ----------------------- -- Get_Codec_Factory -- ----------------------- function Get_Codec_Factory (Self : access Object) return IOP.CodecFactory.Local_Ref is pragma Unreferenced (Self); begin return IOP.CodecFactory.Helper.To_Local_Ref (PolyORB.CORBA_P.Initial_References.Resolve_Initial_References ("CodecFactory")); end Get_Codec_Factory; ---------------- -- Get_ORB_Id -- ---------------- function Get_ORB_Id (Self : access Object) return CORBA.String is pragma Unreferenced (Self); Result : CORBA.String; begin raise Program_Error; return Result; end Get_ORB_Id; ---------- -- Init -- ---------- procedure Init (Self : access Object) is begin Self.Post_Init_Done := False; end Init; ---------- -- Is_A -- ---------- function Is_A (Self : not null access Object; Logical_Type_Id : String) return Boolean is pragma Unreferenced (Self); begin return CORBA.Is_Equivalent (Logical_Type_Id, PortableInterceptor.ORBInitInfo.Repository_Id) or else CORBA.Is_Equivalent (Logical_Type_Id, "IDL:omg.org/CORBA/Object:1.0"); end Is_A; -------------------- -- Post_Init_Done -- -------------------- procedure Post_Init_Done (Self : access Object) is begin pragma Assert (not Self.Post_Init_Done); Self.Post_Init_Done := True; PolyORB.CORBA_P.Interceptors_Slots.ORB_Initializer_Done := True; end Post_Init_Done; -------------------------------- -- Register_Initial_Reference -- -------------------------------- procedure Register_Initial_Reference (Self : access Object; Id : PortableInterceptor.ORBInitInfo.ObjectId; Obj : CORBA.Object.Ref) is pragma Unreferenced (Self); pragma Unreferenced (Id); pragma Unreferenced (Obj); begin -- if Impl.Object_Ptr (Entity_Of (Self)).Initialization_Complete then -- CORBA.Raise_Object_Not_Exist (CORBA.Default_Sys_Member); -- end if; -- -- -- If string id is empty or id is already registered, -- -- then raise InvalidName. -- -- if Id = "" -- or else not CORBA.Object.Is_Nil -- (PCIR.Resolve_Initial_References (To_String (Id))) -- then -- Raise_InvalidName ((null record)); -- end if; -- -- -- If Ref is null, then raise Bad_Param with minor code 27 -- -- if CORBA.Object.Is_Nil (Obj) then -- Raise_Bad_Param (Bad_Param_Members'(Minor => 27, -- Completed => Completed_No)); -- end if; -- -- PCIR.Register_Initial_Reference (To_String (Id), Obj); raise Program_Error; end Register_Initial_Reference; ----------------------------- -- Register_Policy_Factory -- ----------------------------- procedure Register_Policy_Factory (Self : access Object; IDL_Type : CORBA.PolicyType; Policy_Factory : PortableInterceptor.PolicyFactory.Local_Ref) is pragma Unreferenced (Self); begin PolyORB.CORBA_P.Interceptors_Policies.Register_Policy_Factory (IDL_Type, Policy_Factory); end Register_Policy_Factory; -------------------------------- -- Resolve_Initial_References -- -------------------------------- function Resolve_Initial_References (Self : access Object; Id : PortableInterceptor.ORBInitInfo.ObjectId) return CORBA.Object.Ref is pragma Unreferenced (Self); pragma Unreferenced (Id); -- Result : CORBA.Object.Ref -- := PolyORB.CORBA_P.Initial_References.Resolve_Initial_References -- (To_Standard_String (Id)); Result : CORBA.Object.Ref; begin -- if Impl.Object_Ptr (Entity_Of (Self)).Initialization_Complete then -- Raise_Object_Not_Exist (Default_Sys_Member); -- end if; -- -- if CORBA.Object.Is_Nil (Result) then -- Raise_InvalidName ((null record)); -- end if; -- -- return Result; raise Program_Error; return Result; end Resolve_Initial_References; end PortableInterceptor.ORBInitInfo.Impl; ././@LongLink0000000000000000000000000000015600000000000011567 Lustar rootrootpolyorb-2.8~20110207.orig/src/corba/portableinterceptor/portableinterceptor-orbinitializer-initialize_all.adspolyorb-2.8~20110207.orig/src/corba/portableinterceptor/portableinterceptor-orbinitializer-initializ0000644000175000017500000000516511750740340033405 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- PORTABLEINTERCEPTOR.ORBINITIALIZER.INITIALIZE_ALL -- -- -- -- S p e c -- -- -- -- Copyright (C) 2004-2008, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the CORBA Specification, and adapted -- -- for use with PolyORB. The copyright notice above, and the license -- -- provisions that follow apply solely to the contents neither explicitly -- -- nor implicitly specified by the CORBA Specification defined by the OMG. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- XXX Temporary workaround: set up interceptors. Should reword -- PolyORB initialization so that interceptors are configured when -- initializing the CORBA ORB. procedure PortableInterceptor.ORBInitializer.Initialize_All; polyorb-2.8~20110207.orig/src/corba/portableinterceptor/portableinterceptor-iorinterceptor-impl.adb0000644000175000017500000000576511750740340033127 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- PORTABLEINTERCEPTOR.IORINTERCEPTOR.IMPL -- -- -- -- B o d y -- -- -- -- Copyright (C) 2004-2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ package body PortableInterceptor.IORInterceptor.Impl is -------------------------- -- Establish_Components -- -------------------------- procedure Establish_Components (Self : access Object; Info : PortableInterceptor.IORInfo.Local_Ref) is pragma Unreferenced (Self); pragma Unreferenced (Info); begin null; end Establish_Components; ---------- -- Is_A -- ---------- function Is_A (Self : not null access Object; Logical_Type_Id : Standard.String) return Boolean is pragma Unreferenced (Self); begin return CORBA.Is_Equivalent (Logical_Type_Id, PortableInterceptor.IORInterceptor.Repository_Id) or else CORBA.Is_Equivalent (Logical_Type_Id, PortableInterceptor.Interceptor.Repository_Id) or else CORBA.Is_Equivalent (Logical_Type_Id, "IDL:omg.org/CORBA/Object:1.0"); end Is_A; end PortableInterceptor.IORInterceptor.Impl; ././@LongLink0000000000000000000000000000014700000000000011567 Lustar rootrootpolyorb-2.8~20110207.orig/src/corba/portableinterceptor/portableinterceptor-clientrequestinfo-impl.adbpolyorb-2.8~20110207.orig/src/corba/portableinterceptor/portableinterceptor-clientrequestinfo-impl.a0000644000175000017500000004535311750740340033311 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- PORTABLEINTERCEPTOR.CLIENTREQUESTINFO.IMPL -- -- -- -- B o d y -- -- -- -- Copyright (C) 2004-2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with Ada.Unchecked_Deallocation; with PolyORB.Any; with PolyORB.Binding_Data; with PolyORB.Binding_Data_QoS; with PolyORB.Buffers; with PolyORB.CORBA_P.Codec_Utils; with PolyORB.QoS.Service_Contexts; with PolyORB.QoS.Tagged_Components; with PolyORB.References.Binding; with PolyORB.References.IOR; with PolyORB.Representations.CDR.Common; with PolyORB.Request_QoS; with PolyORB.Types; package body PortableInterceptor.ClientRequestInfo.Impl is use PolyORB.CORBA_P.Codec_Utils; use PolyORB.CORBA_P.Interceptors; use PolyORB.QoS; use PolyORB.Representations.CDR.Common; use PolyORB.Request_QoS; --------------------------------- -- Add_Request_Service_Context -- --------------------------------- procedure Add_Request_Service_Context (Self : access Object; Service_Context : IOP.ServiceContext; Replace : CORBA.Boolean) is use PolyORB.QoS.Service_Contexts; use PolyORB.QoS.Service_Contexts.Service_Context_Lists; use type Service_Id; procedure Free is new Ada.Unchecked_Deallocation (Encapsulation, Encapsulation_Access); SCP : QoS_GIOP_Service_Contexts_Parameter_Access; Iter : Iterator; begin if Self.Point /= Send_Request then CORBA.Raise_Bad_Inv_Order (CORBA.Bad_Inv_Order_Members'(Minor => 14, Completed => CORBA.Completed_No)); end if; SCP := QoS_GIOP_Service_Contexts_Parameter_Access (Extract_Request_Parameter (GIOP_Service_Contexts, Self.Request.all)); if SCP = null then SCP := new QoS_GIOP_Service_Contexts_Parameter; Add_Request_QoS (Self.Request.all, GIOP_Service_Contexts, QoS_Parameter_Access (SCP)); end if; Iter := First (SCP.Service_Contexts); while not Last (Iter) loop if Value (Iter).Context_Id = Service_Id (Service_Context.Context_Id) then if not Replace then CORBA.Raise_Bad_Inv_Order (CORBA.Bad_Inv_Order_Members' (Minor => 15, Completed => CORBA.Completed_No)); end if; Free (Value (Iter).Context_Data); Value (Iter).Context_Data := new Encapsulation' (To_Encapsulation (CORBA.IDL_SEQUENCES.IDL_SEQUENCE_Octet.Sequence (Service_Context.Context_Data))); return; end if; Next (Iter); end loop; Append (SCP.Service_Contexts, (Service_Id (Service_Context.Context_Id), new Encapsulation' (To_Encapsulation (CORBA.IDL_SEQUENCES.IDL_SEQUENCE_Octet.Sequence (Service_Context.Context_Data))))); end Add_Request_Service_Context; ------------------- -- Get_Arguments -- ------------------- function Get_Arguments (Self : access Object) return Dynamic.ParameterList is begin if Self.Point /= Send_Request and Self.Point /= Receive_Reply then CORBA.Raise_Bad_Inv_Order (CORBA.Bad_Inv_Order_Members'(Minor => 14, Completed => CORBA.Completed_No)); end if; return RequestInfo.Impl.Get_Arguments (RequestInfo.Impl.Object (Self.all)'Access); end Get_Arguments; ------------------ -- Get_Contexts -- ------------------ function Get_Contexts (Self : access Object) return Dynamic.ContextList is begin if Self.Point = Send_Poll then CORBA.Raise_Bad_Inv_Order (CORBA.Bad_Inv_Order_Members'(Minor => 14, Completed => CORBA.Completed_No)); end if; return RequestInfo.Impl.Get_Contexts (RequestInfo.Impl.Object (Self.all)'Access); end Get_Contexts; ----------------------------- -- Get_Effective_Component -- ----------------------------- function Get_Effective_Component (Self : access Object; Id : IOP.ComponentId) return IOP.TaggedComponent is use PolyORB.QoS.Tagged_Components; use PolyORB.QoS.Tagged_Components.GIOP_Tagged_Component_Lists; use type PolyORB.Types.Unsigned_Long; Profile : PolyORB.Binding_Data.Profile_Access; QoS : QoS_GIOP_Tagged_Components_Parameter_Access; begin if Self.Point = Send_Poll then CORBA.Raise_Bad_Inv_Order (CORBA.Bad_Inv_Order_Members'(Minor => 14, Completed => CORBA.Completed_No)); end if; Profile := PolyORB.References.Binding.Get_Preferred_Profile (Self.Request.Target, True); QoS := QoS_GIOP_Tagged_Components_Parameter_Access (PolyORB.Binding_Data_QoS.Get_Profile_QoS (Profile, GIOP_Tagged_Components)); if QoS /= null then declare Iter : Iterator := First (QoS.Components); begin while not Last (Iter) loop if Value (Iter).Tag = Component_Id (Id) then return (Id, IOP.ComponentData (CORBA.IDL_SEQUENCES.IDL_SEQUENCE_Octet.To_Sequence (CORBA.IDL_SEQUENCES.IDL_SEQUENCE_Octet.To_Element_Array (To_Sequence (Value (Iter).Data.all))))); end if; Next (Iter); end loop; end; end if; CORBA.Raise_Bad_Param (CORBA.Bad_Param_Members'(Minor => 28, Completed => CORBA.Completed_No)); end Get_Effective_Component; ------------------------------ -- Get_Effective_Components -- ------------------------------ function Get_Effective_Components (Self : access Object; Id : IOP.ComponentId) return IOP.TaggedComponentSeq is use IOP; use PolyORB.QoS.Tagged_Components; use PolyORB.QoS.Tagged_Components.GIOP_Tagged_Component_Lists; use type PolyORB.Types.Unsigned_Long; Profile : PolyORB.Binding_Data.Profile_Access; QoS : QoS_GIOP_Tagged_Components_Parameter_Access; Result : IOP.TaggedComponentSeq; begin if Self.Point = Send_Poll then CORBA.Raise_Bad_Inv_Order (CORBA.Bad_Inv_Order_Members'(Minor => 14, Completed => CORBA.Completed_No)); end if; Profile := PolyORB.References.Binding.Get_Preferred_Profile (Self.Request.Target, True); QoS := QoS_GIOP_Tagged_Components_Parameter_Access (PolyORB.Binding_Data_QoS.Get_Profile_QoS (Profile, GIOP_Tagged_Components)); if QoS /= null then declare Iter : Iterator := First (QoS.Components); begin while not Last (Iter) loop if Value (Iter).Tag = Component_Id (Id) then Append (Result, IOP.TaggedComponent' (Id, IOP.ComponentData (CORBA.IDL_SEQUENCES.IDL_SEQUENCE_Octet.To_Sequence (CORBA.IDL_SEQUENCES.IDL_SEQUENCE_Octet.To_Element_Array (To_Sequence (Value (Iter).Data.all)))))); end if; Next (Iter); end loop; end; end if; if Length (Result) = 0 then CORBA.Raise_Bad_Param (CORBA.Bad_Param_Members'(Minor => 28, Completed => CORBA.Completed_No)); else return Result; end if; end Get_Effective_Components; --------------------------- -- Get_Effective_Profile -- --------------------------- function Get_Effective_Profile (Self : access Object) return IOP.TaggedProfile is Profile : PolyORB.Binding_Data.Profile_Access; Result : IOP.TaggedProfile; begin Profile := PolyORB.References.Binding.Get_Preferred_Profile (Self.Request.Target, True); declare Buffer : PolyORB.Buffers.Buffer_Access := new PolyORB.Buffers.Buffer_Type; Success : Boolean; begin -- Marshall profile with IOR rules PolyORB.References.IOR.Marshall_Profile (Buffer, Profile, Success); if not Success then raise Program_Error; end if; PolyORB.Buffers.Show (Buffer); PolyORB.Buffers.Rewind (Buffer); -- Unmarshall profile tag and profile data Result.Tag := IOP.ProfileId (PolyORB.Types.Unsigned_Long' (PolyORB.Representations.CDR.Common.Unmarshall (Buffer))); Result.Profile_Data := IOP.ProfileData (CORBA.IDL_SEQUENCES.IDL_SEQUENCE_Octet.To_Sequence (CORBA.IDL_SEQUENCES.IDL_SEQUENCE_Octet.To_Element_Array (PolyORB.CORBA_P.Codec_Utils.To_Sequence (PolyORB.Representations.CDR.Common.Unmarshall (Buffer))))); PolyORB.Buffers.Release (Buffer); end; return Result; end Get_Effective_Profile; -------------------------- -- Get_Effective_Target -- -------------------------- function Get_Effective_Target (Self : access Object) return CORBA.Object.Ref is begin return CORBA.Object.Internals.To_CORBA_Ref (Self.Request.Target); end Get_Effective_Target; -------------------- -- Get_Exceptions -- -------------------- function Get_Exceptions (Self : access Object) return Dynamic.ExceptionList is begin if Self.Point = Send_Poll then CORBA.Raise_Bad_Inv_Order (CORBA.Bad_Inv_Order_Members'(Minor => 14, Completed => CORBA.Completed_No)); end if; return RequestInfo.Impl.Get_Exceptions (RequestInfo.Impl.Object (Self.all)'Access); end Get_Exceptions; --------------------------- -- Get_Forward_Reference -- --------------------------- function Get_Forward_Reference (Self : access Object) return CORBA.Object.Ref is begin if Self.Point /= Receive_Other then CORBA.Raise_Bad_Inv_Order (CORBA.Bad_Inv_Order_Members'(Minor => 14, Completed => CORBA.Completed_No)); end if; return RequestInfo.Impl.Get_Forward_Reference (RequestInfo.Impl.Object (Self.all)'Access); end Get_Forward_Reference; --------------------------- -- Get_Operation_Context -- --------------------------- function Get_Operation_Context (Self : access Object) return Dynamic.RequestContext is begin if Self.Point = Send_Poll then CORBA.Raise_Bad_Inv_Order (CORBA.Bad_Inv_Order_Members'(Minor => 14, Completed => CORBA.Completed_No)); end if; return RequestInfo.Impl.Get_Operation_Context (RequestInfo.Impl.Object (Self.all)'Access); end Get_Operation_Context; ---------------------------- -- Get_Received_Exception -- ---------------------------- function Get_Received_Exception (Self : access Object) return CORBA.Any is begin if Self.Point /= Receive_Exception then CORBA.Raise_Bad_Inv_Order (CORBA.Bad_Inv_Order_Members'(Minor => 14, Completed => CORBA.Completed_No)); end if; return CORBA.Any (Self.Request.Exception_Info); end Get_Received_Exception; ------------------------------- -- Get_Received_Exception_Id -- ------------------------------- function Get_Received_Exception_Id (Self : access Object) return CORBA.RepositoryId is begin if Self.Point /= Receive_Exception then CORBA.Raise_Bad_Inv_Order (CORBA.Bad_Inv_Order_Members'(Minor => 14, Completed => CORBA.Completed_No)); end if; return CORBA.RepositoryId (PolyORB.Any.TypeCode.Id (PolyORB.Any.Get_Type (Self.Request.Exception_Info))); end Get_Received_Exception_Id; ------------------------------- -- Get_Reply_Service_Context -- ------------------------------- function Get_Reply_Service_Context (Self : access Object; Id : IOP.ServiceId) return IOP.ServiceContext is begin if Self.Point = Send_Request or else Self.Point = Send_Poll then CORBA.Raise_Bad_Inv_Order (CORBA.Bad_Inv_Order_Members'(Minor => 14, Completed => CORBA.Completed_No)); end if; return RequestInfo.Impl.Get_Reply_Service_Context (RequestInfo.Impl.Object (Self.all)'Access, Id); end Get_Reply_Service_Context; ---------------------- -- Get_Reply_Status -- ---------------------- function Get_Reply_Status (Self : access Object) return ReplyStatus is begin if Self.Point = Send_Request or else Self.Point = Send_Poll then CORBA.Raise_Bad_Inv_Order (CORBA.Bad_Inv_Order_Members'(Minor => 14, Completed => CORBA.Completed_No)); end if; return RequestInfo.Impl.Get_Reply_Status (RequestInfo.Impl.Object (Self.all)'Access); end Get_Reply_Status; ------------------------ -- Get_Request_Policy -- ------------------------ function Get_Request_Policy (Self : access Object; IDL_Type : CORBA.PolicyType) return CORBA.Policy.Ref is pragma Unreferenced (IDL_Type); Result : CORBA.Policy.Ref; begin if Self.Point = Send_Poll then CORBA.Raise_Bad_Inv_Order (CORBA.Bad_Inv_Order_Members'(Minor => 14, Completed => CORBA.Completed_No)); end if; raise Program_Error; return Result; end Get_Request_Policy; --------------------------------- -- Get_Request_Service_Context -- --------------------------------- function Get_Request_Service_Context (Self : access Object; Id : IOP.ServiceId) return IOP.ServiceContext is begin if Self.Point = Send_Poll then CORBA.Raise_Bad_Inv_Order (CORBA.Bad_Inv_Order_Members'(Minor => 14, Completed => CORBA.Completed_No)); end if; return RequestInfo.Impl.Get_Request_Service_Context (RequestInfo.Impl.Object (Self.all)'Access, Id); end Get_Request_Service_Context; ---------------- -- Get_Result -- ---------------- function Get_Result (Self : access Object) return CORBA.Any is begin if Self.Point /= Receive_Reply then CORBA.Raise_Bad_Inv_Order (CORBA.Bad_Inv_Order_Members'(Minor => 14, Completed => CORBA.Completed_No)); end if; return RequestInfo.Impl.Get_Result (RequestInfo.Impl.Object (Self.all)'Access); end Get_Result; -------------------- -- Get_Sync_Scope -- -------------------- function Get_Sync_Scope (Self : access Object) return Messaging.SyncScope is begin if Self.Point = Send_Poll then CORBA.Raise_Bad_Inv_Order (CORBA.Bad_Inv_Order_Members'(Minor => 14, Completed => CORBA.Completed_No)); end if; return RequestInfo.Impl.Get_Sync_Scope (RequestInfo.Impl.Object (Self.all)'Access); end Get_Sync_Scope; ---------------- -- Get_Target -- ---------------- function Get_Target (Self : access Object) return CORBA.Object.Ref is begin return Self.Target; end Get_Target; ---------- -- Init -- ---------- procedure Init (Self : access Object; Point : Client_Interception_Point; Request : PolyORB.Requests.Request_Access; Request_Id : CORBA.Unsigned_Long; Target : CORBA.Object.Ref) is begin RequestInfo.Impl.Init (RequestInfo.Impl.Object_Ptr (Self), Request, Request_Id); Self.Point := Point; Self.Request := Request; Self.Target := Target; end Init; ---------- -- Is_A -- ---------- function Is_A (Self : not null access Object; Logical_Type_Id : String) return Boolean is pragma Unreferenced (Self); begin return CORBA.Is_Equivalent (Logical_Type_Id, PortableInterceptor.ClientRequestInfo.Repository_Id) or else CORBA.Is_Equivalent (Logical_Type_Id, PortableInterceptor.RequestInfo.Repository_Id) or else CORBA.Is_Equivalent (Logical_Type_Id, "IDL:omg.org/CORBA/Object:1.0"); end Is_A; end PortableInterceptor.ClientRequestInfo.Impl; polyorb-2.8~20110207.orig/src/corba/portableinterceptor/polyorb-corba_p-interceptors_slots.adb0000644000175000017500000001032311750740340032051 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . C O R B A _ P . I N T E R C E P T O R S _ S L O T S -- -- -- -- B o d y -- -- -- -- Copyright (C) 2004-2007, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with PortableInterceptor.Helper; package body PolyORB.CORBA_P.Interceptors_Slots is use Any_Sequences; use PortableInterceptor; use PortableInterceptor.Helper; Last_Allocated_Slot_Id : PortableInterceptor.SlotId := 0; ---------------------- -- Allocate_Slot_Id -- ---------------------- function Allocate_Slot_Id return SlotId is begin Last_Allocated_Slot_Id := Last_Allocated_Slot_Id + 1; return Last_Allocated_Slot_Id; end Allocate_Slot_Id; -------------------- -- Allocate_Slots -- -------------------- procedure Allocate_Slots (Note : in out Slots_Note) is Empty : constant CORBA.Any := CORBA.Internals.Get_Empty_Any (CORBA.TC_Null); begin Note.Slots := Null_Sequence; for J in 1 .. Last_Allocated_Slot_Id loop Append (Note.Slots, Empty); end loop; Note.Allocated := True; end Allocate_Slots; -------------- -- Get_Slot -- -------------- function Get_Slot (Note : Slots_Note; Id : SlotId) return CORBA.Any is begin pragma Assert (Note.Allocated); if Id not in 1 .. SlotId (Length (Note.Slots)) then Raise_InvalidSlot ((null record)); end if; return Get_Element (Note.Slots, Integer (Id)); end Get_Slot; ------------------------ -- Invalid_Slots_Note -- ------------------------ function Invalid_Slots_Note return Slots_Note is Aux : constant Slots_Note := (PolyORB.Annotations.Note with False, Any_Sequences.Null_Sequence); begin return Aux; end Invalid_Slots_Note; ------------------ -- Is_Allocated -- ------------------ function Is_Allocated (Note : Slots_Note) return Boolean is begin return Note.Allocated; end Is_Allocated; -------------- -- Set_Slot -- -------------- procedure Set_Slot (Note : in out Slots_Note; Id : SlotId; Data : CORBA.Any) is begin pragma Assert (Note.Allocated); if Id not in 1 .. SlotId (Length (Note.Slots)) then Raise_InvalidSlot ((null record)); end if; Replace_Element (Note.Slots, Integer (Id), Data); end Set_Slot; end PolyORB.CORBA_P.Interceptors_Slots; ././@LongLink0000000000000000000000000000015000000000000011561 Lustar rootrootpolyorb-2.8~20110207.orig/src/corba/portableinterceptor/portableinterceptor-iorinterceptor_3_0-impl.adbpolyorb-2.8~20110207.orig/src/corba/portableinterceptor/portableinterceptor-iorinterceptor_3_0-impl.0000644000175000017500000000775511750740340033122 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- PORTABLEINTERCEPTOR.IORINTERCEPTOR_3_0.IMPL -- -- -- -- B o d y -- -- -- -- Copyright (C) 2004-2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with PortableInterceptor.Interceptor; package body PortableInterceptor.IORInterceptor_3_0.Impl is ----------------------------------- -- Adapter_Manager_State_Changed -- ----------------------------------- procedure Adapter_Manager_State_Changed (Self : access Object; Id : AdapterManagerId; State : AdapterState) is pragma Unreferenced (Self); pragma Unreferenced (Id); pragma Unreferenced (State); begin null; end Adapter_Manager_State_Changed; -- --------------------------- -- -- Adapter_State_Changed -- -- --------------------------- -- -- procedure Adapter_State_Changed -- (Self : access Object; -- Templates : ObjectReferenceTemplate.Abstract_Value_Ref; -- State : AdapterState) -- is -- pragma Unreferenced (Self); -- pragma Unreferenced (Templates); -- pragma Unreferenced (State); -- begin -- null; -- end Adapter_State_Changed; ---------------------------- -- Components_Established -- ---------------------------- procedure Components_Established (Self : access Object; Info : PortableInterceptor.IORInfo.Local_Ref) is pragma Unreferenced (Self); pragma Unreferenced (Info); begin null; end Components_Established; ---------- -- Is_A -- ---------- function Is_A (Self : not null access Object; Logical_Type_Id : Standard.String) return Boolean is pragma Unreferenced (Self); begin return CORBA.Is_Equivalent (Logical_Type_Id, PortableInterceptor.IORInterceptor_3_0.Repository_Id) or else CORBA.Is_Equivalent (Logical_Type_Id, PortableInterceptor.IORInterceptor.Repository_Id) or else CORBA.Is_Equivalent (Logical_Type_Id, PortableInterceptor.Interceptor.Repository_Id) or else CORBA.Is_Equivalent (Logical_Type_Id, "IDL:omg.org/CORBA/Object:1.0"); end Is_A; end PortableInterceptor.IORInterceptor_3_0.Impl; polyorb-2.8~20110207.orig/src/corba/portableinterceptor/portableinterceptor-iorinfo-impl.adb0000644000175000017500000001551411750740340031515 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O R T A B L E I N T E R C E P T O R . I O R I N F O . I M P L -- -- -- -- B o d y -- -- -- -- Copyright (C) 2004-2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with Ada.Streams; with PolyORB.Annotations; with PolyORB.CORBA_P.Codec_Utils; with PolyORB.CORBA_P.Policy_Management; with PolyORB.Obj_Adapter_QoS; with PolyORB.QoS.Tagged_Components; package body PortableInterceptor.IORInfo.Impl is ----------------------- -- Add_IOR_Component -- ----------------------- procedure Add_IOR_Component (Self : access Object; A_Component : IOP.TaggedComponent) is use PolyORB.Obj_Adapter_QoS; use PolyORB.QoS; use PolyORB.QoS.Tagged_Components; use PolyORB.QoS.Tagged_Components.GIOP_Tagged_Component_Lists; QoS : QoS_GIOP_Tagged_Components_Parameter_Access := QoS_GIOP_Tagged_Components_Parameter_Access (Get_Object_Adapter_QoS (Self.POA, GIOP_Tagged_Components)); begin if QoS = null then QoS := new QoS_GIOP_Tagged_Components_Parameter; Set_Object_Adapter_QoS (Self.POA, GIOP_Tagged_Components, QoS_Parameter_Access (QoS)); end if; Append (QoS.Components, (Component_Id (A_Component.Tag), new Ada.Streams.Stream_Element_Array' (PolyORB.CORBA_P.Codec_Utils.To_Encapsulation (CORBA.IDL_SEQUENCES.IDL_SEQUENCE_Octet.Sequence (A_Component.Component_Data))))); end Add_IOR_Component; ---------------------------------- -- Add_IOR_Component_To_Profile -- ---------------------------------- procedure Add_IOR_Component_To_Profile (Self : access Object; A_Component : IOP.TaggedComponent; Profile_Id : IOP.ProfileId) is use type IOP.ProfileId; begin if Profile_Id /= IOP.Tag_Internet_IOP then CORBA.Raise_Bad_Param (CORBA.System_Exception_Members' (CORBA.IDL_Exception_Members with Minor => 29, Completed => CORBA.Completed_No)); end if; Add_IOR_Component (Self, A_Component); end Add_IOR_Component_To_Profile; -- -------------------------- -- -- Get_Adapter_Template -- -- -------------------------- -- -- function Get_Adapter_Template -- (Self : access Object) -- return ObjectReferenceTemplate.Abstract_Value_Ref -- is -- Result : ObjectReferenceTemplate.Abstract_Value_Ref; -- begin -- raise Program_Error; -- return Result; -- end Get_Adapter_Template; -- ------------------------- -- -- Get_Current_Factory -- -- ------------------------- -- -- function Get_Current_Factory -- (Self : access Object) -- return ObjectReferenceFactory.Abstract_Value_Ref -- is -- Result : ObjectReferenceFactory.Abstract_Value_Ref; -- begin -- raise Program_Error; -- return Result; -- end Get_Current_Factory; -------------------------- -- Get_Effective_Policy -- -------------------------- function Get_Effective_Policy (Self : access Object; IDL_Type : CORBA.PolicyType) return CORBA.Policy.Ref is use PolyORB.CORBA_P.Policy_Management; Note : Policy_Manager_Note; begin if not Is_Registered (IDL_Type) then CORBA.Raise_Inv_Policy (CORBA.System_Exception_Members'(3, CORBA.Completed_No)); end if; PolyORB.Annotations.Get_Note (PolyORB.POA.Notepad_Of (Self.POA).all, Note, Empty_Policy_Manager_Note); return Note.Overrides (IDL_Type); end Get_Effective_Policy; -------------------- -- Get_Manager_Id -- -------------------- function Get_Manager_Id (Self : access Object) return AdapterManagerId is pragma Unreferenced (Self); Result : AdapterManagerId; begin raise Program_Error; return Result; end Get_Manager_Id; --------------- -- Get_State -- --------------- function Get_State (Self : access Object) return AdapterState is pragma Unreferenced (Self); Result : AdapterState; begin raise Program_Error; return Result; end Get_State; ---------- -- Init -- ---------- procedure Init (Self : access Object; POA : PolyORB.POA.Obj_Adapter_Access) is begin Self.POA := POA; end Init; ---------- -- Is_A -- ---------- function Is_A (Self : not null access Object; Logical_Type_Id : Standard.String) return Boolean is pragma Unreferenced (Self); begin return CORBA.Is_Equivalent (Logical_Type_Id, PortableInterceptor.IORInfo.Repository_Id) or else CORBA.Is_Equivalent (Logical_Type_Id, "IDL:omg.org/CORBA/Object:1.0"); end Is_A; -- ------------------------- -- -- Set_Current_Factory -- -- ------------------------- -- -- procedure Set_Current_Factory -- (Self : access Object; -- To : ObjectReferenceFactory.Abstract_Value_Ref) -- is -- begin -- raise Program_Error; -- end Set_Current_Factory; end PortableInterceptor.IORInfo.Impl; ././@LongLink0000000000000000000000000000014700000000000011567 Lustar rootrootpolyorb-2.8~20110207.orig/src/corba/portableinterceptor/portableinterceptor-serverrequestinfo-impl.adbpolyorb-2.8~20110207.orig/src/corba/portableinterceptor/portableinterceptor-serverrequestinfo-impl.a0000644000175000017500000004212411750740340033332 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- PORTABLEINTERCEPTOR.SERVERREQUESTINFO.IMPL -- -- -- -- B o d y -- -- -- -- Copyright (C) 2004-2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with Ada.Unchecked_Deallocation; with PortableInterceptor.RequestInfo; with PolyORB.Annotations; with PolyORB.CORBA_P.Codec_Utils; with PolyORB.CORBA_P.Interceptors_Slots; with PolyORB.POA; with PolyORB.QoS.Service_Contexts; with PolyORB.Representations.CDR.Common; with PolyORB.Request_QoS; package body PortableInterceptor.ServerRequestInfo.Impl is use PolyORB.CORBA_P.Interceptors; ------------------------------- -- Add_Reply_Service_Context -- ------------------------------- procedure Add_Reply_Service_Context (Self : access Object; Service_Context : IOP.ServiceContext; Replace : CORBA.Boolean) is use PolyORB.CORBA_P.Codec_Utils; use PolyORB.QoS; use PolyORB.QoS.Service_Contexts; use PolyORB.Representations.CDR.Common; use PolyORB.Request_QoS; use Service_Context_Lists; use type Service_Id; procedure Free is new Ada.Unchecked_Deallocation (Encapsulation, Encapsulation_Access); SCP : QoS_GIOP_Service_Contexts_Parameter_Access; Iter : Iterator; begin SCP := QoS_GIOP_Service_Contexts_Parameter_Access (Extract_Reply_Parameter (GIOP_Service_Contexts, Self.Request.all)); if SCP = null then SCP := new QoS_GIOP_Service_Contexts_Parameter; Add_Reply_QoS (Self.Request.all, GIOP_Service_Contexts, QoS_Parameter_Access (SCP)); end if; Iter := First (SCP.Service_Contexts); while not Last (Iter) loop if Value (Iter).Context_Id = Service_Id (Service_Context.Context_Id) then if not Replace then CORBA.Raise_Bad_Inv_Order (CORBA.Bad_Inv_Order_Members' (Minor => 11, Completed => CORBA.Completed_No)); end if; Free (Value (Iter).Context_Data); Value (Iter).Context_Data := new Encapsulation' (To_Encapsulation (CORBA.IDL_SEQUENCES.IDL_SEQUENCE_Octet.Sequence (Service_Context.Context_Data))); return; end if; Next (Iter); end loop; Append (SCP.Service_Contexts, (Service_Id (Service_Context.Context_Id), new Encapsulation' (To_Encapsulation (CORBA.IDL_SEQUENCES.IDL_SEQUENCE_Octet.Sequence (Service_Context.Context_Data))))); end Add_Reply_Service_Context; -------------------- -- Get_Adapter_Id -- -------------------- function Get_Adapter_Id (Self : access Object) return CORBA.IDL_SEQUENCES.OctetSeq is pragma Unreferenced (Self); Result : CORBA.IDL_SEQUENCES.OctetSeq; begin raise Program_Error; return Result; end Get_Adapter_Id; ---------------------- -- Get_Adapter_Name -- ---------------------- function Get_Adapter_Name (Self : access Object) return AdapterName is begin if Self.Point = Receive_Request_Service_Contexts then CORBA.Raise_Bad_Inv_Order (CORBA.Bad_Inv_Order_Members'(Minor => 14, Completed => CORBA.Completed_No)); end if; declare use type PolyORB.POA.Obj_Adapter_Access; OA : PolyORB.POA.Obj_Adapter_Access := PolyORB.POA.Obj_Adapter_Access (PolyORB.Binding_Data.Get_OA (Self.Profile.all)); Result : AdapterName; begin while OA /= null loop Result := CORBA.To_CORBA_String (OA.Name.all) & Result; OA := PolyORB.POA.Obj_Adapter_Access (OA.Father); end loop; return Result; end; end Get_Adapter_Name; ------------------- -- Get_Arguments -- ------------------- function Get_Arguments (Self : access Object) return Dynamic.ParameterList is begin if Self.Point /= Receive_Request and Self.Point /= Send_Reply then CORBA.Raise_Bad_Inv_Order (CORBA.Bad_Inv_Order_Members'(Minor => 14, Completed => CORBA.Completed_No)); end if; -- If Receive_Request interception point called from Set_Exception -- then the arguments is not available and NO_RESOURCES (with minor -- code 1) raised. If Set_Exception called after Arguments then -- interception point called only once from Arguments. if not Self.Args_Present then CORBA.Raise_No_Resources (CORBA.No_Resources_Members'(Minor => 1, Completed => CORBA.Completed_No)); end if; return RequestInfo.Impl.Get_Arguments (RequestInfo.Impl.Object (Self.all)'Access); end Get_Arguments; ------------------ -- Get_Contexts -- ------------------ function Get_Contexts (Self : access Object) return Dynamic.ContextList is begin if Self.Point = Receive_Request_Service_Contexts then CORBA.Raise_Bad_Inv_Order (CORBA.Bad_Inv_Order_Members'(Minor => 14, Completed => CORBA.Completed_No)); end if; return RequestInfo.Impl.Get_Contexts (RequestInfo.Impl.Object (Self.all)'Access); end Get_Contexts; -------------------- -- Get_Exceptions -- -------------------- function Get_Exceptions (Self : access Object) return Dynamic.ExceptionList is begin if Self.Point = Receive_Request_Service_Contexts then CORBA.Raise_Bad_Inv_Order (CORBA.Bad_Inv_Order_Members'(Minor => 14, Completed => CORBA.Completed_No)); end if; -- XXX Is exceptions list available on server side ? Comment in -- PolyORB.Request say that Exc_List member is a client side -- information, thus we should raise NO_RESOURCES exception with -- standard minor code 1. CORBA.Raise_No_Resources (CORBA.No_Resources_Members'(Minor => 1, Completed => CORBA.Completed_No)); return RequestInfo.Impl.Get_Exceptions (RequestInfo.Impl.Object (Self.all)'Access); end Get_Exceptions; --------------------------- -- Get_Forward_Reference -- --------------------------- function Get_Forward_Reference (Self : access Object) return CORBA.Object.Ref is begin if Self.Point /= Send_Other then CORBA.Raise_Bad_Inv_Order (CORBA.Bad_Inv_Order_Members'(Minor => 14, Completed => CORBA.Completed_No)); end if; return RequestInfo.Impl.Get_Forward_Reference (RequestInfo.Impl.Object (Self.all)'Access); end Get_Forward_Reference; ------------------- -- Get_Object_Id -- ------------------- function Get_Object_Id (Self : access Object) return ObjectId is begin if Self.Point = Receive_Request_Service_Contexts then CORBA.Raise_Bad_Inv_Order (CORBA.Bad_Inv_Order_Members'(Minor => 14, Completed => CORBA.Completed_No)); end if; -- In Send_Exception and Send_Other interception points if servant -- locator caused a location forward, or raised an exception, this -- operation may not be available. NO_RESOURCES with a standard minor -- code of 1 will be raised if it is not available. -- CORBA3 can't describe the value returned by this operation if -- servant locator or portable interceptor caused location forward, -- so NO_RESOURCES exception is always raised in Send_Exception and -- Send_Other interception points. if Self.Point = Send_Exception or else Self.Point = Send_Other then CORBA.Raise_No_Resources (CORBA.No_Resources_Members'(Minor => 1, Completed => CORBA.Completed_No)); end if; return PortableInterceptor.ObjectId (PortableServer.Internals.To_PortableServer_ObjectId (PolyORB.Binding_Data.Get_Object_Key (Self.Profile.all).all)); end Get_Object_Id; --------------------------- -- Get_Operation_Context -- --------------------------- function Get_Operation_Context (Self : access Object) return Dynamic.RequestContext is begin if Self.Point /= Receive_Request and Self.Point /= Send_Reply then CORBA.Raise_Bad_Inv_Order (CORBA.Bad_Inv_Order_Members'(Minor => 14, Completed => CORBA.Completed_No)); end if; return RequestInfo.Impl.Get_Operation_Context (RequestInfo.Impl.Object (Self.all)'Access); end Get_Operation_Context; ---------------- -- Get_ORB_Id -- ---------------- function Get_ORB_Id (Self : access Object) return ORBId is Result : ORBId; begin if Self.Point = Receive_Request_Service_Contexts then CORBA.Raise_Bad_Inv_Order (CORBA.Bad_Inv_Order_Members'(Minor => 14, Completed => CORBA.Completed_No)); end if; raise Program_Error; return Result; end Get_ORB_Id; ------------------------------- -- Get_Reply_Service_Context -- ------------------------------- function Get_Reply_Service_Context (Self : access Object; Id : IOP.ServiceId) return IOP.ServiceContext is begin if Self.Point = Receive_Request_Service_Contexts or else Self.Point = Receive_Request then CORBA.Raise_Bad_Inv_Order (CORBA.Bad_Inv_Order_Members'(Minor => 14, Completed => CORBA.Completed_No)); end if; return RequestInfo.Impl.Get_Reply_Service_Context (RequestInfo.Impl.Object (Self.all)'Access, Id); end Get_Reply_Service_Context; ---------------------- -- Get_Reply_Status -- ---------------------- function Get_Reply_Status (Self : access Object) return ReplyStatus is begin if Self.Point = Receive_Request_Service_Contexts or else Self.Point = Receive_Request then CORBA.Raise_Bad_Inv_Order (CORBA.Bad_Inv_Order_Members'(Minor => 14, Completed => CORBA.Completed_No)); end if; return RequestInfo.Impl.Get_Reply_Status (RequestInfo.Impl.Object (Self.all)'Access); end Get_Reply_Status; ---------------- -- Get_Result -- ---------------- function Get_Result (Self : access Object) return CORBA.Any is begin if Self.Point /= Send_Reply then CORBA.Raise_Bad_Inv_Order (CORBA.Bad_Inv_Order_Members'(Minor => 14, Completed => CORBA.Completed_No)); end if; return RequestInfo.Impl.Get_Result (RequestInfo.Impl.Object (Self.all)'Access); end Get_Result; --------------------------- -- Get_Sending_Exception -- --------------------------- function Get_Sending_Exception (Self : access Object) return CORBA.Any is begin if Self.Point /= Send_Exception then CORBA.Raise_Bad_Inv_Order (CORBA.Bad_Inv_Order_Members'(Minor => 14, Completed => CORBA.Completed_No)); end if; return CORBA.Any (Self.Request.Exception_Info); end Get_Sending_Exception; ------------------- -- Get_Server_Id -- ------------------- function Get_Server_Id (Self : access Object) return ServerId is Result : ServerId; begin if Self.Point = Receive_Request_Service_Contexts then CORBA.Raise_Bad_Inv_Order (CORBA.Bad_Inv_Order_Members'(Minor => 14, Completed => CORBA.Completed_No)); end if; raise Program_Error; return Result; end Get_Server_Id; ----------------------- -- Get_Server_Policy -- ----------------------- function Get_Server_Policy (Self : access Object; A_Type : CORBA.PolicyType) return CORBA.Policy.Ref is pragma Unreferenced (Self); pragma Unreferenced (A_Type); Result : CORBA.Policy.Ref; begin raise Program_Error; return Result; end Get_Server_Policy; --------------------------------------- -- Get_Target_Most_Derived_Interface -- --------------------------------------- function Get_Target_Most_Derived_Interface (Self : access Object) return CORBA.RepositoryId is begin if Self.Point /= Receive_Request then CORBA.Raise_Bad_Inv_Order (CORBA.Bad_Inv_Order_Members'(Minor => 14, Completed => CORBA.Completed_No)); end if; return CORBA.To_CORBA_String (PortableServer.Internals.Target_Most_Derived_Interface (Self.Servant)); end Get_Target_Most_Derived_Interface; ---------- -- Init -- ---------- procedure Init (Self : access Object; Point : Server_Interception_Point; Servant : PortableServer.Servant; Request : PolyORB.Requests.Request_Access; Request_Id : CORBA.Unsigned_Long; Profile : PolyORB.Binding_Data.Profile_Access; Args_Present : Boolean) is begin RequestInfo.Impl.Init (RequestInfo.Impl.Object (Self.all)'Access, Request, Request_Id); Self.Point := Point; Self.Servant := Servant; Self.Request := Request; Self.Profile := Profile; Self.Args_Present := Args_Present; end Init; ---------- -- Is_A -- ---------- function Is_A (Self : not null access Object; Logical_Type_Id : Standard.String) return Boolean is pragma Unreferenced (Self); begin return CORBA.Is_Equivalent (Logical_Type_Id, PortableInterceptor.ServerRequestInfo.Repository_Id) or else CORBA.Is_Equivalent (Logical_Type_Id, PortableInterceptor.RequestInfo.Repository_Id) or else CORBA.Is_Equivalent (Logical_Type_Id, "IDL:omg.org/CORBA/Object:1.0"); end Is_A; -------------- -- Set_Slot -- -------------- procedure Set_Slot (Self : access Object; Id : PortableInterceptor.SlotId; Data : CORBA.Any) is use PolyORB.Annotations; use PolyORB.CORBA_P.Interceptors_Slots; Note : Slots_Note; begin Get_Note (Self.Request.Notepad, Note, Invalid_Slots_Note); Set_Slot (Note, Id, Data); Set_Note (Self.Request.Notepad, Note); end Set_Slot; ----------------- -- Target_Is_A -- ----------------- function Target_Is_A (Self : access Object; Id : CORBA.RepositoryId) return CORBA.Boolean is begin if Self.Point /= Receive_Request then CORBA.Raise_Bad_Inv_Order (CORBA.Bad_Inv_Order_Members'(Minor => 14, Completed => CORBA.Completed_No)); end if; return PortableServer.Internals.Target_Is_A (Self.Servant, CORBA.To_Standard_String (Id)); end Target_Is_A; end PortableInterceptor.ServerRequestInfo.Impl; polyorb-2.8~20110207.orig/src/corba/portableinterceptor/portableinterceptor-policyfactory-impl.adb0000644000175000017500000000567711750740340032750 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- PORTABLEINTERCEPTOR.POLICYFACTORY.IMPL -- -- -- -- B o d y -- -- -- -- Copyright (C) 2004-2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ package body PortableInterceptor.PolicyFactory.Impl is ------------------- -- Create_Policy -- ------------------- function Create_Policy (Self : access Object; IDL_Type : CORBA.PolicyType; Value : CORBA.Any) return CORBA.Policy.Ref is pragma Unreferenced (Self); pragma Unreferenced (IDL_Type); pragma Unreferenced (Value); Result : CORBA.Policy.Ref; begin return Result; end Create_Policy; ---------- -- Is_A -- ---------- function Is_A (Self : not null access Object; Logical_Type_Id : Standard.String) return Boolean is pragma Unreferenced (Self); begin return CORBA.Is_Equivalent (Logical_Type_Id, PortableInterceptor.PolicyFactory.Repository_Id) or else CORBA.Is_Equivalent (Logical_Type_Id, "IDL:omg.org/CORBA/Object:1.0"); end Is_A; end PortableInterceptor.PolicyFactory.Impl; ././@LongLink0000000000000000000000000000015600000000000011567 Lustar rootrootpolyorb-2.8~20110207.orig/src/corba/portableinterceptor/portableinterceptor-serverrequestinterceptor-impl.adbpolyorb-2.8~20110207.orig/src/corba/portableinterceptor/portableinterceptor-serverrequestinterceptor0000644000175000017500000001041711750740340033557 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- PORTABLEINTERCEPTOR.SERVERREQUESTINTERCEPTOR.IMPL -- -- -- -- B o d y -- -- -- -- Copyright (C) 2004-2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ package body PortableInterceptor.ServerRequestInterceptor.Impl is ---------- -- Is_A -- ---------- function Is_A (Self : not null access Object; Logical_Type_Id : Standard.String) return Boolean is pragma Unreferenced (Self); begin return CORBA.Is_Equivalent (Logical_Type_Id, PortableInterceptor.ServerRequestInterceptor.Repository_Id) or else CORBA.Is_Equivalent (Logical_Type_Id, PortableInterceptor.Interceptor.Repository_Id) or else CORBA.Is_Equivalent (Logical_Type_Id, "IDL:omg.org/CORBA/Object:1.0"); end Is_A; --------------------- -- Receive_Request -- --------------------- procedure Receive_Request (Self : access Object; RI : PortableInterceptor.ServerRequestInfo.Local_Ref) is pragma Unreferenced (Self); pragma Unreferenced (RI); begin null; end Receive_Request; -------------------------------------- -- Receive_Request_Service_Contexts -- -------------------------------------- procedure Receive_Request_Service_Contexts (Self : access Object; RI : PortableInterceptor.ServerRequestInfo.Local_Ref) is pragma Unreferenced (Self); pragma Unreferenced (RI); begin null; end Receive_Request_Service_Contexts; -------------------- -- Send_Exception -- -------------------- procedure Send_Exception (Self : access Object; RI : PortableInterceptor.ServerRequestInfo.Local_Ref) is pragma Unreferenced (Self); pragma Unreferenced (RI); begin null; end Send_Exception; ---------------- -- Send_Other -- ---------------- procedure Send_Other (Self : access Object; RI : PortableInterceptor.ServerRequestInfo.Local_Ref) is pragma Unreferenced (Self); pragma Unreferenced (RI); begin null; end Send_Other; ---------------- -- Send_Reply -- ---------------- procedure Send_Reply (Self : access Object; RI : PortableInterceptor.ServerRequestInfo.Local_Ref) is pragma Unreferenced (Self); pragma Unreferenced (RI); begin null; end Send_Reply; end PortableInterceptor.ServerRequestInterceptor.Impl; polyorb-2.8~20110207.orig/src/corba/portableinterceptor/portableinterceptor-current-impl.ads0000644000175000017500000000576511750740340031562 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O R T A B L E I N T E R C E P T O R . C U R R E N T . I M P L -- -- -- -- S p e c -- -- -- -- Copyright (C) 2004-2010, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the CORBA Specification, and adapted -- -- for use with PolyORB. The copyright notice above, and the license -- -- provisions that follow apply solely to the contents neither explicitly -- -- nor implicitly specified by the CORBA Specification defined by the OMG. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with CORBA.Local; package PortableInterceptor.Current.Impl is type Object is new CORBA.Local.Object with private; type Object_Ptr is access all Object'Class; function Get_Slot (Self : access Object; Id : SlotId) return CORBA.Any; procedure Set_Slot (Self : access Object; Id : SlotId; Data : CORBA.Any); function Is_A (Self : not null access Object; Logical_Type_Id : Standard.String) return Boolean; private type Object is new CORBA.Local.Object with record null; end record; end PortableInterceptor.Current.Impl; polyorb-2.8~20110207.orig/src/corba/portableinterceptor/portableinterceptor-policyfactory-impl.ads0000644000175000017500000000572711750740340032765 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- PORTABLEINTERCEPTOR.POLICYFACTORY.IMPL -- -- -- -- S p e c -- -- -- -- Copyright (C) 2004-2010, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the CORBA Specification, and adapted -- -- for use with PolyORB. The copyright notice above, and the license -- -- provisions that follow apply solely to the contents neither explicitly -- -- nor implicitly specified by the CORBA Specification defined by the OMG. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with CORBA.Local; with CORBA.Policy; package PortableInterceptor.PolicyFactory.Impl is type Object is new CORBA.Local.Object with private; type Object_Ptr is access all Object'Class; function Create_Policy (Self : access Object; IDL_Type : CORBA.PolicyType; Value : CORBA.Any) return CORBA.Policy.Ref; function Is_A (Self : not null access Object; Logical_Type_Id : Standard.String) return Boolean; private type Object is new CORBA.Local.Object with null record; end PortableInterceptor.PolicyFactory.Impl; polyorb-2.8~20110207.orig/src/corba/portableinterceptor/polyorb-corba_p-interceptors_policies.adb0000644000175000017500000000741111750740340032520 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- POLYORB.CORBA_P.INTERCEPTORS_POLICIES -- -- -- -- B o d y -- -- -- -- Copyright (C) 2004-2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with CORBA.Policy; with PolyORB.CORBA_P.Policy_Management; package body PolyORB.CORBA_P.Interceptors_Policies is Registry : array (CORBA.PolicyType range 1 .. 60) of PortableInterceptor.PolicyFactory.Local_Ref; function Create_Policy (The_Type : CORBA.PolicyType; Value : CORBA.Any) return CORBA.Policy.Ref; ------------------- -- Create_Policy -- ------------------- function Create_Policy (The_Type : CORBA.PolicyType; Value : CORBA.Any) return CORBA.Policy.Ref is begin pragma Assert (not PortableInterceptor.PolicyFactory.Is_Null (Registry (The_Type))); return PortableInterceptor.PolicyFactory.Create_Policy (Registry (The_Type), The_Type, Value); end Create_Policy; ----------------------------- -- Register_Policy_Factory -- ----------------------------- procedure Register_Policy_Factory (IDL_Type : CORBA.PolicyType; Policy_Factory : PortableInterceptor.PolicyFactory.Local_Ref) is begin if Policy_Management.Is_Registered (IDL_Type) then CORBA.Raise_Bad_Inv_Order (CORBA.System_Exception_Members'(16, CORBA.Completed_No)); end if; Registry (IDL_Type) := Policy_Factory; Policy_Management.Register (The_Type => IDL_Type, POA_Level => True, ORB_Level => True, Thread_Level => True, Reference_Level => True, Factory => Create_Policy'Access); -- Implementation Note: we don't known real allowed levels for policy -- registered throught PortableInterceptor infrastructure, thus we -- always allow it usage on all levels. end Register_Policy_Factory; end PolyORB.CORBA_P.Interceptors_Policies; polyorb-2.8~20110207.orig/src/corba/portableinterceptor/polyorb-corba_p-interceptors.ads0000644000175000017500000000774311750740340030662 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . C O R B A _ P . I N T E R C E P T O R S -- -- -- -- S p e c -- -- -- -- Copyright (C) 2004-2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with PortableInterceptor.ClientRequestInterceptor; with PortableInterceptor.IORInterceptor; with PortableInterceptor.ORBInitializer; with PortableInterceptor.ServerRequestInterceptor; package PolyORB.CORBA_P.Interceptors is -- Client interceptors type Client_Interception_Point is (Send_Request, Send_Poll, Receive_Reply, Receive_Exception, Receive_Other); function Is_Client_Request_Interceptor_Exists (Name : String) return Boolean; procedure Add_Client_Request_Interceptor (Interceptor : PortableInterceptor.ClientRequestInterceptor.Local_Ref); -- Server interceptors type Server_Interception_Point is (Receive_Request_Service_Contexts, Receive_Request, Send_Reply, Send_Exception, Send_Other); function Is_Server_Request_Interceptor_Exists (Name : String) return Boolean; procedure Add_Server_Request_Interceptor (Interceptor : PortableInterceptor.ServerRequestInterceptor.Local_Ref); -- IOR interceptors function Is_IOR_Interceptor_Exists (Name : String) return Boolean; procedure Add_IOR_Interceptor (Interceptor : PortableInterceptor.IORInterceptor.Local_Ref); -- ORB Initializers procedure Register_ORB_Initializer (Init : PortableInterceptor.ORBInitializer.Local_Ref); -- Register Interceptor initializer object procedure Call_ORB_Initializers; -- Call pre_init and post_init operations for all registered initializers. -- XXX This is a temporary workaround, and after improvement of -- PolyORB initialization these operations must be called from ORB_init. -- procedure Pre_Init_Interceptors -- (Info : PortableInterceptor.ORBInitInfo.Local_Ref); -- -- Call Pre_Init method on all registered initializers. -- -- procedure Post_Init_Interceptors -- (Info : PortableInterceptor.ORBInitInfo.Local_Ref); -- -- Call Post_Init method on all registered initializers. end PolyORB.CORBA_P.Interceptors; polyorb-2.8~20110207.orig/src/corba/portableinterceptor/portableinterceptor-iorinterceptor-impl.ads0000644000175000017500000000576211750740340033145 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- PORTABLEINTERCEPTOR.IORINTERCEPTOR.IMPL -- -- -- -- S p e c -- -- -- -- Copyright (C) 2004-2010, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the CORBA Specification, and adapted -- -- for use with PolyORB. The copyright notice above, and the license -- -- provisions that follow apply solely to the contents neither explicitly -- -- nor implicitly specified by the CORBA Specification defined by the OMG. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with PortableInterceptor.Interceptor.Impl; package PortableInterceptor.IORInterceptor.Impl is type Object is new PortableInterceptor.Interceptor.Impl.Object with private; type Object_Ptr is access all Object'Class; procedure Establish_Components (Self : access Object; Info : PortableInterceptor.IORInfo.Local_Ref); private type Object is new PortableInterceptor.Interceptor.Impl.Object with null record; function Is_A (Self : not null access Object; Logical_Type_Id : Standard.String) return Boolean; end PortableInterceptor.IORInterceptor.Impl; polyorb-2.8~20110207.orig/src/corba/portableinterceptor/polyorb-corba_p-interceptors_slots.ads0000644000175000017500000000605011750740340032074 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . C O R B A _ P . I N T E R C E P T O R S _ S L O T S -- -- -- -- S p e c -- -- -- -- Copyright (C) 2004-2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with CORBA; with PolyORB.Annotations; with PolyORB.Sequences.Unbounded; with PortableInterceptor; package PolyORB.CORBA_P.Interceptors_Slots is type Slots_Note is new PolyORB.Annotations.Note with private; function Invalid_Slots_Note return Slots_Note; function Allocate_Slot_Id return PortableInterceptor.SlotId; function Get_Slot (Note : Slots_Note; Id : PortableInterceptor.SlotId) return CORBA.Any; procedure Set_Slot (Note : in out Slots_Note; Id : PortableInterceptor.SlotId; Data : CORBA.Any); procedure Allocate_Slots (Note : in out Slots_Note); function Is_Allocated (Note : Slots_Note) return Boolean; -- Return True if slot table is allocated. ORB_Initializer_Done : Boolean := False; private package Any_Sequences is new PolyORB.Sequences.Unbounded (CORBA.Any); type Slots_Note is new PolyORB.Annotations.Note with record Allocated : Boolean := False; Slots : Any_Sequences.Sequence; end record; end PolyORB.CORBA_P.Interceptors_Slots; ././@LongLink0000000000000000000000000000015000000000000011561 Lustar rootrootpolyorb-2.8~20110207.orig/src/corba/portableinterceptor/portableinterceptor-orbinitializer-register.adbpolyorb-2.8~20110207.orig/src/corba/portableinterceptor/portableinterceptor-orbinitializer-register.0000644000175000017500000000442411750740340033310 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- PORTABLEINTERCEPTOR.ORBINITIALIZER.REGISTER -- -- -- -- B o d y -- -- -- -- Copyright (C) 2004-2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with PolyORB.CORBA_P.Interceptors; procedure PortableInterceptor.ORBInitializer.Register (Init : PortableInterceptor.ORBInitializer.Local_Ref) is begin PolyORB.CORBA_P.Interceptors.Register_ORB_Initializer (Init); end PortableInterceptor.ORBInitializer.Register; polyorb-2.8~20110207.orig/src/corba/portableinterceptor/portableinterceptor-orbinitializer-impl.ads0000644000175000017500000000604511750740340033116 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- PORTABLEINTERCEPTOR.ORBINITIALIZER.IMPL -- -- -- -- S p e c -- -- -- -- Copyright (C) 2004-2010, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the CORBA Specification, and adapted -- -- for use with PolyORB. The copyright notice above, and the license -- -- provisions that follow apply solely to the contents neither explicitly -- -- nor implicitly specified by the CORBA Specification defined by the OMG. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with CORBA.Local; with PortableInterceptor.ORBInitInfo; package PortableInterceptor.ORBInitializer.Impl is type Object is new CORBA.Local.Object with private; type Object_Ptr is access all Object'Class; procedure Pre_Init (Self : access Object; Info : PortableInterceptor.ORBInitInfo.Local_Ref); procedure Post_Init (Self : access Object; Info : PortableInterceptor.ORBInitInfo.Local_Ref); function Is_A (Self : not null access Object; Logical_Type_Id : String) return Boolean; private type Object is new CORBA.Local.Object with null record; end PortableInterceptor.ORBInitializer.Impl; polyorb-2.8~20110207.orig/src/corba/portableinterceptor/portableinterceptor-iorinfo-impl.ads0000644000175000017500000000761711750740340031543 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O R T A B L E I N T E R C E P T O R . I O R I N F O . I M P L -- -- -- -- S p e c -- -- -- -- Copyright (C) 2004-2010, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the CORBA Specification, and adapted -- -- for use with PolyORB. The copyright notice above, and the license -- -- provisions that follow apply solely to the contents neither explicitly -- -- nor implicitly specified by the CORBA Specification defined by the OMG. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with CORBA.Local; with PolyORB.POA; package PortableInterceptor.IORInfo.Impl is type Object is new CORBA.Local.Object with private; type Object_Ptr is access all Object'Class; function Get_Effective_Policy (Self : access Object; IDL_Type : CORBA.PolicyType) return CORBA.Policy.Ref; procedure Add_IOR_Component (Self : access Object; A_Component : IOP.TaggedComponent); procedure Add_IOR_Component_To_Profile (Self : access Object; A_Component : IOP.TaggedComponent; Profile_Id : IOP.ProfileId); function Get_Manager_Id (Self : access Object) return AdapterManagerId; function Get_State (Self : access Object) return AdapterState; -- function Get_Adapter_Template -- (Self : access Object) -- return ObjectReferenceTemplate.Abstract_Value_Ref; -- -- function Get_Current_Factory -- (Self : access Object) -- return ObjectReferenceFactory.Abstract_Value_Ref; -- -- procedure Set_Current_Factory -- (Self : access Object; -- To : ObjectReferenceFactory.Abstract_Value_Ref); procedure Init (Self : access Object; POA : PolyORB.POA.Obj_Adapter_Access); -- Internal subprogram for initial initialization. private type Object is new CORBA.Local.Object with record POA : PolyORB.POA.Obj_Adapter_Access; end record; function Is_A (Self : not null access Object; Logical_Type_Id : Standard.String) return Boolean; end PortableInterceptor.IORInfo.Impl; polyorb-2.8~20110207.orig/src/corba/portableinterceptor/portableinterceptor-current-impl.adb0000644000175000017500000001334511750740340031532 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O R T A B L E I N T E R C E P T O R . C U R R E N T . I M P L -- -- -- -- B o d y -- -- -- -- Copyright (C) 2004-2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with PolyORB.CORBA_P.Initial_References; with PolyORB.CORBA_P.Interceptors_Slots; with PolyORB.Annotations; with PolyORB.Tasking.Threads.Annotations; with PolyORB.Initialization; with PolyORB.Smart_Pointers; with PolyORB.Utils.Strings.Lists; package body PortableInterceptor.Current.Impl is use PolyORB.Annotations; use PolyORB.CORBA_P.Interceptors_Slots; use PolyORB.Tasking.Threads.Annotations; function Create return CORBA.Object.Ref; procedure Deferred_Initialization; ------------ -- Create -- ------------ function Create return CORBA.Object.Ref is Result : Local_Ref; Current : constant PolyORB.Smart_Pointers.Entity_Ptr := new Impl.Object; begin Set (Result, Current); return CORBA.Object.Ref (Result); end Create; ----------------------------- -- Deferred_Initialization -- ----------------------------- procedure Deferred_Initialization is begin PolyORB.CORBA_P.Initial_References.Register_Initial_Reference ("PICurrent", Create'Access); end Deferred_Initialization; -------------- -- Get_Slot -- -------------- function Get_Slot (Self : access Object; Id : SlotId) return CORBA.Any is pragma Unreferenced (Self); Npad : Notepad_Access; Note : Slots_Note; begin if not PolyORB.CORBA_P.Interceptors_Slots.ORB_Initializer_Done then CORBA.Raise_Bad_Inv_Order (CORBA.Bad_Inv_Order_Members'(Minor => 10, Completed => CORBA.Completed_No)); end if; Npad := Get_Current_Thread_Notepad; Get_Note (Npad.all, Note, Invalid_Slots_Note); -- If the slot table is not allocated for this thread then -- allocate it if not Is_Allocated (Note) then Allocate_Slots (Note); Set_Note (Npad.all, Note); end if; return Get_Slot (Note, Id); end Get_Slot; ---------- -- Is_A -- ---------- function Is_A (Self : not null access Object; Logical_Type_Id : Standard.String) return Boolean is pragma Unreferenced (Self); begin return CORBA.Is_Equivalent (Logical_Type_Id, PortableInterceptor.Current.Repository_Id) or else CORBA.Is_Equivalent (Logical_Type_Id, "IDL:omg.org/CORBA/Current:1.0") or else CORBA.Is_Equivalent (Logical_Type_Id, "IDL:omg.org/CORBA/Object:1.0"); end Is_A; -------------- -- Set_Slot -- -------------- procedure Set_Slot (Self : access Object; Id : SlotId; Data : CORBA.Any) is pragma Unreferenced (Self); Npad : Notepad_Access; Note : Slots_Note; begin if not PolyORB.CORBA_P.Interceptors_Slots.ORB_Initializer_Done then CORBA.Raise_Bad_Inv_Order (CORBA.Bad_Inv_Order_Members'(Minor => 10, Completed => CORBA.Completed_No)); end if; Npad := Get_Current_Thread_Notepad; Get_Note (Npad.all, Note, Invalid_Slots_Note); -- If the slot table is not allocated for this thread then -- allocate it. if not Is_Allocated (Note) then Allocate_Slots (Note); end if; Set_Slot (Note, Id, Data); Set_Note (Npad.all, Note); end Set_Slot; use PolyORB.Initialization; use PolyORB.Utils.Strings; use PolyORB.Utils.Strings.Lists; begin Register_Module (Module_Info' (Name => +"portableinterceptor.current", Conflicts => Empty, Depends => +"corba.initial_references", Provides => Empty, Implicit => False, Init => Deferred_Initialization'Access, Shutdown => null)); end PortableInterceptor.Current.Impl; polyorb-2.8~20110207.orig/src/corba/portableinterceptor/portableinterceptor-interceptor-impl.ads0000644000175000017500000000563011750740340032425 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- PORTABLEINTERCEPTOR.INTERCEPTOR.IMPL -- -- -- -- S p e c -- -- -- -- Copyright (C) 2004-2010, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the CORBA Specification, and adapted -- -- for use with PolyORB. The copyright notice above, and the license -- -- provisions that follow apply solely to the contents neither explicitly -- -- nor implicitly specified by the CORBA Specification defined by the OMG. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with CORBA.Local; package PortableInterceptor.Interceptor.Impl is type Object is new CORBA.Local.Object with private; type Object_Ptr is access all Object'Class; function Get_Name (Self : access Object) return CORBA.String; procedure Destroy (Self : access Object); function Is_A (Self : not null access Object; Logical_Type_Id : Standard.String) return Boolean; private type Object is new CORBA.Local.Object with null record; end PortableInterceptor.Interceptor.Impl; ././@LongLink0000000000000000000000000000015600000000000011567 Lustar rootrootpolyorb-2.8~20110207.orig/src/corba/portableinterceptor/portableinterceptor-clientrequestinterceptor-impl.adspolyorb-2.8~20110207.orig/src/corba/portableinterceptor/portableinterceptor-clientrequestinterceptor0000644000175000017500000000702711750740340033532 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- PORTABLEINTERCEPTOR.CLIENTREQUESTINTERCEPTOR.IMPL -- -- -- -- S p e c -- -- -- -- Copyright (C) 2004-2010, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the CORBA Specification, and adapted -- -- for use with PolyORB. The copyright notice above, and the license -- -- provisions that follow apply solely to the contents neither explicitly -- -- nor implicitly specified by the CORBA Specification defined by the OMG. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with PortableInterceptor.ClientRequestInfo; with PortableInterceptor.Interceptor.Impl; package PortableInterceptor.ClientRequestInterceptor.Impl is type Object is new PortableInterceptor.Interceptor.Impl.Object with private; type Object_Ptr is access all Object'Class; procedure Send_Request (Self : access Object; RI : PortableInterceptor.ClientRequestInfo.Local_Ref); procedure Send_Poll (Self : access Object; RI : PortableInterceptor.ClientRequestInfo.Local_Ref); procedure Receive_Reply (Self : access Object; RI : PortableInterceptor.ClientRequestInfo.Local_Ref); procedure Receive_Exception (Self : access Object; RI : PortableInterceptor.ClientRequestInfo.Local_Ref); procedure Receive_Other (Self : access Object; RI : PortableInterceptor.ClientRequestInfo.Local_Ref); function Is_A (Self : not null access Object; Logical_Type_Id : Standard.String) return Boolean; private type Object is new PortableInterceptor.Interceptor.Impl.Object with null record; end PortableInterceptor.ClientRequestInterceptor.Impl; polyorb-2.8~20110207.orig/src/corba/portableinterceptor/portableinterceptor-orbinitializer-impl.adb0000644000175000017500000000610611750740340033073 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- PORTABLEINTERCEPTOR.ORBINITIALIZER.IMPL -- -- -- -- B o d y -- -- -- -- Copyright (C) 2004-2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ package body PortableInterceptor.ORBInitializer.Impl is ---------- -- Is_A -- ---------- function Is_A (Self : not null access Object; Logical_Type_Id : String) return Boolean is pragma Unreferenced (Self); begin return CORBA.Is_Equivalent (Logical_Type_Id, PortableInterceptor.ORBInitializer.Repository_Id) or else CORBA.Is_Equivalent (Logical_Type_Id, "IDL:omg.org/CORBA/Object:1.0"); end Is_A; -------------- -- Pre_Init -- -------------- procedure Pre_Init (Self : access Object; Info : PortableInterceptor.ORBInitInfo.Local_Ref) is pragma Unreferenced (Self); pragma Unreferenced (Info); begin null; end Pre_Init; --------------- -- Post_Init -- --------------- procedure Post_Init (Self : access Object; Info : PortableInterceptor.ORBInitInfo.Local_Ref) is pragma Unreferenced (Self); pragma Unreferenced (Info); begin null; end Post_Init; end PortableInterceptor.ORBInitializer.Impl; polyorb-2.8~20110207.orig/src/corba/corba-idl_sequences-helper.ads0000644000175000017500000002470511750740337024152 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- C O R B A . I D L _ S E Q U E N C E S . H E L P E R -- -- -- -- S p e c -- -- -- -- Copyright (C) 2005-2008, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the CORBA Specification, and adapted -- -- for use with PolyORB. The copyright notice above, and the license -- -- provisions that follow apply solely to the contents neither explicitly -- -- nor implicitly specified by the CORBA Specification defined by the OMG. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with PolyORB.Any; with CORBA; pragma Elaborate_All (CORBA); package CORBA.IDL_SEQUENCES.Helper is -- AnySeq sequence TC_IDL_SEQUENCE_Any : CORBA.TypeCode.Object; function From_Any (Item : CORBA.Any) return IDL_SEQUENCE_Any.Sequence; function To_Any (Item : IDL_SEQUENCE_Any.Sequence) return CORBA.Any; function Wrap (X : access IDL_SEQUENCE_Any.Sequence) return PolyORB.Any.Content'Class; TC_AnySeq : CORBA.TypeCode.Object; function From_Any (Item : CORBA.Any) return AnySeq; function To_Any (Item : AnySeq) return CORBA.Any; -- BooleanSeq sequence TC_IDL_SEQUENCE_Boolean : CORBA.TypeCode.Object; function From_Any (Item : CORBA.Any) return IDL_SEQUENCE_Boolean.Sequence; function To_Any (Item : IDL_SEQUENCE_Boolean.Sequence) return CORBA.Any; function Wrap (X : access IDL_SEQUENCE_Boolean.Sequence) return PolyORB.Any.Content'Class; TC_BooleanSeq : CORBA.TypeCode.Object; function From_Any (Item : CORBA.Any) return BooleanSeq; function To_Any (Item : BooleanSeq) return CORBA.Any; -- CharSeq sequence TC_IDL_SEQUENCE_Char : CORBA.TypeCode.Object; function From_Any (Item : CORBA.Any) return IDL_SEQUENCE_Char.Sequence; function To_Any (Item : IDL_SEQUENCE_Char.Sequence) return CORBA.Any; function Wrap (X : access IDL_SEQUENCE_Char.Sequence) return PolyORB.Any.Content'Class; TC_CharSeq : CORBA.TypeCode.Object; function From_Any (Item : CORBA.Any) return CharSeq; function To_Any (Item : CharSeq) return CORBA.Any; -- WCharSeq sequence TC_IDL_SEQUENCE_Wide_Char : CORBA.TypeCode.Object; function From_Any (Item : CORBA.Any) return IDL_SEQUENCE_Wide_Char.Sequence; function To_Any (Item : IDL_SEQUENCE_Wide_Char.Sequence) return CORBA.Any; function Wrap (X : access IDL_SEQUENCE_Wide_Char.Sequence) return PolyORB.Any.Content'Class; TC_WCharSeq : CORBA.TypeCode.Object; function From_Any (Item : CORBA.Any) return WCharSeq; function To_Any (Item : WCharSeq) return CORBA.Any; -- Octet sequence TC_IDL_SEQUENCE_Octet : CORBA.TypeCode.Object; function From_Any (Item : CORBA.Any) return IDL_SEQUENCE_Octet.Sequence; function To_Any (Item : IDL_SEQUENCE_Octet.Sequence) return CORBA.Any; function Wrap (X : access IDL_SEQUENCE_Octet.Sequence) return PolyORB.Any.Content'Class; TC_OctetSeq : CORBA.TypeCode.Object; function From_Any (Item : CORBA.Any) return OctetSeq; function To_Any (Item : OctetSeq) return CORBA.Any; -- ShortSeq sequence TC_IDL_SEQUENCE_Short : CORBA.TypeCode.Object; function From_Any (Item : CORBA.Any) return IDL_SEQUENCE_Short.Sequence; function To_Any (Item : IDL_SEQUENCE_Short.Sequence) return CORBA.Any; function Wrap (X : access IDL_SEQUENCE_Short.Sequence) return PolyORB.Any.Content'Class; TC_ShortSeq : CORBA.TypeCode.Object; function From_Any (Item : CORBA.Any) return ShortSeq; function To_Any (Item : ShortSeq) return CORBA.Any; -- UShortSeq sequence TC_IDL_SEQUENCE_Unsigned_Short : CORBA.TypeCode.Object; function From_Any (Item : CORBA.Any) return IDL_SEQUENCE_Unsigned_Short.Sequence; function To_Any (Item : IDL_SEQUENCE_Unsigned_Short.Sequence) return CORBA.Any; function Wrap (X : access IDL_SEQUENCE_Unsigned_Short.Sequence) return PolyORB.Any.Content'Class; TC_UShortSeq : CORBA.TypeCode.Object; function From_Any (Item : CORBA.Any) return UShortSeq; function To_Any (Item : UShortSeq) return CORBA.Any; -- LongSeq sequence TC_IDL_SEQUENCE_Long : CORBA.TypeCode.Object; function From_Any (Item : CORBA.Any) return IDL_SEQUENCE_Long.Sequence; function To_Any (Item : IDL_SEQUENCE_Long.Sequence) return CORBA.Any; function Wrap (X : access IDL_SEQUENCE_Long.Sequence) return PolyORB.Any.Content'Class; TC_LongSeq : CORBA.TypeCode.Object; function From_Any (Item : CORBA.Any) return LongSeq; function To_Any (Item : LongSeq) return CORBA.Any; -- ULongSeq sequence TC_IDL_SEQUENCE_Unsigned_Long : CORBA.TypeCode.Object; function From_Any (Item : CORBA.Any) return IDL_SEQUENCE_Unsigned_Long.Sequence; function To_Any (Item : IDL_SEQUENCE_Unsigned_Long.Sequence) return CORBA.Any; function Wrap (X : access IDL_SEQUENCE_Unsigned_Long.Sequence) return PolyORB.Any.Content'Class; TC_ULongSeq : CORBA.TypeCode.Object; function From_Any (Item : CORBA.Any) return ULongSeq; function To_Any (Item : ULongSeq) return CORBA.Any; -- LongLongSeq sequence TC_IDL_SEQUENCE_Long_Long : CORBA.TypeCode.Object; function From_Any (Item : CORBA.Any) return IDL_SEQUENCE_Long_Long.Sequence; function To_Any (Item : IDL_SEQUENCE_Long_Long.Sequence) return CORBA.Any; function Wrap (X : access IDL_SEQUENCE_Long_Long.Sequence) return PolyORB.Any.Content'Class; TC_LongLongSeq : CORBA.TypeCode.Object; function From_Any (Item : CORBA.Any) return LongLongSeq; function To_Any (Item : LongLongSeq) return CORBA.Any; -- UnsignedLongLongSeq sequence TC_IDL_SEQUENCE_Unsigned_Long_Long : CORBA.TypeCode.Object; function From_Any (Item : CORBA.Any) return IDL_SEQUENCE_Unsigned_Long_Long.Sequence; function To_Any (Item : IDL_SEQUENCE_Unsigned_Long_Long.Sequence) return CORBA.Any; function Wrap (X : access IDL_SEQUENCE_Unsigned_Long_Long.Sequence) return PolyORB.Any.Content'Class; TC_ULongLongSeq : CORBA.TypeCode.Object; function From_Any (Item : CORBA.Any) return ULongLongSeq; function To_Any (Item : ULongLongSeq) return CORBA.Any; -- FloatSeq sequence TC_IDL_SEQUENCE_Float : CORBA.TypeCode.Object; function From_Any (Item : CORBA.Any) return IDL_SEQUENCE_Float.Sequence; function To_Any (Item : IDL_SEQUENCE_Float.Sequence) return CORBA.Any; function Wrap (X : access IDL_SEQUENCE_Float.Sequence) return PolyORB.Any.Content'Class; TC_FloatSeq : CORBA.TypeCode.Object; function From_Any (Item : CORBA.Any) return FloatSeq; function To_Any (Item : FloatSeq) return CORBA.Any; -- DoubleSeq sequence TC_IDL_SEQUENCE_Double : CORBA.TypeCode.Object; function From_Any (Item : CORBA.Any) return IDL_SEQUENCE_Double.Sequence; function To_Any (Item : IDL_SEQUENCE_Double.Sequence) return CORBA.Any; function Wrap (X : access IDL_SEQUENCE_Double.Sequence) return PolyORB.Any.Content'Class; TC_DoubleSeq : CORBA.TypeCode.Object; function From_Any (Item : CORBA.Any) return DoubleSeq; function To_Any (Item : DoubleSeq) return CORBA.Any; -- LongDoubleSeq sequence TC_IDL_SEQUENCE_Long_Double : CORBA.TypeCode.Object; function From_Any (Item : CORBA.Any) return IDL_SEQUENCE_Long_Double.Sequence; function To_Any (Item : IDL_SEQUENCE_Long_Double.Sequence) return CORBA.Any; function Wrap (X : access IDL_SEQUENCE_Long_Double.Sequence) return PolyORB.Any.Content'Class; TC_LongDoubleSeq : CORBA.TypeCode.Object; function From_Any (Item : CORBA.Any) return LongDoubleSeq; function To_Any (Item : LongDoubleSeq) return CORBA.Any; -- StringSeq sequence TC_IDL_SEQUENCE_String : CORBA.TypeCode.Object; function From_Any (Item : CORBA.Any) return IDL_SEQUENCE_String.Sequence; function To_Any (Item : IDL_SEQUENCE_String.Sequence) return CORBA.Any; function Wrap (X : access IDL_SEQUENCE_String.Sequence) return PolyORB.Any.Content'Class; TC_StringSeq : CORBA.TypeCode.Object; function From_Any (Item : CORBA.Any) return StringSeq; function To_Any (Item : StringSeq) return CORBA.Any; -- WStringSeq sequence TC_IDL_SEQUENCE_Wide_String : CORBA.TypeCode.Object; function From_Any (Item : CORBA.Any) return IDL_SEQUENCE_Wide_String.Sequence; function To_Any (Item : IDL_SEQUENCE_Wide_String.Sequence) return CORBA.Any; function Wrap (X : access IDL_SEQUENCE_Wide_String.Sequence) return PolyORB.Any.Content'Class; TC_WStringSeq : CORBA.TypeCode.Object; function From_Any (Item : CORBA.Any) return WStringSeq; function To_Any (Item : WStringSeq) return CORBA.Any; end CORBA.IDL_SEQUENCES.Helper; polyorb-2.8~20110207.orig/src/corba/portableserver-poa.ads0000644000175000017500000003012211750740340022562 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O R T A B L E S E R V E R . P O A -- -- -- -- S p e c -- -- -- -- Copyright (C) 2001-2008, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the CORBA Specification, and adapted -- -- for use with PolyORB. The copyright notice above, and the license -- -- provisions that follow apply solely to the contents neither explicitly -- -- nor implicitly specified by the CORBA Specification defined by the OMG. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with Ada.Exceptions; with CORBA.Object; with CORBA.Policy; with PortableServer.POAManager; with PortableServer.AdapterActivator; with PortableServer.ServantManager; with PortableServer.IdAssignmentPolicy; with PortableServer.IdUniquenessPolicy; with PortableServer.ImplicitActivationPolicy; with PortableServer.LifespanPolicy; with PortableServer.RequestProcessingPolicy; with PortableServer.ServantRetentionPolicy; with PortableServer.ThreadPolicy; with PolyORB.Errors; with PolyORB.POA; package PortableServer.POA is type Local_Ref is new CORBA.Object.Ref with null record; AdapterAlreadyExists : exception; AdapterNonExistent : exception; InvalidPolicy : exception; NoServant : exception; ObjectAlreadyActive : exception; ObjectNotActive : exception; ServantAlreadyActive : exception; ServantNotActive : exception; WrongAdapter : exception; WrongPolicy : exception; -- POA creation and destruction function Create_POA (Self : Local_Ref; Adapter_Name : CORBA.String; A_POAManager : PortableServer.POAManager.Local_Ref; Policies : CORBA.Policy.PolicyList) return Local_Ref'Class; function Find_POA (Self : Local_Ref; Adapter_Name : CORBA.String; Activate_It : CORBA.Boolean) return Local_Ref'Class; procedure Destroy (Self : in out Local_Ref; Etherealize_Objects : CORBA.Boolean; Wait_For_Completion : CORBA.Boolean); -- Factories for Policy objects function Create_Thread_Policy (Value : PortableServer.ThreadPolicyValue) return PortableServer.ThreadPolicy.Ref; function Create_Lifespan_Policy (Value : PortableServer.LifespanPolicyValue) return PortableServer.LifespanPolicy.Ref; function Create_Id_Uniqueness_Policy (Value : PortableServer.IdUniquenessPolicyValue) return PortableServer.IdUniquenessPolicy.Ref; function Create_Id_Assignment_Policy (Value : PortableServer.IdAssignmentPolicyValue) return PortableServer.IdAssignmentPolicy.Ref; function Create_Implicit_Activation_Policy (Value : PortableServer.ImplicitActivationPolicyValue) return PortableServer.ImplicitActivationPolicy.Ref; function Create_Servant_Retention_Policy (Value : PortableServer.ServantRetentionPolicyValue) return PortableServer.ServantRetentionPolicy.Ref; function Create_Request_Processing_Policy (Value : PortableServer.RequestProcessingPolicyValue) return PortableServer.RequestProcessingPolicy.Ref; -- POA attributes function Get_The_Name (Self : Local_Ref) return CORBA.String; function Get_The_Parent (Self : Local_Ref) return Local_Ref'Class; function Get_The_Children (Self : Local_Ref) return POAList; function Get_The_POAManager (Self : Local_Ref) return PortableServer.POAManager.Local_Ref; function Get_The_Activator (Self : Local_Ref) return PortableServer.AdapterActivator.Ref'Class; procedure Set_The_Activator (Self : Local_Ref; To : access PortableServer.AdapterActivator.Ref'Class); -- Servant Manager registration function Get_Servant_Manager (Self : Local_Ref) return PortableServer.ServantManager.Local_Ref'Class; procedure Set_Servant_Manager (Self : Local_Ref; Imgr : PortableServer.ServantManager.Local_Ref'Class); -- operations for the USE_DEFAULT_SERVANT policy function Get_Servant (Self : Local_Ref) return Servant; procedure Set_Servant (Self : Local_Ref; P_Servant : Servant); -- object activation and deactivation function Activate_Object (Self : Local_Ref; P_Servant : Servant) return ObjectId; procedure Activate_Object_With_Id (Self : Local_Ref; Oid : ObjectId; P_Servant : Servant); procedure Deactivate_Object (Self : Local_Ref; Oid : ObjectId); -- reference creation operations function Create_Reference (Self : Local_Ref; Intf : CORBA.RepositoryId) return CORBA.Object.Ref; function Create_Reference_With_Id (Self : Local_Ref; Oid : ObjectId; Intf : CORBA.RepositoryId) return CORBA.Object.Ref; -- identity mapping operations function Servant_To_Id (Self : Local_Ref; P_Servant : Servant) return ObjectId; function Servant_To_Reference (Self : Local_Ref; P_Servant : Servant) return CORBA.Object.Ref; function Reference_To_Servant (Self : Local_Ref; Reference : CORBA.Object.Ref'Class) return Servant; function Reference_To_Id (Self : Local_Ref; Reference : CORBA.Object.Ref'Class) return ObjectId; function Id_To_Servant (Self : Local_Ref; Oid : ObjectId) return Servant; function Id_To_Reference (Self : Local_Ref; Oid : ObjectId) return CORBA.Object.Ref; ---------------------------------- -- Convert from POA_Forward Ref -- ---------------------------------- package Convert is new PortableServer.POA_Forward.Convert (Local_Ref); ---------------------------------------------- -- PortableServer.POA Exceptions Management -- ---------------------------------------------- procedure Raise_From_Error (Error : in out PolyORB.Errors.Error_Container; Message : Standard.String); -- AdapterAlreadyExists type AdapterAlreadyExists_Members is new CORBA.IDL_Exception_Members with null record; procedure Get_Members (From : Ada.Exceptions.Exception_Occurrence; To : out AdapterAlreadyExists_Members); procedure Raise_AdapterAlreadyExists (Excp_Memb : AdapterAlreadyExists_Members; Message : Standard.String := ""); pragma No_Return (Raise_AdapterAlreadyExists); -- AdapterNonExistent type AdapterNonExistent_Members is new CORBA.IDL_Exception_Members with null record; procedure Get_Members (From : Ada.Exceptions.Exception_Occurrence; To : out AdapterNonExistent_Members); procedure Raise_AdapterNonExistent (Excp_Memb : AdapterNonExistent_Members; Message : Standard.String := ""); pragma No_Return (Raise_AdapterNonExistent); -- InvalidPolicy type InvalidPolicy_Members is new CORBA.IDL_Exception_Members with record Index : CORBA.Unsigned_Short; end record; procedure Get_Members (From : Ada.Exceptions.Exception_Occurrence; To : out InvalidPolicy_Members); procedure Raise_InvalidPolicy (Excp_Memb : InvalidPolicy_Members; Message : Standard.String := ""); pragma No_Return (Raise_InvalidPolicy); -- NoServant type NoServant_Members is new CORBA.IDL_Exception_Members with null record; procedure Get_Members (From : Ada.Exceptions.Exception_Occurrence; To : out NoServant_Members); procedure Raise_NoServant (Excp_Memb : NoServant_Members; Message : Standard.String := ""); pragma No_Return (Raise_NoServant); -- ObjectAlreadyActive type ObjectAlreadyActive_Members is new CORBA.IDL_Exception_Members with null record; procedure Get_Members (From : Ada.Exceptions.Exception_Occurrence; To : out ObjectAlreadyActive_Members); procedure Raise_ObjectAlreadyActive (Excp_Memb : ObjectAlreadyActive_Members; Message : Standard.String := ""); pragma No_Return (Raise_ObjectAlreadyActive); -- ObjectNotActive type ObjectNotActive_Members is new CORBA.IDL_Exception_Members with null record; procedure Get_Members (From : Ada.Exceptions.Exception_Occurrence; To : out ObjectNotActive_Members); procedure Raise_ObjectNotActive (Excp_Memb : ObjectNotActive_Members; Message : Standard.String := ""); pragma No_Return (Raise_ObjectNotActive); -- ServantAlreadyActive type ServantAlreadyActive_Members is new CORBA.IDL_Exception_Members with null record; procedure Get_Members (From : Ada.Exceptions.Exception_Occurrence; To : out ServantAlreadyActive_Members); procedure Raise_ServantAlreadyActive (Excp_Memb : ServantAlreadyActive_Members; Message : Standard.String := ""); pragma No_Return (Raise_ServantAlreadyActive); -- ServantNotActive type ServantNotActive_Members is new CORBA.IDL_Exception_Members with null record; procedure Get_Members (From : Ada.Exceptions.Exception_Occurrence; To : out ServantNotActive_Members); procedure Raise_ServantNotActive (Excp_Memb : ServantNotActive_Members; Message : Standard.String := ""); pragma No_Return (Raise_ServantNotActive); -- WrongAdapter type WrongAdapter_Members is new CORBA.IDL_Exception_Members with null record; procedure Get_Members (From : Ada.Exceptions.Exception_Occurrence; To : out WrongAdapter_Members); procedure Raise_WrongAdapter (Excp_Memb : WrongAdapter_Members; Message : Standard.String := ""); pragma No_Return (Raise_WrongAdapter); -- WrongPolicy type WrongPolicy_Members is new CORBA.IDL_Exception_Members with null record; procedure Get_Members (From : Ada.Exceptions.Exception_Occurrence; To : out WrongPolicy_Members); procedure Raise_WrongPolicy (Excp_Memb : WrongPolicy_Members; Message : Standard.String := ""); pragma No_Return (Raise_WrongPolicy); Repository_Id : constant Standard.String := "IDL:omg.org/PortableServer/POA:1.0"; package Internals is function To_CORBA_POA (Referenced : PolyORB.POA.Obj_Adapter_Access) return Local_Ref; -- Convert a PolyORB.POA.Obj_Adapter_Access into -- a PortableServer.POA.Ref. end Internals; end PortableServer.POA; polyorb-2.8~20110207.orig/src/corba/portableserver-iduniquenesspolicy.adb0000644000175000017500000001422511750740340025724 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O R T A B L E S E R V E R . I D U N I Q U E N E S S P O L I C Y -- -- -- -- B o d y -- -- -- -- Copyright (C) 2003-2007, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with PolyORB.CORBA_P.Policy; with PolyORB.CORBA_P.Policy_Management; with PortableServer.Helper; with PolyORB.Initialization; with PolyORB.Smart_Pointers; with PolyORB.Utils.Strings; package body PortableServer.IdUniquenessPolicy is use CORBA; use CORBA.Policy; use CORBA.TypeCode; use PortableServer.Helper; use PolyORB.CORBA_P.Policy; use PolyORB.CORBA_P.Policy_Management; function Create_IdUniquenessPolicy (The_Type : CORBA.PolicyType; Value : CORBA.Any) return CORBA.Policy.Ref; ------------ -- To_Ref -- ------------ function To_Ref (The_Ref : CORBA.Object.Ref'Class) return Ref is begin if The_Ref not in CORBA.Policy.Ref'Class or else Get_Policy_Type (CORBA.Policy.Ref (The_Ref)) /= ID_UNIQUENESS_POLICY_ID then CORBA.Raise_Bad_Param (CORBA.Default_Sys_Member); end if; declare Entity : constant PolyORB.Smart_Pointers.Entity_Ptr := new Policy_Object_Type; Result : Ref; begin Set_Policy_Type (Policy_Object_Type (Entity.all), ID_UNIQUENESS_POLICY_ID); Set_Policy_Value (Policy_Object_Type (Entity.all), Get_Policy_Value (Policy_Object_Type (Entity_Of (CORBA.Policy.Ref (The_Ref)).all))); CORBA.Policy.Set (CORBA.Policy.Ref (Result), Entity); return Result; end; end To_Ref; --------------- -- Get_Value -- --------------- function Get_Value (Self : Ref) return PortableServer.IdUniquenessPolicyValue is begin return From_Any (Get_Policy_Value (Policy_Object_Type (Entity_Of (CORBA.Policy.Ref (Self)).all))); end Get_Value; ------------------------------- -- Create_IdUniquenessPolicy -- ------------------------------- function Create_IdUniquenessPolicy (The_Type : CORBA.PolicyType; Value : CORBA.Any) return CORBA.Policy.Ref is begin pragma Assert (The_Type = ID_UNIQUENESS_POLICY_ID); if Get_Type (Value) /= TC_IdUniquenessPolicyValue then Raise_PolicyError ((Reason => BAD_POLICY_TYPE)); end if; declare Position : constant CORBA.Unsigned_Long := CORBA.From_Any (CORBA.Internals.Get_Aggregate_Element (Value, CORBA.TC_Unsigned_Long, CORBA.Unsigned_Long (0))); begin if Position > IdUniquenessPolicyValue'Pos (IdUniquenessPolicyValue'Last) then Raise_PolicyError ((Reason => BAD_POLICY_VALUE)); end if; end; declare Result : CORBA.Policy.Ref; Entity : constant PolyORB.Smart_Pointers.Entity_Ptr := new Policy_Object_Type; begin Set_Policy_Type (Policy_Object_Type (Entity.all), The_Type); Set_Policy_Value (Policy_Object_Type (Entity.all), Value); CORBA.Policy.Set (Result, Entity); return Result; end; end Create_IdUniquenessPolicy; ----------------------------- -- Deferred_Initialization -- ----------------------------- procedure Deferred_Initialization; procedure Deferred_Initialization is begin Register (The_Type => ID_UNIQUENESS_POLICY_ID, POA_Level => True, Factory => Create_IdUniquenessPolicy'Access, System_Default => Create_IdUniquenessPolicy (ID_UNIQUENESS_POLICY_ID, To_Any (UNIQUE_ID))); end Deferred_Initialization; use PolyORB.Initialization; use PolyORB.Initialization.String_Lists; use PolyORB.Utils.Strings; begin Register_Module (Module_Info' (Name => +"portableserver.iduniquenesspolicy", Conflicts => Empty, Depends => +"PortableServer.Helper", Provides => Empty, Implicit => False, Init => Deferred_Initialization'Access, Shutdown => null)); end PortableServer.IdUniquenessPolicy; polyorb-2.8~20110207.orig/src/corba/corba-policycurrent.adb0000644000175000017500000001413611750740337022730 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- C O R B A . P O L I C Y C U R R E N T -- -- -- -- B o d y -- -- -- -- Copyright (C) 2004-2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with CORBA.Object; with PolyORB.Annotations; with PolyORB.CORBA_P.Initial_References; with PolyORB.CORBA_P.Policy_Management; with PolyORB.Initialization; with PolyORB.Smart_Pointers; with PolyORB.Tasking.Threads.Annotations; with PolyORB.Utils.Strings; package body CORBA.PolicyCurrent is use PolyORB.Annotations; use PolyORB.CORBA_P.Policy_Management; use PolyORB.Tasking.Threads.Annotations; ---------- -- Is_A -- ---------- function Is_A (Self : not null access Object; Logical_Type_Id : Standard.String) return Boolean is pragma Unreferenced (Self); begin return CORBA.Is_Equivalent (Logical_Type_Id, "IDL:omg.org/CORBA/PolicyCurrent:1.0") or else CORBA.Is_Equivalent (Logical_Type_Id, "IDL:omg.org/CORBA/PolicyManager:1.0") or else CORBA.Is_Equivalent (Logical_Type_Id, "IDL:omg.org/CORBA/Current:1.0") or else CORBA.Is_Equivalent (Logical_Type_Id, "IDL:omg.org/CORBA/Object:1.0"); end Is_A; -------------------------- -- Get_Policy_Overrides -- -------------------------- function Get_Policy_Overrides (Self : Local_Ref; TS : CORBA.Policy.PolicyTypeSeq) return CORBA.Policy.PolicyList is begin if Is_Nil (Self) then CORBA.Raise_Inv_Objref (CORBA.Default_Sys_Member); end if; return Get_Policy_Overrides (Object_Ptr (Entity_Of (Self)), TS); end Get_Policy_Overrides; function Get_Policy_Overrides (Self : access Object; TS : CORBA.Policy.PolicyTypeSeq) return CORBA.Policy.PolicyList is pragma Unreferenced (Self); Notepad : Notepad_Access; Note : Policy_Manager_Note; begin Notepad := Get_Current_Thread_Notepad; Get_Note (Notepad.all, Note, Empty_Policy_Manager_Note); return Get_Policy_Overrides (Note.Overrides, TS); end Get_Policy_Overrides; -------------------------- -- Set_Policy_Overrides -- -------------------------- procedure Set_Policy_Overrides (Self : Local_Ref; Policies : CORBA.Policy.PolicyList; Set_Add : SetOverrideType) is begin if Is_Nil (Self) then CORBA.Raise_Inv_Objref (CORBA.Default_Sys_Member); end if; Set_Policy_Overrides (Object_Ptr (Entity_Of (Self)), Policies, Set_Add); end Set_Policy_Overrides; procedure Set_Policy_Overrides (Self : access Object; Policies : CORBA.Policy.PolicyList; Set_Add : CORBA.SetOverrideType) is pragma Unreferenced (Self); Notepad : Notepad_Access; Note : Policy_Manager_Note; Indexes : CORBA.Unsigned_Short; begin Notepad := Get_Current_Thread_Notepad; if Set_Add = ADD_OVERRIDE then Get_Note (Notepad.all, Note, Empty_Policy_Manager_Note); end if; Add_Policy_Overrides (Note.Overrides, Policies, Thread_Level); Check_Compatibility (Note.Overrides, Indexes); if Indexes /= 0 then raise Program_Error; -- XXX We must raise CORBA.InvalidPolicies exception, but it -- is not (yet) defined in CORBA package. end if; Set_Note (Notepad.all, Note); end Set_Policy_Overrides; ----------------------------- -- Deferred_Initialization -- ----------------------------- procedure Deferred_Initialization; procedure Deferred_Initialization is Ptr : constant Object_Ptr := new Object; Ref : CORBA.Object.Ref; begin CORBA.Object.Set (Ref, PolyORB.Smart_Pointers.Entity_Ptr (Ptr)); PolyORB.CORBA_P.Initial_References.Register_Initial_Reference ("PolicyCurrent", Ref); end Deferred_Initialization; use PolyORB.Initialization; use PolyORB.Initialization.String_Lists; use PolyORB.Utils.Strings; begin Register_Module (Module_Info' (Name => +"corba.policycurrent", Conflicts => Empty, Depends => +"corba.initial_references", Provides => Empty, Implicit => False, Init => Deferred_Initialization'Access, Shutdown => null)); end CORBA.PolicyCurrent; polyorb-2.8~20110207.orig/src/corba/corba-object-policies.ads0000644000175000017500000000677311750740337023132 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- C O R B A . O B J E C T . P O L I C I E S -- -- -- -- S p e c -- -- -- -- Copyright (C) 2005-2008, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the CORBA Specification, and adapted -- -- for use with PolyORB. The copyright notice above, and the license -- -- provisions that follow apply solely to the contents neither explicitly -- -- nor implicitly specified by the CORBA Specification defined by the OMG. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with CORBA.DomainManager; with CORBA.Policy; package CORBA.Object.Policies is function Get_Policy (Self : Ref; Policy_Type : PolicyType) return CORBA.Policy.Ref; function Get_Domain_Managers (Self : Ref'Class) return CORBA.DomainManager.DomainManagersList; procedure Set_Policy_Overrides (Self : Ref'Class; Policies : CORBA.Policy.PolicyList; Set_Add : SetOverrideType); function Get_Client_Policy (Self : Ref'Class; The_Type : PolicyType) return CORBA.Policy.Ref; function Get_Policy_Overrides (Self : Ref'Class; Types : CORBA.Policy.PolicyTypeSeq) return CORBA.Policy.PolicyList; procedure Validate_Connection (Self : Ref; Inconsistent_Policies : out CORBA.Policy.PolicyList; Result : out CORBA.Boolean); -- Implementation Notes: -- * Inconsistent_Policies is currently not set. -- * The actual processing of the LocateRequest message depends on -- the configuration of the GIOP personality, if it is used. end CORBA.Object.Policies; polyorb-2.8~20110207.orig/src/corba/corba-context.ads0000644000175000017500000000634611750740337021537 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- C O R B A . C O N T E X T -- -- -- -- S p e c -- -- -- -- Copyright (C) 2001-2008, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the CORBA Specification, and adapted -- -- for use with PolyORB. The copyright notice above, and the license -- -- provisions that follow apply solely to the contents neither explicitly -- -- nor implicitly specified by the CORBA Specification defined by the OMG. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with CORBA.NVList; package CORBA.Context is type Ref is private; Nil_Ref : constant Ref; procedure Set_One_Value (Self : Ref; Prop_Name : Identifier; Value : CORBA.String); procedure Set_Values (Self : Ref; Values : CORBA.NVList.Ref); procedure Get_Values (Self : Ref; Start_Scope : Identifier; This_Object : Boolean := True; Prop_Name : Identifier; Values : out CORBA.NVList.Ref); procedure Delete_Values (Self : Ref; Prop_Name : Identifier); procedure Create_Child (Self : Ref; Ctx_Name : Identifier; Child_Ctx : out Ref); procedure Delete (Self : Ref; Del_Flags : Flags); private type Ref is null record; Nil_Ref : constant Ref := (null record); end CORBA.Context; polyorb-2.8~20110207.orig/src/corba/corba-orb.ads0000644000175000017500000002050111750740337020622 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- C O R B A . O R B -- -- -- -- S p e c -- -- -- -- Copyright (C) 2001-2010, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the CORBA Specification, and adapted -- -- for use with PolyORB. The copyright notice above, and the license -- -- provisions that follow apply solely to the contents neither explicitly -- -- nor implicitly specified by the CORBA Specification defined by the OMG. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- The standard CORBA ORB interface. with CORBA.Context; with CORBA.ExceptionList; with CORBA.NVList; with CORBA.Object; with CORBA.Policy; with CORBA.Sequences.Unbounded; package CORBA.ORB is pragma Elaborate_Body; -- ORB initialisation type ORBid is new CORBA.String; package IDL_SEQUENCE_String is new CORBA.Sequences.Unbounded (CORBA.String); -- Implementation Note: the IDL-to-Ada mapping specification does -- not define the formal type for package instantiation, we retain -- CORBA.String. type Arg_List is new IDL_SEQUENCE_String.Sequence; function Command_Line_Arguments return Arg_List; procedure Init (ORB_Identifier : ORBid; Argv : in out Arg_List); -- Implementation Note: -- * the CORBA specification defines this procedure in module CORBA. -- The IDL-to-Ada mapping declares it here to avoid a circular -- dependency due to the ORBid type. -- -- * The CORBA specification states Argv is an inout parameter; -- the IDL-to-Ada mapping specification indicates it should be an -- in parameter. The IDL-to-Ada defines a default parameter, yet -- this is not allowed for in out parmaters by the Ada Reference -- Manual. PolyORB follows the semantics prescribed by the CORBA -- specification. package Octet_Sequence is new CORBA.Sequences.Unbounded (Octet); type ServiceDetail is record Service_Detail_Type : ServiceDetailType; Service_Detail : Octet_Sequence.Sequence; end record; package IDL_SEQUENCE_ServiceOption is new CORBA.Sequences.Unbounded (ServiceOption); package IDL_SEQUENCE_ServiceDetail is new CORBA.Sequences.Unbounded (ServiceDetail); type ServiceInformation is record service_options : IDL_SEQUENCE_ServiceOption.Sequence; service_details : IDL_SEQUENCE_ServiceDetail.Sequence; end record; type ObjectId is new CORBA.String; package IDL_SEQUENCE_ObjectId is new CORBA.Sequences.Unbounded (ObjectId); type ObjectIdList is new IDL_SEQUENCE_ObjectId.Sequence; InvalideName : exception; function Object_To_String (Obj : CORBA.Object.Ref'Class) return CORBA.String; -- Convert reference to IOR procedure String_To_Object (From : CORBA.String; To : in out CORBA.Object.Ref'Class); -- Dynamic Invocation related operations procedure Create_List (Count : CORBA.Long; New_List : out CORBA.NVList.Ref); -- Implementation Note: the parameter Count is only a hint. -- In this implementation, it is ignored. procedure Create_List (New_List : out CORBA.ExceptionList.Ref); -- XXX Requires CORBA.OperationDef defined in COS IR -- procedure Create_Operation_List -- (Oper : CORBA.OperationDef.Ref'Class; -- New_List : out CORBA.NVList.Object); function Get_Default_Context return CORBA.Context.Ref; -- Service information operations procedure Get_Service_Information (Service_Type : CORBA.ServiceType; Service_Information : out ServiceInformation; Returns : out CORBA.Boolean); function List_Initial_Services return ObjectIdList; -- Initial reference operations procedure Register_Initial_Reference (Identifier : ObjectId; Ref : CORBA.Object.Ref); function Resolve_Initial_References (Identifier : ObjectId) return CORBA.Object.Ref; -- Type code creation operations function Create_Alias_Tc (Id : CORBA.RepositoryId; Name : CORBA.Identifier; Original_Type : CORBA.TypeCode.Object) return CORBA.TypeCode.Object; function Create_Interface_Tc (Id : CORBA.RepositoryId; Name : CORBA.Identifier) return CORBA.TypeCode.Object; function Create_String_Tc (Bound : CORBA.Unsigned_Long) return CORBA.TypeCode.Object; function Create_Wstring_Tc (Bound : CORBA.Unsigned_Long) return CORBA.TypeCode.Object; function Create_Fixed_Tc (IDL_Digits : CORBA.Unsigned_Short; scale : CORBA.Short) return CORBA.TypeCode.Object; function Create_Sequence_Tc (Bound : CORBA.Unsigned_Long; Element_Type : CORBA.TypeCode.Object) return CORBA.TypeCode.Object; function Create_Recursive_Sequence_Tc (Bound : CORBA.Unsigned_Long; Offset : CORBA.Unsigned_Long) return CORBA.TypeCode.Object; function Create_Array_Tc (Length : CORBA.Unsigned_Long; Element_Type : CORBA.TypeCode.Object) return CORBA.TypeCode.Object; function Create_Native_Tc (Id : RepositoryId; Name : Identifier) return CORBA.TypeCode.Object; -- The following functions require CORBA.*MemberSeq sequence types -- and are therefore defined only in CORBA.ORB.TypeCode (which is -- part of the Interface Repository implementation): -- function create_struct_tc -- function create_enum_tc -- function create_exception_tc -- Thread related operations function Work_Pending return Boolean; procedure Perform_Work; procedure Run; procedure Shutdown (Wait_For_Completion : Boolean); -- Policy related operations function Create_Policy (The_Type : PolicyType; Val : Any) return CORBA.Policy.Ref; -- The following subprograms are not in CORBA spec. procedure Initialize (ORB_Name : Standard.String); -- Implementation Note: this procedure is deprecated, use -- CORBA.ORB.Init instead ------------------------------------- -- CORBA.ORB Exceptions Management -- ------------------------------------- -- InvalidName_Members type InvalidName_Members is new CORBA.IDL_Exception_Members with null record; procedure Get_Members (From : Ada.Exceptions.Exception_Occurrence; To : out InvalidName_Members); procedure Raise_InvalidName (Excp_Memb : InvalidName_Members); pragma No_Return (Raise_InvalidName); end CORBA.ORB; polyorb-2.8~20110207.orig/src/corba/polyorb-corba_p-policy_management.ads0000644000175000017500000001674111750740340025543 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . C O R B A _ P . P O L I C Y _ M A N A G E M E N T -- -- -- -- S p e c -- -- -- -- Copyright (C) 2004-2007, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with CORBA.Policy; with PolyORB.Annotations; with PolyORB.Errors; package PolyORB.CORBA_P.Policy_Management is type Policy_List is array (CORBA.PolicyType range 1 .. 60) of CORBA.Policy.Ref; type Policy_Manager_Note is new Annotations.Note with record Overrides : Policy_List; end record; Empty_Policy_Manager_Note : constant Policy_Manager_Note; Null_Policy : CORBA.Policy.Ref; type Policy_Override_Level is (POA_Level, Domain_Level, ORB_Level, Thread_Level, Reference_Level); -- Level of policy overrides type Policy_Factory is access function (IDL_Type : CORBA.PolicyType; Value : CORBA.Any) return CORBA.Policy.Ref; -- Factory function may raise CORBA::PolicyError exception with -- BAD_POLICY_TYPE, BAD_POLICY_VALUE and UNSUPPORTED_POLICY_VALUE reasons. function Is_Registered (The_Type : CORBA.PolicyType) return Boolean; -- Return True iff policy have been registered function Get_Policy_Factory (The_Type : CORBA.PolicyType) return Policy_Factory; -- Return policy factory function Is_POA_Policy (The_Type : CORBA.PolicyType) return Boolean; -- Return True iff The_Type is a POA level policy function Is_Domain_Policy (The_Type : CORBA.PolicyType) return Boolean; -- Return True iff The_Type is a Domain level policy function Is_ORB_Policy (The_Type : CORBA.PolicyType) return Boolean; -- Return True iff The_Type is an ORB level policy function Is_Thread_Policy (The_Type : CORBA.PolicyType) return Boolean; -- Return True iff The_Type is a thread level policy function Is_Reference_Policy (The_Type : CORBA.PolicyType) return Boolean; -- Return True iff The_Type is an object reference policy function Policy_System_Default_Value (The_Type : CORBA.PolicyType) return CORBA.Policy.Ref; -- Return system default value for given policy type procedure Add_Policy_Overrides (To : in out Policy_List; Policies : CORBA.Policy.PolicyList; Level : Policy_Override_Level); -- Add policy overrides to exists policies. -- Raise BAD_PARAM with Minor code 30 iff Policies contents two -- policies of the same type. -- Raise NO_PERMISSION system exception iff policy override is not -- allowed at given level. function Get_Policy_Overrides (From : Policy_List; TS : CORBA.Policy.PolicyTypeSeq) return CORBA.Policy.PolicyList; -- Return the list of overriden policies for requested policy -- types. Return all overriden policies if policy type sequence -- is empty. If there is no overriden policies then return empty list. procedure Check_Compatibility (Policies : Policy_List; Indexes : out CORBA.Unsigned_Short); -- Check compatibility of policies, defined in Policies list. -- If the incompatibility check failed then Indexes contain the -- index of the first incompatible policy. -- XXX After the implementation of CORBA::InvalidPolicies exception, -- Indexes will be a sequence of incompatible policies indexes. type Compatibility_Check_Proc is access procedure (The_Policy : CORBA.Policy.Ref; Policies : Policy_List; Indexes : out CORBA.Unsigned_Short); -- XXX Indexes type must be replaced by sequence after -- the implementation of CORBA.InvalidPolicies exception is done. type Reconciliation_Proc is access procedure (Server_Policy : CORBA.Policy.Ref; Client_Policy : CORBA.Policy.Ref; Result_Policy : out CORBA.Policy.Ref; Error : in out Errors.Error_Container); procedure Register (The_Type : CORBA.PolicyType; POA_Level : Boolean := False; ORB_Level : Boolean := False; Thread_Level : Boolean := False; Reference_Level : Boolean := False; Domain_Level : Boolean := False; Factory : Policy_Factory := null; Compatibility_Check : Compatibility_Check_Proc := null; Reconciliation : Reconciliation_Proc := null; System_Default : CORBA.Policy.Ref := Null_Policy); -- Register CORBA Policy and define allowed policy usage. -- - The_Type : policy id -- - POA_Level : policy is allowed at POA level -- - Domain_Level : policy is allowed at Domain level -- - ORB_Level : policy is allowed at ORB level -- - Thread_Level : policy is allowed at thread level -- - Reference_Level : policy is allowed at object reference level -- - Factory : policy factory -- - Compatibility_Check : subprogram used to check policy -- compatibility with over policies at same level -- - Reconciliation : subprogram used to perform policy -- reconciliation for policies defined at both -- client and server levels -- - Default : system default value; may be null reference -- Exception helpers procedure Raise_PolicyError (Members : CORBA.PolicyError_Members); pragma No_Return (Raise_PolicyError); private Empty_Policy_Manager_Note : constant Policy_Manager_Note := (Annotations.Note with Overrides => (others => Null_Policy)); end PolyORB.CORBA_P.Policy_Management; polyorb-2.8~20110207.orig/src/corba/corba-exceptionlist.adb0000644000175000017500000001102011750740337022705 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- C O R B A . E X C E P T I O N L I S T -- -- -- -- B o d y -- -- -- -- Copyright (C) 2001-2007, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ package body CORBA.ExceptionList is package body Internals is -------------------- -- To_PolyORB_Ref -- -------------------- function To_PolyORB_Ref (Self : Ref) return PolyORB.Any.ExceptionList.Ref is Result : PolyORB.Any.ExceptionList.Ref; begin PolyORB.Any.ExceptionList.Set (Result, Entity_Of (Self)); return Result; end To_PolyORB_Ref; ------------------ -- To_CORBA_Ref -- ------------------ function To_CORBA_Ref (Self : PolyORB.Any.ExceptionList.Ref) return Ref is Result : Ref; begin Set (Result, PolyORB.Any.ExceptionList.Entity_Of (Self)); return Result; end To_CORBA_Ref; end Internals; --------- -- "+" -- --------- function "+" (Self : Ref) return PolyORB.Any.ExceptionList.Ref renames Internals.To_PolyORB_Ref; function "+" (Self : PolyORB.Any.ExceptionList.Ref) return Ref renames Internals.To_CORBA_Ref; use PolyORB.Any.ExceptionList; --------------- -- Get_Count -- --------------- function Get_Count (Self : Ref) return CORBA.Unsigned_Long is begin return CORBA.Unsigned_Long (Get_Count (+Self)); end Get_Count; --------- -- Add -- --------- procedure Add (Self : Ref; Exc : CORBA.TypeCode.Object) is begin Add (+Self, CORBA.TypeCode.Internals.To_PolyORB_Object (Exc)); end Add; ---------- -- Item -- ---------- function Item (Self : Ref; Index : CORBA.Unsigned_Long) return CORBA.TypeCode.Object is begin return CORBA.TypeCode.Internals.To_CORBA_Object (Item (+Self, PolyORB.Types.Unsigned_Long (Index))); end Item; ------------ -- Remove -- ------------ procedure Remove (Self : Ref; Index : CORBA.Unsigned_Long) is begin Remove (+Self, PolyORB.Types.Unsigned_Long (Index)); end Remove; ----------------- -- Create_List -- ----------------- procedure Create_List (Self : out Ref) is Result : PolyORB.Any.ExceptionList.Ref; begin Create_List (Result); Self := +Result; end Create_List; ------------------------- -- Search_Exception_Id -- ------------------------- function Search_Exception_Id (Self : Ref; Name : CORBA.RepositoryId) return CORBA.Unsigned_Long is begin return CORBA.Unsigned_Long (Search_Exception_Id (+Self, PolyORB.Types.String (Name))); end Search_Exception_Id; end CORBA.ExceptionList; polyorb-2.8~20110207.orig/src/corba/corba-policymanager.adb0000644000175000017500000001411411750740340022646 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- C O R B A . P O L I C Y M A N A G E R -- -- -- -- B o d y -- -- -- -- Copyright (C) 2004-2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with PolyORB.Annotations; with PolyORB.CORBA_P.Initial_References; with PolyORB.CORBA_P.Policy_Management; with PolyORB.Initialization; with PolyORB.ORB; with PolyORB.Setup; with PolyORB.Smart_Pointers; with PolyORB.Utils.Strings; package body CORBA.PolicyManager is use PolyORB.Annotations; use PolyORB.CORBA_P.Policy_Management; use PolyORB.Setup; use PolyORB.Tasking.Mutexes; ---------- -- Is_A -- ---------- function Is_A (Self : not null access Object; Logical_Type_Id : Standard.String) return Boolean is pragma Unreferenced (Self); begin return CORBA.Is_Equivalent (Logical_Type_Id, "IDL:omg.org/CORBA/PolicyManager:1.0") or else CORBA.Is_Equivalent (Logical_Type_Id, "IDL:omg.org/CORBA/Object:1.0"); end Is_A; -------------------------- -- Get_Policy_Overrides -- -------------------------- function Get_Policy_Overrides (Self : Local_Ref; TS : CORBA.Policy.PolicyTypeSeq) return CORBA.Policy.PolicyList is begin if Is_Nil (Self) then CORBA.Raise_Inv_Objref (CORBA.Default_Sys_Member); end if; return Get_Policy_Overrides (Object_Ptr (Entity_Of (Self)), TS); end Get_Policy_Overrides; function Get_Policy_Overrides (Self : access Object; TS : CORBA.Policy.PolicyTypeSeq) return CORBA.Policy.PolicyList is Npad : Notepad_Access; Note : Policy_Manager_Note; Result : CORBA.Policy.PolicyList; begin Enter (Self.Lock); Npad := PolyORB.ORB.Notepad_Of (The_ORB); Get_Note (Npad.all, Note, Empty_Policy_Manager_Note); Result := Get_Policy_Overrides (Note.Overrides, TS); Leave (Self.Lock); return Result; end Get_Policy_Overrides; -------------------------- -- Set_Policy_Overrides -- -------------------------- procedure Set_Policy_Overrides (Self : Local_Ref; Policies : CORBA.Policy.PolicyList; Set_Add : SetOverrideType) is begin if Is_Nil (Self) then CORBA.Raise_Inv_Objref (CORBA.Default_Sys_Member); end if; Set_Policy_Overrides (Object_Ptr (Entity_Of (Self)), Policies, Set_Add); end Set_Policy_Overrides; procedure Set_Policy_Overrides (Self : access Object; Policies : CORBA.Policy.PolicyList; Set_Add : CORBA.SetOverrideType) is Npad : Notepad_Access; Note : Policy_Manager_Note; Indexes : CORBA.Unsigned_Short; begin Enter (Self.Lock); Npad := PolyORB.ORB.Notepad_Of (The_ORB); if Set_Add = ADD_OVERRIDE then Get_Note (Npad.all, Note, Empty_Policy_Manager_Note); end if; Add_Policy_Overrides (Note.Overrides, Policies, ORB_Level); Check_Compatibility (Note.Overrides, Indexes); if Indexes /= 0 then raise Program_Error; -- XXX should raise the CORBA.InvalidPolicies exception end if; Set_Note (Npad.all, Note); Leave (Self.Lock); exception when others => Leave (Self.Lock); raise; end Set_Policy_Overrides; ----------------------------- -- Deferred_Initialization -- ----------------------------- procedure Deferred_Initialization; procedure Deferred_Initialization is PM_Object : constant Object_Ptr := new Object; Ref : CORBA.Object.Ref; begin Create (PM_Object.Lock); CORBA.Object.Set (Ref, PolyORB.Smart_Pointers.Entity_Ptr (PM_Object)); PolyORB.CORBA_P.Initial_References.Register_Initial_Reference ("ORBPolicyManager", Ref); -- There is at most one ORBPolicyManager per partition end Deferred_Initialization; use PolyORB.Initialization; use PolyORB.Initialization.String_Lists; use PolyORB.Utils.Strings; begin Register_Module (Module_Info' (Name => +"corba.policymanager", Conflicts => Empty, Depends => +"corba.initial_references", Provides => Empty, Implicit => False, Init => Deferred_Initialization'Access, Shutdown => null)); end CORBA.PolicyManager; polyorb-2.8~20110207.orig/src/corba/corba-helper.adb0000644000175000017500000002061411750740337021303 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- C O R B A . H E L P E R -- -- -- -- B o d y -- -- -- -- Copyright (C) 2002-2007, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with PolyORB.Initialization; with PolyORB.Utils.Strings; package body CORBA.Helper is ---------------------- -- TC_Repository_Id -- ---------------------- TC_RepositoryId_Cache : CORBA.TypeCode.Object; function TC_RepositoryId return CORBA.TypeCode.Object is begin return TC_RepositoryId_Cache; end TC_RepositoryId; -------------- -- From_Any -- -------------- function From_Any (Item : CORBA.Any) return CORBA.RepositoryId is Result : constant CORBA.String := CORBA.From_Any (Item); begin return CORBA.RepositoryId (Result); end From_Any; ------------ -- To_Any -- ------------ function To_Any (Item : CORBA.RepositoryId) return CORBA.Any is Result : CORBA.Any := CORBA.To_Any (CORBA.String (Item)); begin CORBA.Internals.Set_Type (Result, TC_RepositoryId); return Result; end To_Any; ------------------- -- TC_Identifier -- ------------------- TC_Identifier_Cache : CORBA.TypeCode.Object; function TC_Identifier return CORBA.TypeCode.Object is begin return TC_Identifier_Cache; end TC_Identifier; -------------- -- From_Any -- -------------- function From_Any (Item : CORBA.Any) return CORBA.Identifier is Result : constant CORBA.String := CORBA.From_Any (Item); begin return CORBA.Identifier (Result); end From_Any; ------------ -- To_Any -- ------------ function To_Any (Item : CORBA.Identifier) return CORBA.Any is Result : CORBA.Any := CORBA.To_Any (CORBA.String (Item)); begin CORBA.Internals.Set_Type (Result, TC_Identifier); return Result; end To_Any; ------------------- -- TC_ScopedName -- ------------------- TC_ScopedName_Cache : CORBA.TypeCode.Object; function TC_ScopedName return CORBA.TypeCode.Object is begin return TC_ScopedName_Cache; end TC_ScopedName; -------------- -- From_Any -- -------------- function From_Any (Item : CORBA.Any) return CORBA.ScopedName is Result : constant CORBA.String := CORBA.From_Any (Item); begin return CORBA.ScopedName (Result); end From_Any; ------------ -- To_Any -- ------------ function To_Any (Item : CORBA.ScopedName) return CORBA.Any is Result : CORBA.Any := CORBA.To_Any (CORBA.String (Item)); begin CORBA.Internals.Set_Type (Result, TC_ScopedName); return Result; end To_Any; ------------------- -- TC_Visibility -- ------------------- TC_Visibility_Cache : CORBA.TypeCode.Object; function TC_Visibility return CORBA.TypeCode.Object is begin return TC_Visibility_Cache; end TC_Visibility; -------------- -- From_Any -- -------------- function From_Any (Item : CORBA.Any) return CORBA.Visibility is Result : constant CORBA.Short := CORBA.From_Any (Item); begin return CORBA.Visibility (Result); end From_Any; ------------ -- To_Any -- ------------ function To_Any (Item : CORBA.Visibility) return CORBA.Any is Result : CORBA.Any := CORBA.To_Any (CORBA.Short (Item)); begin CORBA.Internals.Set_Type (Result, TC_Visibility); return Result; end To_Any; ------------------- -- TC_PolicyType -- ------------------- TC_PolicyType_Cache : CORBA.TypeCode.Object; function TC_PolicyType return CORBA.TypeCode.Object is begin return TC_PolicyType_Cache; end TC_PolicyType; -------------- -- From_Any -- -------------- function From_Any (Item : CORBA.Any) return CORBA.PolicyType is Result : constant CORBA.Unsigned_Long := CORBA.From_Any (Item); begin return CORBA.PolicyType (Result); end From_Any; ------------ -- To_Any -- ------------ function To_Any (Item : CORBA.PolicyType) return CORBA.Any is Result : CORBA.Any := CORBA.To_Any (CORBA.Unsigned_Long (Item)); begin CORBA.Internals.Set_Type (Result, TC_PolicyType); return Result; end To_Any; ---------------- -- Initialize -- ---------------- procedure Initialize; procedure Initialize is use CORBA.TypeCode; function Build_TC_Alias_String (Name : Standard.String) return CORBA.TypeCode.Object; -- Build a typecode for type Name which is an alias of CORBA::String function Build_TC_Alias_String (Name : Standard.String) return CORBA.TypeCode.Object is begin return CORBA.TypeCode.Internals.Build_Alias_TC (Name => To_CORBA_String (Name), Id => To_CORBA_String ("IDL:omg.org/CORBA/" & Name & ":1.0"), Parent => CORBA.TC_String); end Build_TC_Alias_String; begin TC_RepositoryId_Cache := Build_TC_Alias_String ("RepositoryId"); CORBA.TypeCode.Internals.Disable_Reference_Counting (TC_RepositoryId_Cache); TC_Identifier_Cache := Build_TC_Alias_String ("Identifier"); CORBA.TypeCode.Internals.Disable_Reference_Counting (TC_Identifier_Cache); TC_ScopedName_Cache := Build_TC_Alias_String ("ScopedName"); CORBA.TypeCode.Internals.Disable_Reference_Counting (TC_ScopedName_Cache); declare Name : constant CORBA.String := CORBA.To_CORBA_String ("Visibility"); Id : constant CORBA.String := CORBA.To_CORBA_String ("IDL:omg.org/CORBA/Visibility:1.0"); begin TC_Visibility_Cache := CORBA.TypeCode.Internals.Build_Alias_TC (Name => Name, Id => Id, Parent => CORBA.TC_Short); CORBA.TypeCode.Internals.Disable_Reference_Counting (TC_Visibility_Cache); end; declare Name : constant CORBA.String := CORBA.To_CORBA_String ("PolicyType"); Id : constant CORBA.String := CORBA.To_CORBA_String ("IDL:CORBA/PolicyType:1.0"); begin TC_PolicyType_Cache := CORBA.TypeCode.Internals.Build_Alias_TC (Name => Name, Id => Id, Parent => CORBA.TC_Unsigned_Long); CORBA.TypeCode.Internals.Disable_Reference_Counting (TC_PolicyType_Cache); end; end Initialize; use PolyORB.Initialization; use PolyORB.Initialization.String_Lists; use PolyORB.Utils.Strings; begin Register_Module (Module_Info' (Name => +"corba.helper", Conflicts => Empty, Depends => +"corba" & "any", Provides => Empty, Implicit => False, Init => Initialize'Access, Shutdown => null)); end CORBA.Helper; polyorb-2.8~20110207.orig/src/corba/corba-impl.ads0000644000175000017500000000777611750740337021024 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- C O R B A . I M P L -- -- -- -- S p e c -- -- -- -- Copyright (C) 2001-2010, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the CORBA Specification, and adapted -- -- for use with PolyORB. The copyright notice above, and the license -- -- provisions that follow apply solely to the contents neither explicitly -- -- nor implicitly specified by the CORBA Specification defined by the OMG. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ pragma Ada_2005; with PolyORB.Requests; with PolyORB.Servants; with PolyORB.Smart_Pointers; with PolyORB.Smart_Pointers.Controlled_Entities; package CORBA.Impl is pragma Elaborate_Body; package PSPCE renames PolyORB.Smart_Pointers.Controlled_Entities; type Object is abstract new PSPCE.Entity with private; subtype Object_Ptr is PolyORB.Smart_Pointers.Entity_Ptr; -- Object_Ptr is the return type of CORBA.AbstractBase.Object_Of. -- It may either designate an actual local object (CORBA.Impl.Object'Class) -- or a surrogate thereof. function Execute_Servant (Self : not null access Object; Req : PolyORB.Requests.Request_Access) return Boolean; function To_PolyORB_Servant (S : access Object) return PolyORB.Servants.Servant_Access; package Internals is -- Internal implementation subprograms. These shall not be -- used outside of PolyORB. function To_CORBA_Servant (S : PolyORB.Servants.Servant_Access) return Object_Ptr; end Internals; private type Implementation (As_Object : access Object'Class) is new PolyORB.Servants.Servant with null record; -- The CORBA personality is based on the Portable Object Adapter. overriding function Execute_Servant (Self : not null access Implementation; Req : PolyORB.Requests.Request_Access) return Boolean; type Object is abstract new PSPCE.Entity with record Neutral_View : aliased Implementation (Object'Access); -- The PolyORB (personality-neutral) view of this servant. -- See also PolyORB.Minimal_Servant. end record; end CORBA.Impl; polyorb-2.8~20110207.orig/src/corba/corba-serverrequest.adb0000644000175000017500000001247611750740340022744 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- C O R B A . S E R V E R R E Q U E S T -- -- -- -- B o d y -- -- -- -- Copyright (C) 2001-2008, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- Mapping for the standard ServerRequest interface with PolyORB.Any.NVList; with PolyORB.CORBA_P.Exceptions; with PolyORB.CORBA_P.Interceptors_Hooks; with PolyORB.Log; with PolyORB.Errors; package body CORBA.ServerRequest is use PolyORB.CORBA_P.Interceptors_Hooks; use PolyORB.Log; package L is new PolyORB.Log.Facility_Log ("corba.serverrequest"); procedure O (Message : Standard.String; Level : Log_Level := Debug) renames L.Output; function C (Level : Log_Level := Debug) return Boolean renames L.Enabled; --------------- -- Operation -- --------------- function Operation (O : Object) return Identifier is begin return To_CORBA_String (O.Operation.all); end Operation; --------------- -- Arguments -- --------------- procedure Arguments (O : access Object; NV : in out NVList.Ref) is use PolyORB.Errors; PolyORB_Args : PolyORB.Any.NVList.Ref := CORBA.NVList.Internals.To_PolyORB_Ref (NV); Error : Error_Container; begin PolyORB.Requests.Arguments (PolyORB.Requests.Request_Access (O), PolyORB_Args, Error); if Found (Error) then PolyORB.CORBA_P.Exceptions.Raise_From_Error (Error); end if; NV := CORBA.NVList.Internals.To_CORBA_Ref (PolyORB_Args); if Server_Intermediate /= null then Server_Intermediate (PolyORB.Requests.Request_Access (O), True); end if; end Arguments; ---------------- -- Set_Result -- ---------------- procedure Set_Result (O : access Object; Val : Any) is use PolyORB.Errors; Error : Error_Container; begin -- Need to copy the Any value here, because it may be living on the -- caller's stack. PolyORB.Requests.Set_Result (PolyORB.Requests.Request_Access (O), PolyORB.Any.Copy_Any (PolyORB.Any.Any (Val)), Error); if Found (Error) then PolyORB.CORBA_P.Exceptions.Raise_From_Error (Error); end if; end Set_Result; ------------------- -- Set_Exception -- ------------------- procedure Set_Exception (Obj : access Object; Val : Any) is use PolyORB.Any; use PolyORB.Any.TypeCode; begin pragma Debug (C, O ("Server notifies exception: " & Image (Val))); if Kind (Get_Type (Val)) /= PolyORB.Any.Tk_Except then declare use PolyORB.Errors; Error : Error_Container; Member : constant System_Exception_Members := (Minor => 21, Completed => Completed_No); begin Throw (Error, Bad_Param_E, Member); PolyORB.CORBA_P.Exceptions.Raise_From_Error (Error); end; end if; -- Implementation Note: if the Any denotes an unlisted user -- exception, the CORBA specifications (8.3.1) manadate that -- -- 1. the server receives a BAD_PARAM system exception, -- or -- 2. the client will receive an UNKNOWN exception. -- -- 1. cannot be asserted by our implementation, we retained 2. -- 2. is made on the client side, when the middleware processes -- the request. Obj.Exception_Info := PolyORB.Any.Any (Val); if Server_Intermediate /= null then Server_Intermediate (PolyORB.Requests.Request_Access (Obj), False); end if; end Set_Exception; end CORBA.ServerRequest; polyorb-2.8~20110207.orig/src/corba/portableserver.adb0000644000175000017500000003506711750740340022001 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O R T A B L E S E R V E R -- -- -- -- B o d y -- -- -- -- Copyright (C) 2001-2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with Ada.Tags; with Ada.Unchecked_Conversion; with PolyORB.CORBA_P.Names; with PolyORB.CORBA_P.Interceptors_Hooks; with PolyORB.Any; with PolyORB.Errors; with PolyORB.Exceptions; with PolyORB.Initialization; with PolyORB.Log; with PolyORB.Servants; with PolyORB.Tasking.Threads.Annotations; with PolyORB.Utils.Chained_Lists; with PolyORB.Utils.Strings; package body PortableServer is use PolyORB.Log; package L is new PolyORB.Log.Facility_Log ("portableserver"); procedure O (Message : Standard.String; Level : Log_Level := Debug) renames L.Output; function C (Level : Log_Level := Debug) return Boolean renames L.Enabled; use PolyORB.CORBA_P.Interceptors_Hooks; use PolyORB.Utils.Strings; --------------------------------------- -- Information about a skeleton unit -- --------------------------------------- type Skeleton_Info is record Type_Id : String_Ptr; Is_A : Internals.Servant_Class_Predicate; Target_Is_A : Internals.Servant_Class_Is_A_Operation; Dispatcher : Internals.Request_Dispatcher; end record; function Find_Info (For_Servant : Servant) return Skeleton_Info; package Skeleton_Lists is new PolyORB.Utils.Chained_Lists (Skeleton_Info); All_Skeletons : Skeleton_Lists.List; Skeleton_Unknown : exception; type Dispatcher_Note is new PolyORB.Annotations.Note with record Skeleton : Internals.Request_Dispatcher; end record; Null_Dispatcher_Note : constant Dispatcher_Note := (PolyORB.Annotations.Note with Skeleton => null); procedure Default_Invoke (Servant : access PSPCE.Entity'Class; Request : access PolyORB.Requests.Request; Profile : PolyORB.Binding_Data.Profile_Access); -- This is the default server side invocation handler -------------------- -- Default_Invoke -- -------------------- procedure Default_Invoke (Servant : access PSPCE.Entity'Class; Request : access PolyORB.Requests.Request; Profile : PolyORB.Binding_Data.Profile_Access) is pragma Unreferenced (Profile); begin -- Redispatch Invoke (DynamicImplementation'Class (Servant.all)'Access, Request.all'Unchecked_Access); end Default_Invoke; --------------------- -- Execute_Servant -- --------------------- function Execute_Servant (Self : not null access DynamicImplementation; Req : PolyORB.Requests.Request_Access) return Boolean is use CORBA.ServerRequest; use PolyORB.Annotations; use PolyORB.Binding_Data; use PolyORB.Errors; use PolyORB.Requests; use PolyORB.Tasking.Threads.Annotations; R : constant Request_Access := Req; P : constant Profile_Access := Req.Profile; Error : Error_Container; begin pragma Debug (C, O ("Execute_Servant: enter")); if PortableServer_Current_Registered then declare Notepad : constant Notepad_Access := Get_Current_Thread_Notepad; Save_Note : PortableServer_Current_Note; Note : constant PortableServer_Current_Note := (PolyORB.Annotations.Note with Request => R, Profile => P); begin -- Save POA Current note Get_Note (Notepad.all, Save_Note, Null_PortableServer_Current_Note); -- Set new POA Current note Set_Note (Notepad.all, Note); -- Process invocation PolyORB.CORBA_P.Interceptors_Hooks.Server_Invoke (DynamicImplementation'Class (Self.all)'Access, R, P); -- Restore original POA Current note Set_Note (Notepad.all, Save_Note); end; else -- Process invocation PolyORB.CORBA_P.Interceptors_Hooks.Server_Invoke (DynamicImplementation'Class (Self.all)'Access, R, P); end if; -- Implementation Note: As part of PortableInterceptors specifications, -- an interception point may raise an exception before Arguments is -- called. An exception may also have been raised by Arguments itself, -- in which case Arguments_Called is True and the R.Exception_Info Any -- is non-empty. We set out arguments only if no exception was raised. -- Note: At this point the stack frame of the skel has been exited and -- the shadow any's for IN mode arguments now have dangling content -- pointers. In particular this means that any call to Image -- (R.Out_Args) is likely to fail on such arguments. if R.Arguments_Called and then PolyORB.Any.Is_Empty (R.Exception_Info) then pragma Debug (C, O ("Execute_Servant: executed, setting out args")); Set_Out_Args (R, Error); if Found (Error) then raise Program_Error; -- XXX We should do something if we find a PolyORB exception end if; end if; pragma Debug (C, O ("Execute_Servant: leave")); return True; end Execute_Servant; ------------ -- Invoke -- ------------ procedure Invoke (Self : access Servant_Base; Request : CORBA.ServerRequest.Object_Ptr) is use type Internals.Request_Dispatcher; P_Servant : constant PolyORB.Servants.Servant_Access := CORBA.Impl.To_PolyORB_Servant (CORBA.Impl.Object (Servant (Self).all)'Access); Notepad : constant PolyORB.Annotations.Notepad_Access := PolyORB.Servants.Notepad_Of (P_Servant); Dispatcher : Dispatcher_Note; begin pragma Debug (C, O ("Invoke on a static skeleton: enter")); -- Information about servant's skeleton is cached in its notepad. PolyORB.Annotations.Get_Note (Notepad.all, Dispatcher, Null_Dispatcher_Note); if Dispatcher.Skeleton = null then pragma Debug (C, O ("Caching information about skeleton")); Dispatcher.Skeleton := Find_Info (Servant (Self)).Dispatcher; PolyORB.Annotations.Set_Note (Notepad.all, Dispatcher); end if; Dispatcher.Skeleton (Servant (Self), Request); pragma Debug (C, O ("Invoke on a static skeleton: leave")); end Invoke; package body Internals is ----------------- -- Get_Type_Id -- ----------------- function Get_Type_Id (For_Servant : Servant) return Standard.String is begin return Find_Info (For_Servant).Type_Id.all; exception when Skeleton_Unknown => return PolyORB.CORBA_P.Names.OMG_RepositoryId ("CORBA/OBJECT"); end Get_Type_Id; ----------------------- -- Register_Skeleton -- ----------------------- procedure Register_Skeleton (Type_Id : String; Is_A : Servant_Class_Predicate; Target_Is_A : Servant_Class_Is_A_Operation; Dispatcher : Request_Dispatcher := null) is use Skeleton_Lists; begin pragma Debug (C, O ("Register_Skeleton: Enter.")); Prepend (All_Skeletons, (Type_Id => +Type_Id, Is_A => Is_A, Target_Is_A => Target_Is_A, Dispatcher => Dispatcher)); pragma Debug (C, O ("Registered : type_id = " & Type_Id)); end Register_Skeleton; ----------------- -- Target_Is_A -- ----------------- function Target_Is_A (For_Servant : Servant; Logical_Type_Id : Standard.String) return CORBA.Boolean is begin return Find_Info (For_Servant).Target_Is_A (Logical_Type_Id); end Target_Is_A; ----------------------------------- -- Target_Most_Derived_Interface -- ----------------------------------- function Target_Most_Derived_Interface (For_Servant : Servant) return Standard.String is begin return Find_Info (For_Servant).Type_Id.all; end Target_Most_Derived_Interface; -------------------------- -- To_PolyORB_Object_Id -- -------------------------- function To_PolyORB_Object_Id (Id : ObjectId) return PolyORB.Objects.Object_Id is use CORBA.IDL_SEQUENCES.IDL_SEQUENCE_Octet; use PolyORB.Objects; Elements : Element_Array := To_Element_Array (Id); subtype Oid_Subtype is Object_Id (1 .. Elements'Length); Result : Oid_Subtype; for Result'Address use Elements'Address; pragma Import (Ada, Result); begin return Result; end To_PolyORB_Object_Id; -------------------------------- -- To_PortableServer_ObjectId -- -------------------------------- function To_PortableServer_ObjectId (Id : PolyORB.Objects.Object_Id) return ObjectId is use CORBA.IDL_SEQUENCES.IDL_SEQUENCE_Octet; subtype Elements_Subtype is Element_Array (1 .. Id'Length); Elements : Elements_Subtype; for Elements'Address use Id'Address; pragma Import (Ada, Elements); begin return To_Sequence (Elements); end To_PortableServer_ObjectId; end Internals; --------------- -- Find_Info -- --------------- function Find_Info (For_Servant : Servant) return Skeleton_Info is use Skeleton_Lists; It : Iterator := First (All_Skeletons); begin pragma Debug (C, O ("Find_Info: servant of type " & Ada.Tags.External_Tag (For_Servant'Tag))); while not Last (It) loop pragma Debug (C, O ("... skeleton id: " & Value (It).Type_Id.all)); exit when Value (It).Is_A (For_Servant); Next (It); end loop; if Last (It) then raise Skeleton_Unknown; end if; pragma Debug (C, O ("Selected skeleton of Type_Id " & Value (It).Type_Id.all)); return Value (It).all; end Find_Info; ------------------------ -- String_To_ObjectId -- ------------------------ function String_To_ObjectId (Id : String) return ObjectId is use CORBA.IDL_SEQUENCES.IDL_SEQUENCE_Octet; function To_Octet is new Ada.Unchecked_Conversion (Character, CORBA.Octet); Aux : Element_Array (Id'Range); begin for J in Aux'Range loop Aux (J) := To_Octet (Id (J)); end loop; return To_Sequence (Aux); end String_To_ObjectId; ------------------------ -- ObjectId_To_String -- ------------------------ function ObjectId_To_String (Id : ObjectId) return String is use CORBA.IDL_SEQUENCES.IDL_SEQUENCE_Octet; function To_Character is new Ada.Unchecked_Conversion (CORBA.Octet, Character); Aux : constant Element_Array := To_Element_Array (Id); Result : String (Aux'Range); begin for J in Result'Range loop Result (J) := To_Character (Aux (J)); end loop; return Result; end ObjectId_To_String; ----------------- -- Get_Members -- ----------------- procedure Get_Members (From : Ada.Exceptions.Exception_Occurrence; To : out ForwardRequest_Members) is use Ada.Exceptions; begin if Exception_Identity (From) /= ForwardRequest'Identity then CORBA.Raise_Bad_Param (CORBA.Default_Sys_Member); end if; PolyORB.Exceptions.User_Get_Members (From, To); end Get_Members; procedure Get_Members (From : Ada.Exceptions.Exception_Occurrence; To : out NotAGroupObject_Members) is use Ada.Exceptions; begin if Exception_Identity (From) /= NotAGroupObject'Identity then CORBA.Raise_Bad_Param (CORBA.Default_Sys_Member); end if; To := NotAGroupObject_Members' (CORBA.IDL_Exception_Members with null record); end Get_Members; --------------------------- -- Raise_NotAGroupObject -- --------------------------- procedure Raise_NotAGroupObject (Excp_Memb : NotAGroupObject_Members) is pragma Unreferenced (Excp_Memb); begin raise NotAGroupObject; end Raise_NotAGroupObject; ---------------- -- Initialize -- ---------------- procedure Initialize; procedure Initialize is begin PolyORB.CORBA_P.Interceptors_Hooks.Server_Invoke := Default_Invoke'Access; end Initialize; use PolyORB.Initialization; use PolyORB.Initialization.String_Lists; begin Register_Module (Module_Info' (Name => +"portableserver", Conflicts => Empty, Depends => Empty, Provides => Empty, Implicit => False, Init => Initialize'Access, Shutdown => null)); end PortableServer; polyorb-2.8~20110207.orig/src/corba/polyorb-corba_p-adapteractivator.adb0000644000175000017500000000765711750740340025372 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . C O R B A _ P . A D A P T E R A C T I V A T O R -- -- -- -- B o d y -- -- -- -- Copyright (C) 2003-2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with CORBA; package body PolyORB.CORBA_P.AdapterActivator is ------------ -- Create -- ------------ procedure Create (Self : out PPT.AdapterActivator_Access; AA : access PortableServer.AdapterActivator.Ref'Class) is Activator : constant Object_Ptr := new Object; begin Self := new CORBA_AdapterActivator; Activator.AA := AA_Ptr (AA); Set (CORBA_AdapterActivator (Self.all), PolyORB.Smart_Pointers.Entity_Ptr (Activator)); end Create; --------------------------- -- Get_Adapter_Activator -- --------------------------- function Get_Adapter_Activator (Self : CORBA_AdapterActivator) return PortableServer.AdapterActivator.Ref'Class is Activator : constant Object_Ptr := Object_Ptr (Entity_Of (Self)); begin return Activator.AA.all; end Get_Adapter_Activator; --------------------- -- Unknown_Adapter -- --------------------- procedure Unknown_Adapter (Self : access CORBA_AdapterActivator; Parent : access PPT.Obj_Adapter'Class; Name : String; Result : out Boolean; Error : in out PolyORB.Errors.Error_Container) is use PolyORB.Errors; CORBA_POA : PortableServer.POA_Forward.Ref; Activator : constant PortableServer.AdapterActivator.Ref'Class := Get_Adapter_Activator (Self.all); begin PortableServer.POA_Forward.Set (CORBA_POA, PolyORB.Smart_Pointers.Entity_Ptr (Parent)); Result := PortableServer.AdapterActivator.Unknown_Adapter (Activator, CORBA_POA, CORBA.To_CORBA_String (Name)); exception when others => Result := False; Throw (Error, Obj_Adapter_E, System_Exception_Members' (Minor => 1, Completed => Completed_No)); end Unknown_Adapter; end PolyORB.CORBA_P.AdapterActivator; polyorb-2.8~20110207.orig/src/corba/polyorb-corba_p-corbaloc.adb0000644000175000017500000000500711750740340023604 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . C O R B A _ P . C O R B A L O C -- -- -- -- B o d y -- -- -- -- Copyright (C) 2004-2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with CORBA; with PolyORB.References.Corbaloc; package body PolyORB.CORBA_P.CORBALOC is ------------------------ -- Object_To_Corbaloc -- ------------------------ function Object_To_Corbaloc (Obj : CORBA.Object.Ref'Class) return CORBA.String is begin return CORBA.To_CORBA_String (PolyORB.References.Corbaloc.Object_To_String (CORBA.Object.Internals.To_PolyORB_Ref (CORBA.Object.Ref (Obj)))); end Object_To_Corbaloc; end PolyORB.CORBA_P.CORBALOC; polyorb-2.8~20110207.orig/src/corba/portableserver-poa.adb0000644000175000017500000013562111750740340022553 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O R T A B L E S E R V E R . P O A -- -- -- -- B o d y -- -- -- -- Copyright (C) 2001-2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with CORBA.DomainManager.Helper; with CORBA.ORB; with PortableServer.Helper; with PortableServer.ServantActivator; with PortableServer.ServantLocator; with PolyORB.Annotations; with PolyORB.Binding_Data; with PolyORB.Components; with PolyORB.CORBA_P.Initial_References; with PolyORB.Exceptions; with PolyORB.Initialization; with PolyORB.Log; with PolyORB.ORB; with PolyORB.POA_Manager; with PolyORB.POA_Policies; with PolyORB.POA_Policies.Id_Assignment_Policy; with PolyORB.POA_Types; with PolyORB.References; with PolyORB.References.Binding; with PolyORB.Servants; with PolyORB.Setup; with PolyORB.Smart_Pointers; with PolyORB.Types; with PolyORB.Utils.Strings; with PolyORB.CORBA_P.AdapterActivator; with PolyORB.CORBA_P.Domain_Management; with PolyORB.CORBA_P.Exceptions; with PolyORB.CORBA_P.Interceptors_Hooks; with PolyORB.CORBA_P.POA_Config; with PolyORB.CORBA_P.Policy_Management; with PolyORB.CORBA_P.ServantActivator; with PolyORB.CORBA_P.ServantLocator; package body PortableServer.POA is use PolyORB.Errors; use PolyORB.Log; use PolyORB.POA_Types; use PortableServer.Helper; package L is new PolyORB.Log.Facility_Log ("portableserver.poa"); procedure O (Message : String; Level : Log_Level := Debug) renames L.Output; function C (Level : Log_Level := Debug) return Boolean renames L.Enabled; procedure Initialize; -- Register root POA and set it to HOLD state procedure Associate_To_Domain_Managers (P_Servant : Servant); -- Associate servant with domain managers procedure Extract_Reference_Info (Self : Local_Ref; Reference : CORBA.Object.Ref'Class; Ref_Servant : out Servant; Ref_Object_Id : out Object_Id_Access); -- Given a Reference to a local object, return its servant and object id. -- Shared code between Reference_To_Servant and Reference_To_Id. function To_POA (Self : Local_Ref) return PolyORB.POA.Obj_Adapter_Access; -- Convert a Ref to a CORBA POA to a PolyORB POA. --------------------- -- Activate_Object -- --------------------- function Activate_Object (Self : Local_Ref; P_Servant : Servant) return ObjectId is Error : PolyORB.Errors.Error_Container; POA : constant PolyORB.POA.Obj_Adapter_Access := To_POA (Self); U_Oid : PolyORB.POA_Types.Unmarshalled_Oid; begin PolyORB.POA.Activate_Object (POA, To_PolyORB_Servant (P_Servant), null, U_Oid, Error); if Found (Error) then PolyORB.CORBA_P.Exceptions.Raise_From_Error (Error); end if; Associate_To_Domain_Managers (P_Servant); declare Oid : constant PolyORB.POA_Types.Object_Id := PolyORB.POA_Types.U_Oid_To_Oid (U_Oid); begin return PortableServer.Internals.To_PortableServer_ObjectId (Oid); end; end Activate_Object; ----------------------------- -- Activate_Object_With_Id -- ----------------------------- procedure Activate_Object_With_Id (Self : Local_Ref; Oid : ObjectId; P_Servant : Servant) is Error : PolyORB.Errors.Error_Container; POA : constant PolyORB.POA.Obj_Adapter_Access := To_POA (Self); U_Oid : PolyORB.POA_Types.Unmarshalled_Oid; A_Oid : aliased PolyORB.POA_Types.Object_Id := PolyORB.POA_Types.Object_Id (PortableServer.Internals.To_PolyORB_Object_Id (Oid)); begin PolyORB.POA.Activate_Object (POA, To_PolyORB_Servant (P_Servant), A_Oid'Unchecked_Access, U_Oid, Error); if Found (Error) then PolyORB.CORBA_P.Exceptions.Raise_From_Error (Error); end if; Associate_To_Domain_Managers (P_Servant); end Activate_Object_With_Id; ---------------------------------- -- Associate_To_Domain_Managers -- ---------------------------------- procedure Associate_To_Domain_Managers (P_Servant : Servant) is use PolyORB.CORBA_P.Initial_References; Policy_Manager : constant CORBA.DomainManager.Ref := CORBA.DomainManager.Helper.To_Ref (Resolve_Initial_References ("PolyORBPolicyDomainManager")); Note : PolyORB.CORBA_P.Domain_Management.Domain_Manager_Note; begin if CORBA.DomainManager.Is_Nil (Policy_Manager) then pragma Debug (C, O ("No policy domain manager registered")); return; end if; -- Associate activated servant with domain managers. For now we just -- add policy domain manager into list of object domain managers. CORBA.DomainManager.IDL_SEQUENCE_DomainManager.Append (Note.Domain_Managers, Policy_Manager); PolyORB.Annotations.Set_Note (PolyORB.Servants.Notepad_Of (CORBA.Impl.To_PolyORB_Servant (CORBA.Impl.Object (P_Servant.all)'Access)).all, Note); pragma Debug (C, O ("Servant associated with policy domain manager")); end Associate_To_Domain_Managers; --------------------------------- -- Create_Id_Assignment_Policy -- --------------------------------- function Create_Id_Assignment_Policy (Value : PortableServer.IdAssignmentPolicyValue) return PortableServer.IdAssignmentPolicy.Ref is begin return PortableServer.IdAssignmentPolicy.To_Ref (CORBA.ORB.Create_Policy (ID_ASSIGNMENT_POLICY_ID, To_Any (Value))); end Create_Id_Assignment_Policy; --------------------------------- -- Create_Id_Uniqueness_Policy -- --------------------------------- function Create_Id_Uniqueness_Policy (Value : PortableServer.IdUniquenessPolicyValue) return PortableServer.IdUniquenessPolicy.Ref is begin return PortableServer.IdUniquenessPolicy.To_Ref (CORBA.ORB.Create_Policy (ID_UNIQUENESS_POLICY_ID, To_Any (Value))); end Create_Id_Uniqueness_Policy; --------------------------------------- -- Create_Implicit_Activation_Policy -- --------------------------------------- function Create_Implicit_Activation_Policy (Value : PortableServer.ImplicitActivationPolicyValue) return PortableServer.ImplicitActivationPolicy.Ref is begin return PortableServer.ImplicitActivationPolicy.To_Ref (CORBA.ORB.Create_Policy (IMPLICIT_ACTIVATION_POLICY_ID, To_Any (Value))); end Create_Implicit_Activation_Policy; ---------------------------- -- Create_Lifespan_Policy -- ---------------------------- function Create_Lifespan_Policy (Value : PortableServer.LifespanPolicyValue) return PortableServer.LifespanPolicy.Ref is begin return PortableServer.LifespanPolicy.To_Ref (CORBA.ORB.Create_Policy (LIFESPAN_POLICY_ID, To_Any (Value))); end Create_Lifespan_Policy; ---------------- -- Create_POA -- ---------------- function Create_POA (Self : Local_Ref; Adapter_Name : CORBA.String; A_POAManager : PortableServer.POAManager.Local_Ref; Policies : CORBA.Policy.PolicyList) return Local_Ref'Class is use type PolyORB.CORBA_P.Interceptors_Hooks.POA_Create_Handler; use type CORBA.Unsigned_Short; Res : PolyORB.POA.Obj_Adapter_Access; POA : constant PolyORB.POA.Obj_Adapter_Access := To_POA (Self); POA_Policies : PolyORB.POA_Policies.PolicyList := PolyORB.CORBA_P.POA_Config.Convert_PolicyList (Policies); Note : PolyORB.CORBA_P.Policy_Management.Policy_Manager_Note; Error : PolyORB.Errors.Error_Container; Indices : CORBA.Unsigned_Short; begin pragma Debug (C, O ("Creating POA " & CORBA.To_Standard_String (Adapter_Name))); -- Convert list of policies into policy override Note declare use PolyORB.CORBA_P.Policy_Management; The_Type : CORBA.PolicyType; begin for J in 1 .. CORBA.Policy.IDL_SEQUENCE_Policy.Length (Policies) loop The_Type := CORBA.Policy.Get_Policy_Type (CORBA.Policy.IDL_SEQUENCE_Policy.Get_Element (Policies, J)); if not Is_POA_Policy (The_Type) then PolyORB.Errors.Throw (Error, PolyORB.Errors.InvalidPolicy_E, PolyORB.Errors.InvalidPolicy_Members' (Index => PolyORB.Types.Unsigned_Short (J))); exit; end if; Note.Overrides (The_Type) := CORBA.Policy.IDL_SEQUENCE_Policy.Get_Element (Policies, J); end loop; end; if Found (Error) then PolyORB.CORBA_P.Exceptions.Raise_From_Error (Error); end if; -- Check policy compatibility PolyORB.CORBA_P.Policy_Management.Check_Compatibility (Note.Overrides, Indices); if Indices /= 0 then Raise_InvalidPolicy ((Index => Indices)); end if; -- Note: policy compability is tested by PolyORB.POA.Create_POA PolyORB.POA.Create_POA (POA, CORBA.To_String (Adapter_Name), PolyORB.POA_Manager.POAManager_Access (PortableServer.POAManager.Entity_Of (A_POAManager)), POA_Policies, Res, Error); if Found (Error) then PolyORB.CORBA_P.Exceptions.Raise_From_Error (Error); end if; PolyORB.Annotations.Set_Note (PolyORB.POA.Notepad_Of (Res).all, Note); PolyORB.POA_Policies.Policy_Lists.Deallocate (POA_Policies); if not Found (Error) then if PolyORB.CORBA_P.Interceptors_Hooks.POA_Create /= null then PolyORB.CORBA_P.Interceptors_Hooks.POA_Create (Res, Error); if Found (Error) then PolyORB.CORBA_P.Exceptions.Raise_From_Error (Error); -- XXX if Error found, destroy POA end if; end if; end if; pragma Debug (C, O ("POA created")); return Internals.To_CORBA_POA (Res); end Create_POA; ---------------------- -- Create_Reference -- ---------------------- function Create_Reference (Self : Local_Ref; Intf : CORBA.RepositoryId) return CORBA.Object.Ref is Error : PolyORB.Errors.Error_Container; POA : constant PolyORB.POA.Obj_Adapter_Access := To_POA (Self); U_Oid : PolyORB.POA_Types.Unmarshalled_Oid; begin PolyORB.POA.Create_Object_Identification (POA, null, U_Oid, Error); if Found (Error) then PolyORB.CORBA_P.Exceptions.Raise_From_Error (Error); end if; declare Oid : aliased PolyORB.POA_Types.Object_Id := PolyORB.POA_Types.U_Oid_To_Oid (U_Oid); Result : PolyORB.References.Ref; begin PolyORB.ORB.Create_Reference (PolyORB.Setup.The_ORB, Oid'Access, CORBA.To_Standard_String (Intf), Result); -- Obtain object reference. return CORBA.Object.Internals.To_CORBA_Ref (Result); end; end Create_Reference; ------------------------------ -- Create_Reference_With_Id -- ------------------------------ function Create_Reference_With_Id (Self : Local_Ref; Oid : ObjectId; Intf : CORBA.RepositoryId) return CORBA.Object.Ref is Error : PolyORB.Errors.Error_Container; POA : constant PolyORB.POA.Obj_Adapter_Access := To_POA (Self); U_Oid : PolyORB.POA_Types.Unmarshalled_Oid; OOid : Object_Id_Access := new Object_Id'(PortableServer.Internals.To_PolyORB_Object_Id (Oid)); begin PolyORB.POA.Create_Object_Identification (POA, OOid, U_Oid, Error); Free (OOid); if Found (Error) then PolyORB.CORBA_P.Exceptions.Raise_From_Error (Error); end if; declare A_Oid : aliased PolyORB.POA_Types.Object_Id := PolyORB.POA_Types.U_Oid_To_Oid (U_Oid); Result : PolyORB.References.Ref; begin PolyORB.ORB.Create_Reference (PolyORB.Setup.The_ORB, A_Oid'Access, CORBA.To_Standard_String (Intf), Result); -- Obtain object reference. return CORBA.Object.Internals.To_CORBA_Ref (Result); end; end Create_Reference_With_Id; -------------------------------------- -- Create_Request_Processing_Policy -- -------------------------------------- function Create_Request_Processing_Policy (Value : PortableServer.RequestProcessingPolicyValue) return PortableServer.RequestProcessingPolicy.Ref is begin return PortableServer.RequestProcessingPolicy.To_Ref (CORBA.ORB.Create_Policy (REQUEST_PROCESSING_POLICY_ID, To_Any (Value))); end Create_Request_Processing_Policy; ------------------------------------- -- Create_Servant_Retention_Policy -- ------------------------------------- function Create_Servant_Retention_Policy (Value : PortableServer.ServantRetentionPolicyValue) return PortableServer.ServantRetentionPolicy.Ref is begin return PortableServer.ServantRetentionPolicy.To_Ref (CORBA.ORB.Create_Policy (SERVANT_RETENTION_POLICY_ID, To_Any (Value))); end Create_Servant_Retention_Policy; -------------------------- -- Create_Thread_Policy -- -------------------------- function Create_Thread_Policy (Value : PortableServer.ThreadPolicyValue) return PortableServer.ThreadPolicy.Ref is begin return PortableServer.ThreadPolicy.To_Ref (CORBA.ORB.Create_Policy (THREAD_POLICY_ID, To_Any (Value))); end Create_Thread_Policy; ----------------------- -- Deactivate_Object -- ----------------------- procedure Deactivate_Object (Self : Local_Ref; Oid : ObjectId) is Error : PolyORB.Errors.Error_Container; POA : constant PolyORB.POA.Obj_Adapter_Access := To_POA (Self); A_Oid : aliased constant PolyORB.POA_Types.Object_Id := PolyORB.POA_Types.Object_Id (PortableServer.Internals.To_PolyORB_Object_Id (Oid)); begin PolyORB.POA.Deactivate_Object (POA, A_Oid, Error); if Found (Error) then PolyORB.CORBA_P.Exceptions.Raise_From_Error (Error); end if; end Deactivate_Object; ------------- -- Destroy -- ------------- procedure Destroy (Self : in out Local_Ref; Etherealize_Objects : CORBA.Boolean; Wait_For_Completion : CORBA.Boolean) is POA : constant PolyORB.POA.Obj_Adapter_Access := To_POA (Self); begin PolyORB.POA.Destroy (POA, PolyORB.Types.Boolean (Etherealize_Objects), PolyORB.Types.Boolean (Wait_For_Completion)); -- XXX CORBA Specifications says 'Self' should be an 'in' -- parameter; by doing so 'Self' is still a reference to an -- invalid POA --> file an issue against the spec to have Ref -- converted to an 'in out' arg... end Destroy; ---------------------------- -- Extract_Reference_Info -- ---------------------------- procedure Extract_Reference_Info (Self : Local_Ref; Reference : CORBA.Object.Ref'Class; Ref_Servant : out Servant; Ref_Object_Id : out Object_Id_Access) is use type PolyORB.Binding_Data.Profile_Access; The_Servant : PolyORB.Components.Component_Access; The_Profile : PolyORB.Binding_Data.Profile_Access; Error : Error_Container; begin pragma Debug (C, O ("Extract_Reference_Info: enter")); PolyORB.References.Binding.Bind (CORBA.Object.Internals.To_PolyORB_Ref (CORBA.Object.Ref (Reference)), PolyORB.Setup.The_ORB, (others => null), The_Servant, The_Profile, Local_Only => True, Error => Error); if Found (Error) then pragma Debug (C, O ("Extract_Reference_Info: Bind failed")); PolyORB.CORBA_P.Exceptions.Raise_From_Error (Error); end if; -- Check that the reference belongs to local ORB if The_Profile = null then Raise_WrongAdapter (WrongAdapter_Members' (CORBA.IDL_Exception_Members with null record), "reference does not belong to local ORB"); end if; -- Ensure Reference was actually built by Self Ref_Object_Id := PolyORB.Binding_Data.Get_Object_Key (The_Profile.all); declare use type PolyORB.Types.String; U_Oid : PolyORB.POA_Types.Unmarshalled_Oid; begin PolyORB.POA_Types.Oid_To_U_Oid (Ref_Object_Id.all, U_Oid, Error); if Found (Error) then pragma Debug (C, O ("Extract_Reference_Info: Oid_To_U_Oid failed")); PolyORB.CORBA_P.Exceptions.Raise_From_Error (Error); end if; if U_Oid.Creator /= To_POA (Self).Absolute_Address.all then pragma Debug (C, O ("Extract_Reference_Info: Wrong adapter")); pragma Debug (C, O (PolyORB.Types.To_Standard_String (U_Oid.Creator))); pragma Debug (C, O (To_POA (Self).Absolute_Address.all)); Raise_WrongAdapter (WrongAdapter_Members' (CORBA.IDL_Exception_Members with null record)); end if; end; Ref_Servant := Servant (CORBA.Impl.Internals.To_CORBA_Servant (PolyORB.Servants.Servant_Access (The_Servant))); pragma Debug (C, O ("Extract_Reference_Info: leave")); end Extract_Reference_Info; -------------- -- Find_POA -- -------------- function Find_POA (Self : Local_Ref; Adapter_Name : CORBA.String; Activate_It : CORBA.Boolean) return Local_Ref'Class is POA : constant PolyORB.POA.Obj_Adapter_Access := To_POA (Self); POA_Ref : PolyORB.POA.Obj_Adapter_Access; Res : Local_Ref; Error : Error_Container; begin PolyORB.POA.Find_POA (POA, CORBA.To_Standard_String (Adapter_Name), Activate_It, POA_Ref, Error); if Found (Error) then PolyORB.CORBA_P.Exceptions.Raise_From_Error (Error); end if; Res := Internals.To_CORBA_POA (POA_Ref); return Res; end Find_POA; ----------------- -- Get_Members -- ----------------- procedure Get_Members (From : Ada.Exceptions.Exception_Occurrence; To : out AdapterAlreadyExists_Members) is use Ada.Exceptions; begin if Exception_Identity (From) /= AdapterAlreadyExists'Identity then CORBA.Raise_Bad_Param (CORBA.Default_Sys_Member); end if; To := AdapterAlreadyExists_Members' (CORBA.IDL_Exception_Members with null record); end Get_Members; ----------------- -- Get_Members -- ----------------- procedure Get_Members (From : Ada.Exceptions.Exception_Occurrence; To : out AdapterNonExistent_Members) is use Ada.Exceptions; begin if Exception_Identity (From) /= AdapterNonExistent'Identity then CORBA.Raise_Bad_Param (CORBA.Default_Sys_Member); end if; To := AdapterNonExistent_Members' (CORBA.IDL_Exception_Members with null record); end Get_Members; ----------------- -- Get_Members -- ----------------- procedure Get_Members (From : Ada.Exceptions.Exception_Occurrence; To : out InvalidPolicy_Members) is use Ada.Exceptions; begin if Exception_Identity (From) /= InvalidPolicy'Identity then CORBA.Raise_Bad_Param (CORBA.Default_Sys_Member); end if; PolyORB.Exceptions.User_Get_Members (From, To); end Get_Members; ----------------- -- Get_Members -- ----------------- procedure Get_Members (From : Ada.Exceptions.Exception_Occurrence; To : out NoServant_Members) is use Ada.Exceptions; begin if Exception_Identity (From) /= NoServant'Identity then CORBA.Raise_Bad_Param (CORBA.Default_Sys_Member); end if; To := NoServant_Members' (CORBA.IDL_Exception_Members with null record); end Get_Members; ----------------- -- Get_Members -- ----------------- procedure Get_Members (From : Ada.Exceptions.Exception_Occurrence; To : out ObjectAlreadyActive_Members) is use Ada.Exceptions; begin if Exception_Identity (From) /= ObjectAlreadyActive'Identity then CORBA.Raise_Bad_Param (CORBA.Default_Sys_Member); end if; To := ObjectAlreadyActive_Members' (CORBA.IDL_Exception_Members with null record); end Get_Members; ----------------- -- Get_Members -- ----------------- procedure Get_Members (From : Ada.Exceptions.Exception_Occurrence; To : out ObjectNotActive_Members) is use Ada.Exceptions; begin if Exception_Identity (From) /= ObjectNotActive'Identity then CORBA.Raise_Bad_Param (CORBA.Default_Sys_Member); end if; To := ObjectNotActive_Members' (CORBA.IDL_Exception_Members with null record); end Get_Members; ----------------- -- Get_Members -- ----------------- procedure Get_Members (From : Ada.Exceptions.Exception_Occurrence; To : out ServantAlreadyActive_Members) is use Ada.Exceptions; begin if Exception_Identity (From) /= ServantAlreadyActive'Identity then CORBA.Raise_Bad_Param (CORBA.Default_Sys_Member); end if; To := ServantAlreadyActive_Members' (CORBA.IDL_Exception_Members with null record); end Get_Members; ----------------- -- Get_Members -- ----------------- procedure Get_Members (From : Ada.Exceptions.Exception_Occurrence; To : out ServantNotActive_Members) is use Ada.Exceptions; begin if Exception_Identity (From) /= ServantNotActive'Identity then CORBA.Raise_Bad_Param (CORBA.Default_Sys_Member); end if; To := ServantNotActive_Members' (CORBA.IDL_Exception_Members with null record); end Get_Members; ----------------- -- Get_Members -- ----------------- procedure Get_Members (From : Ada.Exceptions.Exception_Occurrence; To : out WrongAdapter_Members) is use Ada.Exceptions; begin if Exception_Identity (From) /= WrongAdapter'Identity then CORBA.Raise_Bad_Param (CORBA.Default_Sys_Member); end if; To := WrongAdapter_Members' (CORBA.IDL_Exception_Members with null record); end Get_Members; ----------------- -- Get_Members -- ----------------- procedure Get_Members (From : Ada.Exceptions.Exception_Occurrence; To : out WrongPolicy_Members) is use Ada.Exceptions; begin if Exception_Identity (From) /= WrongPolicy'Identity then CORBA.Raise_Bad_Param (CORBA.Default_Sys_Member); end if; To := WrongPolicy_Members' (CORBA.IDL_Exception_Members with null record); end Get_Members; ----------------- -- Get_Servant -- ----------------- function Get_Servant (Self : Local_Ref) return Servant is POA : constant PolyORB.POA.Obj_Adapter_Access := To_POA (Self); Error : PolyORB.Errors.Error_Container; Servant : PolyORB.Servants.Servant_Access; begin PolyORB.POA.Get_Servant (POA, Servant, Error); if Found (Error) then PolyORB.CORBA_P.Exceptions.Raise_From_Error (Error); end if; return PortableServer.Servant (CORBA.Impl.Internals.To_CORBA_Servant (Servant)); end Get_Servant; ------------------------- -- Get_Servant_Manager -- ------------------------- function Get_Servant_Manager (Self : Local_Ref) return PortableServer.ServantManager.Local_Ref'Class is use PolyORB.CORBA_P.ServantActivator; use PolyORB.CORBA_P.ServantLocator; POA : constant PolyORB.POA.Obj_Adapter_Access := To_POA (Self); Error : Error_Container; Manager : ServantManager_Access; Result : PortableServer.ServantManager.Local_Ref; begin PolyORB.POA.Get_Servant_Manager (POA, Manager, Error); if Found (Error) then PolyORB.CORBA_P.Exceptions.Raise_From_Error (Error); end if; if Manager = null then return Result; else if Manager.all in CORBA_ServantActivator'Class then return Get_Servant_Manager (CORBA_ServantActivator (Manager.all)); elsif Manager.all in CORBA_ServantLocator'Class then return Get_Servant_Manager (CORBA_ServantLocator (Manager.all)); else raise Program_Error; end if; end if; end Get_Servant_Manager; ----------------------- -- Get_The_Activator -- ----------------------- function Get_The_Activator (Self : Local_Ref) return PortableServer.AdapterActivator.Ref'Class is use PolyORB.CORBA_P.AdapterActivator; POA : constant PolyORB.POA.Obj_Adapter_Access := To_POA (Self); Result : PortableServer.AdapterActivator.Ref; begin if POA.Adapter_Activator /= null then pragma Assert (POA.Adapter_Activator.all in CORBA_AdapterActivator'Class); return Get_Adapter_Activator (CORBA_AdapterActivator (POA.Adapter_Activator.all)); end if; return Result; end Get_The_Activator; ---------------------- -- Get_The_Children -- ---------------------- function Get_The_Children (Self : Local_Ref) return POAList is use PolyORB.POA_Types.POA_Lists; use PolyORB.Smart_Pointers; use IDL_SEQUENCE_PortableServer_POA_Forward; POA : constant PolyORB.POA.Obj_Adapter_Access := To_POA (Self); Result : POAList; POA_List : PolyORB.POA_Types.POA_Lists.List; begin pragma Debug (C, O ("Get_The_Children: enter")); PolyORB.POA.Get_The_Children (POA, POA_List); declare It : Iterator := First (POA_List); begin while not Last (It) loop pragma Debug (C, O ("++")); Append (Result, Convert.To_Forward (Internals.To_CORBA_POA (PolyORB.POA.Obj_Adapter_Access (PolyORB.POA_Types.Entity_Of (Value (It).all))))); Next (It); end loop; end; Deallocate (POA_List); pragma Debug (C, O ("Get_The_Children: end")); return Result; end Get_The_Children; ------------------ -- Get_The_Name -- ------------------ function Get_The_Name (Self : Local_Ref) return CORBA.String is begin return CORBA.To_CORBA_String (To_POA (Self).Name.all); end Get_The_Name; -------------------- -- Get_The_Parent -- -------------------- function Get_The_Parent (Self : Local_Ref) return Local_Ref'Class is begin return Internals.To_CORBA_POA (PolyORB.POA.Obj_Adapter_Access (To_POA (Self).Father)); end Get_The_Parent; ------------------------ -- Get_The_POAManager -- ------------------------ function Get_The_POAManager (Self : Local_Ref) return PortableServer.POAManager.Local_Ref is use PolyORB.Smart_Pointers; use PortableServer.POAManager; Res : PortableServer.POAManager.Local_Ref; begin pragma Debug (C, O ("Get_The_POAManager: enter")); Set (Res, PolyORB.POA_Manager.Entity_Of (To_POA (Self).POA_Manager)); pragma Debug (C, O ("Get_The_POAManager: leave")); return Res; end Get_The_POAManager; --------------------- -- Id_To_Reference -- --------------------- function Id_To_Reference (Self : Local_Ref; Oid : ObjectId) return CORBA.Object.Ref is begin return Servant_To_Reference (Self, Id_To_Servant (Self, Oid)); end Id_To_Reference; ------------------- -- Id_To_Servant -- ------------------- function Id_To_Servant (Self : Local_Ref; Oid : ObjectId) return Servant is POA : constant PolyORB.POA.Obj_Adapter_Access := To_POA (Self); Error : PolyORB.Errors.Error_Container; S : PolyORB.Servants.Servant_Access; begin PolyORB.POA.Id_To_Servant (POA, PortableServer.Internals.To_PolyORB_Object_Id (Oid), S, Error); if Found (Error) then PolyORB.CORBA_P.Exceptions.Raise_From_Error (Error); end if; return Servant (CORBA.Impl.Internals.To_CORBA_Servant (S)); end Id_To_Servant; ---------------- -- Initialize -- ---------------- procedure Initialize is Root_POA : PortableServer.POA.Local_Ref; Error : PolyORB.Errors.Error_Container; begin PolyORB.CORBA_P.Exceptions.POA_Raise_From_Error := Raise_From_Error'Access; PortableServer.POA.Set (Root_POA, PolyORB.Smart_Pointers.Entity_Ptr (PolyORB.ORB.Object_Adapter (PolyORB.Setup.The_ORB))); -- By construction, Root POA must be in Hold state PolyORB.POA_Manager.Hold_Requests (PolyORB.POA_Manager.POAManager_Access (PolyORB.POA_Manager.Entity_Of (PolyORB.POA.Obj_Adapter (PolyORB.ORB.Object_Adapter (PolyORB.Setup.The_ORB).all).POA_Manager)), False, Error); CORBA.ORB.Register_Initial_Reference (CORBA.ORB.To_CORBA_String ("RootPOA"), CORBA.Object.Ref (Root_POA)); end Initialize; --------------- -- Internals -- --------------- package body Internals is ------------------ -- To_CORBA_POA -- ------------------ function To_CORBA_POA (Referenced : PolyORB.POA.Obj_Adapter_Access) return Local_Ref is Res : Local_Ref; begin Set (Res, PolyORB.Smart_Pointers.Entity_Ptr (Referenced)); return Res; end To_CORBA_POA; end Internals; -------------------------------- -- Raise_AdapterAlreadyExists -- -------------------------------- procedure Raise_AdapterAlreadyExists (Excp_Memb : AdapterAlreadyExists_Members; Message : Standard.String := "") is pragma Unreferenced (Excp_Memb); begin Ada.Exceptions.Raise_Exception (AdapterAlreadyExists'Identity, Message); end Raise_AdapterAlreadyExists; ------------------------------ -- Raise_AdapterNonExistent -- ------------------------------ procedure Raise_AdapterNonExistent (Excp_Memb : AdapterNonExistent_Members; Message : Standard.String := "") is pragma Unreferenced (Excp_Memb); begin Ada.Exceptions.Raise_Exception (AdapterNonExistent'Identity, Message); end Raise_AdapterNonExistent; ---------------------- -- Raise_From_Error -- ---------------------- procedure Raise_From_Error (Error : in out PolyORB.Errors.Error_Container; Message : Standard.String) is begin pragma Debug (C, O ("Raise_From_Error: enter")); pragma Assert (Is_Error (Error)); -- One to one mapping of PolyORB Error_Id to CORBA POA exceptions. case Error.Kind is when AdapterAlreadyExists_E => declare Member : constant AdapterAlreadyExists_Members := AdapterAlreadyExists_Members' (CORBA.IDL_Exception_Members with null record); begin Free (Error.Member); Raise_AdapterAlreadyExists (Member, Message); end; when AdapterNonExistent_E => declare Member : constant AdapterNonExistent_Members := AdapterNonExistent_Members' (CORBA.IDL_Exception_Members with null record); begin Free (Error.Member); Raise_AdapterNonExistent (Member, Message); end; when InvalidPolicy_E => declare Member : constant InvalidPolicy_Members := InvalidPolicy_Members' (CORBA.IDL_Exception_Members with Index => CORBA.Unsigned_Short (PolyORB.Errors.InvalidPolicy_Members (Error.Member.all).Index)); begin Free (Error.Member); Raise_InvalidPolicy (Member, Message); end; when NoServant_E => declare Member : constant NoServant_Members := NoServant_Members' (CORBA.IDL_Exception_Members with null record); begin Free (Error.Member); Raise_NoServant (Member, Message); end; when ObjectAlreadyActive_E => declare Member : constant ObjectAlreadyActive_Members := ObjectAlreadyActive_Members' (CORBA.IDL_Exception_Members with null record); begin Free (Error.Member); Raise_ObjectAlreadyActive (Member, Message); end; when ObjectNotActive_E => declare Member : constant ObjectNotActive_Members := ObjectNotActive_Members' (CORBA.IDL_Exception_Members with null record); begin Free (Error.Member); Raise_ObjectNotActive (Member, Message); end; when ServantAlreadyActive_E => declare Member : constant ServantAlreadyActive_Members := ServantAlreadyActive_Members' (CORBA.IDL_Exception_Members with null record); begin Free (Error.Member); Raise_ServantAlreadyActive (Member, Message); end; when ServantNotActive_E => declare Member : constant ServantNotActive_Members := ServantNotActive_Members' (CORBA.IDL_Exception_Members with null record); begin Free (Error.Member); Raise_ServantNotActive (Member, Message); end; when WrongAdapter_E => declare Member : constant WrongAdapter_Members := WrongAdapter_Members' (CORBA.IDL_Exception_Members with null record); begin Free (Error.Member); Raise_WrongAdapter (Member, Message); end; when WrongPolicy_E => declare Member : constant WrongPolicy_Members := WrongPolicy_Members' (CORBA.IDL_Exception_Members with null record); begin Free (Error.Member); Raise_WrongPolicy (Member, Message); end; when others => raise Program_Error; end case; end Raise_From_Error; ------------------------- -- Raise_InvalidPolicy -- ------------------------- procedure Raise_InvalidPolicy (Excp_Memb : InvalidPolicy_Members; Message : Standard.String := "") is begin PolyORB.Exceptions.User_Raise_Exception (InvalidPolicy'Identity, Excp_Memb, Message); end Raise_InvalidPolicy; --------------------- -- Raise_NoServant -- --------------------- procedure Raise_NoServant (Excp_Memb : NoServant_Members; Message : Standard.String := "") is pragma Unreferenced (Excp_Memb); begin Ada.Exceptions.Raise_Exception (NoServant'Identity, Message); end Raise_NoServant; ------------------------------- -- Raise_ObjectAlreadyActive -- ------------------------------- procedure Raise_ObjectAlreadyActive (Excp_Memb : ObjectAlreadyActive_Members; Message : Standard.String := "") is pragma Unreferenced (Excp_Memb); begin Ada.Exceptions.Raise_Exception (ObjectAlreadyActive'Identity, Message); end Raise_ObjectAlreadyActive; --------------------------- -- Raise_ObjectNotActive -- --------------------------- procedure Raise_ObjectNotActive (Excp_Memb : ObjectNotActive_Members; Message : Standard.String := "") is pragma Unreferenced (Excp_Memb); begin Ada.Exceptions.Raise_Exception (ObjectNotActive'Identity, Message); end Raise_ObjectNotActive; -------------------------------- -- Raise_ServantAlreadyActive -- -------------------------------- procedure Raise_ServantAlreadyActive (Excp_Memb : ServantAlreadyActive_Members; Message : Standard.String := "") is pragma Unreferenced (Excp_Memb); begin Ada.Exceptions.Raise_Exception (ServantAlreadyActive'Identity, Message); end Raise_ServantAlreadyActive; ---------------------------- -- Raise_ServantNotActive -- ---------------------------- procedure Raise_ServantNotActive (Excp_Memb : ServantNotActive_Members; Message : Standard.String := "") is pragma Unreferenced (Excp_Memb); begin Ada.Exceptions.Raise_Exception (ServantNotActive'Identity, Message); end Raise_ServantNotActive; ------------------------ -- Raise_WrongAdapter -- ------------------------ procedure Raise_WrongAdapter (Excp_Memb : WrongAdapter_Members; Message : Standard.String := "") is pragma Unreferenced (Excp_Memb); begin Ada.Exceptions.Raise_Exception (WrongAdapter'Identity, Message); end Raise_WrongAdapter; ----------------------- -- Raise_WrongPolicy -- ----------------------- procedure Raise_WrongPolicy (Excp_Memb : WrongPolicy_Members; Message : Standard.String := "") is pragma Unreferenced (Excp_Memb); begin Ada.Exceptions.Raise_Exception (WrongPolicy'Identity, Message); end Raise_WrongPolicy; --------------------- -- Reference_To_Id -- --------------------- function Reference_To_Id (Self : Local_Ref; Reference : CORBA.Object.Ref'Class) return ObjectId is POA : constant PolyORB.POA.Obj_Adapter_Access := To_POA (Self); Ref_Servant : Servant; Ref_Object_Id : Object_Id_Access; Result : Object_Id_Access; Error : Error_Container; begin Extract_Reference_Info (Self, Reference, Ref_Servant, Ref_Object_Id); PolyORB.POA_Policies.Id_Assignment_Policy.Object_Identifier (POA.Id_Assignment_Policy.all, Ref_Object_Id, Result, Error); if Found (Error) then Raise_From_Error (Error, "Reference_To_Id failed to extract oid"); end if; declare function To_PSOid (X : Object_Id) return ObjectId renames PortableServer.Internals.To_PortableServer_ObjectId; Portable_Result : constant ObjectId := To_PSOid (Result.all); begin Free (Result); return Portable_Result; end; end Reference_To_Id; -------------------------- -- Reference_To_Servant -- -------------------------- function Reference_To_Servant (Self : Local_Ref; Reference : CORBA.Object.Ref'Class) return Servant is Ref_Servant : Servant; Ref_Object_Id : Object_Id_Access; begin Extract_Reference_Info (Self, Reference, Ref_Servant, Ref_Object_Id); return Ref_Servant; end Reference_To_Servant; ------------------- -- Servant_To_Id -- ------------------- function Servant_To_Id (Self : Local_Ref; P_Servant : Servant) return ObjectId is POA : constant PolyORB.POA.Obj_Adapter_Access := To_POA (Self); Oid : PolyORB.POA_Types.Object_Id_Access; Error : PolyORB.Errors.Error_Container; begin PolyORB.POA.Servant_To_Id (POA, To_PolyORB_Servant (P_Servant), Oid, Error); if Found (Error) then PolyORB.CORBA_P.Exceptions.Raise_From_Error (Error); end if; -- XXX Associate an object with domain managers iff it has been -- implicitly activated by this call Associate_To_Domain_Managers (P_Servant); declare Result : constant ObjectId := PortableServer.Internals.To_PortableServer_ObjectId (Oid.all); begin PolyORB.POA_Types.Free (Oid); return Result; end; end Servant_To_Id; -------------------------- -- Servant_To_Reference -- -------------------------- function Servant_To_Reference (Self : Local_Ref; P_Servant : Servant) return CORBA.Object.Ref is POA : constant PolyORB.POA.Obj_Adapter_Access := To_POA (Self); Oid : PolyORB.Objects.Object_Id_Access; TID : constant Standard.String := PortableServer.Internals.Get_Type_Id (P_Servant); Result : PolyORB.References.Ref; Error : PolyORB.Errors.Error_Container; begin PolyORB.POA.Export (POA, To_PolyORB_Servant (P_Servant), null, Oid, Error); if Found (Error) then PolyORB.CORBA_P.Exceptions.Raise_From_Error (Error); end if; PolyORB.ORB.Create_Reference (PolyORB.Setup.The_ORB, Oid, TID, Result); -- Obtain object reference. PolyORB.POA_Types.Free (Oid); -- XXX Associate an object with domain managers iff it has been -- implicitly activated by this call Associate_To_Domain_Managers (P_Servant); return CORBA.Object.Internals.To_CORBA_Ref (Result); end Servant_To_Reference; ----------------- -- Set_Servant -- ----------------- procedure Set_Servant (Self : Local_Ref; P_Servant : Servant) is POA : constant PolyORB.POA.Obj_Adapter_Access := To_POA (Self); Error : PolyORB.Errors.Error_Container; begin PolyORB.POA.Set_Servant (POA, To_PolyORB_Servant (P_Servant), Error); if Found (Error) then PolyORB.CORBA_P.Exceptions.Raise_From_Error (Error); end if; end Set_Servant; ------------------------- -- Set_Servant_Manager -- ------------------------- procedure Set_Servant_Manager (Self : Local_Ref; Imgr : PortableServer.ServantManager.Local_Ref'Class) is use PolyORB.CORBA_P.ServantActivator; use PolyORB.CORBA_P.ServantLocator; POA : constant PolyORB.POA.Obj_Adapter_Access := To_POA (Self); Error : Error_Container; begin if POA.Servant_Manager /= null then CORBA.Raise_Bad_Inv_Order (CORBA.System_Exception_Members' (Minor => 6, Completed => CORBA.Completed_No)); end if; if CORBA.Object.Is_A (CORBA.Object.Ref (Imgr), PortableServer.ServantActivator.Repository_Id) then declare CORBA_Servant_Manager : ServantActivator_Access; begin PolyORB.CORBA_P.ServantActivator.Create (CORBA_Servant_Manager, PortableServer.ServantActivator.Local_Ref (Imgr)); PolyORB.POA.Set_Servant_Manager (POA, ServantManager_Access (CORBA_Servant_Manager), Error); if Found (Error) then PolyORB.CORBA_P.Exceptions.Raise_From_Error (Error); end if; end; elsif CORBA.Object.Is_A (CORBA.Object.Ref (Imgr), PortableServer.ServantLocator.Repository_Id) then declare CORBA_Servant_Manager : ServantLocator_Access; begin Create (CORBA_Servant_Manager, PortableServer.ServantLocator.Local_Ref (Imgr)); PolyORB.POA.Set_Servant_Manager (POA, ServantManager_Access (CORBA_Servant_Manager), Error); if Found (Error) then PolyORB.CORBA_P.Exceptions.Raise_From_Error (Error); end if; end; else CORBA.Raise_Obj_Adapter (CORBA.System_Exception_Members' (Minor => 4, Completed => CORBA.Completed_No)); end if; end Set_Servant_Manager; ----------------------- -- Set_The_Activator -- ----------------------- procedure Set_The_Activator (Self : Local_Ref; To : access PortableServer.AdapterActivator.Ref'Class) is use PolyORB.CORBA_P.AdapterActivator; POA : constant PolyORB.POA.Obj_Adapter_Access := To_POA (Self); begin if POA.Adapter_Activator /= null then Free (POA.Adapter_Activator); end if; Create (POA.Adapter_Activator, To); end Set_The_Activator; ------------ -- To_POA -- ------------ function To_POA (Self : Local_Ref) return PolyORB.POA.Obj_Adapter_Access is use PolyORB.Smart_Pointers; Res : constant PolyORB.Smart_Pointers.Entity_Ptr := Entity_Of (Self); begin if Res = null or else Res.all not in PolyORB.POA.Obj_Adapter'Class then CORBA.Raise_Bad_Param (CORBA.Default_Sys_Member); end if; declare use PolyORB.POA_Manager; The_POA : constant PolyORB.POA.Obj_Adapter_Access := PolyORB.POA.Obj_Adapter_Access (Res); begin if Is_Nil (The_POA.POA_Manager) then CORBA.Raise_Object_Not_Exist (CORBA.Default_Sys_Member); end if; return The_POA; end; end To_POA; use PolyORB.Initialization; use PolyORB.Initialization.String_Lists; use PolyORB.Utils.Strings; begin Register_Module (Module_Info' (Name => +"portableserver.poa", Conflicts => Empty, Depends => +"poa", Provides => Empty, Implicit => False, Init => Initialize'Access, Shutdown => null)); end PortableServer.POA; polyorb-2.8~20110207.orig/src/corba/corba-impl.adb0000644000175000017500000000644411750740337020772 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- C O R B A . I M P L -- -- -- -- B o d y -- -- -- -- Copyright (C) 2001-2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ package body CORBA.Impl is --------------------- -- Execute_Servant -- --------------------- function Execute_Servant (Self : not null access Implementation; Req : PolyORB.Requests.Request_Access) return Boolean is begin return Execute_Servant (Self.As_Object, Req); end Execute_Servant; function Execute_Servant (Self : not null access Object; Req : PolyORB.Requests.Request_Access) return Boolean is begin raise Program_Error; return False; end Execute_Servant; ------------------------ -- To_PolyORB_Servant -- ------------------------ function To_PolyORB_Servant (S : access Object) return PolyORB.Servants.Servant_Access is begin return S.Neutral_View'Access; end To_PolyORB_Servant; package body Internals is ---------------------- -- To_CORBA_Servant -- ---------------------- function To_CORBA_Servant (S : PolyORB.Servants.Servant_Access) return Object_Ptr is use type PolyORB.Servants.Servant_Access; begin if S = null then return null; else return Object_Ptr (Implementation (S.all).As_Object); end if; end To_CORBA_Servant; end Internals; end CORBA.Impl; polyorb-2.8~20110207.orig/src/corba/corba-object.adb0000644000175000017500000003626411750740337021302 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- C O R B A . O B J E C T -- -- -- -- B o d y -- -- -- -- Copyright (C) 2001-2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with PolyORB.Any.NVList; with PolyORB.CORBA_P.Exceptions; with PolyORB.CORBA_P.Interceptors_Hooks; with PolyORB.CORBA_P.Local; with PolyORB.CORBA_P.Names; with PolyORB.Initialization; with PolyORB.Requests; with PolyORB.Smart_Pointers; with PolyORB.Types; use PolyORB.Types; with PolyORB.Utils.HFunctions.Mul; with PolyORB.Utils.Strings; with CORBA.Object.Helper; with CORBA.ORB; package body CORBA.Object is use PolyORB.Smart_Pointers; -- Client stub for remote calls implementing predefined CORBA::Object -- operations. RPC_Result_Name : constant PolyORB.Types.Identifier := To_PolyORB_String ("Result"); RPC_Is_A_Op_Name : constant Standard.String := "_is_a"; RPC_Is_A_Arg_Name : constant PolyORB.Types.Identifier := To_PolyORB_String ("Type_Id"); function RPC_Is_A (Self : Ref; Logical_Type_Id : Standard.String) return CORBA.Boolean; -- Client stub for remote call for class membership determination. -- Note: The body of RPC_Is_A is essneitally a copy of generated code. RPC_Non_Existent_Op_Name : constant Standard.String := "_non_existent"; function RPC_Non_Existent (Self : Ref) return CORBA.Boolean; -- Client stub for remote call for object (non)existence test. -- Note: The body of RPC_Non_Existent is essneitally a copy of generated -- code, with a specific added exception handler for the OBJEXT_NOT_EXIST -- case (where True is returned, and no exception is raised). RPC_Interface_Op_Name : constant Standard.String := "_interface"; ---------- -- Hash -- ---------- function Hash (Self : Ref; Maximum : CORBA.Unsigned_Long) return CORBA.Unsigned_Long is use PolyORB.Utils.HFunctions.Mul; begin return CORBA.Unsigned_Long (Hash (To_Standard_String (CORBA.ORB.Object_To_String (Self)), Default_Hash_Parameters, Natural (Maximum))); end Hash; ------------------- -- Get_Interface -- ------------------- function Get_Interface (Self : Ref) return CORBA.Object.Ref'Class is Request : aliased PolyORB.Requests.Request; Arg_List : PolyORB.Any.NVList.Ref; Result : PolyORB.Any.NamedValue; begin if Is_Nil (Self) then CORBA.Raise_Inv_Objref (Default_Sys_Member); end if; if PolyORB.CORBA_P.Local.Is_Local (Self) then Raise_No_Implement (No_Implement_Members'(Minor => 3, Completed => Completed_No)); end if; PolyORB.Any.NVList.Create (Arg_List); -- No arguments Result := (Name => RPC_Result_Name, Argument => CORBA.Internals.Get_Empty_Any (TC_Object), Arg_Modes => 0); PolyORB.Requests.Setup_Request (Req => Request, Target => CORBA.Object.Internals.To_PolyORB_Ref (Self), Operation => RPC_Interface_Op_Name, Arg_List => Arg_List, Result => Result); PolyORB.CORBA_P.Interceptors_Hooks.Client_Invoke (Request'Access, PolyORB.Requests.Flags (0)); PolyORB.CORBA_P.Exceptions.Request_Raise_Occurrence (Request); return CORBA.Object.Helper.From_Any (CORBA.Any (Result.Argument)); end Get_Interface; -------------- -- RPC_Is_A -- -------------- function RPC_Is_A (Self : Ref; Logical_Type_Id : Standard.String) return CORBA.Boolean is Request : aliased PolyORB.Requests.Request; Arg_List : PolyORB.Any.NVList.Ref; Result : PolyORB.Any.NamedValue; begin -- Self has already been checked to be non-nil PolyORB.Any.NVList.Create (Arg_List); PolyORB.Any.NVList.Add_Item (Arg_List, RPC_Is_A_Arg_Name, PolyORB.Any.To_Any (Logical_Type_Id), PolyORB.Any.ARG_IN); Result := (Name => RPC_Result_Name, Argument => PolyORB.Any.Get_Empty_Any (PolyORB.Any.TC_Boolean), Arg_Modes => 0); PolyORB.Requests.Setup_Request (Req => Request, Target => CORBA.Object.Internals.To_PolyORB_Ref (Self), Operation => RPC_Is_A_Op_Name, Arg_List => Arg_List, Result => Result); PolyORB.CORBA_P.Interceptors_Hooks.Client_Invoke (Request'Access, PolyORB.Requests.Flags (0)); PolyORB.CORBA_P.Exceptions.Request_Raise_Occurrence (Request); return PolyORB.Any.From_Any (Result.Argument); end RPC_Is_A; ---------------------- -- RPC_Non_Existent -- ---------------------- function RPC_Non_Existent (Self : Ref) return CORBA.Boolean is Request : aliased PolyORB.Requests.Request; Arg_List : PolyORB.Any.NVList.Ref; Result : PolyORB.Any.NamedValue; begin -- Self has already been checked to be non-nil PolyORB.Any.NVList.Create (Arg_List); -- No arguments Result := (Name => RPC_Result_Name, Argument => PolyORB.Any.Get_Empty_Any (PolyORB.Any.TC_Boolean), Arg_Modes => 0); PolyORB.Requests.Setup_Request (Req => Request, Target => CORBA.Object.Internals.To_PolyORB_Ref (Self), Operation => RPC_Non_Existent_Op_Name, Arg_List => Arg_List, Result => Result); -- Special case: for a non-existent object, return True instead of -- raising OBJECT_NOT_EXIST. begin PolyORB.CORBA_P.Interceptors_Hooks.Client_Invoke (Request'Access, PolyORB.Requests.Flags (0)); PolyORB.CORBA_P.Exceptions.Request_Raise_Occurrence (Request); return PolyORB.Any.From_Any (Result.Argument); exception when CORBA.Object_Not_Exist => return True; end; end RPC_Non_Existent; ---------- -- Is_A -- ---------- function Is_A (Self : Ref; Logical_Type_Id : Standard.String) return CORBA.Boolean is begin if Is_Nil (Self) then CORBA.Raise_Inv_Objref (Default_Sys_Member); end if; -- Any object is a CORBA::Object if Is_Equivalent (Logical_Type_Id, PolyORB.CORBA_P.Names.OMG_RepositoryId ("CORBA/Object")) then return True; end if; if PolyORB.CORBA_P.Local.Is_Local (Self) then -- For true CORBA local objects, call corresponding local subprogram if PolyORB.CORBA_P.Local.Is_CORBA_Local (Self) then return PolyORB.CORBA_P.Local.Is_A (PolyORB.CORBA_P.Local.Local_Object_Base_Ref (Entity_Of (Self)), Logical_Type_Id); -- Neutral core object else -- ??? -- We should look up a registered mapping between the tag of -- Entity_Of (Self) and a repository Id, as is currently done -- for the particular case of servants in PortableServer.Internals -- (the code of which should be moved to PolyORB.CORBA_P so it -- can be used in a wider context). Raise_No_Implement (No_Implement_Members' (Minor => 3, Completed => Completed_No)); end if; end if; -- Any object is of the class of its actual (i. e. most derived) type. if Is_Equivalent (Logical_Type_Id, PolyORB.References.Type_Id_Of (Internals.To_PolyORB_Ref (Self))) then return True; end if; -- If class membership cannot be determined locally, perform a remote -- call on the object. An exception may be raised (and propagated to the -- caller) if communication cannot be established to the remote ORB. return RPC_Is_A (Self, Logical_Type_Id); end Is_A; ------------------- -- Is_Equivalent -- ------------------- function Is_Equivalent (Self : Ref; Other_Object : Ref'Class) return Boolean is use PolyORB.References; S_Is_Local : constant Boolean := PolyORB.CORBA_P.Local.Is_Local (Self); O_Is_Local : constant Boolean := PolyORB.CORBA_P.Local.Is_Local (Other_Object); begin if Is_Nil (Self) or else Is_Nil (Other_Object) then CORBA.Raise_Inv_Objref (Default_Sys_Member); end if; if S_Is_Local or else O_Is_Local then return Entity_Of (Self) = Entity_Of (Other_Object); end if; declare Left, Right : PolyORB.References.Ref; begin Set (Left, Entity_Of (Self)); Set (Right, Entity_Of (Other_Object)); return Is_Equivalent (Left, Right); end; end Is_Equivalent; ------------ -- Is_Nil -- ------------ function Is_Nil (Self : Ref) return CORBA.Boolean is begin return Is_Nil (PolyORB.Smart_Pointers.Ref (Self)); end Is_Nil; ------------------ -- Non_Existent -- ------------------ function Non_Existent (Self : Ref) return CORBA.Boolean is begin if Is_Nil (Self) then CORBA.Raise_Inv_Objref (Default_Sys_Member); end if; return RPC_Non_Existent (Self); end Non_Existent; -------------------- -- Create_Request -- -------------------- procedure Create_Request (Self : Ref; Ctx : CORBA.Context.Ref; Operation : Identifier; Arg_List : CORBA.NVList.Ref; Result : in out NamedValue; Request : out CORBA.Request.Object; Req_Flags : Flags) is begin if Is_Nil (Self) then CORBA.Raise_Inv_Objref (Default_Sys_Member); end if; if PolyORB.CORBA_P.Local.Is_Local (Self) then Raise_No_Implement (No_Implement_Members'(Minor => 4, Completed => Completed_No)); end if; CORBA.Request.Create_Request (CORBA.AbstractBase.Ref (Self), Ctx, Operation, Arg_List, Result, Request, Req_Flags); end Create_Request; -------------------- -- Create_Request -- -------------------- procedure Create_Request (Self : Ref; Ctx : CORBA.Context.Ref; Operation : Identifier; Arg_List : CORBA.NVList.Ref; Result : in out NamedValue; Exc_List : ExceptionList.Ref; Ctxt_List : ContextList.Ref; Request : out CORBA.Request.Object; Req_Flags : Flags) is begin if Is_Nil (Self) then CORBA.Raise_Inv_Objref (Default_Sys_Member); end if; if PolyORB.CORBA_P.Local.Is_Local (Self) then Raise_No_Implement (No_Implement_Members'(Minor => 4, Completed => Completed_No)); end if; CORBA.Request.Create_Request (CORBA.AbstractBase.Ref (Self), Ctx, Operation, Arg_List, Result, Exc_List, Ctxt_List, Request, Req_Flags); end Create_Request; --------------- -- Duplicate -- --------------- procedure Duplicate (Self : in out Ref) is begin Adjust (PolyORB.Smart_Pointers.Ref (Self)); end Duplicate; ------------- -- Release -- ------------- procedure Release (Self : in out Ref) is begin Release (PolyORB.Smart_Pointers.Ref (Self)); end Release; ---------------------- -- Object_To_String -- ---------------------- function Object_To_String (Obj : CORBA.Object.Ref'Class) return CORBA.String is begin -- Object locality checked inside CORBA.ORB. return CORBA.ORB.Object_To_String (Obj); end Object_To_String; package body Internals is -------------------- -- To_PolyORB_Ref -- -------------------- function To_PolyORB_Ref (R : Ref) return PolyORB.References.Ref is begin return PolyORB.References.Ref (R); end To_PolyORB_Ref; ------------------ -- To_CORBA_Ref -- ------------------ function To_CORBA_Ref (R : PolyORB.References.Ref) return Ref is Result : Ref; begin Set (Result, PolyORB.References.Entity_Of (R)); return Result; end To_CORBA_Ref; end Internals; --------------- -- TC_Object -- --------------- TC_Object_Cache : CORBA.TypeCode.Object; function TC_Object return CORBA.TypeCode.Object is begin return TC_Object_Cache; end TC_Object; ---------------- -- Initialize -- ---------------- procedure Initialize; procedure Initialize is begin TC_Object_Cache := CORBA.TypeCode.Internals.To_CORBA_Object (PolyORB.Any.TypeCode.TC_Object); CORBA.Internals.Add_Parameter (TC_Object_Cache, To_Any (To_CORBA_String ("Object"))); CORBA.Internals.Add_Parameter (TC_Object_Cache, To_Any (To_CORBA_String ("IDL:CORBA/Object:1.0"))); end Initialize; use PolyORB.Initialization; use PolyORB.Initialization.String_Lists; use PolyORB.Utils.Strings; begin Register_Module (Module_Info' (Name => +"corba.object", Conflicts => Empty, Depends => +"corba" & "any", Provides => Empty, Implicit => False, Init => Initialize'Access, Shutdown => null)); end CORBA.Object; polyorb-2.8~20110207.orig/src/corba/polyorb-corba_p-servantactivator.ads0000644000175000017500000000713611750740340025445 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . C O R B A _ P . S E R V A N T A C T I V A T O R -- -- -- -- S p e c -- -- -- -- Copyright (C) 2003-2005 Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- This package provides glue codee between PolyORB's -- ServantActivator and CORBA specific ServantActivator. with PortableServer.ServantActivator; with PolyORB.Errors; with PolyORB.POA_Types; with PolyORB.Servants; with PolyORB.Smart_Pointers; package PolyORB.CORBA_P.ServantActivator is package PPT renames PolyORB.POA_Types; type CORBA_ServantActivator is new PPT.ServantActivator with private; procedure Create (Self : out PPT.ServantActivator_Access; SA : PortableServer.ServantActivator.Local_Ref'Class); function Get_Servant_Manager (Self : CORBA_ServantActivator) return PortableServer.ServantActivator.Local_Ref'Class; procedure Incarnate (Self : access CORBA_ServantActivator; Oid : PPT.Object_Id; Adapter : access PPT.Obj_Adapter'Class; Returns : out PolyORB.Servants.Servant_Access; Error : in out PolyORB.Errors.Error_Container); procedure Etherealize (Self : access CORBA_ServantActivator; Oid : PPT.Object_Id; Adapter : access PPT.Obj_Adapter'Class; Serv : PolyORB.Servants.Servant_Access; Cleanup_In_Progress : Boolean; Remaining_Activations : Boolean); private type CORBA_ServantActivator is new PPT.ServantActivator with null record; type Object is new PolyORB.Smart_Pointers.Non_Controlled_Entity with record SA : PortableServer.ServantActivator.Local_Ref; end record; type Object_Ptr is access all Object; end PolyORB.CORBA_P.ServantActivator; polyorb-2.8~20110207.orig/src/corba/portableserver-servantmanager-impl.ads0000644000175000017500000000535411750740340025770 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O R T A B L E S E R V E R . S E R V A N T M A N A G E R . I M P L -- -- -- -- S p e c -- -- -- -- Copyright (C) 2005-2010, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the CORBA Specification, and adapted -- -- for use with PolyORB. The copyright notice above, and the license -- -- provisions that follow apply solely to the contents neither explicitly -- -- nor implicitly specified by the CORBA Specification defined by the OMG. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with CORBA.Local; package PortableServer.ServantManager.Impl is type Object is new CORBA.Local.Object with null record; type Object_Ptr is access all Object'Class; private function Is_A (Self : not null access Object; Logical_Type_Id : Standard.String) return Boolean; end PortableServer.ServantManager.Impl; polyorb-2.8~20110207.orig/src/corba/portableserver-helper.ads0000644000175000017500000001544211750740340023272 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O R T A B L E S E R V E R . H E L P E R -- -- -- -- S p e c -- -- -- -- Copyright (C) 2006-2008, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the CORBA Specification, and adapted -- -- for use with PolyORB. The copyright notice above, and the license -- -- provisions that follow apply solely to the contents neither explicitly -- -- nor implicitly specified by the CORBA Specification defined by the OMG. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ ------------------------------------------------- -- This file has been generated automatically -- by IDLAC version 2.3.0w. -- -- Do NOT hand-modify this file, as your -- changes will be lost when you re-run the -- IDL to Ada compiler. ------------------------------------------------- pragma Style_Checks ("NM32766"); with PolyORB.Any; with CORBA; pragma Elaborate_All (CORBA); with CORBA.Object; package PortableServer.Helper is function Unchecked_To_Ref (The_Ref : CORBA.Object.Ref'Class) return PortableServer.POA_Forward.Ref; function To_Ref (The_Ref : CORBA.Object.Ref'Class) return PortableServer.POA_Forward.Ref; TC_POA : CORBA.TypeCode.Object; TC_IDL_SEQUENCE_PortableServer_POA_Forward : CORBA.TypeCode.Object; TC_POAList : CORBA.TypeCode.Object; TC_ObjectId : CORBA.TypeCode.Object; function From_Any (Item : CORBA.Any) return PortableServer.ObjectId; function To_Any (Item : PortableServer.ObjectId) return CORBA.Any; TC_ForwardRequest : CORBA.TypeCode.Object; function From_Any (Item : CORBA.Any) return PortableServer.ForwardRequest_Members; function To_Any (Item : PortableServer.ForwardRequest_Members) return CORBA.Any; procedure Raise_ForwardRequest (Members : ForwardRequest_Members); pragma No_Return (Raise_ForwardRequest); function Wrap (X : access PortableServer.ThreadPolicyValue) return PolyORB.Any.Content'Class; TC_ThreadPolicyValue : CORBA.TypeCode.Object; function From_Any (C : PolyORB.Any.Any_Container'Class) return PortableServer.ThreadPolicyValue; function From_Any (Item : CORBA.Any) return PortableServer.ThreadPolicyValue; function To_Any (Item : PortableServer.ThreadPolicyValue) return CORBA.Any; function Wrap (X : access PortableServer.LifespanPolicyValue) return PolyORB.Any.Content'Class; TC_LifespanPolicyValue : CORBA.TypeCode.Object; function From_Any (C : PolyORB.Any.Any_Container'Class) return PortableServer.LifespanPolicyValue; function From_Any (Item : CORBA.Any) return PortableServer.LifespanPolicyValue; function To_Any (Item : PortableServer.LifespanPolicyValue) return CORBA.Any; function Wrap (X : access PortableServer.IdUniquenessPolicyValue) return PolyORB.Any.Content'Class; TC_IdUniquenessPolicyValue : CORBA.TypeCode.Object; function From_Any (C : PolyORB.Any.Any_Container'Class) return PortableServer.IdUniquenessPolicyValue; function From_Any (Item : CORBA.Any) return PortableServer.IdUniquenessPolicyValue; function To_Any (Item : PortableServer.IdUniquenessPolicyValue) return CORBA.Any; function Wrap (X : access PortableServer.IdAssignmentPolicyValue) return PolyORB.Any.Content'Class; TC_IdAssignmentPolicyValue : CORBA.TypeCode.Object; function From_Any (C : PolyORB.Any.Any_Container'Class) return PortableServer.IdAssignmentPolicyValue; function From_Any (Item : CORBA.Any) return PortableServer.IdAssignmentPolicyValue; function To_Any (Item : PortableServer.IdAssignmentPolicyValue) return CORBA.Any; function Wrap (X : access PortableServer.ImplicitActivationPolicyValue) return PolyORB.Any.Content'Class; TC_ImplicitActivationPolicyValue : CORBA.TypeCode.Object; function From_Any (C : PolyORB.Any.Any_Container'Class) return PortableServer.ImplicitActivationPolicyValue; function From_Any (Item : CORBA.Any) return PortableServer.ImplicitActivationPolicyValue; function To_Any (Item : PortableServer.ImplicitActivationPolicyValue) return CORBA.Any; function Wrap (X : access PortableServer.ServantRetentionPolicyValue) return PolyORB.Any.Content'Class; TC_ServantRetentionPolicyValue : CORBA.TypeCode.Object; function From_Any (C : PolyORB.Any.Any_Container'Class) return PortableServer.ServantRetentionPolicyValue; function From_Any (Item : CORBA.Any) return PortableServer.ServantRetentionPolicyValue; function To_Any (Item : PortableServer.ServantRetentionPolicyValue) return CORBA.Any; function Wrap (X : access PortableServer.RequestProcessingPolicyValue) return PolyORB.Any.Content'Class; TC_RequestProcessingPolicyValue : CORBA.TypeCode.Object; function From_Any (C : PolyORB.Any.Any_Container'Class) return PortableServer.RequestProcessingPolicyValue; function From_Any (Item : CORBA.Any) return PortableServer.RequestProcessingPolicyValue; function To_Any (Item : PortableServer.RequestProcessingPolicyValue) return CORBA.Any; end PortableServer.Helper; polyorb-2.8~20110207.orig/src/corba/portableserver-idassignmentpolicy.ads0000644000175000017500000000543011750740340025714 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O R T A B L E S E R V E R . I D A S S I G N M E N T P O L I C Y -- -- -- -- S p e c -- -- -- -- Copyright (C) 2003-2008, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the CORBA Specification, and adapted -- -- for use with PolyORB. The copyright notice above, and the license -- -- provisions that follow apply solely to the contents neither explicitly -- -- nor implicitly specified by the CORBA Specification defined by the OMG. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with CORBA.Policy; package PortableServer.IdAssignmentPolicy is type Ref is new CORBA.Policy.Ref with private; function To_Ref (The_Ref : CORBA.Object.Ref'Class) return Ref; function Get_Value (Self : Ref) return PortableServer.IdAssignmentPolicyValue; private type Ref is new CORBA.Policy.Ref with null record; end PortableServer.IdAssignmentPolicy; polyorb-2.8~20110207.orig/src/corba/rtcorba/0000755000175000017500000000000011750740340017713 5ustar xavierxavierpolyorb-2.8~20110207.orig/src/corba/rtcorba/rtcorba-current-helper.ads0000644000175000017500000000533411750740340025002 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- R T C O R B A . C U R R E N T . H E L P E R -- -- -- -- S p e c -- -- -- -- Copyright (C) 2004-2008, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the CORBA Specification, and adapted -- -- for use with PolyORB. The copyright notice above, and the license -- -- provisions that follow apply solely to the contents neither explicitly -- -- nor implicitly specified by the CORBA Specification defined by the OMG. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with CORBA.Object; package RTCORBA.Current.Helper is pragma Elaborate_Body; function Unchecked_To_Local_Ref (The_Ref : CORBA.Object.Ref'Class) return RTCORBA.Current.Local_Ref; function To_Local_Ref (The_Ref : CORBA.Object.Ref'Class) return RTCORBA.Current.Local_Ref; end RTCORBA.Current.Helper; polyorb-2.8~20110207.orig/src/corba/rtcorba/polyorb-rtcorba_p-to_orb_priority.adb0000644000175000017500000000606011750740340027247 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- T O _ O R B _ P R I O R I T Y -- -- -- -- B o d y -- -- -- -- Copyright (C) 2004 Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by ACT Europe. -- -- (email: sales@act-europe.fr) -- -- -- ------------------------------------------------------------------------------ with CORBA; with RTCORBA.PriorityMapping; with PolyORB.RTCORBA_P.Setup; with PolyORB.Tasking.Priorities; function PolyORB.RTCORBA_P.To_ORB_Priority (From : RTCORBA.Priority) return PolyORB.Tasking.Priorities.ORB_Priority is use type PolyORB.RTCORBA_P.Setup.PriorityMapping_Access; use PolyORB.Tasking.Priorities; Priority_Mapping : constant PolyORB.RTCORBA_P.Setup.PriorityMapping_Access := PolyORB.RTCORBA_P.Setup.Get_Priority_Mapping; Success : CORBA.Boolean; New_Priority : RTCORBA.NativePriority; begin -- Compute new priority if Priority_Mapping = null then CORBA.Raise_Internal (CORBA.Default_Sys_Member); end if; RTCORBA.PriorityMapping.To_Native (Priority_Mapping.all, From, New_Priority, Success); if not Success then CORBA.Raise_Data_Conversion (CORBA.System_Exception_Members'(Minor => 2, Completed => CORBA.Completed_No)); end if; return ORB_Priority (New_Priority); end PolyORB.RTCORBA_P.To_ORB_Priority; polyorb-2.8~20110207.orig/src/corba/rtcorba/rtcorba-prioritymodelpolicy-helper.ads0000644000175000017500000000536111750740340027442 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- R T C O R B A . P R I O R I T Y M O D E L P O L I C Y . H E L P E R -- -- -- -- S p e c -- -- -- -- Copyright (C) 2004-2008, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the CORBA Specification, and adapted -- -- for use with PolyORB. The copyright notice above, and the license -- -- provisions that follow apply solely to the contents neither explicitly -- -- nor implicitly specified by the CORBA Specification defined by the OMG. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with CORBA.Object; package RTCORBA.PriorityModelPolicy.Helper is function Unchecked_To_Local_Ref (The_Ref : CORBA.Object.Ref'Class) return RTCORBA.PriorityModelPolicy.Local_Ref; function To_Local_Ref (The_Ref : CORBA.Object.Ref'Class) return RTCORBA.PriorityModelPolicy.Local_Ref; end RTCORBA.PriorityModelPolicy.Helper; polyorb-2.8~20110207.orig/src/corba/rtcorba/rtcorba-prioritytransform.ads0000644000175000017500000000634211750740340025660 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- R T C O R B A . P R I O R I T Y T R A N S F O R M -- -- -- -- S p e c -- -- -- -- Copyright (C) 2003-2008, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the CORBA Specification, and adapted -- -- for use with PolyORB. The copyright notice above, and the license -- -- provisions that follow apply solely to the contents neither explicitly -- -- nor implicitly specified by the CORBA Specification defined by the OMG. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with PortableServer; package RTCORBA.PriorityTransform is type Object is tagged private; -- Implementation Note: RT-CORBA specifications (formal/03-11-01) -- is unclear and does not state default behavior for this -- object. By default, these functions will always set Returns -- parameter to False. -- -- Other implementations will provide a functionnal mapping. procedure Inbound (Self : Object; The_Priority : in out RTCORBA.Priority; Oid : PortableServer.ObjectId; Returns : out CORBA.Boolean); procedure Outbound (Self : Object; The_Priority : in out RTCORBA.Priority; Oid : PortableServer.ObjectId; Returns : out CORBA.Boolean); private type Object is tagged null record; end RTCORBA.PriorityTransform; polyorb-2.8~20110207.orig/src/corba/rtcorba/polyorb-rtcorba_p-to_orb_priority.ads0000644000175000017500000000434511750740340027274 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- T O _ O R B _ P R I O R I T Y -- -- -- -- S p e c -- -- -- -- Copyright (C) 2004 Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by ACT Europe. -- -- (email: sales@act-europe.fr) -- -- -- ------------------------------------------------------------------------------ with RTCORBA; with PolyORB.Tasking.Priorities; function PolyORB.RTCORBA_P.To_ORB_Priority (From : RTCORBA.Priority) return PolyORB.Tasking.Priorities.ORB_Priority; -- Convert a RTCORBA.Priority into an ORB_priority polyorb-2.8~20110207.orig/src/corba/rtcorba/rtcorba-rtorb-helper.ads0000644000175000017500000000665411750740340024456 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- R T C O R B A . R T O R B . H E L P E R -- -- -- -- S p e c -- -- -- -- Copyright (C) 2004-2008, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the CORBA Specification, and adapted -- -- for use with PolyORB. The copyright notice above, and the license -- -- provisions that follow apply solely to the contents neither explicitly -- -- nor implicitly specified by the CORBA Specification defined by the OMG. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ ------------------------------------------------- -- This file has been generated automatically -- by IDLAC version 2.3.0w. -- -- Do NOT hand-modify this file, as your -- changes will be lost when you re-run the -- IDL to Ada compiler. ------------------------------------------------- pragma Style_Checks ("NM32766"); with CORBA; pragma Elaborate_All (CORBA); with CORBA.Object; package RTCORBA.RTORB.Helper is function Unchecked_To_Local_Ref (The_Ref : CORBA.Object.Ref'Class) return RTCORBA.RTORB.Local_Ref; function To_Local_Ref (The_Ref : CORBA.Object.Ref'Class) return RTCORBA.RTORB.Local_Ref; TC_RTORB : CORBA.TypeCode.Object; TC_InvalidThreadpool : CORBA.TypeCode.Object; function From_Any (Item : CORBA.Any) return RTCORBA.RTORB.InvalidThreadpool_Members; function To_Any (Item : RTCORBA.RTORB.InvalidThreadpool_Members) return CORBA.Any; procedure Raise_InvalidThreadpool (Members : InvalidThreadpool_Members); pragma No_Return (Raise_InvalidThreadpool); end RTCORBA.RTORB.Helper; polyorb-2.8~20110207.orig/src/corba/rtcorba/polyorb-rtcorba_p-threadpoolmanager.adb0000644000175000017500000001331011750740340027512 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . R T C O R B A _ P . T H R E A D P O O L M A N A G E R -- -- -- -- B o d y -- -- -- -- Copyright (C) 2004-2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with PolyORB.Initialization; with PolyORB.Tasking.Mutexes; with PolyORB.Utils.Chained_Lists; with PolyORB.Utils.Strings.Lists; package body PolyORB.RTCORBA_P.ThreadPoolManager is use PolyORB.Tasking.Mutexes; use type RTCORBA.ThreadpoolId; type Thread_Pool is record Lane : PolyORB.Lanes.Lane_Root_Access; Index : RTCORBA.ThreadpoolId; end record; package Thread_Pool_Lists is new PolyORB.Utils.Chained_Lists (Thread_Pool); use Thread_Pool_Lists; Thread_Pool_List_Lock : PolyORB.Tasking.Mutexes.Mutex_Access; Thread_Pool_Index : RTCORBA.ThreadpoolId := 0; Thread_Pools : Thread_Pool_Lists.List; ---------- -- Lane -- ---------- function Lane (Index : RTCORBA.ThreadpoolId) return PolyORB.Lanes.Lane_Root_Access is It : Iterator; Result : PolyORB.Lanes.Lane_Root_Access; begin Enter (Thread_Pool_List_Lock); It := First (Thread_Pools); while not Last (It) loop if Value (It).Index = Index then Result := Value (It).Lane; exit; end if; Next (It); end loop; Leave (Thread_Pool_List_Lock); return Result; end Lane; --------------------- -- Lane_Registered -- --------------------- function Lane_Registered (Index : RTCORBA.ThreadpoolId) return Boolean is It : Iterator; Found : Boolean := False; begin Enter (Thread_Pool_List_Lock); It := First (Thread_Pools); while not Last (It) loop if Value (It).Index = Index then Found := True; exit; end if; Next (It); end loop; Leave (Thread_Pool_List_Lock); return Found; end Lane_Registered; ------------------- -- Register_Lane -- ------------------- procedure Register_Lane (Lane : PolyORB.Lanes.Lane_Root_Access; Index : out RTCORBA.ThreadpoolId) is New_Thread_Pool : Thread_Pool; begin -- Update Thread_Pool_Index Enter (Thread_Pool_List_Lock); New_Thread_Pool.Index := Thread_Pool_Index; Thread_Pool_Index := Thread_Pool_Index + 1; Leave (Thread_Pool_List_Lock); -- Update Thread_Pool_List New_Thread_Pool.Lane := Lane; Append (Thread_Pools, New_Thread_Pool); Index := New_Thread_Pool.Index; end Register_Lane; --------------------- -- Unregister_Lane -- --------------------- procedure Unregister_Lane (Index : RTCORBA.ThreadpoolId) is function Index_Equality (TP : Thread_Pool) return Boolean; function Index_Equality (TP : Thread_Pool) return Boolean is begin return TP.Index = Index; end Index_Equality; procedure Remove is new Remove_G (Index_Equality); begin -- Destroy associated lane PolyORB.Lanes.Destroy (ThreadPoolManager.Lane (Index)); -- Remove index from Thread_Pools list Enter (Thread_Pool_List_Lock); Remove (Thread_Pools, All_Occurrences => False); Leave (Thread_Pool_List_Lock); end Unregister_Lane; ---------------- -- Initialize -- ---------------- procedure Initialize; procedure Initialize is begin Create (Thread_Pool_List_Lock); end Initialize; use PolyORB.Initialization; use PolyORB.Utils.Strings; use PolyORB.Utils.Strings.Lists; begin Register_Module (Module_Info' (Name => +"polyorb.rtcorba_p.threadpoolpolicy", Conflicts => PolyORB.Utils.Strings.Lists.Empty, Depends => +"tasking.mutexes", Provides => PolyORB.Utils.Strings.Lists.Empty, Implicit => False, Init => Initialize'Access, Shutdown => null)); end PolyORB.RTCORBA_P.ThreadPoolManager; polyorb-2.8~20110207.orig/src/corba/rtcorba/rtcorba-current.ads0000644000175000017500000000556711750740340023535 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- R T C O R B A . C U R R E N T -- -- -- -- S p e c -- -- -- -- Copyright (C) 2003-2010, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the CORBA Specification, and adapted -- -- for use with PolyORB. The copyright notice above, and the license -- -- provisions that follow apply solely to the contents neither explicitly -- -- nor implicitly specified by the CORBA Specification defined by the OMG. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with CORBA.Current; with PolyORB.Smart_Pointers; package RTCORBA.Current is type Local_Ref is new CORBA.Current.Local_Ref with private; function Get_The_Priority (Self : Local_Ref) return RTCORBA.Priority; procedure Set_The_Priority (Self : Local_Ref; To : RTCORBA.Priority); private type Local_Ref is new CORBA.Current.Local_Ref with null record; type Current_Object is new PolyORB.Smart_Pointers.Non_Controlled_Entity with null record; end RTCORBA.Current; polyorb-2.8~20110207.orig/src/corba/rtcorba/rtcorba-prioritymapping.adb0000644000175000017500000000566411750740340025265 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- R T C O R B A . P R I O R I T Y M A P P I N G -- -- -- -- B o d y -- -- -- -- Copyright (C) 2003-2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ package body RTCORBA.PriorityMapping is -------------- -- To_CORBA -- -------------- procedure To_CORBA (Self : Object; Native_Priority : RTCORBA.NativePriority; CORBA_Priority : out RTCORBA.Priority; Returns : out CORBA.Boolean) is pragma Unreferenced (Self); pragma Unreferenced (Native_Priority); pragma Unreferenced (CORBA_Priority); begin Returns := False; end To_CORBA; --------------- -- To_Native -- --------------- procedure To_Native (Self : Object; CORBA_Priority : RTCORBA.Priority; Native_Priority : out RTCORBA.NativePriority; Returns : out CORBA.Boolean) is pragma Unreferenced (Self); pragma Unreferenced (Native_Priority); pragma Unreferenced (CORBA_Priority); begin Returns := False; end To_Native; end RTCORBA.PriorityMapping; polyorb-2.8~20110207.orig/src/corba/rtcorba/rtcosscheduling-serverscheduler-impl.ads0000644000175000017500000000733711750740340027760 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- RTCOSSCHEDULING.SERVERSCHEDULER.IMPL -- -- -- -- S p e c -- -- -- -- Copyright (C) 2005-2010, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the CORBA Specification, and adapted -- -- for use with PolyORB. The copyright notice above, and the license -- -- provisions that follow apply solely to the contents neither explicitly -- -- nor implicitly specified by the CORBA Specification defined by the OMG. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with CORBA.Object; with CORBA.Policy; with PortableServer.POAManager; with CORBA; with PortableServer.POA; with CORBA.Local; package RTCosScheduling.ServerScheduler.Impl is type Object is new CORBA.Local.Object with private; type Object_Ptr is access all Object'Class; function Create_POA (Self : access Object; Parent : PortableServer.POA.Local_Ref; Adapter_Name : CORBA.String; A_POAManager : PortableServer.POAManager.Local_Ref; Policies : CORBA.Policy.PolicyList) return PortableServer.POA.Local_Ref; -- Implementation Note: this function may use any POA RT policies, -- as listed in ServerScheduler configuration file. procedure Schedule_Object (Self : access Object; Obj : CORBA.Object.Ref; Name : CORBA.String); function Is_A (Self : not null access Object; Logical_Type_Id : Standard.String) return Boolean; -- Implementation Note: We take advantage of the permissions -- detailled in RT-CORBA 1.1 (3.1) to add a PolyORB specific -- interface for initialization. procedure Load_Configuration_File (Conf_File_Name : String); -- Load the content of Conf_File_Name into PolyORB configuration table private type Object is new CORBA.Local.Object with null record; end RTCosScheduling.ServerScheduler.Impl; polyorb-2.8~20110207.orig/src/corba/rtcorba/rtcorba-prioritymapping.ads0000644000175000017500000000635211750740340025301 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- R T C O R B A . P R I O R I T Y M A P P I N G -- -- -- -- S p e c -- -- -- -- Copyright (C) 2003-2008, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the CORBA Specification, and adapted -- -- for use with PolyORB. The copyright notice above, and the license -- -- provisions that follow apply solely to the contents neither explicitly -- -- nor implicitly specified by the CORBA Specification defined by the OMG. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ package RTCORBA.PriorityMapping is type Object is tagged private; -- Implementation Note: RT-CORBA specifications (formal/03-11-01) -- is unclear and does not state default behavior for these -- implementations. By default, these functions will always set -- Returns parameter to False. -- -- Other implementations will provide a functionnal mapping. procedure To_Native (Self : Object; CORBA_Priority : RTCORBA.Priority; Native_Priority : out RTCORBA.NativePriority; Returns : out CORBA.Boolean); procedure To_CORBA (Self : Object; Native_Priority : RTCORBA.NativePriority; CORBA_Priority : out RTCORBA.Priority; Returns : out CORBA.Boolean); private type Object is tagged null record; end RTCORBA.PriorityMapping; polyorb-2.8~20110207.orig/src/corba/rtcorba/rtportableserver-poa-helper.adb0000644000175000017500000000564011750740340026027 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- R T P O R T A B L E S E R V E R . P O A . H E L P E R -- -- -- -- B o d y -- -- -- -- Copyright (C) 2004-2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with PolyORB.RT_POA; package body RTPortableServer.POA.Helper is ---------------------------- -- Unchecked_To_Local_Ref -- ---------------------------- function Unchecked_To_Local_Ref (The_Ref : CORBA.Object.Ref'Class) return RTPortableServer.POA.Local_Ref is Result : RTPortableServer.POA.Local_Ref; begin Set (Result, CORBA.Object.Object_Of (The_Ref)); return Result; end Unchecked_To_Local_Ref; ------------------ -- To_Local_Ref -- ------------------ function To_Local_Ref (The_Ref : CORBA.Object.Ref'Class) return RTPortableServer.POA.Local_Ref is begin if CORBA.Object.Entity_Of (The_Ref).all not in PolyORB.RT_POA.RT_Obj_Adapter'Class then CORBA.Raise_Bad_Param (CORBA.Default_Sys_Member); end if; return Unchecked_To_Local_Ref (The_Ref); end To_Local_Ref; end RTPortableServer.POA.Helper; polyorb-2.8~20110207.orig/src/corba/rtcorba/rtcorba-mutex.adb0000644000175000017500000000506611750740340023166 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- R T C O R B A . M U T E X -- -- -- -- B o d y -- -- -- -- Copyright (C) 2004-2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with PolyORB.Tasking.Mutexes; with PolyORB.RTCORBA_P.Mutex; package body RTCORBA.Mutex is ---------- -- Lock -- ---------- procedure Lock (Self : Local_Ref) is begin PolyORB.Tasking.Mutexes.Enter (PolyORB.RTCORBA_P.Mutex.Mutex_Entity (Entity_Of (Self).all).Mutex); end Lock; ------------ -- Unlock -- ------------ procedure Unlock (Self : Local_Ref) is begin PolyORB.Tasking.Mutexes.Leave (PolyORB.RTCORBA_P.Mutex.Mutex_Entity (Entity_Of (Self).all).Mutex); end Unlock; end RTCORBA.Mutex; polyorb-2.8~20110207.orig/src/corba/rtcorba/rtcorba-mutex.ads0000644000175000017500000000526111750740340023204 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- R T C O R B A . M U T E X -- -- -- -- S p e c -- -- -- -- Copyright (C) 2003-2008, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the CORBA Specification, and adapted -- -- for use with PolyORB. The copyright notice above, and the license -- -- provisions that follow apply solely to the contents neither explicitly -- -- nor implicitly specified by the CORBA Specification defined by the OMG. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with CORBA.Object; package RTCORBA.Mutex is type Local_Ref is new CORBA.Object.Ref with null record; procedure Lock (Self : Local_Ref); procedure Unlock (Self : Local_Ref); Repository_Id : constant Standard.String := "IDL:omg.org/RTCORBA/Mutex:1.0"; end RTCORBA.Mutex; polyorb-2.8~20110207.orig/src/corba/rtcorba/polyorb-rtcorba_p.ads0000644000175000017500000000424511750740340024050 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . R T C O R B A _ P -- -- -- -- S p e c -- -- -- -- Copyright (C) 2003 Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by ACT Europe. -- -- (email: sales@act-europe.fr) -- -- -- ------------------------------------------------------------------------------ -- The root of all PolyORB packages that are specific to the -- RTCORBA personality. package PolyORB.RTCORBA_P is pragma Pure; end PolyORB.RTCORBA_P; polyorb-2.8~20110207.orig/src/corba/rtcorba/polyorb-rtcorba_p-mutex.adb0000644000175000017500000000456111750740340025170 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . R T C O R B A _ P . M U T E X -- -- -- -- B o d y -- -- -- -- Copyright (C) 2004 Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by ACT Europe. -- -- (email: sales@act-europe.fr) -- -- -- ------------------------------------------------------------------------------ package body PolyORB.RTCORBA_P.Mutex is -------------- -- Finalize -- -------------- procedure Finalize (Self : in out Mutex_Entity) is use type PolyORB.Tasking.Mutexes.Mutex_Access; begin if Self.Mutex /= null then PolyORB.Tasking.Mutexes.Destroy (Self.Mutex); end if; end Finalize; end PolyORB.RTCORBA_P.Mutex; polyorb-2.8~20110207.orig/src/corba/rtcorba/rtcorba-helper.ads0000644000175000017500000001425411750740340023323 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- R T C O R B A . H E L P E R -- -- -- -- S p e c -- -- -- -- Copyright (C) 2004-2008, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the CORBA Specification, and adapted -- -- for use with PolyORB. The copyright notice above, and the license -- -- provisions that follow apply solely to the contents neither explicitly -- -- nor implicitly specified by the CORBA Specification defined by the OMG. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ ------------------------------------------------- -- This file has been generated automatically -- by IDLAC version 2.3.0w. -- -- Do NOT hand-modify this file, as your -- changes will be lost when you re-run the -- IDL to Ada compiler. ------------------------------------------------- pragma Style_Checks ("NM32766"); with CORBA.Object; with PolyORB.Any; with CORBA; pragma Elaborate_All (CORBA); package RTCORBA.Helper is TC_NativePriority : CORBA.TypeCode.Object; function From_Any (Item : CORBA.Any) return RTCORBA.NativePriority; function From_Any (C : PolyORB.Any.Any_Container'Class) return RTCORBA.NativePriority; function To_Any (Item : RTCORBA.NativePriority) return CORBA.Any; TC_Priority : CORBA.TypeCode.Object; function From_Any (Item : CORBA.Any) return RTCORBA.Priority; function From_Any (C : PolyORB.Any.Any_Container'Class) return RTCORBA.Priority; function To_Any (Item : RTCORBA.Priority) return CORBA.Any; TC_ThreadpoolId : CORBA.TypeCode.Object; function From_Any (Item : CORBA.Any) return RTCORBA.ThreadpoolId; function From_Any (C : PolyORB.Any.Any_Container'Class) return RTCORBA.ThreadpoolId; function To_Any (Item : RTCORBA.ThreadpoolId) return CORBA.Any; function Wrap (X : access RTCORBA.ThreadpoolLane) return PolyORB.Any.Content'Class; TC_ThreadpoolLane : CORBA.TypeCode.Object; function From_Any (Item : CORBA.Any) return RTCORBA.ThreadpoolLane; function To_Any (Item : RTCORBA.ThreadpoolLane) return CORBA.Any; TC_IDL_SEQUENCE_RTCORBA_ThreadpoolLane : CORBA.TypeCode.Object; function From_Any (Item : CORBA.Any) return RTCORBA.IDL_SEQUENCE_RTCORBA_ThreadpoolLane.Sequence; function To_Any (Item : RTCORBA.IDL_SEQUENCE_RTCORBA_ThreadpoolLane.Sequence) return CORBA.Any; function Wrap (X : access RTCORBA.IDL_SEQUENCE_RTCORBA_ThreadpoolLane.Sequence) return PolyORB.Any.Content'Class; TC_ThreadpoolLanes : CORBA.TypeCode.Object; function From_Any (Item : CORBA.Any) return RTCORBA.ThreadpoolLanes; function To_Any (Item : RTCORBA.ThreadpoolLanes) return CORBA.Any; function Wrap (X : access RTCORBA.PriorityModel) return PolyORB.Any.Content'Class; TC_PriorityModel : CORBA.TypeCode.Object; function From_Any (C : PolyORB.Any.Any_Container'Class) return RTCORBA.PriorityModel; function From_Any (Item : CORBA.Any) return RTCORBA.PriorityModel; function To_Any (Item : RTCORBA.PriorityModel) return CORBA.Any; function Unchecked_To_Ref (The_Ref : CORBA.Object.Ref'Class) return RTCORBA.ProtocolProperties_Forward.Ref; function To_Ref (The_Ref : CORBA.Object.Ref'Class) return RTCORBA.ProtocolProperties_Forward.Ref; TC_ProtocolProperties : CORBA.TypeCode.Object; function Wrap (X : access RTCORBA.Protocol) return PolyORB.Any.Content'Class; TC_Protocol : CORBA.TypeCode.Object; TC_IDL_SEQUENCE_RTCORBA_Protocol : CORBA.TypeCode.Object; TC_ProtocolList : CORBA.TypeCode.Object; function Wrap (X : access RTCORBA.PriorityBand) return PolyORB.Any.Content'Class; TC_PriorityBand : CORBA.TypeCode.Object; function From_Any (Item : CORBA.Any) return RTCORBA.PriorityBand; function To_Any (Item : RTCORBA.PriorityBand) return CORBA.Any; TC_IDL_SEQUENCE_RTCORBA_PriorityBand : CORBA.TypeCode.Object; function From_Any (Item : CORBA.Any) return RTCORBA.IDL_SEQUENCE_RTCORBA_PriorityBand.Sequence; function To_Any (Item : RTCORBA.IDL_SEQUENCE_RTCORBA_PriorityBand.Sequence) return CORBA.Any; function Wrap (X : access RTCORBA.IDL_SEQUENCE_RTCORBA_PriorityBand.Sequence) return PolyORB.Any.Content'Class; TC_PriorityBands : CORBA.TypeCode.Object; function From_Any (Item : CORBA.Any) return RTCORBA.PriorityBands; function To_Any (Item : RTCORBA.PriorityBands) return CORBA.Any; end RTCORBA.Helper; polyorb-2.8~20110207.orig/src/corba/rtcorba/rtcorba-protocolproperties.ads0000644000175000017500000000126411750740340026017 0ustar xavierxavier------------------------------------------------- -- This file has been generated automatically -- by IDLAC version 2.3.0w. -- -- Do NOT hand-modify this file, as your -- changes will be lost when you re-run the -- IDL to Ada compiler. ------------------------------------------------- pragma Style_Checks ("NM32766"); with PolyORB.Std; with CORBA.Object; package RTCORBA.ProtocolProperties is type Local_Ref is new CORBA.Object.Ref with null record; Repository_Id : constant PolyORB.Std.String := "IDL:omg.org/RTCORBA/ProtocolProperties:1.0"; package Convert_Forward is new RTCORBA.ProtocolProperties_Forward.Convert (Local_Ref); end RTCORBA.ProtocolProperties; polyorb-2.8~20110207.orig/src/corba/rtcorba/rtcorba-current-helper.adb0000644000175000017500000000616411750740340024763 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- R T C O R B A . C U R R E N T . H E L P E R -- -- -- -- B o d y -- -- -- -- Copyright (C) 2004-2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ package body RTCORBA.Current.Helper is ---------------------------- -- Unchecked_To_Local_Ref -- ---------------------------- function Unchecked_To_Local_Ref (The_Ref : CORBA.Object.Ref'Class) return RTCORBA.Current.Local_Ref is Result : RTCORBA.Current.Local_Ref; begin Set (Result, CORBA.Object.Object_Of (The_Ref)); return Result; end Unchecked_To_Local_Ref; ------------------ -- To_Local_Ref -- ------------------ function To_Local_Ref (The_Ref : CORBA.Object.Ref'Class) return RTCORBA.Current.Local_Ref is begin -- if CORBA.Object.Is_Nil (The_Ref) -- or else CORBA.Object.Is_A (The_Ref, Repository_Id) then -- return Unchecked_To_Local_Ref (The_Ref); -- end if; -- CORBA.Raise_Bad_Param (Default_Sys_Member); if CORBA.Object.Entity_Of (The_Ref).all not in Current_Object'Class then CORBA.Raise_Bad_Param (CORBA.Default_Sys_Member); end if; return Unchecked_To_Local_Ref (The_Ref); end To_Local_Ref; end RTCORBA.Current.Helper; polyorb-2.8~20110207.orig/src/corba/rtcorba/rtcorba-threadpoolpolicy-helper.adb0000644000175000017500000000765611750740340026671 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- R T C O R B A . T H R E A D P O O L P O L I C Y . H E L P E R -- -- -- -- B o d y -- -- -- -- Copyright (C) 2004-2007, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with CORBA.Policy; with PolyORB.CORBA_P.Policy; with PolyORB.Smart_Pointers; package body RTCORBA.ThreadpoolPolicy.Helper is ---------------------------- -- Unchecked_To_Local_Ref -- ---------------------------- function Unchecked_To_Local_Ref (The_Ref : CORBA.Object.Ref'Class) return RTCORBA.ThreadpoolPolicy.Local_Ref is Result : RTCORBA.ThreadpoolPolicy.Local_Ref; begin Set (Result, CORBA.Object.Object_Of (The_Ref)); return Result; end Unchecked_To_Local_Ref; ------------------ -- To_Local_Ref -- ------------------ function To_Local_Ref (The_Ref : CORBA.Object.Ref'Class) return RTCORBA.ThreadpoolPolicy.Local_Ref is use PolyORB.CORBA_P.Policy; begin -- if CORBA.Object.Is_Nil (The_Ref) -- or else CORBA.Object.Is_A (The_Ref, Repository_Id) then -- return Unchecked_To_Local_Ref (The_Ref); -- end if; -- CORBA.Raise_Bad_Param (CORBA.Default_Sys_Member); if The_Ref not in CORBA.Policy.Ref'Class or else CORBA.Policy.Get_Policy_Type (CORBA.Policy.Ref (The_Ref)) /= THREADPOOL_POLICY_TYPE then CORBA.Raise_Bad_Param (CORBA.Default_Sys_Member); end if; declare Entity : constant PolyORB.Smart_Pointers.Entity_Ptr := new Policy_Object_Type; Result : Local_Ref; begin Set_Policy_Type (Policy_Object_Type (Entity.all), THREADPOOL_POLICY_TYPE); Set_Policy_Value (Policy_Object_Type (Entity.all), Get_Policy_Value (Policy_Object_Type (CORBA.Policy.Entity_Of (CORBA.Policy.Ref (The_Ref)).all))); CORBA.Policy.Set (CORBA.Policy.Ref (Result), Entity); return Result; end; end To_Local_Ref; end RTCORBA.ThreadpoolPolicy.Helper; polyorb-2.8~20110207.orig/src/corba/rtcorba/rtcorba-prioritymapping-linear.adb0000644000175000017500000000647611750740340026537 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- R T C O R B A . P R I O R I T Y M A P P I N G . L I N E A R -- -- -- -- B o d y -- -- -- -- Copyright (C) 2003-2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with PolyORB.Tasking.Priorities; package body RTCORBA.PriorityMapping.Linear is use PolyORB.Tasking.Priorities; -------------- -- To_CORBA -- -------------- procedure To_CORBA (Self : Object; Native_Priority : RTCORBA.NativePriority; CORBA_Priority : out RTCORBA.Priority; Returns : out CORBA.Boolean) is pragma Unreferenced (Self); Temp : constant Long_Integer := (Long_Integer (Native_Priority) * Long_Integer (MaxPriority)) / Long_Integer (ORB_Component_Priority'Last); -- XXX to be checked ... begin CORBA_Priority := Priority (Temp); Returns := True; end To_CORBA; --------------- -- To_Native -- --------------- procedure To_Native (Self : Object; CORBA_Priority : RTCORBA.Priority; Native_Priority : out RTCORBA.NativePriority; Returns : out CORBA.Boolean) is pragma Unreferenced (Self); Temp : constant Long_Integer := (Long_Integer (CORBA_Priority) * Long_Integer (ORB_Component_Priority'Last)) / Long_Integer (MaxPriority); -- XXX to be checked ... begin Native_Priority := NativePriority (Temp); Returns := True; end To_Native; end RTCORBA.PriorityMapping.Linear; polyorb-2.8~20110207.orig/src/corba/rtcorba/rtcorba-prioritytransform.adb0000644000175000017500000000557411750740340025645 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- R T C O R B A . P R I O R I T Y T R A N S F O R M -- -- -- -- B o d y -- -- -- -- Copyright (C) 2003-2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ package body RTCORBA.PriorityTransform is ------------- -- Inbound -- ------------- procedure Inbound (Self : Object; The_Priority : in out RTCORBA.Priority; Oid : PortableServer.ObjectId; Returns : out CORBA.Boolean) is pragma Unreferenced (Self); pragma Unreferenced (The_Priority); pragma Unreferenced (Oid); begin Returns := False; end Inbound; -------------- -- Outbound -- -------------- procedure Outbound (Self : Object; The_Priority : in out RTCORBA.Priority; Oid : PortableServer.ObjectId; Returns : out CORBA.Boolean) is pragma Unreferenced (Self); pragma Unreferenced (The_Priority); pragma Unreferenced (Oid); begin Returns := False; end Outbound; end RTCORBA.PriorityTransform; polyorb-2.8~20110207.orig/src/corba/rtcorba/rtportableserver-poa.adb0000644000175000017500000002105511750740340024550 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- R T P O R T A B L E S E R V E R . P O A -- -- -- -- B o d y -- -- -- -- Copyright (C) 2004-2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with PolyORB.Errors; with PolyORB.ORB; with PolyORB.POA_Manager; with PolyORB.POA_Types; with PolyORB.References; with PolyORB.RT_POA; with PolyORB.Setup; with PolyORB.Smart_Pointers; with PolyORB.Tasking.Priorities; with PolyORB.CORBA_P.Exceptions; with PolyORB.RTCORBA_P.To_ORB_Priority; package body RTPortableServer.POA is use PolyORB.Tasking.Priorities; function To_RT_POA (Self : Local_Ref) return PolyORB.RT_POA.RT_Obj_Adapter_Access; -- Convert a Ref to a CORBA RTPOA to a PolyORB RTPOA --------------- -- To_RT_POA -- --------------- function To_RT_POA (Self : Local_Ref) return PolyORB.RT_POA.RT_Obj_Adapter_Access is use PolyORB.Smart_Pointers; Res : constant PolyORB.Smart_Pointers.Entity_Ptr := Entity_Of (Self); begin if Res = null or else Res.all not in PolyORB.RT_POA.RT_Obj_Adapter'Class then CORBA.Raise_Bad_Param (CORBA.Default_Sys_Member); end if; declare use PolyORB.POA_Manager; The_POA : constant PolyORB.RT_POA.RT_Obj_Adapter_Access := PolyORB.RT_POA.RT_Obj_Adapter_Access (Res); begin if Is_Nil (The_POA.POA_Manager) then CORBA.Raise_Object_Not_Exist (CORBA.Default_Sys_Member); end if; return The_POA; end; end To_RT_POA; ------------------------------------ -- Create_Reference_With_Priority -- ------------------------------------ function Create_Reference_With_Priority (Self : Local_Ref; Intf : CORBA.RepositoryId; Priority : RTCORBA.Priority) return CORBA.Object.Ref is use PolyORB.Errors; use PolyORB.RT_POA; Error : PolyORB.Errors.Error_Container; RT_POA : constant PolyORB.RT_POA.RT_Obj_Adapter_Access := To_RT_POA (Self); U_Oid : PolyORB.POA_Types.Unmarshalled_Oid; begin PolyORB.RT_POA.Create_Object_Identification_With_Priority (RT_POA, null, PolyORB.RTCORBA_P.To_ORB_Priority (Priority), External_Priority (Priority), U_Oid, Error); if Found (Error) then PolyORB.CORBA_P.Exceptions.Raise_From_Error (Error); end if; declare Oid : aliased PolyORB.POA_Types.Object_Id := PolyORB.POA_Types.U_Oid_To_Oid (U_Oid); Result : PolyORB.References.Ref; begin -- Obtain object reference PolyORB.ORB.Create_Reference (PolyORB.Setup.The_ORB, Oid'Access, CORBA.To_Standard_String (Intf), Result); return CORBA.Object.Internals.To_CORBA_Ref (Result); end; end Create_Reference_With_Priority; ------------------------------------------- -- Create_Reference_With_Id_And_Priority -- ------------------------------------------- function Create_Reference_With_Id_And_Priority (Self : Local_Ref; Oid : PortableServer.ObjectId; Intf : CORBA.RepositoryId; Priority : RTCORBA.Priority) return CORBA.Object.Ref is use PolyORB.Errors; use PolyORB.POA_Types; Error : PolyORB.Errors.Error_Container; RT_POA : constant PolyORB.RT_POA.RT_Obj_Adapter_Access := To_RT_POA (Self); U_Oid : PolyORB.POA_Types.Unmarshalled_Oid; OOid : Object_Id_Access := new Object_Id' (PortableServer.Internals.To_PolyORB_Object_Id (Oid)); begin PolyORB.RT_POA.Create_Object_Identification_With_Priority (RT_POA, OOid, PolyORB.RTCORBA_P.To_ORB_Priority (Priority), External_Priority (Priority), U_Oid, Error); Free (OOid); if Found (Error) then PolyORB.CORBA_P.Exceptions.Raise_From_Error (Error); end if; declare A_Oid : aliased PolyORB.POA_Types.Object_Id := PolyORB.POA_Types.U_Oid_To_Oid (U_Oid); Result : PolyORB.References.Ref; begin -- Obtain object reference PolyORB.ORB.Create_Reference (PolyORB.Setup.The_ORB, A_Oid'Access, CORBA.To_Standard_String (Intf), Result); return CORBA.Object.Internals.To_CORBA_Ref (Result); end; end Create_Reference_With_Id_And_Priority; ----------------------------------- -- Activate_Object_With_Priority -- ----------------------------------- function Activate_Object_With_Priority (Self : Local_Ref; P_Servant : PortableServer.Servant; Priority : RTCORBA.Priority) return PortableServer.ObjectId is use PortableServer; use PolyORB.Errors; Error : PolyORB.Errors.Error_Container; RT_POA : constant PolyORB.RT_POA.RT_Obj_Adapter_Access := To_RT_POA (Self); U_Oid : PolyORB.POA_Types.Unmarshalled_Oid; begin PolyORB.RT_POA.Activate_Object_With_Id_And_Priority (RT_POA, To_PolyORB_Servant (P_Servant), null, PolyORB.RTCORBA_P.To_ORB_Priority (Priority), External_Priority (Priority), U_Oid, Error); if Found (Error) then PolyORB.CORBA_P.Exceptions.Raise_From_Error (Error); end if; declare Oid : constant PolyORB.POA_Types.Object_Id := PolyORB.POA_Types.U_Oid_To_Oid (U_Oid); begin return PortableServer.Internals.To_PortableServer_ObjectId (Oid); end; end Activate_Object_With_Priority; ------------------------------------------ -- Activate_Object_With_Id_And_Priority -- ------------------------------------------ procedure Activate_Object_With_Id_And_Priority (Self : Local_Ref; Oid : PortableServer.ObjectId; P_Servant : PortableServer.Servant; Priority : RTCORBA.Priority) is use PortableServer; use PolyORB.Errors; Error : PolyORB.Errors.Error_Container; RT_POA : constant PolyORB.RT_POA.RT_Obj_Adapter_Access := To_RT_POA (Self); U_Oid : PolyORB.POA_Types.Unmarshalled_Oid; A_Oid : aliased PolyORB.POA_Types.Object_Id := PortableServer.Internals.To_PolyORB_Object_Id (Oid); begin PolyORB.RT_POA.Activate_Object_With_Id_And_Priority (RT_POA, To_PolyORB_Servant (P_Servant), A_Oid'Unchecked_Access, PolyORB.RTCORBA_P.To_ORB_Priority (Priority), External_Priority (Priority), U_Oid, Error); if Found (Error) then PolyORB.CORBA_P.Exceptions.Raise_From_Error (Error); end if; end Activate_Object_With_Id_And_Priority; end RTPortableServer.POA; polyorb-2.8~20110207.orig/src/corba/rtcorba/rtportableserver.ads0000644000175000017500000000510211750740340024007 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- R T P O R T A B L E S E R V E R -- -- -- -- S p e c -- -- -- -- Copyright (C) 2003-2008, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the CORBA Specification, and adapted -- -- for use with PolyORB. The copyright notice above, and the license -- -- provisions that follow apply solely to the contents neither explicitly -- -- nor implicitly specified by the CORBA Specification defined by the OMG. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ package RTPortableServer is pragma Pure (RTPortableServer); Repository_Id : constant Standard.String := "IDL:omg.org/RTPortableServer:1.0"; end RTPortableServer; polyorb-2.8~20110207.orig/src/corba/rtcorba/rtcorba-threadpoolpolicy-helper.ads0000644000175000017500000000534511750740340026703 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- R T C O R B A . T H R E A D P O O L P O L I C Y . H E L P E R -- -- -- -- S p e c -- -- -- -- Copyright (C) 2004-2008, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the CORBA Specification, and adapted -- -- for use with PolyORB. The copyright notice above, and the license -- -- provisions that follow apply solely to the contents neither explicitly -- -- nor implicitly specified by the CORBA Specification defined by the OMG. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with CORBA.Object; package RTCORBA.ThreadpoolPolicy.Helper is function Unchecked_To_Local_Ref (The_Ref : CORBA.Object.Ref'Class) return RTCORBA.ThreadpoolPolicy.Local_Ref; function To_Local_Ref (The_Ref : CORBA.Object.Ref'Class) return RTCORBA.ThreadpoolPolicy.Local_Ref; end RTCORBA.ThreadpoolPolicy.Helper; polyorb-2.8~20110207.orig/src/corba/rtcorba/rtcosscheduling-clientscheduler-impl.ads0000644000175000017500000000630511750740340027722 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- RTCOSSCHEDULING.CLIENTSCHEDULER.IMPL -- -- -- -- S p e c -- -- -- -- Copyright (C) 2005-2010, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the CORBA Specification, and adapted -- -- for use with PolyORB. The copyright notice above, and the license -- -- provisions that follow apply solely to the contents neither explicitly -- -- nor implicitly specified by the CORBA Specification defined by the OMG. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with CORBA.Local; package RTCosScheduling.ClientScheduler.Impl is type Object is new CORBA.Local.Object with private; type Object_Ptr is access all Object'Class; procedure Schedule_Activity (Self : access Object; Activity_Name : CORBA.String); function Is_A (Self : not null access Object; Logical_Type_Id : Standard.String) return Boolean; -- Implementation Note: We take advantage of the permissions -- detailled in RT-CORBA 1.1, 3.1 to add a PolyORB specific -- interface for initialization. procedure Load_Configuration_File (Conf_File_Name : String); -- Load the content of Conf_File_Name into PolyORB configuration table private type Object is new CORBA.Local.Object with null record; end RTCosScheduling.ClientScheduler.Impl; polyorb-2.8~20110207.orig/src/corba/rtcorba/rtcorba-prioritymapping-linear.ads0000644000175000017500000000610411750740340026544 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- R T C O R B A . P R I O R I T Y M A P P I N G . L I N E A R -- -- -- -- S p e c -- -- -- -- Copyright (C) 2004-2008, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the CORBA Specification, and adapted -- -- for use with PolyORB. The copyright notice above, and the license -- -- provisions that follow apply solely to the contents neither explicitly -- -- nor implicitly specified by the CORBA Specification defined by the OMG. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- Linear priority mapping between CORBA and Native priority package RTCORBA.PriorityMapping.Linear is type Object is new RTCORBA.PriorityMapping.Object with private; procedure To_Native (Self : Object; CORBA_Priority : RTCORBA.Priority; Native_Priority : out RTCORBA.NativePriority; Returns : out CORBA.Boolean); procedure To_CORBA (Self : Object; Native_Priority : RTCORBA.NativePriority; CORBA_Priority : out RTCORBA.Priority; Returns : out CORBA.Boolean); private type Object is new RTCORBA.PriorityMapping.Object with null record; end RTCORBA.PriorityMapping.Linear; polyorb-2.8~20110207.orig/src/corba/rtcorba/rtcorba-prioritymodelpolicy.ads0000644000175000017500000000622111750740340026161 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- R T C O R B A . P R I O R I T Y M O D E L P O L I C Y -- -- -- -- S p e c -- -- -- -- Copyright (C) 2003-2008, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the CORBA Specification, and adapted -- -- for use with PolyORB. The copyright notice above, and the license -- -- provisions that follow apply solely to the contents neither explicitly -- -- nor implicitly specified by the CORBA Specification defined by the OMG. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with CORBA.Policy; package RTCORBA.PriorityModelPolicy is type Local_Ref is new CORBA.Policy.Ref with private; -- Implementation note: OMG Issue #5613 indicates: -- -- "RTCORBA::PriorityModelPolicy cannot be created via -- ORB::create_policy() method because this policy has two -- attributes and and the Any that is passed to the -- ORB::create_policy() method can only hold one parameter." -- -- Thus, no Any helpers are provided for this policy. function Get_Priority_Model (Self : Local_Ref) return RTCORBA.PriorityModel; function Get_Server_Priority (Self : Local_Ref) return RTCORBA.Priority; private type Local_Ref is new CORBA.Policy.Ref with null record; end RTCORBA.PriorityModelPolicy; polyorb-2.8~20110207.orig/src/corba/rtcorba/rtcorba-rtorb.ads0000644000175000017500000001601611750740340023172 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- R T C O R B A . R T O R B -- -- -- -- S p e c -- -- -- -- Copyright (C) 2003-2010, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the CORBA Specification, and adapted -- -- for use with PolyORB. The copyright notice above, and the license -- -- provisions that follow apply solely to the contents neither explicitly -- -- nor implicitly specified by the CORBA Specification defined by the OMG. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with Ada.Exceptions; with CORBA.Object; with RTCORBA.Mutex; with RTCORBA.PriorityModelPolicy; with RTCORBA.ThreadpoolPolicy; with PolyORB.Std; with PolyORB.Smart_Pointers.Controlled_Entities; package RTCORBA.RTORB is package PSPCE renames PolyORB.Smart_Pointers.Controlled_Entities; type Local_Ref is new CORBA.Object.Ref with private; function Create_Mutex (Self : Local_Ref) return RTCORBA.Mutex.Local_Ref; -- XXX for now, there is no priority inheritance mechanism in use. procedure Destroy_Mutex (Self : Local_Ref; The_Mutex : RTCORBA.Mutex.Local_Ref); InvalidThreadpool : exception; function Create_Threadpool (Self : Local_Ref; Stacksize : CORBA.Unsigned_Long; Static_Threads : CORBA.Unsigned_Long; Dynamic_Threads : CORBA.Unsigned_Long; Default_Priority : RTCORBA.Priority; Allow_Request_Buffering : CORBA.Boolean; Max_Buffered_Requests : CORBA.Unsigned_Long; Max_Request_Buffer_Size : CORBA.Unsigned_Long) return RTCORBA.ThreadpoolId; -- Implementation Note: -- * the parameter Max_Request_Buffer_Size is currently not -- handled. Setting it to a non-zero value will result in an -- invalid Threadpool configuration, and raise the CORBA.BAD_PARAM -- exception. The lane will buffer up to Max_Buffer_Requests -- requests, diregarding memory used. -- -- * actual deallocation of dynamic threads is left as an -- implementation issue by the RT-CORBA specifications. PolyORB -- destroys dynamically allocated threads once the Threadpool has -- no queued job to process. function Create_Threadpool_With_Lanes (Self : Local_Ref; Stacksize : CORBA.Unsigned_Long; Lanes : RTCORBA.ThreadpoolLanes; Allow_Borrowing : CORBA.Boolean; Allow_Request_Buffering : CORBA.Boolean; Max_Buffered_Requests : CORBA.Unsigned_Long; Max_Request_Buffer_Size : CORBA.Unsigned_Long) return RTCORBA.ThreadpoolId; -- Implementation Note: -- * the parameter Max_Request_Buffer_Size is currently not -- handled. Setting it to a non-zero value will result in an -- invalid Threadpool configuration, and raise the CORBA.BAD_PARAM -- exception. The lane will buffer up to Max_Buffer_Requests -- requests, diregarding memory used. -- -- * the parameter Allow_Borrowing is not handled. Setting it to -- True will result in an invalid Threadpool configuration, and -- raise the CORBA.BAD_PARAM exception. -- -- * actual deallocation of dynamic threads is left as an -- implementation issue by the RT-CORBA specifications. PolyORB -- destroys dynamically allocated threads once the Threadpool has -- no queued job to process. procedure Destroy_Threadpool (Self : Local_Ref; Threadpool : RTCORBA.ThreadpoolId); -- Implementation Note: RT-CORBA specifications defines no return -- exception for this function. However, the user has no control -- on generated ThreadpoolIds, thus destroying a Threadpool_Policy -- from an invalid ThreadpoolId shall be an error. This function -- will raise InvalidThreadpool if Threadpool is not valid. function Create_Priority_Model_Policy (Self : Local_Ref; Priority_Model : RTCORBA.PriorityModel; Server_Priority : RTCORBA.Priority) return RTCORBA.PriorityModelPolicy.Local_Ref; function Create_Threadpool_Policy (Self : Local_Ref; Threadpool : RTCORBA.ThreadpoolId) return RTCORBA.ThreadpoolPolicy.Local_Ref; -- Implementation Note: RT-CORBA specifications defines no return -- exception for this function. However, the user has no control -- on generated ThreadpoolIds, thus creating a Threadpool_Policy -- from an invalid ThreadpoolId shall be an error. This function -- will raise InvalidThreadpool if Threadpool is not valid. ----------------------------------------- -- RTCORBA.RTORB Exceptions Management -- ----------------------------------------- type InvalidThreadpool_Members is new CORBA.IDL_Exception_Members with null record; procedure Get_Members (From : Ada.Exceptions.Exception_Occurrence; To : out InvalidThreadpool_Members); procedure Raise_InvalidThreadpool (Excp_Memb : InvalidThreadpool_Members); Repository_Id : constant PolyORB.Std.String := "IDL:omg.org/RTCORBA/RTORB:1.0"; private type Local_Ref is new CORBA.Object.Ref with null record; type RTORB_Object is new PSPCE.Entity with null record; end RTCORBA.RTORB; polyorb-2.8~20110207.orig/src/corba/rtcorba/rtcorba-prioritymapping-direct.ads0000644000175000017500000000610411750740340026544 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- R T C O R B A . P R I O R I T Y M A P P I N G . D I R E C T -- -- -- -- S p e c -- -- -- -- Copyright (C) 2004-2008, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the CORBA Specification, and adapted -- -- for use with PolyORB. The copyright notice above, and the license -- -- provisions that follow apply solely to the contents neither explicitly -- -- nor implicitly specified by the CORBA Specification defined by the OMG. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- Direct priority mapping between CORBA and Native priority package RTCORBA.PriorityMapping.Direct is type Object is new RTCORBA.PriorityMapping.Object with private; procedure To_Native (Self : Object; CORBA_Priority : RTCORBA.Priority; Native_Priority : out RTCORBA.NativePriority; Returns : out CORBA.Boolean); procedure To_CORBA (Self : Object; Native_Priority : RTCORBA.NativePriority; CORBA_Priority : out RTCORBA.Priority; Returns : out CORBA.Boolean); private type Object is new RTCORBA.PriorityMapping.Object with null record; end RTCORBA.PriorityMapping.Direct; polyorb-2.8~20110207.orig/src/corba/rtcorba/polyorb-rtcorba_p-threadpoolmanager.ads0000644000175000017500000000476111750740340027545 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . R T C O R B A _ P . T H R E A D P O O L M A N A G E R -- -- -- -- S p e c -- -- -- -- Copyright (C) 2004-2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with PolyORB.Lanes; with RTCORBA; package PolyORB.RTCORBA_P.ThreadPoolManager is function Lane (Index : RTCORBA.ThreadpoolId) return PolyORB.Lanes.Lane_Root_Access; function Lane_Registered (Index : RTCORBA.ThreadpoolId) return Boolean; procedure Register_Lane (Lane : PolyORB.Lanes.Lane_Root_Access; Index : out RTCORBA.ThreadpoolId); procedure Unregister_Lane (Index : RTCORBA.ThreadpoolId); end PolyORB.RTCORBA_P.ThreadPoolManager; polyorb-2.8~20110207.orig/src/corba/rtcorba/rtportableserver-poa-helper.ads0000644000175000017500000000532511750740340026050 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- R T P O R T A B L E S E R V E R . P O A . H E L P E R -- -- -- -- S p e c -- -- -- -- Copyright (C) 2004-2008, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the CORBA Specification, and adapted -- -- for use with PolyORB. The copyright notice above, and the license -- -- provisions that follow apply solely to the contents neither explicitly -- -- nor implicitly specified by the CORBA Specification defined by the OMG. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with CORBA.Object; package RTPortableServer.POA.Helper is function Unchecked_To_Local_Ref (The_Ref : CORBA.Object.Ref'Class) return RTPortableServer.POA.Local_Ref; function To_Local_Ref (The_Ref : CORBA.Object.Ref'Class) return RTPortableServer.POA.Local_Ref; end RTPortableServer.POA.Helper; polyorb-2.8~20110207.orig/src/corba/rtcorba/rtcorba-threadpoolpolicy.ads0000644000175000017500000000526411750740340025426 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- R T C O R B A . T H R E A D P O O L P O L I C Y -- -- -- -- S p e c -- -- -- -- Copyright (C) 2003-2008, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the CORBA Specification, and adapted -- -- for use with PolyORB. The copyright notice above, and the license -- -- provisions that follow apply solely to the contents neither explicitly -- -- nor implicitly specified by the CORBA Specification defined by the OMG. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with CORBA.Policy; package RTCORBA.ThreadpoolPolicy is type Local_Ref is new CORBA.Policy.Ref with private; function Get_Threadpool (Self : Local_Ref) return RTCORBA.ThreadpoolId; private type Local_Ref is new CORBA.Policy.Ref with null record; end RTCORBA.ThreadpoolPolicy; polyorb-2.8~20110207.orig/src/corba/rtcorba/rtcosscheduling-serverscheduler-impl.adb0000644000175000017500000002353711750740340027737 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- RTCOSSCHEDULING.SERVERSCHEDULER.IMPL -- -- -- -- B o d y -- -- -- -- Copyright (C) 2005-2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with PolyORB.Binding_Data; with PolyORB.Components; with PolyORB.Errors; with PolyORB.Log; with PolyORB.ORB; with PolyORB.Parameters.File; with PolyORB.POA; with PolyORB.POA_Types; with PolyORB.References.Binding; with PolyORB.RT_POA; with PolyORB.RT_POA_Policies.Priority_Model_Policy; with PolyORB.Servants; with PolyORB.Setup; with PolyORB.Tasking.Priorities; with PolyORB.Types; with PolyORB.Utils; with PolyORB.CORBA_P.Exceptions; with PolyORB.RTCORBA_P.To_ORB_Priority; with CORBA.ORB; with RTCORBA.RTORB.Helper; with RTCORBA.PriorityModelPolicy; with RTCORBA.ThreadpoolPolicy; with RTCosScheduling.Helper; package body RTCosScheduling.ServerScheduler.Impl is use PolyORB.Log; package L is new PolyORB.Log.Facility_Log ("rtcosscheduling.serverscheduler.impl"); procedure O (Message : Standard.String; Level : Log_Level := Debug) renames L.Output; function C (Level : Log_Level := Debug) return Boolean renames L.Enabled; ----------------------------- -- Load_Configuration_File -- ----------------------------- procedure Load_Configuration_File (Conf_File_Name : String) is begin PolyORB.Parameters.File.Load_Configuration_File (Conf_File_Name); end Load_Configuration_File; ---------------- -- Create_POA -- ---------------- function Create_POA (Self : access Object; Parent : PortableServer.POA.Local_Ref; Adapter_Name : CORBA.String; A_POAManager : PortableServer.POAManager.Local_Ref; Policies : CORBA.Policy.PolicyList) return PortableServer.POA.Local_Ref is pragma Unreferenced (Self); RT_ORB : constant RTCORBA.RTORB.Local_Ref := RTCORBA.RTORB.Helper.To_Local_Ref (CORBA.ORB.Resolve_Initial_References (CORBA.ORB.To_CORBA_String ("RTORB"))); All_Policies : CORBA.Policy.PolicyList := Policies; Priority_Model_Policy_Ref : RTCORBA.PriorityModelPolicy.Local_Ref; Thread_Pool_Policy_Ref : RTCORBA.ThreadpoolPolicy.Local_Ref; begin pragma Debug (C, O ("Configuring POA " & CORBA.To_String (Adapter_Name))); -- Retrieve parameters for the PriorityModel Policy, if any declare Priority_Model : constant String := PolyORB.Utils.To_Upper (PolyORB.Parameters.Get_Conf ("poa " & CORBA.To_String (Adapter_Name), "priority_model")); Default_Priority : constant Integer := PolyORB.Parameters.Get_Conf ("poa " & CORBA.To_String (Adapter_Name), "default_priority"); begin if Priority_Model = "CLIENT_PROPAGATED" then pragma Debug (C, O ("Configuring CLIENT_PROPAGATED policy")); Priority_Model_Policy_Ref := RTCORBA.RTORB.Create_Priority_Model_Policy (RT_ORB, RTCORBA.CLIENT_PROPAGATED, RTCORBA.Priority (Default_Priority)); CORBA.Policy.IDL_SEQUENCE_Policy.Append (All_Policies, CORBA.Policy.Ref (Priority_Model_Policy_Ref)); elsif Priority_Model = "SERVER_DECLARED" then pragma Debug (C, O ("Configuring SERVER_DECLARED policy")); Priority_Model_Policy_Ref := RTCORBA.RTORB.Create_Priority_Model_Policy (RT_ORB, RTCORBA.SERVER_DECLARED, RTCORBA.Priority (Default_Priority)); CORBA.Policy.IDL_SEQUENCE_Policy.Append (All_Policies, CORBA.Policy.Ref (Priority_Model_Policy_Ref)); else pragma Debug (C, O ("No PriorityModel policy to configure")); null; end if; end; -- Retrieve parameters for the ThreadPool Policy, if any declare Threadpool_Id : constant Integer := PolyORB.Parameters.Get_Conf ("poa " & CORBA.To_String (Adapter_Name), "threadpool_id", -1); begin if Threadpool_Id /= -1 then pragma Debug (C, O ("Create Threadpool policy")); Thread_Pool_Policy_Ref := RTCORBA.RTORB.Create_Threadpool_Policy (RT_ORB, RTCORBA.ThreadpoolId (Threadpool_Id)); CORBA.Policy.IDL_SEQUENCE_Policy.Append (All_Policies, CORBA.Policy.Ref (Thread_Pool_Policy_Ref)); else pragma Debug (C, O ("No ThreadPool policy to configure")); null; end if; end; return PortableServer.POA.Local_Ref (PortableServer.POA.Create_POA (Parent, Adapter_Name, A_POAManager, All_Policies)); end Create_POA; --------------------- -- Schedule_Object -- --------------------- procedure Schedule_Object (Self : access Object; Obj : CORBA.Object.Ref; Name : CORBA.String) is pragma Unreferenced (Self); use PolyORB.Errors; use PolyORB.RT_POA_Policies.Priority_Model_Policy; CORBA_Priority : Integer; ORB_Priority : PolyORB.Tasking.Priorities.ORB_Priority; The_POA : PolyORB.POA.Obj_Adapter_Access; The_Servant : PolyORB.Components.Component_Access; The_Profile : PolyORB.Binding_Data.Profile_Access; Error : Error_Container; U_Oid : PolyORB.POA_Types.Unmarshalled_Oid; begin pragma Debug (C, O ("Configuring object " & CORBA.To_String (Name))); -- Retrieve CORBA Priority CORBA_Priority := PolyORB.Parameters.Get_Conf ("object " & CORBA.To_String (Name), "priority"); pragma Debug (C, O ("Set priority to:" & CORBA_Priority'Img)); -- Compute corresponding Native priority ORB_Priority := PolyORB.RTCORBA_P.To_ORB_Priority (RTCORBA.Priority (CORBA_Priority)); -- Retrieve servant from reference information PolyORB.References.Binding.Bind (CORBA.Object.Internals.To_PolyORB_Ref (Obj), PolyORB.Setup.The_ORB, (others => null), The_Servant, The_Profile, True, Error); if Found (Error) then PolyORB.CORBA_P.Exceptions.Raise_From_Error (Error); end if; -- Retrieve POA from reference information PolyORB.POA_Types.Oid_To_U_Oid (PolyORB.Binding_Data.Get_Object_Key (The_Profile.all).all, U_Oid, Error); if Found (Error) then PolyORB.CORBA_P.Exceptions.Raise_From_Error (Error); end if; PolyORB.POA.Find_POA (PolyORB.POA.Obj_Adapter (PolyORB.ORB.Object_Adapter (PolyORB.Setup.The_ORB).all)'Access, PolyORB.Types.To_Standard_String (U_Oid.Creator), False, The_POA, Error); if Found (Error) then PolyORB.CORBA_P.Exceptions.Raise_From_Error (Error); end if; -- Update servant priority information Set_Servant_Priority_Information (PolyORB.RT_POA.RT_Obj_Adapter (The_POA.all).Priority_Model_Policy.all, PolyORB.Servants.Servant_Access (The_Servant), ORB_Priority, PolyORB.Tasking.Priorities.External_Priority (CORBA_Priority), Error); if Found (Error) then PolyORB.CORBA_P.Exceptions.Raise_From_Error (Error); end if; exception when others => -- For now, we cannot distinguish between an inconsistent -- value of the priority, and an unknown activity. RTCosScheduling.Helper.Raise_UnknownName (UnknownName_Members' (CORBA.IDL_Exception_Members with null record)); end Schedule_Object; ---------- -- Is_A -- ---------- function Is_A (Self : not null access Object; Logical_Type_Id : Standard.String) return Boolean is pragma Unreferenced (Self); begin return CORBA.Is_Equivalent (Logical_Type_Id, RTCosScheduling.ServerScheduler.Repository_Id) or else CORBA.Is_Equivalent (Logical_Type_Id, "IDL:omg.org/CORBA/Object:1.0"); end Is_A; end RTCosScheduling.ServerScheduler.Impl; polyorb-2.8~20110207.orig/src/corba/rtcorba/polyorb-rtcorba_p-mutex.ads0000644000175000017500000000453311750740340025210 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . R T C O R B A _ P . M U T E X -- -- -- -- S p e c -- -- -- -- Copyright (C) 2004 Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by ACT Europe. -- -- (email: sales@act-europe.fr) -- -- -- ------------------------------------------------------------------------------ with PolyORB.Smart_Pointers; with PolyORB.Tasking.Mutexes; package PolyORB.RTCORBA_P.Mutex is type Mutex_Entity is new PolyORB.Smart_Pointers.Non_Controlled_Entity with record Mutex : PolyORB.Tasking.Mutexes.Mutex_Access; end record; procedure Finalize (Self : in out Mutex_Entity); end PolyORB.RTCORBA_P.Mutex; polyorb-2.8~20110207.orig/src/corba/rtcorba/rtcorba-protocolproperties-helper.ads0000644000175000017500000000136311750740340027274 0ustar xavierxavier------------------------------------------------- -- This file has been generated automatically -- by IDLAC version 2.3.0w. -- -- Do NOT hand-modify this file, as your -- changes will be lost when you re-run the -- IDL to Ada compiler. ------------------------------------------------- pragma Style_Checks ("NM32766"); with CORBA; pragma Elaborate_All (CORBA); with CORBA.Object; package RTCORBA.ProtocolProperties.Helper is function Unchecked_To_Local_Ref (The_Ref : CORBA.Object.Ref'Class) return RTCORBA.ProtocolProperties.Local_Ref; function To_Local_Ref (The_Ref : CORBA.Object.Ref'Class) return RTCORBA.ProtocolProperties.Local_Ref; TC_ProtocolProperties : CORBA.TypeCode.Object; end RTCORBA.ProtocolProperties.Helper; polyorb-2.8~20110207.orig/src/corba/rtcorba/polyorb-rtcorba_p-setup.adb0000644000175000017500000001303711750740340025164 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . R T C O R B A _ P . S E T U P -- -- -- -- B o d y -- -- -- -- Copyright (C) 2003-2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with PolyORB.Initialization; with PolyORB.Tasking.Priorities; with PolyORB.Types; with PolyORB.Utils.Strings; package body PolyORB.RTCORBA_P.Setup is use PolyORB.Tasking.Priorities; Current_Priority_Mapping : PriorityMapping_Access; Current_Priority_Transform : PriorityTransform_Access; -------------------------- -- Set_Priority_Mapping -- -------------------------- procedure Set_Priority_Mapping (Mapping : RTCORBA.PriorityMapping.Object'Class) is begin if Current_Priority_Mapping = null then Current_Priority_Mapping := new RTCORBA.PriorityMapping.Object'Class'(Mapping); else Current_Priority_Mapping.all := Mapping; end if; end Set_Priority_Mapping; -------------------------- -- Get_Priority_Mapping -- -------------------------- function Get_Priority_Mapping return PriorityMapping_Access is begin return Current_Priority_Mapping; end Get_Priority_Mapping; ---------------------------- -- Set_Priority_Transform -- ---------------------------- procedure Set_Priority_Transform (Transform : RTCORBA.PriorityTransform.Object'Class) is begin if Current_Priority_Transform = null then Current_Priority_Transform := new RTCORBA.PriorityTransform.Object'Class'(Transform); else Current_Priority_Transform.all := Transform; end if; end Set_Priority_Transform; ---------------------------- -- Get_Priority_Transform -- ---------------------------- function Get_Priority_Transform return PriorityTransform_Access is begin return Current_Priority_Transform; end Get_Priority_Transform; -------------------------- -- To_External_Priority -- -------------------------- procedure To_External_Priority (Value : ORB_Priority; Result : out External_Priority; Returns : out PolyORB.Types.Boolean); procedure To_External_Priority (Value : ORB_Priority; Result : out External_Priority; Returns : out PolyORB.Types.Boolean) is begin RTCORBA.PriorityMapping.To_CORBA (Current_Priority_Mapping.all, RTCORBA.NativePriority (Value), RTCORBA.Priority (Result), Returns); end To_External_Priority; --------------------- -- To_ORB_Priority -- --------------------- procedure To_ORB_Priority (Value : External_Priority; Result : out ORB_Priority; Returns : out PolyORB.Types.Boolean); procedure To_ORB_Priority (Value : External_Priority; Result : out ORB_Priority; Returns : out PolyORB.Types.Boolean) is begin RTCORBA.PriorityMapping.To_Native (Current_Priority_Mapping.all, RTCORBA.Priority (Value), RTCORBA.NativePriority (Result), Returns); end To_ORB_Priority; ---------------- -- Initialize -- ---------------- procedure Initialize; procedure Initialize is begin PolyORB.Tasking.Priorities.To_External_Priority := To_External_Priority'Access; PolyORB.Tasking.Priorities.To_ORB_Priority := To_ORB_Priority'Access; end Initialize; use PolyORB.Initialization; use PolyORB.Initialization.String_Lists; use PolyORB.Utils.Strings; begin Register_Module (Module_Info' (Name => +"rtcorba_p.setup", Conflicts => Empty, Depends => Empty, Provides => Empty, Implicit => False, Init => Initialize'Access, Shutdown => null)); end PolyORB.RTCORBA_P.Setup; polyorb-2.8~20110207.orig/src/corba/rtcorba/rtcorba-rtorb.adb0000644000175000017500000002454611750740340023160 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- R T C O R B A . R T O R B -- -- -- -- B o d y -- -- -- -- Copyright (C) 2003-2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with CORBA.ORB; with PolyORB.CORBA_P.Initial_References; with PolyORB.RTCORBA_P.Mutex; with PolyORB.RTCORBA_P.PriorityModelPolicy; with PolyORB.RTCORBA_P.ThreadPoolManager; with PolyORB.RTCORBA_P.To_ORB_Priority; with PolyORB.Exceptions; with PolyORB.Initialization; with PolyORB.Lanes; with PolyORB.Tasking.Mutexes; with PolyORB.Tasking.Priorities; with PolyORB.Types; with PolyORB.Utils.Strings.Lists; with RTCORBA.ThreadpoolPolicy.Helper; package body RTCORBA.RTORB is use CORBA; use PolyORB.Tasking.Priorities; function Create return CORBA.Object.Ref; -- Create a RTCORBA.RTORB.Ref ------------ -- Create -- ------------ function Create return CORBA.Object.Ref is Result : Local_Ref; RTORB_Obj : constant PolyORB.Smart_Pointers.Entity_Ptr := new RTORB_Object; begin Set (Result, RTORB_Obj); return CORBA.Object.Ref (Result); end Create; ------------------ -- Create_Mutex -- ------------------ function Create_Mutex (Self : Local_Ref) return RTCORBA.Mutex.Local_Ref is pragma Unreferenced (Self); use PolyORB.Smart_Pointers; Result : RTCORBA.Mutex.Local_Ref; Mutex_E : constant Entity_Ptr := new PolyORB.RTCORBA_P.Mutex.Mutex_Entity; begin PolyORB.Tasking.Mutexes.Create (PolyORB.RTCORBA_P.Mutex.Mutex_Entity (Mutex_E.all).Mutex); RTCORBA.Mutex.Set (Result, Mutex_E); return Result; end Create_Mutex; ------------------- -- Destroy_Mutex -- ------------------- procedure Destroy_Mutex (Self : Local_Ref; The_Mutex : RTCORBA.Mutex.Local_Ref) is pragma Unreferenced (Self); Mutex : PolyORB.Tasking.Mutexes.Mutex_Access := PolyORB.RTCORBA_P.Mutex.Mutex_Entity (RTCORBA.Mutex.Entity_Of (The_Mutex).all).Mutex; begin PolyORB.Tasking.Mutexes.Destroy (Mutex); PolyORB.RTCORBA_P.Mutex.Mutex_Entity (RTCORBA.Mutex.Entity_Of (The_Mutex).all).Mutex := null; end Destroy_Mutex; ----------------------- -- Create_Threadpool -- ----------------------- function Create_Threadpool (Self : Local_Ref; Stacksize : CORBA.Unsigned_Long; Static_Threads : CORBA.Unsigned_Long; Dynamic_Threads : CORBA.Unsigned_Long; Default_Priority : RTCORBA.Priority; Allow_Request_Buffering : CORBA.Boolean; Max_Buffered_Requests : CORBA.Unsigned_Long; Max_Request_Buffer_Size : CORBA.Unsigned_Long) return RTCORBA.ThreadpoolId is pragma Unreferenced (Self); use PolyORB.Lanes; New_Lane : Lane_Root_Access; Lane_Index : RTCORBA.ThreadpoolId; begin if Max_Request_Buffer_Size /= 0 then -- See note in package specification Raise_Bad_Param (Default_Sys_Member); end if; New_Lane := Lane_Root_Access (Create (PolyORB.RTCORBA_P.To_ORB_Priority (Default_Priority), External_Priority (Default_Priority), Natural (Static_Threads), Natural (Dynamic_Threads), Natural (Stacksize), Allow_Request_Buffering, PolyORB.Types.Unsigned_Long (Max_Buffered_Requests), PolyORB.Types.Unsigned_Long (Max_Request_Buffer_Size))); PolyORB.RTCORBA_P.ThreadPoolManager.Register_Lane (New_Lane, Lane_Index); return Lane_Index; end Create_Threadpool; ---------------------------------- -- Create_Threadpool_With_Lanes -- ---------------------------------- function Create_Threadpool_With_Lanes (Self : Local_Ref; Stacksize : CORBA.Unsigned_Long; Lanes : RTCORBA.ThreadpoolLanes; Allow_Borrowing : CORBA.Boolean; Allow_Request_Buffering : CORBA.Boolean; Max_Buffered_Requests : CORBA.Unsigned_Long; Max_Request_Buffer_Size : CORBA.Unsigned_Long) return RTCORBA.ThreadpoolId is pragma Unreferenced (Self); use PolyORB.Lanes; New_Lane : Lane_Root_Access; Lane_Index : RTCORBA.ThreadpoolId; begin if Max_Request_Buffer_Size /= 0 or else Allow_Borrowing then -- See note in package specification Raise_Bad_Param (Default_Sys_Member); end if; New_Lane := new Lanes_Set (Length (Lanes)); for J in 1 .. Length (Lanes) loop Add_Lane (Lanes_Set (New_Lane.all), Create (PolyORB.RTCORBA_P.To_ORB_Priority (Get_Element (Lanes, J).Lane_Priority), External_Priority (Get_Element (Lanes, J).Lane_Priority), Positive (Get_Element (Lanes, J).Static_Threads), Natural (Get_Element (Lanes, J).Dynamic_Threads), Natural (Stacksize), Allow_Request_Buffering, PolyORB.Types.Unsigned_Long (Max_Buffered_Requests), PolyORB.Types.Unsigned_Long (Max_Request_Buffer_Size)), J); end loop; PolyORB.RTCORBA_P.ThreadPoolManager.Register_Lane (New_Lane, Lane_Index); return Lane_Index; end Create_Threadpool_With_Lanes; ------------------------ -- Destroy_Threadpool -- ------------------------ procedure Destroy_Threadpool (Self : Local_Ref; Threadpool : RTCORBA.ThreadpoolId) is pragma Warnings (Off); pragma Unreferenced (Self); pragma Warnings (On); use PolyORB.RTCORBA_P.ThreadPoolManager; begin if not Lane_Registered (Threadpool) then raise InvalidThreadpool; end if; PolyORB.RTCORBA_P.ThreadPoolManager.Unregister_Lane (Threadpool); end Destroy_Threadpool; ---------------------------------- -- Create_Priority_Model_Policy -- ---------------------------------- function Create_Priority_Model_Policy (Self : Local_Ref; Priority_Model : RTCORBA.PriorityModel; Server_Priority : RTCORBA.Priority) return RTCORBA.PriorityModelPolicy.Local_Ref is pragma Unreferenced (Self); use PolyORB.RTCORBA_P.PriorityModelPolicy; Result : RTCORBA.PriorityModelPolicy.Local_Ref; Entity : constant PolyORB.Smart_Pointers.Entity_Ptr := Create (Priority_Model, Server_Priority); begin RTCORBA.PriorityModelPolicy.Set (Result, Entity); return Result; end Create_Priority_Model_Policy; ------------------------------ -- Create_Threadpool_Policy -- ------------------------------ function Create_Threadpool_Policy (Self : Local_Ref; Threadpool : RTCORBA.ThreadpoolId) return RTCORBA.ThreadpoolPolicy.Local_Ref is pragma Unreferenced (Self); use PolyORB.RTCORBA_P.ThreadPoolManager; begin if not Lane_Registered (Threadpool) then raise InvalidThreadpool; end if; return RTCORBA.ThreadpoolPolicy.Helper.To_Local_Ref (CORBA.ORB.Create_Policy (THREADPOOL_POLICY_TYPE, To_Any (Threadpool))); end Create_Threadpool_Policy; ----------------- -- Get_Members -- ----------------- procedure Get_Members (From : Ada.Exceptions.Exception_Occurrence; To : out InvalidThreadpool_Members) is use Ada.Exceptions; begin if Exception_Identity (From) /= InvalidThreadpool'Identity then CORBA.Raise_Bad_Param (CORBA.Default_Sys_Member); end if; To := InvalidThreadpool_Members' (CORBA.IDL_Exception_Members with null record); end Get_Members; ----------------------------- -- Raise_InvalidThreadpool -- ----------------------------- procedure Raise_InvalidThreadpool (Excp_Memb : InvalidThreadpool_Members) is begin PolyORB.Exceptions.User_Raise_Exception (InvalidThreadpool'Identity, Excp_Memb); end Raise_InvalidThreadpool; ---------------- -- Initialize -- ---------------- procedure Initialize; procedure Initialize is use PolyORB.CORBA_P.Initial_References; begin Register_Initial_Reference ("RTORB", Create'Access); end Initialize; use PolyORB.Initialization; use PolyORB.Utils.Strings; use PolyORB.Utils.Strings.Lists; begin Register_Module (Module_Info' (Name => +"rtcorba.rtorb", Conflicts => Empty, Depends => +"corba.initial_references", Provides => Empty, Implicit => False, Init => Initialize'Access, Shutdown => null)); end RTCORBA.RTORB; polyorb-2.8~20110207.orig/src/corba/rtcorba/rtcorba-prioritymodelpolicy.adb0000644000175000017500000001562211750740340026145 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- R T C O R B A . P R I O R I T Y M O D E L P O L I C Y -- -- -- -- B o d y -- -- -- -- Copyright (C) 2003-2007, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with PolyORB.CORBA_P.POA_Config; with PolyORB.CORBA_P.Policy; with PolyORB.CORBA_P.Policy_Management; with PolyORB.Initialization; with PolyORB.POA_Policies; with PolyORB.Smart_Pointers; with PolyORB.RTCORBA_P.PriorityModelPolicy; with PolyORB.RTCORBA_P.Setup; with PolyORB.Tasking.Priorities; with PolyORB.Utils.Strings; with RTCORBA.PriorityMapping; with RTCORBA.PriorityModelPolicy.Helper; package body RTCORBA.PriorityModelPolicy is use CORBA; use CORBA.TypeCode; use PolyORB.CORBA_P.Policy; use PolyORB.CORBA_P.Policy_Management; use PolyORB.RTCORBA_P.PriorityModelPolicy; function Priority_Model_Policy_Allocator (Self : CORBA.Policy.Ref) return PolyORB.POA_Policies.Policy_Access; function Create_PriorityModelPolicy (The_Type : CORBA.PolicyType; Value : CORBA.Any) return CORBA.Policy.Ref; ------------------------------------- -- Priority_Model_Policy_Allocator -- ------------------------------------- function Priority_Model_Policy_Allocator (Self : CORBA.Policy.Ref) return PolyORB.POA_Policies.Policy_Access is use type PolyORB.RTCORBA_P.Setup.PriorityMapping_Access; use PolyORB.Tasking.Priorities; use RTCORBA.PriorityModelPolicy.Helper; Priority_Mapping : constant PolyORB.RTCORBA_P.Setup.PriorityMapping_Access := PolyORB.RTCORBA_P.Setup.Get_Priority_Mapping; Success : CORBA.Boolean; New_Priority : RTCORBA.NativePriority; begin -- Compute new priority if Priority_Mapping = null then CORBA.Raise_Internal (CORBA.Default_Sys_Member); end if; RTCORBA.PriorityMapping.To_Native (Priority_Mapping.all, Get_Server_Priority (To_Local_Ref (Self)), New_Priority, Success); if not Success then CORBA.Raise_Data_Conversion (CORBA.System_Exception_Members'(Minor => 2, Completed => CORBA.Completed_No)); end if; return Create (Get_Priority_Model (To_Local_Ref (Self)), ORB_Priority (New_Priority), External_Priority (Get_Server_Priority (To_Local_Ref (Self)))); end Priority_Model_Policy_Allocator; --------------------------------- -- Create_PriorityModelPolicy -- --------------------------------- function Create_PriorityModelPolicy (The_Type : CORBA.PolicyType; Value : CORBA.Any) return CORBA.Policy.Ref is begin pragma Assert (The_Type = PRIORITY_MODEL_POLICY_TYPE); if Get_Type (Value) /= CORBA.TC_Unsigned_Long then Raise_PolicyError ((Reason => BAD_POLICY_TYPE)); end if; declare Result : CORBA.Policy.Ref; Entity : constant PolyORB.Smart_Pointers.Entity_Ptr := new Policy_Object_Type; begin Set_Policy_Type (Policy_Object_Type (Entity.all), The_Type); Set_Policy_Value (Policy_Object_Type (Entity.all), Value); CORBA.Policy.Set (Result, Entity); return Result; end; end Create_PriorityModelPolicy; ------------------------ -- Get_Priority_Model -- ------------------------ function Get_Priority_Model (Self : Local_Ref) return RTCORBA.PriorityModel is begin return Get_Priority_Model (PriorityModelPolicy_Type (Entity_Of (Self).all)); end Get_Priority_Model; ------------------------- -- Get_Server_Priority -- ------------------------- function Get_Server_Priority (Self : Local_Ref) return RTCORBA.Priority is begin return Get_Server_Priority (PriorityModelPolicy_Type (Entity_Of (Self).all)); end Get_Server_Priority; ---------------- -- Initialize -- ---------------- procedure Initialize; procedure Initialize is begin PolyORB.CORBA_P.POA_Config.Register (PRIORITY_MODEL_POLICY_TYPE, Priority_Model_Policy_Allocator'Access); Register (The_Type => PRIORITY_MODEL_POLICY_TYPE, POA_Level => True, Factory => Create_PriorityModelPolicy'Access, System_Default => Create_PriorityModelPolicy (PRIORITY_MODEL_POLICY_TYPE, To_Any (CORBA.Unsigned_Long (0)))); -- XXX Is this correct? If policy can't be created with -- CORBA::create_policy then we must not register factory procedure. -- Also, created system default value is not compatible with policy -- implementation. end Initialize; use PolyORB.Initialization; use PolyORB.Initialization.String_Lists; use PolyORB.Utils.Strings; begin Register_Module (Module_Info' (Name => +"rtcorba-prioritymodelpolicy", Conflicts => Empty, Depends => +"rt_poa", Provides => Empty, Implicit => False, Init => Initialize'Access, Shutdown => null)); end RTCORBA.PriorityModelPolicy; polyorb-2.8~20110207.orig/src/corba/rtcorba/rtcorba-prioritymapping-direct.adb0000644000175000017500000000644111750740340026527 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- R T C O R B A . P R I O R I T Y M A P P I N G . D I R E C T -- -- -- -- B o d y -- -- -- -- Copyright (C) 2003-2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with System; package body RTCORBA.PriorityMapping.Direct is -------------- -- To_CORBA -- -------------- procedure To_CORBA (Self : Object; Native_Priority : RTCORBA.NativePriority; CORBA_Priority : out RTCORBA.Priority; Returns : out CORBA.Boolean) is pragma Unreferenced (Self); begin if Native_Priority >= NativePriority (System.Priority'First) and then Native_Priority <= NativePriority (System.Priority'Last) then CORBA_Priority := Priority (Native_Priority); Returns := True; else Returns := False; end if; end To_CORBA; --------------- -- To_Native -- --------------- procedure To_Native (Self : Object; CORBA_Priority : RTCORBA.Priority; Native_Priority : out RTCORBA.NativePriority; Returns : out CORBA.Boolean) is pragma Unreferenced (Self); begin if CORBA_Priority >= Priority (System.Priority'First) and then CORBA_Priority <= Priority (System.Priority'Last) then Native_Priority := NativePriority (CORBA_Priority); Returns := True; else Returns := False; end if; end To_Native; end RTCORBA.PriorityMapping.Direct; polyorb-2.8~20110207.orig/src/corba/rtcorba/polyorb-rtcorba_p-setup.ads0000644000175000017500000000714311750740340025206 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . R T C O R B A _ P . S E T U P -- -- -- -- S p e c -- -- -- -- Copyright (C) 2003-2004 Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by ACT Europe. -- -- (email: sales@act-europe.fr) -- -- -- ------------------------------------------------------------------------------ -- Implementation Notes: RTCORBA specifications defines objects that -- are (Ada) programming language objects rather than CORBA -- objects. Therefore the normal mechanism for coupling an -- implementation to the code that uses it (an object reference) does -- not apply. The implementation must provide specific mechanisms to -- enable this coupling. -- -- This package provides accessors to configure them. It supports the -- following objects: -- * PriorityMapping -- * PriorityTransform with RTCORBA.PriorityMapping; with RTCORBA.PriorityTransform; package PolyORB.RTCORBA_P.Setup is -- PriorityMapping type PriorityMapping_Access is access all RTCORBA.PriorityMapping.Object'Class; procedure Set_Priority_Mapping (Mapping : RTCORBA.PriorityMapping.Object'Class); pragma Inline (Set_Priority_Mapping); -- Set RT-ORB PriorityMapping object, -- overrides previous settings, if any. function Get_Priority_Mapping return PriorityMapping_Access; pragma Inline (Get_Priority_Mapping); -- Return RT-ORB PriorityMapping object. -- PriorityTransform type PriorityTransform_Access is access all RTCORBA.PriorityTransform.Object'Class; procedure Set_Priority_Transform (Transform : RTCORBA.PriorityTransform.Object'Class); pragma Inline (Set_Priority_Transform); -- Set RT-ORB global Priority Mapping object, -- overrides previous settings, if any. function Get_Priority_Transform return PriorityTransform_Access; pragma Inline (Get_Priority_Transform); -- Return RT-ORB global Priority Mapping object. end PolyORB.RTCORBA_P.Setup; polyorb-2.8~20110207.orig/src/corba/rtcorba/rtcorba-current.adb0000644000175000017500000001375411750740340023511 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- R T C O R B A . C U R R E N T -- -- -- -- B o d y -- -- -- -- Copyright (C) 2003-2009, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with CORBA.Object; with RTCORBA.PriorityMapping; with PolyORB.CORBA_P.Initial_References; with PolyORB.RTCORBA_P.Setup; with PolyORB.Annotations; with PolyORB.Initialization; with PolyORB.QoS.Priority; with PolyORB.Tasking.Priorities; with PolyORB.Tasking.Threads.Annotations; with PolyORB.Utils.Strings.Lists; package body RTCORBA.Current is use PolyORB.Annotations; use PolyORB.Tasking.Priorities; use PolyORB.Tasking.Threads.Annotations; use PolyORB.QoS.Priority; function Create return CORBA.Object.Ref; -- Create a RTCORBA.Current.Ref ------------ -- Create -- ------------ function Create return CORBA.Object.Ref is Result : Local_Ref; Current : constant PolyORB.Smart_Pointers.Entity_Ptr := new Current_Object; begin Set (Result, Current); return CORBA.Object.Ref (Result); end Create; ---------------------- -- Get_The_Priority -- ---------------------- function Get_The_Priority (Self : Local_Ref) return RTCORBA.Priority is pragma Unreferenced (Self); Note : Thread_Priority_Note; begin Get_Note (Get_Current_Thread_Notepad.all, Note, Default_Note); if Note.Priority = Invalid_Priority then CORBA.Raise_Initialize (CORBA.Default_Sys_Member); end if; return RTCORBA.Priority (Note.Priority); end Get_The_Priority; ---------------------- -- Set_The_Priority -- ---------------------- procedure Set_The_Priority (Self : Local_Ref; To : RTCORBA.Priority) is pragma Unreferenced (Self); use type PolyORB.RTCORBA_P.Setup.PriorityMapping_Access; Success : CORBA.Boolean; New_Priority : RTCORBA.NativePriority; Priority_Mapping : constant PolyORB.RTCORBA_P.Setup.PriorityMapping_Access := PolyORB.RTCORBA_P.Setup.Get_Priority_Mapping; begin -- Consistency check: To is in range 0 .. 32767 if To < 0 then -- Implementation Note: To is a CORBA.Short, thus To < 32767 -- is always true. CORBA.Raise_Bad_Param (CORBA.Default_Sys_Member); end if; -- Compute new priority if Priority_Mapping = null then CORBA.Raise_Internal (CORBA.Default_Sys_Member); end if; RTCORBA.PriorityMapping.To_Native (Priority_Mapping.all, To, New_Priority, Success); if not Success then CORBA.Raise_Data_Conversion (CORBA.System_Exception_Members'(Minor => 2, Completed => CORBA.Completed_No)); end if; declare use PolyORB.Tasking.Threads; Note : Thread_Priority_Note; Notepad : constant Notepad_Access := Get_Current_Thread_Notepad; begin Get_Note (Notepad.all, Note, Default_Note); -- Modify priority if Note.Priority /= External_Priority (New_Priority) or else Get_Priority (Get_Thread_Factory, Current_Task) /= Integer (New_Priority) then Set_Priority (Get_Thread_Factory, Current_Task, Integer (New_Priority)); end if; -- Update current object Note.Priority := External_Priority (To); Set_Note (Notepad.all, Note); end; end Set_The_Priority; ---------------- -- Initialize -- ---------------- procedure Initialize; procedure Initialize is use PolyORB.CORBA_P.Initial_References; begin Register_Initial_Reference ("RTCurrent", Create'Access); end Initialize; use PolyORB.Initialization; use PolyORB.Utils.Strings; use PolyORB.Utils.Strings.Lists; begin Register_Module (Module_Info' (Name => +"rtcorba.current", Conflicts => Empty, Depends => +"corba.initial_references" & "tasking.annotations", Provides => Empty, Implicit => False, Init => Initialize'Access, Shutdown => null)); end RTCORBA.Current; polyorb-2.8~20110207.orig/src/corba/rtcorba/rtcorba-prioritymodelpolicy-helper.adb0000644000175000017500000000664211750740340027424 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- R T C O R B A . P R I O R I T Y M O D E L P O L I C Y . H E L P E R -- -- -- -- B o d y -- -- -- -- Copyright (C) 2004-2007, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ package body RTCORBA.PriorityModelPolicy.Helper is ---------------------------- -- Unchecked_To_Local_Ref -- ---------------------------- function Unchecked_To_Local_Ref (The_Ref : CORBA.Object.Ref'Class) return RTCORBA.PriorityModelPolicy.Local_Ref is Result : RTCORBA.PriorityModelPolicy.Local_Ref; begin Set (Result, CORBA.Object.Object_Of (The_Ref)); return Result; end Unchecked_To_Local_Ref; ------------------ -- To_Local_Ref -- ------------------ function To_Local_Ref (The_Ref : CORBA.Object.Ref'Class) return RTCORBA.PriorityModelPolicy.Local_Ref is begin -- if CORBA.Object.Is_Nil (The_Ref) -- or else CORBA.Object.Is_A (The_Ref, Repository_Id) then -- return Unchecked_To_Local_Ref (The_Ref); -- end if; -- CORBA.Raise_Bad_Param (CORBA.Default_Sys_Member); if The_Ref not in CORBA.Policy.Ref'Class or else CORBA.Policy.Get_Policy_Type (CORBA.Policy.Ref (The_Ref)) /= PRIORITY_MODEL_POLICY_TYPE then CORBA.Raise_Bad_Param (CORBA.Default_Sys_Member); end if; declare Result : Local_Ref; begin CORBA.Policy.Set (CORBA.Policy.Ref (Result), CORBA.Object.Entity_Of (The_Ref)); return Result; end; end To_Local_Ref; end RTCORBA.PriorityModelPolicy.Helper; polyorb-2.8~20110207.orig/src/corba/rtcorba/polyorb-rtcorba_p-prioritymodelpolicy.ads0000644000175000017500000000554411750740340030173 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- POLYORB.RTCORBA_P.PRIORITYMODELPOLICY -- -- -- -- S p e c -- -- -- -- Copyright (C) 2003-2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with PolyORB.CORBA_P.Policy; with PolyORB.Smart_Pointers; with RTCORBA; package PolyORB.RTCORBA_P.PriorityModelPolicy is type PriorityModelPolicy_Type is new PolyORB.CORBA_P.Policy.Policy_Object_Type with private; function Create (Priority_Model : RTCORBA.PriorityModel; Server_Priority : RTCORBA.Priority) return PolyORB.Smart_Pointers.Entity_Ptr; function Get_Priority_Model (Self : PriorityModelPolicy_Type) return RTCORBA.PriorityModel; function Get_Server_Priority (Self : PriorityModelPolicy_Type) return RTCORBA.Priority; private type PriorityModelPolicy_Type is new PolyORB.CORBA_P.Policy.Policy_Object_Type with record Priority_Model : RTCORBA.PriorityModel; Server_Priority : RTCORBA.Priority; end record; end PolyORB.RTCORBA_P.PriorityModelPolicy; polyorb-2.8~20110207.orig/src/corba/rtcorba/rtcorba-mutex-helper.ads0000644000175000017500000000532411750740340024461 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- R T C O R B A . M U T E X . H E L P E R -- -- -- -- S p e c -- -- -- -- Copyright (C) 2004-2008, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the CORBA Specification, and adapted -- -- for use with PolyORB. The copyright notice above, and the license -- -- provisions that follow apply solely to the contents neither explicitly -- -- nor implicitly specified by the CORBA Specification defined by the OMG. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with CORBA.Object; package RTCORBA.Mutex.Helper is pragma Elaborate_Body; function Unchecked_To_Local_Ref (The_Ref : CORBA.Object.Ref'Class) return RTCORBA.Mutex.Local_Ref; function To_Local_Ref (The_Ref : CORBA.Object.Ref'Class) return RTCORBA.Mutex.Local_Ref; end RTCORBA.Mutex.Helper; polyorb-2.8~20110207.orig/src/corba/rtcorba/rtcosscheduling-clientscheduler-impl.adb0000644000175000017500000001064711750740340027705 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- RTCOSSCHEDULING.CLIENTSCHEDULER.IMPL -- -- -- -- B o d y -- -- -- -- Copyright (C) 2005-2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with PolyORB.Log; with PolyORB.Parameters.File; with CORBA.ORB; with RTCORBA.Current.Helper; with RTCosScheduling.Helper; package body RTCosScheduling.ClientScheduler.Impl is use PolyORB.Log; package L is new PolyORB.Log.Facility_Log ("rtcosscheduling.clientscheduler.impl"); procedure O (Message : Standard.String; Level : Log_Level := Debug) renames L.Output; function C (Level : Log_Level := Debug) return Boolean renames L.Enabled; ----------------------------- -- Load_Configuration_File -- ----------------------------- procedure Load_Configuration_File (Conf_File_Name : String) is begin PolyORB.Parameters.File.Load_Configuration_File (Conf_File_Name); end Load_Configuration_File; ----------------------- -- Schedule_Activity -- ----------------------- procedure Schedule_Activity (Self : access Object; Activity_Name : CORBA.String) is pragma Unreferenced (Self); Priority : Integer; Current : constant RTCORBA.Current.Local_Ref := RTCORBA.Current.Helper.To_Local_Ref (CORBA.ORB.Resolve_Initial_References (CORBA.ORB.To_CORBA_String ("RTCurrent"))); begin pragma Debug (C, O ("Configuring activity: " & CORBA.To_String (Activity_Name))); Priority := PolyORB.Parameters.Get_Conf ("activity " & CORBA.To_String (Activity_Name), "priority"); pragma Debug (C, O ("Set priority to:" & Integer'Image (Priority))); RTCORBA.Current.Set_The_Priority (Current, RTCORBA.Priority (Priority)); exception when others => -- For now, we cannot distinguish between an inconsistent -- value of the priority, and an unknown activity. RTCosScheduling.Helper.Raise_UnknownName (UnknownName_Members' (CORBA.IDL_Exception_Members with null record)); end Schedule_Activity; ---------- -- Is_A -- ---------- function Is_A (Self : not null access Object; Logical_Type_Id : Standard.String) return Boolean is pragma Unreferenced (Self); begin return CORBA.Is_Equivalent (Logical_Type_Id, RTCosScheduling.ClientScheduler.Repository_Id) or else CORBA.Is_Equivalent (Logical_Type_Id, "IDL:omg.org/CORBA/Object:1.0"); end Is_A; end RTCosScheduling.ClientScheduler.Impl; polyorb-2.8~20110207.orig/src/corba/rtcorba/rtportableserver-poa.ads0000644000175000017500000000774311750740340024601 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- R T P O R T A B L E S E R V E R . P O A -- -- -- -- S p e c -- -- -- -- Copyright (C) 2004-2008, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the CORBA Specification, and adapted -- -- for use with PolyORB. The copyright notice above, and the license -- -- provisions that follow apply solely to the contents neither explicitly -- -- nor implicitly specified by the CORBA Specification defined by the OMG. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with CORBA.Object; with PortableServer.POA; with RTCORBA; package RTPortableServer.POA is -- Implementation Note: RT-CORBA specifications states these -- functions may fail and raise CORBA.BAD_PARAM if the priority -- parameter doest not match the priority configuration for -- ressources assigned to the POA. -- -- As a consequence, PolyORB will raise BAD_PARAM if either the -- POA doest not support a ThreadPoolPolicy or if the set up of -- attached ThreadPoolPolicy doest not match the priority -- parameter. type Local_Ref is new PortableServer.POA.Local_Ref with private; function Create_Reference_With_Priority (Self : Local_Ref; Intf : CORBA.RepositoryId; Priority : RTCORBA.Priority) return CORBA.Object.Ref; function Create_Reference_With_Id_And_Priority (Self : Local_Ref; Oid : PortableServer.ObjectId; Intf : CORBA.RepositoryId; Priority : RTCORBA.Priority) return CORBA.Object.Ref; function Activate_Object_With_Priority (Self : Local_Ref; P_Servant : PortableServer.Servant; Priority : RTCORBA.Priority) return PortableServer.ObjectId; procedure Activate_Object_With_Id_And_Priority (Self : Local_Ref; Oid : PortableServer.ObjectId; P_Servant : PortableServer.Servant; Priority : RTCORBA.Priority); Repository_Id : constant Standard.String := "IDL:omg.org/RTPortableServer/POA:1.0"; private type Local_Ref is new PortableServer.POA.Local_Ref with null record; end RTPortableServer.POA; polyorb-2.8~20110207.orig/src/corba/rtcorba/rtcorba-helper.adb0000644000175000017500000010562111750740340023301 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- R T C O R B A . H E L P E R -- -- -- -- B o d y -- -- -- -- Copyright (C) 2004-2007, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ ------------------------------------------------- -- This file has been generated automatically -- by IDLAC version 2.3.0w. -- -- Do NOT hand-modify this file, as your -- changes will be lost when you re-run the -- IDL to Ada compiler. ------------------------------------------------- pragma Style_Checks ("NM32766"); with PolyORB.Utils.Strings; with PolyORB.Initialization; pragma Elaborate_All (PolyORB.Initialization); with RTCORBA.ProtocolProperties.Helper; with IOP.Helper; with CORBA.Object.Helper; with PolyORB.Sequences.Unbounded.CORBA_Helper; pragma Elaborate_All (PolyORB.Sequences.Unbounded.CORBA_Helper); with Ada.Unchecked_Deallocation; with PolyORB.Types; package body RTCORBA.Helper is function From_Any (Item : CORBA.Any) return RTCORBA.NativePriority is begin return RTCORBA.NativePriority (CORBA.Short'(CORBA.From_Any (Item))); end From_Any; function From_Any (C : PolyORB.Any.Any_Container'Class) return RTCORBA.NativePriority is begin return RTCORBA.NativePriority (CORBA.Short'(CORBA.From_Any (C))); end From_Any; function To_Any (Item : RTCORBA.NativePriority) return CORBA.Any is Result : CORBA.Any := CORBA.To_Any (CORBA.Short (Item)); begin CORBA.Internals.Set_Type (Result, TC_NativePriority); return Result; end To_Any; function From_Any (Item : CORBA.Any) return RTCORBA.Priority is begin return RTCORBA.Priority (CORBA.Short'(CORBA.From_Any (Item))); end From_Any; function From_Any (C : PolyORB.Any.Any_Container'Class) return RTCORBA.Priority is begin return RTCORBA.Priority (CORBA.Short'(CORBA.From_Any (C))); end From_Any; function To_Any (Item : RTCORBA.Priority) return CORBA.Any is Result : CORBA.Any := CORBA.To_Any (CORBA.Short (Item)); begin CORBA.Internals.Set_Type (Result, TC_Priority); return Result; end To_Any; function From_Any (Item : CORBA.Any) return RTCORBA.ThreadpoolId is begin return RTCORBA.ThreadpoolId (CORBA.Unsigned_Long'(CORBA.From_Any (Item))); end From_Any; function From_Any (C : PolyORB.Any.Any_Container'Class) return RTCORBA.ThreadpoolId is begin return RTCORBA.ThreadpoolId (CORBA.Unsigned_Long'(CORBA.From_Any (C))); end From_Any; function To_Any (Item : RTCORBA.ThreadpoolId) return CORBA.Any is Result : CORBA.Any := CORBA.To_Any (CORBA.Unsigned_Long (Item)); begin CORBA.Internals.Set_Type (Result, TC_ThreadpoolId); return Result; end To_Any; type Ptr_Ü_ThreadpoolLane is access all RTCORBA.ThreadpoolLane; type Content_Ü_ThreadpoolLane is new PolyORB.Any.Aggregate_Content with record V : Ptr_Ü_ThreadpoolLane; end record; function Get_Aggregate_Element (ACC : not null access Content_Ü_ThreadpoolLane; TC : PolyORB.Any.TypeCode.Object_Ptr; Index : PolyORB.Types.Unsigned_Long; Mech : not null access PolyORB.Any.Mechanism) return PolyORB.Any.Content'Class; function Get_Aggregate_Count (ACC : Content_Ü_ThreadpoolLane) return PolyORB.Types.Unsigned_Long; procedure Set_Aggregate_Count (ACC : in out Content_Ü_ThreadpoolLane; Count : PolyORB.Types.Unsigned_Long); function Clone (ACC : Content_Ü_ThreadpoolLane; Into : PolyORB.Any.Content_Ptr := null) return PolyORB.Any.Content_Ptr; procedure Finalize_Value (ACC : in out Content_Ü_ThreadpoolLane); function Get_Aggregate_Element (ACC : not null access Content_Ü_ThreadpoolLane; TC : PolyORB.Any.TypeCode.Object_Ptr; Index : PolyORB.Types.Unsigned_Long; Mech : not null access PolyORB.Any.Mechanism) return PolyORB.Any.Content'Class is use type PolyORB.Types.Unsigned_Long; use type PolyORB.Any.Mechanism; pragma Unreferenced (TC); begin Mech.all := PolyORB.Any.By_Reference; case Index is when 0 => return CORBA.Wrap (CORBA.Short (ACC.V.lane_priority)'Unrestricted_Access); when 1 => return CORBA.Wrap (ACC.V.static_threads'Unrestricted_Access); when 2 => return CORBA.Wrap (ACC.V.dynamic_threads'Unrestricted_Access); when others => raise Constraint_Error; end case; end Get_Aggregate_Element; function Get_Aggregate_Count (ACC : Content_Ü_ThreadpoolLane) return PolyORB.Types.Unsigned_Long is pragma Unreferenced (ACC); begin return 3; end Get_Aggregate_Count; procedure Set_Aggregate_Count (ACC : in out Content_Ü_ThreadpoolLane; Count : PolyORB.Types.Unsigned_Long) is use type PolyORB.Types.Unsigned_Long; pragma Unreferenced (ACC); begin if Count /= 3 then raise Program_Error; end if; end Set_Aggregate_Count; function Clone (ACC : Content_Ü_ThreadpoolLane; Into : PolyORB.Any.Content_Ptr := null) return PolyORB.Any.Content_Ptr is use type PolyORB.Any.Content_Ptr; Target : PolyORB.Any.Content_Ptr; begin if Into /= null then if Into.all not in Content_Ü_ThreadpoolLane then return null; end if; Target := Into; Content_Ü_ThreadpoolLane (Target.all).V.all := ACC.V.all; else Target := new Content_Ü_ThreadpoolLane; Content_Ü_ThreadpoolLane (Target.all).V := new RTCORBA.ThreadpoolLane'(ACC.V.all); end if; return Target; end Clone; procedure Finalize_Value (ACC : in out Content_Ü_ThreadpoolLane) is procedure Free is new Ada.Unchecked_Deallocation (RTCORBA.ThreadpoolLane, Ptr_Ü_ThreadpoolLane); begin Free (ACC.V); end Finalize_Value; function Wrap (X : access RTCORBA.ThreadpoolLane) return PolyORB.Any.Content'Class is begin return Content_Ü_ThreadpoolLane'(PolyORB.Any.Aggregate_Content with V => Ptr_Ü_ThreadpoolLane (X)); end Wrap; function From_Any (Item : CORBA.Any) return RTCORBA.ThreadpoolLane is Index : CORBA.Any; Result_lane_priority : RTCORBA.Priority; Result_static_threads : CORBA.Unsigned_Long; Result_dynamic_threads : CORBA.Unsigned_Long; begin Index := CORBA.Internals.Get_Aggregate_Element (Item, RTCORBA.Helper.TC_Priority, CORBA.Unsigned_Long ( 0)); Result_lane_priority := RTCORBA.Helper.From_Any (Index); Index := CORBA.Internals.Get_Aggregate_Element (Item, CORBA.TC_Unsigned_Long, CORBA.Unsigned_Long ( 1)); Result_static_threads := CORBA.From_Any (Index); Index := CORBA.Internals.Get_Aggregate_Element (Item, CORBA.TC_Unsigned_Long, CORBA.Unsigned_Long ( 2)); Result_dynamic_threads := CORBA.From_Any (Index); return (lane_priority => Result_lane_priority, static_threads => Result_static_threads, dynamic_threads => Result_dynamic_threads); end From_Any; function To_Any (Item : RTCORBA.ThreadpoolLane) return CORBA.Any is Result : CORBA.Any := CORBA.Internals.Get_Empty_Any_Aggregate (TC_ThreadpoolLane); begin CORBA.Internals.Add_Aggregate_Element (Result, RTCORBA.Helper.To_Any (Item.lane_priority)); CORBA.Internals.Add_Aggregate_Element (Result, CORBA.To_Any (Item.static_threads)); CORBA.Internals.Add_Aggregate_Element (Result, CORBA.To_Any (Item.dynamic_threads)); return Result; end To_Any; function IDL_SEQUENCE_RTCORBA_ThreadpoolLane_Element_Wrap (X : access RTCORBA.ThreadpoolLane) return PolyORB.Any.Content'Class is begin return RTCORBA.Helper.Wrap (X.all'Unrestricted_Access); end IDL_SEQUENCE_RTCORBA_ThreadpoolLane_Element_Wrap; package IDL_SEQUENCE_RTCORBA_ThreadpoolLane_Helper is new IDL_SEQUENCE_RTCORBA_ThreadpoolLane.CORBA_Helper (Element_To_Any => RTCORBA.Helper.To_Any, Element_From_Any => RTCORBA.Helper.From_Any, Element_Wrap => IDL_SEQUENCE_RTCORBA_ThreadpoolLane_Element_Wrap); function From_Any (Item : CORBA.Any) return RTCORBA.IDL_SEQUENCE_RTCORBA_ThreadpoolLane.Sequence renames IDL_SEQUENCE_RTCORBA_ThreadpoolLane_Helper.From_Any; function To_Any (Item : RTCORBA.IDL_SEQUENCE_RTCORBA_ThreadpoolLane.Sequence) return CORBA.Any renames IDL_SEQUENCE_RTCORBA_ThreadpoolLane_Helper.To_Any; function Wrap (X : access RTCORBA.IDL_SEQUENCE_RTCORBA_ThreadpoolLane.Sequence) return PolyORB.Any.Content'Class renames IDL_SEQUENCE_RTCORBA_ThreadpoolLane_Helper.Wrap; function From_Any (Item : CORBA.Any) return RTCORBA.ThreadpoolLanes is begin return RTCORBA.ThreadpoolLanes (RTCORBA.IDL_SEQUENCE_RTCORBA_ThreadpoolLane.Sequence'(RTCORBA.Helper.From_Any (Item))); end From_Any; function To_Any (Item : RTCORBA.ThreadpoolLanes) return CORBA.Any is Result : CORBA.Any := RTCORBA.Helper.To_Any (RTCORBA.IDL_SEQUENCE_RTCORBA_ThreadpoolLane.Sequence (Item)); begin CORBA.Internals.Set_Type (Result, TC_ThreadpoolLanes); return Result; end To_Any; type Ptr_Ü_PriorityModel is access all RTCORBA.PriorityModel; type Content_Ü_PriorityModel is new PolyORB.Any.Aggregate_Content with record V : Ptr_Ü_PriorityModel; Repr_Cache : aliased PolyORB.Types.Unsigned_Long; end record; function Get_Aggregate_Element (ACC : not null access Content_Ü_PriorityModel; TC : PolyORB.Any.TypeCode.Object_Ptr; Index : PolyORB.Types.Unsigned_Long; Mech : not null access PolyORB.Any.Mechanism) return PolyORB.Any.Content'Class; procedure Set_Aggregate_Element (ACC : in out Content_Ü_PriorityModel; TC : PolyORB.Any.TypeCode.Object_Ptr; Index : PolyORB.Types.Unsigned_Long; From_C : in out PolyORB.Any.Any_Container'Class); function Get_Aggregate_Count (ACC : Content_Ü_PriorityModel) return PolyORB.Types.Unsigned_Long; procedure Set_Aggregate_Count (ACC : in out Content_Ü_PriorityModel; Count : PolyORB.Types.Unsigned_Long); function Clone (ACC : Content_Ü_PriorityModel; Into : PolyORB.Any.Content_Ptr := null) return PolyORB.Any.Content_Ptr; procedure Finalize_Value (ACC : in out Content_Ü_PriorityModel); function Get_Aggregate_Element (ACC : not null access Content_Ü_PriorityModel; TC : PolyORB.Any.TypeCode.Object_Ptr; Index : PolyORB.Types.Unsigned_Long; Mech : not null access PolyORB.Any.Mechanism) return PolyORB.Any.Content'Class is use type PolyORB.Types.Unsigned_Long; use type PolyORB.Any.Mechanism; pragma Unreferenced (TC, Index); pragma Suppress (All_Checks); begin ACC.Repr_Cache := RTCORBA.PriorityModel'Pos (ACC.V.all); Mech.all := PolyORB.Any.By_Value; return PolyORB.Any.Wrap (ACC.Repr_Cache'Unrestricted_Access); end Get_Aggregate_Element; procedure Set_Aggregate_Element (ACC : in out Content_Ü_PriorityModel; TC : PolyORB.Any.TypeCode.Object_Ptr; Index : PolyORB.Types.Unsigned_Long; From_C : in out PolyORB.Any.Any_Container'Class) is pragma Unreferenced (TC); use type PolyORB.Types.Unsigned_Long; pragma Assert (Index = 0); begin ACC.V.all := RTCORBA.PriorityModel'Val (PolyORB.Types.Unsigned_Long'(PolyORB.Any.From_Any (From_C))); end Set_Aggregate_Element; function Get_Aggregate_Count (ACC : Content_Ü_PriorityModel) return PolyORB.Types.Unsigned_Long is pragma Unreferenced (ACC); begin return 1; end Get_Aggregate_Count; procedure Set_Aggregate_Count (ACC : in out Content_Ü_PriorityModel; Count : PolyORB.Types.Unsigned_Long) is use type PolyORB.Types.Unsigned_Long; pragma Unreferenced (ACC); begin if Count /= 1 then raise Program_Error; end if; end Set_Aggregate_Count; function Clone (ACC : Content_Ü_PriorityModel; Into : PolyORB.Any.Content_Ptr := null) return PolyORB.Any.Content_Ptr is use type PolyORB.Any.Content_Ptr; Target : PolyORB.Any.Content_Ptr; begin if Into /= null then if Into.all not in Content_Ü_PriorityModel then return null; end if; Target := Into; Content_Ü_PriorityModel (Target.all).V.all := ACC.V.all; else Target := new Content_Ü_PriorityModel; Content_Ü_PriorityModel (Target.all).V := new RTCORBA.PriorityModel'(ACC.V.all); end if; Content_Ü_PriorityModel (Target.all).Repr_Cache:= ACC.Repr_Cache; return Target; end Clone; procedure Finalize_Value (ACC : in out Content_Ü_PriorityModel) is procedure Free is new Ada.Unchecked_Deallocation (RTCORBA.PriorityModel, Ptr_Ü_PriorityModel); begin Free (ACC.V); end Finalize_Value; function Wrap (X : access RTCORBA.PriorityModel) return PolyORB.Any.Content'Class is begin return Content_Ü_PriorityModel'(PolyORB.Any.Aggregate_Content with V => Ptr_Ü_PriorityModel (X), Repr_Cache => 0); end Wrap; function From_Any (C : PolyORB.Any.Any_Container'Class) return RTCORBA.PriorityModel is ACC : PolyORB.Any.Aggregate_Content'Class renames PolyORB.Any.Aggregate_Content'Class (PolyORB.Any.Get_Value (C).all); El_M : aliased PolyORB.Any.Mechanism := PolyORB.Any.By_Value; El_CC : aliased PolyORB.Any.Content'Class := PolyORB.Any.Get_Aggregate_Element (ACC'Access, PolyORB.Any.TC_Unsigned_Long, 0, El_M'Access); El_C : PolyORB.Any.Any_Container; begin PolyORB.Any.Set_Type (El_C, PolyORB.Any.TC_Unsigned_Long); PolyORB.Any.Set_Value (El_C, El_CC'Unchecked_Access); return PriorityModel'Val (PolyORB.Types.Unsigned_Long'(PolyORB.Any.From_Any (El_C))); end From_Any; function From_Any (Item : CORBA.Any) return RTCORBA.PriorityModel is begin return From_Any (CORBA.Get_Container (Item).all); end From_Any; function To_Any (Item : RTCORBA.PriorityModel) return CORBA.Any is Result : CORBA.Any := CORBA.Internals.Get_Empty_Any_Aggregate (TC_PriorityModel); begin CORBA.Internals.Add_Aggregate_Element (Result, CORBA.To_Any (CORBA.Unsigned_Long (PriorityModel'Pos (Item)))); return Result; end To_Any; function Unchecked_To_Ref (The_Ref : CORBA.Object.Ref'Class) return RTCORBA.ProtocolProperties_Forward.Ref is Result : RTCORBA.ProtocolProperties_Forward.Ref; begin ProtocolProperties_Forward.Set (Result, CORBA.Object.Object_Of (The_Ref)); return Result; end Unchecked_To_Ref; function To_Ref (The_Ref : CORBA.Object.Ref'Class) return RTCORBA.ProtocolProperties_Forward.Ref is begin if CORBA.Object.Is_Nil (The_Ref) or else CORBA.Object.Is_A (The_Ref, "IDL:omg.org/RTCORBA/ProtocolProperties:1.0") then return Unchecked_To_Ref (The_Ref); end if; CORBA.Raise_Bad_Param (CORBA.Default_Sys_Member); end To_Ref; type Ptr_Ü_Protocol is access all RTCORBA.Protocol; type Content_Ü_Protocol is new PolyORB.Any.Aggregate_Content with record V : Ptr_Ü_Protocol; end record; function Get_Aggregate_Element (ACC : not null access Content_Ü_Protocol; TC : PolyORB.Any.TypeCode.Object_Ptr; Index : PolyORB.Types.Unsigned_Long; Mech : not null access PolyORB.Any.Mechanism) return PolyORB.Any.Content'Class; function Get_Aggregate_Count (ACC : Content_Ü_Protocol) return PolyORB.Types.Unsigned_Long; procedure Set_Aggregate_Count (ACC : in out Content_Ü_Protocol; Count : PolyORB.Types.Unsigned_Long); function Clone (ACC : Content_Ü_Protocol; Into : PolyORB.Any.Content_Ptr := null) return PolyORB.Any.Content_Ptr; procedure Finalize_Value (ACC : in out Content_Ü_Protocol); function Get_Aggregate_Element (ACC : not null access Content_Ü_Protocol; TC : PolyORB.Any.TypeCode.Object_Ptr; Index : PolyORB.Types.Unsigned_Long; Mech : not null access PolyORB.Any.Mechanism) return PolyORB.Any.Content'Class is use type PolyORB.Types.Unsigned_Long; use type PolyORB.Any.Mechanism; pragma Unreferenced (TC); begin Mech.all := PolyORB.Any.By_Reference; case Index is when 0 => return CORBA.Wrap (CORBA.Unsigned_Long (ACC.V.protocol_type)'Unrestricted_Access); when 1 => return CORBA.Object.Helper.Wrap (CORBA.Object.Ref (ACC.V.orb_protocol_properties)'Unrestricted_Access); when 2 => return CORBA.Object.Helper.Wrap (CORBA.Object.Ref (ACC.V.transport_protocol_properties)'Unrestricted_Access); when others => raise Constraint_Error; end case; end Get_Aggregate_Element; function Get_Aggregate_Count (ACC : Content_Ü_Protocol) return PolyORB.Types.Unsigned_Long is pragma Unreferenced (ACC); begin return 3; end Get_Aggregate_Count; procedure Set_Aggregate_Count (ACC : in out Content_Ü_Protocol; Count : PolyORB.Types.Unsigned_Long) is use type PolyORB.Types.Unsigned_Long; pragma Unreferenced (ACC); begin if Count /= 3 then raise Program_Error; end if; end Set_Aggregate_Count; function Clone (ACC : Content_Ü_Protocol; Into : PolyORB.Any.Content_Ptr := null) return PolyORB.Any.Content_Ptr is use type PolyORB.Any.Content_Ptr; Target : PolyORB.Any.Content_Ptr; begin if Into /= null then if Into.all not in Content_Ü_Protocol then return null; end if; Target := Into; Content_Ü_Protocol (Target.all).V.all := ACC.V.all; else Target := new Content_Ü_Protocol; Content_Ü_Protocol (Target.all).V := new RTCORBA.Protocol'(ACC.V.all); end if; return Target; end Clone; procedure Finalize_Value (ACC : in out Content_Ü_Protocol) is procedure Free is new Ada.Unchecked_Deallocation (RTCORBA.Protocol, Ptr_Ü_Protocol); begin Free (ACC.V); end Finalize_Value; function Wrap (X : access RTCORBA.Protocol) return PolyORB.Any.Content'Class is begin return Content_Ü_Protocol'(PolyORB.Any.Aggregate_Content with V => Ptr_Ü_Protocol (X)); end Wrap; type Ptr_Ü_PriorityBand is access all RTCORBA.PriorityBand; type Content_Ü_PriorityBand is new PolyORB.Any.Aggregate_Content with record V : Ptr_Ü_PriorityBand; end record; function Get_Aggregate_Element (ACC : not null access Content_Ü_PriorityBand; TC : PolyORB.Any.TypeCode.Object_Ptr; Index : PolyORB.Types.Unsigned_Long; Mech : not null access PolyORB.Any.Mechanism) return PolyORB.Any.Content'Class; function Get_Aggregate_Count (ACC : Content_Ü_PriorityBand) return PolyORB.Types.Unsigned_Long; procedure Set_Aggregate_Count (ACC : in out Content_Ü_PriorityBand; Count : PolyORB.Types.Unsigned_Long); function Clone (ACC : Content_Ü_PriorityBand; Into : PolyORB.Any.Content_Ptr := null) return PolyORB.Any.Content_Ptr; procedure Finalize_Value (ACC : in out Content_Ü_PriorityBand); function Get_Aggregate_Element (ACC : not null access Content_Ü_PriorityBand; TC : PolyORB.Any.TypeCode.Object_Ptr; Index : PolyORB.Types.Unsigned_Long; Mech : not null access PolyORB.Any.Mechanism) return PolyORB.Any.Content'Class is use type PolyORB.Types.Unsigned_Long; use type PolyORB.Any.Mechanism; pragma Unreferenced (TC); begin Mech.all := PolyORB.Any.By_Reference; case Index is when 0 => return CORBA.Wrap (CORBA.Short (ACC.V.low)'Unrestricted_Access); when 1 => return CORBA.Wrap (CORBA.Short (ACC.V.high)'Unrestricted_Access); when others => raise Constraint_Error; end case; end Get_Aggregate_Element; function Get_Aggregate_Count (ACC : Content_Ü_PriorityBand) return PolyORB.Types.Unsigned_Long is pragma Unreferenced (ACC); begin return 2; end Get_Aggregate_Count; procedure Set_Aggregate_Count (ACC : in out Content_Ü_PriorityBand; Count : PolyORB.Types.Unsigned_Long) is use type PolyORB.Types.Unsigned_Long; pragma Unreferenced (ACC); begin if Count /= 2 then raise Program_Error; end if; end Set_Aggregate_Count; function Clone (ACC : Content_Ü_PriorityBand; Into : PolyORB.Any.Content_Ptr := null) return PolyORB.Any.Content_Ptr is use type PolyORB.Any.Content_Ptr; Target : PolyORB.Any.Content_Ptr; begin if Into /= null then if Into.all not in Content_Ü_PriorityBand then return null; end if; Target := Into; Content_Ü_PriorityBand (Target.all).V.all := ACC.V.all; else Target := new Content_Ü_PriorityBand; Content_Ü_PriorityBand (Target.all).V := new RTCORBA.PriorityBand'(ACC.V.all); end if; return Target; end Clone; procedure Finalize_Value (ACC : in out Content_Ü_PriorityBand) is procedure Free is new Ada.Unchecked_Deallocation (RTCORBA.PriorityBand, Ptr_Ü_PriorityBand); begin Free (ACC.V); end Finalize_Value; function Wrap (X : access RTCORBA.PriorityBand) return PolyORB.Any.Content'Class is begin return Content_Ü_PriorityBand'(PolyORB.Any.Aggregate_Content with V => Ptr_Ü_PriorityBand (X)); end Wrap; function From_Any (Item : CORBA.Any) return RTCORBA.PriorityBand is Index : CORBA.Any; Result_low : RTCORBA.Priority; Result_high : RTCORBA.Priority; begin Index := CORBA.Internals.Get_Aggregate_Element (Item, RTCORBA.Helper.TC_Priority, CORBA.Unsigned_Long ( 0)); Result_low := RTCORBA.Helper.From_Any (Index); Index := CORBA.Internals.Get_Aggregate_Element (Item, RTCORBA.Helper.TC_Priority, CORBA.Unsigned_Long ( 1)); Result_high := RTCORBA.Helper.From_Any (Index); return (low => Result_low, high => Result_high); end From_Any; function To_Any (Item : RTCORBA.PriorityBand) return CORBA.Any is Result : CORBA.Any := CORBA.Internals.Get_Empty_Any_Aggregate (TC_PriorityBand); begin CORBA.Internals.Add_Aggregate_Element (Result, RTCORBA.Helper.To_Any (Item.low)); CORBA.Internals.Add_Aggregate_Element (Result, RTCORBA.Helper.To_Any (Item.high)); return Result; end To_Any; function IDL_SEQUENCE_RTCORBA_PriorityBand_Element_Wrap (X : access RTCORBA.PriorityBand) return PolyORB.Any.Content'Class is begin return RTCORBA.Helper.Wrap (X.all'Unrestricted_Access); end IDL_SEQUENCE_RTCORBA_PriorityBand_Element_Wrap; package IDL_SEQUENCE_RTCORBA_PriorityBand_Helper is new IDL_SEQUENCE_RTCORBA_PriorityBand.CORBA_Helper (Element_To_Any => RTCORBA.Helper.To_Any, Element_From_Any => RTCORBA.Helper.From_Any, Element_Wrap => IDL_SEQUENCE_RTCORBA_PriorityBand_Element_Wrap); function From_Any (Item : CORBA.Any) return RTCORBA.IDL_SEQUENCE_RTCORBA_PriorityBand.Sequence renames IDL_SEQUENCE_RTCORBA_PriorityBand_Helper.From_Any; function To_Any (Item : RTCORBA.IDL_SEQUENCE_RTCORBA_PriorityBand.Sequence) return CORBA.Any renames IDL_SEQUENCE_RTCORBA_PriorityBand_Helper.To_Any; function Wrap (X : access RTCORBA.IDL_SEQUENCE_RTCORBA_PriorityBand.Sequence) return PolyORB.Any.Content'Class renames IDL_SEQUENCE_RTCORBA_PriorityBand_Helper.Wrap; function From_Any (Item : CORBA.Any) return RTCORBA.PriorityBands is begin return RTCORBA.PriorityBands (RTCORBA.IDL_SEQUENCE_RTCORBA_PriorityBand.Sequence'(RTCORBA.Helper.From_Any (Item))); end From_Any; function To_Any (Item : RTCORBA.PriorityBands) return CORBA.Any is Result : CORBA.Any := RTCORBA.Helper.To_Any (RTCORBA.IDL_SEQUENCE_RTCORBA_PriorityBand.Sequence (Item)); begin CORBA.Internals.Set_Type (Result, TC_PriorityBands); return Result; end To_Any; procedure Deferred_Initialization is begin declare Name : constant CORBA.String := CORBA.To_CORBA_String ("NativePriority"); Id : constant CORBA.String := CORBA.To_CORBA_String ("IDL:omg.org/RTCORBA/NativePriority:1.0"); begin TC_NativePriority := CORBA.TypeCode.Internals.Build_Alias_TC (Name => Name, Id => Id, Parent => CORBA.TC_Short); end; declare Name : constant CORBA.String := CORBA.To_CORBA_String ("Priority"); Id : constant CORBA.String := CORBA.To_CORBA_String ("IDL:omg.org/RTCORBA/Priority:1.0"); begin TC_Priority := CORBA.TypeCode.Internals.Build_Alias_TC (Name => Name, Id => Id, Parent => CORBA.TC_Short); end; declare Name : constant CORBA.String := CORBA.To_CORBA_String ("ThreadpoolId"); Id : constant CORBA.String := CORBA.To_CORBA_String ("IDL:omg.org/RTCORBA/ThreadpoolId:1.0"); begin TC_ThreadpoolId := CORBA.TypeCode.Internals.Build_Alias_TC (Name => Name, Id => Id, Parent => CORBA.TC_Unsigned_Long); end; declare Name : constant CORBA.String := CORBA.To_CORBA_String ("ThreadpoolLane"); Id : constant CORBA.String := CORBA.To_CORBA_String ("IDL:omg.org/RTCORBA/ThreadpoolLane:1.0"); Arg_Name_lane_priority : constant CORBA.String := CORBA.To_CORBA_String ("lane_priority"); Arg_Name_static_threads : constant CORBA.String := CORBA.To_CORBA_String ("static_threads"); Arg_Name_dynamic_threads : constant CORBA.String := CORBA.To_CORBA_String ("dynamic_threads"); begin TC_ThreadpoolLane := CORBA.TypeCode.Internals.To_CORBA_Object (PolyORB.Any.TypeCode.TC_Struct); CORBA.Internals.Add_Parameter (TC_ThreadpoolLane, CORBA.To_Any (Name)); CORBA.Internals.Add_Parameter (TC_ThreadpoolLane, CORBA.To_Any (Id)); CORBA.Internals.Add_Parameter (TC_ThreadpoolLane, CORBA.To_Any (RTCORBA.Helper.TC_Priority)); CORBA.Internals.Add_Parameter (TC_ThreadpoolLane, CORBA.To_Any (Arg_Name_lane_priority)); CORBA.Internals.Add_Parameter (TC_ThreadpoolLane, CORBA.To_Any (CORBA.TC_Unsigned_Long)); CORBA.Internals.Add_Parameter (TC_ThreadpoolLane, CORBA.To_Any (Arg_Name_static_threads)); CORBA.Internals.Add_Parameter (TC_ThreadpoolLane, CORBA.To_Any (CORBA.TC_Unsigned_Long)); CORBA.Internals.Add_Parameter (TC_ThreadpoolLane, CORBA.To_Any (Arg_Name_dynamic_threads)); end; TC_IDL_SEQUENCE_RTCORBA_ThreadpoolLane := CORBA.TypeCode.Internals.Build_Sequence_TC (RTCORBA.Helper.TC_ThreadpoolLane, 0); IDL_SEQUENCE_RTCORBA_ThreadpoolLane_Helper.Initialize (Element_TC => RTCORBA.Helper.TC_ThreadpoolLane, Sequence_TC => TC_IDL_SEQUENCE_RTCORBA_ThreadpoolLane); declare Name : constant CORBA.String := CORBA.To_CORBA_String ("ThreadpoolLanes"); Id : constant CORBA.String := CORBA.To_CORBA_String ("IDL:omg.org/RTCORBA/ThreadpoolLanes:1.0"); begin TC_ThreadpoolLanes := CORBA.TypeCode.Internals.Build_Alias_TC (Name => Name, Id => Id, Parent => RTCORBA.Helper.TC_IDL_SEQUENCE_RTCORBA_ThreadpoolLane); end; declare Name : constant CORBA.String := CORBA.To_CORBA_String ("PriorityModel"); Id : constant CORBA.String := CORBA.To_CORBA_String ("IDL:omg.org/RTCORBA/PriorityModel:1.0"); CLIENT_PROPAGATED_Name : constant CORBA.String := CORBA.To_CORBA_String ("CLIENT_PROPAGATED"); SERVER_DECLARED_Name : constant CORBA.String := CORBA.To_CORBA_String ("SERVER_DECLARED"); begin TC_PriorityModel := CORBA.TypeCode.Internals.To_CORBA_Object (PolyORB.Any.TypeCode.TC_Enum); CORBA.Internals.Add_Parameter (TC_PriorityModel, CORBA.To_Any (Name)); CORBA.Internals.Add_Parameter (TC_PriorityModel, CORBA.To_Any (Id)); CORBA.Internals.Add_Parameter (TC_PriorityModel, CORBA.To_Any (CLIENT_PROPAGATED_Name)); CORBA.Internals.Add_Parameter (TC_PriorityModel, CORBA.To_Any (SERVER_DECLARED_Name)); end; declare Name : constant CORBA.String := CORBA.To_CORBA_String ("ProtocolProperties"); Id : constant CORBA.String := CORBA.To_CORBA_String ("IDL:omg.org/RTCORBA/ProtocolProperties:1.0"); begin TC_ProtocolProperties := CORBA.TypeCode.Internals.To_CORBA_Object (PolyORB.Any.TypeCode.TC_Object); CORBA.Internals.Add_Parameter (TC_ProtocolProperties, CORBA.To_Any (Name)); CORBA.Internals.Add_Parameter (TC_ProtocolProperties, CORBA.To_Any (Id)); end; declare Name : constant CORBA.String := CORBA.To_CORBA_String ("Protocol"); Id : constant CORBA.String := CORBA.To_CORBA_String ("IDL:omg.org/RTCORBA/Protocol:1.0"); Arg_Name_protocol_type : constant CORBA.String := CORBA.To_CORBA_String ("protocol_type"); Arg_Name_orb_protocol_properties : constant CORBA.String := CORBA.To_CORBA_String ("orb_protocol_properties"); Arg_Name_transport_protocol_properties : constant CORBA.String := CORBA.To_CORBA_String ("transport_protocol_properties"); begin TC_Protocol := CORBA.TypeCode.Internals.To_CORBA_Object (PolyORB.Any.TypeCode.TC_Struct); CORBA.Internals.Add_Parameter (TC_Protocol, CORBA.To_Any (Name)); CORBA.Internals.Add_Parameter (TC_Protocol, CORBA.To_Any (Id)); CORBA.Internals.Add_Parameter (TC_Protocol, CORBA.To_Any (IOP.Helper.TC_ProfileId)); CORBA.Internals.Add_Parameter (TC_Protocol, CORBA.To_Any (Arg_Name_protocol_type)); CORBA.Internals.Add_Parameter (TC_Protocol, CORBA.To_Any (RTCORBA.ProtocolProperties.Helper.TC_ProtocolProperties)); CORBA.Internals.Add_Parameter (TC_Protocol, CORBA.To_Any (Arg_Name_orb_protocol_properties)); CORBA.Internals.Add_Parameter (TC_Protocol, CORBA.To_Any (RTCORBA.ProtocolProperties.Helper.TC_ProtocolProperties)); CORBA.Internals.Add_Parameter (TC_Protocol, CORBA.To_Any (Arg_Name_transport_protocol_properties)); end; TC_IDL_SEQUENCE_RTCORBA_Protocol := CORBA.TypeCode.Internals.Build_Sequence_TC (RTCORBA.Helper.TC_Protocol, 0); declare Name : constant CORBA.String := CORBA.To_CORBA_String ("ProtocolList"); Id : constant CORBA.String := CORBA.To_CORBA_String ("IDL:omg.org/RTCORBA/ProtocolList:1.0"); begin TC_ProtocolList := CORBA.TypeCode.Internals.Build_Alias_TC (Name => Name, Id => Id, Parent => RTCORBA.Helper.TC_IDL_SEQUENCE_RTCORBA_Protocol); end; declare Name : constant CORBA.String := CORBA.To_CORBA_String ("PriorityBand"); Id : constant CORBA.String := CORBA.To_CORBA_String ("IDL:omg.org/RTCORBA/PriorityBand:1.0"); Arg_Name_low : constant CORBA.String := CORBA.To_CORBA_String ("low"); Arg_Name_high : constant CORBA.String := CORBA.To_CORBA_String ("high"); begin TC_PriorityBand := CORBA.TypeCode.Internals.To_CORBA_Object (PolyORB.Any.TypeCode.TC_Struct); CORBA.Internals.Add_Parameter (TC_PriorityBand, CORBA.To_Any (Name)); CORBA.Internals.Add_Parameter (TC_PriorityBand, CORBA.To_Any (Id)); CORBA.Internals.Add_Parameter (TC_PriorityBand, CORBA.To_Any (RTCORBA.Helper.TC_Priority)); CORBA.Internals.Add_Parameter (TC_PriorityBand, CORBA.To_Any (Arg_Name_low)); CORBA.Internals.Add_Parameter (TC_PriorityBand, CORBA.To_Any (RTCORBA.Helper.TC_Priority)); CORBA.Internals.Add_Parameter (TC_PriorityBand, CORBA.To_Any (Arg_Name_high)); end; TC_IDL_SEQUENCE_RTCORBA_PriorityBand := CORBA.TypeCode.Internals.Build_Sequence_TC (RTCORBA.Helper.TC_PriorityBand, 0); IDL_SEQUENCE_RTCORBA_PriorityBand_Helper.Initialize (Element_TC => RTCORBA.Helper.TC_PriorityBand, Sequence_TC => TC_IDL_SEQUENCE_RTCORBA_PriorityBand); declare Name : constant CORBA.String := CORBA.To_CORBA_String ("PriorityBands"); Id : constant CORBA.String := CORBA.To_CORBA_String ("IDL:omg.org/RTCORBA/PriorityBands:1.0"); begin TC_PriorityBands := CORBA.TypeCode.Internals.Build_Alias_TC (Name => Name, Id => Id, Parent => RTCORBA.Helper.TC_IDL_SEQUENCE_RTCORBA_PriorityBand); end; end Deferred_Initialization; begin declare use PolyORB.Initialization; use PolyORB.Initialization.String_Lists; use PolyORB.Utils.Strings; begin Register_Module (Module_Info' (Name => +"RTCORBA.Helper", Conflicts => PolyORB.Initialization.String_Lists.Empty, Depends => +"any" , Provides => PolyORB.Initialization.String_Lists.Empty, Implicit => False, Init => Deferred_Initialization'Access, Shutdown => null)); end; end RTCORBA.Helper; polyorb-2.8~20110207.orig/src/corba/rtcorba/rtcorba-protocolproperties-helper.adb0000644000175000017500000001007111750740340027247 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- R T C O R B A . P R O T O C O L P R O P E R T I E S . H E L P E R -- -- -- -- B o d y -- -- -- -- Copyright (C) 2007, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ pragma Style_Checks ("NM32766"); with PolyORB.Utils.Strings; with PolyORB.Initialization; pragma Elaborate_All (PolyORB.Initialization); with PolyORB.Any; package body RTCORBA.ProtocolProperties.Helper is function Unchecked_To_Local_Ref (The_Ref : CORBA.Object.Ref'Class) return RTCORBA.ProtocolProperties.Local_Ref is Result : RTCORBA.ProtocolProperties.Local_Ref; begin Set (Result, CORBA.Object.Object_Of (The_Ref)); return Result; end Unchecked_To_Local_Ref; function To_Local_Ref (The_Ref : CORBA.Object.Ref'Class) return RTCORBA.ProtocolProperties.Local_Ref is begin if CORBA.Object.Is_Nil (The_Ref) or else CORBA.Object.Is_A (The_Ref, Repository_Id) then return Unchecked_To_Local_Ref (The_Ref); end if; CORBA.Raise_Bad_Param (CORBA.Default_Sys_Member); end To_Local_Ref; procedure Deferred_Initialization is begin declare Name : constant CORBA.String := CORBA.To_CORBA_String ("ProtocolProperties"); Id : constant CORBA.String := CORBA.To_CORBA_String ("IDL:omg.org/RTCORBA/ProtocolProperties:1.0"); begin TC_ProtocolProperties := CORBA.TypeCode.Internals.To_CORBA_Object (PolyORB.Any.TypeCode.TC_Object); CORBA.Internals.Add_Parameter (TC_ProtocolProperties, CORBA.To_Any (Name)); CORBA.Internals.Add_Parameter (TC_ProtocolProperties, CORBA.To_Any (Id)); end; end Deferred_Initialization; begin declare use PolyORB.Initialization; use PolyORB.Initialization.String_Lists; use PolyORB.Utils.Strings; begin Register_Module (Module_Info' (Name => +"RTCORBA.ProtocolProperties.Helper", Conflicts => PolyORB.Initialization.String_Lists.Empty, Depends => +"any" , Provides => PolyORB.Initialization.String_Lists.Empty, Implicit => False, Init => Deferred_Initialization'Access, Shutdown => null)); end; end RTCORBA.ProtocolProperties.Helper; polyorb-2.8~20110207.orig/src/corba/rtcorba/rtcorba-threadpoolpolicy.adb0000644000175000017500000001277111750740340025406 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- R T C O R B A . T H R E A D P O O L P O L I C Y -- -- -- -- B o d y -- -- -- -- Copyright (C) 2003-2007, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with PolyORB.CORBA_P.POA_Config; with PolyORB.CORBA_P.Policy; with PolyORB.CORBA_P.Policy_Management; with PolyORB.Initialization; with PolyORB.Lanes; with PolyORB.POA_Policies; with PolyORB.RTCORBA_P.ThreadPoolManager; with PolyORB.RT_POA_Policies.Thread_Pool_Policy; with PolyORB.Smart_Pointers; with PolyORB.Utils.Strings; with RTCORBA.ThreadpoolPolicy.Helper; package body RTCORBA.ThreadpoolPolicy is use CORBA; use CORBA.Policy; use CORBA.TypeCode; use PolyORB.CORBA_P.Policy; use PolyORB.CORBA_P.Policy_Management; function Create_ThreadpoolPolicy (The_Type : CORBA.PolicyType; Value : CORBA.Any) return CORBA.Policy.Ref; ----------------------------- -- Create_ThreadpoolPolicy -- ----------------------------- function Create_ThreadpoolPolicy (The_Type : CORBA.PolicyType; Value : CORBA.Any) return CORBA.Policy.Ref is begin pragma Assert (The_Type = THREADPOOL_POLICY_TYPE); if Get_Type (Value) /= CORBA.TC_Unsigned_Long then Raise_PolicyError ((Reason => BAD_POLICY_TYPE)); end if; declare Result : CORBA.Policy.Ref; Entity : constant PolyORB.Smart_Pointers.Entity_Ptr := new Policy_Object_Type; begin Set_Policy_Type (Policy_Object_Type (Entity.all), The_Type); Set_Policy_Value (Policy_Object_Type (Entity.all), Value); CORBA.Policy.Set (Result, Entity); return Result; end; end Create_ThreadpoolPolicy; -------------------- -- Get_Threadpool -- -------------------- function Get_Threadpool (Self : Local_Ref) return RTCORBA.ThreadpoolId is begin return From_Any (Get_Policy_Value (Policy_Object_Type (Entity_Of (CORBA.Policy.Ref (Self)).all))); end Get_Threadpool; ---------------------------------- -- Thread_Pool_Policy_Allocator -- ---------------------------------- function Thread_Pool_Policy_Allocator (Self : CORBA.Policy.Ref) return PolyORB.POA_Policies.Policy_Access; function Thread_Pool_Policy_Allocator (Self : CORBA.Policy.Ref) return PolyORB.POA_Policies.Policy_Access is use PolyORB.RT_POA_Policies.Thread_Pool_Policy; use PolyORB.RTCORBA_P.ThreadPoolManager; use RTCORBA.ThreadpoolPolicy.Helper; Lanes : constant PolyORB.Lanes.Lane_Root_Access := Lane (Get_Threadpool (To_Local_Ref (Self))); begin return Create (Lanes); end Thread_Pool_Policy_Allocator; ---------------- -- Initialize -- ---------------- procedure Initialize; procedure Initialize is begin PolyORB.CORBA_P.POA_Config.Register (THREADPOOL_POLICY_TYPE, Thread_Pool_Policy_Allocator'Access); Register (The_Type => THREADPOOL_POLICY_TYPE, POA_Level => True, Factory => Create_ThreadpoolPolicy'Access, System_Default => Create_ThreadpoolPolicy (THREADPOOL_POLICY_TYPE, To_Any (CORBA.Unsigned_Long (0)))); end Initialize; use PolyORB.Initialization; use PolyORB.Initialization.String_Lists; use PolyORB.Utils.Strings; begin Register_Module (Module_Info' (Name => +"rtcorba-threadpoolpolicy", Conflicts => Empty, Depends => +"rt_poa", Provides => Empty, Implicit => False, Init => Initialize'Access, Shutdown => null)); end RTCORBA.ThreadpoolPolicy; polyorb-2.8~20110207.orig/src/corba/rtcorba/rtcorba-rtorb-helper.adb0000644000175000017500000001552711750740340024434 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- R T C O R B A . R T O R B . H E L P E R -- -- -- -- B o d y -- -- -- -- Copyright (C) 2004-2008, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ ------------------------------------------------- -- This file has been generated automatically -- by IDLAC version 2.3.0w. -- -- Do NOT hand-modify this file, as your -- changes will be lost when you re-run the -- IDL to Ada compiler. ------------------------------------------------- pragma Style_Checks ("NM32766"); with PolyORB.Utils.Strings; with PolyORB.Initialization; pragma Elaborate_All (PolyORB.Initialization); with PolyORB.Exceptions; with PolyORB.Std; with PolyORB.Any; package body RTCORBA.RTORB.Helper is function Unchecked_To_Local_Ref (The_Ref : CORBA.Object.Ref'Class) return RTCORBA.RTORB.Local_Ref is Result : RTCORBA.RTORB.Local_Ref; begin Set (Result, CORBA.Object.Object_Of (The_Ref)); return Result; end Unchecked_To_Local_Ref; function To_Local_Ref (The_Ref : CORBA.Object.Ref'Class) return RTCORBA.RTORB.Local_Ref is begin -- XXX This implementation should use the canonical code, as -- generated by idlac. This would require CORBA.Object.Is_A to be -- modified to recognize the designated built-in entity type as valid -- for this logical type. -- if CORBA.Object.Is_Nil (The_Ref) -- or else CORBA.Object.Is_A (The_Ref, Repository_Id) -- then -- return Unchecked_To_Ref (The_Ref); -- end if; -- -- CORBA.Raise_Bad_Param (CORBA.Default_Sys_Member); if CORBA.Object.Entity_Of (The_Ref).all not in RTCORBA.RTORB.RTORB_Object'Class then CORBA.Raise_Bad_Param (CORBA.Default_Sys_Member); end if; return Unchecked_To_Local_Ref (The_Ref); end To_Local_Ref; function From_Any (Item : CORBA.Any) return RTCORBA.RTORB.InvalidThreadpool_Members is Result : InvalidThreadpool_Members; pragma Warnings (Off); pragma Unreferenced (Item); pragma Warnings (On); begin return Result; end From_Any; function To_Any (Item : RTCORBA.RTORB.InvalidThreadpool_Members) return CORBA.Any is Result : constant CORBA.Any := CORBA.Internals.Get_Empty_Any_Aggregate (TC_InvalidThreadpool); pragma Warnings (Off); pragma Unreferenced (Item); pragma Warnings (On); begin return Result; end To_Any; procedure Raise_InvalidThreadpool_From_Any (Item : PolyORB.Any.Any; Message : PolyORB.Std.String); pragma No_Return (Raise_InvalidThreadpool_From_Any); procedure Raise_InvalidThreadpool_From_Any (Item : PolyORB.Any.Any; Message : PolyORB.Std.String) is Members : constant InvalidThreadpool_Members := From_Any (CORBA.Any (Item)); begin PolyORB.Exceptions.User_Raise_Exception (InvalidThreadpool'Identity, Members, Message); end Raise_InvalidThreadpool_From_Any; procedure Raise_InvalidThreadpool (Members : InvalidThreadpool_Members) is begin PolyORB.Exceptions.User_Raise_Exception (InvalidThreadpool'Identity, Members); end Raise_InvalidThreadpool; procedure Deferred_Initialization is begin declare Name : constant CORBA.String := CORBA.To_CORBA_String ("RTORB"); Id : constant CORBA.String := CORBA.To_CORBA_String ("IDL:omg.org/RTCORBA/RTORB:1.0"); begin TC_RTORB := CORBA.TypeCode.Internals.To_CORBA_Object (PolyORB.Any.TypeCode.TC_Object); CORBA.Internals.Add_Parameter (TC_RTORB, CORBA.To_Any (Name)); CORBA.Internals.Add_Parameter (TC_RTORB, CORBA.To_Any (Id)); end; declare Name : constant CORBA.String := CORBA.To_CORBA_String ("InvalidThreadpool"); Id : constant CORBA.String := CORBA.To_CORBA_String ("IDL:omg.org/RTCORBA/RTORB/InvalidThreadpool:1.0"); begin TC_InvalidThreadpool := CORBA.TypeCode.Internals.To_CORBA_Object (PolyORB.Any.TypeCode.TC_Except); CORBA.Internals.Add_Parameter (TC_InvalidThreadpool, CORBA.To_Any (Name)); CORBA.Internals.Add_Parameter (TC_InvalidThreadpool, CORBA.To_Any (Id)); end; PolyORB.Exceptions.Register_Exception (CORBA.TypeCode.Internals.To_PolyORB_Object (TC_InvalidThreadpool), Raise_InvalidThreadpool_From_Any'Access); end Deferred_Initialization; begin declare use PolyORB.Initialization; use PolyORB.Initialization.String_Lists; use PolyORB.Utils.Strings; begin Register_Module (Module_Info' (Name => +"RTCORBA.RTORB.Helper", Conflicts => PolyORB.Initialization.String_Lists.Empty, Depends => +"any" & "exceptions" , Provides => PolyORB.Initialization.String_Lists.Empty, Implicit => False, Init => Deferred_Initialization'Access, Shutdown => null)); end; end RTCORBA.RTORB.Helper; polyorb-2.8~20110207.orig/src/corba/rtcorba/rtcorba.ads0000644000175000017500000001530011750740340022037 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- R T C O R B A -- -- -- -- S p e c -- -- -- -- Copyright (C) 2004-2008, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the CORBA Specification, and adapted -- -- for use with PolyORB. The copyright notice above, and the license -- -- provisions that follow apply solely to the contents neither explicitly -- -- nor implicitly specified by the CORBA Specification defined by the OMG. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ ------------------------------------------------- -- This file has been generated automatically -- by IDLAC version 2.3.0w. -- -- Do NOT hand-modify this file, as your -- changes will be lost when you re-run the -- IDL to Ada compiler. ------------------------------------------------- pragma Style_Checks ("NM32766"); with IOP; with CORBA.Forward; pragma Elaborate_All (CORBA.Forward); with CORBA.Sequences.Unbounded; pragma Elaborate_All (CORBA.Sequences.Unbounded); with PolyORB.Std; with CORBA; with PolyORB.RT_POA_Policies.Priority_Model_Policy; package RTCORBA is type NativePriority is new CORBA.Short; NativePriority_Repository_Id : constant PolyORB.Std.String := "IDL:omg.org/RTCORBA/NativePriority:1.0"; type Priority is new CORBA.Short; Priority_Repository_Id : constant PolyORB.Std.String := "IDL:omg.org/RTCORBA/Priority:1.0"; minPriority : constant RTCORBA.Priority := 0; maxPriority : constant RTCORBA.Priority := 32767; -- Type PriorityMapping is implementation defined; -- Type PriorityTransform is implementation defined; type ThreadpoolId is new CORBA.Unsigned_Long; ThreadpoolId_Repository_Id : constant PolyORB.Std.String := "IDL:omg.org/RTCORBA/ThreadpoolId:1.0"; type ThreadpoolLane is record lane_priority : RTCORBA.Priority; static_threads : CORBA.Unsigned_Long; dynamic_threads : CORBA.Unsigned_Long; end record; ThreadpoolLane_Repository_Id : constant PolyORB.Std.String := "IDL:omg.org/RTCORBA/ThreadpoolLane:1.0"; package IDL_SEQUENCE_RTCORBA_ThreadpoolLane is new CORBA.Sequences.Unbounded (RTCORBA.ThreadpoolLane); type ThreadpoolLanes is new RTCORBA.IDL_SEQUENCE_RTCORBA_ThreadpoolLane.Sequence; ThreadpoolLanes_Repository_Id : constant PolyORB.Std.String := "IDL:omg.org/RTCORBA/ThreadpoolLanes:1.0"; use type CORBA.PolicyType; PRIORITY_MODEL_POLICY_TYPE : constant CORBA.PolicyType := 40; type PriorityModel is new PolyORB.RT_POA_Policies.Priority_Model_Policy.Priority_Model; -- Implementation Note: this is equivalent to -- type PriorityModel is (CLIENT_PROPAGATED, SERVER_DECLARED); PriorityModel_Repository_Id : constant PolyORB.Std.String := "IDL:omg.org/RTCORBA/PriorityModel:1.0"; -- Interface PriorityModelPolicy THREADPOOL_POLICY_TYPE : constant CORBA.PolicyType := 41; -- Interface ThreadpoolPolicy package ProtocolProperties_Forward is new CORBA.Forward; -- Interface ProtocolProperties type Protocol is record protocol_type : IOP.ProfileId; orb_protocol_properties : RTCORBA.ProtocolProperties_Forward.Ref; transport_protocol_properties : RTCORBA.ProtocolProperties_Forward.Ref; end record; Protocol_Repository_Id : constant PolyORB.Std.String := "IDL:omg.org/RTCORBA/Protocol:1.0"; package IDL_SEQUENCE_RTCORBA_Protocol is new CORBA.Sequences.Unbounded (RTCORBA.Protocol); type ProtocolList is new RTCORBA.IDL_SEQUENCE_RTCORBA_Protocol.Sequence; ProtocolList_Repository_Id : constant PolyORB.Std.String := "IDL:omg.org/RTCORBA/ProtocolList:1.0"; SERVER_PROTOCOL_POLICY_TYPE : constant CORBA.PolicyType := 42; -- Interface ServerProtocolPolicy CLIENT_PROTOCOL_POLICY_TYPE : constant CORBA.PolicyType := 43; -- Interface ClientProtocolPolicy PRIVATE_CONNECTION_POLICY_TYPE : constant CORBA.PolicyType := 44; -- Interface PrivateConnectionPolicy -- Interface TCPProtocolProperties type PriorityBand is record low : RTCORBA.Priority; high : RTCORBA.Priority; end record; PriorityBand_Repository_Id : constant PolyORB.Std.String := "IDL:omg.org/RTCORBA/PriorityBand:1.0"; package IDL_SEQUENCE_RTCORBA_PriorityBand is new CORBA.Sequences.Unbounded (RTCORBA.PriorityBand); type PriorityBands is new RTCORBA.IDL_SEQUENCE_RTCORBA_PriorityBand.Sequence; PriorityBands_Repository_Id : constant PolyORB.Std.String := "IDL:omg.org/RTCORBA/PriorityBands:1.0"; PRIORITY_BANDED_CONNECTION_POLICY_TYPE : constant CORBA.PolicyType := 45; -- Interface PriorityBandedConnectionPolicy -- Interface Current -- Interface Mutex -- Interface RTORB Repository_Id : constant PolyORB.Std.String := "IDL:omg.org/RTCORBA:1.0"; end RTCORBA; polyorb-2.8~20110207.orig/src/corba/rtcorba/polyorb-rtcorba_p-prioritymodelpolicy.adb0000644000175000017500000000642011750740340030144 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- POLYORB.RTCORBA_P.PRIORITYMODELPOLICY -- -- -- -- B o d y -- -- -- -- Copyright (C) 2003-2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ package body PolyORB.RTCORBA_P.PriorityModelPolicy is ------------ -- Create -- ------------ function Create (Priority_Model : RTCORBA.PriorityModel; Server_Priority : RTCORBA.Priority) return PolyORB.Smart_Pointers.Entity_Ptr is Result : constant PolyORB.CORBA_P.Policy.Policy_Object_Ptr := new PriorityModelPolicy_Type; TResult : PriorityModelPolicy_Type renames PriorityModelPolicy_Type (Result.all); begin Set_Policy_Type (TResult, RTCORBA.PRIORITY_MODEL_POLICY_TYPE); TResult.Priority_Model := Priority_Model; TResult.Server_Priority := Server_Priority; return PolyORB.Smart_Pointers.Entity_Ptr (Result); end Create; ------------------------ -- Get_Priority_Model -- ------------------------ function Get_Priority_Model (Self : PriorityModelPolicy_Type) return RTCORBA.PriorityModel is begin return Self.Priority_Model; end Get_Priority_Model; ------------------------- -- Get_Server_Priority -- ------------------------- function Get_Server_Priority (Self : PriorityModelPolicy_Type) return RTCORBA.Priority is begin return Self.Server_Priority; end Get_Server_Priority; end PolyORB.RTCORBA_P.PriorityModelPolicy; polyorb-2.8~20110207.orig/src/corba/rtcorba/rtcorba-mutex-helper.adb0000644000175000017500000000555611750740340024447 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- R T C O R B A . M U T E X . H E L P E R -- -- -- -- B o d y -- -- -- -- Copyright (C) 2004-2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ package body RTCORBA.Mutex.Helper is ---------------------------- -- Unchecked_To_Local_Ref -- ---------------------------- function Unchecked_To_Local_Ref (The_Ref : CORBA.Object.Ref'Class) return RTCORBA.Mutex.Local_Ref is Result : RTCORBA.Mutex.Local_Ref; begin Set (Result, CORBA.Object.Object_Of (The_Ref)); return Result; end Unchecked_To_Local_Ref; ------------------ -- To_Local_Ref -- ------------------ function To_Local_Ref (The_Ref : CORBA.Object.Ref'Class) return RTCORBA.Mutex.Local_Ref is begin if CORBA.Object.Is_Nil (The_Ref) or else CORBA.Object.Is_A (The_Ref, Repository_Id) then return Unchecked_To_Local_Ref (The_Ref); end if; CORBA.Raise_Bad_Param (CORBA.Default_Sys_Member); end To_Local_Ref; end RTCORBA.Mutex.Helper; polyorb-2.8~20110207.orig/src/corba/corba-current-impl.ads0000644000175000017500000000541511750740337022470 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- C O R B A . C U R R E N T . I M P L -- -- -- -- S p e c -- -- -- -- Copyright (C) 2006-2008, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the CORBA Specification, and adapted -- -- for use with PolyORB. The copyright notice above, and the license -- -- provisions that follow apply solely to the contents neither explicitly -- -- nor implicitly specified by the CORBA Specification defined by the OMG. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- Root implementation type for CORBA::Current (empty placeholder, used to -- allow using the default implementation template to implement interfaces -- derived from CORBA::Current). with CORBA.Impl; package CORBA.Current.Impl is type Object is new CORBA.Impl.Object with private; private type Object is new CORBA.Impl.Object with null record; end CORBA.Current.Impl; polyorb-2.8~20110207.orig/src/corba/security/0000755000175000017500000000000011750740340020126 5ustar xavierxavierpolyorb-2.8~20110207.orig/src/corba/security/polyorb-corba_p-css_state_machine_actions.adb0000644000175000017500000002546011750740340031070 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- POLYORB.CORBA_P.CSS_STATE_MACHINE_ACTIONS -- -- -- -- B o d y -- -- -- -- Copyright (C) 2005-2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with Ada.Streams; with PolyORB.Annotations; with PolyORB.CORBA_P.Security_Current; with PolyORB.Security.Authentication_Mechanisms; with PolyORB.Security.Authority_Mechanisms; with PolyORB.Security.Transport_Mechanisms; with PolyORB.Tasking.Threads.Annotations; package body PolyORB.CORBA_P.CSS_State_Machine_Actions is use PolyORB.Security.Authentication_Mechanisms; use PolyORB.Security.Types; ---------------------- -- Complete_Context -- ---------------------- procedure Complete_Context (Connection : PolyORB.Security.Connections.Connection_Access; Client_Context_Id : PolyORB.Security.Types.Context_Id; Context_Stateful : Boolean; Final_Context_Token : PolyORB.Security.Types.Stream_Element_Array_Access) is pragma Unreferenced (Connection); pragma Unreferenced (Client_Context_Id); pragma Unreferenced (Context_Stateful); pragma Unreferenced (Final_Context_Token); begin null; end Complete_Context; ---------------------------- -- Get_Client_Credentials -- ---------------------------- function Get_Client_Credentials (Policy : PolyORB.CORBA_P.Security_Policy.Client_Policy; Mechanism : PolyORB.QoS.Clients_Security.Client_Mechanism_Access) return PolyORB.Security.Credentials.Credentials_Ref is use PolyORB.Security.Credentials; use PolyORB.Security.Transport_Mechanisms; Credentials_Supports : Association_Options; Failed : Boolean; Result : Credentials_Ref; begin -- At this point we should decide to use only own credentials -- or create special credentials which contained selected own -- credentials (for transport layer and authentication layer) and -- received credentials (for creation of identity assertion token and -- authorization token at attribute layer). -- Find appropriate credentials in Security Manager own credentials -- XXX CORBA Security Service: we also need to analize Invocation -- Credentials Policy. In proper order, of course. for J in Policy.Invocation_Credentials'Range loop Credentials_Supports := 0; Failed := False; -- Is current credentials satisfy Transport Mechanism level -- requirements? if Mechanism.Transport /= null and then Target_Supports (Mechanism.Transport) /= 0 then -- Transport layer is security aware if Is_Supports (Mechanism.Transport, Policy.Invocation_Credentials (J)) then Credentials_Supports := Credentials_Supports or Get_Invocation_Options_Supported (Credentials_Access (Entity_Of (Policy.Invocation_Credentials (J)))); else Failed := True; end if; end if; -- Is current credentials satisfy Authentication Mechanism level -- requirements? if Mechanism.Authentication_Mechanism /= null then -- Authentication layer present if Is_Supports (Mechanism.Authentication_Mechanism, Policy.Invocation_Credentials (J)) then Credentials_Supports := Credentials_Supports or Get_Invocation_Options_Supported (Credentials_Access (Entity_Of (Policy.Invocation_Credentials (J)))); elsif Mechanism.Authentication_Required then -- Authentication layer required but not suppoted Failed := True; end if; end if; -- XXX Delegation??? if not Failed and then Is_Set (Policy.Client_Requires, Credentials_Supports) then Result := Policy.Invocation_Credentials (J); exit; end if; end loop; return Result; end Get_Client_Credentials; ------------------------- -- Get_Context_Element -- ------------------------- function Get_Context_Element (Policy : PolyORB.CORBA_P.Security_Policy.Client_Policy; Mechanism : PolyORB.QoS.Clients_Security.Client_Mechanism_Access; Credentials : PolyORB.Security.Credentials.Credentials_Ref; Connection : PolyORB.Security.Connections.Connection_Access) return Context_Element is pragma Unreferenced (Connection); use PolyORB.CORBA_P.Security_Current; use PolyORB.Security.Authority_Mechanisms; use PolyORB.Security.Authority_Mechanisms.Client_Authority_Mechanism_Lists; use PolyORB.Security.Authorization_Elements; use PolyORB.Security.Identities; Authentication_Token : Stream_Element_Array_Access; Identity_Token : Identity_Access; Authorization_Token : Authorization_Element_Lists.List; Current_Note : Security_Current_Note; Success : Boolean; begin PolyORB.Annotations.Get_Note (PolyORB.Tasking.Threads.Annotations.Get_Current_Thread_Notepad.all, Current_Note, Empty_Security_Current_Note); if Mechanism.Authentication_Mechanism /= null then if Mechanism.Authentication_Required or else Is_Set (Establish_Trust_In_Client, Policy.Client_Requires) then Authentication_Token := new Ada.Streams.Stream_Element_Array' (PolyORB.Security.Authentication_Mechanisms.Init_Security_Context (Mechanism.Authentication_Mechanism, Credentials)); end if; end if; -- Retrieve authorization token from the privilege authority if Mechanism.Authorities /= Client_Authority_Mechanism_Lists.Empty then Get_Authorization_Token (Element (Mechanism.Authorities, 0).all, Identity_Token, Authorization_Token, Success); -- XXX Error processing should be investigated. end if; if Mechanism.Identity_Assertion and then Current_Note.Access_Identity /= null and then Identity_Token = null then Identity_Token := Duplicate (Current_Note.Access_Identity); end if; if Authentication_Token = null and then Identity_Token = null then return Context_Element'(Kind => No_Element); else return Context_Element' (Kind => Establish_Context, Client_Context_Id => 0, Client_Authentication_Token => Authentication_Token, Identity_Token => Identity_Token, Authorization_Token => Authorization_Token); end if; end Get_Context_Element; ------------------- -- Get_Mechanism -- ------------------- procedure Get_Mechanism (Policy : PolyORB.CORBA_P.Security_Policy.Client_Policy; Configuration : PolyORB.QoS.Clients_Security.Client_Mechanism_Lists.List; Mechanism : out PolyORB.QoS.Clients_Security.Client_Mechanism_Access; Success : out Boolean) is use PolyORB.QoS.Clients_Security; use PolyORB.QoS.Clients_Security.Client_Mechanism_Lists; Iter : Iterator := First (Configuration); begin Mechanism := null; Success := False; -- If target supports only unprotected invocations and client don't -- requires any protection then process unprotected invocation if Last (Iter) and then Policy.Client_Requires = 0 then Success := True; end if; -- Otherwise try to find mechanism which satisfy client's requirements while not Last (Iter) loop if Is_Set (Policy.Client_Requires, Target_Supports (Value (Iter).all.all)) then Mechanism := Value (Iter).all; Success := True; return; end if; Next (Iter); end loop; end Get_Mechanism; ------------------------ -- Invalidate_Context -- ------------------------ procedure Invalidate_Context (Connection : PolyORB.Security.Connections.Connection_Access; Client_Context_Id : PolyORB.Security.Types.Context_Id) is pragma Unreferenced (Connection); pragma Unreferenced (Client_Context_Id); begin null; end Invalidate_Context; procedure Invalidate_Context (Connection : PolyORB.Security.Connections.Connection_Access; Client_Context_Id : PolyORB.Security.Types.Context_Id; Error_Token : PolyORB.Security.Types.Stream_Element_Array_Access) is pragma Unreferenced (Connection); pragma Unreferenced (Client_Context_Id); pragma Unreferenced (Error_Token); begin null; end Invalidate_Context; end PolyORB.CORBA_P.CSS_State_Machine_Actions; polyorb-2.8~20110207.orig/src/corba/security/polyorb-corba_p-tss_state_machine.ads0000644000175000017500000000430511750740340027405 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . C O R B A _ P . T S S _ S T A T E _ M A C H I N E -- -- -- -- S p e c -- -- -- -- Copyright (C) 2005-2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- CORBA CSI Version 2 Client Security Service State Machine Implementation package PolyORB.CORBA_P.TSS_State_Machine is pragma Elaborate_Body; end PolyORB.CORBA_P.TSS_State_Machine; polyorb-2.8~20110207.orig/src/corba/security/polyorb-corba_p-css_state_machine_actions.ads0000644000175000017500000001304211750740340031102 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- POLYORB.CORBA_P.CSS_STATE_MACHINE_ACTIONS -- -- -- -- S p e c -- -- -- -- Copyright (C) 2005-2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- CORBA CSI Version 2 Client Security Service State Machine Actions with PolyORB.CORBA_P.Security_Policy; with PolyORB.QoS.Clients_Security; with PolyORB.Security.Authorization_Elements; with PolyORB.Security.Identities; with PolyORB.Security.Connections; with PolyORB.Security.Credentials; with PolyORB.Security.Types; package PolyORB.CORBA_P.CSS_State_Machine_Actions is package PS renames PolyORB.Security; type Context_Element_Kind is (No_Element, Establish_Context, Message_In_Context); type Context_Element (Kind : Context_Element_Kind) is record case Kind is when No_Element => null; when Establish_Context | Message_In_Context => Client_Context_Id : PolyORB.Security.Types.Context_Id; case Kind is when No_Element => null; when Establish_Context => Authorization_Token : PS.Authorization_Elements.Authorization_Element_Lists.List; Identity_Token : PolyORB.Security.Identities.Identity_Access; Client_Authentication_Token : PolyORB.Security.Types.Stream_Element_Array_Access; when Message_In_Context => Discard_Context : Boolean; end case; end case; end record; procedure Get_Mechanism (Policy : PolyORB.CORBA_P.Security_Policy.Client_Policy; Configuration : PolyORB.QoS.Clients_Security.Client_Mechanism_Lists.List; Mechanism : out PolyORB.QoS.Clients_Security.Client_Mechanism_Access; Success : out Boolean); -- Select a compound mechanism that satisfy client policy. Mechanism -- may be null iff target don't have security support. Success -- should be set to True iff compound mechanism that satisfy client -- policy has been found. function Get_Client_Credentials (Policy : PolyORB.CORBA_P.Security_Policy.Client_Policy; Mechanism : PolyORB.QoS.Clients_Security.Client_Mechanism_Access) return PolyORB.Security.Credentials.Credentials_Ref; -- Return the client credentials as necessary to satisfy client policy -- and then target policy in the mechanism function Get_Context_Element (Policy : PolyORB.CORBA_P.Security_Policy.Client_Policy; Mechanism : PolyORB.QoS.Clients_Security.Client_Mechanism_Access; Credentials : PolyORB.Security.Credentials.Credentials_Ref; Connection : PolyORB.Security.Connections.Connection_Access) return Context_Element; -- In the scope of connection, use the client credentials to create -- context element that satisfies the client policy and the target -- policy in mechanism procedure Invalidate_Context (Connection : PolyORB.Security.Connections.Connection_Access; Client_Context_Id : PolyORB.Security.Types.Context_Id); procedure Invalidate_Context (Connection : PolyORB.Security.Connections.Connection_Access; Client_Context_Id : PolyORB.Security.Types.Context_Id; Error_Token : PolyORB.Security.Types.Stream_Element_Array_Access); -- Mark context in connection scope as invalid procedure Complete_Context (Connection : PolyORB.Security.Connections.Connection_Access; Client_Context_Id : PolyORB.Security.Types.Context_Id; Context_Stateful : Boolean; Final_Context_Token : PolyORB.Security.Types.Stream_Element_Array_Access); end PolyORB.CORBA_P.CSS_State_Machine_Actions; polyorb-2.8~20110207.orig/src/corba/security/polyorb-corba_p-security_policy.ads0000644000175000017500000000536511750740340027145 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . C O R B A _ P . S E C U R I T Y _ P O L I C Y -- -- -- -- S p e c -- -- -- -- Copyright (C) 2005-2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with CORBA.Policy; with PolyORB.References; with PolyORB.Security.Credentials; with PolyORB.Security.Types; package PolyORB.CORBA_P.Security_Policy is type Client_Policy (Length : Natural) is record Client_Requires : PolyORB.Security.Types.Association_Options; Invocation_Credentials : PolyORB.Security.Credentials.Credentials_List (1 .. Length); end record; function Get_Client_Policy (Object : PolyORB.References.Ref) return Client_Policy; type Convert_Client_Policy is access function (Policy : CORBA.Policy.Ref) return Client_Policy; procedure Register_Client_Policy (The_Type : CORBA.PolicyType; Convertor : Convert_Client_Policy); end PolyORB.CORBA_P.Security_Policy; polyorb-2.8~20110207.orig/src/corba/security/polyorb-corba_p-tss_state_machine.adb0000644000175000017500000004431611750740340027372 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . C O R B A _ P . T S S _ S T A T E _ M A C H I N E -- -- -- -- B o d y -- -- -- -- Copyright (C) 2005-2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with Ada.Unchecked_Deallocation; with PolyORB.Annotations; with PolyORB.ASN1; with PolyORB.Binding_Data; with PolyORB.CORBA_P.Interceptors_Hooks; with PolyORB.CORBA_P.Security_Current; with PolyORB.CORBA_P.TSS_State_Machine_Actions; with PolyORB.Errors; with PolyORB.Initialization; with PolyORB.Log; with PolyORB.Obj_Adapter_QoS; with PolyORB.Parameters; with PolyORB.POA; with PolyORB.QoS.Security_Contexts; with PolyORB.QoS.Targets_Security; with PolyORB.QoS.Transport_Contexts; with PolyORB.References; with PolyORB.Requests; with PolyORB.Request_QoS; with PolyORB.Security.Authentication_Mechanisms; with PolyORB.Security.Authority_Mechanisms; with PolyORB.Security.Backward_Trust_Evaluators; with PolyORB.Security.Forward_Trust_Evaluators; with PolyORB.Security.Credentials; with PolyORB.Security.Security_Manager; with PolyORB.Security.Transport_Mechanisms; with PolyORB.Security.Types; with PolyORB.Tasking.Threads.Annotations; with PolyORB.Types; with PolyORB.Utils.Strings; package body PolyORB.CORBA_P.TSS_State_Machine is use PolyORB.CORBA_P.Interceptors_Hooks; use PolyORB.Log; use PolyORB.QoS; use PolyORB.QoS.Transport_Contexts; package L is new PolyORB.Log.Facility_Log ("polyorb.corba_p.tss_state_machine"); procedure O (Message : String; Level : Log_Level := Debug) renames L.Output; function C (Level : Log_Level := Debug) return Boolean renames L.Enabled; procedure POA_Create (POA : PolyORB.POA.Obj_Adapter_Access; Error : in out PolyORB.Errors.Error_Container); procedure Server_Invoke (Self : access PSPCE.Entity'Class; Request : access PolyORB.Requests.Request; Profile : PolyORB.Binding_Data.Profile_Access); procedure Throw_SAS_No_Permission (Request : access PolyORB.Requests.Request; Context_Id : PolyORB.Security.Types.Context_Id; Major : PolyORB.Types.Long; Minor : PolyORB.Types.Long; Error_Token : PolyORB.Security.Types.Stream_Element_Array_Access; Reply_QoS : out PolyORB.QoS.Security_Contexts.QoS_Security_Context_Parameter_Access); -- Issue NO_PERMISSION system exception with SAS ContextError service -- context as result of execution of request procedure Initialize; Legacy_POA_Create : PolyORB.CORBA_P.Interceptors_Hooks.POA_Create_Handler; Legacy_Server_Invoke : PolyORB.CORBA_P.Interceptors_Hooks.Server_Invoke_Handler; ---------------- -- Initialize -- ---------------- procedure Initialize is begin Legacy_POA_Create := PolyORB.CORBA_P.Interceptors_Hooks.POA_Create; PolyORB.CORBA_P.Interceptors_Hooks.POA_Create := POA_Create'Access; Legacy_Server_Invoke := PolyORB.CORBA_P.Interceptors_Hooks.Server_Invoke; PolyORB.CORBA_P.Interceptors_Hooks.Server_Invoke := Server_Invoke'Access; end Initialize; ---------------- -- POA_Create -- ---------------- procedure POA_Create (POA : PolyORB.POA.Obj_Adapter_Access; Error : in out PolyORB.Errors.Error_Container) is use PolyORB.Obj_Adapter_QoS; use PolyORB.Parameters; use PolyORB.QoS.Targets_Security; use PolyORB.QoS.Targets_Security.Target_Mechanism_Lists; use PolyORB.Security.Authentication_Mechanisms; use PolyORB.Security.Transport_Mechanisms; use PolyORB.Security.Types; procedure Free is new Ada.Unchecked_Deallocation (QoS_Target_Security_Parameter, QoS_Target_Security_Parameter_Access); Creds : constant PolyORB.Security.Credentials.Credentials_List := PolyORB.Security.Security_Manager.Own_Credentials; begin declare use PolyORB.Security.Authority_Mechanisms; use PolyORB.Security.Backward_Trust_Evaluators; use PolyORB.Security.Forward_Trust_Evaluators; use PolyORB.Security.Types.OID_Lists; use PolyORB.ASN1; Disable_Unprotected : constant Boolean := Get_Conf (POA.Name.all, "disable_unprotected", False); Transport_Mechanism_Name : constant String := Get_Conf (POA.Name.all, "transport_mechanism", ""); Authentication_Mechanism_Name : constant String := Get_Conf (POA.Name.all, "authentication_mechanism", "none"); Authentication_Required : constant Boolean := Get_Conf (POA.Name.all, "authentication_required", False); Backward_Trust_Rules_File : constant String := Get_Conf (POA.Name.all, "backward_trust_rules_file", ""); Privilege_Authorities : constant String := Get_Conf (POA.Name.all, "privilege_authorities", ""); QoS : QoS_Target_Security_Parameter_Access := new QoS_Target_Security_Parameter; CM : constant Target_Mechanism_Access := new Target_Mechanism; Identity_Types : Identity_Token_Type := 0; Naming_Mechanisms : OID_Lists.List; procedure Copy_Naming_Mechanisms (NM : OID_Lists.List); ---------------------------- -- Copy_Naming_Mechanisms -- ---------------------------- procedure Copy_Naming_Mechanisms (NM : OID_Lists.List) is Iter : OID_Lists.Iterator := First (NM); begin while not Last (Iter) loop Append (Naming_Mechanisms, Duplicate (Value (Iter).all)); Next (Iter); end loop; end Copy_Naming_Mechanisms; begin QoS.Stateful := False; QoS.Disable_Unprotected := Disable_Unprotected; -- Transport Mechanism if Transport_Mechanism_Name /= "" then CM.Transport := PolyORB.Security.Security_Manager.Get_Transport_Mechanism (Transport_Mechanism_Name); if CM.Transport = null then raise Program_Error; end if; Identity_Types := Supported_Identity_Types (CM.Transport); Copy_Naming_Mechanisms (Supported_Naming_Mechanisms (CM.Transport)); else CM.Transport := null; end if; -- Authentication layer if Authentication_Mechanism_Name /= "none" then CM.Authentication_Mechanism := PolyORB.Security.Authentication_Mechanisms. Create_Target_Mechanism (Authentication_Mechanism_Name); CM.Authentication_Required := Authentication_Required; Identity_Types := Identity_Types or Get_Supported_Identity_Types (CM.Authentication_Mechanism); Copy_Naming_Mechanisms (Get_Supported_Naming_Mechanisms (CM.Authentication_Mechanism)); else CM.Authentication_Mechanism := null; CM.Authentication_Required := False; end if; -- Privilege authorities if Privilege_Authorities /= "" then Target_Authority_Mechanism_Lists.Append (CM.Authorities, Create_Target_Authority_Mechanism (Privilege_Authorities)); end if; -- Backward trust evaluation if Backward_Trust_Rules_File /= "" then CM.Backward_Trust_Evaluator := Create_Backward_Trust_Evaluator (Backward_Trust_Rules_File); else CM.Backward_Trust_Evaluator := null; end if; -- Forward trust evaluation CM.Forward_Trust_Evaluator := null; CM.Delegation_Required := False; -- Not supported yet -- Supported identity types and naming mechanisms if CM.Backward_Trust_Evaluator /= null or else CM.Forward_Trust_Evaluator /= null then if Identity_Types = 0 then raise Program_Error; end if; CM.Naming_Mechanisms := Naming_Mechanisms; CM.Identity_Types := Identity_Types; else CM.Identity_Types := 0; end if; -- Credentials if Creds'Length /= 0 then -- XXX Here should be more useful way to select accepting -- credentials Set_Accepting_Credentials (CM.all, Creds (Creds'First)); end if; Append (QoS.Mechanisms, CM); if Target_Supports (CM.all) /= 0 then Set_Object_Adapter_QoS (POA, Compound_Security, QoS_Parameter_Access (QoS)); else Release_Contents (QoS); Free (QoS); end if; end; if Legacy_POA_Create /= null then Legacy_POA_Create (POA, Error); end if; end POA_Create; ------------------- -- Server_Invoke -- ------------------- procedure Server_Invoke (Self : access PSPCE.Entity'Class; Request : access PolyORB.Requests.Request; Profile : PolyORB.Binding_Data.Profile_Access) is use PolyORB.CORBA_P.Security_Current; use PolyORB.CORBA_P.TSS_State_Machine_Actions; use PolyORB.QoS.Security_Contexts; use PolyORB.Request_QoS; use PolyORB.Security.Types; Request_QoS : constant QoS_Security_Context_Parameter_Access := QoS_Security_Context_Parameter_Access (Extract_Request_Parameter (Compound_Security, Request.all)); Transport_QoS : constant QoS_Transport_Context_Parameter_Access := QoS_Transport_Context_Parameter_Access (Extract_Request_Parameter (Transport_Security, Request.all)); Reply_QoS : QoS_Security_Context_Parameter_Access; Stateful : Boolean; Context_Accepted : Boolean := False; Token : Stream_Element_Array_Access; Save_Note : Security_Current_Note; Aux_Note : Security_Current_Note; begin -- Store Security Current note, it will be replaced inside -- Accept_Transport_Context or Accept_Context iff context accepted PolyORB.Annotations.Get_Note (PolyORB.Tasking.Threads.Annotations.Get_Current_Thread_Notepad.all, Save_Note, Empty_Security_Current_Note); -- Check is SAS Service Context present if Request_QoS = null then if not Accept_Transport_Context (Profile, Transport_QoS) then declare use PolyORB.Errors; Error : Error_Container; begin pragma Debug (C, O ("Transport context without SAS message not accepted")); Throw (Error, No_Permission_E, System_Exception_Members' (Minor => 0, Completed => Completed_No)); PolyORB.Requests.Set_Exception (Request.all, Error); end; else Context_Accepted := True; end if; else case Request_QoS.Context_Kind is when Establish_Context => declare Status : Accept_Context_Status; Reference : PolyORB.References.Ref; begin Accept_Context (Profile, Transport_QoS, Request_QoS.Client_Context_Id, Request_QoS.Client_Authentication_Token, Request_QoS.Identity_Token, Request_QoS.Authorization_Token, Status, Stateful, Reference, Token); case Status is when Success => Context_Accepted := True; when Invalid_Evidence => Throw_SAS_No_Permission (Request, Request_QoS.Client_Context_Id, 1, 1, Token, Reply_QoS); when Invalid_Mechanism => Throw_SAS_No_Permission (Request, Request_QoS.Client_Context_Id, 2, 1, Token, Reply_QoS); when Policy_Change => raise Program_Error; when Conflicting_Evidence => Throw_SAS_No_Permission (Request, Request_QoS.Client_Context_Id, 3, 1, Token, Reply_QoS); end case; end; when Complete_Establish_Context => raise Program_Error; when Context_Error => raise Program_Error; when Message_In_Context => declare Success : Boolean; begin Reference_Context (Transport_QoS, Request_QoS.Client_Context_Id, Success, Token); if not Success then Throw_SAS_No_Permission (Request, Request_QoS.Client_Context_Id, 4, 1, Token, Reply_QoS); else -- XXX Should be called after complete of request -- processing Discard_Context (Transport_QoS, Request_QoS.Client_Context_Id); end if; end; end case; end if; if Context_Accepted then Legacy_Server_Invoke (Self, Request, Profile); if Request_QoS /= null then Reply_QoS := new QoS_Security_Context_Parameter (Complete_Establish_Context); Reply_QoS.Client_Context_Id := Request_QoS.Client_Context_Id; Reply_QoS.Context_Stateful := Stateful; Reply_QoS.Final_Context_Token := Token; end if; end if; Add_Reply_QoS (Request.all, Compound_Security, QoS_Parameter_Access (Reply_QoS)); -- Destroy current Security Current note if Context_Accepted then PolyORB.Annotations.Get_Note (PolyORB.Tasking.Threads.Annotations.Get_Current_Thread_Notepad.all, Aux_Note); Destroy (Aux_Note); end if; -- Restore original Security Current note PolyORB.Annotations.Set_Note (PolyORB.Tasking.Threads.Annotations.Get_Current_Thread_Notepad.all, Save_Note); end Server_Invoke; ----------------------------- -- Throw_SAS_No_Permission -- ----------------------------- procedure Throw_SAS_No_Permission (Request : access PolyORB.Requests.Request; Context_Id : PolyORB.Security.Types.Context_Id; Major : PolyORB.Types.Long; Minor : PolyORB.Types.Long; Error_Token : PolyORB.Security.Types.Stream_Element_Array_Access; Reply_QoS : out PolyORB.QoS.Security_Contexts.QoS_Security_Context_Parameter_Access) is use PolyORB.Errors; use PolyORB.QoS.Security_Contexts; Error : Error_Container; begin Throw (Error, No_Permission_E, System_Exception_Members'(Minor => 0, Completed => Completed_No)); PolyORB.Requests.Set_Exception (Request.all, Error); Reply_QoS := new QoS_Security_Context_Parameter (Context_Error); Reply_QoS.Client_Context_Id := Context_Id; Reply_QoS.Major_Status := Major; Reply_QoS.Minor_Status := Minor; Reply_QoS.Error_Token := Error_Token; end Throw_SAS_No_Permission; begin declare use PolyORB.Initialization; use PolyORB.Initialization.String_Lists; use PolyORB.Utils.Strings; begin Register_Module (Module_Info' (Name => +"polyorb.corba_p.security.tss_state_machine", Conflicts => Empty, Depends => +"corba.request" & "portableserver" & "polyorb.corba_p.interceptors?", Provides => Empty, Implicit => False, Init => Initialize'Access, Shutdown => null)); end; end PolyORB.CORBA_P.TSS_State_Machine; polyorb-2.8~20110207.orig/src/corba/security/polyorb-corba_p-tss_state_machine_actions.ads0000644000175000017500000001041411750740340031123 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- POLYORB.CORBA_P.TSS_STATE_MACHINE_ACTIONS -- -- -- -- S p e c -- -- -- -- Copyright (C) 2005-2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- CORBA CSI Version 2 Client Security Service State Machine Actions with PolyORB.Binding_Data; with PolyORB.QoS.Transport_Contexts; with PolyORB.References; with PolyORB.Security.Authorization_Elements; with PolyORB.Security.Identities; with PolyORB.Security.Types; package PolyORB.CORBA_P.TSS_State_Machine_Actions is package PS renames PolyORB.Security; type Accept_Context_Status is (Success, Invalid_Evidence, Invalid_Mechanism, Policy_Change, Conflicting_Evidence); function Accept_Transport_Context (Profile : PolyORB.Binding_Data.Profile_Access; Transport : PolyORB.QoS.Transport_Contexts.QoS_Transport_Context_Parameter_Access) return Boolean; -- Validate the request, arrives without a SAS protocol message procedure Accept_Context (Profile : PolyORB.Binding_Data.Profile_Access; Transport : PolyORB.QoS.Transport_Contexts.QoS_Transport_Context_Parameter_Access; Client_Context_Id : PolyORB.Security.Types.Context_Id; Client_Authentication_Token : PolyORB.Security.Types.Stream_Element_Array_Access; Identity_Token : PolyORB.Security.Identities.Identity_Access; Authorization_Token : PS.Authorization_Elements.Authorization_Element_Lists.List; Status : out Accept_Context_Status; Stateful : out Boolean; Reference : out PolyORB.References.Ref; Final_Token : out PolyORB.Security.Types.Stream_Element_Array_Access); -- Validates the security context procedure Reference_Context (Transport : PolyORB.QoS.Transport_Contexts.QoS_Transport_Context_Parameter_Access; Client_Context_Id : PolyORB.Security.Types.Context_Id; Status : out Boolean; Final_Token : out PolyORB.Security.Types.Stream_Element_Array_Access); -- procedure Discard_Context (Transport : PolyORB.QoS.Transport_Contexts.QoS_Transport_Context_Parameter_Access; Client_Context_Id : PolyORB.Security.Types.Context_Id); -- Delete context end PolyORB.CORBA_P.TSS_State_Machine_Actions; polyorb-2.8~20110207.orig/src/corba/security/polyorb-corba_p-tss_state_machine_actions.adb0000644000175000017500000004565311750740340031117 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- POLYORB.CORBA_P.TSS_STATE_MACHINE_ACTIONS -- -- -- -- B o d y -- -- -- -- Copyright (C) 2005-2008, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with PolyORB.Annotations; with PolyORB.CORBA_P.Security_Current; with PolyORB.Errors; with PolyORB.Log; with PolyORB.Obj_Adapter_QoS; with PolyORB.POA; with PolyORB.POA_Types; with PolyORB.QoS.Targets_Security; with PolyORB.Security.Authentication_Mechanisms; with PolyORB.Security.Authority_Mechanisms; with PolyORB.Security.Backward_Trust_Evaluators; with PolyORB.Security.Credentials.Compound; with PolyORB.Security.Forward_Trust_Evaluators; with PolyORB.Security.Identities.Anonymous; with PolyORB.Security.Transport_Mechanisms; with PolyORB.Tasking.Threads.Annotations; with PolyORB.Types; package body PolyORB.CORBA_P.TSS_State_Machine_Actions is use PolyORB.CORBA_P.Security_Current; use PolyORB.Log; use PolyORB.Security.Backward_Trust_Evaluators; use PolyORB.Security.Credentials; use PolyORB.Security.Credentials.Compound; use PolyORB.Security.Forward_Trust_Evaluators; use PolyORB.Security.Identities.Anonymous; use PolyORB.Security.Transport_Mechanisms; package L is new PolyORB.Log.Facility_Log ("polyorb.corba_p.tss_state_machine_actions"); procedure O (Message : String; Level : Log_Level := Debug) renames L.Output; function C (Level : Log_Level := Debug) return Boolean renames L.Enabled; function Get_Object_Adapter_Security_Configuration (Profile : PolyORB.Binding_Data.Profile_Access) return QoS.Targets_Security.QoS_Target_Security_Parameter_Access; -- Retrieve Profile's Object Adapter Security Configuration -------------------- -- Accept_Context -- -------------------- procedure Accept_Context (Profile : PolyORB.Binding_Data.Profile_Access; Transport : PolyORB.QoS.Transport_Contexts.QoS_Transport_Context_Parameter_Access; Client_Context_Id : PolyORB.Security.Types.Context_Id; Client_Authentication_Token : PolyORB.Security.Types.Stream_Element_Array_Access; Identity_Token : PolyORB.Security.Identities.Identity_Access; Authorization_Token : PS.Authorization_Elements.Authorization_Element_Lists.List; Status : out Accept_Context_Status; Stateful : out Boolean; Reference : out PolyORB.References.Ref; Final_Token : out PolyORB.Security.Types.Stream_Element_Array_Access) is pragma Unreferenced (Client_Context_Id); pragma Unreferenced (Reference); use PolyORB.QoS.Targets_Security; use PolyORB.QoS.Transport_Contexts; use PolyORB.Security.Authorization_Elements; use PolyORB.Security.Authorization_Elements.Authorization_Element_Lists; use PolyORB.Security.Authentication_Mechanisms; use PolyORB.Security.Identities; use PolyORB.Security.Authority_Mechanisms; use PolyORB.Security.Authority_Mechanisms. Target_Authority_Mechanism_Lists; use PolyORB.Security.Types; QoS : QoS_Target_Security_Parameter_Access; Mech : Target_Mechanism_Access; Client_Identity : Identity_Access := null; Target_Identity : constant Identity_Access := null; Current_Note : Security_Current_Note; Forward_Done : Boolean := False; begin -- Extract Object's POA security configuration QoS := Get_Object_Adapter_Security_Configuration (Profile); -- Iff security support for object adapter not configured (and we -- have request with SAS message) then reject request if QoS = null or else Target_Mechanism_Lists.Length (QoS.Mechanisms) = 0 then Status := Invalid_Mechanism; pragma Warnings (Off); -- "Stateful" not set before return return; pragma Warnings (On); end if; Mech := Target_Mechanism_Lists.Element (QoS.Mechanisms, 0).all; -- Initial values Status := Success; Stateful := False; Final_Token := null; -- Accepting transport context if Transport = null then if Mech.Transport /= null then Status := Invalid_Mechanism; return; end if; elsif Mech.Transport /= Transport.Transport then Status := Invalid_Mechanism; return; end if; -- Authenticate client -- If target support client authentication and request contains -- client authentication token, then authenticate cleint if Mech.Authentication_Mechanism /= null and then Client_Authentication_Token /= null then declare Success : Boolean; begin Accept_Security_Context (Mech.Authentication_Mechanism, Client_Authentication_Token, Success, Final_Token, Client_Identity); if not Success then Status := Invalid_Evidence; return; end if; end; -- If request contains client authentication token, or target -- requires client authentication and request not contains client -- authentication token then report client authentication failure elsif Mech.Authentication_Required or else Client_Authentication_Token /= null then Status := Invalid_Evidence; return; end if; -- If no authentication layer client identity, then use transport layer -- client identity if Client_Identity = null and then Transport /= null then Client_Identity := Get_Transport_Identity (Compound_Credentials_Access (Entity_Of (Transport.Invocation_Credentials))); end if; -- If target not supports identity assertion but identity token present -- then reject request if Identity_Token /= null and then Mech.Forward_Trust_Evaluator = null and then Mech.Backward_Trust_Evaluator = null then Status := Invalid_Evidence; return; end if; -- If target supports authorization token delivery and request contains -- authorization token, then check: -- - is authorization token elements signed by trusted authority -- - is authorization token elements identity same with identity token -- or authentication identity if Mech.Authorities /= Target_Authority_Mechanism_Lists.Empty and then Authorization_Token /= Authorization_Element_Lists.Empty then declare Element_Iter : Authorization_Element_Lists.Iterator := First (Authorization_Token); Signed : Boolean; begin while not Last (Element_Iter) loop Signed := False; -- Check authorization element signed by privilege authority declare Authority_Iter : Target_Authority_Mechanism_Lists.Iterator := First (Mech.Authorities); begin while not Last (Authority_Iter) loop if Verify (Value (Authority_Iter).all, Value (Element_Iter).all) then Signed := True; exit; end if; Next (Authority_Iter); end loop; end; if not Signed then Status := Invalid_Evidence; return; end if; -- Check identity in identity token same as authorization -- element identity if Identity_Token /= null then if not Is_Holder (Value (Element_Iter).all, Identity_Token) then Status := Invalid_Evidence; return; end if; -- Or, check authentication identity same as authorization -- element identity elsif Client_Identity /= null then if not Is_Holder (Value (Element_Iter).all, Client_Identity) then Status := Invalid_Evidence; return; end if; end if; Next (Element_Iter); end loop; end; -- If target not supports authorization token delivery and authorization -- token present or target supports authorization token delivery and -- no authorization token present, then reject request elsif Mech.Authorities /= Target_Authority_Mechanism_Lists.Empty or else Authorization_Token /= Authorization_Element_Lists.Empty then Status := Invalid_Evidence; return; end if; -- If asserted identity present, authentication identity present and -- authorization token also present, then do forward trust evaluation if Client_Identity /= null and then Identity_Token /= null and then Authorization_Token /= Authorization_Element_Lists.Empty and then Mech.Forward_Trust_Evaluator /= null then declare Trusted : Boolean; begin Status := Invalid_Evidence; Evaluate_Trust (Mech.Forward_Trust_Evaluator, Target_Identity, Client_Identity, Authorization_Token, Mech.Authorities /= Target_Authority_Mechanism_Lists.Empty, Forward_Done, Trusted); -- If authorization elements don't have information for forward -- trust evaluation, then process backward trust evaluation if not Forward_Done then Status := Success; elsif Trusted then Status := Success; else Status := Invalid_Evidence; end if; end; end if; -- If itendity token present, authentication identity present and -- no authorization token or authorization token don't have proxy -- info attributes, then proceed backward trust evaluation if Client_Identity /= null and then Identity_Token /= null and then not Forward_Done then declare Trusted : Boolean := False; begin if Mech.Backward_Trust_Evaluator /= null then Evaluate_Trust (Mech.Backward_Trust_Evaluator, Client_Identity, Identity_Token, Trusted); end if; if not Trusted then Status := Invalid_Evidence; Destroy (Client_Identity); return; end if; end; end if; -- All checks done, prepare Security Current note if Identity_Token /= null then Current_Note.Access_Identity := Duplicate (Identity_Token); Destroy (Client_Identity); else Current_Note.Access_Identity := Client_Identity; end if; PolyORB.Annotations.Set_Note (PolyORB.Tasking.Threads.Annotations.Get_Current_Thread_Notepad.all, Current_Note); end Accept_Context; ------------------------------ -- Accept_Transport_Context -- ------------------------------ function Accept_Transport_Context (Profile : PolyORB.Binding_Data.Profile_Access; Transport : PolyORB.QoS.Transport_Contexts.QoS_Transport_Context_Parameter_Access) return Boolean is use PolyORB.Binding_Data; use PolyORB.QoS.Targets_Security; use PolyORB.QoS.Transport_Contexts; use PolyORB.Security.Types; QoS : QoS_Target_Security_Parameter_Access; Current_Note : Security_Current_Note; begin -- Extract Object's POA security configuration QoS := Get_Object_Adapter_Security_Configuration (Profile); if QoS = null then -- Unprotected POA if Transport = null then Current_Note.Access_Identity := Create_Anonymous_Identity; PolyORB.Annotations.Set_Note (PolyORB.Tasking.Threads.Annotations. Get_Current_Thread_Notepad.all, Current_Note); return True; else pragma Debug (C, O ("Unprotected POA, secure transport")); return False; end if; end if; if Transport = null then -- Unprotected transport if not QoS.Disable_Unprotected then Current_Note.Access_Identity := Create_Anonymous_Identity; PolyORB.Annotations.Set_Note (PolyORB.Tasking.Threads.Annotations. Get_Current_Thread_Notepad.all, Current_Note); return True; else pragma Debug (C, O ("Unprotected transport, POA require protection")); return False; end if; end if; declare use Target_Mechanism_Lists; Iter : Target_Mechanism_Lists.Iterator := First (QoS.Mechanisms); begin -- Always accept transport context for local profiles if Transport.Transport = null then Current_Note.Access_Identity := Get_Transport_Identity (Compound_Credentials_Access (Entity_Of (Transport.Invocation_Credentials))); PolyORB.Annotations.Set_Note (PolyORB.Tasking.Threads.Annotations. Get_Current_Thread_Notepad.all, Current_Note); return True; end if; while not Last (Iter) loop if Value (Iter).all.Transport = Transport.Transport then if not Value (Iter).all.Authentication_Required and then not Value (Iter).all.Delegation_Required then Current_Note.Access_Identity := Get_Transport_Identity (Compound_Credentials_Access (Entity_Of (Transport.Invocation_Credentials))); PolyORB.Annotations.Set_Note (PolyORB.Tasking.Threads.Annotations. Get_Current_Thread_Notepad.all, Current_Note); return True; else pragma Debug (C, O ("Transport mechanism match," & " POA requies authentication or delegation")); return False; end if; end if; Next (Iter); end loop; pragma Debug (C, O ("Transport mechanism not matched")); return False; end; end Accept_Transport_Context; --------------------- -- Discard_Context -- --------------------- procedure Discard_Context (Transport : PolyORB.QoS.Transport_Contexts.QoS_Transport_Context_Parameter_Access; Client_Context_Id : PolyORB.Security.Types.Context_Id) is pragma Unreferenced (Transport); pragma Unreferenced (Client_Context_Id); begin null; end Discard_Context; ----------------------------------------------- -- Get_Object_Adapter_Security_Configuration -- ----------------------------------------------- function Get_Object_Adapter_Security_Configuration (Profile : PolyORB.Binding_Data.Profile_Access) return QoS.Targets_Security.QoS_Target_Security_Parameter_Access is use PolyORB.Binding_Data; use PolyORB.Errors; use PolyORB.Obj_Adapter_QoS; use PolyORB.POA; use PolyORB.POA_Types; use PolyORB.QoS; use PolyORB.QoS.Targets_Security; use PolyORB.Types; U_Oid : Unmarshalled_Oid; Obj_OA : PolyORB.POA.Obj_Adapter_Access; Error : Error_Container; begin -- Extract Object's POA security configuration Oid_To_U_Oid (Get_Object_Key (Profile.all).all, U_Oid, Error); if Found (Error) then raise Program_Error; end if; Find_POA (PolyORB.POA.Obj_Adapter_Access (Get_OA (Profile.all)), To_Standard_String (U_Oid.Creator), True, Obj_OA, Error); if Found (Error) then raise Program_Error; end if; return QoS_Target_Security_Parameter_Access (Get_Object_Adapter_QoS (Obj_OA, Compound_Security)); end Get_Object_Adapter_Security_Configuration; ----------------------- -- Reference_Context -- ----------------------- procedure Reference_Context (Transport : PolyORB.QoS.Transport_Contexts.QoS_Transport_Context_Parameter_Access; Client_Context_Id : PolyORB.Security.Types.Context_Id; Status : out Boolean; Final_Token : out PolyORB.Security.Types.Stream_Element_Array_Access) is pragma Unreferenced (Transport); pragma Unreferenced (Client_Context_Id); begin Status := False; Final_Token := null; end Reference_Context; end PolyORB.CORBA_P.TSS_State_Machine_Actions; polyorb-2.8~20110207.orig/src/corba/security/polyorb-corba_p-css_state_machine.ads0000644000175000017500000000430511750740340027364 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . C O R B A _ P . C S S _ S T A T E _ M A C H I N E -- -- -- -- S p e c -- -- -- -- Copyright (C) 2005-2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- CORBA CSI Version 2 Client Security Service State Machine Implementation package PolyORB.CORBA_P.CSS_State_Machine is pragma Elaborate_Body; end PolyORB.CORBA_P.CSS_State_Machine; polyorb-2.8~20110207.orig/src/corba/security/polyorb-corba_p-security_policy.adb0000644000175000017500000001165011750740340027116 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . C O R B A _ P . S E C U R I T Y _ P O L I C Y -- -- -- -- B o d y -- -- -- -- Copyright (C) 2005-2009, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with Ada.Unchecked_Deallocation; with CORBA.Object.Policies; with PolyORB.CORBA_P.Policy_Management; with PolyORB.Security.Security_Manager; package body PolyORB.CORBA_P.Security_Policy is type Credentials_List_Access is access all PolyORB.Security.Credentials.Credentials_List; type Client_Policy_Info is record Registered : Boolean; Convertor : Convert_Client_Policy; end record; Registry : array (PolyORB.CORBA_P.Policy_Management.Policy_List'Range) of Client_Policy_Info := (others => (False, null)); procedure Free is new Ada.Unchecked_Deallocation (PolyORB.Security.Credentials.Credentials_List, Credentials_List_Access); ----------------------- -- Get_Client_Policy -- ----------------------- function Get_Client_Policy (Object : PolyORB.References.Ref) return Client_Policy is use PolyORB.Security.Types; Target : constant CORBA.Object.Ref := CORBA.Object.Internals.To_CORBA_Ref (Object); Creds : Credentials_List_Access := null; Requires : PolyORB.Security.Types.Association_Options := 0; begin -- Analize overridden policy for J in Registry'Range loop if Registry (J).Registered then declare Aux : constant Client_Policy := Registry (J).Convertor (CORBA.Object.Policies.Get_Policy (Target, J)); begin Requires := Requires or Aux.Client_Requires; if Aux.Invocation_Credentials'Length /= 0 then Free (Creds); Creds := new PolyORB.Security.Credentials.Credentials_List' (Aux.Invocation_Credentials); end if; exception when CORBA.Inv_Policy => null; end; end if; end loop; -- Force minimum capsule's level of protection Requires := Requires or PolyORB.Security.Security_Manager.Client_Requires; -- Use capsule's credentials if no invocation credentials defined if Creds = null then Creds := new PolyORB.Security.Credentials.Credentials_List' (PolyORB.Security.Security_Manager.Own_Credentials); end if; declare Result : constant Client_Policy := (Length => Creds'Length, Client_Requires => Requires, Invocation_Credentials => Creds.all); begin Free (Creds); return Result; end; end Get_Client_Policy; ---------------------------- -- Register_Client_Policy -- ---------------------------- procedure Register_Client_Policy (The_Type : CORBA.PolicyType; Convertor : Convert_Client_Policy) is begin Registry (The_Type) := (True, Convertor); end Register_Client_Policy; end PolyORB.CORBA_P.Security_Policy; polyorb-2.8~20110207.orig/src/corba/security/polyorb-corba_p-security_current.ads0000644000175000017500000000476211750740340027330 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . C O R B A _ P . S E C U R I T Y _ C U R R E N T -- -- -- -- S p e c -- -- -- -- Copyright (C) 2005-2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with PolyORB.Annotations; with PolyORB.Security.Identities; package PolyORB.CORBA_P.Security_Current is type Security_Current_Note is new PolyORB.Annotations.Note with record Access_Identity : PolyORB.Security.Identities.Identity_Access; end record; procedure Destroy (N : in out Security_Current_Note); Empty_Security_Current_Note : constant Security_Current_Note := (PolyORB.Annotations.Note with Access_Identity => null); end PolyORB.CORBA_P.Security_Current; polyorb-2.8~20110207.orig/src/corba/security/polyorb-corba_p-css_state_machine.adb0000644000175000017500000002521411750740340027345 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . C O R B A _ P . C S S _ S T A T E _ M A C H I N E -- -- -- -- B o d y -- -- -- -- Copyright (C) 2005-2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with PolyORB.Binding_Data_QoS; with PolyORB.CORBA_P.CSS_State_Machine_Actions; with PolyORB.CORBA_P.Exceptions; with PolyORB.CORBA_P.Interceptors_Hooks; with PolyORB.CORBA_P.Security_Policy; with PolyORB.Errors; with PolyORB.Initialization; with PolyORB.QoS; with PolyORB.QoS.Clients_Security; with PolyORB.QoS.Security_Contexts; with PolyORB.QoS.Transport_Contexts; with PolyORB.References.Binding; with PolyORB.Requests; with PolyORB.Request_QoS; with PolyORB.Security.Connections; with PolyORB.Security.Credentials; with PolyORB.Utils.Strings; package body PolyORB.CORBA_P.CSS_State_Machine is use PolyORB.Binding_Data_QoS; use PolyORB.CORBA_P.Exceptions; use PolyORB.CORBA_P.Interceptors_Hooks; use PolyORB.CORBA_P.CSS_State_Machine_Actions; use PolyORB.QoS; use PolyORB.QoS.Clients_Security; use PolyORB.QoS.Security_Contexts; use PolyORB.QoS.Transport_Contexts; use PolyORB.References.Binding; use PolyORB.Request_QoS; use PolyORB.Security.Credentials; Legacy_Client_Invoke : Client_Invoke_Handler; procedure Initialize; procedure Security_Client_Invoke (Request : access PolyORB.Requests.Request; Flags : PolyORB.Requests.Flags); ---------------- -- Initialize -- ---------------- procedure Initialize is begin Legacy_Client_Invoke := Client_Invoke; Client_Invoke := Security_Client_Invoke'Access; end Initialize; ---------------------------- -- Security_Client_Invoke -- ---------------------------- procedure Security_Client_Invoke (Request : access PolyORB.Requests.Request; Flags : PolyORB.Requests.Flags) is use PolyORB.CORBA_P.Security_Policy; use PolyORB.QoS.Clients_Security.Client_Mechanism_Lists; Configuration_QoS : constant QoS_Client_Security_Parameter_Access := QoS_Client_Security_Parameter_Access (Get_Profile_QoS (Get_Preferred_Profile (Request.Target, True), Compound_Security)); Policy : constant Client_Policy := Get_Client_Policy (Request.Target); Mechanism : PolyORB.QoS.Clients_Security.Client_Mechanism_Access; Credentials : PolyORB.Security.Credentials.Credentials_Ref; Connection : PolyORB.Security.Connections.Connection_Access; Request_QoS : PolyORB.QoS.Security_Contexts.QoS_Security_Context_Parameter_Access; Reply_QoS : PolyORB.QoS.Security_Contexts.QoS_Security_Context_Parameter_Access; Transport_QoS : PolyORB.QoS.Transport_Contexts.QoS_Transport_Context_Parameter_Access; Success : Boolean; begin -- Getting preferred compound mechanism if Configuration_QoS /= null then Get_Mechanism (Policy, Configuration_QoS.Mechanisms, Mechanism, Success); else Get_Mechanism (Policy, Empty, Mechanism, Success); end if; if not Success then declare Error : PolyORB.Errors.Error_Container; begin PolyORB.Errors.Throw (Error, PolyORB.Errors.Inv_Policy_E, PolyORB.Errors.System_Exception_Members' (Minor => 0, Completed => PolyORB.Errors.Completed_No)); PolyORB.Requests.Set_Exception (Request.all, Error); return; end; end if; -- If no preferred compound mechanism or preferred compound mechanism -- is unprotected then use legacy invocation handler if Mechanism = null or else not Is_Protected (Mechanism.all) then Legacy_Client_Invoke (Request, Flags); return; end if; -- Getting credentials Credentials := Get_Client_Credentials (Policy, Mechanism); if Is_Nil (Credentials) then declare Error : PolyORB.Errors.Error_Container; begin PolyORB.Errors.Throw (Error, PolyORB.Errors.No_Resources_E, PolyORB.Errors.System_Exception_Members' (Minor => 0, Completed => PolyORB.Errors.Completed_No)); PolyORB.Requests.Set_Exception (Request.all, Error); return; end; end if; -- Configure transport mechanism Transport_QoS := new QoS_Transport_Context_Parameter; Transport_QoS.Selected := Mechanism; Transport_QoS.Invocation_Credentials := Credentials; Add_Request_QoS (Request.all, Transport_Security, QoS_Parameter_Access (Transport_QoS)); -- Bind Object Reference with selected transport mechanism and obtained -- credentials -- XXX Not yet impelemnted, assume unprotected transport mechanism Connection := null; -- Create SAS context declare Element : constant Context_Element := Get_Context_Element (Policy, Mechanism, Credentials, Connection); begin case Element.Kind is when No_Element => Request_QoS := null; when Establish_Context => Request_QoS := new QoS_Security_Context_Parameter (Establish_Context); Request_QoS.Client_Context_Id := Element.Client_Context_Id; Request_QoS.Client_Authentication_Token := Element.Client_Authentication_Token; Request_QoS.Identity_Token := Element.Identity_Token; Request_QoS.Authorization_Token := Element.Authorization_Token; when Message_In_Context => Request_QoS := new QoS_Security_Context_Parameter (Message_In_Context); Request_QoS.Client_Context_Id := Element.Client_Context_Id; Request_QoS.Discard_Context := Element.Discard_Context; end case; end; Add_Request_QoS (Request.all, Compound_Security, QoS_Parameter_Access (Request_QoS)); Legacy_Client_Invoke (Request, Flags); -- If no request security context then return if Request_QoS = null then return; end if; -- Otherwise, if location forwarding received or no empty SAS context -- then invalidate context and return Reply_QoS := QoS_Security_Context_Parameter_Access (Extract_Reply_Parameter (Compound_Security, Request.all)); if Is_Forward_Request (Request.Exception_Info) or else Reply_QoS = null then Invalidate_Context (Connection, Request_QoS.Client_Context_Id); return; end if; -- If reply security context received then analyze it case Reply_QoS.Context_Kind is when Establish_Context => raise Program_Error; -- Never happens when Complete_Establish_Context => Complete_Context (Connection, Reply_QoS.Client_Context_Id, Reply_QoS.Context_Stateful, Reply_QoS.Final_Context_Token); when Context_Error => case Reply_QoS.Major_Status is when 1 => -- Invalid Evidience null; when 2 => -- Invalid Mechanism null; when 3 => -- Conflicting Evidience Invalidate_Context (Connection, Reply_QoS.Client_Context_Id, Reply_QoS.Error_Token); when 4 => -- No Context Invalidate_Context (Connection, Reply_QoS.Client_Context_Id, Reply_QoS.Error_Token); raise Program_Error; -- XXX Should repeat request with new context element, -- not yet implemented. when others => raise Program_Error; -- Never be happen end case; when Message_In_Context => raise Program_Error; -- Never be happen end case; end Security_Client_Invoke; begin declare use PolyORB.Initialization; use PolyORB.Initialization.String_Lists; use PolyORB.Utils.Strings; begin Register_Module (Module_Info' (Name => +"polyorb.corba_p.security.css_state_machine", Conflicts => Empty, Depends => +"corba.request" & "polyorb.corba_p.interceptors?", Provides => Empty, Implicit => False, Init => Initialize'Access, Shutdown => null)); end; end PolyORB.CORBA_P.CSS_State_Machine; polyorb-2.8~20110207.orig/src/corba/security/polyorb-corba_p-security_current.adb0000644000175000017500000000444711750740340027307 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . C O R B A _ P . S E C U R I T Y _ C U R R E N T -- -- -- -- B o d y -- -- -- -- Copyright (C) 2005-2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ package body PolyORB.CORBA_P.Security_Current is ------------- -- Destroy -- ------------- procedure Destroy (N : in out Security_Current_Note) is begin PolyORB.Security.Identities.Destroy (N.Access_Identity); end Destroy; end PolyORB.CORBA_P.Security_Current; polyorb-2.8~20110207.orig/src/corba/portableserver-requestprocessingpolicy.ads0000644000175000017500000000544711750740340027024 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- PORTABLESERVER.REQUESTPROCESSINGPOLICY -- -- -- -- S p e c -- -- -- -- Copyright (C) 2003-2008, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the CORBA Specification, and adapted -- -- for use with PolyORB. The copyright notice above, and the license -- -- provisions that follow apply solely to the contents neither explicitly -- -- nor implicitly specified by the CORBA Specification defined by the OMG. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with CORBA.Policy; package PortableServer.RequestProcessingPolicy is type Ref is new CORBA.Policy.Ref with private; function To_Ref (The_Ref : CORBA.Object.Ref'Class) return Ref; function Get_Value (Self : Ref) return PortableServer.RequestProcessingPolicyValue; private type Ref is new CORBA.Policy.Ref with null record; end PortableServer.RequestProcessingPolicy; polyorb-2.8~20110207.orig/src/corba/corba-bounded_wide_strings.adb0000644000175000017500000007012011750740337024222 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- C O R B A . B O U N D E D _ W I D E _ S T R I N G S -- -- -- -- B o d y -- -- -- -- Copyright (C) 2005-2008, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ pragma Warnings (Off); with Ada.Strings.Wide_Superbounded; -- Internal GNAT unit pragma Warnings (On); with Ada.Unchecked_Conversion; package body CORBA.Bounded_Wide_Strings is use CBWS; function To_Bounded_Wide_String is new Ada.Unchecked_Conversion (Ada.Strings.Wide_Superbounded.Super_String, Bounded_Wide_String); function To_Super_String is new Ada.Unchecked_Conversion (Bounded_Wide_String, Ada.Strings.Wide_Superbounded.Super_String); ---------------------------- -- TC_Bounded_Wide_String -- ---------------------------- TC_Cache : PolyORB.Any.TypeCode.Local_Ref; function TC_Bounded_Wide_String return PolyORB.Any.TypeCode.Local_Ref; -- Internal representation as a PolyORB TypeCode function TC_Bounded_Wide_String return PolyORB.Any.TypeCode.Local_Ref is use PolyORB.Any.TypeCode; begin if Is_Nil (TC_Cache) then TC_Cache := Build_Wstring_TC (PolyORB.Types.Unsigned_Long (Max_Length)); Disable_Reference_Counting (Object_Of (TC_Cache).all); end if; return TC_Cache; end TC_Bounded_Wide_String; ---------------------------- -- TC_Bounded_Wide_String -- ---------------------------- function TC_Bounded_Wide_String return CORBA.TypeCode.Object is begin return CORBA.TypeCode.Internals.To_CORBA_Object (TC_Bounded_Wide_String); end TC_Bounded_Wide_String; -------------- -- From_Any -- -------------- function From_Any (From : CORBA.Any) return Bounded_Wide_String is Super : constant Ada.Strings.Wide_Superbounded.Super_String := From_Any (From); begin if Super.Max_Length /= Max_Length then raise Constraint_Error; end if; return To_Bounded_Wide_String (Super); end From_Any; ------------ -- To_Any -- ------------ function To_Any (To : Bounded_Wide_String) return CORBA.Any is begin return To_Any (To_Super_String (To), TC_Bounded_Wide_String'Access); end To_Any; ------------ -- Length -- ------------ function Length (Source : Bounded_Wide_String) return Length_Range is Result : constant CBWS.Length_Range := CBWS.Length (CBWS.Bounded_Wide_String (Source)); begin return Length_Range (Result); end Length; ---------------------------- -- To_Bounded_Wide_String -- ---------------------------- function To_Bounded_Wide_String (Source : Standard.Wide_String; Drop : Ada.Strings.Truncation := Ada.Strings.Error) return Bounded_Wide_String is Result : constant CBWS.Bounded_Wide_String := CBWS.To_Bounded_Wide_String (Source, Drop); begin return Bounded_Wide_String (Result); end To_Bounded_Wide_String; -------------------- -- To_Wide_String -- -------------------- function To_Wide_String (Source : Bounded_Wide_String) return Standard.Wide_String is Result : constant Standard.Wide_String := CBWS.To_Wide_String (CBWS.Bounded_Wide_String (Source)); begin return Result; end To_Wide_String; ------------ -- Append -- ------------ function Append (Left, Right : Bounded_Wide_String; Drop : Ada.Strings.Truncation := Ada.Strings.Error) return Bounded_Wide_String is Result : constant CBWS.Bounded_Wide_String := CBWS.Append (CBWS.Bounded_Wide_String (Left), CBWS.Bounded_Wide_String (Right), Drop); begin return Bounded_Wide_String (Result); end Append; function Append (Left : Bounded_Wide_String; Right : Standard.Wide_String; Drop : Ada.Strings.Truncation := Ada.Strings.Error) return Bounded_Wide_String is Result : constant CBWS.Bounded_Wide_String := CBWS.Append (CBWS.Bounded_Wide_String (Left), Right, Drop); begin return Bounded_Wide_String (Result); end Append; function Append (Left : Standard.Wide_String; Right : Bounded_Wide_String; Drop : Ada.Strings.Truncation := Ada.Strings.Error) return Bounded_Wide_String is Result : constant CBWS.Bounded_Wide_String := CBWS.Append (Left, CBWS.Bounded_Wide_String (Right), Drop); begin return Bounded_Wide_String (Result); end Append; function Append (Left : Bounded_Wide_String; Right : Wide_Character; Drop : Ada.Strings.Truncation := Ada.Strings.Error) return Bounded_Wide_String is Result : constant CBWS.Bounded_Wide_String := CBWS.Append (CBWS.Bounded_Wide_String (Left), Right, Drop); begin return Bounded_Wide_String (Result); end Append; function Append (Left : Wide_Character; Right : Bounded_Wide_String; Drop : Ada.Strings.Truncation := Ada.Strings.Error) return Bounded_Wide_String is Result : constant CBWS.Bounded_Wide_String := CBWS.Append (Left, CBWS.Bounded_Wide_String (Right), Drop); begin return Bounded_Wide_String (Result); end Append; procedure Append (Source : in out Bounded_Wide_String; New_Item : Bounded_Wide_String; Drop : Ada.Strings.Truncation := Ada.Strings.Error) is CBWS_Source : CBWS.Bounded_Wide_String := CBWS.Bounded_Wide_String (Source); begin CBWS.Append (CBWS_Source, CBWS.Bounded_Wide_String (New_Item), Drop); Source := Bounded_Wide_String (CBWS_Source); end Append; procedure Append (Source : in out Bounded_Wide_String; New_Item : Standard.Wide_String; Drop : Ada.Strings.Truncation := Ada.Strings.Error) is CBWS_Source : CBWS.Bounded_Wide_String := CBWS.Bounded_Wide_String (Source); begin CBWS.Append (CBWS_Source, New_Item, Drop); Source := Bounded_Wide_String (CBWS_Source); end Append; procedure Append (Source : in out Bounded_Wide_String; New_Item : Wide_Character; Drop : Ada.Strings.Truncation := Ada.Strings.Error) is CBWS_Source : CBWS.Bounded_Wide_String := CBWS.Bounded_Wide_String (Source); begin CBWS.Append (CBWS_Source, New_Item, Drop); Source := Bounded_Wide_String (CBWS_Source); end Append; --------- -- "&" -- --------- function "&" (Left, Right : Bounded_Wide_String) return Bounded_Wide_String is Result : constant CBWS.Bounded_Wide_String := CBWS.Bounded_Wide_String (Left) & CBWS.Bounded_Wide_String (Right); begin return Bounded_Wide_String (Result); end "&"; function "&" (Left : Bounded_Wide_String; Right : Standard.Wide_String) return Bounded_Wide_String is Result : constant CBWS.Bounded_Wide_String := CBWS.Bounded_Wide_String (Left) & Right; begin return Bounded_Wide_String (Result); end "&"; function "&" (Left : Standard.Wide_String; Right : Bounded_Wide_String) return Bounded_Wide_String is Result : constant CBWS.Bounded_Wide_String := Left & CBWS.Bounded_Wide_String (Right); begin return Bounded_Wide_String (Result); end "&"; function "&" (Left : Bounded_Wide_String; Right : Wide_Character) return Bounded_Wide_String is Result : constant CBWS.Bounded_Wide_String := CBWS.Bounded_Wide_String (Left) & Right; begin return Bounded_Wide_String (Result); end "&"; function "&" (Left : Wide_Character; Right : Bounded_Wide_String) return Bounded_Wide_String is Result : constant CBWS.Bounded_Wide_String := Left & CBWS.Bounded_Wide_String (Right); begin return Bounded_Wide_String (Result); end "&"; ------------- -- Element -- ------------- function Element (Source : Bounded_Wide_String; Index : Positive) return Wide_Character is Result : constant Wide_Character := CBWS.Element (CBWS.Bounded_Wide_String (Source), Index); begin return Result; end Element; --------------------- -- Replace_Element -- --------------------- procedure Replace_Element (Source : in out Bounded_Wide_String; Index : Positive; By : Wide_Character) is CBWS_Source : CBWS.Bounded_Wide_String := CBWS.Bounded_Wide_String (Source); begin CBWS.Replace_Element (CBWS_Source, Index, By); Source := Bounded_Wide_String (CBWS_Source); end Replace_Element; ----------- -- Slice -- ----------- function Slice (Source : Bounded_Wide_String; Low : Positive; High : Natural) return Standard.Wide_String is Result : constant Standard.Wide_String := CBWS.Slice (CBWS.Bounded_Wide_String (Source), Low, High); begin return Result; end Slice; --------- -- "=" -- --------- function "=" (Left, Right : Bounded_Wide_String) return Boolean is Result : constant Boolean := CBWS.Bounded_Wide_String (Left) = CBWS.Bounded_Wide_String (Right); begin return Result; end "="; function "=" (Left : Bounded_Wide_String; Right : Standard.Wide_String) return Boolean is Result : constant Boolean := CBWS.Bounded_Wide_String (Left) = Right; begin return Result; end "="; function "=" (Left : Standard.Wide_String; Right : Bounded_Wide_String) return Boolean is Result : constant Boolean := Left = CBWS.Bounded_Wide_String (Right); begin return Result; end "="; --------- -- "<" -- --------- function "<" (Left, Right : Bounded_Wide_String) return Boolean is Result : constant Boolean := CBWS.Bounded_Wide_String (Left) < CBWS.Bounded_Wide_String (Right); begin return Result; end "<"; function "<" (Left : Bounded_Wide_String; Right : Standard.Wide_String) return Boolean is Result : constant Boolean := CBWS.Bounded_Wide_String (Left) < Right; begin return Result; end "<"; function "<" (Left : Standard.Wide_String; Right : Bounded_Wide_String) return Boolean is Result : constant Boolean := Left < CBWS.Bounded_Wide_String (Right); begin return Result; end "<"; ---------- -- "<=" -- ---------- function "<=" (Left, Right : Bounded_Wide_String) return Boolean is Result : constant Boolean := CBWS.Bounded_Wide_String (Left) <= CBWS.Bounded_Wide_String (Right); begin return Result; end "<="; function "<=" (Left : Bounded_Wide_String; Right : Standard.Wide_String) return Boolean is Result : constant Boolean := CBWS.Bounded_Wide_String (Left) <= Right; begin return Result; end "<="; function "<=" (Left : Standard.Wide_String; Right : Bounded_Wide_String) return Boolean is Result : constant Boolean := Left <= CBWS.Bounded_Wide_String (Right); begin return Result; end "<="; --------- -- ">" -- --------- function ">" (Left, Right : Bounded_Wide_String) return Boolean is Result : constant Boolean := CBWS.Bounded_Wide_String (Left) > CBWS.Bounded_Wide_String (Right); begin return Result; end ">"; function ">" (Left : Bounded_Wide_String; Right : Standard.Wide_String) return Boolean is Result : constant Boolean := CBWS.Bounded_Wide_String (Left) > Right; begin return Result; end ">"; function ">" (Left : Standard.Wide_String; Right : Bounded_Wide_String) return Boolean is Result : constant Boolean := Left > CBWS.Bounded_Wide_String (Right); begin return Result; end ">"; ---------- -- ">=" -- ---------- function ">=" (Left, Right : Bounded_Wide_String) return Boolean is Result : constant Boolean := CBWS.Bounded_Wide_String (Left) >= CBWS.Bounded_Wide_String (Right); begin return Result; end ">="; function ">=" (Left : Bounded_Wide_String; Right : Standard.Wide_String) return Boolean is Result : constant Boolean := CBWS.Bounded_Wide_String (Left) >= Right; begin return Result; end ">="; function ">=" (Left : Standard.Wide_String; Right : Bounded_Wide_String) return Boolean is Result : constant Boolean := Left >= CBWS.Bounded_Wide_String (Right); begin return Result; end ">="; ----------- -- Index -- ----------- function Index (Source : Bounded_Wide_String; Pattern : Standard.Wide_String; Going : Ada.Strings.Direction := Ada.Strings.Forward; Mapping : Ada.Strings.Wide_Maps.Wide_Character_Mapping := Ada.Strings.Wide_Maps.Identity) return Natural is Result : constant Natural := CBWS.Index (CBWS.Bounded_Wide_String (Source), Pattern, Going, Mapping); begin return Result; end Index; function Index (Source : Bounded_Wide_String; Pattern : Standard.Wide_String; Going : Ada.Strings.Direction := Ada.Strings.Forward; Mapping : Ada.Strings.Wide_Maps.Wide_Character_Mapping_Function) return Natural is Result : constant Natural := CBWS.Index (CBWS.Bounded_Wide_String (Source), Pattern, Going, Mapping); begin return Result; end Index; function Index (Source : Bounded_Wide_String; Set : Ada.Strings.Wide_Maps.Wide_Character_Set; Test : Ada.Strings.Membership := Ada.Strings.Inside; Going : Ada.Strings.Direction := Ada.Strings.Forward) return Natural is Result : constant Natural := CBWS.Index (CBWS.Bounded_Wide_String (Source), Set, Test, Going); begin return Result; end Index; --------------------- -- Index_Non_Blank -- --------------------- function Index_Non_Blank (Source : Bounded_Wide_String; Going : Ada.Strings.Direction := Ada.Strings.Forward) return Natural is Result : constant Natural := CBWS.Index_Non_Blank (CBWS.Bounded_Wide_String (Source), Going); begin return Result; end Index_Non_Blank; ----------- -- Count -- ----------- function Count (Source : Bounded_Wide_String; Pattern : Standard.Wide_String; Mapping : Ada.Strings.Wide_Maps.Wide_Character_Mapping := Ada.Strings.Wide_Maps.Identity) return Natural is Result : constant Natural := CBWS.Count (CBWS.Bounded_Wide_String (Source), Pattern, Mapping); begin return Result; end Count; function Count (Source : Bounded_Wide_String; Pattern : Standard.Wide_String; Mapping : Ada.Strings.Wide_Maps.Wide_Character_Mapping_Function) return Natural is Result : constant Natural := CBWS.Count (CBWS.Bounded_Wide_String (Source), Pattern, Mapping); begin return Result; end Count; function Count (Source : Bounded_Wide_String; Set : Ada.Strings.Wide_Maps.Wide_Character_Set) return Natural is Result : constant Natural := CBWS.Count (CBWS.Bounded_Wide_String (Source), Set); begin return Result; end Count; ---------------- -- Find_Token -- ---------------- procedure Find_Token (Source : Bounded_Wide_String; Set : Ada.Strings.Wide_Maps.Wide_Character_Set; Test : Ada.Strings.Membership; First : out Positive; Last : out Natural) is begin CBWS.Find_Token (CBWS.Bounded_Wide_String (Source), Set, Test, First, Last); end Find_Token; --------------- -- Translate -- --------------- function Translate (Source : Bounded_Wide_String; Mapping : Ada.Strings.Wide_Maps.Wide_Character_Mapping) return Bounded_Wide_String is Result : constant CBWS.Bounded_Wide_String := CBWS.Translate (CBWS.Bounded_Wide_String (Source), Mapping); begin return Bounded_Wide_String (Result); end Translate; procedure Translate (Source : in out Bounded_Wide_String; Mapping : Ada.Strings.Wide_Maps.Wide_Character_Mapping) is CBWS_Source : CBWS.Bounded_Wide_String := CBWS.Bounded_Wide_String (Source); begin CBWS.Translate (CBWS_Source, Mapping); Source := Bounded_Wide_String (CBWS_Source); end Translate; function Translate (Source : Bounded_Wide_String; Mapping : Ada.Strings.Wide_Maps.Wide_Character_Mapping_Function) return Bounded_Wide_String is Result : constant CBWS.Bounded_Wide_String := CBWS.Translate (CBWS.Bounded_Wide_String (Source), Mapping); begin return Bounded_Wide_String (Result); end Translate; procedure Translate (Source : in out Bounded_Wide_String; Mapping : Ada.Strings.Wide_Maps.Wide_Character_Mapping_Function) is CBWS_Source : CBWS.Bounded_Wide_String := CBWS.Bounded_Wide_String (Source); begin CBWS.Translate (CBWS_Source, Mapping); Source := Bounded_Wide_String (CBWS_Source); end Translate; ------------------- -- Replace_Slice -- ------------------- function Replace_Slice (Source : Bounded_Wide_String; Low : Positive; High : Natural; By : Standard.Wide_String; Drop : Ada.Strings.Truncation := Ada.Strings.Error) return Bounded_Wide_String is Result : constant CBWS.Bounded_Wide_String := CBWS.Replace_Slice (CBWS.Bounded_Wide_String (Source), Low, High, By, Drop); begin return Bounded_Wide_String (Result); end Replace_Slice; procedure Replace_Slice (Source : in out Bounded_Wide_String; Low : Positive; High : Natural; By : Standard.Wide_String; Drop : Ada.Strings.Truncation := Ada.Strings.Error) is CBWS_Source : CBWS.Bounded_Wide_String := CBWS.Bounded_Wide_String (Source); begin CBWS.Replace_Slice (CBWS_Source, Low, High, By, Drop); Source := Bounded_Wide_String (CBWS_Source); end Replace_Slice; ------------ -- Insert -- ------------ function Insert (Source : Bounded_Wide_String; Before : Positive; New_Item : Standard.Wide_String; Drop : Ada.Strings.Truncation := Ada.Strings.Error) return Bounded_Wide_String is Result : constant CBWS.Bounded_Wide_String := CBWS.Insert (CBWS.Bounded_Wide_String (Source), Before, New_Item, Drop); begin return Bounded_Wide_String (Result); end Insert; procedure Insert (Source : in out Bounded_Wide_String; Before : Positive; New_Item : Standard.Wide_String; Drop : Ada.Strings.Truncation := Ada.Strings.Error) is CBWS_Source : CBWS.Bounded_Wide_String := CBWS.Bounded_Wide_String (Source); begin CBWS.Insert (CBWS_Source, Before, New_Item, Drop); Source := Bounded_Wide_String (CBWS_Source); end Insert; --------------- -- Overwrite -- --------------- function Overwrite (Source : Bounded_Wide_String; Position : Positive; New_Item : Standard.Wide_String; Drop : Ada.Strings.Truncation := Ada.Strings.Error) return Bounded_Wide_String is Result : constant CBWS.Bounded_Wide_String := CBWS.Overwrite (CBWS.Bounded_Wide_String (Source), Position, New_Item, Drop); begin return Bounded_Wide_String (Result); end Overwrite; procedure Overwrite (Source : in out Bounded_Wide_String; Position : Positive; New_Item : Standard.Wide_String; Drop : Ada.Strings.Truncation := Ada.Strings.Error) is CBWS_Source : CBWS.Bounded_Wide_String := CBWS.Bounded_Wide_String (Source); begin CBWS.Overwrite (CBWS_Source, Position, New_Item, Drop); Source := Bounded_Wide_String (CBWS_Source); end Overwrite; ------------ -- Delete -- ------------ function Delete (Source : Bounded_Wide_String; From : Positive; Through : Natural) return Bounded_Wide_String is Result : constant CBWS.Bounded_Wide_String := CBWS.Delete (CBWS.Bounded_Wide_String (Source), From, Through); begin return Bounded_Wide_String (Result); end Delete; procedure Delete (Source : in out Bounded_Wide_String; From : Positive; Through : Natural) is CBWS_Source : CBWS.Bounded_Wide_String := CBWS.Bounded_Wide_String (Source); begin CBWS.Delete (CBWS_Source, From, Through); Source := Bounded_Wide_String (CBWS_Source); end Delete; ---------- -- Trim -- ---------- function Trim (Source : Bounded_Wide_String; Side : Ada.Strings.Trim_End) return Bounded_Wide_String is Result : constant CBWS.Bounded_Wide_String := CBWS.Trim (CBWS.Bounded_Wide_String (Source), Side); begin return Bounded_Wide_String (Result); end Trim; procedure Trim (Source : in out Bounded_Wide_String; Side : Ada.Strings.Trim_End) is CBWS_Source : CBWS.Bounded_Wide_String := CBWS.Bounded_Wide_String (Source); begin CBWS.Trim (CBWS_Source, Side); Source := Bounded_Wide_String (CBWS_Source); end Trim; function Trim (Source : Bounded_Wide_String; Left : Ada.Strings.Wide_Maps.Wide_Character_Set; Right : Ada.Strings.Wide_Maps.Wide_Character_Set) return Bounded_Wide_String is Result : constant CBWS.Bounded_Wide_String := CBWS.Trim (CBWS.Bounded_Wide_String (Source), Left, Right); begin return Bounded_Wide_String (Result); end Trim; procedure Trim (Source : in out Bounded_Wide_String; Left : Ada.Strings.Wide_Maps.Wide_Character_Set; Right : Ada.Strings.Wide_Maps.Wide_Character_Set) is CBWS_Source : CBWS.Bounded_Wide_String := CBWS.Bounded_Wide_String (Source); begin CBWS.Trim (CBWS_Source, Left, Right); Source := Bounded_Wide_String (CBWS_Source); end Trim; ---------- -- Head -- ---------- function Head (Source : Bounded_Wide_String; Count : Natural; Pad : Wide_Character := Ada.Strings.Wide_Space; Drop : Ada.Strings.Truncation := Ada.Strings.Error) return Bounded_Wide_String is Result : constant CBWS.Bounded_Wide_String := CBWS.Head (CBWS.Bounded_Wide_String (Source), Count, Pad, Drop); begin return Bounded_Wide_String (Result); end Head; procedure Head (Source : in out Bounded_Wide_String; Count : Natural; Pad : Wide_Character := Ada.Strings.Wide_Space; Drop : Ada.Strings.Truncation := Ada.Strings.Error) is CBWS_Source : CBWS.Bounded_Wide_String := CBWS.Bounded_Wide_String (Source); begin CBWS.Head (CBWS_Source, Count, Pad, Drop); Source := Bounded_Wide_String (CBWS_Source); end Head; ---------- -- Tail -- ---------- function Tail (Source : Bounded_Wide_String; Count : Natural; Pad : Wide_Character := Ada.Strings.Wide_Space; Drop : Ada.Strings.Truncation := Ada.Strings.Error) return Bounded_Wide_String is Result : constant CBWS.Bounded_Wide_String := CBWS.Tail (CBWS.Bounded_Wide_String (Source), Count, Pad, Drop); begin return Bounded_Wide_String (Result); end Tail; procedure Tail (Source : in out Bounded_Wide_String; Count : Natural; Pad : Wide_Character := Ada.Strings.Wide_Space; Drop : Ada.Strings.Truncation := Ada.Strings.Error) is CBWS_Source : CBWS.Bounded_Wide_String := CBWS.Bounded_Wide_String (Source); begin CBWS.Tail (CBWS_Source, Count, Pad, Drop); Source := Bounded_Wide_String (CBWS_Source); end Tail; --------- -- "*" -- --------- function "*" (Left : Natural; Right : Wide_Character) return Bounded_Wide_String is Result : constant CBWS.Bounded_Wide_String := Left * Right; begin return Bounded_Wide_String (Result); end "*"; function "*" (Left : Natural; Right : Standard.Wide_String) return Bounded_Wide_String is Result : constant CBWS.Bounded_Wide_String := Left * Right; begin return Bounded_Wide_String (Result); end "*"; function "*" (Left : Natural; Right : Bounded_Wide_String) return Bounded_Wide_String is Result : constant CBWS.Bounded_Wide_String := Left * CBWS.Bounded_Wide_String (Right); begin return Bounded_Wide_String (Result); end "*"; --------------- -- Replicate -- --------------- function Replicate (Count : Natural; Item : Wide_Character; Drop : Ada.Strings.Truncation := Ada.Strings.Error) return Bounded_Wide_String is Result : constant CBWS.Bounded_Wide_String := CBWS.Replicate (Count, Item, Drop); begin return Bounded_Wide_String (Result); end Replicate; function Replicate (Count : Natural; Item : Standard.Wide_String; Drop : Ada.Strings.Truncation := Ada.Strings.Error) return Bounded_Wide_String is Result : constant CBWS.Bounded_Wide_String := CBWS.Replicate (Count, Item, Drop); begin return Bounded_Wide_String (Result); end Replicate; function Replicate (Count : Natural; Item : Bounded_Wide_String; Drop : Ada.Strings.Truncation := Ada.Strings.Error) return Bounded_Wide_String is Result : constant CBWS.Bounded_Wide_String := CBWS.Replicate (Count, CBWS.Bounded_Wide_String (Item), Drop); begin return Bounded_Wide_String (Result); end Replicate; ---------- -- Wrap -- ---------- function Wrap (X : access Bounded_Wide_String) return PolyORB.Any.Content'Class is begin return PolyORB.Any.Wrap (To_Super_String (X.all)'Unrestricted_Access); end Wrap; end CORBA.Bounded_Wide_Strings; polyorb-2.8~20110207.orig/src/corba/portableserver-servantactivator-impl.ads0000644000175000017500000000664411750740340026355 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- PORTABLESERVER.SERVANTACTIVATOR.IMPL -- -- -- -- S p e c -- -- -- -- Copyright (C) 2005-2010, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the CORBA Specification, and adapted -- -- for use with PolyORB. The copyright notice above, and the license -- -- provisions that follow apply solely to the contents neither explicitly -- -- nor implicitly specified by the CORBA Specification defined by the OMG. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with PortableServer.ServantManager.Impl; package PortableServer.ServantActivator.Impl is type Object is new PortableServer.ServantManager.Impl.Object with private; type Object_Ptr is access all Object'Class; function Incarnate (Self : access Object; Oid : PortableServer.ObjectId; Adapter : PortableServer.POA_Forward.Ref) return PortableServer.Servant; procedure Etherealize (Self : access Object; Oid : PortableServer.ObjectId; Adapter : PortableServer.POA_Forward.Ref; Serv : PortableServer.Servant; Cleanup_In_Progress : CORBA.Boolean; Remaining_Activations : CORBA.Boolean); private type Object is new PortableServer.ServantManager.Impl.Object with null record; function Is_A (Self : not null access Object; Logical_Type_Id : Standard.String) return Boolean; end PortableServer.ServantActivator.Impl; polyorb-2.8~20110207.orig/src/corba/corba-domainmanager-helper.adb0000644000175000017500000001502411750740337024102 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- C O R B A . D O M A I N M A N A G E R . H E L P E R -- -- -- -- B o d y -- -- -- -- Copyright (C) 2005-2007, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- XXX This file should be generated using idlac with PolyORB.Initialization; with PolyORB.Utils.Strings; with CORBA.Object.Helper; with PolyORB.Sequences.Unbounded.CORBA_Helper; pragma Elaborate_All (PolyORB.Sequences.Unbounded.CORBA_Helper); package body CORBA.DomainManager.Helper is TC_DomainManager_Cache : TypeCode.Object; TC_IDL_SEQUENCE_DomainManager_Cache : TypeCode.Object; TC_DomainManagersList_Cache : TypeCode.Object; function Element_Wrap (X : access Ref) return PolyORB.Any.Content'Class; function Element_Wrap (X : access Ref) return PolyORB.Any.Content'Class is begin return CORBA.Object.Helper.Wrap (CORBA.Object.Ref (X.all)'Unrestricted_Access); end Element_Wrap; package IDL_SEQUENCE_DomainManager_Helper is new IDL_SEQUENCE_DomainManager.CORBA_Helper (Element_To_Any => To_Any, Element_From_Any => From_Any, Element_Wrap => Element_Wrap); procedure Deferred_Initialization; ----------------------------- -- Deferred_Initialization -- ----------------------------- procedure Deferred_Initialization is begin TC_DomainManager_Cache := TypeCode.Internals.To_CORBA_Object (PolyORB.Any.TypeCode.TC_Object); Internals.Add_Parameter (TC_DomainManager_Cache, To_Any (To_CORBA_String ("DomainManager"))); Internals.Add_Parameter (TC_DomainManager_Cache, To_Any (To_CORBA_String (Repository_Id))); TC_IDL_SEQUENCE_DomainManager_Cache := CORBA.TypeCode.Internals.Build_Sequence_TC (TC_DomainManager_Cache, 0); IDL_SEQUENCE_DomainManager_Helper.Initialize (Element_TC => TC_DomainManager_Cache, Sequence_TC => TC_IDL_SEQUENCE_DomainManager_Cache); TC_DomainManagersList_Cache := CORBA.TypeCode.Internals.Build_Alias_TC (Name => To_CORBA_String ("DomainManagersList"), Id => To_CORBA_String ("IDL:CORBA_A/DomainManagersList:1.0"), Parent => TC_IDL_SEQUENCE_DomainManager); end Deferred_Initialization; -------------- -- From_Any -- -------------- function From_Any (Item : Any) return IDL_SEQUENCE_DomainManager.Sequence renames IDL_SEQUENCE_DomainManager_Helper.From_Any; function From_Any (Item : Any) return Ref is begin return To_Ref (Object.Helper.From_Any (Item)); end From_Any; ---------------------- -- TC_DomainManager -- ---------------------- function TC_DomainManager return TypeCode.Object is begin return TC_DomainManager_Cache; end TC_DomainManager; --------------------------- -- TC_DomainManagersList -- --------------------------- function TC_DomainManagersList return TypeCode.Object is begin return TC_DomainManagersList_Cache; end TC_DomainManagersList; ----------------------------------- -- TC_IDL_SEQUENCE_DomainManager -- ----------------------------------- function TC_IDL_SEQUENCE_DomainManager return TypeCode.Object is begin return TC_IDL_SEQUENCE_DomainManager_Cache; end TC_IDL_SEQUENCE_DomainManager; ------------ -- To_Any -- ------------ function To_Any (Item : IDL_SEQUENCE_DomainManager.Sequence) return Any renames IDL_SEQUENCE_DomainManager_Helper.To_Any; function To_Any (Item : Ref) return Any is Result : Any := Object.Helper.To_Any (Object.Ref (Item)); begin Internals.Set_Type (Result, TC_DomainManager); return Result; end To_Any; ------------ -- To_Ref -- ------------ function To_Ref (The_Ref : Object.Ref'Class) return Ref is begin if Object.Is_Nil (The_Ref) or else Object.Is_A (The_Ref, Repository_Id) then return Unchecked_To_Ref (The_Ref); end if; Raise_Bad_Param (Default_Sys_Member); end To_Ref; ---------------------- -- Unchecked_To_Ref -- ---------------------- function Unchecked_To_Ref (The_Ref : Object.Ref'Class) return Ref is Result : Ref; begin Set (Result, Object.Object_Of (The_Ref)); return Result; end Unchecked_To_Ref; begin declare use PolyORB.Initialization; use PolyORB.Initialization.String_Lists; use PolyORB.Utils.Strings; begin Register_Module (Module_Info' (Name => +"corba.domainmanager.helper", Conflicts => Empty, Depends => +"corba" & "any", Provides => Empty, Implicit => False, Init => Deferred_Initialization'Access, Shutdown => null)); end; end CORBA.DomainManager.Helper; polyorb-2.8~20110207.orig/src/corba/polyorb-corba_p-policy.adb0000644000175000017500000000600611750740340023317 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . C O R B A _ P . P O L I C Y -- -- -- -- B o d y -- -- -- -- Copyright (C) 2003 Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by ACT Europe. -- -- (email: sales@act-europe.fr) -- -- -- ------------------------------------------------------------------------------ package body PolyORB.CORBA_P.Policy is --------------------- -- Get_Policy_Type -- --------------------- function Get_Policy_Type (Self : Policy_Object_Type) return CORBA.PolicyType is begin return Self.Policy; end Get_Policy_Type; --------------------- -- Set_Policy_Type -- --------------------- procedure Set_Policy_Type (Self : in out Policy_Object_Type; Policy : CORBA.PolicyType) is begin Self.Policy := Policy; end Set_Policy_Type; ---------------------- -- Get_Policy_Value -- ---------------------- function Get_Policy_Value (Self : Policy_Object_Type) return CORBA.Any is begin return Self.Value; end Get_Policy_Value; ---------------------- -- Set_Policy_Value -- ---------------------- procedure Set_Policy_Value (Self : in out Policy_Object_Type; Value : CORBA.Any) is begin Self.Value := Value; end Set_Policy_Value; end PolyORB.CORBA_P.Policy; polyorb-2.8~20110207.orig/src/corba/corba-context.adb0000644000175000017500000001051511750740337021507 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- C O R B A . C O N T E X T -- -- -- -- B o d y -- -- -- -- Copyright (C) 2001-2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ package body CORBA.Context is ------------------- -- Set_One_Value -- ------------------- procedure Set_One_Value (Self : Ref; Prop_Name : Identifier; Value : CORBA.String) is pragma Unreferenced (Self, Prop_Name, Value); begin CORBA.Raise_No_Implement (CORBA.Default_Sys_Member); end Set_One_Value; ---------------- -- Set_Values -- ---------------- procedure Set_Values (Self : Ref; Values : CORBA.NVList.Ref) is pragma Warnings (Off); pragma Unreferenced (Self, Values); pragma Warnings (On); begin CORBA.Raise_No_Implement (CORBA.Default_Sys_Member); end Set_Values; ---------------- -- Get_Values -- ---------------- procedure Get_Values (Self : Ref; Start_Scope : Identifier; This_Object : Boolean := True; Prop_Name : Identifier; Values : out CORBA.NVList.Ref) is pragma Unreferenced (Self, Start_Scope, This_Object, Prop_Name); Dummy : CORBA.NVList.Ref; pragma Warnings (Off, Dummy); -- No explicit initialization. begin Values := Dummy; CORBA.Raise_No_Implement (CORBA.Default_Sys_Member); end Get_Values; ------------------- -- Delete_Values -- ------------------- procedure Delete_Values (Self : Ref; Prop_Name : Identifier) is pragma Unreferenced (Self, Prop_Name); begin CORBA.Raise_No_Implement (CORBA.Default_Sys_Member); end Delete_Values; ------------------ -- Create_Child -- ------------------ procedure Create_Child (Self : Ref; Ctx_Name : Identifier; Child_Ctx : out Ref) is pragma Unreferenced (Self, Ctx_Name); Dummy : Ref; pragma Warnings (Off, Dummy); -- No explicit initialization. begin Child_Ctx := Dummy; CORBA.Raise_No_Implement (CORBA.Default_Sys_Member); end Create_Child; ------------ -- Delete -- ------------ procedure Delete (Self : Ref; Del_Flags : Flags) is pragma Unreferenced (Self, Del_Flags); begin CORBA.Raise_No_Implement (CORBA.Default_Sys_Member); end Delete; end CORBA.Context; polyorb-2.8~20110207.orig/src/corba/corba-exceptionlist.ads0000644000175000017500000000754511750740337022747 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- C O R B A . E X C E P T I O N L I S T -- -- -- -- S p e c -- -- -- -- Copyright (C) 2001-2008, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the CORBA Specification, and adapted -- -- for use with PolyORB. The copyright notice above, and the license -- -- provisions that follow apply solely to the contents neither explicitly -- -- nor implicitly specified by the CORBA Specification defined by the OMG. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- Implementation Note: this package implements the recommendation of -- the OMG issue #3706, that add new primitives to CORBA::Object. -- See CORBA.Object package specifications for more details. with CORBA.AbstractBase; pragma Elaborate_All (CORBA.AbstractBase); with PolyORB.Any.ExceptionList; package CORBA.ExceptionList is pragma Elaborate_Body; type Ref is new CORBA.AbstractBase.Ref with null record; Nil_Ref : constant Ref; function Get_Count (Self : Ref) return CORBA.Unsigned_Long; procedure Add (Self : Ref; Exc : CORBA.TypeCode.Object); function Item (Self : Ref; Index : CORBA.Unsigned_Long) return CORBA.TypeCode.Object; procedure Remove (Self : Ref; Index : CORBA.Unsigned_Long); procedure Create_List (Self : out Ref); function Search_Exception_Id (Self : Ref; Name : CORBA.RepositoryId) return CORBA.Unsigned_Long; package Internals is -- Internal implementation subprograms. These shall not be -- used outside of PolyORB. function To_PolyORB_Ref (Self : Ref) return PolyORB.Any.ExceptionList.Ref; function To_CORBA_Ref (Self : PolyORB.Any.ExceptionList.Ref) return Ref; end Internals; private Nil_Ref : constant Ref := (CORBA.AbstractBase.Ref with null record); pragma Inline (Get_Count, Add, Item, Remove, Create_List, Search_Exception_Id); end CORBA.ExceptionList; polyorb-2.8~20110207.orig/src/corba/iop/0000755000175000017500000000000011750740340017046 5ustar xavierxavierpolyorb-2.8~20110207.orig/src/corba/iop/iop-codec-impl.ads0000644000175000017500000000637611750740340022354 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- I O P . C O D E C . I M P L -- -- -- -- S p e c -- -- -- -- Copyright (C) 2004-2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with CORBA.Local; with PolyORB.Representations.CDR; package IOP.Codec.Impl is type Object is new CORBA.Local.Object with private; type Object_Ptr is access all Object'Class; function Encode (Self : access Object; Data : CORBA.Any) return CORBA.IDL_SEQUENCES.OctetSeq; function Decode (Self : access Object; Data : CORBA.IDL_SEQUENCES.OctetSeq) return CORBA.Any; function Encode_Value (Self : access Object; Data : CORBA.Any) return CORBA.IDL_SEQUENCES.OctetSeq; function Decode_Value (Self : access Object; Data : CORBA.IDL_SEQUENCES.OctetSeq; TC : CORBA.TypeCode.Object) return CORBA.Any; procedure Init (Self : access Object; Representation : PolyORB.Representations.CDR.CDR_Representation_Access); -- Internal initialization subprogram private type Object is new CORBA.Local.Object with record Representation : PolyORB.Representations.CDR.CDR_Representation_Access; end record; function Is_A (Self : not null access Object; Logical_Type_Id : Standard.String) return Boolean; -- Derived from PolyORB.Smart_Pointers.Entity procedure Finalize (Self : in out Object); end IOP.Codec.Impl; polyorb-2.8~20110207.orig/src/corba/iop/iop-codec-impl.adb0000644000175000017500000001615211750740340022324 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- I O P . C O D E C . I M P L -- -- -- -- B o d y -- -- -- -- Copyright (C) 2004-2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with Ada.Streams; with Ada.Unchecked_Deallocation; with PolyORB.Any; with PolyORB.Buffers; with PolyORB.Errors; with PolyORB.Representations.CDR.Common; package body IOP.Codec.Impl is use Ada.Streams; use PolyORB.Buffers; use PolyORB.Errors; use PolyORB.Representations.CDR; use PolyORB.Representations.CDR.Common; procedure Free is new Ada.Unchecked_Deallocation (CDR_Representation'Class, CDR_Representation_Access); function To_Sequence (Item : Encapsulation) return CORBA.IDL_SEQUENCES.OctetSeq; function To_Encapsulation (Item : CORBA.IDL_SEQUENCES.OctetSeq) return Encapsulation; ------------ -- Decode -- ------------ function Decode (Self : access Object; Data : CORBA.IDL_SEQUENCES.OctetSeq) return CORBA.Any is Data_Enc : aliased Encapsulation := To_Encapsulation (Data); Buffer : Buffer_Access := new Buffer_Type; Result : PolyORB.Any.Any; begin Decapsulate (Data_Enc'Access, Buffer); Result := Unmarshall (Buffer, Self.Representation); Release (Buffer); return CORBA.Any (Result); end Decode; ------------------ -- Decode_Value -- ------------------ function Decode_Value (Self : access Object; Data : CORBA.IDL_SEQUENCES.OctetSeq; TC : CORBA.TypeCode.Object) return CORBA.Any is Data_Enc : aliased Encapsulation := To_Encapsulation (Data); Buffer : Buffer_Access := new Buffer_Type; Error : Error_Container; Result : constant PolyORB.Any.Any := PolyORB.Any.Get_Empty_Any (CORBA.TypeCode.Internals.To_PolyORB_Object (TC)); use PolyORB.Any; begin Decapsulate (Data_Enc'Access, Buffer); Unmarshall_To_Any (Self.Representation, Buffer, Get_Container (Result).all, Error); Release (Buffer); if Found (Error) then Catch (Error); raise Program_Error; -- XXX Handling of errors must be investigated end if; return CORBA.Any (Result); end Decode_Value; ------------ -- Encode -- ------------ function Encode (Self : access Object; Data : CORBA.Any) return CORBA.IDL_SEQUENCES.OctetSeq is Buffer : Buffer_Access := new Buffer_Type; Result : CORBA.IDL_SEQUENCES.OctetSeq; begin Start_Encapsulation (Buffer); Marshall (Buffer, Self.Representation, PolyORB.Any.Any (Data)); Result := To_Sequence (Encapsulate (Buffer)); Release (Buffer); return Result; end Encode; ------------------ -- Encode_Value -- ------------------ function Encode_Value (Self : access Object; Data : CORBA.Any) return CORBA.IDL_SEQUENCES.OctetSeq is Buffer : Buffer_Access := new Buffer_Type; Error : Error_Container; Result : CORBA.IDL_SEQUENCES.OctetSeq; use PolyORB.Any; begin Start_Encapsulation (Buffer); Marshall_From_Any (Self.Representation, Buffer, CORBA.Get_Container (Data).all, Error); if Found (Error) then Release (Buffer); Catch (Error); raise Program_Error; -- XXX Handling of errors must be investigated end if; Result := To_Sequence (Encapsulate (Buffer)); Release (Buffer); return Result; end Encode_Value; -------------- -- Finalize -- -------------- procedure Finalize (Self : in out Object) is begin Release (Self.Representation.all); Free (Self.Representation); end Finalize; ---------- -- Init -- ---------- procedure Init (Self : access Object; Representation : CDR_Representation_Access) is begin Self.Representation := Representation; end Init; ---------- -- Is_A -- ---------- function Is_A (Self : not null access Object; Logical_Type_Id : Standard.String) return Boolean is pragma Unreferenced (Self); begin return CORBA.Is_Equivalent (Logical_Type_Id, IOP.Codec.Repository_Id) or else CORBA.Is_Equivalent (Logical_Type_Id, "IDL:omg.org/CORBA/Object:1.0"); end Is_A; ---------------------- -- To_Encapsulation -- ---------------------- function To_Encapsulation (Item : CORBA.IDL_SEQUENCES.OctetSeq) return Encapsulation is Result : Encapsulation (1 .. Stream_Element_Offset (CORBA.IDL_SEQUENCES.Length (Item))); begin for J in Result'Range loop Result (J) := Stream_Element (CORBA.IDL_SEQUENCES.Get_Element (Item, Integer (J))); end loop; return Result; end To_Encapsulation; ----------------- -- To_Sequence -- ----------------- function To_Sequence (Item : Encapsulation) return CORBA.IDL_SEQUENCES.OctetSeq is Result : CORBA.IDL_SEQUENCES.OctetSeq; begin for J in Item'Range loop CORBA.IDL_SEQUENCES.Append (Result, CORBA.Octet (Item (J))); end loop; return Result; end To_Sequence; end IOP.Codec.Impl; polyorb-2.8~20110207.orig/src/corba/iop/polyorb-corba_p-codec_utils.adb0000644000175000017500000000637011750740340025110 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . C O R B A _ P . C O D E C _ U T I L S -- -- -- -- B o d y -- -- -- -- Copyright (C) 2004-2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with Ada.Streams; package body PolyORB.CORBA_P.Codec_Utils is use Ada.Streams; ---------------------- -- To_Encapsulation -- ---------------------- function To_Encapsulation (Item : CORBA.IDL_SEQUENCES.IDL_SEQUENCE_Octet.Sequence) return PolyORB.Representations.CDR.Common.Encapsulation is Result : PolyORB.Representations.CDR.Common.Encapsulation (1 .. Stream_Element_Offset (CORBA.IDL_SEQUENCES.IDL_SEQUENCE_Octet.Length (Item))); begin for J in Result'Range loop Result (J) := Stream_Element (CORBA.IDL_SEQUENCES.IDL_SEQUENCE_Octet.Get_Element (Item, Integer (J))); end loop; return Result; end To_Encapsulation; ----------------- -- To_Sequence -- ----------------- function To_Sequence (Item : PolyORB.Representations.CDR.Common.Encapsulation) return CORBA.IDL_SEQUENCES.IDL_SEQUENCE_Octet.Sequence is Result : CORBA.IDL_SEQUENCES.IDL_SEQUENCE_Octet.Sequence; begin for J in Item'Range loop CORBA.IDL_SEQUENCES.IDL_SEQUENCE_Octet.Append (Result, CORBA.Octet (Item (J))); end loop; return Result; end To_Sequence; end PolyORB.CORBA_P.Codec_Utils; polyorb-2.8~20110207.orig/src/corba/iop/iop-codecfactory-impl.adb0000644000175000017500000001153311750740340023712 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- I O P . C O D E C F A C T O R Y . I M P L -- -- -- -- B o d y -- -- -- -- Copyright (C) 2004-2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with CORBA.Impl; with PolyORB.CORBA_P.Initial_References; with PolyORB.Initialization; with PolyORB.Representations.CDR; with PolyORB.Types; with PolyORB.Utils.Strings.Lists; with IOP.Codec.Impl; with IOP.CodecFactory.Helper; package body IOP.CodecFactory.Impl is use PolyORB.Representations.CDR; function Create return CORBA.Object.Ref; procedure Deferred_Initialization; ------------ -- Create -- ------------ function Create return CORBA.Object.Ref is Result : Local_Ref; Current : constant CORBA.Impl.Object_Ptr := new Object; begin Set (Result, Current); return CORBA.Object.Ref (Result); end Create; ------------------ -- Create_Codec -- ------------------ function Create_Codec (Self : access Object; Enc : Encoding) return IOP.Codec.Local_Ref is pragma Unreferenced (Self); Representation : CDR_Representation_Access; Ptr : IOP.Codec.Impl.Object_Ptr; Result : IOP.Codec.Local_Ref; begin case Enc.Format is when Encoding_CDR_Encaps => Representation := Create_Representation (PolyORB.Types.Octet (Enc.Major_Version), PolyORB.Types.Octet (Enc.Minor_Version)); if Representation /= null then Ptr := new IOP.Codec.Impl.Object; IOP.Codec.Impl.Init (Ptr, Representation); IOP.Codec.Set (Result, CORBA.Impl.Object_Ptr (Ptr)); return Result; end if; when others => null; end case; Helper.Raise_UnknownEncoding ((null record)); end Create_Codec; ----------------------------- -- Deferred_Initialization -- ----------------------------- procedure Deferred_Initialization is begin PolyORB.CORBA_P.Initial_References.Register_Initial_Reference ("CodecFactory", Create'Access); end Deferred_Initialization; ---------- -- Is_A -- ---------- function Is_A (Self : not null access Object; Logical_Type_Id : Standard.String) return Boolean is pragma Unreferenced (Self); begin return CORBA.Is_Equivalent (Logical_Type_Id, IOP.CodecFactory.Repository_Id) or else CORBA.Is_Equivalent (Logical_Type_Id, "IDL:omg.org/CORBA/Object:1.0"); end Is_A; begin declare use PolyORB.Initialization; use PolyORB.Utils.Strings; use PolyORB.Utils.Strings.Lists; begin Register_Module (Module_Info' (Name => +"ior.codecfactory.impl", Conflicts => Empty, Depends => +"corba.initial_references", Provides => Empty, Implicit => False, Init => Deferred_Initialization'Access, Shutdown => null)); end; end IOP.CodecFactory.Impl; polyorb-2.8~20110207.orig/src/corba/iop/polyorb-corba_p-codec_utils.ads0000644000175000017500000000470511750740340025131 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . C O R B A _ P . C O D E C _ U T I L S -- -- -- -- S p e c -- -- -- -- Copyright (C) 2004-2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with CORBA.IDL_SEQUENCES; with PolyORB.Representations.CDR.Common; package PolyORB.CORBA_P.Codec_Utils is function To_Sequence (Item : PolyORB.Representations.CDR.Common.Encapsulation) return CORBA.IDL_SEQUENCES.IDL_SEQUENCE_Octet.Sequence; function To_Encapsulation (Item : CORBA.IDL_SEQUENCES.IDL_SEQUENCE_Octet.Sequence) return PolyORB.Representations.CDR.Common.Encapsulation; end PolyORB.CORBA_P.Codec_Utils; polyorb-2.8~20110207.orig/src/corba/iop/iop-codecfactory-impl.ads0000644000175000017500000000475511750740340023743 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- I O P . C O D E C F A C T O R Y . I M P L -- -- -- -- S p e c -- -- -- -- Copyright (C) 2004-2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with CORBA.Local; package IOP.CodecFactory.Impl is type Object is new CORBA.Local.Object with private; type Object_Ptr is access all Object'Class; function Create_Codec (Self : access Object; Enc : Encoding) return IOP.Codec.Local_Ref; private type Object is new CORBA.Local.Object with null record; function Is_A (Self : not null access Object; Logical_Type_Id : Standard.String) return Boolean; end IOP.CodecFactory.Impl; polyorb-2.8~20110207.orig/src/corba/polyorb-corba_p-adapteractivator.ads0000644000175000017500000000633211750740340025400 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . C O R B A _ P . A D A P T E R A C T I V A T O R -- -- -- -- S p e c -- -- -- -- Copyright (C) 2003-2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- This package provides glue codee between PolyORB's -- AdapterActivator and CORBA specific AdapterActivator. with PortableServer.AdapterActivator; with PolyORB.Errors; with PolyORB.POA_Types; with PolyORB.Smart_Pointers; package PolyORB.CORBA_P.AdapterActivator is package PPT renames PolyORB.POA_Types; type CORBA_AdapterActivator is new PPT.AdapterActivator with private; procedure Create (Self : out PPT.AdapterActivator_Access; AA : access PortableServer.AdapterActivator.Ref'Class); function Get_Adapter_Activator (Self : CORBA_AdapterActivator) return PortableServer.AdapterActivator.Ref'Class; procedure Unknown_Adapter (Self : access CORBA_AdapterActivator; Parent : access PPT.Obj_Adapter'Class; Name : String; Result : out Boolean; Error : in out PolyORB.Errors.Error_Container); private type CORBA_AdapterActivator is new PPT.AdapterActivator with null record; type AA_Ptr is access all PortableServer.AdapterActivator.Ref'Class; type Object is new PolyORB.Smart_Pointers.Non_Controlled_Entity with record AA : AA_Ptr; end record; type Object_Ptr is access all Object; end PolyORB.CORBA_P.AdapterActivator; polyorb-2.8~20110207.orig/src/corba/corba-abstractbase.ads0000644000175000017500000000731611750740337022507 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- C O R B A . A B S T R A C T B A S E -- -- -- -- S p e c -- -- -- -- Copyright (C) 2001-2008, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the CORBA Specification, and adapted -- -- for use with PolyORB. The copyright notice above, and the license -- -- provisions that follow apply solely to the contents neither explicitly -- -- nor implicitly specified by the CORBA Specification defined by the OMG. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with PolyORB.References; with CORBA.Impl; package CORBA.AbstractBase is pragma Elaborate_Body; type Ref is new PolyORB.References.Ref with private; -- procedure Set -- (The_Ref : in out Ref; -- The_Object : CORBA.Impl.Object_Ptr); -- Since CORBA.Impl.Object_Ptr is declared as a subtype -- of PolyORB.Smart_Pointers.Entity_Ptr, the Set operation -- is implicitly inherited from PolyORB.Smart_Pointers.Ref. function Object_Of (The_Ref : Ref) return CORBA.Impl.Object_Ptr; function Get (The_Ref : Ref) return CORBA.Impl.Object_Ptr renames Object_Of; -- The following primitive operations are inherited -- from PolyORB.Smart_Pointers.Ref. -- procedure Set -- (The_Ref : in out Ref; -- The_Entity : Ref_Ptr); -- procedure Unref (The_Ref : in out Ref) -- renames Finalize; -- function Is_Nil (The_Ref : Ref) return Boolean; -- function Is_Null (The_Ref : Ref) return Boolean -- renames Is_Nil; -- procedure Duplicate (The_Ref : in out Ref) -- renames Adjust; -- procedure Release (The_Ref : in out Ref); Nil_Ref : constant Ref; private type Ref is new PolyORB.References.Ref with null record; Nil_Ref : constant Ref := (PolyORB.References.Ref with null record); end CORBA.AbstractBase; polyorb-2.8~20110207.orig/src/corba/portableserver-servantmanager-impl.adb0000644000175000017500000000506011750740340025741 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O R T A B L E S E R V E R . S E R V A N T M A N A G E R . I M P L -- -- -- -- B o d y -- -- -- -- Copyright (C) 2005-2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with CORBA; package body PortableServer.ServantManager.Impl is ---------- -- Is_A -- ---------- function Is_A (Self : not null access Object; Logical_Type_Id : Standard.String) return Boolean is pragma Unreferenced (Self); begin return CORBA.Is_Equivalent (Logical_Type_Id, PortableServer.ServantManager.Repository_Id) or else CORBA.Is_Equivalent (Logical_Type_Id, "IDL:omg.org/CORBA/Object:1.0"); end Is_A; end PortableServer.ServantManager.Impl; polyorb-2.8~20110207.orig/src/corba/polyorb-corba_p-names.ads0000644000175000017500000000463011750740340023145 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . C O R B A _ P . N A M E S -- -- -- -- S p e c -- -- -- -- Copyright (C) 2001-2002 Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by ACT Europe. -- -- (email: sales@act-europe.fr) -- -- -- ------------------------------------------------------------------------------ -- String constants defined by OMG specifications. package PolyORB.CORBA_P.Names is pragma Pure; function OMG_Prefix return String; function OMG_Version return String; function OMG_RepositoryId (Name : String) return String; private pragma Inline (OMG_Prefix); pragma Inline (OMG_Version); pragma Inline (OMG_RepositoryId); end PolyORB.CORBA_P.Names; polyorb-2.8~20110207.orig/src/corba/polyorb-corba_p-policy_management.adb0000644000175000017500000002356011750740340025517 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . C O R B A _ P . P O L I C Y _ M A N A G E M E N T -- -- -- -- B o d y -- -- -- -- Copyright (C) 2004-2007, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with PolyORB.Exceptions; package body PolyORB.CORBA_P.Policy_Management is type Policy_Info is record Registered : Boolean := False; POA_Level : Boolean; Domain_Level : Boolean; ORB_Level : Boolean; Thread_Level : Boolean; Reference_Level : Boolean; Factory : Policy_Factory; Compatibility_Check : Compatibility_Check_Proc; Reconciliation : Reconciliation_Proc; System_Default : CORBA.Policy.Ref; end record; Policy_Registry : array (CORBA.PolicyType range 1 .. 60) of Policy_Info; -------------------------- -- Add_Policy_Overrides -- -------------------------- procedure Add_Policy_Overrides (To : in out Policy_List; Policies : CORBA.Policy.PolicyList; Level : Policy_Override_Level) is use CORBA.Policy.IDL_SEQUENCE_Policy; The_Type : CORBA.PolicyType; Defined : array (Policy_List'Range) of Boolean := (others => False); begin for J in 1 .. Length (Policies) loop The_Type := CORBA.Policy.Get_Policy_Type (Get_Element (Policies, J)); if Defined (The_Type) then CORBA.Raise_Bad_Param (CORBA.System_Exception_Members' (Minor => 30, Completed => CORBA.Completed_No)); else Defined (The_Type) := True; end if; case Level is when POA_Level => if not Is_POA_Policy (The_Type) then CORBA.Raise_No_Permission (CORBA.Default_Sys_Member); end if; when ORB_Level => if not Is_ORB_Policy (The_Type) then CORBA.Raise_No_Permission (CORBA.Default_Sys_Member); end if; when Thread_Level => if not Is_Thread_Policy (The_Type) then CORBA.Raise_No_Permission (CORBA.Default_Sys_Member); end if; when Reference_Level => if not Is_Reference_Policy (The_Type) then CORBA.Raise_No_Permission (CORBA.Default_Sys_Member); end if; when Domain_Level => raise Program_Error; end case; To (The_Type) := Get_Element (Policies, J); end loop; end Add_Policy_Overrides; ------------------------- -- Check_Compatibility -- ------------------------- procedure Check_Compatibility (Policies : Policy_List; Indexes : out CORBA.Unsigned_Short) is use type CORBA.Unsigned_Short; begin Indexes := 0; for J in Policies'Range loop if not CORBA.Policy.Is_Null (Policies (J)) and then Policy_Registry (J).Compatibility_Check /= null then Policy_Registry (J).Compatibility_Check (Policies (J), Policies, Indexes); if Indexes /= 0 then return; end if; end if; end loop; end Check_Compatibility; ------------------------ -- Get_Policy_Factory -- ------------------------ function Get_Policy_Factory (The_Type : CORBA.PolicyType) return Policy_Factory is begin pragma Assert (Policy_Registry (The_Type).Registered); return Policy_Registry (The_Type).Factory; end Get_Policy_Factory; -------------------------- -- Get_Policy_Overrides -- -------------------------- function Get_Policy_Overrides (From : Policy_List; TS : CORBA.Policy.PolicyTypeSeq) return CORBA.Policy.PolicyList is use CORBA.Policy.IDL_SEQUENCE_Policy; use CORBA.Policy.IDL_SEQUENCE_PolicyType; Result : CORBA.Policy.PolicyList; begin if Length (TS) = 0 then for J in From'Range loop if not CORBA.Policy.Is_Null (From (J)) then Append (Result, From (J)); end if; end loop; else for J in 1 .. Length (TS) loop if not CORBA.Policy.Is_Null (From (Get_Element (TS, J))) then Append (Result, From (Get_Element (TS, J))); end if; end loop; end if; return Result; end Get_Policy_Overrides; ---------------------- -- Is_Domain_Policy -- ---------------------- function Is_Domain_Policy (The_Type : CORBA.PolicyType) return Boolean is begin pragma Assert (Policy_Registry (The_Type).Registered); return Policy_Registry (The_Type).Domain_Level; end Is_Domain_Policy; ------------------- -- Is_ORB_Policy -- ------------------- function Is_ORB_Policy (The_Type : CORBA.PolicyType) return Boolean is begin pragma Assert (Policy_Registry (The_Type).Registered); return Policy_Registry (The_Type).ORB_Level; end Is_ORB_Policy; ------------------- -- Is_POA_Policy -- ------------------- function Is_POA_Policy (The_Type : CORBA.PolicyType) return Boolean is begin pragma Assert (Policy_Registry (The_Type).Registered); return Policy_Registry (The_Type).POA_Level; end Is_POA_Policy; ------------------------- -- Is_Reference_Policy -- ------------------------- function Is_Reference_Policy (The_Type : CORBA.PolicyType) return Boolean is begin pragma Assert (Policy_Registry (The_Type).Registered); return Policy_Registry (The_Type).Reference_Level; end Is_Reference_Policy; ------------------- -- Is_Registered -- ------------------- function Is_Registered (The_Type : CORBA.PolicyType) return Boolean is begin return Policy_Registry (The_Type).Registered; end Is_Registered; ---------------------- -- Is_Thread_Policy -- ---------------------- function Is_Thread_Policy (The_Type : CORBA.PolicyType) return Boolean is begin pragma Assert (Policy_Registry (The_Type).Registered); return Policy_Registry (The_Type).Thread_Level; end Is_Thread_Policy; --------------------------------- -- Policy_System_Default_Value -- --------------------------------- function Policy_System_Default_Value (The_Type : CORBA.PolicyType) return CORBA.Policy.Ref is begin pragma Assert (Policy_Registry (The_Type).Registered); return Policy_Registry (The_Type).System_Default; end Policy_System_Default_Value; ----------------------- -- Raise_PolicyError -- ----------------------- procedure Raise_PolicyError (Members : CORBA.PolicyError_Members) is begin PolyORB.Exceptions.User_Raise_Exception (CORBA.PolicyError'Identity, Members); end Raise_PolicyError; -------------- -- Register -- -------------- procedure Register (The_Type : CORBA.PolicyType; POA_Level : Boolean := False; ORB_Level : Boolean := False; Thread_Level : Boolean := False; Reference_Level : Boolean := False; Domain_Level : Boolean := False; Factory : Policy_Factory := null; Compatibility_Check : Compatibility_Check_Proc := null; Reconciliation : Reconciliation_Proc := null; System_Default : CORBA.Policy.Ref := Null_Policy) is begin Policy_Registry (The_Type) := (Registered => True, POA_Level => POA_Level, Domain_Level => Domain_Level, ORB_Level => ORB_Level, Thread_Level => Thread_Level, Reference_Level => Reference_Level, Factory => Factory, Compatibility_Check => Compatibility_Check, Reconciliation => Reconciliation, System_Default => System_Default); end Register; end PolyORB.CORBA_P.Policy_Management; polyorb-2.8~20110207.orig/src/corba/corba-object-policies.adb0000644000175000017500000002462111750740337023101 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- C O R B A . O B J E C T . P O L I C I E S -- -- -- -- B o d y -- -- -- -- Copyright (C) 2005-2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with PolyORB.Annotations; with PolyORB.Any.NVList; with PolyORB.Binding_Data; with PolyORB.Components; with PolyORB.Errors; with PolyORB.ORB; with PolyORB.References.Binding; with PolyORB.Requests; with PolyORB.Setup; with PolyORB.Tasking.Threads.Annotations; with CORBA.DomainManager.Helper; with PolyORB.CORBA_P.Exceptions; with PolyORB.CORBA_P.Interceptors_Hooks; with PolyORB.CORBA_P.Local; with PolyORB.CORBA_P.Policy_Management; package body CORBA.Object.Policies is use PolyORB.Annotations; use PolyORB.CORBA_P.Policy_Management; ----------------------- -- Get_Client_Policy -- ----------------------- function Get_Client_Policy (Self : Ref'Class; The_Type : PolicyType) return CORBA.Policy.Ref is Npad : Notepad_Access; Note : Policy_Manager_Note; Result : CORBA.Policy.Ref; begin if Is_Nil (Self) then Raise_Inv_Objref (CORBA.Default_Sys_Member); end if; if PolyORB.CORBA_P.Local.Is_Local (Self) then Raise_No_Implement (No_Implement_Members'(Minor => 3, Completed => Completed_No)); end if; -- First, checking reference overrides Npad := PolyORB.References.Notepad_Of (Internals.To_PolyORB_Ref (Ref (Self))); Get_Note (Npad.all, Note, Empty_Policy_Manager_Note); Result := Note.Overrides (The_Type); if not CORBA.Policy.Is_Null (Result) then return Result; end if; -- Second, checking thread overrides Npad := PolyORB.Tasking.Threads.Annotations.Get_Current_Thread_Notepad; Get_Note (Npad.all, Note, Empty_Policy_Manager_Note); Result := Note.Overrides (The_Type); if not CORBA.Policy.Is_Null (Result) then return Result; end if; -- Third, checking ORB overrides Npad := PolyORB.ORB.Notepad_Of (PolyORB.Setup.The_ORB); Get_Note (Npad.all, Note, Empty_Policy_Manager_Note); Result := Note.Overrides (The_Type); if not CORBA.Policy.Is_Null (Result) then return Result; end if; -- Last, try to find default value return Policy_System_Default_Value (The_Type); end Get_Client_Policy; ------------------------- -- Get_Domain_Managers -- ------------------------- function Get_Domain_Managers (Self : Ref'Class) return CORBA.DomainManager.DomainManagersList is Operation_Name : constant Standard.String := "_domain_managers"; Request : aliased PolyORB.Requests.Request; Arg_List : PolyORB.Any.NVList.Ref; Result : PolyORB.Any.NamedValue; Result_Name : constant CORBA.String := To_CORBA_String ("Result"); begin if CORBA.Object.Is_Nil (Self) then CORBA.Raise_Inv_Objref (Default_Sys_Member); end if; PolyORB.Any.NVList.Create (Arg_List); Result := (Name => PolyORB.Types.Identifier (Result_Name), Argument => CORBA.Internals.Get_Empty_Any (CORBA.DomainManager.Helper.TC_IDL_SEQUENCE_DomainManager), Arg_Modes => 0); PolyORB.Requests.Setup_Request (Req => Request, Target => Internals.To_PolyORB_Ref (Ref (Self)), Operation => Operation_Name, Arg_List => Arg_List, Result => Result); PolyORB.CORBA_P.Interceptors_Hooks.Client_Invoke (Request'Access, PolyORB.Requests.Flags (0)); PolyORB.CORBA_P.Exceptions.Request_Raise_Occurrence (Request); return CORBA.DomainManager.Helper.From_Any (CORBA.Any (Result.Argument)); end Get_Domain_Managers; ---------------- -- Get_Policy -- ---------------- function Get_Policy (Self : Ref; Policy_Type : PolicyType) return CORBA.Policy.Ref is Result : CORBA.Policy.Ref; begin Result := Get_Client_Policy (Self, Policy_Type); if not Policy.Is_Nil (Result) then -- XXX Client policy should be reconcilied with value -- defined in IOR. Not supported for now. return Result; end if; if not Is_Domain_Policy (Policy_Type) then return Result; end if; -- Obtain domain list from Object declare use CORBA.DomainManager; use CORBA.DomainManager.IDL_SEQUENCE_DomainManager; Managers : constant DomainManagersList := Get_Domain_Managers (Self); begin -- XXX For now we simply find the first domain manager which -- hold information about the requested policy and return -- policy value. This is not conformant with CORBA -- specifications which require to resolve policy -- overlapping conflicts but not define any way to do this -- (CORBA 3.0.3 par. 4.10.1.4 Object Membership of Policy -- Domains). for J in 1 .. Length (Managers) loop begin Result := Get_Domain_Policy (Get_Element (Managers, J), Policy_Type); if not Policy.Is_Nil (Result) then return Result; end if; exception when CORBA.Inv_Policy => null; end; end loop; end; Raise_Inv_Policy (Default_Sys_Member); end Get_Policy; -------------------------- -- Get_Policy_Overrides -- -------------------------- function Get_Policy_Overrides (Self : Ref'Class; Types : CORBA.Policy.PolicyTypeSeq) return CORBA.Policy.PolicyList is Npad : Notepad_Access; Note : Policy_Manager_Note; begin if Is_Nil (Self) then Raise_Inv_Objref (CORBA.Default_Sys_Member); end if; if PolyORB.CORBA_P.Local.Is_Local (Self) then Raise_No_Implement (No_Implement_Members'(Minor => 3, Completed => Completed_No)); end if; Npad := PolyORB.References.Notepad_Of (Internals.To_PolyORB_Ref (Ref (Self))); Get_Note (Npad.all, Note, Empty_Policy_Manager_Note); return Get_Policy_Overrides (Note.Overrides, Types); end Get_Policy_Overrides; -------------------------- -- Set_Policy_Overrides -- -------------------------- procedure Set_Policy_Overrides (Self : Ref'Class; Policies : CORBA.Policy.PolicyList; Set_Add : SetOverrideType) is Npad : Notepad_Access; Note : Policy_Manager_Note; Indexes : CORBA.Unsigned_Short; begin if Is_Nil (Self) then Raise_Inv_Objref (CORBA.Default_Sys_Member); end if; if PolyORB.CORBA_P.Local.Is_Local (Self) then Raise_No_Implement (No_Implement_Members'(Minor => 3, Completed => Completed_No)); end if; Npad := PolyORB.References.Notepad_Of (Internals.To_PolyORB_Ref (Ref (Self))); if Set_Add = ADD_OVERRIDE then Get_Note (Npad.all, Note, Empty_Policy_Manager_Note); end if; Add_Policy_Overrides (Note.Overrides, Policies, Reference_Level); Check_Compatibility (Note.Overrides, Indexes); if Indexes /= 0 then raise Program_Error; -- XXX should raise the CORBA.InvalidPolicies exception end if; Set_Note (Npad.all, Note); end Set_Policy_Overrides; ------------------------- -- Validate_Connection -- ------------------------- procedure Validate_Connection (Self : Ref; Inconsistent_Policies : out CORBA.Policy.PolicyList; Result : out CORBA.Boolean) is pragma Unreferenced (Inconsistent_Policies); use PolyORB.Errors; The_Servant : PolyORB.Components.Component_Access; The_Profile : PolyORB.Binding_Data.Profile_Access; Error : Error_Container; begin PolyORB.References.Binding.Bind (CORBA.Object.Internals.To_PolyORB_Ref (Self), PolyORB.Setup.The_ORB, (others => null), The_Servant, The_Profile, False, Error); if Found (Error) then Result := False; if Error.Kind /= ForwardRequest_E then PolyORB.CORBA_P.Exceptions.Raise_From_Error (Error); else -- Do not propagate exception if we receive a -- ForwardRequest error. Catch (Error); return; end if; else Result := True; end if; end Validate_Connection; end CORBA.Object.Policies; polyorb-2.8~20110207.orig/src/corba/polyorb-corba_p-interceptors_hooks.ads0000644000175000017500000000675411750740340025777 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . C O R B A _ P . I N T E R C E P T O R S _ H O O K S -- -- -- -- S p e c -- -- -- -- Copyright (C) 2004-2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- Hook to set up request's invoke method used by the CORBA personality. with PolyORB.Binding_Data; with PolyORB.Errors; with PolyORB.POA; with PolyORB.Requests; with PolyORB.Smart_Pointers.Controlled_Entities; package PolyORB.CORBA_P.Interceptors_Hooks is package PSPCE renames PolyORB.Smart_Pointers.Controlled_Entities; type Client_Invoke_Handler is access procedure (Self : access PolyORB.Requests.Request; Flags : PolyORB.Requests.Flags); type Server_Invoke_Handler is access procedure (Self : access PSPCE.Entity'Class; -- Actually must be PortableServer.DynamicImplementation'Class. Request : access PolyORB.Requests.Request; Profile : PolyORB.Binding_Data.Profile_Access); type Server_Intermediate_Handler is access procedure (Self : access PolyORB.Requests.Request; From_Agruments : Boolean); type POA_Create_Handler is access procedure (POA : PolyORB.POA.Obj_Adapter_Access; Error : in out PolyORB.Errors.Error_Container); Client_Invoke : Client_Invoke_Handler := null; Server_Invoke : Server_Invoke_Handler := null; -- Server side hook initialized in PortableServer module. Server_Intermediate : Server_Intermediate_Handler := null; -- This hook used for call intermediate interception point Receive_Request. -- If program don't use PortableInterceptors this variable have null -- value. POA_Create : POA_Create_Handler := null; end PolyORB.CORBA_P.Interceptors_Hooks; polyorb-2.8~20110207.orig/src/corba/portableserver-current.adb0000644000175000017500000002175011750740340023453 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O R T A B L E S E R V E R . C U R R E N T -- -- -- -- B o d y -- -- -- -- Copyright (C) 2003-2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with PolyORB.CORBA_P.Initial_References; with PolyORB.Errors; with PolyORB.Initialization; with PolyORB.POA; with PolyORB.POA_Policies.Id_Assignment_Policy; with PolyORB.POA_Types; with PolyORB.Servants; with PolyORB.Smart_Pointers; with PolyORB.Tasking.Threads.Annotations; with PolyORB.Types; with PolyORB.Utils.Strings.Lists; with PortableServer.POA; with PortableServer.Current.Helper; package body PortableServer.Current is use PolyORB.Errors; use PolyORB.Annotations; use PolyORB.Binding_Data; use PolyORB.POA; use PolyORB.POA_Policies.Id_Assignment_Policy; use PolyORB.POA_Types; use PolyORB.Tasking.Threads.Annotations; use PolyORB.Types; use PortableServer.Current.Helper; function Create return CORBA.Object.Ref; function Find_POA (Profile : Profile_Access) return PolyORB.POA.Obj_Adapter_Access; -- Find POA which manage object specified by profile ------------ -- Create -- ------------ function Create return CORBA.Object.Ref is Result : Local_Ref; Current : constant PolyORB.Smart_Pointers.Entity_Ptr := new Current_Object; begin Set (Result, Current); return CORBA.Object.Ref (Result); end Create; -------------- -- Find_POA -- -------------- function Find_POA (Profile : Profile_Access) return PolyORB.POA.Obj_Adapter_Access is U_Oid : Unmarshalled_Oid; Obj_OA : PolyORB.POA.Obj_Adapter_Access; Error : Error_Container; begin Oid_To_U_Oid (Get_Object_Key (Profile.all).all, U_Oid, Error); if Found (Error) then raise Program_Error; end if; Find_POA (PolyORB.POA.Obj_Adapter_Access (Get_OA (Profile.all)), To_Standard_String (U_Oid.Creator), True, Obj_OA, Error); if Found (Error) then raise Program_Error; end if; return Obj_OA; end Find_POA; ---------- -- Is_A -- ---------- function Is_A (Obj : not null access Current_Object; Logical_Type_Id : Standard.String) return Boolean is pragma Unreferenced (Obj); begin return CORBA.Is_Equivalent (Logical_Type_Id, "IDL:omg.org/PortableServer/Current:1.0") or else CORBA.Is_Equivalent (Logical_Type_Id, "IDL:omg.org/CORBA/Object:1.0"); end Is_A; ------------ -- To_Ref -- ------------ function To_Ref (Self : CORBA.Object.Ref'Class) return Local_Ref is Result : Local_Ref; begin if CORBA.Object.Entity_Of (Self).all not in Current_Object'Class then CORBA.Raise_Bad_Param (CORBA.Default_Sys_Member); end if; Set (Result, CORBA.Object.Entity_Of (Self)); return Result; end To_Ref; ------------- -- Get_POA -- ------------- function Get_POA (Self : Local_Ref) return PortableServer.POA_Forward.Ref is pragma Unreferenced (Self); use type PolyORB.Requests.Request_Access; Note : PortableServer_Current_Note; begin Get_Note (Get_Current_Thread_Notepad.all, Note, Null_PortableServer_Current_Note); if Note.Request = null then Raise_NoContext ((CORBA.IDL_Exception_Members with null record)); end if; return POA.Convert.To_Forward (POA.Internals.To_CORBA_POA (Find_POA (Note.Profile))); end Get_POA; ------------------- -- Get_Object_Id -- ------------------- function Get_Object_Id (Self : Local_Ref) return ObjectId is pragma Unreferenced (Self); use type PolyORB.Requests.Request_Access; Note : PortableServer_Current_Note; Error : Error_Container; Oid : PolyORB.Objects.Object_Id_Access; begin Get_Note (Get_Current_Thread_Notepad.all, Note, Null_PortableServer_Current_Note); if Note.Request = null then Raise_NoContext ((CORBA.IDL_Exception_Members with null record)); end if; Object_Identifier (Find_POA (Note.Profile).Id_Assignment_Policy.all, Get_Object_Key (Note.Profile.all), Oid, Error); if Found (Error) then raise Program_Error; end if; declare Result : constant ObjectId := Internals.To_PortableServer_ObjectId (Oid.all); begin Free (Oid); return Result; end; end Get_Object_Id; ------------------- -- Get_Reference -- ------------------- function Get_Reference (Self : Local_Ref) return CORBA.Object.Ref is pragma Unreferenced (Self); use type PolyORB.Requests.Request_Access; Note : PortableServer_Current_Note; begin Get_Note (Get_Current_Thread_Notepad.all, Note, Null_PortableServer_Current_Note); if Note.Request = null then Raise_NoContext ((CORBA.IDL_Exception_Members with null record)); end if; return CORBA.Object.Internals.To_CORBA_Ref (Note.Request.Target); end Get_Reference; ----------------- -- Get_Servant -- ----------------- function Get_Servant (Self : Local_Ref) return Servant is pragma Unreferenced (Self); use type PolyORB.Requests.Request_Access; Note : PortableServer_Current_Note; Error : Error_Container; Neutral : PolyORB.Servants.Servant_Access; begin Get_Note (Get_Current_Thread_Notepad.all, Note, Null_PortableServer_Current_Note); if Note.Request = null then Raise_NoContext ((CORBA.IDL_Exception_Members with null record)); end if; Id_To_Servant (Find_POA (Note.Profile), Get_Object_Key (Note.Profile.all).all, Neutral, Error); if Found (Error) then raise Program_Error; end if; return Servant (CORBA.Impl.Internals.To_CORBA_Servant (Neutral)); end Get_Servant; ----------------- -- Get_Members -- ----------------- procedure Get_Members (From : Ada.Exceptions.Exception_Occurrence; To : out NoContext_Members) is use Ada.Exceptions; begin if Exception_Identity (From) /= NoContext'Identity then CORBA.Raise_Bad_Param (CORBA.Default_Sys_Member); end if; To := NoContext_Members' (CORBA.IDL_Exception_Members with null record); end Get_Members; ---------------- -- Initialize -- ---------------- procedure Initialize; procedure Initialize is use PolyORB.CORBA_P.Initial_References; begin Register_Initial_Reference ("POACurrent", Create'Access); PortableServer.PortableServer_Current_Registered := True; end Initialize; use PolyORB.Initialization; use PolyORB.Utils.Strings; use PolyORB.Utils.Strings.Lists; begin Register_Module (Module_Info' (Name => +"portableserver.current", Conflicts => Empty, Depends => +"corba.initial_references", Provides => Empty, Implicit => False, Init => Initialize'Access, Shutdown => null)); end PortableServer.Current; polyorb-2.8~20110207.orig/src/corba/polyorb-corba_p-poa_config.ads0000644000175000017500000000526111750740340024147 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . C O R B A _ P . P O A _ C O N F I G -- -- -- -- S p e c -- -- -- -- Copyright (C) 2003-2004 Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by ACT Europe. -- -- (email: sales@act-europe.fr) -- -- -- ------------------------------------------------------------------------------ -- Utility package to manipulate Policy list used to set up PolyORB's POA. with CORBA.Policy; with PolyORB.POA_Policies; package PolyORB.CORBA_P.POA_Config is function Convert_PolicyList (List : CORBA.Policy.PolicyList) return PolyORB.POA_Policies.PolicyList; -- Convert a CORBA.PolicyList into a PolyORB.POA_Policies.PolicyList type Policy_Type_Allocator is access function (Policy : CORBA.Policy.Ref) return PolyORB.POA_Policies.Policy_Access; procedure Register (Policy : CORBA.PolicyType; Allocator : Policy_Type_Allocator); -- Register a constructor function for Policy end PolyORB.CORBA_P.POA_Config; polyorb-2.8~20110207.orig/src/corba/polyorb-corba_p-local.ads0000644000175000017500000000556111750740340023140 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . C O R B A _ P . L O C A L -- -- -- -- S p e c -- -- -- -- Copyright (C) 2004-2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with CORBA.Object; with PolyORB.Smart_Pointers; with PolyORB.Smart_Pointers.Controlled_Entities; package PolyORB.CORBA_P.Local is type Local_Object_Base is abstract new PolyORB.Smart_Pointers.Controlled_Entities.Entity with null record; type Local_Object_Base_Ref is access all Local_Object_Base'Class; function Is_A (Obj : not null access Local_Object_Base; Logical_Type_Id : String) return Boolean is abstract; function Is_Local (Self : CORBA.Object.Ref'Class) return Boolean; -- True iff Self is a valid reference a local object. -- Raise CORBA.Inv_Objref if reference is null. function Is_CORBA_Local (Self : CORBA.Object.Ref'Class) return Boolean; -- True iff Self is a valid reference a CORBA personality local object. -- Raise CORBA.Inv_Objref if reference is null. end PolyORB.CORBA_P.Local; polyorb-2.8~20110207.orig/src/corba/corba-forward.adb0000644000175000017500000000533211750740337021470 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- C O R B A . F O R W A R D -- -- -- -- B o d y -- -- -- -- Copyright (C) 2001-2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ package body CORBA.Forward is package body Convert is -- Minimal implementation of conversion between forward references -- and complete references. ------------------ -- From_Forward -- ------------------ function From_Forward (The_Forward : Ref) return Ref_Type is Res : Ref_Type; begin Set (Res, Object_Of (The_Forward)); return Res; end From_Forward; ---------------- -- To_Forward -- ---------------- function To_Forward (The_Ref : Ref_Type) return Ref is Res : Ref; begin Set (Res, Object_Of (The_Ref)); return Res; end To_Forward; end Convert; end CORBA.Forward; polyorb-2.8~20110207.orig/src/corba/polyorb-corba_p-server_tools.ads0000644000175000017500000000763511750740340024600 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . C O R B A _ P . S E R V E R _ T O O L S -- -- -- -- S p e c -- -- -- -- Copyright (C) 2001-2009, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- Helper functions for CORBA servers. Note that using this unit implies -- using the Portable Object Adapter. with CORBA.Object; with PortableServer.POA; package PolyORB.CORBA_P.Server_Tools is pragma Elaborate_Body; type Hook_Type is access procedure; Initiate_Server_Hook : Hook_Type; -- Access to a procedure to be called upon start up. -- See Initiate_Server for more details. procedure Activate_Server; -- Start a new ORB, and initialize the Root POA. -- -- If the Initiate_Server_Hook variable is not null, the designated -- procedure will be called after initializing the ORB. procedure Initiate_Server (Start_New_Task : Boolean := False); -- Calls Activate_Server then starts ORB main loop. -- If Start_New_Task is True, a new task will be created and control will -- be returned to the caller. Otherwise, the ORB main loop will be executed -- in the current context. function Get_Root_POA return PortableServer.POA.Local_Ref; -- Return the Root_POA attached to the current ORB instance. procedure Initiate_Servant (S : PortableServer.Servant; R : out CORBA.Object.Ref'Class); -- Initiate a servant: register a servant to the Root POA. -- If the Root POA has not been initialized, initialize it. procedure Reference_To_Servant (R : CORBA.Object.Ref'Class; S : out PortableServer.Servant); -- Convert a CORBA.Object.Ref into a PortableServer.Servant. procedure Servant_To_Reference (S : PortableServer.Servant; R : out CORBA.Object.Ref'Class); -- Convert a PortableServer.Servant into CORBA.Object.Ref. procedure Initiate_Well_Known_Service (S : PortableServer.Servant; Name : String; R : out CORBA.Object.Ref'Class); -- Make S accessible through a reference appropriate for -- generation of a corbaloc URI with a named key of Name. end PolyORB.CORBA_P.Server_Tools; polyorb-2.8~20110207.orig/src/corba/corba-object.ads0000644000175000017500000001421511750740337021313 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- C O R B A . O B J E C T -- -- -- -- S p e c -- -- -- -- Copyright (C) 2001-2010, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the CORBA Specification, and adapted -- -- for use with PolyORB. The copyright notice above, and the license -- -- provisions that follow apply solely to the contents neither explicitly -- -- nor implicitly specified by the CORBA Specification defined by the OMG. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with PolyORB.References; with CORBA.AbstractBase; with CORBA.Context; with CORBA.ContextList; with CORBA.ExceptionList; with CORBA.NVList; with CORBA.Request; package CORBA.Object is type Ref is new CORBA.AbstractBase.Ref with private; function Get_Interface (Self : Ref) return CORBA.Object.Ref'Class; function Is_Nil (Self : Ref) return CORBA.Boolean; function Is_Null (Self : Ref) return CORBA.Boolean renames Is_Nil; procedure Duplicate (Self : in out Ref); procedure Release (Self : in out Ref); function Is_A (Self : Ref; Logical_Type_Id : Standard.String) return CORBA.Boolean; function Non_Existent (Self : Ref) return CORBA.Boolean; function Is_Equivalent (Self : Ref; Other_Object : Ref'Class) return Boolean; procedure Create_Request (Self : Ref; Ctx : CORBA.Context.Ref; Operation : Identifier; Arg_List : CORBA.NVList.Ref; Result : in out NamedValue; Request : out CORBA.Request.Object; Req_Flags : Flags); -- Implementation Note: the CORBA specifications define one -- possible value for Req_Flags: CORBA::OUT_LIST_MEMORY, which is -- currently not supported. The only possible value for -- Req_Flags is 0, all other values will be ignored for now. procedure Create_Request (Self : Ref; Ctx : CORBA.Context.Ref; Operation : Identifier; Arg_List : CORBA.NVList.Ref; Result : in out NamedValue; Exc_List : ExceptionList.Ref; Ctxt_List : ContextList.Ref; Request : out CORBA.Request.Object; Req_Flags : Flags); -- Implementation Notes: -- #1: see above -- -- #2: this procedure implements the recommendation detailed in -- the OMG issue #3706, that add new primitives to -- CORBA::Object. It adds the Exc_List and Ctxt_List parameters, -- to provide more control on the request created. function Hash (Self : Ref; Maximum : CORBA.Unsigned_Long) return CORBA.Unsigned_Long; -- Implementation Note: The following policy management related -- Object operations were moved into child package -- CORBA.Object.Policies to avoid circular dependency. -- -- function Get_Policy -- (Self : Ref; -- Policy_Type : PolicyType) -- return CORBA.Policy.Ref; -- function Get_Domain_Managers -- (Self : Ref) -- return CORBA.DomainManager.DomainManagerList; -- procedure Set_Policy_Overrides -- (Self : Ref; -- Policies : CORBA.Policy.PolicyList; -- Set_Add : SetOverrideType); -- function Get_Client_Policy -- (Self : Ref; -- The_Type : PolicyType) -- return CORBA.Policy.Ref; -- function Get_Policy_Overrides -- (Self : Ref; -- Types : CORBA.Policy.PolicyTypeSeq) -- return CORBA.Policy.PolicyList; -- procedure Validate_Connection -- (Self : Ref; -- Inconsistent_Policies : out CORBA.Policy.PolicyList; -- Result : out Boolean); function TC_Object return CORBA.TypeCode.Object; function Object_To_String (Obj : CORBA.Object.Ref'Class) return CORBA.String; package Internals is -- Implementation Note: This package defines internal subprograms -- specific to PolyORB. You must not use them. function To_PolyORB_Ref (R : Ref) return PolyORB.References.Ref; function To_CORBA_Ref (R : PolyORB.References.Ref) return Ref; -- Conversion functions between CORBA and neutral references. end Internals; private type Ref is new CORBA.AbstractBase.Ref with null record; pragma Inline (Object_To_String); end CORBA.Object; polyorb-2.8~20110207.orig/src/corba/portableserver-implicitactivationpolicy.ads0000644000175000017500000000545211750740340027127 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- PORTABLESERVER.IMPLICITACTIVATIONPOLICY -- -- -- -- S p e c -- -- -- -- Copyright (C) 2003-2008, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the CORBA Specification, and adapted -- -- for use with PolyORB. The copyright notice above, and the license -- -- provisions that follow apply solely to the contents neither explicitly -- -- nor implicitly specified by the CORBA Specification defined by the OMG. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with CORBA.Policy; package PortableServer.ImplicitActivationPolicy is type Ref is new CORBA.Policy.Ref with private; function To_Ref (The_Ref : CORBA.Object.Ref'Class) return Ref; function Get_Value (Self : Ref) return PortableServer.ImplicitActivationPolicyValue; private type Ref is new CORBA.Policy.Ref with null record; end PortableServer.ImplicitActivationPolicy; polyorb-2.8~20110207.orig/src/corba/corba-object-helper.ads0000644000175000017500000000551211750740337022570 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- C O R B A . O B J E C T . H E L P E R -- -- -- -- S p e c -- -- -- -- Copyright (C) 2001-2008, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the CORBA Specification, and adapted -- -- for use with PolyORB. The copyright notice above, and the license -- -- provisions that follow apply solely to the contents neither explicitly -- -- nor implicitly specified by the CORBA Specification defined by the OMG. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with PolyORB.Any; package CORBA.Object.Helper is -- See comments of the corresponding methods in package CORBA function To_Any (Item : CORBA.Object.Ref) return Any; function From_Any (Item : Any) return CORBA.Object.Ref; function Wrap (X : access CORBA.Object.Ref) return PolyORB.Any.Content'Class; function TC_Object return CORBA.TypeCode.Object renames CORBA.Object.TC_Object; end CORBA.Object.Helper; polyorb-2.8~20110207.orig/src/corba/polyorb-corba_p-initial_references.ads0000644000175000017500000000602511750740340025674 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . C O R B A _ P . I N I T I A L _ R E F E R E N C E S -- -- -- -- S p e c -- -- -- -- Copyright (C) 2003-2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- Support package for CORBA initial references. with CORBA.Object; with PolyORB.Utils.Strings.Lists; package PolyORB.CORBA_P.Initial_References is type Create_Ptr is access function return CORBA.Object.Ref; -- Allocator type procedure Register_Initial_Reference (Id : Standard.String; Allocator : Create_Ptr); -- Register (Id, Allocator) tuple procedure Register_Initial_Reference (Id : Standard.String; Ref : CORBA.Object.Ref); -- Register (Id, Ref) tuple function Resolve_Initial_References (Id : Standard.String) return CORBA.Object.Ref; -- Return a valid reference to an object if Id has been previously -- registred. -- If Id has been registred with a CORBA.Object.Ref, then returns it. -- If Id has been registred with an allocator, use this allocator -- to create a reference. function List_Initial_Services return PolyORB.Utils.Strings.Lists.List; -- List all registered references. end PolyORB.CORBA_P.Initial_References; polyorb-2.8~20110207.orig/src/corba/corba-abstractbase.adb0000644000175000017500000000444311750740337022464 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- C O R B A . A B S T R A C T B A S E -- -- -- -- B o d y -- -- -- -- Copyright (C) 2001 Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by ACT Europe. -- -- (email: sales@act-europe.fr) -- -- -- ------------------------------------------------------------------------------ package body CORBA.AbstractBase is --------------- -- Object_Of -- --------------- function Object_Of (The_Ref : Ref) return CORBA.Impl.Object_Ptr is begin return CORBA.Impl.Object_Ptr (Entity_Of (The_Ref)); end Object_Of; end CORBA.AbstractBase; polyorb-2.8~20110207.orig/src/corba/polyorb-corba_p-servantlocator.adb0000644000175000017500000001340111750740340025063 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . C O R B A _ P . S E R V A N T L O C A T O R -- -- -- -- B o d y -- -- -- -- Copyright (C) 2003-2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with CORBA.Impl; with CORBA.Object; package body PolyORB.CORBA_P.ServantLocator is ------------ -- Create -- ------------ procedure Create (Self : out PPT.ServantLocator_Access; SL : PortableServer.ServantLocator.Local_Ref'Class) is Locator : constant Object_Ptr := new Object; begin Self := new CORBA_ServantLocator; Locator.SL := PortableServer.ServantLocator.Local_Ref (SL); Set (CORBA_ServantLocator (Self.all), PolyORB.Smart_Pointers.Entity_Ptr (Locator)); end Create; ------------------------- -- Get_Servant_Manager -- ------------------------- function Get_Servant_Manager (Self : CORBA_ServantLocator) return PortableServer.ServantLocator.Local_Ref'Class is Locator : constant Object_Ptr := Object_Ptr (Entity_Of (Self)); begin return Locator.SL; end Get_Servant_Manager; --------------- -- Preinvoke -- --------------- procedure Preinvoke (Self : access CORBA_ServantLocator; Oid : PPT.Object_Id; Adapter : access PPT.Obj_Adapter'Class; Operation : PolyORB.Types.Identifier; The_Cookie : out PPT.Cookie; Returns : out PolyORB.Servants.Servant_Access; Error : in out PolyORB.Errors.Error_Container) is CORBA_POA : PortableServer.POA_Forward.Ref; CORBA_Servant : PortableServer.Servant; Locator : constant PortableServer.ServantLocator.Local_Ref'Class := Get_Servant_Manager (Self.all); begin PortableServer.POA_Forward.Set (CORBA_POA, PolyORB.Smart_Pointers.Entity_Ptr (Adapter)); begin PortableServer.ServantLocator.Preinvoke (Locator, PortableServer.Internals.To_PortableServer_ObjectId (Oid), CORBA_POA, CORBA.Identifier (Operation), PortableServer.ServantLocator.Cookie (The_Cookie), CORBA_Servant); exception when E : PortableServer.ForwardRequest => declare Members : PortableServer.ForwardRequest_Members; begin PortableServer.Get_Members (E, Members); Error.Kind := PolyORB.Errors.ForwardRequest_E; Error.Member := new PolyORB.Errors.ForwardRequest_Members' (Forward_Reference => PolyORB.Smart_Pointers.Ref (CORBA.Object.Internals.To_PolyORB_Ref (Members.Forward_Reference))); end; end; Returns := PortableServer.To_PolyORB_Servant (CORBA_Servant); end Preinvoke; ---------------- -- Postinvoke -- ---------------- procedure Postinvoke (Self : access CORBA_ServantLocator; Oid : PPT.Object_Id; Adapter : access PPT.Obj_Adapter'Class; Operation : PolyORB.Types.Identifier; The_Cookie : PPT.Cookie; The_Servant : PolyORB.Servants.Servant_Access) is CORBA_POA : PortableServer.POA_Forward.Ref; CORBA_Servant : constant PortableServer.Servant := PortableServer.Servant (CORBA.Impl.Internals.To_CORBA_Servant (The_Servant)); Locator : constant PortableServer.ServantLocator.Local_Ref'Class := Get_Servant_Manager (Self.all); begin PortableServer.POA_Forward.Set (CORBA_POA, PolyORB.Smart_Pointers.Entity_Ptr (Adapter)); PortableServer.ServantLocator.Postinvoke (Locator, PortableServer.Internals.To_PortableServer_ObjectId (Oid), CORBA_POA, CORBA.Identifier (Operation), PortableServer.ServantLocator.Cookie (The_Cookie), CORBA_Servant); end Postinvoke; end PolyORB.CORBA_P.ServantLocator; polyorb-2.8~20110207.orig/src/corba/polyorb-corba_p.ads0000644000175000017500000000417711750740340022052 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . C O R B A _ P -- -- -- -- S p e c -- -- -- -- Copyright (C) 2001-2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- Root package for the CORBA applicative personality package PolyORB.CORBA_P is pragma Pure; end PolyORB.CORBA_P; polyorb-2.8~20110207.orig/src/corba/polyorb-corba_p-exceptions.ads0000644000175000017500000001050211750740340024216 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . C O R B A _ P . E X C E P T I O N S -- -- -- -- S p e c -- -- -- -- Copyright (C) 2001-2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- Exceptions management for the CORBA application personality of PolyORB with Ada.Exceptions; with CORBA; with PolyORB.Any; with PolyORB.Errors; with PolyORB.Requests; package PolyORB.CORBA_P.Exceptions is procedure Request_Raise_Occurrence (R : Requests.Request); -- If R has non-empty exception information, call Raise_From_Any with an -- appropriate information message. procedure Raise_From_Any (Occurrence : PolyORB.Any.Any; Message : String := ""); pragma No_Return (Raise_From_Any); -- Raise CORBA exception from data in 'Occurrence' function System_Exception_To_Any (E : Ada.Exceptions.Exception_Occurrence) return PolyORB.Any.Any; function System_Exception_To_Any (E : Ada.Exceptions.Exception_Occurrence) return CORBA.Any; -- Convert a CORBA System Exception into a Any procedure Raise_From_Error (Error : in out PolyORB.Errors.Error_Container; Message : String := ""); pragma No_Return (Raise_From_Error); -- Raise a CORBA specific exception from the data in 'Error' -- Exceptions classification function Is_Forward_Request (Occurrence : PolyORB.Any.Any) return Boolean; -- Return True iff Occurrence is a PolyORB forward request exception function Is_Needs_Addressing_Mode (Occurrence : PolyORB.Any.Any) return Boolean; -- Returns True iff Occurrence is a PolyORB style addressing mode change -- request. function Is_System_Exception (Occurrence : PolyORB.Any.Any) return Boolean; -- Return True iff Occurrence is an ORB system exception ---------------------------- -- Raise_From_Error Hooks -- ---------------------------- -- The CORBA aplication personality may raise exceptions found in -- different packages. Hooks are set up to work around circular -- references problems. type Raise_From_Error_Hook is access procedure (Error : in out PolyORB.Errors.Error_Container; Message : String); CORBA_Raise_From_Error : Raise_From_Error_Hook := null; -- Raise CORBA.* exceptions POA_Raise_From_Error : Raise_From_Error_Hook := null; -- Raise PortableServer.POA.* exceptions POAManager_Raise_From_Error : Raise_From_Error_Hook := null; -- Raise PortableServer.POAManager.* exceptions end PolyORB.CORBA_P.Exceptions; polyorb-2.8~20110207.orig/src/corba/portableserver-lifespanpolicy.ads0000644000175000017500000000541411750740340025032 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O R T A B L E S E R V E R . L I F E S P A N P O L I C Y -- -- -- -- S p e c -- -- -- -- Copyright (C) 2003-2008, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the CORBA Specification, and adapted -- -- for use with PolyORB. The copyright notice above, and the license -- -- provisions that follow apply solely to the contents neither explicitly -- -- nor implicitly specified by the CORBA Specification defined by the OMG. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with CORBA.Policy; package PortableServer.LifespanPolicy is type Ref is new CORBA.Policy.Ref with private; function To_Ref (The_Ref : CORBA.Object.Ref'Class) return Ref; function Get_Value (Self : Ref) return PortableServer.LifespanPolicyValue; private type Ref is new CORBA.Policy.Ref with null record; end PortableServer.LifespanPolicy; polyorb-2.8~20110207.orig/src/corba/corba-bounded_strings.ads0000644000175000017500000003301411750740337023234 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- C O R B A . B O U N D E D _ S T R I N G S -- -- -- -- S p e c -- -- -- -- Copyright (C) 2005-2008, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the CORBA Specification, and adapted -- -- for use with PolyORB. The copyright notice above, and the license -- -- provisions that follow apply solely to the contents neither explicitly -- -- nor implicitly specified by the CORBA Specification defined by the OMG. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- As defined by the IDL-to-Ada mapping, this package has the same -- specification and semantic as the -- Ada.Strings.Bounded.Generic_Bounded_Length package with Ada.Strings.Maps; with Ada.Strings.Bounded; with PolyORB.Any; generic Max : Positive; -- Maximum length of a Bounded_String package CORBA.Bounded_Strings is Max_Length : constant Positive := Max; type Bounded_String is private; Null_Bounded_String : constant Bounded_String; subtype Length_Range is Natural range 0 .. Max_Length; function Length (Source : Bounded_String) return Length_Range; ------------------------------ -- Any conversion functions -- ------------------------------ function TC_Bounded_String return CORBA.TypeCode.Object; function From_Any (From : CORBA.Any) return Bounded_String; function To_Any (To : Bounded_String) return CORBA.Any; function Wrap (X : access Bounded_String) return PolyORB.Any.Content'Class; -------------------------------------------------------- -- Conversion, Concatenation, and Selection Functions -- -------------------------------------------------------- function To_Bounded_String (Source : Standard.String; Drop : Ada.Strings.Truncation := Ada.Strings.Error) return Bounded_String; function To_String (Source : Bounded_String) return Standard.String; function Append (Left, Right : Bounded_String; Drop : Ada.Strings.Truncation := Ada.Strings.Error) return Bounded_String; function Append (Left : Bounded_String; Right : Standard.String; Drop : Ada.Strings.Truncation := Ada.Strings.Error) return Bounded_String; function Append (Left : Standard.String; Right : Bounded_String; Drop : Ada.Strings.Truncation := Ada.Strings.Error) return Bounded_String; function Append (Left : Bounded_String; Right : Character; Drop : Ada.Strings.Truncation := Ada.Strings.Error) return Bounded_String; function Append (Left : Character; Right : Bounded_String; Drop : Ada.Strings.Truncation := Ada.Strings.Error) return Bounded_String; procedure Append (Source : in out Bounded_String; New_Item : Bounded_String; Drop : Ada.Strings.Truncation := Ada.Strings.Error); procedure Append (Source : in out Bounded_String; New_Item : Standard.String; Drop : Ada.Strings.Truncation := Ada.Strings.Error); procedure Append (Source : in out Bounded_String; New_Item : Character; Drop : Ada.Strings.Truncation := Ada.Strings.Error); function "&" (Left, Right : Bounded_String) return Bounded_String; function "&" (Left : Bounded_String; Right : Standard.String) return Bounded_String; function "&" (Left : Standard.String; Right : Bounded_String) return Bounded_String; function "&" (Left : Bounded_String; Right : Character) return Bounded_String; function "&" (Left : Character; Right : Bounded_String) return Bounded_String; function Element (Source : Bounded_String; Index : Positive) return Character; procedure Replace_Element (Source : in out Bounded_String; Index : Positive; By : Character); function Slice (Source : Bounded_String; Low : Positive; High : Natural) return Standard.String; function "=" (Left, Right : Bounded_String) return Boolean; function "=" (Left : Bounded_String; Right : Standard.String) return Boolean; function "=" (Left : Standard.String; Right : Bounded_String) return Boolean; function "<" (Left, Right : Bounded_String) return Boolean; function "<" (Left : Bounded_String; Right : Standard.String) return Boolean; function "<" (Left : Standard.String; Right : Bounded_String) return Boolean; function "<=" (Left, Right : Bounded_String) return Boolean; function "<=" (Left : Bounded_String; Right : Standard.String) return Boolean; function "<=" (Left : Standard.String; Right : Bounded_String) return Boolean; function ">" (Left, Right : Bounded_String) return Boolean; function ">" (Left : Bounded_String; Right : Standard.String) return Boolean; function ">" (Left : Standard.String; Right : Bounded_String) return Boolean; function ">=" (Left, Right : Bounded_String) return Boolean; function ">=" (Left : Bounded_String; Right : Standard.String) return Boolean; function ">=" (Left : Standard.String; Right : Bounded_String) return Boolean; ---------------------- -- Search Functions -- ---------------------- function Index (Source : Bounded_String; Pattern : Standard.String; Going : Ada.Strings.Direction := Ada.Strings.Forward; Mapping : Ada.Strings.Maps.Character_Mapping := Ada.Strings.Maps.Identity) return Natural; function Index (Source : Bounded_String; Pattern : Standard.String; Going : Ada.Strings.Direction := Ada.Strings.Forward; Mapping : Ada.Strings.Maps.Character_Mapping_Function) return Natural; function Index (Source : Bounded_String; Set : Ada.Strings.Maps.Character_Set; Test : Ada.Strings.Membership := Ada.Strings.Inside; Going : Ada.Strings.Direction := Ada.Strings.Forward) return Natural; function Index_Non_Blank (Source : Bounded_String; Going : Ada.Strings.Direction := Ada.Strings.Forward) return Natural; function Count (Source : Bounded_String; Pattern : Standard.String; Mapping : Ada.Strings.Maps.Character_Mapping := Ada.Strings.Maps.Identity) return Natural; function Count (Source : Bounded_String; Pattern : Standard.String; Mapping : Ada.Strings.Maps.Character_Mapping_Function) return Natural; function Count (Source : Bounded_String; Set : Ada.Strings.Maps.Character_Set) return Natural; procedure Find_Token (Source : Bounded_String; Set : Ada.Strings.Maps.Character_Set; Test : Ada.Strings.Membership; First : out Positive; Last : out Natural); ------------------------------------ -- String Translation Subprograms -- ------------------------------------ function Translate (Source : Bounded_String; Mapping : Ada.Strings.Maps.Character_Mapping) return Bounded_String; procedure Translate (Source : in out Bounded_String; Mapping : Ada.Strings.Maps.Character_Mapping); function Translate (Source : Bounded_String; Mapping : Ada.Strings.Maps.Character_Mapping_Function) return Bounded_String; procedure Translate (Source : in out Bounded_String; Mapping : Ada.Strings.Maps.Character_Mapping_Function); --------------------------------------- -- String Transformation Subprograms -- --------------------------------------- function Replace_Slice (Source : Bounded_String; Low : Positive; High : Natural; By : Standard.String; Drop : Ada.Strings.Truncation := Ada.Strings.Error) return Bounded_String; procedure Replace_Slice (Source : in out Bounded_String; Low : Positive; High : Natural; By : Standard.String; Drop : Ada.Strings.Truncation := Ada.Strings.Error); function Insert (Source : Bounded_String; Before : Positive; New_Item : Standard.String; Drop : Ada.Strings.Truncation := Ada.Strings.Error) return Bounded_String; procedure Insert (Source : in out Bounded_String; Before : Positive; New_Item : Standard.String; Drop : Ada.Strings.Truncation := Ada.Strings.Error); function Overwrite (Source : Bounded_String; Position : Positive; New_Item : Standard.String; Drop : Ada.Strings.Truncation := Ada.Strings.Error) return Bounded_String; procedure Overwrite (Source : in out Bounded_String; Position : Positive; New_Item : Standard.String; Drop : Ada.Strings.Truncation := Ada.Strings.Error); function Delete (Source : Bounded_String; From : Positive; Through : Natural) return Bounded_String; procedure Delete (Source : in out Bounded_String; From : Positive; Through : Natural); --------------------------------- -- String Selector Subprograms -- --------------------------------- function Trim (Source : Bounded_String; Side : Ada.Strings.Trim_End) return Bounded_String; procedure Trim (Source : in out Bounded_String; Side : Ada.Strings.Trim_End); function Trim (Source : Bounded_String; Left : Ada.Strings.Maps.Character_Set; Right : Ada.Strings.Maps.Character_Set) return Bounded_String; procedure Trim (Source : in out Bounded_String; Left : Ada.Strings.Maps.Character_Set; Right : Ada.Strings.Maps.Character_Set); function Head (Source : Bounded_String; Count : Natural; Pad : Character := Ada.Strings.Space; Drop : Ada.Strings.Truncation := Ada.Strings.Error) return Bounded_String; procedure Head (Source : in out Bounded_String; Count : Natural; Pad : Character := Ada.Strings.Space; Drop : Ada.Strings.Truncation := Ada.Strings.Error); function Tail (Source : Bounded_String; Count : Natural; Pad : Character := Ada.Strings.Space; Drop : Ada.Strings.Truncation := Ada.Strings.Error) return Bounded_String; procedure Tail (Source : in out Bounded_String; Count : Natural; Pad : Character := Ada.Strings.Space; Drop : Ada.Strings.Truncation := Ada.Strings.Error); ------------------------------------ -- String Constructor Subprograms -- ------------------------------------ function "*" (Left : Natural; Right : Character) return Bounded_String; function "*" (Left : Natural; Right : Standard.String) return Bounded_String; function "*" (Left : Natural; Right : Bounded_String) return Bounded_String; function Replicate (Count : Natural; Item : Character; Drop : Ada.Strings.Truncation := Ada.Strings.Error) return Bounded_String; function Replicate (Count : Natural; Item : Standard.String; Drop : Ada.Strings.Truncation := Ada.Strings.Error) return Bounded_String; function Replicate (Count : Natural; Item : Bounded_String; Drop : Ada.Strings.Truncation := Ada.Strings.Error) return Bounded_String; private package CBS is new Ada.Strings.Bounded.Generic_Bounded_Length (Max_Length); type Bounded_String is new CBS.Bounded_String; Null_Bounded_String : constant Bounded_String := Bounded_String (CBS.Null_Bounded_String); end CORBA.Bounded_Strings; polyorb-2.8~20110207.orig/src/corba/polyorb-corba_p-local.adb0000644000175000017500000000571611750740340023121 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . C O R B A _ P . L O C A L -- -- -- -- B o d y -- -- -- -- Copyright (C) 2004-2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with CORBA; with PolyORB.References; package body PolyORB.CORBA_P.Local is -------------------- -- Is_CORBA_Local -- -------------------- function Is_CORBA_Local (Self : CORBA.Object.Ref'Class) return Boolean is begin if PolyORB.Smart_Pointers.Is_Nil (PolyORB.Smart_Pointers.Ref (Self)) then CORBA.Raise_Inv_Objref (CORBA.Default_Sys_Member); end if; return CORBA.Object.Entity_Of (Self).all in Local_Object_Base'Class; end Is_CORBA_Local; -------------- -- Is_Local -- -------------- function Is_Local (Self : CORBA.Object.Ref'Class) return Boolean is begin if PolyORB.Smart_Pointers.Is_Nil (PolyORB.Smart_Pointers.Ref (Self)) then CORBA.Raise_Inv_Objref (CORBA.Default_Sys_Member); end if; return not PolyORB.References.Is_Exported_Reference (CORBA.Object.Internals.To_PolyORB_Ref (CORBA.Object.Ref (Self))); end Is_Local; end PolyORB.CORBA_P.Local; polyorb-2.8~20110207.orig/src/corba/corba-bounded_wide_strings.ads0000644000175000017500000003534011750740337024250 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- C O R B A . B O U N D E D _ W I D E _ S T R I N G S -- -- -- -- S p e c -- -- -- -- Copyright (C) 2005-2008, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the CORBA Specification, and adapted -- -- for use with PolyORB. The copyright notice above, and the license -- -- provisions that follow apply solely to the contents neither explicitly -- -- nor implicitly specified by the CORBA Specification defined by the OMG. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- As defined by the IDL-to-Ada mapping, this package has the same -- specification and semantic as the -- Ada.Strings.Wide_Bounded.Generic_Bounded_Length package with Ada.Strings.Wide_Maps; with Ada.Strings.Wide_Bounded; generic Max : Positive; -- Maximum length of a Bounded_Wide_String package CORBA.Bounded_Wide_Strings is Max_Length : constant Positive := Max; type Bounded_Wide_String is private; Null_Bounded_Wide_String : constant Bounded_Wide_String; subtype Length_Range is Natural range 0 .. Max_Length; function Length (Source : Bounded_Wide_String) return Length_Range; ------------------------------ -- Any conversion functions -- ------------------------------ function TC_Bounded_Wide_String return CORBA.TypeCode.Object; function From_Any (From : CORBA.Any) return Bounded_Wide_String; function To_Any (To : Bounded_Wide_String) return CORBA.Any; function Wrap (X : access Bounded_Wide_String) return PolyORB.Any.Content'Class; -------------------------------------------------------- -- Conversion, Concatenation, and Selection Functions -- -------------------------------------------------------- function To_Bounded_Wide_String (Source : Standard.Wide_String; Drop : Ada.Strings.Truncation := Ada.Strings.Error) return Bounded_Wide_String; function To_Wide_String (Source : Bounded_Wide_String) return Standard.Wide_String; function Append (Left, Right : Bounded_Wide_String; Drop : Ada.Strings.Truncation := Ada.Strings.Error) return Bounded_Wide_String; function Append (Left : Bounded_Wide_String; Right : Standard.Wide_String; Drop : Ada.Strings.Truncation := Ada.Strings.Error) return Bounded_Wide_String; function Append (Left : Standard.Wide_String; Right : Bounded_Wide_String; Drop : Ada.Strings.Truncation := Ada.Strings.Error) return Bounded_Wide_String; function Append (Left : Bounded_Wide_String; Right : Wide_Character; Drop : Ada.Strings.Truncation := Ada.Strings.Error) return Bounded_Wide_String; function Append (Left : Wide_Character; Right : Bounded_Wide_String; Drop : Ada.Strings.Truncation := Ada.Strings.Error) return Bounded_Wide_String; procedure Append (Source : in out Bounded_Wide_String; New_Item : Bounded_Wide_String; Drop : Ada.Strings.Truncation := Ada.Strings.Error); procedure Append (Source : in out Bounded_Wide_String; New_Item : Standard.Wide_String; Drop : Ada.Strings.Truncation := Ada.Strings.Error); procedure Append (Source : in out Bounded_Wide_String; New_Item : Wide_Character; Drop : Ada.Strings.Truncation := Ada.Strings.Error); function "&" (Left, Right : Bounded_Wide_String) return Bounded_Wide_String; function "&" (Left : Bounded_Wide_String; Right : Standard.Wide_String) return Bounded_Wide_String; function "&" (Left : Standard.Wide_String; Right : Bounded_Wide_String) return Bounded_Wide_String; function "&" (Left : Bounded_Wide_String; Right : Wide_Character) return Bounded_Wide_String; function "&" (Left : Wide_Character; Right : Bounded_Wide_String) return Bounded_Wide_String; function Element (Source : Bounded_Wide_String; Index : Positive) return Wide_Character; procedure Replace_Element (Source : in out Bounded_Wide_String; Index : Positive; By : Wide_Character); function Slice (Source : Bounded_Wide_String; Low : Positive; High : Natural) return Standard.Wide_String; function "=" (Left : Bounded_Wide_String; Right : Bounded_Wide_String) return Boolean; function "=" (Left : Bounded_Wide_String; Right : Standard.Wide_String) return Boolean; function "=" (Left : Standard.Wide_String; Right : Bounded_Wide_String) return Boolean; function "<" (Left : Bounded_Wide_String; Right : Bounded_Wide_String) return Boolean; function "<" (Left : Bounded_Wide_String; Right : Standard.Wide_String) return Boolean; function "<" (Left : Standard.Wide_String; Right : Bounded_Wide_String) return Boolean; function "<=" (Left : Bounded_Wide_String; Right : Bounded_Wide_String) return Boolean; function "<=" (Left : Bounded_Wide_String; Right : Standard.Wide_String) return Boolean; function "<=" (Left : Standard.Wide_String; Right : Bounded_Wide_String) return Boolean; function ">" (Left : Bounded_Wide_String; Right : Bounded_Wide_String) return Boolean; function ">" (Left : Bounded_Wide_String; Right : Standard.Wide_String) return Boolean; function ">" (Left : Standard.Wide_String; Right : Bounded_Wide_String) return Boolean; function ">=" (Left : Bounded_Wide_String; Right : Bounded_Wide_String) return Boolean; function ">=" (Left : Bounded_Wide_String; Right : Standard.Wide_String) return Boolean; function ">=" (Left : Standard.Wide_String; Right : Bounded_Wide_String) return Boolean; ---------------------- -- Search Functions -- ---------------------- function Index (Source : Bounded_Wide_String; Pattern : Standard.Wide_String; Going : Ada.Strings.Direction := Ada.Strings.Forward; Mapping : Ada.Strings.Wide_Maps.Wide_Character_Mapping := Ada.Strings.Wide_Maps.Identity) return Natural; function Index (Source : Bounded_Wide_String; Pattern : Standard.Wide_String; Going : Ada.Strings.Direction := Ada.Strings.Forward; Mapping : Ada.Strings.Wide_Maps.Wide_Character_Mapping_Function) return Natural; function Index (Source : Bounded_Wide_String; Set : Ada.Strings.Wide_Maps.Wide_Character_Set; Test : Ada.Strings.Membership := Ada.Strings.Inside; Going : Ada.Strings.Direction := Ada.Strings.Forward) return Natural; function Index_Non_Blank (Source : Bounded_Wide_String; Going : Ada.Strings.Direction := Ada.Strings.Forward) return Natural; function Count (Source : Bounded_Wide_String; Pattern : Standard.Wide_String; Mapping : Ada.Strings.Wide_Maps.Wide_Character_Mapping := Ada.Strings.Wide_Maps.Identity) return Natural; function Count (Source : Bounded_Wide_String; Pattern : Standard.Wide_String; Mapping : Ada.Strings.Wide_Maps.Wide_Character_Mapping_Function) return Natural; function Count (Source : Bounded_Wide_String; Set : Ada.Strings.Wide_Maps.Wide_Character_Set) return Natural; procedure Find_Token (Source : Bounded_Wide_String; Set : Ada.Strings.Wide_Maps.Wide_Character_Set; Test : Ada.Strings.Membership; First : out Positive; Last : out Natural); ----------------------------------------- -- Wide_String Translation Subprograms -- ----------------------------------------- function Translate (Source : Bounded_Wide_String; Mapping : Ada.Strings.Wide_Maps.Wide_Character_Mapping) return Bounded_Wide_String; procedure Translate (Source : in out Bounded_Wide_String; Mapping : Ada.Strings.Wide_Maps.Wide_Character_Mapping); function Translate (Source : Bounded_Wide_String; Mapping : Ada.Strings.Wide_Maps.Wide_Character_Mapping_Function) return Bounded_Wide_String; procedure Translate (Source : in out Bounded_Wide_String; Mapping : Ada.Strings.Wide_Maps.Wide_Character_Mapping_Function); -------------------------------------------- -- Wide_String Transformation Subprograms -- -------------------------------------------- function Replace_Slice (Source : Bounded_Wide_String; Low : Positive; High : Natural; By : Standard.Wide_String; Drop : Ada.Strings.Truncation := Ada.Strings.Error) return Bounded_Wide_String; procedure Replace_Slice (Source : in out Bounded_Wide_String; Low : Positive; High : Natural; By : Standard.Wide_String; Drop : Ada.Strings.Truncation := Ada.Strings.Error); function Insert (Source : Bounded_Wide_String; Before : Positive; New_Item : Standard.Wide_String; Drop : Ada.Strings.Truncation := Ada.Strings.Error) return Bounded_Wide_String; procedure Insert (Source : in out Bounded_Wide_String; Before : Positive; New_Item : Standard.Wide_String; Drop : Ada.Strings.Truncation := Ada.Strings.Error); function Overwrite (Source : Bounded_Wide_String; Position : Positive; New_Item : Standard.Wide_String; Drop : Ada.Strings.Truncation := Ada.Strings.Error) return Bounded_Wide_String; procedure Overwrite (Source : in out Bounded_Wide_String; Position : Positive; New_Item : Standard.Wide_String; Drop : Ada.Strings.Truncation := Ada.Strings.Error); function Delete (Source : Bounded_Wide_String; From : Positive; Through : Natural) return Bounded_Wide_String; procedure Delete (Source : in out Bounded_Wide_String; From : Positive; Through : Natural); -------------------------------------- -- Wide_String Selector Subprograms -- -------------------------------------- function Trim (Source : Bounded_Wide_String; Side : Ada.Strings.Trim_End) return Bounded_Wide_String; procedure Trim (Source : in out Bounded_Wide_String; Side : Ada.Strings.Trim_End); function Trim (Source : Bounded_Wide_String; Left : Ada.Strings.Wide_Maps.Wide_Character_Set; Right : Ada.Strings.Wide_Maps.Wide_Character_Set) return Bounded_Wide_String; procedure Trim (Source : in out Bounded_Wide_String; Left : Ada.Strings.Wide_Maps.Wide_Character_Set; Right : Ada.Strings.Wide_Maps.Wide_Character_Set); function Head (Source : Bounded_Wide_String; Count : Natural; Pad : Wide_Character := Ada.Strings.Wide_Space; Drop : Ada.Strings.Truncation := Ada.Strings.Error) return Bounded_Wide_String; procedure Head (Source : in out Bounded_Wide_String; Count : Natural; Pad : Wide_Character := Ada.Strings.Wide_Space; Drop : Ada.Strings.Truncation := Ada.Strings.Error); function Tail (Source : Bounded_Wide_String; Count : Natural; Pad : Wide_Character := Ada.Strings.Wide_Space; Drop : Ada.Strings.Truncation := Ada.Strings.Error) return Bounded_Wide_String; procedure Tail (Source : in out Bounded_Wide_String; Count : Natural; Pad : Wide_Character := Ada.Strings.Wide_Space; Drop : Ada.Strings.Truncation := Ada.Strings.Error); ----------------------------------------- -- Wide_String Constructor Subprograms -- ----------------------------------------- function "*" (Left : Natural; Right : Wide_Character) return Bounded_Wide_String; function "*" (Left : Natural; Right : Standard.Wide_String) return Bounded_Wide_String; function "*" (Left : Natural; Right : Bounded_Wide_String) return Bounded_Wide_String; function Replicate (Count : Natural; Item : Wide_Character; Drop : Ada.Strings.Truncation := Ada.Strings.Error) return Bounded_Wide_String; function Replicate (Count : Natural; Item : Standard.Wide_String; Drop : Ada.Strings.Truncation := Ada.Strings.Error) return Bounded_Wide_String; function Replicate (Count : Natural; Item : Bounded_Wide_String; Drop : Ada.Strings.Truncation := Ada.Strings.Error) return Bounded_Wide_String; private package CBWS is new Ada.Strings.Wide_Bounded.Generic_Bounded_Length (Max_Length); type Bounded_Wide_String is new CBWS.Bounded_Wide_String; Null_Bounded_Wide_String : constant Bounded_Wide_String := Bounded_Wide_String (CBWS.Null_Bounded_Wide_String); end CORBA.Bounded_Wide_Strings; polyorb-2.8~20110207.orig/src/corba/portableserver-servantlocator.adb0000644000175000017500000000654311750740340025042 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O R T A B L E S E R V E R . S E R V A N T L O C A T O R -- -- -- -- B o d y -- -- -- -- Copyright (C) 2003-2005 Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with PortableServer.ServantLocator.Impl; package body PortableServer.ServantLocator is --------------- -- Preinvoke -- --------------- procedure Preinvoke (Self : Local_Ref; Oid : ObjectId; Adapter : PortableServer.POA_Forward.Ref; Operation : CORBA.Identifier; The_Cookie : out Cookie; Returns : out Servant) is begin if CORBA.Object.Is_Nil (CORBA.Object.Ref (Self)) then CORBA.Raise_Inv_Objref (CORBA.Default_Sys_Member); end if; Impl.Preinvoke (Impl.Object_Ptr (Entity_Of (Self)), Oid, Adapter, Operation, The_Cookie, Returns); end Preinvoke; ---------------- -- Postinvoke -- ---------------- procedure Postinvoke (Self : Local_Ref; Oid : ObjectId; Adapter : PortableServer.POA_Forward.Ref; Operation : CORBA.Identifier; The_Cookie : Cookie; The_Servant : Servant) is begin if CORBA.Object.Is_Nil (CORBA.Object.Ref (Self)) then CORBA.Raise_Inv_Objref (CORBA.Default_Sys_Member); end if; Impl.Postinvoke (Impl.Object_Ptr (Entity_Of (Self)), Oid, Adapter, Operation, The_Cookie, The_Servant); end Postinvoke; end PortableServer.ServantLocator; polyorb-2.8~20110207.orig/src/corba/portableserver-servantmanager.ads0000644000175000017500000000522611750740340025027 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O R T A B L E S E R V E R . S E R V A N T M A N A G E R -- -- -- -- S p e c -- -- -- -- Copyright (C) 2001-2008, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the CORBA Specification, and adapted -- -- for use with PolyORB. The copyright notice above, and the license -- -- provisions that follow apply solely to the contents neither explicitly -- -- nor implicitly specified by the CORBA Specification defined by the OMG. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with CORBA.Object; package PortableServer.ServantManager is type Local_Ref is new CORBA.Object.Ref with null record; Repository_Id : constant Standard.String := "IDL:omg.org/PortableServer/ServantManager:1.0"; end PortableServer.ServantManager; polyorb-2.8~20110207.orig/src/corba/corba-bounded_strings.adb0000644000175000017500000006376311750740337023231 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- C O R B A . B O U N D E D _ S T R I N G S -- -- -- -- B o d y -- -- -- -- Copyright (C) 2005-2008, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ pragma Warnings (Off); with Ada.Strings.Superbounded; -- Internal GNAT unit pragma Warnings (On); with Ada.Unchecked_Conversion; package body CORBA.Bounded_Strings is use CBS; function To_Bounded_String is new Ada.Unchecked_Conversion (Ada.Strings.Superbounded.Super_String, Bounded_String); function To_Super_String is new Ada.Unchecked_Conversion (Bounded_String, Ada.Strings.Superbounded.Super_String); ----------------------- -- TC_Bounded_String -- ----------------------- TC_Cache : PolyORB.Any.TypeCode.Local_Ref; function TC_Bounded_String return PolyORB.Any.TypeCode.Local_Ref; -- Internal representation as a PolyORB TypeCode function TC_Bounded_String return PolyORB.Any.TypeCode.Local_Ref is use PolyORB.Any.TypeCode; begin if Is_Nil (TC_Cache) then TC_Cache := Build_String_TC (PolyORB.Types.Unsigned_Long (Max_Length)); Disable_Reference_Counting (Object_Of (TC_Cache).all); end if; return TC_Cache; end TC_Bounded_String; ----------------------- -- TC_Bounded_String -- ----------------------- function TC_Bounded_String return CORBA.TypeCode.Object is begin return CORBA.TypeCode.Internals.To_CORBA_Object (TC_Bounded_String); end TC_Bounded_String; -------------- -- From_Any -- -------------- function From_Any (From : CORBA.Any) return Bounded_String is Super : constant Ada.Strings.Superbounded.Super_String := From_Any (From); begin if Super.Max_Length /= Max_Length then raise Constraint_Error; end if; return To_Bounded_String (Super); end From_Any; ------------ -- To_Any -- ------------ function To_Any (To : Bounded_String) return CORBA.Any is begin return To_Any (To_Super_String (To), TC_Bounded_String'Access); end To_Any; ------------ -- Length -- ------------ function Length (Source : Bounded_String) return Length_Range is Result : constant CBS.Length_Range := CBS.Length (CBS.Bounded_String (Source)); begin return Length_Range (Result); end Length; ----------------------- -- To_Bounded_String -- ----------------------- function To_Bounded_String (Source : Standard.String; Drop : Ada.Strings.Truncation := Ada.Strings.Error) return Bounded_String is Result : constant CBS.Bounded_String := CBS.To_Bounded_String (Source, Drop); begin return Bounded_String (Result); end To_Bounded_String; --------------- -- To_String -- --------------- function To_String (Source : Bounded_String) return Standard.String is Result : constant Standard.String := CBS.To_String (CBS.Bounded_String (Source)); begin return Result; end To_String; ------------ -- Append -- ------------ function Append (Left, Right : Bounded_String; Drop : Ada.Strings.Truncation := Ada.Strings.Error) return Bounded_String is Result : constant CBS.Bounded_String := CBS.Append (CBS.Bounded_String (Left), CBS.Bounded_String (Right), Drop); begin return Bounded_String (Result); end Append; function Append (Left : Bounded_String; Right : Standard.String; Drop : Ada.Strings.Truncation := Ada.Strings.Error) return Bounded_String is Result : constant CBS.Bounded_String := CBS.Append (CBS.Bounded_String (Left), Right, Drop); begin return Bounded_String (Result); end Append; function Append (Left : Standard.String; Right : Bounded_String; Drop : Ada.Strings.Truncation := Ada.Strings.Error) return Bounded_String is Result : constant CBS.Bounded_String := CBS.Append (Left, CBS.Bounded_String (Right), Drop); begin return Bounded_String (Result); end Append; function Append (Left : Bounded_String; Right : Character; Drop : Ada.Strings.Truncation := Ada.Strings.Error) return Bounded_String is Result : constant CBS.Bounded_String := CBS.Append (CBS.Bounded_String (Left), Right, Drop); begin return Bounded_String (Result); end Append; function Append (Left : Character; Right : Bounded_String; Drop : Ada.Strings.Truncation := Ada.Strings.Error) return Bounded_String is Result : constant CBS.Bounded_String := CBS.Append (Left, CBS.Bounded_String (Right), Drop); begin return Bounded_String (Result); end Append; procedure Append (Source : in out Bounded_String; New_Item : Bounded_String; Drop : Ada.Strings.Truncation := Ada.Strings.Error) is CBS_Source : CBS.Bounded_String := CBS.Bounded_String (Source); begin CBS.Append (CBS_Source, CBS.Bounded_String (New_Item), Drop); Source := Bounded_String (CBS_Source); end Append; procedure Append (Source : in out Bounded_String; New_Item : Standard.String; Drop : Ada.Strings.Truncation := Ada.Strings.Error) is CBS_Source : CBS.Bounded_String := CBS.Bounded_String (Source); begin CBS.Append (CBS_Source, New_Item, Drop); Source := Bounded_String (CBS_Source); end Append; procedure Append (Source : in out Bounded_String; New_Item : Character; Drop : Ada.Strings.Truncation := Ada.Strings.Error) is CBS_Source : CBS.Bounded_String := CBS.Bounded_String (Source); begin CBS.Append (CBS_Source, New_Item, Drop); Source := Bounded_String (CBS_Source); end Append; --------- -- "&" -- --------- function "&" (Left, Right : Bounded_String) return Bounded_String is Result : constant CBS.Bounded_String := CBS.Bounded_String (Left) & CBS.Bounded_String (Right); begin return Bounded_String (Result); end "&"; function "&" (Left : Bounded_String; Right : Standard.String) return Bounded_String is Result : constant CBS.Bounded_String := CBS.Bounded_String (Left) & Right; begin return Bounded_String (Result); end "&"; function "&" (Left : Standard.String; Right : Bounded_String) return Bounded_String is Result : constant CBS.Bounded_String := Left & CBS.Bounded_String (Right); begin return Bounded_String (Result); end "&"; function "&" (Left : Bounded_String; Right : Character) return Bounded_String is Result : constant CBS.Bounded_String := CBS.Bounded_String (Left) & Right; begin return Bounded_String (Result); end "&"; function "&" (Left : Character; Right : Bounded_String) return Bounded_String is Result : constant CBS.Bounded_String := Left & CBS.Bounded_String (Right); begin return Bounded_String (Result); end "&"; ------------- -- Element -- ------------- function Element (Source : Bounded_String; Index : Positive) return Character is Result : constant Character := CBS.Element (CBS.Bounded_String (Source), Index); begin return Result; end Element; --------------------- -- Replace_Element -- --------------------- procedure Replace_Element (Source : in out Bounded_String; Index : Positive; By : Character) is CBS_Source : CBS.Bounded_String := CBS.Bounded_String (Source); begin CBS.Replace_Element (CBS_Source, Index, By); Source := Bounded_String (CBS_Source); end Replace_Element; ----------- -- Slice -- ----------- function Slice (Source : Bounded_String; Low : Positive; High : Natural) return Standard.String is Result : constant Standard.String := CBS.Slice (CBS.Bounded_String (Source), Low, High); begin return Result; end Slice; --------- -- "=" -- --------- function "=" (Left, Right : Bounded_String) return Boolean is Result : constant Boolean := CBS.Bounded_String (Left) = CBS.Bounded_String (Right); begin return Result; end "="; function "=" (Left : Bounded_String; Right : Standard.String) return Boolean is Result : constant Boolean := CBS.Bounded_String (Left) = Right; begin return Result; end "="; function "=" (Left : Standard.String; Right : Bounded_String) return Boolean is Result : constant Boolean := Left = CBS.Bounded_String (Right); begin return Result; end "="; --------- -- "<" -- --------- function "<" (Left, Right : Bounded_String) return Boolean is Result : constant Boolean := CBS.Bounded_String (Left) < CBS.Bounded_String (Right); begin return Result; end "<"; function "<" (Left : Bounded_String; Right : Standard.String) return Boolean is Result : constant Boolean := CBS.Bounded_String (Left) < Right; begin return Result; end "<"; function "<" (Left : Standard.String; Right : Bounded_String) return Boolean is Result : constant Boolean := Left < CBS.Bounded_String (Right); begin return Result; end "<"; ---------- -- "<=" -- ---------- function "<=" (Left, Right : Bounded_String) return Boolean is Result : constant Boolean := CBS.Bounded_String (Left) <= CBS.Bounded_String (Right); begin return Result; end "<="; function "<=" (Left : Bounded_String; Right : Standard.String) return Boolean is Result : constant Boolean := CBS.Bounded_String (Left) <= Right; begin return Result; end "<="; function "<=" (Left : Standard.String; Right : Bounded_String) return Boolean is Result : constant Boolean := Left <= CBS.Bounded_String (Right); begin return Result; end "<="; --------- -- ">" -- --------- function ">" (Left, Right : Bounded_String) return Boolean is Result : constant Boolean := CBS.Bounded_String (Left) > CBS.Bounded_String (Right); begin return Result; end ">"; function ">" (Left : Bounded_String; Right : Standard.String) return Boolean is Result : constant Boolean := CBS.Bounded_String (Left) > Right; begin return Result; end ">"; function ">" (Left : Standard.String; Right : Bounded_String) return Boolean is Result : constant Boolean := Left > CBS.Bounded_String (Right); begin return Result; end ">"; ---------- -- ">=" -- ---------- function ">=" (Left, Right : Bounded_String) return Boolean is Result : constant Boolean := CBS.Bounded_String (Left) >= CBS.Bounded_String (Right); begin return Result; end ">="; function ">=" (Left : Bounded_String; Right : Standard.String) return Boolean is Result : constant Boolean := CBS.Bounded_String (Left) >= Right; begin return Result; end ">="; function ">=" (Left : Standard.String; Right : Bounded_String) return Boolean is Result : constant Boolean := Left >= CBS.Bounded_String (Right); begin return Result; end ">="; ----------- -- Index -- ----------- function Index (Source : Bounded_String; Pattern : Standard.String; Going : Ada.Strings.Direction := Ada.Strings.Forward; Mapping : Ada.Strings.Maps.Character_Mapping := Ada.Strings.Maps.Identity) return Natural is Result : constant Natural := CBS.Index (CBS.Bounded_String (Source), Pattern, Going, Mapping); begin return Result; end Index; function Index (Source : Bounded_String; Pattern : Standard.String; Going : Ada.Strings.Direction := Ada.Strings.Forward; Mapping : Ada.Strings.Maps.Character_Mapping_Function) return Natural is Result : constant Natural := CBS.Index (CBS.Bounded_String (Source), Pattern, Going, Mapping); begin return Result; end Index; function Index (Source : Bounded_String; Set : Ada.Strings.Maps.Character_Set; Test : Ada.Strings.Membership := Ada.Strings.Inside; Going : Ada.Strings.Direction := Ada.Strings.Forward) return Natural is Result : constant Natural := CBS.Index (CBS.Bounded_String (Source), Set, Test, Going); begin return Result; end Index; --------------------- -- Index_Non_Blank -- --------------------- function Index_Non_Blank (Source : Bounded_String; Going : Ada.Strings.Direction := Ada.Strings.Forward) return Natural is Result : constant Natural := CBS.Index_Non_Blank (CBS.Bounded_String (Source), Going); begin return Result; end Index_Non_Blank; ----------- -- Count -- ----------- function Count (Source : Bounded_String; Pattern : Standard.String; Mapping : Ada.Strings.Maps.Character_Mapping := Ada.Strings.Maps.Identity) return Natural is Result : constant Natural := CBS.Count (CBS.Bounded_String (Source), Pattern, Mapping); begin return Result; end Count; function Count (Source : Bounded_String; Pattern : Standard.String; Mapping : Ada.Strings.Maps.Character_Mapping_Function) return Natural is Result : constant Natural := CBS.Count (CBS.Bounded_String (Source), Pattern, Mapping); begin return Result; end Count; function Count (Source : Bounded_String; Set : Ada.Strings.Maps.Character_Set) return Natural is Result : constant Natural := CBS.Count (CBS.Bounded_String (Source), Set); begin return Result; end Count; ---------------- -- Find_Token -- ---------------- procedure Find_Token (Source : Bounded_String; Set : Ada.Strings.Maps.Character_Set; Test : Ada.Strings.Membership; First : out Positive; Last : out Natural) is begin CBS.Find_Token (CBS.Bounded_String (Source), Set, Test, First, Last); end Find_Token; --------------- -- Translate -- --------------- function Translate (Source : Bounded_String; Mapping : Ada.Strings.Maps.Character_Mapping) return Bounded_String is Result : constant CBS.Bounded_String := CBS.Translate (CBS.Bounded_String (Source), Mapping); begin return Bounded_String (Result); end Translate; procedure Translate (Source : in out Bounded_String; Mapping : Ada.Strings.Maps.Character_Mapping) is CBS_Source : CBS.Bounded_String := CBS.Bounded_String (Source); begin CBS.Translate (CBS_Source, Mapping); Source := Bounded_String (CBS_Source); end Translate; function Translate (Source : Bounded_String; Mapping : Ada.Strings.Maps.Character_Mapping_Function) return Bounded_String is Result : constant CBS.Bounded_String := CBS.Translate (CBS.Bounded_String (Source), Mapping); begin return Bounded_String (Result); end Translate; procedure Translate (Source : in out Bounded_String; Mapping : Ada.Strings.Maps.Character_Mapping_Function) is CBS_Source : CBS.Bounded_String := CBS.Bounded_String (Source); begin CBS.Translate (CBS_Source, Mapping); Source := Bounded_String (CBS_Source); end Translate; ------------------- -- Replace_Slice -- ------------------- function Replace_Slice (Source : Bounded_String; Low : Positive; High : Natural; By : Standard.String; Drop : Ada.Strings.Truncation := Ada.Strings.Error) return Bounded_String is Result : constant CBS.Bounded_String := CBS.Replace_Slice (CBS.Bounded_String (Source), Low, High, By, Drop); begin return Bounded_String (Result); end Replace_Slice; procedure Replace_Slice (Source : in out Bounded_String; Low : Positive; High : Natural; By : Standard.String; Drop : Ada.Strings.Truncation := Ada.Strings.Error) is CBS_Source : CBS.Bounded_String := CBS.Bounded_String (Source); begin CBS.Replace_Slice (CBS_Source, Low, High, By, Drop); Source := Bounded_String (CBS_Source); end Replace_Slice; ------------ -- Insert -- ------------ function Insert (Source : Bounded_String; Before : Positive; New_Item : Standard.String; Drop : Ada.Strings.Truncation := Ada.Strings.Error) return Bounded_String is Result : constant CBS.Bounded_String := CBS.Insert (CBS.Bounded_String (Source), Before, New_Item, Drop); begin return Bounded_String (Result); end Insert; procedure Insert (Source : in out Bounded_String; Before : Positive; New_Item : Standard.String; Drop : Ada.Strings.Truncation := Ada.Strings.Error) is CBS_Source : CBS.Bounded_String := CBS.Bounded_String (Source); begin CBS.Insert (CBS_Source, Before, New_Item, Drop); Source := Bounded_String (CBS_Source); end Insert; --------------- -- Overwrite -- --------------- function Overwrite (Source : Bounded_String; Position : Positive; New_Item : Standard.String; Drop : Ada.Strings.Truncation := Ada.Strings.Error) return Bounded_String is Result : constant CBS.Bounded_String := CBS.Overwrite (CBS.Bounded_String (Source), Position, New_Item, Drop); begin return Bounded_String (Result); end Overwrite; procedure Overwrite (Source : in out Bounded_String; Position : Positive; New_Item : Standard.String; Drop : Ada.Strings.Truncation := Ada.Strings.Error) is CBS_Source : CBS.Bounded_String := CBS.Bounded_String (Source); begin CBS.Overwrite (CBS_Source, Position, New_Item, Drop); Source := Bounded_String (CBS_Source); end Overwrite; ------------ -- Delete -- ------------ function Delete (Source : Bounded_String; From : Positive; Through : Natural) return Bounded_String is Result : constant CBS.Bounded_String := CBS.Delete (CBS.Bounded_String (Source), From, Through); begin return Bounded_String (Result); end Delete; procedure Delete (Source : in out Bounded_String; From : Positive; Through : Natural) is CBS_Source : CBS.Bounded_String := CBS.Bounded_String (Source); begin CBS.Delete (CBS_Source, From, Through); Source := Bounded_String (CBS_Source); end Delete; ---------- -- Trim -- ---------- function Trim (Source : Bounded_String; Side : Ada.Strings.Trim_End) return Bounded_String is Result : constant CBS.Bounded_String := CBS.Trim (CBS.Bounded_String (Source), Side); begin return Bounded_String (Result); end Trim; procedure Trim (Source : in out Bounded_String; Side : Ada.Strings.Trim_End) is CBS_Source : CBS.Bounded_String := CBS.Bounded_String (Source); begin CBS.Trim (CBS_Source, Side); Source := Bounded_String (CBS_Source); end Trim; function Trim (Source : Bounded_String; Left : Ada.Strings.Maps.Character_Set; Right : Ada.Strings.Maps.Character_Set) return Bounded_String is Result : constant CBS.Bounded_String := CBS.Trim (CBS.Bounded_String (Source), Left, Right); begin return Bounded_String (Result); end Trim; procedure Trim (Source : in out Bounded_String; Left : Ada.Strings.Maps.Character_Set; Right : Ada.Strings.Maps.Character_Set) is CBS_Source : CBS.Bounded_String := CBS.Bounded_String (Source); begin CBS.Trim (CBS_Source, Left, Right); Source := Bounded_String (CBS_Source); end Trim; ---------- -- Head -- ---------- function Head (Source : Bounded_String; Count : Natural; Pad : Character := Ada.Strings.Space; Drop : Ada.Strings.Truncation := Ada.Strings.Error) return Bounded_String is Result : constant CBS.Bounded_String := CBS.Head (CBS.Bounded_String (Source), Count, Pad, Drop); begin return Bounded_String (Result); end Head; procedure Head (Source : in out Bounded_String; Count : Natural; Pad : Character := Ada.Strings.Space; Drop : Ada.Strings.Truncation := Ada.Strings.Error) is CBS_Source : CBS.Bounded_String := CBS.Bounded_String (Source); begin CBS.Head (CBS_Source, Count, Pad, Drop); Source := Bounded_String (CBS_Source); end Head; ---------- -- Tail -- ---------- function Tail (Source : Bounded_String; Count : Natural; Pad : Character := Ada.Strings.Space; Drop : Ada.Strings.Truncation := Ada.Strings.Error) return Bounded_String is Result : constant CBS.Bounded_String := CBS.Tail (CBS.Bounded_String (Source), Count, Pad, Drop); begin return Bounded_String (Result); end Tail; procedure Tail (Source : in out Bounded_String; Count : Natural; Pad : Character := Ada.Strings.Space; Drop : Ada.Strings.Truncation := Ada.Strings.Error) is CBS_Source : CBS.Bounded_String := CBS.Bounded_String (Source); begin CBS.Tail (CBS_Source, Count, Pad, Drop); Source := Bounded_String (CBS_Source); end Tail; --------- -- "*" -- --------- function "*" (Left : Natural; Right : Character) return Bounded_String is Result : constant CBS.Bounded_String := Left * Right; begin return Bounded_String (Result); end "*"; function "*" (Left : Natural; Right : Standard.String) return Bounded_String is Result : constant CBS.Bounded_String := Left * Right; begin return Bounded_String (Result); end "*"; function "*" (Left : Natural; Right : Bounded_String) return Bounded_String is Result : constant CBS.Bounded_String := Left * CBS.Bounded_String (Right); begin return Bounded_String (Result); end "*"; --------------- -- Replicate -- --------------- function Replicate (Count : Natural; Item : Character; Drop : Ada.Strings.Truncation := Ada.Strings.Error) return Bounded_String is Result : constant CBS.Bounded_String := CBS.Replicate (Count, Item, Drop); begin return Bounded_String (Result); end Replicate; function Replicate (Count : Natural; Item : Standard.String; Drop : Ada.Strings.Truncation := Ada.Strings.Error) return Bounded_String is Result : constant CBS.Bounded_String := CBS.Replicate (Count, Item, Drop); begin return Bounded_String (Result); end Replicate; function Replicate (Count : Natural; Item : Bounded_String; Drop : Ada.Strings.Truncation := Ada.Strings.Error) return Bounded_String is Result : constant CBS.Bounded_String := CBS.Replicate (Count, CBS.Bounded_String (Item), Drop); begin return Bounded_String (Result); end Replicate; ---------- -- Wrap -- ---------- function Wrap (X : access Bounded_String) return PolyORB.Any.Content'Class is begin return PolyORB.Any.Wrap (To_Super_String (X.all)'Unrestricted_Access); end Wrap; end CORBA.Bounded_Strings; polyorb-2.8~20110207.orig/src/corba/polyorb-corba_p-servantlocator.ads0000644000175000017500000000722211750740340025110 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . C O R B A _ P . S E R V A N T L O C A T O R -- -- -- -- S p e c -- -- -- -- Copyright (C) 2003-2005 Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- This package provides glue codee between PolyORB's -- ServantLocator and CORBA specific ServantLocator. with PortableServer.ServantLocator; with PolyORB.Errors; with PolyORB.POA_Types; with PolyORB.Servants; with PolyORB.Smart_Pointers; with PolyORB.Types; package PolyORB.CORBA_P.ServantLocator is package PPT renames PolyORB.POA_Types; type CORBA_ServantLocator is new PPT.ServantLocator with private; procedure Create (Self : out PPT.ServantLocator_Access; SL : PortableServer.ServantLocator.Local_Ref'Class); function Get_Servant_Manager (Self : CORBA_ServantLocator) return PortableServer.ServantLocator.Local_Ref'Class; procedure Preinvoke (Self : access CORBA_ServantLocator; Oid : PPT.Object_Id; Adapter : access PPT.Obj_Adapter'Class; Operation : PolyORB.Types.Identifier; The_Cookie : out PPT.Cookie; Returns : out PolyORB.Servants.Servant_Access; Error : in out PolyORB.Errors.Error_Container); procedure Postinvoke (Self : access CORBA_ServantLocator; Oid : PPT.Object_Id; Adapter : access PPT.Obj_Adapter'Class; Operation : PolyORB.Types.Identifier; The_Cookie : PPT.Cookie; The_Servant : PolyORB.Servants.Servant_Access); private type CORBA_ServantLocator is new PPT.ServantLocator with null record; type Object is new PolyORB.Smart_Pointers.Non_Controlled_Entity with record SL : PortableServer.ServantLocator.Local_Ref; end record; type Object_Ptr is access all Object; end PolyORB.CORBA_P.ServantLocator; polyorb-2.8~20110207.orig/src/corba/polyorb-corba_p-orb_init.ads0000644000175000017500000000550011750740340023644 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . C O R B A _ P . O R B _ I N I T -- -- -- -- S p e c -- -- -- -- Copyright (C) 2004 Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by ACT Europe. -- -- (email: sales@act-europe.fr) -- -- -- ------------------------------------------------------------------------------ -- This package defines procedures to register call backs functions -- to be called when initializing an ORB object. package PolyORB.CORBA_P.ORB_Init is type ORB_Init_Suffix_Type is access function (Value : String) return Boolean; procedure Register (Suffix : String; ORB_Init_Suffix : ORB_Init_Suffix_Type); -- Attach ORB_Init_Suffix initialization routine to Suffix function Initialize (Suffix : String; Value : String) return Boolean; -- Initialize Suffix with Value. Return True if the initialisation -- was succesful, else return False. function Initialize (Value : String) return Boolean; -- If the N first characters of Value matches one registered -- suffix, run the corresponding initialization routine, else -- return false. end PolyORB.CORBA_P.ORB_Init; polyorb-2.8~20110207.orig/src/corba/portableserver-idassignmentpolicy.adb0000644000175000017500000001422511750740340025675 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O R T A B L E S E R V E R . I D A S S I G N M E N T P O L I C Y -- -- -- -- B o d y -- -- -- -- Copyright (C) 2003-2007, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with PolyORB.CORBA_P.Policy; with PolyORB.CORBA_P.Policy_Management; with PortableServer.Helper; with PolyORB.Initialization; with PolyORB.Smart_Pointers; with PolyORB.Utils.Strings; package body PortableServer.IdAssignmentPolicy is use CORBA; use CORBA.Policy; use CORBA.TypeCode; use PortableServer.Helper; use PolyORB.CORBA_P.Policy; use PolyORB.CORBA_P.Policy_Management; function Create_IdAssignmentPolicy (The_Type : CORBA.PolicyType; Value : CORBA.Any) return CORBA.Policy.Ref; ------------ -- To_Ref -- ------------ function To_Ref (The_Ref : CORBA.Object.Ref'Class) return Ref is begin if The_Ref not in CORBA.Policy.Ref'Class or else Get_Policy_Type (CORBA.Policy.Ref (The_Ref)) /= ID_ASSIGNMENT_POLICY_ID then CORBA.Raise_Bad_Param (CORBA.Default_Sys_Member); end if; declare Entity : constant PolyORB.Smart_Pointers.Entity_Ptr := new Policy_Object_Type; Result : Ref; begin Set_Policy_Type (Policy_Object_Type (Entity.all), ID_ASSIGNMENT_POLICY_ID); Set_Policy_Value (Policy_Object_Type (Entity.all), Get_Policy_Value (Policy_Object_Type (Entity_Of (CORBA.Policy.Ref (The_Ref)).all))); CORBA.Policy.Set (CORBA.Policy.Ref (Result), Entity); return Result; end; end To_Ref; --------------- -- Get_Value -- --------------- function Get_Value (Self : Ref) return PortableServer.IdAssignmentPolicyValue is begin return From_Any (Get_Policy_Value (Policy_Object_Type (Entity_Of (CORBA.Policy.Ref (Self)).all))); end Get_Value; ------------------------------- -- Create_IdAssignmentPolicy -- ------------------------------- function Create_IdAssignmentPolicy (The_Type : CORBA.PolicyType; Value : CORBA.Any) return CORBA.Policy.Ref is begin pragma Assert (The_Type = ID_ASSIGNMENT_POLICY_ID); if Get_Type (Value) /= TC_IdAssignmentPolicyValue then Raise_PolicyError ((Reason => BAD_POLICY_TYPE)); end if; declare Position : constant CORBA.Unsigned_Long := CORBA.From_Any (CORBA.Internals.Get_Aggregate_Element (Value, CORBA.TC_Unsigned_Long, CORBA.Unsigned_Long (0))); begin if Position > IdAssignmentPolicyValue'Pos (IdAssignmentPolicyValue'Last) then Raise_PolicyError ((Reason => BAD_POLICY_VALUE)); end if; end; declare Result : CORBA.Policy.Ref; Entity : constant PolyORB.Smart_Pointers.Entity_Ptr := new Policy_Object_Type; begin Set_Policy_Type (Policy_Object_Type (Entity.all), The_Type); Set_Policy_Value (Policy_Object_Type (Entity.all), Value); CORBA.Policy.Set (Result, Entity); return Result; end; end Create_IdAssignmentPolicy; ----------------------------- -- Deferred_Initialization -- ----------------------------- procedure Deferred_Initialization; procedure Deferred_Initialization is begin Register (The_Type => ID_ASSIGNMENT_POLICY_ID, POA_Level => True, Factory => Create_IdAssignmentPolicy'Access, System_Default => Create_IdAssignmentPolicy (ID_ASSIGNMENT_POLICY_ID, To_Any (SYSTEM_ID))); end Deferred_Initialization; use PolyORB.Initialization; use PolyORB.Initialization.String_Lists; use PolyORB.Utils.Strings; begin Register_Module (Module_Info' (Name => +"portableserver.idassignmentpolicy", Conflicts => Empty, Depends => +"PortableServer.Helper", Provides => Empty, Implicit => False, Init => Deferred_Initialization'Access, Shutdown => null)); end PortableServer.IdAssignmentPolicy; polyorb-2.8~20110207.orig/src/corba/polyorb-sequences-unbounded-corba_helper.adb0000644000175000017500000000711211750740340027013 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- POLYORB.SEQUENCES.UNBOUNDED.CORBA_HELPER -- -- -- -- B o d y -- -- -- -- Copyright (C) 2003-2007, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- Any conversion subprograms for unbounded sequences package body PolyORB.Sequences.Unbounded.CORBA_Helper is ------------------------------ -- Element_From_Any_Wrapper -- ------------------------------ function Element_From_Any_Wrapper (Item : PolyORB.Any.Any) return Element is begin return Element_From_Any (CORBA.Any (Item)); end Element_From_Any_Wrapper; ---------------------------- -- Element_To_Any_Wrapper -- ---------------------------- function Element_To_Any_Wrapper (Item : Element) return PolyORB.Any.Any is begin return PolyORB.Any.Any (Element_To_Any (Item)); end Element_To_Any_Wrapper; -------------- -- From_Any -- -------------- function From_Any (Item : CORBA.Any) return Sequence is begin return Neutral_Helper.From_Any (PolyORB.Any.Any (Item)); end From_Any; ---------------- -- Initialize -- ---------------- procedure Initialize (Element_TC, Sequence_TC : CORBA.TypeCode.Object) is use CORBA.TypeCode.Internals; begin Neutral_Helper.Initialize (Element_TC => To_PolyORB_Object (Element_TC), Sequence_TC => To_PolyORB_Object (Sequence_TC)); end Initialize; ------------ -- To_Any -- ------------ function To_Any (Item : Sequence) return CORBA.Any is begin return CORBA.Any (Neutral_Helper.To_Any (Item)); end To_Any; ---------- -- Wrap -- ---------- function Wrap (X : access Sequence) return PolyORB.Any.Content'Class renames Neutral_Helper.Wrap; end PolyORB.Sequences.Unbounded.CORBA_Helper; polyorb-2.8~20110207.orig/src/corba/portableserver-servantretentionpolicy.adb0000644000175000017500000001437511750740340026630 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- PORTABLESERVER.SERVANTRETENTIONPOLICY -- -- -- -- B o d y -- -- -- -- Copyright (C) 2003-2007, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with PolyORB.CORBA_P.Policy; with PolyORB.CORBA_P.Policy_Management; with PortableServer.Helper; with PolyORB.Initialization; with PolyORB.Smart_Pointers; with PolyORB.Utils.Strings; package body PortableServer.ServantRetentionPolicy is use CORBA; use CORBA.Policy; use CORBA.TypeCode; use PortableServer.Helper; use PolyORB.CORBA_P.Policy; use PolyORB.CORBA_P.Policy_Management; function Create_ServantRetentionPolicy (The_Type : CORBA.PolicyType; Value : CORBA.Any) return CORBA.Policy.Ref; ------------ -- To_Ref -- ------------ function To_Ref (The_Ref : CORBA.Object.Ref'Class) return Ref is begin if The_Ref not in CORBA.Policy.Ref'Class or else Get_Policy_Type (CORBA.Policy.Ref (The_Ref)) /= SERVANT_RETENTION_POLICY_ID then CORBA.Raise_Bad_Param (CORBA.Default_Sys_Member); end if; declare Entity : constant PolyORB.Smart_Pointers.Entity_Ptr := new Policy_Object_Type; Result : Ref; begin Set_Policy_Type (Policy_Object_Type (Entity.all), SERVANT_RETENTION_POLICY_ID); Set_Policy_Value (Policy_Object_Type (Entity.all), Get_Policy_Value (Policy_Object_Type (Entity_Of (CORBA.Policy.Ref (The_Ref)).all))); CORBA.Policy.Set (CORBA.Policy.Ref (Result), Entity); return Result; end; end To_Ref; --------------- -- Get_Value -- --------------- function Get_Value (Self : Ref) return PortableServer.ServantRetentionPolicyValue is begin return From_Any (Get_Policy_Value (Policy_Object_Type (Entity_Of (CORBA.Policy.Ref (Self)).all))); end Get_Value; ----------------------------------- -- Create_ServantRetentionPolicy -- ----------------------------------- function Create_ServantRetentionPolicy (The_Type : CORBA.PolicyType; Value : CORBA.Any) return CORBA.Policy.Ref is begin pragma Assert (The_Type = SERVANT_RETENTION_POLICY_ID); if Get_Type (Value) /= TC_ServantRetentionPolicyValue then Raise_PolicyError ((Reason => BAD_POLICY_TYPE)); end if; declare Position : constant CORBA.Unsigned_Long := CORBA.From_Any (CORBA.Internals.Get_Aggregate_Element (Value, CORBA.TC_Unsigned_Long, CORBA.Unsigned_Long (0))); begin if Position > ServantRetentionPolicyValue'Pos (ServantRetentionPolicyValue'Last) then Raise_PolicyError ((Reason => BAD_POLICY_VALUE)); end if; end; declare Result : CORBA.Policy.Ref; Entity : constant PolyORB.Smart_Pointers.Entity_Ptr := new Policy_Object_Type; begin Set_Policy_Type (Policy_Object_Type (Entity.all), The_Type); Set_Policy_Value (Policy_Object_Type (Entity.all), Value); CORBA.Policy.Set (Result, Entity); return Result; end; end Create_ServantRetentionPolicy; ----------------------------- -- Deferred_Initialization -- ----------------------------- procedure Deferred_Initialization; procedure Deferred_Initialization is begin Register (The_Type => SERVANT_RETENTION_POLICY_ID, POA_Level => True, Factory => Create_ServantRetentionPolicy'Access, System_Default => Create_ServantRetentionPolicy (SERVANT_RETENTION_POLICY_ID, To_Any (RETAIN))); end Deferred_Initialization; use PolyORB.Initialization; use PolyORB.Initialization.String_Lists; use PolyORB.Utils.Strings; begin Register_Module (Module_Info' (Name => +"portableserver.servantretentionpolicy", Conflicts => Empty, Depends => +"PortableServer.Helper", Provides => Empty, Implicit => False, Init => Deferred_Initialization'Access, Shutdown => null)); end PortableServer.ServantRetentionPolicy; polyorb-2.8~20110207.orig/src/corba/portableserver-current-helper.ads0000644000175000017500000000666411750740340024760 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O R T A B L E S E R V E R . C U R R E N T . H E L P E R -- -- -- -- S p e c -- -- -- -- Copyright (C) 2005-2008, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the CORBA Specification, and adapted -- -- for use with PolyORB. The copyright notice above, and the license -- -- provisions that follow apply solely to the contents neither explicitly -- -- nor implicitly specified by the CORBA Specification defined by the OMG. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ ------------------------------------------------- -- This file has been generated automatically -- by IDLAC version 2.3.0w. -- -- Do NOT hand-modify this file, as your -- changes will be lost when you re-run the -- IDL to Ada compiler. ------------------------------------------------- pragma Style_Checks ("NM32766"); with CORBA; pragma Elaborate_All (CORBA); with CORBA.Object; package PortableServer.Current.Helper is function Unchecked_To_Local_Ref (The_Ref : CORBA.Object.Ref'Class) return PortableServer.Current.Local_Ref; function To_Local_Ref (The_Ref : CORBA.Object.Ref'Class) return PortableServer.Current.Local_Ref; TC_Current : CORBA.TypeCode.Object; TC_NoContext : CORBA.TypeCode.Object; function From_Any (Item : CORBA.Any) return PortableServer.Current.NoContext_Members; function To_Any (Item : PortableServer.Current.NoContext_Members) return CORBA.Any; procedure Raise_NoContext (Members : NoContext_Members); pragma No_Return (Raise_NoContext); end PortableServer.Current.Helper; polyorb-2.8~20110207.orig/src/corba/corba-policymanager.ads0000644000175000017500000000670211750740340022673 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- C O R B A . P O L I C Y M A N A G E R -- -- -- -- S p e c -- -- -- -- Copyright (C) 2004-2010, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the CORBA Specification, and adapted -- -- for use with PolyORB. The copyright notice above, and the license -- -- provisions that follow apply solely to the contents neither explicitly -- -- nor implicitly specified by the CORBA Specification defined by the OMG. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with CORBA.Local; with CORBA.Object; with CORBA.Policy; with PolyORB.Tasking.Mutexes; package CORBA.PolicyManager is type Local_Ref is new CORBA.Object.Ref with null record; function Get_Policy_Overrides (Self : Local_Ref; TS : CORBA.Policy.PolicyTypeSeq) return CORBA.Policy.PolicyList; procedure Set_Policy_Overrides (Self : Local_Ref; Policies : CORBA.Policy.PolicyList; Set_Add : SetOverrideType); private type Object is new CORBA.Local.Object with record Lock : PolyORB.Tasking.Mutexes.Mutex_Access; end record; type Object_Ptr is access all Object'Class; function Get_Policy_Overrides (Self : access Object; TS : CORBA.Policy.PolicyTypeSeq) return CORBA.Policy.PolicyList; procedure Set_Policy_Overrides (Self : access Object; Policies : CORBA.Policy.PolicyList; Set_Add : CORBA.SetOverrideType); function Is_A (Self : not null access Object; Logical_Type_Id : Standard.String) return Boolean; end CORBA.PolicyManager; polyorb-2.8~20110207.orig/src/corba/portableserver-iduniquenesspolicy.ads0000644000175000017500000000543011750740340025743 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O R T A B L E S E R V E R . I D U N I Q U E N E S S P O L I C Y -- -- -- -- S p e c -- -- -- -- Copyright (C) 2003-2008, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the CORBA Specification, and adapted -- -- for use with PolyORB. The copyright notice above, and the license -- -- provisions that follow apply solely to the contents neither explicitly -- -- nor implicitly specified by the CORBA Specification defined by the OMG. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with CORBA.Policy; package PortableServer.IdUniquenessPolicy is type Ref is new CORBA.Policy.Ref with private; function To_Ref (The_Ref : CORBA.Object.Ref'Class) return Ref; function Get_Value (Self : Ref) return PortableServer.IdUniquenessPolicyValue; private type Ref is new CORBA.Policy.Ref with null record; end PortableServer.IdUniquenessPolicy; polyorb-2.8~20110207.orig/src/corba/portableserver-implicitactivationpolicy.adb0000644000175000017500000001444611750740340027111 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- PORTABLESERVER.IMPLICITACTIVATIONPOLICY -- -- -- -- B o d y -- -- -- -- Copyright (C) 2003-2007, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with PolyORB.CORBA_P.Policy; with PolyORB.CORBA_P.Policy_Management; with PortableServer.Helper; with PolyORB.Initialization; with PolyORB.Smart_Pointers; with PolyORB.Utils.Strings; package body PortableServer.ImplicitActivationPolicy is use CORBA; use CORBA.Policy; use CORBA.TypeCode; use PortableServer.Helper; use PolyORB.CORBA_P.Policy; use PolyORB.CORBA_P.Policy_Management; function Create_ImplicitActivationPolicy (The_Type : CORBA.PolicyType; Value : CORBA.Any) return CORBA.Policy.Ref; ------------ -- To_Ref -- ------------ function To_Ref (The_Ref : CORBA.Object.Ref'Class) return Ref is begin if The_Ref not in CORBA.Policy.Ref'Class or else Get_Policy_Type (CORBA.Policy.Ref (The_Ref)) /= IMPLICIT_ACTIVATION_POLICY_ID then CORBA.Raise_Bad_Param (CORBA.Default_Sys_Member); end if; declare Entity : constant PolyORB.Smart_Pointers.Entity_Ptr := new Policy_Object_Type; Result : Ref; begin Set_Policy_Type (Policy_Object_Type (Entity.all), IMPLICIT_ACTIVATION_POLICY_ID); Set_Policy_Value (Policy_Object_Type (Entity.all), Get_Policy_Value (Policy_Object_Type (Entity_Of (CORBA.Policy.Ref (The_Ref)).all))); CORBA.Policy.Set (CORBA.Policy.Ref (Result), Entity); return Result; end; end To_Ref; --------------- -- Get_Value -- --------------- function Get_Value (Self : Ref) return PortableServer.ImplicitActivationPolicyValue is begin return From_Any (Get_Policy_Value (Policy_Object_Type (Entity_Of (CORBA.Policy.Ref (Self)).all))); end Get_Value; ------------------------------------- -- Create_ImplicitActivationPolicy -- ------------------------------------- function Create_ImplicitActivationPolicy (The_Type : CORBA.PolicyType; Value : CORBA.Any) return CORBA.Policy.Ref is begin pragma Assert (The_Type = IMPLICIT_ACTIVATION_POLICY_ID); if Get_Type (Value) /= TC_ImplicitActivationPolicyValue then Raise_PolicyError ((Reason => BAD_POLICY_TYPE)); end if; declare Position : constant CORBA.Unsigned_Long := CORBA.From_Any (CORBA.Internals.Get_Aggregate_Element (Value, CORBA.TC_Unsigned_Long, CORBA.Unsigned_Long (0))); begin if Position > ImplicitActivationPolicyValue'Pos (ImplicitActivationPolicyValue'Last) then Raise_PolicyError ((Reason => BAD_POLICY_VALUE)); end if; end; declare Result : CORBA.Policy.Ref; Entity : constant PolyORB.Smart_Pointers.Entity_Ptr := new Policy_Object_Type; begin Set_Policy_Type (Policy_Object_Type (Entity.all), The_Type); Set_Policy_Value (Policy_Object_Type (Entity.all), Value); CORBA.Policy.Set (Result, Entity); return Result; end; end Create_ImplicitActivationPolicy; ----------------------------- -- Deferred_Initialization -- ----------------------------- procedure Deferred_Initialization; procedure Deferred_Initialization is begin Register (The_Type => IMPLICIT_ACTIVATION_POLICY_ID, POA_Level => True, Factory => Create_ImplicitActivationPolicy'Access, System_Default => Create_ImplicitActivationPolicy (IMPLICIT_ACTIVATION_POLICY_ID, To_Any (NO_IMPLICIT_ACTIVATION))); end Deferred_Initialization; use PolyORB.Initialization; use PolyORB.Initialization.String_Lists; use PolyORB.Utils.Strings; begin Register_Module (Module_Info' (Name => +"portableserver.implicitactivationpolicy", Conflicts => Empty, Depends => +"PortableServer.Helper", Provides => Empty, Implicit => False, Init => Deferred_Initialization'Access, Shutdown => null)); end PortableServer.ImplicitActivationPolicy; polyorb-2.8~20110207.orig/src/corba/dynamicany/0000755000175000017500000000000011750740340020413 5ustar xavierxavierpolyorb-2.8~20110207.orig/src/corba/dynamicany/dynamicany-dynunion-impl.ads0000644000175000017500000000716111750740340026045 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- D Y N A M I C A N Y . D Y N U N I O N . I M P L -- -- -- -- S p e c -- -- -- -- Copyright (C) 2005-2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with PolyORB.Any; with DynamicAny.DynAny.Impl; package DynamicAny.DynUnion.Impl is type Object is new DynamicAny.DynAny.Impl.Object with private; type Object_Ptr is access all Object'Class; function Get_Discriminator (Self : access Object) return DynAny.Local_Ref; procedure Set_Discriminator (Self : access Object; D : DynAny.Local_Ref); procedure Set_To_Default_Member (Self : access Object); procedure Set_To_No_Active_Member (Self : access Object); function Has_No_Active_Member (Self : access Object) return CORBA.Boolean; function Discriminator_Kind (Self : access Object) return CORBA.TCKind; function Member (Self : access Object) return DynAny.Local_Ref; function Member_Name (Self : access Object) return FieldName; function Member_Kind (Self : access Object) return CORBA.TCKind; function Is_A (Self : not null access Object; Logical_Type_Id : Standard.String) return Boolean; package Internals is procedure Initialize (Self : access Object'Class; Value : PolyORB.Any.Any; Parent : DynAny.Impl.Object_Ptr); procedure Initialize (Self : access Object'Class; IDL_Type : PolyORB.Any.TypeCode.Local_Ref); function Create (Value : CORBA.Any; Parent : DynAny.Impl.Object_Ptr) return DynAny.Local_Ref; function Create (Value : PolyORB.Any.TypeCode.Local_Ref) return DynAny.Local_Ref; end Internals; private type Object is new DynamicAny.DynAny.Impl.Object with record null; end record; end DynamicAny.DynUnion.Impl; polyorb-2.8~20110207.orig/src/corba/dynamicany/dynamicany-dynany-impl.adb0000644000175000017500000023737311750740340025475 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- D Y N A M I C A N Y . D Y N A N Y . I M P L -- -- -- -- B o d y -- -- -- -- Copyright (C) 2005-2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with PolyORB.CORBA_P.Dynamic_Any; with PolyORB.Smart_Pointers; with PolyORB.Types; with DynamicAny.DynAny.Helper; package body DynamicAny.DynAny.Impl is use PolyORB.Any; use PolyORB.Any.TypeCode; use PolyORB.Types; use Internals; use type CORBA.Long; use type CORBA.Unsigned_Long; function Is_Ordinary_Aggregate (Kind : TCKind) return Boolean; -- Return True iff Kind is an ordinary aggregate (Tk_Struct, -- Tk_Union, Tk_Sequence, Tk_Array, Tk_Except). procedure Reset_Current_Position (Self : access Object'Class); -- Reset internal current position to initial value: -- 0 - for Any's with not zero components -- -1 - for Any's without components or with zero components ------------ -- Assign -- ------------ procedure Assign (Self : access Object; Dyn_Any : Local_Ref'Class) is begin if Is_Destroyed (Self) then CORBA.Raise_Object_Not_Exist (CORBA.Default_Sys_Member); end if; declare Value : constant PolyORB.Any.Any := Object_Ptr (Entity_Of (Dyn_Any)).Value; begin if not Equivalent (Get_Type (Self.Value), Get_Type (Value)) then Helper.Raise_TypeMismatch ((CORBA.IDL_Exception_Members with null record)); end if; Copy_Any_Value (Self.Value, Value); Reset_Current_Position (Self); end; end Assign; --------------------- -- Component_Count -- --------------------- function Component_Count (Self : access Object) return CORBA.Unsigned_Long is begin if Is_Destroyed (Self) then CORBA.Raise_Object_Not_Exist (CORBA.Default_Sys_Member); end if; declare T : constant PolyORB.Any.TypeCode.Object_Ptr := Get_Unwound_Type (Self.Value); begin case Kind (T) is when Tk_Sequence => return CORBA.Unsigned_Long (Get_Aggregate_Count (Self.Value)); -- For sequences the operation returns the current number -- of elements. when Tk_Struct | Tk_Except | Tk_Value => return CORBA.Unsigned_Long (Member_Count (T)); -- For structures, exceptions and valuetypes the operation -- returns the number of members. when Tk_Array => return CORBA.Unsigned_Long (Length (T)); -- For arrays the operation returns the number of elements when Tk_Union => raise Program_Error; -- For unions the operation returns 2 if the discriminator -- indicates that a named member is active; otherwise, -- it returns 1. -- XXX Not yet implemented. See CORBA 3.0 paragraph 9.2.2.9 -- "Iterating through components of a DynAny" when others => return 0; -- For all others types the operation always returns zero end case; end; end Component_Count; ---------- -- Copy -- ---------- function Copy (Self : access Object) return Local_Ref'Class is begin if Is_Destroyed (Self) then CORBA.Raise_Object_Not_Exist (CORBA.Default_Sys_Member); end if; return PolyORB.CORBA_P.Dynamic_Any.Create (CORBA.Any (Self.Value), True, null); end Copy; ----------------------- -- Current_Component -- ----------------------- function Current_Component (Self : access Object) return Local_Ref'Class is begin if Is_Destroyed (Self) then CORBA.Raise_Object_Not_Exist (CORBA.Default_Sys_Member); end if; if not Is_Ordinary_Aggregate (Kind (Get_Unwound_Type (Self.Value))) or else Component_Count (Self) = 0 then Helper.Raise_TypeMismatch ((CORBA.IDL_Exception_Members with null record)); end if; declare use Local_Ref_Lists; Null_Result : Local_Ref; Result : Local_Ref; begin if Self.Current = -1 then return Result; end if; -- Check list of already created DynAny's and return cached value if Length (Self.Children) > Natural (Self.Current) then Result := Element (Self.Children, Natural (Self.Current)).all; if not Is_Nil (Result) then return Null_Result; end if; end if; -- Create new DynAny declare Elem : constant PolyORB.Any.Any := Get_Aggregate_Element (Self.Value, TypeCode.TC_Null, Unsigned_Long (Self.Current)); begin Result := PolyORB.CORBA_P.Dynamic_Any.Create (CORBA.Any (Elem), True, Object_Ptr (Self)); if Length (Self.Children) > Natural (Self.Current) then -- If corresponding item in list already present, set value Element (Self.Children, Natural (Self.Current)).all := Result; else -- Append empty items to list if needed for J in Length (Self.Children) .. Integer (Self.Current) - 1 loop Append (Self.Children, Null_Result); end loop; -- Append created items Append (Self.Children, Result); end if; return Result; end; end; end Current_Component; ------------- -- Destroy -- ------------- procedure Destroy (Self : access Object) is begin if Is_Destroyed (Self) then CORBA.Raise_Object_Not_Exist (CORBA.Default_Sys_Member); end if; -- If DynAny is a top level object then mark it and all it's children -- are destroyed; otherwise do nothing. if Self.Parent = null then Mark_Destroyed (Self); end if; end Destroy; ----------- -- Equal -- ----------- function Equal (Self : access Object; Dyn_Any : Local_Ref'Class) return CORBA.Boolean is use type CORBA.Any; begin if Is_Destroyed (Self) then CORBA.Raise_Object_Not_Exist (CORBA.Default_Sys_Member); end if; return CORBA.Any (Self.Value) = Get_Value (Object_Ptr (Entity_Of (Dyn_Any))); end Equal; -------------- -- Finalize -- -------------- procedure Finalize (Self : in out Object) is begin -- Deallocate list of children Local_Ref_Lists.Deallocate (Self.Children); -- Finalize parent type CORBA.Local.Finalize (CORBA.Local.Object (Self)); end Finalize; -------------- -- From_Any -- -------------- procedure From_Any (Self : access Object; Value : CORBA.Any) is begin if Is_Destroyed (Self) then CORBA.Raise_Object_Not_Exist (CORBA.Default_Sys_Member); end if; declare Neutral : constant PolyORB.Any.Any := PolyORB.Any.Any (Value); begin if not Equivalent (Get_Type (Self.Value), Get_Type (Neutral)) then Helper.Raise_TypeMismatch ((CORBA.IDL_Exception_Members with null record)); end if; Copy_Any_Value (Self.Value, Neutral); Reset_Current_Position (Self); end; end From_Any; ------------------ -- Get_Abstract -- ------------------ function Get_Abstract (Self : access Object) return CORBA.AbstractBase.Ref is Result : CORBA.AbstractBase.Ref; begin if Is_Destroyed (Self) then CORBA.Raise_Object_Not_Exist (CORBA.Default_Sys_Member); end if; raise Program_Error; return Result; end Get_Abstract; ------------- -- Get_Any -- ------------- function Get_Any (Self : access Object) return CORBA.Any is begin if Is_Destroyed (Self) then CORBA.Raise_Object_Not_Exist (CORBA.Default_Sys_Member); end if; declare K : constant TCKind := Kind (Get_Unwound_Type (Self.Value)); begin if K = Tk_Any then return CORBA.Any (PolyORB.Any.Any'(From_Any (Self.Value))); elsif not Is_Ordinary_Aggregate (K) then Helper.Raise_TypeMismatch ((CORBA.IDL_Exception_Members with null record)); elsif Self.Current = -1 then Helper.Raise_InvalidValue ((CORBA.IDL_Exception_Members with null record)); else declare Element : constant PolyORB.Any.Any := Get_Aggregate_Element (Self.Value, TypeCode.TC_Any, Unsigned_Long (Self.Current)); begin if Kind (Get_Unwound_Type (Element)) = Tk_Any then return CORBA.Any (PolyORB.Any.Any'(From_Any (Element))); else Helper.Raise_TypeMismatch ((CORBA.IDL_Exception_Members with null record)); end if; end; end if; end; end Get_Any; ----------------- -- Get_Boolean -- ----------------- function Get_Boolean (Self : access Object) return CORBA.Boolean is begin if Is_Destroyed (Self) then CORBA.Raise_Object_Not_Exist (CORBA.Default_Sys_Member); end if; declare K : constant TCKind := Kind (Get_Unwound_Type (Self.Value)); begin if K = Tk_Boolean then return CORBA.From_Any (CORBA.Any (Self.Value)); elsif not Is_Ordinary_Aggregate (K) then Helper.Raise_TypeMismatch ((CORBA.IDL_Exception_Members with null record)); elsif Self.Current = -1 then Helper.Raise_InvalidValue ((CORBA.IDL_Exception_Members with null record)); else declare Element : constant PolyORB.Any.Any := Get_Aggregate_Element (Self.Value, TypeCode.TC_Boolean, Unsigned_Long (Self.Current)); begin if Kind (Get_Unwound_Type (Element)) = Tk_Boolean then return From_Any (Element); else Helper.Raise_TypeMismatch ((CORBA.IDL_Exception_Members with null record)); end if; end; end if; end; end Get_Boolean; --------------------- -- Get_Boolean_Seq -- --------------------- function Get_Boolean_Seq (Self : access Object) return CORBA.IDL_SEQUENCES.BooleanSeq is Result : CORBA.IDL_SEQUENCES.BooleanSeq; begin if Is_Destroyed (Self) then CORBA.Raise_Object_Not_Exist (CORBA.Default_Sys_Member); end if; raise Program_Error; return Result; end Get_Boolean_Seq; -------------- -- Get_Char -- -------------- function Get_Char (Self : access Object) return CORBA.Char is begin if Is_Destroyed (Self) then CORBA.Raise_Object_Not_Exist (CORBA.Default_Sys_Member); end if; declare K : constant TCKind := Kind (Get_Unwound_Type (Self.Value)); begin if K = Tk_Char then return From_Any (Self.Value); elsif not Is_Ordinary_Aggregate (K) then Helper.Raise_TypeMismatch ((CORBA.IDL_Exception_Members with null record)); elsif Self.Current = -1 then Helper.Raise_InvalidValue ((CORBA.IDL_Exception_Members with null record)); else declare Element : constant PolyORB.Any.Any := Get_Aggregate_Element (Self.Value, TypeCode.TC_Char, Unsigned_Long (Self.Current)); begin if Kind (Get_Unwound_Type (Element)) = Tk_Char then return From_Any (Element); else Helper.Raise_TypeMismatch ((CORBA.IDL_Exception_Members with null record)); end if; end; end if; end; end Get_Char; ------------------ -- Get_Char_Seq -- ------------------ function Get_Char_Seq (Self : access Object) return CORBA.IDL_SEQUENCES.CharSeq is Result : CORBA.IDL_SEQUENCES.CharSeq; begin if Is_Destroyed (Self) then CORBA.Raise_Object_Not_Exist (CORBA.Default_Sys_Member); end if; raise Program_Error; return Result; end Get_Char_Seq; ---------------- -- Get_Double -- ---------------- function Get_Double (Self : access Object) return CORBA.Double is begin if Is_Destroyed (Self) then CORBA.Raise_Object_Not_Exist (CORBA.Default_Sys_Member); end if; declare K : constant TCKind := Kind (Get_Unwound_Type (Self.Value)); begin if K = Tk_Double then return CORBA.Double (PolyORB.Types.Double'(From_Any (Self.Value))); elsif not Is_Ordinary_Aggregate (K) then Helper.Raise_TypeMismatch ((CORBA.IDL_Exception_Members with null record)); elsif Self.Current = -1 then Helper.Raise_InvalidValue ((CORBA.IDL_Exception_Members with null record)); else declare Element : constant PolyORB.Any.Any := Get_Aggregate_Element (Self.Value, TypeCode.TC_Double, Unsigned_Long (Self.Current)); begin if Kind (Get_Unwound_Type (Element)) = Tk_Double then return CORBA.Double (PolyORB.Types.Double'(From_Any (Element))); else Helper.Raise_TypeMismatch ((CORBA.IDL_Exception_Members with null record)); end if; end; end if; end; end Get_Double; -------------------- -- Get_Double_Seq -- -------------------- function Get_Double_Seq (Self : access Object) return CORBA.IDL_SEQUENCES.DoubleSeq is Result : CORBA.IDL_SEQUENCES.DoubleSeq; begin if Is_Destroyed (Self) then CORBA.Raise_Object_Not_Exist (CORBA.Default_Sys_Member); end if; raise Program_Error; return Result; end Get_Double_Seq; ----------------- -- Get_Dyn_Any -- ----------------- function Get_Dyn_Any (Self : access Object) return Local_Ref'Class is begin if Is_Destroyed (Self) then CORBA.Raise_Object_Not_Exist (CORBA.Default_Sys_Member); end if; declare K : constant TCKind := Kind (Get_Unwound_Type (Self.Value)); begin if K = Tk_Any then declare use Local_Ref_Lists; Result : Local_Ref; begin -- In case of DynAny, contains another Any we use Children -- list for store only one reference to DynAny. Thus if -- list is empty we create new DynAny and if not empty -- return cached DynAny. if Is_Empty (Self.Children) then Result := PolyORB.CORBA_P.Dynamic_Any.Create (CORBA.Any'(CORBA.From_Any (CORBA.Any (Self.Value))), True, Object_Ptr (Self)); Append (Self.Children, Result); else Result := Element (Self.Children, 0).all; end if; return Result; end; elsif not Is_Ordinary_Aggregate (K) then Helper.Raise_TypeMismatch ((CORBA.IDL_Exception_Members with null record)); elsif Self.Current = -1 then Helper.Raise_InvalidValue ((CORBA.IDL_Exception_Members with null record)); else declare Element : constant PolyORB.Any.Any := Get_Aggregate_Element (Self.Value, TypeCode.TC_Any, Unsigned_Long (Self.Current)); begin if Kind (Get_Unwound_Type (Element)) = Tk_Any then -- In case of component of type Any we just return -- the current component return Current_Component (Self); else Helper.Raise_TypeMismatch ((CORBA.IDL_Exception_Members with null record)); end if; end; end if; end; end Get_Dyn_Any; --------------- -- Get_Float -- --------------- function Get_Float (Self : access Object) return CORBA.Float is begin if Is_Destroyed (Self) then CORBA.Raise_Object_Not_Exist (CORBA.Default_Sys_Member); end if; declare K : constant TCKind := Kind (Get_Unwound_Type (Self.Value)); begin if K = Tk_Float then return CORBA.Float (PolyORB.Types.Float'(From_Any (Self.Value))); elsif not Is_Ordinary_Aggregate (K) then Helper.Raise_TypeMismatch ((CORBA.IDL_Exception_Members with null record)); elsif Self.Current = -1 then Helper.Raise_InvalidValue ((CORBA.IDL_Exception_Members with null record)); else declare Element : constant PolyORB.Any.Any := Get_Aggregate_Element (Self.Value, TypeCode.TC_Float, Unsigned_Long (Self.Current)); begin if Kind (Get_Unwound_Type (Element)) = Tk_Float then return CORBA.Float (PolyORB.Types.Float'(From_Any (Element))); else Helper.Raise_TypeMismatch ((CORBA.IDL_Exception_Members with null record)); end if; end; end if; end; end Get_Float; ------------------- -- Get_Float_Seq -- ------------------- function Get_Float_Seq (Self : access Object) return CORBA.IDL_SEQUENCES.FloatSeq is Result : CORBA.IDL_SEQUENCES.FloatSeq; begin if Is_Destroyed (Self) then CORBA.Raise_Object_Not_Exist (CORBA.Default_Sys_Member); end if; raise Program_Error; return Result; end Get_Float_Seq; -------------- -- Get_Long -- -------------- function Get_Long (Self : access Object) return CORBA.Long is begin if Is_Destroyed (Self) then CORBA.Raise_Object_Not_Exist (CORBA.Default_Sys_Member); end if; declare K : constant TCKind := Kind (Get_Unwound_Type (Self.Value)); begin if K = Tk_Long then return CORBA.Long (PolyORB.Types.Long'(From_Any (Self.Value))); elsif not Is_Ordinary_Aggregate (K) then Helper.Raise_TypeMismatch ((CORBA.IDL_Exception_Members with null record)); elsif Self.Current = -1 then Helper.Raise_InvalidValue ((CORBA.IDL_Exception_Members with null record)); else declare Element : constant PolyORB.Any.Any := Get_Aggregate_Element (Self.Value, TypeCode.TC_Long, Unsigned_Long (Self.Current)); begin if Kind (Get_Unwound_Type (Element)) = Tk_Long then return CORBA.Long (PolyORB.Types.Long'(From_Any (Element))); else Helper.Raise_TypeMismatch ((CORBA.IDL_Exception_Members with null record)); end if; end; end if; end; end Get_Long; ------------------ -- Get_Long_Seq -- ------------------ function Get_Long_Seq (Self : access Object) return CORBA.IDL_SEQUENCES.LongSeq is Result : CORBA.IDL_SEQUENCES.LongSeq; begin if Is_Destroyed (Self) then CORBA.Raise_Object_Not_Exist (CORBA.Default_Sys_Member); end if; raise Program_Error; return Result; end Get_Long_Seq; -------------------- -- Get_LongDouble -- -------------------- function Get_LongDouble (Self : access Object) return CORBA.Long_Double is begin if Is_Destroyed (Self) then CORBA.Raise_Object_Not_Exist (CORBA.Default_Sys_Member); end if; declare K : constant TCKind := Kind (Get_Unwound_Type (Self.Value)); begin if K = Tk_LongDouble then return CORBA.Long_Double (PolyORB.Types.Long_Double'(From_Any (Self.Value))); elsif not Is_Ordinary_Aggregate (K) then Helper.Raise_TypeMismatch ((CORBA.IDL_Exception_Members with null record)); elsif Self.Current = -1 then Helper.Raise_InvalidValue ((CORBA.IDL_Exception_Members with null record)); else declare Element : constant PolyORB.Any.Any := Get_Aggregate_Element (Self.Value, TypeCode.TC_Long_Double, Unsigned_Long (Self.Current)); begin if Kind (Get_Unwound_Type (Element)) = Tk_LongDouble then return CORBA.Long_Double (PolyORB.Types.Long_Double'(From_Any (Element))); else Helper.Raise_TypeMismatch ((CORBA.IDL_Exception_Members with null record)); end if; end; end if; end; end Get_LongDouble; ------------------------ -- Get_LongDouble_Seq -- ------------------------ function Get_LongDouble_Seq (Self : access Object) return CORBA.IDL_SEQUENCES.LongDoubleSeq is Result : CORBA.IDL_SEQUENCES.LongDoubleSeq; begin if Is_Destroyed (Self) then CORBA.Raise_Object_Not_Exist (CORBA.Default_Sys_Member); end if; raise Program_Error; return Result; end Get_LongDouble_Seq; ------------------ -- Get_LongLong -- ------------------ function Get_LongLong (Self : access Object) return CORBA.Long_Long is begin if Is_Destroyed (Self) then CORBA.Raise_Object_Not_Exist (CORBA.Default_Sys_Member); end if; declare K : constant TCKind := Kind (Get_Unwound_Type (Self.Value)); begin if K = Tk_LongLong then return CORBA.Long_Long (PolyORB.Types.Long_Long'(From_Any (Self.Value))); elsif not Is_Ordinary_Aggregate (K) then Helper.Raise_TypeMismatch ((CORBA.IDL_Exception_Members with null record)); elsif Self.Current = -1 then Helper.Raise_InvalidValue ((CORBA.IDL_Exception_Members with null record)); else declare Element : constant PolyORB.Any.Any := Get_Aggregate_Element (Self.Value, TypeCode.TC_Long_Long, Unsigned_Long (Self.Current)); begin if Kind (Get_Unwound_Type (Element)) = Tk_LongLong then return CORBA.Long_Long (PolyORB.Types.Long_Long'(From_Any (Element))); else Helper.Raise_TypeMismatch ((CORBA.IDL_Exception_Members with null record)); end if; end; end if; end; end Get_LongLong; ---------------------- -- Get_LongLong_Seq -- ---------------------- function Get_LongLong_Seq (Self : access Object) return CORBA.IDL_SEQUENCES.LongLongSeq is Result : CORBA.IDL_SEQUENCES.LongLongSeq; begin if Is_Destroyed (Self) then CORBA.Raise_Object_Not_Exist (CORBA.Default_Sys_Member); end if; raise Program_Error; return Result; end Get_LongLong_Seq; --------------- -- Get_Octet -- --------------- function Get_Octet (Self : access Object) return CORBA.Octet is begin if Is_Destroyed (Self) then CORBA.Raise_Object_Not_Exist (CORBA.Default_Sys_Member); end if; declare K : constant TCKind := Kind (Get_Unwound_Type (Self.Value)); begin if K = Tk_Octet then return CORBA.Octet (PolyORB.Types.Octet'(From_Any (Self.Value))); elsif not Is_Ordinary_Aggregate (K) then Helper.Raise_TypeMismatch ((CORBA.IDL_Exception_Members with null record)); elsif Self.Current = -1 then Helper.Raise_InvalidValue ((CORBA.IDL_Exception_Members with null record)); else declare Element : constant PolyORB.Any.Any := Get_Aggregate_Element (Self.Value, TypeCode.TC_Octet, Unsigned_Long (Self.Current)); begin if Kind (Get_Unwound_Type (Element)) = Tk_Octet then return CORBA.Octet (PolyORB.Types.Octet'(From_Any (Element))); else Helper.Raise_TypeMismatch ((CORBA.IDL_Exception_Members with null record)); end if; end; end if; end; end Get_Octet; ------------------- -- Get_Octet_Seq -- ------------------- function Get_Octet_Seq (Self : access Object) return CORBA.IDL_SEQUENCES.OctetSeq is Result : CORBA.IDL_SEQUENCES.OctetSeq; begin if Is_Destroyed (Self) then CORBA.Raise_Object_Not_Exist (CORBA.Default_Sys_Member); end if; raise Program_Error; return Result; end Get_Octet_Seq; ------------------- -- Get_Reference -- ------------------- function Get_Reference (Self : access Object) return CORBA.Object.Ref is Result : CORBA.Object.Ref; begin if Is_Destroyed (Self) then CORBA.Raise_Object_Not_Exist (CORBA.Default_Sys_Member); end if; raise Program_Error; return Result; end Get_Reference; --------------- -- Get_Short -- --------------- function Get_Short (Self : access Object) return CORBA.Short is begin if Is_Destroyed (Self) then CORBA.Raise_Object_Not_Exist (CORBA.Default_Sys_Member); end if; declare K : constant TCKind := Kind (Get_Unwound_Type (Self.Value)); begin if K = Tk_Short then return CORBA.Short (PolyORB.Types.Short'(From_Any (Self.Value))); elsif not Is_Ordinary_Aggregate (K) then Helper.Raise_TypeMismatch ((CORBA.IDL_Exception_Members with null record)); elsif Self.Current = -1 then Helper.Raise_InvalidValue ((CORBA.IDL_Exception_Members with null record)); else declare Element : constant PolyORB.Any.Any := Get_Aggregate_Element (Self.Value, TypeCode.TC_Short, Unsigned_Long (Self.Current)); begin if Kind (Get_Unwound_Type (Element)) = Tk_Short then return CORBA.Short (PolyORB.Types.Short'(From_Any (Element))); else Helper.Raise_TypeMismatch ((CORBA.IDL_Exception_Members with null record)); end if; end; end if; end; end Get_Short; ------------------- -- Get_Short_Seq -- ------------------- function Get_Short_Seq (Self : access Object) return CORBA.IDL_SEQUENCES.ShortSeq is Result : CORBA.IDL_SEQUENCES.ShortSeq; begin if Is_Destroyed (Self) then CORBA.Raise_Object_Not_Exist (CORBA.Default_Sys_Member); end if; raise Program_Error; return Result; end Get_Short_Seq; ---------------- -- Get_String -- ---------------- function Get_String (Self : access Object) return CORBA.String is begin if Is_Destroyed (Self) then CORBA.Raise_Object_Not_Exist (CORBA.Default_Sys_Member); end if; declare K : constant TCKind := Kind (Get_Unwound_Type (Self.Value)); begin if K = Tk_String then return CORBA.String (PolyORB.Types.String'(From_Any (Self.Value))); elsif not Is_Ordinary_Aggregate (K) then Helper.Raise_TypeMismatch ((CORBA.IDL_Exception_Members with null record)); elsif Self.Current = -1 then Helper.Raise_InvalidValue ((CORBA.IDL_Exception_Members with null record)); else declare Element : constant PolyORB.Any.Any := Get_Aggregate_Element (Self.Value, TypeCode.TC_String, Unsigned_Long (Self.Current)); begin if Kind (Get_Unwound_Type (Element)) = Tk_String then return CORBA.String (PolyORB.Types.String'(From_Any (Element))); else Helper.Raise_TypeMismatch ((CORBA.IDL_Exception_Members with null record)); end if; end; end if; end; end Get_String; ------------------ -- Get_TypeCode -- ------------------ function Get_TypeCode (Self : access Object) return CORBA.TypeCode.Object is begin if Is_Destroyed (Self) then CORBA.Raise_Object_Not_Exist (CORBA.Default_Sys_Member); end if; declare K : constant TCKind := Kind (Get_Unwound_Type (Self.Value)); begin if K = Tk_TypeCode then return CORBA.From_Any (CORBA.Any (Self.Value)); elsif not Is_Ordinary_Aggregate (K) then Helper.Raise_TypeMismatch ((CORBA.IDL_Exception_Members with null record)); elsif Self.Current = -1 then Helper.Raise_InvalidValue ((CORBA.IDL_Exception_Members with null record)); else declare Element : constant PolyORB.Any.Any := Get_Aggregate_Element (Self.Value, TypeCode.TC_Any, Unsigned_Long (Self.Current)); begin if Kind (Get_Unwound_Type (Element)) = Tk_Any then return CORBA.From_Any (CORBA.Any (Element)); else Helper.Raise_TypeMismatch ((CORBA.IDL_Exception_Members with null record)); end if; end; end if; end; end Get_TypeCode; --------------- -- Get_ULong -- --------------- function Get_ULong (Self : access Object) return CORBA.Unsigned_Long is begin if Is_Destroyed (Self) then CORBA.Raise_Object_Not_Exist (CORBA.Default_Sys_Member); end if; declare K : constant TCKind := Kind (Get_Unwound_Type (Self.Value)); begin if K = Tk_Ulong then return CORBA.Unsigned_Long (PolyORB.Types.Unsigned_Long'(From_Any (Self.Value))); elsif not Is_Ordinary_Aggregate (K) then Helper.Raise_TypeMismatch ((CORBA.IDL_Exception_Members with null record)); elsif Self.Current = -1 then Helper.Raise_InvalidValue ((CORBA.IDL_Exception_Members with null record)); else declare Element : constant PolyORB.Any.Any := Get_Aggregate_Element (Self.Value, TypeCode.TC_Unsigned_Long, Unsigned_Long (Self.Current)); begin if Kind (Get_Unwound_Type (Element)) = Tk_Ulong then return CORBA.Unsigned_Long (PolyORB.Types.Unsigned_Long'(From_Any (Element))); else Helper.Raise_TypeMismatch ((CORBA.IDL_Exception_Members with null record)); end if; end; end if; end; end Get_ULong; ------------------- -- Get_ULong_Seq -- ------------------- function Get_ULong_Seq (Self : access Object) return CORBA.IDL_SEQUENCES.ULongSeq is Result : CORBA.IDL_SEQUENCES.ULongSeq; begin if Is_Destroyed (Self) then CORBA.Raise_Object_Not_Exist (CORBA.Default_Sys_Member); end if; raise Program_Error; return Result; end Get_ULong_Seq; ------------------- -- Get_ULongLong -- ------------------- function Get_ULongLong (Self : access Object) return CORBA.Unsigned_Long_Long is begin if Is_Destroyed (Self) then CORBA.Raise_Object_Not_Exist (CORBA.Default_Sys_Member); end if; declare K : constant TCKind := Kind (Get_Unwound_Type (Self.Value)); begin if K = Tk_Ulonglong then return CORBA.Unsigned_Long_Long (PolyORB.Types.Unsigned_Long_Long'(From_Any (Self.Value))); elsif not Is_Ordinary_Aggregate (K) then Helper.Raise_TypeMismatch ((CORBA.IDL_Exception_Members with null record)); elsif Self.Current = -1 then Helper.Raise_InvalidValue ((CORBA.IDL_Exception_Members with null record)); else declare Element : constant PolyORB.Any.Any := Get_Aggregate_Element (Self.Value, TypeCode.TC_Unsigned_Long_Long, Unsigned_Long (Self.Current)); begin if Kind (Get_Unwound_Type (Element)) = Tk_Ulonglong then return CORBA.Unsigned_Long_Long (PolyORB.Types.Unsigned_Long_Long'(From_Any (Element))); else Helper.Raise_TypeMismatch ((CORBA.IDL_Exception_Members with null record)); end if; end; end if; end; end Get_ULongLong; ----------------------- -- Get_ULongLong_Seq -- ----------------------- function Get_ULongLong_Seq (Self : access Object) return CORBA.IDL_SEQUENCES.ULongLongSeq is Result : CORBA.IDL_SEQUENCES.ULongLongSeq; begin if Is_Destroyed (Self) then CORBA.Raise_Object_Not_Exist (CORBA.Default_Sys_Member); end if; raise Program_Error; return Result; end Get_ULongLong_Seq; ---------------- -- Get_UShort -- ---------------- function Get_UShort (Self : access Object) return CORBA.Unsigned_Short is begin if Is_Destroyed (Self) then CORBA.Raise_Object_Not_Exist (CORBA.Default_Sys_Member); end if; declare K : constant TCKind := Kind (Get_Unwound_Type (Self.Value)); begin if K = Tk_Ushort then return CORBA.Unsigned_Short (PolyORB.Types.Unsigned_Short'(From_Any (Self.Value))); elsif not Is_Ordinary_Aggregate (K) then Helper.Raise_TypeMismatch ((CORBA.IDL_Exception_Members with null record)); elsif Self.Current = -1 then Helper.Raise_InvalidValue ((CORBA.IDL_Exception_Members with null record)); else declare Element : constant PolyORB.Any.Any := Get_Aggregate_Element (Self.Value, TypeCode.TC_Unsigned_Short, Unsigned_Long (Self.Current)); begin if Kind (Get_Unwound_Type (Element)) = Tk_Ushort then return CORBA.Unsigned_Short (PolyORB.Types.Unsigned_Short'(From_Any (Element))); else Helper.Raise_TypeMismatch ((CORBA.IDL_Exception_Members with null record)); end if; end; end if; end; end Get_UShort; -------------------- -- Get_UShort_Seq -- -------------------- function Get_UShort_Seq (Self : access Object) return CORBA.IDL_SEQUENCES.UShortSeq is Result : CORBA.IDL_SEQUENCES.UShortSeq; begin if Is_Destroyed (Self) then CORBA.Raise_Object_Not_Exist (CORBA.Default_Sys_Member); end if; raise Program_Error; return Result; end Get_UShort_Seq; --------------- -- Get_WChar -- --------------- function Get_WChar (Self : access Object) return CORBA.Wchar is begin if Is_Destroyed (Self) then CORBA.Raise_Object_Not_Exist (CORBA.Default_Sys_Member); end if; declare K : constant TCKind := Kind (Get_Unwound_Type (Self.Value)); begin if K = Tk_Widechar then return From_Any (Self.Value); elsif not Is_Ordinary_Aggregate (K) then Helper.Raise_TypeMismatch ((CORBA.IDL_Exception_Members with null record)); elsif Self.Current = -1 then Helper.Raise_InvalidValue ((CORBA.IDL_Exception_Members with null record)); else declare Element : constant PolyORB.Any.Any := Get_Aggregate_Element (Self.Value, TypeCode.TC_Wchar, Unsigned_Long (Self.Current)); begin if Kind (Get_Unwound_Type (Element)) = Tk_Widechar then return From_Any (Element); else Helper.Raise_TypeMismatch ((CORBA.IDL_Exception_Members with null record)); end if; end; end if; end; end Get_WChar; ------------------- -- Get_WChar_Seq -- ------------------- function Get_WChar_Seq (Self : access Object) return CORBA.IDL_SEQUENCES.WCharSeq is Result : CORBA.IDL_SEQUENCES.WCharSeq; begin if Is_Destroyed (Self) then CORBA.Raise_Object_Not_Exist (CORBA.Default_Sys_Member); end if; raise Program_Error; return Result; end Get_WChar_Seq; ----------------- -- Get_WString -- ----------------- function Get_WString (Self : access Object) return CORBA.Wide_String is begin if Is_Destroyed (Self) then CORBA.Raise_Object_Not_Exist (CORBA.Default_Sys_Member); end if; declare K : constant TCKind := Kind (Get_Unwound_Type (Self.Value)); begin if K = Tk_Wstring then return CORBA.Wide_String (PolyORB.Types.Wide_String'(From_Any (Self.Value))); elsif not Is_Ordinary_Aggregate (K) then Helper.Raise_TypeMismatch ((CORBA.IDL_Exception_Members with null record)); elsif Self.Current = -1 then Helper.Raise_InvalidValue ((CORBA.IDL_Exception_Members with null record)); else declare Element : constant PolyORB.Any.Any := Get_Aggregate_Element (Self.Value, TypeCode.TC_Wide_String, Unsigned_Long (Self.Current)); begin if Kind (Get_Unwound_Type (Element)) = Tk_Wstring then return CORBA.Wide_String (PolyORB.Types.Wide_String'(From_Any (Element))); else Helper.Raise_TypeMismatch ((CORBA.IDL_Exception_Members with null record)); end if; end; end if; end; end Get_WString; -------------- -- IDL_Type -- -------------- function IDL_Type (Self : access Object) return CORBA.TypeCode.Object is begin if Is_Destroyed (Self) then CORBA.Raise_Object_Not_Exist (CORBA.Default_Sys_Member); end if; return CORBA.TypeCode.Internals.To_CORBA_Object (Get_Type (Self.Value)); end IDL_Type; --------------------- -- Insert_Abstract -- --------------------- procedure Insert_Abstract (Self : access Object; Value : CORBA.AbstractBase.Ref) is pragma Unreferenced (Value); begin if Is_Destroyed (Self) then CORBA.Raise_Object_Not_Exist (CORBA.Default_Sys_Member); end if; raise Program_Error; end Insert_Abstract; ---------------- -- Insert_Any -- ---------------- procedure Insert_Any (Self : access Object; Value : CORBA.Any) is begin if Is_Destroyed (Self) then CORBA.Raise_Object_Not_Exist (CORBA.Default_Sys_Member); end if; declare K : constant TCKind := Kind (Get_Unwound_Type (Self.Value)); begin if K = Tk_Any then Set_Any_Value (PolyORB.Any.Any (Value), Get_Container (Self.Value).all); elsif not Is_Ordinary_Aggregate (K) then Helper.Raise_TypeMismatch ((CORBA.IDL_Exception_Members with null record)); elsif Self.Current = -1 then Helper.Raise_InvalidValue ((CORBA.IDL_Exception_Members with null record)); else declare Element : constant PolyORB.Any.Any := Get_Aggregate_Element (Self.Value, TypeCode.TC_Any, Unsigned_Long (Self.Current)); begin if Kind (Get_Unwound_Type (Element)) = Tk_Any then Set_Any_Value (PolyORB.Any.Any (Value), Get_Container (Element).all); else Helper.Raise_TypeMismatch ((CORBA.IDL_Exception_Members with null record)); end if; end; end if; end; end Insert_Any; --------------------- -- Insert_Boolean -- --------------------- procedure Insert_Boolean (Self : access Object; Value : CORBA.Boolean) is begin if Is_Destroyed (Self) then CORBA.Raise_Object_Not_Exist (CORBA.Default_Sys_Member); end if; declare K : constant TCKind := Kind (Get_Unwound_Type (Self.Value)); begin if K = Tk_Boolean then Set_Any_Value (Value, Get_Container (Self.Value).all); elsif not Is_Ordinary_Aggregate (K) then Helper.Raise_TypeMismatch ((CORBA.IDL_Exception_Members with null record)); elsif Self.Current = -1 then Helper.Raise_InvalidValue ((CORBA.IDL_Exception_Members with null record)); else declare Element : constant PolyORB.Any.Any := Get_Aggregate_Element (Self.Value, TypeCode.TC_Boolean, Unsigned_Long (Self.Current)); begin if Kind (Get_Unwound_Type (Element)) = Tk_Boolean then Set_Any_Value (Value, Get_Container (Element).all); else Helper.Raise_TypeMismatch ((CORBA.IDL_Exception_Members with null record)); end if; end; end if; end; end Insert_Boolean; ------------------------ -- Insert_Boolean_Seq -- ------------------------ procedure Insert_Boolean_Seq (Self : access Object; Value : CORBA.IDL_SEQUENCES.BooleanSeq) is pragma Unreferenced (Value); begin if Is_Destroyed (Self) then CORBA.Raise_Object_Not_Exist (CORBA.Default_Sys_Member); end if; raise Program_Error; end Insert_Boolean_Seq; ------------------ -- Insert_Char -- ------------------ procedure Insert_Char (Self : access Object; Value : CORBA.Char) is begin if Is_Destroyed (Self) then CORBA.Raise_Object_Not_Exist (CORBA.Default_Sys_Member); end if; declare K : constant TCKind := Kind (Get_Unwound_Type (Self.Value)); begin if K = Tk_Char then Set_Any_Value (Value, Get_Container (Self.Value).all); elsif not Is_Ordinary_Aggregate (K) then Helper.Raise_TypeMismatch ((CORBA.IDL_Exception_Members with null record)); elsif Self.Current = -1 then Helper.Raise_InvalidValue ((CORBA.IDL_Exception_Members with null record)); else declare Element : constant PolyORB.Any.Any := Get_Aggregate_Element (Self.Value, TypeCode.TC_Char, Unsigned_Long (Self.Current)); begin if Kind (Get_Unwound_Type (Element)) = Tk_Char then Set_Any_Value (Value, Get_Container (Element).all); else Helper.Raise_TypeMismatch ((CORBA.IDL_Exception_Members with null record)); end if; end; end if; end; end Insert_Char; --------------------- -- Insert_Char_Seq -- --------------------- procedure Insert_Char_Seq (Self : access Object; Value : CORBA.IDL_SEQUENCES.CharSeq) is pragma Unreferenced (Value); begin if Is_Destroyed (Self) then CORBA.Raise_Object_Not_Exist (CORBA.Default_Sys_Member); end if; raise Program_Error; end Insert_Char_Seq; ------------------- -- Insert_Double -- ------------------- procedure Insert_Double (Self : access Object; Value : CORBA.Double) is begin if Is_Destroyed (Self) then CORBA.Raise_Object_Not_Exist (CORBA.Default_Sys_Member); end if; declare K : constant TCKind := Kind (Get_Unwound_Type (Self.Value)); begin if K = Tk_Double then Set_Any_Value (PolyORB.Types.Double (Value), Get_Container (Self.Value).all); elsif not Is_Ordinary_Aggregate (K) then Helper.Raise_TypeMismatch ((CORBA.IDL_Exception_Members with null record)); elsif Self.Current = -1 then Helper.Raise_InvalidValue ((CORBA.IDL_Exception_Members with null record)); else declare Element : constant PolyORB.Any.Any := Get_Aggregate_Element (Self.Value, TypeCode.TC_Double, Unsigned_Long (Self.Current)); begin if Kind (Get_Unwound_Type (Element)) = Tk_Double then Set_Any_Value (PolyORB.Types.Double (Value), Get_Container (Element).all); else Helper.Raise_TypeMismatch ((CORBA.IDL_Exception_Members with null record)); end if; end; end if; end; end Insert_Double; ----------------------- -- Insert_Double_Seq -- ----------------------- procedure Insert_Double_Seq (Self : access Object; Value : CORBA.IDL_SEQUENCES.DoubleSeq) is pragma Unreferenced (Value); begin if Is_Destroyed (Self) then CORBA.Raise_Object_Not_Exist (CORBA.Default_Sys_Member); end if; raise Program_Error; end Insert_Double_Seq; -------------------- -- Insert_Dyn_Any -- -------------------- procedure Insert_Dyn_Any (Self : access Object; Value : Local_Ref'Class) is begin if Is_Destroyed (Self) then CORBA.Raise_Object_Not_Exist (CORBA.Default_Sys_Member); end if; declare K : constant TCKind := Kind (Get_Unwound_Type (Self.Value)); begin if K = Tk_Any then Set_Any_Value (PolyORB.Any.Any (Get_Value (Object_Ptr (Entity_Of (Value)))), Get_Container (Self.Value).all); elsif not Is_Ordinary_Aggregate (K) then Helper.Raise_TypeMismatch ((CORBA.IDL_Exception_Members with null record)); elsif Self.Current = -1 then Helper.Raise_InvalidValue ((CORBA.IDL_Exception_Members with null record)); else declare Element : constant PolyORB.Any.Any := Get_Aggregate_Element (Self.Value, TypeCode.TC_Any, Unsigned_Long (Self.Current)); begin if Kind (Get_Unwound_Type (Element)) = Tk_Any then Set_Any_Value (PolyORB.Any.Any (Get_Value (Object_Ptr (Entity_Of (Value)))), Get_Container (Element).all); else Helper.Raise_TypeMismatch ((CORBA.IDL_Exception_Members with null record)); end if; end; end if; end; end Insert_Dyn_Any; ------------------- -- Insert_Float -- ------------------- procedure Insert_Float (Self : access Object; Value : CORBA.Float) is begin if Is_Destroyed (Self) then CORBA.Raise_Object_Not_Exist (CORBA.Default_Sys_Member); end if; declare K : constant TCKind := Kind (Get_Unwound_Type (Self.Value)); begin if K = Tk_Float then Set_Any_Value (PolyORB.Types.Float (Value), Get_Container (Self.Value).all); elsif not Is_Ordinary_Aggregate (K) then Helper.Raise_TypeMismatch ((CORBA.IDL_Exception_Members with null record)); elsif Self.Current = -1 then Helper.Raise_InvalidValue ((CORBA.IDL_Exception_Members with null record)); else declare Element : constant PolyORB.Any.Any := Get_Aggregate_Element (Self.Value, TypeCode.TC_Float, Unsigned_Long (Self.Current)); begin if Kind (Get_Unwound_Type (Element)) = Tk_Float then Set_Any_Value (PolyORB.Types.Float (Value), Get_Container (Element).all); else Helper.Raise_TypeMismatch ((CORBA.IDL_Exception_Members with null record)); end if; end; end if; end; end Insert_Float; ---------------------- -- Insert_Float_Seq -- ---------------------- procedure Insert_Float_Seq (Self : access Object; Value : CORBA.IDL_SEQUENCES.FloatSeq) is pragma Unreferenced (Value); begin if Is_Destroyed (Self) then CORBA.Raise_Object_Not_Exist (CORBA.Default_Sys_Member); end if; raise Program_Error; end Insert_Float_Seq; ------------------ -- Insert_Long -- ------------------ procedure Insert_Long (Self : access Object; Value : CORBA.Long) is begin if Is_Destroyed (Self) then CORBA.Raise_Object_Not_Exist (CORBA.Default_Sys_Member); end if; declare K : constant TCKind := Kind (Get_Unwound_Type (Self.Value)); begin if K = Tk_Long then Set_Any_Value (PolyORB.Types.Long (Value), Get_Container (Self.Value).all); elsif not Is_Ordinary_Aggregate (K) then Helper.Raise_TypeMismatch ((CORBA.IDL_Exception_Members with null record)); elsif Self.Current = -1 then Helper.Raise_InvalidValue ((CORBA.IDL_Exception_Members with null record)); else declare Element : constant PolyORB.Any.Any := Get_Aggregate_Element (Self.Value, TypeCode.TC_Long, Unsigned_Long (Self.Current)); begin if Kind (Get_Unwound_Type (Element)) = Tk_Long then Set_Any_Value (PolyORB.Types.Long (Value), Get_Container (Element).all); else Helper.Raise_TypeMismatch ((CORBA.IDL_Exception_Members with null record)); end if; end; end if; end; end Insert_Long; --------------------- -- Insert_Long_Seq -- --------------------- procedure Insert_Long_Seq (Self : access Object; Value : CORBA.IDL_SEQUENCES.LongSeq) is pragma Unreferenced (Value); begin if Is_Destroyed (Self) then CORBA.Raise_Object_Not_Exist (CORBA.Default_Sys_Member); end if; raise Program_Error; end Insert_Long_Seq; ----------------------- -- Insert_LongDouble -- ----------------------- procedure Insert_LongDouble (Self : access Object; Value : CORBA.Long_Double) is begin if Is_Destroyed (Self) then CORBA.Raise_Object_Not_Exist (CORBA.Default_Sys_Member); end if; declare K : constant TCKind := Kind (Get_Unwound_Type (Self.Value)); begin if K = Tk_LongDouble then Set_Any_Value (PolyORB.Types.Long_Double (Value), Get_Container (Self.Value).all); elsif not Is_Ordinary_Aggregate (K) then Helper.Raise_TypeMismatch ((CORBA.IDL_Exception_Members with null record)); elsif Self.Current = -1 then Helper.Raise_InvalidValue ((CORBA.IDL_Exception_Members with null record)); else declare Element : constant PolyORB.Any.Any := Get_Aggregate_Element (Self.Value, TypeCode.TC_Long_Double, Unsigned_Long (Self.Current)); begin if Kind (Get_Unwound_Type (Element)) = Tk_LongDouble then Set_Any_Value (PolyORB.Types.Long_Double (Value), Get_Container (Element).all); else Helper.Raise_TypeMismatch ((CORBA.IDL_Exception_Members with null record)); end if; end; end if; end; end Insert_LongDouble; --------------------------- -- Insert_LongDouble_Seq -- --------------------------- procedure Insert_LongDouble_Seq (Self : access Object; Value : CORBA.IDL_SEQUENCES.LongDoubleSeq) is pragma Unreferenced (Value); begin if Is_Destroyed (Self) then CORBA.Raise_Object_Not_Exist (CORBA.Default_Sys_Member); end if; raise Program_Error; end Insert_LongDouble_Seq; ---------------------- -- Insert_LongLong -- ---------------------- procedure Insert_LongLong (Self : access Object; Value : CORBA.Long_Long) is begin if Is_Destroyed (Self) then CORBA.Raise_Object_Not_Exist (CORBA.Default_Sys_Member); end if; declare K : constant TCKind := Kind (Get_Unwound_Type (Self.Value)); begin if K = Tk_LongLong then Set_Any_Value (PolyORB.Types.Long_Long (Value), Get_Container (Self.Value).all); elsif not Is_Ordinary_Aggregate (K) then Helper.Raise_TypeMismatch ((CORBA.IDL_Exception_Members with null record)); elsif Self.Current = -1 then Helper.Raise_InvalidValue ((CORBA.IDL_Exception_Members with null record)); else declare Element : constant PolyORB.Any.Any := Get_Aggregate_Element (Self.Value, TypeCode.TC_Long_Long, Unsigned_Long (Self.Current)); begin if Kind (Get_Unwound_Type (Element)) = Tk_LongLong then Set_Any_Value (PolyORB.Types.Long_Long (Value), Get_Container (Element).all); else Helper.Raise_TypeMismatch ((CORBA.IDL_Exception_Members with null record)); end if; end; end if; end; end Insert_LongLong; ------------------------- -- Insert_LongLong_Seq -- ------------------------- procedure Insert_LongLong_Seq (Self : access Object; Value : CORBA.IDL_SEQUENCES.LongLongSeq) is pragma Unreferenced (Value); begin if Is_Destroyed (Self) then CORBA.Raise_Object_Not_Exist (CORBA.Default_Sys_Member); end if; raise Program_Error; end Insert_LongLong_Seq; ------------------- -- Insert_Octet -- ------------------- procedure Insert_Octet (Self : access Object; Value : CORBA.Octet) is begin if Is_Destroyed (Self) then CORBA.Raise_Object_Not_Exist (CORBA.Default_Sys_Member); end if; declare K : constant TCKind := Kind (Get_Unwound_Type (Self.Value)); begin if K = Tk_Octet then Set_Any_Value (PolyORB.Types.Octet (Value), Get_Container (Self.Value).all); elsif not Is_Ordinary_Aggregate (K) then Helper.Raise_TypeMismatch ((CORBA.IDL_Exception_Members with null record)); elsif Self.Current = -1 then Helper.Raise_InvalidValue ((CORBA.IDL_Exception_Members with null record)); else declare Element : constant PolyORB.Any.Any := Get_Aggregate_Element (Self.Value, TypeCode.TC_Octet, Unsigned_Long (Self.Current)); begin if Kind (Get_Unwound_Type (Element)) = Tk_Octet then Set_Any_Value (PolyORB.Types.Octet (Value), Get_Container (Element).all); else Helper.Raise_TypeMismatch ((CORBA.IDL_Exception_Members with null record)); end if; end; end if; end; end Insert_Octet; ---------------------- -- Insert_Octet_Seq -- ---------------------- procedure Insert_Octet_Seq (Self : access Object; Value : CORBA.IDL_SEQUENCES.OctetSeq) is pragma Unreferenced (Value); begin if Is_Destroyed (Self) then CORBA.Raise_Object_Not_Exist (CORBA.Default_Sys_Member); end if; raise Program_Error; end Insert_Octet_Seq; ---------------------- -- Insert_Reference -- ---------------------- procedure Insert_Reference (Self : access Object; Value : CORBA.Object.Ref) is pragma Unreferenced (Value); begin if Is_Destroyed (Self) then CORBA.Raise_Object_Not_Exist (CORBA.Default_Sys_Member); end if; raise Program_Error; end Insert_Reference; ------------------- -- Insert_Short -- ------------------- procedure Insert_Short (Self : access Object; Value : CORBA.Short) is begin if Is_Destroyed (Self) then CORBA.Raise_Object_Not_Exist (CORBA.Default_Sys_Member); end if; declare K : constant TCKind := Kind (Get_Unwound_Type (Self.Value)); begin if K = Tk_Short then Set_Any_Value (PolyORB.Types.Short (Value), Get_Container (Self.Value).all); elsif not Is_Ordinary_Aggregate (K) then Helper.Raise_TypeMismatch ((CORBA.IDL_Exception_Members with null record)); elsif Self.Current = -1 then Helper.Raise_InvalidValue ((CORBA.IDL_Exception_Members with null record)); else declare Element : constant PolyORB.Any.Any := Get_Aggregate_Element (Self.Value, TypeCode.TC_Short, Unsigned_Long (Self.Current)); begin if Kind (Get_Unwound_Type (Element)) = Tk_Short then Set_Any_Value (PolyORB.Types.Short (Value), Get_Container (Element).all); else Helper.Raise_TypeMismatch ((CORBA.IDL_Exception_Members with null record)); end if; end; end if; end; end Insert_Short; ---------------------- -- Insert_Short_Seq -- ---------------------- procedure Insert_Short_Seq (Self : access Object; Value : CORBA.IDL_SEQUENCES.ShortSeq) is pragma Unreferenced (Value); begin if Is_Destroyed (Self) then CORBA.Raise_Object_Not_Exist (CORBA.Default_Sys_Member); end if; raise Program_Error; end Insert_Short_Seq; ------------------- -- Insert_String -- ------------------- procedure Insert_String (Self : access Object; Value : CORBA.String) is begin if Is_Destroyed (Self) then CORBA.Raise_Object_Not_Exist (CORBA.Default_Sys_Member); end if; declare K : constant TCKind := Kind (Get_Unwound_Type (Self.Value)); begin if K = Tk_String then Set_Any_Value (PolyORB.Types.String (Value), Get_Container (Self.Value).all); elsif not Is_Ordinary_Aggregate (K) then Helper.Raise_TypeMismatch ((CORBA.IDL_Exception_Members with null record)); elsif Self.Current = -1 then Helper.Raise_InvalidValue ((CORBA.IDL_Exception_Members with null record)); else declare Element : constant PolyORB.Any.Any := Get_Aggregate_Element (Self.Value, TypeCode.TC_String, Unsigned_Long (Self.Current)); begin if Kind (Get_Unwound_Type (Element)) = Tk_String then Set_Any_Value (PolyORB.Types.String (Value), Get_Container (Element).all); else Helper.Raise_TypeMismatch ((CORBA.IDL_Exception_Members with null record)); end if; end; end if; end; end Insert_String; --------------------- -- Insert_Typecode -- --------------------- procedure Insert_TypeCode (Self : access Object; Value : CORBA.TypeCode.Object) is begin if Is_Destroyed (Self) then CORBA.Raise_Object_Not_Exist (CORBA.Default_Sys_Member); end if; declare K : constant TCKind := Kind (Get_Unwound_Type (Self.Value)); begin if K = Tk_TypeCode then Set_Any_Value (CORBA.TypeCode.Internals.To_PolyORB_Object (Value), Get_Container (Self.Value).all); elsif not Is_Ordinary_Aggregate (K) then Helper.Raise_TypeMismatch ((CORBA.IDL_Exception_Members with null record)); elsif Self.Current = -1 then Helper.Raise_InvalidValue ((CORBA.IDL_Exception_Members with null record)); else declare Element : constant PolyORB.Any.Any := Get_Aggregate_Element (Self.Value, TypeCode.TC_TypeCode, Unsigned_Long (Self.Current)); begin if Kind (Get_Unwound_Type (Element)) = Tk_TypeCode then Set_Any_Value (CORBA.TypeCode.Internals.To_PolyORB_Object (Value), Get_Container (Element).all); else Helper.Raise_TypeMismatch ((CORBA.IDL_Exception_Members with null record)); end if; end; end if; end; end Insert_TypeCode; ------------------- -- Insert_ULong -- ------------------- procedure Insert_ULong (Self : access Object; Value : CORBA.Unsigned_Long) is begin if Is_Destroyed (Self) then CORBA.Raise_Object_Not_Exist (CORBA.Default_Sys_Member); end if; declare K : constant TCKind := Kind (Get_Unwound_Type (Self.Value)); begin if K = Tk_Ulong then Set_Any_Value (PolyORB.Types.Unsigned_Long (Value), Get_Container (Self.Value).all); elsif not Is_Ordinary_Aggregate (K) then Helper.Raise_TypeMismatch ((CORBA.IDL_Exception_Members with null record)); elsif Self.Current = -1 then Helper.Raise_InvalidValue ((CORBA.IDL_Exception_Members with null record)); else declare Element : constant PolyORB.Any.Any := Get_Aggregate_Element (Self.Value, TypeCode.TC_Unsigned_Long, Unsigned_Long (Self.Current)); begin if Kind (Get_Unwound_Type (Element)) = Tk_Ulong then Set_Any_Value (PolyORB.Types.Unsigned_Long (Value), Get_Container (Element).all); else Helper.Raise_TypeMismatch ((CORBA.IDL_Exception_Members with null record)); end if; end; end if; end; end Insert_ULong; ---------------------- -- Insert_ULong_Seq -- ---------------------- procedure Insert_ULong_Seq (Self : access Object; Value : CORBA.IDL_SEQUENCES.ULongSeq) is pragma Unreferenced (Value); begin if Is_Destroyed (Self) then CORBA.Raise_Object_Not_Exist (CORBA.Default_Sys_Member); end if; raise Program_Error; end Insert_ULong_Seq; ---------------------- -- Insert_ULongLong -- ---------------------- procedure Insert_ULongLong (Self : access Object; Value : CORBA.Unsigned_Long_Long) is begin if Is_Destroyed (Self) then CORBA.Raise_Object_Not_Exist (CORBA.Default_Sys_Member); end if; declare K : constant TCKind := Kind (Get_Unwound_Type (Self.Value)); begin if K = Tk_Ulonglong then Set_Any_Value (PolyORB.Types.Unsigned_Long_Long (Value), Get_Container (Self.Value).all); elsif not Is_Ordinary_Aggregate (K) then Helper.Raise_TypeMismatch ((CORBA.IDL_Exception_Members with null record)); elsif Self.Current = -1 then Helper.Raise_InvalidValue ((CORBA.IDL_Exception_Members with null record)); else declare Element : constant PolyORB.Any.Any := Get_Aggregate_Element (Self.Value, TypeCode.TC_Unsigned_Long_Long, Unsigned_Long (Self.Current)); begin if Kind (Get_Unwound_Type (Element)) = Tk_Ulonglong then Set_Any_Value (PolyORB.Types.Unsigned_Long_Long (Value), Get_Container (Element).all); else Helper.Raise_TypeMismatch ((CORBA.IDL_Exception_Members with null record)); end if; end; end if; end; end Insert_ULongLong; -------------------------- -- Insert_ULongLong_Seq -- -------------------------- procedure Insert_ULongLong_Seq (Self : access Object; Value : CORBA.IDL_SEQUENCES.ULongLongSeq) is pragma Unreferenced (Value); begin if Is_Destroyed (Self) then CORBA.Raise_Object_Not_Exist (CORBA.Default_Sys_Member); end if; raise Program_Error; end Insert_ULongLong_Seq; -------------------- -- Insert_UShort -- -------------------- procedure Insert_UShort (Self : access Object; Value : CORBA.Unsigned_Short) is begin if Is_Destroyed (Self) then CORBA.Raise_Object_Not_Exist (CORBA.Default_Sys_Member); end if; declare K : constant TCKind := Kind (Get_Unwound_Type (Self.Value)); begin if K = Tk_Ushort then Set_Any_Value (PolyORB.Types.Unsigned_Short (Value), Get_Container (Self.Value).all); elsif not Is_Ordinary_Aggregate (K) then Helper.Raise_TypeMismatch ((CORBA.IDL_Exception_Members with null record)); elsif Self.Current = -1 then Helper.Raise_InvalidValue ((CORBA.IDL_Exception_Members with null record)); else declare Element : constant PolyORB.Any.Any := Get_Aggregate_Element (Self.Value, TypeCode.TC_Unsigned_Short, Unsigned_Long (Self.Current)); begin if Kind (Get_Unwound_Type (Element)) = Tk_Ushort then Set_Any_Value (PolyORB.Types.Unsigned_Short (Value), Get_Container (Element).all); else Helper.Raise_TypeMismatch ((CORBA.IDL_Exception_Members with null record)); end if; end; end if; end; end Insert_UShort; ----------------------- -- Insert_UShort_Seq -- ----------------------- procedure Insert_UShort_Seq (Self : access Object; Value : CORBA.IDL_SEQUENCES.UShortSeq) is pragma Unreferenced (Value); begin if Is_Destroyed (Self) then CORBA.Raise_Object_Not_Exist (CORBA.Default_Sys_Member); end if; raise Program_Error; end Insert_UShort_Seq; ------------------ -- Insert_WChar -- ------------------ procedure Insert_WChar (Self : access Object; Value : CORBA.Wchar) is begin if Is_Destroyed (Self) then CORBA.Raise_Object_Not_Exist (CORBA.Default_Sys_Member); end if; declare K : constant TCKind := Kind (Get_Unwound_Type (Self.Value)); begin if K = Tk_Widechar then Set_Any_Value (Value, Get_Container (Self.Value).all); elsif not Is_Ordinary_Aggregate (K) then Helper.Raise_TypeMismatch ((CORBA.IDL_Exception_Members with null record)); elsif Self.Current = -1 then Helper.Raise_InvalidValue ((CORBA.IDL_Exception_Members with null record)); else declare Element : constant PolyORB.Any.Any := Get_Aggregate_Element (Self.Value, TypeCode.TC_Wchar, Unsigned_Long (Self.Current)); begin if Kind (Get_Unwound_Type (Element)) = Tk_Widechar then Set_Any_Value (Value, Get_Container (Element).all); else Helper.Raise_TypeMismatch ((CORBA.IDL_Exception_Members with null record)); end if; end; end if; end; end Insert_WChar; ---------------------- -- Insert_WChar_Seq -- ---------------------- procedure Insert_WChar_Seq (Self : access Object; Value : CORBA.IDL_SEQUENCES.WCharSeq) is pragma Unreferenced (Value); begin if Is_Destroyed (Self) then CORBA.Raise_Object_Not_Exist (CORBA.Default_Sys_Member); end if; raise Program_Error; end Insert_WChar_Seq; -------------------- -- Insert_WString -- -------------------- procedure Insert_WString (Self : access Object; Value : CORBA.Wide_String) is begin if Is_Destroyed (Self) then CORBA.Raise_Object_Not_Exist (CORBA.Default_Sys_Member); end if; declare K : constant TCKind := Kind (Get_Unwound_Type (Self.Value)); begin if K = Tk_Wstring then Set_Any_Value (PolyORB.Types.Wide_String (Value), Get_Container (Self.Value).all); elsif not Is_Ordinary_Aggregate (K) then Helper.Raise_TypeMismatch ((CORBA.IDL_Exception_Members with null record)); elsif Self.Current = -1 then Helper.Raise_InvalidValue ((CORBA.IDL_Exception_Members with null record)); else declare Element : constant PolyORB.Any.Any := Get_Aggregate_Element (Self.Value, TypeCode.TC_Wide_String, Unsigned_Long (Self.Current)); begin if Kind (Get_Unwound_Type (Element)) = Tk_Wstring then Set_Any_Value (PolyORB.Types.Wide_String (Value), Get_Container (Element).all); else Helper.Raise_TypeMismatch ((CORBA.IDL_Exception_Members with null record)); end if; end; end if; end; end Insert_WString; --------------- -- Internals -- --------------- package body Internals is ------------ -- Create -- ------------ function Create (Value : CORBA.Any; Parent : DynAny.Impl.Object_Ptr) return Local_Ref is Obj : constant Object_Ptr := new Object; Result : Local_Ref; begin Initialize (Obj, PolyORB.Any.Any (Value), Parent); Set (Result, PolyORB.Smart_Pointers.Entity_Ptr (Obj)); return Result; end Create; function Create (Value : PolyORB.Any.TypeCode.Local_Ref) return DynAny.Local_Ref is Obj : constant Object_Ptr := new Object; Result : Local_Ref; begin Initialize (Obj, Value); Set (Result, PolyORB.Smart_Pointers.Entity_Ptr (Obj)); return Result; end Create; --------------- -- Get_Value -- --------------- function Get_Value (Self : access Object'Class) return CORBA.Any is begin return CORBA.Any (Self.Value); end Get_Value; ---------------- -- Initialize -- ---------------- procedure Initialize (Self : access Object'Class; IDL_Type : PolyORB.Any.TypeCode.Local_Ref) is pragma Unreferenced (Self); pragma Unreferenced (IDL_Type); begin raise Program_Error; end Initialize; procedure Initialize (Self : access Object'Class; Value : PolyORB.Any.Any; Parent : Object_Ptr) is begin -- Copy Any value for top level object and store value otherwise if Parent = null then Self.Value := Get_Empty_Any (Get_Type (Value)); Copy_Any_Value (Self.Value, Value); else Self.Value := Value; end if; -- Reset current position Reset_Current_Position (Self); -- Set up parent Self.Parent := Parent; end Initialize; ------------------ -- Is_Destroyed -- ------------------ function Is_Destroyed (Self : access Object'Class) return Boolean is begin return Self.Is_Destroyed; end Is_Destroyed; end Internals; ---------- -- Is_A -- ---------- function Is_A (Self : not null access Object; Logical_Type_Id : Standard.String) return Boolean is pragma Unreferenced (Self); begin return CORBA.Is_Equivalent (Logical_Type_Id, DynamicAny.DynAny.Repository_Id) or else CORBA.Is_Equivalent (Logical_Type_Id, "IDL:omg.org/CORBA/Object:1.0"); end Is_A; --------------------------- -- Is_Ordinary_Aggregate -- --------------------------- function Is_Ordinary_Aggregate (Kind : TCKind) return Boolean is begin case Kind is when Tk_Struct | Tk_Union | Tk_Sequence | Tk_Array | Tk_Except | Tk_Value => return True; when others => return False; end case; end Is_Ordinary_Aggregate; -------------------- -- Mark_Destroyed -- -------------------- procedure Mark_Destroyed (Self : access Object) is use Local_Ref_Lists; Iter : Iterator := First (Self.Children); begin Self.Is_Destroyed := True; while not Last (Iter) loop Mark_Destroyed (Object_Ptr (Entity_Of (Value (Iter).all))); Next (Iter); end loop; end Mark_Destroyed; ---------- -- Next -- ---------- function Next (Self : access Object) return CORBA.Boolean is begin if Is_Destroyed (Self) then CORBA.Raise_Object_Not_Exist (CORBA.Default_Sys_Member); end if; return Seek (Self, Self.Current + 1); end Next; ---------------------------- -- Reset_Current_Position -- ---------------------------- procedure Reset_Current_Position (Self : access Object'Class) is begin if Is_Ordinary_Aggregate (Kind (Get_Unwound_Type (Self.Value))) and then Get_Aggregate_Count (Self.Value) /= 0 then Self.Current := 0; else Self.Current := -1; end if; end Reset_Current_Position; ------------ -- Rewind -- ------------ procedure Rewind (Self : access Object) is Aux : Boolean; pragma Unreferenced (Aux); -- This variable used for temporary store return value of Seek -- operation. CORBA specification don't describe any exception -- for situation of Seek fault, so this value newer used. begin if Is_Destroyed (Self) then CORBA.Raise_Object_Not_Exist (CORBA.Default_Sys_Member); end if; Aux := Seek (Self, 0); end Rewind; ---------- -- Seek -- ---------- function Seek (Self : access Object; Index : CORBA.Long) return CORBA.Boolean is begin if Is_Destroyed (Self) then CORBA.Raise_Object_Not_Exist (CORBA.Default_Sys_Member); end if; case Kind (Get_Unwound_Type (Self.Value)) is when Tk_Struct | Tk_Except | Tk_Sequence | Tk_Array | Tk_Value | Tk_Union => if Index in 0 .. CORBA.Long (Get_Aggregate_Count (Self.Value) - 1) then Self.Current := Index; return True; else Self.Current := -1; return False; end if; when others => return False; end case; end Seek; ------------- -- To_Any -- ------------- function To_Any (Self : access Object) return CORBA.Any is Result : CORBA.Any; C_Value : constant CORBA.Any := CORBA.Any (Self.Value); begin if Is_Destroyed (Self) then CORBA.Raise_Object_Not_Exist (CORBA.Default_Sys_Member); end if; Result := CORBA.Get_Empty_Any (CORBA.Get_Type (C_Value)); CORBA.Copy_Any_Value (Result, C_Value); return Result; end To_Any; end DynamicAny.DynAny.Impl; polyorb-2.8~20110207.orig/src/corba/dynamicany/polyorb-corba_p-dynamic_any.ads0000644000175000017500000000504311750740340026470 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . C O R B A _ P . D Y N A M I C _ A N Y -- -- -- -- S p e c -- -- -- -- Copyright (C) 2005-2007, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with CORBA; with DynamicAny.DynAny.Impl; package PolyORB.CORBA_P.Dynamic_Any is function Create (Value : CORBA.Any; Allow_Truncate : Boolean; Parent : DynamicAny.DynAny.Impl.Object_Ptr) return DynamicAny.DynAny.Local_Ref; -- Create new DynAny object and initialize it to specified value function Create (IDL_Type : CORBA.TypeCode.Object) return DynamicAny.DynAny.Local_Ref; -- Create new DynAny object and initialize it to default value end PolyORB.CORBA_P.Dynamic_Any; polyorb-2.8~20110207.orig/src/corba/dynamicany/dynamicany-dynstruct-impl.adb0000644000175000017500000001531011750740340026213 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- D Y N A M I C A N Y . D Y N S T R U C T . I M P L -- -- -- -- B o d y -- -- -- -- Copyright (C) 2005-2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with PolyORB.Smart_Pointers; package body DynamicAny.DynStruct.Impl is use PolyORB.Any; use PolyORB.Any.TypeCode; function Is_Destroyed (Self : access DynAny.Impl.Object'Class) return Boolean renames DynAny.Impl.Internals.Is_Destroyed; ------------------------- -- Current_Member_Kind -- ------------------------- function Current_Member_Kind (Self : access Object) return CORBA.TCKind is begin if Is_Destroyed (Self) then CORBA.Raise_Object_Not_Exist (CORBA.Default_Sys_Member); end if; raise Program_Error; return CORBA.Tk_Void; end Current_Member_Kind; ------------------------- -- Current_Member_Name -- ------------------------- function Current_Member_Name (Self : access Object) return FieldName is Result : FieldName; begin if Is_Destroyed (Self) then CORBA.Raise_Object_Not_Exist (CORBA.Default_Sys_Member); end if; raise Program_Error; return Result; end Current_Member_Name; ----------------- -- Get_Members -- ----------------- function Get_Members (Self : access Object) return NameValuePairSeq is Result : NameValuePairSeq; begin if Is_Destroyed (Self) then CORBA.Raise_Object_Not_Exist (CORBA.Default_Sys_Member); end if; raise Program_Error; return Result; end Get_Members; ---------------------------- -- Get_Members_As_Dyn_Any -- ---------------------------- function Get_Members_As_Dyn_Any (Self : access Object) return NameDynAnyPairSeq is Result : NameDynAnyPairSeq; begin if Is_Destroyed (Self) then CORBA.Raise_Object_Not_Exist (CORBA.Default_Sys_Member); end if; raise Program_Error; return Result; end Get_Members_As_Dyn_Any; --------------- -- Internals -- --------------- package body Internals is ------------ -- Create -- ------------ function Create (Value : CORBA.Any; Parent : DynAny.Impl.Object_Ptr) return DynAny.Local_Ref is Obj : constant Object_Ptr := new Object; Result : DynAny.Local_Ref; begin pragma Assert (Kind (CORBA.Get_Type (Value)) = Tk_Struct); Initialize (Obj, PolyORB.Any.Any (Value), Parent); DynAny.Set (Result, PolyORB.Smart_Pointers.Entity_Ptr (Obj)); return Result; end Create; function Create (Value : PolyORB.Any.TypeCode.Local_Ref) return DynAny.Local_Ref is Obj : constant Object_Ptr := new Object; Result : DynAny.Local_Ref; begin pragma Assert (Kind (Value) = Tk_Array); Initialize (Obj, Value); DynAny.Set (Result, PolyORB.Smart_Pointers.Entity_Ptr (Obj)); return Result; end Create; ---------------- -- Initialize -- ---------------- procedure Initialize (Self : access Object'Class; IDL_Type : PolyORB.Any.TypeCode.Local_Ref) is begin DynAny.Impl.Internals.Initialize (Self, IDL_Type); end Initialize; procedure Initialize (Self : access Object'Class; Value : PolyORB.Any.Any; Parent : DynAny.Impl.Object_Ptr) is begin DynAny.Impl.Internals.Initialize (Self, Value, Parent); end Initialize; end Internals; ---------- -- Is_A -- ---------- function Is_A (Self : not null access Object; Logical_Type_Id : Standard.String) return Boolean is pragma Unreferenced (Self); begin return CORBA.Is_Equivalent (Logical_Type_Id, DynamicAny.DynStruct.Repository_Id) or else CORBA.Is_Equivalent (Logical_Type_Id, DynamicAny.DynAny.Repository_Id) or else CORBA.Is_Equivalent (Logical_Type_Id, "IDL:omg.org/CORBA/Object:1.0"); end Is_A; ----------------- -- Set_Members -- ----------------- procedure Set_Members (Self : access Object; Value : NameValuePairSeq) is pragma Unreferenced (Value); begin if Is_Destroyed (Self) then CORBA.Raise_Object_Not_Exist (CORBA.Default_Sys_Member); end if; raise Program_Error; end Set_Members; ---------------------------- -- Set_Members_As_Dyn_Any -- ---------------------------- procedure Set_Members_As_Dyn_Any (Self : access Object; Value : NameDynAnyPairSeq) is pragma Unreferenced (Value); begin if Is_Destroyed (Self) then CORBA.Raise_Object_Not_Exist (CORBA.Default_Sys_Member); end if; raise Program_Error; end Set_Members_As_Dyn_Any; end DynamicAny.DynStruct.Impl; polyorb-2.8~20110207.orig/src/corba/dynamicany/dynamicany-dynvaluecommon-impl.ads0000644000175000017500000000567011750740340027245 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- D Y N A M I C A N Y . D Y N V A L U E C O M M O N . I M P L -- -- -- -- S p e c -- -- -- -- Copyright (C) 2005-2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with PolyORB.Any; with DynamicAny.DynAny.Impl; package DynamicAny.DynValueCommon.Impl is type Object is new DynamicAny.DynAny.Impl.Object with private; type Object_Ptr is access all Object'Class; function Is_Null (Self : access Object) return CORBA.Boolean; procedure Set_To_Null (Self : access Object); procedure Set_To_Value (Self : access Object); function Is_A (Self : not null access Object; Logical_Type_Id : Standard.String) return Boolean; package Internals is procedure Initialize (Self : access Object'Class; Value : PolyORB.Any.Any; Parent : DynAny.Impl.Object_Ptr); procedure Initialize (Self : access Object'Class; IDL_Type : PolyORB.Any.TypeCode.Local_Ref); end Internals; private type Object is new DynamicAny.DynAny.Impl.Object with record null; end record; end DynamicAny.DynValueCommon.Impl; polyorb-2.8~20110207.orig/src/corba/dynamicany/dynamicany-dynsequence-impl.adb0000644000175000017500000001513411750740340026503 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- D Y N A M I C A N Y . D Y N S E Q U E N C E . I M P L -- -- -- -- B o d y -- -- -- -- Copyright (C) 2005-2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with PolyORB.Smart_Pointers; package body DynamicAny.DynSequence.Impl is use PolyORB.Any; use PolyORB.Any.TypeCode; function Is_Destroyed (Self : access DynAny.Impl.Object'Class) return Boolean renames DynAny.Impl.Internals.Is_Destroyed; ------------------ -- Get_Elements -- ------------------ function Get_Elements (Self : access Object) return AnySeq is Result : DynamicAny.AnySeq; begin if Is_Destroyed (Self) then CORBA.Raise_Object_Not_Exist (CORBA.Default_Sys_Member); end if; raise Program_Error; return Result; end Get_Elements; ----------------------------- -- Get_Elements_As_Dyn_Any -- ----------------------------- function Get_Elements_As_Dyn_Any (Self : access Object) return DynAnySeq is Result : DynamicAny.DynAnySeq; begin if Is_Destroyed (Self) then CORBA.Raise_Object_Not_Exist (CORBA.Default_Sys_Member); end if; raise Program_Error; return Result; end Get_Elements_As_Dyn_Any; ---------------- -- Get_Length -- ---------------- function Get_Length (Self : access Object) return CORBA.Unsigned_Long is begin if Is_Destroyed (Self) then CORBA.Raise_Object_Not_Exist (CORBA.Default_Sys_Member); end if; raise Program_Error; return 0; end Get_Length; --------------- -- Internals -- --------------- package body Internals is ------------ -- Create -- ------------ function Create (Value : CORBA.Any; Parent : DynAny.Impl.Object_Ptr) return DynAny.Local_Ref is Obj : constant Object_Ptr := new Object; Result : DynAny.Local_Ref; begin pragma Assert (Kind (CORBA.Get_Type (Value)) = Tk_Sequence); Initialize (Obj, PolyORB.Any.Any (Value), Parent); DynAny.Set (Result, PolyORB.Smart_Pointers.Entity_Ptr (Obj)); return Result; end Create; function Create (Value : PolyORB.Any.TypeCode.Local_Ref) return DynAny.Local_Ref is Obj : constant Object_Ptr := new Object; Result : DynAny.Local_Ref; begin pragma Assert (Kind (Value) = Tk_Array); Initialize (Obj, Value); DynAny.Set (Result, PolyORB.Smart_Pointers.Entity_Ptr (Obj)); return Result; end Create; ---------------- -- Initialize -- ---------------- procedure Initialize (Self : access Object'Class; IDL_Type : PolyORB.Any.TypeCode.Local_Ref) is begin DynAny.Impl.Internals.Initialize (Self, IDL_Type); end Initialize; procedure Initialize (Self : access Object'Class; Value : PolyORB.Any.Any; Parent : DynAny.Impl.Object_Ptr) is begin DynAny.Impl.Internals.Initialize (Self, Value, Parent); end Initialize; end Internals; ---------- -- Is_A -- ---------- function Is_A (Self : not null access Object; Logical_Type_Id : Standard.String) return Boolean is pragma Unreferenced (Self); begin return CORBA.Is_Equivalent (Logical_Type_Id, DynamicAny.DynSequence.Repository_Id) or else CORBA.Is_Equivalent (Logical_Type_Id, DynamicAny.DynAny.Repository_Id) or else CORBA.Is_Equivalent (Logical_Type_Id, "IDL:omg.org/CORBA/Object:1.0"); end Is_A; ------------------ -- Set_Elements -- ------------------ procedure Set_Elements (Self : access Object; Value : AnySeq) is pragma Unreferenced (Value); begin if Is_Destroyed (Self) then CORBA.Raise_Object_Not_Exist (CORBA.Default_Sys_Member); end if; raise Program_Error; end Set_Elements; ----------------------------- -- Set_Elements_As_Dyn_Any -- ----------------------------- procedure Set_Elements_As_Dyn_Any (Self : access Object; Value : DynAnySeq) is pragma Unreferenced (Value); begin if Is_Destroyed (Self) then CORBA.Raise_Object_Not_Exist (CORBA.Default_Sys_Member); end if; raise Program_Error; end Set_Elements_As_Dyn_Any; ---------------- -- Set_Length -- ---------------- procedure Set_Length (Self : access Object; Len : CORBA.Unsigned_Long) is pragma Unreferenced (Len); begin if Is_Destroyed (Self) then CORBA.Raise_Object_Not_Exist (CORBA.Default_Sys_Member); end if; raise Program_Error; end Set_Length; end DynamicAny.DynSequence.Impl; polyorb-2.8~20110207.orig/src/corba/dynamicany/dynamicany-dynarray-impl.adb0000644000175000017500000001364411750740340026015 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- D Y N A M I C A N Y . D Y N A R R A Y . I M P L -- -- -- -- B o d y -- -- -- -- Copyright (C) 2005-2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with PolyORB.Smart_Pointers; package body DynamicAny.DynArray.Impl is use PolyORB.Any; use PolyORB.Any.TypeCode; function Is_Destroyed (Self : access DynAny.Impl.Object'Class) return Boolean renames DynAny.Impl.Internals.Is_Destroyed; ------------------ -- Get_Elements -- ------------------ function Get_Elements (Self : access Object) return AnySeq is Result : DynamicAny.AnySeq; begin if Is_Destroyed (Self) then CORBA.Raise_Object_Not_Exist (CORBA.Default_Sys_Member); end if; raise Program_Error; return Result; end Get_Elements; ----------------------------- -- Get_Elements_As_Dyn_Any -- ----------------------------- function Get_Elements_As_Dyn_Any (Self : access Object) return DynAnySeq is Result : DynamicAny.DynAnySeq; begin if Is_Destroyed (Self) then CORBA.Raise_Object_Not_Exist (CORBA.Default_Sys_Member); end if; raise Program_Error; return Result; end Get_Elements_As_Dyn_Any; --------------- -- Internals -- --------------- package body Internals is ------------ -- Create -- ------------ function Create (Value : CORBA.Any; Parent : DynAny.Impl.Object_Ptr) return DynAny.Local_Ref is Obj : constant Object_Ptr := new Object; Result : DynAny.Local_Ref; begin pragma Assert (Kind (CORBA.Get_Type (Value)) = Tk_Array); Initialize (Obj, PolyORB.Any.Any (Value), Parent); DynAny.Set (Result, PolyORB.Smart_Pointers.Entity_Ptr (Obj)); return Result; end Create; function Create (Value : PolyORB.Any.TypeCode.Local_Ref) return DynAny.Local_Ref is Obj : constant Object_Ptr := new Object; Result : DynAny.Local_Ref; begin pragma Assert (Kind (Value) = Tk_Array); Initialize (Obj, Value); DynAny.Set (Result, PolyORB.Smart_Pointers.Entity_Ptr (Obj)); return Result; end Create; ---------------- -- Initialize -- ---------------- procedure Initialize (Self : access Object'Class; IDL_Type : PolyORB.Any.TypeCode.Local_Ref) is begin DynAny.Impl.Internals.Initialize (Self, IDL_Type); end Initialize; procedure Initialize (Self : access Object'Class; Value : PolyORB.Any.Any; Parent : DynAny.Impl.Object_Ptr) is begin DynAny.Impl.Internals.Initialize (Self, Value, Parent); end Initialize; end Internals; ---------- -- Is_A -- ---------- function Is_A (Self : not null access Object; Logical_Type_Id : Standard.String) return Boolean is pragma Unreferenced (Self); begin return CORBA.Is_Equivalent (Logical_Type_Id, DynamicAny.DynArray.Repository_Id) or else CORBA.Is_Equivalent (Logical_Type_Id, DynamicAny.DynAny.Repository_Id) or else CORBA.Is_Equivalent (Logical_Type_Id, "IDL:omg.org/CORBA/Object:1.0"); end Is_A; ------------------ -- Set_Elements -- ------------------ procedure Set_Elements (Self : access Object; Value : AnySeq) is pragma Unreferenced (Value); begin if Is_Destroyed (Self) then CORBA.Raise_Object_Not_Exist (CORBA.Default_Sys_Member); end if; raise Program_Error; end Set_Elements; ----------------------------- -- Set_Elements_As_Dyn_Any -- ----------------------------- procedure Set_Elements_As_Dyn_Any (Self : access Object; Value : DynAnySeq) is pragma Unreferenced (Value); begin if Is_Destroyed (Self) then CORBA.Raise_Object_Not_Exist (CORBA.Default_Sys_Member); end if; raise Program_Error; end Set_Elements_As_Dyn_Any; end DynamicAny.DynArray.Impl; polyorb-2.8~20110207.orig/src/corba/dynamicany/dynamicany-dynunion-impl.adb0000644000175000017500000001710611750740340026024 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- D Y N A M I C A N Y . D Y N U N I O N . I M P L -- -- -- -- B o d y -- -- -- -- Copyright (C) 2005-2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with PolyORB.Smart_Pointers; package body DynamicAny.DynUnion.Impl is use PolyORB.Any; use PolyORB.Any.TypeCode; function Is_Destroyed (Self : access DynAny.Impl.Object'Class) return Boolean renames DynAny.Impl.Internals.Is_Destroyed; ------------------------ -- Discriminator_Kind -- ------------------------ function Discriminator_Kind (Self : access Object) return CORBA.TCKind is begin if Is_Destroyed (Self) then CORBA.Raise_Object_Not_Exist (CORBA.Default_Sys_Member); end if; raise Program_Error; return CORBA.Tk_Void; end Discriminator_Kind; ----------------------- -- Get_Discriminator -- ----------------------- function Get_Discriminator (Self : access Object) return DynAny.Local_Ref is Result : DynAny.Local_Ref; begin if Is_Destroyed (Self) then CORBA.Raise_Object_Not_Exist (CORBA.Default_Sys_Member); end if; raise Program_Error; return Result; end Get_Discriminator; -------------------------- -- Has_No_Active_Member -- -------------------------- function Has_No_Active_Member (Self : access Object) return CORBA.Boolean is begin if Is_Destroyed (Self) then CORBA.Raise_Object_Not_Exist (CORBA.Default_Sys_Member); end if; raise Program_Error; return False; end Has_No_Active_Member; --------------- -- Internals -- --------------- package body Internals is ------------ -- Create -- ------------ function Create (Value : CORBA.Any; Parent : DynAny.Impl.Object_Ptr) return DynAny.Local_Ref is Obj : constant Object_Ptr := new Object; Result : DynAny.Local_Ref; begin pragma Assert (Kind (CORBA.Get_Type (Value)) = Tk_Union); Initialize (Obj, PolyORB.Any.Any (Value), Parent); DynAny.Set (Result, PolyORB.Smart_Pointers.Entity_Ptr (Obj)); return Result; end Create; function Create (Value : PolyORB.Any.TypeCode.Local_Ref) return DynAny.Local_Ref is Obj : constant Object_Ptr := new Object; Result : DynAny.Local_Ref; begin pragma Assert (Kind (Value) = Tk_Array); Initialize (Obj, Value); DynAny.Set (Result, PolyORB.Smart_Pointers.Entity_Ptr (Obj)); return Result; end Create; ---------------- -- Initialize -- ---------------- procedure Initialize (Self : access Object'Class; IDL_Type : PolyORB.Any.TypeCode.Local_Ref) is begin DynAny.Impl.Internals.Initialize (Self, IDL_Type); end Initialize; procedure Initialize (Self : access Object'Class; Value : PolyORB.Any.Any; Parent : DynAny.Impl.Object_Ptr) is begin DynAny.Impl.Internals.Initialize (Self, Value, Parent); end Initialize; end Internals; ---------- -- Is_A -- ---------- function Is_A (Self : not null access Object; Logical_Type_Id : Standard.String) return Boolean is pragma Unreferenced (Self); begin return CORBA.Is_Equivalent (Logical_Type_Id, DynamicAny.DynUnion.Repository_Id) or else CORBA.Is_Equivalent (Logical_Type_Id, DynamicAny.DynAny.Repository_Id) or else CORBA.Is_Equivalent (Logical_Type_Id, "IDL:omg.org/CORBA/Object:1.0"); end Is_A; ------------ -- Member -- ------------ function Member (Self : access Object) return DynAny.Local_Ref is Result : DynamicAny.DynAny.Local_Ref; begin if Is_Destroyed (Self) then CORBA.Raise_Object_Not_Exist (CORBA.Default_Sys_Member); end if; raise Program_Error; return Result; end Member; ----------------- -- Member_Kind -- ----------------- function Member_Kind (Self : access Object) return CORBA.TCKind is begin if Is_Destroyed (Self) then CORBA.Raise_Object_Not_Exist (CORBA.Default_Sys_Member); end if; raise Program_Error; return CORBA.Tk_Void; end Member_Kind; ----------------- -- Member_Name -- ----------------- function Member_Name (Self : access Object) return FieldName is Result : DynamicAny.FieldName; begin if Is_Destroyed (Self) then CORBA.Raise_Object_Not_Exist (CORBA.Default_Sys_Member); end if; raise Program_Error; return Result; end Member_Name; ----------------------- -- Set_Discriminator -- ----------------------- procedure Set_Discriminator (Self : access Object; D : DynAny.Local_Ref) is pragma Unreferenced (D); begin if Is_Destroyed (Self) then CORBA.Raise_Object_Not_Exist (CORBA.Default_Sys_Member); end if; raise Program_Error; end Set_Discriminator; --------------------------- -- Set_To_Default_Member -- --------------------------- procedure Set_To_Default_Member (Self : access Object) is begin if Is_Destroyed (Self) then CORBA.Raise_Object_Not_Exist (CORBA.Default_Sys_Member); end if; raise Program_Error; end Set_To_Default_Member; ----------------------------- -- Set_To_No_Active_Member -- ----------------------------- procedure Set_To_No_Active_Member (Self : access Object) is begin if Is_Destroyed (Self) then CORBA.Raise_Object_Not_Exist (CORBA.Default_Sys_Member); end if; raise Program_Error; end Set_To_No_Active_Member; end DynamicAny.DynUnion.Impl; polyorb-2.8~20110207.orig/src/corba/dynamicany/dynamicany-dynvalue-impl.adb0000644000175000017500000001706111750740340026010 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- D Y N A M I C A N Y . D Y N V A L U E . I M P L -- -- -- -- B o d y -- -- -- -- Copyright (C) 2005-2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with PolyORB.Smart_Pointers; with DynamicAny.DynAny; with DynamicAny.DynValueCommon; with PolyORB.CORBA_P.Dynamic_Any; package body DynamicAny.DynValue.Impl is use PolyORB.Any; use PolyORB.Any.TypeCode; function Is_Destroyed (Self : access DynAny.Impl.Object'Class) return Boolean renames DynAny.Impl.Internals.Is_Destroyed; ---------- -- Copy -- ---------- function Copy (Self : access Object) return DynAny.Local_Ref'Class is begin if Is_Destroyed (Self) then CORBA.Raise_Object_Not_Exist (CORBA.Default_Sys_Member); end if; return PolyORB.CORBA_P.Dynamic_Any.Create (DynAny.Impl.Internals.Get_Value (Self), Self.Allow_Truncate, null); end Copy; ------------------------- -- Current_Member_Kind -- ------------------------- function Current_Member_Kind (Self : access Object) return CORBA.TCKind is begin if Is_Destroyed (Self) then CORBA.Raise_Object_Not_Exist (CORBA.Default_Sys_Member); end if; raise Program_Error; return CORBA.Tk_Void; end Current_Member_Kind; ------------------------- -- Current_Member_Name -- ------------------------- function Current_Member_Name (Self : access Object) return FieldName is Result : DynamicAny.FieldName; begin if Is_Destroyed (Self) then CORBA.Raise_Object_Not_Exist (CORBA.Default_Sys_Member); end if; raise Program_Error; return Result; end Current_Member_Name; ----------------- -- Get_Members -- ----------------- function Get_Members (Self : access Object) return NameValuePairSeq is Result : DynamicAny.NameValuePairSeq; begin if Is_Destroyed (Self) then CORBA.Raise_Object_Not_Exist (CORBA.Default_Sys_Member); end if; raise Program_Error; return Result; end Get_Members; ---------------------------- -- Get_Members_As_Dyn_Any -- ---------------------------- function Get_Members_As_Dyn_Any (Self : access Object) return NameDynAnyPairSeq is Result : DynamicAny.NameDynAnyPairSeq; begin if Is_Destroyed (Self) then CORBA.Raise_Object_Not_Exist (CORBA.Default_Sys_Member); end if; raise Program_Error; return Result; end Get_Members_As_Dyn_Any; --------------- -- Internals -- --------------- package body Internals is ------------ -- Create -- ------------ function Create (Value : CORBA.Any; Allow_Truncate : Boolean; Parent : DynAny.Impl.Object_Ptr) return DynAny.Local_Ref is Obj : constant Object_Ptr := new Object; Result : DynAny.Local_Ref; begin pragma Assert (Kind (CORBA.Get_Type (Value)) = Tk_Value); Initialize (Obj, PolyORB.Any.Any (Value), Allow_Truncate, Parent); DynAny.Set (Result, PolyORB.Smart_Pointers.Entity_Ptr (Obj)); return Result; end Create; function Create (Value : PolyORB.Any.TypeCode.Local_Ref) return DynAny.Local_Ref is Obj : constant Object_Ptr := new Object; Result : DynAny.Local_Ref; begin pragma Assert (Kind (Value) = Tk_Array); Initialize (Obj, Value); DynAny.Set (Result, PolyORB.Smart_Pointers.Entity_Ptr (Obj)); return Result; end Create; ---------------- -- Initialize -- ---------------- procedure Initialize (Self : access Object'Class; IDL_Type : PolyORB.Any.TypeCode.Local_Ref) is begin DynValueCommon.Impl.Internals.Initialize (Self, IDL_Type); Self.Allow_Truncate := True; end Initialize; procedure Initialize (Self : access Object'Class; Value : PolyORB.Any.Any; Allow_Truncate : Boolean; Parent : DynAny.Impl.Object_Ptr) is begin DynValueCommon.Impl.Internals.Initialize (Self, Value, Parent); Self.Allow_Truncate := Allow_Truncate; end Initialize; end Internals; ---------- -- Is_A -- ---------- function Is_A (Self : not null access Object; Logical_Type_Id : Standard.String) return Boolean is pragma Unreferenced (Self); begin return CORBA.Is_Equivalent (Logical_Type_Id, DynamicAny.DynValue.Repository_Id) or else CORBA.Is_Equivalent (Logical_Type_Id, DynamicAny.DynValueCommon.Repository_Id) or else CORBA.Is_Equivalent (Logical_Type_Id, DynamicAny.DynAny.Repository_Id) or else CORBA.Is_Equivalent (Logical_Type_Id, "IDL:omg.org/CORBA/Object:1.0"); end Is_A; ----------------- -- Set_Members -- ----------------- procedure Set_Members (Self : access Object; Value : NameValuePairSeq) is pragma Unreferenced (Value); begin if Is_Destroyed (Self) then CORBA.Raise_Object_Not_Exist (CORBA.Default_Sys_Member); end if; raise Program_Error; end Set_Members; ---------------------------- -- Set_Members_As_Dyn_Any -- ---------------------------- procedure Set_Members_As_Dyn_Any (Self : access Object; Value : NameDynAnyPairSeq) is pragma Unreferenced (Value); begin if Is_Destroyed (Self) then CORBA.Raise_Object_Not_Exist (CORBA.Default_Sys_Member); end if; raise Program_Error; end Set_Members_As_Dyn_Any; end DynamicAny.DynValue.Impl; polyorb-2.8~20110207.orig/src/corba/dynamicany/dynamicany-dynvaluecommon-impl.adb0000644000175000017500000001042411750740340027215 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- D Y N A M I C A N Y . D Y N V A L U E C O M M O N . I M P L -- -- -- -- B o d y -- -- -- -- Copyright (C) 2005-2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ package body DynamicAny.DynValueCommon.Impl is function Is_Destroyed (Self : access DynAny.Impl.Object'Class) return Boolean renames DynAny.Impl.Internals.Is_Destroyed; ---------- -- Is_A -- ---------- function Is_A (Self : not null access Object; Logical_Type_Id : Standard.String) return Boolean is pragma Unreferenced (Self); begin return CORBA.Is_Equivalent (Logical_Type_Id, DynamicAny.DynValueCommon.Repository_Id) or else CORBA.Is_Equivalent (Logical_Type_Id, DynamicAny.DynAny.Repository_Id) or else CORBA.Is_Equivalent (Logical_Type_Id, "IDL:omg.org/CORBA/Object:1.0"); end Is_A; --------------- -- Internals -- --------------- package body Internals is ---------------- -- Initialize -- ---------------- procedure Initialize (Self : access Object'Class; IDL_Type : PolyORB.Any.TypeCode.Local_Ref) is begin DynAny.Impl.Internals.Initialize (Self, IDL_Type); end Initialize; procedure Initialize (Self : access Object'Class; Value : PolyORB.Any.Any; Parent : DynAny.Impl.Object_Ptr) is begin DynAny.Impl.Internals.Initialize (Self, Value, Parent); end Initialize; end Internals; ------------- -- Is_Null -- ------------- function Is_Null (Self : access Object) return CORBA.Boolean is begin if Is_Destroyed (Self) then CORBA.Raise_Object_Not_Exist (CORBA.Default_Sys_Member); end if; raise Program_Error; return False; end Is_Null; ----------------- -- Set_To_Null -- ----------------- procedure Set_To_Null (Self : access Object) is begin if Is_Destroyed (Self) then CORBA.Raise_Object_Not_Exist (CORBA.Default_Sys_Member); end if; raise Program_Error; end Set_To_Null; ------------------ -- Set_To_Value -- ------------------ procedure Set_To_Value (Self : access Object) is begin if Is_Destroyed (Self) then CORBA.Raise_Object_Not_Exist (CORBA.Default_Sys_Member); end if; raise Program_Error; end Set_To_Value; end DynamicAny.DynValueCommon.Impl; polyorb-2.8~20110207.orig/src/corba/dynamicany/dynamicany-dynarray-impl.ads0000644000175000017500000000642711750740340026037 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- D Y N A M I C A N Y . D Y N A R R A Y . I M P L -- -- -- -- S p e c -- -- -- -- Copyright (C) 2005-2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with PolyORB.Any; with DynamicAny.DynAny.Impl; package DynamicAny.DynArray.Impl is type Object is new DynamicAny.DynAny.Impl.Object with private; type Object_Ptr is access all Object'Class; function Get_Elements (Self : access Object) return AnySeq; procedure Set_Elements (Self : access Object; Value : AnySeq); function Get_Elements_As_Dyn_Any (Self : access Object) return DynAnySeq; procedure Set_Elements_As_Dyn_Any (Self : access Object; Value : DynAnySeq); function Is_A (Self : not null access Object; Logical_Type_Id : Standard.String) return Boolean; package Internals is procedure Initialize (Self : access Object'Class; Value : PolyORB.Any.Any; Parent : DynAny.Impl.Object_Ptr); procedure Initialize (Self : access Object'Class; IDL_Type : PolyORB.Any.TypeCode.Local_Ref); function Create (Value : CORBA.Any; Parent : DynAny.Impl.Object_Ptr) return DynAny.Local_Ref; function Create (Value : PolyORB.Any.TypeCode.Local_Ref) return DynAny.Local_Ref; end Internals; private type Object is new DynamicAny.DynAny.Impl.Object with record null; end record; end DynamicAny.DynArray.Impl; polyorb-2.8~20110207.orig/src/corba/dynamicany/dynamicany-dynvalue-impl.ads0000644000175000017500000000742211750740340026031 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- D Y N A M I C A N Y . D Y N V A L U E . I M P L -- -- -- -- S p e c -- -- -- -- Copyright (C) 2005-2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with PolyORB.Any; with DynamicAny.DynAny.Impl; with DynamicAny.DynValueCommon.Impl; package DynamicAny.DynValue.Impl is type Object is new DynamicAny.DynValueCommon.Impl.Object with private; type Object_Ptr is access all Object'Class; function Current_Member_Name (Self : access Object) return FieldName; function Current_Member_Kind (Self : access Object) return CORBA.TCKind; function Get_Members (Self : access Object) return NameValuePairSeq; procedure Set_Members (Self : access Object; Value : NameValuePairSeq); function Get_Members_As_Dyn_Any (Self : access Object) return NameDynAnyPairSeq; procedure Set_Members_As_Dyn_Any (Self : access Object; Value : NameDynAnyPairSeq); function Is_A (Self : not null access Object; Logical_Type_Id : Standard.String) return Boolean; -- Derived from DynamicAny::DynAny function Copy (Self : access Object) return DynAny.Local_Ref'Class; package Internals is procedure Initialize (Self : access Object'Class; Value : PolyORB.Any.Any; Allow_Truncate : Boolean; Parent : DynAny.Impl.Object_Ptr); procedure Initialize (Self : access Object'Class; IDL_Type : PolyORB.Any.TypeCode.Local_Ref); function Create (Value : CORBA.Any; Allow_Truncate : Boolean; Parent : DynAny.Impl.Object_Ptr) return DynAny.Local_Ref; function Create (Value : PolyORB.Any.TypeCode.Local_Ref) return DynAny.Local_Ref; end Internals; private type Object is new DynamicAny.DynValueCommon.Impl.Object with record Allow_Truncate : Boolean; end record; end DynamicAny.DynValue.Impl; polyorb-2.8~20110207.orig/src/corba/dynamicany/dynamicany-dynenum-impl.ads0000644000175000017500000000647611750740340025671 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- D Y N A M I C A N Y . D Y N E N U M . I M P L -- -- -- -- S p e c -- -- -- -- Copyright (C) 2005-2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with PolyORB.Any; with DynamicAny.DynAny.Impl; package DynamicAny.DynEnum.Impl is type Object is new DynamicAny.DynAny.Impl.Object with private; type Object_Ptr is access all Object'Class; function Get_As_String (Self : access Object) return CORBA.String; procedure Set_As_String (Self : access Object; Value : CORBA.String); function Get_As_ULong (Self : access Object) return CORBA.Unsigned_Long; procedure Set_As_ULong (Self : access Object; Value : CORBA.Unsigned_Long); function Is_A (Self : not null access Object; Logical_Type_Id : Standard.String) return Boolean; package Internals is procedure Initialize (Self : access Object'Class; Value : PolyORB.Any.Any; Parent : DynAny.Impl.Object_Ptr); procedure Initialize (Self : access Object'Class; IDL_Type : PolyORB.Any.TypeCode.Local_Ref); function Create (Value : CORBA.Any; Parent : DynAny.Impl.Object_Ptr) return DynAny.Local_Ref; function Create (Value : PolyORB.Any.TypeCode.Local_Ref) return DynAny.Local_Ref; end Internals; private type Object is new DynamicAny.DynAny.Impl.Object with record null; end record; end DynamicAny.DynEnum.Impl; polyorb-2.8~20110207.orig/src/corba/dynamicany/dynamicany-dynanyfactory-impl.adb0000644000175000017500000001333411750740340027052 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- D Y N A M I C A N Y . D Y N A N Y F A C T O R Y . I M P L -- -- -- -- B o d y -- -- -- -- Copyright (C) 2005-2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with PolyORB.CORBA_P.Initial_References; with PolyORB.Initialization; with PolyORB.Smart_Pointers; with PolyORB.Utils.Strings; with PolyORB.CORBA_P.Dynamic_Any; package body DynamicAny.DynAnyFactory.Impl is procedure Deferred_Initialization; -------------------- -- Create_Dyn_Any -- -------------------- function Create_Dyn_Any (Self : access Object; Value : CORBA.Any) return DynAny.Local_Ref is pragma Unreferenced (Self); begin return PolyORB.CORBA_P.Dynamic_Any.Create (Value, True, null); end Create_Dyn_Any; ----------------------------------- -- Create_Dyn_Any_From_Type_Code -- ----------------------------------- function Create_Dyn_Any_From_Type_Code (Self : access Object; IDL_Type : CORBA.TypeCode.Object) return DynAny.Local_Ref is pragma Unreferenced (Self); begin return PolyORB.CORBA_P.Dynamic_Any.Create (IDL_Type); end Create_Dyn_Any_From_Type_Code; --------------------------------------- -- Create_Dyn_Any_Without_Truncation -- --------------------------------------- function Create_Dyn_Any_Without_Truncation (Self : access Object; Value : CORBA.Any) return DynAny.Local_Ref is pragma Unreferenced (Self); begin return PolyORB.CORBA_P.Dynamic_Any.Create (Value, False, null); end Create_Dyn_Any_Without_Truncation; -------------------------- -- Create_Multiple_Anys -- -------------------------- function Create_Multiple_Anys (Self : access Object; Values : DynAnySeq) return AnySeq is pragma Unreferenced (Self); pragma Unreferenced (Values); Result : DynamicAny.AnySeq; begin raise Program_Error; return Result; end Create_Multiple_Anys; ------------------------------ -- Create_Multiple_Dyn_Anys -- ------------------------------ function Create_Multiple_Dyn_Anys (Self : access Object; Values : AnySeq; Allow_Truncate : CORBA.Boolean) return DynamicAny.DynAnySeq is pragma Unreferenced (Self); pragma Unreferenced (Values); pragma Unreferenced (Allow_Truncate); Result : DynamicAny.DynAnySeq; begin raise Program_Error; return Result; end Create_Multiple_Dyn_Anys; ----------------------------- -- Deferred_Initialization -- ----------------------------- procedure Deferred_Initialization is Factory_Object : constant Object_Ptr := new Object; Factory_Ref : CORBA.Object.Ref; begin CORBA.Object.Set (Factory_Ref, PolyORB.Smart_Pointers.Entity_Ptr (Factory_Object)); PolyORB.CORBA_P.Initial_References.Register_Initial_Reference ("DynAnyFactory", Factory_Ref); end Deferred_Initialization; ---------- -- Is_A -- ---------- function Is_A (Self : not null access Object; Logical_Type_Id : Standard.String) return Boolean is pragma Unreferenced (Self); begin return CORBA.Is_Equivalent (Logical_Type_Id, DynamicAny.DynAnyFactory.Repository_Id) or else CORBA.Is_Equivalent (Logical_Type_Id, "IDL:omg.org/CORBA/Object:1.0"); end Is_A; begin declare use PolyORB.Initialization; use PolyORB.Initialization.String_Lists; use PolyORB.Utils.Strings; begin Register_Module (Module_Info' (Name => +"dynamicany.dynanyfactory", Conflicts => Empty, Depends => +"corba.initial_references", Provides => Empty, Implicit => False, Init => Deferred_Initialization'Access, Shutdown => null)); end; end DynamicAny.DynAnyFactory.Impl; polyorb-2.8~20110207.orig/src/corba/dynamicany/dynamicany-dynfixed-impl.adb0000644000175000017500000001217411750740340025773 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- D Y N A M I C A N Y . D Y N F I X E D . I M P L -- -- -- -- B o d y -- -- -- -- Copyright (C) 2005-2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with PolyORB.Smart_Pointers; package body DynamicAny.DynFixed.Impl is use PolyORB.Any; use PolyORB.Any.TypeCode; function Is_Destroyed (Self : access DynAny.Impl.Object'Class) return Boolean renames DynAny.Impl.Internals.Is_Destroyed; --------------- -- Get_Value -- --------------- function Get_Value (Self : access Object) return CORBA.String is Result : CORBA.String; begin if Is_Destroyed (Self) then CORBA.Raise_Object_Not_Exist (CORBA.Default_Sys_Member); end if; raise Program_Error; return Result; end Get_Value; --------------- -- Internals -- --------------- package body Internals is ------------ -- Create -- ------------ function Create (Value : CORBA.Any; Parent : DynAny.Impl.Object_Ptr) return DynAny.Local_Ref is Obj : constant Object_Ptr := new Object; Result : DynAny.Local_Ref; begin pragma Assert (Kind (CORBA.Get_Type (Value)) = Tk_Fixed); Initialize (Obj, PolyORB.Any.Any (Value), Parent); DynAny.Set (Result, PolyORB.Smart_Pointers.Entity_Ptr (Obj)); return Result; end Create; function Create (Value : PolyORB.Any.TypeCode.Local_Ref) return DynAny.Local_Ref is Obj : constant Object_Ptr := new Object; Result : DynAny.Local_Ref; begin pragma Assert (Kind (Value) = Tk_Array); Initialize (Obj, Value); DynAny.Set (Result, PolyORB.Smart_Pointers.Entity_Ptr (Obj)); return Result; end Create; ---------------- -- Initialize -- ---------------- procedure Initialize (Self : access Object'Class; IDL_Type : PolyORB.Any.TypeCode.Local_Ref) is begin DynAny.Impl.Internals.Initialize (Self, IDL_Type); end Initialize; procedure Initialize (Self : access Object'Class; Value : PolyORB.Any.Any; Parent : DynAny.Impl.Object_Ptr) is begin DynAny.Impl.Internals.Initialize (Self, Value, Parent); end Initialize; end Internals; ---------- -- Is_A -- ---------- function Is_A (Self : not null access Object; Logical_Type_Id : Standard.String) return Boolean is pragma Unreferenced (Self); begin return CORBA.Is_Equivalent (Logical_Type_Id, DynamicAny.DynFixed.Repository_Id) or else CORBA.Is_Equivalent (Logical_Type_Id, DynamicAny.DynAny.Repository_Id) or else CORBA.Is_Equivalent (Logical_Type_Id, "IDL:omg.org/CORBA/Object:1.0"); end Is_A; --------------- -- Set_Value -- --------------- function Set_Value (Self : access Object; Val : CORBA.String) return CORBA.Boolean is pragma Unreferenced (Val); begin if Is_Destroyed (Self) then CORBA.Raise_Object_Not_Exist (CORBA.Default_Sys_Member); end if; raise Program_Error; return False; end Set_Value; end DynamicAny.DynFixed.Impl; polyorb-2.8~20110207.orig/src/corba/dynamicany/dynamicany-dynsequence-impl.ads0000644000175000017500000000673011750740340026526 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- D Y N A M I C A N Y . D Y N S E Q U E N C E . I M P L -- -- -- -- S p e c -- -- -- -- Copyright (C) 2005-2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with PolyORB.Any; with DynamicAny.DynAny.Impl; package DynamicAny.DynSequence.Impl is type Object is new DynamicAny.DynAny.Impl.Object with private; type Object_Ptr is access all Object'Class; function Get_Length (Self : access Object) return CORBA.Unsigned_Long; procedure Set_Length (Self : access Object; Len : CORBA.Unsigned_Long); function Get_Elements (Self : access Object) return AnySeq; procedure Set_Elements (Self : access Object; Value : AnySeq); function Get_Elements_As_Dyn_Any (Self : access Object) return DynAnySeq; procedure Set_Elements_As_Dyn_Any (Self : access Object; Value : DynAnySeq); function Is_A (Self : not null access Object; Logical_Type_Id : Standard.String) return Boolean; package Internals is procedure Initialize (Self : access Object'Class; Value : PolyORB.Any.Any; Parent : DynAny.Impl.Object_Ptr); procedure Initialize (Self : access Object'Class; IDL_Type : PolyORB.Any.TypeCode.Local_Ref); function Create (Value : CORBA.Any; Parent : DynAny.Impl.Object_Ptr) return DynAny.Local_Ref; function Create (Value : PolyORB.Any.TypeCode.Local_Ref) return DynAny.Local_Ref; end Internals; private type Object is new DynamicAny.DynAny.Impl.Object with record null; end record; end DynamicAny.DynSequence.Impl; polyorb-2.8~20110207.orig/src/corba/dynamicany/dynamicany-dynany-impl.ads0000644000175000017500000002540111750740340025501 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- D Y N A M I C A N Y . D Y N A N Y . I M P L -- -- -- -- S p e c -- -- -- -- Copyright (C) 2005-2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with CORBA.AbstractBase; with CORBA.IDL_SEQUENCES; with CORBA.Local; with CORBA.Object; with PolyORB.Any; with PolyORB.Utils.Chained_Lists; package DynamicAny.DynAny.Impl is type Object is new CORBA.Local.Object with private; type Object_Ptr is access all Object'Class; function IDL_Type (Self : access Object) return CORBA.TypeCode.Object; procedure Assign (Self : access Object; Dyn_Any : Local_Ref'Class); procedure From_Any (Self : access Object; Value : CORBA.Any); function To_Any (Self : access Object) return CORBA.Any; function Equal (Self : access Object; Dyn_Any : Local_Ref'Class) return CORBA.Boolean; procedure Destroy (Self : access Object); function Copy (Self : access Object) return Local_Ref'Class; procedure Insert_Boolean (Self : access Object; Value : CORBA.Boolean); procedure Insert_Octet (Self : access Object; Value : CORBA.Octet); procedure Insert_Char (Self : access Object; Value : CORBA.Char); procedure Insert_Short (Self : access Object; Value : CORBA.Short); procedure Insert_UShort (Self : access Object; Value : CORBA.Unsigned_Short); procedure Insert_Long (Self : access Object; Value : CORBA.Long); procedure Insert_ULong (Self : access Object; Value : CORBA.Unsigned_Long); procedure Insert_Float (Self : access Object; Value : CORBA.Float); procedure Insert_Double (Self : access Object; Value : CORBA.Double); procedure Insert_String (Self : access Object; Value : CORBA.String); procedure Insert_Reference (Self : access Object; Value : CORBA.Object.Ref); procedure Insert_TypeCode (Self : access Object; Value : CORBA.TypeCode.Object); procedure Insert_LongLong (Self : access Object; Value : CORBA.Long_Long); procedure Insert_ULongLong (Self : access Object; Value : CORBA.Unsigned_Long_Long); procedure Insert_LongDouble (Self : access Object; Value : CORBA.Long_Double); procedure Insert_WChar (Self : access Object; Value : CORBA.Wchar); procedure Insert_WString (Self : access Object; Value : CORBA.Wide_String); procedure Insert_Any (Self : access Object; Value : CORBA.Any); procedure Insert_Dyn_Any (Self : access Object; Value : Local_Ref'Class); function Get_Boolean (Self : access Object) return CORBA.Boolean; function Get_Octet (Self : access Object) return CORBA.Octet; function Get_Char (Self : access Object) return CORBA.Char; function Get_Short (Self : access Object) return CORBA.Short; function Get_UShort (Self : access Object) return CORBA.Unsigned_Short; function Get_Long (Self : access Object) return CORBA.Long; function Get_ULong (Self : access Object) return CORBA.Unsigned_Long; function Get_Float (Self : access Object) return CORBA.Float; function Get_Double (Self : access Object) return CORBA.Double; function Get_String (Self : access Object) return CORBA.String; function Get_Reference (Self : access Object) return CORBA.Object.Ref; function Get_TypeCode (Self : access Object) return CORBA.TypeCode.Object; function Get_LongLong (Self : access Object) return CORBA.Long_Long; function Get_ULongLong (Self : access Object) return CORBA.Unsigned_Long_Long; function Get_LongDouble (Self : access Object) return CORBA.Long_Double; function Get_WChar (Self : access Object) return CORBA.Wchar; function Get_WString (Self : access Object) return CORBA.Wide_String; function Get_Any (Self : access Object) return CORBA.Any; function Get_Dyn_Any (Self : access Object) return Local_Ref'Class; function Seek (Self : access Object; Index : CORBA.Long) return CORBA.Boolean; procedure Rewind (Self : access Object); function Next (Self : access Object) return CORBA.Boolean; function Component_Count (Self : access Object) return CORBA.Unsigned_Long; function Current_Component (Self : access Object) return Local_Ref'Class; procedure Insert_Abstract (Self : access Object; Value : CORBA.AbstractBase.Ref); function Get_Abstract (Self : access Object) return CORBA.AbstractBase.Ref; procedure Insert_Boolean_Seq (Self : access Object; Value : CORBA.IDL_SEQUENCES.BooleanSeq); procedure Insert_Octet_Seq (Self : access Object; Value : CORBA.IDL_SEQUENCES.OctetSeq); procedure Insert_Char_Seq (Self : access Object; Value : CORBA.IDL_SEQUENCES.CharSeq); procedure Insert_Short_Seq (Self : access Object; Value : CORBA.IDL_SEQUENCES.ShortSeq); procedure Insert_UShort_Seq (Self : access Object; Value : CORBA.IDL_SEQUENCES.UShortSeq); procedure Insert_Long_Seq (Self : access Object; Value : CORBA.IDL_SEQUENCES.LongSeq); procedure Insert_ULong_Seq (Self : access Object; Value : CORBA.IDL_SEQUENCES.ULongSeq); procedure Insert_Float_Seq (Self : access Object; Value : CORBA.IDL_SEQUENCES.FloatSeq); procedure Insert_Double_Seq (Self : access Object; Value : CORBA.IDL_SEQUENCES.DoubleSeq); procedure Insert_LongLong_Seq (Self : access Object; Value : CORBA.IDL_SEQUENCES.LongLongSeq); procedure Insert_ULongLong_Seq (Self : access Object; Value : CORBA.IDL_SEQUENCES.ULongLongSeq); procedure Insert_LongDouble_Seq (Self : access Object; Value : CORBA.IDL_SEQUENCES.LongDoubleSeq); procedure Insert_WChar_Seq (Self : access Object; Value : CORBA.IDL_SEQUENCES.WCharSeq); function Get_Boolean_Seq (Self : access Object) return CORBA.IDL_SEQUENCES.BooleanSeq; function Get_Octet_Seq (Self : access Object) return CORBA.IDL_SEQUENCES.OctetSeq; function Get_Char_Seq (Self : access Object) return CORBA.IDL_SEQUENCES.CharSeq; function Get_Short_Seq (Self : access Object) return CORBA.IDL_SEQUENCES.ShortSeq; function Get_UShort_Seq (Self : access Object) return CORBA.IDL_SEQUENCES.UShortSeq; function Get_Long_Seq (Self : access Object) return CORBA.IDL_SEQUENCES.LongSeq; function Get_ULong_Seq (Self : access Object) return CORBA.IDL_SEQUENCES.ULongSeq; function Get_Float_Seq (Self : access Object) return CORBA.IDL_SEQUENCES.FloatSeq; function Get_Double_Seq (Self : access Object) return CORBA.IDL_SEQUENCES.DoubleSeq; function Get_LongLong_Seq (Self : access Object) return CORBA.IDL_SEQUENCES.LongLongSeq; function Get_ULongLong_Seq (Self : access Object) return CORBA.IDL_SEQUENCES.ULongLongSeq; function Get_LongDouble_Seq (Self : access Object) return CORBA.IDL_SEQUENCES.LongDoubleSeq; function Get_WChar_Seq (Self : access Object) return CORBA.IDL_SEQUENCES.WCharSeq; function Is_A (Self : not null access Object; Logical_Type_Id : Standard.String) return Boolean; -- Implementation specific subprograms package Internals is function Is_Destroyed (Self : access Object'Class) return Boolean; -- Return True iff Self marked to be destroyed as part of top level -- dynamic any destruction. function Get_Value (Self : access Object'Class) return CORBA.Any; -- Return internal Value -- Constructors procedure Initialize (Self : access Object'Class; Value : PolyORB.Any.Any; Parent : Object_Ptr); -- Initialize DynAny object. If Parent is null (initialized object is -- a top level object) then independent copy of Value is created; -- otherwise value stored inside object. procedure Initialize (Self : access Object'Class; IDL_Type : PolyORB.Any.TypeCode.Local_Ref); -- Initialize DynAny object and setup default value function Create (Value : CORBA.Any; Parent : Object_Ptr) return Local_Ref; function Create (Value : PolyORB.Any.TypeCode.Local_Ref) return DynAny.Local_Ref; end Internals; private package Local_Ref_Lists is new PolyORB.Utils.Chained_Lists (Local_Ref); type Object is new CORBA.Local.Object with record Value : PolyORB.Any.Any; -- ??? should really be a CORBA.Any Current : CORBA.Long; Parent : Object_Ptr; Children : Local_Ref_Lists.List; Is_Destroyed : Boolean := False; end record; procedure Mark_Destroyed (Self : access Object); -- Mark DynAny and all it children are destroyed procedure Finalize (Self : in out Object); -- Destructor. Called automatically from Smart Pointers. end DynamicAny.DynAny.Impl; polyorb-2.8~20110207.orig/src/corba/dynamicany/dynamicany-dynenum-impl.adb0000644000175000017500000002013611750740340025635 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- D Y N A M I C A N Y . D Y N E N U M . I M P L -- -- -- -- B o d y -- -- -- -- Copyright (C) 2005-2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with PolyORB.Smart_Pointers; with PolyORB.Types; with DynamicAny.DynAny.Helper; package body DynamicAny.DynEnum.Impl is use PolyORB.Any; use PolyORB.Any.TypeCode; use type PolyORB.Types.Identifier; use type PolyORB.Types.Unsigned_Long; function Is_Destroyed (Self : access DynAny.Impl.Object'Class) return Boolean renames DynAny.Impl.Internals.Is_Destroyed; ------------------- -- Get_As_String -- ------------------- function Get_As_String (Self : access Object) return CORBA.String is begin if Is_Destroyed (Self) then CORBA.Raise_Object_Not_Exist (CORBA.Default_Sys_Member); end if; declare Value : constant PolyORB.Any.Any := PolyORB.Any.Any (DynAny.Impl.Internals.Get_Value (Self)); TC : constant PolyORB.Any.TypeCode.Local_Ref := Get_Type (Value); Index : constant PolyORB.Types.Unsigned_Long := From_Any (Get_Aggregate_Element (Value, PolyORB.Any.TC_Unsigned_Long, 0)); begin return CORBA.String (Member_Name (TC, Index)); end; end Get_As_String; ------------------ -- Get_As_ULong -- ------------------ function Get_As_ULong (Self : access Object) return CORBA.Unsigned_Long is begin if Is_Destroyed (Self) then CORBA.Raise_Object_Not_Exist (CORBA.Default_Sys_Member); end if; declare Value : constant PolyORB.Any.Any := PolyORB.Any.Any (DynAny.Impl.Internals.Get_Value (Self)); begin return CORBA.Unsigned_Long (PolyORB.Types.Unsigned_Long' (From_Any (Get_Aggregate_Element (Value, PolyORB.Any.TC_Unsigned_Long, 0)))); end; end Get_As_ULong; --------------- -- Internals -- --------------- package body Internals is ------------ -- Create -- ------------ function Create (Value : CORBA.Any; Parent : DynAny.Impl.Object_Ptr) return DynAny.Local_Ref is Obj : constant Object_Ptr := new Object; Result : DynAny.Local_Ref; begin pragma Assert (Kind (CORBA.Get_Type (Value)) = Tk_Enum); Initialize (Obj, PolyORB.Any.Any (Value), Parent); DynAny.Set (Result, PolyORB.Smart_Pointers.Entity_Ptr (Obj)); return Result; end Create; function Create (Value : PolyORB.Any.TypeCode.Local_Ref) return DynAny.Local_Ref is Obj : constant Object_Ptr := new Object; Result : DynAny.Local_Ref; begin pragma Assert (Kind (Value) = Tk_Array); Initialize (Obj, Value); DynAny.Set (Result, PolyORB.Smart_Pointers.Entity_Ptr (Obj)); return Result; end Create; ---------------- -- Initialize -- ---------------- procedure Initialize (Self : access Object'Class; IDL_Type : PolyORB.Any.TypeCode.Local_Ref) is begin DynAny.Impl.Internals.Initialize (Self, IDL_Type); end Initialize; procedure Initialize (Self : access Object'Class; Value : PolyORB.Any.Any; Parent : DynAny.Impl.Object_Ptr) is begin DynAny.Impl.Internals.Initialize (Self, Value, Parent); end Initialize; end Internals; ---------- -- Is_A -- ---------- function Is_A (Self : not null access Object; Logical_Type_Id : Standard.String) return Boolean is pragma Unreferenced (Self); begin return CORBA.Is_Equivalent (Logical_Type_Id, DynamicAny.DynEnum.Repository_Id) or else CORBA.Is_Equivalent (Logical_Type_Id, DynamicAny.DynAny.Repository_Id) or else CORBA.Is_Equivalent (Logical_Type_Id, "IDL:omg.org/CORBA/Object:1.0"); end Is_A; ------------------- -- Set_As_String -- ------------------- procedure Set_As_String (Self : access Object; Value : CORBA.String) is begin if Is_Destroyed (Self) then CORBA.Raise_Object_Not_Exist (CORBA.Default_Sys_Member); end if; declare Val : constant PolyORB.Any.Any := PolyORB.Any.Any (DynAny.Impl.Internals.Get_Value (Self)); TC : constant PolyORB.Any.TypeCode.Local_Ref := Get_Type (Val); Enum_Value : constant PolyORB.Any.Any := Get_Aggregate_Element (Val, PolyORB.Any.TC_Unsigned_Long, 0); begin for J in 0 .. Member_Count (TC) - 1 loop if Member_Name (TC, J) = PolyORB.Types.Identifier (Value) then Set_Any_Value (J, Get_Container (Enum_Value).all); return; end if; end loop; end; DynAny.Helper.Raise_InvalidValue ((CORBA.IDL_Exception_Members with null record)); end Set_As_String; ------------------ -- Set_As_ULong -- ------------------ procedure Set_As_ULong (Self : access Object; Value : CORBA.Unsigned_Long) is begin if Is_Destroyed (Self) then CORBA.Raise_Object_Not_Exist (CORBA.Default_Sys_Member); end if; declare Val : constant PolyORB.Any.Any := PolyORB.Any.Any (DynAny.Impl.Internals.Get_Value (Self)); TC : constant PolyORB.Any.TypeCode.Local_Ref := Get_Type (Val); Enum_Value : constant PolyORB.Any.Any := Get_Aggregate_Element (Val, PolyORB.Any.TC_Unsigned_Long, 0); begin if PolyORB.Types.Unsigned_Long (Value) < Member_Count (TC) then Set_Any_Value (PolyORB.Types.Unsigned_Long (Value), Get_Container (Enum_Value).all); else DynAny.Helper.Raise_InvalidValue ((CORBA.IDL_Exception_Members with null record)); end if; end; end Set_As_ULong; end DynamicAny.DynEnum.Impl; polyorb-2.8~20110207.orig/src/corba/dynamicany/polyorb-corba_p-dynamic_any.adb0000644000175000017500000001571211750740340026453 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . C O R B A _ P . D Y N A M I C _ A N Y -- -- -- -- B o d y -- -- -- -- Copyright (C) 2005-2007, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with PolyORB.Any; with DynamicAny.DynAnyFactory.Helper; with DynamicAny.DynArray.Impl; with DynamicAny.DynEnum.Impl; with DynamicAny.DynFixed.Impl; with DynamicAny.DynSequence.Impl; with DynamicAny.DynStruct.Impl; with DynamicAny.DynUnion.Impl; with DynamicAny.DynValue.Impl; with DynamicAny.DynValueBox.Impl; package body PolyORB.CORBA_P.Dynamic_Any is use PolyORB.Any; use PolyORB.Any.TypeCode; ------------ -- Create -- ------------ function Create (IDL_Type : CORBA.TypeCode.Object) return DynamicAny.DynAny.Local_Ref is Neutral : constant PolyORB.Any.TypeCode.Local_Ref := CORBA.TypeCode.Internals.To_PolyORB_Object (IDL_Type); begin case Kind (Unwind_Typedefs (Neutral)) is when Tk_Null | Tk_Void | Tk_Boolean | Tk_Octet | Tk_Char | Tk_Short | Tk_Ushort | Tk_Long | Tk_Ulong | Tk_Float | Tk_Double | Tk_String | Tk_TypeCode | Tk_Longlong | Tk_Ulonglong | Tk_Longdouble | Tk_Widechar | Tk_Wstring | Tk_Any | Tk_Objref | Tk_Abstract_Interface => return DynamicAny.DynAny.Impl.Internals.Create (Neutral); when Tk_Array => return DynamicAny.DynArray.Impl.Internals.Create (Neutral); when Tk_Enum => return DynamicAny.DynEnum.Impl.Internals.Create (Neutral); when Tk_Fixed => return DynamicAny.DynFixed.Impl.Internals.Create (Neutral); when Tk_Sequence => return DynamicAny.DynSequence.Impl.Internals.Create (Neutral); when Tk_Struct | Tk_Except => return DynamicAny.DynStruct.Impl.Internals.Create (Neutral); when Tk_Union => return DynamicAny.DynUnion.Impl.Internals.Create (Neutral); when Tk_Value => return DynamicAny.DynValue.Impl.Internals.Create (Neutral); when Tk_Valuebox => return DynamicAny.DynValueBox.Impl.Internals.Create (Neutral); when Tk_Principal | Tk_Native => DynamicAny.DynAnyFactory.Helper.Raise_InconsistentTypeCode ((CORBA.IDL_Exception_Members with null record)); when Tk_Local_Interface | Tk_Component | Tk_Home | Tk_Event => -- XXX Not yet implemented raise Program_Error; when Tk_Alias => -- This should never happen raise Program_Error; end case; end Create; function Create (Value : CORBA.Any; Allow_Truncate : Boolean; Parent : DynamicAny.DynAny.Impl.Object_Ptr) return DynamicAny.DynAny.Local_Ref is begin case Kind (Get_Unwound_Type (PolyORB.Any.Any (Value))) is when Tk_Null | Tk_Void | Tk_Boolean | Tk_Octet | Tk_Char | Tk_Short | Tk_Ushort | Tk_Long | Tk_Ulong | Tk_Float | Tk_Double | Tk_String | Tk_TypeCode | Tk_Longlong | Tk_Ulonglong | Tk_Longdouble | Tk_Widechar | Tk_Wstring | Tk_Any | Tk_Objref | Tk_Abstract_Interface => return DynamicAny.DynAny.Impl.Internals.Create (Value, Parent); when Tk_Array => return DynamicAny.DynArray.Impl.Internals.Create (Value, Parent); when Tk_Enum => return DynamicAny.DynEnum.Impl.Internals.Create (Value, Parent); when Tk_Fixed => return DynamicAny.DynFixed.Impl.Internals.Create (Value, Parent); when Tk_Sequence => return DynamicAny.DynSequence.Impl.Internals.Create (Value, Parent); when Tk_Struct | Tk_Except => return DynamicAny.DynStruct.Impl.Internals.Create (Value, Parent); when Tk_Union => return DynamicAny.DynUnion.Impl.Internals.Create (Value, Parent); when Tk_Value => return DynamicAny.DynValue.Impl.Internals.Create (Value, Allow_Truncate, Parent); when Tk_Valuebox => return DynamicAny.DynValueBox.Impl.Internals.Create (Value, Parent); when Tk_Principal | Tk_Native => DynamicAny.DynAnyFactory.Helper.Raise_InconsistentTypeCode ((CORBA.IDL_Exception_Members with null record)); when Tk_Local_Interface | Tk_Component | Tk_Home | Tk_Event => -- XXX Not yet implemented raise Program_Error; when Tk_Alias => -- This should never happen raise Program_Error; end case; end Create; end PolyORB.CORBA_P.Dynamic_Any; polyorb-2.8~20110207.orig/src/corba/dynamicany/dynamicany-dynstruct-impl.ads0000644000175000017500000000673311750740340026245 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- D Y N A M I C A N Y . D Y N S T R U C T . I M P L -- -- -- -- S p e c -- -- -- -- Copyright (C) 2005-2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with PolyORB.Any; with DynamicAny.DynAny.Impl; package DynamicAny.DynStruct.Impl is type Object is new DynamicAny.DynAny.Impl.Object with private; type Object_Ptr is access all Object'Class; function Current_Member_Name (Self : access Object) return FieldName; function Current_Member_Kind (Self : access Object) return CORBA.TCKind; function Get_Members (Self : access Object) return NameValuePairSeq; procedure Set_Members (Self : access Object; Value : NameValuePairSeq); function Get_Members_As_Dyn_Any (Self : access Object) return NameDynAnyPairSeq; procedure Set_Members_As_Dyn_Any (Self : access Object; Value : NameDynAnyPairSeq); function Is_A (Self : not null access Object; Logical_Type_Id : Standard.String) return Boolean; package Internals is procedure Initialize (Self : access Object'Class; Value : PolyORB.Any.Any; Parent : DynAny.Impl.Object_Ptr); procedure Initialize (Self : access Object'Class; IDL_Type : PolyORB.Any.TypeCode.Local_Ref); function Create (Value : CORBA.Any; Parent : DynAny.Impl.Object_Ptr) return DynAny.Local_Ref; function Create (Value : PolyORB.Any.TypeCode.Local_Ref) return DynAny.Local_Ref; end Internals; private type Object is new DynamicAny.DynAny.Impl.Object with record null; end record; end DynamicAny.DynStruct.Impl; polyorb-2.8~20110207.orig/src/corba/dynamicany/dynamicany-dynvaluebox-impl.adb0000644000175000017500000001430011750740340026512 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- D Y N A M I C A N Y . D Y N V A L U E B O X . I M P L -- -- -- -- B o d y -- -- -- -- Copyright (C) 2005-2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with PolyORB.Smart_Pointers; with DynamicAny.DynValueCommon; package body DynamicAny.DynValueBox.Impl is use PolyORB.Any; use PolyORB.Any.TypeCode; function Is_Destroyed (Self : access DynAny.Impl.Object'Class) return Boolean renames DynAny.Impl.Internals.Is_Destroyed; --------------------- -- Get_Boxed_Value -- --------------------- function Get_Boxed_Value (Self : access Object) return CORBA.Any is Result : CORBA.Any; begin if Is_Destroyed (Self) then CORBA.Raise_Object_Not_Exist (CORBA.Default_Sys_Member); end if; raise Program_Error; return Result; end Get_Boxed_Value; -------------------------------- -- Get_Boxed_Value_As_Dyn_Any -- -------------------------------- function Get_Boxed_Value_As_Dyn_Any (Self : access Object) return DynAny.Local_Ref is Result : DynamicAny.DynAny.Local_Ref; begin if Is_Destroyed (Self) then CORBA.Raise_Object_Not_Exist (CORBA.Default_Sys_Member); end if; raise Program_Error; return Result; end Get_Boxed_Value_As_Dyn_Any; --------------- -- Internals -- --------------- package body Internals is ------------ -- Create -- ------------ function Create (Value : CORBA.Any; Parent : DynAny.Impl.Object_Ptr) return DynAny.Local_Ref is Obj : constant Object_Ptr := new Object; Result : DynAny.Local_Ref; begin pragma Assert (Kind (CORBA.Get_Type (Value)) = Tk_Valuebox); Initialize (Obj, PolyORB.Any.Any (Value), Parent); DynAny.Set (Result, PolyORB.Smart_Pointers.Entity_Ptr (Obj)); return Result; end Create; function Create (Value : PolyORB.Any.TypeCode.Local_Ref) return DynAny.Local_Ref is Obj : constant Object_Ptr := new Object; Result : DynAny.Local_Ref; begin pragma Assert (Kind (Value) = Tk_Valuebox); Initialize (Obj, Value); DynAny.Set (Result, PolyORB.Smart_Pointers.Entity_Ptr (Obj)); return Result; end Create; ---------------- -- Initialize -- ---------------- procedure Initialize (Self : access Object'Class; IDL_Type : PolyORB.Any.TypeCode.Local_Ref) is begin DynValueCommon.Impl.Internals.Initialize (Self, IDL_Type); end Initialize; procedure Initialize (Self : access Object'Class; Value : PolyORB.Any.Any; Parent : DynAny.Impl.Object_Ptr) is begin DynValueCommon.Impl.Internals.Initialize (Self, Value, Parent); end Initialize; end Internals; ---------- -- Is_A -- ---------- function Is_A (Self : not null access Object; Logical_Type_Id : Standard.String) return Boolean is pragma Unreferenced (Self); begin return CORBA.Is_Equivalent (Logical_Type_Id, DynamicAny.DynValueBox.Repository_Id) or else CORBA.Is_Equivalent (Logical_Type_Id, DynamicAny.DynValueCommon.Repository_Id) or else CORBA.Is_Equivalent (Logical_Type_Id, DynamicAny.DynAny.Repository_Id) or else CORBA.Is_Equivalent (Logical_Type_Id, "IDL:omg.org/CORBA/Object:1.0"); end Is_A; --------------------- -- Set_Boxed_Value -- --------------------- procedure Set_Boxed_Value (Self : access Object; Boxed : CORBA.Any) is pragma Unreferenced (Boxed); begin if Is_Destroyed (Self) then CORBA.Raise_Object_Not_Exist (CORBA.Default_Sys_Member); end if; raise Program_Error; end Set_Boxed_Value; -------------------------------- -- Set_Boxed_Value_As_Dyn_Any -- -------------------------------- procedure Set_Boxed_Value_As_Dyn_Any (Self : access Object; Boxed : DynAny.Local_Ref) is pragma Unreferenced (Boxed); begin if Is_Destroyed (Self) then CORBA.Raise_Object_Not_Exist (CORBA.Default_Sys_Member); end if; raise Program_Error; end Set_Boxed_Value_As_Dyn_Any; end DynamicAny.DynValueBox.Impl; polyorb-2.8~20110207.orig/src/corba/dynamicany/dynamicany-dynvaluebox-impl.ads0000644000175000017500000000660611750740340026545 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- D Y N A M I C A N Y . D Y N V A L U E B O X . I M P L -- -- -- -- S p e c -- -- -- -- Copyright (C) 2005-2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with PolyORB.Any; with DynamicAny.DynAny.Impl; with DynamicAny.DynValueCommon.Impl; package DynamicAny.DynValueBox.Impl is type Object is new DynamicAny.DynValueCommon.Impl.Object with private; type Object_Ptr is access all Object'Class; function Get_Boxed_Value (Self : access Object) return CORBA.Any; procedure Set_Boxed_Value (Self : access Object; Boxed : CORBA.Any); function Get_Boxed_Value_As_Dyn_Any (Self : access Object) return DynAny.Local_Ref; procedure Set_Boxed_Value_As_Dyn_Any (Self : access Object; Boxed : DynAny.Local_Ref); function Is_A (Self : not null access Object; Logical_Type_Id : Standard.String) return Boolean; package Internals is procedure Initialize (Self : access Object'Class; Value : PolyORB.Any.Any; Parent : DynAny.Impl.Object_Ptr); procedure Initialize (Self : access Object'Class; IDL_Type : PolyORB.Any.TypeCode.Local_Ref); function Create (Value : CORBA.Any; Parent : DynAny.Impl.Object_Ptr) return DynAny.Local_Ref; function Create (Value : PolyORB.Any.TypeCode.Local_Ref) return DynAny.Local_Ref; end Internals; private type Object is new DynamicAny.DynValueCommon.Impl.Object with record null; end record; end DynamicAny.DynValueBox.Impl; polyorb-2.8~20110207.orig/src/corba/dynamicany/dynamicany-dynfixed-impl.ads0000644000175000017500000000623411750740340026014 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- D Y N A M I C A N Y . D Y N F I X E D . I M P L -- -- -- -- S p e c -- -- -- -- Copyright (C) 2005-2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with PolyORB.Any; with DynamicAny.DynAny.Impl; package DynamicAny.DynFixed.Impl is type Object is new DynamicAny.DynAny.Impl.Object with private; type Object_Ptr is access all Object'Class; function Get_Value (Self : access Object) return CORBA.String; function Set_Value (Self : access Object; Val : CORBA.String) return CORBA.Boolean; function Is_A (Self : not null access Object; Logical_Type_Id : Standard.String) return Boolean; package Internals is procedure Initialize (Self : access Object'Class; Value : PolyORB.Any.Any; Parent : DynAny.Impl.Object_Ptr); procedure Initialize (Self : access Object'Class; IDL_Type : PolyORB.Any.TypeCode.Local_Ref); function Create (Value : CORBA.Any; Parent : DynAny.Impl.Object_Ptr) return DynAny.Local_Ref; function Create (Value : PolyORB.Any.TypeCode.Local_Ref) return DynAny.Local_Ref; end Internals; private type Object is new DynamicAny.DynAny.Impl.Object with record null; end record; end DynamicAny.DynFixed.Impl; polyorb-2.8~20110207.orig/src/corba/dynamicany/dynamicany-dynanyfactory-impl.ads0000644000175000017500000000606711750740340027100 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- D Y N A M I C A N Y . D Y N A N Y F A C T O R Y . I M P L -- -- -- -- S p e c -- -- -- -- Copyright (C) 2005-2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with CORBA.Local; package DynamicAny.DynAnyFactory.Impl is type Object is new CORBA.Local.Object with private; type Object_Ptr is access all Object'Class; function Create_Dyn_Any (Self : access Object; Value : CORBA.Any) return DynAny.Local_Ref; function Create_Dyn_Any_From_Type_Code (Self : access Object; IDL_Type : CORBA.TypeCode.Object) return DynAny.Local_Ref; function Create_Dyn_Any_Without_Truncation (Self : access Object; Value : CORBA.Any) return DynAny.Local_Ref; function Create_Multiple_Dyn_Anys (Self : access Object; Values : AnySeq; Allow_Truncate : CORBA.Boolean) return DynamicAny.DynAnySeq; function Create_Multiple_Anys (Self : access Object; Values : DynAnySeq) return AnySeq; function Is_A (Self : not null access Object; Logical_Type_Id : Standard.String) return Boolean; private type Object is new CORBA.Local.Object with null record; end DynamicAny.DynAnyFactory.Impl; polyorb-2.8~20110207.orig/src/corba/corba.ads0000644000175000017500000012124711750740340020045 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- C O R B A -- -- -- -- S p e c -- -- -- -- Copyright (C) 2001-2010, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the CORBA Specification, and adapted -- -- for use with PolyORB. The copyright notice above, and the license -- -- provisions that follow apply solely to the contents neither explicitly -- -- nor implicitly specified by the CORBA Specification defined by the OMG. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with Ada.Exceptions; with Ada.Strings.Unbounded; with Ada.Strings.Wide_Unbounded; with Ada.Unchecked_Deallocation; with Interfaces; with PolyORB.Any; with PolyORB.Errors; with PolyORB.Types; package CORBA is -- CORBA Module: In order to prevent names defined with the CORBA -- specification from clashing with names in programming languages and -- other software systems, all names defined by CORBA are treated as if -- they were defined with a module named CORBA. -- Each IDL data type is mapped to a native data type via the -- appropriate language mapping. The following definitions may -- differ. See the mapping specification for more information. type Short is new Interfaces.Integer_16; type Long is new Interfaces.Integer_32; type Long_Long is new Interfaces.Integer_64; type Unsigned_Short is new Interfaces.Unsigned_16; type Unsigned_Long is new Interfaces.Unsigned_32; type Unsigned_Long_Long is new Interfaces.Unsigned_64; type Float is new Interfaces.IEEE_Float_32; type Double is new Interfaces.IEEE_Float_64; type Long_Double is new Interfaces.IEEE_Extended_Float; subtype Char is Standard.Character; subtype Wchar is Standard.Wide_Character; type Octet is new Interfaces.Unsigned_8; subtype Boolean is Standard.Boolean; type String is new PolyORB.Types.String; type Wide_String is new Ada.Strings.Wide_Unbounded.Unbounded_Wide_String; -- Pointers on the previous types type Short_Ptr is access all Short; type Long_Ptr is access all Long; type Long_Long_Ptr is access all Long_Long; type Unsigned_Short_Ptr is access all Unsigned_Short; type Unsigned_Long_Ptr is access all Unsigned_Long; type Unsigned_Long_Long_Ptr is access all Unsigned_Long_Long; type Float_Ptr is access all Float; type Double_Ptr is access all Double; type Long_Double_Ptr is access all Long_Double; type Char_Ptr is access all Char; type Wchar_Ptr is access all Wchar; type Octet_Ptr is access all Octet; type Boolean_Ptr is access all Boolean; type String_Ptr is access all String; type Wide_String_Ptr is access all Wide_String; -- ... and deallocation method for each pointer type procedure Deallocate is new Ada.Unchecked_Deallocation (Short, Short_Ptr); procedure Deallocate is new Ada.Unchecked_Deallocation (Long, Long_Ptr); procedure Deallocate is new Ada.Unchecked_Deallocation (Long_Long, Long_Long_Ptr); procedure Deallocate is new Ada.Unchecked_Deallocation (Unsigned_Short, Unsigned_Short_Ptr); procedure Deallocate is new Ada.Unchecked_Deallocation (Unsigned_Long, Unsigned_Long_Ptr); procedure Deallocate is new Ada.Unchecked_Deallocation (Unsigned_Long_Long, Unsigned_Long_Long_Ptr); procedure Deallocate is new Ada.Unchecked_Deallocation (Float, Float_Ptr); procedure Deallocate is new Ada.Unchecked_Deallocation (Double, Double_Ptr); procedure Deallocate is new Ada.Unchecked_Deallocation (Long_Double, Long_Double_Ptr); procedure Deallocate is new Ada.Unchecked_Deallocation (Char, Char_Ptr); procedure Deallocate is new Ada.Unchecked_Deallocation (Wchar, Wchar_Ptr); procedure Deallocate is new Ada.Unchecked_Deallocation (Octet, Octet_Ptr); procedure Deallocate is new Ada.Unchecked_Deallocation (Boolean, Boolean_Ptr); procedure Deallocate is new Ada.Unchecked_Deallocation (String, String_Ptr); procedure Deallocate is new Ada.Unchecked_Deallocation (Wide_String, Wide_String_Ptr); --------------------------------- -- String conversion functions -- --------------------------------- function To_CORBA_String (Source : Standard.String) return CORBA.String; Null_String : constant CORBA.String := CORBA.String (Ada.Strings.Unbounded.To_Unbounded_String ("")); function To_CORBA_Wide_String (Source : Standard.Wide_String) return CORBA.Wide_String; function To_Standard_Wide_String (Source : CORBA.Wide_String) return Standard.Wide_String; Null_Wide_String : constant CORBA.Wide_String := CORBA.Wide_String (Ada.Strings.Wide_Unbounded.To_Unbounded_Wide_String ("")); ----------- -- Types -- ----------- type Identifier is new PolyORB.Types.Identifier; function To_CORBA_String (Source : Standard.String) return Identifier; Null_Identifier : constant Identifier := Identifier (Null_String); type RepositoryId is new CORBA.String; Null_RepositoryId : constant RepositoryId := RepositoryId (Null_String); type ScopedName is new CORBA.String; Null_ScopedName : constant ScopedName := ScopedName (Null_String); ---------------- -- Exceptions -- ---------------- subtype IDL_Exception_Members is PolyORB.Errors.Exception_Members; -- Base type for all CORBA exception members. A member is a record attached -- to an exception that allows the programmer to pass arguments when an -- exception is raised. The default Member record is abstract and empty but -- all other records will inherit from it. -- procedure Get_Members -- (From : Ada.Exceptions.Exception_Occurrence; -- To : out IDL_Exception_Members) is abstract; -- Return the member corresponding to an exception occurence. -- There is no abstract dispatching operation; this is defined only -- for derived types of Exception_Members. type Completion_Status is new PolyORB.Errors.Completion_Status; -- Characterization the state of execution when an exception occurs type Exception_Type is (No_Exception, System_Exception, User_Exception); -- Type used for characterize exceptions. ----------------------- -- System Exceptions -- ----------------------- OMGVMCID : constant CORBA.Unsigned_Long := 16#4f4d0000#; -- The CORBA speficiations mandate that the actual value for the -- minor field of system exceptions is obtained by or-ing the -- value with this constant, for all values defined in CORBA A.5. Unknown : exception; -- unknown exception Bad_Param : exception; -- an invalid parameter was passed No_Memory : exception; -- dynamic memory allocation failure Imp_Limit : exception; -- violated implementation limit Comm_Failure : exception; -- communication failure Inv_Objref : exception; -- invalid object reference No_Permission : exception; -- no permission for attempted op Internal : exception; -- ORB internal error Marshal : exception; -- error marshalling param/result Initialize : exception; -- ORB initialization failure No_Implement : exception; -- operation impleme. unavailable Bad_TypeCode : exception; -- bad typecode Bad_Operation : exception; -- invalid operation No_Resources : exception; -- insufficient resources for req No_Response : exception; -- response to request not available Persist_Store : exception; -- persistent storage failure Bad_Inv_Order : exception; -- routine invocations out of order Transient : exception; -- transient failure - reissue request Free_Mem : exception; -- cannot free memory Inv_Ident : exception; -- invalid identifier syntax Inv_Flag : exception; -- invalid flag was specified Intf_Repos : exception; -- error accessing intf. repository Bad_Context : exception; -- error processing context object Obj_Adapter : exception; -- failure detected by object adapter Data_Conversion : exception; -- data conversion error Object_Not_Exist : exception; -- non-existent object or deleted ref Transaction_Required : exception; -- transaction required Transaction_Rolledback : exception; -- transaction rolled back Invalid_Transaction : exception; -- invalid transaction Inv_Policy : exception; -- invalid policy Codeset_Incompatible : exception; -- incompatible code set Rebind : exception; -- rebind needed Timeout : exception; -- operation timed out Transaction_Unavailable : exception; -- no transaction Transaction_Mode : exception; -- invalid transaction mode Bad_Qos : exception; -- bad quality of service Initialization_Failure : exception renames Initialize; -- Implementation Note: this exception is defined in the Ada mapping -- specification, not in the CORBA specification itself. type System_Exception_Members is new PolyORB.Errors.Exception_Members with record Minor : CORBA.Unsigned_Long; Completed : CORBA.Completion_Status; end record; procedure Get_Members (From : Ada.Exceptions.Exception_Occurrence; To : out System_Exception_Members); -- Return the member corresponding to a system exception occurence. -- The following procedures are used to raise specific system exceptions procedure Raise_Unknown (Excp_Memb : System_Exception_Members; Message : Standard.String := ""); pragma No_Return (Raise_Unknown); procedure Raise_Bad_Param (Excp_Memb : System_Exception_Members; Message : Standard.String := ""); pragma No_Return (Raise_Bad_Param); procedure Raise_No_Memory (Excp_Memb : System_Exception_Members; Message : Standard.String := ""); pragma No_Return (Raise_No_Memory); procedure Raise_Imp_Limit (Excp_Memb : System_Exception_Members; Message : Standard.String := ""); pragma No_Return (Raise_Imp_Limit); procedure Raise_Comm_Failure (Excp_Memb : System_Exception_Members; Message : Standard.String := ""); pragma No_Return (Raise_Comm_Failure); procedure Raise_Inv_Objref (Excp_Memb : System_Exception_Members; Message : Standard.String := ""); pragma No_Return (Raise_Inv_Objref); procedure Raise_No_Permission (Excp_Memb : System_Exception_Members; Message : Standard.String := ""); pragma No_Return (Raise_No_Permission); procedure Raise_Internal (Excp_Memb : System_Exception_Members; Message : Standard.String := ""); pragma No_Return (Raise_Internal); procedure Raise_Marshal (Excp_Memb : System_Exception_Members; Message : Standard.String := ""); pragma No_Return (Raise_Marshal); procedure Raise_Initialize (Excp_Memb : System_Exception_Members; Message : Standard.String := ""); pragma No_Return (Raise_Initialize); procedure Raise_No_Implement (Excp_Memb : System_Exception_Members; Message : Standard.String := ""); pragma No_Return (Raise_No_Implement); procedure Raise_Bad_TypeCode (Excp_Memb : System_Exception_Members; Message : Standard.String := ""); pragma No_Return (Raise_Bad_TypeCode); procedure Raise_Bad_Operation (Excp_Memb : System_Exception_Members; Message : Standard.String := ""); pragma No_Return (Raise_Bad_Operation); procedure Raise_No_Resources (Excp_Memb : System_Exception_Members; Message : Standard.String := ""); pragma No_Return (Raise_No_Resources); procedure Raise_No_Response (Excp_Memb : System_Exception_Members; Message : Standard.String := ""); pragma No_Return (Raise_No_Response); procedure Raise_Persist_Store (Excp_Memb : System_Exception_Members; Message : Standard.String := ""); pragma No_Return (Raise_Persist_Store); procedure Raise_Bad_Inv_Order (Excp_Memb : System_Exception_Members; Message : Standard.String := ""); pragma No_Return (Raise_Bad_Inv_Order); procedure Raise_Transient (Excp_Memb : System_Exception_Members; Message : Standard.String := ""); pragma No_Return (Raise_Transient); procedure Raise_Free_Mem (Excp_Memb : System_Exception_Members; Message : Standard.String := ""); pragma No_Return (Raise_Free_Mem); procedure Raise_Inv_Ident (Excp_Memb : System_Exception_Members; Message : Standard.String := ""); pragma No_Return (Raise_Inv_Ident); procedure Raise_Inv_Flag (Excp_Memb : System_Exception_Members; Message : Standard.String := ""); pragma No_Return (Raise_Inv_Flag); procedure Raise_Intf_Repos (Excp_Memb : System_Exception_Members; Message : Standard.String := ""); pragma No_Return (Raise_Intf_Repos); procedure Raise_Bad_Context (Excp_Memb : System_Exception_Members; Message : Standard.String := ""); pragma No_Return (Raise_Bad_Context); procedure Raise_Obj_Adapter (Excp_Memb : System_Exception_Members; Message : Standard.String := ""); pragma No_Return (Raise_Obj_Adapter); procedure Raise_Data_Conversion (Excp_Memb : System_Exception_Members; Message : Standard.String := ""); pragma No_Return (Raise_Data_Conversion); procedure Raise_Object_Not_Exist (Excp_Memb : System_Exception_Members; Message : Standard.String := ""); pragma No_Return (Raise_Object_Not_Exist); procedure Raise_Transaction_Required (Excp_Memb : System_Exception_Members; Message : Standard.String := ""); pragma No_Return (Raise_Transaction_Required); procedure Raise_Transaction_Rolledback (Excp_Memb : System_Exception_Members; Message : Standard.String := ""); pragma No_Return (Raise_Transaction_Rolledback); procedure Raise_Invalid_Transaction (Excp_Memb : System_Exception_Members; Message : Standard.String := ""); pragma No_Return (Raise_Invalid_Transaction); procedure Raise_Inv_Policy (Excp_Memb : System_Exception_Members; Message : Standard.String := ""); pragma No_Return (Raise_Inv_Policy); procedure Raise_Codeset_Incompatible (Excp_Memb : System_Exception_Members; Message : Standard.String := ""); pragma No_Return (Raise_Codeset_Incompatible); procedure Raise_Rebind (Excp_Memb : System_Exception_Members; Message : Standard.String := ""); pragma No_Return (Raise_Rebind); procedure Raise_Timeout (Excp_Memb : System_Exception_Members; Message : Standard.String := ""); pragma No_Return (Raise_Timeout); procedure Raise_Transaction_Unavailable (Excp_Memb : System_Exception_Members; Message : Standard.String := ""); pragma No_Return (Raise_Transaction_Unavailable); procedure Raise_Transaction_Mode (Excp_Memb : System_Exception_Members; Message : Standard.String := ""); pragma No_Return (Raise_Transaction_Mode); procedure Raise_Bad_Qos (Excp_Memb : System_Exception_Members; Message : Standard.String := ""); pragma No_Return (Raise_Bad_Qos); procedure Raise_Initialization_Failure (Excp_Memb : System_Exception_Members; Message : Standard.String := "") renames Raise_Initialize; Default_Sys_Member : constant System_Exception_Members := System_Exception_Members'(Minor => 0, Completed => CORBA.Completed_No); type Unknown_Members is new System_Exception_Members with null record; type Bad_Param_Members is new System_Exception_Members with null record; type No_Memory_Members is new System_Exception_Members with null record; type Imp_Limit_Members is new System_Exception_Members with null record; type Comm_Failure_Members is new System_Exception_Members with null record; type Inv_Objref_Members is new System_Exception_Members with null record; type No_Permission_Members is new System_Exception_Members with null record; type Internal_Members is new System_Exception_Members with null record; type Marshal_Members is new System_Exception_Members with null record; type Initialize_Members is new System_Exception_Members with null record; type No_Implement_Members is new System_Exception_Members with null record; type Bad_Typecode_Members is new System_Exception_Members with null record; type Bad_Operation_Members is new System_Exception_Members with null record; type No_Resources_Members is new System_Exception_Members with null record; type No_Response_Members is new System_Exception_Members with null record; type Persist_Store_Members is new System_Exception_Members with null record; type Bad_Inv_Order_Members is new System_Exception_Members with null record; type Transient_Members is new System_Exception_Members with null record; type Free_Mem_Members is new System_Exception_Members with null record; type Inv_Ident_Members is new System_Exception_Members with null record; type Inv_Flag_Members is new System_Exception_Members with null record; type Intf_Repos_Members is new System_Exception_Members with null record; type Bad_Context_Members is new System_Exception_Members with null record; type Obj_Adapter_Members is new System_Exception_Members with null record; type Data_Conversion_Members is new System_Exception_Members with null record; type Object_Not_Exist_Members is new System_Exception_Members with null record; type Transaction_Required_Members is new System_Exception_Members with null record; type Transaction_Rolledback_Members is new System_Exception_Members with null record; type Invalid_Transaction_Members is new System_Exception_Members with null record; type Inv_Policy_Members is new System_Exception_Members with null record; type Codeset_Incompatible_Members is new System_Exception_Members with null record; type Rebind_Members is new System_Exception_Members with null record; type Timeout_Members is new System_Exception_Members with null record; type Transaction_Unavailable_Members is new System_Exception_Members with null record; type Transaction_Mode_Members is new System_Exception_Members with null record; type Bad_Qos_Members is new System_Exception_Members with null record; subtype Initialization_Failure_Members is Initialize_Members; ------------ -- Policy -- ------------ -- Defined in 4.7 type PolicyType is new CORBA.Unsigned_Long; type PolicyErrorCode is new CORBA.Short; BAD_POLICY : constant PolicyErrorCode := PolicyErrorCode'(0); UNSUPPORTED_POLICY : constant PolicyErrorCode := PolicyErrorCode'(1); BAD_POLICY_TYPE : constant PolicyErrorCode := PolicyErrorCode'(2); BAD_POLICY_VALUE : constant PolicyErrorCode := PolicyErrorCode'(3); UNSUPPORTED_POLICY_VALUE : constant PolicyErrorCode := PolicyErrorCode'(4); type SetOverrideType is (SET_OVERRIDE, ADD_OVERRIDE); -------------------- -- ORB Exceptions -- -------------------- -- exception PolicyError PolicyError : exception; type PolicyError_Members is new CORBA.IDL_Exception_Members with record Reason : PolicyErrorCode; end record; procedure Get_Members (From : Ada.Exceptions.Exception_Occurrence; To : out PolicyError_Members); -- exception InvalidName InvalidName : exception; type InvalidName_Members is new CORBA.IDL_Exception_Members with null record; procedure Get_Members (From : Ada.Exceptions.Exception_Occurrence; To : out InvalidName_Members); -- exception InconsistentTypeCode InconsistentTypeCode : exception; type InconsistentTypeCode_Members is new CORBA.IDL_Exception_Members with null record; procedure Get_Members (From : Ada.Exceptions.Exception_Occurrence; To : out InconsistentTypeCode_Members); ------------------------- -- Types and constants -- ------------------------- type ServiceType is new CORBA.Unsigned_Short; type ServiceOption is new CORBA.Unsigned_Long; type ServiceDetailType is new CORBA.Unsigned_Long; Security : constant ServiceType := 1; --------- -- Any -- --------- type Any is new PolyORB.Any.Any; --------------- -- TypeCodes -- --------------- -- See spec CORBA V2.3, Ada Langage Mapping 1.33 subtype TCKind is PolyORB.Any.TCKind; -- Accessors functions on TCKind values -- -- Implementation Note: these function are defined to allow -- visibility on the different TCKind values. function Tk_Null return TCKind renames PolyORB.Any.Tk_Null; function Tk_Void return TCKind renames PolyORB.Any.Tk_Void; function Tk_Short return TCKind renames PolyORB.Any.Tk_Short; function Tk_Long return TCKind renames PolyORB.Any.Tk_Long; function Tk_Ushort return TCKind renames PolyORB.Any.Tk_Ushort; function Tk_Ulong return TCKind renames PolyORB.Any.Tk_Ulong; function Tk_Float return TCKind renames PolyORB.Any.Tk_Float; function Tk_Double return TCKind renames PolyORB.Any.Tk_Double; function Tk_Boolean return TCKind renames PolyORB.Any.Tk_Boolean; function Tk_Char return TCKind renames PolyORB.Any.Tk_Char; function Tk_Octet return TCKind renames PolyORB.Any.Tk_Octet; function Tk_Any return TCKind renames PolyORB.Any.Tk_Any; function Tk_TypeCode return TCKind renames PolyORB.Any.Tk_TypeCode; function Tk_Principal return TCKind renames PolyORB.Any.Tk_Principal; function Tk_Objref return TCKind renames PolyORB.Any.Tk_Objref; function Tk_Struct return TCKind renames PolyORB.Any.Tk_Struct; function Tk_Union return TCKind renames PolyORB.Any.Tk_Union; function Tk_Enum return TCKind renames PolyORB.Any.Tk_Enum; function Tk_String return TCKind renames PolyORB.Any.Tk_String; function Tk_Sequence return TCKind renames PolyORB.Any.Tk_Sequence; function Tk_Array return TCKind renames PolyORB.Any.Tk_Array; function Tk_Alias return TCKind renames PolyORB.Any.Tk_Alias; function Tk_Except return TCKind renames PolyORB.Any.Tk_Except; function Tk_Longlong return TCKind renames PolyORB.Any.Tk_Longlong; function Tk_Ulonglong return TCKind renames PolyORB.Any.Tk_Ulonglong; function Tk_Longdouble return TCKind renames PolyORB.Any.Tk_Longdouble; function Tk_Widechar return TCKind renames PolyORB.Any.Tk_Widechar; function Tk_Wstring return TCKind renames PolyORB.Any.Tk_Wstring; function Tk_Fixed return TCKind renames PolyORB.Any.Tk_Fixed; function Tk_Value return TCKind renames PolyORB.Any.Tk_Value; function Tk_Valuebox return TCKind renames PolyORB.Any.Tk_Valuebox; function Tk_Native return TCKind renames PolyORB.Any.Tk_Native; function Tk_Abstract_Interface return TCKind renames PolyORB.Any.Tk_Abstract_Interface; subtype ValueModifier is PolyORB.Any.ValueModifier; VTM_NONE : constant ValueModifier; VTM_CUSTOM : constant ValueModifier; VTM_ABSTRACT : constant ValueModifier; VTM_TRUNCATABLE : constant ValueModifier; -- Implementation Note: see CORBA.Repository_Root for a discussion -- of the issue with the declaration of the Visibility type. subtype Visibility is PolyORB.Any.Visibility; PRIVATE_MEMBER : constant Visibility; PUBLIC_MEMBER : constant Visibility; package TypeCode is type Object is private; -- Mandated by standard mapping. Note that this pseudo-object cannot -- be made limited, and we cannot force the usage of a proper ref -- type on the CORBA side. -- exception Bounds Bounds : exception; type Bounds_Members is new CORBA.IDL_Exception_Members with null record; procedure Get_Members (From : Ada.Exceptions.Exception_Occurrence; To : out Bounds_Members); -- exception BadKind BadKind : exception; type BadKind_Members is new CORBA.IDL_Exception_Members with null record; procedure Get_Members (From : Ada.Exceptions.Exception_Occurrence; To : out BadKind_Members); function "=" (Left, Right : Object) return Boolean; function Equal (Left, Right : Object) return Boolean renames "="; function Equivalent (Left, Right : Object) return Boolean; function Get_Compact_TypeCode (Self : Object) return Object; -- XXX not implemented function Kind (Self : Object) return TCKind; function Id (Self : Object) return RepositoryId; function Name (Self : Object) return Identifier; function Member_Count (Self : Object) return Unsigned_Long; function Member_Name (Self : Object; Index : Unsigned_Long) return Identifier; function Member_Type (Self : Object; Index : Unsigned_Long) return Object; function Member_Label (Self : Object; Index : Unsigned_Long) return Any; function Discriminator_Type (Self : Object) return Object; function Default_Index (Self : Object) return Long; function Length (Self : Object) return Unsigned_Long; function Content_Type (Self : Object) return Object; function Fixed_Digits (Self : Object) return Unsigned_Short; function Fixed_Scale (Self : Object) return Short; function Member_Visibility (Self : Object; Index : Unsigned_Long) return Visibility; function Type_Modifier (Self : Object) return ValueModifier; function Concrete_Base_Type (Self : Object) return Object; package Internals is -- Internal implementation subprograms. These shall not be -- used outside of PolyORB. procedure Set_Kind (Self : out Object; Kind : TCKind); -- Return a typecode of kind Kind, with an empty parameter list procedure Add_Parameter (Self : in out Object; Param : Any); -- Add the parameter Param in the list of Self's parameters function To_PolyORB_Object (Self : CORBA.TypeCode.Object) return PolyORB.Any.TypeCode.Local_Ref; function To_CORBA_Object (Self : PolyORB.Any.TypeCode.Local_Ref) return CORBA.TypeCode.Object; function Is_Nil (Self : CORBA.TypeCode.Object) return Boolean; -- True when Self has not been initialized to contain any typecode -- information. procedure Disable_Reference_Counting (Self : CORBA.TypeCode.Object); -- Disable reference counting on the underlying storage of Self -- (meant to be used for library-level typecode objects). function Build_Alias_TC (Name, Id : CORBA.String; Parent : Object) return Object; function Build_Sequence_TC (Element_TC : Object; Max : Natural) return Object; function Build_String_TC (Max : CORBA.Unsigned_Long) return Object; function Build_Wstring_TC (Max : CORBA.Unsigned_Long) return Object; -- ??? Should use CORBA.ORB.Create_*_Tc instead of these function Wrap (X : not null access Object) return PolyORB.Any.Content'Class; private pragma Inline (To_PolyORB_Object); pragma Inline (To_CORBA_Object); end Internals; private type Object is new PolyORB.Any.TypeCode.Local_Ref; -- In the neutral layer, TypeCode.Object is a limited type with -- reference counting. end TypeCode; -- Pre-defined TypeCode "constants" function TC_Null return TypeCode.Object; function TC_Void return TypeCode.Object; function TC_Short return TypeCode.Object; function TC_Long return TypeCode.Object; function TC_Long_Long return TypeCode.Object; function TC_Unsigned_Short return TypeCode.Object; function TC_Unsigned_Long return TypeCode.Object; function TC_Unsigned_Long_Long return TypeCode.Object; function TC_Float return TypeCode.Object; function TC_Double return TypeCode.Object; function TC_Long_Double return TypeCode.Object; function TC_Boolean return TypeCode.Object; function TC_Char return TypeCode.Object; function TC_Wchar return TypeCode.Object; function TC_Octet return TypeCode.Object; function TC_Any return TypeCode.Object; function TC_TypeCode return TypeCode.Object; function TC_String return TypeCode.Object; function TC_Wide_String return TypeCode.Object; -- Implementation Note: function TC_Object is defined in -- CORBA.Object. -- This is the returned exception in case of dynamic invocation UnknownUserException : exception; type UnknownUserException_Members is new CORBA.IDL_Exception_Members with record IDL_Exception : Any; end record; procedure Get_Members (From : Ada.Exceptions.Exception_Occurrence; To : out UnknownUserException_Members); function To_Any (Item : Short) return Any; function To_Any (Item : Long) return Any; function To_Any (Item : Long_Long) return Any; function To_Any (Item : Unsigned_Short) return Any; function To_Any (Item : Unsigned_Long) return Any; function To_Any (Item : Unsigned_Long_Long) return Any; function To_Any (Item : CORBA.Float) return Any; function To_Any (Item : Double) return Any; function To_Any (Item : Long_Double) return Any; -- function To_Any (Item : Boolean) return Any; -- function To_Any (Item : Char) return Any; -- function To_Any (Item : Wchar) return Any; -- function To_Any (Item : Any) return Any; -- Implicitly inherited function To_Any (Item : TypeCode.Object) return Any; function To_Any (Item : Octet) return Any; function To_Any (Item : CORBA.String) return Any; function To_Any (Item : CORBA.Wide_String) return Any; function From_Any (Item : Any) return Short; function From_Any (Item : Any) return Long; function From_Any (Item : Any) return Long_Long; function From_Any (Item : Any) return Unsigned_Short; function From_Any (Item : Any) return Unsigned_Long; function From_Any (Item : Any) return Unsigned_Long_Long; function From_Any (Item : Any) return CORBA.Float; function From_Any (Item : Any) return Double; function From_Any (Item : Any) return Long_Double; -- function From_Any (Item : Any) return Boolean; -- function From_Any (Item : Any) return Char; -- function From_Any (Item : Any) return Wchar; -- function From_Any (Item : Any) return Any; -- Implicitly inherited function From_Any (Item : Any) return TypeCode.Object; function From_Any (Item : Any) return Octet; function From_Any (Item : Any) return CORBA.String; function From_Any (Item : Any) return CORBA.Wide_String; subtype Any_Container is PolyORB.Any.Any_Container; function From_Any (Item : Any_Container'Class) return Short; function From_Any (Item : Any_Container'Class) return Long; function From_Any (Item : Any_Container'Class) return Long_Long; function From_Any (Item : Any_Container'Class) return Unsigned_Short; function From_Any (Item : Any_Container'Class) return Unsigned_Long; function From_Any (Item : Any_Container'Class) return Unsigned_Long_Long; function From_Any (Item : Any_Container'Class) return CORBA.Float; function From_Any (Item : Any_Container'Class) return Double; function From_Any (Item : Any_Container'Class) return Long_Double; function From_Any (Item : Any_Container'Class) return Boolean; function From_Any (Item : Any_Container'Class) return Char; function From_Any (Item : Any_Container'Class) return Wchar; function From_Any (Item : Any_Container'Class) return Octet; -- function From_Any (Item : Any_Container'Class) return Any; -- Implicitly inherited function From_Any (Item : Any_Container'Class) return TypeCode.Object; function From_Any (Item : Any_Container'Class) return CORBA.String; function From_Any (Item : Any_Container'Class) return CORBA.Wide_String; subtype Content is PolyORB.Any.Content; function Wrap (X : not null access Short) return Content'Class; function Wrap (X : not null access Long) return Content'Class; function Wrap (X : not null access Long_Long) return Content'Class; function Wrap (X : not null access Unsigned_Short) return Content'Class; function Wrap (X : not null access Unsigned_Long) return Content'Class; function Wrap (X : not null access Unsigned_Long_Long) return Content'Class; function Wrap (X : not null access CORBA.Float) return Content'Class; function Wrap (X : not null access Double) return Content'Class; function Wrap (X : not null access Long_Double) return Content'Class; function Wrap (X : not null access Boolean) return Content'Class; function Wrap (X : not null access Char) return Content'Class; function Wrap (X : not null access Wchar) return Content'Class; function Wrap (X : not null access Octet) return Content'Class; -- function Wrap (X : not null access Any) return Content'Class; -- Implicitly inherited function Wrap (X : not null access TypeCode.Object) return Content'Class; function Wrap (X : not null access CORBA.String) return Content'Class; function Wrap (X : not null access CORBA.Wide_String) return Content'Class; pragma Inline (Wrap); ---------------- -- NamedValue -- ---------------- type Flags is new CORBA.Unsigned_Long; ARG_IN : constant Flags; ARG_OUT : constant Flags; ARG_INOUT : constant Flags; IN_COPY_VALUE : constant Flags; type NamedValue is record Name : Identifier; Argument : Any; Arg_Modes : Flags; end record; function Image (NV : NamedValue) return Standard.String; -- Return a human-readable image of NV for debugging purposes ------------------ -- RepositoryId -- ------------------ function Is_Equivalent (RI1, RI2 : RepositoryId) return Boolean; function Is_Equivalent (RI1, RI2 : Standard.String) return Boolean; -- Return True if, and only if, RI1 and RI2 denote the same -- repository entity (a case-insensitive string match). -- Helper function for CORBA.Completion_Status function From_Any (Item : CORBA.Any) return CORBA.Completion_Status; function To_Any (Item : CORBA.Completion_Status) return CORBA.Any; function Get_Type (The_Any : Any) return CORBA.TypeCode.Object; -- Return the typecode of The_Any package Internals is -- Implementation Note: This package defines internal subprograms -- specific to PolyORB which should not be used directly from -- application code. function Get_Unwound_Type (The_Any : Any) return PolyORB.Any.TypeCode.Object_Ptr; -- Returns the type of The_Any after unwinding all typedefs procedure Set_Type (The_Any : in out Any; The_Type : TypeCode.Object); -- Change the type of an any without changing its value (to be used -- carefully) function Get_Wrapper_Any (TC : TypeCode.Object; CC : access PolyORB.Any.Content'Class) return Any; -- Return an Any with the specified typecode and contents wrapper function Get_Empty_Any (TC : TypeCode.Object) return Any; function Get_Empty_Any (TC : TypeCode.Object) return PolyORB.Any.Any; -- Return an empty any with the given Typecode but not value function Is_Empty (Any_Value : CORBA.Any) return Boolean; -- True iff Any_Value does not have a value -- Not in spec : some methods to deal with any aggregates. -- What is called any aggregate is an any, made of an aggregate -- of values, instead of one unique. It is used for structs, -- unions, enums, arrays, sequences, objref, values... function Get_Empty_Any_Aggregate (TC : CORBA.TypeCode.Object) return Any; -- Return an Any with an aggregate value containing zero elements and -- having the specified typecode function Get_Aggregate_Count (Value : Any) return CORBA.Unsigned_Long; -- Return the number of elements in an any aggregate procedure Add_Aggregate_Element (Value : in out CORBA.Any; Element : CORBA.Any); -- Append the value of Element to aggregate Value (note that the -- TypeCode of Element is discarded: it is assumed that the necessary -- type information is contained within the typecode of Value. function Get_Aggregate_Element (Value : Any; TC : CORBA.TypeCode.Object; Index : CORBA.Unsigned_Long) return Any; -- Return an any constructed with typecode Tc and the value extracted -- from position Index in aggregate Value procedure Move_Any_Value (Dest : Any; Src : Any); procedure Add_Parameter (TC : TypeCode.Object; Param : Any); private pragma Inline (Get_Aggregate_Count); pragma Inline (Get_Aggregate_Element); end Internals; private VTM_NONE : constant ValueModifier := PolyORB.Any.VTM_NONE; VTM_CUSTOM : constant ValueModifier := PolyORB.Any.VTM_CUSTOM; VTM_ABSTRACT : constant ValueModifier := PolyORB.Any.VTM_ABSTRACT; VTM_TRUNCATABLE : constant ValueModifier := PolyORB.Any.VTM_TRUNCATABLE; PRIVATE_MEMBER : constant Visibility := PolyORB.Any.PRIVATE_MEMBER; PUBLIC_MEMBER : constant Visibility := PolyORB.Any.PUBLIC_MEMBER; function To_CORBA_NV (NV : PolyORB.Any.NamedValue) return NamedValue; pragma Inline (From_Any); pragma Inline (To_Any); pragma Inline (To_CORBA_String); ---------------- -- NamedValue -- ---------------- ARG_IN : constant Flags := Flags (PolyORB.Any.ARG_IN); ARG_OUT : constant Flags := Flags (PolyORB.Any.ARG_OUT); ARG_INOUT : constant Flags := Flags (PolyORB.Any.ARG_INOUT); IN_COPY_VALUE : constant Flags := Flags (PolyORB.Any.IN_COPY_VALUE); end CORBA; polyorb-2.8~20110207.orig/src/corba/corba-sequences-unbounded.ads0000644000175000017500000000500411750740340024007 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- C O R B A . S E Q U E N C E S . U N B O U N D E D -- -- -- -- S p e c -- -- -- -- Copyright (C) 2003-2008, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the CORBA Specification, and adapted -- -- for use with PolyORB. The copyright notice above, and the license -- -- provisions that follow apply solely to the contents neither explicitly -- -- nor implicitly specified by the CORBA Specification defined by the OMG. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with PolyORB.Sequences.Unbounded; generic package CORBA.Sequences.Unbounded renames PolyORB.Sequences.Unbounded; polyorb-2.8~20110207.orig/src/corba/portableserver-servantlocator-impl.adb0000644000175000017500000000767311750740340026006 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O R T A B L E S E R V E R . S E R V A N T L O C A T O R . I M P L -- -- -- -- B o d y -- -- -- -- Copyright (C) 2005-2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ package body PortableServer.ServantLocator.Impl is ---------- -- Is_A -- ---------- function Is_A (Self : not null access Object; Logical_Type_Id : Standard.String) return Boolean is pragma Unreferenced (Self); begin return CORBA.Is_Equivalent (Logical_Type_Id, PortableServer.ServantLocator.Repository_Id) or else CORBA.Is_Equivalent (Logical_Type_Id, PortableServer.ServantManager.Repository_Id) or else CORBA.Is_Equivalent (Logical_Type_Id, "IDL:omg.org/CORBA/Object:1.0"); end Is_A; --------------- -- Preinvoke -- --------------- procedure Preinvoke (Self : access Object; Oid : PortableServer.ObjectId; Adapter : PortableServer.POA_Forward.Ref; Operation : CORBA.Identifier; The_Cookie : out PortableServer.ServantLocator.Cookie; Returns : out PortableServer.Servant) is pragma Unreferenced (Self); pragma Unreferenced (Oid); pragma Unreferenced (Adapter); pragma Unreferenced (Operation); pragma Unreferenced (The_Cookie); pragma Unreferenced (Returns); begin null; end Preinvoke; ---------------- -- Postinvoke -- ---------------- procedure Postinvoke (Self : access Object; Oid : PortableServer.ObjectId; Adapter : PortableServer.POA_Forward.Ref; Operation : CORBA.Identifier; The_Cookie : PortableServer.ServantLocator.Cookie; The_Servant : PortableServer.Servant) is pragma Unreferenced (Self); pragma Unreferenced (Oid); pragma Unreferenced (Adapter); pragma Unreferenced (Operation); pragma Unreferenced (The_Cookie); pragma Unreferenced (The_Servant); begin null; end Postinvoke; end PortableServer.ServantLocator.Impl; polyorb-2.8~20110207.orig/src/corba/portableserver-threadpolicy.ads0000644000175000017500000000540611750740340024501 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O R T A B L E S E R V E R . T H R E A D P O L I C Y -- -- -- -- S p e c -- -- -- -- Copyright (C) 2001-2008, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the CORBA Specification, and adapted -- -- for use with PolyORB. The copyright notice above, and the license -- -- provisions that follow apply solely to the contents neither explicitly -- -- nor implicitly specified by the CORBA Specification defined by the OMG. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with CORBA.Policy; package PortableServer.ThreadPolicy is type Ref is new CORBA.Policy.Ref with private; function To_Ref (The_Ref : CORBA.Object.Ref'Class) return Ref; function Get_Value (Self : Ref) return PortableServer.ThreadPolicyValue; private type Ref is new CORBA.Policy.Ref with null record; end PortableServer.ThreadPolicy; polyorb-2.8~20110207.orig/src/corba/corba-domainmanager.adb0000644000175000017500000001146311750740337022630 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- C O R B A . D O M A I N M A N A G E R -- -- -- -- B o d y -- -- -- -- Copyright (C) 2005-2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with PolyORB.Any.NVList; with PolyORB.Requests; with PolyORB.Types; with CORBA.Helper; with CORBA.Policy.Helper; with PolyORB.CORBA_P.Exceptions; with PolyORB.CORBA_P.Interceptors_Hooks; package body CORBA.DomainManager is ----------------------- -- Get_Domain_Policy -- ----------------------- function Get_Domain_Policy (Self : Ref; Policy_Type : PolicyType) return CORBA.Policy.Ref is Operation_Name : constant Standard.String := "get_domain_policy"; Arg_Name_Policy_Type : constant PolyORB.Types.Identifier := PolyORB.Types.To_PolyORB_String ("policy_type"); Argument_Policy_Type : constant CORBA.Any := CORBA.Helper.To_Any (Policy_Type); Self_Ref : constant CORBA.Object.Ref := CORBA.Object.Ref (Self); Request : aliased PolyORB.Requests.Request; Arg_List : PolyORB.Any.NVList.Ref; Result : PolyORB.Any.NamedValue; Result_Name : constant CORBA.String := To_CORBA_String ("Result"); begin if CORBA.Object.Is_Nil (Self_Ref) then CORBA.Raise_Inv_Objref (CORBA.Default_Sys_Member); end if; PolyORB.Any.NVList.Create (Arg_List); PolyORB.Any.NVList.Add_Item (Arg_List, Arg_Name_Policy_Type, PolyORB.Any.Any (Argument_Policy_Type), PolyORB.Any.ARG_IN); Result := (Name => PolyORB.Types.Identifier (Result_Name), Argument => CORBA.Internals.Get_Empty_Any (CORBA.Policy.Helper.TC_Policy), Arg_Modes => 0); PolyORB.Requests.Setup_Request (Req => Request, Target => CORBA.Object.Internals.To_PolyORB_Ref (CORBA.Object.Ref (Self)), Operation => Operation_Name, Arg_List => Arg_List, Result => Result); PolyORB.CORBA_P.Interceptors_Hooks.Client_Invoke (Request'Access, PolyORB.Requests.Flags (0)); PolyORB.CORBA_P.Exceptions.Request_Raise_Occurrence (Request); return CORBA.Policy.Helper.From_Any (CORBA.Any (Result.Argument)); end Get_Domain_Policy; ---------- -- Is_A -- ---------- function Is_A (Self : Ref; Logical_Type_Id : Standard.String) return CORBA.Boolean is begin return Is_A (Logical_Type_Id) or else Object.Is_A (Object.Ref (Self), Logical_Type_Id); end Is_A; function Is_A (Logical_Type_Id : Standard.String) return CORBA.Boolean is begin return Is_Equivalent (Logical_Type_Id, Repository_Id) or else Is_Equivalent (Logical_Type_Id, "IDL:omg.org/CORBA/Object:1.0"); end Is_A; end CORBA.DomainManager; polyorb-2.8~20110207.orig/src/corba/polyorb-corba_p-domain_management.ads0000644000175000017500000000545311750740340025511 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . C O R B A _ P . D O M A I N _ M A N A G E M E N T -- -- -- -- S p e c -- -- -- -- Copyright (C) 2005-2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with CORBA.DomainManager; with PortableServer; with PolyORB.Annotations; package PolyORB.CORBA_P.Domain_Management is type Domain_Manager_Note is new PolyORB.Annotations.Note with record Domain_Managers : CORBA.DomainManager.DomainManagersList; end record; Empty_Domain_Manager_Note : constant Domain_Manager_Note; function Get_Domain_Managers (Servant : PortableServer.Servant) return CORBA.Any; -- Return sequence of domain manager in form of Any. -- Implementation Note: this is an idlac helper subprogram. private Empty_Domain_Manager_Note : constant Domain_Manager_Note := (PolyORB.Annotations.Note with Domain_Managers => CORBA.DomainManager.IDL_SEQUENCE_DomainManager.Null_Sequence); end PolyORB.CORBA_P.Domain_Management; polyorb-2.8~20110207.orig/src/corba/corba-object-helper.adb0000644000175000017500000000646111750740337022553 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- C O R B A . O B J E C T . H E L P E R -- -- -- -- B o d y -- -- -- -- Copyright (C) 2001-2009, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with PolyORB.Any.ObjRef; with PolyORB.CORBA_P.Local; package body CORBA.Object.Helper is use PolyORB.Any; -------------- -- From_Any -- -------------- function From_Any (Item : Any) return CORBA.Object.Ref is begin return CORBA.Object.Internals.To_CORBA_Ref (PolyORB.Any.ObjRef.From_Any (PolyORB.Any.Any (Item))); end From_Any; ------------ -- To_Any -- ------------ function To_Any (Item : CORBA.Object.Ref) return Any is begin -- To_Any operation are not defined on local objects if not Is_Nil (Item) and then PolyORB.CORBA_P.Local.Is_Local (Item) then Raise_Marshal (Marshal_Members'(Minor => 4, Completed => Completed_No)); end if; declare A : Any := CORBA.Any (PolyORB.Any.ObjRef.To_Any (CORBA.Object.Internals.To_PolyORB_Ref (Item))); begin CORBA.Internals.Set_Type (A, CORBA.Object.TC_Object); return A; end; end To_Any; ---------- -- Wrap -- ---------- function Wrap (X : access CORBA.Object.Ref) return PolyORB.Any.Content'Class is begin return PolyORB.Any.ObjRef.Wrap (PolyORB.References.Ref (X.all)'Unrestricted_Access); end Wrap; end CORBA.Object.Helper; polyorb-2.8~20110207.orig/src/corba/portableserver-requestprocessingpolicy.adb0000644000175000017500000001442611750740340027000 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- PORTABLESERVER.REQUESTPROCESSINGPOLICY -- -- -- -- B o d y -- -- -- -- Copyright (C) 2003-2007, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with PolyORB.CORBA_P.Policy; with PolyORB.CORBA_P.Policy_Management; with PortableServer.Helper; with PolyORB.Initialization; with PolyORB.Smart_Pointers; with PolyORB.Utils.Strings; package body PortableServer.RequestProcessingPolicy is use CORBA; use CORBA.Policy; use CORBA.TypeCode; use PortableServer.Helper; use PolyORB.CORBA_P.Policy; use PolyORB.CORBA_P.Policy_Management; function Create_RequestProcessingPolicy (The_Type : CORBA.PolicyType; Value : CORBA.Any) return CORBA.Policy.Ref; ------------ -- To_Ref -- ------------ function To_Ref (The_Ref : CORBA.Object.Ref'Class) return Ref is begin if The_Ref not in CORBA.Policy.Ref'Class or else Get_Policy_Type (CORBA.Policy.Ref (The_Ref)) /= REQUEST_PROCESSING_POLICY_ID then CORBA.Raise_Bad_Param (CORBA.Default_Sys_Member); end if; declare Entity : constant PolyORB.Smart_Pointers.Entity_Ptr := new Policy_Object_Type; Result : Ref; begin Set_Policy_Type (Policy_Object_Type (Entity.all), REQUEST_PROCESSING_POLICY_ID); Set_Policy_Value (Policy_Object_Type (Entity.all), Get_Policy_Value (Policy_Object_Type (Entity_Of (CORBA.Policy.Ref (The_Ref)).all))); CORBA.Policy.Set (CORBA.Policy.Ref (Result), Entity); return Result; end; end To_Ref; --------------- -- Get_Value -- --------------- function Get_Value (Self : Ref) return PortableServer.RequestProcessingPolicyValue is begin return From_Any (Get_Policy_Value (Policy_Object_Type (Entity_Of (CORBA.Policy.Ref (Self)).all))); end Get_Value; ------------------------------------ -- Create_RequestProcessingPolicy -- ------------------------------------ function Create_RequestProcessingPolicy (The_Type : CORBA.PolicyType; Value : CORBA.Any) return CORBA.Policy.Ref is begin pragma Assert (The_Type = REQUEST_PROCESSING_POLICY_ID); if Get_Type (Value) /= TC_RequestProcessingPolicyValue then Raise_PolicyError ((Reason => BAD_POLICY_TYPE)); end if; declare Position : constant CORBA.Unsigned_Long := CORBA.From_Any (CORBA.Internals.Get_Aggregate_Element (Value, CORBA.TC_Unsigned_Long, CORBA.Unsigned_Long (0))); begin if Position > RequestProcessingPolicyValue'Pos (RequestProcessingPolicyValue'Last) then Raise_PolicyError ((Reason => BAD_POLICY_VALUE)); end if; end; declare Result : CORBA.Policy.Ref; Entity : constant PolyORB.Smart_Pointers.Entity_Ptr := new Policy_Object_Type; begin Set_Policy_Type (Policy_Object_Type (Entity.all), The_Type); Set_Policy_Value (Policy_Object_Type (Entity.all), Value); CORBA.Policy.Set (Result, Entity); return Result; end; end Create_RequestProcessingPolicy; ----------------------------- -- Deferred_Initialization -- ----------------------------- procedure Deferred_Initialization; procedure Deferred_Initialization is begin Register (The_Type => REQUEST_PROCESSING_POLICY_ID, POA_Level => True, Factory => Create_RequestProcessingPolicy'Access, System_Default => Create_RequestProcessingPolicy (REQUEST_PROCESSING_POLICY_ID, To_Any (USE_ACTIVE_OBJECT_MAP_ONLY))); end Deferred_Initialization; use PolyORB.Initialization; use PolyORB.Initialization.String_Lists; use PolyORB.Utils.Strings; begin Register_Module (Module_Info' (Name => +"portableserver.requestprocessingpolicy", Conflicts => Empty, Depends => +"PortableServer.Helper", Provides => Empty, Implicit => False, Init => Deferred_Initialization'Access, Shutdown => null)); end PortableServer.RequestProcessingPolicy; polyorb-2.8~20110207.orig/src/corba/corba-current.ads0000644000175000017500000000556411750740337021536 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- C O R B A . C U R R E N T -- -- -- -- S p e c -- -- -- -- Copyright (C) 2003-2008, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the CORBA Specification, and adapted -- -- for use with PolyORB. The copyright notice above, and the license -- -- provisions that follow apply solely to the contents neither explicitly -- -- nor implicitly specified by the CORBA Specification defined by the OMG. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with CORBA.Object; package CORBA.Current is type Local_Ref is new CORBA.Object.Ref with null record; -- Implementation note: this deviates from the Ada Mapping rev. 1.2 -- to adjust for a change in the CORBA IDL specifications. In CORBA 2.3 -- CORBA::Current was a non-constrained interface; it was changed to a -- locality-constrained interface in CORBA 3.0. Repository_Id : constant Standard.String := "IDL:omg.org/CORBA/Current:1.0"; end CORBA.Current; polyorb-2.8~20110207.orig/src/corba/corba-fixed_point.adb0000644000175000017500000002115611750740337022336 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- C O R B A . F I X E D _ P O I N T -- -- -- -- B o d y -- -- -- -- Copyright (C) 2001-2008, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with Ada.Unchecked_Deallocation; with PolyORB.Log; with PolyORB.Representations.CDR.Common; package body CORBA.Fixed_Point is use PolyORB.Log; ----------- -- Debug -- ----------- package L is new PolyORB.Log.Facility_Log ("corba.fixed_point"); procedure O (Message : Standard.String; Level : Log_Level := Debug) renames L.Output; function C (Level : Log_Level := Debug) return Boolean renames L.Enabled; package CDR_Fixed_F is new PolyORB.Representations.CDR.Common.Fixed_Point (F); TC_Cache : TypeCode.Object; function TC return TypeCode.Object; -- Return typecode for this fixed point type -------- -- TC -- -------- function TC return TypeCode.Object is begin if CORBA.TypeCode.Internals.Is_Nil (TC_Cache) then TC_Cache := CORBA.TypeCode.Internals.To_CORBA_Object (PolyORB.Any.TypeCode.Build_Complex_TC (Tk_Fixed, (PolyORB.Any.To_Any (PolyORB.Types.Unsigned_Short (F'Digits)), PolyORB.Any.To_Any (PolyORB.Types.Short (F'Scale))))); end if; return TC_Cache; end TC; ------------ -- To_Any -- ------------ function To_Any (Item : F) return CORBA.Any is Result : Any := CORBA.Internals.Get_Empty_Any_Aggregate (TC); Octets : constant Ada.Streams.Stream_Element_Array := CDR_Fixed_F.Fixed_To_Octets (Item); begin for I in Octets'Range loop CORBA.Internals.Add_Aggregate_Element (Result, CORBA.To_Any (CORBA.Octet (Octets (I)))); end loop; return Result; end To_Any; -------------- -- From_Any -- -------------- function From_Any (Item : Any) return F is use type PolyORB.Any.TCKind; begin pragma Debug (C, O ("From_Any (Fixed) : enter")); if PolyORB.Any.TypeCode.Kind (Internals.Get_Unwound_Type (Item)) /= PolyORB.Any.Tk_Fixed then pragma Debug (C, O ("From_Any (Fixed) : Bad_TypeCode, type is " & PolyORB.Any.TCKind'Image (PolyORB.Any.TypeCode.Kind (Internals.Get_Unwound_Type (Item))))); raise Bad_TypeCode; end if; declare use Ada.Streams; Nb : constant CORBA.Unsigned_Long := CORBA.Internals.Get_Aggregate_Count (Item); Octets : Stream_Element_Array (1 .. Stream_Element_Offset (Nb)) := (others => 0); begin for J in Octets'Range loop pragma Debug (C, O ("From_Any (Fixed) : yet another octet")); Octets (J) := Stream_Element (PolyORB.Types.Octet'(PolyORB.Any.Get_Aggregate_Element (PolyORB.Any.Any (Item), PolyORB.Types.Unsigned_Long (J - 1)))); end loop; pragma Debug (C, O ("From_Any (Fixed) : return")); return CDR_Fixed_F.Octets_To_Fixed (Octets); exception when CORBA.Marshal => pragma Debug (C, O ("From_Any (Fixed) : exception catched" & "while returning")); raise CORBA.Bad_TypeCode; end; end From_Any; ---------- -- Wrap -- ---------- function Wrap (X : access F) return PolyORB.Any.Content'Class is begin return Fixed_Content' (PolyORB.Any.Aggregate_Content with V => X.all'Unrestricted_Access, Repr_Cache => (others => 0)); end Wrap; ----------- -- Clone -- ----------- function Clone (ACC : Fixed_Content; Into : PolyORB.Any.Content_Ptr := null) return PolyORB.Any.Content_Ptr is use type PolyORB.Any.Content_Ptr; Target : PolyORB.Any.Content_Ptr; begin if Into /= null then if Into.all not in Fixed_Content then return null; end if; Target := Into; else Target := new Fixed_Content; Fixed_Content (Target.all).V := new F; end if; Fixed_Content (Target.all).V.all := ACC.V.all; Fixed_Content (Target.all).Repr_Cache := ACC.Repr_Cache; return Target; end Clone; -------------------- -- Finalize_Value -- -------------------- procedure Finalize_Value (ACC : in out Fixed_Content) is procedure Free is new Ada.Unchecked_Deallocation (F, F_Ptr); begin Free (ACC.V); end Finalize_Value; --------------------------- -- Get_Aggregate_Element -- --------------------------- function Get_Aggregate_Element (ACC : not null access Fixed_Content; TC : PolyORB.Any.TypeCode.Object_Ptr; Index : PolyORB.Types.Unsigned_Long; Mech : not null access PolyORB.Any.Mechanism) return PolyORB.Any.Content'Class is pragma Unreferenced (TC); use Ada.Streams; use type PolyORB.Any.Mechanism; begin -- If getting first element, and accessing for read, prime cache if Mech.all = PolyORB.Any.By_Value and then Stream_Element_Offset (Index) = ACC.Repr_Cache'First then ACC.Repr_Cache := CDR_Fixed_F.Fixed_To_Octets (ACC.V.all); end if; Mech.all := PolyORB.Any.By_Value; return PolyORB.Any.Wrap (PolyORB.Types.Octet (ACC.Repr_Cache (Stream_Element_Offset (Index)))'Unrestricted_Access); end Get_Aggregate_Element; --------------------------- -- Set_Aggregate_Element -- --------------------------- procedure Set_Aggregate_Element (ACC : in out Fixed_Content; TC : PolyORB.Any.TypeCode.Object_Ptr; Index : PolyORB.Types.Unsigned_Long; From_C : in out PolyORB.Any.Any_Container'Class) is pragma Unreferenced (TC); use Ada.Streams; begin ACC.Repr_Cache (Stream_Element_Offset (Index)) := Stream_Element (PolyORB.Types.Octet'(PolyORB.Any.From_Any (From_C))); -- If setting last element, update actual fixed value if Stream_Element_Offset (Index) = ACC.Repr_Cache'Last then ACC.V.all := CDR_Fixed_F.Octets_To_Fixed (ACC.Repr_Cache); end if; end Set_Aggregate_Element; ------------------------- -- Get_Aggregate_Count -- ------------------------- function Get_Aggregate_Count (ACC : Fixed_Content) return PolyORB.Types.Unsigned_Long is pragma Unreferenced (ACC); begin return Fixed_Content_Count; end Get_Aggregate_Count; ------------------------- -- Set_Aggregate_Count -- ------------------------- procedure Set_Aggregate_Count (ACC : in out Fixed_Content; Count : PolyORB.Types.Unsigned_Long) is pragma Unreferenced (ACC); begin if Count /= Fixed_Content_Count then raise Constraint_Error; end if; end Set_Aggregate_Count; end CORBA.Fixed_Point; polyorb-2.8~20110207.orig/src/corba/corba-policycurrent.ads0000644000175000017500000000657311750740337022757 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- C O R B A . P O L I C Y C U R R E N T -- -- -- -- S p e c -- -- -- -- Copyright (C) 2004-2010, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the CORBA Specification, and adapted -- -- for use with PolyORB. The copyright notice above, and the license -- -- provisions that follow apply solely to the contents neither explicitly -- -- nor implicitly specified by the CORBA Specification defined by the OMG. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with CORBA.Local; with CORBA.Policy; with CORBA.PolicyManager; package CORBA.PolicyCurrent is type Local_Ref is new CORBA.PolicyManager.Local_Ref with null record; function Get_Policy_Overrides (Self : Local_Ref; TS : CORBA.Policy.PolicyTypeSeq) return CORBA.Policy.PolicyList; procedure Set_Policy_Overrides (Self : Local_Ref; Policies : CORBA.Policy.PolicyList; Set_Add : SetOverrideType); private type Object is new CORBA.Local.Object with null record; type Object_Ptr is access all Object'Class; function Get_Policy_Overrides (Self : access Object; TS : CORBA.Policy.PolicyTypeSeq) return CORBA.Policy.PolicyList; procedure Set_Policy_Overrides (Self : access Object; Policies : CORBA.Policy.PolicyList; Set_Add : CORBA.SetOverrideType); function Is_A (Self : not null access Object; Logical_Type_Id : Standard.String) return Boolean; end CORBA.PolicyCurrent; polyorb-2.8~20110207.orig/src/corba/corba-sequences.ads0000644000175000017500000000567411750740340022043 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- C O R B A . S E Q U E N C E S -- -- -- -- S p e c -- -- -- -- Copyright (C) 2003-2008, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the CORBA Specification, and adapted -- -- for use with PolyORB. The copyright notice above, and the license -- -- provisions that follow apply solely to the contents neither explicitly -- -- nor implicitly specified by the CORBA Specification defined by the OMG. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with PolyORB.Sequences; package CORBA.Sequences is Length_Error : exception renames PolyORB.Sequences.Length_Error; Pattern_Error : exception renames PolyORB.Sequences.Pattern_Error; Index_Error : exception renames PolyORB.Sequences.Index_Error; subtype Alignment is PolyORB.Sequences.Alignment; subtype Truncation is PolyORB.Sequences.Truncation; subtype Membership is PolyORB.Sequences.Membership; subtype Direction is PolyORB.Sequences.Direction; subtype Trim_End is PolyORB.Sequences.Trim_End; end CORBA.Sequences; polyorb-2.8~20110207.orig/src/corba/corba-policy-helper.adb0000644000175000017500000001064211750740337022600 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- C O R B A . P O L I C Y . H E L P E R -- -- -- -- B o d y -- -- -- -- Copyright (C) 2005-2007, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with PolyORB.Initialization; with PolyORB.Utils.Strings; with CORBA.Object.Helper; package body CORBA.Policy.Helper is Repository_Id : constant Standard.String := "IDL:omg.org/CORBA/Policy:1.0"; procedure Deferred_Initialization; TC_Policy_Cache : TypeCode.Object; ----------------------------- -- Deferred_Initialization -- ----------------------------- procedure Deferred_Initialization is begin TC_Policy_Cache := CORBA.TypeCode.Internals.To_CORBA_Object (PolyORB.Any.TypeCode.TC_Object); Internals.Add_Parameter (TC_Policy_Cache, To_Any (To_CORBA_String ("Policy"))); Internals.Add_Parameter (TC_Policy_Cache, To_Any (To_CORBA_String (Repository_Id))); end Deferred_Initialization; -------------- -- From_Any -- -------------- function From_Any (Item : Any) return Ref is begin return To_Ref (CORBA.Object.Helper.From_Any (Item)); end From_Any; --------------- -- TC_Policy -- --------------- function TC_Policy return TypeCode.Object is begin return TC_Policy_Cache; end TC_Policy; ------------ -- To_Any -- ------------ function To_Any (Item : Ref) return Any is Result : Any := Object.Helper.To_Any (Object.Ref (Item)); begin Internals.Set_Type (Result, TC_Policy); return Result; end To_Any; ------------ -- To_Ref -- ------------ function To_Ref (The_Ref : Object.Ref'Class) return Ref is begin if Object.Is_Nil (The_Ref) or else Object.Is_A (The_Ref, Repository_Id) then return Unchecked_To_Ref (The_Ref); end if; Raise_Bad_Param (Default_Sys_Member); end To_Ref; ---------------------- -- Unchecked_To_Ref -- ---------------------- function Unchecked_To_Ref (The_Ref : Object.Ref'Class) return Ref is Result : Ref; begin Set (Result, Object.Object_Of (The_Ref)); return Result; end Unchecked_To_Ref; begin declare use PolyORB.Initialization; use PolyORB.Initialization.String_Lists; use PolyORB.Utils.Strings; begin Register_Module (Module_Info' (Name => +"corba.policy.helper", Conflicts => Empty, Depends => +"corba" & "any", Provides => Empty, Implicit => False, Init => Deferred_Initialization'Access, Shutdown => null)); end; end CORBA.Policy.Helper; polyorb-2.8~20110207.orig/src/corba/polyorb-corba_p-ir_hooks.ads0000644000175000017500000000573211750740340023663 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . C O R B A _ P . I R _ H O O K S -- -- -- -- S p e c -- -- -- -- Copyright (C) 2005-2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with CORBA.Object; package PolyORB.CORBA_P.IR_Hooks is type Get_Interface_Definition_Hook is access function (Id : CORBA.RepositoryId) return CORBA.Object.Ref'Class; -- A Get_Intrerface_Definition hook returns an InterfaceDef reference -- that describes the interface identified by Id. Implementations -- must node return a Nil reference. -- Instead, the exception INTF_REPOS should be raised, with minor code -- 1 if the interface repository is unavailable, or minor code 2 if the -- interface repository don't contain an entry with the specified -- RepositoryId. function Default_Get_Interface_Definition (Id : CORBA.RepositoryId) return CORBA.Object.Ref'Class; -- Default implementation of Get_Interface_Definition hook. -- Always raises INTF_REPOS (Minor => 1). Get_Interface_Definition : Get_Interface_Definition_Hook := Default_Get_Interface_Definition'Access; end PolyORB.CORBA_P.IR_Hooks; polyorb-2.8~20110207.orig/src/corba/portableserver-helper.adb0000644000175000017500000016035111750740340023251 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O R T A B L E S E R V E R . H E L P E R -- -- -- -- B o d y -- -- -- -- Copyright (C) 2006-2008, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ ------------------------------------------------- -- This file has been generated automatically -- by IDLAC version 2.3.0w. -- -- Do NOT hand-modify this file, as your -- changes will be lost when you re-run the -- IDL to Ada compiler. ------------------------------------------------- pragma Style_Checks ("NM32766"); with PolyORB.Utils.Strings; with PolyORB.Initialization; pragma Elaborate_All (PolyORB.Initialization); with Ada.Unchecked_Deallocation; with PolyORB.Types; with PolyORB.Exceptions; with PolyORB.Std; with CORBA.Object.Helper; with CORBA.IDL_SEQUENCES.Helper; with PortableServer.POA.Helper; package body PortableServer.Helper is function Unchecked_To_Ref (The_Ref : CORBA.Object.Ref'Class) return PortableServer.POA_Forward.Ref is Result : PortableServer.POA_Forward.Ref; begin POA_Forward.Set (Result, CORBA.Object.Object_Of (The_Ref)); return Result; end Unchecked_To_Ref; function To_Ref (The_Ref : CORBA.Object.Ref'Class) return PortableServer.POA_Forward.Ref is begin if CORBA.Object.Is_Nil (The_Ref) or else CORBA.Object.Is_A (The_Ref, "IDL:omg.org/PortableServer/POA:1.0") then return Unchecked_To_Ref (The_Ref); end if; CORBA.Raise_Bad_Param (CORBA.Default_Sys_Member); end To_Ref; function From_Any (Item : CORBA.Any) return PortableServer.ObjectId is begin return PortableServer.ObjectId (CORBA.IDL_SEQUENCES.OctetSeq'(CORBA.IDL_SEQUENCES.Helper.From_Any (Item))); end From_Any; function To_Any (Item : PortableServer.ObjectId) return CORBA.Any is Result : CORBA.Any := CORBA.IDL_SEQUENCES.Helper.To_Any (CORBA.IDL_SEQUENCES.OctetSeq (Item)); begin CORBA.Internals.Set_Type (Result, TC_ObjectId); return Result; end To_Any; function From_Any (Item : CORBA.Any) return PortableServer.ForwardRequest_Members is Index : CORBA.Any; Result_forward_reference : CORBA.Object.Ref; begin Index := CORBA.Internals.Get_Aggregate_Element (Item, CORBA.Object.Helper.TC_Object, CORBA.Unsigned_Long ( 0)); Result_forward_reference := CORBA.Object.Helper.From_Any (Index); return (forward_reference => Result_forward_reference); end From_Any; function To_Any (Item : PortableServer.ForwardRequest_Members) return CORBA.Any is Result : CORBA.Any := CORBA.Internals.Get_Empty_Any_Aggregate (TC_ForwardRequest); begin CORBA.Internals.Add_Aggregate_Element (Result, CORBA.Object.Helper.To_Any (Item.forward_reference)); return Result; end To_Any; procedure Raise_ForwardRequest_From_Any (Item : PolyORB.Any.Any; Message : PolyORB.Std.String); pragma No_Return (Raise_ForwardRequest_From_Any); procedure Raise_ForwardRequest_From_Any (Item : PolyORB.Any.Any; Message : PolyORB.Std.String) is Members : constant ForwardRequest_Members := From_Any (CORBA.Any (Item)); begin PolyORB.Exceptions.User_Raise_Exception (ForwardRequest'Identity, Members, Message); end Raise_ForwardRequest_From_Any; procedure Raise_ForwardRequest (Members : ForwardRequest_Members) is begin PolyORB.Exceptions.User_Raise_Exception (ForwardRequest'Identity, Members); end Raise_ForwardRequest; type Ptr_Ü_ThreadPolicyValue is access all PortableServer.ThreadPolicyValue; type Content_Ü_ThreadPolicyValue is new PolyORB.Any.Aggregate_Content with record V : Ptr_Ü_ThreadPolicyValue; Repr_Cache : aliased PolyORB.Types.Unsigned_Long; end record; function Get_Aggregate_Element (ACC : not null access Content_Ü_ThreadPolicyValue; TC : PolyORB.Any.TypeCode.Object_Ptr; Index : PolyORB.Types.Unsigned_Long; Mech : not null access PolyORB.Any.Mechanism) return PolyORB.Any.Content'Class; procedure Set_Aggregate_Element (ACC : in out Content_Ü_ThreadPolicyValue; TC : PolyORB.Any.TypeCode.Object_Ptr; Index : PolyORB.Types.Unsigned_Long; From_C : in out PolyORB.Any.Any_Container'Class); function Get_Aggregate_Count (ACC : Content_Ü_ThreadPolicyValue) return PolyORB.Types.Unsigned_Long; procedure Set_Aggregate_Count (ACC : in out Content_Ü_ThreadPolicyValue; Count : PolyORB.Types.Unsigned_Long); function Clone (ACC : Content_Ü_ThreadPolicyValue; Into : PolyORB.Any.Content_Ptr := null) return PolyORB.Any.Content_Ptr; procedure Finalize_Value (ACC : in out Content_Ü_ThreadPolicyValue); function Get_Aggregate_Element (ACC : not null access Content_Ü_ThreadPolicyValue; TC : PolyORB.Any.TypeCode.Object_Ptr; Index : PolyORB.Types.Unsigned_Long; Mech : not null access PolyORB.Any.Mechanism) return PolyORB.Any.Content'Class is use type PolyORB.Types.Unsigned_Long; use type PolyORB.Any.Mechanism; pragma Unreferenced (TC, Index); pragma Suppress (All_Checks); begin ACC.Repr_Cache := PortableServer.ThreadPolicyValue'Pos (ACC.V.all); Mech.all := PolyORB.Any.By_Value; return PolyORB.Any.Wrap (ACC.Repr_Cache'Unrestricted_Access); end Get_Aggregate_Element; procedure Set_Aggregate_Element (ACC : in out Content_Ü_ThreadPolicyValue; TC : PolyORB.Any.TypeCode.Object_Ptr; Index : PolyORB.Types.Unsigned_Long; From_C : in out PolyORB.Any.Any_Container'Class) is pragma Unreferenced (TC); use type PolyORB.Types.Unsigned_Long; pragma Assert (Index = 0); begin ACC.V.all := PortableServer.ThreadPolicyValue'Val (PolyORB.Types.Unsigned_Long'(PolyORB.Any.From_Any (From_C))); end Set_Aggregate_Element; function Get_Aggregate_Count (ACC : Content_Ü_ThreadPolicyValue) return PolyORB.Types.Unsigned_Long is pragma Unreferenced (ACC); begin return 1; end Get_Aggregate_Count; procedure Set_Aggregate_Count (ACC : in out Content_Ü_ThreadPolicyValue; Count : PolyORB.Types.Unsigned_Long) is use type PolyORB.Types.Unsigned_Long; pragma Unreferenced (ACC); begin if Count /= 1 then raise Program_Error; end if; end Set_Aggregate_Count; function Clone (ACC : Content_Ü_ThreadPolicyValue; Into : PolyORB.Any.Content_Ptr := null) return PolyORB.Any.Content_Ptr is use type PolyORB.Any.Content_Ptr; Target : PolyORB.Any.Content_Ptr; begin if Into /= null then if Into.all not in Content_Ü_ThreadPolicyValue then return null; end if; Target := Into; Content_Ü_ThreadPolicyValue (Target.all).V.all := ACC.V.all; else Target := new Content_Ü_ThreadPolicyValue; Content_Ü_ThreadPolicyValue (Target.all).V := new PortableServer.ThreadPolicyValue'(ACC.V.all); end if; Content_Ü_ThreadPolicyValue (Target.all).Repr_Cache:= ACC.Repr_Cache; return Target; end Clone; procedure Finalize_Value (ACC : in out Content_Ü_ThreadPolicyValue) is procedure Free is new Ada.Unchecked_Deallocation (PortableServer.ThreadPolicyValue, Ptr_Ü_ThreadPolicyValue); begin Free (ACC.V); end Finalize_Value; function Wrap (X : access PortableServer.ThreadPolicyValue) return PolyORB.Any.Content'Class is begin return Content_Ü_ThreadPolicyValue'(PolyORB.Any.Aggregate_Content with V => Ptr_Ü_ThreadPolicyValue (X), Repr_Cache => 0); end Wrap; function From_Any (C : PolyORB.Any.Any_Container'Class) return PortableServer.ThreadPolicyValue is ACC : PolyORB.Any.Aggregate_Content'Class renames PolyORB.Any.Aggregate_Content'Class (PolyORB.Any.Get_Value (C).all); El_M : aliased PolyORB.Any.Mechanism := PolyORB.Any.By_Value; El_CC : aliased PolyORB.Any.Content'Class := PolyORB.Any.Get_Aggregate_Element (ACC'Access, PolyORB.Any.TC_Unsigned_Long, 0, El_M'Access); El_C : PolyORB.Any.Any_Container; begin PolyORB.Any.Set_Type (El_C, PolyORB.Any.TC_Unsigned_Long); PolyORB.Any.Set_Value (El_C, El_CC'Unchecked_Access); return ThreadPolicyValue'Val (PolyORB.Types.Unsigned_Long'(PolyORB.Any.From_Any (El_C))); end From_Any; function From_Any (Item : CORBA.Any) return PortableServer.ThreadPolicyValue is begin return From_Any (CORBA.Get_Container (Item).all); end From_Any; function To_Any (Item : PortableServer.ThreadPolicyValue) return CORBA.Any is Result : CORBA.Any := CORBA.Internals.Get_Empty_Any_Aggregate (TC_ThreadPolicyValue); begin CORBA.Internals.Add_Aggregate_Element (Result, CORBA.To_Any (CORBA.Unsigned_Long (ThreadPolicyValue'Pos (Item)))); return Result; end To_Any; type Ptr_Ü_LifespanPolicyValue is access all PortableServer.LifespanPolicyValue; type Content_Ü_LifespanPolicyValue is new PolyORB.Any.Aggregate_Content with record V : Ptr_Ü_LifespanPolicyValue; Repr_Cache : aliased PolyORB.Types.Unsigned_Long; end record; function Get_Aggregate_Element (ACC : not null access Content_Ü_LifespanPolicyValue; TC : PolyORB.Any.TypeCode.Object_Ptr; Index : PolyORB.Types.Unsigned_Long; Mech : not null access PolyORB.Any.Mechanism) return PolyORB.Any.Content'Class; procedure Set_Aggregate_Element (ACC : in out Content_Ü_LifespanPolicyValue; TC : PolyORB.Any.TypeCode.Object_Ptr; Index : PolyORB.Types.Unsigned_Long; From_C : in out PolyORB.Any.Any_Container'Class); function Get_Aggregate_Count (ACC : Content_Ü_LifespanPolicyValue) return PolyORB.Types.Unsigned_Long; procedure Set_Aggregate_Count (ACC : in out Content_Ü_LifespanPolicyValue; Count : PolyORB.Types.Unsigned_Long); function Clone (ACC : Content_Ü_LifespanPolicyValue; Into : PolyORB.Any.Content_Ptr := null) return PolyORB.Any.Content_Ptr; procedure Finalize_Value (ACC : in out Content_Ü_LifespanPolicyValue); function Get_Aggregate_Element (ACC : not null access Content_Ü_LifespanPolicyValue; TC : PolyORB.Any.TypeCode.Object_Ptr; Index : PolyORB.Types.Unsigned_Long; Mech : not null access PolyORB.Any.Mechanism) return PolyORB.Any.Content'Class is use type PolyORB.Types.Unsigned_Long; use type PolyORB.Any.Mechanism; pragma Unreferenced (TC, Index); pragma Suppress (All_Checks); begin ACC.Repr_Cache := PortableServer.LifespanPolicyValue'Pos (ACC.V.all); Mech.all := PolyORB.Any.By_Value; return PolyORB.Any.Wrap (ACC.Repr_Cache'Unrestricted_Access); end Get_Aggregate_Element; procedure Set_Aggregate_Element (ACC : in out Content_Ü_LifespanPolicyValue; TC : PolyORB.Any.TypeCode.Object_Ptr; Index : PolyORB.Types.Unsigned_Long; From_C : in out PolyORB.Any.Any_Container'Class) is pragma Unreferenced (TC); use type PolyORB.Types.Unsigned_Long; pragma Assert (Index = 0); begin ACC.V.all := PortableServer.LifespanPolicyValue'Val (PolyORB.Types.Unsigned_Long'(PolyORB.Any.From_Any (From_C))); end Set_Aggregate_Element; function Get_Aggregate_Count (ACC : Content_Ü_LifespanPolicyValue) return PolyORB.Types.Unsigned_Long is pragma Unreferenced (ACC); begin return 1; end Get_Aggregate_Count; procedure Set_Aggregate_Count (ACC : in out Content_Ü_LifespanPolicyValue; Count : PolyORB.Types.Unsigned_Long) is use type PolyORB.Types.Unsigned_Long; pragma Unreferenced (ACC); begin if Count /= 1 then raise Program_Error; end if; end Set_Aggregate_Count; function Clone (ACC : Content_Ü_LifespanPolicyValue; Into : PolyORB.Any.Content_Ptr := null) return PolyORB.Any.Content_Ptr is use type PolyORB.Any.Content_Ptr; Target : PolyORB.Any.Content_Ptr; begin if Into /= null then if Into.all not in Content_Ü_LifespanPolicyValue then return null; end if; Target := Into; Content_Ü_LifespanPolicyValue (Target.all).V.all := ACC.V.all; else Target := new Content_Ü_LifespanPolicyValue; Content_Ü_LifespanPolicyValue (Target.all).V := new PortableServer.LifespanPolicyValue'(ACC.V.all); end if; Content_Ü_LifespanPolicyValue (Target.all).Repr_Cache:= ACC.Repr_Cache; return Target; end Clone; procedure Finalize_Value (ACC : in out Content_Ü_LifespanPolicyValue) is procedure Free is new Ada.Unchecked_Deallocation (PortableServer.LifespanPolicyValue, Ptr_Ü_LifespanPolicyValue); begin Free (ACC.V); end Finalize_Value; function Wrap (X : access PortableServer.LifespanPolicyValue) return PolyORB.Any.Content'Class is begin return Content_Ü_LifespanPolicyValue'(PolyORB.Any.Aggregate_Content with V => Ptr_Ü_LifespanPolicyValue (X), Repr_Cache => 0); end Wrap; function From_Any (C : PolyORB.Any.Any_Container'Class) return PortableServer.LifespanPolicyValue is ACC : PolyORB.Any.Aggregate_Content'Class renames PolyORB.Any.Aggregate_Content'Class (PolyORB.Any.Get_Value (C).all); El_M : aliased PolyORB.Any.Mechanism := PolyORB.Any.By_Value; El_CC : aliased PolyORB.Any.Content'Class := PolyORB.Any.Get_Aggregate_Element (ACC'Access, PolyORB.Any.TC_Unsigned_Long, 0, El_M'Access); El_C : PolyORB.Any.Any_Container; begin PolyORB.Any.Set_Type (El_C, PolyORB.Any.TC_Unsigned_Long); PolyORB.Any.Set_Value (El_C, El_CC'Unchecked_Access); return LifespanPolicyValue'Val (PolyORB.Types.Unsigned_Long'(PolyORB.Any.From_Any (El_C))); end From_Any; function From_Any (Item : CORBA.Any) return PortableServer.LifespanPolicyValue is begin return From_Any (CORBA.Get_Container (Item).all); end From_Any; function To_Any (Item : PortableServer.LifespanPolicyValue) return CORBA.Any is Result : CORBA.Any := CORBA.Internals.Get_Empty_Any_Aggregate (TC_LifespanPolicyValue); begin CORBA.Internals.Add_Aggregate_Element (Result, CORBA.To_Any (CORBA.Unsigned_Long (LifespanPolicyValue'Pos (Item)))); return Result; end To_Any; type Ptr_Ü_IdUniquenessPolicyValue is access all PortableServer.IdUniquenessPolicyValue; type Content_Ü_IdUniquenessPolicyValue is new PolyORB.Any.Aggregate_Content with record V : Ptr_Ü_IdUniquenessPolicyValue; Repr_Cache : aliased PolyORB.Types.Unsigned_Long; end record; function Get_Aggregate_Element (ACC : not null access Content_Ü_IdUniquenessPolicyValue; TC : PolyORB.Any.TypeCode.Object_Ptr; Index : PolyORB.Types.Unsigned_Long; Mech : not null access PolyORB.Any.Mechanism) return PolyORB.Any.Content'Class; procedure Set_Aggregate_Element (ACC : in out Content_Ü_IdUniquenessPolicyValue; TC : PolyORB.Any.TypeCode.Object_Ptr; Index : PolyORB.Types.Unsigned_Long; From_C : in out PolyORB.Any.Any_Container'Class); function Get_Aggregate_Count (ACC : Content_Ü_IdUniquenessPolicyValue) return PolyORB.Types.Unsigned_Long; procedure Set_Aggregate_Count (ACC : in out Content_Ü_IdUniquenessPolicyValue; Count : PolyORB.Types.Unsigned_Long); function Clone (ACC : Content_Ü_IdUniquenessPolicyValue; Into : PolyORB.Any.Content_Ptr := null) return PolyORB.Any.Content_Ptr; procedure Finalize_Value (ACC : in out Content_Ü_IdUniquenessPolicyValue); function Get_Aggregate_Element (ACC : not null access Content_Ü_IdUniquenessPolicyValue; TC : PolyORB.Any.TypeCode.Object_Ptr; Index : PolyORB.Types.Unsigned_Long; Mech : not null access PolyORB.Any.Mechanism) return PolyORB.Any.Content'Class is use type PolyORB.Types.Unsigned_Long; use type PolyORB.Any.Mechanism; pragma Unreferenced (TC, Index); pragma Suppress (All_Checks); begin ACC.Repr_Cache := PortableServer.IdUniquenessPolicyValue'Pos (ACC.V.all); Mech.all := PolyORB.Any.By_Value; return PolyORB.Any.Wrap (ACC.Repr_Cache'Unrestricted_Access); end Get_Aggregate_Element; procedure Set_Aggregate_Element (ACC : in out Content_Ü_IdUniquenessPolicyValue; TC : PolyORB.Any.TypeCode.Object_Ptr; Index : PolyORB.Types.Unsigned_Long; From_C : in out PolyORB.Any.Any_Container'Class) is pragma Unreferenced (TC); use type PolyORB.Types.Unsigned_Long; pragma Assert (Index = 0); begin ACC.V.all := PortableServer.IdUniquenessPolicyValue'Val (PolyORB.Types.Unsigned_Long'(PolyORB.Any.From_Any (From_C))); end Set_Aggregate_Element; function Get_Aggregate_Count (ACC : Content_Ü_IdUniquenessPolicyValue) return PolyORB.Types.Unsigned_Long is pragma Unreferenced (ACC); begin return 1; end Get_Aggregate_Count; procedure Set_Aggregate_Count (ACC : in out Content_Ü_IdUniquenessPolicyValue; Count : PolyORB.Types.Unsigned_Long) is use type PolyORB.Types.Unsigned_Long; pragma Unreferenced (ACC); begin if Count /= 1 then raise Program_Error; end if; end Set_Aggregate_Count; function Clone (ACC : Content_Ü_IdUniquenessPolicyValue; Into : PolyORB.Any.Content_Ptr := null) return PolyORB.Any.Content_Ptr is use type PolyORB.Any.Content_Ptr; Target : PolyORB.Any.Content_Ptr; begin if Into /= null then if Into.all not in Content_Ü_IdUniquenessPolicyValue then return null; end if; Target := Into; Content_Ü_IdUniquenessPolicyValue (Target.all).V.all := ACC.V.all; else Target := new Content_Ü_IdUniquenessPolicyValue; Content_Ü_IdUniquenessPolicyValue (Target.all).V := new PortableServer.IdUniquenessPolicyValue'(ACC.V.all); end if; Content_Ü_IdUniquenessPolicyValue (Target.all).Repr_Cache:= ACC.Repr_Cache; return Target; end Clone; procedure Finalize_Value (ACC : in out Content_Ü_IdUniquenessPolicyValue) is procedure Free is new Ada.Unchecked_Deallocation (PortableServer.IdUniquenessPolicyValue, Ptr_Ü_IdUniquenessPolicyValue); begin Free (ACC.V); end Finalize_Value; function Wrap (X : access PortableServer.IdUniquenessPolicyValue) return PolyORB.Any.Content'Class is begin return Content_Ü_IdUniquenessPolicyValue'(PolyORB.Any.Aggregate_Content with V => Ptr_Ü_IdUniquenessPolicyValue (X), Repr_Cache => 0); end Wrap; function From_Any (C : PolyORB.Any.Any_Container'Class) return PortableServer.IdUniquenessPolicyValue is ACC : PolyORB.Any.Aggregate_Content'Class renames PolyORB.Any.Aggregate_Content'Class (PolyORB.Any.Get_Value (C).all); El_M : aliased PolyORB.Any.Mechanism := PolyORB.Any.By_Value; El_CC : aliased PolyORB.Any.Content'Class := PolyORB.Any.Get_Aggregate_Element (ACC'Access, PolyORB.Any.TC_Unsigned_Long, 0, El_M'Access); El_C : PolyORB.Any.Any_Container; begin PolyORB.Any.Set_Type (El_C, PolyORB.Any.TC_Unsigned_Long); PolyORB.Any.Set_Value (El_C, El_CC'Unchecked_Access); return IdUniquenessPolicyValue'Val (PolyORB.Types.Unsigned_Long'(PolyORB.Any.From_Any (El_C))); end From_Any; function From_Any (Item : CORBA.Any) return PortableServer.IdUniquenessPolicyValue is begin return From_Any (CORBA.Get_Container (Item).all); end From_Any; function To_Any (Item : PortableServer.IdUniquenessPolicyValue) return CORBA.Any is Result : CORBA.Any := CORBA.Internals.Get_Empty_Any_Aggregate (TC_IdUniquenessPolicyValue); begin CORBA.Internals.Add_Aggregate_Element (Result, CORBA.To_Any (CORBA.Unsigned_Long (IdUniquenessPolicyValue'Pos (Item)))); return Result; end To_Any; type Ptr_Ü_IdAssignmentPolicyValue is access all PortableServer.IdAssignmentPolicyValue; type Content_Ü_IdAssignmentPolicyValue is new PolyORB.Any.Aggregate_Content with record V : Ptr_Ü_IdAssignmentPolicyValue; Repr_Cache : aliased PolyORB.Types.Unsigned_Long; end record; function Get_Aggregate_Element (ACC : not null access Content_Ü_IdAssignmentPolicyValue; TC : PolyORB.Any.TypeCode.Object_Ptr; Index : PolyORB.Types.Unsigned_Long; Mech : not null access PolyORB.Any.Mechanism) return PolyORB.Any.Content'Class; procedure Set_Aggregate_Element (ACC : in out Content_Ü_IdAssignmentPolicyValue; TC : PolyORB.Any.TypeCode.Object_Ptr; Index : PolyORB.Types.Unsigned_Long; From_C : in out PolyORB.Any.Any_Container'Class); function Get_Aggregate_Count (ACC : Content_Ü_IdAssignmentPolicyValue) return PolyORB.Types.Unsigned_Long; procedure Set_Aggregate_Count (ACC : in out Content_Ü_IdAssignmentPolicyValue; Count : PolyORB.Types.Unsigned_Long); function Clone (ACC : Content_Ü_IdAssignmentPolicyValue; Into : PolyORB.Any.Content_Ptr := null) return PolyORB.Any.Content_Ptr; procedure Finalize_Value (ACC : in out Content_Ü_IdAssignmentPolicyValue); function Get_Aggregate_Element (ACC : not null access Content_Ü_IdAssignmentPolicyValue; TC : PolyORB.Any.TypeCode.Object_Ptr; Index : PolyORB.Types.Unsigned_Long; Mech : not null access PolyORB.Any.Mechanism) return PolyORB.Any.Content'Class is use type PolyORB.Types.Unsigned_Long; use type PolyORB.Any.Mechanism; pragma Unreferenced (TC, Index); pragma Suppress (All_Checks); begin ACC.Repr_Cache := PortableServer.IdAssignmentPolicyValue'Pos (ACC.V.all); Mech.all := PolyORB.Any.By_Value; return PolyORB.Any.Wrap (ACC.Repr_Cache'Unrestricted_Access); end Get_Aggregate_Element; procedure Set_Aggregate_Element (ACC : in out Content_Ü_IdAssignmentPolicyValue; TC : PolyORB.Any.TypeCode.Object_Ptr; Index : PolyORB.Types.Unsigned_Long; From_C : in out PolyORB.Any.Any_Container'Class) is pragma Unreferenced (TC); use type PolyORB.Types.Unsigned_Long; pragma Assert (Index = 0); begin ACC.V.all := PortableServer.IdAssignmentPolicyValue'Val (PolyORB.Types.Unsigned_Long'(PolyORB.Any.From_Any (From_C))); end Set_Aggregate_Element; function Get_Aggregate_Count (ACC : Content_Ü_IdAssignmentPolicyValue) return PolyORB.Types.Unsigned_Long is pragma Unreferenced (ACC); begin return 1; end Get_Aggregate_Count; procedure Set_Aggregate_Count (ACC : in out Content_Ü_IdAssignmentPolicyValue; Count : PolyORB.Types.Unsigned_Long) is use type PolyORB.Types.Unsigned_Long; pragma Unreferenced (ACC); begin if Count /= 1 then raise Program_Error; end if; end Set_Aggregate_Count; function Clone (ACC : Content_Ü_IdAssignmentPolicyValue; Into : PolyORB.Any.Content_Ptr := null) return PolyORB.Any.Content_Ptr is use type PolyORB.Any.Content_Ptr; Target : PolyORB.Any.Content_Ptr; begin if Into /= null then if Into.all not in Content_Ü_IdAssignmentPolicyValue then return null; end if; Target := Into; Content_Ü_IdAssignmentPolicyValue (Target.all).V.all := ACC.V.all; else Target := new Content_Ü_IdAssignmentPolicyValue; Content_Ü_IdAssignmentPolicyValue (Target.all).V := new PortableServer.IdAssignmentPolicyValue'(ACC.V.all); end if; Content_Ü_IdAssignmentPolicyValue (Target.all).Repr_Cache:= ACC.Repr_Cache; return Target; end Clone; procedure Finalize_Value (ACC : in out Content_Ü_IdAssignmentPolicyValue) is procedure Free is new Ada.Unchecked_Deallocation (PortableServer.IdAssignmentPolicyValue, Ptr_Ü_IdAssignmentPolicyValue); begin Free (ACC.V); end Finalize_Value; function Wrap (X : access PortableServer.IdAssignmentPolicyValue) return PolyORB.Any.Content'Class is begin return Content_Ü_IdAssignmentPolicyValue'(PolyORB.Any.Aggregate_Content with V => Ptr_Ü_IdAssignmentPolicyValue (X), Repr_Cache => 0); end Wrap; function From_Any (C : PolyORB.Any.Any_Container'Class) return PortableServer.IdAssignmentPolicyValue is ACC : PolyORB.Any.Aggregate_Content'Class renames PolyORB.Any.Aggregate_Content'Class (PolyORB.Any.Get_Value (C).all); El_M : aliased PolyORB.Any.Mechanism := PolyORB.Any.By_Value; El_CC : aliased PolyORB.Any.Content'Class := PolyORB.Any.Get_Aggregate_Element (ACC'Access, PolyORB.Any.TC_Unsigned_Long, 0, El_M'Access); El_C : PolyORB.Any.Any_Container; begin PolyORB.Any.Set_Type (El_C, PolyORB.Any.TC_Unsigned_Long); PolyORB.Any.Set_Value (El_C, El_CC'Unchecked_Access); return IdAssignmentPolicyValue'Val (PolyORB.Types.Unsigned_Long'(PolyORB.Any.From_Any (El_C))); end From_Any; function From_Any (Item : CORBA.Any) return PortableServer.IdAssignmentPolicyValue is begin return From_Any (CORBA.Get_Container (Item).all); end From_Any; function To_Any (Item : PortableServer.IdAssignmentPolicyValue) return CORBA.Any is Result : CORBA.Any := CORBA.Internals.Get_Empty_Any_Aggregate (TC_IdAssignmentPolicyValue); begin CORBA.Internals.Add_Aggregate_Element (Result, CORBA.To_Any (CORBA.Unsigned_Long (IdAssignmentPolicyValue'Pos (Item)))); return Result; end To_Any; type Ptr_Ü_ImplicitActivationPolicyValue is access all PortableServer.ImplicitActivationPolicyValue; type Content_Ü_ImplicitActivationPolicyValue is new PolyORB.Any.Aggregate_Content with record V : Ptr_Ü_ImplicitActivationPolicyValue; Repr_Cache : aliased PolyORB.Types.Unsigned_Long; end record; function Get_Aggregate_Element (ACC : not null access Content_Ü_ImplicitActivationPolicyValue; TC : PolyORB.Any.TypeCode.Object_Ptr; Index : PolyORB.Types.Unsigned_Long; Mech : not null access PolyORB.Any.Mechanism) return PolyORB.Any.Content'Class; procedure Set_Aggregate_Element (ACC : in out Content_Ü_ImplicitActivationPolicyValue; TC : PolyORB.Any.TypeCode.Object_Ptr; Index : PolyORB.Types.Unsigned_Long; From_C : in out PolyORB.Any.Any_Container'Class); function Get_Aggregate_Count (ACC : Content_Ü_ImplicitActivationPolicyValue) return PolyORB.Types.Unsigned_Long; procedure Set_Aggregate_Count (ACC : in out Content_Ü_ImplicitActivationPolicyValue; Count : PolyORB.Types.Unsigned_Long); function Clone (ACC : Content_Ü_ImplicitActivationPolicyValue; Into : PolyORB.Any.Content_Ptr := null) return PolyORB.Any.Content_Ptr; procedure Finalize_Value (ACC : in out Content_Ü_ImplicitActivationPolicyValue); function Get_Aggregate_Element (ACC : not null access Content_Ü_ImplicitActivationPolicyValue; TC : PolyORB.Any.TypeCode.Object_Ptr; Index : PolyORB.Types.Unsigned_Long; Mech : not null access PolyORB.Any.Mechanism) return PolyORB.Any.Content'Class is use type PolyORB.Types.Unsigned_Long; use type PolyORB.Any.Mechanism; pragma Unreferenced (TC, Index); pragma Suppress (All_Checks); begin ACC.Repr_Cache := PortableServer.ImplicitActivationPolicyValue'Pos (ACC.V.all); Mech.all := PolyORB.Any.By_Value; return PolyORB.Any.Wrap (ACC.Repr_Cache'Unrestricted_Access); end Get_Aggregate_Element; procedure Set_Aggregate_Element (ACC : in out Content_Ü_ImplicitActivationPolicyValue; TC : PolyORB.Any.TypeCode.Object_Ptr; Index : PolyORB.Types.Unsigned_Long; From_C : in out PolyORB.Any.Any_Container'Class) is pragma Unreferenced (TC); use type PolyORB.Types.Unsigned_Long; pragma Assert (Index = 0); begin ACC.V.all := PortableServer.ImplicitActivationPolicyValue'Val (PolyORB.Types.Unsigned_Long'(PolyORB.Any.From_Any (From_C))); end Set_Aggregate_Element; function Get_Aggregate_Count (ACC : Content_Ü_ImplicitActivationPolicyValue) return PolyORB.Types.Unsigned_Long is pragma Unreferenced (ACC); begin return 1; end Get_Aggregate_Count; procedure Set_Aggregate_Count (ACC : in out Content_Ü_ImplicitActivationPolicyValue; Count : PolyORB.Types.Unsigned_Long) is use type PolyORB.Types.Unsigned_Long; pragma Unreferenced (ACC); begin if Count /= 1 then raise Program_Error; end if; end Set_Aggregate_Count; function Clone (ACC : Content_Ü_ImplicitActivationPolicyValue; Into : PolyORB.Any.Content_Ptr := null) return PolyORB.Any.Content_Ptr is use type PolyORB.Any.Content_Ptr; Target : PolyORB.Any.Content_Ptr; begin if Into /= null then if Into.all not in Content_Ü_ImplicitActivationPolicyValue then return null; end if; Target := Into; Content_Ü_ImplicitActivationPolicyValue (Target.all).V.all := ACC.V.all; else Target := new Content_Ü_ImplicitActivationPolicyValue; Content_Ü_ImplicitActivationPolicyValue (Target.all).V := new PortableServer.ImplicitActivationPolicyValue'(ACC.V.all); end if; Content_Ü_ImplicitActivationPolicyValue (Target.all).Repr_Cache:= ACC.Repr_Cache; return Target; end Clone; procedure Finalize_Value (ACC : in out Content_Ü_ImplicitActivationPolicyValue) is procedure Free is new Ada.Unchecked_Deallocation (PortableServer.ImplicitActivationPolicyValue, Ptr_Ü_ImplicitActivationPolicyValue); begin Free (ACC.V); end Finalize_Value; function Wrap (X : access PortableServer.ImplicitActivationPolicyValue) return PolyORB.Any.Content'Class is begin return Content_Ü_ImplicitActivationPolicyValue'(PolyORB.Any.Aggregate_Content with V => Ptr_Ü_ImplicitActivationPolicyValue (X), Repr_Cache => 0); end Wrap; function From_Any (C : PolyORB.Any.Any_Container'Class) return PortableServer.ImplicitActivationPolicyValue is ACC : PolyORB.Any.Aggregate_Content'Class renames PolyORB.Any.Aggregate_Content'Class (PolyORB.Any.Get_Value (C).all); El_M : aliased PolyORB.Any.Mechanism := PolyORB.Any.By_Value; El_CC : aliased PolyORB.Any.Content'Class := PolyORB.Any.Get_Aggregate_Element (ACC'Access, PolyORB.Any.TC_Unsigned_Long, 0, El_M'Access); El_C : PolyORB.Any.Any_Container; begin PolyORB.Any.Set_Type (El_C, PolyORB.Any.TC_Unsigned_Long); PolyORB.Any.Set_Value (El_C, El_CC'Unchecked_Access); return ImplicitActivationPolicyValue'Val (PolyORB.Types.Unsigned_Long'(PolyORB.Any.From_Any (El_C))); end From_Any; function From_Any (Item : CORBA.Any) return PortableServer.ImplicitActivationPolicyValue is begin return From_Any (CORBA.Get_Container (Item).all); end From_Any; function To_Any (Item : PortableServer.ImplicitActivationPolicyValue) return CORBA.Any is Result : CORBA.Any := CORBA.Internals.Get_Empty_Any_Aggregate (TC_ImplicitActivationPolicyValue); begin CORBA.Internals.Add_Aggregate_Element (Result, CORBA.To_Any (CORBA.Unsigned_Long (ImplicitActivationPolicyValue'Pos (Item)))); return Result; end To_Any; type Ptr_Ü_ServantRetentionPolicyValue is access all PortableServer.ServantRetentionPolicyValue; type Content_Ü_ServantRetentionPolicyValue is new PolyORB.Any.Aggregate_Content with record V : Ptr_Ü_ServantRetentionPolicyValue; Repr_Cache : aliased PolyORB.Types.Unsigned_Long; end record; function Get_Aggregate_Element (ACC : not null access Content_Ü_ServantRetentionPolicyValue; TC : PolyORB.Any.TypeCode.Object_Ptr; Index : PolyORB.Types.Unsigned_Long; Mech : not null access PolyORB.Any.Mechanism) return PolyORB.Any.Content'Class; procedure Set_Aggregate_Element (ACC : in out Content_Ü_ServantRetentionPolicyValue; TC : PolyORB.Any.TypeCode.Object_Ptr; Index : PolyORB.Types.Unsigned_Long; From_C : in out PolyORB.Any.Any_Container'Class); function Get_Aggregate_Count (ACC : Content_Ü_ServantRetentionPolicyValue) return PolyORB.Types.Unsigned_Long; procedure Set_Aggregate_Count (ACC : in out Content_Ü_ServantRetentionPolicyValue; Count : PolyORB.Types.Unsigned_Long); function Clone (ACC : Content_Ü_ServantRetentionPolicyValue; Into : PolyORB.Any.Content_Ptr := null) return PolyORB.Any.Content_Ptr; procedure Finalize_Value (ACC : in out Content_Ü_ServantRetentionPolicyValue); function Get_Aggregate_Element (ACC : not null access Content_Ü_ServantRetentionPolicyValue; TC : PolyORB.Any.TypeCode.Object_Ptr; Index : PolyORB.Types.Unsigned_Long; Mech : not null access PolyORB.Any.Mechanism) return PolyORB.Any.Content'Class is use type PolyORB.Types.Unsigned_Long; use type PolyORB.Any.Mechanism; pragma Unreferenced (TC, Index); pragma Suppress (All_Checks); begin ACC.Repr_Cache := PortableServer.ServantRetentionPolicyValue'Pos (ACC.V.all); Mech.all := PolyORB.Any.By_Value; return PolyORB.Any.Wrap (ACC.Repr_Cache'Unrestricted_Access); end Get_Aggregate_Element; procedure Set_Aggregate_Element (ACC : in out Content_Ü_ServantRetentionPolicyValue; TC : PolyORB.Any.TypeCode.Object_Ptr; Index : PolyORB.Types.Unsigned_Long; From_C : in out PolyORB.Any.Any_Container'Class) is pragma Unreferenced (TC); use type PolyORB.Types.Unsigned_Long; pragma Assert (Index = 0); begin ACC.V.all := PortableServer.ServantRetentionPolicyValue'Val (PolyORB.Types.Unsigned_Long'(PolyORB.Any.From_Any (From_C))); end Set_Aggregate_Element; function Get_Aggregate_Count (ACC : Content_Ü_ServantRetentionPolicyValue) return PolyORB.Types.Unsigned_Long is pragma Unreferenced (ACC); begin return 1; end Get_Aggregate_Count; procedure Set_Aggregate_Count (ACC : in out Content_Ü_ServantRetentionPolicyValue; Count : PolyORB.Types.Unsigned_Long) is use type PolyORB.Types.Unsigned_Long; pragma Unreferenced (ACC); begin if Count /= 1 then raise Program_Error; end if; end Set_Aggregate_Count; function Clone (ACC : Content_Ü_ServantRetentionPolicyValue; Into : PolyORB.Any.Content_Ptr := null) return PolyORB.Any.Content_Ptr is use type PolyORB.Any.Content_Ptr; Target : PolyORB.Any.Content_Ptr; begin if Into /= null then if Into.all not in Content_Ü_ServantRetentionPolicyValue then return null; end if; Target := Into; Content_Ü_ServantRetentionPolicyValue (Target.all).V.all := ACC.V.all; else Target := new Content_Ü_ServantRetentionPolicyValue; Content_Ü_ServantRetentionPolicyValue (Target.all).V := new PortableServer.ServantRetentionPolicyValue'(ACC.V.all); end if; Content_Ü_ServantRetentionPolicyValue (Target.all).Repr_Cache:= ACC.Repr_Cache; return Target; end Clone; procedure Finalize_Value (ACC : in out Content_Ü_ServantRetentionPolicyValue) is procedure Free is new Ada.Unchecked_Deallocation (PortableServer.ServantRetentionPolicyValue, Ptr_Ü_ServantRetentionPolicyValue); begin Free (ACC.V); end Finalize_Value; function Wrap (X : access PortableServer.ServantRetentionPolicyValue) return PolyORB.Any.Content'Class is begin return Content_Ü_ServantRetentionPolicyValue'(PolyORB.Any.Aggregate_Content with V => Ptr_Ü_ServantRetentionPolicyValue (X), Repr_Cache => 0); end Wrap; function From_Any (C : PolyORB.Any.Any_Container'Class) return PortableServer.ServantRetentionPolicyValue is ACC : PolyORB.Any.Aggregate_Content'Class renames PolyORB.Any.Aggregate_Content'Class (PolyORB.Any.Get_Value (C).all); El_M : aliased PolyORB.Any.Mechanism := PolyORB.Any.By_Value; El_CC : aliased PolyORB.Any.Content'Class := PolyORB.Any.Get_Aggregate_Element (ACC'Access, PolyORB.Any.TC_Unsigned_Long, 0, El_M'Access); El_C : PolyORB.Any.Any_Container; begin PolyORB.Any.Set_Type (El_C, PolyORB.Any.TC_Unsigned_Long); PolyORB.Any.Set_Value (El_C, El_CC'Unchecked_Access); return ServantRetentionPolicyValue'Val (PolyORB.Types.Unsigned_Long'(PolyORB.Any.From_Any (El_C))); end From_Any; function From_Any (Item : CORBA.Any) return PortableServer.ServantRetentionPolicyValue is begin return From_Any (CORBA.Get_Container (Item).all); end From_Any; function To_Any (Item : PortableServer.ServantRetentionPolicyValue) return CORBA.Any is Result : CORBA.Any := CORBA.Internals.Get_Empty_Any_Aggregate (TC_ServantRetentionPolicyValue); begin CORBA.Internals.Add_Aggregate_Element (Result, CORBA.To_Any (CORBA.Unsigned_Long (ServantRetentionPolicyValue'Pos (Item)))); return Result; end To_Any; type Ptr_Ü_RequestProcessingPolicyValue is access all PortableServer.RequestProcessingPolicyValue; type Content_Ü_RequestProcessingPolicyValue is new PolyORB.Any.Aggregate_Content with record V : Ptr_Ü_RequestProcessingPolicyValue; Repr_Cache : aliased PolyORB.Types.Unsigned_Long; end record; function Get_Aggregate_Element (ACC : not null access Content_Ü_RequestProcessingPolicyValue; TC : PolyORB.Any.TypeCode.Object_Ptr; Index : PolyORB.Types.Unsigned_Long; Mech : not null access PolyORB.Any.Mechanism) return PolyORB.Any.Content'Class; procedure Set_Aggregate_Element (ACC : in out Content_Ü_RequestProcessingPolicyValue; TC : PolyORB.Any.TypeCode.Object_Ptr; Index : PolyORB.Types.Unsigned_Long; From_C : in out PolyORB.Any.Any_Container'Class); function Get_Aggregate_Count (ACC : Content_Ü_RequestProcessingPolicyValue) return PolyORB.Types.Unsigned_Long; procedure Set_Aggregate_Count (ACC : in out Content_Ü_RequestProcessingPolicyValue; Count : PolyORB.Types.Unsigned_Long); function Clone (ACC : Content_Ü_RequestProcessingPolicyValue; Into : PolyORB.Any.Content_Ptr := null) return PolyORB.Any.Content_Ptr; procedure Finalize_Value (ACC : in out Content_Ü_RequestProcessingPolicyValue); function Get_Aggregate_Element (ACC : not null access Content_Ü_RequestProcessingPolicyValue; TC : PolyORB.Any.TypeCode.Object_Ptr; Index : PolyORB.Types.Unsigned_Long; Mech : not null access PolyORB.Any.Mechanism) return PolyORB.Any.Content'Class is use type PolyORB.Types.Unsigned_Long; use type PolyORB.Any.Mechanism; pragma Unreferenced (TC, Index); pragma Suppress (All_Checks); begin ACC.Repr_Cache := PortableServer.RequestProcessingPolicyValue'Pos (ACC.V.all); Mech.all := PolyORB.Any.By_Value; return PolyORB.Any.Wrap (ACC.Repr_Cache'Unrestricted_Access); end Get_Aggregate_Element; procedure Set_Aggregate_Element (ACC : in out Content_Ü_RequestProcessingPolicyValue; TC : PolyORB.Any.TypeCode.Object_Ptr; Index : PolyORB.Types.Unsigned_Long; From_C : in out PolyORB.Any.Any_Container'Class) is pragma Unreferenced (TC); use type PolyORB.Types.Unsigned_Long; pragma Assert (Index = 0); begin ACC.V.all := PortableServer.RequestProcessingPolicyValue'Val (PolyORB.Types.Unsigned_Long'(PolyORB.Any.From_Any (From_C))); end Set_Aggregate_Element; function Get_Aggregate_Count (ACC : Content_Ü_RequestProcessingPolicyValue) return PolyORB.Types.Unsigned_Long is pragma Unreferenced (ACC); begin return 1; end Get_Aggregate_Count; procedure Set_Aggregate_Count (ACC : in out Content_Ü_RequestProcessingPolicyValue; Count : PolyORB.Types.Unsigned_Long) is use type PolyORB.Types.Unsigned_Long; pragma Unreferenced (ACC); begin if Count /= 1 then raise Program_Error; end if; end Set_Aggregate_Count; function Clone (ACC : Content_Ü_RequestProcessingPolicyValue; Into : PolyORB.Any.Content_Ptr := null) return PolyORB.Any.Content_Ptr is use type PolyORB.Any.Content_Ptr; Target : PolyORB.Any.Content_Ptr; begin if Into /= null then if Into.all not in Content_Ü_RequestProcessingPolicyValue then return null; end if; Target := Into; Content_Ü_RequestProcessingPolicyValue (Target.all).V.all := ACC.V.all; else Target := new Content_Ü_RequestProcessingPolicyValue; Content_Ü_RequestProcessingPolicyValue (Target.all).V := new PortableServer.RequestProcessingPolicyValue'(ACC.V.all); end if; Content_Ü_RequestProcessingPolicyValue (Target.all).Repr_Cache:= ACC.Repr_Cache; return Target; end Clone; procedure Finalize_Value (ACC : in out Content_Ü_RequestProcessingPolicyValue) is procedure Free is new Ada.Unchecked_Deallocation (PortableServer.RequestProcessingPolicyValue, Ptr_Ü_RequestProcessingPolicyValue); begin Free (ACC.V); end Finalize_Value; function Wrap (X : access PortableServer.RequestProcessingPolicyValue) return PolyORB.Any.Content'Class is begin return Content_Ü_RequestProcessingPolicyValue'(PolyORB.Any.Aggregate_Content with V => Ptr_Ü_RequestProcessingPolicyValue (X), Repr_Cache => 0); end Wrap; function From_Any (C : PolyORB.Any.Any_Container'Class) return PortableServer.RequestProcessingPolicyValue is ACC : PolyORB.Any.Aggregate_Content'Class renames PolyORB.Any.Aggregate_Content'Class (PolyORB.Any.Get_Value (C).all); El_M : aliased PolyORB.Any.Mechanism := PolyORB.Any.By_Value; El_CC : aliased PolyORB.Any.Content'Class := PolyORB.Any.Get_Aggregate_Element (ACC'Access, PolyORB.Any.TC_Unsigned_Long, 0, El_M'Access); El_C : PolyORB.Any.Any_Container; begin PolyORB.Any.Set_Type (El_C, PolyORB.Any.TC_Unsigned_Long); PolyORB.Any.Set_Value (El_C, El_CC'Unchecked_Access); return RequestProcessingPolicyValue'Val (PolyORB.Types.Unsigned_Long'(PolyORB.Any.From_Any (El_C))); end From_Any; function From_Any (Item : CORBA.Any) return PortableServer.RequestProcessingPolicyValue is begin return From_Any (CORBA.Get_Container (Item).all); end From_Any; function To_Any (Item : PortableServer.RequestProcessingPolicyValue) return CORBA.Any is Result : CORBA.Any := CORBA.Internals.Get_Empty_Any_Aggregate (TC_RequestProcessingPolicyValue); begin CORBA.Internals.Add_Aggregate_Element (Result, CORBA.To_Any (CORBA.Unsigned_Long (RequestProcessingPolicyValue'Pos (Item)))); return Result; end To_Any; procedure Deferred_Initialization is begin declare Name : constant CORBA.String := CORBA.To_CORBA_String ("POA"); Id : constant CORBA.String := CORBA.To_CORBA_String ("IDL:omg.org/PortableServer/POA:1.0"); begin TC_POA := CORBA.TypeCode.Internals.To_CORBA_Object (PolyORB.Any.TypeCode.TC_Object); CORBA.Internals.Add_Parameter (TC_POA, CORBA.To_Any (Name)); CORBA.Internals.Add_Parameter (TC_POA, CORBA.To_Any (Id)); CORBA.TypeCode.Internals.Disable_Reference_Counting (TC_POA); end; TC_IDL_SEQUENCE_PortableServer_POA_Forward := CORBA.TypeCode.Internals.Build_Sequence_TC (PortableServer.POA.Helper.TC_POA, 0); CORBA.TypeCode.Internals.Disable_Reference_Counting (TC_IDL_SEQUENCE_PortableServer_POA_Forward); declare Name : constant CORBA.String := CORBA.To_CORBA_String ("POAList"); Id : constant CORBA.String := CORBA.To_CORBA_String ("IDL:omg.org/PortableServer/POAList:1.0"); begin TC_POAList := CORBA.TypeCode.Internals.Build_Alias_TC (Name => Name, Id => Id, Parent => PortableServer.Helper.TC_IDL_SEQUENCE_PortableServer_POA_Forward); CORBA.TypeCode.Internals.Disable_Reference_Counting (TC_POAList); end; declare Name : constant CORBA.String := CORBA.To_CORBA_String ("ObjectId"); Id : constant CORBA.String := CORBA.To_CORBA_String ("IDL:omg.org/PortableServer/ObjectId:1.0"); begin TC_ObjectId := CORBA.TypeCode.Internals.Build_Alias_TC (Name => Name, Id => Id, Parent => CORBA.IDL_SEQUENCES.Helper.TC_OctetSeq); CORBA.TypeCode.Internals.Disable_Reference_Counting (TC_ObjectId); end; declare Name : constant CORBA.String := CORBA.To_CORBA_String ("ForwardRequest"); Id : constant CORBA.String := CORBA.To_CORBA_String ("IDL:omg.org/PortableServer/ForwardRequest:1.0"); Arg_Name_forward_reference : constant CORBA.String := CORBA.To_CORBA_String ("forward_reference"); begin TC_ForwardRequest := CORBA.TypeCode.Internals.To_CORBA_Object (PolyORB.Any.TypeCode.TC_Except); CORBA.Internals.Add_Parameter (TC_ForwardRequest, CORBA.To_Any (Name)); CORBA.Internals.Add_Parameter (TC_ForwardRequest, CORBA.To_Any (Id)); CORBA.Internals.Add_Parameter (TC_ForwardRequest, CORBA.To_Any (CORBA.Object.Helper.TC_Object)); CORBA.Internals.Add_Parameter (TC_ForwardRequest, CORBA.To_Any (Arg_Name_forward_reference)); CORBA.TypeCode.Internals.Disable_Reference_Counting (TC_ForwardRequest); end; PolyORB.Exceptions.Register_Exception (CORBA.TypeCode.Internals.To_PolyORB_Object (TC_ForwardRequest), Raise_ForwardRequest_From_Any'Access); declare Name : constant CORBA.String := CORBA.To_CORBA_String ("ThreadPolicyValue"); Id : constant CORBA.String := CORBA.To_CORBA_String ("IDL:omg.org/PortableServer/ThreadPolicyValue:1.0"); ORB_CTRL_MODEL_Name : constant CORBA.String := CORBA.To_CORBA_String ("ORB_CTRL_MODEL"); SINGLE_THREAD_MODEL_Name : constant CORBA.String := CORBA.To_CORBA_String ("SINGLE_THREAD_MODEL"); MAIN_THREAD_MODEL_Name : constant CORBA.String := CORBA.To_CORBA_String ("MAIN_THREAD_MODEL"); begin TC_ThreadPolicyValue := CORBA.TypeCode.Internals.To_CORBA_Object (PolyORB.Any.TypeCode.TC_Enum); CORBA.Internals.Add_Parameter (TC_ThreadPolicyValue, CORBA.To_Any (Name)); CORBA.Internals.Add_Parameter (TC_ThreadPolicyValue, CORBA.To_Any (Id)); CORBA.Internals.Add_Parameter (TC_ThreadPolicyValue, CORBA.To_Any (ORB_CTRL_MODEL_Name)); CORBA.Internals.Add_Parameter (TC_ThreadPolicyValue, CORBA.To_Any (SINGLE_THREAD_MODEL_Name)); CORBA.Internals.Add_Parameter (TC_ThreadPolicyValue, CORBA.To_Any (MAIN_THREAD_MODEL_Name)); CORBA.TypeCode.Internals.Disable_Reference_Counting (TC_ThreadPolicyValue); end; declare Name : constant CORBA.String := CORBA.To_CORBA_String ("LifespanPolicyValue"); Id : constant CORBA.String := CORBA.To_CORBA_String ("IDL:omg.org/PortableServer/LifespanPolicyValue:1.0"); TRANSIENT_Name : constant CORBA.String := CORBA.To_CORBA_String ("TRANSIENT"); PERSISTENT_Name : constant CORBA.String := CORBA.To_CORBA_String ("PERSISTENT"); begin TC_LifespanPolicyValue := CORBA.TypeCode.Internals.To_CORBA_Object (PolyORB.Any.TypeCode.TC_Enum); CORBA.Internals.Add_Parameter (TC_LifespanPolicyValue, CORBA.To_Any (Name)); CORBA.Internals.Add_Parameter (TC_LifespanPolicyValue, CORBA.To_Any (Id)); CORBA.Internals.Add_Parameter (TC_LifespanPolicyValue, CORBA.To_Any (TRANSIENT_Name)); CORBA.Internals.Add_Parameter (TC_LifespanPolicyValue, CORBA.To_Any (PERSISTENT_Name)); CORBA.TypeCode.Internals.Disable_Reference_Counting (TC_LifespanPolicyValue); end; declare Name : constant CORBA.String := CORBA.To_CORBA_String ("IdUniquenessPolicyValue"); Id : constant CORBA.String := CORBA.To_CORBA_String ("IDL:omg.org/PortableServer/IdUniquenessPolicyValue:1.0"); UNIQUE_ID_Name : constant CORBA.String := CORBA.To_CORBA_String ("UNIQUE_ID"); MULTIPLE_ID_Name : constant CORBA.String := CORBA.To_CORBA_String ("MULTIPLE_ID"); begin TC_IdUniquenessPolicyValue := CORBA.TypeCode.Internals.To_CORBA_Object (PolyORB.Any.TypeCode.TC_Enum); CORBA.Internals.Add_Parameter (TC_IdUniquenessPolicyValue, CORBA.To_Any (Name)); CORBA.Internals.Add_Parameter (TC_IdUniquenessPolicyValue, CORBA.To_Any (Id)); CORBA.Internals.Add_Parameter (TC_IdUniquenessPolicyValue, CORBA.To_Any (UNIQUE_ID_Name)); CORBA.Internals.Add_Parameter (TC_IdUniquenessPolicyValue, CORBA.To_Any (MULTIPLE_ID_Name)); CORBA.TypeCode.Internals.Disable_Reference_Counting (TC_IdUniquenessPolicyValue); end; declare Name : constant CORBA.String := CORBA.To_CORBA_String ("IdAssignmentPolicyValue"); Id : constant CORBA.String := CORBA.To_CORBA_String ("IDL:omg.org/PortableServer/IdAssignmentPolicyValue:1.0"); USER_ID_Name : constant CORBA.String := CORBA.To_CORBA_String ("USER_ID"); SYSTEM_ID_Name : constant CORBA.String := CORBA.To_CORBA_String ("SYSTEM_ID"); begin TC_IdAssignmentPolicyValue := CORBA.TypeCode.Internals.To_CORBA_Object (PolyORB.Any.TypeCode.TC_Enum); CORBA.Internals.Add_Parameter (TC_IdAssignmentPolicyValue, CORBA.To_Any (Name)); CORBA.Internals.Add_Parameter (TC_IdAssignmentPolicyValue, CORBA.To_Any (Id)); CORBA.Internals.Add_Parameter (TC_IdAssignmentPolicyValue, CORBA.To_Any (USER_ID_Name)); CORBA.Internals.Add_Parameter (TC_IdAssignmentPolicyValue, CORBA.To_Any (SYSTEM_ID_Name)); CORBA.TypeCode.Internals.Disable_Reference_Counting (TC_IdAssignmentPolicyValue); end; declare Name : constant CORBA.String := CORBA.To_CORBA_String ("ImplicitActivationPolicyValue"); Id : constant CORBA.String := CORBA.To_CORBA_String ("IDL:omg.org/PortableServer/ImplicitActivationPolicyValue:1.0"); IMPLICIT_ACTIVATION_Name : constant CORBA.String := CORBA.To_CORBA_String ("IMPLICIT_ACTIVATION"); NO_IMPLICIT_ACTIVATION_Name : constant CORBA.String := CORBA.To_CORBA_String ("NO_IMPLICIT_ACTIVATION"); begin TC_ImplicitActivationPolicyValue := CORBA.TypeCode.Internals.To_CORBA_Object (PolyORB.Any.TypeCode.TC_Enum); CORBA.Internals.Add_Parameter (TC_ImplicitActivationPolicyValue, CORBA.To_Any (Name)); CORBA.Internals.Add_Parameter (TC_ImplicitActivationPolicyValue, CORBA.To_Any (Id)); CORBA.Internals.Add_Parameter (TC_ImplicitActivationPolicyValue, CORBA.To_Any (IMPLICIT_ACTIVATION_Name)); CORBA.Internals.Add_Parameter (TC_ImplicitActivationPolicyValue, CORBA.To_Any (NO_IMPLICIT_ACTIVATION_Name)); CORBA.TypeCode.Internals.Disable_Reference_Counting (TC_ImplicitActivationPolicyValue); end; declare Name : constant CORBA.String := CORBA.To_CORBA_String ("ServantRetentionPolicyValue"); Id : constant CORBA.String := CORBA.To_CORBA_String ("IDL:omg.org/PortableServer/ServantRetentionPolicyValue:1.0"); RETAIN_Name : constant CORBA.String := CORBA.To_CORBA_String ("RETAIN"); NON_RETAIN_Name : constant CORBA.String := CORBA.To_CORBA_String ("NON_RETAIN"); begin TC_ServantRetentionPolicyValue := CORBA.TypeCode.Internals.To_CORBA_Object (PolyORB.Any.TypeCode.TC_Enum); CORBA.Internals.Add_Parameter (TC_ServantRetentionPolicyValue, CORBA.To_Any (Name)); CORBA.Internals.Add_Parameter (TC_ServantRetentionPolicyValue, CORBA.To_Any (Id)); CORBA.Internals.Add_Parameter (TC_ServantRetentionPolicyValue, CORBA.To_Any (RETAIN_Name)); CORBA.Internals.Add_Parameter (TC_ServantRetentionPolicyValue, CORBA.To_Any (NON_RETAIN_Name)); CORBA.TypeCode.Internals.Disable_Reference_Counting (TC_ServantRetentionPolicyValue); end; declare Name : constant CORBA.String := CORBA.To_CORBA_String ("RequestProcessingPolicyValue"); Id : constant CORBA.String := CORBA.To_CORBA_String ("IDL:omg.org/PortableServer/RequestProcessingPolicyValue:1.0"); USE_ACTIVE_OBJECT_MAP_ONLY_Name : constant CORBA.String := CORBA.To_CORBA_String ("USE_ACTIVE_OBJECT_MAP_ONLY"); USE_DEFAULT_SERVANT_Name : constant CORBA.String := CORBA.To_CORBA_String ("USE_DEFAULT_SERVANT"); USE_SERVANT_MANAGER_Name : constant CORBA.String := CORBA.To_CORBA_String ("USE_SERVANT_MANAGER"); begin TC_RequestProcessingPolicyValue := CORBA.TypeCode.Internals.To_CORBA_Object (PolyORB.Any.TypeCode.TC_Enum); CORBA.Internals.Add_Parameter (TC_RequestProcessingPolicyValue, CORBA.To_Any (Name)); CORBA.Internals.Add_Parameter (TC_RequestProcessingPolicyValue, CORBA.To_Any (Id)); CORBA.Internals.Add_Parameter (TC_RequestProcessingPolicyValue, CORBA.To_Any (USE_ACTIVE_OBJECT_MAP_ONLY_Name)); CORBA.Internals.Add_Parameter (TC_RequestProcessingPolicyValue, CORBA.To_Any (USE_DEFAULT_SERVANT_Name)); CORBA.Internals.Add_Parameter (TC_RequestProcessingPolicyValue, CORBA.To_Any (USE_SERVANT_MANAGER_Name)); CORBA.TypeCode.Internals.Disable_Reference_Counting (TC_RequestProcessingPolicyValue); end; end Deferred_Initialization; begin declare use PolyORB.Initialization; use PolyORB.Initialization.String_Lists; use PolyORB.Utils.Strings; begin Register_Module (Module_Info' (Name => +"PortableServer.Helper", Conflicts => PolyORB.Initialization.String_Lists.Empty, Depends => +"any" & "PortableServer.POA.Helper" & "CORBA.IDL_SEQUENCES.Helper" & "corba.object" & "exceptions" , Provides => PolyORB.Initialization.String_Lists.Empty, Implicit => False, Init => Deferred_Initialization'Access, Shutdown => null)); end; end PortableServer.Helper; polyorb-2.8~20110207.orig/src/corba/polyorb-corba_p-ir_hooks.adb0000644000175000017500000000513411750740340023636 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . C O R B A _ P . I R _ H O O K S -- -- -- -- B o d y -- -- -- -- Copyright (C) 2005-2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ package body PolyORB.CORBA_P.IR_Hooks is -------------------------------------- -- Default_Get_Interface_Definition -- -------------------------------------- function Default_Get_Interface_Definition (Id : CORBA.RepositoryId) return CORBA.Object.Ref'Class is pragma Unreferenced (Id); Result : CORBA.Object.Ref; begin CORBA.Raise_Intf_Repos (CORBA.System_Exception_Members' (Minor => 1, Completed => CORBA.Completed_No)); return Result; end Default_Get_Interface_Definition; end PolyORB.CORBA_P.IR_Hooks; polyorb-2.8~20110207.orig/src/corba/corba-repository_root.ads0000644000175000017500000005533011750740340023324 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- C O R B A . R E P O S I T O R Y _ R O O T -- -- -- -- S p e c -- -- -- -- Copyright (C) 2004-2008, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the CORBA Specification, and adapted -- -- for use with PolyORB. The copyright notice above, and the license -- -- provisions that follow apply solely to the contents neither explicitly -- -- nor implicitly specified by the CORBA Specification defined by the OMG. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- Implementation Note: this package defines data types introduced by -- the specification of the Interface Repository. OMG Issue #3639: -- The Ada mapping of the Interface Repository states that these -- types cannot be added to the CORBA package because this would -- introduce a circular dependence between CORBA and CORBA.Forward -- package. -- -- Thus, we follow the proposed correction: -- -- "The types defined within module CORBA by the Interface -- Repository Specification (formal/99-10-07, p10-56 to 10-68), -- except the TypeCode and ORB interfaces, shall be mapped to a -- (child) library package CORBA.Repository_Root." -- -- In addition to this correction, we retained standard names for -- types: all declared type ids are prefixed by CORBA, not -- CORBA.Repository_Root. with CORBA.Forward; pragma Elaborate_All (CORBA.Forward); with CORBA.Sequences.Unbounded; pragma Elaborate_All (CORBA.Sequences.Unbounded); package CORBA.Repository_Root is -- Implementation Notes: these three forward declarations below is -- not declared in CORBA_InterfaceRepository.idl file, but it is -- required for child packages. package ArrayDef_Forward is new CORBA.Forward; package AttributeDef_Forward is new CORBA.Forward; package Contained_Forward is new CORBA.Forward; package Container_Forward is new CORBA.Forward; package FixedDef_Forward is new CORBA.Forward; package IRObject_Forward is new CORBA.Forward; package OperationDef_Forward is new CORBA.Forward; package PrimitiveDef_Forward is new CORBA.Forward; package Repository_Forward is new CORBA.Forward; package SequenceDef_Forward is new CORBA.Forward; package StringDef_Forward is new CORBA.Forward; package TypedefDef_Forward is new CORBA.Forward; package ValueMemberDef_Forward is new CORBA.Forward; package WstringDef_Forward is new CORBA.Forward; -- enum DefinitionKind type DefinitionKind is (dk_none, dk_all, dk_Attribute, dk_Constant, dk_Exception, dk_Interface, dk_Module, dk_Operation, dk_Typedef, dk_Alias, dk_Struct, dk_Union, dk_Enum, dk_Primitive, dk_String, dk_Sequence, dk_Array, dk_Repository, dk_Wstring, dk_Fixed, dk_Value, dk_ValueBox, dk_ValueMember, dk_Native, dk_AbstractInterface, dk_LocalInterface, dk_Component, dk_Home, dk_Factory, dk_Finder, dk_Emits, dk_Publishes, dk_Consumes, dk_Provides, dk_Uses, dk_Event); -- typedef VersionSpec type VersionSpec is new CORBA.String; package ModuleDef_Forward is new CORBA.Forward; package ConstantDef_Forward is new CORBA.Forward; package IDLType_Forward is new CORBA.Forward; package StructDef_Forward is new CORBA.Forward; package UnionDef_Forward is new CORBA.Forward; package EnumDef_Forward is new CORBA.Forward; package AliasDef_Forward is new CORBA.Forward; package ExceptionDef_Forward is new CORBA.Forward; package NativeDef_Forward is new CORBA.Forward; package InterfaceDef_Forward is new CORBA.Forward; -- typedef InterfaceDefSeq package IDL_SEQUENCE_CORBA_InterfaceDef_Forward is new CORBA.Sequences.Unbounded (InterfaceDef_Forward.Ref); type InterfaceDefSeq is new IDL_SEQUENCE_CORBA_InterfaceDef_Forward.Sequence; package ValueDef_Forward is new CORBA.Forward; -- typedef ValueDefSeq package IDL_SEQUENCE_CORBA_ValueDef_Forward is new CORBA.Sequences.Unbounded (ValueDef_Forward.Ref); type ValueDefSeq is new IDL_SEQUENCE_CORBA_ValueDef_Forward.Sequence; package ValueBoxDef_Forward is new CORBA.Forward; package AbstractInterfaceDef_Forward is new CORBA.Forward; -- typedef AbstractInterfaceDefSeq package IDL_SEQUENCE_CORBA_AbstractInterfaceDef_Forward is new CORBA.Sequences.Unbounded (AbstractInterfaceDef_Forward.Ref); type AbstractInterfaceDefSeq is new IDL_SEQUENCE_CORBA_AbstractInterfaceDef_Forward.Sequence; package LocalInterfaceDef_Forward is new CORBA.Forward; -- typedef LocalInterfaceDefSeq package IDL_SEQUENCE_CORBA_LocalInterfaceDef_Forward is new CORBA.Sequences.Unbounded (LocalInterfaceDef_Forward.Ref); type LocalInterfaceDefSeq is new IDL_SEQUENCE_CORBA_LocalInterfaceDef_Forward.Sequence; package ExtInterfaceDef_Forward is new CORBA.Forward; -- typedef ExtInterfaceDefSeq package IDL_SEQUENCE_CORBA_ExtInterfaceDef_Forward is new CORBA.Sequences.Unbounded (ExtInterfaceDef_Forward.Ref); type ExtInterfaceDefSeq is new IDL_SEQUENCE_CORBA_ExtInterfaceDef_Forward.Sequence; package ExtValueDef_Forward is new CORBA.Forward; -- typedef ExtValueDefSeq package IDL_SEQUENCE_CORBA_ExtValueDef_Forward is new CORBA.Sequences.Unbounded (ExtValueDef_Forward.Ref); type ExtValueDefSeq is new IDL_SEQUENCE_CORBA_ExtValueDef_Forward.Sequence; -- ExtAbstractInterfaceDef forward declaration package ExtAbstractInterfaceDef_Forward is new CORBA.Forward; -- typedef ExtAbstractInterfaceDefSeq package IDL_SEQUENCE_CORBA_ExtAbstractInterfaceDef_Forward is new CORBA.Sequences.Unbounded (ExtAbstractInterfaceDef_Forward.Ref); type ExtAbstractInterfaceDefSeq is new IDL_SEQUENCE_CORBA_ExtAbstractInterfaceDef_Forward.Sequence; -- ExtLocalInterfaceDef forward declaration package ExtLocalInterfaceDef_Forward is new CORBA.Forward; -- typedef ExtLocalInterfaceDefSeq package IDL_SEQUENCE_CORBA_ExtLocalInterfaceDef_Forward is new CORBA.Sequences.Unbounded (ExtLocalInterfaceDef_Forward.Ref); type ExtLocalInterfaceDefSeq is new IDL_SEQUENCE_CORBA_ExtLocalInterfaceDef_Forward.Sequence; -- typedef ContainedSeq package IDL_SEQUENCE_CORBA_Contained_Forward is new CORBA.Sequences.Unbounded (Contained_Forward.Ref); type ContainedSeq is new IDL_SEQUENCE_CORBA_Contained_Forward.Sequence; -- struct StructMember type StructMember is record Name : CORBA.Identifier; IDL_Type : CORBA.TypeCode.Object; Type_Def : CORBA.Repository_Root.IDLType_Forward.Ref; end record; -- typedef StructMemberSeq package IDL_SEQUENCE_CORBA_StructMember is new CORBA.Sequences.Unbounded (StructMember); type StructMemberSeq is new IDL_SEQUENCE_CORBA_StructMember.Sequence; -- struct Initializer type Initializer is record Members : CORBA.Repository_Root.StructMemberSeq; Name : CORBA.Identifier; end record; -- typedef InitializerSeq package IDL_SEQUENCE_CORBA_Initializer is new CORBA.Sequences.Unbounded (Initializer); type InitializerSeq is new IDL_SEQUENCE_CORBA_Initializer.Sequence; -- struct UnionMember type UnionMember is record Name : CORBA.Identifier; Label : CORBA.Any; IDL_Type : CORBA.TypeCode.Object; Type_Def : CORBA.Repository_Root.IDLType_Forward.Ref; end record; -- struct ExceptionDescription type ExceptionDescription is record Name : CORBA.Identifier; Id : CORBA.RepositoryId; Defined_In : CORBA.RepositoryId; Version : CORBA.Repository_Root.VersionSpec; IDL_Type : CORBA.TypeCode.Object; end record; -- typedef ExcDescriptionSeq package IDL_SEQUENCE_CORBA_ExceptionDescription is new CORBA.Sequences.Unbounded (ExceptionDescription); type ExcDescriptionSeq is new IDL_SEQUENCE_CORBA_ExceptionDescription.Sequence; -- struct ExtInitializer type ExtInitializer is record Members : CORBA.Repository_Root.StructMemberSeq; Exceptions : CORBA.Repository_Root.ExcDescriptionSeq; Name : CORBA.Identifier; end record; -- typedef ExtInitializerSeq package IDL_SEQUENCE_CORBA_ExtInitializer is new CORBA.Sequences.Unbounded (ExtInitializer); type ExtInitializerSeq is new IDL_SEQUENCE_CORBA_ExtInitializer.Sequence; -- typedef UnionMemberSeq package IDL_SEQUENCE_CORBA_UnionMember is new CORBA.Sequences.Unbounded (UnionMember); type UnionMemberSeq is new IDL_SEQUENCE_CORBA_UnionMember.Sequence; -- typedef EnumMemberSeq package IDL_SEQUENCE_CORBA_Identifier is new CORBA.Sequences.Unbounded (CORBA.Identifier); type EnumMemberSeq is new IDL_SEQUENCE_CORBA_Identifier.Sequence; -- enum PrimitiveKind type PrimitiveKind is (pk_null, pk_void, pk_short, pk_long, pk_ushort, pk_ulong, pk_float, pk_double, pk_boolean, pk_char, pk_octet, pk_any, pk_TypeCode, pk_Principal, pk_string, pk_objref, pk_longlong, pk_ulonglong, pk_longdouble, pk_wchar, pk_wstring, pk_value_base); -- struct ModuleDescription type ModuleDescription is record Name : CORBA.Identifier; Id : CORBA.RepositoryId; Defined_In : CORBA.RepositoryId; Version : CORBA.Repository_Root.VersionSpec; end record; -- struct ConstantDescription type ConstantDescription is record Name : CORBA.Identifier; Id : CORBA.RepositoryId; Defined_In : CORBA.RepositoryId; Version : CORBA.Repository_Root.VersionSpec; IDL_Type : CORBA.TypeCode.Object; Value : CORBA.Any; end record; -- struct TypeDescription type TypeDescription is record Name : CORBA.Identifier; Id : CORBA.RepositoryId; Defined_In : CORBA.RepositoryId; Version : CORBA.Repository_Root.VersionSpec; IDL_type : CORBA.TypeCode.Object; end record; -- enum AttributeMode type AttributeMode is (ATTR_NORMAL, ATTR_READONLY); -- struct AttributeDescription type AttributeDescription is record Name : CORBA.Identifier; Id : CORBA.RepositoryId; Defined_In : CORBA.RepositoryId; Version : CORBA.Repository_Root.VersionSpec; IDL_Type : CORBA.TypeCode.Object; Mode : CORBA.Repository_Root.AttributeMode; end record; -- struct ExtAttributeDescription type ExtAttributeDescription is record Name : CORBA.Identifier; Id : CORBA.RepositoryId; Defined_In : CORBA.RepositoryId; Version : CORBA.Repository_Root.VersionSpec; IDL_Type : CORBA.TypeCode.Object; Mode : CORBA.Repository_Root.AttributeMode; Get_Exceptions : CORBA.Repository_Root.ExcDescriptionSeq; Put_Exceptions : CORBA.Repository_Root.ExcDescriptionSeq; end record; -- enum OperationMode type OperationMode is (OP_NORMAL, OP_ONEWAY); -- enum ParameterMode type ParameterMode is (PARAM_IN, PARAM_OUT, PARAM_INOUT); -- struct ParameterDescription type ParameterDescription is record Name : CORBA.Identifier; IDL_Type : CORBA.TypeCode.Object; Type_Def : CORBA.Repository_Root.IDLType_Forward.Ref; Mode : CORBA.Repository_Root.ParameterMode; end record; -- typedef ParDescriptionSeq package IDL_SEQUENCE_CORBA_ParameterDescription is new CORBA.Sequences.Unbounded (ParameterDescription); type ParDescriptionSeq is new IDL_SEQUENCE_CORBA_ParameterDescription.Sequence; -- typedef ContextIdentifier type ContextIdentifier is new CORBA.Identifier; -- typedef ContextIdSeq package IDL_SEQUENCE_CORBA_ContextIdentifier is new CORBA.Sequences.Unbounded (ContextIdentifier); type ContextIdSeq is new IDL_SEQUENCE_CORBA_ContextIdentifier.Sequence; -- typedef ExceptionDefSeq package IDL_SEQUENCE_CORBA_ExceptionDef_Forward is new CORBA.Sequences.Unbounded (ExceptionDef_Forward.Ref); type ExceptionDefSeq is new IDL_SEQUENCE_CORBA_ExceptionDef_Forward.Sequence; -- struct OperationDescription type OperationDescription is record Name : CORBA.Identifier; Id : CORBA.RepositoryId; Defined_In : CORBA.RepositoryId; Version : CORBA.Repository_Root.VersionSpec; Result : CORBA.TypeCode.Object; Mode : CORBA.Repository_Root.OperationMode; Contexts : CORBA.Repository_Root.ContextIdSeq; Parameters : CORBA.Repository_Root.ParDescriptionSeq; Exceptions : CORBA.Repository_Root.ExcDescriptionSeq; end record; -- typedef RepositoryIdSeq package IDL_SEQUENCE_CORBA_RepositoryId is new CORBA.Sequences.Unbounded (RepositoryId); type RepositoryIdSeq is new IDL_SEQUENCE_CORBA_RepositoryId.Sequence; -- typedef OpDescriptionSeq package IDL_SEQUENCE_CORBA_OperationDescription is new CORBA.Sequences.Unbounded (OperationDescription); type OpDescriptionSeq is new IDL_SEQUENCE_CORBA_OperationDescription.Sequence; -- typedef AttrDescriptionSeq package IDL_SEQUENCE_CORBA_AttributeDescription is new CORBA.Sequences.Unbounded (AttributeDescription); type AttrDescriptionSeq is new IDL_SEQUENCE_CORBA_AttributeDescription.Sequence; -- typedef ExtAttrDescriptionSeq package IDL_SEQUENCE_CORBA_ExtAttributeDescription is new CORBA.Sequences.Unbounded (ExtAttributeDescription); type ExtAttrDescriptionSeq is new IDL_SEQUENCE_CORBA_ExtAttributeDescription.Sequence; -- struct InterfaceDescription type InterfaceDescription is record Name : CORBA.Identifier; Id : CORBA.RepositoryId; Defined_In : CORBA.RepositoryId; Version : CORBA.Repository_Root.VersionSpec; Base_Interfaces : CORBA.Repository_Root.RepositoryIdSeq; Is_Abstract : CORBA.Boolean; end record; -- Implementation Note: the IDL-to-Ada mapping specifications -- states that the Visibility type is part of the CORBA package -- specification. However, this type is defined in the -- specification of the Interface Repository, and thus should be -- in this package. The definition of the Visibility type is in -- the CORBA package. -- typedef Visibility -- -- type Visibility is new CORBA.Short; -- -- PRIVATE_MEMBER : constant Visibility := 0; -- PUBLIC_MEMBER : constant Visibility := 1; -- struct ValueMember type ValueMember is record Name : CORBA.Identifier; Id : CORBA.RepositoryId; Defined_In : CORBA.RepositoryId; Version : CORBA.Repository_Root.VersionSpec; IDL_Type : CORBA.TypeCode.Object; Type_Def : CORBA.Repository_Root.IDLType_Forward.Ref; IDL_Access : CORBA.Visibility; end record; -- typedef ValueMemberSeq package IDL_SEQUENCE_CORBA_ValueMember is new CORBA.Sequences.Unbounded (ValueMember); type ValueMemberSeq is new IDL_SEQUENCE_CORBA_ValueMember.Sequence; -- struct ValueDescription type ValueDescription is record Name : CORBA.Identifier; Id : CORBA.RepositoryId; Is_Abstract : CORBA.Boolean; Is_Custom : CORBA.Boolean; Defined_In : CORBA.RepositoryId; Version : CORBA.Repository_Root.VersionSpec; Supported_Interfaces : CORBA.Repository_Root.RepositoryIdSeq; Abstract_Base_Values : CORBA.Repository_Root.RepositoryIdSeq; Is_Truncatable : CORBA.Boolean; Base_Value : CORBA.RepositoryId; end record; -- Repository Ids DefinitionKind_Repository_Id : constant Standard.String := "IDL:omg.org/CORBA/DefinitionKind:2.3"; VersionSpec_Repository_Id : constant Standard.String := "IDL:omg.org/CORBA/VersionSpec:1.0"; InterfaceDefSeq_Repository_Id : constant Standard.String := "IDL:omg.org/CORBA/InterfaceDefSeq:1.0"; ValueDefSeq_Repository_Id : constant Standard.String := "IDL:omg.org/CORBA/ValueDefSeq:1.0"; AbstractInterfaceDefSeq_Repository_Id : constant Standard.String := "IDL:omg.org/CORBA/AbstractInterfaceDefSeq:1.0"; LocalInterfaceDefSeq_Repository_Id : constant Standard.String := "IDL:omg.org/CORBA/LocalInterfaceDefSeq:1.0"; ExtInterfaceDefSeq_Repository_Id : constant Standard.String := "IDL:omg.org/CORBA/ExtInterfaceDefSeq:1.0"; ExtValueDefSeq_Repository_Id : constant Standard.String := "IDL:omg.org/CORBA/ExtValueDefSeq:1.0"; ExtAbstractInterfaceDefSeq_Repository_Id : constant Standard.String := "IDL:omg.org/CORBA/ExtAbstractInterfaceDefSeq:1.0"; ExtLocalInterfaceDefSeq_Repository_Id : constant Standard.String := "IDL:omg.org/CORBA/ExtLocalInterfaceDefSeq:1.0"; ContainedSeq_Repository_Id : constant Standard.String := "IDL:omg.org/CORBA/ContainedSeq:1.0"; StructMember_Repository_Id : constant Standard.String := "IDL:omg.org/CORBA/StructMember:1.0"; StructMemberSeq_Repository_Id : constant Standard.String := "IDL:omg.org/CORBA/StructMemberSeq:1.0"; Initializer_Repository_Id : constant Standard.String := "IDL:omg.org/CORBA/Initializer:2.3"; InitializerSeq_Repository_Id : constant Standard.String := "IDL:omg.org/CORBA/InitializerSeq:1.0"; UnionMember_Repository_Id : constant Standard.String := "IDL:omg.org/CORBA/UnionMember:1.0"; ExceptionDescription_Repository_Id : constant Standard.String := "IDL:omg.org/CORBA/ExceptionDescription:1.0"; ExcDescriptionSeq_Repository_Id : constant Standard.String := "IDL:omg.org/CORBA/ExcDescriptionSeq:1.0"; ExtInitializer_Repository_Id : constant Standard.String := "IDL:omg.org/CORBA/ExtInitializer:1.0"; ExtInitializerSeq_Repository_Id : constant Standard.String := "IDL:omg.org/CORBA/ExtInitializerSeq:1.0"; UnionMemberSeq_Repository_Id : constant Standard.String := "IDL:omg.org/CORBA/UnionMemberSeq:1.0"; EnumMemberSeq_Repository_Id : constant Standard.String := "IDL:omg.org/CORBA/EnumMemberSeq:1.0"; PrimitiveKind_Repository_Id : constant Standard.String := "IDL:omg.org/CORBA/PrimitiveKind:2.3"; ModuleDescription_Repository_Id : constant Standard.String := "IDL:omg.org/CORBA/ModuleDescription:1.0"; ConstantDescription_Repository_Id : constant Standard.String := "IDL:omg.org/CORBA/ConstantDescription:1.0"; TypeDescription_Repository_Id : constant Standard.String := "IDL:omg.org/CORBA/TypeDescription:1.0"; AttributeMode_Repository_Id : constant Standard.String := "IDL:omg.org/CORBA/AttributeMode:1.0"; AttributeDescription_Repository_Id : constant Standard.String := "IDL:omg.org/CORBA/AttributeDescription:1.0"; ExtAttributeDescription_Repository_Id : constant Standard.String := "IDL:omg.org/CORBA/ExtAttributeDescription:1.0"; OperationMode_Repository_Id : constant Standard.String := "IDL:omg.org/CORBA/OperationMode:1.0"; ParameterMode_Repository_Id : constant Standard.String := "IDL:omg.org/CORBA/ParameterMode:1.0"; ParameterDescription_Repository_Id : constant Standard.String := "IDL:omg.org/CORBA/ParameterDescription:1.0"; ParDescriptionSeq_Repository_Id : constant Standard.String := "IDL:omg.org/CORBA/ParDescriptionSeq:1.0"; ContextIdentifier_Repository_Id : constant Standard.String := "IDL:omg.org/CORBA/ContextIdentifier:1.0"; ContextIdSeq_Repository_Id : constant Standard.String := "IDL:omg.org/CORBA/ContextIdSeq:1.0"; ExceptionDefSeq_Repository_Id : constant Standard.String := "IDL:omg.org/CORBA/ExceptionDefSeq:1.0"; OperationDescription_Repository_Id : constant Standard.String := "IDL:omg.org/CORBA/OperationDescription:1.0"; RepositoryIdSeq_Repository_Id : constant Standard.String := "IDL:omg.org/CORBA/RepositoryIdSeq:1.0"; OpDescriptionSeq_Repository_Id : constant Standard.String := "IDL:omg.org/CORBA/OpDescriptionSeq:1.0"; AttrDescriptionSeq_Repository_Id : constant Standard.String := "IDL:omg.org/CORBA/AttrDescriptionSeq:1.0"; ExtAttrDescriptionSeq_Repository_Id : constant Standard.String := "IDL:omg.org/CORBA/ExtAttrDescriptionSeq:1.0"; InterfaceDescription_Repository_Id : constant Standard.String := "IDL:omg.org/CORBA/InterfaceDescription:2.3"; Visibility_Repository_Id : constant Standard.String := "IDL:omg.org/CORBA/Visibility:1.0"; ValueMember_Repository_Id : constant Standard.String := "IDL:omg.org/CORBA/ValueMember:2.3"; ValueMemberSeq_Repository_Id : constant Standard.String := "IDL:omg.org/CORBA/ValueMemberSeq:1.0"; ValueDescription_Repository_Id : constant Standard.String := "IDL:omg.org/CORBA/ValueDescription:2.3"; end CORBA.Repository_Root; polyorb-2.8~20110207.orig/src/corba/polyorb-corba_p-server_tools.adb0000644000175000017500000001517711750740340024557 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . C O R B A _ P . S E R V E R _ T O O L S -- -- -- -- B o d y -- -- -- -- Copyright (C) 2001-2009, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- Helper functions for CORBA servers. Note that using this unit implies using -- the Portable Object Adapter. with CORBA.ORB; with CORBA.Policy; with PortableServer.POA.Helper; with PortableServer.POAManager; with PolyORB.Log; with PolyORB.Tasking.Threads; package body PolyORB.CORBA_P.Server_Tools is use PolyORB.Log; package L is new PolyORB.Log.Facility_Log ("polyorb.corba_p.server_tools"); procedure O (Message : String; Level : Log_Level := Debug) renames L.Output; function C (Level : Log_Level := Debug) return Boolean renames L.Enabled; Root_POA : PortableServer.POA.Local_Ref; --------------------- -- Activate_Server -- --------------------- procedure Activate_Server is begin PortableServer.POAManager.Activate (PortableServer.POA.Get_The_POAManager (Get_Root_POA)); if Initiate_Server_Hook /= null then Initiate_Server_Hook.all; end if; end Activate_Server; ------------------ -- Get_Root_POA -- ------------------ function Get_Root_POA return PortableServer.POA.Local_Ref is begin if PortableServer.POA.Is_Nil (Root_POA) then Root_POA := PortableServer.POA.Helper.To_Local_Ref (CORBA.ORB.Resolve_Initial_References (CORBA.ORB.To_CORBA_String ("RootPOA"))); end if; return Root_POA; end Get_Root_POA; --------------------- -- Initiate_Server -- --------------------- procedure Initiate_Server (Start_New_Task : Boolean := False) is begin Activate_Server; if Start_New_Task then PolyORB.Tasking.Threads.Create_Task (CORBA.ORB.Run'Access); else CORBA.ORB.Run; end if; end Initiate_Server; ---------------------- -- Initiate_Servant -- ---------------------- procedure Initiate_Servant (S : PortableServer.Servant; R : out CORBA.Object.Ref'Class) is begin pragma Debug (C, O ("Initiate_Servant: enter")); CORBA.Object.Set (R, CORBA.Object.Object_Of (PortableServer.POA.Servant_To_Reference (Get_Root_POA, S))); pragma Debug (C, O ("Initiate_Servant: end")); end Initiate_Servant; --------------------------------- -- Initiate_Well_Known_Service -- --------------------------------- procedure Initiate_Well_Known_Service (S : PortableServer.Servant; Name : String; R : out CORBA.Object.Ref'Class) is use CORBA.Policy.IDL_SEQUENCE_Policy; use PortableServer.POA; Policies : CORBA.Policy.PolicyList; Serv_POA : PortableServer.POA.Local_Ref; begin Append (Policies, CORBA.Policy.Ref (Create_Request_Processing_Policy (PortableServer.USE_DEFAULT_SERVANT))); Append (Policies, CORBA.Policy.Ref (Create_Servant_Retention_Policy (PortableServer.NON_RETAIN))); Append (Policies, CORBA.Policy.Ref (Create_Id_Assignment_Policy (PortableServer.USER_ID))); Append (Policies, CORBA.Policy.Ref (Create_Id_Uniqueness_Policy (PortableServer.MULTIPLE_ID))); Append (Policies, CORBA.Policy.Ref (Create_Implicit_Activation_Policy (PortableServer.NO_IMPLICIT_ACTIVATION))); Append (Policies, CORBA.Policy.Ref (Create_Lifespan_Policy (PortableServer.PERSISTENT))); Serv_POA := PortableServer.POA.Helper.To_Local_Ref (PortableServer.POA.Create_POA (Get_Root_POA, CORBA.To_CORBA_String (Name), PortableServer.POA.Get_The_POAManager (Get_Root_POA), Policies)); PortableServer.POA.Set_Servant (Serv_POA, S); CORBA.Object.Set (R, CORBA.Object.Object_Of ( PortableServer.POA.Create_Reference_With_Id (Serv_POA, PortableServer.String_To_ObjectId ("O"), CORBA.To_CORBA_String (PortableServer.Internals.Get_Type_Id (S))))); end Initiate_Well_Known_Service; -------------------------- -- Reference_To_Servant -- -------------------------- procedure Reference_To_Servant (R : CORBA.Object.Ref'Class; S : out PortableServer.Servant) is begin S := PortableServer.POA.Reference_To_Servant (Get_Root_POA, CORBA.Object.Ref (R)); end Reference_To_Servant; -------------------------- -- Servant_To_Reference -- -------------------------- procedure Servant_To_Reference (S : PortableServer.Servant; R : out CORBA.Object.Ref'Class) renames Initiate_Servant; end PolyORB.CORBA_P.Server_Tools; polyorb-2.8~20110207.orig/src/corba/corba-helper.ads0000644000175000017500000000654011750740337021326 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- C O R B A . H E L P E R -- -- -- -- S p e c -- -- -- -- Copyright (C) 2002-2008, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the CORBA Specification, and adapted -- -- for use with PolyORB. The copyright notice above, and the license -- -- provisions that follow apply solely to the contents neither explicitly -- -- nor implicitly specified by the CORBA Specification defined by the OMG. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ package CORBA.Helper is function TC_RepositoryId return CORBA.TypeCode.Object; function From_Any (Item : CORBA.Any) return CORBA.RepositoryId; function To_Any (Item : CORBA.RepositoryId) return CORBA.Any; function TC_Identifier return CORBA.TypeCode.Object; function From_Any (Item : CORBA.Any) return CORBA.Identifier; function To_Any (Item : CORBA.Identifier) return CORBA.Any; function TC_ScopedName return CORBA.TypeCode.Object; function From_Any (Item : CORBA.Any) return CORBA.ScopedName; function To_Any (Item : CORBA.ScopedName) return CORBA.Any; function TC_Visibility return CORBA.TypeCode.Object; function From_Any (Item : CORBA.Any) return CORBA.Visibility; function To_Any (Item : CORBA.Visibility) return CORBA.Any; function TC_PolicyType return CORBA.TypeCode.Object; function From_Any (Item : CORBA.Any) return CORBA.PolicyType; function To_Any (Item : CORBA.PolicyType) return CORBA.Any; end CORBA.Helper; polyorb-2.8~20110207.orig/src/corba/corba-domainmanager.ads0000644000175000017500000000725511750740337022655 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- C O R B A . D O M A I N M A N A G E R -- -- -- -- S p e c -- -- -- -- Copyright (C) 2005-2010, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the CORBA Specification, and adapted -- -- for use with PolyORB. The copyright notice above, and the license -- -- provisions that follow apply solely to the contents neither explicitly -- -- nor implicitly specified by the CORBA Specification defined by the OMG. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ pragma Ada_2005; with CORBA.Object; with CORBA.Policy; with CORBA.Sequences.Unbounded; package CORBA.DomainManager is type Ref is new CORBA.Object.Ref with null record; function Get_Domain_Policy (Self : Ref; Policy_Type : CORBA.PolicyType) return CORBA.Policy.Ref; function Is_A (Self : Ref; Logical_Type_Id : Standard.String) return CORBA.Boolean; -- Implementation note: this Sequence type should be defined in -- package CORBA. Yet, this would create circular dependencies -- between CORBA and CORBA.Sequences. package IDL_SEQUENCE_DomainManager is new CORBA.Sequences.Unbounded (Ref); subtype DomainManagersList is IDL_SEQUENCE_DomainManager.Sequence; -- Implementation Note: the IDL-to-Ada mapping defines the -- DomainManagersList type as: -- type DomainManagersList is -- new IDL_SEQUENCE_CORBA_DomainManager.Sequence; -- -- This adds new primitives to Ref that requires overriding for -- any derivation of Ref. We define DomainManagersList as a -- subtype to avoid this behavior. Repository_Id : constant Standard.String := "IDL:omg.org/CORBA/DomainManager:1.0"; private function Is_A (Logical_Type_Id : Standard.String) return CORBA.Boolean; end CORBA.DomainManager; polyorb-2.8~20110207.orig/src/corba/portableserver-servantactivator-impl.adb0000644000175000017500000000740511750740340026330 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- PORTABLESERVER.SERVANTACTIVATOR.IMPL -- -- -- -- B o d y -- -- -- -- Copyright (C) 2005-2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ package body PortableServer.ServantActivator.Impl is ----------------- -- Etherealize -- ----------------- procedure Etherealize (Self : access Object; Oid : PortableServer.ObjectId; Adapter : PortableServer.POA_Forward.Ref; Serv : PortableServer.Servant; Cleanup_In_Progress : CORBA.Boolean; Remaining_Activations : CORBA.Boolean) is pragma Unreferenced (Self); pragma Unreferenced (Oid); pragma Unreferenced (Adapter); pragma Unreferenced (Serv); pragma Unreferenced (Cleanup_In_Progress); pragma Unreferenced (Remaining_Activations); begin null; end Etherealize; --------------- -- Incarnate -- --------------- function Incarnate (Self : access Object; Oid : PortableServer.ObjectId; Adapter : PortableServer.POA_Forward.Ref) return PortableServer.Servant is pragma Unreferenced (Self); pragma Unreferenced (Oid); pragma Unreferenced (Adapter); begin return null; end Incarnate; ---------- -- Is_A -- ---------- function Is_A (Self : not null access Object; Logical_Type_Id : Standard.String) return Boolean is pragma Unreferenced (Self); begin return CORBA.Is_Equivalent (Logical_Type_Id, PortableServer.ServantActivator.Repository_Id) or else CORBA.Is_Equivalent (Logical_Type_Id, PortableServer.ServantManager.Repository_Id) or else CORBA.Is_Equivalent (Logical_Type_Id, "IDL:omg.org/CORBA/Object:1.0"); end Is_A; end PortableServer.ServantActivator.Impl; polyorb-2.8~20110207.orig/src/corba/polyorb-corba_p-poa_config.adb0000644000175000017500000003071311750740340024126 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . C O R B A _ P . P O A _ C O N F I G -- -- -- -- B o d y -- -- -- -- Copyright (C) 2003-2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with PortableServer.IdAssignmentPolicy; with PortableServer.IdUniquenessPolicy; with PortableServer.ImplicitActivationPolicy; with PortableServer.LifespanPolicy; with PortableServer.RequestProcessingPolicy; with PortableServer.ServantRetentionPolicy; with PortableServer.ThreadPolicy; with PolyORB.POA_Policies.Id_Assignment_Policy.System; with PolyORB.POA_Policies.Id_Assignment_Policy.User; with PolyORB.POA_Policies.Id_Uniqueness_Policy.Multiple; with PolyORB.POA_Policies.Id_Uniqueness_Policy.Unique; with PolyORB.POA_Policies.Implicit_Activation_Policy.Activation; with PolyORB.POA_Policies.Implicit_Activation_Policy.No_Activation; with PolyORB.POA_Policies.Lifespan_Policy.Persistent; with PolyORB.POA_Policies.Lifespan_Policy.Transient; with PolyORB.POA_Policies.Request_Processing_Policy.Active_Object_Map_Only; with PolyORB.POA_Policies.Request_Processing_Policy.Use_Default_Servant; with PolyORB.POA_Policies.Request_Processing_Policy.Use_Servant_Manager; with PolyORB.POA_Policies.Servant_Retention_Policy.Non_Retain; with PolyORB.POA_Policies.Servant_Retention_Policy.Retain; with PolyORB.POA_Policies.Thread_Policy.ORB_Ctrl; with PolyORB.POA_Policies.Thread_Policy.Single_Thread; with PolyORB.POA_Policies.Thread_Policy.Main_Thread; with PolyORB.Utils.Chained_Lists; package body PolyORB.CORBA_P.POA_Config is use CORBA; use PortableServer; use PortableServer.IdAssignmentPolicy; use PortableServer.IdUniquenessPolicy; use PortableServer.ImplicitActivationPolicy; use PortableServer.LifespanPolicy; use PortableServer.RequestProcessingPolicy; use PortableServer.ServantRetentionPolicy; use PortableServer.ThreadPolicy; use PolyORB.POA_Policies; use PolyORB.POA_Policies.Id_Assignment_Policy.System; use PolyORB.POA_Policies.Id_Assignment_Policy.User; use PolyORB.POA_Policies.Id_Uniqueness_Policy.Multiple; use PolyORB.POA_Policies.Id_Uniqueness_Policy.Unique; use PolyORB.POA_Policies.Implicit_Activation_Policy.Activation; use PolyORB.POA_Policies.Implicit_Activation_Policy.No_Activation; use PolyORB.POA_Policies.Lifespan_Policy.Persistent; use PolyORB.POA_Policies.Lifespan_Policy.Transient; use PolyORB.POA_Policies.Request_Processing_Policy.Active_Object_Map_Only; use PolyORB.POA_Policies.Request_Processing_Policy.Use_Default_Servant; use PolyORB.POA_Policies.Request_Processing_Policy.Use_Servant_Manager; package RPP renames PolyORB.POA_Policies.Request_Processing_Policy; use PolyORB.POA_Policies.Servant_Retention_Policy.Non_Retain; use PolyORB.POA_Policies.Servant_Retention_Policy.Retain; use PolyORB.POA_Policies.Thread_Policy.ORB_Ctrl; use PolyORB.POA_Policies.Thread_Policy.Single_Thread; use PolyORB.POA_Policies.Thread_Policy.Main_Thread; type Allocator_Record is record Policy : CORBA.PolicyType; Allocator : Policy_Type_Allocator; end record; package Allocator_List is new PolyORB.Utils.Chained_Lists (Allocator_Record); use Allocator_List; Callbacks : Allocator_List.List; ------------------------ -- Convert_PolicyList -- ------------------------ function Convert_PolicyList (List : CORBA.Policy.PolicyList) return PolyORB.POA_Policies.PolicyList is package PL renames PolyORB.POA_Policies.Policy_Lists; package ISP renames CORBA.Policy.IDL_SEQUENCE_Policy; CORBA_Policy_Array : constant ISP.Element_Array := ISP.To_Element_Array (ISP.Sequence (List)); Result : PolicyList; Policy : CORBA.PolicyType; begin for J in CORBA_Policy_Array'Range loop Policy := CORBA.Policy.Get_Policy_Type (CORBA_Policy_Array (J)); case Policy is when THREAD_POLICY_ID => declare PolicyValue : constant ThreadPolicyValue := Get_Value (PortableServer.ThreadPolicy.To_Ref (CORBA_Policy_Array (J))); begin case PolicyValue is when ORB_CTRL_MODEL => PL.Append (Result, Policy_Access (Thread_Policy.ORB_Ctrl.Create)); when SINGLE_THREAD_MODEL => PL.Append (Result, Policy_Access (Thread_Policy.Single_Thread.Create)); when MAIN_THREAD_MODEL => PL.Append (Result, Policy_Access (Thread_Policy.Main_Thread.Create)); end case; end; when LIFESPAN_POLICY_ID => declare PolicyValue : constant LifespanPolicyValue := Get_Value (PortableServer.LifespanPolicy.To_Ref (CORBA_Policy_Array (J))); begin case PolicyValue is when PortableServer.TRANSIENT => PL.Append (Result, Policy_Access (Lifespan_Policy.Transient.Create)); when PERSISTENT => PL.Append (Result, Policy_Access (Lifespan_Policy.Persistent.Create)); end case; end; when ID_UNIQUENESS_POLICY_ID => declare PolicyValue : constant IdUniquenessPolicyValue := Get_Value (PortableServer.IdUniquenessPolicy.To_Ref (CORBA_Policy_Array (J))); begin case PolicyValue is when UNIQUE_ID => PL.Append (Result, Policy_Access (Id_Uniqueness_Policy.Unique.Create)); when MULTIPLE_ID => PL.Append (Result, Policy_Access (Id_Uniqueness_Policy.Multiple.Create)); end case; end; when ID_ASSIGNMENT_POLICY_ID => declare PolicyValue : constant IdAssignmentPolicyValue := Get_Value (PortableServer.IdAssignmentPolicy.To_Ref (CORBA_Policy_Array (J))); begin case PolicyValue is when USER_ID => PL.Append (Result, Policy_Access (Id_Assignment_Policy.User.Create)); when SYSTEM_ID => PL.Append (Result, Policy_Access (Id_Assignment_Policy.System.Create)); end case; end; when IMPLICIT_ACTIVATION_POLICY_ID => declare PolicyValue : constant ImplicitActivationPolicyValue := Get_Value (PortableServer.ImplicitActivationPolicy.To_Ref (CORBA_Policy_Array (J))); begin case PolicyValue is when IMPLICIT_ACTIVATION => PL.Append (Result, Policy_Access (Implicit_Activation_Policy.Activation.Create)); when NO_IMPLICIT_ACTIVATION => PL.Append (Result, Policy_Access (Implicit_Activation_Policy.No_Activation.Create)); end case; end; when SERVANT_RETENTION_POLICY_ID => declare PolicyValue : constant ServantRetentionPolicyValue := Get_Value (PortableServer.ServantRetentionPolicy.To_Ref (CORBA_Policy_Array (J))); begin case PolicyValue is when RETAIN => PL.Append (Result, Policy_Access (Servant_Retention_Policy.Retain.Create)); when NON_RETAIN => PL.Append (Result, Policy_Access (Servant_Retention_Policy.Non_Retain.Create)); end case; end; when REQUEST_PROCESSING_POLICY_ID => declare PolicyValue : constant RequestProcessingPolicyValue := Get_Value (PortableServer.RequestProcessingPolicy.To_Ref (CORBA_Policy_Array (J))); begin case PolicyValue is when USE_ACTIVE_OBJECT_MAP_ONLY => PL.Append (Result, Policy_Access (RPP.Active_Object_Map_Only.Create)); when USE_DEFAULT_SERVANT => PL.Append (Result, Policy_Access (RPP.Use_Default_Servant.Create)); when USE_SERVANT_MANAGER => PL.Append (Result, Policy_Access (RPP.Use_Servant_Manager.Create)); end case; end; when others => null; end case; -- Iterate through allocators' list declare Iter : Iterator := First (Callbacks); begin while not Last (Iter) loop declare Info : constant Allocator_Record := Value (Iter).all; begin if Policy = Info.Policy then PL.Append (Result, Info.Allocator.all (CORBA_Policy_Array (J))); exit; end if; end; Next (Iter); end loop; end; end loop; return Result; end Convert_PolicyList; -------------- -- Register -- -------------- procedure Register (Policy : CORBA.PolicyType; Allocator : Policy_Type_Allocator) is Elt : constant Allocator_Record := (Policy, Allocator); begin Append (Callbacks, Elt); end Register; end PolyORB.CORBA_P.POA_Config; polyorb-2.8~20110207.orig/src/corba/corba-contextlist.adb0000644000175000017500000000706111750740337022405 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- C O R B A . C O N T E X T L I S T -- -- -- -- B o d y -- -- -- -- Copyright (C) 2001-2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ package body CORBA.ContextList is -------------- -- Finalize -- -------------- procedure Finalize (Obj : in out Object) is begin Context_Sequence.Delete (Obj.List, 1, Context_Sequence.Length (Obj.List)); end Finalize; --------------- -- Get_Count -- --------------- function Get_Count (Self : Ref) return CORBA.Unsigned_Long is begin return CORBA.Unsigned_Long (Context_Sequence.Length (Object_Ptr (Object_Of (Self)).List)); end Get_Count; --------- -- Add -- --------- procedure Add (Self : Ref; Exc : CORBA.String) is begin Context_Sequence.Append (Object_Ptr (Object_Of (Self)).List, Exc); end Add; ---------- -- Item -- ---------- function Item (Self : Ref; Index : CORBA.Unsigned_Long) return CORBA.String is begin return Context_Sequence.Get_Element (Object_Ptr (Object_Of (Self)).List, Positive (Index)); end Item; ------------ -- Remove -- ------------ procedure Remove (Self : Ref; Index : CORBA.Unsigned_Long) is begin Context_Sequence.Delete (Object_Ptr (Object_Of (Self)).List, Positive (Index), 1); end Remove; ------------------- -- Create_Object -- ------------------- function Create_Object return Object_Ptr is Actual_Ref : constant CORBA.ContextList.Object_Ptr := new Object; begin Actual_Ref.List := Context_Sequence.Null_Sequence; return Actual_Ref; end Create_Object; end CORBA.ContextList; polyorb-2.8~20110207.orig/src/corba/polyorb-corba_p-orb_init.adb0000644000175000017500000000764211750740340023634 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . C O R B A _ P . O R B _ I N I T -- -- -- -- B o d y -- -- -- -- Copyright (C) 2004 Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by ACT Europe. -- -- (email: sales@act-europe.fr) -- -- -- ------------------------------------------------------------------------------ with PolyORB.Utils.Chained_Lists; with PolyORB.Utils.Strings; package body PolyORB.CORBA_P.ORB_Init is use PolyORB.Utils; use PolyORB.Utils.Strings; type ORB_Init_Suffix_Record is record Suffix : String_Ptr; ORB_Init_Suffix : ORB_Init_Suffix_Type; end record; package ORB_Init_Suffix_Record_List is new PolyORB.Utils.Chained_Lists (ORB_Init_Suffix_Record); use ORB_Init_Suffix_Record_List; Callbacks : ORB_Init_Suffix_Record_List.List; -------------- -- Register -- -------------- procedure Register (Suffix : String; ORB_Init_Suffix : ORB_Init_Suffix_Type) is begin Append (Callbacks, ORB_Init_Suffix_Record'(Suffix => +Suffix, ORB_Init_Suffix => ORB_Init_Suffix)); end Register; ---------------- -- Initialize -- ---------------- function Initialize (Suffix : String; Value : String) return Boolean is It : Iterator := First (Callbacks); begin while not Last (It) loop if Suffix = ORB_Init_Suffix_Record_List.Value (It).Suffix.all then return ORB_Init_Suffix_Record_List.Value (It).ORB_Init_Suffix (Value); end if; Next (It); end loop; return False; end Initialize; function Initialize (Value : String) return Boolean is It : Iterator := First (Callbacks); begin while not Last (It) loop declare Suffix : constant String := ORB_Init_Suffix_Record_List.Value (It).Suffix.all; begin if Has_Prefix (Value, Suffix) then return ORB_Init_Suffix_Record_List.Value (It).ORB_Init_Suffix (Value (Value'First + Suffix'Length .. Value'Last)); end if; end; Next (It); end loop; return False; end Initialize; end PolyORB.CORBA_P.ORB_Init; polyorb-2.8~20110207.orig/src/corba/corba-nvlist.ads0000644000175000017500000001002511750740337021357 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- C O R B A . N V L I S T -- -- -- -- S p e c -- -- -- -- Copyright (C) 2001-2008, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the CORBA Specification, and adapted -- -- for use with PolyORB. The copyright notice above, and the license -- -- provisions that follow apply solely to the contents neither explicitly -- -- nor implicitly specified by the CORBA Specification defined by the OMG. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with CORBA.AbstractBase; with PolyORB.Any.NVList; package CORBA.NVList is type Ref is new CORBA.AbstractBase.Ref with private; procedure Add_Item (Self : Ref; Item_Name : Identifier; Item : CORBA.Any; Item_Flags : Flags); -- Create a NamedValue and add it to this NVList procedure Add_Item (Self : Ref; Item : CORBA.NamedValue); -- Add a NamedValue to this NVList function Get_Count (Self : Ref) return CORBA.Long; -- Return the number of items in this NVList procedure Free (Self : Ref); procedure Free_Memory (Self : Ref) renames Free; -- Implementation Note: As per the IDL-to-Ada mapping, Free and -- Free_Memory are no-ops. package Internals is -- Internal implementation subprograms. These shall not be used outside -- of PolyORB. function Item (Self : Ref; Index : CORBA.Long) return CORBA.NamedValue; function To_PolyORB_Ref (Self : Ref) return PolyORB.Any.NVList.Ref; function To_CORBA_Ref (Self : PolyORB.Any.NVList.Ref) return Ref; pragma Inline (To_PolyORB_Ref); pragma Inline (To_CORBA_Ref); procedure Clone_Out_Args (Self : Ref); -- For any NV in Self that has mode out or in out, replace the Argument -- component with a by-value copy of the original one (thus ensuring -- that the value remains valid even after exiting the current scope). end Internals; private type Ref is new CORBA.AbstractBase.Ref with null record; procedure Initialize (Self : in out Ref); pragma Inline (Add_Item); pragma Inline (Get_Count); pragma Inline (Free); end CORBA.NVList; polyorb-2.8~20110207.orig/src/corba/corba-domainmanager-helper.ads0000644000175000017500000000611511750740337024124 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- C O R B A . D O M A I N M A N A G E R . H E L P E R -- -- -- -- S p e c -- -- -- -- Copyright (C) 2005-2008, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the CORBA Specification, and adapted -- -- for use with PolyORB. The copyright notice above, and the license -- -- provisions that follow apply solely to the contents neither explicitly -- -- nor implicitly specified by the CORBA Specification defined by the OMG. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with CORBA.Object; package CORBA.DomainManager.Helper is function Unchecked_To_Ref (The_Ref : Object.Ref'Class) return Ref; function To_Ref (The_Ref : Object.Ref'Class) return Ref; function TC_DomainManager return TypeCode.Object; function From_Any (Item : Any) return Ref; function To_Any (Item : Ref) return Any; -- DomainManager sequence function TC_IDL_SEQUENCE_DomainManager return TypeCode.Object; function From_Any (Item : Any) return IDL_SEQUENCE_DomainManager.Sequence; function To_Any (Item : IDL_SEQUENCE_DomainManager.Sequence) return Any; function TC_DomainManagersList return TypeCode.Object; end CORBA.DomainManager.Helper; polyorb-2.8~20110207.orig/src/corba/portableserver-lifespanpolicy.adb0000644000175000017500000001401211750740340025003 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O R T A B L E S E R V E R . L I F E S P A N P O L I C Y -- -- -- -- B o d y -- -- -- -- Copyright (C) 2003-2007, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with PolyORB.CORBA_P.Policy; with PolyORB.CORBA_P.Policy_Management; with PortableServer.Helper; with PolyORB.Initialization; with PolyORB.Smart_Pointers; with PolyORB.Utils.Strings; package body PortableServer.LifespanPolicy is use CORBA; use CORBA.Policy; use CORBA.TypeCode; use PortableServer.Helper; use PolyORB.CORBA_P.Policy; use PolyORB.CORBA_P.Policy_Management; function Create_LifespanPolicy (The_Type : CORBA.PolicyType; Value : CORBA.Any) return CORBA.Policy.Ref; ------------ -- To_Ref -- ------------ function To_Ref (The_Ref : CORBA.Object.Ref'Class) return Ref is begin if The_Ref not in CORBA.Policy.Ref'Class or else Get_Policy_Type (CORBA.Policy.Ref (The_Ref)) /= LIFESPAN_POLICY_ID then CORBA.Raise_Bad_Param (CORBA.Default_Sys_Member); end if; declare Entity : constant PolyORB.Smart_Pointers.Entity_Ptr := new Policy_Object_Type; Result : Ref; begin Set_Policy_Type (Policy_Object_Type (Entity.all), LIFESPAN_POLICY_ID); Set_Policy_Value (Policy_Object_Type (Entity.all), Get_Policy_Value (Policy_Object_Type (Entity_Of (CORBA.Policy.Ref (The_Ref)).all))); CORBA.Policy.Set (CORBA.Policy.Ref (Result), Entity); return Result; end; end To_Ref; --------------- -- Get_Value -- --------------- function Get_Value (Self : Ref) return PortableServer.LifespanPolicyValue is begin return From_Any (Get_Policy_Value (Policy_Object_Type (Entity_Of (CORBA.Policy.Ref (Self)).all))); end Get_Value; --------------------------- -- Create_LifespanPolicy -- --------------------------- function Create_LifespanPolicy (The_Type : CORBA.PolicyType; Value : CORBA.Any) return CORBA.Policy.Ref is begin pragma Assert (The_Type = LIFESPAN_POLICY_ID); if Get_Type (Value) /= TC_LifespanPolicyValue then Raise_PolicyError ((Reason => BAD_POLICY_TYPE)); end if; declare Position : constant CORBA.Unsigned_Long := CORBA.From_Any (CORBA.Internals.Get_Aggregate_Element (Value, CORBA.TC_Unsigned_Long, CORBA.Unsigned_Long (0))); begin if Position > LifespanPolicyValue'Pos (LifespanPolicyValue'Last) then Raise_PolicyError ((Reason => BAD_POLICY_VALUE)); end if; end; declare Result : CORBA.Policy.Ref; Entity : constant PolyORB.Smart_Pointers.Entity_Ptr := new Policy_Object_Type; begin Set_Policy_Type (Policy_Object_Type (Entity.all), The_Type); Set_Policy_Value (Policy_Object_Type (Entity.all), Value); CORBA.Policy.Set (Result, Entity); return Result; end; end Create_LifespanPolicy; ----------------------------- -- Deferred_Initialization -- ----------------------------- procedure Deferred_Initialization; procedure Deferred_Initialization is begin Register (The_Type => LIFESPAN_POLICY_ID, POA_Level => True, Factory => Create_LifespanPolicy'Access, System_Default => Create_LifespanPolicy (LIFESPAN_POLICY_ID, To_Any (TRANSIENT))); end Deferred_Initialization; use PolyORB.Initialization; use PolyORB.Initialization.String_Lists; use PolyORB.Utils.Strings; begin Register_Module (Module_Info' (Name => +"portableserver.lifespanpolicy", Conflicts => Empty, Depends => +"PortableServer.Helper", Provides => Empty, Implicit => False, Init => Deferred_Initialization'Access, Shutdown => null)); end PortableServer.LifespanPolicy; polyorb-2.8~20110207.orig/src/corba/corba-idl_sequences-helper.adb0000644000175000017500000007777611750740337024151 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- C O R B A . I D L _ S E Q U E N C E S . H E L P E R -- -- -- -- B o d y -- -- -- -- Copyright (C) 2005-2007, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with PolyORB.Initialization; with PolyORB.Sequences.Unbounded.CORBA_Helper; pragma Elaborate_All (PolyORB.Sequences.Unbounded.CORBA_Helper); with PolyORB.Utils.Strings; package body CORBA.IDL_SEQUENCES.Helper is procedure Deferred_Initialization; package IDL_SEQUENCE_Any_Helper is new IDL_SEQUENCE_Any.CORBA_Helper (Element_To_Any => CORBA.To_Any, Element_From_Any => CORBA.From_Any, Element_Wrap => CORBA.Wrap); package IDL_SEQUENCE_Boolean_Helper is new IDL_SEQUENCE_Boolean.CORBA_Helper (Element_To_Any => CORBA.To_Any, Element_From_Any => CORBA.From_Any, Element_Wrap => CORBA.Wrap); package IDL_SEQUENCE_Char_Helper is new IDL_SEQUENCE_Char.CORBA_Helper (Element_To_Any => CORBA.To_Any, Element_From_Any => CORBA.From_Any, Element_Wrap => CORBA.Wrap); package IDL_SEQUENCE_Double_Helper is new IDL_SEQUENCE_Double.CORBA_Helper (Element_To_Any => CORBA.To_Any, Element_From_Any => CORBA.From_Any, Element_Wrap => CORBA.Wrap); package IDL_SEQUENCE_Float_Helper is new IDL_SEQUENCE_Float.CORBA_Helper (Element_To_Any => CORBA.To_Any, Element_From_Any => CORBA.From_Any, Element_Wrap => CORBA.Wrap); package IDL_SEQUENCE_Long_Double_Helper is new IDL_SEQUENCE_Long_Double.CORBA_Helper (Element_To_Any => CORBA.To_Any, Element_From_Any => CORBA.From_Any, Element_Wrap => CORBA.Wrap); package IDL_SEQUENCE_Long_Helper is new IDL_SEQUENCE_Long.CORBA_Helper (Element_To_Any => CORBA.To_Any, Element_From_Any => CORBA.From_Any, Element_Wrap => CORBA.Wrap); package IDL_SEQUENCE_Long_Long_Helper is new IDL_SEQUENCE_Long_Long.CORBA_Helper (Element_To_Any => CORBA.To_Any, Element_From_Any => CORBA.From_Any, Element_Wrap => CORBA.Wrap); package IDL_SEQUENCE_Octet_Helper is new IDL_SEQUENCE_Octet.CORBA_Helper (Element_To_Any => CORBA.To_Any, Element_From_Any => CORBA.From_Any, Element_Wrap => CORBA.Wrap); package IDL_SEQUENCE_Short_Helper is new IDL_SEQUENCE_Short.CORBA_Helper (Element_To_Any => CORBA.To_Any, Element_From_Any => CORBA.From_Any, Element_Wrap => CORBA.Wrap); package IDL_SEQUENCE_String_Helper is new IDL_SEQUENCE_String.CORBA_Helper (Element_To_Any => CORBA.To_Any, Element_From_Any => CORBA.From_Any, Element_Wrap => CORBA.Wrap); package IDL_SEQUENCE_Unsigned_Long_Helper is new IDL_SEQUENCE_Unsigned_Long.CORBA_Helper (Element_To_Any => CORBA.To_Any, Element_From_Any => CORBA.From_Any, Element_Wrap => CORBA.Wrap); package IDL_SEQUENCE_Unsigned_Long_Long_Helper is new IDL_SEQUENCE_Unsigned_Long_Long.CORBA_Helper (Element_To_Any => CORBA.To_Any, Element_From_Any => CORBA.From_Any, Element_Wrap => CORBA.Wrap); package IDL_SEQUENCE_Unsigned_Short_Helper is new IDL_SEQUENCE_Unsigned_Short.CORBA_Helper (Element_To_Any => CORBA.To_Any, Element_From_Any => CORBA.From_Any, Element_Wrap => CORBA.Wrap); package IDL_SEQUENCE_Wide_Char_Helper is new IDL_SEQUENCE_Wide_Char.CORBA_Helper (Element_To_Any => CORBA.To_Any, Element_From_Any => CORBA.From_Any, Element_Wrap => CORBA.Wrap); package IDL_SEQUENCE_Wide_String_Helper is new IDL_SEQUENCE_Wide_String.CORBA_Helper (Element_To_Any => CORBA.To_Any, Element_From_Any => CORBA.From_Any, Element_Wrap => CORBA.Wrap); ----------------------------- -- Deferred_Initialization -- ----------------------------- procedure Deferred_Initialization is begin TC_IDL_SEQUENCE_Any := CORBA.TypeCode.Internals.Build_Sequence_TC (CORBA.TC_Any, 0); CORBA.TypeCode.Internals.Disable_Reference_Counting (TC_IDL_SEQUENCE_Any); IDL_SEQUENCE_Any_Helper.Initialize (Element_TC => CORBA.TC_Any, Sequence_TC => TC_IDL_SEQUENCE_Any); declare Name : constant CORBA.String := CORBA.To_CORBA_String ("AnySeq"); Id : constant CORBA.String := CORBA.To_CORBA_String ("IDL:omg.org/CORBA/AnySeq:1.0"); begin TC_AnySeq := CORBA.TypeCode.Internals.Build_Alias_TC (Name => Name, Id => Id, Parent => TC_IDL_SEQUENCE_Any); CORBA.TypeCode.Internals.Disable_Reference_Counting (TC_AnySeq); end; TC_IDL_SEQUENCE_Boolean := CORBA.TypeCode.Internals.Build_Sequence_TC (CORBA.TC_Boolean, 0); CORBA.TypeCode.Internals.Disable_Reference_Counting (TC_IDL_SEQUENCE_Boolean); IDL_SEQUENCE_Boolean_Helper.Initialize (Element_TC => CORBA.TC_Boolean, Sequence_TC => TC_IDL_SEQUENCE_Boolean); declare Name : constant CORBA.String := CORBA.To_CORBA_String ("BooleanSeq"); Id : constant CORBA.String := CORBA.To_CORBA_String ("IDL:omg.org/CORBA/BooleanSeq:1.0"); begin TC_BooleanSeq := CORBA.TypeCode.Internals.Build_Alias_TC (Name => Name, Id => Id, Parent => TC_IDL_SEQUENCE_Boolean); CORBA.TypeCode.Internals.Disable_Reference_Counting (TC_BooleanSeq); end; TC_IDL_SEQUENCE_Char := CORBA.TypeCode.Internals.Build_Sequence_TC (CORBA.TC_Char, 0); CORBA.TypeCode.Internals.Disable_Reference_Counting (TC_IDL_SEQUENCE_Char); IDL_SEQUENCE_Char_Helper.Initialize (Element_TC => CORBA.TC_Char, Sequence_TC => TC_IDL_SEQUENCE_Char); declare Name : constant CORBA.String := CORBA.To_CORBA_String ("CharSeq"); Id : constant CORBA.String := CORBA.To_CORBA_String ("IDL:omg.org/CORBA/CharSeq:1.0"); begin TC_CharSeq := CORBA.TypeCode.Internals.Build_Alias_TC (Name => Name, Id => Id, Parent => TC_IDL_SEQUENCE_Char); CORBA.TypeCode.Internals.Disable_Reference_Counting (TC_CharSeq); end; TC_IDL_SEQUENCE_Wide_Char := CORBA.TypeCode.Internals.Build_Sequence_TC (CORBA.TC_Wchar, 0); CORBA.TypeCode.Internals.Disable_Reference_Counting (TC_IDL_SEQUENCE_Wide_Char); IDL_SEQUENCE_Wide_Char_Helper.Initialize (Element_TC => CORBA.TC_Wchar, Sequence_TC => TC_IDL_SEQUENCE_Wide_Char); declare Name : constant CORBA.String := CORBA.To_CORBA_String ("WCharSeq"); Id : constant CORBA.String := CORBA.To_CORBA_String ("IDL:omg.org/CORBA/WCharSeq:1.0"); begin TC_WCharSeq := CORBA.TypeCode.Internals.Build_Alias_TC (Name => Name, Id => Id, Parent => TC_IDL_SEQUENCE_Wide_Char); CORBA.TypeCode.Internals.Disable_Reference_Counting (TC_WCharSeq); end; TC_IDL_SEQUENCE_Octet := CORBA.TypeCode.Internals.Build_Sequence_TC (CORBA.TC_Octet, 0); CORBA.TypeCode.Internals.Disable_Reference_Counting (TC_IDL_SEQUENCE_Octet); IDL_SEQUENCE_Octet_Helper.Initialize (Element_TC => CORBA.TC_Octet, Sequence_TC => TC_IDL_SEQUENCE_Octet); declare Name : constant CORBA.String := CORBA.To_CORBA_String ("OctetSeq"); Id : constant CORBA.String := CORBA.To_CORBA_String ("IDL:omg.org/CORBA/OctetSeq:1.0"); begin TC_OctetSeq := CORBA.TypeCode.Internals.Build_Alias_TC (Name => Name, Id => Id, Parent => TC_IDL_SEQUENCE_Octet); CORBA.TypeCode.Internals.Disable_Reference_Counting (TC_OctetSeq); end; TC_IDL_SEQUENCE_Short := CORBA.TypeCode.Internals.Build_Sequence_TC (CORBA.TC_Short, 0); CORBA.TypeCode.Internals.Disable_Reference_Counting (TC_IDL_SEQUENCE_Short); IDL_SEQUENCE_Short_Helper.Initialize (Element_TC => CORBA.TC_Short, Sequence_TC => TC_IDL_SEQUENCE_Short); declare Name : constant CORBA.String := CORBA.To_CORBA_String ("ShortSeq"); Id : constant CORBA.String := CORBA.To_CORBA_String ("IDL:omg.org/CORBA/ShortSeq:1.0"); begin TC_ShortSeq := CORBA.TypeCode.Internals.Build_Alias_TC (Name => Name, Id => Id, Parent => TC_IDL_SEQUENCE_Short); CORBA.TypeCode.Internals.Disable_Reference_Counting (TC_ShortSeq); end; TC_IDL_SEQUENCE_Unsigned_Short := CORBA.TypeCode.Internals.Build_Sequence_TC (CORBA.TC_Unsigned_Short, 0); CORBA.TypeCode.Internals.Disable_Reference_Counting (TC_IDL_SEQUENCE_Unsigned_Short); IDL_SEQUENCE_Unsigned_Short_Helper.Initialize (Element_TC => CORBA.TC_Unsigned_Short, Sequence_TC => TC_IDL_SEQUENCE_Unsigned_Short); declare Name : constant CORBA.String := CORBA.To_CORBA_String ("UShortSeq"); Id : constant CORBA.String := CORBA.To_CORBA_String ("IDL:omg.org/CORBA/UShortSeq:1.0"); begin TC_UShortSeq := CORBA.TypeCode.Internals.Build_Alias_TC (Name => Name, Id => Id, Parent => TC_IDL_SEQUENCE_Unsigned_Short); CORBA.TypeCode.Internals.Disable_Reference_Counting (TC_UShortSeq); end; TC_IDL_SEQUENCE_Long := CORBA.TypeCode.Internals.Build_Sequence_TC (CORBA.TC_Long, 0); CORBA.TypeCode.Internals.Disable_Reference_Counting (TC_IDL_SEQUENCE_Long); IDL_SEQUENCE_Long_Helper.Initialize (Element_TC => CORBA.TC_Long, Sequence_TC => TC_IDL_SEQUENCE_Long); declare Name : constant CORBA.String := CORBA.To_CORBA_String ("LongSeq"); Id : constant CORBA.String := CORBA.To_CORBA_String ("IDL:omg.org/CORBA/LongSeq:1.0"); begin TC_LongSeq := CORBA.TypeCode.Internals.Build_Alias_TC (Name => Name, Id => Id, Parent => TC_IDL_SEQUENCE_Long); CORBA.TypeCode.Internals.Disable_Reference_Counting (TC_LongSeq); end; TC_IDL_SEQUENCE_Unsigned_Long := CORBA.TypeCode.Internals.Build_Sequence_TC (CORBA.TC_Unsigned_Long, 0); CORBA.TypeCode.Internals.Disable_Reference_Counting (TC_IDL_SEQUENCE_Unsigned_Long); IDL_SEQUENCE_Unsigned_Long_Helper.Initialize (Element_TC => CORBA.TC_Unsigned_Long, Sequence_TC => TC_IDL_SEQUENCE_Unsigned_Long); declare Name : constant CORBA.String := CORBA.To_CORBA_String ("ULongSeq"); Id : constant CORBA.String := CORBA.To_CORBA_String ("IDL:omg.org/CORBA/ULongSeq:1.0"); begin TC_ULongSeq := CORBA.TypeCode.Internals.Build_Alias_TC (Name => Name, Id => Id, Parent => TC_IDL_SEQUENCE_Unsigned_Long); CORBA.TypeCode.Internals.Disable_Reference_Counting (TC_ULongSeq); end; TC_IDL_SEQUENCE_Long_Long := CORBA.TypeCode.Internals.Build_Sequence_TC (CORBA.TC_Long_Long, 0); CORBA.TypeCode.Internals.Disable_Reference_Counting (TC_IDL_SEQUENCE_Long_Long); IDL_SEQUENCE_Long_Long_Helper.Initialize (Element_TC => CORBA.TC_Long_Long, Sequence_TC => TC_IDL_SEQUENCE_Long_Long); declare Name : constant CORBA.String := CORBA.To_CORBA_String ("LongLongSeq"); Id : constant CORBA.String := CORBA.To_CORBA_String ("IDL:omg.org/CORBA/LongLongSeq:1.0"); begin TC_LongLongSeq := CORBA.TypeCode.Internals.Build_Alias_TC (Name => Name, Id => Id, Parent => TC_IDL_SEQUENCE_Long_Long); CORBA.TypeCode.Internals.Disable_Reference_Counting (TC_LongLongSeq); end; TC_IDL_SEQUENCE_Unsigned_Long_Long := CORBA.TypeCode.Internals.Build_Sequence_TC (CORBA.TC_Unsigned_Long_Long, 0); CORBA.TypeCode.Internals.Disable_Reference_Counting (TC_IDL_SEQUENCE_Unsigned_Long_Long); IDL_SEQUENCE_Unsigned_Long_Long_Helper.Initialize (Element_TC => CORBA.TC_Unsigned_Long_Long, Sequence_TC => TC_IDL_SEQUENCE_Unsigned_Long_Long); declare Name : constant CORBA.String := CORBA.To_CORBA_String ("ULongLongSeq"); Id : constant CORBA.String := CORBA.To_CORBA_String ("IDL:omg.org/CORBA/ULongLongSeq:1.0"); begin TC_ULongLongSeq := CORBA.TypeCode.Internals.Build_Alias_TC (Name => Name, Id => Id, Parent => TC_IDL_SEQUENCE_Unsigned_Long_Long); CORBA.TypeCode.Internals.Disable_Reference_Counting (TC_ULongLongSeq); end; TC_IDL_SEQUENCE_Float := CORBA.TypeCode.Internals.Build_Sequence_TC (CORBA.TC_Float, 0); CORBA.TypeCode.Internals.Disable_Reference_Counting (TC_IDL_SEQUENCE_Float); IDL_SEQUENCE_Float_Helper.Initialize (Element_TC => CORBA.TC_Float, Sequence_TC => TC_IDL_SEQUENCE_Float); declare Name : constant CORBA.String := CORBA.To_CORBA_String ("FloatSeq"); Id : constant CORBA.String := CORBA.To_CORBA_String ("IDL:omg.org/CORBA/FloatSeq:1.0"); begin TC_FloatSeq := CORBA.TypeCode.Internals.Build_Alias_TC (Name => Name, Id => Id, Parent => TC_IDL_SEQUENCE_Float); CORBA.TypeCode.Internals.Disable_Reference_Counting (TC_FloatSeq); end; TC_IDL_SEQUENCE_Double := CORBA.TypeCode.Internals.Build_Sequence_TC (CORBA.TC_Double, 0); CORBA.TypeCode.Internals.Disable_Reference_Counting (TC_IDL_SEQUENCE_Double); IDL_SEQUENCE_Double_Helper.Initialize (Element_TC => CORBA.TC_Double, Sequence_TC => TC_IDL_SEQUENCE_Double); declare Name : constant CORBA.String := CORBA.To_CORBA_String ("DoubleSeq"); Id : constant CORBA.String := CORBA.To_CORBA_String ("IDL:omg.org/CORBA/DoubleSeq:1.0"); begin TC_DoubleSeq := CORBA.TypeCode.Internals.Build_Alias_TC (Name => Name, Id => Id, Parent => TC_IDL_SEQUENCE_Double); CORBA.TypeCode.Internals.Disable_Reference_Counting (TC_DoubleSeq); end; TC_IDL_SEQUENCE_Long_Double := CORBA.TypeCode.Internals.Build_Sequence_TC (CORBA.TC_Long_Double, 0); CORBA.TypeCode.Internals.Disable_Reference_Counting (TC_IDL_SEQUENCE_Long_Double); IDL_SEQUENCE_Long_Double_Helper.Initialize (Element_TC => CORBA.TC_Long_Double, Sequence_TC => TC_IDL_SEQUENCE_Long_Double); declare Name : constant CORBA.String := CORBA.To_CORBA_String ("LongDoubleSeq"); Id : constant CORBA.String := CORBA.To_CORBA_String ("IDL:omg.org/CORBA/LongDoubleSeq:1.0"); begin TC_LongDoubleSeq := CORBA.TypeCode.Internals.Build_Alias_TC (Name => Name, Id => Id, Parent => TC_IDL_SEQUENCE_Long_Double); CORBA.TypeCode.Internals.Disable_Reference_Counting (TC_LongDoubleSeq); end; TC_IDL_SEQUENCE_String := CORBA.TypeCode.Internals.Build_Sequence_TC (CORBA.TC_String, 0); CORBA.TypeCode.Internals.Disable_Reference_Counting (TC_IDL_SEQUENCE_String); IDL_SEQUENCE_String_Helper.Initialize (Element_TC => CORBA.TC_String, Sequence_TC => TC_IDL_SEQUENCE_String); declare Name : constant CORBA.String := CORBA.To_CORBA_String ("StringSeq"); Id : constant CORBA.String := CORBA.To_CORBA_String ("IDL:omg.org/CORBA/StringSeq:1.0"); begin TC_StringSeq := CORBA.TypeCode.Internals.Build_Alias_TC (Name => Name, Id => Id, Parent => TC_IDL_SEQUENCE_String); CORBA.TypeCode.Internals.Disable_Reference_Counting (TC_StringSeq); end; TC_IDL_SEQUENCE_Wide_String := CORBA.TypeCode.Internals.Build_Sequence_TC (CORBA.TC_Wide_String, 0); CORBA.TypeCode.Internals.Disable_Reference_Counting (TC_IDL_SEQUENCE_Wide_String); IDL_SEQUENCE_Wide_String_Helper.Initialize (Element_TC => CORBA.TC_Wide_String, Sequence_TC => TC_IDL_SEQUENCE_Wide_String); declare Name : constant CORBA.String := CORBA.To_CORBA_String ("WStringSeq"); Id : constant CORBA.String := CORBA.To_CORBA_String ("IDL:omg.org/CORBA/WStringSeq:1.0"); begin TC_WStringSeq := CORBA.TypeCode.Internals.Build_Alias_TC (Name, Id, TC_IDL_SEQUENCE_Wide_String); CORBA.TypeCode.Internals.Disable_Reference_Counting (TC_WStringSeq); end; end Deferred_Initialization; -------------- -- From_Any -- -------------- function From_Any (Item : CORBA.Any) return IDL_SEQUENCE_Any.Sequence renames IDL_SEQUENCE_Any_Helper.From_Any; function From_Any (Item : CORBA.Any) return IDL_SEQUENCE_Boolean.Sequence renames IDL_SEQUENCE_Boolean_Helper.From_Any; function From_Any (Item : CORBA.Any) return IDL_SEQUENCE_Char.Sequence renames IDL_SEQUENCE_Char_Helper.From_Any; function From_Any (Item : CORBA.Any) return IDL_SEQUENCE_Double.Sequence renames IDL_SEQUENCE_Double_Helper.From_Any; function From_Any (Item : CORBA.Any) return IDL_SEQUENCE_Float.Sequence renames IDL_SEQUENCE_Float_Helper.From_Any; function From_Any (Item : CORBA.Any) return IDL_SEQUENCE_Long.Sequence renames IDL_SEQUENCE_Long_Helper.From_Any; function From_Any (Item : CORBA.Any) return IDL_SEQUENCE_Long_Double.Sequence renames IDL_SEQUENCE_Long_Double_Helper.From_Any; function From_Any (Item : CORBA.Any) return IDL_SEQUENCE_Long_Long.Sequence renames IDL_SEQUENCE_Long_Long_Helper.From_Any; function From_Any (Item : CORBA.Any) return IDL_SEQUENCE_Octet.Sequence renames IDL_SEQUENCE_Octet_Helper.From_Any; function From_Any (Item : CORBA.Any) return IDL_SEQUENCE_Short.Sequence renames IDL_SEQUENCE_Short_Helper.From_Any; function From_Any (Item : CORBA.Any) return IDL_SEQUENCE_String.Sequence renames IDL_SEQUENCE_String_Helper.From_Any; function From_Any (Item : CORBA.Any) return IDL_SEQUENCE_Unsigned_Long.Sequence renames IDL_SEQUENCE_Unsigned_Long_Helper.From_Any; function From_Any (Item : CORBA.Any) return IDL_SEQUENCE_Unsigned_Long_Long.Sequence renames IDL_SEQUENCE_Unsigned_Long_Long_Helper.From_Any; function From_Any (Item : CORBA.Any) return IDL_SEQUENCE_Unsigned_Short.Sequence renames IDL_SEQUENCE_Unsigned_Short_Helper.From_Any; function From_Any (Item : CORBA.Any) return IDL_SEQUENCE_Wide_Char.Sequence renames IDL_SEQUENCE_Wide_Char_Helper.From_Any; function From_Any (Item : CORBA.Any) return IDL_SEQUENCE_Wide_String.Sequence renames IDL_SEQUENCE_Wide_String_Helper.From_Any; function From_Any (Item : CORBA.Any) return AnySeq is Result : constant IDL_SEQUENCE_Any.Sequence := From_Any (Item); begin return AnySeq (Result); end From_Any; function From_Any (Item : CORBA.Any) return BooleanSeq is Result : constant IDL_SEQUENCE_Boolean.Sequence := From_Any (Item); begin return BooleanSeq (Result); end From_Any; function From_Any (Item : CORBA.Any) return CharSeq is Result : constant IDL_SEQUENCE_Char.Sequence := From_Any (Item); begin return CharSeq (Result); end From_Any; function From_Any (Item : CORBA.Any) return DoubleSeq is Result : constant IDL_SEQUENCE_Double.Sequence := From_Any (Item); begin return DoubleSeq (Result); end From_Any; function From_Any (Item : CORBA.Any) return FloatSeq is Result : constant IDL_SEQUENCE_Float.Sequence := From_Any (Item); begin return FloatSeq (Result); end From_Any; function From_Any (Item : CORBA.Any) return LongDoubleSeq is Result : constant IDL_SEQUENCE_Long_Double.Sequence := From_Any (Item); begin return LongDoubleSeq (Result); end From_Any; function From_Any (Item : CORBA.Any) return LongSeq is Result : constant IDL_SEQUENCE_Long.Sequence := From_Any (Item); begin return LongSeq (Result); end From_Any; function From_Any (Item : CORBA.Any) return LongLongSeq is Result : constant IDL_SEQUENCE_Long_Long.Sequence := From_Any (Item); begin return LongLongSeq (Result); end From_Any; function From_Any (Item : CORBA.Any) return OctetSeq is Result : constant IDL_SEQUENCE_Octet.Sequence := From_Any (Item); begin return OctetSeq (Result); end From_Any; function From_Any (Item : CORBA.Any) return ShortSeq is Result : constant IDL_SEQUENCE_Short.Sequence := From_Any (Item); begin return ShortSeq (Result); end From_Any; function From_Any (Item : CORBA.Any) return StringSeq is Result : constant IDL_SEQUENCE_String.Sequence := From_Any (Item); begin return StringSeq (Result); end From_Any; function From_Any (Item : CORBA.Any) return ULongLongSeq is Result : constant IDL_SEQUENCE_Unsigned_Long_Long.Sequence := From_Any (Item); begin return ULongLongSeq (Result); end From_Any; function From_Any (Item : CORBA.Any) return ULongSeq is Result : constant IDL_SEQUENCE_Unsigned_Long.Sequence := From_Any (Item); begin return ULongSeq (Result); end From_Any; function From_Any (Item : CORBA.Any) return UShortSeq is Result : constant IDL_SEQUENCE_Unsigned_Short.Sequence := From_Any (Item); begin return UShortSeq (Result); end From_Any; function From_Any (Item : CORBA.Any) return WCharSeq is Result : constant IDL_SEQUENCE_Wide_Char.Sequence := From_Any (Item); begin return WCharSeq (Result); end From_Any; function From_Any (Item : CORBA.Any) return WStringSeq is Result : constant IDL_SEQUENCE_Wide_String.Sequence := From_Any (Item); begin return WStringSeq (Result); end From_Any; ------------ -- To_Any -- ------------ function To_Any (Item : IDL_SEQUENCE_Any.Sequence) return CORBA.Any renames IDL_SEQUENCE_Any_Helper.To_Any; function To_Any (Item : IDL_SEQUENCE_Boolean.Sequence) return CORBA.Any renames IDL_SEQUENCE_Boolean_Helper.To_Any; function To_Any (Item : IDL_SEQUENCE_Char.Sequence) return CORBA.Any renames IDL_SEQUENCE_Char_Helper.To_Any; function To_Any (Item : IDL_SEQUENCE_Double.Sequence) return CORBA.Any renames IDL_SEQUENCE_Double_Helper.To_Any; function To_Any (Item : IDL_SEQUENCE_Float.Sequence) return CORBA.Any renames IDL_SEQUENCE_Float_Helper.To_Any; function To_Any (Item : IDL_SEQUENCE_Long.Sequence) return CORBA.Any renames IDL_SEQUENCE_Long_Helper.To_Any; function To_Any (Item : IDL_SEQUENCE_Long_Double.Sequence) return CORBA.Any renames IDL_SEQUENCE_Long_Double_Helper.To_Any; function To_Any (Item : IDL_SEQUENCE_Long_Long.Sequence) return CORBA.Any renames IDL_SEQUENCE_Long_Long_Helper.To_Any; function To_Any (Item : IDL_SEQUENCE_Octet.Sequence) return CORBA.Any renames IDL_SEQUENCE_Octet_Helper.To_Any; function To_Any (Item : IDL_SEQUENCE_Short.Sequence) return CORBA.Any renames IDL_SEQUENCE_Short_Helper.To_Any; function To_Any (Item : IDL_SEQUENCE_String.Sequence) return CORBA.Any renames IDL_SEQUENCE_String_Helper.To_Any; function To_Any (Item : IDL_SEQUENCE_Unsigned_Long.Sequence) return CORBA.Any renames IDL_SEQUENCE_Unsigned_Long_Helper.To_Any; function To_Any (Item : IDL_SEQUENCE_Unsigned_Long_Long.Sequence) return CORBA.Any renames IDL_SEQUENCE_Unsigned_Long_Long_Helper.To_Any; function To_Any (Item : IDL_SEQUENCE_Unsigned_Short.Sequence) return CORBA.Any renames IDL_SEQUENCE_Unsigned_Short_Helper.To_Any; function To_Any (Item : IDL_SEQUENCE_Wide_Char.Sequence) return CORBA.Any renames IDL_SEQUENCE_Wide_Char_Helper.To_Any; function To_Any (Item : IDL_SEQUENCE_Wide_String.Sequence) return CORBA.Any renames IDL_SEQUENCE_Wide_String_Helper.To_Any; function To_Any (Item : AnySeq) return CORBA.Any is Result : CORBA.Any := To_Any (IDL_SEQUENCE_Any.Sequence (Item)); begin Internals.Set_Type (Result, TC_AnySeq); return Result; end To_Any; function To_Any (Item : BooleanSeq) return CORBA.Any is Result : CORBA.Any := To_Any (IDL_SEQUENCE_Boolean.Sequence (Item)); begin Internals.Set_Type (Result, TC_BooleanSeq); return Result; end To_Any; function To_Any (Item : CharSeq) return CORBA.Any is Result : CORBA.Any := To_Any (IDL_SEQUENCE_Char.Sequence (Item)); begin Internals.Set_Type (Result, TC_CharSeq); return Result; end To_Any; function To_Any (Item : DoubleSeq) return CORBA.Any is Result : CORBA.Any := To_Any (IDL_SEQUENCE_Double.Sequence (Item)); begin Internals.Set_Type (Result, TC_DoubleSeq); return Result; end To_Any; function To_Any (Item : FloatSeq) return CORBA.Any is Result : CORBA.Any := To_Any (IDL_SEQUENCE_Float.Sequence (Item)); begin Internals.Set_Type (Result, TC_FloatSeq); return Result; end To_Any; function To_Any (Item : LongDoubleSeq) return CORBA.Any is Result : CORBA.Any := To_Any (IDL_SEQUENCE_Long_Double.Sequence (Item)); begin Internals.Set_Type (Result, TC_LongDoubleSeq); return Result; end To_Any; function To_Any (Item : LongSeq) return CORBA.Any is Result : CORBA.Any := To_Any (IDL_SEQUENCE_Long.Sequence (Item)); begin Internals.Set_Type (Result, TC_LongSeq); return Result; end To_Any; function To_Any (Item : LongLongSeq) return CORBA.Any is Result : CORBA.Any := To_Any (IDL_SEQUENCE_Long_Long.Sequence (Item)); begin Internals.Set_Type (Result, TC_LongLongSeq); return Result; end To_Any; function To_Any (Item : OctetSeq) return CORBA.Any is Result : CORBA.Any := To_Any (IDL_SEQUENCE_Octet.Sequence (Item)); begin Internals.Set_Type (Result, TC_OctetSeq); return Result; end To_Any; function To_Any (Item : ShortSeq) return CORBA.Any is Result : CORBA.Any := To_Any (IDL_SEQUENCE_Short.Sequence (Item)); begin Internals.Set_Type (Result, TC_ShortSeq); return Result; end To_Any; function To_Any (Item : StringSeq) return CORBA.Any is Result : CORBA.Any := To_Any (IDL_SEQUENCE_String.Sequence (Item)); begin Internals.Set_Type (Result, TC_StringSeq); return Result; end To_Any; function To_Any (Item : ULongLongSeq) return CORBA.Any is Result : CORBA.Any := To_Any (IDL_SEQUENCE_Unsigned_Long_Long.Sequence (Item)); begin Internals.Set_Type (Result, TC_ULongLongSeq); return Result; end To_Any; function To_Any (Item : ULongSeq) return CORBA.Any is Result : CORBA.Any := To_Any (IDL_SEQUENCE_Unsigned_Long.Sequence (Item)); begin Internals.Set_Type (Result, TC_ULongSeq); return Result; end To_Any; function To_Any (Item : UShortSeq) return CORBA.Any is Result : CORBA.Any := To_Any (IDL_SEQUENCE_Unsigned_Short.Sequence (Item)); begin Internals.Set_Type (Result, TC_UShortSeq); return Result; end To_Any; function To_Any (Item : WCharSeq) return CORBA.Any is Result : CORBA.Any := To_Any (IDL_SEQUENCE_Wide_Char.Sequence (Item)); begin Internals.Set_Type (Result, TC_WCharSeq); return Result; end To_Any; function To_Any (Item : WStringSeq) return CORBA.Any is Result : CORBA.Any := To_Any (IDL_SEQUENCE_Wide_String.Sequence (Item)); begin Internals.Set_Type (Result, TC_WStringSeq); return Result; end To_Any; ---------- -- Wrap -- ---------- function Wrap (X : access IDL_SEQUENCE_Any.Sequence) return PolyORB.Any.Content'Class renames IDL_SEQUENCE_Any_Helper.Wrap; function Wrap (X : access IDL_SEQUENCE_Boolean.Sequence) return PolyORB.Any.Content'Class renames IDL_SEQUENCE_Boolean_Helper.Wrap; function Wrap (X : access IDL_SEQUENCE_Char.Sequence) return PolyORB.Any.Content'Class renames IDL_SEQUENCE_Char_Helper.Wrap; function Wrap (X : access IDL_SEQUENCE_Wide_Char.Sequence) return PolyORB.Any.Content'Class renames IDL_SEQUENCE_Wide_Char_Helper.Wrap; function Wrap (X : access IDL_SEQUENCE_Octet.Sequence) return PolyORB.Any.Content'Class renames IDL_SEQUENCE_Octet_Helper.Wrap; function Wrap (X : access IDL_SEQUENCE_Short.Sequence) return PolyORB.Any.Content'Class renames IDL_SEQUENCE_Short_Helper.Wrap; function Wrap (X : access IDL_SEQUENCE_Unsigned_Short.Sequence) return PolyORB.Any.Content'Class renames IDL_SEQUENCE_Unsigned_Short_Helper.Wrap; function Wrap (X : access IDL_SEQUENCE_Long.Sequence) return PolyORB.Any.Content'Class renames IDL_SEQUENCE_Long_Helper.Wrap; function Wrap (X : access IDL_SEQUENCE_Unsigned_Long.Sequence) return PolyORB.Any.Content'Class renames IDL_SEQUENCE_Unsigned_Long_Helper.Wrap; function Wrap (X : access IDL_SEQUENCE_Long_Long.Sequence) return PolyORB.Any.Content'Class renames IDL_SEQUENCE_Long_Long_Helper.Wrap; function Wrap (X : access IDL_SEQUENCE_Unsigned_Long_Long.Sequence) return PolyORB.Any.Content'Class renames IDL_SEQUENCE_Unsigned_Long_Long_Helper.Wrap; function Wrap (X : access IDL_SEQUENCE_Float.Sequence) return PolyORB.Any.Content'Class renames IDL_SEQUENCE_Float_Helper.Wrap; function Wrap (X : access IDL_SEQUENCE_Double.Sequence) return PolyORB.Any.Content'Class renames IDL_SEQUENCE_Double_Helper.Wrap; function Wrap (X : access IDL_SEQUENCE_Long_Double.Sequence) return PolyORB.Any.Content'Class renames IDL_SEQUENCE_Long_Double_Helper.Wrap; function Wrap (X : access IDL_SEQUENCE_String.Sequence) return PolyORB.Any.Content'Class renames IDL_SEQUENCE_String_Helper.Wrap; function Wrap (X : access IDL_SEQUENCE_Wide_String.Sequence) return PolyORB.Any.Content'Class renames IDL_SEQUENCE_Wide_String_Helper.Wrap; begin declare use PolyORB.Initialization; use PolyORB.Initialization.String_Lists; use PolyORB.Utils.Strings; begin Register_Module (Module_Info' (Name => +"CORBA.IDL_SEQUENCES.Helper", Conflicts => Empty, Depends => +"any", Provides => Empty, Implicit => False, Init => Deferred_Initialization'Access, Shutdown => null)); end; end CORBA.IDL_SEQUENCES.Helper; polyorb-2.8~20110207.orig/src/corba/portableserver-adapteractivator.ads0000644000175000017500000000537411750740340025353 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O R T A B L E S E R V E R . A D A P T E R A C T I V A T O R -- -- -- -- S p e c -- -- -- -- Copyright (C) 2001-2008, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the CORBA Specification, and adapted -- -- for use with PolyORB. The copyright notice above, and the license -- -- provisions that follow apply solely to the contents neither explicitly -- -- nor implicitly specified by the CORBA Specification defined by the OMG. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with CORBA.Object; package PortableServer.AdapterActivator is type Ref is new CORBA.Object.Ref with private; function Unknown_Adapter (Self : Ref; Parent : PortableServer.POA_Forward.Ref; Name : CORBA.String) return Boolean; private type Ref is new CORBA.Object.Ref with null record; end PortableServer.AdapterActivator; polyorb-2.8~20110207.orig/src/corba/corba-policy.ads0000644000175000017500000000763011750740337021347 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- C O R B A . P O L I C Y -- -- -- -- S p e c -- -- -- -- Copyright (C) 2001-2010, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the CORBA Specification, and adapted -- -- for use with PolyORB. The copyright notice above, and the license -- -- provisions that follow apply solely to the contents neither explicitly -- -- nor implicitly specified by the CORBA Specification defined by the OMG. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ pragma Ada_2005; with CORBA.Object; with CORBA.Sequences.Unbounded; package CORBA.Policy is -- Implementation note: The Ada mapping defines -- type Ref is new abstract CORBA.Object.Ref with null record; -- This raises Ada semantics error when defining IDL_SEQUENCE_Policy -- and CORBA.ORB.Create_Policy. We modified type Ref to reduce impacts on -- others parts of this CORBA implementation type Ref is new CORBA.Object.Ref with null record; function Get_Policy_Type (Self : Ref) return PolicyType; function Copy (Self : Ref'Class) return Ref'Class; -- Destroy unneeded -- procedure Destroy (Self : Ref); -- Implementation note: these two Sequence types should be defined -- in package CORBA. Yet, this would create circular dependencies -- between CORBA and CORBA.Sequences. package IDL_SEQUENCE_Policy is new CORBA.Sequences.Unbounded (Ref); subtype PolicyList is IDL_SEQUENCE_Policy.Sequence; -- Implementation Note: the IDL-to-Ada mapping defines the -- PolicyList type as: -- type PolicyList is new IDL_SEQUENCE_Policy.Sequence; -- -- This adds new primitives to Ref that requires overriding for -- any derivation of Ref. We define PolicyList as a subtype to -- avoid this behavior. package IDL_SEQUENCE_PolicyType is new CORBA.Sequences.Unbounded (PolicyType); subtype PolicyTypeSeq is IDL_SEQUENCE_PolicyType.Sequence; Repository_Id : constant Standard.String := "IDL:omg.org/CORBA/Policy:1.0"; end CORBA.Policy; polyorb-2.8~20110207.orig/src/corba/portableserver.ads0000644000175000017500000002574111750740340022020 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O R T A B L E S E R V E R -- -- -- -- S p e c -- -- -- -- Copyright (C) 2001-2010, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the CORBA Specification, and adapted -- -- for use with PolyORB. The copyright notice above, and the license -- -- provisions that follow apply solely to the contents neither explicitly -- -- nor implicitly specified by the CORBA Specification defined by the OMG. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ pragma Ada_2005; with Ada.Exceptions; with CORBA.Forward; pragma Elaborate_All (CORBA.Forward); with CORBA.IDL_SEQUENCES; with CORBA.Impl; with CORBA.Object; with CORBA.ServerRequest; with CORBA.Sequences.Unbounded; with PolyORB.Annotations; with PolyORB.Binding_Data; with PolyORB.Objects; with PolyORB.Requests; package PortableServer is pragma Elaborate_Body; -- Forward declaration package POA_Forward is new CORBA.Forward; package IDL_SEQUENCE_PortableServer_POA_Forward is new CORBA.Sequences.Unbounded (POA_Forward.Ref); type POAList is new IDL_SEQUENCE_PortableServer_POA_Forward.Sequence; ForwardRequest : exception; NotAGroupObject : exception; --------------------------- -- DynamicImplementation -- --------------------------- -- The root of all implementation objects: -- DynamicImplementation. type DynamicImplementation is abstract new CORBA.Impl.Object with private; procedure Invoke (Self : access DynamicImplementation; Request : CORBA.ServerRequest.Object_Ptr) is abstract; type Servant is access all DynamicImplementation'Class; -- The root of all static implementations: Servant_Base, -- a type derived from DynamicImplementation (which provides -- a default implementation of the Invoke operation.) type Servant_Base is abstract new DynamicImplementation with private; -- 21.41.1 -- Conforming implementations must provide a controlled (tagged) -- Servant_Base type and default implementations of the primitive -- operations on Servant_Base that meet the required semantics. procedure Invoke (Self : access Servant_Base; Request : CORBA.ServerRequest.Object_Ptr); -- XXX What is the status of these commented spec ? -- FIXME: how to implement this ? -- function "=" (Left, Right : Servant) return Boolean; -- pragma Convention (Intrinsic, "="); -- function Get_Default_POA -- (For_Servant : Servant_Base) -- return POA_Forward.Ref; -- function Get_Interface -- (For_Servant : Servant_Base) -- return CORBA.InterfaceDef.Ref; -- function Is_A -- (For_Servant : Servant_Base; -- Logical_Type_ID : Standard.String) -- return Boolean; -- function Non_Existent -- (For_Servant : Servant_Base) -- return Boolean; -------------- -- ObjectId -- -------------- type ObjectId is new CORBA.IDL_SEQUENCES.OctetSeq; function String_To_ObjectId (Id : String) return ObjectId; -- Convert string Id into an ObjectId. function ObjectId_To_String (Id : ObjectId) return String; -- Convert ObjectId Id into a string. -- Implementation Notes: these functions are not defined in the -- CORBA specification, but defined in various C++ ORB -- implementations. They are provided as a facility. type ObjectId_Access is access ObjectId; package Sequence_IDs is new CORBA.Sequences.Unbounded (ObjectId); -- XXX Part of the MIOP specifications. Should be moved to -- package PortableGroup. type IDs is new Sequence_IDs.Sequence; -- XXX Part of the MIOP specifications. Should be moved to -- package PortableGroup. --------------- -- Constants -- --------------- THREAD_POLICY_ID : constant CORBA.PolicyType := 16; LIFESPAN_POLICY_ID : constant CORBA.PolicyType := 17; ID_UNIQUENESS_POLICY_ID : constant CORBA.PolicyType := 18; ID_ASSIGNMENT_POLICY_ID : constant CORBA.PolicyType := 19; IMPLICIT_ACTIVATION_POLICY_ID : constant CORBA.PolicyType := 20; SERVANT_RETENTION_POLICY_ID : constant CORBA.PolicyType := 21; REQUEST_PROCESSING_POLICY_ID : constant CORBA.PolicyType := 22; type ThreadPolicyValue is (ORB_CTRL_MODEL, SINGLE_THREAD_MODEL, MAIN_THREAD_MODEL); type LifespanPolicyValue is (TRANSIENT, PERSISTENT); type IdUniquenessPolicyValue is (UNIQUE_ID, MULTIPLE_ID); type IdAssignmentPolicyValue is (USER_ID, SYSTEM_ID); type ImplicitActivationPolicyValue is (IMPLICIT_ACTIVATION, NO_IMPLICIT_ACTIVATION); type ServantRetentionPolicyValue is (RETAIN, NON_RETAIN); type RequestProcessingPolicyValue is (USE_ACTIVE_OBJECT_MAP_ONLY, USE_DEFAULT_SERVANT, USE_SERVANT_MANAGER); ------------------------------------------ -- PortableServer Exceptions Management -- ------------------------------------------ type ForwardRequest_Members is new CORBA.IDL_Exception_Members with record Forward_Reference : CORBA.Object.Ref; end record; procedure Get_Members (From : Ada.Exceptions.Exception_Occurrence; To : out ForwardRequest_Members); type NotAGroupObject_Members is new CORBA.IDL_Exception_Members with null record; -- XXX Part of the MIOP specifications. Should be moved to -- package PortableGroup. procedure Get_Members (From : Ada.Exceptions.Exception_Occurrence; To : out NotAGroupObject_Members); -- XXX Part of the MIOP specifications. Should be moved to -- package PortableGroup. procedure Raise_NotAGroupObject (Excp_Memb : NotAGroupObject_Members); pragma No_Return (Raise_NotAGroupObject); -- XXX Part of the MIOP specifications. Should be moved to -- package PortableGroup. -- XXX What is the status of this comment ?? -- Calling ForwardRequest does not increase the usage counter of -- REFERENCE. As a result, the user must ensure not to release -- REFERENCE while the exception is processed. -- There is a dilemna here: -- - if we increase the counter, the usage counter will never -- be decreased if get_members is not called -- - if we do not increase it, the object may be deleted -- before the exception is caught. package Internals is -- Implementation Note: This package defines internal subprograms -- specific to PolyORB. You must not use them. type Request_Dispatcher is access procedure (For_Servant : Servant; Request : CORBA.ServerRequest.Object_Ptr); -- Same signature as primitive Invoke of type -- DynamicImplementation. type Servant_Class_Predicate is access function (For_Servant : Servant) return Boolean; type Servant_Class_Is_A_Operation is access function (Logical_Type_Id : Standard.String) return CORBA.Boolean; procedure Register_Skeleton (Type_Id : String; Is_A : Servant_Class_Predicate; Target_Is_A : Servant_Class_Is_A_Operation; Dispatcher : Request_Dispatcher := null); -- Associate a type id with a class predicate. -- A Dispatcher function can also be specified if the class predicate -- corresponds to a class derived from PortableServer.Servant_Base. -- For classes derived from PortableServer.DynamicImplementation, the -- user must override the Invoke operation himself, and the Dispatcher -- must be set to null. -- NOTE: This procedure is not thread safe. function Get_Type_Id (For_Servant : Servant) return Standard.String; -- Subprograms for PortableInterceptor implementation function Target_Most_Derived_Interface (For_Servant : Servant) return Standard.String; -- Return Type_Id of most derived servant interface function Target_Is_A (For_Servant : Servant; Logical_Type_Id : Standard.String) return CORBA.Boolean; -- Check is servant support specified interface function To_PortableServer_ObjectId (Id : PolyORB.Objects.Object_Id) return ObjectId; -- Convert neutral Object_Id into PortableServer's ObjectId function To_PolyORB_Object_Id (Id : ObjectId) return PolyORB.Objects.Object_Id; -- Convert PortableServer's ObjectId into neutral Object_Id end Internals; private type DynamicImplementation is abstract new CORBA.Impl.Object with null record; overriding function Execute_Servant (Self : not null access DynamicImplementation; Req : PolyORB.Requests.Request_Access) return Boolean; type Servant_Base is abstract new DynamicImplementation with null record; type PortableServer_Current_Note is new PolyORB.Annotations.Note with record Request : PolyORB.Requests.Request_Access; Profile : PolyORB.Binding_Data.Profile_Access; end record; Null_PortableServer_Current_Note : constant PortableServer_Current_Note := (PolyORB.Annotations.Note with Request => null, Profile => null); PortableServer_Current_Registered : Boolean := False; end PortableServer; polyorb-2.8~20110207.orig/src/corba/polyorb-corba_p-names.adb0000644000175000017500000000540411750740340023124 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . C O R B A _ P . N A M E S -- -- -- -- B o d y -- -- -- -- Copyright (C) 2001-2002 Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by ACT Europe. -- -- (email: sales@act-europe.fr) -- -- -- ------------------------------------------------------------------------------ -- String constants defined by OMG specifications. package body PolyORB.CORBA_P.Names is Prefix : constant String := "omg.org"; Version : constant String := "1.0"; ---------------- -- OMG_Prefix -- ---------------- function OMG_Prefix return String is begin return Prefix; end OMG_Prefix; ---------------------- -- OMG_RepositoryId -- ---------------------- function OMG_RepositoryId (Name : String) return String is begin return "IDL:" & Prefix & "/" & Name & ":" & Version; end OMG_RepositoryId; ----------------- -- OMG_Version -- ----------------- function OMG_Version return String is begin return Version; end OMG_Version; end PolyORB.CORBA_P.Names; polyorb-2.8~20110207.orig/src/corba/polyorb-corba_p-exceptions.adb0000644000175000017500000002407011750740340024202 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . C O R B A _ P . E X C E P T I O N S -- -- -- -- B o d y -- -- -- -- Copyright (C) 2001-2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with PolyORB.Errors.Helper; with PolyORB.Exceptions; with PolyORB.Log; with PolyORB.QoS.Exception_Informations; with PolyORB.Types; package body PolyORB.CORBA_P.Exceptions is use Ada.Exceptions; use PolyORB.Any; use PolyORB.Errors; use PolyORB.Errors.Helper; use PolyORB.Exceptions; use PolyORB.Log; use PolyORB.Types; package L is new PolyORB.Log.Facility_Log ("polyorb.corba_p.exceptions"); procedure O (Message : Standard.String; Level : Log_Level := Debug) renames L.Output; function C (Level : Log_Level := Debug) return Boolean renames L.Enabled; ------------------------ -- Is_Forward_Request -- ------------------------ function Is_Forward_Request (Occurrence : PolyORB.Any.Any) return Boolean is use type PolyORB.Any.TypeCode.Local_Ref; begin return not Is_Empty (Occurrence) and then Get_Type (Occurrence) = TC_ForwardRequest; end Is_Forward_Request; ------------------------------ -- Is_Needs_Addressing_Mode -- ------------------------------ function Is_Needs_Addressing_Mode (Occurrence : PolyORB.Any.Any) return Boolean is use type PolyORB.Any.TypeCode.Local_Ref; begin return not Is_Empty (Occurrence) and then Get_Type (Occurrence) = TC_NeedsAddressingMode; end Is_Needs_Addressing_Mode; ------------------------- -- Is_System_Exception -- ------------------------- function Is_System_Exception (Occurrence : PolyORB.Any.Any) return Boolean is Repository_Id : constant PolyORB.Types.RepositoryId := Any.TypeCode.Id (PolyORB.Any.Get_Type (Occurrence)); EId : constant String := To_Standard_String (Repository_Id); Is_Error : Boolean; Id : Error_Id; begin Exception_Name_To_Error_Id (EId, Is_Error, Id); return Is_Error and then Id in ORB_System_Error; end Is_System_Exception; -------------------- -- Raise_From_Any -- -------------------- procedure Raise_From_Any (Occurrence : Any.Any; Message : String := "") is Repository_Id : constant PolyORB.Types.RepositoryId := Any.TypeCode.Id (PolyORB.Any.Get_Type (Occurrence)); EId : constant String := To_Standard_String (Repository_Id); Is_Error : Boolean; Id : Error_Id; Error : Error_Container; begin pragma Debug (C, O ("Raise_From_Any: enter")); Exception_Name_To_Error_Id (EId, Is_Error, Id); if Is_Error then Error.Kind := Id; case Error.Kind is when ORB_System_Error => Error.Member := new System_Exception_Members'(From_Any (Occurrence)); when others => Error.Member := new Null_Members'(Null_Member); end case; pragma Debug (C, O ("Raising " & Error_Id'Image (Error.Kind))); Raise_From_Error (Error, Message); else pragma Debug (C, O ("Raising " & EId)); Raise_User_Exception_From_Any (Repository_Id, Occurrence, Message); end if; raise Program_Error; -- Never reached (Raiser raises an exception.) end Raise_From_Any; ----------------------------- -- System_Exception_To_Any -- ----------------------------- function System_Exception_To_Any (E : Ada.Exceptions.Exception_Occurrence) return CORBA.Any is begin return CORBA.Any (PolyORB.Any.Any'(System_Exception_To_Any (E))); end System_Exception_To_Any; function System_Exception_To_Any (E : Ada.Exceptions.Exception_Occurrence) return PolyORB.Any.Any is Repository_Id : RepositoryId; Members : CORBA.System_Exception_Members; TC : PolyORB.Any.TypeCode.Local_Ref; Result : PolyORB.Any.Any; begin pragma Debug (C, O ("System_Exception_To_Any: enter.")); pragma Debug (C, O ("Exception_Name: " & Exception_Name (E))); pragma Debug (C, O ("Exception_Message: " & Exception_Message (E))); begin Repository_Id := To_PolyORB_String (Occurrence_To_Name (E)); CORBA.Get_Members (E, Members); exception when others => pragma Debug (C, O ("No matching system exception found, " & "will use CORBA/UNKNOWN")); Repository_Id := To_PolyORB_String ("CORBA/UNKNOWN"); Members := (1, CORBA.Completed_Maybe); end; declare CORBA_Exception_Namespace : constant String := "CORBA/"; -- All CORBA System exceptions are prefixed by this string Name : constant String := To_Standard_String (Repository_Id); begin -- Construct exception typecode TC := System_Exception_TypeCode (Name (Name'First + CORBA_Exception_Namespace'Length .. Name'Last)); -- Remove 'CORBA.' from exception name to produce a name -- compatible with internal naming scheme for exceptions. end; Result := Get_Empty_Any_Aggregate (TC); Add_Aggregate_Element (Result, PolyORB.Any.Any (CORBA.To_Any (Members.Minor))); Add_Aggregate_Element (Result, PolyORB.Any.Any (CORBA.To_Any (Members.Completed))); pragma Debug (C, O ("System_Exception_To_Any: leave")); return Result; end System_Exception_To_Any; ---------------------- -- Raise_From_Error -- ---------------------- procedure Raise_From_Error (Error : in out PolyORB.Errors.Error_Container; Message : String := "") is begin pragma Debug (C, O ("About to raise exception: " & Error_Id'Image (Error.Kind))); pragma Assert (Is_Error (Error)); if Error.Kind in ORB_System_Error then pragma Debug (C, O ("Raising CORBA Exception")); CORBA_Raise_From_Error (Error, Message); elsif Error.Kind in POA_Error then pragma Debug (C, O ("Raising PORTABLESERVER.POA Exception")); POA_Raise_From_Error (Error, Message); elsif Error.Kind in POAManager_Error then pragma Debug (C, O ("Raising PORTABLESERVER.POAManager Exception")); POAManager_Raise_From_Error (Error, Message); elsif Error.Kind in PolyORB_Internal_Error then -- PolyORB internal errors are mapped to CORBA.Unknown pragma Debug (C, O ("Raising CORBA.UNKNOWN")); CORBA.Raise_Unknown (CORBA.Default_Sys_Member); end if; raise Program_Error; -- Never reached (Raiser raises an exception.) end Raise_From_Error; ------------------------------ -- Request_Raise_Occurrence -- ------------------------------ procedure Request_Raise_Occurrence (R : Requests.Request) is begin if not Any.Is_Empty (R.Exception_Info) then declare Exception_Occurrence : constant Any.Any := R.Exception_Info; Exception_Information : constant String := PolyORB.QoS.Exception_Informations. Get_Exception_Information (R); Last : Integer; begin -- Truncate exception information to first 150 characters if Exception_Information'Length <= 150 then Last := Exception_Information'Last; else Last := Exception_Information'First + 149; end if; -- Strip trailing newline if Last >= Exception_Information'First and then Exception_Information (Last) = ASCII.LF then Last := Last - 1; end if; -- Raise exception, including original exception information if -- present. if Last >= Exception_Information'First then Raise_From_Any (Exception_Occurrence, ""); else Raise_From_Any (Exception_Occurrence); end if; end; end if; end Request_Raise_Occurrence; end PolyORB.CORBA_P.Exceptions; polyorb-2.8~20110207.orig/src/corba/polyorb-corba_p-corbaloc.ads0000644000175000017500000000447411750740340023634 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . C O R B A _ P . C O R B A L O C -- -- -- -- S p e c -- -- -- -- Copyright (C) 2004-2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- Helper functions to manage CORBA corbaloc references with CORBA.Object; package PolyORB.CORBA_P.CORBALOC is function Object_To_Corbaloc (Obj : CORBA.Object.Ref'Class) return CORBA.String; -- Convert reference to corbaloc, return corbaloc of best profile end PolyORB.CORBA_P.CORBALOC; polyorb-2.8~20110207.orig/src/corba/corba-idl_sequences.ads0000644000175000017500000001536011750740337022672 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- C O R B A . I D L _ S E Q U E N C E S -- -- -- -- S p e c -- -- -- -- Copyright (C) 2005-2010, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the CORBA Specification, and adapted -- -- for use with PolyORB. The copyright notice above, and the license -- -- provisions that follow apply solely to the contents neither explicitly -- -- nor implicitly specified by the CORBA Specification defined by the OMG. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with CORBA.Sequences.Unbounded; package CORBA.IDL_SEQUENCES is -- Implementation Note: this package defines all sequences types -- in the CORBA module. These definitions are separate to avoid -- dragging to much code. -- AnySeq sequence package IDL_SEQUENCE_Any is new CORBA.Sequences.Unbounded (Any); type AnySeq is new IDL_SEQUENCE_Any.Sequence; -- BooleanSeq sequence package IDL_SEQUENCE_Boolean is new CORBA.Sequences.Unbounded (CORBA.Boolean); type BooleanSeq is new IDL_SEQUENCE_Boolean.Sequence; -- CharSeq sequence package IDL_SEQUENCE_Char is new CORBA.Sequences.Unbounded (Char); type CharSeq is new IDL_SEQUENCE_Char.Sequence; -- WCharSeq sequence package IDL_SEQUENCE_Wide_Char is new CORBA.Sequences.Unbounded (Wchar); type WCharSeq is new IDL_SEQUENCE_Wide_Char.Sequence; -- Octet sequence package IDL_SEQUENCE_Octet is new CORBA.Sequences.Unbounded (Octet); type OctetSeq is new IDL_SEQUENCE_Octet.Sequence; -- ShortSeq sequence package IDL_SEQUENCE_Short is new CORBA.Sequences.Unbounded (Short); type ShortSeq is new IDL_SEQUENCE_Short.Sequence; -- UShortSeq sequence package IDL_SEQUENCE_Unsigned_Short is new CORBA.Sequences.Unbounded (Unsigned_Short); type UShortSeq is new IDL_SEQUENCE_Unsigned_Short.Sequence; -- LongSeq sequence package IDL_SEQUENCE_Long is new CORBA.Sequences.Unbounded (Long); type LongSeq is new IDL_SEQUENCE_Long.Sequence; -- ULongSeq sequence package IDL_SEQUENCE_Unsigned_Long is new CORBA.Sequences.Unbounded (Unsigned_Long); type ULongSeq is new IDL_SEQUENCE_Unsigned_Long.Sequence; -- LongLongSeq sequence package IDL_SEQUENCE_Long_Long is new CORBA.Sequences.Unbounded (Long_Long); type LongLongSeq is new IDL_SEQUENCE_Long_Long.Sequence; -- LongLongSeq sequence package IDL_SEQUENCE_Unsigned_Long_Long is new CORBA.Sequences.Unbounded (Unsigned_Long_Long); type ULongLongSeq is new IDL_SEQUENCE_Unsigned_Long_Long.Sequence; -- FloatSeq sequence package IDL_SEQUENCE_Float is new CORBA.Sequences.Unbounded (Float); type FloatSeq is new IDL_SEQUENCE_Float.Sequence; -- DoubleSeq sequence package IDL_SEQUENCE_Double is new CORBA.Sequences.Unbounded (Double); type DoubleSeq is new IDL_SEQUENCE_Double.Sequence; -- LongDoubleSeq sequence package IDL_SEQUENCE_Long_Double is new CORBA.Sequences.Unbounded (Long_Double); type LongDoubleSeq is new IDL_SEQUENCE_Long_Double.Sequence; -- StringSeq sequence package IDL_SEQUENCE_String is new CORBA.Sequences.Unbounded (CORBA.String); type StringSeq is new IDL_SEQUENCE_String.Sequence; -- WStringSeq sequence package IDL_SEQUENCE_Wide_String is new CORBA.Sequences.Unbounded (Wide_String); type WStringSeq is new IDL_SEQUENCE_Wide_String.Sequence; -- Repository Ids AnySeq_Repository_Id : constant Standard.String := "IDL:CORBA/AnySeq:1.0"; BooleanSeq_Repository_Id : constant Standard.String := "IDL:CORBA/BooleanSeq:1.0"; CharSeq_Repository_Id : constant Standard.String := "IDL:CORBA/CharSeq:1.0"; DoubleSeq_Repository_Id : constant Standard.String := "IDL:CORBA/DoubleSeq:1.0"; FloatSeq_Repository_Id : constant Standard.String := "IDL:CORBA/FloatSeq:1.0"; LongDoubleSeq_Repository_Id : constant Standard.String := "IDL:CORBA/LongDoubleSeq:1.0"; LongLongSeq_Repository_Id : constant Standard.String := "IDL:CORBA/LongLongSeq:1.0"; LongSeq_Repository_Id : constant Standard.String := "IDL:CORBA/LongSeq:1.0"; OctetSeq_Repository_Id : constant Standard.String := "IDL:CORBA/OctetSeq:1.0"; ShortSeq_Repository_Id : constant Standard.String := "IDL:CORBA/ShortSeq:1.0"; StringSeq_Repository_Id : constant Standard.String := "IDL:CORBA/StringSeq:1.0"; ULongSeq_Repository_Id : constant Standard.String := "IDL:CORBA/ULongSeq:1.0"; ULongLongSeq_Repository_Id : constant Standard.String := "IDL:CORBA/ULongLongSeq:1.0"; UShortSeq_Repository_Id : constant Standard.String := "IDL:CORBA/UShortSeq:1.0"; WCharSeq_Repository_Id : constant Standard.String := "IDL:CORBA/WCharSeq:1.0"; WStringSeq_Repository_Id : constant Standard.String := "IDL:CORBA/WStringSeq:1.0"; end CORBA.IDL_SEQUENCES; polyorb-2.8~20110207.orig/src/corba/portableserver-current-helper.adb0000644000175000017500000001452111750740340024726 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O R T A B L E S E R V E R . C U R R E N T . H E L P E R -- -- -- -- B o d y -- -- -- -- Copyright (C) 2005-2008, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ ------------------------------------------------- -- This file has been generated automatically -- by IDLAC version 2.3.0w. -- -- Do NOT hand-modify this file, as your -- changes will be lost when you re-run the -- IDL to Ada compiler. ------------------------------------------------- pragma Style_Checks ("NM32766"); with PolyORB.Utils.Strings; with PolyORB.Initialization; pragma Elaborate_All (PolyORB.Initialization); with PolyORB.Exceptions; with PolyORB.Std; with PolyORB.Any; package body PortableServer.Current.Helper is function Unchecked_To_Local_Ref (The_Ref : CORBA.Object.Ref'Class) return PortableServer.Current.Local_Ref is Result : PortableServer.Current.Local_Ref; begin Set (Result, CORBA.Object.Object_Of (The_Ref)); return Result; end Unchecked_To_Local_Ref; function To_Local_Ref (The_Ref : CORBA.Object.Ref'Class) return PortableServer.Current.Local_Ref is begin if CORBA.Object.Is_Nil (The_Ref) or else CORBA.Object.Is_A (The_Ref, Repository_Id) then return Unchecked_To_Local_Ref (The_Ref); end if; CORBA.Raise_Bad_Param (CORBA.Default_Sys_Member); end To_Local_Ref; function From_Any (Item : CORBA.Any) return PortableServer.Current.NoContext_Members is Result : NoContext_Members; pragma Warnings (Off); pragma Unreferenced (Item); pragma Warnings (On); begin return Result; end From_Any; function To_Any (Item : PortableServer.Current.NoContext_Members) return CORBA.Any is Result : constant CORBA.Any := CORBA.Internals.Get_Empty_Any_Aggregate (TC_NoContext); pragma Warnings (Off); pragma Unreferenced (Item); pragma Warnings (On); begin return Result; end To_Any; procedure Raise_NoContext_From_Any (Item : PolyORB.Any.Any; Message : PolyORB.Std.String); pragma No_Return (Raise_NoContext_From_Any); procedure Raise_NoContext_From_Any (Item : PolyORB.Any.Any; Message : PolyORB.Std.String) is Members : constant NoContext_Members := From_Any (CORBA.Any (Item)); begin PolyORB.Exceptions.User_Raise_Exception (NoContext'Identity, Members, Message); end Raise_NoContext_From_Any; procedure Raise_NoContext (Members : NoContext_Members) is begin PolyORB.Exceptions.User_Raise_Exception (NoContext'Identity, Members); end Raise_NoContext; procedure Deferred_Initialization is begin declare Name : constant CORBA.String := CORBA.To_CORBA_String ("Current"); Id : constant CORBA.String := CORBA.To_CORBA_String ("IDL:omg.org/PortableServer/Current:1.0"); begin TC_Current := CORBA.TypeCode.Internals.To_CORBA_Object (PolyORB.Any.TypeCode.TC_Object); CORBA.Internals.Add_Parameter (TC_Current, CORBA.To_Any (Name)); CORBA.Internals.Add_Parameter (TC_Current, CORBA.To_Any (Id)); end; declare Name : constant CORBA.String := CORBA.To_CORBA_String ("NoContext"); Id : constant CORBA.String := CORBA.To_CORBA_String ("IDL:omg.org/PortableServer/Current/NoContext:1.0"); begin TC_NoContext := CORBA.TypeCode.Internals.To_CORBA_Object (PolyORB.Any.TypeCode.TC_Except); CORBA.Internals.Add_Parameter (TC_NoContext, CORBA.To_Any (Name)); CORBA.Internals.Add_Parameter (TC_NoContext, CORBA.To_Any (Id)); end; PolyORB.Exceptions.Register_Exception (CORBA.TypeCode.Internals.To_PolyORB_Object (TC_NoContext), Raise_NoContext_From_Any'Access); end Deferred_Initialization; begin declare use PolyORB.Initialization; use PolyORB.Initialization.String_Lists; use PolyORB.Utils.Strings; begin Register_Module (Module_Info' (Name => +"PortableServer.Current.Helper", Conflicts => PolyORB.Initialization.String_Lists.Empty, Depends => +"any" & "exceptions" , Provides => PolyORB.Initialization.String_Lists.Empty, Implicit => False, Init => Deferred_Initialization'Access, Shutdown => null)); end; end PortableServer.Current.Helper; polyorb-2.8~20110207.orig/src/corba/corba.adb0000644000175000017500000016543511750740340020033 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- C O R B A -- -- -- -- B o d y -- -- -- -- Copyright (C) 2001-2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with Ada.Characters.Handling; with Ada.Characters.Latin_1; with PolyORB.CORBA_P.Exceptions; with PolyORB.Errors.Helper; with PolyORB.Exceptions; with PolyORB.Initialization; with PolyORB.Utils.Strings; package body CORBA is function To_PolyORB_NV (NV : NamedValue) return PolyORB.Any.NamedValue; -- The standard PolyORB's exception annotation mechanism is not -- used for CORBA system exceptions: all CORBA system exceptions -- have the same exception members structure. Exception members -- for such exceptions are represented as first 9 characters of -- exception occurrence message. If an optional message associated -- with exception occurrence then it added after exception members -- representation and separated by the LF character. To_Hex : constant array (Natural range 0 .. 15) of Standard.Character := "0123456789ABCDEF"; ------------------- -- To_PolyORB_NV -- ------------------- function To_PolyORB_NV (NV : NamedValue) return PolyORB.Any.NamedValue is begin return PolyORB.Any.NamedValue' (Name => PolyORB.Types.Identifier (NV.Name), Argument => PolyORB.Any.Any (NV.Argument), Arg_Modes => PolyORB.Any.Flags (NV.Arg_Modes)); end To_PolyORB_NV; function To_CORBA_NV (NV : PolyORB.Any.NamedValue) return NamedValue is begin return CORBA.NamedValue' (Name => CORBA.Identifier (NV.Name), Argument => CORBA.Any (NV.Argument), Arg_Modes => Flags (NV.Arg_Modes)); end To_CORBA_NV; -------------------------- -- TC_Completion_Status -- -------------------------- function TC_Completion_Status return CORBA.TypeCode.Object; -- The typecode for standard enumeration type completion_status. TC_Completion_Status_Cache : CORBA.TypeCode.Object; function TC_Completion_Status return CORBA.TypeCode.Object is use type PolyORB.Types.Unsigned_Long; TC : CORBA.TypeCode.Object renames TC_Completion_Status_Cache; begin if not TypeCode.Internals.Is_Nil (TC) then return TC; end if; TC := TypeCode.Internals.To_CORBA_Object (PolyORB.Any.TypeCode.TC_Enum); Internals.Add_Parameter (TC, To_Any (To_PolyORB_String ("completion_status"))); Internals.Add_Parameter (TC, To_Any (To_PolyORB_String ("IDL:omg.org/CORBA/completion_status:1.0"))); for C in Completion_Status'Range loop Internals.Add_Parameter (TC, To_Any (To_PolyORB_String (Completion_Status'Image (C)))); end loop; TypeCode.Internals.Disable_Reference_Counting (TC); return TC; end TC_Completion_Status; procedure Raise_From_Error (Error : in out PolyORB.Errors.Error_Container; Message : Standard.String); -- Raise the exception associated with the current state of Error. -- If Error is an empty Error Container, no exception is raised. procedure Raise_System_Exception (Excp : Ada.Exceptions.Exception_Id; Excp_Memb : System_Exception_Members; Or_OMGVMCD : Boolean := False; Message : Standard.String := ""); pragma No_Return (Raise_System_Exception); -- Raise any system exception --------------------------------- -- String conversion functions -- --------------------------------- --------------------- -- To_CORBA_String -- --------------------- function To_CORBA_String (Source : Standard.String) return CORBA.String is begin return To_PolyORB_String (Source); end To_CORBA_String; function To_CORBA_String (Source : Standard.String) return CORBA.Identifier is begin return To_PolyORB_String (Source); end To_CORBA_String; -------------------------- -- To_CORBA_Wide_String -- -------------------------- function To_CORBA_Wide_String (Source : Standard.Wide_String) return CORBA.Wide_String is begin return CORBA.Wide_String (Ada.Strings.Wide_Unbounded.To_Unbounded_Wide_String (Source)); end To_CORBA_Wide_String; ----------------------------- -- To_Standard_Wide_String -- ----------------------------- function To_Standard_Wide_String (Source : CORBA.Wide_String) return Standard.Wide_String is begin return Ada.Strings.Wide_Unbounded.To_Wide_String (Ada.Strings.Wide_Unbounded.Unbounded_Wide_String (Source)); end To_Standard_Wide_String; ----------------- -- Get_Members -- ----------------- procedure Get_Members (From : Ada.Exceptions.Exception_Occurrence; To : out System_Exception_Members) is Str : constant Standard.String := Ada.Exceptions.Exception_Message (From); Val : Unsigned_Long; begin -- Check length if Str'Length < 9 or else (Str'Length > 9 and then Str (Str'First + 9) /= Ada.Characters.Latin_1.LF) then Raise_Bad_Param (Default_Sys_Member); end if; -- Unmarshall completion status case Str (Str'First + 8) is when 'N' => To.Completed := Completed_No; when 'Y' => To.Completed := Completed_Yes; when 'M' => To.Completed := Completed_Maybe; when others => raise Constraint_Error; end case; -- Unmarshall minor Val := 0; for J in Str'First .. Str'First + 7 loop case Str (J) is when '0' .. '9' => Val := Val * 16 + Character'Pos (Str (J)) - Character'Pos ('0'); when 'A' .. 'F' => Val := Val * 16 + Character'Pos (Str (J)) - Character'Pos ('A') + 10; when others => raise Constraint_Error; end case; end loop; To.Minor := Val; end Get_Members; procedure Get_Members (From : Ada.Exceptions.Exception_Occurrence; To : out InvalidName_Members) is use Ada.Exceptions; begin if Exception_Identity (From) /= InvalidName'Identity then Raise_Bad_Param (Default_Sys_Member); end if; To := InvalidName_Members'(IDL_Exception_Members with null record); end Get_Members; procedure Get_Members (From : Ada.Exceptions.Exception_Occurrence; To : out InconsistentTypeCode_Members) is use Ada.Exceptions; begin if Exception_Identity (From) /= InconsistentTypeCode'Identity then Raise_Bad_Param (Default_Sys_Member); end if; To := InconsistentTypeCode_Members' (IDL_Exception_Members with null record); end Get_Members; procedure Get_Members (From : Ada.Exceptions.Exception_Occurrence; To : out PolicyError_Members) is use Ada.Exceptions; begin if Exception_Identity (From) /= PolicyError'Identity then Raise_Bad_Param (Default_Sys_Member); end if; PolyORB.Exceptions.User_Get_Members (From, To); end Get_Members; procedure Get_Members (From : Ada.Exceptions.Exception_Occurrence; To : out UnknownUserException_Members) is use Ada.Exceptions; begin if Exception_Identity (From) /= UnknownUserException'Identity then Raise_Bad_Param (Default_Sys_Member); end if; PolyORB.Exceptions.User_Get_Members (From, To); end Get_Members; ---------------------------- -- Raise_System_Exception -- ---------------------------- procedure Raise_System_Exception (Excp : Ada.Exceptions.Exception_Id; Excp_Memb : System_Exception_Members; Or_OMGVMCD : Boolean := False; Message : Standard.String := "") is Str : Standard.String (1 .. 9); Val : CORBA.Unsigned_Long; begin -- Marshall Minor and Completed fields of EXCP_MEMB into a string. case Excp_Memb.Completed is when Completed_Yes => Str (9) := 'Y'; when Completed_No => Str (9) := 'N'; when Completed_Maybe => Str (9) := 'M'; end case; Val := Excp_Memb.Minor; if Or_OMGVMCD then Val := Val or OMGVMCID; end if; for J in 1 .. 8 loop Str (J) := To_Hex (Integer (Val / 2 ** 28)); Val := (Val mod 2 ** 28) * 16; end loop; -- Raise the exception if Message = "" then Ada.Exceptions.Raise_Exception (Excp, Str); else Ada.Exceptions.Raise_Exception (Excp, Str & Ada.Characters.Latin_1.LF & Message); end if; -- This point is never reached (Excp cannot be null) raise Program_Error; end Raise_System_Exception; ------------------- -- Raise_Unknown -- ------------------- procedure Raise_Unknown (Excp_Memb : System_Exception_Members; Message : Standard.String := "") is Or_OMGVMCD : constant Boolean := Excp_Memb.Minor in 1 .. 3; begin Raise_System_Exception (Unknown'Identity, Excp_Memb, Or_OMGVMCD, Message); end Raise_Unknown; --------------------- -- Raise_Bad_Param -- --------------------- procedure Raise_Bad_Param (Excp_Memb : System_Exception_Members; Message : Standard.String := "") is Or_OMGVMCD : constant Boolean := Excp_Memb.Minor in 1 .. 41; begin Raise_System_Exception (Bad_Param'Identity, Excp_Memb, Or_OMGVMCD, Message); end Raise_Bad_Param; --------------------- -- Raise_No_Memory -- --------------------- procedure Raise_No_Memory (Excp_Memb : System_Exception_Members; Message : Standard.String := "") is begin Raise_System_Exception (No_Memory'Identity, Excp_Memb, False, Message); end Raise_No_Memory; --------------------- -- Raise_Imp_Limit -- --------------------- procedure Raise_Imp_Limit (Excp_Memb : System_Exception_Members; Message : Standard.String := "") is Or_OMGVMCD : constant Boolean := Excp_Memb.Minor = 1; begin Raise_System_Exception (Imp_Limit'Identity, Excp_Memb, Or_OMGVMCD, Message); end Raise_Imp_Limit; ------------------------ -- Raise_Comm_Failure -- ------------------------ procedure Raise_Comm_Failure (Excp_Memb : System_Exception_Members; Message : Standard.String := "") is begin Raise_System_Exception (Comm_Failure'Identity, Excp_Memb, False, Message); end Raise_Comm_Failure; ---------------------- -- Raise_Inv_Objref -- ---------------------- procedure Raise_Inv_Objref (Excp_Memb : System_Exception_Members; Message : Standard.String := "") is begin Raise_System_Exception (Inv_Objref'Identity, Excp_Memb, False, Message); end Raise_Inv_Objref; ------------------------- -- Raise_No_Permission -- ------------------------- procedure Raise_No_Permission (Excp_Memb : System_Exception_Members; Message : Standard.String := "") is begin Raise_System_Exception (No_Permission'Identity, Excp_Memb, False, Message); end Raise_No_Permission; -------------------- -- Raise_Internal -- -------------------- procedure Raise_Internal (Excp_Memb : System_Exception_Members; Message : Standard.String := "") is Or_OMGVMCD : constant Boolean := Excp_Memb.Minor in 1 .. 2; begin Raise_System_Exception (Internal'Identity, Excp_Memb, Or_OMGVMCD, Message); end Raise_Internal; ------------------- -- Raise_Marshal -- ------------------- procedure Raise_Marshal (Excp_Memb : System_Exception_Members; Message : Standard.String := "") is Or_OMGVMCD : constant Boolean := Excp_Memb.Minor in 1 .. 7; begin Raise_System_Exception (Marshal'Identity, Excp_Memb, Or_OMGVMCD, Message); end Raise_Marshal; ---------------------- -- Raise_Initialize -- ---------------------- procedure Raise_Initialize (Excp_Memb : System_Exception_Members; Message : Standard.String := "") is Or_OMGVMCD : constant Boolean := Excp_Memb.Minor = 1; begin Raise_System_Exception (Initialize'Identity, Excp_Memb, Or_OMGVMCD, Message); end Raise_Initialize; ------------------------ -- Raise_No_Implement -- ------------------------ procedure Raise_No_Implement (Excp_Memb : System_Exception_Members; Message : Standard.String := "") is Or_OMGVMCD : constant Boolean := Excp_Memb.Minor in 1 .. 7; begin Raise_System_Exception (No_Implement'Identity, Excp_Memb, Or_OMGVMCD, Message); end Raise_No_Implement; ------------------------ -- Raise_Bad_TypeCode -- ------------------------ procedure Raise_Bad_TypeCode (Excp_Memb : System_Exception_Members; Message : Standard.String := "") is Or_OMGVMCD : constant Boolean := Excp_Memb.Minor in 1 .. 3; begin Raise_System_Exception (Bad_TypeCode'Identity, Excp_Memb, Or_OMGVMCD, Message); end Raise_Bad_TypeCode; ------------------------- -- Raise_Bad_Operation -- ------------------------- procedure Raise_Bad_Operation (Excp_Memb : System_Exception_Members; Message : Standard.String := "") is Or_OMGVMCD : constant Boolean := Excp_Memb.Minor in 1 .. 2; begin Raise_System_Exception (Bad_Operation'Identity, Excp_Memb, Or_OMGVMCD, Message); end Raise_Bad_Operation; ------------------------ -- Raise_No_Resources -- ------------------------ procedure Raise_No_Resources (Excp_Memb : System_Exception_Members; Message : Standard.String := "") is Or_OMGVMCD : constant Boolean := Excp_Memb.Minor in 1 .. 2; begin Raise_System_Exception (No_Resources'Identity, Excp_Memb, Or_OMGVMCD, Message); end Raise_No_Resources; ----------------------- -- Raise_No_Response -- ----------------------- procedure Raise_No_Response (Excp_Memb : System_Exception_Members; Message : Standard.String := "") is begin Raise_System_Exception (No_Response'Identity, Excp_Memb, False, Message); end Raise_No_Response; ------------------------- -- Raise_Persist_Store -- ------------------------- procedure Raise_Persist_Store (Excp_Memb : System_Exception_Members; Message : Standard.String := "") is begin Raise_System_Exception (Persist_Store'Identity, Excp_Memb, False, Message); end Raise_Persist_Store; ------------------------- -- Raise_Bad_Inv_Order -- ------------------------- procedure Raise_Bad_Inv_Order (Excp_Memb : System_Exception_Members; Message : Standard.String := "") is Or_OMGVMCD : constant Boolean := Excp_Memb.Minor in 1 .. 20; begin Raise_System_Exception (Bad_Inv_Order'Identity, Excp_Memb, Or_OMGVMCD, Message); end Raise_Bad_Inv_Order; --------------------- -- Raise_Transient -- --------------------- procedure Raise_Transient (Excp_Memb : System_Exception_Members; Message : Standard.String := "") is Or_OMGVMCD : constant Boolean := Excp_Memb.Minor in 1 .. 4; begin Raise_System_Exception (Transient'Identity, Excp_Memb, Or_OMGVMCD, Message); end Raise_Transient; -------------------- -- Raise_Free_Mem -- -------------------- procedure Raise_Free_Mem (Excp_Memb : System_Exception_Members; Message : Standard.String := "") is begin Raise_System_Exception (Free_Mem'Identity, Excp_Memb, False, Message); end Raise_Free_Mem; --------------------- -- Raise_Inv_Ident -- --------------------- procedure Raise_Inv_Ident (Excp_Memb : System_Exception_Members; Message : Standard.String := "") is begin Raise_System_Exception (Inv_Ident'Identity, Excp_Memb, False, Message); end Raise_Inv_Ident; -------------------- -- Raise_Inv_Flag -- -------------------- procedure Raise_Inv_Flag (Excp_Memb : System_Exception_Members; Message : Standard.String := "") is begin Raise_System_Exception (Inv_Flag'Identity, Excp_Memb, False, Message); end Raise_Inv_Flag; ---------------------- -- Raise_Intf_Repos -- ---------------------- procedure Raise_Intf_Repos (Excp_Memb : System_Exception_Members; Message : Standard.String := "") is Or_OMGVMCD : constant Boolean := Excp_Memb.Minor in 1 .. 2; begin Raise_System_Exception (Intf_Repos'Identity, Excp_Memb, Or_OMGVMCD, Message); end Raise_Intf_Repos; ----------------------- -- Raise_Bad_Context -- ----------------------- procedure Raise_Bad_Context (Excp_Memb : System_Exception_Members; Message : Standard.String := "") is Or_OMGVMCD : constant Boolean := Excp_Memb.Minor in 1 .. 2; begin Raise_System_Exception (Bad_Context'Identity, Excp_Memb, Or_OMGVMCD, Message); end Raise_Bad_Context; ----------------------- -- Raise_Obj_Adapter -- ----------------------- procedure Raise_Obj_Adapter (Excp_Memb : System_Exception_Members; Message : Standard.String := "") is Or_OMGVMCD : constant Boolean := Excp_Memb.Minor in 1 .. 7; begin Raise_System_Exception (Obj_Adapter'Identity, Excp_Memb, Or_OMGVMCD, Message); end Raise_Obj_Adapter; --------------------------- -- Raise_Data_Conversion -- --------------------------- procedure Raise_Data_Conversion (Excp_Memb : System_Exception_Members; Message : Standard.String := "") is Or_OMGVMCD : constant Boolean := Excp_Memb.Minor in 1 .. 2; begin Raise_System_Exception (Data_Conversion'Identity, Excp_Memb, Or_OMGVMCD, Message); end Raise_Data_Conversion; ---------------------------- -- Raise_Object_Not_Exist -- ---------------------------- procedure Raise_Object_Not_Exist (Excp_Memb : System_Exception_Members; Message : Standard.String := "") is Or_OMGVMCD : constant Boolean := Excp_Memb.Minor in 1 .. 4; begin Raise_System_Exception (Object_Not_Exist'Identity, Excp_Memb, Or_OMGVMCD, Message); end Raise_Object_Not_Exist; -------------------------------- -- Raise_Transaction_Required -- -------------------------------- procedure Raise_Transaction_Required (Excp_Memb : System_Exception_Members; Message : Standard.String := "") is begin Raise_System_Exception (Transaction_Required'Identity, Excp_Memb, False, Message); end Raise_Transaction_Required; ---------------------------------- -- Raise_Transaction_Rolledback -- ---------------------------------- procedure Raise_Transaction_Rolledback (Excp_Memb : System_Exception_Members; Message : Standard.String := "") is Or_OMGVMCD : constant Boolean := Excp_Memb.Minor in 1 .. 3; begin Raise_System_Exception (Transaction_Rolledback'Identity, Excp_Memb, Or_OMGVMCD, Message); end Raise_Transaction_Rolledback; ------------------------------- -- Raise_Invalid_Transaction -- ------------------------------- procedure Raise_Invalid_Transaction (Excp_Memb : System_Exception_Members; Message : Standard.String := "") is begin Raise_System_Exception (Invalid_Transaction'Identity, Excp_Memb, False, Message); end Raise_Invalid_Transaction; ---------------------- -- Raise_Inv_Policy -- ---------------------- procedure Raise_Inv_Policy (Excp_Memb : System_Exception_Members; Message : Standard.String := "") is Or_OMGVMCD : constant Boolean := Excp_Memb.Minor in 1 .. 3; begin Raise_System_Exception (Inv_Policy'Identity, Excp_Memb, Or_OMGVMCD, Message); end Raise_Inv_Policy; -------------------------------- -- Raise_Codeset_Incompatible -- -------------------------------- procedure Raise_Codeset_Incompatible (Excp_Memb : System_Exception_Members; Message : Standard.String := "") is begin Raise_System_Exception (Codeset_Incompatible'Identity, Excp_Memb, False, Message); end Raise_Codeset_Incompatible; ------------------- -- Raise_Rebind -- ------------------- procedure Raise_Rebind (Excp_Memb : System_Exception_Members; Message : Standard.String := "") is begin Raise_System_Exception (Rebind'Identity, Excp_Memb, False, Message); end Raise_Rebind; ------------------- -- Raise_Timeout -- ------------------- procedure Raise_Timeout (Excp_Memb : System_Exception_Members; Message : Standard.String := "") is begin Raise_System_Exception (Timeout'Identity, Excp_Memb, False, Message); end Raise_Timeout; ----------------------------------- -- Raise_Transaction_Unavailable -- ----------------------------------- procedure Raise_Transaction_Unavailable (Excp_Memb : System_Exception_Members; Message : Standard.String := "") is begin Raise_System_Exception (Transaction_Unavailable'Identity, Excp_Memb, False, Message); end Raise_Transaction_Unavailable; ---------------------------- -- Raise_Transaction_Mode -- ---------------------------- procedure Raise_Transaction_Mode (Excp_Memb : System_Exception_Members; Message : Standard.String := "") is begin Raise_System_Exception (Transaction_Mode'Identity, Excp_Memb, False, Message); end Raise_Transaction_Mode; ------------------- -- Raise_Bad_Qos -- ------------------- procedure Raise_Bad_Qos (Excp_Memb : System_Exception_Members; Message : Standard.String := "") is begin Raise_System_Exception (Bad_Qos'Identity, Excp_Memb, False, Message); end Raise_Bad_Qos; ------------ -- To_Any -- ------------ function To_Any (Item : Short) return CORBA.Any is begin return CORBA.Any (PolyORB.Any.To_Any (PolyORB.Types.Short (Item))); end To_Any; function To_Any (Item : Long) return Any is begin return CORBA.Any (PolyORB.Any.To_Any (PolyORB.Types.Long (Item))); end To_Any; function To_Any (Item : Long_Long) return Any is begin return CORBA.Any (PolyORB.Any.To_Any (PolyORB.Types.Long_Long (Item))); end To_Any; function To_Any (Item : Unsigned_Short) return Any is begin return CORBA.Any (PolyORB.Any.To_Any (PolyORB.Types.Unsigned_Short (Item))); end To_Any; function To_Any (Item : Unsigned_Long) return Any is begin return CORBA.Any (PolyORB.Any.To_Any (PolyORB.Types.Unsigned_Long (Item))); end To_Any; function To_Any (Item : Unsigned_Long_Long) return Any is begin return CORBA.Any (PolyORB.Any.To_Any (PolyORB.Types.Unsigned_Long_Long (Item))); end To_Any; function To_Any (Item : CORBA.Float) return Any is begin return CORBA.Any (PolyORB.Any.To_Any (PolyORB.Types.Float (Item))); end To_Any; function To_Any (Item : Double) return Any is begin return CORBA.Any (PolyORB.Any.To_Any (PolyORB.Types.Double (Item))); end To_Any; function To_Any (Item : Long_Double) return Any is begin return CORBA.Any (PolyORB.Any.To_Any (PolyORB.Types.Long_Double (Item))); end To_Any; function To_Any (Item : Octet) return Any is begin return CORBA.Any (PolyORB.Any.To_Any (PolyORB.Types.Octet (Item))); end To_Any; function To_Any (Item : CORBA.String) return Any is begin return CORBA.Any (PolyORB.Any.To_Any (PolyORB.Types.String (Item))); end To_Any; function To_Any (Item : CORBA.Wide_String) return Any is begin return CORBA.Any (PolyORB.Any.To_Any (PolyORB.Types.Wide_String (Item))); end To_Any; function To_Any (Item : TypeCode.Object) return CORBA.Any is begin return CORBA.Any (PolyORB.Any.To_Any (TypeCode.Internals.To_PolyORB_Object (Item))); end To_Any; function To_Any (Item : Completion_Status) return CORBA.Any is Result : CORBA.Any := Internals.Get_Empty_Any_Aggregate (TC_Completion_Status); begin CORBA.Internals.Add_Aggregate_Element (Result, To_Any (Unsigned_Long (Completion_Status'Pos (Item)))); return Result; end To_Any; -------------------- -- From_Any (Any) -- -------------------- function From_Any (Item : Any) return Short is begin return Short (PolyORB.Types.Short'(From_Any (Item))); end From_Any; function From_Any (Item : Any) return Long is begin return Long (PolyORB.Types.Long'(From_Any (Item))); end From_Any; function From_Any (Item : Any) return Long_Long is begin return Long_Long (PolyORB.Types.Long_Long'(From_Any (Item))); end From_Any; function From_Any (Item : Any) return Unsigned_Short is begin return Unsigned_Short (PolyORB.Types.Unsigned_Short'(From_Any (Item))); end From_Any; function From_Any (Item : Any) return Unsigned_Long is begin return Unsigned_Long (PolyORB.Types.Unsigned_Long'(From_Any (Item))); end From_Any; function From_Any (Item : Any) return Unsigned_Long_Long is begin return Unsigned_Long_Long (PolyORB.Types.Unsigned_Long_Long'(From_Any (Item))); end From_Any; function From_Any (Item : Any) return CORBA.Float is begin return CORBA.Float (PolyORB.Types.Float'(From_Any (Item))); end From_Any; function From_Any (Item : Any) return Double is begin return Double (PolyORB.Types.Double'(From_Any (Item))); end From_Any; function From_Any (Item : Any) return Long_Double is begin return Long_Double (PolyORB.Types.Long_Double'(From_Any (Item))); end From_Any; function From_Any (Item : Any) return Octet is begin return Octet (PolyORB.Types.Octet'(From_Any (Item))); end From_Any; function From_Any (Item : Any) return CORBA.String is begin return CORBA.String (PolyORB.Types.String'(From_Any (Item))); end From_Any; function From_Any (Item : Any) return CORBA.Wide_String is begin return CORBA.Wide_String (PolyORB.Types.Wide_String'(From_Any (Item))); end From_Any; function From_Any (Item : Any) return TypeCode.Object is begin return TypeCode.Internals.To_CORBA_Object (From_Any (Item)); end From_Any; function From_Any (Item : CORBA.Any) return Completion_Status is Result : constant PolyORB.Errors.Completion_Status := PolyORB.Errors.Helper.From_Any (PolyORB.Any.Any (Get_Aggregate_Element (Item, PolyORB.Any.TypeCode.TC_Unsigned_Long, 0))); begin return CORBA.Completion_Status (Result); end From_Any; ------------------------------ -- From_Any (Any_Container) -- ------------------------------ function From_Any (Item : Any_Container'Class) return Short is begin return Short (PolyORB.Types.Short'(PolyORB.Any.From_Any (Item))); end From_Any; function From_Any (Item : Any_Container'Class) return Long is begin return Long (PolyORB.Types.Long'(PolyORB.Any.From_Any (Item))); end From_Any; function From_Any (Item : Any_Container'Class) return Long_Long is begin return Long_Long (PolyORB.Types.Long_Long'(PolyORB.Any.From_Any (Item))); end From_Any; function From_Any (Item : Any_Container'Class) return Unsigned_Short is begin return Unsigned_Short (PolyORB.Types.Unsigned_Short'(PolyORB.Any.From_Any (Item))); end From_Any; function From_Any (Item : Any_Container'Class) return Unsigned_Long is begin return Unsigned_Long (PolyORB.Types.Unsigned_Long'(PolyORB.Any.From_Any (Item))); end From_Any; function From_Any (Item : Any_Container'Class) return Unsigned_Long_Long is begin return Unsigned_Long_Long (PolyORB.Types.Unsigned_Long_Long'(PolyORB.Any.From_Any (Item))); end From_Any; function From_Any (Item : Any_Container'Class) return CORBA.Float is begin return CORBA.Float (PolyORB.Types.Float'(PolyORB.Any.From_Any (Item))); end From_Any; function From_Any (Item : Any_Container'Class) return Double is begin return Double (PolyORB.Types.Double'(PolyORB.Any.From_Any (Item))); end From_Any; function From_Any (Item : Any_Container'Class) return Long_Double is begin return Long_Double (PolyORB.Types.Long_Double'(PolyORB.Any.From_Any (Item))); end From_Any; function From_Any (Item : Any_Container'Class) return Boolean is begin return Boolean (PolyORB.Types.Boolean'(PolyORB.Any.From_Any (Item))); end From_Any; function From_Any (Item : Any_Container'Class) return Char is begin return Char (PolyORB.Types.Char'(PolyORB.Any.From_Any (Item))); end From_Any; function From_Any (Item : Any_Container'Class) return Wchar is begin return Wchar (PolyORB.Types.Wchar'(PolyORB.Any.From_Any (Item))); end From_Any; function From_Any (Item : Any_Container'Class) return Octet is begin return Octet (PolyORB.Types.Octet'(PolyORB.Any.From_Any (Item))); end From_Any; function From_Any (Item : Any_Container'Class) return TypeCode.Object is begin return TypeCode.Internals.To_CORBA_Object (PolyORB.Any.From_Any (Item)); end From_Any; function From_Any (Item : Any_Container'Class) return CORBA.String is begin return CORBA.String (PolyORB.Types.String'(PolyORB.Any.From_Any (Item))); end From_Any; function From_Any (Item : Any_Container'Class) return CORBA.Wide_String is begin return CORBA.Wide_String (PolyORB.Types.Wide_String'(PolyORB.Any.From_Any (Item))); end From_Any; ---------- -- Wrap -- ---------- -- Generic wrapper around PolyORB neutral Wrap functions, performing -- conversion from access to CORBA type to access to neutral type. generic type CT is private; type PT is private; with function Wrap (X : not null access PT) return PolyORB.Any.Content'Class is <>; function WG (CX : not null access CT) return Content'Class; -------- -- WG -- -------- function WG (CX : not null access CT) return Content'Class is PX : access PT; -- WAG:64 -- Should be "not null access PT" but the compiler currently rejects -- a null excluding access object without initialization, even though -- the object is imported. for PX'Address use CX'Address; pragma Import (Ada, PX); begin return Wrap (PX); end WG; package PT renames PolyORB.Types; use PolyORB.Any; function W is new WG (CT => Short, PT => PT.Short); function Wrap (X : not null access Short) return Content'Class renames W; function W is new WG (CT => Long, PT => PT.Long); function Wrap (X : not null access Long) return Content'Class renames W; function W is new WG (CT => Long_Long, PT => PT.Long_Long); function Wrap (X : not null access Long_Long) return Content'Class renames W; function W is new WG (CT => Unsigned_Short, PT => PT.Unsigned_Short); function Wrap (X : not null access Unsigned_Short) return Content'Class renames W; function W is new WG (CT => Unsigned_Long, PT => PT.Unsigned_Long); function Wrap (X : not null access Unsigned_Long) return Content'Class renames W; function W is new WG (CT => Unsigned_Long_Long, PT => PT.Unsigned_Long_Long); function Wrap (X : not null access Unsigned_Long_Long) return Content'Class renames W; function W is new WG (CT => Float, PT => PT.Float); function Wrap (X : not null access Float) return Content'Class renames W; function W is new WG (CT => Double, PT => PT.Double); function Wrap (X : not null access Double) return Content'Class renames W; function W is new WG (CT => Long_Double, PT => PT.Long_Double); function Wrap (X : not null access Long_Double) return Content'Class renames W; -- Boolean, Char and Wchar are subtypes, not derived types: no need for -- conversion. function Wrap (X : not null access Boolean) return Content'Class renames PolyORB.Any.Wrap; function Wrap (X : not null access Char) return Content'Class renames PolyORB.Any.Wrap; function Wrap (X : not null access Wchar) return Content'Class renames PolyORB.Any.Wrap; function W is new WG (CT => Octet, PT => PT.Octet); function Wrap (X : not null access Octet) return Content'Class renames W; function W is new WG (CT => CORBA.String, PT => PT.String); function Wrap (X : not null access String) return Content'Class renames W; function W is new WG (CT => CORBA.Wide_String, PT => PT.Wide_String); function Wrap (X : not null access Wide_String) return Content'Class renames W; function Wrap (X : not null access TypeCode.Object) return Content'Class is begin return TypeCode.Internals.Wrap (X); end Wrap; -------------- -- Get_Type -- -------------- function Get_Type (The_Any : Any) return CORBA.TypeCode.Object is begin return CORBA.TypeCode.Internals.To_CORBA_Object (Get_Type (The_Any)); end Get_Type; ----------- -- Image -- ----------- function Image (NV : NamedValue) return Standard.String is begin return PolyORB.Any.Image (To_PolyORB_NV (NV)); end Image; ------------------- -- Is_Equivalent -- ------------------- function Is_Equivalent (RI1, RI2 : RepositoryId) return Boolean is begin return Is_Equivalent (To_Standard_String (RI1), To_Standard_String (RI2)); end Is_Equivalent; function Is_Equivalent (RI1, RI2 : Standard.String) return Boolean is use Ada.Characters.Handling; begin return To_Lower (RI1) = To_Lower (RI2); end Is_Equivalent; ---------------------- -- Raise_From_Error -- ---------------------- procedure Raise_From_Error (Error : in out PolyORB.Errors.Error_Container; Message : Standard.String) is use PolyORB.Errors; begin pragma Assert (Error.Kind in ORB_System_Error); declare Member : constant PolyORB.Errors.System_Exception_Members := PolyORB.Errors.System_Exception_Members (Error.Member.all); CORBA_Member : constant CORBA.System_Exception_Members := System_Exception_Members' (Minor => CORBA.Unsigned_Long (Member.Minor), Completed => CORBA.Completion_Status (Member.Completed)); begin Free (Error.Member); -- One to one mapping of PolyORB Error_Id to CORBA System exceptions case Error.Kind is when Unknown_E => Raise_Unknown (CORBA_Member, Message); when Bad_Param_E => Raise_Bad_Param (CORBA_Member, Message); when No_Memory_E => Raise_No_Memory (CORBA_Member, Message); when Imp_Limit_E => Raise_Imp_Limit (CORBA_Member, Message); when Comm_Failure_E => Raise_Comm_Failure (CORBA_Member, Message); when Inv_Objref_E => Raise_Inv_Objref (CORBA_Member, Message); when No_Permission_E => Raise_No_Permission (CORBA_Member, Message); when Internal_E => Raise_Internal (CORBA_Member, Message); when Marshal_E => Raise_Marshal (CORBA_Member, Message); when Initialize_E => Raise_Initialize (CORBA_Member, Message); when No_Implement_E => Raise_No_Implement (CORBA_Member, Message); when Bad_TypeCode_E => Raise_Bad_TypeCode (CORBA_Member, Message); when Bad_Operation_E => Raise_Bad_Operation (CORBA_Member, Message); when No_Resources_E => Raise_No_Resources (CORBA_Member, Message); when No_Response_E => Raise_No_Response (CORBA_Member, Message); when Persist_Store_E => Raise_Persist_Store (CORBA_Member, Message); when Bad_Inv_Order_E => Raise_Bad_Inv_Order (CORBA_Member, Message); when Transient_E => Raise_Transient (CORBA_Member, Message); when Free_Mem_E => Raise_Free_Mem (CORBA_Member, Message); when Inv_Ident_E => Raise_Inv_Ident (CORBA_Member, Message); when Inv_Flag_E => Raise_Inv_Flag (CORBA_Member, Message); when Intf_Repos_E => Raise_Intf_Repos (CORBA_Member, Message); when Bad_Context_E => Raise_Bad_Context (CORBA_Member, Message); when Obj_Adapter_E => Raise_Obj_Adapter (CORBA_Member, Message); when Data_Conversion_E => Raise_Data_Conversion (CORBA_Member, Message); when Object_Not_Exist_E => Raise_Object_Not_Exist (CORBA_Member, Message); when Transaction_Required_E => Raise_Transaction_Required (CORBA_Member, Message); when Transaction_Rolledback_E => Raise_Transaction_Rolledback (CORBA_Member, Message); when Invalid_Transaction_E => Raise_Invalid_Transaction (CORBA_Member, Message); when Inv_Policy_E => Raise_Inv_Policy (CORBA_Member, Message); when Codeset_Incompatible_E => Raise_Codeset_Incompatible (CORBA_Member, Message); when Rebind_E => Raise_Rebind (CORBA_Member, Message); when Timeout_E => Raise_Timeout (CORBA_Member, Message); when Transaction_Unavailable_E => Raise_Transaction_Unavailable (CORBA_Member, Message); when Transaction_Mode_E => Raise_Transaction_Mode (CORBA_Member, Message); when Bad_Qos_E => Raise_Bad_Qos (CORBA_Member, Message); when others => raise Program_Error; end case; end; end Raise_From_Error; package body Internals is --------------------------- -- Add_Aggregate_Element -- --------------------------- procedure Add_Aggregate_Element (Value : in out CORBA.Any; Element : CORBA.Any) renames CORBA.Add_Aggregate_Element; ------------------- -- Add_Parameter -- ------------------- procedure Add_Parameter (TC : TypeCode.Object; Param : Any) is begin PolyORB.Any.TypeCode.Add_Parameter (CORBA.TypeCode.Internals.To_PolyORB_Object (TC), PolyORB.Any.Any (Param)); end Add_Parameter; ------------------------- -- Get_Aggregate_Count -- ------------------------- function Get_Aggregate_Count (Value : Any) return CORBA.Unsigned_Long is begin return CORBA.Unsigned_Long (PolyORB.Types.Unsigned_Long'(Get_Aggregate_Count (Value))); end Get_Aggregate_Count; --------------------------- -- Get_Aggregate_Element -- --------------------------- function Get_Aggregate_Element (Value : Any; TC : CORBA.TypeCode.Object; Index : CORBA.Unsigned_Long) return Any is begin return Get_Aggregate_Element (Value, TypeCode.Internals.To_PolyORB_Object (TC), PolyORB.Types.Unsigned_Long (Index)); end Get_Aggregate_Element; ------------------- -- Get_Empty_Any -- ------------------- function Get_Empty_Any (TC : TypeCode.Object) return PolyORB.Any.Any is begin return PolyORB.Any.Get_Empty_Any (TypeCode.Internals.To_PolyORB_Object (TC)); end Get_Empty_Any; function Get_Empty_Any (TC : TypeCode.Object) return Any is begin return Get_Empty_Any (TypeCode.Internals.To_PolyORB_Object (TC)); end Get_Empty_Any; ----------------------------- -- Get_Empty_Any_Aggregate -- ----------------------------- function Get_Empty_Any_Aggregate (TC : TypeCode.Object) return Any is begin return Get_Empty_Any_Aggregate (TypeCode.Internals.To_PolyORB_Object (TC)); end Get_Empty_Any_Aggregate; ---------------------- -- Get_Unwound_Type -- ---------------------- function Get_Unwound_Type (The_Any : Any) return PolyORB.Any.TypeCode.Object_Ptr is begin return PolyORB.Any.Get_Unwound_Type (PolyORB.Any.Any (The_Any)); end Get_Unwound_Type; --------------------- -- Get_Wrapper_Any -- --------------------- function Get_Wrapper_Any (TC : TypeCode.Object; CC : access PolyORB.Any.Content'Class) return Any is Result : constant Any := Get_Empty_Any (TC); pragma Suppress (Accessibility_Check); begin PolyORB.Any.Set_Value (Get_Container (Result).all, PolyORB.Any.Content_Ptr (CC)); return Result; end Get_Wrapper_Any; -------------- -- Is_Empty -- -------------- function Is_Empty (Any_Value : CORBA.Any) return Boolean renames CORBA.Is_Empty; -------------------- -- Move_Any_Value -- -------------------- procedure Move_Any_Value (Dest : Any; Src : Any) renames CORBA.Move_Any_Value; -------------- -- Set_Type -- -------------- procedure Set_Type (The_Any : in out Any; The_Type : TypeCode.Object) is begin Set_Type (The_Any, TypeCode.Internals.To_PolyORB_Object (The_Type)); end Set_Type; end Internals; ------------------------ -- Initialize_Package -- ------------------------ procedure Initialize_Package; procedure Initialize_Package is begin PolyORB.CORBA_P.Exceptions.CORBA_Raise_From_Error := Raise_From_Error'Access; end Initialize_Package; package body TypeCode is ----------------- -- Get_Members -- ----------------- procedure Get_Members (From : Ada.Exceptions.Exception_Occurrence; To : out Bounds_Members) is use Ada.Exceptions; begin if Exception_Identity (From) /= InvalidName'Identity then Raise_Bad_Param (Default_Sys_Member); end if; To := Bounds_Members'(IDL_Exception_Members with null record); end Get_Members; procedure Get_Members (From : Ada.Exceptions.Exception_Occurrence; To : out BadKind_Members) is use Ada.Exceptions; begin if Exception_Identity (From) /= InvalidName'Identity then Raise_Bad_Param (Default_Sys_Member); end if; To := BadKind_Members'(IDL_Exception_Members with null record); end Get_Members; --------- -- "=" -- --------- function "=" (Left, Right : Object) return Boolean is begin return PolyORB.Any.TypeCode."=" (Internals.To_PolyORB_Object (Left), Internals.To_PolyORB_Object (Right)); end "="; ---------------- -- Equivalent -- ---------------- function Equivalent (Left, Right : Object) return Boolean renames "="; -------------------------- -- Get_Compact_TypeCode -- -------------------------- function Get_Compact_TypeCode (Self : Object) return Object is begin -- XXX not implemented raise Program_Error; return Get_Compact_TypeCode (Self); end Get_Compact_TypeCode; ---------- -- Kind -- ---------- function Kind (Self : Object) return TCKind is begin return PolyORB.Any.TypeCode.Kind (Internals.To_PolyORB_Object (Self)); end Kind; -------- -- Id -- -------- function Id (Self : Object) return RepositoryId is begin return CORBA.RepositoryId (PolyORB.Any.TypeCode.Id (Internals.To_PolyORB_Object (Self))); end Id; ---------- -- Name -- ---------- function Name (Self : Object) return Identifier is begin return CORBA.Identifier (PolyORB.Any.TypeCode.Name (Internals.To_PolyORB_Object (Self))); end Name; ------------------ -- Member_Count -- ------------------ function Member_Count (Self : Object) return Unsigned_Long is begin return CORBA.Unsigned_Long (PolyORB.Any.TypeCode.Member_Count (Internals.To_PolyORB_Object (Self))); end Member_Count; ----------------- -- Member_Name -- ----------------- function Member_Name (Self : Object; Index : Unsigned_Long) return Identifier is begin return CORBA.Identifier (PolyORB.Any.TypeCode.Member_Name (Internals.To_PolyORB_Object (Self), PolyORB.Types.Unsigned_Long (Index))); end Member_Name; ----------------- -- Member_Type -- ----------------- function Member_Type (Self : Object; Index : Unsigned_Long) return Object is begin return Internals.To_CORBA_Object (PolyORB.Any.TypeCode.Member_Type (Internals.To_PolyORB_Object (Self), PolyORB.Types.Unsigned_Long (Index))); end Member_Type; ------------------ -- Member_Label -- ------------------ function Member_Label (Self : Object; Index : Unsigned_Long) return Any is begin return CORBA.Any (PolyORB.Any.Any'(PolyORB.Any.TypeCode.Member_Label (Internals.To_PolyORB_Object (Self), PolyORB.Types.Unsigned_Long (Index)))); end Member_Label; ------------------------ -- Discriminator_Type -- ------------------------ function Discriminator_Type (Self : Object) return Object is begin return Internals.To_CORBA_Object (PolyORB.Any.TypeCode.Discriminator_Type (Internals.To_PolyORB_Object (Self))); end Discriminator_Type; ------------------- -- Default_Index -- ------------------- function Default_Index (Self : Object) return Long is begin return CORBA.Long (PolyORB.Any.TypeCode.Default_Index (Internals.To_PolyORB_Object (Self))); end Default_Index; ------------ -- Length -- ------------ function Length (Self : Object) return Unsigned_Long is begin return CORBA.Unsigned_Long (PolyORB.Any.TypeCode.Length (Internals.To_PolyORB_Object (Self))); end Length; ------------------ -- Content_Type -- ------------------ function Content_Type (Self : Object) return Object is begin return Internals.To_CORBA_Object (PolyORB.Any.TypeCode.Content_Type (Internals.To_PolyORB_Object (Self))); end Content_Type; ------------------ -- Fixed_Digits -- ------------------ function Fixed_Digits (Self : Object) return Unsigned_Short is begin return CORBA.Unsigned_Short (PolyORB.Any.TypeCode.Fixed_Digits (Internals.To_PolyORB_Object (Self))); end Fixed_Digits; ----------------- -- Fixed_Scale -- ----------------- function Fixed_Scale (Self : Object) return Short is begin return CORBA.Short (PolyORB.Any.TypeCode.Fixed_Scale (Internals.To_PolyORB_Object (Self))); end Fixed_Scale; ----------------------- -- Member_Visibility -- ----------------------- function Member_Visibility (Self : Object; Index : Unsigned_Long) return Visibility is begin return CORBA.Visibility (PolyORB.Any.TypeCode.Member_Visibility (Internals.To_PolyORB_Object (Self), PolyORB.Types.Unsigned_Long (Index))); end Member_Visibility; ------------------- -- Type_Modifier -- ------------------- function Type_Modifier (Self : Object) return ValueModifier is begin return PolyORB.Any.TypeCode.Type_Modifier (Internals.To_PolyORB_Object (Self)); end Type_Modifier; ------------------------ -- Concrete_Base_Type -- ------------------------ function Concrete_Base_Type (Self : Object) return Object is begin return Internals.To_CORBA_Object (PolyORB.Any.TypeCode.Concrete_Base_Type (Internals.To_PolyORB_Object (Self))); end Concrete_Base_Type; package body Internals is ------------------- -- Add_Parameter -- ------------------- procedure Add_Parameter (Self : in out Object; Param : Any) is begin PolyORB.Any.TypeCode.Add_Parameter (To_PolyORB_Object (Self), PolyORB.Any.Any (Param)); end Add_Parameter; -------------------- -- Build_Alias_TC -- -------------------- function Build_Alias_TC (Name, Id : CORBA.String; Parent : Object) return Object is Res : constant PolyORB.Any.TypeCode.Local_Ref := PolyORB.Any.TypeCode.TC_Alias; begin PolyORB.Any.TypeCode.Add_Parameter (Res, PolyORB.Any.Any (To_Any (Name))); PolyORB.Any.TypeCode.Add_Parameter (Res, PolyORB.Any.Any (To_Any (Id))); PolyORB.Any.TypeCode.Add_Parameter (Res, PolyORB.Any.Any (To_Any (Parent))); return To_CORBA_Object (Res); end Build_Alias_TC; ----------------------- -- Build_Sequence_TC -- ----------------------- function Build_Sequence_TC (Element_TC : Object; Max : Natural) return Object is begin return To_CORBA_Object ( PolyORB.Any.TypeCode.Build_Sequence_TC ( To_PolyORB_Object (Element_TC), Max)); end Build_Sequence_TC; --------------------- -- Build_String_TC -- --------------------- function Build_String_TC (Max : CORBA.Unsigned_Long) return Object is begin return To_CORBA_Object (PolyORB.Any.TypeCode.Build_String_TC (PolyORB.Types.Unsigned_Long (Max))); end Build_String_TC; ---------------------- -- Build_Wstring_TC -- ---------------------- function Build_Wstring_TC (Max : CORBA.Unsigned_Long) return Object is begin return To_CORBA_Object (PolyORB.Any.TypeCode.Build_Wstring_TC (PolyORB.Types.Unsigned_Long (Max))); end Build_Wstring_TC; -------------------------------- -- Disable_Reference_Counting -- -------------------------------- procedure Disable_Reference_Counting (Self : CORBA.TypeCode.Object) is begin PolyORB.Any.TypeCode.Disable_Reference_Counting (Object_Of (Self).all); end Disable_Reference_Counting; ------------ -- Is_Nil -- ------------ function Is_Nil (Self : CORBA.TypeCode.Object) return Boolean is begin return TypeCode.Is_Nil (Self); end Is_Nil; -------------- -- Set_Kind -- -------------- procedure Set_Kind (Self : out Object; Kind : TCKind) is Empty : PolyORB.Any.TypeCode.Any_Array (1 .. 0); P_Self : PolyORB.Any.TypeCode.Local_Ref; begin P_Self := PolyORB.Any.TypeCode.Build_Complex_TC (Kind, Empty); Self := To_CORBA_Object (P_Self); end Set_Kind; ----------------------- -- To_PolyORB_Object -- ----------------------- function To_PolyORB_Object (Self : CORBA.TypeCode.Object) return PolyORB.Any.TypeCode.Local_Ref is begin return PolyORB.Any.TypeCode.Local_Ref (Self); end To_PolyORB_Object; --------------------- -- To_CORBA_Object -- --------------------- function To_CORBA_Object (Self : PolyORB.Any.TypeCode.Local_Ref) return CORBA.TypeCode.Object is begin return To_Ref (PolyORB.Any.TypeCode.Object_Of (Self)); end To_CORBA_Object; ---------- -- Wrap -- ---------- function Wrap (X : not null access Object) return Content'Class is begin return PolyORB.Any.Wrap (PolyORB.Any.TypeCode.Local_Ref (X.all)'Unrestricted_Access); end Wrap; end Internals; end TypeCode; ------------- -- TC_Null -- ------------- function TC_Null return TypeCode.Object is begin return TypeCode.Internals.To_CORBA_Object (PolyORB.Any.TypeCode.TC_Null); end TC_Null; ------------- -- TC_Void -- ------------- function TC_Void return TypeCode.Object is begin return TypeCode.Internals.To_CORBA_Object (PolyORB.Any.TypeCode.TC_Void); end TC_Void; -------------- -- TC_Short -- -------------- function TC_Short return TypeCode.Object is begin return TypeCode.Internals.To_CORBA_Object (PolyORB.Any.TypeCode.TC_Short); end TC_Short; ------------- -- TC_Long -- ------------- function TC_Long return TypeCode.Object is begin return TypeCode.Internals.To_CORBA_Object (PolyORB.Any.TypeCode.TC_Long); end TC_Long; ------------------ -- TC_Long_Long -- ------------------ function TC_Long_Long return TypeCode.Object is begin return TypeCode.Internals.To_CORBA_Object (PolyORB.Any.TypeCode.TC_Long_Long); end TC_Long_Long; ----------------------- -- TC_Unsigned_Short -- ----------------------- function TC_Unsigned_Short return TypeCode.Object is begin return TypeCode.Internals.To_CORBA_Object (PolyORB.Any.TypeCode.TC_Unsigned_Short); end TC_Unsigned_Short; ---------------------- -- TC_Unsigned_Long -- ---------------------- function TC_Unsigned_Long return TypeCode.Object is begin return TypeCode.Internals.To_CORBA_Object (PolyORB.Any.TypeCode.TC_Unsigned_Long); end TC_Unsigned_Long; --------------------------- -- TC_Unsigned_Long_Long -- --------------------------- function TC_Unsigned_Long_Long return TypeCode.Object is begin return TypeCode.Internals.To_CORBA_Object (PolyORB.Any.TypeCode.TC_Unsigned_Long_Long); end TC_Unsigned_Long_Long; -------------- -- TC_Float -- -------------- function TC_Float return TypeCode.Object is begin return TypeCode.Internals.To_CORBA_Object (PolyORB.Any.TypeCode.TC_Float); end TC_Float; --------------- -- TC_Double -- --------------- function TC_Double return TypeCode.Object is begin return TypeCode.Internals.To_CORBA_Object (PolyORB.Any.TypeCode.TC_Double); end TC_Double; -------------------- -- TC_Long_Double -- -------------------- function TC_Long_Double return TypeCode.Object is begin return TypeCode.Internals.To_CORBA_Object (PolyORB.Any.TypeCode.TC_Long_Double); end TC_Long_Double; ---------------- -- TC_Boolean -- ---------------- function TC_Boolean return TypeCode.Object is begin return TypeCode.Internals.To_CORBA_Object (PolyORB.Any.TypeCode.TC_Boolean); end TC_Boolean; ------------- -- TC_Char -- ------------- function TC_Char return TypeCode.Object is begin return TypeCode.Internals.To_CORBA_Object (PolyORB.Any.TypeCode.TC_Char); end TC_Char; -------------- -- TC_Wchar -- -------------- function TC_Wchar return TypeCode.Object is begin return TypeCode.Internals.To_CORBA_Object (PolyORB.Any.TypeCode.TC_Wchar); end TC_Wchar; -------------- -- TC_Octet -- -------------- function TC_Octet return TypeCode.Object is begin return TypeCode.Internals.To_CORBA_Object (PolyORB.Any.TypeCode.TC_Octet); end TC_Octet; ------------ -- TC_Any -- ------------ function TC_Any return TypeCode.Object is begin return TypeCode.Internals.To_CORBA_Object (PolyORB.Any.TypeCode.TC_Any); end TC_Any; ----------------- -- TC_TypeCode -- ----------------- function TC_TypeCode return TypeCode.Object is begin return TypeCode.Internals.To_CORBA_Object (PolyORB.Any.TypeCode.TC_TypeCode); end TC_TypeCode; --------------- -- TC_String -- --------------- function TC_String return TypeCode.Object is begin return TypeCode.Internals.To_CORBA_Object (PolyORB.Any.TypeCode.TC_String); end TC_String; -------------------- -- TC_Wide_String -- -------------------- function TC_Wide_String return TypeCode.Object is begin return TypeCode.Internals.To_CORBA_Object (PolyORB.Any.TypeCode.TC_Wide_String); end TC_Wide_String; use PolyORB.Initialization; use PolyORB.Initialization.String_Lists; use PolyORB.Utils.Strings; begin Register_Module (Module_Info' (Name => +"corba", Conflicts => Empty, Depends => Empty, Provides => Empty, Implicit => False, Init => Initialize_Package'Access, Shutdown => null)); end CORBA; polyorb-2.8~20110207.orig/src/corba/portableserver-poamanager.ads0000644000175000017500000000764311750740340024131 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O R T A B L E S E R V E R . P O A M A N A G E R -- -- -- -- S p e c -- -- -- -- Copyright (C) 2001-2008, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the CORBA Specification, and adapted -- -- for use with PolyORB. The copyright notice above, and the license -- -- provisions that follow apply solely to the contents neither explicitly -- -- nor implicitly specified by the CORBA Specification defined by the OMG. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with Ada.Exceptions; with CORBA.Object; with PolyORB.Errors; with PolyORB.POA_Manager; package PortableServer.POAManager is type Local_Ref is new CORBA.Object.Ref with null record; type State is new PolyORB.POA_Manager.State; -- equivalent to -- type State is (HOLDING, ACTIVE, DISCARDING, INACTIVE); AdapterInactive : exception; procedure Activate (Self : Local_Ref); procedure Hold_Requests (Self : Local_Ref; Wait_For_Completion : CORBA.Boolean); procedure Discard_Requests (Self : Local_Ref; Wait_For_Completion : CORBA.Boolean); procedure Deactivate (Self : Local_Ref; Etherealize_Objects : CORBA.Boolean; Wait_For_Completion : CORBA.Boolean); function Get_State (Self : Local_Ref) return PortableServer.POAManager.State; -------------------------------------- -- POAManager Exceptions Management -- -------------------------------------- procedure Raise_From_Error (Error : in out PolyORB.Errors.Error_Container; Message : Standard.String); -- AdapterInactive type AdapterInactive_Members is new CORBA.IDL_Exception_Members with null record; procedure Get_Members (From : Ada.Exceptions.Exception_Occurrence; To : out AdapterInactive_Members); procedure Raise_AdapterInactive (Excp_Memb : AdapterInactive_Members; Message : Standard.String := ""); pragma No_Return (Raise_AdapterInactive); end PortableServer.POAManager; polyorb-2.8~20110207.orig/src/corba/corba-policy-helper.ads0000644000175000017500000000533211750740337022621 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- C O R B A . P O L I C Y . H E L P E R -- -- -- -- S p e c -- -- -- -- Copyright (C) 2005-2008, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the CORBA Specification, and adapted -- -- for use with PolyORB. The copyright notice above, and the license -- -- provisions that follow apply solely to the contents neither explicitly -- -- nor implicitly specified by the CORBA Specification defined by the OMG. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ package CORBA.Policy.Helper is function Unchecked_To_Ref (The_Ref : Object.Ref'Class) return Ref; function To_Ref (The_Ref : Object.Ref'Class) return Ref; function TC_Policy return TypeCode.Object; function From_Any (Item : Any) return Ref; function To_Any (Item : Ref) return Any; end CORBA.Policy.Helper; polyorb-2.8~20110207.orig/src/corba/corba-local.ads0000644000175000017500000000523511750740337021141 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- C O R B A . L O C A L -- -- -- -- S p e c -- -- -- -- Copyright (C) 2003-2008, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the CORBA Specification, and adapted -- -- for use with PolyORB. The copyright notice above, and the license -- -- provisions that follow apply solely to the contents neither explicitly -- -- nor implicitly specified by the CORBA Specification defined by the OMG. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with PolyORB.CORBA_P.Local; package CORBA.Local is type Object is abstract new PolyORB.CORBA_P.Local.Local_Object_Base with private; private type Object is abstract new PolyORB.CORBA_P.Local.Local_Object_Base with null record; end CORBA.Local; polyorb-2.8~20110207.orig/src/corba/portableserver-poa-goa.adb0000644000175000017500000002710711750740340023316 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O R T A B L E S E R V E R . P O A . G O A -- -- -- -- B o d y -- -- -- -- Copyright (C) 2003-2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with PolyORB.Binding_Data.Local; with PolyORB.Obj_Adapters.Group_Object_Adapter; with PolyORB.POA; with PolyORB.POA_Types; with PolyORB.POA_Manager; with PolyORB.References; with PolyORB.Servants.Group_Servants; with PolyORB.Smart_Pointers; with PolyORB.CORBA_P.Exceptions; with PolyORB.Errors; package body PortableServer.POA.GOA is use PolyORB.Errors; function To_POA (Self : Ref) return PolyORB.POA.Obj_Adapter_Access; -- Group management procedure Associate (Group : PolyORB.Servants.Servant_Access; Oid : PolyORB.Objects.Object_Id); -- Associate a group servant to an Oid procedure Disassociate (Group : PolyORB.Servants.Servant_Access; Oid : PolyORB.Objects.Object_Id); -- Remove an Oid from a group servant ------------ -- To_Ref -- ------------ function To_Ref (Self : CORBA.Object.Ref'Class) return Ref is Result : Ref; begin if CORBA.Object.Entity_Of (Self).all not in PolyORB.POA.Obj_Adapter'Class then CORBA.Raise_Bad_Param (CORBA.Default_Sys_Member); end if; Set (Result, CORBA.Object.Entity_Of (Self)); return Result; end To_Ref; ------------ -- To_POA -- ------------ function To_POA (Self : Ref) return PolyORB.POA.Obj_Adapter_Access is use PolyORB.Smart_Pointers; Res : constant PolyORB.Smart_Pointers.Entity_Ptr := Entity_Of (Self); begin if Res = null or else Res.all not in PolyORB.POA.Obj_Adapter'Class then CORBA.Raise_Bad_Param (CORBA.Default_Sys_Member); end if; declare use PolyORB.POA_Manager; The_POA : constant PolyORB.POA.Obj_Adapter_Access := PolyORB.POA.Obj_Adapter_Access (Res); begin if Is_Nil (The_POA.POA_Manager) then CORBA.Raise_Object_Not_Exist (CORBA.Default_Sys_Member); end if; return The_POA; end; end To_POA; ---------------------- -- Raise_From_Error -- ---------------------- procedure Raise_From_Error (Error : in out PolyORB.Errors.Error_Container); procedure Raise_From_Error (Error : in out PolyORB.Errors.Error_Container) is begin pragma Assert (Is_Error (Error)); case Error.Kind is when NotAGroupObject_E => declare Member : constant NotAGroupObject_Members := NotAGroupObject_Members' (CORBA.IDL_Exception_Members with null record); begin Free (Error.Member); Raise_NotAGroupObject (Member); end; when others => PolyORB.CORBA_P.Exceptions.Raise_From_Error (Error); end case; end Raise_From_Error; --------------- -- Associate -- --------------- procedure Associate (Group : PolyORB.Servants.Servant_Access; Oid : PolyORB.Objects.Object_Id) is use PolyORB.Binding_Data; use PolyORB.Binding_Data.Local; P : constant Profile_Access := new Local_Profile_Type; Ref : PolyORB.References.Ref; Error : Error_Container; begin Create_Local_Profile (Oid, Local_Profile_Type (P.all)); PolyORB.References.Create_Reference ((1 => P), "", Ref); PolyORB.Servants.Group_Servants.Associate (Group, Ref, Error); if Found (Error) then Raise_From_Error (Error); end if; end Associate; ------------------ -- Disassociate -- ------------------ procedure Disassociate (Group : PolyORB.Servants.Servant_Access; Oid : PolyORB.Objects.Object_Id) is use PolyORB.Servants.Group_Servants; It : PolyORB.Servants.Group_Servants.Iterator; Error : Error_Container; begin First (Group, It, Error); if Found (Error) then Raise_From_Error (Error); end if; while not Last (It) loop declare use PolyORB.References; use PolyORB.Binding_Data; use PolyORB.Objects; Pro : constant Profile_Array := Profiles_Of (Value (It)); begin for J in Pro'Range loop if Oid = Get_Object_Key (Pro (J).all).all then Disassociate (Group, Value (It), Error); if Found (Error) then Raise_From_Error (Error); end if; return; end if; end loop; end; Next (It); end loop; end Disassociate; ----------------------------- -- Create_Id_For_Reference -- ----------------------------- function Create_Id_For_Reference (Self : Ref; The_Ref : CORBA.Object.Ref) return PortableServer.ObjectId is use PolyORB.POA; use PolyORB.POA_Types; use PolyORB.Servants; use PolyORB.Servants.Group_Servants; use PolyORB.Obj_Adapters.Group_Object_Adapter; U_Oid : Unmarshalled_Oid; Error : Error_Container; GS : constant Servant_Access := Get_Group (CORBA.Object.Internals.To_PolyORB_Ref (The_Ref), True); begin if GS = null then declare Member : constant NotAGroupObject_Members := NotAGroupObject_Members' (CORBA.IDL_Exception_Members with null record); begin Raise_NotAGroupObject (Member); end; end if; Create_Object_Identification (To_POA (Self), null, U_Oid, Error); if Found (Error) then Raise_From_Error (Error); end if; declare Oid : constant PolyORB.Objects.Object_Id := U_Oid_To_Oid (U_Oid); begin Associate (GS, Oid); return PortableServer.Internals.To_PortableServer_ObjectId (Oid); end; end Create_Id_For_Reference; ---------------------- -- Reference_To_Ids -- ---------------------- function Reference_To_Ids (Self : Ref; The_Ref : CORBA.Object.Ref) return IDs is pragma Warnings (Off); pragma Unreferenced (Self); pragma Warnings (On); use Sequence_IDs; use PolyORB.Servants; use PolyORB.Servants.Group_Servants; use PolyORB.Obj_Adapters.Group_Object_Adapter; GS : constant Servant_Access := Get_Group (CORBA.Object.Internals.To_PolyORB_Ref (The_Ref)); begin if GS = null then declare Member : constant NotAGroupObject_Members := NotAGroupObject_Members' (CORBA.IDL_Exception_Members with null record); begin Raise_NotAGroupObject (Member); end; end if; declare It : PolyORB.Servants.Group_Servants.Iterator; List : Sequence := Null_Sequence; Error : Error_Container; begin First (GS, It, Error); if Found (Error) then Raise_From_Error (Error); end if; while not Last (It) loop declare use PolyORB.References; use PolyORB.Binding_Data; use PolyORB.Objects; Pro : constant Profile_Array := Profiles_Of (Value (It)); Oid : Object_Id_Access; begin for J in Pro'Range loop Oid := Get_Object_Key (Pro (J).all); if Oid /= null then Append (List, PortableServer.Internals. To_PortableServer_ObjectId (Oid.all)); exit; end if; end loop; end; Next (It); end loop; return IDs (List); end; end Reference_To_Ids; --------------------------------- -- Associate_Reference_With_Id -- --------------------------------- procedure Associate_Reference_With_Id (Self : Ref; Ref : CORBA.Object.Ref; Oid : PortableServer.ObjectId) is pragma Warnings (Off); pragma Unreferenced (Self); pragma Warnings (On); use PolyORB.Servants; use PolyORB.Servants.Group_Servants; use PolyORB.Obj_Adapters.Group_Object_Adapter; GS : constant Servant_Access := Get_Group (CORBA.Object.Internals.To_PolyORB_Ref (Ref), True); begin if GS = null then declare Member : constant NotAGroupObject_Members := NotAGroupObject_Members' (CORBA.IDL_Exception_Members with null record); begin Raise_NotAGroupObject (Member); end; end if; Associate (GS, PortableServer.Internals.To_PolyORB_Object_Id (Oid)); end Associate_Reference_With_Id; ------------------------------------ -- Disassociate_Reference_With_Id -- ------------------------------------ procedure Disassociate_Reference_With_Id (Self : Ref; Ref : CORBA.Object.Ref; Oid : PortableServer.ObjectId) is pragma Warnings (Off); pragma Unreferenced (Self); pragma Warnings (On); use PolyORB.Servants; use PolyORB.Servants.Group_Servants; use PolyORB.Obj_Adapters.Group_Object_Adapter; GS : constant Servant_Access := Get_Group (CORBA.Object.Internals.To_PolyORB_Ref (Ref)); begin if GS = null then declare Member : constant NotAGroupObject_Members := NotAGroupObject_Members' (CORBA.IDL_Exception_Members with null record); begin Raise_NotAGroupObject (Member); end; end if; Disassociate (GS, PortableServer.Internals.To_PolyORB_Object_Id (Oid)); end Disassociate_Reference_With_Id; end PortableServer.POA.GOA; polyorb-2.8~20110207.orig/src/corba/corba-orb.adb0000644000175000017500000005406411750740337020614 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- C O R B A . O R B -- -- -- -- B o d y -- -- -- -- Copyright (C) 2001-2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- The following subprograms still have to be implemented : -- -- Get_Default_Context -- -- Create_Fixed_Tc -- -- Create_Native_Tc -- -- Create_Recursive_Sequence_Tc -- with Ada.Command_Line; with Ada.Exceptions; with PolyORB.CORBA_P.Initial_References; with PolyORB.CORBA_P.Local; with PolyORB.CORBA_P.ORB_Init; with PolyORB.CORBA_P.Policy_Management; with PolyORB.Initialization; with PolyORB.Log; with PolyORB.ORB; with PolyORB.Parameters; with PolyORB.References.IOR; with PolyORB.Setup; with PolyORB.Utils.Strings.Lists; package body CORBA.ORB is use PolyORB.Log; use PolyORB.ORB; use PolyORB.Setup; package L is new PolyORB.Log.Facility_Log ("corba.orb"); procedure O (Message : Standard.String; Level : Log_Level := Debug) renames L.Output; function C (Level : Log_Level := Debug) return Boolean renames L.Enabled; procedure Register_Initial_Reference (Identifier : ObjectId; IOR : CORBA.String); -- Register an initial reference from an IOR given -- through the configuration subsystem. function ORB_Init_Initial_References (Value : Standard.String) return Boolean; -- Initialisation routine for the InitRef suffix --------------------------------- -- ORB_Init_Initial_References -- --------------------------------- function ORB_Init_Initial_References (Value : Standard.String) return Boolean is Pos : constant Integer := PolyORB.Utils.Find (Value, Value'First, '='); begin if Pos = Value'Last + 1 then Raise_Bad_Param (Default_Sys_Member); else pragma Debug (C, O ("Registering " & Value (Value'First .. Pos - 1) & " with " & Value (Pos + 1 .. Value'Last))); Register_Initial_Reference (To_CORBA_String (Value (Value'First .. Pos - 1)), To_CORBA_String (Value (Pos + 1 .. Value'Last))); return True; end if; end ORB_Init_Initial_References; ---------------------------- -- Command_Line_Arguments -- ---------------------------- function Command_Line_Arguments return Arg_List is use Ada.Command_Line; Result : Arg_List; begin for J in 1 .. Argument_Count loop Append (Result, CORBA.To_CORBA_String (Argument (J))); end loop; return Result; end Command_Line_Arguments; ---------- -- Init -- ---------- procedure Init (ORB_Identifier : ORBid; Argv : in out Arg_List) is pragma Unreferenced (ORB_Identifier); use PolyORB.CORBA_P.ORB_Init; use PolyORB.Initialization; Pos : Natural := 1; ORB_Prefix : constant Standard.String := "-ORB"; Not_Initialized_One : Boolean := False; begin -- Implementation Note: We first run Initialize_World to allow packages -- to register helper routines to parse specific command line arguments. if not Is_Initialized then Initialize_World; end if; pragma Debug (C, O ("Init: enter")); while Pos <= Length (Argv) loop declare Suffix : constant Standard.String := To_Standard_String (Get_Element (Argv, Pos)); Initialized : Boolean := False; Space_Index : Positive; begin pragma Debug (C, O ("Processing " & Suffix)); if PolyORB.Utils.Has_Prefix (Suffix, ORB_Prefix) then pragma Debug (C, O ("Possible suffix is " & Suffix (Suffix'First + ORB_Prefix'Length .. Suffix'Last))); Space_Index := PolyORB.Utils.Find_Whitespace (Suffix, Suffix'First); -- Test if parameter is -ORB if Space_Index <= Suffix'Last then Initialized := PolyORB.CORBA_P.ORB_Init.Initialize (Suffix (Suffix'First + ORB_Prefix'Length .. Suffix'Last)); if Initialized then Delete (Argv, Pos, Pos); end if; -- Test if parameter is -ORB and next argument is -- a . elsif Pos < Length (Argv) then declare Value : constant Standard.String := To_Standard_String (Get_Element (Argv, Pos + 1)); begin pragma Debug (C, O ("Try to initialize (" & Suffix (Suffix'First + ORB_Prefix'Length .. Suffix'Last) & "," & Value & ")")); Initialized := PolyORB.CORBA_P.ORB_Init.Initialize (Suffix (Suffix'First + ORB_Prefix'Length .. Suffix'Last), Value); if Initialized then Delete (Argv, Pos, Pos + 1); end if; end; end if; -- Test if parameter is -ORB if not Initialized then Initialized := PolyORB.CORBA_P.ORB_Init.Initialize (Suffix (Suffix'First + ORB_Prefix'Length .. Suffix'Last)); if Initialized then Delete (Argv, Pos, Pos); end if; end if; if not Initialized then Not_Initialized_One := True; Delete (Argv, Pos, Pos); end if; else Pos := Pos + 1; end if; end; end loop; if Not_Initialized_One then Raise_Bad_Param (Default_Sys_Member); end if; pragma Debug (C, O ("Init: leave")); end Init; --------------------- -- Create_Alias_Tc -- --------------------- function Create_Alias_Tc (Id : CORBA.RepositoryId; Name : CORBA.Identifier; Original_Type : CORBA.TypeCode.Object) return CORBA.TypeCode.Object is begin return CORBA.TypeCode.Internals.Build_Alias_TC (Id => CORBA.String (Id), Name => CORBA.String (Name), Parent => Original_Type); end Create_Alias_Tc; --------------------- -- Create_Array_Tc -- --------------------- function Create_Array_Tc (Length : CORBA.Unsigned_Long; Element_Type : CORBA.TypeCode.Object) return CORBA.TypeCode.Object is begin return TypeCode.Internals.To_CORBA_Object (PolyORB.Any.TypeCode.Build_Complex_TC (Tk_Array, (PolyORB.Any.To_Any (PolyORB.Types.Unsigned_Long (Length)), PolyORB.Any.Any (To_Any (Element_Type))))); end Create_Array_Tc; --------------------- -- Create_Fixed_Tc -- --------------------- function Create_Fixed_Tc (IDL_Digits : CORBA.Unsigned_Short; scale : CORBA.Short) return CORBA.TypeCode.Object is begin return TypeCode.Internals.To_CORBA_Object (PolyORB.Any.TypeCode.Build_Complex_TC (Tk_Fixed, (PolyORB.Any.To_Any (PolyORB.Types.Unsigned_Short (IDL_Digits)), PolyORB.Any.To_Any (PolyORB.Types.Short (scale))))); end Create_Fixed_Tc; ------------------------- -- Create_Interface_Tc -- ------------------------- function Create_Interface_Tc (Id : CORBA.RepositoryId; Name : CORBA.Identifier) return CORBA.TypeCode.Object is begin return TypeCode.Internals.To_CORBA_Object (PolyORB.Any.TypeCode.Build_Complex_TC (Tk_Objref, (PolyORB.Any.To_Any (PolyORB.Types.String (Name)), PolyORB.Any.To_Any (PolyORB.Types.String (Id))))); end Create_Interface_Tc; ----------------- -- Create_List -- ----------------- procedure Create_List (Count : CORBA.Long; New_List : out CORBA.NVList.Ref) is pragma Unreferenced (Count); Result : CORBA.NVList.Ref; begin New_List := Result; end Create_List; procedure Create_List (New_List : out CORBA.ExceptionList.Ref) renames CORBA.ExceptionList.Create_List; ---------------------- -- Create_Native_Tc -- ---------------------- function Create_Native_Tc (Id : CORBA.RepositoryId; Name : CORBA.Identifier) return CORBA.TypeCode.Object is begin return TypeCode.Internals.To_CORBA_Object (PolyORB.Any.TypeCode.Build_Complex_TC (Tk_Native, (PolyORB.Any.To_Any (PolyORB.Types.String (Name)), PolyORB.Any.To_Any (PolyORB.Types.String (Id))))); end Create_Native_Tc; ---------------------------------- -- Create_Recursive_Sequence_Tc -- ---------------------------------- function Create_Recursive_Sequence_Tc (Bound : CORBA.Unsigned_Long; Offset : CORBA.Unsigned_Long) return CORBA.TypeCode.Object is begin raise Program_Error; pragma Warnings (Off); return Create_Recursive_Sequence_Tc (Bound, Offset); -- "Possible infinite recursion". pragma Warnings (On); end Create_Recursive_Sequence_Tc; ------------------------ -- Create_Sequence_Tc -- ------------------------ function Create_Sequence_Tc (Bound : CORBA.Unsigned_Long; Element_Type : CORBA.TypeCode.Object) return CORBA.TypeCode.Object is begin return TypeCode.Internals.To_CORBA_Object (PolyORB.Any.TypeCode.Build_Complex_TC (Tk_Sequence, (PolyORB.Any.To_Any (PolyORB.Types.Unsigned_Long (Bound)), PolyORB.Any.Any (To_Any (Element_Type))))); end Create_Sequence_Tc; ---------------------- -- Create_String_Tc -- ---------------------- function Create_String_Tc (Bound : CORBA.Unsigned_Long) return CORBA.TypeCode.Object is begin return TypeCode.Internals.To_CORBA_Object (PolyORB.Any.TypeCode.Build_String_TC (PolyORB.Types.Unsigned_Long (Bound))); end Create_String_Tc; ----------------------- -- Create_Wstring_Tc -- ----------------------- function Create_Wstring_Tc (Bound : CORBA.Unsigned_Long) return CORBA.TypeCode.Object is begin return TypeCode.Internals.To_CORBA_Object (PolyORB.Any.TypeCode.Build_Wstring_TC (PolyORB.Types.Unsigned_Long (Bound))); end Create_Wstring_Tc; ------------------------- -- Get_Default_Context -- ------------------------- function Get_Default_Context return CORBA.Context.Ref is R : CORBA.Context.Ref; begin raise Program_Error; -- Not implemented return R; end Get_Default_Context; ----------------------------- -- Get_Service_Information -- ----------------------------- procedure Get_Service_Information (Service_Type : CORBA.ServiceType; Service_Information : out ServiceInformation; Returns : out CORBA.Boolean) is pragma Unreferenced (Service_Type); Null_Service_Information : constant ServiceInformation := ServiceInformation'(IDL_SEQUENCE_ServiceOption.Null_Sequence, IDL_SEQUENCE_ServiceDetail.Null_Sequence); begin -- Service information is not (yet) supported, we return false -- for all values of Service_Type. Service_Information := Null_Service_Information; Returns := False; end Get_Service_Information; --------------------------- -- List_Initial_Services -- --------------------------- function List_Initial_Services return ObjectIdList is use PolyORB.CORBA_P.Initial_References; use PolyORB.Utils.Strings.Lists; Services_List : List := List_Initial_Services; Result : ObjectIdList; It : Iterator := First (Services_List); begin pragma Debug (C, O ("List_Initial_Services: enter")); while not Last (It) loop pragma Debug (C, O ("Service name: " & Value (It).all)); IDL_SEQUENCE_ObjectId.Append (IDL_SEQUENCE_ObjectId.Sequence (Result), To_CORBA_String (Value (It).all)); Next (It); end loop; Deallocate (Services_List); pragma Debug (C, O ("List_Initial_Services: end")); return Result; end List_Initial_Services; ------------------ -- Perform_Work -- ------------------ procedure Perform_Work is begin Perform_Work (The_ORB); end Perform_Work; -------------------------------- -- Register_Initial_Reference -- -------------------------------- procedure Register_Initial_Reference (Identifier : ObjectId; Ref : CORBA.Object.Ref) is use CORBA.Object; use PolyORB.CORBA_P.Initial_References; Id : constant Standard.String := To_Standard_String (Identifier); begin pragma Debug (C, O ("Register_Initial_Reference: " & Id)); -- If string id is empty or id is already registered, -- then raise InvalidName. if Id = "" or else not Is_Nil (Resolve_Initial_References (Id)) then Raise_InvalidName (InvalidName_Members'(null record)); end if; -- If Ref is null, then raise Bad_Param with minor code 27 if Is_Nil (Ref) then Raise_Bad_Param ( System_Exception_Members'(Minor => 27, Completed => Completed_No)); end if; Register_Initial_Reference (Id, Ref); end Register_Initial_Reference; procedure Register_Initial_Reference (Identifier : ObjectId; IOR : CORBA.String) is Ref : CORBA.Object.Ref; begin CORBA.ORB.String_To_Object (IOR, Ref); Register_Initial_Reference (Identifier, Ref); end Register_Initial_Reference; -------------------------------- -- Resolve_Initial_References -- -------------------------------- function Resolve_Initial_References (Identifier : ObjectId) return CORBA.Object.Ref is use CORBA.Object; use PolyORB.CORBA_P.Initial_References; Id : constant Standard.String := To_Standard_String (Identifier); Result : constant CORBA.Object.Ref := Resolve_Initial_References (Id); begin pragma Debug (C, O ("Resolve_Initial_References: " & Id)); if Is_Nil (Result) then Raise_InvalidName (InvalidName_Members'(null record)); end if; return Result; end Resolve_Initial_References; --------- -- Run -- --------- procedure Run is begin PolyORB.ORB.Run (The_ORB, May_Exit => False); end Run; -------------- -- Shutdown -- -------------- procedure Shutdown (Wait_For_Completion : Boolean) is begin Shutdown (The_ORB, Wait_For_Completion); end Shutdown; ---------------------- -- Object_To_String -- ---------------------- function Object_To_String (Obj : CORBA.Object.Ref'Class) return CORBA.String is use PolyORB.References.IOR; begin if CORBA.Object.Is_Nil (Obj) then CORBA.Raise_Inv_Objref (Default_Sys_Member); end if; if PolyORB.CORBA_P.Local.Is_Local (Obj) then Raise_Marshal (Marshal_Members'(Minor => 4, Completed => Completed_No)); end if; return To_CORBA_String (Object_To_String (CORBA.Object.Internals.To_PolyORB_Ref (CORBA.Object.Ref (Obj)))); end Object_To_String; ---------------------- -- String_To_Object -- ---------------------- procedure String_To_Object (From : CORBA.String; To : in out CORBA.Object.Ref'Class) is begin declare use PolyORB.References; My_Ref : Ref; begin String_To_Object (To_Standard_String (From), My_Ref); CORBA.Object.Set (To, Entity_Of (My_Ref)); end; exception when others => CORBA.Raise_Bad_Param (CORBA.Default_Sys_Member); end String_To_Object; ------------------ -- Work_Pending -- ------------------ function Work_Pending return Boolean is begin return Work_Pending (The_ORB); end Work_Pending; ---------------- -- Initialize -- ---------------- procedure Initialize (ORB_Name : Standard.String) is pragma Warnings (Off); pragma Unreferenced (ORB_Name); pragma Warnings (On); use PolyORB.Initialization; begin if not Is_Initialized then Initialize_World; end if; end Initialize; ------------------- -- Create_Policy -- ------------------- function Create_Policy (The_Type : PolicyType; Val : Any) return CORBA.Policy.Ref is use PolyORB.CORBA_P.Policy_Management; Factory : Policy_Factory; begin if not Is_Registered (The_Type) then Raise_PolicyError ((Reason => BAD_POLICY)); end if; Factory := Get_Policy_Factory (The_Type); if Factory = null then Raise_PolicyError ((Reason => UNSUPPORTED_POLICY)); end if; return Factory (The_Type, Val); end Create_Policy; ----------------- -- Get_Members -- ----------------- procedure Get_Members (From : Ada.Exceptions.Exception_Occurrence; To : out InvalidName_Members) is use Ada.Exceptions; begin if Exception_Identity (From) /= InvalidName'Identity then CORBA.Raise_Bad_Param (CORBA.Default_Sys_Member); end if; To := InvalidName_Members' (CORBA.IDL_Exception_Members with null record); end Get_Members; ----------------------- -- Raise_InvalidName -- ----------------------- procedure Raise_InvalidName (Excp_Memb : InvalidName_Members) is pragma Unreferenced (Excp_Memb); begin raise InvalidName; end Raise_InvalidName; ---------------- -- Initialize -- ---------------- procedure Initialize; procedure Initialize is Naming_IOR : constant Standard.String := PolyORB.Parameters.Get_Conf (Section => "corba", Key => "name_service", Default => ""); InterfaceRepository_IOR : constant Standard.String := PolyORB.Parameters.Get_Conf (Section => "corba", Key => "ir_service", Default => ""); PolicyDomainManager_IOR : constant Standard.String := PolyORB.Parameters.Get_Conf (Section => "corba", Key => "policy_domain_manager", Default => ""); ReplicationManager_IOR : constant Standard.String := PolyORB.Parameters.Get_Conf (Section => "corba", Key => "replication_manager", Default => ""); begin -- Register initial reference for NamingService if Naming_IOR /= "" then -- Standard CORBA3 name Register_Initial_Reference (To_CORBA_String ("NameService"), To_CORBA_String (Naming_IOR)); -- Legacy compatibility synonym Register_Initial_Reference (To_CORBA_String ("NamingService"), To_CORBA_String (Naming_IOR)); end if; -- Register initial reference for Interface Repository if InterfaceRepository_IOR /= "" then Register_Initial_Reference (To_CORBA_String ("InterfaceRepository"), To_CORBA_String (InterfaceRepository_IOR)); end if; -- Register initial reference for Policy Domain Manager if PolicyDomainManager_IOR /= "" then Register_Initial_Reference (To_CORBA_String ("PolyORBPolicyDomainManager"), To_CORBA_String (PolicyDomainManager_IOR)); end if; -- Register initial reference for Replication Manager if ReplicationManager_IOR /= "" then Register_Initial_Reference (To_CORBA_String ("ReplicationManager"), To_CORBA_String (ReplicationManager_IOR)); end if; PolyORB.CORBA_P.ORB_Init.Register ("InitRef", ORB_Init_Initial_References'Access); end Initialize; use PolyORB.Initialization; use PolyORB.Utils.Strings; use PolyORB.Utils.Strings.Lists; begin Register_Module (Module_Info' (Name => +"corba.orb", Conflicts => Empty, Depends => +"orb" & "corba.initial_references", Provides => Empty, Implicit => False, Init => Initialize'Access, Shutdown => null)); end CORBA.ORB; polyorb-2.8~20110207.orig/src/corba/corba-sequences-bounded.ads0000644000175000017500000000477611750740340023463 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- C O R B A . S E Q U E N C E S . B O U N D E D -- -- -- -- S p e c -- -- -- -- Copyright (C) 2003-2008, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the CORBA Specification, and adapted -- -- for use with PolyORB. The copyright notice above, and the license -- -- provisions that follow apply solely to the contents neither explicitly -- -- nor implicitly specified by the CORBA Specification defined by the OMG. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with PolyORB.Sequences.Bounded; generic package CORBA.Sequences.Bounded renames PolyORB.Sequences.Bounded; polyorb-2.8~20110207.orig/src/corba/portableserver-poamanager.adb0000644000175000017500000001647011750740340024106 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O R T A B L E S E R V E R . P O A M A N A G E R -- -- -- -- B o d y -- -- -- -- Copyright (C) 2001-2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with PolyORB.Initialization; with PolyORB.Smart_Pointers; with PolyORB.Utils.Strings; with PolyORB.CORBA_P.Exceptions; package body PortableServer.POAManager is use PolyORB.Errors; use PolyORB.POA_Manager; function To_POA_Manager (Self : Local_Ref) return POAManager_Access; -- Convert a Local_Ref to the designated POAManager_Access. Check the -- reference points to a non null POAM, the type of the referenced -- object (else BAD_PARAM is raised). Check that the POAM is -- active (else AdapterInactive is raised). -------------------- -- To_POA_Manager -- -------------------- function To_POA_Manager (Self : Local_Ref) return POAManager_Access is Res : constant PolyORB.Smart_Pointers.Entity_Ptr := Entity_Of (Self); begin if Is_Nil (Self) or else Res.all not in PolyORB.POA_Manager.POAManager'Class then CORBA.Raise_Bad_Param (CORBA.Default_Sys_Member); end if; return POAManager_Access (Res); end To_POA_Manager; -------------- -- Activate -- -------------- procedure Activate (Self : Local_Ref) is POA_Manager : constant POAManager_Access := To_POA_Manager (Self); Error : Error_Container; begin Activate (POA_Manager, Error); if Found (Error) then PolyORB.CORBA_P.Exceptions.Raise_From_Error (Error); end if; end Activate; ------------------- -- Hold_Requests -- ------------------- procedure Hold_Requests (Self : Local_Ref; Wait_For_Completion : CORBA.Boolean) is POA_Manager : constant POAManager_Access := To_POA_Manager (Self); Error : Error_Container; begin Hold_Requests (POA_Manager, Wait_For_Completion, Error); if Found (Error) then PolyORB.CORBA_P.Exceptions.Raise_From_Error (Error); end if; end Hold_Requests; ---------------------- -- Discard_Requests -- ---------------------- procedure Discard_Requests (Self : Local_Ref; Wait_For_Completion : CORBA.Boolean) is POA_Manager : constant POAManager_Access := To_POA_Manager (Self); Error : Error_Container; begin Discard_Requests (POA_Manager, Wait_For_Completion, Error); if Found (Error) then PolyORB.CORBA_P.Exceptions.Raise_From_Error (Error); end if; end Discard_Requests; ---------------- -- Deactivate -- ---------------- procedure Deactivate (Self : Local_Ref; Etherealize_Objects : CORBA.Boolean; Wait_For_Completion : CORBA.Boolean) is POA_Manager : constant POAManager_Access := To_POA_Manager (Self); begin Deactivate (POA_Manager, Etherealize_Objects, Wait_For_Completion); end Deactivate; --------------- -- Get_State -- --------------- function Get_State (Self : Local_Ref) return State is POA_Manager : constant POAManager_Access := To_POA_Manager (Self); State : constant PolyORB.POA_Manager.State := Get_State (POA_Manager.all); begin return PortableServer.POAManager.State (State); end Get_State; ---------------------- -- Raise_From_Error -- ---------------------- procedure Raise_From_Error (Error : in out PolyORB.Errors.Error_Container; Message : Standard.String) is begin pragma Assert (Is_Error (Error)); case Error.Kind is when AdapterInactive_E => declare Member : constant AdapterInactive_Members := AdapterInactive_Members'(CORBA.IDL_Exception_Members with null record); begin Free (Error.Member); Raise_AdapterInactive (Member, Message); end; when others => raise Program_Error; end case; end Raise_From_Error; ----------------- -- Get_Members -- ----------------- procedure Get_Members (From : Ada.Exceptions.Exception_Occurrence; To : out AdapterInactive_Members) is use Ada.Exceptions; begin if Exception_Identity (From) /= AdapterInactive'Identity then CORBA.Raise_Bad_Param (CORBA.Default_Sys_Member); end if; To := AdapterInactive_Members' (CORBA.IDL_Exception_Members with null record); end Get_Members; --------------------------- -- Raise_AdapterInactive -- --------------------------- procedure Raise_AdapterInactive (Excp_Memb : AdapterInactive_Members; Message : Standard.String := "") is pragma Unreferenced (Excp_Memb); begin Ada.Exceptions.Raise_Exception (AdapterInactive'Identity, Message); end Raise_AdapterInactive; ---------------- -- Initialize -- ---------------- procedure Initialize; procedure Initialize is begin PolyORB.CORBA_P.Exceptions.POAManager_Raise_From_Error := Raise_From_Error'Access; end Initialize; use PolyORB.Initialization; use PolyORB.Initialization.String_Lists; use PolyORB.Utils.Strings; begin Register_Module (Module_Info' (Name => +"portableserver.poamanager", Conflicts => Empty, Depends => Empty, Provides => Empty, Implicit => False, Init => Initialize'Access, Shutdown => null)); end PortableServer.POAManager; polyorb-2.8~20110207.orig/src/corba/portableserver-servantretentionpolicy.ads0000644000175000017500000000544411750740340026646 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- PORTABLESERVER.SERVANTRETENTIONPOLICY -- -- -- -- S p e c -- -- -- -- Copyright (C) 2001-2008, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the CORBA Specification, and adapted -- -- for use with PolyORB. The copyright notice above, and the license -- -- provisions that follow apply solely to the contents neither explicitly -- -- nor implicitly specified by the CORBA Specification defined by the OMG. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with CORBA.Policy; package PortableServer.ServantRetentionPolicy is type Ref is new CORBA.Policy.Ref with private; function To_Ref (The_Ref : CORBA.Object.Ref'Class) return Ref; function Get_Value (Self : Ref) return PortableServer.ServantRetentionPolicyValue; private type Ref is new CORBA.Policy.Ref with null record; end PortableServer.ServantRetentionPolicy; polyorb-2.8~20110207.orig/src/corba/portableserver-poa-helper.adb0000644000175000017500000006334311750740340024031 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O R T A B L E S E R V E R . P O A . H E L P E R -- -- -- -- B o d y -- -- -- -- Copyright (C) 2004-2008, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ ------------------------------------------------- -- This file has been generated automatically -- by IDLAC version 2.3.0w. -- -- Do NOT hand-modify this file, as your -- changes will be lost when you re-run the -- IDL to Ada compiler. ------------------------------------------------- pragma Style_Checks ("NM32766"); with PolyORB.Utils.Strings; with PolyORB.Initialization; pragma Elaborate_All (PolyORB.Initialization); with PolyORB.Exceptions; with PolyORB.Std; with PolyORB.Any; package body PortableServer.POA.Helper is function Unchecked_To_Local_Ref (The_Ref : CORBA.Object.Ref'Class) return PortableServer.POA.Local_Ref is Result : PortableServer.POA.Local_Ref; begin Set (Result, CORBA.Object.Object_Of (The_Ref)); return Result; end Unchecked_To_Local_Ref; function To_Local_Ref (The_Ref : CORBA.Object.Ref'Class) return PortableServer.POA.Local_Ref is begin -- XXX This implementation should use the canonical code, as -- generated by idlac. This would require CORBA.Object.Is_A to be -- modified to recognize the designated built-in entity type as valid -- for this logical type. -- if CORBA.Object.Is_Nil (The_Ref) -- or else CORBA.Object.Is_A (The_Ref, Repository_Id) -- then -- return Unchecked_To_Ref (The_Ref); -- end if; -- -- CORBA.Raise_Bad_Param (CORBA.Default_Sys_Member); if CORBA.Object.Entity_Of (The_Ref).all not in PolyORB.POA.Obj_Adapter'Class then CORBA.Raise_Bad_Param (CORBA.Default_Sys_Member); end if; return Unchecked_To_Local_Ref (The_Ref); end To_Local_Ref; function From_Any (Item : CORBA.Any) return PortableServer.POA.AdapterAlreadyExists_Members is Result : AdapterAlreadyExists_Members; pragma Warnings (Off); pragma Unreferenced (Item); pragma Warnings (On); begin return Result; end From_Any; function To_Any (Item : PortableServer.POA.AdapterAlreadyExists_Members) return CORBA.Any is Result : constant CORBA.Any := CORBA.Internals.Get_Empty_Any_Aggregate (TC_AdapterAlreadyExists); pragma Warnings (Off); pragma Unreferenced (Item); pragma Warnings (On); begin return Result; end To_Any; procedure Raise_AdapterAlreadyExists_From_Any (Item : PolyORB.Any.Any; Message : PolyORB.Std.String); pragma No_Return (Raise_AdapterAlreadyExists_From_Any); procedure Raise_AdapterAlreadyExists_From_Any (Item : PolyORB.Any.Any; Message : PolyORB.Std.String) is Members : constant AdapterAlreadyExists_Members := From_Any (CORBA.Any (Item)); begin PolyORB.Exceptions.User_Raise_Exception (AdapterAlreadyExists'Identity, Members, Message); end Raise_AdapterAlreadyExists_From_Any; procedure Raise_AdapterAlreadyExists (Members : AdapterAlreadyExists_Members) is begin PolyORB.Exceptions.User_Raise_Exception (AdapterAlreadyExists'Identity, Members); end Raise_AdapterAlreadyExists; function From_Any (Item : CORBA.Any) return PortableServer.POA.AdapterNonExistent_Members is Result : AdapterNonExistent_Members; pragma Warnings (Off); pragma Unreferenced (Item); pragma Warnings (On); begin return Result; end From_Any; function To_Any (Item : PortableServer.POA.AdapterNonExistent_Members) return CORBA.Any is Result : constant CORBA.Any := CORBA.Internals.Get_Empty_Any_Aggregate (TC_AdapterNonExistent); pragma Warnings (Off); pragma Unreferenced (Item); pragma Warnings (On); begin return Result; end To_Any; procedure Raise_AdapterNonExistent_From_Any (Item : PolyORB.Any.Any; Message : PolyORB.Std.String); pragma No_Return (Raise_AdapterNonExistent_From_Any); procedure Raise_AdapterNonExistent_From_Any (Item : PolyORB.Any.Any; Message : PolyORB.Std.String) is Members : constant AdapterNonExistent_Members := From_Any (CORBA.Any (Item)); begin PolyORB.Exceptions.User_Raise_Exception (AdapterNonExistent'Identity, Members, Message); end Raise_AdapterNonExistent_From_Any; procedure Raise_AdapterNonExistent (Members : AdapterNonExistent_Members) is begin PolyORB.Exceptions.User_Raise_Exception (AdapterNonExistent'Identity, Members); end Raise_AdapterNonExistent; function From_Any (Item : CORBA.Any) return PortableServer.POA.InvalidPolicy_Members is Index : CORBA.Any; Result_index : CORBA.Unsigned_Short; begin Index := CORBA.Internals.Get_Aggregate_Element (Item, CORBA.TC_Unsigned_Short, CORBA.Unsigned_Long ( 0)); Result_index := CORBA.From_Any (Index); return (index => Result_index); end From_Any; function To_Any (Item : PortableServer.POA.InvalidPolicy_Members) return CORBA.Any is Result : CORBA.Any := CORBA.Internals.Get_Empty_Any_Aggregate (TC_InvalidPolicy); begin CORBA.Internals.Add_Aggregate_Element (Result, CORBA.To_Any (Item.index)); return Result; end To_Any; procedure Raise_InvalidPolicy_From_Any (Item : PolyORB.Any.Any; Message : PolyORB.Std.String); pragma No_Return (Raise_InvalidPolicy_From_Any); procedure Raise_InvalidPolicy_From_Any (Item : PolyORB.Any.Any; Message : PolyORB.Std.String) is Members : constant InvalidPolicy_Members := From_Any (CORBA.Any (Item)); begin PolyORB.Exceptions.User_Raise_Exception (InvalidPolicy'Identity, Members, Message); end Raise_InvalidPolicy_From_Any; procedure Raise_InvalidPolicy (Members : InvalidPolicy_Members) is begin PolyORB.Exceptions.User_Raise_Exception (InvalidPolicy'Identity, Members); end Raise_InvalidPolicy; function From_Any (Item : CORBA.Any) return PortableServer.POA.NoServant_Members is Result : NoServant_Members; pragma Warnings (Off); pragma Unreferenced (Item); pragma Warnings (On); begin return Result; end From_Any; function To_Any (Item : PortableServer.POA.NoServant_Members) return CORBA.Any is Result : constant CORBA.Any := CORBA.Internals.Get_Empty_Any_Aggregate (TC_NoServant); pragma Warnings (Off); pragma Unreferenced (Item); pragma Warnings (On); begin return Result; end To_Any; procedure Raise_NoServant_From_Any (Item : PolyORB.Any.Any; Message : PolyORB.Std.String); pragma No_Return (Raise_NoServant_From_Any); procedure Raise_NoServant_From_Any (Item : PolyORB.Any.Any; Message : PolyORB.Std.String) is Members : constant NoServant_Members := From_Any (CORBA.Any (Item)); begin PolyORB.Exceptions.User_Raise_Exception (NoServant'Identity, Members, Message); end Raise_NoServant_From_Any; procedure Raise_NoServant (Members : NoServant_Members) is begin PolyORB.Exceptions.User_Raise_Exception (NoServant'Identity, Members); end Raise_NoServant; function From_Any (Item : CORBA.Any) return PortableServer.POA.ObjectAlreadyActive_Members is Result : ObjectAlreadyActive_Members; pragma Warnings (Off); pragma Unreferenced (Item); pragma Warnings (On); begin return Result; end From_Any; function To_Any (Item : PortableServer.POA.ObjectAlreadyActive_Members) return CORBA.Any is Result : constant CORBA.Any := CORBA.Internals.Get_Empty_Any_Aggregate (TC_ObjectAlreadyActive); pragma Warnings (Off); pragma Unreferenced (Item); pragma Warnings (On); begin return Result; end To_Any; procedure Raise_ObjectAlreadyActive_From_Any (Item : PolyORB.Any.Any; Message : PolyORB.Std.String); pragma No_Return (Raise_ObjectAlreadyActive_From_Any); procedure Raise_ObjectAlreadyActive_From_Any (Item : PolyORB.Any.Any; Message : PolyORB.Std.String) is Members : constant ObjectAlreadyActive_Members := From_Any (CORBA.Any (Item)); begin PolyORB.Exceptions.User_Raise_Exception (ObjectAlreadyActive'Identity, Members, Message); end Raise_ObjectAlreadyActive_From_Any; procedure Raise_ObjectAlreadyActive (Members : in ObjectAlreadyActive_Members) is begin PolyORB.Exceptions.User_Raise_Exception (ObjectAlreadyActive'Identity, Members); end Raise_ObjectAlreadyActive; function From_Any (Item : CORBA.Any) return PortableServer.POA.ObjectNotActive_Members is Result : ObjectNotActive_Members; pragma Warnings (Off); pragma Unreferenced (Item); pragma Warnings (On); begin return Result; end From_Any; function To_Any (Item : PortableServer.POA.ObjectNotActive_Members) return CORBA.Any is Result : constant CORBA.Any := CORBA.Internals.Get_Empty_Any_Aggregate (TC_ObjectNotActive); pragma Warnings (Off); pragma Unreferenced (Item); pragma Warnings (On); begin return Result; end To_Any; procedure Raise_ObjectNotActive_From_Any (Item : PolyORB.Any.Any; Message : PolyORB.Std.String); pragma No_Return (Raise_ObjectNotActive_From_Any); procedure Raise_ObjectNotActive_From_Any (Item : PolyORB.Any.Any; Message : PolyORB.Std.String) is Members : constant ObjectNotActive_Members := From_Any (CORBA.Any (Item)); begin PolyORB.Exceptions.User_Raise_Exception (ObjectNotActive'Identity, Members, Message); end Raise_ObjectNotActive_From_Any; procedure Raise_ObjectNotActive (Members : in ObjectNotActive_Members) is begin PolyORB.Exceptions.User_Raise_Exception (ObjectNotActive'Identity, Members); end Raise_ObjectNotActive; function From_Any (Item : CORBA.Any) return PortableServer.POA.ServantAlreadyActive_Members is Result : ServantAlreadyActive_Members; pragma Warnings (Off); pragma Unreferenced (Item); pragma Warnings (On); begin return Result; end From_Any; function To_Any (Item : PortableServer.POA.ServantAlreadyActive_Members) return CORBA.Any is Result : constant CORBA.Any := CORBA.Internals.Get_Empty_Any_Aggregate (TC_ServantAlreadyActive); pragma Warnings (Off); pragma Unreferenced (Item); pragma Warnings (On); begin return Result; end To_Any; procedure Raise_ServantAlreadyActive_From_Any (Item : PolyORB.Any.Any; Message : PolyORB.Std.String); pragma No_Return (Raise_ServantAlreadyActive_From_Any); procedure Raise_ServantAlreadyActive_From_Any (Item : PolyORB.Any.Any; Message : PolyORB.Std.String) is Members : constant ServantAlreadyActive_Members := From_Any (CORBA.Any (Item)); begin PolyORB.Exceptions.User_Raise_Exception (ServantAlreadyActive'Identity, Members, Message); end Raise_ServantAlreadyActive_From_Any; procedure Raise_ServantAlreadyActive (Members : ServantAlreadyActive_Members) is begin PolyORB.Exceptions.User_Raise_Exception (ServantAlreadyActive'Identity, Members); end Raise_ServantAlreadyActive; function From_Any (Item : CORBA.Any) return PortableServer.POA.ServantNotActive_Members is Result : ServantNotActive_Members; pragma Warnings (Off); pragma Unreferenced (Item); pragma Warnings (On); begin return Result; end From_Any; function To_Any (Item : PortableServer.POA.ServantNotActive_Members) return CORBA.Any is Result : constant CORBA.Any := CORBA.Internals.Get_Empty_Any_Aggregate (TC_ServantNotActive); pragma Warnings (Off); pragma Unreferenced (Item); pragma Warnings (On); begin return Result; end To_Any; procedure Raise_ServantNotActive_From_Any (Item : PolyORB.Any.Any; Message : PolyORB.Std.String); pragma No_Return (Raise_ServantNotActive_From_Any); procedure Raise_ServantNotActive_From_Any (Item : PolyORB.Any.Any; Message : PolyORB.Std.String) is Members : constant ServantNotActive_Members := From_Any (CORBA.Any (Item)); begin PolyORB.Exceptions.User_Raise_Exception (ServantNotActive'Identity, Members, Message); end Raise_ServantNotActive_From_Any; procedure Raise_ServantNotActive (Members : ServantNotActive_Members) is begin PolyORB.Exceptions.User_Raise_Exception (ServantNotActive'Identity, Members); end Raise_ServantNotActive; function From_Any (Item : CORBA.Any) return PortableServer.POA.WrongAdapter_Members is Result : WrongAdapter_Members; pragma Warnings (Off); pragma Unreferenced (Item); pragma Warnings (On); begin return Result; end From_Any; function To_Any (Item : PortableServer.POA.WrongAdapter_Members) return CORBA.Any is Result : constant CORBA.Any := CORBA.Internals.Get_Empty_Any_Aggregate (TC_WrongAdapter); pragma Warnings (Off); pragma Unreferenced (Item); pragma Warnings (On); begin return Result; end To_Any; procedure Raise_WrongAdapter_From_Any (Item : PolyORB.Any.Any; Message : PolyORB.Std.String); pragma No_Return (Raise_WrongAdapter_From_Any); procedure Raise_WrongAdapter_From_Any (Item : PolyORB.Any.Any; Message : PolyORB.Std.String) is Members : constant WrongAdapter_Members := From_Any (CORBA.Any (Item)); begin PolyORB.Exceptions.User_Raise_Exception (WrongAdapter'Identity, Members, Message); end Raise_WrongAdapter_From_Any; procedure Raise_WrongAdapter (Members : WrongAdapter_Members) is begin PolyORB.Exceptions.User_Raise_Exception (WrongAdapter'Identity, Members); end Raise_WrongAdapter; function From_Any (Item : CORBA.Any) return PortableServer.POA.WrongPolicy_Members is Result : WrongPolicy_Members; pragma Warnings (Off); pragma Unreferenced (Item); pragma Warnings (On); begin return Result; end From_Any; function To_Any (Item : PortableServer.POA.WrongPolicy_Members) return CORBA.Any is Result : constant CORBA.Any := CORBA.Internals.Get_Empty_Any_Aggregate (TC_WrongPolicy); pragma Warnings (Off); pragma Unreferenced (Item); pragma Warnings (On); begin return Result; end To_Any; procedure Raise_WrongPolicy_From_Any (Item : PolyORB.Any.Any; Message : PolyORB.Std.String); pragma No_Return (Raise_WrongPolicy_From_Any); procedure Raise_WrongPolicy_From_Any (Item : PolyORB.Any.Any; Message : PolyORB.Std.String) is Members : constant WrongPolicy_Members := From_Any (CORBA.Any (Item)); begin PolyORB.Exceptions.User_Raise_Exception (WrongPolicy'Identity, Members, Message); end Raise_WrongPolicy_From_Any; procedure Raise_WrongPolicy (Members : WrongPolicy_Members) is begin PolyORB.Exceptions.User_Raise_Exception (WrongPolicy'Identity, Members); end Raise_WrongPolicy; procedure Deferred_Initialization is begin declare Name : constant CORBA.String := CORBA.To_CORBA_String ("POA"); Id : constant CORBA.String := CORBA.To_CORBA_String ("IDL:omg.org/PortableServer/POA:1.0"); begin TC_POA := CORBA.TypeCode.Internals.To_CORBA_Object (PolyORB.Any.TypeCode.TC_Object); CORBA.Internals.Add_Parameter (TC_POA, CORBA.To_Any (Name)); CORBA.Internals.Add_Parameter (TC_POA, CORBA.To_Any (Id)); end; declare Name : constant CORBA.String := CORBA.To_CORBA_String ("AdapterAlreadyExists"); Id : constant CORBA.String := CORBA.To_CORBA_String ("IDL:omg.org/PortableServer/POA/AdapterAlreadyExists:1.0"); begin TC_AdapterAlreadyExists := CORBA.TypeCode.Internals.To_CORBA_Object (PolyORB.Any.TypeCode.TC_Except); CORBA.Internals.Add_Parameter (TC_AdapterAlreadyExists, CORBA.To_Any (Name)); CORBA.Internals.Add_Parameter (TC_AdapterAlreadyExists, CORBA.To_Any (Id)); end; PolyORB.Exceptions.Register_Exception (CORBA.TypeCode.Internals.To_PolyORB_Object (TC_AdapterAlreadyExists), Raise_AdapterAlreadyExists_From_Any'Access); declare Name : constant CORBA.String := CORBA.To_CORBA_String ("AdapterNonExistent"); Id : constant CORBA.String := CORBA.To_CORBA_String ("IDL:omg.org/PortableServer/POA/AdapterNonExistent:1.0"); begin TC_AdapterNonExistent := CORBA.TypeCode.Internals.To_CORBA_Object (PolyORB.Any.TypeCode.TC_Except); CORBA.Internals.Add_Parameter (TC_AdapterNonExistent, CORBA.To_Any (Name)); CORBA.Internals.Add_Parameter (TC_AdapterNonExistent, CORBA.To_Any (Id)); end; PolyORB.Exceptions.Register_Exception (CORBA.TypeCode.Internals.To_PolyORB_Object (TC_AdapterNonExistent), Raise_AdapterNonExistent_From_Any'Access); declare Name : constant CORBA.String := CORBA.To_CORBA_String ("InvalidPolicy"); Id : constant CORBA.String := CORBA.To_CORBA_String ("IDL:omg.org/PortableServer/POA/InvalidPolicy:1.0"); Arg_Name_index : constant CORBA.String := CORBA.To_CORBA_String ("index"); begin TC_InvalidPolicy := CORBA.TypeCode.Internals.To_CORBA_Object (PolyORB.Any.TypeCode.TC_Except); CORBA.Internals.Add_Parameter (TC_InvalidPolicy, CORBA.To_Any (Name)); CORBA.Internals.Add_Parameter (TC_InvalidPolicy, CORBA.To_Any (Id)); CORBA.Internals.Add_Parameter (TC_InvalidPolicy, CORBA.To_Any (CORBA.TC_Unsigned_Short)); CORBA.Internals.Add_Parameter (TC_InvalidPolicy, CORBA.To_Any (Arg_Name_index)); end; PolyORB.Exceptions.Register_Exception (CORBA.TypeCode.Internals.To_PolyORB_Object (TC_InvalidPolicy), Raise_InvalidPolicy_From_Any'Access); declare Name : constant CORBA.String := CORBA.To_CORBA_String ("NoServant"); Id : constant CORBA.String := CORBA.To_CORBA_String ("IDL:omg.org/PortableServer/POA/NoServant:1.0"); begin TC_NoServant := CORBA.TypeCode.Internals.To_CORBA_Object (PolyORB.Any.TypeCode.TC_Except); CORBA.Internals.Add_Parameter (TC_NoServant, CORBA.To_Any (Name)); CORBA.Internals.Add_Parameter (TC_NoServant, CORBA.To_Any (Id)); end; PolyORB.Exceptions.Register_Exception (CORBA.TypeCode.Internals.To_PolyORB_Object (TC_NoServant), Raise_NoServant_From_Any'Access); declare Name : constant CORBA.String := CORBA.To_CORBA_String ("ObjectAlreadyActive"); Id : constant CORBA.String := CORBA.To_CORBA_String ("IDL:omg.org/PortableServer/POA/ObjectAlreadyActive:1.0"); begin TC_ObjectAlreadyActive := CORBA.TypeCode.Internals.To_CORBA_Object (PolyORB.Any.TypeCode.TC_Except); CORBA.Internals.Add_Parameter (TC_ObjectAlreadyActive, CORBA.To_Any (Name)); CORBA.Internals.Add_Parameter (TC_ObjectAlreadyActive, CORBA.To_Any (Id)); end; PolyORB.Exceptions.Register_Exception (CORBA.TypeCode.Internals.To_PolyORB_Object (TC_ObjectAlreadyActive), Raise_ObjectAlreadyActive_From_Any'Access); declare Name : constant CORBA.String := CORBA.To_CORBA_String ("ObjectNotActive"); Id : constant CORBA.String := CORBA.To_CORBA_String ("IDL:omg.org/PortableServer/POA/ObjectNotActive:1.0"); begin TC_ObjectNotActive := CORBA.TypeCode.Internals.To_CORBA_Object (PolyORB.Any.TypeCode.TC_Except); CORBA.Internals.Add_Parameter (TC_ObjectNotActive, CORBA.To_Any (Name)); CORBA.Internals.Add_Parameter (TC_ObjectNotActive, CORBA.To_Any (Id)); end; PolyORB.Exceptions.Register_Exception (CORBA.TypeCode.Internals.To_PolyORB_Object (TC_ObjectNotActive), Raise_ObjectNotActive_From_Any'Access); declare Name : constant CORBA.String := CORBA.To_CORBA_String ("ServantAlreadyActive"); Id : constant CORBA.String := CORBA.To_CORBA_String ("IDL:omg.org/PortableServer/POA/ServantAlreadyActive:1.0"); begin TC_ServantAlreadyActive := CORBA.TypeCode.Internals.To_CORBA_Object (PolyORB.Any.TypeCode.TC_Except); CORBA.Internals.Add_Parameter (TC_ServantAlreadyActive, CORBA.To_Any (Name)); CORBA.Internals.Add_Parameter (TC_ServantAlreadyActive, CORBA.To_Any (Id)); end; PolyORB.Exceptions.Register_Exception (CORBA.TypeCode.Internals.To_PolyORB_Object (TC_ServantAlreadyActive), Raise_ServantAlreadyActive_From_Any'Access); declare Name : constant CORBA.String := CORBA.To_CORBA_String ("ServantNotActive"); Id : constant CORBA.String := CORBA.To_CORBA_String ("IDL:omg.org/PortableServer/POA/ServantNotActive:1.0"); begin TC_ServantNotActive := CORBA.TypeCode.Internals.To_CORBA_Object (PolyORB.Any.TypeCode.TC_Except); CORBA.Internals.Add_Parameter (TC_ServantNotActive, CORBA.To_Any (Name)); CORBA.Internals.Add_Parameter (TC_ServantNotActive, CORBA.To_Any (Id)); end; PolyORB.Exceptions.Register_Exception (CORBA.TypeCode.Internals.To_PolyORB_Object (TC_ServantNotActive), Raise_ServantNotActive_From_Any'Access); declare Name : constant CORBA.String := CORBA.To_CORBA_String ("WrongAdapter"); Id : constant CORBA.String := CORBA.To_CORBA_String ("IDL:omg.org/PortableServer/POA/WrongAdapter:1.0"); begin TC_WrongAdapter := CORBA.TypeCode.Internals.To_CORBA_Object (PolyORB.Any.TypeCode.TC_Except); CORBA.Internals.Add_Parameter (TC_WrongAdapter, CORBA.To_Any (Name)); CORBA.Internals.Add_Parameter (TC_WrongAdapter, CORBA.To_Any (Id)); end; PolyORB.Exceptions.Register_Exception (CORBA.TypeCode.Internals.To_PolyORB_Object (TC_WrongAdapter), Raise_WrongAdapter_From_Any'Access); declare Name : constant CORBA.String := CORBA.To_CORBA_String ("WrongPolicy"); Id : constant CORBA.String := CORBA.To_CORBA_String ("IDL:omg.org/PortableServer/POA/WrongPolicy:1.0"); begin TC_WrongPolicy := CORBA.TypeCode.Internals.To_CORBA_Object (PolyORB.Any.TypeCode.TC_Except); CORBA.Internals.Add_Parameter (TC_WrongPolicy, CORBA.To_Any (Name)); CORBA.Internals.Add_Parameter (TC_WrongPolicy, CORBA.To_Any (Id)); end; PolyORB.Exceptions.Register_Exception (CORBA.TypeCode.Internals.To_PolyORB_Object (TC_WrongPolicy), Raise_WrongPolicy_From_Any'Access); end Deferred_Initialization; begin declare use PolyORB.Initialization; use PolyORB.Initialization.String_Lists; use PolyORB.Utils.Strings; begin Register_Module (Module_Info' (Name => +"PortableServer.POA.Helper", Conflicts => PolyORB.Initialization.String_Lists.Empty, Depends => +"any" & "exceptions" & "exceptions" & "exceptions" & "exceptions" & "exceptions" & "exceptions" & "exceptions" & "exceptions" & "exceptions" & "exceptions" , Provides => PolyORB.Initialization.String_Lists.Empty, Implicit => False, Init => Deferred_Initialization'Access, Shutdown => null)); end; end PortableServer.POA.Helper; polyorb-2.8~20110207.orig/src/corba/polyorb-sequences-unbounded-corba_helper.ads0000644000175000017500000000641011750740340027034 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- POLYORB.SEQUENCES.UNBOUNDED.CORBA_HELPER -- -- -- -- S p e c -- -- -- -- Copyright (C) 2003-2007, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- Any conversion subprograms for unbounded sequences with CORBA; with PolyORB.Any; with PolyORB.Sequences.Unbounded.Helper; pragma Elaborate_All (PolyORB.Sequences.Unbounded.Helper); generic with function Element_From_Any (Item : CORBA.Any) return Element; with function Element_To_Any (Item : Element) return CORBA.Any; with function Element_Wrap (X : access Element) return PolyORB.Any.Content'Class; package PolyORB.Sequences.Unbounded.CORBA_Helper is function From_Any (Item : CORBA.Any) return Sequence; function To_Any (Item : Sequence) return CORBA.Any; function Wrap (X : access Sequence) return PolyORB.Any.Content'Class; procedure Initialize (Element_TC, Sequence_TC : CORBA.TypeCode.Object); private function Element_From_Any_Wrapper (Item : PolyORB.Any.Any) return Element; function Element_To_Any_Wrapper (Item : Element) return PolyORB.Any.Any; -- Helpers operating on PolyORB Any's, constructed from the formal helpers -- operating on CORBA Any's. package Neutral_Helper is new PolyORB.Sequences.Unbounded.Helper (Element_From_Any => Element_From_Any_Wrapper, Element_To_Any => Element_To_Any_Wrapper, Element_Wrap => Element_Wrap); end PolyORB.Sequences.Unbounded.CORBA_Helper; polyorb-2.8~20110207.orig/src/corba/portableserver-current.ads0000644000175000017500000000724511750740340023477 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O R T A B L E S E R V E R . C U R R E N T -- -- -- -- S p e c -- -- -- -- Copyright (C) 2001-2010, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the CORBA Specification, and adapted -- -- for use with PolyORB. The copyright notice above, and the license -- -- provisions that follow apply solely to the contents neither explicitly -- -- nor implicitly specified by the CORBA Specification defined by the OMG. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with Ada.Exceptions; with CORBA.Current; with CORBA.Local; with CORBA.Object; package PortableServer.Current is type Local_Ref is new CORBA.Current.Local_Ref with private; function To_Ref (Self : CORBA.Object.Ref'Class) return Local_Ref; NoContext : exception; function Get_POA (Self : Local_Ref) return PortableServer.POA_Forward.Ref; function Get_Object_Id (Self : Local_Ref) return ObjectId; function Get_Reference (Self : Local_Ref) return CORBA.Object.Ref; function Get_Servant (Self : Local_Ref) return Servant; --------------------------------------- -- PortableServer.Current exceptions -- --------------------------------------- -- NoContext_Members type NoContext_Members is new CORBA.IDL_Exception_Members with null record; procedure Get_Members (From : Ada.Exceptions.Exception_Occurrence; To : out NoContext_Members); Repository_Id : constant Standard.String := "IDL:omg.org/PortableServer/Current:1.0"; private type Local_Ref is new CORBA.Current.Local_Ref with null record; type Current_Object is new CORBA.Local.Object with null record; function Is_A (Obj : not null access Current_Object; Logical_Type_Id : Standard.String) return Boolean; end PortableServer.Current; polyorb-2.8~20110207.orig/src/corba/corba-contextlist.ads0000644000175000017500000000734611750740337022434 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- C O R B A . C O N T E X T L I S T -- -- -- -- S p e c -- -- -- -- Copyright (C) 2001-2008, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the CORBA Specification, and adapted -- -- for use with PolyORB. The copyright notice above, and the license -- -- provisions that follow apply solely to the contents neither explicitly -- -- nor implicitly specified by the CORBA Specification defined by the OMG. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- Implementation Note: this package implements the recommendation of -- the OMG issue #3706, that add new primitives to CORBA::Object. -- See CORBA.Object package specifications for more details. with CORBA.AbstractBase; with CORBA.Impl; with CORBA.Sequences.Unbounded; pragma Elaborate_All (CORBA.Sequences.Unbounded); package CORBA.ContextList is pragma Elaborate_Body; type Ref is new CORBA.AbstractBase.Ref with null record; Nil_Ref : constant Ref; type Object is new CORBA.Impl.Object with private; type Object_Ptr is access all Object; procedure Finalize (Obj : in out Object); function Get_Count (Self : Ref) return CORBA.Unsigned_Long; procedure Add (Self : Ref; Exc : CORBA.String); function Item (Self : Ref; Index : CORBA.Unsigned_Long) return CORBA.String; procedure Remove (Self : Ref; Index : CORBA.Unsigned_Long); function Create_Object return Object_Ptr; private -- The actual implementation of an ContextList: an unbounded -- sequence of CORBA.String package Context_Sequence is new CORBA.Sequences.Unbounded (CORBA.String); type Object is new CORBA.Impl.Object with record List : Context_Sequence.Sequence := Context_Sequence.Null_Sequence; end record; Nil_Ref : constant Ref := (CORBA.AbstractBase.Ref with null record); end CORBA.ContextList; polyorb-2.8~20110207.orig/src/corba/corba-request.ads0000644000175000017500000001006511750740340021526 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- C O R B A . R E Q U E S T -- -- -- -- S p e c -- -- -- -- Copyright (C) 2001-2010, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the CORBA Specification, and adapted -- -- for use with PolyORB. The copyright notice above, and the license -- -- provisions that follow apply solely to the contents neither explicitly -- -- nor implicitly specified by the CORBA Specification defined by the OMG. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- The CORBA Dynamic Invocation Interface. with CORBA.AbstractBase; with CORBA.Context; with CORBA.ContextList; with CORBA.ExceptionList; with CORBA.NVList; with PolyORB.Requests; package CORBA.Request is type Object is limited private; procedure Create_Request (Self : CORBA.AbstractBase.Ref; Ctx : CORBA.Context.Ref; Operation : Identifier; Arg_List : CORBA.NVList.Ref; Result : in out NamedValue; Request : out CORBA.Request.Object; Req_Flags : Flags); procedure Create_Request (Self : CORBA.AbstractBase.Ref; Ctx : CORBA.Context.Ref; Operation : Identifier; Arg_List : CORBA.NVList.Ref; Result : in out NamedValue; Exc_List : ExceptionList.Ref; Ctxt_List : ContextList.Ref; Request : out CORBA.Request.Object; Req_Flags : Flags); procedure Invoke (Self : in out Object; Invoke_Flags : Flags := 0); -- Implementation Note: the IDL-to-Ada mapping specifies a default -- value for Invoke_Flags, but it does not define its -- semantics. Moreover, the CORBA specifications define no value -- for Invoke_Flags. Thus, we retain the following semantics: the -- only possible value for Invoke_Flags is 0, all other values -- will be ignored for now. procedure Delete (Self : in out Object); -- XXX incomplete! private type Object is limited record The_Request : aliased PolyORB.Requests.Request; end record; -- XXX Would it not be simpler to declare -- type Object is new PolyORB.Requests.Request; ? -- (as is presently done in CORBA.ServerRequest!) end CORBA.Request; polyorb-2.8~20110207.orig/src/corba/polyorb-corba_p-initial_references.adb0000644000175000017500000001604711750740340025660 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . C O R B A _ P . I N I T I A L _ R E F E R E N C E S -- -- -- -- B o d y -- -- -- -- Copyright (C) 2003-2008, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with PolyORB.Initialization; with PolyORB.Log; with PolyORB.Utils.HFunctions.Hyper; with PolyORB.Utils.HTables.Perfect; package body PolyORB.CORBA_P.Initial_References is use PolyORB.Log; package L is new PolyORB.Log.Facility_Log ("polyorb.corba_p.initial_references"); procedure O (Message : Standard.String; Level : Log_Level := Debug) renames L.Output; function C (Level : Log_Level := Debug) return Boolean renames L.Enabled; -- Management of Initial references. -- Resolve_Initial_References may either return a reference to a -- pre allocated object (e.g. RootPOA), or return a newly created -- object (e.g. POACurrent). We build to hash tables to store each -- information. package Referenced_Objects_HTables is new PolyORB.Utils.HTables.Perfect (CORBA.Object.Ref, PolyORB.Utils.HFunctions.Hyper.Hash_Hyper_Parameters, PolyORB.Utils.HFunctions.Hyper.Default_Hash_Parameters, PolyORB.Utils.HFunctions.Hyper.Hash, PolyORB.Utils.HFunctions.Hyper.Next_Hash_Parameters); Referenced_Objects : Referenced_Objects_HTables.Table_Instance; -- Hash table of referenced objects package Referenced_Allocators_HTables is new PolyORB.Utils.HTables.Perfect (Create_Ptr, PolyORB.Utils.HFunctions.Hyper.Hash_Hyper_Parameters, PolyORB.Utils.HFunctions.Hyper.Default_Hash_Parameters, PolyORB.Utils.HFunctions.Hyper.Hash, PolyORB.Utils.HFunctions.Hyper.Next_Hash_Parameters); Referenced_Allocators : Referenced_Allocators_HTables.Table_Instance; -- Hash table of referenced allocators -------------------------------- -- Register_Initial_Reference -- -------------------------------- procedure Register_Initial_Reference (Id : Standard.String; Ref : CORBA.Object.Ref) is begin pragma Debug (C, O ("Register_Initial_Reference: id " & Id)); Referenced_Objects_HTables.Insert (Referenced_Objects, Id, Ref); end Register_Initial_Reference; procedure Register_Initial_Reference (Id : Standard.String; Allocator : Create_Ptr) is begin pragma Debug (C, O ("Register_Initial_Reference: id " & Id)); Referenced_Allocators_HTables.Insert (Referenced_Allocators, Id, Allocator); end Register_Initial_Reference; -------------------------------- -- Resolve_Initial_References -- -------------------------------- function Resolve_Initial_References (Id : Standard.String) return CORBA.Object.Ref is Nil_Ref : CORBA.Object.Ref; begin pragma Debug (C, O ("Resolve_Initial_Reference: id " & Id)); -- Test if Id is in Referenced_Objects declare use Referenced_Objects_HTables; Result : CORBA.Object.Ref; begin Result := Lookup (Referenced_Objects, Id, Nil_Ref); if not CORBA.Object.Is_Nil (Result) then return Result; end if; end; -- Else test if Id is in Referenced_Allocators declare use Referenced_Allocators_HTables; Allocator : constant Create_Ptr := Lookup (Referenced_Allocators, Id, null); begin if Allocator /= null then return Allocator.all; end if; end; -- Otherwise, return Nil_Ref pragma Debug (C, O ("Id not found !")); return Nil_Ref; end Resolve_Initial_References; --------------------------- -- List_Initial_Services -- --------------------------- function List_Initial_Services return PolyORB.Utils.Strings.Lists.List is Result : PolyORB.Utils.Strings.Lists.List; begin -- Add all elements in Referenced_Objects declare use Referenced_Objects_HTables; It : Iterator := First (Referenced_Objects); begin while not Last (It) loop PolyORB.Utils.Strings.Lists.Append (Result, Key (It)); Next (It); end loop; end; -- Add all elements in Referenced_Allocators declare use Referenced_Allocators_HTables; It : Iterator := First (Referenced_Allocators); begin while not Last (It) loop PolyORB.Utils.Strings.Lists.Append (Result, Key (It)); Next (It); end loop; end; return Result; end List_Initial_Services; ---------------- -- Initialize -- ---------------- procedure Initialize; procedure Initialize is begin -- Initialize hash tables Referenced_Objects_HTables.Initialize (Referenced_Objects); Referenced_Allocators_HTables.Initialize (Referenced_Allocators); end Initialize; use PolyORB.Initialization; use PolyORB.Utils.Strings; use PolyORB.Utils.Strings.Lists; begin Register_Module (Module_Info' (Name => +"polyorb.corba_p.initial_references", Conflicts => Empty, Depends => +"references?", Provides => +"corba.initial_references", Implicit => False, Init => Initialize'Access, Shutdown => null)); end PolyORB.CORBA_P.Initial_References; polyorb-2.8~20110207.orig/src/corba/portableserver-servantlocator.ads0000644000175000017500000000713411750740340025060 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O R T A B L E S E R V E R . S E R V A N T L O C A T O R -- -- -- -- S p e c -- -- -- -- Copyright (C) 2001-2008, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the CORBA Specification, and adapted -- -- for use with PolyORB. The copyright notice above, and the license -- -- provisions that follow apply solely to the contents neither explicitly -- -- nor implicitly specified by the CORBA Specification defined by the OMG. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with CORBA; with PortableServer.ServantManager; with PolyORB.POA_Types; package PortableServer.ServantLocator is type Local_Ref is new PortableServer.ServantManager.Local_Ref with private; type Root_Cookie is new PolyORB.POA_Types.Cookie_Base with private; type Cookie_Base is new Root_Cookie with private; type Cookie is access all Cookie_Base'Class; procedure Preinvoke (Self : Local_Ref; Oid : ObjectId; Adapter : PortableServer.POA_Forward.Ref; Operation : CORBA.Identifier; The_Cookie : out Cookie; Returns : out Servant); procedure Postinvoke (Self : Local_Ref; Oid : ObjectId; Adapter : PortableServer.POA_Forward.Ref; Operation : CORBA.Identifier; The_Cookie : Cookie; The_Servant : Servant); Repository_Id : constant Standard.String := "IDL:omg.org/PortableServer/ServantLocator:1.0"; private type Local_Ref is new PortableServer.ServantManager.Local_Ref with null record; type Root_Cookie is new PolyORB.POA_Types.Cookie_Base with null record; type Cookie_Base is new Root_Cookie with null record; end PortableServer.ServantLocator; polyorb-2.8~20110207.orig/src/polyorb-poa_policies-id_assignment_policy-system.ads0000644000175000017500000000644211750740340027545 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- POLYORB.POA_POLICIES.ID_ASSIGNMENT_POLICY.SYSTEM -- -- -- -- S p e c -- -- -- -- Copyright (C) 2001-2005 Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ package PolyORB.POA_Policies.Id_Assignment_Policy.System is type System_Id_Policy is new IdAssignmentPolicy with null record; type System_Id_Policy_Access is access all System_Id_Policy; function Create return System_Id_Policy_Access; procedure Check_Compatibility (Self : System_Id_Policy; Other_Policies : AllPolicies; Error : in out PolyORB.Errors.Error_Container); function Policy_Id (Self : System_Id_Policy) return String; function Create_Object_Map (Self : System_Id_Policy) return PolyORB.Object_Maps.Object_Map_Access; procedure Assign_Object_Identifier (Self : System_Id_Policy; OA : PolyORB.POA_Types.Obj_Adapter_Access; Hint : Object_Id_Access; U_Oid : out Unmarshalled_Oid; Error : in out PolyORB.Errors.Error_Container); procedure Reconstruct_Object_Identifier (Self : System_Id_Policy; OA : Obj_Adapter_Access; Oid : Object_Id; U_Oid : out Unmarshalled_Oid; Error : in out PolyORB.Errors.Error_Container); procedure Object_Identifier (Self : System_Id_Policy; Oid : Object_Id_Access; Result : out Object_Id_Access; Error : in out PolyORB.Errors.Error_Container); end PolyORB.POA_Policies.Id_Assignment_Policy.System; polyorb-2.8~20110207.orig/src/polyorb-rt_poa_policies-priority_model_policy.adb0000644000175000017500000001527711750740340027132 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- POLYORB.RT_POA_POLICIES.PRIORITY_MODEL_POLICY -- -- -- -- B o d y -- -- -- -- Copyright (C) 2004-2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with PolyORB.Annotations; package body PolyORB.RT_POA_Policies.Priority_Model_Policy is type Priority_Model_Policy_Note is new PolyORB.Annotations.Note with record Model : Priority_Model; Server_ORB_Priority : ORB_Priority; Server_External_Priority : External_Priority; end record; Default_PMP : constant Priority_Model_Policy_Note := (PolyORB.Annotations.Note with Model => SERVER_DECLARED, Server_ORB_Priority => ORB_Priority'Last, Server_External_Priority => Invalid_Priority); ------------ -- Create -- ------------ function Create (Model : Priority_Model; Server_ORB_Priority : ORB_Priority; Server_External_Priority : External_Priority) return Policy_Access is Result : constant Policy_Access := new PriorityModelPolicy (Model => Model); TResult : PriorityModelPolicy renames PriorityModelPolicy (Result.all); begin TResult.Server_ORB_Priority := Server_ORB_Priority; TResult.Server_External_Priority := Server_External_Priority; return Result; end Create; --------------- -- Policy_Id -- --------------- function Policy_Id (Self : PriorityModelPolicy) return String is begin return "PRIORITY_MODEL_POLICY_" & Priority_Model'Image (Self.Model); end Policy_Id; ------------------------ -- Check_Compatiblity -- ------------------------ procedure Check_Compatibility (Self : PriorityModelPolicy; Other_Policies : AllPolicies; Error : in out PolyORB.Errors.Error_Container) is pragma Unreferenced (Self); pragma Unreferenced (Other_Policies); pragma Unreferenced (Error); pragma Warnings (On); begin -- No rule to test null; end Check_Compatibility; -------------------------------------- -- Get_Servant_Priority_Information -- -------------------------------------- procedure Get_Servant_Priority_Information (Servant : Servants.Servant_Access; Model : out Priority_Model; Server_ORB_Priority : out ORB_Priority; Server_External_Priority : out External_Priority; Error : in out PolyORB.Errors.Error_Container) is use PolyORB.Errors; Notepad : constant PolyORB.Annotations.Notepad_Access := PolyORB.Servants.Notepad_Of (Servant); Note : Priority_Model_Policy_Note; begin PolyORB.Annotations.Get_Note (Notepad.all, Note, Default_PMP); if Note /= Default_PMP then Model := Note.Model; Server_ORB_Priority := Note.Server_ORB_Priority; Server_External_Priority := Note.Server_External_Priority; else Throw (Error, WrongPolicy_E, Null_Members'(Null_Member)); return; end if; end Get_Servant_Priority_Information; -------------------------------------- -- Set_Servant_Priority_Information -- -------------------------------------- procedure Set_Servant_Priority_Information (Self : PriorityModelPolicy; Servant : PolyORB.Servants.Servant_Access) is Notepad : constant PolyORB.Annotations.Notepad_Access := PolyORB.Servants.Notepad_Of (Servant); Note : Priority_Model_Policy_Note; begin PolyORB.Annotations.Get_Note (Notepad.all, Note, Default_PMP); if Note = Default_PMP then Note.Model := Self.Model; Note.Server_ORB_Priority := Self.Server_ORB_Priority; Note.Server_External_Priority := Self.Server_External_Priority; PolyORB.Annotations.Set_Note (Notepad.all, Note); end if; end Set_Servant_Priority_Information; procedure Set_Servant_Priority_Information (Self : PriorityModelPolicy; Servant : Servants.Servant_Access; Server_ORB_Priority : ORB_Priority; Server_External_Priority : External_Priority; Error : in out PolyORB.Errors.Error_Container) is use PolyORB.Errors; Notepad : constant PolyORB.Annotations.Notepad_Access := PolyORB.Servants.Notepad_Of (Servant); Note : Priority_Model_Policy_Note; begin if Self.Model /= SERVER_DECLARED then Throw (Error, WrongPolicy_E, Null_Members'(Null_Member)); return; end if; Note.Model := SERVER_DECLARED; Note.Server_ORB_Priority := Server_ORB_Priority; Note.Server_External_Priority := Server_External_Priority; PolyORB.Annotations.Set_Note (Notepad.all, Note); end Set_Servant_Priority_Information; end PolyORB.RT_POA_Policies.Priority_Model_Policy; polyorb-2.8~20110207.orig/src/dns/0000755000175000017500000000000011750740340015755 5ustar xavierxavierpolyorb-2.8~20110207.orig/src/dns/polyorb-representations-dns.adb0000644000175000017500000004767611750740340024144 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . R E P R E S E N T A T I O N S . D N S -- -- -- -- B o d y -- -- -- -- Copyright (C) 2002-2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with Ada.Streams; with PolyORB.Initialization; with PolyORB.Log; with GNAT.Byte_Swapping; with PolyORB.Utils.Strings; with PolyORB.Utils.Buffers; with PolyORB.DNS.Helper; with PolyORB.Utils; pragma Elaborate_All (PolyORB.Utils.Buffers); package body PolyORB.Representations.DNS is use Ada.Streams; use PolyORB.Any.TypeCode; use PolyORB.Log; use PolyORB.Errors; use PolyORB.Utils.Buffers; use GNAT.Byte_Swapping; use PolyORB.Utils; use PolyORB.DNS.Helper; package L is new PolyORB.Log.Facility_Log ("polyorb.representations.dns"); procedure O (Message : String; Level : Log_Level := Debug) renames L.Output; function C (Level : Log_Level := Debug) return Boolean renames L.Enabled; procedure Marshall_From_Any (Buffer : Buffer_Access; Argument : Any.Any; Is_Reply : Types.Boolean) is current_Seq : rrSequence; current_rr : RR; begin pragma Debug (C, O ("Marshall_From_Any: enter")); current_Seq := From_Any (Argument); for J in 1 .. Length (current_Seq) loop current_rr := Get_Element (current_Seq, J); Marshall_DNS_String (Buffer, To_Standard_String (current_rr.rr_name)); case current_rr.rr_type is when A => Marshall (Buffer, A_Code); Marshall (Buffer, Default_Class_Code); if Is_Reply then Marshall (Buffer, current_rr.TTL); Marshall (Buffer, current_rr.data_length); Marshall (Buffer, Get_Element (current_rr.rr_data.a_address, 1)); Marshall (Buffer, Get_Element (current_rr.rr_data.a_address, 2)); Marshall (Buffer, Get_Element (current_rr.rr_data.a_address, 3)); Marshall (Buffer, Get_Element (current_rr.rr_data.a_address, 4)); end if; when PTR => Marshall (Buffer, PTR_Code); Marshall (Buffer, Default_Class_Code); if Is_Reply then Marshall (Buffer, current_rr.TTL); Marshall (Buffer, current_rr.data_length); Marshall_DNS_String (Buffer, To_Standard_String (current_rr.rr_data.rr_answer)); end if; when TXT => Marshall (Buffer, TXT_Code); Marshall (Buffer, Default_Class_Code); if Is_Reply then Marshall (Buffer, current_rr.TTL); Marshall (Buffer, current_rr.data_length); Marshall_TXT_String (Buffer, To_Standard_String (current_rr.rr_data.rr_answer)); end if; when SRV => Marshall (Buffer, SRV_Code); Marshall (Buffer, Default_Class_Code); if Is_Reply then Marshall (Buffer, current_rr.TTL); Marshall (Buffer, current_rr.data_length); Marshall (Buffer, current_rr.rr_data.srv_data.priority); Marshall (Buffer, current_rr.rr_data.srv_data.weight); Marshall (Buffer, current_rr.rr_data.srv_data.port); Marshall_DNS_String (Buffer, To_Standard_String (current_rr.rr_data.srv_data.target)); end if; when others => null; end case; end loop; pragma Debug (C, O ("Marshall_From_Any: leave")); end Marshall_From_Any; ----------------------- -- Unmarshall_To_Any -- ----------------------- procedure Unmarshall_To_Any (Buffer : Buffer_Access; Arg : Any.Any; Length : Integer; Is_Reply : Types.Boolean) is Request_Class : Types.Unsigned_Short; pragma Unreferenced (Request_Class); Request_Type_Code : Types.Unsigned_Short; current_rr : RR; current_Seq : rrSequence := To_Sequence (Length); begin for J in 1 .. Length loop current_rr.rr_name := Unmarshall_DNS_String (Buffer); Request_Type_Code := Unmarshall (Buffer); case Request_Type_Code is when A_Code => current_rr.rr_type := A; when PTR_Code => current_rr.rr_type := PTR; when TXT_Code => current_rr.rr_type := TXT; when SRV_Code => current_rr.rr_type := SRV; when others => -- Should not happen for now raise DNS_Error; end case; Request_Class := Unmarshall (Buffer); if not Is_Reply then return; end if; current_rr.TTL := Unmarshall (Buffer); current_rr.data_length := Unmarshall (Buffer); -- Part specific to each RR type declare rr_d : RR_Data (current_rr.rr_type); begin case current_rr.rr_type is when SRV => rr_d.srv_data.priority := Unmarshall (Buffer); rr_d.srv_data.weight := Unmarshall (Buffer); rr_d.srv_data.port := Unmarshall (Buffer); rr_d.srv_data.target := Unmarshall_DNS_String (Buffer); when A => rr_d.a_address := IDL_AT_Sequence_4_octet (IDL_SEQUENCE_4_octet.To_Sequence (IDL_SEQUENCE_4_octet.Element_Array'( Unmarshall (Buffer), Unmarshall (Buffer), Unmarshall (Buffer), Unmarshall (Buffer)))); when TXT => pragma Debug (C, O ("Message is a TXT record")); rr_d.rr_answer := Unmarshall_TXT_String (Buffer, current_rr.data_length); pragma Debug (C, O (To_Standard_String (rr_d.rr_answer))); when others => rr_d.rr_answer := Unmarshall_DNS_String (Buffer); end case; current_rr.rr_data := rr_d; Replace_Element (current_Seq, Integer (J), current_rr); end; end loop; Copy_Any_Value (Arg, To_Any (current_Seq)); pragma Debug (C, O ("After Copy_Any_Value")); end Unmarshall_To_Any; -- Marshalling of a Boolean procedure Marshall (Buffer : access Buffer_Type; Data : PolyORB.Types.Boolean) is begin pragma Debug (C, O ("Marshall (Boolean) : enter")); Marshall (Buffer, PolyORB.Types.Octet'(PolyORB.Types.Boolean'Pos (Data))); pragma Debug (C, O ("Marshall (Boolean) : end")); end Marshall; -- Marshalling of a Character procedure Marshall_Latin_1_Char (Buffer : access Buffer_Type; Data : PolyORB.Types.Char) is begin pragma Debug (C, O ("Marshall (Char) : enter")); Marshall (Buffer, PolyORB.Types.Octet'(PolyORB.Types.Char'Pos (Data))); pragma Debug (C, O ("Marshall (Char) : end")); end Marshall_Latin_1_Char; function Unmarshall_Latin_1_Char (Buffer : access Buffer_Type) return PolyORB.Types.Char is begin pragma Debug (C, O ("Unmarshall (Char) : enter & end")); return PolyORB.Types.Char'Val (PolyORB.Types.Octet'(Unmarshall (Buffer))); end Unmarshall_Latin_1_Char; -- Marshalling of an Octet procedure Marshall (Buffer : access Buffer_Type; Data : PolyORB.Types.Octet) is begin pragma Debug (C, O ("Marshall (Octet) : enter")); Align_Marshall_Copy (Buffer, (1 => Stream_Element (PolyORB.Types.Octet'(Data))), Align_1); pragma Debug (C, O ("Marshall (Octet) : end")); end Marshall; procedure Marshall_Latin_1_String (Buffer : access Buffer_Type; Data : Standard.String) is Str : Stream_Element_Array (1 .. Data'Length); for Str'Address use Data'Address; pragma Import (Ada, Str); begin pragma Debug (C, O ("Marshall (String) : enter:" & Data'Length'Img)); if Data'Length = 0 then return; end if; Marshall (Buffer, PolyORB.Types.Octet'(Data'Length)); Align_Marshall_Copy (Buffer, Str); pragma Debug (C, O ("Marshall (String) : end")); end Marshall_Latin_1_String; -- Marshalling of a PolyORB.Types.String procedure Marshall_Latin_1_String (Buffer : access Buffer_Type; Data : PolyORB.Types.String) is begin pragma Debug (C, O ("Marshall (PolyORB.Types.String) : enter")); Marshall_Latin_1_String (Buffer, PolyORB.Types.To_Standard_String (Data)); pragma Debug (C, O ("Marshall (PolyORB.Types.String) : end")); end Marshall_Latin_1_String; procedure Marshall_DNS_String (Buffer : access Buffer_Type; Data : Standard.String) is S : String renames Data; Index : Integer; Index2 : Integer; Label : PolyORB.Types.String; begin pragma Debug (C, O ("Marshall DNS string : enter")); Index := S'First; Index2 := Find (S, Index, '.'); while Index2 > Index loop Label := To_PolyORB_String (S (Index .. Index2 - 1)); Marshall_Latin_1_String (Buffer, Label); pragma Debug (C, O ("Marshall DNS string :label " & To_Standard_String (Label))); Index := Index2 + 1; Index2 := Find (S, Index, '.'); end loop; Marshall (Buffer, Types.Octet (0)); pragma Debug (C, O ("Marshall DNS string: end")); end Marshall_DNS_String; procedure Marshall_TXT_String (Buffer : access Buffer_Type; Data : Standard.String) is S : String renames Data; Index : Integer; Index2 : Integer; Label : PolyORB.Types.String; begin pragma Debug (C, O ("Marshall TXT string : enter")); Index := S'First; Index2 := Find (S, Index, '\') + 1; while Index2 > Index and Index /= S'Last + 3 loop Label := To_PolyORB_String (S (Index .. Index2 - 2)); Marshall_Latin_1_String (Buffer, Label); pragma Debug (C, O ("Marshall TXT string :label " & To_Standard_String (Label))); Index := Index2 + 1; Index2 := Find (S, Index, '\') + 1; pragma Debug (C, O ("Index2=" & Index2'Img & " > Index=" & Index'Img)); end loop; pragma Debug (C, O ("Marshall TXT string: end")); end Marshall_TXT_String; function Unmarshall_TXT_String (Buffer : access Buffer_Type; Data_Length : PolyORB.Types.Unsigned_Short) return PolyORB.Types.String is Length : PolyORB.Types.Octet := Unmarshall (Buffer); Current_Length : PolyORB.Types.Unsigned_Short := 0; Label : Types.String := To_PolyORB_String (""); begin pragma Debug (C, O ("Unmarshall TXT: enter")); pragma Debug (C, O ("Unmarshall TXT: length is " & PolyORB.Types.Octet'Image (Length))); if Length = 0 then pragma Debug (C, O ("Unmarshall TXT: returning empty")); return To_PolyORB_String (""); end if; while Data_Length > Current_Length loop declare Equiv : String (1 .. Natural (Length)); begin for J in Equiv'Range loop Equiv (J) := Character'Val (PolyORB.Types.Char'Pos (Unmarshall_Latin_1_Char (Buffer))); end loop; Label := Label & To_PolyORB_String (Equiv); pragma Debug (C, O ("Unmarshall DNS (String): -> " & To_Standard_String (Label))); Current_Length := Current_Length + To_Standard_String (Label)'Length; end; if Data_Length > Current_Length then Length := Unmarshall (Buffer); Label := Label & "\."; Current_Length := Current_Length + 2; end if; end loop; pragma Debug (C, O ("Unmarshall (String): -> " & To_Standard_String (Label))); return Label; end Unmarshall_TXT_String; function Unmarshall_DNS_String (Buffer : access Buffer_Type) return PolyORB.Types.String is Length : PolyORB.Types.Octet := Unmarshall (Buffer); Label : Types.String := To_PolyORB_String (""); begin pragma Debug (C, O ("Unmarshall (String): enter")); pragma Debug (C, O ("Unmarshall (String): length is " & PolyORB.Types.Octet'Image (Length))); if Length = 0 then pragma Debug (C, O ("Unmarshall (String): returning empty")); return To_PolyORB_String (""); end if; while Length /= Types.Octet (0) loop declare Equiv : String (1 .. Natural (Length)); begin for J in Equiv'Range loop Equiv (J) := Character'Val (PolyORB.Types.Char'Pos (Unmarshall_Latin_1_Char (Buffer))); end loop; Label := Label & To_PolyORB_String (Equiv); pragma Debug (C, O ("Unmarshall DNS (String): -> " & To_Standard_String (Label))); end; Length := Unmarshall (Buffer); pragma Debug (C, O ("Unmarshall (String): length is " & PolyORB.Types.Octet'Image (Length))); if Length /= Types.Octet (0) then Label := Label & "."; end if; end loop; pragma Debug (C, O ("Unmarshall (String): -> " & To_Standard_String (Label))); return Label; end Unmarshall_DNS_String; function Unmarshall_Latin_1_String (Buffer : access Buffer_Type) return Standard.String is Length : constant PolyORB.Types.Unsigned_Short := Unmarshall (Buffer); Equiv : String (1 .. Natural (Length) - 1); begin pragma Debug (C, O ("Unmarshall (String): enter")); pragma Debug (C, O ("Unmarshall (String): length is " & PolyORB.Types.Unsigned_Short'Image (Length))); if Length = 0 then return ""; end if; for J in Equiv'Range loop Equiv (J) := Character'Val (PolyORB.Types.Char'Pos (Unmarshall_Latin_1_Char (Buffer))); end loop; if Character'Val (PolyORB.Types.Char'Pos (Unmarshall_Latin_1_Char (Buffer))) /= ASCII.NUL then raise Constraint_Error; end if; pragma Debug (C, O ("Unmarshall (String): -> " & Equiv)); return Equiv; end Unmarshall_Latin_1_String; function Unmarshall_Latin_1_String (Buffer : access Buffer_Type) return PolyORB.Types.String is begin return PolyORB.Types.To_PolyORB_String (Unmarshall_Latin_1_String (Buffer)); end Unmarshall_Latin_1_String; ------------------------------------ -- Unmarshall-by-copy subprograms -- ------------------------------------ function Unmarshall (Buffer : access Buffer_Type) return PolyORB.Types.Boolean is begin pragma Debug (C, O ("Unmarshall (Boolean) : enter & end")); return PolyORB.Types.Boolean'Val (PolyORB.Types.Octet'(Unmarshall (Buffer))); end Unmarshall; function Swapped (X : Types.Octet) return Types.Octet; pragma Inline (Swapped); package DNS_Octet is new Align_Transfer_Elementary (T => PolyORB.Types.Octet); function Unmarshall (Buffer : access Buffer_Type) return PolyORB.Types.Octet renames DNS_Octet.Unmarshall; function Swapped (X : Types.Octet) return Types.Octet is begin return X; end Swapped; function Swapped is new GNAT.Byte_Swapping.Swapped4 (PolyORB.Types.Unsigned_Long); package DNS_Unsigned_Long is new Align_Transfer_Elementary (T => PolyORB.Types.Unsigned_Long, With_Alignment => False); function Unmarshall (Buffer : access Buffer_Type) return PolyORB.Types.Unsigned_Long renames DNS_Unsigned_Long.Unmarshall; procedure Marshall (Buffer : access Buffer_Type; Data : PolyORB.Types.Unsigned_Long) renames DNS_Unsigned_Long.Marshall; -- Unsigned_Long_Long function Swapped is new GNAT.Byte_Swapping.Swapped8 (PolyORB.Types.Unsigned_Long_Long); package DNS_Unsigned_Long_Long is new Align_Transfer_Elementary (T => PolyORB.Types.Unsigned_Long_Long); function Unmarshall (Buffer : access Buffer_Type) return PolyORB.Types.Unsigned_Long_Long renames DNS_Unsigned_Long_Long.Unmarshall; procedure Marshall (Buffer : access Buffer_Type; Data : PolyORB.Types.Unsigned_Long_Long) renames DNS_Unsigned_Long_Long.Marshall; function Swapped is new GNAT.Byte_Swapping.Swapped2 (PolyORB.Types.Unsigned_Short); package DNS_Unsigned_Short is new Align_Transfer_Elementary (T => PolyORB.Types.Unsigned_Short, With_Alignment => False); procedure Marshall (Buffer : access Buffer_Type; Data : PolyORB.Types.Unsigned_Short) renames DNS_Unsigned_Short.Marshall; function Unmarshall (Buffer : access Buffer_Type) return PolyORB.Types.Unsigned_Short renames DNS_Unsigned_Short.Unmarshall; procedure Marshall (Buffer : access Buffer_Type; Data : PolyORB.Types.Identifier) is begin pragma Debug (C, O ("Marshall (Identifier) : enter")); Marshall_Latin_1_String (Buffer, PolyORB.Types.String (Data)); pragma Debug (C, O ("Marshall (Identifier) : end")); end Marshall; function Unmarshall (Buffer : access Buffer_Type) return PolyORB.Types.Identifier is begin pragma Debug (C, O ("Unmarshall (Identifier) : enter & end")); return PolyORB.Types.Identifier (Types.String'(Unmarshall_Latin_1_String (Buffer))); end Unmarshall; procedure Initialize; procedure Initialize is begin null; end Initialize; use PolyORB.Initialization; use PolyORB.Initialization.String_Lists; use PolyORB.Utils.Strings; begin Register_Module (Module_Info' (Name => +"representations.dns", Conflicts => Empty, Depends => Empty, Provides => Empty, Implicit => False, Init => Initialize'Access, Shutdown => null)); end PolyORB.Representations.DNS; polyorb-2.8~20110207.orig/src/dns/polyorb-binding_data-dns.ads0000644000175000017500000000677011750740340023331 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . B I N D I N G _ D A T A . D N S -- -- -- -- S p e c -- -- -- -- Copyright (C) 2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with PolyORB.DNS.Transport_Mechanisms; package PolyORB.Binding_Data.DNS is package PDTM renames PolyORB.DNS.Transport_Mechanisms; type DNS_Profile_Type is abstract new Profile_Type with private; type DNS_Profile_Factory is abstract new Profile_Factory with private; procedure Bind_Profile (Profile : access DNS_Profile_Type; The_ORB : Components.Component_Access; QoS : PolyORB.QoS.QoS_Parameters; BO_Ref : out Smart_Pointers.Ref; Error : out Errors.Error_Container); procedure Release (P : in out DNS_Profile_Type); function Is_Colocated (Left : DNS_Profile_Type; Right : Profile_Type'Class) return Boolean; function Is_Local_Profile (PF : access DNS_Profile_Factory; P : access Profile_Type'Class) return Boolean; function Get_Primary_Transport_Mechanism (P : DNS_Profile_Type) return PDTM.Transport_Mechanism_Access; -- Return primary transport mechanism for profile function Get_Primary_Transport_Mechanism_Factory (P : DNS_Profile_Factory) return PDTM.Transport_Mechanism_Factory_Access; -- Return primary transport mechanism factory for profile factory. private type DNS_Profile_Type is abstract new Profile_Type with record -- Transport mechanisms list Mechanisms : PDTM.Transport_Mechanism_List; end record; type DNS_Profile_Factory is abstract new Profile_Factory with record Mechanisms : PDTM.Transport_Mechanism_Factory_List; end record; end PolyORB.Binding_Data.DNS; polyorb-2.8~20110207.orig/src/dns/polyorb-representations-dns.ads0000644000175000017500000001240511750740340024143 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . R E P R E S E N T A T I O N S . D N S -- -- -- -- S p e c -- -- -- -- Copyright (C) 2002-2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- A data representation implementing the DNS Data Representation. with PolyORB.Types; with PolyORB.Buffers; with PolyORB.Protocols.DNS; with PolyORB.Any; with PolyORB.Any.NVList; package PolyORB.Representations.DNS is use PolyORB.Types; use PolyORB.Buffers; use PolyORB.Protocols.DNS; use PolyORB.Any; use PolyORB.Any.NVList.Internals; use PolyORB.Any.NVList.Internals.NV_Lists; -- The next two subprograms marshall or unmarshall the value of -- the Any, not the Any type itself (i.e. they do not marshall Data's -- typecode). procedure Marshall_From_Any (Buffer : Buffer_Access; Argument : Any.Any; Is_Reply : Types.Boolean); procedure Unmarshall_To_Any (Buffer : Buffer_Access; Arg : Any.Any; Length : Integer; Is_Reply : Types.Boolean); -- 'Boolean' type procedure Marshall (Buffer : access Buffer_Type; Data : PolyORB.Types.Boolean); function Unmarshall (Buffer : access Buffer_Type) return PolyORB.Types.Boolean; -- 'Octet' type procedure Marshall (Buffer : access Buffer_Type; Data : PolyORB.Types.Octet); function Unmarshall (Buffer : access Buffer_Type) return PolyORB.Types.Octet; -- 'Unsigned_Long' type procedure Marshall (Buffer : access Buffer_Type; Data : PolyORB.Types.Unsigned_Long); function Unmarshall (Buffer : access Buffer_Type) return PolyORB.Types.Unsigned_Long; -- 'Unsigned_Long_Long' type procedure Marshall (Buffer : access Buffer_Type; Data : PolyORB.Types.Unsigned_Long_Long); function Unmarshall (Buffer : access Buffer_Type) return PolyORB.Types.Unsigned_Long_Long; -- 'Unsigned_Short' type procedure Marshall (Buffer : access Buffer_Type; Data : PolyORB.Types.Unsigned_Short); function Unmarshall (Buffer : access Buffer_Type) return PolyORB.Types.Unsigned_Short ; -- 'String' type procedure Marshall_DNS_String (Buffer : access Buffer_Type; Data : Standard.String); procedure Marshall_TXT_String (Buffer : access Buffer_Type; Data : Standard.String); function Unmarshall_TXT_String (Buffer : access Buffer_Type; Data_Length : PolyORB.Types.Unsigned_Short) return PolyORB.Types.String; procedure Marshall_Latin_1_String (Buffer : access Buffer_Type; Data : Standard.String); procedure Marshall_Latin_1_String (Buffer : access Buffer_Type; Data : PolyORB.Types.String); function Unmarshall_Latin_1_String (Buffer : access Buffer_Type) return Standard.String; function Unmarshall_Latin_1_String (Buffer : access Buffer_Type) return PolyORB.Types.String; function Unmarshall_DNS_String (Buffer : access Buffer_Type) return PolyORB.Types.String; procedure Marshall_Latin_1_Char (Buffer : access Buffer_Type; Data : PolyORB.Types.Char); function Unmarshall_Latin_1_Char (Buffer : access Buffer_Type) return PolyORB.Types.Char; -- Identifier type procedure Marshall (Buffer : access Buffer_Type; Data : PolyORB.Types.Identifier); function Unmarshall (Buffer : access Buffer_Type) return PolyORB.Types.Identifier; end PolyORB.Representations.DNS; polyorb-2.8~20110207.orig/src/dns/polyorb-dns-helper.ads0000644000175000017500000003710511750740340022201 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . D N S . H E L P E R -- -- -- -- S p e c -- -- -- -- Copyright (C) 2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with PolyORB.Types; with PolyORB.Sequences.Unbounded; with PolyORB.Sequences.Unbounded.Helper; with PolyORB.Sequences.Bounded; with PolyORB.Sequences.Bounded.Helper; pragma Elaborate_All (PolyORB.Sequences.Unbounded.Helper, PolyORB.Sequences.Bounded.Helper); with PolyORB.Any; package PolyORB.DNS.Helper is -- Rcode type definition type Rcode is (No_Error, Format_Error, Server_Failure, Name_Error, Not_Implemented, Refused, YX_Domain, YX_RRSet, NX_RRSet, Not_Auth, Not_Zone); -- Rcode constant code values , -- defined by IANA, ref: [RFC 5395] [RFC 1035] No_Error_Code : constant Types.Unsigned_Short := 0; Format_Error_Code : constant Types.Unsigned_Short := 1; Server_Failure_Code : constant Types.Unsigned_Short := 2; Name_Error_Code : constant Types.Unsigned_Short := 3; Not_Implemented_Code : constant Types.Unsigned_Short := 4; Refused_Code : constant Types.Unsigned_Short := 5; YX_Domain_Code : constant Types.Unsigned_Short := 6; YX_RRSet_Code : constant Types.Unsigned_Short := 7; NX_RRSet_Code : constant Types.Unsigned_Short := 8; Not_Auth_Code : constant Types.Unsigned_Short := 9; Not_Zone_Code : constant Types.Unsigned_Short := 10; type Opcode_Type is (Query, IQuery, Status ); -- Opcode operation name definition Query_Name : constant Standard.String := "Query"; IQuery_Name : constant Standard.String := "IQuery"; Status_Name : constant Standard.String := "Status"; type RR_Type is (A, NS, SOA, CNAME, PTR, TXT, SRV); -- Resource Record (RR) TYPEs constant code values -- ,defined by IANA, ref: [RFC 5395] [RFC 1035] A_Code : constant Types.Unsigned_Short := 1; NS_Code : constant Types.Unsigned_Short := 2; SOA_Code : constant Types.Unsigned_Short := 6; CNAME_Code : constant Types.Unsigned_Short := 5; PTR_Code : constant Types.Unsigned_Short := 12; TXT_Code : constant Types.Unsigned_Short := 16; SRV_Code : constant Types.Unsigned_Short := 33; Default_Class_Code : constant Types.Unsigned_Short := 1; Arg_Name_Auth : constant PolyORB.Types.Identifier := PolyORB.Types.To_PolyORB_String ("authoritative"); Arg_Name_Question : constant PolyORB.Types.Identifier := PolyORB.Types.To_PolyORB_String ("question"); Arg_Name_Answer : constant PolyORB.Types.Identifier := PolyORB.Types.To_PolyORB_String ("answer"); Arg_Name_Au : constant PolyORB.Types.Identifier := PolyORB.Types.To_PolyORB_String ("authority"); Arg_Name_Add : constant PolyORB.Types.Identifier := PolyORB.Types.To_PolyORB_String ("additional"); type SRV_Data is record priority : PolyORB.Types.Unsigned_Short; weight : PolyORB.Types.Unsigned_Short; port : PolyORB.Types.Unsigned_Short; target : PolyORB.Types.String; end record; package IDL_SEQUENCE_4_octet is new PolyORB.Sequences.Bounded (PolyORB.Types.Octet, 4); type IDL_AT_Sequence_4_octet is new IDL_SEQUENCE_4_octet.Sequence; type RR_Data (Switch : RR_Type := RR_Type'First) is record case Switch is when SRV => srv_data : PolyORB.DNS.Helper.SRV_Data; when A => a_address : IDL_AT_Sequence_4_octet; when others => rr_answer : PolyORB.Types.String; end case; end record; type RR is record rr_name : PolyORB.Types.String; rr_type : PolyORB.DNS.Helper.RR_Type; TTL : PolyORB.Types.Unsigned_Long; data_length : PolyORB.Types.Unsigned_Short; rr_data : PolyORB.DNS.Helper.RR_Data; end record; package IDL_SEQUENCE_DNS_RR is new PolyORB.Sequences.Unbounded (RR); type rrSequence is new IDL_SEQUENCE_DNS_RR.Sequence; TC_RR_Type : PolyORB.Any.TypeCode.Local_Ref; function From_Any (Item : PolyORB.Any.Any) return RR_Type; function To_Any (Item : RR_Type) return PolyORB.Any.Any; TC_SRV_Data : PolyORB.Any.TypeCode.Local_Ref; function From_Any (Item : PolyORB.Any.Any) return SRV_Data; function To_Any (Item : SRV_Data) return PolyORB.Any.Any; TC_IDL_SEQUENCE_4_octet : PolyORB.Any.TypeCode.Local_Ref; function From_Any (Item : PolyORB.Any.Any) return IDL_SEQUENCE_4_octet.Sequence; function To_Any (Item : IDL_SEQUENCE_4_octet.Sequence) return PolyORB.Any.Any; TC_IDL_AT_Sequence_4_octet : PolyORB.Any.TypeCode.Local_Ref; function From_Any (Item : PolyORB.Any.Any) return IDL_AT_Sequence_4_octet; function To_Any (Item : IDL_AT_Sequence_4_octet) return PolyORB.Any.Any; TC_RR_Data : PolyORB.Any.TypeCode.Local_Ref; function From_Any (Item : PolyORB.Any.Any) return RR_Data; function To_Any (Item : RR_Data) return PolyORB.Any.Any; TC_RR : PolyORB.Any.TypeCode.Local_Ref; function From_Any (Item : PolyORB.Any.Any) return RR; function To_Any (Item : RR) return PolyORB.Any.Any; TC_Rcode : PolyORB.Any.TypeCode.Local_Ref; function From_Any (Item : PolyORB.Any.Any) return Rcode; function To_Any (Item : Rcode) return PolyORB.Any.Any; TC_IDL_SEQUENCE_DNS_RR : PolyORB.Any.TypeCode.Local_Ref; function From_Any (Item : PolyORB.Any.Any) return IDL_SEQUENCE_DNS_RR.Sequence; function To_Any (Item : IDL_SEQUENCE_DNS_RR.Sequence) return PolyORB.Any.Any; TC_rrSequence : PolyORB.Any.TypeCode.Local_Ref; function From_Any (Item : PolyORB.Any.Any) return rrSequence; function To_Any (Item : rrSequence) return PolyORB.Any.Any; package Internals is function From_Any (C : PolyORB.Any.Any_Container'Class) return RR_Type; type Ptr_RR_Type is access all RR_Type; type Content_RR_Type is new PolyORB.Any.Aggregate_Content with record V : Ptr_RR_Type; Repr_Cache : aliased PolyORB.Types.Unsigned_Long; end record; function Get_Aggregate_Element (Acc : not null access Content_RR_Type; Tc : PolyORB.Any.TypeCode.Object_Ptr; Index : PolyORB.Types.Unsigned_Long; Mech : not null access PolyORB.Any.Mechanism) return PolyORB.Any.Content'Class; procedure Set_Aggregate_Element (Acc : in out Content_RR_Type; Tc : PolyORB.Any.TypeCode.Object_Ptr; Index : PolyORB.Types.Unsigned_Long; From_C : in out PolyORB.Any.Any_Container'Class); function Get_Aggregate_Count (Acc : Content_RR_Type) return PolyORB.Types.Unsigned_Long; procedure Set_Aggregate_Count (Acc : in out Content_RR_Type; Count : PolyORB.Types.Unsigned_Long); function Unchecked_Get_V (Acc : not null access Content_RR_Type) return PolyORB.Types.Address; function Clone (Acc : Content_RR_Type; Into : PolyORB.Any.Content_Ptr := null) return PolyORB.Any.Content_Ptr; procedure Finalize_Value (Acc : in out Content_RR_Type); function Wrap (X : access RR_Type) return PolyORB.Any.Content'Class; procedure Initialize_RR_Type; type Ptr_SRV_Data is access all SRV_Data; type Content_SRV_Data is new PolyORB.Any.Aggregate_Content with record V : Ptr_SRV_Data; end record; function Get_Aggregate_Element (Acc : not null access Content_SRV_Data; Tc : PolyORB.Any.TypeCode.Object_Ptr; Index : PolyORB.Types.Unsigned_Long; Mech : not null access PolyORB.Any.Mechanism) return PolyORB.Any.Content'Class; function Get_Aggregate_Count (Acc : Content_SRV_Data) return PolyORB.Types.Unsigned_Long; procedure Set_Aggregate_Count (Acc : in out Content_SRV_Data; Count : PolyORB.Types.Unsigned_Long); function Unchecked_Get_V (Acc : not null access Content_SRV_Data) return PolyORB.Types.Address; function Clone (Acc : Content_SRV_Data; Into : PolyORB.Any.Content_Ptr := null) return PolyORB.Any.Content_Ptr; procedure Finalize_Value (Acc : in out Content_SRV_Data); function Wrap (X : access SRV_Data) return PolyORB.Any.Content'Class; procedure Initialize_SRV_Data; function IDL_SEQUENCE_4_octet_Element_Wrap (X : access PolyORB.Types.Octet) return PolyORB.Any.Content'Class; function Wrap (X : access IDL_SEQUENCE_4_octet.Sequence) return PolyORB.Any.Content'Class; package IDL_SEQUENCE_4_octet_Helper is new IDL_SEQUENCE_4_octet.Helper (Element_From_Any => PolyORB.Any.From_Any, Element_To_Any => PolyORB.Any.To_Any, Element_Wrap => Helper.Internals.IDL_SEQUENCE_4_octet_Element_Wrap); procedure Initialize_IDL_SEQUENCE_4_octet; procedure Initialize_IDL_AT_Sequence_4_octet; type Ptr_RR_Data is access all RR_Data; type Content_RR_Data is new PolyORB.Any.Aggregate_Content with record V : Ptr_RR_Data; Switch_Cache : aliased RR_Type; end record; function Get_Aggregate_Element (Acc : not null access Content_RR_Data; Tc : PolyORB.Any.TypeCode.Object_Ptr; Index : PolyORB.Types.Unsigned_Long; Mech : not null access PolyORB.Any.Mechanism) return PolyORB.Any.Content'Class; procedure Set_Aggregate_Element (Acc : in out Content_RR_Data; Tc : PolyORB.Any.TypeCode.Object_Ptr; Index : PolyORB.Types.Unsigned_Long; From_C : in out PolyORB.Any.Any_Container'Class); function Get_Aggregate_Count (Acc : Content_RR_Data) return PolyORB.Types.Unsigned_Long; procedure Set_Aggregate_Count (Acc : in out Content_RR_Data; Count : PolyORB.Types.Unsigned_Long); function Unchecked_Get_V (Acc : not null access Content_RR_Data) return PolyORB.Types.Address; function Clone (Acc : Content_RR_Data; Into : PolyORB.Any.Content_Ptr := null) return PolyORB.Any.Content_Ptr; procedure Finalize_Value (Acc : in out Content_RR_Data); function Wrap (X : access RR_Data) return PolyORB.Any.Content'Class; procedure Initialize_RR_Data; type Ptr_RR is access all RR; type Content_RR is new PolyORB.Any.Aggregate_Content with record V : Ptr_RR; end record; function Get_Aggregate_Element (Acc : not null access Content_RR; Tc : PolyORB.Any.TypeCode.Object_Ptr; Index : PolyORB.Types.Unsigned_Long; Mech : not null access PolyORB.Any.Mechanism) return PolyORB.Any.Content'Class; function Get_Aggregate_Count (Acc : Content_RR) return PolyORB.Types.Unsigned_Long; procedure Set_Aggregate_Count (Acc : in out Content_RR; Count : PolyORB.Types.Unsigned_Long); function Unchecked_Get_V (Acc : not null access Content_RR) return PolyORB.Types.Address; function Clone (Acc : Content_RR; Into : PolyORB.Any.Content_Ptr := null) return PolyORB.Any.Content_Ptr; procedure Finalize_Value (Acc : in out Content_RR); function Wrap (X : access RR) return PolyORB.Any.Content'Class; procedure Initialize_RR; function From_Any (C : PolyORB.Any.Any_Container'Class) return Rcode; type Ptr_Rcode is access all Rcode; type Content_Rcode is new PolyORB.Any.Aggregate_Content with record V : Ptr_Rcode; Repr_Cache : aliased PolyORB.Types.Unsigned_Long; end record; function Get_Aggregate_Element (Acc : not null access Content_Rcode; Tc : PolyORB.Any.TypeCode.Object_Ptr; Index : PolyORB.Types.Unsigned_Long; Mech : not null access PolyORB.Any.Mechanism) return PolyORB.Any.Content'Class; procedure Set_Aggregate_Element (Acc : in out Content_Rcode; Tc : PolyORB.Any.TypeCode.Object_Ptr; Index : PolyORB.Types.Unsigned_Long; From_C : in out PolyORB.Any.Any_Container'Class); function Get_Aggregate_Count (Acc : Content_Rcode) return PolyORB.Types.Unsigned_Long; procedure Set_Aggregate_Count (Acc : in out Content_Rcode; Count : PolyORB.Types.Unsigned_Long); function Unchecked_Get_V (Acc : not null access Content_Rcode) return PolyORB.Types.Address; function Clone (Acc : Content_Rcode; Into : PolyORB.Any.Content_Ptr := null) return PolyORB.Any.Content_Ptr; procedure Finalize_Value (Acc : in out Content_Rcode); function Wrap (X : access Rcode) return PolyORB.Any.Content'Class; procedure Initialize_Rcode; function IDL_SEQUENCE_DNS_RR_Element_Wrap (X : access RR) return PolyORB.Any.Content'Class; function Wrap (X : access IDL_SEQUENCE_DNS_RR.Sequence) return PolyORB.Any.Content'Class; package IDL_SEQUENCE_DNS_RR_Helper is new IDL_SEQUENCE_DNS_RR.Helper (Element_From_Any => Helper.From_Any, Element_To_Any => Helper.To_Any, Element_Wrap => Helper.Internals.IDL_SEQUENCE_DNS_RR_Element_Wrap); procedure Initialize_IDL_SEQUENCE_DNS_RR; procedure Initialize_rrSequence; end Internals; end PolyORB.DNS.Helper; polyorb-2.8~20110207.orig/src/dns/polyorb-dns-helper.adb0000644000175000017500000015613011750740340022160 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . D N S . H E L P E R -- -- -- -- B o d y -- -- -- -- Copyright (C) 2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with PolyORB.Log; with PolyORB.Initialization; with PolyORB.Utils.Strings; with Ada.Unchecked_Deallocation; with Ada.Unchecked_Conversion; package body PolyORB.DNS.Helper is use PolyORB.Log; package L is new PolyORB.Log.Facility_Log ("polyorb.dns.helper"); procedure O (Message : String; Level : Log_Level := Debug) renames L.Output; function C (Level : Log_Level := Debug) return Boolean renames L.Enabled; package body Internals is -------------- -- From_Any -- -------------- function From_Any (C : PolyORB.Any.Any_Container'Class) return RR_Type is begin return RR_Type'Val (PolyORB.Types.Unsigned_Long' (PolyORB.Any.Get_Aggregate_Element (C, 0))); end From_Any; --------------------------- -- Get_Aggregate_Element -- --------------------------- function Get_Aggregate_Element (Acc : not null access Content_RR_Type; Tc : PolyORB.Any.TypeCode.Object_Ptr; Index : PolyORB.Types.Unsigned_Long; Mech : not null access PolyORB.Any.Mechanism) return PolyORB.Any.Content'Class is use type PolyORB.Types.Unsigned_Long; use type PolyORB.Any.Mechanism; pragma Suppress (Validity_Check); pragma Unreferenced (Tc, Index); begin Acc.Repr_Cache := RR_Type'Pos (Acc.V.all); Mech.all := PolyORB.Any.By_Value; return PolyORB.Any.Wrap (Acc.Repr_Cache'Unrestricted_Access); end Get_Aggregate_Element; --------------------------- -- Set_Aggregate_Element -- --------------------------- procedure Set_Aggregate_Element (Acc : in out Content_RR_Type; Tc : PolyORB.Any.TypeCode.Object_Ptr; Index : PolyORB.Types.Unsigned_Long; From_C : in out PolyORB.Any.Any_Container'Class) is use type PolyORB.Types.Unsigned_Long; pragma Assert ((Index = 0)); pragma Unreferenced (Tc); begin Acc.V.all := RR_Type'Val (PolyORB.Types.Unsigned_Long' (PolyORB.Any.From_Any (From_C))); end Set_Aggregate_Element; ------------------------- -- Get_Aggregate_Count -- ------------------------- function Get_Aggregate_Count (Acc : Content_RR_Type) return PolyORB.Types.Unsigned_Long is pragma Unreferenced (Acc); begin return 1; end Get_Aggregate_Count; ------------------------- -- Set_Aggregate_Count -- ------------------------- procedure Set_Aggregate_Count (Acc : in out Content_RR_Type; Count : PolyORB.Types.Unsigned_Long) is begin null; end Set_Aggregate_Count; --------------------- -- Unchecked_Get_V -- --------------------- function Unchecked_Get_V (Acc : not null access Content_RR_Type) return PolyORB.Types.Address is function To_Address is new Ada.Unchecked_Conversion (Ptr_RR_Type, PolyORB.Types.Address); begin return To_Address (Acc.V); end Unchecked_Get_V; ----------- -- Clone -- ----------- function Clone (Acc : Content_RR_Type; Into : PolyORB.Any.Content_Ptr := null) return PolyORB.Any.Content_Ptr is use type PolyORB.Any.Content_Ptr; Target : PolyORB.Any.Content_Ptr; begin if Into /= null then if Into.all not in Content_RR_Type then return null; end if; Target := Into; Content_RR_Type (Target.all).V.all := Acc.V.all; else Target := new Content_RR_Type; Content_RR_Type (Target.all).V := new RR_Type' (Acc.V.all); end if; Content_RR_Type (Target.all).Repr_Cache := Acc.Repr_Cache; return Target; end Clone; -------------------- -- Finalize_Value -- -------------------- procedure Finalize_Value (Acc : in out Content_RR_Type) is procedure Free is new Ada.Unchecked_Deallocation (RR_Type, Ptr_RR_Type); begin Free (Acc.V); end Finalize_Value; ---------- -- Wrap -- ---------- function Wrap (X : access RR_Type) return PolyORB.Any.Content'Class is begin return Content_RR_Type' (PolyORB.Any.Aggregate_Content with V => Ptr_RR_Type (X), Repr_Cache => 0); end Wrap; RR_Type_Initialized : PolyORB.Types.Boolean := False; ------------------------ -- Initialize_RR_Type -- ------------------------ procedure Initialize_RR_Type is Name : constant PolyORB.Types.String := PolyORB.Types.To_PolyORB_String ("RR_Type"); Id : constant PolyORB.Types.String := PolyORB.Types.To_PolyORB_String ("IDL:DNS/RR_Type:1.0"); A_Name : constant PolyORB.Types.String := PolyORB.Types.To_PolyORB_String ("A"); NS_Name : constant PolyORB.Types.String := PolyORB.Types.To_PolyORB_String ("NS"); SOA_Name : constant PolyORB.Types.String := PolyORB.Types.To_PolyORB_String ("SOA"); CNAME_Name : constant PolyORB.Types.String := PolyORB.Types.To_PolyORB_String ("CNAME"); PTR_Name : constant PolyORB.Types.String := PolyORB.Types.To_PolyORB_String ("PTR"); TXT_Name : constant PolyORB.Types.String := PolyORB.Types.To_PolyORB_String ("TXT"); SRV_Name : constant PolyORB.Types.String := PolyORB.Types.To_PolyORB_String ("SRV"); begin if not RR_Type_Initialized then RR_Type_Initialized := True; TC_RR_Type := PolyORB.Any.TypeCode.TC_Enum; PolyORB.Any.TypeCode.Add_Parameter (TC_RR_Type, PolyORB.Any.To_Any (Name)); PolyORB.Any.TypeCode.Add_Parameter (TC_RR_Type, PolyORB.Any.To_Any (Id)); PolyORB.Any.TypeCode.Add_Parameter (TC_RR_Type, PolyORB.Any.To_Any (A_Name)); PolyORB.Any.TypeCode.Add_Parameter (TC_RR_Type, PolyORB.Any.To_Any (NS_Name)); PolyORB.Any.TypeCode.Add_Parameter (TC_RR_Type, PolyORB.Any.To_Any (SOA_Name)); PolyORB.Any.TypeCode.Add_Parameter (TC_RR_Type, PolyORB.Any.To_Any (CNAME_Name)); PolyORB.Any.TypeCode.Add_Parameter (TC_RR_Type, PolyORB.Any.To_Any (PTR_Name)); PolyORB.Any.TypeCode.Add_Parameter (TC_RR_Type, PolyORB.Any.To_Any (TXT_Name)); PolyORB.Any.TypeCode.Add_Parameter (TC_RR_Type, PolyORB.Any.To_Any (SRV_Name)); Any.TypeCode.Disable_Reference_Counting (Any.TypeCode.Object_Of (TC_RR_Type).all); end if; end Initialize_RR_Type; --------------------------- -- Get_Aggregate_Element -- --------------------------- function Get_Aggregate_Element (Acc : not null access Content_SRV_Data; Tc : PolyORB.Any.TypeCode.Object_Ptr; Index : PolyORB.Types.Unsigned_Long; Mech : not null access PolyORB.Any.Mechanism) return PolyORB.Any.Content'Class is use type PolyORB.Types.Unsigned_Long; use type PolyORB.Any.Mechanism; pragma Suppress (Validity_Check); pragma Unreferenced (Tc); begin Mech.all := PolyORB.Any.By_Reference; case Index is when 0 => return PolyORB.Any.Wrap (Acc.V.priority'Unrestricted_Access); when 1 => return PolyORB.Any.Wrap (Acc.V.weight'Unrestricted_Access); when 2 => return PolyORB.Any.Wrap (Acc.V.port'Unrestricted_Access); when 3 => return PolyORB.Any.Wrap (Acc.V.target'Unrestricted_Access); pragma Warnings (Off); when others => raise Constraint_Error; pragma Warnings (On); end case; end Get_Aggregate_Element; ------------------------- -- Get_Aggregate_Count -- ------------------------- function Get_Aggregate_Count (Acc : Content_SRV_Data) return PolyORB.Types.Unsigned_Long is pragma Unreferenced (Acc); begin return 4; end Get_Aggregate_Count; ------------------------- -- Set_Aggregate_Count -- ------------------------- procedure Set_Aggregate_Count (Acc : in out Content_SRV_Data; Count : PolyORB.Types.Unsigned_Long) is begin null; end Set_Aggregate_Count; --------------------- -- Unchecked_Get_V -- --------------------- function Unchecked_Get_V (Acc : not null access Content_SRV_Data) return PolyORB.Types.Address is function To_Address is new Ada.Unchecked_Conversion (Ptr_SRV_Data, PolyORB.Types.Address); begin return To_Address (Acc.V); end Unchecked_Get_V; ----------- -- Clone -- ----------- function Clone (Acc : Content_SRV_Data; Into : PolyORB.Any.Content_Ptr := null) return PolyORB.Any.Content_Ptr is use type PolyORB.Any.Content_Ptr; Target : PolyORB.Any.Content_Ptr; begin if Into /= null then if Into.all not in Content_SRV_Data then return null; end if; Target := Into; Content_SRV_Data (Target.all).V.all := Acc.V.all; else Target := new Content_SRV_Data; Content_SRV_Data (Target.all).V := new SRV_Data' (Acc.V.all); end if; return Target; end Clone; -------------------- -- Finalize_Value -- -------------------- procedure Finalize_Value (Acc : in out Content_SRV_Data) is procedure Free is new Ada.Unchecked_Deallocation (SRV_Data, Ptr_SRV_Data); begin Free (Acc.V); end Finalize_Value; ---------- -- Wrap -- ---------- function Wrap (X : access SRV_Data) return PolyORB.Any.Content'Class is begin return Content_SRV_Data' (PolyORB.Any.Aggregate_Content with V => Ptr_SRV_Data (X)); end Wrap; SRV_Data_Initialized : PolyORB.Types.Boolean := False; ------------------------- -- Initialize_SRV_Data -- ------------------------- procedure Initialize_SRV_Data is Name : constant PolyORB.Types.String := PolyORB.Types.To_PolyORB_String ("SRV_Data"); Id : constant PolyORB.Types.String := PolyORB.Types.To_PolyORB_String ("IDL:DNS/SRV_Data:1.0"); Argument_Name_priority : constant PolyORB.Types.String := PolyORB.Types.To_PolyORB_String ("priority"); Argument_Name_weight : constant PolyORB.Types.String := PolyORB.Types.To_PolyORB_String ("weight"); Argument_Name_port : constant PolyORB.Types.String := PolyORB.Types.To_PolyORB_String ("port"); Argument_Name_target : constant PolyORB.Types.String := PolyORB.Types.To_PolyORB_String ("target"); begin if not SRV_Data_Initialized then SRV_Data_Initialized := True; Helper.TC_SRV_Data := PolyORB.Any.TypeCode.TC_Struct; PolyORB.Any.TypeCode.Add_Parameter (TC_SRV_Data, PolyORB.Any.To_Any (Name)); PolyORB.Any.TypeCode.Add_Parameter (TC_SRV_Data, PolyORB.Any.To_Any (Id)); PolyORB.Any.TypeCode.Add_Parameter (TC_SRV_Data, PolyORB.Any.To_Any (PolyORB.Any.TC_Unsigned_Short)); PolyORB.Any.TypeCode.Add_Parameter (TC_SRV_Data, PolyORB.Any.To_Any (Argument_Name_priority)); PolyORB.Any.TypeCode.Add_Parameter (TC_SRV_Data, PolyORB.Any.To_Any (PolyORB.Any.TC_Unsigned_Short)); PolyORB.Any.TypeCode.Add_Parameter (TC_SRV_Data, PolyORB.Any.To_Any (Argument_Name_weight)); PolyORB.Any.TypeCode.Add_Parameter (TC_SRV_Data, PolyORB.Any.To_Any (PolyORB.Any.TC_Unsigned_Short)); PolyORB.Any.TypeCode.Add_Parameter (TC_SRV_Data, PolyORB.Any.To_Any (Argument_Name_port)); PolyORB.Any.TypeCode.Add_Parameter (TC_SRV_Data, PolyORB.Any.To_Any (PolyORB.Any.TC_String)); PolyORB.Any.TypeCode.Add_Parameter (TC_SRV_Data, PolyORB.Any.To_Any (Argument_Name_target)); Any.TypeCode.Disable_Reference_Counting (Any.TypeCode.Object_Of (TC_SRV_Data).all); end if; end Initialize_SRV_Data; IDL_SEQUENCE_4_octet_Initialized : PolyORB.Types.Boolean := False; --------------------------------------- -- IDL_SEQUENCE_4_octet_Element_Wrap -- --------------------------------------- function IDL_SEQUENCE_4_octet_Element_Wrap (X : access PolyORB.Types.Octet) return PolyORB.Any.Content'Class is begin return PolyORB.Any.Wrap (X.all'Unrestricted_Access); end IDL_SEQUENCE_4_octet_Element_Wrap; function Wrap (X : access IDL_SEQUENCE_4_octet.Sequence) return PolyORB.Any.Content'Class renames IDL_SEQUENCE_4_octet_Helper.Wrap; ------------------------------------- -- Initialize_IDL_SEQUENCE_4_octet -- ------------------------------------- procedure Initialize_IDL_SEQUENCE_4_octet is begin if not IDL_SEQUENCE_4_octet_Initialized then IDL_SEQUENCE_4_octet_Initialized := True; Helper.TC_IDL_SEQUENCE_4_octet := PolyORB.Any.TypeCode.Build_Sequence_TC (PolyORB.Any.TC_Octet, 4); Any.TypeCode.Disable_Reference_Counting (Any.TypeCode.Object_Of (TC_IDL_SEQUENCE_4_octet).all); IDL_SEQUENCE_4_octet_Helper.Initialize (Element_TC => PolyORB.Any.TC_Octet, Sequence_TC => Helper.TC_IDL_SEQUENCE_4_octet); end if; end Initialize_IDL_SEQUENCE_4_octet; IDL_AT_Sequence_4_octet_Initialized : PolyORB.Types.Boolean := False; ---------------------------------------- -- Initialize_IDL_AT_Sequence_4_octet -- ---------------------------------------- procedure Initialize_IDL_AT_Sequence_4_octet is Name : constant PolyORB.Types.String := PolyORB.Types.To_PolyORB_String ("IDL_AT_Sequence_4_octet"); Id : constant PolyORB.Types.String := PolyORB.Types.To_PolyORB_String ("IDL:DNS/IDL_AT_Sequence_4_octet:1.0"); begin if not IDL_AT_Sequence_4_octet_Initialized then IDL_AT_Sequence_4_octet_Initialized := True; Helper.Internals.Initialize_IDL_SEQUENCE_4_octet; TC_IDL_AT_Sequence_4_octet := PolyORB.Any.TypeCode.TC_Alias; Any.TypeCode.Add_Parameter (TC_IDL_AT_Sequence_4_octet, Any.To_Any (Name)); Any.TypeCode.Add_Parameter (TC_IDL_AT_Sequence_4_octet, Any.To_Any (Id)); Any.TypeCode.Add_Parameter (TC_IDL_AT_Sequence_4_octet, Any.To_Any (TC_IDL_SEQUENCE_4_octet)); Any.TypeCode.Disable_Reference_Counting (Any.TypeCode.Object_Of (TC_IDL_AT_Sequence_4_octet).all); end if; end Initialize_IDL_AT_Sequence_4_octet; --------------------------- -- Get_Aggregate_Element -- --------------------------- function Get_Aggregate_Element (Acc : not null access Content_RR_Data; Tc : PolyORB.Any.TypeCode.Object_Ptr; Index : PolyORB.Types.Unsigned_Long; Mech : not null access PolyORB.Any.Mechanism) return PolyORB.Any.Content'Class is use type PolyORB.Types.Unsigned_Long; use type PolyORB.Any.Mechanism; pragma Suppress (Validity_Check); pragma Unreferenced (Tc); begin if Index = 0 then Mech.all := PolyORB.Any.By_Value; Acc.Switch_Cache := Acc.V.Switch; return Helper.Internals.Wrap (Acc.Switch_Cache'Unrestricted_Access); else pragma Assert ((Index = 1)); Mech.all := PolyORB.Any.By_Reference; case Acc.V.Switch is when SRV => return Helper.Internals.Wrap (Acc.V.srv_data'Unrestricted_Access); when A => return Helper.Internals.Wrap (IDL_SEQUENCE_4_octet.Sequence (Acc.V.a_address)'Unrestricted_Access); pragma Warnings (Off); when others => return PolyORB.Any.Wrap (Acc.V.rr_answer'Unrestricted_Access); pragma Warnings (On); end case; end if; end Get_Aggregate_Element; --------------------------- -- Set_Aggregate_Element -- --------------------------- procedure Set_Aggregate_Element (Acc : in out Content_RR_Data; Tc : PolyORB.Any.TypeCode.Object_Ptr; Index : PolyORB.Types.Unsigned_Long; From_C : in out PolyORB.Any.Any_Container'Class) is use type PolyORB.Types.Unsigned_Long; pragma Assert ((Index = 0)); New_Switch : constant RR_Type := Helper.Internals.From_Any (From_C); New_Union : RR_Data (Switch => New_Switch); -- Use default initialization pragma Warnings (Off, New_Union); pragma Suppress (Discriminant_Check); pragma Unreferenced (Tc); begin Acc.V.all := New_Union; end Set_Aggregate_Element; ------------------------- -- Get_Aggregate_Count -- ------------------------- function Get_Aggregate_Count (Acc : Content_RR_Data) return PolyORB.Types.Unsigned_Long is pragma Unreferenced (Acc); begin return 2; end Get_Aggregate_Count; ------------------------- -- Set_Aggregate_Count -- ------------------------- procedure Set_Aggregate_Count (Acc : in out Content_RR_Data; Count : PolyORB.Types.Unsigned_Long) is begin null; end Set_Aggregate_Count; --------------------- -- Unchecked_Get_V -- --------------------- function Unchecked_Get_V (Acc : not null access Content_RR_Data) return PolyORB.Types.Address is function To_Address is new Ada.Unchecked_Conversion (Ptr_RR_Data, PolyORB.Types.Address); begin return To_Address (Acc.V); end Unchecked_Get_V; ----------- -- Clone -- ----------- function Clone (Acc : Content_RR_Data; Into : PolyORB.Any.Content_Ptr := null) return PolyORB.Any.Content_Ptr is use type PolyORB.Any.Content_Ptr; Target : PolyORB.Any.Content_Ptr; pragma Suppress (Discriminant_Check); begin if Into /= null then if Into.all not in Content_RR_Data then return null; end if; Target := Into; Content_RR_Data (Target.all).V.all := Acc.V.all; else Target := new Content_RR_Data; Content_RR_Data (Target.all).V := new RR_Data' (Acc.V.all); end if; Content_RR_Data (Target.all).Switch_Cache := Acc.Switch_Cache; return Target; end Clone; -------------------- -- Finalize_Value -- -------------------- procedure Finalize_Value (Acc : in out Content_RR_Data) is procedure Free is new Ada.Unchecked_Deallocation (RR_Data, Ptr_RR_Data); begin Free (Acc.V); end Finalize_Value; ---------- -- Wrap -- ---------- function Wrap (X : access RR_Data) return PolyORB.Any.Content'Class is begin return Content_RR_Data' (PolyORB.Any.Aggregate_Content with V => Ptr_RR_Data (X), Switch_Cache => X.Switch); end Wrap; RR_Data_Initialized : PolyORB.Types.Boolean := False; ------------------------ -- Initialize_RR_Data -- ------------------------ procedure Initialize_RR_Data is Name : constant PolyORB.Types.String := PolyORB.Types.To_PolyORB_String ("RR_Data"); Id : constant PolyORB.Types.String := PolyORB.Types.To_PolyORB_String ("IDL:DNS/RR_Data:1.0"); Argument_Name_srv_data : constant PolyORB.Types.String := PolyORB.Types.To_PolyORB_String ("srv_data"); Argument_Name_a_address : constant PolyORB.Types.String := PolyORB.Types.To_PolyORB_String ("a_address"); Argument_Name_rr_answer : constant PolyORB.Types.String := PolyORB.Types.To_PolyORB_String ("rr_answer"); begin if not RR_Data_Initialized then RR_Data_Initialized := True; Helper.TC_RR_Data := PolyORB.Any.TypeCode.TC_Union; PolyORB.Any.TypeCode.Add_Parameter (TC_RR_Data, PolyORB.Any.To_Any (Name)); PolyORB.Any.TypeCode.Add_Parameter (TC_RR_Data, PolyORB.Any.To_Any (Id)); Helper.Internals.Initialize_RR_Type; PolyORB.Any.TypeCode.Add_Parameter (TC_RR_Data, PolyORB.Any.To_Any (Helper.TC_RR_Type)); Helper.Internals.Initialize_SRV_Data; Helper.Internals.Initialize_IDL_AT_Sequence_4_octet; PolyORB.Any.TypeCode.Add_Parameter (TC_RR_Data, PolyORB.Any.To_Any (PolyORB.Types.Long (2))); PolyORB.Any.TypeCode.Add_Parameter (TC_RR_Data, Helper.To_Any (RR_Type' (SRV))); PolyORB.Any.TypeCode.Add_Parameter (TC_RR_Data, PolyORB.Any.To_Any (Helper.TC_SRV_Data)); PolyORB.Any.TypeCode.Add_Parameter (TC_RR_Data, PolyORB.Any.To_Any (Argument_Name_srv_data)); PolyORB.Any.TypeCode.Add_Parameter (TC_RR_Data, Helper.To_Any (RR_Type' (A))); PolyORB.Any.TypeCode.Add_Parameter (TC_RR_Data, PolyORB.Any.To_Any (Helper.TC_IDL_AT_Sequence_4_octet)); PolyORB.Any.TypeCode.Add_Parameter (TC_RR_Data, PolyORB.Any.To_Any (Argument_Name_a_address)); PolyORB.Any.TypeCode.Add_Parameter (TC_RR_Data, Helper.To_Any (RR_Type'First)); PolyORB.Any.TypeCode.Add_Parameter (TC_RR_Data, PolyORB.Any.To_Any (PolyORB.Any.TC_String)); PolyORB.Any.TypeCode.Add_Parameter (TC_RR_Data, PolyORB.Any.To_Any (Argument_Name_rr_answer)); Any.TypeCode.Disable_Reference_Counting (Any.TypeCode.Object_Of (TC_RR_Data).all); end if; end Initialize_RR_Data; --------------------------- -- Get_Aggregate_Element -- --------------------------- function Get_Aggregate_Element (Acc : not null access Content_RR; Tc : PolyORB.Any.TypeCode.Object_Ptr; Index : PolyORB.Types.Unsigned_Long; Mech : not null access PolyORB.Any.Mechanism) return PolyORB.Any.Content'Class is use type PolyORB.Types.Unsigned_Long; use type PolyORB.Any.Mechanism; pragma Suppress (Validity_Check); pragma Unreferenced (Tc); begin Mech.all := PolyORB.Any.By_Reference; case Index is when 0 => return PolyORB.Any.Wrap (Acc.V.rr_name'Unrestricted_Access); when 1 => return Helper.Internals.Wrap (Acc.V.rr_type'Unrestricted_Access); when 2 => return PolyORB.Any.Wrap (Acc.V.TTL'Unrestricted_Access); when 3 => return PolyORB.Any.Wrap (Acc.V.data_length'Unrestricted_Access); when 4 => return Helper.Internals.Wrap (Acc.V.rr_data'Unrestricted_Access); pragma Warnings (Off); when others => raise Constraint_Error; pragma Warnings (On); end case; end Get_Aggregate_Element; ------------------------- -- Get_Aggregate_Count -- ------------------------- function Get_Aggregate_Count (Acc : Content_RR) return PolyORB.Types.Unsigned_Long is pragma Unreferenced (Acc); begin return 5; end Get_Aggregate_Count; ------------------------- -- Set_Aggregate_Count -- ------------------------- procedure Set_Aggregate_Count (Acc : in out Content_RR; Count : PolyORB.Types.Unsigned_Long) is begin null; end Set_Aggregate_Count; --------------------- -- Unchecked_Get_V -- --------------------- function Unchecked_Get_V (Acc : not null access Content_RR) return PolyORB.Types.Address is function To_Address is new Ada.Unchecked_Conversion (Ptr_RR, PolyORB.Types.Address); begin return To_Address (Acc.V); end Unchecked_Get_V; ----------- -- Clone -- ----------- function Clone (Acc : Content_RR; Into : PolyORB.Any.Content_Ptr := null) return PolyORB.Any.Content_Ptr is use type PolyORB.Any.Content_Ptr; Target : PolyORB.Any.Content_Ptr; begin if Into /= null then if Into.all not in Content_RR then return null; end if; Target := Into; Content_RR (Target.all).V.all := Acc.V.all; else Target := new Content_RR; Content_RR (Target.all).V := new RR' (Acc.V.all); end if; return Target; end Clone; -------------------- -- Finalize_Value -- -------------------- procedure Finalize_Value (Acc : in out Content_RR) is procedure Free is new Ada.Unchecked_Deallocation (RR, Ptr_RR); begin Free (Acc.V); end Finalize_Value; ---------- -- Wrap -- ---------- function Wrap (X : access RR) return PolyORB.Any.Content'Class is begin return Content_RR' (PolyORB.Any.Aggregate_Content with V => Ptr_RR (X)); end Wrap; RR_Initialized : PolyORB.Types.Boolean := False; ------------------- -- Initialize_RR -- ------------------- procedure Initialize_RR is Name : constant PolyORB.Types.String := PolyORB.Types.To_PolyORB_String ("RR"); Id : constant PolyORB.Types.String := PolyORB.Types.To_PolyORB_String ("IDL:DNS/RR:1.0"); Argument_Name_rr_name : constant PolyORB.Types.String := PolyORB.Types.To_PolyORB_String ("rr_name"); Argument_Name_rr_type : constant PolyORB.Types.String := PolyORB.Types.To_PolyORB_String ("rr_type"); Argument_Name_TTL : constant PolyORB.Types.String := PolyORB.Types.To_PolyORB_String ("TTL"); Argument_Name_data_length : constant PolyORB.Types.String := PolyORB.Types.To_PolyORB_String ("data_length"); Argument_Name_rr_data : constant PolyORB.Types.String := PolyORB.Types.To_PolyORB_String ("rr_data"); begin if not RR_Initialized then RR_Initialized := True; Helper.TC_RR := PolyORB.Any.TypeCode.TC_Struct; PolyORB.Any.TypeCode.Add_Parameter (TC_RR, PolyORB.Any.To_Any (Name)); PolyORB.Any.TypeCode.Add_Parameter (TC_RR, PolyORB.Any.To_Any (Id)); PolyORB.Any.TypeCode.Add_Parameter (TC_RR, PolyORB.Any.To_Any (PolyORB.Any.TC_String)); PolyORB.Any.TypeCode.Add_Parameter (TC_RR, PolyORB.Any.To_Any (Argument_Name_rr_name)); Helper.Internals.Initialize_RR_Type; PolyORB.Any.TypeCode.Add_Parameter (TC_RR, PolyORB.Any.To_Any (Helper.TC_RR_Type)); PolyORB.Any.TypeCode.Add_Parameter (TC_RR, PolyORB.Any.To_Any (Argument_Name_rr_type)); PolyORB.Any.TypeCode.Add_Parameter (TC_RR, PolyORB.Any.To_Any (PolyORB.Any.TC_Unsigned_Long)); PolyORB.Any.TypeCode.Add_Parameter (TC_RR, PolyORB.Any.To_Any (Argument_Name_TTL)); PolyORB.Any.TypeCode.Add_Parameter (TC_RR, PolyORB.Any.To_Any (PolyORB.Any.TC_Unsigned_Short)); PolyORB.Any.TypeCode.Add_Parameter (TC_RR, PolyORB.Any.To_Any (Argument_Name_data_length)); Helper.Internals.Initialize_RR_Data; PolyORB.Any.TypeCode.Add_Parameter (TC_RR, PolyORB.Any.To_Any (Helper.TC_RR_Data)); PolyORB.Any.TypeCode.Add_Parameter (TC_RR, PolyORB.Any.To_Any (Argument_Name_rr_data)); Any.TypeCode.Disable_Reference_Counting (Any.TypeCode.Object_Of (TC_RR).all); end if; end Initialize_RR; -------------- -- From_Any -- -------------- function From_Any (C : PolyORB.Any.Any_Container'Class) return Rcode is begin return Rcode'Val (PolyORB.Types.Unsigned_Long' (PolyORB.Any.Get_Aggregate_Element (C, 0))); end From_Any; --------------------------- -- Get_Aggregate_Element -- --------------------------- function Get_Aggregate_Element (Acc : not null access Content_Rcode; Tc : PolyORB.Any.TypeCode.Object_Ptr; Index : PolyORB.Types.Unsigned_Long; Mech : not null access PolyORB.Any.Mechanism) return PolyORB.Any.Content'Class is use type PolyORB.Types.Unsigned_Long; use type PolyORB.Any.Mechanism; pragma Suppress (Validity_Check); pragma Unreferenced (Tc, Index); begin Acc.Repr_Cache := Rcode'Pos (Acc.V.all); Mech.all := PolyORB.Any.By_Value; return PolyORB.Any.Wrap (Acc.Repr_Cache'Unrestricted_Access); end Get_Aggregate_Element; --------------------------- -- Set_Aggregate_Element -- --------------------------- procedure Set_Aggregate_Element (Acc : in out Content_Rcode; Tc : PolyORB.Any.TypeCode.Object_Ptr; Index : PolyORB.Types.Unsigned_Long; From_C : in out PolyORB.Any.Any_Container'Class) is use type PolyORB.Types.Unsigned_Long; pragma Assert ((Index = 0)); pragma Unreferenced (Tc); begin Acc.V.all := Rcode'Val (PolyORB.Types.Unsigned_Long' (PolyORB.Any.From_Any (From_C))); end Set_Aggregate_Element; ------------------------- -- Get_Aggregate_Count -- ------------------------- function Get_Aggregate_Count (Acc : Content_Rcode) return PolyORB.Types.Unsigned_Long is pragma Unreferenced (Acc); begin return 1; end Get_Aggregate_Count; ------------------------- -- Set_Aggregate_Count -- ------------------------- procedure Set_Aggregate_Count (Acc : in out Content_Rcode; Count : PolyORB.Types.Unsigned_Long) is begin null; end Set_Aggregate_Count; --------------------- -- Unchecked_Get_V -- --------------------- function Unchecked_Get_V (Acc : not null access Content_Rcode) return PolyORB.Types.Address is function To_Address is new Ada.Unchecked_Conversion (Ptr_Rcode, PolyORB.Types.Address); begin return To_Address (Acc.V); end Unchecked_Get_V; ----------- -- Clone -- ----------- function Clone (Acc : Content_Rcode; Into : PolyORB.Any.Content_Ptr := null) return PolyORB.Any.Content_Ptr is use type PolyORB.Any.Content_Ptr; Target : PolyORB.Any.Content_Ptr; begin if Into /= null then if Into.all not in Content_Rcode then return null; end if; Target := Into; Content_Rcode (Target.all).V.all := Acc.V.all; else Target := new Content_Rcode; Content_Rcode (Target.all).V := new Rcode' (Acc.V.all); end if; Content_Rcode (Target.all).Repr_Cache := Acc.Repr_Cache; return Target; end Clone; -------------------- -- Finalize_Value -- -------------------- procedure Finalize_Value (Acc : in out Content_Rcode) is procedure Free is new Ada.Unchecked_Deallocation (Rcode, Ptr_Rcode); begin Free (Acc.V); end Finalize_Value; ---------- -- Wrap -- ---------- function Wrap (X : access Rcode) return PolyORB.Any.Content'Class is begin return Content_Rcode' (PolyORB.Any.Aggregate_Content with V => Ptr_Rcode (X), Repr_Cache => 0); end Wrap; Rcode_Initialized : PolyORB.Types.Boolean := False; ---------------------- -- Initialize_Rcode -- ---------------------- procedure Initialize_Rcode is Name : constant PolyORB.Types.String := PolyORB.Types.To_PolyORB_String ("Rcode"); Id : constant PolyORB.Types.String := PolyORB.Types.To_PolyORB_String ("IDL:DNS/Rcode:1.0"); No_Error_Name : constant PolyORB.Types.String := PolyORB.Types.To_PolyORB_String ("No_Error"); Format_Error_Name : constant PolyORB.Types.String := PolyORB.Types.To_PolyORB_String ("Format_Error"); Server_Failure_Name : constant PolyORB.Types.String := PolyORB.Types.To_PolyORB_String ("Server_Failure"); Name_Error_Name : constant PolyORB.Types.String := PolyORB.Types.To_PolyORB_String ("Name_Error"); Not_Implemented_Name : constant PolyORB.Types.String := PolyORB.Types.To_PolyORB_String ("Not_Implemented"); Refused_Name : constant PolyORB.Types.String := PolyORB.Types.To_PolyORB_String ("Refused"); YX_Domain_Name : constant PolyORB.Types.String := PolyORB.Types.To_PolyORB_String ("YX_Domain"); YX_RRSet_Name : constant PolyORB.Types.String := PolyORB.Types.To_PolyORB_String ("YX_RRSet"); NX_RRSet_Name : constant PolyORB.Types.String := PolyORB.Types.To_PolyORB_String ("NX_RRSet"); Not_Auth_Name : constant PolyORB.Types.String := PolyORB.Types.To_PolyORB_String ("Not_Auth"); Not_Zone_Name : constant PolyORB.Types.String := PolyORB.Types.To_PolyORB_String ("Not_Zone"); begin if not Rcode_Initialized then Rcode_Initialized := True; Helper.TC_Rcode := PolyORB.Any.TypeCode.TC_Enum; PolyORB.Any.TypeCode.Add_Parameter (TC_Rcode, PolyORB.Any.To_Any (Name)); PolyORB.Any.TypeCode.Add_Parameter (TC_Rcode, PolyORB.Any.To_Any (Id)); PolyORB.Any.TypeCode.Add_Parameter (TC_Rcode, PolyORB.Any.To_Any (No_Error_Name)); PolyORB.Any.TypeCode.Add_Parameter (TC_Rcode, PolyORB.Any.To_Any (Format_Error_Name)); PolyORB.Any.TypeCode.Add_Parameter (TC_Rcode, PolyORB.Any.To_Any (Server_Failure_Name)); PolyORB.Any.TypeCode.Add_Parameter (TC_Rcode, PolyORB.Any.To_Any (Name_Error_Name)); PolyORB.Any.TypeCode.Add_Parameter (TC_Rcode, PolyORB.Any.To_Any (Not_Implemented_Name)); PolyORB.Any.TypeCode.Add_Parameter (TC_Rcode, PolyORB.Any.To_Any (Refused_Name)); PolyORB.Any.TypeCode.Add_Parameter (TC_Rcode, PolyORB.Any.To_Any (YX_Domain_Name)); PolyORB.Any.TypeCode.Add_Parameter (TC_Rcode, PolyORB.Any.To_Any (YX_RRSet_Name)); PolyORB.Any.TypeCode.Add_Parameter (TC_Rcode, PolyORB.Any.To_Any (NX_RRSet_Name)); PolyORB.Any.TypeCode.Add_Parameter (TC_Rcode, PolyORB.Any.To_Any (Not_Auth_Name)); PolyORB.Any.TypeCode.Add_Parameter (TC_Rcode, PolyORB.Any.To_Any (Not_Zone_Name)); Any.TypeCode.Disable_Reference_Counting (Any.TypeCode.Object_Of (TC_Rcode).all); end if; end Initialize_Rcode; -------------------------------------- -- IDL_SEQUENCE_DNS_RR_Element_Wrap -- -------------------------------------- function IDL_SEQUENCE_DNS_RR_Element_Wrap (X : access RR) return PolyORB.Any.Content'Class is begin return Helper.Internals.Wrap (X.all'Unrestricted_Access); end IDL_SEQUENCE_DNS_RR_Element_Wrap; function Wrap (X : access IDL_SEQUENCE_DNS_RR.Sequence) return PolyORB.Any.Content'Class renames IDL_SEQUENCE_DNS_RR_Helper.Wrap; IDL_SEQUENCE_DNS_RR_Initialized : PolyORB.Types.Boolean := False; ------------------------------------ -- Initialize_IDL_SEQUENCE_DNS_RR -- ------------------------------------ procedure Initialize_IDL_SEQUENCE_DNS_RR is begin if not IDL_SEQUENCE_DNS_RR_Initialized then IDL_SEQUENCE_DNS_RR_Initialized := True; Helper.Internals.Initialize_RR; Helper.TC_IDL_SEQUENCE_DNS_RR := PolyORB.Any.TypeCode.Build_Sequence_TC (Helper.TC_RR, 0); Any.TypeCode.Disable_Reference_Counting (Any.TypeCode.Object_Of (TC_IDL_SEQUENCE_DNS_RR).all); IDL_SEQUENCE_DNS_RR_Helper.Initialize (Element_TC => Helper.TC_RR, Sequence_TC => Helper.TC_IDL_SEQUENCE_DNS_RR); end if; end Initialize_IDL_SEQUENCE_DNS_RR; rrSequence_Initialized : PolyORB.Types.Boolean := False; --------------------------- -- Initialize_rrSequence -- --------------------------- procedure Initialize_rrSequence is Name : constant PolyORB.Types.String := PolyORB.Types.To_PolyORB_String ("rrSequence"); Id : constant PolyORB.Types.String := PolyORB.Types.To_PolyORB_String ("IDL:DNS/rrSequence:1.0"); begin if not rrSequence_Initialized then rrSequence_Initialized := True; Helper.Internals.Initialize_IDL_SEQUENCE_DNS_RR; TC_rrSequence := PolyORB.Any.TypeCode.TC_Alias; Any.TypeCode.Add_Parameter (TC_rrSequence, Any.To_Any (Name)); Any.TypeCode.Add_Parameter (TC_rrSequence, Any.To_Any (Id)); Any.TypeCode.Add_Parameter (TC_rrSequence, Any.To_Any (TC_IDL_SEQUENCE_DNS_RR)); Any.TypeCode.Disable_Reference_Counting (Any.TypeCode.Object_Of (TC_rrSequence).all); end if; end Initialize_rrSequence; end Internals; -------------- -- From_Any -- -------------- function From_Any (Item : PolyORB.Any.Any) return RR_Type is begin return Helper.Internals.From_Any (PolyORB.Any.Get_Container (Item).all); end From_Any; ------------ -- To_Any -- ------------ function To_Any (Item : RR_Type) return PolyORB.Any.Any is Result : PolyORB.Any.Any := PolyORB.Any.Get_Empty_Any_Aggregate (TC_RR_Type); begin PolyORB.Any.Add_Aggregate_Element (Result, PolyORB.Any.To_Any (PolyORB.Types.Unsigned_Long (RR_Type'Pos (Item)))); return Result; end To_Any; -------------- -- From_Any -- -------------- function From_Any (Item : PolyORB.Any.Any) return SRV_Data is begin return (priority => PolyORB.Any.From_Any (PolyORB.Any.Get_Aggregate_Element (Item, PolyORB.Any.TC_Unsigned_Short, 0)), weight => PolyORB.Any.From_Any (PolyORB.Any.Get_Aggregate_Element (Item, PolyORB.Any.TC_Unsigned_Short, 1)), port => PolyORB.Any.From_Any (PolyORB.Any.Get_Aggregate_Element (Item, PolyORB.Any.TC_Unsigned_Short, 2)), target => PolyORB.Any.From_Any (PolyORB.Any.Get_Aggregate_Element (Item, PolyORB.Any.TC_String, 3))); end From_Any; ------------ -- To_Any -- ------------ function To_Any (Item : SRV_Data) return PolyORB.Any.Any is Result : PolyORB.Any.Any := PolyORB.Any.Get_Empty_Any_Aggregate (TC_SRV_Data); begin PolyORB.Any.Add_Aggregate_Element (Result, PolyORB.Any.To_Any (Item.priority)); PolyORB.Any.Add_Aggregate_Element (Result, PolyORB.Any.To_Any (Item.weight)); PolyORB.Any.Add_Aggregate_Element (Result, PolyORB.Any.To_Any (Item.port)); PolyORB.Any.Add_Aggregate_Element (Result, PolyORB.Any.To_Any (Item.target)); return Result; end To_Any; function From_Any (Item : PolyORB.Any.Any) return IDL_SEQUENCE_4_octet.Sequence renames Helper.Internals.IDL_SEQUENCE_4_octet_Helper.From_Any; function To_Any (Item : IDL_SEQUENCE_4_octet.Sequence) return PolyORB.Any.Any renames Helper.Internals.IDL_SEQUENCE_4_octet_Helper.To_Any; -------------- -- From_Any -- -------------- function From_Any (Item : PolyORB.Any.Any) return IDL_AT_Sequence_4_octet is Result : constant IDL_SEQUENCE_4_octet.Sequence := Helper.From_Any (Item); begin return IDL_AT_Sequence_4_octet (Result); end From_Any; ------------ -- To_Any -- ------------ function To_Any (Item : IDL_AT_Sequence_4_octet) return PolyORB.Any.Any is Result : PolyORB.Any.Any := To_Any (IDL_SEQUENCE_4_octet.Sequence (Item)); begin PolyORB.Any.Set_Type (Result, TC_IDL_AT_Sequence_4_octet); return Result; end To_Any; -------------- -- From_Any -- -------------- function From_Any (Item : PolyORB.Any.Any) return RR_Data is Label_Any : constant PolyORB.Any.Any := PolyORB.Any.Get_Aggregate_Element (Item, Helper.TC_RR_Type, PolyORB.Types.Unsigned_Long (0)); Label : constant RR_Type := Helper.From_Any (Label_Any); Result : RR_Data (Label); Index : PolyORB.Any.Any; begin case Label is when SRV => Index := PolyORB.Any.Get_Aggregate_Element (Item, Helper.TC_SRV_Data, PolyORB.Types.Unsigned_Long (1)); Result.srv_data := Helper.From_Any (Index); when A => Index := PolyORB.Any.Get_Aggregate_Element (Item, Helper.TC_IDL_AT_Sequence_4_octet, PolyORB.Types.Unsigned_Long (1)); Result.a_address := Helper.From_Any (Index); pragma Warnings (Off); when others => Index := PolyORB.Any.Get_Aggregate_Element (Item, PolyORB.Any.TC_String, PolyORB.Types.Unsigned_Long (1)); Result.rr_answer := PolyORB.Any.From_Any (Index); pragma Warnings (On); end case; return Result; end From_Any; ------------ -- To_Any -- ------------ function To_Any (Item : RR_Data) return PolyORB.Any.Any is Result : PolyORB.Any.Any := PolyORB.Any.Get_Empty_Any_Aggregate (Helper.TC_RR_Data); begin PolyORB.Any.Add_Aggregate_Element (Result, Helper.To_Any (Item.Switch)); case Item.Switch is when SRV => PolyORB.Any.Add_Aggregate_Element (Result, Helper.To_Any (Item.srv_data)); when A => PolyORB.Any.Add_Aggregate_Element (Result, Helper.To_Any (Item.a_address)); pragma Warnings (Off); when others => PolyORB.Any.Add_Aggregate_Element (Result, PolyORB.Any.To_Any (Item.rr_answer)); pragma Warnings (On); end case; return Result; end To_Any; -------------- -- From_Any -- -------------- function From_Any (Item : PolyORB.Any.Any) return RR is begin return (rr_name => PolyORB.Any.From_Any (PolyORB.Any.Get_Aggregate_Element (Item, PolyORB.Any.TC_String, 0)), rr_type => Helper.From_Any (PolyORB.Any.Get_Aggregate_Element (Item, Helper.TC_RR_Type, 1)), TTL => PolyORB.Any.From_Any (PolyORB.Any.Get_Aggregate_Element (Item, PolyORB.Any.TC_Unsigned_Long, 2)), data_length => PolyORB.Any.From_Any (PolyORB.Any.Get_Aggregate_Element (Item, PolyORB.Any.TC_Unsigned_Short, 3)), rr_data => Helper.From_Any (PolyORB.Any.Get_Aggregate_Element (Item, Helper.TC_RR_Data, 4))); end From_Any; ------------ -- To_Any -- ------------ function To_Any (Item : RR) return PolyORB.Any.Any is Result : PolyORB.Any.Any := PolyORB.Any.Get_Empty_Any_Aggregate (TC_RR); begin PolyORB.Any.Add_Aggregate_Element (Result, PolyORB.Any.To_Any (Item.rr_name)); PolyORB.Any.Add_Aggregate_Element (Result, Helper.To_Any (Item.rr_type)); PolyORB.Any.Add_Aggregate_Element (Result, PolyORB.Any.To_Any (Item.TTL)); PolyORB.Any.Add_Aggregate_Element (Result, PolyORB.Any.To_Any (Item.data_length)); PolyORB.Any.Add_Aggregate_Element (Result, Helper.To_Any (Item.rr_data)); return Result; end To_Any; -------------- -- From_Any -- -------------- function From_Any (Item : PolyORB.Any.Any) return Rcode is begin return Helper.Internals.From_Any (PolyORB.Any.Get_Container (Item).all); end From_Any; ------------ -- To_Any -- ------------ function To_Any (Item : Rcode) return PolyORB.Any.Any is Result : PolyORB.Any.Any := PolyORB.Any.Get_Empty_Any_Aggregate (TC_Rcode); begin PolyORB.Any.Add_Aggregate_Element (Result, PolyORB.Any.To_Any (PolyORB.Types.Unsigned_Long (Rcode'Pos (Item)))); return Result; end To_Any; function From_Any (Item : PolyORB.Any.Any) return IDL_SEQUENCE_DNS_RR.Sequence renames Helper.Internals.IDL_SEQUENCE_DNS_RR_Helper.From_Any; function To_Any (Item : IDL_SEQUENCE_DNS_RR.Sequence) return PolyORB.Any.Any renames Helper.Internals.IDL_SEQUENCE_DNS_RR_Helper.To_Any; -------------- -- From_Any -- -------------- function From_Any (Item : PolyORB.Any.Any) return rrSequence is Result : constant IDL_SEQUENCE_DNS_RR.Sequence := Helper.From_Any (Item); begin return rrSequence (Result); end From_Any; ------------ -- To_Any -- ------------ function To_Any (Item : rrSequence) return PolyORB.Any.Any is Result : PolyORB.Any.Any := Helper.To_Any (IDL_SEQUENCE_DNS_RR.Sequence (Item)); begin PolyORB.Any.Set_Type (Result, TC_rrSequence); return Result; end To_Any; ----------------------------- -- Deferred_Initialization -- ----------------------------- procedure Deferred_Initialization; procedure Deferred_Initialization is begin DNS.Helper.Internals.Initialize_RR_Type; DNS.Helper.Internals.Initialize_SRV_Data; DNS.Helper.Internals.Initialize_IDL_SEQUENCE_4_octet; DNS.Helper.Internals.Initialize_IDL_AT_Sequence_4_octet; DNS.Helper.Internals.Initialize_RR_Data; DNS.Helper.Internals.Initialize_RR; DNS.Helper.Internals.Initialize_Rcode; DNS.Helper.Internals.Initialize_IDL_SEQUENCE_DNS_RR; DNS.Helper.Internals.Initialize_rrSequence; end Deferred_Initialization; use PolyORB.Initialization; use PolyORB.Initialization.String_Lists; use PolyORB.Utils.Strings; begin pragma Debug (C, O ("Registering Module DNS-Helper")); Register_Module (Module_Info' (Name => +"dns.helper", Conflicts => Empty, Depends => Empty, Provides => Empty, Implicit => False, Init => Deferred_Initialization'Access, Shutdown => null)); end PolyORB.DNS.Helper; polyorb-2.8~20110207.orig/src/dns/polyorb-dns.ads0000644000175000017500000000416211750740340020721 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . D N S -- -- -- -- S p e c -- -- -- -- Copyright (C) 2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- Root package for the DNS protocol personality package PolyORB.DNS is pragma Pure; end PolyORB.DNS; polyorb-2.8~20110207.orig/src/dns/polyorb-dns-transport_mechanisms.ads0000644000175000017500000001130111750740340025153 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . D N S . T R A N S P O R T _ M E C H A N I S M S -- -- -- -- S p e c -- -- -- -- Copyright (C) 2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- Abstraction for DNS Transport Mechanisms. with PolyORB.Binding_Data; with PolyORB.Components; with PolyORB.Errors; with PolyORB.QoS; with PolyORB.Smart_Pointers; with PolyORB.Transport; with PolyORB.Utils.Chained_Lists; package PolyORB.DNS.Transport_Mechanisms is -- Transport mechanism type Transport_Mechanism is abstract tagged null record; type Transport_Mechanism_Access is access all Transport_Mechanism'Class; procedure Bind_Mechanism (Mechanism : Transport_Mechanism; Profile : access PolyORB.Binding_Data.Profile_Type'Class; The_ORB : Components.Component_Access; QoS : PolyORB.QoS.QoS_Parameters; BO_Ref : out Smart_Pointers.Ref; Error : out Errors.Error_Container) is abstract; procedure Release_Contents (M : access Transport_Mechanism) is abstract; -- Transport mechanism factory type Transport_Mechanism_Factory is abstract tagged null record; type Transport_Mechanism_Factory_Access is access all Transport_Mechanism_Factory'Class; procedure Create_Factory (MF : out Transport_Mechanism_Factory; TAP : Transport.Transport_Access_Point_Access) is abstract; -- Initialize MF to act as transport mechanism factory for -- transport access point TAP function Is_Local_Mechanism (MF : access Transport_Mechanism_Factory; M : access Transport_Mechanism'Class) return Boolean is abstract; -- True iff M designates an mechanism that can be contacted -- at the access point associated with MF -- List of Transport Mechanisms package Transport_Mechanism_Lists is new PolyORB.Utils.Chained_Lists (Transport_Mechanism_Access); type Transport_Mechanism_List is new Transport_Mechanism_Lists.List; procedure Release_Contents (List : in out Transport_Mechanism_List); -- Free memory for all tags in List function Duplicate (TMA : Transport_Mechanism) return Transport_Mechanism is abstract; function Is_Colocated (Left : Transport_Mechanism; Right : Transport_Mechanism'Class) return Boolean is abstract; -- True iff Left and Right mechanisms point to the same node. function Is_Colocated (Left, Right : Transport_Mechanism_List) return Boolean; -- True iff Left and Right mechanisms lists have both a transport mechanism -- pointing to the same node. -- List of Transport Mechanism Factories package Transport_Mechanism_Factory_Lists is new PolyORB.Utils.Chained_Lists (Transport_Mechanism_Factory_Access); type Transport_Mechanism_Factory_List is new Transport_Mechanism_Factory_Lists.List; -- Creation of Transport Mechanisms from list of Tagged Component end PolyORB.DNS.Transport_Mechanisms; polyorb-2.8~20110207.orig/src/dns/polyorb-protocols-dns.ads0000644000175000017500000002432111750740340022742 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . P R O T O C O L S . D N S -- -- -- -- S p e c -- -- -- -- Copyright (C) 2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with Ada.Streams; with Ada.Unchecked_Deallocation; with PolyORB.Buffers; with PolyORB.ORB; with PolyORB.Tasking.Mutexes; with PolyORB.Types; with PolyORB.Utils.Dynamic_Tables; with PolyORB.Utils.Simple_Flags; with PolyORB.DNS.Helper; with PolyORB.References; package PolyORB.Protocols.DNS is use Ada.Streams; use PolyORB.Buffers; use PolyORB.DNS.Helper; type Flags is new Types.Unsigned_Short; package Unsigned_Short_Flags is new PolyORB.Utils.Simple_Flags (Flags); use Unsigned_Short_Flags; DNS_Error : exception; type DNS_Protocol is new Protocol with private; type DNS_Session is new Session with private; procedure Create (Proto : access DNS_Protocol; Session : out Filter_Access); -- INTERFACE TO UPPER LAYERS procedure Invoke_Request (Sess : access DNS_Session; R : Requests.Request_Access; Pro : access Binding_Data.Profile_Type'Class); procedure Abort_Request (S : access DNS_Session; R : Requests.Request_Access); procedure Send_Reply (S : access DNS_Session; Request : Requests.Request_Access); -- INTERFACE TO LOWER LAYERS procedure Handle_Connect_Indication (S : access DNS_Session); procedure Handle_Connect_Confirmation (S : access DNS_Session); procedure Handle_Data_Indication (Sess : access DNS_Session; Data_Amount : Ada.Streams.Stream_Element_Count; Error : in out Errors.Error_Container); procedure Handle_Disconnect (Sess : access DNS_Session; Error : Errors.Error_Container); procedure Handle_Flush (S : access DNS_Session); -- DNS protocol proper API procedure Initialize_Session (S : access Session'Class); procedure Finalize_Session (S : access Session'Class); type DNS_Message_Context is abstract tagged private; type DNS_Message_Context_Access is access all DNS_Message_Context'Class; ----------------------- -- DNS message type -- ----------------------- type Msg_Type is (Request, Reply, Update); procedure Process_Message (S : access Session'Class); procedure Process_Request (S : access DNS_Session); procedure Reply_Received (Sess : access DNS_Session; Request_Id : Types.Unsigned_Long; RC : Rcode); procedure Initialize; procedure Set_Default_Servant (The_Ref : PolyORB.References.Ref); function Get_Default_Servant return PolyORB.References.Ref; -- Set/Get the user specified default servant private Object_Reference : PolyORB.References.Ref; -- Default Object Reference, specified by user type Pending_Request is record Req : Requests.Request_Access; Request_Id : Types.Unsigned_Long; Target_Profile : Binding_Data.Profile_Access; end record; type Pending_Request_Access is access all Pending_Request; procedure Send_Request (S : access Session'Class; R : Pending_Request_Access; Error : in out Errors.Error_Container); procedure Free is new Ada.Unchecked_Deallocation (Pending_Request, Pending_Request_Access); package Pend_Req_Tables is new PolyORB.Utils.Dynamic_Tables (Pending_Request_Access, Natural, 1, 10, 10); type DNS_Protocol is new Protocol with null record; -- For now the DNS message context is exhaustive for all -- dns message fields.. to be discussed type DNS_Message_Context is abstract tagged record Message_Type : Msg_Type; Request_Id : aliased Types.Unsigned_Long; Request_Opcode : Types.String; -- DNS Header Flags QR_Flag : Types.Boolean; AA_Flag : Types.Boolean; Opcode_Flag : Opcode_Type; TC_Flag : Types.Boolean; Rec_Flag : Types.Boolean; Rec_Disp_Flag : Types.Boolean; Rcode_Flag : Rcode; Nb_Questions : Types.Unsigned_Short := 0; Nb_Answers : Types.Unsigned_Short; Nb_Auth_Servers : Types.Unsigned_Short; Nb_Add_Infos : Types.Unsigned_Short; -- Arg list used on the server side to create local request New_Args : Any.NVList.Ref; end record; -- Index of the current question being received on server side Current_Question_Nb : Types.Unsigned_Short := 0; type DNS_Message_Ctx is new DNS_Message_Context with null record; type DNS_Session is new Session with record Buffer_In : PolyORB.Buffers.Buffer_Access; -- DNS Buffer in Role : PolyORB.ORB.Endpoint_Role; -- role of session for ORB Mutex : PolyORB.Tasking.Mutexes.Mutex_Access; -- DNS message context for the message being received Pending_Reqs : Pend_Req_Tables.Instance; -- List of pendings request Req_Index : Types.Unsigned_Long := 1; -- Counter to have new Request Index MCtx : DNS_Message_Context_Access; -- Access to Message_Context end record; type DNS_Session_Access is access all DNS_Session; -- annotations used by pending requests type Request_Note is new PolyORB.Annotations.Note with record Id : Types.Unsigned_Long; end record; procedure Initialize (S : in out DNS_Session); -- Header size of the DNS packet DNS_Header_Size : constant Stream_Element_Offset := 12; DNS_Max_Size : constant Stream_Element_Offset := 512; -- Bit_Count definition for DNS header flags QR_Flag_Pos : constant Bit_Count := 15; Opcode_Flag_Pos : constant Bit_Count := 11; AA_Flag_Pos : constant Bit_Count := 10; TC_Flag_Pos : constant Bit_Count := 9; Rec_Flag_Pos : constant Bit_Count := 8; Rec_Disp_Flag_Pos : constant Bit_Count := 7; Res_Flag_Pos : constant Bit_Count := 4; Rcode_Flag_Pos : constant Bit_Count := 0; procedure Expect_DNS_Header (Sess : access DNS_Session); procedure Marshall_DNS_Header_Reply (Header_Buffer : access Buffers.Buffer_Type; R : Requests.Request_Access; MCtx : access DNS_Message_Context'Class); procedure Marshall_DNS_Header (Header_Buffer : access Buffers.Buffer_Type; R : Pending_Request_Access; MCtx : access DNS_Message_Context'Class); procedure Unmarshall_DNS_Header (MCtx_Acc : access DNS_Message_Context'Class; Buffer : access Buffers.Buffer_Type); procedure Unmarshall_Argument_List (Sess : access DNS_Session; Args : in out Any.NVList.Ref; Direction : Any.Flags; Error : in out Errors.Error_Container); -------------------------------- -- Pending Request management -- -------------------------------- function Get_Request_Id (Sess : access DNS_Session) return Types.Unsigned_Long; -- Obtain a new, unique request identifier. The caller is responsible -- for ensuring that this function is called under mutual exclusion. procedure Add_Pending_Request (Sess : access DNS_Session; Pend_Req : Pending_Request_Access); -- Add Pend_Req to the list of pending requests on S. -- The Req and Target_Profile fields must be already initialized; this -- procedure sets the Request_Id. The caller is reponsible for ensuring -- that this procedure is called under mutual exclusion. procedure Get_Pending_Request (Sess : access DNS_Session; Id : Types.Unsigned_Long; Req : out Pending_Request; Success : out Boolean; Remove : Boolean := True); -- Retrieve a pending request of Sess by its request id, and -- remove it from the list of pending requests if Remove is set to -- true. This procedure ensures proper mutual exclusion. -- procedure Remove_Pending_Request (Sess : access DNS_Session; Id : Types.Unsigned_Long; Success : out Boolean); -- Remove pending request by its request id from the list of pending -- requests on Sess. This procedure ensures proper mutual exclusion. procedure Emit_Message (S : access Session'Class; Buffer : PolyORB.Buffers.Buffer_Access; Error : in out Errors.Error_Container); -- Emit message contained in Buffer to lower layer of the protocol stack. -- Implementations may override this operation to provide outgoing messages -- fragmentation. end PolyORB.Protocols.DNS; polyorb-2.8~20110207.orig/src/dns/polyorb-dns-transport_mechanisms.adb0000644000175000017500000000701611750740340025142 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . D N S . T R A N S P O R T _ M E C H A N I S M S -- -- -- -- B o d y -- -- -- -- Copyright (C) 2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with Ada.Unchecked_Deallocation; package body PolyORB.DNS.Transport_Mechanisms is --------------------------------- -- Create_Transport_Mechanisms -- --------------------------------- ------------------ -- Is_Colocated -- ------------------ function Is_Colocated (Left, Right : Transport_Mechanism_List) return Boolean is use Transport_Mechanism_Lists; L_Iter : Iterator := First (Right); R_Iter : Iterator; begin Left_Iteration : while not Last (L_Iter) loop R_Iter := First (Left); Right_Iteration : while not Last (R_Iter) loop if Is_Colocated (Value (L_Iter).all.all, Value (R_Iter).all.all) then return True; end if; Next (R_Iter); end loop Right_Iteration; Next (L_Iter); end loop Left_Iteration; return False; end Is_Colocated; ---------------------- -- Release_Contents -- ---------------------- procedure Release_Contents (List : in out Transport_Mechanism_List) is procedure Free is new Ada.Unchecked_Deallocation (Transport_Mechanism'Class, Transport_Mechanism_Access); Component : Transport_Mechanism_Access; begin while List /= Transport_Mechanism_List (Transport_Mechanism_Lists.Empty) loop Extract_First (List, Component); Release_Contents (Component); Free (Component); end loop; end Release_Contents; end PolyORB.DNS.Transport_Mechanisms; polyorb-2.8~20110207.orig/src/dns/mdns/0000755000175000017500000000000011750740340016716 5ustar xavierxavierpolyorb-2.8~20110207.orig/src/dns/mdns/polyorb-setup-mdns.adb0000644000175000017500000000545211750740340023157 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . S E T U P . M D N S -- -- -- -- B o d y -- -- -- -- Copyright (C) 2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ pragma Warnings (Off); -- No entities referenced. with PolyORB.Protocols.DNS; pragma Warnings (On); with PolyORB.Initialization; with PolyORB.Utils.Strings; package body PolyORB.Setup.MDNS is use PolyORB.Smart_Pointers; ---------------- -- Initialize -- ---------------- procedure Initialize; procedure Initialize is begin null; end Initialize; use PolyORB.Initialization; use PolyORB.Initialization.String_Lists; use PolyORB.Utils.Strings; begin Register_Module (Module_Info' (Name => +"setup.mdns", Conflicts => Empty, Depends => +"protocols.dns" & "smart_pointers", Provides => Empty, Implicit => False, Init => Initialize'Access, Shutdown => null)); end PolyORB.Setup.MDNS; polyorb-2.8~20110207.orig/src/dns/mdns/polyorb-setup-access_points-mdns.ads0000644000175000017500000000422011750740340026023 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . S E T U P . A C C E S S _ P O I N T S . M D N S -- -- -- -- S p e c -- -- -- -- Copyright (C) 2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- Setup socket for MDNS package PolyORB.Setup.Access_Points.MDNS is pragma Elaborate_Body; end PolyORB.Setup.Access_Points.MDNS; polyorb-2.8~20110207.orig/src/dns/mdns/polyorb-setup-access_points-mdns.adb0000644000175000017500000001057711750740340026016 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . S E T U P . A C C E S S _ P O I N T S . M D N S -- -- -- -- B o d y -- -- -- -- Copyright (C) 2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- Setup socket for MDNS with PolyORB.Binding_Data.DNS.MDNS; with PolyORB.Filters; with PolyORB.Initialization; with PolyORB.ORB; with PolyORB.Parameters; with PolyORB.Protocols; with PolyORB.Protocols.DNS.MDNS; with PolyORB.Sockets; with PolyORB.Transport.Datagram.Sockets; with PolyORB.Utils.Strings; with PolyORB.Utils.UDP_Access_Points; package body PolyORB.Setup.Access_Points.MDNS is use PolyORB.Filters; use PolyORB.ORB; use PolyORB.Sockets; use PolyORB.Transport.Datagram.Sockets; use PolyORB.Utils.UDP_Access_Points; MDNS_Access_Point : UDP_Access_Point_Info := (Socket => No_Socket, Address => No_Sock_Addr, SAP => new Socket_Access_Point, PF => new PolyORB.Binding_Data.DNS.MDNS.MDNS_Profile_Factory); Pro : aliased Protocols.DNS.MDNS.MDNS_Protocol; MDNS_Factories : aliased Filters.Factory_Array := (0 => Pro'Access); ------------------------------ -- Initialize_Access_Points -- ------------------------------ procedure Initialize_Access_Points; procedure Initialize_Access_Points is use PolyORB.Parameters; Addr : constant String := Get_Conf ("mdns", "polyorb.mdns.multicast_addr", ""); Port : constant Port_Type := Port_Type (Get_Conf ("mdns", "polyorb.mdns.multicast_port", 0)); begin if Get_Conf ("access_points", "mdns", True) then -- If multicast group address or port number is not set, access -- point is deactivated. if Addr = "" or else Port = 0 then return; end if; Initialize_Multicast_Socket (MDNS_Access_Point, Inet_Addr (Addr), Port); Register_Access_Point (ORB => The_ORB, TAP => MDNS_Access_Point.SAP, Chain => MDNS_Factories'Access, PF => MDNS_Access_Point.PF); end if; end Initialize_Access_Points; use PolyORB.Initialization; use PolyORB.Initialization.String_Lists; use PolyORB.Utils.Strings; begin Register_Module (Module_Info' (Name => +"access_points.mdns", Conflicts => String_Lists.Empty, Depends => +"orb" & "sockets", Provides => String_Lists.Empty, Implicit => False, Init => Initialize_Access_Points'Access, Shutdown => null)); end PolyORB.Setup.Access_Points.MDNS; polyorb-2.8~20110207.orig/src/dns/mdns/polyorb-dns-transport_mechanisms-mdns.adb0000644000175000017500000001646411750740340027051 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- POLYORB.DNS.TRANSPORT_MECHANISMS.MDNS -- -- -- -- B o d y -- -- -- -- Copyright (C) 2005-2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with PolyORB.Binding_Data.DNS.MDNS; with PolyORB.Binding_Objects; with PolyORB.ORB; with PolyORB.Parameters; with PolyORB.Protocols.DNS.MDNS; with PolyORB.Sockets; with PolyORB.Transport.Datagram.Sockets; with PolyORB.Filters; package body PolyORB.DNS.Transport_Mechanisms.MDNS is use PolyORB.Components; use PolyORB.Errors; use PolyORB.Parameters; use PolyORB.Sockets; use PolyORB.Transport.Datagram.Sockets; use PolyORB.Utils.Sockets; ---------------- -- Address_Of -- ---------------- function Address_Of (M : MDNS_Transport_Mechanism) return Utils.Sockets.Socket_Name is begin return M.Address.all; end Address_Of; -------------------- -- Bind_Mechanism -- -------------------- -- Factories Pro : aliased PolyORB.Protocols.DNS.MDNS.MDNS_Protocol; MDNS_Factories : constant PolyORB.Filters.Factory_Array := (0 => Pro'Access); procedure Bind_Mechanism (Mechanism : MDNS_Transport_Mechanism; Profile : access PolyORB.Binding_Data.Profile_Type'Class; The_ORB : Components.Component_Access; QoS : PolyORB.QoS.QoS_Parameters; BO_Ref : out Smart_Pointers.Ref; Error : out Errors.Error_Container) is pragma Unreferenced (QoS); use PolyORB.Binding_Data; use PolyORB.Binding_Objects; Sock : Socket_Type; TTL : constant Natural := Natural (Get_Conf ("dns", "polyorb.dns.ttl", Default_TTL)); TE : Transport.Transport_Endpoint_Access; begin if Profile.all not in PolyORB.Binding_Data.DNS.MDNS.MDNS_Profile_Type then Throw (Error, Comm_Failure_E, System_Exception_Members' (Minor => 0, Completed => Completed_Maybe)); return; end if; Create_Socket (Socket => Sock, Family => Family_Inet, Mode => Socket_Datagram); Set_Socket_Option (Sock, Socket_Level, (Reuse_Address, True)); Set_Socket_Option (Sock, IP_Protocol_For_IP_Level, (Multicast_TTL, TTL)); TE := new Socket_Endpoint; Create (Socket_Endpoint (TE.all), Sock, To_Address (Mechanism.Address.all)); Binding_Objects.Setup_Binding_Object (The_ORB, TE, MDNS_Factories, BO_Ref, Profile_Access (Profile)); ORB.Register_Binding_Object (ORB.ORB_Access (The_ORB), BO_Ref, ORB.Client); exception when Sockets.Socket_Error => Throw (Error, Comm_Failure_E, System_Exception_Members' (Minor => 0, Completed => Completed_Maybe)); end Bind_Mechanism; -------------------- -- Create_Factory -- -------------------- procedure Create_Factory (MF : out MDNS_Transport_Mechanism_Factory; TAP : Transport.Transport_Access_Point_Access) is begin MF.Address := new Socket_Name'(Address_Of (Socket_Access_Point (TAP.all))); end Create_Factory; -------------------------------- -- Create_Transport_Mechanism -- -------------------------------- function Create_Transport_Mechanism (MF : MDNS_Transport_Mechanism_Factory) return Transport_Mechanism_Access is Result : constant Transport_Mechanism_Access := new MDNS_Transport_Mechanism; TResult : MDNS_Transport_Mechanism renames MDNS_Transport_Mechanism (Result.all); begin TResult.Address := new Socket_Name'(MF.Address.all); return Result; end Create_Transport_Mechanism; function Create_Transport_Mechanism (Address : Utils.Sockets.Socket_Name) return Transport_Mechanism_Access is Result : constant Transport_Mechanism_Access := new MDNS_Transport_Mechanism; TResult : MDNS_Transport_Mechanism renames MDNS_Transport_Mechanism (Result.all); begin TResult.Address := new Socket_Name'(Address); return Result; end Create_Transport_Mechanism; ------------------------ -- Is_Local_Mechanism -- ------------------------ function Is_Local_Mechanism (MF : access MDNS_Transport_Mechanism_Factory; M : access Transport_Mechanism'Class) return Boolean is begin return M.all in MDNS_Transport_Mechanism and then MDNS_Transport_Mechanism (M.all).Address.all = MF.Address.all; end Is_Local_Mechanism; ---------------------- -- Release_Contents -- ---------------------- procedure Release_Contents (M : access MDNS_Transport_Mechanism) is begin Free (M.Address); end Release_Contents; --------------- -- Duplicate -- --------------- function Duplicate (TMA : MDNS_Transport_Mechanism) return MDNS_Transport_Mechanism is begin return MDNS_Transport_Mechanism' (Address => new Socket_Name'(TMA.Address.all)); end Duplicate; ------------------ -- Is_Colocated -- ------------------ function Is_Colocated (Left : MDNS_Transport_Mechanism; Right : Transport_Mechanism'Class) return Boolean is begin return Right in MDNS_Transport_Mechanism and then Left.Address = MDNS_Transport_Mechanism (Right).Address; end Is_Colocated; end PolyORB.DNS.Transport_Mechanisms.MDNS; polyorb-2.8~20110207.orig/src/dns/mdns/polyorb-binding_data-dns-mdns.ads0000644000175000017500000000633111750740340025222 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . B I N D I N G _ D A T A . D N S . M D N S -- -- -- -- S p e c -- -- -- -- Copyright (C) 2003-2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ package PolyORB.Binding_Data.DNS.MDNS is DNS_Error : exception; type MDNS_Profile_Type is new DNS_Profile_Type with private; type MDNS_Profile_Factory is new DNS_Profile_Factory with private; function Create_Profile (PF : access MDNS_Profile_Factory; Oid : Objects.Object_Id) return Profile_Access; function Duplicate_Profile (P : MDNS_Profile_Type) return Profile_Access; function Get_Profile_Tag (Profile : MDNS_Profile_Type) return Profile_Tag; pragma Inline (Get_Profile_Tag); function Get_Profile_Preference (Profile : MDNS_Profile_Type) return Profile_Preference; pragma Inline (Get_Profile_Preference); procedure Create_Factory (PF : out MDNS_Profile_Factory; TAP : Transport.Transport_Access_Point_Access; ORB : Components.Component_Access); function Image (Prof : MDNS_Profile_Type) return String; function Get_OA (Profile : MDNS_Profile_Type) return PolyORB.Smart_Pointers.Entity_Ptr; pragma Inline (Get_OA); private type MDNS_Profile_Type is new DNS_Profile_Type with null record; type MDNS_Profile_Factory is new DNS_Profile_Factory with null record; end PolyORB.Binding_Data.DNS.MDNS; polyorb-2.8~20110207.orig/src/dns/mdns/polyorb-setup-mdns.ads0000644000175000017500000000446011750740340023176 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . S E T U P . M D N S -- -- -- -- S p e c -- -- -- -- Copyright (C) 2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by ACT Europe. -- -- (email: sales@act-europe.fr) -- -- -- ------------------------------------------------------------------------------ with PolyORB.Obj_Adapters.Group_Object_Adapter; with PolyORB.Smart_Pointers; package PolyORB.Setup.MDNS is pragma Elaborate_Body; use PolyORB.Obj_Adapters.Group_Object_Adapter; MDNS_GOA : Group_Object_Adapter_Access; MDNS_GOA_Ref : PolyORB.Smart_Pointers.Ref; end PolyORB.Setup.MDNS; polyorb-2.8~20110207.orig/src/dns/mdns/polyorb-protocols-dns-mdns.ads0000644000175000017500000000445611750740340024651 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . P R O T O C O L S . DNS . MDNS -- -- -- -- S p e c -- -- -- -- Copyright (C) 2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by ACT Europe. -- -- (email: sales@act-europe.fr) -- -- -- ------------------------------------------------------------------------------ package PolyORB.Protocols.DNS.MDNS is type MDNS_Protocol is new DNS_Protocol with private; procedure Create (Proto : access MDNS_Protocol; Session : out Filter_Access); private type MDNS_Protocol is new DNS_Protocol with null record; end PolyORB.Protocols.DNS.MDNS; polyorb-2.8~20110207.orig/src/dns/mdns/polyorb-binding_data-dns-mdns.adb0000644000175000017500000002504111750740340025200 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . B I N D I N G _ D A T A . D N S . M D N S -- -- -- -- B o d y -- -- -- -- Copyright (C) 2003-2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with PolyORB.DNS.Transport_Mechanisms; with PolyORB.DNS.Transport_Mechanisms.MDNS; with PolyORB.Initialization; with PolyORB.Log; with PolyORB.Parameters; with PolyORB.References.Corbaloc; with PolyORB.Sockets; with PolyORB.Utils; with PolyORB.Utils.Strings; with PolyORB.Utils.Sockets; with PolyORB.Setup.MDNS; with Ada.Streams; package body PolyORB.Binding_Data.DNS.MDNS is use PolyORB.DNS.Transport_Mechanisms; use PolyORB.DNS.Transport_Mechanisms.MDNS; use PolyORB.Log; use PolyORB.Objects; use PolyORB.References.Corbaloc; use PolyORB.Utils; use PolyORB.Utils.Sockets; use Ada.Streams; package L is new PolyORB.Log.Facility_Log ("polyorb.binding_data.dns.mdns"); procedure O (Message : Standard.String; Level : Log_Level := Debug) renames L.Output; function C (Level : Log_Level := Debug) return Boolean renames L.Enabled; MDNS_Corbaloc_Prefix : constant String := "mdns"; Preference : Profile_Preference; function Profile_To_Corbaloc (P : Profile_Access) return String; function Corbaloc_To_Profile (Str : String) return Profile_Access; --------------------- -- Get_Profile_Tag -- --------------------- function Get_Profile_Tag (Profile : MDNS_Profile_Type) return Profile_Tag is pragma Unreferenced (Profile); begin return Tag_MDNS; end Get_Profile_Tag; ---------------------------- -- Get_Profile_Preference -- ---------------------------- function Get_Profile_Preference (Profile : MDNS_Profile_Type) return Profile_Preference is pragma Unreferenced (Profile); begin return Preference; end Get_Profile_Preference; -------------------- -- Create_Factory -- -------------------- procedure Create_Factory (PF : out MDNS_Profile_Factory; TAP : Transport.Transport_Access_Point_Access; ORB : Components.Component_Access) is pragma Unreferenced (ORB); MF : constant Transport_Mechanism_Factory_Access := new MDNS_Transport_Mechanism_Factory; begin Create_Factory (MF.all, TAP); Append (PF.Mechanisms, MF); end Create_Factory; -------------------- -- Create_Profile -- -------------------- function Create_Profile (PF : access MDNS_Profile_Factory; Oid : Objects.Object_Id) return Profile_Access is Result : constant Profile_Access := new MDNS_Profile_Type; TResult : MDNS_Profile_Type renames MDNS_Profile_Type (Result.all); begin TResult.Object_Id := new Object_Id'(Oid); pragma Debug (C, O ("enter:Oid = " & Image (TResult.Object_Id.all))); -- Create transport mechanism Append (TResult.Mechanisms, Create_Transport_Mechanism (MDNS_Transport_Mechanism_Factory (Element (PF.Mechanisms, 0).all.all))); pragma Debug (C, O ("leave")); return Result; end Create_Profile; ----------------------- -- Duplicate_Profile -- ----------------------- function Duplicate_Profile (P : MDNS_Profile_Type) return Profile_Access is Result : constant Profile_Access := new MDNS_Profile_Type; TResult : MDNS_Profile_Type renames MDNS_Profile_Type (Result.all); begin TResult.Object_Id := new Object_Id'(P.Object_Id.all); TResult.Mechanisms := P.Mechanisms; return Result; end Duplicate_Profile; ------------------------- -- Profile_To_Corbaloc -- ------------------------- function Profile_To_Corbaloc (P : Profile_Access) return String is use PolyORB.Sockets; MDNS_Profile : MDNS_Profile_Type renames MDNS_Profile_Type (P.all); Prefix : constant String := MDNS_Corbaloc_Prefix; Oid_Str : String (1 .. P.Object_Id'Length); pragma Import (Ada, Oid_Str); for Oid_Str'Address use P.Object_Id (P.Object_Id'First)'Address; begin pragma Debug (C, O ("MDNS_Profile_To_Corbaloc")); return Prefix & ":@" & Utils.Sockets.Image (Address_Of (MDNS_Transport_Mechanism (Element (MDNS_Profile.Mechanisms, 0).all.all))) & "/"; end Profile_To_Corbaloc; ------------------------- -- Corbaloc_To_Profile -- ------------------------- function Corbaloc_To_Profile (Str : String) return Profile_Access is Profile : Profile_Access := new MDNS_Profile_Type; TResult : MDNS_Profile_Type renames MDNS_Profile_Type (Profile.all); Host_First, Host_Last : Natural; Port : Sockets.Port_Type; -- Returned in error case S : String renames Str; Index : Integer := S'First; Index2 : Integer; begin pragma Debug (C, O ("MDNS corbaloc to profile: enter: ")); Index := Find (S, S'First, '@') + 1; -- Index at start of host declare Colon : constant Integer := Find (S, Index, ':'); Slash : constant Integer := Find (S, Index, '/'); begin if Colon < Slash then -- Port number is present Index2 := Colon - 1; else Index2 := Slash - 1; end if; if Index2 < Index then -- Empty host Destroy_Profile (Profile); return null; end if; pragma Debug (C, O ("Address = " & S (Index .. Index2))); Host_First := Index; Host_Last := Index2; if Colon < Slash then if Colon + 1 < Slash then pragma Debug (C, O ("Port = " & S (Colon + 1 .. Slash - 1))); Port := PolyORB.Sockets.Port_Type'Value (S (Colon + 1 .. Slash - 1)); else -- Empty port Destroy_Profile (Profile); return null; end if; else Port := 5353; end if; end; if Index > S'Last then -- Empty key_string Destroy_Profile (Profile); return null; end if; declare Slash : constant Integer := Find (S, Index, '/'); Oid_Str : constant String := URI_Decode (S (Slash + 1 .. S'Last)); Oid : Object_Id (Stream_Element_Offset (Oid_Str'First) .. Stream_Element_Offset (Oid_Str'Last)); pragma Import (Ada, Oid); for Oid'Address use Oid_Str (Oid_Str'First)'Address; begin TResult.Object_Id := new Object_Id'(Oid); end; if TResult.Object_Id = null then Destroy_Profile (Profile); return null; end if; pragma Debug (C, O ("Oid = " & Image (TResult.Object_Id.all))); declare Address : constant Utils.Sockets.Socket_Name := S (Host_First .. Host_Last) + Port; begin Append (MDNS_Profile_Type (Profile.all).Mechanisms, Create_Transport_Mechanism (Address)); pragma Debug (C, O ("MDNS corbaloc to profile: leave")); return Profile; end; end Corbaloc_To_Profile; ----------- -- Image -- ----------- function Image (Prof : MDNS_Profile_Type) return String is begin return "Address : " & Utils.Sockets.Image (Address_Of (MDNS_Transport_Mechanism (Element (Prof.Mechanisms, 0).all.all))) & ", Object_Id : " & PolyORB.Objects.Image (Prof.Object_Id.all); end Image; ------------ -- Get_OA -- ------------ function Get_OA (Profile : MDNS_Profile_Type) return PolyORB.Smart_Pointers.Entity_Ptr is pragma Unreferenced (Profile); begin return PolyORB.Smart_Pointers.Entity_Ptr (PolyORB.Setup.MDNS.MDNS_GOA); end Get_OA; ---------------- -- Initialize -- ---------------- procedure Initialize; procedure Initialize is Preference_Offset : constant String := PolyORB.Parameters.Get_Conf (Section => "mdns", Key => "polyorb.binding_data.mdns.preference", Default => "0"); begin Preference := Preference_Default - 1 + Profile_Preference'Value (Preference_Offset); Register (Tag_MDNS, MDNS_Corbaloc_Prefix, Profile_To_Corbaloc'Access, Corbaloc_To_Profile'Access); end Initialize; use PolyORB.Initialization; use PolyORB.Initialization.String_Lists; use PolyORB.Utils.Strings; begin Register_Module (Module_Info' (Name => +"binding_data.mdns", Conflicts => Empty, Depends => +"protocols.dns.mdns" & "sockets", Provides => +"binding_factories", Implicit => False, Init => Initialize'Access, Shutdown => null)); end PolyORB.Binding_Data.DNS.MDNS; polyorb-2.8~20110207.orig/src/dns/mdns/polyorb-dns-transport_mechanisms-mdns.ads0000644000175000017500000001021411750740340027055 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- POLYORB.DNS.TRANSPORT_MECHANISMS.MDNS -- -- -- -- S p e c -- -- -- -- Copyright (C) 2005-2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with PolyORB.Utils.Sockets; package PolyORB.DNS.Transport_Mechanisms.MDNS is type MDNS_Transport_Mechanism is new Transport_Mechanism with private; procedure Bind_Mechanism (Mechanism : MDNS_Transport_Mechanism; Profile : access PolyORB.Binding_Data.Profile_Type'Class; The_ORB : Components.Component_Access; QoS : PolyORB.QoS.QoS_Parameters; BO_Ref : out Smart_Pointers.Ref; Error : out Errors.Error_Container); procedure Release_Contents (M : access MDNS_Transport_Mechanism); -- MDNS Transport Mechanism specific subprograms function Address_Of (M : MDNS_Transport_Mechanism) return Utils.Sockets.Socket_Name; -- Return address of transport mechanism's transport access point. type MDNS_Transport_Mechanism_Factory is new Transport_Mechanism_Factory with private; procedure Create_Factory (MF : out MDNS_Transport_Mechanism_Factory; TAP : Transport.Transport_Access_Point_Access); function Is_Local_Mechanism (MF : access MDNS_Transport_Mechanism_Factory; M : access Transport_Mechanism'Class) return Boolean; -- MDNS Transport Mechanism Factory specific subprograms function Create_Transport_Mechanism (MF : MDNS_Transport_Mechanism_Factory) return Transport_Mechanism_Access; -- Create transport mechanism function Create_Transport_Mechanism (Address : Utils.Sockets.Socket_Name) return Transport_Mechanism_Access; -- Create transport mechanism for specified transport access point address function Duplicate (TMA : MDNS_Transport_Mechanism) return MDNS_Transport_Mechanism; function Is_Colocated (Left : MDNS_Transport_Mechanism; Right : Transport_Mechanism'Class) return Boolean; private Default_TTL : constant Natural := 15; type MDNS_Transport_Mechanism is new Transport_Mechanism with record Address : Utils.Sockets.Socket_Name_Ptr; end record; type MDNS_Transport_Mechanism_Factory is new Transport_Mechanism_Factory with record Address : Utils.Sockets.Socket_Name_Ptr; end record; end PolyORB.DNS.Transport_Mechanisms.MDNS; polyorb-2.8~20110207.orig/src/dns/mdns/polyorb-mdns.ads0000644000175000017500000000423011750740340022033 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . M D N S -- -- -- -- S p e c -- -- -- -- Copyright (C) 2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by ACT Europe. -- -- (email: sales@act-europe.fr) -- -- -- ------------------------------------------------------------------------------ -- The root of all PolyORB packages that are specific to the -- MDNS personality. package PolyORB.MDNS is pragma Pure; end PolyORB.MDNS; polyorb-2.8~20110207.orig/src/dns/mdns/polyorb-protocols-dns-mdns.adb0000644000175000017500000000612311750740340024621 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . P R O T O C O L S . D N S. M D N S -- -- -- -- B o d y -- -- -- -- Copyright (C) 2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with PolyORB.Initialization; with PolyORB.Utils.Strings; package body PolyORB.Protocols.DNS.MDNS is ------------ -- Create -- ------------ procedure Create (Proto : access MDNS_Protocol; Session : out Filter_Access) is begin PolyORB.Protocols.DNS.Create (DNS_Protocol (Proto.all)'Access, Session); end Create; ---------------- -- Initialize -- ---------------- procedure Initialize; procedure Initialize is F : constant Requests.Flags := Sync_None or Sync_With_Transport; pragma Unreferenced (F); begin PolyORB.Protocols.DNS.Initialize; end Initialize; use PolyORB.Initialization; use PolyORB.Initialization.String_Lists; use PolyORB.Utils.Strings; begin Register_Module (Module_Info' (Name => +"protocols.dns.mdns", Conflicts => Empty, Depends => +"setup.mdns", Provides => Empty, Implicit => False, Init => Initialize'Access, Shutdown => null)); end PolyORB.Protocols.DNS.MDNS; polyorb-2.8~20110207.orig/src/dns/polyorb-protocols-dns.adb0000644000175000017500000011647411750740340022734 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . P R O T O C O L S . D N S -- -- -- -- B o d y -- -- -- -- Copyright (C) 2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with PolyORB.Log; with PolyORB.Servants.Iface; with PolyORB.Annotations; with PolyORB.References.Binding; with PolyORB.Any.NVList; with PolyORB.Binding_Data; with PolyORB.Errors; with PolyORB.Initialization; with PolyORB.Utils.Strings; with PolyORB.Representations.DNS; with PolyORB.Utils; with PolyORB.Objects; with PolyORB.Smart_Pointers; with PolyORB.ORB.Iface; with PolyORB.POA; with PolyORB.Binding_Objects; with PolyORB.Any; with PolyORB.Filters.Iface; with PolyORB.Setup; package body PolyORB.Protocols.DNS is use PolyORB.Representations.DNS; use PolyORB.Binding_Objects; use PolyORB.Annotations; use PolyORB.Components; use PolyORB.Log; use PolyORB.References.Binding; use PolyORB.ORB; use PolyORB.Tasking; use PolyORB.Tasking.Mutexes; use PolyORB.Servants.Iface; use PolyORB.Types; use PolyORB.Filters.Iface; use PolyORB.Utils; package L is new PolyORB.Log.Facility_Log ("polyorb.protocols.dns"); procedure O (Message : String; Level : Log_Level := Debug) renames L.Output; function C (Level : Log_Level := Debug) return Boolean renames L.Enabled; ---------------- -- Initialize -- ---------------- procedure Initialize (S : in out DNS_Session) is begin pragma Debug (C, O ("Initializing DNS session")); -- we need to create a mutex to deal with pending requests Tasking.Mutexes.Create (S.Mutex); S.Buffer_In := new Buffer_Type; end Initialize; ------------ -- Create -- ------------ procedure Create (Proto : access DNS_Protocol; Session : out Filter_Access) is pragma Warnings (Off); pragma Unreferenced (Proto); pragma Warnings (On); begin Session := new DNS_Session; pragma Debug (C, O ("Creating DNS Session")); Initialize (DNS_Session (Session.all)); end Create; -------------------- -- Invoke_Request -- -------------------- procedure Invoke_Request (Sess : access DNS_Session; R : Requests.Request_Access; Pro : access Binding_Data.Profile_Type'Class) is use PolyORB.Binding_Data; use PolyORB.Errors; use Unsigned_Long_Flags; New_Pending_Req : Pending_Request_Access; New_Pending_Req_Id : Types.Unsigned_Long; Error : Errors.Error_Container; Success : Boolean; begin New_Pending_Req := new Pending_Request; New_Pending_Req.Req := R; New_Pending_Req.Target_Profile := Profile_Access (Pro); Enter (Sess.Mutex); if Is_Set (Sync_None, R.Req_Flags) or else Is_Set (Sync_With_Transport, R.Req_Flags) then -- Oneway call: we won't see any reply for this request, so we need -- to destroy the pending request information now. New_Pending_Req.Request_Id := Get_Request_Id (Sess); Leave (Sess.Mutex); pragma Debug (C, O ("One way call : No reply expected")); Send_Request (Sess, New_Pending_Req, Error); Free (New_Pending_Req); if Found (Error) then Set_Exception (R.all, Error); Catch (Error); end if; return; end if; -- Two-way call: a reply is expected, we store the pending request Add_Pending_Request (Sess, New_Pending_Req); New_Pending_Req_Id := New_Pending_Req.Request_Id; Leave (Sess.Mutex); pragma Debug (C, O ("Two way call : a reply is expected")); Send_Request (Sess, New_Pending_Req, Error); if Found (Error) then pragma Debug (C, O ("An error is found after Send_Request")); Remove_Pending_Request (Sess, New_Pending_Req_Id, Success); if Success then Set_Exception (R.all, Error); else null; end if; Catch (Error); declare ORB : constant ORB_Access := ORB_Access (Sess.Server); begin Emit_No_Reply (Component_Access (ORB), Servants.Iface.Executed_Request'(Req => R)); end; end if; pragma Debug (C, O ("Invoke_Request : leaving")); end Invoke_Request; ------------------- -- Abort_Request -- ------------------- procedure Abort_Request (S : access DNS_Session; R : Requests.Request_Access) is begin null; -- Process_Abort_Request (S.Implem, S, R); end Abort_Request; ---------------- -- Send_Reply -- ---------------- procedure Send_Reply (S : access DNS_Session; Request : Requests.Request_Access) is use PolyORB.Any; use PolyORB.Any.NVList.Internals; use PolyORB.Any.NVList.Internals.NV_Lists; use PolyORB.Errors; use type PolyORB.Any.TypeCode.Local_Ref; Buffer_Out : Buffer_Access := new Buffer_Type; Header_Buffer : Buffer_Access := new Buffer_Type; Header_Space : Reservation; It : Iterator; Arg : Element_Access; Sess : DNS_Session renames S.all; Error : Errors.Error_Container; begin if Sess.Role = Client then raise DNS_Error; end if; -- XXX: TODO : Manage eventual Exceptions if PolyORB.Any.Is_Empty (Request.Exception_Info) then Sess.MCtx.Rcode_Flag := From_Any (Request.Result.Argument); end if; Set_Endianness (Buffer_Out, Big_Endian); Set_Endianness (Header_Buffer, Big_Endian); Header_Space := Reserve (Buffer_Out, DNS_Header_Size); -- Find and marshall the answer sequence It := First (List_Of (Request.Args).all); Next (It); Next (It); Arg := Value (It); Marshall_From_Any (Buffer_Out, Arg.Argument, True); -- Find and marshall the authority servers RR sequence Next (It); Arg := Value (It); Marshall_From_Any (Buffer_Out, Arg.Argument, True); -- Find and marshall the authority servers RR sequence Next (It); Arg := Value (It); Marshall_From_Any (Buffer_Out, Arg.Argument, True); -- Copy Header Marshall_DNS_Header_Reply (Header_Buffer, Request, Sess.MCtx); Copy_Data (Header_Buffer.all, Header_Space); Release (Header_Buffer); -- Emit reply Emit_Message (Sess'Access, Buffer_Out, Error); Release (Buffer_Out); pragma Debug (C, O ("Reply sent")); end Send_Reply; ------------------------------- -- Handle_Connect_Indication -- ------------------------------- procedure Handle_Connect_Indication (S : access DNS_Session) is begin pragma Debug (C, O ("Handle_Connect_Indication")); S.Role := Server; Initialize_Session (S); Expect_DNS_Header (S); end Handle_Connect_Indication; --------------------------------- -- Handle_Connect_Confirmation -- --------------------------------- procedure Handle_Connect_Confirmation (S : access DNS_Session) is begin pragma Debug (C, O ("Handle_Connect_Confirmation")); S.Role := Client; Initialize_Session (S); Expect_DNS_Header (S); end Handle_Connect_Confirmation; ---------------------------- -- Handle_Data_Indication -- ---------------------------- procedure Handle_Data_Indication (Sess : access DNS_Session; Data_Amount : Ada.Streams.Stream_Element_Count; Error : in out Errors.Error_Container) is use PolyORB.Any.NVList; use PolyORB.Any.TypeCode; use Errors; begin pragma Debug (C, O ("Handle_Data_Indication : Enter")); pragma Debug (C, O ("Received data : " & Data_Amount'Img)); Unmarshall_DNS_Header (Sess.MCtx, Sess.Buffer_In); Process_Message (Sess); Expect_DNS_Header (Sess); pragma Debug (C, O ("Handle_Data_Indication : Leave")); exception when others => Throw (Error, Comm_Failure_E, System_Exception_Members'(0, Completed_Maybe)); end Handle_Data_Indication; ----------------------- -- Handle_Disconnect -- ----------------------- procedure Handle_Disconnect (Sess : access DNS_Session; Error : Errors.Error_Container) is use Pend_Req_Tables; P : Pending_Request_Access; ORB : constant ORB_Access := ORB_Access (Sess.Server); begin pragma Debug (C, O ("Handle_Disconnect: enter")); Enter (Sess.Mutex); if Sess.Buffer_In /= null then Release (Sess.Buffer_In); end if; for J in First (Sess.Pending_Reqs) .. Last (Sess.Pending_Reqs) loop if Sess.Pending_Reqs.Table /= null and then Sess.Pending_Reqs.Table (J) /= null then P := Sess.Pending_Reqs.Table (J); Sess.Pending_Reqs.Table (J) := null; Set_Exception (P.Req.all, Error); References.Binding.Unbind (P.Req.Target); -- After the following call, P.Req is destroyed Emit_No_Reply (Component_Access (ORB), Servants.Iface.Executed_Request'(Req => P.Req)); Free (P); end if; end loop; -- All pending request entries have been cleared: reset table Set_Last (Sess.Pending_Reqs, First (Sess.Pending_Reqs) - 1); Leave (Sess.Mutex); pragma Debug (C, O ("Handle_Disconnect: leave")); end Handle_Disconnect; ------------------ -- Handle_Flush -- ------------------ procedure Handle_Flush (S : access DNS_Session) renames Expect_DNS_Header; ------------------------ -- Expect_DNS_Header -- ------------------------ -- called to wait another DNS message procedure Expect_DNS_Header (Sess : access DNS_Session) is begin -- Check if buffer has been totally read if Remaining (Sess.Buffer_In) /= 0 then pragma Debug (C, O ("Remaining data in buffer :" & Remaining (Sess.Buffer_In)'Img & " bytes")); null; end if; pragma Debug (C, O ("Waiting for next message")); Buffers.Release_Contents (Sess.Buffer_In.all); pragma Debug (C, O ("Expect Header : Here Buffer_In is empty")); Set_Endianness (Sess.Buffer_In, Big_Endian); Emit_No_Reply (Port => Lower (Sess), Msg => Data_Expected' (In_Buf => Sess.Buffer_In, Max => DNS_Header_Size)); end Expect_DNS_Header; -------------------- -- Get_Request_Id -- -------------------- function Get_Request_Id (Sess : access DNS_Session) return Types.Unsigned_Long is R : constant Types.Unsigned_Long := Sess.Req_Index; begin Sess.Req_Index := Sess.Req_Index + 1; return R; end Get_Request_Id; procedure Add_Pending_Request (Sess : access DNS_Session; Pend_Req : Pending_Request_Access) is use Pend_Req_Tables; Request_Id : Types.Unsigned_Long; begin Request_Id := Get_Request_Id (Sess); pragma Debug (C, O ("Adding pending request with id" & Request_Id'Img)); Set_Note (Pend_Req.Req.Notepad, Request_Note'(Annotations.Note with Id => Request_Id)); Pend_Req.Request_Id := Request_Id; for J in First (Sess.Pending_Reqs) .. Last (Sess.Pending_Reqs) loop if Sess.Pending_Reqs.Table (J) = null then Sess.Pending_Reqs.Table (J) := Pend_Req; return; end if; end loop; Increment_Last (Sess.Pending_Reqs); Sess.Pending_Reqs.Table (Last (Sess.Pending_Reqs)) := Pend_Req; end Add_Pending_Request; procedure Get_Pending_Request (Sess : access DNS_Session; Id : Types.Unsigned_Long; Req : out Pending_Request; Success : out Boolean; Remove : Boolean := True) is use Pend_Req_Tables; PRA : Pending_Request_Access; begin pragma Debug (C, O ("Retrieving pending request with id" & Types.Unsigned_Long'Image (Id))); Success := False; Enter (Sess.Mutex); for J in First (Sess.Pending_Reqs) .. Last (Sess.Pending_Reqs) loop if Sess.Pending_Reqs.Table (J) /= null and then Sess.Pending_Reqs.Table (J).Request_Id = Id then PRA := Sess.Pending_Reqs.Table (J); if Remove then Sess.Pending_Reqs.Table (J) := null; end if; Req := PRA.all; if Remove then Free (PRA); end if; Success := True; exit; end if; end loop; Leave (Sess.Mutex); end Get_Pending_Request; procedure Remove_Pending_Request (Sess : access DNS_Session; Id : Types.Unsigned_Long; Success : out Boolean) is use Pend_Req_Tables; PRA : Pending_Request_Access; begin pragma Debug (C, O ("Retrieving pending request with id" & Types.Unsigned_Long'Image (Id))); Enter (Sess.Mutex); Success := False; for J in First (Sess.Pending_Reqs) .. Last (Sess.Pending_Reqs) loop if Sess.Pending_Reqs.Table (J) /= null and then Sess.Pending_Reqs.Table (J).Request_Id = Id then PRA := Sess.Pending_Reqs.Table (J); Sess.Pending_Reqs.Table (J) := null; Free (PRA); Success := True; exit; end if; end loop; Leave (Sess.Mutex); end Remove_Pending_Request; ------------------ -- Emit Message -- ------------------ procedure Emit_Message (S : access Session'Class; Buffer : Buffer_Access; Error : in out Errors.Error_Container) is M : constant Message'Class := Emit (Lower (S), Data_Out'(Out_Buf => Buffer)); begin if M in Filter_Error'Class then Error := Filter_Error (M).Error; else pragma Assert (M in Null_Message'Class); null; end if; end Emit_Message; ------------------ -- Send_Request -- ------------------ procedure Send_Request (S : access Session'Class; R : Pending_Request_Access; Error : in out Errors.Error_Container) is use PolyORB.Any; use PolyORB.Any.NVList.Internals; use PolyORB.Any.NVList.Internals.NV_Lists; use PolyORB.Errors; Sess : DNS_Session renames DNS_Session (S.all); Buffer : Buffer_Access; Header_Buffer : Buffer_Access; Header_Space : Reservation; It : Iterator; Arg : Element_Access; begin pragma Debug (C, O ("Send_Request enter")); Buffer := new Buffer_Type; Set_Endianness (Buffer, Big_Endian); Header_Buffer := new Buffer_Type; Set_Endianness (Header_Buffer, Big_Endian); Header_Space := Reserve (Buffer, DNS_Header_Size); pragma Debug (C, O ("Marshalling request body")); It := First (List_Of (R.Req.Args).all); Next (It); -- Retrieving the number of questions field here, so that -- we could marshall them in the dns header Arg := Value (It); Sess.MCtx.Nb_Questions := Types.Unsigned_Short (Get_Aggregate_Count (Aggregate_Content'Class (Get_Value (Get_Container (Arg.Argument).all).all)) - 1); -- Marshalling the header Sess.MCtx.Message_Type := Request; Marshall_DNS_Header (Header_Buffer, R, Sess.MCtx); -- Marshalling the IN argument : question RR sequence Marshall_From_Any (Buffer, Arg.Argument, False); Copy_Data (Header_Buffer.all, Header_Space); Release (Header_Buffer); Emit_Message (Sess'Access, Buffer, Error); pragma Debug (C, O ("Send_Request : leave")); Release (Buffer); end Send_Request; procedure Process_Message (S : access Session'Class) is pragma Warnings (Off); Sess : DNS_Session renames DNS_Session (S.all); Label_Size : Types.Octet; begin pragma Debug (C, O ("Processing message of type :" & Sess.MCtx.Message_Type'Img)); case Sess.MCtx.Message_Type is when Request => if Sess.Role /= Server then raise DNS_Error; end if; Process_Request (Sess'Access); when Reply => if Sess.Role /= Client then raise DNS_Error; end if; Reply_Received (Sess'Access, Sess.MCtx.Request_Id, Sess.MCtx.Rcode_Flag); when others => raise Program_Error; end case; pragma Debug (C, O ("Processed message : leaving")); end Process_Message; --------------------- -- Process_Request -- --------------------- procedure Process_Request (S : access DNS_Session) is use PolyORB.Any.NVList; use PolyORB.Any.TypeCode; use PolyORB.Binding_Data; use PolyORB.Errors; use PolyORB.References; use PolyORB.Filters.Iface; use PolyORB.Objects; use PolyORB.ORB.Iface; use PolyORB.Smart_Pointers; use PolyORB.POA; use PolyORB.Any; use PolyORB.Servants; Req_Flags : Requests.Flags := 0; Object_Key : PolyORB.Objects.Object_Id_Access; Target_Profile : Binding_Data.Profile_Access; Target : References.Ref; Result : Any.NamedValue; Req : Request_Access; Args : Any.NVList.Ref; Def_Args : Component_Access; New_RR : RR; Q_sequence : rrSequence; A_sequence : rrSequence; Auth_sequence : rrSequence; Add_sequence : rrSequence; Error : Errors.Error_Container; Root_POA : PolyORB.POA.Obj_Adapter_Access := POA.Obj_Adapter_Access (Object_Adapter (PolyORB.Setup.The_ORB)); Child_POA : PolyORB.POA.Obj_Adapter_Access; Servant : Servants.Servant_Access; Return_Code : Types.Unsigned_Short; Request_Type_Code : Types.Unsigned_Short; Request_Class : Types.Unsigned_Short; begin if S.Role /= Server then raise DNS_Error; end if; Q_sequence := To_Sequence (Integer (S.MCtx.Nb_Questions)); Any.NVList.Create (S.MCtx.New_Args); for J in 1 .. S.MCtx.Nb_Questions loop New_RR.rr_name := Unmarshall_DNS_String (S.Buffer_In); Request_Type_Code := Unmarshall (S.Buffer_In); Request_Class := Unmarshall (S.Buffer_In); case Request_Type_Code is when A_Code => New_RR.rr_type := A; when PTR_Code => New_RR.rr_type := PTR; when TXT_Code => New_RR.rr_type := TXT; when SRV_Code => New_RR.rr_type := SRV; when others => -- should not happen for now raise DNS_Error; end case; -- Assigning the question rrSequence Current_Question_Nb := Current_Question_Nb + 1; Replace_Element (Q_sequence, Integer (Current_Question_Nb), New_RR); end loop; Current_Question_Nb := 0; -- Assigning the in out authoritative argument Add_Item (S.MCtx.New_Args, Arg_Name_Auth, To_Any (S.MCtx.AA_Flag), Any.ARG_INOUT); -- Assigning the question rrSequence Add_Item (S.MCtx.New_Args, Arg_Name_Question, To_Any (Q_sequence), Any.ARG_IN); -- initializing the out Answer rr sequence Add_Item (S.MCtx.New_Args, Arg_Name_Answer, To_Any (A_sequence), Any.ARG_OUT); -- initializing the out Authority rr sequence Add_Item (S.MCtx.New_Args, Arg_Name_Au, To_Any (Auth_sequence), Any.ARG_OUT); -- initializing the out Additional infos rr sequence Add_Item (S.MCtx.New_Args, Arg_Name_Add, To_Any (Add_sequence), Any.ARG_OUT); -- Retrieve the default servant, specified by user Target := Get_Default_Servant; Create_Request (Target => Target, Operation => To_Standard_String (S.MCtx.Request_Opcode), Arg_List => S.MCtx.New_Args, Result => Result, Deferred_Arguments_Session => null, Req => Req, Req_Flags => Sync_With_Target, Dependent_Binding_Object => Smart_Pointers.Entity_Ptr (S.Dependent_Binding_Object)); Queue_Request_To_Handler (ORB_Access (S.Server), Queue_Request' (Request => Req, Requestor => Component_Access (S))); pragma Debug (C, O ("Process_Request: leaving")); end Process_Request; procedure Initialize_Session (S : access Session'Class) is Sess : DNS_Session renames DNS_Session (S.all); begin pragma Debug (C, O ("Initialize context for DNS session")); Sess.MCtx := new DNS_Message_Ctx; end Initialize_Session; ---------------------- -- Finalize_Session -- ---------------------- procedure Finalize_Session (S : access Session'Class) is pragma Warnings (Off); Sess : DNS_Session renames DNS_Session (S.all); begin null; -- Free (Sess.MCtx); pragma Debug (C, O ("Finalize context for DNS session")); end Finalize_Session; procedure Initialize is begin pragma Debug (C, O ("Initializing DNS Protocol...")); null; end Initialize; procedure Marshall_DNS_Header (Header_Buffer : access Buffers.Buffer_Type; R : Pending_Request_Access; MCtx : access DNS_Message_Context'Class) is use PolyORB.Any; use PolyORB.Any.NVList.Internals; use PolyORB.Any.NVList.Internals.NV_Lists; Arg : Element_Access; Test_Request_Id : Types.Unsigned_Short; Header_Flags : Flags; begin -- Marshall DNS request header pragma Debug (C, O ("Marshalling DNS request header")); -- Marshalling the transaction number MCtx.Request_Id := R.Request_Id; Marshall (Header_Buffer, Types.Unsigned_Short (MCtx.Request_Id)); Header_Flags := 0; -- Marshalling the DNS header flags -- message is a request MCtx.QR_Flag := (MCtx.Message_Type = Reply); Unsigned_Short_Flags.Set (Header_Flags, QR_Flag_Pos, MCtx.QR_Flag); if R.Req.Operation.all = Query_Name then -- message is a standard query (0) - no flags to set pragma Debug (C, O ("request is a standard Query")); MCtx.Opcode_Flag := Query; elsif R.Req.Operation.all = IQuery_Name then pragma Debug (C, O ("request is an IQuery")); MCtx.Opcode_Flag := IQuery; Unsigned_Short_Flags.Set (Header_Flags, Opcode_Flag_Pos + 3, True); elsif R.Req.Operation.all = Status_Name then pragma Debug (C, O ("request is a Status Query")); MCtx.Opcode_Flag := Status; Unsigned_Short_Flags.Set (Header_Flags, Opcode_Flag_Pos + 2, True); end if; -- Marshalling the authoritative flag -- : retrieve it from the request's arguments list Arg := Value (First (List_Of (R.Req.Args).all)); Unsigned_Short_Flags.Set (Header_Flags, AA_Flag_Pos, PolyORB.Types.Boolean'(From_Any (Arg.Argument))); pragma Debug (C, O ("retrieved authoritative flag")); -- TODO : if message size > max_message_size then tc=1 MCtx.TC_Flag := False; Unsigned_Short_Flags.Set (Header_Flags, TC_Flag_Pos, MCtx.TC_Flag); pragma Debug (C, O ("TC_Flag is set")); MCtx.Rec_Flag := False; Unsigned_Short_Flags.Set (Header_Flags, Rec_Flag_Pos, MCtx.Rec_Flag); pragma Debug (C, O ("Rec_Flag is set")); MCtx.Rec_Disp_Flag := False; Unsigned_Short_Flags.Set (Header_Flags, Rec_Disp_Flag_Pos, MCtx.Rec_Disp_Flag); pragma Debug (C, O ("Rec_Disp_Flag is set")); -- As this is a query,not a response, Rcode = No_Error MCtx.Rcode_Flag := No_Error; pragma Debug (C, O ("marshalling flags")); Marshall (Header_Buffer, Types.Unsigned_Short (Header_Flags)); -- Number of questions being sent pragma Debug (C, O ("marsh. of questions : " & MCtx.Nb_Questions'Img)); Marshall (Header_Buffer, MCtx.Nb_Questions); -- By default, for a query, next fields = 0 MCtx.Nb_Answers := 0; Marshall (Header_Buffer, MCtx.Nb_Answers); MCtx.Nb_Auth_Servers := 0; Marshall (Header_Buffer, MCtx.Nb_Auth_Servers); MCtx.Nb_Add_Infos := 0; Marshall (Header_Buffer, MCtx.Nb_Add_Infos); end Marshall_DNS_Header; ---------------------------- -- Unmarshall_DNS_Header -- ---------------------------- procedure Unmarshall_DNS_Header (MCtx_Acc : access DNS_Message_Context'Class; Buffer : access Buffers.Buffer_Type) is Header_Flags : Flags; Flags_Buffer : Types.Unsigned_Short; MCtx : DNS_Message_Context renames DNS_Message_Context (MCtx_Acc.all); Test_Request_Id : Types.Unsigned_Short; begin pragma Debug (C, O ("Unmarshalling DNS header")); -- Extract Request_Id Test_Request_Id := Unmarshall (Buffer); pragma Debug (C, O ("Request ID :" & Test_Request_Id'Img)); MCtx.Request_Id := Types.Unsigned_Long (Test_Request_Id); -- Extract the DNS header flags Flags_Buffer := Unmarshall (Buffer); Header_Flags := Flags (Flags_Buffer); if Is_Set (QR_Flag_Pos, Header_Flags) then MCtx.Message_Type := Reply; else MCtx.Message_Type := Request; end if; pragma Debug (C, O ("Message is a : " & MCtx.Message_Type'Img)); if Is_Set (Opcode_Flag_Pos + 3, Header_Flags) then MCtx.Opcode_Flag := IQuery; MCtx.Request_Opcode := To_PolyORB_String (IQuery_Name); elsif Is_Set (Opcode_Flag_Pos + 2, Header_Flags) then MCtx.Opcode_Flag := Status; MCtx.Request_Opcode := To_PolyORB_String (Status_Name); else MCtx.Opcode_Flag := Query; MCtx.Request_Opcode := To_PolyORB_String (Query_Name); end if; MCtx.AA_Flag := Is_Set (AA_Flag_Pos, Header_Flags); MCtx.TC_Flag := Is_Set (TC_Flag_Pos, Header_Flags); MCtx.Rec_Flag := Is_Set (Rec_Flag_Pos, Header_Flags); MCtx.Rec_Disp_Flag := Is_Set (Rcode_Flag_Pos + 3, Header_Flags); -- currently only No_Error and Name_Error cases are supported if not Is_Set (Rcode_Flag_Pos + 3, Header_Flags) then if not Is_Set (Rcode_Flag_Pos + 2, Header_Flags) then if not Is_Set (Rcode_Flag_Pos + 1, Header_Flags) then if not Is_Set (Rcode_Flag_Pos, Header_Flags) then MCtx.Rcode_Flag := No_Error; end if; else if Is_Set (Rcode_Flag_Pos, Header_Flags) then MCtx.Rcode_Flag := Name_Error; end if; end if; end if; end if; pragma Debug (C, O ("RCODE :" & MCtx.Rcode_Flag'Img)); MCtx.Nb_Questions := Unmarshall (Buffer); pragma Debug (C, O ("NB Questions :" & MCtx.Nb_Questions'Img)); MCtx.Nb_Answers := Unmarshall (Buffer); pragma Debug (C, O ("NB Resp :" & MCtx.Nb_Answers'Img)); MCtx.Nb_Auth_Servers := Unmarshall (Buffer); pragma Debug (C, O ("NB Auth :" & MCtx.Nb_Auth_Servers'Img)); MCtx.Nb_Add_Infos := Unmarshall (Buffer); pragma Debug (C, O ("NB Add Inf :" & MCtx.Nb_Auth_Servers'Img)); pragma Debug (C, O ("Leaving Unmarshall_DNS_Header")); end Unmarshall_DNS_Header; procedure Marshall_DNS_Header_Reply (Header_Buffer : access Buffers.Buffer_Type; R : Requests.Request_Access; MCtx : access DNS_Message_Context'Class) is use PolyORB.Any; use PolyORB.Any.NVList.Internals; use PolyORB.Any.NVList.Internals.NV_Lists; Arg : Element_Access; Header_Flags : Flags; It : Iterator; begin -- Marshall DNS request header pragma Debug (C, O ("Marshall_DNS_Header_Reply: enter")); Marshall (Header_Buffer, Types.Unsigned_Short (MCtx.Request_Id)); -- Marshalling the DNS header flags; Header_Flags := 0; -- message is a reply MCtx.Message_Type := Reply; MCtx.QR_Flag := (MCtx.Message_Type = Reply); Unsigned_Short_Flags.Set (Header_Flags, QR_Flag_Pos, MCtx.QR_Flag); if R.Operation.all = Query_Name then -- message is a standard query (0) - no flags to set pragma Debug (C, O ("request is a standard Query")); MCtx.Opcode_Flag := Query; elsif R.Operation.all = IQuery_Name then pragma Debug (C, O ("request is an IQuery")); MCtx.Opcode_Flag := IQuery; Unsigned_Short_Flags.Set (Header_Flags, Opcode_Flag_Pos + 3, True); elsif R.Operation.all = Status_Name then pragma Debug (C, O ("request is a Status Query")); MCtx.Opcode_Flag := Status; Unsigned_Short_Flags.Set (Header_Flags, QR_Flag_Pos + 2, True); end if; -- Marshalling the authoritative flag -- : retrieve it from the request's arguments list It := First (List_Of (R.Args).all); Arg := Value (It); Unsigned_Short_Flags.Set (Header_Flags, AA_Flag_Pos, PolyORB.Types.Boolean'(From_Any (Arg.Argument))); pragma Debug (C, O ("Authoritative flag : ")); -- TODO : if message size > max_message_size then tc=1 MCtx.TC_Flag := False; Unsigned_Short_Flags.Set (Header_Flags, TC_Flag_Pos, MCtx.TC_Flag); MCtx.Rec_Flag := False; Unsigned_Short_Flags.Set (Header_Flags, Rec_Flag_Pos, MCtx.Rec_Flag); MCtx.Rec_Disp_Flag := False; Unsigned_Short_Flags.Set (Header_Flags, Rec_Disp_Flag_Pos, MCtx.Rec_Disp_Flag); -- three reserved bits case MCtx.Rcode_Flag is -- No Error : 0x0000 when No_Error => null; -- Format Error : 0x0001 when Format_Error => Unsigned_Short_Flags.Set (Header_Flags, Rcode_Flag_Pos, True); -- Server Failure : 0x0010 when Server_Failure => Unsigned_Short_Flags.Set (Header_Flags, Rcode_Flag_Pos + 1, True); -- Name Error : 0x0011 when PolyORB.DNS.Helper.Name_Error => Unsigned_Short_Flags.Set (Header_Flags, Rcode_Flag_Pos, True); Unsigned_Short_Flags.Set (Header_Flags, Rcode_Flag_Pos + 1, True); -- Not Implemented : 0x0100 when Not_Implemented => Unsigned_Short_Flags.Set (Header_Flags, Rcode_Flag_Pos + 2, True); -- Refused : 0x0101 when Refused => Unsigned_Short_Flags.Set (Header_Flags, Rcode_Flag_Pos, True); Unsigned_Short_Flags.Set (Header_Flags, Rcode_Flag_Pos + 2, True); -- YX Domain - name exists: 0x0110 when YX_Domain => Unsigned_Short_Flags.Set (Header_Flags, Rcode_Flag_Pos + 1, True); Unsigned_Short_Flags.Set (Header_Flags, Rcode_Flag_Pos + 2, True); -- YX RR set exists : 0x0111 when YX_RRSet => Unsigned_Short_Flags.Set (Header_Flags, Rcode_Flag_Pos, True); Unsigned_Short_Flags.Set (Header_Flags, Rcode_Flag_Pos + 1, True); Unsigned_Short_Flags.Set (Header_Flags, Rcode_Flag_Pos + 2, True); -- NX RR set does not exist : 0x1000 when NX_RRSet => Unsigned_Short_Flags.Set (Header_Flags, Rcode_Flag_Pos + 3, True); -- Not Authoritative : 0x1001 when Not_Auth => Unsigned_Short_Flags.Set (Header_Flags, Rcode_Flag_Pos, True); Unsigned_Short_Flags.Set (Header_Flags, Rcode_Flag_Pos + 3, True); -- Name is out of zone : 0x1010 when Not_Zone => Unsigned_Short_Flags.Set (Header_Flags, Rcode_Flag_Pos + 3, True); Unsigned_Short_Flags.Set (Header_Flags, Rcode_Flag_Pos + 1, True); end case; pragma Debug (C, O ("Flags have been set ")); Marshall (Header_Buffer, Types.Unsigned_Short (Header_Flags)); Next (It); -- Number of questions being sent -- XXX : Should nb questions be always 0 for an answer? MCtx.Nb_Questions := 0; Marshall (Header_Buffer, MCtx.Nb_Questions); Next (It); -- Retrieving the number of answers field here, so that -- we could marshall them in the dns header Arg := Value (It); MCtx.Nb_Answers := Types.Unsigned_Short (Get_Aggregate_Count (Aggregate_Content'Class (Get_Value (Get_Container (Arg.Argument).all).all)) - 1); Marshall (Header_Buffer, MCtx.Nb_Answers); -- retrieve and marshall nb of authority servers Next (It); Arg := Value (It); MCtx.Nb_Auth_Servers := Types.Unsigned_Short (Get_Aggregate_Count (Aggregate_Content'Class (Get_Value (Get_Container (Arg.Argument).all).all)) - 1); Marshall (Header_Buffer, MCtx.Nb_Auth_Servers); -- retrieve and marshall nb of additionnal infos Next (It); Arg := Value (It); MCtx.Nb_Add_Infos := Types.Unsigned_Short (Get_Aggregate_Count (Aggregate_Content'Class (Get_Value (Get_Container (Arg.Argument).all).all)) - 1); Marshall (Header_Buffer, MCtx.Nb_Add_Infos); pragma Debug (C, O ("Marshall_DNS_Header_Reply: leave")); end Marshall_DNS_Header_Reply; procedure Unmarshall_Argument_List (Sess : access DNS_Session; Args : in out Any.NVList.Ref; Direction : Any.Flags; Error : in out Errors.Error_Container) is use PolyORB.Any; use PolyORB.Any.NVList.Internals; use PolyORB.Any.NVList.Internals.NV_Lists; use PolyORB.Errors; It : Iterator := First (List_Of (Args).all); Arg : Element_Access; pragma Unreferenced (Error); begin -- We know in advance the different types of the arguments -- First one is the authoritative flags - direction in out Arg := Value (It); if Arg.Arg_Modes = ARG_INOUT then pragma Debug (C, O ("First arg is: inout")); Set_Any_Value (Sess.MCtx.AA_Flag, Get_Container (Arg.Argument).all); end if; Next (It); Next (It); Arg := Value (It); Unmarshall_To_Any (Sess.Buffer_In, Arg.Argument, Integer (Sess.MCtx.Nb_Answers), True); -- authority rr sequence Next (It); Arg := Value (It); Unmarshall_To_Any (Sess.Buffer_In, Arg.Argument, Integer (Sess.MCtx.Nb_Auth_Servers), True); -- additionnal info rr sequence Next (It); Arg := Value (It); Unmarshall_To_Any (Sess.Buffer_In, Arg.Argument, Integer (Sess.MCtx.Nb_Add_Infos), True); pragma Debug (C, O ("Leaving Unmarshall_Argument_List")); end Unmarshall_Argument_List; procedure Reply_Received (Sess : access DNS_Session; Request_Id : Types.Unsigned_Long; RC : Rcode) is use PolyORB.Any; use PolyORB.Errors; Current_Req : Pending_Request; Success : Boolean; ORB : constant ORB_Access := ORB_Access (Sess.Server); Error : Errors.Error_Container; begin pragma Debug (C, O ("Reply received: status = " & Rcode'Image (RC) & ", id =" & Types.Unsigned_Long'Image (Request_Id))); Get_Pending_Request (Sess, Request_Id, Current_Req, Success); if not Success then raise DNS_Error; end if; case RC is when No_Error => pragma Debug (C, O ("No_Error : Unmarshall Reply Body")); Copy_Any_Value (Current_Req.Req.Result.Argument, To_Any (RC)); pragma Debug (C, O ("After Copy Any Value")); -- Unmarshall reply body. Unmarshall_Argument_List (Sess, Current_Req.Req.Args, PolyORB.Any.ARG_OUT, Error); pragma Debug (C, O ("After Unmarshall_Argument_List")); -- inform the requestor that the request has been executed Emit_No_Reply (Current_Req.Req.Requesting_Component, Servants.Iface.Executed_Request' (Req => Current_Req.Req)); pragma Debug (C, O ("After Emit No_Reply")); when Name_Error => pragma Debug (C, O ("Name_Error : Record was not found")); Copy_Any_Value (Current_Req.Req.Result.Argument, To_Any (RC)); Emit_No_Reply (Current_Req.Req.Requesting_Component, Servants.Iface.Executed_Request' (Req => Current_Req.Req)); when others => Emit_No_Reply (Component_Access (ORB), Servants.Iface.Executed_Request' (Req => Current_Req.Req)); end case; end Reply_Received; procedure Set_Default_Servant (The_Ref : PolyORB.References.Ref) is begin Object_Reference := The_Ref; end Set_Default_Servant; function Get_Default_Servant return PolyORB.References.Ref is begin return Object_Reference; end Get_Default_Servant; use PolyORB.Initialization; use PolyORB.Initialization.String_Lists; use PolyORB.Utils.Strings; begin pragma Debug (C, O ("Registering Module PROTOCOLS.DNS")); Register_Module (Module_Info' (Name => +"protocols.dns", Conflicts => Empty, Depends => Empty, Provides => Empty, Implicit => False, Init => Initialize'Access, Shutdown => null)); end PolyORB.Protocols.DNS; polyorb-2.8~20110207.orig/src/dns/polyorb-binding_data-dns.adb0000644000175000017500000001345611750740340023307 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . B I N D I N G _ D A T A . D N S -- -- -- -- B o d y -- -- -- -- Copyright (C) 2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ package body PolyORB.Binding_Data.DNS is use PolyORB.Errors; use PolyORB.DNS.Transport_Mechanisms; use PolyORB.Objects; use PolyORB.Types; ------------------ -- Bind_Profile -- ------------------ procedure Bind_Profile (Profile : access DNS_Profile_Type; The_ORB : Components.Component_Access; QoS : PolyORB.QoS.QoS_Parameters; BO_Ref : out Smart_Pointers.Ref; Error : out Errors.Error_Container) is use Transport_Mechanism_Lists; Iter : Transport_Mechanism_Lists.Iterator := First (Profile.Mechanisms); begin Throw (Error, No_Resources_E, System_Exception_Members' (Minor => 0, Completed => Completed_Maybe)); while not Last (Iter) loop Catch (Error); Bind_Mechanism (Value (Iter).all.all, Profile, The_ORB, QoS, BO_Ref, Error); exit when not Found (Error); Next (Iter); end loop; end Bind_Profile; ------------------ -- Is_Colocated -- ------------------ function Is_Colocated (Left : DNS_Profile_Type; Right : Profile_Type'Class) return Boolean is begin if Right not in DNS_Profile_Type'Class then return False; end if; -- Compare transport mechanisms declare L_Mechanisms, R_Mechanisms : Transport_Mechanism_List; begin L_Mechanisms := Left.Mechanisms; R_Mechanisms := DNS_Profile_Type (Right).Mechanisms; return Is_Colocated (L_Mechanisms, R_Mechanisms); end; end Is_Colocated; ---------------------- -- Is_Local_Profile -- ---------------------- function Is_Local_Profile (PF : access DNS_Profile_Factory; P : access Profile_Type'Class) return Boolean is use Transport_Mechanism_Lists; use Transport_Mechanism_Factory_Lists; F_Iter : Transport_Mechanism_Factory_Lists.Iterator := First (PF.Mechanisms); begin if P.all not in DNS_Profile_Type'Class then return False; end if; -- Profile designates a local object if at least one of its -- transport mechanism is local. while not Last (F_Iter) loop declare M_Iter : Transport_Mechanism_Lists.Iterator := First (DNS_Profile_Type (P.all).Mechanisms); begin while not Last (M_Iter) loop if Is_Local_Mechanism (Value (F_Iter).all, Value (M_Iter).all) then P.Known_Local := True; return True; end if; Next (M_Iter); end loop; end; Next (F_Iter); end loop; return False; end Is_Local_Profile; ------------------------------------- -- Get_Primary_Transport_Mechanism -- ------------------------------------- function Get_Primary_Transport_Mechanism (P : DNS_Profile_Type) return PolyORB.DNS.Transport_Mechanisms.Transport_Mechanism_Access is begin return Element (P.Mechanisms, 0).all; end Get_Primary_Transport_Mechanism; --------------------------------------------- -- Get_Primary_Transport_Mechanism_Factory -- --------------------------------------------- function Get_Primary_Transport_Mechanism_Factory (P : DNS_Profile_Factory) return PolyORB.DNS.Transport_Mechanisms.Transport_Mechanism_Factory_Access is begin return Element (P.Mechanisms, 0).all; end Get_Primary_Transport_Mechanism_Factory; ------------- -- Release -- ------------- procedure Release (P : in out DNS_Profile_Type) is begin Free (P.Object_Id); PolyORB.Annotations.Destroy (P.Notepad); -- XXX This is a temporary fix -- Release_Contents (P.Mechanisms); end Release; end PolyORB.Binding_Data.DNS; polyorb-2.8~20110207.orig/src/dns/udns/0000755000175000017500000000000011750740340016726 5ustar xavierxavierpolyorb-2.8~20110207.orig/src/dns/udns/polyorb-binding_data-dns-udns.ads0000644000175000017500000000651211750740340025243 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . B I N D I N G _ D A T A . D N S . U D N S -- -- -- -- S p e c -- -- -- -- Copyright (C) 2003-2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- Package providing the data binding facilities for the uDNS transport -- mechanism, specific to the DNS protocol personality package PolyORB.Binding_Data.DNS.UDNS is DNS_Error : exception; type UDNS_Profile_Type is new DNS_Profile_Type with private; type UDNS_Profile_Factory is new DNS_Profile_Factory with private; function Create_Profile (PF : access UDNS_Profile_Factory; Oid : Objects.Object_Id) return Profile_Access; function Duplicate_Profile (P : UDNS_Profile_Type) return Profile_Access; function Get_Profile_Tag (Profile : UDNS_Profile_Type) return Profile_Tag; pragma Inline (Get_Profile_Tag); function Get_Profile_Preference (Profile : UDNS_Profile_Type) return Profile_Preference; pragma Inline (Get_Profile_Preference); procedure Create_Factory (PF : out UDNS_Profile_Factory; TAP : Transport.Transport_Access_Point_Access; ORB : Components.Component_Access); function Image (Prof : UDNS_Profile_Type) return String; function Get_OA (Profile : UDNS_Profile_Type) return PolyORB.Smart_Pointers.Entity_Ptr; pragma Inline (Get_OA); private type UDNS_Profile_Type is new DNS_Profile_Type with null record; type UDNS_Profile_Factory is new DNS_Profile_Factory with null record; end PolyORB.Binding_Data.DNS.UDNS; polyorb-2.8~20110207.orig/src/dns/udns/polyorb-setup-udns.ads0000644000175000017500000000413111750740340023211 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . S E T U P . U D N S -- -- -- -- S p e c -- -- -- -- Copyright (C) 2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by ACT Europe. -- -- (email: sales@act-europe.fr) -- -- -- ------------------------------------------------------------------------------ package PolyORB.Setup.UDNS is pragma Elaborate_Body; end PolyORB.Setup.UDNS; polyorb-2.8~20110207.orig/src/dns/udns/polyorb-setup-udns.adb0000644000175000017500000000541411750740340023175 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . S E T U P . U D N S -- -- -- -- B o d y -- -- -- -- Copyright (C) 2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ pragma Warnings (Off); -- No entities referenced. with PolyORB.Protocols.DNS; pragma Warnings (On); with PolyORB.Initialization; with PolyORB.Utils.Strings; package body PolyORB.Setup.UDNS is ---------------- -- Initialize -- ---------------- procedure Initialize; procedure Initialize is begin null; end Initialize; use PolyORB.Initialization; use PolyORB.Initialization.String_Lists; use PolyORB.Utils.Strings; begin Register_Module (Module_Info' (Name => +"setup.udns", Conflicts => Empty, Depends => +"protocols.dns" & "smart_pointers", Provides => Empty, Implicit => False, Init => Initialize'Access, Shutdown => null)); end PolyORB.Setup.UDNS; polyorb-2.8~20110207.orig/src/dns/udns/polyorb-setup-access_points-udns.ads0000644000175000017500000000422011750740340026043 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . S E T U P . A C C E S S _ P O I N T S . U D N S -- -- -- -- S p e c -- -- -- -- Copyright (C) 2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- Setup socket for UDNS package PolyORB.Setup.Access_Points.UDNS is pragma Elaborate_Body; end PolyORB.Setup.Access_Points.UDNS; polyorb-2.8~20110207.orig/src/dns/udns/polyorb-setup-access_points-udns.adb0000644000175000017500000001162511750740340026031 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . S E T U P . A C C E S S _ P O I N T S . U D N S -- -- -- -- B o d y -- -- -- -- Copyright (C) 2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- Setup socket for UDNS with PolyORB.Binding_Data.DNS.UDNS; with PolyORB.Filters; with PolyORB.Initialization; with PolyORB.Utils.Socket_Access_Points; with PolyORB.ORB; with PolyORB.Parameters; with PolyORB.Protocols; with PolyORB.Protocols.DNS.UDNS; with PolyORB.Sockets; with PolyORB.Transport.Datagram.Sockets; with PolyORB.Utils.Strings; with PolyORB.Utils.UDP_Access_Points; package body PolyORB.Setup.Access_Points.UDNS is use PolyORB.Filters; use PolyORB.ORB; use PolyORB.Sockets; use PolyORB.Transport.Datagram.Sockets; use PolyORB.Utils.UDP_Access_Points; use PolyORB.Utils.Socket_Access_Points; UDNS_Access_Point : UDP_Access_Point_Info := (Socket => No_Socket, Address => No_Sock_Addr, SAP => new Socket_Access_Point, PF => new PolyORB.Binding_Data.DNS.UDNS.UDNS_Profile_Factory); Pro : aliased Protocols.DNS.UDNS.UDNS_Protocol; UDNS_Factories : aliased Filters.Factory_Array := (0 => Pro'Access); ------------------------------ -- Initialize_Access_Points -- ------------------------------ procedure Initialize_Access_Points; procedure Initialize_Access_Points is use PolyORB.Parameters; -- Addr : constant String := -- Get_Conf ("udns", "polyorb.udns.multicast_addr", ""); -- Port : constant Port_Type := -- Port_Type (Get_Conf ("udns", "polyorb.udns.multicast_port", 0)); Addr : constant Inet_Addr_Type := Inet_Addr (String'( Get_Conf ("udns", "polyorb.udns.unicast_addr", Image (No_Inet_Addr)))); -- Port : constant Port_Type := -- Port_Type (Get_Conf ("udns", "polyorb.udns.unicast_port", 0)); Port_Hint : constant Port_Interval := To_Port_Interval (Get_Conf ("udns", "polyorb.udns.unicast_port", (Integer (Any_Port), Integer (Any_Port)))); begin if Get_Conf ("access_points", "udns", True) then -- Initialize_Multicast_Socket -- (UDNS_Access_Point, Inet_Addr (Addr), Port); Initialize_Unicast_Socket (UDNS_Access_Point, Port_Hint, Addr); Register_Access_Point (ORB => The_ORB, TAP => UDNS_Access_Point.SAP, Chain => UDNS_Factories'Access, PF => UDNS_Access_Point.PF); end if; end Initialize_Access_Points; use PolyORB.Initialization; use PolyORB.Initialization.String_Lists; use PolyORB.Utils.Strings; begin Register_Module (Module_Info' (Name => +"access_points.udns", Conflicts => String_Lists.Empty, Depends => +"orb" & "sockets", Provides => String_Lists.Empty, Implicit => False, Init => Initialize_Access_Points'Access, Shutdown => null)); end PolyORB.Setup.Access_Points.UDNS; polyorb-2.8~20110207.orig/src/dns/udns/polyorb-protocols-dns-udns.ads0000644000175000017500000000445611750740340024671 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . P R O T O C O L S . DNS . UDNS -- -- -- -- S p e c -- -- -- -- Copyright (C) 2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by ACT Europe. -- -- (email: sales@act-europe.fr) -- -- -- ------------------------------------------------------------------------------ package PolyORB.Protocols.DNS.UDNS is type UDNS_Protocol is new DNS_Protocol with private; procedure Create (Proto : access UDNS_Protocol; Session : out Filter_Access); private type UDNS_Protocol is new DNS_Protocol with null record; end PolyORB.Protocols.DNS.UDNS; polyorb-2.8~20110207.orig/src/dns/udns/polyorb-binding_data-dns-udns.adb0000644000175000017500000002475511750740340025233 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . B I N D I N G _ D A T A . D N S . U D N S -- -- -- -- B o d y -- -- -- -- Copyright (C) 2003-2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with Ada.Streams; with PolyORB.DNS.Transport_Mechanisms; with PolyORB.DNS.Transport_Mechanisms.UDNS; with PolyORB.Initialization; with PolyORB.Log; with PolyORB.ORB; with PolyORB.Parameters; with PolyORB.References.Corbaloc; with PolyORB.Setup.UDNS; with PolyORB.Sockets; with PolyORB.Utils; with PolyORB.Utils.Sockets; with PolyORB.Utils.Strings; package body PolyORB.Binding_Data.DNS.UDNS is use Ada.Streams; use PolyORB.DNS.Transport_Mechanisms; use PolyORB.DNS.Transport_Mechanisms.UDNS; use PolyORB.Log; use PolyORB.Objects; use PolyORB.References.Corbaloc; use PolyORB.Utils; use PolyORB.Utils.Sockets; package L is new PolyORB.Log.Facility_Log ("polyorb.binding_data.dns.udns"); procedure O (Message : Standard.String; Level : Log_Level := Debug) renames L.Output; function C (Level : Log_Level := Debug) return Boolean renames L.Enabled; UDNS_Corbaloc_Prefix : constant String := "udns"; Preference : Profile_Preference; function Profile_To_Corbaloc (P : Profile_Access) return String; function Corbaloc_To_Profile (Str : String) return Profile_Access; --------------------- -- Get_Profile_Tag -- --------------------- function Get_Profile_Tag (Profile : UDNS_Profile_Type) return Profile_Tag is pragma Unreferenced (Profile); begin return Tag_UDNS; end Get_Profile_Tag; ---------------------------- -- Get_Profile_Preference -- ---------------------------- function Get_Profile_Preference (Profile : UDNS_Profile_Type) return Profile_Preference is pragma Unreferenced (Profile); begin return Preference; end Get_Profile_Preference; -------------------- -- Create_Factory -- -------------------- procedure Create_Factory (PF : out UDNS_Profile_Factory; TAP : Transport.Transport_Access_Point_Access; ORB : Components.Component_Access) is pragma Unreferenced (ORB); MF : constant Transport_Mechanism_Factory_Access := new UDNS_Transport_Mechanism_Factory; begin Create_Factory (MF.all, TAP); Append (PF.Mechanisms, MF); end Create_Factory; -------------------- -- Create_Profile -- -------------------- function Create_Profile (PF : access UDNS_Profile_Factory; Oid : Objects.Object_Id) return Profile_Access is Result : constant Profile_Access := new UDNS_Profile_Type; TResult : UDNS_Profile_Type renames UDNS_Profile_Type (Result.all); begin pragma Debug (C, O ("enter: Oid = " & Image (Oid))); TResult.Object_Id := new Object_Id'(Oid); -- Create transport mechanism Append (TResult.Mechanisms, Create_Transport_Mechanism (UDNS_Transport_Mechanism_Factory (Element (PF.Mechanisms, 0).all.all))); pragma Debug (C, O ("leave")); return Result; end Create_Profile; ----------------------- -- Duplicate_Profile -- ----------------------- function Duplicate_Profile (P : UDNS_Profile_Type) return Profile_Access is Result : constant Profile_Access := new UDNS_Profile_Type; TResult : UDNS_Profile_Type renames UDNS_Profile_Type (Result.all); begin TResult.Object_Id := new Object_Id'(P.Object_Id.all); TResult.Mechanisms := P.Mechanisms; return Result; end Duplicate_Profile; ------------------------- -- Profile_To_Corbaloc -- ------------------------- function Profile_To_Corbaloc (P : Profile_Access) return String is use PolyORB.Sockets; UDNS_Profile : UDNS_Profile_Type renames UDNS_Profile_Type (P.all); Prefix : constant String := UDNS_Corbaloc_Prefix; Oid_Str : String (1 .. P.Object_Id'Length); pragma Import (Ada, Oid_Str); for Oid_Str'Address use P.Object_Id'Address; begin pragma Debug (C, O ("UDNS_Profile_To_Corbaloc")); return Prefix & ":@" & Utils.Sockets.Image (Address_Of (UDNS_Transport_Mechanism (Element (UDNS_Profile.Mechanisms, 0).all.all))) & "/" & URI_Encode (Oid_Str, Also_Escape => No_Escape); end Profile_To_Corbaloc; ------------------------- -- Corbaloc_To_Profile -- ------------------------- function Corbaloc_To_Profile (Str : String) return Profile_Access is Profile : Profile_Access := new UDNS_Profile_Type; TResult : UDNS_Profile_Type renames UDNS_Profile_Type (Profile.all); Host_First, Host_Last : Natural; Port : Sockets.Port_Type; -- Returned in error case S : String renames Str; Index : Integer := S'First; Index2 : Integer; begin pragma Debug (C, O ("UDNS corbaloc to profile: enter")); Index := Find (S, S'First, '@') + 1; -- Index at start of host declare Colon : constant Integer := Find (S, Index, ':'); Slash : constant Integer := Find (S, Index, '/'); begin if Colon < Slash then -- Port number is present Index2 := Colon - 1; else Index2 := Slash - 1; end if; if Index2 < Index then -- Empty host Destroy_Profile (Profile); return null; end if; pragma Debug (C, O ("Address = " & S (Index .. Index2))); Host_First := Index; Host_Last := Index2; if Colon < Slash then if Colon + 1 < Slash then pragma Debug (C, O ("Port = " & S (Colon + 1 .. Slash - 1))); Port := PolyORB.Sockets.Port_Type'Value (S (Colon + 1 .. Slash - 1)); else -- Empty port Destroy_Profile (Profile); return null; end if; else Port := 5353; end if; Index := Slash + 1; end; if Index > S'Last then -- Empty key_string Destroy_Profile (Profile); return null; end if; declare Oid_Str : constant String := URI_Decode (S (Index .. S'Last)); Oid : Object_Id (Stream_Element_Offset (Oid_Str'First) .. Stream_Element_Offset (Oid_Str'Last)); pragma Import (Ada, Oid); for Oid'Address use Oid_Str (Oid_Str'First)'Address; begin TResult.Object_Id := new Object_Id'(Oid); end; if TResult.Object_Id = null then Destroy_Profile (Profile); return null; end if; pragma Debug (C, O ("Oid = " & Image (TResult.Object_Id.all))); declare Address : constant Utils.Sockets.Socket_Name := S (Host_First .. Host_Last) + Port; begin Append (UDNS_Profile_Type (Profile.all).Mechanisms, Create_Transport_Mechanism (Address)); return Profile; end; end Corbaloc_To_Profile; ----------- -- Image -- ----------- function Image (Prof : UDNS_Profile_Type) return String is begin return "Address : " & Utils.Sockets.Image (Address_Of (UDNS_Transport_Mechanism (Element (Prof.Mechanisms, 0).all.all))) & ", Object_Id : " & PolyORB.Objects.Image (Prof.Object_Id.all); end Image; ------------ -- Get_OA -- ------------ function Get_OA (Profile : UDNS_Profile_Type) return PolyORB.Smart_Pointers.Entity_Ptr is pragma Unreferenced (Profile); begin return PolyORB.Smart_Pointers.Entity_Ptr (PolyORB.ORB.Object_Adapter (PolyORB.Setup.The_ORB)); end Get_OA; ---------------- -- Initialize -- ---------------- procedure Initialize; procedure Initialize is Preference_Offset : constant String := PolyORB.Parameters.Get_Conf (Section => "udns", Key => "polyorb.binding_data.udns.preference", Default => "0"); begin Preference := Preference_Default - 1 + Profile_Preference'Value (Preference_Offset); Register (Tag_UDNS, UDNS_Corbaloc_Prefix, Profile_To_Corbaloc'Access, Corbaloc_To_Profile'Access); end Initialize; use PolyORB.Initialization; use PolyORB.Initialization.String_Lists; use PolyORB.Utils.Strings; begin Register_Module (Module_Info' (Name => +"binding_data.udns", Conflicts => Empty, Depends => +"protocols.dns.udns" & "sockets", Provides => +"binding_factories", Implicit => False, Init => Initialize'Access, Shutdown => null)); end PolyORB.Binding_Data.DNS.UDNS; polyorb-2.8~20110207.orig/src/dns/udns/polyorb-protocols-dns-udns.adb0000644000175000017500000000612311750740340024641 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . P R O T O C O L S . D N S. U D N S -- -- -- -- B o d y -- -- -- -- Copyright (C) 2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with PolyORB.Initialization; with PolyORB.Utils.Strings; package body PolyORB.Protocols.DNS.UDNS is ------------ -- Create -- ------------ procedure Create (Proto : access UDNS_Protocol; Session : out Filter_Access) is begin PolyORB.Protocols.DNS.Create (DNS_Protocol (Proto.all)'Access, Session); end Create; ---------------- -- Initialize -- ---------------- procedure Initialize; procedure Initialize is F : constant Requests.Flags := Sync_None or Sync_With_Transport; pragma Unreferenced (F); begin PolyORB.Protocols.DNS.Initialize; end Initialize; use PolyORB.Initialization; use PolyORB.Initialization.String_Lists; use PolyORB.Utils.Strings; begin Register_Module (Module_Info' (Name => +"protocols.dns.udns", Conflicts => Empty, Depends => +"setup.udns", Provides => Empty, Implicit => False, Init => Initialize'Access, Shutdown => null)); end PolyORB.Protocols.DNS.UDNS; polyorb-2.8~20110207.orig/src/dns/udns/polyorb-udns.ads0000644000175000017500000000423011750740340022053 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . U D N S -- -- -- -- S p e c -- -- -- -- Copyright (C) 2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by ACT Europe. -- -- (email: sales@act-europe.fr) -- -- -- ------------------------------------------------------------------------------ -- The root of all PolyORB packages that are specific to the -- UDNS personality. package PolyORB.UDNS is pragma Pure; end PolyORB.UDNS; polyorb-2.8~20110207.orig/src/dns/udns/polyorb-dns-transport_mechanisms-udns.adb0000644000175000017500000001603511750740340027063 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- POLYORB.DNS.TRANSPORT_MECHANISMS.UDNS -- -- -- -- B o d y -- -- -- -- Copyright (C) 2005-2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with PolyORB.Binding_Data.DNS.UDNS; with PolyORB.Binding_Objects; with PolyORB.ORB; with PolyORB.Protocols.DNS.UDNS; with PolyORB.Sockets; with PolyORB.Transport.Datagram.Sockets; with PolyORB.Filters; package body PolyORB.DNS.Transport_Mechanisms.UDNS is use PolyORB.Components; use PolyORB.Errors; use PolyORB.Sockets; use PolyORB.Transport.Datagram.Sockets; use PolyORB.Utils.Sockets; ---------------- -- Address_Of -- ---------------- function Address_Of (M : UDNS_Transport_Mechanism) return Utils.Sockets.Socket_Name is begin return M.Address.all; end Address_Of; -------------------- -- Bind_Mechanism -- -------------------- -- Factories Pro : aliased PolyORB.Protocols.DNS.UDNS.UDNS_Protocol; UDNS_Factories : constant PolyORB.Filters.Factory_Array := (0 => Pro'Access); procedure Bind_Mechanism (Mechanism : UDNS_Transport_Mechanism; Profile : access PolyORB.Binding_Data.Profile_Type'Class; The_ORB : Components.Component_Access; QoS : PolyORB.QoS.QoS_Parameters; BO_Ref : out Smart_Pointers.Ref; Error : out Errors.Error_Container) is pragma Unreferenced (QoS); use PolyORB.Binding_Data; use PolyORB.Binding_Objects; Sock : Socket_Type; TE : Transport.Transport_Endpoint_Access; begin if Profile.all not in PolyORB.Binding_Data.DNS.UDNS.UDNS_Profile_Type then Throw (Error, Comm_Failure_E, System_Exception_Members' (Minor => 0, Completed => Completed_Maybe)); return; end if; Create_Socket (Socket => Sock, Family => Family_Inet, Mode => Socket_Datagram); Set_Socket_Option (Sock, Socket_Level, (Reuse_Address, True)); TE := new Socket_Endpoint; Create (Socket_Endpoint (TE.all), Sock, To_Address (Mechanism.Address.all)); Binding_Objects.Setup_Binding_Object (The_ORB, TE, UDNS_Factories, BO_Ref, Profile_Access (Profile)); ORB.Register_Binding_Object (ORB.ORB_Access (The_ORB), BO_Ref, ORB.Client); exception when Sockets.Socket_Error => Throw (Error, Comm_Failure_E, System_Exception_Members' (Minor => 0, Completed => Completed_Maybe)); end Bind_Mechanism; -------------------- -- Create_Factory -- -------------------- procedure Create_Factory (MF : out UDNS_Transport_Mechanism_Factory; TAP : Transport.Transport_Access_Point_Access) is begin MF.Address := new Socket_Name'(Address_Of (Socket_Access_Point (TAP.all))); end Create_Factory; -------------------------------- -- Create_Transport_Mechanism -- -------------------------------- function Create_Transport_Mechanism (MF : UDNS_Transport_Mechanism_Factory) return Transport_Mechanism_Access is Result : constant Transport_Mechanism_Access := new UDNS_Transport_Mechanism; TResult : UDNS_Transport_Mechanism renames UDNS_Transport_Mechanism (Result.all); begin TResult.Address := new Socket_Name'(MF.Address.all); return Result; end Create_Transport_Mechanism; function Create_Transport_Mechanism (Address : Utils.Sockets.Socket_Name) return Transport_Mechanism_Access is Result : constant Transport_Mechanism_Access := new UDNS_Transport_Mechanism; TResult : UDNS_Transport_Mechanism renames UDNS_Transport_Mechanism (Result.all); begin TResult.Address := new Socket_Name'(Address); return Result; end Create_Transport_Mechanism; ------------------------ -- Is_Local_Mechanism -- ------------------------ function Is_Local_Mechanism (MF : access UDNS_Transport_Mechanism_Factory; M : access Transport_Mechanism'Class) return Boolean is begin return M.all in UDNS_Transport_Mechanism and then UDNS_Transport_Mechanism (M.all).Address.all = MF.Address.all; end Is_Local_Mechanism; ---------------------- -- Release_Contents -- ---------------------- procedure Release_Contents (M : access UDNS_Transport_Mechanism) is begin Free (M.Address); end Release_Contents; --------------- -- Duplicate -- --------------- function Duplicate (TMA : UDNS_Transport_Mechanism) return UDNS_Transport_Mechanism is begin return UDNS_Transport_Mechanism' (Address => new Socket_Name'(TMA.Address.all)); end Duplicate; ------------------ -- Is_Colocated -- ------------------ function Is_Colocated (Left : UDNS_Transport_Mechanism; Right : Transport_Mechanism'Class) return Boolean is begin return Right in UDNS_Transport_Mechanism and then Left.Address = UDNS_Transport_Mechanism (Right).Address; end Is_Colocated; end PolyORB.DNS.Transport_Mechanisms.UDNS; polyorb-2.8~20110207.orig/src/dns/udns/polyorb-dns-transport_mechanisms-udns.ads0000644000175000017500000001014411750740340027077 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- POLYORB.DNS.TRANSPORT_MECHANISMS.UDNS -- -- -- -- S p e c -- -- -- -- Copyright (C) 2005-2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with PolyORB.Utils.Sockets; package PolyORB.DNS.Transport_Mechanisms.UDNS is type UDNS_Transport_Mechanism is new Transport_Mechanism with private; procedure Bind_Mechanism (Mechanism : UDNS_Transport_Mechanism; Profile : access PolyORB.Binding_Data.Profile_Type'Class; The_ORB : Components.Component_Access; QoS : PolyORB.QoS.QoS_Parameters; BO_Ref : out Smart_Pointers.Ref; Error : out Errors.Error_Container); procedure Release_Contents (M : access UDNS_Transport_Mechanism); -- UDNS Transport Mechanism specific subprograms function Address_Of (M : UDNS_Transport_Mechanism) return Utils.Sockets.Socket_Name; -- Return address of transport mechanism's transport access point. type UDNS_Transport_Mechanism_Factory is new Transport_Mechanism_Factory with private; procedure Create_Factory (MF : out UDNS_Transport_Mechanism_Factory; TAP : Transport.Transport_Access_Point_Access); function Is_Local_Mechanism (MF : access UDNS_Transport_Mechanism_Factory; M : access Transport_Mechanism'Class) return Boolean; -- UDNS Transport Mechanism Factory specific subprograms function Create_Transport_Mechanism (MF : UDNS_Transport_Mechanism_Factory) return Transport_Mechanism_Access; -- Create transport mechanism function Create_Transport_Mechanism (Address : Utils.Sockets.Socket_Name) return Transport_Mechanism_Access; -- Create transport mechanism for specified transport access point address function Duplicate (TMA : UDNS_Transport_Mechanism) return UDNS_Transport_Mechanism; function Is_Colocated (Left : UDNS_Transport_Mechanism; Right : Transport_Mechanism'Class) return Boolean; private type UDNS_Transport_Mechanism is new Transport_Mechanism with record Address : Utils.Sockets.Socket_Name_Ptr; end record; type UDNS_Transport_Mechanism_Factory is new Transport_Mechanism_Factory with record Address : Utils.Sockets.Socket_Name_Ptr; end record; end PolyORB.DNS.Transport_Mechanisms.UDNS; polyorb-2.8~20110207.orig/src/polyorb-tasking-condition_variables.ads0000644000175000017500000001067311750740340025031 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . T A S K I N G . C O N D I T I O N _ V A R I A B L E S -- -- -- -- S p e c -- -- -- -- Copyright (C) 2002-2008, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- Implementation of POSIX-like condition variables -- A complete implementation of this package is provided for each -- tasking profile. with PolyORB.Tasking.Mutexes; package PolyORB.Tasking.Condition_Variables is pragma Preelaborate; use PolyORB.Tasking.Mutexes; ---------------- -- Conditions -- ---------------- type Condition_Type is abstract tagged limited private; type Condition_Access is access all Condition_Type'Class; -- Type for condition variables. procedure Wait (C : access Condition_Type; M : access Mutex_Type'Class) is abstract; -- Wait for a notification on condition variable C. -- This procedure atomically: -- (1) leaves the critical section protected by M (which the -- caller must own); -- (2) blocks until a subsequent notification from another -- task (via the Signal or Broadcast operations described below); -- On return, M is owned again. procedure Broadcast (C : access Condition_Type) is abstract; -- Unblock all tasks blocked on C. procedure Signal (C : access Condition_Type) is abstract; -- Unblock one task blocked on C. ----------------------- -- Condition_Factory -- ----------------------- type Condition_Factory_Type is abstract tagged limited null record; -- Factory of condition variables. -- A subclass of this factory exists for every tasking profile: -- Full Tasking, Ravenscar and No Tasking. type Condition_Factory_Access is access all Condition_Factory_Type'Class; function Create (MF : access Condition_Factory_Type; Name : String := "") return Condition_Access is abstract; -- Create a new condition variable, or get a preallocated one. -- Name will be used to get the configuration of this -- condition variable from the configuration module. procedure Destroy (MF : access Condition_Factory_Type; Cond : in out Condition_Access) is abstract; -- Destroy Cond, or just release it if it was preallocated. procedure Register_Condition_Factory (MF : Condition_Factory_Access); -- Register the factory corresponding to the chosen tasking profile. procedure Create (Cond : out Condition_Access; Name : String := ""); procedure Destroy (Cond : in out Condition_Access); private type Condition_Type is abstract tagged limited null record; end PolyORB.Tasking.Condition_Variables; polyorb-2.8~20110207.orig/src/polyorb-tasking-profiles-full_tasking-condition_variables.ads0000644000175000017500000000752611750740340031335 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- POLYORB.TASKING.PROFILES.FULL_TASKING.CONDITION_VARIABLES -- -- -- -- S p e c -- -- -- -- Copyright (C) 2002-2005 Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- Implementation of POSIX-like condition variables with full Ada -- tasking. More comments can be found at polyorb-tasking-condition_variables. with PolyORB.Tasking.Condition_Variables; with PolyORB.Tasking.Mutexes; package PolyORB.Tasking.Profiles.Full_Tasking.Condition_Variables is package PTM renames PolyORB.Tasking.Mutexes; package PTCV renames PolyORB.Tasking.Condition_Variables; type Full_Tasking_Condition_Type is new PTCV.Condition_Type with private; type Full_Tasking_Condition_Access is access all Full_Tasking_Condition_Type'Class; procedure Wait (Cond : access Full_Tasking_Condition_Type; M : access PTM.Mutex_Type'Class); procedure Signal (Cond : access Full_Tasking_Condition_Type); procedure Broadcast (Cond : access Full_Tasking_Condition_Type); type Full_Tasking_Condition_Factory_Type is new PTCV.Condition_Factory_Type with private; type Full_Tasking_Condition_Factory_Access is access all Full_Tasking_Condition_Factory_Type'Class; The_Condition_Factory : constant Full_Tasking_Condition_Factory_Access; function Create (MF : access Full_Tasking_Condition_Factory_Type; Name : String := "") return PTCV.Condition_Access; procedure Destroy (MF : access Full_Tasking_Condition_Factory_Type; Cond : in out PTCV.Condition_Access); private type Condition_PO; type Condition_PO_Access is access Condition_PO; type Full_Tasking_Condition_Type is new PTCV.Condition_Type with record The_PO : Condition_PO_Access; end record; type Full_Tasking_Condition_Factory_Type is new PTCV.Condition_Factory_Type with null record; The_Condition_Factory : constant Full_Tasking_Condition_Factory_Access := new Full_Tasking_Condition_Factory_Type; end PolyORB.Tasking.Profiles.Full_Tasking.Condition_Variables; polyorb-2.8~20110207.orig/src/polyorb-poa_config.adb0000644000175000017500000000522511750740340021435 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . P O A _ C O N F I G -- -- -- -- B o d y -- -- -- -- Copyright (C) 2001-2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by ACT Europe. -- -- (email: sales@act-europe.fr) -- -- -- ------------------------------------------------------------------------------ -- Global POA configuration package body PolyORB.POA_Config is The_Configuration : Configuration_Access; ----------------------- -- Set_Configuration -- ----------------------- procedure Set_Configuration (C : Configuration_Access) is begin pragma Assert (The_Configuration = null and then C /= null); The_Configuration := C; end Set_Configuration; ------------------- -- Configuration -- ------------------- function Configuration return Configuration_Access is begin pragma Assert (The_Configuration /= null); return The_Configuration; end Configuration; end PolyORB.POA_Config; polyorb-2.8~20110207.orig/src/polyorb-protocols.adb0000644000175000017500000002557111750740340021363 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . P R O T O C O L S -- -- -- -- B o d y -- -- -- -- Copyright (C) 2001-2011, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- Support for object method invocation protocols. with Ada.Tags; with PolyORB.Filters.Iface; with PolyORB.If_Descriptors; with PolyORB.Log; with PolyORB.Protocols.Iface; with PolyORB.Servants.Iface; package body PolyORB.Protocols is use PolyORB.Components; use PolyORB.Filters.Iface; use PolyORB.Log; use PolyORB.Protocols.Iface; use PolyORB.Servants.Iface; use Unsigned_Long_Flags; package L is new PolyORB.Log.Facility_Log ("polyorb.protocols"); procedure O (Message : String; Level : Log_Level := Debug) renames L.Output; function C (Level : Log_Level := Debug) return Boolean renames L.Enabled; --------------------------------- -- Handle_Unmarshall_Arguments -- --------------------------------- procedure Handle_Unmarshall_Arguments (S : access Session; Args : in out Any.NVList.Ref; Error : in out Errors.Error_Container) is begin raise Program_Error; -- By default: no support for deferred arguments unmarshalling. -- Concrete Session implementations may override this operation -- to provide this functionality. end Handle_Unmarshall_Arguments; -------------------- -- Handle_Message -- -------------------- function Handle_Message (Sess : not null access Session; S : Components.Message'Class) return Components.Message'Class is use PolyORB.Errors; Nothing : Components.Null_Message; Req : Request_Access; Error : Errors.Error_Container; begin pragma Debug (C, O ("Handling message of type " & Ada.Tags.External_Tag (S'Tag))); if S in Connect_Indication then Handle_Connect_Indication (Session_Access (Sess)); elsif S in Connect_Confirmation then Handle_Connect_Confirmation (Session_Access (Sess)); elsif S in Disconnect_Indication then Handle_Disconnect (Session_Access (Sess), Disconnect_Indication (S).Error); elsif S in Data_Indication then Handle_Data_Indication (Session_Access (Sess), Data_Indication (S).Data_Amount, Error); if Found (Error) then return Filter_Error'(Error => Error); end if; elsif S in Unmarshall_Arguments then declare Args : PolyORB.Any.NVList.Ref := Unmarshall_Arguments (S).Args; begin Handle_Unmarshall_Arguments (Session_Access (Sess), Args, Error); if Found (Error) then return Arguments_Error'(Error => Error); else return Unmarshalled_Arguments'(Args => Args); end if; end; elsif S in Flush then Handle_Flush (Session_Access (Sess)); elsif S in Set_Server then Sess.Server := Set_Server (S).Server; Sess.Dependent_Binding_Object := Set_Server (S).Binding_Object; elsif S in Execute_Request then Req := Execute_Request (S).Req; declare use type Binding_Data.Profile_Access; Req_Flags : constant Flags := Req.Req_Flags; -- Req may be destroyed as soon as we have called Invoke_Request -- below, so we need to take a copy of its flags in advance. begin pragma Assert (Execute_Request (S).Pro /= null); if Req.Deferred_Arguments_Session /= null then -- This session object participates in a proxy construct: now -- is the last place we can determine the signature of the -- called method in order to translate the request. As we do -- not have the actual servant on the local node, we need -- another way of retrieving an interface description (i.e. a -- parameter and result profile). This is typically achieved by -- looking up the target interface in an interface repository. -- In PolyORB, such operations are abstracted by the -- If_Descriptor interface. declare use PolyORB.If_Descriptors; Desc : If_Descriptor_Access renames Default_If_Descriptor; -- Delegate the decision and lookup process to the default -- interface descriptor objet. Args : constant Any.NVList.Ref := Get_Empty_Arg_List (Desc, Req.Target, Req.Operation.all); Reply : constant Components.Message'Class := Components.Emit (Req.Deferred_Arguments_Session, Unmarshall_Arguments'(Args => Args)); begin pragma Assert (Reply in Unmarshalled_Arguments or else Reply in Arguments_Error); if Reply in Unmarshalled_Arguments then pragma Debug (C, O ("Unmarshalled deferred arguments")); Req.Args := Unmarshalled_Arguments (Reply).Args; Req.Result.Argument := Get_Empty_Result (Desc, Req.Target, Req.Operation.all); Req.Deferred_Arguments_Session := null; pragma Debug (C, O ("Proxying request: " & Image (Req.all))); else pragma Debug (C, O ("Unmarshall deferred arguments error")); Set_Exception (Req.all, Arguments_Error (Reply).Error); -- Free data associated to Arguments_Error (Reply).Error declare Error : Error_Container := Arguments_Error (Reply).Error; begin Catch (Error); end; end if; end; end if; if Found (Error) then return Executed_Request'(Req => Req); end if; Invoke_Request (Session_Access (Sess), Req, Execute_Request (S).Pro); -- At this point, the request has been sent to the server: -- We cannot rely on Req still existing, since if it is a two-way -- request, it may have been completed and destroyed. If it is a -- one-way, however, we are responsible for signalling that it has -- been completed. if False or else Is_Set (Sync_With_Transport, Req_Flags) or else Is_Set (Sync_Call_Back, Req_Flags) then pragma Debug (C, O ("Completed Sync_With_Transport")); Req.Completed := True; return Executed_Request'(Req => Req); end if; end; elsif S in Servants.Iface.Abort_Request then Abort_Request (Session_Access (Sess), Servants.Iface.Abort_Request (S).Req); return Null_Message'(null record); elsif S in Executed_Request then declare Req : Request_Access := Executed_Request (S).Req; begin if Req.Deferred_Arguments_Session /= null then -- The request has been aborted before being fully processed. -- Flush the session's data and restore the session to its -- initial state, waiting for requests. Emit_No_Reply (Component_Access (Sess), Protocols.Iface.Flush'(Message with null record)); end if; if not Req.Aborted and then (Is_Set (Sync_With_Target, Req.Req_Flags) or else Is_Set (Sync_Call_Back, Req.Req_Flags)) then -- Send a reply if one is expected (per sync scope) and the -- request was completed (i.e. not aborted). Send_Reply (Session_Access (Sess), Req); end if; Destroy_Request (Req); end; elsif S in Acknowledge_Request then if Is_Set (Sync_With_Server, Acknowledge_Request (S).Req.Req_Flags) then Send_Reply (Session_Access (Sess), Acknowledge_Request (S).Req); end if; else return Filters.Handle_Message (Filters.Filter (Sess.all)'Access, S); end if; return Nothing; end Handle_Message; ------------------- -- Get_Task_Info -- ------------------- function Get_Task_Info (S : Session_Access) return PolyORB.Annotations.Notepad_Access is begin return S.N; end Get_Task_Info; ------------------- -- Set_Task_Info -- ------------------- procedure Set_Task_Info (S : Session_Access; N : PolyORB.Annotations.Notepad_Access) is begin S.N := N; end Set_Task_Info; end PolyORB.Protocols; polyorb-2.8~20110207.orig/src/polyorb-tasking-profiles-ravenscar-condition_variables.adb0000644000175000017500000003013111750740340030602 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- POLYORB.TASKING.PROFILES.RAVENSCAR.CONDITION_VARIABLES -- -- -- -- B o d y -- -- -- -- Copyright (C) 2002-2008, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- Implementation of synchronisation objects under the ravenscar profile with PolyORB.Log; with PolyORB.Utils.Strings; package body PolyORB.Tasking.Profiles.Ravenscar.Condition_Variables is use PolyORB.Log; package L is new PolyORB.Log.Facility_Log ("polyorb.tasking.profiles.ravenscar.condition_variables"); procedure O (Message : String; Level : Log_Level := Debug) renames L.Output; function C (Level : Log_Level := Debug) return Boolean renames L.Enabled; package PTM renames PolyORB.Tasking.Mutexes; package PTCV renames PolyORB.Tasking.Condition_Variables; type Queued_Thread is record -- Element of a queue of Thread; see comment for Thread_Queue Sync : Synchro_Index_Type; -- Synchro object the Thread is waiting on Next : Extended_Synchro_Index; -- Next Thread in the queue Is_Waiting : Boolean; -- True if the thread is waiting end record; type Thread_Queue is array (Synchro_Index_Type) of Queued_Thread; -- Implementation of a queue using an array. -- Each element of the array represent a waiting thread, and -- contain an access to the synchro object on which it is waiting, -- and the index of the Thread following it in the queue. -- This queue is used by a condition variable to record the tasks that -- wait for it. -- The place of a Thread in the array change at every suspending call; -- It is determinate by the index of its current synchro object. type Condition_Pool_Type is array (Condition_Index_Type) of aliased Ravenscar_Condition_Type; The_Condition_Pool : Condition_Pool_Type; -- The pool of preallocated condition variables protected type Condition_PO is -- Provide thread safe primitives for a Mutex, -- and manage its Thread_Queue. function Check_Queue_Consistency return Boolean; -- Function supposed to be used in an assert statement. -- It check some simple properties of the Thread_Queue : -- No loop, no error in the Is_Waiting flags, etc. procedure Prepare_Wait (S : Synchro_Index_Type); -- Inform the PO that the current task is about to Wait procedure Signal (Someone_Is_Waiting : out Boolean; To_Free : out Synchro_Index_Type); -- Protected part of the implementation of Signal procedure Broadcast (To_Free : out Thread_Queue); -- Protected part of the implementation Broadcast procedure Initialize (N : Condition_Index_Type); -- Initialize the condition variable private My_Index : Condition_Index_Type; First : Extended_Synchro_Index; Waiters : Thread_Queue; end Condition_PO; type Condition_PO_Arr is array (Condition_Index_Manager.Index_Type) of Condition_PO; The_Condition_PO_Arr : Condition_PO_Arr; -- Pool of Condition_POs --------------- -- Broadcast -- --------------- procedure Broadcast (Cond : access Ravenscar_Condition_Type) is To_Free : Thread_Queue; begin pragma Debug (C, O ("Broadcast")); The_Condition_PO_Arr (Cond.Id).Broadcast (To_Free); for J in To_Free'Range loop if To_Free (J).Is_Waiting then Resume (To_Free (J).Sync); end if; end loop; end Broadcast; ------------ -- Create -- ------------ function Create (MF : access Ravenscar_Condition_Factory_Type; Name : String := "") return PTCV.Condition_Access is pragma Warnings (Off); pragma Unreferenced (MF); pragma Unreferenced (Name); pragma Warnings (On); -- XXX The use of names is not implemented yet. Index : Condition_Index_Type; Cond : Ravenscar_Condition_Access; begin pragma Debug (C, O ("Create")); Condition_Index_Manager.Get (Index); Cond := The_Condition_Pool (Index)'Access; Cond.Id := Index; The_Condition_PO_Arr (Cond.Id).Initialize (Cond.Id); return Condition_Access (Cond); end Create; ------------- -- Destroy -- ------------- procedure Destroy (MF : access Ravenscar_Condition_Factory_Type; Cond : in out Condition_Access) is pragma Warnings (Off); pragma Unreferenced (MF); pragma Warnings (On); begin pragma Debug (C, O ("Destroy")); Condition_Index_Manager.Release (Ravenscar_Condition_Access (Cond).Id); end Destroy; ------------------ -- Condition_PO -- ------------------ protected body Condition_PO is -- XXX gestion of the queue not implemented yet. ------------------------------------------ -- Condition_PO.Check_Queue_Consistency -- ------------------------------------------ function Check_Queue_Consistency return Boolean is type Bool_Arr is array (Waiters'Range) of Boolean; Marked : Bool_Arr; Current : Extended_Synchro_Index := First; begin for J in Marked'Range loop Marked (J) := False; end loop; while Current /= Null_Synchro_Index loop if Marked (Synchro_Index_Type (Current)) then -- Loop in the queue return False; end if; if not Waiters (Synchro_Index_Type (Current)).Is_Waiting then -- Someone is in the queue, but does not wait return False; end if; Marked (Synchro_Index_Type (Current)) := True; Current := Waiters (Synchro_Index_Type (Current)).Next; end loop; return True; end Check_Queue_Consistency; ---------------------------- -- Condition_PO.Broadcast -- ---------------------------- procedure Broadcast (To_Free : out Thread_Queue) is begin pragma Assert (Check_Queue_Consistency); To_Free := Waiters; First := Null_Synchro_Index; for J in Waiters'Range loop Waiters (J).Is_Waiting := False; end loop; pragma Assert (Check_Queue_Consistency); end Broadcast; ----------------------------- -- Condition_PO.Initialize -- ----------------------------- procedure Initialize (N : Condition_Index_Type) is begin My_Index := N; First := Null_Synchro_Index; for J in Waiters'Range loop Waiters (J).Next := Null_Synchro_Index; Waiters (J).Is_Waiting := False; end loop; pragma Assert (Check_Queue_Consistency); end Initialize; ------------------------------- -- Condition_PO.Prepare_Wait -- ------------------------------- procedure Prepare_Wait (S : Synchro_Index_Type) is Current : Extended_Synchro_Index; Precedent : Extended_Synchro_Index; begin pragma Assert (Check_Queue_Consistency); Waiters (S).Is_Waiting := True; Waiters (S).Sync := S; if First /= Null_Synchro_Index then -- Search the rank of T in the queue Current := Waiters (Synchro_Index_Type (First)).Next; Precedent := First; while Current /= Null_Synchro_Index loop -- XXX compare the Priorities... Precedent := Current; Current := Waiters (Synchro_Index_Type (Current)).Next; end loop; Waiters (Synchro_Index_Type (Precedent)).Next := Extended_Synchro_Index (S); Waiters (S).Next := Current; else First := Extended_Synchro_Index (S); Waiters (S).Next := Null_Synchro_Index; end if; pragma Assert (Check_Queue_Consistency); end Prepare_Wait; ------------------------- -- Condition_PO.Signal -- ------------------------- procedure Signal (Someone_Is_Waiting : out Boolean; To_Free : out Synchro_Index_Type) is Former_First : constant Extended_Synchro_Index := First; begin pragma Assert (Check_Queue_Consistency); Someone_Is_Waiting := First /= Null_Synchro_Index; if Someone_Is_Waiting then First := Waiters (Synchro_Index_Type (Former_First)).Next; Waiters (Synchro_Index_Type (Former_First)).Next := Null_Synchro_Index; Waiters (Synchro_Index_Type (Former_First)).Is_Waiting := False; To_Free := Waiters (Synchro_Index_Type (Former_First)).Sync; end if; pragma Assert (Check_Queue_Consistency); end Signal; end Condition_PO; ---------------- -- Initialize -- ---------------- procedure Initialize is begin Condition_Index_Manager.Initialize; for J in The_Condition_PO_Arr'Range loop The_Condition_PO_Arr (J).Initialize (J); end loop; PTCV.Register_Condition_Factory (PTCV.Condition_Factory_Access (The_Condition_Factory)); end Initialize; ------------ -- Signal -- ------------ procedure Signal (Cond : access Ravenscar_Condition_Type) is Someone_Is_Waiting : Boolean; To_Free : Synchro_Index_Type; begin pragma Debug (C, O ("Signal")); The_Condition_PO_Arr (Cond.Id).Signal (Someone_Is_Waiting, To_Free); if Someone_Is_Waiting then Resume (To_Free); end if; end Signal; ---------- -- Wait -- ---------- procedure Wait (Cond : access Ravenscar_Condition_Type; M : access PTM.Mutex_Type'Class) is S : Synchro_Index_Type; begin pragma Debug (C, O ("Wait")); S := Prepare_Suspend; The_Condition_PO_Arr (Cond.Id).Prepare_Wait (S); PTM.Leave (M); Suspend (S); PTM.Enter (M); end Wait; use PolyORB.Initialization; use PolyORB.Initialization.String_Lists; use PolyORB.Utils.Strings; begin Register_Module (Module_Info' (Name => +"tasking.profiles.ravenscar.condition_variables", Conflicts => Empty, Depends => Empty, Provides => +"tasking.condition_variables", Implicit => False, Init => Initializer, Shutdown => null)); end PolyORB.Tasking.Profiles.Ravenscar.Condition_Variables; polyorb-2.8~20110207.orig/src/polyorb-poa_manager.ads0000644000175000017500000001051211750740340021616 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . P O A _ M A N A G E R -- -- -- -- S p e c -- -- -- -- Copyright (C) 2001-2009, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- Abstract interface for the POA manager. with PolyORB.Errors; with PolyORB.Servants; with PolyORB.POA_Types; with PolyORB.Smart_Pointers; package PolyORB.POA_Manager is use PolyORB.POA_Types; -- Unit has no proper body: no elab control necessary. type State is (HOLDING, ACTIVE, DISCARDING, INACTIVE); type Ref is new Smart_Pointers.Ref with private; type POAManager is abstract new Smart_Pointers.Non_Controlled_Entity with private; type POAManager_Access is access all POAManager'Class; -------------------------------------------------------------------- -- Procedures and functions to implement the POAManager interface -- -------------------------------------------------------------------- procedure Activate (Self : access POAManager; Error : in out PolyORB.Errors.Error_Container) is abstract; procedure Hold_Requests (Self : access POAManager; Wait_For_Completion : Boolean; Error : in out PolyORB.Errors.Error_Container) is abstract; procedure Discard_Requests (Self : access POAManager; Wait_For_Completion : Boolean; Error : in out PolyORB.Errors.Error_Container) is abstract; procedure Deactivate (Self : access POAManager; Etherealize_Objects : Boolean; Wait_For_Completion : Boolean) is abstract; function Get_State (Self : POAManager) return State is abstract; ------------------------------------------------------------- -- Procedures and functions specific to the implementation -- ------------------------------------------------------------- procedure Create (M : access POAManager) is abstract; procedure Register_POA (Self : access POAManager; OA : Obj_Adapter_Access) is abstract; procedure Remove_POA (Self : access POAManager; OA : Obj_Adapter_Access) is abstract; function Get_Hold_Servant (Self : access POAManager; OA : Obj_Adapter_Access) return PolyORB.Servants.Servant_Access is abstract; private type Ref is new Smart_Pointers.Ref with null record; type POAManager is abstract new Smart_Pointers.Non_Controlled_Entity with null record; end PolyORB.POA_Manager; polyorb-2.8~20110207.orig/src/polyorb-parameters-static.ads0000644000175000017500000000542211750740340023001 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . P A R A M E T E R S . S T A T I C -- -- -- -- S p e c -- -- -- -- Copyright (C) 2008, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ package PolyORB.Parameters.Static is pragma Elaborate_Body; type Parameter_Ptr is access constant Standard.String; type Value_Ptr is access constant Standard.String; type Parameter_Entry is record Parameter : Parameter_Ptr; Value : Value_Ptr; end record; -- Static array of parameters for link-time configuration of PolyORB. -- Requirements: -- - The last entry must be (null, null) -- - The application must export an array of the following type with -- the External_Name "__polyorbconf_optional". -- See PolyORB's User Manual section 4.2 [Run-time configuration] for -- further information. type Static_Parameter_Array is array (Positive range <>) of Parameter_Entry; end PolyORB.Parameters.Static; polyorb-2.8~20110207.orig/src/polyorb-poa_policies-request_processing_policy.ads0000644000175000017500000000772411750740340027327 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- POLYORB.POA_POLICIES.REQUEST_PROCESSING_POLICY -- -- -- -- S p e c -- -- -- -- Copyright (C) 2001-2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with PolyORB.Errors; with PolyORB.POA_Types; with PolyORB.Servants; package PolyORB.POA_Policies.Request_Processing_Policy is use PolyORB.POA_Types; type RequestProcessingPolicy is abstract new Policy with null record; type RequestProcessingPolicy_Access is access all RequestProcessingPolicy'Class; procedure Id_To_Servant (Self : RequestProcessingPolicy; OA : PolyORB.POA_Types.Obj_Adapter_Access; U_Oid : Unmarshalled_Oid; Servant : out Servants.Servant_Access; Error : in out PolyORB.Errors.Error_Container) is abstract; -- Case USE_OBJECT_MAP_ONLY: -- Asks the Servant Retention Policy to look for the given Oid. -- If NON_RETAIN, raises WrongPolicy. -- If found, returns the associated servant. -- Otherwise, raises ObjectNotActive -- Case USE_DEFAULT_SERVANT: -- If not found in the Active Object Map, returns the default servant. -- If there's no default servant registered, raises Obj_Adapter with -- minor code 3. -- Case USE_SERVANT_MANAGER: -- If not found in the Active Object Map, asks the servant manager -- to create it. If there's not servant manager, raises Obj_Adapter -- with minor code 4. procedure Set_Servant (Self : RequestProcessingPolicy; OA : PolyORB.POA_Types.Obj_Adapter_Access; Servant : Servants.Servant_Access; Error : in out PolyORB.Errors.Error_Container) is abstract; procedure Get_Servant (Self : RequestProcessingPolicy; OA : PolyORB.POA_Types.Obj_Adapter_Access; Servant : out Servants.Servant_Access; Error : in out PolyORB.Errors.Error_Container) is abstract; procedure Ensure_Servant_Manager (Self : RequestProcessingPolicy; Error : in out PolyORB.Errors.Error_Container) is abstract; end PolyORB.POA_Policies.Request_Processing_Policy; polyorb-2.8~20110207.orig/src/polyorb-lanes.ads0000644000175000017500000001747111750740340020462 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . L A N E S -- -- -- -- S p e c -- -- -- -- Copyright (C) 2004-2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with PolyORB.Jobs; with PolyORB.Tasking.Condition_Variables; with PolyORB.Tasking.Mutexes; with PolyORB.Tasking.Priorities; with PolyORB.Tasking.Threads; with PolyORB.Types; with PolyORB.Utils.Chained_Lists; -- XXX Should this be in the PolyORB.Tasking.* hierarchy ? package PolyORB.Lanes is use PolyORB.Jobs; use PolyORB.Tasking.Priorities; use PolyORB.Tasking.Threads; -- A lane is an advanced queue made of several job queues and a -- set of threads (Ti)i=1..n at priority P (Ti). The lane -- schedules all queued jobs and dispatch threads to process -- them, depending on lane's policy. --------------- -- Lane_Root -- --------------- -- Lane_Root is the root type for all lanes. type Lane_Root is abstract tagged limited private; type Lane_Root_Access is access all Lane_Root'Class; procedure Queue_Job (L : access Lane_Root; J : Job_Access; Hint_Priority : External_Priority := Invalid_Priority) is abstract; -- Queue job J in lane L, Hint_Priority defines a base priority to -- be used by the lane to queue J. function Is_Valid_Priority (L : access Lane_Root; Priority : External_Priority) return Boolean is abstract; -- Return True if a request at priority Priority can be handled by -- lane L. procedure Destroy (L : access Lane_Root) is abstract; ---------- -- Lane -- ---------- -- A Lane is an advanced queue made of one job queue and several -- attached threads, all threads are at the same priority tuple -- (ORB_Component_Priority, External_Priority). type Lane (ORB_Priority : ORB_Component_Priority; Ext_Priority : External_Priority; Base_Number_Of_Threads : Natural; Dynamic_Number_Of_Threads : Natural; Stack_Size : Natural; Buffer_Request : Boolean; Max_Buffered_Requests : PolyORB.Types.Unsigned_Long; Max_Buffer_Size : PolyORB.Types.Unsigned_Long) is new Lane_Root with private; -- XXX missing: request buffering using Max_Buffer_Size type Lane_Access is access all Lane'Class; function Create (ORB_Priority : ORB_Component_Priority; Ext_Priority : External_Priority; Base_Number_Of_Threads : Natural; Dynamic_Number_Of_Threads : Natural; Stack_Size : Natural; Buffer_Request : Boolean; Max_Buffered_Requests : PolyORB.Types.Unsigned_Long; Max_Buffer_Size : PolyORB.Types.Unsigned_Long) return Lane_Access; procedure Queue_Job (L : access Lane; J : Job_Access; Hint_Priority : External_Priority := Invalid_Priority); function Is_Valid_Priority (L : access Lane; Priority : External_Priority) return Boolean; procedure Destroy (L : access Lane); --------------------- -- Extensible_Lane -- --------------------- -- An Extensible_Lane is a lane to which no thread are attached at -- startup. Thread may be attached to this lane, they will be used -- to process queued jobs. type Extensible_Lane is new Lane with private; procedure Attach_Thread (EL : in out Extensible_Lane; T : Thread_Access); -------------- -- Lane_Set -- -------------- -- A Lane_Set is a set of Lanes. type Lanes_Set (Length : Positive) is new Lane_Root with private; procedure Add_Lane (Set : in out Lanes_Set; L : Lane_Access; Index : Positive); -- Add lane L at position Index in Set procedure Queue_Job (L : access Lanes_Set; J : Job_Access; Hint_Priority : External_Priority := Invalid_Priority); function Is_Valid_Priority (L : access Lanes_Set; Priority : External_Priority) return Boolean; procedure Destroy (L : access Lanes_Set); private type Lane_Runnable is new PolyORB.Tasking.Threads.Runnable with record L : Lane_Access; Dynamically_Allocated : Boolean; end record; type Lane_Runnable_Access is access all Lane_Runnable; procedure Run (R : not null access Lane_Runnable); ------------------------------ -- Management of idle tasks -- ------------------------------ package PTM renames PolyORB.Tasking.Mutexes; package PTCV renames PolyORB.Tasking.Condition_Variables; -- Lane_Root type Lane_Root is abstract tagged limited null record; -- Lane type Thread_Array is array (Positive range <>) of Thread_Access; type Lane (ORB_Priority : ORB_Component_Priority; Ext_Priority : External_Priority; Base_Number_Of_Threads : Natural; Dynamic_Number_Of_Threads : Natural; Stack_Size : Natural; Buffer_Request : Boolean; Max_Buffered_Requests : PolyORB.Types.Unsigned_Long; Max_Buffer_Size : PolyORB.Types.Unsigned_Long) is new Lane_Root with record Lock : PTM.Mutex_Access; Job_Queue : Job_Queue_Access; Dynamic_Threads_Created : Natural := 0; CV : PTCV.Condition_Access; Idle_Tasks : Natural := 0; Clean_Up_In_Progress : Boolean := False; end record; -- Extensible_Lane package Thread_Lists is new PolyORB.Utils.Chained_Lists (Thread_Access); type Extensible_Lane is new Lane with record Additional_Threads : Thread_Lists.List; end record; -- Lane_Set type Lane_Array is array (Positive range <>) of Lane_Access; type Lanes_Set (Length : Positive) is new Lane_Root with record Set : Lane_Array (1 .. Length); end record; end PolyORB.Lanes; polyorb-2.8~20110207.orig/src/polyorb-references-file.ads0000644000175000017500000000424411750740340022410 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . R E F E R E N C E S . F I L E -- -- -- -- S p e c -- -- -- -- Copyright (C) 2005 Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- Helper routines to fetch stringified references from a file package PolyORB.References.File is pragma Elaborate_Body; end PolyORB.References.File; polyorb-2.8~20110207.orig/src/polyorb-orb_controller-workers.adb0000644000175000017500000003223111750740340024045 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . O R B _ C O N T R O L L E R . W O R K E R S -- -- -- -- B o d y -- -- -- -- Copyright (C) 2004-2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with Ada.Tags; with PolyORB.Asynch_Ev; with PolyORB.Initialization; with PolyORB.Utils.Strings; package body PolyORB.ORB_Controller.Workers is use PolyORB.Asynch_Ev; use PolyORB.Task_Info; use PolyORB.Tasking.Condition_Variables; --------------------- -- Disable_Polling -- --------------------- procedure Disable_Polling (O : access ORB_Controller_Workers; M : PAE.Asynch_Ev_Monitor_Access) is AEM_Index : constant Natural := Index (O.all, M); begin -- Force all tasks currently waiting on this monitor to abort if O.AEM_Infos (AEM_Index).TI /= null then pragma Debug (C1, O1 ("Disable_Polling: Aborting polling task")); PTI.Request_Abort_Polling (O.AEM_Infos (AEM_Index).TI.all); PolyORB.Asynch_Ev.Abort_Check_Sources (Selector (O.AEM_Infos (AEM_Index).TI.all).all); pragma Debug (C1, O1 ("Disable_Polling: waiting abort is complete")); O.AEM_Infos (AEM_Index).Polling_Abort_Counter := O.AEM_Infos (AEM_Index).Polling_Abort_Counter + 1; Wait (O.AEM_Infos (AEM_Index).Polling_Completed, O.ORB_Lock); O.AEM_Infos (AEM_Index).Polling_Abort_Counter := O.AEM_Infos (AEM_Index).Polling_Abort_Counter - 1; pragma Debug (C1, O1 ("Disable_Polling: aborting done")); end if; end Disable_Polling; -------------------- -- Enable_Polling -- -------------------- procedure Enable_Polling (O : access ORB_Controller_Workers; M : PAE.Asynch_Ev_Monitor_Access) is AEM_Index : constant Natural := Index (O.all, M); begin pragma Debug (C1, O1 ("Enable_Polling")); if O.AEM_Infos (AEM_Index).Polling_Abort_Counter = 0 then -- Allocate one task to poll on AES Try_Allocate_One_Task (O, Allow_Transient => True); end if; end Enable_Polling; ------------------ -- Notify_Event -- ------------------ procedure Notify_Event (O : access ORB_Controller_Workers; E : Event) is use type PRS.Request_Scheduler_Access; begin pragma Debug (C1, O1 ("Notify_Event: " & Event_Kind'Image (E.Kind))); case E.Kind is when End_Of_Check_Sources => declare AEM_Index : constant Natural := Index (O.all, E.On_Monitor); begin -- A task completed polling on a monitor pragma Debug (C1, O1 ("End of check sources on monitor #" & Natural'Image (AEM_Index) & Ada.Tags.External_Tag (O.AEM_Infos (AEM_Index).Monitor.all'Tag))); -- Reset TI O.AEM_Infos (AEM_Index).TI := null; if O.AEM_Infos (AEM_Index).Polling_Abort_Counter > 0 then -- This task has been aborted by one or more tasks, -- we broadcast them. Broadcast (O.AEM_Infos (AEM_Index).Polling_Completed); end if; end; when Event_Sources_Added => declare AEM_Index : Natural := Index (O.all, E.Add_In_Monitor); begin if AEM_Index = 0 then -- This monitor was not yet registered, register it pragma Debug (C1, O1 ("Adding new monitor")); for J in O.AEM_Infos'Range loop if O.AEM_Infos (J).Monitor = null then O.AEM_Infos (J).Monitor := E.Add_In_Monitor; AEM_Index := J; exit; end if; end loop; end if; pragma Debug (C1, O1 ("Added monitor at index:" & AEM_Index'Img & " " & Ada.Tags.External_Tag (O.AEM_Infos (AEM_Index).Monitor.all'Tag))); if O.AEM_Infos (AEM_Index).TI /= null and then not O.AEM_Infos (AEM_Index).Polling_Scheduled then -- No task is currently polling, allocate one O.AEM_Infos (AEM_Index).Polling_Scheduled := True; Try_Allocate_One_Task (O, Allow_Transient => True); end if; end; when Event_Sources_Deleted => -- An AES has been removed from monitored AES list null; when Job_Completed => -- A task has completed the execution of a job null; when ORB_Shutdown => -- ORB shutdown has been requested O.Shutdown := True; -- Awake all idle tasks Awake_All_Idle_Tasks (O.Idle_Tasks); -- Unblock blocked tasks for J in O.AEM_Infos'Range loop if O.AEM_Infos (J).TI /= null then PTI.Request_Abort_Polling (O.AEM_Infos (J).TI.all); PolyORB.Asynch_Ev.Abort_Check_Sources (Selector (O.AEM_Infos (J).TI.all).all); end if; end loop; when Queue_Event_Job => -- Queue event to main job queue pragma Debug (C1, O1 ("Queue Event_Job to default queue")); PJ.Queue_Job (O.Job_Queue, E.Event_Job); Try_Allocate_One_Task (O, Allow_Transient => True); when Queue_Request_Job => declare Job_Queued : Boolean := False; begin if O.RS /= null then Leave_ORB_Critical_Section (O); Job_Queued := PRS.Try_Queue_Request_Job (O.RS, E.Request_Job, E.Target); Enter_ORB_Critical_Section (O); end if; if not Job_Queued then -- Default: Queue request to main job queue pragma Debug (C1, O1 ("Queue Request_Job to default queue")); PJ.Queue_Job (O.Job_Queue, E.Request_Job); Try_Allocate_One_Task (O, Allow_Transient => not Is_Upcall (E.Request_Job.all)); -- We don't want the ORB to borrow a transient task to -- make an upcall to application code, because this could -- take a long time or even deadlock. -- Note that if there is a blocked permanent task and no -- idle or running permanent tasks, then we might need -- to abort the block??? end if; end; when Request_Result_Ready => -- A Request has been completed and a response is available. We -- must forward it to requesting task. We ensure this task will -- stop its current action and ask for rescheduling. Reschedule_Task (O, E.Requesting_Task); when Idle_Awake => -- A task has left Idle state Remove_Idle_Task (O.Idle_Tasks, E.Awakened_Task); when Task_Registered => null; when Task_Unregistered => if Need_Polling_Task (O) > 0 then Try_Allocate_One_Task (O, Allow_Transient => True); -- ??? Is this necessary? Won't this awake a task only to get -- it back to idle immediately? end if; Note_Task_Unregistered (O); end case; pragma Debug (C2, O2 (Status (O.all))); end Notify_Event; ------------------- -- Schedule_Task -- ------------------- procedure Schedule_Task (O : access ORB_Controller_Workers; TI : PTI.Task_Info_Access) is function Is_Schedulable (J : PJ.Job'Class) return Boolean; -- True if J is schedulable for this task (i.e. not an upcall job -- if the task is transient). -------------------- -- Is_Schedulable -- -------------------- function Is_Schedulable (J : PJ.Job'Class) return Boolean is begin return TI.Kind = Permanent or else not Is_Upcall (J); end Is_Schedulable; -- Start of processing for Schedule_Task begin pragma Debug (C1, O1 ("Schedule_Task: enter " & Image (TI.all))); if State (TI.all) = Terminated then pragma Debug (C1, O1 ("Schedule_Task: task is terminated")); return; end if; Set_State_Unscheduled (O.Summary, TI.all); -- Recompute TI status if Exit_Condition (TI.all) or else (O.Shutdown and then not Has_Pending_Job (O) and then TI.Kind = Permanent) then Set_State_Terminated (O.Summary, TI.all); pragma Debug (C1, O1 ("Task is now terminated")); pragma Debug (C2, O2 (Status (O.all))); return; end if; declare use type PJ.Job_Access; Job : constant PJ.Job_Access := PJ.Fetch_Job (O.Job_Queue, Is_Schedulable'Access); begin if Job /= null then Set_State_Running (O.Summary, TI.all, Job); pragma Debug (C1, O1 ("Task is now running a job")); pragma Debug (C2, O2 (Status (O.all))); return; end if; end; declare AEM_Index : constant Natural := Need_Polling_Task (O); begin if AEM_Index > 0 then O.AEM_Infos (AEM_Index).Polling_Scheduled := False; O.AEM_Infos (AEM_Index).TI := TI; Set_State_Blocked (O.Summary, TI.all, O.AEM_Infos (AEM_Index).Monitor, O.AEM_Infos (AEM_Index).Polling_Timeout); pragma Debug (C1, O1 ("Task is now blocked on monitor" & Natural'Image (AEM_Index) & " " & Ada.Tags.External_Tag (O.AEM_Infos (AEM_Index).Monitor.all'Tag))); pragma Debug (C2, O2 (Status (O.all))); return; end if; end; Set_State_Idle (O.Summary, TI.all, Insert_Idle_Task (O.Idle_Tasks, TI), O.ORB_Lock); pragma Debug (C1, O1 ("Task is now idle")); pragma Debug (C2, O2 (Status (O.all))); end Schedule_Task; ------------ -- Create -- ------------ function Create (OCF : ORB_Controller_Workers_Factory) return ORB_Controller_Access is pragma Unreferenced (OCF); OC : ORB_Controller_Workers_Access; RS : PRS.Request_Scheduler_Access; begin PRS.Create (RS); OC := new ORB_Controller_Workers (RS); Initialize (ORB_Controller (OC.all)); return ORB_Controller_Access (OC); end Create; ---------------- -- Initialize -- ---------------- procedure Initialize; procedure Initialize is begin Register_ORB_Controller_Factory (OCF); end Initialize; use PolyORB.Initialization; use PolyORB.Initialization.String_Lists; use PolyORB.Utils.Strings; begin Register_Module (Module_Info' (Name => +"orb_controller.workers", Conflicts => Empty, Depends => +"tasking.condition_variables" & "tasking.mutexes" & "request_scheduler?", Provides => +"orb_controller!", Implicit => False, Init => Initialize'Access, Shutdown => null)); end PolyORB.ORB_Controller.Workers; polyorb-2.8~20110207.orig/src/polyorb-setup.ads0000644000175000017500000000461211750740340020511 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . S E T U P -- -- -- -- S p e c -- -- -- -- Copyright (C) 2001-2008 Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by ACT Europe. -- -- (email: sales@act-europe.fr) -- -- -- ------------------------------------------------------------------------------ -- Initialization of a complete PolyORB partition. with PolyORB.ORB; with PolyORB.Representations; package PolyORB.Setup is -- No elaboration control (no proper body). The_Tasking_Policy : PolyORB.ORB.Tasking_Policy_Access; The_ORB : PolyORB.ORB.ORB_Access; Default_Representation : PolyORB.Representations.Representation_Access; end PolyORB.Setup; polyorb-2.8~20110207.orig/src/polyorb-object_maps-system.adb0000644000175000017500000001632011750740340023137 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . O B J E C T _ M A P S . S Y S T E M -- -- -- -- B o d y -- -- -- -- Copyright (C) 2003-2008, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with PolyORB.Log; with PolyORB.Types; package body PolyORB.Object_Maps.System is use Map_Entry_Tables; use PolyORB.Log; use PolyORB.POA_Types; use PolyORB.Types; package L is new Log.Facility_Log ("polyorb.object_maps.system"); procedure O (Message : Standard.String; Level : Log_Level := Debug) renames L.Output; function C (Level : Log_Level := Debug) return Boolean renames L.Enabled; ---------------- -- Initialize -- ---------------- procedure Initialize (O_Map : in out System_Object_Map) is begin Initialize (O_Map.System_Map); end Initialize; -------------- -- Finalize -- -------------- procedure Finalize (O_Map : in out System_Object_Map) is begin Deallocate (O_Map.System_Map); end Finalize; --------- -- Add -- --------- function Add (O_Map : access System_Object_Map; Obj : Object_Map_Entry_Access) return Integer is begin pragma Debug (C, O ("Add: enter")); if Obj.Oid /= null then raise Program_Error; end if; -- First try to reuse one slice in object map for J in First (O_Map.System_Map) .. Last (O_Map.System_Map) loop if Is_Null (O_Map.System_Map.Table (J)) then pragma Debug (C, O ("Replacing element" & Integer'Image (J))); O_Map.System_Map.Table (1 + J - First (O_Map.System_Map)) := Obj; pragma Debug (C, O ("Add: leave")); return J; end if; end loop; -- else, allocate one new element in table pragma Debug (C, O ("Appending element")); Increment_Last (O_Map.System_Map); O_Map.System_Map.Table (Last (O_Map.System_Map)) := Obj; pragma Debug (C, O ("Add: leave")); return Last (O_Map.System_Map); end Add; procedure Add (O_Map : access System_Object_Map; Obj : Object_Map_Entry_Access; Index : Integer) is use type PolyORB.Servants.Servant_Access; begin pragma Debug (C, O ("Add: enter")); if False or else not Obj.Oid.System_Generated or else (not Is_Null (O_Map.System_Map.Table (Index)) and then O_Map.System_Map.Table (Index).Servant /= null) then -- We cannot add Obj at Index if it is not system generated, -- or if a servant is already set for a non null entry at Index. raise Program_Error; end if; if not Is_Null (O_Map.System_Map.Table (Index)) then -- An incomplete object map entry has been previously -- created to reserve Index in this active object map. -- We now free it. Free (O_Map.System_Map.Table (Index)); end if; -- Add new object map entry. O_Map.System_Map.Table (1 + Index - First (O_Map.System_Map)) := Obj; pragma Debug (C, O ("Add: leave")); end Add; --------------- -- Get_By_Id -- --------------- function Get_By_Id (O_Map : System_Object_Map; Item : PolyORB.POA_Types.Unmarshalled_Oid) return Object_Map_Entry_Access is begin pragma Debug (C, O ("Get_By_Id: enter")); pragma Debug (C, O ("Looking for: " & To_Standard_String (Item.Id))); if not Item.System_Generated then raise Program_Error; end if; pragma Debug (C, O ("System generated OID, directly return element")); return O_Map.System_Map.Table (Integer'Value (To_Standard_String (Item.Id))); end Get_By_Id; -------------------- -- Get_By_Servant -- -------------------- function Get_By_Servant (O_Map : System_Object_Map; Item : PolyORB.Servants.Servant_Access) return Object_Map_Entry_Access is use type PolyORB.Servants.Servant_Access; begin pragma Debug (C, O ("Get_By_Servant: enter")); for J in First (O_Map.System_Map) .. Last (O_Map.System_Map) loop if not Is_Null (O_Map.System_Map.Table (J)) then pragma Debug (C, O ("Examinating elt: " & To_Standard_String (O_Map.System_Map.Table (J).Oid.Id))); if O_Map.System_Map.Table (J).Servant = Item then pragma Debug (C, O ("Found !")); return O_Map.System_Map.Table (J); end if; end if; end loop; pragma Debug (C, O ("Not Found !")); return null; end Get_By_Servant; ------------------ -- Remove_By_Id -- ------------------ function Remove_By_Id (O_Map : access System_Object_Map; Item : PolyORB.POA_Types.Unmarshalled_Oid) return Object_Map_Entry_Access is Old_Entry : Object_Map_Entry_Access; begin pragma Debug (C, O ("Remove_By_Id: enter")); pragma Debug (C, O ("Looking for: " & To_Standard_String (Item.Id))); if not Item.System_Generated then raise Program_Error; end if; pragma Debug (C, O ("System generated OID, directly remove element")); declare Index : constant Integer := Integer'Value (To_Standard_String (Item.Id)); begin Old_Entry := O_Map.System_Map.Table (Index); O_Map.System_Map.Table (Index) := null; return Old_Entry; end; end Remove_By_Id; end PolyORB.Object_Maps.System; polyorb-2.8~20110207.orig/src/polyorb-transport-handlers.adb0000644000175000017500000001044111750740340023157 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . T R A N S P O R T . H A N D L E R S -- -- -- -- B o d y -- -- -- -- Copyright (C) 2003-2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- Event handlers associated with all transport access points and endpoints with PolyORB.Asynch_Ev; with PolyORB.Components; with PolyORB.Filters.Iface; package body PolyORB.Transport.Handlers is ------------------ -- Handle_Event -- ------------------ procedure Handle_Event (H : access TE_AES_Event_Handler) is use PolyORB.Components; use PolyORB.ORB; Reply : constant Message'Class := Emit (Component_Access (H.TE), Filters.Iface.Data_Indication'(Data_Amount => 0)); -- The size of the data received is not known yet begin if Reply in Filters.Iface.Filter_Error then -- Notify the tasking policy that an endpoint is being destroyed. Handle_Close_Connection (H.ORB.Tasking_Policy, H.TE); declare use PolyORB.Smart_Pointers; Dependent_Binding_Object : Ref; begin -- Ensure that the binding object remains referenced while we -- are dismantling it. Reuse_Entity (Dependent_Binding_Object, H.TE.Binding_Object); pragma Assert (not Is_Nil (Dependent_Binding_Object)); -- Close the endpoint. Note: for the case of a client side -- endpoint, this may clear the last reference to the BO, except -- for the above Dependent_Binding_Object). Emit_No_Reply (Component_Access (H.TE), Filters.Iface.Disconnect_Indication'( Error => Filters.Iface.Filter_Error (Reply).Error)); -- For the case of a server-side transport endpoint, the binding -- object is still be referenced by the TE for keep-alive purposes -- so we need to detach it now. if not Is_Nil (H.TE.Dependent_Binding_Object) then pragma Assert (Entity_Of (H.TE.Dependent_Binding_Object) = H.TE.Binding_Object); Smart_Pointers.Set (H.TE.Dependent_Binding_Object, null); end if; -- The complete binding object will be finalised when this block -- is exited, provided it is not referenced anymore. end; else null; end if; end Handle_Event; end PolyORB.Transport.Handlers; polyorb-2.8~20110207.orig/src/ravenscar.adc.in0000644000175000017500000000104211750740340020230 0ustar xavierxavier-- GNAT configuration pragmas for units to be compiled under -- pragma Ravenscar. -- @configure_input@ -- INCLUDE: polyorb-setup-ravenscar_tp_server.adb -- INCLUDE: polyorb-setup-tasking-ravenscar.ads -- INCLUDE: polyorb-tasking-profiles-ravenscar.ads -- INCLUDE: polyorb-tasking-profiles-ravenscar-condition_variables.adb -- INCLUDE: polyorb-tasking-profiles-ravenscar-index_manager.adb -- INCLUDE: polyorb-tasking-profiles-ravenscar-mutexes.adb -- INCLUDE: polyorb-tasking-profiles-ravenscar-threads.adb @PRAGMA_PROFILE_RAVENSCAR@ polyorb-2.8~20110207.orig/src/polyorb-tasking-priorities.ads0000644000175000017500000001132511750740340023177 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . T A S K I N G . P R I O R I T I E S -- -- -- -- S p e c -- -- -- -- Copyright (C) 2003-2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- This package defines priority ranges available within PolyORB with System; with PolyORB.Types; package PolyORB.Tasking.Priorities is ------------------ -- ORB Priority -- ------------------ -- ORB priorities are derived from Ada native priorities. We -- define ORB_Core and ORB_Component priority levels, so we make a -- distinction between ORB Core entities that require high -- priority to process some information and other components. subtype ORB_Priority is System.Priority range System.Priority'First .. System.Priority'Last; -- ORB priority range ORB_Core_Levels : constant Natural := 1; -- Number of priority levels affected to the ORB Core subtype ORB_Component_Priority is ORB_Priority range ORB_Priority'First .. ORB_Priority'Last - ORB_Core_Levels; -- ORB_Component_Priority defines the priority an ORB component -- may have. This range usually applies to most components, -- including user components. Default_Component_Priority : constant ORB_Component_Priority; -- Default priority for ORB Components subtype ORB_Core_Priority is System.Priority range ORB_Priority'Last - ORB_Core_Levels + 1 .. ORB_Priority'Last; -- ORB_Core_Priority defines the priority of some ORB key -- components. It is reserved to high priority loops, such as -- PolyORB.ORB main loop. Default_Core_Priority : constant ORB_Core_Priority; -- Default priority for ORB Core ----------------------- -- External Priority -- ----------------------- -- External priorities are derived from integer. They represent -- priority levels as defined by PolyORB's personalities. type External_Priority is new Integer; Invalid_Priority : constant External_Priority; ---------------------- -- Priority mapping -- ---------------------- -- These funcitons define mapping between ORB_Priority and -- External_Priority. When False, Returns indicate the mapping was -- not possible. type To_External_Priority_T is access procedure (Value : ORB_Priority; Result : out External_Priority; Returns : out PolyORB.Types.Boolean); type To_ORB_Priority_T is access procedure (Value : External_Priority; Result : out ORB_Priority; Returns : out PolyORB.Types.Boolean); To_External_Priority : To_External_Priority_T; To_ORB_Priority : To_ORB_Priority_T; private Default_Component_Priority : constant ORB_Component_Priority := ORB_Component_Priority (System.Default_Priority); Default_Core_Priority : constant ORB_Core_Priority := ORB_Core_Priority'First; Invalid_Priority : constant External_Priority := External_Priority'Last; end PolyORB.Tasking.Priorities; polyorb-2.8~20110207.orig/src/polyorb-utils-hfunctions-hyper.adb0000644000175000017500000000743711750740340024003 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . U T I L S . H F U N C T I O N S . H Y P E R -- -- -- -- B o d y -- -- -- -- Copyright (C) 2003-2008, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with PolyORB.Utils.Random; package body PolyORB.Utils.HFunctions.Hyper is use PolyORB.Types; use PolyORB.Utils.Random; Default_Prime : constant := 17_771; ---------------- -- Hash_Hyper -- ---------------- function Hash_Hyper (S : String; Seed : PolyORB.Types.Unsigned_Long; Prime : Natural; Size : Natural) return Natural is Result : Long_Long_Integer := 0; G : aliased Generator; begin Reset (G'Access, Seed_Type (Seed)); -- Loop for J in S'Range loop Result := (Result + Long_Long_Integer (Random.Random (G'Access)) * Long_Long_Integer (Character'Pos (S (J)))) mod Long_Long_Integer (Prime); end loop; -- Final return Natural (Result mod Long_Long_Integer (Size)); end Hash_Hyper; ---------- -- Hash -- ---------- function Hash (S : String; Param : Hash_Hyper_Parameters; Size : Natural) return Natural is begin return Hash_Hyper (S, Param.Seed, Param.Prime, Size); end Hash; ----------------------------- -- Default_Hash_Parameters -- ----------------------------- function Default_Hash_Parameters return Hash_Hyper_Parameters is begin return Hash_Hyper_Parameters'(Seed => 42, Prime => Default_Prime); end Default_Hash_Parameters; -------------------------- -- Next_Hash_Parameters -- -------------------------- function Next_Hash_Parameters (Param : Hash_Hyper_Parameters) return Hash_Hyper_Parameters is begin return Hash_Hyper_Parameters' (Seed => Unsigned_Long (Hash (Param.Seed'Img, Param, Natural'Last)), Prime => Param.Prime); end Next_Hash_Parameters; end PolyORB.Utils.HFunctions.Hyper; polyorb-2.8~20110207.orig/src/polyorb-transport.ads0000644000175000017500000002002211750740340021376 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . T R A N S P O R T -- -- -- -- S p e c -- -- -- -- Copyright (C) 2001-2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- Abstract transport service access points and transport endpoints. with Ada.Streams; with PolyORB.Annotations; with PolyORB.Asynch_Ev; with PolyORB.Buffers; with PolyORB.Components; with PolyORB.Errors; with PolyORB.Smart_Pointers; package PolyORB.Transport is -- Package body needs PolyORB.ORB.Interface, which has an -- indirect dependency on Transport: no pramga Elaborate_Body. ------------------------------------------------------------- -- A transport service access point: -- -- An object that has an address within a communication -- -- domain, to which connections can be established by -- -- remote entities that wish to communicate with this ORB. -- ------------------------------------------------------------- type Transport_Access_Point is abstract new Components.Component with private; type Transport_Access_Point_Access is access all Transport_Access_Point'Class; -- A listening transport service access point function Notepad_Of (TAP : Transport_Access_Point_Access) return Annotations.Notepad_Access; pragma Inline (Notepad_Of); -- A TAP is an annotable object (cf. PolyORB.Annotations), -- so clients can associate it with any information they see fit. -- This functions returns an access to TAP's Notepad component. function Create_Event_Source (TAP : access Transport_Access_Point) return Asynch_Ev.Asynch_Ev_Source_Access is abstract; -- Create a view of TAP as an asynchronous event source. The Handler -- of the newly-created event source is TAP.Handler. function Handle_Message (TAP : not null access Transport_Access_Point; Msg : Components.Message'Class) return Components.Message'Class; ----------------------------------------------------------------- -- A transport service endpoint: -- -- An object that represents a connection that was established -- -- when a transport access point was contacted. -- ----------------------------------------------------------------- type Transport_Endpoint is abstract new Components.Component with private; procedure Connect_Upper (TE : access Transport_Endpoint; Upper : Components.Component_Access); -- Connect the "upper layer" signal of TE to Upper. type Transport_Endpoint_Access is access all Transport_Endpoint'Class; -- An opened transport endpoint. function Notepad_Of (TE : Transport_Endpoint_Access) return Annotations.Notepad_Access; pragma Inline (Notepad_Of); function Handle_Message (TE : not null access Transport_Endpoint; Msg : Components.Message'Class) return Components.Message'Class; function Upper (TE : Transport_Endpoint_Access) return Components.Component_Access; -- Return a component access to the upper layer of TE ---------------------------------------------------- -- Primitive operations of Transport_Access_Point -- -- and Transport_Endpoint. -- -- To be overridden by concrete implementations. -- ---------------------------------------------------- -- These primitives are invoked from event-driven ORB -- threads, and /must not/ be blocking. function Create_Event_Source (TE : access Transport_Endpoint) return Asynch_Ev.Asynch_Ev_Source_Access is abstract; -- Create a view of TE as an asynchronous event source. The Handler -- of the newly-created event source is TE.Handler. procedure Read (TE : in out Transport_Endpoint; Buffer : Buffers.Buffer_Access; Size : in out Ada.Streams.Stream_Element_Count; Error : out Errors.Error_Container) is abstract; -- Receive data from TE into Buffer at the current position. On entry, -- called, Size is set to the maximum size of the data to be received. -- On return, Size is set to the effective amount of data received. -- The current position in Buffer remains unchanged. procedure Write (TE : in out Transport_Endpoint; Buffer : Buffers.Buffer_Access; Error : out Errors.Error_Container) is abstract; -- Write out the contents of Buffer onto TE procedure Close (TE : access Transport_Endpoint); -- Dissociate the transport endpoint from any communication resource procedure Destroy (TE : in out Transport_Endpoint); -- Destroy any resources allocated to TE procedure Destroy (TE : in out Transport_Endpoint_Access); -- Destroy TE and the protocol stack built upon it, recursively. -- Deallocate TE. On return, TE is null. private type Transport_Access_Point is abstract new Components.Component with record Notepad : aliased Annotations.Notepad; end record; type Transport_Endpoint is abstract new Components.Component with record Notepad : aliased Annotations.Notepad; Server : Components.Component_Access; -- Communication signal to ORB core. Upper : Components.Component_Access; -- Communication signal to upper layer. Binding_Object : Smart_Pointers.Entity_Ptr; -- Enclosing binding object entity (not reference counted, set for -- both client side and server side TEs). Dependent_Binding_Object : Smart_Pointers.Ref; -- For server-side transport endpoints, keep a reference to the -- associated binding object as long as the transport endpoint is -- is alive. Note: when Dependent_Binding_Object is set, its -- entity is always equal to the above Binding_Object. Closed : Boolean := False; -- Set to True once Close has been called on this endpoint. In_Buf : Buffers.Buffer_Access; Max : Ada.Streams.Stream_Element_Count; end record; procedure Check_Validity (TE : access Transport_Endpoint); -- Check whether TE (which must not be closed) is still valid, and if not, -- close it. Used for handling of Check_Validity filter message. end PolyORB.Transport; polyorb-2.8~20110207.orig/src/polyorb-poa_policies-id_assignment_policy-user.ads0000644000175000017500000000641211750740340027174 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- POLYORB.POA_POLICIES.ID_ASSIGNMENT_POLICY.USER -- -- -- -- S p e c -- -- -- -- Copyright (C) 2002-2005 Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ package PolyORB.POA_Policies.Id_Assignment_Policy.User is type User_Id_Policy is new IdAssignmentPolicy with null record; type User_Id_Policy_Access is access all User_Id_Policy; function Create return User_Id_Policy_Access; procedure Check_Compatibility (Self : User_Id_Policy; Other_Policies : AllPolicies; Error : in out PolyORB.Errors.Error_Container); function Policy_Id (Self : User_Id_Policy) return String; function Create_Object_Map (Self : User_Id_Policy) return PolyORB.Object_Maps.Object_Map_Access; procedure Assign_Object_Identifier (Self : User_Id_Policy; OA : PolyORB.POA_Types.Obj_Adapter_Access; Hint : Object_Id_Access; U_Oid : out Unmarshalled_Oid; Error : in out PolyORB.Errors.Error_Container); procedure Reconstruct_Object_Identifier (Self : User_Id_Policy; OA : Obj_Adapter_Access; Oid : Object_Id; U_Oid : out Unmarshalled_Oid; Error : in out PolyORB.Errors.Error_Container); procedure Object_Identifier (Self : User_Id_Policy; Oid : Object_Id_Access; Result : out Object_Id_Access; Error : in out PolyORB.Errors.Error_Container); end PolyORB.POA_Policies.Id_Assignment_Policy.User; polyorb-2.8~20110207.orig/src/polyorb-poa_policies-implicit_activation_policy-no_activation.adb0000644000175000017500000001044611750740340032243 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- POLYORB.POA_POLICIES.IMPLICIT_ACTIVATION_POLICY.NO_ACTIVATION -- -- -- -- B o d y -- -- -- -- Copyright (C) 2001-2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ package body PolyORB.POA_Policies.Implicit_Activation_Policy.No_Activation is ------------ -- Create -- ------------ function Create return No_Activation_Policy_Access is begin return new No_Activation_Policy; end Create; ------------------------- -- Check_Compatibility -- ------------------------- procedure Check_Compatibility (Self : No_Activation_Policy; Other_Policies : AllPolicies; Error : in out PolyORB.Errors.Error_Container) is pragma Warnings (Off); pragma Unreferenced (Self); pragma Unreferenced (Other_Policies); pragma Unreferenced (Error); pragma Warnings (On); begin null; -- No rule to test. end Check_Compatibility; --------------- -- Policy_Id -- --------------- function Policy_Id (Self : No_Activation_Policy) return String is pragma Warnings (Off); pragma Unreferenced (Self); pragma Warnings (On); begin return "IMPLICIT_ACTIVATION_POLICY.NO_ACTIVATION"; end Policy_Id; ------------------------------- -- Implicit_Activate_Servant -- ------------------------------- procedure Implicit_Activate_Servant (Self : No_Activation_Policy; OA : PolyORB.POA_Types.Obj_Adapter_Access; P_Servant : Servants.Servant_Access; Hint : Object_Id_Access; Oid : out Object_Id_Access; Error : in out PolyORB.Errors.Error_Container) is pragma Unreferenced (Self); pragma Unreferenced (OA); pragma Unreferenced (P_Servant); pragma Unreferenced (Hint); use PolyORB.Errors; begin Oid := null; Throw (Error, ServantNotActive_E, Null_Member); end Implicit_Activate_Servant; ----------------------------------- -- Ensure_No_Implicit_Activation -- ----------------------------------- procedure Ensure_No_Implicit_Activation (Self : No_Activation_Policy; Error : in out PolyORB.Errors.Error_Container) is pragma Unreferenced (Self); pragma Unreferenced (Error); begin null; end Ensure_No_Implicit_Activation; end PolyORB.POA_Policies.Implicit_Activation_Policy.No_Activation; polyorb-2.8~20110207.orig/src/polyorb-any-initialization.ads0000644000175000017500000000422011750740340023160 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . A N Y . I N I T I A L I Z A T I O N -- -- -- -- S p e c -- -- -- -- Copyright (C) 2004 Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by ACT Europe. -- -- (email: sales@act-europe.fr) -- -- -- ------------------------------------------------------------------------------ -- Initialization code for PolyORB.Any package PolyORB.Any.Initialization is pragma Elaborate_Body; end PolyORB.Any.Initialization; polyorb-2.8~20110207.orig/src/polyorb-utils-hfunctions-mul.adb0000644000175000017500000000704511750740340023444 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . U T I L S . H F U N C T I O N S . M U L -- -- -- -- B o d y -- -- -- -- Copyright (C) 2003-2008, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ package body PolyORB.Utils.HFunctions.Mul is Default_Prime : constant := 1_777_771; -------------- -- Hash_Mul -- -------------- function Hash_Mul (S : String; K : Natural; Prime : Natural; Size : Natural) return Natural is Lambda : constant := 65599; Result : Long_Long_Integer := 0; begin for J in S'Range loop Result := (Result * Lambda + Long_Long_Integer (Character'Pos (S (J))) * Long_Long_Integer (K)) mod Long_Long_Integer (Prime); end loop; return Natural (Result mod Long_Long_Integer (Size)); end Hash_Mul; ---------- -- Hash -- ---------- function Hash (S : String; Param : Hash_Mul_Parameters; Size : Natural) return Natural is begin return Hash_Mul (S, Param.K, Param.Prime, Size); end Hash; ----------------------------- -- Default_Hash_Parameters -- ----------------------------- function Default_Hash_Parameters return Hash_Mul_Parameters is begin return Hash_Mul_Parameters'(K => 1, Prime => Default_Prime); end Default_Hash_Parameters; -------------------------- -- Next_Hash_Parameters -- -------------------------- function Next_Hash_Parameters (Param : Hash_Mul_Parameters) return Hash_Mul_Parameters is begin return Hash_Mul_Parameters' (K => 1 + (Param.K mod Param.Prime), Prime => Param.Prime); end Next_Hash_Parameters; end PolyORB.Utils.HFunctions.Mul; polyorb-2.8~20110207.orig/src/polyorb-tasking-profiles-ravenscar-threads-annotations.ads0000644000175000017500000000543411750740340030602 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- POLYORB.TASKING.PROFILES.RAVENSCAR.THREADS.ANNOTATIONS -- -- -- -- S p e c -- -- -- -- Copyright (C) 2004-2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with PolyORB.Annotations; with PolyORB.Initialization; with PolyORB.Tasking.Threads.Annotations; generic package PolyORB.Tasking.Profiles.Ravenscar.Threads.Annotations is type Ravenscar_TAF is new PolyORB.Tasking.Threads.Annotations.Thread_Annotations_Factory with private; type Ravenscar_TAF_Access is access all Ravenscar_TAF; function Get_Current_Thread_Notepad (TAF : access Ravenscar_TAF) return PolyORB.Annotations.Notepad_Access; private type Ravenscar_TAF is new PolyORB.Tasking.Threads.Annotations.Thread_Annotations_Factory with null record; procedure Initialize; Initializer : constant PolyORB.Initialization.Initializer := Initialize'Access; end PolyORB.Tasking.Profiles.Ravenscar.Threads.Annotations; polyorb-2.8~20110207.orig/src/polyorb-tasking-profiles-full_tasking-threads-dynamic_priorities.ads0000644000175000017500000000506211750740340032635 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- POLYORB.TASKING.PROFILES.FULL_TASKING.THREADS.DYNAMIC_PRIORITIES -- -- -- -- S p e c -- -- -- -- Copyright (C) 2003-2004 Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by ACT Europe. -- -- (email: sales@act-europe.fr) -- -- -- ------------------------------------------------------------------------------ -- This packages provides a thread library for an Ada full tasking -- runtime, using Ada.Dynamic_Priorities. package PolyORB.Tasking.Profiles.Full_Tasking.Threads.Dynamic_Priorities is procedure Set_Priority (TF : access Full_Tasking_Thread_Factory_Type; T : PTT.Thread_Id; P : System.Any_Priority); function Get_Priority (TF : access Full_Tasking_Thread_Factory_Type; T : PTT.Thread_Id) return System.Any_Priority; end PolyORB.Tasking.Profiles.Full_Tasking.Threads.Dynamic_Priorities; polyorb-2.8~20110207.orig/src/moma/0000755000175000017500000000000011750740340016122 5ustar xavierxavierpolyorb-2.8~20110207.orig/src/moma/moma-message_producers.adb0000644000175000017500000004070611750740340023242 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- M O M A . M E S S A G E _ P R O D U C E R S -- -- -- -- B o d y -- -- -- -- Copyright (C) 2002-2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with MOMA.Messages.MExecutes; with MOMA.Runtime; with PolyORB.MOMA_P.Exceptions; with PolyORB.MOMA_P.Provider.Message_Producer; with PolyORB.Any.NVList; with PolyORB.Errors; with PolyORB.Log; with PolyORB.Minimal_Servant.Tools; with PolyORB.References; with PolyORB.Requests; with PolyORB.Request_QoS; with PolyORB.QoS.Priority; with PolyORB.Tasking.Priorities; with PolyORB.Types; package body MOMA.Message_Producers is use MOMA.Messages; use MOMA.Messages.MExecutes; use MOMA.Types; use PolyORB.MOMA_P.Provider.Message_Producer; use PolyORB.Any; use PolyORB.Log; use PolyORB.Minimal_Servant.Tools; use PolyORB.Types; package L is new PolyORB.Log.Facility_Log ("moma.message_producers"); procedure O (Message : Standard.String; Level : Log_Level := Debug) renames L.Output; function C (Level : Log_Level := Debug) return Boolean renames L.Enabled; procedure Response_Handler (Req : PolyORB.Requests.Request; CBH : access PolyORB.Call_Back.Call_Back_Handler); -- Call back handler attached to a MOM producer interacting with -- an ORB node. procedure Send_To_MOM (Servant : MOMA.Types.Ref; Message : MOMA.Messages.Message'Class); -- Send Message to a MOM object. procedure Send_To_ORB (Self : Message_Producer; Message : MOMA.Messages.Message'Class); -- Send Message to an ORB object, see MOMA.Messages.MExecutes -- specifications for more details. ----------- -- Close -- ----------- procedure Close is begin null; end Close; --------------------- -- Create_Producer -- --------------------- function Create_Producer (Session : MOMA.Sessions.Session; Dest : MOMA.Destinations.Destination) return Message_Producer is pragma Warnings (Off); pragma Unreferenced (Session); pragma Warnings (On); -- XXX Session is to be used to 'place' the receiver -- using session position in the POA use PolyORB.Errors; use PolyORB.References; MOMA_Obj : constant PolyORB.MOMA_P.Provider.Message_Producer.Object_Acc := new PolyORB.MOMA_P.Provider.Message_Producer.Object; MOMA_Ref : PolyORB.References.Ref; Producer : MOMA.Message_Producers.Message_Producer; Type_Id_S : constant MOMA.Types.String := To_MOMA_String (Type_Id_Of (MOMA.Destinations.Get_Ref (Dest))); Error : Error_Container; begin Initiate_Servant (MOMA_Obj, MOMA.Runtime.MOMA_OA, PolyORB.Types.String (MOMA.Types.MOMA_Type_Id), MOMA_Ref, Error); if Found (Error) then PolyORB.MOMA_P.Exceptions.Raise_From_Error (Error); end if; Set_Remote_Ref (MOMA_Obj.all, MOMA.Destinations.Get_Ref (Dest)); Set_Destination (Producer, Dest); Set_Ref (Producer, MOMA_Ref); Set_Type_Id_Of (Producer, Type_Id_S); -- XXX Is it really useful to have the Ref to the remote destination in -- the Message_Producer itself ? By construction, this ref is -- encapsulated in the PolyORB.MOMA_P.Provider.Message_Producer.Object return Producer; end Create_Producer; function Create_Producer (ORB_Object : MOMA.Types.String; Mesg_Pool : MOMA.Types.String) return Message_Producer is use PolyORB.Annotations; use PolyORB.Call_Back; use PolyORB.References; Producer : MOMA.Message_Producers.Message_Producer; ORB_Object_IOR : PolyORB.References.Ref; Dest_Ref_Object_IOR : PolyORB.References.Ref; begin String_To_Object (MOMA.Types.To_Standard_String (ORB_Object), ORB_Object_IOR); String_To_Object (MOMA.Types.To_Standard_String (Mesg_Pool), Dest_Ref_Object_IOR); declare Type_Id_S : constant String := Type_Id_Of (ORB_Object_IOR); begin if Type_Id_S = MOMA_Type_Id then raise Program_Error; end if; Set_Ref (Producer, ORB_Object_IOR); Set_Type_Id_Of (Producer, To_PolyORB_String (Type_Id_S)); Set_CBH (Producer, new PolyORB.Call_Back.Call_Back_Handler); -- XXX should free this memory sometime, somewhere ... end; Attach_Handler_To_CB (Call_Back_Handler (Get_CBH (Producer).all), MOMA.Message_Producers.Response_Handler'Access); Set_Note (Notepad_Of (Get_CBH (Producer)).all, CBH_Note'(Note with Dest => Dest_Ref_Object_IOR)); return Producer; end Create_Producer; ------------- -- Get_CBH -- ------------- function Get_CBH (Self : Message_Producer) return PolyORB.Call_Back.CBH_Access is begin return Self.CBH; end Get_CBH; --------------------- -- Get_Destination -- --------------------- function Get_Destination (Self : Message_Producer) return MOMA.Destinations.Destination is begin return Self.Destination; end Get_Destination; -------------------- -- Get_Persistent -- -------------------- function Get_Persistent (Self : Message_Producer) return Boolean is begin return Self.Persistent; end Get_Persistent; ------------------ -- Get_Priority -- ------------------ function Get_Priority (Self : Message_Producer) return MOMA.Types.Priority is begin return Self.Priority_Level; end Get_Priority; ------------- -- Get_Ref -- ------------- function Get_Ref (Self : Message_Producer) return MOMA.Types.Ref is begin return Self.Ref; end Get_Ref; ---------------------- -- Get_Time_To_Live -- ---------------------- function Get_Time_To_Live (Self : Message_Producer) return Time is begin return Self.TTL; end Get_Time_To_Live; -------------------- -- Get_Type_Id_Of -- -------------------- function Get_Type_Id_Of (Self : Message_Producer) return MOMA.Types.String is begin return Self.Type_Id_Of; end Get_Type_Id_Of; ---------------------- -- Response_Handler -- ---------------------- procedure Response_Handler (Req : PolyORB.Requests.Request; CBH : access PolyORB.Call_Back.Call_Back_Handler) is use PolyORB.Annotations; use PolyORB.Call_Back; Message : MExecute := Create_Execute_Message; begin pragma Debug (C, O ("Got : " & PolyORB.Requests.Image (Req))); pragma Debug (C, O ("return value : " & PolyORB.Any.Image (Req.Result.Argument))); declare Method_Name : Map_Element; Return_1 : Map_Element; Parameter_Map : Map; Note : CBH_Note; begin Method_Name := (Name => To_MOMA_String ("method"), Value => PolyORB.Any.To_Any (PolyORB.Types.To_PolyORB_String (Req.Operation.all))); Return_1 := (Name => To_MOMA_String ("return_1"), Value => Req.Result.Argument); Append (Parameter_Map, Method_Name); Append (Parameter_Map, Return_1); Set_Parameter (Message, Parameter_Map); Get_Note (Notepad_Of (CBH).all, Note); Send_To_MOM (Note.Dest, Message); end; end Response_Handler; ---------- -- Send -- ---------- procedure Send (Self : Message_Producer; Message : in out MOMA.Messages.Message'Class) is use MOMA.Destinations; Type_Id_S : constant MOMA.Types.String := Get_Type_Id_Of (Self); begin MOMA.Messages.Set_Destination (Message, Get_Destination (Self)); if Type_Id_S = MOMA.Types.MOMA_Type_Id then Send_To_MOM (Get_Ref (Self), Message); else Send_To_ORB (Self, Message); end if; end Send; ---------- -- Send -- ---------- procedure Send (Self : Message_Producer; Message : MOMA.Messages.Message'Class; Persistent : Boolean; Priority_Value : MOMA.Types.Priority; TTL : Time) is pragma Warnings (Off); pragma Unreferenced (Self); pragma Unreferenced (Message); pragma Unreferenced (Persistent); pragma Unreferenced (Priority_Value); pragma Unreferenced (TTL); pragma Warnings (On); begin null; -- XXX Not Implemented end Send; ----------------- -- Send_To_MOM -- ----------------- procedure Send_To_MOM (Servant : MOMA.Types.Ref; Message : MOMA.Messages.Message'Class) is use type PolyORB.Tasking.Priorities.External_Priority; Argument_Mesg : constant PolyORB.Any.Any := MOMA.Messages.To_Any (Message); Request : PolyORB.Requests.Request_Access; Arg_List : PolyORB.Any.NVList.Ref; Result : PolyORB.Any.NamedValue; begin pragma Debug (C, O ("Sending to MOM object : " & PolyORB.Any.Image (Argument_Mesg))); PolyORB.Any.NVList.Create (Arg_List); PolyORB.Any.NVList.Add_Item (Arg_List, To_PolyORB_String ("Message"), Argument_Mesg, PolyORB.Any.ARG_IN); Result := (Name => To_PolyORB_String ("Result"), Argument => PolyORB.Any.Get_Empty_Any (PolyORB.Any.TC_Void), Arg_Modes => 0); PolyORB.Requests.Create_Request (Target => Servant, Operation => "Publish", Arg_List => Arg_List, Result => Result, Req => Request); if MOMA.Messages.Get_Priority (Message) /= Invalid_Priority then declare Prio_QoS : PolyORB.QoS.QoS_Parameter_Access; begin Prio_QoS := new PolyORB.QoS.Priority.QoS_Static_Priority; PolyORB.QoS.Priority.QoS_Static_Priority (Prio_QoS.all).EP := MOMA.Messages.Get_Priority (Message); PolyORB.Request_QoS.Add_Request_QoS (Request.all, PolyORB.QoS.Static_Priority, Prio_QoS); end; end if; PolyORB.Requests.Invoke (Request); PolyORB.Requests.Destroy_Request (Request); end Send_To_MOM; ----------------- -- Send_To_ORB -- ----------------- procedure Send_To_ORB (Self : Message_Producer; Message : MOMA.Messages.Message'Class) is use PolyORB.Any.TypeCode; use PolyORB.Call_Back; Request : PolyORB.Requests.Request_Access; Arg_List : PolyORB.Any.NVList.Ref; Result : PolyORB.Any.NamedValue; Parameter_Map : Map; begin pragma Debug (C, O ("Sending message to ORB object.")); if Message not in MExecute then raise Program_Error; else Parameter_Map := Get_Parameter (MExecute (Message)); end if; declare Method_Name : constant String := MOMA.Types.To_Standard_String (Get_String (Get_Element (Parameter_Map, 1))); Result_TypeCode : constant PolyORB.Any.TypeCode.Local_Ref := Get_Type (Get_Element (Parameter_Map, 2).Value); begin pragma Debug (C, O ("Method name : " & Method_Name)); PolyORB.Any.NVList.Create (Arg_List); for J in 3 .. Length (Parameter_Map) loop pragma Debug (C, O ("Argument: " & PolyORB.Types.To_Standard_String (PolyORB.Any.From_Any (Get_Element (Parameter_Map, J).Value)))); PolyORB.Any.NVList.Add_Item (Arg_List, To_PolyORB_String ("Message"), Get_Element (Parameter_Map, J).Value, PolyORB.Any.ARG_IN); end loop; Result := (Name => To_PolyORB_String ("Result"), Argument => PolyORB.Any.Get_Empty_Any (Result_TypeCode), Arg_Modes => 0); PolyORB.Requests.Create_Request (Target => Get_Ref (Self), Operation => Method_Name, Arg_List => Arg_List, Result => Result, Req => Request, Req_Flags => PolyORB.Requests.Sync_Call_Back); if Result_TypeCode /= TypeCode.TC_Void then pragma Debug (C, O ("Non void return parameter.")); Attach_Request_To_CB (Request, Self.CBH); end if; pragma Debug (C, O ("Invoking : " & PolyORB.Requests.Image (Request.all))); PolyORB.Requests.Invoke (Request); if Result_TypeCode = TypeCode.TC_Void then PolyORB.Requests.Destroy_Request (Request); end if; -- Note : in the other case, the request is destroyed when sending -- see polyorb-protocols.adb for more details. end; end Send_To_ORB; ------------- -- Set_CBH -- ------------- procedure Set_CBH (Self : in out Message_Producer; CBH : PolyORB.Call_Back.CBH_Access) is begin Self.CBH := CBH; end Set_CBH; --------------------- -- Set_Destination -- --------------------- procedure Set_Destination (Self : in out Message_Producer; Dest : MOMA.Destinations.Destination) is begin Self.Destination := Dest; end Set_Destination; -------------------- -- Set_Persistent -- -------------------- procedure Set_Persistent (Self : in out Message_Producer; Persistent : Boolean) is begin Self.Persistent := Persistent; end Set_Persistent; ------------------ -- Set_Priority -- ------------------ procedure Set_Priority (Self : in out Message_Producer; Value : MOMA.Types.Priority) is begin Self.Priority_Level := Value; end Set_Priority; ------------- -- Set_Ref -- ------------- procedure Set_Ref (Self : in out Message_Producer; Ref : MOMA.Types.Ref) is begin Self.Ref := Ref; end Set_Ref; ---------------------- -- Set_Time_To_Live -- ---------------------- procedure Set_Time_To_Live (Self : in out Message_Producer; TTL : Time) is begin Self.TTL := TTL; end Set_Time_To_Live; -------------------- -- Set_Type_Id_Of -- -------------------- procedure Set_Type_Id_Of (Self : in out Message_Producer; Type_Id_Of : MOMA.Types.String) is begin Self.Type_Id_Of := Type_Id_Of; end Set_Type_Id_Of; end MOMA.Message_Producers; polyorb-2.8~20110207.orig/src/moma/password.conf0000644000175000017500000000014411750740340020632 0ustar xavierxavier[user_1] name=Ada password=Lovelace class=user [user_2] name=Byron password=Lord class=admin polyorb-2.8~20110207.orig/src/moma/polyorb-moma_p-provider-message_producer.ads0000644000175000017500000000621711750740340026732 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- POLYORB.MOMA_P.PROVIDER.MESSAGE_PRODUCER -- -- -- -- S p e c -- -- -- -- Copyright (C) 2002-2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- Actual implementation of the Message_Producer object. It is -- derived from PolyORB's Minimal_Servant. This package contains -- Message_Producer skeleton and implementation subroutines. By -- construction, its implementation subroutines contain parts of a -- stub for the Message_Pool object. with PolyORB.Minimal_Servant; with PolyORB.References; with PolyORB.Requests; package PolyORB.MOMA_P.Provider.Message_Producer is type Object is new PolyORB.Minimal_Servant.Servant with private; -- Remote_Ref : Reference to the remote object to which send messages. type Object_Acc is access Object; procedure Invoke (Self : access Object; Req : PolyORB.Requests.Request_Access); -- Message_Producer servant skeleton. -- Accessors to Object internals. function Get_Remote_Ref (Self : Object) return PolyORB.References.Ref; procedure Set_Remote_Ref (Self : in out Object; Ref : PolyORB.References.Ref); private type Object is new PolyORB.Minimal_Servant.Servant with record Remote_Ref : PolyORB.References.Ref; end record; end PolyORB.MOMA_P.Provider.Message_Producer; polyorb-2.8~20110207.orig/src/moma/moma-sessions.adb0000644000175000017500000001276311750740340021400 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- M O M A . S E S S I O N S -- -- -- -- B o d y -- -- -- -- Copyright (C) 2002-2004 Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with PolyORB.Any.NVList; with PolyORB.Requests; with PolyORB.Types; package body MOMA.Sessions is use PolyORB.Types; ------------ -- Close -- ------------ procedure Close is begin null; -- XXX Not Implemented end Close; ------------- -- Commit -- ------------- procedure Commit is begin null; -- XXX Not Implemented end Commit; -------------------- -- Create_Session -- -------------------- function Create_Session (Connection : MOMA.Connections.Connection; Transacted : Boolean; Acknowledge_Mode : MOMA.Types.Acknowledge_Type) return Session is pragma Warnings (Off); pragma Unreferenced (Connection); pragma Warnings (On); New_Session : Session; begin -- XXX ??? Why New_Session.Transacted := Transacted; New_Session.Acknowledge_Mode := Acknowledge_Mode; return New_Session; end Create_Session; --------------------- -- Get_Transacted -- --------------------- function Get_Transacted return Boolean is begin raise Program_Error; pragma Warnings (Off); return Get_Transacted; pragma Warnings (On); end Get_Transacted; -------------- -- Recover -- -------------- procedure Recover is begin null; -- XXX Not Implemented end Recover; --------------- -- Rollback -- --------------- procedure Rollback is begin null; -- XXX Not Implemented end Rollback; --------------- -- Subscribe -- --------------- procedure Subscribe (Topic : MOMA.Destinations.Destination; Pool : MOMA.Destinations.Destination; Sub : Boolean := True) is use MOMA.Destinations; use type MOMA.Types.Destination_Type; Arg_List : PolyORB.Any.NVList.Ref; Request : PolyORB.Requests.Request_Access; Result : PolyORB.Any.NamedValue; Operation : PolyORB.Types.String := To_PolyORB_String ("Subscribe"); begin if Get_Kind (Topic) /= MOMA.Types.Topic or else Get_Kind (Pool) /= MOMA.Types.Pool then raise Program_Error; end if; if not Sub then Operation := To_PolyORB_String ("Unsubscribe"); end if; PolyORB.Any.NVList.Create (Arg_List); PolyORB.Any.NVList.Add_Item (Arg_List, To_PolyORB_String ("Topic"), To_Any (Topic), PolyORB.Any.ARG_IN); PolyORB.Any.NVList.Add_Item (Arg_List, To_PolyORB_String ("Pool"), To_Any (Pool), PolyORB.Any.ARG_IN); Result := (Name => To_PolyORB_String ("Result"), Argument => PolyORB.Any.Get_Empty_Any (PolyORB.Any.TC_Void), Arg_Modes => 0); PolyORB.Requests.Create_Request (Target => Get_Ref (Topic), Operation => PolyORB.Types.To_Standard_String (Operation), Arg_List => Arg_List, Result => Result, Req => Request); PolyORB.Requests.Invoke (Request); PolyORB.Requests.Destroy_Request (Request); end Subscribe; ----------------- -- Unsubscribe -- ----------------- procedure Unsubscribe (Topic : MOMA.Destinations.Destination; Pool : MOMA.Destinations.Destination) is begin Subscribe (Topic, Pool, False); end Unsubscribe; end MOMA.Sessions; polyorb-2.8~20110207.orig/src/moma/moma-messages-mstreams.adb0000644000175000017500000001137611750740340023171 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- M O M A . M E S S A G E S . M S T R E A M S -- -- -- -- B o d y -- -- -- -- Copyright (C) 2002 Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by ACT Europe. -- -- (email: sales@act-europe.fr) -- -- -- ------------------------------------------------------------------------------ package body MOMA.Messages.MStreams is Not_Implemented : exception; ------------------ -- Read_Boolean -- ------------------ function Read_Boolean return Boolean is begin raise Not_Implemented; pragma Warnings (Off); return Read_Boolean; pragma Warnings (On); end Read_Boolean; --------------- -- Read_Char -- --------------- function Read_Char return Character is begin raise Not_Implemented; pragma Warnings (Off); return Read_Char; pragma Warnings (On); end Read_Char; ---------------- -- Read_Float -- ---------------- function Read_Float return Float is begin raise Not_Implemented; pragma Warnings (Off); return Read_Float; pragma Warnings (On); end Read_Float; ------------------ -- Read_Integer -- ------------------ function Read_Integer return Integer is begin raise Not_Implemented; pragma Warnings (Off); return Read_Integer; pragma Warnings (On); end Read_Integer; ----------------- -- Read_String -- ----------------- function Read_String return String is begin raise Not_Implemented; pragma Warnings (Off); return Read_String; pragma Warnings (On); end Read_String; ----------- -- Reset -- ----------- procedure Reset is begin null; -- XXX Not Implemented end Reset; ----------------- -- Set_Boolean -- ----------------- procedure Set_Boolean (Value : Boolean) is begin pragma Warnings (Off); pragma Unreferenced (Value); pragma Warnings (On); null; -- XXX Not Implemented end Set_Boolean; -------------- -- Set_Char -- -------------- procedure Set_Char (Value : Character) is begin pragma Warnings (Off); pragma Unreferenced (Value); pragma Warnings (On); null; -- XXX Not Implemented end Set_Char; --------------- -- Set_Float -- --------------- procedure Set_Float (Value : Float) is begin pragma Warnings (Off); pragma Unreferenced (Value); pragma Warnings (On); null; -- XXX Not Implemented end Set_Float; ----------------- -- Set_Integer -- ----------------- procedure Set_Integer (Value : Integer) is begin pragma Warnings (Off); pragma Unreferenced (Value); pragma Warnings (On); null; -- XXX Not Implemented end Set_Integer; ---------------- -- Set_String -- ---------------- procedure Set_String (Value : String) is begin pragma Warnings (Off); pragma Unreferenced (Value); pragma Warnings (On); null; -- XXX Not Implemented end Set_String; end MOMA.Messages.MStreams; polyorb-2.8~20110207.orig/src/moma/moma-configuration.ads0000644000175000017500000000507311750740340022416 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- M O M A . C O N F I G U R A T I O N -- -- -- -- S p e c -- -- -- -- Copyright (C) 2002 Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by ACT Europe. -- -- (email: sales@act-europe.fr) -- -- -- ------------------------------------------------------------------------------ -- This package provides accessors to data contained in MOMA configuration -- files. See '*.conf' files for more details about their syntax. with MOMA.Types; package MOMA.Configuration is procedure Load_Configuration_File (Conf_File_Name : String); -- Load the content of Conf_File_Name into PolyORB configuration table. -- Accessors to MOMA destination configuration files data. function Get_Message_Pool (Number : Natural) return MOMA.Types.Message_Pool; -- Get information about message pool #Number. end MOMA.Configuration; polyorb-2.8~20110207.orig/src/moma/moma-configuration-server.ads0000644000175000017500000000520611750740340023720 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- M O M A . C O N F I G U R A T I O N . S E R V E R -- -- -- -- S p e c -- -- -- -- Copyright (C) 2002-2004 Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by ACT Europe. -- -- (email: sales@act-europe.fr) -- -- -- ------------------------------------------------------------------------------ -- This package provides utility functions to setup a MOMA server node. with MOMA.Types; package MOMA.Configuration.Server is procedure Create_Message_Pool (Pool : MOMA.Types.Message_Pool; Ref : out MOMA.Types.Ref); -- Create a message pool and return its reference. procedure Create_Router (Id : MOMA.Types.String; Ref : out MOMA.Types.Ref; Router_Ref : MOMA.Types.Ref := MOMA.Types.Nil_Ref); -- Create a router and return its reference. -- If Router_Ref is specified, it's a reference to another router on the -- network. end MOMA.Configuration.Server; polyorb-2.8~20110207.orig/src/moma/moma-types.ads0000644000175000017500000002424011750740340020710 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- M O M A . T Y P E S -- -- -- -- S p e c -- -- -- -- Copyright (C) 2002-2007, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- This package provides definition of all MOMA types. with Ada.Strings.Unbounded; with PolyORB.Any; with PolyORB.References; with PolyORB.Sequences.Unbounded; with PolyORB.Tasking.Priorities; with PolyORB.Types; package MOMA.Types is use PolyORB.Types; ----------------- -- Basic types -- ----------------- subtype Any is PolyORB.Any.Any; type Boolean is new PolyORB.Types.Boolean; type Byte is new PolyORB.Types.Octet; type Char is new PolyORB.Types.Char; type Double is new PolyORB.Types.Double; type Float is new PolyORB.Types.Float; type Long is new PolyORB.Types.Long; type Short is new PolyORB.Types.Short; type String is new PolyORB.Types.String; type Unsigned_Long is new PolyORB.Types.Unsigned_Long; type Unsigned_Short is new PolyORB.Types.Unsigned_Short; subtype Ref is PolyORB.References.Ref; function To_Any (Item : Any) return Any; function To_Any (Item : Boolean) return Any; function To_Any (Item : Byte) return Any; function To_Any (Item : Char) return Any; function To_Any (Item : Double) return Any; function To_Any (Item : MOMA.Types.Float) return Any; function To_Any (Item : Long) return Any; function To_Any (Item : Short) return Any; function To_Any (Item : MOMA.Types.String) return Any; function To_Any (Item : Unsigned_Short) return Any; function To_Any (Item : Unsigned_Long) return Any; function From_Any (Item : Any) return Any; function From_Any (Item : Any) return Boolean; function From_Any (Item : Any) return Byte; function From_Any (Item : Any) return Char; function From_Any (Item : Any) return Double; function From_Any (Item : Any) return MOMA.Types.Float; function From_Any (Item : Any) return Long; function From_Any (Item : Any) return Short; function From_Any (Item : Any) return MOMA.Types.String; function From_Any (Item : Any) return Unsigned_Long; function From_Any (Item : Any) return Unsigned_Short; function "=" (Left, Right : Any) return Standard.Boolean renames PolyORB.Any."="; function "=" (Left, Right : Ref) return Standard.Boolean renames PolyORB.References."="; Nil_Ref : constant MOMA.Types.Ref := MOMA.Types.Ref (PolyORB.References.Nil_Ref); --------------------------------- -- String conversion fonctions -- --------------------------------- function To_Standard_String (V : MOMA.Types.String) return Standard.String; function To_MOMA_String (V : Standard.String) return MOMA.Types.String; ------------------------- -- MOMA specific types -- ------------------------- -- The Map type, see JMS spec. for more details. As implemented, -- a Map is an unbounded sequence of Map_Elements. -- -- Note that Map type inherits all primitives from the -- PolyORB.Sequences.Unbounded package. -- Map_Element type type Map_Element is record Name : MOMA.Types.String; Value : MOMA.Types.Any; end record; TC_Map_Element : PolyORB.Any.TypeCode.Local_Ref; function To_Any (Item : Map_Element) return MOMA.Types.Any; function From_Any (Item : MOMA.Types.Any) return Map_Element; function Get_Boolean (Self : Map_Element) return MOMA.Types.Boolean; procedure Set_Boolean (Self : in out Map_Element; Value : MOMA.Types.Boolean); function Get_Byte (Self : Map_Element) return MOMA.Types.Byte; procedure Set_Byte (Self : in out Map_Element; Value : MOMA.Types.Byte); function Get_Char (Self : Map_Element) return MOMA.Types.Char; procedure Set_Char (Self : in out Map_Element; Value : MOMA.Types.Char); function Get_Double (Self : Map_Element) return MOMA.Types.Double; procedure Set_Double (Self : in out Map_Element; Value : MOMA.Types.Double); function Get_Float (Self : Map_Element) return MOMA.Types.Float; procedure Set_Float (Self : in out Map_Element; Value : MOMA.Types.Float); function Get_Long (Self : Map_Element) return MOMA.Types.Long; procedure Set_Long (Self : in out Map_Element; Value : MOMA.Types.Long); function Get_Name (Self : Map_Element) return MOMA.Types.String; procedure Set_Name (Self : in out Map_Element; Value : MOMA.Types.String); function Get_Short (Self : Map_Element) return MOMA.Types.Short; procedure Set_Short (Self : in out Map_Element; Value : MOMA.Types.Short); function Get_String (Self : Map_Element) return MOMA.Types.String; procedure Set_String (Self : in out Map_Element; Value : MOMA.Types.String); function Get_Unsigned_Short (Self : Map_Element) return MOMA.Types.Unsigned_Short; procedure Set_Unsigned_Short (Self : in out Map_Element; Value : MOMA.Types.Unsigned_Short); function Get_Unsigned_Long (Self : Map_Element) return MOMA.Types.Unsigned_Long; procedure Set_Unsigned_Long (Self : in out Map_Element; Value : MOMA.Types.Unsigned_Long); -- Map type package IDL_SEQUENCE_Map_Element is new PolyORB.Sequences.Unbounded (Map_Element); TC_IDL_SEQUENCE_Map_Element : PolyORB.Any.TypeCode.Local_Ref; function To_Any (Item : IDL_SEQUENCE_Map_Element.Sequence) return MOMA.Types.Any; function From_Any (Item : MOMA.Types.Any) return IDL_SEQUENCE_Map_Element.Sequence; TC_Map : PolyORB.Any.TypeCode.Local_Ref; type Map is new MOMA.Types.IDL_SEQUENCE_Map_Element.Sequence; function To_Any (Item : Map) return MOMA.Types.Any; function From_Any (Item : MOMA.Types.Any) return Map; ------------------------------- -- MOMA administrative types -- ------------------------------- MOMA_Type_Id : constant MOMA.Types.String; -- Destination type type Destination_Type is (Unknown, Pool, Router, Topic); TC_Destination_Type : PolyORB.Any.TypeCode.Local_Ref; function To_Any (Item : Destination_Type) return MOMA.Types.Any; function From_Any (Item : MOMA.Types.Any) return Destination_Type; -- Pool type type Pool_Type is (Queue, Topic); -- Persistence mode type Persistence_Mode is (None, File); -- Message type type Message_Type is (Any_M, Byte_M, Execute_M, Map_M, Text_M); -- Callback type Call_Back_Behavior is (Notify, Handle, None); -- Behaviors for call-back : only notify message presence, send -- the message when received for Handle, or None. -- Message_Pool type type Message_Pool is private; -- Type : type of the pool -- Name : name of the pool -- Persistence : persistence mode of the pool function Get_Name (Pool : MOMA.Types.Message_Pool) return MOMA.Types.String; procedure Set_Name (Pool : in out MOMA.Types.Message_Pool; Name : MOMA.Types.String); function Get_Type (Pool : MOMA.Types.Message_Pool) return MOMA.Types.Pool_Type; procedure Set_Type (Pool : in out MOMA.Types.Message_Pool; PType : Pool_Type); function Get_Persistence (Pool : MOMA.Types.Message_Pool) return MOMA.Types.Persistence_Mode; procedure Set_Persistence (Pool : in out MOMA.Types.Message_Pool; PMode : Persistence_Mode); -- Priority subtype Priority is PolyORB.Tasking.Priorities.External_Priority; Invalid_Priority : constant Priority; -- Other types -- XXX to be clarified type Meta_Data is new Integer; type Acknowledge_Type is new Integer; type Property_Type is new Integer; private MOMA_Type_Id : constant MOMA.Types.String := MOMA.Types.String (Ada.Strings.Unbounded.To_Unbounded_String ("MOMA")); type Message_Pool is record Pool : MOMA.Types.Pool_Type; Name : MOMA.Types.String; Persistence : MOMA.Types.Persistence_Mode; end record; Invalid_Priority : constant Priority := Priority (PolyORB.Tasking.Priorities.Invalid_Priority); end MOMA.Types; polyorb-2.8~20110207.orig/src/moma/moma-messages-mbytes.adb0000644000175000017500000001757211750740340022645 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- M O M A . M E S S A G E S . M B Y T E S -- -- -- -- B o d y -- -- -- -- Copyright (C) 2002-2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with PolyORB.Types; package body MOMA.Messages.MBytes is ------------------------- -- Create_Byte_Message -- ------------------------- function Create_Byte_Message return MByte is Result : MByte; begin Set_Type (Result, MOMA.Types.Byte_M); Set_Default_Message_Header (Result); return Result; end Create_Byte_Message; ----------- -- Image -- ----------- function Image (Self : MByte) return String is begin raise Program_Error; pragma Warnings (Off); return Image (Self); pragma Warnings (On); end Image; ----------------- -- Get_Boolean -- ----------------- function Get_Boolean (Self : MByte) return MOMA.Types.Boolean is begin return MOMA.Types.Boolean (PolyORB.Types.Boolean'(PolyORB.Any.From_Any (Get_Payload (Self)))); end Get_Boolean; ----------------- -- Set_Boolean -- ----------------- procedure Set_Boolean (Self : in out MByte; Value : MOMA.Types.Boolean) is begin Set_Payload (Self, PolyORB.Any.To_Any (PolyORB.Types.Boolean (Value))); end Set_Boolean; -------------- -- Get_Byte -- -------------- function Get_Byte (Self : MByte) return MOMA.Types.Byte is begin return MOMA.Types.Byte (PolyORB.Types.Octet'(PolyORB.Any.From_Any (Get_Payload (Self)))); end Get_Byte; -------------- -- Set_Byte -- -------------- procedure Set_Byte (Self : in out MByte; Value : MOMA.Types.Byte) is begin Set_Payload (Self, PolyORB.Any.To_Any (PolyORB.Types.Octet (Value))); end Set_Byte; -------------- -- Get_Char -- -------------- function Get_Char (Self : MByte) return MOMA.Types.Char is begin return MOMA.Types.Char (PolyORB.Types.Char'(PolyORB.Any.From_Any (Get_Payload (Self)))); end Get_Char; -------------- -- Set_Char -- -------------- procedure Set_Char (Self : in out MByte; Value : MOMA.Types.Char) is begin Set_Payload (Self, PolyORB.Any.To_Any (PolyORB.Types.Char (Value))); end Set_Char; ---------------- -- Get_Double -- ---------------- function Get_Double (Self : MByte) return MOMA.Types.Double is begin return MOMA.Types.Double (PolyORB.Types.Double'(PolyORB.Any.From_Any (Get_Payload (Self)))); end Get_Double; ---------------- -- Set_Double -- ---------------- procedure Set_Double (Self : in out MByte; Value : MOMA.Types.Double) is begin Set_Payload (Self, PolyORB.Any.To_Any (PolyORB.Types.Double (Value))); end Set_Double; --------------- -- Get_Float -- --------------- function Get_Float (Self : MByte) return MOMA.Types.Float is begin return MOMA.Types.Float (PolyORB.Types.Float'(PolyORB.Any.From_Any (Get_Payload (Self)))); end Get_Float; --------------- -- Set_Float -- --------------- procedure Set_Float (Self : in out MByte; Value : MOMA.Types.Float) is begin Set_Payload (Self, PolyORB.Any.To_Any (PolyORB.Types.Float (Value))); end Set_Float; -------------- -- Get_Long -- -------------- function Get_Long (Self : MByte) return MOMA.Types.Long is begin return MOMA.Types.Long (PolyORB.Types.Long'(PolyORB.Any.From_Any (Get_Payload (Self)))); end Get_Long; -------------- -- Set_Long -- -------------- procedure Set_Long (Self : in out MByte; Value : MOMA.Types.Long) is begin Set_Payload (Self, PolyORB.Any.To_Any (PolyORB.Types.Long (Value))); end Set_Long; --------------- -- Get_Short -- --------------- function Get_Short (Self : MByte) return MOMA.Types.Short is begin return MOMA.Types.Short (PolyORB.Types.Short'(PolyORB.Any.From_Any (Get_Payload (Self)))); end Get_Short; --------------- -- Set_Short -- --------------- procedure Set_Short (Self : in out MByte; Value : MOMA.Types.Short) is begin Set_Payload (Self, PolyORB.Any.To_Any (PolyORB.Types.Short (Value))); end Set_Short; ----------------------- -- Get_Unsigned_Long -- ----------------------- function Get_Unsigned_Long (Self : MByte) return MOMA.Types.Unsigned_Long is begin return MOMA.Types.Unsigned_Long (PolyORB.Types.Unsigned_Long'(PolyORB.Any.From_Any (Get_Payload (Self)))); end Get_Unsigned_Long; ----------------------- -- Set_Unsigned_Long -- ----------------------- procedure Set_Unsigned_Long (Self : in out MByte; Value : MOMA.Types.Unsigned_Long) is begin Set_Payload (Self, PolyORB.Any.To_Any (PolyORB.Types.Unsigned_Long (Value))); end Set_Unsigned_Long; ------------------------ -- Get_Unsigned_Short -- ------------------------ function Get_Unsigned_Short (Self : MByte) return MOMA.Types.Unsigned_Short is begin return MOMA.Types.Unsigned_Short (PolyORB.Types.Unsigned_Short'(PolyORB.Any.From_Any (Get_Payload (Self)))); end Get_Unsigned_Short; ------------------------ -- Set_Unsigned_Short -- ------------------------ procedure Set_Unsigned_Short (Self : in out MByte; Value : MOMA.Types.Unsigned_Short) is begin Set_Payload (Self, PolyORB.Any.To_Any (PolyORB.Types.Unsigned_Short (Value))); end Set_Unsigned_Short; end MOMA.Messages.MBytes; polyorb-2.8~20110207.orig/src/moma/moma-references.ads0000644000175000017500000000570611750740340021673 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- M O M A . R E F E R E N C E S -- -- -- -- S p e c -- -- -- -- Copyright (C) 2004-2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with MOMA.Types; package MOMA.References is procedure Initialize_Naming_Service (Naming_Ref : Standard.String); -- Initialize Naming Service using Naming_Ref stringified reference procedure Register_Name (Name : String; Ref : MOMA.Types.Ref; Rebind : Boolean := False; Sep : Character := '/'); -- Register an object by its name by binding or rebinding. -- If Rebind is True, then a rebind will be performed if the name -- is already bound. function Locate (IOR_Or_Name : String; Sep : Character := '/') return MOMA.Types.Ref; -- Locate an object by IOR or name. If the string does not start with -- "IOR:", the name will be parsed before it is looked up. function Reference_To_IOR_String (Ref : MOMA.Types.Ref) return Standard.String; procedure String_To_Reference (S : Standard.String; Ref : out MOMA.Types.Ref); end MOMA.References; polyorb-2.8~20110207.orig/src/moma/moma-sessions.ads0000644000175000017500000000716211750740340021416 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- M O M A . S E S S I O N S -- -- -- -- S p e c -- -- -- -- Copyright (C) 2002 Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by ACT Europe. -- -- (email: sales@act-europe.fr) -- -- -- ------------------------------------------------------------------------------ -- A Session defines an execution context in which Message_Producers and -- Message_Consumers live. We use the capabilities of PolyORB's POA to -- associate a thread to each session. -- XXX this package requires first to complete the implementation of POA -- policies. Its definition and the completion of its API is left 'as is'. -- XXX Need to add functions to implement durable subscription to a topic. with MOMA.Connections; with MOMA.Destinations; with MOMA.Types; package MOMA.Sessions is type Session is record Transacted : Boolean; Acknowledge_Mode : MOMA.Types.Acknowledge_Type; end record; function Create_Session (Connection : MOMA.Connections.Connection; Transacted : Boolean; Acknowledge_Mode : MOMA.Types.Acknowledge_Type) return Session; -- Create a session from a Connection. procedure Close; procedure Commit; function Get_Transacted return Boolean; procedure Recover; procedure Rollback; procedure Subscribe (Topic : MOMA.Destinations.Destination; Pool : MOMA.Destinations.Destination; Sub : Boolean := True); -- Subscribe / Unsubscribe a Pool to a Topic. -- Topic's reference must be a router. -- Pool's reference must be a message pool. -- If Sub is true then it is a subscription, if false an unsubscription. procedure Unsubscribe (Topic : MOMA.Destinations.Destination; Pool : MOMA.Destinations.Destination); -- Unsubscribe a Pool from a Topic. -- Provided for convenience only, as the Subscribe function may be used -- for the same purpose. end MOMA.Sessions; polyorb-2.8~20110207.orig/src/moma/moma-message_consumers.ads0000644000175000017500000001157011750740340023270 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- M O M A . M E S S A G E _ C O N S U M E R S -- -- -- -- S p e c -- -- -- -- Copyright (C) 2002-2005 Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- A Message_Consumer object is the client view of the message receiving -- process. It is the facade to all communications carried out with -- a message pool to receive messages; it contains the stub to access -- Message_Consumer servants (see MOMA.Provider for more details). -- NOTE: A MOMA client must use only this package to receive messages from a -- message pool. with Ada.Real_Time; with MOMA.Destinations; with MOMA.Messages; with MOMA.Sessions; with MOMA.Types; package MOMA.Message_Consumers is type Message_Consumer is private; -- Destination : origin of all messages received. -- Ref : reference to the provider servant type Message_Consumer_Acc is access Message_Consumer; function Create_Consumer (Session : MOMA.Sessions.Session; Dest : MOMA.Destinations.Destination) return Message_Consumer_Acc; -- Create a new message consumer. function Create_Consumer (Session : MOMA.Sessions.Session; Dest : MOMA.Destinations.Destination; Message_Selector : MOMA.Types.String) return Message_Consumer_Acc; -- XXX Not implemented. procedure Close; -- XXX not implemented. Rename it to Destroy ? function Get_Message_Selector return String; -- XXX not implemented. function Receive (Self : Message_Consumer; Priority : MOMA.Types.Priority := MOMA.Types.Invalid_Priority) return MOMA.Messages.Message'Class; -- Get next message from the pool if it is non empty; otherwise -- the call is blocking until a new message is received by the -- pool. Use Priority as priority for the corresponding -- invocations, unless it is set to Invalid_Priority. -- XXX not all cases are tested ! function Receive (Timeout : Ada.Real_Time.Time) return MOMA.Messages.Message; -- Get next message from the pool if it is non empty; otherwise will -- wait during Timeout until a new message arrives. -- XXX not implemented. function Receive_No_Wait return MOMA.Messages.Message; -- Get next message from the pool if it is non empty; exit otherwise. -- XXX not implemented. -- Accessors to Message_Consumer internal data. function Get_Ref (Self : Message_Consumer) return MOMA.Types.Ref; procedure Set_Ref (Self : in out Message_Consumer; Ref : MOMA.Types.Ref); function Get_Destination (Self : Message_Consumer) return MOMA.Destinations.Destination; procedure Set_Destination (Self : in out Message_Consumer; Dest : MOMA.Destinations.Destination); private type Message_Consumer is record Destination : MOMA.Destinations.Destination; Ref : MOMA.Types.Ref; end record; pragma Inline (Get_Ref); pragma Inline (Set_Ref); pragma Inline (Get_Destination); pragma Inline (Set_Destination); end MOMA.Message_Consumers; polyorb-2.8~20110207.orig/src/moma/polyorb-moma_p-exceptions.adb0000644000175000017500000000464311750740340023714 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . M O M A _ P . E X C E P T I O N S -- -- -- -- B o d y -- -- -- -- Copyright (C) 2003-2005 Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with MOMA; package body PolyORB.MOMA_P.Exceptions is use PolyORB.Errors; ---------------------- -- Raise_From_Error -- ---------------------- procedure Raise_From_Error (Error : in out PolyORB.Errors.Error_Container) is begin pragma Assert (Is_Error (Error)); Free (Error.Member); raise MOMA.Internal_Error; end Raise_From_Error; end PolyORB.MOMA_P.Exceptions; polyorb-2.8~20110207.orig/src/moma/moma-messages-manys.ads0000644000175000017500000000534511750740340022505 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- M O M A . M E S S A G E S . M A N Y S -- -- -- -- S p e c -- -- -- -- Copyright (C) 2002-2004 Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by ACT Europe. -- -- (email: sales@act-europe.fr) -- -- -- ------------------------------------------------------------------------------ -- MAny message type. -- -- A MAny message's payload is a PolyORB Any. It's an 'all purpose' message -- type designed to create ad hoc messages, from various data types such as -- arrays, records, user defined types .. with MOMA.Types; package MOMA.Messages.MAnys is type MAny is new Message with private; function Create_Any_Message return Messages.MAnys.MAny; -- Create a MAny message. function Image (Self : MAny) return String; -- Image function for MAny type. -- Accessors to MAny payload. function Get_Any (Self : MAny) return MOMA.Types.Any; procedure Set_Any (Self : in out MAny; Value : MOMA.Types.Any); private type MAny is new Message with null record; end MOMA.Messages.MAnys; polyorb-2.8~20110207.orig/src/moma/polyorb-moma_p-provider-warehouse.adb0000644000175000017500000001541311750740340025362 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . M O M A _ P . P R O V I D E R . W A R E H O U S E -- -- -- -- B o d y -- -- -- -- Copyright (C) 2002-2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- A dynamic, protected dictionary of Any, indexed by Strings. with Ada.Streams.Stream_IO; package body PolyORB.MOMA_P.Provider.Warehouse is use Ada.Streams; use Ada.Streams.Stream_IO; use PolyORB.Any; use PolyORB.Tasking.Rw_Locks; use MOMA.Types; --------------------------- -- Ensure_Initialization -- --------------------------- procedure Ensure_Initialization (W : in out Warehouse); pragma Inline (Ensure_Initialization); -- Ensure that T was initialized procedure Ensure_Initialization (W : in out Warehouse) is begin if W.T_Initialized then return; end if; Initialize (W.T); Create (W.T_Lock); W.T_Initialized := True; end Ensure_Initialization; ------------ -- Lookup -- ------------ function Lookup (W : Warehouse; K : String) return PolyORB.Any.Any is Result : PolyORB.Any.Any; -- Stream_File : Ada.Streams.Stream_IO.File_Type; -- Buffer : constant Buffer_Access := new Buffer_Type; -- Data : Opaque_Pointer; -- Last : Ada.Streams.Stream_Element_Offset; -- Received : Ada.Streams.Stream_Element_Count; Temp : Warehouse := W; begin Ensure_Initialization (Temp); if W.T_Persistence = None then Lock_R (W.T_Lock); Result := Lookup (W.T, K, Result); Unlock_R (W.T_Lock); if Is_Empty (Result) then raise Key_Not_Found; end if; else -- Ada.Streams.Stream_IO.Open (Stream_File, In_File, "message_" & K); -- Allocate_And_Insert_Cooked_Data (Buffer, 1024, Data); -- declare -- Z_Addr : constant System.Address := Data; -- Z : Stream_Element_Array (0 .. 1023); -- for Z'Address use Z_Addr; -- pragma Import (Ada, Z); -- begin -- Ada.Streams.Stream_IO.Read (Stream_File, Z, Last); -- end; -- Received := Last + 1; -- Unuse_Allocation (Buffer, 1024 - Received); -- Ada.Streams.Stream_IO.Close (Stream_File); -- Set_Type (Result, TC_MOMA_Message); -- Rewind (Buffer); -- Unmarshall_To_Any (Buffer, Result); raise Program_Error; -- XXX This code is now deactivated (as of 9/17/04): We -- cannot rely on the Rewind primitive which is -- deprecated. Besides, we need to find an efficient way to -- store a buffer into a file. end if; return Result; end Lookup; function Lookup (W : Warehouse; K : String; Default : PolyORB.Any.Any) return PolyORB.Any.Any is V : PolyORB.Any.Any; Temp : Warehouse := W; begin Ensure_Initialization (Temp); Lock_R (W.T_Lock); V := Lookup (W.T, K, Default); Unlock_R (W.T_Lock); return V; end Lookup; -------------- -- Register -- -------------- procedure Register (W : in out Warehouse; K : String; V : PolyORB.Any.Any) is -- Stream_File : Ada.Streams.Stream_IO.File_Type; -- Buffer : constant Buffer_Access := new Buffer_Type; begin Ensure_Initialization (W); if W.T_Persistence = None then Lock_W (W.T_Lock); Insert (W.T, K, V); Unlock_W (W.T_Lock); else -- Marshall_From_Any (Buffer, V); -- Ada.Streams.Stream_IO.Create (Stream_File, Out_File, "message_" & K); -- Ada.Streams.Stream_IO.Write (Stream_File, -- To_Stream_Element_Array (Buffer)); -- Ada.Streams.Stream_IO.Close (Stream_File); -- XXX This code is now deactivated (as of 9/17/04): We -- cannot rely on the Rewind primitive which is -- deprecated. Besides, we need to find an efficient way to -- store a buffer into a file. raise Program_Error; end if; end Register; ---------------- -- Unregister -- ---------------- procedure Unregister (W : in out Warehouse; K : String) is Stream_File : Ada.Streams.Stream_IO.File_Type; begin Ensure_Initialization (W); if W.T_Persistence = None then Lock_W (W.T_Lock); Delete (W.T, K); Unlock_W (W.T_Lock); else Ada.Streams.Stream_IO.Open (Stream_File, Out_File, "message_" & K); Ada.Streams.Stream_IO.Delete (Stream_File); end if; end Unregister; --------------------- -- Set_Persistence -- --------------------- procedure Set_Persistence (W : in out Warehouse; Persistence : MOMA.Types.Persistence_Mode) is begin W.T_Persistence := Persistence; end Set_Persistence; end PolyORB.MOMA_P.Provider.Warehouse; polyorb-2.8~20110207.orig/src/moma/moma-messages-mexecutes.ads0000644000175000017500000000670011750740340023354 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- M O M A . M E S S A G E S . M E X E C U T E S -- -- -- -- S p e c -- -- -- -- Copyright (C) 2002 Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by ACT Europe. -- -- (email: sales@act-europe.fr) -- -- -- ------------------------------------------------------------------------------ -- MExecute message type. -- -- A MExecute message derives directly from MMap message. -- Its payload contains a map type. -- -- It should be filled the following way : -- -- element : (name => "method", -- value => any()) -- element : (name => "return" , -- value => any()) -- element i in 1 .. n : (name => "arg_i" , -- value => any()) -- -- Warning : for this mapping to work, the method _must_ only accept in -- parameters. -- -- Given the destination of this messages, the payload can be interpreted -- either as -- -- - a normal payload, if the destination is a message pool. -- - request parameters if the destination is an ORB object. -- ORB objects are objects created using a PolyORB ORB application -- personality (e.g. CORBA, DSA ..) package MOMA.Messages.MExecutes is type MExecute is new Message with private; function Create_Execute_Message return Messages.MExecutes.MExecute; -- Create a MExecute message. function Image (Self : MExecute) return String; -- Image function for MExecute type. -- Accessors to MExecute payload. function Get_Parameter (Self : MExecute) return MOMA.Types.Map; procedure Set_Parameter (Self : in out MExecute; Value : MOMA.Types.Map); private type MExecute is new Message with null record; end MOMA.Messages.MExecutes; polyorb-2.8~20110207.orig/src/moma/moma-messages-mmaps.ads0000644000175000017500000000516711750740340022475 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- M O M A . M E S S A G E S . M M A P S -- -- -- -- S p e c -- -- -- -- Copyright (C) 2002 Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by ACT Europe. -- -- (email: sales@act-europe.fr) -- -- -- ------------------------------------------------------------------------------ -- MMap message type. -- -- A MMap message contains a sequence of named value, similar to a bag -- container. with MOMA.Types; package MOMA.Messages.MMaps is type MMap is new Message with private; function Create_Map_Message return Messages.MMaps.MMap; -- Create a MMap message. function Image (Self : MMap) return String; -- Image function for MMap type. -- Accessors to MMap payload. function Get_Map (Self : MMap) return MOMA.Types.Map; procedure Set_Map (Self : in out MMap; Value : MOMA.Types.Map); private type MMap is new Message with null record; end MOMA.Messages.MMaps; polyorb-2.8~20110207.orig/src/moma/polyorb-moma_p-provider-topic_datas.adb0000644000175000017500000001262311750740340025652 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . M O M A _ P . P R O V I D E R . T O P I C _ D A T A S -- -- -- -- B o d y -- -- -- -- Copyright (C) 2002-2009, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- A dynamic, protected dictionary of Topics, indexed by Strings. -- Such a dictionary is used by a router to retrieve topics informations. with PolyORB.Log; package body PolyORB.MOMA_P.Provider.Topic_Datas is use Perfect_Htable; use MOMA.Types; use PolyORB.Log; use PolyORB.Tasking.Rw_Locks; package L is new PolyORB.Log.Facility_Log ("moma.provider.topic_datas"); procedure O (Message : Standard.String; Level : Log_Level := Debug) renames L.Output; function C (Level : Log_Level := Debug) return Boolean renames L.Enabled; -------------------- -- Add_Subscriber -- -------------------- procedure Add_Subscriber (Data : Topic_Data; Topic_Id : MOMA.Types.String; Pool : MOMA.Destinations.Destination) is V : Topic; T : constant String := To_Standard_String (Topic_Id); begin pragma Debug (C, O ("Adding to topic " & T & " the Pool " & MOMA.Destinations.Image (Pool))); Lock_W (Data.T_Lock); V := Lookup (Data.T, T, Null_Topic); if V /= Null_Topic then Destination_List.Append (V.Subscribers, Pool); else Insert (Data.T, T, New_Topic (Destination_List."+" (Pool))); end if; Unlock_W (Data.T_Lock); end Add_Subscriber; --------------------------- -- Ensure_Initialization -- --------------------------- procedure Ensure_Initialization (W : in out Topic_Data) is begin if W.T_Initialized then return; end if; Initialize (W.T); PolyORB.Tasking.Rw_Locks.Create (W.T_Lock); W.T_Initialized := True; end Ensure_Initialization; --------------------- -- Get_Subscribers -- --------------------- function Get_Subscribers (Data : Topic_Data; Topic_Id : MOMA.Types.String) return Destination_List.List is V : Topic; Subscribers : Destination_List.List; K : constant String := To_Standard_String (Topic_Id); begin Lock_R (Data.T_Lock); V := Lookup (Data.T, K, Null_Topic); if V /= Null_Topic then Subscribers := Destination_List.Duplicate (V.Subscribers); end if; Unlock_R (Data.T_Lock); return Subscribers; end Get_Subscribers; --------------- -- New_Topic -- --------------- function New_Topic (S : Destination_List.List) return Topic is begin return Topic'(To_MOMA_String ("Unknown"), S); end New_Topic; ----------------------- -- Remove_Subscriber -- ----------------------- procedure Remove_Subscriber (Data : Topic_Data; Topic_Id : MOMA.Types.String; Pool : MOMA.Destinations.Destination) is use Destination_List; V : Topic; T : constant String := To_Standard_String (Topic_Id); begin pragma Debug (C, O ("Removing from topic " & T & " the Pool " & MOMA.Destinations.Image (Pool))); Lock_W (Data.T_Lock); V := Lookup (Data.T, T, Null_Topic); if V = Null_Topic then raise Key_Not_Found; -- XXX do we really need to raise an exception ? end if; Destination_List.Remove_Occurrences (V.Subscribers, Pool); if V.Subscribers = Destination_List.Empty then Delete (Data.T, T); end if; Unlock_W (Data.T_Lock); end Remove_Subscriber; end PolyORB.MOMA_P.Provider.Topic_Datas; polyorb-2.8~20110207.orig/src/moma/moma-connection_factories.adb0000644000175000017500000000526111750740340023723 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- M O M A . C O N N E C T I O N _ F A C T O R I E S -- -- -- -- B o d y -- -- -- -- Copyright (C) 2002-2004 Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by ACT Europe. -- -- (email: sales@act-europe.fr) -- -- -- ------------------------------------------------------------------------------ package body MOMA.Connection_Factories is ------------ -- Create -- ------------ procedure Create (Self : out Connection_Factory; Remote : MOMA.Types.Ref) is begin Set_Ref (Self, Remote); end Create; ------------- -- Get_Ref -- ------------- function Get_Ref (Self : Connection_Factory) return MOMA.Types.Ref is begin return Self.Remote; end Get_Ref; ------------- -- Set_Ref -- ------------- procedure Set_Ref (Self : in out Connection_Factory; Remote : MOMA.Types.Ref) is begin Self.Remote := Remote; end Set_Ref; end MOMA.Connection_Factories; polyorb-2.8~20110207.orig/src/moma/polyorb-moma_p-provider-topic_datas.ads0000644000175000017500000001113311750740340025666 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . M O M A _ P . P R O V I D E R . T O P I C _ D A T A S -- -- -- -- S p e c -- -- -- -- Copyright (C) 2002-2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- A dynamic, protected dictionary of Topics, indexed by Strings. -- Such a dictionary is used by a router to retrieve topics informations. with PolyORB.Tasking.Rw_Locks; with PolyORB.Utils.Chained_Lists; with PolyORB.Utils.HFunctions.Hyper; with PolyORB.Utils.HTables.Perfect; with MOMA.Destinations; with MOMA.Types; pragma Elaborate_All (MOMA.Types); package PolyORB.MOMA_P.Provider.Topic_Datas is use MOMA.Destinations; package Destination_List is new PolyORB.Utils.Chained_Lists (MOMA.Destinations.Destination, MOMA.Destinations."="); -- A chained list of destinations. type Topic is private; -- Name : Name of the topic. -- Subscribers : chained list of destinations, which are the message -- pools subscribed to this topic. -- XXX Maybe not necessary to store a name... Null_Topic : constant Topic; Key_Not_Found : exception; type Topic_Data is private; procedure Add_Subscriber (Data : Topic_Data; Topic_Id : MOMA.Types.String; Pool : MOMA.Destinations.Destination); -- Add a new pool in the subscribers list of a topic. procedure Ensure_Initialization (W : in out Topic_Data); -- Ensure that T was initialized. procedure Remove_Subscriber (Data : Topic_Data; Topic_Id : MOMA.Types.String; Pool : MOMA.Destinations.Destination); -- Remove a pool from the subscribers list of a topic. function Get_Subscribers (Data : Topic_Data; Topic_Id : MOMA.Types.String) return Destination_List.List; -- Return the list of current subscribers to a given topic. private type Topic is record Name : MOMA.Types.String; Subscribers : Destination_List.List; end record; Null_Topic : constant Topic := (Name => MOMA.Types.To_MOMA_String (""), Subscribers => Destination_List.Empty); package Perfect_Htable is new PolyORB.Utils.HTables.Perfect (Topic, PolyORB.Utils.HFunctions.Hyper.Hash_Hyper_Parameters, PolyORB.Utils.HFunctions.Hyper.Default_Hash_Parameters, PolyORB.Utils.HFunctions.Hyper.Hash, PolyORB.Utils.HFunctions.Hyper.Next_Hash_Parameters); type Topic_Data is record T : Perfect_Htable.Table_Instance; T_Initialized : Boolean := False; T_Lock : PolyORB.Tasking.Rw_Locks.Rw_Lock_Access; end record; function New_Topic (S : Destination_List.List) return Topic; -- Return a new topic with the list of subscribers S. end PolyORB.MOMA_P.Provider.Topic_Datas; polyorb-2.8~20110207.orig/src/moma/moma-configuration.adb0000644000175000017500000000775411750740340022405 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- M O M A . C O N F I G U R A T I O N -- -- -- -- B o d y -- -- -- -- Copyright (C) 2002-2008, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with PolyORB.Log; with PolyORB.Parameters.File; package body MOMA.Configuration is use PolyORB.Log; package L is new PolyORB.Log.Facility_Log ("moma.configuration"); procedure O (Message : Standard.String; Level : Log_Level := Debug) renames L.Output; function C (Level : Log_Level := Debug) return Boolean renames L.Enabled; ----------------------------- -- Load_Configuration_File -- ----------------------------- procedure Load_Configuration_File (Conf_File_Name : String) is begin PolyORB.Parameters.File.Load_Configuration_File (Conf_File_Name); end Load_Configuration_File; ---------------------- -- Get_Message_Pool -- ---------------------- function Get_Message_Pool (Number : Natural) return MOMA.Types.Message_Pool is use PolyORB.Parameters; use MOMA.Types; Section : constant String := "destination" & Natural'Image (Number); Pool_S : constant String := Get_Conf (Section, "type"); Persistent_S : constant String := Get_Conf (Section, "persistent"); Result : Message_Pool; begin Set_Name (Result, To_MOMA_String (Get_Conf (Section, "name"))); pragma Debug (C, O ("Pool #" & Natural'Image (Number) & " : " & "Name : " & To_Standard_String (Get_Name (Result)) & ", Type : " & Pool_S & ", Persistent : " & Persistent_S)); if Pool_S = "queue" then Set_Type (Result, Queue); elsif Pool_S = "topic" then Set_Type (Result, Topic); else raise Program_Error; -- XXX should raise something else ... end if; if Persistent_S = "none" then Set_Persistence (Result, None); elsif Persistent_S = "file" then Set_Persistence (Result, MOMA.Types.File); else raise Program_Error; -- XXX should raise something else ... end if; return Result; end Get_Message_Pool; end MOMA.Configuration; polyorb-2.8~20110207.orig/src/moma/moma-messages-manys.adb0000644000175000017500000000556411750740340022467 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- M O M A . M E S S A G E S . M A N Y S -- -- -- -- B o d y -- -- -- -- Copyright (C) 2002-2004 Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by ACT Europe. -- -- (email: sales@act-europe.fr) -- -- -- ------------------------------------------------------------------------------ package body MOMA.Messages.MAnys is -------------- -- Get_Any -- -------------- function Get_Any (Self : MAny) return MOMA.Types.Any is begin return Get_Payload (Self); end Get_Any; -------------- -- Set_Any -- -------------- procedure Set_Any (Self : in out MAny; Value : MOMA.Types.Any) is begin Set_Payload (Self, Value); end Set_Any; ------------------------- -- Create_Any_Message -- ------------------------- function Create_Any_Message return MAny is Result : MAny; begin Set_Type (Result, MOMA.Types.Any_M); Set_Default_Message_Header (Result); return Result; end Create_Any_Message; ----------- -- Image -- ----------- function Image (Self : MAny) return String is begin return Image (Get_Any (Self)); end Image; end MOMA.Messages.MAnys; polyorb-2.8~20110207.orig/src/moma/moma-message_consumers.adb0000644000175000017500000002023511750740340023245 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- M O M A . M E S S A G E _ C O N S U M E R S -- -- -- -- B o d y -- -- -- -- Copyright (C) 2002-2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with MOMA.Runtime; with PolyORB.MOMA_P.Provider.Message_Consumer; with PolyORB.Any.NVList; with PolyORB.Errors; with PolyORB.Minimal_Servant.Tools; with PolyORB.MOMA_P.Exceptions; with PolyORB.Requests; with PolyORB.Request_QoS; with PolyORB.QoS.Priority; with PolyORB.Tasking.Priorities; with PolyORB.Types; package body MOMA.Message_Consumers is use MOMA.Messages; use PolyORB.MOMA_P.Provider.Message_Consumer; use PolyORB.Any; use PolyORB.Minimal_Servant.Tools; use PolyORB.Types; ----------- -- Close -- ----------- procedure Close is begin null; end Close; --------------------- -- Create_Consumer -- --------------------- function Create_Consumer (Session : MOMA.Sessions.Session; Dest : MOMA.Destinations.Destination) return Message_Consumer_Acc is pragma Warnings (Off); pragma Unreferenced (Session); pragma Warnings (On); use PolyORB.Errors; MOMA_Obj : constant PolyORB.MOMA_P.Provider.Message_Consumer.Object_Acc := new PolyORB.MOMA_P.Provider.Message_Consumer.Object; MOMA_Ref : MOMA.Types.Ref; Consumer : constant MOMA.Message_Consumers.Message_Consumer_Acc := new MOMA.Message_Consumers.Message_Consumer; Error : Error_Container; begin -- XXX Session is to be used to 'place' the receiver -- using session position in the POA Initiate_Servant (MOMA_Obj, MOMA.Runtime.MOMA_OA, PolyORB.Types.String (MOMA.Types.MOMA_Type_Id), MOMA_Ref, Error); if Found (Error) then PolyORB.MOMA_P.Exceptions.Raise_From_Error (Error); end if; Set_Remote_Ref (MOMA_Obj.all, MOMA.Destinations.Get_Ref (Dest)); Set_Destination (Consumer.all, Dest); Set_Ref (Consumer.all, MOMA_Ref); -- XXX Is it really useful to have the Ref to the remote destination in -- the Message_Consumer itself ? By construction, this ref is -- encapsulated in the PolyORB.MOMA_P.Provider.Message_Consumer.Object return Consumer; end Create_Consumer; function Create_Consumer (Session : MOMA.Sessions.Session; Dest : MOMA.Destinations.Destination; Message_Selector : MOMA.Types.String) return Message_Consumer_Acc is begin raise Program_Error; pragma Warnings (Off); return Create_Consumer (Session, Dest, Message_Selector); pragma Warnings (On); end Create_Consumer; -------------------------- -- Get_Message_Selector -- -------------------------- function Get_Message_Selector return String is begin raise Program_Error; pragma Warnings (Off); return Get_Message_Selector; pragma Warnings (On); end Get_Message_Selector; --------------------- -- Get_Destination -- --------------------- function Get_Destination (Self : Message_Consumer) return MOMA.Destinations.Destination is begin return Self.Destination; end Get_Destination; ------------- -- Get_Ref -- ------------- function Get_Ref (Self : Message_Consumer) return MOMA.Types.Ref is begin return Self.Ref; end Get_Ref; ------------- -- Receive -- ------------- function Receive (Self : Message_Consumer; Priority : MOMA.Types.Priority := MOMA.Types.Invalid_Priority) return MOMA.Messages.Message'Class is use type PolyORB.Tasking.Priorities.External_Priority; Argument_Mesg : constant PolyORB.Any.Any := PolyORB.Any.To_Any (To_PolyORB_String ("")); -- XXX Temporary hack, should pass message filter ... or not ? Request : PolyORB.Requests.Request_Access; Arg_List : PolyORB.Any.NVList.Ref; Result : PolyORB.Any.NamedValue; Result_Name : constant PolyORB.Types.String := To_PolyORB_String ("Result"); begin PolyORB.Any.NVList.Create (Arg_List); PolyORB.Any.NVList.Add_Item (Arg_List, To_PolyORB_String ("Message"), Argument_Mesg, PolyORB.Any.ARG_IN); Result := (Name => PolyORB.Types.Identifier (Result_Name), Argument => PolyORB.Any.Get_Empty_Any (TC_MOMA_Message), Arg_Modes => 0); PolyORB.Requests.Create_Request (Target => Get_Ref (Self), Operation => "Get", Arg_List => Arg_List, Result => Result, Req => Request); if Priority /= MOMA.Types.Invalid_Priority then declare Prio_QoS : PolyORB.QoS.QoS_Parameter_Access; begin Prio_QoS := new PolyORB.QoS.Priority.QoS_Static_Priority; PolyORB.QoS.Priority.QoS_Static_Priority (Prio_QoS.all).EP := Priority; PolyORB.Request_QoS.Add_Request_QoS (Request.all, PolyORB.QoS.Static_Priority, Prio_QoS); end; end if; PolyORB.Requests.Invoke (Request); PolyORB.Requests.Destroy_Request (Request); return MOMA.Messages.From_Any (Result.Argument); end Receive; function Receive (Timeout : Ada.Real_Time.Time) return MOMA.Messages.Message is begin raise Program_Error; pragma Warnings (Off); return Receive (Timeout); pragma Warnings (On); end Receive; --------------------- -- Receive_No_Wait -- --------------------- function Receive_No_Wait return MOMA.Messages.Message is begin raise Program_Error; pragma Warnings (Off); return Receive_No_Wait; pragma Warnings (On); end Receive_No_Wait; --------------------- -- Set_Destination -- --------------------- procedure Set_Destination (Self : in out Message_Consumer; Dest : MOMA.Destinations.Destination) is begin Self.Destination := Dest; end Set_Destination; ------------- -- Set_Ref -- ------------- procedure Set_Ref (Self : in out Message_Consumer; Ref : MOMA.Types.Ref) is begin Self.Ref := Ref; end Set_Ref; end MOMA.Message_Consumers; polyorb-2.8~20110207.orig/src/moma/moma-destinations.adb0000644000175000017500000002113411750740340022226 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- M O M A . D E S T I N A T I O N S -- -- -- -- B o d y -- -- -- -- Copyright (C) 2002-2007, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with PolyORB.Any.ObjRef; with PolyORB.Initialization; with PolyORB.References; with PolyORB.Types; with PolyORB.Utils.Strings; package body MOMA.Destinations is use MOMA.Types; use PolyORB.Any.ObjRef; use PolyORB.Types; procedure Set_Kind (Self : in out Destination; Kind : MOMA.Types.Destination_Type); pragma Inline (Set_Kind); --------- -- "=" -- --------- function "=" (Dest1 : Destination; Dest2 : Destination) return Boolean is begin return Get_Name (Dest1) = Get_Name (Dest2); end "="; ------------------------ -- Create_Destination -- ------------------------ function Create_Destination (Name : MOMA.Types.String; Ref : MOMA.Types.Ref; Kind : MOMA.Types.Destination_Type := MOMA.Types.Unknown) return Destination is Dest : MOMA.Destinations.Destination; begin Set_Name (Dest, Name); Set_Ref (Dest, Ref); Set_Kind (Dest, Kind); return Dest; end Create_Destination; function Create_Destination return Destination is begin return Create_Destination (To_MOMA_String ("null"), MOMA.Types.Nil_Ref, MOMA.Types.Unknown); end Create_Destination; ---------------------- -- Create_Temporary -- ---------------------- function Create_Temporary return Destination is begin raise Program_Error; pragma Warnings (Off); return Create_Temporary; pragma Warnings (On); end Create_Temporary; ------------ -- Delete -- ------------ procedure Delete is begin null; end Delete; -------------- -- From_Any -- -------------- function From_Any (Self : PolyORB.Any.Any) return MOMA.Destinations.Destination is Kind : MOMA.Types.Destination_Type := MOMA.Types.Unknown; Name : MOMA.Types.String; Ref : MOMA.Types.Ref; begin Name := From_Any (PolyORB.Any.Get_Aggregate_Element (Self, PolyORB.Any.TypeCode.TC_String, PolyORB.Types.Unsigned_Long (0))); Ref := From_Any (PolyORB.Any.Get_Aggregate_Element (Self, PolyORB.Any.TypeCode.TC_Object, PolyORB.Types.Unsigned_Long (1))); Kind := MOMA.Types.From_Any (PolyORB.Any.Get_Aggregate_Element (Self, MOMA.Types.TC_Destination_Type, PolyORB.Types.Unsigned_Long (2))); return Create_Destination (Name, Ref, Kind); end From_Any; -------------- -- Get_Kind -- -------------- function Get_Kind (Self : Destination) return MOMA.Types.Destination_Type is begin return Self.Kind; end Get_Kind; -------------- -- Get_Name -- -------------- function Get_Name (Self : Destination) return MOMA.Types.String is begin return Self.Name; end Get_Name; ------------- -- Get_Ref -- ------------- function Get_Ref (Self : Destination) return MOMA.Types.Ref is begin return Self.Ref; end Get_Ref; ----------- -- Image -- ----------- function Image (Self : Destination) return String is begin return ""; end Image; -------------- -- Set_Name -- -------------- procedure Set_Name (Self : in out Destination; Name : MOMA.Types.String) is begin Self.Name := Name; end Set_Name; ------------- -- Set_Ref -- ------------- procedure Set_Ref (Self : in out Destination; Ref : MOMA.Types.Ref) is begin Self.Ref := Ref; end Set_Ref; -------------- -- Set_Kind -- -------------- procedure Set_Kind (Self : in out Destination; Kind : MOMA.Types.Destination_Type) is begin Self.Kind := Kind; end Set_Kind; ------------ -- To_Any -- ------------ function To_Any (Self : Destination) return MOMA.Types.Any is Result : MOMA.Types.Any := PolyORB.Any.Get_Empty_Any_Aggregate (TC_MOMA_Destination); begin PolyORB.Any.Add_Aggregate_Element (Result, PolyORB.Any.To_Any (PolyORB.Types.String (Self.Name))); PolyORB.Any.Add_Aggregate_Element (Result, PolyORB.Any.ObjRef.To_Any (Self.Ref)); PolyORB.Any.Add_Aggregate_Element (Result, MOMA.Types.To_Any (Self.Kind)); return Result; end To_Any; ---------------- -- Initialize -- ---------------- procedure Initialize; procedure Initialize is use PolyORB.Utils.Strings; T : constant PolyORB.Any.TypeCode.Local_Ref := PolyORB.Any.TypeCode.TC_Object; begin TC_MOMA_Destination := PolyORB.Any.TypeCode.TC_Struct; PolyORB.Any.TypeCode.Add_Parameter (TC_MOMA_Destination, To_Any (To_PolyORB_String ("moma_destination"))); PolyORB.Any.TypeCode.Add_Parameter (TC_MOMA_Destination, To_Any (To_PolyORB_String ("MOMA:destinations/moma_destinations:1.0"))); PolyORB.Any.TypeCode.Add_Parameter (TC_MOMA_Destination, PolyORB.Any.To_Any (PolyORB.Any.TypeCode.TC_String)); PolyORB.Any.TypeCode.Add_Parameter (TC_MOMA_Destination, To_Any (To_PolyORB_String ("name"))); PolyORB.Any.TypeCode.Add_Parameter (T, To_Any (To_PolyORB_String ("Object"))); PolyORB.Any.TypeCode.Add_Parameter (T, To_Any (To_PolyORB_String ("destination"))); PolyORB.Any.TypeCode.Add_Parameter (TC_MOMA_Destination, PolyORB.Any.To_Any (T)); PolyORB.Any.TypeCode.Add_Parameter (TC_MOMA_Destination, To_Any (To_PolyORB_String ("ref"))); PolyORB.Any.TypeCode.Add_Parameter (TC_MOMA_Destination, PolyORB.Any.To_Any (MOMA.Types.TC_Destination_Type)); PolyORB.Any.TypeCode.Add_Parameter (TC_MOMA_Destination, To_Any (To_PolyORB_String ("kind"))); end Initialize; begin declare use PolyORB.Initialization; use PolyORB.Initialization.String_Lists; use PolyORB.Utils.Strings; begin Register_Module (Module_Info' (Name => +"MOMA.Destinations", Conflicts => Empty, Depends => +"MOMA.Types", Provides => Empty, Implicit => False, Init => Initialize'Access, Shutdown => null)); end; end MOMA.Destinations; polyorb-2.8~20110207.orig/src/moma/moma-messages-mtexts.ads0000644000175000017500000000514111750740340022674 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- M O M A . M E S S A G E S . M T E X T S -- -- -- -- S p e c -- -- -- -- Copyright (C) 2002 Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by ACT Europe. -- -- (email: sales@act-europe.fr) -- -- -- ------------------------------------------------------------------------------ -- MText message type. -- -- A MText message's payload is a string. with MOMA.Types; package MOMA.Messages.MTexts is type MText is new Message with private; function Create_Text_Message return Messages.MTexts.MText; -- Create a MText message. function Image (Self : MText) return String; -- Image function for MText type. -- Accessors to MText payload. function Get_Text (Self : MText) return MOMA.Types.String; procedure Set_Text (Self : in out MText; Value : MOMA.Types.String); private type MText is new Message with null record; end MOMA.Messages.MTexts; polyorb-2.8~20110207.orig/src/moma/moma.ads0000644000175000017500000000442311750740340017547 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- M O M A -- -- -- -- S p e c -- -- -- -- Copyright (C) 2002-2003 Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by ACT Europe. -- -- (email: sales@act-europe.fr) -- -- -- ------------------------------------------------------------------------------ -- Base package for all packages related to the MOMA application personality, -- the Message Oriented Middleware for Ada API. package MOMA is pragma Pure (MOMA); Internal_Error : exception; -- Raised when an interal error occurs within MOMA. end MOMA; polyorb-2.8~20110207.orig/src/moma/moma-messages-mstreams.ads0000644000175000017500000000653311750740340023211 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- M O M A . M E S S A G E S . M S T R E A M S -- -- -- -- S p e c -- -- -- -- Copyright (C) 2002 Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by ACT Europe. -- -- (email: sales@act-europe.fr) -- -- -- ------------------------------------------------------------------------------ -- XXX should we keep it ? package MOMA.Messages.MStreams is --------------------- -- MStream Object -- --------------------- type MStream is new Message with null record; ------------------- -- Read_Boolean -- ------------------- function Read_Boolean return Boolean; ---------------- -- Read_Char -- ---------------- function Read_Char return Character; ----------------- -- Read_Float -- ----------------- function Read_Float return Float; ------------------- -- Read_Integer -- ------------------- function Read_Integer return Integer; ------------------ -- Read_String -- ------------------ function Read_String return String; ------------ -- Reset -- ------------ procedure Reset; ------------------------ -- Set_Boolean_Value -- ------------------------ procedure Set_Boolean (Value : Boolean); --------------- -- Set_Char -- --------------- procedure Set_Char (Value : Character); ---------------- -- Set_Float -- ---------------- procedure Set_Float (Value : Float); ------------------ -- Set_Integer -- ------------------ procedure Set_Integer (Value : Integer); ----------------- -- Set_String -- ----------------- procedure Set_String (Value : String); end MOMA.Messages.MStreams; polyorb-2.8~20110207.orig/src/moma/moma-messages-mbytes.ads0000644000175000017500000001007011750740340022650 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- M O M A . M E S S A G E S . M B Y T E S -- -- -- -- S p e c -- -- -- -- Copyright (C) 2002 Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by ACT Europe. -- -- (email: sales@act-europe.fr) -- -- -- ------------------------------------------------------------------------------ -- MByte message type. -- -- A MByte message's payload is a basic type among: Boolean, Byte, Char, -- Double, Float, Long, Short, Unsigned_Short, Unsigned_Long. with MOMA.Types; package MOMA.Messages.MBytes is type MByte is new Message with private; function Create_Byte_Message return MByte; -- Create a MByte message. function Image (Self : MByte) return String; -- Image function for MByte type. -- Accessors to MByte payload. function Get_Boolean (Self : MByte) return MOMA.Types.Boolean; procedure Set_Boolean (Self : in out MByte; Value : MOMA.Types.Boolean); function Get_Byte (Self : MByte) return MOMA.Types.Byte; procedure Set_Byte (Self : in out MByte; Value : MOMA.Types.Byte); function Get_Char (Self : MByte) return MOMA.Types.Char; procedure Set_Char (Self : in out MByte; Value : MOMA.Types.Char); function Get_Double (Self : MByte) return MOMA.Types.Double; procedure Set_Double (Self : in out MByte; Value : MOMA.Types.Double); function Get_Float (Self : MByte) return MOMA.Types.Float; procedure Set_Float (Self : in out MByte; Value : MOMA.Types.Float); function Get_Long (Self : MByte) return MOMA.Types.Long; procedure Set_Long (Self : in out MByte; Value : MOMA.Types.Long); function Get_Short (Self : MByte) return MOMA.Types.Short; procedure Set_Short (Self : in out MByte; Value : MOMA.Types.Short); function Get_Unsigned_Short (Self : MByte) return MOMA.Types.Unsigned_Short; procedure Set_Unsigned_Short (Self : in out MByte; Value : MOMA.Types.Unsigned_Short); function Get_Unsigned_Long (Self : MByte) return MOMA.Types.Unsigned_Long; procedure Set_Unsigned_Long (Self : in out MByte; Value : MOMA.Types.Unsigned_Long); private type MByte is new Message with null record; end MOMA.Messages.MBytes; polyorb-2.8~20110207.orig/src/moma/moma-runtime.ads0000644000175000017500000000445611750740340021236 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- M O M A . R U N T I M E -- -- -- -- S p e c -- -- -- -- Copyright (C) 2004-2005 Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with PolyORB.Obj_Adapters; package MOMA.Runtime is MOMA_OA : PolyORB.Obj_Adapters.Obj_Adapter_Access; procedure Initialize; -- Initialize MOMA runtime procedure Start; -- Launch MOMA node. Current thread will be blocked until MOMA -- node is stopped. end MOMA.Runtime; polyorb-2.8~20110207.orig/src/moma/moma-messages.ads0000644000175000017500000001650711750740340021362 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- M O M A . M E S S A G E S -- -- -- -- S p e c -- -- -- -- Copyright (C) 2002-2007, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- Root of all MOMA message types. with Ada.Real_Time; with MOMA.Destinations; with MOMA.Types; with PolyORB.Any; package MOMA.Messages is use PolyORB.Any; type Message is tagged private; procedure Acknowledge; -- Acknowledge message. -- XXX not implemented. need to define acknowledgment process. procedure Clear_Body; -- Clear message payload. -- XXX not implemented. function Image (Self : Message) return String; -- Image function for message type. procedure Set_Default_Message_Header (Self : in out Message); -- Set Message header to its default value. -- XXX define this 'default value'. procedure Set_Message_Header (Self : in out Message; Message_Id : MOMA.Types.String; Correlation_Id : MOMA.Types.String; Destination : MOMA.Destinations.Destination; Reply_To : MOMA.Destinations.Destination; Priority : MOMA.Types.Priority; Timestamp : Ada.Real_Time.Time; Expiration : Ada.Real_Time.Time; Is_Persistent : MOMA.Types.Boolean; Is_Redelivered : MOMA.Types.Boolean); -- Set the Message's header. -- Accessor to Message internal data. function Get_Correlation_Id (Self : Message) return MOMA.Types.String; function Get_Persistent (Self : Message) return MOMA.Types.Boolean; function Get_Destination (Self : Message) return MOMA.Destinations.Destination; function Get_Expiration (Self : Message) return Ada.Real_Time.Time; function Get_Message_Id (Self : Message) return MOMA.Types.String; function Get_Payload (Self : Message) return MOMA.Types.Any; function Get_Priority (Self : Message) return MOMA.Types.Priority; function Get_Redelivered (Self : Message) return MOMA.Types.Boolean; function Get_Reply_To (Self : Message) return MOMA.Destinations.Destination; function Get_Timestamp (Self : Message) return Ada.Real_Time.Time; function Get_Type (Self : Message) return MOMA.Types.Message_Type; procedure Set_Correlation_Id (Self : in out Message; Correlation_Id : MOMA.Types.String); procedure Set_Persistent (Self : in out Message; Is_Persistent : MOMA.Types.Boolean); procedure Set_Destination (Self : in out Message; Destination : MOMA.Destinations.Destination); procedure Set_Expiration (Self : in out Message; Expiration : Ada.Real_Time.Time); procedure Set_Message_Id (Self : in out Message; Id : MOMA.Types.String); procedure Set_Payload (Self : in out Message; Payload : MOMA.Types.Any); procedure Set_Priority (Self : in out Message; Priority : MOMA.Types.Priority); procedure Set_Redelivered (Self : in out Message; Redelivered : MOMA.Types.Boolean); procedure Set_Reply_To (Self : in out Message; Reply_To : MOMA.Destinations.Destination); procedure Set_Timestamp (Self : in out Message; Timestamp : Ada.Real_Time.Time); procedure Set_Type (Self : in out Message; Type_Of_Message : MOMA.Types.Message_Type); -- XXX Are the following functions junk ? function Get_Property_Names return Integer; function Property_Exists (Name : MOMA.Types.String) return MOMA.Types.Boolean; procedure Set_Property (Name : MOMA.Types.String; Value : MOMA.Types.Property_Type); function Get_Property (Name : MOMA.Types.String) return MOMA.Types.Property_Type; pragma Inline (Get_Property); -- Marshalling support for Message type. TC_MOMA_Message : TypeCode.Local_Ref; function To_Any (Self : Message) return MOMA.Types.Any; function From_Any (Self : MOMA.Types.Any) return Message'Class; private type Message is tagged record Type_Of_Message : MOMA.Types.Message_Type; Message_Id : MOMA.Types.String; Correlation_Id : MOMA.Types.String; Destination : MOMA.Destinations.Destination; Reply_To : MOMA.Destinations.Destination; Priority : MOMA.Types.Priority := MOMA.Types.Invalid_Priority; Timestamp : Ada.Real_Time.Time; Expiration : Ada.Real_Time.Time; Is_Persistent : MOMA.Types.Boolean; Is_Redelivered : MOMA.Types.Boolean; Payload : MOMA.Types.Any; end record; pragma Inline (Get_Correlation_Id); pragma Inline (Get_Persistent); pragma Inline (Get_Destination); pragma Inline (Get_Expiration); pragma Inline (Get_Message_Id); pragma Inline (Get_Payload); pragma Inline (Get_Priority); pragma Inline (Get_Redelivered); pragma Inline (Get_Reply_To); pragma Inline (Get_Timestamp); pragma Inline (Get_Type); pragma Inline (Set_Correlation_Id); pragma Inline (Set_Persistent); pragma Inline (Set_Destination); pragma Inline (Set_Expiration); pragma Inline (Set_Message_Id); pragma Inline (Set_Payload); pragma Inline (Set_Priority); pragma Inline (Set_Redelivered); pragma Inline (Set_Reply_To); pragma Inline (Set_Timestamp); pragma Inline (Set_Type); end MOMA.Messages; polyorb-2.8~20110207.orig/src/moma/producer.conf0000644000175000017500000000025711750740340020620 0ustar xavierxavier[producer] log=true # log = true | false log-level=1 # log-level = 1 .. 3 connection-limit=42 # maximum number of connection # XXX check conformity with whole architecrture polyorb-2.8~20110207.orig/src/moma/polyorb-moma_p-provider-routers.adb0000644000175000017500000004423511750740340025067 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . M O M A _ P . P R O V I D E R . R O U T E R S -- -- -- -- B o d y -- -- -- -- Copyright (C) 2003-2008, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with MOMA.Messages; with PolyORB.Any.NVList; with PolyORB.Errors; with PolyORB.Log; with PolyORB.Types; package body PolyORB.MOMA_P.Provider.Routers is use MOMA.Destinations; use MOMA.Messages; use PolyORB.Any; use PolyORB.Log; use PolyORB.Tasking.Rw_Locks; use PolyORB.Types; package L is new PolyORB.Log.Facility_Log ("moma.provider.routers"); procedure O (Message : Standard.String; Level : Log_Level := Debug) renames L.Output; function C (Level : Log_Level := Debug) return Boolean renames L.Enabled; -- Actual functions implemented by the servant. procedure Add_Router (Self : in out Router; Router : MOMA.Destinations.Destination); -- Add a Router to the list of known routers. procedure Publish (Self : access Router; Message : PolyORB.Any.Any; From_Router_Id : MOMA.Types.String := To_MOMA_String ("")); -- Publish a Message on the topic given by the Message destination. -- From_Router_Id is the Id of the router the message is coming from, if -- it's received from a router and not from a client. procedure Register (Self : access Router; Router_Ref : PolyORB.References.Ref); -- Register a router with another one : this means they will exchange -- messages one with each other. procedure Route (Self : access Router; Message : PolyORB.Any.Any; To_Router : MOMA.Destinations.Destination); -- Route a Message to another router. procedure Store (Pool : PolyORB.References.Ref; Message : PolyORB.Any.Any); -- Store a Message in a Pool. -- XXX Code from Moma.Provider.Message_Producer is duplicated. procedure Subscribe (Self : access Router; Topic : MOMA.Destinations.Destination; Pool : MOMA.Destinations.Destination); -- Subscribe a Pool to a Topic. -- Topic's kind must be set to "Topic". -- Pool's kind must be set to "Pool". procedure Unsubscribe (Self : access Router; Topic : MOMA.Destinations.Destination; Pool : MOMA.Destinations.Destination); -- Unsubscribe a Pool to a Topic (same parameters as Subscribe). -- NB : the current implementation needs a client to send the -- Unsubscription and Subscription requests for a same pool to the same -- router. -- Accessors to servant interface. function Get_Parameter_Profile (Method : String) return PolyORB.Any.NVList.Ref; -- Parameters part of the interface description. -- Private accessors to some internal data. function Get_Routers (Self : Router) return PolyORB.MOMA_P.Provider.Topic_Datas.Destination_List.List; -- Return a copy of the list Self.Routers.List. Message_S : constant PolyORB.Types.Identifier := To_PolyORB_String ("Message"); Result_S : constant PolyORB.Types.Identifier := To_PolyORB_String ("Result"); From_Router_Id_S : constant PolyORB.Types.Identifier := To_PolyORB_String ("From_Router_Id"); Router_S : constant PolyORB.Types.Identifier := To_PolyORB_String ("Router"); Topic_S : constant PolyORB.Types.Identifier := To_PolyORB_String ("Topic"); Pool_S : constant PolyORB.Types.Identifier := To_PolyORB_String ("Pool"); ---------------- -- Add_Router -- ---------------- procedure Add_Router (Self : in out Router; Router : MOMA.Destinations.Destination) is begin Lock_W (Self.Routers.L_Lock); Destination_List.Append (Self.Routers.List, Router); Unlock_W (Self.Routers.L_Lock); -- XXX It would be better to check first the router isn't already -- in the list. end Add_Router; ------------------------ -- Create_Destination -- ------------------------ function Create_Destination (Self : Router) return MOMA.Destinations.Destination is begin return MOMA.Destinations.Create_Destination (Get_Id (Self), Get_Self_Ref (Self), MOMA.Types.Router); end Create_Destination; ------------ -- Get_Id -- ------------ function Get_Id (Self : Router) return MOMA.Types.String is begin return Self.Id; end Get_Id; --------------------------- -- Get_Parameter_Profile -- --------------------------- function Get_Parameter_Profile (Method : String) return PolyORB.Any.NVList.Ref is Result : PolyORB.Any.NVList.Ref; begin PolyORB.Any.NVList.Create (Result); pragma Debug (C, O ("Parameter profile for " & Method & " requested.")); if Method = "Publish" or else Method = "Route" then PolyORB.Any.NVList.Add_Item (Result, (Name => Message_S, Argument => PolyORB.Any.Get_Empty_Any (MOMA.Messages.TC_MOMA_Message), Arg_Modes => PolyORB.Any.ARG_IN)); if Method = "Route" then PolyORB.Any.NVList.Add_Item (Result, (Name => From_Router_Id_S, Argument => PolyORB.Any.Get_Empty_Any (TypeCode.TC_String), Arg_Modes => PolyORB.Any.ARG_IN)); end if; elsif Method = "Register" then PolyORB.Any.NVList.Add_Item (Result, (Name => Router_S, Argument => PolyORB.Any.Get_Empty_Any (MOMA.Destinations.TC_MOMA_Destination), Arg_Modes => PolyORB.Any.ARG_IN)); elsif Method = "Subscribe" or else Method = "Unsubscribe" then PolyORB.Any.NVList.Add_Item (Result, (Name => Topic_S, Argument => PolyORB.Any.Get_Empty_Any (MOMA.Destinations.TC_MOMA_Destination), Arg_Modes => PolyORB.Any.ARG_IN)); PolyORB.Any.NVList.Add_Item (Result, (Name => Pool_S, Argument => PolyORB.Any.Get_Empty_Any (MOMA.Destinations.TC_MOMA_Destination), Arg_Modes => PolyORB.Any.ARG_IN)); else raise Program_Error; end if; return Result; end Get_Parameter_Profile; ----------------- -- Get_Routers -- ----------------- function Get_Routers (Self : Router) return PolyORB.MOMA_P.Provider.Topic_Datas.Destination_List.List is Routers : Destination_List.List; begin Lock_R (Self.Routers.L_Lock); Routers := Destination_List.Duplicate (Self.Routers.List); Unlock_R (Self.Routers.L_Lock); return Routers; end Get_Routers; ------------------ -- Get_Self_Ref -- ------------------ function Get_Self_Ref (Self : Router) return PolyORB.References.Ref is begin return Self.Self_Ref; end Get_Self_Ref; ---------------- -- Initialize -- ---------------- procedure Initialize (Self : access Router; Router_Ref : PolyORB.References.Ref) is begin PolyORB.MOMA_P.Provider.Topic_Datas.Ensure_Initialization (Self.Topics); if not (Self.Routers.L_Initialized) then PolyORB.Tasking.Rw_Locks.Create (Self.Routers.L_Lock); Self.Routers.L_Initialized := True; end if; if not PolyORB.References.Is_Nil (Router_Ref) then Register (Self, Router_Ref); end if; end Initialize; ------------ -- Invoke -- ------------ procedure Invoke (Self : access Router; Req : PolyORB.Requests.Request_Access) is use PolyORB.Any.NVList.Internals; use PolyORB.Any.NVList.Internals.NV_Lists; use PolyORB.Errors; Args : PolyORB.Any.NVList.Ref; It : Iterator; Operation : String renames Req.Operation.all; Error : Error_Container; begin pragma Debug (C, O ("The router is executing the request:" & PolyORB.Requests.Image (Req.all))); Args := Get_Parameter_Profile (Operation); PolyORB.Requests.Arguments (Req, Args, Error); if Found (Error) then raise Program_Error; -- XXX We should do something more contructive end if; It := First (List_Of (Args).all); if Operation = "Publish" then -- Publish Publish (Self, Value (It).Argument); elsif Operation = "Register" then -- Register declare begin Req.Result.Argument := To_Any (Create_Destination (Self.all)); Add_Router (Self.all, MOMA.Destinations.From_Any (Value (It).Argument)); end; elsif Operation = "Route" then -- Route declare Message, From_Router_Id : Element_Access; begin Message := Value (It); Next (It); From_Router_Id := Value (It); Publish (Self, Message.Argument, MOMA.Types.String (PolyORB.Types.String'(PolyORB.Any.From_Any (From_Router_Id.Argument)))); end; elsif Operation = "Subscribe" or else Operation = "Unsubscribe" then -- Subscribe / Unsubscribe declare Topic, Pool : Element_Access; begin Topic := Value (It); Next (It); Pool := Value (It); if Operation = "Subscribe" then Subscribe (Self, MOMA.Destinations.From_Any (Topic.Argument), MOMA.Destinations.From_Any (Pool.Argument)); else Unsubscribe (Self, MOMA.Destinations.From_Any (Topic.Argument), MOMA.Destinations.From_Any (Pool.Argument)); end if; end; end if; end Invoke; ------------- -- Publish -- ------------- procedure Publish (Self : access Router; Message : PolyORB.Any.Any; From_Router_Id : MOMA.Types.String := To_MOMA_String ("")) is Subscribers : Destination_List.List; I : Destination_List.Iterator; Topic_Id : MOMA.Types.String; Destination : MOMA.Destinations.Destination; Routers : Destination_List.List; J : Destination_List.Iterator; begin -- Check the destination is really a topic. Destination := Get_Destination (MOMA.Messages.From_Any (Message)); if Get_Kind (Destination) /= MOMA.Types.Topic then raise Program_Error; end if; Topic_Id := Get_Name (Destination); -- Relay Message to other routers. Routers := Get_Routers (Self.all); J := Destination_List.First (Routers); while not (Destination_List.Last (J)) loop if MOMA.Destinations.Get_Name (Destination_List.Value (J).all) /= From_Router_Id then Route (Self, Message, Destination_List.Value (J).all); end if; Destination_List.Next (J); end loop; Destination_List.Deallocate (Routers); -- Store Message into known pools subscribed to this topic. Subscribers := Get_Subscribers (Self.Topics, Topic_Id); I := Destination_List.First (Subscribers); while not (Destination_List.Last (I)) loop Store (Get_Ref (Destination_List.Value (I).all), Message); Destination_List.Next (I); end loop; Destination_List.Deallocate (Subscribers); end Publish; -------------- -- Register -- -------------- procedure Register (Self : access Router; Router_Ref : PolyORB.References.Ref) is Request : PolyORB.Requests.Request_Access; Arg_List : PolyORB.Any.NVList.Ref; Result : PolyORB.Any.NamedValue; Destination : constant MOMA.Destinations.Destination := Create_Destination (Self.all); begin PolyORB.Any.NVList.Create (Arg_List); PolyORB.Any.NVList.Add_Item (Arg_List, Router_S, To_Any (Destination), PolyORB.Any.ARG_IN); Result := (Name => Result_S, Argument => PolyORB.Any.Get_Empty_Any (MOMA.Destinations.TC_MOMA_Destination), Arg_Modes => 0); PolyORB.Requests.Create_Request (Target => Router_Ref, Operation => "Register", Arg_List => Arg_List, Result => Result, Req => Request); PolyORB.Requests.Invoke (Request); PolyORB.Requests.Destroy_Request (Request); Add_Router (Self.all, MOMA.Destinations.From_Any (Result.Argument)); end Register; ----------- -- Route -- ----------- procedure Route (Self : access Router; Message : PolyORB.Any.Any; To_Router : MOMA.Destinations.Destination) is Request : PolyORB.Requests.Request_Access; Arg_List : PolyORB.Any.NVList.Ref; Result : PolyORB.Any.NamedValue; begin PolyORB.Any.NVList.Create (Arg_List); PolyORB.Any.NVList.Add_Item (Arg_List, Message_S, Message, PolyORB.Any.ARG_IN); PolyORB.Any.NVList.Add_Item (Arg_List, From_Router_Id_S, PolyORB.Any.To_Any (PolyORB.Types.String (Get_Id (Self.all))), PolyORB.Any.ARG_IN); Result := (Name => Result_S, Argument => PolyORB.Any.Get_Empty_Any (PolyORB.Any.TC_Void), Arg_Modes => 0); PolyORB.Requests.Create_Request (Target => Get_Ref (To_Router), Operation => "Route", Arg_List => Arg_List, Result => Result, Req => Request); PolyORB.Requests.Invoke (Request); PolyORB.Requests.Destroy_Request (Request); end Route; ------------ -- Set_Id -- ------------ procedure Set_Id (Self : in out Router; Id : MOMA.Types.String) is begin Self.Id := Id; end Set_Id; ------------------- -- Set_Self_Ref -- ------------------- procedure Set_Self_Ref (Self : in out Router; Ref : PolyORB.References.Ref) is begin Self.Self_Ref := Ref; end Set_Self_Ref; ----------- -- Store -- ----------- procedure Store (Pool : PolyORB.References.Ref; Message : PolyORB.Any.Any) is Request : PolyORB.Requests.Request_Access; Arg_List : PolyORB.Any.NVList.Ref; Result : PolyORB.Any.NamedValue; begin PolyORB.Any.NVList.Create (Arg_List); PolyORB.Any.NVList.Add_Item (Arg_List, Message_S, Message, PolyORB.Any.ARG_IN); Result := (Name => Result_S, Argument => PolyORB.Any.Get_Empty_Any (PolyORB.Any.TC_Void), Arg_Modes => 0); PolyORB.Requests.Create_Request (Target => Pool, Operation => "Publish", Arg_List => Arg_List, Result => Result, Req => Request); PolyORB.Requests.Invoke (Request); PolyORB.Requests.Destroy_Request (Request); end Store; --------------- -- Subscribe -- --------------- procedure Subscribe (Self : access Router; Topic : MOMA.Destinations.Destination; Pool : MOMA.Destinations.Destination) is begin if Get_Kind (Topic) /= MOMA.Types.Topic or else Get_Kind (Pool) /= MOMA.Types.Pool then raise Program_Error; end if; PolyORB.MOMA_P.Provider.Topic_Datas.Add_Subscriber (Self.Topics, Get_Name (Topic), Pool); end Subscribe; ----------------- -- Unsubscribe -- ----------------- procedure Unsubscribe (Self : access Router; Topic : MOMA.Destinations.Destination; Pool : MOMA.Destinations.Destination) is begin if Get_Kind (Topic) /= MOMA.Types.Topic or else Get_Kind (Pool) /= MOMA.Types.Pool then raise Program_Error; end if; PolyORB.MOMA_P.Provider.Topic_Datas.Remove_Subscriber (Self.Topics, Get_Name (Topic), Pool); end Unsubscribe; end PolyORB.MOMA_P.Provider.Routers; polyorb-2.8~20110207.orig/src/moma/polyorb-moma_p-provider-routers.ads0000644000175000017500000001057511750740340025110 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . M O M A _ P . P R O V I D E R . R O U T E R S -- -- -- -- S p e c -- -- -- -- Copyright (C) 2002-2003 Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by ACT Europe. -- -- (email: sales@act-europe.fr) -- -- -- ------------------------------------------------------------------------------ -- A servant used for routing topic messages. with MOMA.Destinations; with MOMA.Types; with PolyORB.MOMA_P.Provider.Topic_Datas; with PolyORB.Minimal_Servant; with PolyORB.References; with PolyORB.Requests; with PolyORB.Tasking.Rw_Locks; package PolyORB.MOMA_P.Provider.Routers is use MOMA.Types; use PolyORB.References; type Router is new PolyORB.Minimal_Servant.Servant with private; -- Id : the Id of the router. -- Routers : the list of routers the router will exchange messages with. -- Self_Ref : a reference to the router, that it can give to other routers. -- Topics : the list of all topics, with their subscribers. type Router_Acc is access Router; type Routers_List is private; -- A protected list of routers. function Create_Destination (Self : Router) return MOMA.Destinations.Destination; -- Return a destination object whose reference is the router and whose -- name is the router Id. procedure Initialize (Self : access Router; Router_Ref : PolyORB.References.Ref); -- Initialize a Router. -- Router_Ref is a reference to another router on the network (it can be -- Nil_Ref) the router will register with. procedure Invoke (Self : access Router; Req : PolyORB.Requests.Request_Access); -- Router servant skeleton. -- Accessors to internal data. function Get_Id (Self : Router) return MOMA.Types.String; procedure Set_Id (Self : in out Router; Id : MOMA.Types.String); function Get_Self_Ref (Self : Router) return PolyORB.References.Ref; procedure Set_Self_Ref (Self : in out Router; Ref : PolyORB.References.Ref); private use PolyORB.MOMA_P.Provider.Topic_Datas; type Routers_List is record List : Destination_List.List; L_Initialized : Boolean := False; L_Lock : PolyORB.Tasking.Rw_Locks.Rw_Lock_Access; end record; type Router is new PolyORB.Minimal_Servant.Servant with record Id : MOMA.Types.String; Routers : Routers_List; Self_Ref : PolyORB.References.Ref; Topics : PolyORB.MOMA_P.Provider.Topic_Datas.Topic_Data; end record; pragma Inline (Get_Id); pragma Inline (Set_Id); pragma Inline (Get_Self_Ref); pragma Inline (Set_Self_Ref); end PolyORB.MOMA_P.Provider.Routers; polyorb-2.8~20110207.orig/src/moma/polyorb-moma_p-provider-message_handler.adb0000644000175000017500000001425711750740340026506 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- POLYORB.MOMA_P.PROVIDER.MESSAGE_HANDLER -- -- -- -- B o d y -- -- -- -- Copyright (C) 2002-2008, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- Message_Handler servant. with MOMA.Messages; with PolyORB.Any; with PolyORB.Any.NVList; with PolyORB.Log; with PolyORB.Types; with PolyORB.Errors; package body PolyORB.MOMA_P.Provider.Message_Handler is use MOMA.Message_Handlers; use PolyORB.Any; use PolyORB.Any.NVList; use PolyORB.Log; use PolyORB.Types; use PolyORB.Requests; package L is new PolyORB.Log.Facility_Log ("moma.provider.message_handler"); procedure O (Message : Standard.String; Level : Log_Level := Debug) renames L.Output; function C (Level : Log_Level := Debug) return Boolean renames L.Enabled; -- Actual function implemented by the servant. procedure Handle (Self : access Object; Message : PolyORB.Any.Any); -- Execute the Handler procedure. -- Called when receiving a Handle request. procedure Notify (Self : access Object); -- Execute the Notifier procedure. -- Called when receiving a Notify request. -- Accessors to servant interface. function Get_Parameter_Profile (Method : String) return PolyORB.Any.NVList.Ref; -- Parameters part of the interface description. ---------------- -- Initialize -- ---------------- procedure Initialize (Self : access Object; MOMA_Message_Handler : MOMA.Message_Handlers.Message_Handler_Acc) is begin Self.MOMA_Message_Handler := MOMA_Message_Handler; end Initialize; ------------ -- Invoke -- ------------ procedure Invoke (Self : access Object; Req : PolyORB.Requests.Request_Access) is use PolyORB.Errors; Args : PolyORB.Any.NVList.Ref; Operation : String renames Req.Operation.all; Error : Error_Container; begin pragma Debug (C, O ("The message handler is executing the request:" & PolyORB.Requests.Image (Req.all))); Args := Get_Parameter_Profile (Operation); PolyORB.Requests.Arguments (Req, Args, Error); if Found (Error) then raise Program_Error; -- XXX We should do something more contructive end if; if Operation = "Notify" then Notify (Self); elsif Operation = "Handle" then declare use PolyORB.Any.NVList.Internals; use PolyORB.Any.NVList.Internals.NV_Lists; begin Handle (Self, Value (First (List_Of (Args).all)).Argument); end; end if; end Invoke; --------------------------- -- Get_Parameter_Profile -- --------------------------- function Get_Parameter_Profile (Method : String) return PolyORB.Any.NVList.Ref is Result : PolyORB.Any.NVList.Ref; begin PolyORB.Any.NVList.Create (Result); pragma Debug (C, O ("Parameter profile for " & Method & " requested.")); if Method = "Notify" then null; elsif Method = "Handle" then PolyORB.Any.NVList.Add_Item (Result, (Name => To_PolyORB_String ("Message"), Argument => PolyORB.Any.Get_Empty_Any (MOMA.Messages.TC_MOMA_Message), Arg_Modes => PolyORB.Any.ARG_IN)); else raise Program_Error; end if; return Result; end Get_Parameter_Profile; ------------ -- Handle -- ------------ procedure Handle (Self : access Object; Message : PolyORB.Any.Any) is Rcvd_Message : constant MOMA.Messages.Message'Class := MOMA.Messages.From_Any (Message); Handler_Procedure : constant MOMA.Message_Handlers.Handler := Get_Handler (Self.MOMA_Message_Handler); begin if Handler_Procedure /= null then Handler_Procedure.all (Self.MOMA_Message_Handler, Rcvd_Message); end if; end Handle; ------------ -- Notify -- ------------ procedure Notify (Self : access Object) is Notifier_Procedure : constant MOMA.Message_Handlers.Notifier := Get_Notifier (Self.MOMA_Message_Handler); begin if Notifier_Procedure /= null then Notifier_Procedure.all (Self.MOMA_Message_Handler); end if; end Notify; end PolyORB.MOMA_P.Provider.Message_Handler; polyorb-2.8~20110207.orig/src/moma/moma-references.adb0000644000175000017500000000674111750740340021652 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- M O M A . R E F E R E N C E S -- -- -- -- B o d y -- -- -- -- Copyright (C) 2004-2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with PolyORB.References.IOR; with PolyORB.Services.Naming.Tools; package body MOMA.References is ------------------------------- -- Initialize_Naming_Service -- ------------------------------- procedure Initialize_Naming_Service (Naming_Ref : Standard.String) is Ref : MOMA.Types.Ref; begin PolyORB.References.String_To_Object (Naming_Ref, Ref); PolyORB.Services.Naming.Tools.Init (Ref); end Initialize_Naming_Service; ------------------- -- Register_Name -- ------------------- procedure Register_Name (Name : String; Ref : MOMA.Types.Ref; Rebind : Boolean := False; Sep : Character := '/') renames PolyORB.Services.Naming.Tools.Register; ------------ -- Locate -- ------------ function Locate (IOR_Or_Name : String; Sep : Character := '/') return MOMA.Types.Ref renames PolyORB.Services.Naming.Tools.Locate; ----------------------------- -- Reference_To_IOR_String -- ----------------------------- function Reference_To_IOR_String (Ref : MOMA.Types.Ref) return Standard.String is begin return PolyORB.References.IOR.Object_To_String (Ref); end Reference_To_IOR_String; ------------------------- -- String_To_Reference -- ------------------------- procedure String_To_Reference (S : Standard.String; Ref : out MOMA.Types.Ref) renames PolyORB.References.String_To_Object; end MOMA.References; polyorb-2.8~20110207.orig/src/moma/moma-messages-mtexts.adb0000644000175000017500000000613211750740340022654 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- M O M A . M E S S A G E S . M T E X T S -- -- -- -- B o d y -- -- -- -- Copyright (C) 2002-2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with PolyORB.Types; package body MOMA.Messages.MTexts is -------------- -- Get_Text -- -------------- function Get_Text (Self : MText) return MOMA.Types.String is begin return MOMA.Types.String (PolyORB.Types.String'(PolyORB.Any.From_Any (Get_Payload (Self)))); end Get_Text; -------------- -- Set_Text -- -------------- procedure Set_Text (Self : in out MText; Value : MOMA.Types.String) is begin Set_Payload (Self, PolyORB.Any.To_Any (PolyORB.Types.String (Value))); end Set_Text; ------------------------- -- Create_Text_Message -- ------------------------- function Create_Text_Message return MText is Result : MText; begin Set_Type (Result, MOMA.Types.Text_M); Set_Default_Message_Header (Result); return Result; end Create_Text_Message; ----------- -- Image -- ----------- function Image (Self : MText) return String is begin return MOMA.Types.To_Standard_String (Get_Text (Self)); end Image; end MOMA.Messages.MTexts; polyorb-2.8~20110207.orig/src/moma/moma-message_handlers.adb0000644000175000017500000002415111750740340023030 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- M O M A . M E S S A G E _ H A N D L E R S -- -- -- -- B o d y -- -- -- -- Copyright (C) 2002-2008, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with MOMA.Destinations; with MOMA.Runtime; with PolyORB.Any.NVList; with PolyORB.Errors; with PolyORB.Log; with PolyORB.Minimal_Servant.Tools; with PolyORB.MOMA_P.Exceptions; with PolyORB.MOMA_P.Provider.Message_Handler; with PolyORB.References; with PolyORB.Requests; with PolyORB.Types; package body MOMA.Message_Handlers is use MOMA.Messages; use MOMA.Message_Consumers; use MOMA.Destinations; use PolyORB.Annotations; use PolyORB.Any; use PolyORB.Any.NVList; use PolyORB.Log; use PolyORB.Minimal_Servant.Tools; use PolyORB.Types; use PolyORB.Requests; package L is new PolyORB.Log.Facility_Log ("moma.message_handlers"); procedure O (Message : Standard.String; Level : Log_Level := Debug) renames L.Output; function C (Level : Log_Level := Debug) return Boolean renames L.Enabled; procedure Register_To_Servant (Self : access Message_Handler); -- Register the Message_Handler or change the Behavior, -- via a Request to the actual servant. -------------------- -- Create_Handler -- -------------------- function Create_Handler (Session : MOMA.Sessions.Session; Message_Cons : MOMA.Message_Consumers.Message_Consumer_Acc; Notifier_Procedure : Notifier := null; Handler_Procedure : Handler := null; Behavior : MOMA.Types.Call_Back_Behavior := None) return MOMA.Message_Handlers.Message_Handler_Acc is pragma Warnings (Off); pragma Unreferenced (Session); pragma Warnings (On); -- XXX Session is to be used to 'place' the receiver -- using session position in the POA. use PolyORB.Errors; Self : constant MOMA.Message_Handlers.Message_Handler_Acc := new MOMA.Message_Handlers.Message_Handler; Servant : constant PolyORB.MOMA_P.Provider.Message_Handler.Object_Acc := new PolyORB.MOMA_P.Provider.Message_Handler.Object; Servant_Ref : PolyORB.References.Ref; Error : Error_Container; begin Initiate_Servant (Servant, MOMA.Runtime.MOMA_OA, PolyORB.Types.String (MOMA.Types.MOMA_Type_Id), Servant_Ref, Error); if Found (Error) then PolyORB.MOMA_P.Exceptions.Raise_From_Error (Error); end if; PolyORB.MOMA_P.Provider.Message_Handler.Initialize (Servant, Self); Self.Message_Cons := Message_Cons; Self.Servant_Ref := Servant_Ref; Self.Handler_Procedure := Handler_Procedure; Self.Notifier_Procedure := Notifier_Procedure; Self.Behavior := Behavior; if Behavior /= None then Register_To_Servant (Self); end if; return Self; end Create_Handler; ------------------------ -- Get_Call_Back_Data -- ------------------------ procedure Get_Call_Back_Data (Self : access Message_Handler; Data : out PolyORB.Annotations.Note'Class) is begin Get_Note (Self.Call_Back_Data, Data); end Get_Call_Back_Data; ------------------ -- Get_Consumer -- ------------------ function Get_Consumer (Self : access Message_Handler) return MOMA.Message_Consumers.Message_Consumer is begin return Self.Message_Cons.all; end Get_Consumer; ----------------- -- Get_Handler -- ----------------- function Get_Handler (Self : access Message_Handler) return Handler is begin return Self.Handler_Procedure; end Get_Handler; ------------------ -- Get_Notifier -- ------------------ function Get_Notifier (Self : access Message_Handler) return Notifier is begin return Self.Notifier_Procedure; end Get_Notifier; ------------------------- -- Register_To_Servant -- ------------------------- procedure Register_To_Servant (Self : access Message_Handler) is Request : PolyORB.Requests.Request_Access; Arg_List : PolyORB.Any.NVList.Ref; Result : PolyORB.Any.NamedValue; Servant_Ref : PolyORB.References.Ref; Self_Dest : constant MOMA.Destinations.Destination := MOMA.Destinations.Create_Destination (To_PolyORB_String (""), Self.Servant_Ref); begin pragma Debug (C, O ("Registering Message_Handler with " & Call_Back_Behavior'Image (Self.Behavior) & " behavior")); if Self.Message_Cons /= null then Servant_Ref := MOMA.Message_Consumers.Get_Ref (Self.Message_Cons.all); PolyORB.Any.NVList.Create (Arg_List); PolyORB.Any.NVList.Add_Item (Arg_List, To_PolyORB_String ("Message_Handler"), To_Any (Self_Dest), PolyORB.Any.ARG_IN); PolyORB.Any.NVList.Add_Item (Arg_List, To_PolyORB_String ("Behavior"), PolyORB.Any.To_Any (To_PolyORB_String (Call_Back_Behavior'Image (Self.Behavior))), PolyORB.Any.ARG_IN); Result := (Name => To_PolyORB_String ("Result"), Argument => PolyORB.Any.Get_Empty_Any (TypeCode.TC_Void), Arg_Modes => 0); PolyORB.Requests.Create_Request (Target => Servant_Ref, Operation => "Register_Handler", Arg_List => Arg_List, Result => Result, Req => Request); PolyORB.Requests.Invoke (Request); pragma Debug (C, O ("Register_Handler request complete")); PolyORB.Requests.Destroy_Request (Request); pragma Debug (C, O ("Register_Handler request destroyed")); end if; end Register_To_Servant; ------------------ -- Set_Behavior -- ------------------ procedure Set_Behavior (Self : access Message_Handler; New_Behavior : MOMA.Types.Call_Back_Behavior) is Previous_Behavior : constant MOMA.Types.Call_Back_Behavior := Self.Behavior; begin if New_Behavior /= Previous_Behavior then Self.Behavior := New_Behavior; Register_To_Servant (Self); end if; end Set_Behavior; ------------------------ -- Set_Call_Back_Data -- ------------------------ procedure Set_Call_Back_Data (Self : access Message_Handler; Data : PolyORB.Annotations.Note'Class) is begin Set_Note (Self.Call_Back_Data, Data); end Set_Call_Back_Data; ----------------- -- Set_Handler -- ----------------- procedure Set_Handler (Self : access Message_Handler; New_Handler_Procedure : Handler; Handle_Behavior : Boolean := False) is begin Self.Handler_Procedure := New_Handler_Procedure; if Handle_Behavior then Set_Behavior (Self, Handle); end if; end Set_Handler; ------------------ -- Set_Notifier -- ------------------ procedure Set_Notifier (Self : access Message_Handler; New_Notifier_Procedure : Notifier; Notify_Behavior : Boolean := False) is begin Self.Notifier_Procedure := New_Notifier_Procedure; if Notify_Behavior then Set_Behavior (Self, Notify); end if; end Set_Notifier; ---------------------- -- Template_Handler -- ---------------------- procedure Template_Handler (Self : access Message_Handler; Message : MOMA.Messages.Message'Class) is Id : constant String := MOMA.Types.To_Standard_String (MOMA.Messages.Get_Message_Id (Message)); begin pragma Debug (C, O ("Message_Handler is handling message")); if Id = "Stop handling messages" then Set_Behavior (Self, None); end if; -- XXX Why is this in the Message_Id ????? end Template_Handler; ----------------------- -- Template_Notifier -- ----------------------- procedure Template_Notifier (Self : access Message_Handler) is pragma Warnings (Off); pragma Unreferenced (Self); pragma Warnings (On); begin pragma Debug (C, O ("Message_Handler is being notified of a message")); null; end Template_Notifier; end MOMA.Message_Handlers; polyorb-2.8~20110207.orig/src/moma/moma-messages-mmaps.adb0000644000175000017500000000564011750740340022450 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- M O M A . M E S S A G E S . M M A P S -- -- -- -- B o d y -- -- -- -- Copyright (C) 2002-2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ package body MOMA.Messages.MMaps is -------------- -- Get_Map -- -------------- function Get_Map (Self : MMap) return MOMA.Types.Map is begin return MOMA.Types.From_Any (Get_Payload (Self)); end Get_Map; -------------- -- Set_Map -- -------------- procedure Set_Map (Self : in out MMap; Value : MOMA.Types.Map) is begin Set_Payload (Self, MOMA.Types.To_Any (Value)); end Set_Map; ------------------------- -- Create_Map_Message -- ------------------------- function Create_Map_Message return MMap is Result : MMap; begin Set_Type (Result, MOMA.Types.Map_M); Set_Default_Message_Header (Result); return Result; end Create_Map_Message; ----------- -- Image -- ----------- function Image (Self : MMap) return String is begin return Image (Get_Payload (Self)); end Image; end MOMA.Messages.MMaps; polyorb-2.8~20110207.orig/src/moma/moma-message_handlers.ads0000644000175000017500000001510111750740340023044 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- M O M A . M E S S A G E _ H A N D L E R S -- -- -- -- S p e c -- -- -- -- Copyright (C) 2002-2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- A Message_Handler object is the client view of the message handling -- process. It is the facade used to define the callback behavior and -- procedures, and provides templates ; it contains the stub to access -- Message_Handler servants (see MOMA.Provider for more details). -- NOTE: A MOMA client must use only this package to get a callback for the -- messages it receives. with MOMA.Messages; with MOMA.Message_Consumers; with MOMA.Sessions; with MOMA.Types; with PolyORB.Annotations; package MOMA.Message_Handlers is use MOMA.Types; type Message_Handler is private; -- Self_Ref is the reference to the Message_Handler Servant. -- Message_Cons is the Message_Consumer associated to the Message_Handler. -- Behavior is the callback behavior, which changes are passed to the -- Message_Consumer actual servant. -- Handler_Procedure is the procedure called when a message is received by -- the Message_Consumer actual Servant when the behavior is Handle. -- Notifier_Procedure is the procedure called when a message is received -- by the Message_Consumer actual Servant when the behavior is Notify. -- Call_Back_Data contains callback data in the form of Notes than can be -- set by the client. The actual type of Notes is up to the client. type Message_Handler_Acc is access Message_Handler; type Handler is access procedure (Self : access Message_Handler; Message : MOMA.Messages.Message'Class); -- The procedure to be called when a message is received, if the behavior -- is Handle. type Notifier is access procedure (Self : access Message_Handler); -- The procedure to be called when a message is received, if the behavior -- is Notify. function Create_Handler (Session : MOMA.Sessions.Session; Message_Cons : MOMA.Message_Consumers.Message_Consumer_Acc; Notifier_Procedure : Notifier := null; Handler_Procedure : Handler := null; Behavior : MOMA.Types.Call_Back_Behavior := None) return MOMA.Message_Handlers.Message_Handler_Acc; -- Create a Message Handler associated to the specified Message consumer. -- If the behavior is Handle and no Handler_Procedure is provided, the -- incoming messages will be lost. procedure Get_Call_Back_Data (Self : access Message_Handler; Data : out PolyORB.Annotations.Note'Class); -- Retrieve Call_Back Data for use in Handler or Notifier procedure. function Get_Consumer (Self : access Message_Handler) return MOMA.Message_Consumers.Message_Consumer; function Get_Handler (Self : access Message_Handler) return Handler; -- Get the Handler procedure. function Get_Notifier (Self : access Message_Handler) return Notifier; -- Get the Notifier procedure. procedure Set_Behavior (Self : access Message_Handler; New_Behavior : MOMA.Types.Call_Back_Behavior); -- Set the Behavior. A request is sent to the actual servant if the -- behavior has changed. procedure Set_Call_Back_Data (Self : access Message_Handler; Data : PolyORB.Annotations.Note'Class); -- Set Call_Back Data for use in Handler or Notifier procedure. procedure Set_Handler (Self : access Message_Handler; New_Handler_Procedure : Handler; Handle_Behavior : Boolean := False); -- Associate a Handler procedure to the Message Handler. -- Replace the current Handler procedure. -- The behavior is set to Handle if Handle_Behavior is true. procedure Set_Notifier (Self : access Message_Handler; New_Notifier_Procedure : Notifier; Notify_Behavior : Boolean := False); -- Associate a Notifier procedure to the Message Handler. -- Replace the current Handler procedure. -- The behavior is set to Handle if Notify_Behavior is true. procedure Template_Handler (Self : access Message_Handler; Message : MOMA.Messages.Message'Class); procedure Template_Notifier (Self : access Message_Handler); -- Templates for handler and notifier procedures. private type Message_Handler is record Servant_Ref : MOMA.Types.Ref; Message_Cons : MOMA.Message_Consumers.Message_Consumer_Acc; Handler_Procedure : Handler := null; Notifier_Procedure : Notifier := null; Behavior : MOMA.Types.Call_Back_Behavior := None; Call_Back_Data : aliased PolyORB.Annotations.Notepad; end record; end MOMA.Message_Handlers; polyorb-2.8~20110207.orig/src/moma/polyorb-moma_p-provider-warehouse.ads0000644000175000017500000001020211750740340025372 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . M O M A _ P . P R O V I D E R . W A R E H O U S E -- -- -- -- S p e c -- -- -- -- Copyright (C) 2002-2003 Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by ACT Europe. -- -- (email: sales@act-europe.fr) -- -- -- ------------------------------------------------------------------------------ -- A dynamic, protected dictionary of Any, indexed by Strings. It is used -- as a placeholder for received messages. with PolyORB.Any; with PolyORB.Tasking.Rw_Locks; with PolyORB.Utils.HFunctions.Hyper; with PolyORB.Utils.HTables.Perfect; with MOMA.Types; package PolyORB.MOMA_P.Provider.Warehouse is Key_Not_Found : exception; type Warehouse is private; procedure Register (W : in out Warehouse; K : String; V : PolyORB.Any.Any); -- Associate key K with value V. procedure Unregister (W : in out Warehouse; K : String); -- Remove any association for K. Key_Not_Found is raised -- if no value was registered for this key. function Lookup (W : Warehouse; K : String) return PolyORB.Any.Any; -- Lookup K in the dictionary, and return the associated value. -- Key_Not_Found is raised if no value was registered for this -- key. function Lookup (W : Warehouse; K : String; Default : PolyORB.Any.Any) return PolyORB.Any.Any; -- As above, but Default is returned for non-registered keys, -- instead of raising an exception. procedure Set_Persistence (W : in out Warehouse; Persistence : MOMA.Types.Persistence_Mode); -- Set persistency flag for this warehouse, -- Note : this overrides any flag set for a message if set to a mode -- allowing persistence. -- XXX Warning : not safe in case of multiple message pools !!!! private package Perfect_Htable is new PolyORB.Utils.HTables.Perfect (PolyORB.Any.Any, PolyORB.Utils.HFunctions.Hyper.Hash_Hyper_Parameters, PolyORB.Utils.HFunctions.Hyper.Default_Hash_Parameters, PolyORB.Utils.HFunctions.Hyper.Hash, PolyORB.Utils.HFunctions.Hyper.Next_Hash_Parameters); use Perfect_Htable; type Warehouse is record T : Table_Instance; T_Initialized : Boolean := False; T_Persistence : MOMA.Types.Persistence_Mode := MOMA.Types.None; T_Lock : PolyORB.Tasking.Rw_Locks.Rw_Lock_Access; end record; end PolyORB.MOMA_P.Provider.Warehouse; polyorb-2.8~20110207.orig/src/moma/moma-connection_factories.ads0000644000175000017500000000556011750740340023746 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- M O M A . C O N N E C T I O N _ F A C T O R I E S -- -- -- -- S p e c -- -- -- -- Copyright (C) 2002-2004 Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by ACT Europe. -- -- (email: sales@act-europe.fr) -- -- -- ------------------------------------------------------------------------------ -- A Connection_Factory contains all information to create a connection to -- the MOMA provider. -- XXX need to clarify the notion of provider. with MOMA.Types; package MOMA.Connection_Factories is type Connection_Factory is private; procedure Create (Self : out Connection_Factory; Remote : MOMA.Types.Ref); -- Create a new connection factory, with the provider Remote. -- Accessors to the Connection_Factory internals. procedure Set_Ref (Self : in out Connection_Factory; Remote : MOMA.Types.Ref); function Get_Ref (Self : Connection_Factory) return MOMA.Types.Ref; private type Connection_Factory is record Remote : MOMA.Types.Ref; -- The access point to the MOMA domain. -- XXX : this is a concept to clarify. end record; end MOMA.Connection_Factories; polyorb-2.8~20110207.orig/src/moma/moma-messages-mexecutes.adb0000644000175000017500000000603411750740340023333 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- M O M A . M E S S A G E S . M E X E C U T E S -- -- -- -- B o d y -- -- -- -- Copyright (C) 2002-2003 Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by ACT Europe. -- -- (email: sales@act-europe.fr) -- -- -- ------------------------------------------------------------------------------ with MOMA.Types; package body MOMA.Messages.MExecutes is ------------------- -- Get_Parameter -- ------------------- function Get_Parameter (Self : MExecute) return MOMA.Types.Map is begin return MOMA.Types.From_Any (Get_Payload (Self)); end Get_Parameter; ------------------- -- Set_Parameter -- ------------------- procedure Set_Parameter (Self : in out MExecute; Value : MOMA.Types.Map) is begin Set_Payload (Self, MOMA.Types.To_Any (Value)); end Set_Parameter; ---------------------------- -- Create_Execute_Message -- ---------------------------- function Create_Execute_Message return MExecute is Result : MExecute; begin Set_Type (Result, MOMA.Types.Execute_M); Set_Default_Message_Header (Result); return Result; end Create_Execute_Message; ----------- -- Image -- ----------- function Image (Self : MExecute) return String is begin return Image (Get_Payload (Self)); end Image; end MOMA.Messages.MExecutes; polyorb-2.8~20110207.orig/src/moma/polyorb-moma_p-provider-message_pool.adb0000644000175000017500000003235411750740340026040 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- POLYORB.MOMA_P.PROVIDER.MESSAGE_POOL -- -- -- -- B o d y -- -- -- -- Copyright (C) 2002-2008, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- Message_Pool servant. with MOMA.Destinations; with MOMA.Messages; with PolyORB.Any.NVList; with PolyORB.Errors; with PolyORB.Log; with PolyORB.Types; package body PolyORB.MOMA_P.Provider.Message_Pool is use MOMA.Messages; use PolyORB.Any; use PolyORB.Any.NVList; use PolyORB.Log; use PolyORB.Requests; use PolyORB.Types; package L is new PolyORB.Log.Facility_Log ("moma.provider.message_pool"); procedure O (Message : Standard.String; Level : Log_Level := Debug) renames L.Output; function C (Level : Log_Level := Debug) return Boolean renames L.Enabled; -- Actual functions implemented by the servant. procedure Publish (Self : access Object; Message : PolyORB.Any.Any); function Get (Self : access Object; Message_Id : MOMA.Types.String) return PolyORB.Any.Any; procedure Register_Handler (Self : access Object; Handler_Ref : PolyORB.References.Ref; Behavior : MOMA.Types.Call_Back_Behavior); -- Accessors to servant interface. function Get_Parameter_Profile (Method : String) return PolyORB.Any.NVList.Ref; -- Parameters part of the interface description. Message_S : constant PolyORB.Types.Identifier := To_PolyORB_String ("Message"); Message_Id_S : constant PolyORB.Types.Identifier := To_PolyORB_String ("Message_Id"); Message_Handler_S : constant PolyORB.Types.Identifier := To_PolyORB_String ("Message_Handler"); Behavior_S : constant PolyORB.Types.Identifier := To_PolyORB_String ("Behavior"); Result_S : constant PolyORB.Types.Identifier := To_PolyORB_String ("Result"); ------------ -- Invoke -- ------------ procedure Invoke (Self : access Object; Req : PolyORB.Requests.Request_Access) is Args : PolyORB.Any.NVList.Ref; use PolyORB.Any.NVList.Internals; use PolyORB.Any.NVList.Internals.NV_Lists; use PolyORB.Errors; Error : Error_Container; begin pragma Debug (C, O ("The server is executing the request:" & PolyORB.Requests.Image (Req.all))); Create (Args); if Req.Operation.all = "Publish" then -- Publish Add_Item (Args, (Name => Message_S, Argument => Get_Empty_Any (TC_MOMA_Message), Arg_Modes => PolyORB.Any.ARG_IN)); Arguments (Req, Args, Error); if Found (Error) then raise Program_Error; -- XXX We should do something more contructive end if; Publish (Self, Value (First (List_Of (Args).all)).Argument); elsif Req.Operation.all = "Get" then -- Get Add_Item (Args, (Name => Message_Id_S, Argument => Get_Empty_Any (TypeCode.TC_String), Arg_Modes => PolyORB.Any.ARG_IN)); Arguments (Req, Args, Error); if Found (Error) then raise Program_Error; -- XXX We should do something more contructive end if; Req.Result.Argument := Get (Self, MOMA.Types.String (PolyORB.Types.String' (PolyORB.Any.From_Any (Value (First (List_Of (Args).all)).Argument)))); pragma Debug (C, O ("Result: " & Image (Req.Result))); elsif Req.Operation.all = "Register_Handler" then -- Register Message call_back handler pragma Debug (C, O ("Register_Handler request")); Args := Get_Parameter_Profile (Req.Operation.all); PolyORB.Requests.Arguments (Req, Args, Error); if Found (Error) then raise Program_Error; -- XXX We should do something more contructive end if; declare It : Iterator := First (List_Of (Args).all); Handler_Dest, Behavior : Element_Access; begin Handler_Dest := Value (It); Next (It); Behavior := Value (It); Register_Handler (Self, MOMA.Destinations.Get_Ref (MOMA.Destinations.From_Any (Handler_Dest.Argument)), MOMA.Types.Call_Back_Behavior'Value (MOMA.Types.To_Standard_String (MOMA.Types.From_Any (Behavior.Argument)))); pragma Debug (C, O ("Registered message handler")); end; else pragma Debug (C, O ("Unrecognized request " & Req.Operation.all)); raise Program_Error; end if; end Invoke; --------------------------- -- Get_Parameter_Profile -- --------------------------- function Get_Parameter_Profile (Method : String) return PolyORB.Any.NVList.Ref is Result : PolyORB.Any.NVList.Ref; begin PolyORB.Any.NVList.Create (Result); pragma Debug (C, O ("Parameter profile for " & Method & " requested.")); if Method = "Publish" then Add_Item (Result, (Name => Message_S, Argument => Get_Empty_Any (TC_MOMA_Message), Arg_Modes => ARG_IN)); elsif Method = "Get" then Add_Item (Result, (Name => Message_Id_S, Argument => Get_Empty_Any (TypeCode.TC_String), Arg_Modes => ARG_IN)); elsif Method = "Register_Handler" then Add_Item (Result, (Name => Message_Handler_S, Argument => Get_Empty_Any (MOMA.Destinations.TC_MOMA_Destination), Arg_Modes => ARG_IN)); Add_Item (Result, (Name => Behavior_S, Argument => Get_Empty_Any (TypeCode.TC_String), Arg_Modes => ARG_IN)); else raise Program_Error; end if; return Result; end Get_Parameter_Profile; ------------------------------ -- Servant actual functions -- ------------------------------ ---------------- -- Initialize -- ---------------- procedure Initialize (Self : access Object; Info : MOMA.Types.Message_Pool) is begin Self.Pool := Info; PolyORB.MOMA_P.Provider.Warehouse.Set_Persistence (Self.W, MOMA.Types.Get_Persistence (Info)); end Initialize; ------------- -- Publish -- ------------- procedure Publish (Self : access Object; Message : PolyORB.Any.Any) is Temp : constant String := Integer'Image (Self.Message_Id); Key : constant String := "M" & Temp (2 .. Temp'Last); -- Dummy Key construction, should be analyzed from message Rcvd_Message : constant MOMA.Messages.Message'Class := From_Any (Message); Id : constant String := MOMA.Types.To_Standard_String (Get_Message_Id (Rcvd_Message)); begin if Self.Behavior = Handle and then not PolyORB.References.Is_Nil (Self.Message_Handler) then -- Send the message to the Message Call_Back Handler. -- Do not store the message locally. pragma Debug (C, O ("Got new message " & Image (Message) & " with Id " & Key & ", forwarding to Message_" & "Handler with Handle request")); declare Request : PolyORB.Requests.Request_Access; Arg_List : PolyORB.Any.NVList.Ref; Result : PolyORB.Any.NamedValue; begin PolyORB.Any.NVList.Create (Arg_List); PolyORB.Any.NVList.Add_Item (Arg_List, Message_S, Message, PolyORB.Any.ARG_IN); Result := (Name => Result_S, Argument => PolyORB.Any.Get_Empty_Any (PolyORB.Any.TC_Void), Arg_Modes => 0); PolyORB.Requests.Create_Request (Target => Self.Message_Handler, Operation => "Handle", Arg_List => Arg_List, Result => Result, Req => Request); PolyORB.Requests.Invoke (Request); PolyORB.Requests.Destroy_Request (Request); end; else if Id = "moma" then pragma Debug (C, O ("Got new message " & Image (Message) & " with Id " & Key)); Self.Message_Id := Self.Message_Id + 1; PolyORB.MOMA_P.Provider.Warehouse.Register (Self.W, Key, Message); else pragma Debug (C, O ("Got new message " & Image (Message) & " with Id " & Id)); PolyORB.MOMA_P.Provider.Warehouse.Register (Self.W, Id, Message); end if; if Self.Behavior = Notify and then not PolyORB.References.Is_Nil (Self.Message_Handler) then pragma Debug (C, O ("Forwarding to Message_Handler" & " with Notify request")); -- Notify call_back Handler. -- The Message is stored locally. declare Request : PolyORB.Requests.Request_Access; Arg_List : PolyORB.Any.NVList.Ref; Result : PolyORB.Any.NamedValue; begin PolyORB.Any.NVList.Create (Arg_List); Result := (Name => Result_S, Argument => PolyORB.Any.Get_Empty_Any (PolyORB.Any.TC_Void), Arg_Modes => 0); PolyORB.Requests.Create_Request (Target => Self.Message_Handler, Operation => "Notify", Arg_List => Arg_List, Result => Result, Req => Request); PolyORB.Requests.Invoke (Request); PolyORB.Requests.Destroy_Request (Request); end; end if; end if; end Publish; --------- -- Get -- --------- function Get (Self : access Object; Message_Id : MOMA.Types.String) return PolyORB.Any.Any is Result : PolyORB.Any.Any; Temp : constant String := Integer'Image (Self.Last_Read_Id); Key : constant String := "M" & Temp (2 .. Temp'Last); Id : constant String := MOMA.Types.To_Standard_String (Message_Id); begin if Id = "" then Result := PolyORB.MOMA_P.Provider.Warehouse.Lookup (Self.W, Key); PolyORB.MOMA_P.Provider.Warehouse.Unregister (Self.W, Key); Self.Last_Read_Id := Self.Last_Read_Id + 1; pragma Debug (C, O ("Sending back message " & Image (Result) & " with id " & Key)); else Result := PolyORB.MOMA_P.Provider.Warehouse.Lookup (Self.W, Key); pragma Debug (C, O ("Sending back message " & Image (Result) & " with id " & Key)); end if; return Result; end Get; ---------------------- -- Register_Handler -- ---------------------- procedure Register_Handler (Self : access Object; Handler_Ref : PolyORB.References.Ref; Behavior : MOMA.Types.Call_Back_Behavior) is begin Self.Message_Handler := Handler_Ref; Self.Behavior := Behavior; end Register_Handler; end PolyORB.MOMA_P.Provider.Message_Pool; polyorb-2.8~20110207.orig/src/moma/consumer.conf0000644000175000017500000000032411750740340020623 0ustar xavierxavier[consumer] #server_ior=1234 log=true # log = true | false log-level=1 # log-level = 1 .. 3 default_username=John_Doe default-password=plop default-time-to-live=42 default-priority=1 default-persistence=false polyorb-2.8~20110207.orig/src/moma/moma-configuration-server.adb0000644000175000017500000001062511750740340023700 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- M O M A . C O N F I G U R A T I O N . S E R V E R -- -- -- -- B o d y -- -- -- -- Copyright (C) 2002-2008, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with MOMA.Runtime; with PolyORB.MOMA_P.Provider.Message_Pool; with PolyORB.MOMA_P.Provider.Routers; with PolyORB.Errors; with PolyORB.Log; with PolyORB.Minimal_Servant.Tools; with PolyORB.MOMA_P.Exceptions; with PolyORB.Types; package body MOMA.Configuration.Server is use PolyORB.Errors; use PolyORB.Log; use PolyORB.Minimal_Servant.Tools; use MOMA.Types; package L is new PolyORB.Log.Facility_Log ("moma.configuration.server"); procedure O (Message : Standard.String; Level : Log_Level := Debug) renames L.Output; function C (Level : Log_Level := Debug) return Boolean renames L.Enabled; ------------------------- -- Create_Message_Pool -- ------------------------- procedure Create_Message_Pool (Pool : MOMA.Types.Message_Pool; Ref : out MOMA.Types.Ref) is MOMA_Obj : constant PolyORB.MOMA_P.Provider.Message_Pool.Object_Acc := new PolyORB.MOMA_P.Provider.Message_Pool.Object; Error : Error_Container; begin pragma Debug (C, O ("Creating Message Pool " & To_Standard_String (Get_Name (Pool)))); Initiate_Servant (MOMA_Obj, MOMA.Runtime.MOMA_OA, PolyORB.Types.String (MOMA_Type_Id), Ref, Error); if Found (Error) then PolyORB.MOMA_P.Exceptions.Raise_From_Error (Error); end if; PolyORB.MOMA_P.Provider.Message_Pool.Initialize (MOMA_Obj, Pool); end Create_Message_Pool; ------------------- -- Create_Router -- ------------------- procedure Create_Router (Id : MOMA.Types.String; Ref : out MOMA.Types.Ref; Router_Ref : MOMA.Types.Ref := MOMA.Types.Nil_Ref) is Router : constant PolyORB.MOMA_P.Provider.Routers.Router_Acc := new PolyORB.MOMA_P.Provider.Routers.Router; Error : Error_Container; begin pragma Debug (C, O ("Creating Router")); Initiate_Servant (Router, MOMA.Runtime.MOMA_OA, PolyORB.Types.String (MOMA_Type_Id), Ref, Error); if Found (Error) then PolyORB.MOMA_P.Exceptions.Raise_From_Error (Error); end if; PolyORB.MOMA_P.Provider.Routers.Set_Id (Router.all, Id); PolyORB.MOMA_P.Provider.Routers.Set_Self_Ref (Router.all, Ref); PolyORB.MOMA_P.Provider.Routers.Initialize (Router, Router_Ref); end Create_Router; end MOMA.Configuration.Server; polyorb-2.8~20110207.orig/src/moma/moma-connections.ads0000644000175000017500000000733211750740340022071 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- M O M A . C O N N E C T I O N S -- -- -- -- S p e c -- -- -- -- Copyright (C) 2002-2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- A Connection provides access to the provider for the client. with MOMA.Connection_Factories; with MOMA.Types; package MOMA.Connections is type Connection is private; -- Client_Id : Id of the MOMA client. -- Ref : Reference. procedure Close; -- Close the connection. function Create_Connection (Factory : MOMA.Connection_Factories.Connection_Factory) return Connection; -- Create a new connection using this connection factory. function Create_Connection (Factory : MOMA.Connection_Factories.Connection_Factory; Username : String; Password : String) return Connection; -- Create a new connection using this connection factory -- and providing a username/password. -- XXX Not implemented. -- Accessors to Connection internal data. function Get_Client_Id (Self : Connection) return MOMA.Types.String; procedure Set_Client_Id (Self : in out Connection; Client_Id : MOMA.Types.String); function Get_Ref (Self : Connection) return MOMA.Types.Ref; procedure Set_Ref (Self : in out Connection; Ref : MOMA.Types.Ref); procedure Start; -- Start the connection, i.e activate all rattached message producers -- and consumers. -- XXX to be implemented. procedure Stop; -- Stop the connection, i.e desactivate all rattached message producers -- and consumers. -- XXX to be implemented. -- XXX check the conformance and pertinence of the above spec. function Get_Meta_Data return MOMA.Types.Meta_Data; private type Connection is record Client_Id : MOMA.Types.String; Ref : MOMA.Types.Ref; end record; end MOMA.Connections; polyorb-2.8~20110207.orig/src/moma/polyorb-moma_p-exceptions.ads0000644000175000017500000000454711750740340023740 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . M O M A _ P . E X C E P T I O N S -- -- -- -- S p e c -- -- -- -- Copyright (C) 2003-2005 Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- Errors management for the MOMA Application Personality of PolyORB. with PolyORB.Errors; package PolyORB.MOMA_P.Exceptions is procedure Raise_From_Error (Error : in out PolyORB.Errors.Error_Container); pragma No_Return (Raise_From_Error); -- Raise a MOMA specific exception from the data in 'Error' end PolyORB.MOMA_P.Exceptions; polyorb-2.8~20110207.orig/src/moma/polyorb-moma_p-provider-message_handler.ads0000644000175000017500000000651511750740340026525 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- POLYORB.MOMA_P.PROVIDER.MESSAGE_HANDLER -- -- -- -- S p e c -- -- -- -- Copyright (C) 2002-2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- Actual implementation of the Message_Handler object. -- It is derived from PolyORB's Minimal_Servant. -- The call-back purpose of a Message Handler is to receive a Request from -- the actual message consumer servant when a message is received : this -- Request can either be Handle (then the message can not be recovered by a -- call to the Message_Consumer's Receive and has to be treated by the Handle -- procedure), or Notify (then the message stays in the pool). with MOMA.Message_Handlers; with PolyORB.Minimal_Servant; with PolyORB.Requests; package PolyORB.MOMA_P.Provider.Message_Handler is type Object is new PolyORB.Minimal_Servant.Servant with private; type Object_Acc is access Object; procedure Invoke (Self : access Object; Req : PolyORB.Requests.Request_Access); -- Message_Handler servant skeleton. procedure Initialize (Self : access Object; MOMA_Message_Handler : MOMA.Message_Handlers.Message_Handler_Acc); -- Initialize with MOMA_Message_Handler. -- Should be called after Initiate_Servant. -- Should be called only once. private type Object is new PolyORB.Minimal_Servant.Servant with record MOMA_Message_Handler : MOMA.Message_Handlers.Message_Handler_Acc := null; end record; end PolyORB.MOMA_P.Provider.Message_Handler; polyorb-2.8~20110207.orig/src/moma/polyorb-moma_p-provider-message_consumer.ads0000644000175000017500000000621411750740340026737 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- POLYORB.MOMA_P.PROVIDER.MESSAGE_CONSUMER -- -- -- -- S p e c -- -- -- -- Copyright (C) 2002-2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- Actual implementation of the Message_Consumer object. It is -- derived from PolyORB's Minimal_Servant. This package contains -- Message_Consumer skeleton and implementation subroutines. By -- construction, its implementation subroutines contain parts of a -- stub for the Message_Pool object. with PolyORB.Minimal_Servant; with PolyORB.Requests; with PolyORB.References; package PolyORB.MOMA_P.Provider.Message_Consumer is type Object is new PolyORB.Minimal_Servant.Servant with private; -- Remote_Ref : Reference to the pool from which receive messages. type Object_Acc is access Object; procedure Invoke (Self : access Object; Req : PolyORB.Requests.Request_Access); -- Message_Consumer servant skeleton. -- Accessors to Object internals. function Get_Remote_Ref (Self : Object) return PolyORB.References.Ref; procedure Set_Remote_Ref (Self : in out Object; Ref : PolyORB.References.Ref); private type Object is new PolyORB.Minimal_Servant.Servant with record Remote_Ref : PolyORB.References.Ref; end record; end PolyORB.MOMA_P.Provider.Message_Consumer; polyorb-2.8~20110207.orig/src/moma/moma-runtime.adb0000644000175000017500000000477411750740340021220 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- M O M A . R U N T I M E -- -- -- -- B o d y -- -- -- -- Copyright (C) 2004-2005 Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with PolyORB.Initialization; with PolyORB.Minimal_Servant.Tools; with PolyORB.ORB; with PolyORB.Setup; package body MOMA.Runtime is ---------------- -- Initialize -- ---------------- procedure Initialize is begin PolyORB.Initialization.Initialize_World; MOMA_OA := PolyORB.ORB.Object_Adapter (PolyORB.Setup.The_ORB); end Initialize; ----------- -- Start -- ----------- procedure Start renames PolyORB.Minimal_Servant.Tools.Run_Server; end MOMA.Runtime; polyorb-2.8~20110207.orig/src/moma/moma-destinations.ads0000644000175000017500000001056011750740340022250 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- M O M A . D E S T I N A T I O N S -- -- -- -- S p e c -- -- -- -- Copyright (C) 2002-2007, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- A Destination contains data to reference an object to which messages -- can be sent, or from which messages can be retrieved. with MOMA.Types; with PolyORB.Any; package MOMA.Destinations is type Destination is private; -- Name : Logical name of the destination. When Kind is set to Topic, Name -- must be set to the Topic_Id. -- Ref : Reference to the actual destination object. -- Kind : The kind of object it is really (message pool, router, ...). function Create_Destination (Name : MOMA.Types.String; Ref : MOMA.Types.Ref; Kind : MOMA.Types.Destination_Type := MOMA.Types.Unknown) return Destination; -- Create a destination structure. function "=" (Dest1 : Destination; Dest2 : Destination) return Boolean; -- Compare two destinations. -- XXX Comparison is made only on the name. function Create_Destination return Destination; -- Create an empty destination structure. function Create_Temporary return Destination; -- Create a temporary destination -- XXX Not implemented. function Image (Self : Destination) return String; -- Image function for destination type. -- Accessors to Destination internal data. function Get_Name (Self : Destination) return MOMA.Types.String; procedure Set_Name (Self : in out Destination; Name : MOMA.Types.String); function Get_Kind (Self : Destination) return MOMA.Types.Destination_Type; function Get_Ref (Self : Destination) return MOMA.Types.Ref; -- XXX should be restricted to internal use only ... procedure Set_Ref (Self : in out Destination; Ref : MOMA.Types.Ref); -- XXX should be restricted to internal use only ... -- Marshalling support for Destination type. TC_MOMA_Destination : PolyORB.Any.TypeCode.Local_Ref; function To_Any (Self : Destination) return MOMA.Types.Any; function From_Any (Self : MOMA.Types.Any) return Destination; procedure Delete; -- XXX really useful in this context ? private type Destination is record Name : MOMA.Types.String; Ref : MOMA.Types.Ref; Kind : MOMA.Types.Destination_Type; end record; pragma Inline (Get_Name); pragma Inline (Set_Name); pragma Inline (Get_Ref); pragma Inline (Set_Ref); pragma Inline (Get_Kind); end MOMA.Destinations; polyorb-2.8~20110207.orig/src/moma/destinations.conf0000644000175000017500000000023311750740340021473 0ustar xavierxavier[destination 1] type=topic #type=queue|topic name=example1 persistent=none #persistent=none|file [destination 2] type=queue name=example2 persistent=none polyorb-2.8~20110207.orig/src/moma/moma-types.adb0000644000175000017500000004651411750740340020677 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- M O M A . T Y P E S -- -- -- -- B o d y -- -- -- -- Copyright (C) 2002-2008, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with PolyORB.Initialization; with PolyORB.Log; with PolyORB.Utils.Strings; package body MOMA.Types is use PolyORB.Any; use PolyORB.Log; package L is new PolyORB.Log.Facility_Log ("moma.types"); procedure O (Message : Standard.String; Level : Log_Level := Debug) renames L.Output; function C (Level : Log_Level := Debug) return Standard.Boolean renames L.Enabled; -------------- -- From_Any -- -------------- function From_Any (Item : MOMA.Types.Any) return Map_Element is Index : PolyORB.Any.Any; Result : Map_Element; begin pragma Debug (C, O ("From_Any : (Map_Element)")); Index := Get_Aggregate_Element (Item, TypeCode.TC_String, PolyORB.Types.Unsigned_Long (0)); Result.Name := MOMA.Types.String (PolyORB.Types.String'(PolyORB.Any.From_Any (Index))); Result.Value := From_Any (Get_Aggregate_Element (Item, TypeCode.TC_Any, PolyORB.Types.Unsigned_Long (1))); return Result; end From_Any; function From_Any (Item : MOMA.Types.Any) return IDL_SEQUENCE_Map_Element.Sequence is use IDL_SEQUENCE_Map_Element; Nb_Any : constant Any := Get_Aggregate_Element (Item, TC_Unsigned_Long, PolyORB.Types.Unsigned_Long (0)); Nb_Long : constant Unsigned_Long := From_Any (Nb_Any); Nb : constant Integer := Integer (Nb_Long); Index : Any; Result : Element_Array (1 .. Nb); begin pragma Debug (C, O ("From_Any : (IDL_Sequence_Map_Element)")); for J in 1 .. Nb loop Index := Get_Aggregate_Element (Item, TC_Map_Element, PolyORB.Types.Unsigned_Long (J)); Result (J) := From_Any (Index); end loop; return To_Sequence (Result); end From_Any; function From_Any (Item : MOMA.Types.Any) return Map is Result : constant IDL_SEQUENCE_Map_Element.Sequence := From_Any (Item); begin pragma Debug (C, O ("From_Any : (Map)")); return Map (Result); end From_Any; function From_Any (Item : MOMA.Types.Any) return Destination_Type is Index : constant Any := Get_Aggregate_Element (Item, TC_Unsigned_Long, PolyORB.Types.Unsigned_Long (0)); Position : constant Unsigned_Long := From_Any (Index); begin return Destination_Type'Val (Position); end From_Any; function From_Any (Item : Any) return Short is begin return Short (PolyORB.Types.Short'(PolyORB.Any.From_Any (Item))); end From_Any; function From_Any (Item : Any) return Long is begin return Long (PolyORB.Types.Long'(PolyORB.Any.From_Any (Item))); end From_Any; function From_Any (Item : Any) return Unsigned_Short is begin return Unsigned_Short (PolyORB.Types.Unsigned_Short'(PolyORB.Any.From_Any (Item))); end From_Any; function From_Any (Item : Any) return Unsigned_Long is begin return Unsigned_Long (PolyORB.Types.Unsigned_Long'(PolyORB.Any.From_Any (Item))); end From_Any; function From_Any (Item : Any) return MOMA.Types.Float is begin return MOMA.Types.Float (PolyORB.Types.Float'(PolyORB.Any.From_Any (Item))); end From_Any; function From_Any (Item : Any) return Double is begin return Double (PolyORB.Types.Double'(PolyORB.Any.From_Any (Item))); end From_Any; function From_Any (Item : Any) return Boolean is begin return Boolean (PolyORB.Types.Boolean'(PolyORB.Any.From_Any (Item))); end From_Any; function From_Any (Item : Any) return Char is begin return Char (PolyORB.Types.Char'(PolyORB.Any.From_Any (Item))); end From_Any; function From_Any (Item : Any) return Byte is begin return Byte (PolyORB.Types.Octet'(PolyORB.Any.From_Any (Item))); end From_Any; function From_Any (Item : Any) return Any renames PolyORB.Any.From_Any; function From_Any (Item : Any) return MOMA.Types.String is begin return MOMA.Types.String (PolyORB.Types.String'(PolyORB.Any.From_Any (Item))); end From_Any; ------------ -- To_Any -- ------------ function To_Any (Item : Map_Element) return MOMA.Types.Any is Result : Any := Get_Empty_Any_Aggregate (TC_Map_Element); begin pragma Debug (C, O ("To_Any : (Map_Element)")); Add_Aggregate_Element (Result, To_Any (Item.Name)); Add_Aggregate_Element (Result, To_Any (Item.Value)); return Result; end To_Any; function To_Any (Item : IDL_SEQUENCE_Map_Element.Sequence) return MOMA.Types.Any is use IDL_SEQUENCE_Map_Element; Array_Item : constant Element_Array := To_Element_Array (Item); Result : Any := Get_Empty_Any_Aggregate (TC_IDL_SEQUENCE_Map_Element); begin pragma Debug (C, O ("To_Any : (IDL_SEQUENCE_Map_Element)")); Add_Aggregate_Element (Result, To_Any (Unsigned_Long (Length (Item)))); for J in Array_Item'Range loop Add_Aggregate_Element (Result, To_Any (Array_Item (J))); end loop; return Result; end To_Any; function To_Any (Item : Map) return MOMA.Types.Any is Result : Any := To_Any (IDL_SEQUENCE_Map_Element.Sequence (Item)); begin pragma Debug (C, O ("To_Any : (Map)")); Set_Type (Result, TC_Map); return Result; end To_Any; function To_Any (Item : Destination_Type) return MOMA.Types.Any is Result : Any := Get_Empty_Any_Aggregate (TC_Destination_Type); begin Add_Aggregate_Element (Result, To_Any (Unsigned_Long (Destination_Type'Pos (Item)))); return Result; end To_Any; function To_Any (Item : Short) return Any is begin return PolyORB.Any.To_Any (PolyORB.Types.Short (Item)); end To_Any; function To_Any (Item : Long) return Any is begin return PolyORB.Any.To_Any (PolyORB.Types.Long (Item)); end To_Any; function To_Any (Item : Unsigned_Short) return Any is begin return PolyORB.Any.To_Any (PolyORB.Types.Unsigned_Short (Item)); end To_Any; function To_Any (Item : Unsigned_Long) return Any is begin return PolyORB.Any.To_Any (PolyORB.Types.Unsigned_Long (Item)); end To_Any; function To_Any (Item : MOMA.Types.Float) return Any is begin return PolyORB.Any.To_Any (PolyORB.Types.Float (Item)); end To_Any; function To_Any (Item : Double) return Any is begin return PolyORB.Any.To_Any (PolyORB.Types.Double (Item)); end To_Any; function To_Any (Item : Boolean) return Any is begin return PolyORB.Any.To_Any (PolyORB.Types.Boolean (Item)); end To_Any; function To_Any (Item : Char) return Any is begin return PolyORB.Any.To_Any (PolyORB.Types.Char (Item)); end To_Any; function To_Any (Item : Byte) return Any is begin return PolyORB.Any.To_Any (PolyORB.Types.Octet (Item)); end To_Any; function To_Any (Item : Any) return Any renames PolyORB.Any.To_Any; function To_Any (Item : MOMA.Types.String) return Any is begin return PolyORB.Any.To_Any (PolyORB.Types.String (Item)); end To_Any; ----------------- -- Get_Boolean -- ----------------- function Get_Boolean (Self : Map_Element) return MOMA.Types.Boolean is begin return From_Any (Self.Value); end Get_Boolean; ----------------- -- Set_Boolean -- ----------------- procedure Set_Boolean (Self : in out Map_Element; Value : MOMA.Types.Boolean) is begin Self.Value := To_Any (PolyORB.Types.Boolean (Value)); end Set_Boolean; -------------- -- Get_Byte -- -------------- function Get_Byte (Self : Map_Element) return MOMA.Types.Byte is begin return From_Any (Self.Value); end Get_Byte; -------------- -- Set_Byte -- -------------- procedure Set_Byte (Self : in out Map_Element; Value : MOMA.Types.Byte) is begin Self.Value := To_Any (PolyORB.Types.Octet (Value)); end Set_Byte; -------------- -- Get_Char -- -------------- function Get_Char (Self : Map_Element) return MOMA.Types.Char is begin return From_Any (Self.Value); end Get_Char; -------------- -- Set_Char -- -------------- procedure Set_Char (Self : in out Map_Element; Value : MOMA.Types.Char) is begin Self.Value := To_Any (PolyORB.Types.Char (Value)); end Set_Char; ---------------- -- Get_Double -- ---------------- function Get_Double (Self : Map_Element) return MOMA.Types.Double is begin return From_Any (Self.Value); end Get_Double; ---------------- -- Set_Double -- ---------------- procedure Set_Double (Self : in out Map_Element; Value : MOMA.Types.Double) is begin Self.Value := To_Any (PolyORB.Types.Double (Value)); end Set_Double; --------------- -- Get_Float -- --------------- function Get_Float (Self : Map_Element) return MOMA.Types.Float is begin return From_Any (Self.Value); end Get_Float; --------------- -- Set_Float -- --------------- procedure Set_Float (Self : in out Map_Element; Value : MOMA.Types.Float) is begin Self.Value := To_Any (PolyORB.Types.Float (Value)); end Set_Float; -------------- -- Get_Long -- -------------- function Get_Long (Self : Map_Element) return MOMA.Types.Long is begin return From_Any (Self.Value); end Get_Long; -------------- -- Set_Long -- -------------- procedure Set_Long (Self : in out Map_Element; Value : MOMA.Types.Long) is begin Self.Value := To_Any (PolyORB.Types.Long (Value)); end Set_Long; -------------- -- Get_Name -- -------------- function Get_Name (Self : Map_Element) return MOMA.Types.String is begin return Self.Name; end Get_Name; -------------- -- Set_Name -- -------------- procedure Set_Name (Self : in out Map_Element; Value : MOMA.Types.String) is begin Self.Name := Value; end Set_Name; --------------- -- Get_Short -- --------------- function Get_Short (Self : Map_Element) return MOMA.Types.Short is begin return From_Any (Self.Value); end Get_Short; --------------- -- Set_Short -- --------------- procedure Set_Short (Self : in out Map_Element; Value : MOMA.Types.Short) is begin Self.Value := To_Any (PolyORB.Types.Short (Value)); end Set_Short; ---------------- -- Get_String -- ---------------- function Get_String (Self : Map_Element) return MOMA.Types.String is begin return From_Any (Self.Value); end Get_String; ---------------- -- Set_String -- ---------------- procedure Set_String (Self : in out Map_Element; Value : MOMA.Types.String) is begin Self.Value := To_Any (PolyORB.Types.String (Value)); end Set_String; ----------------------- -- Get_Unsigned_Long -- ----------------------- function Get_Unsigned_Long (Self : Map_Element) return MOMA.Types.Unsigned_Long is begin return From_Any (Self.Value); end Get_Unsigned_Long; ----------------------- -- Set_Unsigned_Long -- ----------------------- procedure Set_Unsigned_Long (Self : in out Map_Element; Value : MOMA.Types.Unsigned_Long) is begin Self.Value := To_Any (PolyORB.Types.Unsigned_Long (Value)); end Set_Unsigned_Long; ------------------------ -- Get_Unsigned_Short -- ------------------------ function Get_Unsigned_Short (Self : Map_Element) return MOMA.Types.Unsigned_Short is begin return From_Any (Self.Value); end Get_Unsigned_Short; ------------------------ -- Set_Unsigned_Short -- ------------------------ procedure Set_Unsigned_Short (Self : in out Map_Element; Value : MOMA.Types.Unsigned_Short) is begin Self.Value := To_Any (PolyORB.Types.Unsigned_Short (Value)); end Set_Unsigned_Short; -------------- -- Get_Name -- -------------- function Get_Name (Pool : MOMA.Types.Message_Pool) return MOMA.Types.String is begin return Pool.Name; end Get_Name; -------------- -- Set_Name -- -------------- procedure Set_Name (Pool : in out MOMA.Types.Message_Pool; Name : MOMA.Types.String) is begin Pool.Name := Name; end Set_Name; -------------- -- Get_Type -- -------------- function Get_Type (Pool : MOMA.Types.Message_Pool) return Pool_Type is begin return Pool.Pool; end Get_Type; -------------- -- Set_Type -- -------------- procedure Set_Type (Pool : in out MOMA.Types.Message_Pool; PType : Pool_Type) is begin Pool.Pool := PType; end Set_Type; -------------------- -- Get_Persistent -- -------------------- function Get_Persistence (Pool : MOMA.Types.Message_Pool) return Persistence_Mode is begin return Pool.Persistence; end Get_Persistence; --------------------- -- Set_Persistence -- --------------------- procedure Set_Persistence (Pool : in out MOMA.Types.Message_Pool; PMode : Persistence_Mode) is begin Pool.Persistence := PMode; end Set_Persistence; ------------------------ -- To_Standard_String -- ------------------------ function To_Standard_String (V : MOMA.Types.String) return Standard.String is begin return Ada.Strings.Unbounded.To_String (Ada.Strings.Unbounded.Unbounded_String (V)); end To_Standard_String; -------------------- -- To_MOMA_String -- -------------------- function To_MOMA_String (V : Standard.String) return MOMA.Types.String is begin return Types.String (Ada.Strings.Unbounded.To_Unbounded_String (V)); end To_MOMA_String; ---------------- -- Initialize -- ---------------- procedure Initialize; procedure Initialize is use PolyORB.Utils.Strings; begin -- Map_Element TC_Map_Element := PolyORB.Any.TypeCode.TC_Struct; TypeCode.Add_Parameter (TC_Map_Element, PolyORB.Any.To_Any (To_PolyORB_String ("map_element"))); TypeCode.Add_Parameter (TC_Map_Element, PolyORB.Any.To_Any (To_PolyORB_String ("MOMA:types/map_element:1.0"))); TypeCode.Add_Parameter (TC_Map_Element, PolyORB.Any.To_Any (TC_String)); TypeCode.Add_Parameter (TC_Map_Element, PolyORB.Any.To_Any (To_PolyORB_String ("name"))); TypeCode.Add_Parameter (TC_Map_Element, PolyORB.Any.To_Any (TC_Any)); TypeCode.Add_Parameter (TC_Map_Element, PolyORB.Any.To_Any (To_PolyORB_String ("value"))); -- IDL_SEQUENCE_Map_Element TC_IDL_SEQUENCE_Map_Element := PolyORB.Any.TypeCode.TC_Sequence; TypeCode.Add_Parameter (TC_IDL_SEQUENCE_Map_Element, PolyORB.Any.To_Any (PolyORB.Types.Unsigned_Long (0))); TypeCode.Add_Parameter (TC_IDL_SEQUENCE_Map_Element, PolyORB.Any.To_Any (TC_Map_Element)); -- Map TC_Map := PolyORB.Any.TypeCode.TC_Alias; TypeCode.Add_Parameter (TC_Map, PolyORB.Any.To_Any (To_PolyORB_String ("map"))); TypeCode.Add_Parameter (TC_Map, PolyORB.Any.To_Any (To_PolyORB_String ("MOMA:types/map:1.0"))); TypeCode.Add_Parameter (TC_Map, PolyORB.Any.To_Any (TC_IDL_SEQUENCE_Map_Element)); -- Destination_Type TC_Destination_Type := PolyORB.Any.TypeCode.TC_Enum; declare Name : constant String := To_PolyORB_String ("Destination_Type"); Id : constant String := To_PolyORB_String ("MOMA:types/destination_type:1.0"); Unknown_Name : constant String := To_PolyORB_String ("Unknown"); Pool_Name : constant String := To_PolyORB_String ("Pool"); Router_Name : constant String := To_PolyORB_String ("Router"); Topic_Name : constant String := To_PolyORB_String ("Topic"); begin TypeCode.Add_Parameter (TC_Destination_Type, To_Any (Name)); TypeCode.Add_Parameter (TC_Destination_Type, To_Any (Id)); TypeCode.Add_Parameter (TC_Destination_Type, To_Any (Unknown_Name)); TypeCode.Add_Parameter (TC_Destination_Type, To_Any (Pool_Name)); TypeCode.Add_Parameter (TC_Destination_Type, To_Any (Router_Name)); TypeCode.Add_Parameter (TC_Destination_Type, To_Any (Topic_Name)); end; end Initialize; begin declare use PolyORB.Initialization; use PolyORB.Initialization.String_Lists; use PolyORB.Utils.Strings; begin Register_Module (Module_Info' (Name => +"MOMA.Types", Conflicts => Empty, Depends => +"any", Provides => Empty, Implicit => False, Init => Initialize'Access, Shutdown => null)); end; end MOMA.Types; polyorb-2.8~20110207.orig/src/moma/moma-connections.adb0000644000175000017500000001011211750740340022036 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- M O M A . C O N N E C T I O N S -- -- -- -- B o d y -- -- -- -- Copyright (C) 2002-2004 Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by ACT Europe. -- -- (email: sales@act-europe.fr) -- -- -- ------------------------------------------------------------------------------ package body MOMA.Connections is ----------- -- Close -- ----------- procedure Close is begin null; end Close; ----------------------- -- Create_Connection -- ----------------------- function Create_Connection (Factory : MOMA.Connection_Factories.Connection_Factory) return Connection is New_Connection : Connection; begin Set_Ref (New_Connection, MOMA.Connection_Factories.Get_Ref (Factory)); return New_Connection; end Create_Connection; function Create_Connection (Factory : MOMA.Connection_Factories.Connection_Factory; Username : String; Password : String) return Connection is begin raise Program_Error; pragma Warnings (Off); return Create_Connection (Factory, Username, Password); pragma Warnings (On); end Create_Connection; ------------------- -- Get_Client_Id -- ------------------- function Get_Client_Id (Self : Connection) return MOMA.Types.String is begin return Self.Client_Id; end Get_Client_Id; ------------------- -- Set_Client_Id -- ------------------- procedure Set_Client_Id (Self : in out Connection; Client_Id : MOMA.Types.String) is begin Self.Client_Id := Client_Id; end Set_Client_Id; ------------- -- Get_Ref -- ------------- function Get_Ref (Self : Connection) return MOMA.Types.Ref is begin return Self.Ref; end Get_Ref; ------------- -- Set_Ref -- ------------- procedure Set_Ref (Self : in out Connection; Ref : MOMA.Types.Ref) is begin Self.Ref := Ref; end Set_Ref; ----------- -- Start -- ----------- procedure Start is begin null; end Start; ---------- -- Stop -- ---------- procedure Stop is begin null; end Stop; ------------------- -- Get_Meta_Data -- ------------------- function Get_Meta_Data return MOMA.Types.Meta_Data is begin return 0; end Get_Meta_Data; end MOMA.Connections; polyorb-2.8~20110207.orig/src/moma/moma-message_producers.ads0000644000175000017500000001462311750740340023262 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- M O M A . M E S S A G E _ P R O D U C E R S -- -- -- -- S p e c -- -- -- -- Copyright (C) 2002-2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ pragma Ada_2005; -- A Message_Producer object is the client view of the message sending -- process. It is the facade to all communication carried out with -- a message pool to send messages; it contains the stub to access -- Message_Producer servants (see MOMA.Provider for more details). -- NOTE: A MOMA client must use only this package to send messages to a -- message pool. with Ada.Real_Time; with MOMA.Destinations; with MOMA.Messages; with MOMA.Sessions; with MOMA.Types; with PolyORB.Annotations; with PolyORB.Call_Back; package MOMA.Message_Producers is use Ada.Real_Time; type Message_Producer is private; -- Priority_Level : priority of the message producer. -- Persistent : default persistent status for sent messages. -- TTL : default time to live for sent messages. -- Destination : destination of sent messages. -- Type_Id_Of : XXX to be defined. -- Ref : reference to the provider servant. -- CBH : call back handler associated to the producer. type CBH_Note is new PolyORB.Annotations.Note with record Dest : MOMA.Types.Ref; end record; function Create_Producer (Session : MOMA.Sessions.Session; Dest : MOMA.Destinations.Destination) return Message_Producer; -- Create a message producer whose destination is a MOM object. function Create_Producer (ORB_Object : MOMA.Types.String; Mesg_Pool : MOMA.Types.String) return Message_Producer; -- Create a message producer whose destination is an ORB object. procedure Close; -- XXX not implemented. Rename it to Destroy ? procedure Send (Self : Message_Producer; Message : in out MOMA.Messages.Message'Class); -- Send a Message using the producer Self. -- XXX should send asynchronous message !!! procedure Send (Self : Message_Producer; Message : MOMA.Messages.Message'Class; Persistent : Boolean; Priority_Value : MOMA.Types.Priority; TTL : Time); -- Same as above, overriding default producer's values. -- XXX not implemented. -- Accessors to Message_Producer internal data. function Get_Persistent (Self : Message_Producer) return Boolean; procedure Set_Persistent (Self : in out Message_Producer; Persistent : Boolean); function Get_Priority (Self : Message_Producer) return MOMA.Types.Priority; procedure Set_Priority (Self : in out Message_Producer; Value : MOMA.Types.Priority); function Get_Time_To_Live (Self : Message_Producer) return Time; procedure Set_Time_To_Live (Self : in out Message_Producer; TTL : Time); function Get_Ref (Self : Message_Producer) return MOMA.Types.Ref; procedure Set_Ref (Self : in out Message_Producer; Ref : MOMA.Types.Ref); function Get_Type_Id_Of (Self : Message_Producer) return MOMA.Types.String; procedure Set_Type_Id_Of (Self : in out Message_Producer; Type_Id_Of : MOMA.Types.String); function Get_CBH (Self : Message_Producer) return PolyORB.Call_Back.CBH_Access; procedure Set_CBH (Self : in out Message_Producer; CBH : PolyORB.Call_Back.CBH_Access); private type Message_Producer is record Priority_Level : MOMA.Types.Priority; Persistent : Boolean; TTL : Time; Destination : MOMA.Destinations.Destination; Type_Id_Of : MOMA.Types.String; Ref : MOMA.Types.Ref; CBH : PolyORB.Call_Back.CBH_Access; end record; -- Private accessors to Message_Producer internal data. function Get_Destination (Self : Message_Producer) return MOMA.Destinations.Destination; procedure Set_Destination (Self : in out Message_Producer; Dest : MOMA.Destinations.Destination); pragma Inline (Get_Persistent); pragma Inline (Set_Persistent); pragma Inline (Get_Priority); pragma Inline (Set_Priority); pragma Inline (Get_Time_To_Live); pragma Inline (Set_Time_To_Live); pragma Inline (Get_Ref); pragma Inline (Set_Ref); pragma Inline (Get_Destination); pragma Inline (Set_Destination); pragma Inline (Get_Type_Id_Of); pragma Inline (Set_Type_Id_Of); pragma Inline (Get_CBH); pragma Inline (Set_CBH); end MOMA.Message_Producers; polyorb-2.8~20110207.orig/src/moma/polyorb-moma_p.ads0000644000175000017500000000417411750740340021555 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . M O M A _ P -- -- -- -- S p e c -- -- -- -- Copyright (C) 2002-2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- Root package for the MOMA applicative personality package PolyORB.MOMA_P is pragma Pure; end PolyORB.MOMA_P; polyorb-2.8~20110207.orig/src/moma/moma-messages.adb0000644000175000017500000005044311750740340021336 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- M O M A . M E S S A G E S -- -- -- -- B o d y -- -- -- -- Copyright (C) 2002-2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with MOMA.Messages.MAnys; with MOMA.Messages.MBytes; with MOMA.Messages.MExecutes; with MOMA.Messages.MMaps; with MOMA.Messages.MTexts; with PolyORB.Initialization; -- with PolyORB.Log; with PolyORB.Types; with PolyORB.Utils.Strings; package body MOMA.Messages is use MOMA.Destinations; use MOMA.Types; -- use PolyORB.Log; -- package L is new PolyORB.Log.Facility_Log ("moma.messages"); -- procedure O (Message : Standard.String; Level : Log_Level := Debug) -- renames L.Output; ----------------- -- Acknowledge -- ----------------- procedure Acknowledge is begin null; end Acknowledge; ---------------- -- Clear_Body -- ---------------- procedure Clear_Body is begin null; end Clear_Body; -------------- -- From_Any -- -------------- function From_Any (Self : MOMA.Types.Any) return Message'Class is use MOMA.Messages.MAnys; use MOMA.Messages.MBytes; use MOMA.Messages.MExecutes; use MOMA.Messages.MMaps; use MOMA.Messages.MTexts; Pos : MOMA.Types.Short; Type_Of_Message : Message_Type; Message_Id : MOMA.Types.String; Correlation_Id : MOMA.Types.String; Destination : MOMA.Destinations.Destination; Reply_To : MOMA.Destinations.Destination; Is_Persistent : MOMA.Types.Boolean; Is_Redelivered : MOMA.Types.Boolean; Payload : MOMA.Types.Any; begin Pos := MOMA.Types.From_Any (Get_Aggregate_Element (Self, TypeCode.TC_Short, PolyORB.Types.Unsigned_Long (0))); Type_Of_Message := Message_Type'Val (Pos); Message_Id := MOMA.Types.From_Any (Get_Aggregate_Element (Self, TypeCode.TC_String, PolyORB.Types.Unsigned_Long (1))); Correlation_Id := MOMA.Types.From_Any (Get_Aggregate_Element (Self, TypeCode.TC_String, PolyORB.Types.Unsigned_Long (2))); Destination := MOMA.Destinations.From_Any (Get_Aggregate_Element (Self, TC_MOMA_Destination, PolyORB.Types.Unsigned_Long (3))); Reply_To := MOMA.Destinations.From_Any (Get_Aggregate_Element (Self, TC_MOMA_Destination, PolyORB.Types.Unsigned_Long (4))); Is_Persistent := MOMA.Types.From_Any (Get_Aggregate_Element (Self, TypeCode.TC_Boolean, PolyORB.Types.Unsigned_Long (5))); Is_Redelivered := MOMA.Types.From_Any (Get_Aggregate_Element (Self, TypeCode.TC_Boolean, PolyORB.Types.Unsigned_Long (6))); Payload := MOMA.Types.From_Any (Get_Aggregate_Element (Self, TypeCode.TC_Any, PolyORB.Types.Unsigned_Long (7))); if Type_Of_Message = Any_M then declare Rcvd_Message : MOMA.Messages.MAnys.MAny := Create_Any_Message; begin Set_Message_Id (Rcvd_Message, Message_Id); Set_Correlation_Id (Rcvd_Message, Correlation_Id); Set_Destination (Rcvd_Message, Destination); Set_Reply_To (Rcvd_Message, Reply_To); Set_Persistent (Rcvd_Message, Is_Persistent); Set_Redelivered (Rcvd_Message, Is_Redelivered); Set_Payload (Rcvd_Message, Payload); return Rcvd_Message; end; elsif Type_Of_Message = Byte_M then declare Rcvd_Message : MOMA.Messages.MBytes.MByte := Create_Byte_Message; begin Set_Message_Id (Rcvd_Message, Message_Id); Set_Correlation_Id (Rcvd_Message, Correlation_Id); Set_Destination (Rcvd_Message, Destination); Set_Reply_To (Rcvd_Message, Reply_To); Set_Persistent (Rcvd_Message, Is_Persistent); Set_Redelivered (Rcvd_Message, Is_Redelivered); Set_Payload (Rcvd_Message, Payload); return Rcvd_Message; end; elsif Type_Of_Message = Map_M then declare Rcvd_Message : MOMA.Messages.MMaps.MMap := Create_Map_Message; begin Set_Message_Id (Rcvd_Message, Message_Id); Set_Correlation_Id (Rcvd_Message, Correlation_Id); Set_Destination (Rcvd_Message, Destination); Set_Reply_To (Rcvd_Message, Reply_To); Set_Persistent (Rcvd_Message, Is_Persistent); Set_Redelivered (Rcvd_Message, Is_Redelivered); Set_Payload (Rcvd_Message, Payload); return Rcvd_Message; end; elsif Type_Of_Message = Text_M then declare Rcvd_Message : MOMA.Messages.MTexts.MText := Create_Text_Message; begin Set_Message_Id (Rcvd_Message, Message_Id); Set_Correlation_Id (Rcvd_Message, Correlation_Id); Set_Destination (Rcvd_Message, Destination); Set_Reply_To (Rcvd_Message, Reply_To); Set_Persistent (Rcvd_Message, Is_Persistent); Set_Redelivered (Rcvd_Message, Is_Redelivered); Set_Payload (Rcvd_Message, Payload); return Rcvd_Message; end; elsif Type_Of_Message = Execute_M then declare Rcvd_Message : MOMA.Messages.MExecutes.MExecute := Create_Execute_Message; begin Set_Message_Id (Rcvd_Message, Message_Id); Set_Correlation_Id (Rcvd_Message, Correlation_Id); Set_Destination (Rcvd_Message, Destination); Set_Reply_To (Rcvd_Message, Reply_To); Set_Persistent (Rcvd_Message, Is_Persistent); Set_Redelivered (Rcvd_Message, Is_Redelivered); Set_Payload (Rcvd_Message, Payload); return Rcvd_Message; end; end if; raise Program_Error; -- Should not come to this point. end From_Any; ------------------ -- Get_Property -- ------------------ function Get_Property (Name : MOMA.Types.String) return MOMA.Types.Property_Type is begin raise Program_Error; pragma Warnings (Off); return Get_Property (Name); pragma Warnings (On); end Get_Property; ------------------------ -- Get_Correlation_Id -- ------------------------ function Get_Correlation_Id (Self : Message) return MOMA.Types.String is begin return Self.Correlation_Id; end Get_Correlation_Id; -------------------- -- Get_Persistent -- -------------------- function Get_Persistent (Self : Message) return MOMA.Types.Boolean is begin return Self.Is_Persistent; end Get_Persistent; --------------------- -- Get_Destination -- --------------------- function Get_Destination (Self : Message) return MOMA.Destinations.Destination is begin return Self.Destination; end Get_Destination; -------------------- -- Get_Expiration -- -------------------- function Get_Expiration (Self : Message) return Ada.Real_Time.Time is begin return Self.Expiration; end Get_Expiration; -------------------- -- Get_Message_Id -- -------------------- function Get_Message_Id (Self : Message) return MOMA.Types.String is begin return Self.Message_Id; end Get_Message_Id; ----------------- -- Get_Payload -- ----------------- function Get_Payload (Self : Message) return MOMA.Types.Any is begin return Self.Payload; end Get_Payload; ------------------- -- Get_Priority -- ------------------- function Get_Priority (Self : Message) return MOMA.Types.Priority is begin return Self.Priority; end Get_Priority; --------------------- -- Get_Redelivered -- --------------------- function Get_Redelivered (Self : Message) return MOMA.Types.Boolean is begin return Self.Is_Redelivered; end Get_Redelivered; ------------------ -- Get_Reply_To -- ------------------ function Get_Reply_To (Self : Message) return MOMA.Destinations.Destination is begin return Self.Reply_To; end Get_Reply_To; ------------------- -- Get_Timestamp -- ------------------- function Get_Timestamp (Self : Message) return Ada.Real_Time.Time is begin return Self.Timestamp; end Get_Timestamp; -------------- -- Get_Type -- -------------- function Get_Type (Self : Message) return MOMA.Types.Message_Type is begin return Self.Type_Of_Message; end Get_Type; ------------------------ -- Get_Property_Names -- ------------------------ function Get_Property_Names return Integer is begin return 0; end Get_Property_Names; --------------------- -- Property_Exists -- --------------------- function Property_Exists (Name : MOMA.Types.String) return MOMA.Types.Boolean is pragma Warnings (Off); pragma Unreferenced (Name); pragma Warnings (On); begin return False; -- XXX Not Implemented end Property_Exists; ------------------ -- Set_Property -- ------------------ procedure Set_Property (Name : MOMA.Types.String; Value : MOMA.Types.Property_Type) is pragma Warnings (Off); pragma Unreferenced (Name); pragma Unreferenced (Value); pragma Warnings (On); begin null; -- XXX Not Implemented end Set_Property; ------------------------ -- Set_Correlation_Id -- ------------------------ procedure Set_Correlation_Id (Self : in out Message; Correlation_Id : MOMA.Types.String) is begin Self.Correlation_Id := Correlation_Id; end Set_Correlation_Id; -------------------- -- Set_Persistent -- -------------------- procedure Set_Persistent (Self : in out Message; Is_Persistent : MOMA.Types.Boolean) is begin Self.Is_Persistent := Is_Persistent; end Set_Persistent; --------------------- -- Set_Destination -- --------------------- procedure Set_Destination (Self : in out Message; Destination : MOMA.Destinations.Destination) is begin Self.Destination := Destination; end Set_Destination; -------------------- -- Set_Expiration -- -------------------- procedure Set_Expiration (Self : in out Message; Expiration : Ada.Real_Time.Time) is begin Self.Expiration := Expiration; end Set_Expiration; ----------------- -- Set_Payload -- ----------------- procedure Set_Payload (Self : in out Message; Payload : MOMA.Types.Any) is begin Self.Payload := Payload; end Set_Payload; ----------- -- Image -- ----------- function Image (Self : Message) return String is begin return ""; end Image; -------------------------------- -- Set_Default_Message_Header -- -------------------------------- procedure Set_Default_Message_Header (Self : in out Message) is begin Set_Message_Id (Self, To_MOMA_String ("moma")); Set_Correlation_Id (Self, To_MOMA_String ("moma")); Set_Destination (Self, Create_Destination); Set_Reply_To (Self, Create_Destination); -- Set_Priority (Self, Priority); -- Set_Timestamp (Self, Timestamp); -- Set_Expiration (Self, Expiration); Set_Persistent (Self, True); Set_Redelivered (Self, True); end Set_Default_Message_Header; ------------------------ -- Set_Message_Header -- ------------------------ procedure Set_Message_Header (Self : in out Message; Message_Id : MOMA.Types.String; Correlation_Id : MOMA.Types.String; Destination : MOMA.Destinations.Destination; Reply_To : MOMA.Destinations.Destination; Priority : MOMA.Types.Priority; Timestamp : Ada.Real_Time.Time; Expiration : Ada.Real_Time.Time; Is_Persistent : MOMA.Types.Boolean; Is_Redelivered : MOMA.Types.Boolean) is begin Set_Message_Id (Self, Message_Id); Set_Correlation_Id (Self, Correlation_Id); Set_Destination (Self, Destination); Set_Reply_To (Self, Reply_To); Set_Priority (Self, Priority); Set_Timestamp (Self, Timestamp); Set_Expiration (Self, Expiration); Set_Persistent (Self, Is_Persistent); Set_Redelivered (Self, Is_Redelivered); end Set_Message_Header; -------------------- -- Set_Message_Id -- -------------------- procedure Set_Message_Id (Self : in out Message; Id : MOMA.Types.String) is begin Self.Message_Id := Id; end Set_Message_Id; ------------------ -- Set_Priority -- ------------------ procedure Set_Priority (Self : in out Message; Priority : MOMA.Types.Priority) is begin Self.Priority := Priority; end Set_Priority; --------------------- -- Set_Redelivered -- --------------------- procedure Set_Redelivered (Self : in out Message; Redelivered : MOMA.Types.Boolean) is begin Self.Is_Redelivered := Redelivered; end Set_Redelivered; ------------------ -- Set_Reply_To -- ------------------ procedure Set_Reply_To (Self : in out Message; Reply_To : MOMA.Destinations.Destination) is begin Self.Reply_To := Reply_To; end Set_Reply_To; ------------------- -- Set_Timestamp -- ------------------- procedure Set_Timestamp (Self : in out Message; Timestamp : Ada.Real_Time.Time) is begin Self.Timestamp := Timestamp; end Set_Timestamp; -------------- -- Set_Type -- -------------- procedure Set_Type (Self : in out Message; Type_Of_Message : MOMA.Types.Message_Type) is begin Self.Type_Of_Message := Type_Of_Message; end Set_Type; ------------ -- To_Any -- ------------ function To_Any (Self : Message) return MOMA.Types.Any is Result : MOMA.Types.Any := Get_Empty_Any_Aggregate (TC_MOMA_Message); begin Add_Aggregate_Element (Result, PolyORB.Any.To_Any (PolyORB.Types.Short (Message_Type'Pos (Self.Type_Of_Message)))); Add_Aggregate_Element (Result, MOMA.Types.To_Any (Self.Message_Id)); Add_Aggregate_Element (Result, MOMA.Types.To_Any (Self.Correlation_Id)); Add_Aggregate_Element (Result, MOMA.Destinations.To_Any (Self.Destination)); Add_Aggregate_Element (Result, MOMA.Destinations.To_Any (Self.Reply_To)); Add_Aggregate_Element (Result, MOMA.Types.To_Any (Self.Is_Persistent)); Add_Aggregate_Element (Result, MOMA.Types.To_Any (Self.Is_Redelivered)); Add_Aggregate_Element (Result, MOMA.Types.To_Any (Self.Payload)); return Result; end To_Any; ---------------- -- Initialize -- ---------------- procedure Initialize; procedure Initialize is use PolyORB.Utils.Strings; use PolyORB.Types; begin TC_MOMA_Message := PolyORB.Any.TypeCode.TC_Struct; TypeCode.Add_Parameter (TC_MOMA_Message, PolyORB.Any.To_Any (To_PolyORB_String ("moma_message"))); TypeCode.Add_Parameter (TC_MOMA_Message, PolyORB.Any.To_Any (To_PolyORB_String ("MOMA:messages/moma_message:1.0"))); TypeCode.Add_Parameter (TC_MOMA_Message, To_Any (TC_Short)); TypeCode.Add_Parameter (TC_MOMA_Message, PolyORB.Any.To_Any (To_PolyORB_String ("type"))); TypeCode.Add_Parameter (TC_MOMA_Message, To_Any (TC_String)); TypeCode.Add_Parameter (TC_MOMA_Message, PolyORB.Any.To_Any (To_PolyORB_String ("message_id"))); TypeCode.Add_Parameter (TC_MOMA_Message, To_Any (TC_String)); TypeCode.Add_Parameter (TC_MOMA_Message, PolyORB.Any.To_Any (To_PolyORB_String ("correlation_id"))); TypeCode.Add_Parameter (TC_MOMA_Message, To_Any (TC_MOMA_Destination)); TypeCode.Add_Parameter (TC_MOMA_Message, PolyORB.Any.To_Any (To_PolyORB_String ("destination"))); TypeCode.Add_Parameter (TC_MOMA_Message, To_Any (TC_MOMA_Destination)); TypeCode.Add_Parameter (TC_MOMA_Message, PolyORB.Any.To_Any (To_PolyORB_String ("reply_to"))); TypeCode.Add_Parameter (TC_MOMA_Message, To_Any (TC_Boolean)); TypeCode.Add_Parameter (TC_MOMA_Message, PolyORB.Any.To_Any (To_PolyORB_String ("is_persistent"))); TypeCode.Add_Parameter (TC_MOMA_Message, To_Any (TC_Boolean)); TypeCode.Add_Parameter (TC_MOMA_Message, PolyORB.Any.To_Any (To_PolyORB_String ("is_redelivered"))); TypeCode.Add_Parameter (TC_MOMA_Message, To_Any (TC_Any)); TypeCode.Add_Parameter (TC_MOMA_Message, PolyORB.Any.To_Any (To_PolyORB_String ("payload"))); end Initialize; begin declare use PolyORB.Initialization; use PolyORB.Initialization.String_Lists; use PolyORB.Utils.Strings; begin Register_Module (Module_Info' (Name => +"MOMA.Messages", Conflicts => Empty, Depends => +"MOMA.Destinations" & "any", Provides => Empty, Implicit => False, Init => Initialize'Access, Shutdown => null)); end; end MOMA.Messages; polyorb-2.8~20110207.orig/src/moma/polyorb-moma_p-provider-message_producer.adb0000644000175000017500000001375411750740340026715 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- POLYORB.MOMA_P.PROVIDER.MESSAGE_PRODUCER -- -- -- -- B o d y -- -- -- -- Copyright (C) 2002-2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- Message_Producer servant with MOMA.Messages; with PolyORB.Any.NVList; with PolyORB.Errors; with PolyORB.Log; with PolyORB.QoS; with PolyORB.Request_QoS; with PolyORB.Types; package body PolyORB.MOMA_P.Provider.Message_Producer is use MOMA.Messages; use PolyORB.Any; use PolyORB.Any.NVList; use PolyORB.Log; use PolyORB.Requests; use PolyORB.Types; package L is new PolyORB.Log.Facility_Log ("moma.provider.message_producer"); procedure O (Message : Standard.String; Level : Log_Level := Debug) renames L.Output; function C (Level : Log_Level := Debug) return Boolean renames L.Enabled; -- Actual function implemented by the servant procedure Publish (Self : PolyORB.References.Ref; Message : PolyORB.Any.Any; QoS_Params : PolyORB.QoS.QoS_Parameters); -- Publish a message Message_S : constant PolyORB.Types.Identifier := To_PolyORB_String ("Message"); Result_S : constant PolyORB.Types.Identifier := To_PolyORB_String ("Result"); -------------------- -- Get_Remote_Ref -- -------------------- function Get_Remote_Ref (Self : Object) return PolyORB.References.Ref is begin return Self.Remote_Ref; end Get_Remote_Ref; ------------ -- Invoke -- ------------ procedure Invoke (Self : access Object; Req : PolyORB.Requests.Request_Access) is use PolyORB.Errors; use PolyORB.Any.NVList.Internals; use PolyORB.Any.NVList.Internals.NV_Lists; Args : PolyORB.Any.NVList.Ref; Error : Error_Container; QoS_Params : PolyORB.QoS.QoS_Parameters; begin pragma Debug (C, O ("The server is executing the request:" & PolyORB.Requests.Image (Req.all))); Create (Args); if Req.all.Operation.all = "Publish" then -- Publish Add_Item (Args, (Name => Message_S, Argument => Get_Empty_Any (TC_MOMA_Message), Arg_Modes => PolyORB.Any.ARG_IN)); Arguments (Req, Args, Error); if Found (Error) then raise Program_Error; -- XXX We should do something more contructive end if; QoS_Params (PolyORB.QoS.Static_Priority) := PolyORB.Request_QoS.Extract_Request_Parameter (PolyORB.QoS.Static_Priority, Req.all); Publish (Self.Remote_Ref, Value (First (List_Of (Args).all)).Argument, QoS_Params); end if; end Invoke; ------------- -- Publish -- ------------- procedure Publish (Self : PolyORB.References.Ref; Message : PolyORB.Any.Any; QoS_Params : PolyORB.QoS.QoS_Parameters) is Request : PolyORB.Requests.Request_Access; Arg_List : PolyORB.Any.NVList.Ref; Result : PolyORB.Any.NamedValue; begin pragma Debug (C, O ("Publishing Message " & Image (Message))); PolyORB.Any.NVList.Create (Arg_List); PolyORB.Any.NVList.Add_Item (Arg_List, Message_S, Message, PolyORB.Any.ARG_IN); Result := (Name => Result_S, Argument => PolyORB.Any.Get_Empty_Any (PolyORB.Any.TC_Void), Arg_Modes => 0); PolyORB.Requests.Create_Request (Target => Self, Operation => "Publish", Arg_List => Arg_List, Result => Result, Req => Request); PolyORB.Request_QoS.Set_Request_QoS (Request.all, QoS_Params); PolyORB.Requests.Invoke (Request); PolyORB.Requests.Destroy_Request (Request); pragma Debug (C, O ("Message published")); end Publish; -------------------- -- Set_Remote_Ref -- -------------------- procedure Set_Remote_Ref (Self : in out Object; Ref : PolyORB.References.Ref) is begin Self.Remote_Ref := Ref; end Set_Remote_Ref; end PolyORB.MOMA_P.Provider.Message_Producer; polyorb-2.8~20110207.orig/src/moma/polyorb-moma_p-provider.ads0000644000175000017500000000444311750740340023404 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . M O M A _ P . P R O V I D E R -- -- -- -- S p e c -- -- -- -- Copyright (C) 2002-2003 Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by ACT Europe. -- -- (email: sales@act-europe.fr) -- -- -- ------------------------------------------------------------------------------ -- Base package for MOMA provider. Its child packages define MOMA actual -- objects, implemented as PolyORB servants using the Minimal_Servant -- construction; they also define internal constructs. package PolyORB.MOMA_P.Provider is pragma Pure; end PolyORB.MOMA_P.Provider; polyorb-2.8~20110207.orig/src/moma/polyorb-moma_p-provider-message_consumer.adb0000644000175000017500000002615111750740340026720 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- POLYORB.MOMA_P.PROVIDER.MESSAGE_CONSUMER -- -- -- -- B o d y -- -- -- -- Copyright (C) 2002-2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- Message_Consumer servant with MOMA.Destinations; with MOMA.Types; with MOMA.Messages; with PolyORB.Any.NVList; with PolyORB.Errors; with PolyORB.Log; with PolyORB.QoS; with PolyORB.Request_QoS; with PolyORB.Types; package body PolyORB.MOMA_P.Provider.Message_Consumer is use MOMA.Messages; use MOMA.Destinations; use MOMA.Types; use PolyORB.Any; use PolyORB.Log; use PolyORB.Requests; use PolyORB.Types; package L is new PolyORB.Log.Facility_Log ("moma.provider.message_consumer"); procedure O (Message : Standard.String; Level : Log_Level := Debug) renames L.Output; function C (Level : Log_Level := Debug) return Boolean renames L.Enabled; -- Actual function implemented by the servant function Get (Self : PolyORB.References.Ref; Message_Id : MOMA.Types.String; QoS_Params : PolyORB.QoS.QoS_Parameters) return PolyORB.Any.Any; -- Return Message_Id message procedure Register_Handler (Self : access Object; Handler_Ref : PolyORB.References.Ref; Behavior : MOMA.Types.Call_Back_Behavior); -- Register a message handler -- Accessors to servant interface function Get_Parameter_Profile (Method : String) return PolyORB.Any.NVList.Ref; -- Parameters part of the interface description Message_S : constant PolyORB.Types.Identifier := To_PolyORB_String ("Message"); Message_Id_S : constant PolyORB.Types.Identifier := To_PolyORB_String ("Message_Id"); Message_Handler_S : constant PolyORB.Types.Identifier := To_PolyORB_String ("Message_Handler"); Behavior_S : constant PolyORB.Types.Identifier := To_PolyORB_String ("Behavior"); Result_S : constant PolyORB.Types.Identifier := To_PolyORB_String ("Result"); --------- -- Get -- --------- function Get (Self : PolyORB.References.Ref; Message_Id : MOMA.Types.String; QoS_Params : PolyORB.QoS.QoS_Parameters) return PolyORB.Any.Any is Argument_Mesg : constant PolyORB.Any.Any := PolyORB.Any.To_Any (PolyORB.Types.String (Message_Id)); Operation_Name : constant Standard.String := "Get"; Request : PolyORB.Requests.Request_Access; Arg_List : PolyORB.Any.NVList.Ref; Result : PolyORB.Any.NamedValue; begin PolyORB.Any.NVList.Create (Arg_List); PolyORB.Any.NVList.Add_Item (Arg_List, Message_S, Argument_Mesg, PolyORB.Any.ARG_IN); Result := (Name => Result_S, Argument => PolyORB.Any.Get_Empty_Any (TC_MOMA_Message), Arg_Modes => 0); PolyORB.Requests.Create_Request (Target => Self, Operation => Operation_Name, Arg_List => Arg_List, Result => Result, Req => Request); PolyORB.Request_QoS.Set_Request_QoS (Request.all, QoS_Params); PolyORB.Requests.Invoke (Request); PolyORB.Requests.Destroy_Request (Request); return Result.Argument; end Get; --------------------------- -- Get_Parameter_Profile -- --------------------------- function Get_Parameter_Profile (Method : String) return PolyORB.Any.NVList.Ref is use PolyORB.Any.NVList; Result : PolyORB.Any.NVList.Ref; begin PolyORB.Any.NVList.Create (Result); pragma Debug (C, O ("Parameter profile for " & Method & " requested.")); if Method = "Get" then Add_Item (Result, (Name => Message_Id_S, Argument => Get_Empty_Any (TypeCode.TC_String), Arg_Modes => ARG_IN)); elsif Method = "Register_Handler" then Add_Item (Result, (Name => Message_Handler_S, Argument => Get_Empty_Any (MOMA.Destinations.TC_MOMA_Destination), Arg_Modes => ARG_IN)); Add_Item (Result, (Name => Behavior_S, Argument => Get_Empty_Any (TypeCode.TC_String), Arg_Modes => ARG_IN)); -- XXX should use an enum type ! else raise Program_Error; end if; return Result; end Get_Parameter_Profile; -------------------- -- Get_Remote_Ref -- -------------------- function Get_Remote_Ref (Self : Object) return PolyORB.References.Ref is begin return Self.Remote_Ref; end Get_Remote_Ref; ------------ -- Invoke -- ------------ procedure Invoke (Self : access Object; Req : PolyORB.Requests.Request_Access) is use PolyORB.Any.NVList.Internals; use PolyORB.Any.NVList.Internals.NV_Lists; use PolyORB.Errors; Args : PolyORB.Any.NVList.Ref; It : Iterator; Error : Error_Container; QoS_Params : PolyORB.QoS.QoS_Parameters; begin pragma Debug (C, O ("The server is executing the request:" & PolyORB.Requests.Image (Req.all))); PolyORB.Any.NVList.Create (Args); if Req.Operation.all = "Get" then PolyORB.Any.NVList.Add_Item (Args, (Name => Message_Id_S, Argument => Get_Empty_Any (TypeCode.TC_String), Arg_Modes => PolyORB.Any.ARG_IN)); Arguments (Req, Args, Error); if Found (Error) then raise Program_Error; -- XXX We should do something more contructive end if; QoS_Params (PolyORB.QoS.Static_Priority) := PolyORB.Request_QoS.Extract_Request_Parameter (PolyORB.QoS.Static_Priority, Req.all); It := First (List_Of (Args).all); Set_Result (Req, Get (Self.Remote_Ref, MOMA.Types.String (PolyORB.Types.String'(PolyORB.Any.From_Any (Value (It).Argument))), QoS_Params)); pragma Debug (C, O ("Result: " & Image (Req.Result))); elsif Req.Operation.all = "Register_Handler" then -- Register Message call_back handler pragma Debug (C, O ("Register_Handler request")); Args := Get_Parameter_Profile (Req.Operation.all); PolyORB.Requests.Arguments (Req, Args, Error); if Found (Error) then raise Program_Error; -- XXX We should do something more contructive end if; declare Handler_Dest, Behavior : Element_Access; begin It := First (List_Of (Args).all); Handler_Dest := Value (It); Next (It); Behavior := Value (It); Register_Handler (Self, MOMA.Destinations.Get_Ref (MOMA.Destinations.From_Any (Handler_Dest.Argument)), MOMA.Types.Call_Back_Behavior'Value (MOMA.Types.To_Standard_String (MOMA.Types.From_Any (Behavior.Argument)))); pragma Debug (C, O ("Handler registered")); end; else pragma Debug (C, O ("Unrecognized request " & Req.Operation.all)); null; end if; end Invoke; ---------------------- -- Register_Handler -- ---------------------- procedure Register_Handler (Self : access Object; Handler_Ref : PolyORB.References.Ref; Behavior : MOMA.Types.Call_Back_Behavior) is Request : PolyORB.Requests.Request_Access; Arg_List : PolyORB.Any.NVList.Ref; Result : PolyORB.Any.NamedValue; Handler_Dest : constant MOMA.Destinations.Destination := MOMA.Destinations.Create_Destination (To_PolyORB_String (""), Handler_Ref); begin pragma Debug (C, O ("Registering Message_Handler with " & Call_Back_Behavior'Image (Behavior) & " behavior")); PolyORB.Any.NVList.Create (Arg_List); PolyORB.Any.NVList.Add_Item (Arg_List, Message_Handler_S, To_Any (Handler_Dest), PolyORB.Any.ARG_IN); PolyORB.Any.NVList.Add_Item (Arg_List, Behavior_S, PolyORB.Any.To_Any (To_PolyORB_String (Call_Back_Behavior'Image (Behavior))), PolyORB.Any.ARG_IN); Result := (Name => Result_S, Argument => PolyORB.Any.Get_Empty_Any (TypeCode.TC_Void), Arg_Modes => 0); PolyORB.Requests.Create_Request (Target => Self.Remote_Ref, Operation => "Register_Handler", Arg_List => Arg_List, Result => Result, Req => Request); PolyORB.Requests.Invoke (Request); pragma Debug (C, O ("Register_Handler request complete")); PolyORB.Requests.Destroy_Request (Request); pragma Debug (C, O ("Register_Handler request destroyed")); end Register_Handler; -------------------- -- Set_Remote_Ref -- -------------------- procedure Set_Remote_Ref (Self : in out Object; Ref : PolyORB.References.Ref) is begin Self.Remote_Ref := Ref; end Set_Remote_Ref; end PolyORB.MOMA_P.Provider.Message_Consumer; polyorb-2.8~20110207.orig/src/moma/polyorb-moma_p-provider-message_pool.ads0000644000175000017500000000743111750740340026057 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- POLYORB.MOMA_P.PROVIDER.MESSAGE_POOL -- -- -- -- S p e c -- -- -- -- Copyright (C) 2003-2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- Actual implementation of the Message_Pool object. It is derived -- from PolyORB's Minimal_Servant. This package contains Message_Pool -- skeleton and implementation subroutines. with MOMA.Types; with PolyORB.MOMA_P.Provider.Warehouse; with PolyORB.Minimal_Servant; with PolyORB.References; with PolyORB.Requests; package PolyORB.MOMA_P.Provider.Message_Pool is type Object is new PolyORB.Minimal_Servant.Servant with private; type Object_Acc is access Object; procedure Initialize (Self : access Object; Info : MOMA.Types.Message_Pool); -- Initialize the object. procedure Invoke (Self : access Object; Req : PolyORB.Requests.Request_Access); -- Message_Pool servant skeleton. private use MOMA.Types; use PolyORB.References; type Object is new PolyORB.Minimal_Servant.Servant with record Pool : MOMA.Types.Message_Pool; -- Pool information. W : PolyORB.MOMA_P.Provider.Warehouse.Warehouse; -- XXX up to now, we use one and only one Warehouse, per -- message_pool, more warehouses would require message analysis, -- => to be done later, after proper message definition. Message_Id : Natural := 0; -- XXX Dummy counter for message_id, to be trashed ... Last_Read_Id : Natural := 0; -- XXX Dummy counter for message_id, to be trashed ... Message_Handler : PolyORB.References.Ref := PolyORB.References.Nil_Ref; -- Reference of the Message_Handler to which Notify or Handle -- Requests must be sent. Behavior : MOMA.Types.Call_Back_Behavior := None; -- Specifies if a Notify or Handle request must be sent on reception -- of a message, or none. end record; end PolyORB.MOMA_P.Provider.Message_Pool; polyorb-2.8~20110207.orig/src/polyorb-smart_pointers-sync_counters__intrinsic.adb0000644000175000017500000000544411750740340027522 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- POLYORB.SMART_POINTERS.SYNC_COUNTERS -- -- -- -- B o d y -- -- -- -- Copyright (C) 2009, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ separate (PolyORB.Smart_Pointers) package body Sync_Counters is ---------------- -- Initialize -- ---------------- procedure Initialize is begin null; end Initialize; ------------------------ -- Sync_Add_And_Fetch -- ------------------------ function Sync_Add_And_Fetch (Ptr : access Interfaces.Integer_32; Value : Interfaces.Integer_32) return Interfaces.Integer_32 is function Intrinsic_Sync_Add_And_Fetch (Ptr : access Interfaces.Integer_32; Value : Interfaces.Integer_32) return Interfaces.Integer_32; pragma Import (Intrinsic, Intrinsic_Sync_Add_And_Fetch, "__sync_add_and_fetch_4"); begin return Intrinsic_Sync_Add_And_Fetch (Ptr, Value); end Sync_Add_And_Fetch; end Sync_Counters; polyorb-2.8~20110207.orig/src/polyorb-utils-random.adb0000644000175000017500000001174611750740340021754 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . U T I L S . R A N D O M -- -- -- -- B o d y -- -- -- -- Copyright (C) 2003-2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ package body PolyORB.Utils.Random is use PolyORB.Types; M : constant := 397; -- Period parameter Upper_Mask : constant := 16#80000000#; -- Most significant w-r bits Lower_Mask : constant := 16#7FFFFFFF#; -- Least significant r bits ----------- -- Magic -- ----------- function Magic (S : Unsigned_Long) return Unsigned_Long; -- Return magic value for computation in random number generation function Magic (S : Unsigned_Long) return Unsigned_Long is begin if (S and 16#1#) = 1 then return 16#9908B0DF#; else return 0; end if; end Magic; ------------ -- Random -- ------------ function Random (G : access Generator) return PolyORB.Types.Unsigned_Long is S : Unsigned_Long; begin if G.Gen_State.Condition >= N then if G.Gen_State.Condition = Invalid then -- The generator is not initialized raise Program_Error; end if; for J in 0 .. N - M - 1 loop S := (G.Gen_State.Vector_N (J) and Upper_Mask) or (G.Gen_State.Vector_N (J + 1) and Lower_Mask); G.Gen_State.Vector_N (J) := G.Gen_State.Vector_N (J + M) xor Shift_Right (S, 1) xor Magic (S); end loop; for J in N - M .. N - 2 loop S := (G.Gen_State.Vector_N (J) and Upper_Mask) or (G.Gen_State.Vector_N (J + 1) and Lower_Mask); G.Gen_State.Vector_N (J) := G.Gen_State.Vector_N (J + (M - N)) xor Shift_Right (S, 1) xor Magic (S); end loop; S := (G.Gen_State.Vector_N (N - 1) and Upper_Mask) or (G.Gen_State.Vector_N (0) and Lower_Mask); G.Gen_State.Vector_N (N - 1) := G.Gen_State.Vector_N (M - 1) xor Shift_Right (S, 1) xor Magic (S); G.Gen_State.Condition := 0; end if; -- Tempering S := G.Gen_State.Vector_N (G.Gen_State.Condition); G.Gen_State.Condition := G.Gen_State.Condition + 1; S := S xor Shift_Right (S, 11); S := S xor (Shift_Left (S, 7) and 16#9D2C5680#); S := S xor (Shift_Left (S, 15) and 16#EFC60000#); S := S xor Shift_Right (S, 18); return S; end Random; ----------- -- Reset -- ----------- procedure Reset (G : access Generator; Seed : Seed_Type := Default_Seed) is begin G.Gen_State.Seed := Seed; G.Gen_State.Vector_N (0) := Unsigned_Long (G.Gen_State.Seed) and 16#FFFFFFFF#; -- See Knuth, "The Art Of Computer Programming" (Vol2. 3rd Ed. p.106) -- for multiplier. for J in 1 .. N loop G.Gen_State.Vector_N (J) := 1_812_433_253 * (G.Gen_State.Vector_N (J - 1) xor Shift_Right (G.Gen_State.Vector_N (J - 1), 30)) + Unsigned_Long (J); G.Gen_State.Vector_N (J) := G.Gen_State.Vector_N (J) and 16#FFFFFFFF#; end loop; G.Gen_State.Condition := N; end Reset; end PolyORB.Utils.Random; polyorb-2.8~20110207.orig/src/polyorb-request_scheduler.ads0000644000175000017500000000647111750740340023104 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . R E Q U E S T _ S C H E D U L E R -- -- -- -- S p e c -- -- -- -- Copyright (C) 2004 Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by ACT Europe. -- -- (email: sales@act-europe.fr) -- -- -- ------------------------------------------------------------------------------ with PolyORB.Jobs; with PolyORB.References; package PolyORB.Request_Scheduler is ----------------------- -- Request_Scheduler -- ----------------------- type Request_Scheduler is abstract tagged limited null record; type Request_Scheduler_Access is access all Request_Scheduler'Class; function Try_Queue_Request_Job (Self : access Request_Scheduler; Job : PolyORB.Jobs.Job_Access; Target : PolyORB.References.Ref) return Boolean is abstract; -- Try to have Job scheduled by Self, return False if the request -- scheduler refuses Job. ------------------------------- -- Request_Scheduler_Factory -- ------------------------------- type Request_Scheduler_Factory is abstract tagged limited null record; type Request_Scheduler_Factory_Access is access all Request_Scheduler_Factory'Class; function Create (RSF : access Request_Scheduler_Factory) return Request_Scheduler_Access is abstract; -- Use factory to create a new Request_Scheduler procedure Register_Request_Scheduler_Factory (RSF : Request_Scheduler_Factory_Access); -- Register a Request_Scheduler factory procedure Create (RS : out Request_Scheduler_Access); -- Initialize a Request_Scheduler end PolyORB.Request_Scheduler; polyorb-2.8~20110207.orig/src/polyorb-poa_policies-servant_retention_policy-non_retain.ads0000644000175000017500000000741111750740340031277 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- POLYORB.POA_POLICIES.SERVANT_RETENTION_POLICY.NON_RETAIN -- -- -- -- S p e c -- -- -- -- Copyright (C) 2002-2005 Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ package PolyORB.POA_Policies.Servant_Retention_Policy.Non_Retain is type Non_Retain_Policy is new ServantRetentionPolicy with null record; type Non_Retain_Policy_Access is access all Non_Retain_Policy; function Create return Non_Retain_Policy_Access; procedure Check_Compatibility (Self : Non_Retain_Policy; Other_Policies : AllPolicies; Error : in out PolyORB.Errors.Error_Container); function Policy_Id (Self : Non_Retain_Policy) return String; procedure Retain_Servant_Association (Self : Non_Retain_Policy; OA : PolyORB.POA_Types.Obj_Adapter_Access; P_Servant : Servants.Servant_Access; U_Oid : Unmarshalled_Oid; Error : in out PolyORB.Errors.Error_Container); procedure Forget_Servant_Association (Self : Non_Retain_Policy; OA : PolyORB.POA_Types.Obj_Adapter_Access; U_Oid : Unmarshalled_Oid; Error : in out PolyORB.Errors.Error_Container); function Retained_Servant_To_Id (Self : Non_Retain_Policy; OA : PolyORB.POA_Types.Obj_Adapter_Access; P_Servant : Servants.Servant_Access) return Object_Id_Access; procedure Retained_Id_To_Servant (Self : Non_Retain_Policy; OA : PolyORB.POA_Types.Obj_Adapter_Access; U_Oid : Unmarshalled_Oid; Servant : out Servants.Servant_Access; Error : in out PolyORB.Errors.Error_Container); procedure Ensure_Servant_Manager_Type (Self : Non_Retain_Policy; Manager : ServantManager'Class; Error : in out PolyORB.Errors.Error_Container); end PolyORB.POA_Policies.Servant_Retention_Policy.Non_Retain; polyorb-2.8~20110207.orig/src/polyorb-tasking-rw_locks.ads0000644000175000017500000001053011750740340022626 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . T A S K I N G . R W _ L O C K S -- -- -- -- S p e c -- -- -- -- Copyright (C) 2002-2003 Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by ACT Europe. -- -- (email: sales@act-europe.fr) -- -- -- ------------------------------------------------------------------------------ -- Inter-process synchronisation objects. with PolyORB.Tasking.Condition_Variables; package PolyORB.Tasking.Rw_Locks is pragma Preelaborate; ---------------------------- -- A readers/writers lock -- ---------------------------- -- Several tasks can own the lock in read (shared) mode. -- Only one task can own the lock in write (exclusive) mode. -- No task can own the lock in exclusive mode while any other -- task owns it in read mode. -- The contention resolution policy gives priority to -- writers: as long as a task is blocked waiting for -- write access, requests for read access are declined. type Rw_Lock_Type is limited private; type Rw_Lock_Access is access all Rw_Lock_Type; procedure Create (L : out Rw_Lock_Access); procedure Destroy (L : in out Rw_Lock_Access); procedure Lock_W (L : access Rw_Lock_Type); -- Get lock in write mode. procedure Lock_R (L : access Rw_Lock_Type); -- Get lock in read mode. procedure Unlock_W (L : access Rw_Lock_Type); -- Release write mode lock. procedure Unlock_R (L : access Rw_Lock_Type); -- Release read mode lock. function Is_Set_W (L : access Rw_Lock_Type) return Boolean; -- Return True if the lock is held in write mode. function Is_Set_R (L : access Rw_Lock_Type) return Boolean; -- Return True if the lock is held in read mode. procedure Set_Max_Count (L : access Rw_Lock_Type; Max : Natural); -- Set maximum number of readers. private type Rw_Lock_Type is limited record Guard_Values : Tasking.Condition_Variables.Condition_Access; -- This condition is signalled each time an attribute -- of the Rw_Lock_Type that is used in a guard clause -- is changed. Readers_Waiting : Natural := 0; Writers_Waiting : Natural := 0; Serial : Integer := 0; -- Debug information, Rw_Lock identifier. Count : Integer := 0; -- Current readers, or -1 if held for writing. -- If Count > 0, it is the number of tasks owning the lock in R mode. -- Count = 0, no tasks own the lock. -- Count = -1, a task is owning the lock in W mode. Max_Count : Natural := Natural'Last; -- Maximum number of readers. end record; pragma Inline (Is_Set_W); pragma Inline (Is_Set_R); end PolyORB.Tasking.Rw_Locks; polyorb-2.8~20110207.orig/src/polyorb-poa_config-root_poa.adb0000644000175000017500000001017011750740340023250 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . P O A _ C O N F I G . R O O T _ P O A -- -- -- -- B o d y -- -- -- -- Copyright (C) 2003 Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by ACT Europe. -- -- (email: sales@act-europe.fr) -- -- -- ------------------------------------------------------------------------------ -- A POA configuration corresponding to minimumCORBA policies. with PolyORB.POA_Policies; with PolyORB.POA_Policies.Id_Assignment_Policy.System; with PolyORB.POA_Policies.Id_Uniqueness_Policy.Unique; with PolyORB.POA_Policies.Implicit_Activation_Policy.Activation; with PolyORB.POA_Policies.Lifespan_Policy.Transient; with PolyORB.POA_Policies.Request_Processing_Policy.Active_Object_Map_Only; with PolyORB.POA_Policies.Servant_Retention_Policy.Retain; with PolyORB.POA_Policies.Thread_Policy.ORB_Ctrl; package body PolyORB.POA_Config.Root_POA is use PolyORB.POA_Policies; My_Default_Policies : PolicyList; Initialized : Boolean := False; ---------------- -- Initialize -- ---------------- procedure Initialize (C : Root_POA_Configuration) is pragma Warnings (Off); pragma Unreferenced (C); pragma Warnings (On); use PolyORB.POA_Policies.Policy_Lists; begin if Initialized then return; end if; Append (My_Default_Policies, Policy_Access (Id_Assignment_Policy.System.Create)); Append (My_Default_Policies, Policy_Access (Id_Uniqueness_Policy.Unique.Create)); Append (My_Default_Policies, Policy_Access (Implicit_Activation_Policy.Activation.Create)); Append (My_Default_Policies, Policy_Access (Lifespan_Policy.Transient.Create)); Append (My_Default_Policies, Policy_Access (Request_Processing_Policy.Active_Object_Map_Only.Create)); Append (My_Default_Policies, Policy_Access (Servant_Retention_Policy.Retain.Create)); Append (My_Default_Policies, Policy_Access (Thread_Policy.ORB_Ctrl.Create)); Initialized := True; end Initialize; ---------------------- -- Default_Policies -- ---------------------- function Default_Policies (C : Root_POA_Configuration) return PolyORB.POA_Policies.PolicyList is begin if not Initialized then Initialize (C); end if; return My_Default_Policies; end Default_Policies; end PolyORB.POA_Config.Root_POA; polyorb-2.8~20110207.orig/src/polyorb-obj_adapters.ads0000644000175000017500000002002311750740340022000 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . O B J _ A D A P T E R S -- -- -- -- S p e c -- -- -- -- Copyright (C) 2001-2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- This package provides the root definition of all Object adapters. -- An Object Adapter manages the association of references to servants. with PolyORB.Annotations; with PolyORB.Any; with PolyORB.Any.NVList; with PolyORB.Errors; with PolyORB.Objects; with PolyORB.QoS; with PolyORB.References; with PolyORB.Servants; with PolyORB.Smart_Pointers; with PolyORB.Types; package PolyORB.Obj_Adapters is type Obj_Adapter is abstract new Smart_Pointers.Non_Controlled_Entity with private; type Obj_Adapter_Access is access all Obj_Adapter'Class; procedure Create (OA : access Obj_Adapter) is abstract; -- Set up OA's internal structures procedure Destroy (OA : access Obj_Adapter); -- Deallocate OA's internal structures procedure Finalize (OA : in out Obj_Adapter); -- Makes a dispatching call on Destroy -------------------------------------- -- Interface to application objects -- -------------------------------------- procedure Export (OA : access Obj_Adapter; Obj : Servants.Servant_Access; Key : Objects.Object_Id_Access; Oid : out Objects.Object_Id_Access; Error : in out PolyORB.Errors.Error_Container) is abstract; -- Create an identifier for Obj within OA. If Key is not null, use it as -- an application-level identifier for the object (which will be used to -- construct the local identifier). procedure Unexport (OA : access Obj_Adapter; Id : Objects.Object_Id_Access; Error : in out PolyORB.Errors.Error_Container) is abstract; -- Id is an object identifier attributed by OA. The corresponding -- association is suppressed. procedure Object_Key (OA : access Obj_Adapter; Id : Objects.Object_Id_Access; User_Id : out Objects.Object_Id_Access; Error : in out PolyORB.Errors.Error_Container) is abstract; -- If Id is user defined associated with Id, return user identifier -- component of Id, else raise an error. procedure Get_QoS (OA : access Obj_Adapter; Id : Objects.Object_Id; QoS : out PolyORB.QoS.QoS_Parameters; Error : in out PolyORB.Errors.Error_Container) is abstract; -- Return the QoS information managed by object adapter OA, for -- object denoted by Id. ---------------------------------------------------- -- Interface to ORB (acting on behalf of clients) -- ---------------------------------------------------- function Get_Empty_Arg_List (OA : access Obj_Adapter; Oid : access Objects.Object_Id; Method : String) return Any.NVList.Ref is abstract; -- Return the parameter profile of the given method, so the protocol layer -- can unmarshall the message into a Request object. function Get_Empty_Result (OA : access Obj_Adapter; Oid : access Objects.Object_Id; Method : String) return Any.Any is abstract; -- Return the result profile of the given method procedure Find_Servant (OA : access Obj_Adapter; Id : access Objects.Object_Id; Servant : out Servants.Servant_Access; Error : in out PolyORB.Errors.Error_Container) is abstract; -- Retrieve the servant managed by OA for logical object Id. The servant -- that incarnates the object is returned. procedure Release_Servant (OA : access Obj_Adapter; Id : access Objects.Object_Id; Servant : in out Servants.Servant_Access) is abstract; -- Signal to OA that a Servant previously obtained using Find_Servant won't -- be used by the client anymore. This may cause the servant to be -- destroyed if so is OA's policy. ---------------------------------- -- Export of object identifiers -- ---------------------------------- procedure Oid_To_Rel_URI (OA : access Obj_Adapter; Id : access Objects.Object_Id; URI : out Types.String; Error : in out PolyORB.Errors.Error_Container); function Rel_URI_To_Oid (OA : access Obj_Adapter; URI : String) return Objects.Object_Id_Access; -- Convert an object id from/to its representation as a relative URI. A -- default implementation of these functions is provided; actual object -- adapters may overload them if desired. -------------------------------- -- Proxy namespace management -- -------------------------------- -- The object id name space is managed entirely by the object adapter. -- Consequently, the OA is also responsible for assigning object IDs to -- virtual proxy objects corresponding to object references for which we -- act as a proxy. function Is_Proxy_Oid (OA : access Obj_Adapter; Oid : access Objects.Object_Id) return Boolean; -- Determine whether Oid is the identifier for a proxy object. Always -- False if OA does not support proxy objects. procedure To_Proxy_Oid (OA : access Obj_Adapter; R : References.Ref; Oid : out Objects.Object_Id_Access; Error : in out PolyORB.Errors.Error_Container); -- Create a proxy oid for reference R. No_Implement_E is thrown if OA -- does not support proxy objects. procedure Proxy_To_Ref (OA : access Obj_Adapter; Oid : access Objects.Object_Id; Ref : out References.Ref; Error : in out PolyORB.Errors.Error_Container); -- Retrieve the reference for which Oid is a proxy oid into Ref. -- No_Implement_E is thrown if OA does not support proxy objects. ---------------------------- -- Annotations management -- ---------------------------- function Notepad_Of (OA : access Obj_Adapter) return Annotations.Notepad_Access; private type Obj_Adapter is abstract new Smart_Pointers.Non_Controlled_Entity with record Notepad : aliased Annotations.Notepad; -- OA's notepad. The user is responsible for ensuring protection -- against incorrect concurrent accesses. end record; end PolyORB.Obj_Adapters; polyorb-2.8~20110207.orig/src/polyorb-orb_controller-half_sync_half_async.adb0000644000175000017500000004164311750740340026515 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- POLYORB.ORB_CONTROLLER.HALF_SYNC_HALF_ASYNC -- -- -- -- B o d y -- -- -- -- Copyright (C) 2004-2011, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with Ada.Tags; with PolyORB.Asynch_Ev; with PolyORB.Initialization; with PolyORB.Utils.Strings; package body PolyORB.ORB_Controller.Half_Sync_Half_Async is use PolyORB.Asynch_Ev; use PolyORB.Task_Info; use PolyORB.Tasking.Condition_Variables; use PolyORB.Tasking.Mutexes; function AEM_Index_Of_Task (O : access ORB_Controller_Half_Sync_Half_Async; TI : Task_Info_Access) return Natural; -- For a monitoring task, return the index of its AEM. For any other task, -- return 0. ----------------------- -- AEM_Index_Of_Task -- ----------------------- function AEM_Index_Of_Task (O : access ORB_Controller_Half_Sync_Half_Async; TI : Task_Info_Access) return Natural is begin for J in O.AEM_Infos'Range loop if O.AEM_Infos (J).TI = TI then return J; end if; end loop; return 0; end AEM_Index_Of_Task; --------------------- -- Disable_Polling -- --------------------- procedure Disable_Polling (O : access ORB_Controller_Half_Sync_Half_Async; M : PAE.Asynch_Ev_Monitor_Access) is AEM_Index : constant Natural := Index (O.all, M); begin -- Force all tasks currently waiting on event sources to abort if O.AEM_Infos (AEM_Index).TI /= null and then State (O.AEM_Infos (AEM_Index).TI.all) = Blocked then -- First condition is a guard for the case where no monitoring task -- has been registered yet for this AEM (can this actually happen???) -- Second condition handles the fact that the designated monitoring -- task may not be Blocked (can be Running while processing detected -- events). pragma Debug (C1, O1 ("Disable_Polling: Aborting polling task")); PTI.Request_Abort_Polling (O.AEM_Infos (AEM_Index).TI.all); PolyORB.Asynch_Ev.Abort_Check_Sources (Selector (O.AEM_Infos (AEM_Index).TI.all).all); pragma Debug (C1, O1 ("Disable_Polling: waiting abort is complete")); O.AEM_Infos (AEM_Index).Polling_Abort_Counter := O.AEM_Infos (AEM_Index).Polling_Abort_Counter + 1; Wait (O.AEM_Infos (AEM_Index).Polling_Completed, O.ORB_Lock); O.AEM_Infos (AEM_Index).Polling_Abort_Counter := O.AEM_Infos (AEM_Index).Polling_Abort_Counter - 1; pragma Debug (C1, O1 ("Disable_Polling: aborting done")); end if; end Disable_Polling; -------------------- -- Enable_Polling -- -------------------- procedure Enable_Polling (O : access ORB_Controller_Half_Sync_Half_Async; M : PAE.Asynch_Ev_Monitor_Access) is AEM_Index : constant Natural := Index (O.all, M); begin pragma Debug (C1, O1 ("Enable_Polling: enter")); if O.AEM_Infos (AEM_Index).Polling_Abort_Counter = 0 and then O.Monitoring_Tasks (AEM_Index).Idle then -- Awake monitoring task O.Monitoring_Tasks (AEM_Index).Idle := False; pragma Debug (C1, O1 ("Enable_Polling: awake monitoring task")); Signal (O.Monitoring_Tasks (AEM_Index).CV); end if; end Enable_Polling; ------------------ -- Notify_Event -- ------------------ procedure Notify_Event (O : access ORB_Controller_Half_Sync_Half_Async; E : Event) is use type PRS.Request_Scheduler_Access; use type PolyORB.Tasking.Threads.Thread_Id; begin pragma Debug (C1, O1 ("Notify_Event: " & Event_Kind'Image (E.Kind))); case E.Kind is when End_Of_Check_Sources => declare AEM_Index : constant Natural := Index (O.all, E.On_Monitor); begin -- A task completed polling on a monitor pragma Debug (C1, O1 ("End of check sources on monitor #" & Natural'Image (AEM_Index) & Ada.Tags.External_Tag (O.AEM_Infos (AEM_Index).Monitor.all'Tag))); if O.AEM_Infos (AEM_Index).Polling_Abort_Counter > 0 then -- This task has been aborted by one or more tasks, we -- broadcast them. Broadcast (O.AEM_Infos (AEM_Index).Polling_Completed); end if; end; when Event_Sources_Added => declare AEM_Index : Natural := Index (O.all, E.Add_In_Monitor); begin if AEM_Index = 0 then -- This monitor was not yet registered, register it pragma Debug (C1, O1 ("Adding new monitor")); for J in O.AEM_Infos'Range loop if O.AEM_Infos (J).Monitor = null then O.AEM_Infos (J).Monitor := E.Add_In_Monitor; AEM_Index := J; exit; end if; end loop; end if; pragma Debug (C1, O1 ("Added monitor at index:" & AEM_Index'Img & " " & Ada.Tags.External_Tag (O.AEM_Infos (AEM_Index).Monitor.all'Tag))); if O.AEM_Infos (AEM_Index).TI /= null and then not O.AEM_Infos (AEM_Index).Polling_Scheduled and then O.Monitoring_Tasks (AEM_Index).Idle then -- No task is currently polling, allocate one O.AEM_Infos (AEM_Index).Polling_Scheduled := True; O.Monitoring_Tasks (AEM_Index).Idle := False; Signal (O.Monitoring_Tasks (AEM_Index).CV); end if; end; when Event_Sources_Deleted => null; when Job_Completed => -- A task has completed the execution of a job null; when ORB_Shutdown => -- ORB shutdown has been requested O.Shutdown := True; -- Awake all idle tasks Awake_All_Idle_Tasks (O.Idle_Tasks); -- Unblock blocked tasks for J in O.AEM_Infos'Range loop -- Note: if polling is temporarily disabled, then the polling -- tasks may be Idle and have a null Selector. if O.AEM_Infos (J).TI /= null and then State (O.AEM_Infos (J).TI.all) = Blocked then PTI.Request_Abort_Polling (O.AEM_Infos (J).TI.all); PolyORB.Asynch_Ev.Abort_Check_Sources (Selector (O.AEM_Infos (J).TI.all).all); end if; end loop; when Queue_Event_Job => -- Queue event to monitoring job queue; the corresponding AES -- has been removed from its monitor. -- Inefficient to scan the Monitoring_Tasks array, this should -- be an annotation on the originating BO or AES??? for J in O.Monitoring_Tasks'Range loop if E.By_Task = Id (O.AEM_Infos (J).TI.all) then pragma Debug (C1, O1 ("Job queued by monitoring task")); PJ.Queue_Job (O.Monitoring_Tasks (J).Job_Queue, E.Event_Job); return; end if; end loop; -- Failure to queue event job denotes an abnormal situation, since -- by construction an associated monitoring task should have been -- established, associated with the binding object. raise Program_Error; when Queue_Request_Job => declare Job_Queued : Boolean := False; begin if O.RS /= null then Leave_ORB_Critical_Section (O); Job_Queued := PRS.Try_Queue_Request_Job (O.RS, E.Request_Job, E.Target); Enter_ORB_Critical_Section (O); end if; if not Job_Queued then -- Default: Queue request to main job queue pragma Debug (C1, O1 ("Queue Request_Job to default queue")); PJ.Queue_Job (O.Job_Queue, E.Request_Job); Try_Allocate_One_Task (O, Allow_Transient => not Is_Upcall (E.Request_Job.all)); -- We don't want the ORB to borrow a transient task to -- make an upcall to application code, because this could -- take a long time or even deadlock. end if; end; when Request_Result_Ready => -- A Request has been completed and a response is available. We -- must forward it to requesting task. Ensure the requesting task -- is rescheduled now. Reschedule_Task (O, E.Requesting_Task); when Idle_Awake => -- A task has left Idle state. Note that the monitoring tasks are -- managed internally by the ORB controller, not by the idle -- tasks manager. if AEM_Index_Of_Task (O, E.Awakened_Task) = 0 then Remove_Idle_Task (O.Idle_Tasks, E.Awakened_Task); end if; when Task_Registered => -- The O.AEM_Infos'Length first registered tasks will poll -- the corresponding event monitors. for J in O.AEM_Infos'Range loop if O.AEM_Infos (J).TI = null then pragma Debug (C1, O1 ("Registered monitoring task")); O.AEM_Infos (J).TI := E.Registered_Task; pragma Assert (E.Registered_Task.Kind = Permanent); -- Prevent task from terminating when going idle Set_May_Exit (E.Registered_Task.all, May_Exit => False); end if; end loop; when Task_Unregistered => declare Index : constant Integer := AEM_Index_Of_Task (O, E.Unregistered_Task); begin if Index in O.AEM_Infos'Range then -- Unregistering one of the designated monitoring tasks -- (happens during partition termination). O.AEM_Infos (Index).TI := null; end if; end; Note_Task_Unregistered (O); end case; pragma Debug (C2, O2 (Status (O.all))); end Notify_Event; ------------------- -- Schedule_Task -- ------------------- procedure Schedule_Task (O : access ORB_Controller_Half_Sync_Half_Async; TI : PTI.Task_Info_Access) is AEM_Index : Natural; begin pragma Debug (C1, O1 ("Schedule_Task " & PTI.Image (TI.all) & ": enter")); if State (TI.all) = Terminated then pragma Debug (C1, O1 ("Schedule_Task: task is terminated")); return; end if; Set_State_Unscheduled (O.Summary, TI.all); -- Recompute TI status if Exit_Condition (TI.all) or else (O.Shutdown and then not Has_Pending_Job (O) and then TI.Kind = Permanent) then Set_State_Terminated (O.Summary, TI.all); pragma Debug (C1, O1 ("Task is now terminated")); pragma Debug (C2, O2 (Status (O.all))); else AEM_Index := AEM_Index_Of_Task (O, TI); if AEM_Index > 0 then -- Task is a monitoring task pragma Debug (C1, O1 ("Scheduling monitoring task")); if not PJ.Is_Empty (O.Monitoring_Tasks (AEM_Index).Job_Queue) then -- Process event on the monitor Set_State_Running (O.Summary, TI.all, PJ.Fetch_Job (O.Monitoring_Tasks (AEM_Index).Job_Queue)); elsif O.AEM_Infos (AEM_Index).Polling_Abort_Counter = 0 and then O.AEM_Infos (AEM_Index).Monitor /= null and then Has_Sources (O.AEM_Infos (AEM_Index).Monitor.all) then -- Monitor O.AEM_Infos (AEM_Index).Polling_Scheduled := False; Set_State_Blocked (O.Summary, TI.all, O.AEM_Infos (AEM_Index).Monitor, O.AEM_Infos (AEM_Index).Polling_Timeout); pragma Debug (C1, O1 ("Task is now blocked")); pragma Debug (C2, O2 (Status (O.all))); else -- Go idle. Note that monitoring tasks that go idle are managed -- directly by the ORB controller rather than by the idle tasks -- manager. O.Monitoring_Tasks (AEM_Index).Idle := True; pragma Debug (C1, O1 ("Task is now idle")); pragma Debug (C2, O2 (Status (O.all))); Set_State_Idle (O.Summary, TI.all, O.Monitoring_Tasks (AEM_Index).CV, O.ORB_Lock); end if; else -- Task is a processing task if Has_Pending_Job (O) then -- Case of the pending job being an upcall when the current -- task is transient??? Set_State_Running (O.Summary, TI.all, PJ.Fetch_Job (O.Job_Queue)); pragma Debug (C1, O1 ("Task is now running a job")); pragma Debug (C2, O2 (Status (O.all))); else Set_State_Idle (O.Summary, TI.all, Insert_Idle_Task (O.Idle_Tasks, TI), O.ORB_Lock); pragma Debug (C1, O1 ("Task is now idle")); pragma Debug (C2, O2 (Status (O.all))); end if; end if; end if; end Schedule_Task; ------------ -- Create -- ------------ function Create (OCF : ORB_Controller_Half_Sync_Half_Async_Factory) return ORB_Controller_Access is pragma Unreferenced (OCF); OC : ORB_Controller_Half_Sync_Half_Async_Access; RS : PRS.Request_Scheduler_Access; begin PRS.Create (RS); OC := new ORB_Controller_Half_Sync_Half_Async (RS); for J in OC.Monitoring_Tasks'Range loop Create (OC.Monitoring_Tasks (J).CV); OC.Monitoring_Tasks (J).Job_Queue := PolyORB.Jobs.Create_Queue; end loop; Initialize (ORB_Controller (OC.all)); return ORB_Controller_Access (OC); end Create; ---------------- -- Initialize -- ---------------- procedure Initialize; procedure Initialize is begin Register_ORB_Controller_Factory (OCF); end Initialize; use PolyORB.Initialization; use PolyORB.Initialization.String_Lists; use PolyORB.Utils.Strings; begin Register_Module (Module_Info' (Name => +"orb_controller.half_sync_half_async", Conflicts => +"orb.no_tasking", Depends => +"tasking.condition_variables" & "tasking.mutexes" & "request_scheduler?", Provides => +"orb_controller!", Implicit => False, Init => Initialize'Access, Shutdown => null)); end PolyORB.ORB_Controller.Half_Sync_Half_Async; polyorb-2.8~20110207.orig/src/polyorb-qos.ads0000644000175000017500000000575011750740340020157 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . Q O S -- -- -- -- S p e c -- -- -- -- Copyright (C) 2005-2009, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- This package defines the Quality of Service (QoS) parameters to be -- associated with Requets, Object Adapters and Profiles package PolyORB.QoS is pragma Preelaborate; -- List of supported QoS policies type QoS_Kind is (Static_Priority, Ada_Exception_Information, GIOP_Code_Sets, GIOP_Addressing_Mode, GIOP_Service_Contexts, GIOP_Tagged_Components, DSA_TM_Info, Compound_Security, Transport_Security, GIOP_Static_Buffer); -- Definition of QoS parameters type QoS_Parameter (Kind : QoS_Kind) is abstract tagged null record; type QoS_Parameter_Access is access all QoS_Parameter'Class; procedure Release_Contents (QoS : access QoS_Parameter); procedure Release (QoS : in out QoS_Parameter_Access); type QoS_Parameters is array (QoS_Kind) of QoS_Parameter_Access; function Image (QoS : QoS_Parameters) return String; -- For debugging purposes. Return an image of QoS end PolyORB.QoS; polyorb-2.8~20110207.orig/src/polyorb-poa_policies-request_processing_policy-use_default_servant.ads0000644000175000017500000000707411750740340033365 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- POLYORB.POA_POLICIES.REQUEST_PROCESSING_POLICY.USE_DEFAULT_SERVANT -- -- -- -- S p e c -- -- -- -- Copyright (C) 2002-2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ package PolyORB.POA_Policies.Request_Processing_Policy.Use_Default_Servant is type Use_Default_Servant_Policy is new RequestProcessingPolicy with null record; type Use_Default_Servant_Policy_Access is access all Use_Default_Servant_Policy; function Create return Use_Default_Servant_Policy_Access; procedure Check_Compatibility (Self : Use_Default_Servant_Policy; Other_Policies : AllPolicies; Error : in out PolyORB.Errors.Error_Container); function Policy_Id (Self : Use_Default_Servant_Policy) return String; procedure Id_To_Servant (Self : Use_Default_Servant_Policy; OA : PolyORB.POA_Types.Obj_Adapter_Access; U_Oid : Unmarshalled_Oid; Servant : out Servants.Servant_Access; Error : in out PolyORB.Errors.Error_Container); procedure Set_Servant (Self : Use_Default_Servant_Policy; OA : PolyORB.POA_Types.Obj_Adapter_Access; Servant : Servants.Servant_Access; Error : in out PolyORB.Errors.Error_Container); procedure Get_Servant (Self : Use_Default_Servant_Policy; OA : PolyORB.POA_Types.Obj_Adapter_Access; Servant : out Servants.Servant_Access; Error : in out PolyORB.Errors.Error_Container); procedure Ensure_Servant_Manager (Self : Use_Default_Servant_Policy; Error : in out PolyORB.Errors.Error_Container); end PolyORB.POA_Policies.Request_Processing_Policy.Use_Default_Servant; polyorb-2.8~20110207.orig/src/polyorb-utils-strings-lists.ads0000644000175000017500000000571311750740340023337 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . U T I L S . S T R I N G S . L I S T S -- -- -- -- S p e c -- -- -- -- Copyright (C) 2002-2008, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- Generic chained list. with PolyORB.Utils.Chained_Lists; package PolyORB.Utils.Strings.Lists is pragma Preelaborate; package String_Ptr_Lists is new PolyORB.Utils.Chained_Lists (String_Ptr); type List is new String_Ptr_Lists.List; type Iterator is new String_Ptr_Lists.Iterator; function Empty return List; function First (L : List) return Iterator; function Value (I : Iterator) return String_Ptr; procedure Prepend (L : in out List; I : String); procedure Append (L : in out List; I : String); function "+" (I : String) return List; -- Make a list with I as its only element function "&" (L : List; I : String) return List; -- Append I to L procedure Deallocate (L : in out List); private pragma Inline (Empty); pragma Inline (First); pragma Inline (Value); pragma Inline (Prepend); pragma Inline (Append); pragma Inline ("+"); pragma Inline ("&"); end PolyORB.Utils.Strings.Lists; polyorb-2.8~20110207.orig/src/polyorb-parameters-static.adb0000644000175000017500000001106311750740340022756 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . P A R A M E T E R S . S T A T I C -- -- -- -- B o d y -- -- -- -- Copyright (C) 2008, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with PolyORB.Initialization; with PolyORB.Utils.Strings; with System; use type System.Address; package body PolyORB.Parameters.Static is -- The length of the array is unknown, the last entry must be marked with -- a null access. pragma Suppress (Range_Check); Parameters : Static_Parameter_Array (1 .. 1); pragma Import (Ada, Parameters, "__PolyORB_static_parameters"); pragma Warnings (Off); -- WAG:GPL2007 pragma Weak_External (Parameters); pragma Warnings (On); -- WAG:GPL2007 -- This symbol is optional, PolyORB can be configured using other methods -- like the command line or environment variables. -- In some platforms like VxWorks 5.5 the loader gives a warning even if -- the unresolved symbol is weak. This external name was chosen to avoid -- alarming the user when this happen instead of a more descriptive one. Last : Natural := 0; type Partition_Source is new Parameters_Source with null record; -------------- -- Get_Conf -- -------------- function Get_Conf (Source : access Partition_Source; Section, Key : String) return String; function Get_Conf (Source : access Partition_Source; Section, Key : String) return String is pragma Unreferenced (Source); S : constant String := Make_Global_Key (Section, Key); begin for I in 1 .. Last loop if Parameters (I).Parameter.all = S then return Parameters (I).Value.all; end if; end loop; return ""; end Get_Conf; The_Static_Source : aliased Partition_Source; ---------------- -- Initialize -- ---------------- procedure Initialize; procedure Initialize is begin Last := 0; -- If a weak symbol isn't resolved by the linker, it is assigned the -- null address. if Parameters'Address /= System.Null_Address then loop if Parameters (Last + 1).Parameter = null then exit; else Last := Last + 1; end if; end loop; end if; Register_Source (The_Static_Source'Access); end Initialize; use PolyORB.Initialization; use PolyORB.Initialization.String_Lists; use PolyORB.Utils.Strings; begin Register_Module (Module_Info' (Name => +"parameters.static", Conflicts => Empty, Depends => Empty, Provides => +"parameters_sources", Implicit => True, Init => Initialize'Access, Shutdown => null)); end PolyORB.Parameters.Static; polyorb-2.8~20110207.orig/src/polyorb-binding_object_qos.ads0000644000175000017500000000602511750740340023173 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . B I N D I N G _ O B J E C T _ Q O S -- -- -- -- S p e c -- -- -- -- Copyright (C) 2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with PolyORB.Binding_Objects; with PolyORB.QoS; package PolyORB.Binding_Object_QoS is procedure Set_Binding_Object_QoS (BO : access PolyORB.Binding_Objects.Binding_Object'Class; QoS : PolyORB.QoS.QoS_Parameters); function Get_Binding_Object_QoS (BO : access PolyORB.Binding_Objects.Binding_Object'Class) return PolyORB.QoS.QoS_Parameters; procedure Set_Binding_Object_QoS (BO : access PolyORB.Binding_Objects.Binding_Object'Class; Kind : PolyORB.QoS.QoS_Kind; QoS : PolyORB.QoS.QoS_Parameter_Access); function Is_Compatible (BO : access PolyORB.Binding_Objects.Binding_Object'Class; QoS : PolyORB.QoS.QoS_Parameters) return Boolean; type QoS_Compatibility_Check_Proc is access function (BO_QoS : PolyORB.QoS.QoS_Parameter_Access; QoS : PolyORB.QoS.QoS_Parameter_Access) return Boolean; procedure Register (Kind : PolyORB.QoS.QoS_Kind; Proc : QoS_Compatibility_Check_Proc); end PolyORB.Binding_Object_QoS; polyorb-2.8~20110207.orig/src/polyorb-rt_poa-basic_rt_poa.adb0000644000175000017500000003175611750740340023250 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . R T _ P O A . B A S I C _ R T _ P O A -- -- -- -- B o d y -- -- -- -- Copyright (C) 2004-2008, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with PolyORB.Log; with PolyORB.POA_Policies.Implicit_Activation_Policy; with PolyORB.Utils.Chained_Lists; package body PolyORB.RT_POA.Basic_RT_POA is use PolyORB.Errors; use PolyORB.Log; use PolyORB.POA; package L is new Log.Facility_Log ("polyorb.rt_poa.basic_rt_poa"); procedure O (Message : Standard.String; Level : Log_Level := Debug) renames L.Output; function C (Level : Log_Level := Debug) return Boolean renames L.Enabled; type Oid_Information is record U_Oid : PolyORB.POA_Types.Unmarshalled_Oid; Model : Priority_Model; Oid_ORB_Priority : ORB_Priority; Oid_External_Priority : External_Priority; end record; package Oid_Lists is new PolyORB.Utils.Chained_Lists (Oid_Information); use Oid_Lists; subtype Oid_List is Oid_Lists.List; Shadow_Oids : Oid_List; -- This list keeps track of information that have to be stored -- along with the Oid. procedure Set_Policies (OA : access Basic_RT_Obj_Adapter; Policies : POA_Policies.PolicyList); -- Set OA policies from the values in Policies. ------------------ -- Set_Policies -- ------------------ procedure Set_Policies (OA : access Basic_RT_Obj_Adapter; Policies : POA_Policies.PolicyList) is use PolyORB.POA_Policies; use Policy_Lists; It : Policy_Lists.Iterator := First (Policies); A_Policy : Policy_Access; begin while not Last (It) loop A_Policy := Value (It).all; if A_Policy.all in PriorityModelPolicy'Class then if OA.Priority_Model_Policy /= null then pragma Debug (C, O ("Duplicate in PriorityModelPolicy: using last one")); null; end if; OA.Priority_Model_Policy := PriorityModelPolicy_Access (A_Policy); pragma Debug (C, O ("Setting up PriorityModelPolicy")); end if; if A_Policy.all in ThreadPoolPolicy'Class then if OA.Thread_Pool_Policy /= null then pragma Debug (C, O ("Duplicate in ThreadPoolPolicy: using last one")); null; end if; OA.Thread_Pool_Policy := ThreadPoolPolicy_Access (A_Policy); pragma Debug (C, O ("Setting up ThreadPoolPolicy")); end if; Next (It); end loop; end Set_Policies; --------------------------------------------- -- CORBA-like POA interface implementation -- --------------------------------------------- ---------------- -- Create_POA -- ---------------- procedure Create_POA (Self : access Basic_RT_Obj_Adapter; Adapter_Name : Standard.String; A_POAManager : POA_Manager.POAManager_Access; Policies : POA_Policies.PolicyList; POA : out PolyORB.POA.Obj_Adapter_Access; Error : in out PolyORB.Errors.Error_Container) is begin POA := new Basic_RT_Obj_Adapter; Initialize_POA (PolyORB.POA.Obj_Adapter (Self.all)'Access, Adapter_Name, A_POAManager, Policies, PolyORB.POA.Obj_Adapter_Access (POA), Error); if Found (Error) then return; end if; Set_Policies (Basic_RT_Obj_Adapter (POA.all)'Access, Policies); end Create_POA; ------------ -- Export -- ------------ procedure Export (OA : access Basic_RT_Obj_Adapter; Obj : Servants.Servant_Access; Key : Objects.Object_Id_Access; Oid : out Objects.Object_Id_Access; Error : in out PolyORB.Errors.Error_Container) is begin pragma Debug (C, O ("Export: enter")); -- Export servant Export (PolyORB.POA.Obj_Adapter (OA.all)'Access, Obj, Key, Oid, Error); if Found (Error) then return; end if; -- XXX Caching must be propagated to all procedures that store -- a servant in the POA, to be investigated !! if OA.Priority_Model_Policy /= null then -- Cache information on Priority_Model_Policy in servant Set_Servant_Priority_Information (OA.Priority_Model_Policy.all, Obj); end if; if OA.Thread_Pool_Policy /= null then -- Cache information on Thread_Pool_Policy in servant Set_Servant_Lane (OA.Thread_Pool_Policy.all, Obj); end if; pragma Debug (C, O ("Export: leave")); end Export; ------------------------------- -- Get_Scheduling_Parameters -- ------------------------------- procedure Get_Scheduling_Parameters (Self : access Basic_RT_Obj_Adapter; Id : Object_Id_Access; Model : out Priority_Model; Server_ORB_Priority : out ORB_Priority; Server_External_Priority : out External_Priority; Error : in out PolyORB.Errors.Error_Container) is Servant : Servants.Servant_Access; begin Find_Servant (Self, Id, Servant, Error); if Found (Error) then declare U_Oid : Unmarshalled_Oid; It : Iterator := First (Shadow_Oids); Error2 : PolyORB.Errors.Error_Container; begin Oid_To_U_Oid (Id.all, U_Oid, Error2); if Found (Error2) then Catch (Error); Error := Error2; pragma Warnings (Off); -- Model, Server_External_Priority, and Server_ORB_Priority not -- set before return return; pragma Warnings (On); end if; while not Last (It) loop if U_Oid = Value (It).all.U_Oid then Model := Value (It).all.Model; Server_ORB_Priority := Value (It).all.Oid_ORB_Priority; Server_External_Priority := Value (It).all.Oid_External_Priority; Catch (Error); return; end if; Next (It); end loop; return; end; end if; Get_Servant_Priority_Information (Servant, Model, Server_ORB_Priority, Server_External_Priority, Error); end Get_Scheduling_Parameters; ------------------------------------------------ -- CORBA-like RT POA interface implementation -- ------------------------------------------------ ------------------------------------------------ -- Create_Object_Identification_With_Priority -- ------------------------------------------------ procedure Create_Object_Identification_With_Priority (Self : access Basic_RT_Obj_Adapter; Hint : Object_Id_Access; Server_ORB_Priority : ORB_Priority; Server_External_Priority : External_Priority; U_Oid : out Unmarshalled_Oid; Error : in out PolyORB.Errors.Error_Container) is use PolyORB.POA_Policies.Implicit_Activation_Policy; begin -- Check Self's policies are correct Ensure_No_Implicit_Activation (Self.Implicit_Activation_Policy.all, Error); if Found (Error) then return; end if; if Self.Priority_Model_Policy = null or else Self.Priority_Model_Policy.Model /= SERVER_DECLARED then Throw (Error, WrongPolicy_E, Null_Members'(Null_Member)); return; end if; -- Check Server_External_Priority is correct if Self.Thread_Pool_Policy = null or else not Is_Valid_Priority (Self.Thread_Pool_Policy.all, Server_External_Priority) then Throw (Error, Bad_Param_E, System_Exception_Members'(Minor => 0, Completed => Completed_No)); return; end if; Create_Object_Identification (Self, Hint, U_Oid, Error); Append (Shadow_Oids, Oid_Information'(U_Oid, SERVER_DECLARED, Server_ORB_Priority, Server_External_Priority)); end Create_Object_Identification_With_Priority; ------------------------------------------ -- Activate_Object_With_Id_And_Priority -- ------------------------------------------ procedure Activate_Object_With_Id_And_Priority (Self : access Basic_RT_Obj_Adapter; P_Servant : Servants.Servant_Access; Hint : Object_Id_Access; Server_ORB_Priority : ORB_Priority; Server_External_Priority : External_Priority; U_Oid : out Unmarshalled_Oid; Error : in out PolyORB.Errors.Error_Container) is use PolyORB.POA_Policies.Implicit_Activation_Policy; It : Iterator := First (Shadow_Oids); begin -- Check Self's policies are correct Ensure_No_Implicit_Activation (Self.Implicit_Activation_Policy.all, Error); if Found (Error) then return; end if; if Self.Priority_Model_Policy = null or else Self.Priority_Model_Policy.Model /= SERVER_DECLARED then Throw (Error, WrongPolicy_E, Null_Members'(Null_Member)); return; end if; -- Check Server_External_Priority is correct if Self.Thread_Pool_Policy = null or else not Is_Valid_Priority (Self.Thread_Pool_Policy.all, Server_External_Priority) then Throw (Error, Bad_Param_E, System_Exception_Members'(Minor => 0, Completed => Completed_No)); return; end if; -- Activate object Activate_Object (Self, P_Servant, Hint, U_Oid, Error); if Found (Error) then return; end if; -- Check the object has not been previously set up with a -- different priority. while not Last (It) loop if U_Oid = Value (It).all.U_Oid and then Value (It).all.Oid_External_Priority /= Server_External_Priority then Throw (Error, Bad_Inv_Order_E, System_Exception_Members'(Minor => 18, Completed => Completed_No)); return; end if; Next (It); end loop; -- Cache information on Priority_Model_Policy Set_Servant_Priority_Information (Self.Priority_Model_Policy.all, P_Servant, Server_ORB_Priority, Server_External_Priority, Error); if Self.Thread_Pool_Policy /= null then -- Cache information on Thread_Pool_Policy in servant Set_Servant_Lane (Self.Thread_Pool_Policy.all, P_Servant); end if; end Activate_Object_With_Id_And_Priority; end PolyORB.RT_POA.Basic_RT_POA; polyorb-2.8~20110207.orig/src/polyorb-filters-slicers.ads0000644000175000017500000000555511750740340022472 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . F I L T E R S . S L I C E R S -- -- -- -- S p e c -- -- -- -- Copyright (C) 2001-2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- A filter that slices a stream into a set of known-length messages. with Ada.Streams; with PolyORB.Buffers; with PolyORB.Components; package PolyORB.Filters.Slicers is pragma Elaborate_Body; type Slicer_Factory is new Factory with private; procedure Create (Fact : access Slicer_Factory; Slicer : out Filter_Access); private type Slicer_Factory is new Factory with null record; type Slicer_Filter is new Filter with record In_Buf : Buffers.Buffer_Access; Data_Expected : Ada.Streams.Stream_Element_Count; Initial_Data_Expected : Ada.Streams.Stream_Element_Count; Buffer_Length : Ada.Streams.Stream_Element_Count; end record; function Handle_Message (F : not null access Slicer_Filter; S : Components.Message'Class) return Components.Message'Class; end PolyORB.Filters.Slicers; polyorb-2.8~20110207.orig/src/polyorb-utils-report.adb0000644000175000017500000002152111750740340021777 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . U T I L S . R E P O R T -- -- -- -- B o d y -- -- -- -- Copyright (C) 2003-2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with Ada.Numerics.Elementary_Functions; with Ada.Text_IO; package body PolyORB.Utils.Report is Max : constant Natural := 60; Passed : Boolean := True; ------------ -- Output -- ------------ procedure Output (Message : String; Result : Boolean) is Line : String (1 .. Max) := (others => '.'); Last : Natural := Message'Length; begin if Last > Max then Last := Max; end if; Line (1 .. Last) := Message (Message'First .. Message'First + Last - 1); if Result then Ada.Text_IO.Put_Line (Line & ": PASSED"); else Ada.Text_IO.Put_Line (Line & ": FAILED"); end if; Passed := Passed and then Result; end Output; ---------------- -- End_Report -- ---------------- procedure End_Report is begin Output ("END TESTS", Passed); end End_Report; -------------- -- New_Test -- -------------- procedure New_Test (Test_Name : String) is begin Ada.Text_IO.New_Line; Ada.Text_IO.Put_Line ("==> Begin test " & Test_Name & " <=="); end New_Test; package body Statistics is use Ada.Text_IO; --------- -- Min -- --------- function Min (V : Stat_Vector) return T is Result : T := V (V'First); begin for J in V'Range loop if Result > V (J) then Result := V (J); end if; end loop; return Result; end Min; --------- -- Max -- --------- function Max (V : Stat_Vector) return T is Result : T := V (V'First); begin for J in V'Range loop if Result < V (J) then Result := V (J); end if; end loop; return Result; end Max; --------- -- Avg -- --------- function Avg (V : Stat_Vector) return Float is Result : Float := 0.0; begin for J in V'Range loop Result := Result + Float (V (J)); end loop; if V'Length > 0 then return Result / Float (V'Length); else return Result; end if; end Avg; ------------- -- Std_Dev -- ------------- function Std_Dev (V : Stat_Vector) return Float is use Ada.Numerics.Elementary_Functions; Result : Float := 0.0; Mean : constant Float := Avg (V); begin if V'Length < 2 then raise Program_Error; end if; for J in V'Range loop Result := Result + (Float (V (J)) - Mean) ** 2; end loop; Result := Sqrt (Result / Float (V'Length - 1)); return Result; end Std_Dev; --------------- -- Partition -- --------------- function Partition (V : Stat_Vector; Number_Of_Bins : Natural; Low : Float; High : Float) return Partitions is Result : Partitions (0 .. Number_Of_Bins + 1); It : Natural := 0; Done : Natural := 0; begin if V'Length = 0 then raise Program_Error; end if; for K in 0 .. Number_Of_Bins + 1 loop Result (K).Index := T (Low + Float (K) * (High - Low) / Float (Result'Length)); end loop; for J in V'Range loop It := It + 1; for K in Result'Range loop if Float (V (J)) <= Low + Float (K) * (High - Low) / Float (Result'Length) then Result (K).Value := Result (K).Value + 1; Done := Done + 1; exit; end if; end loop; end loop; return Result; end Partition; ---------------- -- To_GNUPlot -- ---------------- procedure To_GNUPlot (V : Stat_Vector; Filename : String) is Output_FH : Ada.Text_IO.File_Type; begin Create (Output_FH, Out_File, Filename & ".gnuplot"); Put_Line (Output_FH, "#"); Put_Line (Output_FH, "# GNUPlot configuration"); Put_Line (Output_FH, "#"); Put_Line (Output_FH, "set size 1.0, 0.4"); Put_Line (Output_FH, "set grid"); Put_Line (Output_FH, "set terminal postscript eps " & "enhanced colour lw 2 ""Helvetica"" 14"); Put_Line (Output_FH, "set out """ & Filename & ".eps"""); Put_Line (Output_FH, "#"); Put_Line (Output_FH, "# Data To Be Plotted"); Put_Line (Output_FH, "#"); Put_Line (Output_FH, "#Min:" & T'Image (Min (V))); Put_Line (Output_FH, "#Max:" & T'Image (Max (V))); Put_Line (Output_FH, "#Max - Min:" & T'Image (Max (V) - Min (V))); Put_Line (Output_FH, "#Avg:" & Float'Image (Avg (V))); Put_Line (Output_FH, "#Dev:" & Float'Image (Std_Dev (V))); Put_Line (Output_FH, "#"); Put_Line (Output_FH, "plot ""-"" notitle"); for J in V'Range loop Put_Line (Output_FH, T'Image (V (J))); end loop; Put_Line (Output_FH, "end"); Close (Output_FH); end To_GNUPlot; procedure To_GNUPlot (P : Partitions; Filename : String) is Output_FH : Ada.Text_IO.File_Type; begin Create (Output_FH, Out_File, Filename & ".gnuplot"); Put_Line (Output_FH, "#"); Put_Line (Output_FH, "# GNUPlot configuration"); Put_Line (Output_FH, "#"); Put_Line (Output_FH, "set size 1.0, 0.4"); Put_Line (Output_FH, "set grid"); Put_Line (Output_FH, "set terminal postscript eps " & "enhanced colour lw 2 ""Helvetica"" 14"); Put_Line (Output_FH, "set data style linespoints"); Put_Line (Output_FH, "set out """ & Filename & ".eps"""); Put_Line (Output_FH, "#"); Put_Line (Output_FH, "# Data To Be Plotted"); Put_Line (Output_FH, "#"); Put_Line (Output_FH, "plot ""-"" notitle"); for J in P'Range loop Put_Line (Output_FH, T'Image (P (J).Index) & Natural'Image (P (J).Value)); end loop; Put_Line (Output_FH, "end"); Close (Output_FH); end To_GNUPlot; -------------------- -- Analyse_Vector -- -------------------- procedure Analyse_Vector (V : Stat_Vector; Filename : String) is P : constant Partitions := Partition (V, 100, 0.9 * Avg (V), 1.1 * Avg (V)); begin Put_Line ("Output data for " & Filename); Put_Line (" Min:" & T'Image (Min (V))); Put_Line (" Max:" & T'Image (Max (V))); Put_Line (" Avg:" & Float'Image (Avg (V))); Put_Line (" Dev:" & Float'Image (Std_Dev (V))); To_GNUPlot (V, Filename); To_GNUPlot (P, Filename & "_bins"); end Analyse_Vector; end Statistics; end PolyORB.Utils.Report; polyorb-2.8~20110207.orig/src/polyorb-filters-fragmenter.ads0000644000175000017500000000617311750740340023155 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . F I L T E R S . F R A G M E N T E R -- -- -- -- S p e c -- -- -- -- Copyright (C) 2001-2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- Fragmenter filter -- Fragment data which comes from endpoint whithout read length control -- For example UDP sockets with Ada.Streams; with PolyORB.Buffers; with PolyORB.Components; package PolyORB.Filters.Fragmenter is pragma Elaborate_Body; type Fragmenter_Factory is new Factory with private; procedure Create (Fact : access Fragmenter_Factory; Fragmenter : out Filter_Access); private type Fragmenter_Factory is new Factory with null record; -- Fragmenter status type Fragmenter_Filter is new Filter with record -- Buffer to upper filter In_Buf : Buffers.Buffer_Access; -- Buffer from lower filter Socket_Buf : Buffers.Buffer_Access; -- Size of data expected by upper filter Data_Expected : Ada.Streams.Stream_Element_Count; -- Size of data expected by upper filter at demand Initial_Data_Expected : Ada.Streams.Stream_Element_Count; end record; function Handle_Message (F : not null access Fragmenter_Filter; S : Components.Message'Class) return Components.Message'Class; end PolyORB.Filters.Fragmenter; polyorb-2.8~20110207.orig/src/polyorb-request_scheduler-servant_lane.adb0000644000175000017500000001457411750740340025545 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- POLYORB.REQUEST_SCHEDULER.SERVANT_LANE -- -- -- -- B o d y -- -- -- -- Copyright (C) 2004-2008, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with PolyORB.Binding_Data; with PolyORB.Components; with PolyORB.Errors; with PolyORB.Initialization; with PolyORB.Lanes; with PolyORB.Log; with PolyORB.References.Binding; with PolyORB.RT_POA_Policies.Priority_Model_Policy; with PolyORB.RT_POA_Policies.Thread_Pool_Policy; with PolyORB.Servants; with PolyORB.Setup; with PolyORB.Task_Info; with PolyORB.Tasking.Priorities; with PolyORB.Utils.Strings; package body PolyORB.Request_Scheduler.Servant_Lane is use PolyORB.Log; package L is new PolyORB.Log.Facility_Log ("polyorb.request_scheduler.servant_lane"); procedure O (Message : String; Level : Log_Level := Debug) renames L.Output; function C (Level : Log_Level := Debug) return Boolean renames L.Enabled; --------------------------- -- Try_Queue_Request_Job -- --------------------------- function Try_Queue_Request_Job (Self : access Request_Scheduler_Servant_Lane; Job : PolyORB.Jobs.Job_Access; Target : PolyORB.References.Ref) return Boolean is pragma Unreferenced (Self); use PolyORB.Errors; use PolyORB.Lanes; use PolyORB.Servants; use type Task_Info.Task_Info_Access; Surrogate : Components.Component_Access; Pro : PolyORB.Binding_Data.Profile_Access; Error : Errors.Error_Container; begin pragma Debug (C, O ("Try_Queue_Request_Job: enter")); -- First test whether the target is a local servant managed by a RT-POA. References.Binding.Bind (Target, PolyORB.Setup.The_ORB, (others => null), Surrogate, Pro, False, Error); -- XXX Should remove dependency on The_ORB if Found (Error) then Catch (Error); return False; end if; if Surrogate.all in Servant'Class then declare use PolyORB.RT_POA_Policies.Priority_Model_Policy; use PolyORB.RT_POA_Policies.Thread_Pool_Policy; To_Lane : constant Lane_Root_Access := Get_Servant_Lane (PolyORB.Servants.Servant_Access (Surrogate)); begin if To_Lane /= null then -- Queue request to the lane attached to servant declare use PolyORB.Tasking.Priorities; Model : Priority_Model; Server_ORB_Priority : ORB_Priority; Server_External_Priority : External_Priority; Error : PolyORB.Errors.Error_Container; begin Get_Servant_Priority_Information (PolyORB.Servants.Servant_Access (Surrogate), Model, Server_ORB_Priority, Server_External_Priority, Error); if Found (Error) then Catch (Error); pragma Debug (C, O ("No priority information")); pragma Debug (C, O ("Try_Queue_Request_Job: leave")); return False; end if; Queue_Job (To_Lane, Job, Server_External_Priority); pragma Debug (C, O ("Job queued")); pragma Debug (C, O ("Try_Queue_Request_Job: leave")); return True; end; end if; end; end if; pragma Debug (C, O ("No lane attached to servant, cannot queue job")); pragma Debug (C, O ("Try_Queue_Request_Job: leave")); return False; end Try_Queue_Request_Job; ------------ -- Create -- ------------ function Create (RCF : access Request_Scheduler_Servant_Lane_Factory) return Request_Scheduler_Access is pragma Unreferenced (RCF); begin return new Request_Scheduler_Servant_Lane; end Create; ---------------- -- Initialize -- ---------------- procedure Initialize; procedure Initialize is begin Register_Request_Scheduler_Factory (RCF); end Initialize; use PolyORB.Initialization; use PolyORB.Initialization.String_Lists; use PolyORB.Utils.Strings; begin Register_Module (Module_Info' (Name => +"request_scheduler.servant_lane", Conflicts => Empty, Depends => Empty, Provides => +"request_scheduler", Implicit => False, Init => Initialize'Access, Shutdown => null)); end PolyORB.Request_Scheduler.Servant_Lane; polyorb-2.8~20110207.orig/src/polyorb-object_maps-system.ads0000644000175000017500000001007411750740340023160 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . O B J E C T _ M A P S . S Y S T E M -- -- -- -- S p e c -- -- -- -- Copyright (C) 2003-2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- Implementation of an Active Object Map optimized for System defined -- Object Identifier. -- Note: this package depends on Unmarshalled_Oid construction for -- SYSTEM_ID POA policy as defined in the package -- PolyORB.POA_Policies.Id_Assignment_Policy.System with PolyORB.Utils.Dynamic_Tables; package PolyORB.Object_Maps.System is type System_Object_Map is new Object_Map with private; procedure Initialize (O_Map : in out System_Object_Map); -- Initialize object map O_Map private structures procedure Finalize (O_Map : in out System_Object_Map); -- Finalize object map O_Map private structures function Add (O_Map : access System_Object_Map; Obj : Object_Map_Entry_Access) return Integer; -- Adds a new entry in the map, returning its index. procedure Add (O_Map : access System_Object_Map; Obj : Object_Map_Entry_Access; Index : Integer); -- Adds a new entry in the map at the given index. function Get_By_Id (O_Map : System_Object_Map; Item : PolyORB.POA_Types.Unmarshalled_Oid) return Object_Map_Entry_Access; -- Given an Object_Id, look up the corresponding map entry. -- If not found, returns null. function Get_By_Servant (O_Map : System_Object_Map; Item : PolyORB.Servants.Servant_Access) return Object_Map_Entry_Access; -- Given a servant, looks for the corresponding map entry -- Doesn't check that the servant is only once in the map -- If not found, returns null. function Remove_By_Id (O_Map : access System_Object_Map; Item : PolyORB.POA_Types.Unmarshalled_Oid) return Object_Map_Entry_Access; -- Given an Object_Id, removes an entry from the map -- and returns it . A null value means -- that the object_id wasn't in the map. private package Map_Entry_Tables is new PolyORB.Utils.Dynamic_Tables (Object_Map_Entry_Access, Natural, 1, 10, 1); type System_Object_Map is new Object_Map with record System_Map : Map_Entry_Tables.Instance; end record; end PolyORB.Object_Maps.System; polyorb-2.8~20110207.orig/src/polyorb-tasking-rw_locks.adb0000644000175000017500000001463511750740340022617 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . T A S K I N G . R W _ L O C K S -- -- -- -- B o d y -- -- -- -- Copyright (C) 2002-2008, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- Inter-process synchronisation objects. with Ada.Unchecked_Deallocation; with PolyORB.Log; with PolyORB.Tasking.Mutexes; package body PolyORB.Tasking.Rw_Locks is use PolyORB.Log; use PolyORB.Tasking.Condition_Variables; use PolyORB.Tasking.Mutexes; package L is new PolyORB.Log.Facility_Log ("polyorb.tasking.rw_locks"); procedure O (Message : String; Level : Log_Level := Debug) renames L.Output; function C (Level : Log_Level := Debug) return Boolean renames L.Enabled; Rw_Lock_Counter : Natural := 0; -- For debugging purposes. All_Rw_Locks : Tasking.Mutexes.Mutex_Access; ------------ -- Create -- ------------ procedure Create (L : out Rw_Lock_Access) is Result : constant Rw_Lock_Access := new Rw_Lock_Type; begin if All_Rw_Locks = null then Create (All_Rw_Locks); end if; pragma Assert (All_Rw_Locks /= null); Enter (All_Rw_Locks); Rw_Lock_Counter := Rw_Lock_Counter + 1; Result.Serial := Rw_Lock_Counter; pragma Debug (C, O ("Create, Serial =" & Integer'Image (Result.Serial))); Leave (All_Rw_Locks); Create (Result.Guard_Values); L := Result; end Create; ---------- -- Free -- ---------- procedure Free is new Ada.Unchecked_Deallocation (Rw_Lock_Type, Rw_Lock_Access); ------------- -- Destroy -- ------------- procedure Destroy (L : in out Rw_Lock_Access) is begin pragma Debug (C, O ("Destroy, Serial =" & Integer'Image (L.Serial))); Destroy (L.Guard_Values); Free (L); pragma Debug (C, O ("Desroy: end")); end Destroy; -------------- -- Is_Set_R -- -------------- function Is_Set_R (L : access Rw_Lock_Type) return Boolean is begin return L.Count > 0; end Is_Set_R; -------------- -- Is_Set_W -- -------------- function Is_Set_W (L : access Rw_Lock_Type) return Boolean is begin return L.Count = -1; end Is_Set_W; ------------ -- Lock_W -- ------------ procedure Lock_W (L : access Rw_Lock_Type) is begin pragma Debug (C, O ("Lock_W Serial =" & Integer'Image (L.Serial))); Enter (All_Rw_Locks); while L.Count /= 0 loop L.Writers_Waiting := L.Writers_Waiting + 1; Wait (L.Guard_Values, All_Rw_Locks); L.Writers_Waiting := L.Writers_Waiting - 1; -- Wait until the condition may have changed -- from the value it had when we were within -- the critical section. end loop; L.Count := -1; Leave (All_Rw_Locks); end Lock_W; ------------ -- Lock_R -- ------------ procedure Lock_R (L : access Rw_Lock_Type) is begin pragma Debug (C, O ("Lock_R Serial =" & Integer'Image (L.Serial))); Enter (All_Rw_Locks); while not (True and then L.Count >= 0 and then L.Count < L.Max_Count and then L.Writers_Waiting = 0) loop L.Readers_Waiting := L.Readers_Waiting + 1; Wait (L.Guard_Values, All_Rw_Locks); L.Readers_Waiting := L.Readers_Waiting - 1; end loop; L.Count := L.Count + 1; Leave (All_Rw_Locks); end Lock_R; -------------- -- Unlock_W -- -------------- procedure Unlock_W (L : access Rw_Lock_Type) is begin pragma Debug (C, O ("Unlock_W Serial =" & Integer'Image (L.Serial))); Enter (All_Rw_Locks); if L.Count /= -1 then pragma Debug (C, O ("Lock has not been previously taken !")); raise Program_Error; else L.Count := 0; end if; Broadcast (L.Guard_Values); Leave (All_Rw_Locks); end Unlock_W; -------------- -- Unlock_R -- -------------- procedure Unlock_R (L : access Rw_Lock_Type) is begin pragma Debug (C, O ("Unlock_R Serial =" & Integer'Image (L.Serial))); Enter (All_Rw_Locks); if L.Count <= 0 then raise Program_Error; else L.Count := L.Count - 1; end if; Broadcast (L.Guard_Values); Leave (All_Rw_Locks); end Unlock_R; ------------------- -- Set_Max_Count -- ------------------- procedure Set_Max_Count (L : access Rw_Lock_Type; Max : Natural) is begin Enter (All_Rw_Locks); L.Max_Count := Max; Broadcast (L.Guard_Values); Leave (All_Rw_Locks); end Set_Max_Count; end PolyORB.Tasking.Rw_Locks; polyorb-2.8~20110207.orig/src/polyorb-object_maps.ads0000644000175000017500000001070711750740340021641 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . O B J E C T _ M A P S -- -- -- -- S p e c -- -- -- -- Copyright (C) 2001-2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- Abstract model for the POA Active Object Map. with Ada.Unchecked_Deallocation; with PolyORB.POA_Types; with PolyORB.Servants; package PolyORB.Object_Maps is ---------------------- -- Object_Map_Entry -- ---------------------- type Object_Map_Entry is limited record Oid : PolyORB.POA_Types.Unmarshalled_Oid_Access; Servant : PolyORB.Servants.Servant_Access; end record; type Object_Map_Entry_Access is access all Object_Map_Entry; procedure Free is new Ada.Unchecked_Deallocation (Object_Map_Entry, Object_Map_Entry_Access); ---------------- -- Object_Map -- ---------------- type Object_Map is abstract tagged limited private; type Object_Map_Access is access all Object_Map'Class; procedure Initialize (O_Map : in out Object_Map) is abstract; -- Initialize object map O_Map private structures procedure Finalize (O_Map : in out Object_Map) is abstract; -- Finalize object map O_Map private structures function Is_Servant_In (O_Map : Object_Map; Item : PolyORB.Servants.Servant_Access) return Boolean; -- Checks if a servant is already in the map -- (and return True if it is the case) function Is_Object_Id_In (O_Map : Object_Map; Item : PolyORB.POA_Types.Unmarshalled_Oid) return Boolean; -- Checks if an object_id is already used in the map -- (and return True if it is the case) function Get_By_Id (O_Map : Object_Map; Item : PolyORB.POA_Types.Unmarshalled_Oid) return Object_Map_Entry_Access is abstract; -- Given an Object_Id, look up the corresponding map entry. -- If not found, returns null. function Get_By_Servant (O_Map : Object_Map; Item : PolyORB.Servants.Servant_Access) return Object_Map_Entry_Access is abstract; -- Given a servant, looks for the corresponding map entry -- Doesn't check that the servant is only once in the map -- If not found, returns null. function Remove_By_Id (O_Map : access Object_Map; Item : PolyORB.POA_Types.Unmarshalled_Oid) return Object_Map_Entry_Access is abstract; -- Given an Object_Id, removes an entry from the map -- and returns it . A null value means -- that the object_id wasn't in the map. private type Object_Map is abstract tagged limited null record; function Is_Null (Item : Object_Map_Entry_Access) return Boolean; end PolyORB.Object_Maps; polyorb-2.8~20110207.orig/src/polyorb-qos-tagged_components.ads0000644000175000017500000000565011750740340023654 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . Q O S . T A G G E D _ C O M P O N E N T S -- -- -- -- S p e c -- -- -- -- Copyright (C) 2005 Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with PolyORB.Representations.CDR.Common; with PolyORB.Types; with PolyORB.Utils.Chained_Lists; package PolyORB.QoS.Tagged_Components is subtype Component_Id is PolyORB.Types.Unsigned_Long; type Encapsulation_Access is access all PolyORB.Representations.CDR.Common.Encapsulation; type GIOP_Tagged_Component is record Tag : Component_Id; Data : Encapsulation_Access; end record; package GIOP_Tagged_Component_Lists is new Utils.Chained_Lists (GIOP_Tagged_Component); type QoS_GIOP_Tagged_Components_Parameter is new QoS_Parameter (GIOP_Tagged_Components) with record Components : GIOP_Tagged_Component_Lists.List; end record; type QoS_GIOP_Tagged_Components_Parameter_Access is access all QoS_GIOP_Tagged_Components_Parameter'Class; procedure Release_Contents (QoS : access QoS_GIOP_Tagged_Components_Parameter); end PolyORB.QoS.Tagged_Components; polyorb-2.8~20110207.orig/src/polyorb-orb-thread_per_session.adb0000644000175000017500000002473711750740340024002 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . O R B . T H R E A D _ P E R _ S E S S I O N -- -- -- -- B o d y -- -- -- -- Copyright (C) 2001-2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with Ada.Unchecked_Deallocation; with PolyORB.Components; with PolyORB.Filters; with PolyORB.Filters.Iface; with PolyORB.Initialization; with PolyORB.Log; with PolyORB.Protocols; with PolyORB.Setup; with PolyORB.Tasking.Condition_Variables; with PolyORB.Tasking.Threads; with PolyORB.Utils.Strings; package body PolyORB.ORB.Thread_Per_Session is use PolyORB.Annotations; use PolyORB.Asynch_Ev; use PolyORB.Filters; use PolyORB.Filters.Iface; use PolyORB.Log; use PolyORB.Protocols; use PolyORB.Tasking.Condition_Variables; use PolyORB.Tasking.Semaphores; use PolyORB.Tasking.Threads; package L is new PolyORB.Log.Facility_Log ("polyorb.orb.thread_per_session"); procedure O (Message : String; Level : Log_Level := Debug) renames L.Output; function C (Level : Log_Level := Debug) return Boolean renames L.Enabled; type Session_Runnable is new Runnable with record ORB : ORB_Access; A_S : Session_Access; end record; procedure Run (R : not null access Session_Runnable); procedure Initialize; ---------- -- Free -- ---------- procedure Free is new Ada.Unchecked_Deallocation (Notepad, Notepad_Access); procedure Free is new Ada.Unchecked_Deallocation (Request_Queue, Request_Queue_Access); ----------------- -- Add_Request -- ----------------- procedure Add_Request (S : Session_Thread_Info; RI : Request_Info) is begin Request_Queues.Append (S.Request_List.all, RI); V (S.Request_Semaphore); pragma Debug (C, O ("A request has been queued")); end Add_Request; ----------------------------- -- Handle_Close_Connection -- ----------------------------- procedure Handle_Close_Connection (P : access Thread_Per_Session_Policy; TE : Transport_Endpoint_Access) is pragma Unreferenced (P); S : Filters.Filter_Access := null; begin -- Find an access to the session declare Temp : Filters.Filter_Access := Filters.Filter_Access (Upper (TE)); begin while Temp /= null loop S := Temp; Temp := Filters.Filter_Access (Upper (Temp)); end loop; end; -- Create and queue an End_Thread_Job declare ET : constant End_Thread_Job_Access := new End_Thread_Job; N : constant Notepad_Access := Get_Task_Info (Session_Access (S)); STI : Session_Thread_Info; begin Get_Note (N.all, STI); Add_Request (STI, Request_Info'(Job => Jobs.Job_Access (ET))); end; pragma Debug (C, O ("A End_Thread_Job has been queued")); end Handle_Close_Connection; ---------------------------------- -- Handle_New_Client_Connection -- ---------------------------------- procedure Handle_New_Client_Connection (P : access Thread_Per_Session_Policy; ORB : ORB_Access; AC : Active_Connection) is pragma Unreferenced (P, ORB); begin pragma Debug (C, O ("New client connection")); Components.Emit_No_Reply (Component_Access (AC.TE), Connect_Confirmation'(null record)); end Handle_New_Client_Connection; ---------------------------------- -- Handle_New_Server_Connection -- ---------------------------------- procedure Handle_New_Server_Connection (P : access Thread_Per_Session_Policy; ORB : ORB_Access; AC : Active_Connection) is pragma Unreferenced (P); S : Filters.Filter_Access; Temp : Filters.Filter_Access := Filters.Filter_Access (Upper (AC.TE)); T : Thread_Access; pragma Unreferenced (T); -- T is assigned but never read begin pragma Debug (C, O ("New server connection.")); -- Determine ORB session attached to this connection while Temp /= null loop S := Temp; Temp := Filters.Filter_Access (Upper (Temp)); end loop; pragma Assert (S /= null); -- Start session task T := Run_In_Task (Get_Thread_Factory, R => new Session_Runnable'(ORB => ORB, A_S => Session_Access (S))); Components.Emit_No_Reply (Component_Access (AC.TE), Connect_Indication'(null record)); end Handle_New_Server_Connection; ------------------------------ -- Handle_Request_Execution -- ------------------------------ procedure Handle_Request_Execution (P : access Thread_Per_Session_Policy; ORB : ORB_Access; RJ : access Request_Job'Class) is pragma Unreferenced (P); pragma Unreferenced (ORB); S : constant Session_Access := Session_Access (RJ.Request.Requesting_Component); N : constant Notepad_Access := Get_Task_Info (S); STI : Session_Thread_Info; begin -- Pass on request to session task Get_Note (N.all, STI); Add_Request (STI, Request_Info'(Job => Job_Access (RJ))); end Handle_Request_Execution; ---------- -- Idle -- ---------- procedure Idle (P : access Thread_Per_Session_Policy; This_Task : PTI.Task_Info_Access; ORB : ORB_Access) is pragma Unreferenced (P); pragma Unreferenced (ORB); package PTI renames PolyORB.Task_Info; begin -- In Thread_Per_Session policy, only one task is executing ORB.Run. -- However, it can be set to idle while another thread modifies -- ORB internals. pragma Debug (C, O ("Thread " & Image (PTI.Id (This_Task.all)) & " is going idle.")); Wait (PTI.Condition (This_Task.all), PTI.Mutex (This_Task.all)); pragma Debug (C, O ("Thread " & Image (PTI.Id (This_Task.all)) & " is leaving Idle state")); end Idle; ---------------- -- Initialize -- ---------------- procedure Initialize is begin Setup.The_Tasking_Policy := new Thread_Per_Session_Policy; end Initialize; --------- -- Run -- --------- procedure Run (J : not null access End_Thread_Job) is pragma Unreferenced (J); begin null; end Run; --------- -- Run -- --------- procedure Run (R : not null access Session_Runnable) is Sem : Semaphore_Access := null; L : Request_Queue_Access := null; N : Notepad_Access := null; Q : Request_Info; begin pragma Debug (C, O ("Session Thread number " & Image (Current_Task) & " is starting")); -- Runnable initialization Create (Sem); L := new Request_Queue; N := new Notepad; Set_Note (N.all, Session_Thread_Info'(Note with Request_Semaphore => Sem, Request_List => L)); Set_Task_Info (R.A_S, N); -- Runnable main loop loop pragma Debug (C, O ("Thread number" & Image (Current_Task) & " is waiting")); P (Sem); Request_Queues.Extract_First (L.all, Q); pragma Debug (C, O ("Thread number" & Image (Current_Task) & " is executing Job")); if Q.Job.all in Request_Job'Class then Run_Request (R.ORB, Request_Job (Q.Job.all).Request); Jobs.Free (Q.Job); elsif Q.Job.all in End_Thread_Job'Class then pragma Debug (C, O ("Received an End_Thread_Message")); Jobs.Free (Q.Job); exit; end if; pragma Debug (C, O ("Thread number" & Image (Current_Task) & " has executed Job")); end loop; -- Runnable finalization pragma Debug (C, O ("Finalizing thread " & Image (Current_Task))); Request_Queues.Deallocate (L.all); Free (L); Destroy (Sem); Destroy (N.all); Free (N); pragma Debug (C, O ("Thread " & Image (Current_Task) & " stopped")); end Run; use PolyORB.Initialization; use PolyORB.Initialization.String_Lists; use PolyORB.Utils.Strings; begin Register_Module (Module_Info' (Name => +"orb.thread_per_session", Conflicts => +"no_tasking", Depends => +"tasking.condition_variables", Provides => +"orb.tasking_policy!", Implicit => False, Init => Initialize'Access, Shutdown => null)); end PolyORB.ORB.Thread_Per_Session; polyorb-2.8~20110207.orig/src/polyorb-obj_adapters-simple.adb0000644000175000017500000002562311750740340023261 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . O B J _ A D A P T E R S . S I M P L E -- -- -- -- B o d y -- -- -- -- Copyright (C) 2001-2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with Ada.Streams; with Ada.Unchecked_Conversion; with PolyORB.Obj_Adapter_QoS; package body PolyORB.Obj_Adapters.Simple is use Ada.Streams; use PolyORB.Errors; use PolyORB.Tasking.Mutexes; use Object_Map_Entry_Arrays; subtype Simple_OA_Oid is Stream_Element_Array (1 .. Integer'Size / Stream_Element'Size); function Index_To_Oid is new Ada.Unchecked_Conversion (Integer, Simple_OA_Oid); function Oid_To_Index is new Ada.Unchecked_Conversion (Simple_OA_Oid, Integer); procedure Find_Entry (OA : Simple_Obj_Adapter; Index : Integer; OME : out Object_Map_Entry; Error : in out PolyORB.Errors.Error_Container); -- Check that Index is a valid object Index (associated to a -- non-null Servant) for object adapter OA, and return a copy of -- the associated entry. If Index is out of range or associated to -- a null Servant, Invalid_Object_Id is raised. ---------------- -- Find_Entry -- ---------------- procedure Find_Entry (OA : Simple_Obj_Adapter; Index : Integer; OME : out Object_Map_Entry; Error : in out PolyORB.Errors.Error_Container) is use type Servants.Servant_Access; begin Enter (OA.Lock); if Index > Last (OA.Object_Map) or else OA.Object_Map.Table = null then -- Going outside limits of the Object Map implies the -- Object_Id we are looking for is not valid. OME := (Servant => null, If_Desc => (null, null)); else OME := OA.Object_Map.Table (Index); end if; Leave (OA.Lock); if OME.Servant = null then Throw (Error, Invalid_Object_Id_E, Null_Members'(Null_Member)); OME := (Servant => null, If_Desc => (null, null)); end if; end Find_Entry; ------------ -- Create -- ------------ procedure Create (OA : access Simple_Obj_Adapter) is begin Create (OA.Lock); Initialize (OA.Object_Map); end Create; ------------- -- Destroy -- ------------- procedure Destroy (OA : access Simple_Obj_Adapter) is begin Destroy (OA.Lock); Deallocate (OA.Object_Map); Destroy (Obj_Adapter (OA.all)'Access); end Destroy; ------------ -- Export -- ------------ procedure Export (OA : access Simple_Obj_Adapter; Obj : Servants.Servant_Access; Key : Objects.Object_Id_Access; Oid : out Objects.Object_Id_Access; Error : in out PolyORB.Errors.Error_Container) is use type Servants.Servant_Access; use type Objects.Object_Id_Access; begin if Key /= null or else OA.Object_Map.Table = null then Throw (Error, Invalid_Object_Id_E, Null_Members'(Null_Member)); return; end if; Enter (OA.Lock); declare New_Id : Integer := Last (OA.Object_Map) + 1; begin Map : for J in First (OA.Object_Map) .. Last (OA.Object_Map) loop if OA.Object_Map.Table (J).Servant = null then OA.Object_Map.Table (J) := Object_Map_Entry'(Servant => Obj, If_Desc => (null, null)); New_Id := J; exit Map; end if; end loop Map; if New_Id > Last (OA.Object_Map) then Increment_Last (OA.Object_Map); OA.Object_Map.Table (Last (OA.Object_Map)) := Object_Map_Entry'(Servant => Obj, If_Desc => (null, null)); end if; Leave (OA.Lock); Oid := new Objects.Object_Id' (Objects.Object_Id (Index_To_Oid (New_Id - First (OA.Object_Map) + 1))); end; end Export; -- XXX There is FAR TOO MUCH code duplication in here! -------------- -- Unexport -- -------------- procedure Unexport (OA : access Simple_Obj_Adapter; Id : Objects.Object_Id_Access; Error : in out PolyORB.Errors.Error_Container) is use type Servants.Servant_Access; Index : constant Integer := Oid_To_Index (Simple_OA_Oid (Id.all)); OME : Object_Map_Entry; begin -- First, ensure the servant is not null Find_Entry (OA.all, Index, OME, Error); if Is_Error (Error) then return; end if; pragma Assert (OME.Servant /= null); -- then, set to null the entry in object map OME := (Servant => null, If_Desc => (null, null)); Enter (OA.Lock); OA.Object_Map.Table (Index) := OME; Leave (OA.Lock); end Unexport; ---------------- -- Object_Key -- ---------------- procedure Object_Key (OA : access Simple_Obj_Adapter; Id : Objects.Object_Id_Access; User_Id : out Objects.Object_Id_Access; Error : in out PolyORB.Errors.Error_Container) is pragma Unreferenced (OA, Id); begin Throw (Error, Invalid_Object_Id_E, Null_Members'(Null_Member)); -- The Simple Object Adapter does not support -- user-defined object identifiers. User_Id := null; end Object_Key; ------------- -- Get_QoS -- ------------- procedure Get_QoS (OA : access Simple_Obj_Adapter; Id : Objects.Object_Id; QoS : out PolyORB.QoS.QoS_Parameters; Error : in out PolyORB.Errors.Error_Container) is pragma Unreferenced (Id); pragma Unreferenced (Error); begin QoS := PolyORB.Obj_Adapter_QoS.Get_Object_Adapter_QoS (OA); end Get_QoS; ------------------------------- -- Set_Interface_Description -- ------------------------------- procedure Set_Interface_Description (OA : in out Simple_Obj_Adapter; Id : access Objects.Object_Id; If_Desc : Interface_Description) is use type Servants.Servant_Access; Error : Error_Container; Index : constant Integer := Oid_To_Index (Simple_OA_Oid (Id.all)); OME : Object_Map_Entry; begin Find_Entry (OA, Index, OME, Error); if Is_Error (Error) then return; end if; OME.If_Desc := If_Desc; Enter (OA.Lock); OA.Object_Map.Table (Index) := OME; Leave (OA.Lock); end Set_Interface_Description; ------------------------ -- Get_Empty_Arg_List -- ------------------------ function Get_Empty_Arg_List (OA : access Simple_Obj_Adapter; Oid : access Objects.Object_Id; Method : String) return Any.NVList.Ref is Error : Error_Container; Index : constant Integer := Oid_To_Index (Simple_OA_Oid (Oid.all)); OME : Object_Map_Entry; Result : Any.NVList.Ref; begin Find_Entry (OA.all, Index, OME, Error); if Is_Error (Error) then Catch (Error); return Result; end if; if OME.If_Desc.PP_Desc = null then -- No interface information, return empty list return Result; end if; return OME.If_Desc.PP_Desc (Method); end Get_Empty_Arg_List; ---------------------- -- Get_Empty_Result -- ---------------------- function Get_Empty_Result (OA : access Simple_Obj_Adapter; Oid : access Objects.Object_Id; Method : String) return Any.Any is Error : Error_Container; Index : constant Integer := Oid_To_Index (Simple_OA_Oid (Oid.all)); OME : Object_Map_Entry; Result : Any.Any; begin Find_Entry (OA.all, Index, OME, Error); if Is_Error (Error) then Catch (Error); return Result; end if; if OME.If_Desc.PP_Desc = null then -- No interface information, return empty list return Result; end if; return OME.If_Desc.RP_Desc (Method); end Get_Empty_Result; ------------------ -- Find_Servant -- ------------------ procedure Find_Servant (OA : access Simple_Obj_Adapter; Id : access Objects.Object_Id; Servant : out Servants.Servant_Access; Error : in out PolyORB.Errors.Error_Container) is Index : constant Integer := Oid_To_Index (Simple_OA_Oid (Id.all)); OME : Object_Map_Entry; begin Find_Entry (OA.all, Index, OME, Error); if Is_Error (Error) then return; end if; Servant := OME.Servant; PolyORB.Servants.Set_Executor (Servant, OA.S_Exec'Access); end Find_Servant; --------------------- -- Release_Servant -- --------------------- procedure Release_Servant (OA : access Simple_Obj_Adapter; Id : access Objects.Object_Id; Servant : in out Servants.Servant_Access) is pragma Warnings (Off); pragma Unreferenced (OA); pragma Unreferenced (Id); pragma Warnings (On); begin -- SOA: do nothing Servant := null; end Release_Servant; end PolyORB.Obj_Adapters.Simple; polyorb-2.8~20110207.orig/src/polyorb-qos-exception_informations.adb0000644000175000017500000001724011750740340024717 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . Q O S . E X C E P T I O N _ I N F O R M A T I O N S -- -- -- -- B o d y -- -- -- -- Copyright (C) 2006-2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with Ada.Strings.Fixed; with PolyORB.Buffers; with PolyORB.Initialization; with PolyORB.QoS.Service_Contexts; with PolyORB.Representations.CDR.Common; with PolyORB.Request_QoS; with PolyORB.Utils.Strings; package body PolyORB.QoS.Exception_Informations is use PolyORB.Buffers; use PolyORB.QoS.Service_Contexts; use PolyORB.Representations.CDR.Common; function To_AdaExceptionInformation_Service_Context (QoS : QoS_Parameter_Access) return Service_Context; function To_Ada_Exception_Information_Parameter (SC : Service_Context) return QoS_Parameter_Access; procedure Initialize; ------------------------------- -- Get_Exception_Information -- ------------------------------- function Get_Exception_Information (R : Requests.Request) return String is QoS : constant QoS_Ada_Exception_Information_Parameter_Access := QoS_Ada_Exception_Information_Parameter_Access (PolyORB.Request_QoS.Extract_Reply_Parameter (PolyORB.QoS.Ada_Exception_Information, R)); begin if QoS /= null then return Types.To_Standard_String (QoS.Exception_Information); else return ""; end if; end Get_Exception_Information; --------------------------- -- Get_Exception_Message -- --------------------------- function Get_Exception_Message (R : Requests.Request) return String is Exception_Information : constant String := Get_Exception_Information (R); Exception_Message_Marker : constant String := ASCII.LF & "Message: "; First, Last : Integer; begin -- The expected format of the exception information is: -- "Exception name: " & Excception_Name & ASCII.LF & -- "Message: " & Exception_Message & ASCII.LF First := Ada.Strings.Fixed.Index (Source => Exception_Information, Pattern => Exception_Message_Marker); -- If separator is not found, just return entire Exception_Information if First = 0 then First := Exception_Information'First; else First := First + Exception_Message_Marker'Length; end if; -- Strip trailing newline Last := Exception_Information'Last; if Last >= First and then Exception_Information (Last) = ASCII.LF then Last := Last - 1; end if; -- Return appropriate slice return Exception_Information (First .. Last); end Get_Exception_Message; ------------------------------- -- Set_Exception_Information -- ------------------------------- procedure Set_Exception_Information (Request : in out Requests.Request; Occurrence : Ada.Exceptions.Exception_Occurrence) is use PolyORB.QoS.Exception_Informations; begin Request_QoS.Add_Reply_QoS (Request, PolyORB.QoS.Ada_Exception_Information, new QoS_Ada_Exception_Information_Parameter' (Kind => QoS.Ada_Exception_Information, Exception_Information => Types.To_PolyORB_String (Ada.Exceptions.Exception_Information (Occurrence)))); end Set_Exception_Information; ------------------------------------------------ -- To_AdaExceptionInformation_Service_Context -- ------------------------------------------------ function To_AdaExceptionInformation_Service_Context (QoS : QoS_Parameter_Access) return Service_Context is Result : Service_Context := (AdaExceptionInformation, null); begin if QoS = null then return Result; end if; declare AEI : QoS_Ada_Exception_Information_Parameter renames QoS_Ada_Exception_Information_Parameter (QoS.all); Buffer : Buffer_Access := new Buffer_Type; begin Start_Encapsulation (Buffer); Marshall_Latin_1_String (Buffer, AEI.Exception_Information); Result.Context_Data := new Encapsulation'(Encapsulate (Buffer)); Release (Buffer); end; return Result; end To_AdaExceptionInformation_Service_Context; -------------------------------------------- -- To_Ada_Exception_Information_Parameter -- -------------------------------------------- function To_Ada_Exception_Information_Parameter (SC : Service_Context) return QoS_Parameter_Access is Buffer : aliased Buffer_Type; Exception_Information : PolyORB.Types.String; begin Decapsulate (SC.Context_Data, Buffer'Access); Exception_Information := Unmarshall_Latin_1_String (Buffer'Access); return new QoS_Ada_Exception_Information_Parameter' (Kind => Ada_Exception_Information, Exception_Information => Exception_Information); end To_Ada_Exception_Information_Parameter; ---------------- -- Initialize -- ---------------- procedure Initialize is begin Register (Ada_Exception_Information, To_AdaExceptionInformation_Service_Context'Access); Register (AdaExceptionInformation, To_Ada_Exception_Information_Parameter'Access); end Initialize; begin declare use PolyORB.Initialization; use PolyORB.Initialization.String_Lists; use PolyORB.Utils.Strings; begin Register_Module (Module_Info' (Name => +"qos.exception_information", Conflicts => Empty, Depends => Empty, Provides => Empty, Implicit => False, Init => Initialize'Access, Shutdown => null)); end; end PolyORB.QoS.Exception_Informations; polyorb-2.8~20110207.orig/src/polyorb-representations-cdr.ads0000644000175000017500000001744611750740340023355 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . R E P R E S E N T A T I O N S . C D R -- -- -- -- S p e c -- -- -- -- Copyright (C) 2002-2008, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- A data representation implementing the CORBA Common Data Representation. -- For reference on CDR see: -- The Common Object Request Broker Architecture: Core Specification, -- Version 3.0", Open Management Group -- (http://www.omg.org/). with PolyORB.Types; with PolyORB.Utils.Dynamic_Tables; package PolyORB.Representations.CDR is -- pragma Elaborate_Body; type CDR_Representation is abstract new Representation with private; type CDR_Representation_Access is access all CDR_Representation'Class; -- The next two subprograms marshall or unmarshall the value of -- the Any, not the Any type itself (i.e. they do not marshall Data's -- typecode). procedure Marshall_From_Any (R : access CDR_Representation; Buffer : access Buffers.Buffer_Type; CData : Any.Any_Container'Class; Error : in out Errors.Error_Container); procedure Unmarshall_To_Any (R : access CDR_Representation; Buffer : access Buffers.Buffer_Type; CData : in out Any.Any_Container'Class; Error : in out Errors.Error_Container); -- XXX Encapsulation is also GIOP version dependent. -- 'char' type procedure Marshall (R : CDR_Representation; Buffer : access Buffers.Buffer_Type; Data : PolyORB.Types.Char; Error : in out Errors.Error_Container) is abstract; procedure Unmarshall (R : CDR_Representation; Buffer : access Buffers.Buffer_Type; Data : out PolyORB.Types.Char; Error : in out Errors.Error_Container) is abstract; -- 'wchar' type procedure Marshall (R : CDR_Representation; Buffer : access Buffers.Buffer_Type; Data : PolyORB.Types.Wchar; Error : in out Errors.Error_Container) is abstract; procedure Unmarshall (R : CDR_Representation; Buffer : access Buffers.Buffer_Type; Data : out PolyORB.Types.Wchar; Error : in out Errors.Error_Container) is abstract; -- 'string' type procedure Marshall (R : CDR_Representation; Buffer : access Buffers.Buffer_Type; Data : PolyORB.Types.String; Error : in out Errors.Error_Container) is abstract; procedure Unmarshall (R : CDR_Representation; Buffer : access Buffers.Buffer_Type; Data : out PolyORB.Types.String; Error : in out Errors.Error_Container) is abstract; -- 'wstring' type procedure Marshall (R : CDR_Representation; Buffer : access Buffers.Buffer_Type; Data : PolyORB.Types.Wide_String; Error : in out Errors.Error_Container) is abstract; procedure Unmarshall (R : CDR_Representation; Buffer : access Buffers.Buffer_Type; Data : out PolyORB.Types.Wide_String; Error : in out Errors.Error_Container) is abstract; function Create_Representation (Major : Types.Octet; Minor : Types.Octet) return CDR_Representation_Access; -- Create Representation object for requested version procedure Release (Representation : in out CDR_Representation); -- 'Any' type procedure Marshall (Buffer : access Buffers.Buffer_Type; Representation : access CDR_Representation'Class; Data : PolyORB.Any.Any); function Unmarshall (Buffer : access Buffers.Buffer_Type; Representation : access CDR_Representation'Class) return PolyORB.Any.Any; -- 'TypeCode' type procedure Marshall (Buffer : access Buffers.Buffer_Type; R : access CDR_Representation'Class; Data : Any.TypeCode.Object_Ptr; Error : in out Errors.Error_Container); procedure Unmarshall (Buffer : access Buffers.Buffer_Type; R : access CDR_Representation'Class; Data : out Any.TypeCode.Local_Ref; Error : in out Errors.Error_Container); private -- Typecodes map management -- When a complex typecode is marshalled into a CDR stream, nested -- typecodes can be stored as indirect references to a previous occurrence -- of the same typecode within the same enclosing outermost complex -- typecode. This is supported by keeping track of the mapping between -- typecodes and their offset in the CDR stream within each CDR engine. type TC_Map_Entry is record Enclosing_Complex : Types.Long; -- Index in the TC_Map of the innermost enclosing complex typecode, used -- for computation of offset relative the to topmost complex typecode. -- Set to -1 for the outermost complex TC. TC_Ref : Any.TypeCode.Object_Ptr; -- TC object at this offset. Assumes reference semantics Offset : Types.Long; -- Offset of this typecode in outermost CDR stream end record; package TC_Maps is new PolyORB.Utils.Dynamic_Tables (Table_Component_Type => TC_Map_Entry, Table_Index_Type => Types.Long, Table_Low_Bound => 0, Table_Initial => 1, Table_Increment => 4); use type Types.Long; -- For unary minus operator used for component Current_Complex below type CDR_Representation is abstract new Representation with record TC_Map : TC_Maps.Instance; -- Map of typecodes in current CDR stream. This map is flushed when the -- outermost complex typecode has been completely processed. Current_Complex : Types.Long := -1; -- Index in TC_Map of complex typecode currently being processed, or -- -1 if none. end record; -- CDR Representation versions registry type CDR_Representation_Factory is access function return CDR_Representation_Access; procedure Register_Factory (Major : Types.Octet; Minor : Types.Octet; Factory : CDR_Representation_Factory); end PolyORB.Representations.CDR; polyorb-2.8~20110207.orig/src/polyorb-tasking-idle_tasks_managers.ads0000644000175000017500000001027111750740340025004 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . T A S K I N G . I D L E _ T A S K S _ M A N A G E R S -- -- -- -- S p e c -- -- -- -- Copyright (C) 2004-2009, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with PolyORB.Task_Info; with PolyORB.Tasking.Condition_Variables; with PolyORB.Utils.Chained_Lists; package PolyORB.Tasking.Idle_Tasks_Managers is pragma Preelaborate; package PTI renames PolyORB.Task_Info; package PTCV renames PolyORB.Tasking.Condition_Variables; type Idle_Tasks_Manager is limited private; type Idle_Tasks_Manager_Access is access all Idle_Tasks_Manager; procedure Awake_Idle_Task (ITM : access Idle_Tasks_Manager; TI : PTI.Task_Info_Access); -- Awake one specific idle task function Awake_One_Idle_Task (ITM : access Idle_Tasks_Manager; Allow_Transient : Boolean) return Boolean; -- Awake one idle task, if any, else do nothing. If Allow_Transient is -- True, we can awaken any Kind of task; otherwise, we must awaken a -- Permanent task (or do nothing). Returns True when an idle task has been -- awakened. procedure Awake_All_Idle_Tasks (ITM : access Idle_Tasks_Manager); -- Awake all idle tasks procedure Remove_Idle_Task (ITM : access Idle_Tasks_Manager; TI : PTI.Task_Info_Access); -- Called after task TI has exited Idle to return its CV to the free list function Insert_Idle_Task (ITM : access Idle_Tasks_Manager; TI : PTI.Task_Info_Access) return PTCV.Condition_Access; -- Add TI to the pool of tasks managed by ITM. The returned CV -- will be used by a task to put itself in an idle (waiting) state. private pragma Inline (Remove_Idle_Task); pragma Inline (Insert_Idle_Task); package CV_Lists is new PolyORB.Utils.Chained_Lists (PTCV.Condition_Access, PTCV."="); type Task_List_Array is array (PTI.Task_Kind) of PTI.Task_List; type Idle_Tasks_Manager is limited record Idle_Task_Lists : Task_List_Array; -- Lists of idle tasks, segregated by Kind Free_CV : CV_Lists.List; -- Free_CV is the list of pre-allocated CV. When scheduling a task -- to idle state, the ORB controller first looks for an availble -- CV in this list; or else allocates one new CV. When a task -- leaves idle state, the ORB controller puts its CV in Free_CV. end record; end PolyORB.Tasking.Idle_Tasks_Managers; polyorb-2.8~20110207.orig/src/polyorb-log-initialization.ads0000644000175000017500000000426411750740340023162 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . L O G . I N I T I A L I Z A T I O N -- -- -- -- S p e c -- -- -- -- Copyright (C) 2005 Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- This package provides the module registration for the logging subsystem package PolyORB.Log.Initialization is pragma Elaborate_Body; end PolyORB.Log.Initialization; polyorb-2.8~20110207.orig/src/polyorb-sequences-bounded.ads0000644000175000017500000002342211750740340022762 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . S E Q U E N C E S . B O U N D E D -- -- -- -- S p e c -- -- -- -- Copyright (C) 2002-2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- This package provides the definitions required by the IDL-to-Ada mapping -- specification for bounded sequences. This package is instantiated for each -- IDL bounded sequence type. This package defines the sequence type and the -- operations upon it. This package is modeled after Ada.Strings and is -- compliant with the specifications of CORBA.Sequences.Bounded defined in the -- CORBA Ada Mapping. -- -- Most query operations are not usable until the sequence object has been -- initialized through an assignment. -- -- Value semantics apply to assignment, that is, assignment of a sequence -- value to a sequence object yields a copy of the value. -- -- The exception INDEX_ERROR is raised when indexes are not in the range of -- the object being manipulated. -- -- The exception CONSTRAINT_ERROR is raised when objects that have not been -- initialized or assigned to are manipulated. generic type Element is private; Max : Positive; -- Maximum length of the bounded sequence package PolyORB.Sequences.Bounded is pragma Preelaborate; Max_Length : constant Positive := Max; type Element_Array is array (Positive range <>) of Element; -- Can't be "of aliased Element" because Element may be an unconstrained -- mutable record type. type Element_Ptr is access all Element; Null_Element_Array : Element_Array (2 .. 1); type Sequence is private; Null_Sequence : constant Sequence; subtype Length_Range is Natural range 0 .. Max_Length; function Length (Source : Sequence) return Length_Range; procedure Set_Length (Source : in out Sequence; Length : Length_Range); type Element_Array_Access is access all Element_Array; procedure Free (X : in out Element_Array_Access); -------------------------------------------------------- -- Conversion, Concatenation, and Selection Functions -- -------------------------------------------------------- function To_Sequence (Source : Element_Array; Drop : Truncation := Error) return Sequence; function To_Sequence (Length : Length_Range) return Sequence; procedure Set (Item : in out Sequence; Source : Element_Array; Drop : Truncation := Error); function To_Element_Array (Source : Sequence) return Element_Array; function Append (Left, Right : Sequence; Drop : Truncation := Error) return Sequence; function Append (Left : Sequence; Right : Element_Array; Drop : Truncation := Error) return Sequence; function Append (Left : Element_Array; Right : Sequence; Drop : Truncation := Error) return Sequence; function Append (Left : Sequence; Right : Element; Drop : Truncation := Error) return Sequence; function Append (Left : Element; Right : Sequence; Drop : Truncation := Error) return Sequence; procedure Append (Source : in out Sequence; New_Item : Sequence; Drop : Truncation := Error); procedure Append (Source : in out Sequence; New_Item : Element_Array; Drop : Truncation := Error); procedure Append (Source : in out Sequence; New_Item : Element; Drop : Truncation := Error); function "&" (Left, Right : Sequence) return Sequence; function "&" (Left : Sequence; Right : Element_Array) return Sequence; function "&" (Left : Element_Array; Right : Sequence) return Sequence; function "&" (Left : Sequence; Right : Element) return Sequence; function "&" (Left : Element; Right : Sequence) return Sequence; function Element_Of (Source : Sequence; Index : Positive) return Element; function Get_Element (Source : Sequence; Index : Positive) return Element renames Element_Of; procedure Replace_Element (Source : in out Sequence; Index : Positive; By : Element); function Slice (Source : Sequence; Low : Positive; High : Natural) return Element_Array; function "=" (Left, Right : Sequence) return Boolean; function "=" (Left : Sequence; Right : Element_Array) return Boolean; function "=" (Left : Element_Array; Right : Sequence) return Boolean; ---------------------- -- Search functions -- ---------------------- function Index (Source : Sequence; Pattern : Element_Array; Going : Direction := Forward) return Natural; function Count (Source : Sequence; Pattern : Element_Array) return Natural; ----------------------------------------- -- Sequence transformation subprograms -- ----------------------------------------- function Replace_Slice (Source : Sequence; Low : Positive; High : Natural; By : Element_Array; Drop : Truncation := Error) return Sequence; procedure Replace_Slice (Source : in out Sequence; Low : Positive; High : Natural; By : Element_Array; Drop : Truncation := Error); function Insert (Source : Sequence; Before : Positive; New_Item : Element_Array; Drop : Truncation := Error) return Sequence; procedure Insert (Source : in out Sequence; Before : Positive; New_Item : Element_Array; Drop : Truncation := Error); function Overwrite (Source : Sequence; Position : Positive; New_Item : Element_Array; Drop : Truncation := Error) return Sequence; procedure Overwrite (Source : in out Sequence; Position : Positive; New_Item : Element_Array; Drop : Truncation := Error); function Delete (Source : Sequence; From : Positive; Through : Natural) return Sequence; procedure Delete (Source : in out Sequence; From : Positive; Through : Natural); ----------------------------------- -- Sequence selector subprograms -- ----------------------------------- function Head (Source : Sequence; Count : Natural; Pad : Element; Drop : Truncation := Error) return Sequence; procedure Head (Source : in out Sequence; Count : Natural; Pad : Element; Drop : Truncation := Error); function Tail (Source : Sequence; Count : Natural; Pad : Element; Drop : Truncation := Error) return Sequence; procedure Tail (Source : in out Sequence; Count : Natural; Pad : Element; Drop : Truncation := Error); -------------------------------------- -- Sequence constructor subprograms -- -------------------------------------- function "*" (Left : Natural; Right : Element) return Sequence; function "*" (Left : Natural; Right : Element_Array) return Sequence; function "*" (Left : Natural; Right : Sequence) return Sequence; function Replicate (Count : Natural; Item : Element; Drop : Truncation := Error) return Sequence; function Replicate (Count : Natural; Item : Element_Array; Drop : Truncation := Error) return Sequence; function Replicate (Count : Natural; Item : Sequence; Drop : Truncation := Error) return Sequence; -------------------------------------- -- Accessor to stored element space -- -------------------------------------- function Unchecked_Element_Of (Source : access Sequence; Index : Positive) return Element_Ptr; private type Sequence is record Length : Natural := 0; Content : Element_Array (1 .. Max_Length); end record; Default : Sequence; pragma Warnings (Off, Default); -- The default initial value is fine Null_Sequence : constant Sequence := Default; end PolyORB.Sequences.Bounded; polyorb-2.8~20110207.orig/src/polyorb-utils-udp_access_points.adb0000644000175000017500000001471311750740340024176 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . U T I L S . U D P _ A C C E S S _ P O I N T S -- -- -- -- B o d y -- -- -- -- Copyright (C) 2003-2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- Helper subprograms to set up access points based on UDP sockets with Ada.Exceptions; with PolyORB.Components; with PolyORB.Log; with PolyORB.Platform; with PolyORB.Setup; with PolyORB.Transport.Datagram.Sockets; package body PolyORB.Utils.UDP_Access_Points is use PolyORB.Binding_Data; use PolyORB.Log; use PolyORB.Sockets; package L is new PolyORB.Log.Facility_Log ("polyorb.utils.udp_access_points"); procedure O (Message : String; Level : Log_Level := Debug) renames L.Output; -- function C (Level : Log_Level := Debug) return Boolean -- renames L.Enabled; procedure Initialize_Socket (AP_Info : in out UDP_Access_Point_Info); pragma Inline (Initialize_Socket); -- Shared part between Initialize_Unicast_Socket and -- Initialize_Multicast_Socket. ----------------------- -- Initialize_Socket -- ----------------------- procedure Initialize_Socket (AP_Info : in out UDP_Access_Point_Info) is begin Create_Socket (AP_Info.Socket, Family_Inet, Socket_Datagram); -- Allow reuse of local addresses Set_Socket_Option (AP_Info.Socket, Socket_Level, (Reuse_Address, True)); end Initialize_Socket; --------------------------------- -- Initialize_Multicast_Socket -- --------------------------------- procedure Initialize_Multicast_Socket (AP_Info : in out UDP_Access_Point_Info; Address : Inet_Addr_Type; Port : Port_Type) is use PolyORB.Transport.Datagram.Sockets; Bind_Address : Sock_Addr_Type; begin Initialize_Socket (AP_Info); AP_Info.Address := Sock_Addr_Type'(Addr => Address, Port => Port, Family => Family_Inet); Bind_Address := AP_Info.Address; -- Bind socket: for UNIX it needs to be bound to the group address; -- for Windows to INADDR_ANY. if PolyORB.Platform.Windows_On_Target then Bind_Address.Addr := Any_Inet_Addr; end if; Init_Socket (Socket_Access_Point (AP_Info.SAP.all), AP_Info.Socket, Address => AP_Info.Address, Bind_Address => Bind_Address, Update_Addr => False); -- Join multicast group on the appropriate interface (note that under -- Windows, this is possible only after the socket is bound). Set_Socket_Option (AP_Info.Socket, IP_Protocol_For_IP_Level, (Name => Add_Membership, Multicast_Address => Address, Local_Interface => Any_Inet_Addr)); -- Allow local multicast operation Set_Socket_Option (AP_Info.Socket, IP_Protocol_For_IP_Level, (Multicast_Loop, True)); if AP_Info.PF /= null then Create_Factory (AP_Info.PF.all, AP_Info.SAP, PolyORB.Components.Component_Access (Setup.The_ORB)); end if; end Initialize_Multicast_Socket; ------------------------------- -- Initialize_Unicast_Socket -- ------------------------------- procedure Initialize_Unicast_Socket (AP_Info : in out UDP_Access_Point_Info; Port_Hint : Port_Interval; Address : Inet_Addr_Type := Any_Inet_Addr) is use PolyORB.Transport.Datagram.Sockets; begin -- Create Socket Initialize_Socket (AP_Info); AP_Info.Address := Sock_Addr_Type'(Addr => Address, Port => Port_Hint.Lo, Family => Family_Inet); loop begin Init_Socket (Socket_Access_Point (AP_Info.SAP.all), AP_Info.Socket, AP_Info.Address); exit; exception when E : Socket_Error => -- If a specific port range was given, try next port in range if AP_Info.Address.Port /= Any_Port and then AP_Info.Address.Port < Port_Hint.Hi then AP_Info.Address.Port := AP_Info.Address.Port + 1; else O ("bind failed: " & Ada.Exceptions.Exception_Message (E), Notice); raise; end if; end; end loop; -- Create profile factory if AP_Info.PF /= null then Create_Factory (AP_Info.PF.all, AP_Info.SAP, Components.Component_Access (Setup.The_ORB)); end if; end Initialize_Unicast_Socket; end PolyORB.Utils.UDP_Access_Points; polyorb-2.8~20110207.orig/src/polyorb-rt_poa_policies-thread_pool_policy.ads0000644000175000017500000000657411750740340026412 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- POLYORB.RT_POA_POLICIES.THREAD_POOL_POLICY -- -- -- -- S p e c -- -- -- -- Copyright (C) 2004-2005 Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with PolyORB.Errors; with PolyORB.Lanes; with PolyORB.POA_Policies; with PolyORB.Servants; with PolyORB.Tasking.Priorities; package PolyORB.RT_POA_Policies.Thread_Pool_Policy is use PolyORB.Lanes; use PolyORB.POA_Policies; use PolyORB.Tasking.Priorities; type ThreadPoolPolicy is new PolyORB.POA_Policies.Policy with private; type ThreadPoolPolicy_Access is access all ThreadPoolPolicy'Class; function Create (Lanes : Lane_Root_Access) return Policy_Access; function Policy_Id (Self : ThreadPoolPolicy) return String; procedure Check_Compatibility (Self : ThreadPoolPolicy; Other_Policies : AllPolicies; Error : in out PolyORB.Errors.Error_Container); function Get_Servant_Lane (Servant : PolyORB.Servants.Servant_Access) return Lane_Root_Access; -- Retrieve information on ThreadPoolPolicy stored in Servant, -- return null if unset. procedure Set_Servant_Lane (Self : ThreadPoolPolicy; Servant : PolyORB.Servants.Servant_Access); -- Cache Self information into Servant function Is_Valid_Priority (Self : ThreadPoolPolicy; Priority : External_Priority) return Boolean; private type ThreadPoolPolicy is new PolyORB.POA_Policies.Policy with record Lanes : Lane_Root_Access; end record; end PolyORB.RT_POA_Policies.Thread_Pool_Policy; polyorb-2.8~20110207.orig/src/polyorb-orb_controller.ads0000644000175000017500000003476411750740340022411 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . O R B _ C O N T R O L L E R -- -- -- -- S p e c -- -- -- -- Copyright (C) 2003-2011, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- ORB Controller for PolyORB ORB main loop with PolyORB.Asynch_Ev; with PolyORB.Jobs; with PolyORB.Log; with PolyORB.References; with PolyORB.Request_Scheduler; with PolyORB.Task_Info; with PolyORB.Tasking.Condition_Variables; with PolyORB.Tasking.Idle_Tasks_Managers; with PolyORB.Tasking.Mutexes; with PolyORB.Tasking.Threads; package PolyORB.ORB_Controller is -- An ORB Control Policy is responsible for the management of the global -- state of the ORB (running tasks, job processing, etc). It grants access -- to ORB internals and affects action to all registered tasks. -- It is the responsibility of the ORB Control Policy to ensure that all -- tasks work concurrently and access the ORB internals safely. -- An ORB Controller is an instance of an ORB Control Policy, attached to -- an ORB instance. It is a passive object, triggered by the occurence of -- some specific events within the ORB. package PAE renames PolyORB.Asynch_Ev; package PJ renames PolyORB.Jobs; package PR renames PolyORB.References; package PRS renames PolyORB.Request_Scheduler; package PTI renames PolyORB.Task_Info; package PTCV renames PolyORB.Tasking.Condition_Variables; package PTM renames PolyORB.Tasking.Mutexes; package PTT renames PolyORB.Tasking.Threads; ----------- -- Event -- ----------- -- Events handled by ORB Controllers. Specific events trigger the ORB -- Controller, which then modify ORB global state. type Event_Kind is (End_Of_Check_Sources, -- A task completed Check_Sources on a monitor Event_Sources_Added, -- An AES has been added to monitored AES list Event_Sources_Deleted, -- An AES has been deleted from monitored AES list Job_Completed, -- A job has been completed ORB_Shutdown, -- ORB shutdown has been requested Queue_Event_Job, -- Queue an event job Queue_Request_Job, -- Queue a request job Request_Result_Ready, -- A Request has been completed Idle_Awake, -- A task has left Idle state Task_Registered, -- A task has joined the ORB pool and has been added to the summary Task_Unregistered -- A task has left the ORB pool and has been removed from the summary ); -- Event type type Event (Kind : Event_Kind) is record case Kind is when End_Of_Check_Sources => On_Monitor : PAE.Asynch_Ev_Monitor_Access; when Event_Sources_Added => Add_In_Monitor : PAE.Asynch_Ev_Monitor_Access; -- Non null iff we add a source to a new monitor when Event_Sources_Deleted | Job_Completed | ORB_Shutdown => null; when Queue_Event_Job => Event_Job : PJ.Job_Access; By_Task : PTT.Thread_Id; when Queue_Request_Job => Request_Job : PJ.Job_Access; Target : PR.Ref; when Request_Result_Ready => Requesting_Task : PTI.Task_Info_Access; when Idle_Awake => Awakened_Task : PTI.Task_Info_Access; when Task_Registered => Registered_Task : PTI.Task_Info_Access; when Task_Unregistered => Unregistered_Task : PTI.Task_Info_Access; end case; end record; -------------------- -- ORB_Controller -- -------------------- type ORB_Controller (RS : PRS.Request_Scheduler_Access) is abstract tagged limited private; type ORB_Controller_Access is access all ORB_Controller'Class; procedure Enter_ORB_Critical_Section (O : access ORB_Controller); pragma Inline (Enter_ORB_Critical_Section); -- Enter ORB critical section procedure Leave_ORB_Critical_Section (O : access ORB_Controller); pragma Inline (Leave_ORB_Critical_Section); -- Leave ORB critical section -- The following subprograms must be called from within the ORB critical -- section. procedure Register_Task (O : access ORB_Controller; TI : PTI.Task_Info_Access); -- Register TI to the ORB Controller. TI may now be used by the ORB -- Controller to process ORB actions. procedure Terminate_Task (O : access ORB_Controller; TI : PTI.Task_Info_Access); -- Record that the given task is terminating. If the task was idle, the -- ORB controller is notified. Task state is then set to Terminated. procedure Unregister_Task (O : access ORB_Controller; TI : PTI.Task_Info_Access); -- Unregister terminated task TI from the ORB Controller procedure Notify_Event (O : access ORB_Controller; E : Event) is abstract; -- Notify ORB Controller O of the occurence of event E. -- This procedure may change the status of idle or blocked tasks. procedure Schedule_Task (O : access ORB_Controller; TI : PTI.Task_Info_Access) is abstract; -- TI is the current task. Set its state to indicate the next action to be -- executed. This operation has no effect and returns immediately if the -- current state of the task is Terminated. procedure Disable_Polling (O : access ORB_Controller; M : PAE.Asynch_Ev_Monitor_Access) is abstract; -- Disable polling on AES monitored by M, abort polling task and waits for -- its completion, if required. -- -- The ORB critical section is exited temporarily while waiting for -- completion of any ongoing polling operation: several tasks might be -- blocked concurrently in this procedure. The critical section is -- re-entered after the ongoing polling operation has been completed. procedure Enable_Polling (O : access ORB_Controller; M : PAE.Asynch_Ev_Monitor_Access) is abstract; -- Enable polling on AES monitored by M. If Disable_Polling has been called -- N times, Enable_Polling must be called N times to actually enable -- polling. It is the user's responsability to ensure that Enable_Polling -- actually enables polling in bounded time. function Has_Pending_Job (O : access ORB_Controller) return Boolean; -- Return true iff a job is pending function Get_Pending_Job (O : access ORB_Controller) return PJ.Job_Access; -- Return a pending job, null if there is none function Shutting_Down (O : ORB_Controller) return Boolean; pragma Inline (Shutting_Down); -- Return True if ORB shutdown is in progress function Is_Locally_Terminated (O : access ORB_Controller; Expected_Running_Tasks : Natural) return Boolean; -- Return true if the local node is locally terminated. -- Expected_Running_Tasks is the number of expected non terminated tasks -- when local termination is computed. type Monitor_Array is array (Natural range <>) of PAE.Asynch_Ev_Monitor_Access; function Get_Monitors (O : access ORB_Controller) return Monitor_Array; pragma Inline (Get_Monitors); -- Return monitors handled by the ORB function Get_Tasks_Count (OC : ORB_Controller; Kind : PTI.Any_Task_Kind := PTI.Any; State : PTI.Any_Task_State := PTI.Any) return Natural; pragma Inline (Get_Tasks_Count); -- Return the count of tasks for the given kind and state procedure Wait_For_Completion (O : access ORB_Controller); -- When ORB shutdown has been requested, block until all pending jobs are -- processed. The ORB critical section is exited temporarily while waiting -- for completion, and reasserted afterwards. ---------------------------- -- ORB_Controller_Factory -- ---------------------------- type ORB_Controller_Factory is abstract tagged limited null record; type ORB_Controller_Factory_Access is access all ORB_Controller_Factory'Class; function Create (OCF : ORB_Controller_Factory) return ORB_Controller_Access is abstract; -- Use factory to create a new ORB_Controller procedure Register_ORB_Controller_Factory (OCF : ORB_Controller_Factory_Access); -- Register an ORB_Controller factory procedure Create (O : out ORB_Controller_Access); -- Initialize an ORB_Controller by dispatching to Create function of the -- currently registered factory. private use PolyORB.Log; use PolyORB.Tasking.Idle_Tasks_Managers; package L1 is new PolyORB.Log.Facility_Log ("polyorb.orb_controller"); procedure O1 (Message : String; Level : Log_Level := Debug) renames L1.Output; function C1 (Level : Log_Level := Debug) return Boolean renames L1.Enabled; package L2 is new PolyORB.Log.Facility_Log ("polyorb.orb_controller_status"); procedure O2 (Message : String; Level : Log_Level := Debug) renames L2.Output; function C2 (Level : Log_Level := Debug) return Boolean renames L2.Enabled; function Status (O : ORB_Controller) return String; -- Output status of task running Broker, for debugging purpose procedure Try_Allocate_One_Task (O : access ORB_Controller; Allow_Transient : Boolean); -- A job has been queued on the general ORB controller job queue: -- awake one idle task to process it. If no idle task is available, and no -- permanent running task is about to reschedule, unblock a polling task. function Need_Polling_Task (O : access ORB_Controller) return Natural; -- Return the index of the AEM_Info of a monitor waiting for polling task, -- else return 0. Note that the index of the last polled AEM is recorded -- in O to ensure fairness. function Index (O : ORB_Controller; M : PAE.Asynch_Ev_Monitor_Access) return Natural; pragma Inline (Index); -- Return the index of M held in O.AEM_Infos, 0 if not found type AEM_Info is record Monitor : PAE.Asynch_Ev_Monitor_Access; -- Monitor to be polled TI : PTI.Task_Info_Access; -- Store the Task_Info allocated to monitor this AEM Polling_Abort_Counter : Natural := 0; -- Indicates number of tasks that requested abortion of polling Polling_Completed : PTCV.Condition_Access; -- This condition is signalled after polling is completed. It is used by -- tasks for the polling task to release any reference to source list -- that is to be modified. Polling_Scheduled : Boolean := False; -- True iff a task will poll on AES Polling_Interval : Duration; -- XXX TO BE DOCUMENTED Polling_Timeout : Duration; -- XXX TO BE DOCUMENTED end record; type AEM_Infos_Array is array (Natural range <>) of AEM_Info; Maximum_Number_Of_Monitors : constant := 2; type ORB_Controller (RS : PRS.Request_Scheduler_Access) is abstract tagged limited record ORB_Lock : PTM.Mutex_Access; -- Mutex used to enforce ORB critical section Job_Queue : PJ.Job_Queue_Access; -- The queue of jobs to be processed by ORB tasks AEM_Infos : AEM_Infos_Array (1 .. Maximum_Number_Of_Monitors); Last_Monitored_AEM : Natural := Maximum_Number_Of_Monitors; -- ??? Needs proper documentation of usage of this component. -- Half_Sync_Half_Async uses it to point to the designated monitoring -- task for each monitor; other ORB controllers use it for the currently -- blocked task (and in the latter only there is an invariant that the -- TI component of each slot points to the existing valid task info for -- a Blocked task.) Idle_Tasks : Idle_Tasks_Manager_Access; ----------------------------- -- Global controller state -- ----------------------------- Summary : PTI.Task_Summary; -- Task counters Shutdown : Boolean := False; -- True iff ORB is to be shutdown Shutdown_CV : PTCV.Condition_Access; -- CV used by callers of Shutdown to wait for completion of all pending -- requests. end record; procedure Initialize (OC : in out ORB_Controller); -- Initialize OC elements procedure Note_Task_Unregistered (O : access ORB_Controller'Class); -- Called by concrete ORB controllers after processing a task -- unregistration notification. function Is_Upcall (J : PJ.Job'Class) return Boolean; -- Return True if job J that is queued on the ORB controller job queue -- involves an upcall to application code (in which case it must not be -- handled by a transient task). Note that this predicate is defined only -- for queued jobs. procedure Reschedule_Task (O : access ORB_Controller; TI : PTI.Task_Info_Access); -- Cause the given task to be rescheduled (i.e. awakened if it is idle, -- unblocked if it is blocked). Used when a condition occurs that the task -- needs to be informed of. end PolyORB.ORB_Controller; polyorb-2.8~20110207.orig/src/polyorb-request_scheduler-servant_lane.ads0000644000175000017500000000575411750740340025566 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- POLYORB.REQUEST_SCHEDULER.SERVANT_LANE -- -- -- -- S p e c -- -- -- -- Copyright (C) 2004 Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by ACT Europe. -- -- (email: sales@act-europe.fr) -- -- -- ------------------------------------------------------------------------------ package PolyORB.Request_Scheduler.Servant_Lane is type Request_Scheduler_Servant_Lane is new Request_Scheduler with private; type Request_Scheduler_Servant_Lane_Access is access all Request_Scheduler_Servant_Lane; function Try_Queue_Request_Job (Self : access Request_Scheduler_Servant_Lane; Job : PolyORB.Jobs.Job_Access; Target : PolyORB.References.Ref) return Boolean; type Request_Scheduler_Servant_Lane_Factory is new Request_Scheduler_Factory with private; function Create (RCF : access Request_Scheduler_Servant_Lane_Factory) return Request_Scheduler_Access; private type Request_Scheduler_Servant_Lane is new Request_Scheduler with null record; type Request_Scheduler_Servant_Lane_Factory is new Request_Scheduler_Factory with null record; RCF : constant Request_Scheduler_Factory_Access := new Request_Scheduler_Servant_Lane_Factory; end PolyORB.Request_Scheduler.Servant_Lane; polyorb-2.8~20110207.orig/src/polyorb-constants.ads0000644000175000017500000000432011750740340021361 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . C O N S T A N T S -- -- -- -- S p e c -- -- -- -- Copyright (C) 2001 Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by ACT Europe. -- -- (email: sales@act-europe.fr) -- -- -- ------------------------------------------------------------------------------ -- Constants for the PolyORB system. package PolyORB.Constants is pragma Pure; Forever : constant Duration; private Forever : constant Duration := Duration'Last; end PolyORB.Constants; polyorb-2.8~20110207.orig/src/polyorb-smart_pointers.adb0000644000175000017500000002671711750740340022413 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . S M A R T _ P O I N T E R S -- -- -- -- B o d y -- -- -- -- Copyright (C) 2001-2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with Ada.Unchecked_Deallocation; with PolyORB.Log; with PolyORB.Parameters; package body PolyORB.Smart_Pointers is use Interfaces; use PolyORB.Log; package L is new PolyORB.Log.Facility_Log ("polyorb.smart_pointers"); procedure O (Message : String; Level : Log_Level := Debug) renames L.Output; function C (Level : Log_Level := Debug) return Boolean renames L.Enabled; type Event_Kind_Type is (Inc_Usage, Dec_Usage); -- Smart pointer events that can be traced procedure Trace_Event (Event_Kind : Event_Kind_Type; Obj : Entity_Ptr); -- Produce debugging trace for the indicated event on Obj, if applicable -- (must be called just before updating Obj's reference counter). function Dummy_Entity_External_Tag (X : Unsafe_Entity'Class) return String; function Dummy_Ref_External_Tag (X : Ref'Class) return String; -- Dummy version of functions returning External_Tag (X'Tag) to prevent -- crashes at elaboration time for early initialization of references -- (before complete ORB initialization). Entity_External_Tag : Entity_External_Tag_Hook := Dummy_Entity_External_Tag'Access; Ref_External_Tag : Ref_External_Tag_Hook := Dummy_Ref_External_Tag'Access; -- Debugging hooks, set at initialization Default_Trace : Boolean := True; -- Needs comment??? package Sync_Counters is -- Support for atomic addition/subtraction procedure Initialize; function Sync_Add_And_Fetch (Ptr : access Interfaces.Integer_32; Value : Interfaces.Integer_32) return Interfaces.Integer_32; pragma Inline (Initialize); pragma Inline (Sync_Add_And_Fetch); end Sync_Counters; package body Sync_Counters is separate; use Sync_Counters; ------------ -- Adjust -- ------------ procedure Adjust (The_Ref : in out Ref) is begin pragma Debug (C, O ("Adjust: enter")); if The_Ref.A_Ref /= null then Inc_Usage (The_Ref.A_Ref); else pragma Debug (C, O ("Adjust: null ref")); null; end if; pragma Debug (C, O ("Adjust: leave")); end Adjust; --------------- -- Dec_Usage -- --------------- procedure Dec_Usage (Obj : in out Entity_Ptr) is procedure Free is new Ada.Unchecked_Deallocation (Unsafe_Entity'Class, Entity_Ptr); Counter : Interfaces.Integer_32; begin if Obj.Counter = -1 then -- Entity is not reference-counted return; end if; pragma Debug (C, Trace_Event (Dec_Usage, Obj)); Counter := Sync_Add_And_Fetch (Obj.Counter'Access, -1); pragma Assert (Counter >= 0); if Counter = 0 then pragma Debug (C, O ("Dec_Usage: deallocating " & Entity_External_Tag (Obj.all))); if not Is_Controlled (Obj.all) then -- This entity is not controlled: finalize it ourselves Finalize (Obj.all); end if; Free (Obj); pragma Debug (C, O ("Dec_Usage: deallocation done")); end if; end Dec_Usage; -------------------------------- -- Disable_Reference_Counting -- -------------------------------- procedure Disable_Reference_Counting (Obj : in out Unsafe_Entity'Class) is begin Obj.Counter := -1; end Disable_Reference_Counting; ------------------------------- -- Dummy_Entity_External_Tag -- ------------------------------- function Dummy_Entity_External_Tag (X : Unsafe_Entity'Class) return String is pragma Unreferenced (X); begin return ""; end Dummy_Entity_External_Tag; ---------------------------- -- Dummy_Ref_External_Tag -- ---------------------------- function Dummy_Ref_External_Tag (X : Ref'Class) return String is pragma Unreferenced (X); begin return ""; end Dummy_Ref_External_Tag; --------------- -- Entity_Of -- --------------- function Entity_Of (The_Ref : Ref) return Entity_Ptr is begin return The_Ref.A_Ref; end Entity_Of; -------------- -- Finalize -- -------------- procedure Finalize (X : in out Unsafe_Entity) is pragma Warnings (Off); pragma Unreferenced (X); pragma Warnings (On); begin null; end Finalize; -------------- -- Finalize -- -------------- procedure Finalize (The_Ref : in out Ref) is function Return_Ref_External_Tag return String; -- Encapsulate the call to Ref_External_Tag. This function avoids -- run-time overhead if debug is turned off. function Return_Ref_External_Tag return String is begin if Ref_External_Tag /= null then return "Finalize: enter, The_Ref is a " & Ref_External_Tag (The_Ref); else return "Finalize: enter, The_Ref is a "; end if; end Return_Ref_External_Tag; Obj : Entity_Ptr := The_Ref.A_Ref; -- Start of processing for Finalize begin pragma Debug (C, O (Return_Ref_External_Tag)); -- Invalidate A_Ref early because such access may subsequently become -- erroneous, see below. The_Ref.A_Ref := null; if Obj /= null then Dec_Usage (Obj); -- From this point on, we may not assume that The_Ref is still valid, -- because in the case of auto-referential structures, it may be -- a member of Obj.all, which has been destroyed above if its ref -- counter dropped to 0. else pragma Debug (C, O ("Finalize: null ref")); null; end if; pragma Debug (C, O ("Finalize: leave")); end Finalize; --------------- -- Get_Trace -- --------------- function Get_Trace (Entity_Type : String) return Boolean is begin return Parameters.Get_Conf (Section => Trace_Section, Key => Entity_Type & Trace_Suffix, Default => Default_Trace); end Get_Trace; --------------- -- Inc_Usage -- --------------- procedure Inc_Usage (Obj : Entity_Ptr) is Discard : Interfaces.Integer_32; pragma Unreferenced (Discard); begin if Obj.Counter = -1 then -- Entity is not reference-counted return; end if; pragma Debug (C, Trace_Event (Inc_Usage, Obj)); Discard := Sync_Add_And_Fetch (Obj.Counter'Access, 1); end Inc_Usage; ---------------- -- Initialize -- ---------------- procedure Initialize (The_Entity_External_Tag : Entity_External_Tag_Hook; The_Ref_External_Tag : Ref_External_Tag_Hook; The_Default_Trace : Boolean) is begin Sync_Counters.Initialize; Entity_External_Tag := The_Entity_External_Tag; Ref_External_Tag := The_Ref_External_Tag; Default_Trace := The_Default_Trace; end Initialize; ------------------- -- Is_Controlled -- ------------------- function Is_Controlled (X : Unsafe_Entity) return Boolean is pragma Unreferenced (X); begin return False; end Is_Controlled; ------------ -- Is_Nil -- ------------ function Is_Nil (The_Ref : Ref) return Boolean is begin return The_Ref.A_Ref = null; end Is_Nil; ------------------ -- Reuse_Entity -- ------------------ procedure Reuse_Entity (The_Ref : in out Ref; The_Entity : Entity_Ptr) is Counter : Interfaces.Integer_32; begin pragma Assert (The_Ref.A_Ref = null); pragma Assert (The_Entity.Counter /= -1); pragma Debug (C, Trace_Event (Inc_Usage, The_Entity)); Counter := Sync_Add_And_Fetch (The_Entity.Counter'Access, 1); if Counter = 1 then -- Was 0, can't reuse entity, reset counter pragma Debug (C, Trace_Event (Dec_Usage, The_Entity)); Counter := Sync_Add_And_Fetch (The_Entity.Counter'Access, -1); else The_Ref.A_Ref := The_Entity; end if; end Reuse_Entity; ----------------- -- Same_Entity -- ----------------- function Same_Entity (Left, Right : Ref) return Boolean is begin return Entity_Of (Left) = Entity_Of (Right); end Same_Entity; --------- -- Set -- --------- procedure Set (The_Ref : in out Ref; The_Entity : Entity_Ptr) is begin if The_Ref.A_Ref = The_Entity then -- Same entity: no-op return; end if; Finalize (The_Ref); The_Ref.A_Ref := The_Entity; Adjust (The_Ref); end Set; ----------------- -- Trace_Event -- ----------------- procedure Trace_Event (Event_Kind : Event_Kind_Type; Obj : Entity_Ptr) is Entity_Kind : constant String := Entity_External_Tag (Obj.all); Event_Values : constant array (Event_Kind_Type) of Integer_32 := (Inc_Usage => +1, Dec_Usage => -1); begin if Get_Trace (Entity_Kind) then O (Event_Kind'Img & ": " & Entity_Kind & Integer_32'Image (Obj.Counter) & " ->" & Integer_32'Image (Obj.Counter + Event_Values (Event_Kind))); end if; end Trace_Event; ---------------- -- Use_Entity -- ---------------- procedure Use_Entity (The_Ref : in out Ref; The_Entity : Entity_Ptr) is begin pragma Assert (The_Ref.A_Ref = null and then The_Entity.Counter = 0); pragma Debug (C, Trace_Event (Inc_Usage, The_Entity)); The_Entity.Counter := 1; The_Ref.A_Ref := The_Entity; end Use_Entity; end PolyORB.Smart_Pointers; polyorb-2.8~20110207.orig/src/polyorb-rt_poa_policies.ads0000644000175000017500000000416311750740340022525 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . R T _ P O A _ P O L I C I E S -- -- -- -- S p e c -- -- -- -- Copyright (C) 2004 Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by ACT Europe. -- -- (email: sales@act-europe.fr) -- -- -- ------------------------------------------------------------------------------ package PolyORB.RT_POA_Policies is pragma Pure (PolyORB.RT_POA_Policies); end PolyORB.RT_POA_Policies; polyorb-2.8~20110207.orig/src/polyorb-setup-oa.ads0000644000175000017500000000416211750740340021106 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . S E T U P . O A -- -- -- -- S p e c -- -- -- -- Copyright (C) 2003 Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by ACT Europe. -- -- (email: sales@act-europe.fr) -- -- -- ------------------------------------------------------------------------------ -- Root package for the setup of the object adapters. package PolyORB.Setup.OA is end PolyORB.Setup.OA; polyorb-2.8~20110207.orig/src/polyorb-utils.ads0000644000175000017500000001266711750740340020522 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . U T I L S -- -- -- -- S p e c -- -- -- -- Copyright (C) 2001-2008, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- Miscellaneous utility subprograms with Ada.Streams; package PolyORB.Utils is pragma Pure; function Hex_Value (C : Character) return Integer; -- The integer value corresponding to hexadecimal digit C. -- If C is not a valid hexadecimal digit, Constraint_Error is raised. function SEA_To_Hex_String (A : Ada.Streams.Stream_Element_Array) return String; -- Return a string of hexadecimal digits representing the contents of A function Hex_String_To_SEA (S : String) return Ada.Streams.Stream_Element_Array; -- Return the Stream_Element_Array represented by hexadecimal string S No_Escape : constant String := ""; function URI_Encode (S : String; Also_Escape : String := "/") return String; -- Implement the encoding scheme defined in the RFC 2396. -- Return S with special characters replaced by "%" "hexdigit" -- "hexdigit" if these characters need to be escaped in URIs. Any -- character in Also_Escape is considered as special. function URI_Decode (S : String) return String; -- Implement the decoding scheme defined in the RFC 2396. -- Return S with any %xy sequence replaced with the character whose -- hexadecimal representation is xy. ----------------------- -- String operations -- ----------------------- type Direction_Type is private; Forward : constant Direction_Type; Backward : constant Direction_Type; function Find_Skip (S : String; Start : Integer; What : Character; Skip : Boolean; Direction : Direction_Type) return Integer; -- If Skip is False, return the index of the first occurrence of What in S -- starting at Start and going in the indicated direction (which can be -- Forward or Backward). -- If Skip is True, return the index of the first occurrence of any -- character OTHER THAN What. -- If no such character exists, S'Last + 1 is returned if Direction is -- Forward, or S'First - 1 if Direction is Backward. -- Shorthands for commonly-used forms of Find_Skip function Find (S : String; Start : Integer; What : Character; Skip : Boolean := False; Direction : Direction_Type := Forward) return Integer renames Find_Skip; function Find_Whitespace (S : String; Start : Integer; What : Character := ' '; Skip : Boolean := False; Direction : Direction_Type := Forward) return Integer renames Find_Skip; function Skip_Whitespace (S : String; Start : Integer; What : Character := ' '; Skip : Boolean := True; Direction : Direction_Type := Forward) return Integer renames Find_Skip; function Has_Prefix (S : String; Prefix : String) return Boolean; -- True if, and only if, S starts with Prefix function To_Upper (S : String) return String; -- Folds all characters of string S to upper case function To_Lower (S : String) return String; -- Folds all characters of string S to lower case private type Direction_Type is new Integer range -1 .. +1; Forward : constant Direction_Type := +1; Backward : constant Direction_Type := -1; -- Direction_Type value 0 does not make sense pragma Inline (Hex_Value, SEA_To_Hex_String, Hex_String_To_SEA, URI_Encode, URI_Decode, Find_Skip); end PolyORB.Utils; polyorb-2.8~20110207.orig/src/polyorb-poa.ads0000644000175000017500000003534411750740340020136 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . P O A -- -- -- -- S p e c -- -- -- -- Copyright (C) 2001-2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- Abstract interface for the POA Object Adapter -- This package provides a higher level abstraction (the POA) of a -- PolyORB's Object Adapter as defined in PolyORB.Obj_Adapters. -- PolyORB's POA is notionnaly equivalent to CORBA's POA. -- PolyORB's POA can be accessed through two different interfaces: -- - a CORBA-like interface', which encompasses CORBA POA API; -- - the PolyORB Obj_Adapter interface, as defined in PolyORB.Obj_Adapters. -- Thus, an implementation of this interface must provide both the -- CORBA-like POA interface and the PolyORB Obj_Adapter interface. with PolyORB.Any.NVList; with PolyORB.Errors; with PolyORB.Objects; with PolyORB.Object_Maps; with PolyORB.POA_Manager; with PolyORB.POA_Policies; with PolyORB.POA_Policies.Thread_Policy; with PolyORB.POA_Policies.Request_Processing_Policy; with PolyORB.POA_Policies.Id_Assignment_Policy; with PolyORB.POA_Policies.Id_Uniqueness_Policy; with PolyORB.POA_Policies.Servant_Retention_Policy; with PolyORB.POA_Policies.Lifespan_Policy; with PolyORB.POA_Policies.Implicit_Activation_Policy; with PolyORB.POA_Types; with PolyORB.QoS; with PolyORB.Servants; with PolyORB.Tasking.Mutexes; with PolyORB.Types; with PolyORB.Utils.Strings; package PolyORB.POA is pragma Elaborate_Body; use PolyORB.POA_Policies.Thread_Policy; use PolyORB.POA_Policies.Request_Processing_Policy; use PolyORB.POA_Policies.Id_Assignment_Policy; use PolyORB.POA_Policies.Id_Uniqueness_Policy; use PolyORB.POA_Policies.Servant_Retention_Policy; use PolyORB.POA_Policies.Lifespan_Policy; use PolyORB.POA_Policies.Implicit_Activation_Policy; use PolyORB.POA_Types; use PolyORB.Utils.Strings; --------------------------- -- POA Obj_Adapter type. -- --------------------------- type Obj_Adapter is abstract new PolyORB.POA_Types.Obj_Adapter with record Name : String_Ptr; -- The POA's name. If this is null, the object has been destroyed Boot_Time : Duration; -- Creation date of this POA Absolute_Address : String_Ptr; -- Absolute path of this POA relative to the root POA POA_Manager : PolyORB.POA_Manager.Ref; -- POA Manager attached to this POA Adapter_Activator : AdapterActivator_Access; -- Adapter Activator attached to this POA (null if not used) Active_Object_Map : PolyORB.Object_Maps.Object_Map_Access; -- The active object map (null if the policies used for this POA -- do not require one). Default_Servant : Servants.Servant_Access; -- The default servant (null if the policies used for this POA -- do not require one). Servant_Manager : ServantManager_Access; -- The servant manager (null if the policies used for this POA -- do not require one). -- Policies (one of each is required) Thread_Policy : ThreadPolicy_Access := null; Request_Processing_Policy : RequestProcessingPolicy_Access := null; Id_Assignment_Policy : IdAssignmentPolicy_Access := null; Id_Uniqueness_Policy : IdUniquenessPolicy_Access := null; Servant_Retention_Policy : ServantRetentionPolicy_Access := null; Lifespan_Policy : LifespanPolicy_Access := null; Implicit_Activation_Policy : ImplicitActivationPolicy_Access := null; Father : Obj_Adapter_Access; -- Parent POA Children : POATable_Access; -- All child-POAs of this POA POA_Lock : Tasking.Mutexes.Mutex_Access; Children_Lock : Tasking.Mutexes.Mutex_Access; Map_Lock : Tasking.Mutexes.Mutex_Access; -- Locks end record; type Obj_Adapter_Access is access all Obj_Adapter'Class; -- The POA object -- XXX Part of this should be private (locks, active object map, father...) ------------------------------ -- CORBA-like POA interface -- ------------------------------ procedure Create_POA (Self : access Obj_Adapter; Adapter_Name : Standard.String; A_POAManager : POA_Manager.POAManager_Access; Policies : POA_Policies.PolicyList; POA : out Obj_Adapter_Access; Error : in out PolyORB.Errors.Error_Container) is abstract; -- Create a POA given its name and a list of policies -- Policies are optionnal : defaults values are provided. -- Compability of Policies is checked. procedure Initialize_POA (Self : access Obj_Adapter; Adapter_Name : Standard.String; A_POAManager : POA_Manager.POAManager_Access; Policies : POA_Policies.PolicyList; POA : in out Obj_Adapter_Access; Error : in out PolyORB.Errors.Error_Container); -- Create a POA given its name and a list of policies Policies are -- optionnal : defaults values are provided. Compability of Policies is -- checked. procedure Find_POA (Self : access Obj_Adapter; Name : String; Activate_It : Boolean; POA : out Obj_Adapter_Access; Error : in out PolyORB.Errors.Error_Container); -- Starting from given POA, looks for the POA in all the descendancy whose -- name is Name. Returns null if not found. procedure Destroy (Self : access Obj_Adapter; Etherealize_Objects : Types.Boolean; Wait_For_Completion : Types.Boolean); -- Destroys recursively the POA and all his descendants procedure Create_Object_Identification (Self : access Obj_Adapter; Hint : Object_Id_Access; U_Oid : out Unmarshalled_Oid; Error : in out PolyORB.Errors.Error_Container); -- Reserve a complete object identifier, possibly using the given Hint (if -- not null) for the construction of the object identifier included in the -- Object_Id. procedure Activate_Object (Self : access Obj_Adapter; P_Servant : Servants.Servant_Access; Hint : Object_Id_Access; U_Oid : out Unmarshalled_Oid; Error : in out PolyORB.Errors.Error_Container); -- Activates an object, i.e. associate it with a local identification, -- possibly using the given Hint (if not null) for the construction of the -- object identifier included in the Object_Id. procedure Deactivate_Object (Self : access Obj_Adapter; Oid : Object_Id; Error : in out PolyORB.Errors.Error_Container); -- Deactivates an object from the Active Object Map (requires the RETAIN -- policy). In case a ServantManager is used, calls its etherealize -- method. -- Active requests should be completed before the object is removed -- XXX ??? How do we implement that? How do we implement the queue? procedure Servant_To_Id (Self : access Obj_Adapter; P_Servant : Servants.Servant_Access; Oid : out Object_Id_Access; Error : in out PolyORB.Errors.Error_Container); procedure Id_To_Servant (Self : access Obj_Adapter; Oid : Object_Id; Servant : out Servants.Servant_Access; Error : in out PolyORB.Errors.Error_Container); -- Requires RETAIN or USE_DEFAULT_SERVANT -- Case RETAIN: -- Look for the given Object_Id in the Active Object Map. -- If found, returns the associated servant. -- Case USE_DEFAULT_SERVANT: -- If the Object_Id is not in the map, or the NON_RETAIN policy is used, -- returns the default servant (if one has been registered). -- Otherwise: -- Raises ObjectNotActive procedure Get_Servant (Self : access Obj_Adapter; Servant : out Servants.Servant_Access; Error : in out PolyORB.Errors.Error_Container); procedure Set_Servant (Self : access Obj_Adapter; Servant : Servants.Servant_Access; Error : in out PolyORB.Errors.Error_Container); procedure Get_Servant_Manager (Self : access Obj_Adapter; Manager : out ServantManager_Access; Error : in out PolyORB.Errors.Error_Container); procedure Set_Servant_Manager (Self : access Obj_Adapter; Manager : ServantManager_Access; Error : in out PolyORB.Errors.Error_Container); procedure Get_The_Children (Self : access Obj_Adapter; Children : out POAList); -------------------------------------------------- -- PolyORB Obj_Adapter interface implementation -- -------------------------------------------------- procedure Create (OA : access Obj_Adapter); procedure Destroy (OA : access Obj_Adapter); procedure Export (OA : access Obj_Adapter; Obj : Servants.Servant_Access; Key : Objects.Object_Id_Access; Oid : out Objects.Object_Id_Access; Error : in out PolyORB.Errors.Error_Container); procedure Unexport (OA : access Obj_Adapter; Id : Objects.Object_Id_Access; Error : in out PolyORB.Errors.Error_Container); procedure Object_Key (OA : access Obj_Adapter; Id : Objects.Object_Id_Access; User_Id : out Objects.Object_Id_Access; Error : in out PolyORB.Errors.Error_Container); procedure Get_QoS (OA : access Obj_Adapter; Id : Objects.Object_Id; QoS : out PolyORB.QoS.QoS_Parameters; Error : in out PolyORB.Errors.Error_Container); function Get_Empty_Arg_List (OA : access Obj_Adapter; Oid : access Objects.Object_Id; Method : String) return Any.NVList.Ref; function Get_Empty_Result (OA : access Obj_Adapter; Oid : access Objects.Object_Id; Method : String) return Any.Any; procedure Find_Servant (OA : access Obj_Adapter; Id : access Objects.Object_Id; Servant : out Servants.Servant_Access; Error : in out PolyORB.Errors.Error_Container); procedure Release_Servant (OA : access Obj_Adapter; Id : access Objects.Object_Id; Servant : in out Servants.Servant_Access); ----------------------- -- Utility functions -- ----------------------- procedure Copy_Obj_Adapter (From : Obj_Adapter; To : access Obj_Adapter); -- Copy values from one Obj_Adapter to another (Obj_Adapter is limited) procedure Remove_POA_By_Name (Self : access Obj_Adapter; Child_Name : Standard.String); -- Remove a child POA from Self's list of children -- Does not lock the list of children procedure Oid_To_Rel_URI (OA : access Obj_Adapter; Id : access Object_Id; URI : out Types.String; Error : in out PolyORB.Errors.Error_Container); -- Convert an object id to its representation as a relative URI function Rel_URI_To_Oid (OA : access Obj_Adapter; URI : String) return Object_Id_Access; -- Convert an object id from its representation as a relative URI private procedure Init_With_User_Policies (OA : access Obj_Adapter; Policies : POA_Policies.PolicyList); -- Initialize OA with a set of policies provided by the user procedure Init_With_Default_Policies (OA : access Obj_Adapter); -- Initialize OA with a default set of policies provided by the currently -- active POA configuration. procedure Check_Policies_Compatibility (OA : Obj_Adapter_Access; Error : in out PolyORB.Errors.Error_Container); procedure Destroy_Policies (OA : in out Obj_Adapter); pragma Warnings (Off); pragma Unreferenced (Destroy_Policies); pragma Warnings (On); -- Destroys OA's policies procedure Create_Root_POA (New_Obj_Adapter : access Obj_Adapter); -- Create the Root of all POAs procedure Find_Servant (OA : access Obj_Adapter; Id : access Objects.Object_Id; Do_Check : Boolean; Servant : out Servants.Servant_Access; Error : in out PolyORB.Errors.Error_Container); -- The Find_Servant from PolyORB, plus a parameter. -- If Do_Check is True, then the POA checks the state of its POA -- Manager. procedure Set_Policies (OA : access Obj_Adapter; Policies : POA_Policies.PolicyList; Default : Boolean); -- Set OA policies from the values in Policies. -- If Default is True, set only those policies that -- are not yet explicitly set in OA. If Default is False, -- set all policies, and warn for duplicates. function POA_Manager_Of (OA : access Obj_Adapter) return POA_Manager.POAManager_Access; -- Return the POA Manager associated to 'OA' end PolyORB.POA; polyorb-2.8~20110207.orig/src/polyorb-protocols.ads0000644000175000017500000001500411750740340021372 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . P R O T O C O L S -- -- -- -- S p e c -- -- -- -- Copyright (C) 2001-2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- Support for object method invocation protocols. with Ada.Streams; with PolyORB.Any.NVList; with PolyORB.Binding_Data; with PolyORB.Binding_Objects; with PolyORB.Components; with PolyORB.Errors; with PolyORB.Filters; with PolyORB.Requests; with PolyORB.Annotations; package PolyORB.Protocols is -- A protocol is a factory of sessions. Each session corresponds -- to a connection to a remote protocol entity. -- XXX This package needs some comments and in particular the -- callback and the demux stuff. use PolyORB.Filters; use PolyORB.Requests; type Protocol is abstract new Filters.Factory with private; type Protocol_Access is access all Protocol'Class; type Session is abstract new Filters.Filter with private; type Session_Access is access all Session'Class; procedure Create (Proto : access Protocol; Session : out Filter_Access) is abstract; -- Create a Session for protocol Proto using filter Lower. -------------------------------------------------- -- Primitives needed with some tasking policies -- -------------------------------------------------- procedure Set_Task_Info (S : Session_Access; N : PolyORB.Annotations.Notepad_Access); -- Set the notes associated with session function Get_Task_Info (S : Session_Access) return PolyORB.Annotations.Notepad_Access; -- Return the notes associated with session. ----------------------------------------------------- -- Protocol primitives (interface to upper layers) -- ----------------------------------------------------- procedure Invoke_Request (S : access Session; R : Requests.Request_Access; P : access Binding_Data.Profile_Type'Class) is abstract; -- Send a method invocation message for request R on session S. -- P designates the profile of the target object reference that -- was bound to establish session S. procedure Abort_Request (S : access Session; R : Request_Access) is abstract; -- Abort pending invocation of R. procedure Send_Reply (S : access Session; R : Request_Access) is abstract; -- Send back a reply on S notifying caller of the result -- of executing R. ------------------------------------------------ -- Callback point (interface to lower layers) -- ------------------------------------------------ procedure Handle_Connect_Indication (S : access Session) is abstract; -- A new server connection has been accepted as session S. procedure Handle_Connect_Confirmation (S : access Session) is abstract; -- A new client connection has been established as session S. procedure Handle_Data_Indication (S : access Session; Data_Amount : Ada.Streams.Stream_Element_Count; Error : in out Errors.Error_Container) is abstract; -- Invoked when some data arrives for session S. procedure Handle_Disconnect (S : access Session; Error : Errors.Error_Container) is abstract; -- Invoked when the underlying connection is closed. Any pending request -- must be marked as completed, and the corresponding target reference -- must be unbound. procedure Handle_Unmarshall_Arguments (S : access Session; Args : in out Any.NVList.Ref; Error : in out Errors.Error_Container); -- Invoked when the application needs unmarshalled arguments -- for a request. Must be implemented by protocols that -- allow deferred arguments unmarshalling. procedure Handle_Flush (S : access Session) is abstract; -- Flush all pending received data in S, and make S read to -- receive a new incoming message. --------------------- -- Message demuxer -- --------------------- function Handle_Message (Sess : not null access Session; S : Components.Message'Class) return Components.Message'Class; -- Demultiplex Messages to the above specialized operations private type Protocol is abstract new Filters.Factory with null record; type Session is abstract new Filters.Filter with record Server : Components.Component_Access; -- The ORB instance Dependent_Binding_Object : Binding_Objects.Binding_Object_Access; -- The enclosing binding object, if this session is on server side -- (used to keep the BO referenced and prevent it from being destroyed -- while the request is being processed). N : PolyORB.Annotations.Notepad_Access := null; end record; end PolyORB.Protocols; polyorb-2.8~20110207.orig/src/polyorb-sequences-helper.adb0000644000175000017500000001652011750740340022601 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . S E Q U E N C E S . H E L P E R -- -- -- -- B o d y -- -- -- -- Copyright (C) 2003-2009, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- Any conversion subprograms for sequences (both bounded and unbounded) with Ada.Unchecked_Deallocation; package body PolyORB.Sequences.Helper is use PolyORB.Any; use PolyORB.Types; -- Global data Initialized : Boolean := False; Sequence_TC, Element_TC : PolyORB.Any.TypeCode.Local_Ref; ----------- -- Clone -- ----------- function Clone (ACC : Sequence_Content; Into : PolyORB.Any.Content_Ptr := null) return PolyORB.Any.Content_Ptr is Target : Content_Ptr; begin if Into /= null then if Into.all not in Sequence_Content then return null; end if; Target := Into; else Target := new Sequence_Content; Sequence_Content (Target.all).V := new Sequence; end if; Sequence_Content (Target.all).V.all := ACC.V.all; Sequence_Content (Target.all).Length_Cache := ACC.Length_Cache; return Target; end Clone; -------------------- -- Finalize_Value -- -------------------- procedure Finalize_Value (ACC : in out Sequence_Content) is procedure Free is new Ada.Unchecked_Deallocation (Sequence, Sequence_Ptr); begin Free (ACC.V); end Finalize_Value; -------------- -- From_Any -- -------------- function From_Any (Item : Any.Any) return Sequence is pragma Suppress (Discriminant_Check); Len : constant Integer := Integer (Types.Unsigned_Long'(Get_Aggregate_Element (Item, 0))); Result : aliased Sequence := New_Sequence (Len); begin pragma Assert (Initialized); for J in 1 .. Len loop Unchecked_Element_Of (Result'Access, J).all := Element_From_Any (Get_Aggregate_Element (Item, Element_TC, Types.Unsigned_Long (J))); end loop; return Result; end From_Any; ------------------------- -- Get_Aggregate_Count -- ------------------------- function Get_Aggregate_Count (ACC : Sequence_Content) return PolyORB.Types.Unsigned_Long is begin return PolyORB.Types.Unsigned_Long (Length (ACC.V.all) + 1); end Get_Aggregate_Count; --------------------------- -- Get_Aggregate_Element -- --------------------------- function Get_Aggregate_Element (ACC : not null access Sequence_Content; TC : PolyORB.Any.TypeCode.Object_Ptr; Index : PolyORB.Types.Unsigned_Long; Mech : not null access PolyORB.Any.Mechanism) return PolyORB.Any.Content'Class is pragma Unreferenced (TC); begin if Index = 0 then Mech.all := PolyORB.Any.By_Value; ACC.Length_Cache := Types.Unsigned_Long (Length (ACC.V.all)); return PolyORB.Any.Wrap (ACC.Length_Cache'Unrestricted_Access); else Mech.all := PolyORB.Any.By_Reference; return Element_Wrap (Unchecked_Element_Of (ACC.V, Standard.Positive (Index))); end if; end Get_Aggregate_Element; ---------------- -- Initialize -- ---------------- procedure Initialize (Element_TC, Sequence_TC : PolyORB.Any.TypeCode.Local_Ref) is begin Helper.Element_TC := Element_TC; Helper.Sequence_TC := Sequence_TC; Initialized := True; end Initialize; ------------------------- -- Set_Aggregate_Count -- ------------------------- procedure Set_Aggregate_Count (ACC : in out Sequence_Content; Count : PolyORB.Types.Unsigned_Long) is begin Set_Length (ACC.V.all, Length => Integer (Count - 1)); end Set_Aggregate_Count; --------------------------- -- Set_Aggregate_Element -- --------------------------- procedure Set_Aggregate_Element (ACC : in out Sequence_Content; TC : TypeCode.Object_Ptr; Index : Types.Unsigned_Long; From_C : in out Any_Container'Class) is pragma Unreferenced (TC); begin -- For a sequence aggregate, only index 0 (the length item) is by value pragma Assert (Index = 0); -- Check consistency and discard value pragma Assert (PolyORB.Types.Unsigned_Long (Length (ACC.V.all)) = PolyORB.Any.From_Any (From_C)); null; end Set_Aggregate_Element; ------------ -- To_Any -- ------------ function To_Any (Item : Sequence) return Any.Any is pragma Assert (Initialized); Result : Any.Any; begin Set_Type (Result, Sequence_TC); Set_Value (Get_Container (Result).all, new Sequence_Content' (Any.Aggregate_Content with V => new Sequence'(Item), Length_Cache => Unsigned_Long (Length (Item))), Foreign => False); return Result; end To_Any; --------------------- -- Unchecked_Get_V -- --------------------- function Unchecked_Get_V (ACC : not null access Sequence_Content) return System.Address is begin if ACC.V = null or else Length (ACC.V.all) = 0 then return System.Null_Address; end if; return Unchecked_Element_Of (ACC.V, 1).all'Address; end Unchecked_Get_V; ---------- -- Wrap -- ---------- function Wrap (X : access Sequence) return Any.Content'Class is begin return Sequence_Content'(Any.Aggregate_Content with V => Sequence_Ptr (X), Length_Cache => 0); end Wrap; end PolyORB.Sequences.Helper; polyorb-2.8~20110207.orig/src/polyorb-smart_pointers-controlled_entities.adb0000644000175000017500000000523011750740340026445 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- POLYORB.SMART_POINTERS.CONTROLLED_ENTITIES -- -- -- -- B o d y -- -- -- -- Copyright (C) 2001-2009, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ package body PolyORB.Smart_Pointers.Controlled_Entities is -------------- -- Finalize -- -------------- procedure Finalize (X : in out Entity_Controller) is begin Finalize (X.E.all); end Finalize; ---------------- -- Initialize -- ---------------- procedure Initialize (X : in out Entity_Controller) is begin Initialize (X.E.all); end Initialize; ------------------- -- Is_Controlled -- ------------------- function Is_Controlled (X : Entity) return Boolean is pragma Unreferenced (X); begin return True; end Is_Controlled; end PolyORB.Smart_Pointers.Controlled_Entities; polyorb-2.8~20110207.orig/src/polyorb-minimal_servant-tools.ads0000644000175000017500000000542011750740340023675 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . M I N I M A L _ S E R V A N T . T O O L S -- -- -- -- S p e c -- -- -- -- Copyright (C) 2002-2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with PolyORB.Errors; with PolyORB.Minimal_Servant; with PolyORB.References; with PolyORB.Types; with PolyORB.Obj_Adapters; package PolyORB.Minimal_Servant.Tools is procedure Initiate_Servant (Obj : access PolyORB.Minimal_Servant.Servant'Class; Type_Id : PolyORB.Types.String; Ref : out PolyORB.References.Ref; Error : in out PolyORB.Errors.Error_Container); procedure Initiate_Servant (Obj : access PolyORB.Minimal_Servant.Servant'Class; Obj_Adapter : PolyORB.Obj_Adapters.Obj_Adapter_Access; Type_Id : PolyORB.Types.String; Ref : out PolyORB.References.Ref; Error : in out PolyORB.Errors.Error_Container); procedure Run_Server; end PolyORB.Minimal_Servant.Tools; polyorb-2.8~20110207.orig/src/polyorb-utils-hfunctions-mul.ads0000644000175000017500000000625011750740340023462 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . U T I L S . H F U N C T I O N S . M U L -- -- -- -- S p e c -- -- -- -- Copyright (C) 2003 Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by ACT Europe. -- -- (email: sales@act-europe.fr) -- -- -- ------------------------------------------------------------------------------ -- This package provides a simple class of hashing functions for strings. -- Hash_Mul computes for string S = (Si)i the sum of the elements -- Hi (S) = (( K * Si ) mod Prime) mod Size -- Note: this class of function is not universal. package PolyORB.Utils.HFunctions.Mul is pragma Preelaborate; function Hash_Mul (S : String; K : Natural; Prime : Natural; Size : Natural) return Natural; -- Hash function implemented by this package. -- S: key to hash, -- (K, Prime): Hash function parameters, -- Size: restrict results to range O .. Size - 1. type Hash_Mul_Parameters is new Hash_Parameters with private; function Hash (S : String; Param : Hash_Mul_Parameters; Size : Natural) return Natural; function Default_Hash_Parameters return Hash_Mul_Parameters; pragma Inline (Default_Hash_Parameters); function Next_Hash_Parameters (Param : Hash_Mul_Parameters) return Hash_Mul_Parameters; private type Hash_Mul_Parameters is new Hash_Parameters with record K : Natural; Prime : Natural; end record; end PolyORB.Utils.HFunctions.Mul; polyorb-2.8~20110207.orig/src/polyorb-poa_config-proxies.ads0000644000175000017500000000470711750740340023151 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . P O A _ C O N F I G . P R O X I E S -- -- -- -- S p e c -- -- -- -- Copyright (C) 2002 Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by ACT Europe. -- -- (email: sales@act-europe.fr) -- -- -- ------------------------------------------------------------------------------ -- A POA configuration for the Proxy-objects-subPOA. package PolyORB.POA_Config.Proxies is pragma Elaborate_Body; type Configuration is new Configuration_Type with private; procedure Initialize (C : Configuration); function Default_Policies (C : Configuration) return PolyORB.POA_Policies.PolicyList; private type Configuration is new Configuration_Type with null record; end PolyORB.POA_Config.Proxies; polyorb-2.8~20110207.orig/src/polyorb-utils-simple_flags.adb0000644000175000017500000000701011750740340023126 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . U T I L S . S I M P L E _ F L A G S -- -- -- -- B o d y -- -- -- -- Copyright (C) 2002-2008, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ package body PolyORB.Utils.Simple_Flags is ---------- -- Mask -- ---------- function Mask (N : Bit_Count) return Flags_Type is begin return Shift_Left (1, Natural (N)); end Mask; ------------ -- Is_Set -- ------------ function Is_Set (Flag_To_Test : Flags_Type; In_Flags : Flags_Type) return Boolean is begin return ((Flag_To_Test and In_Flags) = Flag_To_Test); end Is_Set; ------------ -- Is_Set -- ------------ function Is_Set (N : Bit_Count; In_Flags : Flags_Type) return Boolean is M : constant Flags_Type := Mask (N); begin return Is_Set (M, In_Flags); end Is_Set; --------- -- Set -- --------- function Set (Flag_To_Set : Flags_Type; In_Flags : Flags_Type) return Flags_Type is begin return (In_Flags and Flag_To_Set); end Set; --------- -- Set -- --------- function Set (N : Bit_Count; In_Flags : Flags_Type) return Flags_Type is M : constant Flags_Type := Mask (N); begin return Set (M, In_Flags); end Set; --------- -- Set -- --------- procedure Set (Flag_Field : in out Flags_Type; N : Bit_Count; Value : Boolean) is M : constant Flags_Type := Mask (N); begin if Value then Flag_Field := (Flag_Field and (not M)) or M; else Flag_Field := Flag_Field and (not M); end if; end Set; end PolyORB.Utils.Simple_Flags; polyorb-2.8~20110207.orig/src/polyorb-exceptions.ads0000644000175000017500000001262511750740340021535 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . E X C E P T I O N S -- -- -- -- S p e c -- -- -- -- Copyright (C) 2002-2007, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- Exceptions management subsystem -- PolyORB distinguishes errors and exceptions: -- -- A non null error means that a wrong execution occurs within -- PolyORB's core middleware or one of its personalities. -- -- An exception is one possible result of the execution of a -- personality-specific function or procedure. It is either raised -- within application personality context, or returned in the request -- response message. -- -- When raised, exception is built from error information, -- translated to personality specific context. -- PolyORB's core middleware should not raise exceptions, except Ada -- standard exceptions as defined in the Ada Reference Manual. It -- should instead return a non null Error_Container. with Ada.Exceptions; with PolyORB.Any; with PolyORB.Errors; with PolyORB.Types; package PolyORB.Exceptions is use PolyORB.Errors; --------------------- -- User exceptions -- --------------------- procedure User_Get_Members (Occurrence : Ada.Exceptions.Exception_Occurrence; Members : out Exception_Members'Class); -- Extract members from User exception occurence procedure User_Purge_Members (Occurrence : Ada.Exceptions.Exception_Occurrence); -- Forget exception members associated with an exception occurrence procedure User_Raise_Exception (Id : Ada.Exceptions.Exception_Id; Members : Exception_Members'Class; Message : Standard.String := ""); pragma No_Return (User_Raise_Exception); -- Raise a user exception with the specified members. procedure Raise_User_Exception_From_Any (Repository_Id : PolyORB.Types.RepositoryId; Occurence : PolyORB.Any.Any; Message : Standard.String := ""); type Raise_From_Any_Procedure is access procedure (Occurrence : PolyORB.Any.Any; Message : Standard.String); procedure Default_Raise_From_Any (Occurrence : PolyORB.Any.Any); procedure Register_Exception (TC : PolyORB.Any.TypeCode.Local_Ref; Raiser : Raise_From_Any_Procedure); -- Associate the TypeCode for a user-defined exception with -- a procedure that raises an occurrence of that exception, -- given an Any with that TypeCode. -- (When a client creates a request, it is his responsability -- to provide the list of typecodes of potential exceptions, -- so the generic middleware can unmarshall occurrences and -- store them into an Any. It is then the responsibility of -- the application layer -- eg. the CORBA PortableServer -- -- to map the Any back to whatever representation is relevant -- in the application personality: here, raising a language -- exception with proper members. --------------------------------- -- Exception utility functions -- --------------------------------- function Exception_Name (Repository_Id : Standard.String) return Standard.String; -- Return the name of an exception from its repository ID procedure Exception_Name_To_Error_Id (Name : String; Is_Error : out Boolean; Id : out Error_Id); -- Convert an exception name into a PolyORB's Error Id function Get_ExcepId_By_Name (Name : Standard.String) return Ada.Exceptions.Exception_Id; -- Returns the exception id from its name function Occurrence_To_Name (Occurrence : Ada.Exceptions.Exception_Occurrence) return String; end PolyORB.Exceptions; polyorb-2.8~20110207.orig/src/polyorb-sequences-bounded.adb0000644000175000017500000005004011750740340022735 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . S E Q U E N C E S . B O U N D E D -- -- -- -- B o d y -- -- -- -- Copyright (C) 2002-2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with Ada.Unchecked_Deallocation; package body PolyORB.Sequences.Bounded is ---------------------------------------------- -- SVM implementation for bounded sequences -- ---------------------------------------------- procedure Run is new Sequences.Run (Element, Element_Array); -- Core execution engine function Run_Copy (Prog : Program; Left : Element_Array; Right : Element_Array := Null_Element_Array) return Sequence; -- Execute Prog and return a new sequence containing the result procedure Run_In_Place (Prog : Program; Left : in out Sequence; Right : Element_Array := Null_Element_Array); -- Execute Prog in-place on Left's storage ----------------------- -- Local subprograms -- ----------------------- function Append (Left : Element_Array; Right : Element_Array; Drop : Truncation := Error) return Sequence; -- Return Left & Right function Count_Index (Source : Sequence; Pattern : Element_Array; What : Search_Kind; Going : Direction := Forward) return Natural; -- Common subprogram used to implement Count and Index, depending on -- the What parameter. function Array_Bounds (A : Element_Array) return Bounds; -- Return (A'First, A'Last) function Sequence_Bounds (S : Sequence) return Bounds; -- Return (1, Length (S)) --------- -- "&" -- --------- function "&" (Left, Right : Sequence) return Sequence is begin return Append (Left, Right, Drop => Error); end "&"; --------- -- "&" -- --------- function "&" (Left : Sequence; Right : Element_Array) return Sequence is begin return Append (Left, Right, Drop => Error); end "&"; --------- -- "&" -- --------- function "&" (Left : Element_Array; Right : Sequence) return Sequence is begin return Append (Left, Right, Drop => Error); end "&"; --------- -- "&" -- --------- function "&" (Left : Sequence; Right : Element) return Sequence is begin return Append (Left, Right, Drop => Error); end "&"; --------- -- "&" -- --------- function "&" (Left : Element; Right : Sequence) return Sequence is begin return Append (Left, Right, Drop => Error); end "&"; --------- -- "*" -- --------- function "*" (Left : Natural; Right : Element) return Sequence is begin return Replicate (Left, Right, Drop => Error); end "*"; --------- -- "*" -- --------- function "*" (Left : Natural; Right : Element_Array) return Sequence is begin return Replicate (Left, Right, Drop => Error); end "*"; --------- -- "*" -- --------- function "*" (Left : Natural; Right : Sequence) return Sequence is begin return Replicate (Left, Right, Drop => Error); end "*"; --------- -- "=" -- --------- function "=" (Left, Right : Sequence) return Boolean is L : Natural renames Left.Length; begin return L = Right.Length and then Left.Content (1 .. L) = Right.Content (1 .. L); end "="; --------- -- "=" -- --------- function "=" (Left : Sequence; Right : Element_Array) return Boolean is begin return Left.Length = Right'Length and then Left.Content (1 .. Left.Length) = Right; end "="; --------- -- "=" -- --------- function "=" (Left : Element_Array; Right : Sequence) return Boolean is begin return Left'Length = Right.Length and then Left = Right.Content (1 .. Right.Length); end "="; ------------ -- Append -- ------------ function Append (Left : Element_Array; Right : Element_Array; Drop : Truncation := Error) return Sequence is Left_Bounds : constant Bounds := Array_Bounds (Left); begin -- Replace a null-length slice of Left located right after the last -- element with Right. return Run_Copy (Prog => Replace_Slice (Max_Length, Left_Bounds, Bounds'(Left_Bounds.Hi + 1, Left_Bounds.Hi), Array_Bounds (Right), Drop), Left => Left, Right => Right); end Append; ------------ -- Append -- ------------ function Append (Left, Right : Sequence; Drop : Truncation := Error) return Sequence is begin return Append (Left.Content (1 .. Left.Length), Right.Content (1 .. Right.Length), Drop); end Append; ------------ -- Append -- ------------ function Append (Left : Sequence; Right : Element_Array; Drop : Truncation := Error) return Sequence is begin return Append (Left.Content (1 .. Left.Length), Right, Drop); end Append; ------------ -- Append -- ------------ function Append (Left : Element_Array; Right : Sequence; Drop : Truncation := Error) return Sequence is begin return Append (Left, Right.Content (1 .. Right.Length), Drop); end Append; ------------ -- Append -- ------------ function Append (Left : Sequence; Right : Element; Drop : Truncation := Error) return Sequence is begin return Append (Left.Content (1 .. Left.Length), Element_Array'(1 => Right), Drop); end Append; ------------ -- Append -- ------------ function Append (Left : Element; Right : Sequence; Drop : Truncation := Error) return Sequence is begin return Append (Element_Array'(1 => Left), Right.Content (1 .. Right.Length), Drop); end Append; ------------ -- Append -- ------------ procedure Append (Source : in out Sequence; New_Item : Element_Array; Drop : Truncation := Error) is Left_Bounds : constant Bounds := Sequence_Bounds (Source); begin Run_In_Place (Prog => Replace_Slice (Max_Length, Left_Bounds, Bounds'(Left_Bounds.Hi + 1, Left_Bounds.Hi), Array_Bounds (New_Item), Drop), Left => Source, Right => New_Item); end Append; ------------ -- Append -- ------------ procedure Append (Source : in out Sequence; New_Item : Sequence; Drop : Truncation := Error) is begin Append (Source, New_Item.Content (1 .. New_Item.Length), Drop); end Append; ------------ -- Append -- ------------ procedure Append (Source : in out Sequence; New_Item : Element; Drop : Truncation := Error) is begin Append (Source, Element_Array'(1 => New_Item), Drop); end Append; ------------------ -- Array_Bounds -- ------------------ function Array_Bounds (A : Element_Array) return Bounds is begin return (Lo => A'First, Hi => A'Last); end Array_Bounds; ----------- -- Count -- ----------- function Count (Source : Sequence; Pattern : Element_Array) return Natural is begin return Count_Index (Source, Pattern, Return_Count, Forward); end Count; ----------------- -- Count_Index -- ----------------- function Count_Index (Source : Sequence; Pattern : Element_Array; What : Search_Kind; Going : Direction := Forward) return Natural is function Check_For_Pattern (Lo, Hi : Positive) return Boolean; function Check_For_Pattern (Lo, Hi : Positive) return Boolean is begin return Source.Content (Lo .. Hi) = Pattern; end Check_For_Pattern; begin return Sequences.Count_Index (Check_Slice => Check_For_Pattern'Unrestricted_Access, Source => Sequence_Bounds (Source), Pattern => Array_Bounds (Pattern), What => What, Going => Going); end Count_Index; ------------ -- Delete -- ------------ procedure Delete (Source : in out Sequence; From : Positive; Through : Natural) is begin Replace_Slice (Source, Low => From, High => Through, By => Null_Element_Array); end Delete; ------------ -- Delete -- ------------ function Delete (Source : Sequence; From : Positive; Through : Natural) return Sequence is begin return Replace_Slice (Source, Low => From, High => Through, By => Null_Element_Array); end Delete; ---------------- -- Element_Of -- ---------------- function Element_Of (Source : Sequence; Index : Positive) return Element is begin if Index > Source.Length then raise Index_Error; end if; return Source.Content (Index); end Element_Of; ---------- -- Free -- ---------- procedure Free (X : in out Element_Array_Access) is procedure Deallocate is new Ada.Unchecked_Deallocation (Element_Array, Element_Array_Access); begin Deallocate (X); end Free; ---------- -- Head -- ---------- procedure Head (Source : in out Sequence; Count : Natural; Pad : Element; Drop : Truncation := Error) is begin Run_In_Place (Prog => Head_Tail (Max_Length, Sequence_Bounds (Source), Count, Drop, Head), Left => Source, Right => Element_Array'(1 => Pad)); end Head; ---------- -- Head -- ---------- function Head (Source : Sequence; Count : Natural; Pad : Element; Drop : Truncation := Error) return Sequence is begin return Run_Copy (Prog => Head_Tail (Max_Length, Sequence_Bounds (Source), Count, Drop, Head), Left => Source.Content (1 .. Source.Length), Right => Element_Array'(1 => Pad)); end Head; ----------- -- Index -- ----------- function Index (Source : Sequence; Pattern : Element_Array; Going : Direction := Forward) return Natural is begin return Count_Index (Source, Pattern, Return_Index, Going); end Index; ------------ -- Insert -- ------------ function Insert (Source : Sequence; Before : Positive; New_Item : Element_Array; Drop : Truncation := Error) return Sequence is begin return Replace_Slice (Source, Low => Before, High => Before - 1, By => New_Item, Drop => Drop); end Insert; ------------ -- Insert -- ------------ procedure Insert (Source : in out Sequence; Before : Positive; New_Item : Element_Array; Drop : Truncation := Error) is begin Replace_Slice (Source, Low => Before, High => Before - 1, By => New_Item, Drop => Drop); end Insert; ------------ -- Length -- ------------ function Length (Source : Sequence) return Length_Range is begin return Source.Length; end Length; --------------- -- Overwrite -- --------------- procedure Overwrite (Source : in out Sequence; Position : Positive; New_Item : Element_Array; Drop : Truncation := Error) is begin Replace_Slice (Source => Source, Low => Position, High => Position + New_Item'Length - 1, By => New_Item, Drop => Drop); end Overwrite; --------------- -- Overwrite -- --------------- function Overwrite (Source : Sequence; Position : Positive; New_Item : Element_Array; Drop : Truncation := Error) return Sequence is begin return Replace_Slice (Source, Low => Position, High => Position + New_Item'Length - 1, By => New_Item, Drop => Drop); end Overwrite; --------------------- -- Replace_Element -- --------------------- procedure Replace_Element (Source : in out Sequence; Index : Positive; By : Element) is begin if Index > Source.Length then raise Index_Error; end if; Source.Content (Index) := By; end Replace_Element; ------------------- -- Replace_Slice -- ------------------- function Replace_Slice (Source : Sequence; Low : Positive; High : Natural; By : Element_Array; Drop : Truncation := Error) return Sequence is begin return Run_Copy (Prog => Replace_Slice (Max_Length, Sequence_Bounds (Source), Bounds'(Low, High), Array_Bounds (By), Drop), Left => Source.Content (1 .. Source.Length), Right => By); end Replace_Slice; ------------------- -- Replace_Slice -- ------------------- procedure Replace_Slice (Source : in out Sequence; Low : Positive; High : Natural; By : Element_Array; Drop : Truncation := Error) is begin Run_In_Place (Prog => Replace_Slice (Max_Length, Sequence_Bounds (Source), Bounds'(Low, High), Array_Bounds (By), Drop), Left => Source, Right => By); end Replace_Slice; --------------- -- Replicate -- --------------- function Replicate (Count : Natural; Item : Element; Drop : Truncation := Error) return Sequence is begin return Replicate (Count, Element_Array'(1 => Item), Drop); end Replicate; --------------- -- Replicate -- --------------- function Replicate (Count : Natural; Item : Element_Array; Drop : Truncation := Error) return Sequence is begin return Run_Copy (Prog => Replicate (Max_Length, Count, Array_Bounds (Item), Drop), Left => Item); end Replicate; --------------- -- Replicate -- --------------- function Replicate (Count : Natural; Item : Sequence; Drop : Truncation := Error) return Sequence is begin return Run_Copy (Prog => Replicate (Max_Length, Count, Sequence_Bounds (Item), Drop), Left => Item.Content (1 .. Item.Length)); end Replicate; -------------- -- Run_Copy -- -------------- function Run_Copy (Prog : Program; Left : Element_Array; Right : Element_Array := Null_Element_Array) return Sequence is Result : Sequence; begin Run (Prog, Result.Content, Left, Right); Result.Length := Prog.Result_Length; return Result; end Run_Copy; ------------------ -- Run_In_Place -- ------------------ procedure Run_In_Place (Prog : Program; Left : in out Sequence; Right : Element_Array := Null_Element_Array) is begin Run (Prog, Left.Content, Left.Content (1 .. Left.Length), Right); Left.Length := Prog.Result_Length; end Run_In_Place; --------------------- -- Sequence_Bounds -- --------------------- function Sequence_Bounds (S : Sequence) return Bounds is begin return (Lo => 1, Hi => S.Length); end Sequence_Bounds; --------- -- Set -- --------- procedure Set (Item : in out Sequence; Source : Element_Array; Drop : Truncation := Error) is begin Item := To_Sequence (Source, Drop); end Set; ---------------- -- Set_Length -- ---------------- procedure Set_Length (Source : in out Sequence; Length : Length_Range) is begin Source.Length := Length; end Set_Length; ----------- -- Slice -- ----------- function Slice (Source : Sequence; Low : Positive; High : Natural) return Element_Array is begin if Low > Source.Length + 1 or else High > Source.Length then raise Index_Error; end if; return Source.Content (Low .. High); end Slice; ---------- -- Tail -- ---------- procedure Tail (Source : in out Sequence; Count : Natural; Pad : Element; Drop : Truncation := Error) is begin Run_In_Place (Prog => Head_Tail (Max_Length, Sequence_Bounds (Source), Count, Drop, Tail), Left => Source, Right => Element_Array'(1 => Pad)); end Tail; ---------- -- Tail -- ---------- function Tail (Source : Sequence; Count : Natural; Pad : Element; Drop : Truncation := Error) return Sequence is begin return Run_Copy (Prog => Head_Tail (Max_Length, Sequence_Bounds (Source), Count, Drop, Tail), Left => Source.Content (1 .. Source.Length), Right => Element_Array'(1 => Pad)); end Tail; ---------------------- -- To_Element_Array -- ---------------------- function To_Element_Array (Source : Sequence) return Element_Array is begin return Source.Content (1 .. Source.Length); end To_Element_Array; ----------------- -- To_Sequence -- ----------------- function To_Sequence (Source : Element_Array; Drop : Truncation := Error) return Sequence is begin return Replicate (1, Source, Drop); end To_Sequence; ----------------- -- To_Sequence -- ----------------- function To_Sequence (Length : Length_Range) return Sequence is Result : Sequence; pragma Warnings (Off, Sequence); -- Not fully initialized, but the default initialization is what we -- want. begin Result.Length := Length; return Result; end To_Sequence; -------------------------- -- Unchecked_Element_Of -- -------------------------- function Unchecked_Element_Of (Source : access Sequence; Index : Positive) return Element_Ptr is begin if Index > Source.Length then raise Index_Error; end if; return Source.Content (Index)'Unrestricted_Access; end Unchecked_Element_Of; end PolyORB.Sequences.Bounded; polyorb-2.8~20110207.orig/src/polyorb-servants.adb0000644000175000017500000001377211750740340021204 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . S E R V A N T S -- -- -- -- B o d y -- -- -- -- Copyright (C) 2002-2011, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with PolyORB.Servants.Iface; with PolyORB.Tasking.Abortables; with PolyORB.Tasking.Threads; package body PolyORB.Servants is type Req_Runnable is new PolyORB.Tasking.Threads.Runnable with record Servant : access Servants.Servant'Class; Req : Requests.Request_Access; Completed : Boolean := False; Aborted : Boolean := True; end record; procedure Run (RR : not null access Req_Runnable); --------- -- Run -- --------- procedure Run (RR : not null access Req_Runnable) is begin RR.Completed := Execute_Servant (RR.Servant, RR.Req); -- Note: Can't set RR.Req.Completed here, since this would allow the -- requesting task to destroy RR.Req and prevent us from obtaining -- the RR.Req.Upcall_Abortable_Mutex to clean RR.Req.Upcall_Abortable -- (see Abortable_Execute_Servant). RR.Aborted := False; end Run; ------------------------------- -- Abortable_Execute_Servant -- ------------------------------- function Abortable_Execute_Servant (S : not null access Servant'Class; Req : Requests.Request_Access) return Boolean is use PolyORB.Tasking.Abortables; R : aliased Req_Runnable := (Servant => S, Req => Req, others => <>); pragma Warnings (Off); -- WAG:FSF-4.5.0 -- Hide warning "A is not referenced" A : aliased Abortable'Class := Make_Abortable (Abortable_Tag, R'Unchecked_Access); pragma Warnings (On); begin Req.Upcall_Abortable := A'Unchecked_Access; A.Run; Req.Upcall_Abortable_Mutex.Enter; Req.Upcall_Abortable := null; Req.Upcall_Abortable_Mutex.Leave; -- If aborted, mark the request to inhibit sending of a reply if R.Aborted then Req.Aborted := True; end if; -- Generate Executed_Request if completed normally or aborted return R.Completed or R.Aborted; end Abortable_Execute_Servant; ------------------------ -- Execute_In_Context -- ------------------------ function Execute_In_Context (Self : access Executor; Req : Requests.Request_Access; Requestor : Components.Component_Access) return Boolean is use PolyORB.Servants; pragma Unreferenced (Self); begin return Abortable_Execute_Servant (Servant_Access (Requestor), Req); end Execute_In_Context; ---------------- -- Notepad_Of -- ---------------- function Notepad_Of (S : Servant_Access) return PolyORB.Annotations.Notepad_Access is begin return S.Notepad'Access; end Notepad_Of; ------------------ -- Set_Executor -- ------------------ procedure Set_Executor (S : access Servant; Exec : Executor_Access) is begin S.Exec := Exec; end Set_Executor; -------------------- -- Handle_Message -- -------------------- function Handle_Message (S : not null access Servant; Msg : Components.Message'Class) return Components.Message'Class is use PolyORB.Servants.Iface; begin if Msg in Execute_Request then declare Req : constant Requests.Request_Access := Execute_Request (Msg).Req; begin if Execute_In_Context (S.Exec, Req, PolyORB.Components.Component_Access (S)) then return Executed_Request'(Req => Req); else return Components.Null_Message'(null record); end if; end; elsif Msg in Abort_Request then declare Req : constant Requests.Request_Access := Abort_Request (Msg).Req; begin Req.Upcall_Abortable_Mutex.Enter; if Req.Upcall_Abortable /= null then Req.Upcall_Abortable.Abort_Run; end if; Req.Upcall_Abortable_Mutex.Leave; end; return Components.Null_Message'(null record); else raise Program_Error; end if; end Handle_Message; end PolyORB.Servants; polyorb-2.8~20110207.orig/src/giop/0000755000175000017500000000000011750740340016127 5ustar xavierxavierpolyorb-2.8~20110207.orig/src/giop/polyorb-representations-cdr-giop_1_0.ads0000644000175000017500000001010011750740340025662 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- POLYORB.REPRESENTATIONS.CDR.GIOP_1_0 -- -- -- -- S p e c -- -- -- -- Copyright (C) 2004-2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- Support package for CDR representation of char and strings for GIOP 1.0 package PolyORB.Representations.CDR.GIOP_1_0 is pragma Elaborate_Body; type GIOP_1_0_CDR_Representation is new CDR_Representation with null record; type GIOP_1_0_CDR_Representation_Access is access all GIOP_1_0_CDR_Representation; -- XXX Encapsulation is also GIOP version dependent. -- 'char' type procedure Marshall (R : GIOP_1_0_CDR_Representation; Buffer : access Buffers.Buffer_Type; Data : PolyORB.Types.Char; Error : in out Errors.Error_Container); procedure Unmarshall (R : GIOP_1_0_CDR_Representation; Buffer : access Buffers.Buffer_Type; Data : out PolyORB.Types.Char; Error : in out Errors.Error_Container); -- 'wchar' type procedure Marshall (R : GIOP_1_0_CDR_Representation; Buffer : access Buffers.Buffer_Type; Data : PolyORB.Types.Wchar; Error : in out Errors.Error_Container); procedure Unmarshall (R : GIOP_1_0_CDR_Representation; Buffer : access Buffers.Buffer_Type; Data : out PolyORB.Types.Wchar; Error : in out Errors.Error_Container); -- 'string' type procedure Marshall (R : GIOP_1_0_CDR_Representation; Buffer : access Buffers.Buffer_Type; Data : PolyORB.Types.String; Error : in out Errors.Error_Container); procedure Unmarshall (R : GIOP_1_0_CDR_Representation; Buffer : access Buffers.Buffer_Type; Data : out PolyORB.Types.String; Error : in out Errors.Error_Container); -- 'wstring' type procedure Marshall (R : GIOP_1_0_CDR_Representation; Buffer : access Buffers.Buffer_Type; Data : PolyORB.Types.Wide_String; Error : in out Errors.Error_Container); procedure Unmarshall (R : GIOP_1_0_CDR_Representation; Buffer : access Buffers.Buffer_Type; Data : out PolyORB.Types.Wide_String; Error : in out Errors.Error_Container); end PolyORB.Representations.CDR.GIOP_1_0; ././@LongLink0000000000000000000000000000014700000000000011567 Lustar rootrootpolyorb-2.8~20110207.orig/src/giop/polyorb-giop_p-tagged_components-policies-priority_model_policy.adbpolyorb-2.8~20110207.orig/src/giop/polyorb-giop_p-tagged_components-policies-priority_model_policy.a0000644000175000017500000001177111750740340033162 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- POLYORB.GIOP_P.TAGGED_COMPONENTS.POLICIES.PRIORITY_MODEL_POLICY -- -- -- -- B o d y -- -- -- -- Copyright (C) 2004-2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with PolyORB.Initialization; with PolyORB.Utils.Strings; with PolyORB.Errors; with PolyORB.ORB; with PolyORB.Setup; with PolyORB.RT_POA; with PolyORB.RT_POA_Policies.Priority_Model_Policy; with PolyORB.Tasking.Priorities; package body PolyORB.GIOP_P.Tagged_Components.Policies.Priority_Model_Policy is Priority_Model_Policy_Type : constant := 40; -- Defined in RT-CORA specifications --------------------- -- Fetch_Component -- --------------------- function Fetch_Component (Oid : access PolyORB.Objects.Object_Id) return Policy_Value; function Fetch_Component (Oid : access PolyORB.Objects.Object_Id) return Policy_Value is use PolyORB.Errors; use PolyORB.ORB; use PolyORB.RT_POA; use PolyORB.RT_POA_Policies.Priority_Model_Policy; use PolyORB.Tasking.Priorities; use Policy_Value_Seq; use PolyORB.Representations.CDR.Common; use type PolyORB.Types.Unsigned_Long; Result : Policy_Value; Buffer : Buffer_Access; Model : Priority_Model; Server_ORB_Priority : ORB_Priority; Server_External_Priority : External_Priority; Error : PolyORB.Errors.Error_Container; begin if Object_Adapter (PolyORB.Setup.The_ORB).all not in PolyORB.RT_POA.RT_Obj_Adapter'Class then return Policy_Value'(P_Type => Invalid_Policy_Type, P_Value => null); end if; Buffer := new Buffer_Type; Get_Scheduling_Parameters (RT_Obj_Adapter_Access (Object_Adapter (PolyORB.Setup.The_ORB)), PolyORB.Objects.Object_Id_Access (Oid), Model, Server_ORB_Priority, Server_External_Priority, Error); if Found (Error) then Catch (Error); return Policy_Value'(P_Type => Invalid_Policy_Type, P_Value => null); end if; Start_Encapsulation (Buffer); Marshall (Buffer, PolyORB.Types.Unsigned_Long (Priority_Model'Pos (Model))); Marshall (Buffer, PolyORB.Types.Short (Server_External_Priority)); Result := Policy_Value'(P_Type => Priority_Model_Policy_Type, P_Value => new Encapsulation'(Encapsulate (Buffer))); Release (Buffer); return Result; end Fetch_Component; ---------------- -- Initialize -- ---------------- procedure Initialize; procedure Initialize is begin Register (Fetch_Component'Access); end Initialize; use PolyORB.Initialization; use PolyORB.Utils.Strings; begin Register_Module (Module_Info' (Name => +"tagged_components.policies.priority_model_policy", Conflicts => PolyORB.Initialization.String_Lists.Empty, Depends => PolyORB.Initialization.String_Lists.Empty, Provides => PolyORB.Initialization.String_Lists.Empty, Implicit => False, Init => Initialize'Access, Shutdown => null)); end PolyORB.GIOP_P.Tagged_Components.Policies.Priority_Model_Policy; polyorb-2.8~20110207.orig/src/giop/polyorb-giop_p-service_contexts.ads0000644000175000017500000000506111750740340025150 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . G I O P _ P . S E R V I C E _ C O N T E X T S -- -- -- -- S p e c -- -- -- -- Copyright (C) 2004-2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- Support package for GIOP Service Contexts with PolyORB.Buffers; with PolyORB.QoS.Service_Contexts; package PolyORB.GIOP_P.Service_Contexts is package PRSC renames PolyORB.QoS.Service_Contexts; procedure Marshall_Service_Context_List (Buffer : access Buffers.Buffer_Type; SCP : PRSC.QoS_GIOP_Service_Contexts_Parameter_Access); procedure Unmarshall_Service_Context_List (Buffer : access Buffers.Buffer_Type; SCP : out PRSC.QoS_GIOP_Service_Contexts_Parameter_Access); end PolyORB.GIOP_P.Service_Contexts; polyorb-2.8~20110207.orig/src/giop/polyorb-protocols-giop-common.ads0000644000175000017500000001533111750740340024555 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . P R O T O C O L S . G I O P . C O M M O N -- -- -- -- S p e c -- -- -- -- Copyright (C) 2002-2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with PolyORB.Buffers; with PolyORB.References; with PolyORB.QoS.Service_Contexts; with PolyORB.Types; package PolyORB.Protocols.GIOP.Common is package PRQSC renames PolyORB.QoS.Service_Contexts; ----------------------- -- Generic Marshsall -- ----------------------- generic type Table_Type is (<>); type Target_Type is mod <>; with procedure Marshall (Buffer : access PolyORB.Buffers.Buffer_Type; Index : Target_Type); procedure Generic_Marshall (Buffer : access PolyORB.Buffers.Buffer_Type; Val : Table_Type); ------------------------ -- Generic Unmarshall -- ------------------------ generic type Table_Type is (<>); type Target_Type is mod <>; with function Unmarshall (Buffer : access PolyORB.Buffers.Buffer_Type) return Target_Type; function Generic_Unmarshall (Buffer : access PolyORB.Buffers.Buffer_Type) return Table_Type; procedure Marshall (Buffer : access PolyORB.Buffers.Buffer_Type; Val : Reply_Status_Type); function Unmarshall (Buffer : access PolyORB.Buffers.Buffer_Type) return Reply_Status_Type; procedure Common_Send_Reply (Sess : access GIOP_Session; Request : Requests.Request_Access; MCtx : access GIOP_Message_Context'Class; Error : in out Errors.Error_Container; Recovery : Boolean := False); -- Part of processing for sending a result or exception reply that is -- shared across all GIOP versions. -- For each completed request, this is initially called with Recovery set -- False. If an error occurs, a second call is made with Recovery set True. -- In the first case, the request is expected to be marked pending on the -- Session (if not, it means we have received a cancel request, and we -- do not attempt to send a reply). In that case, the request is removed -- from the pending list. In the second case, the check is not made, and -- a reply is always sent (on the basis that an error occurred during the -- first attempt, which means that at that time the request was indeed -- pending, otherwise Common_Send_Reply would have returned immediately -- with no error). type Locate_Reply_Type is (Unknown_Object, Object_Here, Object_Forward, Object_Forward_Perm, Loc_System_Exception, -- not implemented, GIOP 1.2 only Loc_Need_Addressing_Mode); -- not implemented, GIOP 1.2 only procedure Marshall (Buffer : access PolyORB.Buffers.Buffer_Type; Val : Locate_Reply_Type); function Unmarshall (Buffer : access PolyORB.Buffers.Buffer_Type) return Locate_Reply_Type; procedure Common_Locate_Reply (Sess : access GIOP_Session; MCtx : access GIOP_Message_Context'Class; Loc_Type : Locate_Reply_Type; Forward_Ref : References.Ref; Error : in out Errors.Error_Container); procedure Common_Process_Locate_Reply (Sess : access GIOP_Session; Locate_Request_Id : Types.Unsigned_Long; Loc_Type : Locate_Reply_Type); procedure Common_Send_Cancel_Request (Sess : access GIOP_Session; R : Request_Access; MCtx : access GIOP_Message_Context'Class; Error : in out Errors.Error_Container); procedure Common_Process_Cancel_Request (Sess : access GIOP_Session; Request_Id : Types.Unsigned_Long); procedure Common_Reply_Received (Sess : access GIOP_Session; Request_Id : Types.Unsigned_Long; Reply_Status : Reply_Status_Type; Service_Contexts : PRQSC.QoS_GIOP_Service_Contexts_Parameter_Access); -- Helper routines to replace Error Kind procedure Replace_Marshal_5_To_Bad_Param_23 (Error : in out Errors.Error_Container; Status : PolyORB.Errors.Completion_Status); -- If Error is Marshhall_E with minor code 5, replace it with Bad_Param_E, -- with minor code 23 and set its status to Status, else do nothing. procedure Replace_Marshal_5_To_Inv_Objref_2 (Error : in out Errors.Error_Container; Status : PolyORB.Errors.Completion_Status); -- If Error is Marshhall_E with minor code 5, replace it with Inv_Objref_E, -- with minor code 2, and set its status to Status, else do nothing. ------------------------ -- Overkill functions -- ------------------------ -- Need to be replaced! procedure Copy (Buf_In : PolyORB.Buffers.Buffer_Access; Buf_Out : PolyORB.Buffers.Buffer_Access; Count : Types.Unsigned_Long); -- Copy Count bytes from a buffer to another one end PolyORB.Protocols.GIOP.Common; polyorb-2.8~20110207.orig/src/giop/polyorb-representations-cdr-giop_1_2.ads0000644000175000017500000000553711750740340025706 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- POLYORB.REPRESENTATIONS.CDR.GIOP_1_2 -- -- -- -- S p e c -- -- -- -- Copyright (C) 2004-2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- Support package for CDR representation of char and strings for GIOP 1.2 with PolyORB.GIOP_P.Code_Sets.Converters; with PolyORB.Representations.CDR.GIOP_1_1; package PolyORB.Representations.CDR.GIOP_1_2 is pragma Elaborate_Body; type GIOP_1_2_CDR_Representation is new GIOP_1_1.GIOP_1_1_CDR_Representation with private; type GIOP_1_2_CDR_Representation_Access is access all GIOP_1_2_CDR_Representation; -- XXX Encapsulation is also GIOP version dependent. procedure Set_Converters (R : in out GIOP_1_2_CDR_Representation; C : PolyORB.GIOP_P.Code_Sets.Converters.Converter_Access; W : PolyORB.GIOP_P.Code_Sets.Converters.Wide_Converter_Access); private type GIOP_1_2_CDR_Representation is new GIOP_1_1.GIOP_1_1_CDR_Representation with null record; end PolyORB.Representations.CDR.GIOP_1_2; polyorb-2.8~20110207.orig/src/giop/polyorb-protocols-giop.adb0000644000175000017500000010352211750740340023246 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . P R O T O C O L S . G I O P -- -- -- -- B o d y -- -- -- -- Copyright (C) 2002-2011, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with PolyORB.Annotations; with PolyORB.Binding_Data.GIOP; with PolyORB.Components; with PolyORB.Errors.Helper; with PolyORB.Protocols.GIOP.Common; with PolyORB.GIOP_P.Exceptions; with PolyORB.Log; with PolyORB.ORB.Iface; with PolyORB.Parameters; with PolyORB.References.Binding; with PolyORB.Representations.CDR.Common; with PolyORB.Representations.CDR.GIOP_Utils; with PolyORB.Servants.Iface; package body PolyORB.Protocols.GIOP is use PolyORB.Annotations; use PolyORB.Buffers; use PolyORB.Components; use PolyORB.Protocols.GIOP.Common; use PolyORB.Log; use PolyORB.ORB; use PolyORB.Representations.CDR; use PolyORB.Representations.CDR.Common; use PolyORB.Representations.CDR.GIOP_Utils; use PolyORB.Tasking.Mutexes; package L is new PolyORB.Log.Facility_Log ("polyorb.protocols.giop"); procedure O (Message : String; Level : Log_Level := Debug) renames L.Output; function C (Level : Log_Level := Debug) return Boolean renames L.Enabled; GIOP_Factories : array (GIOP_Version) of GIOP_Factory; -- It is assumed this array is written once at initialization -- time, read many during partition lifetime, no mutex is required. ------------ -- Create -- ------------ procedure Create (Proto : access GIOP_Protocol; Session : out Filter_Access) is pragma Warnings (Off); pragma Unreferenced (Proto); pragma Warnings (On); begin Session := new GIOP_Session; pragma Debug (C, O ("Create GIOP Session")); Initialize (GIOP_Session (Session.all)); end Create; ---------------- -- Initialize -- ---------------- procedure Initialize (Conf : access GIOP_Conf; Version : GIOP_Version; Permitted_Sync_Scopes : PolyORB.Requests.Flags; Locate_Then_Request : Boolean; Section : String; Prefix : String) is use PolyORB.Parameters; use PolyORB.Utils; begin pragma Debug (C, O ("Initialize parameters for GIOP Protocol")); pragma Debug (C, O ("Conf Section : " & Section)); pragma Debug (C, O ("Conf Prefix : " & Prefix)); pragma Debug (C, O ("Permitted sync scope" & Permitted_Sync_Scopes'Img)); Conf.Permitted_Sync_Scopes := Permitted_Sync_Scopes; -- ??? The following assumes that the GIOP major version is always 1 Conf.GIOP_Default_Version := To_GIOP_Version (Get_Conf (Section, Prefix & ".default_version.minor", Integer (To_Minor_GIOP (Version)))); for J in GIOP_Version'Range loop if Get_Conf (Section, Prefix & ".1." & Trimmed_Image (Unsigned_Long_Long (To_Minor_GIOP (J))) & ".enable", True) and then GIOP_Factories (J) /= null then pragma Debug (C, O ("Enable GIOP Version : 1." & Trimmed_Image (Unsigned_Long_Long (To_Minor_GIOP (J))))); Conf.GIOP_Implems (J) := GIOP_Factories (J).all; Conf.GIOP_Implems (J).Version := J; Conf.GIOP_Implems (J).Section := To_PolyORB_String (Section); Conf.GIOP_Implems (J).Prefix := To_PolyORB_String (Prefix); Initialize_Implem (Conf.GIOP_Implems (J)); Conf.GIOP_Implems (J).Locate_Then_Request := Get_Conf (Section, Get_Conf_Chain (Conf.GIOP_Implems (J)) & ".locate_then_request", Locate_Then_Request); end if; end loop; end Initialize; ---------------- -- Initialize -- ---------------- procedure Initialize (S : in out GIOP_Session) is begin pragma Debug (C, O ("Initializing GIOP session")); Tasking.Mutexes.Create (S.Mutex); S.Buffer_In := new Buffer_Type; end Initialize; ------------- -- Destroy -- ------------- procedure Destroy (S : in out GIOP_Session) is begin pragma Debug (C, O ("Destroying GIOP session")); pragma Assert (S.State = Not_Initialized); -- We assume that this session has already been disconnected. -- All pending requests have been flushed, and its state has been -- reset to Not_Initialized. Pend_Req_Tables.Deallocate (S.Pending_Reqs); Destroy (S.Mutex); if S.Buffer_In /= null then Release (S.Buffer_In); end if; if S.Implem /= null then Finalize_Session (S.Implem, S'Access); end if; Protocols.Destroy (Protocols.Session (S)); end Destroy; ---------------------------- -- Handle_Data_Indication -- ---------------------------- procedure Handle_Data_Indication (Sess : access GIOP_Session; Data_Amount : Stream_Element_Count; Error : in out Errors.Error_Container) is pragma Warnings (Off); pragma Unreferenced (Data_Amount); pragma Warnings (On); use Errors; Version : GIOP_Version; begin pragma Debug (C, O ("Received data in state " & Sess.State'Img)); pragma Assert (Sess.State /= Not_Initialized); case Sess.State is when Expect_Header => Unmarshall_Global_GIOP_Header (Sess, Sess.Buffer_In, Version); Unmarshall_GIOP_Header (Sess.Implem, Sess.MCtx, Sess.Buffer_In); Sess.State := Expect_Body; pragma Debug (C, O ("GIOP Header OK, ask for body, size :" & Sess.MCtx.Message_Size'Img)); if Sess.MCtx.Message_Size = 0 then Process_Message (Sess.Implem, Sess); else Emit_No_Reply (Port => Lower (Sess), Msg => GIOP_Data_Expected' (In_Buf => Sess.Buffer_In, Max => Stream_Element_Count (Sess.MCtx.Message_Size), State => Sess.State)); end if; when Expect_Body => pragma Debug (C, O ("Received GIOP message body")); pragma Debug (C, Show (Sess.Buffer_In)); Process_Message (Sess.Implem, Sess); when others => Throw (Error, Comm_Failure_E, System_Exception_Members'(0, Completed_Maybe)); end case; exception when others => Throw (Error, Comm_Failure_E, System_Exception_Members'(0, Completed_Maybe)); end Handle_Data_Indication; --------------------------------- -- Handle_Unmarshall_Arguments -- --------------------------------- procedure Handle_Unmarshall_Arguments (Sess : access GIOP_Session; Args : in out Any.NVList.Ref; Error : in out Errors.Error_Container) is use PolyORB.Errors; begin pragma Debug (C, O ("Unmarshalling_Request_Arguments")); pragma Assert (Sess.State = Waiting_Unmarshalling); Unmarshall_Argument_List (Sess.Implem, Sess.Buffer_In, Sess.Repr, Args, PolyORB.Any.ARG_IN, Sess.Implem.Data_Alignment, Error); if Found (Error) then Replace_Marshal_5_To_Bad_Param_23 (Error, Completed_No); -- An error in the marshalling of wchar data implies the -- server did not provide a valid codeset service -- context. We convert this exception to Bad_Param 23. end if; Expect_GIOP_Header (Sess); end Handle_Unmarshall_Arguments; ------------------ -- Handle_Flush -- ------------------ procedure Handle_Flush (Sess : access GIOP_Session) renames Expect_GIOP_Header; ------------------------------- -- Handle_Connect_Indication -- ------------------------------- procedure Handle_Connect_Indication (Sess : access GIOP_Session) is begin pragma Debug (C, O ("Handle_Connect_Indication")); pragma Assert (Sess.State = Not_Initialized); Sess.Role := Server; Expect_GIOP_Header (Sess); end Handle_Connect_Indication; --------------------------------- -- Handle_Connect_Confirmation -- --------------------------------- procedure Handle_Connect_Confirmation (Sess : access GIOP_Session) is use PolyORB.Binding_Data.GIOP; use PolyORB.Binding_Objects; begin pragma Debug (C, O ("Handle_Connect_Confirmation")); pragma Assert (Sess.State = Not_Initialized); Sess.Role := Client; if Sess.Implem = null then -- Initialize session with GIOP version specified by the profile -- used to create the session. As a client, we are allowed to use -- a lower protocol version than the one advertised by the server. Get_GIOP_Implem (Sess, Get_GIOP_Version (GIOP_Profile_Type'Class (Get_Profile (Sess.Dependent_Binding_Object).all)), Allow_Downgrade => True); end if; Expect_GIOP_Header (Sess); end Handle_Connect_Confirmation; ----------------------- -- Handle_Disconnect -- ----------------------- procedure Handle_Disconnect (Sess : access GIOP_Session; Error : Errors.Error_Container) is use Pend_Req_Tables; P : Pending_Request_Access; ORB : constant ORB_Access := ORB_Access (Sess.Server); begin pragma Debug (C, O ("Handle_Disconnect: enter")); Enter (Sess.Mutex); Sess.State := Not_Initialized; if Sess.Buffer_In /= null then Release (Sess.Buffer_In); end if; for J in First (Sess.Pending_Reqs) .. Last (Sess.Pending_Reqs) loop if Sess.Pending_Reqs.Table /= null and then Sess.Pending_Reqs.Table (J) /= null then P := Sess.Pending_Reqs.Table (J); Sess.Pending_Reqs.Table (J) := null; if Sess.Role = Client then -- Client case: return with exception Set_Exception (P.Req.all, Error); References.Binding.Unbind (P.Req.Target); -- After the following call, P.Req is destroyed Emit_No_Reply (Component_Access (ORB), Servants.Iface.Executed_Request'(Req => P.Req)); else if P.Req.Surrogate /= null then -- Note: Req can't disappear from under our feet, because -- its destruction is preceded by a call to Send_Reply, -- which takes Sess.Mutex. -- Server case: abort upcall, ORB will clean up the request Emit_No_Reply (P.Req.Surrogate, Servants.Iface.Abort_Request'(Req => P.Req)); end if; end if; Free (P); end if; end loop; -- All pending request entries have been cleared: reset table Set_Last (Sess.Pending_Reqs, First (Sess.Pending_Reqs) - 1); Leave (Sess.Mutex); pragma Debug (C, O ("Handle_Disconnect: leave")); end Handle_Disconnect; -------------------- -- Invoke_Request -- -------------------- procedure Invoke_Request (Sess : access GIOP_Session; R : Request_Access; Pro : access Binding_Data.Profile_Type'Class) is use PolyORB.Binding_Data; use PolyORB.Errors; use Unsigned_Long_Flags; New_Pending_Req : Pending_Request_Access; Error : Errors.Error_Container; Success : Boolean; begin if (Sess.Conf.Permitted_Sync_Scopes and R.Req_Flags) = 0 or else (Sess.Implem.Permitted_Sync_Scopes and R.Req_Flags) = 0 then pragma Debug (C, O ("Requested sync scope not supported")); raise GIOP_Error; end if; New_Pending_Req := new Pending_Request; New_Pending_Req.Req := R; New_Pending_Req.Target_Profile := Profile_Access (Pro); Enter (Sess.Mutex); if Is_Set (Sync_None, R.Req_Flags) or else Is_Set (Sync_With_Transport, R.Req_Flags) then -- Oneway call: we won't see any reply for this request, so we need -- to destroy the pending request information now. New_Pending_Req.Request_Id := Get_Request_Id (Sess); Leave (Sess.Mutex); Send_Request (Sess.Implem, Sess, New_Pending_Req, Error); Free (New_Pending_Req); if Found (Error) then Set_Exception (R.all, Error); Catch (Error); -- Since this is a oneway called, this request will return to the -- caller immediately; no need to generate an Executed_Request -- message at this point (see PolyORB.Protocols.Invoke_Request). end if; return; end if; -- Two-way call: a reply is expected, we store the pending request New_Pending_Req.Request_Id := Get_Request_Id (Sess); if Sess.Implem.Locate_Then_Request then New_Pending_Req.Locate_Req_Id := Get_Request_Id (Sess); Add_Pending_Request (Sess, New_Pending_Req); Leave (Sess.Mutex); Locate_Object (Sess.Implem, Sess, New_Pending_Req, Error); else Add_Pending_Request (Sess, New_Pending_Req); Leave (Sess.Mutex); Send_Request (Sess.Implem, Sess, New_Pending_Req, Error); end if; if Found (Error) then Remove_Pending_Request (Sess, New_Pending_Req.Request_Id, Success); if Success then Set_Exception (R.all, Error); else -- If the session has been disconnected, all pending requests -- have been flushed already: their exit status has been set, -- and New_Pending_Req has already been deallocated. Nothing -- left to do here. pragma Assert (Sess.State = Not_Initialized); null; end if; Catch (Error); declare ORB : constant ORB_Access := ORB_Access (Sess.Server); begin Emit_No_Reply (Component_Access (ORB), Servants.Iface.Executed_Request'(Req => R)); end; end if; end Invoke_Request; ------------------- -- Abort_Request -- ------------------- procedure Abort_Request (Sess : access GIOP_Session; R : Requests.Request_Access) is begin Send_Cancel_Request (Sess.Implem, Sess, R); end Abort_Request; ---------------- -- Send_Reply -- ---------------- procedure Send_Reply (Sess : access GIOP_Session; R : Requests.Request_Access) is begin Send_Reply (Sess.Implem, Sess, R); end Send_Reply; ------------------- -- Locate_Object -- ------------------- procedure Locate_Object (Sess : access GIOP_Session; Profile : Binding_Data.Profile_Access; Error : in out Errors.Error_Container) is use PolyORB.Errors; use Unsigned_Long_Flags; New_Pending_Req : Pending_Request_Access; begin if not Sess.Implem.Locate_Then_Request then return; end if; New_Pending_Req := new Pending_Request; New_Pending_Req.Req := new PolyORB.Requests.Request; -- We build an empty Request to store any exception sent back by the -- remote node. New_Pending_Req.Target_Profile := Profile; Enter (Sess.Mutex); New_Pending_Req.Request_Id := Get_Request_Id (Sess); New_Pending_Req.Locate_Req_Id := Get_Request_Id (Sess); Add_Pending_Request (Sess, New_Pending_Req); Leave (Sess.Mutex); Locate_Object (Sess.Implem, Sess, New_Pending_Req, Error); end Locate_Object; ------------------ -- Emit Message -- ------------------ procedure Emit_Message (Implem : access GIOP_Implem; S : access Session'Class; MCtx : access GIOP_Message_Context'Class; Buffer : Buffer_Access; Error : in out Errors.Error_Container) is pragma Warnings (Off); pragma Unreferenced (Implem, MCtx); pragma Warnings (On); use PolyORB.Filters.Iface; M : constant Message'Class := Emit (Lower (S), Data_Out'(Out_Buf => Buffer)); begin if M in Filter_Error'Class then Error := Filter_Error (M).Error; else pragma Assert (M in Null_Message'Class); null; end if; end Emit_Message; -- Local functions ------------------------ -- Expect_GIOP_Header -- ------------------------ -- called to wait another GIOP message procedure Expect_GIOP_Header (Sess : access GIOP_Session) is begin -- Check if buffer has been totally read if Remaining (Sess.Buffer_In) /= 0 then pragma Debug (C, O ("Remaining data in buffer :" & Remaining (Sess.Buffer_In)'Img & " bytes")); null; -- It is not an error to leave data remaining in Buffer, -- e.g. in the case of an (unexpected) unknown user exception. end if; pragma Debug (C, O ("Waiting for next message")); Buffers.Release_Contents (Sess.Buffer_In.all); Sess.State := Expect_Header; Emit_No_Reply (Port => Lower (Sess), Msg => GIOP_Data_Expected' (In_Buf => Sess.Buffer_In, Max => GIOP_Header_Size, State => Sess.State)); end Expect_GIOP_Header; ----------------------------------- -- Unmarshall_Global_GIOP_Header -- ----------------------------------- procedure Unmarshall_Global_GIOP_Header (Sess : access GIOP_Session; Buffer : access Buffer_Type; Version : out GIOP_Version) is use Octet_Flags; Message_Magic : Stream_Element_Array (Magic'Range); Flags : Types.Octet; Version_Data : Types.Octet; begin -- Get Endianness -- This code works only if the endianness bit dont move -- in different giop version Flags := Types.Octet (Peek (Buffer, Flags_Index - 1)); pragma Debug (C, O ("Flags : " & Flags'Img)); if Is_Set (Bit_Little_Endian, Flags) then Set_Endianness (Buffer, Little_Endian); else Set_Endianness (Buffer, Big_Endian); end if; -- Beginning of GIOP message is byte-ordering independent -- Magic for J in Message_Magic'Range loop Message_Magic (J) := Stream_Element (Types.Octet'(Unmarshall (Buffer))); end loop; if Message_Magic /= Magic then raise GIOP_Error; end if; -- Get GIOP Message version Version_Data := Unmarshall (Buffer); pragma Assert (Version_Data = 1); -- Major Version_Data := Unmarshall (Buffer); -- Minor Version := To_GIOP_Version (Integer (Version_Data)); pragma Debug (C, O ("Received GIOP message, version: " & GIOP_Version'Image (Version))); if Sess.Implem = null then Get_GIOP_Implem (Sess, Version); elsif Version /= Sess.Implem.Version then raise GIOP_Error; end if; end Unmarshall_Global_GIOP_Header; --------------------------------- -- Marshall_Global_GIOP_Header -- --------------------------------- procedure Marshall_Global_GIOP_Header (Sess : access GIOP_Session; MCtx : access GIOP_Message_Context'Class; Buffer : access PolyORB.Buffers.Buffer_Type) is begin -- Magic for J in Magic'Range loop Marshall (Buffer, Types.Octet (Magic (J))); end loop; -- Version Marshall (Buffer, Types.Octet (1)); Marshall (Buffer, To_Minor_GIOP (Sess.Implem.Version)); -- Implem-specific data Marshall_GIOP_Header (Sess.Implem, Sess, MCtx, Buffer); end Marshall_Global_GIOP_Header; ------------------------------ -- Unmarshall_Argument_List -- ------------------------------ procedure Unmarshall_Argument_List (Implem : access GIOP_Implem; Buffer : Buffer_Access; Representation : access CDR_Representation'Class; Args : in out Any.NVList.Ref; Direction : Any.Flags; First_Arg_Alignment : Buffers.Alignment_Type; Error : in out Errors.Error_Container) is pragma Warnings (Off); pragma Unreferenced (Implem); pragma Warnings (On); use PolyORB.Any; use PolyORB.Any.NVList.Internals; use PolyORB.Any.NVList.Internals.NV_Lists; use PolyORB.Errors; It : Iterator := First (List_Of (Args).all); Arg : Element_Access; begin pragma Assert (Direction = ARG_IN or else Direction = ARG_OUT); if not Last (It) then Align_Position (Buffer, First_Arg_Alignment); end if; while not Last (It) loop Arg := Value (It); if False or else Arg.Arg_Modes = Direction or else Arg.Arg_Modes = ARG_INOUT then Unmarshall_To_Any (Representation, Buffer, Get_Container (Arg.Argument).all, Error); if Found (Error) then return; end if; end if; Next (It); end loop; end Unmarshall_Argument_List; ---------------------------- -- Marshall_Argument_List -- ---------------------------- procedure Marshall_Argument_List (Implem : access GIOP_Implem; Buffer : Buffer_Access; Representation : access CDR_Representation'Class; Args : in out Any.NVList.Ref; Direction : Any.Flags; First_Arg_Alignment : Buffers.Alignment_Type; Error : in out Errors.Error_Container) is pragma Warnings (Off); pragma Unreferenced (Implem); pragma Warnings (On); use PolyORB.Any; use PolyORB.Any.NVList.Internals; use PolyORB.Any.NVList.Internals.NV_Lists; use PolyORB.Errors; It : Iterator; Arg : Element_Access; begin if List_Of (Args) = null then -- Do not fail if there is no argument to marshall, for instance in -- the case of a simple acknowledgement (in Sync_With_Server mode) -- that is sent prior to reading arguments. return; end if; It := First (List_Of (Args).all); pragma Assert (Direction = ARG_IN or else Direction = ARG_OUT); if not Last (It) then Pad_Align (Buffer, First_Arg_Alignment); end if; while not Last (It) loop Arg := Value (It); if False or else Arg.Arg_Modes = Direction or else Arg.Arg_Modes = ARG_INOUT then pragma Debug (C, O ("Marshalling argument " & Types.To_Standard_String (Arg.Name) & " = " & Image (Arg.Argument))); Marshall (Buffer, Representation, Arg.all, Error); if Found (Error) then return; end if; end if; Next (It); end loop; end Marshall_Argument_List; ---------------------------------------- -- Unmarshall_System_Exception_To_Any -- ---------------------------------------- procedure Unmarshall_System_Exception_To_Any (Buffer : Buffer_Access; Repr : access Representations.CDR.CDR_Representation'Class; Info : out Any.Any) is use PolyORB.Any; use PolyORB.Errors; use PolyORB.GIOP_P.Exceptions; Exception_Name : constant String := Extract_System_Exception_Name (To_Standard_String (Types.RepositoryId'(Unmarshall (Buffer)))); Error : PolyORB.Errors.Error_Container; begin Info := Any.Get_Empty_Any (PolyORB.GIOP_P.Exceptions.System_Exception_TypeCode (Exception_Name)); Unmarshall_To_Any (Repr, Buffer, Get_Container (Info).all, Error); if Found (Error) then Info := Helper.Error_To_Any (Error); Catch (Error); end if; end Unmarshall_System_Exception_To_Any; -- Version management ---------------------------------- -- Global_Register_GIOP_Version -- ---------------------------------- procedure Global_Register_GIOP_Version (Version : GIOP_Version; Implem : GIOP_Factory) is begin pragma Assert (Implem /= null); pragma Assert (GIOP_Factories (Version) = null); GIOP_Factories (Version) := Implem; end Global_Register_GIOP_Version; --------------------- -- Get_GIOP_Implem -- --------------------- procedure Get_GIOP_Implem (Sess : access GIOP_Session; Version : GIOP_Version; Allow_Downgrade : Boolean := False) is use PolyORB.Utils; Use_Version : GIOP_Version := Version; begin pragma Debug (C, O ("Looking up implementation for " & GIOP_Version'Image (Version))); loop Sess.Implem := Sess.Conf.GIOP_Implems (Use_Version); exit when Sess.Implem /= null or else not Allow_Downgrade or else Use_Version = Sess.Conf.GIOP_Implems'First; Use_Version := GIOP_Version'Pred (Use_Version); end loop; if Sess.Implem /= null then pragma Debug (C, O ("... using version " & Use_Version'Img)); Initialize_Session (Sess.Implem, Sess); else raise GIOP_Error with "could not find a suitable GIOP version"; end if; end Get_GIOP_Implem; ------------------------- -- Get_Pending_Request -- ------------------------- procedure Get_Pending_Request (Sess : access GIOP_Session; Id : Types.Unsigned_Long; Req : out Pending_Request; Success : out Boolean) is use Pend_Req_Tables; begin pragma Debug (C, O ("Retrieving pending request with id" & Types.Unsigned_Long'Image (Id))); Success := False; for J in First (Sess.Pending_Reqs) .. Last (Sess.Pending_Reqs) loop if Sess.Pending_Reqs.Table (J) /= null and then Sess.Pending_Reqs.Table (J).Request_Id = Id then Req := Sess.Pending_Reqs.Table (J).all; Free (Sess.Pending_Reqs.Table (J)); Success := True; exit; end if; end loop; end Get_Pending_Request; ----------------------------------- -- Get_Pending_Request_By_Locate -- ----------------------------------- procedure Get_Pending_Request_By_Locate (Sess : access GIOP_Session; L_Id : Types.Unsigned_Long; Req : out Pending_Request_Access; Success : out Boolean; Remove : Boolean) is use Pend_Req_Tables; begin pragma Debug (C, O ("Retrieving pending request with locate id" & Types.Unsigned_Long'Image (L_Id))); Success := False; Enter (Sess.Mutex); for J in First (Sess.Pending_Reqs) .. Last (Sess.Pending_Reqs) loop if Sess.Pending_Reqs.Table (J) /= null and then Sess.Pending_Reqs.Table (J).Locate_Req_Id = L_Id then if Remove then Free (Sess.Pending_Reqs.Table (J)); end if; -- Req is returned as null if found and removed Req := Sess.Pending_Reqs.Table (J); Success := True; exit; end if; end loop; Leave (Sess.Mutex); end Get_Pending_Request_By_Locate; ---------------------------- -- Remove_Pending_Request -- ---------------------------- procedure Remove_Pending_Request (Sess : access GIOP_Session; Id : Types.Unsigned_Long; Success : out Boolean) is use Pend_Req_Tables; Ignored_Req : Pending_Request; pragma Unreferenced (Ignored_Req); begin pragma Debug (C, O ("Retrieving pending request with id" & Types.Unsigned_Long'Image (Id))); -- Retrieve request with removal, and discard retrieved request (if any) Sess.Mutex.Enter; Sess.Get_Pending_Request (Id => Id, Req => Ignored_Req, Success => Success); Sess.Mutex.Leave; end Remove_Pending_Request; -------------------------------------- -- Remove_Pending_Request_By_Locate -- -------------------------------------- procedure Remove_Pending_Request_By_Locate (Sess : access GIOP_Session; Id : Types.Unsigned_Long; Success : out Boolean) is use Pend_Req_Tables; Ignored_Req : Pending_Request_Access; pragma Unreferenced (Ignored_Req); begin pragma Debug (C, O ("Removing pending request with locate id" & Types.Unsigned_Long'Image (Id))); Sess.Get_Pending_Request_By_Locate (L_Id => Id, Req => Ignored_Req, Success => Success, Remove => True); end Remove_Pending_Request_By_Locate; ------------------------- -- Add_Pending_Request -- ------------------------- procedure Add_Pending_Request (Sess : access GIOP_Session; Pend_Req : Pending_Request_Access) is use Pend_Req_Tables; begin pragma Debug (C, O ("Adding pending request with id" & Pend_Req.Request_Id'Img)); Set_Note (Pend_Req.Req.Notepad, Request_Note'(Annotations.Note with Id => Pend_Req.Request_Id)); for J in First (Sess.Pending_Reqs) .. Last (Sess.Pending_Reqs) loop if Sess.Pending_Reqs.Table (J) = null then Sess.Pending_Reqs.Table (J) := Pend_Req; return; end if; end loop; -- Here if there was no available slot in the pending requests table: -- allocate a new one. Increment_Last (Sess.Pending_Reqs); Sess.Pending_Reqs.Table (Last (Sess.Pending_Reqs)) := Pend_Req; end Add_Pending_Request; -------------------- -- Get_Request_Id -- -------------------- function Get_Request_Id (Sess : access GIOP_Session) return Types.Unsigned_Long is R : constant Types.Unsigned_Long := Sess.Req_Index; begin Sess.Req_Index := Sess.Req_Index + 1; return R; end Get_Request_Id; -------------------- -- Get_Conf_Chain -- -------------------- function Get_Conf_Chain (Implem : access GIOP_Implem'Class) return String is use PolyORB.Utils; begin return To_Standard_String (Implem.Prefix) & ".1." & Trimmed_Image (Unsigned_Long_Long (To_Minor_GIOP (Implem.Version))); end Get_Conf_Chain; ------------------------ -- Get_Representation -- ------------------------ function Get_Representation (Sess : access GIOP_Session) return PolyORB.Representations.CDR.CDR_Representation_Access is begin return Sess.Repr; end Get_Representation; ---------------- -- Get_Buffer -- ---------------- function Get_Buffer (Sess : access GIOP_Session) return Buffer_Access is Buffer : constant Buffer_Access := Sess.Buffer_In; begin return Buffer; end Get_Buffer; ------------------- -- Queue_Request -- ------------------- procedure Queue_Request (Sess : access GIOP_Session; Req : Request_Access; Req_Id : Types.Unsigned_Long) is use Unsigned_Long_Flags; begin Set_Note (Req.Notepad, Request_Note'(Annotations.Note with Id => Req_Id)); -- Mark request as server-side pending, unless it is a oneway call (in -- which case we never get signalled when it completes, so we'd be -- unable to clean up). if not (Is_Set (Sync_None, Req.Req_Flags) or else Is_Set (Sync_With_Transport, Req.Req_Flags)) then Sess.Mutex.Enter; Add_Pending_Request (Sess, new Pending_Request'(Req => Req, Locate_Req_Id => 0, Request_Id => Req_Id, Target_Profile => null)); Sess.Mutex.Leave; end if; Queue_Request_To_Handler (ORB_Access (Sess.Server), ORB.Iface.Queue_Request' (Request => Req, Requestor => Component_Access (Sess))); end Queue_Request; end PolyORB.Protocols.GIOP; polyorb-2.8~20110207.orig/src/giop/polyorb-giop_p-transport_mechanisms.adb0000644000175000017500000001263011750740340026003 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . G I O P _ P . T R A N S P O R T _ M E C H A N I S M S -- -- -- -- B o d y -- -- -- -- Copyright (C) 2005-2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with Ada.Unchecked_Deallocation; package body PolyORB.GIOP_P.Transport_Mechanisms is use PolyORB.GIOP_P.Tagged_Components; type Registry_Item is record Tag : Tagged_Components.Tag_Value; Constructor : Transport_Mechanism_Constructor; end record; package Registry_Item_Lists is new PolyORB.Utils.Chained_Lists (Registry_Item); Registry : Registry_Item_Lists.List; --------------------------------- -- Create_Transport_Mechanisms -- --------------------------------- procedure Create_Transport_Mechanisms (TC : Tagged_Components.Tagged_Component_List; Profile : Binding_Data.Profile_Access; Mechs : in out Transport_Mechanism_List) is use Registry_Item_Lists; Iter : Registry_Item_Lists.Iterator := First (Registry); begin while not Last (Iter) loop declare SC : constant Tagged_Component_Array := Get_Components (TC, Value (Iter).Tag); begin for J in SC'Range loop Value (Iter).Constructor (SC (J), Profile, Mechs); end loop; end; Next (Iter); end loop; end Create_Transport_Mechanisms; --------------- -- Deep_Copy -- --------------- function Deep_Copy (List : Transport_Mechanism_List) return Transport_Mechanism_List is use Transport_Mechanism_Lists; Result : Transport_Mechanism_List; Iter : Iterator := First (List); begin while not Last (Iter) loop declare C : constant Transport_Mechanism'Class := Duplicate (Value (Iter).all.all); CC : constant Transport_Mechanism_Access := new Transport_Mechanism'Class'(C); begin Append (Result, CC); end; Next (Iter); end loop; return Result; end Deep_Copy; ------------------ -- Is_Colocated -- ------------------ function Is_Colocated (Left, Right : Transport_Mechanism_List) return Boolean is use Transport_Mechanism_Lists; L_Iter : Iterator := First (Right); R_Iter : Iterator; begin Left_Iteration : while not Last (L_Iter) loop R_Iter := First (Left); Right_Iteration : while not Last (R_Iter) loop if Is_Colocated (Value (L_Iter).all.all, Value (R_Iter).all.all) then return True; end if; Next (R_Iter); end loop Right_Iteration; Next (L_Iter); end loop Left_Iteration; return False; end Is_Colocated; -------------- -- Register -- -------------- procedure Register (Tag : Tagged_Components.Tag_Value; Constructor : Transport_Mechanism_Constructor) is begin Registry_Item_Lists.Append (Registry, (Tag, Constructor)); end Register; ---------------------- -- Release_Contents -- ---------------------- procedure Release_Contents (List : in out Transport_Mechanism_List) is procedure Free is new Ada.Unchecked_Deallocation (Transport_Mechanism'Class, Transport_Mechanism_Access); Component : Transport_Mechanism_Access; begin while not Is_Empty (List) loop Extract_First (List, Component); Release_Contents (Component); Free (Component); end loop; end Release_Contents; end PolyORB.GIOP_P.Transport_Mechanisms; polyorb-2.8~20110207.orig/src/giop/polyorb-protocols-giop-giop_1_1.adb0000644000175000017500000006661211750740340024652 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . P R O T O C O L S . G I O P . G I O P _ 1 _ 1 -- -- -- -- B o d y -- -- -- -- Copyright (C) 2002-2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with Ada.Unchecked_Deallocation; with PolyORB.Any; with PolyORB.Binding_Data.Local; with PolyORB.Buffers; with PolyORB.GIOP_P.Service_Contexts; with PolyORB.Initialization; with PolyORB.Log; with PolyORB.Objects; with PolyORB.Obj_Adapters; with PolyORB.Protocols.GIOP.Common; pragma Elaborate_All (PolyORB.Protocols.GIOP.Common); with PolyORB.QoS.Service_Contexts; with PolyORB.References; with PolyORB.Representations.CDR.Common; with PolyORB.Representations.CDR.GIOP_1_1; with PolyORB.Representations.CDR.GIOP_Utils; with PolyORB.Request_QoS; with PolyORB.Smart_Pointers; with PolyORB.Utils.Strings; package body PolyORB.Protocols.GIOP.GIOP_1_1 is use PolyORB.Buffers; use PolyORB.GIOP_P.Service_Contexts; use PolyORB.Log; use PolyORB.Objects; use PolyORB.Protocols.GIOP.Common; use PolyORB.QoS; use PolyORB.QoS.Service_Contexts; use PolyORB.Representations.CDR; use PolyORB.Representations.CDR.Common; use PolyORB.Representations.CDR.GIOP_1_1; use PolyORB.Representations.CDR.GIOP_Utils; use PolyORB.Request_QoS; package L is new PolyORB.Log.Facility_Log ("polyorb.protocols.giop.giop_1_1"); procedure O (Message : String; Level : Log_Level := Debug) renames L.Output; function C (Level : Log_Level := Debug) return Boolean renames L.Enabled; procedure Free is new Ada.Unchecked_Deallocation (GIOP_1_1_CDR_Representation, GIOP_1_1_CDR_Representation_Access); Permitted_Sync_Scopes : constant PolyORB.Requests.Flags := Sync_None or Sync_With_Transport or Sync_With_Target; -- Msg_Type function Unmarshall is new Generic_Unmarshall (Msg_Type, Types.Octet, Unmarshall); procedure Marshall is new Generic_Marshall (Msg_Type, Types.Octet, Marshall); -- local helpers procedure Marshall_Locate_Request (Buffer : Buffer_Access; Request_Id : Types.Unsigned_Long; Object_Key : PolyORB.Objects.Object_Id_Access); procedure Unmarshall_Request_Message (Buffer : access Buffers.Buffer_Type; Request_Id : out Types.Unsigned_Long; Resp_Exp : out Boolean; Object_Key : out PolyORB.Objects.Object_Id_Access; Operation : out Types.String; Principal : out Types.String; Service_Contexts : out QoS_GIOP_Service_Contexts_Parameter_Access); ----------------------------------- -- Internal function declaration -- ----------------------------------- procedure Process_Request (S : access GIOP_Session); procedure Process_Locate_Request (S : in out Session'Class); ----------------------- -- Initialize_Implem -- ----------------------- procedure Initialize_Implem (Implem : access GIOP_Implem_1_1) is begin Implem.Data_Alignment := Data_Alignment_1_1; Implem.Permitted_Sync_Scopes := Permitted_Sync_Scopes; end Initialize_Implem; ------------------------ -- Initialize_Session -- ------------------------ procedure Initialize_Session (Implem : access GIOP_Implem_1_1; S : access Session'Class) is pragma Warnings (Off); pragma Unreferenced (Implem); pragma Warnings (On); Sess : GIOP_Session renames GIOP_Session (S.all); begin Sess.MCtx := new GIOP_Message_Context_1_1; -- Sess.SCtx := new GIOP_Session_Context_1_1; -- There is no SCtx for GIOP 1.1 Sess.Repr := new GIOP_1_1_CDR_Representation; pragma Debug (C, O ("Initialize context for GIOP session 1.1")); end Initialize_Session; ---------------------- -- Finalize_Session -- ---------------------- procedure Finalize_Session (Implem : access GIOP_Implem_1_1; S : access Session'Class) is pragma Warnings (Off); pragma Unreferenced (Implem); pragma Warnings (On); Sess : GIOP_Session renames GIOP_Session (S.all); begin Free (Sess.MCtx); -- Free (Sess.SCtx); -- There is no SCtx for GIOP 1.1 Release (GIOP_1_1_CDR_Representation (Sess.Repr.all)); Free (GIOP_1_1_CDR_Representation_Access (Sess.Repr)); pragma Debug (C, O ("Finalize context for GIOP session 1.1")); end Finalize_Session; --------------------- -- Process_Message -- --------------------- procedure Process_Message (Implem : access GIOP_Implem_1_1; S : access Session'Class) is pragma Unreferenced (Implem); use PolyORB.ORB; Sess : GIOP_Session renames GIOP_Session (S.all); MCtx : GIOP_Message_Context_1_1 renames GIOP_Message_Context_1_1 (Sess.MCtx.all); begin case MCtx.Message_Type is when Request => if Sess.Role /= Server then raise GIOP_Error; end if; Process_Request (Sess'Access); when Cancel_Request => if Sess.Role /= Server then raise GIOP_Error; end if; Common_Process_Cancel_Request (Sess'Access, Request_Id => Unmarshall (Sess.Buffer_In)); when Reply => if Sess.Role /= Client then raise GIOP_Error; end if; declare Request_Id : Types.Unsigned_Long; Reply_Status : Reply_Status_Type; Service_Contexts : QoS_GIOP_Service_Contexts_Parameter_Access; begin Unmarshall_Service_Context_List (Sess.Buffer_In, Service_Contexts); Request_Id := Unmarshall (Sess.Buffer_In); Reply_Status := Unmarshall (Sess.Buffer_In); Common_Reply_Received (Sess'Access, Request_Id, Reply_Status, Service_Contexts); end; when Close_Connection => if Sess.Role /= Server then raise GIOP_Error; end if; Expect_GIOP_Header (Sess'Access); when Fragment => O ("GIOP 1.1 fragment discarded.", Warning); when Locate_Reply => if Sess.Role /= Client then raise GIOP_Error; end if; declare Request_Id : constant Types.Unsigned_Long := Unmarshall (Sess.Buffer_In); Locate_Reply : constant Locate_Reply_Type := Unmarshall (Sess.Buffer_In); begin -- Exec request if request id is found in pending req list Common_Process_Locate_Reply (Sess'Access, Request_Id, Locate_Reply); end; when Locate_Request => if Sess.Role /= Server then raise GIOP_Error; end if; Process_Locate_Request (Sess); when Message_Error => raise GIOP_Error; end case; end Process_Message; --------------------- -- Process_Request -- --------------------- procedure Process_Request (S : access GIOP_Session) is use PolyORB.Annotations; use PolyORB.Any.NVList; use PolyORB.Binding_Data; use PolyORB.Binding_Data.Local; use PolyORB.Components; use PolyORB.Errors; use PolyORB.Obj_Adapters; use PolyORB.ORB; use PolyORB.References; Object_Key : Objects.Object_Id_Access; Request_Id : Unsigned_Long; Operation : Types.String; Principal : Types.String; Resp_Exp : Boolean; Req_Flags : Flags := 0; Args : Any.NVList.Ref; Def_Args : Component_Access; Target : References.Ref; Req : Request_Access; Error : Errors.Error_Container; Service_Contexts : QoS_GIOP_Service_Contexts_Parameter_Access; Result : Any.NamedValue; -- Dummy NamedValue for Create_Request; -- the actual Result is set by the called method. begin if S.Role /= Server then raise GIOP_Error; end if; pragma Debug (C, O ("Request_Received: entering")); Unmarshall_Request_Message (S.Buffer_In, Request_Id, Resp_Exp, Object_Key, Operation, Principal, Service_Contexts); if Resp_Exp then Req_Flags := Sync_With_Target; else Req_Flags := Sync_With_Transport; end if; pragma Debug (C, O ("Object Key : " & Oid_To_Hex_String (Object_Key.all))); Args := Get_Empty_Arg_List (Object_Adapter (ORB_Access (S.Server)), Object_Key, To_Standard_String (Operation)); if not Is_Nil (Args) then pragma Debug (C, O ("Immediate arguments unmarshalling")); Handle_Unmarshall_Arguments (S, Args, Error); if Found (Error) then Catch (Error); raise Program_Error; -- XXX We cannot silently ignore any error. For now, -- we raise this exception. To be investigated. end if; else pragma Debug (C, O ("Unmarshalling of arguments deferred")); S.State := Waiting_Unmarshalling; Def_Args := Component_Access (S); end if; declare Target_Profile : constant Binding_Data.Profile_Access := new Local_Profile_Type; begin Create_Local_Profile (Object_Key.all, Local_Profile_Type (Target_Profile.all)); Create_Reference ((1 => Target_Profile), "", Target); -- Create a temporary, typeless reference for this object. -- If we wanted to have proper type information, we would -- have to resolve the (local) object id through the object -- adapter, and query the target object for its most derived -- type. end; Create_Request (Target => Target, Operation => To_Standard_String (Operation), Arg_List => Args, Result => Result, Deferred_Arguments_Session => Def_Args, Req => Req, Req_Flags => Req_Flags, Dependent_Binding_Object => Smart_Pointers.Entity_Ptr (S.Dependent_Binding_Object)); Add_Request_QoS (Req.all, GIOP_Service_Contexts, QoS_Parameter_Access (Service_Contexts)); Rebuild_Request_QoS_Parameters (Req.all); Queue_Request (S, Req, Request_Id); Free (Object_Key); pragma Debug (C, O ("Request queued.")); end Process_Request; ---------------- -- Send_Reply -- ---------------- procedure Send_Reply (Implem : access GIOP_Implem_1_1; S : access Session'Class; Request : Requests.Request_Access) is pragma Warnings (Off); pragma Unreferenced (Implem); pragma Warnings (On); use PolyORB.ORB; use PolyORB.Errors; Sess : GIOP_Session renames GIOP_Session (S.all); MCtx : aliased GIOP_Message_Context_1_1; Error : Errors.Error_Container; begin if Sess.Role = Client then raise GIOP_Error; end if; MCtx.Message_Type := Reply; Common_Send_Reply (Sess'Access, Request, MCtx'Access, Error); if Found (Error) then Set_Exception (Request.all, Error); Catch (Error); Common_Send_Reply (Sess'Access, Request, MCtx'Access, Error, Recovery => True); if Found (Error) then Catch (Error); raise GIOP_Error; end if; end if; end Send_Reply; ---------------------------- -- Process_Locate_Request -- ---------------------------- procedure Process_Locate_Request (S : in out Session'Class) is use PolyORB.Errors; Sess : GIOP_Session renames GIOP_Session (S); Buffer : Buffer_Access renames Sess.Buffer_In; Request_Id : constant Types.Unsigned_Long := Unmarshall (Buffer); pragma Warnings (Off); Obj : constant Stream_Element_Array := Unmarshall (Buffer); pragma Warnings (On); Target : References.Ref; Result : Locate_Reply_Type; Error : Errors.Error_Container; MCtx : aliased GIOP_Message_Context_1_1; begin Result := Object_Here; -- XXX need to be implemented MCtx.Message_Type := Locate_Reply; MCtx.Request_Id := Request_Id; Common_Locate_Reply (Sess'Access, MCtx'Access, Result, Target, Error); if Found (Error) then Catch (Error); raise GIOP_Error; end if; Expect_GIOP_Header (Sess'Access); end Process_Locate_Request; ------------------- -- Locate Object -- ------------------- procedure Locate_Object (Implem : access GIOP_Implem_1_1; S : access Session'Class; R : Pending_Request_Access; Error : in out Errors.Error_Container) is pragma Warnings (Off); pragma Unreferenced (Implem); pragma Warnings (On); use PolyORB.ORB; use PolyORB.Binding_Data; Sess : GIOP_Session renames GIOP_Session (S.all); MCtx : aliased GIOP_Message_Context_1_1; Buffer : Buffer_Access; Header_Buffer : Buffer_Access; Header_Space : Reservation; begin if Sess.Role /= Client then raise GIOP_Error; end if; pragma Debug (C, O ("Send locate request to find target object")); pragma Debug (C, O ("Locate Request Id :" & R.Locate_Req_Id'Img)); pragma Debug (C, O ("Request Id :" & R.Request_Id'Img)); Buffer := new Buffer_Type; Header_Buffer := new Buffer_Type; Header_Space := Reserve (Buffer, GIOP_Header_Size); Marshall_Locate_Request (Buffer, R.Locate_Req_Id, Get_Object_Key (R.Target_Profile.all)); MCtx.Message_Type := Locate_Request; MCtx.Message_Size := Types.Unsigned_Long (Length (Buffer.all) - GIOP_Header_Size); Marshall_Global_GIOP_Header (Sess'Access, MCtx'Access, Header_Buffer); Copy_Data (Header_Buffer.all, Header_Space); Release (Header_Buffer); Emit_Message (Sess.Implem, S, MCtx'Access, Buffer, Error); Release (Buffer); end Locate_Object; ------------------ -- Send_Request -- ------------------ procedure Send_Request (Implem : access GIOP_Implem_1_1; S : access Session'Class; R : Pending_Request_Access; Error : in out Errors.Error_Container) is pragma Warnings (Off); pragma Unreferenced (Implem); pragma Warnings (On); use PolyORB.Errors; use PolyORB.Requests.Unsigned_Long_Flags; Sess : GIOP_Session renames GIOP_Session (S.all); MCtx : aliased GIOP_Message_Context_1_1; Buffer : Buffer_Access; Header_Buffer : Buffer_Access; Header_Space : Reservation; Resp_Exp : constant Boolean := Is_Set (Sync_With_Target, R.Req.Req_Flags) or else Is_Set (Sync_Call_Back, R.Req.Req_Flags); Oid : constant Object_Id_Access := Binding_Data.Get_Object_Key (R.Target_Profile.all); begin pragma Debug (C, O ("Sending request, Id :" & R.Request_Id'Img)); Buffer := new Buffer_Type; Header_Buffer := new Buffer_Type; Header_Space := Reserve (Buffer, GIOP_Header_Size); Rebuild_Request_Service_Contexts (R.Req.all); Marshall_Service_Context_List (Buffer, QoS_GIOP_Service_Contexts_Parameter_Access (Extract_Request_Parameter (GIOP_Service_Contexts, R.Req.all))); Marshall (Buffer, R.Request_Id); Marshall (Buffer, Resp_Exp); for J in 1 .. 3 loop Marshall (Buffer, Types.Octet'(0)); end loop; Marshall (Buffer, Stream_Element_Array (Oid.all)); pragma Debug (C, O ("Operation : " & R.Req.Operation.all)); Marshall_Latin_1_String (Buffer, R.Req.Operation.all); Marshall_Latin_1_String (Buffer, Nobody_Principal); Marshall_Argument_List (Sess.Implem, Buffer, Sess.Repr, R.Req.Args, PolyORB.Any.ARG_IN, Sess.Implem.Data_Alignment, Error); if Found (Error) then Replace_Marshal_5_To_Inv_Objref_2 (Error, Completed_No); -- An error in the marshalling of wchar data implies the -- server did not provide a valid codeset component. We -- convert this exception to Inv_ObjRef 2. Release (Header_Buffer); Release (Buffer); return; end if; MCtx.Message_Type := Request; MCtx.Message_Size := Types.Unsigned_Long (Length (Buffer.all) - GIOP_Header_Size); Marshall_Global_GIOP_Header (Sess'Access, MCtx'Access, Header_Buffer); Copy_Data (Header_Buffer.all, Header_Space); Release (Header_Buffer); Emit_Message (Sess.Implem, Sess'Access, MCtx'Access, Buffer, Error); pragma Debug (C, O ("Request sent, Id :" & R.Request_Id'Img & ", size:" & MCtx.Message_Size'Img)); Release (Buffer); end Send_Request; ------------------------- -- Send_Cancel_Request -- ------------------------- procedure Send_Cancel_Request (Implem : access GIOP_Implem_1_1; S : access Session'Class; R : Request_Access) is pragma Warnings (Off); pragma Unreferenced (Implem); pragma Warnings (On); use PolyORB.Errors; use PolyORB.ORB; Sess : GIOP_Session renames GIOP_Session (S.all); MCtx : aliased GIOP_Message_Context_1_1; Error : Errors.Error_Container; begin if Sess.Role = Server then raise GIOP_Error; end if; MCtx.Message_Type := Cancel_Request; Common_Send_Cancel_Request (Sess'Access, R, MCtx'Access, Error); if Found (Error) then Catch (Error); raise GIOP_Error; end if; end Send_Cancel_Request; ---------------------------- -- Marshall_Argument_List -- ---------------------------- procedure Marshall_Argument_List (Implem : access GIOP_Implem_1_1; Buffer : Buffers.Buffer_Access; Representation : access CDR_Representation'Class; Args : in out Any.NVList.Ref; Direction : Any.Flags; First_Arg_Alignment : Buffers.Alignment_Type; Error : in out Errors.Error_Container) is pragma Unreferenced (Implem); use PolyORB.Any; use PolyORB.Any.NVList.Internals; use PolyORB.Any.NVList.Internals.NV_Lists; use PolyORB.Errors; It : Iterator := First (List_Of (Args).all); First : Boolean := True; Arg : Element_Access; begin pragma Assert (Direction = ARG_IN or else Direction = ARG_OUT); while not Last (It) loop Arg := Value (It); if False or else Arg.Arg_Modes = Direction or else Arg.Arg_Modes = ARG_INOUT then pragma Debug (C, O ("Marshalling argument " & Types.To_Standard_String (Arg.Name) & " = " & Image (Arg.Argument))); if First then Pad_Align (Buffer, First_Arg_Alignment); First := False; end if; Marshall (Buffer, Representation, Arg.all, Error); if Found (Error) then return; end if; end if; Next (It); end loop; end Marshall_Argument_List; --------------------------------- -- Unmarshalling / Marshalling -- --------------------------------- ---------------------------- -- Unmarshall_GIOP_Header -- ---------------------------- procedure Unmarshall_GIOP_Header (Implem : access GIOP_Implem_1_1; MCtx : access GIOP_Message_Context'Class; Buffer : access Buffers.Buffer_Type) is use Octet_Flags; pragma Warnings (Off); pragma Unreferenced (Implem); pragma Warnings (On); MCtx_1_1 : GIOP_Message_Context_1_1 renames GIOP_Message_Context_1_1 (MCtx.all); Flags : Types.Octet; begin Flags := Unmarshall (Buffer); if Is_Set (Bit_Little_Endian, Flags) then MCtx_1_1.Message_Endianness := Little_Endian; else MCtx_1_1.Message_Endianness := Big_Endian; end if; pragma Assert (MCtx_1_1.Message_Endianness = Endianness (Buffer)); pragma Debug (C, O ("Message Endianness : " & MCtx_1_1.Message_Endianness'Img)); if Is_Set (Bit_Fragment, Flags) then O ("GIOP 1.1 fragmented message discarded", Warning); end if; -- Extract type MCtx_1_1.Message_Type := Unmarshall (Buffer); pragma Debug (C, O ("Message Type : " & MCtx_1_1.Message_Type'Img)); -- Extract size MCtx_1_1.Message_Size := Unmarshall (Buffer); pragma Debug (C, O ("Message Size :" & MCtx_1_1.Message_Size'Img)); end Unmarshall_GIOP_Header; -------------------------- -- Marshall_GIOP_Header -- -------------------------- procedure Marshall_GIOP_Header (Implem : access GIOP_Implem_1_1; S : access Session'Class; MCtx : access GIOP_Message_Context'Class; Buffer : access Buffers.Buffer_Type) is pragma Unreferenced (Implem, S); use Octet_Flags; MCtx_1_1 : GIOP_Message_Context_1_1 renames GIOP_Message_Context_1_1 (MCtx.all); Flags : Types.Octet := 0; begin Set (Flags, Bit_Little_Endian, Endianness (Buffer) = Little_Endian); -- Set (Flags, Bit_Fragment, False); Marshall (Buffer, Flags); Marshall (Buffer, MCtx_1_1.Message_Type); Marshall (Buffer, MCtx_1_1.Message_Size); end Marshall_GIOP_Header; -------------------------------- -- Unmarshall_Request_Message -- -------------------------------- procedure Unmarshall_Request_Message (Buffer : access Buffers.Buffer_Type; Request_Id : out Types.Unsigned_Long; Resp_Exp : out Types.Boolean; Object_Key : out PolyORB.Objects.Object_Id_Access; Operation : out Types.String; Principal : out Types.String; Service_Contexts : out QoS_GIOP_Service_Contexts_Parameter_Access) is Sink : Types.Octet; begin -- Service context Unmarshall_Service_Context_List (Buffer, Service_Contexts); -- Request id Request_Id := Unmarshall (Buffer); pragma Debug (C, O ("Request_Id :" & Request_Id'Img)); -- Response flags Resp_Exp := Unmarshall (Buffer); -- Reserved for I in 1 .. 3 loop Sink := Unmarshall (Buffer); pragma Debug (C and then Sink /= 0, O ("reserved byte in GIOP 1.1 header is non-zero")); end loop; declare Obj : constant Stream_Element_Array := Unmarshall (Buffer); begin Object_Key := new Object_Id'(Object_Id (Obj)); end; -- Operation Operation := Types.String (Types.Identifier'(Unmarshall (Buffer))); pragma Debug (C, O ("Operation : " & Types.To_Standard_String (Operation))); Principal := Unmarshall_Latin_1_String (Buffer); end Unmarshall_Request_Message; -------------------------------- -- Marshall_GIOP_Header_Reply -- -------------------------------- procedure Marshall_GIOP_Header_Reply (Implem : access GIOP_Implem_1_1; S : access Session'Class; R : Request_Access; MCtx : access GIOP_Message_Context'Class; Buffer : access Buffers.Buffer_Type) is pragma Unreferenced (Implem, S); MCtx_1_1 : GIOP_Message_Context_1_1 renames GIOP_Message_Context_1_1 (MCtx.all); begin Rebuild_Reply_Service_Contexts (R.all); Marshall_Service_Context_List (Buffer, QoS_GIOP_Service_Contexts_Parameter_Access (Extract_Reply_Parameter (GIOP_Service_Contexts, R.all))); Marshall (Buffer, MCtx_1_1.Request_Id); Marshall (Buffer, MCtx_1_1.Reply_Status); end Marshall_GIOP_Header_Reply; ----------------------------- -- Marshall_Locate_Request -- ----------------------------- procedure Marshall_Locate_Request (Buffer : Buffer_Access; Request_Id : Types.Unsigned_Long; Object_Key : PolyORB.Objects.Object_Id_Access) is begin Marshall (Buffer, Request_Id); Marshall (Buffer, Stream_Element_Array (Object_Key.all)); end Marshall_Locate_Request; ---------------- -- New_Implem -- ---------------- function New_Implem return GIOP_Implem_Access; function New_Implem return GIOP_Implem_Access is begin return new GIOP_Implem_1_1; end New_Implem; ---------------- -- Initialize -- ---------------- procedure Initialize; procedure Initialize is begin Global_Register_GIOP_Version (GIOP_V1_1, New_Implem'Access); end Initialize; use PolyORB.Initialization; use PolyORB.Initialization.String_Lists; use PolyORB.Utils.Strings; begin Register_Module (Module_Info' (Name => +"protocols.giop.giop_1_1", Conflicts => Empty, Depends => Empty, Provides => Empty, Implicit => False, Init => Initialize'Access, Shutdown => null)); end PolyORB.Protocols.GIOP.GIOP_1_1; ././@LongLink0000000000000000000000000000014700000000000011567 Lustar rootrootpolyorb-2.8~20110207.orig/src/giop/polyorb-giop_p-tagged_components-policies-priority_model_policy.adspolyorb-2.8~20110207.orig/src/giop/polyorb-giop_p-tagged_components-policies-priority_model_policy.a0000644000175000017500000000436611750740340033164 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- POLYORB.GIOP_P.TAGGED_COMPONENTS.POLICIES.PRIORITY_MODEL_POLICY -- -- -- -- S p e c -- -- -- -- Copyright (C) 2004 Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by ACT Europe. -- -- (email: sales@act-europe.fr) -- -- -- ------------------------------------------------------------------------------ -- Allocator for TAG_POLICIES subcomponent PRIORITY_MODEL_POLICY package PolyORB.GIOP_P.Tagged_Components.Policies.Priority_Model_Policy is pragma Elaborate_Body; end PolyORB.GIOP_P.Tagged_Components.Policies.Priority_Model_Policy; polyorb-2.8~20110207.orig/src/giop/polyorb-giop_p-tagged_components.adb0000644000175000017500000003723311750740340025246 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . G I O P _ P . T A G G E D _ C O M P O N E N T S -- -- -- -- B o d y -- -- -- -- Copyright (C) 2003-2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- Implementation of CORBA IOR Tagged components with Ada.Unchecked_Deallocation; with Ada.Tags; with PolyORB.Log; with PolyORB.Representations.CDR.Common; package body PolyORB.GIOP_P.Tagged_Components is use Ada.Streams; use PolyORB.Log; use PolyORB.Representations.CDR.Common; package L is new PolyORB.Log.Facility_Log ("polyorb.giop_p.tagged_components"); procedure O (Message : Standard.String; Level : Log_Level := Debug) renames L.Output; function C (Level : Log_Level := Debug) return Boolean renames L.Enabled; type Bind_Tag is record Tag : Tag_Value; New_Empty_Component : New_Empty_Component_Func_Access; Fetch_Component : Fetch_Component_Func_Access; end record; Binding_List : array (1 .. 10) of Bind_Tag; -- XXX augment array size if there is more components types Bind_Index : Natural := 0; function Get_New_Empty_Component (Tag : Tag_Value) return Tagged_Component_Access; -- Return new empty tagged component with tag Tag procedure Free is new Ada.Unchecked_Deallocation (Tagged_Component'Class, Tagged_Component_Access); -------------------------------------------- -- Create_QoS_GIOP_Tagged_Components_List -- -------------------------------------------- function Create_QoS_GIOP_Tagged_Components_List (Components : Tagged_Component_List) return PolyORB.QoS.Tagged_Components.GIOP_Tagged_Component_Lists.List is use PolyORB.QoS.Tagged_Components; C : Tagged_Component_Access; It : Iterator := First (Components); Result : PolyORB.QoS.Tagged_Components.GIOP_Tagged_Component_Lists.List; begin while not Last (It) loop C := Value (It).all; if C.all in TC_Unknown_Component then PolyORB.QoS.Tagged_Components.GIOP_Tagged_Component_Lists.Append (Result, (Tag => Types.Unsigned_Long (TC_Unknown_Component (C.all).Unknown_Tag), Data => new Ada.Streams.Stream_Element_Array' (TC_Unknown_Component (C.all).Data.all))); else declare Temp_Buf : Buffer_Access := new Buffer_Type; begin Marshall_Component_Data (C, Temp_Buf); Rewind (Temp_Buf); -- XXX Should remove this occurrence of rewind PolyORB.QoS.Tagged_Components.GIOP_Tagged_Component_Lists.Append (Result, (Tag => Types.Unsigned_Long (C.Tag), Data => new Ada.Streams.Stream_Element_Array' (Unmarshall (Temp_Buf)))); Release (Temp_Buf); end; end if; Next (It); end loop; return Result; end Create_QoS_GIOP_Tagged_Components_List; ------------------------------ -- Create_Unknown_Component -- ------------------------------ function Create_Unknown_Component (Unknown_Tag : Tag_Value; Data : Octet_Access) return Tagged_Component_Access is TC : constant Tagged_Component_Access := new TC_Unknown_Component; begin TC_Unknown_Component (TC.all).Unknown_Tag := Unknown_Tag; TC_Unknown_Component (TC.all).Data := Data; return TC; end Create_Unknown_Component; ---------------------- -- Release_Contents -- ---------------------- procedure Release_Contents (List : in out Tagged_Component_List) is Component : Tagged_Component_Access; begin while not Is_Empty (List) loop Extract_First (List, Component); Release_Contents (Component); Free (Component); end loop; end Release_Contents; -------------- -- Register -- -------------- procedure Register (Tag : Tag_Value; New_Empty_Component : New_Empty_Component_Func_Access; Fetch_Component : Fetch_Component_Func_Access) is use type PolyORB.Types.Unsigned_Long; begin -- Check if this Tag has already been registered for J in 1 .. Bind_Index loop if Binding_List (J).Tag = Tag then -- FATAL ERROR: This tag has already been registered raise Program_Error; end if; end loop; Bind_Index := Bind_Index + 1; -- Register tag Binding_List (Bind_Index) := Bind_Tag'(Tag => Tag, New_Empty_Component => New_Empty_Component, Fetch_Component => Fetch_Component); end Register; ------------------------------- -- Marshall_Tagged_Component -- ------------------------------- procedure Marshall_Tagged_Component (Buffer : access Buffer_Type; Components : Tagged_Component_List) is It : Iterator := First (Components); begin pragma Debug (C, O ("Marshall" & Integer'Image (Length (Components)) & " component()s")); Marshall (Buffer, Types.Unsigned_Long (Length (Components))); while not Last (It) loop pragma Debug (C, O (Ada.Tags.External_Tag (Value (It).all'Tag))); Marshall_Tagged_Component (Buffer, Value (It).all); Next (It); end loop; end Marshall_Tagged_Component; procedure Marshall_Tagged_Component (Buffer : access Buffer_Type; Component : Tagged_Component_Access) is begin if Component.Tag /= Tag_Unknown then Marshall (Buffer, Types.Unsigned_Long (Component.Tag)); else Marshall (Buffer, Types.Unsigned_Long (TC_Unknown_Component (Component.all).Unknown_Tag)); end if; Marshall_Component_Data (Component, Buffer); end Marshall_Tagged_Component; ----------------------------- -- Get_New_Empty_Component -- ----------------------------- function Get_New_Empty_Component (Tag : Tag_Value) return Tagged_Component_Access is use type PolyORB.Types.Unsigned_Long; begin pragma Debug (C, O ("Search for tag :" & Tag'Img)); for J in 1 .. Bind_Index loop if Binding_List (J).Tag = Tag then return Binding_List (J).New_Empty_Component.all; end if; end loop; pragma Debug (C, O ("Tag not found, return a TC_Unknown_Component")); declare C : constant Tagged_Component_Access := new TC_Unknown_Component; begin TC_Unknown_Component (C.all).Unknown_Tag := Tag; return C; end; end Get_New_Empty_Component; --------------------------------- -- Unmarshall_Tagged_Component -- --------------------------------- function Unmarshall_Tagged_Component (Buffer : access Buffer_Type) return Tagged_Component_List is Components : Tagged_Component_List := Null_Tagged_Component_List; Length : Types.Unsigned_Long; begin Length := Unmarshall (Buffer); pragma Debug (C, O ("Unmarshall" & Types.Unsigned_Long'Image (Length) & " component(s)")); for J in 1 .. Length loop declare use PolyORB.Errors; TC : Tagged_Component_Access; Tag : Tag_Value; Error : Error_Container; begin Tag := Tag_Value (Types.Unsigned_Long'(Unmarshall (Buffer))); TC := Get_New_Empty_Component (Tag); Unmarshall_Component_Data (TC, Buffer, Error); pragma Assert (not Found (Error)); -- XXX Should properly propagate the error if TC.At_Most_Once then declare It : Iterator := First (Components); begin while not Last (It) loop if Value (It).all.Tag = TC.Tag then Release_Contents (TC); Free (TC); Throw (Error, Bad_Param_E, System_Exception_Members'(10, Completed_No)); -- XXX error to be returned ? return Components; end if; Next (It); end loop; end; end if; Append (Components, TC); end; end loop; return Components; end Unmarshall_Tagged_Component; procedure Unmarshall_Tagged_Component (Buffer : access Buffer_Type; C : out Tagged_Component_Access; Error : out PolyORB.Errors.Error_Container) is use PolyORB.Errors; Tag : Tag_Value; begin Tag := Tag_Value (Types.Unsigned_Long'(Unmarshall (Buffer))); C := Get_New_Empty_Component (Tag); Unmarshall_Component_Data (C, Buffer, Error); end Unmarshall_Tagged_Component; ------------------- -- Get_Component -- ------------------- function Get_Component (List : Tagged_Component_List; Tag : Tag_Value) return Tagged_Component_Access is use type PolyORB.Types.Unsigned_Long; It : Iterator := First (List); begin if Tag = Tag_Value'Last then return null; end if; while not Last (It) loop if Value (It).all.Tag = Tag then return Value (It).all; end if; Next (It); end loop; return null; end Get_Component; -------------------- -- Get_Components -- -------------------- function Get_Components (List : Tagged_Component_List; Tag : Tag_Value) return Tagged_Component_Array is It : Iterator := First (List); Result : Tagged_Component_Array (1 .. Length (List)); RLast : Natural := 0; begin if Tag = Tag_Value'Last then return Result (1 .. 0); end if; while not Last (It) loop if Value (It).all.Tag = Tag then RLast := RLast + 1; Result (RLast) := Value (It).all; end if; Next (It); end loop; return Result (1 .. RLast); end Get_Components; ---------------------- -- Fetch_Components -- ---------------------- function Fetch_Components (Oid : access PolyORB.Objects.Object_Id) return Tagged_Component_List is Result : Tagged_Component_List; New_Component : Tagged_Component_Access; begin for J in 1 .. Bind_Index loop if Binding_List (J).Fetch_Component /= null then New_Component := Binding_List (J).Fetch_Component.all (Oid); if New_Component /= null then Append (Result, New_Component); end if; end if; end loop; return Result; end Fetch_Components; --------- -- Add -- --------- procedure Add (List : in out Tagged_Component_List; Comp : Tagged_Component_Access) is begin pragma Debug (C, O ("Add component to list with tag :" & PolyORB.Types.Unsigned_Long'Image (PolyORB.Types.Unsigned_Long (Comp.Tag)))); Append (List, Comp); end Add; procedure Add (List : in out Tagged_Component_List; CL : Tagged_Component_List) is It : Iterator := First (CL); begin while not Last (It) loop Append (List, Value (It).all); Next (It); end loop; end Add; ------------ -- Remove -- ------------ procedure Remove (List : in out Tagged_Component_List; Comp : Tagged_Component_Access) is begin Remove_Occurrences (List, Comp, All_Occurrences => False); end Remove; --------------- -- Deep_Copy -- --------------- function Deep_Copy (List : Tagged_Component_List) return Tagged_Component_List is Result : Tagged_Component_List; Iter : Iterator := First (List); begin while not Last (Iter) loop Append (Result, Duplicate (Value (Iter).all.all)); Next (Iter); end loop; return Result; end Deep_Copy; ----------------------- -- Unknown Component -- ----------------------- ----------------------------- -- Marshall_Component_Data -- ----------------------------- procedure Marshall_Component_Data (Comp : access TC_Unknown_Component; Buffer : access Buffer_Type) is begin pragma Debug (C, O ("Marshall unknown component, tag = " & PolyORB.Types.Unsigned_Long'Image (PolyORB.Types.Unsigned_Long (Comp.Unknown_Tag)))); Marshall (Buffer, Comp.Data.all); end Marshall_Component_Data; ------------------------------- -- Unmarshall_Component_Data -- ------------------------------- procedure Unmarshall_Component_Data (Comp : access TC_Unknown_Component; Buffer : access Buffer_Type; Error : out PolyORB.Errors.Error_Container) is pragma Unreferenced (Error); begin pragma Debug (C, O ("Unmarshall unknown component")); Comp.Data := new Stream_Element_Array'(Unmarshall (Buffer)); pragma Debug (C, O ("done")); end Unmarshall_Component_Data; --------------- -- Duplicate -- --------------- function Duplicate (Comp : TC_Unknown_Component) return Tagged_Component_Access is Result : constant Tagged_Component_Access := new TC_Unknown_Component; begin TC_Unknown_Component (Result.all).Data := new Stream_Element_Array'(Comp.Data.all); return Result; end Duplicate; ---------------------- -- Release_Contents -- ---------------------- procedure Free is new Ada.Unchecked_Deallocation (Stream_Element_Array, Octet_Access); procedure Release_Contents (Comp : access TC_Unknown_Component) is begin Free (Comp.Data); end Release_Contents; end PolyORB.GIOP_P.Tagged_Components; polyorb-2.8~20110207.orig/src/giop/polyorb-protocols-giop-giop_1_2.ads0000644000175000017500000001752711750740340024675 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . P R O T O C O L S . G I O P . G I O P _ 1 _ 2 -- -- -- -- S p e c -- -- -- -- Copyright (C) 2002-2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with PolyORB.Objects; with PolyORB.References; with PolyORB.QoS.Code_Sets; with PolyORB.Utils.Chained_Lists; package PolyORB.Protocols.GIOP.GIOP_1_2 is private type GIOP_Implem_1_2 is new GIOP_Implem with record Max_GIOP_Message_Size : Types.Unsigned_Long; Max_Body : Types.Unsigned_Long; end record; -- Maximal size for unfragmented messages: by default, no fragmentation Default_Max_GIOP_Message_Size_1_2 : constant Integer := Integer'Last; -- Fragment reassembly state state type Fragment_State is (First, -- Expecting first body fragment Req, -- Expecting request id in fragment header Fragment); -- Expecting fragment body -- GIOP 1.2 message context package GIOP_Message_Context_Lists is new PolyORB.Utils.Chained_Lists (T => GIOP_Message_Context_Access, Doubly_Chained => True); type GIOP_Message_Context_1_2 is new GIOP_Message_Context with record Fragmented : Types.Boolean; -- The following components are used while reassembling a fragmented -- message Frag_State : Fragment_State := First; -- Fragment reassembly state Frag_Buf : Buffers.Buffer_Access; -- Reassembly buffer holding body of reassembled message Frag_Size : Types.Unsigned_Long; -- Amount of data from (non-first) fragment that corresponds to actual -- fragmented payload. Frag_Type : Msg_Type; -- Type of the unfragmented message Frag_Position : GIOP_Message_Context_Lists.Iterator; -- Iterator used to remove this element from the reassembly list when -- last fragment is processed. end record; type GIOP_Session_Context_1_2 is new GIOP_Session_Context with record -- For code sets negotiation CSN_Complete : Boolean := False; CS_Context : PolyORB.QoS.Code_Sets.QoS_GIOP_Code_Sets_Parameter_Access; Reassembly_Contexts : GIOP_Message_Context_Lists.List; end record; procedure Initialize_Implem (Implem : access GIOP_Implem_1_2); procedure Initialize_Session (Implem : access GIOP_Implem_1_2; S : access Session'Class); procedure Finalize_Session (Implem : access GIOP_Implem_1_2; S : access Session'Class); procedure Unmarshall_GIOP_Header (Implem : access GIOP_Implem_1_2; MCtx : access GIOP_Message_Context'Class; Buffer : access Buffers.Buffer_Type); procedure Marshall_GIOP_Header (Implem : access GIOP_Implem_1_2; S : access Session'Class; MCtx : access GIOP_Message_Context'Class; Buffer : access Buffers.Buffer_Type); procedure Marshall_GIOP_Header_Reply (Implem : access GIOP_Implem_1_2; S : access Session'Class; R : Request_Access; MCtx : access GIOP_Message_Context'Class; Buffer : access Buffers.Buffer_Type); procedure Process_Message (Implem : access GIOP_Implem_1_2; S : access Session'Class); procedure Send_Reply (Implem : access GIOP_Implem_1_2; S : access Session'Class; Request : Requests.Request_Access); procedure Emit_Message (Implem : access GIOP_Implem_1_2; S : access Session'Class; MCtx : access GIOP_Message_Context'Class; Buffer : Buffers.Buffer_Access; Error : in out Errors.Error_Container); procedure Locate_Object (Implem : access GIOP_Implem_1_2; S : access Session'Class; R : Pending_Request_Access; Error : in out Errors.Error_Container); procedure Send_Request (Implem : access GIOP_Implem_1_2; S : access Session'Class; R : Pending_Request_Access; Error : in out Errors.Error_Container); procedure Send_Cancel_Request (Implem : access GIOP_Implem_1_2; S : access Session'Class; R : Request_Access); Bidirectionnal_GIOP_Not_Implemented : exception; -- Reassembly management procedure Store_Reassembly_Context (SCtx : access GIOP_Session_Context_1_2; MCtx : GIOP_Message_Context_Access); function Get_Reassembly_Context (SCtx : access GIOP_Session_Context_1_2; Request_Id : Types.Unsigned_Long) return GIOP_Message_Context_Access; procedure Remove_Reassembly_Context (SCtx : access GIOP_Session_Context_1_2; MCtx : in out GIOP_Message_Context_Access); -- XXX documentation required -- Note: These subprograms assume exclusive access to SCtx, which is -- guaranteed by the fact that they are only ever called within -- Handle_Data_Indication. -- Synchronisation scope for 1.2 type Sync_Scope is (NONE, WITH_TRANSPORT, WITH_SERVER, WITH_TARGET); -- Different kind of addressing in GIOP 1.2 type IOR_Addressing_Info is record Selected_Profile_Index : Types.Unsigned_Long; IOR : PolyORB.References.Ref; end record; type IOR_Addressing_Info_Access is access all IOR_Addressing_Info; type Addressing_Disposition is (Key_Addr, Profile_Addr, Reference_Addr); type Target_Address (Address_Type : Addressing_Disposition) is record case Address_Type is when Key_Addr => Object_Key : PolyORB.Objects.Object_Id_Access; when Profile_Addr => Profile : Binding_Data.Profile_Access; when Reference_Addr => Ref : IOR_Addressing_Info_Access; end case; end record; type Target_Address_Access is access all Target_Address; -- Bits in flags field Bit_Fragment : constant Octet_Flags.Bit_Count := 1; -- Data alignment Data_Alignment_1_2 : constant Buffers.Alignment_Type := Buffers.Align_8; -- Fragment header size Frag_Header_Size : constant Types.Unsigned_Long := Types.Unsigned_Long'Size / Types.Octet'Size; end PolyORB.Protocols.GIOP.GIOP_1_2; polyorb-2.8~20110207.orig/src/giop/polyorb-giop_p-code_sets-converters.adb0000644000175000017500000006646411750740340025716 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . G I O P _ P . C O D E _ S E T S . C O N V E R T E R S -- -- -- -- B o d y -- -- -- -- Copyright (C) 2004-2009, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with PolyORB.Initialization; with PolyORB.Parameters; with PolyORB.Representations.CDR.Common; with PolyORB.Utils.Chained_Lists; with PolyORB.Utils.Strings; package body PolyORB.GIOP_P.Code_Sets.Converters is use PolyORB.Buffers; use PolyORB.Errors; use PolyORB.Representations.CDR.Common; use PolyORB.Types; -- Character data converters registry data types type Conversion_Record is record Code_Set : Code_Set_Id; Factory : Converter_Factory; end record; package Conversion_Lists is new PolyORB.Utils.Chained_Lists (Conversion_Record); type Info_Record is record Code_Set : Code_Set_Id; Native : Converter_Factory; Fallback : Converter_Factory; Conversions : Conversion_Lists.List; Conversion_Code_Sets : Code_Set_Id_List; -- Cache of supported conversion code sets, used to avoid re-creation -- of the list for each processed request. end record; package Info_Lists is new PolyORB.Utils.Chained_Lists (Info_Record); -- Wide_Character data converters registry data types type Wide_Conversion_Record is record Code_Set : Code_Set_Id; Factory : Wide_Converter_Factory; end record; package Wide_Conversion_Lists is new PolyORB.Utils.Chained_Lists (Wide_Conversion_Record); type Wide_Info_Record is record Code_Set : Code_Set_Id; Native : Wide_Converter_Factory; Fallback : Wide_Converter_Factory; Conversions : Wide_Conversion_Lists.List; Conversion_Code_Sets : Code_Set_Id_List; -- Cache of supported conversion code sets, used to avoid re-creation -- of the list for each processed request. end record; package Wide_Info_Lists is new PolyORB.Utils.Chained_Lists (Wide_Info_Record); subtype Surrogate_Character is Wide_Character range Wide_Character'Val (16#D800#) .. Wide_Character'Val (16#DFFF#); subtype Invalid_Character is Wide_Character range Wide_Character'Val (16#FFFE#) .. Wide_Character'Val (16#FFFF#); function Find (Code_Set : Code_Set_Id) return Info_Lists.Element_Access; function Find (Code_Set : Code_Set_Id) return Wide_Info_Lists.Element_Access; -- Code set converters factory functions function Create_ISO88591_Native_Converter return Converter_Access; function Create_ISO88591_UTF8_Converter return Converter_Access; function Create_UCS2_Native_Converter return Wide_Converter_Access; function Create_UCS2_UTF16_Converter return Wide_Converter_Access; -- Code set registry variables Info : Info_Lists.List; Wide_Info : Wide_Info_Lists.List; -- UTF16 byte order mark BOM : constant Unsigned_Short := 16#FEFF#; Reverse_BOM : constant Unsigned_Short := 16#FFFE#; -------------------------------------- -- Create_ISO88591_Native_Converter -- -------------------------------------- function Create_ISO88591_Native_Converter return Converter_Access is begin return new ISO88591_Native_Converter; end Create_ISO88591_Native_Converter; ------------------------------------ -- Create_ISO88591_UTF8_Converter -- ------------------------------------ function Create_ISO88591_UTF8_Converter return Converter_Access is begin return new ISO88591_UTF8_Converter; end Create_ISO88591_UTF8_Converter; ---------------------------------- -- Create_UCS2_Native_Converter -- ---------------------------------- function Create_UCS2_Native_Converter return Wide_Converter_Access is begin return new UCS2_Native_Wide_Converter; end Create_UCS2_Native_Converter; --------------------------------- -- Create_UCS2_UTF16_Converter -- --------------------------------- function Create_UCS2_UTF16_Converter return Wide_Converter_Access is begin return new UCS2_UTF16_Wide_Converter; end Create_UCS2_UTF16_Converter; ---------- -- Find -- ---------- function Find (Code_Set : Code_Set_Id) return Info_Lists.Element_Access is use Info_Lists; Iter : Iterator := First (Info); begin while not Last (Iter) loop if Value (Iter).Code_Set = Code_Set then return Value (Iter); end if; Next (Iter); end loop; return null; end Find; function Find (Code_Set : Code_Set_Id) return Wide_Info_Lists.Element_Access is use Wide_Info_Lists; Iter : Iterator := First (Wide_Info); begin while not Last (Iter) loop if Value (Iter).Code_Set = Code_Set then return Value (Iter); end if; Next (Iter); end loop; return null; end Find; ------------------- -- Get_Converter -- ------------------- function Get_Converter (Native_Code_Set : Code_Set_Id; Target_Code_Set : Code_Set_Id) return Converter_Access is use Conversion_Lists; use type Info_Lists.Element_Access; Info : constant Info_Lists.Element_Access := Find (Native_Code_Set); begin if Info = null then return null; elsif Target_Code_Set = Native_Code_Set then return Info.Native.all; elsif Target_Code_Set = Char_Data_Fallback_Code_Set then return Info.Fallback.all; else declare Iter : Iterator := First (Info.Conversions); begin while not Last (Iter) loop if Target_Code_Set = Value (Iter).Code_Set then return Value (Iter).Factory.all; end if; Next (Iter); end loop; end; end if; return null; end Get_Converter; function Get_Converter (Native_Code_Set : Code_Set_Id; Target_Code_Set : Code_Set_Id) return Wide_Converter_Access is use Wide_Conversion_Lists; use type Wide_Info_Lists.Element_Access; Info : constant Wide_Info_Lists.Element_Access := Find (Native_Code_Set); begin if Info = null then return null; elsif Target_Code_Set = Native_Code_Set then return Info.Native.all; elsif Target_Code_Set = Wchar_Data_Fallback_Code_Set then return Info.Fallback.all; else declare Iter : Iterator := First (Info.Conversions); begin while not Last (Iter) loop if Target_Code_Set = Value (Iter).Code_Set then return Value (Iter).Factory.all; end if; Next (Iter); end loop; end; end if; return null; end Get_Converter; -------------- -- Marshall -- -------------- procedure Marshall (C : ISO88591_Native_Converter; Buffer : access Buffers.Buffer_Type; Data : Types.Char; Error : in out Errors.Error_Container) is pragma Unreferenced (C); pragma Unreferenced (Error); begin Marshall_Latin_1_Char (Buffer, Data); end Marshall; procedure Marshall (C : ISO88591_Native_Converter; Buffer : access Buffers.Buffer_Type; Data : Types.String; Error : in out Errors.Error_Container) is pragma Unreferenced (C); pragma Unreferenced (Error); begin Marshall_Latin_1_String (Buffer, Data); end Marshall; procedure Marshall (C : ISO88591_UTF8_Converter; Buffer : access Buffers.Buffer_Type; Data : Types.Char; Error : in out Errors.Error_Container) is pragma Unreferenced (C); begin if Character'Pos (Data) < 16#80# then Marshall (Buffer, Octet (Character'Pos (Data))); else Throw (Error, Data_Conversion_E, System_Exception_Members' (Minor => 1, Completed => Completed_No)); end if; end Marshall; procedure Marshall (C : ISO88591_UTF8_Converter; Buffer : access Buffers.Buffer_Type; Data : Types.String; Error : in out Errors.Error_Container) is pragma Unreferenced (C); pragma Unreferenced (Error); begin Pad_Align (Buffer, Align_4); declare Reserv : constant Reservation := Reserve (Buffer, 4); Buf : Buffer_Access := new Buffer_Type; Length : Unsigned_Long := 0; Equiv : constant Standard.String := To_String (Data) & Character'Val (16#00#); begin for J in Equiv'Range loop if Character'Pos (Equiv (J)) < 16#80# then Marshall (Buffer, Octet (Character'Pos (Equiv (J)))); Length := Length + 1; else Marshall (Buffer, Octet'((Character'Pos (Equiv (J)) and 16#3F#) or 16#80#)); Marshall (Buffer, Octet'((Character'Pos (Equiv (J)) / 2**6) or 16#C0#)); Length := Length + 2; end if; end loop; Marshall (Buf, Length); Copy_Data (Buf.all, Reserv); Release (Buf); end; end Marshall; procedure Marshall (C : UCS2_Native_Wide_Converter; Buffer : access Buffers.Buffer_Type; Data : Types.Wchar; Error : in out Errors.Error_Container) is pragma Unreferenced (Error); begin if C.GIOP_1_2_Mode then Marshall (Buffer, Types.Octet'(2)); Unaligned_Unsigned_Short.Marshall (Buffer, Unsigned_Short (Wchar'Pos (Data))); else Marshall (Buffer, Unsigned_Short (Wchar'Pos (Data))); end if; end Marshall; procedure Marshall (C : UCS2_Native_Wide_Converter; Buffer : access Buffers.Buffer_Type; Data : Types.Wide_String; Error : in out Errors.Error_Container) is pragma Unreferenced (Error); Equiv : constant Wide_String := PolyORB.Types.To_Wide_String (Data); begin if C.GIOP_1_2_Mode then Marshall (Buffer, Unsigned_Long'(Equiv'Length * 2)); else Marshall (Buffer, Unsigned_Long'(Equiv'Length + 1)); end if; for J in Equiv'Range loop Marshall (Buffer, Unsigned_Short'(Wide_Character'Pos (Equiv (J)))); end loop; if not C.GIOP_1_2_Mode then Marshall (Buffer, Unsigned_Short'(0)); end if; end Marshall; procedure Marshall (C : UCS2_UTF16_Wide_Converter; Buffer : access Buffers.Buffer_Type; Data : Types.Wchar; Error : in out Errors.Error_Container) is begin if Data in Surrogate_Character or else Data in Invalid_Character then Throw (Error, Data_Conversion_E, System_Exception_Members' (Minor => 1, Completed => Completed_No)); return; end if; if C.GIOP_1_2_Mode then Marshall (Buffer, Octet'(4)); Unaligned_Unsigned_Short.Marshall (Buffer, BOM); Unaligned_Unsigned_Short.Marshall (Buffer, Unsigned_Short'(Wchar'Pos (Data))); else Marshall (Buffer, Unsigned_Short'(Wchar'Pos (Data))); end if; end Marshall; procedure Marshall (C : UCS2_UTF16_Wide_Converter; Buffer : access Buffers.Buffer_Type; Data : Types.Wide_String; Error : in out Errors.Error_Container) is Equiv : constant Wide_String := To_Wide_String (Data); begin if C.GIOP_1_2_Mode then Marshall (Buffer, Unsigned_Long (Equiv'Length + 1) * 2); Marshall (Buffer, BOM); else Marshall (Buffer, Unsigned_Long (Equiv'Length + 2)); Marshall (Buffer, BOM); end if; for J in Equiv'Range loop if Equiv (J) in Surrogate_Character or else Equiv (J) in Invalid_Character then Throw (Error, Data_Conversion_E, System_Exception_Members' (Minor => 1, Completed => Completed_No)); return; end if; Marshall (Buffer, Unsigned_Short'(Wide_Character'Pos (Equiv (J)))); end loop; if not C.GIOP_1_2_Mode then Marshall (Buffer, Unsigned_Short'(0)); end if; end Marshall; ------------------------------ -- Register_Native_Code_Set -- ------------------------------ procedure Register_Native_Code_Set (Code_Set : Code_Set_Id; Native : Converter_Factory; Fallback : Converter_Factory) is begin Info_Lists.Append (Info, (Code_Set => Code_Set, Native => Native, Fallback => Fallback, Conversions => Conversion_Lists.Empty, Conversion_Code_Sets => Code_Set_Id_List (Code_Set_Id_Lists.Empty))); end Register_Native_Code_Set; procedure Register_Native_Code_Set (Code_Set : Code_Set_Id; Native : Wide_Converter_Factory; Fallback : Wide_Converter_Factory) is begin Wide_Info_Lists.Append (Wide_Info, (Code_Set => Code_Set, Native => Native, Fallback => Fallback, Conversions => Wide_Conversion_Lists.Empty, Conversion_Code_Sets => Code_Set_Id_List (Code_Set_Id_Lists.Empty))); end Register_Native_Code_Set; ---------------------------------- -- Register_Conversion_Code_Set -- ---------------------------------- procedure Register_Conversion_Code_Set (Native : Code_Set_Id; Conversion : Code_Set_Id; Factory : Converter_Factory) is Info : constant Info_Lists.Element_Access := Find (Native); begin Conversion_Lists.Append (Info.Conversions, (Conversion, Factory)); Append (Info.Conversion_Code_Sets, Conversion); end Register_Conversion_Code_Set; procedure Register_Conversion_Code_Set (Native : Code_Set_Id; Conversion : Code_Set_Id; Factory : Wide_Converter_Factory) is Info : constant Wide_Info_Lists.Element_Access := Find (Native); begin Wide_Conversion_Lists.Append (Info.Conversions, (Conversion, Factory)); Append (Info.Conversion_Code_Sets, Conversion); end Register_Conversion_Code_Set; ----------------------- -- Set_GIOP_1_2_Mode -- ----------------------- procedure Set_GIOP_1_2_Mode (C : in out Wide_Converter) is begin C.GIOP_1_2_Mode := True; end Set_GIOP_1_2_Mode; ----------------------------------------- -- Supported_Char_Conversion_Code_Sets -- ----------------------------------------- function Supported_Char_Conversion_Code_Sets (Code_Set : Code_Set_Id) return Code_Set_Id_List is use type Info_Lists.Element_Access; Info : constant Info_Lists.Element_Access := Find (Code_Set); begin if Info /= null then return Info.Conversion_Code_Sets; else return Code_Set_Id_List (Code_Set_Id_Lists.Empty); end if; end Supported_Char_Conversion_Code_Sets; ------------------------------------------ -- Supported_Wchar_Conversion_Code_Sets -- ------------------------------------------ function Supported_Wchar_Conversion_Code_Sets (Code_Set : Code_Set_Id) return Code_Set_Id_List is use type Wide_Info_Lists.Element_Access; Info : constant Wide_Info_Lists.Element_Access := Find (Code_Set); begin if Info /= null then return Info.Conversion_Code_Sets; else return Code_Set_Id_List (Code_Set_Id_Lists.Empty); end if; end Supported_Wchar_Conversion_Code_Sets; ---------------- -- Unmarshall -- ---------------- procedure Unmarshall (C : ISO88591_Native_Converter; Buffer : access Buffers.Buffer_Type; Data : out Types.Char; Error : in out Errors.Error_Container) is pragma Unreferenced (C); pragma Unreferenced (Error); begin Data := Unmarshall_Latin_1_Char (Buffer); end Unmarshall; ---------------- -- Unmarshall -- ---------------- procedure Unmarshall (C : ISO88591_Native_Converter; Buffer : access Buffers.Buffer_Type; Data : out Types.String; Error : in out Errors.Error_Container) is pragma Unreferenced (C); pragma Unreferenced (Error); begin Data := Unmarshall_Latin_1_String (Buffer); end Unmarshall; procedure Unmarshall (C : ISO88591_UTF8_Converter; Buffer : access Buffers.Buffer_Type; Data : out Types.Char; Error : in out Errors.Error_Container) is pragma Unreferenced (C); begin Data := Character'Val (Octet'(Unmarshall (Buffer))); if Character'Pos (Data) >= 16#80# then Throw (Error, Data_Conversion_E, System_Exception_Members' (Minor => 1, Completed => Completed_No)); end if; end Unmarshall; procedure Unmarshall (C : ISO88591_UTF8_Converter; Buffer : access Buffers.Buffer_Type; Data : out Types.String; Error : in out Errors.Error_Container) is pragma Unreferenced (C); pragma Unreferenced (Error); Length : Unsigned_Long := Unmarshall (Buffer); Result : Standard.String (1 .. Integer (Length)); Aux : Octet; Last : Natural := Result'First - 1; begin while Length > 0 loop Last := Last + 1; Result (Last) := Character'Val (Octet'(Unmarshall (Buffer))); Length := Length - 1; if Character'Pos (Result (Last)) >= 16#80# then if Length = 0 then raise Program_Error; -- XXX Raise Marshall exception ? end if; Aux := Unmarshall (Buffer); Result (Last) := Character'Val (Octet'(Character'Pos (Result (Last)) and 16#1F#) * 2**6 + (Aux and 16#3F#)); Length := Length - 1; end if; end loop; Data := To_PolyORB_String (Result (Result'First .. Last - 1)); end Unmarshall; procedure Unmarshall (C : UCS2_Native_Wide_Converter; Buffer : access Buffers.Buffer_Type; Data : out Types.Wchar; Error : in out Errors.Error_Container) is pragma Unreferenced (Error); Length : Octet; begin if C.GIOP_1_2_Mode then Length := Unmarshall (Buffer); if Length /= 2 then raise Program_Error; -- XXX Raise Marshall exception ? else Data := Wchar'Val (Unaligned_Unsigned_Short.Unmarshall (Buffer)); end if; else Data := Wchar'Val (Unsigned_Short'(Unmarshall (Buffer))); end if; end Unmarshall; procedure Unmarshall (C : UCS2_Native_Wide_Converter; Buffer : access Buffers.Buffer_Type; Data : out Types.Wide_String; Error : in out Errors.Error_Container) is pragma Unreferenced (Error); Length : constant Unsigned_Long := Unmarshall (Buffer); Result : Standard.Wide_String (1 .. Integer (Length)); Last : Natural := Result'First - 1; begin if C.GIOP_1_2_Mode then if Length mod 2 /= 0 then raise Program_Error; -- XXX Raise Marshall exception ? end if; Last := Natural (Length / 2); else Last := Natural (Length); end if; for J in Result'First .. Last loop Result (J) := Wchar'Val (Unsigned_Short'(Unmarshall (Buffer))); end loop; if not C.GIOP_1_2_Mode then Last := Last - 1; end if; Data := To_PolyORB_Wide_String (Result (Result'First .. Last)); end Unmarshall; procedure Unmarshall (C : UCS2_UTF16_Wide_Converter; Buffer : access Buffers.Buffer_Type; Data : out Types.Wchar; Error : in out Errors.Error_Container) is Code : Unsigned_Short; begin if C.GIOP_1_2_Mode then declare Length : constant Octet := Unmarshall (Buffer); begin Code := Unaligned_Unsigned_Short.Unmarshall (Buffer); if Length = 2 then Data := Wchar'Val (Code); elsif Length = 4 then if Code = Reverse_BOM then raise Program_Error; -- XXX Value marshalled in reverse endian-ness elsif Code = BOM then Data := Wchar'Val (Unaligned_Unsigned_Short.Unmarshall (Buffer)); else raise Program_Error; end if; else raise Program_Error; end if; end; else Code := Unmarshall (Buffer); if Code = Reverse_BOM then raise Program_Error; -- XXX Value marshalled in reverse endian-ness elsif Code = BOM then Data := Wchar'Val (Unsigned_Short'(Unmarshall (Buffer))); else Data := Wchar'Val (Code); end if; end if; if Data in Surrogate_Character or else Data in Invalid_Character then Throw (Error, Data_Conversion_E, System_Exception_Members' (Minor => 1, Completed => Completed_No)); end if; end Unmarshall; procedure Unmarshall (C : UCS2_UTF16_Wide_Converter; Buffer : access Buffers.Buffer_Type; Data : out Types.Wide_String; Error : in out Errors.Error_Container) is Length : constant Unsigned_Long := Unmarshall (Buffer); Result : Standard.Wide_String (1 .. Integer (Length)); First : Positive; Last : Natural; Code : Unsigned_Short; begin if C.GIOP_1_2_Mode then if Length mod 2 = 1 then raise Program_Error; -- XXX Raise Marshall exception ? elsif Length = 0 then Data := To_PolyORB_Wide_String (Wide_String'("")); return; end if; Last := Natural (Length / 2); else Last := Natural (Length); end if; Code := Unmarshall (Buffer); if Code = Reverse_BOM then raise Program_Error; -- Value encoded in reverse endian-ness elsif Code = BOM then Last := Last - 1; First := Result'First; else Result (Result'First) := Wchar'Val (Code); First := Result'First + 1; end if; for J in First .. Last loop Result (J) := Wchar'Val (Unsigned_Short'(Unmarshall (Buffer))); if Result (J) in Surrogate_Character or else Result (J) in Invalid_Character then Throw (Error, Data_Conversion_E, System_Exception_Members' (Minor => 1, Completed => Completed_No)); end if; end loop; if not C.GIOP_1_2_Mode then Last := Last - 1; end if; Data := To_PolyORB_Wide_String (Result (Result'First .. Last)); end Unmarshall; ---------------- -- Initialize -- ---------------- procedure Initialize; procedure Initialize is use PolyORB.Parameters; -- These parameters force the registration of additional fallback code -- sets for char and wchar data. This is useful for interoperation with -- ORBs with broken charsets negotiation support. Char_Fallback : constant Boolean := Get_Conf ("giop", "giop.add_char_fallback_code_set", Default => False); Wide_Char_Fallback : constant Boolean := Get_Conf ("giop", "giop.add_wchar_fallback_code_set", Default => False); begin -- Register supported char code sets (ISO-8859-1) Register_Native_Code_Set (Ada95_Native_Character_Code_Set, Create_ISO88591_Native_Converter'Access, Create_ISO88591_UTF8_Converter'Access); if Char_Fallback then -- Fallback code sets (UTF-8) Register_Conversion_Code_Set (Ada95_Native_Character_Code_Set, Char_Data_Fallback_Code_Set, Create_ISO88591_UTF8_Converter'Access); end if; -- Register supported wchar code sets (UCS-2) Register_Native_Code_Set (Ada95_Native_Wide_Character_Code_Set, Create_UCS2_Native_Converter'Access, Create_UCS2_UTF16_Converter'Access); Register_Conversion_Code_Set (Ada95_Native_Wide_Character_Code_Set, UCS_2_Level_2_Code_Set, Create_UCS2_Native_Converter'Access); Register_Conversion_Code_Set (Ada95_Native_Wide_Character_Code_Set, UCS_2_Level_3_Code_Set, Create_UCS2_Native_Converter'Access); if Wide_Char_Fallback then -- Fallback code sets (UTF-16) Register_Conversion_Code_Set (Ada95_Native_Wide_Character_Code_Set, Wchar_Data_Fallback_Code_Set, Create_UCS2_UTF16_Converter'Access); end if; end Initialize; begin declare use PolyORB.Initialization; use PolyORB.Initialization.String_Lists; use PolyORB.Utils.Strings; begin Register_Module (Module_Info' (Name => +"code_sets.converters", Conflicts => Empty, Depends => Empty, Provides => Empty, Implicit => False, Init => Initialize'Access, Shutdown => null)); end; end PolyORB.GIOP_P.Code_Sets.Converters; polyorb-2.8~20110207.orig/src/giop/gen_codeset.adb0000644000175000017500000004340411750740340021063 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- G E N _ C O D E S E T -- -- -- -- B o d y -- -- -- -- Copyright (C) 2004-2009, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- Generate a code sets data packages from the OSF/OpenGroup code set -- registry file from an Open Group code set registry file (version 1.2). -- The latest code set registry file can be downloaded from the Open Group -- FTP server at ftp://ftp.opengroup.org/pub/code_set_registry/ with Ada.Command_Line; with Ada.Text_IO; with Ada.Streams; with Ada.Streams.Stream_IO; use Ada.Streams.Stream_IO; with GNAT.Table; procedure Gen_Codeset is package ATIO renames Ada.Text_IO; Output : Ada.Streams.Stream_IO.File_Type; procedure Put (S : String; Width : Integer := 0); generic type T is range <>; procedure Integer_Put (I : T; Width : Integer := 0); procedure Put (C : Character); procedure Put_Line (S : String); procedure New_Line; -- Same as ATIO.*, but reimplemented on top of Stream_IO and -- always using UNIX-style line terminators. type Mode_Type is (Description, Compatibility); type Code_Set_Id is range 0 .. 2**32 - 1; type Character_Set_Id is range 0 .. 2**16 - 1; package Description_Table is new GNAT.Table (Character, Natural, 1, 1024, 1024); package Character_Sets_Table is new GNAT.Table (Character_Set_Id, Natural, 1, 1024, 1024); type Code_Set_Info is record Code_Set : Code_Set_Id; Description_First : Positive; Description_Last : Natural; Character_Set_First : Positive; Character_Set_Last : Natural; end record; package Code_Set_Table is new GNAT.Table (Code_Set_Info, Natural, 1, 1024, 1024); procedure Add_Description (Description : String; First : out Positive; Last : out Natural); -- Copy description string into descriptions table, and return -- the first and last indices of copied string. procedure Process_Code_Set; -- Process one section of code set registry file. procedure Compact_Character_Sets_Table; -- Compress contents of Character_Sets_Table. procedure Generate_Description_Data_Module; procedure Generate_Compatibility_Data_Module; procedure Put (Buffer : out String; Value : Code_Set_Id); procedure Put (Buffer : out String; Value : Character_Set_Id); Pkg_Name : String renames Ada.Command_Line.Argument (2); Mode : Mode_Type; Line : String (1 .. 1024); First : constant Positive := Line'First; Last : Natural := Line'First - 1; Short_Description : constant String := "Short Description"; Registered_Value : constant String := "Registered Value"; Character_Set_Ids : constant String := "Character Set ID(s)"; --------------------- -- Add_Description -- --------------------- procedure Add_Description (Description : String; First : out Positive; Last : out Natural) is begin First := Description_Table.Last + 1; for J in Description'Range loop Description_Table.Append (Description (J)); end loop; Last := Description_Table.Last; end Add_Description; ---------------------------------- -- Compact_Character_Sets_Table -- ---------------------------------- procedure Compact_Character_Sets_Table is package Aux_Table is new GNAT.Table (Character_Set_Id, Natural, 1, 1024, 1024); function Find (First : Positive; Last : Natural) return Natural; -- Return first index of sequence of characters sets in Aux_Table -- what equal of sequence Character_Sets_Talbe (First .. Last). ---------- -- Find -- ---------- function Find (First : Positive; Last : Natural) return Natural is Length : constant Natural := Last - First + 1; Found : Boolean := False; begin for J in Aux_Table.First .. Aux_Table.Last - Length + 1 loop if Aux_Table.Table (J) = Character_Sets_Table.Table (First) then Found := True; for K in First + 1 .. Last loop if Aux_Table.Table (J + K - First) /= Character_Sets_Table.Table (K) then Found := False; exit; end if; end loop; if Found then return J; end if; end if; end loop; return 0; end Find; begin for J in Code_Set_Table.First .. Code_Set_Table.Last loop declare Info : Code_Set_Info renames Code_Set_Table.Table (J); Length : constant Natural := Info.Character_Set_Last - Info.Character_Set_First + 1; Index : constant Natural := Find (Info.Character_Set_First, Info.Character_Set_Last); First : constant Natural := Aux_Table.Last + 1; begin if Index = 0 then for J in Info.Character_Set_First .. Info.Character_Set_Last loop Aux_Table.Append (Character_Sets_Table.Table (J)); end loop; Info.Character_Set_First := First; Info.Character_Set_Last := First + Length - 1; else Info.Character_Set_First := Index; Info.Character_Set_Last := Index + Length - 1; end if; end; end loop; for J in Aux_Table.First .. Aux_Table.Last loop Character_Sets_Table.Set_Item (J, Aux_Table.Table (J)); end loop; Character_Sets_Table.Set_Last (Aux_Table.Last); Aux_Table.Free; end Compact_Character_Sets_Table; ---------------------------------------- -- Generate_Compatibility_Data_Module -- ---------------------------------------- procedure Generate_Compatibility_Data_Module is procedure Put is new Integer_Put (Integer); begin Put_Line ("-- AUTOMATICALLY GENERATED, DO NOT EDIT!"); New_Line; -- Disable style checks (N), and set maximum line length to the largest -- allowed value (M32766). Put_Line ("pragma Style_Checks (""NM32766"");"); Put_Line ("private package " & Pkg_Name & " is"); New_Line; Put_Line (" Info : constant array (Positive range <>)" & " of Code_Set_Info_Record :="); Put (" ("); for J in 1 .. Code_Set_Table.Last loop declare Info : Code_Set_Info renames Code_Set_Table.Table (J); Buf : String (1 .. 13); procedure Put_Description; -- Output Ada comment with description of current entry procedure Put_Description is begin Put (" -- "); for J in Info.Description_First .. Info.Description_Last loop Put (Description_Table.Table (J)); end loop; New_Line; end Put_Description; begin Put (Buf, Info.Code_Set); Put ('('); Put (Buf (2 .. 13)); Put (','); Put (Info.Character_Set_First, 3); Put (','); Put (Info.Character_Set_Last, 3); Put (')'); if J /= Code_Set_Table.Last then Put (", "); Put_Description; Put (" "); else Put (");"); Put_Description; end if; end; end loop; New_Line; Put_Line (" Character_Sets : constant Character_Set_Id_Array :="); Put (" ("); for J in 1 .. Character_Sets_Table.Last loop declare Buf : String (1 .. 9); begin Put (Buf, Character_Sets_Table.Table (J)); Put (Buf (2 .. 9)); end; if J /= Character_Sets_Table.Last then Put (","); if J mod 7 = 0 then New_Line; Put (" "); else Put (' '); end if; end if; end loop; Put_Line (");"); New_Line; Put ("end " & Pkg_Name & ";"); end Generate_Compatibility_Data_Module; -------------------------------------- -- Generate_Description_Data_Module -- -------------------------------------- procedure Generate_Description_Data_Module is procedure Put is new Integer_Put (Integer); begin Put_Line ("-- AUTOMATICALLY GENERATED, DO NOT EDIT!"); Put_Line ("package " & Pkg_Name & " is"); New_Line; Put_Line (" type Info_Record is record"); Put_Line (" Code_Set : Code_Set_Id;"); Put_Line (" First : Positive;"); Put_Line (" Last : Natural;"); Put_Line (" end record;"); New_Line; Put_Line (" Info : constant array (Positive range <>) of Info_Record"); Put (" := ("); for J in 1 .. Code_Set_Table.Last loop declare Info : Code_Set_Info renames Code_Set_Table.Table (J); Buf : String (1 .. 13); begin Put (Buf, Info.Code_Set); Put ('('); Put (Buf (2 .. 13)); Put (','); Put (Info.Description_First, 5); Put (','); Put (Info.Description_Last, 5); Put (')'); end; if J /= Code_Set_Table.Last then Put (','); New_Line; Put (" "); else Put_Line (");"); end if; end loop; New_Line; Put_Line (" Description : constant String"); Put (" := """); for J in 1 .. Description_Table.Last loop Put (Description_Table.Table (J)); if J = 68 or else (J > 68 and then (J - 68) mod 64 = 0) then Put ('"'); New_Line; Put (" & """); end if; end loop; Put (""";"); New_Line; Put ("end " & Pkg_Name & ";"); end Generate_Description_Data_Module; ----------------- -- Integer_Put -- ----------------- procedure Integer_Put (I : T; Width : Integer := 0) is Img : constant String := T'Image (I); First : Integer := Img'First; begin if Img (First) = ' ' then First := First + 1; end if; Put (Img (First .. Img'Last), Width); end Integer_Put; -------------- -- New_Line -- -------------- procedure New_Line is begin Put (ASCII.LF); end New_Line; ---------------------- -- Process_Code_Set -- ---------------------- procedure Process_Code_Set is Description_First : Positive := 1; Description_Last : Natural := 0; Code_Set : Code_Set_Id := 0; Character_Set_First : constant Positive := Character_Sets_Table.Last + 1; Character_Set_Last : Natural := 0; Length : Natural; begin for J in 1 .. 4 loop ATIO.Get_Line (Line, Last); Length := Last - Line'First + 1; if Length - Line'First + 1 > Short_Description'Length + 2 and then Line (First .. First + Short_Description'Length - 1) = Short_Description then Add_Description (Line (First + Short_Description'Length + 1 .. Last), Description_First, Description_Last); elsif Length > Registered_Value'Length + 2 and then Line (First .. First + Registered_Value'Length - 1) = Registered_Value then declare Image : constant String := "16#" & Line (Registered_Value'Last + 4 .. Last) & '#'; begin Code_Set := Code_Set_Id'Value (Image); end; elsif Length > Character_Set_Ids'Length + 2 and then Line (First .. First + Character_Set_Ids'Length - 1) = Character_Set_Ids then declare First : Positive := Character_Set_Ids'Last + 4; begin while First < Last loop declare Image : constant String := "16#" & Line (First .. First + 3) & '#'; begin Character_Sets_Table.Append (Character_Set_Id'Value (Image)); Character_Set_Last := Character_Sets_Table.Last; end; First := First + 7; end loop; end; else null; -- XXX end if; end loop; Code_Set_Table.Append ((Code_Set, Description_First, Description_Last, Character_Set_First, Character_Set_Last)); end Process_Code_Set; --------- -- Put -- --------- procedure Put (S : String; Width : Integer := 0) is use Ada.Streams; Len : Integer := Width; begin if S'Length > Len then Len := S'Length; end if; declare SS : aliased String (1 .. Len) := (others => ' '); subtype SEA is Stream_Element_Array (1 .. Stream_Element_Offset (Len)); Bytes : SEA; for Bytes'Address use SS'Address; pragma Import (Ada, Bytes); begin SS (Len - S'Length + 1 .. Len) := S; Write (Output, Bytes); end; end Put; --------- -- Put -- --------- procedure Put (C : Character) is begin Write (Output, Ada.Streams.Stream_Element_Array'(0 => Character'Pos (C))); end Put; --------- -- Put -- --------- procedure Put (Buffer : out String; Value : Character_Set_Id) is package IO is new Ada.Text_IO.Integer_IO (Character_Set_Id); Aux : Character; begin IO.Put (Buffer, Value, 16); if Buffer (Buffer'First + 1) = ' ' then Buffer (Buffer'First + 1 .. Buffer'First + 3) := "16#"; for J in Buffer'First + 4 .. Buffer'Last - 1 loop Aux := Buffer (J); Buffer (J) := '0'; exit when Aux = '#'; end loop; end if; end Put; --------- -- Put -- --------- procedure Put (Buffer : out String; Value : Code_Set_Id) is package IO is new Ada.Text_IO.Integer_IO (Code_Set_Id); Aux : Character; begin IO.Put (Buffer, Value, 16); if Buffer (Buffer'First + 1) = ' ' then Buffer (Buffer'First + 1 .. Buffer'First + 3) := "16#"; for J in Buffer'First + 4 .. Buffer'Last - 1 loop Aux := Buffer (J); Buffer (J) := '0'; exit when Aux = '#'; end loop; end if; end Put; -------------- -- Put_Line -- -------------- procedure Put_Line (S : String) is begin Put (S); New_Line; end Put_Line; -- Start of processing for Gen_Codeset begin if Ada.Command_Line.Argument_Count /= 3 or else (Ada.Command_Line.Argument (1) /= "-d" and then Ada.Command_Line.Argument (1) /= "-c") then ATIO.Put_Line (ATIO.Standard_Error, "Usage:"); ATIO.Put_Line (ATIO.Standard_Error, "gen_codesets "); ATIO.Put_Line (ATIO.Standard_Error, ":"); ATIO.Put_Line (ATIO.Standard_Error, " -d Code sets description"); ATIO.Put_Line (ATIO.Standard_Error, " -c Code sets compatibility"); Ada.Command_Line.Set_Exit_Status (1); return; end if; if Ada.Command_Line.Argument (1) = "-d" then Mode := Description; else Mode := Compatibility; end if; while not ATIO.End_Of_File (ATIO.Standard_Input) loop ATIO.Get_Line (Line, Last); if Line (First .. Last) = "start" then Process_Code_Set; end if; end loop; Create (Output, Out_File, Ada.Command_Line.Argument (3)); if Mode = Compatibility then Compact_Character_Sets_Table; Generate_Compatibility_Data_Module; else Generate_Description_Data_Module; end if; end Gen_Codeset; polyorb-2.8~20110207.orig/src/giop/polyorb-binding_data-giop-inet.ads0000644000175000017500000000655311750740340024611 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . B I N D I N G _ D A T A . G I O P . I N E T -- -- -- -- S p e c -- -- -- -- Copyright (C) 2004-2008, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- Common utilities for GIOP instances that rely on IP sockets. with PolyORB.Buffers; with PolyORB.Utils.Sockets; package PolyORB.Binding_Data.GIOP.INET is procedure Common_Marshall_Profile_Body (Buffer : access Buffers.Buffer_Type; Profile : Profile_Access; Sock : Utils.Sockets.Socket_Name; Marshall_Object_Id : Boolean); function Common_Unmarshall_Profile_Body (Buffer : access Buffers.Buffer_Type; Profile : Profile_Access; Unmarshall_Object_Id : Boolean; Unmarshall_Tagged_Components : Boolean) return Utils.Sockets.Socket_Name; -- If True always unmarshall tagged component, if False then the -- tagged components are unmarshalled only if Version_Minor >= 1. function Common_IIOP_DIOP_Profile_To_Corbaloc (Profile : Profile_Access; Address : Utils.Sockets.Socket_Name; Prefix : String) return String; function Common_IIOP_DIOP_Corbaloc_To_Profile (Str : String; Default_Major : Types.Octet; Default_Minor : Types.Octet; Profile : access Profile_Access) return Utils.Sockets.Socket_Name; -- Set Profile.all.all and return address according to given corbaloc URI. -- In case of error, Profile.all is freed. end PolyORB.Binding_Data.GIOP.INET; polyorb-2.8~20110207.orig/src/giop/polyorb-giop_p-exceptions.ads0000644000175000017500000000537311750740340023750 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . G I O P _ P . E X C E P T I O N S -- -- -- -- S p e c -- -- -- -- Copyright (C) 2002-2007, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- Exceptions management for the GIOP Protocol Personality of PolyORB. with PolyORB.Any; package PolyORB.GIOP_P.Exceptions is function Is_System_Exception (Name : String) return Boolean; function To_CORBA_Exception (Exc : PolyORB.Any.Any) return PolyORB.Any.Any; -- Convert PolyORB Exc exception typecode to CORBA exception typecode function Extract_System_Exception_Name (Name : Standard.String) return Standard.String; -- Extract the name of the system exception found in Name. function System_Exception_TypeCode (Name : Standard.String) return PolyORB.Any.TypeCode.Local_Ref; -- Return the TypeCode corresponding to the indicated -- system exception name. end PolyORB.GIOP_P.Exceptions; polyorb-2.8~20110207.orig/src/giop/polyorb-protocols-giop-common.adb0000644000175000017500000011242211750740340024533 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . P R O T O C O L S . G I O P . C O M M O N -- -- -- -- B o d y -- -- -- -- Copyright (C) 2002-2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with PolyORB.Any.ExceptionList; with PolyORB.Errors.Helper; with PolyORB.Exceptions; with PolyORB.GIOP_P.Exceptions; with PolyORB.Log; with PolyORB.References.IOR; with PolyORB.Representations.CDR.Common; with PolyORB.Request_QoS; with PolyORB.Requests; with PolyORB.Servants.Iface; with PolyORB.Smart_Pointers; with PolyORB.Utils.Strings; with PolyORB.QoS.Static_Buffers; with PolyORB.Opaque; package body PolyORB.Protocols.GIOP.Common is use PolyORB.Buffers; use PolyORB.Exceptions; use PolyORB.Log; use PolyORB.Representations.CDR; use PolyORB.Representations.CDR.Common; use PolyORB.Request_QoS; use PolyORB.QoS; use PolyORB.QoS.Service_Contexts; use PolyORB.QoS.Static_Buffers; package L is new PolyORB.Log.Facility_Log ("polyorb.protocols.giop.common"); procedure O (Message : String; Level : Log_Level := Debug) renames L.Output; function C (Level : Log_Level := Debug) return Boolean renames L.Enabled; ---------------------- -- Generic_Marshall -- ---------------------- procedure Generic_Marshall (Buffer : access PolyORB.Buffers.Buffer_Type; Val : Table_Type) is Index : constant Target_Type := Table_Type'Pos (Val); begin Marshall (Buffer, Index); end Generic_Marshall; ------------------------ -- Generic_Unmarshall -- ------------------------ function Generic_Unmarshall (Buffer : access PolyORB.Buffers.Buffer_Type) return Table_Type is Index : constant Target_Type := Unmarshall (Buffer); begin return Table_Type'Val (Index); end Generic_Unmarshall; ------------- -- Helpers -- ------------- procedure Marshall_Aux is new Generic_Marshall (Reply_Status_Type, Types.Unsigned_Long, Marshall); procedure Marshall (Buffer : access PolyORB.Buffers.Buffer_Type; Val : Reply_Status_Type) is begin -- XXX not necessary, instantiate it in spec Marshall_Aux (Buffer, Val); end Marshall; procedure Marshall_Aux is new Generic_Marshall (Locate_Reply_Type, Types.Unsigned_Long, Marshall); procedure Marshall (Buffer : access PolyORB.Buffers.Buffer_Type; Val : Locate_Reply_Type) is begin -- XXX not necessary, instantiate it in spec Marshall_Aux (Buffer, Val); end Marshall; function Unmarshall_Aux is new Generic_Unmarshall (Reply_Status_Type, Types.Unsigned_Long, Unmarshall); function Unmarshall (Buffer : access PolyORB.Buffers.Buffer_Type) return Reply_Status_Type is begin -- XXX not necessary, instantiate it in spec return Unmarshall_Aux (Buffer); end Unmarshall; function Unmarshall_Aux is new Generic_Unmarshall (Locate_Reply_Type, Types.Unsigned_Long, Unmarshall); function Unmarshall (Buffer : access PolyORB.Buffers.Buffer_Type) return Locate_Reply_Type is begin -- XXX not necessary, instantiate it in spec return Unmarshall_Aux (Buffer); end Unmarshall; ----------------------- -- Common_Send_Reply -- ----------------------- procedure Common_Send_Reply (Sess : access GIOP_Session; Request : Requests.Request_Access; MCtx : access GIOP_Message_Context'Class; Error : in out Errors.Error_Container; Recovery : Boolean := False) is use PolyORB.Annotations; use PolyORB.Any; use PolyORB.Components; use PolyORB.Errors; use PolyORB.Errors.Helper; use type PolyORB.Any.TypeCode.Local_Ref; Buffer_Out : Buffer_Access := new Buffer_Type; Header_Buffer : Buffer_Access := new Buffer_Type; Header_Space : constant Reservation := Reserve (Buffer_Out, GIOP_Header_Size); Reply_Status : Reply_Status_Type; N : Request_Note; Request_Id : Types.Unsigned_Long renames N.Id; CORBA_Occurence : PolyORB.Any.Any; Data_Alignment : Alignment_Type := Sess.Implem.Data_Alignment; Success : Boolean; Static_Buffer : constant QoS_GIOP_Static_Buffer_Parameter_Access := QoS_GIOP_Static_Buffer_Parameter_Access (Extract_Request_Parameter (QoS.GIOP_Static_Buffer, Request.all)); begin Get_Note (Request.Notepad, N); pragma Debug (C, O ("Process reply of request id =" & Request_Id'Img)); -- Remove request from list of pending server-side (abortable) requests Sess.Remove_Pending_Request (Request_Id, Success); if not Success and then not Recovery then -- A missing request upon first attempt means the client cancelled -- it: nothing to do (discard reply). On second attempt (Recovery -- case), however, the request is always missing from the pending -- list because it has been found, and removed, during the first -- attempt. return; end if; if PolyORB.Any.Is_Empty (Request.Exception_Info) then Reply_Status := No_Exception; pragma Debug (C, O ("Sending reply, Status: " & Reply_Status'Img)); else if Get_Type (Request.Exception_Info) = TC_ForwardRequest then Reply_Status := Location_Forward; pragma Debug (C, O ("Sending reply, Status: " & Reply_Status'Img)); elsif Get_Type (Request.Exception_Info) = TC_ForwardRequestPerm then Reply_Status := Location_Forward_Perm; pragma Debug (C, O ("Sending reply, Status: " & Reply_Status'Img)); elsif Get_Type (Request.Exception_Info) = TC_NeedsAddressingMode then Reply_Status := Needs_Addressing_Mode; pragma Debug (C, O ("Sending reply, Status: " & Reply_Status'Img)); else declare Exception_Id : constant String := To_Standard_String (TypeCode.Id (Get_Type (Request.Exception_Info))); begin if PolyORB.GIOP_P.Exceptions.Is_System_Exception (Exception_Id) then Reply_Status := System_Exception; else Reply_Status := User_Exception; end if; pragma Debug (C, O ("Sending reply, Status: " & Reply_Status'Img)); pragma Debug (C, O ("Exception ID: " & Exception_Id)); end; end if; end if; -- Set parameter for header request marshalling MCtx.Request_Id := Request_Id; MCtx.Reply_Status := Reply_Status; -- Marshall reply header Marshall_GIOP_Header_Reply (Sess.Implem, Sess, Request, MCtx, Buffer_Out); case Reply_Status is when User_Exception | System_Exception => if Reply_Status = System_Exception then CORBA_Occurence := PolyORB.GIOP_P.Exceptions.To_CORBA_Exception (Request.Exception_Info); -- It is a system exception: we translate it to a GIOP -- specific exception occurence else CORBA_Occurence := Request.Exception_Info; -- It is a user exception, nothing is done. end if; Pad_Align (Buffer_Out, Sess.Implem.Data_Alignment); Marshall (Buffer_Out, Any.TypeCode.Id (Any.Get_Type (CORBA_Occurence))); Marshall_From_Any (Sess.Repr, Buffer_Out, Get_Container (CORBA_Occurence).all, Error); if Found (Error) then Replace_Marshal_5_To_Bad_Param_23 (Error, Completed_Yes); -- An error in the marshalling of wchar data implies -- the server did not provide a valid codeset service -- context. We convert this exception to Bad_Param 23. Release (Header_Buffer); Release (Buffer_Out); return; end if; when No_Exception => if Static_Buffer = null then pragma Debug (C, O ("Using Any to send reply data")); if TypeCode.Kind (Get_Type (Request.Result.Argument)) /= Tk_Void then Pad_Align (Buffer_Out, Data_Alignment); Data_Alignment := Align_1; end if; Marshall_From_Any (Sess.Repr, Buffer_Out, Get_Container (Request.Result.Argument).all, Error); if Found (Error) then -- An error in the marshalling of wchar data implies -- the server did not provide a valid codeset service -- context. We convert this exception to Bad_Param 23. Replace_Marshal_5_To_Bad_Param_23 (Error, Completed_Yes); -- The error was encountered while marshalling a reply -- with a No_Exception status: we know that the servant -- executed the request succesfully. if Error.Member.all in System_Exception_Members then System_Exception_Members (Error.Member.all).Completed := Completed_Yes; end if; Release (Header_Buffer); Release (Buffer_Out); return; end if; Marshall_Argument_List (Sess.Implem, Buffer_Out, Sess.Repr, Request.Args, PolyORB.Any.ARG_OUT, Data_Alignment, Error); if Found (Error) then Replace_Marshal_5_To_Bad_Param_23 (Error, Completed_Yes); -- An error in the marshalling of wchar data implies -- the server did not provide a valid codeset service -- context. We convert this exception to Bad_Param 23. Release (Header_Buffer); Release (Buffer_Out); return; end if; else if Length (Static_Buffer.Buffer.all) /= 0 then pragma Debug (C, O ("Using buffer to send reply data")); -- The arguments were marshalled and stored in the -- request QoS attribute. We insert the data -- contained in the request QoS in the buffer. Pad_Align (Buffer_Out, Data_Alignment); declare Data : PolyORB.Opaque.Opaque_Pointer; Data_To_Process : Stream_Element_Count := Length (Static_Buffer.Buffer.all); Data_Processed : Stream_Element_Count := Data_To_Process; Position : Ada.Streams.Stream_Element_Offset := 0; begin while Data_To_Process > 0 loop PolyORB.Buffers.Partial_Extract_Data (Static_Buffer.Buffer, Data, Data_Processed, Use_Current => False, At_Position => Position, Partial => True); Insert_Raw_Data (Buffer_Out, Data_Processed, Data); Data_To_Process := Data_To_Process - Data_Processed; Position := Position + Data_Processed; end loop; end; end if; end if; when Location_Forward => declare Member : constant ForwardRequest_Members := From_Any (Request.Exception_Info); Ref : References.Ref; begin References.Set (Ref, Smart_Pointers.Entity_Of (Member.Forward_Reference)); Pad_Align (Buffer_Out, Sess.Implem.Data_Alignment); Marshall (Buffer_Out, Ref); end; when Location_Forward_Perm => pragma Assert (Sess.Implem.Version = GIOP_V1_2); declare Member : constant ForwardRequestPerm_Members := From_Any (Request.Exception_Info); Ref : References.Ref; begin References.Set (Ref, Smart_Pointers.Entity_Of (Member.Forward_Reference)); Pad_Align (Buffer_Out, Sess.Implem.Data_Alignment); Marshall (Buffer_Out, Ref); end; when Needs_Addressing_Mode => pragma Assert (Sess.Implem.Version = GIOP_V1_2); declare Member : constant NeedsAddressingMode_Members := From_Any (Request.Exception_Info); Mode : Short; begin case Member.Mode is when Key => Mode := 0; when Profile => Mode := 1; when Reference => Mode := 2; end case; Pad_Align (Buffer_Out, Sess.Implem.Data_Alignment); Marshall (Buffer_Out, Mode); end; end case; -- Marshall Header MCtx.Message_Size := Types.Unsigned_Long (Length (Buffer_Out.all) - GIOP_Header_Size); Marshall_Global_GIOP_Header (Sess, MCtx, Header_Buffer); -- Copy Header Copy_Data (Header_Buffer.all, Header_Space); Release (Header_Buffer); -- Emit reply Emit_Message (Sess.Implem, Sess, MCtx, Buffer_Out, Error); Release (Buffer_Out); pragma Debug (C, O ("Reply sent")); end Common_Send_Reply; ------------------------- -- Common_Locate_Reply -- ------------------------- procedure Common_Locate_Reply (Sess : access GIOP_Session; MCtx : access GIOP_Message_Context'Class; Loc_Type : Locate_Reply_Type; Forward_Ref : References.Ref; Error : in out Errors.Error_Container) is use PolyORB.Components; Buffer : Buffer_Access := new Buffer_Type; Header_Buffer : Buffer_Access := new Buffer_Type; Header_Space : constant Reservation := Reserve (Buffer, GIOP_Header_Size); begin pragma Debug (C, O ("Sending Locate Reply, Request Id :" & MCtx.Request_Id'Img & " , type: " & Loc_Type'Img)); Marshall (Buffer, MCtx.Request_Id); Marshall (Buffer, Loc_Type); if Loc_Type = Object_Forward then References.IOR.Marshall_IOR (Buffer, Forward_Ref); end if; MCtx.Message_Size := Types.Unsigned_Long (Length (Buffer.all) - GIOP_Header_Size); Marshall_Global_GIOP_Header (Sess, MCtx, Header_Buffer); -- Copy Header Copy_Data (Header_Buffer.all, Header_Space); Release (Header_Buffer); Emit_Message (Sess.Implem, Sess, MCtx, Buffer, Error); Release (Buffer); end Common_Locate_Reply; ----------------------------------- -- Common_Process_Cancel_Request -- ----------------------------------- procedure Common_Process_Cancel_Request (Sess : access GIOP_Session; Request_Id : Types.Unsigned_Long) is use Components; Pending_Req : Pending_Request; Success : Boolean; begin pragma Debug (C, O ("Cancel_Request received, Request_Id:" & Request_Id'Img)); Sess.Mutex.Enter; Sess.Get_Pending_Request (Id => Request_Id, Req => Pending_Req, Success => Success); -- Note: abortion must be done while still holding the Sess mutex, -- to ensure that the request does not disappear under our feet because -- it has completed. if Success and then Pending_Req.Req.Surrogate /= null then Emit_No_Reply (Pending_Req.Req.Surrogate, Servants.Iface.Abort_Request'(Req => Pending_Req.Req)); end if; Sess.Mutex.Leave; Expect_GIOP_Header (Sess); end Common_Process_Cancel_Request; --------------------------------- -- Common_Process_Locate_Reply -- --------------------------------- procedure Common_Process_Locate_Reply (Sess : access GIOP_Session; Locate_Request_Id : Types.Unsigned_Long; Loc_Type : Locate_Reply_Type) is use type PolyORB.Utils.Strings.String_Ptr; ORB : constant PolyORB.ORB.ORB_Access := PolyORB.ORB.ORB_Access (Sess.Server); begin pragma Debug (C, O ("Locate_Reply received, Request Id:" & Locate_Request_Id'Img & " , type: " & Loc_Type'Img)); case Loc_Type is when Object_Here | Unknown_Object => declare use PolyORB.Errors; Req : Pending_Request_Access; Success : Boolean; Error : Errors.Error_Container; begin Get_Pending_Request_By_Locate (Sess, Locate_Request_Id, Req, Success, Remove => False); if not Success then raise GIOP_Error; end if; if Loc_Type /= Object_Here then -- The object was no found, propagate error. Throw (Error, Object_Not_Exist_E, System_Exception_Members'( Minor => 1, Completed => Completed_No)); elsif not PolyORB.References.Is_Nil (Req.Req.Target) then -- The request has a non-null target, finish the -- processing of the locate_reply message and send -- the request. Send_Request (Sess.Implem, Sess, Req, Error); else -- Null target, no error, finish processing of the -- locate_reply message. PolyORB.Requests.Destroy_Request (Req.Req); Remove_Pending_Request_By_Locate (Sess, Locate_Request_Id, Success); end if; if Found (Error) then Set_Exception (Req.Req.all, Error); Catch (Error); Expect_GIOP_Header (Sess); Components.Emit_No_Reply (Components.Component_Access (ORB), Servants.Iface.Executed_Request'(Req => Req.Req)); Remove_Pending_Request_By_Locate (Sess, Locate_Request_Id, Success); if not Success then raise GIOP_Error; end if; else Expect_GIOP_Header (Sess); end if; end; when Object_Forward => declare Req : Pending_Request_Access; Success : Boolean; begin Get_Pending_Request_By_Locate (Sess, Locate_Request_Id, Req, Success, Remove => False); if not Success then raise GIOP_Error; end if; declare Ref : constant References.Ref := Unmarshall (Sess.Buffer_In); begin Req.Req.Exception_Info := PolyORB.Errors.Helper.To_Any (PolyORB.Errors.ForwardRequest_Members' (Forward_Reference => Smart_Pointers.Ref (Ref))); end; Expect_GIOP_Header (Sess); Components.Emit_No_Reply (Components.Component_Access (ORB), Servants.Iface.Executed_Request' (Req => Req.Req)); Remove_Pending_Request_By_Locate (Sess, Locate_Request_Id, Success); if not Success then raise GIOP_Error; end if; end; when Object_Forward_Perm => declare Req : Pending_Request_Access; Success : Boolean; begin Get_Pending_Request_By_Locate (Sess, Locate_Request_Id, Req, Success, Remove => False); if not Success then raise GIOP_Error; end if; declare Ref : constant References.Ref := Unmarshall (Sess.Buffer_In); begin Req.Req.Exception_Info := PolyORB.Errors.Helper.To_Any (PolyORB.Errors.ForwardRequestPerm_Members' (Forward_Reference => Smart_Pointers.Ref (Ref))); end; Expect_GIOP_Header (Sess); Components.Emit_No_Reply (Components.Component_Access (ORB), Servants.Iface.Executed_Request' (Req => Req.Req)); Remove_Pending_Request_By_Locate (Sess, Locate_Request_Id, Success); if not Success then raise GIOP_Error; end if; end; when others => raise GIOP_Error; end case; end Common_Process_Locate_Reply; -------------------------------- -- Common_Send_Cancel_Request -- -------------------------------- procedure Common_Send_Cancel_Request (Sess : access GIOP_Session; R : Request_Access; MCtx : access GIOP_Message_Context'Class; Error : in out Errors.Error_Container) is use PolyORB.Annotations; Current_Req : Pending_Request; Current_Note : Request_Note; Buffer : Buffer_Access; Success : Boolean; begin Get_Note (R.Notepad, Current_Note); Sess.Mutex.Enter; Get_Pending_Request (Sess, Current_Note.Id, Current_Req, Success); Sess.Mutex.Leave; if not Success then raise GIOP_Error; end if; Buffer := new Buffer_Type; MCtx.Message_Size := Types.Unsigned_Long'Size / Types.Octet'Size; Marshall_Global_GIOP_Header (Sess, MCtx, Buffer); Marshall (Buffer, Current_Req.Request_Id); -- Sending the message Emit_Message (Sess.Implem, Sess, MCtx.all'Access, Buffer, Error); Release (Buffer); end Common_Send_Cancel_Request; --------------------------- -- Common_Reply_Received -- --------------------------- procedure Common_Reply_Received (Sess : access GIOP_Session; Request_Id : Types.Unsigned_Long; Reply_Status : Reply_Status_Type; Service_Contexts : QoS_GIOP_Service_Contexts_Parameter_Access) is use PolyORB.Any; use PolyORB.Components; use PolyORB.Errors; use PolyORB.ORB; Current_Req : Pending_Request; Success : Boolean; ORB : constant ORB_Access := ORB_Access (Sess.Server); Arguments_Alignment : Buffers.Alignment_Type := Sess.Implem.Data_Alignment; Error : Errors.Error_Container; Static_Buffer : QoS_GIOP_Static_Buffer_Parameter_Access; begin pragma Debug (C, O ("Reply received: status = " & Reply_Status_Type'Image (Reply_Status) & ", id =" & Types.Unsigned_Long'Image (Request_Id))); Sess.Mutex.Enter; Get_Pending_Request (Sess, Request_Id, Current_Req, Success); Sess.Mutex.Leave; if not Success then -- The request for this reply has been cancelled: just discard the -- message. Expect_GIOP_Header (Sess); return; end if; Static_Buffer := QoS_GIOP_Static_Buffer_Parameter_Access (Extract_Request_Parameter (QoS.GIOP_Static_Buffer, Current_Req.Req.all)); Add_Reply_QoS (Current_Req.Req.all, GIOP_Service_Contexts, QoS_Parameter_Access (Service_Contexts)); Rebuild_Reply_QoS_Parameters (Current_Req.Req.all); case Reply_Status is when No_Exception => -- Unmarshall reply body if Static_Buffer = null then pragma Debug (C, O ("Use Anys")); if TypeCode.Kind (Get_Type (Current_Req.Req.Result.Argument)) /= Tk_Void then Align_Position (Sess.Buffer_In, Arguments_Alignment); Arguments_Alignment := Align_1; end if; Unmarshall_To_Any (Sess.Repr, Sess.Buffer_In, Get_Container (Current_Req.Req.Result.Argument).all, Error); if Found (Error) then Replace_Marshal_5_To_Inv_Objref_2 (Error, Completed_Yes); -- An error in the marshalling of wchar data implies -- the server did not provide a valid codeset -- component. We convert this exception to Inv_ObjRef 2. Set_Exception (Current_Req.Req.all, Error); Catch (Error); else Unmarshall_Argument_List (Sess.Implem, Sess.Buffer_In, Sess.Repr, Current_Req.Req.Args, PolyORB.Any.ARG_OUT, Arguments_Alignment, Error); if Found (Error) then Replace_Marshal_5_To_Inv_Objref_2 (Error, Completed_Yes); -- An error in the marshalling of wchar data implies -- the server did not provide a valid codeset -- component. We convert this exception to Inv_ObjRef 2. Set_Exception (Current_Req.Req.all, Error); Catch (Error); end if; end if; else pragma Debug (C, O ("Use static buffer")); declare Buffer : Buffer_Access; begin Buffer := Sess.Buffer_In; Sess.Buffer_In := Static_Buffer.Buffer; Static_Buffer.Buffer := Buffer; Release_Contents (Sess.Buffer_In.all); end; end if; Expect_GIOP_Header (Sess); Emit_No_Reply (Current_Req.Req.Requesting_Component, Servants.Iface.Executed_Request' (Req => Current_Req.Req)); when System_Exception => Align_Position (Sess.Buffer_In, Sess.Implem.Data_Alignment); Unmarshall_System_Exception_To_Any (Sess.Buffer_In, Sess.Repr, Current_Req.Req.Exception_Info); Expect_GIOP_Header (Sess); Emit_No_Reply (Component_Access (ORB), Servants.Iface.Executed_Request' (Req => Current_Req.Req)); when User_Exception => Align_Position (Sess.Buffer_In, Sess.Implem.Data_Alignment); declare RepositoryId : constant PolyORB.Types.RepositoryId := Unmarshall (Sess.Buffer_In); Except_Index : constant PolyORB.Types.Unsigned_Long := Any.ExceptionList.Search_Exception_Id (Current_Req.Req.Exc_List, Types.String (RepositoryId)); begin pragma Debug (C, O ("Exception repository ID:" & To_Standard_String (RepositoryId))); if Except_Index = 0 then declare -- Received an unexpected exception: we'll -- have to conjure up a minimal exception -- TypeCode to get at least the repo. ID -- right. Note that we cannot map exceptions -- that are not in Exc_List to 'unknown', -- because the applicative personality above -- us may be able to do something with an -- unknown exception. -- Actually we could be more clever here -- and ask the ORB to provide a TypeCode -- (maybe by querying an application -- personality or interface repository -- for information about this repository ID), -- which would even allow us to unmarshall -- the valuation of an unknown exception. Exception_Name : constant String := Exceptions.Exception_Name (To_Standard_String (RepositoryId)); Slash, Next_Slash : Integer; TC : constant Any.TypeCode.Local_Ref := TypeCode.TC_Except; begin Slash := Exception_Name'First - 1; loop Next_Slash := Utils.Find (Exception_Name, Slash + 1, '/'); exit when Next_Slash > Exception_Name'Last; pragma Assert (Next_Slash > Slash); Slash := Next_Slash; end loop; if Slash = Exception_Name'First - 1 then Slash := Slash + 1; end if; TypeCode.Add_Parameter (TC, To_Any (To_PolyORB_String (Exception_Name (Slash .. Exception_Name'Last)))); TypeCode.Add_Parameter (TC, To_Any (Types.String (RepositoryId))); Current_Req.Req.Exception_Info := PolyORB.Any.Get_Empty_Any_Aggregate (TC); end; else Current_Req.Req.Exception_Info := PolyORB.Any.Get_Empty_Any (Any.ExceptionList.Item (Current_Req.Req.Exc_List, Except_Index)); Unmarshall_To_Any (Sess.Repr, Sess.Buffer_In, Get_Container (Current_Req.Req.Exception_Info).all, Error); if Found (Error) then Replace_Marshal_5_To_Inv_Objref_2 (Error, Completed_Yes); -- An error in the marshalling of wchar data implies -- the server did not provide a valid codeset -- component. We convert this exception to Inv_ObjRef 2. Set_Exception (Current_Req.Req.all, Error); Catch (Error); end if; pragma Debug (C, O ("Exception: " & Any.Image (Current_Req.Req.Exception_Info))); end if; Expect_GIOP_Header (Sess); Emit_No_Reply (Component_Access (ORB), Servants.Iface.Executed_Request' (Req => Current_Req.Req)); end; when Location_Forward => Align_Position (Sess.Buffer_In, Sess.Implem.Data_Alignment); declare Ref : constant References.Ref := Unmarshall (Sess.Buffer_In); begin Current_Req.Req.Exception_Info := PolyORB.Errors.Helper.To_Any (PolyORB.Errors.ForwardRequest_Members' (Forward_Reference => Smart_Pointers.Ref (Ref))); end; Expect_GIOP_Header (Sess); Emit_No_Reply (Component_Access (ORB), Servants.Iface.Executed_Request' (Req => Current_Req.Req)); when Location_Forward_Perm => Align_Position (Sess.Buffer_In, Sess.Implem.Data_Alignment); declare Ref : constant References.Ref := Unmarshall (Sess.Buffer_In); begin Current_Req.Req.Exception_Info := PolyORB.Errors.Helper.To_Any (PolyORB.Errors.ForwardRequestPerm_Members' (Forward_Reference => Smart_Pointers.Ref (Ref))); end; Expect_GIOP_Header (Sess); Emit_No_Reply (Component_Access (ORB), Servants.Iface.Executed_Request' (Req => Current_Req.Req)); when Needs_Addressing_Mode => Align_Position (Sess.Buffer_In, Sess.Implem.Data_Alignment); declare Mode : constant Types.Short := Unmarshall (Sess.Buffer_In); Members : PolyORB.Errors.NeedsAddressingMode_Members; begin case Mode is when 0 => Members.Mode := Key; when 1 => Members.Mode := Profile; when 2 => Members.Mode := Reference; when others => raise Program_Error; end case; Current_Req.Req.Exception_Info := PolyORB.Errors.Helper.To_Any (Members); end; Expect_GIOP_Header (Sess); Emit_No_Reply (Component_Access (ORB), Servants.Iface.Executed_Request' (Req => Current_Req.Req)); end case; end Common_Reply_Received; ---------- -- Copy -- ---------- procedure Copy (Buf_In : PolyORB.Buffers.Buffer_Access; Buf_Out : PolyORB.Buffers.Buffer_Access; Count : Types.Unsigned_Long) is Temp : Types.Octet; begin for K in 1 .. Count loop Temp := Unmarshall (Buf_In); Marshall (Buf_Out, Temp); end loop; end Copy; --------------------------------------- -- Replace_Marshal_5_To_Bad_Param_23 -- --------------------------------------- procedure Replace_Marshal_5_To_Bad_Param_23 (Error : in out Errors.Error_Container; Status : Errors.Completion_Status) is use PolyORB.Errors; begin if Error.Kind = Marshal_E and then System_Exception_Members'Class (Error.Member.all).Minor = 5 then Error.Kind := Bad_Param_E; System_Exception_Members'Class (Error.Member.all).Minor := 23; System_Exception_Members'Class (Error.Member.all).Completed := Status; end if; end Replace_Marshal_5_To_Bad_Param_23; --------------------------------------- -- Replace_Marshal_5_To_Inv_Objref_2 -- --------------------------------------- procedure Replace_Marshal_5_To_Inv_Objref_2 (Error : in out Errors.Error_Container; Status : Errors.Completion_Status) is use PolyORB.Errors; begin if Error.Kind = Marshal_E and then System_Exception_Members'Class (Error.Member.all).Minor = 5 then Error.Kind := Inv_Objref_E; System_Exception_Members'Class (Error.Member.all).Minor := 2; System_Exception_Members'Class (Error.Member.all).Completed := Status; end if; end Replace_Marshal_5_To_Inv_Objref_2; end PolyORB.Protocols.GIOP.Common; polyorb-2.8~20110207.orig/src/giop/polyorb-giop_p-code_sets-converters-unicode.ads0000644000175000017500000000611511750740340027346 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- POLYORB.GIOP_P.CODE_SETS.CONVERTERS.UNICODE -- -- -- -- S p e c -- -- -- -- Copyright (C) 2006-2009, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- This package provides character data code sets converters for Unicode -- encodings: UTF-8 for char data and UTF-16 for wchar data. -- Note: Client application which use these encodings should be ready to deal -- with multibyte character sequences and avoid use of char IDL type (use -- string instead). -- Supported char native code sets: -- 0x05010001 X/Open UTF-8; UCS Transformation Format 8 (UTF-8) -- -- Supported char conversion code sets: -- not provided -- -- Supported wchar native code sets: -- 0x00010109 UTF-16, UCS Transformation Format 16-bit form -- -- Supported wchar conversion code sets: -- 0x00010100 ISO/IEC 10646-1:1993; UCS-2, Level 1 -- 0x00010101 ISO/IEC 10646-1:1993; UCS-2, Level 2 -- 0x00010102 ISO/IEC 10646-1:1993; UCS-2, Level 3 -- 0x00010104 ISO/IEC 10646-1:1993; UCS-4, Level 1 -- 0x00010105 ISO/IEC 10646-1:1993; UCS-4, Level 2 -- 0x00010106 ISO/IEC 10646-1:1993; UCS-4, Level 3 package PolyORB.GIOP_P.Code_Sets.Converters.Unicode is pragma Elaborate_Body; end PolyORB.GIOP_P.Code_Sets.Converters.Unicode; polyorb-2.8~20110207.orig/src/giop/polyorb-representations-cdr-giop_1_0.adb0000644000175000017500000001547511750740340025665 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- POLYORB.REPRESENTATIONS.CDR.GIOP_1_0 -- -- -- -- B o d y -- -- -- -- Copyright (C) 2004-2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with PolyORB.Initialization; with PolyORB.Representations.CDR.Common; with PolyORB.Utils.Strings; package body PolyORB.Representations.CDR.GIOP_1_0 is use PolyORB.Errors; use PolyORB.Representations.CDR.Common; function Create return CDR_Representation_Access; procedure Deferred_Initialization; ------------ -- Create -- ------------ function Create return CDR_Representation_Access is begin return new GIOP_1_0_CDR_Representation; end Create; ----------------------------- -- Deferred_Initialization -- ----------------------------- procedure Deferred_Initialization is begin Register_Factory (1, 0, Create'Access); end Deferred_Initialization; -------------- -- Marshall -- -------------- procedure Marshall (R : GIOP_1_0_CDR_Representation; Buffer : access Buffers.Buffer_Type; Data : PolyORB.Types.Char; Error : in out Errors.Error_Container) is pragma Unreferenced (R); pragma Unreferenced (Error); begin Marshall_Latin_1_Char (Buffer, Data); end Marshall; -------------- -- Marshall -- -------------- procedure Marshall (R : GIOP_1_0_CDR_Representation; Buffer : access Buffers.Buffer_Type; Data : PolyORB.Types.String; Error : in out Errors.Error_Container) is pragma Unreferenced (R); pragma Unreferenced (Error); begin Marshall_Latin_1_String (Buffer, Data); end Marshall; -------------- -- Marshall -- -------------- procedure Marshall (R : GIOP_1_0_CDR_Representation; Buffer : access Buffers.Buffer_Type; Data : PolyORB.Types.Wchar; Error : in out Errors.Error_Container) is pragma Unreferenced (R); pragma Unreferenced (Buffer); pragma Unreferenced (Data); begin Throw (Error, Marshal_E, System_Exception_Members'(5, Completed_No)); end Marshall; -------------- -- Marshall -- -------------- procedure Marshall (R : GIOP_1_0_CDR_Representation; Buffer : access Buffers.Buffer_Type; Data : PolyORB.Types.Wide_String; Error : in out Errors.Error_Container) is pragma Unreferenced (R); pragma Unreferenced (Buffer); pragma Unreferenced (Data); begin Throw (Error, Marshal_E, System_Exception_Members'(5, Completed_No)); end Marshall; ---------------- -- Unmarshall -- ---------------- procedure Unmarshall (R : GIOP_1_0_CDR_Representation; Buffer : access Buffers.Buffer_Type; Data : out PolyORB.Types.Char; Error : in out Errors.Error_Container) is pragma Unreferenced (R); pragma Unreferenced (Error); begin Data := Unmarshall_Latin_1_Char (Buffer); end Unmarshall; ---------------- -- Unmarshall -- ---------------- procedure Unmarshall (R : GIOP_1_0_CDR_Representation; Buffer : access Buffers.Buffer_Type; Data : out PolyORB.Types.String; Error : in out Errors.Error_Container) is pragma Unreferenced (R); pragma Unreferenced (Error); begin Data := Unmarshall_Latin_1_String (Buffer); end Unmarshall; ---------------- -- Unmarshall -- ---------------- procedure Unmarshall (R : GIOP_1_0_CDR_Representation; Buffer : access Buffers.Buffer_Type; Data : out PolyORB.Types.Wchar; Error : in out Errors.Error_Container) is pragma Unreferenced (R); pragma Unreferenced (Buffer); pragma Unreferenced (Data); begin Throw (Error, Marshal_E, System_Exception_Members'(5, Completed_No)); -- XXX The minor code different for client and server end Unmarshall; ---------------- -- Unmarshall -- ---------------- procedure Unmarshall (R : GIOP_1_0_CDR_Representation; Buffer : access Buffers.Buffer_Type; Data : out PolyORB.Types.Wide_String; Error : in out Errors.Error_Container) is pragma Unreferenced (R); pragma Unreferenced (Buffer); pragma Unreferenced (Data); begin Throw (Error, Marshal_E, System_Exception_Members'(5, Completed_No)); -- XXX The minor code different for client and server end Unmarshall; begin declare use PolyORB.Initialization; use PolyORB.Initialization.String_Lists; use PolyORB.Utils.Strings; begin Register_Module (Module_Info' (Name => +"representations.cdr.giop_1_0", Conflicts => Empty, Depends => Empty, Provides => Empty, Implicit => False, Init => Deferred_Initialization'Access, Shutdown => null)); end; end PolyORB.Representations.CDR.GIOP_1_0; polyorb-2.8~20110207.orig/src/giop/polyorb-giop_p-tagged_components-code_sets.adb0000644000175000017500000001704211750740340027210 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- POLYORB.GIOP_P.TAGGED_COMPONENTS.CODE_SETS -- -- -- -- B o d y -- -- -- -- Copyright (C) 2004-2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with PolyORB.Initialization; with PolyORB.Representations.CDR.Common; with PolyORB.Utils.Strings; package body PolyORB.GIOP_P.Tagged_Components.Code_Sets is use PolyORB.Representations.CDR.Common; use PolyORB.GIOP_P.Code_Sets; function Create_Empty_Component return Tagged_Component_Access; function Fetch_Component (Oid : access PolyORB.Objects.Object_Id) return Tagged_Component_Access; procedure Marshall (Buffer : access Buffer_Type; Data : Code_Set_Component); function Unmarshall (Buffer : access Buffer_Type) return Code_Set_Component; ---------------------------- -- Create_Empty_Component -- ---------------------------- function Create_Empty_Component return Tagged_Component_Access is begin return new TC_Code_Sets; end Create_Empty_Component; --------------- -- Duplicate -- --------------- function Duplicate (C : TC_Code_Sets) return Tagged_Component_Access is Result : constant Tagged_Component_Access := new TC_Code_Sets; begin TC_Code_Sets (Result.all).For_Char_Data := (C.For_Char_Data.Native_Code_Set, Duplicate (C.For_Char_Data.Conversion_Code_Sets)); TC_Code_Sets (Result.all).For_Wchar_Data := (C.For_Wchar_Data.Native_Code_Set, Duplicate (C.For_Wchar_Data.Conversion_Code_Sets)); return Result; end Duplicate; --------------------- -- Fetch_Component -- --------------------- function Fetch_Component (Oid : access PolyORB.Objects.Object_Id) return Tagged_Component_Access is pragma Unreferenced (Oid); Aux : TC_Code_Sets; begin Aux.For_Char_Data := (Native_Char_Code_Set, Duplicate (Conversion_Char_Code_Sets)); Aux.For_Wchar_Data := (Native_Wchar_Code_Set, Duplicate (Conversion_Wchar_Code_Sets)); return new TC_Code_Sets'(Aux); end Fetch_Component; ---------------------- -- Release_Contents -- ---------------------- procedure Release_Contents (C : access TC_Code_Sets) is begin Deallocate (C.For_Char_Data.Conversion_Code_Sets); Deallocate (C.For_Wchar_Data.Conversion_Code_Sets); end Release_Contents; -------------- -- Marshall -- -------------- procedure Marshall (Buffer : access Buffer_Type; Data : Code_Set_Component) is use Code_Set_Id_Lists; Iter : Code_Set_Id_Lists.Iterator; begin Marshall (Buffer, Types.Unsigned_Long (Data.Native_Code_Set)); Marshall (Buffer, Types.Unsigned_Long (Length (Data.Conversion_Code_Sets))); Iter := First (Data.Conversion_Code_Sets); while not Last (Iter) loop Marshall (Buffer, Types.Unsigned_Long (Value (Iter).all)); Next (Iter); end loop; end Marshall; ----------------------------- -- Marshall_Component_Data -- ----------------------------- procedure Marshall_Component_Data (C : access TC_Code_Sets; Buffer : access Buffer_Type) is Temp_Buf : Buffer_Access := new Buffer_Type; begin -- The body of a Tag_Policy component is an encapsulation Start_Encapsulation (Temp_Buf); Marshall (Temp_Buf, C.For_Char_Data); Marshall (Temp_Buf, C.For_Wchar_Data); Marshall (Buffer, Encapsulate (Temp_Buf)); Release (Temp_Buf); end Marshall_Component_Data; ---------------- -- Unmarshall -- ---------------- function Unmarshall (Buffer : access Buffer_Type) return Code_Set_Component is Result : Code_Set_Component; Length : Types.Unsigned_Long; begin Result.Native_Code_Set := Code_Set_Id (Types.Unsigned_Long'(Unmarshall (Buffer))); Length := Unmarshall (Buffer); for J in 1 .. Length loop Append (Result.Conversion_Code_Sets, Code_Set_Id (Types.Unsigned_Long'(Unmarshall (Buffer)))); end loop; return Result; end Unmarshall; ------------------------------- -- Unmarshall_Component_Data -- ------------------------------- procedure Unmarshall_Component_Data (C : access TC_Code_Sets; Buffer : access Buffer_Type; Error : out PolyORB.Errors.Error_Container) is use type Ada.Streams.Stream_Element_Offset; use PolyORB.Errors; Tag_Body : aliased Encapsulation := Unmarshall (Buffer); Temp_Buf : Buffer_Access := new Buffer_Type; begin Decapsulate (Tag_Body'Access, Temp_Buf); C.For_Char_Data := Unmarshall (Temp_Buf); C.For_Wchar_Data := Unmarshall (Temp_Buf); pragma Assert (Remaining (Temp_Buf) = 0); Release (Temp_Buf); exception when others => Release (Temp_Buf); Throw (Error, Bad_Param_E, System_Exception_Members'(10, Completed_No)); end Unmarshall_Component_Data; ---------------- -- Initialize -- ---------------- procedure Initialize; procedure Initialize is begin Register (Tag_Code_Sets, Create_Empty_Component'Access, Fetch_Component'Access); end Initialize; use PolyORB.Initialization; use PolyORB.Utils.Strings; begin Register_Module (Module_Info' (Name => +"tagged_components.code_sets", Conflicts => PolyORB.Initialization.String_Lists.Empty, Depends => PolyORB.Initialization.String_Lists.Empty, Provides => PolyORB.Initialization.String_Lists.Empty, Implicit => False, Init => Initialize'Access, Shutdown => null)); end PolyORB.GIOP_P.Tagged_Components.Code_Sets; polyorb-2.8~20110207.orig/src/giop/polyorb-binding_data-giop-inet.adb0000644000175000017500000002555011750740340024566 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . B I N D I N G _ D A T A . G I O P . I N E T -- -- -- -- B o d y -- -- -- -- Copyright (C) 2004-2008, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with Ada.Streams; with PolyORB.Log; with PolyORB.Representations.CDR.Common; with PolyORB.Sockets; with PolyORB.Types; package body PolyORB.Binding_Data.GIOP.INET is use Ada.Streams; use PolyORB.GIOP_P.Tagged_Components; use PolyORB.Buffers; use PolyORB.Log; use PolyORB.Objects; use PolyORB.Representations.CDR.Common; use PolyORB.Types; use PolyORB.Utils; use PolyORB.Utils.Sockets; package L is new PolyORB.Log.Facility_Log ("polyorb.binding_data.giop.common_sockets"); procedure O (Message : Standard.String; Level : Log_Level := Debug) renames L.Output; function C (Level : Log_Level := Debug) return Boolean renames L.Enabled; ------------------------------------------ -- Common_IIOP_DIOP_Corbaloc_To_Profile -- ------------------------------------------ function Common_IIOP_DIOP_Corbaloc_To_Profile (Str : String; Default_Major : Types.Octet; Default_Minor : Types.Octet; Profile : access Profile_Access) return Utils.Sockets.Socket_Name is TResult : GIOP_Profile_Type'Class renames GIOP_Profile_Type'Class (Profile.all.all); S : String renames Str; Index : Integer; Index2 : Integer; Host_First, Host_Last : Natural; -- Indices within S of start and end of host name Port : Sockets.Port_Type; Empty_Name : constant Socket_Name := "" + 0; -- Returned in error case begin pragma Debug (C, O ("Common_IIOP_DIOP_Corbaloc_To_Profile: enter")); -- Index is at start of iiop_addr -- Version present? Index := Find (S, S'First, '@'); if Index in S'First + 1 .. S'Last then Index2 := Find (S, S'First, '.'); if S'First < Index2 and then Index2 < Index then TResult.Version_Major := Octet'Value (S (S'First .. Index2 - 1)); TResult.Version_Minor := Octet'Value (S (Index2 + 1 .. Index - 1)); else Destroy_Profile (Profile.all); end if; Index := Index + 1; else TResult.Version_Major := Default_Major; TResult.Version_Minor := Default_Minor; Index := S'First; end if; -- Index at start of host declare Colon : constant Integer := Find (S, Index, ':'); Slash : constant Integer := Find (S, Index, '/'); begin if Colon < Slash then -- Port number is present Index2 := Colon - 1; else Index2 := Slash - 1; end if; if Index2 < Index then -- Empty host Destroy_Profile (Profile.all); return Empty_Name; end if; pragma Debug (C, O ("Address = " & S (Index .. Index2))); Host_First := Index; Host_Last := Index2; if Colon < Slash then if Colon + 1 < Slash then pragma Debug (C, O ("Port = " & S (Colon + 1 .. Slash - 1))); Port := PolyORB.Sockets.Port_Type'Value (S (Colon + 1 .. Slash - 1)); else -- Empty port Destroy_Profile (Profile.all); return Empty_Name; end if; else -- No port indication: default to IANA-reserved value Port := 2809; end if; Index := Slash + 1; end; if Index > S'Last then -- Empty key_string Destroy_Profile (Profile.all); return Empty_Name; end if; declare Oid_Str : constant String := URI_Decode (S (Index .. S'Last)); Oid : Object_Id (Stream_Element_Offset (Oid_Str'First) .. Stream_Element_Offset (Oid_Str'Last)); pragma Import (Ada, Oid); for Oid'Address use Oid_Str (Oid_Str'First)'Address; begin TResult.Object_Id := new Object_Id'(Oid); end; if TResult.Object_Id = null then Destroy_Profile (Profile.all); return Empty_Name; end if; pragma Debug (C, O ("Oid = " & Image (TResult.Object_Id.all))); TResult.Components := Null_Tagged_Component_List; pragma Debug (C, O ("Common_IIOP_DIOP_Corbaloc_To_Profile: leave")); return S (Host_First .. Host_Last) + Port; end Common_IIOP_DIOP_Corbaloc_To_Profile; ------------------------------------------ -- Common_IIOP_DIOP_Profile_To_Corbaloc -- ------------------------------------------ function Common_IIOP_DIOP_Profile_To_Corbaloc (Profile : Profile_Access; Address : Utils.Sockets.Socket_Name; Prefix : String) return String is use PolyORB.Sockets; GIOP_Profile : GIOP_Profile_Type'Class renames GIOP_Profile_Type'Class (Profile.all); Oid_Str : String (1 .. Profile.Object_Id'Length); pragma Import (Ada, Oid_Str); for Oid_Str'Address use Profile.Object_Id (Profile.Object_Id'First)'Address; begin pragma Debug (C, O ("Common_IIOP_DIOP_Profile_To_Corbaloc")); return Prefix & ":" & Trimmed_Image (Unsigned_Long_Long (GIOP_Profile.Version_Major)) & "." & Trimmed_Image (Unsigned_Long_Long (GIOP_Profile.Version_Minor)) & "@" & Image (Address) & "/" & URI_Encode (Oid_Str, Also_Escape => No_Escape); end Common_IIOP_DIOP_Profile_To_Corbaloc; ---------------------------------- -- Common_Marshall_Profile_Body -- ---------------------------------- procedure Common_Marshall_Profile_Body (Buffer : access Buffer_Type; Profile : Profile_Access; Sock : Socket_Name; Marshall_Object_Id : Boolean) is GIOP_Profile : GIOP_Profile_Type'Class renames GIOP_Profile_Type'Class (Profile.all); Profile_Body : Buffer_Access := new Buffer_Type; begin pragma Debug (C, O ("Common_Marshall_Profile_Body: enter")); -- A Profile Body is an encapsulation Start_Encapsulation (Profile_Body); -- Version Marshall (Profile_Body, GIOP_Profile.Version_Major); Marshall (Profile_Body, GIOP_Profile.Version_Minor); pragma Debug (C, O (" Version = " & GIOP_Profile.Version_Major'Img & "." & GIOP_Profile.Version_Minor'Img)); -- Marshalling of a Socket Marshall_Socket (Profile_Body, Sock); pragma Debug (C, O (" Address = " & Image (Sock))); -- Marshalling the object id if Marshall_Object_Id then Marshall (Profile_Body, Stream_Element_Array (GIOP_Profile.Object_Id.all)); end if; -- Marshalling the tagged components Marshall_Tagged_Component (Profile_Body, GIOP_Profile.Components); -- Marshalling the Profile_Body into IOR Marshall (Buffer, Encapsulate (Profile_Body)); Release (Profile_Body); pragma Debug (C, O ("Common_Marshall_Profile_Body: leave")); end Common_Marshall_Profile_Body; ------------------------------------ -- Common_Unmarshall_Profile_Body -- ------------------------------------ function Common_Unmarshall_Profile_Body (Buffer : access Buffer_Type; Profile : Profile_Access; Unmarshall_Object_Id : Boolean; Unmarshall_Tagged_Components : Boolean) return Utils.Sockets.Socket_Name is TResult : GIOP_Profile_Type'Class renames GIOP_Profile_Type'Class (Profile.all); Profile_Body : aliased Encapsulation := Unmarshall (Buffer); Profile_Buffer : Buffer_Access := new Buffers.Buffer_Type; begin pragma Debug (C, O ("Common_Unmarshall_Profile_Body: enter")); -- A Profile Body is an encapsulation Decapsulate (Profile_Body'Access, Profile_Buffer); TResult.Version_Major := Unmarshall (Profile_Buffer); TResult.Version_Minor := Unmarshall (Profile_Buffer); pragma Debug (C, O (" Version = " & TResult.Version_Major'Img & "." & TResult.Version_Minor'Img)); -- Unmarshalling the socket name declare Address : constant Socket_Name := Unmarshall_Socket (Profile_Buffer); begin pragma Debug (C, O (" Address = " & Image (Address))); -- Unmarshalling the object id if Unmarshall_Object_Id then declare Str : aliased constant Stream_Element_Array := Unmarshall (Profile_Buffer); begin TResult.Object_Id := new Object_Id'(Object_Id (Str)); end; end if; if TResult.Version_Minor /= 0 or else Unmarshall_Tagged_Components then TResult.Components := Unmarshall_Tagged_Component (Profile_Buffer); end if; Release (Profile_Buffer); pragma Debug (C, O ("Common_Unmarshall_Profile_body: leave")); return Address; end; end Common_Unmarshall_Profile_Body; end PolyORB.Binding_Data.GIOP.INET; polyorb-2.8~20110207.orig/src/giop/polyorb-giop_p-code_sets-converters-unicode.adb0000644000175000017500000006577311750740340027344 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- POLYORB.GIOP_P.CODE_SETS.CONVERTERS.UNICODE -- -- -- -- B o d y -- -- -- -- Copyright (C) 2006-2009, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with PolyORB.Initialization; with PolyORB.Parameters; with PolyORB.Representations.CDR.Common; with PolyORB.Utils.Strings; package body PolyORB.GIOP_P.Code_Sets.Converters.Unicode is use PolyORB.Buffers; use PolyORB.Errors; use PolyORB.Representations.CDR.Common; use PolyORB.Types; -- Special ranges of UTF-16 codes subtype Surrogate_Character is Wide_Character range Wide_Character'Val (16#D800#) .. Wide_Character'Val (16#DFFF#); subtype Invalid_Character is Wide_Character range Wide_Character'Val (16#FFFE#) .. Wide_Character'Val (16#FFFF#); subtype High_Surrogate_Character is Surrogate_Character range Wide_Character'Val (16#D800#) .. Wide_Character'Val (16#DBFF#); subtype Low_Surrogate_Character is Surrogate_Character range Wide_Character'Val (16#DC00#) .. Wide_Character'Val (16#DFFF#); High_Surrogate_Base : constant Types.Unsigned_Long := Wide_Character'Pos (High_Surrogate_Character'First); Low_Surrogate_Base : constant Types.Unsigned_Long := Wide_Character'Pos (Low_Surrogate_Character'First); -- UTF16 byte order mark BOM : constant Unsigned_Short := 16#FEFF#; Reverse_BOM : constant Unsigned_Short := 16#FFFE#; -- UTF-8 native converter type UTF8_Native_Converter is new Converter with null record; procedure Marshall (C : UTF8_Native_Converter; Buffer : access Buffers.Buffer_Type; Data : Types.Char; Error : in out Errors.Error_Container); procedure Marshall (C : UTF8_Native_Converter; Buffer : access Buffers.Buffer_Type; Data : Types.String; Error : in out Errors.Error_Container); procedure Unmarshall (C : UTF8_Native_Converter; Buffer : access Buffers.Buffer_Type; Data : out Types.Char; Error : in out Errors.Error_Container); procedure Unmarshall (C : UTF8_Native_Converter; Buffer : access Buffers.Buffer_Type; Data : out Types.String; Error : in out Errors.Error_Container); -- UTF-16 native converter type UTF16_Native_Wide_Converter is new Wide_Converter with null record; procedure Marshall (C : UTF16_Native_Wide_Converter; Buffer : access Buffers.Buffer_Type; Data : Types.Wchar; Error : in out Errors.Error_Container); procedure Marshall (C : UTF16_Native_Wide_Converter; Buffer : access Buffers.Buffer_Type; Data : Types.Wide_String; Error : in out Errors.Error_Container); procedure Unmarshall (C : UTF16_Native_Wide_Converter; Buffer : access Buffers.Buffer_Type; Data : out Types.Wchar; Error : in out Errors.Error_Container); procedure Unmarshall (C : UTF16_Native_Wide_Converter; Buffer : access Buffers.Buffer_Type; Data : out Types.Wide_String; Error : in out Errors.Error_Container); -- UTF-16 as UCS-2 converter type UTF16_UCS2_Wide_Converter is new Wide_Converter with null record; procedure Marshall (C : UTF16_UCS2_Wide_Converter; Buffer : access Buffers.Buffer_Type; Data : Types.Wchar; Error : in out Errors.Error_Container); procedure Marshall (C : UTF16_UCS2_Wide_Converter; Buffer : access Buffers.Buffer_Type; Data : Types.Wide_String; Error : in out Errors.Error_Container); procedure Unmarshall (C : UTF16_UCS2_Wide_Converter; Buffer : access Buffers.Buffer_Type; Data : out Types.Wchar; Error : in out Errors.Error_Container); procedure Unmarshall (C : UTF16_UCS2_Wide_Converter; Buffer : access Buffers.Buffer_Type; Data : out Types.Wide_String; Error : in out Errors.Error_Container); -- UTF-16 as UCS-4 converter type UTF16_UCS4_Wide_Converter is new Wide_Converter with null record; procedure Marshall (C : UTF16_UCS4_Wide_Converter; Buffer : access Buffers.Buffer_Type; Data : Types.Wchar; Error : in out Errors.Error_Container); procedure Marshall (C : UTF16_UCS4_Wide_Converter; Buffer : access Buffers.Buffer_Type; Data : Types.Wide_String; Error : in out Errors.Error_Container); procedure Unmarshall (C : UTF16_UCS4_Wide_Converter; Buffer : access Buffers.Buffer_Type; Data : out Types.Wchar; Error : in out Errors.Error_Container); procedure Unmarshall (C : UTF16_UCS4_Wide_Converter; Buffer : access Buffers.Buffer_Type; Data : out Types.Wide_String; Error : in out Errors.Error_Container); -- Converter factories function Create_UTF8_Native_Converter return Converter_Access; function Create_UTF16_Native_Converter return Wide_Converter_Access; function Create_UTF16_UCS2_Converter return Wide_Converter_Access; function Create_UTF16_UCS4_Converter return Wide_Converter_Access; procedure Initialize; ----------------------------------- -- Create_UTF16_Native_Converter -- ----------------------------------- function Create_UTF16_Native_Converter return Wide_Converter_Access is begin return new UTF16_Native_Wide_Converter; end Create_UTF16_Native_Converter; --------------------------------- -- Create_UTF16_UCS2_Converter -- --------------------------------- function Create_UTF16_UCS2_Converter return Wide_Converter_Access is begin return new UTF16_UCS2_Wide_Converter; end Create_UTF16_UCS2_Converter; --------------------------------- -- Create_UTF16_UCS4_Converter -- --------------------------------- function Create_UTF16_UCS4_Converter return Wide_Converter_Access is begin return new UTF16_UCS4_Wide_Converter; end Create_UTF16_UCS4_Converter; ---------------------------------- -- Create_UTF8_Native_Converter -- ---------------------------------- function Create_UTF8_Native_Converter return Converter_Access is begin return new UTF8_Native_Converter; end Create_UTF8_Native_Converter; ---------------- -- Initialize -- ---------------- procedure Initialize is use PolyORB.Parameters; -- The following parameters force the registration of additional -- "fallback" code sets for char and wchar data. This is useful for -- interoperation with ORB with broken char sets negotiation support. Char_Fallback : constant Boolean := Get_Conf ("giop", "giop.add_char_fallback_code_set", Default => False); Wide_Char_Fallback : constant Boolean := Get_Conf ("giop", "giop.add_wchar_fallback_code_set", Default => False); begin -- Register supported char code sets (UTF-8) Register_Native_Code_Set (UTF_8_Code_Set, Create_UTF8_Native_Converter'Access, Create_UTF8_Native_Converter'Access); if Char_Fallback then -- Fallback code sets (UTF-8) Register_Conversion_Code_Set (UTF_8_Code_Set, Char_Data_Fallback_Code_Set, Create_UTF8_Native_Converter'Access); end if; -- Register supported wchar code sets (UTF-16) Register_Native_Code_Set (UTF_16_Code_Set, Create_UTF16_Native_Converter'Access, Create_UTF16_Native_Converter'Access); Register_Conversion_Code_Set (UTF_16_Code_Set, UCS_2_Level_1_Code_Set, Create_UTF16_UCS2_Converter'Access); Register_Conversion_Code_Set (UTF_16_Code_Set, UCS_2_Level_2_Code_Set, Create_UTF16_UCS2_Converter'Access); Register_Conversion_Code_Set (UTF_16_Code_Set, UCS_2_Level_3_Code_Set, Create_UTF16_UCS2_Converter'Access); Register_Conversion_Code_Set (UTF_16_Code_Set, UCS_4_Level_1_Code_Set, Create_UTF16_UCS4_Converter'Access); Register_Conversion_Code_Set (UTF_16_Code_Set, UCS_4_Level_2_Code_Set, Create_UTF16_UCS4_Converter'Access); Register_Conversion_Code_Set (UTF_16_Code_Set, UCS_4_Level_3_Code_Set, Create_UTF16_UCS4_Converter'Access); if Wide_Char_Fallback then -- Fallback code sets (UTF-16) Register_Conversion_Code_Set (UTF_16_Code_Set, Wchar_Data_Fallback_Code_Set, Create_UTF16_Native_Converter'Access); end if; end Initialize; -------------- -- Marshall -- -------------- procedure Marshall (C : UTF16_Native_Wide_Converter; Buffer : access Buffers.Buffer_Type; Data : Types.Wchar; Error : in out Errors.Error_Container) is begin if Data in Surrogate_Character or else Data in Invalid_Character then Throw (Error, Data_Conversion_E, System_Exception_Members' (Minor => 1, Completed => Completed_No)); return; end if; if C.GIOP_1_2_Mode then Marshall (Buffer, Octet'(4)); Unaligned_Unsigned_Short.Marshall (Buffer, BOM); Unaligned_Unsigned_Short.Marshall (Buffer, Wchar'Pos (Data)); else Marshall (Buffer, Unsigned_Short (Wchar'Pos (Data))); end if; end Marshall; procedure Marshall (C : UTF16_Native_Wide_Converter; Buffer : access Buffers.Buffer_Type; Data : Types.Wide_String; Error : in out Errors.Error_Container) is Equiv : constant Wide_String := To_Wide_String (Data); begin if C.GIOP_1_2_Mode then Marshall (Buffer, Unsigned_Long (Equiv'Length + 1) * 2); Marshall (Buffer, BOM); else Marshall (Buffer, Unsigned_Long (Equiv'Length + 2)); Marshall (Buffer, BOM); end if; for J in Equiv'Range loop if Equiv (J) in Invalid_Character then Throw (Error, Data_Conversion_E, System_Exception_Members' (Minor => 1, Completed => Completed_No)); return; end if; Marshall (Buffer, Unsigned_Short'(Wide_Character'Pos (Equiv (J)))); end loop; if not C.GIOP_1_2_Mode then Marshall (Buffer, Unsigned_Short (0)); end if; end Marshall; procedure Marshall (C : UTF16_UCS2_Wide_Converter; Buffer : access Buffers.Buffer_Type; Data : Types.Wchar; Error : in out Errors.Error_Container) is begin if Data in Surrogate_Character or else Data in Invalid_Character then Throw (Error, Data_Conversion_E, System_Exception_Members' (Minor => 1, Completed => Completed_No)); return; end if; if C.GIOP_1_2_Mode then Marshall (Buffer, Types.Octet'(2)); Unaligned_Unsigned_Short.Marshall (Buffer, Unsigned_Short'(Wchar'Pos (Data))); else Marshall (Buffer, Unsigned_Short'(Wchar'Pos (Data))); end if; end Marshall; procedure Marshall (C : UTF16_UCS2_Wide_Converter; Buffer : access Buffers.Buffer_Type; Data : Types.Wide_String; Error : in out Errors.Error_Container) is Equiv : constant Wide_String := PolyORB.Types.To_Wide_String (Data); begin if C.GIOP_1_2_Mode then Marshall (Buffer, Unsigned_Long'(Equiv'Length * 2)); else Marshall (Buffer, Unsigned_Long'(Equiv'Length + 1)); end if; for J in Equiv'Range loop if Equiv (J) in Surrogate_Character or else Equiv (J) in Invalid_Character then Throw (Error, Data_Conversion_E, System_Exception_Members' (Minor => 1, Completed => Completed_No)); return; end if; Marshall (Buffer, Unsigned_Short'(Wide_Character'Pos (Equiv (J)))); end loop; if not C.GIOP_1_2_Mode then Marshall (Buffer, Unsigned_Short'(0)); end if; end Marshall; procedure Marshall (C : UTF16_UCS4_Wide_Converter; Buffer : access Buffers.Buffer_Type; Data : Types.Wchar; Error : in out Errors.Error_Container) is begin if Data in Surrogate_Character or else Data in Invalid_Character then Throw (Error, Data_Conversion_E, System_Exception_Members' (Minor => 1, Completed => Completed_No)); return; end if; if C.GIOP_1_2_Mode then Marshall (Buffer, Types.Octet'(4)); Unaligned_Unsigned_Long.Marshall (Buffer, Unsigned_Long'(Wchar'Pos (Data))); else Marshall (Buffer, Unsigned_Long (Wchar'Pos (Data))); end if; end Marshall; procedure Marshall (C : UTF16_UCS4_Wide_Converter; Buffer : access Buffers.Buffer_Type; Data : Types.Wide_String; Error : in out Errors.Error_Container) is Equiv : constant Wide_String := PolyORB.Types.To_Wide_String (Data); Space : constant Reservation := Reserve (Buffer, 4); J : Positive := Equiv'First; L : Natural := 0; begin while J <= Equiv'Last loop if Equiv (J) in High_Surrogate_Character then if J < Equiv'Last and then Equiv (J + 1) in Low_Surrogate_Character then Marshall (Buffer, Unsigned_Long ((Wide_Character'Pos (Equiv (J)) - High_Surrogate_Base) * 16#400# + (Wide_Character'Pos (Equiv (J + 1)) - Low_Surrogate_Base) + 16#10000#)); J := J + 2; L := L + 1; else Throw (Error, Data_Conversion_E, System_Exception_Members' (Minor => 1, Completed => Completed_No)); return; end if; elsif Equiv (J) in Invalid_Character then Throw (Error, Data_Conversion_E, System_Exception_Members' (Minor => 1, Completed => Completed_No)); return; else Marshall (Buffer, Unsigned_Long (Wide_Character'Pos (Equiv (J)))); J := J + 1; L := L + 1; end if; end loop; if not C.GIOP_1_2_Mode then Marshall (Buffer, Unsigned_Long'(0)); end if; declare Length_Buffer : Buffer_Access := new Buffer_Type; begin if C.GIOP_1_2_Mode then Marshall (Buffer, Unsigned_Long'(Unsigned_Long (L) * 4)); else Marshall (Buffer, Unsigned_Long'(Unsigned_Long (L) + 1)); end if; Copy_Data (Length_Buffer.all, Space); Release (Length_Buffer); end; end Marshall; procedure Marshall (C : UTF8_Native_Converter; Buffer : access Buffers.Buffer_Type; Data : Types.Char; Error : in out Errors.Error_Container) is pragma Unreferenced (C); begin if Character'Pos (Data) < 16#80# then Marshall (Buffer, Octet (Character'Pos (Data))); else Throw (Error, Data_Conversion_E, System_Exception_Members' (Minor => 1, Completed => Completed_No)); end if; end Marshall; procedure Marshall (C : UTF8_Native_Converter; Buffer : access Buffers.Buffer_Type; Data : Types.String; Error : in out Errors.Error_Container) is pragma Unreferenced (C); pragma Unreferenced (Error); begin Marshall_Latin_1_String (Buffer, Data); end Marshall; ---------------- -- Unmarshall -- ---------------- procedure Unmarshall (C : UTF16_Native_Wide_Converter; Buffer : access Buffers.Buffer_Type; Data : out Types.Wchar; Error : in out Errors.Error_Container) is Code : Unsigned_Short; begin if C.GIOP_1_2_Mode then declare Length : constant Octet := Unmarshall (Buffer); begin Code := Unaligned_Unsigned_Short.Unmarshall (Buffer); if Length = 2 then Data := Wchar'Val (Code); elsif Length = 4 then if Code = Reverse_BOM then raise Program_Error; -- XXX Value marshalled in reverse endian-ness elsif Code = BOM then Data := Wchar'Val (Unaligned_Unsigned_Short.Unmarshall (Buffer)); else raise Program_Error; end if; else raise Program_Error; end if; end; else Code := Unmarshall (Buffer); if Code = Reverse_BOM then raise Program_Error; -- XXX Value marshalled in reverse endian-ness elsif Code = BOM then Data := Wchar'Val (Unsigned_Short'(Unmarshall (Buffer))); else Data := Wchar'Val (Code); end if; end if; if Data in Surrogate_Character or else Data in Invalid_Character then Throw (Error, Data_Conversion_E, System_Exception_Members' (Minor => 1, Completed => Completed_No)); end if; end Unmarshall; procedure Unmarshall (C : UTF16_Native_Wide_Converter; Buffer : access Buffers.Buffer_Type; Data : out Types.Wide_String; Error : in out Errors.Error_Container) is Length : constant Unsigned_Long := Unmarshall (Buffer); Result : Standard.Wide_String (1 .. Integer (Length)); First : Positive; Last : Natural; Code : Unsigned_Short; begin if C.GIOP_1_2_Mode then if Length mod 2 = 1 then raise Program_Error; -- XXX Raise Marshall exception ? elsif Length = 0 then Data := To_PolyORB_Wide_String (Wide_String'("")); return; end if; Last := Natural (Length / 2); else Last := Natural (Length); end if; Code := Unmarshall (Buffer); if Code = Reverse_BOM then raise Program_Error; -- Value encoded in reverse endian-ness elsif Code = BOM then Last := Last - 1; First := Result'First; else Result (Result'First) := Wchar'Val (Code); First := Result'First + 1; end if; for J in First .. Last loop Result (J) := Wchar'Val (Unsigned_Short'(Unmarshall (Buffer))); if Result (J) in Invalid_Character then Throw (Error, Data_Conversion_E, System_Exception_Members' (Minor => 1, Completed => Completed_No)); end if; end loop; if not C.GIOP_1_2_Mode then Last := Last - 1; end if; Data := To_PolyORB_Wide_String (Result (Result'First .. Last)); end Unmarshall; procedure Unmarshall (C : UTF16_UCS2_Wide_Converter; Buffer : access Buffers.Buffer_Type; Data : out Types.Wchar; Error : in out Errors.Error_Container) is Length : Octet; begin if C.GIOP_1_2_Mode then Length := Unmarshall (Buffer); if Length /= 2 then raise Program_Error; -- XXX Raise Marshall exception ? else Data := Wchar'Val (Unaligned_Unsigned_Short.Unmarshall (Buffer)); end if; else Data := Wchar'Val (Unsigned_Short'(Unmarshall (Buffer))); end if; if Data in Surrogate_Character or else Data in Invalid_Character then Throw (Error, Data_Conversion_E, System_Exception_Members' (Minor => 1, Completed => Completed_No)); end if; end Unmarshall; procedure Unmarshall (C : UTF16_UCS2_Wide_Converter; Buffer : access Buffers.Buffer_Type; Data : out Types.Wide_String; Error : in out Errors.Error_Container) is Length : constant Unsigned_Long := Unmarshall (Buffer); Result : Standard.Wide_String (1 .. Integer (Length)); Last : Natural := Result'First - 1; begin if C.GIOP_1_2_Mode then if Length mod 2 = 1 then raise Program_Error; -- XXX Raise Marshall exception ? end if; Last := Natural (Length / 2); else Last := Natural (Length); end if; for J in Result'First .. Last loop Result (J) := Wchar'Val (Unsigned_Short'(Unmarshall (Buffer))); if Result (J) in Surrogate_Character or else Result (J) in Invalid_Character then Throw (Error, Data_Conversion_E, System_Exception_Members' (Minor => 1, Completed => Completed_No)); end if; end loop; if not C.GIOP_1_2_Mode then Last := Last - 1; end if; Data := To_PolyORB_Wide_String (Result (Result'First .. Last)); end Unmarshall; procedure Unmarshall (C : UTF16_UCS4_Wide_Converter; Buffer : access Buffers.Buffer_Type; Data : out Types.Wchar; Error : in out Errors.Error_Container) is Length : Octet; Aux : Unsigned_Long; begin if C.GIOP_1_2_Mode then Length := Unmarshall (Buffer); if Length /= 4 then raise Program_Error; -- XXX Raise Marshall exception ? else Aux := Unaligned_Unsigned_Long.Unmarshall (Buffer); end if; else Aux := Unsigned_Long'(Unmarshall (Buffer)); end if; if Aux > 16#FFFF# or else Wchar'Val (Aux) in Surrogate_Character or else Wchar'Val (Aux) in Invalid_Character then Throw (Error, Data_Conversion_E, System_Exception_Members' (Minor => 1, Completed => Completed_No)); else Data := Wchar'Val (Aux); end if; end Unmarshall; procedure Unmarshall (C : UTF16_UCS4_Wide_Converter; Buffer : access Buffers.Buffer_Type; Data : out Types.Wide_String; Error : in out Errors.Error_Container) is pragma Unreferenced (Error); Length : Unsigned_Long := Unmarshall (Buffer); begin if C.GIOP_1_2_Mode then if Length mod 4 /= 0 then raise Program_Error; -- XXX Raise Marshall exception ? end if; Length := Length / 4; end if; declare Result : Standard.Wide_String (1 .. Integer (Length) * 2); Last : Natural := Result'First - 1; Aux : Unsigned_Long; begin for J in 1 .. Length loop Aux := Unsigned_Long'(Unmarshall (Buffer)); if Aux <= 16#FFFF# then Last := Last + 1; Result (Last) := Wchar'Val (Aux); else Last := Last + 1; Result (Last) := Wide_Character'Val (Aux / 16#400# + High_Surrogate_Base); Last := Last + 1; Result (Last) := Wide_Character'Val (Aux mod 16#400# + Low_Surrogate_Base); end if; end loop; if not C.GIOP_1_2_Mode then Last := Last - 1; end if; Data := To_PolyORB_Wide_String (Result (Result'First .. Last)); end; end Unmarshall; procedure Unmarshall (C : UTF8_Native_Converter; Buffer : access Buffers.Buffer_Type; Data : out Types.Char; Error : in out Errors.Error_Container) is pragma Unreferenced (C); begin Data := Character'Val (Octet'(Unmarshall (Buffer))); if Character'Pos (Data) >= 16#80# then Throw (Error, Data_Conversion_E, System_Exception_Members' (Minor => 1, Completed => Completed_No)); end if; end Unmarshall; procedure Unmarshall (C : UTF8_Native_Converter; Buffer : access Buffers.Buffer_Type; Data : out Types.String; Error : in out Errors.Error_Container) is pragma Unreferenced (C); pragma Unreferenced (Error); begin Data := Unmarshall_Latin_1_String (Buffer); end Unmarshall; begin declare use PolyORB.Initialization; use PolyORB.Initialization.String_Lists; use PolyORB.Utils.Strings; begin Register_Module (Module_Info' (Name => +"code_sets.converters.unicode", Conflicts => Empty, Depends => +"code_sets.converters", Provides => Empty, Implicit => False, Init => Initialize'Access, Shutdown => null)); end; end PolyORB.GIOP_P.Code_Sets.Converters.Unicode; polyorb-2.8~20110207.orig/src/giop/polyorb-qos-code_sets.ads0000644000175000017500000000471211750740340023060 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . Q O S . C O D E _ S E T S -- -- -- -- S p e c -- -- -- -- Copyright (C) 2004-2005 Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with PolyORB.GIOP_P.Code_Sets; package PolyORB.QoS.Code_Sets is pragma Elaborate_Body (Code_Sets); type QoS_GIOP_Code_Sets_Parameter is new QoS_Parameter (GIOP_Code_Sets) with record Char_Data : PolyORB.GIOP_P.Code_Sets.Code_Set_Id; Wchar_Data : PolyORB.GIOP_P.Code_Sets.Code_Set_Id; end record; type QoS_GIOP_Code_Sets_Parameter_Access is access all QoS_GIOP_Code_Sets_Parameter; end PolyORB.QoS.Code_Sets; polyorb-2.8~20110207.orig/src/giop/diop/0000755000175000017500000000000011750740340017062 5ustar xavierxavierpolyorb-2.8~20110207.orig/src/giop/diop/polyorb-setup-diop.adb0000644000175000017500000000562711750740340023321 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . S E T U P . D I O P -- -- -- -- B o d y -- -- -- -- Copyright (C) 2003-2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ pragma Warnings (Off); -- No entities referenced. with PolyORB.Protocols.GIOP.GIOP_1_2; with PolyORB.Protocols.GIOP.GIOP_1_1; with PolyORB.Protocols.GIOP.GIOP_1_0; pragma Warnings (On); with PolyORB.Initialization; with PolyORB.Utils.Strings; package body PolyORB.Setup.DIOP is ---------------- -- Initialize -- ---------------- procedure Initialize; procedure Initialize is begin null; end Initialize; use PolyORB.Initialization; use PolyORB.Initialization.String_Lists; use PolyORB.Utils.Strings; begin Register_Module (Module_Info' (Name => +"setup.diop", Conflicts => Empty, Depends => +"protocols.giop.giop_1_2" &"protocols.giop.giop_1_1" &"protocols.giop.giop_1_0", Provides => Empty, Implicit => False, Init => Initialize'Access, Shutdown => null)); end PolyORB.Setup.DIOP; polyorb-2.8~20110207.orig/src/giop/diop/polyorb-protocols-giop-diop.adb0000644000175000017500000000634011750740340025132 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . P R O T O C O L S . G I O P . D I O P -- -- -- -- B o d y -- -- -- -- Copyright (C) 2002-2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with PolyORB.Initialization; with PolyORB.Utils.Strings; package body PolyORB.Protocols.GIOP.DIOP is ------------ -- Create -- ------------ procedure Create (Proto : access DIOP_Protocol; Session : out Filter_Access) is begin PolyORB.Protocols.GIOP.Create (GIOP_Protocol (Proto.all)'Access, Session); GIOP_Session (Session.all).Conf := DIOP_Conf'Access; end Create; ---------------- -- Initialize -- ---------------- procedure Initialize; procedure Initialize is F : constant Flags := Sync_With_Transport; begin PolyORB.Protocols.GIOP.Initialize (DIOP_Conf'Access, GIOP_Default_Version, F, False, "diop", "polyorb.protocols.diop.giop"); end Initialize; use PolyORB.Initialization; use PolyORB.Initialization.String_Lists; use PolyORB.Utils.Strings; begin Register_Module (Module_Info' (Name => +"protocols.giop.diop", Conflicts => Empty, Depends => +"setup.diop", Provides => Empty, Implicit => False, Init => Initialize'Access, Shutdown => null)); end PolyORB.Protocols.GIOP.DIOP; polyorb-2.8~20110207.orig/src/giop/diop/polyorb-giop_p-transport_mechanisms-diop.adb0000644000175000017500000001657311750740340027701 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- POLYORB.GIOP_P.TRANSPORT_MECHANISMS.DIOP -- -- -- -- B o d y -- -- -- -- Copyright (C) 2005-2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with PolyORB.Binding_Data.GIOP.DIOP; with PolyORB.Binding_Objects; with PolyORB.Filters; with PolyORB.ORB; with PolyORB.Protocols.GIOP.DIOP; with PolyORB.Sockets; with PolyORB.Transport.Datagram.Sockets; package body PolyORB.GIOP_P.Transport_Mechanisms.DIOP is use PolyORB.Components; use PolyORB.Errors; use PolyORB.Sockets; use PolyORB.Transport.Datagram.Sockets; use PolyORB.Utils.Sockets; ---------------- -- Address_Of -- ---------------- function Address_Of (M : DIOP_Transport_Mechanism) return Utils.Sockets.Socket_Name is begin return M.Address.all; end Address_Of; -------------------- -- Bind_Mechanism -- -------------------- -- Factories Pro : aliased PolyORB.Protocols.GIOP.DIOP.DIOP_Protocol; DIOP_Factories : constant Filters.Factory_Array := (0 => Pro'Access); procedure Bind_Mechanism (Mechanism : DIOP_Transport_Mechanism; Profile : access PolyORB.Binding_Data.Profile_Type'Class; The_ORB : Components.Component_Access; QoS : PolyORB.QoS.QoS_Parameters; BO_Ref : out Smart_Pointers.Ref; Error : out Errors.Error_Container) is pragma Unreferenced (QoS); use PolyORB.Binding_Data; use PolyORB.Binding_Objects; Sock : Socket_Type; TE : Transport.Transport_Endpoint_Access; begin if Profile.all not in PolyORB.Binding_Data.GIOP.DIOP.DIOP_Profile_Type then Throw (Error, Comm_Failure_E, System_Exception_Members' (Minor => 0, Completed => Completed_Maybe)); return; end if; Create_Socket (Socket => Sock, Family => Family_Inet, Mode => Socket_Datagram); TE := new Socket_Endpoint; Create (Socket_Endpoint (TE.all), Sock, Utils.Sockets.To_Address (Mechanism.Address.all)); Binding_Objects.Setup_Binding_Object (The_ORB, TE, DIOP_Factories, BO_Ref, Profile_Access (Profile)); ORB.Register_Binding_Object (ORB.ORB_Access (The_ORB), BO_Ref, ORB.Client); exception when Sockets.Socket_Error => Throw (Error, Comm_Failure_E, System_Exception_Members' (Minor => 0, Completed => Completed_Maybe)); end Bind_Mechanism; -------------------- -- Create_Factory -- -------------------- procedure Create_Factory (MF : out DIOP_Transport_Mechanism_Factory; TAP : Transport.Transport_Access_Point_Access) is begin MF.Address := new Socket_Name'(Address_Of (Socket_Access_Point (TAP.all))); end Create_Factory; ------------------------------ -- Create_Tagged_Components -- ------------------------------ function Create_Tagged_Components (MF : DIOP_Transport_Mechanism_Factory) return Tagged_Components.Tagged_Component_List is pragma Unreferenced (MF); begin return Tagged_Components.Null_Tagged_Component_List; end Create_Tagged_Components; -------------------------------- -- Create_Transport_Mechanism -- -------------------------------- function Create_Transport_Mechanism (MF : DIOP_Transport_Mechanism_Factory) return Transport_Mechanism_Access is Result : constant Transport_Mechanism_Access := new DIOP_Transport_Mechanism; TResult : DIOP_Transport_Mechanism renames DIOP_Transport_Mechanism (Result.all); begin TResult.Address := new Socket_Name'(MF.Address.all); return Result; end Create_Transport_Mechanism; -------------------------------- -- Create_Transport_Mechanism -- -------------------------------- function Create_Transport_Mechanism (Address : Utils.Sockets.Socket_Name) return Transport_Mechanism_Access is Result : constant Transport_Mechanism_Access := new DIOP_Transport_Mechanism; TResult : DIOP_Transport_Mechanism renames DIOP_Transport_Mechanism (Result.all); begin TResult.Address := new Socket_Name'(Address); return Result; end Create_Transport_Mechanism; ------------------------ -- Is_Local_Mechanism -- ------------------------ function Is_Local_Mechanism (MF : access DIOP_Transport_Mechanism_Factory; M : access Transport_Mechanism'Class) return Boolean is begin return M.all in DIOP_Transport_Mechanism and then DIOP_Transport_Mechanism (M.all).Address = MF.Address; end Is_Local_Mechanism; ---------------------- -- Release_Contents -- ---------------------- procedure Release_Contents (M : access DIOP_Transport_Mechanism) is begin Free (M.Address); end Release_Contents; --------------- -- Duplicate -- --------------- function Duplicate (TMA : DIOP_Transport_Mechanism) return DIOP_Transport_Mechanism is begin return DIOP_Transport_Mechanism' (Address => new Socket_Name'(TMA.Address.all)); end Duplicate; ------------------ -- Is_Colocated -- ------------------ function Is_Colocated (Left : DIOP_Transport_Mechanism; Right : Transport_Mechanism'Class) return Boolean is begin return Right in DIOP_Transport_Mechanism and then Left.Address = DIOP_Transport_Mechanism (Right).Address; end Is_Colocated; end PolyORB.GIOP_P.Transport_Mechanisms.DIOP; polyorb-2.8~20110207.orig/src/giop/diop/polyorb-protocols-giop-diop.ads0000644000175000017500000000452511750740340025156 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . P R O T O C O L S . G I O P . D I O P -- -- -- -- S p e c -- -- -- -- Copyright (C) 2002-2003 Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by ACT Europe. -- -- (email: sales@act-europe.fr) -- -- -- ------------------------------------------------------------------------------ package PolyORB.Protocols.GIOP.DIOP is type DIOP_Protocol is new GIOP_Protocol with private; procedure Create (Proto : access DIOP_Protocol; Session : out Filter_Access); private type DIOP_Protocol is new GIOP_Protocol with null record; DIOP_Conf : aliased GIOP_Conf; end PolyORB.Protocols.GIOP.DIOP; polyorb-2.8~20110207.orig/src/giop/diop/polyorb-giop_p-transport_mechanisms-diop.ads0000644000175000017500000001035511750740340027712 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- POLYORB.GIOP_P.TRANSPORT_MECHANISMS.DIOP -- -- -- -- S p e c -- -- -- -- Copyright (C) 2005-2008, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with PolyORB.Utils.Sockets; package PolyORB.GIOP_P.Transport_Mechanisms.DIOP is type DIOP_Transport_Mechanism is new Transport_Mechanism with private; procedure Bind_Mechanism (Mechanism : DIOP_Transport_Mechanism; Profile : access PolyORB.Binding_Data.Profile_Type'Class; The_ORB : Components.Component_Access; QoS : PolyORB.QoS.QoS_Parameters; BO_Ref : out Smart_Pointers.Ref; Error : out Errors.Error_Container); procedure Release_Contents (M : access DIOP_Transport_Mechanism); -- DIOP Transport Mechanism specific subprograms function Address_Of (M : DIOP_Transport_Mechanism) return Utils.Sockets.Socket_Name; -- Return address of transport mechanism's transport access point. type DIOP_Transport_Mechanism_Factory is new Transport_Mechanism_Factory with private; procedure Create_Factory (MF : out DIOP_Transport_Mechanism_Factory; TAP : Transport.Transport_Access_Point_Access); function Is_Local_Mechanism (MF : access DIOP_Transport_Mechanism_Factory; M : access Transport_Mechanism'Class) return Boolean; function Create_Tagged_Components (MF : DIOP_Transport_Mechanism_Factory) return Tagged_Components.Tagged_Component_List; -- DIOP Transport Mechanism Factory specific subprograms function Create_Transport_Mechanism (MF : DIOP_Transport_Mechanism_Factory) return Transport_Mechanism_Access; -- Create transport mechanism function Create_Transport_Mechanism (Address : Utils.Sockets.Socket_Name) return Transport_Mechanism_Access; -- Create transport mechanism for specified transport access point address function Duplicate (TMA : DIOP_Transport_Mechanism) return DIOP_Transport_Mechanism; function Is_Colocated (Left : DIOP_Transport_Mechanism; Right : Transport_Mechanism'Class) return Boolean; private type DIOP_Transport_Mechanism is new Transport_Mechanism with record Address : Utils.Sockets.Socket_Name_Ptr; end record; type DIOP_Transport_Mechanism_Factory is new Transport_Mechanism_Factory with record Address : Utils.Sockets.Socket_Name_Ptr; end record; end PolyORB.GIOP_P.Transport_Mechanisms.DIOP; polyorb-2.8~20110207.orig/src/giop/diop/polyorb-binding_data-giop-diop.ads0000644000175000017500000000702511750740340025533 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . B I N D I N G _ D A T A . G I O P . D I O P -- -- -- -- S p e c -- -- -- -- Copyright (C) 2002-2011, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- Binding data concrete implementation for DIOP with PolyORB.Buffers; with PolyORB.Types; package PolyORB.Binding_Data.GIOP.DIOP is use PolyORB.Buffers; type DIOP_Profile_Type is new GIOP_Profile_Type with private; type DIOP_Profile_Factory is new GIOP_Profile_Factory with private; function Create_Profile (PF : access DIOP_Profile_Factory; Oid : Objects.Object_Id) return Profile_Access; function Duplicate_Profile (P : DIOP_Profile_Type) return Profile_Access; function Get_Profile_Tag (Profile : DIOP_Profile_Type) return Profile_Tag; pragma Inline (Get_Profile_Tag); function Get_Profile_Preference (Profile : DIOP_Profile_Type) return Profile_Preference; pragma Inline (Get_Profile_Preference); procedure Create_Factory (PF : out DIOP_Profile_Factory; TAP : Transport.Transport_Access_Point_Access; ORB : Components.Component_Access); procedure Marshall_DIOP_Profile_Body (Buf : access Buffer_Type; Profile : Profile_Access); function Unmarshall_DIOP_Profile_Body (Buffer : access Buffer_Type) return Profile_Access; function Image (Prof : DIOP_Profile_Type) return String; private -- DIOP version DIOP_Version_Major : constant Types.Octet := 1; DIOP_Version_Minor : constant Types.Octet := 0; type DIOP_Profile_Type is new GIOP_Profile_Type with null record; type DIOP_Profile_Factory is new GIOP_Profile_Factory with null record; end PolyORB.Binding_Data.GIOP.DIOP; polyorb-2.8~20110207.orig/src/giop/diop/polyorb-binding_data-giop-diop.adb0000644000175000017500000002317611750740340025517 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . B I N D I N G _ D A T A . G I O P . D I O P -- -- -- -- B o d y -- -- -- -- Copyright (C) 2002-2011, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with PolyORB.Binding_Data.GIOP.INET; with PolyORB.GIOP_P.Transport_Mechanisms.DIOP; with PolyORB.Initialization; with PolyORB.Log; with PolyORB.Parameters; with PolyORB.References.Corbaloc; with PolyORB.References.IOR; with PolyORB.Utils.Strings; with PolyORB.Utils.Sockets; package body PolyORB.Binding_Data.GIOP.DIOP is use PolyORB.Binding_Data.GIOP.INET; use PolyORB.GIOP_P.Tagged_Components; use PolyORB.GIOP_P.Transport_Mechanisms; use PolyORB.GIOP_P.Transport_Mechanisms.DIOP; use PolyORB.Log; use PolyORB.Objects; use PolyORB.References.IOR; use PolyORB.References.Corbaloc; use PolyORB.Types; use PolyORB.Utils.Sockets; package L is new PolyORB.Log.Facility_Log ("polyorb.binding_data.giop.diop"); procedure O (Message : Standard.String; Level : Log_Level := Debug) renames L.Output; function C (Level : Log_Level := Debug) return Boolean renames L.Enabled; DIOP_Corbaloc_Prefix : constant String := "diop"; Preference : Profile_Preference; -- Global variable: the preference to be returned -- by Get_Profile_Preference for DIOP profiles. function Profile_To_Corbaloc (P : Profile_Access) return String; function Corbaloc_To_Profile (Str : String) return Profile_Access; --------------------- -- Get_Profile_Tag -- --------------------- function Get_Profile_Tag (Profile : DIOP_Profile_Type) return Profile_Tag is pragma Unreferenced (Profile); begin return Tag_DIOP; end Get_Profile_Tag; ---------------------------- -- Get_Profile_Preference -- ---------------------------- function Get_Profile_Preference (Profile : DIOP_Profile_Type) return Profile_Preference is pragma Unreferenced (Profile); begin return Preference; end Get_Profile_Preference; -------------------- -- Create_Factory -- -------------------- procedure Create_Factory (PF : out DIOP_Profile_Factory; TAP : Transport.Transport_Access_Point_Access; ORB : Components.Component_Access) is pragma Unreferenced (ORB); MF : constant Transport_Mechanism_Factory_Access := new DIOP_Transport_Mechanism_Factory; begin Create_Factory (MF.all, TAP); Append (PF.Mechanisms, MF); end Create_Factory; -------------------- -- Create_Profile -- -------------------- function Create_Profile (PF : access DIOP_Profile_Factory; Oid : Objects.Object_Id) return Profile_Access is Result : constant Profile_Access := new DIOP_Profile_Type; TResult : DIOP_Profile_Type renames DIOP_Profile_Type (Result.all); begin TResult.Version_Major := DIOP_Version_Major; TResult.Version_Minor := DIOP_Version_Minor; TResult.Object_Id := new Object_Id'(Oid); TResult.Components := Null_Tagged_Component_List; -- Create transport mechanism Append (TResult.Mechanisms, Create_Transport_Mechanism (DIOP_Transport_Mechanism_Factory (Element (PF.Mechanisms, 0).all.all))); return Result; end Create_Profile; ----------------------- -- Duplicate_Profile -- ----------------------- function Duplicate_Profile (P : DIOP_Profile_Type) return Profile_Access is Result : constant Profile_Access := new DIOP_Profile_Type; TResult : DIOP_Profile_Type renames DIOP_Profile_Type (Result.all); begin TResult.Version_Major := P.Version_Major; TResult.Version_Minor := P.Version_Minor; TResult.Object_Id := new Object_Id'(P.Object_Id.all); TResult.Components := Deep_Copy (P.Components); TResult.Mechanisms := Deep_Copy (P.Mechanisms); return Result; end Duplicate_Profile; -------------------------------- -- Marshall_DIOP_Profile_Body -- -------------------------------- procedure Marshall_DIOP_Profile_Body (Buf : access Buffer_Type; Profile : Profile_Access) is begin Common_Marshall_Profile_Body (Buf, Profile, Address_Of (DIOP_Transport_Mechanism (Element (DIOP_Profile_Type (Profile.all).Mechanisms, 0).all.all)), True); end Marshall_DIOP_Profile_Body; ---------------------------------- -- Unmarshall_DIOP_Profile_Body -- ---------------------------------- function Unmarshall_DIOP_Profile_Body (Buffer : access Buffer_Type) return Profile_Access is Result : constant Profile_Access := new DIOP_Profile_Type; Address : constant Utils.Sockets.Socket_Name := Common_Unmarshall_Profile_Body (Buffer, Result, Unmarshall_Object_Id => True, Unmarshall_Tagged_Components => False); begin -- Create transport mechanism Append (DIOP_Profile_Type (Result.all).Mechanisms, Create_Transport_Mechanism (Address)); return Result; end Unmarshall_DIOP_Profile_Body; ----------- -- Image -- ----------- function Image (Prof : DIOP_Profile_Type) return String is begin return "Address : " & Utils.Sockets.Image (Address_Of (DIOP_Transport_Mechanism (Element (Prof.Mechanisms, 0).all.all))) & ", Object_Id : " & PolyORB.Objects.Image (Prof.Object_Id.all); end Image; ------------------------- -- Profile_To_Corbaloc -- ------------------------- function Profile_To_Corbaloc (P : Profile_Access) return String is begin pragma Debug (C, O ("DIOP Profile to corbaloc")); return Common_IIOP_DIOP_Profile_To_Corbaloc (P, Address_Of (DIOP_Transport_Mechanism (Element (DIOP_Profile_Type (P.all).Mechanisms, 0).all.all)), DIOP_Corbaloc_Prefix); end Profile_To_Corbaloc; ------------------------- -- Corbaloc_To_Profile -- ------------------------- function Corbaloc_To_Profile (Str : String) return Profile_Access is Result : aliased Profile_Access := new DIOP_Profile_Type; Address : constant Utils.Sockets.Socket_Name := Common_IIOP_DIOP_Corbaloc_To_Profile (Str, DIOP_Version_Major, DIOP_Version_Minor, Result'Access); begin -- Create transport mechanism Append (DIOP_Profile_Type (Result.all).Mechanisms, Create_Transport_Mechanism (Address)); return Result; end Corbaloc_To_Profile; ---------------- -- Initialize -- ---------------- procedure Initialize; procedure Initialize is Preference_Offset : constant String := PolyORB.Parameters.Get_Conf (Section => "diop", Key => "polyorb.binding_data.diop.preference", Default => "0"); begin -- XXX we impose a slight preference penalty to DIOP to favor IIOP -- by default. See F501-004. Preference := Preference_Default - 1 + Profile_Preference'Value (Preference_Offset); Register (Tag_DIOP, Marshall_DIOP_Profile_Body'Access, Unmarshall_DIOP_Profile_Body'Access); Register (Tag_DIOP, DIOP_Corbaloc_Prefix, Profile_To_Corbaloc'Access, Corbaloc_To_Profile'Access); end Initialize; use PolyORB.Initialization; use PolyORB.Initialization.String_Lists; use PolyORB.Utils.Strings; begin Register_Module (Module_Info' (Name => +"binding_data.diop", Conflicts => Empty, Depends => +"sockets", Provides => +"binding_factories", Implicit => False, Init => Initialize'Access, Shutdown => null)); end PolyORB.Binding_Data.GIOP.DIOP; polyorb-2.8~20110207.orig/src/giop/diop/polyorb-setup-diop.ads0000644000175000017500000000413111750740340023327 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . S E T U P . D I O P -- -- -- -- S p e c -- -- -- -- Copyright (C) 2003 Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by ACT Europe. -- -- (email: sales@act-europe.fr) -- -- -- ------------------------------------------------------------------------------ package PolyORB.Setup.DIOP is pragma Elaborate_Body; end PolyORB.Setup.DIOP; polyorb-2.8~20110207.orig/src/giop/diop/polyorb-setup-access_points-diop.ads0000644000175000017500000000422011750740340026161 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . S E T U P . A C C E S S _ P O I N T S . D I O P -- -- -- -- S p e c -- -- -- -- Copyright (C) 2003 Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by ACT Europe. -- -- (email: sales@act-europe.fr) -- -- -- ------------------------------------------------------------------------------ -- Setup socket for DIOP package PolyORB.Setup.Access_Points.DIOP is pragma Elaborate_Body; end PolyORB.Setup.Access_Points.DIOP; polyorb-2.8~20110207.orig/src/giop/diop/polyorb-setup-access_points-diop.adb0000644000175000017500000001140411750740340026142 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . S E T U P . A C C E S S _ P O I N T S . D I O P -- -- -- -- B o d y -- -- -- -- Copyright (C) 2003-2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- Setup socket for DIOP with PolyORB.Binding_Data.GIOP.DIOP; with PolyORB.Protocols.GIOP.DIOP; with PolyORB.Filters; with PolyORB.Filters.Fragmenter; with PolyORB.Initialization; with PolyORB.ORB; with PolyORB.Parameters; with PolyORB.Protocols; with PolyORB.Sockets; with PolyORB.Transport.Datagram.Sockets; with PolyORB.Utils.Strings; with PolyORB.Utils.Socket_Access_Points; with PolyORB.Utils.UDP_Access_Points; package body PolyORB.Setup.Access_Points.DIOP is use PolyORB.Filters; use PolyORB.Filters.Fragmenter; use PolyORB.ORB; use PolyORB.Sockets; use PolyORB.Transport.Datagram.Sockets; use PolyORB.Utils.Socket_Access_Points; use PolyORB.Utils.UDP_Access_Points; DIOP_Access_Point : UDP_Access_Point_Info := (Socket => No_Socket, Address => No_Sock_Addr, SAP => new Socket_Access_Point, PF => new PolyORB.Binding_Data.GIOP.DIOP.DIOP_Profile_Factory); Fra : aliased Fragmenter_Factory; Pro : aliased Protocols.GIOP.DIOP.DIOP_Protocol; DIOP_Factories : aliased Filters.Factory_Array := (0 => Fra'Access, 1 => Pro'Access); ------------------------------ -- Initialize_Access_Points -- ------------------------------ procedure Initialize_Access_Points; procedure Initialize_Access_Points is use PolyORB.Parameters; begin if Get_Conf ("access_points", "diop", True) then declare Port_Hint : constant Port_Interval := To_Port_Interval (Get_Conf ("diop", "polyorb.protocols.diop.default_port", (Integer (Any_Port), Integer (Any_Port)))); Addr : constant Inet_Addr_Type := Inet_Addr (String'(Get_Conf ("diop", "polyorb.protocols.diop.default_addr", Image (No_Inet_Addr)))); begin Initialize_Unicast_Socket (DIOP_Access_Point, Port_Hint, Addr); Register_Access_Point (ORB => The_ORB, TAP => DIOP_Access_Point.SAP, Chain => DIOP_Factories'Access, PF => DIOP_Access_Point.PF); end; end if; end Initialize_Access_Points; use PolyORB.Initialization; use PolyORB.Initialization.String_Lists; use PolyORB.Utils.Strings; begin Register_Module (Module_Info' (Name => +"access_points.diop", Conflicts => String_Lists.Empty, Depends => +"orb" & "sockets", Provides => String_Lists.Empty, Implicit => False, Init => Initialize_Access_Points'Access, Shutdown => null)); end PolyORB.Setup.Access_Points.DIOP; polyorb-2.8~20110207.orig/src/giop/polyorb-binding_data-giop.ads0000644000175000017500000001112611750740340023644 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . B I N D I N G _ D A T A . G I O P -- -- -- -- S p e c -- -- -- -- Copyright (C) 2004-2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with PolyORB.GIOP_P.Tagged_Components; with PolyORB.GIOP_P.Transport_Mechanisms; with PolyORB.Protocols.GIOP; package PolyORB.Binding_Data.GIOP is package PGTC renames PolyORB.GIOP_P.Tagged_Components; package PGTM renames PolyORB.GIOP_P.Transport_Mechanisms; type GIOP_Profile_Type is abstract new Profile_Type with private; type GIOP_Profile_Factory is abstract new Profile_Factory with private; procedure Bind_Profile (Profile : access GIOP_Profile_Type; The_ORB : Components.Component_Access; QoS : PolyORB.QoS.QoS_Parameters; BO_Ref : out Smart_Pointers.Ref; Error : out Errors.Error_Container); procedure Release (P : in out GIOP_Profile_Type); function Get_Component (P : GIOP_Profile_Type; C : PGTC.Tag_Value) return PGTC.Tagged_Component_Access; function Is_Colocated (Left : GIOP_Profile_Type; Right : Profile_Type'Class) return Boolean; function Is_Local_Profile (PF : access GIOP_Profile_Factory; P : access Profile_Type'Class) return Boolean; function Get_GIOP_Version (P : GIOP_Profile_Type) return Protocols.GIOP.GIOP_Version; -- Return the GIOP version indicated in profile P function Get_Primary_Transport_Mechanism (P : GIOP_Profile_Type) return PGTM.Transport_Mechanism_Access; -- Return primary transport mechanism for profile function Get_Primary_Transport_Mechanism_Factory (P : GIOP_Profile_Factory) return PGTM.Transport_Mechanism_Factory_Access; -- Return primary transport mechanism factory for profile factory type Is_Security_Selected_Hook is access function (QoS : PolyORB.QoS.QoS_Parameters; Mechanism : PGTM.Transport_Mechanism_Access) return Boolean; Is_Security_Selected : Is_Security_Selected_Hook := null; -- This hook is used in profile binding procedure to avoid binding with -- transport mechanisms other than those selected by security service. -- Binding of such mechanisms may cause unexpected behavior because some -- security related information (credentials, for example) are unavailable. private type GIOP_Profile_Type is abstract new Profile_Type with record Version_Major : Types.Octet; Version_Minor : Types.Octet; Components : PGTC.Tagged_Component_List; -- Tagged components list Mechanisms : PGTM.Transport_Mechanism_List; -- Transport mechanisms list end record; type GIOP_Profile_Factory is abstract new Profile_Factory with record Mechanisms : PGTM.Transport_Mechanism_Factory_List; end record; end PolyORB.Binding_Data.GIOP; polyorb-2.8~20110207.orig/src/giop/polyorb-representations-cdr-giop_1_1.ads0000644000175000017500000001164611750740340025703 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- POLYORB.REPRESENTATIONS.CDR.GIOP_1_1 -- -- -- -- S p e c -- -- -- -- Copyright (C) 2004-2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- Support package for CDR representation of char and strings for GIOP 1.1 with PolyORB.GIOP_P.Code_Sets.Converters; package PolyORB.Representations.CDR.GIOP_1_1 is pragma Elaborate_Body; type GIOP_1_1_CDR_Representation is new CDR_Representation with private; type GIOP_1_1_CDR_Representation_Access is access all GIOP_1_1_CDR_Representation; -- XXX Encapsulation is also GIOP version dependent. procedure Set_Converters (R : in out GIOP_1_1_CDR_Representation; C : PolyORB.GIOP_P.Code_Sets.Converters.Converter_Access; W : PolyORB.GIOP_P.Code_Sets.Converters.Wide_Converter_Access); -- Set code sets converters for Character/String and -- Wide_Character/Wide_String types. Code set converters may be -- null value. If the code set converter is set to null, then we -- assume what the backward compatibility mode with GIOP 1.0 -- enabled. procedure Release (R : in out GIOP_1_1_CDR_Representation); -- Deallocate content of R private type GIOP_1_1_CDR_Representation is new CDR_Representation with record C_Converter : PolyORB.GIOP_P.Code_Sets.Converters.Converter_Access; W_Converter : PolyORB.GIOP_P.Code_Sets.Converters.Wide_Converter_Access; end record; -- 'char' type procedure Marshall (R : GIOP_1_1_CDR_Representation; Buffer : access Buffers.Buffer_Type; Data : PolyORB.Types.Char; Error : in out Errors.Error_Container); procedure Unmarshall (R : GIOP_1_1_CDR_Representation; Buffer : access Buffers.Buffer_Type; Data : out PolyORB.Types.Char; Error : in out Errors.Error_Container); -- 'wchar' type procedure Marshall (R : GIOP_1_1_CDR_Representation; Buffer : access Buffers.Buffer_Type; Data : PolyORB.Types.Wchar; Error : in out Errors.Error_Container); procedure Unmarshall (R : GIOP_1_1_CDR_Representation; Buffer : access Buffers.Buffer_Type; Data : out PolyORB.Types.Wchar; Error : in out Errors.Error_Container); -- 'string' type procedure Marshall (R : GIOP_1_1_CDR_Representation; Buffer : access Buffers.Buffer_Type; Data : PolyORB.Types.String; Error : in out Errors.Error_Container); procedure Unmarshall (R : GIOP_1_1_CDR_Representation; Buffer : access Buffers.Buffer_Type; Data : out PolyORB.Types.String; Error : in out Errors.Error_Container); -- 'wstring' type procedure Marshall (R : GIOP_1_1_CDR_Representation; Buffer : access Buffers.Buffer_Type; Data : PolyORB.Types.Wide_String; Error : in out Errors.Error_Container); procedure Unmarshall (R : GIOP_1_1_CDR_Representation; Buffer : access Buffers.Buffer_Type; Data : out PolyORB.Types.Wide_String; Error : in out Errors.Error_Container); end PolyORB.Representations.CDR.GIOP_1_1; polyorb-2.8~20110207.orig/src/giop/polyorb-representations-cdr-giop_utils.ads0000644000175000017500000000536511750740340026464 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- POLYORB.REPRESENTATIONS.CDR.GIOP_UTILS -- -- -- -- S p e c -- -- -- -- Copyright (C) 2004-2007, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ package PolyORB.Representations.CDR.GIOP_Utils is -- 'NamedValue' type procedure Marshall (Buffer : access Buffers.Buffer_Type; Representation : access CDR_Representation'Class; Data : PolyORB.Any.NamedValue; Error : in out Errors.Error_Container); -- Marshall Data according to selected CDR representation Representation procedure Unmarshall (Buffer : access Buffers.Buffer_Type; Representation : access CDR_Representation'Class; Data : in out PolyORB.Any.NamedValue; Error : in out Errors.Error_Container); -- Unmarshall data according to selected CDR representation Representation end PolyORB.Representations.CDR.GIOP_Utils; polyorb-2.8~20110207.orig/src/giop/cs_registry1.2h0000644000175000017500000020221611750740340021003 0ustar xavierxavier# # OSF Character and Code Set Registry # Version 1.2g # June, 1999 # # Copyright 1994, 1995, 1996 Open Software Foundation, Inc. # Copyright 1997, 1998, 1999 The Open Group, Inc. # # Permission to use, copy, and distribute this documentation # is hereby granted provided that the above copyright notice # appears in all copies and that both the copyright notice # and this permission notice appears in supporting documentation. # This documentation is provided "as is" without express or # implied warranty. # # # This file lists the current entries in the OSF Character and # Code Set Registry. Registered character sets are listed first, # followed by registered code sets. The code set entries have # the following line-oriented format (field separators = whitespace = # spaces or tabs; lines beginning with "#" or whitespace are comments): # # start # Short Description [text] # Registered Value [unsigned32] # Character Set ID(s) [unsigned16:...:unsigned16] # Max Bytes per Character [unsigned16] # Ordering Information # [text -- optional] # Comments # [text -- optional] # end # # See DCE RFC 40.1 for a description of the fields, and for # more information on the registry. # # Registered code sets are grouped according to organization # type -- standards group first, followed by consortium, # commercial company, and other. # # For most entries in the registry, OSF has a contact and address # from which you can request additional information. Note that it # is the responsibility of the designated contact to respond; OSF # will not attempt to supply the requested information if the # organization in question fails to do so, or fails to provide # the information you want. # # For more information about the registry, or to make a request # to register a character set or code set, send email to # cs_registry@osf.org # ################################################################# # REGISTERED CHARACTER SETS # ################################################################# # Identifier Descriptive Name Approx. Repertoire # ---------- ---------------- ------------------ # 0x0000 /* not used */ # 0x0001 PCS A-Za-z0-9 !"#$%&'()*+,-/:;<=>?@[\]^_`{|}~ # 0x0011 Latin-1 ISO 8859-1 # 0x0012 Latin-2 ISO 8859-2 # 0x0013 Latin-3 ISO 8859-3 # 0x0014 Latin-4 ISO 8859-4 # 0x0015 Cyrillic Script ISO 8859-5 # 0x0016 Arabic Script ISO 8859-6 # 0x0017 Greek Script ISO 8859-7 # 0x0018 Hebrew Script ISO 8859-8 # 0x0019 Latin-5 ISO 8859-9 # 0x001a Latin-6 ISO 8859-10 # 0x001f Latin-9 ISO 8859-15 # 0x0050 European ISO 6937 # 0x0080 Japanese1 JIS X0201 # 0x0081 Japanese2 JIS X0208 # 0x0082 Japanese3 JIS X0212 # 0x0100 Korean1 KS C5601 # 0x0101 Korean2 KS C5657 # 0x0180 Taiwanese1 CNS 11643 (1986) # 0x0181 Taiwanese2 CNS 11643 (1992) # 0x0200 Thai TIS 620-2529 # 0x0280 Indian LTD 37(1610) # 0x0300 Simplified Chinese GB 2312-1980 # 0x1000 Universal ISO 10646-1 # 0xf000-0xffff /* reserved for vendor- or user-defined values */ ################################################################### # INTERNATIONAL OR NATIONAL STANDARD CODE SETS/ENCODING METHODS # ################################################################### ################################################################### # ISO/IEC # Organization ID: 0x0001 # # The Ordering Information for all the ISO/IEC code sets is the same. # Rather than repeat it for each entry, it is listed here: # # International Organization for Standardization # 1, Rue de Varembe # Case postale 56 # CH-1211 Geneva 20 # Switzerland # ################################################################### start Short Description ISO 8859-1:1987; Latin Alphabet No. 1 Registered Value 0x00010001 Character Set ID(s) 0x0011 Max Bytes per Character 1 Ordering Information See information provided before first ISO/IEC entry (above). Comments Contains characters used for writing these languages: Danish, Dutch, English, Faeroese, Finnish, French, German, Icelandic, Italian, Norwegian, Portuguese, Spanish, Swedish. end start Short Description ISO 8859-2:1987; Latin Alphabet No. 2 Registered Value 0x00010002 Character Set ID(s) 0x0012 Max Bytes per Character 1 Ordering Information See information provided before first ISO/IEC entry (above). Comments Contains characters used for writing these languages: Albanian, Czechoslovakian, English, German, Hungarian, Polish, Rumanian, Serbo-Croatian, Slovak, Slovene. end start Short Description ISO 8859-3:1988; Latin Alphabet No. 3 Registered Value 0x00010003 Character Set ID(s) 0x0013 Max Bytes per Character 1 Ordering Information See information provided before first ISO/IEC entry (above). Comments Contains characters used for writing these languages: Afrikaans, Catalan, Dutch, English, Esperanto, German, Italian, Maltese, Spanish, Turkish. end start Short Description ISO 8859-4:1988; Latin Alphabet No. 4 Registered Value 0x00010004 Character Set ID(s) 0x0014 Max Bytes per Character 1 Ordering Information See information provided before first ISO/IEC entry (above). Comments Contains characters used for writing these languages: Danish, Estonian, English, Finnish, German, Greenlandic, Lappish, Latvian, Lithuanian, Norwegian, Swedish. end start Short Description ISO/IEC 8859-5:1988; Latin-Cyrillic Alphabet Registered Value 0x00010005 Character Set ID(s) 0x0015 Max Bytes per Character 1 Ordering Information See information provided before first ISO/IEC entry (above). Comments Contains characters used for writing these languages: Bulgarian, Byelorussian, English, Macedonian, Russian, Serbo-Croatian, Ukranian. end start Short Description ISO 8859-6:1987; Latin-Arabic Alphabet Registered Value 0x00010006 Character Set ID(s) 0x0016 Max Bytes per Character 1 Ordering Information See information provided before first ISO/IEC entry (above). Comments Contains characters for writing English and Arabic. end start Short Description ISO 8859-7:1987; Latin-Greek Alphabet Registered Value 0x00010007 Character Set ID(s) 0x0017 Max Bytes per Character 1 Ordering Information See information provided before first ISO/IEC entry (above). Comments Contains characters for writing English and Greek. end start Short Description ISO 8859-8:1988; Latin-Hebrew Alphabet Registered Value 0x00010008 Character Set ID(s) 0x0018 Max Bytes per Character 1 Ordering Information See information provided before first ISO/IEC entry (above). Comments Contains characters for writing English and Hebrew. end start Short Description ISO/IEC 8859-9:1989; Latin Alphabet No. 5 Registered Value 0x00010009 Character Set ID(s) 0x0019 Max Bytes per Character 1 Ordering Information See information provided before first ISO/IEC entry (above). Comments Contains characters used for writing these languages: Danish, Dutch, English, Faeroese, Finnish, French, German, Italian, Norwegian, Portuguese, Spanish, Swedish, Turkish. end start Short Description ISO/IEC 8859-10:1992; Latin Alphabet No. 6 Registered Value 0x0001000a Character Set ID(s) 0x001a Max Bytes per Character 1 Ordering Information See information provided before first ISO/IEC entry (above). Comments Contains characters used for writing these languages: Danish, English, Estonian, Faeroese, Finnish, German, Greenlandic, Icelandic, Lappish, Latvian, Lithuanian, Norwegian, Swedish. end start Short Description ISO/IEC 8859-15:1999; Latin Alphabet No. 9 Registered Value 0x0001000f Character Set ID(s) 0x0011 Max Bytes per Character 1 Ordering Information To be provided Comments None end start Short Description ISO 646:1991 IRV (International Reference Version) Registered Value 0x00010020 Character Set ID(s) 0x0001 Max Bytes per Character 1 Ordering Information See information provided before first ISO/IEC entry (above). Comments Contains English A-Z and a-z, digits 0-9, common control characters, , and these symbols: !"#$%&'()*+,-./:;<=>?@[\]^_`{|}~ end start Short Description ISO/IEC 10646-1:1993; UCS-2, Level 1 Registered Value 0x00010100 Character Set ID(s) 0x1000 Max Bytes per Character 2 Ordering Information See information provided before first ISO/IEC entry (above). Comments Two-octet form of Universal Coded Character Set. Level 1 means no combining characters are allowed in a data stream. end start Short Description ISO/IEC 10646-1:1993; UCS-2, Level 2 Registered Value 0x00010101 Character Set ID(s) 0x1000 Max Bytes per Character 2 Ordering Information See information provided before first ISO/IEC entry (above). Comments Two-octet form of Universal Coded Character Set. Level 2 means combining characters are permitted in a data stream for these scripts only: Arabic, Hebrew, Indic, and Thai. end start Short Description ISO/IEC 10646-1:1993; UCS-2, Level 3 Registered Value 0x00010102 Character Set ID(s) 0x1000 Max Bytes per Character 2 Ordering Information See information provided before first ISO/IEC entry (above). Comments Two-octet form of Universal Coded Character Set. Level 3 means combining characters are permitted without restrictions. end start Short Description ISO/IEC 10646-1:1993; UCS-4, Level 1 Registered Value 0x00010104 Character Set ID(s) 0x1000 Max Bytes per Character 4 Ordering Information See information provided before first ISO/IEC entry (above). Comments Four-octet form of Universal Coded Character Set. Level 1 means no combining characters are allowed in a data stream. end start Short Description ISO/IEC 10646-1:1993; UCS-4, Level 2 Registered Value 0x00010105 Character Set ID(s) 0x1000 Max Bytes per Character 4 Ordering Information See information provided before first ISO/IEC entry (above). Comments Four-octet form of Universal Coded Character Set. Level 2 means combining characters are permitted in a data stream for these scripts only: Arabic, Hebrew, Indic, and Thai. end start Short Description ISO/IEC 10646-1:1993; UCS-4, Level 3 Registered Value 0x00010106 Character Set ID(s) 0x1000 Max Bytes per Character 4 Ordering Information See information provided before first ISO/IEC entry (above). Comments Four-octet form of Universal Coded Character Set. Level 3 means combining characters are permitted without restrictions. end start Short Description ISO/IEC 10646-1:1993; UTF-1, UCS Transformation Format 1 Registered Value 0x00010108 Character Set ID(s) 0x1000 Max Bytes per Character 5 Ordering Information See information provided before first ISO/IEC entry (above). Comments Multibyte-compatible encoding for ISO 10646-1 character repertoire. end start Short Description ISO/IEC 10646-1:1993; UTF-16, UCS Transformation Format 16-bit form Registered Value 0x00010109 Character Set ID(s) 0x1000 Max Bytes per Character 2 Ordering Information See information provided before first ISO/IEC entry (above). Comments UTF-16 specifies the encoding format by which Unicode/UCS-2 can specify code points within the UCS-4 defined code region as specified in ISO-10646. These code points exist outside of the 65,536 currently defined within the BMP (Basic Multilingual Plane) region of ISO-10646. end ################################################################### # JIS # Organization ID: 0x0003 ################################################################### start Short Description JIS X0201:1976; Japanese phonetic characters Registered Value 0x00030001 Character Set ID(s) 0x0080 Max Bytes per Character 1 Ordering Information ? Comments Contains Japanese katakana characters. end start Short Description JIS X0208:1978 Japanese Kanji Graphic Characters Registered Value 0x00030004 Character Set ID(s) 0x0081 Max Bytes per Character 2 Ordering Information ? Comments Contains approximately 6350 Japanese Kanji characters. end start Short Description JIS X0208:1983 Japanese Kanji Graphic Characters Registered Value 0x00030005 Character Set ID(s) 0x0081 Max Bytes per Character 2 Ordering Information ? Comments Contains approximately 6350 Japanese Kanji characters. Revised version of JIS X0208:1978. end start Short Description JIS X0208:1990 Japanese Kanji Graphic Characters Registered Value 0x00030006 Character Set ID(s) 0x0081 Max Bytes per Character 2 Ordering Information ? Comments Contains approximately 6350 Japanese Kanji characters. Revised version of JIS X0208:1983. end start Short Description JIS X0212:1990; Supplementary Japanese Kanji Graphic Chars Registered Value 0x0003000a Character Set ID(s) 0x0082 Max Bytes per Character 2 Ordering Information ? Comments Contains approximately 6100 Japanese Kanji characters. end start Short Description JIS eucJP:1993; Japanese EUC Registered Value 0x00030010 Character Set ID(s) 0x0011:0x0080:0x0081:0x0082 Max Bytes per Character 3 Ordering Information ? Comments Implementation of the EUC (Extended UNIX Codes) encoding method, with ISO 646:1991 IRV assigned to CS0, JIS X0208:1990 assigned to CS1, JIS X0201:1976 assigned to CS2, and JIS X0212:1990 assigned to CS3. end ################################################################### # KS # Organization ID: 0x0004 ################################################################### start Short Description KS C5601:1987; Korean Hangul and Hanja Graphic Characters Registered Value 0x00040001 Character Set ID(s) 0x0100 Max Bytes per Character 2 Ordering Information ? Comments Contains 2,350 Hangul syllables and approximately 6,000 Hanja ideographs. end start Short Description KS C5657:1991; Supplementary Korean Graphic Characters Registered Value 0x00040002 Character Set ID(s) 0x0101 Max Bytes per Character 2 Ordering Information ? Comments ? end start Short Description KS eucKR:1991; Korean EUC Registered Value 0x0004000a Character Set ID(s) 0x0011:0x0100:0x0101 Max Bytes per Character 2 Ordering Information ? Comments Implementation of the EUC (Extended UNIX Codes) encoding method with ISO 646:1991 IRV assigned to CS0 and KS C5601:1987 assigned to CS1. end ################################################################### # CNS # Organization ID: 0x0005 ################################################################### start Short Description CNS 11643:1986; Taiwanese Hanzi Graphic Characters Registered Value 0x00050001 Character Set ID(s) 0x0180 Max Bytes per Character 2 Ordering Information ? Comments Contains approximately 13,700 Traditional Chinese Hanzi ideographs. end start Short Description CNS 11643:1992; Taiwanese Extended Hanzi Graphic Chars Registered Value 0x00050002 Character Set ID(s) 0x0181 Max Bytes per Character 4 Ordering Information ? Comments Contains approximately 48,200 Traditional Chinese Hanzi ideographs. Revised version of CNS 11643:1986. end start Short Description CNS eucTW:1991; Taiwanese EUC Registered Value 0x0005000a Character Set ID(s) 0x0001:0x0180 Max Bytes per Character 4 Ordering Information ? Comments Implementation of the EUC (Extended UNIX Codes) encoding method with ISO 646:1991 IRV assigned to CS0 and CNS 11643:1986 assigned to CS1. end start Short Description CNS eucTW:1993; Taiwanese EUC Registered Value 0x00050010 Character Set ID(s) 0x0001:0x0181 Max Bytes per Character 4 Ordering Information ? Comments Implementation of the EUC (Extended UNIX Codes) encoding method with ISO 646:1991 IRV assigned to CS0 and CNS 11643:1992 assigned to CS1. end ################################################################### # TIS # Organization ID: 0x000b ################################################################### start Short Description TIS 620-2529, Thai characters Registered Value 0x000b0001 Character Set ID(s) 0x0200 Max Bytes per Character 1 Ordering Information ? Comments ? end ################################################################### # TTB # Organization ID: 0x000d ################################################################### start Short Description TTB CCDC:1984; Chinese Code for Data Communications Registered Value 0x000d0001 Character Set ID(s) 0x0180 Max Bytes per Character 2 Ordering Information ? Comments Defined by the Taiwan Telegraph Bureau, this code set contains 16,384 Chinese characters and was originally meant for use in teletype communications. end ########################################################## # INDUSTRY CONSORTIUM CODE SETS/ENCODING METHODS # ########################################################## ################################################################### # OSF # Organization ID: 0x0500 # # The Ordering Information for all the OSF code sets is the same. # Rather than repeat it for each entry, it is listed here: # # Code Set Registry # Open Software Foundation # 11 Cambridge Center # Cambridge, MA 02142 # USA # Email: cs_registry@osf.org # ################################################################### start Short Description OSF Japanese UJIS Registered Value 0x05000010 Character Set ID(s) 0x0001:0x0080:0x0081 Max Bytes per Character 2 Ordering Information See information provided before first OSF entry (above). Comments Implementation of the EUC (Extended UNIX Codes) encoding method with ISO 646:1991 IRV assigned to CS0, JIS X0208:1983 assigned to CS1, and JIS X0201:1976 assigned to CS2. end start Short Description OSF Japanese SJIS-1 Registered Value 0x05000011 Character Set ID(s) 0x0001:0x0080:0x0081 Max Bytes per Character 2 Ordering Information See information provided before first OSF entry (above). Comments Implementation of the Shift-JIS encoding method using ISO 646:1991 IRV, JIS X0201:1976, and JIS X0208:1983. Matches the version of SJIS available on OSF/1. end start Short Description OSF Japanese SJIS-2 Registered Value 0x05000012 Character Set ID(s) 0x0001:0x0080:0x0081 Max Bytes per Character 2 Ordering Information See information provided before first OSF entry (above). Comments Implementation of the Shift-JIS encoding method using ISO 646:1991 IRV, JIS X0201:1976, and JIS X0208:1990. end ################################################################### # X/Open # Organization ID: 0x0501 ################################################################### start Short Description X/Open UTF-8; UCS Transformation Format 8 (UTF-8) Registered Value 0x05010001 Character Set ID(s) 0x1000 Max Bytes per Character 6 Ordering Information ? Comments Multibyte compatible encoding of the repertoire of characters in ISO 10646-1. Encoding can be used on most UNIX-like file systems and OSes. Also known as FSS-UTF and UTF-2. end ################################################################### # OSF JVC # Organization ID: 0x0502 # # The Ordering Information for all the OSF JVC code sets is the same. # Rather than repeat it for each entry, it is listed here: # # Code Set Inquiries # OSF Japan Vendor Council # 2-11-10 Kita-Aoyama, Minato-ku, Tokyo 107 Japan # Email: yoshi@osf.or.jp # ################################################################### start Short Description JVC_eucJP Registered Value 0x05020001 Character Set ID(s) 0x0001:0x0080:0x0081:0x0082 Max Bytes per Character 3 Ordering Information See information provided before first OSF JVC entry (above). Comments ? end start Short Description JVC_SJIS Registered Value 0x05020002 Character Set ID(s) 0x0001:0x0080:0x0081 Max Bytes per Character 2 Ordering Information See information provided before first OSF JVC entry (above). Comments ? end ############################################################### # COMMERCIAL COMPANY CODE SETS/ENCODING METHODS # ############################################################### ################################################################### # DEC # Organization ID: 0x1000 # # The Ordering Information for all the DEC code sets is the same. # Rather than repeat it for each entry, it is listed here: # # Code Set Inquiries # ATTN: Hirofumi Onozawa # Digital Equipment Corporation Japan # Research and Development Center # 1432 Sugao, Akiruno-shi, Tokyo 197 Japan # Email: onozawa@jrd.dec.com # ################################################################### start Short Description DEC Kanji Registered Value 0x10000001 Character Set ID(s) 0x0011:0x0080:0x0081 Max Bytes per Character 2 Ordering Information See information provided before first DEC entry (above). Comments end start Short Description Super DEC Kanji Registered Value 0x10000002 Character Set ID(s) 0x0011:0x0080:0x0081:0x0082 Max Bytes per Character 3 Ordering Information See information provided before first DEC entry (above). Comments end start Short Description DEC Shift JIS Registered Value 0x10000003 Character Set ID(s) 0x0011:0x0080:0x0081 Max Bytes per Character 2 Ordering Information See information provided before first DEC entry (above). Comments end ################################################################### # HP # Organization ID: 0x1001 # # The Ordering Information for all the HP code sets is the same. # Rather than repeat it for each entry, it is listed here: # # Code Set Inquiries # ATTN: Sue Kline # Hewlett-Packard Company # 300 Apollo Drive # Chelmsford, MA 01824 # USA # Email: kline_s@apollo.hp.com # ################################################################### start Short Description HP roman8; English and Western European languages Registered Value 0x10010001 Character Set ID(s) 0x0011 Max Bytes per Character 1 Ordering Information See information provided before first HP entry (above). Comments roman8 is a 8-bit code-set comprised of ASCII and subset of ECMA-94 Latin 1. end start Short Description HP kana8; Japanese katakana (incl JIS X0201:1976) Registered Value 0x10010002 Character Set ID(s) 0x0080 Max Bytes per Character 1 Ordering Information See information provided before first HP entry (above). Comments kana8 is a 8-bit code-set comprised of JASCII and one-byte Katakana. end start Short Description HP arabic8; Arabic Registered Value 0x10010003 Character Set ID(s) 0x0016 Max Bytes per Character 1 Ordering Information See information provided before first HP entry (above). Comments arabic8 is a 8-bit code-set comprised of ASCII and a superset of ASMO 449. end start Short Description HP greek8; Greek Registered Value 0x10010004 Character Set ID(s) 0x0017 Max Bytes per Character 1 Ordering Information See information provided before first HP entry (above). Comments greek8 is a 8-bit code-set that is comprised of ASCII and characters defined in ECMA-118 Latin/Greek. However, it is not identical to ECMA-118, as different code locations are defined for some symbols. end start Short Description HP hebrew8; Hebrew Registered Value 0x10010005 Character Set ID(s) 0x0018 Max Bytes per Character 1 Ordering Information See information provided before first HP entry (above). Comments hebrew8 is a 8-bit code-set that is comprised of ASCII and characters defined in ECMA-121. However, it is not identical to ECMA-121, as different code locations are defined for some symbols. end start Short Description HP turkish8; Turkish Registered Value 0x10010006 Character Set ID(s) 0x0013:0x0019 Max Bytes per Character 1 Ordering Information See information provided before first HP entry (above). Comments turkish8 is a 8-bit code-set that is comprised of ASCII and Turkish characters. It is different than ECMA-94 Latin 3 or ECMA-128 Latin 5, as different code locations are defined for some symbols. end start Short Description HP15CN; encoding method for Simplified Chinese Registered Value 0x10010007 Character Set ID(s) 0x0001:0x0300 Max Bytes per Character 2 Ordering Information See information provided before first HP entry (above). Comments hp15CN is an encoding method which implements the Chinese national standard GB 2312-1980. This includes common Chinese characters which are sorted phonetically (Level 1), other Chinese characters which are sorted according to radical and number of strokes (Level 2), as well as special symbols and space for additional user-defined characters. end start Short Description HP big5; encoding method for Traditional Chinese Registered Value 0x10010008 Character Set ID(s) 0x0001:0x0180 Max Bytes per Character 2 Ordering Information See information provided before first HP entry (above). Comments HP big5 is an implementation of the big5 encoding method for Traditional Chinese and contains 13,052 characters from CISCII (Chinese Industrial Standard Code for Information Interchange: 1986), with 1,700 code values being reserved for user-defined characters. end start Short Description HP japanese15 (sjis); Shift-JIS for mainframe (incl JIS X0208:1990) Registered Value 0x10010009 Character Set ID(s) 0x0001:0x0080:0x0081 Max Bytes per Character 2 Ordering Information See information provided before first HP entry (above). Comments HP japanese15/sjis is the HP Shift-JIS implementation for JIS X0208:1990. It includes the set of user defined characters (UDC) and vendor defined characters (VDC) for mainframe use. end start Short Description HP sjishi; Shift-JIS for HP user (incl JIS X0208:1990) Registered Value 0x1001000a Character Set ID(s) 0x0001:0x0080:0x0081 Max Bytes per Character 2 Ordering Information See information provided before first HP entry (above). Comments sjishi is the HP Shift-JIS implementation for JIS X0208:1990. It includes the set of user defined characters (UDC) and vendor defined characters (VDC) for HP users' use. end start Short Description HP sjispc; Shift-JIS for PC (incl JIS X0208:1990) Registered Value 0x1001000b Character Set ID(s) 0x0001:0x0080:0x0081 Max Bytes per Character 2 Ordering Information See information provided before first HP entry (above). Comments HP sjispc is the HP Shift-JIS implementation for JIS X0208:1990. It includes the set of user defined characters (UDC) and vendor defined characters (VDC) for PC use. end start Short Description HP ujis; EUC (incl JIS X0208:1990) Registered Value 0x1001000c Character Set ID(s) 0x0001:0x0080:0x0081 Max Bytes per Character 2 Ordering Information See information provided before first HP entry (above). Comments HP ujis is the HP EUC implementation of the EUC (Extended UNIX Codes) encoding method with ISO 646:1991 IRV assigned to CS0, JIS X0208:1990 assigned to CS1, and JIS X0201:1976 assigned to CS2. end ################################################################### # IBM # Organization ID: 0x1002 # # The Ordering Information for all the IBM code sets is the same. # Rather than repeat it for each entry, it is listed here: # # Code Set Inquiries # ATTN: Willy Rose or Dr. V.S. Umamaheswaran # IBM Canada Laboratory # National Language Technical Centre # 1150 Eglinton Avenue East # 3R/979/1150 # North York, Ontario, Canada, M3C 1H7 # Email: wrose@vnet.ibm.com # umavs@torolab6.vnet.ibm.com # # More information on CCSIDs, and their detailed # definitions, can be obtained from the following # IBM publications: # GC09-2207 Character Data Representation Architecture # Overview # SC09-2190 Character Data Representation Architecture # Reference and Registry # # Some IBM-specific acronyms that appear in the "Short Description" # fields include: # # CCSID Coded Character Set Identifier # CECP Country Extended Code Page # DBCS Double-Byte Code Set # SBCS Single-Byte Code Set # S-Ch Simplified Chinese # T-Ch Traditional Chinese # UDC User Defined Character # ################################################################### start Short Description IBM-037 (CCSID 00037); CECP for USA, Canada, NL, Ptgl, Brazil, Australia, NZ Registered Value 0x10020025 Character Set ID(s) 0x0011 Max Bytes per Character 1 Ordering Information See information provided before first IBM entry (above). Comments ? end start Short Description IBM-273 (CCSID 00273); CECP for Austria, Germany Registered Value 0x10020111 Character Set ID(s) 0x0011 Max Bytes per Character 1 Ordering Information See information provided before first IBM entry (above). Comments ? end start Short Description IBM-277 (CCSID 00277); CECP for Denmark, Norway Registered Value 0x10020115 Character Set ID(s) 0x0011 Max Bytes per Character 1 Ordering Information See information provided before first IBM entry (above). Comments ? end start Short Description IBM-278 (CCSID 00278); CECP for Finland, Sweden Registered Value 0x10020116 Character Set ID(s) 0x0011 Max Bytes per Character 1 Ordering Information See information provided before first IBM entry (above). Comments ? end start Short Description IBM-280 (CCSID 00280); CECP for Italy Registered Value 0x10020118 Character Set ID(s) 0x0011 Max Bytes per Character 1 Ordering Information See information provided before first IBM entry (above). Comments ? end start Short Description IBM-282 (CCSID 00282); CECP for Portugal Registered Value 0x1002011a Character Set ID(s) 0x0011 Max Bytes per Character 1 Ordering Information See information provided before first IBM entry (above). Comments ? end start Short Description IBM-284 (CCSID 00284); CECP for Spain, Latin America (Spanish) Registered Value 0x1002011c Character Set ID(s) 0x0011 Max Bytes per Character 1 Ordering Information See information provided before first IBM entry (above). Comments ? end start Short Description IBM-285 (CCSID 00285); CECP for United Kingdom Registered Value 0x1002011d Character Set ID(s) 0x0011 Max Bytes per Character 1 Ordering Information See information provided before first IBM entry (above). Comments ? end start Short Description IBM-290 (CCSID 00290); Japanese Katakana Host Ext SBCS Registered Value 0x10020122 Character Set ID(s) 0x0080 Max Bytes per Character 1 Ordering Information See information provided before first IBM entry (above). Comments ? end start Short Description IBM-297 (CCSID 00297); CECP for France Registered Value 0x10020129 Character Set ID(s) 0x0011 Max Bytes per Character 1 Ordering Information See information provided before first IBM entry (above). Comments ? end start Short Description IBM-300 (CCSID 00300); Japanese Host DBCS incl 4370 UDC Registered Value 0x1002012c Character Set ID(s) 0x0081 Max Bytes per Character 2 Ordering Information See information provided before first IBM entry (above). Comments ? end start Short Description IBM-301 (CCSID 00301); Japanese PC Data DBCS incl 1880 UDC Registered Value 0x1002012d Character Set ID(s) 0x0081 Max Bytes per Character 2 Ordering Information See information provided before first IBM entry (above). Comments ? end start Short Description IBM-420 (CCSID 00420); Arabic (presentation shapes) Registered Value 0x100201a4 Character Set ID(s) 0x0016 Max Bytes per Character 1 Ordering Information See information provided before first IBM entry (above). Comments ? end start Short Description IBM-424 (CCSID 00424); Hebrew Registered Value 0x100201a8 Character Set ID(s) 0x0018 Max Bytes per Character 1 Ordering Information See information provided before first IBM entry (above). Comments ? end start Short Description IBM-437 (CCSID 00437); PC USA Registered Value 0x100201b5 Character Set ID(s) 0x0011 Max Bytes per Character 1 Ordering Information See information provided before first IBM entry (above). Comments ? end start Short Description IBM-500 (CCSID 00500); CECP for Belgium, Switzerland Registered Value 0x100201f4 Character Set ID(s) 0x0011 Max Bytes per Character 1 Ordering Information See information provided before first IBM entry (above). Comments ? end start Short Description IBM-833 (CCSID 00833); Korean Host Extended SBCS Registered Value 0x10020341 Character Set ID(s) 0x0001 Max Bytes per Character 1 Ordering Information See information provided before first IBM entry (above). Comments ? end start Short Description IBM-834 (CCSID 00834); Korean Host DBCS incl 1227 UDC Registered Value 0x10020342 Character Set ID(s) 0x0100 Max Bytes per Character 2 Ordering Information See information provided before first IBM entry (above). Comments ? end start Short Description IBM-835 (CCSID 00835); T-Ch Host DBCS incl 6204 UDC Registered Value 0x10020343 Character Set ID(s) 0x0180 Max Bytes per Character 2 Ordering Information See information provided before first IBM entry (above). Comments ? end start Short Description IBM-836 (CCSID 00836); S-Ch Host Extended SBCS Registered Value 0x10020344 Character Set ID(s) 0x0001 Max Bytes per Character 1 Ordering Information See information provided before first IBM entry (above). Comments ? end start Short Description IBM-837 (CCSID 00837); S-Ch Host DBCS incl 1880 UDC Registered Value 0x10020345 Character Set ID(s) 0x0300 Max Bytes per Character 2 Ordering Information See information provided before first IBM entry (above). Comments ? end start Short Description IBM-838 (CCSID 00838); Thai Host Extended SBCS Registered Value 0x10020346 Character Set ID(s) 0x0200 Max Bytes per Character 1 Ordering Information See information provided before first IBM entry (above). Comments ? end start Short Description IBM-839 (CCSID 00839); Thai Host DBCS incl 374 UDC Registered Value 0x10020347 Character Set ID(s) 0x0200 Max Bytes per Character 2 Ordering Information See information provided before first IBM entry (above). Comments ? end start Short Description IBM-850 (CCSID 00850); Multilingual IBM PC Data-MLP 222 Registered Value 0x10020352 Character Set ID(s) 0x0011 Max Bytes per Character 1 Ordering Information See information provided before first IBM entry (above). Comments ? end start Short Description IBM-852 (CCSID 00852); Multilingual Latin-2 Registered Value 0x10020354 Character Set ID(s) 0x0012 Max Bytes per Character 1 Ordering Information See information provided before first IBM entry (above). Comments ? end start Short Description IBM-855 (CCSID 00855); Cyrillic PC Data Registered Value 0x10020357 Character Set ID(s) 0x0015 Max Bytes per Character 1 Ordering Information See information provided before first IBM entry (above). Comments ? end start Short Description IBM-856 (CCSID 00856); Hebrew PC Data (extensions) Registered Value 0x10020358 Character Set ID(s) 0x0018 Max Bytes per Character 1 Ordering Information See information provided before first IBM entry (above). Comments ? end start Short Description IBM-857 (CCSID 00857); Turkish Latin-5 PC Data Registered Value 0x10020359 Character Set ID(s) 0x0019 Max Bytes per Character 1 Ordering Information See information provided before first IBM entry (above). Comments ? end start Short Description IBM-861 (CCSID 00861); PC Data Iceland Registered Value 0x1002035d Character Set ID(s) 0x0011 Max Bytes per Character 1 Ordering Information See information provided before first IBM entry (above). Comments ? end start Short Description IBM-862 (CCSID 00862); PC Data Hebrew Registered Value 0x1002035e Character Set ID(s) 0x0018 Max Bytes per Character 1 Ordering Information See information provided before first IBM entry (above). Comments ? end start Short Description IBM-863 (CCSID 00863); PC Data Canadian French Registered Value 0x1002035f Character Set ID(s) 0x0011 Max Bytes per Character 1 Ordering Information See information provided before first IBM entry (above). Comments ? end start Short Description IBM-864 (CCSID 00864); Arabic PC Data Registered Value 0x10020360 Character Set ID(s) 0x0016 Max Bytes per Character 1 Ordering Information See information provided before first IBM entry (above). Comments ? end start Short Description IBM-866 (CCSID 00866); PC Data Cyrillic 2 Registered Value 0x10020362 Character Set ID(s) 0x0015 Max Bytes per Character 1 Ordering Information See information provided before first IBM entry (above). Comments ? end start Short Description IBM-868 (CCSID 00868); Urdu PC Data Registered Value 0x10020364 Character Set ID(s) 0x0016 Max Bytes per Character 1 Ordering Information See information provided before first IBM entry (above). Comments ? end start Short Description IBM-869 (CCSID 00869); Greek PC Data Registered Value 0x10020365 Character Set ID(s) 0x0017 Max Bytes per Character 1 Ordering Information See information provided before first IBM entry (above). Comments ? end start Short Description IBM-870 (CCSID 00870); Multilingual Latin-2 EBCDIC Registered Value 0x10020366 Character Set ID(s) 0x0012 Max Bytes per Character 1 Ordering Information See information provided before first IBM entry (above). Comments ? end start Short Description IBM-871 (CCSID 00871); CECP for Iceland Registered Value 0x10020367 Character Set ID(s) 0x0011 Max Bytes per Character 1 Ordering Information See information provided before first IBM entry (above). Comments ? end start Short Description IBM-874 (CCSID 00874); Thai PC Display Extended SBCS Registered Value 0x1002036a Character Set ID(s) 0x0200 Max Bytes per Character 1 Ordering Information See information provided before first IBM entry (above). Comments ? end start Short Description IBM-875 (CCSID 00875); Greek Registered Value 0x1002036b Character Set ID(s) 0x0017 Max Bytes per Character 1 Ordering Information See information provided before first IBM entry (above). Comments ? end start Short Description IBM-880 (CCSID 00880); Multilingual Cyrillic Registered Value 0x10020370 Character Set ID(s) 0x0015 Max Bytes per Character 1 Ordering Information See information provided before first IBM entry (above). Comments ? end start Short Description IBM-891 (CCSID 00891); Korean PC Data SBCS Registered Value 0x1002037b Character Set ID(s) 0x0001 Max Bytes per Character 1 Ordering Information See information provided before first IBM entry (above). Comments ? end start Short Description IBM-896 (CCSID 00896); Japanese Katakana characters; superset of JIS X0201:1976 Registered Value 0x10020380 Character Set ID(s) 0x0080 Max Bytes per Character 1 Ordering Information See information provided before first IBM entry (above). Comments ? end start Short Description IBM-897 (CCSID 00897); PC Data Japanese SBCS (use with CP 00301) Registered Value 0x10020381 Character Set ID(s) 0x0080 Max Bytes per Character 1 Ordering Information See information provided before first IBM entry (above). Comments ? end start Short Description IBM-903 (CCSID 00903); PC Data Simplified Chinese SBCS (use with DBCS) Registered Value 0x10020387 Character Set ID(s) 0x0001 Max Bytes per Character 1 Ordering Information See information provided before first IBM entry (above). Comments ? end start Short Description IBM-904 (CCSID 00904); PC Data Traditional Chinese SBCS (use with DBCS) Registered Value 0x10020388 Character Set ID(s) 0x0001 Max Bytes per Character 1 Ordering Information See information provided before first IBM entry (above). Comments ? end start Short Description IBM-918 (CCSID 00918); Urdu Registered Value 0x10020396 Character Set ID(s) 0x0016 Max Bytes per Character 1 Ordering Information See information provided before first IBM entry (above). Comments ? end start Short Description IBM-921 (CCSID 00921); Baltic 8-Bit Registered Value 0x10020399 Character Set ID(s) 0x001a Max Bytes per Character 1 Ordering Information See information provided before first IBM entry (above). Comments Will be used to represent the new encoding for Baltic countries to use the Lithuanian and Latvian standards. Not registered with ISO yet. end start Short Description IBM-922 (CCSID 00922); Estonia 8-Bit Registered Value 0x1002039a Character Set ID(s) 0x001a Max Bytes per Character 1 Ordering Information See information provided before first IBM entry (above). Comments Will be used to represent the new encoding for Estonia to use its new Estonian standard. Not registered as on eof the ISO 8859 family on its own. end start Short Description IBM-926 (CCSID 00926); Korean PC Data DBCS incl 1880 UDC Registered Value 0x1002039e Character Set ID(s) 0x0100 Max Bytes per Character 2 Ordering Information See information provided before first IBM entry (above). Comments Incorporated in the IBM-944 as the DBCS component. end start Short Description IBM-927 (CCSID 00927); T-Ch PC Data DBCS incl 6204 UDC Registered Value 0x1002039f Character Set ID(s) 0x0180 Max Bytes per Character 2 Ordering Information See information provided before first IBM entry (above). Comments ? end start Short Description IBM-928 (CCSID 00928); S-Ch PC Data DBCS incl 1880 UDC Registered Value 0x100203a0 Character Set ID(s) 0x0300 Max Bytes per Character 2 Ordering Information See information provided before first IBM entry (above). Comments Incorporated in the IBM-946 as the DBCS component. end start Short Description IBM-929 (CCSID 00929); Thai PC Data DBCS incl 374 UDC Registered Value 0x100203a1 Character Set ID(s) 0x0200 Max Bytes per Character 2 Ordering Information See information provided before first IBM entry (above). Comments ? end start Short Description IBM-930 (CCSID 00930); Kat-Kanji Host MBCS Ext-SBCS Registered Value 0x100203a2 Character Set ID(s) 0x0080:0x0081 Max Bytes per Character 2 Ordering Information See information provided before first IBM entry (above). Comments ? end start Short Description IBM-932 (CCSID 00932); Japanese PC Data Mixed Registered Value 0x100203a4 Character Set ID(s) 0x0080:0x0081 Max Bytes per Character 2 Ordering Information See information provided before first IBM entry (above). Comments Combination of IBM-897 and IBM-301, use IBM-942 as superset. For SJIS support of JIS X0208-1978 level. end start Short Description IBM-933 (CCSID 00933); Korean Host Extended SBCS Registered Value 0x100203a5 Character Set ID(s) 0x0001:0x0100 Max Bytes per Character 2 Ordering Information See information provided before first IBM entry (above). Comments Combination of IBM-833 and IBM-834. end start Short Description IBM-934 (CCSID 00934); Korean PC Data Mixed Registered Value 0x100203a6 Character Set ID(s) 0x0001:0x0100 Max Bytes per Character 2 Ordering Information See information provided before first IBM entry (above). Comments Combination of IBM-891 and IBM-926, includes 1880 UDC, use IBM-944 as a superset. end start Short Description IBM-935 (CCSID 00935); S-Ch Host Mixed Registered Value 0x100203a7 Character Set ID(s) 0x0001:0x0300 Max Bytes per Character 2 Ordering Information See information provided before first IBM entry (above). Comments Combination of IBM-836 and IBM-837, includes 1880 UDC. end start Short Description IBM-936 (CCSID 00936); PC Data S-Ch MBCS Registered Value 0x100203a8 Character Set ID(s) 0x0001:0x0300 Max Bytes per Character 2 Ordering Information See information provided before first IBM entry (above). Comments Combination of IBM-903 and IBM-928 includes 1880 UDC, use IBM-946 as a superset. end start Short Description IBM-937 (CCSID 00937); T-Ch Host Mixed Registered Value 0x100203a9 Character Set ID(s) 0x0001:0x0180 Max Bytes per Character 2 Ordering Information See information provided before first IBM entry (above). Comments Combination of IBM-037 and IBM-835 includes 6204 UDC. end start Short Description IBM-938 (CCSID 00938); PC Data T-Ch MBCS Registered Value 0x100203aa Character Set ID(s) 0x0001:0x0180 Max Bytes per Character 2 Ordering Information See information provided before first IBM entry (above). Comments Combination of IBM-904 and IBM-927 includes 6204 UDC, use IBM-948 as a superset. end start Short Description IBM-939 (CCSID 00939); Latin-Kanji Host MBCS Registered Value 0x100203ab Character Set ID(s) 0x0080:0x0081 Max Bytes per Character 2 Ordering Information See information provided before first IBM entry (above). Comments Combination of IBM-1027 and IBM-300 includes 4370 UDC Ext SBCS. end start Short Description IBM-941 (CCSID 00941); Japanese PC DBCS for Open Registered Value 0x100203ad Character Set ID(s) 0x0081 Max Bytes per Character 2 Ordering Information See information provided before first IBM entry (above). Comments ? end start Short Description IBM-942 (CCSID 00942); Japanese PC Data Mixed Registered Value 0x100203ae Character Set ID(s) 0x0080:0x0081 Max Bytes per Character 2 Ordering Information See information provided before first IBM entry (above). Comments Combination of IBM-1041 and IBM-301, 1880 UDC Extended SBCS. end start Short Description IBM-943 (CCSID 00943); Japanese PC MBCS for Open Registered Value 0x100203af Character Set ID(s) 0x0080:0x0081 Max Bytes per Character 2 Ordering Information See information provided before first IBM entry (above). Comments Combination of IBM-1041 and IBM-941, 1880 UDC. For SJIS support at the JIS X0208-1990 level. end start Short Description IBM-946 (CCSID 00946); S-Ch PC Data Mixed Registered Value 0x100203b2 Character Set ID(s) 0x0001:0x0300 Max Bytes per Character 2 Ordering Information See information provided before first IBM entry (above). Comments Combination of IBM-1042 and IBM-928 includes 1880 UDC. end start Short Description IBM-947 (CCSID 00947); T-Ch PC Data DBCS incl 6204 UDC Registered Value 0x100203b3 Character Set ID(s) 0x0180 Max Bytes per Character 2 Ordering Information See information provided before first IBM entry (above). Comments ? end start Short Description IBM-948 (CCSID 00948); T-Ch PC Data Mixed Registered Value 0x100203b4 Character Set ID(s) 0x0001:0x0180 Max Bytes per Character 2 Ordering Information See information provided before first IBM entry (above). Comments Combination of IBM-1043 and IBM-927 includes 6204 UDC. end start Short Description IBM-949 (CCSID 00949); IBM KS PC Data Mixed Registered Value 0x100203b5 Character Set ID(s) 0x0001:0x0100 Max Bytes per Character 2 Ordering Information See information provided before first IBM entry (above). Comments Combination of IBM-1088 and IBM-951 includes 1880 UDC. end start Short Description IBM-950 (CCSID 00950); T-Ch PC Data Mixed Registered Value 0x100203b6 Character Set ID(s) 0x0001:0x0180 Max Bytes per Character 2 Ordering Information See information provided before first IBM entry (above). Comments Combination of IBM-1114 and IBM-947 includes 6204 UDC. end start Short Description IBM-951 (CCSID 00951); IBM KS PC Data DBCS incl 1880 UDC Registered Value 0x100203b7 Character Set ID(s) 0x0100 Max Bytes per Character 2 Ordering Information See information provided before first IBM entry (above). Comments ? end start Short Description IBM-955 (CCSID 00955); Japan Kanji characters; superset of JIS X0208:1978 Registered Value 0x100203bb Character Set ID(s) 0x0081 Max Bytes per Character 2 Ordering Information See information provided before first IBM entry (above). Comments ? end start Short Description IBM-964 (CCSID 00964); T-Chinese EUC CNS1163 plane 1,2 Registered Value 0x100203c4 Character Set ID(s) 0x0001:0x0180 Max Bytes per Character 4 Ordering Information See information provided before first IBM entry (above). Comments Combination of IBM-367, IBM-960, IBM-961, ASCII + CNS-11643 P1,P2. end start Short Description IBM-970 (CCSID 00970); Korean EUC Registered Value 0x100203ca Character Set ID(s) 0x0011:0x0100:0x0101 Max Bytes per Character 2 Ordering Information See information provided before first IBM entry (above). Comments Combination of IBM-367, IBM-971, ASCII + KS-5601:1989 with 188 UDC. end start Short Description IBM-1006 (CCSID 01006); Urdu 8-bit Registered Value 0x100203ee Character Set ID(s) 0x0016 Max Bytes per Character 1 Ordering Information See information provided before first IBM entry (above). Comments ? end start Short Description IBM-1025 (CCSID 01025); Cyrillic Multilingual Registered Value 0x10020401 Character Set ID(s) 0x0015 Max Bytes per Character 1 Ordering Information See information provided before first IBM entry (above). Comments ? end start Short Description IBM-1026 (CCSID 01026); Turkish Latin-5 Registered Value 0x10020402 Character Set ID(s) 0x0019 Max Bytes per Character 1 Ordering Information See information provided before first IBM entry (above). Comments ? end start Short Description IBM-1027 (CCSID 01027); Japanese Latin Host Ext SBCS Registered Value 0x10020403 Character Set ID(s) 0x0080 Max Bytes per Character 1 Ordering Information See information provided before first IBM entry (above). Comments ? end start Short Description IBM-1040 (CCSID 01040); Korean PC Data Extended SBCS Registered Value 0x10020410 Character Set ID(s) 0x0001 Max Bytes per Character 1 Ordering Information See information provided before first IBM entry (above). Comments ? end start Short Description IBM-1041 (CCSID 01041); Japanese PC Data Extended SBCS Registered Value 0x10020411 Character Set ID(s) 0x0080 Max Bytes per Character 1 Ordering Information See information provided before first IBM entry (above). Comments ? end start Short Description IBM-1043 (CCSID 01043); T-Ch PC Data Extended SBCS Registered Value 0x10020413 Character Set ID(s) 0x0001 Max Bytes per Character 1 Ordering Information See information provided before first IBM entry (above). Comments ? end start Short Description IBM-1046 (CCSID 01046); Arabic PC Data Registered Value 0x10020416 Character Set ID(s) 0x0016 Max Bytes per Character 1 Ordering Information See information provided before first IBM entry (above). Comments ? end start Short Description IBM-1047 (CCSID 01047); Latin-1 Open System Registered Value 0x10020417 Character Set ID(s) 0x0011 Max Bytes per Character 1 Ordering Information See information provided before first IBM entry (above). Comments Latin-1 based encoding supporting C/370 compiler character set. end start Short Description IBM-1088 (CCSID 01088); IBM KS Code PC Data SBCS Registered Value 0x10020440 Character Set ID(s) 0x0001 Max Bytes per Character 1 Ordering Information See information provided before first IBM entry (above). Comments ? end start Short Description IBM-1097 (CCSID 01097); Farsi Registered Value 0x10020449 Character Set ID(s) 0x0016 Max Bytes per Character 1 Ordering Information See information provided before first IBM entry (above). Comments ? end start Short Description IBM-1098 (CCSID 01098); Farsi PC Data Registered Value 0x1002044a Character Set ID(s) 0x0016 Max Bytes per Character 1 Ordering Information See information provided before first IBM entry (above). Comments ? end start Short Description IBM-1112 (CCSID 01112); Baltic Multilingual Registered Value 0x10020458 Character Set ID(s) 0x001a Max Bytes per Character 1 Ordering Information See information provided before first IBM entry (above). Comments New support will include the Lithuanian and Latvian standards, not yet registered as part of the ISO 8859 family. end start Short Description IBM-1114 (CCSID 01114); T-Ch PC Data SBCS (IBM BIG-5) Registered Value 0x1002045a Character Set ID(s) 0x0001 Max Bytes per Character 1 Ordering Information See information provided before first IBM entry (above). Comments ? end start Short Description IBM-1115 (CCSID 01115); S-Ch PC Data SBCS (IBM GB) Registered Value 0x1002045b Character Set ID(s) 0x0001 Max Bytes per Character 1 Ordering Information See information provided before first IBM entry (above). Comments With 5 SAA SB characters. end start Short Description IBM-1122 (CCSID 01122); Estonia Registered Value 0x10020462 Character Set ID(s) 0x001a Max Bytes per Character 1 Ordering Information See information provided before first IBM entry (above). Comments New support will include characters from the Estonian standards, as yet not registered as a member of the ISO 8859 family. end start Short Description IBM-1250 (CCSID 01250); MS Windows Latin-2 Registered Value 0x100204e2 Character Set ID(s) 0x0012 Max Bytes per Character 1 Ordering Information See information provided before first IBM entry (above). Comments ? end start Short Description IBM-1251 (CCSID 01251); MS Windows Cyrillic Registered Value 0x100204e3 Character Set ID(s) 0x0015 Max Bytes per Character 1 Ordering Information See information provided before first IBM entry (above). Comments ? end start Short Description IBM-1252 (CCSID 01252); MS Windows Latin-1 Registered Value 0x100204e4 Character Set ID(s) 0x0011 Max Bytes per Character 1 Ordering Information See information provided before first IBM entry (above). Comments ? end start Short Description IBM-1253 (CCSID 01253); MS Windows Greek Registered Value 0x100204e5 Character Set ID(s) 0x0017 Max Bytes per Character 1 Ordering Information See information provided before first IBM entry (above). Comments ? end start Short Description IBM-1254 (CCSID 01254); MS Windows Turkey Registered Value 0x100204e6 Character Set ID(s) 0x0019 Max Bytes per Character 1 Ordering Information See information provided before first IBM entry (above). Comments ? end start Short Description IBM-1255 (CCSID 01255); MS Windows Hebrew Registered Value 0x100204e7 Character Set ID(s) 0x0018 Max Bytes per Character 1 Ordering Information See information provided before first IBM entry (above). Comments ? end start Short Description IBM-1256 (CCSID 01256); MS Windows Arabic Registered Value 0x100204e8 Character Set ID(s) 0x0016 Max Bytes per Character 1 Ordering Information See information provided before first IBM entry (above). Comments ? end start Short Description IBM-1257 (CCSID 01257); MS Windows Baltic Registered Value 0x100204e9 Character Set ID(s) 0x001a Max Bytes per Character 1 Ordering Information See information provided before first IBM entry (above). Comments ? end start Short Description IBM-1380 (CCSID 01380); S-Ch PC Data DBCS incl 1880 UDC Registered Value 0x10020564 Character Set ID(s) 0x0300 Max Bytes per Character 2 Ordering Information See information provided before first IBM entry (above). Comments IBM GB, includes 1880 UDC and 31 IBM selected. end start Short Description IBM-1381 (CCSID 01381); S-Ch PC Data Mixed incl 1880 UDC Registered Value 0x10020565 Character Set ID(s) 0x0001:0x0300 Max Bytes per Character 2 Ordering Information See information provided before first IBM entry (above). Comments Combination of IBM-1115 and IBM-1380 includes 1880 UDC. end start Short Description IBM-1383 (CCSID 01383); S-Ch EUC GB 2312-80 set (1382) Registered Value 0x10020567 Character Set ID(s) 0x0001:0x0300 Max Bytes per Character 3 Ordering Information See information provided before first IBM entry (above). Comments Combination of IBM-367 and IBM-1382, ASCII + GB2312-80 set. end start Short Description IBM-300 (CCSID 04396); Japanese Host DBCS incl 1880 UDC Registered Value 0x1002112c Character Set ID(s) 0x0081 Max Bytes per Character 2 Ordering Information See information provided before first IBM entry (above). Comments ? end start Short Description IBM-850 (CCSID 04946); Multilingual IBM PC Data-190 Registered Value 0x10021352 Character Set ID(s) 0x0011 Max Bytes per Character 1 Ordering Information See information provided before first IBM entry (above). Comments Subset of full 850, includes cs697 for CECP support. end start Short Description IBM-852 (CCSID 04948); Latin-2 Personal Computer Registered Value 0x10021354 Character Set ID(s) 0x0012 Max Bytes per Character 1 Ordering Information See information provided before first IBM entry (above). Comments ? end start Short Description IBM-855 (CCSID 04951); Cyrillic Personal Computer Registered Value 0x10021357 Character Set ID(s) 0x0015 Max Bytes per Character 1 Ordering Information See information provided before first IBM entry (above). Comments ? end start Short Description IBM-856 (CCSID 04952); Hebrew PC Data Registered Value 0x10021358 Character Set ID(s) 0x0018 Max Bytes per Character 1 Ordering Information See information provided before first IBM entry (above). Comments ? end start Short Description IBM-857 (CCSID 04953); Turkish Latin-5 PC Data Registered Value 0x10021359 Character Set ID(s) 0x0019 Max Bytes per Character 1 Ordering Information See information provided before first IBM entry (above). Comments ? end start Short Description IBM-864 (CCSID 04960); Arabic PC Data (all shapes) Registered Value 0x10021360 Character Set ID(s) 0x0016 Max Bytes per Character 1 Ordering Information See information provided before first IBM entry (above). Comments ? end start Short Description IBM-868 (CCSID 04964); PC Data for Urdu Registered Value 0x10021364 Character Set ID(s) 0x0016 Max Bytes per Character 1 Ordering Information See information provided before first IBM entry (above). Comments ? end start Short Description IBM-869 (CCSID 04965); Greek PC Data Registered Value 0x10021365 Character Set ID(s) 0x0017 Max Bytes per Character 1 Ordering Information See information provided before first IBM entry (above). Comments ? end start Short Description IBM-5026 (CCSID 05026); Japanese Katakana-Kanji Host Mixed Registered Value 0x100213a2 Character Set ID(s) 0x0080:0x0081 Max Bytes per Character 2 Ordering Information See information provided before first IBM entry (above). Comments Combination of IBM-290 and IBM-300, includes 1880 UDC Extended SBCS. end start Short Description IBM-5031 (CCSID 05031); S-Ch Host MBCS Registered Value 0x100213a7 Character Set ID(s) 0x0001:0x0300 Max Bytes per Character 2 Ordering Information See information provided before first IBM entry (above). Comments Combination of IBM-836 and IBM-837, includes 1880 UDC Extended SBCS. end start Short Description IBM-1027 and -300 (CCSID 05035); Japanese Latin-Kanji Host Mixed Registered Value 0x100213ab Character Set ID(s) 0x0080:0x0081 Max Bytes per Character 2 Ordering Information See information provided before first IBM entry (above). Comments Combination of IBM-1027 and IBM-300, 1880 UDC Extended SBCS, Host Mixed. end start Short Description IBM-5048 (CCSID 05048); Japanese Kanji characters; superset of JIS X0208:1990 (and 1983) Registered Value 0x100213b8 Character Set ID(s) 0x0081 Max Bytes per Character 2 Ordering Information See information provided before first IBM entry (above). Comments ? end start Short Description IBM-5049 (CCSID 05049); Japanese Kanji characters; superset of JIS X0212:1990 Registered Value 0x100213b9 Character Set ID(s) 0x0082 Max Bytes per Character 2 Ordering Information See information provided before first IBM entry (above). Comments ? end start Short Description IBM-5067 (CCSID 05067); Korean Hangul and Hanja; superset of KS C5601:1987 Registered Value 0x100213cb Character Set ID(s) 0x0100 Max Bytes per Character 2 Ordering Information See information provided before first IBM entry (above). Comments ? end start Short Description IBM-420 (CCSID 08612); Arabic (base shapes only) Registered Value 0x100221a4 Character Set ID(s) 0x0016 Max Bytes per Character 1 Ordering Information See information provided before first IBM entry (above). Comments ? end start Short Description IBM-833 (CCSID 09025); Korean Host SBCS Registered Value 0x10022341 Character Set ID(s) 0x0001 Max Bytes per Character 1 Ordering Information See information provided before first IBM entry (above). Comments ? end start Short Description IBM-834 (CCSID 09026); Korean Host DBCS incl 1880 UDC Registered Value 0x10022342 Character Set ID(s) 0x0100 Max Bytes per Character 2 Ordering Information See information provided before first IBM entry (above). Comments ? end start Short Description IBM-838 (CCSID 09030); Thai Host Extended SBCS Registered Value 0x10022346 Character Set ID(s) 0x0200 Max Bytes per Character 1 Ordering Information See information provided before first IBM entry (above). Comments ? end start Short Description IBM-864 (CCSID 09056); Arabic PC Data (unshaped) Registered Value 0x10022360 Character Set ID(s) 0x0016 Max Bytes per Character 1 Ordering Information See information provided before first IBM entry (above). Comments ? end start Short Description IBM-874 (CCSID 09066); Thai PC Display Extended SBCS Registered Value 0x1002236a Character Set ID(s) 0x0200 Max Bytes per Character 1 Ordering Information See information provided before first IBM entry (above). Comments ? end start Short Description IBM-9125 (CCSID 09125); Korean Host Mixed incl 1880 UDC Registered Value 0x100223a5 Character Set ID(s) 0x0001:0x0100 Max Bytes per Character 2 Ordering Information See information provided before first IBM entry (above). Comments Combination of IBM-833 and IBM-834 includes 1880 UDC. end start Short Description IBM-850 (CCSID 25426); Multilingual IBM PC Display-MLP Registered Value 0x10026352 Character Set ID(s) 0x0011 Max Bytes per Character 1 Ordering Information See information provided before first IBM entry (above). Comments ? end start Short Description IBM-856 (CCSID 25432); Hebrew PC Display (extensions) Registered Value 0x10026358 Character Set ID(s) 0x0018 Max Bytes per Character 1 Ordering Information See information provided before first IBM entry (above). Comments ? end start Short Description IBM-1042 (CCSID 25618); S-Ch PC Display Ext SBCS Registered Value 0x10026412 Character Set ID(s) 0x0001 Max Bytes per Character 1 Ordering Information See information provided before first IBM entry (above). Comments ? end start Short Description IBM-037 (CCSID 28709); T-Ch Host Extended SBCS Registered Value 0x10027025 Character Set ID(s) 0x0001 Max Bytes per Character 1 Ordering Information See information provided before first IBM entry (above). Comments ? end start Short Description IBM-856 (CCSID 33624); Hebrew PC Display Registered Value 0x10028358 Character Set ID(s) 0x0018 Max Bytes per Character 1 Ordering Information See information provided before first IBM entry (above). Comments ? end start Short Description IBM33722 (CCSID 33722); Japanese EUC JISx201,208,212 Registered Value 0x100283ba Character Set ID(s) 0x0080:0x0081:0x0082 Max Bytes per Character 3 Ordering Information See information provided before first IBM entry (above). Comments ? end ################################################################### # Hitachi # Organization ID: 0x1003 # # The Ordering Information for all the Hitachi code sets is the same. # Rather than repeat it for each entry, it is listed here: # # Kimitoshi Yamada # TYG 11th Bldg. # 16-1 3-Chome, Nakamachi # Atsugi-shi 243, Japan # Fax: +81-462-25-9390 # Email: hitsoft!cs.registry@hi.com # ################################################################### start Short Description HTCsjis; Hitachi SJIS 90-1 Registered Value 0x10030001 Character Set ID(s) 0x0001:0x0080:0x0081 Max Bytes per Character 2 Ordering Information See information provided before first Hitachi entry (above). Comments Hitachi SJIS 90-1 is Shift JIS encoding mothod. It includes standard character sets of ASCII, JIS X0208:1990 and JIS X0201:1976, and proprietary of Hitachi Vender Define Character set. end start Short Description HTCujis; Hitachi eucJP 90-1 Registered Value 0x10030002 Character Set ID(s) 0x0001:0x0080:0x0081 Max Bytes per Character 2 Ordering Information See information provided before first Hitachi entry (above). Comments Hitachi eucJP 90-1 is Japanese EUC encoding mothod. It includes standard character sets of ASCII, JIS X0208:1990 and JIS X0201:1976, and proprietary of Hitachi Vender Define Character set. end ################################################################### # Fujitsu # Organization ID: 0x1004 # # The Ordering Information for all the Fujitsu code sets is the same. # Rather than repeat it for each entry, it is listed here: # # Masahiro Sekiguchi # FUJITSU LIMITED # Nikko Fudosan Bldg. # 15-16, Shinyokohama 2-chome # Kohoku-ku, Yokohama 222-0033, Japan # Email: seki@sysrap.cs.fujitsu.co.jp # ################################################################### start Short Description Fujitsu U90; Japanese EUC Registered Value 0x10040001 Character Set ID(s) 0x0001:0x0080:0x0081 Max Bytes per Character 3 Ordering Information See information provided before first Fujitsu entry (above). Comments A version of Japanese EUC, consisting of ASCII, JIS X0201 Katakana, JIS X0208:1990, Fujitsu proprietary extension, and user-definable characters. end start Short Description Fujitsu S90; Japanese EUC Registered Value 0x10040002 Character Set ID(s) 0x0001:0x0080:0x0081 Max Bytes per Character 3 Ordering Information See information provided before first Fujitsu entry (above). Comments A version of Japanese EUC, consisting of ASCII, JIS X0201 Katakana, JIS X0208:1990, and user-definable characters. end start Short Description Fujitsu R90; Fujitsu Shift JIS Registered Value 0x10040003 Character Set ID(s) 0x0001:0x0080:0x0081 Max Bytes per Character 2 Ordering Information See information provided before first Fujitsu entry (above). Comments A version of Shift JIS, consisting of ASCII, JIS X0201 Katakana, JIS X0208:1990, Fujitsu proprietary extension, and user-definable characters. end start Short Description EBCDIC(ASCII) and JEF; Japanese encoding method for mainframe Registered Value 0x10040004 Character Set ID(s) 0x0001:0x0081 Max Bytes per Character 3 Ordering Information See information provided before first Fujitsu entry (above). Comments An EBCDIC-based Japanese code set, consisting of ASCII, JIS X0208:1990, Fujitsu proprietary extension, and user-definable characters. end start Short Description EBCDIC(Katakana) and JEF; Japanese encoding method for mainframe Registered Value 0x10040005 Max Bytes per Character 3 Character Set ID(s) 0x0001:0x0080:0x0081 Ordering Information See information provided before first Fujitsu entry (above). Comments An EBCDIC-based Japanese code set, consisting of alphanumeric (upper-case Latin, digits, some symbols, but no lower-cases), JIS X0201 Katakana, JIS X0208:1990, Fujitsu proprietary extension, and user-definable characters. end start Short Description EBCDIC(Japanese English) and JEF; Japanese encoding method for mainframe Registered Value 0x10040006 Max Bytes per Character 3 Character Set ID(s) 0x0001:0x0081 Ordering Information See information provided before first Fujitsu entry (above). Comments An EBCDIC-based Japanese code set, consisting of alphanumeric (lower-case Latin, digits, some symbols, but no upper-cases), JIS X0208:1990, Fujitsu proprietary extension, and user-definable characters. end ################# # END OF FILE # ################# polyorb-2.8~20110207.orig/src/giop/polyorb-giop_p-code_sets.adb0000644000175000017500000002357011750740340023515 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . G I O P _ P . C O D E _ S E T S -- -- -- -- B o d y -- -- -- -- Copyright (C) 2004-2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with PolyORB.GIOP_P.Code_Sets.Converters; with PolyORB.GIOP_P.Code_Sets.Data; with PolyORB.Parameters; package body PolyORB.GIOP_P.Code_Sets is use PolyORB.Errors; function Is_In (List : Code_Set_Id_List; Item : Code_Set_Id) return Boolean; -- Return True iff Item is in List function Intersection (List_A, List_B : Code_Set_Id_List) return Code_Set_Id_List; -- Return list of Code_Set_Ids that exist in both List_A and List_B function Is_Compatible (Code_Set_A, Code_Set_B : Code_Set_Id) return Boolean; -- Return True iff Code_Set_A and Code_Set_B is compatible ------------------------------- -- Conversion_Char_Code_Sets -- ------------------------------- function Conversion_Char_Code_Sets return Code_Set_Id_List is begin return Converters.Supported_Char_Conversion_Code_Sets (Native_Char_Code_Set); end Conversion_Char_Code_Sets; -------------------------------- -- Conversion_Wchar_Code_Sets -- -------------------------------- function Conversion_Wchar_Code_Sets return Code_Set_Id_List is begin return Converters.Supported_Wchar_Conversion_Code_Sets (Native_Wchar_Code_Set); end Conversion_Wchar_Code_Sets; ------------------ -- Intersection -- ------------------ function Intersection (List_A, List_B : Code_Set_Id_List) return Code_Set_Id_List is use Code_Set_Id_Lists; Result : Code_Set_Id_List; Iter : Code_Set_Id_Lists.Iterator := First (List_A); begin while not Last (Iter) loop if Is_In (List_B, Value (Iter).all) then Append (Result, Value (Iter).all); end if; Next (Iter); end loop; return Result; end Intersection; ------------------- -- Is_Compatible -- ------------------- function Is_Compatible (Code_Set_A, Code_Set_B : Code_Set_Id) return Boolean is function Find_Info_Index (Code_Set : Code_Set_Id) return Natural; -- Return index of Code_Set information in table. Return 0 if -- code set is not in information table. --------------------- -- Find_Info_Index -- --------------------- function Find_Info_Index (Code_Set : Code_Set_Id) return Natural is begin for J in Data.Info'Range loop if Data.Info (J).Code_Set = Code_Set then return J; end if; end loop; return 0; end Find_Info_Index; begin pragma Assert (Code_Set_A /= Code_Set_B); declare Index_A : constant Natural := Find_Info_Index (Code_Set_A); Index_B : constant Natural := Find_Info_Index (Code_Set_B); Info_A : Code_Set_Info_Record renames Data.Info (Index_A); Info_B : Code_Set_Info_Record renames Data.Info (Index_B); begin if Index_A = 0 or else Index_B = 0 then -- No information about code set compatibility -- found. Assume code sets are incompatible. return False; end if; -- These checks are based on the knowledg of specific data -- representation in generated tables. This reduces the -- complexity of the compatibility checks in most cases. -- This check assumes that the Character_Sets table is -- "packed": if two or more code set have equal character -- sets, then this character sets sequence appears only once -- in Character_Sets table, thus First and Last indexes of -- these code sets are equal. if Info_A.First = Info_B.First and then Info_A.Last = Info_B.Last then return True; end if; -- Code sets are not compatible or data in generated tables -- not correctly prepared. -- Check that both code sets have only one character set if Info_A.Last = Info_A.First and then Info_B.Last = Info_B.First then return Data.Character_Sets (Info_A.First) = Data.Character_Sets (Info_B.First); end if; -- If one of code sets have only one character set then code -- sets are not compatible. if Info_A.Last = Info_A.First or else Info_B.Last = Info_B.First then return False; end if; -- Default case: for compatibility we require at least two -- compatible character sets. declare Count : Natural := 0; begin for J in Info_A.First .. Info_A.Last loop for K in Info_B.First .. Info_B.Last loop if Data.Character_Sets (J) = Data.Character_Sets (K) then Count := Count + 1; exit; end if; end loop; end loop; return Count >= 2; end; end; end Is_Compatible; ----------- -- Is_In -- ----------- function Is_In (List : Code_Set_Id_List; Item : Code_Set_Id) return Boolean is use Code_Set_Id_Lists; Iter : Code_Set_Id_Lists.Iterator := First (List); begin while not Last (Iter) loop if Value (Iter).all = Item then return True; end if; Next (Iter); end loop; return False; end Is_In; -------------------------- -- Native_Char_Code_Set -- -------------------------- function Native_Char_Code_Set return Code_Set_Id is begin return Code_Set_Id (PolyORB.Parameters.Get_Conf ("giop", "giop.native_char_code_set", Integer (Ada95_Native_Character_Code_Set))); end Native_Char_Code_Set; --------------------------- -- Native_Wchar_Code_Set -- --------------------------- function Native_Wchar_Code_Set return Code_Set_Id is begin return Code_Set_Id (PolyORB.Parameters.Get_Conf ("giop", "giop.native_wchar_code_set", Integer (Ada95_Native_Wide_Character_Code_Set))); end Native_Wchar_Code_Set; ------------------------ -- Negotiate_Code_Set -- ------------------------ procedure Negotiate_Code_Set (CNCS : Code_Set_Id; CCCS : Code_Set_Id_List; SNCS : Code_Set_Id; SCCS : Code_Set_Id_List; Fallback : Code_Set_Id; TCS : out Code_Set_Id; Error : in out PolyORB.Errors.Error_Container) is begin -- Implementation Note: this algorithm is defined in CORBA3 -- 13.10.2.6 Code Set Negotiation. if CNCS = SNCS then -- No conversion required TCS := CNCS; elsif Is_In (CCCS, SNCS) then -- Client converts to server's native code set TCS := SNCS; elsif Is_In (SCCS, CNCS) then -- Server converts from client's native code set TCS := CNCS; else declare Common : Code_Set_Id_List := Intersection (CCCS, SCCS); begin if Common /= Code_Set_Id_List (Code_Set_Id_Lists.Empty) then -- Client chooses TCS, from intersection, that is -- most preferable to server; client converts from -- CNCS to TCS and server from TCS to SNCS Extract_First (Common, TCS); elsif Is_Compatible (CNCS, SNCS) then -- Fallback are UTF-8 (for char data) and UTF-16 (for -- wchar data) TCS := Fallback; else -- XXX What is the minor code corresponding to this -- situation ? Throw (Error, Codeset_Incompatible_E, System_Exception_Members' (Minor => 255, Completed => Completed_No)); end if; Deallocate (Common); end; end if; end Negotiate_Code_Set; end PolyORB.GIOP_P.Code_Sets; polyorb-2.8~20110207.orig/src/giop/polyorb-protocols-giop.ads0000644000175000017500000005232311750740340023271 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . P R O T O C O L S . G I O P -- -- -- -- S p e c -- -- -- -- Copyright (C) 2002-2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with Ada.Streams; with Ada.Unchecked_Deallocation; with PolyORB.Binding_Data; with PolyORB.Buffers; with PolyORB.Errors; with PolyORB.Filters.Iface; with PolyORB.ORB; with PolyORB.QoS; with PolyORB.Representations.CDR; with PolyORB.Requests; with PolyORB.Tasking.Mutexes; with PolyORB.Transport; with PolyORB.Types; with PolyORB.Utils.Dynamic_Tables; with PolyORB.Utils.Simple_Flags; package PolyORB.Protocols.GIOP is use Ada.Streams; GIOP_Error : exception; type GIOP_Session is new Session with private; type GIOP_Protocol is abstract new Protocol with private; ------------------------ -- Version management -- ------------------------ -- ??? How about other major versions -- ??? How about other minor versions type GIOP_Version is (GIOP_V1_0, GIOP_V1_1, GIOP_V1_2); -- Must be kept in ascending order To_GIOP_Version : constant array (0 .. 2) of GIOP_Version := (0 => GIOP_V1_0, 1 => GIOP_V1_1, 2 => GIOP_V1_2); To_Minor_GIOP : constant array (GIOP_Version) of Types.Octet := (GIOP_V1_0 => 0, GIOP_V1_1 => 1, GIOP_V1_2 => 2); ------------------------ -- Session primitives -- ------------------------ procedure Create (Proto : access GIOP_Protocol; Session : out Filter_Access); procedure Invoke_Request (Sess : access GIOP_Session; R : Requests.Request_Access; Pro : access Binding_Data.Profile_Type'Class); procedure Abort_Request (Sess : access GIOP_Session; R : Requests.Request_Access); procedure Send_Reply (Sess : access GIOP_Session; R : Requests.Request_Access); procedure Locate_Object (Sess : access GIOP_Session; Profile : Binding_Data.Profile_Access; Error : in out Errors.Error_Container); procedure Handle_Connect_Indication (Sess : access GIOP_Session); procedure Handle_Connect_Confirmation (Sess : access GIOP_Session); procedure Handle_Data_Indication (Sess : access GIOP_Session; Data_Amount : Stream_Element_Count; Error : in out Errors.Error_Container); procedure Handle_Disconnect (Sess : access GIOP_Session; Error : Errors.Error_Container); procedure Handle_Unmarshall_Arguments (Sess : access GIOP_Session; Args : in out Any.NVList.Ref; Error : in out Errors.Error_Container); procedure Handle_Flush (Sess : access GIOP_Session); ---------------- -- GIOP State -- ---------------- type GIOP_State is (Not_Initialized, -- Session initialized Expect_Header, -- Waiting for a new message header Expect_Body, -- Waiting for body message Waiting_Unmarshalling -- Waiting argument unsmarshalling ); type GIOP_Data_Expected is new PolyORB.Filters.Iface.Data_Expected with record State : GIOP_State; end record; ----------------------- -- GIOP message type -- ----------------------- type Msg_Type is (Request, Reply, Cancel_Request, Locate_Request, Locate_Reply, Close_Connection, Message_Error, Fragment); -- Not available for GIOP 1.0 -------------------------- -- GIOP message context -- -------------------------- type GIOP_Message_Context is abstract tagged private; type GIOP_Message_Context_Access is access all GIOP_Message_Context'Class; type Reply_Status_Type is (No_Exception, User_Exception, System_Exception, Location_Forward, Location_Forward_Perm, Needs_Addressing_Mode); -- 1.2 specific, but not implemented -- Security Service Hooks type Fetch_Secure_Transport_QoS_Hook is access function (End_Point : PolyORB.Transport.Transport_Endpoint_Access) return PolyORB.QoS.QoS_Parameter_Access; Fetch_Secure_Transport_QoS : Fetch_Secure_Transport_QoS_Hook := null; function Get_Representation (Sess : access GIOP_Session) return PolyORB.Representations.CDR.CDR_Representation_Access; -- Return the representation object used by the session. -- Note: the user is not allowed to destroy this object function Get_Buffer (Sess : access GIOP_Session) return PolyORB.Buffers.Buffer_Access; -- Return the buffer object used by the session. -- Note: the user is not allowed to destroy this object private use PolyORB.Types; type GIOP_Protocol is abstract new Protocol with null record; package Octet_Flags is new PolyORB.Utils.Simple_Flags (Types.Octet); type Pending_Request is record Req : Requests.Request_Access; Locate_Req_Id : Types.Unsigned_Long := 0; Request_Id : Types.Unsigned_Long := 0; Target_Profile : Binding_Data.Profile_Access; -- XXX This attribute should be removed, and Get_Reference_Info on -- Req.Target should be used instead when it is necessary to access the -- target profile. end record; type Pending_Request_Access is access all Pending_Request; procedure Free is new Ada.Unchecked_Deallocation (Pending_Request, Pending_Request_Access); package Pend_Req_Tables is new PolyORB.Utils.Dynamic_Tables (Pending_Request_Access, Natural, 1, 10, 10); -------------------- -- GIOP send mode -- -------------------- Default_Locate_Then_Request : constant Boolean := True; -- Default GIOP_Version GIOP_Default_Version : constant GIOP_Version := GIOP_V1_2; procedure Get_GIOP_Implem (Sess : access GIOP_Session; Version : GIOP_Version; Allow_Downgrade : Boolean := False); -- Retrieve a GIOP_Implem for the specified GIOP Version, and associate -- it with Sess. If Allow_Downgrade is True, and the given Version is -- unavailable, try a lower version. -------------------------- -- GIOP message context -- -------------------------- -- Version-specific information associated with a GIOP message type GIOP_Message_Context is abstract tagged record Message_Endianness : PolyORB.Buffers.Endianness_Type := PolyORB.Buffers.Host_Order; Message_Type : Msg_Type; Message_Size : Types.Unsigned_Long; Request_Id : aliased Types.Unsigned_Long; Reply_Status : Reply_Status_Type; end record; procedure Free is new Ada.Unchecked_Deallocation (GIOP_Message_Context'Class, GIOP_Message_Context_Access); --------------------------- -- GIOP session context -- --------------------------- -- Version-specific information associated with a GIOP sesssion type GIOP_Session_Context is abstract tagged null record; type GIOP_Session_Context_Access is access all GIOP_Session_Context'Class; procedure Free is new Ada.Unchecked_Deallocation (GIOP_Session_Context'Class, GIOP_Session_Context_Access); ----------------- -- GIOP_Implem -- ----------------- -- A GIOP implementation encapsulates the version-specific behaviour -- of a GIOP stack. type GIOP_Implem is abstract tagged record Version : GIOP_Version; -- This values must be set at Implem initialization Data_Alignment : Buffers.Alignment_Type; Locate_Then_Request : Boolean; -- Configuration values Section : Types.String; Prefix : Types.String; -- XXX ??? what are these? Permitted_Sync_Scopes : PolyORB.Requests.Flags; -- Allowed Req Flags end record; type GIOP_Implem_Access is access all GIOP_Implem'Class; procedure Initialize_Implem (Implem : access GIOP_Implem) is abstract; -- Initialize global parameters for Implem -- Called at PolyORB initialization procedure Initialize_Session (Implem : access GIOP_Implem; S : access Session'Class) is abstract; -- Initialize parameters for a session -- Called at GIOP Session initialization procedure Finalize_Session (Implem : access GIOP_Implem; S : access Session'Class) is abstract; -- Finalize for a session (free parameters) procedure Unmarshall_GIOP_Header (Implem : access GIOP_Implem; MCtx : access GIOP_Message_Context'Class; Buffer : access Buffers.Buffer_Type) is abstract; procedure Marshall_GIOP_Header (Implem : access GIOP_Implem; S : access Session'Class; MCtx : access GIOP_Message_Context'Class; Buffer : access Buffers.Buffer_Type) is abstract; procedure Process_Message (Implem : access GIOP_Implem; S : access Session'Class) is abstract; procedure Emit_Message (Implem : access GIOP_Implem; S : access Session'Class; MCtx : access GIOP_Message_Context'Class; Buffer : PolyORB.Buffers.Buffer_Access; Error : in out Errors.Error_Container); -- Emit message contained in Buffer to lower layer of the protocol stack. -- Implementations may override this operation to provide outgoing messages -- fragmentation. procedure Send_Cancel_Request (Implem : access GIOP_Implem; S : access Session'Class; R : Request_Access) is abstract; -- Cancel a request procedure Send_Reply (Implem : access GIOP_Implem; S : access Session'Class; Request : Requests.Request_Access) is abstract; -- Send a reply procedure Send_Request (Implem : access GIOP_Implem; S : access Session'Class; R : Pending_Request_Access; Error : in out Errors.Error_Container) is abstract; -- Send a request procedure Locate_Object (Implem : access GIOP_Implem; S : access Session'Class; R : Pending_Request_Access; Error : in out Errors.Error_Container) is abstract; -- Send a locate request to locate an object procedure Marshall_Argument_List (Implem : access GIOP_Implem; Buffer : Buffers.Buffer_Access; Representation : access Representations.CDR.CDR_Representation'Class; Args : in out Any.NVList.Ref; Direction : Any.Flags; First_Arg_Alignment : Buffers.Alignment_Type; Error : in out Errors.Error_Container); -- Internal subprogram: Marshall arguments from Args into Buf. -- Direction may be ARG_IN or ARG_OUT. Only NamedValues with Arg_Modes -- equal to either ARG_INOUT or Direction will be considered. The first -- argument marshalled will be aligned on First_Arg_Alignment. procedure Unmarshall_Argument_List (Implem : access GIOP_Implem; Buffer : Buffers.Buffer_Access; Representation : access Representations.CDR.CDR_Representation'Class; Args : in out Any.NVList.Ref; Direction : Any.Flags; First_Arg_Alignment : Buffers.Alignment_Type; Error : in out Errors.Error_Container); -- Internal subprogram: set the values of arguments in -- Args by unmarshalling them from Ses. -- Direction may be ARG_IN or ARG_OUT. Only NamedValues with Arg_Modes -- equal to either ARG_INOUT or Direction will be considered. The first -- argument is assumed to be aligned on First_Arg_Alignment. procedure Marshall_GIOP_Header_Reply (Implem : access GIOP_Implem; S : access Session'Class; R : Request_Access; MCtx : access GIOP_Message_Context'Class; Buffer : access PolyORB.Buffers.Buffer_Type) is abstract; -- GIOP Implem management type GIOP_Factory is access function return GIOP_Implem_Access; type GIOP_Implem_Array is array (GIOP_Version) of GIOP_Implem_Access; procedure Global_Register_GIOP_Version (Version : GIOP_Version; Implem : GIOP_Factory); ------------------------ -- GIOP configuration -- ------------------------ type GIOP_Conf is record GIOP_Default_Version : GIOP_Version; -- Default GIOP Version GIOP_Implems : GIOP_Implem_Array; -- List of activated GIOP Implem Permitted_Sync_Scopes : PolyORB.Requests.Flags; -- Allowed Req Flags end record; type GIOP_Conf_Access is access all GIOP_Conf; procedure Initialize (Conf : access GIOP_Conf; Version : GIOP_Version; Permitted_Sync_Scopes : PolyORB.Requests.Flags; Locate_Then_Request : Boolean; Section : String; Prefix : String); -- Initialize a GIOP Configuration, reading PolyORB configuration ------------------ -- GIOP_Session -- ------------------ type GIOP_Session is new Session with record Implem : GIOP_Implem_Access; -- Access to current implem Repr : Representations.CDR.CDR_Representation_Access; -- Marshalling/unmarshalling representation object State : GIOP_State := Not_Initialized; -- GIOP state SCtx : GIOP_Session_Context_Access; -- GIOP session context, implem dependant MCtx : GIOP_Message_Context_Access; -- GIOP message context for the message being received Buffer_In : Buffers.Buffer_Access; -- GIOP Buffer in Role : ORB.Endpoint_Role; -- Role of session for ORB Conf : GIOP_Conf_Access; -- Configuration parameters -------------------------------------- -- Global state of the GIOP session -- -------------------------------------- -- These components must be accessed under mutual exclusion at -- the session level. Mutex : Tasking.Mutexes.Mutex_Access; -- Critical section for concurrent access to Pending_Reqs and -- Req_Index. Pending_Reqs : Pend_Req_Tables.Instance; -- List of pendings requests. Note: when Bidirectional_GIOP is -- implemented, this component will need to be split into a client-side -- and a server-side list. -- Investigate usage of an Ordered_Map container??? Req_Index : Types.Unsigned_Long := 1; -- Request Id for next request end record; type GIOP_Session_Access is access all GIOP_Session; procedure Initialize (S : in out GIOP_Session); procedure Destroy (S : in out GIOP_Session); -- Magic identifier: 4 bytes at the begining of every GIOP message Magic : constant Stream_Element_Array (1 .. 4) := (Character'Pos ('G'), Character'Pos ('I'), Character'Pos ('O'), Character'Pos ('P')); GIOP_Header_Size : constant Stream_Element_Offset := 12; -- Header size of GIOP_packet (non version specific header) GIOP_Fixed_Part_Size : constant Stream_Element_Offset := 6; -- Size of the fixed GIOP_packet header (version specific header) Request_Id_Size : constant := 4; Flags_Index : constant Stream_Element_Offset := 7; Bit_Little_Endian : constant Octet_Flags.Bit_Count := 0; -- Location of flags in GIOP packet --------------------------- -- Global GIOP Functions -- --------------------------- procedure Unmarshall_Global_GIOP_Header (Sess : access GIOP_Session; Buffer : access Buffers.Buffer_Type; Version : out GIOP_Version); -- XXX description required procedure Marshall_Global_GIOP_Header (Sess : access GIOP_Session; MCtx : access GIOP_Message_Context'Class; Buffer : access PolyORB.Buffers.Buffer_Type); -- XXX description required procedure Expect_GIOP_Header (Sess : access GIOP_Session); -- Prepare S to receive next GIOP message. -- This must be called once when a session is established (in -- Handle_Connect_Indication for a server session, in -- Handle_Connect_Confirmation for a client session), and then exactly -- once after a message has been received. This must not be called after -- sending a message (because message sends and receives can be -- interleaved in an arbitrary way, and Expect_Message must not be called -- twice in a row). The caller must guarantee that the binding object -- terminated by Sess will persist during the execution of -- Expect_GIOP_Header. type Request_Note is new PolyORB.Annotations.Note with record Id : Types.Unsigned_Long; end record; -- A note can be attached to a PolyORB request to augment -- it with personality-specific information. The GIOP stack -- uses such a note to associate the Request with its -- Request_Id. procedure Queue_Request (Sess : access GIOP_Session; Req : Request_Access; Req_Id : Types.Unsigned_Long); -- Queue Req for further processing by ORB (usually for service by a local -- servant). Req is added to the (server-side) pending requests list -- associated with Sess. -------------------------------- -- Pending Request management -- -------------------------------- function Get_Request_Id (Sess : access GIOP_Session) return Types.Unsigned_Long; -- Obtain a new, unique request identifier. The caller is responsible -- for ensuring that this function is called under mutual exclusion. procedure Add_Pending_Request (Sess : access GIOP_Session; Pend_Req : Pending_Request_Access); -- Add Pend_Req to the list of pending requests on S. -- The Req and Target_Profile fields must be already initialized; this -- procedure sets the Request_Id. The caller is reponsible for ensuring -- that this procedure is called under mutual exclusion. procedure Get_Pending_Request (Sess : access GIOP_Session; Id : Types.Unsigned_Long; Req : out Pending_Request; Success : out Boolean); -- Retrieve a pending request of Sess by its request id, and remove it from -- the list of pending requests. The caller is reponsible for ensuring -- that this procedure is called under mutual exclusion. procedure Get_Pending_Request_By_Locate (Sess : access GIOP_Session; L_Id : Types.Unsigned_Long; Req : out Pending_Request_Access; Success : out Boolean; Remove : Boolean); -- Retrieve a pending request of Sess by its locate request id, and remove -- it from the list of pending requests if Remove is set True. In this -- case, Req is set to null on return. This procedure ensures proper mutual -- exclusion. procedure Remove_Pending_Request (Sess : access GIOP_Session; Id : Types.Unsigned_Long; Success : out Boolean); -- Remove pending request by its request id from the list of pending -- requests on Sess. This procedure ensures proper mutual exclusion. procedure Remove_Pending_Request_By_Locate (Sess : access GIOP_Session; Id : Types.Unsigned_Long; Success : out Boolean); -- Remove pending request by locate request id from the list of pending -- requests on Sess. This procedure ensures proper mutual exclusion. --------------------------------- -- Marshall Unmarshall helpers -- --------------------------------- procedure Unmarshall_System_Exception_To_Any (Buffer : Buffers.Buffer_Access; Repr : access Representations.CDR.CDR_Representation'Class; Info : out Any.Any); function Get_Conf_Chain (Implem : access GIOP_Implem'Class) return String; end PolyORB.Protocols.GIOP; polyorb-2.8~20110207.orig/src/giop/polyorb-giop_p-exceptions.adb0000644000175000017500000003002411750740340023716 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . G I O P _ P . E X C E P T I O N S -- -- -- -- B o d y -- -- -- -- Copyright (C) 2002-2008, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with PolyORB.Dynamic_Dict; with PolyORB.Errors.Helper; with PolyORB.Log; with PolyORB.Types; with PolyORB.Utils; package body PolyORB.GIOP_P.Exceptions is use PolyORB.Any; use PolyORB.Errors; use PolyORB.Errors.Helper; use PolyORB.Log; use PolyORB.Types; use PolyORB.Utils; package L is new PolyORB.Log.Facility_Log ("polyorb.giop_p.exceptions"); procedure O (Message : Standard.String; Level : Log_Level := Debug) renames L.Output; function C (Level : Log_Level := Debug) return Boolean renames L.Enabled; CORBA_Exc_Root : constant String := "IDL:omg.org/CORBA/"; CORBA_Exc_Version : constant String := ":1.0"; -- CORBA exceptions root and version OMGVMCID : constant PolyORB.Types.Unsigned_Long := 16#4f4d0000#; -- The CORBA speficiations mandate that the actual value for the -- minor field of system exceptions is obtained by or-ing the -- value with this constant, for all values defined in CORBA A.5. Exception_Code_Upper_Bounds : constant array (ORB_System_Error'Range) of Unsigned_Long := (Unknown_E => 3, Bad_Param_E => 41, No_Memory_E => 0, Imp_Limit_E => 1, Comm_Failure_E => 0, Inv_Objref_E => 2, No_Permission_E => 0, Internal_E => 2, Marshal_E => 7, Initialize_E => 1, No_Implement_E => 7, Bad_TypeCode_E => 3, Bad_Operation_E => 2, No_Resources_E => 2, No_Response_E => 0, Persist_Store_E => 0, Bad_Inv_Order_E => 20, Transient_E => 4, Free_Mem_E => 0, Inv_Ident_E => 0, Inv_Flag_E => 0, Intf_Repos_E => 2, Bad_Context_E => 2, Obj_Adapter_E => 7, Data_Conversion_E => 2, Object_Not_Exist_E => 4, Transaction_Required_E => 0, Transaction_Rolledback_E => 3, Invalid_Transaction_E => 1, Inv_Policy_E => 3, Codeset_Incompatible_E => 0, Rebind_E => 0, Timeout_E => 0, Transaction_Unavailable_E => 0, Transaction_Mode_E => 0, Bad_Qos_E => 0); function To_CORBA_Exception_TypeCode (TC : PolyORB.Any.TypeCode.Local_Ref) return PolyORB.Any.TypeCode.Local_Ref; -- Construct CORBA exception typecode from TC ------------------------- -- Is_System_Exception -- ------------------------- function Is_System_Exception (Name : String) return Boolean is Prefix_Length : constant Natural := PolyORB_Exc_Prefix'Length; Version_Length : constant Natural := PolyORB_Exc_Version'Length; Result : Boolean := False; begin if Name'Length > Prefix_Length + Version_Length and then Name (Name'First .. Name'First + Prefix_Length - 1) = PolyORB_Exc_Prefix then declare Error_Id_Name : constant String := Name (Name'First + Prefix_Length .. Name'Last - Version_Length) & "_E"; begin pragma Debug (C, O ("Error_Id_Name : " & Error_Id_Name)); Result := Error_Id'Value (Error_Id_Name) in ORB_System_Error; end; end if; pragma Debug (C, O (Name & " is a system exception ? " & Boolean'Image (Result))); return Result; end Is_System_Exception; ----------------------------------- -- Extract_System_Exception_Name -- ----------------------------------- function Extract_System_Exception_Name (Name : Standard.String) return Standard.String is CER_Length : constant Natural := CORBA_Exc_Root'Length; CEV_Length : constant Natural := CORBA_Exc_Version'Length; begin if Name (Name'First .. Name'First + CER_Length - 1) /= CORBA_Exc_Root then raise Program_Error; end if; pragma Debug (C, O ("System exception name :" & Name (Name'First + CER_Length .. Name'Last - CEV_Length))); return Name (Name'First + CER_Length .. Name'Last - CEV_Length); end Extract_System_Exception_Name; --------------------------------- -- To_CORBA_Exception_TypeCode -- --------------------------------- function To_CORBA_Exception_TypeCode (TC : PolyORB.Any.TypeCode.Local_Ref) return PolyORB.Any.TypeCode.Local_Ref is CORBA_Root_PTS : constant PolyORB.Types.String := To_PolyORB_String (CORBA_Exc_Root); CORBA_Exc_Version_PTS : constant PolyORB.Types.String := To_PolyORB_String (CORBA_Exc_Version); Id : constant String := To_Standard_String (TypeCode.Id (TC)); Colon1 : constant Integer := Find (Id, Id'First, '/'); Colon2 : constant Integer := Find (Id, Colon1 + 1, ':'); Internal_Name : constant PolyORB.Types.String := To_PolyORB_String (Id (Colon1 + 1 .. Colon2 - 1)); New_Name : constant PolyORB.Types.String := CORBA_Root_PTS & Internal_Name & CORBA_Exc_Version_PTS; Result_TC : constant TypeCode.Local_Ref := TypeCode.TC_Except; begin pragma Debug (C, O ("Exception Id was: " & Id)); pragma Debug (C, O ("New exception Id is: " & To_Standard_String (New_Name))); -- Name TypeCode.Add_Parameter (Result_TC, To_Any (Internal_Name)); -- Id TypeCode.Add_Parameter (Result_TC, To_Any (New_Name)); -- Minor TypeCode.Add_Parameter (Result_TC, To_Any (TC_Unsigned_Long)); TypeCode.Add_Parameter (Result_TC, To_Any (To_PolyORB_String ("minor"))); -- Completed TypeCode.Add_Parameter (Result_TC, To_Any (TC_Completion_Status)); TypeCode.Add_Parameter (Result_TC, To_Any (To_PolyORB_String ("completed"))); return Result_TC; end To_CORBA_Exception_TypeCode; ------------------------ -- To_CORBA_Exception -- ------------------------ function To_CORBA_Exception (Exc : PolyORB.Any.Any) return PolyORB.Any.Any is use PolyORB.Any.TypeCode; Exc_TC : constant PolyORB.Any.TypeCode.Local_Ref := Get_Type (Exc); Result_TC : PolyORB.Any.TypeCode.Local_Ref; Result : Any.Any; begin pragma Debug (C, O ("To_CORBA_Exception: enter")); -- Construct exception typecode Result_TC := To_CORBA_Exception_TypeCode (Exc_TC); if Exc_TC /= Result_TC then pragma Debug (C, O ("Must modify exception content")); Set_Type (Result, Result_TC); Result := Get_Empty_Any_Aggregate (Result_TC); pragma Debug (C, O (Image (Result_TC))); declare Exception_Name : constant String := To_Standard_String (Name (Result_TC)); Id : constant Error_Id := Error_Id'Value (Exception_Name & "_E"); Minor : constant Types.Unsigned_Long := From_Any (Get_Aggregate_Element (Exc, TypeCode.TC_Unsigned_Long, Types.Unsigned_Long (0))); begin pragma Debug (C, O ("Exception Name: " & Exception_Name)); if Id in ORB_System_Error then if Minor in 1 .. Exception_Code_Upper_Bounds (Id) then Add_Aggregate_Element (Result, To_Any (OMGVMCID or Minor)); -- Or'ing with OMGVMCID as required by CORBA A.5 else Add_Aggregate_Element (Result, Get_Aggregate_Element (Exc, TypeCode.TC_Unsigned_Long, Types.Unsigned_Long (0))); end if; end if; end; Add_Aggregate_Element (Result, Get_Aggregate_Element (Exc, TC_Completion_Status, Types.Unsigned_Long (1))); pragma Debug (C, O ("To_CORBA_Exception: leave")); return Result; else pragma Debug (C, O ("No need to modify exception TypeCode")); pragma Debug (C, O ("To_CORBA_Exception: leave")); return Exc; end if; end To_CORBA_Exception; ------------------------------- -- System_Exception_TypeCode -- ------------------------------- package System_Exception_TC_Cache is new PolyORB.Dynamic_Dict (Value => TypeCode.Local_Ref); function System_Exception_TypeCode (Name : Standard.String) return Any.TypeCode.Local_Ref is use System_Exception_TC_Cache; TC : constant TypeCode.Local_Ref := Lookup (Name, TypeCode.TC_Except); Shift : Natural := 0; Repository_Id : PolyORB.Types.String; begin if TypeCode.Parameter_Count (TC) > 0 then return TC; end if; -- Name TypeCode.Add_Parameter (TC, To_Any (To_PolyORB_String (Name))); if Name (Name'First .. Name'First + PolyORB_Exc_Root'Length - 1) = PolyORB_Exc_Root then Shift := PolyORB_Exc_Root'Length + 1; end if; -- RepositoryId: 'INTERNAL::1.0' Repository_Id := To_PolyORB_String (PolyORB_Exc_Prefix) & To_PolyORB_String (Name (Name'First + Shift .. Name'Last)) & PolyORB_Exc_Version; TypeCode.Add_Parameter (TC, To_Any (Repository_Id)); -- Minor TypeCode.Add_Parameter (TC, To_Any (TC_Unsigned_Long)); TypeCode.Add_Parameter (TC, To_Any (To_PolyORB_String ("minor"))); -- Completed TypeCode.Add_Parameter (TC, To_Any (TC_Completion_Status)); TypeCode.Add_Parameter (TC, To_Any (To_PolyORB_String ("completed"))); pragma Debug (C, O ("Built Exception TypeCode for: " & To_Standard_String (Repository_Id))); Register (Name, TC); return TC; end System_Exception_TypeCode; end PolyORB.GIOP_P.Exceptions; polyorb-2.8~20110207.orig/src/giop/polyorb-protocols-giop-giop_1_1.ads0000644000175000017500000001172611750740340024667 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . P R O T O C O L S . G I O P . G I O P _ 1 _ 1 -- -- -- -- S p e c -- -- -- -- Copyright (C) 2002-2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- Note: this implementation does not actually support GIOP 1.1 -- fragmentation: incoming fragmented messages won't be accepted, and -- outgoing messages will never be fragmented. package PolyORB.Protocols.GIOP.GIOP_1_1 is private type GIOP_Implem_1_1 is new GIOP_Implem with record Max_GIOP_Message_Size : Types.Unsigned_Long; Max_Body : Types.Unsigned_Long; end record; -- GIOP 1.1 context type GIOP_Message_Context_1_1 is new GIOP_Message_Context with null record; procedure Initialize_Implem (Implem : access GIOP_Implem_1_1); procedure Initialize_Session (Implem : access GIOP_Implem_1_1; S : access Session'Class); procedure Finalize_Session (Implem : access GIOP_Implem_1_1; S : access Session'Class); procedure Unmarshall_GIOP_Header (Implem : access GIOP_Implem_1_1; MCtx : access GIOP_Message_Context'Class; Buffer : access Buffers.Buffer_Type); procedure Marshall_GIOP_Header (Implem : access GIOP_Implem_1_1; S : access Session'Class; MCtx : access GIOP_Message_Context'Class; Buffer : access Buffers.Buffer_Type); procedure Marshall_GIOP_Header_Reply (Implem : access GIOP_Implem_1_1; S : access Session'Class; R : Request_Access; MCtx : access GIOP_Message_Context'Class; Buffer : access Buffers.Buffer_Type); procedure Process_Message (Implem : access GIOP_Implem_1_1; S : access Session'Class); procedure Send_Reply (Implem : access GIOP_Implem_1_1; S : access Session'Class; Request : Requests.Request_Access); procedure Locate_Object (Implem : access GIOP_Implem_1_1; S : access Session'Class; R : Pending_Request_Access; Error : in out Errors.Error_Container); procedure Send_Request (Implem : access GIOP_Implem_1_1; S : access Session'Class; R : Pending_Request_Access; Error : in out Errors.Error_Container); procedure Send_Cancel_Request (Implem : access GIOP_Implem_1_1; S : access Session'Class; R : Request_Access); procedure Marshall_Argument_List (Implem : access GIOP_Implem_1_1; Buffer : Buffers.Buffer_Access; Representation : access Representations.CDR.CDR_Representation'Class; Args : in out Any.NVList.Ref; Direction : Any.Flags; First_Arg_Alignment : Buffers.Alignment_Type; Error : in out Errors.Error_Container); -- Bits in flags field Bit_Fragment : constant Octet_Flags.Bit_Count := 1; -- Data alignment Data_Alignment_1_1 : constant Buffers.Alignment_Type := Buffers.Align_1; -- Principal Nobody_Principal : constant Types.String := Types.To_PolyORB_String ("nobody"); end PolyORB.Protocols.GIOP.GIOP_1_1; polyorb-2.8~20110207.orig/src/giop/polyorb-giop_p-code_sets.ads0000644000175000017500000001223711750740340023534 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . G I O P _ P . C O D E _ S E T S -- -- -- -- S p e c -- -- -- -- Copyright (C) 2004-2009, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with PolyORB.Errors; with PolyORB.Utils.Chained_Lists; with PolyORB.Types; package PolyORB.GIOP_P.Code_Sets is type Code_Set_Id is new PolyORB.Types.Unsigned_Long; -- Code_Set_Ids, as defined by the Open Software Foundation. Latin_1_Code_Set : constant Code_Set_Id := 16#00010001#; UCS_2_Level_1_Code_Set : constant Code_Set_Id := 16#00010100#; UCS_2_Level_2_Code_Set : constant Code_Set_Id := 16#00010101#; UCS_2_Level_3_Code_Set : constant Code_Set_Id := 16#00010102#; UCS_4_Level_1_Code_Set : constant Code_Set_Id := 16#00010104#; UCS_4_Level_2_Code_Set : constant Code_Set_Id := 16#00010105#; UCS_4_Level_3_Code_Set : constant Code_Set_Id := 16#00010106#; UTF_16_Code_Set : constant Code_Set_Id := 16#00010109#; UTF_8_Code_Set : constant Code_Set_Id := 16#05010001#; -- Fallback Code_Set_Ids, defined by the CORBA specifications. Char_Data_Fallback_Code_Set : constant Code_Set_Id := UTF_8_Code_Set; Wchar_Data_Fallback_Code_Set : constant Code_Set_Id := UTF_16_Code_Set; -- Ada 95 Native Code_Set_Ids. See RM 3.5.2 Ada95_Native_Character_Code_Set : constant Code_Set_Id := Latin_1_Code_Set; Ada95_Native_Wide_Character_Code_Set : constant Code_Set_Id := UCS_2_Level_1_Code_Set; type Character_Set_Id is new PolyORB.Types.Unsigned_Short; package Code_Set_Id_Lists is new PolyORB.Utils.Chained_Lists (Code_Set_Id); type Code_Set_Id_List is new Code_Set_Id_Lists.List; function Native_Char_Code_Set return Code_Set_Id; -- Return program's native code set for Character type function Native_Wchar_Code_Set return Code_Set_Id; -- Return program's native code set for Wide_Character type function Conversion_Char_Code_Sets return Code_Set_Id_List; -- Return conversion code sets supported for program's native -- code set for Character type, except fallback code set. -- Returned list must not be deallocated. function Conversion_Wchar_Code_Sets return Code_Set_Id_List; -- Return conversion code sets supported for program's native -- code set for Wide_Character type, except fallback code set. -- Returned list must not be deallocated. procedure Negotiate_Code_Set (CNCS : Code_Set_Id; CCCS : Code_Set_Id_List; SNCS : Code_Set_Id; SCCS : Code_Set_Id_List; Fallback : Code_Set_Id; TCS : out Code_Set_Id; Error : in out PolyORB.Errors.Error_Container); -- Select transmission code set to use based on: -- - CNCS - Client Native Code Set -- - CCCS - Client Conversion Code Sets -- - SNCS - Server Native Code Set -- - SCCS - Server Conversion Code Sets -- Fallback argument provide fallback code sets. -- Returns negotiated transmission code set (TCS) or raises -- Codeset_Incompatible error if code sets are incompatible. private type Code_Set_Info_Record is record Code_Set : Code_Set_Id; First : Positive; Last : Natural; end record; type Character_Set_Id_Array is array (Positive range <>) of Character_Set_Id; end PolyORB.GIOP_P.Code_Sets; polyorb-2.8~20110207.orig/src/giop/polyorb-representations-cdr-giop_1_2.adb0000644000175000017500000000705311750740340025660 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- POLYORB.REPRESENTATIONS.CDR.GIOP_1_2 -- -- -- -- B o d y -- -- -- -- Copyright (C) 2004-2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with PolyORB.Initialization; with PolyORB.Utils.Strings; package body PolyORB.Representations.CDR.GIOP_1_2 is function Create return CDR_Representation_Access; procedure Deferred_Initialization; ------------ -- Create -- ------------ function Create return CDR_Representation_Access is begin return new GIOP_1_2_CDR_Representation; end Create; ----------------------------- -- Deferred_Initialization -- ----------------------------- procedure Deferred_Initialization is begin Register_Factory (1, 2, Create'Access); end Deferred_Initialization; -------------------- -- Set_Converters -- -------------------- procedure Set_Converters (R : in out GIOP_1_2_CDR_Representation; C : PolyORB.GIOP_P.Code_Sets.Converters.Converter_Access; W : PolyORB.GIOP_P.Code_Sets.Converters.Wide_Converter_Access) is begin PolyORB.GIOP_P.Code_Sets.Converters.Set_GIOP_1_2_Mode (W.all); GIOP_1_1.Set_Converters (GIOP_1_1.GIOP_1_1_CDR_Representation (R), C, W); end Set_Converters; begin declare use PolyORB.Initialization; use PolyORB.Initialization.String_Lists; use PolyORB.Utils.Strings; begin Register_Module (Module_Info' (Name => +"representations.cdr.giop_1_2", Conflicts => Empty, Depends => Empty, Provides => Empty, Implicit => False, Init => Deferred_Initialization'Access, Shutdown => null)); end; end PolyORB.Representations.CDR.GIOP_1_2; polyorb-2.8~20110207.orig/src/giop/polyorb-giop_p-transport_mechanisms.ads0000644000175000017500000001470111750740340026025 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . G I O P _ P . T R A N S P O R T _ M E C H A N I S M S -- -- -- -- S p e c -- -- -- -- Copyright (C) 2005-2008, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- Abstraction for GIOP Transport Mechanisms. with PolyORB.Binding_Data; with PolyORB.Components; with PolyORB.Errors; with PolyORB.GIOP_P.Tagged_Components; with PolyORB.QoS; with PolyORB.Smart_Pointers; with PolyORB.Transport; with PolyORB.Utils.Chained_Lists; package PolyORB.GIOP_P.Transport_Mechanisms is -- Transport mechanism type Transport_Mechanism is abstract tagged null record; -- ??? Should be made a limited type, really, since derived types may -- use (non-controlled) chained lists as components. type Transport_Mechanism_Access is access all Transport_Mechanism'Class; procedure Bind_Mechanism (Mechanism : Transport_Mechanism; Profile : access PolyORB.Binding_Data.Profile_Type'Class; The_ORB : Components.Component_Access; QoS : PolyORB.QoS.QoS_Parameters; BO_Ref : out Smart_Pointers.Ref; Error : out Errors.Error_Container) is abstract; -- Create a transport endpoint and an attached protocol stack instance -- that match this transport mechanism, in order to send a message -- to the middleware that hosts the designated object. -- The Filter at the top of the protocol stack is returned. -- Concrete implementations are responsible for registering the -- Transport Endpoint with the ORB if necessary. procedure Release_Contents (M : access Transport_Mechanism) is abstract; -- Transport mechanism factory type Transport_Mechanism_Factory is abstract tagged null record; type Transport_Mechanism_Factory_Access is access all Transport_Mechanism_Factory'Class; procedure Create_Factory (MF : out Transport_Mechanism_Factory; TAP : Transport.Transport_Access_Point_Access) is abstract; -- Initialize MF to act as transport mechanism factory for -- transport access point TAP function Is_Local_Mechanism (MF : access Transport_Mechanism_Factory; M : access Transport_Mechanism'Class) return Boolean is abstract; -- True iff M designates an mechanism that can be contacted -- at the access point associated with MF function Create_Tagged_Components (MF : Transport_Mechanism_Factory) return Tagged_Components.Tagged_Component_List is abstract; -- Create tagged components, which represent transport mechanism's -- transport access points and association options in the object profile -- List of Transport Mechanisms package Transport_Mechanism_Lists is new PolyORB.Utils.Chained_Lists (Transport_Mechanism_Access); type Transport_Mechanism_List is new Transport_Mechanism_Lists.List; procedure Release_Contents (List : in out Transport_Mechanism_List); -- Free memory for all tags in List function Deep_Copy (List : Transport_Mechanism_List) return Transport_Mechanism_List; -- Return a deep copy of list function Duplicate (TMA : Transport_Mechanism) return Transport_Mechanism is abstract; function Is_Colocated (Left : Transport_Mechanism; Right : Transport_Mechanism'Class) return Boolean is abstract; -- True iff Left and Right mechanisms point to the same node. function Is_Colocated (Left, Right : Transport_Mechanism_List) return Boolean; -- True iff Left and Right mechanisms lists have both a transport mechanism -- pointing to the same node. -- List of Transport Mechanism Factories package Transport_Mechanism_Factory_Lists is new PolyORB.Utils.Chained_Lists (Transport_Mechanism_Factory_Access); type Transport_Mechanism_Factory_List is new Transport_Mechanism_Factory_Lists.List; -- Creation of Transport Mechanisms from list of Tagged Component procedure Create_Transport_Mechanisms (TC : Tagged_Components.Tagged_Component_List; Profile : Binding_Data.Profile_Access; Mechs : in out Transport_Mechanism_List); -- Create Transport Mechanisms from Profile's list of Tagged Components, -- and append them to Mechs. type Transport_Mechanism_Constructor is access procedure (TC : Tagged_Components.Tagged_Component_Access; Profile : Binding_Data.Profile_Access; Mechs : in out Transport_Mechanism_List); -- Create transport mechanisms for TC, and append them to Mechs procedure Register (Tag : Tagged_Components.Tag_Value; Constructor : Transport_Mechanism_Constructor); -- Register tagged component to transport mechanism converter end PolyORB.GIOP_P.Transport_Mechanisms; polyorb-2.8~20110207.orig/src/giop/polyorb-giop_p-service_contexts.adb0000644000175000017500000001113111750740340025122 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . G I O P _ P . S E R V I C E _ C O N T E X T S -- -- -- -- B o d y -- -- -- -- Copyright (C) 2004-2008, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with PolyORB.Log; with PolyORB.Representations.CDR.Common; with PolyORB.Types; package body PolyORB.GIOP_P.Service_Contexts is use PolyORB.Buffers; use PolyORB.Log; use PolyORB.Representations.CDR.Common; use PolyORB.QoS.Service_Contexts; use PolyORB.Types; package L is new PolyORB.Log.Facility_Log ("polyorb.giop_p.service_contexts"); procedure O (Message : String; Level : Log_Level := Debug) renames L.Output; function C (Level : Log_Level := Debug) return Boolean renames L.Enabled; ----------------------------------- -- Marshall_Service_Context_List -- ----------------------------------- procedure Marshall_Service_Context_List (Buffer : access Buffers.Buffer_Type; SCP : PRSC.QoS_GIOP_Service_Contexts_Parameter_Access) is use PolyORB.QoS.Service_Contexts.Service_Context_Lists; Iter : Iterator; begin if SCP = null then Marshall (Buffer, Types.Unsigned_Long'(0)); return; end if; pragma Debug (C, O ("Marshall_Service_Context_List: enter, length=" & Integer'Image (Length (SCP.Service_Contexts)))); Iter := First (SCP.Service_Contexts); Marshall (Buffer, Types.Unsigned_Long (Length (SCP.Service_Contexts))); while not Last (Iter) loop Marshall (Buffer, Unsigned_Long (Value (Iter).Context_Id)); Marshall (Buffer, Value (Iter).Context_Data.all); Next (Iter); end loop; pragma Debug (C, O ("Marshall_Service_Context_List: leave")); end Marshall_Service_Context_List; ------------------------------------- -- Unmarshall_Service_Context_List -- ------------------------------------- procedure Unmarshall_Service_Context_List (Buffer : access Buffers.Buffer_Type; SCP : out PRSC.QoS_GIOP_Service_Contexts_Parameter_Access) is use Service_Context_Lists; Length : constant PolyORB.Types.Unsigned_Long := Unmarshall (Buffer); begin pragma Debug (C, O ("Unmarshall_Service_Context_List: enter, length =" & PolyORB.Types.Unsigned_Long'Image (Length))); if Length = 0 then SCP := null; return; end if; SCP := new QoS_GIOP_Service_Contexts_Parameter; for J in 1 .. Length loop Append (SCP.Service_Contexts, (Types.Unsigned_Long'(Unmarshall (Buffer)), new Encapsulation'(Unmarshall (Buffer)))); end loop; pragma Debug (C, O ("Unmarshall_Service_Context_List: leave")); end Unmarshall_Service_Context_List; end PolyORB.GIOP_P.Service_Contexts; polyorb-2.8~20110207.orig/src/giop/polyorb-protocols-giop-giop_1_0.adb0000644000175000017500000006264111750740340024647 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . P R O T O C O L S . G I O P . G I O P _ 1 _ 0 -- -- -- -- B o d y -- -- -- -- Copyright (C) 2002-2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with Ada.Unchecked_Deallocation; with PolyORB.Any; with PolyORB.Binding_Data.Local; with PolyORB.Buffers; with PolyORB.GIOP_P.Service_Contexts; with PolyORB.Initialization; with PolyORB.Log; with PolyORB.Objects; with PolyORB.Obj_Adapters; with PolyORB.Protocols.GIOP.Common; pragma Elaborate_All (PolyORB.Protocols.GIOP.Common); with PolyORB.QoS.Service_Contexts; with PolyORB.References; with PolyORB.Representations.CDR.Common; with PolyORB.Representations.CDR.GIOP_1_0; with PolyORB.Request_QoS; with PolyORB.Smart_Pointers; with PolyORB.Utils.Strings; package body PolyORB.Protocols.GIOP.GIOP_1_0 is use PolyORB.Buffers; use PolyORB.GIOP_P.Service_Contexts; use PolyORB.Log; use PolyORB.Objects; use PolyORB.Protocols.GIOP.Common; use PolyORB.Representations.CDR.Common; use PolyORB.Representations.CDR.GIOP_1_0; use PolyORB.Request_QoS; use PolyORB.QoS; use PolyORB.QoS.Service_Contexts; package L is new PolyORB.Log.Facility_Log ("polyorb.protocols.giop.giop_1_0"); procedure O (Message : String; Level : Log_Level := Debug) renames L.Output; function C (Level : Log_Level := Debug) return Boolean renames L.Enabled; procedure Free is new Ada.Unchecked_Deallocation (GIOP_1_0_CDR_Representation, GIOP_1_0_CDR_Representation_Access); Permitted_Sync_Scopes : constant PolyORB.Requests.Flags := Sync_None or Sync_With_Transport or Sync_With_Target; -- Msg_Type function Unmarshall is new Generic_Unmarshall (Msg_Type, Types.Octet, Unmarshall); procedure Marshall is new Generic_Marshall (Msg_Type, Types.Octet, Marshall); -- Helpers procedure Marshall_Locate_Request (Buffer : Buffer_Access; Request_Id : Types.Unsigned_Long; Object_Key : PolyORB.Objects.Object_Id_Access); procedure Unmarshall_Request_Message (Buffer : access Buffer_Type; Request_Id : out Types.Unsigned_Long; Resp_Exp : out Boolean; Object_Key : out PolyORB.Objects.Object_Id_Access; Operation : out Types.String; Principal : out Types.String; Service_Contexts : out QoS_GIOP_Service_Contexts_Parameter_Access); ----------------------------------- -- Internal function declaration -- ----------------------------------- procedure Process_Request (S : access GIOP_Session); procedure Process_Locate_Request (S : in out Session'Class); ----------------------- -- Initialize_Implem -- ----------------------- procedure Initialize_Implem (Implem : access GIOP_Implem_1_0) is begin Implem.Data_Alignment := Data_Alignment_1_0; Implem.Permitted_Sync_Scopes := Permitted_Sync_Scopes; end Initialize_Implem; ------------------------ -- Initialize_Session -- ------------------------ procedure Initialize_Session (Implem : access GIOP_Implem_1_0; S : access Session'Class) is pragma Warnings (Off); pragma Unreferenced (Implem); pragma Warnings (On); Sess : GIOP_Session renames GIOP_Session (S.all); begin pragma Debug (C, O ("Initialize context for GIOP session 1.0")); Sess.MCtx := new GIOP_Message_Context_1_0; -- Sess.SCtx := new GIOP_Session_Context_1_0; -- There is no SCtx for GIOP 1.0 Sess.Repr := new GIOP_1_0_CDR_Representation; end Initialize_Session; ---------------------- -- Finalize_Session -- ---------------------- procedure Finalize_Session (Implem : access GIOP_Implem_1_0; S : access Session'Class) is pragma Warnings (Off); pragma Unreferenced (Implem); pragma Warnings (On); Sess : GIOP_Session renames GIOP_Session (S.all); begin Free (Sess.MCtx); -- Free (Sess.SCtx); -- There is no SCtx for GIOP 1.0 Free (GIOP_1_0_CDR_Representation_Access (Sess.Repr)); pragma Debug (C, O ("Finalize context for GIOP session 1.0")); end Finalize_Session; --------------------- -- Process_Message -- --------------------- procedure Process_Message (Implem : access GIOP_Implem_1_0; S : access Session'Class) is pragma Warnings (Off); pragma Unreferenced (Implem); pragma Warnings (On); use PolyORB.ORB; Sess : GIOP_Session renames GIOP_Session (S.all); MCtx : GIOP_Message_Context_1_0 renames GIOP_Message_Context_1_0 (Sess.MCtx.all); begin case MCtx.Message_Type is when Request => if Sess.Role /= Server then raise GIOP_Error; end if; Process_Request (Sess'Access); when Cancel_Request => if Sess.Role /= Server then raise GIOP_Error; end if; Common_Process_Cancel_Request (Sess'Access, Request_Id => Unmarshall (Sess.Buffer_In)); when Reply => if Sess.Role /= Client then raise GIOP_Error; end if; declare Request_Id : Types.Unsigned_Long; Reply_Status : Reply_Status_Type; Service_Contexts : QoS_GIOP_Service_Contexts_Parameter_Access; begin Unmarshall_Service_Context_List (Sess.Buffer_In, Service_Contexts); Request_Id := Unmarshall (Sess.Buffer_In); Reply_Status := Unmarshall (Sess.Buffer_In); pragma Debug (C, O ("Process_Message (1.0): got GIOP Reply," & " Request_Id =" & Request_Id'Img & ", status = " & Reply_Status'Img)); Common_Reply_Received (Sess'Access, Request_Id, Reply_Status, Service_Contexts); end; when Close_Connection => if Sess.Role /= Server then raise GIOP_Error; end if; Expect_GIOP_Header (Sess'Access); when Locate_Reply => if Sess.Role /= Client then raise GIOP_Error; end if; declare Request_Id : constant Types.Unsigned_Long := Unmarshall (Sess.Buffer_In); Locate_Reply : constant Locate_Reply_Type := Unmarshall (Sess.Buffer_In); begin -- Exec request if request id is found in pending req list Common_Process_Locate_Reply (Sess'Access, Request_Id, Locate_Reply); end; when Locate_Request => if Sess.Role /= Server then raise GIOP_Error; end if; Process_Locate_Request (Sess); when Message_Error => raise GIOP_Error; when others => raise Program_Error; end case; end Process_Message; --------------------- -- Process_Request -- --------------------- procedure Process_Request (S : access GIOP_Session) is use PolyORB.ORB; use PolyORB.Components; use PolyORB.Errors; use PolyORB.Binding_Data; use PolyORB.Binding_Data.Local; use PolyORB.Obj_Adapters; use PolyORB.Any.NVList; use PolyORB.References; use PolyORB.Annotations; Object_Key : Objects.Object_Id_Access; Request_Id : Unsigned_Long; Operation : Types.String; Principal : Types.String; Resp_Exp : Boolean; Req_Flags : Flags := 0; Args : Any.NVList.Ref; Def_Args : Component_Access; Target : References.Ref; Req : Request_Access; Service_Contexts : QoS_GIOP_Service_Contexts_Parameter_Access; Error : Errors.Error_Container; Result : Any.NamedValue; -- Dummy NamedValue for Create_Request; -- the actual Result is set by the called method. begin if S.Role /= Server then raise GIOP_Error; end if; pragma Debug (C, O ("Request_Received: entering")); Unmarshall_Request_Message (S.Buffer_In, Request_Id, Resp_Exp, Object_Key, Operation, Principal, Service_Contexts); if Resp_Exp then Req_Flags := Sync_With_Target; else Req_Flags := Sync_With_Transport; end if; pragma Debug (C, O ("Object Key : " & Oid_To_Hex_String (Object_Key.all))); Args := Get_Empty_Arg_List (Object_Adapter (ORB_Access (S.Server)), Object_Key, To_Standard_String (Operation)); if not Is_Nil (Args) then pragma Debug (C, O ("Immediate arguments unmarshalling")); Handle_Unmarshall_Arguments (S, Args, Error); if Found (Error) then Catch (Error); raise Program_Error; -- XXX We cannot silently ignore any error. For now, -- we raise this exception. To be investigated. end if; else pragma Debug (C, O ("Unmarshalling of arguments deferred")); S.State := Waiting_Unmarshalling; Def_Args := Component_Access (S); end if; declare Target_Profile : constant Binding_Data.Profile_Access := new Local_Profile_Type; begin Create_Local_Profile (Object_Key.all, Local_Profile_Type (Target_Profile.all)); Create_Reference ((1 => Target_Profile), "", Target); -- Create a temporary, typeless reference for this object. -- If we wanted to have proper type information, we would -- have to resolve the (local) object id through the object -- adapter, and query the target object for its most derived -- type. end; Create_Request (Target => Target, Operation => To_Standard_String (Operation), Arg_List => Args, Result => Result, Deferred_Arguments_Session => Def_Args, Req => Req, Req_Flags => Req_Flags, Dependent_Binding_Object => Smart_Pointers.Entity_Ptr (S.Dependent_Binding_Object)); Add_Request_QoS (Req.all, GIOP_Service_Contexts, QoS_Parameter_Access (Service_Contexts)); Rebuild_Request_QoS_Parameters (Req.all); Queue_Request (S, Req, Request_Id); Free (Object_Key); pragma Debug (C, O ("Request queued.")); end Process_Request; ---------------- -- Send_Reply -- ---------------- procedure Send_Reply (Implem : access GIOP_Implem_1_0; S : access Session'Class; Request : Requests.Request_Access) is pragma Warnings (Off); pragma Unreferenced (Implem); pragma Warnings (On); use PolyORB.ORB; use PolyORB.Errors; Sess : GIOP_Session renames GIOP_Session (S.all); MCtx : aliased GIOP_Message_Context_1_0; Error : Errors.Error_Container; begin if Sess.Role = Client then raise GIOP_Error; end if; MCtx.Message_Type := Reply; Common_Send_Reply (Sess'Access, Request, MCtx'Access, Error); if Found (Error) then Set_Exception (Request.all, Error); Catch (Error); Common_Send_Reply (Sess'Access, Request, MCtx'Access, Error, Recovery => True); if Found (Error) then Catch (Error); raise GIOP_Error; end if; end if; end Send_Reply; ---------------------------- -- Process_Locate_Request -- ---------------------------- procedure Process_Locate_Request (S : in out Session'Class) is use PolyORB.Errors; Sess : GIOP_Session renames GIOP_Session (S); MCtx : aliased GIOP_Message_Context_1_0 := GIOP_Message_Context_1_0 (Sess.MCtx.all); Buffer : Buffer_Access renames Sess.Buffer_In; Request_Id : constant Types.Unsigned_Long := Unmarshall (Buffer); pragma Warnings (Off); Obj : constant Stream_Element_Array := Unmarshall (Buffer); -- XXX missing documentation for use of pragma Warnings (Off) pragma Warnings (On); Target : References.Ref; Result : Locate_Reply_Type; Error : Errors.Error_Container; begin Result := Object_Here; MCtx.Message_Type := Locate_Reply; MCtx.Request_Id := Request_Id; Common_Locate_Reply (Sess'Access, MCtx'Access, Result, Target, Error); if Found (Error) then Catch (Error); raise GIOP_Error; end if; Expect_GIOP_Header (Sess'Access); end Process_Locate_Request; ------------------- -- Locate_Object -- ------------------- procedure Locate_Object (Implem : access GIOP_Implem_1_0; S : access Session'Class; R : Pending_Request_Access; Error : in out Errors.Error_Container) is pragma Warnings (Off); pragma Unreferenced (Implem); pragma Warnings (On); use PolyORB.Binding_Data; use PolyORB.Errors; use PolyORB.ORB; Sess : GIOP_Session renames GIOP_Session (S.all); MCtx : aliased GIOP_Message_Context_1_0; Buffer : Buffer_Access; Header_Buffer : Buffer_Access; Header_Space : Reservation; begin if Sess.Role /= Client then raise GIOP_Error; end if; pragma Debug (C, O ("Send locate request to find target object")); pragma Debug (C, O ("Locate Request Id :" & R.Locate_Req_Id'Img)); pragma Debug (C, O ("Request Id :" & R.Request_Id'Img)); Buffer := new Buffer_Type; Header_Buffer := new Buffer_Type; Header_Space := Reserve (Buffer, GIOP_Header_Size); Marshall_Locate_Request (Buffer, R.Locate_Req_Id, Get_Object_Key (R.Target_Profile.all)); MCtx.Message_Type := Locate_Request; MCtx.Message_Size := Types.Unsigned_Long (Length (Buffer.all) - GIOP_Header_Size); Marshall_Global_GIOP_Header (Sess'Access, MCtx'Access, Header_Buffer); Copy_Data (Header_Buffer.all, Header_Space); Release (Header_Buffer); Emit_Message (Sess.Implem, S, MCtx'Access, Buffer, Error); Release (Buffer); end Locate_Object; ------------------ -- Send_Request -- ------------------ procedure Send_Request (Implem : access GIOP_Implem_1_0; S : access Session'Class; R : Pending_Request_Access; Error : in out Errors.Error_Container) is pragma Warnings (Off); pragma Unreferenced (Implem); pragma Warnings (On); use PolyORB.Errors; use PolyORB.Requests.Unsigned_Long_Flags; Sess : GIOP_Session renames GIOP_Session (S.all); MCtx : aliased GIOP_Message_Context_1_0; Buffer : Buffer_Access; Header_Buffer : Buffer_Access; Header_Space : Reservation; Resp_Exp : constant Boolean := Is_Set (Sync_With_Target, R.Req.Req_Flags) or else Is_Set (Sync_Call_Back, R.Req.Req_Flags); Oid : constant Object_Id_Access := Binding_Data.Get_Object_Key (R.Target_Profile.all); begin pragma Debug (C, O ("Sending request, Id :" & R.Request_Id'Img)); Buffer := new Buffer_Type; Header_Buffer := new Buffer_Type; Header_Space := Reserve (Buffer, GIOP_Header_Size); Rebuild_Request_Service_Contexts (R.Req.all); Marshall_Service_Context_List (Buffer, QoS_GIOP_Service_Contexts_Parameter_Access (Extract_Request_Parameter (GIOP_Service_Contexts, R.Req.all))); Marshall (Buffer, R.Request_Id); Marshall (Buffer, Resp_Exp); Marshall (Buffer, Stream_Element_Array (Oid.all)); pragma Debug (C, O ("Operation : " & R.Req.Operation.all)); Marshall_Latin_1_String (Buffer, R.Req.Operation.all); Marshall_Latin_1_String (Buffer, Nobody_Principal); Marshall_Argument_List (Sess.Implem, Buffer, Sess.Repr, R.Req.Args, PolyORB.Any.ARG_IN, Sess.Implem.Data_Alignment, Error); if Found (Error) then Release (Header_Buffer); Release (Buffer); return; end if; MCtx.Message_Type := Request; MCtx.Message_Size := Types.Unsigned_Long (Length (Buffer.all) - GIOP_Header_Size); Marshall_Global_GIOP_Header (Sess'Access, MCtx'Access, Header_Buffer); Copy_Data (Header_Buffer.all, Header_Space); Release (Header_Buffer); Emit_Message (Sess.Implem, Sess'Access, MCtx'Access, Buffer, Error); pragma Debug (C, O ("Request sent, Id :" & R.Request_Id'Img & ", size:" & MCtx.Message_Size'Img)); Release (Buffer); end Send_Request; ------------------------- -- Send_Cancel_Request -- ------------------------- procedure Send_Cancel_Request (Implem : access GIOP_Implem_1_0; S : access Session'Class; R : Request_Access) is pragma Warnings (Off); pragma Unreferenced (Implem); pragma Warnings (On); use PolyORB.Errors; use PolyORB.ORB; Sess : GIOP_Session renames GIOP_Session (S.all); MCtx : aliased GIOP_Message_Context_1_0; Error : Errors.Error_Container; begin if Sess.Role = Server then raise GIOP_Error; end if; MCtx.Message_Type := Cancel_Request; Common_Send_Cancel_Request (Sess'Access, R, MCtx'Access, Error); if Found (Error) then Catch (Error); raise GIOP_Error; end if; end Send_Cancel_Request; --------------------------------- -- Unmarshalling / Marshalling -- --------------------------------- ---------------------------- -- Unmarshall_GIOP_Header -- ---------------------------- procedure Unmarshall_GIOP_Header (Implem : access GIOP_Implem_1_0; MCtx : access GIOP_Message_Context'Class; Buffer : access Buffers.Buffer_Type) is use Octet_Flags; pragma Warnings (Off); pragma Unreferenced (Implem); pragma Warnings (On); MCtx_1_0 : GIOP_Message_Context_1_0 renames GIOP_Message_Context_1_0 (MCtx.all); Flags : Types.Boolean; begin Flags := Unmarshall (Buffer); if Flags then MCtx_1_0.Message_Endianness := Little_Endian; else MCtx_1_0.Message_Endianness := Big_Endian; end if; pragma Assert (MCtx_1_0.Message_Endianness = Endianness (Buffer)); pragma Debug (C, O ("Message Endianness : " & MCtx_1_0.Message_Endianness'Img)); -- Extract type MCtx_1_0.Message_Type := Unmarshall (Buffer); pragma Debug (C, O ("Message Type : " & MCtx_1_0.Message_Type'Img)); -- Extract size MCtx_1_0.Message_Size := Unmarshall (Buffer); pragma Debug (C, O ("Message Size :" & MCtx_1_0.Message_Size'Img)); end Unmarshall_GIOP_Header; -------------------------- -- Marshall_GIOP_Header -- -------------------------- procedure Marshall_GIOP_Header (Implem : access GIOP_Implem_1_0; S : access Session'Class; MCtx : access GIOP_Message_Context'Class; Buffer : access Buffer_Type) is pragma Unreferenced (S, Implem); MCtx_1_0 : GIOP_Message_Context_1_0 renames GIOP_Message_Context_1_0 (MCtx.all); begin pragma Assert (Endianness (Buffer) = MCtx_1_0.Message_Endianness); Marshall (Buffer, MCtx_1_0.Message_Endianness = Little_Endian); Marshall (Buffer, MCtx_1_0.Message_Type); Marshall (Buffer, MCtx_1_0.Message_Size); end Marshall_GIOP_Header; -------------------------------- -- Unmarshall_Request_Message -- -------------------------------- procedure Unmarshall_Request_Message (Buffer : access Buffer_Type; Request_Id : out Types.Unsigned_Long; Resp_Exp : out Types.Boolean; Object_Key : out PolyORB.Objects.Object_Id_Access; Operation : out Types.String; Principal : out Types.String; Service_Contexts : out QoS_GIOP_Service_Contexts_Parameter_Access) is begin -- Service context Unmarshall_Service_Context_List (Buffer, Service_Contexts); -- Request id Request_Id := Unmarshall (Buffer); pragma Debug (C, O ("Request_Id :" & Request_Id'Img)); -- Response flags Resp_Exp := Unmarshall (Buffer); pragma Debug (C, O ("Reply expected : " & Boolean'Image (Resp_Exp))); -- Object key declare Obj : constant Stream_Element_Array := Unmarshall (Buffer); begin Object_Key := new Object_Id'(Object_Id (Obj)); end; -- Operation Operation := Types.String (Types.Identifier'(Unmarshall (Buffer))); pragma Debug (C, O ("Operation : " & Types.To_Standard_String (Operation))); Principal := Unmarshall_Latin_1_String (Buffer); end Unmarshall_Request_Message; -------------------------------- -- Marshall_GIOP_Header_Reply -- -------------------------------- procedure Marshall_GIOP_Header_Reply (Implem : access GIOP_Implem_1_0; S : access Session'Class; R : Request_Access; MCtx : access GIOP_Message_Context'Class; Buffer : access Buffer_Type) is pragma Warnings (Off); pragma Unreferenced (Implem, S); pragma Warnings (On); MCtx_1_0 : GIOP_Message_Context_1_0 renames GIOP_Message_Context_1_0 (MCtx.all); begin pragma Debug (C, O ("Marshall_GIOP_Header_Reply (1.0): Request_Id =" & MCtx_1_0.Request_Id'Img & ", status = " & MCtx_1_0.Reply_Status'Img)); Rebuild_Reply_Service_Contexts (R.all); Marshall_Service_Context_List (Buffer, QoS_GIOP_Service_Contexts_Parameter_Access (Extract_Reply_Parameter (GIOP_Service_Contexts, R.all))); Marshall (Buffer, MCtx_1_0.Request_Id); Marshall (Buffer, MCtx_1_0.Reply_Status); end Marshall_GIOP_Header_Reply; ----------------------------- -- Marshall_Locate_Request -- ----------------------------- procedure Marshall_Locate_Request (Buffer : Buffer_Access; Request_Id : Types.Unsigned_Long; Object_Key : PolyORB.Objects.Object_Id_Access) is begin Marshall (Buffer, Request_Id); Marshall (Buffer, Stream_Element_Array (Object_Key.all)); end Marshall_Locate_Request; ---------------- -- New_Implem -- ---------------- function New_Implem return GIOP_Implem_Access; function New_Implem return GIOP_Implem_Access is begin return new GIOP_Implem_1_0; end New_Implem; ---------------- -- Initialize -- ---------------- procedure Initialize; procedure Initialize is begin Global_Register_GIOP_Version (GIOP_V1_0, New_Implem'Access); end Initialize; use PolyORB.Initialization; use PolyORB.Initialization.String_Lists; use PolyORB.Utils.Strings; begin Register_Module (Module_Info' (Name => +"protocols.giop.giop_1_0", Conflicts => Empty, Depends => Empty, Provides => Empty, Implicit => False, Init => Initialize'Access, Shutdown => null)); end PolyORB.Protocols.GIOP.GIOP_1_0; polyorb-2.8~20110207.orig/src/giop/iiop/0000755000175000017500000000000011750740340017067 5ustar xavierxavierpolyorb-2.8~20110207.orig/src/giop/iiop/polyorb-giop_p-tagged_components-ssl_sec_trans.ads0000644000175000017500000001145411750740340031064 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- POLYORB.GIOP_P.TAGGED_COMPONENTS.SSL_SEC_TRANS -- -- -- -- S p e c -- -- -- -- Copyright (C) 2005-2008, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with PolyORB.Sockets; with PolyORB.Utils.Simple_Flags; package PolyORB.GIOP_P.Tagged_Components.SSL_Sec_Trans is -- Association Options from CORBA CSIv2 and Security Specification type Association_Options is new Types.Unsigned_Short; No_Protection : constant Association_Options := 1; Integrity : constant Association_Options := 2; Confidentiality : constant Association_Options := 4; Detect_Replay : constant Association_Options := 8; Detect_Misordering : constant Association_Options := 16; Establish_Trust_In_Target : constant Association_Options := 32; Establish_Trust_In_Client : constant Association_Options := 64; No_Delegation : constant Association_Options := 128; Simple_Delegation : constant Association_Options := 256; Composite_Delegation : constant Association_Options := 512; Identity_Assertion : constant Association_Options := 1024; Delegation_By_Client : constant Association_Options := 2048; function Is_Set (Flag_To_Test : Association_Options; In_Flags : Association_Options) return Boolean; -- Test if Flag_To_Test has been set in In_Flags -- Flag_To_Test is a mask function Set (Flag_To_Set : Association_Options; In_Flags : Association_Options) return Association_Options; -- Set Flag_To_Set in In_Flags -- Flag_To_Set is a mask type TC_SSL_Sec_Trans is new Tagged_Component (Tag => Tag_SSL_Sec_Trans, At_Most_Once => False) with record Target_Supports : Association_Options; Target_Requires : Association_Options; Port : Sockets.Port_Type; end record; -- Note: the at-most-once semantics of this component is not -- specified in the Security specification, par. 3.7.3, use -- default value. procedure Marshall_Component_Data (C : access TC_SSL_Sec_Trans; Buffer : access Buffer_Type); procedure Unmarshall_Component_Data (C : access TC_SSL_Sec_Trans; Buffer : access Buffer_Type; Error : out PolyORB.Errors.Error_Container); procedure Release_Contents (C : access TC_SSL_Sec_Trans); function Duplicate (C : TC_SSL_Sec_Trans) return Tagged_Component_Access; private package Association_Options_Flags is new PolyORB.Utils.Simple_Flags (Association_Options, Shift_Left); function Is_Set (Flag_To_Test : Association_Options; In_Flags : Association_Options) return Boolean renames Association_Options_Flags.Is_Set; function Set (Flag_To_Set : Association_Options; In_Flags : Association_Options) return Association_Options renames Association_Options_Flags.Set; end PolyORB.GIOP_P.Tagged_Components.SSL_Sec_Trans; polyorb-2.8~20110207.orig/src/giop/iiop/polyorb-giop_p-tagged_components-ssl_sec_trans.adb0000644000175000017500000001317211750740340031042 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- POLYORB.GIOP_P.TAGGED_COMPONENTS.SSL_SEC_TRANS -- -- -- -- B o d y -- -- -- -- Copyright (C) 2005-2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with PolyORB.Initialization; with PolyORB.Representations.CDR.Common; with PolyORB.Utils.Strings; package body PolyORB.GIOP_P.Tagged_Components.SSL_Sec_Trans is use PolyORB.Representations.CDR.Common; function Create_Empty_Component return Tagged_Component_Access; procedure Initialize; ---------------------------- -- Create_Empty_Component -- ---------------------------- function Create_Empty_Component return Tagged_Component_Access is begin return new TC_SSL_Sec_Trans; end Create_Empty_Component; --------------- -- Duplicate -- --------------- function Duplicate (C : TC_SSL_Sec_Trans) return Tagged_Component_Access is Result : constant Tagged_Component_Access := new TC_SSL_Sec_Trans; begin TC_SSL_Sec_Trans (Result.all).Target_Supports := C.Target_Supports; TC_SSL_Sec_Trans (Result.all).Target_Requires := C.Target_Requires; TC_SSL_Sec_Trans (Result.all).Port := C.Port; return Result; end Duplicate; ---------------- -- Initialize -- ---------------- procedure Initialize is begin Register (Tag_SSL_Sec_Trans, Create_Empty_Component'Access, null); end Initialize; ----------------------------- -- Marshall_Component_Data -- ----------------------------- procedure Marshall_Component_Data (C : access TC_SSL_Sec_Trans; Buffer : access Buffer_Type) is Temp_Buf : Buffer_Access := new Buffer_Type; begin Start_Encapsulation (Temp_Buf); Marshall (Temp_Buf, Types.Unsigned_Short (C.Target_Supports)); Marshall (Temp_Buf, Types.Unsigned_Short (C.Target_Requires)); Marshall (Temp_Buf, Types.Unsigned_Short (C.Port)); Marshall (Buffer, Encapsulate (Temp_Buf)); Release (Temp_Buf); end Marshall_Component_Data; ---------------------- -- Release_Contents -- ---------------------- procedure Release_Contents (C : access TC_SSL_Sec_Trans) is pragma Unreferenced (C); begin null; end Release_Contents; ------------------------------- -- Unmarshall_Component_Data -- ------------------------------- procedure Unmarshall_Component_Data (C : access TC_SSL_Sec_Trans; Buffer : access Buffer_Type; Error : out PolyORB.Errors.Error_Container) is use type Ada.Streams.Stream_Element_Offset; use PolyORB.Errors; Tag_Body : aliased Encapsulation := Unmarshall (Buffer); Temp_Buf : Buffer_Access := new Buffer_Type; begin Decapsulate (Tag_Body'Access, Temp_Buf); C.Target_Supports := Association_Options (Types.Unsigned_Short'(Unmarshall (Temp_Buf))); C.Target_Requires := Association_Options (Types.Unsigned_Short'(Unmarshall (Temp_Buf))); C.Port := Sockets.Port_Type (Types.Unsigned_Short'(Unmarshall (Temp_Buf))); pragma Assert (Remaining (Temp_Buf) = 0); Release (Temp_Buf); exception when others => Release (Temp_Buf); Throw (Error, Bad_Param_E, System_Exception_Members'(10, Completed_No)); end Unmarshall_Component_Data; use PolyORB.Initialization; use PolyORB.Utils.Strings; begin Register_Module (Module_Info' (Name => +"tagged_components.ssl_sec_trans", Conflicts => PolyORB.Initialization.String_Lists.Empty, Depends => PolyORB.Initialization.String_Lists.Empty, Provides => PolyORB.Initialization.String_Lists.Empty, Implicit => False, Init => Initialize'Access, Shutdown => null)); end PolyORB.GIOP_P.Tagged_Components.SSL_Sec_Trans; polyorb-2.8~20110207.orig/src/giop/iiop/security/0000755000175000017500000000000011750740340020736 5ustar xavierxavierpolyorb-2.8~20110207.orig/src/giop/iiop/security/polyorb-giop_p-tagged_components-null_tag.adb0000644000175000017500000001625511750740340031661 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- POLYORB.GIOP_P.TAGGED_COMPONENTS.NULL_TAG -- -- -- -- B o d y -- -- -- -- Copyright (C) 2005-2008, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with PolyORB.Binding_Data.GIOP; with PolyORB.GIOP_P.Tagged_Components.CSI_Sec_Mech_List; with PolyORB.GIOP_P.Transport_Mechanisms; with PolyORB.Initialization; with PolyORB.Representations.CDR.Common; with PolyORB.Security.Transport_Mechanisms.Unprotected; with PolyORB.Utils.Strings; package body PolyORB.GIOP_P.Tagged_Components.Null_Tag is use PolyORB.Representations.CDR.Common; use PolyORB.GIOP_P.Transport_Mechanisms; function Create_Empty_Component return Tagged_Component_Access; procedure Initialize; function To_Tagged_Component (TM : PolyORB.Security.Transport_Mechanisms. Target_Transport_Mechanism_Access) return Tagged_Component_Access; function To_Security_Transport_Mechanism (TC : access Tagged_Component'Class) return PolyORB.Security.Transport_Mechanisms.Client_Transport_Mechanism_Access; procedure Create_GIOP_Transport_Mechanisms (TC : PolyORB.GIOP_P.Tagged_Components.Tagged_Component_Access; Profile : PolyORB.Binding_Data.Profile_Access; Mechs : in out Transport_Mechanism_List); ---------------------------- -- Create_Empty_Component -- ---------------------------- function Create_Empty_Component return Tagged_Component_Access is begin return new TC_Null_Tag; end Create_Empty_Component; -------------------------------------- -- Create_GIOP_Transport_Mechanisms -- -------------------------------------- procedure Create_GIOP_Transport_Mechanisms (TC : PolyORB.GIOP_P.Tagged_Components.Tagged_Component_Access; Profile : PolyORB.Binding_Data.Profile_Access; Mechs : in out Transport_Mechanism_List) is pragma Unreferenced (TC); use PolyORB.Binding_Data.GIOP; begin Append (Mechs, Get_Primary_Transport_Mechanism (GIOP_Profile_Type (Profile.all))); end Create_GIOP_Transport_Mechanisms; --------------- -- Duplicate -- --------------- function Duplicate (C : TC_Null_Tag) return Tagged_Component_Access is pragma Unreferenced (C); begin return new TC_Null_Tag; end Duplicate; ---------------- -- Initialize -- ---------------- procedure Initialize is begin -- Register Tagged Component Register (Tag_NULL_Tag, Create_Empty_Component'Access, null); -- Register Tagged Component => GIOP Transport Mechanisms convertor PolyORB.GIOP_P.Transport_Mechanisms.Register (Tag_NULL_Tag, Create_GIOP_Transport_Mechanisms'Access); -- Register Tagged Component <=> Secure Transport Mechanism convertor PolyORB.GIOP_P.Tagged_Components.CSI_Sec_Mech_List.Register (Tag_NULL_Tag, To_Tagged_Component'Access, To_Security_Transport_Mechanism'Access); end Initialize; ----------------------------- -- Marshall_Component_Data -- ----------------------------- procedure Marshall_Component_Data (C : access TC_Null_Tag; Buffer : access Buffer_Type) is pragma Unreferenced (C); begin Marshall (Buffer, Types.Unsigned_Long (0)); end Marshall_Component_Data; ---------------------- -- Release_Contents -- ---------------------- procedure Release_Contents (C : access TC_Null_Tag) is pragma Unreferenced (C); begin null; end Release_Contents; ------------------------------------- -- To_Security_Transport_Mechanism -- ------------------------------------- function To_Security_Transport_Mechanism (TC : access Tagged_Component'Class) return PolyORB.Security.Transport_Mechanisms.Client_Transport_Mechanism_Access is pragma Unreferenced (TC); package PSTMU renames PolyORB.Security.Transport_Mechanisms.Unprotected; begin return new PSTMU.Unprotected_Transport_Mechanism; end To_Security_Transport_Mechanism; ------------------------- -- To_Tagged_Component -- ------------------------- function To_Tagged_Component (TM : PolyORB.Security.Transport_Mechanisms. Target_Transport_Mechanism_Access) return Tagged_Component_Access is pragma Unreferenced (TM); begin return null; end To_Tagged_Component; ------------------------------- -- Unmarshall_Component_Data -- ------------------------------- procedure Unmarshall_Component_Data (C : access TC_Null_Tag; Buffer : access Buffer_Type; Error : out PolyORB.Errors.Error_Container) is pragma Unreferenced (C); pragma Unreferenced (Error); use PolyORB.Types; Aux : constant Unsigned_Long := Unmarshall (Buffer); begin pragma Assert (Aux = 0); null; end Unmarshall_Component_Data; begin declare use PolyORB.Initialization; use PolyORB.Utils.Strings; begin Register_Module (Module_Info' (Name => +"tagged_components.null_tag", Conflicts => PolyORB.Initialization.String_Lists.Empty, Depends => PolyORB.Initialization.String_Lists.Empty, Provides => PolyORB.Initialization.String_Lists.Empty, Implicit => False, Init => Initialize'Access, Shutdown => null)); end; end PolyORB.GIOP_P.Tagged_Components.Null_Tag; ././@LongLink0000000000000000000000000000015000000000000011561 Lustar rootrootpolyorb-2.8~20110207.orig/src/giop/iiop/security/polyorb-giop_p-tagged_components-csi_sec_mech_list.adbpolyorb-2.8~20110207.orig/src/giop/iiop/security/polyorb-giop_p-tagged_components-csi_sec_mech_list.0000644000175000017500000010163411750740340033040 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- POLYORB.GIOP_P.TAGGED_COMPONENTS.CSI_SEC_MECH_LIST -- -- -- -- B o d y -- -- -- -- Copyright (C) 2005-2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with Ada.Unchecked_Deallocation; with PolyORB.Annotations; with PolyORB.Binding_Data.GIOP.IIOP; with PolyORB.Binding_Data_QoS; with PolyORB.Errors; with PolyORB.Initialization; with PolyORB.GIOP_P.Tagged_Components.Null_Tag; with PolyORB.Obj_Adapters; with PolyORB.ORB; with PolyORB.Protocols.GIOP; with PolyORB.QoS.Clients_Security; with PolyORB.QoS.Targets_Security; with PolyORB.QoS.Transport_Contexts; with PolyORB.Representations.CDR.Common; with PolyORB.Security.Authentication_Mechanisms; with PolyORB.Security.Backward_Trust_Evaluators; with PolyORB.Security.Forward_Trust_Evaluators; with PolyORB.Setup; with PolyORB.Utils.Strings; package body PolyORB.GIOP_P.Tagged_Components.CSI_Sec_Mech_List is use Ada.Streams; use PolyORB.Annotations; use PolyORB.ASN1; use PolyORB.Binding_Data.GIOP; use PolyORB.Errors; use PolyORB.GIOP_P.Transport_Mechanisms; use PolyORB.QoS; use PolyORB.QoS.Clients_Security; use PolyORB.QoS.Clients_Security.Client_Mechanism_Lists; use PolyORB.QoS.Targets_Security; use PolyORB.QoS.Targets_Security.Target_Mechanism_Lists; use PolyORB.QoS.Transport_Contexts; use PolyORB.Representations.CDR.Common; use PolyORB.Security.Authentication_Mechanisms; use PolyORB.Security.Authority_Mechanisms; use PolyORB.Security.Authority_Mechanisms.Client_Authority_Mechanism_Lists; use PolyORB.Security.Authority_Mechanisms.Target_Authority_Mechanism_Lists; use PolyORB.Security.Backward_Trust_Evaluators; use PolyORB.Security.Forward_Trust_Evaluators; use PolyORB.Security.Exported_Names; use PolyORB.Security.Transport_Mechanisms; use PolyORB.Security.Types; use PolyORB.Security.Types.OID_Lists; use PolyORB.Types; use Mechanism_Lists; use Service_Configuration_Lists; type Compound_Mechanism_Note is new PolyORB.Annotations.Note with record Mechanism : Mechanism_Access; end record; type Registry_Record is record Tag : Tag_Value; TC_Constructor : To_Tagged_Component; TM_Constructor : To_Security_Transport_Mechanism; end record; package Registry_Lists is new PolyORB.Utils.Chained_Lists (Registry_Record); procedure Release_Contents (X : in out Mechanism); procedure Marshall (Buffer : access Buffer_Type; Item : Mechanism); function Unmarshall (Buffer : access Buffer_Type) return Mechanism; -- WAG:504 need fully qualified name for visibility on sibling of parent -- (PolyORB.Binding_Data). procedure Create_Transport_Mechanisms (TC : Tagged_Components.Tagged_Component_Access; Profile : PolyORB.Binding_Data.Profile_Access; Mechs : in out Transport_Mechanism_List); procedure Fetch_QoS (P : access PolyORB.Binding_Data.GIOP.IIOP.IIOP_Profile_Type); function Fetch_Tagged_Component (Oid : PolyORB.Objects.Object_Id) return Tagged_Component_Access; function Fetch_QoS (End_Point : PolyORB.Transport.Transport_Endpoint_Access) return PolyORB.QoS.QoS_Parameter_Access; function Is_Selected (QoS : PolyORB.QoS.QoS_Parameters; Mechanism : PolyORB.GIOP_P.Transport_Mechanisms.Transport_Mechanism_Access) return Boolean; function Deep_Copy (Item : Mechanism_Lists.List) return Mechanism_Lists.List; function Deep_Copy (Item : Service_Configuration_Lists.List) return Service_Configuration_Lists.List; function Duplicate (Item : Mechanism_Access) return Mechanism_Access; procedure Initialize; function Create_Empty_Component return Tagged_Component_Access; Registry : Registry_Lists.List; QoS_Registry : QoS_Constructor := null; -- XXX Only one secure transportm mechanism supported for now ---------------------------- -- Create_Empty_Component -- ---------------------------- function Create_Empty_Component return Tagged_Component_Access is begin return new TC_CSI_Sec_Mech_List; end Create_Empty_Component; --------------------------------- -- Create_Transport_Mechanisms -- --------------------------------- -- WAG:504 need fully qualified name for visibility on sibling of parent -- (PolyORB.Binding_Data). procedure Create_Transport_Mechanisms (TC : Tagged_Components.Tagged_Component_Access; Profile : PolyORB.Binding_Data.Profile_Access; Mechs : in out Transport_Mechanism_List) is Iter : Mechanism_Lists.Iterator := First (TC_CSI_Sec_Mech_List (TC.all).Mechanisms); begin while not Last (Iter) loop declare TCL : Tagged_Component_List; TML : Transport_Mechanism_List; TMI : Transport_Mechanism_Lists.Iterator; use Transport_Mechanism_Lists; begin Append (TCL, Value (Iter).all.Transport_Mechanism_Tag); Create_Transport_Mechanisms (TCL, Profile, TML); -- possible memory leak, when is TML deallocated??? Deallocate (TCL); if Length (TML) = 0 then Value (Iter).all.Transport_Mechanism := null; elsif Length (TML) = 1 then TMI := First (TML); if Value (TMI).all /= Get_Primary_Transport_Mechanism (GIOP_Profile_Type (Profile.all)) then Value (Iter).all.Transport_Mechanism := Element (TML, 0).all; Append (Mechs, Value (TMI).all); else Value (Iter).all.Transport_Mechanism := Get_Primary_Transport_Mechanism (GIOP_Profile_Type (Profile.all)); end if; else raise Program_Error; end if; end; Next (Iter); end loop; end Create_Transport_Mechanisms; --------------- -- Deep_Copy -- --------------- function Deep_Copy (Item : Mechanism_Lists.List) return Mechanism_Lists.List is Result : Mechanism_Lists.List; Iter : Mechanism_Lists.Iterator := Mechanism_Lists.First (Item); begin while not Mechanism_Lists.Last (Iter) loop Mechanism_Lists.Append (Result, Duplicate (Mechanism_Lists.Value (Iter).all)); Mechanism_Lists.Next (Iter); end loop; return Result; end Deep_Copy; function Deep_Copy (Item : Service_Configuration_Lists.List) return Service_Configuration_Lists.List is Result : Service_Configuration_Lists.List; Iter : Service_Configuration_Lists.Iterator := Service_Configuration_Lists.First (Item); begin while not Service_Configuration_Lists.Last (Iter) loop Service_Configuration_Lists.Append (Result, (Service_Configuration_Lists.Value (Iter).all.Syntax, new Ada.Streams.Stream_Element_Array' (Service_Configuration_Lists.Value (Iter).all.Name.all))); Service_Configuration_Lists.Next (Iter); end loop; return Result; end Deep_Copy; --------------- -- Duplicate -- --------------- function Duplicate (Item : Mechanism_Access) return Mechanism_Access is Result : constant Mechanism_Access := new Mechanism; begin Result.Target_Requires := Item.Target_Requires; Result.Transport_Mechanism_Tag := Duplicate (Item.Transport_Mechanism_Tag.all); Result.Authentication_Target_Supports := Item.Authentication_Target_Supports; Result.Authentication_Target_Requires := Item.Authentication_Target_Requires; Result.Authentication_Mechanism := Duplicate (Item.Authentication_Mechanism); if Item.Authentication_Target_Name /= null then Result.Authentication_Target_Name := Duplicate (Item.Authentication_Target_Name); end if; Result.Attribute_Target_Supports := Item.Attribute_Target_Supports; Result.Attribute_Target_Requires := Item.Attribute_Target_Requires; Result.Attribute_Privilege_Authorities := Deep_Copy (Item.Attribute_Privilege_Authorities); Result.Attribute_Naming_Mechanisms := PolyORB.Security.Types.Duplicate (Item.Attribute_Naming_Mechanisms); Result.Attribute_Identity_Types := Item.Attribute_Identity_Types; return Result; end Duplicate; function Duplicate (C : TC_CSI_Sec_Mech_List) return Tagged_Component_Access is Result : constant TC_CSI_Sec_Mech_List_Access := new TC_CSI_Sec_Mech_List; begin Result.Stateful := C.Stateful; Result.Mechanisms := Deep_Copy (C.Mechanisms); return Tagged_Component_Access (Result); end Duplicate; --------------- -- Fetch_QoS -- --------------- procedure Fetch_QoS (P : access PolyORB.Binding_Data.GIOP.IIOP.IIOP_Profile_Type) is use PolyORB.Binding_Data_QoS; C : constant TC_CSI_Sec_Mech_List_Access := TC_CSI_Sec_Mech_List_Access (PolyORB.Binding_Data.GIOP.Get_Component (GIOP_Profile_Type (P.all), Tag_CSI_Sec_Mech_List)); begin if C = null then return; end if; declare QoS : constant QoS_Client_Security_Parameter_Access := new QoS_Client_Security_Parameter; Iter : Mechanism_Lists.Iterator := First (C.Mechanisms); begin -- If target supports unprotected invocations then add -- compound mechanism for unprotected invocations -- Append (QoS.Mechanisms, new Client_Mechanism); -- XXX For now, always add unprotected mechanism. -- Add supported by client protected compound mechanisms while not Last (Iter) loop declare Aux : Client_Mechanism_Access := new Client_Mechanism; Supported : Boolean := True; Note : Compound_Mechanism_Note; begin Aux.Stateful := C.Stateful; -- Transport Mechanism if Value (Iter).all.Transport_Mechanism_Tag = null then raise Program_Error; else Supported := False; declare use Registry_Lists; C_Iter : Registry_Lists.Iterator := First (Registry); begin while not Last (C_Iter) loop if Value (C_Iter).all.Tag = Value (Iter).all.Transport_Mechanism_Tag.Tag then Aux.Transport := Value (C_Iter).all.TM_Constructor (Value (Iter).all.Transport_Mechanism_Tag); Supported := True; exit; end if; Next (C_Iter); end loop; end; end if; -- Authentication if Is_Set (Establish_Trust_In_Client, Value (Iter).all.Authentication_Target_Supports) then Aux.Authentication_Mechanism := Create_Client_Mechanism (Duplicate (Value (Iter).all.Authentication_Mechanism), Duplicate (Value (Iter).all.Authentication_Target_Name)); Aux.Authentication_Required := Is_Set (Establish_Trust_In_Client, Value (Iter).all.Authentication_Target_Requires); if Aux.Authentication_Mechanism = null then Supported := False; end if; else Aux.Authentication_Mechanism := null; Aux.Authentication_Required := False; end if; -- Identity Assertion Aux.Identity_Assertion := Is_Set (Identity_Assertion, Value (Iter).all.Attribute_Target_Supports); if Aux.Identity_Assertion then Aux.Identity_Types := Value (Iter).all.Attribute_Identity_Types; if Is_Set (ITT_Principal_Name, Aux.Identity_Types) then Aux.Naming_Mechanisms := PolyORB.Security.Types.Duplicate (Value (Iter).all.Attribute_Naming_Mechanisms); if Aux.Naming_Mechanisms = OID_Lists.Empty then Supported := False; end if; end if; else Aux.Identity_Types := 0; end if; -- Privilege Authorities and Delegation By Client declare AP_Iter : Service_Configuration_Lists.Iterator := First (Value (Iter).all. Attribute_Privilege_Authorities); Aux_PA : Client_Authority_Mechanism_Access; begin while not Last (AP_Iter) loop Aux_PA := Create_Client_Authority_Mechanism (Value (AP_Iter).Syntax, Value (AP_Iter).Name.all); if Aux_PA = null then Supported := False; else Append (Aux.Authorities, Aux_PA); end if; Next (AP_Iter); end loop; end; if Is_Set (Delegation_By_Client, Value (Iter).all.Attribute_Target_Supports) and then Value (Iter).all.Attribute_Privilege_Authorities /= Service_Configuration_Lists.Empty then Aux.Delegation_Supported := True; Aux.Delegation_Required := Is_Set (Delegation_By_Client, Value (Iter).all.Attribute_Target_Requires); else Aux.Delegation_Supported := False; Aux.Delegation_Required := False; end if; Note.Mechanism := Value (Iter).all; Set_Note (Aux.Notepad, Note); -- If at least one layer mechanisms not supported, then -- compound mechanism not added to the list of QoS compound -- mechanisms if Supported then Append (QoS.Mechanisms, Aux); else Destroy (Aux); end if; Next (Iter); end; end loop; Set_Profile_QoS (P, Compound_Security, QoS_Parameter_Access (QoS)); end; end Fetch_QoS; function Fetch_QoS (End_Point : PolyORB.Transport.Transport_Endpoint_Access) return PolyORB.QoS.QoS_Parameter_Access is begin if QoS_Registry /= null then return QoS_Registry (End_Point); else return null; end if; end Fetch_QoS; ---------------------------- -- Fetch_Tagged_Component -- ---------------------------- function Fetch_Tagged_Component (Oid : PolyORB.Objects.Object_Id) return Tagged_Component_Access is QoS : QoS_Parameters; Error : PolyORB.Errors.Error_Container; begin PolyORB.Obj_Adapters.Get_QoS (PolyORB.ORB.Object_Adapter (PolyORB.Setup.The_ORB), Oid, QoS, Error); if PolyORB.Errors.Found (Error) then raise Program_Error; end if; if QoS (Compound_Security) /= null then declare Result : constant TC_CSI_Sec_Mech_List_Access := new TC_CSI_Sec_Mech_List; M : constant Mechanism_Access := new Mechanism; Iter : Target_Mechanism_Lists.Iterator := First (QoS_Target_Security_Parameter (QoS (Compound_Security).all).Mechanisms); begin Result.Stateful := QoS_Target_Security_Parameter (QoS (Compound_Security).all).Stateful; while not Last (Iter) loop M.Target_Requires := Target_Requires (Value (Iter).all.all); -- Transport mechanism if Value (Iter).all.Transport = null then M.Transport_Mechanism_Tag := new Null_Tag.TC_Null_Tag; else declare use Registry_Lists; C_Iter : Registry_Lists.Iterator := First (Registry); begin while not Last (C_Iter) loop M.Transport_Mechanism_Tag := Value (C_Iter).all.TC_Constructor (Value (Iter).all.Transport); exit when M.Transport_Mechanism_Tag /= null; Next (C_Iter); end loop; end; end if; -- Authentication layer M.Authentication_Target_Supports := 0; M.Authentication_Target_Requires := 0; M.Authentication_Mechanism := Null_Object_Identifier; M.Authentication_Target_Name := null; if Value (Iter).all.Authentication_Mechanism /= null then M.Authentication_Target_Supports := Establish_Trust_In_Client; if Value (Iter).all.Authentication_Required then M.Authentication_Target_Requires := Establish_Trust_In_Client; end if; M.Authentication_Mechanism := Duplicate (Get_Mechanism_OID (Value (Iter).all.Authentication_Mechanism)); M.Authentication_Target_Name := Duplicate (Get_Target_Name (Value (Iter).all.Authentication_Mechanism)); end if; -- Attribute layer M.Attribute_Target_Supports := 0; M.Attribute_Target_Requires := 0; M.Attribute_Identity_Types := 0; if Value (Iter).all.Backward_Trust_Evaluator /= null or else Value (Iter).all.Forward_Trust_Evaluator /= null then M.Attribute_Target_Supports := Identity_Assertion; M.Attribute_Naming_Mechanisms := PolyORB.Security.Types.Duplicate (Value (Iter).all.Naming_Mechanisms); M.Attribute_Identity_Types := Value (Iter).all.Identity_Types; end if; if Value (Iter).all.Authorities /= Target_Authority_Mechanism_Lists.Empty then declare PA_Iter : Target_Authority_Mechanism_Lists.Iterator := First (Value (Iter).all.Authorities); begin while not Last (PA_Iter) loop Append (M.Attribute_Privilege_Authorities, (Get_Service_Configuration_Syntax (Value (PA_Iter).all), new Ada.Streams.Stream_Element_Array' (Encode (Value (PA_Iter).all)))); Next (PA_Iter); end loop; end; if Value (Iter).all.Forward_Trust_Evaluator /= null then -- XXX DelegationByClient is a property of trust -- evaluator! Should be investigated! M.Attribute_Target_Supports := M.Attribute_Target_Supports or Delegation_By_Client; if Value (Iter).all.Delegation_Required then M.Attribute_Target_Requires := Delegation_By_Client; end if; end if; end if; Append (Result.Mechanisms, M); Next (Iter); end loop; return Tagged_Component_Access (Result); end; end if; return null; end Fetch_Tagged_Component; ---------------- -- Initialize -- ---------------- procedure Initialize is begin -- Register Tagged Component Register (Tag_CSI_Sec_Mech_List, Create_Empty_Component'Access, null); -- Register Tagged Component => Transport Mechanisms convertor Register (Tag_CSI_Sec_Mech_List, Create_Transport_Mechanisms'Access); -- Register POA QoS => Tagged Component convertor PolyORB.Binding_Data.GIOP.IIOP.Security_Fetch_Tagged_Component := Fetch_Tagged_Component'Access; -- Register Tagged Component => QoS convertor PolyORB.Binding_Data.GIOP.IIOP.Security_Fetch_QoS := Fetch_QoS'Access; -- Setup GIOP transport mechanism selection hook PolyORB.Binding_Data.GIOP.Is_Security_Selected := Is_Selected'Access; -- Setup GIOP secure transport => QoS hook PolyORB.Protocols.GIOP.Fetch_Secure_Transport_QoS := Fetch_QoS'Access; end Initialize; ----------------- -- Is_Selected -- ----------------- function Is_Selected (QoS : PolyORB.QoS.QoS_Parameters; Mechanism : PolyORB.GIOP_P.Transport_Mechanisms.Transport_Mechanism_Access) return Boolean is Note : Compound_Mechanism_Note; begin if QoS (Transport_Security) = null then -- Unprotected invocation return True; end if; Get_Note (QoS_Transport_Context_Parameter_Access (QoS (Transport_Security)).Selected.Notepad, Note); return Mechanism = Note.Mechanism.Transport_Mechanism; end Is_Selected; -------------- -- Marshall -- -------------- procedure Marshall (Buffer : access Buffer_Type; Item : Mechanism) is begin -- Marshall target requirements Marshall (Buffer, Unsigned_Short (Item.Target_Requires)); -- Marshall transport mechanism tag Marshall_Tagged_Component (Buffer, Item.Transport_Mechanism_Tag); -- Marshall authentication layer configuration Marshall (Buffer, Unsigned_Short (Item.Authentication_Target_Supports)); Marshall (Buffer, Unsigned_Short (Item.Authentication_Target_Requires)); if Item.Authentication_Mechanism /= Null_Object_Identifier then Marshall (Buffer, Encode (Item.Authentication_Mechanism)); else Marshall (Buffer, Stream_Element_Array'(1 .. 0 => 0)); end if; if Item.Authentication_Target_Name /= null then Marshall (Buffer, Encode (Item.Authentication_Target_Name)); else Marshall (Buffer, Stream_Element_Array'(1 .. 0 => 0)); end if; -- Marshall attribute layer configuration Marshall (Buffer, Unsigned_Short (Item.Attribute_Target_Supports)); Marshall (Buffer, Unsigned_Short (Item.Attribute_Target_Requires)); Marshall (Buffer, Unsigned_Long (Length (Item.Attribute_Privilege_Authorities))); declare Iter : Service_Configuration_Lists.Iterator := First (Item.Attribute_Privilege_Authorities); begin while not Last (Iter) loop Marshall (Buffer, Unsigned_Long (Value (Iter).Syntax)); Marshall (Buffer, Value (Iter).Name.all); Next (Iter); end loop; end; Marshall (Buffer, Unsigned_Long (Length (Item.Attribute_Naming_Mechanisms))); declare Iter : OID_Lists.Iterator := First (Item.Attribute_Naming_Mechanisms); begin while not Last (Iter) loop Marshall (Buffer, Encode (Value (Iter).all)); Next (Iter); end loop; end; Marshall (Buffer, Unsigned_Long (Item.Attribute_Identity_Types)); end Marshall; ----------------------------- -- Marshall_Component_Data -- ----------------------------- procedure Marshall_Component_Data (C : access TC_CSI_Sec_Mech_List; Buffer : access Buffer_Type) is Temp_Buf : Buffer_Access := new Buffer_Type; begin -- The body of Tag_CSI_Sec_Mech_List component is an encapsulation Start_Encapsulation (Temp_Buf); Marshall (Temp_Buf, C.Stateful); Marshall (Temp_Buf, Unsigned_Long (Length (C.Mechanisms))); declare Iter : Mechanism_Lists.Iterator := First (C.Mechanisms); begin while not Last (Iter) loop Marshall (Temp_Buf, Value (Iter).all.all); Next (Iter); end loop; end; Marshall (Buffer, Encapsulate (Temp_Buf)); Release (Temp_Buf); end Marshall_Component_Data; -------------- -- Register -- -------------- procedure Register (Tag : Tag_Value; TC_Constructor : To_Tagged_Component; TM_Constructor : To_Security_Transport_Mechanism) is begin Registry_Lists.Append (Registry, (Tag, TC_Constructor, TM_Constructor)); end Register; procedure Register (Constructor : QoS_Constructor) is begin QoS_Registry := Constructor; end Register; ---------------------- -- Release_Contents -- ---------------------- procedure Release_Contents (X : in out Mechanism) is procedure Free is new Ada.Unchecked_Deallocation (Tagged_Component'Class, Tagged_Component_Access); procedure Free is new Ada.Unchecked_Deallocation (Stream_Element_Array, Stream_Element_Array_Access); begin Release_Contents (X.Transport_Mechanism_Tag); Free (X.Transport_Mechanism_Tag); Destroy (X.Authentication_Mechanism); Destroy (X.Authentication_Target_Name); declare Iter : Service_Configuration_Lists.Iterator := First (X.Attribute_Privilege_Authorities); begin while not Last (Iter) loop Free (Value (Iter).all.Name); Next (Iter); end loop; Deallocate (X.Attribute_Privilege_Authorities); end; declare Iter : OID_Lists.Iterator := First (X.Attribute_Naming_Mechanisms); begin while not Last (Iter) loop Destroy (Value (Iter).all); Next (Iter); end loop; Deallocate (X.Attribute_Naming_Mechanisms); end; end Release_Contents; procedure Release_Contents (C : access TC_CSI_Sec_Mech_List) is procedure Free is new Ada.Unchecked_Deallocation (Mechanism, Mechanism_Access); Iter : Mechanism_Lists.Iterator := First (C.Mechanisms); begin while not Last (Iter) loop Release_Contents (Value (Iter).all.all); Free (Value (Iter).all); Next (Iter); end loop; Deallocate (C.Mechanisms); end Release_Contents; ---------------- -- Unmarshall -- ---------------- function Unmarshall (Buffer : access Buffer_Type) return Mechanism is Result : Mechanism; Error : Error_Container; begin -- Target requirements Result.Target_Requires := Association_Options (Unsigned_Short'(Unmarshall (Buffer))); -- Transport mechanism tag Unmarshall_Tagged_Component (Buffer, Result.Transport_Mechanism_Tag, Error); pragma Assert (not Found (Error)); -- XXX Should be properly handled. -- Authentication layer configuration Result.Authentication_Target_Supports := Association_Options (Unsigned_Short'(Unmarshall (Buffer))); Result.Authentication_Target_Requires := Association_Options (Unsigned_Short'(Unmarshall (Buffer))); declare Aux : constant Stream_Element_Array := Unmarshall (Buffer); begin if Aux'Length /= 0 then Result.Authentication_Mechanism := Decode (Aux); else Result.Authentication_Mechanism := Null_Object_Identifier; end if; end; declare Aux : constant Stream_Element_Array := Unmarshall (Buffer); begin if Aux'Length /= 0 then Decode (Aux, Result.Authentication_Target_Name, Error); if Found (Error) then Catch (Error); raise Program_Error; end if; else Result.Authentication_Target_Name := null; end if; end; -- Attribute layer configuration Result.Attribute_Target_Supports := Association_Options (Unsigned_Short'(Unmarshall (Buffer))); Result.Attribute_Target_Requires := Association_Options (Unsigned_Short'(Unmarshall (Buffer))); declare Length : constant Unsigned_Long := Unmarshall (Buffer); begin for J in 1 .. Length loop declare Syntax : constant Service_Configuration_Syntax := Service_Configuration_Syntax (Unsigned_Long'(Unmarshall (Buffer))); begin Append (Result.Attribute_Privilege_Authorities, (Syntax, new Stream_Element_Array'(Unmarshall (Buffer)))); end; end loop; end; declare Length : constant Unsigned_Long := Unmarshall (Buffer); begin for J in 1 .. Length loop Append (Result.Attribute_Naming_Mechanisms, Decode (Unmarshall (Buffer))); end loop; end; Result.Attribute_Identity_Types := Identity_Token_Type (Unsigned_Long'(Unmarshall (Buffer))); return Result; end Unmarshall; ------------------------------- -- Unmarshall_Component_Data -- ------------------------------- procedure Unmarshall_Component_Data (C : access TC_CSI_Sec_Mech_List; Buffer : access Buffer_Type; Error : out PolyORB.Errors.Error_Container) is Tag_Body : aliased Encapsulation := Unmarshall (Buffer); Temp_Buf : Buffer_Access := new Buffer_Type; Len : Unsigned_Long; begin Decapsulate (Tag_Body'Access, Temp_Buf); C.Stateful := Unmarshall (Temp_Buf); Len := Unmarshall (Temp_Buf); for J in 1 .. Len loop Append (C.Mechanisms, new Mechanism'(Unmarshall (Temp_Buf))); end loop; pragma Assert (Remaining (Temp_Buf) = 0); Release (Temp_Buf); exception when others => Release (Temp_Buf); Throw (Error, Bad_Param_E, System_Exception_Members'(10, Completed_No)); end Unmarshall_Component_Data; begin declare use PolyORB.Initialization; use PolyORB.Initialization.String_Lists; use PolyORB.Utils.Strings; begin Register_Module (Module_Info' (Name => +"giop_p.tagged_components.csi_sec_mech_list", Conflicts => PolyORB.Initialization.String_Lists.Empty, Depends => PolyORB.Initialization.String_Lists.Empty, Provides => PolyORB.Initialization.String_Lists.Empty, Implicit => False, Init => Initialize'Access, Shutdown => null)); end; end PolyORB.GIOP_P.Tagged_Components.CSI_Sec_Mech_List; ././@LongLink0000000000000000000000000000015000000000000011561 Lustar rootrootpolyorb-2.8~20110207.orig/src/giop/iiop/security/polyorb-giop_p-tagged_components-csi_sec_mech_list.adspolyorb-2.8~20110207.orig/src/giop/iiop/security/polyorb-giop_p-tagged_components-csi_sec_mech_list.0000644000175000017500000001306111750740340033034 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- POLYORB.GIOP_P.TAGGED_COMPONENTS.CSI_SEC_MECH_LIST -- -- -- -- S p e c -- -- -- -- Copyright (C) 2005-2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- TAG_CSI_SEC_MECH_LIST Tagged Component with PolyORB.ASN1; with PolyORB.GIOP_P.Transport_Mechanisms; with PolyORB.Security.Exported_Names; with PolyORB.Security.Authority_Mechanisms; with PolyORB.Security.Transport_Mechanisms; with PolyORB.Security.Types; with PolyORB.Transport; package PolyORB.GIOP_P.Tagged_Components.CSI_Sec_Mech_List is type Service_Configuration is record Syntax : PolyORB.Security.Authority_Mechanisms.Service_Configuration_Syntax; Name : PolyORB.Security.Types.Stream_Element_Array_Access; end record; package Service_Configuration_Lists is new PolyORB.Utils.Chained_Lists (Service_Configuration); type Mechanism is record Target_Requires : PolyORB.Security.Types.Association_Options; Transport_Mechanism_Tag : Tagged_Component_Access; Authentication_Target_Supports : PolyORB.Security.Types.Association_Options; Authentication_Target_Requires : PolyORB.Security.Types.Association_Options; Authentication_Mechanism : PolyORB.ASN1.Object_Identifier; Authentication_Target_Name : PolyORB.Security.Exported_Names.Exported_Name_Access; Attribute_Target_Supports : PolyORB.Security.Types.Association_Options; Attribute_Target_Requires : PolyORB.Security.Types.Association_Options; Attribute_Privilege_Authorities : Service_Configuration_Lists.List; Attribute_Naming_Mechanisms : PolyORB.Security.Types.OID_Lists.List; Attribute_Identity_Types : PolyORB.Security.Types.Identity_Token_Type; Transport_Mechanism : PolyORB.GIOP_P.Transport_Mechanisms.Transport_Mechanism_Access; -- Corresponding GIOP Transport Mechanism. This item shared with -- Profile's list of Transport Mechanisms. end record; type Mechanism_Access is access all Mechanism; package Mechanism_Lists is new PolyORB.Utils.Chained_Lists (Mechanism_Access); type TC_CSI_Sec_Mech_List is new Tagged_Component (Tag => Tag_CSI_Sec_Mech_List, At_Most_Once => True) with record Stateful : Boolean; Mechanisms : Mechanism_Lists.List; end record; type TC_CSI_Sec_Mech_List_Access is access all TC_CSI_Sec_Mech_List'Class; procedure Marshall_Component_Data (C : access TC_CSI_Sec_Mech_List; Buffer : access Buffer_Type); procedure Unmarshall_Component_Data (C : access TC_CSI_Sec_Mech_List; Buffer : access Buffer_Type; Error : out PolyORB.Errors.Error_Container); procedure Release_Contents (C : access TC_CSI_Sec_Mech_List); function Duplicate (C : TC_CSI_Sec_Mech_List) return Tagged_Component_Access; -- Registry for Transport Mechanisms Tagged Components type To_Security_Transport_Mechanism is access function (TC : access Tagged_Component'Class) return PolyORB.Security.Transport_Mechanisms.Client_Transport_Mechanism_Access; type To_Tagged_Component is access function (TM : PolyORB.Security.Transport_Mechanisms. Target_Transport_Mechanism_Access) return Tagged_Component_Access; procedure Register (Tag : Tag_Value; TC_Constructor : To_Tagged_Component; TM_Constructor : To_Security_Transport_Mechanism); -- Registry for Transport Mechanism's QoS constructors type QoS_Constructor is access function (End_Point : PolyORB.Transport.Transport_Endpoint_Access) return PolyORB.QoS.QoS_Parameter_Access; procedure Register (Constructor : QoS_Constructor); end PolyORB.GIOP_P.Tagged_Components.CSI_Sec_Mech_List; polyorb-2.8~20110207.orig/src/giop/iiop/security/polyorb-giop_p-tagged_components-null_tag.ads0000644000175000017500000000527711750740340031704 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- POLYORB.GIOP_P.TAGGED_COMPONENTS.NULL_TAG -- -- -- -- S p e c -- -- -- -- Copyright (C) 2005-2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- Used only as transport_mech in TAG_CSI_SEC_MECH_LIST tagged component. package PolyORB.GIOP_P.Tagged_Components.Null_Tag is type TC_Null_Tag is new Tagged_Component (Tag => Tag_NULL_Tag, At_Most_Once => False) with null record; procedure Marshall_Component_Data (C : access TC_Null_Tag; Buffer : access Buffer_Type); procedure Unmarshall_Component_Data (C : access TC_Null_Tag; Buffer : access Buffer_Type; Error : out PolyORB.Errors.Error_Container); procedure Release_Contents (C : access TC_Null_Tag); function Duplicate (C : TC_Null_Tag) return Tagged_Component_Access; end PolyORB.GIOP_P.Tagged_Components.Null_Tag; polyorb-2.8~20110207.orig/src/giop/iiop/security/tls/0000755000175000017500000000000011750740340021540 5ustar xavierxavierpolyorb-2.8~20110207.orig/src/giop/iiop/security/tls/polyorb-setup-access_points-tlsiop.adb0000644000175000017500000001645711750740340031214 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . S E T U P . A C C E S S _ P O I N T S . T L S I O P -- -- -- -- B o d y -- -- -- -- Copyright (C) 2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with PolyORB.Filters.Slicers; with PolyORB.Initialization; with PolyORB.ORB; with PolyORB.Parameters; with PolyORB.Protocols.GIOP.IIOP; with PolyORB.Security.Security_Manager; with PolyORB.Security.Transport_Mechanisms.TLS; with PolyORB.Sockets; with PolyORB.Transport.Connected.Sockets.TLS; with PolyORB.Utils.TLS_Access_Points; with PolyORB.Utils.Strings; package body PolyORB.Setup.Access_Points.TLSIOP is procedure Initialize; function Create_Target_Transport_Mechanism (Section_Name : String) return PolyORB.Security.Transport_Mechanisms.Target_Transport_Mechanism_Access; Sli : aliased PolyORB.Filters.Slicers.Slicer_Factory; Pro : aliased PolyORB.Protocols.GIOP.IIOP.IIOP_Protocol; IIOP_Factories : aliased Filters.Factory_Array := (0 => Sli'Access, 1 => Pro'Access); --------------------------------------- -- Create_Target_Transport_Mechanism -- --------------------------------------- function Create_Target_Transport_Mechanism (Section_Name : String) return PolyORB.Security.Transport_Mechanisms.Target_Transport_Mechanism_Access is use PolyORB.Parameters; use PolyORB.Security.Transport_Mechanisms; use PolyORB.Security.Transport_Mechanisms.TAP_Lists; use PolyORB.Security.Transport_Mechanisms.TLS; use PolyORB.Sockets; use PolyORB.Transport.Connected.Sockets.TLS; use PolyORB.Utils.TLS_Access_Points; Addresses : constant String := Get_Conf (Section_Name, "addresses", ""); Addr : Inet_Addr_Type := No_Inet_Addr; Port : Port_Type := Any_Port; Result : constant Target_Transport_Mechanism_Access := new Target_TLS_Transport_Mechanism; Point : Access_Point_Info := (Socket => No_Socket, Address => No_Sock_Addr, SAP => null, PF => null); begin if Addresses = "" then Initialize_Socket (Point, Addr, Port); PolyORB.ORB.Register_Access_Point (ORB => PolyORB.Setup.The_ORB, TAP => Point.SAP, Chain => IIOP_Factories'Access, PF => null); Set_Transport_Mechanism (TLS_Access_Point (Point.SAP.all), Result); Append (Target_TLS_Transport_Mechanism (Result.all).TAP, Point.SAP); else declare First : Positive := Addresses'First; Last : Natural := 0; Delim : Natural := 0; begin while First <= Addresses'Last loop -- Skip all spaces while First <= Addresses'Last and then Addresses (First) = ' ' loop First := First + 1; end loop; -- Find end of address for J in First .. Addresses'Last loop if Addresses (J) = ' ' then Last := J - 1; exit; elsif J = Addresses'Last then Last := J; end if; end loop; -- Find host/port delimiter Delim := Last + 1; for J in First .. Last loop if Addresses (J) = ':' then Delim := J; exit; end if; end loop; -- Create transport access point and register it Addr := Inet_Addr (Addresses (First .. Delim - 1)); if Delim < Last then Port := Port_Type'Value (Addresses (Delim + 1 .. Last)); else Port := Any_Port; end if; Point := (No_Socket, No_Sock_Addr, null, null); if Addr /= No_Inet_Addr then Initialize_Socket (Point, Addr, Port); PolyORB.ORB.Register_Access_Point (ORB => PolyORB.Setup.The_ORB, TAP => Point.SAP, Chain => IIOP_Factories'Access, PF => null); Set_Transport_Mechanism (TLS_Access_Point (Point.SAP.all), Result); Append (Target_TLS_Transport_Mechanism (Result.all).TAP, Point.SAP); end if; First := Last + 1; end loop; end; end if; return Result; end Create_Target_Transport_Mechanism; ---------------- -- Initialize -- ---------------- procedure Initialize is begin PolyORB.Security.Security_Manager.Register_Transport_Mechanism ("tlsiop", Create_Target_Transport_Mechanism ("tlsiop")); end Initialize; begin declare use PolyORB.Initialization; use PolyORB.Initialization.String_Lists; use PolyORB.Utils.Strings; begin Register_Module (Module_Info' (Name => +"polyorb.setup.access_points.tlsiop", Conflicts => PolyORB.Initialization.String_Lists.Empty, Depends => +"orb" & "polyorb.security.security_manager" & "polyorb.setup.tlsiop", Provides => PolyORB.Initialization.String_Lists.Empty, Implicit => False, Init => Initialize'Access, Shutdown => null)); end; end PolyORB.Setup.Access_Points.TLSIOP; ././@LongLink0000000000000000000000000000015000000000000011561 Lustar rootrootpolyorb-2.8~20110207.orig/src/giop/iiop/security/tls/polyorb-giop_p-tagged_components-tls_sec_trans.adbpolyorb-2.8~20110207.orig/src/giop/iiop/security/tls/polyorb-giop_p-tagged_components-tls_sec_trans.0000644000175000017500000002201011750740340033034 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- POLYORB.GIOP_P.TAGGED_COMPONENTS.TLS_SEC_TRANS -- -- -- -- B o d y -- -- -- -- Copyright (C) 2005-2008, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with PolyORB.GIOP_P.Tagged_Components.CSI_Sec_Mech_List; with PolyORB.Initialization; with PolyORB.Representations.CDR.Common; with PolyORB.Security.Transport_Mechanisms.TLS; with PolyORB.Transport.Connected.Sockets.TLS; with PolyORB.Utils.Strings; package body PolyORB.GIOP_P.Tagged_Components.TLS_Sec_Trans is use PolyORB.Representations.CDR.Common; use PolyORB.Security.Transport_Mechanisms; use PolyORB.Security.Transport_Mechanisms.TLS; use PolyORB.Transport.Connected.Sockets.TLS; use Socket_Name_Lists; function Create_Empty_Component return Tagged_Component_Access; procedure Initialize; function To_Tagged_Component (TM : PolyORB.Security.Transport_Mechanisms. Target_Transport_Mechanism_Access) return Tagged_Component_Access; function To_Security_Transport_Mechanism (TC : access Tagged_Component'Class) return PolyORB.Security.Transport_Mechanisms.Client_Transport_Mechanism_Access; ---------------------------- -- Create_Empty_Component -- ---------------------------- function Create_Empty_Component return Tagged_Component_Access is begin return new TC_TLS_Sec_Trans; end Create_Empty_Component; --------------- -- Duplicate -- --------------- function Duplicate (C : TC_TLS_Sec_Trans) return Tagged_Component_Access is TC : constant Tagged_Component_Access := new TC_TLS_Sec_Trans; Result : TC_TLS_Sec_Trans renames TC_TLS_Sec_Trans (TC.all); Iter : Socket_Name_Lists.Iterator := First (C.Addresses); begin Result.Target_Supports := C.Target_Supports; Result.Target_Requires := C.Target_Requires; while not Last (Iter) loop Append (Result.Addresses, new Socket_Name'(Value (Iter).all.all)); Next (Iter); end loop; return TC; end Duplicate; ---------------- -- Initialize -- ---------------- procedure Initialize is begin -- Register tagged component Register (Tag_TLS_Sec_Trans, Create_Empty_Component'Access, null); -- Register Tagged Component <=> Security Transport Mechanism convertors PolyORB.GIOP_P.Tagged_Components.CSI_Sec_Mech_List.Register (Tag_TLS_Sec_Trans, To_Tagged_Component'Access, To_Security_Transport_Mechanism'Access); end Initialize; ----------------------------- -- Marshall_Component_Data -- ----------------------------- procedure Marshall_Component_Data (C : access TC_TLS_Sec_Trans; Buffer : access Buffer_Type) is Temp_Buf : Buffer_Access := new Buffer_Type; Iter : Socket_Name_Lists.Iterator := First (C.Addresses); begin Start_Encapsulation (Temp_Buf); Marshall (Temp_Buf, Types.Unsigned_Short (C.Target_Supports)); Marshall (Temp_Buf, Types.Unsigned_Short (C.Target_Requires)); Marshall (Temp_Buf, Types.Unsigned_Long (Length (C.Addresses))); while not Last (Iter) loop Marshall_Socket (Temp_Buf, Value (Iter).all.all); Next (Iter); end loop; Marshall (Buffer, Encapsulate (Temp_Buf)); Release (Temp_Buf); end Marshall_Component_Data; ---------------------- -- Release_Contents -- ---------------------- procedure Release_Contents (C : access TC_TLS_Sec_Trans) is Iter : Socket_Name_Lists.Iterator := First (C.Addresses); begin while not Last (Iter) loop Free (Value (Iter).all); Next (Iter); end loop; Deallocate (C.Addresses); end Release_Contents; ------------------------------------- -- To_Security_Transport_Mechanism -- ------------------------------------- function To_Security_Transport_Mechanism (TC : access Tagged_Component'Class) return PolyORB.Security.Transport_Mechanisms.Client_Transport_Mechanism_Access is Result : constant Client_Transport_Mechanism_Access := new Client_TLS_Transport_Mechanism; begin Client_TLS_Transport_Mechanism (Result.all).Target_Supports := TC_TLS_Sec_Trans (TC.all).Target_Supports; Client_TLS_Transport_Mechanism (Result.all).Target_Requires := TC_TLS_Sec_Trans (TC.all).Target_Requires; -- XXX Set up addresses (if will be needed) return Result; end To_Security_Transport_Mechanism; ------------------------- -- To_Tagged_Component -- ------------------------- function To_Tagged_Component (TM : PolyORB.Security.Transport_Mechanisms. Target_Transport_Mechanism_Access) return Tagged_Component_Access is use PolyORB.Security.Types; Result : constant Tagged_Component_Access := new TC_TLS_Sec_Trans; Iter : TAP_Lists.Iterator := TAP_Lists.First (TM.TAP); begin TC_TLS_Sec_Trans (Result.all).Target_Supports := Target_Supports (TM); TC_TLS_Sec_Trans (Result.all).Target_Requires := Target_Requires (TM); while not TAP_Lists.Last (Iter) loop Append (TC_TLS_Sec_Trans (Result.all).Addresses, new Socket_Name'(Address_Of (TLS_Access_Point (TAP_Lists.Value (Iter).all.all)))); TAP_Lists.Next (Iter); end loop; return Result; end To_Tagged_Component; ------------------------------- -- Unmarshall_Component_Data -- ------------------------------- procedure Unmarshall_Component_Data (C : access TC_TLS_Sec_Trans; Buffer : access Buffer_Type; Error : out PolyORB.Errors.Error_Container) is use type Ada.Streams.Stream_Element_Offset; use PolyORB.Errors; Tag_Body : aliased Encapsulation := Unmarshall (Buffer); Temp_Buf : Buffer_Access := new Buffer_Type; Length : Types.Unsigned_Long; begin Decapsulate (Tag_Body'Access, Temp_Buf); C.Target_Supports := PolyORB.Security.Types.Association_Options (Types.Unsigned_Short'(Unmarshall (Temp_Buf))); C.Target_Requires := PolyORB.Security.Types.Association_Options (Types.Unsigned_Short'(Unmarshall (Temp_Buf))); Length := Unmarshall (Temp_Buf); for J in 1 .. Length loop Append (C.Addresses, new Socket_Name'(Unmarshall_Socket (Temp_Buf))); end loop; pragma Assert (Remaining (Temp_Buf) = 0); Release (Temp_Buf); exception when others => Release (Temp_Buf); Throw (Error, Bad_Param_E, System_Exception_Members'(10, Completed_No)); end Unmarshall_Component_Data; begin declare use PolyORB.Initialization; use PolyORB.Initialization.String_Lists; use PolyORB.Utils.Strings; begin Register_Module (Module_Info' (Name => +"tagged_components.tls_sec_trans", Conflicts => PolyORB.Initialization.String_Lists.Empty, Depends => +"giop_p.tagged_components.csi_sec_mech_list", Provides => PolyORB.Initialization.String_Lists.Empty, Implicit => False, Init => Initialize'Access, Shutdown => null)); end; end PolyORB.GIOP_P.Tagged_Components.TLS_Sec_Trans; polyorb-2.8~20110207.orig/src/giop/iiop/security/tls/polyorb-giop_p-transport_mechanisms-tls.adb0000644000175000017500000004561411750740340032224 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- POLYORB.GIOP_P.TRANSPORT_MECHANISMS.TLS -- -- -- -- B o d y -- -- -- -- Copyright (C) 2005-2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- with Ada.Strings.Fixed; -- with PolyORB.Binding_Data.GIOP.IIOP; with PolyORB.Binding_Objects; with PolyORB.Filters.Slicers; with PolyORB.GIOP_P.Tagged_Components.CSI_Sec_Mech_List; -- with PolyORB.GIOP_P.Tagged_Components.SSL_Sec_Trans; -- with PolyORB.GIOP_P.Transport_Mechanisms.IIOP; with PolyORB.Initialization; with PolyORB.ORB; -- with PolyORB.Parameters; with PolyORB.Protocols.GIOP.IIOP; with PolyORB.QoS.Transport_Contexts; with PolyORB.Security.Credentials.Compound; with PolyORB.Security.Credentials.TLS; with PolyORB.Sockets; with PolyORB.TLS; with PolyORB.Transport.Connected.Sockets.TLS; with PolyORB.Utils.Sockets; with PolyORB.Utils.Strings; package body PolyORB.GIOP_P.Transport_Mechanisms.TLS is use PolyORB.Components; use PolyORB.Errors; use PolyORB.GIOP_P.Tagged_Components; use PolyORB.GIOP_P.Tagged_Components.TLS_Sec_Trans; use PolyORB.GIOP_P.Tagged_Components.TLS_Sec_Trans.Socket_Name_Lists; use PolyORB.QoS; use PolyORB.QoS.Transport_Contexts; use PolyORB.Security.Credentials; use PolyORB.Security.Credentials.Compound; use PolyORB.Security.Credentials.TLS; use PolyORB.Sockets; use PolyORB.TLS; use PolyORB.Transport.Connected.Sockets.TLS; procedure Initialize; procedure Create (TC : Tagged_Components.Tagged_Component_Access; Profile : Binding_Data.Profile_Access; Mechs : in out Transport_Mechanism_List); -- Create list of Transport Mechanism from list of Tagged Component function Create_QoS (End_Point : PolyORB.Transport.Transport_Endpoint_Access) return PolyORB.QoS.QoS_Parameter_Access; -- Create QoS parameter from transport endpoint function Extract_TLS_Credentials (Credentials : Credentials_Ref) return TLS_Credentials_Access; -- Binding_Context : SSL_Context_Type; -------------------- -- Bind_Mechanism -- -------------------- -- Factories Sli : aliased PolyORB.Filters.Slicers.Slicer_Factory; Pro : aliased PolyORB.Protocols.GIOP.IIOP.IIOP_Protocol; IIOP_Factories : constant PolyORB.Filters.Factory_Array := (0 => Sli'Access, 1 => Pro'Access); procedure Bind_Mechanism (Mechanism : TLS_Transport_Mechanism; Profile : access PolyORB.Binding_Data.Profile_Type'Class; The_ORB : Components.Component_Access; QoS : PolyORB.QoS.QoS_Parameters; BO_Ref : out Smart_Pointers.Ref; Error : out Errors.Error_Container) is Sock : Socket_Type; TLS_Sock : TLS_Socket_Type; Remote_Addr : Utils.Sockets.Socket_Name_Ptr; TE : PolyORB.Transport.Transport_Endpoint_Access; Iter : Socket_Name_Lists.Iterator := First (Mechanism.Addresses); Creds : constant TLS_Credentials_Access := Extract_TLS_Credentials (QoS_Transport_Context_Parameter_Access (QoS (Transport_Security)).Invocation_Credentials); begin if Profile.all not in PolyORB.Binding_Data.GIOP.IIOP.IIOP_Profile_Type then Throw (Error, Comm_Failure_E, System_Exception_Members' (Minor => 0, Completed => Completed_Maybe)); return; end if; while not Last (Iter) loop begin Remote_Addr := Value (Iter).all; Create_Socket (Sock); Utils.Sockets.Connect_Socket (Sock, Remote_Addr.all); TLS_Sock := Create_Invocation_Socket (Creds); Set_Socket (TLS_Sock, Sock); Connect_Socket (TLS_Sock); TE := new TLS_Endpoint; Create (TLS_Endpoint (TE.all), TLS_Sock); Binding_Objects.Setup_Binding_Object (The_ORB, TE, IIOP_Factories, BO_Ref, Binding_Data.Profile_Access (Profile)); ORB.Register_Binding_Object (ORB.ORB_Access (The_ORB), BO_Ref, ORB.Client); -- XXX Accepting credentials should be computed!!! exit; exception when Sockets.Socket_Error => -- This is dubious if not Last (Iter)??? Throw (Error, Comm_Failure_E, System_Exception_Members' (Minor => 0, Completed => Completed_No)); end; Next (Iter); end loop; exception when TLS_Error => Throw (Error, No_Permission_E, System_Exception_Members' (Minor => 0, Completed => Completed_No)); end Bind_Mechanism; ------------ -- Create -- ------------ procedure Create (TC : Tagged_Components.Tagged_Component_Access; Profile : Binding_Data.Profile_Access; Mechs : in out Transport_Mechanism_List) is pragma Unreferenced (Profile); Mechanism : constant Transport_Mechanism_Access := new TLS_Transport_Mechanism; begin -- XXX Setup Target_Supports and Target_Requires TLS_Transport_Mechanism (Mechanism.all).Addresses := Duplicate (TC_TLS_Sec_Trans (TC.all).Addresses); Append (Mechs, Mechanism); end Create; -- -------------------- -- -- Create_Factory -- -- -------------------- -- -- procedure Create_Factory -- (MF : out TLS_Transport_Mechanism_Factory; -- TAP : Transport.Transport_Access_Point_Access) -- is -- pragma Unreferenced (MF); -- pragma Unreferenced (TAP); -- -- begin -- null; -- -- MF.Address := Address_Of (SSL_Access_Point (TAP.all)); -- -- -- Detect supported and required security assocations by -- -- review of descriptions of available ciphers (conformant -- -- with CORBA 3.0 paragraph 24.5.1.3 TAG_TLS_SEC_TRANS) -- -- -- -- The following algorithm are used: -- -- -- -- Integrity: -- -- Supported - one of ciphers have not None Mac parameter -- -- Required - all of ciphers have not None Mac parameter -- -- -- -- Confidentiality: -- -- Supported - one of chipers have not None Enc parameter -- -- Required - all of ciphers have not None Enc parameter -- -- -- -- Establish_Trust_In_Target: -- -- Supported - one of ciphers have not None Au parameter -- -- Required - always false -- -- -- -- Establish_Trust_In_Client: -- -- Supported - verify mode is SSL_VERIFY_PEER but not -- -- SSL_VERIFY_FAIL_IF_NO_PEER_CERT -- -- Required - both SSL_VERIFY_PEER and -- -- SSL_VERIFY_FAIL_IF_NO_PEER_CERT are enabled -- declare -- -- function Is_None -- (Description : String; -- Parameter : String) -- return Boolean; -- -- Check is a Parameter have None value or not present -- -- in Description -- -- ------------- -- -- Is_None -- -- ------------- -- -- function Is_None -- (Description : String; -- Parameter : String) -- return Boolean -- is -- None : constant String := "None"; -- Pos : constant Natural -- := Ada.Strings.Fixed.Index (Description, Parameter & '=') -- + Parameter'Length + 1; -- -- begin -- -- Check if a parameter is present in description -- -- if Pos <= Parameter'Length then -- return False; -- end if; -- -- -- Check the length of parameter value less whan None -- -- if Description'Last < Pos + None'Length then -- return True; -- end if; -- -- return Description (Pos .. Pos + None'Length - 1) = None; -- end Is_None; -- -- List : constant SSL_Cipher_Array -- := Ciphers_Of (Get_SSL_Context (SSL_Access_Point (TAP.all))); -- Mode : constant SSL_Verification_Mode -- := Verification_Mode_Of -- (Get_SSL_Context (SSL_Access_Point (TAP.all))); -- -- Integrity_Supported : Boolean := False; -- Integrity_Required : Boolean := True; -- Confidentiality_Supported : Boolean := False; -- Confidentiality_Required : Boolean := True; -- Establish_Trust_In_Target_Supported : Boolean := False; -- Establish_Trust_In_Client_Supported : Boolean := False; -- Establish_Trust_In_Client_Required : Boolean := False; -- -- begin -- for J in List'Range loop -- declare -- Desc : constant String := Description_Of (List (J)); -- -- begin -- -- Compute Integrity option -- -- if Is_None (Desc, "Mac") then -- Integrity_Required := False; -- else -- Integrity_Supported := True; -- end if; -- -- -- Compute Confidentiality option -- -- if Is_None (Desc, "Enc") then -- Confidentiality_Required := False; -- else -- Confidentiality_Supported := True; -- end if; -- -- -- Compute Establish_Trust_In_Target option -- -- if not Is_None (Desc, "Au") then -- Establish_Trust_In_Target_Supported := True; -- end if; -- -- end; -- end loop; -- -- if Mode (Peer) then -- Establish_Trust_In_Client_Supported := True; -- -- if Mode (Fail_If_No_Peer_Certificate) then -- Establish_Trust_In_Client_Required := True; -- end if; -- end if; -- -- -- Setting consolidated Target Supports accosiation options -- -- MF.Target_Supports := 0; -- -- if Integrity_Supported then -- MF.Target_Supports := MF.Target_Supports + Integrity; -- end if; -- -- if Confidentiality_Supported then -- MF.Target_Supports := MF.Target_Supports + Confidentiality; -- end if; -- -- if Establish_Trust_In_Target_Supported then -- MF.Target_Supports := -- MF.Target_Supports + Establish_Trust_In_Target; -- end if; -- -- if Establish_Trust_In_Client_Supported then -- MF.Target_Supports := -- MF.Target_Supports + Establish_Trust_In_Client; -- end if; -- -- -- Setting consolidated Target Requires accosiation options -- -- MF.Target_Requires := 0; -- -- if Integrity_Required then -- MF.Target_Requires := MF.Target_Requires + Integrity; -- end if; -- -- if Confidentiality_Required then -- MF.Target_Requires := MF.Target_Requires + Confidentiality; -- end if; -- -- if Establish_Trust_In_Client_Required then -- MF.Target_Requires := -- MF.Target_Requires + Establish_Trust_In_Client; -- end if; -- end; -- end Create_Factory; ---------------- -- Create_QoS -- ---------------- function Create_QoS (End_Point : PolyORB.Transport.Transport_Endpoint_Access) return PolyORB.QoS.QoS_Parameter_Access is begin if End_Point.all in TLS_Endpoint then return Create_QoS (TLS_Endpoint (End_Point.all)); else return null; end if; end Create_QoS; -- ------------------------------ -- -- Create_Tagged_Components -- -- ------------------------------ -- -- function Create_Tagged_Components -- (MF : TLS_Transport_Mechanism_Factory) -- return Tagged_Components.Tagged_Component_List -- is -- Result : Tagged_Component_List; -- -- TC : constant Tagged_Component_Access := new TC_TLS_Sec_Trans; -- -- begin -- -- TC_TLS_Sec_Trans (TC.all).Target_Supports := MF.Target_Supports; -- -- TC_TLS_Sec_Trans (TC.all).Target_Requires := MF.Target_Requires; -- TC_TLS_Sec_Trans (TC.all).Addresses := Duplicate (MF.Addresses); -- -- Add (Result, TC); -- -- return Result; -- end Create_Tagged_Components; --------------- -- Duplicate -- --------------- function Duplicate (TMA : TLS_Transport_Mechanism) return TLS_Transport_Mechanism is Result : TLS_Transport_Mechanism; begin Result.Addresses := Duplicate (TMA.Addresses); return Result; end Duplicate; ----------------------------- -- Extract_TLS_Credentials -- ----------------------------- function Extract_TLS_Credentials (Credentials : Credentials_Ref) return TLS_Credentials_Access is Creds : Credentials_Access := Credentials_Access (Entity_Of (Credentials)); begin if Creds /= null then Creds := Credentials_Access (Entity_Of (Get_Transport_Credentials (Compound_Credentials_Access (Creds)))); if Creds /= null and then Creds.all in TLS_Credentials'Class then return TLS_Credentials_Access (Creds); end if; end if; return null; end Extract_TLS_Credentials; ---------------- -- Initialize -- ---------------- procedure Initialize is begin Register (Tag_TLS_Sec_Trans, Create'Access); PolyORB.GIOP_P.Tagged_Components.CSI_Sec_Mech_List.Register (Create_QoS'Access); end Initialize; ------------------ -- Is_Colocated -- ------------------ function Is_Colocated (Left : TLS_Transport_Mechanism; Right : Transport_Mechanism'Class) return Boolean is begin if Right not in TLS_Transport_Mechanism then return False; end if; declare use type Utils.Sockets.Socket_Name; L_Iter : Iterator := First (Left.Addresses); R_Iter : Iterator := First (TLS_Transport_Mechanism (Right).Addresses); begin -- Check if Left.Addresses and Right.Addresses have an address in -- common. Left_Addresses : while not Last (L_Iter) loop Right_Addresses : while not Last (R_Iter) loop if Value (L_Iter).all.all = Value (R_Iter).all.all then return True; end if; Next (R_Iter); end loop Right_Addresses; Next (L_Iter); end loop Left_Addresses; end; return False; end Is_Colocated; ------------------- -- Is_Equivalent -- ------------------- function Is_Equivalent (Left : TLS_Transport_Mechanism; Right : Transport_Mechanism'Class) return Boolean is use type Utils.Sockets.Socket_Name; begin if Right not in TLS_Transport_Mechanism then return False; end if; declare L_Iter : Iterator := First (Left.Addresses); R_Iter : Iterator := First (TLS_Transport_Mechanism (Right).Addresses); begin if Length (Left.Addresses) /= Length (TLS_Transport_Mechanism (Right).Addresses) then return False; end if; while not Last (L_Iter) loop if Value (L_Iter).all.all /= Value (R_Iter).all.all then return False; end if; Next (L_Iter); Next (R_Iter); end loop; return True; end; end Is_Equivalent; -- ------------------------ -- -- Is_Local_Mechanism -- -- ------------------------ -- -- function Is_Local_Mechanism -- (MF : access TLS_Transport_Mechanism_Factory; -- M : access Transport_Mechanism'Class) -- return Boolean -- is -- use type PolyORB.Sockets.Sock_Addr_Type; -- -- Iter_1 : Iterator; -- -- begin -- if M.all not in TLS_Transport_Mechanism then -- return False; -- end if; -- -- Iter_1 := First (TLS_Transport_Mechanism (M.all).Addresses); -- -- while not Last (Iter_1) loop -- declare -- Iter_2 : Iterator := First (MF.Addresses); -- -- begin -- while not Last (Iter_2) loop -- if Value (Iter_1).all = Value (Iter_2).all then -- return True; -- end if; -- -- Next (Iter_2); -- end loop; -- end; -- -- Next (Iter_1); -- end loop; -- -- return False; -- end Is_Local_Mechanism; ---------------------- -- Release_Contents -- ---------------------- procedure Release_Contents (M : access TLS_Transport_Mechanism) is begin Deallocate (M.Addresses); end Release_Contents; begin declare use PolyORB.Initialization; use PolyORB.Initialization.String_Lists; use PolyORB.Utils.Strings; begin Register_Module (Module_Info' (Name => +"giop_p.transport_mechanisms.tls", Conflicts => PolyORB.Initialization.String_Lists.Empty, Depends => +"tls", Provides => PolyORB.Initialization.String_Lists.Empty, Implicit => False, Init => Initialize'Access, Shutdown => null)); end; end PolyORB.GIOP_P.Transport_Mechanisms.TLS; polyorb-2.8~20110207.orig/src/giop/iiop/security/tls/polyorb-setup-access_points-tlsiop.ads0000644000175000017500000000417111750740340031223 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . S E T U P . A C C E S S _ P O I N T S . T L S I O P -- -- -- -- S p e c -- -- -- -- Copyright (C) 2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ package PolyORB.Setup.Access_Points.TLSIOP is pragma Elaborate_Body; end PolyORB.Setup.Access_Points.TLSIOP; polyorb-2.8~20110207.orig/src/giop/iiop/security/tls/polyorb-giop_p-transport_mechanisms-tls.ads0000644000175000017500000001034611750740340032237 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- POLYORB.GIOP_P.TRANSPORT_MECHANISMS.TLS -- -- -- -- S p e c -- -- -- -- Copyright (C) 2005-2008, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with PolyORB.GIOP_P.Tagged_Components.TLS_Sec_Trans; -- with PolyORB.Sockets; package PolyORB.GIOP_P.Transport_Mechanisms.TLS is -- type TLS_Transport_Mechanism is new Transport_Mechanism with private; type TLS_Transport_Mechanism is new Transport_Mechanism with record -- Target_Supports : Tagged_Components.SSL_Sec_Trans.Association_Options; -- Target_Requires : Tagged_Components.SSL_Sec_Trans.Association_Options; Addresses : Tagged_Components.TLS_Sec_Trans.Socket_Name_Lists.List; end record; procedure Bind_Mechanism (Mechanism : TLS_Transport_Mechanism; Profile : access PolyORB.Binding_Data.Profile_Type'Class; The_ORB : Components.Component_Access; QoS : PolyORB.QoS.QoS_Parameters; BO_Ref : out Smart_Pointers.Ref; Error : out Errors.Error_Container); procedure Release_Contents (M : access TLS_Transport_Mechanism); function Duplicate (TMA : TLS_Transport_Mechanism) return TLS_Transport_Mechanism; function Is_Equivalent (Left : TLS_Transport_Mechanism; Right : Transport_Mechanism'Class) return Boolean; function Is_Colocated (Left : TLS_Transport_Mechanism; Right : Transport_Mechanism'Class) return Boolean; -- type TLS_Transport_Mechanism_Factory is -- new Transport_Mechanism_Factory with private; -- -- procedure Create_Factory -- (MF : out TLS_Transport_Mechanism_Factory; -- TAP : Transport.Transport_Access_Point_Access); -- -- function Is_Local_Mechanism -- (MF : access TLS_Transport_Mechanism_Factory; -- M : access Transport_Mechanism'Class) -- return Boolean; -- -- function Create_Tagged_Components -- (MF : TLS_Transport_Mechanism_Factory) -- return Tagged_Components.Tagged_Component_List; private -- type TLS_Transport_Mechanism_Factory is -- new Transport_Mechanism_Factory with -- record -- Target_Supports : Tagged_Components.SSL_Sec_Trans.Association_Options; -- Target_Requires : Tagged_Components.SSL_Sec_Trans.Association_Options; -- Address : Sockets.Sock_Addr_Type; -- Addresses : Tagged_Components.TLS_Sec_Trans.Sock_Addr_Lists.List; -- end record; end PolyORB.GIOP_P.Transport_Mechanisms.TLS; polyorb-2.8~20110207.orig/src/giop/iiop/security/tls/polyorb-setup-tlsiop.ads0000644000175000017500000000413511750740340026370 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . S E T U P . T L S I O P -- -- -- -- S p e c -- -- -- -- Copyright (C) 2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ package PolyORB.Setup.TLSIOP is pragma Elaborate_Body; end PolyORB.Setup.TLSIOP; ././@LongLink0000000000000000000000000000015000000000000011561 Lustar rootrootpolyorb-2.8~20110207.orig/src/giop/iiop/security/tls/polyorb-giop_p-tagged_components-tls_sec_trans.adspolyorb-2.8~20110207.orig/src/giop/iiop/security/tls/polyorb-giop_p-tagged_components-tls_sec_trans.0000644000175000017500000000614711750740340033051 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- POLYORB.GIOP_P.TAGGED_COMPONENTS.TLS_SEC_TRANS -- -- -- -- S p e c -- -- -- -- Copyright (C) 2005-2008, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- Used only as transport_mech in TAG_CSI_SEC_MECH_LIST tagged component with PolyORB.Security.Types; with PolyORB.Utils.Sockets; package PolyORB.GIOP_P.Tagged_Components.TLS_Sec_Trans is use PolyORB.Utils.Sockets; package Socket_Name_Lists is new PolyORB.Utils.Chained_Lists (Utils.Sockets.Socket_Name_Ptr); type TC_TLS_Sec_Trans is new Tagged_Component (Tag => Tag_TLS_Sec_Trans, At_Most_Once => False) with record Target_Supports : PolyORB.Security.Types.Association_Options; Target_Requires : PolyORB.Security.Types.Association_Options; Addresses : Socket_Name_Lists.List; end record; procedure Marshall_Component_Data (C : access TC_TLS_Sec_Trans; Buffer : access Buffer_Type); procedure Unmarshall_Component_Data (C : access TC_TLS_Sec_Trans; Buffer : access Buffer_Type; Error : out PolyORB.Errors.Error_Container); procedure Release_Contents (C : access TC_TLS_Sec_Trans); function Duplicate (C : TC_TLS_Sec_Trans) return Tagged_Component_Access; end PolyORB.GIOP_P.Tagged_Components.TLS_Sec_Trans; polyorb-2.8~20110207.orig/src/giop/iiop/security/tls/polyorb-setup-tlsiop.adb0000644000175000017500000000604511750740340026351 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . S E T U P . T L S I O P -- -- -- -- B o d y -- -- -- -- Copyright (C) 2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with PolyORB.Initialization; with PolyORB.Utils.Strings; with PolyORB.GIOP_P.Tagged_Components.TLS_Sec_Trans; pragma Warnings (Off, PolyORB.GIOP_P.Tagged_Components.TLS_Sec_Trans); with PolyORB.GIOP_P.Transport_Mechanisms.TLS; pragma Warnings (Off, PolyORB.GIOP_P.Transport_Mechanisms.TLS); package body PolyORB.Setup.TLSIOP is procedure Initialize; procedure Initialize is begin null; end Initialize; begin declare use PolyORB.Initialization; use PolyORB.Initialization.String_Lists; use PolyORB.Utils.Strings; begin Register_Module (Module_Info' (Name => +"polyorb.setup.tlsiop", Conflicts => PolyORB.Initialization.String_Lists.Empty, Depends => +"tagged_components.tls_sec_trans?" & "giop_p.transport_mechanisms.tls", Provides => PolyORB.Initialization.String_Lists.Empty, Implicit => False, Init => Initialize'Access, Shutdown => null)); end; end PolyORB.Setup.TLSIOP; polyorb-2.8~20110207.orig/src/giop/iiop/polyorb-protocols-giop-iiop.ads0000644000175000017500000000452511750740340025170 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . P R O T O C O L S . G I O P . I I O P -- -- -- -- S p e c -- -- -- -- Copyright (C) 2002-2003 Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by ACT Europe. -- -- (email: sales@act-europe.fr) -- -- -- ------------------------------------------------------------------------------ package PolyORB.Protocols.GIOP.IIOP is type IIOP_Protocol is new GIOP_Protocol with private; procedure Create (Proto : access IIOP_Protocol; Session : out Filter_Access); private type IIOP_Protocol is new GIOP_Protocol with null record; IIOP_Conf : aliased GIOP_Conf; end PolyORB.Protocols.GIOP.IIOP; polyorb-2.8~20110207.orig/src/giop/iiop/ssliop/0000755000175000017500000000000011750740340020400 5ustar xavierxavierpolyorb-2.8~20110207.orig/src/giop/iiop/ssliop/polyorb-giop_p-transport_mechanisms-ssliop.adb0000644000175000017500000003537611750740340031577 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- POLYORB.GIOP_P.TRANSPORT_MECHANISMS.SSLIOP -- -- -- -- B o d y -- -- -- -- Copyright (C) 2005-2009, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with Ada.Strings.Fixed; with PolyORB.Binding_Data.GIOP.IIOP; with PolyORB.Binding_Objects; with PolyORB.Filters.Slicers; with PolyORB.GIOP_P.Transport_Mechanisms.IIOP; with PolyORB.Initialization; with PolyORB.ORB; with PolyORB.Parameters; with PolyORB.Protocols.GIOP.IIOP; with PolyORB.Sockets; with PolyORB.SSL; with PolyORB.Transport.Connected.Sockets.SSL; with PolyORB.Utils.Strings; package body PolyORB.GIOP_P.Transport_Mechanisms.SSLIOP is use PolyORB.Binding_Data.GIOP.IIOP; use PolyORB.Components; use PolyORB.Errors; use PolyORB.GIOP_P.Tagged_Components; use PolyORB.GIOP_P.Tagged_Components.SSL_Sec_Trans; use PolyORB.GIOP_P.Transport_Mechanisms.IIOP; use PolyORB.Parameters; use PolyORB.Sockets; use PolyORB.SSL; use PolyORB.Transport.Connected.Sockets.SSL; use PolyORB.Utils.Sockets; procedure Initialize; procedure Create (TC : Tagged_Components.Tagged_Component_Access; Profile : Binding_Data.Profile_Access; Mechs : in out Transport_Mechanism_List); -- Create list of Transport Mechanism from list of Tagged Component Binding_Context : SSL_Context_Type; -- Factories Sli : aliased PolyORB.Filters.Slicers.Slicer_Factory; Pro : aliased PolyORB.Protocols.GIOP.IIOP.IIOP_Protocol; IIOP_Factories : constant PolyORB.Filters.Factory_Array := (0 => Sli'Access, 1 => Pro'Access); -------------------- -- Bind_Mechanism -- -------------------- procedure Bind_Mechanism (Mechanism : SSLIOP_Transport_Mechanism; Profile : access PolyORB.Binding_Data.Profile_Type'Class; The_ORB : Components.Component_Access; QoS : PolyORB.QoS.QoS_Parameters; BO_Ref : out Smart_Pointers.Ref; Error : out Errors.Error_Container) is pragma Unreferenced (QoS); use PolyORB.Binding_Data; Sock : Socket_Type; SSL_Sock : SSL_Socket_Type; TE : constant PolyORB.Transport.Transport_Endpoint_Access := new SSL_Endpoint; begin if Profile.all not in PolyORB.Binding_Data.GIOP.IIOP.IIOP_Profile_Type then Throw (Error, Comm_Failure_E, System_Exception_Members' (Minor => 0, Completed => Completed_Maybe)); return; end if; Create_Socket (Sock); Connect_Socket (Sock, Binding_Context, SSL_Sock, Mechanism.Address.all); Create (SSL_Endpoint (TE.all), SSL_Sock); Binding_Objects.Setup_Binding_Object (The_ORB, TE, IIOP_Factories, BO_Ref, Profile_Access (Profile)); ORB.Register_Binding_Object (ORB.ORB_Access (The_ORB), BO_Ref, ORB.Client); exception when Sockets.Socket_Error => Throw (Error, Comm_Failure_E, System_Exception_Members' (Minor => 0, Completed => Completed_No)); when SSL.SSL_Error => Throw (Error, No_Permission_E, System_Exception_Members' (Minor => 0, Completed => Completed_No)); end Bind_Mechanism; ------------ -- Create -- ------------ procedure Create (TC : Tagged_Components.Tagged_Component_Access; Profile : Binding_Data.Profile_Access; Mechs : in out Transport_Mechanism_List) is Mechanism : constant Transport_Mechanism_Access := new SSLIOP_Transport_Mechanism; begin SSLIOP_Transport_Mechanism (Mechanism.all).Address := new Socket_Name'(Primary_Address_Of (IIOP_Transport_Mechanism (Get_Primary_Transport_Mechanism (IIOP_Profile_Type (Profile.all)).all))); SSLIOP_Transport_Mechanism (Mechanism.all).Address.Port := TC_SSL_Sec_Trans (TC.all).Port; Append (Mechs, Mechanism); end Create; -------------------- -- Create_Factory -- -------------------- procedure Create_Factory (MF : out SSLIOP_Transport_Mechanism_Factory; TAP : Transport.Transport_Access_Point_Access) is begin MF.Address := new Socket_Name'(Address_Of (SSL_Access_Point (TAP.all))); -- Detect supported and required security assocations by -- review of descriptions of available ciphers (conformant -- with CORBA 3.0 paragraph 24.5.1.3 TAG_TLS_SEC_TRANS) -- -- The following algorithm are used: -- -- Integrity: -- Supported - one of ciphers have not None Mac parameter -- Required - all of ciphers have not None Mac parameter -- -- Confidentiality: -- Supported - one of chipers have not None Enc parameter -- Required - all of ciphers have not None Enc parameter -- -- Establish_Trust_In_Target: -- Supported - one of ciphers have not None Au parameter -- Required - always false -- -- Establish_Trust_In_Client: -- Supported - verify mode is SSL_VERIFY_PEER but not -- SSL_VERIFY_FAIL_IF_NO_PEER_CERT -- Required - both SSL_VERIFY_PEER and -- SSL_VERIFY_FAIL_IF_NO_PEER_CERT are enabled declare function Is_None (Description : String; Parameter : String) return Boolean; -- Check is a Parameter have None value or not present -- in Description ------------- -- Is_None -- ------------- function Is_None (Description : String; Parameter : String) return Boolean is None : constant String := "None"; Pos : constant Natural := Ada.Strings.Fixed.Index (Description, Parameter & '=') + Parameter'Length + 1; begin -- Check if a parameter is present in description if Pos <= Parameter'Length then return False; end if; -- Check the length of parameter value less whan None if Description'Last < Pos + None'Length then return True; end if; return Description (Pos .. Pos + None'Length - 1) = None; end Is_None; List : constant SSL_Cipher_Array := Ciphers_Of (Get_SSL_Context (SSL_Access_Point (TAP.all))); Mode : constant SSL_Verification_Mode := Verification_Mode_Of (Get_SSL_Context (SSL_Access_Point (TAP.all))); Integrity_Supported : Boolean := False; Integrity_Required : Boolean := True; Confidentiality_Supported : Boolean := False; Confidentiality_Required : Boolean := True; Establish_Trust_In_Target_Supported : Boolean := False; Establish_Trust_In_Client_Supported : Boolean := False; Establish_Trust_In_Client_Required : Boolean := False; begin for J in List'Range loop declare Desc : constant String := Description_Of (List (J)); begin -- Compute Integrity option if Is_None (Desc, "Mac") then Integrity_Required := False; else Integrity_Supported := True; end if; -- Compute Confidentiality option if Is_None (Desc, "Enc") then Confidentiality_Required := False; else Confidentiality_Supported := True; end if; -- Compute Establish_Trust_In_Target option if not Is_None (Desc, "Au") then Establish_Trust_In_Target_Supported := True; end if; end; end loop; if Mode (Peer) then Establish_Trust_In_Client_Supported := True; if Mode (Fail_If_No_Peer_Certificate) then Establish_Trust_In_Client_Required := True; end if; end if; -- Setting consolidated Target Supports accosiation options MF.Target_Supports := 0; if Integrity_Supported then MF.Target_Supports := MF.Target_Supports + Integrity; end if; if Confidentiality_Supported then MF.Target_Supports := MF.Target_Supports + Confidentiality; end if; if Establish_Trust_In_Target_Supported then MF.Target_Supports := MF.Target_Supports + Establish_Trust_In_Target; end if; if Establish_Trust_In_Client_Supported then MF.Target_Supports := MF.Target_Supports + Establish_Trust_In_Client; end if; -- Setting consolidated Target Requires accosiation options MF.Target_Requires := 0; if Integrity_Required then MF.Target_Requires := MF.Target_Requires + Integrity; end if; if Confidentiality_Required then MF.Target_Requires := MF.Target_Requires + Confidentiality; end if; if Establish_Trust_In_Client_Required then MF.Target_Requires := MF.Target_Requires + Establish_Trust_In_Client; end if; end; end Create_Factory; ------------------------------ -- Create_Tagged_Components -- ------------------------------ function Create_Tagged_Components (MF : SSLIOP_Transport_Mechanism_Factory) return Tagged_Components.Tagged_Component_List is Result : Tagged_Component_List; TC : constant Tagged_Component_Access := new TC_SSL_Sec_Trans; begin TC_SSL_Sec_Trans (TC.all).Port := MF.Address.Port; TC_SSL_Sec_Trans (TC.all).Target_Supports := MF.Target_Supports; TC_SSL_Sec_Trans (TC.all).Target_Requires := MF.Target_Requires; Add (Result, TC); return Result; end Create_Tagged_Components; --------------- -- Duplicate -- --------------- function Duplicate (TMA : SSLIOP_Transport_Mechanism) return SSLIOP_Transport_Mechanism is begin return SSLIOP_Transport_Mechanism' (Address => new Socket_Name'(TMA.Address.all), Target_Supports => TMA.Target_Supports, Target_Requires => TMA.Target_Requires); end Duplicate; ---------------- -- Initialize -- ---------------- procedure Initialize is begin if Get_Conf ("modules", "binding_data.iiop.ssliop", False) then Create_Context (Binding_Context, Any, Get_Conf ("ssliop", "polyorb.protocols.ssliop.privatekeyfile", ""), Get_Conf ("ssliop", "polyorb.protocols.ssliop.certificatefile", ""), Get_Conf ("ssliop", "polyorb.protocols.ssliop.cafile", ""), Get_Conf ("ssliop", "polyorb.protocols.ssliop.capath", ""), (Get_Conf ("ssliop", "polyorb.protocols.ssliop.verify", False), Get_Conf ("ssliop", "polyorb.protocols.ssliop.verify_fail_if_no_peer_cert", False), Get_Conf ("ssliop", "polyorb.protocols.ssliop.verify_client_once", False))); Register (Tag_SSL_Sec_Trans, Create'Access); end if; end Initialize; ------------------ -- Is_Colocated -- ------------------ function Is_Colocated (Left : SSLIOP_Transport_Mechanism; Right : Transport_Mechanism'Class) return Boolean is begin return Right in SSLIOP_Transport_Mechanism and then Left.Address = SSLIOP_Transport_Mechanism (Right).Address; end Is_Colocated; ------------------------ -- Is_Local_Mechanism -- ------------------------ function Is_Local_Mechanism (MF : access SSLIOP_Transport_Mechanism_Factory; M : access Transport_Mechanism'Class) return Boolean is begin return M.all in SSLIOP_Transport_Mechanism and then SSLIOP_Transport_Mechanism (M.all).Address = MF.Address; end Is_Local_Mechanism; ---------------------- -- Release_Contents -- ---------------------- procedure Release_Contents (M : access SSLIOP_Transport_Mechanism) is begin Free (M.Address); end Release_Contents; begin declare use PolyORB.Initialization; use PolyORB.Initialization.String_Lists; use PolyORB.Utils.Strings; begin Register_Module (Module_Info' (Name => +"giop_p.transport_mechanisms.ssliop", Conflicts => PolyORB.Initialization.String_Lists.Empty, Depends => +"ssl", Provides => PolyORB.Initialization.String_Lists.Empty, Implicit => False, Init => Initialize'Access, Shutdown => null)); end; end PolyORB.GIOP_P.Transport_Mechanisms.SSLIOP; polyorb-2.8~20110207.orig/src/giop/iiop/ssliop/polyorb-setup-ssliop.ads0000644000175000017500000000413511750740340025227 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . S E T U P . S S L I O P -- -- -- -- S p e c -- -- -- -- Copyright (C) 2005 Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ package PolyORB.Setup.SSLIOP is pragma Elaborate_Body; end PolyORB.Setup.SSLIOP; polyorb-2.8~20110207.orig/src/giop/iiop/ssliop/polyorb-setup-ssliop.adb0000644000175000017500000000427411750740340025212 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . S E T U P . S S L I O P -- -- -- -- B o d y -- -- -- -- Copyright (C) 2005 Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with PolyORB.GIOP_P.Transport_Mechanisms.SSLIOP; pragma Warnings (Off, PolyORB.GIOP_P.Transport_Mechanisms.SSLIOP); package body PolyORB.Setup.SSLIOP is end PolyORB.Setup.SSLIOP; polyorb-2.8~20110207.orig/src/giop/iiop/ssliop/polyorb-setup-access_points-ssliop.ads0000644000175000017500000000424111750740340030060 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . S E T U P . A C C E S S _ P O I N T S . S S L I O P -- -- -- -- S p e c -- -- -- -- Copyright (C) 2005 Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- Set up additional SSL access point package PolyORB.Setup.Access_Points.SSLIOP is pragma Elaborate_Body; end PolyORB.Setup.Access_Points.SSLIOP; polyorb-2.8~20110207.orig/src/giop/iiop/ssliop/polyorb-giop_p-transport_mechanisms-ssliop.ads0000644000175000017500000001000411750740340031575 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- POLYORB.GIOP_P.TRANSPORT_MECHANISMS.SSLIOP -- -- -- -- S p e c -- -- -- -- Copyright (C) 2005-2008, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with PolyORB.GIOP_P.Tagged_Components.SSL_Sec_Trans; with PolyORB.Utils.Sockets; package PolyORB.GIOP_P.Transport_Mechanisms.SSLIOP is type SSLIOP_Transport_Mechanism is new Transport_Mechanism with private; procedure Bind_Mechanism (Mechanism : SSLIOP_Transport_Mechanism; Profile : access PolyORB.Binding_Data.Profile_Type'Class; The_ORB : Components.Component_Access; QoS : PolyORB.QoS.QoS_Parameters; BO_Ref : out Smart_Pointers.Ref; Error : out Errors.Error_Container); procedure Release_Contents (M : access SSLIOP_Transport_Mechanism); type SSLIOP_Transport_Mechanism_Factory is new Transport_Mechanism_Factory with private; procedure Create_Factory (MF : out SSLIOP_Transport_Mechanism_Factory; TAP : Transport.Transport_Access_Point_Access); function Is_Local_Mechanism (MF : access SSLIOP_Transport_Mechanism_Factory; M : access Transport_Mechanism'Class) return Boolean; function Create_Tagged_Components (MF : SSLIOP_Transport_Mechanism_Factory) return Tagged_Components.Tagged_Component_List; function Duplicate (TMA : SSLIOP_Transport_Mechanism) return SSLIOP_Transport_Mechanism; function Is_Colocated (Left : SSLIOP_Transport_Mechanism; Right : Transport_Mechanism'Class) return Boolean; private type SSLIOP_Transport_Mechanism is new Transport_Mechanism with record Target_Supports : Tagged_Components.SSL_Sec_Trans.Association_Options; Target_Requires : Tagged_Components.SSL_Sec_Trans.Association_Options; Address : Utils.Sockets.Socket_Name_Ptr; end record; type SSLIOP_Transport_Mechanism_Factory is new Transport_Mechanism_Factory with record Target_Supports : Tagged_Components.SSL_Sec_Trans.Association_Options; Target_Requires : Tagged_Components.SSL_Sec_Trans.Association_Options; Address : Utils.Sockets.Socket_Name_Ptr; end record; end PolyORB.GIOP_P.Transport_Mechanisms.SSLIOP; polyorb-2.8~20110207.orig/src/giop/iiop/ssliop/polyorb-setup-access_points-ssliop.adb0000644000175000017500000001665511750740340030053 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . S E T U P . A C C E S S _ P O I N T S . S S L I O P -- -- -- -- B o d y -- -- -- -- Copyright (C) 2005-2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with PolyORB.Binding_Data.GIOP.IIOP; with PolyORB.Filters.Slicers; with PolyORB.GIOP_P.Transport_Mechanisms.SSLIOP; with PolyORB.Initialization; with PolyORB.Parameters; with PolyORB.Protocols.GIOP.IIOP; with PolyORB.Setup.Access_Points.IIOP; with PolyORB.Sockets; with PolyORB.SSL; with PolyORB.Transport.Connected.Sockets.SSL; with PolyORB.Utils.Socket_Access_Points; with PolyORB.Utils.SSL_Access_Points; with PolyORB.Utils.Strings; package body PolyORB.Setup.Access_Points.SSLIOP is use PolyORB.Binding_Data.GIOP.IIOP; use PolyORB.Filters.Slicers; use PolyORB.GIOP_P.Transport_Mechanisms; use PolyORB.GIOP_P.Transport_Mechanisms.SSLIOP; use PolyORB.ORB; use PolyORB.Setup.Access_Points.IIOP; use PolyORB.Sockets; use PolyORB.SSL; use PolyORB.Transport.Connected.Sockets.SSL; use PolyORB.Utils.Socket_Access_Points; use PolyORB.Utils.SSL_Access_Points; -- The SSLIOP access point SSLIOP_Access_Point : Access_Point_Info := (Socket => No_Socket, Address => No_Sock_Addr, SAP => new SSL_Access_Point, PF => null); Sli : aliased Slicer_Factory; Pro : aliased PolyORB.Protocols.GIOP.IIOP.IIOP_Protocol; SSLIOP_Factories : aliased Filters.Factory_Array := (0 => Sli'Access, 1 => Pro'Access); ------------------------------ -- Initialize_Access_Points -- ------------------------------ procedure Initialize_Access_Points; procedure Initialize_Access_Points is use PolyORB.Parameters; begin if Get_Conf ("access_points", "iiop", Default => True) and then Get_Conf ("access_points", "iiop.ssliop", Default => False) then declare Factory : constant Transport_Mechanism_Factory_Access := new SSLIOP_Transport_Mechanism_Factory; Port_Hint : constant Port_Interval := To_Port_Interval (Get_Conf ("ssliop", "polyorb.protocols.ssliop.default_port", (Integer (Any_Port), Integer (Any_Port)))); Addr : constant Inet_Addr_Type := Inet_Addr (String'(Get_Conf ("iiop", "polyorb.protocols.iiop.default_addr", Image (No_Inet_Addr)))); -- SSLIOP share its default address with IIOP CA_File : constant String := Get_Conf ("ssliop", "polyorb.protocols.ssliop.cafile", ""); Cont : SSL_Context_Type; Profile_Factory : PolyORB.Binding_Data.Profile_Factory_Access; begin Create_Context (Cont, Any, Get_Conf ("ssliop", "polyorb.protocols.ssliop.privatekeyfile", "privkey.pem"), Get_Conf ("ssliop", "polyorb.protocols.ssliop.certificatefile", "cacert.pem"), CA_File, Get_Conf ("ssliop", "polyorb.protocols.ssliop.capath", ""), (Get_Conf ("ssliop", "polyorb.protocols.ssliop.verify", False), Get_Conf ("ssliop", "polyorb.protocols.ssliop.verify_fail_if_no_peer_cert", False), Get_Conf ("ssliop", "polyorb.protocols.ssliop.verify_client_once", False))); if CA_File /= "" then Load_Client_CA (Cont, CA_File); end if; Initialize_Socket (SSLIOP_Access_Point, Addr, Port_Hint, Cont); -- Create TM factory Create_Factory (SSLIOP_Transport_Mechanism_Factory (Factory.all), SSLIOP_Access_Point.SAP); -- Retrieve primary IIOP profile factory Profile_Factory := Get_Profile_Factory; -- Add newly created TM factory to profile factory Add_Transport_Mechanism_Factory (IIOP_Profile_Factory (Profile_Factory.all), Factory); if Get_Conf ("ssliop", "polyorb.protocols.ssliop.disable_unprotected_invocations", False) then Disable_Unprotected_Invocations (IIOP_Profile_Factory (Profile_Factory.all)); else Profile_Factory := null; end if; Register_Access_Point (ORB => The_ORB, TAP => SSLIOP_Access_Point.SAP, Chain => SSLIOP_Factories'Access, PF => Profile_Factory); end; end if; end Initialize_Access_Points; begin declare use PolyORB.Initialization; use PolyORB.Initialization.String_Lists; use PolyORB.Utils.Strings; begin Register_Module (Module_Info' (Name => +"access_points.iiop.ssliop", Conflicts => Empty, Depends => +"ssl" & "orb" & "protocols.giop.iiop" & "access_points.iiop", Provides => +"access_points", Implicit => False, Init => Initialize_Access_Points'Access, Shutdown => null)); end; end PolyORB.Setup.Access_Points.SSLIOP; polyorb-2.8~20110207.orig/src/giop/iiop/polyorb-setup-iiop.adb0000644000175000017500000000572511750740340023332 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . S E T U P . I I O P -- -- -- -- B o d y -- -- -- -- Copyright (C) 2003-2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ pragma Warnings (Off); -- No entities from the following dependencies are referenced with PolyORB.Protocols.GIOP.GIOP_1_0; with PolyORB.Protocols.GIOP.GIOP_1_1; with PolyORB.Protocols.GIOP.GIOP_1_2; pragma Warnings (On); with PolyORB.Initialization; with PolyORB.Utils.Strings; package body PolyORB.Setup.IIOP is ---------------- -- Initialize -- ---------------- procedure Initialize; procedure Initialize is begin null; end Initialize; use PolyORB.Initialization; use PolyORB.Initialization.String_Lists; use PolyORB.Utils.Strings; begin Register_Module (Module_Info' (Name => +"setup.iiop", Conflicts => Empty, Depends => +"protocols.giop.giop_1_2" & "protocols.giop.giop_1_1" & "protocols.giop.giop_1_0", Provides => Empty, Implicit => False, Init => Initialize'Access, Shutdown => null)); end PolyORB.Setup.IIOP; polyorb-2.8~20110207.orig/src/giop/iiop/polyorb-setup-access_points-iiop.ads0000644000175000017500000000442011750740340026175 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . S E T U P . A C C E S S _ P O I N T S . I I O P -- -- -- -- S p e c -- -- -- -- Copyright (C) 2003-2005 Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- Set up CORBA TCP Access points. with PolyORB.Binding_Data; package PolyORB.Setup.Access_Points.IIOP is pragma Elaborate_Body; function Get_Profile_Factory return PolyORB.Binding_Data.Profile_Factory_Access; end PolyORB.Setup.Access_Points.IIOP; polyorb-2.8~20110207.orig/src/giop/iiop/polyorb-giop_p-transport_mechanisms-iiop.adb0000644000175000017500000003216511750740340027706 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- POLYORB.GIOP_P.TRANSPORT_MECHANISMS.IIOP -- -- -- -- B o d y -- -- -- -- Copyright (C) 2005-2009, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with PolyORB.Binding_Data.GIOP.IIOP; with PolyORB.Binding_Objects; with PolyORB.Filters.Slicers; with PolyORB.GIOP_P.Tagged_Components.Alternate_IIOP_Address; with PolyORB.Initialization; with PolyORB.ORB; with PolyORB.Protocols.GIOP.IIOP; with PolyORB.Sockets; with PolyORB.Transport.Connected.Sockets; with PolyORB.Utils.Strings; package body PolyORB.GIOP_P.Transport_Mechanisms.IIOP is use PolyORB.Components; use PolyORB.Errors; use PolyORB.GIOP_P.Tagged_Components; use PolyORB.GIOP_P.Tagged_Components.Alternate_IIOP_Address; use PolyORB.Sockets; use PolyORB.Transport.Connected.Sockets; use Socket_Name_Lists; procedure Initialize; procedure Create (TC : Tagged_Components.Tagged_Component_Access; Profile : Binding_Data.Profile_Access; Mechs : in out Transport_Mechanism_List); -- Create list of Transport Mechanism from list of Tagged Component -------------------- -- Bind_Mechanism -- -------------------- -- Factories Sli : aliased PolyORB.Filters.Slicers.Slicer_Factory; Pro : aliased PolyORB.Protocols.GIOP.IIOP.IIOP_Protocol; IIOP_Factories : constant PolyORB.Filters.Factory_Array := (0 => Sli'Access, 1 => Pro'Access); procedure Bind_Mechanism (Mechanism : IIOP_Transport_Mechanism; Profile : access PolyORB.Binding_Data.Profile_Type'Class; The_ORB : Components.Component_Access; QoS : PolyORB.QoS.QoS_Parameters; BO_Ref : out Smart_Pointers.Ref; Error : out Errors.Error_Container) is pragma Unreferenced (QoS); use PolyORB.Binding_Data; use PolyORB.Binding_Objects; Iter : Socket_Name_Lists.Iterator := First (Mechanism.Addresses); begin if Profile.all not in PolyORB.Binding_Data.GIOP.IIOP.IIOP_Profile_Type then Throw (Error, Comm_Failure_E, System_Exception_Members' (Minor => 0, Completed => Completed_Maybe)); return; end if; while not Last (Iter) loop declare Sock : Socket_Type; Remote_Addr : Socket_Name renames Value (Iter).all.all; TE : constant Transport.Transport_Endpoint_Access := new Socket_Endpoint; begin Create_Socket (Sock); Utils.Sockets.Connect_Socket (Sock, Remote_Addr); Create (Socket_Endpoint (TE.all), Sock); Binding_Objects.Setup_Binding_Object (The_ORB, TE, IIOP_Factories, BO_Ref, Profile_Access (Profile)); ORB.Register_Binding_Object (ORB.ORB_Access (The_ORB), BO_Ref, ORB.Client); return; exception when Sockets.Socket_Error => Throw (Error, Comm_Failure_E, System_Exception_Members' (Minor => 0, Completed => Completed_No)); end; Next (Iter); if not Last (Iter) and then Found (Error) then Catch (Error); end if; end loop; end Bind_Mechanism; ------------ -- Create -- ------------ procedure Create (TC : Tagged_Components.Tagged_Component_Access; Profile : Binding_Data.Profile_Access; Mechs : in out Transport_Mechanism_List) is pragma Unreferenced (Mechs); -- Behaviour is not conformant with spec, we add the additional address -- from TC directly into the primary transport mechanism, instead of -- creating a separate mechanism??? use PolyORB.Binding_Data.GIOP; Mechanism : constant Transport_Mechanism_Access := Get_Primary_Transport_Mechanism (GIOP_Profile_Type (Profile.all)); begin Append (IIOP_Transport_Mechanism (Mechanism.all).Addresses, new Socket_Name'(TC_Alternate_IIOP_Address (TC.all).Address.all)); end Create; -------------------- -- Create_Factory -- -------------------- procedure Create_Factory (MF : out IIOP_Transport_Mechanism_Factory; TAP : Transport.Transport_Access_Point_Access) is begin Append (MF.Addresses, new Socket_Name'(Address_Of (Socket_Access_Point (TAP.all)))); end Create_Factory; ------------------------------ -- Create_Tagged_Components -- ------------------------------ function Create_Tagged_Components (MF : IIOP_Transport_Mechanism_Factory) return Tagged_Components.Tagged_Component_List is Result : Tagged_Component_List; Iter : Iterator := First (MF.Addresses); begin -- If Transport Mechanism is disabled (e.g. unprotected invocation -- has been disabled), then don't create any tagged components for -- alternative addresses. if MF.Disabled then return Result; end if; Next (Iter); -- Skipping first address in the list because it is a primary address, -- declared in profile itself. while not Last (Iter) loop declare TC : constant Tagged_Component_Access := new TC_Alternate_IIOP_Address; begin TC_Alternate_IIOP_Address (TC.all).Address := new Socket_Name'(Value (Iter).all.all); Add (Result, TC); end; Next (Iter); end loop; return Result; end Create_Tagged_Components; -------------------------------- -- Create_Transport_Mechanism -- -------------------------------- function Create_Transport_Mechanism (MF : IIOP_Transport_Mechanism_Factory) return Transport_Mechanism_Access is Result : constant Transport_Mechanism_Access := new IIOP_Transport_Mechanism; TResult : IIOP_Transport_Mechanism renames IIOP_Transport_Mechanism (Result.all); Iter : Iterator := First (MF.Addresses); begin -- If Transport Mechanism is disabled (e.g. unprotected invocation -- has been disabled), add only primary address with zero port number -- and ignore all alternate addresses. Otherwise, add all addresses. while not Last (Iter) loop declare Addr : Socket_Name := Value (Iter).all.all; begin if MF.Disabled then Addr.Port := 0; end if; Append (TResult.Addresses, new Socket_Name'(Addr)); end; -- In the disabled case, we just set the first address exit when MF.Disabled; Next (Iter); end loop; return Result; end Create_Transport_Mechanism; function Create_Transport_Mechanism (Address : Utils.Sockets.Socket_Name) return Transport_Mechanism_Access is Result : constant Transport_Mechanism_Access := new IIOP_Transport_Mechanism; TResult : IIOP_Transport_Mechanism renames IIOP_Transport_Mechanism (Result.all); begin Append (TResult.Addresses, new Socket_Name'(Address)); return Result; end Create_Transport_Mechanism; --------------------------------- -- Disable_Transport_Mechanism -- --------------------------------- procedure Disable_Transport_Mechanism (MF : in out IIOP_Transport_Mechanism_Factory) is begin MF.Disabled := True; end Disable_Transport_Mechanism; ---------------- -- Initialize -- ---------------- procedure Initialize is begin Register (Tag_Alternate_IIOP_Address, Create'Access); end Initialize; ------------------------ -- Is_Local_Mechanism -- ------------------------ function Is_Local_Mechanism (MF : access IIOP_Transport_Mechanism_Factory; M : access Transport_Mechanism'Class) return Boolean is Iter_1 : Iterator; begin if MF.Disabled or else M.all not in IIOP_Transport_Mechanism then return False; end if; Iter_1 := First (IIOP_Transport_Mechanism (M.all).Addresses); if M.all in IIOP_Transport_Mechanism then while not Last (Iter_1) loop declare Iter_2 : Iterator := First (MF.Addresses); begin while not Last (Iter_2) loop if Value (Iter_1).all.all = Value (Iter_2).all.all then return True; end if; Next (Iter_2); end loop; end; Next (Iter_1); end loop; end if; return False; end Is_Local_Mechanism; ------------------------ -- Primary_Address_Of -- ------------------------ function Primary_Address_Of (M : IIOP_Transport_Mechanism) return Utils.Sockets.Socket_Name is begin return Element (M.Addresses, 0).all.all; end Primary_Address_Of; ---------------------- -- Release_Contents -- ---------------------- procedure Release_Contents (M : access IIOP_Transport_Mechanism) is Iter : Socket_Name_Lists.Iterator := First (M.Addresses); begin while not Last (Iter) loop Free (Value (Iter).all); Next (Iter); end loop; Deallocate (M.Addresses); end Release_Contents; --------------- -- Duplicate -- --------------- function Duplicate (TMA : IIOP_Transport_Mechanism) return IIOP_Transport_Mechanism is Iter : Socket_Name_Lists.Iterator := First (TMA.Addresses); Result : IIOP_Transport_Mechanism; begin while not Last (Iter) loop Append (Result.Addresses, new Socket_Name'(Value (Iter).all.all)); Next (Iter); end loop; return Result; end Duplicate; ------------------ -- Is_Colocated -- ------------------ function Is_Colocated (Left : IIOP_Transport_Mechanism; Right : Transport_Mechanism'Class) return Boolean is begin if Right not in IIOP_Transport_Mechanism then return False; end if; declare L_Iter : Iterator := First (Left.Addresses); R_Iter : Iterator; begin -- Check if Left.Addresses and Right.Addresses have an address in -- common. Left_Addresses : while not Last (L_Iter) loop R_Iter := First (IIOP_Transport_Mechanism (Right).Addresses); Right_Addresses : while not Last (R_Iter) loop if Value (L_Iter).all.all = Value (R_Iter).all.all then return True; end if; Next (R_Iter); end loop Right_Addresses; Next (L_Iter); end loop Left_Addresses; end; return False; end Is_Colocated; begin declare use PolyORB.Initialization; use PolyORB.Utils.Strings; begin Register_Module (Module_Info' (Name => +"giop_p.transport_mechanisms.iiop", Conflicts => PolyORB.Initialization.String_Lists.Empty, Depends => PolyORB.Initialization.String_Lists.Empty, Provides => PolyORB.Initialization.String_Lists.Empty, Implicit => False, Init => Initialize'Access, Shutdown => null)); end; end PolyORB.GIOP_P.Transport_Mechanisms.IIOP; polyorb-2.8~20110207.orig/src/giop/iiop/polyorb-binding_data-giop-iiop.adb0000644000175000017500000003606411750740340025531 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . B I N D I N G _ D A T A . G I O P . I I O P -- -- -- -- B o d y -- -- -- -- Copyright (C) 2002-2011, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- Binding data concrete implementation for IIOP. with Ada.Streams; with PolyORB.Binding_Data.GIOP.INET; with PolyORB.Binding_Data_QoS; with PolyORB.GIOP_P.Transport_Mechanisms.IIOP; with PolyORB.Initialization; with PolyORB.Log; with PolyORB.Obj_Adapters; with PolyORB.ORB; with PolyORB.Parameters; with PolyORB.QoS.Tagged_Components; with PolyORB.References.Corbaloc; with PolyORB.References.IOR; with PolyORB.Setup; with PolyORB.Utils.Sockets; with PolyORB.Utils.Strings; package body PolyORB.Binding_Data.GIOP.IIOP is use PolyORB.Binding_Data.GIOP.INET; use PolyORB.GIOP_P.Tagged_Components; use PolyORB.GIOP_P.Transport_Mechanisms; use PolyORB.GIOP_P.Transport_Mechanisms.IIOP; use PolyORB.Log; use PolyORB.Objects; use PolyORB.References.Corbaloc; use PolyORB.References.IOR; use PolyORB.Types; package L is new PolyORB.Log.Facility_Log ("polyorb.binding_data.giop.iiop"); procedure O (Message : Standard.String; Level : Log_Level := Debug) renames L.Output; function C (Level : Log_Level := Debug) return Boolean renames L.Enabled; IIOP_Corbaloc_Prefix : constant String := "iiop"; Preference : Profile_Preference; -- Global variable: the preference to be returned -- by Get_Profile_Preference for IIOP profiles. function Profile_To_Corbaloc (P : Profile_Access) return String; function Corbaloc_To_Profile (Str : String) return Profile_Access; function Get_Primary_IIOP_Address (Profile : IIOP_Profile_Type) return Utils.Sockets.Socket_Name; -- Return primary address of profile (address of the first profile's -- transport mechanims) procedure Add_Additional_Transport_Mechanisms (P : access IIOP_Profile_Type); -- Add transport mechanisms associated with tagged components in P. -- The primary transport mechanism (associated with the base IIOP profile -- body) should already have been created. procedure Add_Profile_QoS (P : access IIOP_Profile_Type); -- Add profile QoS parameters. This subprogram should be called -- after calculation of additional transport mechanisms. ------------------------------------- -- Add_Transport_Mechanism_Factory -- ------------------------------------- procedure Add_Transport_Mechanism_Factory (PF : in out IIOP_Profile_Factory; MF : Transport_Mechanism_Factory_Access) is begin Append (PF.Mechanisms, MF); end Add_Transport_Mechanism_Factory; ----------------------------------------- -- Add_Additional_Transport_Mechanisms -- ----------------------------------------- procedure Add_Additional_Transport_Mechanisms (P : access IIOP_Profile_Type) is begin Create_Transport_Mechanisms (P.Components, Profile_Access (P), P.Mechanisms); end Add_Additional_Transport_Mechanisms; --------------------- -- Add_Profile_QoS -- --------------------- procedure Add_Profile_QoS (P : access IIOP_Profile_Type) is use PolyORB.QoS; use PolyORB.QoS.Tagged_Components; begin PolyORB.Binding_Data_QoS.Set_Profile_QoS (P, GIOP_Tagged_Components, new QoS_GIOP_Tagged_Components_Parameter' (GIOP_Tagged_Components, Create_QoS_GIOP_Tagged_Components_List (P.Components))); if Security_Fetch_QoS /= null then Security_Fetch_QoS (P); end if; end Add_Profile_QoS; --------------------- -- Get_Profile_Tag -- --------------------- function Get_Profile_Tag (Profile : IIOP_Profile_Type) return Profile_Tag is pragma Unreferenced (Profile); begin return Tag_Internet_IOP; end Get_Profile_Tag; ---------------------------- -- Get_Profile_Preference -- ---------------------------- function Get_Profile_Preference (Profile : IIOP_Profile_Type) return Profile_Preference is pragma Unreferenced (Profile); begin return Preference; end Get_Profile_Preference; ------------------------------ -- Get_Primary_IIOP_Address -- ------------------------------ function Get_Primary_IIOP_Address (Profile : IIOP_Profile_Type) return Utils.Sockets.Socket_Name is begin return Primary_Address_Of (IIOP_Transport_Mechanism (Get_Primary_Transport_Mechanism (Profile).all)); end Get_Primary_IIOP_Address; -------------------- -- Create_Factory -- -------------------- procedure Create_Factory (PF : out IIOP_Profile_Factory; TAP : Transport.Transport_Access_Point_Access; ORB : Components.Component_Access) is pragma Unreferenced (ORB); MF : constant Transport_Mechanism_Factory_Access := new IIOP_Transport_Mechanism_Factory; begin Create_Factory (MF.all, TAP); Append (PF.Mechanisms, MF); end Create_Factory; -------------------- -- Create_Profile -- -------------------- function Create_Profile (PF : access IIOP_Profile_Factory; Oid : Objects.Object_Id) return Profile_Access is use Transport_Mechanism_Factory_Lists; Result : constant Profile_Access := new IIOP_Profile_Type; TResult : IIOP_Profile_Type renames IIOP_Profile_Type (Result.all); Iter : Transport_Mechanism_Factory_Lists.Iterator := First (PF.Mechanisms); begin TResult.Version_Major := IIOP_Version_Major; TResult.Version_Minor := IIOP_Version_Minor; TResult.Object_Id := new Object_Id'(Oid); -- Create primary transport mechanism (which has no associated tagged -- component). Append (TResult.Mechanisms, Create_Transport_Mechanism (IIOP_Transport_Mechanism_Factory (Value (Iter).all.all))); -- Fetch tagged components for Oid TResult.Components := Fetch_Components (TResult.Object_Id); -- Create tagged components for additional transport mechanisms while not Last (Iter) loop Add (TResult.Components, Create_Tagged_Components (Value (Iter).all.all)); Next (Iter); end loop; -- Create tagged components attached to the Object Adapter declare use Ada.Streams; use PolyORB.Errors; use PolyORB.QoS; use PolyORB.QoS.Tagged_Components; Error : Error_Container; QoS : QoS_Parameters; begin PolyORB.Obj_Adapters.Get_QoS (PolyORB.ORB.Object_Adapter (PolyORB.Setup.The_ORB), Oid, QoS, Error); if QoS (GIOP_Tagged_Components) /= null then declare use GIOP_Tagged_Component_Lists; Iter : GIOP_Tagged_Component_Lists.Iterator := First (QoS_GIOP_Tagged_Components_Parameter (QoS (GIOP_Tagged_Components).all).Components); begin while not Last (Iter) loop Add (TResult.Components, Create_Unknown_Component (Tag_Value (Value (Iter).Tag), new Stream_Element_Array'(Value (Iter).Data.all))); Next (Iter); end loop; end; end if; -- Create security related tagged component if Security_Fetch_Tagged_Component /= null then declare Sec_TC : constant Tagged_Component_Access := Security_Fetch_Tagged_Component (Oid); begin if Sec_TC /= null then Add (TResult.Components, Sec_TC); end if; end; end if; end; -- Now create additional transport mechanisms from tagged components Add_Additional_Transport_Mechanisms (TResult'Access); Add_Profile_QoS (TResult'Access); return Result; end Create_Profile; ------------------------------------- -- Disable_Unprotected_Invocations -- ------------------------------------- procedure Disable_Unprotected_Invocations (PF : in out IIOP_Profile_Factory) is begin Disable_Transport_Mechanism (IIOP_Transport_Mechanism_Factory (Element (PF.Mechanisms, 0).all.all)); end Disable_Unprotected_Invocations; ----------------------- -- Duplicate_Profile -- ----------------------- function Duplicate_Profile (P : IIOP_Profile_Type) return Profile_Access is use PolyORB.QoS; use PolyORB.QoS.Tagged_Components; Result : constant Profile_Access := new IIOP_Profile_Type; TResult : IIOP_Profile_Type renames IIOP_Profile_Type (Result.all); begin TResult.Version_Major := P.Version_Major; TResult.Version_Minor := P.Version_Minor; TResult.Object_Id := new Object_Id'(P.Object_Id.all); TResult.Components := Deep_Copy (P.Components); -- Duplicate Primary Transport Mechanism Append (TResult.Mechanisms, new IIOP_Transport_Mechanism' (Duplicate (IIOP_Transport_Mechanism (Element (P.Mechanisms, 0).all.all)))); Add_Additional_Transport_Mechanisms (TResult'Access); Add_Profile_QoS (TResult'Access); return Result; end Duplicate_Profile; -------------------------------- -- Marshall_IIOP_Profile_Body -- -------------------------------- procedure Marshall_IIOP_Profile_Body (Buf : access Buffer_Type; Profile : Profile_Access) is begin Common_Marshall_Profile_Body (Buf, Profile, Get_Primary_IIOP_Address (IIOP_Profile_Type (Profile.all)), True); end Marshall_IIOP_Profile_Body; ---------------------------------- -- Unmarshall_IIOP_Profile_Body -- ---------------------------------- function Unmarshall_IIOP_Profile_Body (Buffer : access Buffer_Type) return Profile_Access is use PolyORB.QoS; use PolyORB.QoS.Tagged_Components; use PolyORB.Utils.Sockets; Result : constant Profile_Access := new IIOP_Profile_Type; TResult : IIOP_Profile_Type renames IIOP_Profile_Type (Result.all); Address : constant Utils.Sockets.Socket_Name := Common_Unmarshall_Profile_Body (Buffer, Result, Unmarshall_Object_Id => True, Unmarshall_Tagged_Components => False); begin -- Create primary transport mechanism Append (TResult.Mechanisms, Create_Transport_Mechanism (Address)); Add_Additional_Transport_Mechanisms (TResult'Access); Add_Profile_QoS (TResult'Access); return Result; end Unmarshall_IIOP_Profile_Body; ----------- -- Image -- ----------- function Image (Prof : IIOP_Profile_Type) return String is begin return "Address : " & PolyORB.Utils.Sockets.Image (Get_Primary_IIOP_Address (Prof)) & ", Object_Id : " & PolyORB.Objects.Image (Prof.Object_Id.all); end Image; ------------------------- -- Profile_To_Corbaloc -- ------------------------- function Profile_To_Corbaloc (P : Profile_Access) return String is begin pragma Debug (C, O ("IIOP Profile to corbaloc")); return Common_IIOP_DIOP_Profile_To_Corbaloc (P, Get_Primary_IIOP_Address (IIOP_Profile_Type (P.all)), IIOP_Corbaloc_Prefix); end Profile_To_Corbaloc; ------------------------- -- Corbaloc_To_Profile -- ------------------------- function Corbaloc_To_Profile (Str : String) return Profile_Access is use Utils.Sockets; Result : aliased Profile_Access := new IIOP_Profile_Type; Address : constant Socket_Name := Common_IIOP_DIOP_Corbaloc_To_Profile (Str, IIOP_Version_Major, IIOP_Version_Minor, Result'Access); begin if Result /= null then -- Create primary transport mechanism Append (IIOP_Profile_Type (Result.all).Mechanisms, Create_Transport_Mechanism (Address)); end if; return Result; end Corbaloc_To_Profile; ---------------- -- Initialize -- ---------------- procedure Initialize; procedure Initialize is Preference_Offset : constant String := PolyORB.Parameters.Get_Conf (Section => "iiop", Key => "polyorb.binding_data.iiop.preference", Default => "0"); begin Preference := Preference_Default + Profile_Preference'Value (Preference_Offset); Register (Tag_Internet_IOP, Marshall_IIOP_Profile_Body'Access, Unmarshall_IIOP_Profile_Body'Access); Register (Tag_Internet_IOP, IIOP_Corbaloc_Prefix, Profile_To_Corbaloc'Access, Corbaloc_To_Profile'Access); end Initialize; use PolyORB.Initialization; use PolyORB.Initialization.String_Lists; use PolyORB.Utils.Strings; begin Register_Module (Module_Info' (Name => +"binding_data.iiop", Conflicts => Empty, Depends => +"protocols.giop.iiop" & "sockets", Provides => +"binding_factories", Implicit => False, Init => Initialize'Access, Shutdown => null)); end PolyORB.Binding_Data.GIOP.IIOP; polyorb-2.8~20110207.orig/src/giop/iiop/polyorb-binding_data-giop-iiop.ads0000644000175000017500000001033411750740340025542 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . B I N D I N G _ D A T A . G I O P . I I O P -- -- -- -- S p e c -- -- -- -- Copyright (C) 2002-2011, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- Binding data concrete implementation for IIOP. with PolyORB.Buffers; with PolyORB.Types; package PolyORB.Binding_Data.GIOP.IIOP is use PolyORB.Buffers; type IIOP_Profile_Type is new GIOP_Profile_Type with private; type IIOP_Profile_Factory is new GIOP_Profile_Factory with private; function Create_Profile (PF : access IIOP_Profile_Factory; Oid : Objects.Object_Id) return Profile_Access; function Duplicate_Profile (P : IIOP_Profile_Type) return Profile_Access; function Get_Profile_Tag (Profile : IIOP_Profile_Type) return Profile_Tag; pragma Inline (Get_Profile_Tag); function Get_Profile_Preference (Profile : IIOP_Profile_Type) return Profile_Preference; pragma Inline (Get_Profile_Preference); procedure Create_Factory (PF : out IIOP_Profile_Factory; TAP : Transport.Transport_Access_Point_Access; ORB : Components.Component_Access); procedure Marshall_IIOP_Profile_Body (Buf : access Buffer_Type; Profile : Profile_Access); function Unmarshall_IIOP_Profile_Body (Buffer : access Buffer_Type) return Profile_Access; function Image (Prof : IIOP_Profile_Type) return String; procedure Add_Transport_Mechanism_Factory (PF : in out IIOP_Profile_Factory; MF : PolyORB.GIOP_P.Transport_Mechanisms.Transport_Mechanism_Factory_Access); -- Add Transport Mechanism Factory to Profile Factory procedure Disable_Unprotected_Invocations (PF : in out IIOP_Profile_Factory); -- Disable unprotected invocations type Fetch_QoS_Callback is access procedure (P : access IIOP_Profile_Type); Security_Fetch_QoS : Fetch_QoS_Callback := null; type Fetch_Tagged_Component_Callback is access function (OA : PolyORB.Objects.Object_Id) return PolyORB.GIOP_P.Tagged_Components.Tagged_Component_Access; Security_Fetch_Tagged_Component : Fetch_Tagged_Component_Callback := null; private IIOP_Version_Major : constant Types.Octet := 1; IIOP_Version_Minor : constant Types.Octet := 2; type IIOP_Profile_Type is new GIOP_Profile_Type with null record; type IIOP_Profile_Factory is new GIOP_Profile_Factory with null record; end PolyORB.Binding_Data.GIOP.IIOP; polyorb-2.8~20110207.orig/src/giop/iiop/polyorb-protocols-giop-iiop.adb0000644000175000017500000000651411750740340025147 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . P R O T O C O L S . G I O P . I I O P -- -- -- -- B o d y -- -- -- -- Copyright (C) 2002-2007, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with PolyORB.Initialization; with PolyORB.Utils.Strings; package body PolyORB.Protocols.GIOP.IIOP is ------------ -- Create -- ------------ procedure Create (Proto : access IIOP_Protocol; Session : out Filter_Access) is begin PolyORB.Protocols.GIOP.Create (GIOP_Protocol (Proto.all)'Access, Session); GIOP_Session (Session.all).Conf := IIOP_Conf'Access; end Create; ---------------- -- Initialize -- ---------------- procedure Initialize; procedure Initialize is F : constant Flags := Sync_None or Sync_With_Transport or Sync_With_Server or Sync_With_Target; begin PolyORB.Protocols.GIOP.Initialize (IIOP_Conf'Access, GIOP_Default_Version, F, Default_Locate_Then_Request, "iiop", "polyorb.protocols.iiop.giop"); end Initialize; use PolyORB.Initialization; use PolyORB.Initialization.String_Lists; use PolyORB.Utils.Strings; begin Register_Module (Module_Info' (Name => +"protocols.giop.iiop", Conflicts => Empty, Depends => +"setup.iiop", Provides => Empty, Implicit => False, Init => Initialize'Access, Shutdown => null)); end PolyORB.Protocols.GIOP.IIOP; polyorb-2.8~20110207.orig/src/giop/iiop/polyorb-giop_p-transport_mechanisms-iiop.ads0000644000175000017500000001104711750740340027723 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- POLYORB.GIOP_P.TRANSPORT_MECHANISMS.IIOP -- -- -- -- S p e c -- -- -- -- Copyright (C) 2005-2008, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with PolyORB.Utils.Chained_Lists; with PolyORB.Utils.Sockets; package PolyORB.GIOP_P.Transport_Mechanisms.IIOP is type IIOP_Transport_Mechanism is new Transport_Mechanism with private; procedure Bind_Mechanism (Mechanism : IIOP_Transport_Mechanism; Profile : access PolyORB.Binding_Data.Profile_Type'Class; The_ORB : Components.Component_Access; QoS : PolyORB.QoS.QoS_Parameters; BO_Ref : out Smart_Pointers.Ref; Error : out Errors.Error_Container); procedure Release_Contents (M : access IIOP_Transport_Mechanism); -- IIOP Transport Mechanism specific subprograms function Primary_Address_Of (M : IIOP_Transport_Mechanism) return Utils.Sockets.Socket_Name; -- Return the primary access point name of M type IIOP_Transport_Mechanism_Factory is new Transport_Mechanism_Factory with private; procedure Create_Factory (MF : out IIOP_Transport_Mechanism_Factory; TAP : Transport.Transport_Access_Point_Access); function Is_Local_Mechanism (MF : access IIOP_Transport_Mechanism_Factory; M : access Transport_Mechanism'Class) return Boolean; function Is_Colocated (Left : IIOP_Transport_Mechanism; Right : Transport_Mechanism'Class) return Boolean; function Create_Tagged_Components (MF : IIOP_Transport_Mechanism_Factory) return Tagged_Components.Tagged_Component_List; -- IIOP Transport Mechanism Factory specific subprograms function Create_Transport_Mechanism (MF : IIOP_Transport_Mechanism_Factory) return Transport_Mechanism_Access; -- Create transport mechanism function Create_Transport_Mechanism (Address : Utils.Sockets.Socket_Name) return Transport_Mechanism_Access; -- Create transport mechanism for specified transport access point name procedure Disable_Transport_Mechanism (MF : in out IIOP_Transport_Mechanism_Factory); -- Disable transport mechanism if it is a primary mechanism function Duplicate (TMA : IIOP_Transport_Mechanism) return IIOP_Transport_Mechanism; private use Utils.Sockets; package Socket_Name_Lists is new PolyORB.Utils.Chained_Lists (Socket_Name_Ptr); type IIOP_Transport_Mechanism is new Transport_Mechanism with record Addresses : Socket_Name_Lists.List; end record; type IIOP_Transport_Mechanism_Factory is new Transport_Mechanism_Factory with record Disabled : Boolean := False; Addresses : Socket_Name_Lists.List; end record; end PolyORB.GIOP_P.Transport_Mechanisms.IIOP; polyorb-2.8~20110207.orig/src/giop/iiop/polyorb-giop_p-tagged_components-alternate_iiop_address.ads0000644000175000017500000000556711750740340032736 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- POLYORB.GIOP_P.TAGGED_COMPONENTS.ALTERNATE_IIOP_ADDRESS -- -- -- -- S p e c -- -- -- -- Copyright (C) 2005-2008, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- TAG_ALTERNATE_IIOP_ADDRESS tagged component with PolyORB.Utils.Sockets; package PolyORB.GIOP_P.Tagged_Components.Alternate_IIOP_Address is type TC_Alternate_IIOP_Address is new Tagged_Component (Tag => Tag_Alternate_IIOP_Address, At_Most_Once => False) with record Address : Utils.Sockets.Socket_Name_Ptr; end record; procedure Marshall_Component_Data (C : access TC_Alternate_IIOP_Address; Buffer : access Buffer_Type); procedure Unmarshall_Component_Data (C : access TC_Alternate_IIOP_Address; Buffer : access Buffer_Type; Error : out PolyORB.Errors.Error_Container); procedure Release_Contents (C : access TC_Alternate_IIOP_Address); function Duplicate (C : TC_Alternate_IIOP_Address) return Tagged_Component_Access; end PolyORB.GIOP_P.Tagged_Components.Alternate_IIOP_Address; polyorb-2.8~20110207.orig/src/giop/iiop/polyorb-giop_p-tagged_components-alternate_iiop_address.adb0000644000175000017500000001277711750740340032716 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- POLYORB.GIOP_P.TAGGED_COMPONENTS.ALTERNATE_IIOP_ADDRESS -- -- -- -- B o d y -- -- -- -- Copyright (C) 2005-2008, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with PolyORB.Initialization; with PolyORB.Utils.Strings; with PolyORB.Representations.CDR.Common; package body PolyORB.GIOP_P.Tagged_Components.Alternate_IIOP_Address is use PolyORB.Representations.CDR.Common; use PolyORB.Utils.Sockets; function Create_Empty_Component return Tagged_Component_Access; -- function Fetch_Component -- (Oid : access PolyORB.Objects.Object_Id) -- return Tagged_Component_Access; -- -- Alternate_IIOP_Address tag created by IIOP Transport Mechanism factory, -- thus no fetch function needed. ---------------------------- -- Create_Empty_Component -- ---------------------------- function Create_Empty_Component return Tagged_Component_Access is begin return new TC_Alternate_IIOP_Address; end Create_Empty_Component; ---------------------- -- Release_Contents -- ---------------------- procedure Release_Contents (C : access TC_Alternate_IIOP_Address) is begin Free (C.Address); end Release_Contents; ----------------------------- -- Marshall_Component_Data -- ----------------------------- procedure Marshall_Component_Data (C : access TC_Alternate_IIOP_Address; Buffer : access Buffer_Type) is Temp_Buf : Buffer_Access := new Buffer_Type; begin Start_Encapsulation (Temp_Buf); Marshall_Socket (Temp_Buf, C.Address.all); Marshall (Buffer, Encapsulate (Temp_Buf)); Release (Temp_Buf); end Marshall_Component_Data; ------------------------------- -- Unmarshall_Component_Data -- ------------------------------- procedure Unmarshall_Component_Data (C : access TC_Alternate_IIOP_Address; Buffer : access Buffer_Type; Error : out PolyORB.Errors.Error_Container) is use type Ada.Streams.Stream_Element_Offset; use PolyORB.Errors; Tag_Body : aliased Encapsulation := Unmarshall (Buffer); Temp_Buf : Buffer_Access := new Buffer_Type; begin Decapsulate (Tag_Body'Access, Temp_Buf); C.Address := new Socket_Name'(Unmarshall_Socket (Temp_Buf)); pragma Assert (Remaining (Temp_Buf) = 0); Release (Temp_Buf); exception when others => Release (Temp_Buf); Throw (Error, Bad_Param_E, System_Exception_Members'(10, Completed_No)); end Unmarshall_Component_Data; --------------- -- Duplicate -- --------------- function Duplicate (C : TC_Alternate_IIOP_Address) return Tagged_Component_Access is Result : constant Tagged_Component_Access := new TC_Alternate_IIOP_Address; begin TC_Alternate_IIOP_Address (Result.all).Address := new Socket_Name'(C.Address.all); return Result; end Duplicate; ---------------- -- Initialize -- ---------------- procedure Initialize; procedure Initialize is begin Register (Tag_Alternate_IIOP_Address, Create_Empty_Component'Access, null); end Initialize; use PolyORB.Initialization; use PolyORB.Utils.Strings; begin Register_Module (Module_Info' (Name => +"tagged_components.alternate_iiop_address", Conflicts => PolyORB.Initialization.String_Lists.Empty, Depends => PolyORB.Initialization.String_Lists.Empty, Provides => PolyORB.Initialization.String_Lists.Empty, Implicit => False, Init => Initialize'Access, Shutdown => null)); end PolyORB.GIOP_P.Tagged_Components.Alternate_IIOP_Address; polyorb-2.8~20110207.orig/src/giop/iiop/polyorb-setup-access_points-iiop.adb0000644000175000017500000002261211750740340026157 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . S E T U P . A C C E S S _ P O I N T S . I I O P -- -- -- -- B o d y -- -- -- -- Copyright (C) 2003-2007, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- Setup for IIOP access point. with PolyORB.Binding_Data.GIOP.IIOP; with PolyORB.GIOP_P.Transport_Mechanisms.IIOP; with PolyORB.Protocols.GIOP; with PolyORB.Protocols.GIOP.IIOP; with PolyORB.Parameters; with PolyORB.Filters; with PolyORB.Filters.Slicers; with PolyORB.Initialization; with PolyORB.ORB; with PolyORB.Protocols; with PolyORB.Sockets; with PolyORB.Transport.Connected.Sockets; with PolyORB.Utils.Strings; with PolyORB.Utils.Socket_Access_Points; with PolyORB.Utils.TCP_Access_Points; package body PolyORB.Setup.Access_Points.IIOP is use PolyORB.Binding_Data.GIOP.IIOP; use PolyORB.Filters; use PolyORB.Filters.Slicers; use PolyORB.GIOP_P.Transport_Mechanisms; use PolyORB.GIOP_P.Transport_Mechanisms.IIOP; use PolyORB.ORB; use PolyORB.Sockets; use PolyORB.Transport.Connected.Sockets; use PolyORB.Utils.Socket_Access_Points; use PolyORB.Utils.TCP_Access_Points; -- The IIOP access point Primary_IIOP_Access_Point : Access_Point_Info := (Socket => No_Socket, Address => No_Sock_Addr, SAP => new Socket_Access_Point, PF => new PolyORB.Binding_Data.GIOP.IIOP.IIOP_Profile_Factory); Sli : aliased Slicer_Factory; Pro : aliased Protocols.GIOP.IIOP.IIOP_Protocol; IIOP_Factories : aliased Filters.Factory_Array := (0 => Sli'Access, 1 => Pro'Access); ------------------------- -- Get_Profile_Factory -- ------------------------- function Get_Profile_Factory return PolyORB.Binding_Data.Profile_Factory_Access is begin return Primary_IIOP_Access_Point.PF; end Get_Profile_Factory; ------------------------------ -- Initialize_Access_Points -- ------------------------------ procedure Initialize_Access_Points; procedure Initialize_Access_Points is use PolyORB.Parameters; begin if Get_Conf ("access_points", "iiop", True) then declare Port_Hint : constant Port_Interval := To_Port_Interval (Get_Conf ("iiop", "polyorb.protocols.iiop.default_port", (Integer (Any_Port), Integer (Any_Port)))); Primary_Addr : constant Inet_Addr_Type := Inet_Addr (String'(Get_Conf ("iiop", "polyorb.protocols.iiop.default_addr", Image (No_Inet_Addr)))); Alternate_Listen_Addresses : constant String := Get_Conf ("iiop", "polyorb.protocols.iiop.alternate_listen_addresses", ""); begin Initialize_Socket (Primary_IIOP_Access_Point, Primary_Addr, Port_Hint); if Get_Conf ("ssliop", "polyorb.protocols.ssliop.disable_unprotected_invocations", False) then return; end if; Register_Access_Point (ORB => The_ORB, TAP => Primary_IIOP_Access_Point.SAP, Chain => IIOP_Factories'Access, PF => Primary_IIOP_Access_Point.PF); if Alternate_Listen_Addresses /= "" then declare Factory : constant Transport_Mechanism_Factory_Access := Get_Primary_Transport_Mechanism_Factory (IIOP_Profile_Factory (Primary_IIOP_Access_Point.PF.all)); First : Positive := Alternate_Listen_Addresses'First; Last : Natural := 0; Delim : Natural := 0; begin while First <= Alternate_Listen_Addresses'Last loop -- Skip all spaces for J in First .. Alternate_Listen_Addresses'Last loop if Alternate_Listen_Addresses (J) /= ' ' then First := J; exit; end if; end loop; -- Find end of address for J in First .. Alternate_Listen_Addresses'Last loop if Alternate_Listen_Addresses (J) = ' ' then Last := J - 1; exit; elsif J = Alternate_Listen_Addresses'Last then Last := J; end if; end loop; -- Find host/port delimiter Delim := Last + 1; for J in First .. Last loop if Alternate_Listen_Addresses (J) = ':' then Delim := J; exit; end if; end loop; -- Create transport mechanism factory, create transport -- access point and register it. declare Alternate_IIOP_Access_Point : Access_Point_Info := (Socket => No_Socket, Address => No_Sock_Addr, SAP => new Socket_Access_Point, PF => null); Alternate_Addr : constant Inet_Addr_Type := Inet_Addr (Alternate_Listen_Addresses (First .. Delim - 1)); Alternate_Port : Port_Interval := (Any_Port, Any_Port); begin if Delim < Last then Alternate_Port.Lo := Port_Type'Value (Alternate_Listen_Addresses (Delim + 1 .. Last)); Alternate_Port.Hi := Alternate_Port.Lo; end if; if Alternate_Addr /= No_Inet_Addr then Initialize_Socket (Alternate_IIOP_Access_Point, Alternate_Addr, Alternate_Port); Create_Factory (IIOP_Transport_Mechanism_Factory (Factory.all), Alternate_IIOP_Access_Point.SAP); Register_Access_Point (ORB => The_ORB, TAP => Alternate_IIOP_Access_Point.SAP, Chain => IIOP_Factories'Access, PF => null); end if; end; First := Last + 1; end loop; end; end if; end; end if; end Initialize_Access_Points; use PolyORB.Initialization; use PolyORB.Initialization.String_Lists; use PolyORB.Utils.Strings; begin Register_Module (Module_Info' (Name => +"access_points.iiop", Conflicts => Empty, Depends => +"sockets" & "orb" & "protocols.giop.iiop", Provides => +"access_points", Implicit => False, Init => Initialize_Access_Points'Access, Shutdown => null)); end PolyORB.Setup.Access_Points.IIOP; polyorb-2.8~20110207.orig/src/giop/iiop/polyorb-setup-iiop.ads0000644000175000017500000000431311750740340023343 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . S E T U P . I I O P -- -- -- -- S p e c -- -- -- -- Copyright (C) 2003 Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by ACT Europe. -- -- (email: sales@act-europe.fr) -- -- -- ------------------------------------------------------------------------------ -- This unit is used to configure the versions of GIOP that are -- supported by IIOP sessions (see unit body). package PolyORB.Setup.IIOP is pragma Elaborate_Body; end PolyORB.Setup.IIOP; polyorb-2.8~20110207.orig/src/giop/polyorb-giop_p-code_sets-converters.ads0000644000175000017500000002467211750740340025732 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . G I O P _ P . C O D E _ S E T S . C O N V E R T E R S -- -- -- -- S p e c -- -- -- -- Copyright (C) 2004-2009, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- Code sets converters -- Each code set converter process conversion between native code set and -- transmission code set and marshalling/unmarshalling of data. A converter is -- defined for each pair of native/transmission code sets. with GNAT.Byte_Swapping; with PolyORB.Buffers; with PolyORB.Utils.Buffers; pragma Elaborate_All (PolyORB.Utils.Buffers); package PolyORB.GIOP_P.Code_Sets.Converters is ---------------------------------------- -- Narrow character converter (CCS-C) -- ---------------------------------------- type Converter is abstract tagged limited private; type Converter_Access is access all Converter'Class; procedure Marshall (C : Converter; Buffer : access Buffers.Buffer_Type; Data : Types.Char; Error : in out Errors.Error_Container) is abstract; procedure Marshall (C : Converter; Buffer : access Buffers.Buffer_Type; Data : Types.String; Error : in out Errors.Error_Container) is abstract; procedure Unmarshall (C : Converter; Buffer : access Buffers.Buffer_Type; Data : out Types.Char; Error : in out Errors.Error_Container) is abstract; procedure Unmarshall (C : Converter; Buffer : access Buffers.Buffer_Type; Data : out Types.String; Error : in out Errors.Error_Container) is abstract; -------------------------------------- -- Wide character converter (CCS-W) -- -------------------------------------- type Wide_Converter is abstract tagged limited private; type Wide_Converter_Access is access all Wide_Converter'Class; procedure Set_GIOP_1_2_Mode (C : in out Wide_Converter); -- Use GIOP 1.2 semantics for wchar types procedure Marshall (C : Wide_Converter; Buffer : access Buffers.Buffer_Type; Data : Types.Wchar; Error : in out Errors.Error_Container) is abstract; procedure Marshall (C : Wide_Converter; Buffer : access Buffers.Buffer_Type; Data : Types.Wide_String; Error : in out Errors.Error_Container) is abstract; procedure Unmarshall (C : Wide_Converter; Buffer : access Buffers.Buffer_Type; Data : out Types.Wchar; Error : in out Errors.Error_Container) is abstract; procedure Unmarshall (C : Wide_Converter; Buffer : access Buffers.Buffer_Type; Data : out Types.Wide_String; Error : in out Errors.Error_Container) is abstract; function Get_Converter (Native_Code_Set : Code_Set_Id; Target_Code_Set : Code_Set_Id) return Converter_Access; -- Return converter for processing conversion between corresponding code -- sets for char data. function Get_Converter (Native_Code_Set : Code_Set_Id; Target_Code_Set : Code_Set_Id) return Wide_Converter_Access; -- Return converter for processing conversion between corresponding code -- sets for wchar data. function Supported_Char_Conversion_Code_Sets (Code_Set : Code_Set_Id) return Code_Set_Id_List; -- Return list of Code_Set_Id supported as conversion code set for defined -- native code set of char data (CCS-C). function Supported_Wchar_Conversion_Code_Sets (Code_Set : Code_Set_Id) return Code_Set_Id_List; -- Return list of Code_Set_Id supported as conversion code set for defined -- native code set of wchar data (CCS-W). private type Converter_Factory is access function return Converter_Access; type Wide_Converter_Factory is access function return Wide_Converter_Access; procedure Register_Native_Code_Set (Code_Set : Code_Set_Id; Native : Converter_Factory; Fallback : Converter_Factory); -- Register native code set procedure Register_Conversion_Code_Set (Native : Code_Set_Id; Conversion : Code_Set_Id; Factory : Converter_Factory); -- Register additional conversion code set procedure Register_Native_Code_Set (Code_Set : Code_Set_Id; Native : Wide_Converter_Factory; Fallback : Wide_Converter_Factory); -- Register native code set procedure Register_Conversion_Code_Set (Native : Code_Set_Id; Conversion : Code_Set_Id; Factory : Wide_Converter_Factory); -- Register additional conversion code set type Converter is abstract tagged limited null record; type Wide_Converter is abstract tagged limited record GIOP_1_2_Mode : Boolean := False; end record; ---------------------------------------------------- -- Supporting routines for unaligned unsigned I/O -- ---------------------------------------------------- use PolyORB.Utils.Buffers; function Swapped is new GNAT.Byte_Swapping.Swapped2 (PolyORB.Types.Unsigned_Short); package Unaligned_Unsigned_Short is new Align_Transfer_Elementary (T => PolyORB.Types.Unsigned_Short, With_Alignment => False); function Swapped is new GNAT.Byte_Swapping.Swapped4 (PolyORB.Types.Unsigned_Long); package Unaligned_Unsigned_Long is new Align_Transfer_Elementary (T => PolyORB.Types.Unsigned_Long, With_Alignment => False); -- Ada95 data converters type ISO88591_Native_Converter is new Converter with null record; procedure Marshall (C : ISO88591_Native_Converter; Buffer : access Buffers.Buffer_Type; Data : Types.Char; Error : in out Errors.Error_Container); procedure Marshall (C : ISO88591_Native_Converter; Buffer : access Buffers.Buffer_Type; Data : Types.String; Error : in out Errors.Error_Container); procedure Unmarshall (C : ISO88591_Native_Converter; Buffer : access Buffers.Buffer_Type; Data : out Types.Char; Error : in out Errors.Error_Container); procedure Unmarshall (C : ISO88591_Native_Converter; Buffer : access Buffers.Buffer_Type; Data : out Types.String; Error : in out Errors.Error_Container); type ISO88591_UTF8_Converter is new Converter with null record; procedure Marshall (C : ISO88591_UTF8_Converter; Buffer : access Buffers.Buffer_Type; Data : Types.Char; Error : in out Errors.Error_Container); procedure Marshall (C : ISO88591_UTF8_Converter; Buffer : access Buffers.Buffer_Type; Data : Types.String; Error : in out Errors.Error_Container); procedure Unmarshall (C : ISO88591_UTF8_Converter; Buffer : access Buffers.Buffer_Type; Data : out Types.Char; Error : in out Errors.Error_Container); procedure Unmarshall (C : ISO88591_UTF8_Converter; Buffer : access Buffers.Buffer_Type; Data : out Types.String; Error : in out Errors.Error_Container); type UCS2_Native_Wide_Converter is new Wide_Converter with null record; procedure Marshall (C : UCS2_Native_Wide_Converter; Buffer : access Buffers.Buffer_Type; Data : Types.Wchar; Error : in out Errors.Error_Container); procedure Marshall (C : UCS2_Native_Wide_Converter; Buffer : access Buffers.Buffer_Type; Data : Types.Wide_String; Error : in out Errors.Error_Container); procedure Unmarshall (C : UCS2_Native_Wide_Converter; Buffer : access Buffers.Buffer_Type; Data : out Types.Wchar; Error : in out Errors.Error_Container); procedure Unmarshall (C : UCS2_Native_Wide_Converter; Buffer : access Buffers.Buffer_Type; Data : out Types.Wide_String; Error : in out Errors.Error_Container); type UCS2_UTF16_Wide_Converter is new Wide_Converter with null record; procedure Marshall (C : UCS2_UTF16_Wide_Converter; Buffer : access Buffers.Buffer_Type; Data : Types.Wchar; Error : in out Errors.Error_Container); procedure Marshall (C : UCS2_UTF16_Wide_Converter; Buffer : access Buffers.Buffer_Type; Data : Types.Wide_String; Error : in out Errors.Error_Container); procedure Unmarshall (C : UCS2_UTF16_Wide_Converter; Buffer : access Buffers.Buffer_Type; Data : out Types.Wchar; Error : in out Errors.Error_Container); procedure Unmarshall (C : UCS2_UTF16_Wide_Converter; Buffer : access Buffers.Buffer_Type; Data : out Types.Wide_String; Error : in out Errors.Error_Container); end PolyORB.GIOP_P.Code_Sets.Converters; polyorb-2.8~20110207.orig/src/giop/polyorb-representations-cdr-giop_1_1.adb0000644000175000017500000002077311750740340025663 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- POLYORB.REPRESENTATIONS.CDR.GIOP_1_1 -- -- -- -- B o d y -- -- -- -- Copyright (C) 2004-2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with Ada.Unchecked_Deallocation; with PolyORB.Initialization; with PolyORB.Representations.CDR.Common; with PolyORB.Utils.Strings; with PolyORB.Setup; package body PolyORB.Representations.CDR.GIOP_1_1 is use PolyORB.Errors; use PolyORB.GIOP_P.Code_Sets.Converters; use PolyORB.Representations.CDR.Common; function Create return CDR_Representation_Access; procedure Deferred_Initialization; procedure Free is new Ada.Unchecked_Deallocation (Converter'Class, Converter_Access); procedure Free is new Ada.Unchecked_Deallocation (Wide_Converter'Class, Wide_Converter_Access); ------------ -- Create -- ------------ function Create return CDR_Representation_Access is begin return new GIOP_1_1_CDR_Representation; end Create; ----------------------------- -- Deferred_Initialization -- ----------------------------- procedure Deferred_Initialization is begin Register_Factory (1, 1, Create'Access); PolyORB.Setup.Default_Representation := Representation_Access (Create); end Deferred_Initialization; -------------- -- Marshall -- -------------- procedure Marshall (R : GIOP_1_1_CDR_Representation; Buffer : access Buffers.Buffer_Type; Data : PolyORB.Types.Char; Error : in out Errors.Error_Container) is begin if R.C_Converter /= null then Marshall (R.C_Converter.all, Buffer, Data, Error); else -- Backward compatibility mode Marshall_Latin_1_Char (Buffer, Data); end if; end Marshall; -------------- -- Marshall -- -------------- procedure Marshall (R : GIOP_1_1_CDR_Representation; Buffer : access Buffers.Buffer_Type; Data : PolyORB.Types.String; Error : in out Errors.Error_Container) is begin if R.C_Converter /= null then Marshall (R.C_Converter.all, Buffer, Data, Error); else -- Backward compatibility mode Marshall_Latin_1_String (Buffer, Data); end if; end Marshall; -------------- -- Marshall -- -------------- procedure Marshall (R : GIOP_1_1_CDR_Representation; Buffer : access Buffers.Buffer_Type; Data : PolyORB.Types.Wchar; Error : in out Errors.Error_Container) is begin if R.W_Converter /= null then Marshall (R.W_Converter.all, Buffer, Data, Error); else -- Backward compatibility mode Throw (Error, Marshal_E, System_Exception_Members'(5, Completed_No)); -- XXX Check exception and minor code. end if; end Marshall; -------------- -- Marshall -- -------------- procedure Marshall (R : GIOP_1_1_CDR_Representation; Buffer : access Buffers.Buffer_Type; Data : PolyORB.Types.Wide_String; Error : in out Errors.Error_Container) is begin if R.W_Converter /= null then Marshall (R.W_Converter.all, Buffer, Data, Error); else -- Backward compatibility mode Throw (Error, Marshal_E, System_Exception_Members'(5, Completed_No)); -- XXX Check exception and minor code. end if; end Marshall; ------------- -- Release -- ------------- procedure Release (R : in out GIOP_1_1_CDR_Representation) is begin Free (R.C_Converter); Free (R.W_Converter); end Release; -------------------- -- Set_Converters -- -------------------- procedure Set_Converters (R : in out GIOP_1_1_CDR_Representation; C : PolyORB.GIOP_P.Code_Sets.Converters.Converter_Access; W : PolyORB.GIOP_P.Code_Sets.Converters.Wide_Converter_Access) is begin R.C_Converter := C; R.W_Converter := W; end Set_Converters; ---------------- -- Unmarshall -- ---------------- procedure Unmarshall (R : GIOP_1_1_CDR_Representation; Buffer : access Buffers.Buffer_Type; Data : out PolyORB.Types.Char; Error : in out Errors.Error_Container) is begin if R.C_Converter /= null then Unmarshall (R.C_Converter.all, Buffer, Data, Error); else -- Backward compatibility mode Data := Unmarshall_Latin_1_Char (Buffer); end if; end Unmarshall; ---------------- -- Unmarshall -- ---------------- procedure Unmarshall (R : GIOP_1_1_CDR_Representation; Buffer : access Buffers.Buffer_Type; Data : out PolyORB.Types.String; Error : in out Errors.Error_Container) is begin if R.C_Converter /= null then Unmarshall (R.C_Converter.all, Buffer, Data, Error); else -- Backward compatibility mode Data := Unmarshall_Latin_1_String (Buffer); end if; end Unmarshall; ---------------- -- Unmarshall -- ---------------- procedure Unmarshall (R : GIOP_1_1_CDR_Representation; Buffer : access Buffers.Buffer_Type; Data : out PolyORB.Types.Wchar; Error : in out Errors.Error_Container) is begin if R.W_Converter /= null then Unmarshall (R.W_Converter.all, Buffer, Data, Error); else -- Backward compatibility mode Throw (Error, Marshal_E, System_Exception_Members'(5, Completed_No)); -- XXX Check exception and minor code. end if; end Unmarshall; ---------------- -- Unmarshall -- ---------------- procedure Unmarshall (R : GIOP_1_1_CDR_Representation; Buffer : access Buffers.Buffer_Type; Data : out PolyORB.Types.Wide_String; Error : in out Errors.Error_Container) is begin if R.W_Converter /= null then Unmarshall (R.W_Converter.all, Buffer, Data, Error); else -- Backward compatibility mode Throw (Error, Marshal_E, System_Exception_Members'(5, Completed_No)); -- XXX Check exception and minor code. end if; end Unmarshall; begin declare use PolyORB.Initialization; use PolyORB.Initialization.String_Lists; use PolyORB.Utils.Strings; begin Register_Module (Module_Info' (Name => +"representations.cdr.giop_1_1", Conflicts => Empty, Depends => Empty, Provides => Empty, Implicit => False, Init => Deferred_Initialization'Access, Shutdown => null)); end; end PolyORB.Representations.CDR.GIOP_1_1; polyorb-2.8~20110207.orig/src/giop/polyorb-giop_p-tagged_components-policies.ads0000644000175000017500000000764511750740340027100 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- POLYORB.GIOP_P.TAGGED_COMPONENTS.POLICIES -- -- -- -- S p e c -- -- -- -- Copyright (C) 2003-2007, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- TAG_POLICIES tagged component with PolyORB.Representations.CDR.Common; with PolyORB.Types; with PolyORB.Utils.Chained_Lists; package PolyORB.GIOP_P.Tagged_Components.Policies is use PolyORB.GIOP_P.Tagged_Components; type TC_Policies is new Tagged_Component (Tag => Tag_Policies, At_Most_Once => True) with private; -- Note: the at-most-once semantics of this component is not -- specified in the CORBA specification, par. 22.3.2, use default -- value. procedure Marshall_Component_Data (C : access TC_Policies; Buffer : access Buffer_Type); procedure Unmarshall_Component_Data (C : access TC_Policies; Buffer : access Buffer_Type; Error : out PolyORB.Errors.Error_Container); procedure Release_Contents (C : access TC_Policies); function Duplicate (C : TC_Policies) return Tagged_Component_Access; private type Encapsulation_Access is access all PolyORB.Representations.CDR.Common.Encapsulation; type Policy_Value is record P_Type : PolyORB.Types.Unsigned_Long; P_Value : Encapsulation_Access; end record; Invalid_Policy_Type : constant := PolyORB.Types.Unsigned_Long'Last; type Fetch_Sub_Component_Func_Access is access function (Oid : access PolyORB.Objects.Object_Id) return Policy_Value; procedure Register (Fetch_Sub_Component : Fetch_Sub_Component_Func_Access); -- Register an allocator for a TAG_POLICIES sub component package Policy_Value_Seq is new PolyORB.Utils.Chained_Lists (Policy_Value); -- Implementation Note: CORBA/GIOP defines Policy_Value_Seq as an -- unbounded sequence. We implement it using as a chain list to -- avoid dragging unbounded sequences, which is unneeded. type TC_Policies is new Tagged_Component (Tag => Tag_Policies, At_Most_Once => True) with record Policies : Policy_Value_Seq.List; end record; end PolyORB.GIOP_P.Tagged_Components.Policies; polyorb-2.8~20110207.orig/src/giop/polyorb-giop_p-tagged_components-policies.adb0000644000175000017500000001755711750740340027062 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- POLYORB.GIOP_P.TAGGED_COMPONENTS.POLICIES -- -- -- -- B o d y -- -- -- -- Copyright (C) 2003-2007, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with Ada.Streams; with Ada.Unchecked_Deallocation; with PolyORB.Initialization; with PolyORB.Utils.Strings; package body PolyORB.GIOP_P.Tagged_Components.Policies is use Ada.Streams; use PolyORB.Representations.CDR.Common; package Sub_Component_Allocator_Lists is new PolyORB.Utils.Chained_Lists (Fetch_Sub_Component_Func_Access); Sub_Component_Allocators : Sub_Component_Allocator_Lists.List; ---------------------------- -- Create_Empty_Component -- ---------------------------- function Create_Empty_Component return Tagged_Component_Access; function Create_Empty_Component return Tagged_Component_Access is begin return new TC_Policies; end Create_Empty_Component; --------------- -- Duplicate -- --------------- function Duplicate (C : TC_Policies) return Tagged_Component_Access is Result : constant Tagged_Component_Access := new TC_Policies; Iter : Policy_Value_Seq.Iterator := Policy_Value_Seq.First (C.Policies); begin while not Policy_Value_Seq.Last (Iter) loop Policy_Value_Seq.Append (TC_Policies (Result.all).Policies, Policy_Value' (Policy_Value_Seq.Value (Iter).P_Type, new Encapsulation'(Policy_Value_Seq.Value (Iter).P_Value.all))); Policy_Value_Seq.Next (Iter); end loop; return Result; end Duplicate; --------------------- -- Fetch_Component -- --------------------- function Fetch_Component (Oid : access PolyORB.Objects.Object_Id) return Tagged_Component_Access; function Fetch_Component (Oid : access PolyORB.Objects.Object_Id) return Tagged_Component_Access is use Sub_Component_Allocator_Lists; use type PolyORB.Types.Unsigned_Long; It : Sub_Component_Allocator_Lists.Iterator := First (Sub_Component_Allocators); Result : Tagged_Component_Access; Policy : Policy_Value; begin while not Last (It) loop Policy := Value (It).all (Oid); if Policy.P_Type /= Invalid_Policy_Type then if Result = null then Result := new TC_Policies; end if; Policy_Value_Seq.Append (TC_Policies (Result.all).Policies, Policy); end if; Next (It); end loop; return Result; end Fetch_Component; ----------------------------- -- Marshall_Component_Data -- ----------------------------- procedure Marshall_Component_Data (C : access TC_Policies; Buffer : access Buffer_Type) is use Policy_Value_Seq; It : Policy_Value_Seq.Iterator := First (C.Policies); Temp_Buf : Buffer_Access := new Buffer_Type; begin -- The body of a Tag_Policy component is an encapsulation Start_Encapsulation (Temp_Buf); -- Length of Policy_Value_Seq Marshall (Temp_Buf, PolyORB.Types.Unsigned_Long (Length (C.Policies))); -- Marshall Policy_Value_Seq elements while not Last (It) loop Marshall (Temp_Buf, Value (It).P_Type); Marshall (Temp_Buf, Value (It).P_Value.all); Next (It); end loop; Marshall (Buffer, Encapsulate (Temp_Buf)); Release (Temp_Buf); end Marshall_Component_Data; ------------------------------- -- Unmarshall_Component_Data -- ------------------------------- procedure Unmarshall_Component_Data (C : access TC_Policies; Buffer : access Buffer_Type; Error : out PolyORB.Errors.Error_Container) is use Policy_Value_Seq; use PolyORB.Errors; Length : PolyORB.Types.Unsigned_Long; Temp_Policy_Value : Policy_Value; Tag_Body : aliased Encapsulation := Unmarshall (Buffer); Temp_Buf : Buffer_Access := new Buffer_Type; begin Decapsulate (Tag_Body'Access, Temp_Buf); Length := Unmarshall (Temp_Buf); for J in 1 .. Length loop Temp_Policy_Value.P_Type := Unmarshall (Temp_Buf); Temp_Policy_Value.P_Value := new Stream_Element_Array'(Unmarshall (Temp_Buf)); Append (C.Policies, Temp_Policy_Value); end loop; pragma Assert (Remaining (Temp_Buf) = 0); Release (Temp_Buf); exception when others => Release (Temp_Buf); Throw (Error, Bad_Param_E, System_Exception_Members'(10, Completed_No)); end Unmarshall_Component_Data; ---------------------- -- Release_Contents -- ---------------------- procedure Release_Contents (C : access TC_Policies) is procedure Free is new Ada.Unchecked_Deallocation (Encapsulation, Encapsulation_Access); use Policy_Value_Seq; It : Policy_Value_Seq.Iterator := First (C.Policies); begin while not Last (It) loop Free (Value (It).P_Value); Next (It); end loop; Deallocate (C.Policies); end Release_Contents; -------------- -- Register -- -------------- procedure Register (Fetch_Sub_Component : Fetch_Sub_Component_Func_Access) is use Sub_Component_Allocator_Lists; begin Append (Sub_Component_Allocators, Fetch_Sub_Component); end Register; ---------------- -- Initialize -- ---------------- procedure Initialize; procedure Initialize is begin Register (Tag_Policies, Create_Empty_Component'Access, Fetch_Component'Access); end Initialize; use PolyORB.Initialization; use PolyORB.Utils.Strings; begin Register_Module (Module_Info' (Name => +"tagged_components.policies", Conflicts => PolyORB.Initialization.String_Lists.Empty, Depends => PolyORB.Initialization.String_Lists.Empty, Provides => PolyORB.Initialization.String_Lists.Empty, Implicit => False, Init => Initialize'Access, Shutdown => null)); end PolyORB.GIOP_P.Tagged_Components.Policies; polyorb-2.8~20110207.orig/src/giop/polyorb-representations-cdr-giop_utils.adb0000644000175000017500000000740411750740340026437 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- POLYORB.REPRESENTATIONS.CDR.GIOP_UTILS -- -- -- -- B o d y -- -- -- -- Copyright (C) 2004-2008, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with PolyORB.Log; package body PolyORB.Representations.CDR.GIOP_Utils is use PolyORB.Log; package L is new PolyORB.Log.Facility_Log ("polyorb.representations.cdr.giop_utils"); procedure O (Message : String; Level : Log_Level := Debug) renames L.Output; function C (Level : Log_Level := Debug) return Boolean renames L.Enabled; -------------- -- Marshall -- -------------- procedure Marshall (Buffer : access Buffers.Buffer_Type; Representation : access CDR_Representation'Class; Data : PolyORB.Any.NamedValue; Error : in out Errors.Error_Container) is use PolyORB.Any; begin pragma Debug (C, O ("Marshall (NamedValue) : enter")); Marshall_From_Any (Representation, Buffer, Get_Container (Data.Argument).all, Error); pragma Debug (C, O ("Marshall (NamedValue) : end")); end Marshall; ---------------- -- Unmarshall -- ---------------- procedure Unmarshall (Buffer : access Buffers.Buffer_Type; Representation : access CDR_Representation'Class; Data : in out PolyORB.Any.NamedValue; Error : in out Errors.Error_Container) is use PolyORB.Any; begin pragma Debug (C, O ("Unmarshall (NamedValue) : enter")); Unmarshall_To_Any (Representation, Buffer, Get_Container (Data.Argument).all, Error); pragma Debug (C, O ("Unmarshall (NamedValue) : is_empty := " & Boolean'Image (PolyORB.Any.Is_Empty (Data.Argument)))); pragma Debug (C, O ("Unmarshall (NamedValue) : end")); end Unmarshall; end PolyORB.Representations.CDR.GIOP_Utils; polyorb-2.8~20110207.orig/src/giop/polyorb-giop_p.ads0000644000175000017500000000417111750740340021564 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . G I O P _ P -- -- -- -- S p e c -- -- -- -- Copyright (C) 2002-2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- Root package for the GIOP protocol personality package PolyORB.GIOP_P is pragma Pure; end PolyORB.GIOP_P; polyorb-2.8~20110207.orig/src/giop/polyorb-protocols-giop-giop_1_0.ads0000644000175000017500000001033011750740340024654 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . P R O T O C O L S . G I O P . G I O P _ 1 _ 0 -- -- -- -- S p e c -- -- -- -- Copyright (C) 2002-2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ package PolyORB.Protocols.GIOP.GIOP_1_0 is private type GIOP_Implem_1_0 is new GIOP_Implem with null record; type GIOP_Implem_1_0_Access is access all GIOP_Implem_1_0'Class; -- GIOP 1.0 message context type GIOP_Message_Context_1_0 is new GIOP_Message_Context with null record; procedure Initialize_Implem (Implem : access GIOP_Implem_1_0); procedure Initialize_Session (Implem : access GIOP_Implem_1_0; S : access Session'Class); procedure Finalize_Session (Implem : access GIOP_Implem_1_0; S : access Session'Class); procedure Unmarshall_GIOP_Header (Implem : access GIOP_Implem_1_0; MCtx : access GIOP_Message_Context'Class; Buffer : access Buffers.Buffer_Type); procedure Marshall_GIOP_Header (Implem : access GIOP_Implem_1_0; S : access Session'Class; MCtx : access GIOP_Message_Context'Class; Buffer : access Buffers.Buffer_Type); procedure Marshall_GIOP_Header_Reply (Implem : access GIOP_Implem_1_0; S : access Session'Class; R : Request_Access; MCtx : access GIOP_Message_Context'Class; Buffer : access Buffers.Buffer_Type); procedure Process_Message (Implem : access GIOP_Implem_1_0; S : access Session'Class); procedure Send_Reply (Implem : access GIOP_Implem_1_0; S : access Session'Class; Request : Requests.Request_Access); procedure Locate_Object (Implem : access GIOP_Implem_1_0; S : access Session'Class; R : Pending_Request_Access; Error : in out Errors.Error_Container); procedure Send_Request (Implem : access GIOP_Implem_1_0; S : access Session'Class; R : Pending_Request_Access; Error : in out Errors.Error_Container); procedure Send_Cancel_Request (Implem : access GIOP_Implem_1_0; S : access Session'Class; R : Request_Access); -- Data alignment Data_Alignment_1_0 : constant Buffers.Alignment_Type := Buffers.Align_1; -- Principal Nobody_Principal : constant Types.String := Types.To_PolyORB_String ("nobody"); end PolyORB.Protocols.GIOP.GIOP_1_0; polyorb-2.8~20110207.orig/src/giop/polyorb-qos-code_sets.adb0000644000175000017500000001166411750740340023043 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . Q O S . C O D E _ S E T S -- -- -- -- B o d y -- -- -- -- Copyright (C) 2004-2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with PolyORB.Buffers; with PolyORB.Initialization; with PolyORB.Representations.CDR.Common; with PolyORB.QoS.Service_Contexts; with PolyORB.Types; with PolyORB.Utils.Strings; package body PolyORB.QoS.Code_Sets is use PolyORB.Buffers; use PolyORB.GIOP_P.Code_Sets; use PolyORB.Representations.CDR.Common; use PolyORB.QoS.Service_Contexts; use PolyORB.Types; function To_CodeSets_Service_Context (QoS : QoS_Parameter_Access) return Service_Context; function To_QoS_GIOP_Code_Sets_Parameter (SC : Service_Context) return QoS_Parameter_Access; --------------------------------- -- To_CodeSets_Service_Context -- --------------------------------- function To_CodeSets_Service_Context (QoS : QoS_Parameter_Access) return Service_Context is Result : Service_Context := (CodeSets, null); begin if QoS = null then return Result; end if; declare CS : QoS_GIOP_Code_Sets_Parameter renames QoS_GIOP_Code_Sets_Parameter (QoS.all); Buffer : Buffer_Access := new Buffer_Type; begin Start_Encapsulation (Buffer); Marshall (Buffer, Unsigned_Long (CS.Char_Data)); Marshall (Buffer, Unsigned_Long (CS.Wchar_Data)); Result.Context_Data := new Encapsulation'(Encapsulate (Buffer)); Release (Buffer); end; return Result; end To_CodeSets_Service_Context; ------------------------------------- -- To_QoS_GIOP_Code_Sets_Parameter -- ------------------------------------- function To_QoS_GIOP_Code_Sets_Parameter (SC : Service_Context) return QoS_Parameter_Access is Buffer : aliased Buffer_Type; Char_Data : Code_Set_Id; Wchar_Data : Code_Set_Id; begin Decapsulate (SC.Context_Data, Buffer'Access); Char_Data := Code_Set_Id (Unsigned_Long'(Unmarshall (Buffer'Access))); Wchar_Data := Code_Set_Id (Unsigned_Long'(Unmarshall (Buffer'Access))); return new QoS_GIOP_Code_Sets_Parameter' (Kind => GIOP_Code_Sets, Char_Data => Char_Data, Wchar_Data => Wchar_Data); end To_QoS_GIOP_Code_Sets_Parameter; ---------------- -- Initialize -- ---------------- procedure Initialize; procedure Initialize is begin -- CodeSets service context Register (GIOP_Code_Sets, To_CodeSets_Service_Context'Access); Register (CodeSets, To_QoS_GIOP_Code_Sets_Parameter'Access); end Initialize; begin declare use PolyORB.Initialization; use PolyORB.Initialization.String_Lists; use PolyORB.Utils.Strings; begin Register_Module (Module_Info' (Name => +"request_qos.code_sets", Conflicts => Empty, Depends => Empty, Provides => Empty, Implicit => False, Init => Initialize'Access, Shutdown => null)); end; end PolyORB.QoS.Code_Sets; polyorb-2.8~20110207.orig/src/giop/polyorb-binding_data-giop.adb0000644000175000017500000001647011750740340023632 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . B I N D I N G _ D A T A . G I O P -- -- -- -- B o d y -- -- -- -- Copyright (C) 2004-2008, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with PolyORB.Binding_Objects; package body PolyORB.Binding_Data.GIOP is use PolyORB.Errors; use PolyORB.GIOP_P.Tagged_Components; use PolyORB.GIOP_P.Transport_Mechanisms; use PolyORB.Objects; use PolyORB.Types; ------------------ -- Bind_Profile -- ------------------ procedure Bind_Profile (Profile : access GIOP_Profile_Type; The_ORB : Components.Component_Access; QoS : PolyORB.QoS.QoS_Parameters; BO_Ref : out Smart_Pointers.Ref; Error : out Errors.Error_Container) is use PolyORB.Binding_Objects; use PolyORB.Protocols.GIOP; use Transport_Mechanism_Lists; Iter : Transport_Mechanism_Lists.Iterator := First (Profile.Mechanisms); begin -- Go through all transport mechanism and try to bind it until the -- operation completes successfully. -- XXX This is a temporary implementation. It is not conformant -- with PortableInterceptors and RebindPolicy specifications. Throw (Error, No_Resources_E, System_Exception_Members' (Minor => 0, Completed => Completed_Maybe)); while not Last (Iter) loop if Is_Security_Selected = null or else Is_Security_Selected (QoS, Value (Iter).all) then Catch (Error); Bind_Mechanism (Value (Iter).all.all, Profile, The_ORB, QoS, BO_Ref, Error); exit when not Found (Error); end if; Next (Iter); end loop; if not Found (Error) then Locate_Object (GIOP_Session (Get_Component (BO_Ref).all)'Access, Profile_Access (Profile), Error); end if; end Bind_Profile; ---------------------- -- Get_GIOP_Version -- ---------------------- function Get_GIOP_Version (P : GIOP_Profile_Type) return Protocols.GIOP.GIOP_Version is use Protocols.GIOP; Minor : constant Integer := Integer (P.Version_Minor); begin pragma Assert (P.Version_Major = 1); if Minor in To_GIOP_Version'Range then return To_GIOP_Version (Minor); else raise GIOP_Error with "unsupported GIOP version 1." & Minor'Img; end if; end Get_GIOP_Version; ------------------ -- Is_Colocated -- ------------------ function Is_Colocated (Left : GIOP_Profile_Type; Right : Profile_Type'Class) return Boolean is begin if Right not in GIOP_Profile_Type'Class then return False; end if; -- Compare transport mechanisms declare L_Mechanisms, R_Mechanisms : Transport_Mechanism_List; begin L_Mechanisms := Left.Mechanisms; R_Mechanisms := GIOP_Profile_Type (Right).Mechanisms; return Is_Colocated (L_Mechanisms, R_Mechanisms); end; end Is_Colocated; ---------------------- -- Is_Local_Profile -- ---------------------- function Is_Local_Profile (PF : access GIOP_Profile_Factory; P : access Profile_Type'Class) return Boolean is use Transport_Mechanism_Lists; use Transport_Mechanism_Factory_Lists; F_Iter : Transport_Mechanism_Factory_Lists.Iterator := First (PF.Mechanisms); begin if P.all not in GIOP_Profile_Type'Class then return False; end if; -- Profile designates a local object if at least one of its -- transport mechanism is local. while not Last (F_Iter) loop declare M_Iter : Transport_Mechanism_Lists.Iterator := First (GIOP_Profile_Type (P.all).Mechanisms); begin while not Last (M_Iter) loop if Is_Local_Mechanism (Value (F_Iter).all, Value (M_Iter).all) then P.Known_Local := True; return True; end if; Next (M_Iter); end loop; end; Next (F_Iter); end loop; return False; end Is_Local_Profile; ------------------- -- Get_Component -- ------------------- function Get_Component (P : GIOP_Profile_Type; C : Tag_Value) return Tagged_Component_Access is begin return Get_Component (P.Components, C); end Get_Component; ------------------------------------- -- Get_Primary_Transport_Mechanism -- ------------------------------------- function Get_Primary_Transport_Mechanism (P : GIOP_Profile_Type) return PolyORB.GIOP_P.Transport_Mechanisms.Transport_Mechanism_Access is begin return Element (P.Mechanisms, 0).all; end Get_Primary_Transport_Mechanism; --------------------------------------------- -- Get_Primary_Transport_Mechanism_Factory -- --------------------------------------------- function Get_Primary_Transport_Mechanism_Factory (P : GIOP_Profile_Factory) return PolyORB.GIOP_P.Transport_Mechanisms.Transport_Mechanism_Factory_Access is begin return Element (P.Mechanisms, 0).all; end Get_Primary_Transport_Mechanism_Factory; ------------- -- Release -- ------------- procedure Release (P : in out GIOP_Profile_Type) is begin Free (P.Object_Id); PolyORB.Annotations.Destroy (P.Notepad); Release_Contents (P.Components); Release_Contents (P.Mechanisms); end Release; end PolyORB.Binding_Data.GIOP; polyorb-2.8~20110207.orig/src/giop/polyorb-giop_p-tagged_components-code_sets.ads0000644000175000017500000000616111750740340027231 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- POLYORB.GIOP_P.TAGGED_COMPONENTS.CODE_SETS -- -- -- -- S p e c -- -- -- -- Copyright (C) 2004-2006 Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- TAG_CODE_SETS tagged component with PolyORB.GIOP_P.Code_Sets; package PolyORB.GIOP_P.Tagged_Components.Code_Sets is type Code_Set_Component is record Native_Code_Set : GIOP_P.Code_Sets.Code_Set_Id; Conversion_Code_Sets : GIOP_P.Code_Sets.Code_Set_Id_List; end record; type TC_Code_Sets is new Tagged_Component (Tag => Tag_Code_Sets, At_Most_Once => False) with record For_Char_Data : Code_Set_Component; For_Wchar_Data : Code_Set_Component; end record; -- Note: the at-most-once semantics of this component is not -- specified in the CORBA specification, par. 13.10.2.4, use -- default value. procedure Marshall_Component_Data (C : access TC_Code_Sets; Buffer : access Buffer_Type); procedure Unmarshall_Component_Data (C : access TC_Code_Sets; Buffer : access Buffer_Type; Error : out PolyORB.Errors.Error_Container); procedure Release_Contents (C : access TC_Code_Sets); function Duplicate (C : TC_Code_Sets) return Tagged_Component_Access; end PolyORB.GIOP_P.Tagged_Components.Code_Sets; polyorb-2.8~20110207.orig/src/giop/miop/0000755000175000017500000000000011750740340017073 5ustar xavierxavierpolyorb-2.8~20110207.orig/src/giop/miop/polyorb-setup-uipmc.adb0000644000175000017500000000566111750740340023512 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . S E T U P . U I P M C -- -- -- -- B o d y -- -- -- -- Copyright (C) 2003-2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ pragma Warnings (Off); -- No entities referenced. with PolyORB.Protocols.GIOP.GIOP_1_2; pragma Warnings (On); with PolyORB.Initialization; with PolyORB.Utils.Strings; package body PolyORB.Setup.UIPMC is use PolyORB.Smart_Pointers; ---------------- -- Initialize -- ---------------- procedure Initialize; procedure Initialize is begin UIPMC_GOA := new Group_Object_Adapter; Create (UIPMC_GOA); Set (UIPMC_GOA_Ref, Entity_Ptr (UIPMC_GOA)); end Initialize; use PolyORB.Initialization; use PolyORB.Initialization.String_Lists; use PolyORB.Utils.Strings; begin Register_Module (Module_Info' (Name => +"setup.uipmc", Conflicts => Empty, Depends => +"protocols.giop.giop_1_2" & "smart_pointers", Provides => Empty, Implicit => False, Init => Initialize'Access, Shutdown => null)); end PolyORB.Setup.UIPMC; polyorb-2.8~20110207.orig/src/giop/miop/polyorb-miop_p-groups.adb0000644000175000017500000000761611750740340024041 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . M I O P _ P . G R O U P S -- -- -- -- B o d y -- -- -- -- Copyright (C) 2003-2009, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with PolyORB.Buffers; with PolyORB.Representations.CDR.Common; package body PolyORB.MIOP_P.Groups is use PolyORB.Types; ----------- -- Image -- ----------- function Image (G_I : Group_Info) return String is begin return "Domain Id : " & To_Standard_String (G_I.Group_Domain_Id) & ", Object Group Id :" & G_I.Object_Group_Id'Img & ", Object Group Ref Version :" & G_I.Object_Group_Ref_Version'Img; end Image; ------------------ -- To_Object_Id -- ------------------ function To_Object_Id (G_I : Group_Info) return PolyORB.Objects.Object_Id_Access is use PolyORB.Buffers; use PolyORB.Objects; use PolyORB.Representations.CDR.Common; Buffer : Buffer_Access := new Buffer_Type; Oid : PolyORB.Objects.Object_Id_Access; begin Marshall (Buffer, G_I.Object_Group_Id); Marshall (Buffer, G_I.Object_Group_Ref_Version); Marshall (Buffer, Types.Identifier (G_I.Group_Domain_Id)); Oid := new Object_Id'(Object_Id (To_Stream_Element_Array (Buffer.all))); Release (Buffer); return Oid; end To_Object_Id; ------------------- -- To_Group_Info -- ------------------- function To_Group_Info (Oid : PolyORB.Objects.Object_Id_Access) return Group_Info is use PolyORB.Buffers; use PolyORB.Representations.CDR.Common; Buffer : Buffer_Access := new Buffer_Type; G_I : Group_Info; begin Initialize_Buffer (Buffer, Oid'Last, Oid (Oid'First)'Address, Host_Order, 0); G_I.Object_Group_Id := Unmarshall (Buffer); G_I.Object_Group_Ref_Version := Unmarshall (Buffer); G_I.Group_Domain_Id := Types.String (Types.Identifier'(Unmarshall (Buffer))); Release (Buffer); return G_I; end To_Group_Info; end PolyORB.MIOP_P.Groups; polyorb-2.8~20110207.orig/src/giop/miop/polyorb-filters-miop.adb0000644000175000017500000001674211750740340023653 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . F I L T E R S . M I O P -- -- -- -- B o d y -- -- -- -- Copyright (C) 2003-2009, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- MIOP stack headers function with PolyORB.Log; with PolyORB.Representations.CDR.Common; package body PolyORB.Filters.MIOP is use PolyORB.Buffers; use PolyORB.Log; use PolyORB.Representations.CDR.Common; package L is new PolyORB.Log.Facility_Log ("polyorb.filters.miop"); procedure O (Message : String; Level : Log_Level := Debug) renames L.Output; function C (Level : Log_Level := Debug) return Boolean renames L.Enabled; -- Unique Id counter Index_Unique_Id : Natural := 0; -------------------------- -- Marshall_MIOP_Header -- -------------------------- procedure Marshall_MIOP_Header (Buffer : access Buffers.Buffer_Type; Header : MIOP_Header) is use Octet_Flags; use PolyORB.Types; Flags : Types.Octet := 0; begin -- Magic for J in Magic'Range loop Marshall (Buffer, Types.Octet (Magic (J))); end loop; -- Version Flags := (MIOP_Minor_Version and 15) or ((MIOP_Major_Version and 15) * 16); Marshall (Buffer, Flags); -- Flags Set (Flags, Bit_Little_Endian, Header.Endianness = Little_Endian); Set (Flags, Bit_Collect_Mode, Header.Collect_Mode); Marshall (Buffer, Flags); pragma Assert (Endianness (Buffer) = Header.Endianness); -- Size Marshall (Buffer, Header.Packet_Size); -- Number Marshall (Buffer, Header.Packet_Number); -- Total Marshall (Buffer, Header.Packet_Total); -- Unique_Id Marshall (Buffer, Types.Identifier (Header.Unique_Id)); -- Final padding Pad_Align (Buffer, Align_8); end Marshall_MIOP_Header; ---------------------------- -- Unmarshall_MIOP_Header -- ---------------------------- procedure Unmarshall_MIOP_Header (Buffer : access Buffers.Buffer_Type; Header : out MIOP_Header) is use Octet_Flags; use PolyORB.Types; Flags : Types.Octet; Message_Magic : Stream_Element_Array (Magic'Range); begin -- Get Endianness Flags := Types.Octet (Peek (Buffer, Flags_Index)); if Is_Set (Bit_Little_Endian, Flags) then Set_Endianness (Buffer, Little_Endian); else Set_Endianness (Buffer, Big_Endian); end if; -- Begining of GIOP message is byte-ordering independent -- Magic for J in Message_Magic'Range loop Message_Magic (J) := Stream_Element (Types.Octet'(Unmarshall (Buffer))); end loop; if Message_Magic /= Magic then raise MIOP_Packet_Error; end if; -- Version if Types.Octet'(Unmarshall (Buffer)) /= (MIOP_Major_Version * 16 or MIOP_Minor_Version) then raise MIOP_Packet_Error; end if; pragma Debug (C, O ("MIOP Version OK")); -- Flags Flags := Unmarshall (Buffer); if Is_Set (Bit_Little_Endian, Flags) then Header.Endianness := Little_Endian; else Header.Endianness := Big_Endian; end if; pragma Assert (Header.Endianness = Endianness (Buffer)); pragma Debug (C, O ("Message Endianness : " & Header.Endianness'Img)); if Is_Set (Bit_Collect_Mode, Flags) then Header.Collect_Mode := True; else Header.Collect_Mode := False; end if; pragma Debug (C, O ("Collect Mode : " & Header.Collect_Mode'Img)); -- Extract size Header.Packet_Size := Unmarshall (Buffer); pragma Debug (C, O ("Packer Size :" & Header.Packet_Size'Img)); -- Extract Number Header.Packet_Number := Unmarshall (Buffer); pragma Debug (C, O ("Packet Number :" & Header.Packet_Number'Img)); -- Extract Total Header.Packet_Total := Unmarshall (Buffer); pragma Debug (C, O ("Packet Total :" & Header.Packet_Total'Img)); -- Unique_Id_Size, Unique Id will be extracted later Header.Unique_Id_Size := Unmarshall (Buffer); pragma Debug (C, O ("Unique Id Size :" & Header.Unique_Id_Size'Img)); end Unmarshall_MIOP_Header; -------------------------- -- Unmarshall_Unique_Id -- -------------------------- -- This function unmarshall unique id -- Unique_Id size must be known -- This is an adpatation of string unmarshalling function procedure Unmarshall_Unique_Id (Buffer : access Buffers.Buffer_Type; Length : Types.Unsigned_Long; Str : out Types.String) is use PolyORB.Types; Equiv : String (1 .. Integer (Length - 1)); begin if Length = 0 then Str := To_PolyORB_String (""); return; end if; for J in Equiv'Range loop Equiv (J) := Character'Val (PolyORB.Types.Char'Pos (Unmarshall_Latin_1_Char (Buffer))); end loop; -- A 0 must end the string if Character'Val (PolyORB.Types.Char'Pos (Unmarshall_Latin_1_Char (Buffer))) /= ASCII.NUL then raise Constraint_Error; end if; Str := To_PolyORB_String (Equiv); end Unmarshall_Unique_Id; ------------------------ -- Generate_Unique_Id -- ------------------------ function Generate_Unique_Id return Types.String is use PolyORB.Types; begin Index_Unique_Id := Index_Unique_Id + 1; return To_PolyORB_String ("PolyORB" & Index_Unique_Id'Img); end Generate_Unique_Id; end PolyORB.Filters.MIOP; polyorb-2.8~20110207.orig/src/giop/miop/polyorb-giop_p-transport_mechanisms-uipmc.adb0000644000175000017500000001747111750740340030072 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- POLYORB.GIOP_P.TRANSPORT_MECHANISMS.UIPMC -- -- -- -- B o d y -- -- -- -- Copyright (C) 2005-2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with PolyORB.Binding_Data.GIOP.UIPMC; with PolyORB.Binding_Objects; with PolyORB.Filters.MIOP.MIOP_Out; with PolyORB.ORB; with PolyORB.Parameters; with PolyORB.Protocols.GIOP.UIPMC; with PolyORB.Sockets; with PolyORB.Transport.Datagram.Sockets; package body PolyORB.GIOP_P.Transport_Mechanisms.UIPMC is use PolyORB.Components; use PolyORB.Errors; use PolyORB.Parameters; use PolyORB.Sockets; use PolyORB.Transport.Datagram.Sockets; use PolyORB.Utils.Sockets; ---------------- -- Address_Of -- ---------------- function Address_Of (M : UIPMC_Transport_Mechanism) return Utils.Sockets.Socket_Name is begin return M.Address.all; end Address_Of; -------------------- -- Bind_Mechanism -- -------------------- -- Factories Mou : aliased PolyORB.Filters.MIOP.MIOP_Out.MIOP_Out_Factory; Pro : aliased PolyORB.Protocols.GIOP.UIPMC.UIPMC_Protocol; MIOP_Factories : constant PolyORB.Filters.Factory_Array := (0 => Mou'Access, 1 => Pro'Access); procedure Bind_Mechanism (Mechanism : UIPMC_Transport_Mechanism; Profile : access PolyORB.Binding_Data.Profile_Type'Class; The_ORB : Components.Component_Access; QoS : PolyORB.QoS.QoS_Parameters; BO_Ref : out Smart_Pointers.Ref; Error : out Errors.Error_Container) is pragma Unreferenced (QoS); use PolyORB.Binding_Data; use PolyORB.Binding_Objects; Sock : Socket_Type; TTL : constant Natural := Natural (Get_Conf ("miop", "polyorb.miop.ttl", Default_TTL)); TE : Transport.Transport_Endpoint_Access; begin if Profile.all not in PolyORB.Binding_Data.GIOP.UIPMC.UIPMC_Profile_Type then Throw (Error, Comm_Failure_E, System_Exception_Members' (Minor => 0, Completed => Completed_Maybe)); return; end if; Create_Socket (Socket => Sock, Family => Family_Inet, Mode => Socket_Datagram); Set_Socket_Option (Sock, Socket_Level, (Reuse_Address, True)); Set_Socket_Option (Sock, IP_Protocol_For_IP_Level, (Multicast_TTL, TTL)); TE := new Socket_Endpoint; Create (Socket_Endpoint (TE.all), Sock, To_Address (Mechanism.Address.all)); Binding_Objects.Setup_Binding_Object (The_ORB, TE, MIOP_Factories, BO_Ref, Profile_Access (Profile)); ORB.Register_Binding_Object (ORB.ORB_Access (The_ORB), BO_Ref, ORB.Client); exception when Sockets.Socket_Error => Throw (Error, Comm_Failure_E, System_Exception_Members' (Minor => 0, Completed => Completed_Maybe)); end Bind_Mechanism; -------------------- -- Create_Factory -- -------------------- procedure Create_Factory (MF : out UIPMC_Transport_Mechanism_Factory; TAP : Transport.Transport_Access_Point_Access) is begin MF.Address := new Socket_Name'(Address_Of (Socket_Access_Point (TAP.all))); end Create_Factory; ------------------------------ -- Create_Tagged_Components -- ------------------------------ function Create_Tagged_Components (MF : UIPMC_Transport_Mechanism_Factory) return Tagged_Components.Tagged_Component_List is pragma Unreferenced (MF); begin return Tagged_Components.Null_Tagged_Component_List; end Create_Tagged_Components; -------------------------------- -- Create_Transport_Mechanism -- -------------------------------- function Create_Transport_Mechanism (MF : UIPMC_Transport_Mechanism_Factory) return Transport_Mechanism_Access is Result : constant Transport_Mechanism_Access := new UIPMC_Transport_Mechanism; TResult : UIPMC_Transport_Mechanism renames UIPMC_Transport_Mechanism (Result.all); begin TResult.Address := new Socket_Name'(MF.Address.all); return Result; end Create_Transport_Mechanism; function Create_Transport_Mechanism (Address : Utils.Sockets.Socket_Name) return Transport_Mechanism_Access is Result : constant Transport_Mechanism_Access := new UIPMC_Transport_Mechanism; TResult : UIPMC_Transport_Mechanism renames UIPMC_Transport_Mechanism (Result.all); begin TResult.Address := new Socket_Name'(Address); return Result; end Create_Transport_Mechanism; ------------------------ -- Is_Local_Mechanism -- ------------------------ function Is_Local_Mechanism (MF : access UIPMC_Transport_Mechanism_Factory; M : access Transport_Mechanism'Class) return Boolean is begin return M.all in UIPMC_Transport_Mechanism and then UIPMC_Transport_Mechanism (M.all).Address.all = MF.Address.all; end Is_Local_Mechanism; ---------------------- -- Release_Contents -- ---------------------- procedure Release_Contents (M : access UIPMC_Transport_Mechanism) is begin Free (M.Address); end Release_Contents; --------------- -- Duplicate -- --------------- function Duplicate (TMA : UIPMC_Transport_Mechanism) return UIPMC_Transport_Mechanism is begin return UIPMC_Transport_Mechanism' (Address => new Socket_Name'(TMA.Address.all)); end Duplicate; ------------------ -- Is_Colocated -- ------------------ function Is_Colocated (Left : UIPMC_Transport_Mechanism; Right : Transport_Mechanism'Class) return Boolean is begin return Right in UIPMC_Transport_Mechanism and then Left.Address = UIPMC_Transport_Mechanism (Right).Address; end Is_Colocated; end PolyORB.GIOP_P.Transport_Mechanisms.UIPMC; polyorb-2.8~20110207.orig/src/giop/miop/polyorb-giop_p-transport_mechanisms-uipmc.ads0000644000175000017500000001051111750740340030077 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- POLYORB.GIOP_P.TRANSPORT_MECHANISMS.UIPMC -- -- -- -- S p e c -- -- -- -- Copyright (C) 2005-2008, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with PolyORB.Utils.Sockets; package PolyORB.GIOP_P.Transport_Mechanisms.UIPMC is type UIPMC_Transport_Mechanism is new Transport_Mechanism with private; procedure Bind_Mechanism (Mechanism : UIPMC_Transport_Mechanism; Profile : access PolyORB.Binding_Data.Profile_Type'Class; The_ORB : Components.Component_Access; QoS : PolyORB.QoS.QoS_Parameters; BO_Ref : out Smart_Pointers.Ref; Error : out Errors.Error_Container); procedure Release_Contents (M : access UIPMC_Transport_Mechanism); -- UIPMC Transport Mechanism specific subprograms function Address_Of (M : UIPMC_Transport_Mechanism) return Utils.Sockets.Socket_Name; -- Return address of transport mechanism's transport access point. type UIPMC_Transport_Mechanism_Factory is new Transport_Mechanism_Factory with private; procedure Create_Factory (MF : out UIPMC_Transport_Mechanism_Factory; TAP : Transport.Transport_Access_Point_Access); function Is_Local_Mechanism (MF : access UIPMC_Transport_Mechanism_Factory; M : access Transport_Mechanism'Class) return Boolean; function Create_Tagged_Components (MF : UIPMC_Transport_Mechanism_Factory) return Tagged_Components.Tagged_Component_List; -- UIPMC Transport Mechanism Factory specific subprograms function Create_Transport_Mechanism (MF : UIPMC_Transport_Mechanism_Factory) return Transport_Mechanism_Access; -- Create transport mechanism function Create_Transport_Mechanism (Address : Utils.Sockets.Socket_Name) return Transport_Mechanism_Access; -- Create transport mechanism for specified transport access point address function Duplicate (TMA : UIPMC_Transport_Mechanism) return UIPMC_Transport_Mechanism; function Is_Colocated (Left : UIPMC_Transport_Mechanism; Right : Transport_Mechanism'Class) return Boolean; private -- Default TTL value Default_TTL : constant Natural := 15; type UIPMC_Transport_Mechanism is new Transport_Mechanism with record Address : Utils.Sockets.Socket_Name_Ptr; end record; type UIPMC_Transport_Mechanism_Factory is new Transport_Mechanism_Factory with record Address : Utils.Sockets.Socket_Name_Ptr; end record; end PolyORB.GIOP_P.Transport_Mechanisms.UIPMC; polyorb-2.8~20110207.orig/src/giop/miop/polyorb-setup-uipmc.ads0000644000175000017500000000447011750740340023530 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . S E T U P . U I P M C -- -- -- -- S p e c -- -- -- -- Copyright (C) 2003 Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by ACT Europe. -- -- (email: sales@act-europe.fr) -- -- -- ------------------------------------------------------------------------------ with PolyORB.Obj_Adapters.Group_Object_Adapter; with PolyORB.Smart_Pointers; package PolyORB.Setup.UIPMC is pragma Elaborate_Body; use PolyORB.Obj_Adapters.Group_Object_Adapter; UIPMC_GOA : Group_Object_Adapter_Access; UIPMC_GOA_Ref : PolyORB.Smart_Pointers.Ref; end PolyORB.Setup.UIPMC; polyorb-2.8~20110207.orig/src/giop/miop/polyorb-miop_p.ads0000644000175000017500000000423411750740340022536 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . M I O P _ P -- -- -- -- S p e c -- -- -- -- Copyright (C) 2003 Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by ACT Europe. -- -- (email: sales@act-europe.fr) -- -- -- ------------------------------------------------------------------------------ -- The root of all PolyORB packages that are specific to the -- MIOP personality. package PolyORB.MIOP_P is pragma Pure; end PolyORB.MIOP_P; polyorb-2.8~20110207.orig/src/giop/miop/polyorb-binding_data-giop-uipmc.ads0000644000175000017500000000741211750740340025726 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . B I N D I N G _ D A T A . G I O P . U I P M C -- -- -- -- S p e c -- -- -- -- Copyright (C) 2003-2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- Binding data concrete implementation for UIPMC with PolyORB.Buffers; with PolyORB.MIOP_P.Groups; with PolyORB.Types; package PolyORB.Binding_Data.GIOP.UIPMC is use PolyORB.Buffers; MIOP_Error : exception; type UIPMC_Profile_Type is new GIOP_Profile_Type with private; type UIPMC_Profile_Factory is new GIOP_Profile_Factory with private; function Create_Profile (PF : access UIPMC_Profile_Factory; Oid : Objects.Object_Id) return Profile_Access; function Duplicate_Profile (P : UIPMC_Profile_Type) return Profile_Access; function Get_Profile_Tag (Profile : UIPMC_Profile_Type) return Profile_Tag; pragma Inline (Get_Profile_Tag); function Get_Profile_Preference (Profile : UIPMC_Profile_Type) return Profile_Preference; pragma Inline (Get_Profile_Preference); procedure Create_Factory (PF : out UIPMC_Profile_Factory; TAP : Transport.Transport_Access_Point_Access; ORB : Components.Component_Access); procedure Marshall_UIPMC_Profile_Body (Buf : access Buffer_Type; Profile : Profile_Access); function Unmarshall_UIPMC_Profile_Body (Buffer : access Buffer_Type) return Profile_Access; function Image (Prof : UIPMC_Profile_Type) return String; function Get_OA (Profile : UIPMC_Profile_Type) return PolyORB.Smart_Pointers.Entity_Ptr; pragma Inline (Get_OA); private -- UIPMC version UIPMC_Version_Major : constant Types.Octet := 1; UIPMC_Version_Minor : constant Types.Octet := 0; type UIPMC_Profile_Type is new GIOP_Profile_Type with record G_I : PolyORB.MIOP_P.Groups.Group_Info_Access; end record; type UIPMC_Profile_Factory is new GIOP_Profile_Factory with null record; end PolyORB.Binding_Data.GIOP.UIPMC; polyorb-2.8~20110207.orig/src/giop/miop/polyorb-filters-miop-miop_in.adb0000644000175000017500000003014311750740340025272 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . F I L T E R S . M I O P . M I O P _ I N -- -- -- -- B o d y -- -- -- -- Copyright (C) 2003-2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- MIOP filter for data which arrive from network to ORB -- this filter MUST be under a GIOP Session with PolyORB.Filters.Iface; with PolyORB.Log; with PolyORB.Protocols.GIOP; package body PolyORB.Filters.MIOP.MIOP_In is use PolyORB.Buffers; use PolyORB.Components; use PolyORB.Filters.Iface; use PolyORB.Log; use PolyORB.Protocols.GIOP; package L is new PolyORB.Log.Facility_Log ("polyorb.filters.miop.miop_in"); procedure O (Message : String; Level : Log_Level := Debug) renames L.Output; function C (Level : Log_Level := Debug) return Boolean renames L.Enabled; ------------ -- Create -- ------------ procedure Create (Fact : access MIOP_In_Factory; MIOP_In : out Filter_Access) is pragma Warnings (Off); pragma Unreferenced (Fact); pragma Warnings (On); Res : constant Filter_Access := new MIOP_In_Filter; begin MIOP_In_Filter (Res.all).In_Buf := null; MIOP_In_Filter (Res.all).MIOP_Buf := new Buffer_Type; MIOP_In := Res; end Create; -------------------- -- Handle_Message -- -------------------- function Handle_Message (F : not null access MIOP_In_Filter; S : Components.Message'Class) return Components.Message'Class is use PolyORB.Types; begin if S in Data_Indication then case F.State is when Wait_MIOP_Header => -- MIOP header received -- read MIOP header and unique id length Unmarshall_MIOP_Header (F.MIOP_Buf, F.Header); F.State := Wait_Unique_Id; pragma Debug (C, O ("Wait for Unique Id, size : " & F.Header.Unique_Id_Size'Img)); -- Calculate length to read, unique id length + 8 bytes padding declare N : Stream_Element_Count := Stream_Element_Count (F.Header.Unique_Id_Size + Types.Unsigned_Long (MIOP_Header_Size)); begin -- Round up N to nearest greater multiple of 8 N := ((N + 7) / 8) * 8; -- Compute payload size F.Payload := F.Header.Packet_Size - Types.Unsigned_Short (N); pragma Debug (C, O ("Packet payload : " & F.Payload'Img)); -- Compute data length of unique id + padding N := N - MIOP_Header_Size; return Emit (F.Lower, Data_Expected'(In_Buf => F.MIOP_Buf, Max => N)); end; when Wait_Unique_Id => -- Unique id received Unmarshall_Unique_Id (F.MIOP_Buf, F.Header.Unique_Id_Size, F.Header.Unique_Id); pragma Debug (C, O ("Unique Id : " & To_Standard_String (F.Header.Unique_Id))); Release_Contents (F.MIOP_Buf.all); F.State := Wait_GIOP_Data; if F.Fragment then -- Check whether the received packet is the expected one if not (F.Header.Collect_Mode and then F.Header.Unique_Id = F.Old_Header.Unique_Id and then F.Header.Packet_Total = F.Old_Header.Packet_Total and then F.Header.Packet_Number = F.Old_Header.Packet_Number + 1) then -- XXX error if a packet is missing raise MIOP_Packet_Error; end if; -- Check size if last fragment pragma Assert (F.Header.Packet_Number + 1 /= F.Header.Packet_Total or else Stream_Element_Offset (F.Payload) = F.Data_Exp); -- Ask for next fragment return Emit (F.Lower, Data_Expected' (In_Buf => F.In_Buf, Max => Stream_Element_Offset (F.Payload))); else -- No fragment, ask for data return Emit (F.Lower, Data_Expected'(In_Buf => F.In_Buf, Max => F.Data_Exp)); end if; when Wait_GIOP_Data => -- GIOP data received if not F.Fragment and then F.Initial_Data_Exp = Remaining (F.In_Buf) - F.Initial_Remain then -- Data reception complete pragma Debug (C, O ("Send asked data to upper filter")); F.Payload := F.Payload - Types.Unsigned_Short (F.Data_Exp); F.State := Wait_GIOP_Ask; return Emit (F.Upper, S); elsif F.Fragment and then F.Header.Packet_Number + 1 = F.Header.Packet_Total then -- All fragments received pragma Debug (C, O ("Fragment received, number" & F.Header.Packet_Number'Img & " /" & Types.Unsigned_Long (F.Header.Packet_Total - 1)'Img & ", size :" & F.Header.Packet_Size'Img & ", payload :" & F.Payload'Img)); F.Fragment := False; pragma Debug (C, O ("Send asked data to upper filter")); F.State := Wait_GIOP_Ask; return Emit (F.Upper, S); else if not F.Header.Collect_Mode then -- XXX error if a packet is missing raise MIOP_Packet_Error; end if; -- Some fragments left, ask for next pragma Assert (F.Initial_Data_Exp >= Remaining (F.In_Buf) - F.Initial_Remain); begin F.Data_Exp := F.Data_Exp - Stream_Element_Offset (F.Payload); exception when Constraint_Error => raise MIOP_Packet_Error; end; pragma Debug (C, O ("Fragment received, number" & F.Header.Packet_Number'Img & " /" & Types.Unsigned_Long (F.Header.Packet_Total - 1)'Img & ", size :" & F.Header.Packet_Size'Img & ", payload :" & F.Payload'Img)); pragma Debug (C, O ("Bytes left to receive:" & F.Data_Exp'Img)); F.Fragment := True; F.Old_Header := F.Header; F.State := Wait_MIOP_Header; pragma Debug (C, O ("Wait for MIOP Header")); return Emit (F.Lower, Data_Expected' (In_Buf => F.MIOP_Buf, Max => MIOP_Header_Size)); end if; when others => raise MIOP_Packet_Error; end case; elsif S in GIOP_Data_Expected then declare D : GIOP_Data_Expected renames GIOP_Data_Expected (S); begin F.In_Buf := D.In_Buf; F.Data_Exp := D.Max; F.Initial_Data_Exp := D.Max; F.Initial_Remain := Remaining (F.In_Buf); case F.State is when Wait_For_GIOP_Layer => -- GIOP layer ask for next packet pragma Assert (D.State = Expect_Header); F.State := Wait_MIOP_Header; pragma Debug (C, O ("Wait for MIOP Header")); return Emit (F.Lower, Data_Expected' (In_Buf => F.MIOP_Buf, Max => MIOP_Header_Size)); when Wait_GIOP_Ask => if D.State = Expect_Header then -- GIOP layer ask for next packet F.State := Wait_MIOP_Header; pragma Debug (C, O ("Wait for MIOP Header")); return Emit (F.Lower, Data_Expected' (In_Buf => F.MIOP_Buf, Max => MIOP_Header_Size)); else -- GIOP layer ask for data pragma Debug (C, O ("Upper requests" & F.Data_Exp'Img & " bytes")); F.State := Wait_GIOP_Data; -- Test if requested data are in the current packet if F.Data_Exp > Stream_Element_Offset (F.Payload) then -- Not all data are here, fragment mode needed if not F.Header.Collect_Mode then raise MIOP_Packet_Error; end if; return Emit (F.Lower, Data_Expected' (In_Buf => F.In_Buf, Max => Stream_Element_Offset (F.Payload))); else -- No fragment, data are in packet return Emit (F.Lower, Data_Expected' (In_Buf => F.In_Buf, Max => F.Data_Exp)); end if; end if; when others => raise MIOP_Packet_Error; end case; end; else return Filters.Handle_Message (Filters.Filter (F.all)'Access, S); end if; end Handle_Message; end PolyORB.Filters.MIOP.MIOP_In; polyorb-2.8~20110207.orig/src/giop/miop/polyorb-filters-miop.ads0000644000175000017500000001077111750740340023670 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . F I L T E R S . M I O P -- -- -- -- S p e c -- -- -- -- Copyright (C) 2003-2008, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- MIOP stack headers function with Ada.Streams; use Ada.Streams; with PolyORB.Buffers; with PolyORB.Types; with PolyORB.Utils.Simple_Flags; package PolyORB.Filters.MIOP is MIOP_Packet_Error : exception; -- MIOP Header type type MIOP_Header is private; type MIOP_Header_Access is access MIOP_Header; private package Octet_Flags is new PolyORB.Utils.Simple_Flags (Types.Octet, Types.Shift_Left); -- Default max MIOP packet size used to fragment Default_Max_MIOP_Message_Size : constant Integer := 1000; -- Location of flags in MIOP packet Flags_Index : constant Stream_Element_Offset := 6 - 1; -- Note: Flags is at 6th position in MIOP 1.0 PacketHeader -- structure, hence at index 6 - 1. Bit_Little_Endian : constant Octet_Flags.Bit_Count := 0; Bit_Collect_Mode : constant Octet_Flags.Bit_Count := 1; -- MIOP header size (with only the size of Unique Id) MIOP_Header_Size : constant Stream_Element_Count := 20; -- Magic identifier -- Begin of all MIOP Messages Magic : constant Stream_Element_Array (1 .. 4) := (Character'Pos ('M'), Character'Pos ('I'), Character'Pos ('O'), Character'Pos ('P')); -- MIOP Version MIOP_Major_Version : constant Types.Octet := 1; MIOP_Minor_Version : constant Types.Octet := 0; -- MIOP Header type MIOP_Header is record -- Packet endianness Endianness : Buffers.Endianness_Type := PolyORB.Buffers.Host_Order; -- Fragmenting mode Collect_Mode : Boolean; -- Packet Size Packet_Size : Types.Unsigned_Short; -- Packet Number in Collection Packet_Number : Types.Unsigned_Long := 0; -- Number of Packet in Collection Packet_Total : Types.Unsigned_Long := 0; -- Unique Id of Collection Unique_Id : Types.String; -- Unique Id string size Unique_Id_Size : Types.Unsigned_Long; end record; -- Marshall MIOP Header procedure Marshall_MIOP_Header (Buffer : access Buffers.Buffer_Type; Header : MIOP_Header); -- Unmarshall MIOP Header procedure Unmarshall_MIOP_Header (Buffer : access Buffers.Buffer_Type; Header : out MIOP_Header); -- Unmarshall Unique Id procedure Unmarshall_Unique_Id (Buffer : access Buffers.Buffer_Type; Length : Types.Unsigned_Long; Str : out Types.String); -- Generate a new Unique Id function Generate_Unique_Id return Types.String; end PolyORB.Filters.MIOP; polyorb-2.8~20110207.orig/src/giop/miop/polyorb-filters-miop-miop_out.adb0000644000175000017500000002201011750740340025465 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . F I L T E R S . M I O P . M I O P _ O U T -- -- -- -- B o d y -- -- -- -- Copyright (C) 2003-2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- MIOP filter for data which arrive from a GIOP Session with PolyORB.Filters.Iface; with PolyORB.Log; with PolyORB.Parameters; with PolyORB.Representations.CDR.Common; with PolyORB.Types; package body PolyORB.Filters.MIOP.MIOP_Out is use PolyORB.Buffers; use PolyORB.Components; use PolyORB.Filters.Iface; use PolyORB.Log; package L is new PolyORB.Log.Facility_Log ("polyorb.filters.miop.miop_out"); procedure O (Message : String; Level : Log_Level := Debug) renames L.Output; function C (Level : Log_Level := Debug) return Boolean renames L.Enabled; ------------ -- Create -- ------------ procedure Create (Fact : access MIOP_Out_Factory; MIOP_Out : out Filter_Access) is pragma Warnings (Off); pragma Unreferenced (Fact); pragma Warnings (On); use PolyORB.Parameters; Res : constant Filter_Access := new MIOP_Out_Filter; begin MIOP_Out_Filter (Res.all).MIOP_Buff := new Buffer_Type; -- read the max MIOP packet size in conf file MIOP_Out_Filter (Res.all).Max_Size := Types.Unsigned_Short (Get_Conf ("miop", "polyorb.miop.max_message_size", Default_Max_MIOP_Message_Size)); MIOP_Out := Res; end Create; ---------- -- Copy -- ---------- -- Copy data between two buffer procedure Copy (From : access Buffer_Type; To : access Buffer_Type; Len : Types.Unsigned_Short); pragma Inline (Copy); procedure Copy (From : access Buffer_Type; To : access Buffer_Type; Len : Types.Unsigned_Short) is use PolyORB.Representations.CDR.Common; Temp : Types.Octet; begin for J in 1 .. Integer (Len) loop Temp := Unmarshall (From); Marshall (To, Temp); end loop; end Copy; -------------------- -- Handle_Message -- -------------------- function Handle_Message (F : not null access MIOP_Out_Filter; S : Components.Message'Class) return Components.Message'Class is use PolyORB.Types; Res : Components.Null_Message; begin if S in Data_Out then -- the GIOP layer MUST send only one Data_Out for each GIOP packet declare D : Data_Out renames Data_Out (S); -- Length of GIOP packet L : constant Types.Unsigned_Short := Types.Unsigned_Short (Length (D.Out_Buf.all)); H : MIOP_Header; begin pragma Debug (C, O ("Encapsulate GIOP data in a MIOP Packet," & L'Img & " bytes")); -- Create the request Unique Id H.Unique_Id := Generate_Unique_Id; pragma Debug (C, O ("Unique Id :" & To_Standard_String (H.Unique_Id))); -- Calculate the packet size H.Packet_Size := Types.Unsigned_Short (MIOP_Header_Size) + Types.Unsigned_Short (Length (H.Unique_Id) + 1); while (H.Packet_Size mod 8) /= 0 loop H.Packet_Size := H.Packet_Size + 1; end loop; -- Rewind GIOP Buffer before copying data Rewind (D.Out_Buf); -- Test if packet need to be fragmented if H.Packet_Size + L <= F.Max_Size then -- Normal packet, no fragmentation H.Packet_Size := H.Packet_Size + L; H.Collect_Mode := False; H.Packet_Number := 0; H.Packet_Total := 1; -- Create MIOP packet Marshall_MIOP_Header (F.MIOP_Buff, H); Copy (D.Out_Buf, F.MIOP_Buff, L); -- Size check pragma Assert (Types.Unsigned_Short (CDR_Position (F.MIOP_Buff)) = H.Packet_Size); pragma Debug (C, O ("Send MIOP Message, size : " & H.Packet_Size'Img)); -- Send packet Emit_No_Reply (F.Lower, Data_Out'(Out_Buf => F.MIOP_Buff)); Release_Contents (F.MIOP_Buff.all); else -- Fragmenting data declare -- Header size for all packets Header_Size : constant Types.Unsigned_Short := H.Packet_Size; -- Number of fragment Packet_Total : Types.Unsigned_Short := L / (F.Max_Size - Header_Size); begin if L mod (F.Max_Size - Header_Size) /= 0 then Packet_Total := Packet_Total + 1; end if; pragma Debug (C, O ("Fragmenting MIOP packet, size : " & Types.Unsigned_Short (Header_Size + L)'Img & ", need " & Packet_Total'Img & " packets, max " & Types.Unsigned_Short (F.Max_Size - Header_Size)'Img & " bytes per packet")); -- Prepare Header Data H.Collect_Mode := True; H.Packet_Total := Types.Unsigned_Long (Packet_Total); for J in 0 .. Packet_Total - 1 loop H.Packet_Number := Types.Unsigned_Long (J); if J /= (Packet_Total - 1) then H.Packet_Size := F.Max_Size; else H.Packet_Size := Types.Unsigned_Short (Remaining (D.Out_Buf)) + Header_Size; end if; -- Prepare fragment Marshall_MIOP_Header (F.MIOP_Buff, H); Copy (D.Out_Buf, F.MIOP_Buff, H.Packet_Size - Header_Size); pragma Debug (C, O ("Send MIOP Fragment, number :" & H.Packet_Number'Img & ", size :" & H.Packet_Size'Img & ", payload :" & Stream_Element_Offset (H.Packet_Size - Header_Size)'Img)); -- Size check pragma Assert (Types.Unsigned_Short (CDR_Position (F.MIOP_Buff)) = H.Packet_Size); -- Send fragment Emit_No_Reply (F.Lower, Data_Out'(Out_Buf => F.MIOP_Buff)); Release_Contents (F.MIOP_Buff.all); end loop; end; end if; end; else return Filters.Handle_Message (Filters.Filter (F.all)'Access, S); end if; return Res; end Handle_Message; end PolyORB.Filters.MIOP.MIOP_Out; polyorb-2.8~20110207.orig/src/giop/miop/polyorb-binding_data-giop-uipmc.adb0000644000175000017500000003773711750740340025722 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . B I N D I N G _ D A T A . G I O P . U I P M C -- -- -- -- B o d y -- -- -- -- Copyright (C) 2003-2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- Binding data concrete implementation for MIOP with PolyORB.Binding_Data.GIOP.INET; with PolyORB.GIOP_P.Tagged_Components; with PolyORB.GIOP_P.Transport_Mechanisms.UIPMC; with PolyORB.Initialization; with PolyORB.Log; with PolyORB.MIOP_P.Tagged_Components; with PolyORB.Obj_Adapters; with PolyORB.Parameters; with PolyORB.References.Corbaloc; with PolyORB.References.IOR; with PolyORB.Servants; with PolyORB.Servants.Group_Servants; with PolyORB.Sockets; with PolyORB.Utils.Strings; with PolyORB.Utils.Sockets; with PolyORB.Setup.UIPMC; package body PolyORB.Binding_Data.GIOP.UIPMC is use PolyORB.Binding_Data.GIOP.INET; use PolyORB.GIOP_P.Transport_Mechanisms; use PolyORB.GIOP_P.Transport_Mechanisms.UIPMC; use PolyORB.Log; use PolyORB.Objects; use PolyORB.MIOP_P.Groups; use PolyORB.References.Corbaloc; use PolyORB.References.IOR; use PolyORB.Types; use PolyORB.Utils.Sockets; package L is new PolyORB.Log.Facility_Log ("polyorb.binding_data.giop.uipmc"); procedure O (Message : Standard.String; Level : Log_Level := Debug) renames L.Output; function C (Level : Log_Level := Debug) return Boolean renames L.Enabled; UIPMC_Corbaloc_Prefix : constant String := "miop"; Preference : Profile_Preference; -- Global variable: the preference to be returned -- by Get_Profile_Preference for UIPMC profiles. function Profile_To_Corbaloc (P : Profile_Access) return String; function Corbaloc_To_Profile (Str : String) return Profile_Access; --------------------- -- Get_Profile_Tag -- --------------------- function Get_Profile_Tag (Profile : UIPMC_Profile_Type) return Profile_Tag is pragma Unreferenced (Profile); begin return Tag_UIPMC; end Get_Profile_Tag; ---------------------------- -- Get_Profile_Preference -- ---------------------------- function Get_Profile_Preference (Profile : UIPMC_Profile_Type) return Profile_Preference is pragma Unreferenced (Profile); begin return Preference; end Get_Profile_Preference; -------------------- -- Create_Factory -- -------------------- procedure Create_Factory (PF : out UIPMC_Profile_Factory; TAP : Transport.Transport_Access_Point_Access; ORB : Components.Component_Access) is pragma Unreferenced (ORB); MF : constant Transport_Mechanism_Factory_Access := new UIPMC_Transport_Mechanism_Factory; begin Create_Factory (MF.all, TAP); Append (PF.Mechanisms, MF); end Create_Factory; -------------------- -- Create_Profile -- -------------------- function Create_Profile (PF : access UIPMC_Profile_Factory; Oid : Objects.Object_Id) return Profile_Access is use PolyORB.Errors; use PolyORB.GIOP_P.Tagged_Components; use PolyORB.MIOP_P.Tagged_Components; use PolyORB.Obj_Adapters; use PolyORB.Servants; use PolyORB.Servants.Group_Servants; GS : PolyORB.Servants.Servant_Access; Error : Error_Container; Oid_Access : Object_Id_Access := new Object_Id'(Oid); begin Find_Servant (Obj_Adapter_Access (PolyORB.Setup.UIPMC.UIPMC_GOA), Oid_Access, GS, Error); if Found (Error) then Free (Oid_Access); return null; end if; Get_Group_Object_Id (GS, Oid_Access, Error); if Found (Error) or else Oid /= Oid_Access.all then Free (Oid_Access); return null; end if; declare Result : constant Profile_Access := new UIPMC_Profile_Type; TResult : UIPMC_Profile_Type renames UIPMC_Profile_Type (Result.all); TC_G_I : TC_Group_Info_Access := new TC_Group_Info; begin TResult.Version_Major := UIPMC_Version_Major; -- We force Version_Minor to 2 to match MIOP specifications -- that requires MIOP 1.0 profile to be conformant with GIOP -- 1.2. TResult.Version_Minor := 2; TResult.Object_Id := Oid_Access; TResult.Components := Null_Tagged_Component_List; -- Create transport mechanism Append (TResult.Mechanisms, Create_Transport_Mechanism (UIPMC_Transport_Mechanism_Factory (Element (PF.Mechanisms, 0).all.all))); TC_G_I.G_I := To_Group_Info (Oid_Access); TResult.G_I := TC_G_I.G_I'Access; -- Add specific tagged component of type Tag_Group Add (TResult.Components, Tagged_Component_Access (TC_G_I)); return Result; end; end Create_Profile; ----------------------- -- Duplicate_Profile -- ----------------------- function Duplicate_Profile (P : UIPMC_Profile_Type) return Profile_Access is Result : constant Profile_Access := new UIPMC_Profile_Type; TResult : UIPMC_Profile_Type renames UIPMC_Profile_Type (Result.all); begin TResult.Version_Major := P.Version_Major; TResult.Version_Minor := P.Version_Minor; TResult.Object_Id := new Object_Id'(P.Object_Id.all); TResult.Components := PolyORB.GIOP_P.Tagged_Components.Deep_Copy (P.Components); TResult.Mechanisms := Deep_Copy (P.Mechanisms); TResult.G_I := new PolyORB.MIOP_P.Groups.Group_Info'(P.G_I.all); return Result; end Duplicate_Profile; --------------------------------- -- Marshall_UIPMC_Profile_Body -- --------------------------------- procedure Marshall_UIPMC_Profile_Body (Buf : access Buffer_Type; Profile : Profile_Access) is begin Common_Marshall_Profile_Body (Buf, Profile, Address_Of (UIPMC_Transport_Mechanism (Element (UIPMC_Profile_Type (Profile.all).Mechanisms, 0).all.all)), False); end Marshall_UIPMC_Profile_Body; ----------------------------------- -- Unmarshall_UIPMC_Profile_Body -- ----------------------------------- function Unmarshall_UIPMC_Profile_Body (Buffer : access Buffer_Type) return Profile_Access is use PolyORB.GIOP_P.Tagged_Components; use PolyORB.MIOP_P.Tagged_Components; Result : Profile_Access := new UIPMC_Profile_Type; TResult : UIPMC_Profile_Type renames UIPMC_Profile_Type (Result.all); Address : constant Utils.Sockets.Socket_Name := Common_Unmarshall_Profile_Body (Buffer, Result, Unmarshall_Object_Id => False, Unmarshall_Tagged_Components => True); Temp_Ref : Tagged_Component_Access; begin pragma Debug (C, O ("Unmarshall_UIPMC_Profile_body: enter")); -- Create transport mechanism Append (UIPMC_Profile_Type (Result.all).Mechanisms, Create_Transport_Mechanism (Address)); if TResult.Version_Major /= UIPMC_Version_Major then Destroy_Profile (Result); raise MIOP_Error; end if; -- We force Version_Minor to 2 to match MIOP specifications -- that requires MIOP 1.0 profile to be conformant with GIOP -- 1.2. TResult.Version_Minor := 2; Temp_Ref := Get_Component (TResult.Components, Tag_Group); if Temp_Ref = null then Destroy_Profile (Result); return null; end if; TResult.G_I := TC_Group_Info_Access (Temp_Ref).G_I'Access; TResult.Object_Id := To_Object_Id (TResult.G_I.all); pragma Debug (C, O ("Unmarshall_UIPMC_Profile_body: leave")); return Result; end Unmarshall_UIPMC_Profile_Body; ------------------------- -- Profile_To_Corbaloc -- ------------------------- function Profile_To_Corbaloc (P : Profile_Access) return String is use PolyORB.GIOP_P.Tagged_Components; use PolyORB.MIOP_P.Tagged_Components; use PolyORB.Sockets; use PolyORB.Utils; UIPMC_Profile : UIPMC_Profile_Type renames UIPMC_Profile_Type (P.all); TC_G_I : constant Tagged_Component_Access := Get_Component (UIPMC_Profile.Components, Tag_Group); begin pragma Debug (C, O ("UIPMC Profile to corbaloc")); if TC_G_I = null then return ""; end if; declare S : constant String := To_String (TC_Group_Info_Access (TC_G_I)); begin if S = "" then return ""; end if; -- Note: we force Version_Minor to 0 to match MIOP -- specifications that requires MIOP 1.0 profile to be -- conformant with GIOP 1.2. return UIPMC_Corbaloc_Prefix & ":" & Trimmed_Image (Unsigned_Long_Long (UIPMC_Profile.Version_Major)) & "." & Trimmed_Image (Unsigned_Long_Long (0)) & "@" & S & "/" & Image (Address_Of (UIPMC_Transport_Mechanism (Element (UIPMC_Profile.Mechanisms, 0).all.all))); end; end Profile_To_Corbaloc; ------------------------- -- Corbaloc_To_Profile -- ------------------------- function Corbaloc_To_Profile (Str : String) return Profile_Access is use PolyORB.GIOP_P.Tagged_Components; use PolyORB.MIOP_P.Tagged_Components; use PolyORB.Utils; Result : Profile_Access := new UIPMC_Profile_Type; TResult : UIPMC_Profile_Type renames UIPMC_Profile_Type (Result.all); Host_First, Host_Last : Natural; Port : Sockets.Port_Type; S : String renames Str; Index : Integer := S'First; Index2 : Integer; Temp_Ref : TC_Group_Info_Access; begin pragma Debug (C, O ("UIPMC corbaloc to profile: enter")); Index2 := Find (S, Index, '.'); if Index2 = S'Last + 1 then Destroy_Profile (Result); return null; end if; TResult.Version_Major := Types.Octet'Value (S (Index .. Index2 - 1)); if TResult.Version_Major /= UIPMC_Version_Major then Destroy_Profile (Result); return null; end if; Index := Index2 + 1; Index2 := Find (S, Index, '@'); if Index2 = S'Last + 1 then Destroy_Profile (Result); return null; end if; TResult.Version_Minor := Types.Octet'Value (S (Index .. Index2 - 1)); if TResult.Version_Minor /= UIPMC_Version_Minor then Destroy_Profile (Result); return null; end if; -- We force Version_Minor to 2 to match MIOP specifications -- that requires MIOP 1.0 profile to be conformant with GIOP -- 1.2. TResult.Version_Minor := 2; Index := Index2 + 1; Index2 := Find (S, Index, '/'); if Index2 = S'Last + 1 then Destroy_Profile (Result); return null; end if; Temp_Ref := From_String (S (Index .. Index2 - 1)); if Temp_Ref = null then Destroy_Profile (Result); return null; end if; pragma Debug (C, O ("Group Info : " & Image (Temp_Ref.G_I))); TResult.G_I := Temp_Ref.G_I'Access; TResult.Components := Null_Tagged_Component_List; Add (TResult.Components, Tagged_Component_Access (Temp_Ref)); Index := Index2 + 1; Index2 := Find (S, Index, ':'); if Index2 = S'Last + 1 then Destroy_Profile (Result); return null; end if; pragma Debug (C, O ("Address = " & S (Index .. Index2 - 1))); Host_First := Index; Host_Last := Index2 - 1; Index := Index2 + 1; pragma Debug (C, O ("Port = " & S (Index .. S'Last))); Port := PolyORB.Sockets.Port_Type'Value (S (Index .. S'Last)); TResult.Object_Id := To_Object_Id (TResult.G_I.all); -- Create transport mechanism Append (TResult.Mechanisms, Create_Transport_Mechanism (S (Host_First .. Host_Last) + Port)); pragma Debug (C, O ("UIPMC corbaloc to profile: leave")); return Result; end Corbaloc_To_Profile; ----------- -- Image -- ----------- function Image (Prof : UIPMC_Profile_Type) return String is use PolyORB.Servants.Group_Servants; use PolyORB.Sockets; begin if Prof.G_I /= null then return "Address : " & Image (Address_Of (UIPMC_Transport_Mechanism (Element (Prof.Mechanisms, 0).all.all))) & ", Group : " & Image (Prof.G_I.all); else return "Address : " & Image (Address_Of (UIPMC_Transport_Mechanism (Element (Prof.Mechanisms, 0).all.all))) & ", no group information"; end if; end Image; ------------ -- Get_OA -- ------------ function Get_OA (Profile : UIPMC_Profile_Type) return PolyORB.Smart_Pointers.Entity_Ptr is pragma Unreferenced (Profile); begin return PolyORB.Smart_Pointers.Entity_Ptr (PolyORB.Setup.UIPMC.UIPMC_GOA); end Get_OA; ---------------- -- Initialize -- ---------------- procedure Initialize; procedure Initialize is Preference_Offset : constant String := PolyORB.Parameters.Get_Conf (Section => "miop", Key => "polyorb.binding_data.uipmc.preference", Default => "0"); begin -- XXX we impose a slight preference penalty to UIPMC to favor IIOP -- by default. See F501-004. Preference := Preference_Default - 1 + Profile_Preference'Value (Preference_Offset); Register (Tag_UIPMC, Marshall_UIPMC_Profile_Body'Access, Unmarshall_UIPMC_Profile_Body'Access); Register (Tag_UIPMC, UIPMC_Corbaloc_Prefix, Profile_To_Corbaloc'Access, Corbaloc_To_Profile'Access); end Initialize; use PolyORB.Initialization; use PolyORB.Initialization.String_Lists; use PolyORB.Utils.Strings; begin Register_Module (Module_Info' (Name => +"binding_data.uipmc", Conflicts => Empty, Depends => +"sockets", Provides => +"binding_factories", Implicit => False, Init => Initialize'Access, Shutdown => null)); end PolyORB.Binding_Data.GIOP.UIPMC; polyorb-2.8~20110207.orig/src/giop/miop/polyorb-filters-miop-miop_out.ads0000644000175000017500000000545211750740340025521 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . F I L T E R S . M I O P . M I O P _ O U T -- -- -- -- S p e c -- -- -- -- Copyright (C) 2003-2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- MIOP filter for data which arrive from a GIOP Session with PolyORB.Buffers; with PolyORB.Components; package PolyORB.Filters.MIOP.MIOP_Out is pragma Elaborate_Body; type MIOP_Out_Factory is new Factory with private; procedure Create (Fact : access MIOP_Out_Factory; MIOP_Out : out Filter_Access); private type MIOP_Out_Factory is new Factory with null record; -- MIOP_OUT status type MIOP_Out_Filter is new Filter with record -- MIOP buffer MIOP_Buff : Buffers.Buffer_Access; -- Max size of MIOP packet Max_Size : Types.Unsigned_Short; end record; function Handle_Message (F : not null access MIOP_Out_Filter; S : Components.Message'Class) return Components.Message'Class; end PolyORB.Filters.MIOP.MIOP_Out; polyorb-2.8~20110207.orig/src/giop/miop/polyorb-protocols-giop-uipmc.ads0000644000175000017500000000453311750740340025350 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . P R O T O C O L S . G I O P . U I P M C -- -- -- -- S p e c -- -- -- -- Copyright (C) 2003 Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by ACT Europe. -- -- (email: sales@act-europe.fr) -- -- -- ------------------------------------------------------------------------------ package PolyORB.Protocols.GIOP.UIPMC is type UIPMC_Protocol is new GIOP_Protocol with private; procedure Create (Proto : access UIPMC_Protocol; Session : out Filter_Access); private type UIPMC_Protocol is new GIOP_Protocol with null record; UIPMC_Conf : aliased GIOP_Conf; end PolyORB.Protocols.GIOP.UIPMC; polyorb-2.8~20110207.orig/src/giop/miop/polyorb-protocols-giop-uipmc.adb0000644000175000017500000000632511750740340025330 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . P R O T O C O L S . G I O P . U I P M C -- -- -- -- B o d y -- -- -- -- Copyright (C) 2003-2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with PolyORB.Initialization; with PolyORB.Utils.Strings; package body PolyORB.Protocols.GIOP.UIPMC is ------------ -- Create -- ------------ procedure Create (Proto : access UIPMC_Protocol; Session : out Filter_Access) is begin PolyORB.Protocols.GIOP.Create (GIOP_Protocol (Proto.all)'Access, Session); GIOP_Session (Session.all).Conf := UIPMC_Conf'Access; end Create; ---------------- -- Initialize -- ---------------- procedure Initialize; procedure Initialize is F : constant Flags := Sync_None or Sync_With_Transport; begin PolyORB.Protocols.GIOP.Initialize (UIPMC_Conf'Access, GIOP_Default_Version, F, False, "miop", "polyorb.protocols.miop.giop"); end Initialize; use PolyORB.Initialization; use PolyORB.Initialization.String_Lists; use PolyORB.Utils.Strings; begin Register_Module (Module_Info' (Name => +"protocols.giop.uipmc", Conflicts => Empty, Depends => +"setup.uipmc", Provides => Empty, Implicit => False, Init => Initialize'Access, Shutdown => null)); end PolyORB.Protocols.GIOP.UIPMC; polyorb-2.8~20110207.orig/src/giop/miop/polyorb-setup-access_points-uipmc.adb0000644000175000017500000001126611750740340026343 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . S E T U P . A C C E S S _ P O I N T S . U I P M C -- -- -- -- B o d y -- -- -- -- Copyright (C) 2003-2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- Setup socket for UIPMC with PolyORB.Binding_Data.GIOP.UIPMC; with PolyORB.Filters; with PolyORB.Filters.Fragmenter; with PolyORB.Filters.MIOP.MIOP_In; with PolyORB.Initialization; with PolyORB.ORB; with PolyORB.Parameters; with PolyORB.Protocols; with PolyORB.Protocols.GIOP.UIPMC; with PolyORB.Sockets; with PolyORB.Transport.Datagram.Sockets; with PolyORB.Utils.Strings; with PolyORB.Utils.UDP_Access_Points; package body PolyORB.Setup.Access_Points.UIPMC is use PolyORB.Filters; use PolyORB.Filters.Fragmenter; use PolyORB.Filters.MIOP.MIOP_In; use PolyORB.ORB; use PolyORB.Sockets; use PolyORB.Transport.Datagram.Sockets; use PolyORB.Utils.UDP_Access_Points; -- Just one UIPMC AP supported??? UIPMC_Access_Point : UDP_Access_Point_Info := (Socket => No_Socket, Address => No_Sock_Addr, SAP => new Socket_Access_Point, PF => new PolyORB.Binding_Data.GIOP.UIPMC.UIPMC_Profile_Factory); Fra : aliased Fragmenter_Factory; Min : aliased MIOP_In_Factory; Pro : aliased Protocols.GIOP.UIPMC.UIPMC_Protocol; UIPMC_Factories : aliased Filters.Factory_Array := (0 => Fra'Access, 1 => Min'Access, 2 => Pro'Access); ------------------------------ -- Initialize_Access_Points -- ------------------------------ procedure Initialize_Access_Points; procedure Initialize_Access_Points is use PolyORB.Parameters; Addr : constant String := Get_Conf ("miop", "polyorb.miop.multicast_addr", ""); Port : constant Port_Type := Port_Type (Get_Conf ("miop", "polyorb.miop.multicast_port", 0)); begin if Get_Conf ("access_points", "uipmc", True) then -- If multicast group address or port number is not set, access -- point is deactivated. if Addr = "" or else Port = 0 then return; end if; Initialize_Multicast_Socket (UIPMC_Access_Point, Inet_Addr (Addr), Port); Register_Access_Point (ORB => The_ORB, TAP => UIPMC_Access_Point.SAP, Chain => UIPMC_Factories'Access, PF => UIPMC_Access_Point.PF); end if; end Initialize_Access_Points; use PolyORB.Initialization; use PolyORB.Initialization.String_Lists; use PolyORB.Utils.Strings; begin Register_Module (Module_Info' (Name => +"access_points.uipmc", Conflicts => String_Lists.Empty, Depends => +"orb" & "sockets", Provides => String_Lists.Empty, Implicit => False, Init => Initialize_Access_Points'Access, Shutdown => null)); end PolyORB.Setup.Access_Points.UIPMC; polyorb-2.8~20110207.orig/src/giop/miop/polyorb-filters-miop-miop_in.ads0000644000175000017500000000754511750740340025325 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . F I L T E R S . M I O P . M I O P _ I N -- -- -- -- S p e c -- -- -- -- Copyright (C) 2003-2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- MIOP filter for data which arrive from network to ORB -- This filter MUST be under a GIOP Session with PolyORB.Buffers; with PolyORB.Components; package PolyORB.Filters.MIOP.MIOP_In is pragma Elaborate_Body; type MIOP_In_Factory is new Factory with private; procedure Create (Fact : access MIOP_In_Factory; MIOP_In : out Filter_Access); private -- MIOP_In state type MIOP_State is (Wait_For_GIOP_Layer, -- Wait for upper GIOP layer Wait_MIOP_Header, -- Wait a new MIOP header Wait_Unique_Id, -- Wait for Unique Id Wait_GIOP_Ask, -- Wait for upper GIOP layer Wait_GIOP_Data -- Wait for data to GIOP layer from lower ); -- MIOP stack status type MIOP_In_Filter is new Filter with record -- MIOP status State : MIOP_State := Wait_For_GIOP_Layer; -- MIOP buffer MIOP_Buf : Buffers.Buffer_Access; -- GIOP buffer In_Buf : Buffers.Buffer_Access; -- Data expected by GIOP layer Data_Exp : Stream_Element_Count; -- Data expected by GIOP layer at demand Initial_Data_Exp : Stream_Element_Count; -- Data remaining in GIOP buffer at demand Initial_Remain : Stream_Element_Count; -- Header of current MIOP packet Header : MIOP_Header; -- Previous MIOP packet Header Old_Header : MIOP_Header; -- Indicate if we are in fragment mode Fragment : Boolean := False; -- Payload of current MIOP packet Payload : Types.Unsigned_Short; end record; function Handle_Message (F : not null access MIOP_In_Filter; S : Components.Message'Class) return Components.Message'Class; type MIOP_In_Factory is new Factory with null record; end PolyORB.Filters.MIOP.MIOP_In; polyorb-2.8~20110207.orig/src/giop/miop/polyorb-setup-access_points-uipmc.ads0000644000175000017500000000422311750740340026357 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . S E T U P . A C C E S S _ P O I N T S . U I P M C -- -- -- -- S p e c -- -- -- -- Copyright (C) 2003-2008, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- Setup socket for UIPMC package PolyORB.Setup.Access_Points.UIPMC is pragma Elaborate_Body; end PolyORB.Setup.Access_Points.UIPMC; polyorb-2.8~20110207.orig/src/giop/miop/polyorb-miop_p-tagged_components.ads0000644000175000017500000000673011750740340026237 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . M I O P _ P . T A G G E D _ C O M P O N E N T S -- -- -- -- S p e c -- -- -- -- Copyright (C) 2003-2006 Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- MIOP specific tagged components with PolyORB.Buffers; with PolyORB.Errors; with PolyORB.GIOP_P.Tagged_Components; with PolyORB.MIOP_P.Groups; with PolyORB.Types; package PolyORB.MIOP_P.Tagged_Components is use PolyORB.Buffers; use PolyORB.GIOP_P.Tagged_Components; use PolyORB.MIOP_P.Groups; TC_Group_Info_Version_Major : constant Types.Octet; TC_Group_Info_Version_Minor : constant Types.Octet; type TC_Group_Info is new Tagged_Component (Tag => Tag_Group, At_Most_Once => False) with record G_I : aliased Group_Info; end record; type TC_Group_Info_Access is access all TC_Group_Info; procedure Marshall_Component_Data (Comp : access TC_Group_Info; Buffer : access Buffer_Type); procedure Unmarshall_Component_Data (Comp : access TC_Group_Info; Buffer : access Buffer_Type; Error : out PolyORB.Errors.Error_Container); procedure Release_Contents (Comp : access TC_Group_Info); function Duplicate (Comp : TC_Group_Info) return Tagged_Component_Access; function To_String (Comp : access TC_Group_Info) return String; -- Convert C into an element of a corbaloc function From_String (S : String) return TC_Group_Info_Access; -- Convert S into a TC_Group_Info_Access. -- S must follow corbaloc syntax. private TC_Group_Info_Version_Major : constant Types.Octet := 1; TC_Group_Info_Version_Minor : constant Types.Octet := 0; end PolyORB.MIOP_P.Tagged_Components; polyorb-2.8~20110207.orig/src/giop/miop/polyorb-miop_p-tagged_components.adb0000644000175000017500000002125411750740340026214 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . M I O P _ P . T A G G E D _ C O M P O N E N T S -- -- -- -- B o d y -- -- -- -- Copyright (C) 2003-2008, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- MIOP specific tagged components with Ada.Streams; with PolyORB.Initialization; with PolyORB.Log; with PolyORB.Representations.CDR.Common; with PolyORB.Utils.Strings; package body PolyORB.MIOP_P.Tagged_Components is use PolyORB.Log; use PolyORB.Representations.CDR.Common; package L is new PolyORB.Log.Facility_Log ("polyorb.miop_p.tagged_components"); procedure O (Message : Standard.String; Level : Log_Level := Debug) renames L.Output; function C (Level : Log_Level := Debug) return Boolean renames L.Enabled; ---------------------- -- Create_Component -- ---------------------- function Create_Component return Tagged_Component_Access; function Create_Component return Tagged_Component_Access is begin return new TC_Group_Info; end Create_Component; ----------------------------- -- Marshall_Component_Data -- ----------------------------- procedure Marshall_Component_Data (Comp : access TC_Group_Info; Buffer : access Buffer_Type) is use PolyORB.Types; Temp_Buf : Buffer_Access := new Buffer_Type; begin pragma Debug (C, O ("Marshall Group_Info")); pragma Debug (C, O ("Group : " & Image (Comp.G_I))); Start_Encapsulation (Temp_Buf); Marshall (Temp_Buf, TC_Group_Info_Version_Major); Marshall (Temp_Buf, TC_Group_Info_Version_Minor); Marshall (Temp_Buf, Types.Identifier (Comp.G_I.Group_Domain_Id)); Marshall (Temp_Buf, Comp.G_I.Object_Group_Id); Marshall (Temp_Buf, Comp.G_I.Object_Group_Ref_Version); Marshall (Buffer, Encapsulate (Temp_Buf)); Release (Temp_Buf); end Marshall_Component_Data; ------------------------------- -- Unmarshall_Component_Data -- ------------------------------- procedure Unmarshall_Component_Data (Comp : access TC_Group_Info; Buffer : access Buffer_Type; Error : out PolyORB.Errors.Error_Container) is use PolyORB.Errors; use PolyORB.Types; use type Ada.Streams.Stream_Element_Offset; Tag_Body : aliased Encapsulation := Unmarshall (Buffer); Temp_Buf : Buffer_Access := new Buffer_Type; Temp : Types.Octet; begin Decapsulate (Tag_Body'Access, Temp_Buf); pragma Debug (C, O ("Unmarshall Group_Info")); Temp := Unmarshall (Temp_Buf); pragma Assert (Temp = TC_Group_Info_Version_Major); Temp := Unmarshall (Temp_Buf); pragma Assert (Temp = TC_Group_Info_Version_Minor); Comp.G_I.Group_Domain_Id := Types.String (Types.Identifier'(Unmarshall (Temp_Buf))); Comp.G_I.Object_Group_Id := Unmarshall (Temp_Buf); Comp.G_I.Object_Group_Ref_Version := Unmarshall (Temp_Buf); pragma Debug (C, O ("Group Info : " & Image (Comp.G_I))); pragma Assert (Remaining (Temp_Buf) = 0); Release (Temp_Buf); exception when others => Release (Temp_Buf); Throw (Error, Bad_Param_E, System_Exception_Members'(10, Completed_No)); end Unmarshall_Component_Data; --------------- -- Duplicate -- --------------- function Duplicate (Comp : TC_Group_Info) return Tagged_Component_Access is begin return new TC_Group_Info'(Comp); end Duplicate; ---------------------- -- Release_Contents -- ---------------------- procedure Release_Contents (Comp : access TC_Group_Info) is pragma Unreferenced (Comp); begin null; end Release_Contents; --------------- -- To_String -- --------------- function To_String (Comp : access TC_Group_Info) return String is use PolyORB.Types; use PolyORB.Utils; begin pragma Debug (C, O ("To_String Group_Info")); pragma Debug (C, O ("Group : " & Image (Comp.G_I))); declare S : constant String := Trimmed_Image (Unsigned_Long_Long (TC_Group_Info_Version_Major)) & "." & Trimmed_Image (Unsigned_Long_Long (TC_Group_Info_Version_Minor)) & "-" & To_Standard_String (Comp.G_I.Group_Domain_Id) & "-" & Trimmed_Image (Comp.G_I.Object_Group_Id); begin if Comp.G_I.Object_Group_Ref_Version /= 0 then return S & "-" & Trimmed_Image (Unsigned_Long_Long (Comp.G_I.Object_Group_Ref_Version)); else return S; end if; end; end To_String; ----------------- -- From_String -- ----------------- function From_String (S : String) return TC_Group_Info_Access is use PolyORB.Types; use PolyORB.Utils; use PolyORB.Utils.Strings; Index : Integer := S'First; Index2 : Integer; G_I : TC_Group_Info_Access; begin pragma Debug (C, O ("Extract Group_Info from string")); Index2 := Find (S, Index, '.'); if Index2 = S'Last + 1 then return null; end if; if Types.Octet'Value (S (Index .. Index2 - 1)) /= TC_Group_Info_Version_Major then return null; end if; Index := Index2 + 1; Index2 := Find (S, Index, '-'); if Index2 = S'Last + 1 then return null; end if; if Types.Octet'Value (S (Index .. Index2 - 1)) /= TC_Group_Info_Version_Minor then return null; end if; Index := Index2 + 1; Index2 := Find (S, Index, '-'); if Index2 = S'Last + 1 then return null; end if; G_I := new TC_Group_Info; G_I.G_I.Group_Domain_Id := To_PolyORB_String (S (Index .. Index2 - 1)); Index := Index2 + 1; Index2 := Find (S, Index, '-'); if Index2 = S'Last + 1 then G_I.G_I.Object_Group_Id := Types.Unsigned_Long_Long'Value (S (Index .. S'Last)); else G_I.G_I.Object_Group_Id := Types.Unsigned_Long_Long'Value (S (Index .. Index2 - 1)); G_I.G_I.Object_Group_Ref_Version := Types.Unsigned_Long'Value (S (Index2 + 1 .. S'Last)); end if; pragma Debug (C, O ("Group Info : " & Image (G_I.G_I))); return G_I; end From_String; ---------------- -- Initialize -- ---------------- procedure Initialize; procedure Initialize is begin Register (Tag_Group, Create_Component'Access, null); end Initialize; use PolyORB.Initialization; use PolyORB.Initialization.String_Lists; use PolyORB.Utils.Strings; begin Register_Module (Module_Info' (Name => +"tagged_components.miop", Conflicts => Empty, Depends => Empty, Provides => Empty, Implicit => False, Init => Initialize'Access, Shutdown => null)); end PolyORB.MIOP_P.Tagged_Components; polyorb-2.8~20110207.orig/src/giop/miop/polyorb-miop_p-groups.ads0000644000175000017500000000570311750740340024055 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . M I O P _ P . G R O U P S -- -- -- -- S p e c -- -- -- -- Copyright (C) 2003 Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by ACT Europe. -- -- (email: sales@act-europe.fr) -- -- -- ------------------------------------------------------------------------------ with PolyORB.Objects; with PolyORB.Types; package PolyORB.MIOP_P.Groups is ---------------- -- Group_info -- ---------------- type Group_Info is record Group_Domain_Id : Types.String; Object_Group_Id : Types.Unsigned_Long_Long; Object_Group_Ref_Version : Types.Unsigned_Long := 0; end record; type Group_Info_Access is access all Group_Info; -- Group_Domain_Id and Object_Relation_Id are bound together -- Object_Group_Ref_Version is optional function Image (G_I : Group_Info) return String; -- Return a string representing the group ----------------------------------------- -- Object Id <-> Group Info conversion -- ----------------------------------------- function To_Object_Id (G_I : Group_Info) return PolyORB.Objects.Object_Id_Access; function To_Group_Info (Oid : PolyORB.Objects.Object_Id_Access) return Group_Info; end PolyORB.MIOP_P.Groups; polyorb-2.8~20110207.orig/src/giop/polyorb-giop_p-tagged_components.ads0000644000175000017500000002730611750740340025267 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . G I O P _ P . T A G G E D _ C O M P O N E N T S -- -- -- -- S p e c -- -- -- -- Copyright (C) 2003-2008, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- Implementation of CORBA IOR Tagged components with Ada.Streams; with PolyORB.Buffers; with PolyORB.Errors; with PolyORB.Objects; with PolyORB.QoS.Tagged_Components; with PolyORB.Types; with PolyORB.Utils.Chained_Lists; package PolyORB.GIOP_P.Tagged_Components is use PolyORB.Buffers; type Tag_Value is new Types.Unsigned_Long; ---------------------- -- Tagged_Component -- ---------------------- type Tagged_Component (Tag : Tag_Value; At_Most_Once : Boolean) is abstract tagged private; type Tagged_Component_Access is access all Tagged_Component'Class; procedure Marshall_Component_Data (Comp : access Tagged_Component; Buffer : access Buffer_Type) is abstract; -- Marshall tagged component_data associated to component procedure Unmarshall_Component_Data (Comp : access Tagged_Component; Buffer : access Buffer_Type; Error : out PolyORB.Errors.Error_Container) is abstract; -- Unmarshall tagged component_data associated to component procedure Release_Contents (Comp : access Tagged_Component) is abstract; -- Free memory associated with component function Duplicate (C : Tagged_Component) return Tagged_Component_Access is abstract; --------------------------- -- Tagged_Component_List -- --------------------------- type Tagged_Component_List is private; Null_Tagged_Component_List : constant Tagged_Component_List; -- Empty list type Tagged_Component_Array is array (Positive range <>) of Tagged_Component_Access; procedure Release_Contents (List : in out Tagged_Component_List); -- Free memory for all tags in List procedure Marshall_Tagged_Component (Buffer : access Buffer_Type; Components : Tagged_Component_List); -- Marshall Tagged Component List function Unmarshall_Tagged_Component (Buffer : access Buffer_Type) return Tagged_Component_List; -- Unmarshall tagged component List function Get_Component (List : Tagged_Component_List; Tag : Tag_Value) return Tagged_Component_Access; -- Search and return a component in a tagged component list function Get_Components (List : Tagged_Component_List; Tag : Tag_Value) return Tagged_Component_Array; -- Search and return all components with specified Tag in a tagged -- component list. function Fetch_Components (Oid : access PolyORB.Objects.Object_Id) return Tagged_Component_List; -- Return a Tagget_Component_List of all tagged components configured for -- object denoted by Oid. procedure Add (List : in out Tagged_Component_List; Comp : Tagged_Component_Access); -- Add a component to a tagged component list procedure Add (List : in out Tagged_Component_List; CL : Tagged_Component_List); -- Add a list of components to a tagged component list procedure Remove (List : in out Tagged_Component_List; Comp : Tagged_Component_Access); -- Remove Comp from List function Deep_Copy (List : Tagged_Component_List) return Tagged_Component_List; -- Return a deep copy of List ------------------------- -- Register components -- ------------------------- type New_Empty_Component_Func_Access is access function return Tagged_Component_Access; type Fetch_Component_Func_Access is access function (Oid : access PolyORB.Objects.Object_Id) return Tagged_Component_Access; procedure Register (Tag : Tag_Value; New_Empty_Component : New_Empty_Component_Func_Access; Fetch_Component : Fetch_Component_Func_Access); -- Register tagged component with tag Tag -------------- -- Tag List -- -------------- Tag_ORB_Type : constant Tag_Value; Tag_Code_Sets : constant Tag_Value; Tag_Policies : constant Tag_Value; Tag_Alternate_IIOP_Address : constant Tag_Value; Tag_Association_Options : constant Tag_Value; Tag_Sec_Name : constant Tag_Value; Tag_SPKM_1_Sec_Mech : constant Tag_Value; Tag_SPKM_2_Sec_Mech : constant Tag_Value; Tag_KerberosV5_Sec_Mech : constant Tag_Value; Tag_CSI_ECMA_Secret_Sec_Mech : constant Tag_Value; Tag_CSI_ECMA_Hybrid_Sec_Mech : constant Tag_Value; Tag_SSL_Sec_Trans : constant Tag_Value; Tag_CSI_ECMA_Public_Sec_Mech : constant Tag_Value; Tag_Generic_Sec_Mech : constant Tag_Value; Tag_Firewall_Trans : constant Tag_Value; Tag_SCCP_Contact_Info : constant Tag_Value; Tag_Java_Codebase : constant Tag_Value; Tag_Transaction_Policy : constant Tag_Value; Tag_FT_Group : constant Tag_Value; Tag_FT_Primary : constant Tag_Value; Tag_Message_Routers : constant Tag_Value; Tag_OTS_Policy : constant Tag_Value; Tag_INV_Policy : constant Tag_Value; Tag_CSI_Sec_Mech_List : constant Tag_Value; Tag_NULL_Tag : constant Tag_Value; Tag_SECIOP_Sec_Trans : constant Tag_Value; Tag_TLS_Sec_Trans : constant Tag_Value; Tag_Activity_Policy : constant Tag_Value; Tag_Group : constant Tag_Value; Tag_INET_Sec_Trans : constant Tag_Value; function Create_QoS_GIOP_Tagged_Components_List (Components : Tagged_Component_List) return PolyORB.QoS.Tagged_Components.GIOP_Tagged_Component_Lists.List; ----------------------- -- Unknown Component -- ----------------------- -- Unknown component is used when tag is unknown at unmarshalling time. -- Users cannot access to unknown components data, but unknown -- components can be remarshalled without being modified. type Octet_Access is access all Ada.Streams.Stream_Element_Array; -- Data in an unknow tagged component Tag_Unknown : constant Tag_Value := Tag_Value'Last; -- PolyORB specific value for Unknown tagged components type TC_Unknown_Component is new Tagged_Component (Tag => Tag_Unknown, At_Most_Once => False) with private; type TC_Unknown_Component_Access is access all TC_Unknown_Component'Class; procedure Marshall_Component_Data (Comp : access TC_Unknown_Component; Buffer : access Buffer_Type); procedure Unmarshall_Component_Data (Comp : access TC_Unknown_Component; Buffer : access Buffer_Type; Error : out PolyORB.Errors.Error_Container); function Create_Unknown_Component (Unknown_Tag : Tag_Value; Data : Octet_Access) return Tagged_Component_Access; procedure Release_Contents (Comp : access TC_Unknown_Component); function Duplicate (Comp : TC_Unknown_Component) return Tagged_Component_Access; private type Tagged_Component (Tag : Tag_Value; At_Most_Once : Boolean) is abstract tagged null record; package Component_Lists is new PolyORB.Utils.Chained_Lists (Tagged_Component_Access); use Component_Lists; -- Tagged component list type Tagged_Component_List is new Component_Lists.List; Null_Tagged_Component_List : constant Tagged_Component_List := Tagged_Component_List (Component_Lists.Empty); procedure Marshall_Tagged_Component (Buffer : access Buffer_Type; Component : Tagged_Component_Access); -- Marshall one tagged component procedure Unmarshall_Tagged_Component (Buffer : access Buffer_Type; C : out Tagged_Component_Access; Error : out PolyORB.Errors.Error_Container); -- Unmarshall one tagged component -------------- -- Tag List -- -------------- Tag_ORB_Type : constant Tag_Value := 0; Tag_Code_Sets : constant Tag_Value := 1; Tag_Policies : constant Tag_Value := 2; Tag_Alternate_IIOP_Address : constant Tag_Value := 3; Tag_Association_Options : constant Tag_Value := 13; Tag_Sec_Name : constant Tag_Value := 14; Tag_SPKM_1_Sec_Mech : constant Tag_Value := 15; Tag_SPKM_2_Sec_Mech : constant Tag_Value := 16; Tag_KerberosV5_Sec_Mech : constant Tag_Value := 17; Tag_CSI_ECMA_Secret_Sec_Mech : constant Tag_Value := 18; Tag_CSI_ECMA_Hybrid_Sec_Mech : constant Tag_Value := 19; Tag_SSL_Sec_Trans : constant Tag_Value := 20; Tag_CSI_ECMA_Public_Sec_Mech : constant Tag_Value := 21; Tag_Generic_Sec_Mech : constant Tag_Value := 22; Tag_Firewall_Trans : constant Tag_Value := 23; Tag_SCCP_Contact_Info : constant Tag_Value := 24; Tag_Java_Codebase : constant Tag_Value := 25; Tag_Transaction_Policy : constant Tag_Value := 26; Tag_FT_Group : constant Tag_Value := 27; Tag_FT_Primary : constant Tag_Value := 28; Tag_Message_Routers : constant Tag_Value := 30; Tag_OTS_Policy : constant Tag_Value := 31; Tag_INV_Policy : constant Tag_Value := 32; Tag_CSI_Sec_Mech_List : constant Tag_Value := 33; Tag_NULL_Tag : constant Tag_Value := 34; Tag_SECIOP_Sec_Trans : constant Tag_Value := 35; Tag_TLS_Sec_Trans : constant Tag_Value := 36; Tag_Activity_Policy : constant Tag_Value := 37; Tag_Group : constant Tag_Value := 39; -- TAO Value -- Tag_Group : constant Tag_Value := 1413566211; Tag_INET_Sec_Trans : constant Tag_Value := 123; type TC_Unknown_Component is new Tagged_Component (Tag => Tag_Unknown, At_Most_Once => False) with record Unknown_Tag : Tag_Value; Data : Octet_Access; end record; end PolyORB.GIOP_P.Tagged_Components; polyorb-2.8~20110207.orig/src/giop/polyorb-protocols-giop-giop_1_2.adb0000644000175000017500000016016211750740340024646 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . P R O T O C O L S . G I O P . G I O P _ 1 _ 2 -- -- -- -- B o d y -- -- -- -- Copyright (C) 2002-2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with Ada.Unchecked_Deallocation; with PolyORB.Any; with PolyORB.Binding_Data.GIOP; with PolyORB.Binding_Data.Local; with PolyORB.Buffers; with PolyORB.Components; with PolyORB.GIOP_P.Code_Sets.Converters; with PolyORB.GIOP_P.Service_Contexts; with PolyORB.GIOP_P.Tagged_Components.Code_Sets; with PolyORB.Initialization; with PolyORB.Log; with PolyORB.Obj_Adapters; with PolyORB.Obj_Adapters.Group_Object_Adapter; with PolyORB.Opaque; with PolyORB.Parameters; with PolyORB.Protocols.GIOP.Common; pragma Elaborate_All (PolyORB.Protocols.GIOP.Common); with PolyORB.QoS.Addressing_Modes; with PolyORB.QoS.Service_Contexts; with PolyORB.QoS.Static_Buffers; with PolyORB.References.Binding; with PolyORB.References.IOR; with PolyORB.Representations.CDR.Common; with PolyORB.Representations.CDR.GIOP_1_2; with PolyORB.Request_QoS; with PolyORB.Smart_Pointers; with PolyORB.Utils.Strings; package body PolyORB.Protocols.GIOP.GIOP_1_2 is use PolyORB.Buffers; use PolyORB.Components; use PolyORB.Errors; use PolyORB.GIOP_P.Code_Sets; use PolyORB.GIOP_P.Code_Sets.Converters; use PolyORB.GIOP_P.Service_Contexts; use PolyORB.Log; use PolyORB.Objects; use PolyORB.Protocols.GIOP.Common; use PolyORB.QoS; use PolyORB.QoS.Code_Sets; use PolyORB.QoS.Service_Contexts; use PolyORB.QoS.Static_Buffers; use PolyORB.Representations.CDR.Common; use PolyORB.Representations.CDR.GIOP_1_2; use PolyORB.Request_QoS; package L is new PolyORB.Log.Facility_Log ("polyorb.protocols.giop.giop_1_2"); procedure O (Message : String; Level : Log_Level := Debug) renames L.Output; function C (Level : Log_Level := Debug) return Boolean renames L.Enabled; Permitted_Sync_Scopes : constant PolyORB.Requests.Flags := Sync_None or Sync_With_Transport or Sync_With_Server or Sync_With_Target; procedure Free is new Ada.Unchecked_Deallocation (GIOP_1_2_CDR_Representation, GIOP_1_2_CDR_Representation_Access); procedure Free is new Ada.Unchecked_Deallocation (Target_Address, Target_Address_Access); -- Msg_Type function Unmarshall is new Generic_Unmarshall (Msg_Type, Types.Octet, Unmarshall); procedure Marshall is new Generic_Marshall (Msg_Type, Types.Octet, Marshall); -- Addressing_Dispostion function Unmarshall is new Generic_Unmarshall (Addressing_Disposition, Types.Unsigned_Short, Unmarshall); procedure Marshall is new Generic_Marshall (Addressing_Disposition, Types.Unsigned_Short, Marshall); -- Helpers ----------------------------- -- Marshall_Locate_Request -- ----------------------------- procedure Marshall_Locate_Request (Buffer : Buffer_Access; Request_Id : Types.Unsigned_Long; Target_Ref : Target_Address); procedure Unmarshall_Request_Message (Buffer : access Buffers.Buffer_Type; MCtx : access GIOP_Message_Context_1_2; Sync : out Sync_Scope; Target_Ref : out Target_Address_Access; Operation : out Types.String; Service_Contexts : out QoS_GIOP_Service_Contexts_Parameter_Access); procedure Negotiate_Code_Set_And_Update_Session (Profile : Binding_Data.Profile_Access; S : access Session'Class; Error : in out Errors.Error_Container); ----------------------------------- -- Internal function declaration -- ----------------------------------- procedure Process_Request (S : access GIOP_Session); procedure Process_Locate_Request (S : in out Session'Class); ----------------------- -- Initialize_Implem -- ----------------------- procedure Initialize_Implem (Implem : access GIOP_Implem_1_2) is use PolyORB.Parameters; Max : constant Types.Unsigned_Long := Types.Unsigned_Long (Get_Conf (To_Standard_String (Implem.Section), Get_Conf_Chain (Implem) & ".max_message_size", Default_Max_GIOP_Message_Size_1_2)); begin Implem.Data_Alignment := Data_Alignment_1_2; Implem.Max_GIOP_Message_Size := Max - (Max mod 8); Implem.Max_Body := Implem.Max_GIOP_Message_Size - Types.Unsigned_Long (GIOP_Header_Size); Implem.Permitted_Sync_Scopes := Permitted_Sync_Scopes; end Initialize_Implem; ------------------------ -- Initialize_Session -- ------------------------ procedure Initialize_Session (Implem : access GIOP_Implem_1_2; S : access Session'Class) is pragma Warnings (Off); pragma Unreferenced (Implem); pragma Warnings (On); begin pragma Debug (C, O ("Initializing GIOP session for version 1.2")); declare Sess : GIOP_Session renames GIOP_Session (S.all); begin Sess.MCtx := new GIOP_Message_Context_1_2; Sess.SCtx := new GIOP_Session_Context_1_2; Sess.Repr := new GIOP_1_2_CDR_Representation; end; pragma Debug (C, O ("... done")); end Initialize_Session; ---------------------- -- Finalize_Session -- ---------------------- procedure Finalize_Session (Implem : access GIOP_Implem_1_2; S : access Session'Class) is pragma Warnings (Off); pragma Unreferenced (Implem); pragma Warnings (On); Sess : GIOP_Session renames GIOP_Session (S.all); MCtx : GIOP_Message_Context_1_2 renames GIOP_Message_Context_1_2 (Sess.MCtx.all); begin if MCtx.Frag_Buf /= null then Release (MCtx.Frag_Buf); end if; Free (Sess.MCtx); Release (QoS_Parameter_Access (GIOP_Session_Context_1_2 (Sess.SCtx.all).CS_Context)); Free (Sess.SCtx); Release (GIOP_1_2_CDR_Representation (Sess.Repr.all)); Free (GIOP_1_2_CDR_Representation_Access (Sess.Repr)); pragma Debug (C, O ("Finalize context for GIOP session 1.2")); end Finalize_Session; --------------------- -- Process_Message -- --------------------- procedure Process_Message (Implem : access GIOP_Implem_1_2; S : access Session'Class) is use PolyORB.ORB; Sess : GIOP_Session renames GIOP_Session (S.all); SCtx : GIOP_Session_Context_1_2 renames GIOP_Session_Context_1_2 (Sess.SCtx.all); MCtx : GIOP_Message_Context_1_2 renames GIOP_Message_Context_1_2 (Sess.MCtx.all); begin case MCtx.Message_Type is when Request => if Sess.Role /= Server then raise Bidirectionnal_GIOP_Not_Implemented; end if; Process_Request (Sess'Access); when Cancel_Request => if Sess.Role /= Server then raise Bidirectionnal_GIOP_Not_Implemented; end if; Common_Process_Cancel_Request (Sess'Access, Request_Id => Unmarshall (Sess.Buffer_In)); when Reply => if Sess.Role /= Client then raise Bidirectionnal_GIOP_Not_Implemented; end if; declare Request_Id : Types.Unsigned_Long; Reply_Status : Reply_Status_Type; Service_Contexts : QoS_GIOP_Service_Contexts_Parameter_Access; begin if CDR_Position (Sess.Buffer_In) = GIOP_Header_Size then Request_Id := Unmarshall (Sess.Buffer_In); else -- Request Id has been read before in fragmenting packet Request_Id := MCtx.Request_Id; end if; Reply_Status := Unmarshall (Sess.Buffer_In); Unmarshall_Service_Context_List (Sess.Buffer_In, Service_Contexts); pragma Debug (C, O (Request_Id'Img)); Common_Reply_Received (Sess'Access, Request_Id, Reply_Status, Service_Contexts); end; when Close_Connection => if Sess.Role /= Server then raise Bidirectionnal_GIOP_Not_Implemented; end if; Expect_GIOP_Header (Sess'Access); when Fragment => -- Process_Message is called twice for a Fragment message: -- once for the decoding of the fragment header (in state First -- or Req), another time for reception of the payload (in state -- Fragment). In the Fragment case, the request id has already -- been set in the message context. if CDR_Position (Sess.Buffer_In) = GIOP_Header_Size then MCtx.Request_Id := Unmarshall (Sess.Buffer_In); end if; declare U_MCtx : GIOP_Message_Context_Access := Get_Reassembly_Context (SCtx'Access, MCtx.Request_Id); subtype GMC_1_2 is GIOP_Message_Context_1_2; procedure Swap_Bufs; -- Exchange the values of the session buffer and the fragment -- reassembly buffer. procedure Reassembly_Completed; -- After receiving the last fragment of a GIOP message, -- delete stored context and process reassembled message -- through the normal circuitry. procedure Swap_Bufs is B : constant Buffer_Access := Sess.Buffer_In; begin Sess.Buffer_In := GMC_1_2 (U_MCtx.all).Frag_Buf; GMC_1_2 (U_MCtx.all).Frag_Buf := B; end Swap_Bufs; -------------------------- -- Reassembly_Completed -- -------------------------- procedure Reassembly_Completed is begin Swap_Bufs; Release (GMC_1_2 (U_MCtx.all).Frag_Buf); GMC_1_2 (U_MCtx.all).Message_Type := GMC_1_2 (U_MCtx.all).Frag_Type; Sess.MCtx.all := U_MCtx.all; Remove_Reassembly_Context (SCtx'Access, U_MCtx); Process_Message (Implem, S); end Reassembly_Completed; begin if U_MCtx = null then pragma Assert (MCtx.Fragmented); U_MCtx := new GIOP_Message_Context_1_2'(MCtx); GMC_1_2 (U_MCtx.all).Message_Type := MCtx.Frag_Type; GMC_1_2 (U_MCtx.all).Frag_State := First; Store_Reassembly_Context (SCtx'Access, U_MCtx); end if; if GMC_1_2 (U_MCtx.all).Frag_State = First then pragma Debug (C, O ("First fragment received")); GMC_1_2 (U_MCtx.all).Frag_Buf := new Buffer_Type; Swap_Bufs; -- Steal session buffer to serve as reassembly buffer for -- this message. GMC_1_2 (U_MCtx.all).Frag_State := Req; end if; if GMC_1_2 (U_MCtx.all).Frag_State = Req then pragma Debug (C, O ("Fragment header received")); pragma Debug (C, O ("Request ID :" & MCtx.Request_Id'Img)); pragma Debug (C, O ("Frag Size :" & MCtx.Frag_Size'Img)); if MCtx.Frag_Size > 0 then -- Receive fragment body into reassembly buffer GMC_1_2 (U_MCtx.all).Frag_State := Fragment; Emit_No_Reply (Port => Lower (S), Msg => GIOP_Data_Expected' (In_Buf => GMC_1_2 (U_MCtx.all).Frag_Buf, Max => Stream_Element_Count (MCtx.Frag_Size), State => Sess.State)); else Reassembly_Completed; end if; else pragma Assert (GMC_1_2 (U_MCtx.all).Frag_State = Fragment); pragma Debug (C, O ("Fragment received, size:" & MCtx.Frag_Size'Img)); GMC_1_2 (U_MCtx.all).Message_Size := GMC_1_2 (U_MCtx.all).Message_Size + MCtx.Frag_Size; if MCtx.Fragmented then -- More fragments to come GMC_1_2 (U_MCtx.all).Frag_State := Req; Expect_GIOP_Header (Sess'Access); else -- Last fragment pragma Debug (C, O ("Last fragment, total size:" & GMC_1_2 (U_MCtx.all).Message_Size'Img)); Reassembly_Completed; end if; end if; end; when Locate_Reply => if Sess.Role /= Client then raise Bidirectionnal_GIOP_Not_Implemented; end if; -- Exec request if request id is found in pending req list declare Request_Id : Types.Unsigned_Long; Locate_Reply : Locate_Reply_Type; begin if CDR_Position (Sess.Buffer_In) = GIOP_Header_Size then Request_Id := Unmarshall (Sess.Buffer_In); else Request_Id := MCtx.Request_Id; end if; Locate_Reply := Unmarshall (Sess.Buffer_In); Common_Process_Locate_Reply (Sess'Access, Request_Id, Locate_Reply); end; when Locate_Request => if Sess.Role /= Server then raise Bidirectionnal_GIOP_Not_Implemented; end if; Process_Locate_Request (Sess); when Message_Error => raise GIOP_Error; end case; end Process_Message; --------------------- -- Process_Request -- --------------------- procedure Process_Request (S : access GIOP_Session) is use PolyORB.Annotations; use PolyORB.Any.NVList; use PolyORB.Binding_Data; use PolyORB.Binding_Data.Local; use PolyORB.Obj_Adapters; use PolyORB.ORB; use PolyORB.QoS.Addressing_Modes; use PolyORB.References; MCtx : GIOP_Message_Context_1_2 renames GIOP_Message_Context_1_2 (S.MCtx.all); SCtx : GIOP_Session_Context_1_2 renames GIOP_Session_Context_1_2 (S.SCtx.all); Sync : Sync_Scope; Target_Addr : Target_Address_Access; Operation : Types.String; Req_Flags : Flags := 0; Args : Any.NVList.Ref; Def_Args : Component_Access; Target : References.Ref; Req : Request_Access; CSP : QoS_GIOP_Code_Sets_Parameter_Access; AM : Addressing_Mode; Service_Contexts : QoS_GIOP_Service_Contexts_Parameter_Access; Error : Errors.Error_Container; Result : Any.NamedValue; -- Dummy NamedValue for Create_Request; -- the actual Result is set by the called method. begin if S.Role /= Server then raise Bidirectionnal_GIOP_Not_Implemented; end if; pragma Debug (C, O ("Request_Received: entering")); if CDR_Position (S.Buffer_In) = GIOP_Header_Size then MCtx.Request_Id := Unmarshall (S.Buffer_In); end if; Unmarshall_Request_Message (S.Buffer_In, MCtx'Access, Sync, Target_Addr, Operation, Service_Contexts); case Sync is when WITH_TARGET => Req_Flags := Sync_With_Target; when WITH_TRANSPORT => Req_Flags := Sync_With_Transport; when WITH_SERVER => Req_Flags := Sync_With_Server; when others => null; end case; S.State := Waiting_Unmarshalling; case Target_Addr.Address_Type is when Key_Addr => AM := Key; pragma Debug (C, O ("Object Key : " & Oid_To_Hex_String ( Target_Addr.Object_Key.all))); Args := Get_Empty_Arg_List (Object_Adapter (ORB_Access (S.Server)), Target_Addr.Object_Key, To_Standard_String (Operation)); if not Is_Nil (Args) then pragma Debug (C, O ("Immediate arguments unmarshalling")); S.State := Waiting_Unmarshalling; -- XXX change state name. We are not waiting for -- unmarshalling: we do it now. See next line. Handle_Unmarshall_Arguments (S, Args, Error); if Found (Error) then Catch (Error); raise Program_Error; -- XXX We cannot silently ignore any error. For now, -- we raise this exception. To be investigated. end if; else pragma Debug (C, O ("Unmarshalling of arguments deferred")); Def_Args := Component_Access (S); end if; declare Target_Profile : constant Binding_Data.Profile_Access := new Local_Profile_Type; begin Create_Local_Profile (Target_Addr.Object_Key.all, Local_Profile_Type (Target_Profile.all)); Create_Reference ((1 => Target_Profile), "", Target); -- Create a temporary, typeless reference for this object. -- If we wanted to have proper type information, we would -- have to resolve the (local) object id through the object -- adapter, and query the target object for its most derived -- type. Free (Target_Addr.Object_Key); end; when Profile_Addr => AM := Profile; Create_Reference ((1 => Target_Addr.Profile), "", Target); Def_Args := Component_Access (S); -- XXX By default, we do deferred unmarshalling, we -- have no way to get servant signature. when Reference_Addr => AM := Reference; Target := Target_Addr.Ref.IOR; Def_Args := Component_Access (S); -- XXX By default, we do deferred unmarshalling, we -- have no way to get servant signature. end case; Create_Request (Target => Target, Operation => To_Standard_String (Operation), Arg_List => Args, Result => Result, Deferred_Arguments_Session => Def_Args, Req => Req, Req_Flags => Req_Flags, Dependent_Binding_Object => Smart_Pointers.Entity_Ptr (S.Dependent_Binding_Object)); Add_Request_QoS (Req.all, GIOP_Addressing_Mode, new QoS_GIOP_Addressing_Mode_Parameter' (Kind => GIOP_Addressing_Mode, Mode => AM)); Add_Request_QoS (Req.all, GIOP_Service_Contexts, QoS_Parameter_Access (Service_Contexts)); Rebuild_Request_QoS_Parameters (Req.all); if Fetch_Secure_Transport_QoS /= null then Add_Request_QoS (Req.all, Transport_Security, Fetch_Secure_Transport_QoS (PolyORB.Transport.Transport_Endpoint_Access (Lower (Filter_Access (Lower (S)))))); -- XXX Should be reimplemented! end if; if not SCtx.CSN_Complete then CSP := QoS_GIOP_Code_Sets_Parameter_Access (Extract_Request_Parameter (GIOP_Code_Sets, Req.all)); SCtx.CS_Context := null; SCtx.CSN_Complete := True; if CSP /= null then SCtx.CS_Context := new QoS_GIOP_Code_Sets_Parameter'(CSP.all); Set_Converters (GIOP_1_2_CDR_Representation (S.all.Repr.all), Get_Converter (Native_Char_Code_Set, CSP.Char_Data), Get_Converter (Native_Wchar_Code_Set, CSP.Wchar_Data)); end if; end if; Queue_Request (S, Req, MCtx.Request_Id); Free (Target_Addr); pragma Debug (C, O ("Request queued.")); end Process_Request; ---------------- -- Send_Reply -- ---------------- procedure Send_Reply (Implem : access GIOP_Implem_1_2; S : access Session'Class; Request : Requests.Request_Access) is pragma Warnings (Off); pragma Unreferenced (Implem); pragma Warnings (On); use PolyORB.ORB; Sess : GIOP_Session renames GIOP_Session (S.all); MCtx : aliased GIOP_Message_Context_1_2; Error : Errors.Error_Container; begin if Sess.Role = Client then raise Bidirectionnal_GIOP_Not_Implemented; end if; MCtx.Fragmented := False; MCtx.Message_Type := Reply; Common_Send_Reply (Sess'Access, Request, MCtx'Access, Error); if Found (Error) then Set_Exception (Request.all, Error); Catch (Error); Common_Send_Reply (Sess'Access, Request, MCtx'Access, Error, Recovery => True); if Found (Error) then Catch (Error); -- Double error: bail out raise GIOP_Error; end if; end if; end Send_Reply; ------------------ -- Emit_Message -- ------------------ procedure Emit_Message (Implem : access GIOP_Implem_1_2; S : access Session'Class; MCtx : access GIOP_Message_Context'Class; Buffer : Buffers.Buffer_Access; Error : in out Errors.Error_Container) is use Octet_Flags; Sess : GIOP_Session renames GIOP_Session (S.all); MCtx_1_2 : GIOP_Message_Context_1_2 renames GIOP_Message_Context_1_2 (MCtx.all); Frag_MCtx : aliased GIOP_Message_Context_1_2; -- Context for fragments Message_Size : Types.Unsigned_Long := Types.Unsigned_Long (Length (Buffer.all)); begin if Message_Size > Implem.Max_GIOP_Message_Size then -- Message is too large, it must be fragmented. -- Message is divided into small slices. Each piece is -- copied in Out_Buf buffer, correct headers are added. declare Out_Buf : Buffer_Access := new Buffer_Type; Emit_Size : Types.Unsigned_Long; Request_Id : Types.Unsigned_Long; Version : GIOP_Version; begin pragma Debug (C, O ("Fragmenting message, size :" & Message_Size'Img)); Set_Endianness (Out_Buf, Endianness (Buffer)); -- Unmarshall headers of input buffer Rewind (Buffer); Unmarshall_Global_GIOP_Header (GIOP_Session (S.all)'Access, Buffer, Version); -- XXX shouldn't we check that version = GIOP 1.2 ? Unmarshall_GIOP_Header (Sess.Implem, MCtx, Buffer); -- Check whether fragmentation is allowed for this message type if False or else MCtx_1_2.Message_Type = Request or else MCtx_1_2.Message_Type = Reply or else MCtx_1_2.Message_Type = Locate_Request or else MCtx_1_2.Message_Type = Locate_Reply then null; else -- Fragmentation not allowed for this message type raise GIOP_Error; end if; -- Check if message_size correspond to buffer size pragma Assert (MCtx_1_2.Message_Size + Types.Unsigned_Long (GIOP_Header_Size) = Message_Size); -- Get request id Request_Id := Unmarshall (Buffer); pragma Debug (C, O ("Request Id :" & Request_Id'Img)); Frag_MCtx.Message_Size := Implem.Max_Body; Frag_MCtx.Fragmented := True; Frag_MCtx.Message_Type := MCtx_1_2.Message_Type; Marshall_Global_GIOP_Header (Sess'Access, Frag_MCtx'Access, Out_Buf); -- Marshall first fragment Marshall (Out_Buf, Request_Id); Copy (Buffer, Out_Buf, Implem.Max_Body - Frag_Header_Size); GIOP.Emit_Message (GIOP_Implem (Implem.all)'Access, S, Frag_MCtx'Access, Out_Buf, Error); Release_Contents (Out_Buf.all); if Found (Error) then return; end if; pragma Debug (C, O ("First fragment sent, size :" & Implem.Max_Body'Img)); -- Create subsequent fragments Frag_MCtx.Message_Type := Fragment; Message_Size := MCtx_1_2.Message_Size - Implem.Max_Body; loop -- Last fragment? if Message_Size <= Implem.Max_Body - Frag_Header_Size then -- This is the last fragment Frag_MCtx.Fragmented := False; Emit_Size := Message_Size; else -- More fragments to come Frag_MCtx.Fragmented := True; Emit_Size := Implem.Max_Body - Frag_Header_Size; end if; Frag_MCtx.Message_Size := Emit_Size + Frag_Header_Size; Marshall_Global_GIOP_Header (Sess'Access, Frag_MCtx'Access, Out_Buf); Marshall (Out_Buf, Request_Id); -- if needed, copy data if Emit_Size > 0 then Copy (Buffer, Out_Buf, Emit_Size); end if; pragma Debug (C, O ("Fragment sent, size :" & Emit_Size'Img)); GIOP.Emit_Message (GIOP_Implem (Implem.all)'Access, S, Frag_MCtx'Access, Out_Buf, Error); Release_Contents (Out_Buf.all); if Found (Error) then return; end if; exit when not Frag_MCtx.Fragmented; -- Prepare for next fragment Message_Size := Message_Size - Emit_Size; end loop; -- free buffer Release (Out_Buf); end; else pragma Debug (C, O ("Emit message, size :" & Message_Size'Img)); GIOP.Emit_Message (GIOP_Implem (Implem.all)'Access, S, MCtx, Buffer, Error); end if; end Emit_Message; ---------------------------- -- Process_Locate_Request -- ---------------------------- procedure Process_Locate_Request (S : in out Session'Class) is use PolyORB.Binding_Data; use PolyORB.Binding_Data.Local; use PolyORB.ORB; use PolyORB.References; Sess : GIOP_Session renames GIOP_Session (S); MCtx : GIOP_Message_Context_1_2 renames GIOP_Message_Context_1_2 (Sess.MCtx.all); Reply_MCtx : aliased GIOP_Message_Context_1_2; Buffer : Buffer_Access renames Sess.Buffer_In; Request_Id : Types.Unsigned_Long; Target : References.Ref; Address_Disp : Addressing_Disposition; Result : Locate_Reply_Type; Error : Errors.Error_Container; begin if CDR_Position (Buffer) = GIOP_Header_Size then Request_Id := Unmarshall (Buffer); else Request_Id := MCtx.Request_Id; end if; pragma Debug (C, O ("Locate_Request, Request_Id :" & Request_Id'Img)); -- Target Ref Address_Disp := Unmarshall (Buffer); pragma Debug (C, O ("Addr_Type : " & Addressing_Disposition'Image (Address_Disp))); case Address_Disp is when Key_Addr => declare Obj : constant Stream_Element_Array := Unmarshall (Buffer); Obj_Id : Object_Id_Access := new Object_Id'(Object_Id (Obj)); Target_Profile : constant Binding_Data.Profile_Access := new Local_Profile_Type; begin Create_Local_Profile (Obj_Id.all, Local_Profile_Type (Target_Profile.all)); Create_Reference ((1 => Target_Profile), "", Target); Free (Obj_Id); end; when Profile_Addr => declare use PolyORB.References.IOR; Pro : constant Binding_Data.Profile_Access := Unmarshall_Profile (Buffer); begin if Pro = null then pragma Debug (C, O ("Incorrect profile")); raise GIOP_Error; end if; Create_Reference ((1 => Pro), "", Target); end; when Reference_Addr => declare Ref : constant IOR_Addressing_Info_Access := new IOR_Addressing_Info; begin Ref.Selected_Profile_Index := Unmarshall (Buffer); Ref.IOR := Unmarshall (Buffer); Target := Ref.IOR; end; end case; -- Check if object is on this node declare ORB : constant PolyORB.ORB.ORB_Access := PolyORB.ORB.ORB_Access (S.Server); Component : PolyORB.Components.Component_Access; Profile : PolyORB.Binding_Data.Profile_Access; Error : PolyORB.Errors.Error_Container; begin PolyORB.References.Binding.Bind (Target, ORB, (others => null), Component, Profile, True, Error); if PolyORB.Errors.Found (Error) then if Error.Kind = ForwardRequest_E then Result := Object_Forward; Set (Target, PolyORB.Smart_Pointers.Entity_Of (ForwardRequest_Members (Error.Member.all).Forward_Reference)); elsif Error.Kind = ForwardRequestPerm_E then Result := Object_Forward_Perm; Set (Target, PolyORB.Smart_Pointers.Entity_Of (ForwardRequestPerm_Members (Error.Member.all).Forward_Reference)); else Result := Unknown_Object; end if; PolyORB.Errors.Catch (Error); else Result := Object_Here; end if; end; pragma Debug (C, O ("Locate_Request: result is " & Locate_Reply_Type'Image (Result))); Reply_MCtx.Fragmented := False; Reply_MCtx.Message_Type := Locate_Reply; Reply_MCtx.Request_Id := Request_Id; Common_Locate_Reply (Sess'Access, Reply_MCtx'Access, Result, Target, Error); if Found (Error) then Catch (Error); raise GIOP_Error; end if; Expect_GIOP_Header (Sess'Access); end Process_Locate_Request; ------------------- -- Locate_Object -- ------------------- procedure Locate_Object (Implem : access GIOP_Implem_1_2; S : access Session'Class; R : Pending_Request_Access; Error : in out Errors.Error_Container) is pragma Warnings (Off); pragma Unreferenced (Implem); pragma Warnings (On); use PolyORB.ORB; use PolyORB.Binding_Data; Sess : GIOP_Session renames GIOP_Session (S.all); MCtx : aliased GIOP_Message_Context_1_2; Buffer : Buffer_Access; Header_Buffer : Buffer_Access; Header_Space : Reservation; begin if Sess.Role /= Client then raise Bidirectionnal_GIOP_Not_Implemented; end if; Negotiate_Code_Set_And_Update_Session (R.Target_Profile, S, Error); if Found (Error) then return; end if; pragma Debug (C, O ("Send locate request to find target object")); pragma Debug (C, O ("Locate Request Id :" & R.Locate_Req_Id'Img)); pragma Debug (C, O ("Request Id :" & R.Request_Id'Img)); Buffer := new Buffer_Type; Header_Buffer := new Buffer_Type; Header_Space := Reserve (Buffer, GIOP_Header_Size); Marshall_Locate_Request (Buffer, R.Locate_Req_Id, Target_Address' (Address_Type => Key_Addr, Object_Key => Get_Object_Key (R.Target_Profile.all))); MCtx.Fragmented := False; MCtx.Message_Type := Locate_Request; MCtx.Message_Size := Types.Unsigned_Long (Length (Buffer.all) - GIOP_Header_Size); Marshall_Global_GIOP_Header (Sess'Access, MCtx'Access, Header_Buffer); Copy_Data (Header_Buffer.all, Header_Space); Release (Header_Buffer); Emit_Message (Sess.Implem, S, MCtx'Access, Buffer, Error); Release (Buffer); end Locate_Object; ------------------ -- Send_Request -- ------------------ procedure Send_Request (Implem : access GIOP_Implem_1_2; S : access Session'Class; R : Pending_Request_Access; Error : in out Errors.Error_Container) is pragma Warnings (Off); pragma Unreferenced (Implem); pragma Warnings (On); use PolyORB.Requests.Unsigned_Long_Flags; Sess : GIOP_Session renames GIOP_Session (S.all); MCtx : aliased GIOP_Message_Context_1_2; SCtx : GIOP_Session_Context_1_2 renames GIOP_Session_Context_1_2 (Sess.SCtx.all); Buffer : Buffer_Access; Header_Buffer : Buffer_Access; Header_Space : Reservation; Static_Buffer : constant QoS_GIOP_Static_Buffer_Parameter_Access := QoS_GIOP_Static_Buffer_Parameter_Access (Extract_Request_Parameter (QoS.GIOP_Static_Buffer, R.Req.all)); begin pragma Debug (C, O ("Sending request, Id :" & R.Request_Id'Img)); Negotiate_Code_Set_And_Update_Session (R.Target_Profile, S, Error); if Found (Error) then return; end if; if SCtx.CS_Context /= null then Add_Request_QoS (R.Req.all, GIOP_Code_Sets, new QoS_GIOP_Code_Sets_Parameter'(SCtx.CS_Context.all)); end if; Buffer := new Buffer_Type; Header_Buffer := new Buffer_Type; Header_Space := Reserve (Buffer, GIOP_Header_Size); Marshall (Buffer, R.Request_Id); -- Marshalling synchronization scope if Is_Set (Sync_With_Target, R.Req.Req_Flags) or else Is_Set (Sync_Call_Back, R.Req.Req_Flags) then -- WITH_TARGET Marshall (Buffer, Types.Octet (3)); elsif Is_Set (Sync_None, R.Req.Req_Flags) then -- NONE Marshall (Buffer, Types.Octet (0)); elsif Is_Set (Sync_With_Transport, R.Req.Req_Flags) then -- WITH_TRANSPORT Marshall (Buffer, Types.Octet (0)); elsif Is_Set (Sync_With_Server, R.Req.Req_Flags) then -- WITH_SERVER Marshall (Buffer, Types.Octet (1)); end if; -- Reserved for J in 1 .. 3 loop Marshall (Buffer, Types.Octet (0)); end loop; -- Target Reference declare use PolyORB.Binding_Data; use PolyORB.Obj_Adapters.Group_Object_Adapter; use PolyORB.QoS.Addressing_Modes; use PolyORB.Smart_Pointers; OA_Entity : constant PolyORB.Smart_Pointers.Entity_Ptr := Get_OA (R.Target_Profile.all); QoS : constant QoS_GIOP_Addressing_Mode_Parameter_Access := QoS_GIOP_Addressing_Mode_Parameter_Access (Extract_Request_Parameter (GIOP_Addressing_Mode, R.Req.all)); Mode : Addressing_Disposition := Key_Addr; begin if QoS /= null then case QoS.Mode is when Key => Mode := Key_Addr; when Profile => Mode := Profile_Addr; when Reference => Mode := Reference_Addr; end case; end if; if Mode < Profile_Addr and then OA_Entity /= null and then OA_Entity.all in Group_Object_Adapter'Class then Mode := Profile_Addr; end if; Marshall (Buffer, Mode); case Mode is when Key_Addr => declare Oid : constant Object_Id_Access := Binding_Data.Get_Object_Key (R.Target_Profile.all); begin Marshall (Buffer, Stream_Element_Array (Oid.all)); end; when Profile_Addr => declare Success : Boolean; begin References.IOR.Marshall_Profile (Buffer, R.Target_Profile, Success); if not Success then pragma Debug (C, O ("Incorrect profile")); raise GIOP_Error; end if; end; when Reference_Addr => declare use PolyORB.References; P : constant Profile_Array := Profiles_Of (R.Req.Target); S : Unsigned_Long := 0; begin for J in P'Range loop if P (J) = R.Target_Profile then S := Unsigned_Long (J - P'First); end if; end loop; Marshall (Buffer, S); References.IOR.Marshall_IOR (Buffer, R.Req.Target); end; end case; end; -- Operation pragma Debug (C, O ("Operation : " & R.Req.Operation.all)); Marshall_Latin_1_String (Buffer, R.Req.Operation.all); -- Service context Rebuild_Request_Service_Contexts (R.Req.all); Marshall_Service_Context_List (Buffer, QoS_GIOP_Service_Contexts_Parameter_Access (Extract_Request_Parameter (GIOP_Service_Contexts, R.Req.all))); -- Arguments if Static_Buffer /= null and then Length (Static_Buffer.Buffer.all) /= 0 then -- The arguments were marshalled and stored in the request -- QoS attribute. We insert the data contained in the -- request QoS in the buffer. pragma Debug (C, O ("Using static buffer")); Pad_Align (Buffer, Sess.Implem.Data_Alignment); declare Data : PolyORB.Opaque.Opaque_Pointer; Data_To_Process : Stream_Element_Count := Length (Static_Buffer.Buffer.all); Data_Processed : Stream_Element_Count := Data_To_Process; Position : Ada.Streams.Stream_Element_Offset := 0; begin while Data_To_Process > 0 loop PolyORB.Buffers.Partial_Extract_Data (Static_Buffer.Buffer, Data, Data_Processed, Use_Current => False, At_Position => Position, Partial => True); Insert_Raw_Data (Buffer, Data_Processed, Data); Data_To_Process := Data_To_Process - Data_Processed; Position := Position + Data_Processed; end loop; end; else pragma Debug (C, O ("Marshalling argument list")); Marshall_Argument_List (Sess.Implem, Buffer, Sess.Repr, R.Req.Args, PolyORB.Any.ARG_IN, Sess.Implem.Data_Alignment, Error); if Found (Error) then Replace_Marshal_5_To_Inv_Objref_2 (Error, Completed_No); -- An error in the marshalling of wchar data implies the -- server did not provide a valid codeset component. We -- convert this exception to Inv_ObjRef 2. Release (Header_Buffer); Release (Buffer); return; end if; end if; -- GIOP Header MCtx.Fragmented := False; MCtx.Message_Type := Request; MCtx.Message_Size := Types.Unsigned_Long (Length (Buffer.all) - GIOP_Header_Size); Marshall_Global_GIOP_Header (Sess'Access, MCtx'Access, Header_Buffer); Copy_Data (Header_Buffer.all, Header_Space); Release (Header_Buffer); -- Sending request Emit_Message (Sess.Implem, Sess'Access, MCtx'Access, Buffer, Error); pragma Debug (C, O ("Request sent, Id :" & R.Request_Id'Img & ", size:" & MCtx.Message_Size'Img)); Release (Buffer); end Send_Request; ------------------------------------------- -- Negotiate_Code_Set_And_Update_Session -- ------------------------------------------- procedure Negotiate_Code_Set_And_Update_Session (Profile : Binding_Data.Profile_Access; S : access Session'Class; Error : in out Errors.Error_Container) is Sess : GIOP_Session renames GIOP_Session (S.all); SCtx : GIOP_Session_Context_1_2 renames GIOP_Session_Context_1_2 (Sess.SCtx.all); begin if not SCtx.CSN_Complete then pragma Debug (C, O ("Negotiate_Code_Set_And_Update_Session")); declare use PolyORB.Binding_Data.GIOP; use PolyORB.GIOP_P.Tagged_Components; use PolyORB.GIOP_P.Tagged_Components.Code_Sets; TC : constant Tagged_Component_Access := Get_Component (GIOP_Profile_Type (Profile.all), Tag_Code_Sets); begin if TC = null then null; else SCtx.CS_Context := new QoS_GIOP_Code_Sets_Parameter; Negotiate_Code_Set (Native_Char_Code_Set, Conversion_Char_Code_Sets, TC_Code_Sets (TC.all).For_Char_Data.Native_Code_Set, TC_Code_Sets (TC.all).For_Char_Data.Conversion_Code_Sets, Char_Data_Fallback_Code_Set, SCtx.CS_Context.Char_Data, Error); if Found (Error) then Release (QoS_Parameter_Access (SCtx.CS_Context)); return; end if; Negotiate_Code_Set (Native_Wchar_Code_Set, Conversion_Wchar_Code_Sets, TC_Code_Sets (TC.all).For_Wchar_Data.Native_Code_Set, TC_Code_Sets (TC.all).For_Wchar_Data.Conversion_Code_Sets, Wchar_Data_Fallback_Code_Set, SCtx.CS_Context.Wchar_Data, Error); if Found (Error) then Release (QoS_Parameter_Access (SCtx.CS_Context)); return; end if; Set_Converters (GIOP_1_2_CDR_Representation (Sess.Repr.all), Get_Converter (Native_Char_Code_Set, SCtx.CS_Context.Char_Data), Get_Converter (Native_Wchar_Code_Set, SCtx.CS_Context.Wchar_Data)); end if; end; SCtx.CSN_Complete := True; end if; end Negotiate_Code_Set_And_Update_Session; ------------------------- -- Send_Cancel_Request -- ------------------------- procedure Send_Cancel_Request (Implem : access GIOP_Implem_1_2; S : access Session'Class; R : Request_Access) is pragma Warnings (Off); pragma Unreferenced (Implem); pragma Warnings (On); use PolyORB.ORB; Sess : GIOP_Session renames GIOP_Session (S.all); MCtx : aliased GIOP_Message_Context_1_2; Error : Errors.Error_Container; begin if Sess.Role = Server then raise Bidirectionnal_GIOP_Not_Implemented; end if; MCtx.Fragmented := False; MCtx.Message_Type := Cancel_Request; Common_Send_Cancel_Request (Sess'Access, R, MCtx'Access, Error); if Found (Error) then Catch (Error); raise GIOP_Error; end if; end Send_Cancel_Request; --------------------------------- -- Unmarshalling / Marshalling -- --------------------------------- ---------------------------- -- Unmarshall_GIOP_Header -- ---------------------------- procedure Unmarshall_GIOP_Header (Implem : access GIOP_Implem_1_2; MCtx : access GIOP_Message_Context'Class; Buffer : access Buffers.Buffer_Type) is use Octet_Flags; pragma Warnings (Off); pragma Unreferenced (Implem); pragma Warnings (On); MCtx_1_2 : GIOP_Message_Context_1_2 renames GIOP_Message_Context_1_2 (MCtx.all); Flags : Types.Octet; begin pragma Debug (C, O ("Unmarshall_GIOP_Header")); -- Flags Flags := Unmarshall (Buffer); pragma Debug (C, O ("Flags : " & Flags'Img)); if Is_Set (Bit_Little_Endian, Flags) then MCtx_1_2.Message_Endianness := Little_Endian; else MCtx_1_2.Message_Endianness := Big_Endian; end if; pragma Assert (MCtx_1_2.Message_Endianness = Endianness (Buffer)); pragma Debug (C, O ("Message Endianness : " & MCtx.Message_Endianness'Img)); MCtx_1_2.Fragmented := Is_Set (Bit_Fragment, Flags); pragma Debug (C, O ("Message Fragment : " & MCtx_1_2.Fragmented'Img)); -- Message type MCtx_1_2.Message_Type := Unmarshall (Buffer); pragma Debug (C, O ("Message Type : " & MCtx_1_2.Message_Type'Img)); -- Message size MCtx_1_2.Message_Size := Unmarshall (Buffer); pragma Debug (C, O ("Message Size :" & MCtx_1_2.Message_Size'Img)); if MCtx_1_2.Message_Type = Fragment then MCtx_1_2.Frag_State := Req; MCtx_1_2.Frag_Size := MCtx_1_2.Message_Size - Frag_Header_Size; MCtx_1_2.Message_Size := Frag_Header_Size; elsif MCtx_1_2.Fragmented then -- First fragment of a fragmented message MCtx_1_2.Frag_State := First; MCtx_1_2.Frag_Size := MCtx_1_2.Message_Size - Frag_Header_Size; MCtx_1_2.Frag_Type := MCtx_1_2.Message_Type; MCtx_1_2.Message_Size := Frag_Header_Size; MCtx_1_2.Message_Type := Fragment; end if; end Unmarshall_GIOP_Header; -------------------------- -- Marshall_GIOP_Header -- -------------------------- procedure Marshall_GIOP_Header (Implem : access GIOP_Implem_1_2; S : access Session'Class; MCtx : access GIOP_Message_Context'Class; Buffer : access Buffers.Buffer_Type) is pragma Unreferenced (Implem, S); use Octet_Flags; MCtx_1_2 : GIOP_Message_Context_1_2 renames GIOP_Message_Context_1_2 (MCtx.all); Flags : Types.Octet := 0; begin Set (Flags, Bit_Little_Endian, Endianness (Buffer) = Little_Endian); Set (Flags, Bit_Fragment, MCtx_1_2.Fragmented); Marshall (Buffer, Flags); Marshall (Buffer, MCtx_1_2.Message_Type); Marshall (Buffer, MCtx_1_2.Message_Size); end Marshall_GIOP_Header; -------------------------------- -- Unmarshall_Request_Message -- -------------------------------- procedure Unmarshall_Request_Message (Buffer : access Buffer_Type; MCtx : access GIOP_Message_Context_1_2; Sync : out Sync_Scope; Target_Ref : out Target_Address_Access; Operation : out Types.String; Service_Contexts : out QoS_GIOP_Service_Contexts_Parameter_Access) is Received_Flags : Types.Octet; Address_Disp : Addressing_Disposition; Sink : Types.Octet; pragma Unreferenced (Sink); begin pragma Debug (C, O ("Request_Id :" & MCtx.Request_Id'Img)); -- Response flags Received_Flags := Unmarshall (Buffer); case Received_Flags is when 0 => Sync := WITH_TRANSPORT; -- At this level, we cannot dissociate NONE from -- WITH_TRANSPORT. Besides, this makes no difference at -- this level. We assume WITH_TRANSPORT. when 1 => Sync := WITH_SERVER; when 3 => Sync := WITH_TARGET; when others => raise GIOP_Error; end case; pragma Debug (C, O ("Sync : " & Sync'Img)); -- Reserved for J in 1 .. 3 loop Sink := Unmarshall (Buffer); -- Ignore unmarshalled value. Note that TAO may set these bytes to -- non-zero values. end loop; -- Target Reference Address_Disp := Unmarshall (Buffer); pragma Debug (C, O ("Addr_Type : " & Address_Disp'Img)); case Address_Disp is when Key_Addr => declare Obj : constant Stream_Element_Array := Unmarshall (Buffer); begin Target_Ref := new Target_Address' (Address_Type => Key_Addr, Object_Key => new Object_Id'(Object_Id (Obj))); end; when Profile_Addr => declare use PolyORB.Binding_Data; use PolyORB.References.IOR; Pro : Binding_Data.Profile_Access; begin Pro := Unmarshall_Profile (Buffer); if Pro = null then pragma Debug (C, O ("Incorrect profile")); raise GIOP_Error; end if; Target_Ref := new Target_Address' (Address_Type => Profile_Addr, Profile => Pro); end; when Reference_Addr => declare Ref : constant IOR_Addressing_Info_Access := new IOR_Addressing_Info; begin Ref.Selected_Profile_Index := Unmarshall (Buffer); Ref.IOR := Unmarshall (Buffer); Target_Ref := new Target_Address' (Address_Type => Reference_Addr, Ref => Ref); end; end case; -- Operation Operation := Types.String (Types.Identifier'(Unmarshall (Buffer))); pragma Debug (C, O ("Operation : " & Types.To_Standard_String (Operation))); -- Service context Unmarshall_Service_Context_List (Buffer, Service_Contexts); end Unmarshall_Request_Message; -------------------------------- -- Marshall_GIOP_Header_Reply -- -------------------------------- procedure Marshall_GIOP_Header_Reply (Implem : access GIOP_Implem_1_2; S : access Session'Class; R : Request_Access; MCtx : access GIOP_Message_Context'Class; Buffer : access Buffers.Buffer_Type) is pragma Unreferenced (Implem, S); MCtx_1_2 : GIOP_Message_Context_1_2 renames GIOP_Message_Context_1_2 (MCtx.all); begin Marshall (Buffer, MCtx_1_2.Request_Id); Marshall (Buffer, MCtx_1_2.Reply_Status); Rebuild_Reply_Service_Contexts (R.all); Marshall_Service_Context_List (Buffer, QoS_GIOP_Service_Contexts_Parameter_Access (Extract_Reply_Parameter (GIOP_Service_Contexts, R.all))); end Marshall_GIOP_Header_Reply; ----------------------------- -- Marshall_Locate_Request -- ----------------------------- procedure Marshall_Locate_Request (Buffer : Buffer_Access; Request_Id : Types.Unsigned_Long; Target_Ref : Target_Address) is begin -- Request id Marshall (Buffer, Request_Id); -- Target address Marshall (Buffer, Target_Ref.Address_Type); case Target_Ref.Address_Type is when Key_Addr => Marshall (Buffer, Stream_Element_Array (Target_Ref.Object_Key.all)); when Profile_Addr => declare use PolyORB.References.IOR; Success : Boolean; begin Marshall (Buffer, Profile_Addr); Marshall_Profile (Buffer, Target_Ref.Profile, Success); if not Success then pragma Debug (C, O ("Incorrect profile")); raise GIOP_Error; end if; end; when Reference_Addr => Marshall (Buffer, Target_Ref.Ref.Selected_Profile_Index); References.IOR.Marshall_IOR (Buffer, Target_Ref.Ref.IOR); end case; end Marshall_Locate_Request; ------------------------------ -- Store_Reassembly_Context -- ------------------------------ procedure Store_Reassembly_Context (SCtx : access GIOP_Session_Context_1_2; MCtx : GIOP_Message_Context_Access) is use GIOP_Message_Context_Lists; begin Prepend (SCtx.Reassembly_Contexts, MCtx); GIOP_Message_Context_1_2 (MCtx.all).Frag_Position := First (SCtx.Reassembly_Contexts); end Store_Reassembly_Context; ---------------------------- -- Get_Reassembly_Context -- ---------------------------- function Get_Reassembly_Context (SCtx : access GIOP_Session_Context_1_2; Request_Id : Types.Unsigned_Long) return GIOP_Message_Context_Access is use GIOP_Message_Context_Lists; It : Iterator := First (SCtx.Reassembly_Contexts); begin while not Last (It) loop if Value (It).all.Request_Id = Request_Id then return Value (It).all; end if; Next (It); end loop; return null; end Get_Reassembly_Context; ------------------------------- -- Remove_Reassembly_Context -- ------------------------------- procedure Remove_Reassembly_Context (SCtx : access GIOP_Session_Context_1_2; MCtx : in out GIOP_Message_Context_Access) is use GIOP_Message_Context_Lists; begin Remove (SCtx.Reassembly_Contexts, GIOP_Message_Context_1_2 (MCtx.all).Frag_Position); Free (MCtx); end Remove_Reassembly_Context; ---------------- -- New_Implem -- ---------------- function New_Implem return GIOP_Implem_Access; function New_Implem return GIOP_Implem_Access is begin return new GIOP_Implem_1_2; end New_Implem; ---------------- -- Initialize -- ---------------- procedure Initialize; procedure Initialize is begin Global_Register_GIOP_Version (GIOP_V1_2, New_Implem'Access); end Initialize; use PolyORB.Initialization; use PolyORB.Initialization.String_Lists; use PolyORB.Utils.Strings; begin Register_Module (Module_Info' (Name => +"protocols.giop.giop_1_2", Conflicts => Empty, Depends => Empty, Provides => Empty, Implicit => False, Init => Initialize'Access, Shutdown => null)); end PolyORB.Protocols.GIOP.GIOP_1_2; polyorb-2.8~20110207.orig/src/polyorb-log.ads0000644000175000017500000001142211750740340020127 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . L O G -- -- -- -- S p e c -- -- -- -- Copyright (C) 2001-2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- Logging support for PolyORB package PolyORB.Log is pragma Preelaborate; -- Log_Levels are used to classify the importance of messages type Log_Level is (Unknown, -- The log level for this facility has not been defined yet Debug, -- Developer interest only, should never be displayed in a production -- environment. Info, -- Informational message indicating progress of normal operation Notice, -- Notesworthy message in normal operation Warning, -- Indication that a condition may be abnormal and requires attention Error, -- Indication that an abnormal condition has been identified Critical -- Indication that an abnormal condition has been identified, and that -- immediate attention is required to resume normal operation. ); -- Generic package providing logging support for one facility. -- Note: the user is responsible for ensuring that the lifetime of any -- instance of the generic is no less than that of library package -- PolyORB.Log. generic Facility : String; package Facility_Log is -- NOTE: these procedures are not thread safe procedure Output (Message : String; Level : Log_Level := Debug); -- Log Message when Level is at least equal to the user-requested level -- for Facility. function Enabled (Level : Log_Level := Debug) return Boolean; pragma Inline (Enabled); -- True when Level is at least equal to the user-requested level -- for Facility. end Facility_Log; ------------------------------------------------------ -- Integration with runtime configuration subsystem -- ------------------------------------------------------ Log_Section : constant String := "log"; Default_Log_Level : Log_Level := Notice; -- Log level associated with a facility when none is specified by the -- user. This can be overridden by setting the "default" parameter in the -- Log_Section configuration section. package Internals is procedure Put_Line (S : String); -- Output S to stderr. -- Note: this function is to be utilised if and only if we cannot -- instantiate PolyORB.Log.Facility_Log. type Log_Hook_T is access procedure (S : String); Log_Hook : Log_Hook_T; end Internals; private procedure Initialize; -- During early initialization (before the logging and configuration -- modules are properly initialized), messages are stored in a buffer. -- This procedure is called when logging is initialized to process -- buffered messages. It also sets Default_Log_Level from the configuration -- file, if an explicit value is provided. end PolyORB.Log; polyorb-2.8~20110207.orig/src/polyorb-orb-thread_pool.adb0000644000175000017500000003350011750740340022406 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . O R B . T H R E A D _ P O O L -- -- -- -- B o d y -- -- -- -- Copyright (C) 2001-2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with PolyORB.Components; with PolyORB.Filters.Iface; with PolyORB.Initialization; with PolyORB.Log; with PolyORB.ORB_Controller; with PolyORB.Parameters; with PolyORB.Setup; with PolyORB.Task_Info; with PolyORB.Tasking.Condition_Variables; with PolyORB.Tasking.Threads; with PolyORB.Utils.Strings; package body PolyORB.ORB.Thread_Pool is use PolyORB.Filters.Iface; use PolyORB.Log; use PolyORB.ORB_Controller; use PolyORB.Parameters; use PolyORB.Task_Info; use PolyORB.Tasking.Threads; package L is new PolyORB.Log.Facility_Log ("polyorb.orb.thread_pool"); procedure O (Message : String; Level : Log_Level := Debug) renames L.Output; function C (Level : Log_Level := Debug) return Boolean renames L.Enabled; ---------------------------- -- Operational parameters -- ---------------------------- Start_Threads : Natural; -- Threads craeted initially Minimum_Spare_Threads : Natural; -- Minimal number of idle threads to maintain continuously Maximum_Spare_Threads : Natural; -- Maximum number of idel threads Maximum_Threads : Natural; -- Maximum number of threads Default_Start_Threads : constant := 4; Default_Minimum_Spare_Threads : constant := 2; Default_Maximum_Spare_Threads : constant := 4; Default_Maximum_Threads : constant := 10; procedure Thread_Pool_Main_Loop; -- Main loop for threads in the pool procedure Check_Spares (ORB : ORB_Access); -- Check the current count of spare (idle) tasks, and create a new one -- if necessary. This must be called within the ORB critical section. --------------------------- -- Thread_Pool_Main_Loop -- --------------------------- procedure Thread_Pool_Main_Loop is begin pragma Debug (C, O ("Thread_Pool_Main_Loop: enter " & Image (Current_Task))); PolyORB.ORB.Run (Setup.The_ORB, May_Exit => True); pragma Debug (C, O ("Thread_Pool_Main_Loop: leave " & Image (Current_Task))); end Thread_Pool_Main_Loop; ----------------------------- -- Handle_Close_Connection -- ----------------------------- procedure Handle_Close_Connection (P : access Thread_Pool_Policy; TE : Transport_Endpoint_Access) is pragma Warnings (Off); pragma Unreferenced (P); pragma Unreferenced (TE); pragma Warnings (On); begin null; end Handle_Close_Connection; ---------------------------------- -- Handle_New_Server_Connection -- ---------------------------------- procedure Handle_New_Server_Connection (P : access Thread_Pool_Policy; ORB : ORB_Access; AC : Active_Connection) is pragma Warnings (Off); pragma Unreferenced (P, ORB); pragma Warnings (On); begin pragma Debug (C, O ("New server connection")); Components.Emit_No_Reply (Component_Access (AC.TE), Connect_Indication'(null record)); -- The newly-created channel will be monitored by general purpose ORB -- tasks when the binding object sends a Data_Expected message to the -- endpoint (which will in turn send Monitor_Endpoint to the ORB). end Handle_New_Server_Connection; ---------------------------------- -- Handle_New_Client_Connection -- ---------------------------------- procedure Handle_New_Client_Connection (P : access Thread_Pool_Policy; ORB : ORB_Access; AC : Active_Connection) is pragma Warnings (Off); pragma Unreferenced (P, ORB); pragma Warnings (On); begin pragma Debug (C, O ("New client connection")); Components.Emit_No_Reply (Component_Access (AC.TE), Connect_Confirmation'(null record)); -- Same comment as Handle_New_Server_Connection. end Handle_New_Client_Connection; ------------------ -- Check_Spares -- ------------------ procedure Check_Spares (ORB : ORB_Access) is OC : ORB_Controller.ORB_Controller'Class renames ORB.ORB_Controller.all; Current_Spares : Natural; Max_New_Spares : Integer; New_Spares : Integer; begin Current_Spares := Get_Tasks_Count (OC, Kind => Permanent, State => Idle); New_Spares := 0; if Current_Spares < Minimum_Spare_Threads and then not Shutting_Down (OC) then -- Note that Max_New_Spares is declared as an Integer, not a Natural, -- because Get_Tasks_Count (OC, Kind => Permanent) may exceed -- Maximum_Threads, for example if the pool when initialized already -- has reached Maximum_Threads, and the user provides an extra -- permanent task with an explicit call to the ORB main loop. If -- Max_New_Spares happens to be negative, no new spares are created. Max_New_Spares := Integer'Min (Maximum_Threads - Get_Tasks_Count (OC, Kind => Permanent), Maximum_Spare_Threads - Current_Spares); New_Spares := Integer'Min (Minimum_Spare_Threads - Current_Spares, Max_New_Spares); end if; pragma Debug (C, O ("Check_Spares: Cur =" & Current_Spares'Img & " Max_New =" & Max_New_Spares'Img & " New =" & New_Spares'Img)); for J in 1 .. New_Spares loop pragma Debug (C, O ("Creating new spare task")); Create_Task (Thread_Pool_Main_Loop'Access); end loop; end Check_Spares; ------------------------------ -- Handle_Request_Execution -- ------------------------------ procedure Handle_Request_Execution (P : access Thread_Pool_Policy; ORB : ORB_Access; RJ : access Request_Job'Class) is pragma Unreferenced (P); begin -- Queue Request_Job to general ORB controller job queue Enter_ORB_Critical_Section (ORB.ORB_Controller); Notify_Event (ORB.ORB_Controller, Event'(Kind => Queue_Request_Job, Request_Job => Job_Access (RJ), Target => RJ.Request.Target)); Leave_ORB_Critical_Section (ORB.ORB_Controller); end Handle_Request_Execution; ---------- -- Idle -- ---------- procedure Idle (P : access Thread_Pool_Policy; This_Task : PTI.Task_Info_Access; ORB : ORB_Access) is pragma Unreferenced (P); package PTCV renames PolyORB.Tasking.Condition_Variables; begin -- We are currently in the ORB critical section -- Terminate permanent task if there are too many idle tasks. -- Note that in the presence of user permanent tasks (for which -- May_Exit is False) we may not always be able to maintain -- the invariant, since we can't decide to remove these tasks -- from the pool. if This_Task.Kind = Permanent and then May_Exit (This_Task.all) and then Get_Tasks_Count (ORB.ORB_Controller.all, Kind => Permanent, State => Idle) > Maximum_Spare_Threads then Terminate_Task (ORB.ORB_Controller, This_Task); return; end if; pragma Debug (C, O ("Thread " & Image (PTI.Id (This_Task.all)) & " going idle")); PTCV.Wait (PTI.Condition (This_Task.all), PTI.Mutex (This_Task.all)); -- This task is about to leave Idle state: check whether new spares -- need to be created. Check_Spares (ORB); pragma Debug (C, O ("Thread " & Image (PTI.Id (This_Task.all)) & " leaving idle")); end Idle; ------------------------- -- Get_Maximum_Threads -- ------------------------- function Get_Maximum_Threads return Natural is begin return Maximum_Threads; end Get_Maximum_Threads; ------------------------------- -- Get_Maximum_Spare_Threads -- ------------------------------- function Get_Maximum_Spare_Threads return Natural is begin return Maximum_Spare_Threads; end Get_Maximum_Spare_Threads; ------------------------------- -- Get_Minimum_Spare_Threads -- ------------------------------- function Get_Minimum_Spare_Threads return Natural is begin return Minimum_Spare_Threads; end Get_Minimum_Spare_Threads; -------------------------------------- -- Initialize_Tasking_Policy_Access -- -------------------------------------- procedure Initialize_Tasking_Policy_Access; procedure Initialize_Tasking_Policy_Access is begin Setup.The_Tasking_Policy := new Thread_Pool_Policy; -- Set Maximum_Threads, Start_Threads, Maximum_Spare_Threads and -- Minimum_Spare_Threads from configuration and defaults. -- Note that the order in which these values are computed is -- significant, because computed values are used to provide -- consistent defaults: if not all four variables are specified by -- the user, and the values specified explicitly are consistent, then -- we want to set the remaining variables to consistent values. -- For example, the default value of Start_Threads is 4, but if the -- user sets Maximum_Threads to 2 and leaves Start_Threads unspecified, -- we want to change the default Start_Threads value to 2, rather than -- to report an inconsistency. Maximum_Threads := Get_Conf ("tasking", "max_threads", Default_Maximum_Threads); Start_Threads := Get_Conf ("tasking", "start_threads", Natural'Min (Maximum_Threads, Default_Start_Threads)); Maximum_Spare_Threads := Get_Conf ("tasking", "max_spare_threads", Natural'Min (Maximum_Threads, Default_Maximum_Spare_Threads)); Minimum_Spare_Threads := Get_Conf ("tasking", "min_spare_threads", Natural'Min (Maximum_Spare_Threads, Default_Minimum_Spare_Threads)); -- Check consistency of configured values if not (Maximum_Threads >= Maximum_Spare_Threads and then Maximum_Threads >= Start_Threads and then Maximum_Spare_Threads >= Minimum_Spare_Threads) then raise Constraint_Error; end if; if Start_Threads < Minimum_Spare_Threads then Start_Threads := Minimum_Spare_Threads; end if; end Initialize_Tasking_Policy_Access; procedure Create_Threads; -- Initial creation of threads for the pool -------------------- -- Create_Threads -- -------------------- procedure Create_Threads is begin pragma Debug (C, O ("Create_Threads: enter")); pragma Debug (C, O ("Creating" & Start_Threads'Img & " threads")); for J in 1 .. Start_Threads loop Create_Task (Thread_Pool_Main_Loop'Access); end loop; pragma Debug (C, O ("Create_Threads: leave")); end Create_Threads; use PolyORB.Initialization; use PolyORB.Initialization.String_Lists; use PolyORB.Utils.Strings; begin Register_Module (Module_Info' (Name => +"orb.thread_pool", Conflicts => +"no_tasking", Depends => +"tasking.threads", Provides => +"orb.tasking_policy!", Implicit => False, Init => Initialize_Tasking_Policy_Access'Access, Shutdown => null)); Register_Module (Module_Info' (Name => +"orb.threads_init", Conflicts => +"no_tasking", Depends => +"orb" & "orb_controller", Provides => +"orb.tasking_policy_init", Implicit => False, Init => Create_Threads'Access, Shutdown => null)); -- Two Register_Module are needed because, on one hand, the -- variable Setup.The_Tasking_Policy must be initialized before -- ORB creation and on the other hand, the variable Setup.The_ORB -- must be initialized in order to run threads from the -- thread_pool. This breaks the circular dependency at -- initialisation. end PolyORB.ORB.Thread_Pool; polyorb-2.8~20110207.orig/src/polyorb-any-exceptionlist.ads0000644000175000017500000000642011750740340023027 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . A N Y . E X C E P T I O N L I S T -- -- -- -- S p e c -- -- -- -- Copyright (C) 2002-2007, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with PolyORB.Any; with PolyORB.Smart_Pointers; pragma Elaborate_All (PolyORB.Smart_Pointers); with PolyORB.Types; with PolyORB.Utils.Chained_Lists; package PolyORB.Any.ExceptionList is pragma Elaborate_Body; type Ref is new PolyORB.Smart_Pointers.Ref with null record; Nil_Ref : constant Ref; function Get_Count (Self : Ref) return PolyORB.Types.Unsigned_Long; procedure Add (Self : Ref; Exc : TypeCode.Local_Ref); function Item (Self : Ref; Index : Types.Unsigned_Long) return TypeCode.Local_Ref; procedure Remove (Self : Ref; Index : PolyORB.Types.Unsigned_Long); procedure Create_List (Self : out Ref); function Search_Exception_Id (Self : Ref; Name : Types.String) return Types.Unsigned_Long; private use PolyORB.Any.TypeCode; Nil_Ref : constant Ref := (PolyORB.Smart_Pointers.Ref with null record); -- The actual implementation of an ExceptionList: a list of TypeCodes package Exception_Lists is new PolyORB.Utils.Chained_Lists (PolyORB.Any.TypeCode.Local_Ref, Doubly_Chained => True); type Object is new PolyORB.Smart_Pointers.Non_Controlled_Entity with record List : Exception_Lists.List; end record; type Object_Ptr is access all Object; end PolyORB.Any.ExceptionList; polyorb-2.8~20110207.orig/src/polyorb-orb_controller-no_tasking.ads0000644000175000017500000000645611750740340024540 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . O R B _ C O N T R O L L E R . N O _ T A S K I N G -- -- -- -- S p e c -- -- -- -- Copyright (C) 2004-2008, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- No Tasking ORB Controller for PolyORB ORB main loop. -- This ORB Controller is dedicated to partition WITHOUT tasking, it -- supports: mono tasking ORB only package PolyORB.ORB_Controller.No_Tasking is type ORB_Controller_No_Tasking is new ORB_Controller with private; type ORB_Controller_No_Tasking_Access is access all ORB_Controller_No_Tasking'Class; procedure Notify_Event (O : access ORB_Controller_No_Tasking; E : Event); procedure Schedule_Task (O : access ORB_Controller_No_Tasking; TI : PTI.Task_Info_Access); procedure Disable_Polling (O : access ORB_Controller_No_Tasking; M : PAE.Asynch_Ev_Monitor_Access); procedure Enable_Polling (O : access ORB_Controller_No_Tasking; M : PAE.Asynch_Ev_Monitor_Access); type ORB_Controller_No_Tasking_Factory is new ORB_Controller_Factory with private; function Create (OCF : ORB_Controller_No_Tasking_Factory) return ORB_Controller_Access; private type ORB_Controller_No_Tasking is new ORB_Controller with null record; type ORB_Controller_No_Tasking_Factory is new ORB_Controller_Factory with null record; OCF : constant ORB_Controller_Factory_Access := new ORB_Controller_No_Tasking_Factory; end PolyORB.ORB_Controller.No_Tasking; polyorb-2.8~20110207.orig/src/polyorb-object_maps-user.ads0000644000175000017500000001001111750740340022601 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . O B J E C T _ M A P S . U S E R -- -- -- -- S p e c -- -- -- -- Copyright (C) 2003-2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- Implementation of an Active Object Map optimized for User defined -- Object Identifier. -- Note: this package depends on Unmarshalled_Oid constrution for -- USER_ID POA policy as defined in the package -- PolyORB.POA_Policies.Id_Assignment_Policy.User with PolyORB.Utils.HFunctions.Hyper; with PolyORB.Utils.HTables.Perfect; package PolyORB.Object_Maps.User is type User_Object_Map is new Object_Map with private; procedure Initialize (O_Map : in out User_Object_Map); procedure Finalize (O_Map : in out User_Object_Map); procedure Add (O_Map : access User_Object_Map; Obj : Object_Map_Entry_Access); -- Adds a new entry in the map. function Get_By_Id (O_Map : User_Object_Map; Item : PolyORB.POA_Types.Unmarshalled_Oid) return Object_Map_Entry_Access; -- Given an Object_Id, look up the corresponding map entry. -- If not found, returns null. function Get_By_Servant (O_Map : User_Object_Map; Item : PolyORB.Servants.Servant_Access) return Object_Map_Entry_Access; -- Given a servant, looks for the corresponding map entry -- Doesn't check that the servant is only once in the map -- If not found, returns null. function Remove_By_Id (O_Map : access User_Object_Map; Item : PolyORB.POA_Types.Unmarshalled_Oid) return Object_Map_Entry_Access; -- Given an Object_Id, removes an entry from the map -- and returns it . A null value means -- that the object_id wasn't in the map. private package Map_Entry_HTables is new PolyORB.Utils.HTables.Perfect (Object_Map_Entry_Access, PolyORB.Utils.HFunctions.Hyper.Hash_Hyper_Parameters, PolyORB.Utils.HFunctions.Hyper.Default_Hash_Parameters, PolyORB.Utils.HFunctions.Hyper.Hash, PolyORB.Utils.HFunctions.Hyper.Next_Hash_Parameters); subtype Map_EntryTable is Map_Entry_HTables.Table_Instance; type User_Object_Map is new Object_Map with record User_Map : Map_EntryTable; end record; end PolyORB.Object_Maps.User; polyorb-2.8~20110207.orig/src/polyorb-annotations.ads0000644000175000017500000000732011750740340021705 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . A N N O T A T I O N S -- -- -- -- S p e c -- -- -- -- Copyright (C) 2001-2009, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- Support the addition of external information ("annotations") -- to objects by their client. The object does not need to have -- visibility on the client in order to allow itself to be annotated; -- it only needs to expose a Notepad attribute. with PolyORB.Utils.Chained_Lists; package PolyORB.Annotations is pragma Preelaborate; type Note is abstract tagged private; -- A note that can be attached to an object. procedure Destroy (N : in out Note); -- Return any associated resource to the system. This primitive is -- called for every note in a notepad being destroyed. type Notepad is private; type Notepad_Access is access all Notepad; -- A space for clients of an object to attach Notes into. -- Notepad_Access can be used by private types to selectively -- expose one Notepad component to their clients. procedure Set_Note (NP : in out Notepad; N : Note'Class); -- Add note N to notepad NP. If a note with the same tag as N -- exists, it is replaced by N. procedure Get_Note (NP : Notepad; N : out Note'Class); -- Retrieve a note of N's type from NP. Constraint_Error is raised if no -- such note exists. procedure Get_Note (NP : Notepad; N : out Note'Class; Default : Note'Class); -- Retrieve a note of N's type from NP. -- Return Default if the note cannot be found. procedure Destroy (NP : in out Notepad); -- Removes all notes in NP and return any associated -- resources to the system. private type Note is abstract tagged null record; type Note_Access is access all Note'Class; package Note_Lists is new PolyORB.Utils.Chained_Lists (Note_Access); type Notepad is new Note_Lists.List; end PolyORB.Annotations; polyorb-2.8~20110207.orig/src/polyorb-setup-oa-basic_poa.adb0000644000175000017500000000774311750740340023013 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . S E T U P . O A . B A S I C _ P O A -- -- -- -- B o d y -- -- -- -- Copyright (C) 2003-2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with PolyORB.Initialization; with PolyORB.Errors; with PolyORB.Obj_Adapters; with PolyORB.ORB; with PolyORB.Setup; with PolyORB.POA.Basic_POA; with PolyORB.POA_Manager; with PolyORB.POA_Config.Root_POA; -- The configuration for the RootPOA. with PolyORB.Setup.Proxies_POA; -- XXX should be depended upon only when proxies are desired. with PolyORB.Utils.Strings; package body PolyORB.Setup.OA.Basic_POA is use PolyORB.POA.Basic_POA; use type PolyORB.POA.Obj_Adapter_Access; ---------------- -- Initialize -- ---------------- procedure Initialize; procedure Initialize is use PolyORB.Errors; Root_POA_Object : PolyORB.POA.Obj_Adapter_Access; Error : Error_Container; begin PolyORB.POA_Config.Set_Configuration (new PolyORB.POA_Config.Root_POA.Root_POA_Configuration); Root_POA_Object := new PolyORB.POA.Basic_POA.Basic_Obj_Adapter; PolyORB.POA.Create (Root_POA_Object); PolyORB.POA_Manager.Activate (PolyORB.POA_Manager.POAManager_Access (PolyORB.POA_Manager.Entity_Of (Root_POA_Object.POA_Manager)), Error); if Found (Error) then Catch (Error); raise Program_Error; end if; -- Link object adapter with ORB. PolyORB.ORB.Set_Object_Adapter (PolyORB.Setup.The_ORB, PolyORB.Obj_Adapters.Obj_Adapter_Access (Root_POA_Object)); PolyORB.Setup.Proxies_POA (Root_POA_Object, Error); if Found (Error) then Catch (Error); raise Program_Error; end if; end Initialize; use PolyORB.Initialization; use PolyORB.Initialization.String_Lists; use PolyORB.Utils.Strings; begin Register_Module (Module_Info' (Name => +"basic_poa", Conflicts => Empty, Depends => +"orb", Provides => +"object_adapter" & "poa", Implicit => False, Init => Initialize'Access, Shutdown => null)); end PolyORB.Setup.OA.Basic_POA; polyorb-2.8~20110207.orig/src/polyorb-requests.adb0000644000175000017500000011355411750740340021211 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . R E Q U E S T S -- -- -- -- B o d y -- -- -- -- Copyright (C) 2001-2011, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with Ada.Unchecked_Deallocation; with PolyORB.Errors.Helper; with PolyORB.Log; with PolyORB.ORB.Iface; with PolyORB.Protocols.Iface; with PolyORB.Request_QoS; with PolyORB.Setup; with PolyORB.Tasking.Threads; package body PolyORB.Requests is use PolyORB.Log; use PolyORB.Types; package L is new PolyORB.Log.Facility_Log ("polyorb.requests"); procedure O (Message : String; Level : Log_Level := Debug) renames L.Output; function C (Level : Log_Level := Debug) return Boolean renames L.Enabled; procedure Pump_Up_Arguments_Unspecified (Dst_Args : in out Any.NVList.Ref; Src_Args : Any.NVList.Ref; Direction : Any.Flags; Error : in out Error_Container; Ignore_Src_Mode : Boolean; Can_Extend : Boolean := False); procedure Pump_Up_Arguments_By_Position (Dst_Args : in out Any.NVList.Ref; Src_Args : Any.NVList.Ref; Direction : Any.Flags; Error : in out Error_Container; Ignore_Src_Mode : Boolean; Can_Extend : Boolean := False); procedure Pump_Up_Arguments_By_Name (Dst_Args : in out Any.NVList.Ref; Src_Args : Any.NVList.Ref; Direction : Any.Flags; Error : in out Error_Container; Ignore_Src_Mode : Boolean; Can_Extend : Boolean := False); -- True arguments of direction Direction (or INOUT) from received protocol -- arguments list P_Args (either from a request, on server side, or for a -- reply, on client side) into A_Args. If Can_Extend is set to True and -- Src_Args contains extra arguments that are not required by Dst_Args, -- then they are appended. -- -- Each variant of the Pump_Up_Arguments procedure corresponds to a -- reconciliation method, according to the identification capabilities of -- the personalities. procedure Free is new Ada.Unchecked_Deallocation (Request, Request_Access); type Request_Completion_Runnable (Req : access Request) is new Tasking.Threads.Runnable with null record; overriding procedure Run (R : not null access Request_Completion_Runnable); -------------------- -- Create_Request -- -------------------- procedure Create_Request (Target : References.Ref; Operation : String; Arg_List : Any.NVList.Ref; Result : in out Any.NamedValue; Exc_List : Any.ExceptionList.Ref := Any.ExceptionList.Nil_Ref; Req : out Request_Access; Req_Flags : Flags := Default_Flags; Deferred_Arguments_Session : Components.Component_Access := null; Identification : Arguments_Identification := Ident_By_Position; Dependent_Binding_Object : Smart_Pointers.Entity_Ptr := null) is use PolyORB.Request_QoS; use type Smart_Pointers.Entity_Ptr; begin pragma Debug (C, O ("Create_Request: enter")); Req := new Request; Setup_Request (Req => Req.all, Target => Target, Operation => Operation, Arg_List => Arg_List, Result => Result, Exc_List => Exc_List, Req_Flags => Req_Flags, Deferred_Arguments_Session => Deferred_Arguments_Session, Identification => Identification, Dependent_Binding_Object => Dependent_Binding_Object); pragma Debug (C, O ("Create_Request: leave")); end Create_Request; --------------------- -- Destroy_Request -- --------------------- procedure Destroy_Request (Req : in out Request_Access) is begin Free (Req); end Destroy_Request; ---------------- -- Initialize -- ---------------- procedure Initialize (Req : in out Request) is begin Tasking.Mutexes.Create (Req.Upcall_Abortable_Mutex); end Initialize; -------------- -- Finalize -- -------------- procedure Finalize (Req : in out Request) is begin PolyORB.Utils.Strings.Free (Req.Operation); Annotations.Destroy (Req.Notepad); Tasking.Mutexes.Destroy (Req.Upcall_Abortable_Mutex); end Finalize; ------------ -- Invoke -- ------------ procedure Invoke (Self : access Request; Invoke_Flags : Flags := 0; Timeout : Duration := 0.0) is pragma Warnings (Off); pragma Unreferenced (Invoke_Flags); pragma Warnings (On); use PolyORB.ORB; use PolyORB.ORB.Iface; use PolyORB.Setup; Req : constant Request_Access := Self.all'Unchecked_Access; R : aliased Request_Completion_Runnable (Self); begin PolyORB.ORB.Queue_Request_To_Handler (The_ORB, Queue_Request'(Request => Req, Requestor => Req.Requesting_Component)); -- Execute the ORB until the request is completed if Timeout = 0.0 then R.Run; else declare use Tasking.Abortables; pragma Warnings (Off); -- WAG:FSF-4.5.0 -- Hide warning "AR is not referenced" AR : aliased Abortable'Class := Make_Abortable (Abortable_Tag, R'Access); pragma Warnings (On); Expired : Boolean := False; Error : Errors.Error_Container; begin AR.Run_With_Timeout (Timeout, Expired); if Expired then Throw (Error, Timeout_E, System_Exception_Members' (Minor => 1, Completed => Completed_Maybe)); Set_Exception (Req.all, Error); end if; end; end if; end Invoke; ----------------------------------- -- Pump_Up_Arguments_By_Position -- ----------------------------------- procedure Pump_Up_Arguments_By_Position (Dst_Args : in out Any.NVList.Ref; Src_Args : Any.NVList.Ref; Direction : Any.Flags; Error : in out Error_Container; Ignore_Src_Mode : Boolean; Can_Extend : Boolean := False) is use PolyORB.Any; use PolyORB.Any.NVList; use PolyORB.Any.NVList.Internals; use PolyORB.Any.NVList.Internals.NV_Lists; use PolyORB.Components; Src_It : Iterator := First (List_Of (Src_Args).all); Dst_It : Iterator := First (List_Of (Dst_Args).all); begin if Same_Entity (Src_Args, Dst_Args) then return; end if; pragma Assert (Direction = ARG_IN or else Direction = ARG_OUT); -- When Direction is ARG_IN, we are a server and we are pumping -- arguments from an incoming request message into the request that will -- be processed by the actual application object. In this case, we know -- that arguments in Dst_Args have their correct canonical modes and -- names. We assume that Src_Args only contain arguments whose actual -- mode (as specifid in Dst_Args) is ARG_IN or ARG_INOUT, possibly -- without names. If without names, we assume that they are in the order -- of Dst_Args. -- When direction is ARG_OUT, we are a client and we are pumping up -- INOUT and OUT arguments from an incoming reply message into the -- request that will be handed back to the client appplication object. -- (no return value must be present in Src_Args, only actual arguments). -- We assume that Src_Args only contain arguments whose actual mode is -- ARG_INOUT or ARG_OUT, possibly without names, and if without names in -- the order of Dst_Args. -- Note that we cannot rely on the mode indications in Src_Args because -- some protocols (eg SOAP) do not set it correcly (more specifically -- SOAP does not support deferred unmarshalling, and insist on -- unmarshalling Self.Args before Arguments is called. Consequence: -- 'OUT' mode arguments might be missing in Self.Args, and 'INOUT' -- arguments might be marked as 'IN'. Also, there is no guarantee that -- the order of arguments is the same in Args and Self.Args.) while not Last (Dst_It) loop declare Dst_Arg : constant Element_Access := Value (Dst_It); begin if Dst_Arg.Arg_Modes = ARG_INOUT or else Dst_Arg.Arg_Modes = Direction then -- This arguments needs to be pumped up from the Src_Args list. -- If Ignore_Arg_Mode is True, we assume that Src contains only -- arguments that actually need to be copied, else we check the -- arg modes of Src args and copy only those that need to, -- according to Direction. loop declare Src_Arg : constant Element_Access := Value (Src_It); begin if Ignore_Src_Mode or else Src_Arg.Arg_Modes = ARG_INOUT or else Src_Arg.Arg_Modes = Direction then -- These MUST be type-compatible! -- Also, if Dst_Arg already provides storage for the -- argument value, we must assign in place using -- Copy_Value (we cannot transfer the value from -- Src_Arg). if Is_Empty (Dst_Arg.Argument) then Move_Any_Value (Dst_Arg.Argument, Src_Arg.Argument); else Copy_Any_Value (Dst_Arg.Argument, Src_Arg.Argument); end if; Next (Src_It); exit; else Next (Src_It); if Last (Src_It) then pragma Debug (C, O ("argument not found")); Throw (Error, Bad_Param_E, System_Exception_Members' (Minor => 1, Completed => Completed_No)); return; end if; end if; end; end loop; end if; Next (Dst_It); end; end loop; if Can_Extend then pragma Debug (C, O ("Appending remaining arguments")); -- If Dst_Args is an extensible NV_List, then we append the -- remaining Src_Args. while not Last (Src_It) loop if Ignore_Src_Mode or else Value (Src_It).Arg_Modes = ARG_INOUT or else Value (Src_It).Arg_Modes = Direction then Add_Item (Dst_Args, Value (Src_It).all); end if; Next (Src_It); end loop; end if; end Pump_Up_Arguments_By_Position; ------------------------------- -- Pump_Up_Arguments_By_Name -- ------------------------------- procedure Pump_Up_Arguments_By_Name (Dst_Args : in out Any.NVList.Ref; Src_Args : Any.NVList.Ref; Direction : Any.Flags; Error : in out Error_Container; Ignore_Src_Mode : Boolean; Can_Extend : Boolean := False) is use PolyORB.Components; use PolyORB.Any; use PolyORB.Any.NVList; use PolyORB.Any.NVList.Internals; use PolyORB.Any.NVList.Internals.NV_Lists; Dst_It : Iterator := First (List_Of (Dst_Args).all); Copied_Src_Args : array (1 .. Get_Count (Src_Args)) of Boolean := (others => False); Src_Idx : Long; Src_It : Iterator; begin if Same_Entity (Src_Args, Dst_Args) then return; end if; pragma Assert (Direction = ARG_IN or else Direction = ARG_OUT); -- Same comment as in Pump_Up_Arguments_By_Position while not Last (Dst_It) loop declare Src_Arg_Found : Boolean := False; begin if Value (Dst_It).Arg_Modes = ARG_INOUT or else Value (Dst_It).Arg_Modes = Direction then -- This arguments needs to be pumped up from the Src_Args list. -- If Ignore_Arg_Mode is True, we assume that Src contains only -- arguments that actually need to be copied, else we check the -- arg modes of Src args and copy only those that need to, -- according to Direction. Src_It := First (List_Of (Src_Args).all); Src_Idx := Copied_Src_Args'First; pragma Debug (C, O ("Dst_Arg: " & To_String (Value (Dst_It).Name))); loop if (Ignore_Src_Mode or else Value (Src_It).Arg_Modes = ARG_INOUT or else Value (Src_It).Arg_Modes = Direction) and then Copied_Src_Args (Src_Idx) = False then pragma Debug (C, O ("Src_Arg: " & To_String (Value (Src_It).Name))); if PolyORB.Any.TypeCode.Equal (Get_Unwound_Type (Value (Dst_It).Argument), Get_Unwound_Type (Value (Src_It).Argument)) and then Value (Dst_It).Name = Value (Src_It).Name then pragma Debug (C, O ("Found the argument: copying")); Src_Arg_Found := True; Move_Any_Value (Value (Dst_It).Argument, Value (Src_It).Argument); Copied_Src_Args (Src_Idx) := True; exit; else Src_Idx := Src_Idx + 1; Next (Src_It); if Last (Src_It) then Src_Arg_Found := False; exit; end if; end if; end if; end loop; if not Src_Arg_Found then pragma Debug (C, O ("argument not found")); Throw (Error, Bad_Param_E, System_Exception_Members' (Minor => 1, Completed => Completed_No)); return; end if; end if; end; Next (Dst_It); end loop; if Can_Extend then -- If Dst_Args is an extensible NV_List, then we append the remaining -- Src_Args. Src_It := First (List_Of (Src_Args).all); Src_Idx := Copied_Src_Args'First; pragma Debug (C, O ("Appending remaining arguments")); while not Last (Src_It) loop if (Ignore_Src_Mode or else Value (Src_It).Arg_Modes = ARG_INOUT or else Value (Src_It).Arg_Modes = Direction) and then Copied_Src_Args (Src_Idx) = False then Add_Item (Dst_Args, Value (Src_It).all); end if; Next (Src_It); Src_Idx := Src_Idx + 1; end loop; end if; end Pump_Up_Arguments_By_Name; ----------------------------------- -- Pump_Up_Arguments_Unspecified -- ----------------------------------- procedure Pump_Up_Arguments_Unspecified (Dst_Args : in out Any.NVList.Ref; Src_Args : Any.NVList.Ref; Direction : Any.Flags; Error : in out Error_Container; Ignore_Src_Mode : Boolean; Can_Extend : Boolean := False) is use PolyORB.Components; use PolyORB.Any; use PolyORB.Any.NVList; use PolyORB.Any.NVList.Internals; use PolyORB.Any.NVList.Internals.NV_Lists; function Name_Exists (Name : Types.Identifier; From : Iterator) return Boolean; -- True if, and only if, the list on which From iterates contains a -- NamedValue whose name is Name between the position denoted by From -- and the end of the list. function Name_Exists (Name : Types.Identifier; From : Iterator) return Boolean is It : Iterator := From; begin while not Last (It) loop if Value (It).Name = Name then return True; end if; Next (It); end loop; return False; end Name_Exists; Dst_It : Iterator := First (List_Of (Dst_Args).all); Copied_Src_Args : array (1 .. Get_Count (Src_Args)) of Boolean := (others => False); Src_Idx : Long; Src_It : Iterator; Copy_Argument : Boolean; Identification_By_Name, Identification_By_Position : Boolean := True; -- By default, we assume that arguments are identified by both name and -- position (this is the ideal case). begin if Same_Entity (Src_Args, Dst_Args) then return; end if; pragma Assert (Direction = ARG_IN or else Direction = ARG_OUT); -- Same comments as in Pump_Up_Arguments_By_Position while not Last (Dst_It) loop declare Src_Arg_Found : Boolean := False; begin if Value (Dst_It).Arg_Modes = ARG_INOUT or else Value (Dst_It).Arg_Modes = Direction then -- This arguments needs to be pumped up from the Src_Args list. -- If Ignore_Arg_Mode is True, we assume that Src contains only -- arguments that actually need to be copied, else we check the -- arg modes of Src args and copy only those that need to, -- according to Direction. Src_It := First (List_Of (Src_Args).all); Src_Idx := Copied_Src_Args'First; pragma Debug (C, O ("Dst_Arg: " & To_String (Value (Dst_It).Name))); loop Copy_Argument := False; -- By default, we will not copy the argument: it is up to -- the algorithm to decide it. if (Ignore_Src_Mode or else Value (Src_It).Arg_Modes = ARG_INOUT or else Value (Src_It).Arg_Modes = Direction) and then Copied_Src_Args (Src_Idx) = False then declare Dst_Arg_Type : constant TypeCode.Object_Ptr := Get_Unwound_Type (Value (Dst_It).Argument); begin pragma Debug (C, O ("Src_Arg: " & To_String (Value (Src_It).Name))); if PolyORB.Any.TypeCode.Equal (Dst_Arg_Type, Get_Unwound_Type (Value (Src_It).Argument)) then if Value (Dst_It).Name = Value (Src_It).Name then Copy_Argument := True; -- The arguments match in name and type. Thus -- we can perform the copy, as the arguments -- are identified both by name and position. else if Identification_By_Position and then not Identification_By_Name then Copy_Argument := True; -- The name does not match. It is not a -- problem if we are identifying arguments by -- their positions and not by their names, -- since we then do not consider the names. elsif Identification_By_Name and then Name_Exists (Value (Dst_It).Name, From => Src_It) then Identification_By_Position := False; Copy_Argument := False; -- If the name does not match, but exists, -- and we are performing identification by -- name (and possibly identification by -- position), then we assume that the -- argument will match by name later and then -- we are not performing identification by -- position any more. Thus identification by -- name has the priority. else Identification_By_Name := False; pragma Debug (C, O ("no more ident by name")); -- If we were identifying the arguments by -- their names and the name does not match -- and does not exist in the hash table, then -- we cannot perform such identification any -- more. if Identification_By_Position then Copy_Argument := True; else -- We must identify the arguments by name -- or by position. Bail out if neither is -- possible. pragma Debug (C, O ("dead end")); Throw (Error, Bad_TypeCode_E, System_Exception_Members' (Minor => 1, Completed => Completed_No)); return; end if; end if; end if; else Identification_By_Position := False; pragma Debug (C, O ("no more ident by pos")); -- If we were identifying arguments by their -- positions, the types should have matched (first -- unused src_arg with first unused dst_arg). This -- is not the case, so we are not identifying -- arguments by their positions. if Identification_By_Name then if not Name_Exists (Value (Dst_It).Name, From => Src_It) then -- If the name does not exist, this means -- that we will never be able to make this -- argument match. pragma Debug (C, O ("name not found")); Throw (Error, Bad_Param_E, System_Exception_Members' (Minor => 1, Completed => Completed_No)); return; end if; -- Else, the type of Src_Arg does not match -- Dst_Arg, but its name exists in the hash -- table, so we can hope that the argument which -- has the proper name also has the proper type: -- we do nothing but continuing the search -- among Src_Args. else -- We must identify the arguments by name or by -- position. Bail out if neither is possible. Throw (Error, Bad_TypeCode_E, System_Exception_Members' (Minor => 1, Completed => Completed_No)); pragma Debug (C, O ("by position impossible")); return; end if; end if; end; end if; if Copy_Argument then pragma Debug (C, O ("Found the argument: copying")); Src_Arg_Found := True; Move_Any_Value (Value (Dst_It).Argument, Value (Src_It).Argument); Copied_Src_Args (Src_Idx) := True; exit; else Src_Idx := Src_Idx + 1; Next (Src_It); if Last (Src_It) then Src_Arg_Found := False; exit; end if; end if; end loop; if not Src_Arg_Found then pragma Debug (C, O ("arg not found")); Throw (Error, Bad_Param_E, System_Exception_Members' (Minor => 1, Completed => Completed_No)); return; end if; end if; end; Next (Dst_It); end loop; if Can_Extend then -- If Dst_Args is an extensible NV_List, then we append the remaining -- Src_Args. Src_It := First (List_Of (Src_Args).all); Src_Idx := Copied_Src_Args'First; pragma Debug (C, O ("Appending remaining arguments")); while not Last (Src_It) loop if (Ignore_Src_Mode or else Value (Src_It).Arg_Modes = ARG_INOUT or else Value (Src_It).Arg_Modes = Direction) and then Copied_Src_Args (Src_Idx) = False then Add_Item (Dst_Args, Value (Src_It).all); end if; Next (Src_It); Src_Idx := Src_Idx + 1; end loop; end if; end Pump_Up_Arguments_Unspecified; ------------------- -- Reset_Request -- ------------------- procedure Reset_Request (Request : in out PolyORB.Requests.Request) is Null_Any : PolyORB.Any.Any; begin Request.Completed := False; Request.Arguments_Called := False; Request.Exception_Info := Null_Any; end Reset_Request; --------- -- Run -- --------- procedure Run (R : not null access Request_Completion_Runnable) is use PolyORB.Setup; begin PolyORB.ORB.Run (The_ORB, R.Req.all'Unchecked_Access, May_Exit => True); end Run; --------------- -- Arguments -- --------------- procedure Arguments (Self : Request_Access; Args : in out Any.NVList.Ref; Error : in out Error_Container; Identification : Arguments_Identification := Ident_By_Position; Can_Extend : Boolean := False) is use Any.NVList; use Components; begin if Self.Arguments_Called or else not PolyORB.Any.Is_Empty (Self.Exception_Info) then pragma Debug (C, O ("Arguments called twice")); Throw (Error, Bad_Inv_Order_E, System_Exception_Members'(Minor => 7, Completed => Completed_No)); return; end if; Self.Arguments_Called := True; if Is_Nil (Self.Args) then pragma Assert (Self.Deferred_Arguments_Session /= null); declare use Protocols.Iface; Reply : constant Components.Message'Class := Components.Emit (Self.Deferred_Arguments_Session, Unmarshall_Arguments' (Args => Args)); begin pragma Assert (Reply in Unmarshalled_Arguments or else Reply in Arguments_Error); if Reply in Unmarshalled_Arguments then pragma Debug (C, O ("Unmarshalled deferred arguments")); Args := Unmarshalled_Arguments (Reply).Args; Self.Args := Args; else pragma Debug (C, O ("Unmarshalling deferred arguments error")); Error := Arguments_Error (Reply).Error; end if; end; Self.Deferred_Arguments_Session := null; else pragma Assert (Self.Deferred_Arguments_Session = null); pragma Debug (C, O ("in Arguments: " & Image (Self.Args))); declare Identification_Method : constant Arguments_Identification := Identification and Self.Args_Ident; Ignore_Src_Mode : constant Boolean := Self.Requesting_Component.all in Protocols.Session'Class; begin if Identification_Method = Ident_By_Position or else Identification_Method = Ident_Both then -- If reconciling arguments by position, and the call comes -- from a network connection, assume that only IN arguments are -- present, and that the direction indications may be wrong in -- Self.Args (because the protocol does not distinguish between -- IN and IN OUT arguments). However for a local call, we may -- assume that direction indicators are correct, and we must -- ensure that we omit all OUT arguments. Pump_Up_Arguments_By_Position (Dst_Args => Args, Src_Args => Self.Args, Direction => Any.ARG_IN, Error => Error, Ignore_Src_Mode => Ignore_Src_Mode, Can_Extend => Can_Extend); elsif Identification_Method = Ident_By_Name then Pump_Up_Arguments_By_Name (Dst_Args => Args, Src_Args => Self.Args, Direction => Any.ARG_IN, Error => Error, Ignore_Src_Mode => Ignore_Src_Mode, Can_Extend => Can_Extend); else Pump_Up_Arguments_Unspecified (Dst_Args => Args, Src_Args => Self.Args, Direction => Any.ARG_IN, Error => Error, Ignore_Src_Mode => Ignore_Src_Mode, Can_Extend => Can_Extend); end if; end; end if; Self.Out_Args := Args; end Arguments; ----------- -- Image -- ----------- function Image (Req : Request) return String is begin return "Operation: " & Req.Operation.all & " on object " & References.Image (Req.Target) & " with arguments " & Any.NVList.Image (Req.Args); end Image; ---------------- -- Set_Result -- ---------------- procedure Set_Result (Self : Request_Access; Val : Any.Any; Error : in out Error_Container) is use PolyORB.Any; begin if not Self.Arguments_Called or else Self.Set_Result_Called or else not PolyORB.Any.Is_Empty (Self.Exception_Info) then pragma Debug (C, O ("Invalid Set_Result call")); Throw (Error, Bad_Inv_Order_E, System_Exception_Members'(Minor => 8, Completed => Completed_No)); return; end if; Self.Set_Result_Called := True; if Is_Empty (Self.Result.Argument) then Set_Type (Self.Result.Argument, Get_Type_Obj (Val)); Move_Any_Value (Self.Result.Argument, Val); else Copy_Any_Value (Self.Result.Argument, Val); end if; end Set_Result; procedure Set_Result (Self : Request_Access; Val : Any.Any) is Error : Error_Container; begin Set_Result (Self, Val, Error); pragma Assert (not Is_Error (Error)); end Set_Result; ------------------- -- Set_Exception -- ------------------- procedure Set_Exception (Self : in out Request; Error : Error_Container) is begin Self.Exception_Info := PolyORB.Errors.Helper.Error_To_Any (Error); end Set_Exception; ------------------ -- Set_Out_Args -- ------------------ procedure Set_Out_Args (Self : Request_Access; Error : in out Error_Container; Identification : Arguments_Identification := Ident_By_Position) is Identification_Method : constant Arguments_Identification := Identification and Self.Args_Ident; begin if Identification_Method = Ident_By_Position or else Identification_Method = Ident_Both then Pump_Up_Arguments_By_Position (Dst_Args => Self.Args, Src_Args => Self.Out_Args, Direction => PolyORB.Any.ARG_OUT, Ignore_Src_Mode => False, Error => Error); elsif Identification_Method = Ident_By_Name then Pump_Up_Arguments_By_Name (Dst_Args => Self.Args, Src_Args => Self.Out_Args, Direction => PolyORB.Any.ARG_OUT, Ignore_Src_Mode => False, Error => Error); else Pump_Up_Arguments_Unspecified (Dst_Args => Self.Args, Src_Args => Self.Out_Args, Direction => PolyORB.Any.ARG_OUT, Ignore_Src_Mode => False, Error => Error); end if; -- Copy back inout and out arguments from Out_Args to Args, so the -- requestor finds them where it expects. -- XXX If a method has IN and OUT args and R.Args contains only the IN -- arguments (and no empty Any's for the OUT ones) what happens? end Set_Out_Args; ------------------- -- Setup_Request -- ------------------- procedure Setup_Request (Req : out Request; Target : References.Ref; Operation : String; Arg_List : Any.NVList.Ref; Result : in out Any.NamedValue; Exc_List : Any.ExceptionList.Ref := Any.ExceptionList.Nil_Ref; Req_Flags : Flags := Default_Flags; Deferred_Arguments_Session : Components.Component_Access := null; Identification : Arguments_Identification := Ident_By_Position; Dependent_Binding_Object : Smart_Pointers.Entity_Ptr := null) is use PolyORB.Request_QoS; use type Smart_Pointers.Entity_Ptr; begin Req.Target := Target; Req.Operation := PolyORB.Utils.Strings."+" (Operation); Req.Args := Arg_List; Req.Deferred_Arguments_Session := Deferred_Arguments_Session; Req.Result := Result; Req.Result.Arg_Modes := Any.ARG_OUT; Req.Exc_List := Exc_List; Req.Args_Ident := Identification; Req.Req_Flags := Req_Flags; Set_Request_QoS (Req, Fetch_QoS (Req.Target)); if Dependent_Binding_Object /= null then Smart_Pointers.Set (Req.Dependent_Binding_Object, Dependent_Binding_Object); end if; end Setup_Request; end PolyORB.Requests; polyorb-2.8~20110207.orig/src/polyorb-services-naming-namingcontext-servant.adb0000644000175000017500000012610611750740340026761 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- POLYORB.SERVICES.NAMING.NAMINGCONTEXT.SERVANT -- -- -- -- B o d y -- -- -- -- Copyright (C) 2002-2009, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with GNAT.HTable; -- XXX Use PolyORB's Hash table ... with Ada.Unchecked_Deallocation; with PolyORB.Any; with PolyORB.Any.NVList; with PolyORB.Any.ObjRef; with PolyORB.Errors; with PolyORB.Exceptions; with PolyORB.Initialization; with PolyORB.Log; with PolyORB.References; with PolyORB.Tasking.Mutexes; with PolyORB.Utils.Strings; with PolyORB.Minimal_Servant.Tools; with PolyORB.Services.Naming; with PolyORB.Services.Naming.Helper; with PolyORB.Services.Naming.NamingContext.Client; with PolyORB.Services.Naming.NamingContext.Helper; package body PolyORB.Services.Naming.NamingContext.Servant is use PolyORB.Any; use PolyORB.Any.NVList; use PolyORB.Any.ObjRef; use PolyORB.Log; use PolyORB.Requests; use PolyORB.Types; use PolyORB.Services.Naming.Helper; use PolyORB.Services.Naming.NamingContext.Helper; package PSNH renames PolyORB.Services.Naming.Helper; package PSNNC renames PolyORB.Services.Naming.NamingContext.Client; package L is new PolyORB.Log.Facility_Log ("polyorb.services.naming.namingcontext.servant"); procedure O (Message : Standard.String; Level : Log_Level := Debug) renames L.Output; function C (Level : Log_Level := Debug) return Boolean renames L.Enabled; package PTM renames PolyORB.Tasking.Mutexes; Critical_Section : PTM.Mutex_Access; procedure Bind (Self : access Object; N : Name; Obj : PolyORB.References.Ref; Exc : access Any.Any); procedure Bind_Context (Self : access Object; N : Name; NC : NamingContext.Ref; Exc : access PolyORB.Any.Any); function Bind_New_Context (Self : access Object; N : Name; Exc : access PolyORB.Any.Any) return NamingContext.Ref; procedure Destroy (Self : access Object); procedure Initialize; function Is_A (Logical_Type_Id : Standard.String) return PolyORB.Types.Boolean; -- procedure List -- (Self : access Object; -- How_Many : PolyORB.Types.Unsigned_Long; -- BL : out BindingList; -- BI : out BindingIterator_Forward.Ref); function New_Context (Self : access Object) return NamingContext.Ref; procedure Rebind (Self : access Object; N : Name; Obj : PolyORB.References.Ref; Exc : access Any.Any); procedure Rebind_Context (Self : access Object; N : Name; NC : NamingContext.Ref; Exc : access Any.Any); function Resolve (Self : access Object; N : Name; Exc : access Any.Any) return PolyORB.References.Ref; procedure Unbind (Self : access Object; N : Name; Exc : access Any.Any); -- Actual functions implemented by the servant. ------------ -- Invoke -- ------------ procedure Invoke (Self : access Object; Request : PolyORB.Requests.Request_Access) is Operation : Standard.String renames Request.all.Operation.all; Arg_List : PolyORB.Any.NVList.Ref; begin pragma Debug (C, O ("The server is executing the request:" & PolyORB.Requests.Image (Request.all))); Create (Arg_List); if Operation = "_is_a" then declare use PolyORB.Errors; Type_Id : PolyORB.Types.String; Argument_Type_Id : constant PolyORB.Any.Any := Get_Empty_Any (TypeCode.TC_String); Result : PolyORB.Types.Boolean; Exception_Error : Error_Container; begin -- Create argument list Add_Item (Arg_List, To_PolyORB_String ("Type_Id"), Argument_Type_Id, PolyORB.Any.ARG_IN); Arguments (Request, Arg_List, Exception_Error); if Found (Exception_Error) then raise Program_Error; -- XXX We should do something more constructive end if; Type_Id := From_Any (Argument_Type_Id); -- Call implementation Result := Is_A (To_Standard_String (Type_Id)); -- Set Result Set_Result (Request, To_Any (Result)); end; elsif Operation = "bind" then declare use PolyORB.Errors; N : Name; Argument_N : constant PolyORB.Any.Any := Get_Empty_Any (TC_Name); Obj : PolyORB.References.Ref; Argument_Obj : constant PolyORB.Any.Any := Get_Empty_Any (PSNH.TC_Object); Exception_Error : Error_Container; begin -- Create argument list Add_Item (Arg_List, To_PolyORB_String ("n"), Argument_N, PolyORB.Any.ARG_IN); Add_Item (Arg_List, To_PolyORB_String ("obj"), Argument_Obj, PolyORB.Any.ARG_IN); Arguments (Request, Arg_List, Exception_Error); if Found (Exception_Error) then raise Program_Error; -- XXX We should do something more constructive end if; -- Convert arguments from their Any N := From_Any (Argument_N); Obj := From_Any (Argument_Obj); -- Call implementation Bind (Self, N, Obj, Request.Exception_Info'Access); return; end; elsif Operation = "rebind" then declare use PolyORB.Errors; N : Name; Argument_N : constant PolyORB.Any.Any := Get_Empty_Any (TC_Name); Obj : PolyORB.References.Ref; Argument_Obj : constant PolyORB.Any.Any := Get_Empty_Any (PSNH.TC_Object); Exception_Error : Error_Container; begin -- Create argument list Add_Item (Arg_List, To_PolyORB_String ("n"), Argument_N, PolyORB.Any.ARG_IN); Add_Item (Arg_List, To_PolyORB_String ("obj"), Argument_Obj, PolyORB.Any.ARG_IN); Arguments (Request, Arg_List, Exception_Error); if Found (Exception_Error) then raise Program_Error; -- XXX We should do something more constructive end if; -- Convert arguments from their Any N := From_Any (Argument_N); Obj := From_Any (Argument_Obj); -- Call implementation Rebind (Self, N, Obj, Request.Exception_Info'Access); return; end; elsif Operation = "bind_context" then declare use PolyORB.Errors; N : Name; Argument_N : constant PolyORB.Any.Any := Get_Empty_Any (TC_Name); Nc : NamingContext.Ref; Argument_Nc : constant PolyORB.Any.Any := Get_Empty_Any (TC_NamingContext); Exception_Error : Error_Container; begin -- Create argument list Add_Item (Arg_List, To_PolyORB_String ("n"), Argument_N, PolyORB.Any.ARG_IN); Add_Item (Arg_List, To_PolyORB_String ("nc"), Argument_Nc, PolyORB.Any.ARG_IN); Arguments (Request, Arg_List, Exception_Error); -- Convert arguments from their Any if Found (Exception_Error) then raise Program_Error; -- XXX We should do something more constructive end if; N := From_Any (Argument_N); Nc := From_Any (Argument_Nc); -- Call implementation Bind_Context (Self, N, Nc, Request.Exception_Info'Access); return; end; elsif Operation = "rebind_context" then declare use PolyORB.Errors; N : Name; Argument_N : constant PolyORB.Any.Any := Get_Empty_Any (TC_Name); Nc : NamingContext.Ref; Argument_Nc : constant PolyORB.Any.Any := Get_Empty_Any (TC_NamingContext); Exception_Error : Error_Container; begin -- Create argument list Add_Item (Arg_List, To_PolyORB_String ("n"), Argument_N, PolyORB.Any.ARG_IN); Add_Item (Arg_List, To_PolyORB_String ("nc"), Argument_Nc, PolyORB.Any.ARG_IN); Arguments (Request, Arg_List, Exception_Error); -- Convert arguments from their Any if Found (Exception_Error) then raise Program_Error; -- XXX We should do something more constructive end if; N := From_Any (Argument_N); Nc := From_Any (Argument_Nc); -- Call implementation Rebind_Context (Self, N, Nc, Request.Exception_Info'Access); return; end; elsif Operation = "resolve" then declare use PolyORB.Errors; N : Name; Argument_N : constant PolyORB.Any.Any := Get_Empty_Any (TC_Name); Result : PolyORB.References.Ref; Exception_Error : Error_Container; begin -- Create argument list Add_Item (Arg_List, To_PolyORB_String ("n"), Argument_N, PolyORB.Any.ARG_IN); Arguments (Request, Arg_List, Exception_Error); -- Convert arguments from their Any if Found (Exception_Error) then raise Program_Error; -- XXX We should do something more constructive end if; N := From_Any (Argument_N); -- Call implementation pragma Debug (C, O ("Invoke: call Resolve stub")); Result := Resolve (Self, N, Request.Exception_Info'Access); -- Set Result if Is_Empty (Request.Exception_Info) then Set_Result (Request, PolyORB.Services.Naming.Helper.To_Any (Result)); end if; return; end; elsif Operation = "unbind" then declare use PolyORB.Errors; N : Name; Argument_N : constant PolyORB.Any.Any := Get_Empty_Any (TC_Name); Exception_Error : Error_Container; begin -- Create argument list Add_Item (Arg_List, To_PolyORB_String ("n"), Argument_N, PolyORB.Any.ARG_IN); Arguments (Request, Arg_List, Exception_Error); if Found (Exception_Error) then raise Program_Error; -- XXX We should do something more constructive end if; -- Convert arguments from their Any N := From_Any (Argument_N); -- Call implementation Unbind (Self, N, Request.Exception_Info'Access); return; end; elsif Operation = "new_context" then declare use PolyORB.Errors; Result : NamingContext.Ref; Exception_Error : Error_Container; begin -- Create argument list Arguments (Request, Arg_List, Exception_Error); if Found (Exception_Error) then raise Program_Error; -- XXX We should do something more constructive end if; -- Call implementation Result := New_Context (Self); -- Set Result Set_Result (Request, To_Any (Result)); return; end; elsif Operation = "bind_new_context" then declare use PolyORB.Errors; N : Name; Argument_N : constant PolyORB.Any.Any := Get_Empty_Any (TC_Name); Result : NamingContext.Ref; Exception_Error : Error_Container; begin -- Create argument list Add_Item (Arg_List, To_PolyORB_String ("n"), Argument_N, PolyORB.Any.ARG_IN); Arguments (Request, Arg_List, Exception_Error); if Found (Exception_Error) then raise Program_Error; -- XXX We should do something more constructive end if; -- Convert arguments from their Any N := From_Any (Argument_N); -- Call implementation Result := Bind_New_Context (Self, N, Request.Exception_Info'Access); if Is_Empty (Request.Exception_Info) then -- Set Result Set_Result (Request, To_Any (Result)); end if; return; end; elsif Operation = "destroy" then -- Call implementation Destroy (Self); return; -- elsif Operation = "list" then ... else -- PolyORB.Exceptions.Raise_Bad_Operation; raise Program_Error; end if; end Invoke; --------------------------- -- Get_Parameter_Profile -- --------------------------- function Get_Parameter_Profile (Method : String) return PolyORB.Any.NVList.Ref; function Get_Parameter_Profile (Method : String) return PolyORB.Any.NVList.Ref is Result : PolyORB.Any.NVList.Ref; begin PolyORB.Any.NVList.Create (Result); pragma Debug (C, O ("Parameter profile for " & Method & " requested.")); if Method = "_is_a" then Add_Item (Result, (Name => To_PolyORB_String ("Type_Id"), Argument => Get_Empty_Any (TypeCode.TC_String), Arg_Modes => ARG_IN)); elsif Method = "bind" then Add_Item (Result, (Name => To_PolyORB_String ("n"), Argument => Get_Empty_Any (TC_Name), Arg_Modes => ARG_IN)); Add_Item (Result, (Name => To_PolyORB_String ("obj"), Argument => Get_Empty_Any (PSNH.TC_Object), Arg_Modes => ARG_IN)); elsif Method = "bind_context" then Add_Item (Result, (Name => To_PolyORB_String ("n"), Argument => Get_Empty_Any (TC_Name), Arg_Modes => ARG_IN)); Add_Item (Result, (Name => To_PolyORB_String ("nc"), Argument => Get_Empty_Any (TC_NamingContext), Arg_Modes => ARG_IN)); elsif Method = "bind_new_context" then Add_Item (Result, (Name => To_PolyORB_String ("n"), Argument => Get_Empty_Any (TC_Name), Arg_Modes => ARG_IN)); elsif Method = "destroy" then null; -- XXX should add an item ? elsif Method = "new_context" then null; -- XXX should add an item ? elsif Method = "rebind" then Add_Item (Result, (Name => To_PolyORB_String ("n"), Argument => Get_Empty_Any (TC_Name), Arg_Modes => ARG_IN)); Add_Item (Result, (Name => To_PolyORB_String ("obj"), Argument => Get_Empty_Any (PSNH.TC_Object), Arg_Modes => ARG_IN)); elsif Method = "rebind_context" then Add_Item (Result, (Name => To_PolyORB_String ("n"), Argument => Get_Empty_Any (TC_Name), Arg_Modes => ARG_IN)); Add_Item (Result, (Name => To_PolyORB_String ("nc"), Argument => Get_Empty_Any (TC_NamingContext), Arg_Modes => ARG_IN)); elsif Method = "resolve" then Add_Item (Result, (Name => To_PolyORB_String ("n"), Argument => Get_Empty_Any (TC_Name), Arg_Modes => ARG_IN)); elsif Method = "unbind" then Add_Item (Result, (Name => To_PolyORB_String ("n"), Argument => Get_Empty_Any (TC_Name), Arg_Modes => ARG_IN)); else raise Program_Error; end if; return Result; end Get_Parameter_Profile; ------------------------ -- Get_Result_Profile -- ------------------------ function Get_Result_Profile (Method : String) return PolyORB.Any.Any; function Get_Result_Profile (Method : String) return PolyORB.Any.Any is begin pragma Debug (C, O ("Result profile for " & Method & " requested.")); if Method = "_is_a" then return Get_Empty_Any (TypeCode.TC_Boolean); elsif Method = "bind" then return Get_Empty_Any (TypeCode.TC_Void); elsif Method = "bind_context" then return Get_Empty_Any (TypeCode.TC_Void); elsif Method = "bind_new_context" then return Get_Empty_Any (TC_NamingContext); elsif Method = "destroy" then return Get_Empty_Any (TypeCode.TC_Void); elsif Method = "new_context" then return Get_Empty_Any (TypeCode.TC_Void); elsif Method = "rebind" then return Get_Empty_Any (TypeCode.TC_Void); elsif Method = "rebind_context" then return Get_Empty_Any (TypeCode.TC_Void); elsif Method = "resolve" then return Get_Empty_Any (PSNH.TC_Object); elsif Method = "unbind" then return Get_Empty_Any (TypeCode.TC_Void); else raise Program_Error; end if; end Get_Result_Profile; ------------- -- If_Desc -- ------------- function If_Desc return PolyORB.Obj_Adapters.Simple.Interface_Description is begin return (PP_Desc => Get_Parameter_Profile'Access, RP_Desc => Get_Result_Profile'Access); end If_Desc; ------------------------------ -- Servant actual functions -- ------------------------------ type String_Access is access String; package Names renames SEQUENCE_NameComponent; Null_Name : constant Name := Name (Names.Null_Sequence); -- Each naming context has its own internal id (Key). Bindings -- from local naming contexts are stored in the same hash table -- (BOHT). Each binding is encoded using its naming context -- internal id, its name component name and its name component -- type (Encode). subtype Hash_Header is Natural range 0 .. 30; function Hash (F : String_Access) return Hash_Header; function Equal (F1, F2 : String_Access) return Boolean; package BOHT is new GNAT.HTable.Simple_HTable (Header_Num => Hash_Header, Element => Bound_Object_Ptr, No_Element => null, Key => String_Access, Hash => Hash, Equal => Equal); function Encode (Ctx : Object_Ptr; N : NameComponent) return String; -- Encode this name component using the naming context internal -- id, the name component name and name component type. procedure Append_BO_To_NC (NC : Object_Ptr; Key : String; BN : NameComponent; BT : BindingType; Obj : PolyORB.References.Ref); -- Append a bound object to a naming context (NC). This bound -- object is composed of a binding (BN, BT) and an object Obj. -- Set a new entry in the hash table using its Key. procedure Display_NC (Text : String; NC : Object_Ptr); -- Display the list of bound objects of naming context NC with a -- output title Text. procedure Get_Ctx_And_Last_NC (Self : access Object; N : Name; Len : out Natural; Ctx : out NamingContext.Ref; NC : out NameComponent; Exc : access Any.Any); -- Resolve N from a given naming context Self: split a name N into -- its naming context Ctx and the last name component NC. Len is -- the length of N. If Len = 1, then Ctx must be ignored. To avoid -- concurrent issues, we get a copy of the bound object lists -- (thread safe). function Look_For_BO_In_NC (NC : Object_Ptr; Key : String) return Bound_Object_Ptr; -- Look for a bound object in a naming context NC using its Key. procedure Remove_BO_From_NC (NC : Object_Ptr; BO : in out Bound_Object_Ptr); -- Remove a bound object from a naming context NC. function To_Name (NC : NameComponent) return Name; -- Basic function which returns a sequence of one name component. procedure Valid (NC : Object_Ptr; Locked : Boolean := False); -- Check whether NC is null. If null, raise an exception and -- unlock global lock if locked. procedure Free is new Ada.Unchecked_Deallocation (Bound_Object, Bound_Object_Ptr); Seed : Key_Type := (others => 'A'); -------------- -- Allocate -- -------------- function Allocate return Key_Type; function Allocate return Key_Type is N : Natural := Key_Size; K : constant Key_Type := Seed; begin while N > 0 loop if Seed (N) /= 'Z' then Seed (N) := Character'Succ (Seed (N)); exit; end if; N := N - 1; end loop; if N = 0 then raise Program_Error; end if; while N < Key_Size loop N := N + 1; Seed (N) := 'A'; end loop; return K; end Allocate; --------------------- -- Append_BO_To_NC -- --------------------- procedure Append_BO_To_NC (NC : Object_Ptr; Key : String; BN : NameComponent; BT : BindingType; Obj : PolyORB.References.Ref) is BO : constant Bound_Object_Ptr := new Bound_Object; begin Valid (NC, True); Display_NC ("register """ & Key & """ in naming context", NC); -- Append to the tail of the double linked list. BOHT.Set (new String'(Key), BO); BO.BN := BN; BO.BT := BT; BO.Obj := Obj; BO.NC := NC; if NC.Head = null then NC.Head := BO; NC.Tail := BO; else BO.Prev := NC.Tail; BO.Prev.Next := BO; NC.Tail := BO; end if; Display_NC ("append """ & Key & """ to naming context", NC); end Append_BO_To_NC; ---------- -- Bind -- ---------- procedure Bind (Self : access Object; N : Name; Obj : PolyORB.References.Ref; Exc : access Any.Any) is Len : Natural; Ctx : NamingContext.Ref; Last : NameComponent; begin Get_Ctx_And_Last_NC (Self, N, Len, Ctx, Last, Exc); if not Is_Empty (Exc.all) then return; end if; if Len /= 1 then PSNNC.Bind (Ctx, To_Name (Last), Obj); else declare BON : constant String := Encode (Self.Self, Last); M : AlreadyBound_Members; begin PTM.Enter (Critical_Section); if Look_For_BO_In_NC (Self.Self, BON) /= null then PTM.Leave (Critical_Section); Exc.all := To_Any (M); return; end if; Append_BO_To_NC (Self.Self, BON, Last, Nobject, Obj); PTM.Leave (Critical_Section); end; end if; end Bind; ------------------ -- Bind_Context -- ------------------ procedure Bind_Context (Self : access Object; N : Name; NC : NamingContext.Ref; Exc : access Any.Any) is Len : Natural; Ctx : NamingContext.Ref; Last : NameComponent; begin pragma Debug (C, O ("Bind_Context: enter")); Get_Ctx_And_Last_NC (Self, N, Len, Ctx, Last, Exc); if not Is_Empty (Exc.all) then return; end if; pragma Debug (C, O ("Bind_Context: len is" & Len'Img)); if Len /= 1 then pragma Debug (C, O ("Bind_Context: binding relative name " & To_String (Last.id))); PSNNC.Bind_Context (Ctx, To_Name (Last), NC); else declare BON : constant String := Encode (Self.Self, Last); begin PTM.Enter (Critical_Section); if Look_For_BO_In_NC (Self.Self, BON) /= null then PTM.Leave (Critical_Section); raise AlreadyBound; end if; Append_BO_To_NC (Self.Self, BON, Last, Ncontext, PolyORB.References.Ref (NC)); PTM.Leave (Critical_Section); end; end if; end Bind_Context; ---------------------- -- Bind_New_Context -- ---------------------- function Bind_New_Context (Self : access Object; N : Name; Exc : access Any.Any) return NamingContext.Ref is Len : Natural; Ctx : NamingContext.Ref; Last : NameComponent; begin Get_Ctx_And_Last_NC (Self, N, Len, Ctx, Last, Exc); if not Is_Empty (Exc.all) then return NamingContext.Nil_Ref; end if; if Len /= 1 then return PSNNC.Bind_New_Context (Ctx, To_Name (Last)); else Ctx := New_Context (Self); Bind_Context (Self, N, Ctx, Exc); return Ctx; end if; end Bind_New_Context; ------------ -- Create -- ------------ function Create return Object_Ptr is Obj : Object_Ptr; begin Obj := new Object; Obj.Self := Obj; Obj.Key := Allocate; return Obj; end Create; ------------- -- Destroy -- ------------- procedure Destroy (Self : access Object) is begin Valid (Self.Self); if Self.Head /= null then raise NotEmpty; end if; end Destroy; ---------------- -- Display_NC -- ---------------- procedure Display_NC (Text : String; NC : Object_Ptr) is BO : Bound_Object_Ptr; begin pragma Debug (C, O (Text)); BO := NC.Head; while BO /= null loop pragma Debug (C, O (String (NC.Key) & " ... " & To_Standard_String (BO.BN.id) & ASCII.HT & To_Standard_String (BO.BN.kind) & ASCII.HT & BO.BT'Img)); BO := BO.Next; end loop; end Display_NC; ------------ -- Encode -- ------------ function Encode (Ctx : Object_Ptr; N : NameComponent) return String is Len : Natural; NI : constant Natural := Length (N.id); NK : constant Natural := Length (N.kind); begin Len := Key_Size + 1 + NI + 1 + NK + 1; declare BON : String (1 .. Len); begin BON (1 .. Key_Size) := String (Ctx.Key); Len := Key_Size + 1; BON (Len) := ASCII.HT; BON (Len + 1 .. Len + NI) := To_String (N.id); Len := Len + NI + 1; BON (Len) := ASCII.HT; BON (Len + 1 .. Len + NK) := To_String (N.kind); Len := Len + NK + 1; BON (Len) := ';'; return BON; end; end Encode; ----------- -- Equal -- ----------- function Equal (F1, F2 : String_Access) return Boolean is begin return F1.all = F2.all; end Equal; ------------------------- -- Get_Ctx_And_Last_NC -- ------------------------- procedure Get_Ctx_And_Last_NC (Self : access Object; N : Name; Len : out Natural; Ctx : out NamingContext.Ref; NC : out NameComponent; Exc : access Any.Any) is use Names; begin pragma Debug (C, O ("Get_Ctx_And_Last_NC: enter")); Valid (Self.Self); PTM.Enter (Critical_Section); declare NCA : Element_Array := To_Element_Array (Sequence (N)); Current_Obj : PolyORB.References.Ref; Current_Ctx : NamingContext.Ref; Current_Idx : Natural; begin PTM.Leave (Critical_Section); Len := NCA'Length; if Len = 0 then raise InvalidName; end if; if Len > 1 then Current_Idx := NCA'First; pragma Debug (C, O ("Get_Ctx_And_Last_NC: resolve " & To_String (NCA (Current_Idx).id))); Current_Obj := Resolve (Self, To_Name (NCA (Current_Idx)), Exc); if not Is_Empty (Exc.all) then return; end if; Current_Ctx := NamingContext.Helper.To_Ref (Current_Obj); Current_Idx := Current_Idx + 1; while Current_Idx < NCA'Last loop pragma Debug (C, O ("Get_Ctx_And_Last_NC: resolve " & To_String (NCA (Current_Idx).id))); Current_Obj := PSNNC.Resolve (Current_Ctx, To_Name (NCA (Current_Idx))); Current_Ctx := NamingContext.Helper.To_Ref (Current_Obj); Current_Idx := Current_Idx + 1; end loop; Ctx := Current_Ctx; end if; NC := NCA (NCA'Last); exception -- when PolyORB.Exceptions.Bad_Param => when others => declare Member : NotFound_Members; begin -- Cannot cast the current name component into a -- naming context. Member.why := not_context; Member.rest_of_name := To_Sequence (NCA (Current_Idx + 1 .. NCA'Last)); PolyORB.Exceptions.User_Raise_Exception (NotFound'Identity, Member); end; end; end Get_Ctx_And_Last_NC; ---------- -- Hash -- ---------- function Hash (F : String_Access) return Hash_Header is N : Natural := 0; begin -- Add up characters of name, mod our table size for J in F'Range loop N := (N + Character'Pos (F (J))) mod (Hash_Header'Last + 1); end loop; return N; end Hash; ---------------- -- Initialize -- ---------------- procedure Initialize is begin PTM.Create (Critical_Section); end Initialize; ---------- -- Is_A -- ---------- function Is_A (Logical_Type_Id : Standard.String) return PolyORB.Types.Boolean is begin pragma Warnings (Off); pragma Unreferenced (Logical_Type_Id); pragma Warnings (On); return True; end Is_A; ---------- -- List -- ---------- -- procedure List -- (Self : access Object; -- How_Many : PolyORB.Types.Unsigned_Long; -- BL : out BindingList; -- BI : out BindingIterator_Forward.Ref) -- is -- use PolyORB.Services.Naming.BindingIterator.Servant; -- Len : Natural := 0; -- Size : Natural := Natural (How_Many); -- Head : Bound_Object_Ptr; -- Iter : BindingIterator.Servant.Object_Ptr; -- begin -- Valid (Self.Self); -- PTM.Enter (Critical_Section); -- -- How many bound objects in this naming context. -- Head := Self.Head; -- while Head /= null loop -- Len := Len + 1; -- Head := Head.Next; -- end loop; -- Head := Self.Head; -- -- First, copy the first bound objects to fill BL. -- if Len < Size then -- Size := Len; -- end if; -- if Size > 0 then -- declare -- Table : Bindings.Element_Array (1 .. Size); -- begin -- for I in 1 .. Size loop -- Table (I) := (To_Name (Head.BN), Head.BT); -- Head := Head.Next; -- end loop; -- BL := BindingList (Bindings.To_Sequence (Table)); -- Len := Len - Size; -- end; -- end if; -- Iter := BindingIterator.Servant.Create; -- Iter.Index := 1; -- Iter.Table := new Bindings.Element_Array (1 .. Len); -- -- Copy the remaining bound objects into the iterator. -- for I in Iter.Table'Range loop -- Iter.Table (I) := (To_Name (Head.BN), Head.BT); -- Head := Head.Next; -- end loop; -- PTM.Leave (Critical_Section); -- -- Activate object Iterator. -- -- PolyORB.CORBA_P.Server_Tools.Initiate_Servant -- -- (PortableServer.Servant (Iter), BI); -- end List; ----------------------- -- Look_For_BO_In_NC -- ----------------------- function Look_For_BO_In_NC (NC : Object_Ptr; Key : String) return Bound_Object_Ptr is begin Display_NC ("look for """ & Key & """", NC); return BOHT.Get (Key'Unrestricted_Access); end Look_For_BO_In_NC; ----------------- -- New_Context -- ----------------- function New_Context (Self : access Object) return NamingContext.Ref is pragma Warnings (Off); pragma Unreferenced (Self); pragma Warnings (On); use PolyORB.Errors; Exception_Error : Error_Container; My_Ref : NamingContext.Ref; begin PolyORB.Minimal_Servant.Tools.Initiate_Servant (Create, To_PolyORB_String ("NAMING"), PolyORB.References.Ref (My_Ref), Exception_Error); if Found (Exception_Error) then raise Program_Error; end if; return My_Ref; end New_Context; ------------ -- Rebind -- ------------ procedure Rebind (Self : access Object; N : Name; Obj : PolyORB.References.Ref; Exc : access Any.Any) is Len : Natural; Ctx : NamingContext.Ref; Last : NameComponent; begin Get_Ctx_And_Last_NC (Self, N, Len, Ctx, Last, Exc); if not Is_Empty (Exc.all) then return; end if; if Len /= 1 then PSNNC.Rebind (Ctx, To_Name (Last), Obj); else declare BON : constant String := Encode (Self.Self, Last); BO : Bound_Object_Ptr; begin PTM.Enter (Critical_Section); BO := Look_For_BO_In_NC (Self.Self, BON); if BO = null then PTM.Leave (Critical_Section); declare Member : NotFound_Members; begin Member.why := missing_node; Member.rest_of_name := Null_Name; PolyORB.Exceptions.User_Raise_Exception (NotFound'Identity, Member); end; end if; if BO.BT /= Nobject then PTM.Leave (Critical_Section); declare Member : NotFound_Members; begin Member.why := not_object; Member.rest_of_name := Null_Name; PolyORB.Exceptions.User_Raise_Exception (NotFound'Identity, Member); end; end if; Remove_BO_From_NC (Self.Self, BO); Append_BO_To_NC (Self.Self, BON, Last, Nobject, Obj); PTM.Leave (Critical_Section); end; end if; end Rebind; -------------------- -- Rebind_Context -- -------------------- procedure Rebind_Context (Self : access Object; N : Name; NC : NamingContext.Ref; Exc : access Any.Any) is Len : Natural; Ctx : NamingContext.Ref; Last : NameComponent; begin Get_Ctx_And_Last_NC (Self, N, Len, Ctx, Last, Exc); if not Is_Empty (Exc.all) then return; end if; if Len /= 1 then PSNNC.Rebind_Context (Ctx, To_Name (Last), NC); else declare BON : constant String := Encode (Self.Self, Last); BO : Bound_Object_Ptr; begin PTM.Enter (Critical_Section); BO := Look_For_BO_In_NC (Self.Self, BON); if BO = null then PTM.Leave (Critical_Section); declare Member : NotFound_Members; begin Member.why := missing_node; Member.rest_of_name := Null_Name; PolyORB.Exceptions.User_Raise_Exception (NotFound'Identity, Member); end; end if; if BO.BT /= Ncontext then PTM.Leave (Critical_Section); declare Member : NotFound_Members; begin Member.why := not_context; Member.rest_of_name := Null_Name; PolyORB.Exceptions.User_Raise_Exception (NotFound'Identity, Member); end; end if; Remove_BO_From_NC (Self.Self, BO); Append_BO_To_NC (Self.Self, BON, Last, Ncontext, PolyORB.References.Ref (NC)); PTM.Leave (Critical_Section); end; end if; end Rebind_Context; ----------------------- -- Remove_BO_From_NC -- ----------------------- procedure Remove_BO_From_NC (NC : Object_Ptr; BO : in out Bound_Object_Ptr) is begin Valid (NC, True); if BO.Next /= null then BO.Next.Prev := BO.Prev; end if; if BO.Prev /= null then BO.Prev.Next := BO.Next; end if; if NC.Head = BO then NC.Head := BO.Next; end if; if NC.Tail = BO then NC.Tail := BO.Prev; end if; BO.Prev := null; BO.Next := null; declare BON : constant String := Encode (NC, BO.BN); begin BOHT.Set (BON'Unrestricted_Access, null); end; Free (BO); Display_NC ("remove object from naming context", NC); end Remove_BO_From_NC; ------------- -- Resolve -- ------------- function Resolve (Self : access Object; N : Name; Exc : access Any.Any) return PolyORB.References.Ref is Len : Natural; Ctx : NamingContext.Ref; Last : NameComponent; begin Get_Ctx_And_Last_NC (Self, N, Len, Ctx, Last, Exc); if not Is_Empty (Exc.all) then return References.Nil_Ref; end if; if Len /= 1 then return PSNNC.Resolve (Ctx, To_Name (Last)); else declare BON : constant String := Encode (Self.Self, Last); BO : Bound_Object_Ptr; Obj : PolyORB.References.Ref; begin PTM.Enter (Critical_Section); BO := Look_For_BO_In_NC (Self.Self, BON); if BO = null then PTM.Leave (Critical_Section); declare Member : NotFound_Members; begin Member.why := missing_node; Member.rest_of_name := Null_Name; Exc.all := To_Any (Member); return References.Nil_Ref; end; end if; Obj := BO.Obj; PTM.Leave (Critical_Section); return Obj; end; end if; end Resolve; ------------- -- To_Name -- ------------- function To_Name (NC : NameComponent) return Name is begin return Name (Names.To_Sequence ((1 => NC))); end To_Name; ------------ -- Unbind -- ------------ procedure Unbind (Self : access Object; N : Name; Exc : access Any.Any) is Len : Natural; Ctx : NamingContext.Ref; Last : NameComponent; begin Get_Ctx_And_Last_NC (Self, N, Len, Ctx, Last, Exc); if not Is_Empty (Exc.all) then return; end if; if Len /= 1 then PSNNC.Unbind (Ctx, To_Name (Last)); else declare BON : constant String := Encode (Self.Self, Last); BO : Bound_Object_Ptr; begin PTM.Enter (Critical_Section); BO := Look_For_BO_In_NC (Self.Self, BON); if BO = null then PTM.Leave (Critical_Section); declare Member : NotFound_Members; begin Member.why := missing_node; Member.rest_of_name := Null_Name; PolyORB.Exceptions.User_Raise_Exception (NotFound'Identity, Member); end; end if; Remove_BO_From_NC (Self.Self, BO); PTM.Leave (Critical_Section); end; end if; end Unbind; ----------- -- Valid -- ----------- procedure Valid (NC : Object_Ptr; Locked : Boolean := False) is begin if NC = null then if Locked then PTM.Leave (Critical_Section); end if; raise CannotProceed; end if; end Valid; use PolyORB.Initialization; use PolyORB.Initialization.String_Lists; use PolyORB.Utils.Strings; begin Register_Module (Module_Info' (Name => +"naming.NamingContext.servant", Conflicts => Empty, Depends => +"tasking.mutexes", Provides => Empty, Implicit => False, Init => Initialize'Access, Shutdown => null)); end PolyORB.Services.Naming.NamingContext.Servant; polyorb-2.8~20110207.orig/src/polyorb-tasking-profiles-full_tasking-threads.ads0000644000175000017500000001260411750740340026742 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- POLYORB.TASKING.PROFILES.FULL_TASKING.THREADS -- -- -- -- S p e c -- -- -- -- Copyright (C) 2002-2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- This package provide an implementation for base types for tasking -- using full Ada tasking, yet it does not allow for dynamic priority -- modification of a running thread. For all comments, see -- PolyORB.Tasking.Threads. with Ada.Task_Identification; with PolyORB.Tasking.Threads; with System; pragma Warnings (Off); -- System.Tasking is an internal GNAT unit with System.Tasking; pragma Warnings (On); package PolyORB.Tasking.Profiles.Full_Tasking.Threads is package PTT renames PolyORB.Tasking.Threads; ------------------------------ -- Full_Tasking_Thread_Type -- ------------------------------ -- Type is declared in package body --------------------------------- -- Full_Tasking_Thread_Factory -- --------------------------------- type Full_Tasking_Thread_Factory_Type is new PTT.Thread_Factory_Type with private; type Full_Tasking_Thread_Factory_Access is access all Full_Tasking_Thread_Factory_Type'Class; The_Thread_Factory : constant Full_Tasking_Thread_Factory_Access; function Run_In_Task (TF : access Full_Tasking_Thread_Factory_Type; Name : String := ""; Default_Priority : System.Any_Priority := System.Default_Priority; Storage_Size : Natural := 0; R : PTT.Runnable_Access) return PTT.Thread_Access; function Run_In_Task (TF : access Full_Tasking_Thread_Factory_Type; Name : String := ""; Default_Priority : System.Any_Priority := System.Default_Priority; Storage_Size : Natural := 0; P : PTT.Parameterless_Procedure) return PTT.Thread_Access; function Get_Current_Thread_Id (TF : access Full_Tasking_Thread_Factory_Type) return PTT.Thread_Id; function P_To_A_Task_Id (TID : PTT.Thread_Id) return Ada.Task_Identification.Task_Id; pragma Inline (P_To_A_Task_Id); -- Convert PolyORB Task_Id to Ada Task_Id. function Thread_Id_Image (TF : access Full_Tasking_Thread_Factory_Type; TID : PTT.Thread_Id) return String; procedure Set_Priority (TF : access Full_Tasking_Thread_Factory_Type; T : PTT.Thread_Id; P : System.Any_Priority); function Get_Priority (TF : access Full_Tasking_Thread_Factory_Type; T : PTT.Thread_Id) return System.Any_Priority; procedure Relative_Delay (TF : access Full_Tasking_Thread_Factory_Type; D : Duration); function Awake_Count (TF : access Full_Tasking_Thread_Factory_Type) return Natural; function Independent_Count (TF : access Full_Tasking_Thread_Factory_Type) return Natural; private type Full_Tasking_Thread_Factory_Type is new PTT.Thread_Factory_Type with record Environment_Task : System.Tasking.Task_Id; -- The environment task end record; The_Thread_Factory : constant Full_Tasking_Thread_Factory_Access := new Full_Tasking_Thread_Factory_Type; type Set_Priority_Hook is access procedure (TF : access Full_Tasking_Thread_Factory_Type; T : PTT.Thread_Id; P : System.Any_Priority); Set_Priority_P : Set_Priority_Hook; type Get_Priority_Hook is access function (TF : access Full_Tasking_Thread_Factory_Type; T : PTT.Thread_Id) return System.Any_Priority; Get_Priority_P : Get_Priority_Hook; end PolyORB.Tasking.Profiles.Full_Tasking.Threads; polyorb-2.8~20110207.orig/src/polyorb-transport-handlers.ads0000644000175000017500000000675011750740340023210 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . T R A N S P O R T . H A N D L E R S -- -- -- -- S p e c -- -- -- -- Copyright (C) 2004-2009, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- Event handlers associated with all transport access points and -- transport endpoints. with PolyORB.Binding_Data; with PolyORB.Filters; with PolyORB.ORB; package PolyORB.Transport.Handlers is type Transport_Event_Handler is abstract new PolyORB.Asynch_Ev.AES_Event_Handler with record ORB : PolyORB.ORB.ORB_Access; end record; -------------------------------- -- Access point event handler -- -------------------------------- type TAP_AES_Event_Handler is abstract new Transport_Event_Handler with record TAP : PolyORB.Transport.Transport_Access_Point_Access; -- Factory of Transport_Endpoint components. Filter_Factory_Chain : Filters.Factories_Access; -- Factory of Filter (protocol stack) components. Profile_Factory : Binding_Data.Profile_Factory_Access; -- Factory of profiles capable of associating the -- address of TAP and the specification of the -- protocol implemented by Filter_Factory_Chain -- with an object id. end record; ---------------------------- -- Endpoint event handler -- ---------------------------- type TE_AES_Event_Handler is new Transport_Event_Handler with record TE : PolyORB.Transport.Transport_Endpoint_Access; -- Back pointer to the corresponding endpoint. end record; procedure Handle_Event (H : access TE_AES_Event_Handler); end PolyORB.Transport.Handlers; polyorb-2.8~20110207.orig/src/polyorb-tasking-profiles-ravenscar-threads-annotations.adb0000644000175000017500000001051511750740340030555 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- POLYORB.TASKING.PROFILES.RAVENSCAR.THREADS.ANNOTATIONS -- -- -- -- B o d y -- -- -- -- Copyright (C) 2004-2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with PolyORB.Utils.Strings; with PolyORB.Utils.HFunctions.Hyper; with PolyORB.Utils.HTables.Perfect; with PolyORB.Tasking.Mutexes; with PolyORB.Tasking.Threads; package body PolyORB.Tasking.Profiles.Ravenscar.Threads.Annotations is use PolyORB.Annotations; use PolyORB.Tasking.Mutexes; Current_TAF : Ravenscar_TAF_Access; package HTable is new PolyORB.Utils.HTables.Perfect (Notepad_Access, PolyORB.Utils.HFunctions.Hyper.Hash_Hyper_Parameters, PolyORB.Utils.HFunctions.Hyper.Default_Hash_Parameters, PolyORB.Utils.HFunctions.Hyper.Hash, PolyORB.Utils.HFunctions.Hyper.Next_Hash_Parameters); use HTable; Map : Table_Instance; Mutex : Mutex_Access; -- Implementation Note: in this implementation, we rely on the -- fact that we use the Ravenscar profile: there is no task -- finalization. Thus, we do not have to care about the -- deallocation of the elements stored in Map. -------------------------------- -- Get_Current_Thread_Notepad -- -------------------------------- function Get_Current_Thread_Notepad (TAF : access Ravenscar_TAF) return PolyORB.Annotations.Notepad_Access is pragma Unreferenced (TAF); Task_Key : constant String := Image (Current_Task); Note : Notepad_Access; begin Enter (Mutex); Note := Lookup (Map, Task_Key, null); if Note = null then Note := new Notepad; Insert (Map, Task_Key, Note); end if; Leave (Mutex); return Note; end Get_Current_Thread_Notepad; ---------------- -- Initialize -- ---------------- procedure Initialize is begin Current_TAF := new Ravenscar_TAF; Initialize (Map); Create (Mutex); PolyORB.Tasking.Threads.Annotations.Register (PolyORB.Tasking.Threads.Annotations.TAF_Access (Current_TAF)); end Initialize; use PolyORB.Initialization; use PolyORB.Initialization.String_Lists; use PolyORB.Utils.Strings; begin Register_Module (Module_Info' (Name => +"tasking.profiles.ravenscar.annotations", Conflicts => Empty, Depends => +"tasking.mutexes", Provides => +"tasking.annotations", Implicit => False, Init => Initializer, Shutdown => null)); end PolyORB.Tasking.Profiles.Ravenscar.Threads.Annotations; polyorb-2.8~20110207.orig/src/polyorb-tasking-profiles-no_tasking-threads-annotations.adb0000644000175000017500000000635311750740340030732 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- POLYORB.TASKING.PROFILES.NO_TASKING.THREADS.ANNOTATIONS -- -- -- -- B o d y -- -- -- -- Copyright (C) 2004-2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with PolyORB.Initialization; with PolyORB.Utils.Strings; package body PolyORB.Tasking.Profiles.No_Tasking.Threads.Annotations is Thread_Annotation_Notepad : aliased PolyORB.Annotations.Notepad; -------------------------------- -- Get_Current_Thread_Notepad -- -------------------------------- function Get_Current_Thread_Notepad (TAF : access No_Tasking_TAF) return PolyORB.Annotations.Notepad_Access is pragma Unreferenced (TAF); begin return Thread_Annotation_Notepad'Access; end Get_Current_Thread_Notepad; ---------------- -- Initialize -- ---------------- procedure Initialize; procedure Initialize is begin PolyORB.Tasking.Threads.Annotations.Register (new No_Tasking_TAF); end Initialize; use PolyORB.Initialization; use PolyORB.Initialization.String_Lists; use PolyORB.Utils.Strings; begin Register_Module (Module_Info' (Name => +"tasking.profiles.no_tasking.annotations", Conflicts => Empty, Depends => Empty, Provides => +"tasking.annotations", Implicit => False, Init => Initialize'Access, Shutdown => null)); end PolyORB.Tasking.Profiles.No_Tasking.Threads.Annotations; polyorb-2.8~20110207.orig/src/polyorb-transport-datagram.adb0000644000175000017500000001537711750740340023154 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . T R A N S P O R T . D A T A G R A M -- -- -- -- B o d y -- -- -- -- Copyright (C) 2003-2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with PolyORB.Binding_Objects; with PolyORB.Log; with PolyORB.Filters; with PolyORB.Filters.Iface; with PolyORB.ORB.Iface; package body PolyORB.Transport.Datagram is use PolyORB.Log; package L is new PolyORB.Log.Facility_Log ("polyorb.transport.datagram"); procedure O (Message : String; Level : Log_Level := Debug) renames L.Output; function C (Level : Log_Level := Debug) return Boolean renames L.Enabled; --------------------- -- Create_Endpoint -- --------------------- function Create_Endpoint (TAP : access Datagram_Transport_Access_Point) return Datagram_Transport_Endpoint_Access is pragma Warnings (Off); pragma Unreferenced (TAP); pragma Warnings (On); begin pragma Debug (C, O ("Return null endpoint")); return null; end Create_Endpoint; ------------------ -- Handle_Event -- ------------------ procedure Handle_Event (H : access Datagram_TAP_AES_Event_Handler) is use PolyORB.Components; use PolyORB.ORB; use PolyORB.ORB.Iface; use PolyORB.Filters; -- Create associated Endpoint New_TE : constant Transport_Endpoint_Access := Transport_Endpoint_Access (Create_Endpoint (Datagram_Transport_Access_Point_Access (H.TAP))); begin if New_TE /= null then pragma Debug (C, O ("Create and register endpoint")); Binding_Objects.Setup_Binding_Object (ORB => Components.Component_Access (H.ORB), TE => New_TE, FFC => H.Filter_Factory_Chain.all, BO_Ref => New_TE.Dependent_Binding_Object, Pro => null); -- XXX Until bidirectional BOs are implemented, -- We mark Server BOs as having a null Profile -- cf. PolyORB.ORB.Find_Reusable_Binding_Object. ORB.Register_Binding_Object (H.ORB, New_TE.Dependent_Binding_Object, ORB.Server); -- Setup binding object end if; end Handle_Event; -------------------- -- Handle_Message -- -------------------- function Handle_Message (TE : not null access Datagram_Transport_Endpoint; Msg : Components.Message'Class) return Components.Message'Class is use PolyORB.Buffers; use PolyORB.Components; use PolyORB.Errors; use PolyORB.Filters; use PolyORB.Filters.Iface; Nothing : Components.Null_Message; begin if Msg in Data_Expected'Class then declare DE : Data_Expected renames Data_Expected (Msg); begin pragma Assert (DE.In_Buf /= null); TE.In_Buf := DE.In_Buf; TE.Max := DE.Max; end; return Emit (TE.Server, ORB.Iface.Monitor_Endpoint' (TE => Transport_Endpoint_Access (TE))); elsif Msg in Data_Indication then pragma Debug (C, O ("Data received")); declare use type Ada.Streams.Stream_Element_Count; Size : Ada.Streams.Stream_Element_Count := TE.Max; Error : Errors.Error_Container; begin if TE.In_Buf /= null then Read (Transport_Endpoint'Class (TE.all), TE.In_Buf, Size, Error); end if; if TE.In_Buf = null or else (Size = 0 and then not Is_Error (Error)) then Throw (Error, Comm_Failure_E, System_Exception_Members' (Minor => 0, Completed => Completed_Maybe)); end if; if not Is_Error (Error) then return Emit (TE.Upper, Data_Indication'(Data_Amount => Size)); else return Filter_Error'(Error => Error); end if; end; elsif Msg in Data_Out then declare Error : Errors.Error_Container; begin Write (Transport_Endpoint'Class (TE.all), Data_Out (Msg).Out_Buf, Error); if Errors.Is_Error (Error) then return Filter_Error'(Error => Error); end if; end; elsif Msg in Set_Server then TE.Server := Set_Server (Msg).Server; TE.Binding_Object := Smart_Pointers.Entity_Ptr (Set_Server (Msg).Binding_Object); return Emit (TE.Upper, Msg); elsif Msg in Disconnect_Indication then Close (Transport_Endpoint'Class (TE.all)'Access); return Emit (TE.Upper, Msg); elsif Msg in Disconnect_Request then Close (Transport_Endpoint'Class (TE.all)'Access); else return Transport.Handle_Message (Transport_Endpoint (TE.all)'Access, Msg); end if; return Nothing; end Handle_Message; end PolyORB.Transport.Datagram; polyorb-2.8~20110207.orig/src/polyorb-asynch_ev.adb0000644000175000017500000000730611750740340021312 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . A S Y N C H _ E V -- -- -- -- B o d y -- -- -- -- Copyright (C) 2001-2009, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- Abstract data type for an asynchrous event source. pragma Ada_2005; with Ada.Unchecked_Deallocation; package body PolyORB.Asynch_Ev is ------------ -- AEM_Of -- ------------ function AEM_Of (AES : Asynch_Ev_Source) return Asynch_Ev_Monitor_Access is begin return AES.Monitor; end AEM_Of; ------------- -- Handler -- ------------- function Handler (AES : Asynch_Ev_Source'Class) return access AES_Event_Handler'Class is begin return AES.Handler; end Handler; ----------------- -- Set_Handler -- ----------------- procedure Set_Handler (AES : in out Asynch_Ev_Source'Class; H : access AES_Event_Handler'Class) is begin AES.Handler := H; end Set_Handler; ----------------------- -- Unregister_Source -- ----------------------- function Unregister_Source (AES : Asynch_Ev_Source_Access) return Boolean is Success : Boolean; begin pragma Assert (AES /= null and then AES.Monitor /= null); Unregister_Source (AES.Monitor.all, AES, Success); return Success; end Unregister_Source; ------------- -- Destroy -- ------------- procedure Destroy (AES : in out Asynch_Ev_Source_Access) is procedure Free is new Ada.Unchecked_Deallocation (Asynch_Ev_Source'Class, Asynch_Ev_Source_Access); begin Free (AES); end Destroy; --------- -- Run -- --------- procedure Run (AEH : not null access AES_Event_Handler) is use PolyORB.Jobs; begin -- Redispatch on Handle_Event operation. -- Note: this may destroy AEH. Handle_Event (AES_Event_Handler'Class (AEH.all)'Access); end Run; end PolyORB.Asynch_Ev; polyorb-2.8~20110207.orig/src/polyorb-tasking-threads-annotations.adb0000644000175000017500000000516211750740340024754 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . T A S K I N G . T H R E A D S . A N N O T A T I O N S -- -- -- -- B o d y -- -- -- -- Copyright (C) 2004 Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by ACT Europe. -- -- (email: sales@act-europe.fr) -- -- -- ------------------------------------------------------------------------------ package body PolyORB.Tasking.Threads.Annotations is Current_TAF : TAF_Access; -------------- -- Register -- -------------- procedure Register (TAF : TAF_Access) is begin pragma Assert (Current_TAF = null); Current_TAF := TAF; end Register; -------------------------------- -- Get_Current_Thread_Notepad -- -------------------------------- function Get_Current_Thread_Notepad return PolyORB.Annotations.Notepad_Access is begin return Get_Current_Thread_Notepad (Current_TAF); end Get_Current_Thread_Notepad; end PolyORB.Tasking.Threads.Annotations; polyorb-2.8~20110207.orig/src/polyorb-initialization.ads0000644000175000017500000001222711750740340022401 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . I N I T I A L I Z A T I O N -- -- -- -- S p e c -- -- -- -- Copyright (C) 2002-2008, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- Automatic initialization of PolyORB subsystems. with PolyORB.Utils.Strings; with PolyORB.Utils.Strings.Lists; package PolyORB.Initialization is pragma Preelaborate; package String_Lists renames PolyORB.Utils.Strings.Lists; type Initializer is access procedure; type Finalizer is access procedure (Wait_For_Completion : Boolean); type Module_Info is record Name : Utils.Strings.String_Ptr; -- The unique name of this module. Provides : String_Lists.List; -- A list of 'virtual' modules provided by this one. -- Several different implementations of the same service may exist: they -- shall have different Names, but will list the same common name in -- their Provides list. If an exclamation mark (!) is appended to a -- provided name, this is equivalent to also listing that module in -- the Conflicts list (preventing any other module from providing the -- same virtual module). Depends : String_Lists.List; -- The list of modules this one depends upon. If a question mark is -- appended to a name in Depends, then the dependency is optional, which -- means that the presence of the depended-upon module is not required, -- but that if that module is present, then it must be initialized -- before this one. Conflicts : String_Lists.List; -- The list of modules that cannot be instantiated simultaneously with -- this one. Note that if this list has an entry mentioning a virtual -- module provided by this module, then there is no conflict unless -- another module provides the same virtual module. This allows the -- specification of multiple implementations of the same virtual -- module that are mutually exclusive. Init : Initializer; -- The initialization procedure for this module Implicit : Boolean; -- If this flag is True, then the module is an implicit dependency: -- it is added automatically to the dependency list of any module -- that is not an implicit dependency itself. Shutdown : Finalizer; -- The shutdown procedure for this module end record; procedure Register_Module (Info : Module_Info); -- Register a module described by Info with -- the autoconfigurator. procedure Initialize_World; -- Initialize all modules, respecting the dependencies listed -- in each module descriptor. procedure Shutdown_World (Wait_For_Completion : Boolean := True); -- Shuts down all the modules in reverse initialization order. function Is_Initialized return Boolean; -- True if, and only if, Initialize_World has been called. type Configuration_Hook is access function (Section, Key, Default : String) return String; Get_Conf_Hook : Configuration_Hook := null; -- When a configuration subsystem is initialized, it may set this pointer -- to a function allowing the logging and initialization subsystems to -- retrieve configuration values. This trick is used so PolyORB.Log -- and PolyORB.Initialization can be preelaborale. end PolyORB.Initialization; polyorb-2.8~20110207.orig/src/polyorb-services-naming-namingcontext.ads0000644000175000017500000001054611750740340025322 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- POLYORB.SERVICES.NAMING.NAMINGCONTEXT -- -- -- -- S p e c -- -- -- -- Copyright (C) 2002-2009, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with Ada.Exceptions; with PolyORB.Errors; with PolyORB.References; package PolyORB.Services.Naming.NamingContext is type Ref is new PolyORB.References.Ref with null record; Nil_Ref : constant Ref := (References.Nil_Ref with null record); type NotFoundReason is (missing_node, not_context, not_object); NotFoundReason_Repository_Id : constant Standard.String := "IDL:omg.org/CosNaming/NamingContext/NotFoundReason:1.0"; type NotFound_Members is new PolyORB.Errors.Exception_Members with record why : NotFoundReason; rest_of_name : Name; end record; NotFound : exception; NotFound_Repository_Id : constant Standard.String := "IDL:omg.org/CosNaming/NamingContext/NotFound:1.0"; procedure Get_Members (From : Ada.Exceptions.Exception_Occurrence; To : out NotFound_Members); type CannotProceed_Members is new PolyORB.Errors.Exception_Members with record cxt : Ref; rest_of_name : Name; end record; CannotProceed : exception; CannotProceed_Repository_Id : constant Standard.String := "IDL:omg.org/CosNaming/NamingContext/CannotProceed:1.0"; procedure Get_Members (From : Ada.Exceptions.Exception_Occurrence; To : out CannotProceed_Members); type InvalidName_Members is new PolyORB.Errors.Exception_Members with null record; InvalidName : exception; InvalidName_Repository_Id : constant Standard.String := "IDL:omg.org/CosNaming/NamingContext/InvalidName:1.0"; procedure Get_Members (From : Ada.Exceptions.Exception_Occurrence; To : out InvalidName_Members); type AlreadyBound_Members is new PolyORB.Errors.Exception_Members with null record; AlreadyBound : exception; AlreadyBound_Repository_Id : constant Standard.String := "IDL:omg.org/CosNaming/NamingContext/AlreadyBound:1.0"; procedure Get_Members (From : Ada.Exceptions.Exception_Occurrence; To : out AlreadyBound_Members); type NotEmpty_Members is new PolyORB.Errors.Exception_Members with null record; NotEmpty : exception; NotEmpty_Repository_Id : constant Standard.String := "IDL:omg.org/CosNaming/NamingContext/NotEmpty:1.0"; procedure Get_Members (From : Ada.Exceptions.Exception_Occurrence; To : out NotEmpty_Members); end PolyORB.Services.Naming.NamingContext; polyorb-2.8~20110207.orig/src/polyorb-services-naming.ads0000644000175000017500000000706311750740340022446 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . S E R V I C E S . N A M I N G -- -- -- -- S p e c -- -- -- -- Copyright (C) 2002 Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by ACT Europe. -- -- (email: sales@act-europe.fr) -- -- -- ------------------------------------------------------------------------------ -- The PolyORB Naming Service is an adaptation from OMG COS Naming, v 1.0 -- with CORBA; -- with CORBA.Forward; -- pragma Elaborate_All (CORBA.Forward); with PolyORB.Sequences.Unbounded; pragma Elaborate_All (PolyORB.Sequences.Unbounded); with PolyORB.Types; package PolyORB.Services.Naming is type Istring is new PolyORB.Types.String; Istring_Repository_Id : constant Standard.String := "IDL:omg.org/CosNaming/Istring:1.0"; type NameComponent is record id : Istring; kind : Istring; end record; NameComponent_Repository_Id : constant Standard.String := "IDL:omg.org/CosNaming/NameComponent:1.0"; package SEQUENCE_NameComponent is new PolyORB.Sequences.Unbounded (NameComponent); type Name is new SEQUENCE_NameComponent.Sequence; Name_Repository_Id : constant Standard.String := "IDL:omg.org/CosNaming/Name:1.0"; type BindingType is (Nobject, Ncontext); BindingType_Repository_Id : constant Standard.String := "IDL:omg.org/CosNaming/BindingType:1.0"; type Binding is record binding_name : Name; binding_type : BindingType; end record; Binding_Repository_Id : constant Standard.String := "IDL:omg.org/CosNaming/Binding:1.0"; package SEQUENCE_Binding is new PolyORB.Sequences.Unbounded (Binding); type BindingList is new SEQUENCE_Binding.Sequence; BindingList_Repository_Id : constant Standard.String := "IDL:omg.org/CosNaming/BindingList:1.0"; -- package BindingIterator_Forward is new CORBA.Forward; end PolyORB.Services.Naming; polyorb-2.8~20110207.orig/src/polyorb-orb-thread_per_session.ads0000644000175000017500000001104111750740340024003 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . O R B . T H R E A D _ P E R _ S E S S I O N -- -- -- -- S p e c -- -- -- -- Copyright (C) 2001-2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with PolyORB.Annotations; with PolyORB.Jobs; with PolyORB.Utils.Chained_Lists; with PolyORB.Tasking.Semaphores; package PolyORB.ORB.Thread_Per_Session is pragma Elaborate_Body; use PolyORB.Components; use PolyORB.Jobs; use PolyORB.Transport; ----------------------------------------------------------- -- Implementation of a thread-per-session tasking policy -- ----------------------------------------------------------- type Thread_Per_Session_Policy is new Tasking_Policy_Type with private; type End_Thread_Job is new Jobs.Job with null record; -- This particular job is used to indicate to a thread associated with a -- session that it has to exit its main loop. type End_Thread_Job_Access is access all End_Thread_Job; procedure Handle_New_Server_Connection (P : access Thread_Per_Session_Policy; ORB : ORB_Access; AC : Active_Connection); procedure Handle_Close_Connection (P : access Thread_Per_Session_Policy; TE : Transport_Endpoint_Access); procedure Handle_New_Client_Connection (P : access Thread_Per_Session_Policy; ORB : ORB_Access; AC : Active_Connection); procedure Handle_Request_Execution (P : access Thread_Per_Session_Policy; ORB : ORB_Access; RJ : access Request_Job'Class); procedure Idle (P : access Thread_Per_Session_Policy; This_Task : PTI.Task_Info_Access; ORB : ORB_Access); procedure Run (J : not null access End_Thread_Job); private type Request_Info is record Job : Jobs.Job_Access; end record; -- Request_Info is the type of the elements stored in the threads queues package Request_Queues is new PolyORB.Utils.Chained_Lists (Request_Info); subtype Request_Queue is Request_Queues.List; type Request_Queue_Access is access all Request_Queue; -- Request queue attached to a thread type Session_Thread_Info is new PolyORB.Annotations.Note with record Request_Semaphore : Tasking.Semaphores.Semaphore_Access := null; Request_List : Request_Queue_Access := null; end record; -- This structure is used in order to be able to retrieve the queue -- and the semaphore associated with a thread, with the knownledge of -- of a session access procedure Add_Request (S : Session_Thread_Info; RI : Request_Info); -- Add a job to a job queue type Thread_Per_Session_Policy is new Tasking_Policy_Type with null record; end PolyORB.ORB.Thread_Per_Session; polyorb-2.8~20110207.orig/src/polyorb-tasking-advanced_mutexes.ads0000644000175000017500000001142211750740340024323 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . T A S K I N G . A D V A N C E D _ M U T E X E S -- -- -- -- S p e c -- -- -- -- Copyright (C) 2002-2008, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by ACT Europe. -- -- (email: sales@act-europe.fr) -- -- -- ------------------------------------------------------------------------------ -- This package provides advanced mutual exclusion objects (mutexes). with PolyORB.Tasking.Mutexes; with PolyORB.Tasking.Condition_Variables; with PolyORB.Tasking.Threads; package PolyORB.Tasking.Advanced_Mutexes is pragma Preelaborate; type Adv_Mutex_Type is limited private; -- This is a classical mutual exclusion object except that it allows -- nested critical sections; that is, when a task tries to Enter a mutex -- several times without leaving it first, it is not blocked and can -- continue. Leave keeps track of the number of times Enter has been -- successful, and must be called the number of times that Enter has been -- called to free the lock. -- Example (assuming all calls below are done by one task): -- -- Enter (My_Mutex); -- -- Enter the critical section. -- -- Enter (My_Mutex); -- -- Enter the critical section again. -- -- Do_Some_Stuff; -- -- Leave (My_Mutex); -- -- Keep the lock. -- -- Enter (My_Mutex); -- -- Reenter. -- -- Leave (My_Mutex); -- -- Still keep the lock -- -- Leave (My_Mutex); -- -- Leave the critical section and free the lock. type Adv_Mutex_Access is access all Adv_Mutex_Type; procedure Create (M : out Adv_Mutex_Access); -- Create an advanced mutex. The object must have been allocated -- by the client of this package. procedure Destroy (M : in out Adv_Mutex_Access); -- Destroy the advanced mutex. The deallocation, if needed, after -- "Destroy" and is the responsability of the client of this -- package. procedure Enter (M : access Adv_Mutex_Type); -- If the lock is free, or if the current task has it, get the -- lock and continue, entering a new critical section; else, wait -- until it is free. procedure Leave (M : access Adv_Mutex_Type); -- The current tasks exit of the current critical section. If it is -- the first critical section opened by the task, free the lock. private package PTM renames PolyORB.Tasking.Mutexes; package PTCV renames PolyORB.Tasking.Condition_Variables; type Adv_Mutex_Type is record Empty : Boolean; pragma Atomic (Empty); -- If no there is no owner for this Mutex, True. else, False. Current : Threads.Thread_Id; pragma Atomic (Current); -- Identity of the thread owning the mutex. Level : Natural; pragma Atomic (Level); -- Number of times the Thread owning the Id enter the mutex -- minus the number of calls to Leave. Await_Count : Integer := 0; -- Number of tasks waiting on Enter. MMutex : PTM.Mutex_Access; MCondition : PTCV.Condition_Access; Passing : Boolean; end record; end PolyORB.Tasking.Advanced_Mutexes; polyorb-2.8~20110207.orig/src/polyorb-any.ads0000644000175000017500000013250711750740340020145 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . A N Y -- -- -- -- S p e c -- -- -- -- Copyright (C) 2001-2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- Definition of the universal container/wrapper type 'Any' pragma Ada_2005; pragma Warnings (Off); -- The following are internal GNAT units: with Ada.Strings.Superbounded; with Ada.Strings.Wide_Superbounded; pragma Warnings (On); with System; with PolyORB.Smart_Pointers; with PolyORB.Types; package PolyORB.Any is pragma Preelaborate; --------- -- Any -- --------- type Any is private; procedure Initialize (Self : in out Any); function Image (A : Any) return Standard.String; -- For debugging purposes. type Any_Container is tagged limited private; type Any_Container_Ptr is access all Any_Container'Class; -- The entity designated by an Any function Image (C : Any_Container'Class) return Standard.String; -- For debugging purposes. ------------- -- Content -- ------------- -- Wrapper for an access to the stored value of an Any type Content is abstract tagged private; type Content_Ptr is access all Content'Class; function Clone (CC : Content; Into : Content_Ptr := null) return Content_Ptr is abstract; -- Value copy primitive. If Into is null, storage is first allocated to -- hold a new copy of the value designated by Content. Then, if the value -- can be copied directly (i.e. either when Into was null and an adapted -- new Content has been allocated, or when Into designates a Content of -- the proper type), the value is assigned, and an access to the new copy -- is returned (may be Into itself). -- When Into is not null but does not support direct in-place assignment -- of the value, no copy is performed, and null is returned. procedure Finalize_Value (CC : in out Content) is abstract; -- Deallocate the stored value type No_Content is new Content with private; -- Placeholder for a missing content generic type T is private; function No_Wrap (X : access T) return Content'Class; -- Dummy Wrap function for types that do not implement proper wrapping -- (should never be called). function Unchecked_Get_V (X : not null access Content) return System.Address; pragma Inline (Unchecked_Get_V); -- Unchecked access to the wrapped value. Default implementation returns -- Null_Address; derived types are allowed not to redefine it. --------------- -- TypeCodes -- --------------- -- See spec CORBA V3.0, Ada Langage Mapping 1.33 type TCKind is (Tk_Null, Tk_Void, Tk_Short, Tk_Long, Tk_Ushort, Tk_Ulong, Tk_Float, Tk_Double, Tk_Boolean, Tk_Char, Tk_Octet, Tk_Any, Tk_TypeCode, Tk_Principal, Tk_Objref, -- Aggregates Tk_Struct, Tk_Union, Tk_Enum, Tk_Sequence, Tk_Array, Tk_Except, Tk_Fixed, -- End aggregates Tk_String, Tk_Alias, Tk_Longlong, Tk_Ulonglong, Tk_Longdouble, Tk_Widechar, Tk_Wstring, Tk_Value, Tk_Valuebox, Tk_Native, Tk_Abstract_Interface, Tk_Local_Interface, Tk_Component, Tk_Home, Tk_Event); subtype Aggregate_TCKind is TCKind range Tk_Struct .. Tk_Fixed; type ValueModifier is new Types.Short; VTM_NONE : constant ValueModifier; VTM_CUSTOM : constant ValueModifier; VTM_ABSTRACT : constant ValueModifier; VTM_TRUNCATABLE : constant ValueModifier; type Visibility is new Types.Short; PRIVATE_MEMBER : constant Visibility; PUBLIC_MEMBER : constant Visibility; package TypeCode is ---------- -- Spec -- ---------- type Local_Ref is private; pragma Preelaborable_Initialization (Local_Ref); type Object (Kind : TCKind) is new Smart_Pointers.Non_Controlled_Entity with record Parameters : Content_Ptr; end record; type Object_Ptr is access all Object; -- A typecode is a locality constrained pseudo object with reference -- counting. function Object_Of (Self : Local_Ref) return Object_Ptr; pragma Inline (Object_Of); -- Return a pointer to underlying object (care must be taken to not -- keep this pointer around beyond the lifetime of said object). function To_Ref (Self : Object_Ptr) return Local_Ref; -- Build a new reference to an existing TypeCode object function Is_Nil (Self : Local_Ref) return Boolean; -- True if Self has not been set to designate any specific TypeCode -- object. procedure Disable_Reference_Counting (Self : in out Object); -- Mark Self as not to be subjected to reference counting Bounds : exception; BadKind : exception; Bad_TypeCode : exception; -- Note: this unit raises 'pure' Ada exceptions. An application or -- protocol personality built upon these subprograms must wrap them -- to raise proper exceptions or messages. function Equal (Left, Right : Object_Ptr) return Boolean; function Equal (Left, Right : Local_Ref) return Boolean; -- TypeCode equality function "=" (Left, Right : Local_Ref) return Boolean renames Equal; function Equivalent (Left, Right : Object_Ptr) return Boolean; function Equivalent (Left, Right : Local_Ref) return Boolean; -- Equivalence between two typecodes as defined in section 10.7.1 of -- the CORBA V2.3 specifications. -------------------------------- -- Accessors from CORBA specs -- -------------------------------- function Kind (Self : Object_Ptr) return TCKind; function Kind (Self : Local_Ref) return TCKind; -- Return the kind of a typecode. Note: as a small optimization, calling -- this function on an unset typecode reference will return Tk_Void. function Id (Self : Object_Ptr) return Types.RepositoryId; function Id (Self : Local_Ref) return Types.RepositoryId; -- Return the repository id associated with a complex typecode of one -- of the following kinds: objref, struct, union, enum, alias, value, -- valuebox, native, abstract_interface or except. -- Otherwise raises BadKind. -- ??? should return Standard.String function Name (Self : Object_Ptr) return Types.Identifier; function Name (Self : Local_Ref) return Types.Identifier; -- Return the name associated with a complex typecode of one of the -- following kinds: objref, struct, union, enum, alias, value, valuebox, -- native, abstract_interface or except. -- Otherwise raises BadKind. -- ??? should return Standard.String function Member_Count (Self : Object_Ptr) return Types.Unsigned_Long; function Member_Count (Self : Local_Ref) return Types.Unsigned_Long; -- Return the number of members associated with a struct, union, enum, -- value or except typecode. -- Otherwise raises BadKind. function Member_Name (Self : Object_Ptr; Index : Types.Unsigned_Long) return Types.Identifier; function Member_Name (Self : Local_Ref; Index : Types.Unsigned_Long) return Types.Identifier; -- Return the name of the indicated member of a struct, union, enum, -- value or except typecode. Raises Bounds if Index is too big. -- Raises BadKind for other typecode kinds. -- ???? should return Standard.String function Member_Type (Self : Object_Ptr; Index : Types.Unsigned_Long) return Object_Ptr; function Member_Type (Self : Local_Ref; Index : Types.Unsigned_Long) return Local_Ref; -- Return the type of the indicated member of a struct, union, enum, -- value or except typecode. Raises Bounds if Index is too big. -- Raises BadKind for other typecode kinds. function Member_Label (Self : Local_Ref; Index : Types.Unsigned_Long) return Any; function Member_Label (Self : Local_Ref; Index : Types.Unsigned_Long) return Any_Container_Ptr; function Member_Label (Self : Object_Ptr; Index : Types.Unsigned_Long) return Any; function Member_Label (Self : Object_Ptr; Index : Types.Unsigned_Long) return Any_Container_Ptr; -- Return the label of the indicated member of a union typecode. -- Raises Bounds if Index is too big. -- Raises BadKind for other typecode kinds. function Enumerator_Name (Self : Object_Ptr; Index : Types.Unsigned_Long) return Types.Identifier; function Enumerator_Name (Self : Local_Ref; Index : Types.Unsigned_Long) return Types.Identifier; -- Return the name of the Index'th enumerator in an enumeration. -- Raises Bounds if Index is too big. -- Raises BadKind for other typecode kinds. -- ??? should return Standard.String function Discriminator_Type (Self : Object_Ptr) return Object_Ptr; function Discriminator_Type (Self : Local_Ref) return Local_Ref; -- Return the discriminator type of a union typecode. -- Raises BadKind for other typecode kinds. function Default_Index (Self : Object_Ptr) return Types.Long; function Default_Index (Self : Local_Ref) return Types.Long; -- Return the position of the default member of a union typecode, or -- -1 if there is no default member. -- Raises BadKind for other typecode kinds. function Length (Self : Object_Ptr) return Types.Unsigned_Long; function Length (Self : Local_Ref) return Types.Unsigned_Long; -- Return the length associated with a string, wide_string, sequence -- or array typecode. -- Raise BadKind for other typecode kinds. function Content_Type (Self : Object_Ptr) return Object_Ptr; function Content_Type (Self : Local_Ref) return Local_Ref; -- Return the element type associated with a string, wide_string, -- sequence or array typecode. -- Raise BadKind for other typecode kinds. function Fixed_Digits (Self : Object_Ptr) return Types.Unsigned_Short; function Fixed_Digits (Self : Local_Ref) return Types.Unsigned_Short; -- Return the number of digits of a fixed typecode. -- Raise BadKind for other typecode kinds. function Fixed_Scale (Self : Object_Ptr) return Types.Short; function Fixed_Scale (Self : Local_Ref) return Types.Short; -- Return the scale of digits of a fixed typecode. -- Raise BadKind for other typecode kinds. function Member_Visibility (Self : Object_Ptr; Index : Types.Unsigned_Long) return Visibility; function Member_Visibility (Self : Local_Ref; Index : Types.Unsigned_Long) return Visibility; -- Return the visibility of the indicated member of a value typecode. -- Raises Bounds if Index is too big. -- Raises BadKind for other typecode kinds. function Type_Modifier (Self : Object_Ptr) return ValueModifier; function Type_Modifier (Self : Local_Ref) return ValueModifier; -- Return the type modifier of a value typecode. -- Raises BadKind for other typecode kinds. function Concrete_Base_Type (Self : Object_Ptr) return Object_Ptr; function Concrete_Base_Type (Self : Local_Ref) return Local_Ref; -- Return the concrete base type of a value typecode. -- Raises BadKind for other typecode kinds. ------------------------------------------------- -- Supplementary accessors provided by PolyORB -- ------------------------------------------------- function Parameter_Count (Self : Object_Ptr) return Types.Unsigned_Long; function Parameter_Count (Self : Local_Ref) return Types.Unsigned_Long; -- Return the number of parameters in typecode Self function Member_Type_With_Label (Self : Object_Ptr; Label : Any_Container'Class) return Object_Ptr; function Member_Type_With_Label (Self : Object_Ptr; Label : Any) return Object_Ptr; function Member_Type_With_Label (Self : Local_Ref; Label : Any_Container'Class) return Local_Ref; function Member_Type_With_Label (Self : Local_Ref; Label : Any) return Local_Ref; -- Return the type of the member of a union typecode for the given -- label value. -- Raises BadKind for other typecode kinds. ------------------------------------------------------------------- -- Low-level accessors for construction/destruction of typecodes -- ------------------------------------------------------------------- procedure Add_Parameter (Self : Local_Ref; Param : Any); -- Append Param to Self's parameter list procedure Finalize (Self : in out Object); -- Reclaim all storage associated with Self's parameters -- Standard typecode constants function TC_Null return Local_Ref; function TC_Void return Local_Ref; function TC_Short return Local_Ref; function TC_Long return Local_Ref; function TC_Long_Long return Local_Ref; function TC_Unsigned_Short return Local_Ref; function TC_Unsigned_Long return Local_Ref; function TC_Unsigned_Long_Long return Local_Ref; function TC_Float return Local_Ref; function TC_Double return Local_Ref; function TC_Long_Double return Local_Ref; function TC_Boolean return Local_Ref; function TC_Char return Local_Ref; function TC_Wchar return Local_Ref; function TC_Octet return Local_Ref; function TC_Any return Local_Ref; function TC_TypeCode return Local_Ref; -- Unbounded string typecodes function TC_String return Local_Ref; function TC_Wide_String return Local_Ref; -- Factories for complex typecodes function TC_Principal return Local_Ref; function TC_Struct return Local_Ref; function TC_Union return Local_Ref; function TC_Enum return Local_Ref; function TC_Alias return Local_Ref; function TC_Except return Local_Ref; function TC_Object return Local_Ref; function TC_Fixed return Local_Ref; function TC_Sequence return Local_Ref; function TC_Array return Local_Ref; function TC_Value return Local_Ref; function TC_Valuebox return Local_Ref; function TC_Native return Local_Ref; function TC_Abstract_Interface return Local_Ref; function TC_Local_Interface return Local_Ref; function TC_Component return Local_Ref; function TC_Home return Local_Ref; function TC_Event return Local_Ref; -- Typecode objects for root types PTC_Null : aliased Object (Tk_Null); PTC_Void : aliased Object (Tk_Void); PTC_Short : aliased Object (Tk_Short); PTC_Long : aliased Object (Tk_Long); PTC_Long_Long : aliased Object (Tk_Longlong); PTC_Unsigned_Short : aliased Object (Tk_Ushort); PTC_Unsigned_Long : aliased Object (Tk_Ulong); PTC_Unsigned_Long_Long : aliased Object (Tk_Ulonglong); PTC_Float : aliased Object (Tk_Float); PTC_Double : aliased Object (Tk_Double); PTC_Long_Double : aliased Object (Tk_Longdouble); PTC_Boolean : aliased Object (Tk_Boolean); PTC_Char : aliased Object (Tk_Char); PTC_Wchar : aliased Object (Tk_Widechar); PTC_Octet : aliased Object (Tk_Octet); PTC_Any : aliased Object (Tk_Any); PTC_TypeCode : aliased Object (Tk_TypeCode); type Any_Array is array (Natural range <>) of Any; function Build_Complex_TC (Kind : TCKind; Parameters : Any_Array) return Local_Ref; -- Fill Base, a typecode with an empty parameter list as created by one -- of the above factories, with the given Parameters. function Build_String_TC (Max : Types.Unsigned_Long) return Local_Ref; -- Build typcode for [bounded] strings function Build_Wstring_TC (Max : Types.Unsigned_Long) return Local_Ref; -- Build typcode for [bounded] wide strings function Build_Sequence_TC (Element_TC : TypeCode.Local_Ref; Max : Natural) return Local_Ref; -- Build typecode for bounded sequence (if Max > 0), for unbounded -- sequence (if Max = 0). procedure Initialize; private pragma Inline (Kind); -- Internally, the parameters of a typecode are stored using a -- Default_Aggregate_Content, i.e. a dynamic table of Any_Containers. type Local_Ref is new Smart_Pointers.Ref with null record; --------------------------- -- Encoding of TypeCodes -- --------------------------- -- 1. For null, void, short, long, long_long, unsigned_short, -- unsigned_long, unsigned_long_long, float, double, -- long_double, boolean, char, Wchar, octet, any, -- TypeCode, Principal: parameters = null -- -- 2. For Objref, struct, union, enum, alias, except, value, valueBox, -- native, abstract_interface, local_interface, component, home -- and event, the first parameter will contain the name and the -- second the repository id. -- -- objref, native, abstract_interface, local_interface, component -- and home don't have any further parameters. -- -- 3. For struct and except, the next parameters will -- be alternatively a type and a name. So the number of -- parameters will be 2 * number_of_members + 2 -- -- 4. For union, the third parameter will be the -- discriminator type. The fourth will be the index of the -- default case as a long. If there's no default case, then -- you'll find -1. Then we'll have alternatively a -- member label, a member type and a member name. -- For the default label, the member label will contain a -- valid label but without any semantic significance. -- So the number of parameters will be 3 * number_of_members + 4 -- -- 5. For enum, the next parameters will be names of the -- different enumerators. So the number of parameters will be -- number_of_enumerators + 2 -- -- 6. For alias, the third parameter is its content type -- -- 7. For value and event, the third parameter will be a type -- modifier and the fourth one a concrete base type. The next -- parameters will be alternatively a visibility, a type and -- a name. So the number of parameters will be -- 3 * number_of_members + 4. -- -- 8. For valueBox, the third parameter is the content type -- -- 9. For string and wide_string, the only parameter will -- be the length of the string. Its value will be 0 for -- unbounded strings or wide strings. -- -- 10. For sequence and array, the first parameter will -- be the length of the sequence or the array and the second -- the content type. As for strings, an unbounded sequence will -- have a length of 0. -- -- 11. For fixed, the first parameter will be the digits -- number and the second the scale. end TypeCode; -- Pre-defined TypeCode "constants". function TC_Null return TypeCode.Local_Ref renames TypeCode.TC_Null; function TC_Void return TypeCode.Local_Ref renames TypeCode.TC_Void; function TC_Short return TypeCode.Local_Ref renames TypeCode.TC_Short; function TC_Long return TypeCode.Local_Ref renames TypeCode.TC_Long; function TC_Long_Long return TypeCode.Local_Ref renames TypeCode.TC_Long_Long; function TC_Unsigned_Short return TypeCode.Local_Ref renames TypeCode.TC_Unsigned_Short; function TC_Unsigned_Long return TypeCode.Local_Ref renames TypeCode.TC_Unsigned_Long; function TC_Unsigned_Long_Long return TypeCode.Local_Ref renames TypeCode.TC_Unsigned_Long_Long; function TC_Float return TypeCode.Local_Ref renames TypeCode.TC_Float; function TC_Double return TypeCode.Local_Ref renames TypeCode.TC_Double; function TC_Long_Double return TypeCode.Local_Ref renames TypeCode.TC_Long_Double; function TC_Boolean return TypeCode.Local_Ref renames TypeCode.TC_Boolean; function TC_Char return TypeCode.Local_Ref renames TypeCode.TC_Char; function TC_Wchar return TypeCode.Local_Ref renames TypeCode.TC_Wchar; function TC_Octet return TypeCode.Local_Ref renames TypeCode.TC_Octet; function TC_Any return TypeCode.Local_Ref renames TypeCode.TC_Any; function TC_TypeCode return TypeCode.Local_Ref renames TypeCode.TC_TypeCode; function TC_String return TypeCode.Local_Ref renames TypeCode.TC_String; function TC_Wide_String return TypeCode.Local_Ref renames TypeCode.TC_Wide_String; --------- -- Any -- --------- function "=" (Left, Right : Any_Container'Class) return Boolean; function "=" (Left, Right : Any) return Boolean; -- Equality on stored value function Get_Container (A : Any) return Any_Container_Ptr; -- Get the container designated by A procedure Set_Container (A : in out Any; ACP : Any_Container_Ptr); -- Set the container designated by A to ACP function Get_Value (C : Any_Container'Class) return Content_Ptr; -- Retrieve a pointer to C's contents wrapper. This pointer shall not be -- permanently saved. procedure Set_Type (C : in out Any_Container'Class; TC : TypeCode.Object_Ptr); procedure Set_Type (C : in out Any_Container'Class; TC : TypeCode.Local_Ref); -- Set the type of C to TC procedure Set_Value (C : in out Any_Container'Class; CC : Content_Ptr; Foreign : Boolean := True); -- Set the contents of C to CC. If Foreign is True then CC, and any -- associated storage, are assumed to be externally managed and won't be -- deallocated by the Any management subsystem. procedure Finalize_Value (C : in out Any_Container'Class); -- Destroy the stored content wrapper for C, if non-null and non-foreign ----------------------- -- Aggregate_Content -- ----------------------- -- Abstract interface implemented by all aggregate contents wrappers type Aggregate_Content is abstract new Content with private; function Get_Aggregate_Count (ACC : Aggregate_Content) return Types.Unsigned_Long is abstract; -- Return elements count procedure Set_Aggregate_Count (ACC : in out Aggregate_Content; Length : Types.Unsigned_Long) is abstract; -- Ensure that ACC has appropriate storage allocated for the given element -- count. For the case of a fixed-size aggregate container, -- Constraint_Error is raised if Count does not match the proper aggregate -- element count. type Mechanism is (By_Reference, By_Value); function Get_Aggregate_Element (ACC : not null access Aggregate_Content'Class; TC : TypeCode.Local_Ref; Index : Types.Unsigned_Long; Mech : not null access Mechanism) return Content'Class; function Get_Aggregate_Element (ACC : not null access Aggregate_Content; TC : TypeCode.Object_Ptr; Index : Types.Unsigned_Long; Mech : not null access Mechanism) return Content'Class is abstract; -- Return contents wrapper for one stored element. -- Upon entry, if Mech is By_Reference, the caller requests access to -- the stored element in order to update it; if it is By_Value, the caller -- needs only the value of the stored element. -- -- Upon exit, Mech is set to By_Value if the designated storage space is -- provided by the ACC content wrapper (as opposed to the actual user data -- space), in which case updates to the designated Content must be followed -- by a call to Set_Aggregate_Element to reflect the update to the original -- user data. -- -- If Mech is By_Reference upon entry, No_Content may be returned, in which -- case Mech must be By_Value upon exit. procedure Set_Aggregate_Element (ACC : in out Aggregate_Content'Class; TC : TypeCode.Local_Ref; Index : Types.Unsigned_Long; From_C : in out Any_Container'Class); procedure Set_Aggregate_Element (ACC : in out Aggregate_Content; TC : TypeCode.Object_Ptr; Index : Types.Unsigned_Long; From_C : in out Any_Container'Class); -- Update contents wrapper for one stored element using value provided by -- From_C. This may be called only in the case of an aggregate element that -- is accessed by value (i.e. for which a previous Get_Aggregate_Element -- returned with Mech set to By_Value upon exit). -- A derived type of Aggregate_Content that may return elements by value -- this primitive. -- -- This operation may leave From_C unchanged (in which case the caller is -- still responsible for deallocation of its contents) or make it empty -- (in which case this responsibility is transferred to the owner of the -- ACC aggregate). The latter case may only occur when From_C is not -- foreign. procedure Add_Aggregate_Element (ACC : in out Aggregate_Content; El : Any_Container_Ptr); -- Add an element to ACC. This is not supported by default but may be -- overridden by derived types. ------------------- -- Set_Any_Value -- ------------------- procedure Set_Any_Value (X : Types.Short; C : in out Any_Container'Class); procedure Set_Any_Value (X : Types.Long; C : in out Any_Container'Class); procedure Set_Any_Value (X : Types.Long_Long; C : in out Any_Container'Class); procedure Set_Any_Value (X : Types.Unsigned_Short; C : in out Any_Container'Class); procedure Set_Any_Value (X : Types.Unsigned_Long; C : in out Any_Container'Class); procedure Set_Any_Value (X : Types.Unsigned_Long_Long; C : in out Any_Container'Class); procedure Set_Any_Value (X : Types.Float; C : in out Any_Container'Class); procedure Set_Any_Value (X : Types.Double; C : in out Any_Container'Class); procedure Set_Any_Value (X : Types.Long_Double; C : in out Any_Container'Class); procedure Set_Any_Value (X : Types.Boolean; C : in out Any_Container'Class); procedure Set_Any_Value (X : Types.Char; C : in out Any_Container'Class); procedure Set_Any_Value (X : Types.Wchar; C : in out Any_Container'Class); procedure Set_Any_Value (X : Types.Octet; C : in out Any_Container'Class); procedure Set_Any_Value (X : Any; C : in out Any_Container'Class); procedure Set_Any_Value (X : TypeCode.Local_Ref; C : in out Any_Container'Class); procedure Set_Any_Value (X : Standard.String; C : in out Any_Container'Class); procedure Set_Any_Value (X : Types.String; C : in out Any_Container'Class); procedure Set_Any_Value (X : Types.Wide_String; C : in out Any_Container'Class); procedure Set_Any_Value (X : String; Bound : Positive; C : in out Any_Container'Class); procedure Set_Any_Value (X : Wide_String; Bound : Positive; C : in out Any_Container'Class); -- Special variants for bounded string types function To_Any (X : Types.Short) return Any; function To_Any (X : Types.Long) return Any; function To_Any (X : Types.Long_Long) return Any; function To_Any (X : Types.Unsigned_Short) return Any; function To_Any (X : Types.Unsigned_Long) return Any; function To_Any (X : Types.Unsigned_Long_Long) return Any; function To_Any (X : Types.Float) return Any; function To_Any (X : Types.Double) return Any; function To_Any (X : Types.Long_Double) return Any; function To_Any (X : Types.Boolean) return Any; function To_Any (X : Types.Char) return Any; function To_Any (X : Types.Wchar) return Any; function To_Any (X : Types.Octet) return Any; function To_Any (X : Any) return Any; function To_Any (X : TypeCode.Local_Ref) return Any; function To_Any (X : Standard.String) return Any; function To_Any (X : Types.String) return Any; function To_Any (X : Types.Wide_String) return Any; -- For bounded strings, need to provide the specific TC function To_Any (X : Ada.Strings.Superbounded.Super_String; TC : access function return TypeCode.Local_Ref) return Any; function To_Any (X : Ada.Strings.Wide_Superbounded.Super_String; TC : access function return TypeCode.Local_Ref) return Any; function Wrap (X : not null access Types.Short) return Content'Class; function Wrap (X : not null access Types.Long) return Content'Class; function Wrap (X : not null access Types.Long_Long) return Content'Class; function Wrap (X : not null access Types.Unsigned_Short) return Content'Class; function Wrap (X : not null access Types.Unsigned_Long) return Content'Class; function Wrap (X : not null access Types.Unsigned_Long_Long) return Content'Class; function Wrap (X : not null access Types.Float) return Content'Class; function Wrap (X : not null access Types.Double) return Content'Class; function Wrap (X : not null access Types.Long_Double) return Content'Class; function Wrap (X : not null access Types.Boolean) return Content'Class; function Wrap (X : not null access Types.Char) return Content'Class; function Wrap (X : not null access Types.Wchar) return Content'Class; function Wrap (X : not null access Types.Octet) return Content'Class; function Wrap (X : not null access Any) return Content'Class; function Wrap (X : not null access TypeCode.Local_Ref) return Content'Class; function Wrap (X : not null access Types.String) return Content'Class; function Wrap (X : not null access Types.Wide_String) return Content'Class; function Wrap (X : not null access Ada.Strings.Superbounded.Super_String) return Content'Class; function Wrap (X : not null access Ada.Strings.Wide_Superbounded.Super_String) return Content'Class; function From_Any (C : Any_Container'Class) return Types.Short; function From_Any (C : Any_Container'Class) return Types.Long; function From_Any (C : Any_Container'Class) return Types.Long_Long; function From_Any (C : Any_Container'Class) return Types.Unsigned_Short; function From_Any (C : Any_Container'Class) return Types.Unsigned_Long; function From_Any (C : Any_Container'Class) return Types.Unsigned_Long_Long; function From_Any (C : Any_Container'Class) return Types.Float; function From_Any (C : Any_Container'Class) return Types.Double; function From_Any (C : Any_Container'Class) return Types.Long_Double; function From_Any (C : Any_Container'Class) return Types.Boolean; function From_Any (C : Any_Container'Class) return Types.Char; function From_Any (C : Any_Container'Class) return Types.Wchar; function From_Any (C : Any_Container'Class) return Types.Octet; function From_Any (C : Any_Container'Class) return Any; function From_Any (C : Any_Container'Class) return TypeCode.Local_Ref; function From_Any (C : Any_Container'Class) return Types.String; function From_Any (C : Any_Container'Class) return Types.Wide_String; function From_Any (C : Any_Container'Class) return Standard.String; function From_Any (C : Any_Container'Class) return Standard.Wide_String; -- Special variant operating on both bounded and unbounded string anys function From_Any (A : Any) return Types.Short; function From_Any (A : Any) return Types.Long; function From_Any (A : Any) return Types.Long_Long; function From_Any (A : Any) return Types.Unsigned_Short; function From_Any (A : Any) return Types.Unsigned_Long; function From_Any (A : Any) return Types.Unsigned_Long_Long; function From_Any (A : Any) return Types.Float; function From_Any (A : Any) return Types.Double; function From_Any (A : Any) return Types.Long_Double; function From_Any (A : Any) return Types.Boolean; function From_Any (A : Any) return Types.Char; function From_Any (A : Any) return Types.Wchar; function From_Any (A : Any) return Types.Octet; function From_Any (A : Any) return Any; function From_Any (A : Any) return TypeCode.Local_Ref; function From_Any (A : Any) return Types.String; function From_Any (A : Any) return Types.Wide_String; function From_Any (A : Any) return Ada.Strings.Superbounded.Super_String; function From_Any (A : Any) return Ada.Strings.Wide_Superbounded.Super_String; function From_Any (A : Any) return String; function From_Any (A : Any) return Wide_String; function Get_Type_Obj (A : Any) return TypeCode.Object_Ptr; function Get_Type_Obj (C : Any_Container'Class) return TypeCode.Object_Ptr; function Get_Type (A : Any) return TypeCode.Local_Ref; function Get_Type (C : Any_Container'Class) return TypeCode.Local_Ref; -- Accessors for the typecode of an Any function Unwind_Typedefs (TC : TypeCode.Object_Ptr) return TypeCode.Object_Ptr; function Unwind_Typedefs (TC : TypeCode.Local_Ref) return TypeCode.Local_Ref; -- Unwind any typedef (alias) from TC function Get_Unwound_Type (The_Any : Any) return TypeCode.Object_Ptr; -- Return the actual type of The_Any, after resolution of all alias levels procedure Set_Type (A : in out Any; TC : TypeCode.Object_Ptr); procedure Set_Type (A : in out Any; TC : TypeCode.Local_Ref); -- Not in spec : change the type of an any without changing its -- value : to be used carefully function Get_Empty_Any (Tc : TypeCode.Local_Ref) return Any; -- Return an empty Any (with no value but a type) function Get_Empty_Any_Aggregate (TC : TypeCode.Local_Ref) return Any; -- Return an empty Any for the given type code. The contents of TC are -- initialized to a default aggregate contents if TC is an aggregate. -- Otherwise, this is equivalent to Get_Empty_Any. function Is_Empty (A : Any) return Boolean; function Is_Empty (C : Any_Container'Class) return Boolean; -- True when A/C has null contents procedure Set_Any_Aggregate_Value (Agg_C : in out Any_Container'Class); -- This one is a bit special : it doesn't put any value but -- create the aggregate value if it does not exist. -- Not in spec : some methods to deal with any aggregates. -- What is called any aggregate is an any, made of an aggregate -- of values, instead of one unique. It is used for structs, -- unions, enums, arrays, sequences, objref, values... function Get_Aggregate_Count (Value : Any) return Types.Unsigned_Long; -- Return the number of elements in an any aggregate procedure Add_Aggregate_Element (Value : in out Any; Element : Any); -- Adds an element to an aggregate Any function Get_Aggregate_Element (Value : Any; TC : TypeCode.Local_Ref; Index : Types.Unsigned_Long) return Any; function Get_Aggregate_Element (Value : Any; TC : TypeCode.Object_Ptr; Index : Types.Unsigned_Long) return Any; -- Gets an element in an aggregate Any. -- Return an any made of the typecode TC and the value read in -- the aggregate. The first element has index 0. function Get_Aggregate_Element (Value : Any_Container'Class; Index : Types.Unsigned_Long) return Types.Unsigned_Long; function Get_Aggregate_Element (Value : Any; Index : Types.Unsigned_Long) return Types.Unsigned_Long; function Get_Aggregate_Element (Value : Any_Container'Class; Index : Types.Unsigned_Long) return Types.Octet; function Get_Aggregate_Element (Value : Any; Index : Types.Unsigned_Long) return Types.Octet; -- Specialized efficient versions for often-used base data types procedure Copy_Any_Value (Dst : Any; Src : Any); -- Set the value of Dest from a copy of the value of Src (as Set_Any_Value -- would do, but without the need to know the precise type of Src). Dest -- and Src must be Any's with identical typecodes. -- If Dest is empty, new storage is allocated for it. -- Note: This is not the same as Set_Any_Value (Dest, Src), which sets the -- value of Dest (an Any which a TC_Any type code) to be Src (not just the -- /value/ of Src). procedure Move_Any_Value (Dst : Any; Src : Any); -- Set the value of Dest to the value of Src, and make Src empty. -- Dest and Src must be Any's with identical typecodes. Dst may be empty. function Copy_Any (Src : Any) return Any; -- Create a new Any with the same typecode as Src, and set its value to -- a copy of Src's. ---------------- -- NamedValue -- ---------------- type Flags is new Types.Unsigned_Long; ARG_IN : constant Flags; ARG_OUT : constant Flags; ARG_INOUT : constant Flags; IN_COPY_VALUE : constant Flags; type NamedValue is record Name : Types.Identifier; Argument : Any; Arg_Modes : Flags; end record; function Image (TC : TypeCode.Object_Ptr) return Standard.String; function Image (TC : TypeCode.Local_Ref) return Standard.String; function Image (NV : NamedValue) return Standard.String; -- For debugging purposes private VTM_NONE : constant ValueModifier := 0; VTM_CUSTOM : constant ValueModifier := 1; VTM_ABSTRACT : constant ValueModifier := 2; VTM_TRUNCATABLE : constant ValueModifier := 3; PRIVATE_MEMBER : constant Visibility := 0; PUBLIC_MEMBER : constant Visibility := 1; --------- -- Any -- --------- -- An Any is a smart reference-counted pointer to a container that holds: -- - one field for the typecode (TypeCode.Object) -- - one field for the value -- -- To be able to carry values of different types, the second field is a -- pointer to an Content wrapper, which encapsulates a pointer to the -- actual stored data. For every elementary type that can be stored in an -- Any, there exsists derived type of Any_Container with appropriate -- accessors. -- -- For complex types (with several values, like structures, arrays...), -- we use a special wrapper, Content_Aggregate, which has a field -- pointing on a list of stored objects; various methods are provided -- to manipulate this list. type Content is abstract tagged null record; type No_Content is new Content with null record; function Clone (CC : No_Content; Into : Content_Ptr := null) return Content_Ptr; procedure Finalize_Value (CC : in out No_Content); -- These operations should never be called on a No_Content value ------------------ -- The Any type -- ------------------ type Any is new PolyORB.Smart_Pointers.Ref with null record; type Any_Container is new PolyORB.Smart_Pointers.Non_Controlled_Entity with record The_Type : TypeCode.Local_Ref; -- TypeCode describing the data The_Value : Content_Ptr; -- Pointer to the stored value, wrapper in a Content. -- Null for an empty Any. Is_Finalized : Boolean := False; -- Set to True in Finalize, used to detect double finalization Foreign : Boolean := True; -- If True, storage for The_Value and for the designated actual -- stored value was provided by the client of PolyORB.Any, and must -- not be deallocated upon finalization of the container. If False, -- the storage was provided by the Any management routines, and is -- deallocated when the container is destroyed. end record; procedure Finalize (Self : in out Any_Container); -- Finalize Container, deallocating associated resources if necessary -- (this is not Ada finalization, but the Finalize primitive of the -- Non_Controlled_Entity type). -- Some methods to deal with the Any fields. ----------------------- -- Aggregate_Content -- ----------------------- type Aggregate_Content is abstract new Content with null record; ------------------ -- Named_Value -- ------------------ ARG_IN : constant Flags := 0; ARG_OUT : constant Flags := 1; ARG_INOUT : constant Flags := 2; IN_COPY_VALUE : constant Flags := 3; -------------------------------------------------------------------- -- Facilities for construction of generic elementary Any handlers -- -------------------------------------------------------------------- generic type T (<>) is private; with function From_Any (C : Any_Container'Class) return T; function From_Any_G (A : Any) return T; -- Default From_Any generic type T (<>) is private; with function TC return TypeCode.Local_Ref; with procedure Set_Any_Value (X : T; C : in out Any_Container'Class); function To_Any_G (X : T) return Any; -- Default To_Any -- Generic Any container for elementary types generic type T (<>) is private; Kind : TCKind; package Elementary_Any is type T_Ptr is access all T; type T_Content is new Content with private; function Clone (CC : T_Content; Into : Content_Ptr := null) return Content_Ptr; procedure Finalize_Value (CC : in out T_Content); function From_Any (C : Any_Container'Class) return T; function From_Any is new From_Any_G (T, From_Any); pragma Inline (From_Any); procedure Set_Any_Value (X : T; C : in out Any_Container'Class); -- Note: this assumes that C has the proper typecode function Wrap (X : not null access T) return Content'Class; function Unchecked_Get_V (X : not null access T_Content) return System.Address; pragma Inline (Unchecked_Get_V); function Unchecked_Get_V (X : not null access T_Content) return T_Ptr; pragma Inline (Unchecked_Get_V); -- Unchecked access to the wrapped value function Get_Aggregate_Element (Value : Any_Container'Class; Index : Types.Unsigned_Long) return T; function Get_Aggregate_Element (Value : Any; Index : Types.Unsigned_Long) return T; -- Shortcut accessors for aggregate elements of type T private type T_Content is new Content with record V : T_Ptr; end record; end Elementary_Any; end PolyORB.Any; polyorb-2.8~20110207.orig/src/polyorb-utils-socket_access_points.ads0000644000175000017500000000474511750740340024723 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . U T I L S . S O C K E T _ A C C E S S _ P O I N T S -- -- -- -- S p e c -- -- -- -- Copyright (C) 2007, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- Common definitions for all socket-based access points with PolyORB.Parameters; with PolyORB.Sockets; package PolyORB.Utils.Socket_Access_Points is use PolyORB.Parameters; use PolyORB.Sockets; type Port_Interval is record Lo, Hi : Port_Type; end record; function To_Port_Interval (I : Interval) return Port_Interval; pragma Inline (To_Port_Interval); -- Convert an integer interval to a port interval end PolyORB.Utils.Socket_Access_Points; polyorb-2.8~20110207.orig/src/polyorb-utils-strings.ads0000644000175000017500000000577411750740340022212 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . U T I L S . S T R I N G S -- -- -- -- S p e c -- -- -- -- Copyright (C) 2001-2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- General-purpose string pointer and related functions with Ada.Unchecked_Deallocation; package PolyORB.Utils.Strings is pragma Preelaborate; ----------------- -- Conversions -- ----------------- function To_Boolean (V : String) return Boolean; -- Convert a String value to a Boolean value according to the following -- interpretation rules: -- * True if the value starts with '1' or 'Y' or 'y', -- or is "on" or "enable" or "true" -- * False if the value starts with '0' or 'n' or 'N', -- or is "off" or "disable" or "false" or empty. -- Constraint_Error is raised if the value is set to anything else. --------------------- -- String accesses -- --------------------- type String_Ptr is access all Standard.String; function "+" (S : Standard.String) return String_Ptr; pragma Inline ("+"); -- Return new String('S) procedure Free is new Ada.Unchecked_Deallocation (Standard.String, String_Ptr); end PolyORB.Utils.Strings; polyorb-2.8~20110207.orig/src/polyorb-jobs.ads0000644000175000017500000001005011750740340020277 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . J O B S -- -- -- -- S p e c -- -- -- -- Copyright (C) 2001-2008, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- Job management for ORB activities. pragma Ada_2005; with PolyORB.Utils.Chained_Lists; package PolyORB.Jobs is pragma Preelaborate; --------- -- Job -- --------- type Job is abstract tagged limited private; -- A Job is any elementary activity that may be assigned to an ORB task to -- be entirely processed within one ORB loop iteration. type Job_Access is access all Job'Class; procedure Free (X : in out Job_Access); procedure Run (J : not null access Job) is abstract; -- Execute the given Job. A task processes a Job by invoking its Run -- primitive. --------------- -- Job_Queue -- --------------- type Job_Queue is limited private; type Job_Queue_Access is access all Job_Queue; -- A queue of pending jobs function Create_Queue return Job_Queue_Access; -- Create a new job queue procedure Queue_Job (Q : access Job_Queue; J : Job_Access); -- Enter a pending Job into Q. function Is_Empty (Q : access Job_Queue) return Boolean; -- True if, and only if, Q contains no pending Job function Fetch_Job (Q : access Job_Queue; Selector : access function (J : Job'Class) return Boolean := null) return Job_Access; -- Returns a pending Job that matches Selector (i.e. such that -- Selector.all (Job) is true), and remove it from Q. Null is returned if -- no matching job exists. All jobs match a null Selector. -- The caller must ensure that all primitive operations of Job_Queue are -- called only from within a critical section. function Length (Q : access Job_Queue) return Natural; private pragma Inline (Queue_Job); pragma Inline (Is_Empty); pragma Inline (Fetch_Job); pragma Inline (Length); type Job is abstract tagged limited null record; package Job_Queues is new PolyORB.Utils.Chained_Lists (Job_Access, Doubly_Chained => True); subtype Job_Queue_Internal is Job_Queues.List; type Job_Queue is limited record Contents : Job_Queue_Internal; end record; end PolyORB.Jobs; polyorb-2.8~20110207.orig/src/csupport.c0000644000175000017500000000500511750740340017214 0ustar xavierxavier/**************************************************************************** * * * POLYORB COMPONENTS * * * * C S U P P O R T * * * * C s u p p o r t f i l e * * * * Copyright (C) 2008-2010, Free Software Foundation, Inc. * * * * PolyORB is free software; you can redistribute it and/or modify it * * under terms of the GNU General Public License as published by the Free * * Software Foundation; either version 2, or (at your option) any later * * version. PolyORB is distributed in the hope that it will be useful, * * but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- * * TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public * * License for more details. You should have received a copy of the GNU * * General Public License distributed with PolyORB; see file COPYING. If * * not, write to the Free Software Foundation, 59 Temple Place - Suite 330, * * Boston, MA 02111-1307, USA. * * * * PolyORB is maintained by AdaCore * * (email: sales@adacore.com) * * * ****************************************************************************/ /* C support functions for PolyORB */ #include "config.h" #ifdef HAVE_FCNTL_H #include #endif #ifdef HAVE_STRFTIME # include #endif void __PolyORB_detach(void) { #ifdef HAVE_SETSID int devnull_fd = open ("/dev/null", O_RDWR); if (devnull_fd < 0) return; (void) dup2 (devnull_fd, 0); (void) dup2 (devnull_fd, 1); (void) dup2 (devnull_fd, 2); (void) setsid (); #endif } void __PolyORB_timestamp (char *buf, int bufsize) { #ifdef HAVE_STRFTIME time_t now = time (NULL); struct tm *tm = localtime (&now); strftime (buf, bufsize, "%Y-%m-%d %T ", tm); #endif } polyorb-2.8~20110207.orig/src/polyorb-representations-cdr-common.ads0000644000175000017500000002466211750740340024641 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . R E P R E S E N T A T I O N S . C D R . C O M M O N -- -- -- -- S p e c -- -- -- -- Copyright (C) 2002-2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- This package containts marshalling/unmarshalling subprograms for base -- types, which representation is GIOP version independent. -- XXX Also this package contains marshalling/unmarshalling subprogram -- for object references, which must be removed. with Ada.Streams; with PolyORB.Any; with PolyORB.Buffers; with PolyORB.References; with PolyORB.Types; package PolyORB.Representations.CDR.Common is pragma Elaborate_Body; use Ada.Streams; use PolyORB.Buffers; ------------------------------------------------- -- The Encapsulation view of a CDR data stream -- ------------------------------------------------- -- A CDR data stream is a sequence of bytes that can be -- turned into an opaque Encapsulation object and back. subtype Encapsulation is Stream_Element_Array; function Encapsulate (Buffer : access Buffer_Type) return Encapsulation; -- Create an Octet_Array corresponding to Buffer -- as an encapsulation. procedure Start_Encapsulation (Buffer : access Buffer_Type); -- Prepare Buffer to receive marshalled data -- that will be turned into an Encapsulation. procedure Decapsulate (Octets : access Encapsulation; Buffer : access Buffer_Type); -- Initialize a buffer with an Octet_Array -- corresponding to an Encapsulation. -- Buffer must be a fresh, empty buffer. -- The lifespan of the actual Octets array -- shall be no less than that of Buffer. ----------------------------------------------- -- Marshalling and unmarshalling subprograms -- ----------------------------------------------- -- 'Octet' type procedure Marshall (Buffer : access Buffer_Type; Data : access PolyORB.Types.Octet); procedure Marshall (Buffer : access Buffer_Type; Data : PolyORB.Types.Octet); function Unmarshall (Buffer : access Buffer_Type) return PolyORB.Types.Octet; -- 'Char' type as defined by GIOP 1.0 (in ISO-8859-1 character set) procedure Marshall_Latin_1_Char (Buffer : access Buffer_Type; Data : PolyORB.Types.Char); function Unmarshall_Latin_1_Char (Buffer : access Buffer_Type) return PolyORB.Types.Char; -- 'Boolean' type procedure Marshall (Buffer : access Buffer_Type; Data : access PolyORB.Types.Boolean); procedure Marshall (Buffer : access Buffer_Type; Data : PolyORB.Types.Boolean); function Unmarshall (Buffer : access Buffer_Type) return PolyORB.Types.Boolean; -- 'Unsigned_Short' type procedure Marshall (Buffer : access Buffer_Type; Data : access PolyORB.Types.Unsigned_Short); procedure Marshall (Buffer : access Buffer_Type; Data : PolyORB.Types.Unsigned_Short); function Unmarshall (Buffer : access Buffer_Type) return PolyORB.Types.Unsigned_Short; -- 'Unsigned_Long' type procedure Marshall (Buffer : access Buffer_Type; Data : access PolyORB.Types.Unsigned_Long); procedure Marshall (Buffer : access Buffer_Type; Data : PolyORB.Types.Unsigned_Long); function Unmarshall (Buffer : access Buffer_Type) return PolyORB.Types.Unsigned_Long; -- 'Unsigned_Long_Long' type procedure Marshall (Buffer : access Buffer_Type; Data : access PolyORB.Types.Unsigned_Long_Long); procedure Marshall (Buffer : access Buffer_Type; Data : PolyORB.Types.Unsigned_Long_Long); function Unmarshall (Buffer : access Buffer_Type) return PolyORB.Types.Unsigned_Long_Long; -- 'Short' type procedure Marshall (Buffer : access Buffer_Type; Data : access PolyORB.Types.Short); procedure Marshall (Buffer : access Buffer_Type; Data : PolyORB.Types.Short); function Unmarshall (Buffer : access Buffer_Type) return PolyORB.Types.Short; -- 'Long' type procedure Marshall (Buffer : access Buffer_Type; Data : access PolyORB.Types.Long); procedure Marshall (Buffer : access Buffer_Type; Data : PolyORB.Types.Long); function Unmarshall (Buffer : access Buffer_Type) return PolyORB.Types.Long; -- 'Long_Long' type procedure Marshall (Buffer : access Buffer_Type; Data : access PolyORB.Types.Long_Long); procedure Marshall (Buffer : access Buffer_Type; Data : PolyORB.Types.Long_Long); function Unmarshall (Buffer : access Buffer_Type) return PolyORB.Types.Long_Long; -- 'Float' type procedure Marshall (Buffer : access Buffer_Type; Data : access PolyORB.Types.Float); procedure Marshall (Buffer : access Buffer_Type; Data : PolyORB.Types.Float); function Unmarshall (Buffer : access Buffer_Type) return PolyORB.Types.Float; -- 'Double' type procedure Marshall (Buffer : access Buffer_Type; Data : access PolyORB.Types.Double); procedure Marshall (Buffer : access Buffer_Type; Data : PolyORB.Types.Double); function Unmarshall (Buffer : access Buffer_Type) return PolyORB.Types.Double; -- 'Long_Double' type procedure Marshall (Buffer : access Buffer_Type; Data : access PolyORB.Types.Long_Double); procedure Marshall (Buffer : access Buffer_Type; Data : PolyORB.Types.Long_Double); function Unmarshall (Buffer : access Buffer_Type) return PolyORB.Types.Long_Double; -- 'String' type as defined by GIOP 1.0 (in ISO-8859-1 character set) procedure Marshall_Latin_1_String (Buffer : access Buffer_Type; Data : PolyORB.Types.String); function Unmarshall_Latin_1_String (Buffer : access Buffer_Type) return PolyORB.Types.String; -- 'Identifier' type procedure Marshall (Buffer : access Buffer_Type; Data : access PolyORB.Types.Identifier); procedure Marshall (Buffer : access Buffer_Type; Data : PolyORB.Types.Identifier); function Unmarshall (Buffer : access Buffer_Type) return PolyORB.Types.Identifier; -- 'RepositoryId' type procedure Marshall (Buffer : access Buffer_Type; Data : access PolyORB.Types.RepositoryId); procedure Marshall (Buffer : access Buffer_Type; Data : PolyORB.Types.RepositoryId); function Unmarshall (Buffer : access Buffer_Type) return PolyORB.Types.RepositoryId; -- 'ValueModifier' type procedure Marshall (Buffer : access Buffer_Type; Data : access PolyORB.Any.ValueModifier); procedure Marshall (Buffer : access Buffer_Type; Data : PolyORB.Any.ValueModifier); function Unmarshall (Buffer : access Buffer_Type) return PolyORB.Any.ValueModifier; -- 'Visibility' type procedure Marshall (Buffer : access Buffer_Type; Data : access PolyORB.Any.Visibility); procedure Marshall (Buffer : access Buffer_Type; Data : PolyORB.Any.Visibility); function Unmarshall (Buffer : access Buffer_Type) return PolyORB.Any.Visibility; -- Object References (but not valuetypes) procedure Marshall (Buffer : access Buffer_Type; Data : PolyORB.References.Ref'Class); procedure Unmarshall (Buffer : access Buffer_Type; Data : in out PolyORB.References.Ref'Class); function Unmarshall (Buffer : access Buffer_Type) return PolyORB.References.Ref; -- Octets sequences procedure Marshall (Buffer : access Buffer_Type; Data : access Stream_Element_Array); procedure Marshall (Buffer : access Buffer_Type; Data : Stream_Element_Array); function Unmarshall (Buffer : access Buffer_Type) return Stream_Element_Array; -- Fixed_Point types generic type F is delta <> digits <>; package Fixed_Point is procedure Marshall (Buffer : access Buffer_Type; Data : access F); procedure Marshall (Buffer : access Buffer_Type; Data : F); function Unmarshall (Buffer : access Buffer_Type) return F; function Fixed_To_Octets (Data : F) return Stream_Element_Array; function Octets_To_Fixed (Octets : Stream_Element_Array) return F; end Fixed_Point; -- Standard 'String' type procedure Marshall_Latin_1_String (Buffer : access Buffer_Type; Data : Standard.String); function Unmarshall_Latin_1_String (Buffer : access Buffer_Type) return Standard.String; end PolyORB.Representations.CDR.Common; polyorb-2.8~20110207.orig/src/polyorb-utils-htables-perfect.adb0000644000175000017500000007526611750740340023553 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . U T I L S . H T A B L E S . P E R F E C T -- -- -- -- B o d y -- -- -- -- Copyright (C) 2002-2008, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by ACT Europe. -- -- (email: sales@act-europe.fr) -- -- -- ------------------------------------------------------------------------------ with Ada.Unchecked_Deallocation; package body PolyORB.Utils.HTables.Perfect is use PolyORB.Utils.Strings; ------------------------ -- Utility procedures -- ------------------------ -- These procedures are utiliy procedures used by the Hash_Table -- type, some of them are defined in the Dietzfelbinger algorithm. procedure Add_Key_To_Subtable (Key : String; ST_Index : Natural; T : in out Hash_Table); -- Insert the Key in an unused Element in subtable ST_Index procedure Find_Hash_For_Subtable (ST_Index : Natural; T : Hash_Table); -- Find an injective hash function associated to the subtable -- at position ST_Index. function Is_Injective (ST_Index : Natural; T : Hash_Table) return Boolean; -- Return true iff the hash function associated to the subtable at -- position subtable ST_Index is injective. procedure Process_Subtable (ST_Index : Natural; T : in out Hash_Table); -- Find the K parameter of subtable ST_Index in order to have -- an injective hash function and to reorder the subtable. procedure Rehash_Subtable (ST_Index : Natural; T : Hash_Table); -- Apply the Hashcode function to each element of subtable -- ST_Index, store the results in the ST_Offset component -- of the component. procedure Rehash_All (Key : String; T : in out Hash_Table); -- Reorganize all the tables. procedure Swap_Elements (T : in out Hash_Table; Index1 : Natural; Index2 : Natural); pragma Inline (Swap_Elements); -- Swap elements at index1 and index2. procedure Free_Table is new Ada.Unchecked_Deallocation (Table, Table_Access); procedure Free_Item is new Ada.Unchecked_Deallocation (Item, Item_Access); ---------------------------------- -- Hash_Table related functions -- ---------------------------------- -- These functions allows for the management of the Hash_Table -- index table used by the hash table. procedure Initialize (T : out Hash_Table; HParam : Hash_Parameters := Default_Hash_Parameters; Max : Natural); -- Initialize the hash table. -- 'HParam' are the hash function parameters, -- 'Max' is the max number of elements to store. procedure Finalize (T : in out Hash_Table); -- Finalize the Hast Table. type Next_Action is (Reorder_SubTable, Reorder_Table, Do_Nothing, Insert_Item); -- Indicate the next action to do after a value has been inserted -- in the hash table index. See the specification of the Insert -- procedure for more details. procedure Insert (T : in out Hash_Table; Key : String; ST_Index : out Natural; ST_Offset : out Natural; To_Do : out Next_Action); -- Insert key in hash table. In case of an already existing Key, -- Insert ignores insertion. Key is the string to hash. -- ST_Index corresponds to the subtable index and ST_Offset to -- the offset in this subtable of the inserted Key -- To_Do indicates if: -- - a reorder of a sub-table or the table is -- necessary or not after the insertion (Reorder_SubTable or -- Reorder_Table) -- - an item associated with the key can be inserted (Insert_Item) -- - the key already exists (Nothing_To_Do) procedure Insert (T : in out Hash_Table; Key : String; Index : out Natural; To_Do : out Next_Action); -- Insert 'Key' in hash table. This function is a wrapper on the -- previous function, it directly returns the index of the Item -- corresponding to 'Key' procedure Lookup (T : Hash_Table; Key : String; ST_Index : out Natural; ST_Offset : out Natural; Found : out Boolean); -- Find 'Key' in hash table. -- If the key is 'Found', then 'ST_Index', 'ST_Offset' return the -- object position in the subtable. procedure Lookup (T : Hash_Table; Key : String; Index : out Natural; Found : out Boolean); -- Find 'Key' in hash table. This function is a wrapper on the -- previous function, it directly returns the index of the Item -- corresponding to 'Key' procedure Delete (T : in out Hash_Table; Key : String; Index : out Natural); -- Delete key in hash table. In case of a non-existing Key, Delete -- ignores deletion. Key is the string to hash. -- When a Key is deleted, it's not physically. Indeed it puts just -- the tag Used to False --------------------------------------- -- Utility procedures implementation -- --------------------------------------- ------------------- -- Swap_Elements -- ------------------- procedure Swap_Elements (T : in out Hash_Table; Index1 : Natural; Index2 : Natural) is Elements : access Dynamic_Element_Array.Table_Type renames T.Elements.Table; Swap : Element; begin Swap := Elements (Index1); Elements (Index1) := Elements (Index2); Elements (Index2) := Swap; end Swap_Elements; --------------------- -- Rehash_Subtable -- --------------------- procedure Rehash_Subtable (ST_Index : Natural; T : Hash_Table) is Elements : access Dynamic_Element_Array.Table_Type renames T.Elements.Table; Subtables : access Dynamic_Subtable_Array.Table_Type renames T.Subtables.Table; begin for J in Subtables (ST_Index).First .. Subtables (ST_Index).Last loop if Elements (J).Key /= null and then Elements (J).Used then Elements (J).ST_Index := ST_Index; Elements (J).ST_Offset := Hash (Elements (J).Key.all, Subtables (ST_Index).HParam, Subtables (ST_Index).Max); end if; end loop; end Rehash_Subtable; ------------------ -- Is_Injective -- ------------------ function Is_Injective (ST_Index : Natural; T : Hash_Table) return Boolean is Elements : access Dynamic_Element_Array.Table_Type renames T.Elements.Table; Subtables : access Dynamic_Subtable_Array.Table_Type renames T.Subtables.Table; begin for J in Subtables (ST_Index).First .. Subtables (ST_Index).Last - 1 loop for K in J + 1 .. Subtables (ST_Index).Last loop if Elements (J).Used and then Elements (K).Used and then Elements (J).ST_Offset = Elements (K).ST_Offset then return False; end if; end loop; end loop; return True; end Is_Injective; ---------------------------- -- Find_Hash_For_Subtable -- ---------------------------- procedure Find_Hash_For_Subtable (ST_Index : Natural; T : Hash_Table) is Subtables : access Dynamic_Subtable_Array.Table_Type renames T.Subtables.Table; begin Subtables (ST_Index).HParam := Default_Hash_Parameters; loop Rehash_Subtable (ST_Index, T); exit when Is_Injective (ST_Index, T); Subtables (ST_Index).HParam := Next_Hash_Parameters (Subtables (ST_Index).HParam); end loop; pragma Assert (Is_Injective (ST_Index, T)); end Find_Hash_For_Subtable; ------------------------- -- Add_Key_To_Subtable -- ------------------------- procedure Add_Key_To_Subtable (Key : String; ST_Index : Natural; T : in out Hash_Table) is Elements : access Dynamic_Element_Array.Table_Type renames T.Elements.Table; Subtables : access Dynamic_Subtable_Array.Table_Type renames T.Subtables.Table; Key_Inserted : Boolean := False; begin for J in Subtables (ST_Index).First .. Subtables (ST_Index).Last loop if Elements (J).Key = null then Elements (J).Key := new String'(Key); Elements (J).Used := True; Key_Inserted := True; exit; elsif not Elements (J).Used then Free (Elements (J).Key); Elements (J).Key := new String'(Key); Elements (J).Used := True; Key_Inserted := True; exit; end if; end loop; pragma Assert (Key_Inserted); end Add_Key_To_Subtable; ---------------- -- Rehash_All -- ---------------- procedure Rehash_All (Key : String; T : in out Hash_Table) is Elements : access Dynamic_Element_Array.Table_Type renames T.Elements.Table; Subtables : access Dynamic_Subtable_Array.Table_Type renames T.Subtables.Table; Max_Sum : Natural := 0; ST_Index : Natural := 0; ST_Offset : Natural := 0; E_Index : Natural := 0; Index : Natural; Offset : Natural := 0; Swap_Index1 : Natural := 0; Swap_Index2 : Natural := Last (T.Elements); begin -- Add the new element at the end of the table of elements -- and deallocate unused element if necessary if Elements (Last (T.Elements)).Key /= null then Free (T.Elements.Table.all (Last (T.Elements)).Key); end if; Elements (Last (T.Elements)).Key := new String'(Key); Elements (Last (T.Elements)).Used := True; -- Put all the elements at the beginning of the table -- XXX why are we doing a swap and not a simple affectation ???? while Swap_Index1 < Swap_Index2 loop if not Elements (Swap_Index1).Used then while not Elements (Swap_Index2).Used and then Swap_Index1 + 1 < Swap_Index2 loop Swap_Index2 := Swap_Index2 - 1; end loop; if Elements (Swap_Index2).Used and then Swap_Index1 < Swap_Index2 then Swap_Elements (T, Swap_Index1, Swap_Index2); end if; end if; Swap_Index1 := Swap_Index1 + 1; end loop; -- Find a hash function for the table T.Info.HParam := Default_Hash_Parameters; loop -- Reinitialize the subtables paramters for J in First (T.Subtables) .. Last (T.Subtables) loop Subtables (J).Count := 0; Subtables (J).HParam := Default_Hash_Parameters; end loop; -- Find the repartition of the elements among the subtables for J in 0 .. T.Info.Count - 1 loop Elements (J).ST_Index := Hash (Elements (J).Key.all, T.Info.HParam, T.Info.N_Subtables); Subtables (Elements (J).ST_Index).Count := Subtables (Elements (J).ST_Index).Count + 1; end loop; -- Compute High and Max parameters for each subtables, -- compute Max_Sum, which serves as a break condition. Max_Sum := 0; for J in First (T.Subtables) .. Last (T.Subtables) loop if Subtables (J).Count = 0 then Subtables (J).High := 1; Subtables (J).Max := 2; else Subtables (J).High := 2 * Subtables (J).Count; Subtables (J).Max := 2 * Subtables (J).High * (Subtables (J).High - 1); end if; Max_Sum := Max_Sum + Subtables (J).Max; end loop; -- Dietzfelbinger algorithm searches a hash function so that -- Max_Sum <= 32 * T.Info.High ^2 / s (T.Info.High) + 4 * T.Info.High -- (inequality #7 p. 5), with s (T.Info.High) the number of subsets -- to be created to accomodate for T.Info.High elements. -- Choosing s : x -> 3 * x is sufficient to ensure linear -- memory usage, thus the following inequality : exit when Max_Sum <= 44 * T.Info.High / 3; T.Info.HParam := Next_Hash_Parameters (T.Info.HParam); end loop; -- Compute boundaries of the different subtables. Index := 0; for J in First (T.Subtables) .. Last (T.Subtables) loop Subtables (J).First := Index; Index := Index + Subtables (J).Max; Subtables (J).Last := Index - 1; end loop; -- Reorder the elements for J in 0 .. T.Info.Count - 1 loop ST_Index := Elements (J).ST_Index; ST_Offset := Hash (Elements (J).Key.all, Subtables (ST_Index).HParam, Subtables (ST_Index).Max); Elements (J).ST_Offset := ST_Offset; E_Index := ST_Offset + Subtables (ST_Index).First; if (J /= E_Index and then Subtables (ST_Index).Count = 1) or else J < Subtables (ST_Index).First or else J > Subtables (ST_Index).Last then while ((J /= E_Index and then Subtables (ST_Index).Count = 1) or else J < Subtables (ST_Index).First or else J > Subtables (ST_Index).Last) and then Elements (J).Used loop if Subtables (ST_Index).Count = 1 then Swap_Elements (T, J, E_Index); ST_Index := Elements (J).ST_Index; if Elements (J).Used then ST_Offset := Hash (Elements (J).Key.all, Subtables (ST_Index).HParam, Subtables (ST_Index).Max); end if; Elements (J).ST_Offset := ST_Offset; E_Index := ST_Offset + Subtables (ST_Index).First; else Offset := Subtables (ST_Index).First; while Elements (Offset).Used and then ST_Index = Elements (Offset).ST_Index loop Offset := Offset + 1; end loop; Swap_Elements (T, J, Offset); ST_Index := Elements (J).ST_Index; if Elements (J).Used then ST_Offset := Hash (Elements (J).Key.all, Subtables (ST_Index).HParam, Subtables (ST_Index).Max); end if; Elements (J).ST_Offset := ST_Offset; E_Index := ST_Offset + Subtables (ST_Index).First; end if; end loop; end if; end loop; -- Apply the Process_Subtable procedure to all the subtables -- that have more than two elements. Otherwise we can directly -- use the default parameters. for J in First (T.Subtables) .. Last (T.Subtables) loop if Subtables (J).Count > 1 then Process_Subtable (J, T); elsif Subtables (J).Count = 0 then Subtables (J).HParam := Default_Hash_Parameters; end if; end loop; end Rehash_All; ---------------------- -- Process_Subtable -- ---------------------- procedure Process_Subtable (ST_Index : Natural; T : in out Hash_Table) is Elements : access Dynamic_Element_Array.Table_Type renames T.Elements.Table; Subtables : access Dynamic_Subtable_Array.Table_Type renames T.Subtables.Table; Offset : Natural; begin -- Find Hash parameter for this subtable. Find_Hash_For_Subtable (ST_Index, T); -- Reorder subtable. for J in Subtables (ST_Index).First .. Subtables (ST_Index).Last loop Offset := Subtables (ST_Index).First + Elements (J).ST_Offset; while Elements (J).Used and then J /= Offset loop if J /= Offset then Swap_Elements (T, J, Offset); end if; Offset := Subtables (ST_Index).First + Elements (J).ST_Offset; end loop; end loop; end Process_Subtable; ---------------------------------- -- Hash_Table related functions -- ---------------------------------- ---------------- -- Initialize -- ---------------- procedure Initialize (T : out Hash_Table; HParam : Hash_Parameters := Default_Hash_Parameters; Max : Natural) is Elements : access Dynamic_Element_Array.Table_Type renames T.Elements.Table; Subtables : access Dynamic_Subtable_Array.Table_Type renames T.Subtables.Table; begin -- Initialization of T.Info T.Info.Count := 0; T.Info.High := Max + (Max + 9) / 10; T.Info.N_Subtables := T.Info.High * 3; T.Info.HParam := HParam; -- Allocation of T.Elements Initialize (T.Elements); Dynamic_Element_Array.Set_Last (T.Elements, 15 * T.Info.High); for J in First (T.Elements) .. Last (T.Elements) loop Elements (J) := Empty; Elements (J).Item_Index := J; end loop; -- Allocation of T.Subtables Initialize (T.Subtables); Set_Last (T.Subtables, T.Info.N_Subtables - 1); for J in First (T.Subtables) .. Last (T.Subtables) loop Subtables (J).First := 2 * J; Subtables (J).Last := 2 * J + 1; Subtables (J).Count := 0; Subtables (J).High := 1; Subtables (J).Max := 2; Subtables (J).HParam := HParam; end loop; end Initialize; -------------- -- Finalize -- -------------- procedure Finalize (T : in out Hash_Table) is Elements : access Dynamic_Element_Array.Table_Type renames T.Elements.Table; begin for J in First (T.Elements) .. Last (T.Elements) loop if Elements (J).Key /= null then Free (Elements (J).Key); end if; end loop; Deallocate (T.Subtables); Deallocate (T.Elements); end Finalize; ------------ -- Insert -- ------------ procedure Insert (T : in out Hash_Table; Key : String; ST_Index : out Natural; ST_Offset : out Natural; To_Do : out Next_Action) is Elements : access Dynamic_Element_Array.Table_Type renames T.Elements.Table; Subtables : access Dynamic_Subtable_Array.Table_Type renames T.Subtables.Table; Found : Boolean; Temp_Index : Natural; Old_Last : Natural; begin if T.Info.Count = T.Info.High then -- Extend the table and Rehash_All, Old_Last := Last (T.Elements); T.Info.Count := T.Info.Count + 1; T.Info.High := T.Info.Count + (T.Info.Count + 1) / 2; T.Info.N_Subtables := T.Info.High * 3; Set_Last (T.Elements, 15 * T.Info.High); for J in Old_Last + 1 .. Last (T.Elements) loop Elements (J) := Empty; Elements (J).Item_Index := J; end loop; Set_Last (T.Subtables, T.Info.N_Subtables - 1); Rehash_All (Key, T); Lookup (T, Key, ST_Index, ST_Offset, Found); pragma Assert (Found); To_Do := Reorder_Table; else -- .. else search if the key is already in the table. Lookup (T, Key, ST_Index, ST_Offset, Found); if Found then -- If key in table and is used, don't insert To_Do := Do_Nothing; else -- Temp_Index will be the position of the new key, -- unless we need to reorganize the tables Temp_Index := Subtables (ST_Index).First + ST_Offset; T.Info.Count := T.Info.Count + 1; Subtables (ST_Index).Count := Subtables (ST_Index).Count + 1; if Subtables (ST_Index).Count > Subtables (ST_Index).High then -- If Count > High, Rehash_all Rehash_All (Key, T); Lookup (T, Key, ST_Index, ST_Offset, Found); pragma Assert (Found); To_Do := Reorder_Table; elsif Elements (Temp_Index).Key = null then -- If the positon is empty insert directly Elements (Temp_Index).Key := new String'(Key); Elements (Temp_Index).Used := True; Elements (Temp_Index).ST_Index := ST_Index; Elements (Temp_Index).ST_Offset := ST_Offset; To_Do := Insert_Item; elsif Elements (Temp_Index).Key.all = Key and then not Elements (Temp_Index).Used then -- If the position contains the same key but unused -- just change the flag Used. Elements (Temp_Index).Used := True; To_Do := Insert_Item; elsif not Elements (Temp_Index).Used then -- If the position contains a key that is unused, -- deallocate the string and then insert the new key Free (Elements (Temp_Index).Key); Elements (Temp_Index).Key := new String'(Key); Elements (Temp_Index).Used := True; Elements (Temp_Index).ST_Index := ST_Index; Elements (Temp_Index).ST_Offset := ST_Offset; To_Do := Insert_Item; else -- Worst case -> reorganize the subtable Add_Key_To_Subtable (Key, ST_Index, T); Process_Subtable (ST_Index, T); Lookup (T, Key, ST_Index, ST_Offset, Found); pragma Assert (Found); To_Do := Reorder_SubTable; end if; end if; end if; end Insert; procedure Insert (T : in out Hash_Table; Key : String; Index : out Natural; To_Do : out Next_Action) is Elements : access Dynamic_Element_Array.Table_Type renames T.Elements.Table; Subtables : access Dynamic_Subtable_Array.Table_Type renames T.Subtables.Table; ST_Index : Natural; ST_Offset : Natural; begin Insert (T, Key, ST_Index, ST_Offset, To_Do); Index := Elements (Subtables (ST_Index).First + ST_Offset).Item_Index; end Insert; ------------ -- Lookup -- ------------ procedure Lookup (T : Hash_Table; Key : String; ST_Index : out Natural; ST_Offset : out Natural; Found : out Boolean) is Elements : access Dynamic_Element_Array.Table_Type renames T.Elements.Table; Subtables : access Dynamic_Subtable_Array.Table_Type renames T.Subtables.Table; Index : Natural; begin ST_Index := Hash (Key, T.Info.HParam, T.Info.N_Subtables); ST_Offset := Hash (Key, Subtables (ST_Index).HParam, Subtables (ST_Index).Max); Index := Subtables (ST_Index).First + ST_Offset; Found := Elements (Index).Key /= null and then Elements (Index).Key.all = Key and then Elements (Index).Used; end Lookup; procedure Lookup (T : Hash_Table; Key : String; Index : out Natural; Found : out Boolean) is Elements : access Dynamic_Element_Array.Table_Type renames T.Elements.Table; Subtables : access Dynamic_Subtable_Array.Table_Type renames T.Subtables.Table; ST_Index : Natural; ST_Offset : Natural; begin Lookup (T, Key, ST_Index, ST_Offset, Found); if Found then Index := Elements (Subtables (ST_Index).First + ST_Offset).Item_Index; end if; end Lookup; ------------ -- Delete -- ------------ procedure Delete (T : in out Hash_Table; Key : String; Index : out Natural) is Elements : access Dynamic_Element_Array.Table_Type renames T.Elements.Table; Subtables : access Dynamic_Subtable_Array.Table_Type renames T.Subtables.Table; ST_Index : Natural; ST_Offset : Natural; Found : Boolean; begin Lookup (T, Key, ST_Index, ST_Offset, Found); if Found then T.Info.Count := T.Info.Count - 1; Subtables (ST_Index).Count := Subtables (ST_Index).Count - 1; Elements (Subtables (ST_Index).First + ST_Offset).Used := False; Index := Elements (Subtables (ST_Index).First + ST_Offset).Item_Index; else Index := 0; end if; end Delete; -- Implementation of the public specification begins here. ---------------- -- Initialize -- ---------------- procedure Initialize (T : out Table_Instance; HParam : Hash_Parameters := Default_Hash_Parameters; Max : Natural := Default_Max) is begin T.T := new Table; Initialize (T.T.HTable, HParam, Max); Initialize (T.T.Items); Set_Last (T.T.Items, 15 * T.T.HTable.Info.High); end Initialize; -------------- -- Finalize -- -------------- procedure Finalize (T : in out Table_Instance) is begin Finalize (T.T.HTable); Deallocate (T.T.Items); Free_Table (T.T); end Finalize; ------------ -- Insert -- ------------ procedure Insert (T : Table_Instance; Key : String; Value : Item) is Items : access Dynamic_Item_Array.Table_Type renames T.T.Items.Table; To_Do : Next_Action; Index : Natural; Old_Last : Natural; begin Insert (T.T.HTable, Key, Index, To_Do); -- First check if 'Elements' table must be extended. if To_Do = Reorder_Table and then Last (T.T.HTable.Elements) > Last (T.T.Items) then Old_Last := Last (T.T.Items); Set_Last (T.T.Items, 15 * T.T.HTable.Info.High); for J in Old_Last + 1 .. Last (T.T.Items) loop Items (J) := null; end loop; end if; -- Then insert the element. if To_Do /= Do_Nothing then pragma Assert (Items (Index) = null); Items (Index) := new Item'(Value); end if; end Insert; ------------ -- Lookup -- ------------ function Lookup (T : Table_Instance; Key : String; Error_Value : Item) return Item is Items : access Dynamic_Item_Array.Table_Type renames T.T.Items.Table; Index : Natural; Found : Boolean; begin Lookup (T.T.HTable, Key, Index, Found); if Found then return Items (Index).all; else return Error_Value; end if; end Lookup; ------------ -- Delete -- ------------ procedure Delete (T : Table_Instance; Key : String) is Index : Natural; begin Delete (T.T.HTable, Key, Index); if Index /= 0 then Free_Item (T.T.Items.Table (Index)); end if; end Delete; -------------- -- Is_Empty -- -------------- function Is_Empty (T : Table_Instance) return Boolean is begin return T.T.HTable.Info.Count = 0; end Is_Empty; ----------- -- First -- ----------- function First (T : Table_Instance) return Iterator is Elements : Element_Array renames T.T.HTable.Elements; begin for J in First (Elements) .. Last (Elements) loop if Elements.Table (J).Used then return Iterator'(On_Table => T, Position => J); end if; end loop; return Iterator'(On_Table => T, Position => Last (Elements) + 1); end First; ----------- -- Value -- ----------- function Value (I : Iterator) return Item is Elements : access Dynamic_Element_Array.Table_Type renames I.On_Table.T.HTable.Elements.Table; Items : access Dynamic_Item_Array.Table_Type renames I.On_Table.T.Items.Table; begin return Items (Elements (I.Position).Item_Index).all; end Value; --------- -- Key -- --------- function Key (I : Iterator) return String is Elements : access Dynamic_Element_Array.Table_Type renames I.On_Table.T.HTable.Elements.Table; begin return Elements (I.Position).Key.all; end Key; ---------- -- Last -- ---------- function Last (I : Iterator) return Boolean is Elements : Element_Array renames I.On_Table.T.HTable.Elements; begin for J in I.Position .. Last (Elements) loop if Elements.Table (J).Used then return False; end if; end loop; return True; end Last; ---------- -- Next -- ---------- procedure Next (I : in out Iterator) is Elements : Element_Array renames I.On_Table.T.HTable.Elements; begin for J in I.Position + 1 .. Last (Elements) loop if Elements.Table (J).Used then I.Position := J; return; end if; end loop; I.Position := Last (Elements) + 1; end Next; end PolyORB.Utils.HTables.Perfect; polyorb-2.8~20110207.orig/src/polyorb-transport-datagram-sockets.adb0000644000175000017500000002127611750740340024620 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . T R A N S P O R T . D A T A G R A M . S O C K E T S -- -- -- -- B o d y -- -- -- -- Copyright (C) 2003-2011, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- Datagram Socket Access Point and End Point to receive data from network with Ada.Exceptions; with System.Storage_Elements; with PolyORB.Asynch_Ev.Sockets; with PolyORB.Log; package body PolyORB.Transport.Datagram.Sockets is use Ada.Streams; use PolyORB.Asynch_Ev.Sockets; use PolyORB.Log; use PolyORB.Utils.Sockets; package L is new PolyORB.Log.Facility_Log ("polyorb.transport.datagram.sockets"); procedure O (Message : String; Level : Log_Level := Debug) renames L.Output; function C (Level : Log_Level := Debug) return Boolean renames L.Enabled; ----------------- -- Init_Socket -- ----------------- procedure Init_Socket (SAP : in out Socket_Access_Point; Socket : Socket_Type; Address : in out Sock_Addr_Type; Bind_Address : Sock_Addr_Type := No_Sock_Addr; Update_Addr : Boolean := True) is begin if Bind_Address /= No_Sock_Addr then Bind_Socket (Socket, Bind_Address); else Bind_Socket (Socket, Address); end if; SAP.Socket := Socket; if Update_Addr then SAP.Addr := Get_Socket_Name (Socket); if SAP.Addr.Addr = Any_Inet_Addr then -- ??? Should keep Host_Name unresolved here, see comments in -- PolyORB.Transport.Connected.Sockets.Create. SAP.Addr.Addr := Local_Inet_Address; end if; Address := SAP.Addr; else SAP.Addr := Address; end if; end Init_Socket; ------------------------- -- Create_Event_Source -- ------------------------- function Create_Event_Source (TAP : access Socket_Access_Point) return Asynch_Ev_Source_Access is Ev_Src : constant Asynch_Ev_Source_Access := Create_Event_Source (TAP.Socket); begin Set_Handler (Ev_Src.all, TAP.Handler'Access); return Ev_Src; end Create_Event_Source; ---------------- -- Address_Of -- ---------------- function Address_Of (SAP : Socket_Access_Point) return Utils.Sockets.Socket_Name is begin return Image (SAP.Addr.Addr) + SAP.Addr.Port; end Address_Of; ------------ -- Create -- ------------ procedure Create (TE : in out Socket_Endpoint; S : Socket_Type; Addr : Sock_Addr_Type) is begin TE.Socket := S; TE.Remote_Address := Addr; end Create; ------------------------- -- Create_Event_Source -- ------------------------- function Create_Event_Source (TE : access Socket_Endpoint) return Asynch_Ev_Source_Access is Ev_Src : constant Asynch_Ev_Source_Access := Create_Event_Source (TE.Socket); begin Set_Handler (Ev_Src.all, TE.Handler'Access); return Ev_Src; end Create_Event_Source; ---------- -- Read -- ---------- procedure Read (TE : in out Socket_Endpoint; Buffer : Buffers.Buffer_Access; Size : in out Stream_Element_Count; Error : out Errors.Error_Container) is use PolyORB.Buffers; use PolyORB.Errors; Request : Request_Type (N_Bytes_To_Read); Data_Received : Ada.Streams.Stream_Element_Offset; procedure Lowlevel_Receive_Datagram (V : access Iovec); -- Receive datagram from TE into V ------------------------------- -- Lowlevel_Receive_Datagram -- ------------------------------- procedure Lowlevel_Receive_Datagram (V : access Iovec) is Count : Stream_Element_Count; Item : Stream_Element_Array (1 .. Stream_Element_Offset (V.Iov_Len)); for Item'Address use V.Iov_Base; pragma Import (Ada, Item); begin Receive_Socket (TE.Socket, Item, Count, TE.Remote_Address, No_Request_Flag); V.Iov_Len := System.Storage_Elements.Storage_Offset (Count); end Lowlevel_Receive_Datagram; procedure Receive_Datagram is new Buffers.Receive_Buffer (Lowlevel_Receive_Datagram); -- Start of processing for Read begin begin Control_Socket (TE.Socket, Request); Size := Stream_Element_Offset (Request.Size); Receive_Datagram (Buffer, Size, Data_Received); exception when E : Socket_Error => O ("receive failed: " & Ada.Exceptions.Exception_Message (E), Notice); Throw (Error, Comm_Failure_E, System_Exception_Members' (Minor => 0, Completed => Completed_Maybe)); when others => Throw (Error, Unknown_E, System_Exception_Members' (Minor => 0, Completed => Completed_Maybe)); end; Size := Data_Received; end Read; ----------- -- Write -- ----------- procedure Write (TE : in out Socket_Endpoint; Buffer : Buffers.Buffer_Access; Error : out Errors.Error_Container) is use PolyORB.Buffers; use PolyORB.Errors; Data : constant Stream_Element_Array := To_Stream_Element_Array (Buffer.all); Last : Stream_Element_Offset; begin pragma Debug (C, O ("Write: enter")); pragma Debug (C, O ("Send to : " & Image (TE.Remote_Address))); pragma Debug (C, O ("Buffer Size : " & Data'Length'Img)); begin PolyORB.Sockets.Send_Socket (TE.Socket, Data, Last, TE.Remote_Address); exception when E : Socket_Error => O ("send failed: " & Ada.Exceptions.Exception_Information (E), Notice); Throw (Error, Comm_Failure_E, System_Exception_Members' (Minor => 0, Completed => Completed_Maybe)); when others => Throw (Error, Unknown_E, System_Exception_Members' (Minor => 0, Completed => Completed_Maybe)); end; pragma Debug (C, O ("Write: leave")); end Write; ----------- -- Close -- ----------- procedure Close (TE : access Socket_Endpoint) is begin pragma Debug (C, O ("Closing UDP socket")); if TE.Closed then return; end if; PolyORB.Transport.Datagram.Close (Datagram_Transport_Endpoint (TE.all)'Access); TE.Socket := No_Socket; end Close; --------------------- -- Create_Endpoint -- --------------------- function Create_Endpoint (TAP : access Socket_Access_Point) return Datagram_Transport_Endpoint_Access is TE : constant Datagram_Transport_Endpoint_Access := new Socket_Endpoint; begin pragma Debug (C, O ("Create Endpoint for UDP socket")); Socket_Endpoint (TE.all).Socket := TAP.Socket; return TE; end Create_Endpoint; end PolyORB.Transport.Datagram.Sockets; polyorb-2.8~20110207.orig/src/polyorb-poa_config-root_poa.ads0000644000175000017500000000477011750740340023302 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . P O A _ C O N F I G . R O O T _ P O A -- -- -- -- S p e c -- -- -- -- Copyright (C) 2003 Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by ACT Europe. -- -- (email: sales@act-europe.fr) -- -- -- ------------------------------------------------------------------------------ -- A POA configuration corresponding to CORBA RootPOA policies. package PolyORB.POA_Config.Root_POA is pragma Elaborate_Body; type Root_POA_Configuration is new Configuration_Type with private; procedure Initialize (C : Root_POA_Configuration); function Default_Policies (C : Root_POA_Configuration) return PolyORB.POA_Policies.PolicyList; private type Root_POA_Configuration is new Configuration_Type with null record; end PolyORB.POA_Config.Root_POA; polyorb-2.8~20110207.orig/src/security/0000755000175000017500000000000011750740340017040 5ustar xavierxavierpolyorb-2.8~20110207.orig/src/security/polyorb-security-authentication_mechanisms.ads0000644000175000017500000001443311750740340030315 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- POLYORB.SECURITY.AUTHENTICATION_MECHANISMS -- -- -- -- S p e c -- -- -- -- Copyright (C) 2005-2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with Ada.Streams; with PolyORB.ASN1; with PolyORB.Security.Credentials; with PolyORB.Security.Identities; with PolyORB.Security.Exported_Names; with PolyORB.Security.Types; package PolyORB.Security.Authentication_Mechanisms is type Client_Authentication_Mechanism is abstract tagged private; type Client_Authentication_Mechanism_Access is access all Client_Authentication_Mechanism'Class; function Is_Supports (Mechanism : access Client_Authentication_Mechanism; Credentials : PolyORB.Security.Credentials.Credentials_Ref) return Boolean is abstract; -- Return True iff Credentials supports the Mechanism function Init_Security_Context (Mechanism : access Client_Authentication_Mechanism; Credentials : PolyORB.Security.Credentials.Credentials_Ref) return Ada.Streams.Stream_Element_Array is abstract; -- Return authentication token procedure Release_Contents (Mechanism : access Client_Authentication_Mechanism); -- Release used resources type Target_Authentication_Mechanism is abstract tagged private; type Target_Authentication_Mechanism_Access is access all Target_Authentication_Mechanism'Class; function Get_Mechanism_OID (Mechanism : access Target_Authentication_Mechanism) return PolyORB.ASN1.Object_Identifier; -- Return authentication mechanism object identifier function Get_Target_Name (Mechanism : access Target_Authentication_Mechanism) return PolyORB.Security.Exported_Names.Exported_Name_Access; -- Return Target Name function Get_Supported_Identity_Types (Mechanism : access Target_Authentication_Mechanism) return PolyORB.Security.Types.Identity_Token_Type; -- Return set of supported identity types function Get_Supported_Naming_Mechanisms (Mechanism : access Target_Authentication_Mechanism) return PolyORB.Security.Types.OID_Lists.List; -- Return list of supported naming mechanisms. If authentication mechanism -- not support principal name identity type then returned list is always -- empty. procedure Accept_Security_Context (Mechanism : access Target_Authentication_Mechanism; Token : PolyORB.Security.Types.Stream_Element_Array_Access; Success : out Boolean; Return_Token : out PolyORB.Security.Types.Stream_Element_Array_Access; Identity : out PolyORB.Security.Identities.Identity_Access) is abstract; -- Accept security context (do authentication) procedure Release_Contents (Mechanism : access Target_Authentication_Mechanism); -- Release used resources procedure Destroy (Mechanism : in out Client_Authentication_Mechanism_Access); procedure Destroy (Mechanism : in out Target_Authentication_Mechanism_Access); function Create_Client_Mechanism (Mechanism_OID : PolyORB.ASN1.Object_Identifier; Target_Name : PolyORB.Security.Exported_Names.Exported_Name_Access) return Client_Authentication_Mechanism_Access; function Create_Target_Mechanism (Section_Name : String) return Target_Authentication_Mechanism_Access; private type Client_Authentication_Mechanism is abstract tagged record Target_Name : PolyORB.Security.Exported_Names.Exported_Name_Access; end record; type Target_Authentication_Mechanism is abstract tagged record Mechanism_OID : PolyORB.ASN1.Object_Identifier; Target_Name : PolyORB.Security.Exported_Names.Exported_Name_Access; Identity_Types : PolyORB.Security.Types.Identity_Token_Type; Naming_Mechanisms : PolyORB.Security.Types.OID_Lists.List; end record; -- Registry for known Authentication Mechanisms type Client_Mechanism_Constructor is access function (Target_Name : PolyORB.Security.Exported_Names.Exported_Name_Access) return Client_Authentication_Mechanism_Access; procedure Register (Mechanism_OID : PolyORB.ASN1.Object_Identifier; Constructor : Client_Mechanism_Constructor); type Target_Mechanism_Constructor is access function (Section_Name : String) return Target_Authentication_Mechanism_Access; procedure Register (Mechanism_Name : String; Constructor : Target_Mechanism_Constructor); end PolyORB.Security.Authentication_Mechanisms; polyorb-2.8~20110207.orig/src/security/polyorb-security-identities-anonymous.adb0000644000175000017500000001245511750740340027237 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- POLYORB.SECURITY.IDENTITIES.ANONYMOUS -- -- -- -- B o d y -- -- -- -- Copyright (C) 2005-2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with PolyORB.Initialization; with PolyORB.Utils.Strings; package body PolyORB.Security.Identities.Anonymous is function Create_Empty_Anonymous_Identity return Identity_Access; procedure Initialize; ------------------------------- -- Create_Anonymous_Identity -- ------------------------------- function Create_Anonymous_Identity return Identity_Access is begin return new Anonymous_Identity_Type; end Create_Anonymous_Identity; ------------------------------------- -- Create_Empty_Anonymous_Identity -- ------------------------------------- function Create_Empty_Anonymous_Identity return Identity_Access is begin return new Anonymous_Identity_Type; end Create_Empty_Anonymous_Identity; ------------ -- Decode -- ------------ procedure Decode (Self : access Anonymous_Identity_Type; Item : Ada.Streams.Stream_Element_Array; Error : in out PolyORB.Errors.Error_Container) is pragma Unreferenced (Self); use PolyORB.Errors; begin if Item'Length /= 0 then Throw (Error, Marshal_E, System_Exception_Members'(Minor => 0, Completed => Completed_No)); end if; end Decode; --------------- -- Duplicate -- --------------- function Duplicate (Self : access Anonymous_Identity_Type) return Identity_Access is pragma Unreferenced (Self); begin return new Anonymous_Identity_Type; end Duplicate; ------------ -- Encode -- ------------ function Encode (Self : access Anonymous_Identity_Type) return Ada.Streams.Stream_Element_Array is pragma Unreferenced (Self); begin return Ada.Streams.Stream_Element_Array'(1 .. 0 => 0); end Encode; ------------------------ -- Get_Printable_Name -- ------------------------ function Get_Printable_Name (Self : access Anonymous_Identity_Type) return String is pragma Unreferenced (Self); begin return "ANONYMOUS"; end Get_Printable_Name; -------------------- -- Get_Token_Type -- -------------------- function Get_Token_Type (Self : access Anonymous_Identity_Type) return PolyORB.Security.Types.Identity_Token_Type is pragma Unreferenced (Self); begin return PolyORB.Security.Types.ITT_Anonymous; end Get_Token_Type; ---------------- -- Initialize -- ---------------- procedure Initialize is begin Register (PolyORB.Security.Types.ITT_Anonymous, Create_Empty_Anonymous_Identity'Access); end Initialize; ---------------------- -- Release_Contents -- ---------------------- procedure Release_Contents (Self : access Anonymous_Identity_Type) is pragma Unreferenced (Self); begin null; end Release_Contents; begin declare use PolyORB.Initialization; use PolyORB.Initialization.String_Lists; use PolyORB.Utils.Strings; begin Register_Module (Module_Info' (Name => +"polyorb.security.identities.anonymous", Conflicts => Empty, Depends => Empty, Provides => Empty, Implicit => False, Init => Initialize'Access, Shutdown => null)); end; end PolyORB.Security.Identities.Anonymous; polyorb-2.8~20110207.orig/src/security/polyorb-security-exported_names-unknown.ads0000644000175000017500000000621711750740340027602 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- POLYORB.SECURITY.EXPORTED_NAMES.UNKNOWN -- -- -- -- S p e c -- -- -- -- Copyright (C) 2005-2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with PolyORB.Security.Types; package PolyORB.Security.Exported_Names.Unknown is type Unknown_Exported_Name_Type is new Exported_Name_Type with private; private type Unknown_Exported_Name_Type is new Exported_Name_Type with record Name_BLOB : PolyORB.Security.Types.Stream_Element_Array_Access := null; end record; -- Derived from Exported_Name_Type function Is_Equivalent (Left : access Unknown_Exported_Name_Type; Right : access Exported_Name_Type'Class) return Boolean; function Get_Printable_Name (Item : access Unknown_Exported_Name_Type) return String; function Duplicate (Item : access Unknown_Exported_Name_Type) return Exported_Name_Access; procedure Release_Contents (Item : access Unknown_Exported_Name_Type); function Encode_Name_BLOB (Item : access Unknown_Exported_Name_Type) return Ada.Streams.Stream_Element_Array; procedure Decode_Name_BLOB (Item : access Unknown_Exported_Name_Type; BLOB : Ada.Streams.Stream_Element_Array; Error : in out PolyORB.Errors.Error_Container); end PolyORB.Security.Exported_Names.Unknown; polyorb-2.8~20110207.orig/src/security/polyorb-security-identities-principal_name.adb0000644000175000017500000001305011750740340030160 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- POLYORB.SECURITY.IDENTITIES.PRINCIPAL_NAME -- -- -- -- B o d y -- -- -- -- Copyright (C) 2005-2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with PolyORB.Initialization; with PolyORB.Utils.Strings; package body PolyORB.Security.Identities.Principal_Name is function Create_Empty_Principal_Name_Identity return Identity_Access; procedure Initialize; ------------------------------------------ -- Create_Empty_Principal_Name_Identity -- ------------------------------------------ function Create_Empty_Principal_Name_Identity return Identity_Access is begin return new Principal_Name_Identity_Type; end Create_Empty_Principal_Name_Identity; ------------------------------------ -- Create_Principal_Name_Identity -- ------------------------------------ function Create_Principal_Name_Identity (Principal_Name : PolyORB.Security.Exported_Names.Exported_Name_Access) return Identity_Access is begin return new Principal_Name_Identity_Type'(Principal_Name => Principal_Name); end Create_Principal_Name_Identity; ------------ -- Decode -- ------------ procedure Decode (Self : access Principal_Name_Identity_Type; Item : Ada.Streams.Stream_Element_Array; Error : in out PolyORB.Errors.Error_Container) is begin PolyORB.Security.Exported_Names.Decode (Item, Self.Principal_Name, Error); end Decode; --------------- -- Duplicate -- --------------- function Duplicate (Self : access Principal_Name_Identity_Type) return Identity_Access is begin return new Principal_Name_Identity_Type' (Principal_Name => PolyORB.Security.Exported_Names.Duplicate (Self.Principal_Name)); end Duplicate; ------------ -- Encode -- ------------ function Encode (Self : access Principal_Name_Identity_Type) return Ada.Streams.Stream_Element_Array is begin return PolyORB.Security.Exported_Names.Encode (Self.Principal_Name); end Encode; ------------------------ -- Get_Printable_Name -- ------------------------ function Get_Printable_Name (Self : access Principal_Name_Identity_Type) return String is begin return PolyORB.Security.Exported_Names.Get_Printable_Name (Self.Principal_Name); end Get_Printable_Name; -------------------- -- Get_Token_Type -- -------------------- function Get_Token_Type (Self : access Principal_Name_Identity_Type) return PolyORB.Security.Types.Identity_Token_Type is pragma Unreferenced (Self); begin return PolyORB.Security.Types.ITT_Principal_Name; end Get_Token_Type; ---------------- -- Initialize -- ---------------- procedure Initialize is begin Register (PolyORB.Security.Types.ITT_Principal_Name, Create_Empty_Principal_Name_Identity'Access); end Initialize; ---------------------- -- Release_Contents -- ---------------------- procedure Release_Contents (Self : access Principal_Name_Identity_Type) is begin PolyORB.Security.Exported_Names.Destroy (Self.Principal_Name); end Release_Contents; begin declare use PolyORB.Initialization; use PolyORB.Initialization.String_Lists; use PolyORB.Utils.Strings; begin Register_Module (Module_Info' (Name => +"polyorb.security.identities.principal_name", Conflicts => Empty, Depends => Empty, Provides => Empty, Implicit => False, Init => Initialize'Access, Shutdown => null)); end; end PolyORB.Security.Identities.Principal_Name; polyorb-2.8~20110207.orig/src/security/polyorb-security-transport_mechanisms-unprotected.ads0000644000175000017500000000526211750740340031664 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- POLYORB.SECURITY.TRANSPORT_MECHANISMS.UNPROTECTED -- -- -- -- S p e c -- -- -- -- Copyright (C) 2005-2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ package PolyORB.Security.Transport_Mechanisms.Unprotected is type Unprotected_Transport_Mechanism is new Client_Transport_Mechanism with null record; function Target_Supports (Mechanism : access Unprotected_Transport_Mechanism) return PolyORB.Security.Types.Association_Options; function Target_Requires (Mechanism : access Unprotected_Transport_Mechanism) return PolyORB.Security.Types.Association_Options; function Is_Supports (Mechanism : access Unprotected_Transport_Mechanism; Credentials : PolyORB.Security.Credentials.Credentials_Ref) return Boolean; end PolyORB.Security.Transport_Mechanisms.Unprotected; polyorb-2.8~20110207.orig/src/security/polyorb-security-authority_mechanisms.ads0000644000175000017500000001510511750740340027323 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- POLYORB.SECURITY.AUTHORITY_MECHANISMS -- -- -- -- S p e c -- -- -- -- Copyright (C) 2005-2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with Ada.Streams; with PolyORB.Security.Authorization_Elements; -- with PolyORB.Security.Credentials; with PolyORB.Security.Identities; with PolyORB.Types; with PolyORB.Utils.Chained_Lists; package PolyORB.Security.Authority_Mechanisms is type Service_Configuration_Syntax is new PolyORB.Types.Unsigned_Long; type Client_Authority_Mechanism is abstract tagged null record; type Client_Authority_Mechanism_Access is access all Client_Authority_Mechanism'Class; -- function Is_Same -- (Self : access Privilege_Authority_Type; -- Privilege_Authority : Privilege_Authority_Access) -- return Boolean -- is abstract; -- procedure Get_Authorization_Token -- (Self : access Privilege_Authority_Type; -- Invocation_Credentials : -- PolyORB.Security.Credentials.Credentials_Ref; -- Identity : -- PolyORB.Security.Identities.Identity_Access; -- Authorization_Token : -- Authorization_Elements.Authorization_Element_Lists.List; -- Privilege_Authority : Privilege_Authority_Access; -- Invocation_Identity : out -- PolyORB.Security.Identities.Identity_Access; -- Invocation_Authorization_Token : out -- Authorization_Elements.Authorization_Element_Lists.List; -- Success : out Boolean) -- is abstract; procedure Get_Authorization_Token (Self : access Client_Authority_Mechanism; -- Invocation_Credentials : -- PolyORB.Security.Credentials.Credentials_Ref; -- Identity : -- PolyORB.Security.Identities.Identity_Access; -- Authorization_Token : -- Authorization_Elements.Authorization_Element_Lists.List; -- Privilege_Authority : Privilege_Authority_Access; Invocation_Identity : out PolyORB.Security.Identities.Identity_Access; Invocation_Authorization_Token : out Authorization_Elements.Authorization_Element_Lists.List; Success : out Boolean) is abstract; procedure Release_Contents (Self : access Client_Authority_Mechanism) is abstract; -- Release used resources type Target_Authority_Mechanism is abstract tagged null record; type Target_Authority_Mechanism_Access is access all Target_Authority_Mechanism'Class; function Get_Service_Configuration_Syntax (Self : access Target_Authority_Mechanism) return Service_Configuration_Syntax is abstract; -- Return serivce configuration syntax function Verify (Self : access Target_Authority_Mechanism; Element : Authorization_Elements.Authorization_Element_Access) return Boolean is abstract; -- Check is autorization element signed by privilege authority function Encode (Self : access Target_Authority_Mechanism) return Ada.Streams.Stream_Element_Array is abstract; procedure Release_Contents (Self : access Target_Authority_Mechanism) is abstract; -- Release used resources procedure Destroy (Item : in out Client_Authority_Mechanism_Access); procedure Destroy (Item : in out Target_Authority_Mechanism_Access); function Create_Client_Authority_Mechanism (Syntax : Service_Configuration_Syntax; Name : Ada.Streams.Stream_Element_Array) return Client_Authority_Mechanism_Access; -- Create client side privilege authority function Create_Target_Authority_Mechanism (Section_Name : Standard.String) return Target_Authority_Mechanism_Access; -- Create target side privilege authority package Client_Authority_Mechanism_Lists is new PolyORB.Utils.Chained_Lists (Client_Authority_Mechanism_Access); package Target_Authority_Mechanism_Lists is new PolyORB.Utils.Chained_Lists (Target_Authority_Mechanism_Access); -- Client and target privilege authority mechanisms registry type Target_Constructor is access function (Section_Name : Standard.String) return Target_Authority_Mechanism_Access; procedure Register (Name : Standard.String; Constructor : Target_Constructor); type Client_Constructor is access function (Name : Ada.Streams.Stream_Element_Array) return Client_Authority_Mechanism_Access; procedure Register (Syntax : Service_Configuration_Syntax; Constructor : Client_Constructor); end PolyORB.Security.Authority_Mechanisms; polyorb-2.8~20110207.orig/src/security/polyorb-security-exported_names.ads0000644000175000017500000001064111750740340026101 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . S E C U R I T Y . E X P O R T E D _ N A M E S -- -- -- -- S p e c -- -- -- -- Copyright (C) 2005-2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- This package provide data type for representation of a -- GSS Mechanism-Independent Exported Name object as defined in -- [IETF RFC 2743], as well as encodeing/decoding subprograms with Ada.Streams; with PolyORB.ASN1; with PolyORB.Errors; package PolyORB.Security.Exported_Names is type Exported_Name_Type is abstract tagged private; type Exported_Name_Access is access all Exported_Name_Type'Class; function Is_Equivalent (Left : access Exported_Name_Type; Right : access Exported_Name_Type'Class) return Boolean is abstract; function Get_Mechanism_OID (Item : access Exported_Name_Type) return PolyORB.ASN1.Object_Identifier; function Get_Printable_Name (Item : access Exported_Name_Type) return String is abstract; function Duplicate (Item : access Exported_Name_Type) return Exported_Name_Access is abstract; -- Return copy of Exported Name procedure Release_Contents (Item : access Exported_Name_Type); procedure Destroy (Item : in out Exported_Name_Access); -- Release contents and destroy Exported Name function Encode_Name_BLOB (Item : access Exported_Name_Type) return Ada.Streams.Stream_Element_Array is abstract; -- Encode Name part of Exported Name. This is an internal subprogram. procedure Decode_Name_BLOB (Item : access Exported_Name_Type; BLOB : Ada.Streams.Stream_Element_Array; Error : in out PolyORB.Errors.Error_Container) is abstract; -- Decode Name part of Exported Name. This is an internal subprogram. function Encode (Item : access Exported_Name_Type'Class) return Ada.Streams.Stream_Element_Array; -- Encode an Exported Name procedure Decode (Item : Ada.Streams.Stream_Element_Array; Name : out Exported_Name_Access; Error : in out PolyORB.Errors.Error_Container); -- Decode an Exported Name private type Exported_Name_Type is abstract tagged record Mechanism_OID : PolyORB.ASN1.Object_Identifier; end record; -- Registry for known External Name types type Empty_Exported_Name_Factory is access function return Exported_Name_Access; -- Return empty Exported Name of corresponding derived type procedure Register (Mechanism_OID : PolyORB.ASN1.Object_Identifier; Factory : Empty_Exported_Name_Factory); end PolyORB.Security.Exported_Names; polyorb-2.8~20110207.orig/src/security/polyorb-security-types.adb0000644000175000017500000000476411750740340024220 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . S E C U R I T Y . T Y P E S -- -- -- -- B o d y -- -- -- -- Copyright (C) 2005-2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ package body PolyORB.Security.Types is use Ada.Streams; --------------- -- Duplicate -- --------------- function Duplicate (Item : OID_Lists.List) return OID_Lists.List is use OID_Lists; Result : List; Iter : Iterator := First (Item); begin while not Last (Iter) loop Append (Result, PolyORB.ASN1.Duplicate (Value (Iter).all)); Next (Iter); end loop; return Result; end Duplicate; end PolyORB.Security.Types; polyorb-2.8~20110207.orig/src/security/polyorb-security-authorization_elements.ads0000644000175000017500000000704611750740340027665 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- POLYORB.SECURITY.AUTHORIZATION_ELEMENTS -- -- -- -- S p e c -- -- -- -- Copyright (C) 2005-2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with Ada.Streams; with PolyORB.Security.Identities; with PolyORB.Types; with PolyORB.Utils.Chained_Lists; package PolyORB.Security.Authorization_Elements is type Element_Type is new PolyORB.Types.Unsigned_Long; type Authorization_Element_Type is abstract tagged null record; type Authorization_Element_Access is access all Authorization_Element_Type'Class; function Get_Authorization_Element_Type (Self : access Authorization_Element_Type) return Element_Type is abstract; function Is_Holder (Self : access Authorization_Element_Type; Identity : PolyORB.Security.Identities.Identity_Access) return Boolean is abstract; procedure Release_Contents (Self : access Authorization_Element_Type) is abstract; function Encode (Self : access Authorization_Element_Type) return Ada.Streams.Stream_Element_Array is abstract; package Authorization_Element_Lists is new PolyORB.Utils.Chained_Lists (Authorization_Element_Access); procedure Release_Contents (Item : in out Authorization_Element_Lists.List); function Create (The_Type : Element_Type; Contents : Ada.Streams.Stream_Element_Array) return Authorization_Element_Access; private type Element_Constructor is access function (Contents : Ada.Streams.Stream_Element_Array) return Authorization_Element_Access; procedure Register (The_Type : Element_Type; Constructor : Element_Constructor); end PolyORB.Security.Authorization_Elements; polyorb-2.8~20110207.orig/src/security/polyorb-security-authorization_elements-unknown.adb0000644000175000017500000000746311750740340031344 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- POLYORB.SECURITY.AUTHORIZATION_ELEMENTS.UNKNOWN -- -- -- -- B o d y -- -- -- -- Copyright (C) 2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with Ada.Unchecked_Deallocation; package body PolyORB.Security.Authorization_Elements.Unknown is ------------ -- Create -- ------------ function Create (The_Type : Element_Type; Contents : Ada.Streams.Stream_Element_Array) return Authorization_Element_Access is begin return new Unknown.Unknown_Authorization_Element_Type' (The_Type, new Ada.Streams.Stream_Element_Array'(Contents)); end Create; ------------ -- Encode -- ------------ function Encode (Self : access Unknown_Authorization_Element_Type) return Ada.Streams.Stream_Element_Array is begin return Self.The_Data.all; end Encode; ------------------------------------ -- Get_Authorization_Element_Type -- ------------------------------------ function Get_Authorization_Element_Type (Self : access Unknown_Authorization_Element_Type) return Element_Type is begin return Self.The_Type; end Get_Authorization_Element_Type; --------------- -- Is_Holder -- --------------- function Is_Holder (Self : access Unknown_Authorization_Element_Type; Identity : PolyORB.Security.Identities.Identity_Access) return Boolean is pragma Unreferenced (Self); pragma Unreferenced (Identity); begin return False; end Is_Holder; ---------------------- -- Release_Contents -- ---------------------- procedure Release_Contents (Self : access Unknown_Authorization_Element_Type) is procedure Free is new Ada.Unchecked_Deallocation (Ada.Streams.Stream_Element_Array, PolyORB.Security.Types.Stream_Element_Array_Access); begin Free (Self.The_Data); end Release_Contents; end PolyORB.Security.Authorization_Elements.Unknown; polyorb-2.8~20110207.orig/src/security/gssup/0000755000175000017500000000000011750740340020201 5ustar xavierxavierpolyorb-2.8~20110207.orig/src/security/gssup/polyorb-security-credentials-gssup.adb0000644000175000017500000001563111750740340027644 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . S E C U R I T Y . C R E D E N T I A L S . G S S U P -- -- -- -- B o d y -- -- -- -- Copyright (C) 2005-2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with PolyORB.Initialization; with PolyORB.Parameters; with PolyORB.Security.Exported_Names.GSSUP; with PolyORB.Utils.Strings; package body PolyORB.Security.Credentials.GSSUP is function Create_Credentials (Section_Name : String) return Credentials_Access; procedure Initialize; ------------------------ -- Create_Credentials -- ------------------------ function Create_Credentials (Section_Name : String) return Credentials_Access is use PolyORB.Parameters; User_Name : constant String := Get_Conf (Section_Name, "gssup.username", ""); Password : constant String := Get_Conf (Section_Name, "gssup.password", ""); Target_Name : constant String := Get_Conf (Section_Name, "gssup.target_name", ""); Result : constant GSSUP_Credentials_Access := new GSSUP_Credentials; begin Result.User_Name := PolyORB.Types.To_PolyORB_String (User_Name); Result.Password := PolyORB.Types.To_PolyORB_String (Password); Result.Target_Name := PolyORB.Security.Exported_Names.GSSUP.Create_GSSUP_Exported_Name (Target_Name); return Credentials_Access (Result); end Create_Credentials; -- ---------------------- -- -- Credentials_Type -- -- ---------------------- -- -- function Credentials_Type -- (Self : access GSSUP_Credentials) -- return Invocation_Credentials_Type -- is -- pragma Unreferenced (Self); -- -- begin -- return Own_Credentials; -- end Credentials_Type; -------------- -- Finalize -- -------------- procedure Finalize (Self : in out GSSUP_Credentials) is begin PolyORB.Security.Exported_Names.Destroy (Self.Target_Name); end Finalize; ------------------------------------ -- Get_Accepting_Options_Required -- ------------------------------------ function Get_Accepting_Options_Required (Self : access GSSUP_Credentials) return PolyORB.Security.Types.Association_Options is pragma Unreferenced (Self); begin return 0; end Get_Accepting_Options_Required; ------------------------------------- -- Get_Accepting_Options_Supported -- ------------------------------------- function Get_Accepting_Options_Supported (Self : access GSSUP_Credentials) return PolyORB.Security.Types.Association_Options is pragma Unreferenced (Self); begin return 0; end Get_Accepting_Options_Supported; ----------------- -- Get_Idenity -- ----------------- function Get_Identity (Self : access GSSUP_Credentials) return PolyORB.Security.Identities.Identity_Access is pragma Unreferenced (Self); begin return null; end Get_Identity; ------------------------------------- -- Get_Invocation_Options_Required -- ------------------------------------- function Get_Invocation_Options_Required (Self : access GSSUP_Credentials) return PolyORB.Security.Types.Association_Options is pragma Unreferenced (Self); begin return 0; end Get_Invocation_Options_Required; -------------------------------------- -- Get_Invocation_Options_Supported -- -------------------------------------- function Get_Invocation_Options_Supported (Self : access GSSUP_Credentials) return PolyORB.Security.Types.Association_Options is pragma Unreferenced (Self); begin return PolyORB.Security.Types.Establish_Trust_In_Client; end Get_Invocation_Options_Supported; ------------------ -- Get_Password -- ------------------ function Get_Password (Self : access GSSUP_Credentials) return UTF8_String is begin return PolyORB.Types.To_Standard_String (Self.Password); end Get_Password; --------------------- -- Get_Target_Name -- --------------------- function Get_Target_Name (Self : access GSSUP_Credentials) return PolyORB.Security.Exported_Names.Exported_Name_Access is begin return Self.Target_Name; end Get_Target_Name; ------------------- -- Get_User_Name -- ------------------- function Get_User_Name (Self : access GSSUP_Credentials) return UTF8_String is begin return PolyORB.Types.To_Standard_String (Self.User_Name); end Get_User_Name; ---------------- -- Initialize -- ---------------- procedure Initialize is begin Register ("gssup", Create_Credentials'Access); end Initialize; begin declare use PolyORB.Initialization; use PolyORB.Initialization.String_Lists; use PolyORB.Utils.Strings; begin Register_Module (Module_Info' (Name => +"polyorb.security.credentials.gssup", Conflicts => Empty, Depends => Empty, Provides => Empty, Implicit => False, Init => Initialize'Access, Shutdown => null)); end; end PolyORB.Security.Credentials.GSSUP; ././@LongLink0000000000000000000000000000015100000000000011562 Lustar rootrootpolyorb-2.8~20110207.orig/src/security/gssup/polyorb-security-authentication_mechanisms-gssup_target.adbpolyorb-2.8~20110207.orig/src/security/gssup/polyorb-security-authentication_mechanisms-gssup_target0000644000175000017500000002245411750740340033417 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- POLYORB.SECURITY.AUTHENTICATION_MECHANISMS.GSSUP_TARGET -- -- -- -- B o d y -- -- -- -- Copyright (C) 2005-2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with Ada.Strings.Fixed; with Ada.Text_IO; with PolyORB.Buffers; with PolyORB.Errors; with PolyORB.Initialization; with PolyORB.Parameters; with PolyORB.Representations.CDR.Common; with PolyORB.Security.Identities.Principal_Name; with PolyORB.Security.Exported_Names.GSSUP; with PolyORB.Utils.Strings; package body PolyORB.Security.Authentication_Mechanisms.GSSUP_Target is use Ada.Streams; use PolyORB.Buffers; use PolyORB.Representations.CDR.Common; use PolyORB.Security.Exported_Names; use PolyORB.Security.Exported_Names.GSSUP; procedure Initialize; function Create_Mechanism (Section_Name : String) return Target_Authentication_Mechanism_Access; type Error_Code is new PolyORB.Types.Unsigned_Long; GSS_UP_S_G_UNSPECIFIED : constant Error_Code := 1; GSS_UP_S_G_NOUSER : constant Error_Code := 2; GSS_UP_S_G_BAD_PASSWORD : constant Error_Code := 3; GSS_UP_S_G_BAD_TARGET : constant Error_Code := 4; Encoded_Mechanism_OID : PolyORB.Security.Types.Stream_Element_Array_Access; ----------------------------- -- Accept_Security_Context -- ----------------------------- procedure Accept_Security_Context (Mechanism : access GSSUP_Target_Authentication_Mechanism; Token : PolyORB.Security.Types.Stream_Element_Array_Access; Success : out Boolean; Return_Token : out PolyORB.Security.Types.Stream_Element_Array_Access; Identity : out PolyORB.Security.Identities.Identity_Access) is use PolyORB.Security.Types; use PolyORB.Types; procedure Create_Error_Token (Code : Error_Code); ------------------------ -- Create_Error_Token -- ------------------------ procedure Create_Error_Token (Code : Error_Code) is Buffer : Buffer_Access := new Buffer_Type; begin Start_Encapsulation (Buffer); Marshall (Buffer, Unsigned_Long (Code)); Return_Token := new Stream_Element_Array'(Encapsulate (Buffer)); Release (Buffer); end Create_Error_Token; User_Name : PolyORB.Types.String; Password : PolyORB.Types.String; Target_Name : Exported_Name_Access; Buffer : aliased Buffer_Type; First : Stream_Element_Offset; Last : Stream_Element_Offset; begin -- Extract mechanism OID if Token (Token'First + 1) < 128 then First := Token'First + 2; else raise Program_Error; end if; if Token (First + 1) < 128 then Last := First + Stream_Element_Offset (Token (First + 1)) + 2 - 1; else raise Program_Error; end if; -- Check is mechanism OID is valid if Token (First .. Last) /= Encoded_Mechanism_OID.all then Success := False; Create_Error_Token (GSS_UP_S_G_UNSPECIFIED); return; end if; -- Unmarshall Initial Token declare Data : aliased Encapsulation := Token (Last + 1 .. Token'Last); begin Decapsulate (Data'Access, Buffer'Access); User_Name := Unmarshall_Latin_1_String (Buffer'Access); Password := Unmarshall_Latin_1_String (Buffer'Access); declare use PolyORB.Errors; Encoded_Name : constant Stream_Element_Array := Unmarshall (Buffer'Access); Error : Error_Container; begin Decode (Encoded_Name, Target_Name, Error); if Found (Error) then raise Program_Error; end if; end; end; -- Check Target Name if not Is_Equivalent (Target_Name, Mechanism.Target_Name) then Success := False; Create_Error_Token (GSS_UP_S_G_BAD_TARGET); Release_Contents (Target_Name); return; end if; Release_Contents (Target_Name); -- Check password declare use Ada.Strings.Fixed; use Ada.Text_IO; use PolyORB.Security.Identities.Principal_Name; File : File_Type; Buffer : String (1 .. 1024); Last : Natural; Delimiter : Natural; begin Open (File, In_File, To_Standard_String (Mechanism.Passwd_File)); while not End_Of_File (File) loop Get_Line (File, Buffer, Last); Delimiter := Index (Buffer (1 .. Last), ":"); if Delimiter /= 0 then if Buffer (1 .. Delimiter - 1) = User_Name then if Buffer (Delimiter + 1 .. Last) = Password then Success := True; Close (File); Identity := Create_Principal_Name_Identity (Create_GSSUP_Exported_Name (To_Standard_String (User_Name))); return; else Success := False; Create_Error_Token (GSS_UP_S_G_BAD_PASSWORD); Close (File); return; end if; end if; end if; end loop; Close (File); end; Success := False; Create_Error_Token (GSS_UP_S_G_NOUSER); end Accept_Security_Context; ---------------------- -- Create_Mechanism -- ---------------------- function Create_Mechanism (Section_Name : String) return Target_Authentication_Mechanism_Access is use PolyORB.Parameters; use PolyORB.Types; Target_Name : constant String := Get_Conf (Section_Name, "gssup.target_name", ""); Passwd_File : constant String := Get_Conf (Section_Name, "gssup.passwd_file", ""); begin if Target_Name = "" or else Passwd_File = "" then raise Program_Error; end if; return new GSSUP_Target_Authentication_Mechanism' (Mechanism_OID => PolyORB.ASN1.To_Object_Identifier (PolyORB.Security.Types.GSSUPMechOID), Target_Name => Create_GSSUP_Exported_Name (Target_Name), Identity_Types => PolyORB.Security.Types.ITT_Principal_Name, Naming_Mechanisms => PolyORB.Security.Types.OID_Lists."+" (PolyORB.ASN1.To_Object_Identifier (PolyORB.Security.Types.GSSUPMechOID)), Passwd_File => To_PolyORB_String (Passwd_File)); end Create_Mechanism; ---------------- -- Initialize -- ---------------- procedure Initialize is begin Encoded_Mechanism_OID := new Ada.Streams.Stream_Element_Array' (PolyORB.ASN1.Encode (PolyORB.ASN1.To_Object_Identifier (PolyORB.Security.Types.GSSUPMechOID))); Register ("gssup", Create_Mechanism'Access); end Initialize; begin declare use PolyORB.Initialization; use PolyORB.Utils.Strings; begin Register_Module (Module_Info' (Name => +"polyorb.security.authentication_mechanisms.gssup_target", Conflicts => PolyORB.Initialization.String_Lists.Empty, Depends => PolyORB.Initialization.String_Lists.Empty, Provides => PolyORB.Initialization.String_Lists.Empty, Implicit => False, Init => Initialize'Access, Shutdown => null)); end; end PolyORB.Security.Authentication_Mechanisms.GSSUP_Target; ././@LongLink0000000000000000000000000000015100000000000011562 Lustar rootrootpolyorb-2.8~20110207.orig/src/security/gssup/polyorb-security-authentication_mechanisms-gssup_client.adspolyorb-2.8~20110207.orig/src/security/gssup/polyorb-security-authentication_mechanisms-gssup_client0000644000175000017500000000546311750740340033410 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- POLYORB.SECURITY.AUTHENTICATION_MECHANISMS.GSSUP_CLIENT -- -- -- -- S p e c -- -- -- -- Copyright (C) 2005-2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ package PolyORB.Security.Authentication_Mechanisms.GSSUP_Client is type GSSUP_Client_Authentication_Mechanism is new Client_Authentication_Mechanism with private; private type GSSUP_Client_Authentication_Mechanism is new Client_Authentication_Mechanism with null record; -- Derived from Client_Authentication_Mechanism function Is_Supports (Mechanism : access GSSUP_Client_Authentication_Mechanism; Credentials : PolyORB.Security.Credentials.Credentials_Ref) return Boolean; function Init_Security_Context (Mechanism : access GSSUP_Client_Authentication_Mechanism; Credentials : PolyORB.Security.Credentials.Credentials_Ref) return Ada.Streams.Stream_Element_Array; end PolyORB.Security.Authentication_Mechanisms.GSSUP_Client; ././@LongLink0000000000000000000000000000015100000000000011562 Lustar rootrootpolyorb-2.8~20110207.orig/src/security/gssup/polyorb-security-authentication_mechanisms-gssup_target.adspolyorb-2.8~20110207.orig/src/security/gssup/polyorb-security-authentication_mechanisms-gssup_target0000644000175000017500000000554411750740340033420 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- POLYORB.SECURITY.AUTHENTICATION_MECHANISMS.GSSUP_TARGET -- -- -- -- S p e c -- -- -- -- Copyright (C) 2005-2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with PolyORB.Types; package PolyORB.Security.Authentication_Mechanisms.GSSUP_Target is type GSSUP_Target_Authentication_Mechanism is new Target_Authentication_Mechanism with private; private type GSSUP_Target_Authentication_Mechanism is new Target_Authentication_Mechanism with record Passwd_File : PolyORB.Types.String; end record; -- Derived from Target_Authentication_Mechanism procedure Accept_Security_Context (Mechanism : access GSSUP_Target_Authentication_Mechanism; Token : PolyORB.Security.Types.Stream_Element_Array_Access; Success : out Boolean; Return_Token : out PolyORB.Security.Types.Stream_Element_Array_Access; Identity : out PolyORB.Security.Identities.Identity_Access); end PolyORB.Security.Authentication_Mechanisms.GSSUP_Target; polyorb-2.8~20110207.orig/src/security/gssup/polyorb-security-exported_names-gssup.adb0000644000175000017500000001567011750740340030367 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- POLYORB.SECURITY.EXPORTED_NAMES.GSSUP -- -- -- -- B o d y -- -- -- -- Copyright (C) 2005-2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with Ada.Unchecked_Conversion; with Ada.Unchecked_Deallocation; with PolyORB.Initialization; with PolyORB.Security.Types; with PolyORB.Utils.Strings; package body PolyORB.Security.Exported_Names.GSSUP is use Ada.Streams; function Create_Empty_Exported_Name return Exported_Name_Access; procedure Initialize; -------------------------------- -- Create_Empty_Exported_Name -- -------------------------------- function Create_Empty_Exported_Name return Exported_Name_Access is begin return new GSSUP_Exported_Name_Type; end Create_Empty_Exported_Name; -------------------------------- -- Create_GSSUP_Exported_Name -- -------------------------------- function Create_GSSUP_Exported_Name (Scoped_Name : String) return Exported_Name_Access is begin return new GSSUP_Exported_Name_Type' (Mechanism_OID => PolyORB.ASN1.To_Object_Identifier (PolyORB.Security.Types.GSSUPMechOID), Scoped_Name => new String'(Scoped_Name)); end Create_GSSUP_Exported_Name; ---------------------- -- Decode_Name_BLOB -- ---------------------- procedure Decode_Name_BLOB (Item : access GSSUP_Exported_Name_Type; BLOB : Ada.Streams.Stream_Element_Array; Error : in out PolyORB.Errors.Error_Container) is use PolyORB.Errors; function To_Character is new Ada.Unchecked_Conversion (Stream_Element, Character); begin if BLOB'Length = 0 then Throw (Error, Marshal_E, System_Exception_Members'(Minor => 0, Completed => Completed_No)); return; end if; Item.Scoped_Name := new String (Integer (BLOB'First) .. Integer (BLOB'Last)); for J in Item.Scoped_Name'Range loop Item.Scoped_Name (J) := To_Character (BLOB (Stream_Element_Offset (J))); end loop; end Decode_Name_BLOB; --------------- -- Duplicate -- --------------- function Duplicate (Item : access GSSUP_Exported_Name_Type) return Exported_Name_Access is begin return new GSSUP_Exported_Name_Type' (Mechanism_OID => PolyORB.ASN1.Duplicate (Item.Mechanism_OID), Scoped_Name => new String'(Item.Scoped_Name.all)); end Duplicate; ---------------------- -- Encode_Name_BLOB -- ---------------------- function Encode_Name_BLOB (Item : access GSSUP_Exported_Name_Type) return Ada.Streams.Stream_Element_Array is function To_Stream_Element is new Ada.Unchecked_Conversion (Character, Stream_Element); Result : Stream_Element_Array (Stream_Element_Offset (Item.Scoped_Name'First) .. Stream_Element_Offset (Item.Scoped_Name'Last)); begin for J in Item.Scoped_Name'Range loop Result (Stream_Element_Offset (J)) := To_Stream_Element (Item.Scoped_Name (J)); end loop; return Result; end Encode_Name_BLOB; ------------------------ -- Get_Printable_Name -- ------------------------ function Get_Printable_Name (Item : access GSSUP_Exported_Name_Type) return String is begin return "[GSSUP]" & Item.Scoped_Name.all; end Get_Printable_Name; -- -------------- -- -- Get_Name -- -- -------------- -- -- function Get_Name -- (Item : access GSSUP_Exported_Name_Type) -- return String -- is -- begin -- return Item.Name.all; -- end Get_Name; ---------------- -- Initialize -- ---------------- procedure Initialize is begin Register (PolyORB.ASN1.To_Object_Identifier (PolyORB.Security.Types.GSSUPMechOID), Create_Empty_Exported_Name'Access); end Initialize; ------------------- -- Is_Equivalent -- ------------------- function Is_Equivalent (Left : access GSSUP_Exported_Name_Type; Right : access Exported_Name_Type'Class) return Boolean is begin return Right.all in GSSUP_Exported_Name_Type and then Left.Scoped_Name.all = GSSUP_Exported_Name_Type (Right.all).Scoped_Name.all; end Is_Equivalent; ---------------------- -- Release_Contents -- ---------------------- procedure Release_Contents (Item : access GSSUP_Exported_Name_Type) is procedure Free is new Ada.Unchecked_Deallocation (String, String_Access); begin Free (Item.Scoped_Name); Release_Contents (Exported_Name_Type (Item.all)'Access); end Release_Contents; begin declare use PolyORB.Initialization; use PolyORB.Initialization.String_Lists; use PolyORB.Utils.Strings; begin Register_Module (Module_Info' (Name => +"polyorb.security.exported_names.gssup", Conflicts => Empty, Depends => Empty, Provides => Empty, Implicit => False, Init => Initialize'Access, Shutdown => null)); end; end PolyORB.Security.Exported_Names.GSSUP; polyorb-2.8~20110207.orig/src/security/gssup/polyorb-security-credentials-gssup.ads0000644000175000017500000001055711750740340027667 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . S E C U R I T Y . C R E D E N T I A L S . G S S U P -- -- -- -- S p e c -- -- -- -- Copyright (C) 2005-2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with PolyORB.Security.Exported_Names; with PolyORB.Types; package PolyORB.Security.Credentials.GSSUP is type GSSUP_Credentials is new Credentials with private; type GSSUP_Credentials_Access is access all GSSUP_Credentials'Class; subtype UTF8_String is String; function Get_User_Name (Self : access GSSUP_Credentials) return UTF8_String; function Get_Password (Self : access GSSUP_Credentials) return UTF8_String; function Get_Target_Name (Self : access GSSUP_Credentials) return PolyORB.Security.Exported_Names.Exported_Name_Access; private type GSSUP_Credentials is new Credentials with record User_Name : PolyORB.Types.String; Password : PolyORB.Types.String; Target_Name : PolyORB.Security.Exported_Names.Exported_Name_Access; end record; -- Derived from Credentials -- function Credentials_Type -- (Self : access GSSUP_Credentials) -- return Invocation_Credentials_Type; function Get_Accepting_Options_Supported (Self : access GSSUP_Credentials) return PolyORB.Security.Types.Association_Options; -- procedure Set_Accepting_Options_Supported -- (Self : access GSSUP_Credentials; -- Options : PolyORB.Security.Types.Association_Options); function Get_Accepting_Options_Required (Self : access GSSUP_Credentials) return PolyORB.Security.Types.Association_Options; -- procedure Set_Accepting_Options_Required -- (Self : access GSSUP_Credentials; -- Options : PolyORB.Security.Types.Association_Options); function Get_Invocation_Options_Supported (Self : access GSSUP_Credentials) return PolyORB.Security.Types.Association_Options; -- procedure Set_Invocation_Options_Supported -- (Self : access GSSUP_Credentials; -- Options : PolyORB.Security.Types.Association_Options); function Get_Invocation_Options_Required (Self : access GSSUP_Credentials) return PolyORB.Security.Types.Association_Options; -- procedure Set_Invocation_Options_Required -- (Self : access GSSUP_Credentials; -- Options : PolyORB.Security.Types.Association_Options); function Get_Identity (Self : access GSSUP_Credentials) return PolyORB.Security.Identities.Identity_Access; -- Derived from Non_Controlled_Entity procedure Finalize (Self : in out GSSUP_Credentials); end PolyORB.Security.Credentials.GSSUP; polyorb-2.8~20110207.orig/src/security/gssup/polyorb-security-exported_names-gssup.ads0000644000175000017500000000671711750740340030412 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- POLYORB.SECURITY.EXPORTED_NAMES.GSSUP -- -- -- -- S p e c -- -- -- -- Copyright (C) 2005-2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- This package provide support for GSSUP mechanism Exported Name package PolyORB.Security.Exported_Names.GSSUP is type GSSUP_Exported_Name_Type is new Exported_Name_Type with private; type GSSUP_Exported_Name_Access is access all GSSUP_Exported_Name_Type'Class; -- function Get_Scoped_Name -- (Item : access GSSUP_Exported_Name_Type) -- return String; function Create_GSSUP_Exported_Name (Scoped_Name : String) return Exported_Name_Access; private type String_Access is access all String; type GSSUP_Exported_Name_Type is new Exported_Name_Type with record Scoped_Name : String_Access := null; end record; -- Derived from Exported_Name_Type function Is_Equivalent (Left : access GSSUP_Exported_Name_Type; Right : access Exported_Name_Type'Class) return Boolean; function Get_Printable_Name (Item : access GSSUP_Exported_Name_Type) return String; function Duplicate (Item : access GSSUP_Exported_Name_Type) return Exported_Name_Access; procedure Release_Contents (Item : access GSSUP_Exported_Name_Type); function Encode_Name_BLOB (Item : access GSSUP_Exported_Name_Type) return Ada.Streams.Stream_Element_Array; procedure Decode_Name_BLOB (Item : access GSSUP_Exported_Name_Type; BLOB : Ada.Streams.Stream_Element_Array; Error : in out PolyORB.Errors.Error_Container); end PolyORB.Security.Exported_Names.GSSUP; ././@LongLink0000000000000000000000000000015100000000000011562 Lustar rootrootpolyorb-2.8~20110207.orig/src/security/gssup/polyorb-security-authentication_mechanisms-gssup_client.adbpolyorb-2.8~20110207.orig/src/security/gssup/polyorb-security-authentication_mechanisms-gssup_client0000644000175000017500000001662711750740340033414 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- POLYORB.SECURITY.AUTHENTICATION_MECHANISMS.GSSUP_CLIENT -- -- -- -- B o d y -- -- -- -- Copyright (C) 2005-2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with PolyORB.Buffers; with PolyORB.Initialization; with PolyORB.Representations.CDR.Common; with PolyORB.Security.Credentials.Compound; with PolyORB.Security.Credentials.GSSUP; with PolyORB.Security.Exported_Names.GSSUP; with PolyORB.Utils.Strings; package body PolyORB.Security.Authentication_Mechanisms.GSSUP_Client is use Ada.Streams; use PolyORB.Buffers; use PolyORB.Representations.CDR.Common; use PolyORB.Security.Credentials; use PolyORB.Security.Credentials.Compound; use PolyORB.Security.Credentials.GSSUP; use PolyORB.Security.Exported_Names; use PolyORB.Security.Exported_Names.GSSUP; procedure Initialize; function Extract_GSSUP_Credentials (Credentials : Credentials_Ref) return GSSUP_Credentials_Access; -- Extract GSSUP specific credentials from compound credentials function Encode_Length (Length : Natural) return Stream_Element_Array; -- Encode item length in ASN.1 DER format function Create_Mechanism (Target_Name : PolyORB.Security.Exported_Names.Exported_Name_Access) return Client_Authentication_Mechanism_Access; Mechanism_OID : PolyORB.ASN1.Object_Identifier; Encoded_Mechanism_OID : PolyORB.Security.Types.Stream_Element_Array_Access; ---------------------- -- Create_Mechanism -- ---------------------- function Create_Mechanism (Target_Name : PolyORB.Security.Exported_Names.Exported_Name_Access) return Client_Authentication_Mechanism_Access is begin if Target_Name.all not in GSSUP_Exported_Name_Type then raise Program_Error; end if; return new GSSUP_Client_Authentication_Mechanism' (Target_Name => Target_Name); end Create_Mechanism; ------------------- -- Encode_Length -- ------------------- function Encode_Length (Length : Natural) return Stream_Element_Array is begin if Length >= 128 then raise Program_Error; -- XXX Only length < 128 bytes supported for now else return Stream_Element_Array'(1 .. 1 => Stream_Element (Length)); end if; end Encode_Length; ------------------------------- -- Extract_GSSUP_Credentials -- ------------------------------- function Extract_GSSUP_Credentials (Credentials : Credentials_Ref) return GSSUP_Credentials_Access is Creds : Credentials_Access := Credentials_Access (Entity_Of (Credentials)); begin if Creds /= null then Creds := Credentials_Access (Entity_Of (Get_Authentication_Credentials (Compound_Credentials_Access (Creds)))); if Creds /= null and then Creds.all in GSSUP_Credentials'Class then return GSSUP_Credentials_Access (Creds); end if; end if; return null; end Extract_GSSUP_Credentials; --------------------------- -- Init_Security_Context -- --------------------------- function Init_Security_Context (Mechanism : access GSSUP_Client_Authentication_Mechanism; Credentials : PolyORB.Security.Credentials.Credentials_Ref) return Ada.Streams.Stream_Element_Array is pragma Unreferenced (Mechanism); Buffer : Buffer_Access := new Buffer_Type; Creds : constant GSSUP_Credentials_Access := Extract_GSSUP_Credentials (Credentials); begin Start_Encapsulation (Buffer); Marshall_Latin_1_String (Buffer, Get_User_Name (Creds)); Marshall_Latin_1_String (Buffer, Get_Password (Creds)); Marshall (Buffer, Encode (Get_Target_Name (Creds))); declare Aux : constant Stream_Element_Array := Encapsulate (Buffer); begin Release (Buffer); return 16#60# & Encode_Length (Encoded_Mechanism_OID'Length + Aux'Length) & Encoded_Mechanism_OID.all & Aux; end; end Init_Security_Context; ---------------- -- Initialize -- ---------------- procedure Initialize is begin Mechanism_OID := PolyORB.ASN1.To_Object_Identifier (PolyORB.Security.Types.GSSUPMechOID); Encoded_Mechanism_OID := new Ada.Streams.Stream_Element_Array' (PolyORB.ASN1.Encode (Mechanism_OID)); Register (Mechanism_OID, Create_Mechanism'Access); end Initialize; ----------------- -- Is_Supports -- ----------------- function Is_Supports (Mechanism : access GSSUP_Client_Authentication_Mechanism; Credentials : PolyORB.Security.Credentials.Credentials_Ref) return Boolean is use PolyORB.Security.Types; Creds : constant GSSUP_Credentials_Access := Extract_GSSUP_Credentials (Credentials); begin return Creds /= null and then Is_Equivalent (Get_Target_Name (Creds), Mechanism.Target_Name); end Is_Supports; begin declare use PolyORB.Initialization; use PolyORB.Utils.Strings; begin Register_Module (Module_Info' (Name => +"polyorb.security.authentication_mechanisms.gssup_client", Conflicts => PolyORB.Initialization.String_Lists.Empty, Depends => PolyORB.Initialization.String_Lists.Empty, Provides => PolyORB.Initialization.String_Lists.Empty, Implicit => False, Init => Initialize'Access, Shutdown => null)); end; end PolyORB.Security.Authentication_Mechanisms.GSSUP_Client; polyorb-2.8~20110207.orig/src/security/polyorb-security-identities-principal_name.ads0000644000175000017500000000643311750740340030210 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- POLYORB.SECURITY.IDENTITIES.PRINCIPAL_NAME -- -- -- -- S p e c -- -- -- -- Copyright (C) 2005-2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with PolyORB.Security.Exported_Names; package PolyORB.Security.Identities.Principal_Name is type Principal_Name_Identity_Type is new Identity_Type with private; function Create_Principal_Name_Identity (Principal_Name : PolyORB.Security.Exported_Names.Exported_Name_Access) return Identity_Access; private type Principal_Name_Identity_Type is new Identity_Type with record Principal_Name : PolyORB.Security.Exported_Names.Exported_Name_Access; end record; -- Derived from Identity_Token_Type function Get_Token_Type (Self : access Principal_Name_Identity_Type) return PolyORB.Security.Types.Identity_Token_Type; function Get_Printable_Name (Self : access Principal_Name_Identity_Type) return String; function Duplicate (Self : access Principal_Name_Identity_Type) return Identity_Access; procedure Release_Contents (Self : access Principal_Name_Identity_Type); function Encode (Self : access Principal_Name_Identity_Type) return Ada.Streams.Stream_Element_Array; procedure Decode (Self : access Principal_Name_Identity_Type; Item : Ada.Streams.Stream_Element_Array; Error : in out PolyORB.Errors.Error_Container); end PolyORB.Security.Identities.Principal_Name; polyorb-2.8~20110207.orig/src/security/polyorb-security-authorization_elements.adb0000644000175000017500000000746211750740340027646 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- POLYORB.SECURITY.AUTHORIZATION_ELEMENTS -- -- -- -- B o d y -- -- -- -- Copyright (C) 2005-2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with Ada.Unchecked_Deallocation; with PolyORB.Security.Authorization_Elements.Unknown; package body PolyORB.Security.Authorization_Elements is type Registry_Record is record The_Type : Element_Type; Constructor : Element_Constructor; end record; package Registry_Lists is new PolyORB.Utils.Chained_Lists (Registry_Record); Registry : Registry_Lists.List; ------------ -- Create -- ------------ function Create (The_Type : Element_Type; Contents : Ada.Streams.Stream_Element_Array) return Authorization_Element_Access is use Registry_Lists; Iter : Iterator := First (Registry); begin while not Last (Iter) loop if Value (Iter).all.The_Type = The_Type then return Value (Iter).all.Constructor (Contents); end if; Next (Iter); end loop; return Unknown.Create (The_Type, Contents); end Create; -------------- -- Register -- -------------- procedure Register (The_Type : Element_Type; Constructor : Element_Constructor) is begin Registry_Lists.Append (Registry, (The_Type, Constructor)); end Register; ---------------------- -- Release_Contents -- ---------------------- procedure Release_Contents (Item : in out Authorization_Element_Lists.List) is use Authorization_Element_Lists; procedure Free is new Ada.Unchecked_Deallocation (Authorization_Element_Type'Class, Authorization_Element_Access); Iter : Iterator := First (Item); begin while not Last (Iter) loop Release_Contents (Value (Iter).all); Free (Value (Iter).all); Next (Iter); end loop; Deallocate (Item); end Release_Contents; end PolyORB.Security.Authorization_Elements; polyorb-2.8~20110207.orig/src/security/polyorb-qos-targets_security.ads0000644000175000017500000001132311750740340025415 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . Q O S . T A R G E T S _ S E C U R I T Y -- -- -- -- S p e c -- -- -- -- Copyright (C) 2005-2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- Target Side CORBA CSI Version 2 Compound Mechanism Configuration with PolyORB.Annotations; with PolyORB.Security.Authentication_Mechanisms; with PolyORB.Security.Authority_Mechanisms; with PolyORB.Security.Backward_Trust_Evaluators; with PolyORB.Security.Credentials; with PolyORB.Security.Forward_Trust_Evaluators; with PolyORB.Security.Transport_Mechanisms; with PolyORB.Security.Types; with PolyORB.Utils.Chained_Lists; package PolyORB.QoS.Targets_Security is type Target_Mechanism is limited record Transport : PolyORB.Security.Transport_Mechanisms. Target_Transport_Mechanism_Access; -- Authentication layer Authentication_Mechanism : PolyORB.Security.Authentication_Mechanisms. Target_Authentication_Mechanism_Access; Authentication_Required : Boolean; -- Attribute layer Authorities : PolyORB.Security.Authority_Mechanisms. Target_Authority_Mechanism_Lists.List; Forward_Trust_Evaluator : PolyORB.Security.Forward_Trust_Evaluators. Forward_Trust_Evaluator_Access; Backward_Trust_Evaluator : PolyORB.Security.Backward_Trust_Evaluators. Backward_Trust_Evaluator_Access; Naming_Mechanisms : PolyORB.Security.Types.OID_Lists.List; Identity_Types : PolyORB.Security.Types.Identity_Token_Type; Delegation_Required : Boolean; Credentials : PolyORB.Security.Credentials.Credentials_Ref; Notepad : PolyORB.Annotations.Notepad; end record; type Target_Mechanism_Access is access all Target_Mechanism; function Is_Protected (Mechanism : Target_Mechanism) return Boolean; function Target_Supports (Mechanism : Target_Mechanism) return PolyORB.Security.Types.Association_Options; function Target_Requires (Mechanism : Target_Mechanism) return PolyORB.Security.Types.Association_Options; procedure Set_Accepting_Credentials (Mechanism : in out Target_Mechanism; Credentials : PolyORB.Security.Credentials.Credentials_Ref); package Target_Mechanism_Lists is new PolyORB.Utils.Chained_Lists (Target_Mechanism_Access); type QoS_Target_Security_Parameter is new QoS_Parameter (Compound_Security) with record Stateful : Boolean; Disable_Unprotected : Boolean; Mechanisms : Target_Mechanism_Lists.List; -- List of available compound security mechanisms. end record; type QoS_Target_Security_Parameter_Access is access all QoS_Target_Security_Parameter; procedure Release_Contents (QoS : access QoS_Target_Security_Parameter); end PolyORB.QoS.Targets_Security; polyorb-2.8~20110207.orig/src/security/polyorb-security-transport_mechanisms-unprotected.adb0000644000175000017500000000616011750740340031641 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- POLYORB.SECURITY.TRANSPORT_MECHANISMS.UNPROTECTED -- -- -- -- B o d y -- -- -- -- Copyright (C) 2005-2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ package body PolyORB.Security.Transport_Mechanisms.Unprotected is ----------------- -- Is_Supports -- ----------------- function Is_Supports (Mechanism : access Unprotected_Transport_Mechanism; Credentials : PolyORB.Security.Credentials.Credentials_Ref) return Boolean is pragma Unreferenced (Mechanism); pragma Unreferenced (Credentials); begin return False; end Is_Supports; --------------------- -- Target_Requires -- --------------------- function Target_Requires (Mechanism : access Unprotected_Transport_Mechanism) return PolyORB.Security.Types.Association_Options is pragma Unreferenced (Mechanism); begin return 0; end Target_Requires; --------------------- -- Target_Supports -- --------------------- function Target_Supports (Mechanism : access Unprotected_Transport_Mechanism) return PolyORB.Security.Types.Association_Options is pragma Unreferenced (Mechanism); begin return 0; end Target_Supports; end PolyORB.Security.Transport_Mechanisms.Unprotected; polyorb-2.8~20110207.orig/src/security/polyorb-security-credentials-compound.adb0000644000175000017500000002150011750740340027156 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- POLYORB.SECURITY.CREDENTIALS.COMPOUND -- -- -- -- B o d y -- -- -- -- Copyright (C) 2005-2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with PolyORB.Parameters; package body PolyORB.Security.Credentials.Compound is use PolyORB.Parameters; use PolyORB.Security.Types; ------------------------ -- Create_Credentials -- ------------------------ function Create_Credentials (Section_Name : String) return Credentials_Ref is Transport_Credentials_Type : constant String := Get_Conf (Section_Name, "transport_credentials_type", ""); Authentication_Credentials_Type : constant String := Get_Conf (Section_Name, "authentication_credentials_type", ""); Aux : constant Compound_Credentials_Access := new Compound_Credentials; Result : Credentials_Ref; begin if Transport_Credentials_Type /= "" then Aux.Transport := PolyORB.Security.Credentials.Credentials_Ref (PolyORB.Security.Credentials.Create_Credentials (Transport_Credentials_Type, Section_Name)); end if; if Authentication_Credentials_Type /= "" then Aux.Authentication := PolyORB.Security.Credentials.Credentials_Ref (PolyORB.Security.Credentials.Create_Credentials (Authentication_Credentials_Type, Section_Name)); end if; Set (Result, PolyORB.Smart_Pointers.Entity_Ptr (Aux)); return Result; end Create_Credentials; ------------------------------------------ -- Create_Received_Compound_Credentials -- ------------------------------------------ function Create_Received_Compound_Credentials (Accepting : Credentials_Ref; Transport : Credentials_Ref) return Credentials_Ref is Result : Credentials_Ref; Aux : constant Received_Compound_Credentials_Access := new Received_Compound_Credentials; begin Aux.Accepting := Accepting; Aux.Transport := Transport; Set (Result, PolyORB.Smart_Pointers.Entity_Ptr (Aux)); return Result; end Create_Received_Compound_Credentials; ---------------------- -- Credentials_Type -- ---------------------- function Credentials_Type (Self : access Compound_Credentials) return Invocation_Credentials_Type is pragma Unreferenced (Self); begin return Own_Credentials; end Credentials_Type; ------------------------------------ -- Get_Accepting_Options_Required -- ------------------------------------ function Get_Accepting_Options_Required (Self : access Compound_Credentials) return PolyORB.Security.Types.Association_Options is T : constant Credentials_Access := Credentials_Access (Entity_Of (Self.Transport)); A : constant Credentials_Access := Credentials_Access (Entity_Of (Self.Authentication)); Result : PolyORB.Security.Types.Association_Options := 0; begin if T /= null then Result := Result or Get_Accepting_Options_Required (T); end if; if A /= null then Result := Result or Get_Accepting_Options_Required (A); end if; return Result; end Get_Accepting_Options_Required; ------------------------------------- -- Get_Accepting_Options_Supported -- ------------------------------------- function Get_Accepting_Options_Supported (Self : access Compound_Credentials) return PolyORB.Security.Types.Association_Options is T : constant Credentials_Access := Credentials_Access (Entity_Of (Self.Transport)); A : constant Credentials_Access := Credentials_Access (Entity_Of (Self.Authentication)); Result : PolyORB.Security.Types.Association_Options := 0; begin if T /= null then Result := Result or Get_Accepting_Options_Supported (T); end if; if A /= null then Result := Result or Get_Accepting_Options_Supported (A); end if; return Result; end Get_Accepting_Options_Supported; ------------------------------------ -- Get_Authentication_Credentials -- ------------------------------------ function Get_Authentication_Credentials (Self : access Compound_Credentials) return Credentials_Ref is begin return Self.Authentication; end Get_Authentication_Credentials; ------------------ -- Get_Identity -- ------------------ function Get_Identity (Self : access Compound_Credentials) return PolyORB.Security.Identities.Identity_Access is pragma Unreferenced (Self); begin raise Program_Error; return null; end Get_Identity; -------------------------------------- -- Get_Invocation_Options_Required -- -------------------------------------- function Get_Invocation_Options_Required (Self : access Compound_Credentials) return PolyORB.Security.Types.Association_Options is T : constant Credentials_Access := Credentials_Access (Entity_Of (Self.Transport)); A : constant Credentials_Access := Credentials_Access (Entity_Of (Self.Authentication)); Result : PolyORB.Security.Types.Association_Options := 0; begin if T /= null then Result := Result or Get_Invocation_Options_Required (T); end if; if A /= null then Result := Result or Get_Invocation_Options_Required (A); end if; return Result; end Get_Invocation_Options_Required; -------------------------------------- -- Get_Invocation_Options_Supported -- -------------------------------------- function Get_Invocation_Options_Supported (Self : access Compound_Credentials) return PolyORB.Security.Types.Association_Options is T : constant Credentials_Access := Credentials_Access (Entity_Of (Self.Transport)); A : constant Credentials_Access := Credentials_Access (Entity_Of (Self.Authentication)); Result : PolyORB.Security.Types.Association_Options := 0; begin if T /= null then Result := Result or Get_Invocation_Options_Supported (T); end if; if A /= null then Result := Result or Get_Invocation_Options_Supported (A); end if; return Result; end Get_Invocation_Options_Supported; ------------------------------- -- Get_Transport_Credentials -- ------------------------------- function Get_Transport_Credentials (Self : access Compound_Credentials) return Credentials_Ref is begin return Self.Transport; end Get_Transport_Credentials; ---------------------------- -- Get_Transport_Identity -- ---------------------------- function Get_Transport_Identity (Self : access Compound_Credentials) return PolyORB.Security.Identities.Identity_Access is begin return Get_Identity (Credentials_Access (Entity_Of (Self.Transport))); end Get_Transport_Identity; end PolyORB.Security.Credentials.Compound; polyorb-2.8~20110207.orig/src/security/polyorb-security-security_manager.adb0000644000175000017500000002233011750740340026402 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . S E C U R I T Y . S E C U R I T Y _ M A N A G E R -- -- -- -- B o d y -- -- -- -- Copyright (C) 2005-2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with PolyORB.Initialization; with PolyORB.Parameters; with PolyORB.Security.Credentials.Compound; with PolyORB.Types; with PolyORB.Utils.Chained_Lists; with PolyORB.Utils.Strings; package body PolyORB.Security.Security_Manager is use PolyORB.Parameters; use PolyORB.Security.Transport_Mechanisms; use PolyORB.Types; procedure Initialize; type Creds_Item is record Creds : PolyORB.Security.Credentials.Credentials_Ref; Name : PolyORB.Types.String; end record; package Creds_Lists is new PolyORB.Utils.Chained_Lists (Creds_Item, "=", True); use Creds_Lists; type Mechs_Item is record Mech : Target_Transport_Mechanism_Access; Name : PolyORB.Types.String; end record; package Transport_Mechanism_Lists is new PolyORB.Utils.Chained_Lists (Mechs_Item, "=", True); use Transport_Mechanism_Lists; Creds : Creds_Lists.List; Mechs : Transport_Mechanism_Lists.List; Requires : PolyORB.Security.Types.Association_Options; --------------------- -- Client_Requires -- --------------------- function Client_Requires return PolyORB.Security.Types.Association_Options is begin return Requires; end Client_Requires; ----------------------------- -- Get_Transport_Mechanism -- ----------------------------- function Get_Transport_Mechanism (Name : String) return PolyORB.Security.Transport_Mechanisms.Target_Transport_Mechanism_Access is Iter : Transport_Mechanism_Lists.Iterator := First (Mechs); begin while not Last (Iter) loop if Value (Iter).Name = Name then return Value (Iter).Mech; end if; Next (Iter); end loop; return null; end Get_Transport_Mechanism; ---------------- -- Initialize -- ---------------- procedure Initialize is begin -- Calculate client requirements declare use PolyORB.Security.Types; Require_Integrity : constant Boolean := Get_Conf ("security_manager", "integrity_required", False); Require_Confidentiality : constant Boolean := Get_Conf ("security_manager", "confidentiality_required", False); Require_Detect_Replay : constant Boolean := Get_Conf ("security_manager", "detect_replay_required", False); Require_Detect_Misordering : constant Boolean := Get_Conf ("security_manager", "detect_misordering_required", False); Require_Establish_Trust_In_Target : constant Boolean := Get_Conf ("security_manager", "establish_trust_in_target_required", False); Require_Establish_Trust_In_Client : constant Boolean := Get_Conf ("security_manager", "establish_trust_in_client_required", False); Require_Identity_Assertion : constant Boolean := Get_Conf ("security_manager", "identity_assertion_required", False); Require_Delegation_By_Client : constant Boolean := Get_Conf ("security_manager", "delegation_by_client_required", False); begin if Require_Integrity then Requires := Requires or Integrity; end if; if Require_Confidentiality then Requires := Requires or Confidentiality; end if; if Require_Detect_Replay then Requires := Requires or Detect_Replay; end if; if Require_Detect_Misordering then Requires := Requires or Detect_Misordering; end if; if Require_Establish_Trust_In_Target then Requires := Requires or Establish_Trust_In_Target; end if; if Require_Establish_Trust_In_Client then Requires := Requires or Establish_Trust_In_Client; end if; if Require_Identity_Assertion then Requires := Requires or Identity_Assertion; end if; if Require_Delegation_By_Client then Requires := Requires or Delegation_By_Client; end if; end; -- Creating capsule's credentials declare Own_Credentials : constant String := Get_Conf ("security_manager", "own_credentials", ""); Last : Natural := Own_Credentials'First - 1; First : Positive; Aux : PolyORB.Security.Credentials.Credentials_Ref; begin Parse_Creds : loop First := Last + 1; exit Parse_Creds when First > Own_Credentials'Last; while Own_Credentials (First) = ' ' loop First := First + 1; exit Parse_Creds when First > Own_Credentials'Last; end loop; Last := First; while Last <= Own_Credentials'Last and then Own_Credentials (Last) /= ' ' loop Last := Last + 1; end loop; Last := Last - 1; Aux := PolyORB.Security.Credentials.Compound.Create_Credentials (Own_Credentials (First .. Last)); if not PolyORB.Security.Credentials.Is_Null (Aux) then Append (Creds, (Aux, PolyORB.Types.To_PolyORB_String (Own_Credentials (First .. Last)))); else raise Program_Error; end if; end loop Parse_Creds; end; end Initialize; --------------------- -- Own_Credentials -- --------------------- function Own_Credentials return PolyORB.Security.Credentials.Credentials_List is Result : PolyORB.Security.Credentials.Credentials_List (1 .. Length (Creds)); RLast : Natural := 0; Iter : Creds_Lists.Iterator := First (Creds); begin while not Last (Iter) loop RLast := RLast + 1; Result (RLast) := Value (Iter).Creds; Next (Iter); end loop; return Result; end Own_Credentials; ---------------------------------- -- Register_Transport_Mechanism -- ---------------------------------- procedure Register_Transport_Mechanism (Name : String; Mech : PolyORB.Security.Transport_Mechanisms.Target_Transport_Mechanism_Access) is begin Append (Mechs, (Mech, PolyORB.Types.To_PolyORB_String (Name))); end Register_Transport_Mechanism; begin declare use PolyORB.Initialization; use PolyORB.Initialization.String_Lists; use PolyORB.Utils.Strings; begin Register_Module (Module_Info' (Name => +"polyorb.security.security_manager", Conflicts => PolyORB.Initialization.String_Lists.Empty, Depends => +"orb" -- Neutral stuff & "polyorb.security.authority_mechanisms.atlas_client?" & "polyorb.security.authority_mechanisms.atlas_target?" & "polyorb.security.credentials.gssup?" & "polyorb.security.credentials.tls?" & "polyorb.security.identities.distinguished_name?", Provides => PolyORB.Initialization.String_Lists.Empty, Implicit => False, Init => Initialize'Access, Shutdown => null)); end; end PolyORB.Security.Security_Manager; polyorb-2.8~20110207.orig/src/security/polyorb-security-identities-anonymous.ads0000644000175000017500000000571311750740340027257 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- POLYORB.SECURITY.IDENTITIES.ANONYMOUS -- -- -- -- S p e c -- -- -- -- Copyright (C) 2005-2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ package PolyORB.Security.Identities.Anonymous is type Anonymous_Identity_Type is new Identity_Type with null record; function Create_Anonymous_Identity return Identity_Access; private -- Derived from Identity_Token_Type function Get_Token_Type (Self : access Anonymous_Identity_Type) return PolyORB.Security.Types.Identity_Token_Type; function Get_Printable_Name (Self : access Anonymous_Identity_Type) return String; function Duplicate (Self : access Anonymous_Identity_Type) return Identity_Access; procedure Release_Contents (Self : access Anonymous_Identity_Type); function Encode (Self : access Anonymous_Identity_Type) return Ada.Streams.Stream_Element_Array; procedure Decode (Self : access Anonymous_Identity_Type; Item : Ada.Streams.Stream_Element_Array; Error : in out PolyORB.Errors.Error_Container); end PolyORB.Security.Identities.Anonymous; polyorb-2.8~20110207.orig/src/security/polyorb-security-identities.ads0000644000175000017500000000673311750740340025234 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . S E C U R I T Y . I D E N T I T I E S -- -- -- -- S p e c -- -- -- -- Copyright (C) 2005-2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with Ada.Streams; with PolyORB.Errors; with PolyORB.Security.Types; package PolyORB.Security.Identities is type Identity_Type is abstract tagged null record; type Identity_Access is access all Identity_Type'Class; function Get_Token_Type (Self : access Identity_Type) return PolyORB.Security.Types.Identity_Token_Type is abstract; function Get_Printable_Name (Self : access Identity_Type) return String is abstract; function Duplicate (Self : access Identity_Type) return Identity_Access is abstract; procedure Release_Contents (Self : access Identity_Type) is abstract; procedure Destroy (Item : in out Identity_Access); function Encode (Self : access Identity_Type) return Ada.Streams.Stream_Element_Array is abstract; procedure Decode (Self : access Identity_Type; Item : Ada.Streams.Stream_Element_Array; Error : in out PolyORB.Errors.Error_Container) is abstract; procedure Create (Kind : PolyORB.Security.Types.Identity_Token_Type; Item : Ada.Streams.Stream_Element_Array; Token : out Identity_Access; Error : in out PolyORB.Errors.Error_Container); private type Empty_Identity_Constructor is access function return Identity_Access; procedure Register (Kind : PolyORB.Security.Types.Identity_Token_Type; Constructor : Empty_Identity_Constructor); end PolyORB.Security.Identities; polyorb-2.8~20110207.orig/src/security/polyorb-security-types.ads0000644000175000017500000001402111750740340024224 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . S E C U R I T Y . T Y P E S -- -- -- -- S p e c -- -- -- -- Copyright (C) 2005-2008, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with Ada.Streams; with PolyORB.ASN1; with PolyORB.Types; with PolyORB.Utils.Chained_Lists; with PolyORB.Utils.Simple_Flags; package PolyORB.Security.Types is -- Association Options from CORBA CSIv2 and Security Specification type Association_Options is new PolyORB.Types.Unsigned_Short; No_Protection : constant Association_Options := 1; Integrity : constant Association_Options := 2; Confidentiality : constant Association_Options := 4; Detect_Replay : constant Association_Options := 8; Detect_Misordering : constant Association_Options := 16; Establish_Trust_In_Target : constant Association_Options := 32; Establish_Trust_In_Client : constant Association_Options := 64; No_Delegation : constant Association_Options := 128; Simple_Delegation : constant Association_Options := 256; Composite_Delegation : constant Association_Options := 512; Identity_Assertion : constant Association_Options := 1024; Delegation_By_Client : constant Association_Options := 2048; function Is_Set (Flag_To_Test : Association_Options; In_Flags : Association_Options) return Boolean; -- Test if Flag_To_Test has been set in In_Flags -- Flag_To_Test is a mask function Set (Flag_To_Set : Association_Options; In_Flags : Association_Options) return Association_Options; -- Set Flag_To_Set in In_Flags -- Flag_To_Set is a mask -- Identity Token Types from CORBA CSIv2 Specification type Identity_Token_Type is new PolyORB.Types.Unsigned_Long; ITT_Absent : constant Identity_Token_Type := 0; ITT_Anonymous : constant Identity_Token_Type := 1; ITT_Principal_Name : constant Identity_Token_Type := 2; ITT_X509_Cert_Chain : constant Identity_Token_Type := 4; ITT_Distinguished_Name : constant Identity_Token_Type := 8; function Is_Set (Flag_To_Test : Identity_Token_Type; In_Flags : Identity_Token_Type) return Boolean; function Set (Flag_To_Set : Identity_Token_Type; In_Flags : Identity_Token_Type) return Identity_Token_Type; -- ASN.1 OBJECT IDENTIFIER list package OID_Lists is new PolyORB.Utils.Chained_Lists (PolyORB.ASN1.Object_Identifier, PolyORB.ASN1."="); function Duplicate (Item : OID_Lists.List) return OID_Lists.List; -- Access to stream element array. Widely used for represent different -- security tokens in encoded form. type Stream_Element_Array_Access is access all Ada.Streams.Stream_Element_Array; -- Security Context Identifier type Context_Id is new PolyORB.Types.Unsigned_Long_Long; -- OIDs for well known security mechanisms -- KRB5MechOID : constant String := "oid:1.2.840.113554.1.2.2"; -- GSS_NT_Export_Name_OID : constant String := "oid:1.3.6.1.5.6.4"; -- GSS_NT_Scoped_Username_OID : constant String := "oid:2.23.130.1.2.1"; GSSUPMechOID : constant String := "oid:2.23.130.1.1.1"; private package Association_Options_Flags is new PolyORB.Utils.Simple_Flags (Association_Options, Shift_Left); function Is_Set (Flag_To_Test : Association_Options; In_Flags : Association_Options) return Boolean renames Association_Options_Flags.Is_Set; function Set (Flag_To_Set : Association_Options; In_Flags : Association_Options) return Association_Options renames Association_Options_Flags.Set; package Identity_Token_Type_Flags is new PolyORB.Utils.Simple_Flags (Identity_Token_Type, Shift_Left); function Is_Set (Flag_To_Test : Identity_Token_Type; In_Flags : Identity_Token_Type) return Boolean renames Identity_Token_Type_Flags.Is_Set; function Set (Flag_To_Set : Identity_Token_Type; In_Flags : Identity_Token_Type) return Identity_Token_Type renames Identity_Token_Type_Flags.Set; end PolyORB.Security.Types; polyorb-2.8~20110207.orig/src/security/polyorb-security-identities.adb0000644000175000017500000001044611750740340025207 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . S E C U R I T Y . I D E N T I T I E S -- -- -- -- B o d y -- -- -- -- Copyright (C) 2005-2008, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with Ada.Unchecked_Deallocation; with PolyORB.Log; with PolyORB.Utils.Chained_Lists; package body PolyORB.Security.Identities is use PolyORB.Log; use PolyORB.Security.Types; package L is new PolyORB.Log.Facility_Log ("polyorb.security.identity_tokens"); procedure O (Message : String; Level : Log_Level := Debug) renames L.Output; function C (Level : Log_Level := Debug) return Boolean renames L.Enabled; type Registry_Item is record Kind : PolyORB.Security.Types.Identity_Token_Type; Constructor : Empty_Identity_Constructor; end record; package Registry_Item_Lists is new PolyORB.Utils.Chained_Lists (Registry_Item); Registry : Registry_Item_Lists.List; ------------ -- Create -- ------------ procedure Create (Kind : PolyORB.Security.Types.Identity_Token_Type; Item : Ada.Streams.Stream_Element_Array; Token : out Identity_Access; Error : in out PolyORB.Errors.Error_Container) is use Registry_Item_Lists; begin if Kind = ITT_Absent then Token := null; else declare Iter : Iterator := First (Registry); begin while not Last (Iter) loop if Value (Iter).Kind = Kind then Token := Value (Iter).Constructor.all; Decode (Token, Item, Error); return; end if; Next (Iter); end loop; end; end if; Token := null; end Create; ------------- -- Destroy -- ------------- procedure Destroy (Item : in out Identity_Access) is procedure Free is new Ada.Unchecked_Deallocation (Identity_Type'Class, Identity_Access); begin if Item /= null then Release_Contents (Item); Free (Item); end if; end Destroy; -------------- -- Register -- -------------- procedure Register (Kind : PolyORB.Security.Types.Identity_Token_Type; Constructor : Empty_Identity_Constructor) is begin pragma Debug (C, O ("Register identity token type:" & Identity_Token_Type'Image (Kind))); Registry_Item_Lists.Append (Registry, (Kind, Constructor)); end Register; end PolyORB.Security.Identities; polyorb-2.8~20110207.orig/src/security/polyorb-security-authority_mechanisms.adb0000644000175000017500000001243311750740340027303 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- POLYORB.SECURITY.AUTHORITY_MECHANISMS -- -- -- -- B o d y -- -- -- -- Copyright (C) 2005-2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with Ada.Unchecked_Deallocation; with PolyORB.Parameters; package body PolyORB.Security.Authority_Mechanisms is use PolyORB.Parameters; use PolyORB.Types; type Target_Registry_Item is record Name : PolyORB.Types.String; Constructor : Target_Constructor; end record; type Client_Registry_Item is record Syntax : Service_Configuration_Syntax; Constructor : Client_Constructor; end record; package Target_Registry_Lists is new PolyORB.Utils.Chained_Lists (Target_Registry_Item); package Client_Registry_Lists is new PolyORB.Utils.Chained_Lists (Client_Registry_Item); Target_Registry : Target_Registry_Lists.List; Client_Registry : Client_Registry_Lists.List; --------------------------------------- -- Create_Client_Authority_Mechanism -- --------------------------------------- function Create_Client_Authority_Mechanism (Syntax : Service_Configuration_Syntax; Name : Ada.Streams.Stream_Element_Array) return Client_Authority_Mechanism_Access is use Client_Registry_Lists; Iter : Iterator := First (Client_Registry); begin while not Last (Iter) loop if Value (Iter).all.Syntax = Syntax then return Value (Iter).all.Constructor (Name); end if; Next (Iter); end loop; return null; end Create_Client_Authority_Mechanism; --------------------------------------- -- Create_Target_Authority_Mechanism -- --------------------------------------- function Create_Target_Authority_Mechanism (Section_Name : Standard.String) return Target_Authority_Mechanism_Access is use Target_Registry_Lists; Mechanism : constant String := Get_Conf (Section_Name, "mechanism", ""); Iter : Iterator := First (Target_Registry); begin while not Last (Iter) loop if Value (Iter).all.Name = Mechanism then return Value (Iter).all.Constructor (Section_Name); end if; Next (Iter); end loop; return null; end Create_Target_Authority_Mechanism; ------------- -- Destroy -- ------------- procedure Destroy (Item : in out Client_Authority_Mechanism_Access) is procedure Free is new Ada.Unchecked_Deallocation (Client_Authority_Mechanism'Class, Client_Authority_Mechanism_Access); begin Release_Contents (Item); Free (Item); end Destroy; procedure Destroy (Item : in out Target_Authority_Mechanism_Access) is procedure Free is new Ada.Unchecked_Deallocation (Target_Authority_Mechanism'Class, Target_Authority_Mechanism_Access); begin Release_Contents (Item); Free (Item); end Destroy; -------------- -- Register -- -------------- procedure Register (Syntax : Service_Configuration_Syntax; Constructor : Client_Constructor) is begin Client_Registry_Lists.Append (Client_Registry, (Syntax, Constructor)); end Register; procedure Register (Name : Standard.String; Constructor : Target_Constructor) is begin Target_Registry_Lists.Append (Target_Registry, (To_PolyORB_String (Name), Constructor)); end Register; end PolyORB.Security.Authority_Mechanisms; polyorb-2.8~20110207.orig/src/security/polyorb-asn1.ads0000644000175000017500000000614311750740340022063 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . A S N 1 -- -- -- -- S p e c -- -- -- -- Copyright (C) 2005-2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with Ada.Streams; package PolyORB.ASN1 is ASN1_Error : exception; -- ASN.1 OBJECT IDENTIFIER type Object_Identifier is private; Null_Object_Identifier : constant Object_Identifier; function Is_Equivalent (OID1 : Object_Identifier; OID2 : Object_Identifier) return Boolean; function Duplicate (Item : Object_Identifier) return Object_Identifier; procedure Free (Item : in out Object_Identifier); procedure Destroy (Item : in out Object_Identifier) renames Free; function Encode (Item : Object_Identifier) return Ada.Streams.Stream_Element_Array; function Decode (Item : Ada.Streams.Stream_Element_Array) return Object_Identifier; function To_String (Item : Object_Identifier) return String; function To_Object_Identifier (Item : String) return Object_Identifier; private type Object_Identifier_Record is null record; pragma Convention (C, Object_Identifier_Record); type Object_Identifier is access all Object_Identifier_Record; Null_Object_Identifier : constant Object_Identifier := null; end PolyORB.ASN1; polyorb-2.8~20110207.orig/src/security/polyorb-qos-security_contexts.ads0000644000175000017500000001046411750740340025620 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . Q O S . S E C U R I T Y _ C O N T E X T S -- -- -- -- S p e c -- -- -- -- Copyright (C) 2005-2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- Request Security Service Context with PolyORB.Security.Authorization_Elements; with PolyORB.Security.Identities; with PolyORB.Security.Types; with PolyORB.Types; package PolyORB.QoS.Security_Contexts is package PS renames PolyORB.Security; type Context_Kinds is (Establish_Context, Complete_Establish_Context, Context_Error, Message_In_Context); type QoS_Security_Context_Parameter (Context_Kind : Context_Kinds) is new QoS_Parameter (Compound_Security) with record -- XXX This portion should be moved into separate QoS parameter! -- It violates QoS <=> GIOP Service Context conversion rules! -- -- Selected : -- PolyORB.Security.Compound_Mechanisms.Compound_Mechanism_Access; -- -- Selected compound security mechanism -- -- Transport_Credentials : PolyORB.Security.Credentials.Credentials_Ref; -- -- Transport layer credentials. For client this credentials used for -- -- establish connection with server (own credentials). For server this -- -- is credentials of client, which establish connection (received -- -- credentials). -- -- XXX End of section Client_Context_Id : PolyORB.Security.Types.Context_Id; case Context_Kind is when Establish_Context => Authorization_Token : PS.Authorization_Elements.Authorization_Element_Lists.List; Identity_Token : PolyORB.Security.Identities.Identity_Access; Client_Authentication_Token : PolyORB.Security.Types.Stream_Element_Array_Access; when Complete_Establish_Context => Context_Stateful : Boolean; Final_Context_Token : PolyORB.Security.Types.Stream_Element_Array_Access; when Context_Error => Major_Status : PolyORB.Types.Long; Minor_Status : PolyORB.Types.Long; Error_Token : PolyORB.Security.Types.Stream_Element_Array_Access; when Message_In_Context => Discard_Context : Boolean; end case; end record; type QoS_Security_Context_Parameter_Access is access all QoS_Security_Context_Parameter; procedure Release_Contents (QoS : access QoS_Security_Context_Parameter); end PolyORB.QoS.Security_Contexts; polyorb-2.8~20110207.orig/src/security/polyorb-qos-clients_security.adb0000644000175000017500000001410711750740340025367 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . Q O S . C L I E N T S _ S E C U R I T Y -- -- -- -- B o d y -- -- -- -- Copyright (C) 2005-2009, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with Ada.Unchecked_Deallocation; with PolyORB.ASN1; package body PolyORB.QoS.Clients_Security is use PolyORB.Annotations; use PolyORB.ASN1; use PolyORB.Security.Authentication_Mechanisms; use PolyORB.Security.Authority_Mechanisms; use PolyORB.Security.Authority_Mechanisms.Client_Authority_Mechanism_Lists; use PolyORB.Security.Transport_Mechanisms; use PolyORB.Security.Types; use OID_Lists; procedure Release_Contents (Item : in out Client_Mechanism); procedure Free is new Ada.Unchecked_Deallocation (Client_Mechanism, Client_Mechanism_Access); ------------- -- Destroy -- ------------- procedure Destroy (Mechanism : in out Client_Mechanism_Access) is begin if Mechanism /= null then Release_Contents (Mechanism.all); Free (Mechanism); end if; end Destroy; ------------------ -- Is_Protected -- ------------------ function Is_Protected (Mechanism : Client_Mechanism) return Boolean is begin return Target_Requires (Mechanism) /= 0; end Is_Protected; ---------------------- -- Release_Contents -- ---------------------- procedure Release_Contents (Item : in out Client_Mechanism) is procedure Free is new Ada.Unchecked_Deallocation (Client_Transport_Mechanism'Class, Client_Transport_Mechanism_Access); begin Free (Item.Transport); Destroy (Item.Authentication_Mechanism); declare Iter : Client_Authority_Mechanism_Lists.Iterator := First (Item.Authorities); begin while not Last (Iter) loop Destroy (Value (Iter).all); Next (Iter); end loop; end; Deallocate (Item.Authorities); declare Iter : OID_Lists.Iterator := First (Item.Naming_Mechanisms); begin while not Last (Iter) loop Free (Value (Iter).all); Next (Iter); end loop; end; Deallocate (Item.Naming_Mechanisms); Destroy (Item.Notepad); end Release_Contents; procedure Release_Contents (QoS : access QoS_Client_Security_Parameter) is use Client_Mechanism_Lists; Iter : Client_Mechanism_Lists.Iterator := First (QoS.Mechanisms); begin while not Last (Iter) loop Release_Contents (Value (Iter).all.all); Free (Value (Iter).all); Next (Iter); end loop; Deallocate (QoS.Mechanisms); end Release_Contents; --------------------- -- Target_Requires -- --------------------- function Target_Requires (Mechanism : Client_Mechanism) return PolyORB.Security.Types.Association_Options is Result : Association_Options := 0; begin if Mechanism.Transport /= null then Result := Target_Requires (Mechanism.Transport); end if; if Mechanism.Authentication_Mechanism /= null and then Mechanism.Authentication_Required then Result := Result or Establish_Trust_In_Client; end if; if not Is_Empty (Mechanism.Authorities) and then Mechanism.Delegation_Supported and then Mechanism.Delegation_Required then Result := Result or Delegation_By_Client; end if; return Result; end Target_Requires; --------------------- -- Target_Supports -- --------------------- function Target_Supports (Mechanism : Client_Mechanism) return PolyORB.Security.Types.Association_Options is Result : Association_Options := 0; begin if Mechanism.Transport /= null then Result := Target_Supports (Mechanism.Transport); end if; if Mechanism.Authentication_Mechanism /= null then Result := Result or Establish_Trust_In_Client; end if; if Mechanism.Identity_Assertion then Result := Result or Identity_Assertion; end if; if not Is_Empty (Mechanism.Authorities) and then Mechanism.Delegation_Supported then Result := Result or Delegation_By_Client; end if; return Result; end Target_Supports; end PolyORB.QoS.Clients_Security; polyorb-2.8~20110207.orig/src/security/polyorb-security-exported_names.adb0000644000175000017500000002103711750740340026061 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . S E C U R I T Y . E X P O R T E D _ N A M E S -- -- -- -- B o d y -- -- -- -- Copyright (C) 2005-2008, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with Ada.Unchecked_Deallocation; with PolyORB.Log; with PolyORB.Security.Exported_Names.Unknown; with PolyORB.Utils.Chained_Lists; package body PolyORB.Security.Exported_Names is use Ada.Streams; use PolyORB.Log; package L is new PolyORB.Log.Facility_Log ("polyorb.security.exported_names"); procedure O (Message : String; Level : Log_Level := Debug) renames L.Output; function C (Level : Log_Level := Debug) return Boolean renames L.Enabled; type Registry_Item is record Mechanism_OID : PolyORB.ASN1.Object_Identifier; Factory : Empty_Exported_Name_Factory; end record; package Registry_Item_Lists is new PolyORB.Utils.Chained_Lists (Registry_Item); Registry : Registry_Item_Lists.List; ------------ -- Decode -- ------------ procedure Decode (Item : Ada.Streams.Stream_Element_Array; Name : out Exported_Name_Access; Error : in out PolyORB.Errors.Error_Container) is use PolyORB.Errors; use type PolyORB.ASN1.Object_Identifier; OID_Length : Stream_Element_Offset; BLOB_Length : Stream_Element_Offset; OID : PolyORB.ASN1.Object_Identifier; begin -- Check minimum data length and token identifier if Item'Length < 2 + 2 + 4 -- token identifier, OID length, BLOB length or else Item (Item'First) /= 16#04# or else Item (Item'First + 1) /= 16#01# then Throw (Error, Marshal_E, System_Exception_Members'(Minor => 0, Completed => Completed_No)); return; end if; -- Calculate OID length OID_Length := Stream_Element_Offset (Item (Item'First + 2)) * 2**8 + Stream_Element_Offset (Item (Item'First + 3)); -- Check is data amount enought to contents BLOB length if 2 + 2 + OID_Length + 4 - 1 > Item'Length then Throw (Error, Marshal_E, System_Exception_Members'(Minor => 0, Completed => Completed_No)); return; end if; -- Calculate BLOB length BLOB_Length := Stream_Element_Offset (Item (Item'First + OID_Length + 4)) * 2**24 + Stream_Element_Offset (Item (Item'First + OID_Length + 5)) * 2**16 + Stream_Element_Offset (Item (Item'First + OID_Length + 6)) * 2**8 + Stream_Element_Offset (Item (Item'First + OID_Length + 7)); -- Check is total amount of data same with encoded value if 2 + 2 + OID_Length + 4 + BLOB_Length /= Item'Length then Throw (Error, Marshal_E, System_Exception_Members'(Minor => 0, Completed => Completed_No)); return; end if; -- Decode mechanism OID begin OID := PolyORB.ASN1.Decode (Item (Item'First + 4 .. Item'First + OID_Length + 3)); exception when PolyORB.ASN1.ASN1_Error => Throw (Error, Marshal_E, System_Exception_Members' (Minor => 0, Completed => Completed_No)); return; end; -- Construct empty Exported Name. If Exported Name is unknown, then -- create unknown Exported Name for represent value. declare use Registry_Item_Lists; Iter : Iterator := First (Registry); begin while not Last (Iter) loop if PolyORB.ASN1.Is_Equivalent (Value (Iter).Mechanism_OID, OID) then Name := Value (Iter).Factory.all; exit; end if; Next (Iter); end loop; end; if Name = null then pragma Debug (C, O ("(Decode) Unknown exported name mechanism: " & PolyORB.ASN1.To_String (OID))); Name := new Unknown.Unknown_Exported_Name_Type; end if; -- Setup internal mechanism OID Name.Mechanism_OID := OID; -- Decode name BLOB Decode_Name_BLOB (Name, Item (Item'First + OID_Length + 8 .. Item'Last), Error); if Found (Error) then Destroy (Name); return; end if; end Decode; ------------- -- Destroy -- ------------- procedure Destroy (Item : in out Exported_Name_Access) is procedure Free is new Ada.Unchecked_Deallocation (Exported_Name_Type'Class, Exported_Name_Access); begin if Item /= null then Release_Contents (Item); Free (Item); end if; end Destroy; ------------ -- Encode -- ------------ function Encode (Item : access Exported_Name_Type'Class) return Ada.Streams.Stream_Element_Array is OID : constant Stream_Element_Array := PolyORB.ASN1.Encode (Item.Mechanism_OID); Name : constant Stream_Element_Array := Encode_Name_BLOB (Item); Result : Stream_Element_Array (1 .. 2 + 2 + OID'Length + 4 + Name'Length); begin -- Token Identifier Result (1 .. 2) := 16#04# & 16#01#; -- Length of Mechanism OID Result (3 .. 4) := Stream_Element ((OID'Length / 2**8) mod 2**8) & Stream_Element (OID'Length mod 2**8); -- Mechanism OID Result (5 .. OID'Length + 4) := OID; -- Length of Name Result (OID'Length + 5 .. OID'Length + 8) := Stream_Element ((Name'Length / 2**24) mod 2**8) & Stream_Element ((Name'Length / 2**16) mod 2**8) & Stream_Element ((Name'Length / 2**8) mod 2**8) & Stream_Element (Name'Length mod 2**8); -- Name Result (OID'Length + 9 .. Result'Last) := Name; return Result; end Encode; ----------------------- -- Get_Mechanism_OID -- ----------------------- function Get_Mechanism_OID (Item : access Exported_Name_Type) return PolyORB.ASN1.Object_Identifier is begin return Item.Mechanism_OID; end Get_Mechanism_OID; -------------- -- Register -- -------------- procedure Register (Mechanism_OID : PolyORB.ASN1.Object_Identifier; Factory : Empty_Exported_Name_Factory) is begin pragma Debug (C, O ("Register exported name mechanism: " & PolyORB.ASN1.To_String (Mechanism_OID))); Registry_Item_Lists.Append (Registry, (Mechanism_OID, Factory)); end Register; ---------------------- -- Release_Contents -- ---------------------- procedure Release_Contents (Item : access Exported_Name_Type) is begin PolyORB.ASN1.Destroy (Item.Mechanism_OID); end Release_Contents; end PolyORB.Security.Exported_Names; polyorb-2.8~20110207.orig/src/security/polyorb-qos-clients_security.ads0000644000175000017500000001041211750740340025403 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . Q O S . C L I E N T S _ S E C U R I T Y -- -- -- -- S p e c -- -- -- -- Copyright (C) 2005-2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- Client Side CORBA CSI Version 2 Compound Mechanism Configuration with PolyORB.Annotations; with PolyORB.Security.Authentication_Mechanisms; with PolyORB.Security.Authority_Mechanisms; with PolyORB.Security.Transport_Mechanisms; with PolyORB.Security.Types; with PolyORB.Utils.Chained_Lists; package PolyORB.QoS.Clients_Security is type Client_Mechanism is limited record Stateful : Boolean; -- Client may establish stateful security context Transport : PolyORB.Security.Transport_Mechanisms. Client_Transport_Mechanism_Access; -- Authentication layer Authentication_Mechanism : PolyORB.Security.Authentication_Mechanisms. Client_Authentication_Mechanism_Access; Authentication_Required : Boolean; -- Attribute layer Identity_Assertion : Boolean; Authorities : PolyORB.Security.Authority_Mechanisms. Client_Authority_Mechanism_Lists.List; Delegation_Supported : Boolean; Delegation_Required : Boolean; Naming_Mechanisms : PolyORB.Security.Types.OID_Lists.List; Identity_Types : PolyORB.Security.Types.Identity_Token_Type; Notepad : PolyORB.Annotations.Notepad; end record; type Client_Mechanism_Access is access all Client_Mechanism; function Is_Protected (Mechanism : Client_Mechanism) return Boolean; function Target_Supports (Mechanism : Client_Mechanism) return PolyORB.Security.Types.Association_Options; function Target_Requires (Mechanism : Client_Mechanism) return PolyORB.Security.Types.Association_Options; package Client_Mechanism_Lists is new PolyORB.Utils.Chained_Lists (Client_Mechanism_Access); type QoS_Client_Security_Parameter is new QoS_Parameter (Compound_Security) with record Mechanisms : Client_Mechanism_Lists.List; -- List of available compound security mechanisms. end record; type QoS_Client_Security_Parameter_Access is access all QoS_Client_Security_Parameter; procedure Release_Contents (QoS : access QoS_Client_Security_Parameter); procedure Destroy (Mechanism : in out Client_Mechanism_Access); end PolyORB.QoS.Clients_Security; polyorb-2.8~20110207.orig/src/security/polyorb-security-credentials.adb0000644000175000017500000000764411750740340025351 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . S E C U R I T Y . C R E D E N T I A L S -- -- -- -- B o d y -- -- -- -- Copyright (C) 2005-2008, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with PolyORB.Log; with PolyORB.Types; with PolyORB.Utils.Chained_Lists; package body PolyORB.Security.Credentials is use PolyORB.Log; package L is new PolyORB.Log.Facility_Log ("polyorb.security.credentials"); procedure O (Message : String; Level : Log_Level := Debug) renames L.Output; function C (Level : Log_Level := Debug) return Boolean renames L.Enabled; type Credentials_Type_Info is record Credentials_Type : PolyORB.Types.String; Constructor : Credentials_Constructor; end record; package Credentials_Type_Info_Lists is new PolyORB.Utils.Chained_Lists (Credentials_Type_Info); Registry : Credentials_Type_Info_Lists.List; ------------------------ -- Create_Credentials -- ------------------------ function Create_Credentials (Credentials_Type : String; Section_Name : String) return Credentials_Ref'Class is use Credentials_Type_Info_Lists; use type PolyORB.Types.String; Result : Credentials_Ref; Aux : Credentials_Access := null; Iter : Iterator := First (Registry); begin while not Last (Iter) loop if Value (Iter).Credentials_Type = Credentials_Type then Aux := Value (Iter).Constructor (Section_Name); exit; end if; Next (Iter); end loop; Set (Result, PolyORB.Smart_Pointers.Entity_Ptr (Aux)); return Result; end Create_Credentials; -------------- -- Register -- -------------- procedure Register (Credentials_Type : String; Constructor : Credentials_Constructor) is use Credentials_Type_Info_Lists; begin pragma Debug (C, O ("Register credentials type: '" & Credentials_Type & ''')); Append (Registry, (PolyORB.Types.To_PolyORB_String (Credentials_Type), Constructor)); end Register; end PolyORB.Security.Credentials; polyorb-2.8~20110207.orig/src/security/polyorb-security.ads0000644000175000017500000000411311750740340023063 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . S E C U R I T Y -- -- -- -- S p e c -- -- -- -- Copyright (C) 2005-2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ package PolyORB.Security is pragma Pure; end PolyORB.Security; polyorb-2.8~20110207.orig/src/security/polyorb-qos-security_contexts.adb0000644000175000017500000004010711750740340025574 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . Q O S . S E C U R I T Y _ C O N T E X T S -- -- -- -- B o d y -- -- -- -- Copyright (C) 2005-2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with Ada.Streams; with Ada.Unchecked_Deallocation; with PolyORB.Buffers; with PolyORB.Errors; with PolyORB.Initialization; with PolyORB.QoS.Service_Contexts; with PolyORB.Representations.CDR.Common; with PolyORB.Utils.Strings; package body PolyORB.QoS.Security_Contexts is use PolyORB.Buffers; use PolyORB.Representations.CDR.Common; use PolyORB.Security.Authorization_Elements; use PolyORB.Security.Identities; use PolyORB.Security.Types; use PolyORB.Types; function To_SASContext_Service_Context (QoS : QoS_Parameter_Access) return PolyORB.QoS.Service_Contexts.Service_Context; -- Convert QoS parameter to GIOP Service Context function To_QoS_Security_Context_Parameter (SC : PolyORB.QoS.Service_Contexts.Service_Context) return QoS_Parameter_Access; -- Convert GIOP Service Context to QoS parameter procedure Initialize; ---------------- -- Initialize -- ---------------- procedure Initialize is begin -- Register QoS <=> Service Context convertors PolyORB.QoS.Service_Contexts.Register (Compound_Security, To_SASContext_Service_Context'Access); PolyORB.QoS.Service_Contexts.Register (PolyORB.QoS.Service_Contexts.SecurityAttributeService, To_QoS_Security_Context_Parameter'Access); end Initialize; ---------------------- -- Release_Contents -- ---------------------- procedure Release_Contents (QoS : access QoS_Security_Context_Parameter) is procedure Free is new Ada.Unchecked_Deallocation (Ada.Streams.Stream_Element_Array, PolyORB.Security.Types.Stream_Element_Array_Access); begin case QoS.Context_Kind is when Establish_Context => Release_Contents (QoS.Authorization_Token); Destroy (QoS.Identity_Token); Free (QoS.Client_Authentication_Token); when Complete_Establish_Context => Free (QoS.Final_Context_Token); when Context_Error => Free (QoS.Error_Token); when Message_In_Context => null; end case; end Release_Contents; --------------------------------------- -- To_QoS_Security_Context_Parameter -- --------------------------------------- function To_QoS_Security_Context_Parameter (SC : PolyORB.QoS.Service_Contexts.Service_Context) return QoS_Parameter_Access is use PolyORB.Errors; Buffer : aliased Buffer_Type; Error : Error_Container; pragma Warnings (Off); begin Decapsulate (SC.Context_Data, Buffer'Access); case Short'(Unmarshall (Buffer'Access)) is when 0 => declare Result : constant QoS_Security_Context_Parameter_Access := new QoS_Security_Context_Parameter (Establish_Context); Client_Context_Id : Context_Id; Authorization_Token : Authorization_Element_Lists.List; Length : Unsigned_Long; Element : Authorization_Element_Access; Identity : Identity_Access; Identity_Type : Identity_Token_Type; Authentication_Token : Stream_Element_Array_Access; begin Client_Context_Id := Context_Id (Unsigned_Long_Long'(Unmarshall (Buffer'Access))); -- Authorization Token Length := Unmarshall (Buffer'Access); for J in 1 .. Length loop declare The_Type : constant Element_Type := Element_Type (Unsigned_Long'(Unmarshall (Buffer'Access))); begin Authorization_Element_Lists.Append (Authorization_Token, Create (The_Type, Unmarshall (Buffer'Access))); end; end loop; -- Identity Token Identity_Type := Identity_Token_Type (Unsigned_Long'(Unmarshall (Buffer'Access))); case Identity_Type is when ITT_Absent | ITT_Anonymous => declare Aux : Boolean; begin Aux := Unmarshall (Buffer'Access); end; Create (Identity_Type, Ada.Streams.Stream_Element_Array'(1 .. 0 => 0), Identity, Error); when others => Create (Identity_Type, Unmarshall (Buffer'Access), Identity, Error); end case; if Found (Error) then raise Program_Error; end if; -- Client Authentication Token declare Aux : constant Ada.Streams.Stream_Element_Array := Unmarshall (Buffer'Access); begin if Aux'Length /= 0 then Authentication_Token := new Ada.Streams.Stream_Element_Array'(Aux); end if; end; Result.Client_Context_Id := Client_Context_Id; Result.Authorization_Token := Authorization_Token; Result.Identity_Token := Identity; Result.Client_Authentication_Token := Authentication_Token; return QoS_Parameter_Access (Result); -- WAG:5.03: This code cause Constraint_Error at caller side because -- value of Result.Kind is invalid. (See EA31-006 for more details) -- return -- new QoS_Security_Context_Parameter' -- (Context_Kind => Establish_Context, -- Client_Context_Id => Client_Context_Id, -- Client_Authentication_Token => Authentication_Token, -- Identity_Token => Identity, -- Authorization_Token => Authorization_Token); end; when 1 => declare Result : constant QoS_Security_Context_Parameter_Access := new QoS_Security_Context_Parameter (Complete_Establish_Context); Client_Context_Id : Context_Id; Context_Stateful : Boolean; Final_Token : Stream_Element_Array_Access := null; begin Client_Context_Id := Context_Id (Unsigned_Long_Long'(Unmarshall (Buffer'Access))); Context_Stateful := Unmarshall (Buffer'Access); declare Aux : constant Ada.Streams.Stream_Element_Array := Unmarshall (Buffer'Access); begin if Aux'Length /= 0 then Final_Token := new Ada.Streams.Stream_Element_Array'(Aux); end if; end; Result.Client_Context_Id := Client_Context_Id; Result.Context_Stateful := Context_Stateful; Result.Final_Context_Token := Final_Token; return QoS_Parameter_Access (Result); end; when 4 => declare Result : constant QoS_Security_Context_Parameter_Access := new QoS_Security_Context_Parameter (Context_Error); Client_Context_Id : Context_Id; Major_Status : Long; Minor_Status : Long; Error_Token : Stream_Element_Array_Access; begin Client_Context_Id := Context_Id (Unsigned_Long_Long'(Unmarshall (Buffer'Access))); Major_Status := Unmarshall (Buffer'Access); Minor_Status := Unmarshall (Buffer'Access); declare Aux : constant Ada.Streams.Stream_Element_Array := Unmarshall (Buffer'Access); begin if Aux'Length /= 0 then Error_Token := new Ada.Streams.Stream_Element_Array'(Aux); end if; end; Result.Client_Context_Id := Client_Context_Id; Result.Major_Status := Major_Status; Result.Minor_Status := Minor_Status; Result.Error_Token := Error_Token; return QoS_Parameter_Access (Result); end; when 5 => declare Result : constant QoS_Security_Context_Parameter_Access := new QoS_Security_Context_Parameter (Message_In_Context); Client_Context_Id : Context_Id; Discard_Context : Boolean; begin Client_Context_Id := Context_Id (Unsigned_Long_Long'(Unmarshall (Buffer'Access))); Discard_Context := Unmarshall (Buffer'Access); Result.Client_Context_Id := Client_Context_Id; Result.Discard_Context := Discard_Context; return QoS_Parameter_Access (Result); end; when others => raise Program_Error; end case; return null; end To_QoS_Security_Context_Parameter; ----------------------------------- -- To_SASContext_Service_Context -- ----------------------------------- function To_SASContext_Service_Context (QoS : QoS_Parameter_Access) return PolyORB.QoS.Service_Contexts.Service_Context is Result : PolyORB.QoS.Service_Contexts.Service_Context := (PolyORB.QoS.Service_Contexts.SecurityAttributeService, null); begin if QoS = null then return Result; end if; declare use PS.Authorization_Elements.Authorization_Element_Lists; SASContext : QoS_Security_Context_Parameter renames QoS_Security_Context_Parameter (QoS.all); Buffer : Buffer_Access := new Buffer_Type; begin Start_Encapsulation (Buffer); case SASContext.Context_Kind is when Establish_Context => Marshall (Buffer, Short (0)); Marshall (Buffer, Unsigned_Long_Long (SASContext.Client_Context_Id)); -- Authorization Token Marshall (Buffer, Unsigned_Long (Length (SASContext.Authorization_Token))); declare Iter : Iterator := First (SASContext.Authorization_Token); begin while not Last (Iter) loop Marshall (Buffer, Unsigned_Long (Get_Authorization_Element_Type (Value (Iter).all))); Marshall (Buffer, Encode (Value (Iter).all)); Next (Iter); end loop; end; -- Identity Token if SASContext.Identity_Token = null then Marshall (Buffer, Unsigned_Long (ITT_Absent)); Marshall (Buffer, True); elsif Get_Token_Type (SASContext.Identity_Token) = ITT_Anonymous then Marshall (Buffer, Unsigned_Long (ITT_Anonymous)); Marshall (Buffer, True); else Marshall (Buffer, Unsigned_Long (Get_Token_Type (SASContext.Identity_Token))); Marshall (Buffer, Encode (SASContext.Identity_Token)); end if; -- Client Authentication Token if SASContext.Client_Authentication_Token = null then Marshall (Buffer, Unsigned_Long (0)); else Marshall (Buffer, SASContext.Client_Authentication_Token.all); end if; when Complete_Establish_Context => Marshall (Buffer, Short (1)); Marshall (Buffer, Unsigned_Long_Long (SASContext.Client_Context_Id)); Marshall (Buffer, SASContext.Context_Stateful); if SASContext.Final_Context_Token /= null then Marshall (Buffer, SASContext.Final_Context_Token.all); else Marshall (Buffer, Ada.Streams.Stream_Element_Array'(1 .. 0 => 0)); end if; when Context_Error => Marshall (Buffer, Short (4)); Marshall (Buffer, Unsigned_Long_Long (SASContext.Client_Context_Id)); Marshall (Buffer, SASContext.Major_Status); Marshall (Buffer, SASContext.Minor_Status); if SASContext.Error_Token /= null then Marshall (Buffer, SASContext.Error_Token.all); else Marshall (Buffer, Ada.Streams.Stream_Element_Array'(1 .. 0 => 0)); end if; when Message_In_Context => Marshall (Buffer, Short (5)); Marshall (Buffer, Unsigned_Long_Long (SASContext.Client_Context_Id)); Marshall (Buffer, SASContext.Discard_Context); end case; Result.Context_Data := new Encapsulation'(Encapsulate (Buffer)); Release (Buffer); end; return Result; end To_SASContext_Service_Context; begin declare use PolyORB.Initialization; use PolyORB.Initialization.String_Lists; use PolyORB.Utils.Strings; begin Register_Module (Module_Info' (Name => +"polyorb.qos.security_contexts", Conflicts => Empty, Depends => Empty, Provides => Empty, Implicit => False, Init => Initialize'Access, Shutdown => null)); end; end PolyORB.QoS.Security_Contexts; polyorb-2.8~20110207.orig/src/security/tls/0000755000175000017500000000000011750740340017642 5ustar xavierxavierpolyorb-2.8~20110207.orig/src/security/tls/polyorb-utils-tls_access_points.ads0000644000175000017500000000572711750740340026707 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . U T I L S . T L S _ A C C E S S _ P O I N T S -- -- -- -- S p e c -- -- -- -- Copyright (C) 2005-2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- Helper subprograms to set up access points based on SSL sockets -- for a PolyORB server. with PolyORB.Binding_Data; with PolyORB.Sockets; with PolyORB.Transport; package PolyORB.Utils.TLS_Access_Points is ---------------------------------- -- Access_Point_Info descriptor -- ---------------------------------- type Access_Point_Info is record Socket : Sockets.Socket_Type; Address : Sockets.Sock_Addr_Type; SAP : Transport.Transport_Access_Point_Access; PF : Binding_Data.Profile_Factory_Access; end record; procedure Initialize_Socket (DAP : out Access_Point_Info; Address : Sockets.Inet_Addr_Type := Sockets.Any_Inet_Addr; Port_Hint : Sockets.Port_Type := Sockets.Any_Port); -- Initialize DAP.Socket and bind it to a free port, using one of -- the address corresponding to hostname, or use Address and -- Port_Hint if possible. end PolyORB.Utils.TLS_Access_Points; polyorb-2.8~20110207.orig/src/security/tls/polyorb-security-credentials-tls.adb0000644000175000017500000004437711750740340026757 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . S E C U R I T Y . C R E D E N T I A L S . T L S -- -- -- -- B o d y -- -- -- -- Copyright (C) 2005-2008, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- Notes: TLS credentials are usually useful at both accepting and -- invocation credentials. But, supported functionality are very -- dependent from credentials configuration. Following description -- describe most significant aspects of credentials configuration. -- -- Integrity: -- -- Confidentiality: -- -- Detect_Replay: Not supported. -- -- Detect_Misordering: Not supported. -- -- Establish_Trust_In_[Target/Client]: This function dependent from presence -- of own certificate/private key pair and trusted CA's certificates. -- -- If credentials have certificate/private key pair then it supports -- Establish_Trust_In_Client invocation association option and -- Establish_Trust_In_Target accepting association option. -- -- If credentials have list of trusted CA's certificates then it supports -- Establish_Trust_In_Target invocation association option and -- Establish_Trust_In_Client accepting association option. with Ada.Strings.Fixed; with PolyORB.Initialization; with PolyORB.Parameters; with PolyORB.Security.Identities.Distinguished_Name; with PolyORB.Utils.Strings; package body PolyORB.Security.Credentials.TLS is use PolyORB.Errors; use PolyORB.Parameters; use PolyORB.Security.Identities.Distinguished_Name; use PolyORB.Security.Types; use PolyORB.TLS; use PolyORB.Types; use PolyORB.X509; function Create_Credentials (Section_Name : String) return Credentials_Access; procedure Initialize; ----------------------------- -- Create_Accepting_Socket -- ----------------------------- function Create_Accepting_Socket (Self : access TLS_Credentials) return PolyORB.TLS.TLS_Socket_Type is begin return Create (Self.Context); end Create_Accepting_Socket; ------------------------ -- Create_Credentials -- ------------------------ function Create_Credentials (Section_Name : String) return Credentials_Access is Method_Name : constant String := Get_Conf (Section_Name, "tls.method", "any"); Certificate_File : constant String := Get_Conf (Section_Name, "tls.certificate_file", ""); Certificate_Chain_File : constant String := Get_Conf (Section_Name, "tls.certificate_chain_file", ""); Private_Key_File : constant String := Get_Conf (Section_Name, "tls.private_key_file", ""); Certificate_Authority_File : constant String := Get_Conf (Section_Name, "tls.certificate_authority_file", ""); Certificate_Authority_Path : constant String := Get_Conf (Section_Name, "tls.certificate_authority_path", ""); Ciphers : constant String := Get_Conf (Section_Name, "tls.ciphers", ""); Verify_Peer : constant Boolean := Get_Conf (Section_Name, "tls.verify_peer", False); Verify_Fail_If_No_Peer_Cert : constant Boolean := Get_Conf (Section_Name, "tls.verify_fail_if_no_peer_certificate", False); Error : Error_Container; Result : TLS_Credentials_Access; begin Create_TLS_Credentials (Credentials => Result, Error => Error, Method_Name => Method_Name, Private_Key_File => Private_Key_File, Certificate_File => Certificate_File, Certificate_Chain_File => Certificate_Chain_File, Certificate_Authority_File => Certificate_Authority_File, Certificate_Authority_Path => Certificate_Authority_Path, Ciphers => Ciphers, Verify_Peer => Verify_Peer, Verify_Fail_If_No_Peer_Certificate => Verify_Fail_If_No_Peer_Cert); if Found (Error) then raise Program_Error; end if; return Credentials_Access (Result); end Create_Credentials; ------------------------------ -- Create_Invocation_Socket -- ------------------------------ function Create_Invocation_Socket (Self : access TLS_Credentials) return PolyORB.TLS.TLS_Socket_Type is begin return Create (Self.Context); end Create_Invocation_Socket; --------------------------------- -- Create_Peer_TLS_Credentials -- --------------------------------- function Create_Peer_TLS_Credentials (Socket : PolyORB.TLS.TLS_Socket_Type) return Credentials_Ref is Result : Credentials_Ref; Aux : constant TLS_Credentials_Access := new TLS_Credentials (False); begin Aux.Certificate := Peer_Certificate_Of (Socket); Set (Result, PolyORB.Smart_Pointers.Entity_Ptr (Aux)); return Result; end Create_Peer_TLS_Credentials; ---------------------------- -- Create_TLS_Credentials -- ---------------------------- procedure Create_TLS_Credentials (Credentials : out TLS_Credentials_Access; Error : in out PolyORB.Errors.Error_Container; Method_Name : String := ""; Private_Key_File : String := ""; Certificate_File : String := ""; Certificate_Chain_File : String := ""; Certificate_Authority_File : String := ""; Certificate_Authority_Path : String := ""; Ciphers : String := ""; Verify_Peer : Boolean := False; Verify_Fail_If_No_Peer_Certificate : Boolean := False) is Method : TLS_Method_Type; Mode : TLS_Verification_Mode := (others => False); begin if Method_Name = "" or else Method_Name = "any" then Method := Any; elsif Method_Name = "tls1" then Method := TLS_1; elsif Method_Name = "ssl3" then Method := SSL_3; elsif Method_Name = "ssl2" then Method := SSL_2; else Throw (Error, Bad_Param_E, System_Exception_Members'(0, Completed_No)); end if; Credentials := new TLS_Credentials (True); Credentials.Context := Create (Method); -- Loading CA's certificates if Certificate_Authority_File /= "" or else Certificate_Authority_Path /= "" then Load_Verify_Locations (Credentials.Context, Certificate_Authority_File, Certificate_Authority_Path); Credentials.CA_Defined := True; end if; -- Load owner's certificate and private key if Private_Key_File /= "" or else Certificate_File /= "" or else Certificate_Chain_File /= "" then Use_Private_Key (Credentials.Context, Private_Key_File); if Certificate_Chain_File /= "" then -- XXX Certificate member should be defined! Use_Certificate_Chain (Credentials.Context, Certificate_Chain_File); else Credentials.Certificate := Read (Certificate_File); Use_Certificate (Credentials.Context, Credentials.Certificate); end if; Check_Private_Key (Credentials.Context); Credentials.Cert_Defined := True; end if; -- Setup ciphers list if Ciphers /= "" then Set_Cipher_List (Credentials.Context, Ciphers); Credentials.Ciphers := To_PolyORB_String (Ciphers); end if; -- Setup verification mode if Verify_Peer then Mode (Peer) := True; if Verify_Fail_If_No_Peer_Certificate then Mode (Fail_If_No_Peer_Certificate) := True; end if; end if; Set_Verify_Mode (Credentials.Context, Mode); -- Calculate Association Options -- Detect supported and required security assocations by -- review of descriptions of available ciphers (conformant -- with CORBA 3.0 paragraph 24.5.1.3 TAG_TLS_SEC_TRANS) -- -- The following algorithm are used: -- -- Integrity: -- Supported - one of ciphers have not None Mac parameter -- Required - all of ciphers have not None Mac parameter -- -- Confidentiality: -- Supported - one of chipers have not None Enc parameter -- Required - all of ciphers have not None Enc parameter -- -- Establish_Trust_In_Target: -- Supported - one of ciphers have not None Au parameter -- Required - always false -- -- Establish_Trust_In_Client: -- Supported - verify mode is SSL_VERIFY_PEER but not -- SSL_VERIFY_FAIL_IF_NO_PEER_CERT -- Required - both SSL_VERIFY_PEER and -- SSL_VERIFY_FAIL_IF_NO_PEER_CERT are enabled declare function Is_None (Description : String; Parameter : String) return Boolean; -- Check is a Parameter have None value or not present -- in Description ------------- -- Is_None -- ------------- function Is_None (Description : String; Parameter : String) return Boolean is None : constant String := "None"; Pos : constant Natural := Ada.Strings.Fixed.Index (Description, Parameter & '=') + Parameter'Length + 1; begin -- Check if a parameter is present in description if Pos <= Parameter'Length then return False; end if; -- Check the length of parameter value less whan None if Description'Last < Pos + None'Length then return True; end if; return Description (Pos .. Pos + None'Length - 1) = None; end Is_None; List : constant TLS_Cipher_List := Ciphers_Of (Credentials.Context); Integrity_Supported : Boolean := False; Integrity_Required : Boolean := True; Confidentiality_Supported : Boolean := False; Confidentiality_Required : Boolean := True; Authentication_Supported : Boolean := False; Authentication_Required : Boolean := True; pragma Warnings (Off, Authentication_Required); -- XXX Should be investigated!!! begin for J in List'Range loop declare Desc : constant String := Description_Of (List (J)); begin -- Compute Integrity option if Is_None (Desc, "Mac") then Integrity_Required := False; else Integrity_Supported := True; end if; -- Compute Confidentiality option if Is_None (Desc, "Enc") then Confidentiality_Required := False; else Confidentiality_Supported := True; end if; -- Compute Authentication option if Is_None (Desc, "Au") then Authentication_Required := False; else Authentication_Supported := True; end if; end; end loop; if Integrity_Supported then Credentials.Accepting_Supports := Credentials.Accepting_Supports or Integrity; Credentials.Invocation_Supports := Credentials.Invocation_Supports or Integrity; if Integrity_Required then Credentials.Accepting_Requires := Credentials.Accepting_Requires or Integrity; Credentials.Invocation_Requires := Credentials.Invocation_Requires or Integrity; end if; end if; if Confidentiality_Supported then Credentials.Accepting_Supports := Credentials.Accepting_Supports or Confidentiality; Credentials.Invocation_Supports := Credentials.Invocation_Supports or Confidentiality; if Confidentiality_Required then Credentials.Accepting_Requires := Credentials.Accepting_Requires or Confidentiality; Credentials.Invocation_Requires := Credentials.Invocation_Requires or Confidentiality; end if; end if; -- XXX Following code should be reviewed. It incorrectly handle -- some configurations. Also, it is possible to raise Bad_Param -- in some situations. if Authentication_Supported then if Credentials.Cert_Defined then Credentials.Accepting_Supports := Credentials.Accepting_Supports or Establish_Trust_In_Target; Credentials.Invocation_Supports := Credentials.Invocation_Supports or Establish_Trust_In_Client; end if; if Credentials.CA_Defined then if Mode (Peer) then Credentials.Accepting_Supports := Credentials.Accepting_Supports or Establish_Trust_In_Client; Credentials.Invocation_Supports := Credentials.Invocation_Supports or Establish_Trust_In_Target; if Mode (Fail_If_No_Peer_Certificate) then Credentials.Accepting_Requires := Credentials.Accepting_Requires or Establish_Trust_In_Client; end if; end if; end if; end if; end; exception when TLS_Error => Throw (Error, Bad_Param_E, System_Exception_Members'(0, Completed_No)); end Create_TLS_Credentials; -------------- -- Finalize -- -------------- procedure Finalize (Self : in out TLS_Credentials) is begin Destroy (Self.Certificate); if Self.Own then Destroy (Self.Context); end if; end Finalize; ------------------------------------ -- Get_Accepting_Options_Required -- ------------------------------------ function Get_Accepting_Options_Required (Self : access TLS_Credentials) return PolyORB.Security.Types.Association_Options is begin return Self.Accepting_Requires; end Get_Accepting_Options_Required; ------------------------------------- -- Get_Accepting_Options_Supported -- ------------------------------------- function Get_Accepting_Options_Supported (Self : access TLS_Credentials) return PolyORB.Security.Types.Association_Options is begin return Self.Accepting_Supports; end Get_Accepting_Options_Supported; ------------------ -- Get_Identity -- ------------------ function Get_Identity (Self : access TLS_Credentials) return PolyORB.Security.Identities.Identity_Access is begin return Create (Duplicate (Subject_Name_Of (Self.Certificate))); end Get_Identity; ------------------------------------- -- Get_Invocation_Options_Required -- ------------------------------------- function Get_Invocation_Options_Required (Self : access TLS_Credentials) return PolyORB.Security.Types.Association_Options is begin return Self.Invocation_Requires; end Get_Invocation_Options_Required; -------------------------------------- -- Get_Invocation_Options_Supported -- -------------------------------------- function Get_Invocation_Options_Supported (Self : access TLS_Credentials) return PolyORB.Security.Types.Association_Options is begin return Self.Invocation_Supports; end Get_Invocation_Options_Supported; ---------------- -- Initialize -- ---------------- procedure Initialize is begin Register ("tls", Create_Credentials'Access); end Initialize; begin declare use PolyORB.Initialization; use PolyORB.Initialization.String_Lists; use PolyORB.Utils.Strings; begin Register_Module (Module_Info' (Name => +"polyorb.security.credentials.tls", Conflicts => Empty, Depends => +"tls", Provides => Empty, Implicit => False, Init => Initialize'Access, Shutdown => null)); end; end PolyORB.Security.Credentials.TLS; polyorb-2.8~20110207.orig/src/security/tls/polyorb-utils-tls_access_points.adb0000644000175000017500000000735311750740340026663 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . U T I L S . T L S _ A C C E S S _ P O I N T S -- -- -- -- B o d y -- -- -- -- Copyright (C) 2005-2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with PolyORB.Components; with PolyORB.Setup; -- with PolyORB.TLS; with PolyORB.Transport.Connected.Sockets.TLS; package body PolyORB.Utils.TLS_Access_Points is use PolyORB.Binding_Data; use PolyORB.Sockets; -- use PolyORB.TLS; use PolyORB.Transport; use PolyORB.Transport.Connected.Sockets.TLS; ----------------------- -- Initialize_Socket -- ----------------------- procedure Initialize_Socket (DAP : out Access_Point_Info; Address : Inet_Addr_Type := Any_Inet_Addr; Port_Hint : Port_Type := Any_Port) is Port : Port_Type := Port_Hint; begin Create_Socket (DAP.Socket); DAP.Address := Sock_Addr_Type'(Addr => Address, Port => Port, Family => Family_Inet); -- Allow reuse of local addresses Set_Socket_Option (DAP.Socket, Socket_Level, (Reuse_Address, True)); if DAP.SAP = null then DAP.SAP := new TLS_Access_Point; end if; loop DAP.Address.Port := Port; begin Create (TLS_Access_Point (DAP.SAP.all), DAP.Socket, DAP.Address); exit; exception when Sockets.Socket_Error => Port := Port + 1; if Port = Port_Hint then raise; -- Argh! we tried every possible value and -- wrapped. Bail out. end if; end; end loop; if DAP.PF /= null then Create_Factory (DAP.PF.all, DAP.SAP, Components.Component_Access (Setup.The_ORB)); end if; end Initialize_Socket; end PolyORB.Utils.TLS_Access_Points; polyorb-2.8~20110207.orig/src/security/tls/polyorb-tls.ads0000644000175000017500000001770711750740340022635 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . T L S -- -- -- -- S p e c -- -- -- -- Copyright (C) 2005-2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- A binding for the OpenSSL library with Ada.Streams; with PolyORB.Sockets; with PolyORB.X509; package PolyORB.TLS is type TLS_Method_Type is (SSL_2, SSL_2_Client, SSL_2_Server, SSL_3, SSL_3_Client, SSL_3_Server, TLS_1, TLS_1_Client, TLS_1_Server, Any, Any_Client, Any_Server); type TLS_Verification_Mode_Flag is (Peer, Fail_If_No_Peer_Certificate, Client_Once); type TLS_Verification_Mode is array (TLS_Verification_Mode_Flag) of Boolean; type TLS_Context_Type is private; type TLS_Cipher_Type is private; No_TLS_Cipher : constant TLS_Cipher_Type; type TLS_Cipher_List is array (Positive range <>) of TLS_Cipher_Type; type TLS_Socket_Type is private; No_TLS_Socket : constant TLS_Socket_Type; TLS_Error : exception; ---------------------------- -- TLS context operations -- ---------------------------- function Create (Method : TLS_Method_Type) return TLS_Context_Type; -- Create a new context with specified Method. Raise TLS_Error on -- any error. procedure Destroy (Context : in out TLS_Context_Type); -- Destroy context procedure Use_Certificate (Context : TLS_Context_Type; File_Name : String); -- Loads certificate from file into context. Raise TLS_Error on any error. procedure Use_Certificate (Context : TLS_Context_Type; Certificate : PolyORB.X509.Certificate); -- Loads certificate into context. Raise TLS_Error on any error. procedure Use_Certificate_Chain (Context : TLS_Context_Type; File_Name : String); -- Loads certificate chain from file into context. Raise TLS_Error on any -- error. procedure Use_Private_Key (Context : TLS_Context_Type; File_Name : String); -- Add private key found in file to context. Raise TLS_Error on any error. procedure Check_Private_Key (Context : TLS_Context_Type); -- Check the consistency of a private key with the corresponding -- certificate loaded into context. Raise TLS_Error on any error. procedure Load_Verify_Locations (Context : TLS_Context_Type; Certificate_Authority_File : String; Certificate_Authority_Path : String); -- Specify the location for context, at which Certificate Authority -- certificates for verification purposes are located. Raise TLS_Error -- on any error. procedure Set_Verify_Mode (Context : TLS_Context_Type; Mode : TLS_Verification_Mode); -- Sets the verification flags for context procedure Set_Cipher_List (Context : TLS_Context_Type; Ciphers : String); -- Sets the list of available ciphers for context. Raise TLS_Error on -- complete failure (no available ciphers at all). function Ciphers_Of (Context : TLS_Context_Type) return TLS_Cipher_List; -- Returns list of available ciphers --------------------------- -- TLS cipher operations -- --------------------------- function Description_Of (Cipher : TLS_Cipher_Type) return String; -- Returns a textual description of the cipher --------------------------- -- TLS socket operations -- --------------------------- function Create (Context : TLS_Context_Type) return TLS_Socket_Type; -- Create new structure for SSL/TLS connection procedure Destroy (Socket : in out TLS_Socket_Type); -- Destroy connection function Cipher_Of (Socket : TLS_Socket_Type; Priority : Natural) return String; -- Returns the name of cipher listed for Socket with Priority. Returns -- an empty string if no cipher with Priority available. function Ciphers_Of (Socket : TLS_Socket_Type) return TLS_Cipher_List; -- Returns list of available ciphers function Socket_Of (Socket : TLS_Socket_Type) return Sockets.Socket_Type; -- Return the underlying socket for the given SSL connection procedure Set_Socket (Socket : TLS_Socket_Type; Sock : Sockets.Socket_Type); -- Set Sock as input/output facility. Raise TLS_Error on any error. procedure Connect_Socket (Socket : TLS_Socket_Type); -- Initiates the TLS/SSL handshake with a server. Raise TLS_Error on -- any error. procedure Accept_Socket (Socket : TLS_Socket_Type); -- Waits for a TLS/SSL client to initiate the TLS/SSL handshake. -- Raise TLS_Error on any error. procedure Close_Socket (Socket : in out TLS_Socket_Type); -- function Peer_Certificate_Of (Socket : TLS_Socket_Type) return PolyORB.X509.Certificate; -- Returns a X.509 certificate the peer present. Returned ceritificate -- should be freed by caller. function Pending_Length (Socket : TLS_Socket_Type) return Natural; -- Return number of readable bytes buffered in Socket procedure Receive_Vector (Socket : TLS_Socket_Type; Vector : Sockets.Vector_Type; Count : out Ada.Streams.Stream_Element_Count); -- Receive data from a socket and scatter it into the set of vector -- elements Vector. Count is set to the count of received stream elements. -- Raise TLS_Error on SSL socket error. procedure Send_Vector (Socket : TLS_Socket_Type; Vector : Sockets.Vector_Type; Count : out Ada.Streams.Stream_Element_Count); -- Transmit data gathered from the set of vector elements Vector to a -- socket. Count is set to the count of transmitted stream elements. -- Raise TLS_Error on SSL socket error. private -- TLS Context type TLS_Context_Record is null record; pragma Convention (C, TLS_Context_Record); type TLS_Context_Type is access all TLS_Context_Record; -- TLS Cipher type TLS_Cipher_Record is null record; pragma Convention (C, TLS_Cipher_Record); type TLS_Cipher_Type is access all TLS_Cipher_Record; No_TLS_Cipher : constant TLS_Cipher_Type := null; -- TLS Socket type TLS_Socket_Record is null record; pragma Convention (C, TLS_Socket_Record); type TLS_Socket_Type is access all TLS_Socket_Record; No_TLS_Socket : constant TLS_Socket_Type := null; end PolyORB.TLS; polyorb-2.8~20110207.orig/src/security/tls/polyorb-asynch_ev-sockets-tls.ads0000644000175000017500000000613511750740340026254 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . A S Y N C H _ E V . S O C K E T S . T L S -- -- -- -- S p e c -- -- -- -- Copyright (C) 2005-2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- An asynchrous event source that is a set of SSL sockets. with PolyORB.TLS; package PolyORB.Asynch_Ev.Sockets.TLS is pragma Elaborate_Body; type TLS_Event_Monitor is new Socket_Event_Monitor with private; type TLS_Event_Source is new Socket_Event_Source with private; procedure Register_Source (AEM : access TLS_Event_Monitor; AES : Asynch_Ev_Source_Access; Success : out Boolean); function Check_Sources (AEM : access TLS_Event_Monitor; Timeout : Duration) return AES_Array; function Create_Event_Source (Socket : PolyORB.TLS.TLS_Socket_Type) return Asynch_Ev_Source_Access; function Create_Event_Source (Socket : PolyORB.Sockets.Socket_Type) return Asynch_Ev_Source_Access; function AEM_Factory_Of (AES : TLS_Event_Source) return AEM_Factory; private type TLS_Event_Source is new Socket_Event_Source with record TLS_Socket : PolyORB.TLS.TLS_Socket_Type; end record; type TLS_Event_Monitor is new Socket_Event_Monitor with null record; end PolyORB.Asynch_Ev.Sockets.TLS; polyorb-2.8~20110207.orig/src/security/tls/polyorb-asynch_ev-sockets-tls.adb0000644000175000017500000001456311750740340026237 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . A S Y N C H _ E V . S O C K E T S . T L S -- -- -- -- B o d y -- -- -- -- Copyright (C) 2005-2009, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with PolyORB.Log; package body PolyORB.Asynch_Ev.Sockets.TLS is use PolyORB.Log; use PolyORB.Sockets; use PolyORB.TLS; package L is new PolyORB.Log.Facility_Log ("polyorb.asynch_ev.sockets.tls"); procedure O (Message : String; Level : Log_Level := Debug) renames L.Output; function C (Level : Log_Level := Debug) return Boolean renames L.Enabled; type Socket_Event_Monitor_Access is access all Socket_Event_Monitor; function Create_TLS_Event_Monitor return Asynch_Ev_Monitor_Access; -------------------- -- AEM_Factory_Of -- -------------------- function AEM_Factory_Of (AES : TLS_Event_Source) return AEM_Factory is pragma Unreferenced (AES); begin return Create_TLS_Event_Monitor'Access; end AEM_Factory_Of; ------------------- -- Check_Sources -- ------------------- function Check_Sources (AEM : access TLS_Event_Monitor; Timeout : Duration) return AES_Array is use Source_Lists; Result : AES_Array (1 .. Length (AEM.Sources)); Last : Integer := 0; begin pragma Debug (C, O ("Check_Sources: enter")); -- SSL transport may cache data in the internal buffer, so if cached -- data available then adding event source to the result declare Iter : Iterator := First (AEM.Sources); begin while not Source_Lists.Last (Iter) loop if TLS_Event_Source (Value (Iter).all).TLS_Socket /= No_TLS_Socket and then Pending_Length (TLS_Event_Source (Value (Iter).all).TLS_Socket) /= 0 then Last := Last + 1; Result (Last) := Asynch_Ev_Source_Access (Value (Iter)); Clear (AEM.Monitored_Set, TLS_Event_Source (Value (Iter).all).Socket); Remove (AEM.Sources, Iter); else Next (Iter); end if; end loop; end; -- If at least one event source have cached data, then immediately -- return (because checking of sockets may produce time delay), -- otherwise, call Socket's Check_Sources for check sockets state -- changes if Last /= 0 then return Result (1 .. Last); else return Check_Sources (Socket_Event_Monitor_Access (AEM), Timeout); end if; end Check_Sources; ------------------------- -- Create_Event_Source -- ------------------------- function Create_Event_Source (Socket : PolyORB.TLS.TLS_Socket_Type) return Asynch_Ev_Source_Access is Result : constant Asynch_Ev_Source_Access := new TLS_Event_Source; begin TLS_Event_Source (Result.all).TLS_Socket := Socket; TLS_Event_Source (Result.all).Socket := Socket_Of (Socket); return Result; end Create_Event_Source; function Create_Event_Source (Socket : PolyORB.Sockets.Socket_Type) return Asynch_Ev_Source_Access is Result : constant Asynch_Ev_Source_Access := new TLS_Event_Source; begin TLS_Event_Source (Result.all).TLS_Socket := No_TLS_Socket; TLS_Event_Source (Result.all).Socket := Socket; return Result; end Create_Event_Source; ------------------------------ -- Create_TLS_Event_Monitor -- ------------------------------ function Create_TLS_Event_Monitor return Asynch_Ev_Monitor_Access is begin return new TLS_Event_Monitor; end Create_TLS_Event_Monitor; --------------------- -- Register_Source -- --------------------- procedure Register_Source (AEM : access TLS_Event_Monitor; AES : Asynch_Ev_Source_Access; Success : out Boolean) is begin pragma Debug (C, O ("Register_Source: enter")); Success := False; if AES.all not in TLS_Event_Source then pragma Debug (C, O ("Register_Source: leave")); return; end if; Set (AEM.Monitored_Set, TLS_Event_Source (AES.all).Socket); Source_Lists.Append (AEM.Sources, Socket_Event_Source (AES.all)'Access); pragma Debug (C, O ("Register_Source: Sources'Length:=" & Integer'Image (Source_Lists.Length (AEM.Sources)))); AES.Monitor := Asynch_Ev_Monitor_Access (AEM); Success := True; pragma Debug (C, O ("Register_Source: leave")); end Register_Source; end PolyORB.Asynch_Ev.Sockets.TLS; polyorb-2.8~20110207.orig/src/security/tls/polyorb-security-credentials-tls.ads0000644000175000017500000001177711750740340026776 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . S E C U R I T Y . C R E D E N T I A L S . T L S -- -- -- -- S p e c -- -- -- -- Copyright (C) 2005-2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with PolyORB.Errors; with PolyORB.TLS; with PolyORB.Types; with PolyORB.X509; package PolyORB.Security.Credentials.TLS is type TLS_Credentials (<>) is new Credentials with private; type TLS_Credentials_Access is access all TLS_Credentials'Class; procedure Create_TLS_Credentials (Credentials : out TLS_Credentials_Access; Error : in out PolyORB.Errors.Error_Container; Method_Name : String := ""; Private_Key_File : String := ""; Certificate_File : String := ""; Certificate_Chain_File : String := ""; Certificate_Authority_File : String := ""; Certificate_Authority_Path : String := ""; Ciphers : String := ""; Verify_Peer : Boolean := False; Verify_Fail_If_No_Peer_Certificate : Boolean := False); function Create_Peer_TLS_Credentials (Socket : PolyORB.TLS.TLS_Socket_Type) return Credentials_Ref; function Create_Invocation_Socket (Self : access TLS_Credentials) return PolyORB.TLS.TLS_Socket_Type; function Create_Accepting_Socket (Self : access TLS_Credentials) return PolyORB.TLS.TLS_Socket_Type; private type TLS_Credentials (Own : Boolean) is new Credentials with record Certificate : PolyORB.X509.Certificate; case Own is when True => Context : PolyORB.TLS.TLS_Context_Type; Ciphers : PolyORB.Types.String; Cert_Defined : Boolean := False; CA_Defined : Boolean := False; Accepting_Supports : PolyORB.Security.Types.Association_Options := 0; Accepting_Requires : PolyORB.Security.Types.Association_Options := 0; Invocation_Supports : PolyORB.Security.Types.Association_Options := 0; Invocation_Requires : PolyORB.Security.Types.Association_Options := 0; when False => null; end case; end record; -- Derived from Credentials function Get_Accepting_Options_Supported (Self : access TLS_Credentials) return PolyORB.Security.Types.Association_Options; function Get_Accepting_Options_Required (Self : access TLS_Credentials) return PolyORB.Security.Types.Association_Options; function Get_Invocation_Options_Supported (Self : access TLS_Credentials) return PolyORB.Security.Types.Association_Options; function Get_Invocation_Options_Required (Self : access TLS_Credentials) return PolyORB.Security.Types.Association_Options; function Get_Identity (Self : access TLS_Credentials) return PolyORB.Security.Identities.Identity_Access; -- Derived from Entity procedure Finalize (Self : in out TLS_Credentials); end PolyORB.Security.Credentials.TLS; polyorb-2.8~20110207.orig/src/security/tls/polyorb-transport-connected-sockets-tls.adb0000644000175000017500000003012311750740340030242 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- POLYORB.TRANSPORT.CONNECTED.SOCKETS.TLS -- -- -- -- B o d y -- -- -- -- Copyright (C) 2005-2008, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with Ada.Exceptions; with System.Storage_Elements; with PolyORB.Asynch_Ev.Sockets.TLS; with PolyORB.Log; with PolyORB.QoS.Transport_Contexts; with PolyORB.Security.Credentials.Compound; with PolyORB.Security.Credentials.TLS; package body PolyORB.Transport.Connected.Sockets.TLS is use PolyORB.Asynch_Ev.Sockets.TLS; use PolyORB.Log; use PolyORB.QoS; use PolyORB.QoS.Transport_Contexts; use PolyORB.Security.Credentials; use PolyORB.Security.Credentials.Compound; use PolyORB.Security.Credentials.TLS; use PolyORB.Security.Transport_Mechanisms; use PolyORB.TLS; use PolyORB.Transport; use PolyORB.Tasking.Mutexes; package L is new PolyORB.Log.Facility_Log ("polyorb.transport.connected.sockets.tls"); procedure O (Message : String; Level : Log.Log_Level := Log.Debug) renames L.Output; function C (Level : Log_Level := Debug) return Boolean renames L.Enabled; function Extract_TLS_Credentials (Credentials : Credentials_Ref) return TLS_Credentials_Access; ----------------------- -- Accept_Connection -- ----------------------- procedure Accept_Connection (TAP : TLS_Access_Point; TE : out Transport_Endpoint_Access) is New_Socket : Socket_Type; TLS_Socket : TLS_Socket_Type := Create_Accepting_Socket (Extract_TLS_Credentials (TAP.Credentials)); New_Address : Sock_Addr_Type; begin Accept_Socket (TAP.Socket, New_Socket, New_Address); Set_Socket (TLS_Socket, New_Socket); Accept_Socket (TLS_Socket); TE := new TLS_Endpoint; Create (TLS_Endpoint (TE.all), TLS_Socket, TAP.Transport, TAP.Credentials); exception when Socket_Error | TLS_Error => Close_Socket (TLS_Socket); end Accept_Connection; ----------- -- Close -- ----------- procedure Close (TE : access TLS_Endpoint) is begin if TE.Closed then return; end if; Enter (TE.Mutex); begin PolyORB.Transport.Connected.Close (Connected_Transport_Endpoint (TE.all)'Access); if TE.TLS_Socket /= No_TLS_Socket then pragma Debug (C, O ("Closing socket" & PolyORB.Sockets.Image (TE.Socket))); Close_Socket (TE.TLS_Socket); pragma Debug (C, O ("Closed socket" & PolyORB.Sockets.Image (TE.Socket))); TE.TLS_Socket := No_TLS_Socket; TE.Socket := No_Socket; end if; Leave (TE.Mutex); exception when E : others => pragma Debug (C, O ("Close (Socket_Endpoint): got " & Ada.Exceptions.Exception_Information (E))); null; end; end Close; ------------ -- Create -- ------------ procedure Create (TE : in out TLS_Endpoint; S : TLS_Socket_Type) is begin Create (Socket_Endpoint (TE), Socket_Of (S)); TE.TLS_Socket := S; end Create; procedure Create (TE : in out TLS_Endpoint; S : TLS_Socket_Type; Mechanism : PolyORB.Security.Transport_Mechanisms.Target_Transport_Mechanism_Access; Credentials : Credentials_Ref) is begin Create (Socket_Endpoint (TE), Socket_Of (S)); TE.Transport := Mechanism; TE.Credentials := Credentials; TE.TLS_Socket := S; end Create; ------------------------- -- Create_Event_Source -- ------------------------- function Create_Event_Source (TAP : access TLS_Access_Point) return Asynch_Ev_Source_Access is Ev_Src : constant Asynch_Ev_Source_Access := Create_Event_Source (TAP.Socket); begin Set_Handler (Ev_Src.all, TAP.Handler'Access); return Ev_Src; end Create_Event_Source; function Create_Event_Source (TE : access TLS_Endpoint) return Asynch_Ev_Source_Access is use PolyORB.Annotations; Ev_Src : constant Asynch_Ev_Source_Access := Create_Event_Source (TE.TLS_Socket); begin Set_Handler (Ev_Src.all, TE.Handler'Access); return Ev_Src; end Create_Event_Source; ---------------- -- Create_QoS -- ---------------- function Create_QoS (End_Point : TLS_Endpoint) return PolyORB.QoS.QoS_Parameter_Access is Result : constant QoS_Transport_Context_Parameter_Access := new QoS_Transport_Context_Parameter; begin Result.Transport := End_Point.Transport; Result.Accepting_Credentials := End_Point.Credentials; Result.Invocation_Credentials := Create_Received_Compound_Credentials (Accepting => End_Point.Credentials, Transport => Create_Peer_TLS_Credentials (End_Point.TLS_Socket)); return QoS_Parameter_Access (Result); end Create_QoS; ----------------------------- -- Extract_TLS_Credentials -- ----------------------------- function Extract_TLS_Credentials (Credentials : Credentials_Ref) return TLS_Credentials_Access is Creds : Credentials_Access := Credentials_Access (Entity_Of (Credentials)); begin if Creds /= null then Creds := Credentials_Access (Entity_Of (Get_Transport_Credentials (Compound_Credentials_Access (Creds)))); if Creds /= null and then Creds.all in TLS_Credentials'Class then return TLS_Credentials_Access (Creds); end if; end if; return null; end Extract_TLS_Credentials; ----------------------- -- Is_Data_Available -- ----------------------- function Is_Data_Available (TE : TLS_Endpoint; N : Natural) return Boolean is begin return Pending_Length (TE.TLS_Socket) >= N; end Is_Data_Available; ---------- -- Read -- ---------- procedure Read (TE : in out TLS_Endpoint; Buffer : Buffers.Buffer_Access; Size : in out Ada.Streams.Stream_Element_Count; Error : out Errors.Error_Container) is use type Ada.Streams.Stream_Element_Count; Data_Received : Ada.Streams.Stream_Element_Count; procedure Receive_Socket (V : access PolyORB.Buffers.Iovec); -- Lowlevel socket receive procedure Receive_Socket (V : access PolyORB.Buffers.Iovec) is Count : Ada.Streams.Stream_Element_Count; Vecs : PolyORB.Sockets.Vector_Type (1 .. 1); pragma Import (Ada, Vecs); for Vecs'Address use V.all'Address; begin PolyORB.TLS.Receive_Vector (TE.TLS_Socket, Vecs, Count); V.Iov_Len := System.Storage_Elements.Storage_Offset (Count); end Receive_Socket; procedure Receive_Buffer is new PolyORB.Buffers.Receive_Buffer (Receive_Socket); begin begin Receive_Buffer (Buffer, Size, Data_Received); exception when PolyORB.Sockets.Socket_Error | PolyORB.TLS.TLS_Error => PolyORB.Errors.Throw (Error, PolyORB.Errors.Comm_Failure_E, PolyORB.Errors.System_Exception_Members' (Minor => 0, Completed => PolyORB.Errors.Completed_Maybe)); return; when others => PolyORB.Errors.Throw (Error, PolyORB.Errors.Unknown_E, PolyORB.Errors.System_Exception_Members' (Minor => 0, Completed => PolyORB.Errors.Completed_Maybe)); return; end; pragma Assert (Data_Received <= Size); Size := Data_Received; end Read; ------------------------------- -- Set_Accepting_Credentials -- ------------------------------- procedure Set_Accepting_Credentials (TAP : in out TLS_Access_Point; Credentials : PolyORB.Security.Credentials.Credentials_Ref) is begin TAP.Credentials := Credentials; end Set_Accepting_Credentials; ----------------------------- -- Set_Transport_Mechanism -- ----------------------------- procedure Set_Transport_Mechanism (TAP : in out TLS_Access_Point; Mechanism : PolyORB.Security.Transport_Mechanisms.Target_Transport_Mechanism_Access) is begin TAP.Transport := Mechanism; end Set_Transport_Mechanism; ----------- -- Write -- ----------- procedure Write (TE : in out TLS_Endpoint; Buffer : Buffers.Buffer_Access; Error : out Errors.Error_Container) is procedure Socket_Send (V : access PolyORB.Buffers.Iovec; N : Integer; Count : out System.Storage_Elements.Storage_Offset); -- Send gathered data ----------------- -- Socket_Send -- ----------------- procedure Socket_Send (V : access PolyORB.Buffers.Iovec; N : Integer; Count : out System.Storage_Elements.Storage_Offset) is subtype SV_T is PolyORB.Sockets.Vector_Type (1 .. N); SV : SV_T; pragma Import (Ada, SV); for SV'Address use V.all'Address; S_Count : Ada.Streams.Stream_Element_Count; begin PolyORB.TLS.Send_Vector (TE.TLS_Socket, SV, S_Count); Count := System.Storage_Elements.Storage_Offset (S_Count); end Socket_Send; procedure Send_Buffer is new Buffers.Send_Buffer (Socket_Send); begin pragma Debug (C, O ("Write: enter")); -- Send_Buffer is not atomic, needs to be protected. Enter (TE.Mutex); pragma Debug (C, O ("TE mutex acquired")); begin Send_Buffer (Buffer); exception when PolyORB.Sockets.Socket_Error | PolyORB.TLS.TLS_Error => PolyORB.Errors.Throw (Error, PolyORB.Errors.Comm_Failure_E, PolyORB.Errors.System_Exception_Members' (Minor => 0, Completed => PolyORB.Errors.Completed_Maybe)); when others => PolyORB.Errors.Throw (Error, PolyORB.Errors.Unknown_E, PolyORB.Errors.System_Exception_Members' (Minor => 0, Completed => PolyORB.Errors.Completed_Maybe)); end; Leave (TE.Mutex); end Write; end PolyORB.Transport.Connected.Sockets.TLS; polyorb-2.8~20110207.orig/src/security/tls/polyorb-transport-connected-sockets-tls.ads0000644000175000017500000001107011750740340030263 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- POLYORB.TRANSPORT.CONNECTED.SOCKETS.TLS -- -- -- -- S p e c -- -- -- -- Copyright (C) 2005-2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- TLS transport service access points and transport endpoints. with PolyORB.QoS; with PolyORB.Security.Credentials; with PolyORB.Security.Transport_Mechanisms; with PolyORB.TLS; package PolyORB.Transport.Connected.Sockets.TLS is pragma Elaborate_Body; type TLS_Access_Point is new Socket_Access_Point with private; function Create_Event_Source (TAP : access TLS_Access_Point) return Asynch_Ev.Asynch_Ev_Source_Access; procedure Set_Accepting_Credentials (TAP : in out TLS_Access_Point; Credentials : PolyORB.Security.Credentials.Credentials_Ref); procedure Set_Transport_Mechanism (TAP : in out TLS_Access_Point; Mechanism : PolyORB.Security.Transport_Mechanisms. Target_Transport_Mechanism_Access); procedure Accept_Connection (TAP : TLS_Access_Point; TE : out Transport_Endpoint_Access); type TLS_Endpoint is new Socket_Endpoint with private; procedure Create (TE : in out TLS_Endpoint; S : PolyORB.TLS.TLS_Socket_Type); procedure Create (TE : in out TLS_Endpoint; S : PolyORB.TLS.TLS_Socket_Type; Mechanism : PolyORB.Security.Transport_Mechanisms.Target_Transport_Mechanism_Access; Credentials : PolyORB.Security.Credentials.Credentials_Ref); function Create_Event_Source (TE : access TLS_Endpoint) return Asynch_Ev.Asynch_Ev_Source_Access; function Is_Data_Available (TE : TLS_Endpoint; N : Natural) return Boolean; procedure Read (TE : in out TLS_Endpoint; Buffer : Buffers.Buffer_Access; Size : in out Ada.Streams.Stream_Element_Count; Error : out Errors.Error_Container); procedure Write (TE : in out TLS_Endpoint; Buffer : Buffers.Buffer_Access; Error : out Errors.Error_Container); procedure Close (TE : access TLS_Endpoint); function Create_QoS (End_Point : TLS_Endpoint) return PolyORB.QoS.QoS_Parameter_Access; private type TLS_Access_Point is new Socket_Access_Point with record Transport : PolyORB.Security.Transport_Mechanisms.Target_Transport_Mechanism_Access; Credentials : PolyORB.Security.Credentials.Credentials_Ref; end record; type TLS_Endpoint is new Socket_Endpoint with record Transport : PolyORB.Security.Transport_Mechanisms.Target_Transport_Mechanism_Access; Credentials : PolyORB.Security.Credentials.Credentials_Ref; TLS_Socket : PolyORB.TLS.TLS_Socket_Type; end record; end PolyORB.Transport.Connected.Sockets.TLS; polyorb-2.8~20110207.orig/src/security/tls/polyorb-tls.adb0000644000175000017500000006741611750740340022616 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . T L S -- -- -- -- B o d y -- -- -- -- Copyright (C) 2005-2009, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with Ada.Characters.Latin_1; with Ada.Exceptions; with Interfaces.C.Strings; with PolyORB.Initialization; with PolyORB.Log; with PolyORB.Utils.Strings; with PolyORB.Platform.SSL_Linker_Options; pragma Warnings (Off, PolyORB.Platform.SSL_Linker_Options); -- No entity referenced package body PolyORB.TLS is use PolyORB.Log; use type Interfaces.C.int; use type Interfaces.C.Strings.chars_ptr; package L is new PolyORB.Log.Facility_Log ("polyorb.tls"); procedure O (Message : String; Level : Log_Level := Debug) renames L.Output; function C (Level : Log_Level := Debug) return Boolean renames L.Enabled; package Thin is type SSL_Method is private; type SSL_Error_Code is new Interfaces.C.unsigned_long; type SSL_Verify_Mode is new Interfaces.C.unsigned_long; SSL_Verify_None : constant SSL_Verify_Mode := 0; SSL_Verify_Peer : constant SSL_Verify_Mode := 1; SSL_Verify_Fail_If_No_Peer_Cert : constant SSL_Verify_Mode := 2; SSL_Verify_Client_Once : constant SSL_Verify_Mode := 4; type SSL_File_Type is private; PEM : constant SSL_File_Type; -- ASN1 : constant SSL_File_Type; type Stack_Of_SSL_Cipher is private; No_Stack_Of_SSL_Cipher : constant Stack_Of_SSL_Cipher; -- Callbacks type SSL_Verify_Callback is access function -- (Preverify : Interfaces.C.int; -- Ctx : X509_STORE_CTX) return Interfaces.C.int; pragma Convention (C, SSL_Verify_Callback); -- Context subprograms function SSL_CTX_new (Method : SSL_Method) return TLS_Context_Type; procedure SSL_CTX_free (Context : TLS_Context_Type); function SSL_CTX_use_certificate (Context : TLS_Context_Type; Certificate : PolyORB.X509.Certificate) return Interfaces.C.int; function SSL_CTX_use_certificate_file (Context : TLS_Context_Type; File : Interfaces.C.char_array; Format_Type : SSL_File_Type) return Interfaces.C.int; function SSL_CTX_use_certificate_chain_file (Context : TLS_Context_Type; File : Interfaces.C.char_array) return Interfaces.C.int; function SSL_CTX_use_PrivateKey_file (Context : TLS_Context_Type; File : Interfaces.C.char_array; Format_Type : SSL_File_Type) return Interfaces.C.int; function SSL_CTX_check_private_key (Context : TLS_Context_Type) return Interfaces.C.int; function SSL_CTX_load_verify_locations (Context : TLS_Context_Type; CA_File : Interfaces.C.char_array; CA_Path : Interfaces.C.char_array) return Interfaces.C.int; function SSL_CTX_load_verify_locations (Context : TLS_Context_Type; CA_File : Interfaces.C.Strings.chars_ptr; CA_Path : Interfaces.C.char_array) return Interfaces.C.int; function SSL_CTX_load_verify_locations (Context : TLS_Context_Type; CA_File : Interfaces.C.char_array; CA_Path : Interfaces.C.Strings.chars_ptr) return Interfaces.C.int; function SSL_CTX_load_verify_locations (Context : TLS_Context_Type; CA_File : Interfaces.C.Strings.chars_ptr; CA_Path : Interfaces.C.Strings.chars_ptr) return Interfaces.C.int; procedure SSL_CTX_set_verify (Ctx : TLS_Context_Type; Mode : SSL_Verify_Mode; Callback : SSL_Verify_Callback); function SSL_CTX_set_cipher_list (Context : TLS_Context_Type; Ciphers : Interfaces.C.char_array) return Interfaces.C.int; -- Cipher subprograms function SSL_CIPHER_description (Cipher : TLS_Cipher_Type) return String; -- Cipher stack subprogram function sk_SSL_CIPHER_num (Stack : Stack_Of_SSL_Cipher) return Interfaces.C.int; function sk_SSL_CIPHER_value (Stack : Stack_Of_SSL_Cipher; Index : Interfaces.C.int) return TLS_Cipher_Type; -- Socket subprograms function SSL_new (Context : TLS_Context_Type) return TLS_Socket_Type; procedure SSL_free (Socket : TLS_Socket_Type); function SSL_get_cipher_list (Socket : TLS_Socket_Type; Priority : Interfaces.C.int) return Interfaces.C.Strings.chars_ptr; function SSL_get_ciphers (Socket : TLS_Socket_Type) return Stack_Of_SSL_Cipher; function SSL_get_peer_certificate (Socket : TLS_Socket_Type) return PolyORB.X509.Certificate; function SSL_get_fd (SSL : TLS_Socket_Type) return Sockets.Socket_Type; function SSL_set_fd (Socket : TLS_Socket_Type; FD : Sockets.Socket_Type) return Interfaces.C.int; function SSL_connect (Socket : TLS_Socket_Type) return Interfaces.C.int; function SSL_accept (Socket : TLS_Socket_Type) return Interfaces.C.int; function SSL_pending (SSL : TLS_Socket_Type) return Interfaces.C.int; function SSL_read (Socket : TLS_Socket_Type; Buffer : Sockets.Stream_Element_Reference; Length : Interfaces.C.int) return Interfaces.C.int; function SSL_write (Socket : TLS_Socket_Type; Buffer : Sockets.Stream_Element_Reference; Length : Interfaces.C.int) return Interfaces.C.int; function SSL_shutdown (SSL : TLS_Socket_Type) return Interfaces.C.int; -- Methods function SSLv2_method return SSL_Method; function SSLv2_client_method return SSL_Method; function SSLv2_server_method return SSL_Method; function SSLv23_method return SSL_Method; function SSLv23_client_method return SSL_Method; function SSLv23_server_method return SSL_Method; function SSLv3_method return SSL_Method; function SSLv3_client_method return SSL_Method; function SSLv3_server_method return SSL_Method; function TLSv1_method return SSL_Method; function TLSv1_client_method return SSL_Method; function TLSv1_server_method return SSL_Method; -- Error handling function ERR_get_error return SSL_Error_Code; function ERR_error_string (Error_Code : SSL_Error_Code) return String; -- Library initialization procedure SSL_library_init; procedure SSL_load_error_strings; -- PolyORB extensions private type SSL_Method_Record is null record; pragma Convention (C, SSL_Method_Record); type SSL_Method is access all SSL_Method_Record; type SSL_File_Type is new Interfaces.C.int; PEM : constant SSL_File_Type := 1; -- ASN1 : constant SSL_File_Type := 2; type Stack_Of_SSL_Cipher_Record is null record; pragma Convention (C, Stack_Of_SSL_Cipher_Record); type Stack_Of_SSL_Cipher is access all Stack_Of_SSL_Cipher_Record; No_Stack_Of_SSL_Cipher : constant Stack_Of_SSL_Cipher := null; pragma Import (C, ERR_get_error, "ERR_get_error"); pragma Import (C, SSL_CTX_check_private_key, "SSL_CTX_check_private_key"); pragma Import (C, SSL_CTX_free, "SSL_CTX_free"); pragma Import (C, SSL_CTX_load_verify_locations, "SSL_CTX_load_verify_locations"); pragma Import (C, SSL_CTX_new, "SSL_CTX_new"); pragma Import (C, SSL_CTX_set_cipher_list, "SSL_CTX_set_cipher_list"); pragma Import (C, SSL_CTX_set_verify, "SSL_CTX_set_verify"); pragma Import (C, SSL_CTX_use_PrivateKey_file, "SSL_CTX_use_PrivateKey_file"); pragma Import (C, SSL_CTX_use_certificate, "SSL_CTX_use_certificate"); pragma Import (C, SSL_CTX_use_certificate_chain_file, "SSL_CTX_use_certificate_chain_file"); pragma Import (C, SSL_CTX_use_certificate_file, "SSL_CTX_use_certificate_file"); pragma Import (C, SSL_accept, "SSL_accept"); pragma Import (C, SSL_connect, "SSL_connect"); pragma Import (C, SSL_free, "SSL_free"); pragma Import (C, SSL_get_cipher_list, "SSL_get_cipher_list"); pragma Import (C, SSL_get_ciphers, "SSL_get_ciphers"); pragma Import (C, SSL_get_fd, "SSL_get_fd"); pragma Import (C, SSL_get_peer_certificate, "SSL_get_peer_certificate"); pragma Import (C, SSL_library_init, "SSL_library_init"); pragma Import (C, SSL_load_error_strings, "SSL_load_error_strings"); pragma Import (C, SSL_new, "SSL_new"); pragma Import (C, SSL_pending, "SSL_pending"); pragma Import (C, SSL_read, "SSL_read"); pragma Import (C, SSL_set_fd, "SSL_set_fd"); pragma Import (C, SSL_shutdown, "SSL_shutdown"); pragma Import (C, SSL_write, "SSL_write"); pragma Import (C, SSLv2_client_method, "SSLv2_client_method"); pragma Import (C, SSLv2_method, "SSLv2_method"); pragma Import (C, SSLv2_server_method, "SSLv2_server_method"); pragma Import (C, SSLv3_client_method, "SSLv3_client_method"); pragma Import (C, SSLv3_method, "SSLv3_method"); pragma Import (C, SSLv3_server_method, "SSLv3_server_method"); pragma Import (C, SSLv23_client_method, "SSLv23_client_method"); pragma Import (C, SSLv23_method, "SSLv23_method"); pragma Import (C, SSLv23_server_method, "SSLv23_server_method"); pragma Import (C, TLSv1_client_method, "TLSv1_client_method"); pragma Import (C, TLSv1_method, "TLSv1_method"); pragma Import (C, TLSv1_server_method, "TLSv1_server_method"); pragma Import (C, sk_SSL_CIPHER_num, "__PolyORB_sk_SSL_CIPHER_num"); pragma Import (C, sk_SSL_CIPHER_value, "__PolyORB_sk_SSL_CIPHER_value"); end Thin; procedure Raise_TLS_Error; -- Raise TLS_Error with error description from OpenSSL library procedure Initialize; -- Initialize OpenSSL library function To_SSL_Verify_Mode (Value : TLS_Verification_Mode) return Thin.SSL_Verify_Mode; -- Convert user friendly TLS_Verification_Mode structure into SSL internal -- representation. -- function To_TLS_Verification_Mode -- (Value : Thin.SSL_Verify_Mode) return TLS_Verification_Mode; -- -- Convert SSL internal representation of SSL_Verify_Mode into -- -- TLS_Verification_Mode ------------------- -- Accept_Socket -- ------------------- procedure Accept_Socket (Socket : TLS_Socket_Type) is begin if Thin.SSL_accept (Socket) /= 1 then Raise_TLS_Error; end if; end Accept_Socket; ----------------------- -- Check_Private_Key -- ----------------------- procedure Check_Private_Key (Context : TLS_Context_Type) is begin if Thin.SSL_CTX_check_private_key (Context) /= 1 then Raise_TLS_Error; end if; end Check_Private_Key; --------------- -- Cipher_Of -- --------------- function Cipher_Of (Socket : TLS_Socket_Type; Priority : Natural) return String is Result : Interfaces.C.Strings.chars_ptr; begin Result := Thin.SSL_get_cipher_list (Socket, Interfaces.C.int (Priority)); if Result = Interfaces.C.Strings.Null_Ptr then return ""; else return Interfaces.C.Strings.Value (Result); end if; end Cipher_Of; ---------------- -- Ciphers_Of -- ---------------- function Ciphers_Of (Context : TLS_Context_Type) return TLS_Cipher_List is Socket : constant TLS_Socket_Type := Thin.SSL_new (Context); Result : constant TLS_Cipher_List := Ciphers_Of (Socket); begin Thin.SSL_free (Socket); return Result; end Ciphers_Of; function Ciphers_Of (Socket : TLS_Socket_Type) return TLS_Cipher_List is use type Thin.Stack_Of_SSL_Cipher; Stack : constant Thin.Stack_Of_SSL_Cipher := Thin.SSL_get_ciphers (Socket); begin if Stack = Thin.No_Stack_Of_SSL_Cipher then return TLS_Cipher_List'(1 .. 0 => No_TLS_Cipher); end if; declare Length : constant Interfaces.C.int := Thin.sk_SSL_CIPHER_num (Stack); Result : TLS_Cipher_List (1 .. Integer (Length)); begin for J in 1 .. Length loop Result (Positive (J)) := Thin.sk_SSL_CIPHER_value (Stack, J - 1); end loop; return Result; end; end Ciphers_Of; ------------------ -- Close_Socket -- ------------------ procedure Close_Socket (Socket : in out TLS_Socket_Type) is Status : Interfaces.C.int; begin -- -- Shutdown procedure may not complete in one call, thus call it -- -- again until it return complete or error status -- -- loop -- Status := Thin.SSL_shutdown (Socket); -- pragma Debug -- (C, O ("SSL_shutdown:" & Interfaces.C.int'Image (Status))); -- -- exit when Status = 1; -- -- if Status /= 0 then -- Raise_TLS_Error; -- end if; -- end loop; -- XXX Original code may go into forever loop if connection closed -- as result of peer termination. Status := Thin.SSL_shutdown (Socket); if Status = 0 then Status := Thin.SSL_shutdown (Socket); end if; if Status not in 0 .. 1 then Raise_TLS_Error; end if; Sockets.Close_Socket (Socket_Of (Socket)); Thin.SSL_free (Socket); Socket := No_TLS_Socket; end Close_Socket; -------------------- -- Connect_Socket -- -------------------- procedure Connect_Socket (Socket : TLS_Socket_Type) is begin if Thin.SSL_connect (Socket) /= 1 then Raise_TLS_Error; end if; end Connect_Socket; ------------ -- Create -- ------------ function Create (Context : TLS_Context_Type) return TLS_Socket_Type is Result : TLS_Socket_Type; begin Result := Thin.SSL_new (Context); if Result = null then Raise_TLS_Error; end if; return Result; end Create; function Create (Method : TLS_Method_Type) return TLS_Context_Type is M : Thin.SSL_Method; Result : TLS_Context_Type; begin case Method is when SSL_2 => M := Thin.SSLv2_method; when SSL_2_Client => M := Thin.SSLv2_client_method; when SSL_2_Server => M := Thin.SSLv2_server_method; when SSL_3 => M := Thin.SSLv3_method; when SSL_3_Client => M := Thin.SSLv3_client_method; when SSL_3_Server => M := Thin.SSLv3_server_method; when TLS_1 => M := Thin.TLSv1_method; when TLS_1_Client => M := Thin.TLSv1_client_method; when TLS_1_Server => M := Thin.TLSv1_server_method; when Any => M := Thin.SSLv23_method; when Any_Client => M := Thin.SSLv23_client_method; when Any_Server => M := Thin.SSLv23_server_method; end case; Result := Thin.SSL_CTX_new (M); if Result = null then Raise_TLS_Error; end if; return Result; end Create; -------------------- -- Description_Of -- -------------------- function Description_Of (Cipher : TLS_Cipher_Type) return String renames Thin.SSL_CIPHER_description; ------------- -- Destroy -- ------------- procedure Destroy (Context : in out TLS_Context_Type) is begin if Context /= null then Thin.SSL_CTX_free (Context); Context := null; end if; end Destroy; procedure Destroy (Socket : in out TLS_Socket_Type) is begin if Socket /= null then Thin.SSL_free (Socket); Socket := null; end if; end Destroy; ---------------- -- Initialize -- ---------------- procedure Initialize is begin Thin.SSL_load_error_strings; Thin.SSL_library_init; -- XXX actions_to_seed_PRNG end Initialize; --------------------------- -- Load_Verify_Locations -- --------------------------- procedure Load_Verify_Locations (Context : TLS_Context_Type; Certificate_Authority_File : String; Certificate_Authority_Path : String) is begin if Certificate_Authority_File /= "" and then Certificate_Authority_Path /= "" then if Thin.SSL_CTX_load_verify_locations (Context, Interfaces.C.To_C (Certificate_Authority_File), Interfaces.C.To_C (Certificate_Authority_Path)) /= 1 then Raise_TLS_Error; end if; elsif Certificate_Authority_File /= "" then if Thin.SSL_CTX_load_verify_locations (Context, Interfaces.C.To_C (Certificate_Authority_File), Interfaces.C.Strings.Null_Ptr) /= 1 then Raise_TLS_Error; end if; elsif Certificate_Authority_Path /= "" then if Thin.SSL_CTX_load_verify_locations (Context, Interfaces.C.Strings.Null_Ptr, Interfaces.C.To_C (Certificate_Authority_Path)) /= 1 then Raise_TLS_Error; end if; else if Thin.SSL_CTX_load_verify_locations (Context, Interfaces.C.Strings.Null_Ptr, Interfaces.C.Strings.Null_Ptr) /= 1 then Raise_TLS_Error; end if; end if; end Load_Verify_Locations; ------------------------- -- Peer_Certificate_Of -- ------------------------- function Peer_Certificate_Of (Socket : TLS_Socket_Type) return PolyORB.X509.Certificate is begin return Thin.SSL_get_peer_certificate (Socket); end Peer_Certificate_Of; -------------------- -- Pending_Length -- -------------------- function Pending_Length (Socket : TLS_Socket_Type) return Natural is begin return Natural (Thin.SSL_pending (Socket)); end Pending_Length; --------------------- -- Raise_TLS_Error -- --------------------- procedure Raise_TLS_Error is function Get_Errors_String return String; ----------------------- -- Get_Errors_String -- ----------------------- function Get_Errors_String return String is use type Thin.SSL_Error_Code; Error : constant Thin.SSL_Error_Code := Thin.ERR_get_error; begin if Error /= 0 then return Get_Errors_String & Ada.Characters.Latin_1.LF & Thin.ERR_error_string (Error); else return ""; end if; end Get_Errors_String; X : constant String := Get_Errors_String; begin pragma Debug (C, O ("TLS ERROR:" & X)); Ada.Exceptions.Raise_Exception (TLS_Error'Identity, X); end Raise_TLS_Error; -------------------- -- Receive_Vector -- -------------------- procedure Receive_Vector (Socket : TLS_Socket_Type; Vector : Sockets.Vector_Type; Count : out Ada.Streams.Stream_Element_Count) is use type Ada.Streams.Stream_Element_Count; Bytes_Readed : Interfaces.C.int; begin Count := 0; for J in Vector'Range loop Bytes_Readed := Thin.SSL_read (Socket, Vector (J).Base, Interfaces.C.int (Vector (J).Length)); if Bytes_Readed <= 0 then Raise_TLS_Error; end if; Count := Count + Ada.Streams.Stream_Element_Count (Bytes_Readed); if Bytes_Readed < Interfaces.C.int (Vector (J).Length) then -- Where are no more data for reading. Exiting. return; end if; end loop; end Receive_Vector; ----------------- -- Send_Vector -- ----------------- procedure Send_Vector (Socket : TLS_Socket_Type; Vector : Sockets.Vector_Type; Count : out Ada.Streams.Stream_Element_Count) is use type Ada.Streams.Stream_Element_Count; Bytes_Written : Interfaces.C.int; begin Count := 0; for J in Vector'Range loop Bytes_Written := Thin.SSL_write (Socket, Vector (J).Base, Interfaces.C.int (Vector (J).Length)); if Bytes_Written <= 0 then Raise_TLS_Error; end if; Count := Count + Ada.Streams.Stream_Element_Count (Bytes_Written); if Bytes_Written < Interfaces.C.int (Vector (J).Length) then -- The actually written number of bytes differ from requested -- number. The operation was successful, but incomplete for some -- reasons. Report this to caller. return; end if; end loop; end Send_Vector; --------------------- -- Set_Cipher_List -- --------------------- procedure Set_Cipher_List (Context : TLS_Context_Type; Ciphers : String) is begin if Thin.SSL_CTX_set_cipher_list (Context, Interfaces.C.To_C (Ciphers)) /= 1 then Raise_TLS_Error; end if; end Set_Cipher_List; ---------------- -- Set_Socket -- ---------------- procedure Set_Socket (Socket : TLS_Socket_Type; Sock : Sockets.Socket_Type) is begin if Thin.SSL_set_fd (Socket, Sock) /= 1 then Raise_TLS_Error; end if; end Set_Socket; --------------------- -- Set_Verify_Mode -- --------------------- procedure Set_Verify_Mode (Context : TLS_Context_Type; Mode : TLS_Verification_Mode) is begin Thin.SSL_CTX_set_verify (Context, To_SSL_Verify_Mode (Mode), null); end Set_Verify_Mode; --------------- -- Socket_Of -- --------------- function Socket_Of (Socket : TLS_Socket_Type) return Sockets.Socket_Type is begin return Thin.SSL_get_fd (Socket); end Socket_Of; ---------- -- Thin -- ---------- package body Thin is ---------------------- -- ERR_error_string -- ---------------------- function ERR_error_string (Error_Code : SSL_Error_Code) return String is procedure ERR_error_string_n (Error_Code : SSL_Error_Code; Buf : Interfaces.C.char_array; Len : Interfaces.C.size_t); pragma Import (C, ERR_error_string_n, "ERR_error_string_n"); Buffer : Interfaces.C.char_array (1 .. 1024); pragma Warnings (Off, Buffer); -- Buffer not needed to be initialized and modified, because -- of side effect of C function ERR_error_string_n begin ERR_error_string_n (Error_Code, Buffer, Buffer'Length); return Interfaces.C.To_Ada (Buffer); end ERR_error_string; ---------------------------- -- SSL_CIPHER_description -- ---------------------------- function SSL_CIPHER_description (Cipher : TLS_Cipher_Type) return String is procedure SSL_CIPHER_description (Cipher : TLS_Cipher_Type; Buf : Interfaces.C.char_array; Size : Interfaces.C.int); pragma Import (C, SSL_CIPHER_description, "SSL_CIPHER_description"); Buffer : Interfaces.C.char_array (1 .. 512); pragma Warnings (Off, Buffer); -- Buffer not needed to be initialized and modified, because -- of side effect of C function SSL_CIPHER_description begin SSL_CIPHER_description (Cipher, Buffer, Buffer'Length); return Interfaces.C.To_Ada (Buffer); end SSL_CIPHER_description; end Thin; ------------------------ -- To_SSL_Verify_Mode -- ------------------------ function To_SSL_Verify_Mode (Value : TLS_Verification_Mode) return Thin.SSL_Verify_Mode is use type Thin.SSL_Verify_Mode; Result : Thin.SSL_Verify_Mode := Thin.SSL_Verify_None; begin if Value (Peer) then Result := Thin.SSL_Verify_Peer; if Value (Fail_If_No_Peer_Certificate) then Result := Result or Thin.SSL_Verify_Fail_If_No_Peer_Cert; end if; if Value (Client_Once) then Result := Result or Thin.SSL_Verify_Client_Once; end if; end if; return Result; end To_SSL_Verify_Mode; --------------------- -- Use_Certificate -- --------------------- procedure Use_Certificate (Context : TLS_Context_Type; File_Name : String) is begin if Thin.SSL_CTX_use_certificate_file (Context, Interfaces.C.To_C (File_Name), Thin.PEM) /= 1 then Raise_TLS_Error; end if; end Use_Certificate; procedure Use_Certificate (Context : TLS_Context_Type; Certificate : PolyORB.X509.Certificate) is begin if Thin.SSL_CTX_use_certificate (Context, Certificate) /= 1 then Raise_TLS_Error; end if; end Use_Certificate; --------------------------- -- Use_Certificate_Chain -- --------------------------- procedure Use_Certificate_Chain (Context : TLS_Context_Type; File_Name : String) is begin if Thin.SSL_CTX_use_certificate_chain_file (Context, Interfaces.C.To_C (File_Name)) /= 1 then Raise_TLS_Error; end if; end Use_Certificate_Chain; --------------------- -- Use_Private_Key -- --------------------- procedure Use_Private_Key (Context : TLS_Context_Type; File_Name : String) is begin if Thin.SSL_CTX_use_PrivateKey_file (Context, Interfaces.C.To_C (File_Name), Thin.PEM) /= 1 then Raise_TLS_Error; end if; end Use_Private_Key; begin declare use PolyORB.Initialization; use PolyORB.Initialization.String_Lists; use PolyORB.Utils.Strings; begin Register_Module (Module_Info' (Name => +"tls", Conflicts => Empty, Depends => +"sockets" & "x509", Provides => Empty, Implicit => False, Init => Initialize'Access, Shutdown => null)); end; end PolyORB.TLS; polyorb-2.8~20110207.orig/src/security/tls/polyorb-security-transport_mechanisms-tls.ads0000644000175000017500000000733211750740340030734 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- POLYORB.SECURITY.TRANSPORT_MECHANISMS.TLS -- -- -- -- S p e c -- -- -- -- Copyright (C) 2005-2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ package PolyORB.Security.Transport_Mechanisms.TLS is type Client_TLS_Transport_Mechanism is new Client_Transport_Mechanism with record Target_Supports : PolyORB.Security.Types.Association_Options; Target_Requires : PolyORB.Security.Types.Association_Options; end record; function Target_Supports (Mechanism : access Client_TLS_Transport_Mechanism) return PolyORB.Security.Types.Association_Options; function Target_Requires (Mechanism : access Client_TLS_Transport_Mechanism) return PolyORB.Security.Types.Association_Options; function Is_Supports (Mechanism : access Client_TLS_Transport_Mechanism; Credentials : PolyORB.Security.Credentials.Credentials_Ref) return Boolean; type Target_TLS_Transport_Mechanism is new Target_Transport_Mechanism with record Credentials : PolyORB.Security.Credentials.Credentials_Ref; end record; function Target_Supports (Mechanism : access Target_TLS_Transport_Mechanism) return PolyORB.Security.Types.Association_Options; function Target_Requires (Mechanism : access Target_TLS_Transport_Mechanism) return PolyORB.Security.Types.Association_Options; function Supported_Identity_Types (Mechanism : access Target_TLS_Transport_Mechanism) return PolyORB.Security.Types.Identity_Token_Type; function Supported_Naming_Mechanisms (Mechanism : access Target_TLS_Transport_Mechanism) return PolyORB.Security.Types.OID_Lists.List; procedure Set_Accepting_Credentials (Mechanism : access Target_TLS_Transport_Mechanism; Credentials : PolyORB.Security.Credentials.Credentials_Ref); end PolyORB.Security.Transport_Mechanisms.TLS; polyorb-2.8~20110207.orig/src/security/tls/polyorb-security-transport_mechanisms-tls.adb0000644000175000017500000001524411750740340030714 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- POLYORB.SECURITY.TRANSPORT_MECHANISMS.TLS -- -- -- -- B o d y -- -- -- -- Copyright (C) 2005-2009, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with PolyORB.Security.Credentials.Compound; with PolyORB.Security.Credentials.TLS; with PolyORB.Transport.Connected.Sockets.TLS; package body PolyORB.Security.Transport_Mechanisms.TLS is use PolyORB.Security.Credentials; use PolyORB.Security.Credentials.Compound; use PolyORB.Security.Credentials.TLS; use PolyORB.Transport; use PolyORB.Transport.Connected.Sockets.TLS; use TAP_Lists; function Extract_TLS_Credentials (Credentials : Credentials_Ref) return TLS_Credentials_Access; ----------------------------- -- Extract_TLS_Credentials -- ----------------------------- function Extract_TLS_Credentials (Credentials : Credentials_Ref) return TLS_Credentials_Access is Creds : Credentials_Access := Credentials_Access (Entity_Of (Credentials)); begin if Creds /= null then Creds := Credentials_Access (Entity_Of (Get_Transport_Credentials (Compound_Credentials_Access (Creds)))); if Creds /= null and then Creds.all in TLS_Credentials'Class then return TLS_Credentials_Access (Creds); end if; end if; return null; end Extract_TLS_Credentials; ----------------- -- Is_Supports -- ----------------- function Is_Supports (Mechanism : access Client_TLS_Transport_Mechanism; Credentials : PolyORB.Security.Credentials.Credentials_Ref) return Boolean is pragma Unreferenced (Mechanism); use PolyORB.Security.Types; Creds : constant TLS_Credentials_Access := Extract_TLS_Credentials (Credentials); begin return Creds /= null; -- XXX Should also check satisfaction of target's requirements end Is_Supports; ------------------------------- -- Set_Accepting_Credentials -- ------------------------------- procedure Set_Accepting_Credentials (Mechanism : access Target_TLS_Transport_Mechanism; Credentials : PolyORB.Security.Credentials.Credentials_Ref) is Iter : Iterator := First (Mechanism.TAP); begin Mechanism.Credentials := Credentials; while not Last (Iter) loop Set_Accepting_Credentials (TLS_Access_Point (Value (Iter).all.all), Credentials); Next (Iter); end loop; end Set_Accepting_Credentials; ------------------------------ -- Supported_Identity_Types -- ------------------------------ function Supported_Identity_Types (Mechanism : access Target_TLS_Transport_Mechanism) return PolyORB.Security.Types.Identity_Token_Type is pragma Unreferenced (Mechanism); use PolyORB.Security.Types; begin return ITT_X509_Cert_Chain or ITT_Distinguished_Name; end Supported_Identity_Types; --------------------------------- -- Supported_Naming_Mechanisms -- --------------------------------- function Supported_Naming_Mechanisms (Mechanism : access Target_TLS_Transport_Mechanism) return PolyORB.Security.Types.OID_Lists.List is pragma Unreferenced (Mechanism); Empty_List : Security.Types.OID_Lists.List; begin return Empty_List; end Supported_Naming_Mechanisms; --------------------- -- Target_Requires -- --------------------- function Target_Requires (Mechanism : access Client_TLS_Transport_Mechanism) return PolyORB.Security.Types.Association_Options is begin return Mechanism.Target_Requires; end Target_Requires; function Target_Requires (Mechanism : access Target_TLS_Transport_Mechanism) return PolyORB.Security.Types.Association_Options is Credentials : constant TLS_Credentials_Access := Extract_TLS_Credentials (Mechanism.Credentials); begin if Credentials = null then raise Program_Error; end if; return Get_Accepting_Options_Required (Credentials); end Target_Requires; --------------------- -- Target_Supports -- --------------------- function Target_Supports (Mechanism : access Client_TLS_Transport_Mechanism) return PolyORB.Security.Types.Association_Options is begin return Mechanism.Target_Supports; end Target_Supports; function Target_Supports (Mechanism : access Target_TLS_Transport_Mechanism) return PolyORB.Security.Types.Association_Options is Credentials : constant TLS_Credentials_Access := Extract_TLS_Credentials (Mechanism.Credentials); begin if Credentials = null then raise Program_Error; end if; return Get_Accepting_Options_Supported (Credentials); end Target_Supports; end PolyORB.Security.Transport_Mechanisms.TLS; polyorb-2.8~20110207.orig/src/security/polyorb-security-backward_trust_evaluators.ads0000644000175000017500000000546211750740340030355 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- POLYORB.SECURITY.BACKWARD_TRUST_EVALUATORS -- -- -- -- S p e c -- -- -- -- Copyright (C) 2005-2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with PolyORB.Security.Identities; with PolyORB.Types; package PolyORB.Security.Backward_Trust_Evaluators is type Backward_Trust_Evaluator is tagged private; type Backward_Trust_Evaluator_Access is access all Backward_Trust_Evaluator'Class; procedure Evaluate_Trust (Evaluator : access Backward_Trust_Evaluator; Client_Identity : PolyORB.Security.Identities.Identity_Access; Asserted_Identity : PolyORB.Security.Identities.Identity_Access; Trusted : out Boolean); function Create_Backward_Trust_Evaluator (File : String) return Backward_Trust_Evaluator_Access; private type Backward_Trust_Evaluator is tagged record File_Name : PolyORB.Types.String; end record; end PolyORB.Security.Backward_Trust_Evaluators; polyorb-2.8~20110207.orig/src/security/polyorb-qos-targets_security.adb0000644000175000017500000001476411750740340025410 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . Q O S . T A R G E T S _ S E C U R I T Y -- -- -- -- B o d y -- -- -- -- Copyright (C) 2005-2009, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with Ada.Unchecked_Deallocation; with PolyORB.ASN1; package body PolyORB.QoS.Targets_Security is use PolyORB.Annotations; use PolyORB.ASN1; use PolyORB.Security.Authentication_Mechanisms; use PolyORB.Security.Backward_Trust_Evaluators; use PolyORB.Security.Forward_Trust_Evaluators; use PolyORB.Security.Authority_Mechanisms; use PolyORB.Security.Authority_Mechanisms.Target_Authority_Mechanism_Lists; use PolyORB.Security.Transport_Mechanisms; use PolyORB.Security.Types; use OID_Lists; procedure Release_Contents (Item : in out Target_Mechanism); ------------------ -- Is_Protected -- ------------------ function Is_Protected (Mechanism : Target_Mechanism) return Boolean is begin return Target_Requires (Mechanism) /= 0; end Is_Protected; ---------------------- -- Release_Contents -- ---------------------- procedure Release_Contents (QoS : access QoS_Target_Security_Parameter) is use Target_Mechanism_Lists; procedure Free is new Ada.Unchecked_Deallocation (Target_Mechanism, Target_Mechanism_Access); Iter : Target_Mechanism_Lists.Iterator := First (QoS.Mechanisms); begin while not Last (Iter) loop Release_Contents (Value (Iter).all.all); Free (Value (Iter).all); Next (Iter); end loop; Deallocate (QoS.Mechanisms); end Release_Contents; procedure Release_Contents (Item : in out Target_Mechanism) is procedure Free is new Ada.Unchecked_Deallocation (Target_Transport_Mechanism'Class, Target_Transport_Mechanism_Access); begin Free (Item.Transport); Destroy (Item.Authentication_Mechanism); declare Iter : Target_Authority_Mechanism_Lists.Iterator := First (Item.Authorities); begin while not Last (Iter) loop Destroy (Value (Iter).all); Next (Iter); end loop; end; Deallocate (Item.Authorities); declare Iter : OID_Lists.Iterator := First (Item.Naming_Mechanisms); begin while not Last (Iter) loop Free (Value (Iter).all); Next (Iter); end loop; end; Deallocate (Item.Naming_Mechanisms); Destroy (Item.Notepad); end Release_Contents; ------------------------------- -- Set_Accepting_Credentials -- ------------------------------- procedure Set_Accepting_Credentials (Mechanism : in out Target_Mechanism; Credentials : PolyORB.Security.Credentials.Credentials_Ref) is begin Mechanism.Credentials := Credentials; if Mechanism.Transport /= null then Set_Accepting_Credentials (Mechanism.Transport, Credentials); end if; end Set_Accepting_Credentials; --------------------- -- Target_Requires -- --------------------- function Target_Requires (Mechanism : Target_Mechanism) return PolyORB.Security.Types.Association_Options is Result : Association_Options := 0; begin if Mechanism.Transport /= null then Result := Target_Requires (Mechanism.Transport); end if; if Mechanism.Authentication_Mechanism /= null and then Mechanism.Authentication_Required then Result := Result or Establish_Trust_In_Client; end if; if not Is_Empty (Mechanism.Authorities) and then Mechanism.Forward_Trust_Evaluator /= null and then Mechanism.Delegation_Required then Result := Result or Delegation_By_Client; end if; return Result; end Target_Requires; --------------------- -- Target_Supports -- --------------------- function Target_Supports (Mechanism : Target_Mechanism) return PolyORB.Security.Types.Association_Options is Result : Association_Options := 0; begin if Mechanism.Transport /= null then Result := Target_Supports (Mechanism.Transport); end if; if Mechanism.Authentication_Mechanism /= null then Result := Result or Establish_Trust_In_Client; end if; if Mechanism.Backward_Trust_Evaluator /= null or else Mechanism.Forward_Trust_Evaluator /= null then Result := Result or Identity_Assertion; end if; if not Is_Empty (Mechanism.Authorities) and then Mechanism.Forward_Trust_Evaluator /= null then Result := Result or Delegation_By_Client; end if; return Result; end Target_Supports; end PolyORB.QoS.Targets_Security; polyorb-2.8~20110207.orig/src/security/polyorb_asn1.c0000644000175000017500000000701211750740340021614 0ustar xavierxavier/***************************************************************************** ** ** ** POLYORB COMPONENTS ** ** ** ** P O L Y O R B _ A S N 1 ** ** ** ** C s u p p o r t f i l e ** ** ** ** Copyright (C) 2005 Free Software Foundation, Inc. ** ** ** ** PolyORB is free software; you can redistribute it and/or modify it ** ** under terms of the GNU General Public License as published by the Free ** ** Software Foundation; either version 2, or (at your option) any later ** ** version. PolyORB is distributed in the hope that it will be useful, ** ** but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- ** ** TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public ** ** License for more details. You should have received a copy of the GNU ** ** General Public License distributed with PolyORB; see file COPYING. If ** ** not, write to the Free Software Foundation, 51 Franklin Street, Fifth ** ** Floor, Boston, MA 02111-1301, USA. ** ** ** ** ** ** PolyORB is maintained by AdaCore ** ** (email: sales at adacore.com) ** ** ** *****************************************************************************/ #include #include /**************************/ /* __PolyORB_OPENSSL_free */ /**************************/ void __PolyORB_OPENSSL_free(unsigned char *x) { if (x != NULL) { OPENSSL_free(x); } } /*****************************/ /* __PolyORB_i2d_ASN1_OBJECT */ /*****************************/ void __PolyORB_i2d_ASN1_OBJECT(ASN1_OBJECT *object, unsigned char **buffer, int *length) { unsigned char *aux; /* Calculate required buffer length */ *length = i2d_ASN1_OBJECT(object, NULL); if (*length < 0) { return; } /* Allocate buffer */ *buffer = OPENSSL_malloc(*length); if (buffer == NULL) { return; } /* Encode OBJECT IDENTIFIER */ aux = *buffer; *length = i2d_ASN1_OBJECT(object, &aux); if (*length < 0) { OPENSSL_free(*buffer); *buffer = NULL; } } /*****************************/ /* __PolyORB_d2i_ASN1_OBJECT */ /*****************************/ ASN1_OBJECT *__PolyORB_d2i_ASN1_OBJECT(unsigned char *buf, int length) { unsigned char *aux = buf; return d2i_ASN1_OBJECT(NULL, &aux, length); } /***************************/ /* PolyORB_ASN1_OBJECT_dup */ /***************************/ ASN1_OBJECT *__PolyORB_ASN1_OBJECT_dup(ASN1_OBJECT *x) { return (ASN1_OBJECT *)ASN1_dup((int (*)())i2d_ASN1_OBJECT, (char *(*)())d2i_ASN1_OBJECT, (char *)x); } polyorb-2.8~20110207.orig/src/security/polyorb-security-authentication_mechanisms.adb0000644000175000017500000002073711750740340030300 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- POLYORB.SECURITY.AUTHENTICATION_MECHANISMS -- -- -- -- B o d y -- -- -- -- Copyright (C) 2005-2008, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with Ada.Unchecked_Deallocation; with PolyORB.Log; with PolyORB.Parameters; with PolyORB.Types; with PolyORB.Utils.Chained_Lists; package body PolyORB.Security.Authentication_Mechanisms is use PolyORB.Log; package L is new PolyORB.Log.Facility_Log ("polyorb.security.authentication_mechanisms"); procedure O (Message : String; Level : Log_Level := Debug) renames L.Output; function C (Level : Log_Level := Debug) return Boolean renames L.Enabled; type Client_Registry_Item is record Mechanism_OID : PolyORB.ASN1.Object_Identifier; Constructor : Client_Mechanism_Constructor; end record; package Client_Registry_Item_Lists is new PolyORB.Utils.Chained_Lists (Client_Registry_Item); Client_Registry : Client_Registry_Item_Lists.List; type Target_Registry_Item is record Mechanism_Name : PolyORB.Types.String; Constructor : Target_Mechanism_Constructor; end record; package Target_Registry_Item_Lists is new PolyORB.Utils.Chained_Lists (Target_Registry_Item); Target_Registry : Target_Registry_Item_Lists.List; ----------------------------- -- Create_Client_Mechanism -- ----------------------------- function Create_Client_Mechanism (Mechanism_OID : PolyORB.ASN1.Object_Identifier; Target_Name : PolyORB.Security.Exported_Names.Exported_Name_Access) return Client_Authentication_Mechanism_Access is use Client_Registry_Item_Lists; Iter : Iterator := First (Client_Registry); begin while not Last (Iter) loop if PolyORB.ASN1.Is_Equivalent (Value (Iter).Mechanism_OID, Mechanism_OID) then return Value (Iter).Constructor (Target_Name); end if; Next (Iter); end loop; return null; end Create_Client_Mechanism; ----------------------------- -- Create_Target_Mechanism -- ----------------------------- function Create_Target_Mechanism (Section_Name : String) return Target_Authentication_Mechanism_Access is use Target_Registry_Item_Lists; use PolyORB.Parameters; use type PolyORB.Types.String; Iter : Iterator := First (Target_Registry); Mechanism : constant String := Get_Conf (Section_Name, "mechanism", ""); begin while not Last (Iter) loop if Value (Iter).Mechanism_Name = Mechanism then return Value (Iter).Constructor (Section_Name); end if; Next (Iter); end loop; return null; end Create_Target_Mechanism; ------------- -- Destroy -- ------------- procedure Destroy (Mechanism : in out Client_Authentication_Mechanism_Access) is procedure Free is new Ada.Unchecked_Deallocation (Client_Authentication_Mechanism'Class, Client_Authentication_Mechanism_Access); begin if Mechanism /= null then Release_Contents (Mechanism); Free (Mechanism); end if; end Destroy; procedure Destroy (Mechanism : in out Target_Authentication_Mechanism_Access) is procedure Free is new Ada.Unchecked_Deallocation (Target_Authentication_Mechanism'Class, Target_Authentication_Mechanism_Access); begin if Mechanism /= null then Release_Contents (Mechanism); Free (Mechanism); end if; end Destroy; ----------------------- -- Get_Mechanism_OID -- ----------------------- function Get_Mechanism_OID (Mechanism : access Target_Authentication_Mechanism) return PolyORB.ASN1.Object_Identifier is begin return Mechanism.Mechanism_OID; end Get_Mechanism_OID; ---------------------------------- -- Get_Supported_Identity_Types -- ---------------------------------- function Get_Supported_Identity_Types (Mechanism : access Target_Authentication_Mechanism) return PolyORB.Security.Types.Identity_Token_Type is begin return Mechanism.Identity_Types; end Get_Supported_Identity_Types; ------------------------------------- -- Get_Supported_Naming_Mechanisms -- ------------------------------------- function Get_Supported_Naming_Mechanisms (Mechanism : access Target_Authentication_Mechanism) return PolyORB.Security.Types.OID_Lists.List is begin return Mechanism.Naming_Mechanisms; end Get_Supported_Naming_Mechanisms; --------------------- -- Get_Target_Name -- --------------------- function Get_Target_Name (Mechanism : access Target_Authentication_Mechanism) return PolyORB.Security.Exported_Names.Exported_Name_Access is begin return Mechanism.Target_Name; end Get_Target_Name; -------------- -- Register -- -------------- procedure Register (Mechanism_OID : PolyORB.ASN1.Object_Identifier; Constructor : Client_Mechanism_Constructor) is begin pragma Debug (C, O ("Register client authentication mechanism: " & PolyORB.ASN1.To_String (Mechanism_OID))); Client_Registry_Item_Lists.Append (Client_Registry, (Mechanism_OID => Mechanism_OID, Constructor => Constructor)); end Register; procedure Register (Mechanism_Name : String; Constructor : Target_Mechanism_Constructor) is begin pragma Debug (C, O ("Register target authentication mechanism: '" & Mechanism_Name & ''')); Target_Registry_Item_Lists.Append (Target_Registry, (Mechanism_Name => PolyORB.Types.To_PolyORB_String (Mechanism_Name), Constructor => Constructor)); end Register; ---------------------- -- Release_Contents -- ---------------------- procedure Release_Contents (Mechanism : access Client_Authentication_Mechanism) is begin PolyORB.Security.Exported_Names.Destroy (Mechanism.Target_Name); end Release_Contents; procedure Release_Contents (Mechanism : access Target_Authentication_Mechanism) is begin PolyORB.ASN1.Destroy (Mechanism.Mechanism_OID); PolyORB.Security.Exported_Names.Destroy (Mechanism.Target_Name); declare use PolyORB.Security.Types.OID_Lists; Iter : Iterator := First (Mechanism.Naming_Mechanisms); begin while not Last (Iter) loop PolyORB.ASN1.Destroy (Value (Iter).all); Next (Iter); end loop; Deallocate (Mechanism.Naming_Mechanisms); end; end Release_Contents; end PolyORB.Security.Authentication_Mechanisms; polyorb-2.8~20110207.orig/src/security/polyorb-security-backward_trust_evaluators.adb0000644000175000017500000000754311750740340030336 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- POLYORB.SECURITY.BACKWARD_TRUST_EVALUATORS -- -- -- -- B o d y -- -- -- -- Copyright (C) 2005-2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with Ada.Text_IO; package body PolyORB.Security.Backward_Trust_Evaluators is ------------------------------------- -- Create_Backward_Trust_Evaluator -- ------------------------------------- function Create_Backward_Trust_Evaluator (File : String) return Backward_Trust_Evaluator_Access is Result : constant Backward_Trust_Evaluator_Access := new Backward_Trust_Evaluator; begin Result.File_Name := PolyORB.Types.To_PolyORB_String (File); return Result; end Create_Backward_Trust_Evaluator; -------------------- -- Evaluate_Trust -- -------------------- procedure Evaluate_Trust (Evaluator : access Backward_Trust_Evaluator; Client_Identity : PolyORB.Security.Identities.Identity_Access; Asserted_Identity : PolyORB.Security.Identities.Identity_Access; Trusted : out Boolean) is use Ada.Text_IO; use PolyORB.Security.Identities; File : File_Type; Buffer : String (1 .. 1024); Last : Natural; Section_Find : Boolean := False; begin Trusted := False; Open (File, In_File, PolyORB.Types.To_Standard_String (Evaluator.File_Name)); while not End_Of_File (File) loop Get_Line (File, Buffer, Last); if Last /= 0 then if Buffer (1) = '[' then Section_Find := Buffer (1 .. Last) = Get_Printable_Name (Client_Identity); elsif Section_Find and then Buffer (1 .. Last) = ' ' & Get_Printable_Name (Asserted_Identity) then Trusted := True; exit; end if; end if; end loop; Close (File); end Evaluate_Trust; end PolyORB.Security.Backward_Trust_Evaluators; polyorb-2.8~20110207.orig/src/security/polyorb-qos-transport_contexts.adb0000644000175000017500000000452311750740340025763 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . Q O S . T R A N S P O R T _ C O N T E X T S -- -- -- -- B o d y -- -- -- -- Copyright (C) 2005-2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ package body PolyORB.QoS.Transport_Contexts is ---------------------- -- Release_Contents -- ---------------------- procedure Release_Contents (QoS : access QoS_Transport_Context_Parameter) is pragma Unreferenced (QoS); begin null; end Release_Contents; end PolyORB.QoS.Transport_Contexts; polyorb-2.8~20110207.orig/src/security/polyorb-security-transport_mechanisms.ads0000644000175000017500000001024511750740340027327 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- POLYORB.SECURITY.TRANSPORT_MECHANISMS -- -- -- -- S p e c -- -- -- -- Copyright (C) 2005-2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- CORBA CSI Version 2 Transport Mechanism configuration information with PolyORB.Security.Credentials; with PolyORB.Security.Types; with PolyORB.Transport; with PolyORB.Utils.Chained_Lists; package PolyORB.Security.Transport_Mechanisms is package TAP_Lists is new PolyORB.Utils.Chained_Lists (PolyORB.Transport.Transport_Access_Point_Access, PolyORB.Transport."="); type Client_Transport_Mechanism is abstract tagged limited null record; type Client_Transport_Mechanism_Access is access all Client_Transport_Mechanism'Class; function Target_Supports (Mechanism : access Client_Transport_Mechanism) return PolyORB.Security.Types.Association_Options is abstract; function Target_Requires (Mechanism : access Client_Transport_Mechanism) return PolyORB.Security.Types.Association_Options is abstract; function Is_Supports (Mechanism : access Client_Transport_Mechanism; Credentials : PolyORB.Security.Credentials.Credentials_Ref) return Boolean is abstract; -- Return True iff Credentials supports the Mechanism type Target_Transport_Mechanism is abstract tagged limited record TAP : TAP_Lists.List; end record; type Target_Transport_Mechanism_Access is access all Target_Transport_Mechanism'Class; function Target_Supports (Mechanism : access Target_Transport_Mechanism) return PolyORB.Security.Types.Association_Options is abstract; function Target_Requires (Mechanism : access Target_Transport_Mechanism) return PolyORB.Security.Types.Association_Options is abstract; function Supported_Identity_Types (Mechanism : access Target_Transport_Mechanism) return PolyORB.Security.Types.Identity_Token_Type is abstract; function Supported_Naming_Mechanisms (Mechanism : access Target_Transport_Mechanism) return PolyORB.Security.Types.OID_Lists.List is abstract; procedure Set_Accepting_Credentials (Mechanism : access Target_Transport_Mechanism; Credentials : PolyORB.Security.Credentials.Credentials_Ref) is abstract; end PolyORB.Security.Transport_Mechanisms; polyorb-2.8~20110207.orig/src/security/polyorb-security-connections.ads0000644000175000017500000000430111750740340025402 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . S E C U R I T Y . C O N N E C T I O N S -- -- -- -- S p e c -- -- -- -- Copyright (C) 2005-2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ package PolyORB.Security.Connections is type Connection is abstract tagged null record; type Connection_Access is access all Connection'Class; end PolyORB.Security.Connections; polyorb-2.8~20110207.orig/src/security/polyorb-security-credentials-compound.ads0000644000175000017500000001200711750740340027201 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- POLYORB.SECURITY.CREDENTIALS.COMPOUND -- -- -- -- S p e c -- -- -- -- Copyright (C) 2005-2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ package PolyORB.Security.Credentials.Compound is -- Compound Credentials type Compound_Credentials is new Credentials with private; type Compound_Credentials_Access is access all Compound_Credentials'Class; function Get_Transport_Credentials (Self : access Compound_Credentials) return Credentials_Ref; function Get_Transport_Identity (Self : access Compound_Credentials) return PolyORB.Security.Identities.Identity_Access; function Get_Authentication_Credentials (Self : access Compound_Credentials) return Credentials_Ref; -- Received Credentials type Received_Compound_Credentials is new Compound_Credentials with private; type Received_Compound_Credentials_Access is access all Received_Compound_Credentials'Class; -- -- Target Credentials -- -- type Target_Compound_Credentials is new Compound_Credentials with private; function Create_Credentials (Section_Name : String) return Credentials_Ref; function Create_Received_Compound_Credentials (Accepting : Credentials_Ref; Transport : Credentials_Ref) return Credentials_Ref; private type Compound_Credentials is new Credentials with record Transport : Credentials_Ref; Authentication : Credentials_Ref; end record; -- Derived from Credentials function Credentials_Type (Self : access Compound_Credentials) return Invocation_Credentials_Type; function Get_Accepting_Options_Supported (Self : access Compound_Credentials) return PolyORB.Security.Types.Association_Options; -- procedure Set_Accepting_Options_Supported -- (Self : access Compound_Credentials; -- Options : PolyORB.Security.Types.Association_Options); function Get_Accepting_Options_Required (Self : access Compound_Credentials) return PolyORB.Security.Types.Association_Options; -- procedure Set_Accepting_Options_Required -- (Self : access Compound_Credentials; -- Options : PolyORB.Security.Types.Association_Options); function Get_Invocation_Options_Supported (Self : access Compound_Credentials) return PolyORB.Security.Types.Association_Options; -- procedure Set_Invocation_Options_Supported -- (Self : access Compound_Credentials; -- Options : PolyORB.Security.Types.Association_Options); function Get_Invocation_Options_Required (Self : access Compound_Credentials) return PolyORB.Security.Types.Association_Options; -- procedure Set_Invocation_Options_Required -- (Self : access Compound_Credentials; -- Options : PolyORB.Security.Types.Association_Options); function Get_Identity (Self : access Compound_Credentials) return PolyORB.Security.Identities.Identity_Access; type Received_Compound_Credentials is new Compound_Credentials with record Accepting : Credentials_Ref; end record; -- type Target_Compound_Credentials is new Compound_Credentials with record -- Initiating : Credentials_Ref; -- end record; end PolyORB.Security.Credentials.Compound; polyorb-2.8~20110207.orig/src/security/x509/0000755000175000017500000000000011750740340017545 5ustar xavierxavierpolyorb-2.8~20110207.orig/src/security/x509/polyorb-x509.ads0000644000175000017500000001372211750740340022434 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . X 5 0 9 -- -- -- -- S p e c -- -- -- -- Copyright (C) 2005-2008, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with Ada.Streams; package PolyORB.X509 is type Name is private; type Certificate is private; type Certificate_Chain is private; -- type Private_Key is private; -- Exceptions X509_Error : exception; -- X.509 Name function Duplicate (The_Name : Name) return Name; procedure Destroy (The_Name : in out Name); function Decode (Item : Ada.Streams.Stream_Element_Array) return Name; function Encode (The_Name : Name) return Ada.Streams.Stream_Element_Array; function To_String (The_Name : Name) return String; -- X.509 Certificate function Read (File_Name : String) return Certificate; procedure Destroy (The_Certificate : in out Certificate); function Subject_Name_Of (The_Certificate : Certificate) return PolyORB.X509.Name; -- X.509 Certificate Chain function Decode (Item : Ada.Streams.Stream_Element_Array) return Certificate_Chain; function Encode (Item : Certificate_Chain) return Ada.Streams.Stream_Element_Array; -- procedure Check_Private_Key -- (The_Certificate : Certificate; -- The_Private_Key : Private_Key); -- -- -- Private Key -- -- function Read (File_Name : String) return Private_Key; -- -- procedure Free (The_Private_Key : in out Private_Key); -- -- -- X509 Certificate Validation Stuff -- -- type X509_Store is private; -- -- type X509_Lookup is private; -- -- type X509_Context is private; -- -- type Stack_Of_Certificate is private; -- -- -- X509 STORE -- -- function Create return X509_Store; -- -- procedure Free (Store : in out X509_Store); -- -- procedure Add_System_Certificate_Authority (Store : X509_Store); -- -- procedure Add_Certificate_Authority_File -- (Store : X509_Store; -- Certificate_Authority_File : String); -- -- procedure Add_Certificate_Authority_Path -- (Store : X509_Store; -- Certificate_Authority_Path : String); -- -- procedure Add_Certificate_Revocation_List_File -- (Store : X509_Store; -- Certificate_Revocation_List_File : String); -- -- -- X509 LOOKUP -- -- procedure Free (Lookup : in out X509_Lookup); -- -- -- X509 STORE CTX -- -- function Create -- (Store : X509_Store; -- The_Certificate : Certificate) -- return X509_Context; -- -- function Verify (Context : X509_Context) return Boolean; -- -- function Verify_Chain (Context : X509_Context) return Stack_Of_Certificate; -- -- procedure Free (Context : in out X509_Context); -- -- -- STACK OF Certificate -- -- function Length (Stack : Stack_Of_Certificate) return Natural; private -- X.509 Name type Name_Record is null record; pragma Convention (C, Name_Record); type Name is access all Name_Record; -- X.509 Certificate type Certificate_Record is null record; pragma Convention (C, Certificate_Record); type Certificate is access all Certificate_Record; type Certificate_Chain_Record is null record; pragma Convention (C, Certificate_Chain_Record); type Certificate_Chain is access all Certificate_Chain_Record; -- type Private_Key_Record is null record; -- pragma Convention (C, Private_Key_Record); -- -- type Private_Key is access all Private_Key_Record; -- -- type X509_Store_Record is null record; -- pragma Convention (C, X509_Store_Record); -- -- type X509_Store is access all X509_Store_Record; -- -- type X509_Lookup_Record is null record; -- pragma Convention (C, X509_Lookup_Record); -- -- type X509_Lookup is access all X509_Lookup_Record; -- -- type X509_Context_Record is null record; -- pragma Convention (C, X509_Context_Record); -- -- type X509_Context is access all X509_Context_Record; -- -- type Stack_Of_Certificate_Record is null record; -- pragma Convention (C, Stack_Of_Certificate_Record); -- -- type Stack_Of_Certificate is access all Stack_Of_Certificate_Record; -- -- pragma Import (C, Verify_Chain, "X509_STORE_CTX_get_chain"); end PolyORB.X509; polyorb-2.8~20110207.orig/src/security/x509/polyorb-security-identities-distinguished_name.adb0000644000175000017500000001255611750740340031561 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- POLYORB.SECURITY.IDENTITIES.DISTINGUISHED_NAME -- -- -- -- B o d y -- -- -- -- Copyright (C) 2005-2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with PolyORB.Initialization; with PolyORB.Utils.Strings; package body PolyORB.Security.Identities.Distinguished_Name is use PolyORB.Errors; use PolyORB.X509; function Create_Empty_Distinguished_Name_Identity return Identity_Access; procedure Initialize; ------------ -- Create -- ------------ function Create (The_Name : PolyORB.X509.Name) return Identity_Access is begin return new Distinguished_Name_Identity_Type'(Name => The_Name); end Create; ---------------------------------------------- -- Create_Empty_Distinguished_Name_Identity -- ---------------------------------------------- function Create_Empty_Distinguished_Name_Identity return Identity_Access is begin return new Distinguished_Name_Identity_Type; end Create_Empty_Distinguished_Name_Identity; ------------ -- Decode -- ------------ procedure Decode (Self : access Distinguished_Name_Identity_Type; Item : Ada.Streams.Stream_Element_Array; Error : in out PolyORB.Errors.Error_Container) is begin Self.Name := Decode (Item); exception when X509_Error => Throw (Error, Marshal_E, System_Exception_Members'(Minor => 0, Completed => Completed_No)); end Decode; --------------- -- Duplicate -- --------------- function Duplicate (Self : access Distinguished_Name_Identity_Type) return Identity_Access is begin return new Distinguished_Name_Identity_Type'(Name => Duplicate (Self.Name)); end Duplicate; ------------ -- Encode -- ------------ function Encode (Self : access Distinguished_Name_Identity_Type) return Ada.Streams.Stream_Element_Array is begin return Encode (Self.Name); end Encode; ------------------------ -- Get_Printable_Name -- ------------------------ function Get_Printable_Name (Self : access Distinguished_Name_Identity_Type) return String is begin return "[DN]" & To_String (Self.Name); end Get_Printable_Name; -------------------- -- Get_Token_Type -- -------------------- function Get_Token_Type (Self : access Distinguished_Name_Identity_Type) return PolyORB.Security.Types.Identity_Token_Type is pragma Unreferenced (Self); begin return PolyORB.Security.Types.ITT_Distinguished_Name; end Get_Token_Type; ---------------- -- Initialize -- ---------------- procedure Initialize is begin Register (PolyORB.Security.Types.ITT_Distinguished_Name, Create_Empty_Distinguished_Name_Identity'Access); end Initialize; ---------------------- -- Release_Contents -- ---------------------- procedure Release_Contents (Self : access Distinguished_Name_Identity_Type) is begin Destroy (Self.Name); end Release_Contents; begin declare use PolyORB.Initialization; use PolyORB.Initialization.String_Lists; use PolyORB.Utils.Strings; begin Register_Module (Module_Info' (Name => +"polyorb.security.identities.distinguished_name", Conflicts => Empty, Depends => +"x509", Provides => Empty, Implicit => False, Init => Initialize'Access, Shutdown => null)); end; end PolyORB.Security.Identities.Distinguished_Name; polyorb-2.8~20110207.orig/src/security/x509/polyorb-security-identities-distinguished_name.ads0000644000175000017500000000624611750740340031601 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- POLYORB.SECURITY.IDENTITIES.DISTINGUISHED_NAME -- -- -- -- S p e c -- -- -- -- Copyright (C) 2005-2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with PolyORB.X509; package PolyORB.Security.Identities.Distinguished_Name is type Distinguished_Name_Identity_Type is new Identity_Type with private; function Create (The_Name : PolyORB.X509.Name) return Identity_Access; private type Distinguished_Name_Identity_Type is new Identity_Type with record Name : PolyORB.X509.Name; end record; -- Derived from Identity_Type function Get_Token_Type (Self : access Distinguished_Name_Identity_Type) return PolyORB.Security.Types.Identity_Token_Type; function Get_Printable_Name (Self : access Distinguished_Name_Identity_Type) return String; function Duplicate (Self : access Distinguished_Name_Identity_Type) return Identity_Access; procedure Release_Contents (Self : access Distinguished_Name_Identity_Type); function Encode (Self : access Distinguished_Name_Identity_Type) return Ada.Streams.Stream_Element_Array; procedure Decode (Self : access Distinguished_Name_Identity_Type; Item : Ada.Streams.Stream_Element_Array; Error : in out PolyORB.Errors.Error_Container); end PolyORB.Security.Identities.Distinguished_Name; polyorb-2.8~20110207.orig/src/security/x509/polyorb_x509.c0000644000175000017500000001664711750740340022202 0ustar xavierxavier/***************************************************************************** ** ** ** POLYORB COMPONENTS ** ** ** ** P O L Y O R B . X 5 0 9 ** ** ** ** C s u p p o r t f i l e ** ** ** ** Copyright (C) 2005 Free Software Foundation, Inc. ** ** ** ** PolyORB is free software; you can redistribute it and/or modify it ** ** under terms of the GNU General Public License as published by the Free ** ** Software Foundation; either version 2, or (at your option) any later ** ** version. PolyORB is distributed in the hope that it will be useful, ** ** but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- ** ** TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public ** ** License for more details. You should have received a copy of the GNU ** ** General Public License distributed with PolyORB; see file COPYING. If ** ** not, write to the Free Software Foundation, 51 Franklin Street, Fifth ** ** Floor, Boston, MA 02111-1301, USA. ** ** ** ** ** ** PolyORB is maintained by AdaCore ** ** (email: sales at adacore.com) ** ** ** *****************************************************************************/ #include #include typedef STACK_OF(X509) X509_CHAIN; DECLARE_ASN1_FUNCTIONS(X509_CHAIN) #define POLYORB_F_PEM_READ_PRIVATEKEY_FILE 100 #define POLYORB_F_PEM_READ_CERTIFICATE_FILE 101 #define ERR_LIB_POLYORB ERR_LIB_USER #define PolyORBerr(f,r) ERR_PUT_error(ERR_LIB_POLYORB,(f),(r),__FILE__,__LINE__) /* End of header */ #include #include #include #include #include ASN1_ITEM_TEMPLATE(X509_CHAIN) = ASN1_EX_TEMPLATE_TYPE(ASN1_TFLG_SEQUENCE_OF, 0, CertificateChain, X509) ASN1_ITEM_TEMPLATE_END(X509_CHAIN) IMPLEMENT_ASN1_FUNCTIONS(X509_CHAIN) /*****************************/ /* __PolyORB_Get_CRYPTO_LOCK */ /*****************************/ unsigned int __PolyORB_Get_CRYPTO_LOCK (void) { return (unsigned int) (CRYPTO_LOCK); } /****************************/ /* __PolyORB_d2i_X509_CHAIN */ /****************************/ X509_CHAIN *__PolyORB_d2i_X509_CHAIN(unsigned char *buffer, int length) { unsigned char *aux = buffer; return d2i_X509_CHAIN(NULL, &aux, length); } /***************************/ /* __PolyORB_d2i_X509_NAME */ /***************************/ X509_NAME *__PolyORB_d2i_X509_NAME(unsigned char *buffer, int length) { unsigned char *aux = buffer; return d2i_X509_NAME(NULL, &aux, length); } /****************************/ /* __PolyORB_i2d_X509_CHAIN */ /****************************/ void __PolyORB_i2d_X509_CHAIN(STACK_OF(X509) *chain, unsigned char **buffer, int *length) { unsigned char *aux; /* Calculate required buffer length */ *length = i2d_X509_CHAIN(chain, NULL); if (*length < 0) { return; } /* Allocate buffer */ *buffer = OPENSSL_malloc(*length); if (*buffer == NULL) { return; } /* Encode X.509 Certificate Chain */ aux = *buffer; *length = i2d_X509_CHAIN(chain, &aux); if (*length < 0) { OPENSSL_free(*buffer); *buffer = NULL; } } /***************************/ /* __PolyORB_i2d_X509_NAME */ /***************************/ void __PolyORB_i2d_X509_NAME(X509_NAME *name, unsigned char **buffer, int *length) { unsigned char *aux; /* Calculate required buffer length */ *length = i2d_X509_NAME(name, NULL); if (*length < 0) { return; } /* Allocate buffer */ *buffer = OPENSSL_malloc(*length); if (*buffer == NULL) { return; } /* Encode X.509 NAME */ aux = *buffer; *length = i2d_X509_NAME(name, &aux); if (*length < 0) { OPENSSL_free(*buffer); *buffer = NULL; } } /***************************************/ /* __PolyORB_PEM_read_certificate_file */ /***************************************/ X509 *__PolyORB_PEM_read_certificate_file (const char *file) { BIO *in; X509 *pkey = NULL; in = BIO_new(BIO_s_file_internal()); if (in == NULL) { PolyORBerr(POLYORB_F_PEM_READ_CERTIFICATE_FILE, ERR_R_BUF_LIB); goto end; }; if (BIO_read_filename(in, file) <= 0) { PolyORBerr(POLYORB_F_PEM_READ_CERTIFICATE_FILE, ERR_R_SYS_LIB); goto end; }; pkey = PEM_read_bio_X509(in, NULL, NULL, NULL); if (pkey == NULL) { PolyORBerr(POLYORB_F_PEM_READ_CERTIFICATE_FILE, ERR_R_PEM_LIB); goto end; } end: if (in != NULL) BIO_free(in); return pkey; } /**************************************/ /* __PolyORB_PEM_read_PrivateKey_file */ /**************************************/ EVP_PKEY *__PolyORB_PEM_read_PrivateKey_file (const char *file) { BIO *in; EVP_PKEY *pkey = NULL; in = BIO_new(BIO_s_file_internal()); if (in == NULL) { PolyORBerr(POLYORB_F_PEM_READ_PRIVATEKEY_FILE, ERR_R_BUF_LIB); goto end; }; if (BIO_read_filename(in, file) <= 0) { PolyORBerr(POLYORB_F_PEM_READ_PRIVATEKEY_FILE, ERR_R_SYS_LIB); goto end; }; pkey = PEM_read_bio_PrivateKey(in, NULL, NULL, NULL); if (pkey == NULL) { PolyORBerr(POLYORB_F_PEM_READ_PRIVATEKEY_FILE, ERR_R_PEM_LIB); goto end; } end: if (in != NULL) BIO_free(in); return pkey; } /*************************/ /* __PolyORB_sk_X509_num */ /*************************/ /* int __PolyORB_sk_X509_num (STACK_OF(X509) *sk) { return sk_X509_num(sk); } */ #define ERR_FUNC(func) ERR_PACK(ERR_LIB_POLYORB, func, 0) #define ERR_REASON(reason) ERR_PACK(ERR_LIB_POLYORB, 0, reason) static ERR_STRING_DATA USER_str_functs[] = { {ERR_FUNC(POLYORB_F_PEM_READ_PRIVATEKEY_FILE), "__PolyORB_PEM_read_PrivateKey_file"}, {ERR_FUNC(POLYORB_F_PEM_READ_CERTIFICATE_FILE), "__PolyORB_PEM_read_certificate_file"}, {0, NULL} }; static ERR_STRING_DATA USER_str_reasons[] = { {0, NULL} }; /****************************/ /* ERR_load_PolyORB_strings */ /****************************/ void ERR_load_PolyORB_strings(void) { static int init = 1; if (init) { init = 0; ERR_load_strings(0, USER_str_functs); ERR_load_strings(0, USER_str_reasons); } } /****************************/ /* __PolyORB_X509_Intialize */ /****************************/ void __PolyORB_X509_Intialize (void (*locking_function)(int mode, int n, const char *file, int line), unsigned long (*id_function)(void)) { CRYPTO_set_locking_callback (locking_function); CRYPTO_set_id_callback (id_function); } polyorb-2.8~20110207.orig/src/security/x509/polyorb-x509.adb0000644000175000017500000005657011750740340022423 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . X 5 0 9 -- -- -- -- B o d y -- -- -- -- Copyright (C) 2005-2008, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with Ada.Characters.Latin_1; with Ada.Exceptions; with Interfaces.C.Strings; with Interfaces.C.Pointers; with System.Storage_Elements; with PolyORB.Initialization; with PolyORB.Tasking.Mutexes; with PolyORB.Tasking.Threads; with PolyORB.Utils.Strings; package body PolyORB.X509 is use Interfaces; use type C.int; package PTM renames PolyORB.Tasking.Mutexes; package PTT renames PolyORB.Tasking.Threads; -- type X509_Lookup_Method_Record is null record; -- pragma Convention (C, X509_Lookup_Method_Record); -- -- type X509_Lookup_Method is access all X509_Lookup_Method_Record; package Stream_Element_Pointers is new Interfaces.C.Pointers (Ada.Streams.Stream_Element_Offset, Ada.Streams.Stream_Element, Ada.Streams.Stream_Element_Array, 0); use Stream_Element_Pointers; ------------------ -- Crypto locks -- ------------------ -- OpenSSL relies on the user to provide thread identification and a -- mutual exclusion facility. In the case of PolyORB, we rely on -- PolyORB.Tasking to provide both facilities. type Lock_Array is array (C.int range <>) of PTM.Mutex_Access; type Lock_Array_Access is access Lock_Array; Crypto_Locks : Lock_Array_Access; -- A set of n locks, where n is the value returned by OpenSSL function -- CRYPTO_num_locks. These are used to implement the OpenSSL locking -- callback. procedure PolyORB_Locking_Function (Mode : C.unsigned; N : C.int; File : C.Strings.chars_ptr; Line : C.int); pragma Convention (C, PolyORB_Locking_Function); -- Callback for CRYPTO_set_locking_callback: -- Lock or unlock (depending on whether (Mode and CRYPTO_LOCK) is nonzero) -- the N'th lock in Crypto_Locks. -- File and Line denote a source location in the OpenSSL library, and are -- provided for debugging purposes. function PolyORB_Id_Function return C.unsigned_long; pragma Convention (C, PolyORB_Id_Function); -- Callback for CRYPTO_set_id_callback: -- Return an unsigned long value identifying the current thread. procedure Initialize; procedure Raise_X509_Error; package Thin is type SSL_Error_Code is new Interfaces.C.unsigned_long; ------------------------------- -- Generic CRYPTO operations -- ------------------------------- function CRYPTO_num_locks return C.int; -- Number of locks to be allocated for locking callback function Get_CRYPTO_LOCK return C.unsigned; -- Function returning the value of C macro CRYPTO_LOCK (used for -- Mode parameter in locking callback). CRYPTO_LOCK : constant C.unsigned; -- Constant used to cache the value of C macro CRYPTO_LOCK --------------------------- -- X.509 Name operations -- --------------------------- procedure X509_NAME_free (Item : Name); function X509_NAME_dup (Item : Name) return Name; function d2i_X509_NAME (Buffer : Ada.Streams.Stream_Element_Array; Length : C.int) return Name; procedure i2d_X509_NAME (Item : Name; Buffer : out Stream_Element_Pointers.Pointer; Length : out C.int); function X509_NAME_oneline (The_Name : Name) return String; ---------------------------------- -- X.509 Certificate operations -- ---------------------------------- procedure X509_free (The_Certificate : Certificate); function X509_get_subject_name (The_Certificate : Certificate) return PolyORB.X509.Name; ---------------------------------------- -- X.509 Certificate Chain operations -- ---------------------------------------- function d2i_X509_CHAIN (Buffer : Ada.Streams.Stream_Element_Array; Length : C.int) return Certificate_Chain; procedure i2d_X509_CHAIN (Item : Certificate_Chain; Buffer : out Stream_Element_Pointers.Pointer; Length : out C.int); -------------------------------- -- Error handling subprograms -- -------------------------------- function ERR_get_error return SSL_Error_Code; function ERR_error_string (Error_Code : SSL_Error_Code) return String; ----------------------- -- Memory management -- ----------------------- procedure OPENSSL_free (Item : Stream_Element_Pointers.Pointer); ------------------------ -- PolyORB extensions -- ------------------------ procedure ERR_load_PolyORB_strings; procedure Initialize (Locking_Function : System.Address; Id_Function : System.Address); -- Perform any required initialization at the C level. -- Locking_Function is passed to CRYPTO_set_locking_callback. -- Id_Function is passed to CRYPTO_set_id_callback. private pragma Import (C, CRYPTO_num_locks, "CRYPTO_num_locks"); pragma Import (C, Get_CRYPTO_LOCK, "__PolyORB_Get_CRYPTO_LOCK"); pragma Import (C, ERR_get_error, "ERR_get_error"); pragma Import (C, ERR_load_PolyORB_strings, "ERR_load_PolyORB_strings"); pragma Import (C, OPENSSL_free, "__PolyORB_OPENSSL_free"); pragma Import (C, X509_NAME_dup, "X509_NAME_dup"); pragma Import (C, X509_NAME_free, "X509_NAME_free"); pragma Import (C, X509_free, "X509_free"); pragma Import (C, X509_get_subject_name, "X509_get_subject_name"); pragma Import (C, d2i_X509_CHAIN, "__PolyORB_d2i_X509_CHAIN"); pragma Import (C, d2i_X509_NAME, "__PolyORB_d2i_X509_NAME"); pragma Import (C, i2d_X509_CHAIN, "__PolyORB_i2d_X509_CHAIN"); pragma Import (C, i2d_X509_NAME, "__PolyORB_i2d_X509_NAME"); pragma Import (C, Initialize, "__PolyORB_X509_Intialize"); CRYPTO_LOCK : constant C.unsigned := Get_CRYPTO_LOCK; end Thin; -- ------------------------------------ -- -- Add_Certificate_Authority_File -- -- ------------------------------------ -- -- procedure Add_Certificate_Authority_File -- (Store : X509_Store; -- Certificate_Authority_File : String) -- is -- -- function X509_STORE_load_locations -- (Store : X509_Store; -- File : Interfaces.C.char_array; -- Path : Interfaces.C.Strings.chars_ptr) -- return C.int; -- pragma Import -- (C, X509_STORE_load_locations, "X509_STORE_load_locations"); -- -- begin -- if X509_STORE_load_locations -- (Store, -- Interfaces.C.To_C (Certificate_Authority_File), -- Interfaces.C.Strings.Null_Ptr) /= 1 -- then -- Raise_X509_Error; -- end if; -- end Add_Certificate_Authority_File; -- -- ------------------------------------ -- -- Add_Certificate_Authority_Path -- -- ------------------------------------ -- -- procedure Add_Certificate_Authority_Path -- (Store : X509_Store; -- Certificate_Authority_Path : String) -- is -- -- function X509_STORE_load_locations -- (Store : X509_Store; -- Path : Interfaces.C.Strings.chars_ptr; -- File : Interfaces.C.char_array) -- return C.int; -- pragma Import -- (C, X509_STORE_load_locations, "X509_STORE_load_locations"); -- -- begin -- if X509_STORE_load_locations -- (Store, -- Interfaces.C.Strings.Null_Ptr, -- Interfaces.C.To_C (Certificate_Authority_Path)) /= 1 -- then -- Raise_X509_Error; -- end if; -- end Add_Certificate_Authority_Path; -- -- ------------------------------------------ -- -- Add_Certificate_Revocation_List_File -- -- ------------------------------------------ -- -- procedure Add_Certificate_Revocation_List_File -- (Store : X509_Store; -- Certificate_Revocation_List_File : String) -- is -- -- function X509_LOOKUP_file return X509_Lookup_Method; -- pragma Import (C, X509_LOOKUP_file, "X509_LOOKUP_file"); -- -- function X509_STORE_add_lookup -- (Store : X509_Store; -- Method : X509_Lookup_Method) -- return X509_Lookup; -- pragma Import (C, X509_STORE_add_lookup, "X509_STORE_add_lookup"); -- -- function X509_load_crl_file -- (Lookup : X509_Lookup; -- File_Name : Interfaces.C.char_array; -- File_Type : C.int) -- return C.int; -- pragma Import (C, X509_load_crl_file, "X509_load_crl_file"); -- -- Lookup : constant X509_Lookup -- := X509_STORE_add_lookup (Store, X509_LOOKUP_file); -- -- begin -- if Lookup = null then -- Raise_X509_Error; -- end if; -- -- if X509_load_crl_file -- (Lookup, -- Interfaces.C.To_C (Certificate_Revocation_List_File), -- 1) /= 1 -- then -- Raise_X509_Error; -- end if; -- end Add_Certificate_Revocation_List_File; -- -- -------------------------------------- -- -- Add_System_Certificate_Authority -- -- -------------------------------------- -- -- procedure Add_System_Certificate_Authority (Store : X509_Store) is -- -- function X509_STORE_set_default_paths -- (Store : X509_Store) -- return C.int; -- pragma Import -- (C, X509_STORE_set_default_paths, "X509_STORE_set_default_paths"); -- -- begin -- if X509_STORE_set_default_paths (Store) /= 1 then -- Raise_X509_Error; -- end if; -- end Add_System_Certificate_Authority; -- -- ----------------------- -- -- Check_Private_Key -- -- ----------------------- -- -- procedure Check_Private_Key -- (The_Certificate : Certificate; -- The_Private_Key : Private_Key) -- is -- -- function X509_check_private_key -- (The_Certificate : Certificate; -- The_Private_Key : Private_Key) -- return C.int; -- pragma Import (C, X509_check_private_key, "X509_check_private_key"); -- -- begin -- if X509_check_private_key (The_Certificate, The_Private_Key) /= 1 then -- Raise_X509_Error; -- end if; -- end Check_Private_Key; -- -- ------------ -- -- Create -- -- ------------ -- -- function Create return X509_Store is -- -- function X509_STORE_new return X509_Store; -- pragma Import (C, X509_STORE_new, "X509_STORE_new"); -- -- Aux : constant X509_Store := X509_STORE_new; -- -- begin -- if Aux = null then -- Raise_X509_Error; -- end if; -- -- return Aux; -- end Create; -- -- function Create -- (Store : X509_Store; -- The_Certificate : Certificate) -- return X509_Context -- is -- -- function X509_STORE_CTX_new return X509_Context; -- pragma Import (C, X509_STORE_CTX_new, "X509_STORE_CTX_new"); -- -- function X509_STORE_CTX_init -- (Context : X509_Context; -- Store : X509_Store; -- The_Certificate : Certificate; -- Chain : Stack_Of_Certificate) -- return C.int; -- pragma Import (C, X509_STORE_CTX_init, "X509_STORE_CTX_init"); -- -- Context : constant X509_Context := X509_STORE_CTX_new; -- -- begin -- if Context = null then -- Raise_X509_Error; -- end if; -- -- if X509_STORE_CTX_init (Context, Store, The_Certificate, null) /= 1 then -- Raise_X509_Error; -- end if; -- -- return Context; -- end Create; ------------ -- Decode -- ------------ function Decode (Item : Ada.Streams.Stream_Element_Array) return Certificate_Chain is Result : Certificate_Chain; begin Result := Thin.d2i_X509_CHAIN (Item, Item'Length); if Result = null then Raise_X509_Error; end if; return Result; end Decode; ------------ -- Decode -- ------------ function Decode (Item : Ada.Streams.Stream_Element_Array) return Name is Result : Name; begin Result := Thin.d2i_X509_NAME (Item, Item'Length); if Result = null then Raise_X509_Error; end if; return Result; end Decode; ------------- -- Destroy -- ------------- procedure Destroy (The_Certificate : in out Certificate) is begin if The_Certificate /= null then Thin.X509_free (The_Certificate); The_Certificate := null; end if; end Destroy; ------------- -- Destroy -- ------------- procedure Destroy (The_Name : in out Name) is begin if The_Name /= null then Thin.X509_NAME_free (The_Name); The_Name := null; end if; end Destroy; --------------- -- Duplicate -- --------------- function Duplicate (The_Name : Name) return Name is begin if The_Name = null then return null; else return Thin.X509_NAME_dup (The_Name); end if; end Duplicate; ------------ -- Encode -- ------------ function Encode (Item : Certificate_Chain) return Ada.Streams.Stream_Element_Array is Buffer : Stream_Element_Pointers.Pointer; Length : C.int; begin Thin.i2d_X509_CHAIN (Item, Buffer, Length); if Length < 0 or else Buffer = null then Raise_X509_Error; end if; declare Result : constant Ada.Streams.Stream_Element_Array := Value (Buffer, C.ptrdiff_t (Length)); begin Thin.OPENSSL_free (Buffer); return Result; end; end Encode; ------------ -- Encode -- ------------ function Encode (The_Name : Name) return Ada.Streams.Stream_Element_Array is Buffer : Stream_Element_Pointers.Pointer; Length : C.int; begin Thin.i2d_X509_NAME (The_Name, Buffer, Length); if Length < 0 or else Buffer = null then Raise_X509_Error; end if; declare Result : constant Ada.Streams.Stream_Element_Array := Value (Buffer, C.ptrdiff_t (Length)); begin Thin.OPENSSL_free (Buffer); return Result; end; end Encode; -- procedure Free (The_Private_Key : in out Private_Key) is -- -- procedure EVP_PKEY_free (The_Private_Key : Private_Key); -- pragma Import (C, EVP_PKEY_free, "EVP_PKEY_free"); -- -- begin -- if The_Private_Key /= null then -- EVP_PKEY_free (The_Private_Key); -- The_Private_Key := null; -- end if; -- end Free; -- -- procedure Free (Lookup : in out X509_Lookup) is -- -- procedure X509_LOOKUP_free (Lookup : X509_Lookup); -- pragma Import (C, X509_LOOKUP_free, "X509_LOOKUP_free"); -- -- begin -- if Lookup /= null then -- X509_LOOKUP_free (Lookup); -- Lookup := null; -- end if; -- end Free; -- -- procedure Free (Store : in out X509_Store) is -- -- procedure X509_STORE_free (Store : X509_Store); -- pragma Import (C, X509_STORE_free, "X509_STORE_free"); -- -- begin -- if Store /= null then -- X509_STORE_free (Store); -- Store := null; -- end if; -- end Free; -- -- procedure Free (Context : in out X509_Context) is -- -- procedure X509_STORE_CTX_free (Store : X509_Context); -- pragma Import (C, X509_STORE_CTX_free, "X509_STORE_CTX_free"); -- -- begin -- if Context /= null then -- X509_STORE_CTX_free (Context); -- Context := null; -- end if; -- end Free; ---------------- -- Initialize -- ---------------- procedure Initialize is begin Crypto_Locks := new Lock_Array (0 .. Thin.CRYPTO_num_locks - 1); for J in Crypto_Locks'Range loop PTM.Create (Crypto_Locks (J)); end loop; Thin.Initialize (Locking_Function => PolyORB_Locking_Function'Address, Id_Function => PolyORB_Id_Function'Address); Thin.ERR_load_PolyORB_strings; end Initialize; -- ------------ -- -- Length -- -- ------------ -- -- function Length (Stack : Stack_Of_Certificate) return Natural is -- -- function sk_X509_num -- (Item : Stack_Of_Certificate) -- return C.int; -- pragma Import (C, sk_X509_num, "__PolyORB_sk_X509_num"); -- -- begin -- return Natural (sk_X509_num (Stack)); -- end Length; ------------------------------ -- PolyORB_Locking_Function -- ------------------------------ procedure PolyORB_Locking_Function (Mode : C.unsigned; N : C.int; File : C.Strings.chars_ptr; Line : C.int) is pragma Unreferenced (File, Line); use type C.unsigned; begin if (Mode and Thin.CRYPTO_LOCK) /= 0 then PTM.Enter (Crypto_Locks (N)); else PTM.Leave (Crypto_Locks (N)); end if; end PolyORB_Locking_Function; ------------------------- -- PolyORB_Id_Function -- ------------------------- function PolyORB_Id_Function return C.unsigned_long is begin return C.unsigned_long (System.Storage_Elements.To_Integer (PTT.To_Address (PTT.Current_Task))); end PolyORB_Id_Function; ---------------------- -- Raise_X509_Error -- ---------------------- procedure Raise_X509_Error is function Get_Errors_String return String; ----------------------- -- Get_Errors_String -- ----------------------- function Get_Errors_String return String is use type Thin.SSL_Error_Code; Error : constant Thin.SSL_Error_Code := Thin.ERR_get_error; begin if Error /= 0 then return Get_Errors_String & Ada.Characters.Latin_1.LF & Thin.ERR_error_string (Error); else return ""; end if; end Get_Errors_String; begin Ada.Exceptions.Raise_Exception (X509_Error'Identity, Get_Errors_String); end Raise_X509_Error; ---------- -- Read -- ---------- function Read (File_Name : String) return Certificate is function PEM_read_certificate_file (File : Interfaces.C.char_array) return Certificate; pragma Import (C, PEM_read_certificate_file, "__PolyORB_PEM_read_certificate_file"); Aux : constant Certificate := PEM_read_certificate_file (Interfaces.C.To_C (File_Name)); begin if Aux = null then Raise_X509_Error; end if; return Aux; end Read; -- function Read (File_Name : String) return Private_Key is -- -- function PEM_read_PrivateKey_file -- (File : Interfaces.C.char_array) -- return Private_Key; -- pragma Import (C, PEM_read_PrivateKey_file, -- "__PolyORB_PEM_read_PrivateKey_file"); -- -- Aux : constant Private_Key -- := PEM_read_PrivateKey_file (Interfaces.C.To_C (File_Name)); -- -- begin -- if Aux = null then -- Raise_X509_Error; -- end if; -- -- return Aux; -- end Read; --------------------- -- Subject_Name_Of -- --------------------- function Subject_Name_Of (The_Certificate : Certificate) return PolyORB.X509.Name is begin return Thin.X509_get_subject_name (The_Certificate); end Subject_Name_Of; ---------- -- Thin -- ---------- package body Thin is ---------------------- -- ERR_error_string -- ---------------------- function ERR_error_string (Error_Code : SSL_Error_Code) return String is procedure ERR_error_string_n (Error_Code : SSL_Error_Code; Buf : Interfaces.C.char_array; Len : Interfaces.C.size_t); pragma Import (C, ERR_error_string_n, "ERR_error_string_n"); Buffer : Interfaces.C.char_array (1 .. 1024); pragma Warnings (Off, Buffer); -- Buffer not needed to be initialized and modified, because -- of side effect of C function ERR_error_string_n begin ERR_error_string_n (Error_Code, Buffer, Buffer'Length); return Interfaces.C.To_Ada (Buffer); end ERR_error_string; ----------------------- -- X509_NAME_oneline -- ----------------------- function X509_NAME_oneline (The_Name : Name) return String is procedure X509_NAME_oneline (The_Name : Name; Buffer : Interfaces.C.char_array; Length : C.int); pragma Import (C, X509_NAME_oneline, "X509_NAME_oneline"); Buffer : Interfaces.C.char_array (1 .. 1024); pragma Warnings (Off, Buffer); -- Buffer not needed to be initialized and modified, because -- of side effect of C function X509_NAME_oneline begin X509_NAME_oneline (The_Name, Buffer, Buffer'Length); return Interfaces.C.To_Ada (Buffer); end X509_NAME_oneline; end Thin; --------------- -- To_String -- --------------- function To_String (The_Name : Name) return String renames Thin.X509_NAME_oneline; -- ------------ -- -- Verify -- -- ------------ -- -- function Verify (Context : X509_Context) return Boolean is -- -- function X509_verify_cert -- (Context : X509_Context) -- return C.int; -- pragma Import (C, X509_verify_cert, "X509_verify_cert"); -- -- begin -- return X509_verify_cert (Context) = 1; -- end Verify; begin declare use PolyORB.Initialization; use PolyORB.Initialization.String_Lists; use PolyORB.Utils.Strings; begin Register_Module (Module_Info' (Name => +"x509", Conflicts => Empty, Depends => +"tasking.mutexes", Provides => Empty, Implicit => False, Init => Initialize'Access, Shutdown => null)); end; end PolyORB.X509; polyorb-2.8~20110207.orig/src/security/polyorb-security-exported_names-unknown.adb0000644000175000017500000001104411750740340027553 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- POLYORB.SECURITY.EXPORTED_NAMES.UNKNOWN -- -- -- -- B o d y -- -- -- -- Copyright (C) 2005-2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with Ada.Unchecked_Deallocation; package body PolyORB.Security.Exported_Names.Unknown is ---------------------- -- Decode_Name_BLOB -- ---------------------- procedure Decode_Name_BLOB (Item : access Unknown_Exported_Name_Type; BLOB : Ada.Streams.Stream_Element_Array; Error : in out PolyORB.Errors.Error_Container) is pragma Unreferenced (Error); begin Item.Name_BLOB := new Ada.Streams.Stream_Element_Array'(BLOB); end Decode_Name_BLOB; --------------- -- Duplicate -- --------------- function Duplicate (Item : access Unknown_Exported_Name_Type) return Exported_Name_Access is begin return new Unknown_Exported_Name_Type' (Mechanism_OID => PolyORB.ASN1.Duplicate (Item.Mechanism_OID), Name_BLOB => new Ada.Streams.Stream_Element_Array'(Item.Name_BLOB.all)); end Duplicate; ---------------------- -- Encode_Name_BLOB -- ---------------------- function Encode_Name_BLOB (Item : access Unknown_Exported_Name_Type) return Ada.Streams.Stream_Element_Array is begin return Item.Name_BLOB.all; end Encode_Name_BLOB; ------------------------ -- Get_Printable_Name -- ------------------------ function Get_Printable_Name (Item : access Unknown_Exported_Name_Type) return String is pragma Unreferenced (Item); begin return "[UNKNOWN]"; end Get_Printable_Name; ------------------- -- Is_Equivalent -- ------------------- function Is_Equivalent (Left : access Unknown_Exported_Name_Type; Right : access Exported_Name_Type'Class) return Boolean is use type Ada.Streams.Stream_Element_Array; use type PolyORB.ASN1.Object_Identifier; begin if Right.all not in Unknown_Exported_Name_Type then return False; end if; return Left.Mechanism_OID = Right.Mechanism_OID and then Left.Name_BLOB.all = Unknown_Exported_Name_Type (Right.all).Name_BLOB.all; end Is_Equivalent; ---------------------- -- Release_Contents -- ---------------------- procedure Release_Contents (Item : access Unknown_Exported_Name_Type) is procedure Free is new Ada.Unchecked_Deallocation (Ada.Streams.Stream_Element_Array, PolyORB.Security.Types.Stream_Element_Array_Access); begin Free (Item.Name_BLOB); Release_Contents (Exported_Name_Type (Item.all)'Access); end Release_Contents; end PolyORB.Security.Exported_Names.Unknown; polyorb-2.8~20110207.orig/src/security/polyorb-security-forward_trust_evaluators.ads0000644000175000017500000000554111750740340030241 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- POLYORB.SECURITY.FORWARD_TRUST_EVALUATORS -- -- -- -- S p e c -- -- -- -- Copyright (C) 2005-2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with PolyORB.Security.Authorization_Elements; with PolyORB.Security.Identities; package PolyORB.Security.Forward_Trust_Evaluators is type Forward_Trust_Evaluator is abstract tagged null record; type Forward_Trust_Evaluator_Access is access all Forward_Trust_Evaluator'Class; procedure Evaluate_Trust (Evaluator : access Forward_Trust_Evaluator; Target_Identity : PolyORB.Security.Identities.Identity_Access; Client_Identity : PolyORB.Security.Identities.Identity_Access; Authorization_Token : PolyORB.Security.Authorization_Elements. Authorization_Element_Lists.List; Delegation_Required : Boolean; No_Information : out Boolean; Trusted : out Boolean) is abstract; end PolyORB.Security.Forward_Trust_Evaluators; polyorb-2.8~20110207.orig/src/security/polyorb-security-authorization_elements-unknown.ads0000644000175000017500000000614611750740340031362 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- POLYORB.SECURITY.AUTHORIZATION_ELEMENTS.UNKNOWN -- -- -- -- S p e c -- -- -- -- Copyright (C) 2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with PolyORB.Security.Types; package PolyORB.Security.Authorization_Elements.Unknown is type Unknown_Authorization_Element_Type is new Authorization_Element_Type with private; function Get_Authorization_Element_Type (Self : access Unknown_Authorization_Element_Type) return Element_Type; function Is_Holder (Self : access Unknown_Authorization_Element_Type; Identity : PolyORB.Security.Identities.Identity_Access) return Boolean; procedure Release_Contents (Self : access Unknown_Authorization_Element_Type); function Encode (Self : access Unknown_Authorization_Element_Type) return Ada.Streams.Stream_Element_Array; function Create (The_Type : Element_Type; Contents : Ada.Streams.Stream_Element_Array) return Authorization_Element_Access; private type Unknown_Authorization_Element_Type is new Authorization_Element_Type with record The_Type : Element_Type; The_Data : PolyORB.Security.Types.Stream_Element_Array_Access; end record; end PolyORB.Security.Authorization_Elements.Unknown; polyorb-2.8~20110207.orig/src/security/polyorb-asn1.adb0000644000175000017500000001455111750740340022044 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . A S N 1 -- -- -- -- B o d y -- -- -- -- Copyright (C) 2005-2008, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with Interfaces.C.Pointers; with PolyORB.Platform.SSL_Linker_Options; pragma Warnings (Off, PolyORB.Platform.SSL_Linker_Options); -- No entity referenced package body PolyORB.ASN1 is package Stream_Element_Pointers is new Interfaces.C.Pointers (Ada.Streams.Stream_Element_Offset, Ada.Streams.Stream_Element, Ada.Streams.Stream_Element_Array, 0); OID : constant String := "oid:"; ------------ -- Decode -- ------------ function Decode (Item : Ada.Streams.Stream_Element_Array) return Object_Identifier is function d2i_ASN1_OBJECT (Buffer : Ada.Streams.Stream_Element_Array; Length : Interfaces.C.int) return Object_Identifier; pragma Import (C, d2i_ASN1_OBJECT, "__PolyORB_d2i_ASN1_OBJECT"); Result : Object_Identifier; begin Result := d2i_ASN1_OBJECT (Item, Item'Length); if Result = null then raise ASN1_Error; end if; return Result; end Decode; --------------- -- Duplicate -- --------------- function Duplicate (Item : Object_Identifier) return Object_Identifier is function ASN1_OBJECT_dup (Item : Object_Identifier) return Object_Identifier; pragma Import (C, ASN1_OBJECT_dup, "__PolyORB_ASN1_OBJECT_dup"); begin return ASN1_OBJECT_dup (Item); end Duplicate; ------------ -- Encode -- ------------ function Encode (Item : Object_Identifier) return Ada.Streams.Stream_Element_Array is use type Interfaces.C.int; use type Stream_Element_Pointers.Pointer; procedure i2d_ASN1_OBJECT (Item : Object_Identifier; Buffer : out Stream_Element_Pointers.Pointer; Length : out Interfaces.C.int); pragma Import (C, i2d_ASN1_OBJECT, "__PolyORB_i2d_ASN1_OBJECT"); procedure OPENSSL_free (Item : Stream_Element_Pointers.Pointer); pragma Import (C, OPENSSL_free, "__PolyORB_OPENSSL_free"); Buffer : Stream_Element_Pointers.Pointer := null; Length : Interfaces.C.int; begin i2d_ASN1_OBJECT (Item, Buffer, Length); if Length < 0 or else Buffer = null then raise ASN1_Error; end if; declare Result : constant Ada.Streams.Stream_Element_Array := Stream_Element_Pointers.Value (Buffer, Interfaces.C.ptrdiff_t (Length)); begin OPENSSL_free (Buffer); return Result; end; end Encode; ---------- -- Free -- ---------- procedure Free (Item : in out Object_Identifier) is procedure ASN1_OBJECT_free (Item : Object_Identifier); pragma Import (C, ASN1_OBJECT_free, "ASN1_OBJECT_free"); begin ASN1_OBJECT_free (Item); Item := null; end Free; ------------------- -- Is_Equivalent -- ------------------- function Is_Equivalent (OID1 : Object_Identifier; OID2 : Object_Identifier) return Boolean is use type Ada.Streams.Stream_Element_Array; begin return Encode (OID1) = Encode (OID2); end Is_Equivalent; -------------------------- -- To_Object_Identifier -- -------------------------- function To_Object_Identifier (Item : String) return Object_Identifier is function OBJ_txt2obj (S : Interfaces.C.char_array; No_Name : Interfaces.C.int) return Object_Identifier; pragma Import (C, OBJ_txt2obj, "OBJ_txt2obj"); begin if Item'Length < OID'Length or else Item (Item'First .. Item'First + OID'Length - 1) /= OID then raise ASN1_Error; end if; return OBJ_txt2obj (Interfaces.C.To_C (Item (Item'First + OID'Length .. Item'Last)), 1); end To_Object_Identifier; --------------- -- To_String -- --------------- function To_String (Item : Object_Identifier) return String is procedure OBJ_obj2txt (Buffer : Interfaces.C.char_array; Length : Interfaces.C.int; Item : Object_Identifier; No_Name : Interfaces.C.int); pragma Import (C, OBJ_obj2txt, "OBJ_obj2txt"); Buffer : Interfaces.C.char_array (1 .. 80); pragma Warnings (Off, Buffer); -- Buffer changed as side effect of OBJ_obj2txt begin OBJ_obj2txt (Buffer, Buffer'Length, Item, 1); return OID & Interfaces.C.To_Ada (Buffer); end To_String; end PolyORB.ASN1; polyorb-2.8~20110207.orig/src/security/polyorb-security-security_manager.ads0000644000175000017500000000670011750740340026426 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . S E C U R I T Y . S E C U R I T Y _ M A N A G E R -- -- -- -- S p e c -- -- -- -- Copyright (C) 2005-2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- Security Manager pseudo object. It represent capsule specific security -- information. with PolyORB.Security.Credentials; with PolyORB.Security.Transport_Mechanisms; with PolyORB.Security.Types; package PolyORB.Security.Security_Manager is function Own_Credentials return PolyORB.Security.Credentials.Credentials_List; function Get_Transport_Mechanism (Name : String) return PolyORB.Security.Transport_Mechanisms.Target_Transport_Mechanism_Access; -- XXX Unimplemented features from CORBA Security Service Specification -- -- readonly attribute Security::MechandOptionsList supported_mechanisms; -- -- readonly attribute RequiredRights required_rights_object; -- -- readonly attribute PrincipalAuthenticator principal_authenticator; -- -- readonly attribute AccessDecision access_decision; -- -- readonly attribute AuditDecision audit_decision; -- -- TargetCredentials get_target_credentials ( -- in Object obj_ref -- ); -- -- void remove_own_credentials ( -- in Credentials creds -- ); -- -- CORBA::Policy get_security_policy ( -- in CORBA::PolicyType policy_type -- ); function Client_Requires return PolyORB.Security.Types.Association_Options; -- Transport mechsnism registry procedure Register_Transport_Mechanism (Name : String; Mech : PolyORB.Security.Transport_Mechanisms.Target_Transport_Mechanism_Access); end PolyORB.Security.Security_Manager; polyorb-2.8~20110207.orig/src/security/polyorb-security-credentials.ads0000644000175000017500000001336111750740340025363 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . S E C U R I T Y . C R E D E N T I A L S -- -- -- -- S p e c -- -- -- -- Copyright (C) 2005-2008, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with PolyORB.Security.Identities; with PolyORB.Security.Types; with PolyORB.Smart_Pointers; package PolyORB.Security.Credentials is type Credentials is abstract new PolyORB.Smart_Pointers.Non_Controlled_Entity with null record; type Credentials_Access is access all Credentials'Class; type Credentials_Ref is new PolyORB.Smart_Pointers.Ref with null record; type Invocation_Credentials_Type is (Own_Credentials, Received_Credentials, Target_Credentials); -- ??? -- function Credentials_Type -- (Self : access Credentials) -- return Invocation_Credentials_Type -- is abstract; -- Server side Association Options function Get_Accepting_Options_Supported (Self : access Credentials) return PolyORB.Security.Types.Association_Options is abstract; -- procedure Set_Accepting_Options_Supported -- (Self : access Credentials; -- Options : PolyORB.Security.Types.Association_Options) -- is abstract; function Get_Accepting_Options_Required (Self : access Credentials) return PolyORB.Security.Types.Association_Options is abstract; -- procedure Set_Accepting_Options_Required -- (Self : access Credentials; -- Options : PolyORB.Security.Types.Association_Options) -- is abstract; -- Client side Association Options function Get_Invocation_Options_Supported (Self : access Credentials) return PolyORB.Security.Types.Association_Options is abstract; -- procedure Set_Invocation_Options_Supported -- (Self : access Credentials; -- Options : PolyORB.Security.Types.Association_Options) -- is abstract; function Get_Invocation_Options_Required (Self : access Credentials) return PolyORB.Security.Types.Association_Options is abstract; -- procedure Set_Invocation_Options_Required -- (Self : access Credentials; -- Options : PolyORB.Security.Types.Association_Options) -- is abstract; function Get_Identity (Self : access Credentials) return PolyORB.Security.Identities.Identity_Access is abstract; -- function Is_Valid (Self : Ref; Expiry_Time : out Time) return Boolean; -- type Security_Feature is -- (No_Protection, Integrity, Confidentiality, -- Integrity_And_Confidentiality, Detect_Replay, Detect_Misordering, -- Establish_Trust_In_Target, Establish_Trust_In_Client); -- -- from Security Service: No_Delegation, Simple_Delegation, -- -- Composite_Delegation -- -- from CSIv2: Identity_Assertion, Delegation_By_Client -- function Get_Security_Feature -- (Self : Ref; Feature : Security_Feature) return Boolean; -- type Received_Credentials is abstract new Ref with null record; -- function Accepting_Credentials (Self : Ref) return Credentials -- is abstract; -- function Association_Options_Used -- (Self : Received_Credentials) -- return PolyORB.Security.Types.Association_Options -- is abstract; -- procedure Set_Invocation_Options_Required -- (Self : Received_Credentials; -- Options : PolyORB.Security.Types.Association_Options) -- is abstract; -- Delegation_State -- Delegation_Mode -- Credentials Lists type Credentials_List is array (Positive range <>) of PolyORB.Security.Credentials.Credentials_Ref; private -- Credentials Type Registry type Credentials_Constructor is access function (Section_Name : String) return Credentials_Access; procedure Register (Credentials_Type : String; Constructor : Credentials_Constructor); function Create_Credentials (Credentials_Type : String; Section_Name : String) return Credentials_Ref'Class; end PolyORB.Security.Credentials; polyorb-2.8~20110207.orig/src/security/polyorb-qos-transport_contexts.ads0000644000175000017500000000661711750740340026012 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . Q O S . T R A N S P O R T _ C O N T E X T S -- -- -- -- S p e c -- -- -- -- Copyright (C) 2005-2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with PolyORB.Binding_Objects; with PolyORB.QoS.Clients_Security; with PolyORB.Security.Credentials; with PolyORB.Security.Transport_Mechanisms; package PolyORB.QoS.Transport_Contexts is type QoS_Transport_Context_Parameter is new QoS_Parameter (Transport_Security) with record Selected : PolyORB.QoS.Clients_Security.Client_Mechanism_Access; -- Client compound security mechanism selected by client security -- service for invocation. Invocation_Credentials : PolyORB.Security.Credentials.Credentials_Ref; -- Compound credentials used for request invocation. Transport : PolyORB.Security.Transport_Mechanisms.Target_Transport_Mechanism_Access; -- Transport mechanism, used for receive request. If request is a local -- request then it null. Accepting_Credentials : PolyORB.Security.Credentials.Credentials_Ref; -- Transport creadentials which has been used for setup connection. -- Null if request is local. Binding_Object : PolyORB.Binding_Objects.Binding_Object_Access; -- Binding object, used for object reference binding. end record; type QoS_Transport_Context_Parameter_Access is access all QoS_Transport_Context_Parameter'Class; procedure Release_Contents (QoS : access QoS_Transport_Context_Parameter); end PolyORB.QoS.Transport_Contexts; polyorb-2.8~20110207.orig/src/src.exclude.in0000644000175000017500000000003011750740340017731 0ustar xavierxavier@EXCLUDED_SOURCE_FILES@ polyorb-2.8~20110207.orig/src/polyorb-obj_adapter_qos.ads0000644000175000017500000000551211750740340022505 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . O B J _ A D A P T E R _ Q O S -- -- -- -- S p e c -- -- -- -- Copyright (C) 2005 Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with PolyORB.Obj_Adapters; with PolyORB.QoS; package PolyORB.Obj_Adapter_QoS is procedure Set_Object_Adapter_QoS (OA : access PolyORB.Obj_Adapters.Obj_Adapter'Class; QoS : PolyORB.QoS.QoS_Parameters); -- Set Object Adapter QoS function Get_Object_Adapter_QoS (OA : access PolyORB.Obj_Adapters.Obj_Adapter'Class) return PolyORB.QoS.QoS_Parameters; -- Retrieve Object Adapter QoS procedure Set_Object_Adapter_QoS (OA : access PolyORB.Obj_Adapters.Obj_Adapter'Class; Kind : PolyORB.QoS.QoS_Kind; QoS : PolyORB.QoS.QoS_Parameter_Access); function Get_Object_Adapter_QoS (OA : access PolyORB.Obj_Adapters.Obj_Adapter'Class; Kind : PolyORB.QoS.QoS_Kind) return PolyORB.QoS.QoS_Parameter_Access; end PolyORB.Obj_Adapter_QoS; polyorb-2.8~20110207.orig/src/polyorb-tasking-profiles-no_tasking-mutexes.adb0000644000175000017500000000776511750740340026447 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- POLYORB.TASKING.PROFILES.NO_TASKING.MUTEXES -- -- -- -- B o d y -- -- -- -- Copyright (C) 2002-2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- Implementation of POSIX-like mutexes under the No_Tasking profile. with PolyORB.Initialization; with PolyORB.Utils.Strings; package body PolyORB.Tasking.Profiles.No_Tasking.Mutexes is The_Mutex : aliased No_Tasking_Mutex_Type; ------------ -- Create -- ------------ function Create (MF : access No_Tasking_Mutex_Factory_Type; Name : String := "") return PTM.Mutex_Access is pragma Warnings (Off); pragma Unreferenced (MF); pragma Unreferenced (Name); pragma Warnings (On); begin return The_Mutex'Access; end Create; ------------- -- Destroy -- ------------- procedure Destroy (MF : access No_Tasking_Mutex_Factory_Type; M : in out PTM.Mutex_Access) is pragma Warnings (Off); pragma Unreferenced (MF); pragma Warnings (On); begin M := null; end Destroy; ----------- -- Enter -- ----------- procedure Enter (M : access No_Tasking_Mutex_Type) is pragma Warnings (Off); pragma Unreferenced (M); pragma Warnings (On); begin null; end Enter; ---------------- -- Initialize -- ---------------- procedure Initialize is begin PTM.Register_Mutex_Factory (PTM.Mutex_Factory_Access (The_Mutex_Factory)); end Initialize; ----------- -- Leave -- ----------- procedure Leave (M : access No_Tasking_Mutex_Type) is pragma Warnings (Off); pragma Unreferenced (M); pragma Warnings (On); begin null; end Leave; use PolyORB.Initialization; use PolyORB.Initialization.String_Lists; use PolyORB.Utils.Strings; begin Register_Module (Module_Info' (Name => +"tasking.profiles.no_tasking.mutexes", Conflicts => Empty, Depends => Empty, Provides => +"tasking.mutexes", Implicit => False, Init => Initialize'Access, Shutdown => null)); end PolyORB.Tasking.Profiles.No_Tasking.Mutexes; polyorb-2.8~20110207.orig/src/polyorb-orb-thread_pool.ads0000644000175000017500000000670011750740340022431 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . O R B . T H R E A D _ P O O L -- -- -- -- S p e c -- -- -- -- Copyright (C) 2001-2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- Implementation of thread pool architecture package PolyORB.ORB.Thread_Pool is pragma Elaborate_Body; use PolyORB.Components; use PolyORB.Jobs; use PolyORB.Transport; ---------------------------------------------------- -- Implementation of a thread-pool tasking policy -- ---------------------------------------------------- type Thread_Pool_Policy is new Tasking_Policy_Type with private; procedure Handle_New_Server_Connection (P : access Thread_Pool_Policy; ORB : ORB_Access; AC : Active_Connection); procedure Handle_Close_Connection (P : access Thread_Pool_Policy; TE : Transport_Endpoint_Access); procedure Handle_New_Client_Connection (P : access Thread_Pool_Policy; ORB : ORB_Access; AC : Active_Connection); procedure Handle_Request_Execution (P : access Thread_Pool_Policy; ORB : ORB_Access; RJ : access Request_Job'Class); procedure Idle (P : access Thread_Pool_Policy; This_Task : PTI.Task_Info_Access; ORB : ORB_Access); function Get_Minimum_Spare_Threads return Natural; function Get_Maximum_Spare_Threads return Natural; function Get_Maximum_Threads return Natural; -- Return operational parameters of the thread pool private type Thread_Pool_Policy is new Tasking_Policy_Type with null record; end PolyORB.ORB.Thread_Pool; polyorb-2.8~20110207.orig/src/polyorb-smart_pointers-controlled_entities.ads0000644000175000017500000000614211750740340026471 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- POLYORB.SMART_POINTERS.CONTROLLED_ENTITIES -- -- -- -- S p e c -- -- -- -- Copyright (C) 2001-2009, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ pragma Ada_2005; package PolyORB.Smart_Pointers.Controlled_Entities is pragma Preelaborate; --------------------------------- -- Controlled task-safe entity -- --------------------------------- type Entity is abstract new Non_Controlled_Entity with private; procedure Initialize (X : in out Entity) is null; function Is_Controlled (X : Entity) return Boolean; private --------------------------------- -- Task-safe controlled entity -- --------------------------------- type Entity_Controller (E : access Entity'Class) is new Ada.Finalization.Limited_Controlled with null record; procedure Initialize (X : in out Entity_Controller); procedure Finalize (X : in out Entity_Controller); type Entity is abstract new Non_Controlled_Entity with record Controller : Entity_Controller (Entity'Access); -- Controller component used to trigger a call to the Entity's -- Finalize primitive operation when it is Finalized (note that -- Entity itself is not a controlled type). end record; end PolyORB.Smart_Pointers.Controlled_Entities; polyorb-2.8~20110207.orig/src/polyorb-rt_poa-basic_rt_poa.ads0000644000175000017500000001114411750740340023256 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . R T _ P O A . B A S I C _ R T _ P O A -- -- -- -- S p e c -- -- -- -- Copyright (C) 2004-2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with PolyORB.Errors; with PolyORB.Objects; with PolyORB.POA; with PolyORB.POA_Manager; with PolyORB.POA_Policies; with PolyORB.Servants; package PolyORB.RT_POA.Basic_RT_POA is type Basic_RT_Obj_Adapter is new PolyORB.RT_POA.RT_Obj_Adapter with private; type Basic_RT_Obj_Adapter_Access is access all Basic_RT_Obj_Adapter; --------------------------------------------- -- CORBA-like POA interface implementation -- --------------------------------------------- procedure Create_POA (Self : access Basic_RT_Obj_Adapter; Adapter_Name : Standard.String; A_POAManager : POA_Manager.POAManager_Access; Policies : POA_Policies.PolicyList; POA : out PolyORB.POA.Obj_Adapter_Access; Error : in out PolyORB.Errors.Error_Container); procedure Export (OA : access Basic_RT_Obj_Adapter; Obj : Servants.Servant_Access; Key : Objects.Object_Id_Access; Oid : out Objects.Object_Id_Access; Error : in out PolyORB.Errors.Error_Container); ------------------------------------------------ -- CORBA-like RT POA interface implementation -- ------------------------------------------------ procedure Create_Object_Identification_With_Priority (Self : access Basic_RT_Obj_Adapter; Hint : Object_Id_Access; Server_ORB_Priority : ORB_Priority; Server_External_Priority : External_Priority; U_Oid : out Unmarshalled_Oid; Error : in out PolyORB.Errors.Error_Container); procedure Activate_Object_With_Id_And_Priority (Self : access Basic_RT_Obj_Adapter; P_Servant : Servants.Servant_Access; Hint : Object_Id_Access; Server_ORB_Priority : ORB_Priority; Server_External_Priority : External_Priority; U_Oid : out Unmarshalled_Oid; Error : in out PolyORB.Errors.Error_Container); procedure Get_Scheduling_Parameters (Self : access Basic_RT_Obj_Adapter; Id : Object_Id_Access; Model : out Priority_Model; Server_ORB_Priority : out ORB_Priority; Server_External_Priority : out External_Priority; Error : in out PolyORB.Errors.Error_Container); private type Basic_RT_Obj_Adapter is new PolyORB.RT_POA.RT_Obj_Adapter with null record; end PolyORB.RT_POA.Basic_RT_POA; polyorb-2.8~20110207.orig/src/polyorb-errors-helper.adb0000644000175000017500000003710011750740340022117 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . E R R O R S . H E L P E R -- -- -- -- B o d y -- -- -- -- Copyright (C) 2005-2008, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with PolyORB.Any.ObjRef; with PolyORB.Log; with PolyORB.References; package body PolyORB.Errors.Helper is use PolyORB.Any; use PolyORB.Any.ObjRef; use PolyORB.Log; use PolyORB.Types; package L is new PolyORB.Log.Facility_Log ("polyorb.errors.helper"); procedure O (Message : Standard.String; Level : Log_Level := Debug) renames L.Output; function C (Level : Log_Level := Debug) return Boolean renames L.Enabled; ------------------ -- Error_To_Any -- ------------------ function Error_To_Any (Error : Error_Container) return PolyORB.Any.Any is Result : PolyORB.Any.Any; Error_Name : constant String := Error_Id'Image (Error.Kind); Exception_Name : constant String := Error_Name (Error_Name'First .. Error_Name'Last - 2); -- Strip "_E" suffix begin pragma Debug (C, O ("Error_To_Any: enter.")); pragma Debug (C, O ("Error is: " & Error_Name)); pragma Debug (C, O ("Exception name is: " & Exception_Name)); if Error.Kind in ORB_System_Error then Result := To_Any (Exception_Name, System_Exception_Members (Error.Member.all)); elsif Error.Kind = ForwardRequest_E then Result := To_Any (ForwardRequest_Members (Error.Member.all)); elsif Error.Kind = ForwardRequestPerm_E then Result := To_Any (ForwardRequestPerm_Members (Error.Member.all)); elsif Error.Kind = NeedsAddressingMode_E then Result := To_Any (NeedsAddressingMode_Members (Error.Member.all)); elsif Error.Kind in POA_Error then Result := To_Any (Exception_Name, Null_Members (Error.Member.all)); else raise Program_Error; -- Never happens end if; pragma Debug (C, O ("Error_To_Any: leave.")); return Result; end Error_To_Any; -------------- -- From_Any -- -------------- function From_Any (Item : PolyORB.Any.Any) return Completion_Status is begin return Completion_Status'Val (Unsigned_Long'(PolyORB.Any.Get_Aggregate_Element (Item, 0))); end From_Any; ------------ -- To_Any -- ------------ function To_Any (Item : Completion_Status) return Any.Any is Result : Any.Any := Get_Empty_Any_Aggregate (TC_Completion_Status); begin Add_Aggregate_Element (Result, To_Any (Unsigned_Long (Completion_Status'Pos (Item)))); return Result; end To_Any; -------------------------- -- TC_Completion_Status -- -------------------------- TC_Completion_Status_Cache : TypeCode.Local_Ref; function TC_Completion_Status return PolyORB.Any.TypeCode.Local_Ref is TC : TypeCode.Local_Ref renames TC_Completion_Status_Cache; begin if not TypeCode.Is_Nil (TC) then return TC; end if; TC := TypeCode.TC_Enum; TypeCode.Add_Parameter (TC, To_Any ("completion_status")); TypeCode.Add_Parameter (TC, To_Any ("IDL:omg.org/CORBA/completion_status:1.0")); for C in Completion_Status'Range loop TypeCode.Add_Parameter (TC, To_Any (Completion_Status'Image (C))); end loop; return TC; end TC_Completion_Status; ------------ -- To_Any -- ------------ function To_Any (Name : Standard.String; Member : Null_Members) return PolyORB.Any.Any is pragma Unreferenced (Member); TC : constant TypeCode.Local_Ref := TypeCode.TC_Except; Shift : Natural := 0; begin -- Name TypeCode.Add_Parameter (TC, To_Any (Name)); if Name (Name'First .. Name'First + PolyORB_Exc_Root'Length - 1) = PolyORB_Exc_Root then Shift := PolyORB_Exc_Root'Length + 1; end if; -- RepositoryId : 'INTERNAL::1.0' declare Repository_Id : constant String := PolyORB_Exc_Prefix & Name (Name'First + Shift .. Name'Last) & PolyORB_Exc_Version; begin TypeCode.Add_Parameter (TC, To_Any (Repository_Id)); end; return Get_Empty_Any_Aggregate (TC); end To_Any; --------------------- -- TC_Comm_Failure -- --------------------- TC_Comm_Failure_Cache : TypeCode.Local_Ref; function TC_Comm_Failure return PolyORB.Any.TypeCode.Local_Ref is begin if not TypeCode.Is_Nil (TC_Comm_Failure_Cache) then return TC_Comm_Failure_Cache; end if; TC_Comm_Failure_Cache := System_Exception_TypeCode ("COMM_FAILURE"); return TC_Comm_Failure_Cache; end TC_Comm_Failure; ------------------ -- TC_Transient -- ------------------ TC_Transient_Cache : TypeCode.Local_Ref; function TC_Transient return PolyORB.Any.TypeCode.Local_Ref is begin if not TypeCode.Is_Nil (TC_Transient_Cache) then return TC_Transient_Cache; end if; TC_Transient_Cache := System_Exception_TypeCode ("TRANSIENT"); return TC_Transient_Cache; end TC_Transient; -------------------- -- TC_No_Response -- -------------------- TC_No_Response_Cache : TypeCode.Local_Ref; function TC_No_Response return PolyORB.Any.TypeCode.Local_Ref is begin if not TypeCode.Is_Nil (TC_No_Response_Cache) then return TC_No_Response_Cache; end if; TC_No_Response_Cache := System_Exception_TypeCode ("NO_RESPONSE"); return TC_No_Response_Cache; end TC_No_Response; -------------------- -- TC_Obj_Adapter -- -------------------- TC_Obj_Adapter_Cache : TypeCode.Local_Ref; function TC_Obj_Adapter return PolyORB.Any.TypeCode.Local_Ref is begin if not TypeCode.Is_Nil (TC_Obj_Adapter_Cache) then return TC_Obj_Adapter_Cache; end if; TC_Obj_Adapter_Cache := System_Exception_TypeCode ("OBJ_ADAPTER"); return TC_Obj_Adapter_Cache; end TC_Obj_Adapter; ----------------------- -- TC_ForwardRequest -- ----------------------- TC_ForwardRequest_Cache : TypeCode.Local_Ref; function TC_ForwardRequest return PolyORB.Any.TypeCode.Local_Ref is TC : TypeCode.Local_Ref renames TC_ForwardRequest_Cache; Name : constant String := "ForwardRequest"; Repository_Id : constant String := PolyORB_Exc_Prefix & Name & PolyORB_Exc_Version; begin if not TypeCode.Is_Nil (TC) then return TC; end if; TC := TypeCode.TC_Except; TypeCode.Add_Parameter (TC, To_Any (Name)); TypeCode.Add_Parameter (TC, To_Any (Repository_Id)); TypeCode.Add_Parameter (TC, To_Any (TypeCode.TC_Object)); TypeCode.Add_Parameter (TC, To_Any ("forward_reference")); return TC; end TC_ForwardRequest; --------------------------- -- TC_ForwardRequestPerm -- --------------------------- TC_ForwardRequestPerm_Cache : TypeCode.Local_Ref; function TC_ForwardRequestPerm return PolyORB.Any.TypeCode.Local_Ref is TC : TypeCode.Local_Ref renames TC_ForwardRequestPerm_Cache; Name : constant String := "ForwardRequestPerm"; Repository_Id : constant String := PolyORB_Exc_Prefix & Name & PolyORB_Exc_Version; begin if not TypeCode.Is_Nil (TC) then return TC; end if; TC := TypeCode.TC_Except; TypeCode.Add_Parameter (TC, To_Any (Name)); TypeCode.Add_Parameter (TC, To_Any (Repository_Id)); TypeCode.Add_Parameter (TC, To_Any (TypeCode.TC_Object)); TypeCode.Add_Parameter (TC, To_Any ("forward_reference")); return TC; end TC_ForwardRequestPerm; ---------------------------- -- TC_NeedsAddressingMode -- ---------------------------- TC_NeedsAddressingMode_Cache : TypeCode.Local_Ref; function TC_NeedsAddressingMode return PolyORB.Any.TypeCode.Local_Ref is TC : TypeCode.Local_Ref renames TC_NeedsAddressingMode_Cache; Name : constant String := "NeedsAddressingMode"; Repository_Id : constant String := PolyORB_Exc_Prefix & Name & PolyORB_Exc_Version; begin if not TypeCode.Is_Nil (TC) then return TC; end if; TC := TypeCode.TC_Except; TypeCode.Add_Parameter (TC, To_Any (Name)); TypeCode.Add_Parameter (TC, To_Any (Repository_Id)); TypeCode.Add_Parameter (TC, To_Any (TC_Short)); TypeCode.Add_Parameter (TC, To_Any ("mode")); return TC; end TC_NeedsAddressingMode; -------------- -- From_Any -- -------------- function From_Any (Item : Any.Any) return ForwardRequest_Members is Index : Any.Any; Result_Forward : References.Ref; begin Index := Get_Aggregate_Element (Item, TypeCode.TC_Object, 0); Result_Forward := From_Any (Index); return (Forward_Reference => Smart_Pointers.Ref (Result_Forward)); end From_Any; -------------- -- From_Any -- -------------- function From_Any (Item : Any.Any) return ForwardRequestPerm_Members is Index : Any.Any; Result_Forward : References.Ref; begin Index := Get_Aggregate_Element (Item, TypeCode.TC_Object, 0); Result_Forward := From_Any (Index); return (Forward_Reference => Smart_Pointers.Ref (Result_Forward)); end From_Any; -------------- -- From_Any -- -------------- function From_Any (Item : PolyORB.Any.Any) return NeedsAddressingMode_Members is Index : Any.Any; Mode : Short; begin Index := Get_Aggregate_Element (Item, TC_Short, 0); Mode := From_Any (Index); case Mode is when 0 => return (Mode => Key); when 1 => return (Mode => Profile); when 2 => return (Mode => Reference); when others => raise Program_Error; -- Never be happen end case; end From_Any; ------------ -- To_Any -- ------------ function To_Any (Item : ForwardRequest_Members) return PolyORB.Any.Any is Result : Any.Any := Get_Empty_Any_Aggregate (TC_ForwardRequest); Ref : References.Ref; begin References.Set (Ref, Smart_Pointers.Entity_Of (Item.Forward_Reference)); Add_Aggregate_Element (Result, To_Any (Ref)); return Result; end To_Any; ------------ -- To_Any -- ------------ function To_Any (Item : ForwardRequestPerm_Members) return PolyORB.Any.Any is Result : Any.Any := Get_Empty_Any_Aggregate (TC_ForwardRequestPerm); Ref : References.Ref; begin References.Set (Ref, Smart_Pointers.Entity_Of (Item.Forward_Reference)); Add_Aggregate_Element (Result, To_Any (Ref)); return Result; end To_Any; ------------ -- To_Any -- ------------ function To_Any (Item : NeedsAddressingMode_Members) return PolyORB.Any.Any is Result : Any.Any := Get_Empty_Any_Aggregate (TC_NeedsAddressingMode); Mode : Short; begin case Item.Mode is when Key => Mode := 0; when Profile => Mode := 1; when Reference => Mode := 2; end case; Add_Aggregate_Element (Result, To_Any (Mode)); return Result; end To_Any; ------------ -- To_Any -- ------------ function To_Any (Name : Standard.String; Member : System_Exception_Members) return PolyORB.Any.Any is TC : PolyORB.Any.TypeCode.Local_Ref; Result : PolyORB.Any.Any; begin -- Construct exception typecode TC := System_Exception_TypeCode (Name); Result := Get_Empty_Any_Aggregate (TC); Add_Aggregate_Element (Result, To_Any (Member.Minor)); Add_Aggregate_Element (Result, To_Any (Member.Completed)); return Result; end To_Any; -------------- -- From_Any -- -------------- function From_Any (Item : Any.Any) return System_Exception_Members is Minor : PolyORB.Types.Unsigned_Long; Completed : Completion_Status; begin Minor := From_Any (Get_Aggregate_Element (Item, TC_Unsigned_Long, PolyORB.Types.Unsigned_Long (0))); Completed := From_Any (Get_Aggregate_Element (Item, TC_Completion_Status, PolyORB.Types.Unsigned_Long (1))); return (Minor => Minor, Completed => Completed); end From_Any; ------------------------------- -- System_Exception_TypeCode -- ------------------------------- function System_Exception_TypeCode (Name : Standard.String) return Any.TypeCode.Local_Ref is TC : constant TypeCode.Local_Ref := TypeCode.TC_Except; Shift : Natural := 0; begin -- Name TypeCode.Add_Parameter (TC, To_Any (Name)); if Name (Name'First .. Name'First + PolyORB_Exc_Root'Length - 1) = PolyORB_Exc_Root then Shift := PolyORB_Exc_Root'Length + 1; end if; -- RepositoryId : 'INTERNAL::1.0' declare Repository_Id : constant String := PolyORB_Exc_Prefix & Name (Name'First + Shift .. Name'Last) & PolyORB_Exc_Version; begin TypeCode.Add_Parameter (TC, To_Any (Repository_Id)); -- Component 'minor' TypeCode.Add_Parameter (TC, To_Any (TC_Unsigned_Long)); TypeCode.Add_Parameter (TC, To_Any ("minor")); -- Component 'completed' TypeCode.Add_Parameter (TC, To_Any (TC_Completion_Status)); TypeCode.Add_Parameter (TC, To_Any ("completed")); pragma Debug (C, O ("Built Exception TypeCode for: " & Repository_Id)); end; pragma Debug (C, O (" " & PolyORB.Any.Image (TC))); return TC; end System_Exception_TypeCode; end PolyORB.Errors.Helper; polyorb-2.8~20110207.orig/src/polyorb-sockets_initialization.adb0000644000175000017500000000602711750740340024114 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . S O C K E T S _ I N I T I A L I Z A T I O N -- -- -- -- B o d y -- -- -- -- Copyright (C) 2003-2008, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- The purpose of this package is to register an initialization module -- for GNAT.Sockets. with GNAT.Sockets; with PolyORB.Initialization; with PolyORB.Utils.Strings; package body PolyORB.Sockets_Initialization is ---------------- -- Initialize -- ---------------- procedure Initialize; procedure Initialize is begin pragma Warnings (Off); -- WAG:61 -- A call GNAT.Sockets.Initialize used to be necessary. This is not -- the case anymore, and so the routine is marked as obsolescent on -- newer compilers. GNAT.Sockets.Initialize; pragma Warnings (On); end Initialize; use PolyORB.Initialization; use PolyORB.Initialization.String_Lists; use PolyORB.Utils.Strings; begin Register_Module (Module_Info' (Name => +"sockets", Conflicts => Empty, Depends => Empty, Provides => Empty, Implicit => False, Init => Initialize'Access, Shutdown => null)); end PolyORB.Sockets_Initialization; polyorb-2.8~20110207.orig/src/polyorb-sequences-unbounded-search.adb0000644000175000017500000000755711750740340024562 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . S E Q U E N C E S . U N B O U N D E D . S E A R C H -- -- -- -- B o d y -- -- -- -- Copyright (C) 2002-2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ package body PolyORB.Sequences.Unbounded.Search is ----------- -- Count -- ----------- function Count (Haystack : Sequence; Needle : Needle_Type) return Natural is Times : Natural := 0; begin for Index in 1 .. Haystack.Length loop if Match (Get_Element (Haystack, Index), Needle) then Times := Times + 1; end if; end loop; return Times; end Count; ----------- -- Index -- ----------- function Index (Haystack : PolyORB.Sequences.Unbounded.Sequence; Needle : Needle_Type; Going : Direction := Forward) return Natural is Shift : Integer; From : Natural; To : Natural; begin if Haystack.Length = 0 then return 0; end if; if Going = Forward then Shift := 1; From := 1; To := Haystack.Length; else Shift := -1; From := Haystack.Length; To := 1; end if; -- There is at least one pass because Haystack.Length /= 0 loop if Match (Get_Element (Haystack, From), Needle) then return From; end if; exit when From = To; From := From + Shift; end loop; -- No match return 0; end Index; ------------------ -- Sub_Sequence -- ------------------ function Sub_Sequence (Haystack : Sequence; Needle : Needle_Type) return Sequence is Result : Sequence := Null_Sequence; begin for Index in 1 .. Haystack.Length loop declare El : Element renames Get_Element (Haystack, Index); begin if Match (El, Needle) then Append (Result, El); end if; end; end loop; return Result; end Sub_Sequence; end PolyORB.Sequences.Unbounded.Search; polyorb-2.8~20110207.orig/src/polyorb-poa_config.ads0000644000175000017500000000603511750740340021456 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . P O A _ C O N F I G -- -- -- -- S p e c -- -- -- -- Copyright (C) 2001-2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by ACT Europe. -- -- (email: sales@act-europe.fr) -- -- -- ------------------------------------------------------------------------------ -- Global POA configuration with PolyORB.POA_Policies; package PolyORB.POA_Config is pragma Elaborate_Body; type Configuration_Type is abstract tagged limited private; type Configuration_Access is access all Configuration_Type'Class; procedure Initialize (C : Configuration_Type) is abstract; -- Create all policies available in this configuration, -- and register them with policy repository F. function Default_Policies (C : Configuration_Type) return PolyORB.POA_Policies.PolicyList is abstract; -- Return the list of default OA policies for this configuration procedure Set_Configuration (C : Configuration_Access); -- Set the configuration for the whole runtime. -- May be called only once. C must be non-null. function Configuration return Configuration_Access; -- The value set by Set_Configuration private type Configuration_Type is abstract tagged limited null record; pragma Inline (Set_Configuration); pragma Inline (Configuration); end PolyORB.POA_Config; polyorb-2.8~20110207.orig/src/aws_orig/0000755000175000017500000000000011750740340017003 5ustar xavierxavierpolyorb-2.8~20110207.orig/src/aws_orig/aws-containers.ads0000644000175000017500000000353211750740337022442 0ustar xavierxavier------------------------------------------------------------------------------ -- Ada Web Server -- -- -- -- Copyright (C) 2000-2001 -- -- ACT-Europe -- -- -- -- Authors: Dmitriy Anisimkov - Pascal Obry -- -- -- -- This library is free software; you can redistribute it and/or modify -- -- it under the terms of the GNU General Public License as published by -- -- the Free Software Foundation; either version 2 of the License, or (at -- -- your option) any later version. -- -- -- -- This library is distributed in the hope that it will be useful, but -- -- WITHOUT ANY WARRANTY; without even the implied warranty of -- -- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -- -- General Public License for more details. -- -- -- -- You should have received a copy of the GNU General Public License -- -- along with this library; if not, write to the Free Software Foundation, -- -- Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. -- -- -- ------------------------------------------------------------------------------ package AWS.Containers is pragma Pure; end AWS.Containers; polyorb-2.8~20110207.orig/src/aws_orig/aws-digest.adb0000644000175000017500000001467011750740337021540 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- A W S . D I G E S T -- -- -- -- B o d y -- -- -- -- Copyright (C) 2000-2007, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- @@@ uses ada.calendar with Ada.Calendar; with Ada.Unchecked_Conversion; with Ada.Strings.Maps.Constants; with AWS.Utils; pragma Elaborate_All (AWS.Utils); package body AWS.Digest is use Ada; Private_Key : MD5.Context; Nonce_Expiration : constant Duration := 300.0; subtype Byte_Array_Of_Integer is MD5.Byte_Array (1 .. Integer'Size / MD5.Byte_Array'Component_Size); function To_Byte_Array is new Ada.Unchecked_Conversion (Integer, Byte_Array_Of_Integer); ----------------- -- Check_Nonce -- ----------------- function Check_Nonce (Value : String) return Boolean is use Calendar; use type MD5.Byte_Array; F : constant Positive := Value'First; Now : constant Time := Clock; Nonce_Time : Time; Year_Now : Year_Number; Month_Now : Month_Number; Day_Now : Day_Number; Seconds_Now : Day_Duration; Seconds_Nonce : Natural; Ctx : MD5.Context; Digest : MD5.Fingerprint; Sample : Digest_String; begin -- Our nonces length is length of Digest plus 5 symbols for -- Day durations. if Value'Length /= Digest_String'Length + 5 then return False; end if; Split (Now, Year_Now, Month_Now, Day_Now, Seconds_Now); declare use Ada.Strings.Maps; begin if not Is_Subset (To_Set (Value (F .. F + 4)), Constants.Hexadecimal_Digit_Set) then return False; end if; end; Seconds_Nonce := Utils.Hex_Value (Value (F .. F + 4)); Nonce_Time := Time_Of (Year_Now, Month_Now, Day_Now, Day_Duration (Seconds_Nonce)); if Nonce_Time > Now then -- Could be next day Nonce_Time := Nonce_Time - Day_Duration'Last; Split (Nonce_Time, Year_Now, Month_Now, Day_Now, Seconds_Now); end if; if Now - Nonce_Time > Nonce_Expiration then return False; end if; Ctx := Private_Key; MD5.Update (Ctx, To_Byte_Array (Year_Now) & To_Byte_Array (Month_Now) & To_Byte_Array (Day_Now) & To_Byte_Array (Seconds_Nonce)); MD5.Final (Ctx, Digest); Sample := MD5.Digest_To_Text (Digest); return Value (F + 5 .. Value'Last) = Sample; end Check_Nonce; ------------------- -- Create_Digest -- ------------------- function Create_Digest (Username, Realm, Password : String; Nonce, NC, CNonce, QOP : String; Method, URI : String) return Digest_String is begin return Create_Digest (Username => Username, Realm => Realm, Password => Password, Nonce => Nonce & ':' & NC & ':' & CNonce & ':' & QOP, Method => Method, URI => URI); end Create_Digest; function Create_Digest (Username, Realm, Password : String; Nonce : String; Method, URI : String) return Digest_String is begin return Utils.Get_MD5 (Utils.Get_MD5 (Username & ':' & Realm & ':' & Password) & ':' & Nonce & ':' & Utils.Get_MD5 (Method & ':' & URI)); end Create_Digest; ------------------ -- Create_Nonce -- ------------------ function Create_Nonce return String is use Calendar; Year_Now : Year_Number; Month_Now : Month_Number; Day_Now : Day_Number; Seconds_Now : Day_Duration; Seconds_Int : Natural; Digest : MD5.Fingerprint; Ctx : MD5.Context; Result : Digest_String; begin Split (Clock, Year_Now, Month_Now, Day_Now, Seconds_Now); Ctx := Private_Key; Seconds_Int := Natural (Float'Floor (Float (Seconds_Now))); MD5.Update (Ctx, To_Byte_Array (Year_Now)); MD5.Update (Ctx, To_Byte_Array (Month_Now)); MD5.Update (Ctx, To_Byte_Array (Day_Now)); MD5.Update (Ctx, To_Byte_Array (Seconds_Int)); MD5.Final (Ctx, Digest); -- Place the digest string representation into the result variable Result := MD5.Digest_To_Text (Digest); -- Five hex digits before MD5 digest for the nonce expiration check return Utils.Hex (Seconds_Int, Width => 5) & Result; end Create_Nonce; begin MD5.Update (Private_Key, Utils.Random_Integer'Image (Utils.Random)); end AWS.Digest; polyorb-2.8~20110207.orig/src/aws_orig/templates_parser.adb0000644000175000017500000034340311750740337023042 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- T E M P L A T E S _ P A R S E R -- -- -- -- B o d y -- -- -- -- Copyright (C) 1999-2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- @@@ uses ada.calendar with Ada.Exceptions; with Ada.Characters.Handling; with Ada.Calendar; with Ada.Strings.Fixed; with Ada.Strings.Maps.Constants; with Ada.Unchecked_Deallocation; with GNAT.Calendar.Time_IO; with GNAT.OS_Lib; with GNAT.Regexp; with Templates_Parser.Input; package body Templates_Parser is use Ada; use Ada.Exceptions; use Ada.Strings; Internal_Error : exception; Blank : constant Maps.Character_Set := Maps.To_Set (' ' & ASCII.HT); function Image (N : Integer) return String; pragma Inline (Image); -- Returns N image without leading blank ----------- -- Image -- ----------- function Image (N : Integer) return String is N_Img : constant String := Integer'Image (N); begin if N_Img (N_Img'First) = '-' then return N_Img; else return N_Img (N_Img'First + 1 .. N_Img'Last); end if; end Image; -------------- -- Tag Info -- -------------- Begin_Tag : Unbounded_String := To_Unbounded_String (Default_Begin_Tag); End_Tag : Unbounded_String := To_Unbounded_String (Default_End_Tag); Table_Token : constant String := "@@TABLE@@"; Terminate_Sections_Token : constant String := "@@TERMINATE_SECTIONS@@"; Section_Token : constant String := "@@SECTION@@"; End_Table_Token : constant String := "@@END_TABLE@@"; If_Token : constant String := "@@IF@@"; Elsif_Token : constant String := "@@ELSIF@@"; Else_Token : constant String := "@@ELSE@@"; End_If_Token : constant String := "@@END_IF@@"; Include_Token : constant String := "@@INCLUDE@@"; ---------------------- -- Filters setting -- ---------------------- Filter_Lower_Token : aliased constant String := "LOWER"; Filter_Upper_Token : aliased constant String := "UPPER"; Filter_Capitalize_Token : aliased constant String := "CAPITALIZE"; Filter_Reverse_Token : aliased constant String := "REVERSE"; Filter_Repeat_Token : aliased constant String := "REPEAT"; Filter_Size_Token : aliased constant String := "SIZE"; Filter_Clean_Text_Token : aliased constant String := "CLEAN_TEXT"; Filter_Contract_Token : aliased constant String := "CONTRACT"; Filter_No_Space_Token : aliased constant String := "NO_SPACE"; Filter_No_Digit_Token : aliased constant String := "NO_DIGIT"; Filter_No_Letter_Token : aliased constant String := "NO_LETTER"; Filter_Format_Number_Token : aliased constant String := "FORMAT_NUMBER"; Filter_Yes_No_Token : aliased constant String := "YES_NO"; Filter_Oui_Non_Token : aliased constant String := "OUI_NON"; Filter_Exist_Token : aliased constant String := "EXIST"; Filter_Is_Empty_Token : aliased constant String := "IS_EMPTY"; Filter_Match_Token : aliased constant String := "MATCH"; Filter_Trim_Token : aliased constant String := "TRIM"; Filter_Web_Escape_Token : aliased constant String := "WEB_ESCAPE"; Filter_Web_NBSP_Token : aliased constant String := "WEB_NBSP"; Filter_Coma_2_Point_Token : aliased constant String := "COMA_2_POINT"; Filter_Point_2_Coma_Token : aliased constant String := "POINT_2_COMA"; Filter_LF_2_BR_Token : aliased constant String := "LF_2_BR"; Filter_BR_2_LF_Token : aliased constant String := "BR_2_LF"; Filter_Plus_Token : aliased constant String := """+"""; Filter_Add_Token : aliased constant String := "ADD"; Filter_Minus_Token : aliased constant String := """-"""; Filter_Sub_Token : aliased constant String := "SUB"; Filter_Multiply_Token : aliased constant String := """*"""; Filter_Mult_Token : aliased constant String := "MULT"; Filter_Divide_Token : aliased constant String := """/"""; Filter_Div_Token : aliased constant String := "DIV"; Filter_Modulo_Token : aliased constant String := "MOD"; -- A filter appear just before a tag variable (e.g. @_LOWER:SOME_VAR_@ -- and means that the filter LOWER should be applied to SOME_VAR before -- replacing it in the template file. type Filters_Mode is (BR_2_LF, -- Replaces all
HTML tag by a LF character. Capitalize, -- Lower case except char before spaces and underscores. Clean_Text, -- Only letter/digits all other chars are changed to spaces. Coma_2_Point, -- Replaces comas by points. Contract, -- Replaces a suite of spaces by a single space character. Exist, -- Returns "TRUE" if var is not empty and "FALSE" otherwise. Format_Number, -- Returns the number with a space added between each 3 digits -- blocks. The decimal part is not transformed. If the data is not a -- number nothing is done. The data is trimmed before processing it. Invert, -- Reverse string. Is_Empty, -- Returns "TRUE" if var is empty and "FALSE" otherwise. LF_2_BR, -- Replaces all LF character to
HTML tag. Lower, -- Lower case. Match, -- Returns "TRUE" if var match the pattern passed as argument. No_Digit, -- Replace all digits by spaces. No_Letter, -- Removes all letters by spaces. No_Space, -- Removes all spaces found in the value. Oui_Non, -- If True return Oui, If False returns Non, else do nothing. Point_2_Coma, -- Replaces points by comas. Repeat, -- Returns N copy of the original string. The number of copy is passed -- as parameter. Size, -- Returns the number of characters in the string value. Trim, -- Trim leading and trailing space. Upper, -- Upper case. Web_Escape, -- Convert characters "<>&" to HTML equivalents: <, > and & Web_NBSP, -- Convert spaces to HTML   - non breaking spaces. Yes_No, -- If True return Yes, If False returns No, else do nothing. Plus, Add, -- Add the given parameter to the string Minus, Sub, -- Substract the given parameter to the string Multiply, Mult, -- Multiply the given parameter to the string Divide, Div, -- Divide the given parameter to the string Modulo -- Returns current value modulo N (N is the filter parameter) ); function Expect_Regexp (Mode : Filters_Mode) return Boolean; -- Returns True is the filter named Filter_Name expect a regular -- expression as parameter. type Parameter_Mode is (Void, Str, Regexp); type Parameter_Data (Mode : Parameter_Mode := Void) is record case Mode is when Void => null; when Str => S : Unbounded_String; when Regexp => R_Str : Unbounded_String; Regexp : GNAT.Regexp.Regexp; end case; end record; No_Parameter : constant Parameter_Data := Parameter_Data'(Mode => Void); function Image (P : Parameter_Data) return String; -- Returns parameter string representation. type Filter_Function is access function (S : String; P : Parameter_Data := No_Parameter) return String; -- P is the filter parameter, no parameter by default. Parameter are -- untyped and will be parsed by the filter function if needed. type Filter_Routine is record Handle : Filter_Function; Parameters : Parameter_Data; end record; type Filter_Set is array (Positive range <>) of Filter_Routine; type Filter_Set_Access is access Filter_Set; type String_Access is access constant String; type Filter_Record is record Name : String_Access; Handle : Filter_Function; end record; -- filter functions, see above. procedure Check_Null_Parameter (P : Parameter_Data); -- Raises Template_Error if P is not equal to Null_Parameter. function BR_2_LF_Filter (S : String; P : Parameter_Data := No_Parameter) return String; function Capitalize_Filter (S : String; P : Parameter_Data := No_Parameter) return String; function Clean_Text_Filter (S : String; P : Parameter_Data := No_Parameter) return String; function Coma_2_Point_Filter (S : String; P : Parameter_Data := No_Parameter) return String; function Contract_Filter (S : String; P : Parameter_Data := No_Parameter) return String; function Exist_Filter (S : String; P : Parameter_Data := No_Parameter) return String; function Format_Number_Filter (S : String; P : Parameter_Data := No_Parameter) return String; function Is_Empty_Filter (S : String; P : Parameter_Data := No_Parameter) return String; function LF_2_BR_Filter (S : String; P : Parameter_Data := No_Parameter) return String; function Lower_Filter (S : String; P : Parameter_Data := No_Parameter) return String; function Match_Filter (S : String; P : Parameter_Data := No_Parameter) return String; function No_Digit_Filter (S : String; P : Parameter_Data := No_Parameter) return String; function No_Letter_Filter (S : String; P : Parameter_Data := No_Parameter) return String; function No_Space_Filter (S : String; P : Parameter_Data := No_Parameter) return String; function Oui_Non_Filter (S : String; P : Parameter_Data := No_Parameter) return String; function Point_2_Coma_Filter (S : String; P : Parameter_Data := No_Parameter) return String; function Repeat_Filter (S : String; P : Parameter_Data := No_Parameter) return String; function Reverse_Filter (S : String; P : Parameter_Data := No_Parameter) return String; function Size_Filter (S : String; P : Parameter_Data := No_Parameter) return String; function Trim_Filter (S : String; P : Parameter_Data := No_Parameter) return String; function Upper_Filter (S : String; P : Parameter_Data := No_Parameter) return String; function Web_Escape_Filter (S : String; P : Parameter_Data := No_Parameter) return String; function Web_NBSP_Filter (S : String; P : Parameter_Data := No_Parameter) return String; function Yes_No_Filter (S : String; P : Parameter_Data := No_Parameter) return String; function Plus_Filter (S : String; P : Parameter_Data := No_Parameter) return String; function Minus_Filter (S : String; P : Parameter_Data := No_Parameter) return String; function Divide_Filter (S : String; P : Parameter_Data := No_Parameter) return String; function Multiply_Filter (S : String; P : Parameter_Data := No_Parameter) return String; function Modulo_Filter (S : String; P : Parameter_Data := No_Parameter) return String; function Filter_Handle (Name : String) return Filter_Function; -- Returns the filter function for the given filter name. function Filter_Handle (Mode : Filters_Mode) return Filter_Function; -- Returns the filter function for the given filter mode. function Filter_Mode (Name : String) return Filters_Mode; -- Returns the Filters_Mode for filter named Name. This is the internal -- representation for this filter name. function Filter_Name (Handle : Filter_Function) return String; -- Returns the filter name for the given filter function. -------------------- -- Tags variable -- -------------------- type Attribute is (Nil, Length, Line, Min_Column, Max_Column); type Tag is record Name : Unbounded_String; Filters : Filter_Set_Access; Attr : Attribute := Nil; end record; function Build (Str : String) return Tag; -- Create a Tag from Str. A tag is composed of a name and a set of -- filters. function Image (T : Tag) return String; -- Returns string representation for the Tag variable. function Translate (T : Tag; Value : String) return String; -- Returns the result of T.Name after applying all filters. procedure Release (T : in out Tag); -- Release all memory associated with Tag. ----------- -- Image -- ----------- function Image (P : Parameter_Data) return String is begin case P.Mode is when Void => return ""; when Str => return '(' & To_String (P.S) & ')'; when Regexp => return '(' & To_String (P.R_Str) & ')'; end case; end Image; ----------- -- Image -- ----------- function Image (T : Tag) return String is R : Unbounded_String; begin R := Begin_Tag; -- Filters if T.Filters /= null then for K in reverse T.Filters'Range loop Append (R, Filter_Name (T.Filters (K).Handle)); Append (R, Image (T.Filters (K).Parameters)); Append (R, ":"); end loop; end if; -- Tag name Append (R, T.Name); -- Attributes case T.Attr is when Nil => null; when Length => Append (R, "'Length"); when Line => Append (R, "'Line"); when Min_Column => Append (R, "'Min_Column"); when Max_Column => Append (R, "'Max_Column"); end case; Append (R, End_Tag); return To_String (R); end Image; ----------- -- Build -- ----------- function Build (Str : String) return Tag is function Get_Var_Name (Tag : String) return Unbounded_String; -- Given a Tag name, it returns the variable name only. It removes -- the tag separator and the filters. function Get_Filter_Set (Tag : String) return Filter_Set_Access; -- Given a tag name, it retruns a set of filter to apply to this -- variable when translated. function Get_Attribute (Tag : String) return Attribute; -- Returns attribute for the given tag. F_Sep : constant Natural := Strings.Fixed.Index (Str, ":", Strings.Backward); -- Last filter separator A_Sep : constant Natural := Strings.Fixed.Index (Str, "'", Strings.Backward); -- Attribute separator ------------------- -- Get_Attribute -- ------------------- function Get_Attribute (Tag : String) return Attribute is Start, Stop : Natural; begin if A_Sep = 0 then return Nil; else Start := A_Sep + 1; Stop := Tag'Last - Length (End_Tag); end if; declare A_Name : constant String := Characters.Handling.To_Lower (Tag (Start .. Stop)); begin if A_Name = "length" then return Length; elsif A_Name = "line" then return Line; elsif A_Name = "min_column" then return Min_Column; elsif A_Name = "max_column" then return Max_Column; else Exceptions.Raise_Exception (Template_Error'Identity, "Unknown attribute name """ & A_Name & '"'); end if; end; end Get_Attribute; -------------------- -- Get_Filter_Set -- -------------------- function Get_Filter_Set (Tag : String) return Filter_Set_Access is Start : Natural; Stop : Natural := Tag'Last; FS : Filter_Set (1 .. Strings.Fixed.Count (Tag, ":")); K : Positive := FS'First; function Name_Parameter (Filter : String) return Filter_Routine; -- Given a Filter description, returns the filter handle and -- parameter. function Name_Parameter (Filter : String) return Filter_Routine is P1 : constant Natural := Strings.Fixed.Index (Filter, "("); P2 : constant Natural := Strings.Fixed.Index (Filter, ")", Strings.Backward); begin if (P1 = 0 and then P2 /= 0) or else (P1 /= 0 and then P2 = 0) then Exceptions.Raise_Exception (Template_Error'Identity, "unbalanced parenthesis """ & Filter & '"'); elsif P2 /= 0 and then P2 < Filter'Last and then Filter (P2 + 1) /= ':' then Exceptions.Raise_Exception (Template_Error'Identity, "unexpected character after parenthesis """ & Filter & '"'); end if; if P1 = 0 then return (Filter_Handle (Filter), Parameter_Data'(Mode => Void)); else declare Name : constant String := Filter (Filter'First .. P1 - 1); Mode : constant Filters_Mode := Filter_Mode (Name); Parameter : constant String := Filter (P1 + 1 .. P2 - 1); begin if Expect_Regexp (Mode) then return (Filter_Handle (Mode), Parameter_Data'(Regexp, To_Unbounded_String (Parameter), GNAT.Regexp.Compile (Parameter))); else return (Filter_Handle (Mode), Parameter_Data'(Templates_Parser.Str, To_Unbounded_String (Parameter))); end if; end; end if; end Name_Parameter; begin if FS'Length = 0 then return null; end if; loop Start := Tag'First; Stop := Strings.Fixed.Index (Tag (Start .. Stop), ":", Strings.Backward); exit when Stop = 0; Start := Strings.Fixed.Index (Tag (Start .. Stop - 1), ":", Strings.Backward); if Start = 0 then -- Last filter found FS (K) := Name_Parameter (Tag (Tag'First + Length (Begin_Tag) .. Stop - 1)); else FS (K) := Name_Parameter (Tag (Start + 1 .. Stop - 1)); end if; K := K + 1; Stop := Stop - 1; end loop; return new Filter_Set'(FS); end Get_Filter_Set; ------------------ -- Get_Var_Name -- ------------------ function Get_Var_Name (Tag : String) return Unbounded_String is Start, Stop : Natural; begin if A_Sep = 0 then -- No attribute Stop := Tag'Last - Length (End_Tag); else Stop := A_Sep - 1; end if; if F_Sep = 0 then -- No filter Start := Tag'First + Length (Begin_Tag); else Start := F_Sep + 1; end if; return To_Unbounded_String (Tag (Start .. Stop)); end Get_Var_Name; begin return (Get_Var_Name (Str), Get_Filter_Set (Str), Get_Attribute (Str)); end Build; ------------- -- Release -- ------------- procedure Release (T : in out Tag) is procedure Free is new Ada.Unchecked_Deallocation (Filter_Set, Filter_Set_Access); begin Free (T.Filters); end Release; --------------- -- Translate -- --------------- function Translate (T : Tag; Value : String) return String is begin if T.Filters /= null then declare R : Unbounded_String := To_Unbounded_String (Value); begin for K in T.Filters'Range loop R := To_Unbounded_String (T.Filters (K).Handle (To_String (R), T.Filters (K).Parameters)); end loop; return To_String (R); end; end if; return Value; end Translate; ---------- -- Data -- ---------- package Data is type Node; type Tree is access Node; type NKind is (Text, Var); type Node (Kind : NKind) is record Next : Tree; case Kind is when Text => Value : Unbounded_String; when Var => Var : Tag; end case; end record; function Parse (Line : String) return Tree; -- Parse text line and returns the corresponding tree representation. procedure Print_Tree (D : Tree); -- Decend the text tree and print it to the standard output. procedure Release (D : in out Tree); -- Release all memory used by the tree. end Data; ------------------ -- Expressions -- ------------------ package Expr is type Ops is (O_And, O_Or, O_Xor, O_Sup, O_Inf, O_Esup, O_Einf, O_Equal, O_Diff); function Image (O : Ops) return String; -- Returns Ops string representation. function Value (O : String) return Ops; -- Returns Ops from its string representation. Raises Templates_Error if -- the token is not a known operation. type U_Ops is (O_Not); function Image (O : U_Ops) return String; -- Returns U_Ops string representation. function Value (O : String) return U_Ops; -- Returns U_Ops from its string representation. Raises Templates_Error -- if the token is not a known operation. type Node; type Tree is access Node; type NKind is (Value, Var, Op, U_Op); -- The node is a value, a variable a binary operator or an unary -- operator type Node (Kind : NKind) is record case Kind is when Value => V : Unbounded_String; when Var => Var : Tag; when Op => O : Ops; Left, Right : Tree; when U_Op => U_O : U_Ops; Next : Tree; end case; end record; function Parse (Expression : String) return Tree; -- Parse Expression and returns the corresponding tree representation. procedure Print_Tree (E : Tree); -- Decend the expression's tree and print the expression. It outputs the -- expression with all parenthesis to show without ambiguity the way the -- expression has been parsed. procedure Release (E : in out Tree); -- Release all associated memory with the tree. end Expr; -------------------------------- -- Template Tree definitions -- -------------------------------- type Nkind is (Info, -- first node is tree infos C_Info, -- second node is cache tree info Text, -- this is a text line If_Stmt, -- an IF tag statement Table_Stmt, -- a TABLE tag statement Section_Stmt, -- a TABLE section Include_Stmt); -- an INCLUDE tag statement -- A template line is coded as a suite of Data and Var element. -- The first node in the tree is of type Info and should never be release -- and changed. This ensure that included tree will always be valid -- otherwise will would have to parse all the current trees in the cache -- to update the reference. type Node; type Tree is access Node; -- Static_Tree represent a Tree immune to cache changes. Info point to the -- first node and C_Info to the second one. C_Info could be different to -- Info.Next in case of cache changes. This way we keep a pointer to the -- old tree to be able to release it when not used anymore. This way it is -- possible to use the cache in multitasking program without trouble. The -- changes in the cache are either because more than one task is parsing -- the same template at the same time, they will update the cache with the -- same tree at some point, or because a newer template was found in the -- file system. type Static_Tree is record Info : Tree; C_Info : Tree; end record; type Node (Kind : Nkind) is record Next : Tree; Line : Natural; case Kind is when Info => Filename : Unbounded_String; -- Name of the file Timestamp : GNAT.OS_Lib.OS_Time; -- Date and Time of last change I_File : Tree; -- Included file references -- Used for the cache system Ref : Natural := 0; -- Number of ref in the cache when C_Info => Obsolete : Boolean := False; -- True if newerversion in cache Used : Natural := 0; -- >0 if currently used when Text => Text : Data.Tree; when If_Stmt => Cond : Expr.Tree; N_True : Tree; N_False : Tree; when Table_Stmt => Terminate_Sections : Boolean; Sections : Tree; when Section_Stmt => N_Section : Tree; when Include_Stmt => File : Static_Tree; end case; end record; procedure Release (T : in out Tree); -- Release all memory associated with the tree. ------------------- -- Cached Files -- ------------------- -- Cached_Files keep the parsed Tree for a given file in memory. This -- implementation is thread safe so it is possible to use the cache in a -- multitasking program. package Cached_Files is protected Prot is procedure Add (Filename : String; T : Tree; Old : out Tree); -- Add Filename/T to the list of cached files. If Filename is -- already in the list, replace the current tree with T. Furthemore -- if Filename tree is already in use, Old will be set with the -- previous C_Info node otherwise Old will be T.Next (C_Info node -- for current tree). procedure Get (Filename : String; Load : Boolean; Result : out Static_Tree); -- Returns the Tree for Filename or null if Filename has not been -- cached. Load must be set to True at load stage and False at Parse -- stage. procedure Release (T : in out Static_Tree); -- After loading a tree and using it, it is required that it be -- released. This will ensure that a tree marked as obsolete (a new -- version being now in the cache) will be released from the memory. end Prot; end Cached_Files; ---------------- -- Vector_Tag -- ---------------- function Field (Vect_Value : Vector_Tag; N : Positive) return String; -- returns the Nth value in the vector tag. --------- -- "+" -- --------- function "+" (Value : String) return Vector_Tag is Item : constant Vector_Tag_Node_Access := new Vector_Tag_Node'(To_Unbounded_String (Value), null); begin return Vector_Tag' (Ada.Finalization.Controlled with Ref_Count => new Integer'(1), Count => 1, Head => Item, Last => Item); end "+"; function "+" (Value : Character) return Vector_Tag is begin return +String'(1 => Value); end "+"; function "+" (Value : Boolean) return Vector_Tag is begin return +Boolean'Image (Value); end "+"; function "+" (Value : Strings.Unbounded.Unbounded_String) return Vector_Tag is begin return +To_String (Value); end "+"; function "+" (Value : Integer) return Vector_Tag is begin return +Image (Value); end "+"; --------- -- "&" -- --------- function "&" (Vect : Vector_Tag; Value : String) return Vector_Tag is Item : constant Vector_Tag_Node_Access := new Vector_Tag_Node'(To_Unbounded_String (Value), null); begin Vect.Ref_Count.all := Vect.Ref_Count.all + 1; if Vect.Count = 0 then return Vector_Tag' (Ada.Finalization.Controlled with Ref_Count => Vect.Ref_Count, Count => 1, Head => Item, Last => Item); else Vect.Last.Next := Item; return Vector_Tag' (Ada.Finalization.Controlled with Ref_Count => Vect.Ref_Count, Count => Vect.Count + 1, Head => Vect.Head, Last => Item); end if; end "&"; function "&" (Vect : Vector_Tag; Value : Character) return Vector_Tag is begin return Vect & String'(1 => Value); end "&"; function "&" (Vect : Vector_Tag; Value : Boolean) return Vector_Tag is begin return Vect & Boolean'Image (Value); end "&"; function "&" (Vect : Vector_Tag; Value : Strings.Unbounded.Unbounded_String) return Vector_Tag is begin return Vect & To_String (Value); end "&"; function "&" (Vect : Vector_Tag; Value : Integer) return Vector_Tag is begin return Vect & Image (Value); end "&"; ----------- -- Clear -- ----------- procedure Clear (Vect : in out Vector_Tag) is begin -- Here we just separate current vector from the new one. The memory -- used by the current one will be collected by the Finalize -- routine. We just want a new independant Vector_Tag here. if Vect.Ref_Count.all = 1 then -- This is the last reference, release object Finalize (Vect); end if; Vect.Ref_Count := new Integer'(1); Vect.Count := 0; Vect.Head := null; Vect.Last := null; end Clear; ------------ -- Adjust -- ------------ procedure Adjust (V : in out Vector_Tag) is begin V.Ref_Count.all := V.Ref_Count.all + 1; end Adjust; ---------------- -- Initialize -- ---------------- procedure Initialize (V : in out Vector_Tag) is begin V.Ref_Count := new Integer'(1); V.Count := 0; end Initialize; ---------- -- Item -- ---------- function Item (Vect : Vector_Tag; N : Positive) return String is K : Positive := 1; V : Vector_Tag_Node_Access := Vect.Head; begin loop if K = N then return To_String (V.Value); end if; V := V.Next; K := K + 1; if V = null then raise Constraint_Error; end if; end loop; end Item; -------------- -- Finalize -- -------------- procedure Finalize (V : in out Vector_Tag) is begin V.Ref_Count.all := V.Ref_Count.all - 1; if V.Ref_Count.all = 0 then declare procedure Free is new Ada.Unchecked_Deallocation (Vector_Tag_Node, Vector_Tag_Node_Access); procedure Free is new Ada.Unchecked_Deallocation (Integer, Integer_Access); P, N : Vector_Tag_Node_Access; begin P := V.Head; while P /= null loop N := P.Next; Free (P); P := N; end loop; V.Head := null; V.Last := null; Free (V.Ref_Count); end; end if; end Finalize; ---------- -- Size -- ---------- function Size (Vect : Vector_Tag) return Natural is begin return Vect.Count; end Size; ---------------- -- Matrix_Tag -- ---------------- --------- -- "+" -- --------- function "+" (Vect : Vector_Tag) return Matrix_Tag is Item : constant Matrix_Tag_Node_Access := new Matrix_Tag_Node'(Vect, null); V_Size : constant Natural := Size (Vect); begin return Matrix_Tag' (M => (Ada.Finalization.Controlled with new Integer'(1), 1, V_Size, V_Size, Item, Item)); end "+"; --------- -- "&" -- --------- function "&" (Matrix : Matrix_Tag; Vect : Vector_Tag) return Matrix_Tag is Item : constant Matrix_Tag_Node_Access := new Matrix_Tag_Node'(Vect, null); V_Size : constant Natural := Size (Vect); begin Matrix.M.Ref_Count.all := Matrix.M.Ref_Count.all + 1; if Matrix.M.Head = null then return Matrix_Tag'(M => (Ada.Finalization.Controlled with Matrix.M.Ref_Count, Matrix.M.Count + 1, Min => Natural'Min (Matrix.M.Min, V_Size), Max => Natural'Max (Matrix.M.Max, V_Size), Head => Item, Last => Item)); else Matrix.M.Last.Next := Item; return Matrix_Tag'(M => (Ada.Finalization.Controlled with Matrix.M.Ref_Count, Matrix.M.Count + 1, Min => Natural'Min (Matrix.M.Min, V_Size), Max => Natural'Max (Matrix.M.Max, V_Size), Head => Matrix.M.Head, Last => Item)); end if; end "&"; ---------- -- Size -- ---------- function Size (Matrix : Matrix_Tag) return Natural is begin return Matrix.M.Count; end Size; ---------------- -- Initialize -- ---------------- procedure Initialize (M : in out Matrix_Tag_Int) is begin M.Ref_Count := new Integer'(1); M.Count := 0; M.Min := Natural'Last; M.Max := 0; end Initialize; -------------- -- Finalize -- -------------- procedure Finalize (M : in out Matrix_Tag_Int) is begin M.Ref_Count.all := M.Ref_Count.all - 1; if M.Ref_Count.all = 0 then declare procedure Free is new Ada.Unchecked_Deallocation (Matrix_Tag_Node, Matrix_Tag_Node_Access); procedure Free is new Ada.Unchecked_Deallocation (Integer, Integer_Access); P, N : Matrix_Tag_Node_Access; begin P := M.Head; while P /= null loop N := P.Next; Free (P); P := N; end loop; M.Head := null; M.Last := null; Free (M.Ref_Count); end; end if; end Finalize; ------------ -- Adjust -- ------------ procedure Adjust (M : in out Matrix_Tag_Int) is begin M.Ref_Count.all := M.Ref_Count.all + 1; end Adjust; ------------ -- Vector -- ------------ function Vector (Matrix : Matrix_Tag; N : Positive) return Vector_Tag is P : Matrix_Tag_Node_Access := Matrix.M.Head; begin for K in 1 .. N - 1 loop P := P.Next; end loop; return P.Vect; exception when others => Exceptions.Raise_Exception (Internal_Error'Identity, "Index out of range"); end Vector; ------------------ -- Cached_Files -- ------------------ package body Cached_Files is separate; ---------- -- Data -- ---------- package body Data is separate; ---------- -- Expr -- ---------- package body Expr is separate; ------------- -- Filters -- ------------- function Expect_Regexp (Mode : Filters_Mode) return Boolean is begin if Mode = Match then return True; else return False; end if; end Expect_Regexp; -------------------------- -- Check_Null_Parameter -- -------------------------- procedure Check_Null_Parameter (P : Parameter_Data) is begin if P.Mode /= Void then Exceptions.Raise_Exception (Template_Error'Identity, "no parameter allowed in this filter"); end if; end Check_Null_Parameter; -------------------- -- BR_2_LF_Filter -- -------------------- function BR_2_LF_Filter (S : String; P : Parameter_Data := No_Parameter) return String is Result : String (S'Range); K : Positive := Result'First; J : Positive := S'First; begin Check_Null_Parameter (P); loop if S (J) = '<' and then J + 3 <= S'Last and then Characters.Handling.To_Lower (S (J .. J + 3)) = "
" then Result (K) := ASCII.LF; K := K + 1; J := J + 4; else Result (K) := S (J); K := K + 1; J := J + 1; end if; exit when J > S'Last; end loop; return Result (Result'First .. K - 1); end BR_2_LF_Filter; ----------------------- -- Capitalize_Filter -- ----------------------- function Capitalize_Filter (S : String; P : Parameter_Data := No_Parameter) return String is Result : String (S'Range); Upper : Boolean := True; begin Check_Null_Parameter (P); for K in Result'Range loop if Upper then Result (K) := Characters.Handling.To_Upper (S (K)); Upper := False; else Result (K) := Characters.Handling.To_Lower (S (K)); if Result (K) = ' ' or else Result (K) = '_' then Upper := True; end if; end if; end loop; return Result; end Capitalize_Filter; ----------------------- -- Clean_Text_Filter -- ----------------------- function Clean_Text_Filter (S : String; P : Parameter_Data := No_Parameter) return String is use type Strings.Maps.Character_Set; Result : String (S'Range); Clean_Set : constant Strings.Maps.Character_Set := Strings.Maps.Constants.Letter_Set or Strings.Maps.Constants.Decimal_Digit_Set or Strings.Maps.To_Set (" éèêîïàôç"); begin Check_Null_Parameter (P); for K in S'Range loop if Strings.Maps.Is_In (S (K), Clean_Set) then Result (K) := S (K); else Result (K) := ' '; end if; end loop; return Result; end Clean_Text_Filter; ------------------------- -- Coma_2_Point_Filter -- ------------------------- function Coma_2_Point_Filter (S : String; P : Parameter_Data := No_Parameter) return String is Result : String := S; begin Check_Null_Parameter (P); for K in Result'Range loop if Result (K) = ',' then Result (K) := '.'; end if; end loop; return Result; end Coma_2_Point_Filter; --------------------- -- Contract_Filter -- --------------------- function Contract_Filter (S : String; P : Parameter_Data := No_Parameter) return String is use type Strings.Maps.Character_Set; Result : String (S'Range); R : Natural := 0; Space : Boolean := False; begin Check_Null_Parameter (P); for K in S'Range loop if S (K) = ' ' then if Space = False then Space := True; R := R + 1; Result (R) := ' '; end if; else Space := False; R := R + 1; Result (R) := S (K); end if; end loop; if R = 0 then return ""; else return Result (Result'First .. R); end if; end Contract_Filter; ------------------ -- Exist_Filter -- ------------------ function Exist_Filter (S : String; P : Parameter_Data := No_Parameter) return String is begin Check_Null_Parameter (P); if S /= "" then return "TRUE"; else return "FALSE"; end if; end Exist_Filter; -------------------------- -- Format_Number_Filter -- -------------------------- function Format_Number_Filter (S : String; P : Parameter_Data := No_Parameter) return String is TS : constant String := Strings.Fixed.Trim (S, Both); function Is_Number return Boolean; -- Returns true if S is a number. Point : Natural := 0; function Is_Number return Boolean is begin for K in TS'Range loop if TS (K) = '.' then Point := K; elsif not Characters.Handling.Is_Digit (TS (K)) then return False; end if; end loop; return True; end Is_Number; Result : String (1 .. TS'Length * 2); K : Positive := Result'Last; I : Natural; Count : Natural := 0; begin Check_Null_Parameter (P); if Is_Number then if Point = 0 then I := TS'Last; else I := Point - 1; end if; for P in reverse TS'First .. I loop Result (K) := TS (P); K := K - 1; Count := Count + 1; if Count mod 3 = 0 and then P /= TS'First then Result (K) := ' '; K := K - 1; end if; end loop; if Point = 0 then return Result (K + 1 .. Result'Last); else return Result (K + 1 .. Result'Last) & TS (Point .. TS'Last); end if; else return S; end if; end Format_Number_Filter; --------------------- -- Is_Empty_Filter -- --------------------- function Is_Empty_Filter (S : String; P : Parameter_Data := No_Parameter) return String is begin Check_Null_Parameter (P); if S = "" then return "TRUE"; else return "FALSE"; end if; end Is_Empty_Filter; -------------------- -- LF_2_BR_Filter -- -------------------- function LF_2_BR_Filter (S : String; P : Parameter_Data := No_Parameter) return String is N : constant Natural := Fixed.Count (S, Strings.Maps.To_Set (ASCII.LF)); begin Check_Null_Parameter (P); if N = 0 then -- No LF, return the original string return S; end if; declare Result : String (1 .. S'Length + N * 3); K : Positive := S'First; begin for J in S'Range loop if S (J) = ASCII.LF then Result (K .. K + 3) := "
"; K := K + 4; else Result (K) := S (J); K := K + 1; end if; end loop; return Result (1 .. K - 1); end; end LF_2_BR_Filter; ------------------ -- Lower_Filter -- ------------------ function Lower_Filter (S : String; P : Parameter_Data := No_Parameter) return String is begin Check_Null_Parameter (P); return Characters.Handling.To_Lower (S); end Lower_Filter; ------------------ -- Match_Filter -- ------------------- function Match_Filter (S : String; P : Parameter_Data := No_Parameter) return String is begin if P = No_Parameter then Exceptions.Raise_Exception (Template_Error'Identity, "missing parameter for MATCH filter"); end if; if GNAT.Regexp.Match (S, P.Regexp) then return "TRUE"; else return "FALSE"; end if; end Match_Filter; --------------------- -- No_Digit_Filter -- --------------------- function No_Digit_Filter (S : String; P : Parameter_Data := No_Parameter) return String is Result : String := S; begin Check_Null_Parameter (P); for K in S'Range loop if Strings.Maps.Is_In (S (K), Strings.Maps.Constants.Decimal_Digit_Set) then Result (K) := ' '; end if; end loop; return Result; end No_Digit_Filter; --------------------- -- No_Letter_Filter -- ---------------------- function No_Letter_Filter (S : String; P : Parameter_Data := No_Parameter) return String is Result : String := S; begin Check_Null_Parameter (P); for K in S'Range loop if Strings.Maps.Is_In (S (K), Strings.Maps.Constants.Letter_Set) then Result (K) := ' '; end if; end loop; return Result; end No_Letter_Filter; --------------------- -- No_Space_Filter -- --------------------- function No_Space_Filter (S : String; P : Parameter_Data := No_Parameter) return String is Result : String (S'Range); L : Natural := Result'First - 1; begin Check_Null_Parameter (P); for K in S'Range loop if not (S (K) = ' ') then L := L + 1; Result (L) := S (K); end if; end loop; return Result (Result'First .. L); end No_Space_Filter; -------------------- -- Oui_Non_Filter -- -------------------- function Oui_Non_Filter (S : String; P : Parameter_Data := No_Parameter) return String is begin Check_Null_Parameter (P); if S = "TRUE" then return "OUI"; elsif S = "true" then return "oui"; elsif S = "True" then return "Oui"; elsif S = "FALSE" then return "NON"; elsif S = "false" then return "non"; elsif S = "False" then return "Non"; else return S; end if; end Oui_Non_Filter; ------------------------- -- Point_2_Coma_Filter -- ------------------------- function Point_2_Coma_Filter (S : String; P : Parameter_Data := No_Parameter) return String is Result : String := S; begin Check_Null_Parameter (P); for K in Result'Range loop if Result (K) = '.' then Result (K) := ','; end if; end loop; return Result; end Point_2_Coma_Filter; ------------------- -- Repeat_Filter -- ------------------- function Repeat_Filter (S : String; P : Parameter_Data := No_Parameter) return String is N : Natural; begin N := Natural'Value (To_String (P.S)); declare R : String (1 .. N * S'Length); begin for K in 1 .. N loop R (1 + (K - 1) * S'Length .. S'Length * K) := S; end loop; return R; end; exception when Constraint_Error => Exceptions.Raise_Exception (Template_Error'Identity, "repeat filter parameter error"); end Repeat_Filter; -------------------- -- Reverse_Filter -- -------------------- function Reverse_Filter (S : String; P : Parameter_Data := No_Parameter) return String is Result : String (S'Range); begin Check_Null_Parameter (P); for K in S'Range loop Result (Result'Last - K + Result'First) := S (K); end loop; return Result; end Reverse_Filter; ----------------- -- Size_Filter -- ----------------- function Size_Filter (S : String; P : Parameter_Data := No_Parameter) return String is begin Check_Null_Parameter (P); return Image (S'Length); end Size_Filter; ----------------- -- Trim_Filter -- ----------------- function Trim_Filter (S : String; P : Parameter_Data := No_Parameter) return String is begin Check_Null_Parameter (P); return Ada.Strings.Fixed.Trim (S, Ada.Strings.Both); end Trim_Filter; ------------------ -- Upper_Filter -- ------------------ function Upper_Filter (S : String; P : Parameter_Data := No_Parameter) return String is begin Check_Null_Parameter (P); return Characters.Handling.To_Upper (S); end Upper_Filter; ------------------- -- Escape_Filter -- ------------------- function Web_Escape_Filter (S : String; P : Parameter_Data := No_Parameter) return String is Max_Escape_Sequence : constant Positive := 5; Result : String (1 .. S'Length * Max_Escape_Sequence); Last : Natural := 0; begin Check_Null_Parameter (P); for I in S'Range loop Last := Last + 1; case S (I) is when '&' => Result (Last .. Last + 4) := "&"; Last := Last + 4; when '>' => Result (Last .. Last + 3) := ">"; Last := Last + 3; when '<' => Result (Last .. Last + 3) := "<"; Last := Last + 3; when '"' => Result (Last .. Last + 5) := """; Last := Last + 5; when others => Result (Last) := S (I); end case; end loop; return Result (1 .. Last); end Web_Escape_Filter; --------------------- -- Web_NBSP_Filter -- --------------------- function Web_NBSP_Filter (S : String; P : Parameter_Data := No_Parameter) return String is Nbsp_Token : constant String := " "; Max_Escape_Sequence : constant Positive := Nbsp_Token'Length; Result : String (1 .. S'Length * Max_Escape_Sequence); Last : Natural := 0; begin Check_Null_Parameter (P); for I in S'Range loop Last := Last + 1; if S (I) = ' ' then Result (Last .. Last + Nbsp_Token'Length - 1) := Nbsp_Token; Last := Last + Nbsp_Token'Length - 1; else Result (Last) := S (I); end if; end loop; return Result (1 .. Last); end Web_NBSP_Filter; ------------------- -- Yes_No_Filter -- ------------------- function Yes_No_Filter (S : String; P : Parameter_Data := No_Parameter) return String is begin Check_Null_Parameter (P); if S = "TRUE" then return "YES"; elsif S = "true" then return "yes"; elsif S = "True" then return "Yes"; elsif S = "FALSE" then return "NO"; elsif S = "false" then return "no"; elsif S = "False" then return "No"; else return S; end if; end Yes_No_Filter; ----------------- -- Plus_Filter -- ----------------- function Plus_Filter (S : String; P : Parameter_Data := No_Parameter) return String is N, V : Natural; begin begin N := Natural'Value (To_String (P.S)); exception when Constraint_Error => Exceptions.Raise_Exception (Template_Error'Identity, """+"" filter parameter error"); end; begin V := Natural'Value (S); return Image (V + N); exception when others => return ""; end; end Plus_Filter; ------------------ -- Minus_Filter -- ------------------ function Minus_Filter (S : String; P : Parameter_Data := No_Parameter) return String is N, V : Natural; begin begin N := Natural'Value (To_String (P.S)); exception when Constraint_Error => Exceptions.Raise_Exception (Template_Error'Identity, """-"" filter parameter error"); end; begin V := Natural'Value (S); return Image (V - N); exception when others => return ""; end; end Minus_Filter; ------------------- -- Divide_Filter -- ------------------- function Divide_Filter (S : String; P : Parameter_Data := No_Parameter) return String is N, V : Natural; begin begin N := Natural'Value (To_String (P.S)); exception when Constraint_Error => Exceptions.Raise_Exception (Template_Error'Identity, """/"" filter parameter error"); end; begin V := Natural'Value (S); return Image (V / N); exception when others => return ""; end; end Divide_Filter; --------------------- -- Multiply_Filter -- --------------------- function Multiply_Filter (S : String; P : Parameter_Data := No_Parameter) return String is N, V : Natural; begin begin N := Natural'Value (To_String (P.S)); exception when Constraint_Error => Exceptions.Raise_Exception (Template_Error'Identity, """*"" filter parameter error"); end; begin V := Natural'Value (S); return Image (V * N); exception when others => return ""; end; end Multiply_Filter; ------------------- -- Modulo_Filter -- ------------------- function Modulo_Filter (S : String; P : Parameter_Data := No_Parameter) return String is N, V : Natural; begin begin N := Natural'Value (To_String (P.S)); exception when Constraint_Error => Exceptions.Raise_Exception (Template_Error'Identity, "modulo filter parameter error"); end; begin V := Natural'Value (S); return Image (V mod N); exception when others => return ""; end; end Modulo_Filter; -- Filter Table Filter_Table : constant array (Filters_Mode) of Filter_Record := (BR_2_LF => (Filter_BR_2_LF_Token'Access, BR_2_LF_Filter'Access), Capitalize => (Filter_Capitalize_Token'Access, Capitalize_Filter'Access), Clean_Text => (Filter_Clean_Text_Token'Access, Clean_Text_Filter'Access), Coma_2_Point => (Filter_Coma_2_Point_Token'Access, Coma_2_Point_Filter'Access), Contract => (Filter_Contract_Token'Access, Contract_Filter'Access), Exist => (Filter_Exist_Token'Access, Exist_Filter'Access), Format_Number => (Filter_Format_Number_Token'Access, Format_Number_Filter'Access), Invert => (Filter_Reverse_Token'Access, Reverse_Filter'Access), Is_Empty => (Filter_Is_Empty_Token'Access, Is_Empty_Filter'Access), LF_2_BR => (Filter_LF_2_BR_Token'Access, LF_2_BR_Filter'Access), Lower => (Filter_Lower_Token'Access, Lower_Filter'Access), Match => (Filter_Match_Token'Access, Match_Filter'Access), No_Digit => (Filter_No_Digit_Token'Access, No_Digit_Filter'Access), No_Letter => (Filter_No_Letter_Token'Access, No_Letter_Filter'Access), No_Space => (Filter_No_Space_Token'Access, No_Space_Filter'Access), Oui_Non => (Filter_Oui_Non_Token'Access, Oui_Non_Filter'Access), Point_2_Coma => (Filter_Point_2_Coma_Token'Access, Point_2_Coma_Filter'Access), Repeat => (Filter_Repeat_Token'Access, Repeat_Filter'Access), Size => (Filter_Size_Token'Access, Size_Filter'Access), Trim => (Filter_Trim_Token'Access, Trim_Filter'Access), Upper => (Filter_Upper_Token'Access, Upper_Filter'Access), Web_Escape => (Filter_Web_Escape_Token'Access, Web_Escape_Filter'Access), Web_NBSP => (Filter_Web_NBSP_Token'Access, Web_NBSP_Filter'Access), Yes_No => (Filter_Yes_No_Token'Access, Yes_No_Filter'Access), Plus => (Filter_Plus_Token'Access, Plus_Filter'Access), Add => (Filter_Add_Token'Access, Plus_Filter'Access), Minus => (Filter_Minus_Token'Access, Minus_Filter'Access), Sub => (Filter_Sub_Token'Access, Minus_Filter'Access), Multiply => (Filter_Multiply_Token'Access, Multiply_Filter'Access), Mult => (Filter_Mult_Token'Access, Multiply_Filter'Access), Divide => (Filter_Divide_Token'Access, Divide_Filter'Access), Div => (Filter_Div_Token'Access, Divide_Filter'Access), Modulo => (Filter_Modulo_Token'Access, Modulo_Filter'Access) ); ------------------- -- Filter_Handle -- ------------------- function Filter_Handle (Name : String) return Filter_Function is Mode : constant Filters_Mode := Filter_Mode (Name); begin return Filter_Table (Mode).Handle; end Filter_Handle; function Filter_Handle (Mode : Filters_Mode) return Filter_Function is begin return Filter_Table (Mode).Handle; end Filter_Handle; ----------------- -- Filter_Mode -- ----------------- function Filter_Mode (Name : String) return Filters_Mode is begin for K in Filter_Table'Range loop if Filter_Table (K).Name.all = Name then return K; end if; end loop; Exceptions.Raise_Exception (Internal_Error'Identity, "Unknown filter " & Name); end Filter_Mode; ----------------- -- Filter_Name -- ----------------- function Filter_Name (Handle : Filter_Function) return String is begin for K in Filter_Table'Range loop if Filter_Table (K).Handle = Handle then return Filter_Table (K).Name.all; end if; end loop; Exceptions.Raise_Exception (Internal_Error'Identity, "Unknown filter handle"); end Filter_Name; ----------- -- Field -- ----------- function Field (Vect_Value : Vector_Tag; N : Positive) return String is P : Vector_Tag_Node_Access := Vect_Value.Head; begin if N = Vect_Value.Count then return To_String (Vect_Value.Last.Value); elsif N > Vect_Value.Count then return ""; else for K in 1 .. N - 1 loop P := P.Next; end loop; return To_String (P.Value); end if; end Field; function Field (Mat_Value : Matrix_Tag; I, J : Natural) return String; function Field (Mat_Value : Matrix_Tag; I, J : Natural) return String is P : Matrix_Tag_Node_Access := Mat_Value.M.Head; begin if I = Mat_Value.M.Count then return Field (Mat_Value.M.Last.Vect, J); elsif I > Mat_Value.M.Count then return ""; else for K in 1 .. I - 1 loop P := P.Next; end loop; return Field (P.Vect, J); end if; end Field; ----------- -- Assoc -- ----------- function Assoc (Variable : String; Value : String) return Association is begin return Association' (Std, To_Unbounded_String (Variable), To_Unbounded_String (Value)); end Assoc; function Assoc (Variable : String; Value : Ada.Strings.Unbounded.Unbounded_String) return Association is begin return Assoc (Variable, To_String (Value)); end Assoc; function Assoc (Variable : String; Value : Integer) return Association is S_Value : constant String := Integer'Image (Value); pragma Warnings (Off); pragma Unreferenced (S_Value); pragma Warnings (On); begin return Assoc (Variable, Image (Value)); end Assoc; function Assoc (Variable : String; Value : Boolean) return Association is begin if Value then return Assoc (Variable, "TRUE"); else return Assoc (Variable, "FALSE"); end if; end Assoc; function Assoc (Variable : String; Value : Vector_Tag; Separator : String := Default_Separator) return Association is begin return Association' (Vect, To_Unbounded_String (Variable), Value, To_Unbounded_String (Separator)); end Assoc; function Assoc (Variable : String; Value : Matrix_Tag; Separator : String := Default_Separator) return Association is begin return Association' (Matrix, To_Unbounded_String (Variable), Value, To_Unbounded_String (Separator)); end Assoc; ---------- -- Load -- ---------- function Load (Filename : String; Cached : Boolean := False; Include_File : Boolean := False) return Static_Tree; function Load (Filename : String; Cached : Boolean := False; Include_File : Boolean := False) return Static_Tree is File : Input.File_Type; -- file beeing parsed. Buffer : String (1 .. 2048); -- current line content Last : Natural; -- index of last characters read in buffer First : Natural; -- first non blank characters in buffer Line : Natural := 0; I_File : Tree; -- list of includes -- Line handling procedure Fatal_Error (Message : String); pragma No_Return (Fatal_Error); -- raise Template_Error exception with message. function Get_Next_Line return Boolean; -- Get new line in File and set Buffer, Last and First. function Get_First_Parameter return Unbounded_String; -- Get first parameter in current line (second word), words beeing -- separated by a set of blank characters (space or horizontal -- tabulation). function Get_All_Parameters return String; -- Get all parameters on the current line. function Is_Stmt (Stmt : String) return Boolean; pragma Inline (Is_Stmt); -- Returns True is Stmt is found at the begining of the current line -- ignoring leading blank characters. function EOF return Boolean; pragma Inline (EOF); -- Returns True if the end of file has been reach. function Build_Include_Pathname (Include_Filename : Unbounded_String) return String; -- Returns the full pathname to the include file (Include_Filename). It -- returns Include_Filename if there is a pathname specified, or the -- pathname of the main template file as a prefix of the include -- filename. procedure Replace_Include_Variables (File : in out Static_Tree; Variables : String); -- Parse the include tree and replace all include variables (numeric -- name) with the corresponding value in Variables (a set of space -- separated words). The first word in Variables is the include file -- name (variable 0), other words are the parameters (variable 1 .. N). type Parse_Mode is (Parse_Std, -- in standard line Parse_If, -- in a if statement Parse_Elsif, -- in elsif part of a if statement Parse_Else, -- in else part of a if statement Parse_Table, -- in a table statement Parse_Section, -- in new section Parse_Section_Content -- in section content ); function Parse (Mode : Parse_Mode) return Tree; -- Get a line in File and returns the Tree. ---------------------------- -- Build_Include_Pathname -- ---------------------------- function Build_Include_Pathname (Include_Filename : Unbounded_String) return String is K : constant Natural := Index (Include_Filename, Maps.To_Set ("/\"), Going => Strings.Backward); begin if K = 0 then declare K : constant Natural := Fixed.Index (Filename, Maps.To_Set ("/\"), Going => Strings.Backward); begin if K = 0 then return To_String (Include_Filename); else return Filename (Filename'First .. K) & To_String (Include_Filename); end if; end; else return To_String (Include_Filename); end if; end Build_Include_Pathname; --------- -- EOF -- --------- function EOF return Boolean is begin return Last = 0; end EOF; ----------------- -- Fatal_Error -- ----------------- procedure Fatal_Error (Message : String) is begin Exceptions.Raise_Exception (Template_Error'Identity, "In " & Filename & " at line" & Natural'Image (Line) & ' ' & Message & '.'); end Fatal_Error; ------------------------ -- Get_All_Parameters -- ------------------------ function Get_All_Parameters return String is Start : Natural; begin Start := Strings.Fixed.Index (Buffer (First .. Last), Blank); if Start = 0 then Fatal_Error ("missing parameter"); end if; if Buffer (Last) = ASCII.CR then -- Last character is a DOS CR (certainly because the template -- file is in DOS format), ignore it as this is not part of the -- parameter. Last := Last - 1; end if; return Strings.Fixed.Trim (Buffer (Start .. Last), Strings.Both); end Get_All_Parameters; ------------------------- -- Get_First_Parameter -- ------------------------- function Get_First_Parameter return Unbounded_String is Start, Stop : Natural; begin Start := Strings.Fixed.Index (Buffer (First .. Last), Blank); if Start = 0 then return Null_Unbounded_String; end if; Start := Strings.Fixed.Index (Buffer (Start .. Last), Blank, Outside); if Start = 0 then -- We have only spaces after the first word, there is no -- parameter in this case. return Null_Unbounded_String; end if; Stop := Strings.Fixed.Index (Buffer (Start .. Last), Blank); if Stop = 0 then Stop := Last; else Stop := Stop - 1; end if; return To_Unbounded_String (Buffer (Start .. Stop)); end Get_First_Parameter; ------------------- -- Get_Next_Line -- ------------------- function Get_Next_Line return Boolean is begin if Input.End_Of_File (File) then Last := 0; return True; else Line := Line + 1; loop Input.Get_Line (File, Buffer, Last); exit when Buffer (Buffer'First .. Buffer'First + 3) /= "@@--"; end loop; First := Strings.Fixed.Index (Buffer (1 .. Last), Blank, Outside); if First = 0 then -- There is only spaces on this line, this is an empty line -- we just have to skip it. Last := 0; return False; end if; Last := Strings.Fixed.Index (Buffer (1 .. Last), Blank, Outside, Strings.Backward); return False; end if; end Get_Next_Line; ------------- -- Is_Stmt -- ------------- function Is_Stmt (Stmt : String) return Boolean is begin return Last /= 0 and then Buffer (First .. First + Stmt'Length - 1) = Stmt; end Is_Stmt; ----------- -- Parse -- ----------- function Parse (Mode : Parse_Mode) return Tree is T : Tree; begin if Mode /= Parse_Section and then Mode /= Parse_Elsif then if Get_Next_Line then return null; end if; end if; case Mode is when Parse_Std => if Is_Stmt (End_If_Token) then Fatal_Error ("@@END_IF@@ found outside an @@IF@@ statement"); end if; if Is_Stmt (End_Table_Token) then Fatal_Error ("@@END_TABLE@@ found outside a @@TABLE@@ statement"); end if; when Parse_If => if Is_Stmt (Else_Token) or else Is_Stmt (Elsif_Token) or else Is_Stmt (End_If_Token) then return null; end if; if Is_Stmt (End_Table_Token) then Fatal_Error ("@@END_TABLE@@ found, @@END_IF@@ expected"); end if; when Parse_Elsif => if Is_Stmt (Else_Token) or else Is_Stmt (End_If_Token) then return null; end if; if Is_Stmt (End_Table_Token) then Fatal_Error ("@@END_TABLE@@ found, @@END_IF@@ expected"); end if; when Parse_Else => if Is_Stmt (End_If_Token) then return null; end if; if Is_Stmt (End_Table_Token) then Fatal_Error ("@@END_TABLE@@ found, @@END_IF@@ expected"); end if; if Is_Stmt (Elsif_Token) then Fatal_Error ("@@ELSIF@@ found after @@ELSE@@"); end if; when Parse_Section => if Is_Stmt (End_If_Token) then Fatal_Error ("@@END_IF@@ found, @@END_TABLE@@ expected"); end if; T := new Node (Section_Stmt); T.Line := Line; T.Next := Parse (Parse_Section_Content); if Is_Stmt (End_Table_Token) then T.N_Section := null; elsif EOF then Fatal_Error ("EOF found, @@END_TABLE@@ expected"); else T.N_Section := Parse (Parse_Section); end if; return T; when Parse_Section_Content => if Is_Stmt (Section_Token) or else Is_Stmt (End_Table_Token) then return null; end if; if Is_Stmt (End_If_Token) then Fatal_Error ("@@END_IF@@ found, @@END_TABLE@@ expected"); end if; when Parse_Table => if Is_Stmt (End_Table_Token) then return null; end if; if Is_Stmt (End_If_Token) then Fatal_Error ("@@END_IF@@ found, @@END_TABLE@@ expected"); end if; end case; if Is_Stmt (If_Token) or else Is_Stmt (Elsif_Token) then T := new Node (If_Stmt); T.Line := Line; T.Cond := Expr.Parse (Get_All_Parameters); T.N_True := Parse (Parse_If); if Is_Stmt (End_If_Token) then T.N_False := null; elsif Is_Stmt (Elsif_Token) then T.N_False := Parse (Parse_Elsif); elsif EOF then Fatal_Error ("EOF found, @@END_IF@@ expected"); else T.N_False := Parse (Parse_Else); end if; T.Next := Parse (Mode); return T; elsif Is_Stmt (Table_Token) then T := new Node (Table_Stmt); T.Line := Line; T.Terminate_Sections := Get_First_Parameter = Terminate_Sections_Token; T.Sections := Parse (Parse_Section); T.Next := Parse (Mode); return T; elsif Is_Stmt (Include_Token) then T := new Node (Include_Stmt); T.Line := Line; T.File := Load (Build_Include_Pathname (Get_First_Parameter), Cached, True); -- Now we must replace the include parameters (if present) into -- the included file tree. Replace_Include_Variables (T.File, Get_All_Parameters); I_File := new Node'(Include_Stmt, I_File, Line, T.File); T.Next := Parse (Mode); return T; else T := new Node (Text); T.Line := Line; if Input.LF_Terminated (File) and then (not Input.End_Of_File (File) or else Include_File) then -- Add a LF is the read line with terminated by a LF. Do not -- add this LF if we reach the end of file except for included -- files. T.Text := Data.Parse (Buffer (1 .. Last) & ASCII.LF); else T.Text := Data.Parse (Buffer (1 .. Last)); end if; T.Next := Parse (Mode); return T; end if; end Parse; ------------------------------- -- Replace_Include_Variables -- ------------------------------- procedure Replace_Include_Variables (File : in out Static_Tree; Variables : String) is procedure Replace (T : in out Tree); -- Recursive routine to parse the tree for all Data.Tree node procedure Replace (T : in out Data.Tree); -- Recursive routine that replace all numeric variables by the -- corresponding parameter in Variables. function Get_Variable (Tag : String) return String; -- Returns the variable name for the include tag Tag. Tag is a -- numeric value and represent the Nth include parameter. ------------------ -- Get_Variable -- ------------------ function Get_Variable (Tag : String) return String is T : constant Natural := Natural'Value (Tag (Tag'First + 1 .. Tag'Last)); S : Natural := Variables'First; E : Natural; K : Natural := 0; begin loop if Variables (S) = '"' then -- Search for the ending quote E := Strings.Fixed.Index (Variables (S + 1 .. Variables'Last), """"); if E = 0 then Fatal_Error ("Missing quote"); else E := E + 1; end if; else -- Search for the next separator E := Strings.Fixed.Index (Variables (S .. Variables'Last), Blank); end if; if E = 0 and then K /= T then -- Not found, return the original tag name return To_String (Begin_Tag) & Tag & To_String (End_Tag); elsif K = T then -- We have found the right variable if E = 0 then E := Variables'Last; else E := E - 1; end if; -- Always return the variable unquoted if Variables (S) = '"' then return Variables (S + 1 .. E - 1); else return Variables (S .. E); end if; else -- Set the new start S := E; S := Strings.Fixed.Index (Variables (S .. Variables'Last), Blank, Strings.Outside); if S = 0 then -- No more values, return the original tag name return To_String (Begin_Tag) & Tag & To_String (End_Tag); end if; end if; K := K + 1; end loop; end Get_Variable; ------------- -- Replace -- ------------- procedure Replace (T : in out Data.Tree) is use type Data.NKind; use type Data.Tree; function Is_Number (Name : String) return Boolean; -- Returns True if Name is an include tag variable ($) --------------- -- Is_Number -- --------------- function Is_Number (Name : String) return Boolean is begin return Name'Length > 1 and then Name (Name'First) = '$' and then Strings.Fixed.Count (Name, Strings.Maps.Constants.Decimal_Digit_Set) = Name'Length - 1; end Is_Number; procedure Free is new Ada.Unchecked_Deallocation (Data.Node, Data.Tree); Old : Data.Tree := T; begin if T /= null then if T.Kind = Data.Var then if Is_Number (To_String (T.Var.Name)) then -- Here we have an include variable name, replace it T := Data.Parse (Get_Variable (To_String (T.Var.Name))); T.Next := Old.Next; Free (Old); end if; end if; Replace (T.Next); end if; end Replace; procedure Replace (T : in out Tree) is use type Tree; begin if T /= null then if T.Kind = Text then Replace (T.Text); end if; Replace (T.Next); end if; end Replace; begin Replace (File.C_Info); end Replace_Include_Variables; T : Static_Tree; New_T : Tree; Old : Tree; begin if Cached then Cached_Files.Prot.Get (Filename, Load => True, Result => T); if T.Info /= null then pragma Assert (T.C_Info /= null); return T; end if; end if; Input.Open (File, Filename, Form => "shared=no"); New_T := Parse (Parse_Std); Input.Close (File); -- T is the tree file, add two nodes (Info and C_Info) in front of the -- tree. -- Add second node (cache info) Old := new Node'(C_Info, New_T, 0, False, 1); -- Add first node (info about tree) New_T := new Node'(Info, Old, 0, To_Unbounded_String (Filename), GNAT.OS_Lib.File_Time_Stamp (Filename), I_File, 1); if Cached then Cached_Files.Prot.Add (Filename, New_T, Old); pragma Assert (Old /= null); end if; return Static_Tree'(New_T, Old); exception when E : Internal_Error => Fatal_Error (Exceptions.Exception_Message (E)); end Load; ---------------- -- Print_Tree -- ---------------- procedure Print_Tree (T : Tree; Level : Natural := 0); procedure Print_Tree (T : Tree; Level : Natural := 0) is separate; ---------------- -- Print_Tree -- ---------------- procedure Print_Tree (Filename : String) is T : Static_Tree; begin T := Load (Filename); Print_Tree (T.Info); Release (T.Info); end Print_Tree; ----------- -- Parse -- ----------- function Parse (Filename : String; Translations : Translate_Table := No_Translation; Cached : Boolean := False; Keep_Unknown_Tags : Boolean := False) return String is begin return To_String (Parse (Filename, Translations, Cached, Keep_Unknown_Tags)); end Parse; ----------- -- Parse -- ----------- function Parse (Filename : String; Translations : Translate_Table := No_Translation; Cached : Boolean := False; Keep_Unknown_Tags : Boolean := False) return Unbounded_String is type Table_State is record I, J : Natural; Max_Lines : Natural; Max_Expand : Natural; Table_Level : Natural; Section_Number : Natural; end record; Empty_State : constant Table_State := (0, 0, 0, 0, 0, 0); Results : Unbounded_String := Null_Unbounded_String; Now : Calendar.Time; procedure Analyze (T : Tree; State : Table_State); -- Parse T and build results file. State is needed for Vector_Tag and -- Matrix_Tag expansion. ------------- -- Analyze -- ------------- procedure Analyze (T : Tree; State : Table_State) is function Analyze (E : Expr.Tree) return String; -- Analyse the expression tree and returns the result as a boolean -- The conditional expression must be equal to either TRUE or -- FALSE. Note that a string is True if it is equal to string "TRUE" -- and False otherwise. procedure Analyze (D : Data.Tree); -- Analyse the data tree and replace all variables by the -- correspinding value specified in Translations. This procedure -- catenate the result into Results variable. procedure Get_Max (T : Tree; Max_Lines : out Natural; Max_Expand : out Natural); -- Returns the maximum number of lines (Max_Lines) into the -- table. This correspond to the length of the shortest vector tag -- into the table or the shortest number of lines in sub-table -- matrix tag. -- Returns also the number of time the table will be expanded -- (Max_Expand), this is equal to Max_Lines + offset to terminate -- the sections. function Is_True (Str : String) return Boolean; -- Return True if Str is one of "TRUE", "OUI", the case beeing not -- case sensitive. function Translate (Var : Tag) return String; -- Translate Tag variable using Translation table and apply all -- Filters and Atribute recorded for this variable. --------------- -- Translate -- --------------- function Translate (Var : Tag) return String is function Vect_List (A : Association) return String; -- Returns the Vector_Tag for the Association as a String, each -- value is separated by the given separator. function Vect_Size (A : Association) return String; pragma Inline (Vect_Size); -- Returns the number of items into the Vector_Tag function Mat_List (A : Association) return String; -- Returns the Matrix_Tag as a string. If Matrix_Tag is not into -- a table, each Vector_Tag is convected using Vect_List and a LF -- is inserted between each rows. If the Matrix_Tag is into a -- table of level 1, it returns only the Vector_Tag (converted -- using Vect_List) for the current table line. function Mat_Line (A : Association) return String; pragma Inline (Mat_Line); -- Returns the number of line (vector) into the matrix function Mat_Min_Column (A : Association) return String; pragma Inline (Mat_Min_Column); -- Returns the size of the smallest vector function Mat_Max_Column (A : Association) return String; pragma Inline (Mat_Max_Column); -- Returns the size of the largest vector --------------- -- Vect_List -- --------------- function Vect_List (A : Association) return String is Result : Unbounded_String; P : Vector_Tag_Node_Access := A.Vect_Value.Head; begin if P = null then return ""; else Result := P.Value; for K in 2 .. A.Vect_Value.Count loop P := P.Next; Append (Result, A.Separator & P.Value); end loop; return To_String (Result); end if; end Vect_List; --------------- -- Vect_Size -- --------------- function Vect_Size (A : Association) return String is begin return Image (A.Vect_Value.Count); end Vect_Size; -------------- -- Mat_List -- -------------- function Mat_List (A : Association) return String is Result : Unbounded_String; P : Matrix_Tag_Node_Access := A.Mat_Value.M.Head; procedure Add_Vector (V : Vector_Tag); -- Add V Vector_Tag representation into Result variable. ---------------- -- Add_Vector -- ---------------- procedure Add_Vector (V : Vector_Tag) is P : Vector_Tag_Node_Access := V.Head; begin -- Check that vector is not empty if P /= null then Result := Result & P.Value; for K in 2 .. V.Count loop P := P.Next; Append (Result, A.Column_Separator & P.Value); end loop; end if; end Add_Vector; begin if State.Table_Level = 0 then -- A Matrix outside a table statement. loop Add_Vector (P.Vect); P := P.Next; exit when P = null; Append (Result, ASCII.LF); end loop; else if not (State.J > A.Mat_Value.M.Count) then Add_Vector (Vector (A.Mat_Value, State.J)); end if; end if; return To_String (Result); end Mat_List; -------------- -- Mat_Line -- -------------- function Mat_Line (A : Association) return String is begin return Image (A.Mat_Value.M.Count); end Mat_Line; -------------------- -- Mat_Min_Column -- -------------------- function Mat_Min_Column (A : Association) return String is begin return Image (A.Mat_Value.M.Min); end Mat_Min_Column; -------------------- -- Mat_Max_Column -- -------------------- function Mat_Max_Column (A : Association) return String is begin return Image (A.Mat_Value.M.Max); end Mat_Max_Column; begin for K in Translations'Range loop if Var.Name = Translations (K).Variable then declare Tk : constant Association := Translations (K); begin case Tk.Kind is when Std => if Var.Attr = Nil then return Translate (Var, To_String (Tk.Value)); else Exceptions.Raise_Exception (Template_Error'Identity, "Attribute not valid on a discrete tag"); end if; when Vect => if Var.Attr = Length then -- 'Length on a vector return Translate (Var, Vect_Size (Tk)); elsif Var.Attr /= Nil then Exceptions.Raise_Exception (Template_Error'Identity, "This attribute is not valid for a " & "vector tag"); elsif State.Table_Level = 0 then -- This is a vector tag (outside of a -- table tag statement), we display it as -- a list separated by the specified -- separator. return Translate (Var, Vect_List (Tk)); else return Translate (Var, Field (Tk.Vect_Value, State.J)); end if; when Matrix => if Var.Attr = Line then -- 'Line on a matrix return Translate (Var, Mat_Line (Tk)); elsif Var.Attr = Min_Column then -- 'Min_Column on a matrix return Translate (Var, Mat_Min_Column (Tk)); elsif Var.Attr = Max_Column then -- 'Max_Column on a matrix return Translate (Var, Mat_Max_Column (Tk)); elsif Var.Attr /= Nil then Exceptions.Raise_Exception (Template_Error'Identity, "This attribute is not valid for a " & "matrix tag"); elsif State.Table_Level in 0 .. 1 then -- This is a matrix tag (outside of a -- level 2 table tag statement), convert -- it using Mat_List. return Translate (Var, Mat_List (Tk)); else return Translate (Var, Field (Tk.Mat_Value, State.I, State.J)); end if; end case; end; end if; end loop; -- Check now for an internal tag declare T_Name : constant String := To_String (Var.Name); begin if T_Name = "UP_TABLE_LINE" then return Translate (Var, Fixed.Trim (Positive'Image (State.I), Strings.Left)); elsif T_Name = "TABLE_LINE" then return Translate (Var, Fixed.Trim (Positive'Image (State.J), Strings.Left)); elsif T_Name = "NUMBER_LINE" then return Translate (Var, Fixed.Trim (Positive'Image (State.Max_Lines), Strings.Left)); elsif T_Name = "TABLE_LEVEL" then return Translate (Var, Fixed.Trim (Positive'Image (State.Table_Level), Strings.Left)); elsif T_Name = "YEAR" then return Translate (Var, GNAT.Calendar.Time_IO.Image (Now, "%Y")); elsif T_Name = "MONTH" then return Translate (Var, GNAT.Calendar.Time_IO.Image (Now, "%m")); elsif T_Name = "DAY" then return Translate (Var, GNAT.Calendar.Time_IO.Image (Now, "%d")); elsif T_Name = "HOUR" then return Translate (Var, GNAT.Calendar.Time_IO.Image (Now, "%H")); elsif T_Name = "MINUTE" then return Translate (Var, GNAT.Calendar.Time_IO.Image (Now, "%M")); elsif T_Name = "SECOND" then return Translate (Var, GNAT.Calendar.Time_IO.Image (Now, "%S")); elsif T_Name = "MONTH_NAME" then return Translate (Var, GNAT.Calendar.Time_IO.Image (Now, "%B")); elsif T_Name = "DAY_NAME" then return Translate (Var, GNAT.Calendar.Time_IO.Image (Now, "%A")); end if; end; -- The tag was not found in the Translation_Table, we either -- returns the empty string or we keep the tag as is. if Keep_Unknown_Tags then return To_String (Begin_Tag & Var.Name & End_Tag); else return Translate (Var, ""); end if; end Translate; ------------- -- Analyze -- ------------- procedure Analyze (D : Data.Tree) is use type Data.Tree; T : Data.Tree := D; begin while T /= null loop case T.Kind is when Data.Text => Append (Results, T.Value); when Data.Var => Append (Results, Translate (T.Var)); end case; T := T.Next; end loop; end Analyze; ------------- -- Analyze -- ------------- function Analyze (E : Expr.Tree) return String is type Ops_Fct is access function (L, R : String) return String; function F_And (L, R : String) return String; function F_Or (L, R : String) return String; function F_Xor (L, R : String) return String; function F_Sup (L, R : String) return String; function F_Esup (L, R : String) return String; function F_Einf (L, R : String) return String; function F_Inf (L, R : String) return String; function F_Equ (L, R : String) return String; function F_Diff (L, R : String) return String; type U_Ops_Fct is access function (N : String) return String; function F_Not (N : String) return String; ----------- -- F_And -- ----------- function F_And (L, R : String) return String is begin if Is_True (L) and Is_True (R) then return "TRUE"; else return "FALSE"; end if; end F_And; ------------ -- F_Diff -- ------------ function F_Diff (L, R : String) return String is begin if L /= R then return "TRUE"; else return "FALSE"; end if; end F_Diff; ------------ -- F_Einf -- ------------ function F_Einf (L, R : String) return String is begin if Integer'Value (L) <= Integer'Value (R) then return "TRUE"; else return "FALSE"; end if; exception when others => if L <= R then return "TRUE"; else return "FALSE"; end if; end F_Einf; ----------- -- F_Equ -- ----------- function F_Equ (L, R : String) return String is begin if L = R then return "TRUE"; else return "FALSE"; end if; end F_Equ; ------------ -- F_Esup -- ------------ function F_Esup (L, R : String) return String is begin if Integer'Value (L) >= Integer'Value (R) then return "TRUE"; else return "FALSE"; end if; exception when others => if L >= R then return "TRUE"; else return "FALSE"; end if; end F_Esup; ----------- -- F_Inf -- ----------- function F_Inf (L, R : String) return String is begin if Integer'Value (L) < Integer'Value (R) then return "TRUE"; else return "FALSE"; end if; exception when others => if L < R then return "TRUE"; else return "FALSE"; end if; end F_Inf; ----------- -- F_Not -- ----------- function F_Not (N : String) return String is begin if Is_True (N) then return "FALSE"; else return "TRUE"; end if; end F_Not; ---------- -- F_Or -- ---------- function F_Or (L, R : String) return String is begin if Is_True (L) or Is_True (R) then return "TRUE"; else return "FALSE"; end if; end F_Or; ----------- -- F_Sup -- ----------- function F_Sup (L, R : String) return String is begin if Integer'Value (L) > Integer'Value (R) then return "TRUE"; else return "FALSE"; end if; exception when others => if L > R then return "TRUE"; else return "FALSE"; end if; end F_Sup; ----------- -- F_Xor -- ----------- function F_Xor (L, R : String) return String is begin if Is_True (L) xor Is_True (R) then return "TRUE"; else return "FALSE"; end if; end F_Xor; Op_Table : constant array (Expr.Ops) of Ops_Fct := (Expr.O_And => F_And'Access, Expr.O_Or => F_Or'Access, Expr.O_Xor => F_Xor'Access, Expr.O_Sup => F_Sup'Access, Expr.O_Inf => F_Inf'Access, Expr.O_Esup => F_Esup'Access, Expr.O_Einf => F_Einf'Access, Expr.O_Equal => F_Equ'Access, Expr.O_Diff => F_Diff'Access); U_Op_Table : constant array (Expr.U_Ops) of U_Ops_Fct := (Expr.O_Not => F_Not'Access); begin case E.Kind is when Expr.Value => return To_String (E.V); when Expr.Var => return Translate (E.Var); when Expr.Op => return Op_Table (E.O) (Analyze (E.Left), Analyze (E.Right)); when Expr.U_Op => return U_Op_Table (E.U_O) (Analyze (E.Next)); end case; end Analyze; ------------- -- Get_Max -- ------------- procedure Get_Max (T : Tree; Max_Lines : out Natural; Max_Expand : out Natural) is function Get_Max_Lines (T : Tree; N : Positive) return Natural; -- Recursivelly descend the tree and compute the max lines that -- will be displayed into the table. function Count_Section return Natural; -- Returns the number of section into table T; ------------------- -- Count_Section -- ------------------- function Count_Section return Natural is C : Natural := 0; S : Tree := T.Sections; begin while S /= null loop C := C + 1; S := S.N_Section; end loop; return C; end Count_Section; ------------------- -- Get_Max_Lines -- ------------------- function Get_Max_Lines (T : Tree; N : Positive) return Natural is function Check (T : Data.Tree) return Natural; -- Returns the length of the largest vector tag found on the -- subtree. ----------- -- Check -- ----------- function Check (T : Data.Tree) return Natural is use type Data.Tree; use type Data.NKind; Iteration : Natural := Natural'First; D : Data.Tree := T; begin while D /= null loop if D.Kind = Data.Var and then D.Var.Attr = Nil then for K in Translations'Range loop declare Tk : constant Association := Translations (K); begin if D.Var.Name = Tk.Variable then if N = 1 then -- First block level analysed. if Tk.Kind = Vect then -- This is a Vector tag into a top -- level table statement. The number -- of iterations for this table -- statement correspond to the number -- of item into the vector. Iteration := Natural'Max (Iteration, Size (Tk.Vect_Value)); elsif Tk.Kind = Matrix then if State.Table_Level = 0 then -- This is Matrix tag into a top -- level table statement. The -- number of iterations for this -- table statement correspond to -- the number of vector into the -- table. Iteration := Natural'Max (Iteration, Size (Tk.Mat_Value)); else -- This is Matrix tag into an -- embbeded table statement (table -- statement into a table -- statement). The number of -- iterations for this table -- statement correspond to the -- largest number of items in the -- Matrix tag's vectors. Iteration := Tk.Mat_Value.M.Max; end if; end if; elsif N = 2 then -- Second block level analysed. if Tk.Kind = Matrix then -- This is a Matrix tag into an -- embedded table statement (table -- statement into a table statement) -- analysed at the second block -- level. This is to report the number -- of iterations for upper level table -- statement. This number of -- iterations correspond to the -- smallest number of vectors into the -- table. Iteration := Natural'Max (Iteration, Size (Tk.Mat_Value)); end if; end if; end if; end; end loop; end if; D := D.Next; end loop; return Iteration; end Check; begin if T = null then return Natural'First; end if; case T.Kind is when Info | C_Info => return Get_Max_Lines (T.Next, N); when Text => return Natural'Max (Check (T.Text), Get_Max_Lines (T.Next, N)); when If_Stmt => return Natural'Max (Natural'Max (Get_Max_Lines (T.N_True, N), Get_Max_Lines (T.N_False, N)), Get_Max_Lines (T.Next, N)); when Table_Stmt => if N = 1 then return Natural'Max (Get_Max_Lines (T.Sections, N + 1), Get_Max_Lines (T.Next, N)); else return Natural'First; end if; when Section_Stmt => return Natural'Max (Get_Max_Lines (T.Next, N), Get_Max_Lines (T.N_Section, N)); when Include_Stmt => return Natural'Max (Get_Max_Lines (T.File.Info, N), Get_Max_Lines (T.Next, N)); end case; end Get_Max_Lines; Result : Natural := Get_Max_Lines (T.Sections, 1); begin pragma Assert (T.Kind = Table_Stmt); Max_Lines := Result; if T.Terminate_Sections then declare N_Section : constant Positive := Count_Section; begin if Result mod N_Section /= 0 then Result := Result + N_Section - (Result mod N_Section); end if; end; end if; Max_Expand := Result; end Get_Max; ------------- -- Is_True -- ------------- function Is_True (Str : String) return Boolean is L_Str : constant String := Characters.Handling.To_Upper (Str); begin return L_Str = "TRUE"; end Is_True; begin if T = null then return; end if; case T.Kind is when Info | C_Info => Analyze (T.Next, State); when Text => begin Analyze (T.Text); exception when E : others => Exceptions.Raise_Exception (Template_Error'Identity, "In " & Filename & " at line" & Natural'Image (T.Line) & ", " & Exceptions.Exception_Message (E) & '.'); end; Analyze (T.Next, State); when If_Stmt => if Analyze (T.Cond) = "TRUE" then Analyze (T.N_True, State); else Analyze (T.N_False, State); end if; Analyze (T.Next, State); when Table_Stmt => declare Max_Lines, Max_Expand : Natural; begin Get_Max (T, Max_Lines, Max_Expand); Analyze (T.Sections, Table_State'(State.I, State.J, Max_Lines, Max_Expand, State.Table_Level + 1, State.Section_Number + 1)); end; Analyze (T.Next, State); when Section_Stmt => declare First_Section : constant Tree := T; Current : Tree := T; Section : Positive := 1; begin for K in 1 .. State.Max_Expand loop Analyze (Current.Next, Table_State'(State.J, K, State.Max_Lines, State.Max_Expand, State.Table_Level, Section)); Current := Current.N_Section; Section := Section + 1; if Current = null then Current := First_Section; Section := 1; end if; end loop; end; when Include_Stmt => Analyze (T.File.Info, State); Analyze (T.Next, State); end case; end Analyze; T : Static_Tree; begin T := Load (Filename, Cached); Now := Ada.Calendar.Clock; -- Used for the time related variable Analyze (T.C_Info, Empty_State); if not Cached then Release (T.Info); else Cached_Files.Prot.Release (T); end if; return Results; end Parse; ------------- -- Release -- ------------- procedure Release (T : in out Tree) is procedure Free is new Ada.Unchecked_Deallocation (Node, Tree); begin if T = null then return; end if; case T.Kind is when Info => declare I : Tree := T.I_File; O : Tree; begin while I /= null loop O := I; I := I.Next; Free (O); end loop; end; Release (T.Next); Free (T); when C_Info => Release (T.Next); Free (T); when Text => Data.Release (T.Text); Release (T.Next); Free (T); when If_Stmt => Expr.Release (T.Cond); Release (T.N_True); Release (T.N_False); Release (T.Next); Free (T); when Table_Stmt => Release (T.Sections); Release (T.Next); Free (T); when Section_Stmt => Release (T.Next); Release (T.N_Section); Free (T); when Include_Stmt => T.File.Info.Ref := T.File.Info.Ref - 1; if T.File.Info.Ref = 0 then -- No more reference to this include file we release it. Release (T.File.C_Info); end if; Release (T.Next); Free (T); end case; end Release; ------------------------ -- Set_Tag_Separators -- ------------------------ procedure Set_Tag_Separators (Start_With : String := Default_Begin_Tag; Stop_With : String := Default_End_Tag) is begin Begin_Tag := To_Unbounded_String (Start_With); End_Tag := To_Unbounded_String (Stop_With); end Set_Tag_Separators; --------------- -- Translate -- --------------- function Translate (Template : String; Translations : Translate_Table := No_Translation) return String is T : Data.Tree := Data.Parse (Template); P : Data.Tree := T; Results : Unbounded_String; function Translate (Var : Tag) return String; -- Returns translation for Var. --------------- -- Translate -- --------------- function Translate (Var : Tag) return String is begin for K in Translations'Range loop if Var.Name = Translations (K).Variable then declare Tk : constant Association := Translations (K); begin case Tk.Kind is when Std => return Translate (Var, To_String (Tk.Value)); when others => return ""; end case; end; end if; end loop; return ""; end Translate; use type Data.Tree; begin while P /= null loop case P.Kind is when Data.Text => Append (Results, P.Value); when Data.Var => Append (Results, Translate (P.Var)); end case; P := P.Next; end loop; Data.Release (T); return To_String (Results); end Translate; end Templates_Parser; polyorb-2.8~20110207.orig/src/aws_orig/aws-config-set.ads0000644000175000017500000002177011750740337022337 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- A W S . C O N F I G . S E T -- -- -- -- S p e c -- -- -- -- Copyright (C) 2000-2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- This package can be used to Set any AWS parameters. package AWS.Config.Set is ------------------------ -- Per Server Options -- ------------------------ procedure Server_Name (O : in out Object; Value : String); -- This is the name of the server as set by AWS.Server.Start. procedure WWW_Root (O : in out Object; Value : String); -- This is the root directory name for the server. This variable is not -- used internally by AWS. It is supposed to be used by the callback -- procedures who want to retreive physical objects (images, Web -- pages...). The default value is the current working directory. procedure Admin_URI (O : in out Object; Value : String); -- This is the name of the admin server page as set by AWS.Server.Start. procedure Server_Host (O : in out Object; Value : String); -- This is the server host as set by the HTTP object declaration. procedure Server_Port (O : in out Object; Value : Positive); -- This is the server port as set by the HTTP object declaration. procedure Security (O : in out Object; Value : Boolean); -- Enable security (HTTPS/SSL) if Value is True. procedure Certificate (Filename : String); -- Set the certificate to be used with the secure server. procedure Hotplug_Port (O : in out Object; Value : Positive); -- This is the hotplug communication port needed to register and -- un-register an hotplug module. procedure Max_Connection (O : in out Object; Value : Positive); -- This is the max simultaneous connections as set by the HTTP object -- declaration. procedure Accept_Queue_Size (O : in out Object; Value : Positive); -- This is the size of the queue for the incoming requests. Higher this -- value will be and less "connection refused" will be reported to the -- client. procedure Log_File_Directory (O : in out Object; Value : String); -- This point to the directory where log files will be written. The -- directory returned will end with a directory separator. procedure Log_Filename_Prefix (O : in out Object; Value : String); -- This is the prefix to use for the log filename. procedure Log_Split_Mode (O : in out Object; Value : String); -- This is split mode for the log file. Possible values are : Each_Run, -- Daily, Monthly and None. Any other values will raise an exception. procedure Error_Log_Filename_Prefix (O : in out Object; Value : String); -- This is the prefix to use for the log filename. procedure Error_Log_Split_Mode (O : in out Object; Value : String); -- This is split mode for the log file. Possible values are : Each_Run, -- Daily, Monthly and None. Any other values will raise an exception. procedure Upload_Directory (O : in out Object; Value : String); -- This point to the directory where uploaded files will be stored. The -- directory returned will end with a directory separator. procedure Session (O : in out Object; Value : Boolean); -- Enable session handling is Value is True. procedure Cleaner_Wait_For_Client_Timeout (O : in out Object; Value : Duration); -- Number of seconds to timout on waiting for a client request. -- This is a timeout for regular cleaning task. procedure Cleaner_Client_Header_Timeout (O : in out Object; Value : Duration); -- Number of seconds to timout on waiting for client header. -- This is a timeout for regular cleaning task. procedure Cleaner_Client_Data_Timeout (O : in out Object; Value : Duration); -- Number of seconds to timout on waiting for client message body. -- This is a timeout for regular cleaning task. procedure Cleaner_Server_Response_Timeout (O : in out Object; Value : Duration); -- Number of seconds to timout on waiting for client to accept answer. -- This is a timeout for regular cleaning task. procedure Force_Wait_For_Client_Timeout (O : in out Object; Value : Duration); -- Number of seconds to timout on waiting for a client request. -- This is a timeout for urgent request when resources are missing. procedure Force_Client_Header_Timeout (O : in out Object; Value : Duration); -- Number of seconds to timout on waiting for client header. -- This is a timeout for urgent request when resources are missing. procedure Force_Client_Data_Timeout (O : in out Object; Value : Duration); -- Number of seconds to timout on waiting for client message body. -- This is a timeout for urgent request when resources are missing. procedure Force_Server_Response_Timeout (O : in out Object; Value : Duration); -- Number of seconds to timout on waiting for client to accept answer. -- This is a timeout for urgent request when resources are missing. procedure Send_Timeout (O : in out Object; Value : Duration); -- Number of seconds to timeout when sending chunck of data. procedure Receive_Timeout (O : in out Object; Value : Duration); -- Number of seconds to timeout when receiving chunck of data. procedure Status_Page (O : in out Object; Value : String); -- Filename for the status page. procedure Up_Image (O : in out Object; Value : String); -- Filename for the up arrow image used in the status page. procedure Down_Image (O : in out Object; Value : String); -- Filename for the down arrow image used in the status page. procedure Logo_Image (O : in out Object; Value : String); -- Filename for the AWS logo image used in the status page. procedure Case_Sensitive_Parameters (O : in out Object; Value : Boolean); -- Parameters are handled with the case if Value is True. procedure Line_Stack_Size (O : in out Object; Value : Positive); -- HTTP lines stack size. ------------------------- -- Per Process Options -- ------------------------- procedure Session_Cleanup_Interval (Value : Duration); -- Number of seconds between each run of the cleaner task to remove -- obsolete session data. procedure Session_Lifetime (Value : Duration); -- Number of seconds to keep a session if not used. After this period the -- session data is obsoleted and will be removed during new cleanup. procedure Parameter (Config : in out Object; Name : String; Value : String; Error_Context : String := ""); -- Set one of the AWS HTTP per server parameters. Raises Constraint_Error -- in case of wrong parameter name or wrong parameter value. -- Error_Context may contain additional information about the parameter. -- This message will be added to the Constraint_Error exception. -- One way to use Error_Context is to set it with information about -- where this parameter come form. procedure Parameter (Name : String; Value : String; Error_Context : String := ""); -- Set one of the AWS HTTP per process parameters. See description above. end AWS.Config.Set; polyorb-2.8~20110207.orig/src/aws_orig/aws-dispatchers-callback.ads0000644000175000017500000000544211750740337024342 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- A W S . D I S P A T C H E R S . C A L L B A C K -- -- -- -- S p e c -- -- -- -- Copyright (C) 2000-2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- Dispatch on a Callback procedure. with AWS.Dispatchers; with AWS.Response; with AWS.Status; package AWS.Dispatchers.Callback is type Handler is new Dispatchers.Handler with private; -- This is a simple wrapper around standard callback procedure (access to -- function). It will be used to build dispatchers services and for the -- main server callback. function Create (Callback : Response.Callback) return Handler; pragma Inline (Create); -- Build a dispatcher for the specified callback. function Dispatch (Dispatcher : Handler; Request : Status.Data) return Response.Data; private type Handler is new AWS.Dispatchers.Handler with record Callback : Response.Callback; end record; end AWS.Dispatchers.Callback; polyorb-2.8~20110207.orig/src/aws_orig/aws-containers-tables-set.adb0000644000175000017500000002113611750740337024462 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- A W S . C O N T A I N E R S . T A B L E S . S E T -- -- -- -- B o d y -- -- -- -- Copyright (C) 2000-2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with Ada.Unchecked_Deallocation; package body AWS.Containers.Tables.Set is procedure Reset (Table : in out Index_Table_Type); -- Free all elements and destroy his entries. procedure Free is new Ada.Unchecked_Deallocation (Element, Element_Access); procedure Free_Elements (Data : in out Data_Table.Instance); -- Free all dynamically allocated strings in the data table. --------- -- Add -- --------- procedure Add (Table : in out Table_Type; Name, Value : String) is L_Key : constant String := Normalize_Name (Name, not Table.Case_Sensitive); Found : Boolean; procedure Add_Value (Key : String; Value : in out Name_Index_Table); -- Append value to the current key's values --------------- -- Add_Value -- --------------- procedure Add_Value (Key : String; Value : in out Name_Index_Table) is pragma Warnings (Off, Key); begin Name_Indexes.Append (Value, Data_Table.Last (Table.Data)); end Add_Value; procedure Update is new Index_Table.Update_Value_Or_Status_G (Add_Value); begin -- Add name/value pair into the Data table Data_Table.Append (Table.Data, new Element' (Name_Length => Name'Length, Value_Length => Value'Length, Name => Name, Value => Value)); -- ??? Update (Table => Index_Table.Table_Type (Table.Index.all), Key => L_Key, Found => Found); -- ??? if not Found then declare Value : Name_Index_Table; begin Name_Indexes.Init (Value); Name_Indexes.Append (Value, Data_Table.Last (Table.Data)); Insert (Table.Index.all, L_Key, Value); end; end if; end Add; -------------------- -- Case_Sensitive -- -------------------- procedure Case_Sensitive (Table : in out Table_Type; Mode : Boolean) is begin Table.Case_Sensitive := Mode; end Case_Sensitive; ---------- -- Free -- ---------- procedure Free (Table : in out Table_Type) is procedure Free is new Ada.Unchecked_Deallocation (Index_Table_Type, Index_Access); begin if Table.Index /= null then Reset (Table.Index.all); Free (Table.Index); Free_Elements (Table.Data); Data_Table.Free (Table.Data); end if; end Free; ------------------- -- Free_Elements -- ------------------- procedure Free_Elements (Data : in out Data_Table.Instance) is begin for I in Data_Table.First .. Data_Table.Last (Data) loop Free (Data.Table (I)); end loop; end Free_Elements; ----------- -- Reset -- ----------- procedure Reset (Table : in out Index_Table_Type) is procedure Release_Value (Key : String; Value : in out Name_Index_Table; Order_Number : Positive; Continue : in out Boolean); -- Release memory associted with the value ------------------- -- Release_Value -- ------------------- procedure Release_Value (Key : String; Value : in out Name_Index_Table; Order_Number : Positive; Continue : in out Boolean) is pragma Warnings (Off, Key); pragma Warnings (Off, Order_Number); pragma Warnings (Off, Continue); begin Name_Indexes.Free (Value); end Release_Value; procedure Release_Values is new Index_Table.Disorder_Traverse_And_Update_Value_G (Release_Value); begin Release_Values (Index_Table.Table_Type (Table)); Destroy (Table); end Reset; procedure Reset (Table : in out Table_Type) is begin if Table.Index = null then Table.Index := new Index_Table_Type; else Reset (Table.Index.all); Free_Elements (Table.Data); end if; Data_Table.Init (Table.Data); end Reset; ------------ -- Update -- ------------ procedure Update (Table : in out Table_Type; Name : String; Value : String; N : Positive := 1) is L_Key : constant String := Normalize_Name (Name, not Table.Case_Sensitive); Found : Boolean; procedure Update_Value (Key : String; Values : in out Name_Index_Table); -- Append value to the current key's values ------------------ -- Update_Value -- ------------------ procedure Update_Value (Key : String; Values : in out Name_Index_Table) is pragma Warnings (Off, Key); begin if Key_Positive (N) <= Name_Indexes.Last (Values) then declare Index : constant Positive := Values.Table (Key_Positive (N)); begin Free (Table.Data.Table (Index)); Table.Data.Table (Index) := new Element' (Name_Length => Name'Length, Value_Length => Value'Length, Name => Name, Value => Value); end; elsif Key_Positive (N) = Name_Indexes.Last (Values) + 1 then Data_Table.Append (Table.Data, new Element' (Name_Length => Name'Length, Value_Length => Value'Length, Name => Name, Value => Value)); Name_Indexes.Append (Values, Data_Table.Last (Table.Data)); else raise Constraint_Error; end if; end Update_Value; procedure Update is new Index_Table.Update_Value_Or_Status_G (Update_Value); begin Update (Table => Index_Table.Table_Type (Table.Index.all), Key => L_Key, Found => Found); if not Found then if N /= 1 then raise Constraint_Error; end if; declare Values : Name_Index_Table; begin Name_Indexes.Init (Values); Data_Table.Append (Table.Data, new Element' (Name_Length => Name'Length, Value_Length => Value'Length, Name => Name, Value => Value)); Name_Indexes.Append (Values, Data_Table.Last (Table.Data)); Insert (Table.Index.all, L_Key, Values); end; end if; end Update; end AWS.Containers.Tables.Set; polyorb-2.8~20110207.orig/src/aws_orig/aws-templates.ads0000644000175000017500000000354211750740337022274 0ustar xavierxavier------------------------------------------------------------------------------ -- Ada Web Server -- -- -- -- Copyright (C) 2000-2001 -- -- ACT-Europe -- -- -- -- Authors: Dmitriy Anisimkov - Pascal Obry -- -- -- -- This library is free software; you can redistribute it and/or modify -- -- it under the terms of the GNU General Public License as published by -- -- the Free Software Foundation; either version 2 of the License, or (at -- -- your option) any later version. -- -- -- -- This library is distributed in the hope that it will be useful, but -- -- WITHOUT ANY WARRANTY; without even the implied warranty of -- -- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -- -- General Public License for more details. -- -- -- -- You should have received a copy of the GNU General Public License -- -- along with this library; if not, write to the Free Software Foundation, -- -- Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. -- -- -- ------------------------------------------------------------------------------ with Templates_Parser; package AWS.Templates renames Templates_Parser; polyorb-2.8~20110207.orig/src/aws_orig/aws-dispatchers.adb0000644000175000017500000000662211750740337022570 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- A W S . D I S P A T C H E R S -- -- -- -- B o d y -- -- -- -- Copyright (C) 2000-2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with Ada.Unchecked_Deallocation; package body AWS.Dispatchers is procedure Release is new Ada.Unchecked_Deallocation (Handler'Class, Handler_Class_Access); procedure Free is new Ada.Unchecked_Deallocation (Natural, Natural_Access); ------------ -- Adjust -- ------------ procedure Adjust (Dispatcher : in out Handler) is begin Dispatcher.Ref_Counter.all := Dispatcher.Ref_Counter.all + 1; end Adjust; -------------- -- Finalize -- -------------- procedure Finalize (Dispatcher : in out Handler) is begin Dispatcher.Ref_Counter.all := Dispatcher.Ref_Counter.all - 1; if Dispatcher.Ref_Counter.all = 0 then Free (Dispatcher.Ref_Counter); end if; end Finalize; ---------- -- Free -- ---------- procedure Free (Dispatcher : in out Handler_Class_Access) is begin Release (Dispatcher); end Free; ---------------- -- Initialize -- ---------------- procedure Initialize (Dispatcher : in out Handler) is begin Dispatcher.Ref_Counter := new Natural'(1); end Initialize; ----------------- -- Ref_Counter -- ----------------- function Ref_Counter (Dispatcher : Handler) return Natural is begin if Dispatcher.Ref_Counter = null then return 0; else return Dispatcher.Ref_Counter.all; end if; end Ref_Counter; end AWS.Dispatchers; polyorb-2.8~20110207.orig/src/aws_orig/table_of_strings_and_static_values_g.ads0000644000175000017500000007564011750740337027120 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- TABLE_OF_STRINGS_AND_STATIC_VALUES_G -- -- -- -- S p e c -- -- -- -- Copyright (C) 2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- TITLE: GENERIC PACKAGE FOR TABLES OF STRINGS ASSOCIATED WITH VALUES. -- REVISION: 13-JUL-1992 Ph. Kipfer (PKR), File header format -- APPROVAL: 03-DEC-1987 C. Genillard. -- CREATION: 13-AUG-1987 A. Strohmeier. with Table_Of_Dynamic_Keys_And_Static_Values_G; generic type Character_Type is (<>); type String_Type is array (Positive range <>) of Character_Type; with function Less (Left, Right : String_Type) return Boolean; -- Defines ordering of strings. with function Equals (Left, Right : String_Type) return Boolean; -- Defines equality between strings. type Value_Type is private; package Table_Of_Strings_And_Static_Values_G is -- OVERVIEW: -- This package provides associative tables of unlimited dynamic size -- with entries of type (String_Type, VALUE_TYPE), where VALUE_TYPE is -- specified by a generic parameter. -- Such a couple will also be called an item. The string -- component acts as a key. Its length is varying. -- The type TABLE_TYPE is implemented in such a way that every object -- has the implied initial value of an empty table. -- Two items (s1, v1) and (s2, v2) have same key if and only if -- EQUALS (s1, s2). -- A table may not contain duplicate items, that is items with same key. -- The following consistency condition must be fullfilled by the -- relational -- operation LESS and EQUALS: -- (i) EQUALS (s1, s2) implies not LESS (s1, s2) and not LESS (s2, s1) -- (ii) not LESS (s1, s2) and not EQUALS (s1, s2) implies LESS (s2, s1) -- In our terminology, a static type is a type which is neither a limited -- type nor an access type. When an actual generic access type is -- associated with a generic static type, objects would be shared, i.e. -- only the access -- value would be stored, without copying the accessed object. -- On the opposite, a dynamic type may be limited or an access type. -- However a dynamic type must have the feature that every object has an -- implied initial value. -- Depending on the very nature of the type VALUE_TYPE, one of the -- provided -- packages has to be used: -- TABLE_OF_STRINGS_AND_DYNAMIC_VALUES_G -- TABLE_OF_STRINGS_AND_STATIC_VALUES_G -- -- CAUTION: -- Functions which return the value of an item (or part of it) of the -- structure share the item with the structure and do not return a copy of -- it. This may have consequences if the type of the item, (or some -- component of it) is an access type. For instance, when accessing an -- item by a function -- call, this item must not be destroyed or modified during the query. -- -- PRIMITIVES: -- CONSTRUCTORS: -- ASSIGN -- INSERT (2) -- INSERT_OR_REPLACE_VALUE -- REPLACE_VALUE (2) -- REMOVE (3) -- REMOVE_MIN (3) -- REMOVE_MAX (3) -- UPDATE_VALUE_OR_EXCEPTION_G -- UPDATE_VALUE_OR_STATUS_G -- QUERIES: -- SIZE -- IS_EMPTY -- IS_PRESENT -- VALUE -- GET_VALUE -- GET_MIN_ITEM -- GET_MAX_ITEM -- MIN_KEY -- GET_MIN_KEY -- MAX_KEY -- GET_MAX_KEY -- GET_LESS_ITEM -- GET_LESS_OR_EQUAL_ITEM -- GET_GREATER_ITEM -- GET_GREATER_OR_EQUAL_ITEM -- LESS_KEY -- GET_LESS_KEY -- LESS_OR_EQUAL_KEY -- GET_LESS_OR_EQUAL_KEY -- GREATER_KEY -- GET_GREATER_KEY -- GREATER_OR_EQUAL_KEY -- GET_GREATER_OR_EQUAL_KEY -- SET_OPERATIONS: -- SET_OPERATIONS_G -- UNION -- INTERSECTION -- DIFFERENCE -- SYMMETRIC_DIFFERENCE -- "=" (set equality) -- "<" (strict set inclusion) -- "<=" (set inclusion) -- ">" (strict set inclusion) -- ">=" (set inclusion) -- ITERATORS: -- TRAVERSE_ASC_G -- TRAVERSE_DESC_G -- TRAVERSE_ASC_AND_UPDATE_VALUE_G -- TRAVERSE_DESC_AND_UPDATE_VALUE_G -- DISORDER_TRAVERSE_G -- DISORDER_TRAVERSE_AND_UPDATE_VALUE_G -- HEAP MANAGEMENT: -- DESTROY -- RELEASE_FREE_LIST -- SET_MAX_FREE_LIST_SIZE -- FREE_LIST_SIZE -- -- ALGORITHM: -- A table is implemented as a balanced search binary tree (AVL-tree) -- using pointers. The items are sorted in the tree by increasing keys in -- conformance to inorder. -- An internal free list is used to avoid returning each free item (i.e. -- coming from REMOVE) to the system, so long as the length of this list -- does not exceed MAX_FREE_LIST_SIZE, in which case the free item is -- immediately returned to the system. When a new item has to be inserted -- (i.e. by a call to INSERT), an element is recovered from the free list -- if it is not empty. Otherwise, new space is taken from the system. type Table_Type is limited private; Duplicate_Item_Error, Missing_Item_Error, Empty_Structure_Error : exception; String_Constraint_Error : exception; -- CONSTRUCTORS: procedure Assign (Destination : in out Table_Type; Source : Table_Type); -- OVERVIEW: -- Begins by a call to DESTROY (DESTINATION) and then copies SOURCE into -- DESTINATION. Note the "in out" mode of the formal parameter DESTINATION. procedure Insert (Table : in out Table_Type; Key : String_Type; Value : Value_Type); -- OVERVIEW: -- Inserts the couple (KEY, VALUE) into TABLE. -- ERROR: -- If an entry with the given key is already in the table, then exception -- DUPLICATE_ITEM_ERROR is raised. procedure Insert (Table : in out Table_Type; Key : String_Type; Value : Value_Type; Duplicate_Item : out Boolean); -- OVERVIEW: -- Inserts the couple (KEY, VALUE) into TABLE. No action is taken and no -- error occurs if an entry with the given key is already in the table -- except that DUPLICATE_ITEM is set to true. procedure Insert_Or_Replace_Value (Table : in out Table_Type; Key : String_Type; Value : Value_Type); -- OVERVIEW: -- Inserts the couple (KEY, VALUE) into TABLE if there is no entry with -- this key. Otherwise the given VALUE replaces the previous one. procedure Replace_Value (Table : in out Table_Type; Key : String_Type; Value : Value_Type); -- OVERVIEW: -- An entry having key KEY is searched for in TABLE. The given VALUE then -- replaces the previous one. -- ERROR: -- If there is no entry with the given key, the exception -- MISSING_ITEM_ERROR is raised. procedure Replace_Value (Table : in out Table_Type; Key : String_Type; Value : Value_Type; Found : out Boolean); -- OVERVIEW: -- An entry having key KEY is searched for in TABLE. The given VALUE then -- replaces the previous one. No action is taken and no error occurs if -- there is no entry with the given key, except that FOUND is set to false. procedure Remove (Table : in out Table_Type; Key : String_Type); procedure Remove (Table : in out Table_Type; Key : String_Type; Value : out Value_Type); -- OVERVIEW: -- Removes the entry with key KEY from TABLE and returns in parameter -- VALUE, if present, the associated VALUE. -- ERROR: -- If there is no entry with the given key, the exception -- MISSING_ITEM_ERROR is raised. procedure Remove (Table : in out Table_Type; Key : String_Type; Found : out Boolean); -- OVERVIEW: -- Removes the entry with key KEY from TABLE. No action is taken and no -- error occurs if there is no entry with the given key value, except that -- FOUND is set to false. procedure Remove_Min (Table : in out Table_Type); -- OVERVIEW: -- Removes the entry with the smallest key from TABLE. -- ERROR: -- Raises EMPTY_STRUCTURE_ERROR if TABLE is empty. procedure Remove_Max (Table : in out Table_Type); -- OVERVIEW: -- Removes the entry with the greatest key from TABLE. -- ERROR: -- Raises EMPTY_STRUCTURE_ERROR if TABLE is empty. generic with procedure Modify (Key : String_Type; Value : in out Value_Type) is <>; procedure Update_Value_Or_Exception_G (Table : in out Table_Type; Key : String_Type); -- OVERVIEW: -- An entry with key KEY is searched for in TABLE. The associated item is -- then passed to procedure MODIFY for modification of its value part. -- ERROR: -- Raises MISSING_ITEM_ERROR if KEY is not in TABLE. generic with procedure Modify (Key : String_Type; Value : in out Value_Type) is <>; procedure Update_Value_Or_Status_G (Table : in out Table_Type; Key : String_Type; Found : out Boolean); -- OVERVIEW: -- An entry with key KEY is searched for in TABLE. The associated item is -- then passed to procedure MODIFY for modification of its value part. No -- action is taken and no error occurs if there is no entry with the given -- key, except that FOUND is set to false. -- QUERIES: function Size (Table : Table_Type) return Natural; -- OVERVIEW: -- Returns the number of entries currently in TABLE. function Is_Empty (Table : Table_Type) return Boolean; -- OVERVIEW: -- Returns TRUE if and only if the TABLE is empty. function Is_Present (Table : Table_Type; Key : String_Type) return Boolean; -- OVERVIEW: -- Returns TRUE if and only if an ITEM with key KEY is in TABLE. function Value (Table : Table_Type; Key : String_Type) return Value_Type; procedure Get_Value (Table : Table_Type; Key : String_Type; Value : out Value_Type); -- OVERVIEW: -- Gives the VALUE associated with KEY in TABLE. -- ERROR: -- Raises MISSING_ITEM_ERROR if KEY is not found in TABLE. procedure Get_Min_Item (Table : Table_Type; Key : out String_Type; Last : out Natural; Value : out Value_Type); -- OVERVIEW: -- Gives the smallest KEY and the VALUE associated with it in TABLE; -- returns in LAST the index value such that KEY(LAST) is the last -- character replaced. -- ERROR: -- Raises EMPTY_STRUCTURE_ERROR if TABLE is empty. -- Raises STRING_CONSTRAINT_ERROR if KEY is too short. procedure Get_Max_Item (Table : Table_Type; Key : out String_Type; Last : out Natural; Value : out Value_Type); -- OVERVIEW: -- Gives the biggest KEY and the VALUE associated with it in TABLE; -- returns in LAST the index value such that KEY(LAST) is the last -- character replaced. -- ERROR: -- Raises EMPTY_STRUCTURE_ERROR if TABLE is empty. -- Raises STRING_CONSTRAINT_ERROR if KEY is too short. function Min_Key (Table : Table_Type) return String_Type; -- OVERVIEW: -- Gives the smallest KEY of TABLE. -- ERROR: -- Raises EMPTY_STRUCTURE_ERROR if TABLE is empty. procedure Get_Min_Key (Table : Table_Type; Key : out String_Type; Last : out Natural); -- OVERVIEW: -- Gives the smallest KEY of TABLE; returns in LAST the index value such -- that KEY(LAST) is the last character replaced. -- ERROR: -- Raises EMPTY_STRUCTURE_ERROR if TABLE is empty. -- Raises STRING_CONSTRAINT_ERROR if KEY is too short. function Max_Key (Table : Table_Type) return String_Type; -- OVERVIEW: -- Gives the biggest KEY of TABLE. -- ERROR: -- Raises EMPTY_STRUCTURE_ERROR if TABLE is empty. procedure Get_Max_Key (Table : Table_Type; Key : out String_Type; Last : out Natural); -- OVERVIEW: -- Gives the biggest KEY of TABLE; returns in LAST the index value such -- that KEY(LAST) is the last character replaced. -- ERROR: -- Raises EMPTY_STRUCTURE_ERROR if TABLE is empty. -- Raises STRING_CONSTRAINT_ERROR if KEY is too short. procedure Get_Less_Item (Table : Table_Type; Key_In : String_Type; Key_Out : out String_Type; Last : out Natural; Value : out Value_Type); -- OVERVIEW: -- Gives the entry (KEY_OUT, VALUE) having the greatest key value less -- than the value of the parameter KEY_IN; returns in LAST the index value -- such that KEY_OUT(LAST) is the last character replaced. -- ERROR: -- The exception MISSING_ITEM_ERROR is raised if there is not such -- an entry in the table. -- Raises STRING_CONSTRAINT_ERROR if KEY_OUT is too short. procedure Get_Less_Or_Equal_Item (Table : Table_Type; Key_In : String_Type; Key_Out : out String_Type; Last : out Natural; Value : out Value_Type); -- OVERVIEW: -- Gives the entry (KEY_OUT, VALUE) having the greatest key value less -- than or equal to the value of the parameter KEY_IN; returns in LAST the -- index value such that KEY_OUT(LAST) is the last character replaced. -- ERROR: -- The exception MISSING_ITEM_ERROR is raised if there is not such an -- entry in the table. -- Raises STRING_CONSTRAINT_ERROR if KEY_OUT is too short. procedure Get_Greater_Item (Table : Table_Type; Key_In : String_Type; Key_Out : out String_Type; Last : out Natural; Value : out Value_Type); -- OVERVIEW: -- Gives the entry (KEY_OUT, VALUE) having the smallest key value greater -- than the value of the parameter KEY_IN; returns in LAST the index value -- such that KEY_OUT(LAST) is the last character replaced. -- ERROR: -- The exception MISSING_ITEM_ERROR is raised if there is not such an -- entry in the table. -- Raises STRING_CONSTRAINT_ERROR if KEY_OUT is too short. procedure Get_Greater_Or_Equal_Item (Table : Table_Type; Key_In : String_Type; Key_Out : out String_Type; Last : out Natural; Value : out Value_Type); -- OVERVIEW: -- Gives the entry (KEY_OUT, VALUE) having the smallest key value greater -- than or equal to the value of the parameter KEY_IN; returns in LAST the -- index value such that KEY_OUT(LAST) is the last character replaced. -- ERROR: -- The exception MISSING_ITEM_ERROR is raised if there is not such an -- entry in the table. -- Raises STRING_CONSTRAINT_ERROR if KEY_OUT is too short. function Less_Key (Table : Table_Type; Key : String_Type) return String_Type; -- OVERVIEW: -- Gives the greatest key value less than the value of the parameter KEY. -- ERROR: -- The exception MISSING_ITEM_ERROR is raised if there is not such an -- entry in the table. procedure Get_Less_Key (Table : Table_Type; Key_In : String_Type; Key_Out : out String_Type; Last : out Natural); -- OVERVIEW: -- Gives in KEY_OUT the greatest key value less than the value of the -- parameter KEY_IN; returns in LAST the index value such that -- KEY_OUT(LAST) -- is the last character replaced. -- ERROR: -- The exception MISSING_ITEM_ERROR is raised if there is not such an -- entry in the table. -- Raises STRING_CONSTRAINT_ERROR if KEY_OUT is too short. function Less_Or_Equal_Key (Table : Table_Type; Key : String_Type) return String_Type; -- OVERVIEW: -- Gives the greatest key value less than or equal to the value of the -- parameter KEY. -- ERROR: -- The exception MISSING_ITEM_ERROR is raised if there is not such an -- entry in the table. procedure Get_Less_Or_Equal_Key (Table : Table_Type; Key_In : String_Type; Key_Out : out String_Type; Last : out Natural); -- OVERVIEW: -- Gives in KEY_OUT the greatest key value less than or equal to the -- value of the parameter KEY_IN; returns in LAST the index value such that -- KEY_OUT(LAST) is the last character replaced. -- ERROR: -- The exception MISSING_ITEM_ERROR is raised if there is not such an -- entry in the table. -- Raises STRING_CONSTRAINT_ERROR if KEY_OUT is too short. function Greater_Key (Table : Table_Type; Key : String_Type) return String_Type; -- OVERVIEW: -- Gives the smallest key value greater than the value of the parameter -- KEY. -- ERROR: -- The exception MISSING_ITEM_ERROR is raised if there is not such an -- entry in the table. procedure Get_Greater_Key (Table : Table_Type; Key_In : String_Type; Key_Out : out String_Type; Last : out Natural); -- OVERVIEW: -- Gives in KEY_OUT the smallest key value greater than the value of the -- parameter KEY_IN; returns in LAST the index value such that -- KEY_OUT(LAST) is the last character replaced. -- ERROR: -- The exception MISSING_ITEM_ERROR is raised if there is not such an -- entry in the table. -- Raises STRING_CONSTRAINT_ERROR if KEY_OUT is too short. function Greater_Or_Equal_Key (Table : Table_Type; Key : String_Type) return String_Type; -- OVERVIEW: -- Gives the smallest key value greater than or equal to the -- value of the parameter KEY. -- ERROR: -- The exception MISSING_ITEM_ERROR is raised if there is not such an -- entry in the table. procedure Get_Greater_Or_Equal_Key (Table : Table_Type; Key_In : String_Type; Key_Out : out String_Type; Last : out Natural); -- OVERVIEW: -- Gives in KEY_OUT the smallest key value greater than or equal to the -- value of the parameter KEY_IN; returns in LAST the index value such that -- KEY_OUT(LAST) is the last character replaced. -- ERROR: -- The exception MISSING_ITEM_ERROR is raised if there is not such -- an entry in the table. -- Raises STRING_CONSTRAINT_ERROR if KEY_OUT is too short. -- SET_OPERATIONS: generic package Set_Operations_G is procedure Union (Destination : in out Table_Type; Left, Right : Table_Type); -- OVERVIEW: -- Union of LEFT and RIGHT. If a key is both in LEFT and RIGHT, the -- value is taken from LEFT. procedure Intersection (Destination : in out Table_Type; Left, Right : Table_Type); -- OVERVIEW: -- Intersection of LEFT and RIGHT. The entries are taken from LEFT. procedure Difference (Destination : in out Table_Type; Left, Right : Table_Type); -- OVERVIEW: -- Set difference of LEFT and RIGHT. An entry is in the resulting -- table if it is in LEFT and if there is no entry with same key in -- RIGHT. procedure Symmetric_Difference (Destination : in out Table_Type; Left, Right : Table_Type); -- OVERVIEW: -- Symmetric set difference of LEFT and RIGHT. An entry is in the -- resulting table if it is in LEFT but there is no entry with same key -- in RIGHT or if it is in RIGHT but there is no entry with same key in -- LEFT. function "=" (Left, Right : Table_Type) return Boolean; -- OVERVIEW: -- Set equality; the LEFT and RIGHT tables contain entries with same -- keys. function "<" (Left, Right : Table_Type) return Boolean; -- OVERVIEW: -- Strict set inclusion; to each entry in the LEFT table an entry with -- same key is associated in the RIGHT table, but the two sets are not -- identical. function "<=" (Left, Right : Table_Type) return Boolean; -- OVERVIEW: -- Set inclusion; to each entry in the LEFT table an entry with same -- key is associated in the RIGHT table. function ">" (Left, Right : Table_Type) return Boolean; -- OVERVIEW: -- Strict set inclusion; to each entry in the RIGHT table an entry with -- same key is associated in the LEFT table, but the two sets are not -- identical. function ">=" (Left, Right : Table_Type) return Boolean; -- OVERVIEW: -- Set inclusion; to each entry in the RIGHT table an entry with same -- key is associated in the LEFT table. end Set_Operations_G; -- ITERATORS: generic with procedure Action (Key : String_Type; Value : Value_Type; Order_Number : Positive; Continue : in out Boolean) is <>; procedure Traverse_Asc_G (Table : Table_Type); -- OVERVIEW: -- The entries in TABLE are visited in ascending order of their key -- values. Procedure ACTION is applied on each entry within TABLE. -- ORDER_NUMBER gives the position of the visited entry in order of -- traversal. The boolean CONTINUE specifies if you want to proceed to the -- next entry or if you want to stop traversing. As long as you do not -- modify its value within ACTION, its value remains TRUE. -- REQUIREMENT: -- For your actual procedure ACTION, you must not use a procedure -- which modifies the traversed table. generic with procedure Action (Key : String_Type; Value : Value_Type; Order_Number : Positive; Continue : in out Boolean) is <>; procedure Traverse_Desc_G (Table : Table_Type); -- OVERVIEW: -- The entries in TABLE are visited in descending order of their key -- values. Procedure ACTION is applied on each entry within TABLE. -- ORDER_NUMBER gives the position of the visited entry in order of -- traversal. The boolean CONTINUE specifies if you want to proceed to the -- next entry or if you want to stop traversing. As long as you do not -- modify its value within ACTION, its value remains TRUE. -- REQUIREMENT: -- For your actual procedure ACTION, you must not use a procedure -- which modifies the traversed table. generic with procedure Modify (Key : String_Type; Value : in out Value_Type; Order_Number : Positive; Continue : in out Boolean) is <>; procedure Traverse_Asc_And_Update_Value_G (Table : in out Table_Type); -- OVERVIEW: -- The entries in TABLE are visited in ascending order of their key -- values. For each visited entry, procedure MODIFY is called. The value of -- the current entry is then replaced by the new value. -- ORDER_NUMBER gives the position of the visited entry in order of -- traversal. The boolean CONTINUE specifies if you want to proceed to the -- next entry or if you want to stop traversing. As long as you do not -- modify its value within MODIFY, its value remains TRUE. -- REQUIREMENT: -- For your actual procedure MODIFY, you must not use a procedure which -- modifies the traversed table. generic with procedure Modify (Key : String_Type; Value : in out Value_Type; Order_Number : Positive; Continue : in out Boolean) is <>; procedure Traverse_Desc_And_Update_Value_G (Table : in out Table_Type); -- OVERVIEW: -- The entries in TABLE are visited in descending order of their key -- values. For each visited entry, procedure MODIFY is called. The item -- value of the current entry is then replaced by the new value. -- ORDER_NUMBER gives the position of the visited entry in order of -- traversal. The boolean CONTINUE specifies if you want to proceed to the -- next entry or if you want to stop traversing. As long as you do not -- modify its value within MODIFY, its value remains TRUE. -- REQUIREMENT: -- For your actual procedure MODIFY, you must not use a procedure which -- modifies the traversed table. generic with procedure Action (Key : String_Type; Value : Value_Type; Order_Number : Positive; Continue : in out Boolean) is <>; procedure Disorder_Traverse_G (Table : Table_Type); -- OVERVIEW: -- The entries in TABLE are visited in disorder of their key values. -- procedure ACTION is applied on each entry within TABLE. -- ORDER_NUMBER gives the position of the visited entry in order of -- traversal. The boolean CONTINUE specifies if you want to proceed to the -- next entry or if you want to stop traversing. As long as you do not -- modify its value within ACTION, its value remains TRUE. -- Traversal by DISORDER_TRAVERSE_G is faster than by TRAVERSE_ASC_G or -- TRAVERSE_DESC_G. Moreover, use of the generic procedure -- DISORDER_TRAVERSE_G is recommended for saving a table in a backstore -- (file or linear list) because recovery will be efficient. -- REQUIREMENT: -- For your actual procedure ACTION, you must not use a procedure -- which modifies the traversed table. generic with procedure Modify (Key : String_Type; Value : in out Value_Type; Order_Number : Positive; Continue : in out Boolean) is <>; procedure Disorder_Traverse_And_Update_Value_G (Table : in out Table_Type); -- OVERVIEW: -- The entries in TABLE are visited in disorder of their key values. -- procedure MODIFY is applied on each entry within TABLE. The item -- value of the current entry is then replaced by the new value. -- ORDER_NUMBER gives the position of the visited entry in order of -- traversal. The boolean CONTINUE specifies if you want to proceed to the -- next entry or if you want to stop traversing. As long as you do not -- modify its value within MODIFY, its value remains TRUE. -- Traversal by DISORDER_TRAVERSE_G is faster than by TRAVERSE_ASC_G or -- TRAVERSE_DESC_G. -- REQUIREMENT: -- For your actual procedure MODIFY, you must not use a procedure -- which modifies the traversed table. -- HEAP MANAGEMENT: procedure Destroy (Table : in out Table_Type); -- OVERVIEW: -- Empties the TABLE and returns space to the free list. procedure Release_Free_List; -- OVERVIEW: -- Releases all items from the free list giving their space back to the -- system. procedure Set_Max_Free_List_Size (Max_Free_List_Size : Natural); -- OVERVIEW: -- Sets the maximum length of the internal free list which is 0 by -- default. -- If parameter MAX_FREE_LIST_SIZE is smaller than the current size -- of the list, the items in excess are returned to the system. function Free_List_Size return Natural; -- OVERVIEW: -- Returns the actual length of the internal free list. private type Access_String_Type is access String_Type; function Less (Left, Right : Access_String_Type) return Boolean; function Equals (Left, Right : Access_String_Type) return Boolean; procedure Assign (Destination : in out Access_String_Type; Source : Access_String_Type); procedure Destroy (Access_String : in out Access_String_Type); package Local_Package is new Table_Of_Dynamic_Keys_And_Static_Values_G (Access_String_Type, Less, Equals, Assign, Destroy, Value_Type); type Table_Type is new Local_Package.Table_Type; end Table_Of_Strings_And_Static_Values_G; polyorb-2.8~20110207.orig/src/aws_orig/aws-resources-streams.ads0000644000175000017500000000541111750740337023761 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- A W S . R E S O U R C E S . S T R E A M S -- -- -- -- S p e c -- -- -- -- Copyright (C) 2002-2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ package AWS.Resources.Streams is use Ada; type Stream_Type is abstract tagged limited private; type Stream_Access is access all Stream_Type'Class; function End_Of_File (Resource : Stream_Type) return Boolean is abstract; procedure Read (Resource : in out Stream_Type; Buffer : out Stream_Element_Array; Last : out Stream_Element_Offset) is abstract; procedure Close (File : in out Stream_Type) is abstract; procedure Create (File : out File_Type; Buffer : Stream_Access); pragma Inline (Create); -- Create the resource from user defined resource. private type Stream_Type is abstract new Resources.File_Tagged with null record; end AWS.Resources.Streams; polyorb-2.8~20110207.orig/src/aws_orig/aws-dispatchers-callback.adb0000644000175000017500000000502711750740337024320 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- A W S . D I S P A T C H E R S . C A L L B A C K -- -- -- -- B o d y -- -- -- -- Copyright (C) 2000-2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ package body AWS.Dispatchers.Callback is ------------ -- Create -- ------------ function Create (Callback : Response.Callback) return Handler is begin return (AWS.Dispatchers.Handler with Callback => Callback); end Create; -------------- -- Dispatch -- -------------- function Dispatch (Dispatcher : Handler; Request : Status.Data) return Response.Data is begin return Dispatcher.Callback (Request); end Dispatch; end AWS.Dispatchers.Callback; polyorb-2.8~20110207.orig/src/aws_orig/aws-parameters.ads0000644000175000017500000000546711750740337022451 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- A W S . P A R A M E T E R S -- -- -- -- S p e c -- -- -- -- Copyright (C) 2000-2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with Ada.Strings.Unbounded; with AWS.Containers.Tables; package AWS.Parameters is type List is new AWS.Containers.Tables.Table_Type with private; subtype VString_Array is AWS.Containers.Tables.VString_Array; function URI_Format (Parameter_List : List) return String; -- Returns the list of parameters in the URI format. This can be added -- after the ressource to form the complete URI. The format is: -- "?name1=value1&name2=value2..." -- See AWS.Containers.Tables for inherited routines. private -- A List must be initialized by calling AWS.Parameters.Set.Reset, Server -- is responsible for doing that. use Ada.Strings.Unbounded; type List is new AWS.Containers.Tables.Table_Type with record Parameters : Unbounded_String; end record; end AWS.Parameters; polyorb-2.8~20110207.orig/src/aws_orig/aws-hotplug.ads0000644000175000017500000000761511750740337021765 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- A W S . H O T P L U G -- -- -- -- S p e c -- -- -- -- Copyright (C) 2000-2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with Ada.Strings.Unbounded; with GNAT.Regexp; with AWS.Response; with AWS.Status; package AWS.Hotplug is type Filter_Set is private; procedure Register (Filters : in out Filter_Set; Regexp : String; URL : String); -- Add a Filter in the Filter_Set, the URL will be called if the URI match -- the regexp. If Regexp already exist it just replace the current entry. procedure Unregister (Filters : in out Filter_Set; Regexp : String); -- Removes a Filter from the Filter_Set. The filter name is defined by the -- regular expression. Does nothing if regexp is not found. procedure Apply (Filters : Filter_Set; Status : AWS.Status.Data; Found : out Boolean; Data : out Response.Data); -- Run through the filters and apply the first one for which the regular -- expression match the URI. Set Found to True if one filter has been -- called and in that case Data contain the answer, otherwise Found is set -- to False. procedure Move_Up (Filters : Filter_Set; N : Positive); -- Move filters number N up one position, it gives filter number N a -- better priority. procedure Move_Down (Filters : Filter_Set; N : Positive); -- Move filters number N down one position, it gives filter number N less -- priority. private use Ada.Strings.Unbounded; type Filter_Data is record Regexp_Str : Unbounded_String; Regexp : GNAT.Regexp.Regexp; URL : Unbounded_String; end record; type Filter_Array is array (Positive range <>) of Filter_Data; type Filter_Array_Access is access Filter_Array; type Filter_Set is record Count : Natural := 0; Set : Filter_Array_Access; end record; end AWS.Hotplug; polyorb-2.8~20110207.orig/src/aws_orig/templates_parser-input.adb0000644000175000017500000000762311750740337024200 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- T E M P L A T E S _ P A R S E R . I N P U T -- -- -- -- B o d y -- -- -- -- Copyright (C) 2002-2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- This is the implementation to be used with AWS, it is using AWS.Resources -- to support embedded resources. with Ada.Text_IO; with Ada.Unchecked_Deallocation; with AWS.Resources; package body Templates_Parser.Input is type File_Record is new AWS.Resources.File_Type; procedure Check_Open (File : File_Type); pragma Inline (Check_Open); -- Check if File is opened (File variable is not null). procedure Free is new Ada.Unchecked_Deallocation (File_Record, File_Type); ---------------- -- Check_Open -- ---------------- procedure Check_Open (File : File_Type) is begin if File = null then raise Ada.Text_IO.Status_Error; end if; end Check_Open; ----------- -- Close -- ----------- procedure Close (File : in out File_Type) is begin Check_Open (File); Close (File.all); Free (File); end Close; ----------------- -- End_Of_File -- ----------------- function End_Of_File (File : File_Type) return Boolean is begin Check_Open (File); return End_Of_File (File.all); end End_Of_File; -------------- -- Get_Line -- -------------- procedure Get_Line (File : File_Type; Buffer : out String; Last : out Natural) is begin Check_Open (File); Get_Line (File.all, Buffer, Last); end Get_Line; ------------------- -- LF_Terminated -- ------------------- function LF_Terminated (File : File_Type) return Boolean is begin Check_Open (File); return LF_Terminated (File.all); end LF_Terminated; ---------- -- Open -- ---------- procedure Open (File : in out File_Type; Name : String; Form : String := "") is begin if File /= null then Close (File); end if; File := new File_Record; Open (File.all, Name, Form); end Open; end Templates_Parser.Input; polyorb-2.8~20110207.orig/src/aws_orig/aws-translator-conversion.adb0000644000175000017500000000662511750740337024636 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- C O N V E R S I O N -- -- -- -- B o d y -- -- -- -- Copyright (C) 2000-2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- $RCSfile: aws-translator-conversion-f.adb,v $ -- $LastChangedRevision$ -- $LastChangedDate$ -- $LastChangedBy$ -- Fast convertion between String and Stream_Element_Array. -- Only for Ada compilers and platforms, where it is possible. with Ada.Unchecked_Conversion; separate (AWS.Translator) package body Conversion is ----------------------------- -- To_Stream_Element_Array -- ----------------------------- function To_Stream_Element_Array (Data : String) return Stream_Element_Array is subtype Fixed_String is String (Data'First .. Data'Last); subtype Fixed_Array is Stream_Element_Array (Stream_Element_Offset (Data'First) .. Stream_Element_Offset (Data'Last)); function To_Stream_Elements is new Ada.Unchecked_Conversion (Fixed_String, Fixed_Array); begin return To_Stream_Elements (Data); end To_Stream_Element_Array; --------------- -- To_String -- --------------- function To_String (Data : Stream_Element_Array) return String is subtype Fixed_String is String (Integer (Data'First) .. Integer (Data'Last)); subtype Fixed_Array is Stream_Element_Array (Data'First .. Data'Last); function To_Characters is new Ada.Unchecked_Conversion (Fixed_Array, Fixed_String); begin return To_Characters (Data); end To_String; end Conversion; polyorb-2.8~20110207.orig/src/aws_orig/aws-hotplug-get_status.adb0000644000175000017500000000513111750740337024113 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- A W S . H O T P L U G . G E T _ S T A T U S -- -- -- -- B o d y -- -- -- -- Copyright (C) 2000-2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ function AWS.Hotplug.Get_Status (Filters : Filter_Set) return Templates_Parser.Translate_Table is use Templates_Parser; Regexp : Vector_Tag; URL : Vector_Tag; -- Avoid : may be referenced before it has a value pragma Warnings (Off, Regexp); pragma Warnings (Off, URL); begin for K in 1 .. Filters.Count loop Regexp := Regexp & Filters.Set (K).Regexp_Str; URL := URL & Filters.Set (K).URL; end loop; return Translate_Table'(Assoc ("HP_REGEXP_V", Regexp), Assoc ("HP_URL_V", URL)); end AWS.Hotplug.Get_Status; polyorb-2.8~20110207.orig/src/aws_orig/aws-translator.ads0000644000175000017500000000653111750740337022470 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- A W S . T R A N S L A T O R -- -- -- -- S p e c -- -- -- -- Copyright (C) 2000-2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with Ada.Streams; with Ada.Strings.Unbounded; package AWS.Translator is function Base64_Encode (Data : Ada.Streams.Stream_Element_Array) return String; -- Encode Data using the base64 algorithm function Base64_Encode (Data : String) return String; -- Same as above but takes a string as input function Base64_Decode (B64_Data : String) return Ada.Streams.Stream_Element_Array; -- Decode B64_Data using the base64 algorithm function QP_Decode (QP_Data : String) return String; -- Decode QP_Data using the Quoted Printable algorithm function To_String (Data : Ada.Streams.Stream_Element_Array) return String; pragma Inline (To_String); -- Convert a Stream_Element_Array to a string. Note that as this routine -- returns a String it should not be used with large array as this could -- break the stack size limit. Use the routine below for large array. function To_Unbounded_String (Data : Ada.Streams.Stream_Element_Array) return Ada.Strings.Unbounded.Unbounded_String; -- Convert a Stream_Element_Array to an Unbounded_String. function To_Stream_Element_Array (Data : String) return Ada.Streams.Stream_Element_Array; pragma Inline (To_Stream_Element_Array); -- Convert a String to a Stream_Element_Array. end AWS.Translator; polyorb-2.8~20110207.orig/src/aws_orig/aws-resources-embedded.ads0000644000175000017500000000713311750740337024037 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- A W S . R E S O U R C E S . E M B E D D E D -- -- -- -- S p e c -- -- -- -- Copyright (C) 2002-2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- @@@ uses ada.calendar with Ada.Streams; package AWS.Resources.Embedded is use Ada; type Buffer_Access is access constant Streams.Stream_Element_Array; procedure Open (File : out File_Type; Name : String; Form : String := ""); -- Open resource from registered data. procedure Create (File : out File_Type; Buffer : Buffer_Access); -- Create the resource directly from memory data. function Is_Regular_File (Name : String) return Boolean; function File_Size (Name : String) return Ada.Streams.Stream_Element_Offset; function File_Timestamp (Name : String) return Ada.Calendar.Time; procedure Register (Name : String; Content : Buffer_Access; File_Time : Calendar.Time); -- Register a new file named Named into the embedded resources. The file -- content is pointed to by Content, the File_Time must be that last -- modification time stamp for the file. function Exists (Name : String) return Boolean; pragma Inline (Exists); -- Returns True if file named Name has been registered (i.e. it is an -- in-memory file). private type File_Tagged is new Resources.File_Tagged with record Buffer : Buffer_Access; K : Streams.Stream_Element_Offset; end record; function End_Of_File (Resource : File_Tagged) return Boolean; procedure Read (Resource : in out File_Tagged; Buffer : out Stream_Element_Array; Last : out Stream_Element_Offset); procedure Close (Resource : in out File_Tagged); end AWS.Resources.Embedded; polyorb-2.8~20110207.orig/src/aws_orig/aws-translator.adb0000644000175000017500000002467611750740337022461 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- A W S . T R A N S L A T O R -- -- -- -- B o d y -- -- -- -- Copyright (C) 2000-2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with Interfaces; with AWS.Utils; package body AWS.Translator is use Ada.Streams; package Conversion is function To_String (Data : Ada.Streams.Stream_Element_Array) return String; pragma Inline (To_String); -- Convert a Stream_Element_Array to a string. function To_Stream_Element_Array (Data : String) return Ada.Streams.Stream_Element_Array; pragma Inline (To_Stream_Element_Array); -- Convert a String to a Stream_Element_Array. end Conversion; ------------------- -- Base64_Decode -- ------------------- function Base64_Decode (B64_Data : String) return Stream_Element_Array is use Interfaces; function Base64 (C : Character) return Interfaces.Unsigned_32; pragma Inline (Base64); -- Returns the base64 stream element given a character Base64_Values : constant array (Character) of Interfaces.Unsigned_32 := ('A' => 0, 'B' => 1, 'C' => 2, 'D' => 3, 'E' => 4, 'F' => 5, 'G' => 6, 'H' => 7, 'I' => 8, 'J' => 9, 'K' => 10, 'L' => 11, 'M' => 12, 'N' => 13, 'O' => 14, 'P' => 15, 'Q' => 16, 'R' => 17, 'S' => 18, 'T' => 19, 'U' => 20, 'V' => 21, 'W' => 22, 'X' => 23, 'Y' => 24, 'Z' => 25, 'a' => 26, 'b' => 27, 'c' => 28, 'd' => 29, 'e' => 30, 'f' => 31, 'g' => 32, 'h' => 33, 'i' => 34, 'j' => 35, 'k' => 36, 'l' => 37, 'm' => 38, 'n' => 39, 'o' => 40, 'p' => 41, 'q' => 42, 'r' => 43, 's' => 44, 't' => 45, 'u' => 46, 'v' => 47, 'w' => 48, 'x' => 49, 'y' => 50, 'z' => 51, '0' => 52, '1' => 53, '2' => 54, '3' => 55, '4' => 56, '5' => 57, '6' => 58, '7' => 59, '8' => 60, '9' => 61, '+' => 62, '/' => 63, others => 16#ffffffff#); function Shift_Left (Value : Interfaces.Unsigned_32; Amount : Natural) return Interfaces.Unsigned_32; pragma Import (Intrinsic, Shift_Left); function Shift_Right (Value : Interfaces.Unsigned_32; Amount : Natural) return Interfaces.Unsigned_32; pragma Import (Intrinsic, Shift_Right); Result : Stream_Element_Array (Stream_Element_Offset range 1 .. B64_Data'Length); R : Stream_Element_Offset := 1; Group : Interfaces.Unsigned_32 := 0; J : Integer := 18; Pad : Stream_Element_Offset := 0; ------------ -- Base64 -- ------------ function Base64 (C : Character) return Interfaces.Unsigned_32 is begin pragma Assert (Base64_Values (C) < 64); return Base64_Values (C); end Base64; begin for C in B64_Data'Range loop if B64_Data (C) = ASCII.LF or else B64_Data (C) = ASCII.CR then null; else case B64_Data (C) is when '=' => Pad := Pad + 1; when others => Group := Group or Shift_Left (Base64 (B64_Data (C)), J); end case; J := J - 6; if J < 0 then Result (R .. R + 2) := (Stream_Element (Shift_Right (Group and 16#FF0000#, 16)), Stream_Element (Shift_Right (Group and 16#00FF00#, 8)), Stream_Element (Group and 16#0000FF#)); R := R + 3; Group := 0; J := 18; end if; end if; end loop; return Result (1 .. R - 1 - Pad); end Base64_Decode; ------------------- -- Base64_Encode -- ------------------- function Base64_Encode (Data : Stream_Element_Array) return String is function Shift_Left (Value : Stream_Element; Amount : Natural) return Stream_Element; pragma Import (Intrinsic, Shift_Left); function Shift_Right (Value : Stream_Element; Amount : Natural) return Stream_Element; pragma Import (Intrinsic, Shift_Right); Encoded_Length : constant Integer := 4 * ((Data'Length + 2) / 3); Result : String (1 .. Encoded_Length); Last : Integer := Result'First - 1; State : Positive range 1 .. 3 := 1; E, Prev_E : Stream_Element := 0; Base64 : constant array (Stream_Element range 0 .. 63) of Character := ('A', 'B', 'C', 'D', 'E', 'F', 'G', 'H', 'I', 'J', 'K', 'L', 'M', 'N', 'O', 'P', 'Q', 'R', 'S', 'T', 'U', 'V', 'W', 'X', 'Y', 'Z', 'a', 'b', 'c', 'd', 'e', 'f', 'g', 'h', 'i', 'j', 'k', 'l', 'm', 'n', 'o', 'p', 'q', 'r', 's', 't', 'u', 'v', 'w', 'x', 'y', 'z', '0', '1', '2', '3', '4', '5', '6', '7', '8', '9', '+', '/'); begin for C in Data'Range loop E := Data (C); Last := Last + 1; case State is when 1 => Result (Last) := Base64 (Shift_Right (E, 2) and 16#3F#); State := 2; when 2 => Result (Last) := Base64 ((Shift_Left (Prev_E, 4) and 16#30#) or (Shift_Right (E, 4) and 16#F#)); State := 3; when 3 => Result (Last) := Base64 ((Shift_Left (Prev_E, 2) and 16#3C#) or (Shift_Right (E, 6) and 16#3#)); Last := Last + 1; Result (Last) := Base64 (E and 16#3F#); State := 1; end case; Prev_E := E; end loop; case State is when 1 => null; when 2 => Last := Last + 1; Result (Last) := Base64 (Shift_Left (Prev_E, 4) and 16#30#); when 3 => Last := Last + 1; Result (Last) := Base64 (Shift_Left (Prev_E, 2) and 16#3C#); end case; pragma Assert ((Result'Last - Last) < 3); Result (Last + 1 .. Result'Last) := (others => '='); return Result; end Base64_Encode; function Base64_Encode (Data : String) return String is Stream_Data : constant Stream_Element_Array := To_Stream_Element_Array (Data); begin return Base64_Encode (Stream_Data); end Base64_Encode; ------------ -- Binary -- ------------ package body Conversion is separate; --------------- -- QP_Decode -- --------------- function QP_Decode (QP_Data : String) return String is End_Of_QP : constant String := "00"; K : Positive := QP_Data'First; Result : String (1 .. QP_Data'Length); R : Natural := 0; begin loop if QP_Data (K) = '=' then if K + 1 <= QP_Data'Last and then QP_Data (K + 1) = ASCII.CR then K := K + 1; elsif K + 2 <= QP_Data'Last then declare Hex : constant String := QP_Data (K + 1 .. K + 2); begin if Hex /= End_Of_QP then R := R + 1; Result (R) := Character'Val (Utils.Hex_Value (Hex)); end if; K := K + 2; end; end if; else R := R + 1; Result (R) := QP_Data (K); end if; K := K + 1; exit when K > QP_Data'Last; end loop; return Result (1 .. R); end QP_Decode; ----------------------------- -- To_Stream_Element_Array -- ----------------------------- function To_Stream_Element_Array (Data : String) return Stream_Element_Array renames Conversion.To_Stream_Element_Array; --------------- -- To_String -- --------------- function To_String (Data : Stream_Element_Array) return String renames Conversion.To_String; ------------------------- -- To_Unbounded_String -- ------------------------- function To_Unbounded_String (Data : Ada.Streams.Stream_Element_Array) return Ada.Strings.Unbounded.Unbounded_String is use Ada.Strings.Unbounded; Chunk_Size : constant := 1_024; Result : Unbounded_String; K : Stream_Element_Offset := Data'First; begin while K <= Data'Last loop declare Last : constant Stream_Element_Offset := Stream_Element_Offset'Min (K + Chunk_Size, Data'Last); begin Append (Result, To_String (Data (K .. Last))); K := K + Chunk_Size + 1; end; end loop; return Result; end To_Unbounded_String; end AWS.Translator; polyorb-2.8~20110207.orig/src/aws_orig/aws-default.ads0000644000175000017500000001077611750740337021731 0ustar xavierxavier------------------------------------------------------------------------------ -- Ada Web Server -- -- -- -- Copyright (C) 2000-2003 -- -- ACT-Europe -- -- -- -- Authors: Dmitriy Anisimkov - Pascal Obry -- -- -- -- This library is free software; you can redistribute it and/or modify -- -- it under the terms of the GNU General Public License as published by -- -- the Free Software Foundation; either version 2 of the License, or (at -- -- your option) any later version. -- -- -- -- This library is distributed in the hope that it will be useful, but -- -- WITHOUT ANY WARRANTY; without even the implied warranty of -- -- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -- -- General Public License for more details. -- -- -- -- You should have received a copy of the GNU General Public License -- -- along with this library; if not, write to the Free Software Foundation, -- -- Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. -- -- -- ------------------------------------------------------------------------------ -- This package contains the default AWS configuration values. These values -- are used to initialize the configuration objects. Users should not modify -- the values here, see AWS.Config.* API. package AWS.Default is pragma Pure; Server_Name : constant String := "AWS Module"; WWW_Root : constant String := "./"; Admin_URI : constant String := ""; Server_Port : constant := 8080; Hotplug_Port : constant := 8888; Max_Connection : constant := 5; Accept_Queue_Size : constant := 64; Upload_Directory : constant String := "./"; -- Log values. The character '@' in the error log filename prefix is -- replaced by the running program name. Log_File_Directory : constant String := "./"; Log_Split_Mode : constant String := "NONE"; Log_Filename_Prefix : constant String := "@"; Error_Log_Split_Mode : constant String := "NONE"; Error_Log_Filename_Prefix : constant String := "@_error"; -- All times are in seconds One_Hour : constant := 3_600.0; One_Minute : constant := 60.0; Eight_Hours : constant := 8.0 * One_Hour; Three_Hours : constant := 3.0 * One_Hour; Five_Minutes : constant := 5.0 * One_Minute; Ten_Minutes : constant := 10.0 * One_Minute; Session_Cleanup_Interval : constant Duration := Five_Minutes; Session_Lifetime : constant Duration := Ten_Minutes; Cleaner_Wait_For_Client_Timeout : constant Duration := 80.0; Cleaner_Client_Header_Timeout : constant Duration := 20.0; Cleaner_Client_Data_Timeout : constant Duration := Eight_Hours; Cleaner_Server_Response_Timeout : constant Duration := Eight_Hours; Force_Wait_For_Client_Timeout : constant Duration := 2.0; Force_Client_Header_Timeout : constant Duration := 3.0; Force_Client_Data_Timeout : constant Duration := Three_Hours; Force_Server_Response_Timeout : constant Duration := Three_Hours; Send_Timeout : constant Duration := 40.0; Receive_Timeout : constant Duration := 30.0; Status_Page : constant String := "aws_status.thtml"; Up_Image : constant String := "aws_up.png"; Down_Image : constant String := "aws_down.png"; Logo_Image : constant String := "aws_logo.png"; Security : constant Boolean := False; Certificate : constant String := "cert.pem"; Session : constant Boolean := False; Case_Sensitive_Parameters : constant Boolean := True; Check_URL_Validity : constant Boolean := True; Line_Stack_Size : constant := 16#150_000#; end AWS.Default; polyorb-2.8~20110207.orig/src/aws_orig/aws-session-control.adb0000644000175000017500000000521011750740337023410 0ustar xavierxavier------------------------------------------------------------------------------ -- Ada Web Server -- -- -- -- Copyright (C) 2000-2001 -- -- ACT-Europe -- -- -- -- Authors: Dmitriy Anisimkov - Pascal Obry -- -- -- -- This library is free software; you can redistribute it and/or modify -- -- it under the terms of the GNU General Public License as published by -- -- the Free Software Foundation; either version 2 of the License, or (at -- -- your option) any later version. -- -- -- -- This library is distributed in the hope that it will be useful, but -- -- WITHOUT ANY WARRANTY; without even the implied warranty of -- -- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -- -- General Public License for more details. -- -- -- -- You should have received a copy of the GNU General Public License -- -- along with this library; if not, write to the Free Software Foundation, -- -- Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. -- -- -- ------------------------------------------------------------------------------ with Ada.Unchecked_Deallocation; package body AWS.Session.Control is -------------- -- Shutdown -- -------------- procedure Shutdown is procedure Free is new Ada.Unchecked_Deallocation (Cleaner, Cleaner_Access); Need_Release : Boolean; begin Cleaner_Control.Stop (Need_Release); if Need_Release then Cleaner_Task.Stop; -- Wait for task termination while not Cleaner_Task'Terminated loop delay 0.5; end loop; -- Release memory Free (Cleaner_Task); end if; end Shutdown; ----------- -- Start -- ----------- procedure Start (Session_Check_Interval : Duration; Session_Lifetime : Duration) is begin Cleaner_Control.Start (Session_Check_Interval, Session_Lifetime); end Start; end AWS.Session.Control; polyorb-2.8~20110207.orig/src/aws_orig/aws-hotplug-get_status.ads0000644000175000017500000000441511750740337024140 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- A W S . H O T P L U G . G E T _ S T A T U S -- -- -- -- S p e c -- -- -- -- Copyright (C) 2000-2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with Templates_Parser; function AWS.Hotplug.Get_Status (Filters : Filter_Set) return Templates_Parser.Translate_Table; -- Returns Server Hotplug status information. Data returned by this function -- will be displayed when in the administrative server page. polyorb-2.8~20110207.orig/src/aws_orig/aws-resources-files.adb0000644000175000017500000001212511750740337023364 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- A W S . R E S O U R C E S . F I L E S -- -- -- -- B o d y -- -- -- -- Copyright (C) 2002-2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- @@@ uses ada.calendar with AWS.OS_Lib; package body AWS.Resources.Files is ----------- -- Close -- ----------- procedure Close (Resource : in out File_Tagged) is begin Stream_IO.Close (Resource.File); end Close; ----------------- -- End_Of_File -- ----------------- function End_Of_File (Resource : File_Tagged) return Boolean is begin return Resource.Current > Resource.Last and then Stream_IO.End_Of_File (Resource.File); end End_Of_File; --------------- -- File_Size -- --------------- function File_Size (Name : String) return Ada.Streams.Stream_Element_Offset is begin return OS_Lib.File_Size (Name); exception when others => raise Resource_Error; end File_Size; -------------------- -- File_Timestamp -- -------------------- function File_Timestamp (Name : String) return Ada.Calendar.Time is begin return OS_Lib.File_Timestamp (Name); exception when others => raise Resource_Error; end File_Timestamp; --------------------- -- Is_Regular_File -- --------------------- function Is_Regular_File (Name : String) return Boolean is begin return OS_Lib.Is_Regular_File (Name); exception when others => raise Resource_Error; end Is_Regular_File; ---------- -- Open -- ---------- procedure Open (File : out File_Type; Name : String; Form : String := "") is begin File := new File_Tagged; Stream_IO.Open (File_Tagged (File.all).File, Stream_IO.In_File, Name, Form); File_Tagged (File.all).Stream := Stream_IO.Stream (File_Tagged (File.all).File); end Open; ---------- -- Read -- ---------- procedure Read (Resource : in out File_Tagged; Buffer : out Stream_Element_Array; Last : out Stream_Element_Offset) is use type Stream_Element_Offset; Buf_Len : constant Stream_Element_Offset := Resource.Last - Resource.Current + 1; begin if Buffer'Length <= Natural (Buf_Len) then -- Enough chars in the buffer, return them Buffer := Resource.Buffer (Resource.Current .. Resource.Current + Buffer'Length - 1); Resource.Current := Resource.Current + Buffer'Length; Last := Buffer'Last; else -- Return the current buffer Buffer (Buffer'First .. Buffer'First + Buf_Len - 1) := Resource.Buffer (Resource.Current .. Resource.Last); -- And read the remaining data directly on the file Read (Resource.Stream.all, Buffer (Buffer'First + Buf_Len .. Buffer'Last), Last); Resource.Current := Resource.Buffer'First; if Last < Buffer'Last then -- There is no more data, set the Resource object Resource.Last := 0; else -- Fill Resource buffer Read (Resource.Stream.all, Resource.Buffer, Resource.Last); end if; end if; end Read; end AWS.Resources.Files; polyorb-2.8~20110207.orig/src/aws_orig/aws-resources-streams.adb0000644000175000017500000000441311750740337023741 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- A W S . R E S O U R C E S . S T R E A M S -- -- -- -- B o d y -- -- -- -- Copyright (C) 2002-2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ package body AWS.Resources.Streams is ------------ -- Create -- ------------ procedure Create (File : out File_Type; Buffer : Stream_Access) is begin File := File_Type (Buffer); end Create; end AWS.Resources.Streams; polyorb-2.8~20110207.orig/src/aws_orig/aws-config-set.adb0000644000175000017500000003466111750740337022321 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- A W S . C O N F I G . S E T -- -- -- -- B o d y -- -- -- -- Copyright (C) 2000-2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with Ada.Exceptions; package body AWS.Config.Set is procedure Parameter (Param_Set : in out Parameter_Set; Name, Value : String; Error_Context : String); -- Set parameter Name/Value in Param_Set. Raises Constraint_Error with -- Error_Context added to error message if Name / Value is wrong. ----------------------- -- Accept_Queue_Size -- ----------------------- procedure Accept_Queue_Size (O : in out Object; Value : Positive) is begin O.P (Accept_Queue_Size).Pos_Value := Value; end Accept_Queue_Size; --------------- -- Admin_URI -- --------------- procedure Admin_URI (O : in out Object; Value : String) is begin O.P (Admin_URI).Str_Value := To_Unbounded_String (Value); end Admin_URI; ------------------------------- -- Case_Sensitive_Parameters -- ------------------------------- procedure Case_Sensitive_Parameters (O : in out Object; Value : Boolean) is begin O.P (Case_Sensitive_Parameters).Bool_Value := Value; end Case_Sensitive_Parameters; ----------------- -- Certificate -- ----------------- procedure Certificate (Filename : String) is begin Process_Options (Certificate).Str_Value := To_Unbounded_String (Filename); end Certificate; --------------------------------- -- Cleaner_Client_Data_Timeout -- --------------------------------- procedure Cleaner_Client_Data_Timeout (O : in out Object; Value : Duration) is begin O.P (Cleaner_Client_Data_Timeout).Dur_Value := Value; end Cleaner_Client_Data_Timeout; ----------------------------------- -- Cleaner_Client_Header_Timeout -- ----------------------------------- procedure Cleaner_Client_Header_Timeout (O : in out Object; Value : Duration) is begin O.P (Cleaner_Client_Header_Timeout).Dur_Value := Value; end Cleaner_Client_Header_Timeout; ------------------------------------- -- Cleaner_Server_Response_Timeout -- ------------------------------------- procedure Cleaner_Server_Response_Timeout (O : in out Object; Value : Duration) is begin O.P (Cleaner_Server_Response_Timeout).Dur_Value := Value; end Cleaner_Server_Response_Timeout; ------------------------------------- -- Cleaner_Wait_For_Client_Timeout -- ------------------------------------- procedure Cleaner_Wait_For_Client_Timeout (O : in out Object; Value : Duration) is begin O.P (Cleaner_Wait_For_Client_Timeout).Dur_Value := Value; end Cleaner_Wait_For_Client_Timeout; ---------------- -- Down_Image -- ---------------- procedure Down_Image (O : in out Object; Value : String) is begin O.P (Down_Image).Str_Value := To_Unbounded_String (Value); end Down_Image; ------------------------------- -- Error_Log_Filename_Prefix -- ------------------------------- procedure Error_Log_Filename_Prefix (O : in out Object; Value : String) is begin O.P (Error_Log_Filename_Prefix).Str_Value := To_Unbounded_String (Value); end Error_Log_Filename_Prefix; -------------------------- -- Error_Log_Split_Mode -- -------------------------- procedure Error_Log_Split_Mode (O : in out Object; Value : String) is begin O.P (Error_Log_Split_Mode).Str_Value := To_Unbounded_String (Value); end Error_Log_Split_Mode; ------------------------------- -- Force_Client_Data_Timeout -- ------------------------------- procedure Force_Client_Data_Timeout (O : in out Object; Value : Duration) is begin O.P (Force_Client_Data_Timeout).Dur_Value := Value; end Force_Client_Data_Timeout; --------------------------------- -- Force_Client_Header_Timeout -- --------------------------------- procedure Force_Client_Header_Timeout (O : in out Object; Value : Duration) is begin O.P (Force_Client_Header_Timeout).Dur_Value := Value; end Force_Client_Header_Timeout; ----------------------------------- -- Force_Server_Response_Timeout -- ----------------------------------- procedure Force_Server_Response_Timeout (O : in out Object; Value : Duration) is begin O.P (Force_Server_Response_Timeout).Dur_Value := Value; end Force_Server_Response_Timeout; ----------------------------------- -- Force_Wait_For_Client_Timeout -- ----------------------------------- procedure Force_Wait_For_Client_Timeout (O : in out Object; Value : Duration) is begin O.P (Force_Wait_For_Client_Timeout).Dur_Value := Value; end Force_Wait_For_Client_Timeout; ------------------ -- Hotplug_Port -- ------------------ procedure Hotplug_Port (O : in out Object; Value : Positive) is begin O.P (Hotplug_Port).Pos_Value := Value; end Hotplug_Port; --------------------- -- Line_Stack_Size -- --------------------- procedure Line_Stack_Size (O : in out Object; Value : Positive) is begin O.P (Line_Stack_Size).Pos_Value := Value; end Line_Stack_Size; ------------------------ -- Log_File_Directory -- ------------------------ procedure Log_File_Directory (O : in out Object; Value : String) is begin O.P (Log_File_Directory).Dir_Value := To_Unbounded_String (Value); end Log_File_Directory; ------------------------- -- Log_Filename_Prefix -- ------------------------- procedure Log_Filename_Prefix (O : in out Object; Value : String) is begin O.P (Log_Filename_Prefix).Str_Value := To_Unbounded_String (Value); end Log_Filename_Prefix; -------------------- -- Log_Split_Mode -- -------------------- procedure Log_Split_Mode (O : in out Object; Value : String) is begin O.P (Log_Split_Mode).Str_Value := To_Unbounded_String (Value); end Log_Split_Mode; ---------------- -- Logo_Image -- ---------------- procedure Logo_Image (O : in out Object; Value : String) is begin O.P (Logo_Image).Str_Value := To_Unbounded_String (Value); end Logo_Image; -------------------- -- Max_Connection -- -------------------- procedure Max_Connection (O : in out Object; Value : Positive) is begin O.P (Max_Connection).Pos_Value := Value; end Max_Connection; --------------- -- Parameter -- --------------- procedure Parameter (Config : in out Object; Name : String; Value : String; Error_Context : String := "") is begin Parameter (Config.P, Name, Value, Error_Context); end Parameter; procedure Parameter (Name : String; Value : String; Error_Context : String := "") is begin Parameter (Process_Options, Name, Value, Error_Context); end Parameter; procedure Parameter (Param_Set : in out Parameter_Set; Name, Value : String; Error_Context : String) is P : Parameter_Name; procedure Set_Parameter (Param : in out Values); -- Set parameter depending on the type (Param.Kind). procedure Error (Message : String); -- Raises Constraint_Error with associated message and Error_Context -- string. function "+" (S : String) return Unbounded_String renames To_Unbounded_String; ----------- -- Error -- ----------- procedure Error (Message : String) is begin Ada.Exceptions.Raise_Exception (Constraint_Error'Identity, Error_Context & ASCII.LF & Message & '.'); end Error; Expected_Type : Unbounded_String; ------------------- -- Set_Parameter -- ------------------- procedure Set_Parameter (Param : in out Values) is begin case Param.Kind is when Str => Expected_Type := +"string"; Param.Str_Value := +Value; when Dir => Expected_Type := +"string"; if Value (Value'Last) = '/' or else Value (Value'Last) = '\' then Param.Dir_Value := +Value; else Param.Dir_Value := +(Value & '/'); end if; when Pos => Expected_Type := +"positive"; Param.Pos_Value := Positive'Value (Value); when Dur => Expected_Type := +"duration"; Param.Dur_Value := Duration'Value (Value); when Bool => Expected_Type := +"boolean"; Param.Bool_Value := Boolean'Value (Value); end case; end Set_Parameter; begin begin P := Parameter_Name'Value (Name); exception when others => Error ("unrecognized option " & Name); return; end; if P not in Param_Set'Range then declare Not_Supported_Msg : constant String := " option '" & Name & "' not supported for this configuration context."; begin if P in Process_Parameter_Name'Range then Error ("Per process" & Not_Supported_Msg); else Error ("Per server" & Not_Supported_Msg); end if; end; return; else Set_Parameter (Param_Set (P)); end if; exception when others => Error ("wrong value for " & Name & " " & To_String (Expected_Type) & " expected"); end Parameter; --------------------- -- Receive_Timeout -- --------------------- procedure Receive_Timeout (O : in out Object; Value : Duration) is begin O.P (Receive_Timeout).Dur_Value := Value; end Receive_Timeout; -------------- -- Security -- -------------- procedure Security (O : in out Object; Value : Boolean) is begin O.P (Security).Bool_Value := Value; end Security; ------------------ -- Send_Timeout -- ------------------ procedure Send_Timeout (O : in out Object; Value : Duration) is begin O.P (Send_Timeout).Dur_Value := Value; end Send_Timeout; ----------------- -- Server_Host -- ----------------- procedure Server_Host (O : in out Object; Value : String) is begin O.P (Server_Host).Str_Value := To_Unbounded_String (Value); end Server_Host; ----------------- -- Server_Name -- ----------------- procedure Server_Name (O : in out Object; Value : String) is begin O.P (Server_Name).Str_Value := To_Unbounded_String (Value); end Server_Name; ----------------- -- Server_Port -- ----------------- procedure Server_Port (O : in out Object; Value : Positive) is begin O.P (Server_Port).Pos_Value := Value; end Server_Port; ------------- -- Session -- ------------- procedure Session (O : in out Object; Value : Boolean) is begin O.P (Session).Bool_Value := Value; end Session; ------------------------------ -- Session_Cleanup_Interval -- ------------------------------ procedure Session_Cleanup_Interval (Value : Duration) is begin Process_Options (Session_Cleanup_Interval).Dur_Value := Value; end Session_Cleanup_Interval; ---------------------- -- Session_Lifetime -- ---------------------- procedure Session_Lifetime (Value : Duration) is begin Process_Options (Session_Lifetime).Dur_Value := Value; end Session_Lifetime; ----------------- -- Status_Page -- ----------------- procedure Status_Page (O : in out Object; Value : String) is begin O.P (Status_Page).Str_Value := To_Unbounded_String (Value); end Status_Page; -------------- -- Up_Image -- -------------- procedure Up_Image (O : in out Object; Value : String) is begin O.P (Up_Image).Str_Value := To_Unbounded_String (Value); end Up_Image; ---------------------- -- Upload_Directory -- ---------------------- procedure Upload_Directory (O : in out Object; Value : String) is Last : constant Character := Value (Value'Last); begin if Last = '/' or else Last = '\' then O.P (Upload_Directory).Dir_Value := To_Unbounded_String (Value); else O.P (Upload_Directory).Dir_Value := To_Unbounded_String (Value & '/'); end if; end Upload_Directory; -------------- -- WWW_Root -- -------------- procedure WWW_Root (O : in out Object; Value : String) is begin O.P (WWW_Root).Dir_Value := To_Unbounded_String (Value); end WWW_Root; end AWS.Config.Set; polyorb-2.8~20110207.orig/src/aws_orig/aws-os_lib.ads0000644000175000017500000000560711750740337021551 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- A W S . O S _ L I B -- -- -- -- S p e c -- -- -- -- Copyright (C) 2000-2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- @@@ uses ada.calendar with Ada.Calendar; with Ada.Streams; package AWS.OS_Lib is No_Such_File : exception; function Is_Regular_File (Filename : String) return Boolean; pragma Inline (Is_Regular_File); -- Returns True if Filename is a regular file and is readable. function Is_Directory (Filename : String) return Boolean; pragma Inline (Is_Directory); -- Returns True if Filename is a directory. function File_Size (Filename : String) return Ada.Streams.Stream_Element_Offset; pragma Inline (File_Size); -- Returns Filename's size in bytes. function File_Timestamp (Filename : String) return Ada.Calendar.Time; pragma Inline (File_Timestamp); -- Get the time for last modification to a file in UTC/GMT. function GMT_Clock return Ada.Calendar.Time; pragma Inline (GMT_Clock); -- Returns current UTC/GMT time. end AWS.OS_Lib; polyorb-2.8~20110207.orig/src/aws_orig/table_of_dynamic_keys_and_static_values_g.ads0000644000175000017500000007473211750740337030107 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- TABLE_OF_DYNAMIC_KEYS_AND_STATIC_VALUES_G -- -- -- -- S p e c -- -- -- -- Copyright (C) 2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- TITLE: GENERIC PACKAGE FOR ASSOCIATIVE TABLES. -- REVISION: 13-JUL-1992 Ph. Kipfer (PKR), File header format -- APPROVAL: 03-DEC-1987 C. Genillard. -- CREATION: 29-JUN-1987 A. Strohmeier. generic type Key_Type is limited private; with function Less (Left, Right : Key_Type) return Boolean; -- Defines ordering of keys. with function Equals (Left, Right : Key_Type) return Boolean; -- Defines equality between keys. with procedure Assign (Destination : in out Key_Type; Source : Key_Type); -- Assigns SOURCE to DESTINATION. If needed, DESTINATION has to be -- destroyed -- before assignement, since ASSIGN is called without a previous call to -- DESTROY in the implementation of the package. with procedure Destroy (Key : in out Key_Type); type Value_Type is private; package Table_Of_Dynamic_Keys_And_Static_Values_G is -- OVERVIEW: -- This package provides associative tables of unlimited dynamic size with -- entries of type (KEY_TYPE, VALUE_TYPE), where KEY_TYPE and VALUE_TYPE -- are specified by generic parameters. Such a couple will also be called -- an item. -- The type TABLE_TYPE is implemented in such a way that every object has -- the implied initial value of an empty table. -- Two items (k1, v1) and (k2, v2) have same key if and only if -- EQUALS (k1, k2). -- A table may not contain duplicate items, that is having same key. -- The following consistency condition must be fullfilled by the -- relational operations LESS and EQUALS: -- (i) EQUALS (k1, k2) implies not LESS (k1, k2) and not LESS (k2, k1) -- (ii) not LESS (k1, k2) and not EQUALS (k1, k2) implies LESS (k2, k1). -- In our terminology, a static type is a type which is neither a limited -- type nor an access type. When an actual generic access type is -- associated with a generic static type, objects would be shared, i.e. -- only the access value would be stored, without copying the accessed -- object. -- On the opposite, a dynamic type may be limited or an access type. -- However a dynamic type must have the feature that every object has an -- implied initial value. -- Depending on the very nature of the types KEY_TYPE and VALUE_TYPE, one -- of the provided packages has to be used: -- TABLE_OF_DYNAMIC_KEYS_AND_DYNAMIC_VALUES_G -- TABLE_OF_STATIC_KEYS_AND_DYNAMIC_VALUES_G -- TABLE_OF_DYNAMIC_KEYS_AND_STATIC_VALUES_G -- TABLE_OF_STATIC_KEYS_AND_STATIC_VALUES_G -- -- CAUTION: -- Functions which return the value of an item (or part of it) of the -- structure share the item with the structure and do not return a copy of -- it. This may have consequences if the type of the item, (or some -- component of it) is an access type. For instance, when accessing an -- item by a function call, this item must not be destroyed or modified -- during the query. -- -- PRIMITIVES: -- CONSTRUCTORS: -- ASSIGN -- INSERT (2) -- INSERT_OR_REPLACE_VALUE -- REPLACE_VALUE (2) -- REMOVE (3) -- REMOVE_MIN (3) -- REMOVE_MAX (3) -- UPDATE_VALUE_OR_EXCEPTION_G -- UPDATE_VALUE_OR_STATUS_G -- QUERIES: -- SIZE -- IS_EMPTY -- IS_PRESENT -- VALUE -- GET_VALUE -- GET_MIN_ITEM -- GET_MAX_ITEM -- MIN_KEY -- GET_MIN_KEY -- MAX_KEY -- GET_MAX_KEY -- GET_LESS_ITEM -- GET_LESS_OR_EQUAL_ITEM -- GET_GREATER_ITEM -- GET_GREATER_OR_EQUAL_ITEM -- LESS_KEY -- GET_LESS_KEY (2) -- LESS_OR_EQUAL_KEY -- GET_LESS_OR_EQUAL_KEY (2) -- GREATER_KEY -- GET_GREATER_KEY (2) -- GREATER_OR_EQUAL_KEY -- GET_GREATER_OR_EQUAL_KEY (2) -- SET_OPERATIONS: -- SET_OPERATIONS_G -- UNION -- INTERSECTION -- DIFFERENCE -- SYMMETRIC_DIFFERENCE -- "=" (set equality) -- "<" (strict set inclusion) -- "<=" (set inclusion) -- ">" (strict set inclusion) -- ">=" (set inclusion) -- ITERATORS: -- TRAVERSE_ASC_G -- TRAVERSE_DESC_G -- TRAVERSE_ASC_AND_UPDATE_VALUE_G -- TRAVERSE_DESC_AND_UPDATE_VALUE_G -- DISORDER_TRAVERSE_G -- DISORDER_TRAVERSE_AND_UPDATE_VALUE_G -- HEAP MANAGEMENT: -- DESTROY -- RELEASE_FREE_LIST -- SET_MAX_FREE_LIST_SIZE -- FREE_LIST_SIZE -- -- ALGORITHM: -- A table is implemented as a balanced search binary tree (AVL-tree) -- using pointers. The items are sorted in the table by increasing keys -- values in conformance to inorder. -- An internal free list is used to avoid returning each free item (i.e. -- coming from REMOVE) to the system, so long as the length of this list -- does not exceed MAX_FREE_LIST_SIZE, in which case the free item is -- immediately returned to the system. When a new item has to be inserted -- (i.e. by a call to INSERT), an element is recovered from the free list -- if it is not empty. Otherwise, new space is taken from the system. type Table_Type is limited private; Duplicate_Item_Error, Missing_Item_Error, Empty_Structure_Error : exception; -- CONSTRUCTORS: procedure Assign (Destination : in out Table_Type; Source : Table_Type); -- OVERVIEW: -- Begins by a call to DESTROY (DESTINATION) and then copies SOURCE into -- DESTINATION. Note the "in out" mode of the formal parameter DESTINATION. procedure Insert (Table : in out Table_Type; Key : Key_Type; Value : Value_Type); -- OVERVIEW: -- Inserts the couple (KEY, VALUE) into TABLE. -- ERROR: -- If an entry with the given key is already in the table, then exception -- DUPLICATE_ITEM_ERROR is raised. procedure Insert (Table : in out Table_Type; Key : Key_Type; Value : Value_Type; Duplicate_Item : out Boolean); -- OVERVIEW: -- Inserts the couple (KEY, VALUE) into TABLE. No action is taken and no -- error occurs if an entry with the given key is already in the table -- except that DUPLICATE_ITEM is set to true. procedure Insert_Or_Replace_Value (Table : in out Table_Type; Key : Key_Type; Value : Value_Type); -- OVERVIEW: -- Inserts the couple (KEY, VALUE) into TABLE if there is no entry with -- this key. Otherwise the given VALUE replaces the previous one. procedure Replace_Value (Table : in out Table_Type; Key : Key_Type; Value : Value_Type); -- OVERVIEW: -- An entry having key KEY is searched for in TABLE. The given VALUE then -- replaces the previous one. -- ERROR: -- If there is no entry with the given key, the exception -- MISSING_ITEM_ERROR is raised. procedure Replace_Value (Table : in out Table_Type; Key : Key_Type; Value : Value_Type; Found : out Boolean); -- OVERVIEW: -- An entry having key KEY is searched for in TABLE. The given -- VALUE then replaces the previous one. No action is taken and no error -- occurs if there is no entry with the given key, except that FOUND -- is set to false. procedure Remove (Table : in out Table_Type; Key : Key_Type); procedure Remove (Table : in out Table_Type; Key : Key_Type; Value : out Value_Type); -- OVERVIEW: -- Removes the entry with key KEY from TABLE and returns in -- parameter VALUE, if present, the associated VALUE. -- ERROR: -- If there is no entry with the given key, the exception -- MISSING_ITEM_ERROR is raised. In this case the value of the actual -- parameter VALUE is left unchanged. procedure Remove (Table : in out Table_Type; Key : Key_Type; Found : out Boolean); -- OVERVIEW: -- Removes the entry with key KEY from TABLE. No action is taken -- and no error occurs if there is no entry with the given key, except -- that FOUND is set to false. procedure Remove_Min (Table : in out Table_Type); procedure Remove_Min (Table : in out Table_Type; Key : in out Key_Type); procedure Remove_Min (Table : in out Table_Type; Key : in out Key_Type; Value : out Value_Type); -- OVERVIEW: -- Removes the entry with the smallest key from TABLE and returns, -- if needed, the values of KEY and VALUE. -- ERROR: -- Raises EMPTY_STRUCTURE_ERROR if TABLE is empty. In this case the -- values of the actual parameters KEY and VALUE are left unchanged. procedure Remove_Max (Table : in out Table_Type); procedure Remove_Max (Table : in out Table_Type; Key : in out Key_Type); procedure Remove_Max (Table : in out Table_Type; Key : in out Key_Type; Value : out Value_Type); -- OVERVIEW: -- Removes the entry with the greatest key from TABLE and returns, -- if needed, the values of KEY and VALUE. -- ERROR: -- Raises EMPTY_STRUCTURE_ERROR if TABLE is empty. In this case the -- values of the actual parameters KEY and VALUE are left unchanged. generic with procedure Modify (Key : Key_Type; Value : in out Value_Type) is <>; procedure Update_Value_Or_Exception_G (Table : in out Table_Type; Key : Key_Type); -- OVERVIEW: -- An entry with key KEY is searched for in TABLE. The associated item -- is then passed to procedure MODIFY for modification of its value part. -- ERROR: -- Raises MISSING_ITEM_ERROR if KEY is not in TABLE. generic with procedure Modify (Key : Key_Type; Value : in out Value_Type) is <>; procedure Update_Value_Or_Status_G (Table : in out Table_Type; Key : Key_Type; Found : out Boolean); -- OVERVIEW: -- An entry with key KEY is searched for in TABLE. The associated item -- is then passed to procedure MODIFY for modification of its value part. -- No action is taken and no error occurs if there is no entry with the -- given key, except that FOUND is set to false. -- QUERIES: function Size (Table : Table_Type) return Natural; -- OVERVIEW: -- Returns the number of entries currently in TABLE. function Is_Empty (Table : Table_Type) return Boolean; -- OVERVIEW: -- Returns TRUE if and only if the TABLE is empty. function Is_Present (Table : Table_Type; Key : Key_Type) return Boolean; -- OVERVIEW: -- Returns TRUE if and only if an ITEM with key KEY is in TABLE. function Value (Table : Table_Type; Key : Key_Type) return Value_Type; procedure Get_Value (Table : Table_Type; Key : Key_Type; Value : out Value_Type); -- OVERVIEW: -- Gives the VALUE associated with KEY in TABLE. -- ERROR: -- Raises MISSING_ITEM_ERROR if KEY is not found in TABLE. In this case -- the value of the actual parameter VALUE is left unchanged. procedure Get_Min_Item (Table : Table_Type; Key : in out Key_Type; Value : out Value_Type); -- OVERVIEW: -- Gives the smallest KEY and the VALUE associated with it in TABLE. -- ERROR: -- Raises EMPTY_STRUCTURE_ERROR if TABLE is empty. In this case the values -- of the actual parameters KEY and VALUE are left unchanged. procedure Get_Max_Item (Table : Table_Type; Key : in out Key_Type; Value : out Value_Type); -- OVERVIEW: -- Gives the biggest KEY and the VALUE associated with it in TABLE. -- ERROR: -- Raises EMPTY_STRUCTURE_ERROR if TABLE is empty. In this case the values -- of the actual parameters KEY and VALUE are left unchanged. function Min_Key (Table : Table_Type) return Key_Type; procedure Get_Min_Key (Table : Table_Type; Key : in out Key_Type); -- OVERVIEW: -- Gives the smallest KEY of TABLE. -- ERROR: -- Raises EMPTY_STRUCTURE_ERROR if TABLE is empty. In this case the value -- of the actual parameter KEY is left unchanged. function Max_Key (Table : Table_Type) return Key_Type; procedure Get_Max_Key (Table : Table_Type; Key : in out Key_Type); -- OVERVIEW: -- Gives the biggest KEY of TABLE. -- ERROR: -- Raises EMPTY_STRUCTURE_ERROR if TABLE is empty. In this case the value -- of the actual parameter KEY is left unchanged. procedure Get_Less_Item (Table : Table_Type; Key : in out Key_Type; Value : out Value_Type); -- OVERVIEW: -- Returns the entry having the greatest key less than the value of -- the actual parameter KEY. KEY is modified in accordance. -- ERROR: -- The exception MISSING_ITEM_ERROR is raised if there is not such an -- entry in the table. In this case the values of the actual parameters KEY -- and VALUE are left unchanged. procedure Get_Less_Or_Equal_Item (Table : Table_Type; Key : in out Key_Type; Value : out Value_Type); -- OVERVIEW: -- Returns the entry having the greatest key less than or equal to -- the value of the actual parameter KEY. KEY is modified in accordance. -- ERROR: -- The exception MISSING_ITEM_ERROR is raised if there is not such an -- entry in the table. In this case the values of the actual parameters KEY -- and VALUE are left unchanged. procedure Get_Greater_Item (Table : Table_Type; Key : in out Key_Type; Value : out Value_Type); -- OVERVIEW: -- Returns the entry having the smallest key greater than the value -- of the actual parameter KEY. KEY is modified in accordance. -- ERROR: -- The exception MISSING_ITEM_ERROR is raised if there is not such an -- entry in the table. In this case the values of the actual parameters KEY -- and VALUE are left unchanged. procedure Get_Greater_Or_Equal_Item (Table : Table_Type; Key : in out Key_Type; Value : out Value_Type); -- OVERVIEW: -- Returns the entry having the smallest key greater than or equal -- to the value of the actual parameter KEY. KEY is modified in accordance. -- ERROR: -- The exception MISSING_ITEM_ERROR is raised if there is not such an -- entry in the table. In this case the values of the actual parameters KEY -- and VALUE are left unchanged. function Less_Key (Table : Table_Type; Key : Key_Type) return Key_Type; procedure Get_Less_Key (Table : Table_Type; Key : in out Key_Type); -- OVERVIEW: -- Gives the greatest key less than the value of the parameter KEY. -- ERROR: -- The exception MISSING_ITEM_ERROR is raised if there is not such an -- entry in the table. In this case the value of the actual parameter KEY -- is left unchanged. procedure Get_Less_Key (Table : Table_Type; Key : in out Key_Type; Found : out Boolean); -- OVERVIEW: -- Returns the greatest key less than the value of the actual -- parameter KEY. KEY is modified in accordance. FOUND is set to TRUE or -- FALSE depending on success of search. The value of the actual parameter -- KEY is left unchanged if FOUND is set to FALSE. function Less_Or_Equal_Key (Table : Table_Type; Key : Key_Type) return Key_Type; procedure Get_Less_Or_Equal_Key (Table : Table_Type; Key : in out Key_Type); -- OVERVIEW: -- Gives the greatest key less than or equal to the value of the -- parameter KEY. -- ERROR: -- The exception MISSING_ITEM_ERROR is raised if there is not such an -- entry in the table. In this case the value of the actual parameter KEY -- is left unchanged. procedure Get_Less_Or_Equal_Key (Table : Table_Type; Key : in out Key_Type; Found : out Boolean); -- OVERVIEW: -- Returns the greatest key less than or equal to the value of the -- actual parameter KEY. KEY is modified in accordance. FOUND is set to -- TRUE or FALSE depending on success of search. The value of the actual -- parameter KEY is left unchanged if FOUND is set to FALSE. function Greater_Key (Table : Table_Type; Key : Key_Type) return Key_Type; procedure Get_Greater_Key (Table : Table_Type; Key : in out Key_Type); -- OVERVIEW: -- Gives the smallest key greater than the value of the parameter -- KEY. -- ERROR: -- The exception MISSING_ITEM_ERROR is raised if there is not such an -- entry in the table. In this case the value of the actual parameter KEY -- is left unchanged. procedure Get_Greater_Key (Table : Table_Type; Key : in out Key_Type; Found : out Boolean); -- OVERVIEW: -- Returns the smallest key greater than the value of the actual -- parameter KEY. KEY is modified in accordance. FOUND is set to TRUE or -- FALSE depending on success of search. The value of the actual parameter -- KEY is left unchanged if FOUND is set to FALSE. function Greater_Or_Equal_Key (Table : Table_Type; Key : Key_Type) return Key_Type; procedure Get_Greater_Or_Equal_Key (Table : Table_Type; Key : in out Key_Type); -- OVERVIEW: -- Returns the smallest key greater than or equal to the value of -- the parameter KEY. -- ERROR: -- The exception MISSING_ITEM_ERROR is raised if there is not such an -- entry in the table. In this case the value of the actual parameter KEY -- is left unchanged. procedure Get_Greater_Or_Equal_Key (Table : Table_Type; Key : in out Key_Type; Found : out Boolean); -- OVERVIEW: -- Returns the smallest key greater than or equal to the value of -- the actual parameter KEY. KEY is modified in accordance. FOUND is set -- to TRUE or FALSE depending on success of search. The value of the actual -- parameter KEY is left unchanged if FOUND is set to FALSE. -- SET_OPERATIONS: generic package Set_Operations_G is procedure Union (Destination : in out Table_Type; Left, Right : Table_Type); -- OVERVIEW: -- Union of LEFT and RIGHT. If a key is both in LEFT and RIGHT, the -- value is taken from LEFT. procedure Intersection (Destination : in out Table_Type; Left, Right : Table_Type); -- OVERVIEW: -- Intersection of LEFT and RIGHT. The items are taken from LEFT. procedure Difference (Destination : in out Table_Type; Left, Right : Table_Type); -- OVERVIEW: -- Set difference of LEFT and RIGHT. An item is in the resulting table -- if it is in LEFT and if there is no item with same key in RIGHT. procedure Symmetric_Difference (Destination : in out Table_Type; Left, Right : Table_Type); -- OVERVIEW: -- Symmetric set difference of LEFT and RIGHT. An item is in the -- resulting table if it is in LEFT but there is no item with same key -- in RIGHT or if it is in RIGHT but there is no item with same key in -- LEFT. function "=" (Left, Right : Table_Type) return Boolean; -- OVERVIEW: -- Set equality; the LEFT and RIGHT tables contain entries with same -- keys. function "<" (Left, Right : Table_Type) return Boolean; -- OVERVIEW: -- Strict set inclusion; to each item in the LEFT table an item with -- same key is associated in the RIGHT table, but the two sets are not -- identical. function "<=" (Left, Right : Table_Type) return Boolean; -- OVERVIEW: -- Set inclusion; to each entry in the LEFT table an entry with same -- key is associated in the RIGHT table. function ">" (Left, Right : Table_Type) return Boolean; -- OVERVIEW: -- Strict set inclusion; to each entry in the RIGHT table an entry with -- same key is associated in the LEFT table, but the two sets are not -- identical. function ">=" (Left, Right : Table_Type) return Boolean; -- OVERVIEW: -- Set inclusion; to each entry in the RIGHT table an entry with same -- key is associated in the LEFT table. end Set_Operations_G; -- ITERATORS: generic with procedure Action (Key : Key_Type; Value : Value_Type; Order_Number : Positive; Continue : in out Boolean) is <>; procedure Traverse_Asc_G (Table : Table_Type); -- OVERVIEW: -- The entries in TABLE are visited in ascending order of their key -- values. Procedure ACTION is applied on each entry within TABLE. -- ORDER_NUMBER gives the position of the visited entry in order of -- traversal. The boolean CONTINUE specifies if you want to proceed to the -- next entry or if you want to stop traversing. As long as you do not -- modify its value within ACTION, its value remains TRUE. -- REQUIREMENT: -- For your actual procedure ACTION, you must not use a procedure -- which modifies the traversed table. generic with procedure Action (Key : Key_Type; Value : Value_Type; Order_Number : Positive; Continue : in out Boolean) is <>; procedure Traverse_Desc_G (Table : Table_Type); -- OVERVIEW: -- The entries in TABLE are visited in descending order of their key -- values. Procedure ACTION is applied on each entry within TABLE. -- ORDER_NUMBER gives the position of the visited entry in order of -- traversal. The boolean CONTINUE specifies if you want to proceed to the -- next entry or if you want to stop traversing. As long as you do not -- modify its value within ACTION, its value remains TRUE. -- REQUIREMENT: -- For your actual procedure ACTION, you must not use a procedure -- which modifies the traversed table. generic with procedure Modify (Key : Key_Type; Value : in out Value_Type; Order_Number : Positive; Continue : in out Boolean) is <>; procedure Traverse_Asc_And_Update_Value_G (Table : in out Table_Type); -- OVERVIEW: -- The entries in TABLE are visited in ascending order of their key -- values. For each visited entry, procedure MODIFY is called. The value of -- the current entry is then replaced by the new value. -- ORDER_NUMBER gives the position of the visited entry in order of -- traversal. The boolean CONTINUE specifies if you want to proceed to the -- next entry or if you want to stop traversing. As long as you do not -- modify its value within MODIFY, its value remains TRUE. -- REQUIREMENT: -- For your actual procedure MODIFY, you must not use a procedure which -- modifies the traversed table. generic with procedure Modify (Key : Key_Type; Value : in out Value_Type; Order_Number : Positive; Continue : in out Boolean) is <>; procedure Traverse_Desc_And_Update_Value_G (Table : in out Table_Type); -- OVERVIEW: -- The entries in TABLE are visited in descending order of their key -- values. For each visited entry, procedure MODIFY is called. The item -- value of the current entry is then replaced by the new value. -- ORDER_NUMBER gives the position of the visited entry in order of -- traversal. The boolean CONTINUE specifies if you want to proceed to the -- next entry or if you want to stop traversing. As long as you do not -- modify its value within MODIFY, its value remains TRUE. -- REQUIREMENT: -- For your actual procedure MODIFY, you must not use a procedure which -- modifies the traversed table. generic with procedure Action (Key : Key_Type; Value : Value_Type; Order_Number : Positive; Continue : in out Boolean) is <>; procedure Disorder_Traverse_G (Table : Table_Type); -- OVERVIEW: -- The entries in TABLE are visited in disorder of their key values. -- procedure ACTION is applied on each entry within TABLE. -- ORDER_NUMBER gives the position of the visited entry in order of -- traversal. The boolean CONTINUE specifies if you want to proceed to the -- next entry or if you want to stop traversing. As long as you do not -- modify its value within ACTION, its value remains TRUE. -- Traversal by DISORDER_TRAVERSE_G is faster than by TRAVERSE_ASC_G or -- TRAVERSE_DESC_G. Moreover, use of the generic procedure -- DISORDER_TRAVERSE_G is recommended for saving a table in a backstore -- (file or linear list) because recovery will be efficient. -- REQUIREMENT: -- For your actual procedure ACTION, you must not use a procedure -- which modifies the traversed table. generic with procedure Modify (Key : Key_Type; Value : in out Value_Type; Order_Number : Positive; Continue : in out Boolean) is <>; procedure Disorder_Traverse_And_Update_Value_G (Table : in out Table_Type); -- OVERVIEW: -- The entries in TABLE are visited in disorder of their key values. -- procedure MODIFY is applied on each entry within TABLE. The item -- value of the current entry is then replaced by the new value. -- ORDER_NUMBER gives the position of the visited entry in order of -- traversal. The boolean CONTINUE specifies if you want to proceed to the -- next entry or if you want to stop traversing. As long as you do not -- modify its value within MODIFY, its value remains TRUE. -- Traversal by DISORDER_TRAVERSE_G is faster than by TRAVERSE_ASC_G or -- TRAVERSE_DESC_G. -- REQUIREMENT: -- For your actual procedure MODIFY, you must not use a procedure -- which modifies the traversed table. -- HEAP MANAGEMENT: procedure Destroy (Table : in out Table_Type); -- OVERVIEW: -- Empties the TABLE and returns space to the free list. procedure Release_Free_List; -- OVERVIEW: -- Releases all items from the free list giving their space back to the -- system. procedure Set_Max_Free_List_Size (Max_Free_List_Size : Natural); -- OVERVIEW: -- Sets the maximum length of the internal free list which is 0 by -- default. -- If parameter MAX_FREE_LIST_SIZE is smaller than the current size -- of the list, the items in excess are returned to the system. function Free_List_Size return Natural; -- OVERVIEW: -- Returns the actual length of the internal free list. private type Equilibrium_Type is range -1 .. 1; type Cell_Type; type Link_Type is access Cell_Type; type Cell_Type is record Balance : Equilibrium_Type := 0; -- always equal to HEIGHT(RIGHT)-HEIGHT(LEFT) Left : Link_Type; Right : Link_Type; -- Is also used for linking within the free list Key : Key_Type; Value : Value_Type; end record; type Table_Type is record Root : Link_Type; Count : Natural := 0; Connect_Predecessor : Boolean := True; -- Used to connect alternatively the predecessor or successor when -- deleting a node. Is provided for optimization. end record; end Table_Of_Dynamic_Keys_And_Static_Values_G; polyorb-2.8~20110207.orig/src/aws_orig/aws-resources-files.ads0000644000175000017500000000623111750740337023406 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- A W S . R E S O U R C E S . F I L E S -- -- -- -- S p e c -- -- -- -- Copyright (C) 2002-2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- @@@ uses ada.calendar with Ada.Streams.Stream_IO; package AWS.Resources.Files is procedure Open (File : out File_Type; Name : String; Form : String := ""); function Is_Regular_File (Name : String) return Boolean; function File_Size (Name : String) return Ada.Streams.Stream_Element_Offset; function File_Timestamp (Name : String) return Ada.Calendar.Time; private type Stream_File_Access is access Stream_IO.File_Type; Buffer_Size : constant := 8_192; type File_Tagged is new Resources.File_Tagged with record File : Stream_IO.File_Type; Stream : Stream_IO.Stream_Access; -- below are data for buffered access to the file. Buffer : Stream_Element_Array (1 .. Buffer_Size); Current : Stream_Element_Offset := 1; Last : Stream_Element_Offset := 0; end record; function End_Of_File (Resource : File_Tagged) return Boolean; procedure Read (Resource : in out File_Tagged; Buffer : out Stream_Element_Array; Last : out Stream_Element_Offset); procedure Close (Resource : in out File_Tagged); end AWS.Resources.Files; polyorb-2.8~20110207.orig/src/aws_orig/table_of_dynamic_keys_and_static_values_g.adb0000644000175000017500000017463311750740337030067 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- TABLE_OF_DYNAMIC_KEYS_AND_STATIC_VALUES_G -- -- -- -- B o d y -- -- -- -- Copyright (C) 2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- TITLE: GENERIC PACKAGE FOR ASSOCIATIVE TABLES. -- REVISION: 13-JUL-1992 Ph. Kipfer (PKR), File header format -- APPROVAL: 03-DEC-1987 C. Genillard. -- CREATION: 29-JUN-1987 A. Strohmeier. with Unchecked_Deallocation; package body Table_Of_Dynamic_Keys_And_Static_Values_G is -- LOCAL SUBPROGRAM: procedure Assign_Item (Destination : out Value_Type; Source : Value_Type); procedure Assign (Destination : out Value_Type; Source : Value_Type) renames Assign_Item; -- LOCAL SUBPROGRAM: procedure Destroy_Item (Item : Value_Type); procedure Destroy (Item : Value_Type) renames Destroy_Item; type Link_List_Type is array (Positive range <>) of Link_Type; Max_Free_List_Size : Natural := 0; type Free_List_Type is record Ptr : Link_Type; Count : Natural := 0; end record; -- STATE VARIABLE: Free_List : Free_List_Type; -- LOCAL SUBPROGRAM: procedure Create_And_Assign_Cell (Link : in out Link_Type; Key : Key_Type; Value : Value_Type); procedure Create_And_Assign_Cell (Link : in out Link_Type; Key : Key_Type; Value : Value_Type) is -- LINK has in (out) mode for allowing access to LINK.VALUE. begin if Free_List.Count = 0 then Link := new Cell_Type; else Link := Free_List.Ptr; Free_List.Ptr := Free_List.Ptr.Right; Free_List.Count := Free_List.Count - 1; Link.Balance := 0; Link.Left := null; Link.Right := null; end if; Assign (Link.Key, Key); Assign (Link.Value, Value); end Create_And_Assign_Cell; pragma Inline (Create_And_Assign_Cell); -- LOCAL SUBPROGRAM: procedure Dispose is new Unchecked_Deallocation (Object => Cell_Type, Name => Link_Type); pragma Inline (Dispose); -- LOCAL SUBPROGRAM: procedure Release (Link : in out Link_Type); procedure Release (Link : in out Link_Type) is -- Collect in the free list, or release to system. begin Destroy (Link.Key); Destroy (Link.Value); if Free_List.Count < Max_Free_List_Size then Link.Right := Free_List.Ptr; Free_List.Ptr := Link; Free_List.Count := Free_List.Count + 1; else Dispose (Link); end if; end Release; pragma Inline (Release); -- LOCAL SUBPROGRAM: function Search_A_Key (Root : Link_Type; Key : Key_Type) return Link_Type; function Search_A_Key (Root : Link_Type; Key : Key_Type) return Link_Type is -- Result points to the cell with key value searched for; when search -- fails, null value is returned. Ptr : Link_Type := Root; begin -- SEARCH_A_KEY while Ptr /= null loop if Less (Ptr.Key, Key) then Ptr := Ptr.Right; elsif Equals (Ptr.Key, Key) then return Ptr; else Ptr := Ptr.Left; end if; end loop; return null; end Search_A_Key; pragma Inline (Search_A_Key); -- LOCAL SUBPROGRAM: function Search_Min (Root : Link_Type) return Link_Type; function Search_Min (Root : Link_Type) return Link_Type is -- Result points to the first (smallest) cell in the table. Ptr : Link_Type := Root; begin if Ptr = null then return null; end if; while Ptr.Left /= null loop Ptr := Ptr.Left; end loop; return Ptr; end Search_Min; pragma Inline (Search_Min); -- LOCAL SUBPROGRAM: function Search_Max (Root : Link_Type) return Link_Type; function Search_Max (Root : Link_Type) return Link_Type is -- Result points to the last (greatest) cell in the table. Ptr : Link_Type := Root; begin if Ptr = null then return null; end if; while Ptr.Right /= null loop Ptr := Ptr.Right; end loop; return Ptr; end Search_Max; pragma Inline (Search_Max); -- CONSTRUCTORS: procedure Assign (Destination : in out Table_Type; Source : Table_Type) is procedure Copy_Subtree (Destination : in out Link_Type; Source : Link_Type); procedure Copy_Subtree (Destination : in out Link_Type; Source : Link_Type) is begin if Source /= null then Create_And_Assign_Cell (Destination, Source.Key, Source.Value); Destination.Balance := Source.Balance; Copy_Subtree (Destination.Left, Source.Left); Copy_Subtree (Destination.Right, Source.Right); else Destination := null; end if; end Copy_Subtree; begin -- ASSIGN if Source.Root = Destination.Root then return; end if; -- Actual parameters are identical tables. Destroy (Destination); if Source.Count = 0 then return; end if; -- SOURCE is a null table. Copy_Subtree (Destination.Root, Source.Root); Destination.Count := Source.Count; end Assign; procedure Insert (Table : in out Table_Type; Key : Key_Type; Value : Value_Type) is Duplicate_Item : Boolean; begin -- INSERT Insert (Table, Key, Value, Duplicate_Item); if Duplicate_Item then raise Duplicate_Item_Error; end if; end Insert; procedure Insert (Table : in out Table_Type; Key : Key_Type; Value : Value_Type; Duplicate_Item : out Boolean) is Depth_Increased : Boolean := False; procedure Insert_Node (Key : Key_Type; Value : Value_Type; Subtree : in out Link_Type; Depth_Increased : in out Boolean); procedure Insert_Node (Key : Key_Type; Value : Value_Type; Subtree : in out Link_Type; Depth_Increased : in out Boolean) is procedure Check_And_Balance_Left (Root : in out Link_Type; Depth_Increased : in out Boolean); procedure Check_And_Balance_Left (Root : in out Link_Type; Depth_Increased : in out Boolean) is begin -- CHECK_AND_BALANCE_LEFT case Root.Balance is when 1 => Root.Balance := 0; Depth_Increased := False; when 0 => Root.Balance := -1; when -1 => -- rebalance declare Left_Son : constant Link_Type := Root.Left; begin if Left_Son.Balance = -1 then -- single LL rotation Root.Left := Left_Son.Right; Left_Son.Right := Root; Root.Balance := 0; Root := Left_Son; else -- double LR rotation declare Left_Right_Son : constant Link_Type := Left_Son.Right; begin Left_Son.Right := Left_Right_Son.Left; Left_Right_Son.Left := Left_Son; Root.Left := Left_Right_Son.Right; Left_Right_Son.Right := Root; if Left_Right_Son.Balance = -1 then Root.Balance := 1; else Root.Balance := 0; end if; if Left_Right_Son.Balance = 1 then Left_Son.Balance := -1; else Left_Son.Balance := 0; end if; Root := Left_Right_Son; end; end if; Root.Balance := 0; Depth_Increased := False; end; end case; end Check_And_Balance_Left; procedure Check_And_Balance_Right (Root : in out Link_Type; Depth_Increased : in out Boolean); procedure Check_And_Balance_Right (Root : in out Link_Type; Depth_Increased : in out Boolean) is begin -- CHECK_AND_BALANCE_RIGHT case Root.Balance is when -1 => Root.Balance := 0; Depth_Increased := False; when 0 => Root.Balance := 1; when 1 => -- rebalance declare Right_Son : constant Link_Type := Root.Right; begin if Right_Son.Balance = 1 then -- single RR rotation Root.Right := Right_Son.Left; Right_Son.Left := Root; Root.Balance := 0; Root := Right_Son; else -- double RL rotation declare Right_Left_Son : constant Link_Type := Right_Son.Left; begin Right_Son.Left := Right_Left_Son.Right; Right_Left_Son.Right := Right_Son; Root.Right := Right_Left_Son.Left; Right_Left_Son.Left := Root; if Right_Left_Son.Balance = 1 then Root.Balance := -1; else Root.Balance := 0; end if; if Right_Left_Son.Balance = -1 then Right_Son.Balance := +1; else Right_Son.Balance := 0; end if; Root := Right_Left_Son; end; end if; Root.Balance := 0; Depth_Increased := False; end; end case; end Check_And_Balance_Right; begin -- INSERT_NODE if Subtree = null then Create_And_Assign_Cell (Subtree, Key, Value); Table.Count := Table.Count + 1; Depth_Increased := True; Duplicate_Item := False; else if Less (Key, Subtree.Key) then -- insert into left subtable Insert_Node (Key, Value, Subtree.Left, Depth_Increased); if Depth_Increased then Check_And_Balance_Left (Subtree, Depth_Increased); end if; elsif Equals (Key, Subtree.Key) then Depth_Increased := False; Duplicate_Item := True; else -- insert into right subtable Insert_Node (Key, Value, Subtree.Right, Depth_Increased); if Depth_Increased then Check_And_Balance_Right (Subtree, Depth_Increased); end if; end if; end if; end Insert_Node; begin -- INSERT Insert_Node (Key, Value, Table.Root, Depth_Increased); end Insert; procedure Insert_Or_Replace_Value (Table : in out Table_Type; Key : Key_Type; Value : Value_Type) is Ptr : constant Link_Type := Search_A_Key (Table.Root, Key); Junk : Boolean; begin if Ptr /= null then Assign (Ptr.Value, Value); else Insert (Table, Key, Value, Junk); end if; end Insert_Or_Replace_Value; procedure Replace_Value (Table : in out Table_Type; Key : Key_Type; Value : Value_Type; Found : out Boolean) is Ptr : constant Link_Type := Search_A_Key (Table.Root, Key); begin if Ptr /= null then Assign (Ptr.Value, Value); Found := True; else Found := False; end if; end Replace_Value; procedure Replace_Value (Table : in out Table_Type; Key : Key_Type; Value : Value_Type) is Ptr : constant Link_Type := Search_A_Key (Table.Root, Key); begin if Ptr /= null then Assign (Ptr.Value, Value); else raise Missing_Item_Error; end if; end Replace_Value; -- LOCAL SUBPROGRAM: -- Primitives for balancing used by procedures that delete cells procedure Balance_Left (Root : in out Link_Type; Depth_Reduced : in out Boolean); procedure Balance_Left (Root : in out Link_Type; Depth_Reduced : in out Boolean) is begin -- BALANCE_LEFT case Root.Balance is when -1 => Root.Balance := 0; when 0 => Root.Balance := 1; Depth_Reduced := False; when 1 => -- rebalance declare Right_Son : constant Link_Type := Root.Right; Right_Son_Balance : constant Equilibrium_Type := Right_Son.Balance; begin if Right_Son_Balance >= 0 then -- single RR rotation Root.Right := Right_Son.Left; Right_Son.Left := Root; if Right_Son_Balance = 0 then Root.Balance := 1; Right_Son.Balance := -1; Depth_Reduced := False; else Root.Balance := 0; Right_Son.Balance := 0; end if; Root := Right_Son; else -- double RL rotation declare Right_Left_Son : constant Link_Type := Right_Son.Left; Right_Left_Son_Balance : constant Equilibrium_Type := Right_Left_Son.Balance; begin Right_Son.Left := Right_Left_Son.Right; Right_Left_Son.Right := Right_Son; Root.Right := Right_Left_Son.Left; Right_Left_Son.Left := Root; if Right_Left_Son_Balance = 1 then Root.Balance := -1; else Root.Balance := 0; end if; if Right_Left_Son_Balance = -1 then Right_Son.Balance := 1; else Right_Son.Balance := 0; end if; Root := Right_Left_Son; Right_Left_Son.Balance := 0; end; end if; end; end case; end Balance_Left; -- LOCAL SUBPROGRAM: procedure Balance_Right (Root : in out Link_Type; Depth_Reduced : in out Boolean); procedure Balance_Right (Root : in out Link_Type; Depth_Reduced : in out Boolean) is begin -- BALANCE_RIGHT case Root.Balance is when 1 => Root.Balance := 0; when 0 => Root.Balance := -1; Depth_Reduced := False; when -1 => -- rebalance declare Left_Son : constant Link_Type := Root.Left; Left_Son_Balance : constant Equilibrium_Type := Left_Son.Balance; begin if Left_Son_Balance <= 0 then -- single LL rotation Root.Left := Left_Son.Right; Left_Son.Right := Root; if Left_Son_Balance = 0 then Root.Balance := -1; Left_Son.Balance := 1; Depth_Reduced := False; else Root.Balance := 0; Left_Son.Balance := 0; end if; Root := Left_Son; else -- double LR rotation declare Left_Right_Son : constant Link_Type := Left_Son.Right; Left_Right_Son_Balance : constant Equilibrium_Type := Left_Right_Son.Balance; begin Left_Son.Right := Left_Right_Son.Left; Left_Right_Son.Left := Left_Son; Root.Left := Left_Right_Son.Right; Left_Right_Son.Right := Root; if Left_Right_Son_Balance = -1 then Root.Balance := 1; else Root.Balance := 0; end if; if Left_Right_Son_Balance = 1 then Left_Son.Balance := -1; else Left_Son.Balance := 0; end if; Root := Left_Right_Son; Left_Right_Son.Balance := 0; end; end if; end; end case; end Balance_Right; procedure Remove (Table : in out Table_Type; Key : Key_Type) is Found : Boolean; begin -- REMOVE Remove (Table, Key, Found); if not Found then raise Missing_Item_Error; end if; end Remove; procedure Remove (Table : in out Table_Type; Key : Key_Type; Value : out Value_Type) is Ptr : constant Link_Type := Search_A_Key (Table.Root, Key); Found : Boolean; begin -- REMOVE if Ptr = null then raise Missing_Item_Error; end if; Assign (Value, Ptr.Value); Remove (Table, Key, Found); end Remove; procedure Remove (Table : in out Table_Type; Key : Key_Type; Found : out Boolean) is Depth_Decreased : Boolean := False; Temp : Link_Type; procedure Remove_Node (Root : in out Link_Type; Depth_Reduced : in out Boolean); procedure Remove_Node (Root : in out Link_Type; Depth_Reduced : in out Boolean) is procedure Delete_Biggest (Node : in out Link_Type; Depth_Reduced : in out Boolean); procedure Delete_Biggest (Node : in out Link_Type; Depth_Reduced : in out Boolean) is begin if Node.Right = null then -- NODE already points to the biggest key value. Assign (Root.Key, Node.Key); Assign (Root.Value, Node.Value); Temp := Node; -- in order to dispose the right cell Node := Node.Left; Depth_Reduced := True; else Delete_Biggest (Node.Right, Depth_Reduced); if Depth_Reduced then Balance_Right (Node, Depth_Reduced); end if; end if; end Delete_Biggest; procedure Delete_Smallest (Node : in out Link_Type; Depth_Reduced : in out Boolean); procedure Delete_Smallest (Node : in out Link_Type; Depth_Reduced : in out Boolean) is begin if Node.Left = null then -- NODE already points to the smallest key value. Assign (Root.Key, Node.Key); Assign (Root.Value, Node.Value); Temp := Node; -- in order to dispose the right cell Node := Node.Right; Depth_Reduced := True; else Delete_Smallest (Node.Left, Depth_Reduced); if Depth_Reduced then Balance_Left (Node, Depth_Reduced); end if; end if; end Delete_Smallest; begin -- REMOVE_NODE if Root = null then return; end if; if Less (Key, Root.Key) then -- delete in left subtable Remove_Node (Root.Left, Depth_Reduced); if Depth_Reduced then Balance_Left (Root, Depth_Reduced); end if; elsif Less (Root.Key, Key) then -- delete in right subtable Remove_Node (Root.Right, Depth_Reduced); if Depth_Reduced then Balance_Right (Root, Depth_Reduced); end if; elsif Equals (Key, Root.Key) then if Root.Right = null then Temp := Root; Root := Root.Left; Depth_Reduced := True; elsif Root.Left = null then Temp := Root; Root := Root.Right; Depth_Reduced := True; else if Table.Connect_Predecessor then Table.Connect_Predecessor := False; Delete_Biggest (Root.Left, Depth_Reduced); if Depth_Reduced then Balance_Left (Root, Depth_Reduced); end if; else -- CONNECT_SUCCESSOR Table.Connect_Predecessor := True; Delete_Smallest (Root.Right, Depth_Reduced); if Depth_Reduced then Balance_Right (Root, Depth_Reduced); end if; end if; end if; Table.Count := Table.Count - 1; Found := True; Release (Temp); end if; end Remove_Node; begin -- REMOVE Found := False; Remove_Node (Table.Root, Depth_Decreased); end Remove; procedure Remove_Min (Table : in out Table_Type) is Found : Boolean; Ptr : constant Link_Type := Search_Min (Table.Root); begin if Table.Root = null then raise Empty_Structure_Error; end if; Remove (Table, Ptr.Key, Found); end Remove_Min; procedure Remove_Min (Table : in out Table_Type; Key : in out Key_Type) is Found : Boolean; Ptr : constant Link_Type := Search_Min (Table.Root); begin if Table.Root = null then raise Empty_Structure_Error; end if; Assign (Key, Ptr.Key); Remove (Table, Ptr.Key, Found); end Remove_Min; procedure Remove_Min (Table : in out Table_Type; Key : in out Key_Type; Value : out Value_Type) is Found : Boolean; Ptr : constant Link_Type := Search_Min (Table.Root); begin if Table.Root = null then raise Empty_Structure_Error; end if; Assign (Key, Ptr.Key); Assign (Value, Ptr.Value); Remove (Table, Ptr.Key, Found); end Remove_Min; procedure Remove_Max (Table : in out Table_Type) is Found : Boolean; Ptr : constant Link_Type := Search_Max (Table.Root); begin if Table.Root = null then raise Empty_Structure_Error; end if; Remove (Table, Ptr.Key, Found); end Remove_Max; procedure Remove_Max (Table : in out Table_Type; Key : in out Key_Type) is Found : Boolean; Ptr : constant Link_Type := Search_Max (Table.Root); begin if Table.Root = null then raise Empty_Structure_Error; end if; Assign (Key, Ptr.Key); Remove (Table, Ptr.Key, Found); end Remove_Max; procedure Remove_Max (Table : in out Table_Type; Key : in out Key_Type; Value : out Value_Type) is Found : Boolean; Ptr : constant Link_Type := Search_Max (Table.Root); begin if Table.Root = null then raise Empty_Structure_Error; end if; Assign (Key, Ptr.Key); Assign (Value, Ptr.Value); Remove (Table, Ptr.Key, Found); end Remove_Max; procedure Update_Value_Or_Exception_G (Table : in out Table_Type; Key : Key_Type) is Link : constant Link_Type := Search_A_Key (Table.Root, Key); begin if Link = null then raise Missing_Item_Error; end if; Modify (Link.Key, Link.Value); end Update_Value_Or_Exception_G; procedure Update_Value_Or_Status_G (Table : in out Table_Type; Key : Key_Type; Found : out Boolean) is Link : constant Link_Type := Search_A_Key (Table.Root, Key); begin if Link = null then Found := False; return; end if; Found := True; Modify (Link.Key, Link.Value); end Update_Value_Or_Status_G; -- QUERIES: function Size (Table : Table_Type) return Natural is begin -- SIZE return Table.Count; end Size; function Is_Empty (Table : Table_Type) return Boolean is begin -- IS_EMPTY return Table.Count = 0; end Is_Empty; function Is_Present (Table : Table_Type; Key : Key_Type) return Boolean is begin -- IS_PRESENT return Search_A_Key (Table.Root, Key) /= null; end Is_Present; function Value (Table : Table_Type; Key : Key_Type) return Value_Type is Ptr : constant Link_Type := Search_A_Key (Table.Root, Key); begin -- GET_VALUE if Ptr = null then raise Missing_Item_Error; end if; return Ptr.Value; end Value; procedure Get_Value (Table : Table_Type; Key : Key_Type; Value : out Value_Type) is Ptr : constant Link_Type := Search_A_Key (Table.Root, Key); begin -- GET_VALUE if Ptr = null then raise Missing_Item_Error; end if; Assign (Value, Ptr.Value); end Get_Value; procedure Get_Min_Item (Table : Table_Type; Key : in out Key_Type; Value : out Value_Type) is Current : Link_Type := Table.Root; begin -- GET_MIN_ITEM if Current = null then raise Empty_Structure_Error; end if; while Current.Left /= null loop Current := Current.Left; end loop; Assign (Key, Current.Key); Assign (Value, Current.Value); end Get_Min_Item; procedure Get_Max_Item (Table : Table_Type; Key : in out Key_Type; Value : out Value_Type) is Current : Link_Type := Table.Root; begin -- GET_MAX_ITEM if Current = null then raise Empty_Structure_Error; end if; while Current.Right /= null loop Current := Current.Right; end loop; Assign (Key, Current.Key); Assign (Value, Current.Value); end Get_Max_Item; function Min_Key (Table : Table_Type) return Key_Type is Current : Link_Type := Table.Root; begin -- GET_MIN_KEY if Current = null then raise Empty_Structure_Error; end if; while Current.Left /= null loop Current := Current.Left; end loop; return Current.Key; end Min_Key; procedure Get_Min_Key (Table : Table_Type; Key : in out Key_Type) is Current : Link_Type := Table.Root; begin -- GET_MIN_KEY if Current = null then raise Empty_Structure_Error; end if; while Current.Left /= null loop Current := Current.Left; end loop; Assign (Key, Current.Key); end Get_Min_Key; function Max_Key (Table : Table_Type) return Key_Type is Current : Link_Type := Table.Root; begin -- GET_MAX_KEY if Current = null then raise Empty_Structure_Error; end if; while Current.Right /= null loop Current := Current.Right; end loop; return Current.Key; end Max_Key; procedure Get_Max_Key (Table : Table_Type; Key : in out Key_Type) is Current : Link_Type := Table.Root; begin -- GET_MAX_KEY if Current = null then raise Empty_Structure_Error; end if; while Current.Right /= null loop Current := Current.Right; end loop; Assign (Key, Current.Key); end Get_Max_Key; -- LOCAL SUBPROGRAM: function Search_Less_Or_Equal (Root : Link_Type; Key : Key_Type) return Link_Type; function Search_Less_Or_Equal (Root : Link_Type; Key : Key_Type) return Link_Type is -- Result points to the cell with key value less than or equal to KEY; -- when search fails, null value is returned. Ptr : Link_Type := Root; Best : Link_Type; begin if Ptr = null then return null; end if; loop if Less (Key, Ptr.Key) then if Ptr.Left = null then return Best; end if; Ptr := Ptr.Left; elsif Equals (Key, Ptr.Key) then return Ptr; else -- LESS (PTR.KEY, KEY) if Ptr.Right = null then return Ptr; end if; Best := Ptr; Ptr := Ptr.Right; end if; end loop; end Search_Less_Or_Equal; pragma Inline (Search_Less_Or_Equal); -- LOCAL SUBPROGRAM: function Search_Less (Root : Link_Type; Key : Key_Type) return Link_Type; function Search_Less (Root : Link_Type; Key : Key_Type) return Link_Type is -- Result points to the cell with key value less than KEY; when search -- fails, null value is returned. Ptr : Link_Type := Root; Best : Link_Type; begin if Ptr = null then return null; end if; loop if Less (Key, Ptr.Key) or Equals (Key, Ptr.Key) then if Ptr.Left = null then return Best; end if; Ptr := Ptr.Left; else -- LESS (PTR.KEY, KEY) if Ptr.Right = null then return Ptr; end if; Best := Ptr; Ptr := Ptr.Right; end if; end loop; end Search_Less; pragma Inline (Search_Less); -- LOCAL SUBPROGRAM: function Search_Greater_Or_Equal (Root : Link_Type; Key : Key_Type) return Link_Type; function Search_Greater_Or_Equal (Root : Link_Type; Key : Key_Type) return Link_Type is -- Result points to the cell with key value greater than or equal to -- KEY; when search fails, null value is returned. Ptr : Link_Type := Root; Best : Link_Type; begin if Ptr = null then return null; end if; loop if Less (Ptr.Key, Key) then if Ptr.Right = null then return Best; end if; Ptr := Ptr.Right; elsif Equals (Key, Ptr.Key) then return Ptr; else -- LESS (KEY, PTR.KEY) if Ptr.Left = null then return Ptr; end if; Best := Ptr; Ptr := Ptr.Left; end if; end loop; end Search_Greater_Or_Equal; pragma Inline (Search_Greater_Or_Equal); -- LOCAL SUBPROGRAM: function Search_Greater (Root : Link_Type; Key : Key_Type) return Link_Type; function Search_Greater (Root : Link_Type; Key : Key_Type) return Link_Type is -- Result points to the cell with key value greater than KEY; when -- search fails, null value is returned. Ptr : Link_Type := Root; Best : Link_Type; begin if Ptr = null then return null; end if; loop if Less (Ptr.Key, Key) or Equals (Ptr.Key, Key) then if Ptr.Right = null then return Best; end if; Ptr := Ptr.Right; else -- LESS (KEY, PTR.KEY) if Ptr.Left = null then return Ptr; end if; Best := Ptr; Ptr := Ptr.Left; end if; end loop; end Search_Greater; pragma Inline (Search_Greater); procedure Get_Less_Item (Table : Table_Type; Key : in out Key_Type; Value : out Value_Type) is Ptr : constant Link_Type := Search_Less (Table.Root, Key); begin if Ptr = null then raise Missing_Item_Error; end if; Assign (Key, Ptr.Key); Assign (Value, Ptr.Value); end Get_Less_Item; procedure Get_Less_Or_Equal_Item (Table : Table_Type; Key : in out Key_Type; Value : out Value_Type) is Ptr : constant Link_Type := Search_Less_Or_Equal (Table.Root, Key); begin if Ptr = null then raise Missing_Item_Error; end if; Assign (Key, Ptr.Key); Assign (Value, Ptr.Value); end Get_Less_Or_Equal_Item; procedure Get_Greater_Item (Table : Table_Type; Key : in out Key_Type; Value : out Value_Type) is Ptr : constant Link_Type := Search_Greater (Table.Root, Key); begin if Ptr = null then raise Missing_Item_Error; end if; Assign (Key, Ptr.Key); Assign (Value, Ptr.Value); end Get_Greater_Item; procedure Get_Greater_Or_Equal_Item (Table : Table_Type; Key : in out Key_Type; Value : out Value_Type) is Ptr : constant Link_Type := Search_Greater_Or_Equal (Table.Root, Key); begin if Ptr = null then raise Missing_Item_Error; end if; Assign (Key, Ptr.Key); Assign (Value, Ptr.Value); end Get_Greater_Or_Equal_Item; function Less_Key (Table : Table_Type; Key : Key_Type) return Key_Type is Ptr : constant Link_Type := Search_Less (Table.Root, Key); begin if Ptr = null then raise Missing_Item_Error; end if; return Ptr.Key; end Less_Key; procedure Get_Less_Key (Table : Table_Type; Key : in out Key_Type) is Ptr : constant Link_Type := Search_Less (Table.Root, Key); begin if Ptr = null then raise Missing_Item_Error; end if; Assign (Key, Ptr.Key); end Get_Less_Key; procedure Get_Less_Key (Table : Table_Type; Key : in out Key_Type; Found : out Boolean) is Ptr : constant Link_Type := Search_Less (Table.Root, Key); begin if Ptr = null then Found := False; else Found := True; Assign (Key, Ptr.Key); end if; end Get_Less_Key; function Less_Or_Equal_Key (Table : Table_Type; Key : Key_Type) return Key_Type is Ptr : constant Link_Type := Search_Less_Or_Equal (Table.Root, Key); begin if Ptr = null then raise Missing_Item_Error; end if; return Ptr.Key; end Less_Or_Equal_Key; procedure Get_Less_Or_Equal_Key (Table : Table_Type; Key : in out Key_Type) is Ptr : constant Link_Type := Search_Less_Or_Equal (Table.Root, Key); begin if Ptr = null then raise Missing_Item_Error; end if; Assign (Key, Ptr.Key); end Get_Less_Or_Equal_Key; procedure Get_Less_Or_Equal_Key (Table : Table_Type; Key : in out Key_Type; Found : out Boolean) is Ptr : constant Link_Type := Search_Less_Or_Equal (Table.Root, Key); begin if Ptr = null then Found := False; else Found := True; Assign (Key, Ptr.Key); end if; end Get_Less_Or_Equal_Key; function Greater_Key (Table : Table_Type; Key : Key_Type) return Key_Type is Ptr : constant Link_Type := Search_Greater (Table.Root, Key); begin if Ptr = null then raise Missing_Item_Error; end if; return Ptr.Key; end Greater_Key; procedure Get_Greater_Key (Table : Table_Type; Key : in out Key_Type) is Ptr : constant Link_Type := Search_Greater (Table.Root, Key); begin if Ptr = null then raise Missing_Item_Error; end if; Assign (Key, Ptr.Key); end Get_Greater_Key; procedure Get_Greater_Key (Table : Table_Type; Key : in out Key_Type; Found : out Boolean) is Ptr : constant Link_Type := Search_Greater (Table.Root, Key); begin if Ptr = null then Found := False; else Found := True; Assign (Key, Ptr.Key); end if; end Get_Greater_Key; function Greater_Or_Equal_Key (Table : Table_Type; Key : Key_Type) return Key_Type is Ptr : constant Link_Type := Search_Greater_Or_Equal (Table.Root, Key); begin if Ptr = null then raise Missing_Item_Error; end if; return Ptr.Key; end Greater_Or_Equal_Key; procedure Get_Greater_Or_Equal_Key (Table : Table_Type; Key : in out Key_Type) is Ptr : constant Link_Type := Search_Greater_Or_Equal (Table.Root, Key); begin if Ptr = null then raise Missing_Item_Error; end if; Assign (Key, Ptr.Key); end Get_Greater_Or_Equal_Key; procedure Get_Greater_Or_Equal_Key (Table : Table_Type; Key : in out Key_Type; Found : out Boolean) is Ptr : constant Link_Type := Search_Greater_Or_Equal (Table.Root, Key); begin if Ptr = null then Found := False; else Found := True; Assign (Key, Ptr.Key); end if; end Get_Greater_Or_Equal_Key; -- SET OPERATIONS: package body Set_Operations_G is -- LOCAL SUBPROGRAM: procedure Conditional_Union (Destination : in out Table_Type; Source : Table_Type); procedure Conditional_Union (Destination : in out Table_Type; Source : Table_Type) is -- All entries which are in SOURCE but not in DESTINATION are -- inserted into DESTINATION. DESTINATION and SOURCE must not access -- the same table. procedure Action (Key : Key_Type; Value : Value_Type; Order_Number : Positive; Continue : in out Boolean); procedure Action (Key : Key_Type; Value : Value_Type; Order_Number : Positive; Continue : in out Boolean) is pragma Warnings (Off, Order_Number); pragma Warnings (Off, Continue); Dummy : Boolean; begin Insert (Destination, Key, Value, Dummy); end Action; procedure Traversal is new Disorder_Traverse_G (Action); begin Traversal (Source); end Conditional_Union; -- LOCAL SUBPROGRAM: procedure Unconditional_Union (Destination : in out Table_Type; Source : Table_Type); procedure Unconditional_Union (Destination : in out Table_Type; Source : Table_Type) is -- All entries which are in SOURCE are inserted into DESTINATION or -- replace previous entries. procedure Action (Key : Key_Type; Value : Value_Type; Order_Number : Positive; Continue : in out Boolean); procedure Action (Key : Key_Type; Value : Value_Type; Order_Number : Positive; Continue : in out Boolean) is pragma Warnings (Off, Order_Number); pragma Warnings (Off, Continue); begin Insert_Or_Replace_Value (Destination, Key, Value); end Action; procedure Traversal is new Disorder_Traverse_G (Action); begin Traversal (Source); end Unconditional_Union; procedure Union (Destination : in out Table_Type; Left, Right : Table_Type) is begin if Left.Root = Right.Root then if Destination.Root = Left.Root then null; else Assign (Destination, Left); end if; elsif Destination.Root = Left.Root then Conditional_Union (Destination, Right); elsif Destination.Root = Right.Root then Unconditional_Union (Destination, Left); else Assign (Destination, Left); Conditional_Union (Destination, Right); end if; end Union; -- LOCAL SUBPROGRAM: procedure Local_Intersection (Destination : in out Table_Type; Left, Right : Table_Type); procedure Local_Intersection (Destination : in out Table_Type; Left, Right : Table_Type) is -- DESTINATION must be an empty table. LEFT is traversed and each -- entry which is also in RIGHT is inserted into DESTINATION. procedure Action (Key : Key_Type; Value : Value_Type; Order_Number : Positive; Continue : in out Boolean); procedure Action (Key : Key_Type; Value : Value_Type; Order_Number : Positive; Continue : in out Boolean) is pragma Warnings (Off, Order_Number); pragma Warnings (Off, Continue); begin if Is_Present (Right, Key) then Insert (Destination, Key, Value); end if; end Action; procedure Traversal is new Disorder_Traverse_G (Action); begin Traversal (Left); end Local_Intersection; procedure Intersection (Destination : in out Table_Type; Left, Right : Table_Type) is Local_Table : Table_Type; begin if Left.Root = Right.Root then if Destination.Root = Left.Root then null; else Assign (Destination, Left); end if; elsif Destination.Root = Left.Root or Destination.Root = Right.Root then Local_Intersection (Local_Table, Left, Right); Assign (Destination, Local_Table); Destroy (Local_Table); else Destroy (Destination); Local_Intersection (Destination, Left, Right); end if; end Intersection; -- LOCAL SUBPROGRAM: procedure Local_Difference (Destination : in out Table_Type; Left, Right : Table_Type); procedure Local_Difference (Destination : in out Table_Type; Left, Right : Table_Type) is -- DESTINATION must be an empty table. LEFT is traversed and each -- entry which is not in RIGHT is inserted into DESTINATION. procedure Action (Key : Key_Type; Value : Value_Type; Order_Number : Positive; Continue : in out Boolean); procedure Action (Key : Key_Type; Value : Value_Type; Order_Number : Positive; Continue : in out Boolean) is pragma Warnings (Off, Order_Number); pragma Warnings (Off, Continue); begin if not Is_Present (Right, Key) then Insert (Destination, Key, Value); end if; end Action; procedure Traversal is new Disorder_Traverse_G (Action); begin Traversal (Left); end Local_Difference; procedure Difference (Destination : in out Table_Type; Left, Right : Table_Type) is Local_Table : Table_Type; begin if Left.Root = Right.Root then Destroy (Destination); elsif Destination.Root = Left.Root or Destination.Root = Right.Root then Local_Difference (Local_Table, Left, Right); Assign (Destination, Local_Table); Destroy (Local_Table); else Destroy (Destination); Local_Difference (Destination, Left, Right); end if; end Difference; -- LOCAL SUBPROGRAM: procedure Local_Symmetric_Difference (Destination : in out Table_Type; Left, Right : Table_Type); procedure Local_Symmetric_Difference (Destination : in out Table_Type; Left, Right : Table_Type) is -- DESTINATION must be an empty table. LEFT is traversed and each -- entry which is not in RIGHT is inserted into DESTINATION. Then -- RIGHT is traversed and each entry which is not in LEFT is -- inserted into DESTINATION. procedure Action_For_Left (Key : Key_Type; Value : Value_Type; Order_Number : Positive; Continue : in out Boolean); procedure Action_For_Left (Key : Key_Type; Value : Value_Type; Order_Number : Positive; Continue : in out Boolean) is pragma Warnings (Off, Order_Number); pragma Warnings (Off, Continue); begin if not Is_Present (Right, Key) then Insert (Destination, Key, Value); end if; end Action_For_Left; procedure Action_For_Right (Key : Key_Type; Value : Value_Type; Order_Number : Positive; Continue : in out Boolean); procedure Action_For_Right (Key : Key_Type; Value : Value_Type; Order_Number : Positive; Continue : in out Boolean) is pragma Warnings (Off, Order_Number); pragma Warnings (Off, Continue); begin if not Is_Present (Left, Key) then Insert (Destination, Key, Value); end if; end Action_For_Right; procedure Traverse_Left is new Disorder_Traverse_G (Action_For_Left); procedure Traverse_Right is new Disorder_Traverse_G (Action_For_Right); begin Traverse_Left (Left); Traverse_Right (Right); end Local_Symmetric_Difference; procedure Symmetric_Difference (Destination : in out Table_Type; Left, Right : Table_Type) is Local_Table : Table_Type; begin if Left.Root = Right.Root then Destroy (Destination); elsif Destination.Root = Left.Root or Destination.Root = Right.Root then Local_Symmetric_Difference (Local_Table, Left, Right); Assign (Destination, Local_Table); Destroy (Local_Table); else Destroy (Destination); Local_Symmetric_Difference (Destination, Left, Right); end if; end Symmetric_Difference; -- LOCAL SUBPROGRAM: procedure Fill_List (Table : Table_Type; Link_List : in out Link_List_Type); procedure Fill_List (Table : Table_Type; Link_List : in out Link_List_Type) is -- Fills LINK_LIST with pointers to the items of TABLE according to -- order defined on them. -- Condition: LINK_LIST'LAST = TABLE.COUNT Index : Natural := 0; procedure Traverse_Subtree (Link : Link_Type); procedure Traverse_Subtree (Link : Link_Type) is -- LINK points to root of subtree. begin -- TRAVERSE_SUBTREE if Link /= null then Traverse_Subtree (Link.Left); Index := Index + 1; Link_List (Index) := Link; Traverse_Subtree (Link.Right); end if; end Traverse_Subtree; begin -- FILL_LIST -- if TABLE.COUNT /= LINK_LIST'LAST then -- raise CONSTRAINT_ERROR; -- end if; -- Statements provided for debugging. Traverse_Subtree (Table.Root); end Fill_List; function "=" (Left, Right : Table_Type) return Boolean is -- Set equality; the LEFT and RIGHT tables contain entries with same -- values Left_Op_Link_List : Link_List_Type (1 .. Left.Count); Right_Op_Link_List : Link_List_Type (1 .. Right.Count); begin -- "=" if Left.Root = Right.Root then -- LEFT and RIGHT points to the same table. return True; end if; if Left.Count /= Right.Count then return False; end if; if Left.Count = 0 then -- two empty tables return True; end if; Fill_List (Left, Left_Op_Link_List); Fill_List (Right, Right_Op_Link_List); for Index in 1 .. Left.Count loop if not Equals (Left_Op_Link_List (Index).Key, Right_Op_Link_List (Index).Key) then return False; end if; end loop; return True; end "="; function "<" (Left, Right : Table_Type) return Boolean is -- Strict set inclusion; to each entry in the LEFT table an entry -- with same value is associated in the RIGHT table, but the two -- sets are not identical. Left_Op_Link_List : Link_List_Type (1 .. Left.Count); Right_Op_Link_List : Link_List_Type (1 .. Right.Count); Found : Boolean; Right_Index : Positive := 1; begin -- "<" if Left.Count >= Right.Count then -- The case of identical sets is processed here. return False; end if; if Left.Count = 0 then return True; end if; Fill_List (Left, Left_Op_Link_List); Fill_List (Right, Right_Op_Link_List); for Left_Index in 1 .. Left.Count loop Found := False; while Right_Index <= Right.Count loop if Equals (Left_Op_Link_List (Left_Index).Key, Right_Op_Link_List (Right_Index).Key) then Found := True; Right_Index := Right_Index + 1; exit; -- inner loop end if; Right_Index := Right_Index + 1; end loop; if not Found then -- item associated with LEFT_INDEX has not been found in RIGHT -- table. return False; end if; end loop; return True; end "<"; function "<=" (Left, Right : Table_Type) return Boolean is -- Strict set inclusion; to each entry in the LEFT table an entry -- with same key is associated in the RIGHT table. Left_Op_Link_List : Link_List_Type (1 .. Left.Count); Right_Op_Link_List : Link_List_Type (1 .. Right.Count); Found : Boolean; Right_Index : Positive := 1; begin -- "<=" if Left.Root = Right.Root then -- LEFT and RIGHT points to the same table. return True; end if; if Left.Count > Right.Count then return False; end if; if Left.Count = 0 then return True; end if; Fill_List (Left, Left_Op_Link_List); Fill_List (Right, Right_Op_Link_List); for Left_Index in 1 .. Left.Count loop Found := False; while Right_Index <= Right.Count loop if Equals (Left_Op_Link_List (Left_Index).Key, Right_Op_Link_List (Right_Index).Key) then Found := True; Right_Index := Right_Index + 1; exit; -- inner loop end if; Right_Index := Right_Index + 1; end loop; if not Found then -- item associated with LEFT_INDEX has not been found in RIGHT -- table. return False; end if; end loop; return True; end "<="; function ">" (Left, Right : Table_Type) return Boolean is begin -- ">" return Right < Left; end ">"; function ">=" (Left, Right : Table_Type) return Boolean is begin -- ">=" return Right <= Left; end ">="; end Set_Operations_G; -- ITERATORS: procedure Traverse_Asc_G (Table : Table_Type) is Order_Number : Positive := 1; Continue : Boolean := True; procedure Traverse_Subtree (Link : Link_Type); procedure Traverse_Subtree (Link : Link_Type) is begin if Link.Left /= null then Traverse_Subtree (Link.Left); end if; if Continue then Action (Link.Key, Link.Value, Order_Number, Continue); Order_Number := Order_Number + 1; end if; if Continue and then Link.Right /= null then Traverse_Subtree (Link.Right); end if; end Traverse_Subtree; begin -- TRAVERSE_ASC_G if Table.Root /= null then Traverse_Subtree (Table.Root); end if; end Traverse_Asc_G; procedure Traverse_Desc_G (Table : Table_Type) is Order_Number : Positive := 1; Continue : Boolean := True; procedure Traverse_Subtree (Link : Link_Type); procedure Traverse_Subtree (Link : Link_Type) is begin if Link.Right /= null then Traverse_Subtree (Link.Right); end if; if Continue then Action (Link.Key, Link.Value, Order_Number, Continue); Order_Number := Order_Number + 1; end if; if Continue and then Link.Left /= null then Traverse_Subtree (Link.Left); end if; end Traverse_Subtree; begin -- TRAVERSE_DESC_G if Table.Root /= null then Traverse_Subtree (Table.Root); end if; end Traverse_Desc_G; procedure Traverse_Asc_And_Update_Value_G (Table : in out Table_Type) is Order_Number : Positive := 1; Continue : Boolean := True; procedure Traverse_Subtree (Link : Link_Type); procedure Traverse_Subtree (Link : Link_Type) is begin if Link.Left /= null then Traverse_Subtree (Link.Left); end if; if Continue then Modify (Link.Key, Link.Value, Order_Number, Continue); Order_Number := Order_Number + 1; end if; if Continue and then Link.Right /= null then Traverse_Subtree (Link.Right); end if; end Traverse_Subtree; begin -- TRAVERSE_ASC_AND_UPDATE_VALUE_G if Table.Root /= null then Traverse_Subtree (Table.Root); end if; end Traverse_Asc_And_Update_Value_G; procedure Traverse_Desc_And_Update_Value_G (Table : in out Table_Type) is Order_Number : Positive := 1; Continue : Boolean := True; procedure Traverse_Subtree (Link : Link_Type); procedure Traverse_Subtree (Link : Link_Type) is begin if Link.Right /= null then Traverse_Subtree (Link.Right); end if; if Continue then Modify (Link.Key, Link.Value, Order_Number, Continue); Order_Number := Order_Number + 1; end if; if Continue and then Link.Left /= null then Traverse_Subtree (Link.Left); end if; end Traverse_Subtree; begin -- TRAVERSE_DESC_AND_UPDATE_VALUE_G if Table.Root /= null then Traverse_Subtree (Table.Root); end if; end Traverse_Desc_And_Update_Value_G; procedure Disorder_Traverse_G (Table : Table_Type) is Current : Link_Type; Insert_Position : Positive; Link_List : Link_List_Type (1 .. Table.Count); Continue : Boolean := True; begin -- DISORDER_TRAVERSE_G if Table.Count = 0 then return; end if; Link_List (1) := Table.Root; Insert_Position := 2; for Order_Number in 1 .. Table.Count loop Current := Link_List (Order_Number); Action (Current.Key, Current.Value, Order_Number, Continue); if not Continue then exit; end if; if Current.Left /= null then Link_List (Insert_Position) := Current.Left; Insert_Position := Insert_Position + 1; end if; if Current.Right /= null then Link_List (Insert_Position) := Current.Right; Insert_Position := Insert_Position + 1; end if; end loop; end Disorder_Traverse_G; procedure Disorder_Traverse_And_Update_Value_G (Table : in out Table_Type) is Current : Link_Type; Insert_Position : Positive; Link_List : Link_List_Type (1 .. Table.Count); Continue : Boolean := True; begin -- DISORDER_TRAVERSE_AND_UPDATE_VALUE_G if Table.Count = 0 then return; end if; Link_List (1) := Table.Root; Insert_Position := 2; for Order_Number in 1 .. Table.Count loop Current := Link_List (Order_Number); Modify (Current.Key, Current.Value, Order_Number, Continue); if not Continue then exit; end if; if Current.Left /= null then Link_List (Insert_Position) := Current.Left; Insert_Position := Insert_Position + 1; end if; if Current.Right /= null then Link_List (Insert_Position) := Current.Right; Insert_Position := Insert_Position + 1; end if; end loop; end Disorder_Traverse_And_Update_Value_G; -- HEAP MANAGEMENT: procedure Destroy (Table : in out Table_Type) is Current : Link_Type; Insert_Position : Positive; Link_List : Link_List_Type (1 .. Table.Count); begin -- DESTROY if Table.Count = 0 then return; end if; -- May optimize. Link_List (1) := Table.Root; Insert_Position := 2; for Fetch_Position in 1 .. Table.Count loop Current := Link_List (Fetch_Position); if Current.Left /= null then Link_List (Insert_Position) := Current.Left; Insert_Position := Insert_Position + 1; end if; if Current.Right /= null then Link_List (Insert_Position) := Current.Right; Insert_Position := Insert_Position + 1; end if; Release (Current); end loop; Table := (null, 0, True); end Destroy; procedure Release_Free_List is Temp : Link_Type; begin while Free_List.Ptr /= null loop Temp := Free_List.Ptr; Free_List.Ptr := Free_List.Ptr.Right; Dispose (Temp); end loop; Free_List.Count := 0; end Release_Free_List; procedure Set_Max_Free_List_Size (Max_Free_List_Size : Natural) is Nb_Of_Cells_For_System : constant Integer := Free_List.Count - Max_Free_List_Size; Temp : Link_Type; begin if Nb_Of_Cells_For_System > 0 then for I in 1 .. Nb_Of_Cells_For_System loop Temp := Free_List.Ptr; Free_List.Ptr := Free_List.Ptr.Right; Dispose (Temp); end loop; Free_List.Count := Free_List.Count - Nb_Of_Cells_For_System; end if; Table_Of_Dynamic_Keys_And_Static_Values_G.Max_Free_List_Size := Max_Free_List_Size; end Set_Max_Free_List_Size; function Free_List_Size return Natural is begin return Free_List.Count; end Free_List_Size; procedure Assign_Item (Destination : out Value_Type; Source : Value_Type) is begin Destination := Source; end Assign_Item; procedure Destroy_Item (Item : Value_Type) is -- Mode of the parameter is artificial, but mode 'out' could raise -- CONSTRAINT_ERROR ! begin pragma Warnings (Off); pragma Unreferenced (Item); pragma Warnings (On); null; end Destroy_Item; pragma Inline (Assign_Item); pragma Inline (Destroy_Item); end Table_Of_Dynamic_Keys_And_Static_Values_G; polyorb-2.8~20110207.orig/src/aws_orig/aws-messages.adb0000644000175000017500000004215611750740337022070 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- A W S . M E S S A G E S -- -- -- -- B o d y -- -- -- -- Copyright (C) 2000-2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with Ada.Characters.Handling; with Ada.Exceptions; with AWS.Utils; package body AWS.Messages is type String_Access is access constant String; subtype Status_Code_Image is String (1 .. 3); S100_Message : aliased constant String := "Continue"; S101_Message : aliased constant String := "Switching Protocols"; S200_Message : aliased constant String := "OK"; S201_Message : aliased constant String := "Create"; S202_Message : aliased constant String := "Accepted"; S203_Message : aliased constant String := "Non-Authoritative Information"; S204_Message : aliased constant String := "No Content"; S205_Message : aliased constant String := "Reset Content"; S206_Message : aliased constant String := "Partial Content"; S300_Message : aliased constant String := "Multiple Choices"; S301_Message : aliased constant String := "Moved Permanently"; S302_Message : aliased constant String := "Found"; S303_Message : aliased constant String := "See Other"; S304_Message : aliased constant String := "Not Modified"; S305_Message : aliased constant String := "Use Proxy"; S307_Message : aliased constant String := "Temporary Redirect"; S400_Message : aliased constant String := "Bad Request"; S401_Message : aliased constant String := "Unauthorized"; S402_Message : aliased constant String := "Payment Required"; S403_Message : aliased constant String := "Forbidden"; S404_Message : aliased constant String := "Not Found"; S405_Message : aliased constant String := "Method Not Allowed"; S406_Message : aliased constant String := "Not Acceptable"; S407_Message : aliased constant String := "Proxy Authentification Required"; S408_Message : aliased constant String := "Request Time-out"; S409_Message : aliased constant String := "Conflict"; S410_Message : aliased constant String := "Gone"; S411_Message : aliased constant String := "Length Required"; S412_Message : aliased constant String := "Precondition Failed"; S413_Message : aliased constant String := "Request Entity Too Large"; S414_Message : aliased constant String := "Request-URI Too Large"; S415_Message : aliased constant String := "Unsupported Media Type"; S416_Message : aliased constant String := "Requestd range not satisfiable"; S417_Message : aliased constant String := "Expectation Failed"; S500_Message : aliased constant String := "Internal Server Error"; S501_Message : aliased constant String := "Not Implemented"; S502_Message : aliased constant String := "Bad Gateway"; S503_Message : aliased constant String := "Service Unavailable"; S504_Message : aliased constant String := "Gateway Time-out"; S505_Message : aliased constant String := "HTTP Version not supported"; type Status_Data is record Code : Status_Code_Image; Reason_Phrase : String_Access; end record; Status_Messages : constant array (Status_Code) of Status_Data := (S100 => ("100", S100_Message'Access), S101 => ("101", S101_Message'Access), S200 => ("200", S200_Message'Access), S201 => ("201", S201_Message'Access), S202 => ("202", S202_Message'Access), S203 => ("203", S203_Message'Access), S204 => ("204", S204_Message'Access), S205 => ("205", S205_Message'Access), S206 => ("206", S206_Message'Access), S300 => ("300", S300_Message'Access), S301 => ("301", S301_Message'Access), S302 => ("302", S302_Message'Access), S303 => ("303", S303_Message'Access), S304 => ("304", S304_Message'Access), S305 => ("305", S305_Message'Access), S307 => ("307", S307_Message'Access), S400 => ("400", S400_Message'Access), S401 => ("401", S401_Message'Access), S402 => ("402", S402_Message'Access), S403 => ("403", S403_Message'Access), S404 => ("404", S404_Message'Access), S405 => ("405", S405_Message'Access), S406 => ("406", S406_Message'Access), S407 => ("407", S407_Message'Access), S408 => ("408", S408_Message'Access), S409 => ("409", S409_Message'Access), S410 => ("410", S410_Message'Access), S411 => ("411", S411_Message'Access), S412 => ("412", S412_Message'Access), S413 => ("413", S413_Message'Access), S414 => ("414", S414_Message'Access), S415 => ("415", S415_Message'Access), S416 => ("416", S416_Message'Access), S417 => ("417", S417_Message'Access), S500 => ("500", S500_Message'Access), S501 => ("501", S501_Message'Access), S502 => ("502", S502_Message'Access), S503 => ("503", S503_Message'Access), S504 => ("504", S504_Message'Access), S505 => ("505", S505_Message'Access)); Month_Name : constant array (Calendar.Month_Number) of String (1 .. 3) := ("Jan", "Feb", "Mar", "Apr", "May", "Jun", "Jul", "Aug", "Sep", "Oct", "Nov", "Dec"); HD : constant String := ": "; -- Header delimiter with space for well formatting. --------------------- -- Accept_Language -- --------------------- function Accept_Language (Mode : String) return String is begin return Accept_Language_Token & HD & Mode; end Accept_Language; ----------------- -- Accept_Type -- ----------------- function Accept_Type (Mode : String) return String is begin return Accept_Token & HD & Mode; end Accept_Type; ------------------- -- Authorization -- ------------------- function Authorization (Mode, Password : String) return String is begin return Authorization_Token & HD & Mode & ' ' & Password; end Authorization; ------------------- -- Cache_Control -- ------------------- function Cache_Control (Option : Cache_Option) return String is begin return Cache_Control_Token & HD & String (Option); end Cache_Control; ---------------- -- Connection -- ---------------- function Connection (Mode : String) return String is begin return Connection_Token & HD & Mode; end Connection; ------------------------- -- Content_Disposition -- ------------------------- function Content_Disposition (Format : String; Name : String; Filename : String) return String is begin if Filename = "" then return Content_Disposition_Token & HD & Format & "; name=""" & Name & '"'; else return Content_Disposition_Token & HD & Format & "; name=""" & Name & """; filename=""" & Filename & '"'; end if; end Content_Disposition; -------------------- -- Content_Length -- -------------------- function Content_Length (Size : Natural) return String is begin return Content_Length_Token & HD & Utils.Image (Size); end Content_Length; ------------------ -- Content_Type -- ------------------ function Content_Type (Format : String; Boundary : String := "") return String is begin if Boundary = "" then return Content_Type_Token & HD & Format; else return Content_Type_Token & HD & Format & "; boundary=" & Boundary; end if; end Content_Type; ------------ -- Cookie -- ------------ function Cookie (Value : String) return String is begin return Cookie_Token & HD & Value; end Cookie; -------------------- -- Does_Not_Match -- -------------------- function Does_Not_Match (Str, Pattern : String) return Boolean is use Ada.Characters; U_Str : constant String := Handling.To_Upper (Str); U_Pattern : constant String := Handling.To_Upper (Pattern); begin return Pattern'Length > Str'Length or else U_Str (1 .. Pattern'Length) /= U_Pattern; end Does_Not_Match; ---------- -- Host -- ---------- function Host (Name : String) return String is begin return Host_Token & HD & Name; end Host; ----------- -- Image -- ----------- function Image (S : Status_Code) return String is begin return Status_Messages (S).Code; end Image; ------------------- -- Last_Modified -- ------------------- function Last_Modified (Date : Calendar.Time) return String is begin return Last_Modified_Token & HD & To_HTTP_Date (Date); end Last_Modified; -------------- -- Location -- -------------- function Location (URL : String) return String is begin return Location_Token & HD & URL; end Location; ----------- -- Match -- ----------- function Match (Str, Pattern : String) return Boolean is use Ada.Characters; U_Str : constant String := Handling.To_Upper (Str); U_Pattern : constant String := Handling.To_Upper (Pattern); begin return Pattern'Length <= Str'Length and then U_Str (1 .. Pattern'Length) = U_Pattern; end Match; ------------------------- -- Proxy_Authorization -- ------------------------- function Proxy_Authorization (Mode, Password : String) return String is begin return Proxy_Authorization_Token & HD & Mode & ' ' & Password; end Proxy_Authorization; ---------------------- -- Proxy_Connection -- ---------------------- function Proxy_Connection (Mode : String) return String is begin return Proxy_Connection_Token & HD & Mode; end Proxy_Connection; ------------------- -- Reason_Phrase -- ------------------- function Reason_Phrase (S : Status_Code) return String is begin return Status_Messages (S).Reason_Phrase.all; end Reason_Phrase; ---------------- -- SOAPAction -- ---------------- function SOAPAction (URI : String) return String is begin return SOAPAction_Token & HD & '"' & URI & '"'; end SOAPAction; ----------------- -- Status_Line -- ----------------- function Status_Line (Code : Status_Code) return String is begin return HTTP_Version & ' ' & Status_Messages (Code).Code & ' ' & Status_Messages (Code).Reason_Phrase.all; end Status_Line; ------------------ -- To_HTTP_Date -- ------------------ function To_HTTP_Date (Time : Calendar.Time) return String is function Truncation (S : Calendar.Day_Duration) return Natural; -- returns the integral value of S. function Image (V : Natural) return String; -- returns V image without the leading space and with leading zero if -- only one digit function Weekday (Date : Calendar.Time) return String; -- returns the weekday as a 3 letters string for the Date. ----------- -- Image -- ----------- function Image (V : Natural) return String is V_Image : constant String := Natural'Image (V); begin if V_Image'Length = 2 then -- only one digit add a leading zero return '0' & V_Image (2 .. V_Image'Last); else return V_Image (2 .. V_Image'Last); end if; end Image; ---------------- -- Truncation -- ---------------- function Truncation (S : Calendar.Day_Duration) return Natural is begin if S = 0.0 then return 0; else return Natural (S - 0.5); end if; end Truncation; ------------- -- Weekday -- ------------- function Weekday (Date : Calendar.Time) return String is Day_Names : constant array (Integer range 0 .. 6) of String (1 .. 3) := ("Sun", "Mon", "Tue", "Wed", "Thu", "Fri", "Sat"); C : Integer; Y : Integer := Calendar.Year (Date); M : Integer := Calendar.Month (Date); D : constant Integer := Calendar.Day (Date); begin -- Calculate day of week by using Zeller's congruence if M < 3 then Y := Y - 1; M := M + 10; else M := M - 2; end if; C := Y / 100; -- first two digits of Year Y := Y mod 100; -- last two digits of Year return Day_Names (((26 * M - 2) / 10 + D + Y + Y / 4 + C / 4 - 2 * C) mod 7); end Weekday; Day : constant String := Image (Calendar.Day (Time)); Mon : constant String := Month_Name (Calendar.Month (Time)); Year : constant String := Image (Calendar.Year (Time)); Secs : constant Natural := Truncation (Calendar.Seconds (Time)); Tmp : constant Natural := Secs mod 3600; H : constant String := Image (Secs / 3600); M : constant String := Image (Tmp / 60); S : constant String := Image (Tmp mod 60); begin return Weekday (Time) & ", " & Day & ' ' & Mon & ' ' & Year & ' ' & H & ':' & M & ':' & S & " GMT"; end To_HTTP_Date; ------------- -- To_Time -- ------------- function To_Time (HTTP_Date : String) return Calendar.Time is function Month_Number (Month_Name : String) return Calendar.Month_Number; -- returns the month number given a 3 letter month name. F : constant Positive := HTTP_Date'First; ------------------ -- Month_Number -- ------------------ function Month_Number (Month_Name : String) return Calendar.Month_Number is begin for I in Calendar.Month_Number loop if Month_Name = Messages.Month_Name (I) then return I; end if; end loop; Exceptions.Raise_Exception (Constraint_Error'Identity, "Month_Number: Wrong Month name (" & Month_Name & ')'); end Month_Number; begin return Calendar.Time_Of (Year => Calendar.Year_Number'Value (HTTP_Date (F + 12 .. F + 15)), Month => Month_Number (HTTP_Date (F + 8 .. F + 10)), Day => Calendar.Day_Number'Value (HTTP_Date (F + 5 .. F + 6)), Seconds => Calendar.Day_Duration (Natural'Value (HTTP_Date (F + 17 .. F + 18)) * 3600 + Natural'Value (HTTP_Date (F + 20 .. F + 21)) * 60 + Natural'Value (HTTP_Date (F + 23 .. F + 24)))); end To_Time; ----------------------- -- Transfer_Encoding -- ----------------------- function Transfer_Encoding (Encoding : String) return String is begin return Transfer_Encoding_Token & HD & Encoding; end Transfer_Encoding; ---------------- -- User_Agent -- ---------------- function User_Agent (Name : String) return String is begin return User_Agent_Token & HD & Name; end User_Agent; ---------------------- -- Www_Authenticate -- ---------------------- function WWW_Authenticate (Realm : String) return String is begin return WWW_Authenticate_Token & HD & "Basic realm=""" & Realm & """"; end WWW_Authenticate; function WWW_Authenticate (Realm : String; Nonce : String; Stale : Boolean) return String is begin return WWW_Authenticate_Token & HD & "Digest qop=""auth"", realm=""" & Realm & """, stale=""" & Boolean'Image (Stale) & """, nonce=""" & Nonce & """"; end WWW_Authenticate; end AWS.Messages; polyorb-2.8~20110207.orig/src/aws_orig/aws-messages.ads0000644000175000017500000002465611750740337022116 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- A W S . M E S S A G E S -- -- -- -- S p e c -- -- -- -- Copyright (C) 2000-2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- @@@ relies on ada.calendar with Ada.Calendar; package AWS.Messages is use Ada; ----------------- -- HTTP tokens -- ----------------- HTTP_Token : constant String := "HTTP/"; Get_Token : constant String := "GET "; Head_Token : constant String := "HEAD "; Post_Token : constant String := "POST "; ------------------------ -- HTTP header tokens -- ------------------------ -- General header tokens RFC 2616 Cache_Control_Token : constant String := "Cache-Control"; Connection_Token : constant String := "Connection"; Date_Token : constant String := "Date"; Pragma_Token : constant String := "Pragma"; Trailer_Token : constant String := "Trailer"; Transfer_Encoding_Token : constant String := "Transfer-Encoding"; Upgrade_Token : constant String := "Upgrade"; Via_Token : constant String := "Via"; Warning_Token : constant String := "Warning"; -- Request header tokens RFC 2616 Accept_Token : constant String := "Accept"; Accept_Charset_Token : constant String := "Accept-Charset"; Accept_Encoding_Token : constant String := "Accept-Encoding"; Accept_Language_Token : constant String := "Accept-Language"; Authorization_Token : constant String := "Authorization"; Expect_Token : constant String := "Expect"; From_Token : constant String := "From"; Host_Token : constant String := "Host"; If_Match_Token : constant String := "If-Match"; If_Modified_Since_Token : constant String := "If-Modified-Since"; If_None_Match_Token : constant String := "If-None-Match"; If_Range_Token : constant String := "If-Range"; If_Unmodified_Since_Token : constant String := "If-Unmodified-Since"; Max_Forwards_Token : constant String := "Max-Forwards"; Proxy_Authorization_Token : constant String := "Proxy-Authorization"; Range_Token : constant String := "Range"; Referer_Token : constant String := "Referer"; TE_Token : constant String := "TE"; User_Agent_Token : constant String := "User-Agent"; -- Response header tokens RFC 2616 Accept_Ranges_Token : constant String := "Accept-Ranges"; Age_Token : constant String := "Age"; ETag_Token : constant String := "ETag"; Location_Token : constant String := "Location"; Proxy_Authenticate_Token : constant String := "Proxy-Authenticate"; Retry_After_Token : constant String := "Retry-After"; Server_Token : constant String := "Server"; Vary_Token : constant String := "Vary"; WWW_Authenticate_Token : constant String := "WWW-Authenticate"; -- Entity header tokens RFC 2616 Allow_Token : constant String := "Allow"; Content_Encoding_Token : constant String := "Content-Encoding"; Content_Language_Token : constant String := "Content-Language"; Content_Length_Token : constant String := "Content-Length"; Content_Location_Token : constant String := "Content-Location"; Content_MD5_Token : constant String := "Content-MD5"; Content_Range_Token : constant String := "Content-Range"; Content_Type_Token : constant String := "Content-Type"; Expires_Token : constant String := "Expires"; Last_Modified_Token : constant String := "Last-Modified"; -- Other tokens. Proxy_Connection_Token : constant String := "Proxy-Connection"; Content_Disposition_Token : constant String := "Content-Disposition"; Cookie_Token : constant String := "Cookie"; Set_Cookie_Token : constant String := "Set-Cookie"; SOAPAction_Token : constant String := "SOAPAction"; ----------------- -- Status Code -- ----------------- type Status_Code is (S100, S101, -- 1xx : Informational - Request received, continuing process S200, S201, S202, S203, S204, S205, S206, -- 2xx : Success - The action was successfully received, understood and -- accepted S300, S301, S302, S303, S304, S305, S307, -- 3xx : Redirection - Further action must be taken in order to -- complete the request S400, S401, S402, S403, S404, S405, S406, S407, S408, S409, S410, S411, S412, S413, S414, S415, S416, S417, -- 4xx : Client Error - The request contains bad syntax or cannot be -- fulfilled S500, S501, S502, S503, S504, S505 -- 5xx : Server Error - The server failed to fulfill an apparently -- valid request ); function Image (S : Status_Code) return String; -- Returns Status_Code image. This value does not contain the leading S. function Reason_Phrase (S : Status_Code) return String; -- Returns the reason phrase for the status code S, see [RFC 2616 - 6.1.1] ------------------- -- Cache_Control -- ------------------- type Cache_Option is new String; Unspecified : constant Cache_Option; No_Cache : constant Cache_Option; No_Store : constant Cache_Option; ------------------------------- -- HTTP message constructors -- ------------------------------- function Accept_Type (Mode : String) return String; pragma Inline (Accept_Type); function Accept_Language (Mode : String) return String; pragma Inline (Accept_Language); function Authorization (Mode, Password : String) return String; pragma Inline (Authorization); function Connection (Mode : String) return String; pragma Inline (Connection); function Content_Length (Size : Natural) return String; pragma Inline (Content_Length); function Cookie (Value : String) return String; pragma Inline (Cookie); function Content_Type (Format : String; Boundary : String := "") return String; pragma Inline (Content_Type); function Cache_Control (Option : Cache_Option) return String; pragma Inline (Cache_Control); function Content_Disposition (Format : String; Name : String; Filename : String) return String; pragma Inline (Content_Disposition); -- Note that this is not part of HTTP/1.1 standard, it is there because -- there is a lot of implementation around using it. This header is used -- in multipart data. function Host (Name : String) return String; pragma Inline (Host); function Last_Modified (Date : Calendar.Time) return String; pragma Inline (Last_Modified); function Location (URL : String) return String; pragma Inline (Location); function Proxy_Authorization (Mode, Password : String) return String; pragma Inline (Proxy_Authorization); function Proxy_Connection (Mode : String) return String; pragma Inline (Proxy_Connection); function SOAPAction (URI : String) return String; pragma Inline (SOAPAction); function Status_Line (Code : Status_Code) return String; pragma Inline (Status_Line); function Transfer_Encoding (Encoding : String) return String; pragma Inline (Transfer_Encoding); function User_Agent (Name : String) return String; pragma Inline (User_Agent); function WWW_Authenticate (Realm : String) return String; pragma Inline (WWW_Authenticate); -- Basic authentication request. function WWW_Authenticate (Realm : String; Nonce : String; Stale : Boolean) return String; pragma Inline (WWW_Authenticate); -- Digest authentication request. -- helper functions function Match (Str, Pattern : String) return Boolean; pragma Inline (Match); -- Returns True if Pattern matches the begining of Str. The test is not -- case sensitive. function Does_Not_Match (Str, Pattern : String) return Boolean; pragma Inline (Does_Not_Match); -- Returns True if Pattern does not matches the begining of Str. The test -- is not case sensitive. function To_HTTP_Date (Time : Calendar.Time) return String; -- Returns an Ada time as a string using the HTTP normalized format. -- Format is RFC 822, updated by RFC 1123. function To_Time (HTTP_Date : String) return Calendar.Time; -- Returns an Ada time from an HTTP one. This is To_HTTP_Date opposite -- function. private Unspecified : constant Cache_Option := ""; No_Cache : constant Cache_Option := "no-cache"; No_Store : constant Cache_Option := "no-store"; end AWS.Messages; polyorb-2.8~20110207.orig/src/aws_orig/aws-resources-embedded.adb0000644000175000017500000001420611750740337024015 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- A W S . R E S O U R C E S . E M B E D D E D -- -- -- -- B o d y -- -- -- -- Copyright (C) 2002-2007, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- @@@ uses ada.calendar with Table_Of_Strings_And_Static_Values_G; pragma Elaborate_All (Table_Of_Strings_And_Static_Values_G); package body AWS.Resources.Embedded is type Node is record File_Buffer : Buffer_Access; File_Time : Calendar.Time; end record; package Res_Files is new Table_Of_Strings_And_Static_Values_G (Character, String, "<", "=", Node); Files_Table : Res_Files.Table_Type; Empty_Buffer : aliased constant Ada.Streams.Stream_Element_Array := (1 .. 0 => 0); ----------- -- Close -- ----------- procedure Close (Resource : in out File_Tagged) is pragma Unreferenced (Resource); begin null; end Close; ------------ -- Create -- ------------ procedure Create (File : out File_Type; Buffer : Buffer_Access) is begin File := new File_Tagged; if Buffer = null then File_Tagged (File.all).Buffer := Empty_Buffer'Access; else File_Tagged (File.all).Buffer := Buffer; end if; File_Tagged (File.all).K := Buffer'First; end Create; ----------------- -- End_Of_File -- ----------------- function End_Of_File (Resource : File_Tagged) return Boolean is begin return Resource.K > Resource.Buffer'Last; end End_Of_File; ------------ -- Exists -- ------------ function Exists (Name : String) return Boolean is begin return Res_Files.Is_Present (Files_Table, Name); end Exists; --------------- -- File_Size -- --------------- function File_Size (Name : String) return Ada.Streams.Stream_Element_Offset is N : Node; begin if Res_Files.Is_Present (Files_Table, Name) then N := Res_Files.Value (Files_Table, Name); return N.File_Buffer'Length; else raise Resource_Error; end if; end File_Size; -------------------- -- File_Timestamp -- -------------------- function File_Timestamp (Name : String) return Ada.Calendar.Time is N : Node; begin if Res_Files.Is_Present (Files_Table, Name) then N := Res_Files.Value (Files_Table, Name); return N.File_Time; else raise Resource_Error; end if; end File_Timestamp; --------------------- -- Is_Regular_File -- --------------------- function Is_Regular_File (Name : String) return Boolean is begin return Exists (Name); end Is_Regular_File; ---------- -- Open -- ---------- procedure Open (File : out File_Type; Name : String; Form : String := "") is pragma Unreferenced (Form); N : Node; begin if Res_Files.Is_Present (Files_Table, Name) then N := Res_Files.Value (Files_Table, Name); File := new File_Tagged; File_Tagged (File.all).Buffer := N.File_Buffer; File_Tagged (File.all).K := N.File_Buffer'First; else File := null; end if; end Open; ---------- -- Read -- ---------- procedure Read (Resource : in out File_Tagged; Buffer : out Stream_Element_Array; Last : out Stream_Element_Offset) is K : Stream_Element_Offset renames Resource.K; Size : Stream_Element_Offset; -- Number of byte remaining in buffer begin if K > Resource.Buffer'Last then Last := 0; else Size := Resource.Buffer'Length - (K - Resource.Buffer'First); if Buffer'Length <= Size then Buffer := Resource.Buffer (K .. K + Buffer'Length - 1); Last := Buffer'Last; K := K + Buffer'Length; else Last := Buffer'First + Size - 1; Buffer (Buffer'First .. Last) := Resource.Buffer (K .. Resource.Buffer'Last); K := Resource.Buffer'Last + 1; end if; end if; Resource.K := K; end Read; -------------- -- Register -- -------------- procedure Register (Name : String; Content : Buffer_Access; File_Time : Calendar.Time) is begin Res_Files.Insert (Files_Table, Name, (Content, File_Time)); end Register; end AWS.Resources.Embedded; polyorb-2.8~20110207.orig/src/aws_orig/aws-containers-key_value.ads0000644000175000017500000000417111750740337024424 0ustar xavierxavier------------------------------------------------------------------------------ -- Ada Web Server -- -- -- -- Copyright (C) 2000-2002 -- -- ACT-Europe -- -- -- -- Authors: Dmitriy Anisimkov - Pascal Obry -- -- -- -- This library is free software; you can redistribute it and/or modify -- -- it under the terms of the GNU General Public License as published by -- -- the Free Software Foundation; either version 2 of the License, or (at -- -- your option) any later version. -- -- -- -- This library is distributed in the hope that it will be useful, but -- -- WITHOUT ANY WARRANTY; without even the implied warranty of -- -- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -- -- General Public License for more details. -- -- -- -- You should have received a copy of the GNU General Public License -- -- along with this library; if not, write to the Free Software Foundation, -- -- Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. -- -- -- ------------------------------------------------------------------------------ with Ada.Strings.Unbounded; with Table_Of_Strings_And_Static_Values_G; package AWS.Containers.Key_Value is package Table is new Table_Of_Strings_And_Static_Values_G (Character, String, "<", "=", Ada.Strings.Unbounded.Unbounded_String); type Set is new Table.Table_Type; type Set_Access is access Set; end AWS.Containers.Key_Value; polyorb-2.8~20110207.orig/src/aws_orig/templates_parser.ads0000644000175000017500000002660611750740337023066 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- T E M P L A T E S _ P A R S E R -- -- -- -- S p e c -- -- -- -- Copyright (C) 1999-2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with Ada.Finalization; with Ada.Strings.Unbounded; package Templates_Parser is use Ada.Strings.Unbounded; Template_Error : exception; Default_Begin_Tag : constant String := "@_"; Default_End_Tag : constant String := "_@"; Default_Separator : constant String := ", "; procedure Set_Tag_Separators (Start_With : String := Default_Begin_Tag; Stop_With : String := Default_End_Tag); -- Set the tag separators for the whole session. This should be changed as -- the very first API call and should not be changed after. ---------------- -- Vector Tag -- ---------------- type Vector_Tag is private; -- A vector tag is a set of strings. Note that this object is using a -- by-reference semantic. A reference counter is associated to it and -- the memory is realeased when there is no more reference to it. function "+" (Value : String) return Vector_Tag; -- Vector_Tag constructor. function "+" (Value : Character) return Vector_Tag; -- Vector_Tag constructor. function "+" (Value : Boolean) return Vector_Tag; -- Vector_Tag constructor. function "+" (Value : Unbounded_String) return Vector_Tag; -- Vector_Tag constructor. function "+" (Value : Integer) return Vector_Tag; -- Vector_Tag constructor. function "&" (Vect : Vector_Tag; Value : String) return Vector_Tag; -- Add Value at the end of the vector tag set. function "&" (Vect : Vector_Tag; Value : Character) return Vector_Tag; -- Add Value at the end of the vector tag set. function "&" (Vect : Vector_Tag; Value : Boolean) return Vector_Tag; -- Add Value (either string TRUE or FALSE) at the end of the vector tag -- set. function "&" (Vect : Vector_Tag; Value : Unbounded_String) return Vector_Tag; -- Add Value at the end of the vector tag set. function "&" (Vect : Vector_Tag; Value : Integer) return Vector_Tag; -- Add Value (converted to a String) at the end of the vector tag set. procedure Clear (Vect : in out Vector_Tag); -- Removes all values in the vector tag. Current Vect is not released but -- the returned object is separated (not using the same reference) from -- the original one. function Size (Vect : Vector_Tag) return Natural; -- Returns the number of value into Vect. function Item (Vect : Vector_Tag; N : Positive) return String; -- Returns the Nth Vector Tag's item. Raises Constraint_Error if there is -- no such Item in the vector (i.e. vector length < N). ---------------- -- Matrix Tag -- ---------------- type Matrix_Tag is private; -- A matrix tag is a set of vectors. Note that this object is using a -- by-reference semantic. A reference counter is associated to it and -- the memory is realeased when there is no more reference to it. function "+" (Vect : Vector_Tag) return Matrix_Tag; -- Matrix_Tag constructor. It returns a matrix with a single row whose -- value is Vect. function "&" (Matrix : Matrix_Tag; Vect : Vector_Tag) return Matrix_Tag; -- Returns Matrix with Vect added to the end. function Size (Matrix : Matrix_Tag) return Natural; -- Returns the number of Vector_Tag (rows) inside the Matrix. function Vector (Matrix : Matrix_Tag; N : Positive) return Vector_Tag; -- Returns Nth Vector_Tag in the Matrix. ----------------------- -- Association table -- ----------------------- type Association is private; type Translate_Table is array (Positive range <>) of Association; No_Translation : constant Translate_Table; function Assoc (Variable : String; Value : String) return Association; -- Build an Association (Variable = Value) to be added to a -- Translate_Table. This is a standard association, value is a string. function Assoc (Variable : String; Value : Unbounded_String) return Association; -- Build an Association (Variable = Value) to be added to a -- Translate_Table. This is a standard association, value is an -- Unbounded_String. function Assoc (Variable : String; Value : Integer) return Association; -- Build an Association (Variable = Value) to be added to a -- Translate_Table. This is a standard association, value is an Integer. -- It will be displayed without leading space if positive. function Assoc (Variable : String; Value : Boolean) return Association; -- Build an Association (Variable = Value) to be added to a -- Translate_Table. It set the variable to TRUE or FALSE depending on -- value. function Assoc (Variable : String; Value : Vector_Tag; Separator : String := Default_Separator) return Association; -- Build an Association (Variable = Value) to be added to a -- Translate_Table. This is a vector tag association, value is a -- Vector_Tag. If the vector tag is found outside a table tag statement -- it is returned as a single string, each value being separated by the -- specified separator. function Assoc (Variable : String; Value : Matrix_Tag; Separator : String := Default_Separator) return Association; -- Build an Association (Variable = Value) to be added to a -- Translate_Table. This is a matrix tag association, value is a -- Matrix_Tag. If the matrix tag is found outside of a 2nd level table tag -- statement, Separator is used to build string representation of the -- matrix tag's vectors. ----------------------------- -- Parsing and Translating -- ----------------------------- function Parse (Filename : String; Translations : Translate_Table := No_Translation; Cached : Boolean := False; Keep_Unknown_Tags : Boolean := False) return String; -- Parse the Template_File replacing variables' occurrences by the -- corresponding values. If Cached is set to True, Filename tree will be -- recorded into a cache for quick retrieval. If Keep_Unknown_Tags is set -- to True then tags that are not in the translate table are kept -- as-is if it is part of the template data. If this tags is part of a -- condition (in an IF statement tag), the condition will evaluate to -- False. function Parse (Filename : String; Translations : Translate_Table := No_Translation; Cached : Boolean := False; Keep_Unknown_Tags : Boolean := False) return Unbounded_String; -- Idem as above but returns an Unbounded_String. function Translate (Template : String; Translations : Translate_Table := No_Translation) return String; -- Just translate the discrete variables in the Template string using the -- Translations table. This function does not parse the command tag -- (TABLE, IF, INCLUDE). All Vector and Matrix tag are replaced by the -- empty string. procedure Print_Tree (Filename : String); -- Use for debugging purpose only, it will output the internal tree -- representation. private ------------------ -- Vector Tags -- ------------------ type Vector_Tag_Node; type Vector_Tag_Node_Access is access Vector_Tag_Node; type Vector_Tag_Node is record Value : Unbounded_String; Next : Vector_Tag_Node_Access; end record; type Integer_Access is access Integer; type Vector_Tag is new Ada.Finalization.Controlled with record Ref_Count : Integer_Access; Count : Natural; Head : Vector_Tag_Node_Access; Last : Vector_Tag_Node_Access; end record; type Vector_Tag_Access is access Vector_Tag; procedure Initialize (V : in out Vector_Tag); procedure Finalize (V : in out Vector_Tag); procedure Adjust (V : in out Vector_Tag); ------------------ -- Matrix Tags -- ------------------ type Matrix_Tag_Node; type Matrix_Tag_Node_Access is access Matrix_Tag_Node; type Matrix_Tag_Node is record Vect : Vector_Tag; Next : Matrix_Tag_Node_Access; end record; type Matrix_Tag_Int is new Ada.Finalization.Controlled with record Ref_Count : Integer_Access; Count : Natural; -- Number of vector Min, Max : Natural; -- Min/Max vector's sizes Head : Matrix_Tag_Node_Access; Last : Matrix_Tag_Node_Access; end record; type Matrix_Tag is record M : Matrix_Tag_Int; end record; procedure Initialize (M : in out Matrix_Tag_Int); procedure Finalize (M : in out Matrix_Tag_Int); procedure Adjust (M : in out Matrix_Tag_Int); ------------------ -- Association -- ------------------ type Var_Kind is (Std, Vect, Matrix); type Association (Kind : Var_Kind := Std) is record Variable : Unbounded_String; case Kind is when Std => Value : Unbounded_String; when Vect => Vect_Value : Vector_Tag; Separator : Unbounded_String; when Matrix => Mat_Value : Matrix_Tag; Column_Separator : Unbounded_String; end case; end record; No_Translation : constant Translate_Table := (2 .. 1 => Association'(Std, Null_Unbounded_String, Null_Unbounded_String)); end Templates_Parser; polyorb-2.8~20110207.orig/src/aws_orig/aws-session.ads0000644000175000017500000001452411750740337021763 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- A W S . S E S S I O N -- -- -- -- S p e c -- -- -- -- Copyright (C) 2000-2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- This is the API to handle session data for each client connected. -- @@@ uses ada.calendar with Ada.Calendar; package AWS.Session is type ID is private; No_Session : constant ID; function Create return ID; -- Create a new uniq Session ID. procedure Delete (SID : ID); -- Delete session, does nothing if SID does not exists. function Image (SID : ID) return String; -- Return ID image function Value (SID : String) return ID; -- Build an ID from a String, returns No_Session if SID is not recongnized -- as an AWS session ID. function Exist (SID : ID) return Boolean; -- Returns True if SID exist procedure Touch (SID : ID); -- Update to current time the timestamp associated with SID. Does nothing -- if SID does not exists. procedure Set (SID : ID; Key : String; Value : String); -- Set key/pair value for the SID. procedure Set (SID : ID; Key : String; Value : Integer); -- Set key/pair value for the SID. procedure Set (SID : ID; Key : String; Value : Float); -- Set key/pair value for the SID. procedure Set (SID : ID; Key : String; Value : Boolean); -- Set key/pair value for the SID. function Get (SID : ID; Key : String) return String; -- Returns the Value for Key in the session SID or the emptry string if -- key does not exist. function Get (SID : ID; Key : String) return Integer; -- Returns the Value for Key in the session SID or the integer value 0 if -- key does not exist or is not an integer. function Get (SID : ID; Key : String) return Float; -- Returns the Value for Key in the session SID or the float value 0.0 if -- key does not exist or is not a float. function Get (SID : ID; Key : String) return Boolean; -- Returns the Value for Key in the session SID or the boolean False if -- key does not exist or is not a boolean. procedure Remove (SID : ID; Key : String); -- Removes Key from the specified session. function Exist (SID : ID; Key : String) return Boolean; -- Returns True if Key exist in session SID. generic with procedure Action (N : Positive; SID : ID; Time_Stamp : Ada.Calendar.Time; Quit : in out Boolean); procedure For_Every_Session; -- Iterator which call Action for every active session. N is the SID -- order. Time_Stamp is the time when SID was updated for the last -- time. Quit is set to False by default, it is possible to control the -- iterator termination by setting its value to True. generic with procedure Action (N : Positive; Key, Value : String; Quit : in out Boolean); procedure For_Every_Session_Data (SID : ID); -- Iterator which returns all the key/value pair defined for session SID. -- Quit is set to False by default, it is possible to control the iterator -- termination by setting its value to True. procedure Set_Lifetime (Seconds : Duration); -- Set the lifetime for session data. function Get_Lifetime return Duration; -- Get current session lifetime for session data. procedure Save (File_Name : String); -- Save all sessions data into File_Name. procedure Load (File_Name : String); -- Restore all sessions data from File_Name. private pragma Inline (Image, Value); type ID is new String (1 .. 11); No_Session : constant ID := (others => ' '); task type Cleaner is entry Stop; end Cleaner; -- Call Database.Clean every Session_Lifetime seconds. type Cleaner_Access is access Cleaner; Cleaner_Task : Cleaner_Access; --------------------- -- Cleaner_Control -- --------------------- protected Cleaner_Control is procedure Start (Session_Check_Interval : Duration; Session_Lifetime : Duration); -- Launch the cleaner task the first time and does nothing after. procedure Stop (Need_Release : out Boolean); -- Stop the cleaner task when there is no more server using it. Release -- is set to True if the Cleaner_Task can be released. private Server_Count : Natural := 0; end Cleaner_Control; end AWS.Session; polyorb-2.8~20110207.orig/src/aws_orig/aws-hotplug.adb0000644000175000017500000001426611750740337021744 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- A W S . H O T P L U G -- -- -- -- B o d y -- -- -- -- Copyright (C) 2000-2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with AWS.Client; with AWS.Parameters; package body AWS.Hotplug is procedure Adjust (Filters : in out Filter_Set); -- Check that the filter set is large enough to receive a new value. If it -- is not, filter set will be ajusted. ------------ -- Adjust -- ------------ procedure Adjust (Filters : in out Filter_Set) is Old_Set : Filter_Array_Access; begin if Filters.Set = null then Filters.Set := new Filter_Array (1 .. 10); elsif Filters.Set'Length <= Filters.Count then Old_Set := Filters.Set; Filters.Set := new Filter_Array (1 .. Filters.Count + 5); Filters.Set.all (Old_Set'Range) := Old_Set.all; end if; end Adjust; ----------- -- Apply -- ----------- procedure Apply (Filters : Filter_Set; Status : AWS.Status.Data; Found : out Boolean; Data : out Response.Data) is URI : constant String := AWS.Status.URI (Status); P : constant AWS.Parameters.List := AWS.Status.Parameters (Status); function Parameters return String; -- Returns the list of parameters suitable to send to a GET HTTP -- command "?name1=value1&name2=value2...". function Parameters return String is Result : Unbounded_String; begin for K in 1 .. AWS.Parameters.Count (P) loop if K = 1 then Append (Result, '?'); else Append (Result, '&'); end if; Append (Result, AWS.Parameters.Get_Name (P, K)); Append (Result, '=' & AWS.Parameters.Get_Value (P, K)); end loop; return To_String (Result); end Parameters; use type AWS.Status.Request_Method; begin Found := False; Look_For_Filters : for K in 1 .. Filters.Count loop if GNAT.Regexp.Match (URI, Filters.Set (K).Regexp) then Found := True; -- we must call the registered server to get the Data. if AWS.Status.Method (Status) = AWS.Status.GET then Data := Client.Get (To_String (Filters.Set (K).URL) & URI (URI'First + 1 .. URI'Last) & Parameters); else Data := Client.Post (To_String (Filters.Set (K).URL) & URI (URI'First + 1 .. URI'Last), AWS.Status.Binary_Data (Status)); end if; exit Look_For_Filters; end if; end loop Look_For_Filters; end Apply; --------------- -- Move_Down -- --------------- procedure Move_Down (Filters : Filter_Set; N : Positive) is Tmp : Filter_Data; begin if Filters.Count > N then Tmp := Filters.Set (N); Filters.Set (N) := Filters.Set (N + 1); Filters.Set (N + 1) := Tmp; end if; end Move_Down; ------------- -- Move_Up -- ------------- procedure Move_Up (Filters : Filter_Set; N : Positive) is Tmp : Filter_Data; begin if Filters.Count >= N and then N > 1 then Tmp := Filters.Set (N - 1); Filters.Set (N - 1) := Filters.Set (N); Filters.Set (N) := Tmp; end if; end Move_Up; -------------- -- Register -- -------------- procedure Register (Filters : in out Filter_Set; Regexp : String; URL : String) is begin Adjust (Filters); Filters.Count := Filters.Count + 1; Filters.Set (Filters.Count) := (To_Unbounded_String (Regexp), GNAT.Regexp.Compile (Regexp), To_Unbounded_String (URL)); end Register; ---------------- -- Unregister -- ---------------- procedure Unregister (Filters : in out Filter_Set; Regexp : String) is begin for K in 1 .. Filters.Count loop if To_String (Filters.Set (K).Regexp_Str) = Regexp then Filters.Set (K .. Filters.Count - 1) := Filters.Set (K + 1 .. Filters.Count); Filters.Count := Filters.Count - 1; exit; end if; end loop; end Unregister; end AWS.Hotplug; polyorb-2.8~20110207.orig/src/aws_orig/aws-dispatchers.ads0000644000175000017500000000674411750740337022616 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- A W S . D I S P A T C H E R S -- -- -- -- S p e c -- -- -- -- Copyright (C) 2000-2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- This package provides a service to build Callbacks which can support -- user's data. It is possible to build a new dispatcher by inheriting the -- handler type and to provides the Dispatch routine. with Ada.Finalization; with AWS.Response; with AWS.Status; package AWS.Dispatchers is type Handler is abstract new Ada.Finalization.Controlled with private; procedure Initialize (Dispatcher : in out Handler); procedure Adjust (Dispatcher : in out Handler); procedure Finalize (Dispatcher : in out Handler); -- Initialize/Adjust/Finalize is doing the reference counting, children -- should just call these routines if possible. It is possible to know if -- no more object are referenced by calling Ref_Counter below. function Dispatch (Dispatcher : Handler; Request : Status.Data) return Response.Data is abstract; -- Call the appropriate inherited dispatcher function Ref_Counter (Dispatcher : Handler) return Natural; -- Returns the reference counter for Handler. If 0 is returned then this -- object is not referenced anymore, it is safe to deallocate ressources. type Handler_Class_Access is access all Handler'Class; procedure Free (Dispatcher : in out Handler_Class_Access); pragma Inline (Free); private type Natural_Access is access all Natural; type Handler is abstract new Ada.Finalization.Controlled with record Ref_Counter : Natural_Access := null; end record; end AWS.Dispatchers; polyorb-2.8~20110207.orig/src/aws_orig/table_of_static_keys_and_dynamic_values_g.ads0000644000175000017500000007444111750740337030104 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- TABLE_OF_STATIC_KEYS_AND_DYNAMIC_VALUES_G -- -- -- -- S p e c -- -- -- -- Copyright (C) 2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- TITLE: GENERIC PACKAGE FOR ASSOCIATIVE TABLES. -- REVISION: 13-JUL-1992 Ph. Kipfer (PKR), File header format -- APPROVAL: 03-DEC-1987 C. Genillard. -- CREATION: 29-JUN-1987 A. Strohmeier. generic type Key_Type is private; with function Less (Left, Right : Key_Type) return Boolean; -- Defines ordering of keys. with function Equals (Left, Right : Key_Type) return Boolean; type Value_Type is limited private; with procedure Assign (Destination : in out Value_Type; Source : Value_Type); -- Assigns SOURCE to DESTINATION. If needed, DESTINATION has to be -- destroyed before assignement, since ASSIGN is called without a -- previous call to DESTROY in the implementation of the package. with procedure Destroy (Value : in out Value_Type); package Table_Of_Static_Keys_And_Dynamic_Values_G is -- OVERVIEW: -- This package provides associative tables of unlimited dynamic size with -- entries of type (KEY_TYPE, VALUE_TYPE), where KEY_TYPE and VALUE_TYPE are -- specified by generic parameters. Such a couple will also be called an item -- The type TABLE_TYPE is implemented in such a way that every object has -- the implied initial value of an empty table. -- Two items (k1, v1) and (k2, v2) have same key if and only if -- EQUALS (k1, k2). -- A table may not contain duplicate items, that is having same key. -- The following consistency condition must be fullfilled by the relational -- operations LESS and EQUALS: -- (i) EQUALS (k1, k2) implies not LESS (k1, k2) and not LESS (k2, k1) -- (ii) not LESS (k1, k2) and not EQUALS (k1, k2) implies LESS (k2, k1). -- In our terminology, a static type is a type which is neither a limited -- type nor an access type. When an actual generic access type is associated -- with a generic static type, objects would be shared, i.e. only the access -- value would be stored, without copying the accessed object. -- On the opposite, a dynamic type may be limited or an access type. -- However a dynamic type must have the feature that every object has an -- implied initial value. -- Depending on the very nature of the types KEY_TYPE and VALUE_TYPE, one -- of the provided packages has to be used: -- TABLE_OF_DYNAMIC_KEYS_AND_DYNAMIC_VALUES_G -- TABLE_OF_STATIC_KEYS_AND_DYNAMIC_VALUES_G -- TABLE_OF_DYNAMIC_KEYS_AND_STATIC_VALUES_G -- TABLE_OF_STATIC_KEYS_AND_STATIC_VALUES_G -- -- CAUTION: -- Functions which return the value of an item (or part of it) of the -- structure share the item with the structure and do not return a copy of it -- This may have consequences if the type of the item, (or some component of -- it) is an access type. For instance, when accessing an item by a function -- call, this item must not be destroyed or modified during the query. -- -- PRIMITIVES: -- CONSTRUCTORS: -- ASSIGN -- INSERT (2) -- INSERT_OR_REPLACE_VALUE -- REPLACE_VALUE (2) -- REMOVE (3) -- REMOVE_MIN (3) -- REMOVE_MAX (3) -- UPDATE_VALUE_OR_EXCEPTION_G -- UPDATE_VALUE_OR_STATUS_G -- QUERIES: -- SIZE -- IS_EMPTY -- IS_PRESENT -- VALUE -- GET_VALUE -- GET_MIN_ITEM -- GET_MAX_ITEM -- MIN_KEY -- GET_MIN_KEY -- MAX_KEY -- GET_MAX_KEY -- GET_LESS_ITEM -- GET_LESS_OR_EQUAL_ITEM -- GET_GREATER_ITEM -- GET_GREATER_OR_EQUAL_ITEM -- LESS_KEY -- GET_LESS_KEY (2) -- LESS_OR_EQUAL_KEY -- GET_LESS_OR_EQUAL_KEY (2) -- GREATER_KEY -- GET_GREATER_KEY (2) -- GREATER_OR_EQUAL_KEY -- GET_GREATER_OR_EQUAL_KEY (2) -- SET_OPERATIONS: -- SET_OPERATIONS_G -- UNION -- INTERSECTION -- DIFFERENCE -- SYMMETRIC_DIFFERENCE -- "=" (set equality) -- "<" (strict set inclusion) -- "<=" (set inclusion) -- ">" (strict set inclusion) -- ">=" (set inclusion) -- ITERATORS: -- TRAVERSE_ASC_G -- TRAVERSE_DESC_G -- TRAVERSE_ASC_AND_UPDATE_VALUE_G -- TRAVERSE_DESC_AND_UPDATE_VALUE_G -- DISORDER_TRAVERSE_G -- DISORDER_TRAVERSE_AND_UPDATE_VALUE_G -- HEAP MANAGEMENT: -- DESTROY -- RELEASE_FREE_LIST -- SET_MAX_FREE_LIST_SIZE -- FREE_LIST_SIZE -- -- ALGORITHM: -- A table is implemented as a balanced search binary tree (AVL-tree) -- using pointers. The items are sorted in the table by increasing keys -- values in conformance to inorder. -- An internal free list is used to avoid returning each free item (i.e. -- coming from REMOVE) to the system, so long as the length of this list does -- not exceed MAX_FREE_LIST_SIZE, in which case the free item is immediately -- returned to the system. When a new item has to be inserted (i.e. by a call -- to INSERT), an element is recovered from the free list if it is not empty. -- Otherwise, new space is taken from the system. type Table_Type is limited private; Duplicate_Item_Error, Missing_Item_Error, Empty_Structure_Error : exception; -- CONSTRUCTORS: procedure Assign (Destination : in out Table_Type; Source : Table_Type); -- OVERVIEW: -- Begins by a call to DESTROY (DESTINATION) and then copies SOURCE into -- DESTINATION. Note the "in out" mode of the formal parameter DESTINATION. procedure Insert (Table : in out Table_Type; Key : Key_Type; Value : Value_Type); -- OVERVIEW: -- Inserts the couple (KEY, VALUE) into TABLE. -- ERROR: -- If an entry with the given key is already in the table, then exception -- DUPLICATE_ITEM_ERROR is raised. procedure Insert (Table : in out Table_Type; Key : Key_Type; Value : Value_Type; Duplicate_Item : out Boolean); -- OVERVIEW: -- Inserts the couple (KEY, VALUE) into TABLE. No action is taken and no -- error occurs if an entry with the given key is already in the table -- except that DUPLICATE_ITEM is set to true. procedure Insert_Or_Replace_Value (Table : in out Table_Type; Key : Key_Type; Value : Value_Type); -- OVERVIEW: -- Inserts the couple (KEY, VALUE) into TABLE if there is no entry with -- this key. Otherwise the given VALUE replaces the previous one. procedure Replace_Value (Table : in out Table_Type; Key : Key_Type; Value : Value_Type); -- OVERVIEW: -- An entry having key KEY is searched for in TABLE. The given VALUE then -- replaces the previous one. -- ERROR: -- If there is no entry with the given key, the exception -- MISSING_ITEM_ERROR is raised. procedure Replace_Value (Table : in out Table_Type; Key : Key_Type; Value : Value_Type; Found : out Boolean); -- OVERVIEW: -- An entry having key KEY is searched for in TABLE. The given -- VALUE then replaces the previous one. No action is taken and no error -- occurs if there is no entry with the given key, except that FOUND -- is set to false. procedure Remove (Table : in out Table_Type; Key : Key_Type); procedure Remove (Table : in out Table_Type; Key : Key_Type; Value : in out Value_Type); -- OVERVIEW: -- Removes the entry with key KEY from TABLE and returns in -- parameter VALUE, if present, the associated VALUE. -- ERROR: -- If there is no entry with the given key, the exception -- MISSING_ITEM_ERROR is raised. In this case the value of the actual -- parameter VALUE is left unchanged. procedure Remove (Table : in out Table_Type; Key : Key_Type; Found : out Boolean); -- OVERVIEW: -- Removes the entry with key KEY from TABLE. No action is taken -- and no error occurs if there is no entry with the given key, except -- that FOUND is set to false. procedure Remove_Min (Table : in out Table_Type); procedure Remove_Min (Table : in out Table_Type; Key : out Key_Type); procedure Remove_Min (Table : in out Table_Type; Key : out Key_Type; Value : in out Value_Type); -- OVERVIEW: -- Removes the entry with the smallest key from TABLE and returns, -- if needed, the values of KEY and VALUE. -- ERROR: -- Raises EMPTY_STRUCTURE_ERROR if TABLE is empty. In this case the -- values of the actual parameters KEY and VALUE are left unchanged. procedure Remove_Max (Table : in out Table_Type); procedure Remove_Max (Table : in out Table_Type; Key : out Key_Type); procedure Remove_Max (Table : in out Table_Type; Key : out Key_Type; Value : in out Value_Type); -- OVERVIEW: -- Removes the entry with the greatest key from TABLE and returns, -- if needed, the values of KEY and VALUE. -- ERROR: -- Raises EMPTY_STRUCTURE_ERROR if TABLE is empty. In this case the -- values of the actual parameters KEY and VALUE are left unchanged. generic with procedure Modify (Key : Key_Type; Value : in out Value_Type) is <>; procedure Update_Value_Or_Exception_G (Table : in out Table_Type; Key : Key_Type); -- OVERVIEW: -- An entry with key KEY is searched for in TABLE. The associated item -- is then passed to procedure MODIFY for modification of its value part. -- ERROR: -- Raises MISSING_ITEM_ERROR if KEY is not in TABLE. generic with procedure Modify (Key : Key_Type; Value : in out Value_Type) is <>; procedure Update_Value_Or_Status_G (Table : in out Table_Type; Key : Key_Type; Found : out Boolean); -- OVERVIEW: -- An entry with key KEY is searched for in TABLE. The associated item -- is then passed to procedure MODIFY for modification of its value part. -- No action is taken and no error occurs if there is no entry with the -- given key, except that FOUND is set to false. -- QUERIES: function Size (Table : Table_Type) return Natural; -- OVERVIEW: -- Returns the number of entries currently in TABLE. function Is_Empty (Table : Table_Type) return Boolean; -- OVERVIEW: -- Returns TRUE if and only if the TABLE is empty. function Is_Present (Table : Table_Type; Key : Key_Type) return Boolean; -- OVERVIEW: -- Returns TRUE if and only if an ITEM with key KEY is in TABLE. function Value (Table : Table_Type; Key : Key_Type) return Value_Type; procedure Get_Value (Table : Table_Type; Key : Key_Type; Value : in out Value_Type); -- OVERVIEW: -- Gives the VALUE associated with KEY in TABLE. -- ERROR: -- Raises MISSING_ITEM_ERROR if KEY is not found in TABLE. In this case -- the value of the actual parameter VALUE is left unchanged. procedure Get_Min_Item (Table : Table_Type; Key : out Key_Type; Value : in out Value_Type); -- OVERVIEW: -- Gives the smallest KEY and the VALUE associated with it in TABLE. -- ERROR: -- Raises EMPTY_STRUCTURE_ERROR if TABLE is empty. In this case the -- values of the actual parameters KEY and VALUE are left unchanged. procedure Get_Max_Item (Table : Table_Type; Key : out Key_Type; Value : in out Value_Type); -- OVERVIEW: -- Gives the biggest KEY and the VALUE associated with it in TABLE. -- ERROR: -- Raises EMPTY_STRUCTURE_ERROR if TABLE is empty. In this case the -- values of the actual parameters KEY and VALUE are left unchanged. function Min_Key (Table : Table_Type) return Key_Type; procedure Get_Min_Key (Table : Table_Type; Key : out Key_Type); -- OVERVIEW: -- Gives the smallest KEY of TABLE. -- ERROR: -- Raises EMPTY_STRUCTURE_ERROR if TABLE is empty. In this case the value -- of the actual parameter KEY is left unchanged. function Max_Key (Table : Table_Type) return Key_Type; procedure Get_Max_Key (Table : Table_Type; Key : out Key_Type); -- OVERVIEW: -- Gives the biggest KEY of TABLE. -- ERROR: -- Raises EMPTY_STRUCTURE_ERROR if TABLE is empty. In this case the value -- of the actual parameter KEY is left unchanged. procedure Get_Less_Item (Table : Table_Type; Key : in out Key_Type; Value : in out Value_Type); -- OVERVIEW: -- Returns the entry having the greatest key less than the value of -- the actual parameter KEY. KEY is modified in accordance. -- ERROR: -- The exception MISSING_ITEM_ERROR is raised if there is not such an -- entry in the table. In this case the values of the actual parameters KEY -- and VALUE are left unchanged. procedure Get_Less_Or_Equal_Item (Table : Table_Type; Key : in out Key_Type; Value : in out Value_Type); -- OVERVIEW: -- Returns the entry having the greatest key less than or equal to -- the value of the actual parameter KEY. KEY is modified in accordance. -- ERROR: -- The exception MISSING_ITEM_ERROR is raised if there is not such an -- entry in the table. In this case the values of the actual parameters KEY -- and VALUE are left unchanged. procedure Get_Greater_Item (Table : Table_Type; Key : in out Key_Type; Value : in out Value_Type); -- OVERVIEW: -- Returns the entry having the smallest key greater than the value -- of the actual parameter KEY. KEY is modified in accordance. -- ERROR: -- The exception MISSING_ITEM_ERROR is raised if there is not such an -- entry in the table. In this case the values of the actual parameters KEY -- and VALUE are left unchanged. procedure Get_Greater_Or_Equal_Item (Table : Table_Type; Key : in out Key_Type; Value : in out Value_Type); -- OVERVIEW: -- Returns the entry having the smallest key greater than or equal -- to the value of the actual parameter KEY. KEY is modified in accordance. -- ERROR: -- The exception MISSING_ITEM_ERROR is raised if there is not such an -- entry in the table. In this case the values of the actual parameters KEY -- and VALUE are left unchanged. function Less_Key (Table : Table_Type; Key : Key_Type) return Key_Type; procedure Get_Less_Key (Table : Table_Type; Key : in out Key_Type); -- OVERVIEW: -- Gives the greatest key less than the value of the parameter KEY. -- ERROR: -- The exception MISSING_ITEM_ERROR is raised if there is not such an -- entry in the table. In this case the value of the actual parameter KEY -- is left unchanged. procedure Get_Less_Key (Table : Table_Type; Key : in out Key_Type; Found : out Boolean); -- OVERVIEW: -- Returns the greatest key less than the value of the actual -- parameter KEY. KEY is modified in accordance. FOUND is set to TRUE or -- FALSE depending on success of search. The value of the actual parameter -- KEY is left unchanged if FOUND is set to FALSE. function Less_Or_Equal_Key (Table : Table_Type; Key : Key_Type) return Key_Type; procedure Get_Less_Or_Equal_Key (Table : Table_Type; Key : in out Key_Type); -- OVERVIEW: -- Gives the greatest key less than or equal to the value of the -- parameter KEY. -- ERROR: -- The exception MISSING_ITEM_ERROR is raised if there is not such an -- entry in the table. In this case the value of the actual parameter KEY -- is left unchanged. procedure Get_Less_Or_Equal_Key (Table : Table_Type; Key : in out Key_Type; Found : out Boolean); -- OVERVIEW: -- Returns the greatest key less than or equal to the value of the -- actual parameter KEY. KEY is modified in accordance. FOUND is set to -- TRUE or FALSE depending on success of search. The value of the actual -- parameter KEY is left unchanged if FOUND is set to FALSE. function Greater_Key (Table : Table_Type; Key : Key_Type) return Key_Type; procedure Get_Greater_Key (Table : Table_Type; Key : in out Key_Type); -- OVERVIEW: -- Gives the smallest key greater than the value of the parameter -- KEY. -- ERROR: -- The exception MISSING_ITEM_ERROR is raised if there is not such an -- entry in the table. In this case the value of the actual parameter KEY -- is left unchanged. procedure Get_Greater_Key (Table : Table_Type; Key : in out Key_Type; Found : out Boolean); -- OVERVIEW: -- Returns the smallest key greater than the value of the actual -- parameter KEY. KEY is modified in accordance. FOUND is set to TRUE or -- FALSE depending on success of search. The value of the actual parameter -- KEY is left unchanged if FOUND is set to FALSE. function Greater_Or_Equal_Key (Table : Table_Type; Key : Key_Type) return Key_Type; procedure Get_Greater_Or_Equal_Key (Table : Table_Type; Key : in out Key_Type); -- OVERVIEW: -- Returns the smallest key greater than or equal to the value of -- the parameter KEY. -- ERROR: -- The exception MISSING_ITEM_ERROR is raised if there is not such an -- entry in the table. In this case the value of the actual parameter KEY -- is left unchanged. procedure Get_Greater_Or_Equal_Key (Table : Table_Type; Key : in out Key_Type; Found : out Boolean); -- OVERVIEW: -- Returns the smallest key greater than or equal to the value of -- the actual parameter KEY. KEY is modified in accordance. FOUND is set -- to TRUE or FALSE depending on success of search. The value of the actual -- parameter KEY is left unchanged if FOUND is set to FALSE. -- SET_OPERATIONS: generic package Set_Operations_G is procedure Union (Destination : in out Table_Type; Left, Right : Table_Type); -- OVERVIEW: -- Union of LEFT and RIGHT. If a key is both in LEFT and RIGHT, -- the value is taken from LEFT. procedure Intersection (Destination : in out Table_Type; Left, Right : Table_Type); -- OVERVIEW: -- Intersection of LEFT and RIGHT. The items are taken from LEFT. procedure Difference (Destination : in out Table_Type; Left, Right : Table_Type); -- OVERVIEW: -- Set difference of LEFT and RIGHT. An item is in the resulting table -- if it is in LEFT and if there is no item with same key in RIGHT. procedure Symmetric_Difference (Destination : in out Table_Type; Left, Right : Table_Type); -- OVERVIEW: -- Symmetric set difference of LEFT and RIGHT. An item is in the -- resulting table if it is in LEFT but there is no item with same key -- in RIGHT or if it is in RIGHT but there is no item with same key in -- LEFT. function "=" (Left, Right : Table_Type) return Boolean; -- OVERVIEW: -- Set equality; the LEFT and RIGHT tables contain entries with same -- keys. function "<" (Left, Right : Table_Type) return Boolean; -- OVERVIEW: -- Strict set inclusion; to each item in the LEFT table an item with -- same key is associated in the RIGHT table, but the two sets are not -- identical. function "<=" (Left, Right : Table_Type) return Boolean; -- OVERVIEW: -- Set inclusion; to each entry in the LEFT table an entry with same -- key is associated in the RIGHT table. function ">" (Left, Right : Table_Type) return Boolean; -- OVERVIEW: -- Strict set inclusion; to each entry in the RIGHT table an entry -- with same key is associated in the LEFT table, but the two sets are -- not identical. function ">=" (Left, Right : Table_Type) return Boolean; -- OVERVIEW: -- Set inclusion; to each entry in the RIGHT table an entry with same -- key is associated in the LEFT table. end Set_Operations_G; -- ITERATORS: generic with procedure Action (Key : Key_Type; Value : Value_Type; Order_Number : Positive; Continue : in out Boolean) is <>; procedure Traverse_Asc_G (Table : Table_Type); -- OVERVIEW: -- The entries in TABLE are visited in ascending order of their key -- values. Procedure ACTION is applied on each entry within TABLE. -- ORDER_NUMBER gives the position of the visited entry in order of -- traversal. The boolean CONTINUE specifies if you want to proceed to the -- next entry or if you want to stop traversing. As long as you do not -- modify its value within ACTION, its value remains TRUE. -- REQUIREMENT: -- For your actual procedure ACTION, you must not use a procedure -- which modifies the traversed table. generic with procedure Action (Key : Key_Type; Value : Value_Type; Order_Number : Positive; Continue : in out Boolean) is <>; procedure Traverse_Desc_G (Table : Table_Type); -- OVERVIEW: -- The entries in TABLE are visited in descending order of their key -- values. Procedure ACTION is applied on each entry within TABLE. -- ORDER_NUMBER gives the position of the visited entry in order of -- traversal. The boolean CONTINUE specifies if you want to proceed to the -- next entry or if you want to stop traversing. As long as you do not -- modify its value within ACTION, its value remains TRUE. -- REQUIREMENT: -- For your actual procedure ACTION, you must not use a procedure -- which modifies the traversed table. generic with procedure Modify (Key : Key_Type; Value : in out Value_Type; Order_Number : Positive; Continue : in out Boolean) is <>; procedure Traverse_Asc_And_Update_Value_G (Table : in out Table_Type); -- OVERVIEW: -- The entries in TABLE are visited in ascending order of their key -- values. For each visited entry, procedure MODIFY is called. The value of -- the current entry is then replaced by the new value. -- ORDER_NUMBER gives the position of the visited entry in order of -- traversal. The boolean CONTINUE specifies if you want to proceed to the -- next entry or if you want to stop traversing. As long as you do not -- modify its value within MODIFY, its value remains TRUE. -- REQUIREMENT: -- For your actual procedure MODIFY, you must not use a procedure which -- modifies the traversed table. generic with procedure Modify (Key : Key_Type; Value : in out Value_Type; Order_Number : Positive; Continue : in out Boolean) is <>; procedure Traverse_Desc_And_Update_Value_G (Table : in out Table_Type); -- OVERVIEW: -- The entries in TABLE are visited in descending order of their key -- values. For each visited entry, procedure MODIFY is called. The item -- value of the current entry is then replaced by the new value. -- ORDER_NUMBER gives the position of the visited entry in order of -- traversal. The boolean CONTINUE specifies if you want to proceed to the -- next entry or if you want to stop traversing. As long as you do not -- modify its value within MODIFY, its value remains TRUE. -- REQUIREMENT: -- For your actual procedure MODIFY, you must not use a procedure which -- modifies the traversed table. generic with procedure Action (Key : Key_Type; Value : Value_Type; Order_Number : Positive; Continue : in out Boolean) is <>; procedure Disorder_Traverse_G (Table : Table_Type); -- OVERVIEW: -- The entries in TABLE are visited in disorder of their key values. -- procedure ACTION is applied on each entry within TABLE. -- ORDER_NUMBER gives the position of the visited entry in order of -- traversal. The boolean CONTINUE specifies if you want to proceed to the -- next entry or if you want to stop traversing. As long as you do not -- modify its value within ACTION, its value remains TRUE. -- Traversal by DISORDER_TRAVERSE_G is faster than by TRAVERSE_ASC_G or -- TRAVERSE_DESC_G. Moreover, use of the generic procedure -- DISORDER_TRAVERSE_G is recommended for saving a table in a backstore -- (file or linear list) because recovery will be efficient. -- REQUIREMENT: -- For your actual procedure ACTION, you must not use a procedure -- which modifies the traversed table. generic with procedure Modify (Key : Key_Type; Value : in out Value_Type; Order_Number : Positive; Continue : in out Boolean) is <>; procedure Disorder_Traverse_And_Update_Value_G (Table : in out Table_Type); -- OVERVIEW: -- The entries in TABLE are visited in disorder of their key values. -- procedure MODIFY is applied on each entry within TABLE. The item -- value of the current entry is then replaced by the new value. -- ORDER_NUMBER gives the position of the visited entry in order of -- traversal. The boolean CONTINUE specifies if you want to proceed to the -- next entry or if you want to stop traversing. As long as you do not -- modify its value within MODIFY, its value remains TRUE. -- Traversal by DISORDER_TRAVERSE_G is faster than by TRAVERSE_ASC_G or -- TRAVERSE_DESC_G. -- REQUIREMENT: -- For your actual procedure MODIFY, you must not use a procedure -- which modifies the traversed table. -- HEAP MANAGEMENT: procedure Destroy (Table : in out Table_Type); -- OVERVIEW: -- Empties the TABLE and returns space to the free list. procedure Release_Free_List; -- OVERVIEW: -- Releases all items from the free list giving their space back to the -- system. procedure Set_Max_Free_List_Size (Max_Free_List_Size : Natural); -- OVERVIEW: -- Sets the maximum length of the internal free list which is 0 by -- default. -- If parameter MAX_FREE_LIST_SIZE is smaller than the current size -- of the list, the items in excess are returned to the system. function Free_List_Size return Natural; -- OVERVIEW: -- Returns the actual length of the internal free list. private type Equilibrium_Type is range -1 .. 1; type Cell_Type; type Link_Type is access Cell_Type; type Cell_Type is record Balance : Equilibrium_Type := 0; -- always equal to HEIGHT(RIGHT)-HEIGHT(LEFT) Left : Link_Type; Right : Link_Type; -- Is also used for linking within the free list Key : Key_Type; Value : Value_Type; end record; type Table_Type is record Root : Link_Type; Count : Natural := 0; Connect_Predecessor : Boolean := True; -- Used to connect alternatively the predecessor or successor when -- deleting a node. Is provided for optimization. end record; end Table_Of_Static_Keys_And_Dynamic_Values_G; polyorb-2.8~20110207.orig/src/aws_orig/templates_parser-data.adb0000644000175000017500000001125111750740337023742 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- D A T A -- -- -- -- B o d y -- -- -- -- Copyright (C) 1999-2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with Ada.Text_IO; separate (Templates_Parser) package body Data is ----------- -- Parse -- ----------- function Parse (Line : String) return Tree is Begin_Tag : constant String := To_String (Templates_Parser.Begin_Tag); End_Tag : constant String := To_String (Templates_Parser.End_Tag); function Build (Line : String) return Tree; -- Recursive function to build the tree ----------- -- Build -- ----------- function Build (Line : String) return Tree is Start, Stop : Natural; begin if Line = "" then return null; else Start := Strings.Fixed.Index (Line, Begin_Tag); if Start = 0 then -- No more tag return new Node'(Text, null, To_Unbounded_String (Line)); else Stop := Strings.Fixed.Index (Line, End_Tag); if Stop = 0 then Exceptions.Raise_Exception (Internal_Error'Identity, "Tag variable not terminated (missing " & End_Tag & ")"); else Stop := Stop + End_Tag'Length - 1; if Start = Line'First then return new Node' (Var, Build (Line (Stop + 1 .. Line'Last)), Build (Line (Start .. Stop))); else return new Node' (Text, Build (Line (Start .. Line'Last)), To_Unbounded_String (Line (Line'First .. Start - 1))); end if; end if; end if; end if; end Build; begin return Build (Line); end Parse; ---------------- -- Print_Tree -- ---------------- procedure Print_Tree (D : Tree) is begin if D = null then return; end if; case D.Kind is when Text => Text_IO.Put (To_String (D.Value)); when Var => Text_IO.Put (Image (D.Var)); end case; Print_Tree (D.Next); end Print_Tree; ------------- -- Release -- ------------- procedure Release (D : in out Tree) is procedure Free is new Ada.Unchecked_Deallocation (Node, Tree); P : Tree; T : Tree := D; begin while T /= null loop P := T; T := T.Next; if P.Kind = Var then Release (P.Var); end if; Free (P); end loop; end Release; end Data; polyorb-2.8~20110207.orig/src/aws_orig/templates_parser-cached_files.adb0000644000175000017500000002036411750740337025427 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- C A C H E D _ F I L E S -- -- -- -- B o d y -- -- -- -- Copyright (C) 1999-2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ separate (Templates_Parser) package body Cached_Files is Initial_Size : constant := 20; -- cache initial size Growing_Size : constant := 50; -- cache growing size type File_Array is array (Positive range <>) of Tree; type File_Array_Access is access File_Array; Files : File_Array_Access; Index : Natural := 0; procedure Growth; -- Growth the size (by Growing_Size places) of Files array. function Get (Filename : String) return Natural; -- Look for Filename into the set and return its index. Returns 0 if -- filename was not found. function Up_To_Date (T : Tree) return Boolean; -- Returns True if the file tree is up to date (the templates files -- have not been modified on disk) or False otherwise. protected body Prot is --------- -- Add -- --------- procedure Add (Filename : String; T : Tree; Old : out Tree) is L_Filename : constant Unbounded_String := To_Unbounded_String (Filename); S : Natural := 1; E : Natural := Index; N : Natural; begin -- Does the table initialized and do we have enough place on it ? if Files = null or else Index = Files'Last then Growth; end if; loop exit when S > E; N := (S + E) / 2; if Files (N).Filename = L_Filename then -- This is a file that was already loaded. If loaded again -- it is because the file timestamp has changed. We want to -- just update the tree and not the info node. Old := Files (N).Next; -- This is a pointer to the C_Info tree node, skipping the -- info node (first node). Files (N).Next := T.Next; Files (N).Timestamp := T.Timestamp; -- This part is tricky, the tree could be currently used -- (parsed). So we need to be careful to not release the tree -- too early. if Old.Used = 0 then -- File is not currently used, we can release it safely. Release (Old); Old := T.Next; else -- Tree is used, mark it as obsoleted, it will be removed -- when no more used by the Prot.Release call. Old.Used := Old.Used + 1; Old.Obsolete := True; -- But current tree is not used, it has been posted here -- for futur used. But if replaced right away it should be -- freed. Files (N).Next.Used := 0; end if; -- Nothing more to do in this case. return; elsif Files (N).Filename < L_Filename then S := N + 1; else E := N - 1; end if; end loop; -- Filename was not found, insert it in the array at position S Files (S + 1 .. Index + 1) := Files (S .. Index); Index := Index + 1; Files (S) := T; Old := T.Next; -- Old point to the current C_Info tree. end Add; --------- -- Get -- --------- procedure Get (Filename : String; Load : Boolean; Result : out Static_Tree) is N : constant Natural := Get (Filename); begin if N = 0 then Result := (null, null); else if Load then Files (N).Ref := Files (N).Ref + 1; end if; Files (N).Next.Used := Files (N).Next.Used + 1; Result := (Files (N), Files (N).Next); end if; end Get; ------------- -- Release -- ------------- procedure Release (T : in out Static_Tree) is begin pragma Assert (T.C_Info /= null); T.C_Info.Used := T.C_Info.Used - 1; if T.C_Info.Obsolete and then T.C_Info.Used = 0 then pragma Assert (T.Info.Next /= T.C_Info); Release (T.C_Info); end if; end Release; end Prot; --------- -- Get -- --------- function Get (Filename : String) return Natural is use type GNAT.OS_Lib.OS_Time; L_Filename : constant Unbounded_String := To_Unbounded_String (Filename); S : Natural := 1; E : Natural := Index; N : Natural; begin loop exit when S > E; N := (S + E) / 2; if Files (N).Filename = L_Filename then if Up_To_Date (Files (N)) then return N; else -- File has changed on disk, we need to read it again. Just -- pretend that the file was not found. return 0; end if; elsif Files (N).Filename < L_Filename then S := N + 1; else E := N - 1; end if; end loop; return 0; end Get; ------------ -- Growth -- ------------ procedure Growth is procedure Free is new Ada.Unchecked_Deallocation (File_Array, File_Array_Access); begin if Files = null then Files := new File_Array (1 .. Initial_Size); else declare New_Array : File_Array_Access; begin New_Array := new File_Array (1 .. Files'Length + Growing_Size); New_Array (1 .. Files'Length) := Files.all; Free (Files); Files := New_Array; end; end if; end Growth; ---------------- -- Up_To_Date -- ---------------- function Up_To_Date (T : Tree) return Boolean is use GNAT; use type GNAT.OS_Lib.OS_Time; P : Tree; begin -- Check main file if OS_Lib.File_Time_Stamp (To_String (T.Filename)) /= T.Timestamp then return False; end if; -- Check all include files P := T.I_File; while P /= null loop if OS_Lib.File_Time_Stamp (To_String (P.File.Info.Filename)) /= P.File.Info.Timestamp then return False; end if; P := P.Next; end loop; return True; end Up_To_Date; end Cached_Files; polyorb-2.8~20110207.orig/src/aws_orig/aws-digest.ads0000644000175000017500000000553411750740337021560 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- A W S . D I G E S T -- -- -- -- S p e c -- -- -- -- Copyright (C) 2000-2007, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- Some utilities for http digest authentication. with MD5; pragma Elaborate_All (MD5); package AWS.Digest is subtype Digest_String is MD5.Digest_String; function Create_Nonce return String; -- Create a Nonce value for the digest authentication -- see [RFC-2617 - 3.2.1] function Check_Nonce (Value : String) return Boolean; -- Check Nonce for validity and expiration. function Create_Digest (Username, Realm, Password : String; Nonce : String; Method, URI : String) return Digest_String; -- Returns a simple MD5 Digest. function Create_Digest (Username, Realm, Password : String; Nonce, NC, CNonce, QOP : String; Method, URI : String) return Digest_String; -- Returns a more complex MD5 Digest. end AWS.Digest; polyorb-2.8~20110207.orig/src/aws_orig/aws-os_lib.adb0000644000175000017500000001117711750740337021527 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- A W S . O S _ L I B -- -- -- -- B o d y -- -- -- -- Copyright (C) 2000-2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- Use the OS support routines in GNAT.OS_Lib instead of the POSIX library -- and get the current UTC/GMT time from the C library. -- @@@ uses ada.calendar with GNAT.OS_Lib; package body AWS.OS_Lib is function OS_Time_To_Calendar_Time (UTC : GNAT.OS_Lib.OS_Time) return Ada.Calendar.Time; -- Returns a Calendar.Time from an OS_Time variable. ------------------ -- Is_Directory -- ------------------ function Is_Directory (Filename : String) return Boolean renames GNAT.OS_Lib.Is_Directory; --------------------- -- Is_Regular_File -- --------------------- function Is_Regular_File (Filename : String) return Boolean renames GNAT.OS_Lib.Is_Regular_File; --------------- -- File_Size -- --------------- function File_Size (Filename : String) return Ada.Streams.Stream_Element_Offset is use GNAT.OS_Lib; Name : String := Filename & ASCII.NUL; FD : File_Descriptor; Length : Ada.Streams.Stream_Element_Offset := 0; begin FD := Open_Read (Name'Address, Binary); if FD /= Invalid_FD then Length := Ada.Streams.Stream_Element_Offset (File_Length (FD)); Close (FD); return Length; end if; raise No_Such_File; end File_Size; -------------------- -- File_Timestamp -- -------------------- function File_Timestamp (Filename : String) return Ada.Calendar.Time is begin return OS_Time_To_Calendar_Time (GNAT.OS_Lib.File_Time_Stamp (Filename)); exception when others => raise No_Such_File; end File_Timestamp; --------------- -- GMT_Clock -- --------------- function GMT_Clock return Ada.Calendar.Time is type OS_Time_A is access all GNAT.OS_Lib.OS_Time; function C_Time (Time : OS_Time_A) return GNAT.OS_Lib.OS_Time; pragma Import (C, C_Time, "time"); begin return OS_Time_To_Calendar_Time (C_Time (null)); end GMT_Clock; ------------------------------ -- OS_Time_To_Calendar_Time -- ------------------------------ function OS_Time_To_Calendar_Time (UTC : GNAT.OS_Lib.OS_Time) return Ada.Calendar.Time is Year : Integer; Month : Integer; Day : Integer; Hour : Integer; Minute : Integer; Second : Integer; begin GNAT.OS_Lib.GM_Split (UTC, Year, Month, Day, Hour, Minute, Second); return Ada.Calendar.Time_Of (Year, Month, Day, Duration (Hour * 3600 + Minute * 60 + Second)); end OS_Time_To_Calendar_Time; end AWS.OS_Lib; polyorb-2.8~20110207.orig/src/aws_orig/aws-resources.ads0000644000175000017500000001115011750740337022302 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- A W S . R E S O U R C E S -- -- -- -- S p e c -- -- -- -- Copyright (C) 2002-2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- @@@ uses ada.calendar with Ada.Calendar; with Ada.Streams; package AWS.Resources is use Ada.Streams; Resource_Error : exception; type File_Type is limited private; procedure Open (File : out File_Type; Name : String; Form : String := ""); -- Open file in mode In_File. Only reading from the file is supported. -- This procedure open the in-memory file if present, otherwise the file -- on disk is opened. procedure Close (Resource : in out File_Type); -- Close the file. procedure Read (Resource : in out File_Type; Buffer : out Stream_Element_Array; Last : out Stream_Element_Offset); -- Returns a set of bytes from the file. procedure Get_Line (Resource : in out File_Type; Buffer : out String; Last : out Natural); -- Returns a line from the file. A line is a set of character terminated -- by ASCII.LF (UNIX style EOF) or ASCII.CR+ASCII.LF (DOS style EOF). function End_Of_File (Resource : File_Type) return Boolean; -- Returns true if there is no more data to read. function LF_Terminated (Resource : File_Type) return Boolean; -- Returns True if last line returned by Get_Line was terminated with a LF -- or CR+LF on DOS based systems. function Is_Regular_File (Name : String) return Boolean; -- Returns True if Filename is a regular file and is readable. Checks first -- for in memory file then for disk file. function File_Size (Name : String) return Ada.Streams.Stream_Element_Offset; -- Returns Filename's size in bytes. Checks first for in memory file -- then for disk file. function File_Timestamp (Name : String) return Ada.Calendar.Time; -- Get the time for last modification to a file in UTC/GMT. Checks first -- for in memory file then for disk file. private type File_Tagged is abstract tagged limited record LFT : Boolean; -- LF terminated state end record; -- Abstract file, operations below must be implemented. The goal here is -- to abstract the file location. Currently there is two implementations, -- one for files on a hard disk and files in memory (array of bytes). type File_Type is access all File_Tagged'Class; function End_Of_File (Resource : File_Tagged) return Boolean is abstract; procedure Read (Resource : in out File_Tagged; Buffer : out Stream_Element_Array; Last : out Stream_Element_Offset) is abstract; procedure Close (File : in out File_Tagged) is abstract; end AWS.Resources; polyorb-2.8~20110207.orig/src/aws_orig/aws-resources.adb0000644000175000017500000001273611750740337022274 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- A W S . R E S O U R C E S -- -- -- -- B o d y -- -- -- -- Copyright (C) 2002-2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- @@@ uses ada.calendar with Ada.Unchecked_Deallocation; with AWS.Resources.Files; with AWS.Resources.Embedded; package body AWS.Resources is use Ada; procedure Free is new Ada.Unchecked_Deallocation (Resources.File_Tagged'Class, File_Type); ----------- -- Close -- ----------- procedure Close (Resource : in out File_Type) is begin Close (Resource.all); Free (Resource); end Close; ----------------- -- End_Of_File -- ----------------- function End_Of_File (Resource : File_Type) return Boolean is begin return End_Of_File (Resource.all); end End_Of_File; --------------- -- File_Size -- --------------- function File_Size (Name : String) return Ada.Streams.Stream_Element_Offset is begin if Resources.Embedded.Exists (Name) then return Resources.Embedded.File_Size (Name); else return Resources.Files.File_Size (Name); end if; end File_Size; -------------------- -- File_Timestamp -- -------------------- function File_Timestamp (Name : String) return Ada.Calendar.Time is begin if Resources.Embedded.Exists (Name) then return Resources.Embedded.File_Timestamp (Name); else return Resources.Files.File_Timestamp (Name); end if; end File_Timestamp; -------------- -- Get_Line -- -------------- procedure Get_Line (Resource : in out File_Type; Buffer : out String; Last : out Natural) is Byte : Stream_Element_Array (1 .. 1); Last_Ind : Stream_Element_Offset; begin Last := 0; Resource.LFT := False; for I in Buffer'Range loop Read (Resource.all, Byte, Last_Ind); exit when Last_Ind < Byte'Last; Buffer (I) := Character'Val (Byte (1)); -- Check for end of line if Buffer (I) = ASCII.LF then -- This is LF if I > Buffer'First and then Buffer (I - 1) = ASCII.CR then -- And previous char was a CR, skip it Last := Last - 1; end if; Resource.LFT := True; exit; end if; Last := Last + 1; end loop; end Get_Line; --------------------- -- Is_Regular_File -- --------------------- function Is_Regular_File (Name : String) return Boolean is begin if Resources.Embedded.Exists (Name) then return Resources.Embedded.Is_Regular_File (Name); else return Resources.Files.Is_Regular_File (Name); end if; end Is_Regular_File; ------------------- -- LF_Terminated -- ------------------- function LF_Terminated (Resource : File_Type) return Boolean is begin return Resource.all.LFT; end LF_Terminated; ---------- -- Open -- ---------- procedure Open (File : out File_Type; Name : String; Form : String := "") is begin -- Try to open the file in memory, if not found open the file on disk. Resources.Embedded.Open (File, Name, Form); if File = null then Resources.Files.Open (File, Name, Form); end if; end Open; ---------- -- Read -- ---------- procedure Read (Resource : in out File_Type; Buffer : out Stream_Element_Array; Last : out Stream_Element_Offset) is begin Read (Resource.all, Buffer, Last); end Read; end AWS.Resources; polyorb-2.8~20110207.orig/src/aws_orig/table_of_strings_and_static_values_g.adb0000644000175000017500000007505511750740337027077 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- TABLE_OF_STRINGS_AND_STATIC_VALUES_G -- -- -- -- B o d y -- -- -- -- Copyright (C) 2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- TITLE: GENERIC PACKAGE FOR TABLES OF STRINGS ASSOCIATED WITH VALUES. -- REVISION: 13-JUL-1992 Ph. Kipfer (PKR), File header format -- APPROVAL: 03-DEC-1987 C. Genillard. -- CREATION: 13-AUG-1987 A. Strohmeier. with Unchecked_Deallocation; package body Table_Of_Strings_And_Static_Values_G is -- LOCAL SUBPROGRAM: function Create (Key : String_Type) return Access_String_Type; function Create (Key : String_Type) return Access_String_Type is begin return new String_Type'(Key); end Create; pragma Inline (Create); -- LOCAL SUBPROGRAM: function Less (Left, Right : Access_String_Type) return Boolean is -- Hint: An ACCESS_STRING_TYPE object has never value null. begin return Less (Left.all, Right.all); end Less; -- LOCAL SUBPROGRAM: function Equals (Left, Right : Access_String_Type) return Boolean is -- Hint : An ACCESS_STRING_TYPE object has never value null. begin return Equals (Left.all, Right.all); end Equals; -- LOCAL SUBPROGRAM: procedure Assign (Destination : in out Access_String_Type; Source : Access_String_Type) is begin if Destination = Source then return; end if; Destroy (Destination); Destination := Create (Source.all); end Assign; -- LOCAL SUBPROGRAM: procedure Dispose is new Unchecked_Deallocation (Object => String_Type, Name => Access_String_Type); pragma Inline (Dispose); -- LOCAL SUBPROGRAM: procedure Destroy (Access_String : in out Access_String_Type) is begin Dispose (Access_String); end Destroy; -- CONSTRUCTORS: procedure Assign (Destination : in out Table_Type; Source : Table_Type) is begin Local_Package.Assign (Local_Package.Table_Type (Destination), Local_Package.Table_Type (Source)); end Assign; procedure Insert (Table : in out Table_Type; Key : String_Type; Value : Value_Type) is Access_String : Access_String_Type := Create (Key); begin Local_Package.Insert (Local_Package.Table_Type (Table), Access_String, Value); Destroy (Access_String); exception when Local_Package.Duplicate_Item_Error => Destroy (Access_String); raise Duplicate_Item_Error; end Insert; procedure Insert (Table : in out Table_Type; Key : String_Type; Value : Value_Type; Duplicate_Item : out Boolean) is Access_String : Access_String_Type := Create (Key); begin Local_Package.Insert (Local_Package.Table_Type (Table), Access_String, Value, Duplicate_Item); Destroy (Access_String); end Insert; procedure Insert_Or_Replace_Value (Table : in out Table_Type; Key : String_Type; Value : Value_Type) is Access_String : Access_String_Type := Create (Key); begin Local_Package.Insert_Or_Replace_Value (Local_Package.Table_Type (Table), Access_String, Value); Destroy (Access_String); end Insert_Or_Replace_Value; procedure Replace_Value (Table : in out Table_Type; Key : String_Type; Value : Value_Type) is Access_String : Access_String_Type := Create (Key); begin Local_Package.Replace_Value (Local_Package.Table_Type (Table), Access_String, Value); Destroy (Access_String); exception when Local_Package.Missing_Item_Error => Destroy (Access_String); raise Missing_Item_Error; end Replace_Value; procedure Replace_Value (Table : in out Table_Type; Key : String_Type; Value : Value_Type; Found : out Boolean) is Access_String : Access_String_Type := Create (Key); begin Local_Package.Replace_Value (Local_Package.Table_Type (Table), Access_String, Value, Found); Destroy (Access_String); end Replace_Value; procedure Remove (Table : in out Table_Type; Key : String_Type) is Access_String : Access_String_Type := Create (Key); begin Local_Package.Remove (Local_Package.Table_Type (Table), Access_String); Destroy (Access_String); exception when Local_Package.Missing_Item_Error => Destroy (Access_String); raise Missing_Item_Error; end Remove; procedure Remove (Table : in out Table_Type; Key : String_Type; Value : out Value_Type) is Access_String : Access_String_Type := Create (Key); begin Local_Package.Remove (Local_Package.Table_Type (Table), Access_String, Value); Destroy (Access_String); exception when Local_Package.Missing_Item_Error => Destroy (Access_String); raise Missing_Item_Error; end Remove; procedure Remove (Table : in out Table_Type; Key : String_Type; Found : out Boolean) is Access_String : Access_String_Type := Create (Key); begin Local_Package.Remove (Local_Package.Table_Type (Table), Access_String, Found); Destroy (Access_String); end Remove; procedure Remove_Min (Table : in out Table_Type) is begin Local_Package.Remove_Min (Local_Package.Table_Type (Table)); exception when Local_Package.Missing_Item_Error => raise Missing_Item_Error; when Local_Package.Empty_Structure_Error => raise Empty_Structure_Error; end Remove_Min; procedure Remove_Max (Table : in out Table_Type) is begin Local_Package.Remove_Max (Local_Package.Table_Type (Table)); exception when Local_Package.Missing_Item_Error => raise Missing_Item_Error; when Local_Package.Empty_Structure_Error => raise Empty_Structure_Error; end Remove_Max; procedure Update_Value_Or_Exception_G (Table : in out Table_Type; Key : String_Type) is Access_String : Access_String_Type := Create (Key); procedure Local (Key : Access_String_Type; Value : in out Value_Type); procedure Local (Key : Access_String_Type; Value : in out Value_Type) is begin Modify (Key.all, Value); end Local; procedure Local_Update is new Local_Package.Update_Value_Or_Exception_G (Local); begin Local_Update (Local_Package.Table_Type (Table), Access_String); Destroy (Access_String); exception when Local_Package.Missing_Item_Error => Destroy (Access_String); raise Missing_Item_Error; end Update_Value_Or_Exception_G; procedure Update_Value_Or_Status_G (Table : in out Table_Type; Key : String_Type; Found : out Boolean) is Access_String : Access_String_Type := Create (Key); procedure Local (Key : Access_String_Type; Value : in out Value_Type); procedure Local (Key : Access_String_Type; Value : in out Value_Type) is begin Modify (Key.all, Value); end Local; procedure Local_Update is new Local_Package.Update_Value_Or_Status_G (Local); begin Local_Update (Local_Package.Table_Type (Table), Access_String, Found); Destroy (Access_String); end Update_Value_Or_Status_G; -- QUERIES: function Size (Table : Table_Type) return Natural is begin return Local_Package.Size (Local_Package.Table_Type (Table)); end Size; function Is_Empty (Table : Table_Type) return Boolean is begin return Local_Package.Is_Empty (Local_Package.Table_Type (Table)); end Is_Empty; function Is_Present (Table : Table_Type; Key : String_Type) return Boolean is Access_String : Access_String_Type := Create (Key); Found : Boolean; begin Found := Local_Package.Is_Present (Local_Package.Table_Type (Table), Access_String); Destroy (Access_String); return Found; end Is_Present; function Value (Table : Table_Type; Key : String_Type) return Value_Type is Access_String : Access_String_Type := Create (Key); Value : Value_Type; begin Local_Package.Get_Value (Local_Package.Table_Type (Table), Access_String, Value); Destroy (Access_String); return Value; exception when Local_Package.Missing_Item_Error => Destroy (Access_String); raise Missing_Item_Error; end Value; procedure Get_Value (Table : Table_Type; Key : String_Type; Value : out Value_Type) is Access_String : Access_String_Type := Create (Key); begin Local_Package.Get_Value (Local_Package.Table_Type (Table), Access_String, Value); Destroy (Access_String); exception when Local_Package.Missing_Item_Error => Destroy (Access_String); raise Missing_Item_Error; end Get_Value; -- LOCAL SUBPROGRAM: procedure Copy (To : out String_Type; Last : out Natural; From : in out Access_String_Type); procedure Copy (To : out String_Type; Last : out Natural; From : in out Access_String_Type) is Local_Last : Natural; begin if To'Length < From.all'Length then Last := To'First - 1; Destroy (From); raise String_Constraint_Error; else Local_Last := To'First + From.all'Length - 1; Last := Local_Last; To (To'First .. Local_Last) := From.all; Destroy (From); end if; end Copy; procedure Get_Min_Item (Table : Table_Type; Key : out String_Type; Last : out Natural; Value : out Value_Type) is Access_String : Access_String_Type; begin Local_Package.Get_Min_Item (Local_Package.Table_Type (Table), Access_String, Value); Copy (Key, Last, Access_String); exception when Local_Package.Empty_Structure_Error => raise Empty_Structure_Error; end Get_Min_Item; procedure Get_Max_Item (Table : Table_Type; Key : out String_Type; Last : out Natural; Value : out Value_Type) is Access_String : Access_String_Type; begin Local_Package.Get_Max_Item (Local_Package.Table_Type (Table), Access_String, Value); Copy (Key, Last, Access_String); exception when Local_Package.Empty_Structure_Error => raise Empty_Structure_Error; end Get_Max_Item; function Min_Key (Table : Table_Type) return String_Type is begin return Local_Package.Min_Key (Local_Package.Table_Type (Table)).all; exception when Local_Package.Empty_Structure_Error => raise Empty_Structure_Error; end Min_Key; procedure Get_Min_Key (Table : Table_Type; Key : out String_Type; Last : out Natural) is Access_String : Access_String_Type; begin Local_Package.Get_Min_Key (Local_Package.Table_Type (Table), Access_String); Copy (Key, Last, Access_String); exception when Local_Package.Empty_Structure_Error => raise Empty_Structure_Error; end Get_Min_Key; function Max_Key (Table : Table_Type) return String_Type is begin return Local_Package.Max_Key (Local_Package.Table_Type (Table)).all; exception when Local_Package.Empty_Structure_Error => raise Empty_Structure_Error; end Max_Key; procedure Get_Max_Key (Table : Table_Type; Key : out String_Type; Last : out Natural) is Access_String : Access_String_Type; begin Local_Package.Get_Max_Key (Local_Package.Table_Type (Table), Access_String); Copy (Key, Last, Access_String); exception when Local_Package.Empty_Structure_Error => raise Empty_Structure_Error; end Get_Max_Key; procedure Get_Less_Item (Table : Table_Type; Key_In : String_Type; Key_Out : out String_Type; Last : out Natural; Value : out Value_Type) is Access_String : Access_String_Type := Create (Key_In); begin Local_Package.Get_Less_Item (Local_Package.Table_Type (Table), Access_String, Value); Copy (Key_Out, Last, Access_String); exception when Local_Package.Missing_Item_Error => Destroy (Access_String); raise Missing_Item_Error; end Get_Less_Item; procedure Get_Less_Or_Equal_Item (Table : Table_Type; Key_In : String_Type; Key_Out : out String_Type; Last : out Natural; Value : out Value_Type) is Access_String : Access_String_Type := Create (Key_In); begin Local_Package.Get_Less_Or_Equal_Item (Local_Package.Table_Type (Table), Access_String, Value); Copy (Key_Out, Last, Access_String); exception when Local_Package.Missing_Item_Error => Destroy (Access_String); raise Missing_Item_Error; end Get_Less_Or_Equal_Item; procedure Get_Greater_Item (Table : Table_Type; Key_In : String_Type; Key_Out : out String_Type; Last : out Natural; Value : out Value_Type) is Access_String : Access_String_Type := Create (Key_In); begin Local_Package.Get_Greater_Item (Local_Package.Table_Type (Table), Access_String, Value); Copy (Key_Out, Last, Access_String); exception when Local_Package.Missing_Item_Error => Destroy (Access_String); raise Missing_Item_Error; end Get_Greater_Item; procedure Get_Greater_Or_Equal_Item (Table : Table_Type; Key_In : String_Type; Key_Out : out String_Type; Last : out Natural; Value : out Value_Type) is Access_String : Access_String_Type := Create (Key_In); begin Local_Package.Get_Greater_Or_Equal_Item (Local_Package.Table_Type (Table), Access_String, Value); Copy (Key_Out, Last, Access_String); exception when Local_Package.Missing_Item_Error => Destroy (Access_String); raise Missing_Item_Error; end Get_Greater_Or_Equal_Item; function Less_Key (Table : Table_Type; Key : String_Type) return String_Type is Access_String : Access_String_Type := Create (Key); begin Local_Package.Get_Less_Key (Local_Package.Table_Type (Table), Access_String); declare -- STR: constant String_type := ACCESS_STRING.all; Str : constant String_Type (1 .. Access_String.all'Length) := Access_String.all; begin Destroy (Access_String); return Str; end; exception when Local_Package.Missing_Item_Error => Destroy (Access_String); raise Missing_Item_Error; end Less_Key; procedure Get_Less_Key (Table : Table_Type; Key_In : String_Type; Key_Out : out String_Type; Last : out Natural) is Access_String : Access_String_Type := Create (Key_In); begin Local_Package.Get_Less_Key (Local_Package.Table_Type (Table), Access_String); Copy (Key_Out, Last, Access_String); exception when Local_Package.Missing_Item_Error => Destroy (Access_String); raise Missing_Item_Error; end Get_Less_Key; function Less_Or_Equal_Key (Table : Table_Type; Key : String_Type) return String_Type is Access_String : Access_String_Type := Create (Key); begin Local_Package.Get_Less_Or_Equal_Key (Local_Package.Table_Type (Table), Access_String); declare -- STR: constant String_type := ACCESS_STRING.all; Str : constant String_Type (1 .. Access_String.all'Length) := Access_String.all; begin Destroy (Access_String); return Str; end; exception when Local_Package.Missing_Item_Error => Destroy (Access_String); raise Missing_Item_Error; end Less_Or_Equal_Key; procedure Get_Less_Or_Equal_Key (Table : Table_Type; Key_In : String_Type; Key_Out : out String_Type; Last : out Natural) is Access_String : Access_String_Type := Create (Key_In); begin Local_Package.Get_Less_Or_Equal_Key (Local_Package.Table_Type (Table), Access_String); Copy (Key_Out, Last, Access_String); exception when Local_Package.Missing_Item_Error => Destroy (Access_String); raise Missing_Item_Error; end Get_Less_Or_Equal_Key; function Greater_Key (Table : Table_Type; Key : String_Type) return String_Type is Access_String : Access_String_Type := Create (Key); begin Local_Package.Get_Greater_Key (Local_Package.Table_Type (Table), Access_String); declare -- STR: constant String_type := ACCESS_STRING.all; Str : constant String_Type (1 .. Access_String.all'Length) := Access_String.all; begin Destroy (Access_String); return Str; end; exception when Local_Package.Missing_Item_Error => Destroy (Access_String); raise Missing_Item_Error; end Greater_Key; procedure Get_Greater_Key (Table : Table_Type; Key_In : String_Type; Key_Out : out String_Type; Last : out Natural) is Access_String : Access_String_Type := Create (Key_In); begin Local_Package.Get_Greater_Key (Local_Package.Table_Type (Table), Access_String); Copy (Key_Out, Last, Access_String); exception when Local_Package.Missing_Item_Error => Destroy (Access_String); raise Missing_Item_Error; end Get_Greater_Key; function Greater_Or_Equal_Key (Table : Table_Type; Key : String_Type) return String_Type is Access_String : Access_String_Type := Create (Key); begin Local_Package.Get_Greater_Or_Equal_Key (Local_Package.Table_Type (Table), Access_String); declare -- STR: constant String_type := ACCESS_STRING.all; Str : constant String_Type (1 .. Access_String.all'Length) := Access_String.all; begin Destroy (Access_String); return Str; end; exception when Local_Package.Missing_Item_Error => Destroy (Access_String); raise Missing_Item_Error; end Greater_Or_Equal_Key; procedure Get_Greater_Or_Equal_Key (Table : Table_Type; Key_In : String_Type; Key_Out : out String_Type; Last : out Natural) is Access_String : Access_String_Type := Create (Key_In); begin Local_Package.Get_Greater_Or_Equal_Key (Local_Package.Table_Type (Table), Access_String); Copy (Key_Out, Last, Access_String); exception when Local_Package.Missing_Item_Error => Destroy (Access_String); raise Missing_Item_Error; end Get_Greater_Or_Equal_Key; -- SET_OPERATIONS: package body Set_Operations_G is package Instance is new Local_Package.Set_Operations_G; procedure Union (Destination : in out Table_Type; Left, Right : Table_Type) is begin Instance.Union (Local_Package.Table_Type (Destination), Local_Package.Table_Type (Left), Local_Package.Table_Type (Right)); end Union; procedure Intersection (Destination : in out Table_Type; Left, Right : Table_Type) is begin Instance.Intersection (Local_Package.Table_Type (Destination), Local_Package.Table_Type (Left), Local_Package.Table_Type (Right)); end Intersection; procedure Difference (Destination : in out Table_Type; Left, Right : Table_Type) is begin Instance.Difference (Local_Package.Table_Type (Destination), Local_Package.Table_Type (Left), Local_Package.Table_Type (Right)); end Difference; procedure Symmetric_Difference (Destination : in out Table_Type; Left, Right : Table_Type) is begin Instance.Symmetric_Difference (Local_Package.Table_Type (Destination), Local_Package.Table_Type (Left), Local_Package.Table_Type (Right)); end Symmetric_Difference; function "=" (Left, Right : Table_Type) return Boolean is begin return Instance."=" (Local_Package.Table_Type (Left), Local_Package.Table_Type (Right)); end "="; function "<" (Left, Right : Table_Type) return Boolean is begin return Instance."<" (Local_Package.Table_Type (Left), Local_Package.Table_Type (Right)); end "<"; function "<=" (Left, Right : Table_Type) return Boolean is begin return Instance."<=" (Local_Package.Table_Type (Left), Local_Package.Table_Type (Right)); end "<="; function ">" (Left, Right : Table_Type) return Boolean is begin return Instance.">" (Local_Package.Table_Type (Left), Local_Package.Table_Type (Right)); end ">"; function ">=" (Left, Right : Table_Type) return Boolean is begin return Instance.">=" (Local_Package.Table_Type (Left), Local_Package.Table_Type (Right)); end ">="; end Set_Operations_G; -- ITERATORS: procedure Traverse_Asc_G (Table : Table_Type) is procedure Local (Key : Access_String_Type; Value : Value_Type; Order_Number : Positive; Continue : in out Boolean); procedure Local (Key : Access_String_Type; Value : Value_Type; Order_Number : Positive; Continue : in out Boolean) is begin Action (Key.all, Value, Order_Number, Continue); end Local; procedure Traverse is new Local_Package.Traverse_Asc_G (Local); begin Traverse (Local_Package.Table_Type (Table)); end Traverse_Asc_G; procedure Traverse_Desc_G (Table : Table_Type) is procedure Local (Key : Access_String_Type; Value : Value_Type; Order_Number : Positive; Continue : in out Boolean); procedure Local (Key : Access_String_Type; Value : Value_Type; Order_Number : Positive; Continue : in out Boolean) is begin Action (Key.all, Value, Order_Number, Continue); end Local; procedure Traverse is new Local_Package.Traverse_Desc_G (Local); begin Traverse (Local_Package.Table_Type (Table)); end Traverse_Desc_G; procedure Traverse_Asc_And_Update_Value_G (Table : in out Table_Type) is procedure Local (Key : Access_String_Type; Value : in out Value_Type; Order_Number : Positive; Continue : in out Boolean); procedure Local (Key : Access_String_Type; Value : in out Value_Type; Order_Number : Positive; Continue : in out Boolean) is begin Modify (Key.all, Value, Order_Number, Continue); end Local; procedure Traverse is new Local_Package.Traverse_Asc_And_Update_Value_G (Local); begin Traverse (Local_Package.Table_Type (Table)); end Traverse_Asc_And_Update_Value_G; procedure Traverse_Desc_And_Update_Value_G (Table : in out Table_Type) is procedure Local (Key : Access_String_Type; Value : in out Value_Type; Order_Number : Positive; Continue : in out Boolean); procedure Local (Key : Access_String_Type; Value : in out Value_Type; Order_Number : Positive; Continue : in out Boolean) is begin Modify (Key.all, Value, Order_Number, Continue); end Local; procedure Traverse is new Local_Package.Traverse_Desc_And_Update_Value_G (Local); begin Traverse (Local_Package.Table_Type (Table)); end Traverse_Desc_And_Update_Value_G; procedure Disorder_Traverse_G (Table : Table_Type) is procedure Local (Key : Access_String_Type; Value : Value_Type; Order_Number : Positive; Continue : in out Boolean); procedure Local (Key : Access_String_Type; Value : Value_Type; Order_Number : Positive; Continue : in out Boolean) is begin Action (Key.all, Value, Order_Number, Continue); end Local; procedure Traverse is new Local_Package.Disorder_Traverse_G (Local); begin Traverse (Local_Package.Table_Type (Table)); end Disorder_Traverse_G; procedure Disorder_Traverse_And_Update_Value_G (Table : in out Table_Type) is procedure Local (Key : Access_String_Type; Value : in out Value_Type; Order_Number : Positive; Continue : in out Boolean); procedure Local (Key : Access_String_Type; Value : in out Value_Type; Order_Number : Positive; Continue : in out Boolean) is begin Modify (Key.all, Value, Order_Number, Continue); end Local; procedure Traverse is new Local_Package.Disorder_Traverse_And_Update_Value_G (Local); begin Traverse (Local_Package.Table_Type (Table)); end Disorder_Traverse_And_Update_Value_G; -- HEAP MANAGEMENT: procedure Destroy (Table : in out Table_Type) is begin Local_Package.Destroy (Local_Package.Table_Type (Table)); end Destroy; procedure Release_Free_List is begin Local_Package.Release_Free_List; end Release_Free_List; procedure Set_Max_Free_List_Size (Max_Free_List_Size : Natural) is begin Local_Package.Set_Max_Free_List_Size (Max_Free_List_Size); end Set_Max_Free_List_Size; function Free_List_Size return Natural is begin return Local_Package.Free_List_Size; end Free_List_Size; end Table_Of_Strings_And_Static_Values_G; polyorb-2.8~20110207.orig/src/aws_orig/templates_parser-input.ads0000644000175000017500000000613011750740337024211 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- T E M P L A T E S _ P A R S E R . I N P U T -- -- -- -- S p e c -- -- -- -- Copyright (C) 2002-2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ package Templates_Parser.Input is type File_Type is limited private; procedure Open (File : in out File_Type; Name : String; Form : String := ""); pragma Inline (Open); -- Like Text_IO.Open and Mode = In_File. procedure Close (File : in out File_Type); pragma Inline (Close); -- Like Text_IO.Close. Raises text_IO.Status_Error is file is not open. function End_Of_File (File : File_Type) return Boolean; pragma Inline (End_Of_File); -- Like Text_IO.End_Of_File. Raises Text_IO.Status_Error is file is not -- open. function LF_Terminated (File : File_Type) return Boolean; pragma Inline (LF_Terminated); -- Returns True if last line returned by Get_Line was terminated with a LF -- or CR+LF on DOS based systems. procedure Get_Line (File : File_Type; Buffer : out String; Last : out Natural); pragma Inline (Get_Line); -- Like Text_IO.Get_Line. Raises Text_IO.Status_Error is file is not open. private type File_Record; type File_Type is access File_Record; end Templates_Parser.Input; polyorb-2.8~20110207.orig/src/aws_orig/aws-session-control.ads0000644000175000017500000000477111750740337023444 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- A W S . S E S S I O N . C O N T R O L -- -- -- -- S p e c -- -- -- -- Copyright (C) 2000-2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- This API control the session cleaner task. Start must be called to launch -- the cleaner task and Shutwdown to terminate it. This is done during sever -- initialization and finalization. Users should not call directly these -- routines. package AWS.Session.Control is procedure Start (Session_Check_Interval : Duration; Session_Lifetime : Duration); -- Start session cleaner task. procedure Shutdown; -- Stop session cleaner task. end AWS.Session.Control; polyorb-2.8~20110207.orig/src/aws_orig/aws-containers-tables.adb0000644000175000017500000002144711750740337023676 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- A W S . C O N T A I N E R S . T A B L E S -- -- -- -- B o d y -- -- -- -- Copyright (C) 2000-2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- Parameters name/value are put into the GNAT.Dynamic_Tables.Table_Type -- (Data field). The name as a key and the numeric index as a value is -- placing to the AVL Tree for the fast find all Name/Value pairs with the -- same name. Each value of the AVL Tree is a table of numeric indexes -- in the Data field. The parameters must be accessible -- through their string index by name and also using an numeric index in -- the place order. So given a set of parameters (K1=V1, K2=V2...), -- one must be able to ask for the value for K1 but also the name of the -- second key or the value of the third key. -- -- Each K/V pair is then inserted into the Data table for access by numeric -- index. And its numeric index is placing to the AVL tree indexed by name. -- The AVL Tree values is a tables of numeric indexes in the Data table. with Ada.Characters.Handling; package body AWS.Containers.Tables is use Ada.Strings.Unbounded; Missing_Item_Error : exception renames Index_Table.Missing_Item_Error; ----------- -- Count -- ----------- function Count (Table : Table_Type) return Natural is begin pragma Assert (Table.Index /= null); return Data_Table.Last (Table.Data); end Count; ----------- -- Count -- ----------- function Count (Table : Table_Type; Name : String) return Natural is Value : Name_Index_Table; begin pragma Assert (Table.Index /= null); Get_Value (Table.Index.all, Normalize_Name (Name, not Table.Case_Sensitive), Value); return Natural (Name_Indexes.Last (Value)); exception when Missing_Item_Error => return 0; end Count; ----------- -- Exist -- ----------- function Exist (Table : Table_Type; Name : String) return Boolean is begin pragma Assert (Table.Index /= null); return Is_Present (Table.Index.all, Normalize_Name (Name, not Table.Case_Sensitive)); end Exist; --------- -- Get -- --------- function Get (Table : Table_Type; Name : String; N : Positive := 1) return String is begin return Internal_Get (Table, Name, N); end Get; function Get (Table : Table_Type; N : Positive) return Element is begin pragma Assert (Table.Index /= null); if N <= Data_Table.Last (Table.Data) then return Table.Data.Table (N).all; else return (Name_Length => 0, Value_Length => 0, Name => "", Value => ""); end if; end Get; -------------- -- Get_Name -- -------------- function Get_Name (Table : Table_Type; N : Positive := 1) return String is begin pragma Assert (Table.Index /= null); if N <= Data_Table.Last (Table.Data) then return Table.Data.Table (N).Name; else return ""; end if; end Get_Name; --------------- -- Get_Names -- --------------- function Get_Names (Table : Table_Type; Sort : Boolean := False) return VString_Array is procedure Process (Key : String; Value : Name_Index_Table; Order : Positive; Continue : in out Boolean); Result : VString_Array (1 .. Name_Count (Table)); ------------- -- Process -- ------------- procedure Process (Key : String; Value : Name_Index_Table; Order : Positive; Continue : in out Boolean) is pragma Warnings (Off, Value); pragma Warnings (Off, Continue); begin Result (Order) := To_Unbounded_String (Key); end Process; ----------------------- -- Disorder_Traverse -- ----------------------- procedure Disorder_Traverse is new Index_Table.Disorder_Traverse_G (Process); ------------------ -- Traverse_Asc -- ------------------ procedure Traverse_Asc is new Index_Table.Traverse_Asc_G (Process); begin if Table.Index /= null then if Sort then Traverse_Asc (Index_Table.Table_Type (Table.Index.all)); else Disorder_Traverse (Index_Table.Table_Type (Table.Index.all)); end if; end if; return Result; end Get_Names; --------------- -- Get_Value -- --------------- function Get_Value (Table : Table_Type; N : Positive := 1) return String is begin pragma Assert (Table.Index /= null); if N <= Data_Table.Last (Table.Data) then return Table.Data.Table (N).Value; else return ""; end if; end Get_Value; ---------------- -- Get_Values -- ---------------- function Get_Values (Table : Table_Type; Name : String) return VString_Array is Value : Name_Index_Table; begin pragma Assert (Table.Index /= null); Get_Value (Table.Index.all, Normalize_Name (Name, not Table.Case_Sensitive), Value); declare Last : constant Key_Positive := Name_Indexes.Last (Value); Result : VString_Array (1 .. Natural (Last)); begin for I in 1 .. Last loop Result (Natural (I)) := To_Unbounded_String (Table.Data.Table (Value.Table (I)).Value); end loop; return Result; end; exception when Missing_Item_Error => return (1 .. 0 => Null_Unbounded_String); end Get_Values; ------------------ -- Internal_Get -- ------------------ function Internal_Get (Table : Table_Type; Name : String; N : Natural) return String is Value : Name_Index_Table; begin pragma Assert (Table.Index /= null); Get_Value (Table.Index.all, Normalize_Name (Name, not Table.Case_Sensitive), Value); if Key_Positive (N) <= Name_Indexes.Last (Value) then return Table.Data.Table (Value.Table (Key_Positive (N))).Value; else return ""; end if; exception when Missing_Item_Error => return ""; end Internal_Get; ---------------- -- Name_Count -- ---------------- function Name_Count (Table : Table_Type) return Natural is begin if Table.Index = null then return 0; else return Size (Table.Index.all); end if; end Name_Count; -------------------- -- Normalize_Name -- -------------------- function Normalize_Name (Name : String; To_Upper : Boolean) return String is begin if To_Upper then return Ada.Characters.Handling.To_Upper (Name); else return Name; end if; end Normalize_Name; end AWS.Containers.Tables; polyorb-2.8~20110207.orig/src/aws_orig/table_of_static_keys_and_dynamic_values_g.adb0000644000175000017500000017460511750740337030066 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- TABLE_OF_STATIC_KEYS_AND_DYNAMIC_VALUES_G -- -- -- -- B o d y -- -- -- -- Copyright (C) 2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- TITLE: GENERIC PACKAGE FOR ASSOCIATIVE TABLES. -- REVISION: 13-JUL-1992 Ph. Kipfer (PKR), File header format -- APPROVAL: 03-DEC-1987 C. Genillard. -- CREATION: 29-JUN-1987 A. Strohmeier. with Unchecked_Deallocation; package body Table_Of_Static_Keys_And_Dynamic_Values_G is -- LOCAL SUBPROGRAM: procedure Assign_Item (Destination : out Key_Type; Source : Key_Type); procedure Assign (Destination : out Key_Type; Source : Key_Type) renames Assign_Item; -- LOCAL SUBPROGRAM: procedure Destroy_Item (Item : Key_Type); procedure Destroy (Item : Key_Type) renames Destroy_Item; type Link_List_Type is array (Positive range <>) of Link_Type; Max_Free_List_Size : Natural := 0; type Free_List_Type is record Ptr : Link_Type; Count : Natural := 0; end record; -- STATE VARIABLE: Free_List : Free_List_Type; -- LOCAL SUBPROGRAM: procedure Create_And_Assign_Cell (Link : in out Link_Type; Key : Key_Type; Value : Value_Type); procedure Create_And_Assign_Cell (Link : in out Link_Type; Key : Key_Type; Value : Value_Type) is -- LINK has in (out) mode for allowing access to LINK.VALUE. begin if Free_List.Count = 0 then Link := new Cell_Type; else Link := Free_List.Ptr; Free_List.Ptr := Free_List.Ptr.Right; Free_List.Count := Free_List.Count - 1; Link.Balance := 0; Link.Left := null; Link.Right := null; end if; Assign (Link.Key, Key); Assign (Link.Value, Value); end Create_And_Assign_Cell; pragma Inline (Create_And_Assign_Cell); -- LOCAL SUBPROGRAM: procedure Dispose is new Unchecked_Deallocation (Object => Cell_Type, Name => Link_Type); pragma Inline (Dispose); -- LOCAL SUBPROGRAM: procedure Release (Link : in out Link_Type); procedure Release (Link : in out Link_Type) is -- Collect in the free list, or release to system. begin Destroy (Link.Key); Destroy (Link.Value); if Free_List.Count < Max_Free_List_Size then Link.Right := Free_List.Ptr; Free_List.Ptr := Link; Free_List.Count := Free_List.Count + 1; else Dispose (Link); end if; end Release; pragma Inline (Release); -- LOCAL SUBPROGRAM: function Search_A_Key (Root : Link_Type; Key : Key_Type) return Link_Type; function Search_A_Key (Root : Link_Type; Key : Key_Type) return Link_Type is -- Result points to the cell with key value searched for; when search -- fails, null value is returned. Ptr : Link_Type := Root; begin -- SEARCH_A_KEY while Ptr /= null loop if Less (Ptr.Key, Key) then Ptr := Ptr.Right; elsif Equals (Ptr.Key, Key) then return Ptr; else Ptr := Ptr.Left; end if; end loop; return null; end Search_A_Key; pragma Inline (Search_A_Key); -- / LOCAL SUBPROGRAM: function Search_Min (Root : Link_Type) return Link_Type; function Search_Min (Root : Link_Type) return Link_Type is -- Result points to the first (smallest) cell in the table. Ptr : Link_Type := Root; begin if Ptr = null then return null; end if; while Ptr.Left /= null loop Ptr := Ptr.Left; end loop; return Ptr; end Search_Min; pragma Inline (Search_Min); -- / LOCAL SUBPROGRAM: function Search_Max (Root : Link_Type) return Link_Type; function Search_Max (Root : Link_Type) return Link_Type is -- Result points to the last (greatest) cell in the table. Ptr : Link_Type := Root; begin if Ptr = null then return null; end if; while Ptr.Right /= null loop Ptr := Ptr.Right; end loop; return Ptr; end Search_Max; pragma Inline (Search_Max); -- / CONSTRUCTORS: procedure Assign (Destination : in out Table_Type; Source : Table_Type) is procedure Copy_Subtree (Destination : in out Link_Type; Source : Link_Type); procedure Copy_Subtree (Destination : in out Link_Type; Source : Link_Type) is begin if Source /= null then Create_And_Assign_Cell (Destination, Source.Key, Source.Value); Destination.Balance := Source.Balance; Copy_Subtree (Destination.Left, Source.Left); Copy_Subtree (Destination.Right, Source.Right); else Destination := null; end if; end Copy_Subtree; begin -- ASSIGN if Source.Root = Destination.Root then return; end if; -- Actual parameters are identical tables. Destroy (Destination); if Source.Count = 0 then return; end if; -- SOURCE is a null table. Copy_Subtree (Destination.Root, Source.Root); Destination.Count := Source.Count; end Assign; procedure Insert (Table : in out Table_Type; Key : Key_Type; Value : Value_Type) is Duplicate_Item : Boolean; begin -- INSERT Insert (Table, Key, Value, Duplicate_Item); if Duplicate_Item then raise Duplicate_Item_Error; end if; end Insert; procedure Insert (Table : in out Table_Type; Key : Key_Type; Value : Value_Type; Duplicate_Item : out Boolean) is Depth_Increased : Boolean := False; procedure Insert_Node (Key : Key_Type; Value : Value_Type; Subtree : in out Link_Type; Depth_Increased : in out Boolean); procedure Insert_Node (Key : Key_Type; Value : Value_Type; Subtree : in out Link_Type; Depth_Increased : in out Boolean) is procedure Check_And_Balance_Left (Root : in out Link_Type; Depth_Increased : in out Boolean); procedure Check_And_Balance_Left (Root : in out Link_Type; Depth_Increased : in out Boolean) is begin -- CHECK_AND_BALANCE_LEFT case Root.Balance is when 1 => Root.Balance := 0; Depth_Increased := False; when 0 => Root.Balance := -1; when -1 => -- rebalance declare Left_Son : constant Link_Type := Root.Left; begin if Left_Son.Balance = -1 then -- single LL rotation Root.Left := Left_Son.Right; Left_Son.Right := Root; Root.Balance := 0; Root := Left_Son; else -- double LR rotation declare Left_Right_Son : constant Link_Type := Left_Son.Right; begin Left_Son.Right := Left_Right_Son.Left; Left_Right_Son.Left := Left_Son; Root.Left := Left_Right_Son.Right; Left_Right_Son.Right := Root; if Left_Right_Son.Balance = -1 then Root.Balance := 1; else Root.Balance := 0; end if; if Left_Right_Son.Balance = 1 then Left_Son.Balance := -1; else Left_Son.Balance := 0; end if; Root := Left_Right_Son; end; end if; Root.Balance := 0; Depth_Increased := False; end; end case; end Check_And_Balance_Left; procedure Check_And_Balance_Right (Root : in out Link_Type; Depth_Increased : in out Boolean); procedure Check_And_Balance_Right (Root : in out Link_Type; Depth_Increased : in out Boolean) is begin -- CHECK_AND_BALANCE_RIGHT case Root.Balance is when -1 => Root.Balance := 0; Depth_Increased := False; when 0 => Root.Balance := 1; when 1 => -- rebalance declare Right_Son : constant Link_Type := Root.Right; begin if Right_Son.Balance = 1 then -- single RR rotation Root.Right := Right_Son.Left; Right_Son.Left := Root; Root.Balance := 0; Root := Right_Son; else -- double RL rotation declare Right_Left_Son : constant Link_Type := Right_Son.Left; begin Right_Son.Left := Right_Left_Son.Right; Right_Left_Son.Right := Right_Son; Root.Right := Right_Left_Son.Left; Right_Left_Son.Left := Root; if Right_Left_Son.Balance = 1 then Root.Balance := -1; else Root.Balance := 0; end if; if Right_Left_Son.Balance = -1 then Right_Son.Balance := +1; else Right_Son.Balance := 0; end if; Root := Right_Left_Son; end; end if; Root.Balance := 0; Depth_Increased := False; end; end case; end Check_And_Balance_Right; begin -- INSERT_NODE if Subtree = null then Create_And_Assign_Cell (Subtree, Key, Value); Table.Count := Table.Count + 1; Depth_Increased := True; Duplicate_Item := False; else if Less (Key, Subtree.Key) then -- insert into left subtable Insert_Node (Key, Value, Subtree.Left, Depth_Increased); if Depth_Increased then Check_And_Balance_Left (Subtree, Depth_Increased); end if; elsif Equals (Key, Subtree.Key) then Depth_Increased := False; Duplicate_Item := True; else -- insert into right subtable Insert_Node (Key, Value, Subtree.Right, Depth_Increased); if Depth_Increased then Check_And_Balance_Right (Subtree, Depth_Increased); end if; end if; end if; end Insert_Node; begin -- INSERT Insert_Node (Key, Value, Table.Root, Depth_Increased); end Insert; procedure Insert_Or_Replace_Value (Table : in out Table_Type; Key : Key_Type; Value : Value_Type) is Ptr : constant Link_Type := Search_A_Key (Table.Root, Key); Junk : Boolean; begin if Ptr /= null then Assign (Ptr.Value, Value); else Insert (Table, Key, Value, Junk); end if; end Insert_Or_Replace_Value; procedure Replace_Value (Table : in out Table_Type; Key : Key_Type; Value : Value_Type; Found : out Boolean) is Ptr : constant Link_Type := Search_A_Key (Table.Root, Key); begin if Ptr /= null then Assign (Ptr.Value, Value); Found := True; else Found := False; end if; end Replace_Value; procedure Replace_Value (Table : in out Table_Type; Key : Key_Type; Value : Value_Type) is Ptr : constant Link_Type := Search_A_Key (Table.Root, Key); begin if Ptr /= null then Assign (Ptr.Value, Value); else raise Missing_Item_Error; end if; end Replace_Value; -- LOCAL SUBPROGRAM: -- Primitives for balancing used by procedures that delete cells procedure Balance_Left (Root : in out Link_Type; Depth_Reduced : in out Boolean); procedure Balance_Left (Root : in out Link_Type; Depth_Reduced : in out Boolean) is begin -- BALANCE_LEFT case Root.Balance is when -1 => Root.Balance := 0; when 0 => Root.Balance := 1; Depth_Reduced := False; when 1 => -- rebalance declare Right_Son : constant Link_Type := Root.Right; Right_Son_Balance : constant Equilibrium_Type := Right_Son.Balance; begin if Right_Son_Balance >= 0 then -- single RR rotation Root.Right := Right_Son.Left; Right_Son.Left := Root; if Right_Son_Balance = 0 then Root.Balance := 1; Right_Son.Balance := -1; Depth_Reduced := False; else Root.Balance := 0; Right_Son.Balance := 0; end if; Root := Right_Son; else -- double RL rotation declare Right_Left_Son : constant Link_Type := Right_Son.Left; Right_Left_Son_Balance : constant Equilibrium_Type := Right_Left_Son.Balance; begin Right_Son.Left := Right_Left_Son.Right; Right_Left_Son.Right := Right_Son; Root.Right := Right_Left_Son.Left; Right_Left_Son.Left := Root; if Right_Left_Son_Balance = 1 then Root.Balance := -1; else Root.Balance := 0; end if; if Right_Left_Son_Balance = -1 then Right_Son.Balance := 1; else Right_Son.Balance := 0; end if; Root := Right_Left_Son; Right_Left_Son.Balance := 0; end; end if; end; end case; end Balance_Left; -- / LOCAL SUBPROGRAM: procedure Balance_Right (Root : in out Link_Type; Depth_Reduced : in out Boolean); procedure Balance_Right (Root : in out Link_Type; Depth_Reduced : in out Boolean) is begin -- BALANCE_RIGHT case Root.Balance is when 1 => Root.Balance := 0; when 0 => Root.Balance := -1; Depth_Reduced := False; when -1 => -- rebalance declare Left_Son : constant Link_Type := Root.Left; Left_Son_Balance : constant Equilibrium_Type := Left_Son.Balance; begin if Left_Son_Balance <= 0 then -- single LL rotation Root.Left := Left_Son.Right; Left_Son.Right := Root; if Left_Son_Balance = 0 then Root.Balance := -1; Left_Son.Balance := 1; Depth_Reduced := False; else Root.Balance := 0; Left_Son.Balance := 0; end if; Root := Left_Son; else -- double LR rotation declare Left_Right_Son : constant Link_Type := Left_Son.Right; Left_Right_Son_Balance : constant Equilibrium_Type := Left_Right_Son.Balance; begin Left_Son.Right := Left_Right_Son.Left; Left_Right_Son.Left := Left_Son; Root.Left := Left_Right_Son.Right; Left_Right_Son.Right := Root; if Left_Right_Son_Balance = -1 then Root.Balance := 1; else Root.Balance := 0; end if; if Left_Right_Son_Balance = 1 then Left_Son.Balance := -1; else Left_Son.Balance := 0; end if; Root := Left_Right_Son; Left_Right_Son.Balance := 0; end; end if; end; end case; end Balance_Right; procedure Remove (Table : in out Table_Type; Key : Key_Type) is Found : Boolean; begin -- REMOVE Remove (Table, Key, Found); if not Found then raise Missing_Item_Error; end if; end Remove; procedure Remove (Table : in out Table_Type; Key : Key_Type; Value : in out Value_Type) is Ptr : constant Link_Type := Search_A_Key (Table.Root, Key); Found : Boolean; begin -- REMOVE if Ptr = null then raise Missing_Item_Error; end if; Assign (Value, Ptr.Value); Remove (Table, Key, Found); end Remove; procedure Remove (Table : in out Table_Type; Key : Key_Type; Found : out Boolean) is Depth_Decreased : Boolean := False; Temp : Link_Type; procedure Remove_Node (Root : in out Link_Type; Depth_Reduced : in out Boolean); procedure Remove_Node (Root : in out Link_Type; Depth_Reduced : in out Boolean) is procedure Delete_Biggest (Node : in out Link_Type; Depth_Reduced : in out Boolean); procedure Delete_Biggest (Node : in out Link_Type; Depth_Reduced : in out Boolean) is begin if Node.Right = null then -- NODE already points to the biggest key value. Assign (Root.Key, Node.Key); Assign (Root.Value, Node.Value); Temp := Node; -- in order to dispose the right cell Node := Node.Left; Depth_Reduced := True; else Delete_Biggest (Node.Right, Depth_Reduced); if Depth_Reduced then Balance_Right (Node, Depth_Reduced); end if; end if; end Delete_Biggest; procedure Delete_Smallest (Node : in out Link_Type; Depth_Reduced : in out Boolean); procedure Delete_Smallest (Node : in out Link_Type; Depth_Reduced : in out Boolean) is begin if Node.Left = null then -- NODE already points to the smallest key value. Assign (Root.Key, Node.Key); Assign (Root.Value, Node.Value); Temp := Node; -- in order to dispose the right cell Node := Node.Right; Depth_Reduced := True; else Delete_Smallest (Node.Left, Depth_Reduced); if Depth_Reduced then Balance_Left (Node, Depth_Reduced); end if; end if; end Delete_Smallest; begin -- REMOVE_NODE if Root = null then return; end if; if Less (Key, Root.Key) then -- delete in left subtable Remove_Node (Root.Left, Depth_Reduced); if Depth_Reduced then Balance_Left (Root, Depth_Reduced); end if; elsif Less (Root.Key, Key) then -- delete in right subtable Remove_Node (Root.Right, Depth_Reduced); if Depth_Reduced then Balance_Right (Root, Depth_Reduced); end if; elsif Equals (Key, Root.Key) then if Root.Right = null then Temp := Root; Root := Root.Left; Depth_Reduced := True; elsif Root.Left = null then Temp := Root; Root := Root.Right; Depth_Reduced := True; else if Table.Connect_Predecessor then Table.Connect_Predecessor := False; Delete_Biggest (Root.Left, Depth_Reduced); if Depth_Reduced then Balance_Left (Root, Depth_Reduced); end if; else -- CONNECT_SUCCESSOR Table.Connect_Predecessor := True; Delete_Smallest (Root.Right, Depth_Reduced); if Depth_Reduced then Balance_Right (Root, Depth_Reduced); end if; end if; end if; Table.Count := Table.Count - 1; Found := True; Release (Temp); end if; end Remove_Node; begin -- REMOVE Found := False; Remove_Node (Table.Root, Depth_Decreased); end Remove; procedure Remove_Min (Table : in out Table_Type) is Found : Boolean; Ptr : constant Link_Type := Search_Min (Table.Root); begin if Table.Root = null then raise Empty_Structure_Error; end if; Remove (Table, Ptr.Key, Found); end Remove_Min; procedure Remove_Min (Table : in out Table_Type; Key : out Key_Type) is Found : Boolean; Ptr : constant Link_Type := Search_Min (Table.Root); begin if Table.Root = null then raise Empty_Structure_Error; end if; Assign (Key, Ptr.Key); Remove (Table, Ptr.Key, Found); end Remove_Min; procedure Remove_Min (Table : in out Table_Type; Key : out Key_Type; Value : in out Value_Type) is Found : Boolean; Ptr : constant Link_Type := Search_Min (Table.Root); begin if Table.Root = null then raise Empty_Structure_Error; end if; Assign (Key, Ptr.Key); Assign (Value, Ptr.Value); Remove (Table, Ptr.Key, Found); end Remove_Min; procedure Remove_Max (Table : in out Table_Type) is Found : Boolean; Ptr : constant Link_Type := Search_Max (Table.Root); begin if Table.Root = null then raise Empty_Structure_Error; end if; Remove (Table, Ptr.Key, Found); end Remove_Max; procedure Remove_Max (Table : in out Table_Type; Key : out Key_Type) is Found : Boolean; Ptr : constant Link_Type := Search_Max (Table.Root); begin if Table.Root = null then raise Empty_Structure_Error; end if; Assign (Key, Ptr.Key); Remove (Table, Ptr.Key, Found); end Remove_Max; procedure Remove_Max (Table : in out Table_Type; Key : out Key_Type; Value : in out Value_Type) is Found : Boolean; Ptr : constant Link_Type := Search_Max (Table.Root); begin if Table.Root = null then raise Empty_Structure_Error; end if; Assign (Key, Ptr.Key); Assign (Value, Ptr.Value); Remove (Table, Ptr.Key, Found); end Remove_Max; procedure Update_Value_Or_Exception_G (Table : in out Table_Type; Key : Key_Type) is Link : constant Link_Type := Search_A_Key (Table.Root, Key); begin if Link = null then raise Missing_Item_Error; end if; Modify (Link.Key, Link.Value); end Update_Value_Or_Exception_G; procedure Update_Value_Or_Status_G (Table : in out Table_Type; Key : Key_Type; Found : out Boolean) is Link : constant Link_Type := Search_A_Key (Table.Root, Key); begin if Link = null then Found := False; return; end if; Found := True; Modify (Link.Key, Link.Value); end Update_Value_Or_Status_G; -- QUERIES: function Size (Table : Table_Type) return Natural is begin -- SIZE return Table.Count; end Size; function Is_Empty (Table : Table_Type) return Boolean is begin -- IS_EMPTY return Table.Count = 0; end Is_Empty; function Is_Present (Table : Table_Type; Key : Key_Type) return Boolean is begin -- IS_PRESENT return Search_A_Key (Table.Root, Key) /= null; end Is_Present; function Value (Table : Table_Type; Key : Key_Type) return Value_Type is Ptr : constant Link_Type := Search_A_Key (Table.Root, Key); begin -- GET_VALUE if Ptr = null then raise Missing_Item_Error; end if; return Ptr.Value; end Value; procedure Get_Value (Table : Table_Type; Key : Key_Type; Value : in out Value_Type) is Ptr : constant Link_Type := Search_A_Key (Table.Root, Key); begin -- GET_VALUE if Ptr = null then raise Missing_Item_Error; end if; Assign (Value, Ptr.Value); end Get_Value; procedure Get_Min_Item (Table : Table_Type; Key : out Key_Type; Value : in out Value_Type) is Current : Link_Type := Table.Root; begin -- GET_MIN_ITEM if Current = null then raise Empty_Structure_Error; end if; while Current.Left /= null loop Current := Current.Left; end loop; Assign (Key, Current.Key); Assign (Value, Current.Value); end Get_Min_Item; procedure Get_Max_Item (Table : Table_Type; Key : out Key_Type; Value : in out Value_Type) is Current : Link_Type := Table.Root; begin -- GET_MAX_ITEM if Current = null then raise Empty_Structure_Error; end if; while Current.Right /= null loop Current := Current.Right; end loop; Assign (Key, Current.Key); Assign (Value, Current.Value); end Get_Max_Item; function Min_Key (Table : Table_Type) return Key_Type is Current : Link_Type := Table.Root; begin -- GET_MIN_KEY if Current = null then raise Empty_Structure_Error; end if; while Current.Left /= null loop Current := Current.Left; end loop; return Current.Key; end Min_Key; procedure Get_Min_Key (Table : Table_Type; Key : out Key_Type) is Current : Link_Type := Table.Root; begin -- GET_MIN_KEY if Current = null then raise Empty_Structure_Error; end if; while Current.Left /= null loop Current := Current.Left; end loop; Assign (Key, Current.Key); end Get_Min_Key; function Max_Key (Table : Table_Type) return Key_Type is Current : Link_Type := Table.Root; begin -- GET_MAX_KEY if Current = null then raise Empty_Structure_Error; end if; while Current.Right /= null loop Current := Current.Right; end loop; return Current.Key; end Max_Key; procedure Get_Max_Key (Table : Table_Type; Key : out Key_Type) is Current : Link_Type := Table.Root; begin -- GET_MAX_KEY if Current = null then raise Empty_Structure_Error; end if; while Current.Right /= null loop Current := Current.Right; end loop; Assign (Key, Current.Key); end Get_Max_Key; -- LOCAL SUBPROGRAM: function Search_Less_Or_Equal (Root : Link_Type; Key : Key_Type) return Link_Type; function Search_Less_Or_Equal (Root : Link_Type; Key : Key_Type) return Link_Type is -- Result points to the cell with key value less than or equal to KEY; -- when search fails, null value is returned. Ptr : Link_Type := Root; Best : Link_Type; begin if Ptr = null then return null; end if; loop if Less (Key, Ptr.Key) then if Ptr.Left = null then return Best; end if; Ptr := Ptr.Left; elsif Equals (Key, Ptr.Key) then return Ptr; else -- LESS (PTR.KEY, KEY) if Ptr.Right = null then return Ptr; end if; Best := Ptr; Ptr := Ptr.Right; end if; end loop; end Search_Less_Or_Equal; pragma Inline (Search_Less_Or_Equal); -- / LOCAL SUBPROGRAM: function Search_Less (Root : Link_Type; Key : Key_Type) return Link_Type; function Search_Less (Root : Link_Type; Key : Key_Type) return Link_Type is -- Result points to the cell with key value less than KEY; when search -- fails, null value is returned. Ptr : Link_Type := Root; Best : Link_Type; begin if Ptr = null then return null; end if; loop if Less (Key, Ptr.Key) or Equals (Key, Ptr.Key) then if Ptr.Left = null then return Best; end if; Ptr := Ptr.Left; else -- LESS (PTR.KEY, KEY) if Ptr.Right = null then return Ptr; end if; Best := Ptr; Ptr := Ptr.Right; end if; end loop; end Search_Less; pragma Inline (Search_Less); -- LOCAL SUBPROGRAM: function Search_Greater_Or_Equal (Root : Link_Type; Key : Key_Type) return Link_Type; function Search_Greater_Or_Equal (Root : Link_Type; Key : Key_Type) return Link_Type is -- Result points to the cell with key value greater than or equal to KEY; -- when search fails, null value is returned. Ptr : Link_Type := Root; Best : Link_Type; begin if Ptr = null then return null; end if; loop if Less (Ptr.Key, Key) then if Ptr.Right = null then return Best; end if; Ptr := Ptr.Right; elsif Equals (Key, Ptr.Key) then return Ptr; else -- LESS (KEY, PTR.KEY) if Ptr.Left = null then return Ptr; end if; Best := Ptr; Ptr := Ptr.Left; end if; end loop; end Search_Greater_Or_Equal; pragma Inline (Search_Greater_Or_Equal); -- / LOCAL SUBPROGRAM: function Search_Greater (Root : Link_Type; Key : Key_Type) return Link_Type; function Search_Greater (Root : Link_Type; Key : Key_Type) return Link_Type is -- Result points to the cell with key value greater than KEY; when search -- fails, null value is returned. Ptr : Link_Type := Root; Best : Link_Type; begin if Ptr = null then return null; end if; loop if Less (Ptr.Key, Key) or Equals (Ptr.Key, Key) then if Ptr.Right = null then return Best; end if; Ptr := Ptr.Right; else -- LESS (KEY, PTR.KEY) if Ptr.Left = null then return Ptr; end if; Best := Ptr; Ptr := Ptr.Left; end if; end loop; end Search_Greater; pragma Inline (Search_Greater); procedure Get_Less_Item (Table : Table_Type; Key : in out Key_Type; Value : in out Value_Type) is Ptr : constant Link_Type := Search_Less (Table.Root, Key); begin if Ptr = null then raise Missing_Item_Error; end if; Assign (Key, Ptr.Key); Assign (Value, Ptr.Value); end Get_Less_Item; procedure Get_Less_Or_Equal_Item (Table : Table_Type; Key : in out Key_Type; Value : in out Value_Type) is Ptr : constant Link_Type := Search_Less_Or_Equal (Table.Root, Key); begin if Ptr = null then raise Missing_Item_Error; end if; Assign (Key, Ptr.Key); Assign (Value, Ptr.Value); end Get_Less_Or_Equal_Item; procedure Get_Greater_Item (Table : Table_Type; Key : in out Key_Type; Value : in out Value_Type) is Ptr : constant Link_Type := Search_Greater (Table.Root, Key); begin if Ptr = null then raise Missing_Item_Error; end if; Assign (Key, Ptr.Key); Assign (Value, Ptr.Value); end Get_Greater_Item; procedure Get_Greater_Or_Equal_Item (Table : Table_Type; Key : in out Key_Type; Value : in out Value_Type) is Ptr : constant Link_Type := Search_Greater_Or_Equal (Table.Root, Key); begin if Ptr = null then raise Missing_Item_Error; end if; Assign (Key, Ptr.Key); Assign (Value, Ptr.Value); end Get_Greater_Or_Equal_Item; function Less_Key (Table : Table_Type; Key : Key_Type) return Key_Type is Ptr : constant Link_Type := Search_Less (Table.Root, Key); begin if Ptr = null then raise Missing_Item_Error; end if; return Ptr.Key; end Less_Key; procedure Get_Less_Key (Table : Table_Type; Key : in out Key_Type) is Ptr : constant Link_Type := Search_Less (Table.Root, Key); begin if Ptr = null then raise Missing_Item_Error; end if; Assign (Key, Ptr.Key); end Get_Less_Key; procedure Get_Less_Key (Table : Table_Type; Key : in out Key_Type; Found : out Boolean) is Ptr : constant Link_Type := Search_Less (Table.Root, Key); begin if Ptr = null then Found := False; else Found := True; Assign (Key, Ptr.Key); end if; end Get_Less_Key; function Less_Or_Equal_Key (Table : Table_Type; Key : Key_Type) return Key_Type is Ptr : constant Link_Type := Search_Less_Or_Equal (Table.Root, Key); begin if Ptr = null then raise Missing_Item_Error; end if; return Ptr.Key; end Less_Or_Equal_Key; procedure Get_Less_Or_Equal_Key (Table : Table_Type; Key : in out Key_Type) is Ptr : constant Link_Type := Search_Less_Or_Equal (Table.Root, Key); begin if Ptr = null then raise Missing_Item_Error; end if; Assign (Key, Ptr.Key); end Get_Less_Or_Equal_Key; procedure Get_Less_Or_Equal_Key (Table : Table_Type; Key : in out Key_Type; Found : out Boolean) is Ptr : constant Link_Type := Search_Less_Or_Equal (Table.Root, Key); begin if Ptr = null then Found := False; else Found := True; Assign (Key, Ptr.Key); end if; end Get_Less_Or_Equal_Key; function Greater_Key (Table : Table_Type; Key : Key_Type) return Key_Type is Ptr : constant Link_Type := Search_Greater (Table.Root, Key); begin if Ptr = null then raise Missing_Item_Error; end if; return Ptr.Key; end Greater_Key; procedure Get_Greater_Key (Table : Table_Type; Key : in out Key_Type) is Ptr : constant Link_Type := Search_Greater (Table.Root, Key); begin if Ptr = null then raise Missing_Item_Error; end if; Assign (Key, Ptr.Key); end Get_Greater_Key; procedure Get_Greater_Key (Table : Table_Type; Key : in out Key_Type; Found : out Boolean) is Ptr : constant Link_Type := Search_Greater (Table.Root, Key); begin if Ptr = null then Found := False; else Found := True; Assign (Key, Ptr.Key); end if; end Get_Greater_Key; function Greater_Or_Equal_Key (Table : Table_Type; Key : Key_Type) return Key_Type is Ptr : constant Link_Type := Search_Greater_Or_Equal (Table.Root, Key); begin if Ptr = null then raise Missing_Item_Error; end if; return Ptr.Key; end Greater_Or_Equal_Key; procedure Get_Greater_Or_Equal_Key (Table : Table_Type; Key : in out Key_Type) is Ptr : constant Link_Type := Search_Greater_Or_Equal (Table.Root, Key); begin if Ptr = null then raise Missing_Item_Error; end if; Assign (Key, Ptr.Key); end Get_Greater_Or_Equal_Key; procedure Get_Greater_Or_Equal_Key (Table : Table_Type; Key : in out Key_Type; Found : out Boolean) is Ptr : constant Link_Type := Search_Greater_Or_Equal (Table.Root, Key); begin if Ptr = null then Found := False; else Found := True; Assign (Key, Ptr.Key); end if; end Get_Greater_Or_Equal_Key; -- SET OPERATIONS: package body Set_Operations_G is -- / LOCAL SUBPROGRAM: procedure Conditional_Union (Destination : in out Table_Type; Source : Table_Type); procedure Conditional_Union (Destination : in out Table_Type; Source : Table_Type) is -- All entries which are in SOURCE but not in DESTINATION are inserted -- into DESTINATION. DESTINATION and SOURCE must not access the same -- table. procedure Action (Key : Key_Type; Value : Value_Type; Order_Number : Positive; Continue : in out Boolean); procedure Action (Key : Key_Type; Value : Value_Type; Order_Number : Positive; Continue : in out Boolean) is pragma Warnings (Off, Order_Number); pragma Warnings (Off, Continue); Dummy : Boolean; begin Insert (Destination, Key, Value, Dummy); end Action; procedure Traversal is new Disorder_Traverse_G (Action); begin Traversal (Source); end Conditional_Union; -- LOCAL SUBPROGRAM: procedure Unconditional_Union (Destination : in out Table_Type; Source : Table_Type); procedure Unconditional_Union (Destination : in out Table_Type; Source : Table_Type) is -- All entries which are in SOURCE are inserted into DESTINATION or -- replace previous entries. procedure Action (Key : Key_Type; Value : Value_Type; Order_Number : Positive; Continue : in out Boolean); procedure Action (Key : Key_Type; Value : Value_Type; Order_Number : Positive; Continue : in out Boolean) is pragma Warnings (Off, Order_Number); pragma Warnings (Off, Continue); begin Insert_Or_Replace_Value (Destination, Key, Value); end Action; procedure Traversal is new Disorder_Traverse_G (Action); begin Traversal (Source); end Unconditional_Union; procedure Union (Destination : in out Table_Type; Left, Right : Table_Type) is begin if Left.Root = Right.Root then if Destination.Root = Left.Root then null; else Assign (Destination, Left); end if; elsif Destination.Root = Left.Root then Conditional_Union (Destination, Right); elsif Destination.Root = Right.Root then Unconditional_Union (Destination, Left); else Assign (Destination, Left); Conditional_Union (Destination, Right); end if; end Union; -- LOCAL SUBPROGRAM: procedure Local_Intersection (Destination : in out Table_Type; Left, Right : Table_Type); procedure Local_Intersection (Destination : in out Table_Type; Left, Right : Table_Type) is -- DESTINATION must be an empty table. LEFT is traversed and each entry -- which is also in RIGHT is inserted into DESTINATION. procedure Action (Key : Key_Type; Value : Value_Type; Order_Number : Positive; Continue : in out Boolean); procedure Action (Key : Key_Type; Value : Value_Type; Order_Number : Positive; Continue : in out Boolean) is pragma Warnings (Off, Order_Number); pragma Warnings (Off, Continue); begin if Is_Present (Right, Key) then Insert (Destination, Key, Value); end if; end Action; procedure Traversal is new Disorder_Traverse_G (Action); begin Traversal (Left); end Local_Intersection; procedure Intersection (Destination : in out Table_Type; Left, Right : Table_Type) is Local_Table : Table_Type; begin if Left.Root = Right.Root then if Destination.Root = Left.Root then null; else Assign (Destination, Left); end if; elsif Destination.Root = Left.Root or Destination.Root = Right.Root then Local_Intersection (Local_Table, Left, Right); Assign (Destination, Local_Table); Destroy (Local_Table); else Destroy (Destination); Local_Intersection (Destination, Left, Right); end if; end Intersection; -- LOCAL SUBPROGRAM: procedure Local_Difference (Destination : in out Table_Type; Left, Right : Table_Type); procedure Local_Difference (Destination : in out Table_Type; Left, Right : Table_Type) is -- DESTINATION must be an empty table. LEFT is traversed and each entry -- which is not in RIGHT is inserted into DESTINATION. procedure Action (Key : Key_Type; Value : Value_Type; Order_Number : Positive; Continue : in out Boolean); procedure Action (Key : Key_Type; Value : Value_Type; Order_Number : Positive; Continue : in out Boolean) is pragma Warnings (Off, Order_Number); pragma Warnings (Off, Continue); begin if not Is_Present (Right, Key) then Insert (Destination, Key, Value); end if; end Action; procedure Traversal is new Disorder_Traverse_G (Action); begin Traversal (Left); end Local_Difference; procedure Difference (Destination : in out Table_Type; Left, Right : Table_Type) is Local_Table : Table_Type; begin if Left.Root = Right.Root then Destroy (Destination); elsif Destination.Root = Left.Root or Destination.Root = Right.Root then Local_Difference (Local_Table, Left, Right); Assign (Destination, Local_Table); Destroy (Local_Table); else Destroy (Destination); Local_Difference (Destination, Left, Right); end if; end Difference; -- LOCAL SUBPROGRAM: procedure Local_Symmetric_Difference (Destination : in out Table_Type; Left, Right : Table_Type); procedure Local_Symmetric_Difference (Destination : in out Table_Type; Left, Right : Table_Type) is -- DESTINATION must be an empty table. LEFT is traversed and each entry -- which is not in RIGHT is inserted into DESTINATION. Then RIGHT is -- traversed and each entry which is not in LEFT is inserted into -- DESTINATION. procedure Action_For_Left (Key : Key_Type; Value : Value_Type; Order_Number : Positive; Continue : in out Boolean); procedure Action_For_Left (Key : Key_Type; Value : Value_Type; Order_Number : Positive; Continue : in out Boolean) is pragma Warnings (Off, Order_Number); pragma Warnings (Off, Continue); begin if not Is_Present (Right, Key) then Insert (Destination, Key, Value); end if; end Action_For_Left; procedure Action_For_Right (Key : Key_Type; Value : Value_Type; Order_Number : Positive; Continue : in out Boolean); procedure Action_For_Right (Key : Key_Type; Value : Value_Type; Order_Number : Positive; Continue : in out Boolean) is pragma Warnings (Off, Order_Number); pragma Warnings (Off, Continue); begin if not Is_Present (Left, Key) then Insert (Destination, Key, Value); end if; end Action_For_Right; procedure Traverse_Left is new Disorder_Traverse_G (Action_For_Left); procedure Traverse_Right is new Disorder_Traverse_G (Action_For_Right); begin Traverse_Left (Left); Traverse_Right (Right); end Local_Symmetric_Difference; procedure Symmetric_Difference (Destination : in out Table_Type; Left, Right : Table_Type) is Local_Table : Table_Type; begin if Left.Root = Right.Root then Destroy (Destination); elsif Destination.Root = Left.Root or Destination.Root = Right.Root then Local_Symmetric_Difference (Local_Table, Left, Right); Assign (Destination, Local_Table); Destroy (Local_Table); else Destroy (Destination); Local_Symmetric_Difference (Destination, Left, Right); end if; end Symmetric_Difference; -- LOCAL SUBPROGRAM: procedure Fill_List (Table : Table_Type; Link_List : in out Link_List_Type); procedure Fill_List (Table : Table_Type; Link_List : in out Link_List_Type) is -- Fills LINK_LIST with pointers to the items of TABLE according to -- order defined on them. -- Condition: LINK_LIST'LAST = TABLE.COUNT Index : Natural := 0; procedure Traverse_Subtree (Link : Link_Type); procedure Traverse_Subtree (Link : Link_Type) is -- LINK points to root of subtree. begin -- TRAVERSE_SUBTREE if Link /= null then Traverse_Subtree (Link.Left); Index := Index + 1; Link_List (Index) := Link; Traverse_Subtree (Link.Right); end if; end Traverse_Subtree; begin -- FILL_LIST -- if TABLE.COUNT /= LINK_LIST'LAST then -- raise CONSTRAINT_ERROR; -- end if; -- Statements provided for debugging. Traverse_Subtree (Table.Root); end Fill_List; function "=" (Left, Right : Table_Type) return Boolean is -- Set equality; the LEFT and RIGHT tables contain entries with same -- values Left_Op_Link_List : Link_List_Type (1 .. Left.Count); Right_Op_Link_List : Link_List_Type (1 .. Right.Count); begin -- "=" if Left.Root = Right.Root then -- LEFT and RIGHT points to the same table. return True; end if; if Left.Count /= Right.Count then return False; end if; if Left.Count = 0 then -- two empty tables return True; end if; Fill_List (Left, Left_Op_Link_List); Fill_List (Right, Right_Op_Link_List); for Index in 1 .. Left.Count loop if not Equals (Left_Op_Link_List (Index).Key, Right_Op_Link_List (Index).Key) then return False; end if; end loop; return True; end "="; function "<" (Left, Right : Table_Type) return Boolean is -- Strict set inclusion; to each entry in the LEFT table an entry with -- same value is associated in the RIGHT table, but the two sets are not -- identical. Left_Op_Link_List : Link_List_Type (1 .. Left.Count); Right_Op_Link_List : Link_List_Type (1 .. Right.Count); Found : Boolean; Right_Index : Positive := 1; begin -- "<" if Left.Count >= Right.Count then -- The case of identical sets is processed here. return False; end if; if Left.Count = 0 then return True; end if; Fill_List (Left, Left_Op_Link_List); Fill_List (Right, Right_Op_Link_List); for Left_Index in 1 .. Left.Count loop Found := False; while Right_Index <= Right.Count loop if Equals (Left_Op_Link_List (Left_Index).Key, Right_Op_Link_List (Right_Index).Key) then Found := True; Right_Index := Right_Index + 1; exit; -- inner loop end if; Right_Index := Right_Index + 1; end loop; if not Found then -- item associated with LEFT_INDEX has not been found in RIGHT -- table. return False; end if; end loop; return True; end "<"; function "<=" (Left, Right : Table_Type) return Boolean is -- Strict set inclusion; to each entry in the LEFT table an entry with -- same key is associated in the RIGHT table. Left_Op_Link_List : Link_List_Type (1 .. Left.Count); Right_Op_Link_List : Link_List_Type (1 .. Right.Count); Found : Boolean; Right_Index : Positive := 1; begin -- "<=" if Left.Root = Right.Root then -- LEFT and RIGHT points to the same table. return True; end if; if Left.Count > Right.Count then return False; end if; if Left.Count = 0 then return True; end if; Fill_List (Left, Left_Op_Link_List); Fill_List (Right, Right_Op_Link_List); for Left_Index in 1 .. Left.Count loop Found := False; while Right_Index <= Right.Count loop if Equals (Left_Op_Link_List (Left_Index).Key, Right_Op_Link_List (Right_Index).Key) then Found := True; Right_Index := Right_Index + 1; exit; -- inner loop end if; Right_Index := Right_Index + 1; end loop; if not Found then -- item associated with LEFT_INDEX has not been found in -- RIGHT table. return False; end if; end loop; return True; end "<="; function ">" (Left, Right : Table_Type) return Boolean is begin -- ">" return Right < Left; end ">"; function ">=" (Left, Right : Table_Type) return Boolean is begin -- ">=" return Right <= Left; end ">="; end Set_Operations_G; -- / ITERATORS: procedure Traverse_Asc_G (Table : Table_Type) is Order_Number : Positive := 1; Continue : Boolean := True; procedure Traverse_Subtree (Link : Link_Type); procedure Traverse_Subtree (Link : Link_Type) is begin if Link.Left /= null then Traverse_Subtree (Link.Left); end if; if Continue then Action (Link.Key, Link.Value, Order_Number, Continue); Order_Number := Order_Number + 1; end if; if Continue and then Link.Right /= null then Traverse_Subtree (Link.Right); end if; end Traverse_Subtree; begin -- TRAVERSE_ASC_G if Table.Root /= null then Traverse_Subtree (Table.Root); end if; end Traverse_Asc_G; procedure Traverse_Desc_G (Table : Table_Type) is Order_Number : Positive := 1; Continue : Boolean := True; procedure Traverse_Subtree (Link : Link_Type); procedure Traverse_Subtree (Link : Link_Type) is begin if Link.Right /= null then Traverse_Subtree (Link.Right); end if; if Continue then Action (Link.Key, Link.Value, Order_Number, Continue); Order_Number := Order_Number + 1; end if; if Continue and then Link.Left /= null then Traverse_Subtree (Link.Left); end if; end Traverse_Subtree; begin -- TRAVERSE_DESC_G if Table.Root /= null then Traverse_Subtree (Table.Root); end if; end Traverse_Desc_G; procedure Traverse_Asc_And_Update_Value_G (Table : in out Table_Type) is Order_Number : Positive := 1; Continue : Boolean := True; procedure Traverse_Subtree (Link : Link_Type); procedure Traverse_Subtree (Link : Link_Type) is begin if Link.Left /= null then Traverse_Subtree (Link.Left); end if; if Continue then Modify (Link.Key, Link.Value, Order_Number, Continue); Order_Number := Order_Number + 1; end if; if Continue and then Link.Right /= null then Traverse_Subtree (Link.Right); end if; end Traverse_Subtree; begin -- TRAVERSE_ASC_AND_UPDATE_VALUE_G if Table.Root /= null then Traverse_Subtree (Table.Root); end if; end Traverse_Asc_And_Update_Value_G; procedure Traverse_Desc_And_Update_Value_G (Table : in out Table_Type) is Order_Number : Positive := 1; Continue : Boolean := True; procedure Traverse_Subtree (Link : Link_Type); procedure Traverse_Subtree (Link : Link_Type) is begin if Link.Right /= null then Traverse_Subtree (Link.Right); end if; if Continue then Modify (Link.Key, Link.Value, Order_Number, Continue); Order_Number := Order_Number + 1; end if; if Continue and then Link.Left /= null then Traverse_Subtree (Link.Left); end if; end Traverse_Subtree; begin -- TRAVERSE_DESC_AND_UPDATE_VALUE_G if Table.Root /= null then Traverse_Subtree (Table.Root); end if; end Traverse_Desc_And_Update_Value_G; procedure Disorder_Traverse_G (Table : Table_Type) is Current : Link_Type; Insert_Position : Positive; Link_List : Link_List_Type (1 .. Table.Count); Continue : Boolean := True; begin -- DISORDER_TRAVERSE_G if Table.Count = 0 then return; end if; Link_List (1) := Table.Root; Insert_Position := 2; for Order_Number in 1 .. Table.Count loop Current := Link_List (Order_Number); Action (Current.Key, Current.Value, Order_Number, Continue); if not Continue then exit; end if; if Current.Left /= null then Link_List (Insert_Position) := Current.Left; Insert_Position := Insert_Position + 1; end if; if Current.Right /= null then Link_List (Insert_Position) := Current.Right; Insert_Position := Insert_Position + 1; end if; end loop; end Disorder_Traverse_G; procedure Disorder_Traverse_And_Update_Value_G (Table : in out Table_Type) is Current : Link_Type; Insert_Position : Positive; Link_List : Link_List_Type (1 .. Table.Count); Continue : Boolean := True; begin -- DISORDER_TRAVERSE_AND_UPDATE_VALUE_G if Table.Count = 0 then return; end if; Link_List (1) := Table.Root; Insert_Position := 2; for Order_Number in 1 .. Table.Count loop Current := Link_List (Order_Number); Modify (Current.Key, Current.Value, Order_Number, Continue); if not Continue then exit; end if; if Current.Left /= null then Link_List (Insert_Position) := Current.Left; Insert_Position := Insert_Position + 1; end if; if Current.Right /= null then Link_List (Insert_Position) := Current.Right; Insert_Position := Insert_Position + 1; end if; end loop; end Disorder_Traverse_And_Update_Value_G; -- / HEAP MANAGEMENT: procedure Destroy (Table : in out Table_Type) is Current : Link_Type; Insert_Position : Positive; Link_List : Link_List_Type (1 .. Table.Count); begin -- DESTROY if Table.Count = 0 then return; end if; -- May optimize. Link_List (1) := Table.Root; Insert_Position := 2; for Fetch_Position in 1 .. Table.Count loop Current := Link_List (Fetch_Position); if Current.Left /= null then Link_List (Insert_Position) := Current.Left; Insert_Position := Insert_Position + 1; end if; if Current.Right /= null then Link_List (Insert_Position) := Current.Right; Insert_Position := Insert_Position + 1; end if; Release (Current); end loop; Table := (null, 0, True); end Destroy; procedure Release_Free_List is Temp : Link_Type; begin while Free_List.Ptr /= null loop Temp := Free_List.Ptr; Free_List.Ptr := Free_List.Ptr.Right; Dispose (Temp); end loop; Free_List.Count := 0; end Release_Free_List; procedure Set_Max_Free_List_Size (Max_Free_List_Size : Natural) is Nb_Of_Cells_For_System : constant Integer := Free_List.Count - Max_Free_List_Size; Temp : Link_Type; begin if Nb_Of_Cells_For_System > 0 then for I in 1 .. Nb_Of_Cells_For_System loop Temp := Free_List.Ptr; Free_List.Ptr := Free_List.Ptr.Right; Dispose (Temp); end loop; Free_List.Count := Free_List.Count - Nb_Of_Cells_For_System; end if; Table_Of_Static_Keys_And_Dynamic_Values_G.Max_Free_List_Size := Max_Free_List_Size; end Set_Max_Free_List_Size; function Free_List_Size return Natural is begin return Free_List.Count; end Free_List_Size; procedure Assign_Item (Destination : out Key_Type; Source : Key_Type) is begin Destination := Source; end Assign_Item; procedure Destroy_Item (Item : Key_Type) is -- Mode of the parameter is artificial, but mode 'out' could raise -- CONSTRAINT_ERROR ! begin pragma Warnings (Off); pragma Unreferenced (Item); pragma Warnings (On); null; end Destroy_Item; pragma Inline (Assign_Item); pragma Inline (Destroy_Item); end Table_Of_Static_Keys_And_Dynamic_Values_G; polyorb-2.8~20110207.orig/src/aws_orig/aws-config-ini.adb0000644000175000017500000002224411750740337022277 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- A W S . C O N F I G . I N I -- -- -- -- B o d y -- -- -- -- Copyright (C) 2000-2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with Ada.Command_Line; with Ada.Strings.Fixed; with Ada.Strings.Maps; with Ada.Text_IO; with AWS.Utils; package body AWS.Config.Ini is use Ada; function Program_Ini_File return String; -- Returns initialization filename for current server (using the -- executable name and adding .ini) procedure Read_If_Present (Config : in out Object; Filename : String); -- Read and parse Filename, does not raise an exception if the file does -- not exists. ---------------------- -- Program_Ini_File -- ---------------------- function Program_Ini_File return String is Exec_Name : constant String := Ada.Command_Line.Command_Name; Last : Natural; First : Natural; begin First := Strings.Fixed.Index (Exec_Name, Strings.Maps.To_Set ("/\"), Going => Strings.Backward); if First = 0 then First := Exec_Name'First; end if; Last := Strings.Fixed.Index (Exec_Name (First .. Exec_Name'Last), ".", Strings.Backward); if Last = 0 then return Exec_Name & ".ini"; else return Exec_Name (Exec_Name'First .. Last) & "ini"; end if; end Program_Ini_File; ---------- -- Read -- ---------- procedure Read (Config : in out Object; Filename : String) is procedure Error_Message (Filename : String; Message : String); -- Output error message with filename and line number. procedure Set_Value (Filename : String; Key : String; Value : String); Line : Natural; -- current line number parsed Process_Mode : constant Boolean := True; -- Set to True when parsing a file that can support per process -- options. ------------------- -- Error_Message -- ------------------- procedure Error_Message (Filename : String; Message : String) is begin Text_IO.Put (Text_IO.Current_Error, '(' & Filename & ':'); Text_IO.Put (Text_IO.Current_Error, AWS.Utils.Image (Line)); Text_IO.Put_Line (Text_IO.Current_Error, ") " & Message & '.'); end Error_Message; --------------- -- Set_Value -- --------------- procedure Set_Value (Filename : String; Key : String; Value : String) is function "+" (S : String) return Unbounded_String renames To_Unbounded_String; Expected_Type : Unbounded_String; P : Parameter_Name; begin begin P := Parameter_Name'Value (Key); exception when others => Error_Message (Filename, "unrecognized option " & Key); return; end; if P in Server_Parameter_Name then case Config.P (P).Kind is when Str => Expected_Type := +"string"; Config.P (P).Str_Value := +Value; when Dir => Expected_Type := +"string"; if Value (Value'Last) = '/' or else Value (Value'Last) = '\' then Config.P (P).Dir_Value := +Value; else Config.P (P).Dir_Value := +(Value & '/'); end if; when Pos => Expected_Type := +"positive"; Config.P (P).Pos_Value := Positive'Value (Value); when Dur => Expected_Type := +"duration"; Config.P (P).Dur_Value := Duration'Value (Value); when Bool => Expected_Type := +"boolean"; Config.P (P).Bool_Value := Boolean'Value (Value); end case; else if not Process_Mode then Error_Message (Filename, "Per process option (" & Key & ") not supported for this file"); end if; case Process_Options (P).Kind is when Str => Expected_Type := +"string"; Process_Options (P).Str_Value := +Value; when Dir => Expected_Type := +"string"; if Value (Value'Last) = '/' or else Value (Value'Last) = '\' then Process_Options (P).Dir_Value := +Value; else Process_Options (P).Dir_Value := +(Value & '/'); end if; when Pos => Expected_Type := +"positive"; Process_Options (P).Pos_Value := Positive'Value (Value); when Dur => Expected_Type := +"duration"; Process_Options (P).Dur_Value := Duration'Value (Value); when Bool => Expected_Type := +"boolean"; Process_Options (P).Bool_Value := Boolean'Value (Value); end case; end if; exception when others => Error_Message (Filename, "wrong value for " & Key & " " & To_String (Expected_Type) & " expected"); end Set_Value; Separators : constant Strings.Maps.Character_Set := Strings.Maps.To_Set (' ' & ASCII.HT); File : Text_IO.File_Type; Buffer : String (1 .. 1024); Last : Natural; K_First : Natural; K_Last : Natural; begin Text_IO.Open (Name => Filename, File => File, Mode => Text_IO.In_File); Line := 0; while not Text_IO.End_Of_File (File) loop Text_IO.Get_Line (File, Buffer, Last); Line := Line + 1; -- Remove comments for I in 1 .. Last loop if Buffer (I) = '#' then Last := I - 1; exit; end if; end loop; if Last /= 0 then -- Looks for Key token Strings.Fixed.Find_Token (Buffer (1 .. Last), Separators, Strings.Outside, K_First, K_Last); if K_Last /= 0 then declare Key : constant String := Buffer (K_First .. K_Last); Value : constant String := Strings.Fixed.Trim (Buffer (K_Last + 1 .. Last), Separators, Separators); begin if Value = "" then Error_Message (Filename, "No value for " & Key); else Set_Value (Filename, Key, Value); end if; end; else Error_Message (Filename, "wrong format"); end if; end if; end loop; Text_IO.Close (File); end Read; --------------------- -- Read_If_Present -- --------------------- procedure Read_If_Present (Config : in out Object; Filename : String) is begin Read (Config, Filename); exception when Text_IO.Name_Error => null; end Read_If_Present; begin Read_If_Present (Server_Config, "aws.ini"); Read_If_Present (Server_Config, Program_Ini_File); end AWS.Config.Ini; polyorb-2.8~20110207.orig/src/aws_orig/aws-containers-tables.ads0000644000175000017500000001446311750740337023717 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- A W S . C O N T A I N E R S . T A B L E S -- -- -- -- S p e c -- -- -- -- Copyright (C) 2000-2007, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with Ada.Strings.Unbounded; with GNAT.Dynamic_Tables; with Table_Of_Strings_And_Static_Values_G; pragma Elaborate_All (Table_Of_Strings_And_Static_Values_G); package AWS.Containers.Tables is type Table_Type is tagged private; type Element (Name_Length, Value_Length : Natural) is record Name : String (1 .. Name_Length); Value : String (1 .. Value_Length); end record; -- Data type to store name/value pair retrieved from a Table_Type. type VString_Array is array (Positive range <>) of Ada.Strings.Unbounded.Unbounded_String; function Count (Table : Table_Type) return Natural; -- Returns the number of item in Table. function Name_Count (Table : Table_Type) return Natural; -- Returns the number of unique key name in Table. function Count (Table : Table_Type; Name : String) return Natural; -- Returns the number of value for Key Name in Table. It returns -- 0 if Key does not exist. function Exist (Table : Table_Type; Name : String) return Boolean; -- Returns True if Key exist in Table. function Get (Table : Table_Type; Name : String; N : Positive := 1) return String; -- Returns the Nth value associated with Key into Table. Returns -- the emptry string if key does not exist. function Get_Name (Table : Table_Type; N : Positive := 1) return String; -- Returns the Nth Name in Table or the empty string if there is -- no parameter with this number. function Get_Value (Table : Table_Type; N : Positive := 1) return String; -- Returns the Nth Value in Table or the empty string if there is -- no parameter with this number. function Get (Table : Table_Type; N : Positive) return Element; -- Return N'th name/value pair. function Get_Names (Table : Table_Type; Sort : Boolean := False) return VString_Array; -- Returns array of unique key names. If Sort is True, the returned names -- array is sorted in alphabetical order. This is of course slightly -- slower than returning unsorted results. function Get_Values (Table : Table_Type; Name : String) return VString_Array; -- Returns all values for the specified parameter key name. private -- A Table_Type must be initialized by calling -- AWS.Containers.Tables.Set.Reset, Server is responsible for doing that. type Element_Access is access all Element; -- Data type to keep the name/value pair in the -- GNAT.Dynamic_Tables.Table_Type. -- We cannot use Unbounded_String becouse GNAT.Dynamic_Tables -- does not support controlled objects. type Key_Positive is new Positive; package Name_Indexes is new GNAT.Dynamic_Tables (Table_Component_Type => Positive, Table_Index_Type => Key_Positive, Table_Low_Bound => 1, Table_Initial => 4, Table_Increment => 30); subtype Name_Index_Table is Name_Indexes.Instance; package Data_Table is new GNAT.Dynamic_Tables (Table_Component_Type => Element_Access, Table_Index_Type => Natural, Table_Low_Bound => 1, Table_Initial => 8, Table_Increment => 30); package Index_Table is new Table_Of_Strings_And_Static_Values_G (Character, String, "<", "=", Name_Index_Table); -- Index of the Element_Array. type Index_Table_Type is new Index_Table.Table_Type; type Index_Access is access Index_Table_Type; type Table_Type is tagged record Case_Sensitive : Boolean := True; Index : Index_Access; -- Index to find appropriate Name/Value pairs in Data by the name Data : Data_Table.Instance; -- Ordered array of name and value pairs end record; function Internal_Get (Table : Table_Type; Name : String; N : Natural) return String; pragma Inline (Internal_Get); -- Returns the Nth value associated with Key into Table. Returns -- the emptry string if key does not exist. If N = 0 it returns as-is all -- the values as inserted in the tree for Key. function Normalize_Name (Name : String; To_Upper : Boolean) return String; -- Returns Name in upper case if To_Upper is set to True and it returns -- Name unchanged otherwise. end AWS.Containers.Tables; polyorb-2.8~20110207.orig/src/aws_orig/aws-log.ads0000644000175000017500000001233611750740337021060 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- A W S . L O G -- -- -- -- S p e c -- -- -- -- Copyright (C) 2000-2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- This package handle the logging facility for AWS. The log file is named -- '-Y-M-D.log' and is written by default in the directory where -- the server is launched, see configuration file. -- -- Note that this package is used internaly by AWS to log server requests but -- it can also be used by users to handle application's log. with Ada.Text_IO; with Ada.Strings.Unbounded; with AWS.Status; with AWS.Response; with AWS.Messages; package AWS.Log is type Object is limited private; -- A log object. It must be activated by calling Start below. type Split_Mode is (None, Each_Run, Daily, Monthly); -- It specifies when to create a new log file. -- None : all log info gets accumulated into the same file. -- Each_Run : a new log file is created each time the server is started. -- Daily : a new log file is created each day. -- Monthly : a new log file is created each month. Not_Specified : constant String := ""; procedure Start (Log : in out Object; Split : Split_Mode := None; File_Directory : String := Not_Specified; Filename_Prefix : String := Not_Specified); -- Activate server's activity logging. Split indicate the way the log file -- should be created. Log_File_Prefix is the log filename prefix. If it is -- not specified the default prefix is the program name. procedure Write (Log : in out Object; Connect_Stat : Status.Data; Answer : Response.Data); -- Write log info if activated (i.e. Start routine above has been called). procedure Write (Log : in out Object; Connect_Stat : Status.Data; Status_Code : Messages.Status_Code; Content_Length : Natural); -- Write log info if activated (i.e. Start routine above has been called). -- This version separated the Content_Length from Status.Data, this is -- required for example in the case of a user defined stream content. See -- AWS.Resources.Stream. procedure Write (Log : in out Object; Connect_Stat : Status.Data; Data : String); -- Write user's log info if activated. (i.e. Start routine above has been -- called). procedure Write (Log : in out Object; Data : String); -- Write Data into the log file. This Data is unstructured, only a time -- tag prefix is prepended to Data. This routine is designed to be used -- for user's info in error log file. procedure Stop (Log : in out Object); -- Stop logging activity. function Is_Active (Log : Object) return Boolean; -- Returns True if Log is activated. function Filename (Log : Object) return String; -- Returns current log filename or the empty string if the log is not -- activated. function Mode (Log : Object) return Split_Mode; -- Returns the split mode. None will be returned if log is not activated. private use Ada; use Ada.Strings.Unbounded; type Object is limited record File : Text_IO.File_Type; File_Directory : Unbounded_String; Filename_Prefix : Unbounded_String; Split : Split_Mode := None; Current_Tag : Positive; end record; end AWS.Log; polyorb-2.8~20110207.orig/src/aws_orig/aws-config.adb0000644000175000017500000002513211750740337021521 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- A W S . C O N F I G -- -- -- -- B o d y -- -- -- -- Copyright (C) 2000-2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with AWS.Config.Ini; -- This package is not used, but it is loaded here to initialize the -- Server_Config variable. pragma Warnings (Off, AWS.Config.Ini); package body AWS.Config is ----------------------- -- Accept_Queue_Size -- ----------------------- function Accept_Queue_Size (O : Object) return Positive is begin return O.P (Accept_Queue_Size).Pos_Value; end Accept_Queue_Size; --------------- -- Admin_URI -- --------------- function Admin_URI (O : Object) return String is begin return To_String (O.P (Admin_URI).Str_Value); end Admin_URI; ------------------------------- -- Case_Sensitive_Parameters -- ------------------------------- function Case_Sensitive_Parameters (O : Object) return Boolean is begin return O.P (Case_Sensitive_Parameters).Bool_Value; end Case_Sensitive_Parameters; ----------------- -- Certificate -- ----------------- function Certificate return String is begin return To_String (Process_Options (Certificate).Str_Value); end Certificate; ------------------------ -- Check_URL_Validity -- ------------------------ function Check_URL_Validity (O : Object) return Boolean is begin return O.P (Check_URL_Validity).Bool_Value; end Check_URL_Validity; --------------------------------- -- Cleaner_Client_Data_Timeout -- --------------------------------- function Cleaner_Client_Data_Timeout (O : Object) return Duration is begin return O.P (Cleaner_Client_Data_Timeout).Dur_Value; end Cleaner_Client_Data_Timeout; ----------------------------------- -- Cleaner_Client_Header_Timeout -- ----------------------------------- function Cleaner_Client_Header_Timeout (O : Object) return Duration is begin return O.P (Cleaner_Client_Header_Timeout).Dur_Value; end Cleaner_Client_Header_Timeout; ------------------------------------- -- Cleaner_Server_Response_Timeout -- ------------------------------------- function Cleaner_Server_Response_Timeout (O : Object) return Duration is begin return O.P (Cleaner_Server_Response_Timeout).Dur_Value; end Cleaner_Server_Response_Timeout; ------------------------------------- -- Cleaner_Wait_For_Client_Timeout -- ------------------------------------- function Cleaner_Wait_For_Client_Timeout (O : Object) return Duration is begin return O.P (Cleaner_Wait_For_Client_Timeout).Dur_Value; end Cleaner_Wait_For_Client_Timeout; ---------------- -- Down_Image -- ---------------- function Down_Image (O : Object) return String is begin return To_String (O.P (Down_Image).Str_Value); end Down_Image; ------------------------------- -- Error_Log_Filename_Prefix -- ------------------------------- function Error_Log_Filename_Prefix (O : Object) return String is begin return To_String (O.P (Error_Log_Filename_Prefix).Str_Value); end Error_Log_Filename_Prefix; -------------------------- -- Error_Log_Split_Mode -- -------------------------- function Error_Log_Split_Mode (O : Object) return String is begin return To_String (O.P (Error_Log_Split_Mode).Str_Value); end Error_Log_Split_Mode; ------------------------------- -- Force_Client_Data_Timeout -- ------------------------------- function Force_Client_Data_Timeout (O : Object) return Duration is begin return O.P (Force_Client_Data_Timeout).Dur_Value; end Force_Client_Data_Timeout; --------------------------------- -- Force_Client_Header_Timeout -- --------------------------------- function Force_Client_Header_Timeout (O : Object) return Duration is begin return O.P (Force_Client_Header_Timeout).Dur_Value; end Force_Client_Header_Timeout; ----------------------------------- -- Force_Server_Response_Timeout -- ----------------------------------- function Force_Server_Response_Timeout (O : Object) return Duration is begin return O.P (Force_Server_Response_Timeout).Dur_Value; end Force_Server_Response_Timeout; ----------------------------------- -- Force_Wait_For_Client_Timeout -- ----------------------------------- function Force_Wait_For_Client_Timeout (O : Object) return Duration is begin return O.P (Force_Wait_For_Client_Timeout).Dur_Value; end Force_Wait_For_Client_Timeout; ----------------- -- Get_Current -- ----------------- function Get_Current return Object is begin return Server_Config; end Get_Current; ------------------ -- Hotplug_Port -- ------------------ function Hotplug_Port (O : Object) return Positive is begin return O.P (Hotplug_Port).Pos_Value; end Hotplug_Port; --------------------- -- Line_Stack_Size -- --------------------- function Line_Stack_Size (O : Object) return Positive is begin return O.P (Line_Stack_Size).Pos_Value; end Line_Stack_Size; ------------------------ -- Log_File_Directory -- ------------------------ function Log_File_Directory (O : Object) return String is begin return To_String (O.P (Log_File_Directory).Dir_Value); end Log_File_Directory; ------------------------- -- Log_Filename_Prefix -- ------------------------- function Log_Filename_Prefix (O : Object) return String is begin return To_String (O.P (Log_Filename_Prefix).Str_Value); end Log_Filename_Prefix; -------------------- -- Log_Split_Mode -- -------------------- function Log_Split_Mode (O : Object) return String is begin return To_String (O.P (Log_Split_Mode).Str_Value); end Log_Split_Mode; ---------------- -- Logo_Image -- ---------------- function Logo_Image (O : Object) return String is begin return To_String (O.P (Logo_Image).Str_Value); end Logo_Image; -------------------- -- Max_Connection -- -------------------- function Max_Connection (O : Object) return Positive is begin return O.P (Max_Connection).Pos_Value; end Max_Connection; --------------------- -- Receive_Timeout -- --------------------- function Receive_Timeout (O : Object) return Duration is begin return O.P (Receive_Timeout).Dur_Value; end Receive_Timeout; -------------- -- Security -- -------------- function Security (O : Object) return Boolean is begin return O.P (Security).Bool_Value; end Security; ------------------ -- Send_Timeout -- ------------------ function Send_Timeout (O : Object) return Duration is begin return O.P (Send_Timeout).Dur_Value; end Send_Timeout; ----------------- -- Server_Host -- ----------------- function Server_Host (O : Object) return String is begin return To_String (O.P (Server_Host).Str_Value); end Server_Host; ----------------- -- Server_Name -- ----------------- function Server_Name (O : Object) return String is begin return To_String (O.P (Server_Name).Str_Value); end Server_Name; ----------------- -- Server_Port -- ----------------- function Server_Port (O : Object) return Positive is begin return O.P (Server_Port).Pos_Value; end Server_Port; ------------- -- Session -- ------------- function Session (O : Object) return Boolean is begin return O.P (Session).Bool_Value; end Session; ------------------------------ -- Session_Cleanup_Interval -- ------------------------------ function Session_Cleanup_Interval return Duration is begin return Process_Options (Session_Cleanup_Interval).Dur_Value; end Session_Cleanup_Interval; ---------------------- -- Session_Lifetime -- ---------------------- function Session_Lifetime return Duration is begin return Process_Options (Session_Lifetime).Dur_Value; end Session_Lifetime; ----------------- -- Status_Page -- ----------------- function Status_Page (O : Object) return String is begin return To_String (O.P (Status_Page).Str_Value); end Status_Page; -------------- -- Up_Image -- -------------- function Up_Image (O : Object) return String is begin return To_String (O.P (Up_Image).Str_Value); end Up_Image; ---------------------- -- Upload_Directory -- ---------------------- function Upload_Directory (O : Object) return String is begin return To_String (O.P (Upload_Directory).Dir_Value); end Upload_Directory; -------------- -- WWW_Root -- -------------- function WWW_Root (O : Object) return String is begin return To_String (O.P (WWW_Root).Dir_Value); end WWW_Root; end AWS.Config; polyorb-2.8~20110207.orig/src/aws_orig/templates_parser-print_tree.adb0000644000175000017500000001035511750740337025210 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P R I N T _ T R E E -- -- -- -- B o d y -- -- -- -- Copyright (C) 1999-2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with Ada.Text_IO; separate (Templates_Parser) procedure Print_Tree (T : Tree; Level : Natural := 0) is procedure Print_Indent (L : Natural); procedure Print_Indent (L : Natural) is use Ada.Strings.Fixed; begin Text_IO.Put ((L * 2) * ' '); end Print_Indent; begin if T = null then return; end if; Print_Indent (Level); case T.Kind is when Info => Text_IO.Put_Line ("[INFO] " & To_String (T.Filename) & Natural'Image (T.Ref)); declare I : Tree := T.I_File; begin while I /= null loop Text_IO.Put (" -> "); Text_IO.Put_Line (To_String (I.File.Info.Filename)); I := I.Next; end loop; end; Print_Tree (T.Next, Level); when C_Info => Text_IO.Put_Line ("[C_INFO] " & Natural'Image (T.Used) & ' ' & Boolean'Image (T.Obsolete)); Print_Tree (T.Next, Level); when Text => Text_IO.Put ("[TEXT] "); Data.Print_Tree (T.Text); Print_Tree (T.Next, Level); when If_Stmt => Text_IO.Put ("[IF_STMT] "); Expr.Print_Tree (T.Cond); Text_IO.New_Line; Print_Tree (T.N_True, Level + 1); Print_Indent (Level); Text_IO.Put_Line ("[ELSE]"); Print_Tree (T.N_False, Level + 1); Print_Indent (Level); Text_IO.Put_Line ("[END_IF_STMT]"); Print_Tree (T.Next, Level); when Table_Stmt => Text_IO.Put_Line ("[TABLE_STMT] TERMINATE_SECTIONS=" & Boolean'Image (T.Terminate_Sections)); Print_Tree (T.Sections, Level + 1); Print_Indent (Level); Text_IO.Put_Line ("[END_TABLE_STMT]"); Print_Tree (T.Next, Level); when Section_Stmt => Text_IO.Put_Line ("[SECTION_STMT]"); Print_Tree (T.Next, Level + 1); Print_Tree (T.N_Section, Level); when Include_Stmt => Text_IO.Put_Line ("[INCLUDE_STMT] " & To_String (T.File.Info.Filename)); Print_Tree (T.File.Info, Level + 1); Print_Tree (T.Next, Level); end case; end Print_Tree; polyorb-2.8~20110207.orig/src/aws_orig/aws-config.ads0000644000175000017500000003642311750740337021547 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- A W S . C O N F I G -- -- -- -- S p e c -- -- -- -- Copyright (C) 2000-2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- This package provide an easy way to handle server configuration options. -- -- If initialization of this package is not done all functions below will -- return the default value as declared in AWS.Default. with Ada.Strings.Unbounded; with AWS.Default; package AWS.Config is use Ada.Strings.Unbounded; type Object is private; Default_Config : constant Object; function Get_Current return Object; -- Returns a configuration record. This is the properties as read in files -- 'aws.ini' and 'progname.ini'. This configuration object holds only the -- per-server options. ------------------------ -- Per Server options -- ------------------------ function Server_Name (O : Object) return String; pragma Inline (Server_Name); -- This is the name of the server as set by AWS.Server.Start. function WWW_Root (O : Object) return String; pragma Inline (WWW_Root); -- This is the root directory name for the server. This variable is not -- used internally by AWS. It is supposed to be used by the callback -- procedures who want to retrieve physical objects (images, Web -- pages...). The default value is the current working directory. function Admin_URI (O : Object) return String; pragma Inline (Admin_URI); -- This is the name of the admin server page as set by AWS.Server.Start. function Server_Host (O : Object) return String; pragma Inline (Server_Host); -- This is the server host. Can be used if the computer has a more than -- one IP addresses. It is possible to have two servers at the same port -- on the same machine, both being binded on different IP addresses. function Server_Port (O : Object) return Positive; pragma Inline (Server_Port); -- This is the server port as set by the HTTP object declaration. function Hotplug_Port (O : Object) return Positive; pragma Inline (Hotplug_Port); -- This is the hotplug communication port needed to register and -- un-register an hotplug module. function Max_Connection (O : Object) return Positive; pragma Inline (Max_Connection); -- This is the max simultaneous connections as set by the HTTP object -- declaration. function Accept_Queue_Size (O : Object) return Positive; pragma Inline (Accept_Queue_Size); -- This is the size of the queue for the incoming requests. Higher this -- value will be and less "connection refused" will be reported to the -- client. function Log_File_Directory (O : Object) return String; pragma Inline (Log_File_Directory); -- This point to the directory where log files will be written. The -- directory returned will end with a directory separator. function Log_Filename_Prefix (O : Object) return String; pragma Inline (Log_Filename_Prefix); -- This is the prefix to use for the log filename. function Log_Split_Mode (O : Object) return String; pragma Inline (Log_Split_Mode); -- This is split mode for the log file. Possible values are : Each_Run, -- Daily, Monthly and None. Any other values will raise an exception. function Error_Log_Filename_Prefix (O : Object) return String; pragma Inline (Error_Log_Filename_Prefix); -- This is the prefix to use for the log filename. function Error_Log_Split_Mode (O : Object) return String; pragma Inline (Error_Log_Split_Mode); -- This is split mode for the log file. Possible values are : Each_Run, -- Daily, Monthly and None. Any other values will raise an exception. function Upload_Directory (O : Object) return String; pragma Inline (Upload_Directory); -- This point to the directory where uploaded files will be stored. The -- directory returned will end with a directory separator. function Session (O : Object) return Boolean; pragma Inline (Session); -- Returns True if the server session is activated. function Cleaner_Wait_For_Client_Timeout (O : Object) return Duration; pragma Inline (Cleaner_Wait_For_Client_Timeout); -- Number of seconds to timout on waiting for a client request. -- This is a timeout for regular cleaning task. function Cleaner_Client_Header_Timeout (O : Object) return Duration; pragma Inline (Cleaner_Client_Header_Timeout); -- Number of seconds to timout on waiting for client header. -- This is a timeout for regular cleaning task. function Cleaner_Client_Data_Timeout (O : Object) return Duration; pragma Inline (Cleaner_Client_Data_Timeout); -- Number of seconds to timout on waiting for client message body. -- This is a timeout for regular cleaning task. function Cleaner_Server_Response_Timeout (O : Object) return Duration; pragma Inline (Cleaner_Server_Response_Timeout); -- Number of seconds to timout on waiting for client to accept answer. -- This is a timeout for regular cleaning task. function Force_Wait_For_Client_Timeout (O : Object) return Duration; pragma Inline (Force_Wait_For_Client_Timeout); -- Number of seconds to timout on waiting for a client request. -- This is a timeout for urgent request when resources are missing. function Force_Client_Header_Timeout (O : Object) return Duration; pragma Inline (Force_Client_Header_Timeout); -- Number of seconds to timout on waiting for client header. -- This is a timeout for urgent request when resources are missing. function Force_Client_Data_Timeout (O : Object) return Duration; pragma Inline (Force_Client_Data_Timeout); -- Number of seconds to timout on waiting for client message body. -- This is a timeout for urgent request when resources are missing. function Force_Server_Response_Timeout (O : Object) return Duration; pragma Inline (Force_Server_Response_Timeout); -- Number of seconds to timout on waiting for client to accept answer. -- This is a timeout for urgent request when resources are missing. function Send_Timeout (O : Object) return Duration; pragma Inline (Send_Timeout); -- Number of seconds to timeout when sending chunck of data. function Receive_Timeout (O : Object) return Duration; pragma Inline (Receive_Timeout); -- Number of seconds to timeout when receiving chunck of data. function Status_Page (O : Object) return String; pragma Inline (Status_Page); -- Filename for the status page. function Up_Image (O : Object) return String; pragma Inline (Up_Image); -- Filename for the up arrow image used in the status page. function Down_Image (O : Object) return String; pragma Inline (Down_Image); -- Filename for the down arrow image used in the status page. function Logo_Image (O : Object) return String; pragma Inline (Logo_Image); -- Filename for the AWS logo image used in the status page. function Security (O : Object) return Boolean; pragma Inline (Security); -- Is the server working through th SSL function Certificate return String; pragma Inline (Certificate); -- Returns the certificate to be used with the secure server. Returns the -- empty string if the server is not a secure one. function Case_Sensitive_Parameters (O : Object) return Boolean; pragma Inline (Case_Sensitive_Parameters); -- HTTP parameters are case sensitive. function Check_URL_Validity (O : Object) return Boolean; pragma Inline (Check_URL_Validity); -- Server have to check URI for validity. For example it checks that an -- URL does not reference a resource above the Web root. function Line_Stack_Size (O : Object) return Positive; pragma Inline (Line_Stack_Size); -- HTTP lines stack size. ------------------------- -- Per Process options -- ------------------------- function Session_Cleanup_Interval return Duration; pragma Inline (Session_Cleanup_Interval); -- Number of seconds between each run of the cleaner task to remove -- obsolete session data. function Session_Lifetime return Duration; pragma Inline (Session_Lifetime); -- Number of seconds to keep a session if not used. After this period the -- session data is obsoleted and will be removed during new cleanup. private -- List of token (keyword) recognized by the parser. There must be one -- entry for every option name to be handled. type Parameter_Name is -- Per server option (Server_Name, WWW_Root, Admin_URI, Server_Host, Server_Port, Security, Hotplug_Port, Max_Connection, Accept_Queue_Size, Log_File_Directory, Log_Filename_Prefix, Log_Split_Mode, Error_Log_Filename_Prefix, Error_Log_Split_Mode, Upload_Directory, Session, Cleaner_Wait_For_Client_Timeout, Cleaner_Client_Header_Timeout, Cleaner_Client_Data_Timeout, Cleaner_Server_Response_Timeout, Force_Wait_For_Client_Timeout, Force_Client_Header_Timeout, Force_Client_Data_Timeout, Force_Server_Response_Timeout, Send_Timeout, Receive_Timeout, Status_Page, Up_Image, Down_Image, Logo_Image, Line_Stack_Size, Check_URL_Validity, Case_Sensitive_Parameters, -- Per process options Session_Cleanup_Interval, Certificate, Session_Lifetime); subtype Server_Parameter_Name is Parameter_Name range Server_Name .. Case_Sensitive_Parameters; subtype Process_Parameter_Name is Parameter_Name range Session_Cleanup_Interval .. Session_Lifetime; type Value_Type is (Str, Dir, Pos, Dur, Bool); type Values (Kind : Value_Type := Str) is record case Kind is when Str => Str_Value : Unbounded_String; when Dir => Dir_Value : Unbounded_String; when Pos => Pos_Value : Positive; when Dur => Dur_Value : Duration; when Bool => Bool_Value : Boolean; end case; end record; type Parameter_Set is array (Parameter_Name range <>) of Values; Default_Parameters : constant Parameter_Set (Server_Parameter_Name) := (Cleaner_Wait_For_Client_Timeout => (Dur, Default.Cleaner_Wait_For_Client_Timeout), Cleaner_Client_Header_Timeout => (Dur, Default.Cleaner_Client_Header_Timeout), Cleaner_Client_Data_Timeout => (Dur, Default.Cleaner_Client_Data_Timeout), Cleaner_Server_Response_Timeout => (Dur, Default.Cleaner_Server_Response_Timeout), Force_Wait_For_Client_Timeout => (Dur, Default.Force_Wait_For_Client_Timeout), Force_Client_Header_Timeout => (Dur, Default.Force_Client_Header_Timeout), Force_Client_Data_Timeout => (Dur, Default.Force_Client_Data_Timeout), Force_Server_Response_Timeout => (Dur, Default.Force_Server_Response_Timeout), Send_Timeout => (Dur, Default.Send_Timeout), Receive_Timeout => (Dur, Default.Receive_Timeout), Status_Page => (Str, To_Unbounded_String (Default.Status_Page)), Up_Image => (Str, To_Unbounded_String (Default.Up_Image)), Down_Image => (Str, To_Unbounded_String (Default.Down_Image)), Logo_Image => (Str, To_Unbounded_String (Default.Logo_Image)), Admin_URI => (Str, To_Unbounded_String (Default.Admin_URI)), Server_Name => (Str, To_Unbounded_String (Default.Server_Name)), WWW_Root => (Dir, To_Unbounded_String (Default.WWW_Root)), Log_File_Directory => (Dir, To_Unbounded_String (Default.Log_File_Directory)), Log_Filename_Prefix => (Str, To_Unbounded_String (Default.Log_Filename_Prefix)), Log_Split_Mode => (Str, To_Unbounded_String (Default.Log_Split_Mode)), Error_Log_Filename_Prefix => (Str, To_Unbounded_String (Default.Error_Log_Filename_Prefix)), Error_Log_Split_Mode => (Str, To_Unbounded_String (Default.Error_Log_Split_Mode)), Upload_Directory => (Dir, To_Unbounded_String (Default.Upload_Directory)), Max_Connection => (Pos, Default.Max_Connection), Accept_Queue_Size => (Pos, Default.Accept_Queue_Size), Server_Host => (Str, Null_Unbounded_String), Server_Port => (Pos, Default.Server_Port), Hotplug_Port => (Pos, Default.Hotplug_Port), Session => (Bool, Default.Session), Security => (Bool, Default.Security), Case_Sensitive_Parameters => (Bool, Default.Case_Sensitive_Parameters), Check_URL_Validity => (Bool, Default.Check_URL_Validity), Line_Stack_Size => (Pos, Default.Line_Stack_Size)); type Object is record P : Parameter_Set (Server_Parameter_Name) := Default_Parameters; end record; Default_Config : constant Object := (P => Default_Parameters); Server_Config : Object; -- This variable will be updated with options found in 'aws.ini' and -- 'progname.ini'. Process_Options : Parameter_Set (Process_Parameter_Name) := (Session_Cleanup_Interval => (Dur, Default.Session_Cleanup_Interval), Certificate => (Str, To_Unbounded_String (Default.Certificate)), Session_Lifetime => (Dur, Default.Session_Lifetime)); end AWS.Config; polyorb-2.8~20110207.orig/src/aws_orig/templates_parser-expr.adb0000644000175000017500000002753711750740337024025 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- E X P R -- -- -- -- B o d y -- -- -- -- Copyright (C) 1999-2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with Ada.Text_IO; separate (Templates_Parser) package body Expr is function Is_Op (O : String) return Boolean; -- Returns True is O is a binary operator. function Is_U_Op (O : String) return Boolean; -- Returns True is O is an unary operator. ----------- -- Image -- ----------- function Image (O : Ops) return String is begin case O is when O_And => return "and"; when O_Or => return "or"; when O_Xor => return "xor"; when O_Sup => return ">"; when O_Inf => return "<"; when O_Esup => return ">="; when O_Einf => return "<="; when O_Equal => return "="; when O_Diff => return "/="; end case; end Image; function Image (O : U_Ops) return String is begin case O is when O_Not => return "not"; end case; end Image; ----------- -- Is_Op -- ----------- function Is_Op (O : String) return Boolean is begin if O = "and" then return True; elsif O = "or" then return True; elsif O = "xor" then return True; elsif O = ">" then return True; elsif O = "<" then return True; elsif O = ">=" then return True; elsif O = "<=" then return True; elsif O = "=" then return True; elsif O = "/=" then return True; else return False; end if; end Is_Op; ------------- -- Is_U_Op -- ------------- function Is_U_Op (O : String) return Boolean is begin if O = "not" then return True; else return False; end if; end Is_U_Op; ----------- -- Parse -- ----------- function Parse (Expression : String) return Tree is Index : Natural := Expression'First; function Get_Token return String; -- Returns next token. Set Index to the last analysed position in -- Expression. function No_Quote (Str : String) return String; -- Removes quotes around Str. If Str (Str'First) and Str (Str'Last) -- are quotes return Str (Str'First + 1 .. Str'Last - 1) otherwise -- return Str as-is. --------------- -- Get_Token -- --------------- function Get_Token return String is K, I : Natural; begin if Index > Expression'Last then -- No more data to read. return ""; end if; Index := Fixed.Index (Expression (Index .. Expression'Last), Blank, Outside); if Index = 0 then -- There is only one token, return the whole string. Index := Expression'Last + 1; return Expression (Index .. Expression'Last); elsif Expression (Index) = '(' then -- This is a sub-expression, returns it. K := 0; declare L : Natural := 1; begin Look_For_Sub_Exp : for I in Index + 1 .. Expression'Last loop if Expression (I) = '(' then L := L + 1; elsif Expression (I) = ')' then K := I; L := L - 1; end if; exit Look_For_Sub_Exp when L = 0; end loop Look_For_Sub_Exp; end; if K = 0 then -- No matching closing parenthesis. Exceptions.Raise_Exception (Internal_Error'Identity, "condition, no matching parenthesis for parent at pos " & Natural'Image (Index)); else I := Index; Index := K + 1; return Expression (I .. K); end if; elsif Expression (Index) = '"' then -- This is a string, returns it. K := 0; Look_For_String : for I in Index + 1 .. Expression'Last loop if Expression (I) = '"' then K := I; exit Look_For_String; end if; end loop Look_For_String; if K = 0 then -- No matching closing quote Exceptions.Raise_Exception (Internal_Error'Identity, "condition, no matching closing quote string at pos " & Natural'Image (Index)); else I := Index; Index := K + 1; return Expression (I .. K); end if; else -- We have found the start of a token, look for end of it. K := Fixed.Index (Expression (Index .. Expression'Last), Blank); if K = 0 then -- Token end is the end of Expression. I := Index; Index := Expression'Last + 1; return Expression (I .. Expression'Last); else I := Index; Index := K + 1; return Expression (I .. K - 1); end if; end if; end Get_Token; -------------- -- No_Quote -- -------------- function No_Quote (Str : String) return String is begin if Str (Str'First) = '"' and then Str (Str'Last) = '"' then return Str (Str'First + 1 .. Str'Last - 1); else return Str; end if; end No_Quote; L_Tok : constant String := Get_Token; -- left operand O_Tok : constant String := Get_Token; -- operator R_Tok : constant String := Get_Token; -- right operand begin if Is_U_Op (L_Tok) then if R_Tok = "" then -- This is "not expr" return new Node' (U_Op, Value (L_Tok), Parse (O_Tok & ' ' & R_Tok & ' ' & Expression (Index .. Expression'Last))); else -- This is "not expr op expr", parse again with -- "(not expr) op expr" return Parse ('(' & L_Tok & ' ' & O_Tok & ") " & R_Tok & ' ' & Expression (Index .. Expression'Last)); end if; elsif Is_Op (O_Tok) and then Is_U_Op (R_Tok) then -- We have "expr op u_op expr", parse again with -- "expr op (u_op expr)" return Parse (L_Tok & ' ' & O_Tok & " (" & R_Tok & ' ' & Expression (Index .. Expression'Last) & ')'); elsif O_Tok = "" then -- No more operator, this is a leaf. It is either a variable or a -- value. if L_Tok (L_Tok'First) = '(' then -- an expression return Parse (L_Tok (L_Tok'First + 1 .. L_Tok'Last - 1)); elsif Strings.Fixed.Index (L_Tok, To_String (Begin_Tag)) = 0 then -- a value return new Node'(Value, To_Unbounded_String (No_Quote (L_Tok))); else -- a variable return new Node'(Var, Build (No_Quote (L_Tok))); end if; else if Index > Expression'Last then -- This is the latest token return new Node'(Op, Value (O_Tok), Parse (L_Tok), Parse (R_Tok)); else declare NO_Tok : constant String := Get_Token; begin return new Node' (Op, Value (NO_Tok), Parse (L_Tok & ' ' & O_Tok & ' ' & R_Tok), Parse (Expression (Index .. Expression'Last))); end; end if; end if; end Parse; ---------------- -- Print_Tree -- ---------------- procedure Print_Tree (E : Tree) is begin case E.Kind is when Value => declare Val : constant String := To_String (E.V); K : constant Natural := Fixed.Index (Val, " "); begin if K = 0 then Text_IO.Put (Val); else Text_IO.Put ('"' & Val & '"'); end if; end; when Var => Text_IO.Put (Image (E.Var)); when Op => Text_IO.Put ('('); Print_Tree (E.Left); Text_IO.Put (' ' & Image (E.O) & ' '); Print_Tree (E.Right); Text_IO.Put (')'); when U_Op => Text_IO.Put ('('); Text_IO.Put (Image (E.U_O) & ' '); Print_Tree (E.Next); Text_IO.Put (')'); end case; end Print_Tree; ------------- -- Release -- ------------- procedure Release (E : in out Tree) is procedure Free is new Ada.Unchecked_Deallocation (Node, Tree); begin case E.Kind is when Value => null; when Var => Release (E.Var); when Op => Release (E.Left); Release (E.Right); when U_Op => Release (E.Next); end case; Free (E); end Release; ----------- -- Value -- ----------- function Value (O : String) return Ops is begin if O = "and" then return O_And; elsif O = "or" then return O_Or; elsif O = "xor" then return O_Xor; elsif O = ">" then return O_Sup; elsif O = "<" then return O_Inf; elsif O = ">=" then return O_Esup; elsif O = "<=" then return O_Einf; elsif O = "=" then return O_Equal; elsif O = "/=" then return O_Diff; else Exceptions.Raise_Exception (Internal_Error'Identity, "condition, unknown operator " & O); end if; end Value; function Value (O : String) return U_Ops is begin if O = "not" then return O_Not; else Exceptions.Raise_Exception (Internal_Error'Identity, "condition, unknown operator " & O); end if; end Value; end Expr; polyorb-2.8~20110207.orig/src/aws_orig/aws-parameters.adb0000644000175000017500000000441111750740337022414 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- A W S . P A R A M E T E R S -- -- -- -- B o d y -- -- -- -- Copyright (C) 2000-2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ package body AWS.Parameters is ---------------- -- URI_Format -- ---------------- function URI_Format (Parameter_List : List) return String is begin return To_String (Parameter_List.Parameters); end URI_Format; end AWS.Parameters; polyorb-2.8~20110207.orig/src/aws_orig/aws-session.adb0000644000175000017500000006553511750740337021752 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- A W S . S E S S I O N -- -- -- -- B o d y -- -- -- -- Copyright (C) 2000-2007, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- @@@ uses ada.calendar with Ada.Exceptions; with Ada.Streams.Stream_IO; with Ada.Strings.Unbounded; with Ada.Text_IO; with Table_Of_Static_Keys_And_Dynamic_Values_G; pragma Elaborate_All (Table_Of_Static_Keys_And_Dynamic_Values_G); with AWS.Default; with AWS.Containers.Key_Value; with AWS.Utils; package body AWS.Session is use Ada; use Ada.Strings.Unbounded; use Containers; SID_Prefix : constant String := "SID-"; Session_Check_Interval : Duration := Default.Session_Cleanup_Interval; -- Check for obsolete section every 10 minutes. Session_Lifetime : Duration := Default.Session_Lifetime; -- A session is obsolete if not used after Session_Lifetime seconds. -- table of session ID type Session_Node is record Time_Stamp : Calendar.Time; Root : Key_Value.Set; end record; procedure Assign (Destination : in out Session_Node; Source : Session_Node); procedure Destroy (Value : in out Session_Node); -- Release the Set associated with the Session_Node. package Session_Set is new Table_Of_Static_Keys_And_Dynamic_Values_G (ID, "<", "=", Session_Node, Assign, Destroy); type Session_Set_Access is access all Session_Set.Table_Type; -------------- -- Database -- -------------- protected Database is entry Add_Session (SID : ID); -- Acdd a new session ID into the database. entry New_Session (SID : out ID); -- Add a new session SID into the database. entry Delete_Session (SID : ID); -- Removes session SID from the Tree. function Session_Exist (SID : ID) return Boolean; -- Return True if session SID exist in the database. procedure Touch_Session (SID : ID); -- Updates the session Time_Stamp to current time. Does nothing if SID -- does not exist. entry Key_Exist (SID : ID; Key : String; Result : out Boolean); -- Result is set to True if Key_Name exist in session SID. entry Get_Value (SID : ID; Key : String; Value : out Unbounded_String); -- Value is set with the value associated with the key Key_Name in -- session SID. entry Set_Value (SID : ID; Key, Value : String); -- Add the pair key/value into the session SID. entry Remove_Key (SID : ID; Key : String); -- Removes Key from the session SID. entry Clean; -- Removes old session data that are older than Session_Lifetime -- seconds. -- -- Not safe routines. These are only to be used by iterators and the -- task cleaner. -- procedure Get_Sessions_And_Lock (Sessions : out Session_Set_Access); -- Increment Lock by 1, all entries are lockedand return the Sessions -- tree procedure Unlock; -- Decrement Lock by 1, unlock all entries when Lock return to 0. private Lock : Natural := 0; Sessions : aliased Session_Set.Table_Type; function Generate_ID return ID; -- Retruns a session ID. This ID is not certified to be uniq in the -- system. It is required that the caller check for uniqness if -- necessary. end Database; ------------ -- Assign -- ------------ procedure Assign (Destination : in out Session_Node; Source : Session_Node) is begin Destination.Time_Stamp := Source.Time_Stamp; Key_Value.Assign (Destination.Root, Source.Root); end Assign; ------------- -- Cleaner -- ------------- task body Cleaner is use type Calendar.Time; Next_Run : Calendar.Time := Calendar.Clock + Session_Check_Interval; begin Clean_Dead_Sessions : loop select accept Stop; exit Clean_Dead_Sessions; or delay until Next_Run; end select; Database.Clean; Next_Run := Next_Run + Session_Check_Interval; end loop Clean_Dead_Sessions; exception when E : others => Ada.Text_IO.Put_Line (Ada.Text_IO.Current_Error, "Unrecoverable Error : Cleaner Task bug detected" & Exceptions.Exception_Information (E)); end Cleaner; ------------ -- Create -- ------------ function Create return ID is New_ID : ID; begin Database.New_Session (New_ID); return New_ID; end Create; --------------------- -- Cleaner_Control -- --------------------- protected body Cleaner_Control is ----------- -- Start -- ----------- procedure Start (Session_Check_Interval : Duration; Session_Lifetime : Duration) is begin Server_Count := Server_Count + 1; if Server_Count = 1 then Session.Session_Check_Interval := Start.Session_Check_Interval; Session.Session_Lifetime := Start.Session_Lifetime; Cleaner_Task := new Cleaner; end if; end Start; ---------- -- Stop -- ---------- procedure Stop (Need_Release : out Boolean) is begin Server_Count := Server_Count - 1; if Server_Count = 0 then Need_Release := True; else Need_Release := False; end if; end Stop; end Cleaner_Control; -------------- -- Database -- -------------- type Session_ID_Array is array (Integer range <>) of ID; protected body Database is ----------------- -- Add_Session -- ----------------- entry Add_Session (SID : ID) when Lock = 0 is New_Node : Session_Node; begin New_Node.Time_Stamp := Calendar.Clock; Session_Set.Insert (Sessions, SID, New_Node); end Add_Session; ----------- -- Clean -- ----------- entry Clean when Lock = 0 is Max_Remove : constant := 50; -- Maximum number of items that will get removed at a time. Other -- items will be checked for removal during next run. Remove : Session_ID_Array (1 .. Max_Remove); -- ??? can't use anonymous array here, GNAT bug TN 9023-002 -- Fixed in GNAT 3.15w (20010625). Index : Natural := 0; Now : constant Calendar.Time := Calendar.Clock; procedure Process (SID : ID; Session : Session_Node; Order : Positive; Continue : in out Boolean); -- Iterator callback ------------- -- Process -- ------------- procedure Process (SID : ID; Session : Session_Node; Order : Positive; Continue : in out Boolean) is pragma Warnings (Off, Order); use type Calendar.Time; begin if Session.Time_Stamp + Session_Lifetime < Now then Index := Index + 1; Remove (Index) := SID; if Index = Max_Remove then -- No more space in the removal buffer, quit now. Continue := False; end if; end if; end Process; procedure In_Order is new Session_Set.Traverse_Asc_G (Process); begin In_Order (Sessions); -- delete nodes for K in 1 .. Index loop Session_Set.Remove (Sessions, Remove (K)); end loop; end Clean; -------------------- -- Delete_Session -- -------------------- entry Delete_Session (SID : ID) when Lock = 0 is begin Session_Set.Remove (Sessions, SID); exception when Key_Value.Table.Missing_Item_Error => null; end Delete_Session; ------------------ -- Generate_UID -- ------------------ function Generate_ID return ID is type NID is new AWS.Utils.Random_Integer; Chars : constant String := "0123456789" & "abcdefghijklmnopqrstuvwxyz" & "ABCDEFGHIJKLMNOPQRSTUVWXYZ"; Rand : NID := 0; Result : ID; begin for I in ID'Range loop if Rand = 0 then Rand := Random; end if; Result (I) := Chars (Integer (Rand rem Chars'Length) + 1); Rand := Rand / Chars'Length; end loop; return Result; end Generate_ID; --------------------------- -- Get_Sessions_And_Lock -- --------------------------- procedure Get_Sessions_And_Lock (Sessions : out Session_Set_Access) is begin Lock := Lock + 1; Sessions := Database.Sessions'Access; end Get_Sessions_And_Lock; --------------- -- Get_Value -- --------------- entry Get_Value (SID : ID; Key : String; Value : out Unbounded_String) when Lock = 0 is procedure Modify (SID : ID; Node : in out Session_Node); -- Adjust time stamp and retreive the value associated to key. Found : Boolean; ------------ -- Modify -- ------------ procedure Modify (SID : ID; Node : in out Session_Node) is pragma Warnings (Off, SID); begin Node.Time_Stamp := Calendar.Clock; Key_Value.Get_Value (Node.Root, Key, Value); end Modify; ------------------ -- Update_Value -- ------------------ procedure Update_Value is new Session_Set.Update_Value_Or_Status_G (Modify); begin Update_Value (Sessions, SID, Found); if not Found then Value := Null_Unbounded_String; end if; exception when Key_Value.Table.Missing_Item_Error => Value := Null_Unbounded_String; end Get_Value; --------------- -- Key_Exist -- --------------- entry Key_Exist (SID : ID; Key : String; Result : out Boolean) when Lock = 0 is procedure Modify (SID : ID; Node : in out Session_Node); -- Adjust time stamp and check if Key is present. ------------ -- Modify -- ------------ procedure Modify (SID : ID; Node : in out Session_Node) is pragma Unreferenced (SID); begin Node.Time_Stamp := Calendar.Clock; Result := Key_Value.Is_Present (Node.Root, Key); end Modify; ------------------ -- Update_Value -- ------------------ procedure Update_Value is new Session_Set.Update_Value_Or_Exception_G (Modify); begin Result := False; Update_Value (Sessions, SID); exception when Key_Value.Table.Missing_Item_Error => Result := False; end Key_Exist; ----------------- -- New_Session -- ----------------- entry New_Session (SID : out ID) when Lock = 0 is New_Node : Session_Node; begin Generate_UID : loop SID := Generate_ID; New_Node.Time_Stamp := Calendar.Clock; begin Session_Set.Insert (Sessions, SID, New_Node); exit Generate_UID; exception when Session_Set.Duplicate_Item_Error => -- very low probability but we should catch it -- and try to generate unique key again. null; end; end loop Generate_UID; end New_Session; ------------ -- Remove -- ------------ entry Remove_Key (SID : ID; Key : String) when Lock = 0 is procedure Modify (SID : ID; Node : in out Session_Node); -- Adjust time stamp and removes key. Found : Boolean; ------------ -- Modify -- ------------ procedure Modify (SID : ID; Node : in out Session_Node) is pragma Unreferenced (SID); Was_Present : Boolean; begin Node.Time_Stamp := Calendar.Clock; Key_Value.Remove (Node.Root, Key, Was_Present); end Modify; ------------------ -- Update_Value -- ------------------ procedure Update_Value is new Session_Set.Update_Value_Or_Status_G (Modify); begin Update_Value (Sessions, SID, Found); end Remove_Key; ------------------- -- Session_Exist -- ------------------- function Session_Exist (SID : ID) return Boolean is begin return Session_Set.Is_Present (Sessions, SID); end Session_Exist; --------------- -- Set_Value -- --------------- entry Set_Value (SID : ID; Key, Value : String) when Lock = 0 is procedure Modify (SID : ID; Node : in out Session_Node); -- Adjust time stamp and set key's value. Found : Boolean; ------------ -- Modify -- ------------ procedure Modify (SID : ID; Node : in out Session_Node) is pragma Unreferenced (SID); V : constant Unbounded_String := To_Unbounded_String (Value); begin Node.Time_Stamp := Calendar.Clock; Key_Value.Insert_Or_Replace_Value (Node.Root, Key, V); end Modify; ------------------ -- Update_Value -- ------------------ procedure Update_Value is new Session_Set.Update_Value_Or_Status_G (Modify); begin Update_Value (Sessions, SID, Found); end Set_Value; ------------------- -- Touch_Session -- ------------------- procedure Touch_Session (SID : ID) is procedure Modify (Key : ID; Node : in out Session_Node); Found : Boolean; ------------ -- Modify -- ------------ procedure Modify (Key : ID; Node : in out Session_Node) is pragma Unreferenced (Key); begin Node.Time_Stamp := Calendar.Clock; end Modify; ------------ -- Update -- ------------ procedure Update is new Session_Set.Update_Value_Or_Status_G (Modify); begin Update (Sessions, SID, Found); end Touch_Session; ------------ -- Unlock -- ------------ procedure Unlock is begin Lock := Lock - 1; end Unlock; end Database; ------------ -- Delete -- ------------ procedure Delete (SID : ID) is begin Database.Delete_Session (SID); end Delete; ------------- -- Destroy -- ------------- procedure Destroy (Value : in out Session_Node) is begin Key_Value.Destroy (Value.Root); end Destroy; ----------- -- Exist -- ----------- function Exist (SID : ID) return Boolean is begin return Database.Session_Exist (SID); end Exist; function Exist (SID : ID; Key : String) return Boolean is Result : Boolean; begin Database.Key_Exist (SID, Key, Result); return Result; end Exist; ----------------------- -- For_Every_Session -- ----------------------- procedure For_Every_Session is procedure Process (Key : ID; Session : Session_Node; Order : Positive; Continue : in out Boolean); -- iterator callback ------------- -- Process -- ------------- procedure Process (Key : ID; Session : Session_Node; Order : Positive; Continue : in out Boolean) is Quit : Boolean := False; begin Action (Order, Key, Session.Time_Stamp, Quit); Continue := not Quit; end Process; -------------- -- In_Order -- -------------- procedure In_Order is new Session_Set.Traverse_Asc_G (Process); Sessions : Session_Set_Access; begin Database.Get_Sessions_And_Lock (Sessions); In_Order (Sessions.all); Database.Unlock; exception when others => Database.Unlock; end For_Every_Session; ---------------------------- -- For_Every_Session_Data -- ---------------------------- procedure For_Every_Session_Data (SID : ID) is procedure Process (Key : String; Value : Unbounded_String; Order : Positive; Continue : in out Boolean); -- Key/Value iterator callback. procedure Start (SID : ID; Node : in out Session_Node); -- Session iterator callback. Sessions : Session_Set_Access; Found : Boolean; ------------- -- Process -- ------------- procedure Process (Key : String; Value : Unbounded_String; Order : Positive; Continue : in out Boolean) is Quit : Boolean := False; begin Action (Order, Key, To_String (Value), Quit); Continue := not Quit; end Process; -------------- -- In_Order -- -------------- procedure In_Order is new Key_Value.Table.Traverse_Asc_G (Process); ----------- -- Start -- ----------- procedure Start (SID : ID; Node : in out Session_Node) is pragma Unreferenced (SID); begin In_Order (Key_Value.Table.Table_Type (Node.Root)); end Start; ----------------- -- For_Session -- ----------------- procedure For_Session is new Session_Set.Update_Value_Or_Status_G (Start); begin Database.Get_Sessions_And_Lock (Sessions); For_Session (Sessions.all, SID, Found); Database.Unlock; exception when others => Database.Unlock; raise; end For_Every_Session_Data; --------- -- Get -- --------- function Get (SID : ID; Key : String) return String is Value : Unbounded_String; begin Database.Get_Value (SID, Key, Value); return To_String (Value); end Get; function Get (SID : ID; Key : String) return Integer is Value : Unbounded_String; begin Database.Get_Value (SID, Key, Value); return Integer'Value (To_String (Value)); exception when others => return 0; end Get; function Get (SID : ID; Key : String) return Float is Value : Unbounded_String; begin Database.Get_Value (SID, Key, Value); return Float'Value (To_String (Value)); exception when others => return 0.0; end Get; function Get (SID : ID; Key : String) return Boolean is Value : Unbounded_String; begin Database.Get_Value (SID, Key, Value); if To_String (Value) = "T" then return True; else return False; end if; exception when others => return False; end Get; ------------------ -- Get_Lifetime -- ------------------ function Get_Lifetime return Duration is begin return Session_Lifetime; end Get_Lifetime; ----------- -- Image -- ----------- function Image (SID : ID) return String is begin return SID_Prefix & String (SID); end Image; ---------- -- Load -- ---------- procedure Load (File_Name : String) is use Ada.Streams.Stream_IO; File : File_Type; Stream_Ptr : Stream_Access; begin Open (File, Name => File_Name, Mode => In_File); Stream_Ptr := Stream (File); while not End_Of_File (File) loop declare SID : constant ID := ID'Input (Stream_Ptr); Key_Value_Size : Natural; begin Database.Add_Session (SID); Key_Value_Size := Natural'Input (Stream_Ptr); for I in 1 .. Key_Value_Size loop declare Key : constant String := String'Input (Stream_Ptr); Value : constant String := String'Input (Stream_Ptr); begin Set (SID, Key, Value); end; end loop; end; end loop; Close (File); end Load; ------------ -- Remove -- ------------ procedure Remove (SID : ID; Key : String) is begin Database.Remove_Key (SID, Key); end Remove; ---------- -- Save -- ---------- procedure Save (File_Name : String) is use Ada.Streams.Stream_IO; File : File_Type; Sessions : Session_Set_Access; Stream_Ptr : Stream_Access; procedure Process (Key : ID; Value : Session_Node; Order : Positive; Continue : in out Boolean); -- Callback for each session node in the table. ------------- -- Process -- ------------- procedure Process (Key : ID; Value : Session_Node; Order : Positive; Continue : in out Boolean) is pragma Unreferenced (Order); pragma Unreferenced (Continue); procedure Process (Key : String; Value : Unbounded_String; Order : Positive; Continue : in out Boolean); -- Callback for each key/value pair for a specific session. ------------- -- Process -- ------------- procedure Process (Key : String; Value : Unbounded_String; Order : Positive; Continue : in out Boolean) is pragma Unreferenced (Order); pragma Unreferenced (Continue); begin String'Output (Stream_Ptr, Key); String'Output (Stream_Ptr, To_String (Value)); end Process; -------------------- -- Each_Key_Value -- -------------------- procedure Each_Key_Value is new Key_Value.Table.Disorder_Traverse_G (Process); Key_Value_Size : constant Natural := Key_Value.Size (Value.Root); begin if Key_Value_Size > 0 then ID'Output (Stream_Ptr, Key); Natural'Output (Stream_Ptr, Key_Value_Size); Each_Key_Value (Key_Value.Table.Table_Type (Value.Root)); end if; end Process; ------------------ -- Each_Session -- ------------------ procedure Each_Session is new Session_Set.Disorder_Traverse_G (Process); begin Create (File, Name => File_Name); Database.Get_Sessions_And_Lock (Sessions); begin Stream_Ptr := Stream (File); Each_Session (Sessions.all); exception when others => -- Never leave this block without releasing the database lock. Database.Unlock; raise; end; Database.Unlock; Close (File); end Save; --------- -- Set -- --------- procedure Set (SID : ID; Key : String; Value : String) is begin Database.Set_Value (SID, Key, Value); end Set; procedure Set (SID : ID; Key : String; Value : Integer) is V : constant String := Integer'Image (Value); begin if V (1) = ' ' then Database.Set_Value (SID, Key, V (2 .. V'Last)); else Database.Set_Value (SID, Key, V); end if; end Set; procedure Set (SID : ID; Key : String; Value : Float) is V : constant String := Float'Image (Value); begin if V (1) = ' ' then Database.Set_Value (SID, Key, V (2 .. V'Last)); else Database.Set_Value (SID, Key, V); end if; end Set; procedure Set (SID : ID; Key : String; Value : Boolean) is V : String (1 .. 1); begin if Value then V := "T"; else V := "F"; end if; Database.Set_Value (SID, Key, V); end Set; ------------------ -- Set_Lifetime -- ------------------ procedure Set_Lifetime (Seconds : Duration) is begin Session_Lifetime := Seconds; end Set_Lifetime; ----------- -- Touch -- ----------- procedure Touch (SID : ID) is begin Database.Touch_Session (SID); end Touch; ----------- -- Value -- ----------- function Value (SID : String) return ID is begin if SID'Length /= ID'Length + SID_Prefix'Length or else (SID'Length > SID_Prefix'Length and then SID (SID'First .. SID'First + SID_Prefix'Length - 1) /= SID_Prefix) then return No_Session; else return ID (SID (SID'First + SID_Prefix'Length .. SID'Last)); end if; end Value; end AWS.Session; polyorb-2.8~20110207.orig/src/aws_orig/aws-containers-tables-set.ads0000644000175000017500000000613511750740337024505 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- A W S . C O N T A I N E R S . T A B L E S . S E T -- -- -- -- S p e c -- -- -- -- Copyright (C) 2000-2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ package AWS.Containers.Tables.Set is procedure Add (Table : in out Table_Type; Name, Value : String); -- Add a new Key/Value pair into the parameter set. procedure Update (Table : in out Table_Type; Name : String; Value : String; N : Positive := 1); -- Update the N-th Value with the given Name into the Table. -- The container could already have more than one value associated with -- this name. If there is M values with this Name, then if: -- N <= M => update the value -- N = M + 1 => the pair name=value is appended to the table -- N > M + 1 => Constraint_Error raised procedure Case_Sensitive (Table : in out Table_Type; Mode : Boolean); -- If Mode is True it will use all parameters with case sensitivity. procedure Reset (Table : in out Table_Type); -- Removes all object from the Set. Set will be reinitialized and will be -- ready for new use. procedure Free (Table : in out Table_Type); -- Release all memory used by the table. end AWS.Containers.Tables.Set; polyorb-2.8~20110207.orig/src/aws_orig/aws-log.adb0000644000175000017500000002156311750740337021041 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- A W S . L O G -- -- -- -- B o d y -- -- -- -- Copyright (C) 2000-2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- @@@ uses ada.calendar with Ada.Calendar; with Ada.Command_Line; with Ada.Strings.Fixed; with Ada.Strings.Maps; with GNAT.Calendar.Time_IO; with AWS.OS_Lib; with AWS.Utils; package body AWS.Log is function Log_Prefix (Prefix : String) return String; -- Returns the prefix to be added before the log filename. The returned -- value is the executable name without directory and filetype if Prefix -- is No_Prefix otherwise Prefix is returned. procedure Write_Log (Log : in out Object; Now : Calendar.Time; Data : String); -- Write data into the log file, change log file depending on the log file -- split mode and Now. -------------- -- Filename -- -------------- function Filename (Log : Object) return String is begin if Text_IO.Is_Open (Log.File) then return Text_IO.Name (Log.File); else return ""; end if; end Filename; --------------- -- Is_Active -- --------------- function Is_Active (Log : Object) return Boolean is begin return Text_IO.Is_Open (Log.File); end Is_Active; ---------------- -- Log_Prefix -- ---------------- function Log_Prefix (Prefix : String) return String is function Prog_Name return String; -- Return current program name --------------- -- Prog_Name -- --------------- function Prog_Name return String is Name : constant String := Ada.Command_Line.Command_Name; First : Natural; Last : Natural; begin First := Strings.Fixed.Index (Name, Strings.Maps.To_Set ("/\"), Going => Strings.Backward); if First = 0 then First := Name'First; else First := First + 1; end if; Last := Strings.Fixed.Index (Name (First .. Name'Last), ".", Strings.Backward); if Last = 0 then Last := Name'Last; else Last := Last - 1; end if; return Name (First .. Last); end Prog_Name; begin if Prefix = Not_Specified then return ""; else declare K : constant Natural := Strings.Fixed.Index (Prefix, "@"); begin if K = 0 then return Prefix & '-'; else return Prefix (Prefix'First .. K - 1) & Prog_Name & Prefix (K + 1 .. Prefix'Last) & '-'; end if; end; end if; end Log_Prefix; ---------- -- Mode -- ---------- function Mode (Log : Object) return Split_Mode is begin return Log.Split; end Mode; ----------- -- Start -- ----------- procedure Start (Log : in out Object; Split : Split_Mode := None; File_Directory : String := Not_Specified; Filename_Prefix : String := Not_Specified) is Now : constant Calendar.Time := Calendar.Clock; Filename : Unbounded_String; use GNAT; begin Log.Filename_Prefix := To_Unbounded_String (Filename_Prefix); Log.File_Directory := To_Unbounded_String (File_Directory); Log.Split := Split; Filename := To_Unbounded_String (File_Directory & Log_Prefix (Filename_Prefix) & GNAT.Calendar.Time_IO.Image (Now, "%Y-%m-%d.log")); case Split is when None => null; when Each_Run => for K in 1 .. 86_400 loop -- no more than one run per second during a full day. exit when not OS_Lib.Is_Regular_File (To_String (Filename)); Filename := To_Unbounded_String (File_Directory & Log_Prefix (Filename_Prefix) & GNAT.Calendar.Time_IO.Image (Now, "%Y-%m-%d-") & Utils.Image (K) & ".log"); end loop; when Daily => Log.Current_Tag := Ada.Calendar.Day (Now); when Monthly => Log.Current_Tag := Ada.Calendar.Month (Now); end case; Text_IO.Open (Log.File, Text_IO.Append_File, To_String (Filename)); exception when Text_IO.Name_Error => Text_IO.Create (Log.File, Text_IO.Out_File, To_String (Filename)); end Start; ---------- -- Stop -- ---------- procedure Stop (Log : in out Object) is begin if Text_IO.Is_Open (Log.File) then Text_IO.Close (Log.File); end if; end Stop; ----------- -- Write -- ----------- -- Here is the log format compatible with Apache: -- -- 127.0.0.1 - - [25/Apr/1998:15:37:29 +0200] "GET / HTTP/1.0" 200 1363 procedure Write (Log : in out Object; Connect_Stat : Status.Data; Answer : Response.Data) is begin Write (Log, Connect_Stat, Response.Status_Code (Answer), Response.Content_Length (Answer)); end Write; procedure Write (Log : in out Object; Connect_Stat : Status.Data; Status_Code : Messages.Status_Code; Content_Length : Natural) is begin Write (Log, Connect_Stat, Messages.Image (Status_Code) & ' ' & Utils.Image (Content_Length)); end Write; procedure Write (Log : in out Object; Connect_Stat : Status.Data; Data : String) is Now : constant Calendar.Time := Calendar.Clock; begin Write_Log (Log, Now, AWS.Status.Peername (Connect_Stat) & " - " & Status.Authorization_Name (Connect_Stat) & " - [" & GNAT.Calendar.Time_IO.Image (Now, "%d/%b/%Y:%T") & "] """ & Status.Request_Method'Image (Status.Method (Connect_Stat)) & ' ' & Status.URI (Connect_Stat) & " " & Status.HTTP_Version (Connect_Stat) & """ " & Data); end Write; procedure Write (Log : in out Object; Data : String) is Now : constant Calendar.Time := Calendar.Clock; begin Write_Log (Log, Now, "[" & GNAT.Calendar.Time_IO.Image (Now, "%d/%b/%Y:%T") & "] " & Data); end Write; --------------- -- Write_Log -- --------------- procedure Write_Log (Log : in out Object; Now : Calendar.Time; Data : String) is begin if Text_IO.Is_Open (Log.File) then if (Log.Split = Daily and then Log.Current_Tag /= Calendar.Day (Now)) or else (Log.Split = Monthly and then Log.Current_Tag /= Calendar.Month (Now)) then Stop (Log); Start (Log, Log.Split, To_String (Log.File_Directory), To_String (Log.Filename_Prefix)); end if; Text_IO.Put_Line (Log.File, Data); Text_IO.Flush (Log.File); end if; end Write_Log; end AWS.Log; polyorb-2.8~20110207.orig/src/aws_orig/aws-config-ini.ads0000644000175000017500000000472011750740337022317 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- A W S . C O N F I G . I N I -- -- -- -- S p e c -- -- -- -- Copyright (C) 2000-2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- Handle .ini style configuration file. In this file each option is on one -- line. The first word is the option name and the second one is the option -- value. package AWS.Config.Ini is procedure Read (Config : in out Object; Filename : String); -- Read 'File_Name.ini' and update the configuration object with the -- options read from it. Raises Ada.Text_IO.Name_Error if Filename does -- not exist. end AWS.Config.Ini; polyorb-2.8~20110207.orig/src/dsa/0000755000175000017500000000000011750740340015740 5ustar xavierxavierpolyorb-2.8~20110207.orig/src/dsa/polyorb-dsa_p-storages-dsm.adb0000644000175000017500000004731511750740340023602 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . D S A _ P . S T O R A G E S . D S M -- -- -- -- B o d y -- -- -- -- Copyright (C) 2008-2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- This package body contains the full declaration of the concret type -- DSM_Manager. This is convenient because it allows to use non remote -- types in DSM_Manager record (Mutexes, Any), so only RACW primitives -- parameters types need to be remote types compatible. -- Note : -- Invalidation phase as described in the algorithm is incomplete and -- should cause deadlocks in specific cases. If an invalidation request -- that refers to the acquirement of Write access by another partition -- is received, it do not make sense since local partition has obtained -- a later Write access on the variable. -- So we track version numbers of variables, and ingnore invalidation -- requests that refer to previous version numbers of the variable than -- the local partition one. pragma Ada_2005; with Ada.Unchecked_Conversion; with System.Partition_Interface; with PolyORB.Any; with PolyORB.DSA_P.Conversions; with PolyORB.Log; with PolyORB.Tasking.Mutexes; with PolyORB.Tasking.Condition_Variables; package body PolyORB.DSA_P.Storages.DSM is use System.Partition_Interface; use PolyORB.Any; use PolyORB.DSA_P.Conversions; use PolyORB.Log; use PolyORB.Tasking.Mutexes; use PolyORB.Tasking.Condition_Variables; -- Access rights to a shared variable can be Write, Read or None type Status_Type is (Write, Read, None); -- Mutexes and barrier used for objects synchronization type Synchonization_Tools is record Critical_Section : Mutex_Access; Protected_Object : Mutex_Access; Wait_Mutex : Mutex_Access; Wait_Barrier : Condition_Access; end record; function Extract_Pkg_Name (Var_Name : String) return String; -- Var_Name is a fully qualified variable string name. Remove suffix -- to get package string name. ----------------- -- DSM_Manager -- ----------------- -- The variable state is composed of the following attribute : -- * Data : System.DSA_Types.Any_Container_Ptr data representation -- * Status : Variable mode (Write, Read or None) -- * Prob_Owner : Probable owner (Li & Hudak algorithm) -- * Copies : Copy set (Li & Hudak algorithm) -- * Synchs : Synchronisation tools -- * Version : Increased each times we handle a remote request type DSM_Manager is new DSM_Manager_Type with record Data : PolyORB.Any.Any; Status : Status_Type; Prob_Owner : DSM_Manager_RACW; Copies : Copy_Set_Type; Synchs : Synchonization_Tools; Version : Integer; end record; type DSM_Manager_Access is access all DSM_Manager'Class; -- DSM_Manager type primitives -- Remotely called primitives overriding procedure Invalidate_Request (Self : access DSM_Manager; Rqst_Node : DSM_Manager_RACW; Version : Integer); overriding procedure Write_Request (Self : access DSM_Manager; Rqst_Node : DSM_Manager_RACW); overriding procedure Write_Reply (Self : access DSM_Manager; Var_Data : SDT.Any_Container_Ptr; Read_Copies : Copy_Set_Type; Version : Integer); overriding procedure Read_Request (Self : access DSM_Manager; Rqst_Node : DSM_Manager_RACW); overriding procedure Read_Reply (Self : access DSM_Manager; Var_Data : SDT.Any_Container_Ptr; Reply_Node : DSM_Manager_RACW; Version : Integer); overriding function Get_Initial_Owner (Self : access DSM_Manager; Var_Name : String) return DSM_Manager_RACW; -- Locally called primitives overriding procedure Read (Self : access DSM_Manager; Var : SDT.Any_Container_Ptr); overriding procedure Write (Self : access DSM_Manager; Var : SDT.Any_Container_Ptr); overriding procedure Lock (Self : access DSM_Manager); overriding procedure Unlock (Self : access DSM_Manager); overriding function Create (Manager_Factory : access DSM_Manager; Full_Name : String) return Shared_Data_Manager_RACW; -------------------------- -- Unchecked_Conversion -- -------------------------- function DSM_Manager_To_Address is new Ada.Unchecked_Conversion (DSM_Manager_Access, System.Address); -- Convert DSM_Manager_Access to system address function Address_To_DSM_Manager is new Ada.Unchecked_Conversion (System.Address, DSM_Manager_Access); -- Convert system address to DSM_Manager_Access ------------- -- Logging -- ------------- package L is new Log.Facility_Log ("polyorb.dsa_p.storages.dsm"); procedure O (Message : Standard.String; Level : Log_Level := Debug) renames L.Output; function C (Level : Log_Level := Debug) return Boolean renames L.Enabled; ---------------------- -- Extract_Pkg_Name -- ---------------------- function Extract_Pkg_Name (Var_Name : String) return String is begin for Index in reverse Var_Name'Range loop if Var_Name (Index) = '.' then return Var_Name (Var_Name'First .. Index - 1); end if; end loop; return ""; end Extract_Pkg_Name; ------------ -- Create -- ------------ function Create (Manager_Factory : access DSM_Manager; Full_Name : String) return Shared_Data_Manager_RACW is use Copy_Set_Tables; Manager : DSM_Manager_Access; Owner_Addr : System.Address; begin pragma Debug (C, O ("create DSM manager for variable " & Full_Name)); Manager := new DSM_Manager; -- Initializing dynamic table Initialize (Manager.Copies); -- Create synchonisation objects Create (Manager.Synchs.Critical_Section); Create (Manager.Synchs.Protected_Object); Create (Manager.Synchs.Wait_Mutex); Create (Manager.Synchs.Wait_Barrier); -- Initialize variable owner if Manager_Factory.Prob_Owner = DSM_Manager_RACW (Manager_Factory) then pragma Debug (C, O ("I am the initial owner of variable " & Full_Name)); Manager.Status := Write; Manager.Prob_Owner := DSM_Manager_RACW (Manager); else pragma Debug (C, O ("Retrieve initial owner of variable " & Full_Name & " from name server")); -- Retrieve initial owner of the variable System.Partition_Interface.Retrieve_RACW_From_Name_Server (Name => Extract_Pkg_Name (Full_Name), Kind => "SP", Stub_Tag => DSM_Manager_RACW'Stub_Type'Tag, Addr => Owner_Addr); Manager.Status := None; Manager.Prob_Owner := Get_Initial_Owner (Address_To_DSM_Manager (Owner_Addr), Full_Name); end if; return Shared_Data_Manager_RACW (Manager); end Create; ----------------------- -- Get_Initial_Owner -- ----------------------- function Get_Initial_Owner (Self : access DSM_Manager; Var_Name : String) return DSM_Manager_RACW is pragma Unreferenced (Self); Owner : Shared_Data_Manager_RACW; begin pragma Debug (C, O ("Initial owner request for " & Var_Name)); Lookup_Variable (Var_Name, Owner); return DSM_Manager_RACW (Owner); end Get_Initial_Owner; ------------------------ -- Invalidate_Request -- ------------------------ procedure Invalidate_Request (Self : access DSM_Manager; Rqst_Node : DSM_Manager_RACW; Version : Integer) is use Copy_Set_Tables; begin -- Asynchronous procedure -- Invalidate only if local partition has read access to the variable -- and if variable version isn't obsolete. Enter (Self.Synchs.Critical_Section); if Self.Status = Read and then Version >= Self.Version then pragma Debug (C, O ("Invalidation request received")); -- Send invalidation request to nodes in the copy set for C in First (Self.Copies) .. Last (Self.Copies) loop declare Target : constant DSM_Manager_RACW := Self.Copies.Table (C); begin if Target /= DSM_Manager_RACW (Self) and then Target /= Rqst_Node then Invalidate_Request (Self => Target, Rqst_Node => DSM_Manager_RACW (Self), Version => Self.Version); end if; end; end loop; Self.Prob_Owner := Rqst_Node; Self.Status := None; -- Reset copy set Initialize (Self.Copies); else pragma Debug (C, O ("Invalidation request ignored")); null; end if; Leave (Self.Synchs.Critical_Section); end Invalidate_Request; ---------- -- Lock -- ---------- procedure Lock (Self : access DSM_Manager) is begin Enter (Self.Synchs.Protected_Object); Enter (Self.Synchs.Critical_Section); -- Critical section of protected objects has the following concept : -- -- lock (); -- read (); -- protected_object.procedure_call (); -- write (); -- unlock (); -- -- So if local partition isn't the owner of the shared protected object, -- we send a write request to the owner to get the ownership. -- As we don't handle any incoming request until the unlock () call -- , we ensure that no other partition could use the protected object -- between local read () and write () calls. if Self.Prob_Owner /= DSM_Manager_RACW (Self) then pragma Debug (C, O ("Sending write request to probable owner")); -- Ask for write access to probable owner. Enter (Self.Synchs.Wait_Mutex); Write_Request (Self => Self.Prob_Owner, Rqst_Node => DSM_Manager_RACW (Self)); -- Awaiting owner reply Wait (Self.Synchs.Wait_Barrier, Self.Synchs.Wait_Mutex); Leave (Self.Synchs.Wait_Mutex); end if; Self.Prob_Owner := DSM_Manager_RACW (Self); Self.Status := Write; Leave (Self.Synchs.Critical_Section); end Lock; ---------- -- Read -- ---------- procedure Read (Self : access DSM_Manager; Var : SDT.Any_Container_Ptr) is begin Enter (Self.Synchs.Critical_Section); if Self.Status = None then pragma Debug (C, O ("Sending read request to probable owner")); Enter (Self.Synchs.Wait_Mutex); -- Ask for read access to probable owner Read_Request (Self => Self.Prob_Owner, Rqst_Node => DSM_Manager_RACW (Self)); -- Awaiting reply from first node which has read access Wait (Self.Synchs.Wait_Barrier, Self.Synchs.Wait_Mutex); Leave (Self.Synchs.Wait_Mutex); Self.Status := Read; end if; -- Set value of container designated by given pointer Set_Value (DAC_To_AC (Var).all, Get_Value (Get_Container (Self.Data).all)); Leave (Self.Synchs.Critical_Section); end Read; ---------------- -- Read_Reply -- ---------------- procedure Read_Reply (Self : access DSM_Manager; Var_Data : SDT.Any_Container_Ptr; Reply_Node : DSM_Manager_RACW; Version : Integer) is begin -- Asynchronous procedure pragma Debug (C, O ("Receiving read reply from probable owner")); Enter (Self.Synchs.Wait_Mutex); Set_Container (Self.Data, DAC_To_AC (Var_Data)); Self.Prob_Owner := Reply_Node; Self.Version := Version; -- Signal blocked task Broadcast (Self.Synchs.Wait_Barrier); Leave (Self.Synchs.Wait_Mutex); end Read_Reply; ------------------ -- Read_Request -- ------------------ procedure Read_Request (Self : access DSM_Manager; Rqst_Node : DSM_Manager_RACW) is use Copy_Set_Tables; begin -- Asynchronous procedure Enter (Self.Synchs.Critical_Section); pragma Debug (C, O ("Read request received")); -- If local partition has read or write access, handle request locally, -- else forward it to the probable owner. if Self.Status /= None then -- Write access lost Self.Status := Read; -- Add requesting node to the copy set Increment_Last (Self.Copies); Self.Copies.Table (Last (Self.Copies)) := Rqst_Node; -- Send reply Self.Version := Self.Version + 1; Read_Reply (Self => Rqst_Node, Var_Data => AC_To_DAC (Get_Container (Self.Data)), Reply_Node => DSM_Manager_RACW (Self), Version => Self.Version); else pragma Debug (C, O ("Forwarding read request to probable owner")); -- Forward request to probable owner Read_Request (Self => Self.Prob_Owner, Rqst_Node => Rqst_Node); Self.Prob_Owner := Rqst_Node; end if; Leave (Self.Synchs.Critical_Section); end Read_Request; ------------------------------ -- Register_Passive_Package -- ------------------------------ procedure Register_Passive_Package (Pkg_Name : String; Is_Owner : Boolean; Location : String) is pragma Unreferenced (Location); Factory : constant DSM_Manager_Access := new DSM_Manager; begin pragma Debug (C, O ("Register DSM factory for package " & Pkg_Name)); -- If local partition is the initial owner of the shared passive unit, -- register it in the name server. if Is_Owner then Factory.Prob_Owner := DSM_Manager_RACW (Factory); System.Partition_Interface.Register_RACW_In_Name_Server (Addr => DSM_Manager_To_Address (Factory), Type_Tag => DSM_Manager_Type'Tag, Name => Pkg_Name, Kind => "SP"); end if; Register_Factory (Pkg_Name, Shared_Data_Manager_RACW (Factory)); end Register_Passive_Package; ------------ -- Unlock -- ------------ procedure Unlock (Self : access DSM_Manager) is begin -- Exit the protected object critical section Leave (Self.Synchs.Protected_Object); end Unlock; ----------- -- Write -- ----------- procedure Write (Self : access DSM_Manager; Var : SDT.Any_Container_Ptr) is use Copy_Set_Tables; begin Enter (Self.Synchs.Critical_Section); if Self.Status /= Write and then Self.Prob_Owner /= DSM_Manager_RACW (Self) then pragma Debug (C, O ("Sending write request to probable owner")); Enter (Self.Synchs.Wait_Mutex); -- Request write access from probable owner Write_Request (Self => Self.Prob_Owner, Rqst_Node => DSM_Manager_RACW (Self)); -- Wait for reply from real owner Wait (Self.Synchs.Wait_Barrier, Self.Synchs.Wait_Mutex); Leave (Self.Synchs.Wait_Mutex); end if; -- Send invalidation request to nodes in the copy set for C in First (Self.Copies) .. Last (Self.Copies) loop declare Target : constant DSM_Manager_RACW := Self.Copies.Table (C); begin if Target /= DSM_Manager_RACW (Self) then Invalidate_Request (Self => Target, Rqst_Node => DSM_Manager_RACW (Self), Version => Self.Version); end if; end; end loop; Self.Prob_Owner := DSM_Manager_RACW (Self); Self.Status := Write; -- Reset copy set Initialize (Self.Copies); -- Set local container pointer to given container pointer Set_Container (Self.Data, DAC_To_AC (Var)); Leave (Self.Synchs.Critical_Section); end Write; ------------------- -- Write_Reply -- ------------------- procedure Write_Reply (Self : access DSM_Manager; Var_Data : SDT.Any_Container_Ptr; Read_Copies : Copy_Set_Type; Version : Integer) is begin -- Asynchronous procedure pragma Debug (C, O ("Receiving write reply from real owner")); Enter (Self.Synchs.Wait_Mutex); Self.Copies := Read_Copies; Self.Version := Version; Set_Container (Self.Data, DAC_To_AC (Var_Data)); -- Unblock waiting task Broadcast (Self.Synchs.Wait_Barrier); Leave (Self.Synchs.Wait_Mutex); end Write_Reply; ------------------- -- Write_Request -- ------------------- procedure Write_Request (Self : access DSM_Manager; Rqst_Node : DSM_Manager_RACW) is begin -- Asynchronous procedure Enter (Self.Synchs.Protected_Object); Enter (Self.Synchs.Critical_Section); -- If variable is a protected object and is curently in use, block until -- exit of protected object critical section. pragma Debug (C, O ("Write request received")); -- If local partition has read or write access, handle request locally, -- else forward it to the probable owner. if Self.Prob_Owner = DSM_Manager_RACW (Self) then -- Send reply Self.Status := None; Self.Version := Self.Version + 1; Write_Reply (Self => Rqst_Node, Var_Data => AC_To_DAC (Get_Container (Self.Data)), Read_Copies => Self.Copies, Version => Self.Version); else pragma Debug (C, O ("Forwarding write request to probable owner")); -- Forward request to probable owner Write_Request (Self => Self.Prob_Owner, Rqst_Node => Rqst_Node); end if; Self.Prob_Owner := Rqst_Node; Leave (Self.Synchs.Critical_Section); Leave (Self.Synchs.Protected_Object); end Write_Request; end PolyORB.DSA_P.Storages.DSM; polyorb-2.8~20110207.orig/src/dsa/polyorb-dsa_p-exceptions.ads0000644000175000017500000000541411750740340023366 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . D S A _ P . E X C E P T I O N S -- -- -- -- S p e c -- -- -- -- Copyright (C) 2003-2007, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- Errors management for the DSA Application Personality of PolyORB. with PolyORB.Any; with PolyORB.Errors; package PolyORB.DSA_P.Exceptions is function Exception_Repository_Id (Name, Version : String) return String; -- Build a repository ID from an Ada exception name and unit version procedure Raise_From_Error (Error : in out PolyORB.Errors.Error_Container); pragma No_Return (Raise_From_Error); -- Raise a DSA specific exception from the data in 'Error' procedure Raise_From_Any (Occurrence : Any.Any; Msg : String := ""); pragma No_Return (Raise_From_Any); -- Raise a DSA specific exception from the data in Occurrence, with an -- optional Exception_Message. end PolyORB.DSA_P.Exceptions; polyorb-2.8~20110207.orig/src/dsa/polyorb-termination_manager.adb0000644000175000017500000004352611750740340024131 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . T E R M I N A T I O N _ M A N A G E R -- -- -- -- B o d y -- -- -- -- Copyright (C) 2006-2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with Ada.Exceptions; with PolyORB.Binding_Objects; with PolyORB.Initialization; with PolyORB.Log; with PolyORB.ORB; with PolyORB.ORB_Controller; with PolyORB.References; with PolyORB.Setup; with PolyORB.Smart_Pointers; with PolyORB.Tasking.Threads; with PolyORB.Tasking.Mutexes; with PolyORB.Termination_Activity; with PolyORB.Termination_Manager.Bootstrap; with System.RPC; package body PolyORB.Termination_Manager is use PolyORB.Binding_Objects; use PolyORB.Log; use PolyORB.ORB; use PolyORB.ORB_Controller; use PolyORB.Setup; use PolyORB.Tasking.Threads; use PolyORB.Tasking.Mutexes; use PolyORB.Termination_Activity; use PolyORB.Termination_Manager.Bootstrap; procedure Termination_Loop; -- Main loop of the task created by the termination manager procedure In_Initiator_Loop; -- Procedure executed in the termination loop for the initiator node procedure In_Slave_Loop; -- Procedure executed in the termination loop for non-initiator nodes type Action is access function (TM : Term_Manager_Access; Stamp : Stamp_Type) return Boolean; -- Comment needed??? function Call_On_Neighbours (A : Action; A_Name : String; Stamp : Stamp_Type) return Boolean; -- Call action A on all the neighbours of the local partition, and return -- the global AND of every neighbour return value to A. function Newer (S1, S2 : Stamp_Type) return Boolean; -- Compare two stamps. Newer (S1, S2) means that S2 is very likely to have -- been issued prior to S1. function Is_Locally_Terminated (TM : Term_Manager; In_Remote_Call : Boolean := False) return Boolean; -- Check for local termination using ORB_Controller.Is_Locally_Terminated. -- In_Remote_Call is set True when this is being called as part of -- processing an Is_Terminated request from a remote node. type Request_Status is (Outdated, Not_From_Father, Valid); -- Comment needed??? ---------------------- -- Critical Section -- ---------------------- Critical_Section : Mutex_Access; function Check_Stamp (S : Stamp_Type) return Request_Status; -- Checks the stamp S against the local TM Current_Stamp to decide if -- request is Valid, Outdated or not from father. -- Also updates the TM Current_Stamp if the request is valid. function Get_Stamp return Stamp_Type; -- Returns the TM Current_Stamp ------------- -- Logging -- ------------- package L is new Log.Facility_Log ("polyorb.termination_manager"); procedure O (Message : Standard.String; Level : Log_Level := Debug) renames L.Output; function C (Level : Log_Level := Debug) return Boolean renames L.Enabled; ------------- -- Actions -- ------------- function Do_Is_Terminated (TM : Term_Manager_Access; Stamp : Stamp_Type) return Boolean; function Do_Terminate_Now (TM : Term_Manager_Access; Stamp : Stamp_Type) return Boolean; ---------------------- -- Do_Is_Terminated -- ---------------------- function Do_Is_Terminated (TM : Term_Manager_Access; Stamp : Stamp_Type) return Boolean is begin return Is_Terminated (TM, Stamp); end Do_Is_Terminated; ---------------------- -- Do_Terminate_Now -- ---------------------- function Do_Terminate_Now (TM : Term_Manager_Access; Stamp : Stamp_Type) return Boolean is begin return Terminate_Now (TM, Stamp); end Do_Terminate_Now; ------------------------ -- Call_On_Neighbours -- ------------------------ function Call_On_Neighbours (A : Action; A_Name : String; Stamp : Stamp_Type) return Boolean is use BO_Ref_Lists; use References; use Smart_Pointers; L : BO_Ref_List := Get_Binding_Objects (Setup.The_ORB); R : References.Ref; NK : Node_Kind; RACW : Term_Manager_Access; Status : Boolean := True; N_Status : Boolean; begin pragma Debug (C, O ("Call_On_Neighbours (" & A_Name & "," & Stamp'Img & "): enter")); All_Binding_Objects : while not Is_Empty (L) loop declare use Ada.Exceptions; BO_Ref : Smart_Pointers.Ref; begin Extract_First (L, BO_Ref); Extract_TM_Reference_From_BO (BO => Binding_Object_Access (Entity_Of (BO_Ref)), Ref => R, NK => NK); case NK is when DSA_Node | Unknown => RACW := Ref_To_Term_Manager_Access (R); pragma Debug (C, O ("Calling " & A_Name & " (" & Stamp'Img & ")" & " on neighbour...")); N_Status := A (RACW, Stamp); pragma Debug (C, O ("-> " & N_Status'Img)); Status := Status and N_Status; when DSA_Node_Without_TM => pragma Debug (C, O ("DSA neighbour without TM")); Status := False; when Non_DSA_Node => -- Non-DSA nodes do not take part in the global decision null; end case; -- XXX A server only, no tasking partition, will not take part -- in the global decision. Indeed we cannot determine the -- kind of node from a client BO. So the server only node kind -- will be marked as Unknown. Because it cannot have a running -- TM (no tasking), request will fail and Status won't be marked -- as false, so others partitions won't wait for it to finish. Decrement_Activity; exception when System.RPC.Communication_Error => Decrement_Activity; end; end loop All_Binding_Objects; pragma Debug (C, O ("Call_On_Neighbours (" & A_Name & ", " & Stamp'Img & "): leave -> " & Status'Img)); return Status; end Call_On_Neighbours; ----------------- -- Check_Stamp -- ----------------- function Check_Stamp (S : Stamp_Type) return Request_Status is Result : Request_Status; begin Enter (Critical_Section); pragma Debug (C, O ("Check_Stamp: stamp =" & S'Img & ", Current =" & The_TM.Current_Stamp'Img)); if Newer (The_TM.Current_Stamp, S) then -- If stamp is older than current stamp, this is an outdated message Result := Outdated; elsif S = The_TM.Current_Stamp then -- If stamp is equal to the current stamp then the request is not -- from a father node. Result := Not_From_Father; else pragma Assert (Newer (S, The_TM.Current_Stamp)); -- If stamp is more recent than current stamp, this is a new wave, -- update the current stamp. Result := Valid; The_TM.Current_Stamp := S; end if; Leave (Critical_Section); pragma Debug (C, O ("Check_Stamp: -> " & Result'Img)); return Result; end Check_Stamp; --------------- -- Get_Stamp -- --------------- function Get_Stamp return Stamp_Type is Result : Stamp_Type; begin Enter (Critical_Section); Result := The_TM.Current_Stamp; Leave (Critical_Section); return Result; end Get_Stamp; ------------------------- -- In_Inititiator_Loop -- ------------------------- procedure In_Initiator_Loop is begin -- Do not bother to start a wave if the local node participates in the -- decision and knows it is not locally terminated. if The_TM.Termination_Policy = Global_Termination and then not Is_Locally_Terminated (The_TM.all) then return; end if; pragma Debug (C, O ("In_Initiator_Loop: start wave")); if Is_Terminated (The_TM, Get_Stamp + 1) then The_TM.Terminated := Terminate_Now (The_TM, Get_Stamp + 1); end if; end In_Initiator_Loop; --------------------- -- In_Slave_Loop -- --------------------- procedure In_Slave_Loop is begin case The_TM.Termination_Policy is when Local_Termination => The_TM.Terminated := Is_Locally_Terminated (The_TM.all); when Global_Termination | Deferred_Termination => null; end case; end In_Slave_Loop; --------------------------- -- Is_Locally_Terminated -- --------------------------- function Is_Locally_Terminated (TM : Term_Manager; In_Remote_Call : Boolean := False) return Boolean is Expected_Running_Tasks : Natural := TM.Non_Terminating_Tasks; Result : Boolean; begin pragma Debug (C, O ("Is_Locally_Terminated: enter (in remote call: " & In_Remote_Call'Img & ")")); -- Compute the number of expected non-terminating tasks pragma Debug (C, O ("TM.Is_Initiator = " & TM.Is_Initiator'Img)); pragma Debug (C, O ("TM.Non_Terminating_Tasks =" & TM.Non_Terminating_Tasks'Img)); if In_Remote_Call and then not TM.Is_Initiator then -- If the termination manager is not the initiator, local termination -- is checked inside a request job so one of the ORB tasks will be -- running at that time, so we have one more non-terminating task. Expected_Running_Tasks := Expected_Running_Tasks + 1; end if; pragma Debug (C, O ("Expect" & Expected_Running_Tasks'Img & " remaining tasks")); -- Theoretically we should just test Is_Locally_Terminated once. -- However in some cases the I/O task that received the message for a -- wave might still be running (about to be rescheduled) at the first -- try, so we wait a tiny bit and check again if at first we don't get -- a positive result. for J in 1 .. 3 loop Enter_ORB_Critical_Section (The_ORB.ORB_Controller); pragma Debug (C, O ("Is_Locally_Terminated: in critical section, " & "iteration" & J'Img)); Result := Is_Locally_Terminated (The_ORB.ORB_Controller, Expected_Running_Tasks); Leave_ORB_Critical_Section (The_ORB.ORB_Controller); exit when Result; Relative_Delay (The_TM.Time_Between_Waves / 10); end loop; pragma Debug (C, O ("Is_Locally_Terminated: leave, Result = " & Result'Img)); return Result; end Is_Locally_Terminated; ------------------- -- Is_Terminated -- ------------------- function Is_Terminated (TM : access Term_Manager; Stamp : Stamp_Type) return Boolean is Local_Decision : Boolean := True; Neighbours_Decision : Boolean := True; begin case Check_Stamp (Stamp) is when Not_From_Father => -- If the request is not from a father node, we immediatly answer -- True as this does not change the computation. return True; when Outdated => return False; when Valid => null; pragma Debug (C, O ("New wave (Is_Terminated) received")); end case; -- Check local termination if not Is_Locally_Terminated (TM.all, In_Remote_Call => True) then pragma Debug (C, O ("Node is not locally terminated, refusing termination.")); Local_Decision := False; end if; -- Check for pending communication with remote nodes if Is_Active then pragma Debug (C, O ("Node is active (has sent messages since the last wave)," & " refusing termination.")); Local_Decision := False; end if; -- If node is locally terminated and has not sent any messages the -- answer depends on its children. -- We propagate the wave even if locally we are refusing termination. -- This is to reset the activity counter in all child partitions. -- Is this desirable if we are the initiator??? Neighbours_Decision := Call_On_Neighbours (Do_Is_Terminated'Access, "Do_Is_Terminated", Stamp); pragma Debug (C, O ("Is_Terminated: Local " & Local_Decision'Img & " / Neighbours " & Neighbours_Decision'Img)); -- Reset activity counter Reset_Activity; return Local_Decision and Neighbours_Decision; end Is_Terminated; ----------- -- Newer -- ----------- function Newer (S1, S2 : Stamp_Type) return Boolean is begin return S1 /= S2 and then S1 - S2 < 2 ** (Stamp_Type'Size - 1); end Newer; ----------- -- Start -- ----------- procedure Start (TM : access Term_Manager; T : Termination_Type; Initiator : Boolean; Time_Between_Waves : Duration; Time_Before_Start : Duration) is Thread_Acc : Thread_Access; begin -- Check consistency of settings if T = Local_Termination and then Initiator then raise Program_Error with "termination initiator can't have local termination policy"; end if; Create (Critical_Section); TM.Time_Between_Waves := Time_Between_Waves; TM.Time_Before_Start := Time_Before_Start; TM.Termination_Policy := T; TM.Is_Initiator := Initiator; -- Since we are running the termination loop in a new task, we should -- consider it as a non-terminating task. TM.Non_Terminating_Tasks := TM.Non_Terminating_Tasks + 1; pragma Debug (C, O ("Starting TM: Is_Initiator = " & Initiator'Img & " / NTT =" & TM.Non_Terminating_Tasks'Img)); Thread_Acc := Run_In_Task (TF => Get_Thread_Factory, Default_Priority => System.Any_Priority'First, P => Termination_Loop'Access); pragma Assert (Thread_Acc /= null); end Start; ---------------------- -- Termination_Loop -- ---------------------- procedure Termination_Loop is use Ada.Exceptions; begin Relative_Delay (The_TM.Time_Before_Start); loop if The_TM.Is_Initiator then In_Initiator_Loop; else In_Slave_Loop; end if; exit when The_TM.Terminated; Relative_Delay (The_TM.Time_Between_Waves); end loop; PolyORB.Initialization.Shutdown_World (Wait_For_Completion => True); exception when E : others => pragma Debug (C, O ("Termination_Loop: got " & Exception_Information (E))); PolyORB.Initialization.Shutdown_World (Wait_For_Completion => False); raise; end Termination_Loop; ------------------- -- Terminate_Now -- ------------------- function Terminate_Now (TM : access Term_Manager; Stamp : Stamp_Type) return Boolean is Status : Boolean; begin -- Ignore the message if it is not from father or if it is outdated case Check_Stamp (Stamp) is when Valid => pragma Debug (C, O ("Terminate_Now: received wave with valid time stamp")); null; when others => pragma Debug (C, O ("Terminate_Now: received wave with junk time stamp")); return True; end case; -- Call Terminate_Now on all of its childs pragma Debug (C, O ("Terminating children")); Status := Call_On_Neighbours (Do_Terminate_Now'Access, "Do_Terminate_Now", Stamp); pragma Assert (Status); -- Terminate this partition, except if it has the Deferred_Termination -- policy. if TM.Termination_Policy /= Deferred_Termination then TM.Terminated := True; end if; return TM.Terminated; end Terminate_Now; end PolyORB.Termination_Manager; polyorb-2.8~20110207.orig/src/dsa/polyorb-dsa_p-name_service-mdns-client.adb0000644000175000017500000003136311750740340026041 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- POLYORB.DSA_P.NAME_SERVICE.MDNS.CLIENT -- -- -- -- B o d y -- -- -- -- Copyright (C) 2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with Ada.Characters.Handling; with PolyORB.Any.NVList; with PolyORB.Any; with PolyORB.Types; with PolyORB.Requests; with PolyORB.Log; with PolyORB.Utils; with System.RPC; package body PolyORB.DSA_P.Name_Service.mDNS.Client is use PolyORB.DSA_P.Name_Service.mDNS.Helper; use PolyORB.Log; package L is new PolyORB.Log.Facility_Log ("polyorb.dsa_p.name_service.mdns.client"); procedure O (Message : String; Level : Log_Level := Debug) renames L.Output; function C (Level : Log_Level := Debug) return Boolean renames L.Enabled; function To_Lower (S : String) return String renames Ada.Characters.Handling.To_Lower; Query_Arg_Name_Authoritative : constant PolyORB.Types.Identifier := PolyORB.Types.To_PolyORB_String ("Authoritative"); Query_Arg_Name_Question : constant PolyORB.Types.Identifier := PolyORB.Types.To_PolyORB_String ("Question"); Query_Arg_Name_Answer : constant PolyORB.Types.Identifier := PolyORB.Types.To_PolyORB_String ("Answer"); Query_Arg_Name_Authority : constant PolyORB.Types.Identifier := PolyORB.Types.To_PolyORB_String ("Authority"); Query_Arg_Name_Additional : constant PolyORB.Types.Identifier := PolyORB.Types.To_PolyORB_String ("Additional"); Query_Result_Name : constant PolyORB.Types.Identifier := PolyORB.Types.To_PolyORB_String ("Result"); -------------------- -- Query_Result -- -------------------- function Query_Result return PolyORB.Any.NamedValue; function Query_Result return PolyORB.Any.NamedValue is pragma Inline (Query_Result); begin return (Name => Query_Result_Name, Argument => PolyORB.Any.Get_Empty_Any (mDNS.Helper.TC_Rcode), Arg_Modes => 0); end Query_Result; function Get_Wrapper_Any (TC : PolyORB.Any.TypeCode.Local_Ref; CC : access PolyORB.Any.Content'Class) return PolyORB.Any.Any; function Get_Wrapper_Any (TC : PolyORB.Any.TypeCode.Local_Ref; CC : access PolyORB.Any.Content'Class) return PolyORB.Any.Any is Result : constant PolyORB.Any.Any := PolyORB.Any.Get_Empty_Any (TC); pragma Suppress (Accessibility_Check); begin PolyORB.Any.Set_Value (PolyORB.Any.Get_Container (Result).all, PolyORB.Any.Content_Ptr (CC)); return Result; end Get_Wrapper_Any; ------------- -- Resolve -- ------------- -- Sending an mdns message on the local link to retrieve -- a valid reference of the selected unit function Resolve (The_Ref : PolyORB.References.Ref; Name : String; Kind : String) return PolyORB.References.Ref is use PolyORB.Any.NVList; use PolyORB.Any.NVList.Internals.NV_Lists; use PolyORB.Types; Request : PolyORB.Requests.Request_Access; Arg_List : PolyORB.Any.NVList.Ref; Question_RR : RR; Q_sequence : rrSequence; A_sequence : rrSequence; Auth_sequence : rrSequence; Add_sequence : rrSequence; Authoritative : Types.Boolean; Res : Rcode; Answer_rr : RR; Version_Id, Str_Ref : PolyORB.Types.String; Ref : PolyORB.References.Ref; begin pragma Debug (C, O ("Enter Resolve : sending to :" & PolyORB.References.Image (The_Ref))); Authoritative := False; -- Create argument list Q_sequence := To_Sequence (1); PolyORB.Any.NVList.Create (Arg_List); Question_RR.rr_name := To_PolyORB_String (Name & "._" & To_Lower (Kind)); Question_RR.rr_type := SRV; Question_RR.TTL := 240; Replace_Element (Q_sequence, 1, Question_RR); -- calling the query procedure Query (Self => The_Ref, Authoritative => Authoritative, Question => Q_sequence, Answer => A_sequence, Authority => Auth_sequence, Additional => Add_sequence, Returns => Res); -- If the the object has been successfully found -- and the out arguments received we receive a No_Error Rcode. if Res = No_Error then Answer_rr := Get_Element (A_sequence, 1); pragma Debug (C, O ("Answer: " & PolyORB.Types.To_Standard_String (Answer_rr.rr_name))); pragma Debug (C, O ("TXT: " & PolyORB.Types.To_Standard_String (Answer_rr.rr_data.rr_answer))); if Answer_rr.rr_type = TXT then Parse_TXT_Record (Answer_rr.rr_data.rr_answer, Str_Ref, Version_Id); -- Creating a reference form its stringified representation PolyORB.References.String_To_Object (Types.To_Standard_String (Str_Ref), Ref); -- Setting its type id, for version checking purposes if PolyORB.References.Type_Id_Of (Ref) = "" then PolyORB.References.Set_Type_Id (Ref, "DSA:" & To_Standard_String (Answer_rr.rr_name) & ":" & To_Standard_String (Version_Id)); end if; end if; elsif Res = Name_Error then pragma Debug (C, O ("Record was not found")); raise System.RPC.Communication_Error with "Name_Error"; else raise Program_Error; end if; PolyORB.Requests.Destroy_Request (Request); -- Request has been synchronously invoked return Ref; end Resolve; ----------- -- Query -- ----------- procedure Query (Self : PolyORB.References.Ref; Authoritative : in out PolyORB.Types.Boolean; Question : PolyORB.DSA_P.Name_Service.mDNS.Helper.rrSequence; Answer : out PolyORB.DSA_P.Name_Service.mDNS.Helper.rrSequence; Authority : out PolyORB.DSA_P.Name_Service.mDNS.Helper.rrSequence; Additional : out PolyORB.DSA_P.Name_Service.mDNS.Helper.rrSequence; Returns : out PolyORB.DSA_P.Name_Service.mDNS.Helper.Rcode) is Argument_List : PolyORB.Any.NVList.Ref; Result : PolyORB.DSA_P.Name_Service.mDNS.Helper.Rcode renames Returns; Arg_CC_Result : aliased PolyORB.Any.Content'Class := mDNS.Helper.Internals.Wrap (Result'Unrestricted_Access); Arg_CC_Authoritative : aliased PolyORB.Any.Content'Class := PolyORB.Any.Wrap (Authoritative'Unrestricted_Access); Arg_Any_Authoritative : constant PolyORB.Any.Any := Get_Wrapper_Any (PolyORB.Any.TC_Boolean, Arg_CC_Authoritative'Unchecked_Access); Arg_CC_Question : aliased PolyORB.Any.Content'Class := PolyORB.DSA_P.Name_Service.mDNS.Helper.Internals.Wrap (PolyORB.DSA_P.Name_Service.mDNS.Helper.IDL_SEQUENCE_DNS_RR.Sequence (Question)'Unrestricted_Access); Arg_Any_Question : constant PolyORB.Any.Any := Get_Wrapper_Any (PolyORB.DSA_P.Name_Service.mDNS.Helper.TC_rrSequence, Arg_CC_Question'Unchecked_Access); Arg_CC_Answer : aliased PolyORB.Any.Content'Class := PolyORB.DSA_P.Name_Service.mDNS.Helper.Internals.Wrap (PolyORB.DSA_P.Name_Service.mDNS.Helper.IDL_SEQUENCE_DNS_RR.Sequence (Answer)'Unrestricted_Access); Arg_Any_Answer : constant PolyORB.Any.Any := Get_Wrapper_Any (PolyORB.DSA_P.Name_Service.mDNS.Helper.TC_rrSequence, Arg_CC_Answer'Unchecked_Access); pragma Warnings (Off, Answer); Arg_CC_Authority : aliased PolyORB.Any.Content'Class := PolyORB.DSA_P.Name_Service.mDNS.Helper.Internals.Wrap (PolyORB.DSA_P.Name_Service.mDNS.Helper.IDL_SEQUENCE_DNS_RR.Sequence (Authority)'Unrestricted_Access); Arg_Any_Authority : constant PolyORB.Any.Any := Get_Wrapper_Any (PolyORB.DSA_P.Name_Service.mDNS.Helper.TC_rrSequence, Arg_CC_Authority'Unchecked_Access); pragma Warnings (Off, Authority); Arg_CC_Additional : aliased PolyORB.Any.Content'Class := PolyORB.DSA_P.Name_Service.mDNS.Helper.Internals.Wrap (PolyORB.DSA_P.Name_Service.mDNS.Helper.IDL_SEQUENCE_DNS_RR.Sequence (Additional)'Unrestricted_Access); Arg_Any_Additional : constant PolyORB.Any.Any := Get_Wrapper_Any (PolyORB.DSA_P.Name_Service.mDNS.Helper.TC_rrSequence, Arg_CC_Additional'Unchecked_Access); pragma Warnings (Off, Additional); Request : PolyORB.Requests.Request_Access; Result_Nv : PolyORB.Any.NamedValue := Query_Result; begin pragma Debug (C, O ("Query : enter")); if Self.Is_Nil then pragma Debug (C, O ("Query : Ref is nil")); raise Program_Error; end if; -- Create the Argument list PolyORB.Any.NVList.Create (Argument_List); -- Fill the Argument list PolyORB.Any.NVList.Add_Item (Argument_List, Query_Arg_Name_Authoritative, Arg_Any_Authoritative, PolyORB.Any.ARG_INOUT); PolyORB.Any.NVList.Add_Item (Argument_List, Query_Arg_Name_Question, Arg_Any_Question, PolyORB.Any.ARG_IN); PolyORB.Any.NVList.Add_Item (Argument_List, Query_Arg_Name_Answer, Arg_Any_Answer, PolyORB.Any.ARG_OUT); PolyORB.Any.NVList.Add_Item (Argument_List, Query_Arg_Name_Authority, Arg_Any_Authority, PolyORB.Any.ARG_OUT); PolyORB.Any.NVList.Add_Item (Argument_List, Query_Arg_Name_Additional, Arg_Any_Additional, PolyORB.Any.ARG_OUT); -- Setting the result value PolyORB.Any.Set_Value (PolyORB.Any.Get_Container (Result_Nv.Argument).all, Arg_CC_Result'Unrestricted_Access); -- Creating the request PolyORB.Requests.Create_Request (Target => Self, Operation => "Query", Arg_List => Argument_List, Req_Flags => PolyORB.Requests.Sync_With_Target, Result => Result_Nv, Req => Request); -- Invoking the request (synchronously or asynchronously) PolyORB.Requests.Invoke (Request); PolyORB.Requests.Destroy_Request (Request); end Query; procedure Parse_TXT_Record (Answer_RR : PolyORB.Types.String; Str_Ref : out PolyORB.Types.String; Version_id : out PolyORB.Types.String) is use PolyORB.Utils; S : constant String := PolyORB.Types.To_Standard_String (Answer_RR); Index : Integer; Index2 : Integer; begin Index := Find (S, S'First, '=') + 1; Index2 := Find (S, Index, '\') - 1; Str_Ref := Types.To_PolyORB_String (S (Index .. Index2)); Index := Find (S, Index2, '=') + 1; Index2 := S'Last; Version_id := Types.To_PolyORB_String (S (Index .. Index2)); end Parse_TXT_Record; end PolyORB.DSA_P.Name_Service.mDNS.Client; polyorb-2.8~20110207.orig/src/dsa/polyorb-termination_manager.ads0000644000175000017500000001203611750740340024142 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . T E R M I N A T I O N _ M A N A G E R -- -- -- -- S p e c -- -- -- -- Copyright (C) 2006-2008, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- The termination algorithm implemented in this package works by sending -- "waves". Each wave reach the entire set of connex partitions participating -- in the distributed program. Each wave possess a chronological stamp. These -- stamps, allow the construction of an implicit covering tree of all the -- partitions. When we speak of child and father, we are refering to childs -- and fathers in the sense of this implicit tree. Note that for each wave the -- tree may be different. -- XXX * Make the algorithm fault tolerant: if the initiator is not -- responding, spawn a new one. -- * Implement the waves as in GARLIC, one detection wave and one -- termination wave. Not really needed but may be more efficient. package PolyORB.Termination_Manager is pragma Remote_Types; type Term_Manager is tagged limited private; type Term_Manager_Access is access all Term_Manager'Class; type Stamp_Type is private; -- A new stamp value is assigned to each termination detection wave function Is_Terminated (TM : access Term_Manager; Stamp : Stamp_Type) return Boolean; -- Return True iff the partition controlled by TM and all of its childs are -- terminated. function Terminate_Now (TM : access Term_Manager; Stamp : Stamp_Type) return Boolean; -- Terminate all the child partitions of the partition controlled by TM, -- then terminates the partition itself. type Termination_Type is (Global_Termination, Local_Termination, Deferred_Termination); -- The termination policies procedure Start (TM : access Term_Manager; T : Termination_Type; Initiator : Boolean; Time_Between_Waves : Duration; Time_Before_Start : Duration); -- Start the Termination Manager with the chosen policy private type Stamp_Type is mod 2 ** Integer'Size; -- Termination wave time stamp type Term_Manager is tagged limited record Terminated : Boolean := False; -- The termination status for this partition. If this becomes true, the -- partition will shutdown itself. Termination_Policy : Termination_Type := Global_Termination; -- The termination policy of the local partition, by default it is -- Global_Termination. Time_Between_Waves : Duration := 1.0; -- The time we wait between two consecutive waves. Time_Before_Start : Duration := 5.0; -- The time we wait before the initiator starts sending waves, this time -- allows all the partitions to boot and start their own TM. Is_Initiator : Boolean := False; -- Is this Term_Manager the initiator Current_Stamp : Stamp_Type := 0; -- The stamp of the last received wave Non_Terminating_Tasks : Natural := 0; -- The number of expected non terminated tasks when we perform a local -- termination computation. end record; end PolyORB.Termination_Manager; polyorb-2.8~20110207.orig/src/dsa/s-parint.adb0000644000175000017500000024533511750740340020161 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- S Y S T E M . P A R T I T I O N _ I N T E R F A C E -- -- -- -- B o d y -- -- -- -- Copyright (C) 2004-2011, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with Ada.Characters.Handling; with Ada.Unchecked_Conversion; with System.Address_To_Access_Conversions; with System.Standard_Library; with GNAT.HTable; with PolyORB.Binding_Data; with PolyORB.DSA_P.Exceptions; with PolyORB.Dynamic_Dict; with PolyORB.Errors; with PolyORB.Exceptions; with PolyORB.Log; with PolyORB.Opaque; with PolyORB.ORB; with PolyORB.Parameters; pragma Elaborate_All (PolyORB.Parameters); with PolyORB.POA; with PolyORB.POA_Config; with PolyORB.POA_Config.RACWs; with PolyORB.POA_Manager; with PolyORB.POA_Types; with PolyORB.QoS; with PolyORB.QoS.Exception_Informations; with PolyORB.QoS.Term_Manager_Info; with PolyORB.References.Binding; with PolyORB.Request_QoS; with PolyORB.Sequences.Unbounded; with PolyORB.Sequences.Unbounded.Helper; pragma Elaborate_All (PolyORB.Sequences.Unbounded.Helper); with PolyORB.Services.Naming; with PolyORB.Services.Naming.Helper; with PolyORB.Services.Naming.NamingContext; with PolyORB.Services.Naming.NamingContext.Client; with PolyORB.Setup; with PolyORB.Tasking.Condition_Variables; with PolyORB.Tasking.Mutexes; with PolyORB.Tasking.Threads; with PolyORB.Termination_Activity; with PolyORB.Utils.Configuration_File; with PolyORB.Utils.Ilists; with PolyORB.Utils.Strings.Lists; package body System.Partition_Interface is use Ada.Streams; use PolyORB.Any; use PolyORB.References; package PL renames PolyORB.Log; package L is new PolyORB.Log.Facility_Log ("system.partition_interface"); procedure O (Message : String; Level : PL.Log_Level := PL.Debug) renames L.Output; function C (Level : PL.Log_Level := PL.Debug) return Boolean renames L.Enabled; -- A few handy aliases package PSNNC renames PolyORB.Services.Naming.NamingContext; package PTC renames PolyORB.Tasking.Condition_Variables; package PTM renames PolyORB.Tasking.Mutexes; package PTT renames PolyORB.Tasking.Threads; package PUCFCT renames PolyORB.Utils.Configuration_File.Configuration_Table; function To_Lower (S : String) return String renames Ada.Characters.Handling.To_Lower; function Make_Global_Key (Section, Key : String) return String renames PolyORB.Parameters.Make_Global_Key; function "+" (S : String) return PolyORB.Utils.Strings.String_Ptr renames PolyORB.Utils.Strings."+"; -- An opaque octet sequence package Octet_Sequences is new PolyORB.Sequences.Unbounded (PolyORB.Types.Octet); package Octet_Sequences_Helper is new Octet_Sequences.Helper (Element_From_Any => PolyORB.Any.From_Any, Element_To_Any => PolyORB.Any.To_Any, Element_Wrap => PolyORB.Any.Wrap); TC_Opaque_Cache : PATC.Local_Ref; -- Typecode for the opaque octet sequence --------------------------------------------------------------- -- Special operation names for remote call interface objects -- --------------------------------------------------------------- Op_Resolve : constant String := "resolve"; -- Corresponds to the CORBA CosNaming::NamingContext::resolve operation. Op_Get_Partition_Id : constant String := "_get_partition_id"; -- Get the DSA partition identifier for the partition that hosts an RCI ------------------------ -- Local declarations -- ------------------------ Critical_Section : PTM.Mutex_Access; -- Protects shared data structures at the DSA personality level procedure Initialize_Parameters; procedure Initialize; procedure Shutdown (Wait_For_Completion : Boolean); -- Procedures called during global PolyORB initialization function Nameserver_Lookup (Name : String; Kind : String; Initial : Boolean := True) return Ref; -- Look up the specified (Name, Kind) pair from the DSA naming context. -- If Initial is True, repeat lookup until a valid reference is obtained, -- and raise an exception if maximum retry count is reached, else just -- return an empty ref if name server retruns an empty or invalid result. procedure Nameserver_Register (Name : String; Kind : String; Obj : PolyORB.References.Ref); -- Register object with the specified (Name, Kind) pair into the -- DSA naming context. function Is_Reference_Valid (R : PolyORB.References.Ref) return Boolean; -- Binds a reference to determine whether it is valid procedure Detach; -- Detach a procedure using setsid() and closing the standard -- input/standard output/standard error file descriptors. Local_PID_Barrier : PTC.Condition_Access; -- Barrier used by task waiting for Local_PID_Allocated to become True -------------------------------------------- -- RCI lookup and reconnection management -- -------------------------------------------- -- These are the initial and default values Time_Between_Requests : Duration := 1.0; Max_Requests : Natural := 10; type Reconnection_Policy_Type is (Fail_Until_Restart, Block_Until_Restart, Reject_On_Restart); Default_Reconnection_Policy : constant Reconnection_Policy_Type := Fail_Until_Restart; function Get_Reconnection_Policy (Name : String) return Reconnection_Policy_Type; -- Retrieve reconnection policy for this RCI from runtime parameters -- set by gnatdist. ------------------------------------------------ -- Termination manager of the local partition -- ------------------------------------------------ -- These values are set by Register_Termination_Manager, which is called -- during elaboration of Termination_Manager.Bootstrap. The_TM_Ref : Ref := Nil_Ref; -- Reference to the termination manager The_TM_Oid : PolyORB.Objects.Object_Id_Access; -- The termination manager Object ID The_TM_Address : System.Address; -- The local termination manager servant address The_TM_Shutdown : PolyORB.Initialization.Finalizer; -- The local termination manager shutdown hook -------------------------------- -- Map of all known RCI units -- -------------------------------- type RCI_State is (Initial, Live, Dead); type RCI_Info is limited record Is_All_Calls_Remote : Boolean := True; -- True if the package is remote or pragma All_Call_Remotes applies Base_Ref : Object_Ref; -- Main reference for package Is_Local : Boolean := False; -- True if the package is assigned on local partition Reconnection_Policy : Reconnection_Policy_Type := Default_Reconnection_Policy; -- Reconnection policy for this RCI's partition State : RCI_State := Initial; -- Initial: never looked up from name server -- Live: valid ref or trying to reconnect -- Dead: permanently unreachable (for Reject_On_Restart policy) Known_Partition_ID : Boolean := False; -- True if the package is not assigned on local partition, and its -- partition ID is known. RCI_Partition_ID : RPC.Partition_ID := RPC.Partition_ID'First; -- Cache of RCI's partition ID, if known end record; type RCI_Info_Access is access all RCI_Info; package Known_RCIs is new PolyORB.Dynamic_Dict (RCI_Info_Access); -- This list is keyed with the lowercased full names of the RCI units. -- Concurrent accesses to Known_RCIs after elaboration must be protected -- by the DSA critical section. procedure Retrieve_RCI_Info (Name : String; Info : in out RCI_Info_Access); -- Retrieve RCI information for a local or remote RCI package. If Info -- is already set to a non-null value, it is used as the RCI_Info for the -- unit, else it is looked up from Known_RCIs, and possibly dynamically -- allocated (if not alread present in Known_RCIs). -- To limit the amount of memory leaked by the use of distributed object -- stub types, these are referenced in a hash table and reused whenever -- possible. Access to this hash table is protected by the DSA critical -- section. type Hash_Index is range 0 .. 100; function Hash (K : RACW_Stub_Type_Access) return Hash_Index; --------------------------- -- DSA parameters source -- --------------------------- Conf_Table : PUCFCT.Table_Instance; type DSA_Source is new PolyORB.Parameters.Parameters_Source with null record; function Get_Conf (Source : access DSA_Source; Section, Key : String) return String; The_DSA_Source : aliased DSA_Source; type RCI_Attribute is (Local, Reconnection); function RCI_Attr (Name : String; Attr : RCI_Attribute) return String; -- Some parameters in section DSA describe attributes of RCI units. -- Their names are of the force RCI_Name'Attribute_Name. RPC_Timeout : Duration; -- Default timeout applied to all remote calls ------------------------ -- Internal functions -- ------------------------ function Compare_Content (Left, Right : RACW_Stub_Type_Access) return Boolean; package Objects_HTable is new GNAT.HTable.Simple_HTable (Header_Num => Hash_Index, Element => RACW_Stub_Type_Access, No_Element => null, Key => RACW_Stub_Type_Access, Hash => Hash, Equal => Compare_Content); -- When a RACW must be constructed to designate a local object, an object -- identifier is created using the address of the object. subtype Local_Oid is PolyORB.Objects.Object_Id (1 .. System.Address'Size / 8); function To_Local_Oid is new Ada.Unchecked_Conversion (System.Address, Local_Oid); function To_Address is new Ada.Unchecked_Conversion (Local_Oid, System.Address); procedure Setup_Object_RPC_Receiver (Name : String; Default_Servant : Servant_Access); -- Set up an object adapter to receive method invocation requests for -- distributed object type Name. Use the specified POA configuration (which -- must include the USER_ID, NON_RETAIN and USE_DEFAULT_SERVANT policies). -- The components of Servant are set appropriately. function DSA_Exception_To_Any (E : Ada.Exceptions.Exception_Occurrence) return Any; -- Construct an Any from an Ada exception raised by a servant function To_Name (Id, Kind : String) return PolyORB.Services.Naming.Name; -- Construct a name consisting of a single name component with the given -- id and kind. function Naming_Context return PSNNC.Ref; -- Naming context used to register all library units in a DSA application Naming_Context_Cache : PSNNC.Ref; ------------------------------------------ -- List of all RPC receivers (servants) -- ------------------------------------------ function Link (S : access Private_Info; Which : PolyORB.Utils.Ilists.Link_Type) return access Private_Info_Access; package Receiving_Stub_Lists is new PolyORB.Utils.Ilists.Lists (Private_Info, Private_Info_Access, Doubly_Linked => False); All_Receiving_Stubs : Receiving_Stub_Lists.List; RPC_Receivers_Activated : Boolean := False; -- False until Activate_RPC_Receivers has been called, at which point -- incoming RPCs can be serviced. procedure Activate_RPC_Receiver (Default_Servant : Servant_Access); -- Activate one RPC receiver (i.e. enable the processing of incoming remote -- subprogram calls to that servant). --------------------------- -- Activate_RPC_Receiver -- --------------------------- procedure Activate_RPC_Receiver (Default_Servant : Servant_Access) is use PolyORB.Errors; use PolyORB.POA; use PolyORB.POA_Manager; POA : constant Obj_Adapter_Access := Obj_Adapter_Access (Default_Servant.Object_Adapter); Error : Error_Container; begin pragma Debug (C, O ("Activate_RPC_Receiver: " & Default_Servant.Impl_Info.Name.all)); Activate (POAManager_Access (Entity_Of (POA.POA_Manager)), Error); if Found (Error) then PolyORB.DSA_P.Exceptions.Raise_From_Error (Error); end if; end Activate_RPC_Receiver; ---------------------------- -- Activate_RPC_Receivers -- ---------------------------- procedure Activate_RPC_Receivers is use Receiving_Stub_Lists; It : Iterator; begin pragma Debug (C, O ("Activate_RPC_Receivers: enter")); RPC_Receivers_Activated := True; It := First (All_Receiving_Stubs); while not Last (It) loop Activate_RPC_Receiver (Value (It).Receiver); Next (It); end loop; pragma Debug (C, O ("Activate_RPC_Receivers: end")); end Activate_RPC_Receivers; ------------------------- -- Any_Aggregate_Build -- ------------------------- function Any_Aggregate_Build (TypeCode : PATC.Local_Ref; Contents : Any_Array) return Any is Result : Any := Get_Empty_Any_Aggregate (TypeCode); begin for J in Contents'Range loop Add_Aggregate_Element (Result, Contents (J)); end loop; return Result; end Any_Aggregate_Build; --------------------- -- Any_Member_Type -- --------------------- function Any_Member_Type (A : Any; Index : System.Unsigned_Types.Long_Unsigned) return PATC.Local_Ref is begin return PATC.To_Ref (PATC.Member_Type (Get_Unwound_Type (A), PolyORB.Types.Unsigned_Long (Index))); end Any_Member_Type; --------------- -- Any_To_BS -- --------------- procedure Any_To_BS (Item : Any; Stream : out Buffer_Stream_Type) is use type PolyORB.Types.Unsigned_Long; AC : Any_Container'Class renames Get_Container (Item).all; ACC : Aggregate_Content'Class renames Aggregate_Content'Class (Get_Value (AC).all); El_Count : constant PolyORB.Types.Unsigned_Long := Get_Aggregate_Count (ACC); Data_Length : constant Stream_Element_Count := Stream_Element_Count (El_Count - 1); pragma Assert (El_Count - 1 = Get_Aggregate_Element (AC, 0)); -- Note: for a sequence aggregate, the first aggregate element is the -- sequence length. Data_Address : System.Address := Unchecked_Get_V (ACC'Access); begin if Data_Address /= Null_Address then PolyORB.Buffers.Initialize_Buffer (Stream.Buf'Access, Data_Length, Data_Address, PolyORB.Buffers.Endianness_Type'First, -- XXX Irrelevant 0); else -- Case of default aggregate contents: there is no materialized -- array of octets. Note, this is quite inefficient, instead -- PolyORB.Any.Get_Empty_Any_Aggregate should always make sure that -- any sequence contents uses the specific shadow any rather -- than the inefficient default aggregate contents. Or alternatively -- the default aggregate contents could be optimized for the case -- of components of an elementary type, and provide an actual -- content array in that case, accessable through Unchecked_Get_V. PolyORB.Buffers.Allocate_And_Insert_Cooked_Data (Stream.Buf'Access, Data_Length, Data_Address); declare Data : array (1 .. Data_Length) of PolyORB.Types.Octet; for Data'Address use Data_Address; pragma Import (Ada, Data); begin for J in Data'Range loop Data (J) := Get_Aggregate_Element (AC, PolyORB.Types.Unsigned_Long (J)); end loop; end; PolyORB.Buffers.Rewind (Stream.Buf'Access); end if; end Any_To_BS; --------------- -- BS_To_Any -- --------------- procedure BS_To_Any (Stream : Buffer_Stream_Type; Item : out Any) is use Octet_Sequences; S : PolyORB.Opaque.Zone_Access := new Stream_Element_Array'(PolyORB.Buffers.To_Stream_Element_Array (Stream.Buf)); subtype OSEA_T is Element_Array (1 .. S'Length); OSEA_Addr : constant System.Address := S (S'First)'Address; OSEA : OSEA_T; for OSEA'Address use OSEA_Addr; pragma Import (Ada, OSEA); begin Item := Octet_Sequences_Helper.To_Any (To_Sequence (OSEA)); PolyORB.Opaque.Free (S); end BS_To_Any; --------------------------- -- Build_Local_Reference -- --------------------------- procedure Build_Local_Reference (Addr : System.Address; Typ : String; Receiver : access Servant; Ref : out PolyORB.References.Ref) is use PolyORB.Errors; use type PolyORB.Obj_Adapters.Obj_Adapter_Access; Last : Integer := Typ'Last; Error : Error_Container; begin if Last in Typ'Range and then Typ (Last) = ASCII.NUL then Last := Last - 1; end if; if Addr /= Null_Address then pragma Assert (Receiver.Object_Adapter /= null); declare Key : aliased PolyORB.Objects.Object_Id := To_Local_Oid (Addr); U_Oid : PolyORB.POA_Types.Unmarshalled_Oid; Oid : PolyORB.POA_Types.Object_Id_Access; begin PolyORB.POA.Activate_Object (Self => PolyORB.POA.Obj_Adapter_Access (Receiver.Object_Adapter), P_Servant => null, Hint => Key'Unchecked_Access, U_Oid => U_Oid, Error => Error); if Found (Error) then PolyORB.DSA_P.Exceptions.Raise_From_Error (Error); end if; Oid := PolyORB.POA_Types.U_Oid_To_Oid (U_Oid); if Found (Error) then PolyORB.DSA_P.Exceptions.Raise_From_Error (Error); end if; PolyORB.ORB.Create_Reference (PolyORB.Setup.The_ORB, Oid, "DSA:" & Typ (Typ'First .. Last), Ref); PolyORB.Objects.Free (Oid); end; end if; exception when E : others => pragma Debug (C, O ("Build_Local_Reference: got exception " & Ada.Exceptions.Exception_Information (E))); pragma Debug (C, O ("returning a nil ref.")); null; end Build_Local_Reference; ------------------------ -- Caseless_String_Eq -- ------------------------ function Caseless_String_Eq (S1, S2 : String) return Boolean is begin return To_Lower (S1) = To_Lower (S2); end Caseless_String_Eq; ----------- -- Check -- ----------- procedure Check (Name : String; Version : String; RCI : Boolean := True) is use Ada.Exceptions; Info : RCI_Info_Access; begin pragma Debug (C, O ("Check: checking RCI versions consistency")); if not RCI then return; end if; Retrieve_RCI_Info (Name, Info); declare Type_Id : constant String := Type_Id_Of (Info.Base_Ref); Last_Colon : Integer; begin for C in reverse Type_Id'Range loop if Type_Id (C) = ':' then Last_Colon := C; exit; end if; end loop; if Version /= Type_Id (Last_Colon + 1 .. Type_Id'Last) then raise Program_Error with "Versions differ for unit """ & Name & """"; end if; end; end Check; --------------------- -- Compare_Content -- --------------------- function Compare_Content (Left, Right : RACW_Stub_Type_Access) return Boolean is use System.RPC; Left_Object, Right_Object : PolyORB.References.Ref; begin Set (Left_Object, Left.Target); Set (Right_Object, Right.Target); return Left /= null and then Right /= null and then PolyORB.References.Is_Equivalent (Left_Object, Right_Object); end Compare_Content; ---------------- -- Create_Any -- ---------------- function Create_Any (TC : PATC.Local_Ref) return Any is use type PATC.Local_Ref; begin if Unwind_Typedefs (TC) = TC_Opaque then declare Empty_Seq : Octet_Sequences.Sequence; begin return Octet_Sequences_Helper.To_Any (Empty_Seq); end; else return Get_Empty_Any_Aggregate (TC); end if; end Create_Any; ------------ -- Detach -- ------------ procedure Detach is procedure C_Detach; pragma Import (C, C_Detach, "__PolyORB_detach"); begin C_Detach; end Detach; -------------------------- -- DSA_Exception_To_Any -- -------------------------- function DSA_Exception_To_Any (E : Ada.Exceptions.Exception_Occurrence) return Any is use PolyORB.Errors; use PolyORB.Types; Name : constant String := PolyORB.Exceptions.Occurrence_To_Name (E); TC : constant PATC.Local_Ref := PATC.TC_Except; Result : PolyORB.Any.Any; begin -- Name PATC.Add_Parameter (TC, To_Any (To_PolyORB_String (Name))); -- RepositoryId PATC.Add_Parameter (TC, To_Any (To_PolyORB_String (PolyORB.DSA_P.Exceptions.Exception_Repository_Id (Name, "1.0")))); -- Valuation: Exception_Message PATC.Add_Parameter (TC, To_Any (TC_String)); PATC.Add_Parameter (TC, To_Any (To_PolyORB_String ("exception_message"))); Result := Get_Empty_Any_Aggregate (TC); Add_Aggregate_Element (Result, To_Any (To_PolyORB_String (Ada.Exceptions.Exception_Message (E)))); return Result; end DSA_Exception_To_Any; --------------------- -- Execute_Servant -- --------------------- function Execute_Servant (Self : not null access Servant; Req : PolyORB.Requests.Request_Access) return Boolean is begin if Self.Impl_Info.Kind = Pkg_Stub then -- The base reference for an RCI unit implements operations -- that correspond to the visible subprograms of the unit -- (which are handled by Self.Handler). -- In addition, it implements the following special operations: -- XXX these hand-crafted skels should be generated by -- auto-generated ones constructed from a distributed object -- type declaration. if Req.Operation.all = Op_Resolve then ------------- -- resolve -- ------------- -- Resolve the name of a remote subprogram declared in this -- remote call interface unit to the corresponding reference -- for the purpose of constructing a RAS value. -- Code extracted from CosNaming::NamingContext IDL skel. declare package ISNC renames PolyORB.Services.Naming.SEQUENCE_NameComponent; n : PolyORB.Services.Naming.Name; Arg_Name_n : constant PolyORB.Types.Identifier := To_PolyORB_String ("n"); Argument_n : constant Any := Get_Empty_Any ( PolyORB.Services.Naming.Helper.TC_Name); Result : Object_Ref; Arg_List : NVList_Ref; begin -- Create argument list NVList_Create (Arg_List); NVList_Add_Item (Arg_List, Arg_Name_n, Argument_n, ARG_IN); Request_Arguments (Req, Arg_List); -- Convert arguments from their Any n := PolyORB.Services.Naming.Helper.From_Any (Argument_n); -- Call implementation Get_RAS_Info (Self.Impl_Info.Name.all, PolyORB.Services.Naming.To_Standard_String (ISNC.Get_Element (ISNC.Sequence (n), 1).id), Result); -- Set Result Req.Result := (Name => PolyORB.Types.To_PolyORB_String ("result"), Arg_Modes => ARG_OUT, Argument => PolyORB.Any.ObjRef.To_Any (Result)); end; goto Request_Completed; elsif Req.Operation.all = Op_Get_Partition_Id then declare Arg_List : NVList_Ref; begin ----------------------- -- _get_partition_id -- ----------------------- -- Return the partition identifier assigned to the -- partition on which this RCI unit resides. NVList_Create (Arg_List); Request_Arguments (Req, Arg_List); -- Must call Arguments (with an empty Arg_List) to -- notify the protocol personality that this request has -- been completely received. Req.Result := (Name => PolyORB.Types.To_PolyORB_String ("result"), Arg_Modes => ARG_OUT, Argument => TA_I (Integer (Get_Local_Partition_ID))); goto Request_Completed; end; end if; end if; -- User-defined subprogram: perform upcall to implementation -- Extract service context info used by the termination manager PolyORB.QoS.Term_Manager_Info.Extract_TM_Info (Req); pragma Assert (Self.Handler /= null); declare use PolyORB.Errors; begin Self.Handler.all (Req); exception when E : others => -- Save exception occurrence in request Req.Exception_Info := DSA_Exception_To_Any (E); -- Also record additional exception information in optional -- service context. PolyORB.QoS.Exception_Informations.Set_Exception_Information (Req.all, E); end; <> return True; end Execute_Servant; ------------------------- -- Extract_Union_Value -- ------------------------- function Extract_Union_Value (U : Any) return Any is U_Type : constant PATC.Local_Ref := Get_Type (U); Label_Any : constant Any := PolyORB.Any.Get_Aggregate_Element (U, PATC.Discriminator_Type (U_Type), 0); Value_Type : constant PATC.Local_Ref := PATC.Member_Type_With_Label (U_Type, Label_Any); begin return PolyORB.Any.Get_Aggregate_Element (U, Value_Type, 1); end Extract_Union_Value; -------------- -- From_Any -- -------------- function FA_A (Item : PolyORB.Any.Any) return DSAT.Any_Container_Ptr is Item_ACP : constant PolyORB.Any.Any_Container_Ptr := PolyORB.Any.Get_Container (PolyORB.Any.From_Any (Item)); pragma Warnings (Off); -- No aliasing issues since DSAT.Any_Container_Ptr values are never -- dereferenced without first being converted back to -- PolyORB.Any.Any_Container_Ptr. function To_DSAT_ACP is new Ada.Unchecked_Conversion (PolyORB.Any.Any_Container_Ptr, DSAT.Any_Container_Ptr); begin return To_DSAT_ACP (Item_ACP); end FA_A; function FA_B (Item : PolyORB.Any.Any) return Boolean is begin return Boolean (PolyORB.Types.Boolean'(From_Any (Item))); end FA_B; function FA_C (Item : PolyORB.Any.Any) return Character is begin return Character (PolyORB.Types.Char'(From_Any (Item))); end FA_C; function FA_F (Item : PolyORB.Any.Any) return Float is begin return Float (PolyORB.Types.Float'(From_Any (Item))); end FA_F; function FA_I (Item : PolyORB.Any.Any) return Integer is begin return Integer (PolyORB.Types.Long'(From_Any (Item))); end FA_I; function FA_U (Item : PolyORB.Any.Any) return Unsigned is begin return Unsigned (PolyORB.Types.Unsigned_Long'(From_Any (Item))); end FA_U; function FA_LF (Item : PolyORB.Any.Any) return Long_Float is begin return Long_Float (PolyORB.Types.Double'(From_Any (Item))); end FA_LF; function FA_LI (Item : PolyORB.Any.Any) return Long_Integer is begin return Long_Integer (PolyORB.Types.Long'(From_Any (Item))); end FA_LI; function FA_LU (Item : PolyORB.Any.Any) return Long_Unsigned is begin return Long_Unsigned (PolyORB.Types.Unsigned_Long'(From_Any (Item))); end FA_LU; function FA_LLF (Item : PolyORB.Any.Any) return Long_Long_Float is begin return Long_Long_Float (PolyORB.Types.Long_Double'(From_Any (Item))); end FA_LLF; function FA_LLI (Item : PolyORB.Any.Any) return Long_Long_Integer is begin return Long_Long_Integer (PolyORB.Types.Long_Long'(From_Any (Item))); end FA_LLI; function FA_LLU (Item : PolyORB.Any.Any) return Long_Long_Unsigned is begin return Long_Long_Unsigned (PolyORB.Types.Unsigned_Long_Long'(From_Any (Item))); end FA_LLU; function FA_SF (Item : PolyORB.Any.Any) return Short_Float is begin return Short_Float (PolyORB.Types.Float'(From_Any (Item))); end FA_SF; function FA_SI (Item : PolyORB.Any.Any) return Short_Integer is begin return Short_Integer (PolyORB.Types.Short'(From_Any (Item))); end FA_SI; function FA_SU (Item : PolyORB.Any.Any) return Short_Unsigned is begin return Short_Unsigned (PolyORB.Types.Unsigned_Short'(From_Any (Item))); end FA_SU; function FA_SSI (Item : PolyORB.Any.Any) return Short_Short_Integer is function To_SSI is new Ada.Unchecked_Conversion (PolyORB.Types.Octet, Short_Short_Integer); begin return To_SSI (From_Any (Item)); end FA_SSI; function FA_SSU (Item : PolyORB.Any.Any) return Short_Short_Unsigned is function To_SSU is new Ada.Unchecked_Conversion (PolyORB.Types.Octet, Short_Short_Unsigned); begin return To_SSU (From_Any (Item)); end FA_SSU; function FA_WC (Item : PolyORB.Any.Any) return Wide_Character is begin return Wide_Character (PolyORB.Types.Wchar'(From_Any (Item))); end FA_WC; function FA_String (Item : PolyORB.Any.Any) return Ada.Strings.Unbounded.Unbounded_String is begin return Ada.Strings.Unbounded.Unbounded_String (PolyORB.Types.String'(From_Any (Item))); end FA_String; --------------------------- -- Get_Aggregate_Element -- --------------------------- function Get_Aggregate_Element (Value : Any; TC : PATC.Local_Ref; Index : System.Unsigned_Types.Long_Unsigned) return Any is begin return PolyORB.Any.Get_Aggregate_Element (Value, TC, PolyORB.Types.Unsigned_Long (Index)); end Get_Aggregate_Element; ----------------------------- -- Get_Active_Partition_ID -- ----------------------------- function Get_Active_Partition_ID (Name : Unit_Name) return RPC.Partition_ID is Is_Local : constant Boolean := PolyORB.Parameters.Get_Conf ("dsa", RCI_Attr (Name, Local)); Info : RCI_Info_Access; begin -- If the unit is local, we should return the partition_id of the local -- partition. -- To determine if the unit is local, we cannot use the -- RCI_Info.Is_Local attribute, since RCI_Info will only be available -- after the RCI receiving stub is registered (and this is not -- guaranteed to happen before a call to Get_Active_Partition_Id is -- issued). -- Thus we use the configuration parameters set up by po_gnatdist in the -- per-partition specific unit 'PolyORB.Parameters.Partition'. if Is_Local then return Get_Local_Partition_ID; end if; Retrieve_RCI_Info (Name, Info); if not Info.Known_Partition_ID then declare Request : PolyORB.Requests.Request_Access; Arg_List : PolyORB.Any.NVList.Ref; Result : PolyORB.Any.NamedValue; begin -- XXX This hand-crafted stub should be replaced with -- one automatically generated from a remote object type -- declaration. PolyORB.Any.NVList.Create (Arg_List); Result := (Name => To_PolyORB_String ("result"), Argument => Get_Empty_Any (TC_I), Arg_Modes => 0); PolyORB.Requests.Create_Request (Target => Info.Base_Ref, Operation => Op_Get_Partition_Id, Arg_List => Arg_List, Result => Result, Req => Request); PolyORB.Requests.Invoke (Request); PolyORB.Requests.Destroy_Request (Request); Info.Known_Partition_ID := True; Info.RCI_Partition_ID := RPC.Partition_ID (FA_I (Result.Argument)); end; end if; pragma Assert (Info.Known_Partition_ID); return Info.RCI_Partition_ID; end Get_Active_Partition_ID; -------------- -- Get_Conf -- -------------- function Get_Conf (Source : access DSA_Source; Section, Key : String) return String is pragma Unreferenced (Source); subtype String_Ptr is PolyORB.Utils.Strings.String_Ptr; use type String_Ptr; V : constant String_Ptr := PUCFCT.Lookup (Conf_Table, Make_Global_Key (Section, Key), null); begin if V /= null then return V.all; else return ""; end if; end Get_Conf; ----------------------- -- Get_Local_Address -- ----------------------- procedure Get_Local_Address (Ref : PolyORB.References.Ref; Is_Local : out Boolean; Addr : out System.Address) is use PolyORB.Errors; Profiles : constant Profile_Array := PolyORB.References.Profiles_Of (Ref); Error : Error_Container; begin for J in Profiles'Range loop if PolyORB.ORB.Is_Profile_Local (PolyORB.Setup.The_ORB, Profiles (J)) then declare use PolyORB.Binding_Data; use PolyORB.Objects; Key : Object_Id_Access; begin PolyORB.Obj_Adapters.Object_Key (OA => PolyORB.ORB.Object_Adapter (PolyORB.Setup.The_ORB), Id => PolyORB.Binding_Data.Get_Object_Key (Profiles (J).all), User_Id => Key, Error => Error); if not Found (Error) then Is_Local := True; if The_TM_Oid /= null and then Get_Object_Key (Profiles (J).all).all = The_TM_Oid.all then -- Requests for the Termination Manager do not contain -- the local memory address of the object (they are -- performed through a reference created under a specific -- POA and a dummy object key) so these have to be -- handled specifically. Addr := The_TM_Address; else Addr := To_Address (Key (Key'Range)); end if; PolyORB.Objects.Free (Key); -- XXX not sure we can do that ... return; elsif Error.Kind = Invalid_Object_Id_E then Catch (Error); -- This object identifier does not contain a user-assigned -- object key. else PolyORB.DSA_P.Exceptions.Raise_From_Error (Error); end if; end; end if; end loop; Is_Local := False; Addr := Null_Address; end Get_Local_Address; ----------------------------- -- Get_Reconnection_Policy -- ----------------------------- function Get_Reconnection_Policy (Name : String) return Reconnection_Policy_Type is begin return Reconnection_Policy_Type'Value (PolyORB.Parameters.Get_Conf (Section => "dsa", Key => RCI_Attr (Name, Reconnection), Default => Default_Reconnection_Policy'Img)); end Get_Reconnection_Policy; ------------ -- Get_TC -- ------------ function Get_TC (A : Any) return PATC.Local_Ref is begin return PATC.To_Ref (PolyORB.Any.Get_Unwound_Type (A)); end Get_TC; ---------- -- Link -- ---------- function Link (S : access Private_Info; Which : PolyORB.Utils.Ilists.Link_Type) return access Private_Info_Access is use PolyORB.Utils.Ilists; begin pragma Assert (Which = Next); return S.Next'Unchecked_Access; end Link; ------------------------- -- Local_PID_Allocated -- ------------------------- function Local_PID_Allocated return Boolean is begin return System.Standard_Library.Local_Partition_ID /= 0; end Local_PID_Allocated; ---------------------------- -- Set_Local_Partition_ID -- ---------------------------- procedure Set_Local_Partition_ID (PID : RPC.Partition_ID) is use type RPC.Partition_ID; begin -- A PID of 0 denotes the unset (initial) state of -- System.Standard_Library.Local_Partition_ID. pragma Assert (PID /= 0); PTM.Enter (Critical_Section); if not Local_PID_Allocated then System.Standard_Library.Local_Partition_ID := Natural (PID); PTC.Broadcast (Local_PID_Barrier); else -- Should attempts to set the local PID twice be diagnosed??? null; end if; PTM.Leave (Critical_Section); end Set_Local_Partition_ID; ---------------------------- -- Get_Local_Partition_ID -- ---------------------------- function Get_Local_Partition_ID return RPC.Partition_ID is begin PTM.Enter (Critical_Section); if not Local_PID_Allocated then -- Wait until a partition identifier has been assigned to the -- local partition (this barrier is opened once System.DSA_Services -- is elaborated). PTC.Wait (Local_PID_Barrier, Critical_Section); pragma Assert (Local_PID_Allocated); end if; PTM.Leave (Critical_Section); return RPC.Partition_ID (System.Standard_Library.Local_Partition_ID); end Get_Local_Partition_ID; ------------------------------ -- Get_Local_Partition_Name -- ------------------------------ function Get_Local_Partition_Name return String is begin return PolyORB.Parameters.Get_Conf (Section => "dsa", Key => "partition_name", Default => "NO NAME"); end Get_Local_Partition_Name; -------------------------------- -- Get_Nested_Sequence_Length -- -------------------------------- function Get_Nested_Sequence_Length (Value : Any; Depth : Positive) return Unsigned is use type PolyORB.Types.Unsigned_Long; Seq_Any : PolyORB.Any.Any; TC : constant PATC.Object_Ptr := Get_Unwound_Type (Value); begin pragma Debug (C, O ("Get_Nested_Sequence_Length: enter," & " Depth =" & Depth'Img & "," & " TC = " & Image (TC))); if PATC.Kind (TC) = Tk_Struct then declare Index : constant PolyORB.Types.Unsigned_Long := PATC.Member_Count (TC) - 1; begin pragma Debug (C, O ("Index of last member is" & Index'Img)); Seq_Any := Get_Aggregate_Element (Value, PATC.Member_Type (TC, Index), Index); end; else pragma Debug (C, O ("TC is (assumed to be) a Tk_Sequence")); pragma Assert (PATC.Kind (TC) = Tk_Sequence); Seq_Any := Value; end if; declare use type Unsigned; Outer_Length : constant Unsigned := FA_U (PolyORB.Any.Get_Aggregate_Element (Seq_Any, TC_U, 0)); begin if Depth = 1 or else Outer_Length = 0 then return Outer_Length; else Seq_Any := PolyORB.Any.Get_Aggregate_Element (Seq_Any, Content_Type (Get_Type (Seq_Any)), 1); return Get_Nested_Sequence_Length (Seq_Any, Depth - 1); end if; end; end Get_Nested_Sequence_Length; -------------- -- Get_RACW -- -------------- function Get_RACW (Ref : PolyORB.References.Ref; Stub_Tag : Ada.Tags.Tag; Is_RAS : Boolean; Asynchronous : Boolean) return System.Address is Is_Local : Boolean; Addr : System.Address; Stub_Obj : aliased RACW_Stub_Type; Stub_Acc : RACW_Stub_Type_Access := Stub_Obj'Unchecked_Access; Stub_Obj_Tag : access Ada.Tags.Tag; begin -- Case of a nil reference: return a null address if Is_Nil (Ref) then return Null_Address; end if; Get_Local_Address (Ref, Is_Local, Addr); -- Local case: return address of local object if Is_Local then declare RAS_Proxy : RAS_Proxy_Type; for RAS_Proxy'Address use Addr; pragma Import (Ada, RAS_Proxy); begin if not (Is_RAS and then RAS_Proxy.All_Calls_Remote) then return Addr; end if; end; end if; -- Remote case: return address of stub Stub_Obj.Target := Entity_Of (Ref); Inc_Usage (Stub_Obj.Target); Stub_Obj.Asynchronous := Asynchronous; Get_Unique_Remote_Pointer (Stub_Acc); -- Fix up stub tag. This is safe because we carefully ensure that -- all stub types have the same layout as RACW_Stub_Type. declare CW_Stub_Obj : RACW_Stub_Type'Class renames RACW_Stub_Type'Class (Stub_Acc.all); -- Class-wide view of stub object, to which 'Tag can be applied begin Stub_Obj_Tag := CW_Stub_Obj'Tag'Unrestricted_Access; Stub_Obj_Tag.all := Stub_Tag; end; return Stub_Acc.all'Address; end Get_RACW; ------------------ -- Get_RAS_Info -- ------------------ procedure Get_RAS_Info (Pkg_Name : String; Subprogram_Name : String; Subp_Ref : out Object_Ref) is Info : RCI_Info_Access; begin Retrieve_RCI_Info (Pkg_Name, Info); if Info.Is_Local then -- Retrieve subprogram address using subprogram name and subprogram -- table. Warning: the name used MUST be the distribution-name (with -- overload suffix, where appropriate.) declare use Receiving_Stub_Lists; It : Receiving_Stub_Lists.Iterator := First (All_Receiving_Stubs); Addr : System.Address := System.Null_Address; Receiver : Servant_Access := null; begin -- XXX -- The following is ugly and inefficient (two levels of linear -- search) and should probably be optimized in some way. pragma Debug (C, O ("Looking up RAS ref for " & Subprogram_Name & " in " & Pkg_Name)); All_Stubs : while not Last (It) loop declare RS : Private_Info renames Value (It).all; pragma Assert (RS.Subp_Info /= Null_Address); subtype Subp_Array is RCI_Subp_Info_Array (0 .. RS.Subp_Info_Len - 1); package Subp_Info_Addr_Conv is new System.Address_To_Access_Conversions (Subp_Array); Subp_Info : constant Subp_Info_Addr_Conv.Object_Pointer := Subp_Info_Addr_Conv.To_Pointer (RS.Subp_Info); begin if RS.Kind = Pkg_Stub and then To_Lower (RS.Name.all) = To_Lower (Pkg_Name) then for J in Subp_Info'Range loop declare Info : RCI_Subp_Info renames Subp_Info (J); subtype Str is String (1 .. Info.Name_Length); package Str_Addr_Conv is new System.Address_To_Access_Conversions (Str); begin if Str_Addr_Conv.To_Pointer (Info.Name).all = Subprogram_Name then Addr := Info.Addr; Receiver := RS.Receiver; exit All_Stubs; end if; end; end loop; end if; end; Next (It); end loop All_Stubs; pragma Assert (Addr /= System.Null_Address); Build_Local_Reference (Addr, Pkg_Name, Receiver, Subp_Ref); end; else declare Ctx_Ref : PSNNC.Ref; begin PSNNC.Set (Ctx_Ref, Entity_Of (Info.Base_Ref)); Subp_Ref := PSNNC.Client.Resolve (Ctx_Ref, To_Name (Subprogram_Name, "SUBP")); end; end if; end Get_RAS_Info; ------------------- -- Get_Reference -- ------------------- function Get_Reference (RACW : System.Address; Type_Name : String; Stub_Tag : Ada.Tags.Tag; Is_RAS : Boolean; Receiver : access Servant) return PolyORB.References.Ref is RACW_Stub : RACW_Stub_Type; for RACW_Stub'Address use RACW; pragma Import (Ada, RACW_Stub); CW_RACW_Stub : RACW_Stub_Type'Class renames RACW_Stub_Type'Class (RACW_Stub); use type Ada.Tags.Tag; begin -- Null case if RACW = System.Null_Address then -- Nothing to do, default initialization for Result is Nil return Nil_Ref; -- Case of a remote object elsif CW_RACW_Stub'Tag = Stub_Tag then return Make_Ref (RACW_Stub.Target); -- Case of a local object elsif Is_RAS then -- Remote access to subprogram: use ref from proxy declare RAS_Proxy : RAS_Proxy_Type; for RAS_Proxy'Address use RACW; pragma Import (Ada, RAS_Proxy); begin return Make_Ref (RAS_Proxy.Target); end; else -- Local object declare Result : PolyORB.References.Ref; begin Build_Local_Reference (RACW, Type_Name, Receiver, Result); return Result; end; end if; end Get_Reference; ------------------------------- -- Get_Unique_Remote_Pointer -- ------------------------------- procedure Get_Unique_Remote_Pointer (Handler : in out RACW_Stub_Type_Access) is Answer : RACW_Stub_Type_Access; begin PTM.Enter (Critical_Section); Answer := Objects_HTable.Get (Handler); if Answer = null then Answer := new RACW_Stub_Type; -- We leak memory here each time we receive a new unique value of a -- remote access to classwide or remote access to subprogram type. Answer.Target := Handler.Target; Answer.Asynchronous := Handler.Asynchronous; Objects_HTable.Set (Answer, Answer); else PolyORB.Smart_Pointers.Dec_Usage (Handler.Target); end if; Handler := Answer; PTM.Leave (Critical_Section); end Get_Unique_Remote_Pointer; ---------- -- Hash -- ---------- function Hash_String is new GNAT.HTable.Hash (Hash_Index); function Hash (K : RACW_Stub_Type_Access) return Hash_Index is K_Ref : PolyORB.References.Ref; begin Set (K_Ref, K.Target); return Hash_String (PolyORB.References.Image (K_Ref)); end Hash; ---------------- -- Initialize -- ---------------- procedure Initialize is begin TC_Opaque_Cache := PATC.Build_Sequence_TC (TC_Octet, 0); Octet_Sequences_Helper.Initialize (Element_TC => PolyORB.Any.TC_Octet, Sequence_TC => TC_Opaque_Cache); PTM.Create (Critical_Section); PTC.Create (Local_PID_Barrier); -- Get runtime parameters Time_Between_Requests := PolyORB.Parameters.Get_Conf (Section => "dsa", Key => "delay_between_failed_requests", Default => 1.0); Max_Requests := PolyORB.Parameters.Get_Conf (Section => "dsa", Key => "max_failed_requests", Default => 10); RPC_Timeout := PolyORB.Parameters.Get_Conf (Section => "dsa", Key => "rpc_timeout", Default => 0.0); end Initialize; --------------------------- -- Initialize_Parameters -- --------------------------- procedure Initialize_Parameters is procedure Set_Conf (Section, Key, Value : String); -- Call back to set the given configuration parameter -------------- -- Set_Conf -- -------------- procedure Set_Conf (Section, Key, Value : String) is LS : constant String := To_Lower (Section); LK : constant String := To_Lower (Key); begin pragma Debug (C, O ("Set_Conf: [" & Section & "] " & Key & " = " & Value)); PUCFCT.Insert (Conf_Table, Make_Global_Key (Section, Key), +Value); -- Placeholders for future special handling of Self_Location and -- Boot_Location attributes. ??? if LS = "dsa" then if LK = "self_location" then null; elsif LK = "boot_location" then null; end if; end if; end Set_Conf; -- Start of processing for Initialize_Parameters begin PUCFCT.Initialize (Conf_Table); PolyORB.Partition_Elaboration.Configure (Set_Conf'Access); PolyORB.Parameters.Register_Source (The_DSA_Source'Access); end Initialize_Parameters; ------------------------ -- Is_Reference_Valid -- ------------------------ function Is_Reference_Valid (R : PolyORB.References.Ref) return Boolean is use PolyORB.References.Binding; use PolyORB.Errors; S : PolyORB.Components.Component_Access; Pro : PolyORB.Binding_Data.Profile_Access; Error : PolyORB.Errors.Error_Container; begin -- Bind the reference to ensure validity Bind (R => R, Local_ORB => PolyORB.Setup.The_ORB, Servant => S, QoS => (others => null), Pro => Pro, Local_Only => False, Error => Error); if Found (Error) then Catch (Error); return False; end if; return True; exception when others => return False; end Is_Reference_Valid; -------------- -- Make_Ref -- -------------- function Make_Ref (The_Entity : PolyORB.Smart_Pointers.Entity_Ptr) return PolyORB.References.Ref is Result : PolyORB.References.Ref; begin Set_Ref (Result, The_Entity); return Result; end Make_Ref; ----------------------- -- Nameserver_Lookup -- ----------------------- function Nameserver_Lookup (Name : String; Kind : String; Initial : Boolean := True) return Ref is use PolyORB.Parameters; use PolyORB.Errors; use PolyORB.References.Binding; LName : constant String := To_Lower (Name); Result : Ref; Retry_Count : Natural := 0; begin pragma Debug (C, O ("Nameserver_Lookup (" & Name & "." & Kind & "): enter")); -- Unit not known yet, we therefore know that it is remote, and we -- need to look it up with the naming service. loop begin Result := PSNNC.Client.Resolve (Naming_Context, To_Name (LName, Kind)); if not Is_Reference_Valid (Result) then PolyORB.References.Release (Result); end if; exception -- Catch all exceptions: we will retry resolution, and bail -- out after Max_Requests iterations. when E : others => pragma Debug (C, O ("retry" & Retry_Count'Img & " got " & Ada.Exceptions.Exception_Information (E))); PolyORB.References.Release (Result); end; exit when not (Initial and then Is_Nil (Result)); -- Resolve succeeded, or just trying to refresh a stale ref: -- exit loop. if Retry_Count = Max_Requests then raise System.RPC.Communication_Error with "lookup of " & Kind & " " & Name & " failed"; end if; Retry_Count := Retry_Count + 1; PolyORB.Tasking.Threads.Relative_Delay (Time_Between_Requests); end loop; pragma Debug (C, O ("Nameserver_Lookup (" & Name & "." & Kind & "): leave")); return Result; end Nameserver_Lookup; ------------------------- -- Nameserver_Register -- ------------------------- procedure Nameserver_Register (Name : String; Kind : String; Obj : PolyORB.References.Ref) is use Ada.Exceptions; Id : constant PolyORB.Services.Naming.Name := To_Name (Name, Kind); Context : PSNNC.Ref; Reg_Obj : PolyORB.References.Ref; begin pragma Debug (C, O ("About to register " & Name & " on nameserver")); -- May raise an exception which we do not want to handle in the -- following block (failure to establish the naming context is a fatal -- error and must be propagated to the caller). Context := Naming_Context; begin Reg_Obj := PSNNC.Client.Resolve (Context, Id); exception when others => -- Resolution attempt returned an authoritative "name not found" -- error: register unit now. PSNNC.Client.Bind (Self => Naming_Context, N => Id, Obj => Obj); return; end; -- Name is present in name server, check validity of the reference it -- resolves to. if Get_Reconnection_Policy (Name) = Reject_On_Restart or else Is_Reference_Valid (Reg_Obj) then -- Reference is valid: RCI unit is already declared by another -- partition. PolyORB.Initialization.Shutdown_World (Wait_For_Completion => False); raise Program_Error with Name & " (" & Kind & ") is already declared"; else -- The reference is not valid anymore: we assume the original server -- has died, and rebind the name. PSNNC.Client.Rebind (Self => Naming_Context, N => To_Name (Name, Kind), Obj => Obj); end if; end Nameserver_Register; -------------------- -- Naming_Context -- -------------------- function Naming_Context return PSNNC.Ref is R : PolyORB.References.Ref; begin if PSNNC.Is_Nil (Naming_Context_Cache) then declare Nameserver_Location : constant String := PolyORB.Parameters.Get_Conf ("dsa", "name_service"); begin PolyORB.References.String_To_Object (Nameserver_Location, R); if Is_Nil (R) then raise Constraint_Error; end if; PSNNC.Set (Naming_Context_Cache, Entity_Of (R)); exception when others => raise System.RPC.Communication_Error with "unable to locate name server " & Nameserver_Location; end; end if; return Naming_Context_Cache; end Naming_Context; ------------------------------------- -- Raise_Program_Error_Unknown_Tag -- ------------------------------------- procedure Raise_Program_Error_Unknown_Tag (E : Ada.Exceptions.Exception_Occurrence) is begin Ada.Exceptions.Raise_Exception (Program_Error'Identity, Ada.Exceptions.Exception_Message (E)); end Raise_Program_Error_Unknown_Tag; ---------- -- Read -- ---------- procedure Read (Stream : in out Buffer_Stream_Type; Item : out Stream_Element_Array; Last : out Stream_Element_Offset) is use PolyORB.Buffers; Transfer_Length : constant Stream_Element_Count := Stream_Element_Count'Min (Remaining (Stream.Buf'Access), Item'Length); Data : PolyORB.Opaque.Opaque_Pointer; begin Extract_Data (Stream.Buf'Access, Data, Transfer_Length); Last := Item'First + Transfer_Length - 1; declare Z_Addr : constant System.Address := Data; Z : Stream_Element_Array (Item'First .. Last); for Z'Address use Z_Addr; pragma Import (Ada, Z); begin Item (Item'First .. Last) := Z; end; end Read; ----------------- -- RCI_Locator -- ----------------- package body RCI_Locator is Info : RCI_Info_Access; -- Cached access to RCI_Info to avoid extra hash table lookups on -- subsequent calls. ------------------------- -- Get_RCI_Package_Ref -- ------------------------- function Get_RCI_Package_Ref return Object_Ref is begin Retrieve_RCI_Info (RCI_Name, Info); -- In case of failure to obtain a valid reference, Retrieve_RCI_Info -- raises Communication_Error, so here we know we have one. pragma Assert (not Is_Nil (Info.Base_Ref)); return Info.Base_Ref; end Get_RCI_Package_Ref; end RCI_Locator; --------------------------------- -- Register_Obj_Receiving_Stub -- --------------------------------- procedure Register_Obj_Receiving_Stub (Name : String; Handler : Request_Handler_Access; Receiver : Servant_Access) is use Receiving_Stub_Lists; Stub : Private_Info renames Receiver.Impl_Info; begin pragma Assert (Name (Name'Last) = ASCII.NUL); Receiver.Handler := Handler; Stub := (Kind => Obj_Stub, Name => +Name (Name'First .. Name'Last - 1), Receiver => Receiver, Version => null, Subp_Info => Null_Address, Subp_Info_Len => 0, Is_All_Calls_Remote => False, others => <>); Prepend (All_Receiving_Stubs, Stub'Access); pragma Debug (C, O ("Setting up RPC receiver: " & Stub.Name.all)); Setup_Object_RPC_Receiver (Stub.Name.all, Stub.Receiver); end Register_Obj_Receiving_Stub; ------------------------- -- Find_Receiving_Stub -- ------------------------- function Find_Receiving_Stub (Name : String; Kind : Receiving_Stub_Kind) return Servant_Access is use Receiving_Stub_Lists; It : Receiving_Stub_Lists.Iterator := First (All_Receiving_Stubs); begin All_Stubs : while not Last (It) loop declare RS : Private_Info renames Value (It).all; begin if RS.Kind = Kind and then To_Lower (RS.Name.all) = To_Lower (Name) then return RS.Receiver; end if; end; Next (It); end loop All_Stubs; return null; end Find_Receiving_Stub; -------------- -- RCI_Attr -- -------------- function RCI_Attr (Name : String; Attr : RCI_Attribute) return String is begin return To_Lower (Name & "'" & Attr'Img); end RCI_Attr; ------------------------------ -- Register_Passive_Package -- ------------------------------ procedure Register_Passive_Package (Name : Unit_Name; Version : String := "") is pragma Unreferenced (Name); pragma Unreferenced (Version); begin null; end Register_Passive_Package; --------------------------------- -- Register_Pkg_Receiving_Stub -- --------------------------------- procedure Register_Pkg_Receiving_Stub (Name : String; Version : String; Handler : Request_Handler_Access; Receiver : Servant_Access; Subp_Info : System.Address; Subp_Info_Len : Integer; Is_All_Calls_Remote : Boolean) is use Receiving_Stub_Lists; Stub : Private_Info renames Receiver.Impl_Info; begin Receiver.Handler := Handler; Receiver.Impl_Info := (Kind => Pkg_Stub, Name => +Name, Receiver => Receiver, Version => +Version, Subp_Info => Subp_Info, Subp_Info_Len => Subp_Info_Len, Is_All_Calls_Remote => Is_All_Calls_Remote, others => <>); Prepend (All_Receiving_Stubs, Stub'Access); declare use PolyORB.Errors; use PolyORB.ORB; use PolyORB.Obj_Adapters; use PolyORB.Setup; use type PolyORB.POA.Obj_Adapter_Access; Error : Error_Container; Key : aliased PolyORB.Objects.Object_Id := To_Local_Oid (System.Null_Address); U_Oid : PolyORB.POA_Types.Unmarshalled_Oid; Oid : PolyORB.POA_Types.Object_Id_Access; Ref : PolyORB.References.Ref; begin pragma Debug (C, O ("Setting up RPC receiver: " & Stub.Name.all)); -- Establish a child POA for this stub. For RACWs, this POA will -- serve all objects of the same type. For RCIs, this POA will serve -- the base object corresponding to the RCI, as well as the -- sub-objects corresponding to each subprogram considered as an -- object (for RAS). Setup_Object_RPC_Receiver (Stub.Name.all, Stub.Receiver); PolyORB.POA.Activate_Object (Self => PolyORB.POA.Obj_Adapter_Access (Servant_Access (Stub.Receiver).Object_Adapter), P_Servant => null, Hint => Key'Unchecked_Access, U_Oid => U_Oid, Error => Error); if Found (Error) then PolyORB.DSA_P.Exceptions.Raise_From_Error (Error); end if; Oid := PolyORB.POA_Types.U_Oid_To_Oid (U_Oid); Create_Reference (The_ORB, Oid, "DSA:" & Stub.Name.all & ":" & Stub.Version.all, Ref); PolyORB.Objects.Free (Oid); pragma Debug (C, O ("Registering local RCI: " & Stub.Name.all)); Known_RCIs.Register (To_Lower (Stub.Name.all), new RCI_Info' (Base_Ref => Ref, Is_Local => True, Reconnection_Policy => Default_Reconnection_Policy, State => Live, Is_All_Calls_Remote => Stub.Is_All_Calls_Remote, Known_Partition_ID => False, RCI_Partition_ID => RPC.Partition_ID'First)); Nameserver_Register (Name => To_Lower (Stub.Name.all), Kind => "RCI", Obj => Ref); end; exception -- An exception occurring during registration of an RCI is fatal to -- the application: terminate PCS and propagate. when E : others => O ("Cannot register information for RCI " & Name & " with name server.", PL.Error); pragma Debug (C, O ("exception raised: " & Ada.Exceptions.Exception_Information (E))); PolyORB.Initialization.Shutdown_World (Wait_For_Completion => False); raise; end Register_Pkg_Receiving_Stub; ---------------------------------- -- Register_Termination_Manager -- ---------------------------------- procedure Register_Termination_Manager (Ref : PolyORB.References.Ref; Oid : PolyORB.Objects.Object_Id_Access; Address : System.Address; Shutdown : PolyORB.Initialization.Finalizer) is begin The_TM_Ref := Ref; The_TM_Oid := Oid; The_TM_Address := Address; The_TM_Shutdown := Shutdown; pragma Debug (C, O ("Registered the termination manager")); end Register_Termination_Manager; ----------------------- -- Request_Arguments -- ----------------------- procedure Request_Arguments (R : PolyORB.Requests.Request_Access; Args : in out PolyORB.Any.NVList.Ref) is Error : PolyORB.Errors.Error_Container; begin PolyORB.Requests.Arguments (R, Args, Error); if PolyORB.Errors.Found (Error) then PolyORB.DSA_P.Exceptions.Raise_From_Error (Error); end if; end Request_Arguments; ------------------------------ -- Request_Raise_Occurrence -- ------------------------------ procedure Request_Raise_Occurrence (R : Request) is use Ada.Exceptions; use PolyORB.DSA_P.Exceptions; use PolyORB.Exceptions; begin if not Is_Empty (R.Exception_Info) then declare E : constant PolyORB.Any.Any := R.Exception_Info; Msg : constant String := PolyORB.QoS.Exception_Informations. Get_Exception_Message (R); begin Raise_From_Any (E, Msg); end; end if; end Request_Raise_Occurrence; ---------------------------------- -- Register_RACW_In_Name_Server -- ---------------------------------- procedure Register_RACW_In_Name_Server (Addr : System.Address; Type_Tag : Ada.Tags.Tag; Name : String; Kind : String) is use type PolyORB.Obj_Adapters.Obj_Adapter_Access; use PolyORB.Errors; use PolyORB.ORB; use PolyORB.Obj_Adapters; use PolyORB.Setup; Key : aliased PolyORB.Objects.Object_Id := To_Local_Oid (Addr); U_Oid : PolyORB.POA_Types.Unmarshalled_Oid; Oid : PolyORB.POA_Types.Object_Id_Access; Error : Error_Container; Ref : PolyORB.References.Ref; Receiver : System.Partition_Interface.Servant_Access; begin pragma Debug (C, O ("Register RACW In Name Server: enter")); Receiver := Find_Receiving_Stub (Ada.Tags.External_Tag (Type_Tag), Obj_Stub); PolyORB.POA.Activate_Object (Self => PolyORB.POA.Obj_Adapter_Access (Receiver.Object_Adapter), P_Servant => null, Hint => Key'Unchecked_Access, U_Oid => U_Oid, Error => Error); if Found (Error) then PolyORB.DSA_P.Exceptions.Raise_From_Error (Error); end if; Oid := PolyORB.POA_Types.U_Oid_To_Oid (U_Oid); PolyORB.ORB.Create_Reference (ORB => The_ORB, Oid => Oid, Typ => "DSA:" & Name, Ref => Ref); PolyORB.Objects.Free (Oid); Nameserver_Register (Name => To_Lower (Name), Kind => Kind, Obj => Ref); pragma Debug (C, O ("Register RACW In Name Server: leave")); end Register_RACW_In_Name_Server; -------------------- -- Release_Buffer -- -------------------- procedure Release_Buffer (Stream : in out Buffer_Stream_Type) is begin PolyORB.Buffers.Release_Contents (Stream.Buf); end Release_Buffer; --------------------- -- Request_Set_Out -- --------------------- procedure Request_Set_Out (R : PolyORB.Requests.Request_Access) is Error : PolyORB.Errors.Error_Container; begin PolyORB.Requests.Set_Out_Args (R, Error); if PolyORB.Errors.Found (Error) then PolyORB.DSA_P.Exceptions.Raise_From_Error (Error); end if; end Request_Set_Out; -------------------- -- Request_Invoke -- -------------------- procedure Request_Invoke (R : access PolyORB.Requests.Request; Invoke_Flags : PolyORB.Requests.Flags := 0) is use PolyORB.QoS; use PolyORB.QoS.Term_Manager_Info; use PolyORB.Request_QoS; use PolyORB.Termination_Activity; begin Increment_Activity; Add_Request_QoS (R.all, DSA_TM_Info, new QoS_DSA_TM_Info_Parameter' (Kind => DSA_TM_Info, TM_Ref => The_TM_Ref)); PolyORB.Requests.Invoke (R, Invoke_Flags, Timeout => RPC_Timeout); end Request_Invoke; ----------------------- -- Retrieve_RCI_Info -- ----------------------- procedure Retrieve_RCI_Info (Name : String; Info : in out RCI_Info_Access) is LName : constant String := To_Lower (Name); Entry_Pending : Boolean := False; begin pragma Debug (C, O ("Retrieve_RCI_Info: enter, Name = " & Name)); PTM.Enter (Critical_Section); if Info = null then Info := Known_RCIs.Lookup (LName, null); if Info = null then -- Here for a new remote RCI Info := new RCI_Info' (Base_Ref => <>, Is_Local => False, Reconnection_Policy => Get_Reconnection_Policy (Name), State => Initial, Is_All_Calls_Remote => True, Known_Partition_ID => False, RCI_Partition_ID => RPC.Partition_ID'First); Known_RCIs.Register (LName, Info); elsif Info.State = Initial then -- Entry is in Initial state, and another task is taking care -- of the lookup. Entry_Pending := True; end if; end if; -- If RCI information is not available locally, we request it from the -- name server. Since some partitions might not be registered yet, we -- retry the query up to Max_Requests times. PTM.Leave (Critical_Section); <> if Info.State /= Dead then -- If state is Initial and Entry_Created is false, this means another -- task is in the process of looking up this RCI from the name -- server: just wait for Base_Ref to become non-null. if (Is_Nil (Info.Base_Ref) and then not Entry_Pending) or else not Is_Reference_Valid (Info.Base_Ref) then Info.Base_Ref := Nameserver_Lookup (LName, "RCI", Initial => Info.State = Initial); Info.State := Live; end if; if Is_Nil (Info.Base_Ref) then if Entry_Pending then PolyORB.Tasking.Threads.Relative_Delay (Time_Between_Requests); goto Lookup; end if; -- Case of a remote RCI for which we have an invalid reference: -- handle reconnection. case Info.Reconnection_Policy is when Reject_On_Restart => Info.State := Dead; when Block_Until_Restart => PTT.Relative_Delay (Time_Between_Requests); goto Lookup; when Fail_Until_Restart => null; end case; end if; end if; -- Check that we have successfully conctacted the remote unit. Note: -- for a local RCI, Info.Base_Ref is always a valid, non-nil reference. if PolyORB.References.Is_Nil (Info.Base_Ref) then raise System.RPC.Communication_Error with "unable to locate RCI " & Name; end if; pragma Debug (C, O ("Retrieve_RCI_Info: leave")); end Retrieve_RCI_Info; ------------------------------------ -- Retrieve_RACW_From_Name_Server -- ------------------------------------ procedure Retrieve_RACW_From_Name_Server (Name : String; Kind : String; Stub_Tag : Ada.Tags.Tag; Addr : out System.Address) is Reg_Obj : PolyORB.References.Ref; begin pragma Debug (C, O ("Retrieve RACW From Name Server: enter")); Reg_Obj := Nameserver_Lookup (Name, Kind); Addr := Get_RACW (Ref => Reg_Obj, Stub_Tag => Stub_Tag, Is_RAS => False, Asynchronous => True); pragma Debug (C, O ("Retrieve RACW From Name Server: leave")); end Retrieve_RACW_From_Name_Server; -------------------- -- Same_Partition -- -------------------- function Same_Partition (Left : access RACW_Stub_Type; Right : access RACW_Stub_Type) return Boolean is begin return Same_Node (Make_Ref (Left.Target), Make_Ref (Right.Target)); end Same_Partition; ------------------------------- -- Setup_Object_RPC_Receiver -- ------------------------------- procedure Setup_Object_RPC_Receiver (Name : String; Default_Servant : Servant_Access) is use PolyORB.Errors; use PolyORB.POA; use PolyORB.POA_Config; use PolyORB.POA_Config.RACWs; use type PolyORB.Obj_Adapters.Obj_Adapter_Access; POA : Obj_Adapter_Access; PName : constant PolyORB.Types.String := PolyORB.Types.String (To_PolyORB_String (Name)); Error : Error_Container; begin -- NOTE: Actually this does more than set up an RPC receiver. A TypeCode -- corresponding to the RACW is also constructed (and this is vital also -- on the client side). Default_Servant.Obj_TypeCode := PATC.TC_Object; PATC.Add_Parameter (Default_Servant.Obj_TypeCode, To_Any (PName)); PATC.Add_Parameter (Default_Servant.Obj_TypeCode, TA_Std_String ("DSA:" & Name & ":1.0")); if RACW_POA_Config = null then return; end if; Create_POA (Self => Obj_Adapter_Access (PolyORB.ORB.Object_Adapter (PolyORB.Setup.The_ORB)), Adapter_Name => Name, A_POAManager => null, Policies => Default_Policies (RACW_POA_Config.all), POA => POA, Error => Error); if Found (Error) then PolyORB.DSA_P.Exceptions.Raise_From_Error (Error); end if; POA.Default_Servant := PolyORB.Servants.Servant_Access (Default_Servant); Default_Servant.Object_Adapter := PolyORB.Obj_Adapters.Obj_Adapter_Access (POA); if RPC_Receivers_Activated then Activate_RPC_Receiver (Default_Servant); else -- If PCS elaboration is not completed yet, activation is deferred -- until Activate_RPC_Receivers is called. pragma Debug (C, O ("Setup_Object_RPC_Receiver: " & Name & " activation deferred")); null; end if; end Setup_Object_RPC_Receiver; -------------- -- Shutdown -- -------------- procedure Shutdown (Wait_For_Completion : Boolean) is use type PolyORB.Initialization.Finalizer; begin -- Shut down the local termination manager, if it has already been -- registered. if The_TM_Shutdown /= null then The_TM_Shutdown (Wait_For_Completion); end if; end Shutdown; -------------- -- TC_Build -- -------------- -- ??? This function should be replaced by a call to Build_Complex_TC function TC_Build (Base : PATC.Local_Ref; Parameters : Any_Array) return PATC.Local_Ref is begin for J in Parameters'Range loop PATC.Add_Parameter (Base, Parameters (J)); end loop; return Base; end TC_Build; --------------- -- TC_Opaque -- --------------- function TC_Opaque return PATC.Local_Ref is begin return TC_Opaque_Cache; end TC_Opaque; ------------ -- To_Any -- ------------ function TA_A (Item : DSAT.Any_Container_Ptr) return PolyORB.Any.Any is pragma Warnings (Off); -- No aliasing issues since DSAT.Any_Container_Ptr always originally -- comes from a PolyORB.Any.Any_Container_Ptr. function To_PolyORB_ACP is new Ada.Unchecked_Conversion (DSAT.Any_Container_Ptr, PolyORB.Any.Any_Container_Ptr); pragma Warnings (On); Item_A : PolyORB.Any.Any; begin PolyORB.Any.Set_Container (Item_A, To_PolyORB_ACP (Item)); return PolyORB.Any.To_Any (Item_A); end TA_A; function TA_B (Item : Boolean) return PolyORB.Any.Any is begin return To_Any (PolyORB.Types.Boolean (Item)); end TA_B; function TA_C (Item : Character) return PolyORB.Any.Any is begin return To_Any (PolyORB.Types.Char (Item)); end TA_C; function TA_F (Item : Float) return PolyORB.Any.Any is begin return To_Any (PolyORB.Types.Float (Item)); end TA_F; function TA_I (Item : Integer) return PolyORB.Any.Any is begin return To_Any (PolyORB.Types.Long (Item)); end TA_I; function TA_U (Item : Unsigned) return PolyORB.Any.Any is begin return To_Any (PolyORB.Types.Unsigned_Long (Item)); end TA_U; function TA_LF (Item : Long_Float) return PolyORB.Any.Any is begin return To_Any (PolyORB.Types.Double (Item)); end TA_LF; function TA_LI (Item : Long_Integer) return PolyORB.Any.Any is begin return To_Any (PolyORB.Types.Long (Item)); end TA_LI; function TA_LU (Item : Long_Unsigned) return PolyORB.Any.Any is begin return To_Any (PolyORB.Types.Unsigned_Long (Item)); end TA_LU; function TA_LLF (Item : Long_Long_Float) return PolyORB.Any.Any is begin return To_Any (PolyORB.Types.Long_Double (Item)); end TA_LLF; function TA_LLI (Item : Long_Long_Integer) return PolyORB.Any.Any is begin return To_Any (PolyORB.Types.Long_Long (Item)); end TA_LLI; function TA_LLU (Item : Long_Long_Unsigned) return PolyORB.Any.Any is begin return To_Any (PolyORB.Types.Unsigned_Long_Long (Item)); end TA_LLU; function TA_SF (Item : Short_Float) return PolyORB.Any.Any is begin return To_Any (PolyORB.Types.Float (Item)); end TA_SF; function TA_SI (Item : Short_Integer) return PolyORB.Any.Any is begin return To_Any (PolyORB.Types.Short (Item)); end TA_SI; function TA_SU (Item : Short_Unsigned) return PolyORB.Any.Any is begin return To_Any (PolyORB.Types.Unsigned_Short (Item)); end TA_SU; function TA_SSI (Item : Short_Short_Integer) return PolyORB.Any.Any is function To_Octet is new Ada.Unchecked_Conversion (Short_Short_Integer, PolyORB.Types.Octet); begin return To_Any (To_Octet (Item)); end TA_SSI; function TA_SSU (Item : Short_Short_Unsigned) return PolyORB.Any.Any is function To_Octet is new Ada.Unchecked_Conversion (Short_Short_Unsigned, PolyORB.Types.Octet); begin return To_Any (To_Octet (Item)); end TA_SSU; function TA_WC (Item : Wide_Character) return PolyORB.Any.Any is begin return To_Any (PolyORB.Types.Wchar (Item)); end TA_WC; function TA_String (S : Ada.Strings.Unbounded.Unbounded_String) return PolyORB.Any.Any is begin return PolyORB.Any.To_Any (PolyORB.Types.String (S)); end TA_String; function TA_Std_String (S : String) return PolyORB.Any.Any is begin return PolyORB.Any.To_Any (PolyORB.Types.To_PolyORB_String (S)); end TA_Std_String; ------------- -- To_Name -- ------------- function To_Name (Id, Kind : String) return PolyORB.Services.Naming.Name is use PolyORB.Services.Naming.SEQUENCE_NameComponent; begin return PolyORB.Services.Naming.Name (To_Sequence ((1 => (id => PolyORB.Services.Naming.To_PolyORB_String (Id), kind => PolyORB.Services.Naming.To_PolyORB_String (Kind))))); end To_Name; ----------- -- Write -- ----------- procedure Write (Stream : in out Buffer_Stream_Type; Item : Stream_Element_Array) is use PolyORB.Buffers; Data : PolyORB.Opaque.Opaque_Pointer; begin Allocate_And_Insert_Cooked_Data (Stream.Buf'Access, Item'Length, Data); declare Z_Addr : constant System.Address := Data; Z : Stream_Element_Array (Item'Range); for Z'Address use Z_Addr; pragma Import (Ada, Z); begin Z := Item; end; end Write; use PolyORB.Initialization; use PolyORB.Utils.Strings.Lists; begin Register_Module (Module_Info' (Name => +"parameters.dsa", Conflicts => Empty, Depends => Empty, Provides => +"parameters_sources", Implicit => True, Init => Initialize_Parameters'Access, Shutdown => null)); Register_Module (Module_Info' (Name => +"dsa", Conflicts => Empty, Depends => +"orb" & "parameters" & "poa" & "poa_config.racws" & "object_adapter" & "naming.Helper" & "naming.NamingContext.Helper" & "dsa.name_server?" & "tasking.condition_variables" & "tasking.mutexes" & "access_points?" & "binding_factories" & "references" & "request_qos.dsa_tm_info" & "termination.activity", Provides => Empty, Implicit => False, Init => Initialize'Access, Shutdown => Shutdown'Access)); -- We initialize PolyORB, so that once s-parint is elaborated, the PCS is -- up and running, ready to process RPCs. Initialize_World; -- Run additional tasks if needed PolyORB.Partition_Elaboration.Run_Additional_Tasks; -- Elaboration of the PCS is finished, launch others partitions if needed PolyORB.Partition_Elaboration.Full_Launch; -- Detach partition if needed if PolyORB.Parameters.Get_Conf (Section => "dsa", Key => "detach", Default => False) then Detach; end if; end System.Partition_Interface; polyorb-2.8~20110207.orig/src/dsa/polyorb-dsa_p-name_service-mdns-servant.ads0000644000175000017500000001233411750740340026263 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- POLYORB.DSA_P.NAME_SERVICE.MDNS.SERVANT -- -- -- -- S p e c -- -- -- -- Copyright (C) 2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- This package implements the actual mDNS servant. It stores a local list -- of entries representing the respective RCI/SP packages and upon reception -- of a request, looks up the requested package's informations and send them -- back to the client partition. with PolyORB.Minimal_Servant; with PolyORB.Requests; with PolyORB.DSA_P.Name_Service.mDNS.Helper; with PolyORB.Dynamic_Dict; package PolyORB.DSA_P.Name_Service.mDNS.Servant is use PolyORB.DSA_P.Name_Service.mDNS.Helper; type Object is new PolyORB.Minimal_Servant.Servant with null record; type Object_Ptr is access all Object'Class; -- The actual servant object type Local_Entry is record Name : PolyORB.Types.String; -- Name of the package Kind : PolyORB.Types.String; -- Kind of the package Version : PolyORB.Types.String; -- Version of the package Base_Ref : PolyORB.References.Ref; -- Actual reference to the package end record; type Local_Entry_Ptr is access all Local_Entry; -- A local entry contains all the data relevant to packages that we need package Local_Entry_List is new PolyORB.Dynamic_Dict (Local_Entry_Ptr); -- The list of all entries. key=Unit Name, value - pointer to Local_Entry procedure Query (Self : access Object; Authoritative : in out Boolean; Question : rrSequence; Answer : out rrSequence; Authority : out rrSequence; Additional : out rrSequence; Response : out Rcode); -- This procedure is called by Invoke upon reception of distant query -- Depending on the incoming request, it generates the corresponding -- Resource Records by lookup up the local list of Local_Entry objects. procedure Invoke (Self : access Object; Request : PolyORB.Requests.Request_Access); -- Overriding the abstract servant's Invoke procedure. Used to create -- an empty argument's list, populate it from Request.Args, invoke Query -- and assign back the out arguments. procedure Append_Entry_To_Context (Name : PolyORB.Types.String; Kind : PolyORB.Types.String; Version : PolyORB.Types.String; Base_Ref : PolyORB.References.Ref); -- Creates a new Local_Entry from the in data provided and appends it -- to the Local_Entry_List private procedure Find_Answer_RR (Question : RR; Answer_Seq : out rrSequence; Authority_Seq : out rrSequence; Additional_Seq : out rrSequence; Response : out Rcode); -- The local procedure responsible for looking up for the record and -- constructing the answer sequences conforming to the RCI/SP<->RR mapping procedure Parse_Question_Name (Question : PolyORB.Types.String; Name : out PolyORB.Types.String; Kind : out PolyORB.Types.String); -- Extract the Name and Kind of the requested package from the incoming -- Question name end PolyORB.DSA_P.Name_Service.mDNS.Servant; polyorb-2.8~20110207.orig/src/dsa/polyorb-dsa_p.ads0000644000175000017500000000417511750740340021212 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . D S A _ P -- -- -- -- S p e c -- -- -- -- Copyright (C) 2002-2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- Root package for the Ada DSA applicative personality package PolyORB.DSA_P is pragma Pure; end PolyORB.DSA_P; polyorb-2.8~20110207.orig/src/dsa/polyorb-qos-term_manager_info.adb0000644000175000017500000001633711750740340024362 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . Q O S . T E R M _ M A N A G E R _ I N F O -- -- -- -- B o d y -- -- -- -- Copyright (C) 2006-2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with PolyORB.Binding_Objects; with PolyORB.Buffers; with PolyORB.Initialization; with PolyORB.Log; with PolyORB.QoS.Service_Contexts; with PolyORB.QoS; with PolyORB.References.IOR; with PolyORB.Representations.CDR.Common; with PolyORB.Request_QoS; with PolyORB.Smart_Pointers; with PolyORB.Utils.Strings; package body PolyORB.QoS.Term_Manager_Info is use PolyORB.Buffers; use PolyORB.Log; use PolyORB.QoS.Service_Contexts; use PolyORB.References.IOR; use PolyORB.References; use PolyORB.Representations.CDR.Common; use PolyORB.Requests; use PolyORB.Tasking.Mutexes; ------------- -- Logging -- ------------- package L is new Log.Facility_Log ("polyorb.qos.term_manager_info"); procedure O (Message : Standard.String; Level : Log_Level := Debug) renames L.Output; function C (Level : Log_Level := Debug) return Boolean renames L.Enabled; --------------- -- Callbacks -- --------------- function To_TMInfo_Service_Context (QoS : QoS_Parameter_Access) return Service_Context; -- Callback to convert a QoS parameter to a TMInfo service context function To_QoS_DSA_TM_Info_Parameter (SC : Service_Context) return QoS_Parameter_Access; -- Callback to convert a TMInfo service context to a QoS parameter --------------------- -- Extract_TM_Info -- --------------------- procedure Extract_TM_Info (R : access Request) is use PolyORB.Annotations; use PolyORB.Binding_Objects; use PolyORB.QoS.Term_Manager_Info; use PolyORB.QoS; use PolyORB.Request_QoS; Note : BO_Note; BO : constant Binding_Object_Access := Binding_Object_Access ( Smart_Pointers.Entity_Of (R.Dependent_Binding_Object)); QoS_Acc : QoS_Parameter_Access; begin -- If the Dependant BO of the request is null, this is a request done on -- the client side and therefore do not interest us here. if BO /= null then Enter_BO_Note_Lock; Get_Note (Notepad_Of (BO).all, Note, Default_BO_Note); Leave_BO_Note_Lock; -- If reference is already set, no need to extract info again if Is_Nil (Note.TM_Ref) then pragma Debug (C, O ("Extracting TM info from request")); -- Extract the QoS parameter from the request QoS_Acc := Extract_Request_Parameter (DSA_TM_Info, R.all); -- Store the reference in the requestor BO's notepad Note.TM_Ref := QoS_DSA_TM_Info_Parameter_Access (QoS_Acc).TM_Ref; Set_Note (Notepad_Of (BO).all, Note); end if; end if; end Extract_TM_Info; ------------------------------- -- To_TMInfo_Service_Context -- ------------------------------- function To_TMInfo_Service_Context (QoS : QoS_Parameter_Access) return Service_Context is Result : Service_Context := (TMInfo, null); begin if QoS = null then return Result; end if; declare TMInfo : QoS_DSA_TM_Info_Parameter renames QoS_DSA_TM_Info_Parameter (QoS.all); Buffer : Buffer_Access := new Buffer_Type; begin Start_Encapsulation (Buffer); pragma Debug (C, O ("Encapsulate :" & Image (TMInfo.TM_Ref))); Marshall_IOR (Buffer, TMInfo.TM_Ref); Result.Context_Data := new Encapsulation'(Encapsulate (Buffer)); Release (Buffer); end; return Result; end To_TMInfo_Service_Context; ---------------------------------- -- To_QoS_DSA_TM_Info_Parameter -- ---------------------------------- function To_QoS_DSA_TM_Info_Parameter (SC : Service_Context) return QoS_Parameter_Access is Buffer : aliased Buffer_Type; TM_Ref : References.Ref; begin Decapsulate (SC.Context_Data, Buffer'Access); TM_Ref := Unmarshall_IOR (Buffer'Access); pragma Debug (C, O ("Decapsulate:" & Image (TM_Ref))); return new QoS_DSA_TM_Info_Parameter'(Kind => DSA_TM_Info, TM_Ref => TM_Ref); end To_QoS_DSA_TM_Info_Parameter; ------------------------ -- Enter_BO_Note_Lock -- ------------------------ procedure Enter_BO_Note_Lock is begin Enter (Lock); end Enter_BO_Note_Lock; ------------------------ -- Leave_BO_Note_Lock -- ------------------------ procedure Leave_BO_Note_Lock is begin Leave (Lock); end Leave_BO_Note_Lock; ---------------- -- Initialize -- ---------------- procedure Initialize is begin Create (Lock); -- Register the TMInfo service context callbacks Register (DSA_TM_Info, To_TMInfo_Service_Context'Access); Register (TMInfo, To_QoS_DSA_TM_Info_Parameter'Access); end Initialize; begin declare use PolyORB.Initialization; use PolyORB.Initialization.String_Lists; use PolyORB.Utils.Strings; begin Register_Module (Module_Info' (Name => +"request_qos.dsa_tm_info", Conflicts => Empty, Depends => Empty, Provides => Empty, Implicit => False, Init => Initialize'Access, Shutdown => null)); end; end PolyORB.QoS.Term_Manager_Info; polyorb-2.8~20110207.orig/src/dsa/polyorb-termination_manager-bootstrap.adb0000644000175000017500000003065011750740340026136 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- POLYORB.TERMINATION_MANAGER.BOOTSTRAP -- -- -- -- B o d y -- -- -- -- Copyright (C) 2006-2011, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with Ada.Unchecked_Conversion; with PolyORB.Annotations; with PolyORB.Binding_Data.Neighbour; with PolyORB.Binding_Data; with PolyORB.DSA_P.Exceptions; with PolyORB.Errors; with PolyORB.Log; with PolyORB.ORB; with PolyORB.Parameters; with PolyORB.POA; with PolyORB.POA_Config; with PolyORB.POA_Config.RACWs; with PolyORB.POA_Manager; with PolyORB.QoS.Term_Manager_Info; with PolyORB.Setup; with PolyORB.Smart_Pointers; with System.Partition_Interface; package body PolyORB.Termination_Manager.Bootstrap is use PolyORB.Binding_Data; use PolyORB.Binding_Objects; use PolyORB.Log; use PolyORB.ORB; use PolyORB.Servants; use PolyORB.Setup; use System.Partition_Interface; ------------- -- Logging -- ------------- package L is new Log.Facility_Log ("polyorb.termination_manager.bootstrap"); procedure O (Message : Standard.String; Level : Log_Level := Debug) renames L.Output; function C (Level : Log_Level := Debug) return Boolean renames L.Enabled; ------------------------- -- Stub Types managing -- ------------------------- type Term_Manager_Stub_Access is access all Term_Manager_Access'Stub_Type; -- We have to consider three views of the same type: -- * Term_Manager_Stub_Access: the type returned by RACW'Stub_Type -- * RACW_Stub_Type_Access: a general stub type used by S-PolInt -- * Term_Manager_Access : the type we use in the termination manager -- We define some Unchecked_Conversions between them: pragma Warnings (Off); -- To disable "possible aliasing problem" warnings which do not apply in -- this case. function To_RACW_Stub_Access is new Ada.Unchecked_Conversion (Source => Term_Manager_Stub_Access, Target => RACW_Stub_Type_Access); function To_TM_Access is new Ada.Unchecked_Conversion (Source => System.Address, Target => Term_Manager_Access); pragma Warnings (On); function Term_Manager_To_Address is new Ada.Unchecked_Conversion (Term_Manager_Access, System.Address); ---------------------------------- -- Extract_TM_Reference_From_BO -- ---------------------------------- procedure Extract_TM_Reference_From_BO (BO : Binding_Object_Access; Ref : out References.Ref; NK : out Node_Kind) is use Annotations; use Binding_Data.Neighbour; use Errors; use QoS.Term_Manager_Info; use References; BO_Ref : Smart_Pointers.Ref; P : Neighbour_Profile_Type; Note : BO_Note; begin pragma Assert (BO /= null); if Get_Profile (BO) = null then pragma Debug (C, O ("Extracting TM ref from Server BO")); -- BO is a server side BO Enter_BO_Note_Lock; begin Get_Note (Notepad_Of (BO).all, Note); exception when Constraint_Error => Leave_BO_Note_Lock; NK := Non_DSA_Node; pragma Debug (C, O ("-> " & NK'Img)); return; end; Leave_BO_Note_Lock; if References.Is_Nil (Note.TM_Ref) then NK := DSA_Node_Without_TM; pragma Debug (C, O ("-> " & NK'Img)); return; end if; NK := DSA_Node; Ref := Note.TM_Ref; else pragma Debug (C, O ("Extracting TM ref from Client BO")); -- BO is a client side BO Smart_Pointers.Set (BO_Ref, Entity_Ptr (BO)); -- We create a new Neighbour profile, which always bind to the given -- Binding Object Create_Neighbour_Profile (BO => BO_Ref, Oid => The_TM_Oid.all, P => P); -- Then we construct a reference using the Neighbour Profile declare P_Array : constant Profile_Array := (1 => Duplicate_Profile (P)); begin Create_Reference (Profiles => P_Array, Type_Id => RACW_Type_Name, R => Ref); end; NK := Unknown; -- In the client BO case, we cannot determine the kind of the target -- node. end if; pragma Debug (C, O ("-> " & NK'Img & " TM: " & Image (Ref))); end Extract_TM_Reference_From_BO; --------------- -- Shutdown -- --------------- procedure Shutdown (Wait_For_Completion : Boolean); procedure Shutdown (Wait_For_Completion : Boolean) is pragma Unreferenced (Wait_For_Completion); begin The_TM.Terminated := True; end Shutdown; ------------------------------------ -- Initialize_Termination_Manager -- ------------------------------------ procedure Initialize_Termination_Manager is use PolyORB.Errors; use PolyORB.Objects; use PolyORB.Parameters; TM : constant Term_Manager_Ptr := new Term_Manager; S : System.Partition_Interface.Servant_Access; -- Retrieve the termination configuration parameters Is_Initiator : constant Boolean := Parameters.Get_Conf (Section => "dsa", Key => "termination_initiator", Default => False); Term_Policy : constant String := Parameters.Get_Conf (Section => "dsa", Key => "termination_policy", Default => "global_termination"); Time_Between_Waves : constant Duration := Parameters.Get_Conf (Section => "dsa", Key => "tm_time_between_waves", Default => 1.0); Time_Before_Start : constant Duration := Parameters.Get_Conf (Section => "dsa", Key => "tm_time_before_start", Default => 5.0); function Term_Policy_Value (S : String) return Termination_Type; function Term_Policy_Value (S : String) return Termination_Type is begin return Termination_Type'Value (S); exception when others => return Global_Termination; end Term_Policy_Value; begin pragma Debug (C, O ("Initialize_Termination_Manager: enter")); if not Get_Conf ("dsa", "tasking_available") then if Term_Policy_Value (Term_Policy) = Local_Termination then -- If our profile is a no_tasking node with local_termination -- then there is nothing more to do! pragma Debug (C, O ("No-tasking, Local_Termination node")); return; else -- Except local_termination, all the others termination policies -- require tasking. O ("Only Local_Termination policy can be used in a " & "No_Tasking partition", Log.Error); raise Program_Error; end if; end if; -- Register a new Termination Manager for this partition The_TM := TM; The_TM_Ref := Term_Manager_Access_To_Ref (Term_Manager_Access (TM)); The_TM_Oid := new Object_Id'(String_To_Oid (TM_Name_Space)); -- We need the servant of TM so we can initiate a well known service -- pointing to it. We bind the reference and get the servant of TM. -- Note, we can't bind The_TM_Ref to obtain the servant because the -- corresponding POA has not been activated yet, and so we would get -- the Hold_Servant instead. S := Find_Receiving_Stub (RACW_Type_Name, Obj_Stub); pragma Assert (S /= null); -- Start the Well Known Service pragma Debug (C, O ("Initiating Well Known Service")); Initiate_Well_Known_Service (S => Servants.Servant_Access (S), Name => TM_Name_Space); -- Start the termination manager Start (Term_Manager_Access (TM), Term_Policy_Value (Term_Policy), Is_Initiator, Time_Between_Waves, Time_Before_Start); Register_Termination_Manager (The_TM_Ref, The_TM_Oid, Term_Manager_To_Address (Term_Manager_Access (TM)), Shutdown'Access); pragma Debug (C, O ("Initialize_Termination_Manager: leave")); end Initialize_Termination_Manager; --------------------------------- -- Initiate_Well_Known_Service -- --------------------------------- procedure Initiate_Well_Known_Service (S : Servants.Servant_Access; Name : String) is use PolyORB.Errors; use PolyORB.POA; use PolyORB.POA_Config; use PolyORB.POA_Manager; use PolyORB.POA_Config.RACWs; POA : Obj_Adapter_Access; Error : Error_Container; begin Create_POA (Self => Obj_Adapter_Access (Object_Adapter (The_ORB)), Adapter_Name => Name, A_POAManager => null, Policies => Default_Policies (RACW_POA_Config.all), POA => POA, Error => Error); if Found (Error) then PolyORB.DSA_P.Exceptions.Raise_From_Error (Error); end if; POA.Default_Servant := S; Activate (POAManager_Access (Entity_Of (POA.POA_Manager)), Error); if Found (Error) then PolyORB.DSA_P.Exceptions.Raise_From_Error (Error); end if; end Initiate_Well_Known_Service; -------------------------------- -- Ref_To_Term_Manager_Access -- -------------------------------- function Ref_To_Term_Manager_Access (R : References.Ref) return Term_Manager_Access is begin return To_TM_Access (System.Partition_Interface.Get_RACW (Ref => R, Stub_Tag => Term_Manager_Access'Stub_Type'Tag, Is_RAS => False, Asynchronous => False)); end Ref_To_Term_Manager_Access; -------------------------------- -- Term_Manager_Access_To_Ref -- -------------------------------- function Term_Manager_Access_To_Ref (TM : Term_Manager_Access) return References.Ref is Receiver : System.Partition_Interface.Servant_Access; Result : References.Ref; begin -- We retrieve the receiver stub of Term_Manager RACW for this partition Receiver := Find_Receiving_Stub (RACW_Type_Name, Obj_Stub); pragma Assert (Receiver /= null); -- Then use it to get a reference to TM Build_Local_Reference (Addr => Term_Manager_To_Address (TM), Typ => RACW_Type_Name, Receiver => Receiver, Ref => Result); return Result; end Term_Manager_Access_To_Ref; end PolyORB.Termination_Manager.Bootstrap; polyorb-2.8~20110207.orig/src/dsa/s-shasto.adb0000644000175000017500000001043411750740340020153 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- S Y S T E M . S H A R E D _ S T O R A G E -- -- -- -- B o d y -- -- -- -- Copyright (C) 2006-2009, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with Ada.Streams.Stream_IO; with System.DSA_Types; with PolyORB.Any; with PolyORB.DSA_P.Conversions; with PolyORB.DSA_P.Storages; with PolyORB.DSA_P.Streams; package body System.Shared_Storage is use PolyORB.Any; use PolyORB.DSA_P.Conversions; use PolyORB.DSA_P.Storages; use PolyORB.DSA_P.Streams; package SDT renames System.DSA_Types; --------------------- -- Shared_Var_Lock -- --------------------- procedure Shared_Var_Lock (Var : String) is SDM : Shared_Data_Manager_RACW; begin Lookup_Variable (Var, SDM); Lock (SDM); end Shared_Var_Lock; ----------------------- -- Shared_Var_Unlock -- ----------------------- procedure Shared_Var_Unlock (Var : String) is SDM : Shared_Data_Manager_RACW; begin Lookup_Variable (Var, SDM); Unlock (SDM); end Shared_Var_Unlock; ---------------------- -- Shared_Var_Procs -- ---------------------- package body Shared_Var_Procs is package SIO renames Ada.Streams.Stream_IO; -- XXX for instance, we use stream attributes to -- assign variable V of limited type Typ. S : constant SIO.Stream_Access := new Memory_Resident_Stream (16384); -- XXX stream used to copy value of variable V -- of limited type Typ in Read routine. ---------- -- Read -- ---------- procedure Read is SDM : Shared_Data_Manager_RACW; Data : constant Any := Typ'To_Any (V); Data_Ptr : constant SDT.Any_Container_Ptr := AC_To_DAC (Get_Container (Data)); begin Lookup_Variable (Full_Name, SDM); Read (SDM, Data_Ptr); if not Is_Empty (Data) then -- V := Typ'From_Any (A) Typ'Write (S, Typ'From_Any (Data)); Typ'Read (S, V); end if; end Read; ----------- -- Write -- ----------- procedure Write is SDM : Shared_Data_Manager_RACW; Data : constant Any := Typ'To_Any (V); Data_Ptr : constant SDT.Any_Container_Ptr := AC_To_DAC (Get_Container (Data)); begin Lookup_Variable (Full_Name, SDM); Write (SDM, Data_Ptr); end Write; end Shared_Var_Procs; end System.Shared_Storage; polyorb-2.8~20110207.orig/src/dsa/s-dsaser.adb0000644000175000017500000000747411750740340020145 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- S Y S T E M . D S A _ S E R V I C E S -- -- -- -- B o d y -- -- -- -- Copyright (C) 2006-2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with Ada.Exceptions; with PolyORB.DSA_P.Partitions; pragma Elaborate_All (PolyORB.DSA_P.Partitions); with PolyORB.Initialization; with PolyORB.Log; with PolyORB.DSA_P.Storages.Config; pragma Elaborate_All (PolyORB.DSA_P.Storages.Config); with PolyORB.Termination_Manager.Bootstrap; pragma Elaborate_All (PolyORB.Termination_Manager.Bootstrap); package body System.DSA_Services is use PolyORB.Log; package L is new PolyORB.Log.Facility_Log ("system.dsa_services"); procedure O (Message : String; Level : Log_Level := Debug) renames L.Output; function C (Level : Log_Level := Debug) return Boolean renames L.Enabled; use PolyORB.DSA_P.Partitions; use System.Partition_Interface; begin -- Check that the PCS is initialized pragma Assert (PolyORB.Initialization.Is_Initialized); -- Initialize the termination manager PolyORB.Termination_Manager.Bootstrap.Initialize_Termination_Manager; -- Initialize shared storage supports PolyORB.DSA_P.Storages.Config.Initialize_Storages; -- Allocate to this partition a local partition ID, unless one has -- already been allocated (case of the PID server partition). if not Local_PID_Allocated then Set_Local_Partition_ID (RPC.Partition_ID (Allocate_Partition_ID (Get_Local_Partition_Name))); end if; -- DSA services are now fully initialized, and incoming remote subprogram -- calls can be processed: activate all pending RPC receivers. System.Partition_Interface.Activate_RPC_Receivers; pragma Debug (C, O ("DSA_Services Initialized")); exception when E : others => O ("exception raised during DSA services initialization: " & Ada.Exceptions.Exception_Information (E)); PolyORB.Initialization.Shutdown_World (Wait_For_Completion => False); raise; end System.DSA_Services; polyorb-2.8~20110207.orig/src/dsa/polyorb-dsa_p-storages.ads0000644000175000017500000001126211750740340023032 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . D S A _ P . S T O R A G E S -- -- -- -- S p e c -- -- -- -- Copyright (C) 2008-2009, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ pragma Ada_2005; pragma Warnings (Off); -- System.DSA_Types is an internal GNAT unit with System.DSA_Types; pragma Warnings (On); package PolyORB.DSA_P.Storages is pragma Remote_Types; package SDT renames System.DSA_Types; ------------------------- -- Shared_Data_Manager -- ------------------------- type Shared_Data_Manager_Type is abstract tagged limited private; type Shared_Data_Manager_RACW is access all Shared_Data_Manager_Type'Class; pragma Asynchronous (Shared_Data_Manager_RACW); -- Primitives of Shared_Data_Manager_Type procedure Read (Self : access Shared_Data_Manager_Type; Var : SDT.Any_Container_Ptr) is abstract; -- Shared passive variable access routine. Each reference to the -- shared variable, V, is preceded by a call to the corresponding -- Read procedure, which either leaves the initial value unchanged -- if the storage does not exist, or reads the current value from -- the shared storage. procedure Write (Self : access Shared_Data_Manager_Type; Var : SDT.Any_Container_Ptr) is abstract; -- Shared passive variable assignement routine. Each assignment to -- the shared variable, V, is followed by a call to the corresponding -- Write procedure, which writes the new value to the shared storage. procedure Lock (Self : access Shared_Data_Manager_Type) is abstract; -- Used for shared protected ojects, it ensures that others partitions -- can't obtain any access to the shared variable while Unlock procedure -- haven't been called by local partition. procedure Unlock (Self : access Shared_Data_Manager_Type) is abstract; -- Used for shared protected ojects, it finalizes the use of the shared -- variable by the local partiton. function Create (Manager_Factory : access Shared_Data_Manager_Type; Full_Name : String) return Shared_Data_Manager_RACW is abstract; -- Create a new manager type according to given factory type. -- General services procedure Lookup_Variable (Var_Name : String; Var_Data : out Shared_Data_Manager_RACW); -- Find a shared data manager Var_Data in hash table, identified by its -- storage name Var_Name. procedure Lookup_Package (Pkg_Name : String; Pkg_Data : out Shared_Data_Manager_RACW); -- Find a package factory in hash table, identified by its name Pkg_Name. procedure Register_Factory (Factory_Name : String; Factory_Data : Shared_Data_Manager_RACW); -- Register a factory corresponding to chosen storage location. private type Shared_Data_Manager_Type is abstract tagged limited null record; end PolyORB.DSA_P.Storages; polyorb-2.8~20110207.orig/src/dsa/polyorb-dsa_p-exceptions.adb0000644000175000017500000000741611750740340023351 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . D S A _ P . E X C E P T I O N S -- -- -- -- B o d y -- -- -- -- Copyright (C) 2003-2007, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with Ada.Exceptions; with PolyORB.Exceptions; with PolyORB.Types; with System.RPC; package body PolyORB.DSA_P.Exceptions is use Ada.Exceptions; use PolyORB.Errors; use PolyORB.Exceptions; use PolyORB.Types; DSA_Exception_Prefix : constant String := "DSA:"; ----------------------------- -- Exception_Repository_Id -- ----------------------------- function Exception_Repository_Id (Name, Version : String) return String is begin return DSA_Exception_Prefix & Name & ":" & Version; end Exception_Repository_Id; -------------------- -- Raise_From_Any -- -------------------- procedure Raise_From_Any (Occurrence : Any.Any; Msg : String := "") is Exc_Repo_Id : constant Standard.String := To_Standard_String (Any.TypeCode.Id (PolyORB.Any.Get_Type (Occurrence))); Is_Error : Boolean; Err_Id : Error_Id; begin pragma Assert (not Any.Is_Empty (Occurrence)); -- PolyORB errors raise DSA specific exception Exception_Name_To_Error_Id (Exc_Repo_Id, Is_Error, Err_Id); if Is_Error then raise System.RPC.Communication_Error; end if; -- Here in the default case (user-generated exception) Ada.Exceptions.Raise_Exception (Get_ExcepId_By_Name (Exception_Name (Exc_Repo_Id)), Msg); raise Program_Error; end Raise_From_Any; ---------------------- -- Raise_From_Error -- ---------------------- procedure Raise_From_Error (Error : in out PolyORB.Errors.Error_Container) is begin pragma Assert (Is_Error (Error)); Free (Error.Member); raise System.RPC.Communication_Error; end Raise_From_Error; end PolyORB.DSA_P.Exceptions; polyorb-2.8~20110207.orig/src/dsa/s-dsaser.ads0000644000175000017500000000532411750740340020156 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- S Y S T E M . D S A _ S E R V I C E S -- -- -- -- S p e c -- -- -- -- Copyright (C) 2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- This package is for distributed system annex services, which require the -- partition communication sub-system to be initialized before they are used. with System.Partition_Interface; with System.RPC; package System.DSA_Services is pragma Elaborate_Body; function Get_Active_Partition_ID (Name : Partition_Interface.Unit_Name) return RPC.Partition_ID renames System.Partition_Interface.Get_Active_Partition_ID; -- Returns the partition ID of the partition in which unit Name resides function Get_Local_Partition_ID return RPC.Partition_ID renames System.Partition_Interface.Get_Local_Partition_ID; -- Return the Partition_ID of the current partition end System.DSA_Services; polyorb-2.8~20110207.orig/src/dsa/s-shasto.ads0000644000175000017500000002142211750740340020173 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- S Y S T E M . S H A R E D _ S T O R A G E -- -- -- -- B o d y -- -- -- -- Copyright (C) 2006-2008, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- This package manages the shared/persistant storage required for -- full implementation of variables in Shared_Passive packages, more -- precisely variables whose enclosing dynamic scope is a shared -- passive package. This implementation is specific to GNAT and GLADE -- provides a more general implementation not dedicated to file -- storage. -- This unit (and shared passive partitions) are supported on all -- GNAT implementations except on OpenVMS (where problems arise from -- trying to share files, and with version numbers of files) -- -------------------------- -- -- Shared Storage Model -- -- -------------------------- -- The basic model used is that each partition that references the -- Shared_Passive package has a local copy of the package data that -- is initialized in accordance with the declarations of the package -- in the normal manner. The routines in System.Shared_Storage are -- then used to ensure that the values in these separate copies are -- properly synchronized with the state of the overall system. -- In the GNAT implementation, this synchronization is ensured by -- maintaining a set of files, in a designated directory. The -- directory is designated by setting the environment variable -- SHARED_MEMORY_DIRECTORY. This variable must be set for all -- partitions. If the environment variable is not defined, then the -- current directory is used. -- There is one storage for each variable. The name is the fully -- qualified name of the variable with all letters forced to lower -- case. For example, the variable Var in the shared passive package -- Pkg results in the storage name pkg.var. -- If the storage does not exist, it indicates that no partition has -- assigned a new value, so that the initial value is the correct -- one. This is the critical component of the model. It means that -- there is no system-wide synchronization required for initializing -- the package, since the shared storages need not (and do not) -- reflect the initial state. There is therefore no issue of -- synchronizing initialization and read/write access. -- ----------------------- -- -- Read/Write Access -- -- ----------------------- -- The approach is as follows: -- For each shared variable, var, an instanciation of the below generic -- package is created which provides Read and Write supporting procedures. -- The routine Read in package System.Shared_Storage.Shared_Var_Procs -- ensure to assign variable V to the last written value among processes -- referencing it. A call to this procedure is generated by the expander -- before each read access to the shared variable. -- The routine Write in package System.Shared_Storage.Shared_Var_Proc -- set a new value to the shared variable and, according to the used -- implementation, propagate this value among processes referencing it. -- A call to this procedure is generated by the expander after each -- assignement of the shared varible. -- Note: a special circuit allows the use of stream attributes Read and -- Write for limited types (using the corresponding attribute for the -- full type), but there are limitations on the data that can be placed -- in shared passive partitions. See sem_smem.ads/adb for details. -- ---------------------------------------------------------------- -- -- Handling of Protected Objects in Shared Passive Partitions -- -- ---------------------------------------------------------------- -- In the context of GNAT, during the execution of a protected -- subprogram call, access is locked out using a locking mechanism -- per protected object, as provided by the GNAT.Lock_Files -- capability in the specific case of GNAT. This package contains the -- lock and unlock calls, and the expander generates a call to the -- lock routine before the protected call and a call to the unlock -- routine after the protected call. -- Within the code of the protected subprogram, the access to the -- protected object itself uses the local copy, without any special -- synchronization. Since global access is locked out, no other task -- or partition can attempt to read or write this data as long as the -- lock is held. -- The data in the local copy does however need synchronizing with -- the global values in the shared storage. This is achieved as -- follows: -- The protected object generates a read and assignment routine as -- described for other shared passive variables. The code for the -- 'Read and 'Write attributes (not normally allowed, but allowed -- in this special case) simply reads or writes the values of the -- components in the protected record. -- The lock call is followed by a call to the shared read routine to -- synchronize the local copy to contain the proper global value. -- The unlock call in the procedure case only is preceded by a call -- to the shared assign routine to synchronize the global shared -- storages with the (possibly modified) local copy. -- These calls to the read and assign routines, as well as the lock -- and unlock routines, are inserted by the expander (see exp_smem.adb). package System.Shared_Storage is procedure Shared_Var_Lock (Var : String); -- This procedure claims the shared storage lock. It is used for -- protected types in shared passive packages. A call to this -- locking routine is generated as the first operation in the code -- for the body of a protected subprogram, and it busy waits if -- the lock is busy. procedure Shared_Var_Unlock (Var : String); -- This procedure releases the shared storage lock obtaind by a -- prior call to the Shared_Var_Lock procedure, and is to be -- generated as the last operation in the body of a protected -- subprogram. -- This generic package is instantiated for each shared passive -- variable. It provides supporting procedures called upon each -- read or write access by the expanded code. generic type Typ is limited private; -- Shared passive variable type V : in out Typ; -- Shared passive variable Full_Name : String; -- Shared passive variable storage name package Shared_Var_Procs is procedure Read; -- Shared passive variable access routine. Each reference to the -- shared variable, V, is preceded by a call to the corresponding -- Read procedure, which either leaves the initial value unchanged -- if the storage does not exist, or reads the current value from -- the shared storage. procedure Write; -- Shared passive variable assignment routine. Each assignment to -- the shared variable, V, is followed by a call to the corresponding -- Write procedure, which writes the new value to the shared storage. end Shared_Var_Procs; end System.Shared_Storage; polyorb-2.8~20110207.orig/src/dsa/polyorb-dsa_p-name_service.adb0000644000175000017500000001500411750740340023620 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . D S A _ P . N A M E _ S E R V I C E -- -- -- -- B o d y -- -- -- -- Copyright (C) 2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with PolyORB.DSA_P.Name_Service.mDNS; with PolyORB.DSA_P.Name_Service.COS_Naming; with PolyORB.Parameters; with PolyORB.Binding_Data; with PolyORB.Binding_Data.Local; with System.RPC; with PolyORB.Objects; with PolyORB.Log; with PolyORB.POA_Types; with PolyORB.Utils; with PolyORB.Errors; with PolyORB.Components; with PolyORB.Setup; with PolyORB.References.Binding; package body PolyORB.DSA_P.Name_Service is use PolyORB.Log; use PolyORB.DSA_P.Name_Service.mDNS; package L is new PolyORB.Log.Facility_Log ("polyorb.dsa_p.name_service"); procedure O (Message : String; Level : Log_Level := Debug) renames L.Output; function C (Level : Log_Level := Debug) return Boolean renames L.Enabled; procedure Initialize_Name_Context is use PolyORB.Binding_Data; use PolyORB.Binding_Data.Local; use PolyORB.References; Name_Context_String : constant String := PolyORB.Parameters.Get_Conf ("dsa", "name_context", "COS"); begin pragma Debug (C, O ("Initialize_Name_Context : Enter")); -- If mDNS is configured by user if Name_Context_String = "MDNS" then Name_Ctx := new PolyORB.DSA_P.Name_Service.mDNS.MDNS_Name_Context; declare Nameservice_Location : constant String := PolyORB.Parameters.Get_Conf ("dsa", "name_service"); Target_Profile : constant Binding_Data.Profile_Access := new Local_Profile_Type; Object_Key : PolyORB.Objects.Object_Id_Access; begin PolyORB.DSA_P.Name_Service.mDNS.Initiate_MDNS_Context (Nameservice_Location, Name_Ctx, Object_Key); -- Creating the local mDNS servant Reference from its Oid Create_Local_Profile (Object_Key.all, Local_Profile_Type (Target_Profile.all)); Create_Reference ((1 => Target_Profile), "", Name_Ctx.Base_Ref); PolyORB.POA_Types.Free (Object_Key); end; -- COS Naming case else Name_Ctx := new PolyORB.DSA_P.Name_Service.COS_Naming.COS_Name_Context; declare Nameserver_Location : constant String := PolyORB.Parameters.Get_Conf ("dsa", "name_service"); begin PolyORB.References.String_To_Object (Nameserver_Location, Name_Ctx.Base_Ref); exception when others => raise System.RPC.Communication_Error with "unable to locate name server " & Nameserver_Location; end; end if; Max_Requests := PolyORB.Parameters.Get_Conf (Section => "dsa", Key => "max_failed_requests", Default => 10); pragma Debug (C, O ("Initialize_Name_Context : Leave")); end Initialize_Name_Context; function Get_Name_Context return Name_Context_Access is begin return Name_Ctx; end Get_Name_Context; ----------------------------- -- Get_Reconnection_Policy -- ----------------------------- function Get_Reconnection_Policy (Name : String) return Reconnection_Policy_Type is begin return Reconnection_Policy_Type'Value (PolyORB.Parameters.Get_Conf (Section => "dsa", Key => RCI_Attr (Name, Reconnection), Default => Default_Reconnection_Policy'Img)); end Get_Reconnection_Policy; -------------- -- RCI_Attr -- -------------- function RCI_Attr (Name : String; Attr : RCI_Attribute) return String is use PolyORB.Utils; begin return To_Lower (Name & "'" & Attr'Img); end RCI_Attr; ------------------------ -- Is_Reference_Valid -- ------------------------ function Is_Reference_Valid (R : PolyORB.References.Ref) return Boolean is use PolyORB.References.Binding; use PolyORB.Errors; S : PolyORB.Components.Component_Access; Pro : PolyORB.Binding_Data.Profile_Access; Error : PolyORB.Errors.Error_Container; begin -- Bind the reference to ensure validity Bind (R => R, Local_ORB => PolyORB.Setup.The_ORB, Servant => S, QoS => (others => null), Pro => Pro, Local_Only => False, Error => Error); if Found (Error) then Catch (Error); return False; end if; return True; exception when others => return False; end Is_Reference_Valid; end PolyORB.DSA_P.Name_Service; polyorb-2.8~20110207.orig/src/dsa/polyorb-dsa_p-storages-dsm.ads0000644000175000017500000001361711750740340023621 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . D S A _ P . S T O R A G E S . D S M -- -- -- -- S p e c -- -- -- -- Copyright (C) 2008-2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- This package implements a distributed shared memory storage -- support for shared passive packages. The algorithm used for this -- implementation is based on the most optimised dynamic distributed -- manager algorithm with dynamic distributed copy set (i.e K .Li and -- P. Hudak, Memory Coherence in Shared Virtual Memory Systems, ACM -- Transactions on Computer Systems, nov 1989, vol. 7, num. 4, -- p. 321-359). -- DSM_Manager_Type is a distributed object which manages memory -- coherence of a shared variable on each node renferencing it. This -- unit defines DSM_Manager_Type which contains informations about -- a shared variable state, like access rigths, probable owner, read -- only copies node refenreces, requiered to running the algorithm. pragma Ada_2005; with PolyORB.Utils.Dynamic_Tables; package PolyORB.DSA_P.Storages.DSM is pragma Remote_Types; ---------------------- -- DSM_Manager_Type -- ---------------------- -- Manage coherence of a shared passive variable. RACW provides -- remote primitives for execution of the Li & Hudak algorithm. type DSM_Manager_Type is abstract new Shared_Data_Manager_Type with private; type DSM_Manager_RACW is access all DSM_Manager_Type'Class; pragma Asynchronous (DSM_Manager_RACW); -- Copy_Set_Type is used to track of other partitions managers to which a -- readonly copy was sent. package Copy_Set_Tables is new PolyORB.Utils.Dynamic_Tables (Table_Component_Type => DSM_Manager_RACW, Table_Index_Type => Integer, Table_Low_Bound => 0, Table_Initial => 10, Table_Increment => 10); subtype Copy_Set_Type is Copy_Set_Tables.Instance; -- DSM_Manager_Type type primitives -- Remotely called primitives procedure Invalidate_Request (Self : access DSM_Manager_Type; Rqst_Node : DSM_Manager_RACW; Version : Integer) is abstract; -- Invalidation request initiated by current write owner of variable V. -- The invalidation request is forwarded to all nodes listed in the local -- copy set. procedure Write_Request (Self : access DSM_Manager_Type; Rqst_Node : DSM_Manager_RACW) is abstract; -- Remote request from node requiring write access to shared variable V. -- Owner node replies using Write_Reply below, any other node forwards the -- request to the probable owner. procedure Write_Reply (Self : access DSM_Manager_Type; Var_Data : SDT.Any_Container_Ptr; Read_Copies : Copy_Set_Type; Version : Integer) is abstract; -- Remote asynchronous procedure: reply to write request, sends copy set -- and shared variable data. procedure Read_Request (Self : access DSM_Manager_Type; Rqst_Node : DSM_Manager_RACW) is abstract; -- Remote request from a node requiring read access to shared variable V. -- The owner node replies using Read_Reply below and adds the requesting -- node to its copy set. Any other node forwards the request to the -- probable owner of V. procedure Read_Reply (Self : access DSM_Manager_Type; Var_Data : SDT.Any_Container_Ptr; Reply_Node : DSM_Manager_RACW; Version : Integer) is abstract; -- Remote asynchronous procedure for reply to read request: sends last -- stored value of the shared variable. function Get_Initial_Owner (Self : access DSM_Manager_Type; Var_Name : String) return DSM_Manager_RACW is abstract; -- Return the intial owner of the varibale Var_Name. It should be called on -- a factory of a package. procedure Register_Passive_Package (Pkg_Name : String; Is_Owner : Boolean; Location : String); -- Register a DSM manager factory for package Pkg_Name private type DSM_Manager_Type is abstract new Shared_Data_Manager_Type with null record; end PolyORB.DSA_P.Storages.DSM; polyorb-2.8~20110207.orig/src/dsa/polyorb-dsa_p-storages-config.ads0000644000175000017500000000416711750740340024303 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . D S A _ P . S T O R A G E S . C O N F I G -- -- -- -- S p e c -- -- -- -- Copyright (C) 2008, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ package PolyORB.DSA_P.Storages.Config is procedure Initialize_Storages; end PolyORB.DSA_P.Storages.Config; polyorb-2.8~20110207.orig/src/dsa/polyorb-dsa_p-name_service-cos_naming.ads0000644000175000017500000000641111750740340025756 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- POLYORB.DSA_P.NAME_SERVICE.COS_NAMING -- -- -- -- S p e c -- -- -- -- Copyright (C) 2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- This package represents the CORBA COS Naming context, that uses the -- concept of a centralized name server. with PolyORB.References; with PolyORB.DSA_P.Name_Service; with PolyORB.Services.Naming; package PolyORB.DSA_P.Name_Service.COS_Naming is type COS_Name_Context is new Name_Context with null record; procedure Nameserver_Register (Name_Ctx : access COS_Name_Context; Name : String; Kind : String; Obj : PolyORB.References.Ref); -- Register object with the specified (Name, Kind) pair into the -- DSA naming context. function Nameserver_Lookup (Name_Ctx : access COS_Name_Context; Name : String; Kind : String; Initial : Boolean := True) return PolyORB.References.Ref; -- Look up the specified (Name, Kind) pair from the DSA naming context. -- If Initial is True, repeat lookup until a valid reference is obtained, -- and raise an exception if maximum retry count is reached, else just -- return an empty ref if name server retruns an empty or invalid result. function To_Name (Id, Kind : String) return PolyORB.Services.Naming.Name; -- Construct a name consisting of a single name component with the given -- id and kind. end PolyORB.DSA_P.Name_Service.COS_Naming; polyorb-2.8~20110207.orig/src/dsa/polyorb-partition_elaboration.adb0000644000175000017500000000547711750740340024501 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . P A R T I T I O N _ E L A B O R A T I O N -- -- -- -- B o d y -- -- -- -- Copyright (C) 2006-2009, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- Dummy placeholder body, replaced by a partition-specific one by the -- partitioning tool. pragma Ada_2005; package body PolyORB.Partition_Elaboration is --------------- -- Configure -- --------------- procedure Configure (Set_Conf : access procedure (Section, Key, Value : String)) is pragma Unreferenced (Set_Conf); begin null; end Configure; ----------------- -- Full_Launch -- ----------------- procedure Full_Launch is begin null; end Full_Launch; -------------------------- -- Run_Additional_Tasks -- -------------------------- procedure Run_Additional_Tasks is begin null; end Run_Additional_Tasks; begin raise Program_Error with "dummy version of polyorb-partition_elaboration"; end PolyORB.Partition_Elaboration; polyorb-2.8~20110207.orig/src/dsa/polyorb-termination_activity.ads0000644000175000017500000000544511750740340024372 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . T E R M I N A T I O N _ A C T I V I T Y -- -- -- -- S p e c -- -- -- -- Copyright (C) 2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- This package manages the termination manager activity counter with PolyORB.Tasking.Mutexes; package PolyORB.Termination_Activity is function Is_Active return Boolean; -- Returns true iff local node has sent messages since last termination -- wave. procedure Increment_Activity; -- Increment activity counter by one procedure Reset_Activity; -- Set to zero activity counter procedure Decrement_Activity; -- Decrement activity counter by one private Lock : PolyORB.Tasking.Mutexes.Mutex_Access; -- The lock ensuring integrity of the Activity Counter Activity_Counter : Natural := 0; -- Number of sent messages since the last wave by this node (not counting -- messages sent by the Termination Manager). end PolyORB.Termination_Activity; polyorb-2.8~20110207.orig/src/dsa/polyorb-dsa_p-name_service-mdns-helper.ads0000644000175000017500000003731311750740340026064 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- POLYORB.DSA_P.NAME_SERVICE.MDNS.HELPER -- -- -- -- S p e c -- -- -- -- Copyright (C) 2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with PolyORB.Types; with PolyORB.Sequences.Unbounded; with PolyORB.Sequences.Unbounded.Helper; with PolyORB.Sequences.Bounded; with PolyORB.Sequences.Bounded.Helper; pragma Elaborate_All (PolyORB.Sequences.Unbounded.Helper, PolyORB.Sequences.Bounded.Helper); with PolyORB.Any; package PolyORB.DSA_P.Name_Service.mDNS.Helper is -- Rcode type definition type Rcode is (No_Error, Format_Error, Server_Failure, Name_Error, Not_Implemented, Refused, YX_Domain, YX_RRSet, NX_RRSet, Not_Auth, Not_Zone); -- Rcode constant code values , -- defined by IANA, ref: [RFC 5395] [RFC 1035] No_Error_Code : constant Types.Unsigned_Short := 0; Format_Error_Code : constant Types.Unsigned_Short := 1; Server_Failure_Code : constant Types.Unsigned_Short := 2; Name_Error_Code : constant Types.Unsigned_Short := 3; Not_Implemented_Code : constant Types.Unsigned_Short := 4; Refused_Code : constant Types.Unsigned_Short := 5; YX_Domain_Code : constant Types.Unsigned_Short := 6; YX_RRSet_Code : constant Types.Unsigned_Short := 7; NX_RRSet_Code : constant Types.Unsigned_Short := 8; Not_Auth_Code : constant Types.Unsigned_Short := 9; Not_Zone_Code : constant Types.Unsigned_Short := 10; type Opcode_Type is (Query, IQuery, Status ); -- Opcode operation name definition Query_Name : constant Standard.String := "Query"; IQuery_Name : constant Standard.String := "IQuery"; Status_Name : constant Standard.String := "Status"; type RR_Type is (A, NS, SOA, CNAME, PTR, TXT, SRV); -- Resource Record (RR) TYPEs constant code values -- ,defined by IANA, ref: [RFC 5395] [RFC 1035] A_Code : constant Types.Unsigned_Short := 1; NS_Code : constant Types.Unsigned_Short := 2; SOA_Code : constant Types.Unsigned_Short := 6; CNAME_Code : constant Types.Unsigned_Short := 5; PTR_Code : constant Types.Unsigned_Short := 12; TXT_Code : constant Types.Unsigned_Short := 16; SRV_Code : constant Types.Unsigned_Short := 33; Default_Class_Code : constant Types.Unsigned_Short := 1; Arg_Name_Auth : constant PolyORB.Types.Identifier := PolyORB.Types.To_PolyORB_String ("authoritative"); Arg_Name_Question : constant PolyORB.Types.Identifier := PolyORB.Types.To_PolyORB_String ("question"); Arg_Name_Answer : constant PolyORB.Types.Identifier := PolyORB.Types.To_PolyORB_String ("answer"); Arg_Name_Au : constant PolyORB.Types.Identifier := PolyORB.Types.To_PolyORB_String ("authority"); Arg_Name_Add : constant PolyORB.Types.Identifier := PolyORB.Types.To_PolyORB_String ("additional"); type SRV_Data is record priority : PolyORB.Types.Unsigned_Short; weight : PolyORB.Types.Unsigned_Short; port : PolyORB.Types.Unsigned_Short; target : PolyORB.Types.String; end record; package IDL_SEQUENCE_4_octet is new PolyORB.Sequences.Bounded (PolyORB.Types.Octet, 4); type IDL_AT_Sequence_4_octet is new IDL_SEQUENCE_4_octet.Sequence; type RR_Data (Switch : RR_Type := RR_Type'First) is record case Switch is when SRV => srv_data : PolyORB.DSA_P.Name_Service.mDNS.Helper.SRV_Data; when A => a_address : IDL_AT_Sequence_4_octet; when others => rr_answer : PolyORB.Types.String; end case; end record; type RR is record rr_name : PolyORB.Types.String; rr_type : PolyORB.DSA_P.Name_Service.mDNS.Helper.RR_Type; TTL : PolyORB.Types.Unsigned_Long; data_length : PolyORB.Types.Unsigned_Short; rr_data : PolyORB.DSA_P.Name_Service.mDNS.Helper.RR_Data; end record; package IDL_SEQUENCE_DNS_RR is new PolyORB.Sequences.Unbounded (RR); type rrSequence is new IDL_SEQUENCE_DNS_RR.Sequence; TC_RR_Type : PolyORB.Any.TypeCode.Local_Ref; function From_Any (Item : PolyORB.Any.Any) return RR_Type; function To_Any (Item : RR_Type) return PolyORB.Any.Any; TC_SRV_Data : PolyORB.Any.TypeCode.Local_Ref; function From_Any (Item : PolyORB.Any.Any) return SRV_Data; function To_Any (Item : SRV_Data) return PolyORB.Any.Any; TC_IDL_SEQUENCE_4_octet : PolyORB.Any.TypeCode.Local_Ref; function From_Any (Item : PolyORB.Any.Any) return IDL_SEQUENCE_4_octet.Sequence; function To_Any (Item : IDL_SEQUENCE_4_octet.Sequence) return PolyORB.Any.Any; TC_IDL_AT_Sequence_4_octet : PolyORB.Any.TypeCode.Local_Ref; function From_Any (Item : PolyORB.Any.Any) return IDL_AT_Sequence_4_octet; function To_Any (Item : IDL_AT_Sequence_4_octet) return PolyORB.Any.Any; TC_RR_Data : PolyORB.Any.TypeCode.Local_Ref; function From_Any (Item : PolyORB.Any.Any) return RR_Data; function To_Any (Item : RR_Data) return PolyORB.Any.Any; TC_RR : PolyORB.Any.TypeCode.Local_Ref; function From_Any (Item : PolyORB.Any.Any) return RR; function To_Any (Item : RR) return PolyORB.Any.Any; TC_Rcode : PolyORB.Any.TypeCode.Local_Ref; function From_Any (Item : PolyORB.Any.Any) return Rcode; function To_Any (Item : Rcode) return PolyORB.Any.Any; TC_IDL_SEQUENCE_DNS_RR : PolyORB.Any.TypeCode.Local_Ref; function From_Any (Item : PolyORB.Any.Any) return IDL_SEQUENCE_DNS_RR.Sequence; function To_Any (Item : IDL_SEQUENCE_DNS_RR.Sequence) return PolyORB.Any.Any; TC_rrSequence : PolyORB.Any.TypeCode.Local_Ref; function From_Any (Item : PolyORB.Any.Any) return rrSequence; function To_Any (Item : rrSequence) return PolyORB.Any.Any; package Internals is function From_Any (C : PolyORB.Any.Any_Container'Class) return RR_Type; type Ptr_RR_Type is access all RR_Type; type Content_RR_Type is new PolyORB.Any.Aggregate_Content with record V : Ptr_RR_Type; Repr_Cache : aliased PolyORB.Types.Unsigned_Long; end record; function Get_Aggregate_Element (Acc : not null access Content_RR_Type; Tc : PolyORB.Any.TypeCode.Object_Ptr; Index : PolyORB.Types.Unsigned_Long; Mech : not null access PolyORB.Any.Mechanism) return PolyORB.Any.Content'Class; procedure Set_Aggregate_Element (Acc : in out Content_RR_Type; Tc : PolyORB.Any.TypeCode.Object_Ptr; Index : PolyORB.Types.Unsigned_Long; From_C : in out PolyORB.Any.Any_Container'Class); function Get_Aggregate_Count (Acc : Content_RR_Type) return PolyORB.Types.Unsigned_Long; procedure Set_Aggregate_Count (Acc : in out Content_RR_Type; Count : PolyORB.Types.Unsigned_Long); function Unchecked_Get_V (Acc : not null access Content_RR_Type) return PolyORB.Types.Address; function Clone (Acc : Content_RR_Type; Into : PolyORB.Any.Content_Ptr := null) return PolyORB.Any.Content_Ptr; procedure Finalize_Value (Acc : in out Content_RR_Type); function Wrap (X : access RR_Type) return PolyORB.Any.Content'Class; procedure Initialize_RR_Type; type Ptr_SRV_Data is access all SRV_Data; type Content_SRV_Data is new PolyORB.Any.Aggregate_Content with record V : Ptr_SRV_Data; end record; function Get_Aggregate_Element (Acc : not null access Content_SRV_Data; Tc : PolyORB.Any.TypeCode.Object_Ptr; Index : PolyORB.Types.Unsigned_Long; Mech : not null access PolyORB.Any.Mechanism) return PolyORB.Any.Content'Class; function Get_Aggregate_Count (Acc : Content_SRV_Data) return PolyORB.Types.Unsigned_Long; procedure Set_Aggregate_Count (Acc : in out Content_SRV_Data; Count : PolyORB.Types.Unsigned_Long); function Unchecked_Get_V (Acc : not null access Content_SRV_Data) return PolyORB.Types.Address; function Clone (Acc : Content_SRV_Data; Into : PolyORB.Any.Content_Ptr := null) return PolyORB.Any.Content_Ptr; procedure Finalize_Value (Acc : in out Content_SRV_Data); function Wrap (X : access SRV_Data) return PolyORB.Any.Content'Class; procedure Initialize_SRV_Data; function IDL_SEQUENCE_4_octet_Element_Wrap (X : access PolyORB.Types.Octet) return PolyORB.Any.Content'Class; function Wrap (X : access IDL_SEQUENCE_4_octet.Sequence) return PolyORB.Any.Content'Class; package IDL_SEQUENCE_4_octet_Helper is new IDL_SEQUENCE_4_octet.Helper (Element_From_Any => PolyORB.Any.From_Any, Element_To_Any => PolyORB.Any.To_Any, Element_Wrap => Helper.Internals.IDL_SEQUENCE_4_octet_Element_Wrap); procedure Initialize_IDL_SEQUENCE_4_octet; procedure Initialize_IDL_AT_Sequence_4_octet; type Ptr_RR_Data is access all RR_Data; type Content_RR_Data is new PolyORB.Any.Aggregate_Content with record V : Ptr_RR_Data; Switch_Cache : aliased RR_Type; end record; function Get_Aggregate_Element (Acc : not null access Content_RR_Data; Tc : PolyORB.Any.TypeCode.Object_Ptr; Index : PolyORB.Types.Unsigned_Long; Mech : not null access PolyORB.Any.Mechanism) return PolyORB.Any.Content'Class; procedure Set_Aggregate_Element (Acc : in out Content_RR_Data; Tc : PolyORB.Any.TypeCode.Object_Ptr; Index : PolyORB.Types.Unsigned_Long; From_C : in out PolyORB.Any.Any_Container'Class); function Get_Aggregate_Count (Acc : Content_RR_Data) return PolyORB.Types.Unsigned_Long; procedure Set_Aggregate_Count (Acc : in out Content_RR_Data; Count : PolyORB.Types.Unsigned_Long); function Unchecked_Get_V (Acc : not null access Content_RR_Data) return PolyORB.Types.Address; function Clone (Acc : Content_RR_Data; Into : PolyORB.Any.Content_Ptr := null) return PolyORB.Any.Content_Ptr; procedure Finalize_Value (Acc : in out Content_RR_Data); function Wrap (X : access RR_Data) return PolyORB.Any.Content'Class; procedure Initialize_RR_Data; type Ptr_RR is access all RR; type Content_RR is new PolyORB.Any.Aggregate_Content with record V : Ptr_RR; end record; function Get_Aggregate_Element (Acc : not null access Content_RR; Tc : PolyORB.Any.TypeCode.Object_Ptr; Index : PolyORB.Types.Unsigned_Long; Mech : not null access PolyORB.Any.Mechanism) return PolyORB.Any.Content'Class; function Get_Aggregate_Count (Acc : Content_RR) return PolyORB.Types.Unsigned_Long; procedure Set_Aggregate_Count (Acc : in out Content_RR; Count : PolyORB.Types.Unsigned_Long); function Unchecked_Get_V (Acc : not null access Content_RR) return PolyORB.Types.Address; function Clone (Acc : Content_RR; Into : PolyORB.Any.Content_Ptr := null) return PolyORB.Any.Content_Ptr; procedure Finalize_Value (Acc : in out Content_RR); function Wrap (X : access RR) return PolyORB.Any.Content'Class; procedure Initialize_RR; function From_Any (C : PolyORB.Any.Any_Container'Class) return Rcode; type Ptr_Rcode is access all Rcode; type Content_Rcode is new PolyORB.Any.Aggregate_Content with record V : Ptr_Rcode; Repr_Cache : aliased PolyORB.Types.Unsigned_Long; end record; function Get_Aggregate_Element (Acc : not null access Content_Rcode; Tc : PolyORB.Any.TypeCode.Object_Ptr; Index : PolyORB.Types.Unsigned_Long; Mech : not null access PolyORB.Any.Mechanism) return PolyORB.Any.Content'Class; procedure Set_Aggregate_Element (Acc : in out Content_Rcode; Tc : PolyORB.Any.TypeCode.Object_Ptr; Index : PolyORB.Types.Unsigned_Long; From_C : in out PolyORB.Any.Any_Container'Class); function Get_Aggregate_Count (Acc : Content_Rcode) return PolyORB.Types.Unsigned_Long; procedure Set_Aggregate_Count (Acc : in out Content_Rcode; Count : PolyORB.Types.Unsigned_Long); function Unchecked_Get_V (Acc : not null access Content_Rcode) return PolyORB.Types.Address; function Clone (Acc : Content_Rcode; Into : PolyORB.Any.Content_Ptr := null) return PolyORB.Any.Content_Ptr; procedure Finalize_Value (Acc : in out Content_Rcode); function Wrap (X : access Rcode) return PolyORB.Any.Content'Class; procedure Initialize_Rcode; function IDL_SEQUENCE_DNS_RR_Element_Wrap (X : access RR) return PolyORB.Any.Content'Class; function Wrap (X : access IDL_SEQUENCE_DNS_RR.Sequence) return PolyORB.Any.Content'Class; package IDL_SEQUENCE_DNS_RR_Helper is new IDL_SEQUENCE_DNS_RR.Helper (Element_From_Any => Helper.From_Any, Element_To_Any => Helper.To_Any, Element_Wrap => Helper.Internals.IDL_SEQUENCE_DNS_RR_Element_Wrap); procedure Initialize_IDL_SEQUENCE_DNS_RR; procedure Initialize_rrSequence; end Internals; end PolyORB.DSA_P.Name_Service.mDNS.Helper; polyorb-2.8~20110207.orig/src/dsa/polyorb-dsa_p-storages.adb0000644000175000017500000001531011750740340023007 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . D S A _ P . S T O R A G E S -- -- -- -- B o d y -- -- -- -- Copyright (C) 2008-2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ pragma Ada_2005; with Ada.Exceptions; with GNAT.HTable; with GNAT.OS_Lib; with PolyORB.Log; with PolyORB.Tasking.Mutexes; package body PolyORB.DSA_P.Storages is use PolyORB.Log; use PolyORB.Tasking.Mutexes; package OS renames GNAT.OS_Lib; subtype Hash_Header is Natural range 0 .. 30; function Hash (F : OS.String_Access) return Hash_Header; function Equal (F1, F2 : OS.String_Access) return Boolean; -- Hash and equality functions for hash table package SST is new GNAT.HTable.Simple_HTable (Header_Num => Hash_Header, Element => Shared_Data_Manager_RACW, No_Element => null, Key => OS.String_Access, Hash => Hash, Equal => Equal); -- Hash table containing shared variable managers of the local partition function Extract_Pkg_Name (Var_Name : String) return String; -- Var_Name is a fully qualified variable string name. Remove suffix -- to get package string name. ---------------------- -- Critical_Section -- ---------------------- Critical_Section : Mutex_Access; ----------- -- Equal -- ----------- function Equal (F1, F2 : OS.String_Access) return Boolean is begin return F1.all = F2.all; end Equal; ---------------------- -- Extract_Pkg_Name -- ---------------------- function Extract_Pkg_Name (Var_Name : String) return String is begin for Index in reverse Var_Name'Range loop if Var_Name (Index) = '.' then return Var_Name (Var_Name'First .. Index - 1); end if; end loop; return ""; end Extract_Pkg_Name; ---------- -- Hash -- ---------- function Hash (F : OS.String_Access) return Hash_Header is N : Natural := 0; begin -- Add up characters of name, mod our table size for J in F'Range loop N := (N + Character'Pos (F (J))) mod (Hash_Header'Last + 1); end loop; return N; end Hash; ------------- -- Logging -- ------------- package L is new Log.Facility_Log ("polyorb.dsa_p.storages"); procedure O (Message : Standard.String; Level : Log_Level := Debug) renames L.Output; function C (Level : Log_Level := Debug) return Boolean renames L.Enabled; -------------------- -- Lookup_Package -- -------------------- procedure Lookup_Package (Pkg_Name : String; Pkg_Data : out Shared_Data_Manager_RACW) is begin pragma Debug (C, O ("lookup package " & Pkg_Name)); -- Try to find a manager factory for package Pkg_Name Pkg_Data := SST.Get (Pkg_Name'Unrestricted_Access); if Pkg_Data = null then raise Program_Error with "unregistred shared passive package " & Pkg_Name; end if; end Lookup_Package; --------------------- -- Lookup_Variable -- --------------------- procedure Lookup_Variable (Var_Name : String; Var_Data : out Shared_Data_Manager_RACW) is Pkg_Data : Shared_Data_Manager_RACW; begin pragma Debug (C, O ("lookup variable " & Var_Name)); Enter (Critical_Section); begin -- Try to find a manager for shared variable Var_Name Var_Data := SST.Get (Var_Name'Unrestricted_Access); if Var_Data = null then -- Manager for this variable isn't created yet, -- so search a manager factory. Lookup_Package (Extract_Pkg_Name (Var_Name), Pkg_Data); Var_Data := Create (Pkg_Data, Var_Name); SST.Set (new String'(Var_Name), Var_Data); end if; Leave (Critical_Section); exception when E : others => pragma Debug (C, O ("Lookup_Variable: got exception " & Ada.Exceptions.Exception_Information (E))); Leave (Critical_Section); raise; end; end Lookup_Variable; ---------------------- -- Register_Factory -- ---------------------- procedure Register_Factory (Factory_Name : String; Factory_Data : Shared_Data_Manager_RACW) is Old_Factory : Shared_Data_Manager_RACW; begin pragma Debug (C, O ("Register_Factory: enter")); Enter (Critical_Section); Old_Factory := SST.Get (Factory_Name'Unrestricted_Access); if Old_Factory = null then SST.Set (new String'(Factory_Name), Factory_Data); Leave (Critical_Section); else Leave (Critical_Section); raise Program_Error with "duplicate factory " & Factory_Name; end if; pragma Debug (C, O ("Register_Factory: leave")); end Register_Factory; begin pragma Debug (C, O ("Create critical section")); Create (Critical_Section); end PolyORB.DSA_P.Storages; polyorb-2.8~20110207.orig/src/dsa/polyorb-dsa_p-streams.ads0000644000175000017500000001012211750740340022653 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . D S A _ P . S T R E A M S -- -- -- -- S p e c -- -- -- -- Copyright (C) 2008, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with Ada.Streams; use Ada.Streams; package PolyORB.DSA_P.Streams is type Memory_Resident_Stream (Size : Stream_Element_Count) is new Root_Stream_Type with private; -- A stream type that holds the stream elements in memory procedure Read (This : in out Memory_Resident_Stream; Item : out Stream_Element_Array; Last : out Stream_Element_Offset); -- Reads the entire value of Item from the stream This, -- setting Last to the last index of Item that is assigned. -- If the length of Item is greater than the number of -- elements in the stream, reading stops and Last will not -- be equal to Item'Last. procedure Write (This : in out Memory_Resident_Stream; Item : Stream_Element_Array); -- Writes the elements in Item to the stream. procedure Reset_Reading (This : access Memory_Resident_Stream); -- Start reading from the beginning of the stream. procedure Reset_Writing (This : access Memory_Resident_Stream); -- Start writing to the beginning of the stream. function Empty (This : Memory_Resident_Stream) return Boolean; -- Returns whether the stream contains any stream elements. procedure Reset (This : access Memory_Resident_Stream); -- Performs a complete reset, as if no reading or writing -- had ever occurred. function Extent (This : Memory_Resident_Stream) return Stream_Element_Count; -- Returns the number of elements in the stream. private type Memory_Resident_Stream (Size : Stream_Element_Count) is new Root_Stream_Type with record Count : Stream_Element_Count := 0; -- The number of stream elements currently held Next_In : Stream_Element_Offset := 1; -- The index of the next stream element to be written Next_Out : Stream_Element_Offset := 1; -- The index of the next stream element to be read Values : Stream_Element_Array (1 .. Size); -- The stream elements currently held end record; end PolyORB.DSA_P.Streams; polyorb-2.8~20110207.orig/src/dsa/polyorb-dsa_p-name_service-mdns-servant.adb0000644000175000017500000003523611750740340026250 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- POLYORB.DSA_P.NAME_SERVICE.MDNS.SERVANT -- -- -- -- B o d y -- -- -- -- Copyright (C) 2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with PolyORB.Any.NVList; with PolyORB.Errors; with PolyORB.Log; with PolyORB.Any; with PolyORB.Utils; with PolyORB.Utils.Strings; with PolyORB.References.Corbaloc; with PolyORB.Tasking.Mutexes; with PolyORB.Initialization; package body PolyORB.DSA_P.Name_Service.mDNS.Servant is use PolyORB.Errors; use PolyORB.Log; package L is new PolyORB.Log.Facility_Log ("polyorb.dsa_p.name_service.mdns.servant"); procedure O (Message : String; Level : Log_Level := Debug) renames L.Output; function C (Level : Log_Level := Debug) return Boolean renames L.Enabled; package PTM renames PolyORB.Tasking.Mutexes; Critical_Section : PTM.Mutex_Access; procedure Query (Self : access Object; Authoritative : in out Boolean; Question : rrSequence; Answer : out rrSequence; Authority : out rrSequence; Additional : out rrSequence; Response : out Rcode) is pragma Unreferenced (Self); begin Authoritative := True; -- By default, each partition is autoritative -- For each received question we must look for an RR or a list of RRs -- and assign them to the RR answer/additional infos sequence for J in 1 .. Length (Question) loop Find_Answer_RR (Get_Element (Question, J), Answer, Authority, Additional, Response); end loop; end Query; procedure Invoke (Self : access Object; Request : PolyORB.Requests.Request_Access) is use PolyORB.Any.NVList; Operation : Standard.String renames Request.all.Operation.all; Arg_List : PolyORB.Any.NVList.Ref; begin pragma Debug (C, O ("The dns servant is executing the request:" & PolyORB.Requests.Image (Request.all))); Create (Arg_List); if Operation = "Query" then declare use PolyORB.Requests; use PolyORB.Any; use PolyORB.Any.NVList.Internals; use PolyORB.Any.NVList.Internals.NV_Lists; Argument_Authoritative : constant PolyORB.Any.Any := PolyORB.Any.Get_Empty_Any (PolyORB.Any.TC_Boolean); Argument_Question : constant PolyORB.Any.Any := PolyORB.Any.Get_Empty_Any (TC_IDL_SEQUENCE_DNS_RR); Argument_Answer : PolyORB.Any.Any := PolyORB.Any.Get_Empty_Any (TC_IDL_SEQUENCE_DNS_RR); Argument_Authority : PolyORB.Any.Any := PolyORB.Any.Get_Empty_Any (TC_IDL_SEQUENCE_DNS_RR); Argument_Additional : PolyORB.Any.Any := PolyORB.Any.Get_Empty_Any (TC_IDL_SEQUENCE_DNS_RR); Question : rrSequence; Authoritative : PolyORB.Types.Boolean; Answer : rrSequence; Authority : rrSequence; Additional : rrSequence; Result : Rcode; Exception_Error : Error_Container; begin -- Create argument list pragma Debug (C, O ("Creating argument list")); Add_Item (Arg_List, Arg_Name_Auth, Argument_Authoritative, PolyORB.Any.ARG_INOUT); Add_Item (Arg_List, Arg_Name_Question, Argument_Question, PolyORB.Any.ARG_IN); Add_Item (Arg_List, Arg_Name_Answer, Argument_Answer, PolyORB.Any.ARG_OUT); Add_Item (Arg_List, Arg_Name_Au, Argument_Authority, PolyORB.Any.ARG_OUT); Add_Item (Arg_List, Arg_Name_Add, Argument_Additional, PolyORB.Any.ARG_OUT); Arguments (Request, Arg_List, Exception_Error); if Found (Exception_Error) then raise Program_Error; end if; -- retrieving IN arguments from the Any representation Authoritative := PolyORB.Any.From_Any (Argument_Authoritative); Question := To_Sequence (1); Question := From_Any (Argument_Question); Query (Self, Authoritative, Question, Answer, Authority, Additional, Result); -- Converting the out rr sequences to the Any type Argument_Answer := To_Any (Answer); Argument_Authority := To_Any (Authority); Argument_Additional := To_Any (Additional); -- Setting out args declare It : Iterator := First (List_Of (Request.Out_Args).all); Arg : Element_Access; begin Arg := Value (It); Set_Any_Value (Authoritative, Get_Container (Arg.Argument).all); Next (It); Arg := Value (It); Copy_Any_Value (Arg.Argument, Argument_Question); -- answer rr sequence Next (It); Arg := Value (It); Copy_Any_Value (Arg.Argument, Argument_Answer); -- authority servers rr sequence Next (It); Arg := Value (It); Copy_Any_Value (Arg.Argument, Argument_Authority); -- additionnal info rr sequence Next (It); Arg := Value (It); Copy_Any_Value (Arg.Argument, Argument_Additional); end; PolyORB.Requests.Set_Result (Request, To_Any (Result)); return; end; end if; end Invoke; procedure Find_Answer_RR (Question : RR; Answer_Seq : out rrSequence; Authority_Seq : out rrSequence; Additional_Seq : out rrSequence; Response : out Rcode) is use PolyORB.Types; TTL : constant PolyORB.Types.Unsigned_Long := 240; Answer : RR; Current_Name, Current_Kind : PolyORB.Types.String; Current_Entry : Local_Entry_Ptr; pragma Unreferenced (Authority_Seq, Additional_Seq); begin case Question.rr_type is -- Currently, the protocol for exchanging mDNS messages in the -- in the mDNS context implies the usage of the TXT mapping, -- so upon reception of an SRV message request, we generate an answer -- resource record by looking up the Local_Entry_List and assigning -- the necessary data (stringified reference and version id) -- to the TXT recorde reply (stored in the Answer rr sequence). when SRV => -- If the request message is not correctly structured, -- send back a Name_Error Rcode to client begin Parse_Question_Name (Question.rr_name, Current_Name, Current_Kind); exception when others => pragma Debug (C, O ("Record not Found, return Name_Error")); Response := Name_Error; return; end; PTM.Enter (Critical_Section); Current_Entry := Local_Entry_List.Lookup (To_Standard_String (Current_Name), null); PTM.Leave (Critical_Section); if Current_Entry = null then -- If the record is not found locally, we return a -- Name_Error DNS Rcode to client. Response := Name_Error; return; end if; Answer_Seq := To_Sequence (1); Answer.rr_name := Question.rr_name; Answer.TTL := TTL; Answer.rr_type := TXT; declare TXT_RR_Data : RR_Data (Answer.rr_type); Base_Ref_String : constant String := References.Corbaloc.Object_To_String (Current_Entry.Base_Ref); begin TXT_RR_Data.rr_answer := To_PolyORB_String ("reference=" & Base_Ref_String & "\.version=" & To_Standard_String (Current_Entry.Version)); Answer.data_length := PolyORB.Types.Unsigned_Short (PolyORB.Types.To_Standard_String (TXT_RR_Data.rr_answer)'Length); Answer.rr_data := TXT_RR_Data; end; Replace_Element (Answer_Seq, 1, Answer); Response := No_Error; -- XXX:The following RRs are used for testing purposes currently when A => Answer.rr_name := Question.rr_name; Answer.TTL := TTL; Answer.rr_type := A; declare rd : RR_Data (Answer.rr_type); addr : IDL_AT_Sequence_4_octet; begin addr := IDL_AT_Sequence_4_octet (IDL_SEQUENCE_4_octet.To_Sequence (IDL_SEQUENCE_4_octet.Element_Array'(192, 168, 1, 11))); rd.a_address := addr; Answer.data_length := PolyORB.Types.Unsigned_Short (4); Answer.rr_data := rd; end; when PTR => Answer_Seq := To_Sequence (1); Answer.rr_name := Question.rr_name; Answer.rr_type := PTR; Answer.TTL := TTL; declare rd : RR_Data (Answer.rr_type); begin rd.rr_answer := PolyORB.Types.To_PolyORB_String ("TEST_PTR"); Answer.data_length := PolyORB.Types.Unsigned_Short (2 + PolyORB.Types.To_Standard_String (rd.rr_answer)'Length); Answer.rr_data := rd; Replace_Element (Answer_Seq, 1, Answer); end; when TXT => Answer_Seq := To_Sequence (1); Answer.rr_name := Question.rr_name; Answer.TTL := TTL; Answer.rr_type := TXT; declare rd : RR_Data (Answer.rr_type); begin rd.rr_answer := PolyORB.Types.To_PolyORB_String ("TEST FOR TXT RECORD"); Answer.data_length := PolyORB.Types.Unsigned_Short (2 + PolyORB.Types.To_Standard_String (rd.rr_answer)'Length); Answer.rr_data := rd; end; Replace_Element (Answer_Seq, 1, Answer); -- Other RR types are not currently supported when others => raise Program_Error; end case; end Find_Answer_RR; procedure Append_Entry_To_Context (Name : PolyORB.Types.String; Kind : PolyORB.Types.String; Version : PolyORB.Types.String; Base_Ref : PolyORB.References.Ref) is New_Entry : Local_Entry_Ptr; begin pragma Debug (C, O ("Appending new entry ")); New_Entry := new Local_Entry; New_Entry.Name := Name; New_Entry.Kind := Kind; New_Entry.Version := Version; New_Entry.Base_Ref := Base_Ref; PTM.Enter (Critical_Section); Local_Entry_List.Register (PolyORB.Types.To_Standard_String (Name), New_Entry); PTM.Leave (Critical_Section); pragma Debug (C, O ("Entry Appended : leaving")); end Append_Entry_To_Context; procedure Parse_Question_Name (Question : PolyORB.Types.String; Name : out PolyORB.Types.String; Kind : out PolyORB.Types.String) is use PolyORB.Utils; use PolyORB.Types; S : constant String := PolyORB.Types.To_Standard_String (Question); Index : Integer; Index2 : Integer; begin Index := PolyORB.Utils.Find (S, S'Last, '_', False, Backward); Index2 := S'Last; Name := Types.To_PolyORB_String (S (S'First .. Index - 2)); Kind := Types.To_PolyORB_String (S (Index + 1 .. Index2)); if Kind /= "rci" and Kind /= "sp" then raise Constraint_Error; end if; end Parse_Question_Name; ---------------- -- Initialize -- ---------------- procedure Initialize; procedure Initialize is begin PTM.Create (Critical_Section); end Initialize; use PolyORB.Initialization; use PolyORB.Initialization.String_Lists; use PolyORB.Utils.Strings; begin Register_Module (Module_Info' (Name => +"name_service.mdns.servant", Conflicts => Empty, Depends => +"tasking.mutexes", Provides => Empty, Implicit => False, Init => Initialize'Access, Shutdown => null)); end PolyORB.DSA_P.Name_Service.mDNS.Servant; polyorb-2.8~20110207.orig/src/dsa/polyorb-dsa_p-storages-dfs.ads0000644000175000017500000000753311750740340023612 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . D S A _ P . S T O R A G E S . D F S -- -- -- -- S p e c -- -- -- -- Copyright (C) 2008-2009, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ pragma Ada_2005; with Ada.Streams; with Ada.Streams.Stream_IO; with GNAT.OS_Lib; pragma Warnings (Off); -- System.Global_Locks is an internal GNAT unit with System.Global_Locks; pragma Warnings (On); with PolyORB.Tasking.Mutexes; with PolyORB.Any; package PolyORB.DSA_P.Storages.DFS is use PolyORB.Tasking.Mutexes; package SIO renames Ada.Streams.Stream_IO; package SGL renames System.Global_Locks; package OS renames GNAT.OS_Lib; ---------------------- -- DFS_Manager_Type -- ---------------------- -- Manage coherence of a shared passive variable. type DFS_Manager_Type is new Shared_Data_Manager_Type with private; type DFS_Manager_Access is access all DFS_Manager_Type'Class; -- DFS_Manager_Type type primitives overriding procedure Read (Self : access DFS_Manager_Type; Var : SDT.Any_Container_Ptr); overriding procedure Write (Self : access DFS_Manager_Type; Var : SDT.Any_Container_Ptr); overriding procedure Lock (Self : access DFS_Manager_Type); overriding procedure Unlock (Self : access DFS_Manager_Type); overriding function Create (Manager_Factory : access DFS_Manager_Type; Full_Name : String) return Shared_Data_Manager_RACW; procedure Register_Passive_Package (Pkg_Name : String; Is_Owner : Boolean; Location : String); -- Register a DFS manager factory for package Pkg_name private type DFS_Manager_Type is new Shared_Data_Manager_Type with record Data : PolyORB.Any.Any; Name : OS.String_Access; File : SIO.File_Type; Lock : SGL.Lock_Type; Mutex : Mutex_Access; Count : Natural; Dir : OS.String_Access; Prev : DFS_Manager_Access; Next : DFS_Manager_Access; Self : DFS_Manager_Access; end record; end PolyORB.DSA_P.Storages.DFS; polyorb-2.8~20110207.orig/src/dsa/polyorb-termination_activity.adb0000644000175000017500000000734011750740340024345 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . T E R M I N A T I O N _ A C T I V I T Y -- -- -- -- B o d y -- -- -- -- Copyright (C) 2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with PolyORB.Initialization; with PolyORB.Utils.Strings; with PolyORB.Utils.Strings.Lists; package body PolyORB.Termination_Activity is use PolyORB.Tasking.Mutexes; procedure Initialize; --------------- -- Is_Active -- --------------- function Is_Active return Boolean is Result : Boolean := False; begin Enter (Lock); Result := Activity_Counter > 0; Leave (Lock); return Result; end Is_Active; ------------------------ -- Increment_Activity -- ------------------------ procedure Increment_Activity is begin Enter (Lock); Activity_Counter := Activity_Counter + 1; Leave (Lock); end Increment_Activity; -------------------- -- Reset_Activity -- -------------------- procedure Reset_Activity is begin Enter (Lock); Activity_Counter := 0; Leave (Lock); end Reset_Activity; ------------------------ -- Decrement_Activity -- ------------------------ procedure Decrement_Activity is begin Enter (Lock); if Activity_Counter > 0 then Activity_Counter := Activity_Counter - 1; end if; Leave (Lock); end Decrement_Activity; ---------------- -- Initialize -- ---------------- procedure Initialize is begin Create (Lock); end Initialize; use PolyORB.Initialization; use PolyORB.Utils.Strings; use PolyORB.Utils.Strings.Lists; begin Register_Module (Module_Info' (Name => +"termination.activity", Conflicts => Empty, Depends => +"tasking.mutexes", Provides => Empty, Implicit => False, Init => Initialize'Access, Shutdown => null)); end PolyORB.Termination_Activity; polyorb-2.8~20110207.orig/src/dsa/polyorb-dsa_p-name_server.ads0000644000175000017500000000444211750740340023513 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . D S A _ P . N A M E _ S E R V E R -- -- -- -- S p e c -- -- -- -- Copyright (C) 2009, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- DSA name server -- This package provides a central repository mapping the names of RCI units -- and DSM Shared Passive variables to remote object references. package PolyORB.DSA_P.Name_Server is pragma Remote_Types; pragma Elaborate_Body; end PolyORB.DSA_P.Name_Server; polyorb-2.8~20110207.orig/src/dsa/polyorb-dsa_p-partitions.ads0000644000175000017500000000456311750740340023405 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . D S A _ P . P A R T I T I O N S -- -- -- -- S p e c -- -- -- -- Copyright (C) 2002-2007, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- Partition ID assignment server package PolyORB.DSA_P.Partitions is pragma Remote_Call_Interface; pragma Elaborate_Body; function Allocate_Partition_ID (Name : String) return Integer; -- Allocate a new partition identifier for the named partition (the name -- is currently unused and has no defined semantics). end PolyORB.DSA_P.Partitions; polyorb-2.8~20110207.orig/src/dsa/polyorb-dsa_p-name_service-mdns-helper.adb0000644000175000017500000015653211750740340026050 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- POLYORB.DSA_P.NAME_SERVICE.MDNS.HELPER -- -- -- -- B o d y -- -- -- -- Copyright (C) 2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- mDNS Helper package containing type declarations and corresponding -- marshall/unmarshall primitives with PolyORB.Log; with PolyORB.Initialization; with PolyORB.Utils.Strings; with Ada.Unchecked_Deallocation; with Ada.Unchecked_Conversion; package body PolyORB.DSA_P.Name_Service.mDNS.Helper is use PolyORB.Log; package L is new PolyORB.Log.Facility_Log ("polyorb.dsa_p.name_service.mdns.helper"); procedure O (Message : String; Level : Log_Level := Debug) renames L.Output; function C (Level : Log_Level := Debug) return Boolean renames L.Enabled; package body Internals is -------------- -- From_Any -- -------------- function From_Any (C : PolyORB.Any.Any_Container'Class) return RR_Type is begin return RR_Type'Val (PolyORB.Types.Unsigned_Long' (PolyORB.Any.Get_Aggregate_Element (C, 0))); end From_Any; --------------------------- -- Get_Aggregate_Element -- --------------------------- function Get_Aggregate_Element (Acc : not null access Content_RR_Type; Tc : PolyORB.Any.TypeCode.Object_Ptr; Index : PolyORB.Types.Unsigned_Long; Mech : not null access PolyORB.Any.Mechanism) return PolyORB.Any.Content'Class is use type PolyORB.Types.Unsigned_Long; use type PolyORB.Any.Mechanism; pragma Suppress (Validity_Check); pragma Unreferenced (Tc, Index); begin Acc.Repr_Cache := RR_Type'Pos (Acc.V.all); Mech.all := PolyORB.Any.By_Value; return PolyORB.Any.Wrap (Acc.Repr_Cache'Unrestricted_Access); end Get_Aggregate_Element; --------------------------- -- Set_Aggregate_Element -- --------------------------- procedure Set_Aggregate_Element (Acc : in out Content_RR_Type; Tc : PolyORB.Any.TypeCode.Object_Ptr; Index : PolyORB.Types.Unsigned_Long; From_C : in out PolyORB.Any.Any_Container'Class) is use type PolyORB.Types.Unsigned_Long; pragma Assert ((Index = 0)); pragma Unreferenced (Tc); begin Acc.V.all := RR_Type'Val (PolyORB.Types.Unsigned_Long' (PolyORB.Any.From_Any (From_C))); end Set_Aggregate_Element; ------------------------- -- Get_Aggregate_Count -- ------------------------- function Get_Aggregate_Count (Acc : Content_RR_Type) return PolyORB.Types.Unsigned_Long is pragma Unreferenced (Acc); begin return 1; end Get_Aggregate_Count; ------------------------- -- Set_Aggregate_Count -- ------------------------- procedure Set_Aggregate_Count (Acc : in out Content_RR_Type; Count : PolyORB.Types.Unsigned_Long) is begin null; end Set_Aggregate_Count; --------------------- -- Unchecked_Get_V -- --------------------- function Unchecked_Get_V (Acc : not null access Content_RR_Type) return PolyORB.Types.Address is function To_Address is new Ada.Unchecked_Conversion (Ptr_RR_Type, PolyORB.Types.Address); begin return To_Address (Acc.V); end Unchecked_Get_V; ----------- -- Clone -- ----------- function Clone (Acc : Content_RR_Type; Into : PolyORB.Any.Content_Ptr := null) return PolyORB.Any.Content_Ptr is use type PolyORB.Any.Content_Ptr; Target : PolyORB.Any.Content_Ptr; begin if Into /= null then if Into.all not in Content_RR_Type then return null; end if; Target := Into; Content_RR_Type (Target.all).V.all := Acc.V.all; else Target := new Content_RR_Type; Content_RR_Type (Target.all).V := new RR_Type' (Acc.V.all); end if; Content_RR_Type (Target.all).Repr_Cache := Acc.Repr_Cache; return Target; end Clone; -------------------- -- Finalize_Value -- -------------------- procedure Finalize_Value (Acc : in out Content_RR_Type) is procedure Free is new Ada.Unchecked_Deallocation (RR_Type, Ptr_RR_Type); begin Free (Acc.V); end Finalize_Value; ---------- -- Wrap -- ---------- function Wrap (X : access RR_Type) return PolyORB.Any.Content'Class is begin return Content_RR_Type' (PolyORB.Any.Aggregate_Content with V => Ptr_RR_Type (X), Repr_Cache => 0); end Wrap; RR_Type_Initialized : PolyORB.Types.Boolean := False; ------------------------ -- Initialize_RR_Type -- ------------------------ procedure Initialize_RR_Type is Name : constant PolyORB.Types.String := PolyORB.Types.To_PolyORB_String ("RR_Type"); Id : constant PolyORB.Types.String := PolyORB.Types.To_PolyORB_String ("IDL:DNS/RR_Type:1.0"); A_Name : constant PolyORB.Types.String := PolyORB.Types.To_PolyORB_String ("A"); NS_Name : constant PolyORB.Types.String := PolyORB.Types.To_PolyORB_String ("NS"); SOA_Name : constant PolyORB.Types.String := PolyORB.Types.To_PolyORB_String ("SOA"); CNAME_Name : constant PolyORB.Types.String := PolyORB.Types.To_PolyORB_String ("CNAME"); PTR_Name : constant PolyORB.Types.String := PolyORB.Types.To_PolyORB_String ("PTR"); TXT_Name : constant PolyORB.Types.String := PolyORB.Types.To_PolyORB_String ("TXT"); SRV_Name : constant PolyORB.Types.String := PolyORB.Types.To_PolyORB_String ("SRV"); begin if not RR_Type_Initialized then RR_Type_Initialized := True; TC_RR_Type := PolyORB.Any.TypeCode.TC_Enum; PolyORB.Any.TypeCode.Add_Parameter (TC_RR_Type, PolyORB.Any.To_Any (Name)); PolyORB.Any.TypeCode.Add_Parameter (TC_RR_Type, PolyORB.Any.To_Any (Id)); PolyORB.Any.TypeCode.Add_Parameter (TC_RR_Type, PolyORB.Any.To_Any (A_Name)); PolyORB.Any.TypeCode.Add_Parameter (TC_RR_Type, PolyORB.Any.To_Any (NS_Name)); PolyORB.Any.TypeCode.Add_Parameter (TC_RR_Type, PolyORB.Any.To_Any (SOA_Name)); PolyORB.Any.TypeCode.Add_Parameter (TC_RR_Type, PolyORB.Any.To_Any (CNAME_Name)); PolyORB.Any.TypeCode.Add_Parameter (TC_RR_Type, PolyORB.Any.To_Any (PTR_Name)); PolyORB.Any.TypeCode.Add_Parameter (TC_RR_Type, PolyORB.Any.To_Any (TXT_Name)); PolyORB.Any.TypeCode.Add_Parameter (TC_RR_Type, PolyORB.Any.To_Any (SRV_Name)); Any.TypeCode.Disable_Reference_Counting (Any.TypeCode.Object_Of (TC_RR_Type).all); end if; end Initialize_RR_Type; --------------------------- -- Get_Aggregate_Element -- --------------------------- function Get_Aggregate_Element (Acc : not null access Content_SRV_Data; Tc : PolyORB.Any.TypeCode.Object_Ptr; Index : PolyORB.Types.Unsigned_Long; Mech : not null access PolyORB.Any.Mechanism) return PolyORB.Any.Content'Class is use type PolyORB.Types.Unsigned_Long; use type PolyORB.Any.Mechanism; pragma Suppress (Validity_Check); pragma Unreferenced (Tc); begin Mech.all := PolyORB.Any.By_Reference; case Index is when 0 => return PolyORB.Any.Wrap (Acc.V.priority'Unrestricted_Access); when 1 => return PolyORB.Any.Wrap (Acc.V.weight'Unrestricted_Access); when 2 => return PolyORB.Any.Wrap (Acc.V.port'Unrestricted_Access); when 3 => return PolyORB.Any.Wrap (Acc.V.target'Unrestricted_Access); pragma Warnings (Off); when others => raise Constraint_Error; pragma Warnings (On); end case; end Get_Aggregate_Element; ------------------------- -- Get_Aggregate_Count -- ------------------------- function Get_Aggregate_Count (Acc : Content_SRV_Data) return PolyORB.Types.Unsigned_Long is pragma Unreferenced (Acc); begin return 4; end Get_Aggregate_Count; ------------------------- -- Set_Aggregate_Count -- ------------------------- procedure Set_Aggregate_Count (Acc : in out Content_SRV_Data; Count : PolyORB.Types.Unsigned_Long) is begin null; end Set_Aggregate_Count; --------------------- -- Unchecked_Get_V -- --------------------- function Unchecked_Get_V (Acc : not null access Content_SRV_Data) return PolyORB.Types.Address is function To_Address is new Ada.Unchecked_Conversion (Ptr_SRV_Data, PolyORB.Types.Address); begin return To_Address (Acc.V); end Unchecked_Get_V; ----------- -- Clone -- ----------- function Clone (Acc : Content_SRV_Data; Into : PolyORB.Any.Content_Ptr := null) return PolyORB.Any.Content_Ptr is use type PolyORB.Any.Content_Ptr; Target : PolyORB.Any.Content_Ptr; begin if Into /= null then if Into.all not in Content_SRV_Data then return null; end if; Target := Into; Content_SRV_Data (Target.all).V.all := Acc.V.all; else Target := new Content_SRV_Data; Content_SRV_Data (Target.all).V := new SRV_Data' (Acc.V.all); end if; return Target; end Clone; -------------------- -- Finalize_Value -- -------------------- procedure Finalize_Value (Acc : in out Content_SRV_Data) is procedure Free is new Ada.Unchecked_Deallocation (SRV_Data, Ptr_SRV_Data); begin Free (Acc.V); end Finalize_Value; ---------- -- Wrap -- ---------- function Wrap (X : access SRV_Data) return PolyORB.Any.Content'Class is begin return Content_SRV_Data' (PolyORB.Any.Aggregate_Content with V => Ptr_SRV_Data (X)); end Wrap; SRV_Data_Initialized : PolyORB.Types.Boolean := False; ------------------------- -- Initialize_SRV_Data -- ------------------------- procedure Initialize_SRV_Data is Name : constant PolyORB.Types.String := PolyORB.Types.To_PolyORB_String ("SRV_Data"); Id : constant PolyORB.Types.String := PolyORB.Types.To_PolyORB_String ("IDL:DNS/SRV_Data:1.0"); Argument_Name_priority : constant PolyORB.Types.String := PolyORB.Types.To_PolyORB_String ("priority"); Argument_Name_weight : constant PolyORB.Types.String := PolyORB.Types.To_PolyORB_String ("weight"); Argument_Name_port : constant PolyORB.Types.String := PolyORB.Types.To_PolyORB_String ("port"); Argument_Name_target : constant PolyORB.Types.String := PolyORB.Types.To_PolyORB_String ("target"); begin if not SRV_Data_Initialized then SRV_Data_Initialized := True; Helper.TC_SRV_Data := PolyORB.Any.TypeCode.TC_Struct; PolyORB.Any.TypeCode.Add_Parameter (TC_SRV_Data, PolyORB.Any.To_Any (Name)); PolyORB.Any.TypeCode.Add_Parameter (TC_SRV_Data, PolyORB.Any.To_Any (Id)); PolyORB.Any.TypeCode.Add_Parameter (TC_SRV_Data, PolyORB.Any.To_Any (PolyORB.Any.TC_Unsigned_Short)); PolyORB.Any.TypeCode.Add_Parameter (TC_SRV_Data, PolyORB.Any.To_Any (Argument_Name_priority)); PolyORB.Any.TypeCode.Add_Parameter (TC_SRV_Data, PolyORB.Any.To_Any (PolyORB.Any.TC_Unsigned_Short)); PolyORB.Any.TypeCode.Add_Parameter (TC_SRV_Data, PolyORB.Any.To_Any (Argument_Name_weight)); PolyORB.Any.TypeCode.Add_Parameter (TC_SRV_Data, PolyORB.Any.To_Any (PolyORB.Any.TC_Unsigned_Short)); PolyORB.Any.TypeCode.Add_Parameter (TC_SRV_Data, PolyORB.Any.To_Any (Argument_Name_port)); PolyORB.Any.TypeCode.Add_Parameter (TC_SRV_Data, PolyORB.Any.To_Any (PolyORB.Any.TC_String)); PolyORB.Any.TypeCode.Add_Parameter (TC_SRV_Data, PolyORB.Any.To_Any (Argument_Name_target)); Any.TypeCode.Disable_Reference_Counting (Any.TypeCode.Object_Of (TC_SRV_Data).all); end if; end Initialize_SRV_Data; IDL_SEQUENCE_4_octet_Initialized : PolyORB.Types.Boolean := False; --------------------------------------- -- IDL_SEQUENCE_4_octet_Element_Wrap -- --------------------------------------- function IDL_SEQUENCE_4_octet_Element_Wrap (X : access PolyORB.Types.Octet) return PolyORB.Any.Content'Class is begin return PolyORB.Any.Wrap (X.all'Unrestricted_Access); end IDL_SEQUENCE_4_octet_Element_Wrap; function Wrap (X : access IDL_SEQUENCE_4_octet.Sequence) return PolyORB.Any.Content'Class renames IDL_SEQUENCE_4_octet_Helper.Wrap; ------------------------------------- -- Initialize_IDL_SEQUENCE_4_octet -- ------------------------------------- procedure Initialize_IDL_SEQUENCE_4_octet is begin if not IDL_SEQUENCE_4_octet_Initialized then IDL_SEQUENCE_4_octet_Initialized := True; Helper.TC_IDL_SEQUENCE_4_octet := PolyORB.Any.TypeCode.Build_Sequence_TC (PolyORB.Any.TC_Octet, 4); Any.TypeCode.Disable_Reference_Counting (Any.TypeCode.Object_Of (TC_IDL_SEQUENCE_4_octet).all); IDL_SEQUENCE_4_octet_Helper.Initialize (Element_TC => PolyORB.Any.TC_Octet, Sequence_TC => Helper.TC_IDL_SEQUENCE_4_octet); end if; end Initialize_IDL_SEQUENCE_4_octet; IDL_AT_Sequence_4_octet_Initialized : PolyORB.Types.Boolean := False; ---------------------------------------- -- Initialize_IDL_AT_Sequence_4_octet -- ---------------------------------------- procedure Initialize_IDL_AT_Sequence_4_octet is Name : constant PolyORB.Types.String := PolyORB.Types.To_PolyORB_String ("IDL_AT_Sequence_4_octet"); Id : constant PolyORB.Types.String := PolyORB.Types.To_PolyORB_String ("IDL:DNS/IDL_AT_Sequence_4_octet:1.0"); begin if not IDL_AT_Sequence_4_octet_Initialized then IDL_AT_Sequence_4_octet_Initialized := True; Helper.Internals.Initialize_IDL_SEQUENCE_4_octet; TC_IDL_AT_Sequence_4_octet := PolyORB.Any.TypeCode.TC_Alias; Any.TypeCode.Add_Parameter (TC_IDL_AT_Sequence_4_octet, Any.To_Any (Name)); Any.TypeCode.Add_Parameter (TC_IDL_AT_Sequence_4_octet, Any.To_Any (Id)); Any.TypeCode.Add_Parameter (TC_IDL_AT_Sequence_4_octet, Any.To_Any (TC_IDL_SEQUENCE_4_octet)); Any.TypeCode.Disable_Reference_Counting (Any.TypeCode.Object_Of (TC_IDL_AT_Sequence_4_octet).all); end if; end Initialize_IDL_AT_Sequence_4_octet; --------------------------- -- Get_Aggregate_Element -- --------------------------- function Get_Aggregate_Element (Acc : not null access Content_RR_Data; Tc : PolyORB.Any.TypeCode.Object_Ptr; Index : PolyORB.Types.Unsigned_Long; Mech : not null access PolyORB.Any.Mechanism) return PolyORB.Any.Content'Class is use type PolyORB.Types.Unsigned_Long; use type PolyORB.Any.Mechanism; pragma Suppress (Validity_Check); pragma Unreferenced (Tc); begin if Index = 0 then Mech.all := PolyORB.Any.By_Value; Acc.Switch_Cache := Acc.V.Switch; return Helper.Internals.Wrap (Acc.Switch_Cache'Unrestricted_Access); else pragma Assert ((Index = 1)); Mech.all := PolyORB.Any.By_Reference; case Acc.V.Switch is when SRV => return Helper.Internals.Wrap (Acc.V.srv_data'Unrestricted_Access); when A => return Helper.Internals.Wrap (IDL_SEQUENCE_4_octet.Sequence (Acc.V.a_address)'Unrestricted_Access); pragma Warnings (Off); when others => return PolyORB.Any.Wrap (Acc.V.rr_answer'Unrestricted_Access); pragma Warnings (On); end case; end if; end Get_Aggregate_Element; --------------------------- -- Set_Aggregate_Element -- --------------------------- procedure Set_Aggregate_Element (Acc : in out Content_RR_Data; Tc : PolyORB.Any.TypeCode.Object_Ptr; Index : PolyORB.Types.Unsigned_Long; From_C : in out PolyORB.Any.Any_Container'Class) is use type PolyORB.Types.Unsigned_Long; pragma Assert ((Index = 0)); New_Switch : constant RR_Type := Helper.Internals.From_Any (From_C); New_Union : RR_Data (Switch => New_Switch); -- Use default initialization pragma Warnings (Off, New_Union); pragma Suppress (Discriminant_Check); pragma Unreferenced (Tc); begin Acc.V.all := New_Union; end Set_Aggregate_Element; ------------------------- -- Get_Aggregate_Count -- ------------------------- function Get_Aggregate_Count (Acc : Content_RR_Data) return PolyORB.Types.Unsigned_Long is pragma Unreferenced (Acc); begin return 2; end Get_Aggregate_Count; ------------------------- -- Set_Aggregate_Count -- ------------------------- procedure Set_Aggregate_Count (Acc : in out Content_RR_Data; Count : PolyORB.Types.Unsigned_Long) is begin null; end Set_Aggregate_Count; --------------------- -- Unchecked_Get_V -- --------------------- function Unchecked_Get_V (Acc : not null access Content_RR_Data) return PolyORB.Types.Address is function To_Address is new Ada.Unchecked_Conversion (Ptr_RR_Data, PolyORB.Types.Address); begin return To_Address (Acc.V); end Unchecked_Get_V; ----------- -- Clone -- ----------- function Clone (Acc : Content_RR_Data; Into : PolyORB.Any.Content_Ptr := null) return PolyORB.Any.Content_Ptr is use type PolyORB.Any.Content_Ptr; Target : PolyORB.Any.Content_Ptr; pragma Suppress (Discriminant_Check); begin if Into /= null then if Into.all not in Content_RR_Data then return null; end if; Target := Into; Content_RR_Data (Target.all).V.all := Acc.V.all; else Target := new Content_RR_Data; Content_RR_Data (Target.all).V := new RR_Data' (Acc.V.all); end if; Content_RR_Data (Target.all).Switch_Cache := Acc.Switch_Cache; return Target; end Clone; -------------------- -- Finalize_Value -- -------------------- procedure Finalize_Value (Acc : in out Content_RR_Data) is procedure Free is new Ada.Unchecked_Deallocation (RR_Data, Ptr_RR_Data); begin Free (Acc.V); end Finalize_Value; ---------- -- Wrap -- ---------- function Wrap (X : access RR_Data) return PolyORB.Any.Content'Class is begin return Content_RR_Data' (PolyORB.Any.Aggregate_Content with V => Ptr_RR_Data (X), Switch_Cache => X.Switch); end Wrap; RR_Data_Initialized : PolyORB.Types.Boolean := False; ------------------------ -- Initialize_RR_Data -- ------------------------ procedure Initialize_RR_Data is Name : constant PolyORB.Types.String := PolyORB.Types.To_PolyORB_String ("RR_Data"); Id : constant PolyORB.Types.String := PolyORB.Types.To_PolyORB_String ("IDL:DNS/RR_Data:1.0"); Argument_Name_srv_data : constant PolyORB.Types.String := PolyORB.Types.To_PolyORB_String ("srv_data"); Argument_Name_a_address : constant PolyORB.Types.String := PolyORB.Types.To_PolyORB_String ("a_address"); Argument_Name_rr_answer : constant PolyORB.Types.String := PolyORB.Types.To_PolyORB_String ("rr_answer"); begin if not RR_Data_Initialized then RR_Data_Initialized := True; Helper.TC_RR_Data := PolyORB.Any.TypeCode.TC_Union; PolyORB.Any.TypeCode.Add_Parameter (TC_RR_Data, PolyORB.Any.To_Any (Name)); PolyORB.Any.TypeCode.Add_Parameter (TC_RR_Data, PolyORB.Any.To_Any (Id)); Helper.Internals.Initialize_RR_Type; PolyORB.Any.TypeCode.Add_Parameter (TC_RR_Data, PolyORB.Any.To_Any (Helper.TC_RR_Type)); Helper.Internals.Initialize_SRV_Data; Helper.Internals.Initialize_IDL_AT_Sequence_4_octet; PolyORB.Any.TypeCode.Add_Parameter (TC_RR_Data, PolyORB.Any.To_Any (PolyORB.Types.Long (2))); PolyORB.Any.TypeCode.Add_Parameter (TC_RR_Data, Helper.To_Any (RR_Type' (SRV))); PolyORB.Any.TypeCode.Add_Parameter (TC_RR_Data, PolyORB.Any.To_Any (Helper.TC_SRV_Data)); PolyORB.Any.TypeCode.Add_Parameter (TC_RR_Data, PolyORB.Any.To_Any (Argument_Name_srv_data)); PolyORB.Any.TypeCode.Add_Parameter (TC_RR_Data, Helper.To_Any (RR_Type' (A))); PolyORB.Any.TypeCode.Add_Parameter (TC_RR_Data, PolyORB.Any.To_Any (Helper.TC_IDL_AT_Sequence_4_octet)); PolyORB.Any.TypeCode.Add_Parameter (TC_RR_Data, PolyORB.Any.To_Any (Argument_Name_a_address)); PolyORB.Any.TypeCode.Add_Parameter (TC_RR_Data, Helper.To_Any (RR_Type'First)); PolyORB.Any.TypeCode.Add_Parameter (TC_RR_Data, PolyORB.Any.To_Any (PolyORB.Any.TC_String)); PolyORB.Any.TypeCode.Add_Parameter (TC_RR_Data, PolyORB.Any.To_Any (Argument_Name_rr_answer)); Any.TypeCode.Disable_Reference_Counting (Any.TypeCode.Object_Of (TC_RR_Data).all); end if; end Initialize_RR_Data; --------------------------- -- Get_Aggregate_Element -- --------------------------- function Get_Aggregate_Element (Acc : not null access Content_RR; Tc : PolyORB.Any.TypeCode.Object_Ptr; Index : PolyORB.Types.Unsigned_Long; Mech : not null access PolyORB.Any.Mechanism) return PolyORB.Any.Content'Class is use type PolyORB.Types.Unsigned_Long; use type PolyORB.Any.Mechanism; pragma Suppress (Validity_Check); pragma Unreferenced (Tc); begin Mech.all := PolyORB.Any.By_Reference; case Index is when 0 => return PolyORB.Any.Wrap (Acc.V.rr_name'Unrestricted_Access); when 1 => return Helper.Internals.Wrap (Acc.V.rr_type'Unrestricted_Access); when 2 => return PolyORB.Any.Wrap (Acc.V.TTL'Unrestricted_Access); when 3 => return PolyORB.Any.Wrap (Acc.V.data_length'Unrestricted_Access); when 4 => return Helper.Internals.Wrap (Acc.V.rr_data'Unrestricted_Access); pragma Warnings (Off); when others => raise Constraint_Error; pragma Warnings (On); end case; end Get_Aggregate_Element; ------------------------- -- Get_Aggregate_Count -- ------------------------- function Get_Aggregate_Count (Acc : Content_RR) return PolyORB.Types.Unsigned_Long is pragma Unreferenced (Acc); begin return 5; end Get_Aggregate_Count; ------------------------- -- Set_Aggregate_Count -- ------------------------- procedure Set_Aggregate_Count (Acc : in out Content_RR; Count : PolyORB.Types.Unsigned_Long) is begin null; end Set_Aggregate_Count; --------------------- -- Unchecked_Get_V -- --------------------- function Unchecked_Get_V (Acc : not null access Content_RR) return PolyORB.Types.Address is function To_Address is new Ada.Unchecked_Conversion (Ptr_RR, PolyORB.Types.Address); begin return To_Address (Acc.V); end Unchecked_Get_V; ----------- -- Clone -- ----------- function Clone (Acc : Content_RR; Into : PolyORB.Any.Content_Ptr := null) return PolyORB.Any.Content_Ptr is use type PolyORB.Any.Content_Ptr; Target : PolyORB.Any.Content_Ptr; begin if Into /= null then if Into.all not in Content_RR then return null; end if; Target := Into; Content_RR (Target.all).V.all := Acc.V.all; else Target := new Content_RR; Content_RR (Target.all).V := new RR' (Acc.V.all); end if; return Target; end Clone; -------------------- -- Finalize_Value -- -------------------- procedure Finalize_Value (Acc : in out Content_RR) is procedure Free is new Ada.Unchecked_Deallocation (RR, Ptr_RR); begin Free (Acc.V); end Finalize_Value; ---------- -- Wrap -- ---------- function Wrap (X : access RR) return PolyORB.Any.Content'Class is begin return Content_RR' (PolyORB.Any.Aggregate_Content with V => Ptr_RR (X)); end Wrap; RR_Initialized : PolyORB.Types.Boolean := False; ------------------- -- Initialize_RR -- ------------------- procedure Initialize_RR is Name : constant PolyORB.Types.String := PolyORB.Types.To_PolyORB_String ("RR"); Id : constant PolyORB.Types.String := PolyORB.Types.To_PolyORB_String ("IDL:DNS/RR:1.0"); Argument_Name_rr_name : constant PolyORB.Types.String := PolyORB.Types.To_PolyORB_String ("rr_name"); Argument_Name_rr_type : constant PolyORB.Types.String := PolyORB.Types.To_PolyORB_String ("rr_type"); Argument_Name_TTL : constant PolyORB.Types.String := PolyORB.Types.To_PolyORB_String ("TTL"); Argument_Name_data_length : constant PolyORB.Types.String := PolyORB.Types.To_PolyORB_String ("data_length"); Argument_Name_rr_data : constant PolyORB.Types.String := PolyORB.Types.To_PolyORB_String ("rr_data"); begin if not RR_Initialized then RR_Initialized := True; Helper.TC_RR := PolyORB.Any.TypeCode.TC_Struct; PolyORB.Any.TypeCode.Add_Parameter (TC_RR, PolyORB.Any.To_Any (Name)); PolyORB.Any.TypeCode.Add_Parameter (TC_RR, PolyORB.Any.To_Any (Id)); PolyORB.Any.TypeCode.Add_Parameter (TC_RR, PolyORB.Any.To_Any (PolyORB.Any.TC_String)); PolyORB.Any.TypeCode.Add_Parameter (TC_RR, PolyORB.Any.To_Any (Argument_Name_rr_name)); Helper.Internals.Initialize_RR_Type; PolyORB.Any.TypeCode.Add_Parameter (TC_RR, PolyORB.Any.To_Any (Helper.TC_RR_Type)); PolyORB.Any.TypeCode.Add_Parameter (TC_RR, PolyORB.Any.To_Any (Argument_Name_rr_type)); PolyORB.Any.TypeCode.Add_Parameter (TC_RR, PolyORB.Any.To_Any (PolyORB.Any.TC_Unsigned_Long)); PolyORB.Any.TypeCode.Add_Parameter (TC_RR, PolyORB.Any.To_Any (Argument_Name_TTL)); PolyORB.Any.TypeCode.Add_Parameter (TC_RR, PolyORB.Any.To_Any (PolyORB.Any.TC_Unsigned_Short)); PolyORB.Any.TypeCode.Add_Parameter (TC_RR, PolyORB.Any.To_Any (Argument_Name_data_length)); Helper.Internals.Initialize_RR_Data; PolyORB.Any.TypeCode.Add_Parameter (TC_RR, PolyORB.Any.To_Any (Helper.TC_RR_Data)); PolyORB.Any.TypeCode.Add_Parameter (TC_RR, PolyORB.Any.To_Any (Argument_Name_rr_data)); Any.TypeCode.Disable_Reference_Counting (Any.TypeCode.Object_Of (TC_RR).all); end if; end Initialize_RR; -------------- -- From_Any -- -------------- function From_Any (C : PolyORB.Any.Any_Container'Class) return Rcode is begin return Rcode'Val (PolyORB.Types.Unsigned_Long' (PolyORB.Any.Get_Aggregate_Element (C, 0))); end From_Any; --------------------------- -- Get_Aggregate_Element -- --------------------------- function Get_Aggregate_Element (Acc : not null access Content_Rcode; Tc : PolyORB.Any.TypeCode.Object_Ptr; Index : PolyORB.Types.Unsigned_Long; Mech : not null access PolyORB.Any.Mechanism) return PolyORB.Any.Content'Class is use type PolyORB.Types.Unsigned_Long; use type PolyORB.Any.Mechanism; pragma Suppress (Validity_Check); pragma Unreferenced (Tc, Index); begin Acc.Repr_Cache := Rcode'Pos (Acc.V.all); Mech.all := PolyORB.Any.By_Value; return PolyORB.Any.Wrap (Acc.Repr_Cache'Unrestricted_Access); end Get_Aggregate_Element; --------------------------- -- Set_Aggregate_Element -- --------------------------- procedure Set_Aggregate_Element (Acc : in out Content_Rcode; Tc : PolyORB.Any.TypeCode.Object_Ptr; Index : PolyORB.Types.Unsigned_Long; From_C : in out PolyORB.Any.Any_Container'Class) is use type PolyORB.Types.Unsigned_Long; pragma Assert ((Index = 0)); pragma Unreferenced (Tc); begin Acc.V.all := Rcode'Val (PolyORB.Types.Unsigned_Long' (PolyORB.Any.From_Any (From_C))); end Set_Aggregate_Element; ------------------------- -- Get_Aggregate_Count -- ------------------------- function Get_Aggregate_Count (Acc : Content_Rcode) return PolyORB.Types.Unsigned_Long is pragma Unreferenced (Acc); begin return 1; end Get_Aggregate_Count; ------------------------- -- Set_Aggregate_Count -- ------------------------- procedure Set_Aggregate_Count (Acc : in out Content_Rcode; Count : PolyORB.Types.Unsigned_Long) is begin null; end Set_Aggregate_Count; --------------------- -- Unchecked_Get_V -- --------------------- function Unchecked_Get_V (Acc : not null access Content_Rcode) return PolyORB.Types.Address is function To_Address is new Ada.Unchecked_Conversion (Ptr_Rcode, PolyORB.Types.Address); begin return To_Address (Acc.V); end Unchecked_Get_V; ----------- -- Clone -- ----------- function Clone (Acc : Content_Rcode; Into : PolyORB.Any.Content_Ptr := null) return PolyORB.Any.Content_Ptr is use type PolyORB.Any.Content_Ptr; Target : PolyORB.Any.Content_Ptr; begin if Into /= null then if Into.all not in Content_Rcode then return null; end if; Target := Into; Content_Rcode (Target.all).V.all := Acc.V.all; else Target := new Content_Rcode; Content_Rcode (Target.all).V := new Rcode' (Acc.V.all); end if; Content_Rcode (Target.all).Repr_Cache := Acc.Repr_Cache; return Target; end Clone; -------------------- -- Finalize_Value -- -------------------- procedure Finalize_Value (Acc : in out Content_Rcode) is procedure Free is new Ada.Unchecked_Deallocation (Rcode, Ptr_Rcode); begin Free (Acc.V); end Finalize_Value; ---------- -- Wrap -- ---------- function Wrap (X : access Rcode) return PolyORB.Any.Content'Class is begin return Content_Rcode' (PolyORB.Any.Aggregate_Content with V => Ptr_Rcode (X), Repr_Cache => 0); end Wrap; Rcode_Initialized : PolyORB.Types.Boolean := False; ---------------------- -- Initialize_Rcode -- ---------------------- procedure Initialize_Rcode is Name : constant PolyORB.Types.String := PolyORB.Types.To_PolyORB_String ("Rcode"); Id : constant PolyORB.Types.String := PolyORB.Types.To_PolyORB_String ("IDL:DNS/Rcode:1.0"); No_Error_Name : constant PolyORB.Types.String := PolyORB.Types.To_PolyORB_String ("No_Error"); Format_Error_Name : constant PolyORB.Types.String := PolyORB.Types.To_PolyORB_String ("Format_Error"); Server_Failure_Name : constant PolyORB.Types.String := PolyORB.Types.To_PolyORB_String ("Server_Failure"); Name_Error_Name : constant PolyORB.Types.String := PolyORB.Types.To_PolyORB_String ("Name_Error"); Not_Implemented_Name : constant PolyORB.Types.String := PolyORB.Types.To_PolyORB_String ("Not_Implemented"); Refused_Name : constant PolyORB.Types.String := PolyORB.Types.To_PolyORB_String ("Refused"); YX_Domain_Name : constant PolyORB.Types.String := PolyORB.Types.To_PolyORB_String ("YX_Domain"); YX_RRSet_Name : constant PolyORB.Types.String := PolyORB.Types.To_PolyORB_String ("YX_RRSet"); NX_RRSet_Name : constant PolyORB.Types.String := PolyORB.Types.To_PolyORB_String ("NX_RRSet"); Not_Auth_Name : constant PolyORB.Types.String := PolyORB.Types.To_PolyORB_String ("Not_Auth"); Not_Zone_Name : constant PolyORB.Types.String := PolyORB.Types.To_PolyORB_String ("Not_Zone"); begin if not Rcode_Initialized then Rcode_Initialized := True; Helper.TC_Rcode := PolyORB.Any.TypeCode.TC_Enum; PolyORB.Any.TypeCode.Add_Parameter (TC_Rcode, PolyORB.Any.To_Any (Name)); PolyORB.Any.TypeCode.Add_Parameter (TC_Rcode, PolyORB.Any.To_Any (Id)); PolyORB.Any.TypeCode.Add_Parameter (TC_Rcode, PolyORB.Any.To_Any (No_Error_Name)); PolyORB.Any.TypeCode.Add_Parameter (TC_Rcode, PolyORB.Any.To_Any (Format_Error_Name)); PolyORB.Any.TypeCode.Add_Parameter (TC_Rcode, PolyORB.Any.To_Any (Server_Failure_Name)); PolyORB.Any.TypeCode.Add_Parameter (TC_Rcode, PolyORB.Any.To_Any (Name_Error_Name)); PolyORB.Any.TypeCode.Add_Parameter (TC_Rcode, PolyORB.Any.To_Any (Not_Implemented_Name)); PolyORB.Any.TypeCode.Add_Parameter (TC_Rcode, PolyORB.Any.To_Any (Refused_Name)); PolyORB.Any.TypeCode.Add_Parameter (TC_Rcode, PolyORB.Any.To_Any (YX_Domain_Name)); PolyORB.Any.TypeCode.Add_Parameter (TC_Rcode, PolyORB.Any.To_Any (YX_RRSet_Name)); PolyORB.Any.TypeCode.Add_Parameter (TC_Rcode, PolyORB.Any.To_Any (NX_RRSet_Name)); PolyORB.Any.TypeCode.Add_Parameter (TC_Rcode, PolyORB.Any.To_Any (Not_Auth_Name)); PolyORB.Any.TypeCode.Add_Parameter (TC_Rcode, PolyORB.Any.To_Any (Not_Zone_Name)); Any.TypeCode.Disable_Reference_Counting (Any.TypeCode.Object_Of (TC_Rcode).all); end if; end Initialize_Rcode; -------------------------------------- -- IDL_SEQUENCE_DNS_RR_Element_Wrap -- -------------------------------------- function IDL_SEQUENCE_DNS_RR_Element_Wrap (X : access RR) return PolyORB.Any.Content'Class is begin return Helper.Internals.Wrap (X.all'Unrestricted_Access); end IDL_SEQUENCE_DNS_RR_Element_Wrap; function Wrap (X : access IDL_SEQUENCE_DNS_RR.Sequence) return PolyORB.Any.Content'Class renames IDL_SEQUENCE_DNS_RR_Helper.Wrap; IDL_SEQUENCE_DNS_RR_Initialized : PolyORB.Types.Boolean := False; ------------------------------------ -- Initialize_IDL_SEQUENCE_DNS_RR -- ------------------------------------ procedure Initialize_IDL_SEQUENCE_DNS_RR is begin if not IDL_SEQUENCE_DNS_RR_Initialized then IDL_SEQUENCE_DNS_RR_Initialized := True; Helper.Internals.Initialize_RR; Helper.TC_IDL_SEQUENCE_DNS_RR := PolyORB.Any.TypeCode.Build_Sequence_TC (Helper.TC_RR, 0); Any.TypeCode.Disable_Reference_Counting (Any.TypeCode.Object_Of (TC_IDL_SEQUENCE_DNS_RR).all); IDL_SEQUENCE_DNS_RR_Helper.Initialize (Element_TC => Helper.TC_RR, Sequence_TC => Helper.TC_IDL_SEQUENCE_DNS_RR); end if; end Initialize_IDL_SEQUENCE_DNS_RR; rrSequence_Initialized : PolyORB.Types.Boolean := False; --------------------------- -- Initialize_rrSequence -- --------------------------- procedure Initialize_rrSequence is Name : constant PolyORB.Types.String := PolyORB.Types.To_PolyORB_String ("rrSequence"); Id : constant PolyORB.Types.String := PolyORB.Types.To_PolyORB_String ("IDL:DNS/rrSequence:1.0"); begin if not rrSequence_Initialized then rrSequence_Initialized := True; Helper.Internals.Initialize_IDL_SEQUENCE_DNS_RR; TC_rrSequence := PolyORB.Any.TypeCode.TC_Alias; Any.TypeCode.Add_Parameter (TC_rrSequence, Any.To_Any (Name)); Any.TypeCode.Add_Parameter (TC_rrSequence, Any.To_Any (Id)); Any.TypeCode.Add_Parameter (TC_rrSequence, Any.To_Any (TC_IDL_SEQUENCE_DNS_RR)); Any.TypeCode.Disable_Reference_Counting (Any.TypeCode.Object_Of (TC_rrSequence).all); end if; end Initialize_rrSequence; end Internals; -------------- -- From_Any -- -------------- function From_Any (Item : PolyORB.Any.Any) return RR_Type is begin return Helper.Internals.From_Any (PolyORB.Any.Get_Container (Item).all); end From_Any; ------------ -- To_Any -- ------------ function To_Any (Item : RR_Type) return PolyORB.Any.Any is Result : PolyORB.Any.Any := PolyORB.Any.Get_Empty_Any_Aggregate (TC_RR_Type); begin PolyORB.Any.Add_Aggregate_Element (Result, PolyORB.Any.To_Any (PolyORB.Types.Unsigned_Long (RR_Type'Pos (Item)))); return Result; end To_Any; -------------- -- From_Any -- -------------- function From_Any (Item : PolyORB.Any.Any) return SRV_Data is begin return (priority => PolyORB.Any.From_Any (PolyORB.Any.Get_Aggregate_Element (Item, PolyORB.Any.TC_Unsigned_Short, 0)), weight => PolyORB.Any.From_Any (PolyORB.Any.Get_Aggregate_Element (Item, PolyORB.Any.TC_Unsigned_Short, 1)), port => PolyORB.Any.From_Any (PolyORB.Any.Get_Aggregate_Element (Item, PolyORB.Any.TC_Unsigned_Short, 2)), target => PolyORB.Any.From_Any (PolyORB.Any.Get_Aggregate_Element (Item, PolyORB.Any.TC_String, 3))); end From_Any; ------------ -- To_Any -- ------------ function To_Any (Item : SRV_Data) return PolyORB.Any.Any is Result : PolyORB.Any.Any := PolyORB.Any.Get_Empty_Any_Aggregate (TC_SRV_Data); begin PolyORB.Any.Add_Aggregate_Element (Result, PolyORB.Any.To_Any (Item.priority)); PolyORB.Any.Add_Aggregate_Element (Result, PolyORB.Any.To_Any (Item.weight)); PolyORB.Any.Add_Aggregate_Element (Result, PolyORB.Any.To_Any (Item.port)); PolyORB.Any.Add_Aggregate_Element (Result, PolyORB.Any.To_Any (Item.target)); return Result; end To_Any; function From_Any (Item : PolyORB.Any.Any) return IDL_SEQUENCE_4_octet.Sequence renames Helper.Internals.IDL_SEQUENCE_4_octet_Helper.From_Any; function To_Any (Item : IDL_SEQUENCE_4_octet.Sequence) return PolyORB.Any.Any renames Helper.Internals.IDL_SEQUENCE_4_octet_Helper.To_Any; -------------- -- From_Any -- -------------- function From_Any (Item : PolyORB.Any.Any) return IDL_AT_Sequence_4_octet is Result : constant IDL_SEQUENCE_4_octet.Sequence := Helper.From_Any (Item); begin return IDL_AT_Sequence_4_octet (Result); end From_Any; ------------ -- To_Any -- ------------ function To_Any (Item : IDL_AT_Sequence_4_octet) return PolyORB.Any.Any is Result : PolyORB.Any.Any := To_Any (IDL_SEQUENCE_4_octet.Sequence (Item)); begin PolyORB.Any.Set_Type (Result, TC_IDL_AT_Sequence_4_octet); return Result; end To_Any; -------------- -- From_Any -- -------------- function From_Any (Item : PolyORB.Any.Any) return RR_Data is Label_Any : constant PolyORB.Any.Any := PolyORB.Any.Get_Aggregate_Element (Item, Helper.TC_RR_Type, PolyORB.Types.Unsigned_Long (0)); Label : constant RR_Type := Helper.From_Any (Label_Any); Result : RR_Data (Label); Index : PolyORB.Any.Any; begin case Label is when SRV => Index := PolyORB.Any.Get_Aggregate_Element (Item, Helper.TC_SRV_Data, PolyORB.Types.Unsigned_Long (1)); Result.srv_data := Helper.From_Any (Index); when A => Index := PolyORB.Any.Get_Aggregate_Element (Item, Helper.TC_IDL_AT_Sequence_4_octet, PolyORB.Types.Unsigned_Long (1)); Result.a_address := Helper.From_Any (Index); pragma Warnings (Off); when others => Index := PolyORB.Any.Get_Aggregate_Element (Item, PolyORB.Any.TC_String, PolyORB.Types.Unsigned_Long (1)); Result.rr_answer := PolyORB.Any.From_Any (Index); pragma Warnings (On); end case; return Result; end From_Any; ------------ -- To_Any -- ------------ function To_Any (Item : RR_Data) return PolyORB.Any.Any is Result : PolyORB.Any.Any := PolyORB.Any.Get_Empty_Any_Aggregate (Helper.TC_RR_Data); begin PolyORB.Any.Add_Aggregate_Element (Result, Helper.To_Any (Item.Switch)); case Item.Switch is when SRV => PolyORB.Any.Add_Aggregate_Element (Result, Helper.To_Any (Item.srv_data)); when A => PolyORB.Any.Add_Aggregate_Element (Result, Helper.To_Any (Item.a_address)); pragma Warnings (Off); when others => PolyORB.Any.Add_Aggregate_Element (Result, PolyORB.Any.To_Any (Item.rr_answer)); pragma Warnings (On); end case; return Result; end To_Any; -------------- -- From_Any -- -------------- function From_Any (Item : PolyORB.Any.Any) return RR is begin return (rr_name => PolyORB.Any.From_Any (PolyORB.Any.Get_Aggregate_Element (Item, PolyORB.Any.TC_String, 0)), rr_type => Helper.From_Any (PolyORB.Any.Get_Aggregate_Element (Item, Helper.TC_RR_Type, 1)), TTL => PolyORB.Any.From_Any (PolyORB.Any.Get_Aggregate_Element (Item, PolyORB.Any.TC_Unsigned_Long, 2)), data_length => PolyORB.Any.From_Any (PolyORB.Any.Get_Aggregate_Element (Item, PolyORB.Any.TC_Unsigned_Short, 3)), rr_data => Helper.From_Any (PolyORB.Any.Get_Aggregate_Element (Item, Helper.TC_RR_Data, 4))); end From_Any; ------------ -- To_Any -- ------------ function To_Any (Item : RR) return PolyORB.Any.Any is Result : PolyORB.Any.Any := PolyORB.Any.Get_Empty_Any_Aggregate (TC_RR); begin PolyORB.Any.Add_Aggregate_Element (Result, PolyORB.Any.To_Any (Item.rr_name)); PolyORB.Any.Add_Aggregate_Element (Result, Helper.To_Any (Item.rr_type)); PolyORB.Any.Add_Aggregate_Element (Result, PolyORB.Any.To_Any (Item.TTL)); PolyORB.Any.Add_Aggregate_Element (Result, PolyORB.Any.To_Any (Item.data_length)); PolyORB.Any.Add_Aggregate_Element (Result, Helper.To_Any (Item.rr_data)); return Result; end To_Any; -------------- -- From_Any -- -------------- function From_Any (Item : PolyORB.Any.Any) return Rcode is begin pragma Debug (C, O ("entering from any")); return Helper.Internals.From_Any (PolyORB.Any.Get_Container (Item).all); end From_Any; ------------ -- To_Any -- ------------ function To_Any (Item : Rcode) return PolyORB.Any.Any is Result : PolyORB.Any.Any := PolyORB.Any.Get_Empty_Any_Aggregate (TC_Rcode); begin PolyORB.Any.Add_Aggregate_Element (Result, PolyORB.Any.To_Any (PolyORB.Types.Unsigned_Long (Rcode'Pos (Item)))); return Result; end To_Any; function From_Any (Item : PolyORB.Any.Any) return IDL_SEQUENCE_DNS_RR.Sequence renames Helper.Internals.IDL_SEQUENCE_DNS_RR_Helper.From_Any; function To_Any (Item : IDL_SEQUENCE_DNS_RR.Sequence) return PolyORB.Any.Any renames Helper.Internals.IDL_SEQUENCE_DNS_RR_Helper.To_Any; -------------- -- From_Any -- -------------- function From_Any (Item : PolyORB.Any.Any) return rrSequence is Result : constant IDL_SEQUENCE_DNS_RR.Sequence := Helper.From_Any (Item); begin return rrSequence (Result); end From_Any; ------------ -- To_Any -- ------------ function To_Any (Item : rrSequence) return PolyORB.Any.Any is Result : PolyORB.Any.Any := Helper.To_Any (IDL_SEQUENCE_DNS_RR.Sequence (Item)); begin PolyORB.Any.Set_Type (Result, TC_rrSequence); return Result; end To_Any; ----------------------------- -- Deferred_Initialization -- ----------------------------- procedure Deferred_Initialization; procedure Deferred_Initialization is begin mDNS.Helper.Internals.Initialize_RR_Type; mDNS.Helper.Internals.Initialize_SRV_Data; mDNS.Helper.Internals.Initialize_IDL_SEQUENCE_4_octet; mDNS.Helper.Internals.Initialize_IDL_AT_Sequence_4_octet; mDNS.Helper.Internals.Initialize_RR_Data; mDNS.Helper.Internals.Initialize_RR; mDNS.Helper.Internals.Initialize_Rcode; mDNS.Helper.Internals.Initialize_IDL_SEQUENCE_DNS_RR; mDNS.Helper.Internals.Initialize_rrSequence; end Deferred_Initialization; use PolyORB.Initialization; use PolyORB.Initialization.String_Lists; use PolyORB.Utils.Strings; begin pragma Debug (C, O ("Registering Module DNS-Helper")); Register_Module (Module_Info' (Name => +"PolyORB.DSA_P.Name_Service.mDNS.helper", Conflicts => Empty, Depends => Empty, Provides => Empty, Implicit => False, Init => Deferred_Initialization'Access, Shutdown => null)); end PolyORB.DSA_P.Name_Service.mDNS.Helper; polyorb-2.8~20110207.orig/src/dsa/polyorb-dsa_p-storages-config.adb0000644000175000017500000000454711750740340024264 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . D S A _ P . S T O R A G E S . C O N F I G -- -- -- -- B o d y -- -- -- -- Copyright (C) 2008, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- Dummy placeholder body, replaced by a partition-specific one by the -- partitioning tool. package body PolyORB.DSA_P.Storages.Config is ------------------------- -- Initialyze_Storages -- ------------------------- procedure Initialize_Storages is begin null; end Initialize_Storages; end PolyORB.DSA_P.Storages.Config; polyorb-2.8~20110207.orig/src/dsa/polyorb-poa_config-racws.ads0000644000175000017500000000462311750740340023343 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . P O A _ C O N F I G . R A C W S -- -- -- -- S p e c -- -- -- -- Copyright (C) 2002-2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- A POA configuration for RACW-objects-subPOAs. with PolyORB.POA_Config.Proxies; package PolyORB.POA_Config.RACWs is pragma Elaborate_Body; type RACWs_Configuration is new Configuration_Type with private; RACW_POA_Config : PolyORB.POA_Config.Configuration_Access; private type RACWs_Configuration is new Proxies.Configuration with null record; end PolyORB.POA_Config.RACWs; polyorb-2.8~20110207.orig/src/dsa/polyorb-dsa_p-name_service-mdns-client.ads0000644000175000017500000000743411750740340026064 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- POLYORB.DSA_P.NAME_SERVICE.MDNS.CLIENT -- -- -- -- S p e c -- -- -- -- Copyright (C) 2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- This package implements the mDNS request invocation procedure, when a -- partition is looking up a remote package's informations with PolyORB.References; with PolyORB.DSA_P.Name_Service.mDNS.Helper; package PolyORB.DSA_P.Name_Service.mDNS.Client is function Resolve (The_Ref : PolyORB.References.Ref; Name : String; Kind : String) return PolyORB.References.Ref; -- The Resolve function is responsible for construction a Question RR from -- a Name and Kind of a package and invoking the Query procedure. Upon -- reception of the result, it constructs a PolyORB.References.Ref -- representing the remote reference and returns it to the -- Nameserver_Lookup function. procedure Query (Self : PolyORB.References.Ref; Authoritative : in out PolyORB.Types.Boolean; Question : PolyORB.DSA_P.Name_Service.mDNS.Helper.rrSequence; Answer : out PolyORB.DSA_P.Name_Service.mDNS.Helper.rrSequence; Authority : out PolyORB.DSA_P.Name_Service.mDNS.Helper.rrSequence; Additional : out PolyORB.DSA_P.Name_Service.mDNS.Helper.rrSequence; Returns : out PolyORB.DSA_P.Name_Service.mDNS.Helper.Rcode); -- The Query procedure is responsible for contructing a request from the -- IN Question argument and invoking it. It retrieves the OUT results and -- stores them in the Answer/Authority/Additional rr sequences, as well as -- the DNS Rcode associated. private procedure Parse_TXT_Record (Answer_RR : PolyORB.Types.String; Str_Ref : out PolyORB.Types.String; Version_id : out PolyORB.Types.String); -- Extract the stringified reference and the version of the package -- from the TXT record. end PolyORB.DSA_P.Name_Service.mDNS.Client; polyorb-2.8~20110207.orig/src/dsa/polyorb-qos-term_manager_info.ads0000644000175000017500000000761011750740340024375 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . Q O S . T E R M _ M A N A G E R _ I N F O -- -- -- -- S p e c -- -- -- -- Copyright (C) 2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- This package is in charge of processing DSA_TM_Info service contexts. -- DSA_TM_Info service contexts are used by clients to pass to the servers a -- reference to their termination manager. When a request is received on the -- server side, the function Extract_TM_Info is called. This function extracts -- the reference from the QoS parameter and stores it in the requestor Binding -- Object notepad. Later on, the termination manager will retrieve this -- reference to reach the client's termination manager. with PolyORB.Annotations; with PolyORB.References; with PolyORB.Requests; with PolyORB.Tasking.Mutexes; package PolyORB.QoS.Term_Manager_Info is pragma Elaborate_Body; type QoS_DSA_TM_Info_Parameter is new QoS_Parameter (DSA_TM_Info) with record TM_Ref : References.Ref; end record; -- The QoS parameter type associated with TM_Info service contexts type QoS_DSA_TM_Info_Parameter_Access is access all QoS_DSA_TM_Info_Parameter; type BO_Note is new Annotations.Note with record TM_Ref : References.Ref; -- TM_Ref is a reference to the Termination Manager of the node the BO -- containing this type of note links to. end record; -- This type of note is used to store the Reference extracted from the -- service context into a Binding Object. Default_BO_Note : constant BO_Note := (PolyORB.Annotations.Note with TM_Ref => References.Nil_Ref); procedure Extract_TM_Info (R : access PolyORB.Requests.Request); -- Extracts the Transaction Manager Info from request R procedure Enter_BO_Note_Lock; -- Take the lock ensuring integrity of the BO_Notes procedure Leave_BO_Note_Lock; -- Release the lock ensuring integrity of the BO_Notes private Lock : PolyORB.Tasking.Mutexes.Mutex_Access; -- The lock ensuring integrity of BO_Notes procedure Initialize; end PolyORB.QoS.Term_Manager_Info; polyorb-2.8~20110207.orig/src/dsa/polyorb-dsa_p-conversions.ads0000644000175000017500000000623211750740340023554 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . D S A _ P . C O N V E R S I O N S -- -- -- -- S p e c -- -- -- -- Copyright (C) 2008, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- This unit gathers unchecked conversions used in dsa personality. with Ada.Unchecked_Conversion; with PolyORB.Any; -- WAG:601 -- pragma Warnings (Off) with pattern not supported in that compiler version -- so use plain pragma Warnings (Off/On) instead. -- pragma Warnings (Off, "* is an internal GNAT unit"); -- pragma Warnings (Off, "use of this unit is non-portable*"); pragma Warnings (Off); with System.DSA_Types; pragma Warnings (On); package PolyORB.DSA_P.Conversions is pragma Warnings (Off); -- No strict aliasing issues, since System.DSA_Types.Any_Container_Ptr -- is a dummy type and it only ever used in the context of unchecked -- conversions from and to PolyORB.Any.Any_Container_Ptr. function DAC_To_AC is new Ada.Unchecked_Conversion (System.DSA_Types.Any_Container_Ptr, PolyORB.Any.Any_Container_Ptr); -- Convert Any_Container_Ptr DSA type to PolyORB one function AC_To_DAC is new Ada.Unchecked_Conversion (PolyORB.Any.Any_Container_Ptr, System.DSA_Types.Any_Container_Ptr); -- Convert Any_Container_Ptr PolyORB type to DSA one pragma Warnings (On); end PolyORB.DSA_P.Conversions; polyorb-2.8~20110207.orig/src/dsa/polyorb-dsa_p-storages-dfs.adb0000644000175000017500000003232611750740340023567 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . D S A _ P . S T O R A G E S . D F S -- -- -- -- B o d y -- -- -- -- Copyright (C) 2008-2009, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with Ada.IO_Exceptions; with Ada.Unchecked_Conversion; with System; -- WAG:601 -- pragma Warnings (Off) with pattern not supported in that compiler version -- so use plain pragma Warnings (Off/On) instead. -- pragma Warnings (Off, "* is an internal GNAT unit"); -- pragma Warnings (Off, "use of this unit is non-portable*"); pragma Warnings (Off); with System.File_IO; with System.File_Control_Block; pragma Warnings (On); with PolyORB.Log; with PolyORB.Buffers; with PolyORB.Representations; with PolyORB.DSA_P.Conversions; with PolyORB.Errors; with PolyORB.Setup; package body PolyORB.DSA_P.Storages.DFS is package IOX renames Ada.IO_Exceptions; package FCB renames System.File_Control_Block; package SFI renames System.File_IO; use Ada.Streams; use PolyORB.Log; use PolyORB.Buffers; use PolyORB.Representations; use PolyORB.DSA_P.Conversions; use PolyORB.Errors; use PolyORB.Any; use type SIO.File_Mode; use type System.Global_Locks.Lock_Type; LRU_Head : DFS_Manager_Access; LRU_Tail : DFS_Manager_Access; Critical_Section : Mutex_Access; -- Global critical section type Request_Type is (Read, Write, Lock); ---------------------------------------------- -- Variables for Shared Memory Access Files -- ---------------------------------------------- Max_Shared_Files_Open : constant := 20; -- Maximum number of lock files that can be open Shared_Files_Open : Natural := 0; -- Number of shared memory access files currently open Endianness : constant Endianness_Type := Big_Endian; -- Endianness for stream representation To_File_Mode : constant array (Read .. Write) of SIO.File_Mode := (Read => SIO.In_File, Write => SIO.Out_File); procedure Initiate_Request (Var_Data : access DFS_Manager_Type; Request : Request_Type; Success : out Boolean); -- Initiate an operation on a variable. This routine can be thread -- blocking in order to serialize several concurrent requests and -- should be protected against abortion. Success returns whether -- the request can be performed on the variable. Typically, if -- there is no storage available on a read operation, Success is -- set to False. Any exception must be caught inside the -- routine. Note also that primitives Read and Write must catch -- all the potential exceptions. procedure Complete_Request (Var_Data : access DFS_Manager_Type); -- Complete the request previously initiated by the routine above. function Lock_Name (Var_Data : DFS_Manager_Type) return String; ------------- -- Logging -- ------------- package L is new Log.Facility_Log ("polyorb.dsa_p.storages.dfs"); procedure O (Message : Standard.String; Level : Log_Level := Debug) renames L.Output; function C (Level : Log_Level := Debug) return Boolean renames L.Enabled; -------------------------- -- Unchecked_Conversion -- -------------------------- function To_AFCB_Ptr is new Ada.Unchecked_Conversion (SIO.File_Type, FCB.AFCB_Ptr); ------------ -- Create -- ------------ function Create (Manager_Factory : access DFS_Manager_Type; Full_Name : String) return Shared_Data_Manager_RACW is Var : constant DFS_Manager_Access := new DFS_Manager_Type; begin pragma Debug (C, O ("create DFS manager for variable " & Full_Name)); Var.Name := new String'(Full_Name); Var.Self := Var; Var.Count := 0; Var.Dir := Manager_Factory.Dir; Var.Lock := SGL.Null_Lock; Create (Var.Mutex); return Shared_Data_Manager_RACW (Var); end Create; ---------------------- -- Complete_Request -- ---------------------- procedure Complete_Request (Var_Data : access DFS_Manager_Type) is begin if Var_Data.Count > 0 then Var_Data.Count := Var_Data.Count - 1; if Var_Data.Count = 0 then SGL.Release_Lock (Var_Data.Lock); end if; pragma Debug (C, O ("Lock count =" & Var_Data.Count'Img)); end if; end Complete_Request; ---------------------- -- Initiate_Request -- ---------------------- procedure Initiate_Request (Var_Data : access DFS_Manager_Type; Request : Request_Type; Success : out Boolean) is Done : Boolean := True; Free : DFS_Manager_Access; begin case Request is when Read | Write => declare Fname : constant String := Var_Data.Dir.all & Var_Data.Name.all; Fmode : constant SIO.File_Mode := To_File_Mode (Request); begin if not SIO.Is_Open (Var_Data.File) then begin SIO.Open (Var_Data.File, Fmode, Name => Fname); SFI.Make_Unbuffered (To_AFCB_Ptr (Var_Data.File)); pragma Debug (C, O ("Open variable file " & Fname)); exception when IOX.Name_Error => if Request = Read then Done := False; else SIO.Create (Var_Data.File, Fmode, Name => Fname); pragma Debug (C, O ("Create variable file " & Fname)); end if; end; if Done then Enter (Critical_Section); Shared_Files_Open := Shared_Files_Open + 1; if Shared_Files_Open = Max_Shared_Files_Open then Free := LRU_Head; if Free.Next /= null then Free.Next.Prev := null; end if; LRU_Head := Free.Next; Free.Next := null; Free.Prev := null; SIO.Close (Free.File); pragma Debug (C, O ("Close variable file " & Free.Name.all)); end if; -- Add new entry at end of LRU chain if LRU_Head = null then LRU_Head := Var_Data.Self; LRU_Tail := Var_Data.Self; else Var_Data.Prev := LRU_Tail; LRU_Tail.Next := Var_Data.Self; LRU_Tail := Var_Data.Self; end if; Leave (Critical_Section); end if; -- Here if file is already open, set file for reading else if SIO.Mode (Var_Data.File) /= Fmode then pragma Debug (C, O ("Reset variable file " & Var_Data.Name.all & " mode to " & Request'Img)); SIO.Set_Mode (Var_Data.File, Fmode); SFI.Make_Unbuffered (To_AFCB_Ptr (Var_Data.File)); end if; SIO.Set_Index (Var_Data.File, 1); end if; end; when Lock => Var_Data.Count := Var_Data.Count + 1; if Var_Data.Lock = SGL.Null_Lock then SGL.Create_Lock (Var_Data.Lock, Lock_Name (Var_Data.all)); end if; if Var_Data.Count = 1 then SGL.Acquire_Lock (Var_Data.Lock); end if; pragma Debug (C, O ("Lock count =" & Var_Data.Count'Img)); end case; Success := Done; end Initiate_Request; --------------- -- Lock_Name -- --------------- function Lock_Name (Var_Data : DFS_Manager_Type) return String is begin return Var_Data.Dir.all & ".entry"; end Lock_Name; ---------- -- Read -- ---------- procedure Read (Self : access DFS_Manager_Type; Var : SDT.Any_Container_Ptr) is Rep : constant Representation_Access := PolyORB.Setup.Default_Representation; Buffer : Buffer_Access := new Buffer_Type; Success : Boolean; Error : Error_Container; begin Enter (Self.Mutex); Initiate_Request (Self, Read, Success); if not Success then Release (Buffer); Leave (Self.Mutex); return; end if; declare Last : Stream_Element_Offset; Stream : Stream_Element_Array (1 .. Stream_Element_Offset (SIO.Size (Self.File))); begin -- Fill buffer with file data SIO.Read (Self.File, Stream, Last); Initialize_Buffer (Buffer => Buffer, Size => Stream'Last, Data => Stream'Address, Endianness => Endianness, Initial_CDR_Position => 0); -- Unmarshall buffer into Any Unmarshall_To_Any (Rep, Buffer, DAC_To_AC (Var).all, Error); end; Complete_Request (Self); Release (Buffer); Leave (Self.Mutex); end Read; ------------------------------ -- Register_Passive_Package -- ------------------------------ procedure Register_Passive_Package (Pkg_Name : String; Is_Owner : Boolean; Location : String) is pragma Unreferenced (Is_Owner); Factory : constant DFS_Manager_Access := new DFS_Manager_Type; begin pragma Debug (C, O ("Register DFS factory for package " & Pkg_Name)); -- Location is a directory. Add a separator if the location is -- not empty. if Location'Length /= 0 then Factory.Dir := new String'(Location & OS.Directory_Separator); else Factory.Dir := new String'(Location); end if; Register_Factory (Pkg_Name, Shared_Data_Manager_RACW (Factory)); end Register_Passive_Package; ----------- -- Write -- ----------- procedure Write (Self : access DFS_Manager_Type; Var : SDT.Any_Container_Ptr) is Rep : constant Representation_Access := PolyORB.Setup.Default_Representation; Buffer : Buffer_Access := new Buffer_Type; Success : Boolean; Error : Error_Container; begin Enter (Self.Mutex); Initiate_Request (Self, Write, Success); if not Success then Release (Buffer); Leave (Self.Mutex); return; end if; -- Marshall Any into buffer Set_Endianness (Buffer, Endianness); Marshall_From_Any (Rep, Buffer, DAC_To_AC (Var).all, Error); -- Fill file with buffer data declare Stream : constant Stream_Element_Array := To_Stream_Element_Array (Buffer.all); begin SIO.Write (Self.File, Stream); end; Complete_Request (Self); Release (Buffer); Leave (Self.Mutex); end Write; ---------- -- Lock -- ---------- procedure Lock (Self : access DFS_Manager_Type) is Success : Boolean; pragma Unreferenced (Success); begin Enter (Self.Mutex); Initiate_Request (Self, Lock, Success); end Lock; ------------ -- Unlock -- ------------ procedure Unlock (Self : access DFS_Manager_Type) is begin Complete_Request (Self); Leave (Self.Mutex); end Unlock; begin Create (Critical_Section); end PolyORB.DSA_P.Storages.DFS; polyorb-2.8~20110207.orig/src/dsa/s-dsatyp.ads0000644000175000017500000000535511750740340020205 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- S Y S T E M . D S A _ T Y P E S -- -- -- -- S p e c -- -- -- -- Copyright (C) 2008, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with Ada.Streams; package System.DSA_Types is pragma Remote_Types; type Any_Container_Ptr is private; procedure Read (S : access Ada.Streams.Root_Stream_Type'Class; V : out Any_Container_Ptr); procedure Write (S : access Ada.Streams.Root_Stream_Type'Class; V : Any_Container_Ptr); for Any_Container_Ptr'Read use Read; for Any_Container_Ptr'Write use Write; private type Dummy_Any_Container is abstract tagged limited null record; type Any_Container_Ptr is access all Dummy_Any_Container'Class; for Any_Container_Ptr'Storage_Size use 0; -- This access type must never be derefenced, it is meant to be -- unchecked-converted to PolyORB.Any.Any_Container_Ptr. end System.DSA_Types; polyorb-2.8~20110207.orig/src/dsa/polyorb-dsa_p-remote_launch.ads0000644000175000017500000000517211750740340024033 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . D S A _ P . R E M O T E _ L A U N C H -- -- -- -- S p e c -- -- -- -- Copyright (C) 2006-2008, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- This package is in charge of launching the remote partitions when Ada -- starter is used. It is a stripped down version of System.Garlic.Remote in -- the GLADE distribution. package PolyORB.DSA_P.Remote_Launch is procedure Launch_Partition (Host : String; Command : String; Env_Vars : String); -- Launch a partition with Command on Host. This can be configured with -- parameters [dsa]rsh_command and [dsa]rsh_options. Env_Vars is a space- -- separated list of environment variables to pass from the current context -- to the remote partition. end PolyORB.DSA_P.Remote_Launch; polyorb-2.8~20110207.orig/src/dsa/polyorb-poa_config-racws.adb0000644000175000017500000000530711750740340023322 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . P O A _ C O N F I G . R A C W S -- -- -- -- B o d y -- -- -- -- Copyright (C) 2002-2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- A POA configuration for RACW-objects-subPOAs. with PolyORB.Initialization; with PolyORB.Utils.Strings; with PolyORB.Utils.Strings.Lists; package body PolyORB.POA_Config.RACWs is procedure Initialize; procedure Initialize is begin RACW_POA_Config := new RACWs_Configuration; end Initialize; use PolyORB.Initialization; use PolyORB.Utils.Strings; use PolyORB.Utils.Strings.Lists; begin Register_Module (Module_Info' (Name => +"poa_config.racws", Conflicts => Empty, Depends => Empty, Provides => Empty, Implicit => False, Init => Initialize'Access, Shutdown => null)); end PolyORB.POA_Config.RACWs; polyorb-2.8~20110207.orig/src/dsa/polyorb-dsa_p-streams.adb0000644000175000017500000000774411750740340022652 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . D S A _ P . S T R E A M S -- -- -- -- B o d y -- -- -- -- Copyright (C) 2008, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ package body PolyORB.DSA_P.Streams is ----------- -- Reset -- ----------- procedure Reset (This : access Memory_Resident_Stream) is begin This.Count := 0; This.Next_In := 1; This.Next_Out := 1; end Reset; ----------- -- Write -- ----------- procedure Write (This : in out Memory_Resident_Stream; Item : Stream_Element_Array) is begin for K in Item'Range loop This.Values (This.Next_In) := Item (K); This.Next_In := (This.Next_In mod This.Size) + 1; end loop; This.Count := This.Count + Item'Length; end Write; ---------- -- Read -- ---------- procedure Read (This : in out Memory_Resident_Stream; Item : out Stream_Element_Array; Last : out Stream_Element_Offset) is begin if This.Count = 0 then Last := Item'First - 1; return; end if; Last := Item'First; for K in Item'Range loop Item (K) := This.Values (This.Next_Out); This.Next_Out := (This.Next_Out mod This.Size) + 1; This.Count := This.Count - 1; Last := Last + 1; exit when This.Count = 0; end loop; end Read; ------------------- -- Reset_Reading -- ------------------- procedure Reset_Reading (This : access Memory_Resident_Stream) is begin This.Next_Out := 1; end Reset_Reading; ------------------- -- Reset_Writing -- ------------------- procedure Reset_Writing (This : access Memory_Resident_Stream) is begin This.Next_In := 1; end Reset_Writing; ----------- -- Empty -- ----------- function Empty (This : Memory_Resident_Stream) return Boolean is begin return This.Count = 0; end Empty; ------------ -- Extent -- ------------ function Extent (This : Memory_Resident_Stream) return Stream_Element_Count is begin return This.Count; end Extent; end PolyORB.DSA_P.Streams; polyorb-2.8~20110207.orig/src/dsa/polyorb-dsa_p-name_service-mdns.ads0000644000175000017500000000777511750740340024620 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . D S A _ P . N A M E _ S E R V I C E . M D N S -- -- -- -- S p e c -- -- -- -- Copyright (C) 2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- This package implements the multicast DNS unit discovery for DSA with PolyORB.POA_Policies; with PolyORB.References; with PolyORB.Objects; with PolyORB.DSA_P.Name_Service; package PolyORB.DSA_P.Name_Service.mDNS is type MDNS_Name_Context is new PolyORB.DSA_P.Name_Service.Name_Context with null record; -- Concrete mDNS implementation of the abstract Name_Context type procedure Nameserver_Register (Name_Ctx : access MDNS_Name_Context; Name : String; Kind : String; Obj : PolyORB.References.Ref); -- Concrete mDNS implementation of the abstract Nameserver_Register -- procedure. In the context of mDNS this procedure is used on server side -- to populate the mDNS servant's list of local RCI/SP package infos. function Nameserver_Lookup (Context : access MDNS_Name_Context; Name : String; Kind : String; Initial : Boolean := True) return PolyORB.References.Ref; -- Concrete mDNS implementation of the abstract Nameserver_Lookup function -- In the context of mDNS, it is used on the client side to invoke a -- request on the remote mDNS servant. procedure Initialize_MDNS_Policies (My_Default_Policies : out PolyORB.POA_Policies.PolicyList); -- Initialize POA Policies for the MDNS Servant. procedure Initiate_MDNS_Context (MDNS_Reference : String; Context : out PolyORB.DSA_P.Name_Service.Name_Context_Access; Oid : out PolyORB.Objects.Object_Id_Access); -- Initiates the mDNS Name Context by initizalizing the servant object, -- and setting is as a default servant for a newly created child_POA. -- A stringified reference is assigned to Context.Stringified_Reference -- which is used to create the Context.Base_Ref in Nameserver_Lookup function Get_MDNS_Servant return PolyORB.References.Ref; -- Offered to the user, used by the partition main file in order to -- retrieve the default mDNS servant and assign it to the DNS protocol end PolyORB.DSA_P.Name_Service.mDNS; polyorb-2.8~20110207.orig/src/dsa/polyorb-dsa_p-remote_launch.adb0000644000175000017500000002766411750740340024024 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . D S A _ P . R E M O T E _ L A U N C H -- -- -- -- B o d y -- -- -- -- Copyright (C) 2006-2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with Ada.Environment_Variables; with Ada.Strings.Fixed; with Ada.Strings.Unbounded; with Ada.Strings.Maps; with GNAT.Expect; with GNAT.OS_Lib; with PolyORB.Initialization; with PolyORB.Log; with PolyORB.Parameters; with PolyORB.Platform; with PolyORB.Sockets; with PolyORB.Utils.Strings.Lists; package body PolyORB.DSA_P.Remote_Launch is use GNAT.OS_Lib; use PolyORB.Sockets; use PolyORB.Log; use PolyORB.Parameters; package L is new PolyORB.Log.Facility_Log ("polyorb.dsa_p.remote_launch"); procedure O (Message : String; Level : Log_Level := Debug) renames L.Output; function C (Level : Log_Level := Debug) return Boolean renames L.Enabled; function Windows_To_Unix (S : String) return String; -- Translate Windows-style pathnames to Unix-style by changing '\' to '/'. -- ???This is a temporary kludge, but we're assuming the existence of a -- Unix-like shell anyway (see below). The goal is to get tests working -- under Windows using Cygwin. The problem is that Cygwin's 'sh' interprets -- '\' as a Unix escape, rather than as a directory separator. -- This should be made more portable. -- This is a no-op on non-Windows systems. function Escape_Spaces (S : String) return String; -- Protect spaces and shell metacharacters in S with a backslash -- ??? Assumes a UNIX shell procedure Initialize; -- Retrieve rsh command and options from configuration Sh_Command : String_Access; Rsh_Command : String_Access; Rsh_Options : String_Access; Rsh_Args : String_List_Access; ------------------- -- Escape_Spaces -- ------------------- function Escape_Spaces (S : String) return String is R : String (1 .. 2 * S'Length); Last : Natural := 0; begin for J in S'Range loop case S (J) is when ' ' | ASCII.HT | ''' | '"' | '*' | '?' | '|' | '[' | ']' | '(' | ')' | '{' | '}' | '<' | '>' => Last := Last + 1; R (Last) := '\'; when others => null; end case; Last := Last + 1; R (Last) := S (J); end loop; return R (1 .. Last); end Escape_Spaces; ---------------- -- Initialize -- ---------------- procedure Initialize is begin Sh_Command := Locate_Exec_On_Path ("sh"); -- Rsh_Command and Rsh_Options are always provided by gnatdist, so no -- default value is required here. Rsh_Command := Locate_Exec_On_Path (Parameters.Get_Conf (Section => "dsa", Key => "rsh_command", Default => "")); Rsh_Options := new String'(Parameters.Get_Conf (Section => "dsa", Key => "rsh_options", Default => "")); Rsh_Args := Argument_String_To_List (Rsh_Options.all); end Initialize; ------------------- -- Is_Local_Host -- ------------------- function Is_Local_Host (Host : String) return Boolean; -- True if Host designates the local machine and we can avoid a remote -- shell execution. function Is_Local_Host (Host : String) return Boolean is Name_Of_Host : constant String := Official_Name (Get_Host_By_Name (Host)); begin -- If force_rsh is True, never optimize away rsh call if Parameters.Get_Conf (Section => "dsa", Key => "force_rsh", Default => False) then return False; end if; return Host = "localhost" or else Name_Of_Host = "localhost" or else Name_Of_Host = Official_Name (Get_Host_By_Name (Host_Name)); end Is_Local_Host; ---------------------- -- Launch_Partition -- ---------------------- procedure Launch_Partition (Host : String; Command : String; Env_Vars : String) is U_Command : constant String := Escape_Spaces (Windows_To_Unix (Command)) & " --polyorb-dsa-name_service=" & Get_Conf ("dsa", "name_service", ""); Pid : Process_Id; pragma Unreferenced (Pid); Remote_Host : String_Access; begin pragma Debug (C, O ("Launch_Partition: enter")); -- ??? This is implemented assuming a UNIX-like shell on both the master -- and the slave hosts. This should be made more portable. If the -- configuration file specified a shell script for the 'Host, then the -- Host will look like `shell-script blah` (using back-quote notation), -- so we have to strip off the back-quotes, and split it into command -- name and arguments. We're using Argument_String_To_List to split off -- the command name as well, which is also kludgy. if Host (Host'First) = '`' then declare Argv : Argument_List_Access := Argument_String_To_List (Host (Host'First + 1 .. Host'Last - 1)); Command : String renames Argv (Argv'First).all; -- First "argument" found by Argument_String_To_List is the name -- of the shell script. Arguments : constant Argument_List (1 .. Argv'Length - 1) := Argv (2 .. Argv'Last); -- Get_Command_Output requires a 1-based array, so we need to -- slide Arguments. Status : aliased Integer; begin Remote_Host := new String'(GNAT.Expect.Get_Command_Output (Command, Arguments, Input => "", Status => Status'Access)); if Status /= 0 then raise Program_Error with "Unable to launch " & Command; end if; for J in Argv'Range loop Free (Argv (J)); end loop; Free (Argv); end; -- Otherwise (no back-quote), we can just use Host as is. else Remote_Host := new String'(Host); end if; pragma Debug (C, O ("Remote_Host: " & Remote_Host.all)); -- Local spawn if Is_Local_Host (Remote_Host.all) then declare Args : Argument_List := (new String'("-c"), new String'(U_Command)); begin pragma Debug (C, O ("Enter Spawn (local): " & U_Command)); Pid := Non_Blocking_Spawn (Sh_Command.all, Args); for J in Args'Range loop Free (Args (J)); end loop; end; -- Remote spawn else Remote_Spawn : declare function Expand_Env_Vars (Vars : String) return String; -- Given a space separated list of environment variable names, -- return a space separated list of assigments of the form: -- VAR='value'. function Expand_Env_Vars (Vars : String) return String is use Ada.Environment_Variables; use Ada.Strings.Unbounded; First, Last : Integer; Result : Unbounded_String; begin First := Vars'First; loop -- Find first character of name while First <= Env_Vars'Last and then Env_Vars (First) = ' ' loop First := First + 1; end loop; exit when First > Env_Vars'Last; -- Find last character of name Last := First; while Last < Env_Vars'Last and then Env_Vars (Last + 1) /= ' ' loop Last := Last + 1; end loop; declare Var_Name : String renames Vars (First .. Last); begin if Exists (Var_Name) then if Length (Result) = 0 then Result := To_Unbounded_String ("env "); end if; Result := Result & Var_Name & "='" & Value (Var_Name) & "' "; end if; end; First := Last + 1; end loop; return To_String (Result); end Expand_Env_Vars; Remote_Command : String_Access := new String'(Expand_Env_Vars (Env_Vars) & U_Command & " --polyorb-dsa-detach"); -- Start of processing for Remote_Spawn begin pragma Debug (C, O ("Enter Spawn (remote: " & Rsh_Command.all & " " & Rsh_Options.all & Remote_Host.all & "): " & Remote_Command.all)); Pid := Non_Blocking_Spawn (Rsh_Command.all, Remote_Host & Rsh_Args.all & Remote_Command); Free (Remote_Command); end Remote_Spawn; end if; Free (Remote_Host); pragma Debug (C, O ("Launch_Partition: leave")); end Launch_Partition; --------------------- -- Windows_To_Unix -- --------------------- function Windows_To_Unix (S : String) return String is use Ada.Strings.Fixed, Ada.Strings.Maps; begin if Platform.Windows_On_Target then return Translate (S, To_Mapping ("\", "/")); else return S; end if; end Windows_To_Unix; use PolyORB.Initialization; use PolyORB.Utils.Strings; use PolyORB.Utils.Strings.Lists; begin Register_Module (Module_Info' (Name => +"dsa_p.remote_launch", Conflicts => Empty, Depends => Empty, Provides => Empty, Implicit => False, Init => Initialize'Access, Shutdown => null)); end PolyORB.DSA_P.Remote_Launch; polyorb-2.8~20110207.orig/src/dsa/polyorb-dsa_p-name_service-mdns.adb0000644000175000017500000002316211750740340024563 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . D S A _ P . N A M E _ S E R V I C E . M D N S -- -- -- -- B o d y -- -- -- -- Copyright (C) 2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with PolyORB.Any; with PolyORB.Any.NVList; with PolyORB.Log; with PolyORB.Errors; with PolyORB.POA; with PolyORB.Setup; with PolyORB.ORB; with PolyORB.DSA_P.Exceptions; with PolyORB.POA_Policies.Request_Processing_Policy.Use_Default_Servant; with PolyORB.POA_Policies.Servant_Retention_Policy.Retain; with PolyORB.POA_Policies.Id_Assignment_Policy.System; with PolyORB.POA_Policies.Id_Uniqueness_Policy.Multiple; with PolyORB.POA_Policies.Implicit_Activation_Policy.Activation; with PolyORB.POA_Policies.Lifespan_Policy.Persistent; with PolyORB.POA_Manager; with PolyORB.Obj_Adapters; with PolyORB.Minimal_Servant; with PolyORB.Types; with PolyORB.DSA_P.Name_Service.mDNS.Client; with PolyORB.DSA_P.Name_Service.mDNS.Servant; with Ada.Exceptions; with System.RPC; with PolyORB.Tasking.Threads; package body PolyORB.DSA_P.Name_Service.mDNS is use PolyORB.POA_Policies; use PolyORB.Any; use PolyORB.Log; use PolyORB.Any.NVList; use PolyORB.Any.NVList.Internals; use PolyORB.Any.NVList.Internals.NV_Lists; use PolyORB.Types; package L is new PolyORB.Log.Facility_Log ("polyorb.dsa_p.name_service.mdns"); procedure O (Message : String; Level : Log_Level := Debug) renames L.Output; function C (Level : Log_Level := Debug) return Boolean renames L.Enabled; Root_DNS : aliased PolyORB.DSA_P.Name_Service.mDNS.Servant. Object_Ptr; ------------------------------ -- Initialize_MDNS_Policies -- ------------------------------ procedure Initialize_MDNS_Policies (My_Default_Policies : out PolyORB.POA_Policies.PolicyList) is use PolyORB.POA_Policies.Policy_Lists; begin Append (My_Default_Policies, Policy_Access (Request_Processing_Policy.Use_Default_Servant.Create)); Append (My_Default_Policies, Policy_Access (Servant_Retention_Policy.Retain.Create)); Append (My_Default_Policies, Policy_Access (Id_Assignment_Policy.System.Create)); Append (My_Default_Policies, Policy_Access (Id_Uniqueness_Policy.Multiple.Create)); Append (My_Default_Policies, Policy_Access (Implicit_Activation_Policy.Activation.Create)); Append (My_Default_Policies, Policy_Access (Lifespan_Policy.Persistent.Create)); end Initialize_MDNS_Policies; ------------------------- -- Nameserver_Register -- ------------------------- procedure Nameserver_Register (Name_Ctx : access MDNS_Name_Context; Name : String; Kind : String; Obj : PolyORB.References.Ref) is use PolyORB.DSA_P.Name_Service.mDNS.Servant; use PolyORB.References; pragma Unreferenced (Name_Ctx); Version : PolyORB.Types.String; begin pragma Debug (C, O ("About to register " & Name & " on mDNS servant")); -- In this block we retrieve the Version Id of the package declare Type_Id : constant String := Type_Id_Of (Obj); Last_Colon : Integer; begin for C in reverse Type_Id'Range loop if Type_Id (C) = ':' then Last_Colon := C; exit; end if; end loop; Version := To_PolyORB_String (Type_Id (Last_Colon + 1 .. Type_Id'Last)); end; -- We register it within the mDNS default servant Append_Entry_To_Context (PolyORB.Types.To_PolyORB_String (Name), PolyORB.Types.To_PolyORB_String (Kind), Version, Obj); end Nameserver_Register; function Nameserver_Lookup (Context : access MDNS_Name_Context; Name : String; Kind : String; Initial : Boolean := True) return PolyORB.References.Ref is use PolyORB.Errors; Result : PolyORB.References.Ref; Retry_Count : Natural := 0; begin pragma Debug (C, O ("Nameserver_Lookup (" & Name & "." & Kind & "): enter")); -- Invoke the Resolve procedure which calls the remote object -- constructs a local reference as a result and returns it. loop begin -- Unit not known yet, we therefore know that it is remote, and we -- need to look it up with the mDNS naming service. -- We create the remote reference from the stringified Ref PolyORB.References.String_To_Object (Types.To_Standard_String (Context.Stringified_Ref), Context.Base_Ref); if References.Is_Nil (Context.Base_Ref) then raise Constraint_Error; end if; Result := PolyORB.DSA_P.Name_Service.mDNS.Client.Resolve (Context.Base_Ref, Name, Kind); if not Is_Reference_Valid (Result) then PolyORB.References.Release (Result); end if; exception -- Catch all exceptions: we will retry resolution, and bail -- out after Max_Requests iterations. when E : others => pragma Debug (C, O ("retry" & Retry_Count'Img & " got " & Ada.Exceptions.Exception_Information (E))); PolyORB.References.Release (Result); end; exit when not (Initial and then PolyORB.References.Is_Nil (Result)); -- Resolve succeeded, or just trying to refresh a stale ref: -- exit loop. if Retry_Count = Max_Requests then raise System.RPC.Communication_Error with "lookup of " & Kind & " " & Name & " failed"; end if; Retry_Count := Retry_Count + 1; PolyORB.Tasking.Threads.Relative_Delay (Time_Between_Requests); end loop; pragma Debug (C, O ("Nameserver_Lookup (" & Name & "." & Kind & "): leave")); return Result; end Nameserver_Lookup; procedure Initiate_MDNS_Context (MDNS_Reference : String; Context : out PolyORB.DSA_P.Name_Service.Name_Context_Access; Oid : out PolyORB.Objects.Object_Id_Access) is use PolyORB.Errors; use PolyORB.POA; use PolyORB.DSA_P.Name_Service.mDNS.Servant; use PolyORB.ORB; use PolyORB.POA_Manager; use type PolyORB.Obj_Adapters.Obj_Adapter_Access; pragma Warnings (Off, Context); Root_POA : constant POA.Obj_Adapter_Access := POA.Obj_Adapter_Access (Object_Adapter (PolyORB.Setup.The_ORB)); DNS_POA : POA.Obj_Adapter_Access; Policies : PolyORB.POA_Policies.PolicyList; Error : Error_Container; begin pragma Assert (Context /= null); Initialize_MDNS_Policies (Policies); Root_DNS := new PolyORB.DSA_P.Name_Service.mDNS.Servant.Object; Create_POA (Root_POA, "DNS_POA", A_POAManager => null, Policies => Policies, POA => DNS_POA, Error => Error); Set_Servant (DNS_POA, Minimal_Servant.To_PolyORB_Servant (PolyORB.Minimal_Servant.Servant_Acc (Root_DNS)), Error); Servant_To_Id (DNS_POA, DNS_POA.Default_Servant, Oid, Error); Context.Stringified_Ref := Types.To_PolyORB_String (MDNS_Reference & PolyORB.Objects.Oid_To_Hex_String (Oid.all)); Activate (POAManager_Access (PolyORB.POA_Manager.Entity_Of (DNS_POA.POA_Manager)), Error); if Found (Error) then PolyORB.DSA_P.Exceptions.Raise_From_Error (Error); end if; pragma Debug (C, O ("Leaving")); end Initiate_MDNS_Context; function Get_MDNS_Servant return PolyORB.References.Ref is begin return PolyORB.DSA_P.Name_Service.Get_Name_Context.Base_Ref; end Get_MDNS_Servant; end PolyORB.DSA_P.Name_Service.mDNS; polyorb-2.8~20110207.orig/src/dsa/polyorb-dsa_p-partitions.adb0000644000175000017500000001137511750740340023363 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . D S A _ P . P A R T I T I O N S -- -- -- -- B o d y -- -- -- -- Copyright (C) 2002-2009, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with PolyORB.Log; with PolyORB.Tasking.Mutexes; with System.Partition_Interface; with System.RPC; package body PolyORB.DSA_P.Partitions is use PolyORB.Log; use PolyORB.Tasking.Mutexes; package L is new PolyORB.Log.Facility_Log ("polyorb.dsa_p.partitions"); procedure O (Message : String; Level : Log_Level := Debug) renames L.Output; function C (Level : Log_Level := Debug) return Boolean renames L.Enabled; Partitions_Mutex : Mutex_Access; Next_Partition_ID : Integer := 1; -- ID to be assigned to the next requesting partition. Note that we start -- at 1 because the value 0 is reserved to denote the unset (initial) state -- of System.Standard_Library.Local_Parition_ID. function Elaborate return Boolean; -- Initialize the Partitions_Mutex and set the local partition ID. -- See comment at end of this unit for explanation of why a function -- is required. --------------------------- -- Allocate_Partition_ID -- --------------------------- function Allocate_Partition_ID (Name : String) return Integer is Current_Partition_ID : Integer; begin Enter (Partitions_Mutex); Current_Partition_ID := Next_Partition_ID; Next_Partition_ID := Next_Partition_ID + 1; Leave (Partitions_Mutex); pragma Debug (C, O ("Assigned partition id" & Integer'Image (Current_Partition_ID) & " to " & Name)); return Current_Partition_ID; end Allocate_Partition_ID; --------------- -- Elaborate -- --------------- function Elaborate return Boolean is use System.Partition_Interface; begin Create (Partitions_Mutex); -- We set the partition Id of the main partition here to avoid a -- possible race condition. Set_Local_Partition_ID (System.RPC.Partition_ID (Allocate_Partition_ID (Get_Local_Partition_Name & " (main partition)"))); return True; end Elaborate; -------------------------------------------- -- Initialization of the Partitions_Mutex -- -------------------------------------------- -- We need the mutex to be initialized, and the local partition ID to be -- set, before this package is registered. Otherwise, if we perform these -- steps in the elaboration statements of this packge, then there is -- a tiny, but non-zero, vulnerability window where we can service RPCs -- without having initialized the mutex (because the registration is -- performed before the elaboration statements are executed). Dummy : constant Boolean := Elaborate; pragma Unreferenced (Dummy); -- Dummy value declared only for the sake of evaluating the side effects -- of Elaborate. end PolyORB.DSA_P.Partitions; polyorb-2.8~20110207.orig/src/dsa/polyorb-partition_elaboration.ads0000644000175000017500000000754711750740340024522 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . P A R T I T I O N _ E L A B O R A T I O N -- -- -- -- S p e c -- -- -- -- Copyright (C) 2006-2009, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ pragma Ada_2005; pragma Warnings (Off); with PolyORB.Exceptions; pragma Elaborate_All (PolyORB.Exceptions); with PolyORB.DSA_P.Exceptions; pragma Elaborate_All (PolyORB.DSA_P.Exceptions); with PolyORB.Initialization; pragma Elaborate_All (PolyORB.Initialization); with PolyORB.Log; pragma Elaborate_All (PolyORB.Log); with PolyORB.Parameters; pragma Elaborate_All (PolyORB.Parameters); with PolyORB.ORB; pragma Elaborate_All (PolyORB.ORB); with PolyORB.ORB_Controller.Workers; pragma Elaborate_All (PolyORB.ORB_Controller.Workers); with PolyORB.POA; pragma Elaborate_All (PolyORB.POA); with PolyORB.QoS; pragma Elaborate_All (PolyORB.QoS); with PolyORB.QoS.Term_Manager_Info; pragma Elaborate_All (PolyORB.QoS.Term_Manager_Info); with PolyORB.Services.Naming; pragma Elaborate_All (PolyORB.Services.Naming); with PolyORB.Services.Naming.Helper; pragma Elaborate_All (PolyORB.Services.Naming.Helper); with PolyORB.Services.Naming.NamingContext.Client; pragma Elaborate_All (PolyORB.Services.Naming.NamingContext.Client); with PolyORB.Setup.OA.Basic_POA; pragma Elaborate_All (PolyORB.Setup.OA.Basic_POA); with PolyORB.Termination_Activity; pragma Elaborate_All (PolyORB.Termination_Activity); package PolyORB.Partition_Elaboration is pragma Elaborate_Body; procedure Configure (Set_Conf : access procedure (Section, Key, Value : String)); -- Set various runtime configuration parameters using the provided callback procedure Full_Launch; -- Launch the slave partitions when using Ada Starter procedure Run_Additional_Tasks; -- Run needed additional tasks according to selected -- ORB tasking policy. -- The body of this package provides further partition-specific -- dependencies that are guaranteed to be elaborated before PCS -- initialization, in addition to the Full_Launch starter. end PolyORB.Partition_Elaboration; polyorb-2.8~20110207.orig/src/dsa/s-dsatyp.adb0000644000175000017500000000515111750740340020156 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- S Y S T E M . D S A _ T Y P E S -- -- -- -- B o d y -- -- -- -- Copyright (C) 2008, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ package body System.DSA_Types is ---------- -- Read -- ---------- procedure Read (S : access Ada.Streams.Root_Stream_Type'Class; V : out Any_Container_Ptr) is begin raise Program_Error with "System.DSA_Types.Any_Container_Ptr'Read should not be called"; end Read; ----------- -- Write -- ----------- procedure Write (S : access Ada.Streams.Root_Stream_Type'Class; V : Any_Container_Ptr) is begin raise Program_Error with "System.DSA_Types.Any_Container_Ptr'Write should not be called"; end Write; end System.DSA_Types; polyorb-2.8~20110207.orig/src/dsa/s-parint.ads0000644000175000017500000006615011750740340020176 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- S Y S T E M . P A R T I T I O N _ I N T E R F A C E -- -- -- -- S p e c -- -- -- -- Copyright (C) 2004-2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- This is the version of System.Partition_Interface for PolyORB. -- It shares part of its spec with the GLADE version and the GNAT RTL version. pragma Warnings (Off); with PolyORB.Partition_Elaboration; pragma Elaborate_All (PolyORB.Partition_Elaboration); pragma Warnings (On); with Ada.Exceptions; with Ada.Streams; with Ada.Strings.Unbounded; with Ada.Tags; with PolyORB.Any; with PolyORB.Any.ExceptionList; with PolyORB.Any.NVList; with PolyORB.Any.ObjRef; with PolyORB.Buffers; with PolyORB.Components; with PolyORB.Initialization; with PolyORB.Objects; with PolyORB.Obj_Adapters; with PolyORB.References; with PolyORB.Requests; with PolyORB.Servants; with PolyORB.Smart_Pointers; with PolyORB.Types; with PolyORB.Utils.Strings; with System.DSA_Types; with System.RPC; with System.Unsigned_Types; package System.Partition_Interface is pragma Elaborate_Body; type DSA_Implementation_Name is (No_DSA, GARLIC_DSA, PolyORB_DSA); DSA_Implementation : constant DSA_Implementation_Name := PolyORB_DSA; -- Identification of this DSA implementation variant PCS_Version : constant := 4; -- Version of the PCS API (for Exp_Dist consistency check). -- This version number is matched against Gnatvsn.PCS_Version_Number to -- ensure that the versions of Exp_Dist and the PCS are consistent. package DSAT renames System.DSA_Types; type Subprogram_Id is new Natural; -- This type is used exclusively by stubs subtype Unit_Name is String; -- Name of Ada units subtype Object_Ref is PolyORB.References.Ref; subtype Entity_Ptr is PolyORB.Smart_Pointers.Entity_Ptr; procedure Raise_Program_Error_Unknown_Tag (E : Ada.Exceptions.Exception_Occurrence); pragma No_Return (Raise_Program_Error_Unknown_Tag); -- Raise Program_Error with the same message as E one function Get_Active_Partition_ID (Name : Unit_Name) return RPC.Partition_ID; -- Get the Partition_ID of the partition where unit Name resides function Get_Local_Partition_Name return String; -- Return the name of the current partition function Get_Local_Partition_ID return RPC.Partition_ID; -- Return the Partition_ID of the current partition procedure Set_Local_Partition_ID (PID : RPC.Partition_ID); -- Set the Partition_ID of the current partition function Local_PID_Allocated return Boolean; pragma Inline (Local_PID_Allocated); -- True once the local partition ID is known --------------------------------------- -- Remote access-to-subprogram types -- --------------------------------------- type RAS_Proxy_Type is tagged limited record All_Calls_Remote : Boolean; Target : Entity_Ptr; Subp_Id : Subprogram_Id := 0; -- This component is unused for PolyORB (it is used only for the GARLIC -- implementation of RAS.) end record; type RAS_Proxy_Type_Access is access RAS_Proxy_Type; -- This type is used by the expansion to implement distributed objects. -- Do not change its definition or its layout without updating -- Exp_Dist.Build_Remote_Subprogram_Proxy_Type. procedure Get_RAS_Info (Pkg_Name : String; Subprogram_Name : String; Subp_Ref : out Object_Ref); -- Return the RAS object reference associated with the named subprogram. ----------------------------- -- Remote Call Interfaces -- ----------------------------- -- Receiving stubs contain a table of all subprograms exported by the unit. type RCI_Subp_Info is record Name : System.Address; Name_Length : Integer; -- Subprogram distribution identifier Addr : System.Address; -- Local address of the proxy object end record; type RCI_Subp_Info_Array is array (Integer range <>) of RCI_Subp_Info; subtype Request is PolyORB.Requests.Request; subtype Request_Access is PolyORB.Requests.Request_Access; generic RCI_Name : String; Version : String; pragma Unreferenced (Version); -- Not used anymore, kept to avoid compiler API change package RCI_Locator is function Get_RCI_Package_Ref return Object_Ref; end RCI_Locator; -- Calling stubs need a cache of the object reference associated with each -- RCI unit. procedure Check (Name : Unit_Name; Version : String; RCI : Boolean := True); -- Use by the main subprogram to check that a remote receiver unit has has -- the same version than the caller's one. -------------------------- -- RPC receiver objects -- -------------------------- -- One RPC receiver is created for each supported interface, i.e. one for -- each RCI library unit, and one for each type that is the designated type -- of one or more RACW type. function Caseless_String_Eq (S1, S2 : String) return Boolean; -- Case-less equality of S1 and S2 type Request_Handler_Access is access procedure (R : Request_Access); type Private_Info is private; type Servant is new PolyORB.Servants.Servant with record Handler : Request_Handler_Access; -- The dispatching routine. Object_Adapter : PolyORB.Obj_Adapters.Obj_Adapter_Access; -- Null for RCI servants (the root POA will be used in this case) Obj_TypeCode : PolyORB.Any.TypeCode.Local_Ref; -- The TypeCode to be used for references to objects of this type Impl_Info : aliased Private_Info; end record; type Servant_Access is access all Servant'Class; type Receiving_Stub_Kind is (Obj_Stub, Pkg_Stub); procedure Register_Obj_Receiving_Stub (Name : String; Handler : Request_Handler_Access; Receiver : Servant_Access); -- Register Receiver as the RPC servant for distributed objects of type -- Name, at elaboration time. procedure Register_Pkg_Receiving_Stub (Name : String; Version : String; Handler : Request_Handler_Access; Receiver : Servant_Access; Subp_Info : System.Address; Subp_Info_Len : Integer; Is_All_Calls_Remote : Boolean); -- Register the fact that the Name receiving stub is now elaborated. -- Register the access value to the package RPC_Receiver procedure. -- Subp_Info is the address of an array of a statically constrained subtype -- of RCI_Subp_Info_Array with a range of 0 .. Subp_Info_Len - 1. function Find_Receiving_Stub (Name : String; Kind : Receiving_Stub_Kind) return Servant_Access; -- Return the servant for distributed objects with given Name and Kind, or -- null if non-existant. procedure Activate_RPC_Receivers; -- Start processing incoming remote calls --------------------------------- -- Remote Access to Class Wide -- --------------------------------- type RACW_Stub_Type is tagged limited record Target : Entity_Ptr; -- Target cannot be a References.Ref (a controlled type) because that -- would pollute RACW_Stub_Type's dispatch table (which must be exactly -- identical to that of the designated tagged type). Target must be a -- pointer to References.Reference_Info. Asynchronous : Boolean; end record; type RACW_Stub_Type_Access is access all RACW_Stub_Type; -- This type is used by the expansion to implement distributed objects. -- Do not change its definition or its layout without updating Exp_Dist -- accordingly. function Same_Partition (Left : access RACW_Stub_Type; Right : access RACW_Stub_Type) return Boolean; -- Determine whether Left and Right correspond to objects instantiated -- on the same partition, for enforcement of E.4(19). -------------------------------------------- -- Support for RACWs as object references -- -------------------------------------------- procedure Inc_Usage (E : PolyORB.Smart_Pointers.Entity_Ptr) renames PolyORB.Smart_Pointers.Inc_Usage; -- In stubs for remote objects, the object reference information is stored -- as a naked Entity_Ptr. We therefore need to account for this reference -- by hand. procedure Set_Ref (The_Ref : in out PolyORB.References.Ref; The_Entity : PolyORB.Smart_Pointers.Entity_Ptr) renames PolyORB.References.Set; function Make_Ref (The_Entity : PolyORB.Smart_Pointers.Entity_Ptr) return PolyORB.References.Ref; function Entity_Of (R : PolyORB.References.Ref) return PolyORB.Smart_Pointers.Entity_Ptr renames PolyORB.References.Entity_Of; -- Conversion from Entity_Ptr to Ref and reverse procedure Get_Unique_Remote_Pointer (Handler : in out RACW_Stub_Type_Access); -- Get a unique pointer on a remote object. On entry, Handler is expected -- to be a pointer to a local variable of any stub type compatible with -- RACW_Stub_Type; on exit, it is a pointer to a variable allocated on the -- heap (either a newly allocated instance, or a previous existing instance -- for the same remote object). Note that newly-allocated stubs are always -- of type RACW_Stub_Type, so a tag fixup is required afterwards. function To_PolyORB_String (S : String) return PolyORB.Types.Identifier renames PolyORB.Types.To_PolyORB_String; function Is_Nil (R : PolyORB.References.Ref) return Boolean renames PolyORB.References.Is_Nil; procedure Get_Local_Address (Ref : PolyORB.References.Ref; Is_Local : out Boolean; Addr : out System.Address); -- If Ref denotes a local object, Is_Local is set to True, and Addr is set -- to the object's actual address, else Is_Local is set to False and Addr -- is set to Null_Address. function Get_Reference (RACW : System.Address; Type_Name : String; Stub_Tag : Ada.Tags.Tag; Is_RAS : Boolean; Receiver : access Servant) return PolyORB.References.Ref; -- Create a reference from an RACW value with designated type Type_Name. -- Stub_Tag is the tag of the associated stub type. Is_RAS is True if the -- RACW is implementing a remote access-to-subprogram type. -- Receiver is the associated servant. procedure Build_Local_Reference (Addr : System.Address; Typ : String; Receiver : access Servant; Ref : out PolyORB.References.Ref); -- Create a reference that can be used to designate the local object whose -- address is Addr, whose type is the designated type of a RACW type -- associated with Servant. function Get_RACW (Ref : PolyORB.References.Ref; Stub_Tag : Ada.Tags.Tag; Is_RAS : Boolean; Asynchronous : Boolean) return System.Address; -- From an object reference, create a remote access-to-classwide value -- designating the same object. Is_RAS indicates whether the RACW is -- implementing a remote access-to-subprogram type. -- The returned address is either the address of a local object, or the -- address of a stub object having the given tag if the designated object -- is remote. For a nil ref, a null address is returned. If All_Calls_ -- Remote is True, the address of a stub object is returned even if the -- reference is local. ------------------------------ -- Any and associated types -- ------------------------------ package PATC renames PolyORB.Any.TypeCode; subtype Identifier is PolyORB.Types.Identifier; Result_Name : constant Identifier := PolyORB.Types.To_PolyORB_String ("Result"); subtype Any is PolyORB.Any.Any; Mode_In : PolyORB.Any.Flags renames PolyORB.Any.ARG_IN; Mode_Out : PolyORB.Any.Flags renames PolyORB.Any.ARG_OUT; Mode_Inout : PolyORB.Any.Flags renames PolyORB.Any.ARG_INOUT; subtype NamedValue is PolyORB.Any.NamedValue; subtype TypeCode is PolyORB.Any.TypeCode.Local_Ref; procedure Set_TC (A : in out Any; T : PATC.Local_Ref) renames PolyORB.Any.Set_Type; function Get_TC (A : Any) return PATC.Local_Ref; function Create_Any (TC : PATC.Local_Ref) return Any; -- Same as PolyORB.Any.Get_Empty_Any_Aggregate, except for the case where -- TC is a sequence typecode, in which case an Any using the -- specific shadow content type for such sequences is returned instead of -- a Default_Aggregate_Content (Any_To_BS relies on this property). function Content_Type (Self : PATC.Local_Ref) return PATC.Local_Ref renames PATC.Content_Type; function Any_Member_Type (A : Any; Index : System.Unsigned_Types.Long_Unsigned) return PATC.Local_Ref; -- Return type of the Index'th component in Tk_Struct or Tk_Union Any A subtype NVList_Ref is PolyORB.Any.NVList.Ref; procedure NVList_Create (NVList : out PolyORB.Any.NVList.Ref) renames PolyORB.Any.NVList.Create; procedure NVList_Add_Item (Self : PolyORB.Any.NVList.Ref; Item_Name : PolyORB.Types.Identifier; Item : Any; Item_Flags : PolyORB.Any.Flags) renames PolyORB.Any.NVList.Add_Item; ----------------------------------------------- -- Elementary From_Any and To_Any operations -- ----------------------------------------------- subtype Unsigned is System.Unsigned_Types.Unsigned; subtype Long_Unsigned is System.Unsigned_Types.Long_Unsigned; subtype Long_Long_Unsigned is System.Unsigned_Types.Long_Long_Unsigned; subtype Short_Unsigned is System.Unsigned_Types.Short_Unsigned; subtype Short_Short_Unsigned is System.Unsigned_Types.Short_Short_Unsigned; -- function FA_AD (Item : Any) return X; -- function FA_AS (Item : Any) return X; function FA_A (Item : Any) return DSAT.Any_Container_Ptr; function FA_B (Item : Any) return Boolean; function FA_C (Item : Any) return Character; function FA_F (Item : Any) return Float; function FA_I (Item : Any) return Integer; function FA_U (Item : Any) return Unsigned; function FA_LF (Item : Any) return Long_Float; function FA_LI (Item : Any) return Long_Integer; function FA_LU (Item : Any) return Long_Unsigned; function FA_LLF (Item : Any) return Long_Long_Float; function FA_LLI (Item : Any) return Long_Long_Integer; function FA_LLU (Item : Any) return Long_Long_Unsigned; function FA_SF (Item : Any) return Short_Float; function FA_SI (Item : Any) return Short_Integer; function FA_SU (Item : Any) return Short_Unsigned; function FA_SSI (Item : Any) return Short_Short_Integer; function FA_SSU (Item : Any) return Short_Short_Unsigned; function FA_WC (Item : Any) return Wide_Character; function FA_String (Item : Any) return Ada.Strings.Unbounded.Unbounded_String; function FA_ObjRef (Item : Any) return PolyORB.References.Ref renames PolyORB.Any.ObjRef.From_Any; function TA_A (Item : DSAT.Any_Container_Ptr) return Any; function TA_B (Item : Boolean) return Any; function TA_C (Item : Character) return Any; function TA_F (Item : Float) return Any; function TA_I (Item : Integer) return Any; function TA_U (Item : Unsigned) return Any; function TA_LF (Item : Long_Float) return Any; function TA_LI (Item : Long_Integer) return Any; function TA_LU (Item : Long_Unsigned) return Any; function TA_LLF (Item : Long_Long_Float) return Any; function TA_LLI (Item : Long_Long_Integer) return Any; function TA_LLU (Item : Long_Long_Unsigned) return Any; function TA_SF (Item : Short_Float) return Any; function TA_SI (Item : Short_Integer) return Any; function TA_SU (Item : Short_Unsigned) return Any; function TA_SSI (Item : Short_Short_Integer) return Any; function TA_SSU (Item : Short_Short_Unsigned) return Any; function TA_WC (Item : Wide_Character) return Any; function TA_String (S : Ada.Strings.Unbounded.Unbounded_String) return Any; function TA_ObjRef (R : PolyORB.References.Ref) return Any renames PolyORB.Any.ObjRef.To_Any; function TA_Std_String (S : String) return Any; function TA_TC (TC : PATC.Local_Ref) return Any renames PolyORB.Any.To_Any; -- function TC_AD return PATC.Local_Ref -- renames PolyORB.Any.TC_X; -- function TC_AS return PATC.Local_Ref -- renames PolyORB.Any.TC_X; -- The typecodes below define the mapping of Ada elementary types to -- PolyORB types. function TC_A return PATC.Local_Ref renames PolyORB.Any.TC_Any; function TC_B return PATC.Local_Ref renames PolyORB.Any.TC_Boolean; function TC_C return PATC.Local_Ref renames PolyORB.Any.TC_Char; function TC_F return PATC.Local_Ref renames PolyORB.Any.TC_Float; -- Warning! Ada numeric types have platform dependant sizes, PolyORB types -- are fixed size: this mapping may need to be changed for other platforms -- (or the biggest PolyORB type for each Ada type should be selected, if -- cross-platform interoperability is desired. function TC_I return PATC.Local_Ref renames PolyORB.Any.TC_Long; function TC_LF return PATC.Local_Ref renames PolyORB.Any.TC_Double; function TC_LI return PATC.Local_Ref renames PolyORB.Any.TC_Long; function TC_LLF return PATC.Local_Ref renames PolyORB.Any.TC_Long_Double; function TC_LLI return PATC.Local_Ref renames PolyORB.Any.TC_Long_Long; function TC_LLU return PATC.Local_Ref renames PolyORB.Any.TC_Unsigned_Long_Long; function TC_LU return PATC.Local_Ref renames PolyORB.Any.TC_Unsigned_Long; function TC_SF return PATC.Local_Ref renames PolyORB.Any.TC_Float; function TC_SI return PATC.Local_Ref renames PolyORB.Any.TC_Short; function TC_SSI return PATC.Local_Ref renames PolyORB.Any.TC_Short; function TC_SSU return PATC.Local_Ref renames PolyORB.Any.TC_Octet; function TC_SU return PATC.Local_Ref renames PolyORB.Any.TC_Unsigned_Short; function TC_U return PATC.Local_Ref renames PolyORB.Any.TC_Unsigned_Long; function TC_WC return PATC.Local_Ref renames PolyORB.Any.TC_Wchar; function TC_String return PATC.Local_Ref renames PATC.TC_String; function TC_Void return PATC.Local_Ref renames PATC.TC_Void; function TC_Opaque return PATC.Local_Ref; function TC_Alias return PATC.Local_Ref renames PATC.TC_Alias; -- Empty Tk_Alias typecode function TC_Array return PATC.Local_Ref renames PATC.TC_Array; -- Empty Tk_Array typecode function TC_Sequence return PATC.Local_Ref renames PATC.TC_Sequence; -- Empty Tk_Sequence typecode function TC_Struct return PATC.Local_Ref renames PATC.TC_Struct; -- Empty Tk_Struct typecode function TC_Object return PATC.Local_Ref renames PATC.TC_Object; -- Empty Tk_ObjRef typecode function TC_Union return PATC.Local_Ref renames PATC.TC_Union; -- Empty Tk_Union typecode subtype Any_Array is PATC.Any_Array; function TC_Build (Base : PATC.Local_Ref; Parameters : Any_Array) return PATC.Local_Ref; procedure Move_Any_Value (Dest, Src : Any) renames PolyORB.Any.Move_Any_Value; function Any_Aggregate_Build (TypeCode : PATC.Local_Ref; Contents : Any_Array) return Any; procedure Add_Aggregate_Element (Value : in out Any; Element : Any) renames PolyORB.Any.Add_Aggregate_Element; function Get_Aggregate_Element (Value : Any; TC : PATC.Local_Ref; Index : System.Unsigned_Types.Long_Unsigned) return Any; function Get_Any_Type (A : Any) return PATC.Local_Ref renames PolyORB.Any.Get_Type; function Get_Nested_Sequence_Length (Value : Any; Depth : Positive) return Unsigned; -- Return the length of the sequence at nesting level Depth within Value, -- a Tk_Struct any representing an unconstrained array. function Extract_Union_Value (U : Any) return Any; -- Given an Any of a union type, return an Any for the value of the union ----------------------------------------------------------------------- -- Support for opaque data transfer using stream-oriented attributes -- ----------------------------------------------------------------------- type Buffer_Stream_Type is new Ada.Streams.Root_Stream_Type with private; -- A stream based on a PolyORB buffer procedure Read (Stream : in out Buffer_Stream_Type; Item : out Ada.Streams.Stream_Element_Array; Last : out Ada.Streams.Stream_Element_Offset); procedure Write (Stream : in out Buffer_Stream_Type; Item : Ada.Streams.Stream_Element_Array); procedure Any_To_BS (Item : Any; Stream : out Buffer_Stream_Type); procedure BS_To_Any (Stream : Buffer_Stream_Type; Item : out Any); -- Conversion between an Any for an opaque sequence of octets and an Ada -- Stream based on a PolyORB buffer. For Any_To_BS, the lifetime of the -- Stream object shall not exceed that of Item. procedure Release_Buffer (Stream : in out Buffer_Stream_Type); -- Return storage allocated for Stream, needs to be called after any data -- has been written to the buffer. -------------- -- Requests -- -------------- Nil_Exc_List : PolyORB.Any.ExceptionList.Ref renames PolyORB.Any.ExceptionList.Nil_Ref; procedure Request_Setup (Req : out PolyORB.Requests.Request; Target : PolyORB.References.Ref; Operation : String; Arg_List : PolyORB.Any.NVList.Ref; Result : in out PolyORB.Any.NamedValue; Exc_List : PolyORB.Any.ExceptionList.Ref := PolyORB.Any.ExceptionList.Nil_Ref; Req_Flags : PolyORB.Requests.Flags; Deferred_Arguments_Session : PolyORB.Components.Component_Access := null; Identification : PolyORB.Requests.Arguments_Identification := PolyORB.Requests.Ident_By_Position; Dependent_Binding_Object : PolyORB.Smart_Pointers.Entity_Ptr := null ) renames PolyORB.Requests.Setup_Request; procedure Request_Invoke (R : access PolyORB.Requests.Request; Invoke_Flags : PolyORB.Requests.Flags := 0); procedure Request_Arguments (R : PolyORB.Requests.Request_Access; Args : in out PolyORB.Any.NVList.Ref); procedure Request_Set_Out (R : PolyORB.Requests.Request_Access); procedure Set_Result (Self : PolyORB.Requests.Request_Access; Val : Any) renames PolyORB.Requests.Set_Result; Asynchronous_P_To_Sync_Scope : constant array (Boolean) of PolyORB.Requests.Flags := (False => PolyORB.Requests.Sync_With_Target, True => PolyORB.Requests.Sync_With_Transport); -- Request_Flags to use for a request according to whether or not the call -- is asynchronous. procedure Request_Raise_Occurrence (R : Request); -- If R terminated with an exception, raise that exception -- If no exception occurred, do nothing. procedure Register_Termination_Manager (Ref : PolyORB.References.Ref; Oid : PolyORB.Objects.Object_Id_Access; Address : System.Address; Shutdown : PolyORB.Initialization.Finalizer); -- Register the termination manager of the local partition procedure Register_Passive_Package (Name : Unit_Name; Version : String := ""); -- This procedure is unused for PolyORB (it is used only for the GARLIC -- implementation of Shared Passive.) procedure Register_RACW_In_Name_Server (Addr : System.Address; Type_Tag : Ada.Tags.Tag; Name : String; Kind : String); -- Register a RACW in name server. Type_Tag is the name of pointed type. procedure Retrieve_RACW_From_Name_Server (Name : String; Kind : String; Stub_Tag : Ada.Tags.Tag; Addr : out System.Address); -- Retreive a RACW from name server. private pragma Inline (FA_B, FA_C, FA_F, FA_I, FA_U, FA_LF, FA_LI, FA_LU, FA_LLF, FA_LLI, FA_LLU, FA_SF, FA_SI, FA_SU, FA_SSI, FA_SSU, FA_WC, FA_String, TA_B, TA_C, TA_F, TA_I, TA_U, TA_LF, TA_LI, TA_LU, TA_LLF, TA_LLI, TA_LLU, TA_SF, TA_SI, TA_SU, TA_SSI, TA_SSU, TA_WC, TA_String); pragma Inline (Caseless_String_Eq, Get_Aggregate_Element); overriding function Execute_Servant (Self : not null access Servant; Req : PolyORB.Requests.Request_Access) return Boolean; type Buffer_Stream_Type is new Ada.Streams.Root_Stream_Type with record Buf : aliased PolyORB.Buffers.Buffer_Type; end record; type Private_Info_Access is access all Private_Info; type Private_Info is record Next : aliased Private_Info_Access; -- For chaining on All_Receiving_Stubs list Kind : Receiving_Stub_Kind; -- Indicates whether this info is relative to RACW type or a RCI Name : PolyORB.Utils.Strings.String_Ptr; -- Fully qualified name of the RACW or RCI Version : PolyORB.Utils.Strings.String_Ptr; -- For RCIs only: library unit version Receiver : Servant_Access; -- The RPC receiver (servant) object Is_All_Calls_Remote : Boolean; -- For RCIs only: true iff a pragma All_Calls_Remote applies to unit Subp_Info : System.Address; Subp_Info_Len : Integer; -- For RCIs only: mapping of RCI subprogram names to addresses. -- For the definition of these values, cf. the specification of -- Register_Pkg_Receiving_Stubs. end record; end System.Partition_Interface; polyorb-2.8~20110207.orig/src/dsa/polyorb-dsa_p-name_service.ads0000644000175000017500000001114411750740340023642 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . D S A _ P . N A M E _ S E R V I C E -- -- -- -- S p e c -- -- -- -- Copyright (C) 2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- This package implements the abstract name context primitives, that -- permit the dispatching between different concrete contexts. with PolyORB.References; with PolyORB.Types; package PolyORB.DSA_P.Name_Service is type Name_Context is abstract tagged record Base_Ref : PolyORB.References.Ref; Stringified_Ref : PolyORB.Types.String; end record; -- The abstract type used to disptach Nameserver_Lookup/ -- Nameserver_Register. The Stringified_Ref is used only on client's side, -- it is assigned by Initialize_MDNS_Context and is used in -- Nameserver_Lookup in order to initialize the remote Base_Ref field. type Name_Context_Access is access all Name_Context'Class; Name_Ctx : PolyORB.DSA_P.Name_Service.Name_Context_Access; function Nameserver_Lookup (Name_Ctx : access Name_Context; Name : String; Kind : String; Initial : Boolean := True) return PolyORB.References.Ref is abstract; -- abstract declaration of Nameserver_Lookup procedure Nameserver_Register (Name_Ctx : access Name_Context; Name : String; Kind : String; Obj : PolyORB.References.Ref) is abstract; -- abstract declaration of Nameserver_Register procedure Initialize_Name_Context; -- Called by the System.Partition_Interface.Initialize procedure, during -- partition's elaboration. Depending on the current configuration, -- sets the Name Context to mDNS or COS_Naming and the Base_Ref to -- the corresponding remote reference. function Get_Name_Context return Name_Context_Access; -- Retrieves the name context, used by System.Partition_Interface -------------------------------------------- -- RCI lookup and reconnection management -- -------------------------------------------- Time_Between_Requests : Duration := 1.0; Max_Requests : Natural := 10; -- These are the initial and default values type Reconnection_Policy_Type is (Fail_Until_Restart, Block_Until_Restart, Reject_On_Restart); Default_Reconnection_Policy : constant Reconnection_Policy_Type := Fail_Until_Restart; function Get_Reconnection_Policy (Name : String) return Reconnection_Policy_Type; -- Retrieve reconnection policy for this RCI from runtime parameters -- set by gnatdist. type RCI_Attribute is (Local, Reconnection); function RCI_Attr (Name : String; Attr : RCI_Attribute) return String; function Is_Reference_Valid (R : PolyORB.References.Ref) return Boolean; -- Binds a reference to determine whether it is valid end PolyORB.DSA_P.Name_Service; polyorb-2.8~20110207.orig/src/dsa/polyorb-dsa_p-name_server.adb0000644000175000017500000001141211750740340023465 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . D S A _ P . N A M E _ S E R V E R -- -- -- -- B o d y -- -- -- -- Copyright (C) 2009, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- Implementation note: we currently use a hand-coded minimal servant. We -- should replace it with a RACW at some point. with Ada.Environment_Variables; with PolyORB.DSA_P.Exceptions; with PolyORB.Errors; with PolyORB.Initialization; with PolyORB.Log; with PolyORB.Objects; with PolyORB.ORB; with PolyORB.POA; with PolyORB.POA_Types; with PolyORB.References; with PolyORB.References.IOR; with PolyORB.Services.Naming.NamingContext.Servant; with PolyORB.Setup; with PolyORB.Utils.Strings.Lists; package body PolyORB.DSA_P.Name_Server is use PolyORB.DSA_P.Exceptions; use PolyORB.Errors; use PolyORB.Initialization; use PolyORB.Log; use PolyORB.Objects; use PolyORB.ORB; use PolyORB.References.IOR; use PolyORB.Services.Naming.NamingContext.Servant; package L is new PolyORB.Log.Facility_Log ("polyorb.dsa_p.name_server"); procedure O (Message : String; Level : Log_Level := Debug) renames L.Output; function C (Level : Log_Level := Debug) return Boolean renames L.Enabled; package NC renames PolyORB.Services.Naming.NamingContext.Servant; Root_NC : NC.Object_Ptr; Root_NC_Ref : PolyORB.References.Ref; procedure Initialize_Naming_Context; -- Set up the name server and set Root_NC_Ref ------------------------------- -- Initialize_Naming_Context -- ------------------------------- procedure Initialize_Naming_Context is Root_POA : constant POA.Obj_Adapter_Access := POA.Obj_Adapter_Access (Object_Adapter (PolyORB.Setup.The_ORB)); Oid : Object_Id_Access; Error : PolyORB.Errors.Error_Container; Type_Id : constant Standard.String := "dsa:NAMING"; begin Root_NC := NC.Create; PolyORB.POA.Export (Root_POA, To_PolyORB_Servant (Root_NC), null, Oid, Error); if Found (Error) then Raise_From_Error (Error); end if; PolyORB.ORB.Create_Reference (PolyORB.Setup.The_ORB, Oid, Type_Id, Root_NC_Ref); PolyORB.POA_Types.Free (Oid); declare Nameserver_Str : constant String := Object_To_String (Root_NC_Ref); begin Ada.Environment_Variables.Set ("POLYORB_DSA_NAME_SERVICE", Nameserver_Str); pragma Debug (C, O ("POLYORB_DSA_NAME_SERVICE=" & Nameserver_Str)); end; -- Initiate_Well_Known_Service ("NameService"); end Initialize_Naming_Context; use PolyORB.Utils.Strings; use PolyORB.Utils.Strings.Lists; begin Register_Module (Module_Info' (Name => +"dsa.name_server", Conflicts => Empty, Depends => +"orb" & "poa" & "access_points", Provides => Empty, Implicit => False, Init => Initialize_Naming_Context'Access, Shutdown => null)); end PolyORB.DSA_P.Name_Server; polyorb-2.8~20110207.orig/src/dsa/polyorb-termination_manager-bootstrap.ads0000644000175000017500000001120011750740340026145 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- POLYORB.TERMINATION_MANAGER.BOOTSTRAP -- -- -- -- S p e c -- -- -- -- Copyright (C) 2006-2011, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- This package starts and setup the termination manager. -- It also provides functions for getting references to local and remote -- termination managers. with PolyORB.Binding_Objects; with PolyORB.Objects; with PolyORB.References; with PolyORB.Servants; package PolyORB.Termination_Manager.Bootstrap is type Term_Manager_Ptr is access Term_Manager; ------------------- -- TM Constants -- ------------------- -- Because the termination manager is a singleton in its own partition, -- it is legitimate to keep here some references to the TM. TM_Name_Space : constant String := "Termination_Manager"; -- The name used by the well known service started by the termination -- manager. RACW_Type_Name : constant String := "polyorb.termination_manager.term_manager"; -- The type name of the termination manager RACW The_TM : Term_Manager_Ptr; -- A pointer to the local termination manager The_TM_Ref : PolyORB.References.Ref; -- A reference to the local termination manager The_TM_Oid : PolyORB.Objects.Object_Id_Access; -- A pointer to the local termination manager Object_Id type Node_Kind is (DSA_Node, DSA_Node_Without_TM, Non_DSA_Node, Unknown); -- The kind of nodes we can link to : -- -- * DSA_Node : a DSA partition with a running termination manager. -- * DSA_Node_Without_TM : a DSA partition without a termination manager. -- * Non_DSA_Node : a node which is not a DSA partition. -- * Unknown : we cannot determine the kind of this node. -------------------------------------- -- TM References Handling Utilities -- -------------------------------------- procedure Extract_TM_Reference_From_BO (BO : Binding_Objects.Binding_Object_Access; Ref : out References.Ref; NK : out Node_Kind); -- Ref is a reference to the termination manager of the partition which BO -- links to. NK gives an indication of the kind of the node to which BO -- links. function Ref_To_Term_Manager_Access (R : References.Ref) return Term_Manager_Access; -- Convert a Reference to a Term Manager Access function Term_Manager_Access_To_Ref (TM : Term_Manager_Access) return References.Ref; -- Convert a Term Manager Access to a Reference procedure Initialize_Termination_Manager; -- Initializes the termination algorithm private procedure Initiate_Well_Known_Service (S : Servants.Servant_Access; Name : String); -- Initiate a POA reachable by an absolute path of the form: /Name/ and -- which returns always the default servant S. end PolyORB.Termination_Manager.Bootstrap; polyorb-2.8~20110207.orig/src/dsa/polyorb-dsa_p-name_service-cos_naming.adb0000644000175000017500000001621111750740340025734 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- POLYORB.DSA_P.NAME_SERVICE.COS_NAMING -- -- -- -- B o d y -- -- -- -- Copyright (C) 2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with PolyORB.Utils; with PolyORB.Log; with PolyORB.Services.Naming.NamingContext; with PolyORB.Services.Naming.NamingContext.Client; with PolyORB.Smart_Pointers; with Ada.Exceptions; with System.RPC; with PolyORB.Tasking.Threads; with PolyORB.Initialization; package body PolyORB.DSA_P.Name_Service.COS_Naming is use PolyORB.Utils; use PolyORB.Log; use PolyORB.Smart_Pointers; package L is new PolyORB.Log.Facility_Log ("polyorb.dsa_p.name_service.cos_naming"); procedure O (Message : String; Level : Log_Level := Debug) renames L.Output; function C (Level : Log_Level := Debug) return Boolean renames L.Enabled; package PSNNC renames PolyORB.Services.Naming.NamingContext; Time_Between_Requests : constant Duration := 1.0; Max_Requests : constant Natural := 10; ------------------------- -- Nameserver_Register -- ------------------------- procedure Nameserver_Register (Name_Ctx : access COS_Name_Context; Name : String; Kind : String; Obj : PolyORB.References.Ref) is use Ada.Exceptions; Id : constant PolyORB.Services.Naming.Name := To_Name (Name, Kind); Context : PSNNC.Ref; Reg_Obj : PolyORB.References.Ref; begin pragma Debug (C, O ("About to register " & Name & " on nameserver")); -- May raise an exception which we do not want to handle in the -- following block (failure to establish the naming context is a fatal -- error and must be propagated to the caller). PSNNC.Set (Context, Entity_Of (Smart_Pointers.Ref (Name_Ctx.Base_Ref))); begin Reg_Obj := PSNNC.Client.Resolve (Context, Id); exception when others => -- Resolution attempt returned an authoritative "name not found" -- error: register unit now. PSNNC.Client.Bind (Self => Context, N => Id, Obj => Obj); return; end; -- Name is present in name server, check validity of the reference it -- resolves to. if Get_Reconnection_Policy (Name) = Reject_On_Restart or else Is_Reference_Valid (Reg_Obj) then -- Reference is valid: RCI unit is already declared by another -- partition. PolyORB.Initialization.Shutdown_World (Wait_For_Completion => False); raise Program_Error with Name & " (" & Kind & ") is already declared"; else -- The reference is not valid anymore: we assume the original server -- has died, and rebind the name. PSNNC.Client.Rebind (Self => Context, N => To_Name (Name, Kind), Obj => Obj); end if; end Nameserver_Register; ----------------------- -- Nameserver_Lookup -- ----------------------- function Nameserver_Lookup (Name_Ctx : access COS_Name_Context; Name : String; Kind : String; Initial : Boolean := True) return PolyORB.References.Ref is LName : constant String := To_Lower (Name); Result : PolyORB.References.Ref; Context : PSNNC.Ref; Retry_Count : Natural := 0; begin pragma Debug (C, O ("Nameserver_Lookup (" & Name & "." & Kind & "): enter")); -- Unit not known yet, we therefore know that it is remote, and we -- need to look it up with the naming service. PSNNC.Set (Context, Entity_Of (Smart_Pointers.Ref (Name_Ctx.Base_Ref))); loop begin Result := PSNNC.Client.Resolve (Context, To_Name (LName, Kind)); if not Is_Reference_Valid (Result) then PolyORB.References.Release (Result); end if; exception -- Catch all exceptions: we will retry resolution, and bail -- out after Max_Requests iterations. when E : others => pragma Debug (C, O ("retry" & Retry_Count'Img & " got " & Ada.Exceptions.Exception_Information (E))); PolyORB.References.Release (Result); end; exit when not (Initial and then Is_Nil (Smart_Pointers.Ref (Result))); -- Resolve succeeded, or just trying to refresh a stale ref: -- exit loop. if Retry_Count = Max_Requests then raise System.RPC.Communication_Error with "lookup of " & Kind & " " & Name & " failed"; end if; Retry_Count := Retry_Count + 1; PolyORB.Tasking.Threads.Relative_Delay (Time_Between_Requests); end loop; pragma Debug (C, O ("Nameserver_Lookup (" & Name & "." & Kind & "): leave")); return Result; end Nameserver_Lookup; ------------- -- To_Name -- ------------- function To_Name (Id, Kind : String) return PolyORB.Services.Naming.Name is use PolyORB.Services.Naming.SEQUENCE_NameComponent; begin return PolyORB.Services.Naming.Name (To_Sequence ((1 => (id => PolyORB.Services.Naming.To_PolyORB_String (Id), kind => PolyORB.Services.Naming.To_PolyORB_String (Kind))))); end To_Name; end PolyORB.DSA_P.Name_Service.COS_Naming; polyorb-2.8~20110207.orig/src/polyorb-protocols-iface.ads0000644000175000017500000000643311750740340022445 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . P R O T O C O L S . I F A C E -- -- -- -- S p e c -- -- -- -- Copyright (C) 2001-2005 Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- Interface for Sessions with PolyORB.Any.NVList; with PolyORB.Components; package PolyORB.Protocols.Iface is -- When a Session receives a method invocation request, -- it is not always possible to determine the signature -- for the called method immediately; it may be necessary -- to wait until the servant has started handling the -- request, and performs a call to ServerRequest.Arguments. -- In that case, where unmarshalling is deferred until request -- execution commences, the message Unmarshall_Arguments must -- be sent to the Session with a properly-type NVList in it -- so the unmarshalling can take place. An Unmarshalled_Arguments -- message is returned. -- If an error is dectected when unmarshalling, then -- Arguments_Error is returned. type Unmarshall_Arguments is new Components.Message with record Args : Any.NVList.Ref; end record; type Unmarshalled_Arguments is new Components.Message with record Args : Any.NVList.Ref; end record; type Arguments_Error is new Components.Message with record Error : Errors.Error_Container; end record; -- The Flush message reinitializes the session object. type Flush is new Components.Message with null record; end PolyORB.Protocols.Iface; polyorb-2.8~20110207.orig/src/polyorb-jobs.adb0000644000175000017500000000731711750740340020272 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . J O B S -- -- -- -- B o d y -- -- -- -- Copyright (C) 2001-2009, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ pragma Ada_2005; with Ada.Unchecked_Deallocation; package body PolyORB.Jobs is ------------------ -- Create_Queue -- ------------------ function Create_Queue return Job_Queue_Access is begin return new Job_Queue; end Create_Queue; --------------- -- Fetch_Job -- --------------- function Fetch_Job (Q : access Job_Queue; Selector : access function (J : Job'Class) return Boolean := null) return Job_Access is use Job_Queues; Result : Job_Access; It : Iterator := First (Q.Contents); begin while not Last (It) loop if Selector = null or else Selector (Value (It).all.all) then Result := Job_Access (Value (It).all); Remove (Q.Contents, It); return Result; end if; Next (It); end loop; return null; end Fetch_Job; ---------- -- Free -- ---------- procedure Free (X : in out Job_Access) is procedure Free is new Ada.Unchecked_Deallocation (Job'Class, Job_Access); begin Free (X); end Free; -------------- -- Is_Empty -- -------------- function Is_Empty (Q : access Job_Queue) return Boolean is use type Job_Queues.List; begin return Job_Queues.Is_Empty (Q.Contents); end Is_Empty; --------------- -- Queue_Job -- --------------- procedure Queue_Job (Q : access Job_Queue; J : Job_Access) is begin Job_Queues.Append (Q.Contents, J); end Queue_Job; ------------ -- Length -- ------------ function Length (Q : access Job_Queue) return Natural is begin return Job_Queues.Length (Q.Contents); end Length; end PolyORB.Jobs; polyorb-2.8~20110207.orig/src/polyorb-poa_policies-thread_policy-main_thread.adb0000644000175000017500000001256111750740340027075 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- POLYORB.POA_POLICIES.THREAD_POLICY.MAIN_THREAD -- -- -- -- B o d y -- -- -- -- Copyright (C) 2003-2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- Implementation of the 'Main thread' POA Policy. -- Under this policy, requests to *all* main-thread POAs are -- processed sequentially. with PolyORB.Log; with PolyORB.Tasking.Mutexes; package body PolyORB.POA_Policies.Thread_Policy.Main_Thread is use PolyORB.Log; package L is new PolyORB.Log.Facility_Log ("polyorb.poa_policies.thread_policy.main_thread"); procedure O (Message : Standard.String; Level : Log_Level := Debug) renames L.Output; function C (Level : Log_Level := Debug) return Boolean renames L.Enabled; Main_Thread_Lock : PolyORB.Tasking.Mutexes.Mutex_Access; Initialized : Boolean := False; ------------ -- Create -- ------------ function Create return Main_Thread_Policy_Access is Result : constant Main_Thread_Policy_Access := new Main_Thread_Policy; begin ThreadPolicy (Result.all).Executor := new Main_Thread_Executor; return Result; end Create; --------------- -- Policy_Id -- --------------- function Policy_Id (Self : Main_Thread_Policy) return String is pragma Warnings (Off); pragma Unreferenced (Self); pragma Warnings (On); begin return "THREAD_POLICY.MAIN_THREAD"; end Policy_Id; ------------------------- -- Check_Compatibility -- ------------------------- procedure Check_Compatibility (Self : Main_Thread_Policy; Other_Policies : AllPolicies; Error : in out PolyORB.Errors.Error_Container) is pragma Warnings (Off); pragma Unreferenced (Self); pragma Unreferenced (Other_Policies); pragma Unreferenced (Error); pragma Warnings (On); begin null; -- No rule to test end Check_Compatibility; ------------------------ -- Execute_In_Context -- ------------------------ function Execute_In_Context (Self : access Main_Thread_Executor; Req : Requests.Request_Access; Requestor : Components.Component_Access) return Boolean is use PolyORB.Servants; use PolyORB.Tasking.Mutexes; pragma Warnings (Off); pragma Unreferenced (Self); pragma Warnings (On); begin -- This policy only prevents us to have to concurrent calls to -- Main_Thread POAs. -- XXX This dirty implementation associates a global lock to all -- Main_Thread POA. -- XXX However, this is a waste of ressources as a number of threads -- would wait on a given and known lock. We should try to specialize -- threads, and have only one threads to handle all upcalls made on all -- main_thread POAs ? cf PolyORB.ORB.Thread_Per_Session for a pattern. pragma Debug (C, O ("Execute_In_Context: Enter")); if not Initialized then pragma Debug (C, O ("Initialize policy")); Create (Main_Thread_Lock); Initialized := True; end if; pragma Debug (C, O ("Waiting on Main Thread's lock")); Enter (Main_Thread_Lock); pragma Debug (C, O ("Waiting done")); declare Res : constant Boolean := Abortable_Execute_Servant (Servant_Access (Requestor), Req); begin Leave (Main_Thread_Lock); pragma Debug (C, O ("Execute_In_Context: Leave")); return Res; end; end Execute_In_Context; end PolyORB.POA_Policies.Thread_Policy.Main_Thread; polyorb-2.8~20110207.orig/src/polyorb-filters.ads0000644000175000017500000001211711750740340021020 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . F I L T E R S -- -- -- -- S p e c -- -- -- -- Copyright (C) 2001-2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- A communication filter (a transport Data_Unit handler/forwarder). -- A protocol implementation can be considered as a stack of layers. -- Each layer exchanges messages with its immediate neighbours. -- Variations on the protocol, and adaptation and optimizations -- according to various environment an application constraints, -- can be implemented in a very modular and configurable fasion -- by adding or removing layers in the stack. This design was -- used for protocol implementation in the x-kernel. This unit -- defines abstract 'filter' components that can be used in such -- a stacked configuration. -- For further information, see: -- N. C. Hutchinson and L. L. Peterson -- "The x-kernel: An Architecture for Implementing Network Protocols", -- IEEE Transactions on Software Engineering, -- vol. 17, pp. 64--76, January 1991. with PolyORB.Components; package PolyORB.Filters is -- Body requires child unit PolyORB.Filters.Interface: -- no elab control pragma. package PC renames PolyORB.Components; ---------------------------------------------------- -- A Filter is a component that forwards messages -- -- across a stack. -- ---------------------------------------------------- type Filter is abstract new PC.Component with private; type Filter_Access is access all Filter'Class; function Handle_Message (F : not null access Filter; Msg : Components.Message'Class) return Components.Message'Class; -- Implement default propagation: just transmit message to the appropriate -- neighbour (lower or upper, depending on message type, as documented in -- Filters.Iface). procedure Connect_Lower (F : access Filter; Lower : PC.Component_Access); function Lower (F : access Filter) return PC.Component_Access; function Upper (F : access Filter) return PC.Component_Access; -- Filters communicate by exchanging Data_Units, defined in child package -- PolyORB.Filters.Interface. -- Filters are associated in a stack, each one having a lower and an -- upper neighbour. A stack is created from a list of factories. type Factory is abstract tagged limited private; type Factory_Access is access all Factory'Class; type Factory_Array is array (Integer range <>) of Factory_Access; type Factories_Access is access all Factory_Array; procedure Create (Fact : access Factory; Filt : out Filter_Access) is abstract; -- Each filter factory implements a Create operation that instantiates -- the corresponding filter. procedure Destroy (F : in out Filter); procedure Create_Filter_Chain (Factories : Factory_Array; Bottom : out Filter_Access; Top : out Filter_Access); -- Invoke the factory chain Factories, to create a stack of filters whose -- bottom and top elements are returned. private type Filter is abstract new PC.Component with record Lower : PC.Component_Access; Upper : PC.Component_Access; end record; type Factory is abstract tagged limited null record; end PolyORB.Filters; polyorb-2.8~20110207.orig/src/polyorb-references-ior.ads0000644000175000017500000001042611750740340022261 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . R E F E R E N C E S . I O R -- -- -- -- S p e c -- -- -- -- Copyright (C) 2002-2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- Representation of object references as typed -- Interoperable Object References. -- An IOR aggregates the identification of an interface (i.e. a type -- identifier) and a set of profiles designating an object that supports -- this interface. An IOR can be converted to a stringified -- representation by marshalling it according to CDR, and converting -- the resulting stream element array into a string of hexadecimal digits. with Ada.Streams; with PolyORB.Buffers; with PolyORB.Binding_Data; package PolyORB.References.IOR is use PolyORB.Buffers; procedure Marshall_Profile (Buffer : access Buffer_Type; P : Binding_Data.Profile_Access; Success : out Boolean); function Unmarshall_Profile (Buffer : access Buffer_Type) return Binding_Data.Profile_Access; -- Return null if failed procedure Marshall_IOR (Buffer : access Buffer_Type; Value : PolyORB.References.Ref); function Unmarshall_IOR (Buffer : access Buffer_Type) return PolyORB.References.Ref; -------------------------------------- -- Object reference <-> opaque data -- -------------------------------------- function Object_To_Opaque (IOR : PolyORB.References.Ref) return Ada.Streams.Stream_Element_Array; function Opaque_To_Object (Opaque : access Ada.Streams.Stream_Element_Array) return PolyORB.References.Ref; ------------------------------------------ -- Object reference <-> stringified IOR -- ------------------------------------------ function Object_To_String (IOR : PolyORB.References.Ref) return String; --------------------- -- Profile Factory -- --------------------- type Marshall_Profile_Body_Type is access procedure (Buffer : access Buffers.Buffer_Type; Profile : Binding_Data.Profile_Access); type Unmarshall_Profile_Body_Type is access function (Buffer : access Buffers.Buffer_Type) return Binding_Data.Profile_Access; procedure Register (Profile : Binding_Data.Profile_Tag; Marshall_Profile_Body : Marshall_Profile_Body_Type; Unmarshall_Profile_Body : Unmarshall_Profile_Body_Type); private function String_To_Object (Str : String) return PolyORB.References.Ref; end PolyORB.References.IOR; polyorb-2.8~20110207.orig/src/polyorb-utils-strings.adb0000644000175000017500000000660011750740340022156 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . U T I L S . S T R I N G S -- -- -- -- B o d y -- -- -- -- Copyright (C) 2001-2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- General-purpose string pointer. package body PolyORB.Utils.Strings is --------- -- "+" -- --------- function "+" (S : Standard.String) return String_Ptr is begin return new Standard.String'(S); end "+"; ---------------- -- To_Boolean -- ---------------- function To_Boolean (V : String) return Boolean is VV : constant String := PolyORB.Utils.To_Lower (V); begin if VV'Length > 0 then case VV (VV'First) is when '0' | 'n' => return False; when '1' | 'y' => return True; when 'o' => if VV = "off" then return False; elsif VV = "on" then return True; end if; when 'd' => if VV = "disable" then return False; end if; when 'e' => if VV = "enable" then return True; end if; when 'f' => if VV = "false" then return False; end if; when 't' => if VV = "true" then return True; end if; when others => null; end case; end if; raise Constraint_Error; end To_Boolean; end PolyORB.Utils.Strings; polyorb-2.8~20110207.orig/src/polyorb-orb_controller-leader_followers.ads0000644000175000017500000000724711750740340025733 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- POLYORB.ORB_CONTROLLER.LEADER_FOLLOWERS -- -- -- -- S p e c -- -- -- -- Copyright (C) 2004-2008, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- Leader/Followers ORB Controller for PolyORB ORB main loop. -- It is a tasking ORB Controller implementation, it supports: -- multi-tasking ORB only -- Under this implementation, a task handles the complete processing -- of an incoming request: from monitors polling up to dispatching -- the request to servant code. package PolyORB.ORB_Controller.Leader_Followers is type ORB_Controller_Leader_Followers is new ORB_Controller with private; type ORB_Controller_Leader_Followers_Access is access all ORB_Controller_Leader_Followers'Class; procedure Notify_Event (O : access ORB_Controller_Leader_Followers; E : Event); procedure Schedule_Task (O : access ORB_Controller_Leader_Followers; TI : PTI.Task_Info_Access); procedure Register_Task (O : access ORB_Controller_Leader_Followers; TI : PTI.Task_Info_Access); procedure Disable_Polling (O : access ORB_Controller_Leader_Followers; M : PAE.Asynch_Ev_Monitor_Access); procedure Enable_Polling (O : access ORB_Controller_Leader_Followers; M : PAE.Asynch_Ev_Monitor_Access); type ORB_Controller_Leader_Followers_Factory is new ORB_Controller_Factory with private; function Create (OCF : ORB_Controller_Leader_Followers_Factory) return ORB_Controller_Access; private type ORB_Controller_Leader_Followers is new ORB_Controller with null record; type ORB_Controller_Leader_Followers_Factory is new ORB_Controller_Factory with null record; OCF : constant ORB_Controller_Factory_Access := new ORB_Controller_Leader_Followers_Factory; end PolyORB.ORB_Controller.Leader_Followers; polyorb-2.8~20110207.orig/src/polyorb-tasking-mutexes.ads0000644000175000017500000001117211750740340022500 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . T A S K I N G . M U T E X E S -- -- -- -- S p e c -- -- -- -- Copyright (C) 2002-2008, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by ACT Europe. -- -- (email: sales@act-europe.fr) -- -- -- ------------------------------------------------------------------------------ -- Implementation of a POSIX-like mutexes -- A complete implementation of this package is provided for all -- tasking profiles. package PolyORB.Tasking.Mutexes is pragma Preelaborate; ------------- -- Mutexes -- ------------- type Mutex_Type is abstract tagged limited private; type Mutex_Access is access all Mutex_Type'Class; -- Mutual exclusion locks (mutexes) prevent multiple threads from -- simultaneously executing critical sections of code which access shared -- data (that is, mutexes are used to serialize the execution of -- threads). While a thread is in the critical section protected by a -- mutex, it is designated as the owner of that mutex. procedure Enter (M : access Mutex_Type) is abstract; -- A call to Enter locks mutex object M. If M is already locked, -- the caller is blocked until it gets unlocked. On exit from Enter, -- M is locked, and the caller is the owner. -- If the current owner of a mutex tries to enter it again, a -- deadlock occurs. procedure Leave (M : access Mutex_Type) is abstract; -- Release M. M must be locked, and the caller must be the owner. -- The scheduling policy determines which blocked thread is awakened -- next and obtains the mutex. -- It is erroneous for any process other than the owner of a mutex -- to invoke Leave. ------------------- -- Mutex_Factory -- ------------------- type Mutex_Factory_Type is abstract tagged limited null record; -- This type is a factory for the mutex type. -- A subclass of this factory exists for every tasking profile: -- Full Tasking, Ravenscar and No Tasking. -- This type provides functionalities for creating mutexes -- corresponding to the chosen tasking profile. type Mutex_Factory_Access is access all Mutex_Factory_Type'Class; function Create (MF : access Mutex_Factory_Type; Name : String := "") return Mutex_Access is abstract; -- Create a new mutex, or get a preallocated one. -- Name will be used to get the configuration of this -- mutex from the configuration module. procedure Destroy (MF : access Mutex_Factory_Type; M : in out Mutex_Access) is abstract; -- Destroy M, or just release it if it was preallocated. procedure Register_Mutex_Factory (MF : Mutex_Factory_Access); -- Register the factory corresponding to the chosen tasking profile. procedure Create (M : out Mutex_Access; Name : String := ""); procedure Destroy (M : in out Mutex_Access); private type Mutex_Type is abstract tagged limited null record; end PolyORB.Tasking.Mutexes; polyorb-2.8~20110207.orig/src/polyorb-poa_config-minimum.ads0000644000175000017500000000474211750740340023132 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . P O A _ C O N F I G . M I N I M U M -- -- -- -- S p e c -- -- -- -- Copyright (C) 2001-2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by ACT Europe. -- -- (email: sales@act-europe.fr) -- -- -- ------------------------------------------------------------------------------ -- A POA configuration corresponding to Minimum CORBA policies package PolyORB.POA_Config.Minimum is pragma Elaborate_Body; type Minimum_Configuration is new Configuration_Type with private; procedure Initialize (C : Minimum_Configuration); function Default_Policies (C : Minimum_Configuration) return PolyORB.POA_Policies.PolicyList; private type Minimum_Configuration is new Configuration_Type with null record; end PolyORB.POA_Config.Minimum; polyorb-2.8~20110207.orig/src/polyorb-qos-static_buffers.adb0000644000175000017500000000451011750740340023130 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . Q O S . S T A T I C _ B U F F E R S -- -- -- -- B o d y -- -- -- -- Copyright (C) 2007 Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ package body PolyORB.QoS.Static_Buffers is ---------------------- -- Release_Contents -- ---------------------- procedure Release_Content (QoS : access QoS_GIOP_Static_Buffer_Parameter) is begin PolyORB.Buffers.Release (QoS.Buffer); end Release_Content; end PolyORB.QoS.Static_Buffers; polyorb-2.8~20110207.orig/src/polyorb-representations.ads0000644000175000017500000000646411750740340022605 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . R E P R E S E N T A T I O N S -- -- -- -- S p e c -- -- -- -- Copyright (C) 2001-2009, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- Data representation methods. -- A Representation is a method for transforming an arbitrary piece -- of data (in the form of an 'Any' object) into a sequence of -- Stream_Elements, and back. with PolyORB.Any; with PolyORB.Buffers; with PolyORB.Errors; package PolyORB.Representations is pragma Preelaborate; type Representation is abstract tagged limited private; type Representation_Access is access all Representation'Class; procedure Marshall_From_Any (R : access Representation; Buffer : access Buffers.Buffer_Type; Data : Any.Any_Container'Class; Error : in out Errors.Error_Container) is abstract; -- Store a representation of Data into Buffer according to representation -- convention R. procedure Unmarshall_To_Any (R : access Representation; Buffer : access Buffers.Buffer_Type; Data : in out Any.Any_Container'Class; Error : in out Errors.Error_Container) is abstract; -- Set the value of Data from the representation stored in Buffer according -- to representation convetion R. procedure Release (R : in out Representation); -- Deallocate resources associated with the given representation engine private type Representation is abstract tagged limited null record; end PolyORB.Representations; polyorb-2.8~20110207.orig/src/polyorb-binding_object_qos.adb0000644000175000017500000001232511750740340023152 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . B I N D I N G _ O B J E C T _ Q O S -- -- -- -- B o d y -- -- -- -- Copyright (C) 2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with PolyORB.Annotations; package body PolyORB.Binding_Object_QoS is type Binding_Object_QoS_Note is new Annotations.Note with record QoS : PolyORB.QoS.QoS_Parameters; end record; procedure Destroy (N : in out Binding_Object_QoS_Note); Empty_Binding_Object_QoS_Note : constant Binding_Object_QoS_Note := (Annotations.Note with QoS => (others => null)); Registry : array (PolyORB.QoS.QoS_Kind) of QoS_Compatibility_Check_Proc; ------------- -- Destroy -- ------------- procedure Destroy (N : in out Binding_Object_QoS_Note) is begin for J in PolyORB.QoS.QoS_Kind loop PolyORB.QoS.Release (N.QoS (J)); end loop; end Destroy; ---------------------------- -- Get_Binding_Object_QoS -- ---------------------------- function Get_Binding_Object_QoS (BO : access PolyORB.Binding_Objects.Binding_Object'Class) return PolyORB.QoS.QoS_Parameters is Note : Binding_Object_QoS_Note; begin PolyORB.Annotations.Get_Note (PolyORB.Binding_Objects.Notepad_Of (PolyORB.Binding_Objects.Binding_Object_Access (BO)).all, Note, Empty_Binding_Object_QoS_Note); return Note.QoS; end Get_Binding_Object_QoS; ------------------- -- Is_Compatible -- ------------------- function Is_Compatible (BO : access PolyORB.Binding_Objects.Binding_Object'Class; QoS : PolyORB.QoS.QoS_Parameters) return Boolean is BO_QoS : constant PolyORB.QoS.QoS_Parameters := Get_Binding_Object_QoS (BO); begin for J in PolyORB.QoS.QoS_Kind loop if Registry (J) /= null then if not Registry (J) (BO_QoS (J), QoS (J)) then return False; end if; end if; end loop; return True; end Is_Compatible; -------------- -- Register -- -------------- procedure Register (Kind : PolyORB.QoS.QoS_Kind; Proc : QoS_Compatibility_Check_Proc) is begin Registry (Kind) := Proc; end Register; ---------------------------- -- Set_Binding_Object_QoS -- ---------------------------- procedure Set_Binding_Object_QoS (BO : access PolyORB.Binding_Objects.Binding_Object'Class; QoS : PolyORB.QoS.QoS_Parameters) is Note : Binding_Object_QoS_Note; begin Note.QoS := QoS; PolyORB.Annotations.Set_Note (PolyORB.Binding_Objects.Notepad_Of (PolyORB.Binding_Objects.Binding_Object_Access (BO)).all, Note); end Set_Binding_Object_QoS; procedure Set_Binding_Object_QoS (BO : access PolyORB.Binding_Objects.Binding_Object'Class; Kind : PolyORB.QoS.QoS_Kind; QoS : PolyORB.QoS.QoS_Parameter_Access) is Note : Binding_Object_QoS_Note; begin PolyORB.Annotations.Get_Note (PolyORB.Binding_Objects.Notepad_Of (PolyORB.Binding_Objects.Binding_Object_Access (BO)).all, Note, Empty_Binding_Object_QoS_Note); Note.QoS (Kind) := QoS; PolyORB.Annotations.Set_Note (PolyORB.Binding_Objects.Notepad_Of (PolyORB.Binding_Objects.Binding_Object_Access (BO)).all, Note); end Set_Binding_Object_QoS; end PolyORB.Binding_Object_QoS; polyorb-2.8~20110207.orig/src/polyorb-utils-sockets.ads0000644000175000017500000000740311750740340022163 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . U T I L S . S O C K E T S -- -- -- -- S p e c -- -- -- -- Copyright (C) 2003-2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- General purpose functions for using sockets with string and buffers with Ada.Unchecked_Deallocation; with PolyORB.Buffers; with PolyORB.Sockets; package PolyORB.Utils.Sockets is type Socket_Name (Name_Len : Natural) is record Host_Name : String (1 .. Name_Len); Port : PolyORB.Sockets.Port_Type; end record; function To_Address (SN : Socket_Name) return PolyORB.Sockets.Sock_Addr_Type; -- Convert socket name to socket address type Socket_Name_Ptr is access all Socket_Name; procedure Free is new Ada.Unchecked_Deallocation (Socket_Name, Socket_Name_Ptr); function "+" (Host_Name : String; Port : PolyORB.Sockets.Port_Type) return Socket_Name; -- Return a Socket_Name with the given contents function Image (SN : Socket_Name) return String; -- Return representation of SN as : procedure Marshall_Socket (Buffer : access PolyORB.Buffers.Buffer_Type; Sock : Socket_Name); -- Marshall socket address and port in a buffer function Unmarshall_Socket (Buffer : access PolyORB.Buffers.Buffer_Type) return Socket_Name; -- Unmarshall socket address and port from a buffer procedure Connect_Socket (Sock : in out PolyORB.Sockets.Socket_Type; Remote_Name : Socket_Name); -- Front-end to PolyORB.Sockets.Connect_Socket. In case of failure, Sock is -- closed, and a log trace is produced. function Is_IP_Address (Name : String) return Boolean; -- True iff S is an IP address in dotted quad notation function Local_Inet_Address return PolyORB.Sockets.Inet_Addr_Type; -- Return an IP address associated with the local host name, preferring -- non-loopback addresses over loopback ones. end PolyORB.Utils.Sockets; polyorb-2.8~20110207.orig/src/polyorb-poa_config-minimum.adb0000644000175000017500000001017111750740340023102 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . P O A _ C O N F I G . M I N I M U M -- -- -- -- B o d y -- -- -- -- Copyright (C) 2001-2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by ACT Europe. -- -- (email: sales@act-europe.fr) -- -- -- ------------------------------------------------------------------------------ -- A POA configuration corresponding to minimumCORBA policies with PolyORB.POA_Policies; with PolyORB.POA_Policies.Id_Assignment_Policy.System; with PolyORB.POA_Policies.Id_Uniqueness_Policy.Unique; with PolyORB.POA_Policies.Implicit_Activation_Policy.No_Activation; with PolyORB.POA_Policies.Lifespan_Policy.Transient; with PolyORB.POA_Policies.Request_Processing_Policy.Active_Object_Map_Only; with PolyORB.POA_Policies.Servant_Retention_Policy.Retain; with PolyORB.POA_Policies.Thread_Policy.ORB_Ctrl; package body PolyORB.POA_Config.Minimum is use PolyORB.POA_Policies; My_Default_Policies : PolicyList; Initialized : Boolean := False; ---------------- -- Initialize -- ---------------- procedure Initialize (C : Minimum_Configuration) is pragma Warnings (Off); pragma Unreferenced (C); pragma Warnings (On); use PolyORB.POA_Policies.Policy_Lists; begin if Initialized then return; end if; Append (My_Default_Policies, Policy_Access (Id_Assignment_Policy.System.Create)); Append (My_Default_Policies, Policy_Access (Id_Uniqueness_Policy.Unique.Create)); Append (My_Default_Policies, Policy_Access (Implicit_Activation_Policy.No_Activation.Create)); Append (My_Default_Policies, Policy_Access (Lifespan_Policy.Transient.Create)); Append (My_Default_Policies, Policy_Access (Request_Processing_Policy.Active_Object_Map_Only.Create)); Append (My_Default_Policies, Policy_Access (Servant_Retention_Policy.Retain.Create)); Append (My_Default_Policies, Policy_Access (Thread_Policy.ORB_Ctrl.Create)); Initialized := True; end Initialize; ---------------------- -- Default_Policies -- ---------------------- function Default_Policies (C : Minimum_Configuration) return PolyORB.POA_Policies.PolicyList is begin if not Initialized then Initialize (C); end if; return My_Default_Policies; end Default_Policies; end PolyORB.POA_Config.Minimum; polyorb-2.8~20110207.orig/src/polyorb-poa_manager-basic_manager.ads0000644000175000017500000001356211750740340024377 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . P O A _ M A N A G E R . B A S I C _ M A N A G E R -- -- -- -- S p e c -- -- -- -- Copyright (C) 2001-2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ pragma Ada_2005; -- Base POA Manager concrete implementation. with PolyORB.Requests; with PolyORB.Tasking.Mutexes; with PolyORB.Utils.Chained_Lists; package PolyORB.POA_Manager.Basic_Manager is pragma Elaborate_Body; use PolyORB.Requests; type Basic_POA_Manager is new POAManager with private; type Basic_POA_Manager_Access is access all Basic_POA_Manager; -------------------------------------------------------------------- -- Procedures and functions to implement the POAManager interface -- -------------------------------------------------------------------- procedure Activate (Self : access Basic_POA_Manager; Error : in out PolyORB.Errors.Error_Container); procedure Hold_Requests (Self : access Basic_POA_Manager; Wait_For_Completion : Boolean; Error : in out PolyORB.Errors.Error_Container); procedure Discard_Requests (Self : access Basic_POA_Manager; Wait_For_Completion : Boolean; Error : in out PolyORB.Errors.Error_Container); procedure Deactivate (Self : access Basic_POA_Manager; Etherealize_Objects : Boolean; Wait_For_Completion : Boolean); function Get_State (Self : Basic_POA_Manager) return State; ------------------------------------------------------------- -- Procedures and functions specific to the implementation -- ------------------------------------------------------------- procedure Create (M : access Basic_POA_Manager); procedure Register_POA (Self : access Basic_POA_Manager; OA : Obj_Adapter_Access); procedure Remove_POA (Self : access Basic_POA_Manager; OA : Obj_Adapter_Access); function Get_Hold_Servant (Self : access Basic_POA_Manager; OA : Obj_Adapter_Access) return PolyORB.Servants.Servant_Access; ---------------------------------- -- Holding state implementation -- ---------------------------------- -- When the POAManager is in the HOLDING state: -- A new entry to the queue is created, along with a Hold_Servant -- that has access to this entry. The servant is returned to the POA, -- which returns it as the requested servant. -- When the Handle_Message method of the servant is called, the -- Hold_Servant queues the request in the POAManager queue. -- When the POAManager changes again to the ACTIVE state: -- The requests in the queue are re-sent to the POA, that will send them -- to the ORB to be executed again. -- Note that the requests are queued in the ORB queue, using ORB -- queueing policy. type Hold_Servant is new PolyORB.Servants.Servant with private; type Hold_Servant_Access is access all Hold_Servant; overriding function Execute_Servant (Obj : not null access Hold_Servant; Req : Requests.Request_Access) return Boolean; -- Implementation of the Hold_Servant servant private package POA_Lists is new PolyORB.Utils.Chained_Lists (Obj_Adapter_Access, "=", True); subtype POAList is POA_Lists.List; package Requests_Queues is new PolyORB.Utils.Chained_Lists (Request_Access); subtype Requests_Queue is Requests_Queues.List; type Basic_POA_Manager is new POAManager with record Current_State : State; Managed_POAs : POAList; Lock : PolyORB.Tasking.Mutexes.Mutex_Access; -- Lock the POA Manager PM_Hold_Servant : Hold_Servant_Access := null; -- Reference to the holding servant Held_Requests : Requests_Queue; -- List of requests held by the POAManager end record; procedure Finalize (Self : in out Basic_POA_Manager); type Hold_Servant is new PolyORB.Servants.Servant with record PM : Basic_POA_Manager_Access := null; end record; end PolyORB.POA_Manager.Basic_Manager; polyorb-2.8~20110207.orig/src/polyorb-filters-iface.ads0000644000175000017500000001332211750740340022064 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . F I L T E R S . I F A C E -- -- -- -- S p e c -- -- -- -- Copyright (C) 2001-2007, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- Messages exchanged by Filter components. with Ada.Streams; with PolyORB.Binding_Objects; with PolyORB.Buffers; with PolyORB.Components; with PolyORB.Errors; with PolyORB.Types; package PolyORB.Filters.Iface is pragma Elaborate_Body; use Ada.Streams; use PolyORB.Buffers; use PolyORB.Components; --------------------- -- Filter messages -- --------------------- type Root_Data_Unit is abstract new Message with null record; subtype Data_Unit is Root_Data_Unit'Class; type Set_Server is new Root_Data_Unit with record Server : Components.Component_Access; Binding_Object : Binding_Objects.Binding_Object_Access; end record; -- Direction: from lower to upper. -- Semantics: inform stacks participants of the ORB -- components they are working for. type Set_Target_Object is new Root_Data_Unit with record Target : PolyORB.Types.String; end record; -- Direction: from lower to upper. -- Semantics: a lower layer has determined what application -- object a specific message is destined to, and informs -- the upper layer. type Connect_Indication is new Root_Data_Unit with null record; -- Direction: from lower to upper. -- Semantics: a new incoming transport connection is -- being initiated. type Connect_Confirmation is new Root_Data_Unit with null record; -- Direction: from lower to upper. -- Semantics: a new client transport connection has been established. type Disconnect_Indication is new Root_Data_Unit with record Error : Errors.Error_Container; end record; -- Direction: from lower to upper. -- Semantics: a transport endpoint has been closed, or some other condition -- occured, causing the ORB to determine that the protocol layer must be -- dismantled. If the cause of the disconnect is a detected error, it is -- identified by the Error component. type Disconnect_Request is new Root_Data_Unit with null record; -- Direction: from upper to lower. -- Semantics: the application requests that the whole -- protocol stack be dismantled. type Data_Expected is new Root_Data_Unit with record -- Direction: from upper to lower. -- Semantics: prepare for reception of a message. In_Buf : Buffer_Access; -- Where to store the data when it arrives. Max : Stream_Element_Count; -- The maximum amount of data to be received. end record; type Data_Indication is new Root_Data_Unit with record Data_Amount : Stream_Element_Count := 0; -- The amount of data received, 0 if unknown. end record; -- Direction: from lower to upper. -- Semantics: Data has been received and must be handled. type Data_Out is new Root_Data_Unit with record -- Direction: from upper to lower. -- Semantics: send data out. Out_Buf : Buffer_Access; -- The data to be sent down. end record; type Filter_Error is new Root_Data_Unit with record -- Direction: from lower to upper. -- Semantics: an error in the transport or filtering layers -- has occured. Error : Errors.Error_Container; end record; type Check_Validity is new Root_Data_Unit with null record; -- Direction: from upper to lower -- Semantics: test whether protocol stack is usable to send a request. -- If so, an Empty message is returned, if not, a Filter_Error. --------------------- -- Helper routines -- --------------------- procedure Expect_Data (Self : access Filter'Class; In_Buf : Buffers.Buffer_Access; Max : Ada.Streams.Stream_Element_Count); -- Signal Lower (Self) that data is expected using -- Data_Expected message. end PolyORB.Filters.Iface; polyorb-2.8~20110207.orig/src/polyorb-poa_policies-id_uniqueness_policy-unique.adb0000644000175000017500000001351011750740340027527 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- POLYORB.POA_POLICIES.ID_UNIQUENESS_POLICY.UNIQUE -- -- -- -- B o d y -- -- -- -- Copyright (C) 2001-2005 Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with Ada.Tags; with PolyORB.Object_Maps; with PolyORB.POA; with PolyORB.POA_Policies.Servant_Retention_Policy.Non_Retain; with PolyORB.Tasking.Mutexes; package body PolyORB.POA_Policies.Id_Uniqueness_Policy.Unique is use PolyORB.Errors; use PolyORB.Object_Maps; use PolyORB.Tasking.Mutexes; ------------ -- Create -- ------------ function Create return Unique_Id_Policy_Access is begin return new Unique_Id_Policy; end Create; ------------------------- -- Check_Compatibility -- ------------------------- procedure Check_Compatibility (Self : Unique_Id_Policy; Other_Policies : AllPolicies; Error : in out PolyORB.Errors.Error_Container) is pragma Warnings (Off); pragma Unreferenced (Self); pragma Warnings (On); use Ada.Tags; use PolyORB.POA_Policies.Servant_Retention_Policy; use PolyORB.POA_Policies.Servant_Retention_Policy.Non_Retain; begin -- Unique_Id and Non_Retain policies are not compatible. for J in Other_Policies'Range loop if Other_Policies (J).all in ServantRetentionPolicy'Class and then Other_Policies (J).all'Tag = Non_Retain_Policy'Tag then Throw (Error, InvalidPolicy_E, InvalidPolicy_Members'(Index => 0)); end if; end loop; end Check_Compatibility; --------------- -- Policy_Id -- --------------- function Policy_Id (Self : Unique_Id_Policy) return String is pragma Warnings (Off); pragma Unreferenced (Self); pragma Warnings (On); begin return "ID_UNIQUENESS_POLICY.UNIQUE_ID"; end Policy_Id; ------------------------------- -- Ensure_Servant_Uniqueness -- ------------------------------- procedure Ensure_Servant_Uniqueness (Self : Unique_Id_Policy; OA : PolyORB.POA_Types.Obj_Adapter_Access; P_Servant : Servants.Servant_Access; Error : in out PolyORB.Errors.Error_Container) is pragma Warnings (Off); pragma Unreferenced (Self); pragma Warnings (On); POA : constant PolyORB.POA.Obj_Adapter_Access := PolyORB.POA.Obj_Adapter_Access (OA); begin if POA.Active_Object_Map /= null then Enter (POA.Map_Lock); if Is_Servant_In (POA.Active_Object_Map.all, P_Servant) then Throw (Error, ServantAlreadyActive_E, Null_Members'(Null_Member)); end if; Leave (POA.Map_Lock); end if; end Ensure_Servant_Uniqueness; -------------------- -- Activate_Again -- -------------------- procedure Activate_Again (Self : Unique_Id_Policy; OA : PolyORB.POA_Types.Obj_Adapter_Access; P_Servant : Servants.Servant_Access; Oid : Object_Id_Access; Result : out Object_Id_Access; Error : in out PolyORB.Errors.Error_Container) is pragma Warnings (Off); pragma Unreferenced (Self); pragma Warnings (On); begin if Oid /= null then -- UNIQUE policy: if already active, return the -- previous value. Result := Oid; else -- If this servant is not activated yet, try to do -- implicit activation now. declare U_Oid : Unmarshalled_Oid; begin PolyORB.POA.Activate_Object (PolyORB.POA.Obj_Adapter_Access (OA), P_Servant, Oid, U_Oid, Error); if Found (Error) then return; end if; Result := U_Oid_To_Oid (U_Oid); end; end if; end Activate_Again; end PolyORB.POA_Policies.Id_Uniqueness_Policy.Unique; polyorb-2.8~20110207.orig/src/polyorb-poa_policies-thread_policy-single_thread.ads0000644000175000017500000000604111750740340027447 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- POLYORB.POA_POLICIES.THREAD_POLICY.SINGLE_THREAD -- -- -- -- S p e c -- -- -- -- Copyright (C) 2003-2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ pragma Ada_2005; -- Implementation of the 'Single thread' POA Policy. with PolyORB.Components; with PolyORB.Requests; package PolyORB.POA_Policies.Thread_Policy.Single_Thread is type Single_Thread_Policy is new ThreadPolicy with private; type Single_Thread_Policy_Access is access all Single_Thread_Policy; function Create return Single_Thread_Policy_Access; procedure Check_Compatibility (Self : Single_Thread_Policy; Other_Policies : AllPolicies; Error : in out PolyORB.Errors.Error_Container); function Policy_Id (Self : Single_Thread_Policy) return String; private type Single_Thread_Policy is new ThreadPolicy with null record; type Single_Thread_Executor is new Servants.Executor with null record; overriding function Execute_In_Context (Self : access Single_Thread_Executor; Req : Requests.Request_Access; Requestor : Components.Component_Access) return Boolean; end PolyORB.POA_Policies.Thread_Policy.Single_Thread; polyorb-2.8~20110207.orig/src/polyorb-qos-service_contexts.adb0000644000175000017500000002057411750740340023524 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . Q O S . S E R V I C E _ C O N T E X T S -- -- -- -- B o d y -- -- -- -- Copyright (C) 2004-2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with Ada.Unchecked_Deallocation; with PolyORB.Request_QoS; package body PolyORB.QoS.Service_Contexts is use PolyORB.Representations.CDR.Common; use PolyORB.Request_QoS; use PolyORB.Types; use Service_Context_Lists; procedure Rebuild_Service_Contexts (QoS : in out QoS_Parameters); procedure Rebuild_QoS_Parameters (QoS : in out QoS_Parameters); function Get_Converter (Context_Id : Service_Id) return To_QoS_Parameter; procedure Free is new Ada.Unchecked_Deallocation (Encapsulation, Encapsulation_Access); To_Service_Context_Registry : array (QoS_Kind) of To_Service_Context := (others => null); type To_QoS_Parameter_Item is record Context_Id : Service_Id; Converter : To_QoS_Parameter; end record; package To_QoS_Parameter_Lists is new PolyORB.Utils.Chained_Lists (To_QoS_Parameter_Item); To_QoS_Parameter_Registry : To_QoS_Parameter_Lists.List; ------------------- -- Get_Converter -- ------------------- function Get_Converter (Context_Id : Service_Id) return To_QoS_Parameter is use To_QoS_Parameter_Lists; Iter : To_QoS_Parameter_Lists.Iterator := First (To_QoS_Parameter_Registry); begin while not Last (Iter) loop if Value (Iter).Context_Id = Context_Id then return Value (Iter).Converter; end if; Next (Iter); end loop; return null; end Get_Converter; -------------- -- Register -- -------------- procedure Register (QoS : QoS_Kind; Converter : To_Service_Context) is begin To_Service_Context_Registry (QoS) := Converter; end Register; procedure Register (Id : Service_Id; Converter : To_QoS_Parameter) is use To_QoS_Parameter_Lists; begin Append (To_QoS_Parameter_Registry, (Id, Converter)); end Register; ---------------------------- -- Rebuild_QoS_Parameters -- ---------------------------- procedure Rebuild_QoS_Parameters (QoS : in out QoS_Parameters) is SC : constant QoS_GIOP_Service_Contexts_Parameter_Access := QoS_GIOP_Service_Contexts_Parameter_Access (QoS (GIOP_Service_Contexts)); Iter : Iterator; begin if SC = null then return; end if; Iter := First (SC.Service_Contexts); while not Last (Iter) loop declare Cnv : constant To_QoS_Parameter := Get_Converter (Value (Iter).Context_Id); Aux : QoS_Parameter_Access; begin if Cnv /= null then Aux := Cnv.all (Value (Iter).all); if Aux /= null then Release (QoS (Aux.Kind)); QoS (Aux.Kind) := Aux; end if; end if; end; Next (Iter); end loop; end Rebuild_QoS_Parameters; ---------------------------------- -- Rebuild_Reply_QoS_Parameters -- ---------------------------------- procedure Rebuild_Reply_QoS_Parameters (Req : in out Requests.Request) is QoS : QoS_Parameters := Get_Reply_QoS (Req); begin Rebuild_QoS_Parameters (QoS); Set_Reply_QoS (Req, QoS); end Rebuild_Reply_QoS_Parameters; ------------------------------------ -- Rebuild_Reply_Service_Contexts -- ------------------------------------ procedure Rebuild_Reply_Service_Contexts (Req : in out Requests.Request) is QoS : QoS_Parameters := Get_Reply_QoS (Req); begin Rebuild_Service_Contexts (QoS); Set_Reply_QoS (Req, QoS); end Rebuild_Reply_Service_Contexts; ------------------------------------ -- Rebuild_Request_QoS_Parameters -- ------------------------------------ procedure Rebuild_Request_QoS_Parameters (Req : in out Requests.Request) is QoS : QoS_Parameters := Get_Request_QoS (Req); begin Rebuild_QoS_Parameters (QoS); Set_Request_QoS (Req, QoS); end Rebuild_Request_QoS_Parameters; -------------------------------------- -- Rebuild_Request_Service_Contexts -- -------------------------------------- procedure Rebuild_Request_Service_Contexts (Req : in out Requests.Request) is QoS : QoS_Parameters := Get_Request_QoS (Req); begin Rebuild_Service_Contexts (QoS); Set_Request_QoS (Req, QoS); end Rebuild_Request_Service_Contexts; ------------------------------ -- Rebuild_Service_Contexts -- ------------------------------ procedure Rebuild_Service_Contexts (QoS : in out QoS_Parameters) is SC : QoS_GIOP_Service_Contexts_Parameter_Access := QoS_GIOP_Service_Contexts_Parameter_Access (QoS (GIOP_Service_Contexts)); Aux : Service_Context; Iter : Iterator; Added : Boolean; begin if SC = null then SC := new QoS_GIOP_Service_Contexts_Parameter; end if; for J in QoS_Kind loop -- XXX We may define subtype of QoS_Kind which can't have -- GIOP_Service_Contexts literal. if J /= GIOP_Service_Contexts and then To_Service_Context_Registry (J) /= null then Aux := To_Service_Context_Registry (J).all (QoS (J)); Iter := First (SC.Service_Contexts); Added := False; while not Last (Iter) loop if Value (Iter).Context_Id = Aux.Context_Id then if Aux.Context_Data = null then Remove (SC.Service_Contexts, Iter); else Free (Value (Iter).Context_Data); Value (Iter).Context_Data := Aux.Context_Data; end if; Added := True; exit; end if; Next (Iter); end loop; if not Added and then Aux.Context_Data /= null then Append (SC.Service_Contexts, Aux); end if; end if; end loop; QoS (GIOP_Service_Contexts) := QoS_Parameter_Access (SC); end Rebuild_Service_Contexts; ---------------------- -- Release_Contents -- ---------------------- procedure Release_Contents (QoS : access QoS_GIOP_Service_Contexts_Parameter) is Iter : Iterator := First (QoS.Service_Contexts); begin while not Last (Iter) loop Free (Value (Iter).Context_Data); Next (Iter); end loop; Deallocate (QoS.Service_Contexts); end Release_Contents; end PolyORB.QoS.Service_Contexts; polyorb-2.8~20110207.orig/src/polyorb-poa_policies-thread_policy-single_thread.adb0000644000175000017500000001473111750740340027433 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- POLYORB.POA_POLICIES.THREAD_POLICY.SINGLE_THREAD -- -- -- -- B o d y -- -- -- -- Copyright (C) 2003-2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- Implementation of the POA Policy 'Single Thread'. -- Under this policy, upcalls made by a POA shall not be made concurrently. -- The POA will still allow reentrant code from any object implementation to -- itself, or to another object implementation managed by the same POA. with PolyORB.Annotations; with PolyORB.Log; with PolyORB.Tasking.Advanced_Mutexes; package body PolyORB.POA_Policies.Thread_Policy.Single_Thread is use PolyORB.Log; package L is new PolyORB.Log.Facility_Log ("polyorb.poa_policies.thread_policy.single_thread"); procedure O (Message : Standard.String; Level : Log_Level := Debug) renames L.Output; function C (Level : Log_Level := Debug) return Boolean renames L.Enabled; type ST_Note is new PolyORB.Annotations.Note with record Lock : PolyORB.Tasking.Advanced_Mutexes.Adv_Mutex_Access; end record; Empty_Note : constant ST_Note := (PolyORB.Annotations.Note with Lock => null); ------------ -- Create -- ------------ function Create return Single_Thread_Policy_Access is Result : constant Single_Thread_Policy_Access := new Single_Thread_Policy; begin ThreadPolicy (Result.all).Executor := new Single_Thread_Executor; return Result; end Create; ------------------------- -- Check_Compatibility -- ------------------------- procedure Check_Compatibility (Self : Single_Thread_Policy; Other_Policies : AllPolicies; Error : in out PolyORB.Errors.Error_Container) is pragma Warnings (Off); pragma Unreferenced (Self); pragma Unreferenced (Other_Policies); pragma Unreferenced (Error); pragma Warnings (On); begin null; -- No rule to test end Check_Compatibility; --------------- -- Policy_Id -- --------------- function Policy_Id (Self : Single_Thread_Policy) return String is pragma Warnings (Off); pragma Unreferenced (Self); pragma Warnings (On); begin return "THREAD_POLICY.SINGLE_THREAD"; end Policy_Id; ------------------------ -- Execute_In_Context -- ------------------------ function Execute_In_Context (Self : access Single_Thread_Executor; Req : Requests.Request_Access; Requestor : Components.Component_Access) return Boolean is use PolyORB.Annotations; use PolyORB.Servants; use PolyORB.Tasking.Advanced_Mutexes; pragma Warnings (Off); pragma Unreferenced (Self); pragma Warnings (On); N : ST_Note; begin -- This policy only prevents us to make concurrent calls to the -- same servant, but allows us to make reentrant call. -- To implement this policy we attach an Advanced Mutex to the -- servant. This construction provides the above expected -- properties. -- XXX reentrant calls are not fully supported. Currently ORB.Run -- does not allow to specify the thread attached to request handling. -- This work in No_Tasking tasking policy. pragma Debug (C, O ("Execute_In_Context: Enter")); -- Test if the servant has been attached to a advanced mutex. -- XXX Note that this could (should ?) be done by the POA. -- when setting the thread policy. This would avoid a call to -- Get Note to test if there is Adv_Mutex already attached. -- but the POA will require visibility on this package ... Get_Note (Notepad_Of (Servant_Access (Requestor)).all, N, Empty_Note); if N = Empty_Note then declare AM : Adv_Mutex_Access; New_Note : ST_Note; begin pragma Debug (C, O ("Attach a mutex to the servant.")); Create (AM); New_Note := (PolyORB.Annotations.Note with Lock => AM); Set_Note (Notepad_Of (Servant_Access (Requestor)).all, New_Note); end; end if; Get_Note (Notepad_Of (Servant_Access (Requestor)).all, N); pragma Debug (C, O ("Waiting on servant's lock")); Enter (N.Lock); pragma Debug (C, O ("Waiting done")); -- Now execute the request in the current task declare Res : constant Boolean := Abortable_Execute_Servant (Servant_Access (Requestor), Req); begin Leave (N.Lock); return Res; end; end Execute_In_Context; end PolyORB.POA_Policies.Thread_Policy.Single_Thread; polyorb-2.8~20110207.orig/src/polyorb-poa_policies-id_uniqueness_policy-multiple.ads0000644000175000017500000000620111750740340030074 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- POLYORB.POA_POLICIES.ID_UNIQUENESS_POLICY.MULTIPLE -- -- -- -- S p e c -- -- -- -- Copyright (C) 2002-2005 Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ package PolyORB.POA_Policies.Id_Uniqueness_Policy.Multiple is type Multiple_Id_Policy is new IdUniquenessPolicy with null record; type Multiple_Id_Policy_Access is access all Multiple_Id_Policy; function Create return Multiple_Id_Policy_Access; procedure Check_Compatibility (Self : Multiple_Id_Policy; Other_Policies : AllPolicies; Error : in out PolyORB.Errors.Error_Container); function Policy_Id (Self : Multiple_Id_Policy) return String; procedure Ensure_Servant_Uniqueness (Self : Multiple_Id_Policy; OA : PolyORB.POA_Types.Obj_Adapter_Access; P_Servant : Servants.Servant_Access; Error : in out PolyORB.Errors.Error_Container); procedure Activate_Again (Self : Multiple_Id_Policy; OA : PolyORB.POA_Types.Obj_Adapter_Access; P_Servant : Servants.Servant_Access; Oid : Object_Id_Access; Result : out Object_Id_Access; Error : in out PolyORB.Errors.Error_Container); end PolyORB.POA_Policies.Id_Uniqueness_Policy.Multiple; polyorb-2.8~20110207.orig/src/polyorb-errors.ads0000644000175000017500000002270611750740340020671 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . E R R O R S -- -- -- -- S p e c -- -- -- -- Copyright (C) 2005-2009, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- Errors management subsystem with Ada.Unchecked_Deallocation; with PolyORB.Smart_Pointers; with PolyORB.Types; package PolyORB.Errors is pragma Preelaborate; ------------------------ -- Exceptions Members -- ------------------------ -- A PolyORB error is notionally equivalent to a CORBA exception. -- It is composed of: -- - Exception Id, -- - Exception Member. type Exception_Members is abstract tagged null record; -- Base type for all PolyORB exception members. A member is a -- record attached to an exception that allows the programmer to -- pass arguments when an exception is raised. type Exception_Members_Access is access all Exception_Members'Class; procedure Free is new Ada.Unchecked_Deallocation (Exception_Members'Class, Exception_Members_Access); ----------------------- -- Completion_Status -- ----------------------- type Completion_Status is (Completed_Yes, Completed_No, Completed_Maybe); -- Characterize the completion state of the execution process when -- systeme exception has been raised. -- Null_Members type Null_Members is new Exception_Members with null record; Null_Member : constant Null_Members := Null_Members'(Exception_Members with null record); -- System_Exception_Members type System_Exception_Members is new Exception_Members with record Minor : PolyORB.Types.Unsigned_Long; Completed : Completion_Status; end record; -- InvalidPolicy_Members type InvalidPolicy_Members is new Exception_Members with record Index : PolyORB.Types.Unsigned_Short; end record; -- ForwardRequest_Members type ForwardRequest_Members is new Exception_Members with record Forward_Reference : PolyORB.Smart_Pointers.Ref; end record; -- ForwardRequestPerm_Members type ForwardRequestPerm_Members is new Exception_Members with record Forward_Reference : PolyORB.Smart_Pointers.Ref; end record; -- NeedsAddressingMode_Members type Addressing_Mode is (Key, Profile, Reference); type NeedsAddressingMode_Members is new Exception_Members with record Mode : Addressing_Mode; end record; ---------------- -- ORB Errors -- ---------------- type Error_Id is ( No_Error, -- no error -- One to one mapping of CORBA System exceptions. Unknown_E, -- unknown exception Bad_Param_E, -- an invalid parameter was passed No_Memory_E, -- dynamic memory allocation failure Imp_Limit_E, -- violated implementation limit Comm_Failure_E, -- communication failure Inv_Objref_E, -- invalid object reference No_Permission_E, -- no permission for attempted op. Internal_E, -- ORB internal error Marshal_E, -- error marshalling param/result Initialize_E, -- ORB initialization failure No_Implement_E, -- operation impleme. unavailable Bad_TypeCode_E, -- bad typecode Bad_Operation_E, -- invalid operation No_Resources_E, -- insufficient resources for req. No_Response_E, -- response to request not available Persist_Store_E, -- persistent storage failure Bad_Inv_Order_E, -- routine invocations out of order Transient_E, -- transient failure - reissue request Free_Mem_E, -- cannot free memory Inv_Ident_E, -- invalid identifier syntax Inv_Flag_E, -- invalid flag was specified Intf_Repos_E, -- error accessing intf. repository Bad_Context_E, -- error processing context object Obj_Adapter_E, -- failure detected by object adapter Data_Conversion_E, -- data conversion error Object_Not_Exist_E, -- non-existent object, delete ref. Transaction_Required_E, -- transaction required Transaction_Rolledback_E, -- transaction rolled back Invalid_Transaction_E, -- invalid transaction Inv_Policy_E, -- invalid policy Codeset_Incompatible_E, -- incompatible code set Rebind_E, -- rebind needed Timeout_E, -- operation timed out Transaction_Unavailable_E, -- no transaction Transaction_Mode_E, -- invalid transaction mode Bad_Qos_E, -- bad quality of service -- Special case for processing PortableServer's and -- PortableInterceptor's ForwardRequest exception. ForwardRequest_E, -- Special error code for Fault Tolerant permanent location forwarding ForwardRequestPerm_E, -- Special error code for requesting GIOP addressing mode NeedsAddressingMode_E, -- One to one mapping of POA exceptions. AdapterAlreadyExists_E, AdapterNonExistent_E, InvalidPolicy_E, NoServant_E, ObjectAlreadyActive_E, ObjectNotActive_E, ServantAlreadyActive_E, ServantNotActive_E, WrongAdapter_E, WrongPolicy_E, -- One to one mapping of POA Manager exceptions. AdapterInactive_E, -- PolyORB internal errors. Invalid_Object_Id_E, -- Group exception NotAGroupObject_E ); subtype ORB_System_Error is Error_Id range Unknown_E .. Bad_Qos_E; subtype POA_Error is Error_Id range AdapterAlreadyExists_E .. WrongPolicy_E; subtype POAManager_Error is Error_Id range AdapterInactive_E .. AdapterInactive_E; subtype PolyORB_Internal_Error is Error_Id range Invalid_Object_Id_E .. Error_Id'Last; ---------------------- -- Error management -- ---------------------- type Error_Container is record Kind : Error_Id := No_Error; Member : Exception_Members_Access; end record; function Found (Error : Error_Container) return Boolean; -- True iff Error is not No_Error procedure Throw (Error : in out Error_Container; Kind : Error_Id; Member : Exception_Members'Class); -- Generates an error with Kind and Member information procedure Catch (Error : in out Error_Container); -- Acknowledge Error and reset its content function Is_Error (Error : Error_Container) return Boolean; -- True iff Error is not No_Error ------------------ -- Exception Id -- ------------------ -- An exception Id has the following form: -- NameSpace:Root'Separator' .. Version PolyORB_Exc_NameSpace : constant String; -- PolyORB exceptions namespace PolyORB_Exc_Root : constant String; -- PolyORB exceptions root PolyORB_Exc_Separator : constant String; -- PolyORB exceptions separator PolyORB_Exc_Prefix : constant String; -- Concantenation of PolyORB_Exc_NameSpace, PolyORB_Root and -- PolyORB_Separator PolyORB_Exc_Version : constant String; -- PolyORB exceptions version private PolyORB_Exc_NameSpace : constant String := "INTERNAL:"; PolyORB_Exc_Root : constant String := "POLYORB"; PolyORB_Exc_Separator : constant String := "/"; PolyORB_Exc_Prefix : constant String := PolyORB_Exc_NameSpace & PolyORB_Exc_Root & PolyORB_Exc_Separator; PolyORB_Exc_Version : constant String := ":1.0"; end PolyORB.Errors; polyorb-2.8~20110207.orig/src/polyorb-opaque.adb0000644000175000017500000000441111750740340020617 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . O P A Q U E -- -- -- -- B o d y -- -- -- -- Copyright (C) 2001-2008, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ package body PolyORB.Opaque is ------------- -- Is_Null -- ------------- function Is_Null (P : Opaque_Pointer) return Boolean is use type System.Address; begin return P = System.Null_Address; end Is_Null; end PolyORB.Opaque; polyorb-2.8~20110207.orig/src/TODO0000644000175000017500000001624511750740337015677 0ustar xavierxavierTODO for PolyORB --------------- $Id: TODO 36489 2004-12-23 14:09:08Z quinot $ DSA implementation (CA22-003) ------------------ * DSA: When taking 'Access on a local RCI subprogram, have only 1 instance of the relay object for the whole partition. (cf. tardieu99 4.6.2) * Ada 95 DSA personality: -> Asynchronous (5910, partial) -> RACW 'Read/'Write -> map system exceptions to System.RPC.Communication_Error. * Ability to specify boot server location by hostname and port number * Make the process of locating the name server transparent * filters * termination * reconnect * version checking Items still requiring attention ------------------------------- * Add an IDL output to po_dumpir. * Document flexible configuration pragmas framework introduced in change 8053. * Suppress Set_CDR_Position from buffer interface, which is needed by the MIOP personality to fragment buffers from UDP sockets. * Establish a configurable connection cache so requests to the same object made though different references can share the same binding object. * Give a look at the ac_prog_cc_for_build from http://ac-archive.sourceforge.net/ to clean up configure script when cross-compiling. * Review stack usage (for example, all_types fails with the default stack size, pragmas Storage_Size are needed in full_tasking and Ravenscar to allow it to proceed). * Create a new PolyORB.Tasking.Time_Stamps package to allow the creation of time stamps. Use it in P.POA.Basic_POA.Time_Stamps and in MOMA. * Merge Dynamic_Tables and Sequences. * Close connection with server properly (ie : generate a 'close connection' message) * GIOP stack: Implement the management of the context list. * GIOP stack: Implement the management of locate messages. * Implement CORBA bounded strings * When registering a profile tag, the associated representation subprograms should be To_Any and From_Any, not CDR marshalling subprograms. * Clarify the uniform interface of representations: create a PolyORB.Representations.SOAP.SOAP__Representation type (derived from P.R.Representation). * Extend Transport framework with a new abstract class Transport_Access_Point_Name with a bind() primitive operation that returns a Transport_Endpoint. * Factor out common code between different versions of PolyORB.Binding_Data.*. * Incorporate Transport_Access_Point_Name usage as a Binding_Object_Fragment_Factory (extension of the notion of Filter_Factory to fragments of binding objects that are not filter). Think Netgraph. * Bind-time configuration tool (to help the user generate a configuration package suited to his needs.) * Run-time configuration of loaded functionality (using Adaplugins ?) * See whether Buffers.Set_Initial_Position can be made private or moved to unit body. * Support logging to syslog (also for Java ?) * PolyORB.Buffers: remove mentions of CDR (most notably, the Endianness property of a buffer and all endianness considerations are irrelevant to PolyORB.Buffers). * PolyORB.Buffers: Zero-copy buffers. * Configuration of memory allocation: -> real-time allocator? -> usage of Storage_Pools? -> static allocation? -> smart resource management (garbage collection, system audit...)? See Allocator abstract class in Quarterware. * HTTP as a Protocol (to be used with Minimal_Servant to compose a web server). * Remove SOAP-specific stuff from the HTTP filter (SOAPAction handling), move that to a SOAP/HTTP binding filter, with the following resulting architecture: SOAP ^ | v SOAP/HTTP binding ^ | v HTTP * CSTA protocol (for telephony applications.) * Alternative implementations of transport endpoints: -> A mechanism for optional implementation of reliable message delivery over a non-reliable message delivery protocol (eg UDP with ack/retransmission, Group_IO) -> A mechanism for message exchange not based on sockets (eg SysV IPC, serial lines). * Architecture documentation. Items processed --------------- * PolyORB.Buffers: remove dependency upon sockets (8945) * Clarify the uniform interface of representations: create a PolyORB.Representations.CDR.CDR_Representation type (derived from P.R.Representation) (8544) * Implement CORBA fixed-point types (8516) * Exception support: separate personality-specific (CORBA) code from generic code. Check proper implementation of DSA exceptions. Document mapping between both models (6642). * Portableserver: Instead of using a flat list All_Skeletons, add a primitive operation to PortableServer.Servant_Base that returns a Skeleton_Info access. This removes the need for a critical section list traversal in Find_Info. This is implemented by change #7237. In fact, the Skeleton_Info access is cached in the servant's notepad. * Review initialization of the object adapter attached to ORB, to enable setup of POA proxies during modules' initialization (7417). * DSA migration -> From_Any and To_Any for tagged records and variant records (7690, 7693, 7694, 7697, 7703, 7705, 7855). * Fix memory leaks (to be checked with Debug_Pools disabled!) (one known memory leak in allocation/deallocation of Any's TypeCode in exception handling) (5724, 5864, 5897, 5915, 5981, 6076, 6507, 6508). * Data reception: when the protocol knows how much data will arrive, preallocate so that unmarshalling is guaranteed to be presented with contiguous data. When it does not, Receive_Buffer should call Receive_Socket with Length no greater than the available space in the chunk, and advance the current position by the exact size of the received data (2770). * Rework PolyORB.ORB event handling: The event handling loop must occur within the critical section (because it must mask certain sockets). Jobs should be created for each event, which will be actually processed by ORB tasks (2770). * A filter to gather a message of a given size from lower layers before signalling to upper layers (as did the old Channel type) (2830). * An abstraction of transport endpoints (2871). * An object adapter. * Use of the Ravenscar profile. * Profile type registration system (for References.IOR). For a profile to be used when creating and parsing IORs, its tag must be registered. * Move CORBA.POA to PolyORB. (3329). * Make PolyORB.References.Ref a Smart_Pointers.Entity so the list of profiles can be free'd when not used anymore. * When a connection is closed, release all associated resources. * Make compliant PortableServer tree for CORBA personality. * Correct handling of arg modes in SOAP (in/inout/out). The SOAP engine sees incoming argument and marks them as IN. If the object expects some args to be inout or out, make sure that before calling the object, the parameters are present and marked with proper modes. Then, the SOAP engine knows to send out any INOUT or OUT argument with the reply. * Make idlac compilable under -gnaty. * DSA: support for user exceptions * Add a flag to Register_Module to enable selective initialization of a module. * Alternative implementations of transport endpoints: -> A mechanism for use of non-connected message passing protocols (UDP) polyorb-2.8~20110207.orig/src/polyorb-qos-static_buffers.ads0000644000175000017500000000471511750740340023160 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . Q O S . S T A T I C _ B U F F E R S -- -- -- -- S p e c -- -- -- -- Copyright (C) 2007, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with PolyORB.Buffers; package PolyORB.QoS.Static_Buffers is type QoS_GIOP_Static_Buffer_Parameter is new QoS_Parameter (GIOP_Static_Buffer) with record Buffer : PolyORB.Buffers.Buffer_Access; end record; type QoS_GIOP_Static_Buffer_Parameter_Access is access all QoS_GIOP_Static_Buffer_Parameter'Class; procedure Release_Content (QoS : access QoS_GIOP_Static_Buffer_Parameter); end PolyORB.QoS.Static_Buffers; polyorb-2.8~20110207.orig/src/polyorb-asynch_ev-sockets.ads0000644000175000017500000001007611750740340023002 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . A S Y N C H _ E V . S O C K E T S -- -- -- -- S p e c -- -- -- -- Copyright (C) 2001-2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- An asynchrous event source that is a set of socket descriptors. with PolyORB.Sockets; with PolyORB.Utils.Ilists; package PolyORB.Asynch_Ev.Sockets is pragma Elaborate_Body; type Socket_Event_Monitor is new Asynch_Ev_Monitor with private; procedure Create (AEM : out Socket_Event_Monitor); procedure Destroy (AEM : in out Socket_Event_Monitor); function Has_Sources (AEM : Socket_Event_Monitor) return Boolean; type Socket_Event_Source is new Asynch_Ev_Source with private; procedure Register_Source (AEM : access Socket_Event_Monitor; AES : Asynch_Ev_Source_Access; Success : out Boolean); procedure Unregister_Source (AEM : in out Socket_Event_Monitor; AES : Asynch_Ev_Source_Access; Success : out Boolean); function Check_Sources (AEM : access Socket_Event_Monitor; Timeout : Duration) return AES_Array; procedure Abort_Check_Sources (AEM : Socket_Event_Monitor); function Create_Event_Source (Socket : PolyORB.Sockets.Socket_Type) return Asynch_Ev_Source_Access; function AEM_Factory_Of (AES : Socket_Event_Source) return AEM_Factory; private package Ilists renames Utils.Ilists; type SES_Access is access all Socket_Event_Source'Class; type Links_Type is array (Ilists.Link_Type) of aliased SES_Access; type Socket_Event_Source is new Asynch_Ev_Source with record Links : Links_Type; Socket : PolyORB.Sockets.Socket_Type; end record; function Link (S : access Socket_Event_Source'Class; Which : Ilists.Link_Type) return access SES_Access; pragma Inline (Link); -- Accessor for Links package Source_Lists is new Ilists.Lists (T => Socket_Event_Source'Class, T_Acc => SES_Access, Doubly_Linked => True); type Socket_Event_Monitor is new Asynch_Ev_Monitor with record Selector : PolyORB.Sockets.Selector_Type; Monitored_Set : PolyORB.Sockets.Socket_Set_Type; Sources : Source_Lists.List; end record; end PolyORB.Asynch_Ev.Sockets; polyorb-2.8~20110207.orig/src/polyorb-orb_controller-half_sync_half_async.ads0000644000175000017500000001013511750740340026526 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- POLYORB.ORB_CONTROLLER.HALF_SYNC_HALF_ASYNC -- -- -- -- S p e c -- -- -- -- Copyright (C) 2004-2008, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- Half-Sync/Half-Async ORB Controller for PolyORB ORB main loop -- It is a tasking ORB Controller implementation, it supports -- multi-tasking ORB only. -- Under this implementation, a set of dedicated tasks monitor AES, -- the other tasks process requests. package PolyORB.ORB_Controller.Half_Sync_Half_Async is type ORB_Controller_Half_Sync_Half_Async is new ORB_Controller with private; type ORB_Controller_Half_Sync_Half_Async_Access is access all ORB_Controller_Half_Sync_Half_Async'Class; procedure Notify_Event (O : access ORB_Controller_Half_Sync_Half_Async; E : Event); procedure Schedule_Task (O : access ORB_Controller_Half_Sync_Half_Async; TI : PTI.Task_Info_Access); procedure Disable_Polling (O : access ORB_Controller_Half_Sync_Half_Async; M : PAE.Asynch_Ev_Monitor_Access); procedure Enable_Polling (O : access ORB_Controller_Half_Sync_Half_Async; M : PAE.Asynch_Ev_Monitor_Access); type ORB_Controller_Half_Sync_Half_Async_Factory is new ORB_Controller_Factory with private; function Create (OCF : ORB_Controller_Half_Sync_Half_Async_Factory) return ORB_Controller_Access; private -- Under this ORB controller implementation, a set of dedicated -- tasks monitor AEM, this structure stores their information. type Monitoring_Task_Control is record Job_Queue : PJ.Job_Queue_Access; -- Specific job queue of jobs to be processed by the blocked task. -- XXX replace it by an array ? CV : PTCV.Condition_Access; Idle : Boolean := False; end record; type MTC_Array is array (Natural range <>) of Monitoring_Task_Control; type ORB_Controller_Half_Sync_Half_Async is new ORB_Controller with record Monitoring_Tasks : MTC_Array (1 .. Maximum_Number_Of_Monitors); end record; type ORB_Controller_Half_Sync_Half_Async_Factory is new ORB_Controller_Factory with null record; OCF : constant ORB_Controller_Factory_Access := new ORB_Controller_Half_Sync_Half_Async_Factory; end PolyORB.ORB_Controller.Half_Sync_Half_Async; polyorb-2.8~20110207.orig/src/polyorb-poa_policies-servant_retention_policy-retain.ads0000644000175000017500000000733211750740340030427 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- POLYORB.POA_POLICIES.SERVANT_RETENTION_POLICY.RETAIN -- -- -- -- S p e c -- -- -- -- Copyright (C) 2001-2005 Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ package PolyORB.POA_Policies.Servant_Retention_Policy.Retain is type Retain_Policy is new ServantRetentionPolicy with null record; type Retain_Policy_Access is access all Retain_Policy; function Create return Retain_Policy_Access; procedure Check_Compatibility (Self : Retain_Policy; Other_Policies : AllPolicies; Error : in out PolyORB.Errors.Error_Container); function Policy_Id (Self : Retain_Policy) return String; procedure Retain_Servant_Association (Self : Retain_Policy; OA : PolyORB.POA_Types.Obj_Adapter_Access; P_Servant : Servants.Servant_Access; U_Oid : Unmarshalled_Oid; Error : in out PolyORB.Errors.Error_Container); procedure Forget_Servant_Association (Self : Retain_Policy; OA : PolyORB.POA_Types.Obj_Adapter_Access; U_Oid : Unmarshalled_Oid; Error : in out PolyORB.Errors.Error_Container); function Retained_Servant_To_Id (Self : Retain_Policy; OA : PolyORB.POA_Types.Obj_Adapter_Access; P_Servant : Servants.Servant_Access) return Object_Id_Access; procedure Retained_Id_To_Servant (Self : Retain_Policy; OA : PolyORB.POA_Types.Obj_Adapter_Access; U_Oid : Unmarshalled_Oid; Servant : out Servants.Servant_Access; Error : in out PolyORB.Errors.Error_Container); procedure Ensure_Servant_Manager_Type (Self : Retain_Policy; Manager : ServantManager'Class; Error : in out PolyORB.Errors.Error_Container); end PolyORB.POA_Policies.Servant_Retention_Policy.Retain; polyorb-2.8~20110207.orig/src/polyorb-tasking-profiles-full_tasking-portable_mutexes.ads0000644000175000017500000000706411750740340030676 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- POLYORB.TASKING.PROFILES.FULL_TASKING.PORTABLE_MUTEXES -- -- -- -- S p e c -- -- -- -- Copyright (C) 2002-2005 Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- Implementation of mutexes under the Full_Tasking profile. -- This is a variant that uses only standard Ada constructs. It is not -- used by default. with PolyORB.Tasking.Mutexes; package PolyORB.Tasking.Profiles.Full_Tasking.Portable_Mutexes is package PTM renames PolyORB.Tasking.Mutexes; type Full_Tasking_Mutex_Type is new PTM.Mutex_Type with private; type Full_Tasking_Mutex_Access is access all Full_Tasking_Mutex_Type'Class; procedure Enter (M : access Full_Tasking_Mutex_Type); pragma Inline (Enter); procedure Leave (M : access Full_Tasking_Mutex_Type); pragma Inline (Leave); type Full_Tasking_Mutex_Factory_Type is new PTM.Mutex_Factory_Type with private; type Full_Tasking_Mutex_Factory_Access is access all Full_Tasking_Mutex_Factory_Type'Class; The_Mutex_Factory : constant Full_Tasking_Mutex_Factory_Access; function Create (MF : access Full_Tasking_Mutex_Factory_Type; Name : String := "") return PTM.Mutex_Access; procedure Destroy (MF : access Full_Tasking_Mutex_Factory_Type; M : in out PTM.Mutex_Access); private type Mutex_PO; type Mutex_PO_Access is access Mutex_PO; type Full_Tasking_Mutex_Type is new PTM.Mutex_Type with record The_PO : Mutex_PO_Access; end record; type Full_Tasking_Mutex_Factory_Type is new PTM.Mutex_Factory_Type with null record; The_Mutex_Factory : constant Full_Tasking_Mutex_Factory_Access := new Full_Tasking_Mutex_Factory_Type; end PolyORB.Tasking.Profiles.Full_Tasking.Portable_Mutexes; polyorb-2.8~20110207.orig/src/polyorb-any-objref.ads0000644000175000017500000000476211750740340021413 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . A N Y . O B J R E F -- -- -- -- S p e c -- -- -- -- Copyright (C) 2001-2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- Any's that contain object references. with PolyORB.References; package PolyORB.Any.ObjRef is pragma Elaborate_Body; procedure Set_Any_Value (X : References.Ref; C : in out Any_Container'Class); function To_Any (X : References.Ref) return Any; function Wrap (X : not null access References.Ref) return Content'Class; function From_Any (A : Any) return References.Ref; function From_Any (C : Any_Container'Class) return References.Ref; end PolyORB.Any.ObjRef; polyorb-2.8~20110207.orig/src/polyorb-poa_policies-id_uniqueness_policy.ads0000644000175000017500000000657211750740340026256 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- POLYORB.POA_POLICIES.ID_UNIQUENESS_POLICY -- -- -- -- S p e c -- -- -- -- Copyright (C) 2001-2005 Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with PolyORB.POA_Types; with PolyORB.Servants; package PolyORB.POA_Policies.Id_Uniqueness_Policy is use PolyORB.POA_Types; type IdUniquenessPolicy is abstract new Policy with null record; type IdUniquenessPolicy_Access is access all IdUniquenessPolicy'Class; procedure Ensure_Servant_Uniqueness (Self : IdUniquenessPolicy; OA : PolyORB.POA_Types.Obj_Adapter_Access; P_Servant : Servants.Servant_Access; Error : in out PolyORB.Errors.Error_Container) is abstract; -- Case UNIQUE_ID: -- Checks that the specified servant is not yet in the Active Objects Map. -- If not, throws a ServantAlreadyActive exception. -- Case MULTIPLE_ID: -- Does nothing procedure Activate_Again (Self : IdUniquenessPolicy; OA : PolyORB.POA_Types.Obj_Adapter_Access; P_Servant : Servants.Servant_Access; Oid : Object_Id_Access; Result : out Object_Id_Access; Error : in out PolyORB.Errors.Error_Container) is abstract; -- Case UNIQUE_ID: -- if Oid is not null, return Oid, else try implicit -- activation and return the created Oid. -- Case MULTIPLE_ID: try implicit activation and return -- the created oid ((regardless of the Oid argument). end PolyORB.POA_Policies.Id_Uniqueness_Policy; polyorb-2.8~20110207.orig/src/polyorb-setup-oa-basic_poa.ads0000644000175000017500000000422511750740340023024 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . S E T U P . O A . B A S I C _ P O A -- -- -- -- S p e c -- -- -- -- Copyright (C) 2003 Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by ACT Europe. -- -- (email: sales@act-europe.fr) -- -- -- ------------------------------------------------------------------------------ -- Set up a Basic Portable Object Adapter package PolyORB.Setup.OA.Basic_POA is pragma Elaborate_Body; end PolyORB.Setup.OA.Basic_POA; polyorb-2.8~20110207.orig/src/polyorb-qos.adb0000644000175000017500000000615511750740340020136 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . Q O S -- -- -- -- B o d y -- -- -- -- Copyright (C) 2005-2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with Ada.Unchecked_Deallocation; with PolyORB.Types; package body PolyORB.QoS is use PolyORB.Types; ----------- -- Image -- ----------- function Image (QoS : QoS_Parameters) return String is Result : PolyORB.Types.String := To_PolyORB_String (""); begin for J in QoS'Range loop if QoS (J) /= null then Result := Result & To_PolyORB_String (QoS_Kind'Image (QoS (J).Kind) & ","); end if; end loop; return To_Standard_String (Result); end Image; ------------- -- Release -- ------------- procedure Release (QoS : in out QoS_Parameter_Access) is procedure Free is new Ada.Unchecked_Deallocation (QoS_Parameter'Class, QoS_Parameter_Access); begin if QoS /= null then Release_Contents (QoS); Free (QoS); end if; end Release; ---------------------- -- Release_Contents -- ---------------------- procedure Release_Contents (QoS : access QoS_Parameter) is pragma Unreferenced (QoS); begin null; end Release_Contents; end PolyORB.QoS; polyorb-2.8~20110207.orig/src/polyorb-poa_policies-implicit_activation_policy-no_activation.ads0000644000175000017500000000614511750740340032265 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- POLYORB.POA_POLICIES.IMPLICIT_ACTIVATION_POLICY.NO_ACTIVATION -- -- -- -- S p e c -- -- -- -- Copyright (C) 2001-2005 Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ package PolyORB.POA_Policies.Implicit_Activation_Policy.No_Activation is type No_Activation_Policy is new ImplicitActivationPolicy with null record; type No_Activation_Policy_Access is access all No_Activation_Policy; function Create return No_Activation_Policy_Access; procedure Check_Compatibility (Self : No_Activation_Policy; Other_Policies : AllPolicies; Error : in out PolyORB.Errors.Error_Container); function Policy_Id (Self : No_Activation_Policy) return String; procedure Implicit_Activate_Servant (Self : No_Activation_Policy; OA : PolyORB.POA_Types.Obj_Adapter_Access; P_Servant : Servants.Servant_Access; Hint : Object_Id_Access; Oid : out Object_Id_Access; Error : in out PolyORB.Errors.Error_Container); procedure Ensure_No_Implicit_Activation (Self : No_Activation_Policy; Error : in out PolyORB.Errors.Error_Container); end PolyORB.POA_Policies.Implicit_Activation_Policy.No_Activation; polyorb-2.8~20110207.orig/src/polyorb-setup-proxies_poa.adb0000644000175000017500000000635111750740340023020 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . S E T U P . P R O X I E S _ P O A -- -- -- -- B o d y -- -- -- -- Copyright (C) 2002-2005 Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with PolyORB.Parameters; with PolyORB.POA_Manager; with PolyORB.POA_Config.Proxies; with PolyORB.POA.Basic_POA; procedure PolyORB.Setup.Proxies_POA (Root_POA_Object : PolyORB.POA.Obj_Adapter_Access; Error : in out PolyORB.Errors.Error_Container) is use PolyORB.POA_Manager; use PolyORB.POA.Basic_POA; use type PolyORB.POA.Obj_Adapter_Access; Proxies_POA_Configuration : POA_Config.Proxies.Configuration; Proxy_POA : PolyORB.POA.Obj_Adapter_Access; begin if PolyORB.Parameters.Get_Conf ("proxies", "enable_proxies", False) then pragma Assert (Root_POA_Object /= null); PolyORB.POA.Basic_POA.Create_POA (Basic_Obj_Adapter (Root_POA_Object.all)'Access, "Proxies", POAManager_Access (Entity_Of (Root_POA_Object.POA_Manager)), POA_Config.Default_Policies (POA_Config.Configuration_Type'Class (Proxies_POA_Configuration)), Proxy_POA, Error); if PolyORB.Errors.Found (Error) then return; end if; PolyORB.POA.Basic_POA.Set_Proxies_OA (POA.Basic_POA.Basic_Obj_Adapter_Access (Root_POA_Object), POA.Basic_POA.Basic_Obj_Adapter_Access (Proxy_POA)); end if; end PolyORB.Setup.Proxies_POA; polyorb-2.8~20110207.orig/src/polyorb-references-uri.adb0000644000175000017500000002471411750740340022253 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . R E F E R E N C E S . U R I -- -- -- -- B o d y -- -- -- -- Copyright (C) 2003-2009, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with PolyORB.Initialization; with PolyORB.Log; with PolyORB.Utils.Chained_Lists; with PolyORB.Types; package body PolyORB.References.URI is use PolyORB.Binding_Data; use PolyORB.Log; use PolyORB.Utils.Strings; package L is new PolyORB.Log.Facility_Log ("polyorb.references.uri"); procedure O (Message : String; Level : Log_Level := Debug) renames L.Output; function C (Level : Log_Level := Debug) return Boolean renames L.Enabled; type Profile_Record is record Tag : PolyORB.Binding_Data.Profile_Tag; Proto_Ident : String_Ptr; Profile_To_String_Body : Profile_To_String_Body_Type; String_To_Profile_Body : String_To_Profile_Body_Type; end record; package Profile_Record_List is new PolyORB.Utils.Chained_Lists (Profile_Record); use Profile_Record_List; Callbacks : Profile_Record_List.List; Null_String : constant String := ""; type Tag_Array is array (Natural range <>) of Profile_Tag; type String_Array is array (Integer range <>) of String_Ptr; ----------------------- -- Local subprograms -- ----------------------- procedure Get_URI_List (URI : URI_Type; URI_List : out String_Array; Tag_List : out Tag_Array; N : out Natural); -- Return the list of all URIs found in URI function String_To_Profile (Obj_Addr : String) return Binding_Data.Profile_Access; -- Returns null if it failed function Profile_To_String (P : Binding_Data.Profile_Access) return String; procedure Free (SA : in out String_Array); -- Free a String_Array ------------------ -- Get_URI_List -- ------------------ procedure Get_URI_List (URI : URI_Type; URI_List : out String_Array; Tag_List : out Tag_Array; N : out Natural) is Profs : constant Profile_Array := Profiles_Of (URI); begin N := 0; for J in Profs'Range loop declare Str : constant String := Profile_To_String (Profs (J)); begin if Str'Length /= 0 then N := N + 1; URI_List (N) := new String'(Str); Tag_List (N) := Get_Profile_Tag (Profs (J).all); end if; end; end loop; pragma Debug (C, O ("Profile found :" & Natural'Image (N))); end Get_URI_List; ----------------------- -- Profile_To_String -- ----------------------- function Profile_To_String (P : Binding_Data.Profile_Access) return String is use PolyORB.Types; T : Profile_Tag; Iter : Iterator := First (Callbacks); begin pragma Assert (P /= null); pragma Debug (C, O ("Profile to string with tag:" & Profile_Tag'Image (Get_Profile_Tag (P.all)))); T := Get_Profile_Tag (P.all); while not Last (Iter) loop declare Info : constant Profile_Record := Value (Iter).all; begin if T = Info.Tag then declare Str : constant String := Info.Profile_To_String_Body (P); begin if Str'Length /= 0 then pragma Debug (C, O ("Profile ok")); return Str; else pragma Debug (C, O ("Profile not ok")); return Null_String; end if; end; end if; end; Next (Iter); end loop; pragma Debug (C, O ("Profile not ok")); return Null_String; end Profile_To_String; ----------------------- -- String_To_Profile -- ----------------------- function String_To_Profile (Obj_Addr : String) return Binding_Data.Profile_Access is use PolyORB.Types; use PolyORB.Utils; Iter : Iterator := First (Callbacks); begin pragma Debug (C, O ("String_To_Profile: enter with " & Obj_Addr)); while not Last (Iter) loop if Has_Prefix (Obj_Addr, Prefix => Value (Iter).Proto_Ident.all) then pragma Debug (C, O ("Try to unmarshall profile with profile factory tag " & Profile_Tag'Image (Value (Iter).Tag))); return Value (Iter).String_To_Profile_Body (Obj_Addr); end if; Next (Iter); end loop; pragma Debug (C, O ("Profile not found for " & Obj_Addr)); return null; end String_To_Profile; ---------------------------------------- -- Object_To_String_With_Best_Profile -- ---------------------------------------- function Object_To_String_With_Best_Profile (URI : URI_Type) return String is begin pragma Debug (C, O ("Create URI with best profile: Enter")); if Is_Nil (URI) then pragma Debug (C, O ("URI is Empty")); return Null_String; else declare use PolyORB.Types; N : Natural; TL : Tag_Array (1 .. Length (Callbacks)); SL : String_Array (1 .. Length (Callbacks)); Profs : constant Profile_Array := Profiles_Of (URI); Best_Preference : Profile_Preference := Profile_Preference'First; Best_Profile_Index : Integer := 0; begin Get_URI_List (URI, SL, TL, N); for J in Profs'Range loop declare P : constant Profile_Preference := Get_Profile_Preference (Profs (J).all); begin if P > Best_Preference then for K in 1 .. N loop if TL (K) = Get_Profile_Tag (Profs (J).all) then Best_Preference := P; Best_Profile_Index := K; end if; end loop; end if; end; end loop; pragma Debug (C, O ("Create URI with best profile: Leave")); if Best_Profile_Index > 0 then declare Str : constant String := SL (Best_Profile_Index).all; begin Free (SL); return Str; end; else Free (SL); return Null_String; end if; end; end if; end Object_To_String_With_Best_Profile; ---------------------- -- String_To_Object -- ---------------------- function String_To_Object (Str : String) return URI_Type is use PolyORB.Types; Result : URI_Type; Pro : Profile_Access; begin pragma Debug (C, O ("Try to decode URI: enter ")); Pro := String_To_Profile (Str); if Pro /= null then Create_Reference ((1 => Pro), "", References.Ref (Result)); end if; pragma Debug (C, O ("Try to decode URI: leave ")); return Result; end String_To_Object; -------------- -- Register -- -------------- procedure Register (Tag : PolyORB.Binding_Data.Profile_Tag; Proto_Ident : String; Profile_To_String_Body : Profile_To_String_Body_Type; String_To_Profile_Body : String_To_Profile_Body_Type) is begin pragma Debug (C, O ("Register URI cb: prefix=" & Proto_Ident & " tag=" & Tag'Img)); Append (Callbacks, Profile_Record'(Tag, new String'(Proto_Ident), Profile_To_String_Body, String_To_Profile_Body)); end Register; ---------- -- Free -- ---------- procedure Free (SA : in out String_Array) is begin for J in SA'Range loop Free (SA (J)); end loop; end Free; ---------------- -- Initialize -- ---------------- procedure Initialize; procedure Initialize is Iter : Iterator := First (Callbacks); begin while not Last (Iter) loop Register_String_To_Object (Value (Iter).Proto_Ident.all, String_To_Object'Access); Next (Iter); end loop; end Initialize; use PolyORB.Initialization; use PolyORB.Initialization.String_Lists; begin Register_Module (Module_Info' (Name => +"references.uri", Conflicts => PolyORB.Initialization.String_Lists.Empty, Depends => +"binding_factories", Provides => +"references", Implicit => False, Init => Initialize'Access, Shutdown => null)); end PolyORB.References.URI; polyorb-2.8~20110207.orig/src/polyorb-poa_policies-implicit_activation_policy-activation.ads0000644000175000017500000000610711750740340031567 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- POLYORB.POA_POLICIES.IMPLICIT_ACTIVATION_POLICY.ACTIVATION -- -- -- -- S p e c -- -- -- -- Copyright (C) 2003-2005 Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ package PolyORB.POA_Policies.Implicit_Activation_Policy.Activation is type Activation_Policy is new ImplicitActivationPolicy with null record; type Activation_Policy_Access is access all Activation_Policy; function Create return Activation_Policy_Access; procedure Check_Compatibility (Self : Activation_Policy; Other_Policies : AllPolicies; Error : in out PolyORB.Errors.Error_Container); function Policy_Id (Self : Activation_Policy) return String; procedure Implicit_Activate_Servant (Self : Activation_Policy; OA : PolyORB.POA_Types.Obj_Adapter_Access; P_Servant : Servants.Servant_Access; Hint : Object_Id_Access; Oid : out Object_Id_Access; Error : in out PolyORB.Errors.Error_Container); procedure Ensure_No_Implicit_Activation (Self : Activation_Policy; Error : in out PolyORB.Errors.Error_Container); end PolyORB.POA_Policies.Implicit_Activation_Policy.Activation; polyorb-2.8~20110207.orig/src/polyorb-parameters-environment.adb0000644000175000017500000001103411750740340024031 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . P A R A M E T E R S . E N V I R O N M E N T -- -- -- -- B o d y -- -- -- -- Copyright (C) 2004-2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with PolyORB.Initialization; with PolyORB.Utils.Strings; with Interfaces.C.Strings; with System; package body PolyORB.Parameters.Environment is use Interfaces.C; use Interfaces.C.Strings; function Make_Env_Name (Section, Key : String) return String; -- Build environment variable from (Section, Key) tuple ----------------------------- -- Environment data source -- ----------------------------- type Env_Source is new Parameters_Source with null record; function Get_Conf (Source : access Env_Source; Section, Key : String) return String; The_Env_Source : aliased Env_Source; -------------- -- Get_Conf -- -------------- function Get_Conf (Source : access Env_Source; Section, Key : String) return String is pragma Unreferenced (Source); function getenv (Key : System.Address) return chars_ptr; pragma Import (C, getenv, "getenv"); C_Key : aliased char_array := To_C (Make_Env_Name (Section, Key)); C_Value : constant chars_ptr := getenv (C_Key'Address); begin if C_Value = Null_Ptr then return ""; else return Value (C_Value); end if; end Get_Conf; ---------------- -- Initialize -- ---------------- procedure Initialize; procedure Initialize is begin Register_Source (The_Env_Source'Access); end Initialize; ------------------- -- Make_Env_Name -- ------------------- function Make_Env_Name (Section, Key : String) return String is Result : String := "POLYORB_" & PolyORB.Utils.To_Upper (Section & "_" & Key); Last : Positive := Result'Last; begin for J in Result'Range loop case Result (J) is when '0' .. '9' | 'A' .. 'Z' | 'a' .. 'z' | '_' => null; when others => Result (J) := '_'; end case; end loop; while Result (Last) = '_' loop Last := Last - 1; end loop; return Result (Result'First .. Last); end Make_Env_Name; use PolyORB.Initialization; use PolyORB.Initialization.String_Lists; use PolyORB.Utils.Strings; begin Register_Module (Module_Info' (Name => +"parameters.environment", Conflicts => Empty, Depends => +"parameters.command_line?", Provides => +"parameters_sources", Implicit => True, Init => Initialize'Access, Shutdown => null)); end PolyORB.Parameters.Environment; polyorb-2.8~20110207.orig/src/polyorb-references-binding.adb0000644000175000017500000003743611750740340023073 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . R E F E R E N C E S . B I N D I N G -- -- -- -- B o d y -- -- -- -- Copyright (C) 2001-2009, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- Object references (binding operation). with Ada.Tags; with PolyORB.Binding_Data.Local; with PolyORB.Binding_Objects; with PolyORB.Log; with PolyORB.Obj_Adapters; with PolyORB.Objects; with PolyORB.Setup; with PolyORB.Servants; with PolyORB.Types; package body PolyORB.References.Binding is use PolyORB.Binding_Data; use PolyORB.Errors; use PolyORB.Log; package L is new PolyORB.Log.Facility_Log ("polyorb.references.binding"); procedure O (Message : String; Level : Log_Level := Debug) renames L.Output; function C (Level : Log_Level := Debug) return Boolean renames L.Enabled; function Find_Tagged_Profile (R : Ref; Tag : Binding_Data.Profile_Tag; Delete : Boolean) return Binding_Data.Profile_Access; -- Find a profile in R with the specified Tag. -- If Delete is true and a matching profile is found, -- then the profile is removed from R. ---------- -- Bind -- ---------- procedure Bind (R : Ref'Class; Local_ORB : ORB.ORB_Access; QoS : PolyORB.QoS.QoS_Parameters; Servant : out Components.Component_Access; Pro : out Binding_Data.Profile_Access; Local_Only : Boolean; Error : in out PolyORB.Errors.Error_Container) is use type Components.Component_Access; use Binding_Data.Local; use Binding_Objects; use Obj_Adapters; use ORB; Selected_Profile : Profile_Access; Object_Id : PolyORB.Objects.Object_Id_Access; Existing_Servant : Components.Component_Access; Existing_Profile : Binding_Data.Profile_Access; Existing_BO : PolyORB.Smart_Pointers.Ref; Best_Profile_Is_Local : Boolean; begin pragma Debug (C, O ("Bind: enter")); if Is_Nil (R) then Throw (Error, Inv_Objref_E, System_Exception_Members'(Minor => 0, Completed => Completed_No)); return; end if; -- Initial values: failure Servant := null; Pro := null; -- First check whether the reference is already bound, if so reuse the -- existing binding object. pragma Debug (C, O ("Bind: Check for already bound reference")); Get_Binding_Info (R, QoS, Existing_Servant, Existing_Profile); if Existing_Servant /= null then if (not Local_Only) or else Existing_Profile.all in Local_Profile_Type or else Is_Profile_Local (Local_ORB, Existing_Profile) then Servant := Existing_Servant; Pro := Existing_Profile; pragma Debug (C, O ("Bind: The reference is already bound")); end if; return; end if; -- XXX should probably rework the two-phase preference -- -> bind mechanism, else we could have a case where -- one non-local profile is preferred to a local, but -- less preferred, profile. On the other hand, this -- might be useful because it allows implementation -- of All_Calls_Remote simply through prefs fiddling. Selected_Profile := Get_Preferred_Profile (R, False); if Selected_Profile = null then Throw (Error, Inv_Objref_E, System_Exception_Members'(Minor => 0, Completed => Completed_No)); return; end if; Best_Profile_Is_Local := Selected_Profile.all in Local_Profile_Type or else Is_Profile_Local (Local_ORB, Selected_Profile); -- Check if there is a binding object which we can reuse (remote case) if not Best_Profile_Is_Local then pragma Debug (C, O ("Bind: Check for reusable BO")); Existing_BO := Find_Reusable_Binding_Object (Local_ORB, Selected_Profile, QoS); if not Smart_Pointers.Is_Nil (Existing_BO) then Pro := Selected_Profile; Servant := Get_Component (Existing_BO); pragma Debug (C, O ("Bind: Found reusable BO for reference")); return; end if; end if; -- No reusable binding object found declare use PolyORB.Objects; OA_Entity : constant PolyORB.Smart_Pointers.Entity_Ptr := Get_OA (Selected_Profile.all); OA : constant Obj_Adapter_Access := Obj_Adapter_Access (OA_Entity); S : PolyORB.Servants.Servant_Access; begin pragma Debug (C, O ("Found profile: " & Ada.Tags.External_Tag (Selected_Profile'Tag))); if Best_Profile_Is_Local then -- Local profile Object_Id := Get_Object_Key (Selected_Profile.all); if Object_Id = null then pragma Debug (C, O ("Unable to locate object")); return; end if; if not Is_Proxy_Oid (OA, Object_Id) then -- Real local object Find_Servant (OA, Object_Id, S, Error); if Found (Error) then return; end if; Pro := Selected_Profile; Servant := Components.Component_Access (S); return; -- ==> When binding a local reference, an OA -- is needed. Where do we obtain it from? -- PolyORB.References cannot depend on Obj_Adapters! -- ... but P.R.Binding can depend on anything. -- We also need to know what profiles are local, -- presumably by sending the ORB an Is_Local_Profile -- query for each profile (for the condition below). end if; if Local_Only then return; end if; declare Continuation : PolyORB.References.Ref; begin Proxy_To_Ref (OA, Object_Id, Continuation, Error); if Found (Error) then return; end if; if not Is_Nil (Continuation) then -- Record a reference to Continuation in Selected_Profile. -- This is necessary in order to prevent the profiles in -- Continuation (a ref to the actual object) from being -- finalized before Selected_Profile (a local profile with -- proxy oid) is finalized itself. Binding_Data.Set_Continuation (Selected_Profile, Smart_Pointers.Ref (Continuation)); pragma Debug (C, O ("Bind: recursing on proxy ref")); Bind (Continuation, Local_ORB, QoS, Servant, Pro, Local_Only, Error); if Found (Error) then return; end if; pragma Debug (C, O ("Recursed.")); Share_Binding_Info (Dest => Ref (R), Source => Continuation); pragma Debug (C, O ("Cached binding data.")); end if; pragma Debug (C, O ("About to finalize Continuation")); end; -- End of processing for local profile case. return; end if; if Local_Only then return; end if; declare RI : constant Reference_Info_Access := Ref_Info_Of (R); BO : Smart_Pointers.Ref; begin pragma Debug (C, O ("Binding non-local profile")); pragma Debug (C, O ("Creating new binding object")); PolyORB.Binding_Data.Bind_Profile (Selected_Profile, Components.Component_Access (Local_ORB), QoS, BO, Error); -- The Session itself acts as a remote surrogate -- of the designated object. if Found (Error) then return; end if; Binding_Info_Lists.Append (RI.Binding_Info, (BO, Selected_Profile)); Servant := Get_Component (BO); Pro := Selected_Profile; pragma Debug (C, O ("... done")); end; end; end Bind; ------------------------- -- Find_Tagged_Profile -- ------------------------- function Find_Tagged_Profile (R : Ref; Tag : Binding_Data.Profile_Tag; Delete : Boolean) return Binding_Data.Profile_Access is use type PolyORB.Types.Unsigned_Long; begin if Is_Nil (R) then return null; end if; declare Profiles : constant Profile_Array := Profiles_Of (R); begin for J in Profiles'Range loop if Tag = Get_Profile_Tag (Profiles (J).all) then if Delete then declare New_Array : constant Profile_Array_Access := new Profile_Array (Profiles'First .. Profiles'Last - 1); begin New_Array (New_Array'First .. New_Array'First + J - 1) := Profiles (Profiles'First .. Profiles'First + J - 1); New_Array (New_Array'First + J .. New_Array'Last) := Profiles (Profiles'First + J + 1 .. Profiles'Last); Free (Reference_Info (Entity_Of (R).all).Profiles); Reference_Info (Entity_Of (R).all).Profiles := New_Array; end; end if; return Profiles (J); end if; end loop; -- No match. return null; end; end Find_Tagged_Profile; --------------------------- -- Get_Preferred_Profile -- --------------------------- function Get_Preferred_Profile (R : Ref'Class; Ignore_Local : Boolean) return Binding_Data.Profile_Access is Profiles : constant Profile_Array := Profiles_Of (R); Best_Profile_Index : Integer := Profiles'Last + 1; Best_Preference : Profile_Preference := Profile_Preference'First; begin for J in Profiles'Range loop if not Ignore_Local or else Profiles (J).all not in Binding_Data.Local.Local_Profile_Type then declare P : constant Profile_Preference := Get_Profile_Preference (Profiles (J).all); begin if P > Best_Preference then Best_Preference := P; Best_Profile_Index := J; end if; end; end if; end loop; if Best_Profile_Index > Profiles'Last or else Best_Preference = Profile_Preference'First then return null; else return Profiles (Best_Profile_Index); end if; end Get_Preferred_Profile; ------------------------ -- Get_Tagged_Profile -- ------------------------ procedure Get_Tagged_Profile (R : Ref; Tag : Binding_Data.Profile_Tag; Pro : out Binding_Data.Profile_Access; Error : in out PolyORB.Errors.Error_Container) is use PolyORB.ORB; use type PolyORB.Types.Unsigned_Long; Local_ORB : ORB_Access renames Setup.The_ORB; Result : Binding_Data.Profile_Access := Find_Tagged_Profile (R, Tag, Delete => False); begin if Result = null then -- This ref has no profile with that tag: -- try to create one. pragma Debug (C, O ("Get_Tagged_Profile: creating proxy")); declare use PolyORB.Obj_Adapters; use PolyORB.Objects; Proxy_Oid : Object_Id_Access; Proxy_Ref : References.Ref; begin To_Proxy_Oid (Object_Adapter (Local_ORB), R, Proxy_Oid, Error); if Found (Error) then return; end if; if Proxy_Oid /= null then Create_Reference (Local_ORB, Proxy_Oid, Type_Id_Of (R), Proxy_Ref); -- If Create_Reference has created a ref containing -- a profile with the desired tag, move that profile -- into R so it won't be destroyed while R is in use. Result := Find_Tagged_Profile (Proxy_Ref, Tag, Delete => True); pragma Debug (C, O ("Created a proxy profile.")); else pragma Debug (C, O ("Could not create proxy oid.")); null; end if; if Result /= null then declare Profiles : Profile_Array renames Reference_Info (Entity_Of (R).all).Profiles.all; New_Array : constant Profile_Array_Access := new Profile_Array (Profiles'First .. Profiles'Last + 1); begin New_Array (New_Array'First .. New_Array'Last - 1) := Profiles (Profiles'First .. Profiles'Last); New_Array (New_Array'Last) := Result; Free (Reference_Info (Entity_Of (R).all).Profiles); Reference_Info (Entity_Of (R).all).Profiles := New_Array; end; else pragma Debug (C, O ("Could not create proxy.")); null; end if; end; end if; Pro := Result; end Get_Tagged_Profile; ------------ -- Unbind -- ------------ procedure Unbind (R : Ref'Class) is use Binding_Objects; use Smart_Pointers; RI : constant Reference_Info_Access := Ref_Info_Of (R); begin if RI /= null then Binding_Info_Lists.Deallocate (RI.Binding_Info); end if; end Unbind; end PolyORB.References.Binding; polyorb-2.8~20110207.orig/src/polyorb-references-corbaloc.ads0000644000175000017500000000621311750740340023253 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . R E F E R E N C E S . C O R B A L O C -- -- -- -- S p e c -- -- -- -- Copyright (C) 2003-2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with PolyORB.Binding_Data; package PolyORB.References.Corbaloc is subtype Corbaloc_Type is PolyORB.References.Ref; ----------------------------------- -- Object reference <-> Corbaloc -- ----------------------------------- function Object_To_String_With_Best_Profile (Corbaloc : Corbaloc_Type) return String; -- Return the corbaloc string for the best profile function Object_To_String (Corbaloc : Corbaloc_Type) return String renames Object_To_String_With_Best_Profile; --------------------- -- Profile Factory -- --------------------- type Profile_To_String_Body_Type is access function (Profile : Binding_Data.Profile_Access) return String; type String_To_Profile_Body_Type is access function (Str : String) return Binding_Data.Profile_Access; procedure Register (Tag : PolyORB.Binding_Data.Profile_Tag; Proto_Ident : String; Profile_To_String_Body : Profile_To_String_Body_Type; String_To_Profile_Body : String_To_Profile_Body_Type); -- Register a corbaloc <-> profile mapping end PolyORB.References.Corbaloc; polyorb-2.8~20110207.orig/src/polyorb-poa_policies-id_assignment_policy-system.adb0000644000175000017500000002155311750740340027524 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- POLYORB.POA_POLICIES.ID_ASSIGNMENT_POLICY.SYSTEM -- -- -- -- B o d y -- -- -- -- Copyright (C) 2001-2008, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with PolyORB.Log; with PolyORB.Object_Maps.System; with PolyORB.POA; with PolyORB.POA_Types; with PolyORB.POA_Policies.Lifespan_Policy; with PolyORB.Tasking.Mutexes; with PolyORB.Types; package body PolyORB.POA_Policies.Id_Assignment_Policy.System is use PolyORB.Log; use PolyORB.Object_Maps; use PolyORB.Tasking.Mutexes; use PolyORB.Types; package L is new Log.Facility_Log ("polyorb.poa_policies.id_assignement_policy.system"); procedure O (Message : Standard.String; Level : Log_Level := Debug) renames L.Output; function C (Level : Log_Level := Debug) return Boolean renames L.Enabled; ------------ -- Create -- ------------ function Create return System_Id_Policy_Access is begin return new System_Id_Policy; end Create; ------------------------- -- Check_Compatibility -- ------------------------- procedure Check_Compatibility (Self : System_Id_Policy; Other_Policies : AllPolicies; Error : in out PolyORB.Errors.Error_Container) is pragma Warnings (Off); pragma Unreferenced (Self, Other_Policies, Error); pragma Warnings (On); begin null; -- No rule to check end Check_Compatibility; --------------- -- Policy_Id -- --------------- function Policy_Id (Self : System_Id_Policy) return String is pragma Warnings (Off); pragma Unreferenced (Self); pragma Warnings (On); begin return "ID_ASSIGNMENT_POLICY.SYSTEM_ID"; end Policy_Id; ----------------------- -- Create_Object_Map -- ----------------------- function Create_Object_Map (Self : System_Id_Policy) return PolyORB.Object_Maps.Object_Map_Access is pragma Warnings (Off); pragma Unreferenced (Self); pragma Warnings (On); Result : constant PolyORB.Object_Maps.Object_Map_Access := new PolyORB.Object_Maps.System.System_Object_Map; begin PolyORB.Object_Maps.Initialize (Result.all); return Result; end Create_Object_Map; ------------------------------ -- Assign_Object_Identifier -- ------------------------------ procedure Assign_Object_Identifier (Self : System_Id_Policy; OA : PolyORB.POA_Types.Obj_Adapter_Access; Hint : Object_Id_Access; U_Oid : out Unmarshalled_Oid; Error : in out PolyORB.Errors.Error_Container) is pragma Warnings (Off); pragma Unreferenced (Self); pragma Warnings (On); use PolyORB.POA_Policies.Lifespan_Policy; use PolyORB.Object_Maps.System; use PolyORB.Errors; POA : constant PolyORB.POA.Obj_Adapter_Access := PolyORB.POA.Obj_Adapter_Access (OA); The_Entry : Object_Map_Entry_Access; Index : Integer; begin pragma Debug (C, O ("Assign_Object_Identifier: enter")); Enter (POA.Map_Lock); if POA.Active_Object_Map = null then POA.Active_Object_Map := Create_Object_Map (POA.Id_Assignment_Policy.all); end if; if POA.Active_Object_Map.all not in System_Object_Map'Class then Throw (Error, Internal_E, System_Exception_Members'(Minor => 0, Completed => Completed_No)); Leave (POA.Map_Lock); return; end if; if Hint /= null then pragma Debug (C, O ("Hint is not null")); declare U_Hint : Unmarshalled_Oid; begin Oid_To_U_Oid (Hint.all, U_Hint, Error); if not U_Hint.System_Generated or else Found (Error) then Throw (Error, Bad_Param_E, System_Exception_Members'(Minor => 0, Completed => Completed_No)); Leave (POA.Map_Lock); return; end if; -- Hint is a valid system generated oid. We reserve slot for this -- oid in POA's active object map. Servant information is still -- null at this point. It will be added later. Index := Integer'Value (To_Standard_String (U_Hint.Id)); The_Entry := new Object_Map_Entry; The_Entry.Oid := PolyORB.POA_Types.Create_Id (Name => PolyORB.Types.Trimmed_Image (Long_Long (Index)), System_Generated => True, Persistency_Flag => Get_Lifespan_Cookie (POA.Lifespan_Policy.all, OA), Creator => POA.Absolute_Address.all); Add (System_Object_Map (POA.Active_Object_Map.all)'Access, The_Entry, Index); Leave (POA.Map_Lock); end; else pragma Debug (C, O ("Hint is null")); -- XXX possible memory leak, to investigate. -- XXX If the servant retention policy is NON_RETAIN, should we not -- get rid of the active object map altogether? But in that case how -- does system id attribution cooperate with id_uniqueness_policy? The_Entry := new Object_Map_Entry; Index := Add (System_Object_Map (POA.Active_Object_Map.all)'Access, The_Entry); The_Entry.Oid := PolyORB.POA_Types.Create_Id (Name => PolyORB.Types.Trimmed_Image (Long_Long (Index)), System_Generated => True, Persistency_Flag => Get_Lifespan_Cookie (POA.Lifespan_Policy.all, OA), Creator => POA.Absolute_Address.all); Leave (POA.Map_Lock); end if; pragma Debug (C, O ("Object Name is '" & PolyORB.Types.Trimmed_Image (Long_Long (Index)) & "'")); U_Oid := The_Entry.Oid.all; pragma Debug (C, O ("Assign_Object_Identifier: leave")); end Assign_Object_Identifier; ----------------------------------- -- Reconstruct_Object_Identifier -- ----------------------------------- procedure Reconstruct_Object_Identifier (Self : System_Id_Policy; OA : Obj_Adapter_Access; Oid : Object_Id; U_Oid : out Unmarshalled_Oid; Error : in out PolyORB.Errors.Error_Container) is pragma Unreferenced (Self); pragma Unreferenced (OA); begin PolyORB.POA_Types.Oid_To_U_Oid (Oid, U_Oid, Error); end Reconstruct_Object_Identifier; ----------------------- -- Object_Identifier -- ----------------------- procedure Object_Identifier (Self : System_Id_Policy; Oid : Object_Id_Access; Result : out Object_Id_Access; Error : in out PolyORB.Errors.Error_Container) is pragma Unreferenced (Self, Error); begin Result := new Object_Id'(Oid.all); end Object_Identifier; end PolyORB.POA_Policies.Id_Assignment_Policy.System; polyorb-2.8~20110207.orig/src/polyorb-any.adb0000644000175000017500000037317511750740340020134 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . A N Y -- -- -- -- B o d y -- -- -- -- Copyright (C) 2001-2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with Ada.Strings.Fixed; with Ada.Unchecked_Deallocation; with PolyORB.Log; with PolyORB.Utils.Dynamic_Tables; with System.Address_Image; package body PolyORB.Any is use PolyORB.Log; use PolyORB.Types; use type System.Address; package L is new PolyORB.Log.Facility_Log ("polyorb.any"); procedure O (Message : Standard.String; Level : Log_Level := Debug) renames L.Output; function C (Level : Log_Level := Debug) return Boolean renames L.Enabled; ----------------------- -- Local subprograms -- ----------------------- procedure Free is new Ada.Unchecked_Deallocation (Content'Class, Content_Ptr); procedure Move_Any_Value (Dst_C, Src_C : in out Any_Container'Class); -- Transfer the value of Src_C to Dst_C; Src_C is empty upon return. -- Foreign status is transferred from Src_C to Dst_C. The previous contents -- of Dst_C are deallocated if appropriate. type Aggregate_Content_Ptr is access all Aggregate_Content'Class; -------------------- -- Elementary_Any -- -------------------- package body Elementary_Any is type T_Content_Ptr is access all T_Content; procedure Free is new Ada.Unchecked_Deallocation (T, T_Ptr); procedure Kind_Check (C : Any_Container'Class); pragma Inline (Kind_Check); ----------- -- Clone -- ----------- function Clone (CC : T_Content; Into : Content_Ptr := null) return Content_Ptr is begin if Into /= null then T_Content (Into.all).V.all := CC.V.all; return Into; end if; return new T_Content'(Content with V => new T'(CC.V.all)); end Clone; -------------------- -- Finalize_Value -- -------------------- procedure Finalize_Value (CC : in out T_Content) is begin Free (CC.V); end Finalize_Value; -------------- -- From_Any -- -------------- function From_Any (C : Any_Container'Class) return T is begin Kind_Check (C); return T_Content_Ptr (C.The_Value).V.all; end From_Any; --------------------------- -- Get_Aggregate_Element -- --------------------------- function Get_Aggregate_Element (Value : Any_Container'Class; Index : Unsigned_Long) return T is CA_Ptr : constant Aggregate_Content_Ptr := Aggregate_Content_Ptr (Value.The_Value); M : aliased Mechanism := By_Value; PTC : aliased TypeCode.Object (Kind); CC : constant T_Content := T_Content (Get_Aggregate_Element (CA_Ptr, PTC'Unchecked_Access, Index, M'Access)); begin return CC.V.all; end Get_Aggregate_Element; --------------------------- -- Get_Aggregate_Element -- --------------------------- function Get_Aggregate_Element (Value : Any; Index : Unsigned_Long) return T is begin return Get_Aggregate_Element (Get_Container (Value).all, Index); end Get_Aggregate_Element; ---------------- -- Kind_Check -- ---------------- procedure Kind_Check (C : Any_Container'Class) is begin if TypeCode.Kind (Unwind_Typedefs (Get_Type_Obj (C))) /= Kind then raise Constraint_Error; end if; end Kind_Check; ------------------- -- Set_Any_Value -- ------------------- procedure Set_Any_Value (X : T; C : in out Any_Container'Class) is begin Kind_Check (C); if C.The_Value = null then C.The_Value := new T_Content'(V => new T'(X)); C.Foreign := False; else T_Content_Ptr (C.The_Value).V.all := X; end if; C.Is_Finalized := False; end Set_Any_Value; --------------------- -- Unchecked_Get_V -- --------------------- function Unchecked_Get_V (X : not null access T_Content) return T_Ptr is begin return X.V; end Unchecked_Get_V; --------------------- -- Unchecked_Get_V -- --------------------- function Unchecked_Get_V (X : not null access T_Content) return System.Address is begin return X.V.all'Address; end Unchecked_Get_V; ---------- -- Wrap -- ---------- function Wrap (X : not null access T) return Content'Class is begin return T_Content'(V => X.all'Unchecked_Access); end Wrap; end Elementary_Any; -- The following two bodies are needed early for elaboration of -- Elementary_Any instances ---------------- -- From_Any_G -- ---------------- function From_Any_G (A : Any) return T is begin return From_Any (Get_Container (A).all); end From_Any_G; -------------- -- To_Any_G -- -------------- function To_Any_G (X : T) return Any is A : Any; begin Set_Type (A, TC); Set_Any_Value (X, Get_Container (A).all); return A; end To_Any_G; ------------------------------ -- Elementary_Any instances -- ------------------------------ package Elementary_Any_Octet is new Elementary_Any (Types.Octet, Tk_Octet); package Elementary_Any_Short is new Elementary_Any (Types.Short, Tk_Short); package Elementary_Any_Long is new Elementary_Any (Types.Long, Tk_Long); package Elementary_Any_Long_Long is new Elementary_Any (Types.Long_Long, Tk_Longlong); package Elementary_Any_UShort is new Elementary_Any (Types.Unsigned_Short, Tk_Ushort); package Elementary_Any_ULong is new Elementary_Any (Types.Unsigned_Long, Tk_Ulong); package Elementary_Any_ULong_Long is new Elementary_Any (Types.Unsigned_Long_Long, Tk_Ulonglong); package Elementary_Any_Boolean is new Elementary_Any (Types.Boolean, Tk_Boolean); package Elementary_Any_Char is new Elementary_Any (Types.Char, Tk_Char); package Elementary_Any_Wchar is new Elementary_Any (Types.Wchar, Tk_Widechar); package Elementary_Any_Float is new Elementary_Any (Types.Float, Tk_Float); package Elementary_Any_Double is new Elementary_Any (Types.Double, Tk_Double); package Elementary_Any_Long_Double is new Elementary_Any (Types.Long_Double, Tk_Longdouble); package Elementary_Any_String is new Elementary_Any (Types.String, Tk_String); package Elementary_Any_Wide_String is new Elementary_Any (Types.Wide_String, Tk_Wstring); package Elementary_Any_Bounded_String is new Elementary_Any (Ada.Strings.Superbounded.Super_String, Tk_String); package Elementary_Any_Bounded_Wide_String is new Elementary_Any (Ada.Strings.Wide_Superbounded.Super_String, Tk_Wstring); package Elementary_Any_Any is new Elementary_Any (Any, Tk_Any); package Elementary_Any_TypeCode is new Elementary_Any (TypeCode.Local_Ref, Tk_TypeCode); --------------------------------- -- 'Aggregate' content wrapper -- --------------------------------- -- While an aggregate is constructed, its contents are stored as a -- chained list. -- Once the construction is completed (i.e. the length of the list won't -- grow anymore), the list is converted to an array (to speed up access -- to random elements) and the aggegate is frozen (i.e. no elements can -- be added to it). Actually the freeze occurs the first time an element -- is retrieved through Get_Aggregate_Element. -- A list of Any contents (for construction of aggregates) package Content_Tables is new PolyORB.Utils.Dynamic_Tables (Table_Component_Type => Any_Container_Ptr, Table_Index_Type => Integer, Table_Low_Bound => 0, Table_Initial => 8, Table_Increment => 100); subtype Content_Table is Content_Tables.Instance; -- For complex types that could be defined in IDL, a Aggregate_Content -- will be used. -- -- Complex types include Struct, Union, Enum, Sequence, Array, Except, -- Fixed, Value, Valuebox, Abstract_Interface. Here is the way the -- content_list is used in each case (See CORBA V2.3 - 15.3) -- - for Struct, Except: the elements are the values of each -- field in the order of the declaration -- -- - for Union : the value of the switch element comes -- first. Then come all the values of the corresponding fields -- -- - for Enum : an unsigned_long corresponding to the position -- of the value in the declaration is the only element -- -- - for Array : all the elements of the array, one by one. -- -- - for Sequence : the length first and then all the elements -- of the sequence, one by one. XXX Can't we get rid of the length? -- it is implicit already in the length of the aggregate -- -- - for Fixed : XXX -- - for Value : XXX -- - for Valuebox : XXX -- - for Abstract_Interface : XXX ------------------------------- -- Default_Aggregate_Content -- ------------------------------- -- Default generic implementation of aggregate content wrapper, based on -- a table of Any_Container accesses. type Default_Aggregate_Content (Kind : TCKind) is new Aggregate_Content with record V : Content_Table; end record; -- Content primitives function Clone (CC : Default_Aggregate_Content; Into : Content_Ptr := null) return Content_Ptr; procedure Finalize_Value (CC : in out Default_Aggregate_Content); -- Aggregate_Content primitives function Get_Aggregate_Count (ACC : Default_Aggregate_Content) return Types.Unsigned_Long; procedure Set_Aggregate_Count (ACC : in out Default_Aggregate_Content; Count : Types.Unsigned_Long); function Get_Aggregate_Element (ACC : not null access Default_Aggregate_Content; TC : TypeCode.Object_Ptr; Index : Types.Unsigned_Long; Mech : not null access Mechanism) return Content'Class; procedure Set_Aggregate_Element (ACC : in out Default_Aggregate_Content; TC : TypeCode.Object_Ptr; Index : Types.Unsigned_Long; From_C : in out Any_Container'Class); procedure Add_Aggregate_Element (ACC : in out Default_Aggregate_Content; El : Any_Container_Ptr); function Allocate_Default_Aggregate_Content (Kind : TCKind) return Content_Ptr; -- Allocate and initialize a Aggregate_Content. The TCKind is that of the -- aggregate. procedure Deep_Deallocate (Table : in out Content_Table); -- Deallocate each content element of a content table --------- -- "=" -- --------- function "=" (Left, Right : Any) return Boolean is Res : Boolean; begin pragma Debug (C, O ("Equal (Any): enter, " & Image (Left) & " =? " & Image (Right))); Res := "=" (Get_Container (Left).all, Get_Container (Right).all); pragma Debug (C, O ("Equal (Any): returning " & Res'Img)); return Res; end "="; --------- -- "=" -- --------- function "=" (Left, Right : Any_Container'Class) return Boolean is L_Type : constant TypeCode.Object_Ptr := Get_Type_Obj (Left); R_Type : constant TypeCode.Object_Ptr := Get_Type_Obj (Right); function Agg_Elements_Equal (TC : TypeCode.Object_Ptr; L_ACC, R_ACC : access Aggregate_Content'Class; Index : Types.Unsigned_Long) return Boolean; -- Compare the Index'th element of Left and Right, which are assumed -- to be aggregates. The expected type for both elements is TC. function Agg_Elements_Equal (TC : TypeCode.Object_Ptr; L_ACC, R_ACC : access Aggregate_Content'Class; Index : Types.Unsigned_Long) return Boolean is L_C : Any_Container; R_C : Any_Container; L_M : aliased Mechanism := By_Value; L_CC : aliased Content'Class := Get_Aggregate_Element (L_ACC, TC, Index, L_M'Access); R_M : aliased Mechanism := By_Value; R_CC : aliased Content'Class := Get_Aggregate_Element (R_ACC, TC, Index, R_M'Access); begin Set_Type (L_C, TC); Set_Value (L_C, L_CC'Unchecked_Access, Foreign => True); Set_Type (R_C, TC); Set_Value (R_C, R_CC'Unchecked_Access, Foreign => True); return "=" (L_C, R_C); end Agg_Elements_Equal; begin if not TypeCode.Equal (L_Type, R_Type) then return False; end if; pragma Debug (C, O ("Equal (Any): passed typecode test")); case TypeCode.Kind (Unwind_Typedefs (L_Type)) is when Tk_Null | Tk_Void => pragma Debug (C, O ("Equal (Any, Null or Void): end")); return True; when Tk_Short => declare L : constant Short := From_Any (Left); R : constant Short := From_Any (Right); begin pragma Debug (C, O ("Equal (Any, Short): end")); return L = R; end; when Tk_Long => declare L : constant Long := From_Any (Left); R : constant Long := From_Any (Right); begin pragma Debug (C, O ("Equal (Any, Long): end")); return L = R; end; when Tk_Ushort => declare L : constant Unsigned_Short := From_Any (Left); R : constant Unsigned_Short := From_Any (Right); begin pragma Debug (C, O ("Equal (Any, Ushort): end")); return L = R; end; when Tk_Ulong => declare L : constant Unsigned_Long := From_Any (Left); R : constant Unsigned_Long := From_Any (Right); begin pragma Debug (C, O ("Equal (Any, Ulong): end")); return L = R; end; when Tk_Float => declare L : constant Types.Float := From_Any (Left); R : constant Types.Float := From_Any (Right); begin pragma Debug (C, O ("Equal (Any, Float): end")); return L = R; end; when Tk_Double => declare L : constant Double := From_Any (Left); R : constant Double := From_Any (Right); begin pragma Debug (C, O ("Equal (Any, Double): end")); return L = R; end; when Tk_Boolean => declare L : constant Boolean := From_Any (Left); R : constant Boolean := From_Any (Right); begin pragma Debug (C, O ("Equal (Any, Boolean): end")); return L = R; end; when Tk_Char => declare L : constant Char := From_Any (Left); R : constant Char := From_Any (Right); begin pragma Debug (C, O ("Equal (Any, Char): end")); return L = R; end; when Tk_Octet => declare L : constant Octet := From_Any (Left); R : constant Octet := From_Any (Right); begin pragma Debug (C, O ("Equal (Any, Octet): end")); return L = R; end; when Tk_Any => declare L : constant Any := From_Any (Left); R : constant Any := From_Any (Right); begin pragma Debug (C, O ("Equal (Any, Any): end")); return "=" (L, R); end; when Tk_TypeCode => declare L : constant TypeCode.Local_Ref := From_Any (Left); R : constant TypeCode.Local_Ref := From_Any (Right); begin if TypeCode.Kind (R) = Tk_Value then pragma Debug (C, O ("Equal (Any, TypeCode) :" & " Skipping Tk_Value" & " typecode comparison")); -- TODO/XXX Call a different equality procedure -- to accomodate eventual circular references in -- typecodes pragma Debug (C, O ("Equal (Any, TypeCode) :" & " Tk_Value NOT IMPLEMENTED")); raise Program_Error; return True; else pragma Debug (C, O ("Equal (Any, TypeCode): end")); return TypeCode.Equal (R, L); end if; end; when Tk_Principal => -- XXX : to be done pragma Debug (C, O ("Equal (Any, Principal): end" & " NOT IMPLEMENTED -> TRUE")); return True; when Tk_Objref => declare -- L : CORBA.Object.Ref := CORBA.Object.Helper.From_Any (Left); -- R : CORBA.Object.Ref := CORBA.Object.Helper.From_Any (Right); begin pragma Debug (C, O ("Equal (Any, ObjRef): end" & " NOT IMPLEMENTED -> TRUE")); -- XXX : is_equivalent has to be implemented return True; -- return CORBA.Object.Is_Equivalent (L, R); end; when Tk_Struct | Tk_Except => -- 1. Retrieve aggregate contents wrapper for Left and Right -- 2. For each member in the aggregate, compare both values: -- 2.1. Retrieve member type -- 2.2. Retrieve contents wrapper on the stack -- 2.3. Conjure up temporary Any's pointing to these wrappers, -- marked as foreign (no contents deallocation upon -- finalization) -- 2.4. Recurse in Equal on temporary Anys declare List_Type : constant TypeCode.Object_Ptr := Unwind_Typedefs (L_Type); M_Type : TypeCode.Object_Ptr; L_ACC : Aggregate_Content'Class renames Aggregate_Content'Class (Left.The_Value.all); R_ACC : Aggregate_Content'Class renames Aggregate_Content'Class (Right.The_Value.all); begin for J in 0 .. TypeCode.Member_Count (List_Type) - 1 loop M_Type := TypeCode.Member_Type (List_Type, J); if not Agg_Elements_Equal (M_Type, L_ACC'Access, R_ACC'Access, J) then pragma Debug (C, O ("Equal (Any, struct/except): end")); return False; end if; end loop; pragma Debug (C, O ("Equal (Any, struct/except): end")); return True; end; when Tk_Union => declare L_ACC : Aggregate_Content'Class renames Aggregate_Content'Class (Left.The_Value.all); R_ACC : Aggregate_Content'Class renames Aggregate_Content'Class (Right.The_Value.all); List_Type : constant TypeCode.Object_Ptr := Unwind_Typedefs (L_Type); Switch_Type : constant TypeCode.Object_Ptr := TypeCode.Discriminator_Type (List_Type); Member_Type : TypeCode.Object_Ptr; begin pragma Assert (Get_Aggregate_Count (L_ACC) = 2); pragma Assert (Get_Aggregate_Count (R_ACC) = 2); -- First compares the switch value if not Agg_Elements_Equal (Switch_Type, L_ACC'Access, R_ACC'Access, 0) then pragma Debug (C, O ("Equal (Any, Union): " & "switch differs, end")); return False; end if; declare Label_Mech : aliased Mechanism := By_Value; Label_CC : aliased Content'Class := Get_Aggregate_Element (L_ACC'Access, Switch_Type, 0, Label_Mech'Access); Label_C : Any_Container; Res : Boolean; begin Set_Type (Label_C, Switch_Type); Set_Value (Label_C, Label_CC'Unchecked_Access, Foreign => True); Member_Type := TypeCode.Member_Type_With_Label (List_Type, Label_C); Res := Agg_Elements_Equal (Member_Type, L_ACC'Access, R_ACC'Access, 1); pragma Debug (C, O ("Equal (Any, Union): end, " & Res'Img)); return Res; end; end; when Tk_Enum => pragma Debug (C, O ("Equal (Any, Enum): end")); -- compares the only element of both aggregate : an unsigned long declare L_ACC : Aggregate_Content'Class renames Aggregate_Content'Class (Left.The_Value.all); R_ACC : Aggregate_Content'Class renames Aggregate_Content'Class (Right.The_Value.all); begin return Agg_Elements_Equal (TypeCode.PTC_Unsigned_Long'Access, L_ACC'Access, R_ACC'Access, 0); end; when Tk_Sequence | Tk_Array => declare List_Type : constant TypeCode.Object_Ptr := Unwind_Typedefs (L_Type); Member_Type : constant TypeCode.Object_Ptr := TypeCode.Content_Type (List_Type); L_ACC : Aggregate_Content'Class renames Aggregate_Content'Class (Left.The_Value.all); R_ACC : Aggregate_Content'Class renames Aggregate_Content'Class (Right.The_Value.all); begin -- for each member in the aggregate, compare both values for J in 0 .. TypeCode.Length (List_Type) - 1 loop if not Agg_Elements_Equal (Member_Type, L_ACC'Access, R_ACC'Access, J) then pragma Debug (C, O ("Equal (Any, sequence/array): end")); return False; end if; end loop; pragma Debug (C, O ("Equal (Any, sequence/array): end")); return True; end; when Tk_Fixed | Tk_Value | Tk_Valuebox | Tk_Abstract_Interface | Tk_Local_Interface | Tk_Component | Tk_Home | Tk_Event => -- XXX : to be done pragma Debug (C, O ("Equal (Any, Fixed, Value, ValueBox, " & "Abstract_Interface, Local_Interface, " & "Component, Home or Event): end" & " NON IMPLEMENTED -> TRUE")); return True; when Tk_String => declare L : constant Standard.String := From_Any (Left); R : constant Standard.String := From_Any (Right); begin pragma Debug (C, O ("Equal (Any, String): end")); return L = R; end; when Tk_Alias => -- We should never be here, since the case statement uses the -- precise type of the anys, that is an unaliased type. pragma Debug (C, O ("Equal (Any, Alias): end with exception")); raise Program_Error; when Tk_Longlong => declare L : constant Long_Long := From_Any (Left); R : constant Long_Long := From_Any (Right); begin pragma Debug (C, O ("Equal (Any, Long_Long): end")); return L = R; end; when Tk_Ulonglong => declare L : constant Unsigned_Long_Long := From_Any (Left); R : constant Unsigned_Long_Long := From_Any (Right); begin pragma Debug (C, O ("Equal (Any, Unsigned_Long_Long): end")); return L = R; end; when Tk_Longdouble => declare L : constant Long_Double := From_Any (Left); R : constant Long_Double := From_Any (Right); begin pragma Debug (C, O ("Equal (Any, Long_Double): end")); return L = R; end; when Tk_Widechar => declare L : constant Wchar := From_Any (Left); R : constant Wchar := From_Any (Right); begin pragma Debug (C, O ("Equal (Any, Wchar): end")); return L = R; end; when Tk_Wstring => declare L : constant Types.Wide_String := From_Any (Left); R : constant Types.Wide_String := From_Any (Right); begin pragma Debug (C, O ("Equal (Any, Wide_String): end")); return L = R; end; when Tk_Native => -- XXX to be done pragma Debug (C, O ("Equal (Any, Native): end" & " NON IMPLEMENTED -> TRUE")); return True; end case; end "="; --------------------------- -- Add_Aggregate_Element -- --------------------------- procedure Add_Aggregate_Element (ACC : in out Aggregate_Content; El : Any_Container_Ptr) is begin -- This is not supported by default raise Program_Error; end Add_Aggregate_Element; --------------------------- -- Add_Aggregate_Element -- --------------------------- procedure Add_Aggregate_Element (ACC : in out Default_Aggregate_Content; El : Any_Container_Ptr) is use Content_Tables; begin pragma Assert (Initialized (ACC.V)); Smart_Pointers.Inc_Usage (Smart_Pointers.Entity_Ptr (El)); Increment_Last (ACC.V); ACC.V.Table (Last (ACC.V)) := El; end Add_Aggregate_Element; --------------------------- -- Add_Aggregate_Element -- --------------------------- procedure Add_Aggregate_Element (Value : in out Any; Element : Any) is CA_Ptr : constant Aggregate_Content_Ptr := Aggregate_Content_Ptr (Get_Container (Value).The_Value); begin pragma Debug (C, O ("Add_Aggregate_Element: enter")); Add_Aggregate_Element (CA_Ptr.all, Get_Container (Element)); pragma Debug (C, O ("Add_Aggregate_Element: end")); end Add_Aggregate_Element; ---------------------------------------- -- Allocate_Default_Aggregate_Content -- ---------------------------------------- function Allocate_Default_Aggregate_Content (Kind : TCKind) return Content_Ptr is Result : constant Aggregate_Content_Ptr := new Default_Aggregate_Content (Kind => Kind); begin Content_Tables.Initialize (Default_Aggregate_Content (Result.all).V); return Content_Ptr (Result); end Allocate_Default_Aggregate_Content; ----------- -- Clone -- ----------- function Clone (CC : No_Content; Into : Content_Ptr := null) return Content_Ptr is begin raise Program_Error; return null; end Clone; -- Clone function for Default_Aggregate_Content -- Caveat emptor: this function allocates a new container for each -- element of the aggregate, and sets its value by recursively cloning -- the contents of the original element. It is *extremely* costly! Also, -- it never supports direct in-place assignment. function Clone (CC : Default_Aggregate_Content; Into : Content_Ptr := null) return Content_Ptr is use PolyORB.Smart_Pointers; use Content_Tables; begin if Into /= null then return null; end if; declare New_CC_P : constant Content_Ptr := Allocate_Default_Aggregate_Content (CC.Kind); New_CC : Default_Aggregate_Content renames Default_Aggregate_Content (New_CC_P.all); begin Set_Last (New_CC.V, Last (CC.V)); for J in First (New_CC.V) .. Last (New_CC.V) loop -- Create a new any container, referenced by this aggregate New_CC.V.Table (J) := new Any_Container; Inc_Usage (Entity_Ptr (New_CC.V.Table (J))); -- Set its type and copy the value from the original element New_CC.V.Table (J).The_Type := CC.V.Table (J).The_Type; Set_Value (New_CC.V.Table (J).all, Clone (CC.V.Table (J).The_Value.all), Foreign => False); end loop; return New_CC_P; end; end Clone; -------------- -- Copy_Any -- -------------- function Copy_Any (Src : Any) return Any is Dst : Any; begin Set_Type (Dst, Get_Type_Obj (Src)); Copy_Any_Value (Dst => Dst, Src => Src); return Dst; end Copy_Any; -------------------- -- Copy_Any_Value -- -------------------- procedure Copy_Any_Value (Dst_C : in out Any_Container'Class; Src_C : Any_Container'Class); procedure Copy_Any_Value (Dst : Any; Src : Any) is begin Copy_Any_Value (Get_Container (Dst).all, Get_Container (Src).all); end Copy_Any_Value; procedure Copy_Any_Value (Dst_C : in out Any_Container'Class; Src_C : Any_Container'Class) is TC : constant TypeCode.Object_Ptr := Unwind_Typedefs (Get_Type_Obj (Src_C)); TCK : constant TCKind := TypeCode.Kind (TC); Dst_TCK : constant TCKind := TypeCode.Kind (Unwind_Typedefs (Get_Type_Obj (Dst_C))); begin if Src_C'Address = Dst_C'Address then return; end if; if Dst_TCK /= TCK then raise TypeCode.Bad_TypeCode; end if; if Dst_C.The_Value = null then Set_Value (Dst_C, Clone (Src_C.The_Value.all), Foreign => False); else case TCK is when Tk_Null | Tk_Void => null; when Tk_Short => Set_Any_Value (Short'(From_Any (Src_C)), Dst_C); when Tk_Long => Set_Any_Value (Long'(From_Any (Src_C)), Dst_C); when Tk_Ushort => Set_Any_Value (Unsigned_Short'(From_Any (Src_C)), Dst_C); when Tk_Ulong => Set_Any_Value (Unsigned_Long'(From_Any (Src_C)), Dst_C); when Tk_Float => Set_Any_Value (Types.Float'(From_Any (Src_C)), Dst_C); when Tk_Double => Set_Any_Value (Double'(From_Any (Src_C)), Dst_C); when Tk_Boolean => Set_Any_Value (Boolean'(From_Any (Src_C)), Dst_C); when Tk_Char => Set_Any_Value (Char'(From_Any (Src_C)), Dst_C); when Tk_Octet => Set_Any_Value (Octet'(From_Any (Src_C)), Dst_C); when Tk_Longlong => Set_Any_Value (Long_Long'(From_Any (Src_C)), Dst_C); when Tk_Ulonglong => Set_Any_Value (Unsigned_Long_Long'(From_Any (Src_C)), Dst_C); when Tk_Longdouble => Set_Any_Value (Long_Double'(From_Any (Src_C)), Dst_C); when Tk_Widechar => Set_Any_Value (Wchar'(From_Any (Src_C)), Dst_C); when Tk_String => declare Bound : constant Types.Unsigned_Long := TypeCode.Length (TC); begin if Bound = 0 then Set_Any_Value (Types.String'(From_Any (Src_C)), Dst_C); else Elementary_Any_Bounded_String.Set_Any_Value (Elementary_Any_Bounded_String.From_Any (Src_C), Dst_C); end if; end; when Tk_Wstring => declare Bound : constant Types.Unsigned_Long := TypeCode.Length (TC); begin if Bound = 0 then Set_Any_Value (Types.Wide_String'(From_Any (Src_C)), Dst_C); else Elementary_Any_Bounded_Wide_String.Set_Any_Value (Elementary_Any_Bounded_Wide_String.From_Any (Src_C), Dst_C); end if; end; when Tk_Any => Set_Any_Value (Any'(From_Any (Src_C)), Dst_C); when Tk_TypeCode => Set_Any_Value (TypeCode.Local_Ref'(From_Any (Src_C)), Dst_C); when Tk_Objref => declare New_CC : constant Content_Ptr := Clone (CC => Src_C.The_Value.all, Into => Dst_C.The_Value); begin if Dst_C.The_Value = null then Set_Value (Dst_C, New_CC, Foreign => False); else pragma Assert (New_CC = Dst_C.The_Value); null; end if; end; when Tk_Struct | Tk_Except | Tk_Union | Tk_Enum | Tk_Sequence | Tk_Array | Tk_Fixed => declare El_TC : TypeCode.Object_Ptr; Dst_ACC : Aggregate_Content'Class renames Aggregate_Content'Class (Dst_C.The_Value.all); Src_ACC : Aggregate_Content'Class renames Aggregate_Content'Class (Src_C.The_Value.all); Src_Count : constant Types.Unsigned_Long := Get_Aggregate_Count (Src_ACC); begin Set_Aggregate_Count (Dst_ACC, Src_Count); -- Set up El_TC for first element case TCK is when Tk_Enum | Tk_Sequence => El_TC := TypeCode.PTC_Unsigned_Long'Access; when Tk_Union => El_TC := TypeCode.Discriminator_Type (TC); when Tk_Array => El_TC := TypeCode.Content_Type (TC); when Tk_Fixed => El_TC := TypeCode.PTC_Octet'Access; when others => null; end case; for J in 0 .. Src_Count - 1 loop if TCK = Tk_Struct or else TCK = Tk_Except then El_TC := TypeCode.Member_Type (TC, J); end if; declare Dst_El_C : Any_Container; Src_El_C : Any_Container; Dst_El_M : aliased Mechanism := By_Reference; Dst_El_CC : aliased Content'Class := Get_Aggregate_Element (Dst_ACC'Access, El_TC, J, Dst_El_M'Access); Src_El_M : aliased Mechanism := By_Value; Src_El_CC : aliased Content'Class := Get_Aggregate_Element (Src_ACC'Access, El_TC, J, Src_El_M'Access); begin Set_Type (Src_El_C, El_TC); Set_Value (Src_El_C, Src_El_CC'Unchecked_Access, Foreign => True); -- Case of an aggregate element that needs to be set -- explicitly. if Dst_El_M = By_Value then Set_Aggregate_Element (Dst_ACC, El_TC, J, Src_El_C); -- This would be incorrect if Dst_ACC is a default -- aggregate content, since in this case the call -- will incorrectly steal the value from Src_El_C. -- At least try to detect this fault case: pragma Assert (not Is_Empty (Src_El_C)); -- Attempt in-place assignment elsif Clone (CC => Src_El_CC, Into => Dst_El_CC'Unchecked_Access) = null -- Fall back to recursive element copy then Set_Type (Dst_El_C, El_TC); Set_Value (Dst_El_C, Dst_El_CC'Unchecked_Access, Foreign => True); Copy_Any_Value (Dst_El_C, Src_El_C); end if; if J = 0 then case TCK is when Tk_Union => El_TC := TypeCode.Member_Type_With_Label (TC, Src_El_C); when Tk_Sequence => El_TC := TypeCode.Content_Type (TC); when others => null; end case; end if; end; end loop; end; when Tk_Value | Tk_Valuebox | Tk_Abstract_Interface | Tk_Local_Interface | Tk_Component | Tk_Home | Tk_Event | Tk_Principal | Tk_Native => -- XXX : to be done pragma Debug (C, O ("Copy (" & Dst_TCK'Img & ": end" & " NON IMPLEMENTED")); return; when Tk_Alias => -- we should never be here, since the case statement uses the -- precise type of the anys, that is an unaliased type pragma Debug (C, O ("Equal (Any, Alias): end with exception")); raise Program_Error; end case; end if; end Copy_Any_Value; --------------------- -- Deep_Deallocate -- --------------------- procedure Deep_Deallocate (Table : in out Content_Table) is use Content_Tables; begin pragma Debug (C, O ("Deep_Deallocate: enter")); if Initialized (Table) then for J in First (Table) .. Last (Table) loop -- If we are aborting during initialisation of the aggregate, -- not all elements might have been initialized at this point, -- so we need to test explicitly against null. if Table.Table (J) /= null then Smart_Pointers.Dec_Usage (Smart_Pointers.Entity_Ptr (Table.Table (J))); end if; end loop; end if; Deallocate (Table); pragma Debug (C, O ("Deep_Deallocate: end")); end Deep_Deallocate; -------------- -- Finalize -- -------------- procedure Finalize (Self : in out Any_Container) is begin pragma Debug (C, O ("Finalizing Any_Container: enter")); if Self.Is_Finalized then return; end if; Self.Is_Finalized := True; Finalize_Value (Self); pragma Debug (C, O ("Finalizing Any_Container: leave")); end Finalize; -------------------- -- Finalize_Value -- -------------------- procedure Finalize_Value (C : in out Any_Container'Class) is begin Set_Value (C, null, Foreign => False); end Finalize_Value; -------------------- -- Finalize_Value -- -------------------- procedure Finalize_Value (CC : in out No_Content) is begin raise Program_Error; end Finalize_Value; -------------------- -- Finalize_Value -- -------------------- procedure Finalize_Value (CC : in out Default_Aggregate_Content) is begin Deep_Deallocate (CC.V); end Finalize_Value; -------------- -- From_Any -- -------------- function From_Any (C : Any_Container'Class) return Types.Octet renames Elementary_Any_Octet.From_Any; function From_Any (C : Any_Container'Class) return Types.Short renames Elementary_Any_Short.From_Any; function From_Any (C : Any_Container'Class) return Types.Long renames Elementary_Any_Long.From_Any; function From_Any (C : Any_Container'Class) return Types.Long_Long renames Elementary_Any_Long_Long.From_Any; function From_Any (C : Any_Container'Class) return Types.Unsigned_Short renames Elementary_Any_UShort.From_Any; function From_Any (C : Any_Container'Class) return Types.Unsigned_Long renames Elementary_Any_ULong.From_Any; function From_Any (C : Any_Container'Class) return Types.Unsigned_Long_Long renames Elementary_Any_ULong_Long.From_Any; function From_Any (C : Any_Container'Class) return Types.Boolean renames Elementary_Any_Boolean.From_Any; function From_Any (C : Any_Container'Class) return Types.Char renames Elementary_Any_Char.From_Any; function From_Any (C : Any_Container'Class) return Types.Wchar renames Elementary_Any_Wchar.From_Any; function From_Any (C : Any_Container'Class) return Types.Float renames Elementary_Any_Float.From_Any; function From_Any (C : Any_Container'Class) return Types.Double renames Elementary_Any_Double.From_Any; function From_Any (C : Any_Container'Class) return Types.Long_Double renames Elementary_Any_Long_Double.From_Any; function From_Any (C : Any_Container'Class) return Types.String renames Elementary_Any_String.From_Any; function From_Any (C : Any_Container'Class) return Types.Wide_String renames Elementary_Any_Wide_String.From_Any; function From_Any (C : Any_Container'Class) return Any renames Elementary_Any_Any.From_Any; function From_Any (C : Any_Container'Class) return TypeCode.Local_Ref renames Elementary_Any_TypeCode.From_Any; function From_Any (A : Any) return Types.Octet renames Elementary_Any_Octet.From_Any; function From_Any (A : Any) return Types.Short renames Elementary_Any_Short.From_Any; function From_Any (A : Any) return Types.Long renames Elementary_Any_Long.From_Any; function From_Any (A : Any) return Types.Long_Long renames Elementary_Any_Long_Long.From_Any; function From_Any (A : Any) return Types.Unsigned_Short renames Elementary_Any_UShort.From_Any; function From_Any (A : Any) return Types.Unsigned_Long renames Elementary_Any_ULong.From_Any; function From_Any (A : Any) return Types.Unsigned_Long_Long renames Elementary_Any_ULong_Long.From_Any; function From_Any (A : Any) return Types.Boolean renames Elementary_Any_Boolean.From_Any; function From_Any (A : Any) return Types.Char renames Elementary_Any_Char.From_Any; function From_Any (A : Any) return Types.Wchar renames Elementary_Any_Wchar.From_Any; function From_Any (A : Any) return Types.Float renames Elementary_Any_Float.From_Any; function From_Any (A : Any) return Types.Double renames Elementary_Any_Double.From_Any; function From_Any (A : Any) return Types.Long_Double renames Elementary_Any_Long_Double.From_Any; function From_Any (A : Any) return Types.String renames Elementary_Any_String.From_Any; function From_Any (A : Any) return Types.Wide_String renames Elementary_Any_Wide_String.From_Any; function From_Any (A : Any) return Any renames Elementary_Any_Any.From_Any; function From_Any (A : Any) return TypeCode.Local_Ref renames Elementary_Any_TypeCode.From_Any; function From_Any (A : Any) return Ada.Strings.Superbounded.Super_String renames Elementary_Any_Bounded_String.From_Any; function From_Any (A : Any) return Ada.Strings.Wide_Superbounded.Super_String renames Elementary_Any_Bounded_Wide_String.From_Any; ------------------------ -- From_Any (strings) -- ------------------------ function From_Any (C : Any_Container'Class) return Standard.String is Bound : constant Types.Unsigned_Long := TypeCode.Length (Unwind_Typedefs (Get_Type_Obj (C))); begin if Bound = 0 then -- Unbounded case -- Use unchecked access to underlying Types.String to avoid -- a costly Adjust. return To_Standard_String (Elementary_Any_String.Unchecked_Get_V (Elementary_Any_String.T_Content (C.The_Value.all)'Access).all); else -- Bounded case return Ada.Strings.Superbounded.Super_To_String (Elementary_Any_Bounded_String.From_Any (C)); end if; end From_Any; function From_Any (C : Any_Container'Class) return Standard.Wide_String is Bound : constant Types.Unsigned_Long := TypeCode.Length (Unwind_Typedefs (Get_Type_Obj (C))); begin if Bound = 0 then -- Unbounded case -- Use unchecked access to underlying Types.String to avoid -- a costly Adjust. return To_Wide_String (Elementary_Any_Wide_String.Unchecked_Get_V (Elementary_Any_Wide_String.T_Content (C.The_Value.all)'Access).all); else -- Bounded case return Ada.Strings.Wide_Superbounded.Super_To_String (Elementary_Any_Bounded_Wide_String.From_Any (C)); end if; end From_Any; function String_From_Any is new From_Any_G (Standard.String, From_Any); function From_Any (A : Any) return Standard.String renames String_From_Any; function Wide_String_From_Any is new From_Any_G (Standard.Wide_String, From_Any); function From_Any (A : Any) return Standard.Wide_String renames Wide_String_From_Any; ------------------------- -- Get_Aggregate_Count -- ------------------------- function Get_Aggregate_Count (Value : Any) return Unsigned_Long is CA_Ptr : constant Aggregate_Content_Ptr := Aggregate_Content_Ptr (Get_Value (Get_Container (Value).all)); begin return Get_Aggregate_Count (CA_Ptr.all); end Get_Aggregate_Count; function Get_Aggregate_Count (ACC : Default_Aggregate_Content) return Unsigned_Long is begin return Unsigned_Long (Content_Tables.Last (ACC.V) - Content_Tables.First (ACC.V) + 1); end Get_Aggregate_Count; --------------------------- -- Get_Aggregate_Element -- --------------------------- function Get_Aggregate_Element (ACC : not null access Aggregate_Content'Class; TC : TypeCode.Local_Ref; Index : Unsigned_Long; Mech : not null access Mechanism) return Content'Class is begin return Get_Aggregate_Element (ACC, TypeCode.Object_Of (TC), Index, Mech); end Get_Aggregate_Element; function Get_Aggregate_Element (ACC : not null access Default_Aggregate_Content; TC : TypeCode.Object_Ptr; Index : Unsigned_Long; Mech : not null access Mechanism) return Content'Class is use PolyORB.Smart_Pointers; use Content_Tables; El_C_Ptr : Any_Container_Ptr renames ACC.V.Table (First (ACC.V) + Natural (Index)); begin pragma Debug (C, O ("Get_Aggregate_Element: enter")); pragma Debug (C, O ("Get_Aggregate_Element: Index = " & Unsigned_Long'Image (Index) & ", aggregate_count = " & Unsigned_Long'Image (Get_Aggregate_Count (ACC.all)))); if El_C_Ptr = null then -- Allocate new container and count one reference (the aggregate) El_C_Ptr := new Any_Container; Inc_Usage (Entity_Ptr (El_C_Ptr)); El_C_Ptr.The_Type := TypeCode.To_Ref (TC); end if; if (El_C_Ptr.The_Value = null) or else (ACC.Kind = Tk_Union and then Index = 0 and then Mech.all = By_Reference) then pragma Assert (Mech.all = By_Reference); -- When there is no current value for this aggregate element, or when -- getting the discriminant of an Union for update, set Mech to -- By_Value to force the caller to call Set_Aggregate_Element. Mech.all := By_Value; return No_Content'(null record); else Mech.all := By_Reference; return El_C_Ptr.The_Value.all; end if; end Get_Aggregate_Element; --------------------------- -- Get_Aggregate_Element -- --------------------------- function Get_Aggregate_Element (Value : Any; TC : TypeCode.Local_Ref; Index : Unsigned_Long) return Any is begin return Get_Aggregate_Element (Value, TypeCode.Object_Of (TC), Index); end Get_Aggregate_Element; function Get_Aggregate_Element (Value : Any; TC : TypeCode.Object_Ptr; Index : Unsigned_Long) return Any is -- Enforce tag check on Value's container to defend against improper -- access for an Any that is not an aggregate. pragma Unsuppress (Tag_Check); CA_Ptr : constant Aggregate_Content_Ptr := Aggregate_Content_Ptr (Get_Container (Value).The_Value); A : Any; M : aliased Mechanism := By_Value; CC : constant Content'Class := Get_Aggregate_Element (CA_Ptr, TC, Index, M'Access); New_CC : Content_Ptr; use PolyORB.Smart_Pointers; begin Set_Type (A, TC); New_CC := Clone (CC); Set_Value (Get_Container (A).all, New_CC, Foreign => False); return A; end Get_Aggregate_Element; function Get_Aggregate_Element (Value : Any; Index : Unsigned_Long) return Types.Unsigned_Long renames Elementary_Any_ULong.Get_Aggregate_Element; function Get_Aggregate_Element (Value : Any_Container'Class; Index : Unsigned_Long) return Types.Unsigned_Long renames Elementary_Any_ULong.Get_Aggregate_Element; function Get_Aggregate_Element (Value : Any; Index : Unsigned_Long) return Types.Octet renames Elementary_Any_Octet.Get_Aggregate_Element; function Get_Aggregate_Element (Value : Any_Container'Class; Index : Unsigned_Long) return Types.Octet renames Elementary_Any_Octet.Get_Aggregate_Element; ------------------- -- Get_Container -- ------------------- function Get_Container (A : Any) return Any_Container_Ptr is begin return Any_Container_Ptr (Entity_Of (A)); end Get_Container; ------------------- -- Get_Empty_Any -- ------------------- function Get_Empty_Any (Tc : TypeCode.Local_Ref) return Any is Result : Any; begin pragma Debug (C, O ("Get_Empty_Any: enter")); Set_Type (Result, Tc); pragma Debug (C, O ("Get_Empty_Any: type set")); return Result; end Get_Empty_Any; ----------------------------- -- Get_Empty_Any_Aggregate -- ----------------------------- function Get_Empty_Any_Aggregate (TC : TypeCode.Local_Ref) return Any is A : Any; Kind : constant TCKind := TypeCode.Kind (Unwind_Typedefs (TC)); begin pragma Debug (C, O ("Get_Empty_Any_Aggregate: begin")); Set_Type (A, TC); if Kind in Aggregate_TCKind then Set_Value (Get_Container (A).all, Allocate_Default_Aggregate_Content (Kind), Foreign => False); end if; pragma Debug (C, O ("Get_Empty_Any_Aggregate: end")); return A; end Get_Empty_Any_Aggregate; -------------- -- Get_Type -- -------------- function Get_Type (A : Any) return TypeCode.Local_Ref is begin return TypeCode.To_Ref (Get_Type_Obj (A)); end Get_Type; function Get_Type_Obj (A : Any) return TypeCode.Object_Ptr is begin return Get_Type_Obj (Get_Container (A).all); end Get_Type_Obj; function Get_Type (C : Any_Container'Class) return TypeCode.Local_Ref is begin return TypeCode.To_Ref (Get_Type_Obj (C)); end Get_Type; function Get_Type_Obj (C : Any_Container'Class) return TypeCode.Object_Ptr is begin return TypeCode.Object_Of (C.The_Type); end Get_Type_Obj; ---------------------- -- Get_Unwound_Type -- ---------------------- function Get_Unwound_Type (The_Any : Any) return TypeCode.Object_Ptr is begin return Unwind_Typedefs (Get_Type_Obj (The_Any)); end Get_Unwound_Type; --------------- -- Get_Value -- --------------- function Get_Value (C : Any_Container'Class) return Content_Ptr is begin return C.The_Value; end Get_Value; ----------- -- Image -- ----------- function Image (NV : NamedValue) return Standard.String is function Flag_Name (F : Flags) return Standard.String; pragma Inline (Flag_Name); -- Return string representation for F, which denotes an argument mode --------------- -- Flag_Name -- --------------- function Flag_Name (F : Flags) return Standard.String is begin case F is when ARG_IN => return "in"; when ARG_OUT => return "out"; when ARG_INOUT => return "in out"; when IN_COPY_VALUE => return "in-copy"; when others => return "(invalid flag" & Flags'Image (F) & ")"; end case; end Flag_Name; begin return Flag_Name (NV.Arg_Modes) & " " & To_Standard_String (NV.Name) & " = " & Image (NV.Argument); end Image; ---------------------- -- Image (typecode) -- ---------------------- function Image (TC : TypeCode.Local_Ref) return Standard.String is begin return Image (TypeCode.Object_Of (TC)); end Image; function Image (TC : TypeCode.Object_Ptr) return Standard.String is use TypeCode; Kind : constant TCKind := TypeCode.Kind (TC); Result : Types.String; begin case Kind is when Tk_Objref | Tk_Struct | Tk_Union | Tk_Enum | Tk_Alias | Tk_Value | Tk_Valuebox | Tk_Native | Tk_Abstract_Interface | Tk_Except => Result := To_PolyORB_String (TCKind'Image (Kind) & " ") & Types.String (Name (TC)) & " (" & Types.String (Id (TC)) & ")"; -- Add a few information case Kind is when Tk_Objref | Tk_Native | Tk_Abstract_Interface => return To_Standard_String (Result); when Tk_Alias => return To_Standard_String (Result) & " <" & TCKind'Image (Kind) & ":" & Image (Content_Type (TC)) & ">"; when Tk_Struct | Tk_Except => Result := Result & " {"; for J in 0 .. Member_Count (TC) - 1 loop Result := Result & " " & Image (Member_Type (TC, J)) & " " & Types.String (Member_Name (TC, J)) & ";"; end loop; Result := Result & " }"; return To_Standard_String (Result); when Tk_Union => Result := Result & " (" & Image (Discriminator_Type (TC)) & " :=" & Types.Long'Image (Default_Index (TC)) & ") {"; for J in 0 .. Member_Count (TC) - 1 loop Result := Result & " case " & Ada.Strings.Fixed.Trim (Image (Member_Label (TC, J)), Ada.Strings.Left) & ": " & Image (Member_Type (TC, J)) & " " & Types.String (Member_Name (TC, J)) & ";"; end loop; Result := Result & " }"; return To_Standard_String (Result); when others => return ""; end case; when Tk_Array | Tk_Sequence => return TCKind'Image (Kind) & "<" & Image (Content_Type (TC)) & "," & Unsigned_Long'Image (Length (TC)) & " >"; when Tk_String | Tk_Wstring => declare function Tmpl return String; -- Return template type name, from typecode kind function Tmpl return String is begin if Kind = Tk_Wstring then return "wide_string"; else return "string"; end if; end Tmpl; Bound : constant Types.Unsigned_Long := Length (TC); Bound_Img : constant String := Bound'Img; begin if Bound = 0 then return Tmpl; else return Tmpl & "<" & Bound_Img (Bound_Img'First + 1 .. Bound_Img'Last) & ">"; end if; end; when others => return TCKind'Image (Kind); end case; end Image; ----------------- -- Image (Any) -- ----------------- function Image (A : Any) return Standard.String is begin return Image (Get_Container (A).all); end Image; --------------------------------- -- Image (Any_Container'Class) -- --------------------------------- function Image (C : Any_Container'Class) return Standard.String is TC : constant TypeCode.Local_Ref := Unwind_Typedefs (Get_Type (C)); Kind : constant TCKind := TypeCode.Kind (TC); begin if Is_Empty (C) then return ""; end if; case Kind is when Tk_Short => return Short'Image (From_Any (C)); when Tk_Long => return Long'Image (From_Any (C)); when Tk_Ushort => return Unsigned_Short'Image (From_Any (C)); when Tk_Ulong => return Unsigned_Long'Image (From_Any (C)); when Tk_Float => return Types.Float'Image (From_Any (C)); when Tk_Double => return Double'Image (From_Any (C)); when Tk_Boolean => return Boolean'Image (From_Any (C)); when Tk_Char => return Char'Image (From_Any (C)); when Tk_Octet => return Octet'Image (From_Any (C)); when Tk_String => return Standard.String'(From_Any (C)); when Tk_Longlong => return Long_Long'Image (From_Any (C)); when Tk_Ulonglong => return Unsigned_Long_Long'Image (From_Any (C)); when Tk_Enum => declare Index_C : Any_Container; Val_M : aliased Mechanism := By_Value; CA_Ptr : constant Aggregate_Content_Ptr := Aggregate_Content_Ptr (C.The_Value); Val_CC : aliased Content'Class := Get_Aggregate_Element (CA_Ptr, TypeCode.PTC_Unsigned_Long'Access, 0, Val_M'Access); begin Set_Type (Index_C, TC_Unsigned_Long); Set_Value (Index_C, Val_CC'Unchecked_Access, Foreign => True); return Types.To_Standard_String (TypeCode.Enumerator_Name (TC, From_Any (Index_C))); end; when Tk_Value => return ""; when Tk_Any => return ""; when others => return ""; end case; exception when others => return ""; end Image; ---------------- -- Initialize -- ---------------- procedure Initialize (Self : in out Any) is use type PolyORB.Smart_Pointers.Entity_Ptr; Container : constant Any_Container_Ptr := new Any_Container; begin pragma Debug (C, O ("Initializing Any: enter")); pragma Assert (Entity_Of (Self) = null); Use_Entity (Self, PolyORB.Smart_Pointers.Entity_Ptr (Container)); pragma Debug (C, O ("Initializing Any: leave")); end Initialize; -------------- -- Is_Empty -- -------------- function Is_Empty (A : Any) return Boolean is begin return Is_Empty (Get_Container (A).all); end Is_Empty; -------------- -- Is_Empty -- -------------- function Is_Empty (C : Any_Container'Class) return Boolean is begin return C.The_Value = null; end Is_Empty; -------------------- -- Move_Any_Value -- -------------------- procedure Move_Any_Value (Dst_C, Src_C : in out Any_Container'Class) is begin if Src_C'Address = Dst_C'Address then return; end if; Set_Value (Dst_C, Src_C.The_Value, Src_C.Foreign); Src_C.The_Value := null; Src_C.Foreign := False; end Move_Any_Value; -------------------- -- Move_Any_Value -- -------------------- procedure Move_Any_Value (Dst : Any; Src : Any) is Src_C : constant Any_Container_Ptr := Get_Container (Src); Dst_C : constant Any_Container_Ptr := Get_Container (Dst); begin if TypeCode.Kind (Get_Unwound_Type (Dst)) /= TypeCode.Kind (Get_Unwound_Type (Src)) then pragma Debug (C, O ("Move_Any_Value from: " & Image (Get_Unwound_Type (Src)))); pragma Debug (C, O (" to: " & Image (Get_Unwound_Type (Dst)))); raise TypeCode.Bad_TypeCode; end if; Move_Any_Value (Dst_C.all, Src_C.all); end Move_Any_Value; ------------- -- No_Wrap -- ------------- function No_Wrap (X : access T) return Content'Class is pragma Unreferenced (X); begin raise Program_Error; return No_Content'(null record); end No_Wrap; ------------------------- -- Set_Aggregate_Count -- ------------------------- procedure Set_Aggregate_Count (ACC : in out Default_Aggregate_Content; Count : Types.Unsigned_Long) is Prev_Last : constant Integer := Content_Tables.Last (ACC.V); begin Content_Tables.Set_Last (ACC.V, Content_Tables.First (ACC.V) + Natural (Count) - 1); -- Note: there is no default initialization for table elements, so -- make sure here that they are properly initialized to null. for J in Prev_Last + 1 .. Content_Tables.Last (ACC.V) loop ACC.V.Table (J) := null; end loop; end Set_Aggregate_Count; --------------------------- -- Set_Aggregate_Element -- --------------------------- procedure Set_Aggregate_Element (ACC : in out Aggregate_Content'Class; TC : TypeCode.Local_Ref; Index : Unsigned_Long; From_C : in out Any_Container'Class) is begin Set_Aggregate_Element (ACC, TypeCode.Object_Of (TC), Index, From_C); end Set_Aggregate_Element; procedure Set_Aggregate_Element (ACC : in out Aggregate_Content; TC : TypeCode.Object_Ptr; Index : Unsigned_Long; From_C : in out Any_Container'Class) is begin -- By default this is not implemented. This operation must be overridden -- for derived types of Aggregate_Content that may return No_Content -- in Get_Aggregate_Element. raise Program_Error; end Set_Aggregate_Element; --------------------------- -- Set_Aggregate_Element -- --------------------------- procedure Set_Aggregate_Element (ACC : in out Default_Aggregate_Content; TC : TypeCode.Object_Ptr; Index : Unsigned_Long; From_C : in out Any_Container'Class) is use Content_Tables; V_First : constant Natural := First (ACC.V); El_C : Any_Container'Class renames ACC.V.Table (V_First + Natural (Index)).all; begin if ACC.Kind = Tk_Union and then Index = 0 and then not Is_Empty (El_C) and then ACC.V.Table (V_First + 1) /= null and then not Is_Empty (ACC.V.Table (V_First + 1).all) and then El_C /= From_C then -- Changing the discriminant of a union: finalize previous member, -- if present. Finalize_Value (ACC.V.Table (V_First + 1).all); end if; Set_Type (El_C, TC); if From_C.Foreign then -- If From_C is foreign, we are not allowed to steal its contents -- pointer (it may become invalid at any point). Copy_Any_Value (Dst_C => El_C, Src_C => From_C); else Move_Any_Value (Dst_C => El_C, Src_C => From_C); end if; end Set_Aggregate_Element; ----------------------------- -- Set_Any_Aggregate_Value -- ----------------------------- procedure Set_Any_Aggregate_Value (Agg_C : in out Any_Container'Class) is use TypeCode; Kind : constant TCKind := TypeCode.Kind (Unwind_Typedefs (Get_Type_Obj (Agg_C))); begin pragma Debug (C, O ("Set_Any_Aggregate_Value: enter")); if Kind not in Aggregate_TCKind then raise TypeCode.Bad_TypeCode; end if; pragma Debug (C, O ("Set_Any_Aggregate_Value: typecode is correct")); if Agg_C.The_Value = null then Set_Value (Agg_C, Allocate_Default_Aggregate_Content (Kind), Foreign => False); end if; end Set_Any_Aggregate_Value; ------------------- -- Set_Any_Value -- ------------------- procedure Set_Any_Value (X : Types.Short; C : in out Any_Container'Class) renames Elementary_Any_Short.Set_Any_Value; procedure Set_Any_Value (X : Types.Long; C : in out Any_Container'Class) renames Elementary_Any_Long.Set_Any_Value; procedure Set_Any_Value (X : Types.Long_Long; C : in out Any_Container'Class) renames Elementary_Any_Long_Long.Set_Any_Value; procedure Set_Any_Value (X : Types.Unsigned_Short; C : in out Any_Container'Class) renames Elementary_Any_UShort.Set_Any_Value; procedure Set_Any_Value (X : Types.Unsigned_Long; C : in out Any_Container'Class) renames Elementary_Any_ULong.Set_Any_Value; procedure Set_Any_Value (X : Types.Unsigned_Long_Long; C : in out Any_Container'Class) renames Elementary_Any_ULong_Long.Set_Any_Value; procedure Set_Any_Value (X : Types.Float; C : in out Any_Container'Class) renames Elementary_Any_Float.Set_Any_Value; procedure Set_Any_Value (X : Types.Double; C : in out Any_Container'Class) renames Elementary_Any_Double.Set_Any_Value; procedure Set_Any_Value (X : Types.Long_Double; C : in out Any_Container'Class) renames Elementary_Any_Long_Double.Set_Any_Value; procedure Set_Any_Value (X : Types.Boolean; C : in out Any_Container'Class) renames Elementary_Any_Boolean.Set_Any_Value; procedure Set_Any_Value (X : Types.Char; C : in out Any_Container'Class) renames Elementary_Any_Char.Set_Any_Value; procedure Set_Any_Value (X : Types.Wchar; C : in out Any_Container'Class) renames Elementary_Any_Wchar.Set_Any_Value; procedure Set_Any_Value (X : Types.Octet; C : in out Any_Container'Class) renames Elementary_Any_Octet.Set_Any_Value; procedure Set_Any_Value (X : Any; C : in out Any_Container'Class) renames Elementary_Any_Any.Set_Any_Value; procedure Set_Any_Value (X : TypeCode.Local_Ref; C : in out Any_Container'Class) renames Elementary_Any_TypeCode.Set_Any_Value; procedure Set_Any_Value (X : Types.String; C : in out Any_Container'Class) renames Elementary_Any_String.Set_Any_Value; procedure Set_Any_Value (X : Types.Wide_String; C : in out Any_Container'Class) renames Elementary_Any_Wide_String.Set_Any_Value; procedure Set_Any_Value (X : Standard.String; C : in out Any_Container'Class) is begin Set_Any_Value (To_PolyORB_String (X), C); end Set_Any_Value; procedure Set_Any_Value (X : String; Bound : Positive; C : in out Any_Container'Class) is begin Elementary_Any_Bounded_String.Set_Any_Value (Ada.Strings.Superbounded.To_Super_String (X, Max_Length => Bound), C); end Set_Any_Value; procedure Set_Any_Value (X : Wide_String; Bound : Positive; C : in out Any_Container'Class) is begin Elementary_Any_Bounded_Wide_String.Set_Any_Value (Ada.Strings.Wide_Superbounded.To_Super_String (X, Max_Length => Bound), C); end Set_Any_Value; ------------------- -- Set_Container -- ------------------- procedure Set_Container (A : in out Any; ACP : Any_Container_Ptr) is begin Set (A, Smart_Pointers.Entity_Ptr (ACP)); end Set_Container; -------------- -- Set_Type -- -------------- procedure Set_Type (A : in out Any; TC : TypeCode.Local_Ref) is begin Set_Type (A, TypeCode.Object_Of (TC)); end Set_Type; procedure Set_Type (A : in out Any; TC : TypeCode.Object_Ptr) is begin Set_Type (Get_Container (A).all, TC); end Set_Type; procedure Set_Type (C : in out Any_Container'Class; TC : TypeCode.Local_Ref) is begin Set_Type (C, TypeCode.Object_Of (TC)); end Set_Type; procedure Set_Type (C : in out Any_Container'Class; TC : TypeCode.Object_Ptr) is begin C.The_Type := TypeCode.To_Ref (TC); end Set_Type; --------------- -- Set_Value -- --------------- procedure Set_Value (C : in out Any_Container'Class; CC : Content_Ptr; Foreign : Boolean := True) is begin if C.The_Value /= null and then not C.Foreign then Finalize_Value (C.The_Value.all); Free (C.The_Value); end if; C.The_Value := CC; C.Foreign := Foreign; end Set_Value; ------------ -- To_Any -- ------------ package To_Any_Instances is function To_Any is new To_Any_G (Types.Octet, TC_Octet, Elementary_Any_Octet.Set_Any_Value); function To_Any is new To_Any_G (Types.Short, TC_Short, Elementary_Any_Short.Set_Any_Value); function To_Any is new To_Any_G (Types.Long, TC_Long, Elementary_Any_Long.Set_Any_Value); function To_Any is new To_Any_G (Types.Long_Long, TC_Long_Long, Elementary_Any_Long_Long.Set_Any_Value); function To_Any is new To_Any_G (Types.Unsigned_Short, TC_Unsigned_Short, Elementary_Any_UShort.Set_Any_Value); function To_Any is new To_Any_G (Types.Unsigned_Long, TC_Unsigned_Long, Elementary_Any_ULong.Set_Any_Value); function To_Any is new To_Any_G (Types.Unsigned_Long_Long, TC_Unsigned_Long_Long, Elementary_Any_ULong_Long.Set_Any_Value); function To_Any is new To_Any_G (Types.Boolean, TC_Boolean, Elementary_Any_Boolean.Set_Any_Value); function To_Any is new To_Any_G (Types.Char, TC_Char, Elementary_Any_Char.Set_Any_Value); function To_Any is new To_Any_G (Types.Wchar, TC_Wchar, Elementary_Any_Wchar.Set_Any_Value); function To_Any is new To_Any_G (Types.Float, TC_Float, Elementary_Any_Float.Set_Any_Value); function To_Any is new To_Any_G (Types.Double, TC_Double, Elementary_Any_Double.Set_Any_Value); function To_Any is new To_Any_G (Types.Long_Double, TC_Long_Double, Elementary_Any_Long_Double.Set_Any_Value); function To_Any is new To_Any_G (Types.String, TC_String, Elementary_Any_String.Set_Any_Value); function To_Any is new To_Any_G (Types.Wide_String, TC_Wide_String, Elementary_Any_Wide_String.Set_Any_Value); function To_Any is new To_Any_G (Any, TC_Any, Elementary_Any_Any.Set_Any_Value); function To_Any is new To_Any_G (TypeCode.Local_Ref, TC_TypeCode, Elementary_Any_TypeCode.Set_Any_Value); end To_Any_Instances; function To_Any (X : Types.Octet) return Any renames To_Any_Instances.To_Any; function To_Any (X : Types.Short) return Any renames To_Any_Instances.To_Any; function To_Any (X : Types.Long) return Any renames To_Any_Instances.To_Any; function To_Any (X : Types.Long_Long) return Any renames To_Any_Instances.To_Any; function To_Any (X : Types.Unsigned_Short) return Any renames To_Any_Instances.To_Any; function To_Any (X : Types.Unsigned_Long) return Any renames To_Any_Instances.To_Any; function To_Any (X : Types.Unsigned_Long_Long) return Any renames To_Any_Instances.To_Any; function To_Any (X : Types.Boolean) return Any renames To_Any_Instances.To_Any; function To_Any (X : Types.Char) return Any renames To_Any_Instances.To_Any; function To_Any (X : Types.Wchar) return Any renames To_Any_Instances.To_Any; function To_Any (X : Types.Float) return Any renames To_Any_Instances.To_Any; function To_Any (X : Types.Double) return Any renames To_Any_Instances.To_Any; function To_Any (X : Types.Long_Double) return Any renames To_Any_Instances.To_Any; function To_Any (X : Types.String) return Any renames To_Any_Instances.To_Any; function To_Any (X : Types.Wide_String) return Any renames To_Any_Instances.To_Any; function To_Any (X : Any) return Any renames To_Any_Instances.To_Any; function To_Any (X : TypeCode.Local_Ref) return Any renames To_Any_Instances.To_Any; function To_Any (X : Ada.Strings.Superbounded.Super_String; TC : access function return TypeCode.Local_Ref) return Any is function To_Any is new To_Any_G (Ada.Strings.Superbounded.Super_String, TC.all, Elementary_Any_Bounded_String.Set_Any_Value); begin return To_Any (X); end To_Any; function To_Any (X : Ada.Strings.Wide_Superbounded.Super_String; TC : access function return TypeCode.Local_Ref) return Any is function To_Any is new To_Any_G (Ada.Strings.Wide_Superbounded.Super_String, TC.all, Elementary_Any_Bounded_Wide_String.Set_Any_Value); begin return To_Any (X); end To_Any; function To_Any (X : Standard.String) return Any is begin return To_Any (To_PolyORB_String (X)); end To_Any; --------------------- -- Unchecked_Get_V -- --------------------- function Unchecked_Get_V (X : not null access Content) return System.Address is pragma Unreferenced (X); begin -- By default, content wrappers do not provide direct access to the -- underlying data. return System.Null_Address; end Unchecked_Get_V; --------------------- -- Unwind_Typedefs -- --------------------- function Unwind_Typedefs (TC : TypeCode.Local_Ref) return TypeCode.Local_Ref is begin return TypeCode.To_Ref (Unwind_Typedefs (TypeCode.Object_Of (TC))); end Unwind_Typedefs; function Unwind_Typedefs (TC : TypeCode.Object_Ptr) return TypeCode.Object_Ptr is Result : TypeCode.Object_Ptr := TC; begin while TypeCode.Kind (Result) = Tk_Alias loop Result := TypeCode.Content_Type (Result); end loop; return Result; end Unwind_Typedefs; ---------- -- Wrap -- ---------- function Wrap (X : not null access Types.Octet) return Content'Class renames Elementary_Any_Octet.Wrap; function Wrap (X : not null access Types.Short) return Content'Class renames Elementary_Any_Short.Wrap; function Wrap (X : not null access Types.Long) return Content'Class renames Elementary_Any_Long.Wrap; function Wrap (X : not null access Types.Long_Long) return Content'Class renames Elementary_Any_Long_Long.Wrap; function Wrap (X : not null access Types.Unsigned_Short) return Content'Class renames Elementary_Any_UShort.Wrap; function Wrap (X : not null access Types.Unsigned_Long) return Content'Class renames Elementary_Any_ULong.Wrap; function Wrap (X : not null access Types.Unsigned_Long_Long) return Content'Class renames Elementary_Any_ULong_Long.Wrap; function Wrap (X : not null access Types.Boolean) return Content'Class renames Elementary_Any_Boolean.Wrap; function Wrap (X : not null access Types.Char) return Content'Class renames Elementary_Any_Char.Wrap; function Wrap (X : not null access Types.Wchar) return Content'Class renames Elementary_Any_Wchar.Wrap; function Wrap (X : not null access Types.Float) return Content'Class renames Elementary_Any_Float.Wrap; function Wrap (X : not null access Types.Double) return Content'Class renames Elementary_Any_Double.Wrap; function Wrap (X : not null access Types.Long_Double) return Content'Class renames Elementary_Any_Long_Double.Wrap; function Wrap (X : not null access Types.String) return Content'Class renames Elementary_Any_String.Wrap; function Wrap (X : not null access Types.Wide_String) return Content'Class renames Elementary_Any_Wide_String.Wrap; function Wrap (X : not null access Any) return Content'Class renames Elementary_Any_Any.Wrap; function Wrap (X : not null access TypeCode.Local_Ref) return Content'Class renames Elementary_Any_TypeCode.Wrap; function Wrap (X : not null access Ada.Strings.Superbounded.Super_String) return Content'Class renames Elementary_Any_Bounded_String.Wrap; function Wrap (X : not null access Ada.Strings.Wide_Superbounded.Super_String) return Content'Class renames Elementary_Any_Bounded_Wide_String.Wrap; -------------- -- TypeCode -- -------------- package body TypeCode is -- Empty parameter list subtype Empty_Any_Array is Any_Array (1 .. 0); -- Default complex typecodes PTC_String : TypeCode.Object_Ptr; PTC_Wide_String : TypeCode.Object_Ptr; type Default_Aggregate_Content_Ptr is access all Default_Aggregate_Content'Class; function Parameters (TC : TypeCode.Object_Ptr) return Default_Aggregate_Content_Ptr; pragma Inline (Parameters); -- Return a pointer to the parameters of TC function Get_Parameter (Self : Object_Ptr; Index : Types.Unsigned_Long) return Any_Container_Ptr; -- Extract the Index'th parameter from Self function Get_Parameter (Self : Object_Ptr; Index : Types.Unsigned_Long) return Object_Ptr; -- Special version of Get_Parameter for the case where the parameter -- is itself a TypeCode. ----------- -- Equal -- ----------- function Equal (Left, Right : Local_Ref) return Boolean is begin return Equal (Object_Of (Left), Object_Of (Right)); end Equal; function Equal (Left, Right : Object_Ptr) return Boolean is Nb_Param : Unsigned_Long; begin pragma Debug (C, O ("Equal (TypeCode): enter")); -- Shortcut further tests when testing for the same object if Left = Right then return True; end if; if Kind (Left) /= Kind (Right) then pragma Debug (C, O ("Equal (TypeCode): end")); return False; end if; pragma Debug (C, O ("Equal (TypeCode): parameter number comparison")); Nb_Param := Parameter_Count (Right); if Nb_Param /= Parameter_Count (Left) then pragma Debug (C, O ("Equal (TypeCode): end")); return False; end if; if Nb_Param = 0 then pragma Debug (C, O ("Equal (TypeCode): end")); return True; end if; -- Recursive comparison pragma Debug (C, O ("Equal (TypeCode): recursive comparison")); for J in 0 .. Nb_Param - 1 loop if not "=" (Any_Container'Class'(Get_Parameter (Left, J).all), Any_Container'Class'(Get_Parameter (Right, J).all)) then pragma Debug (C, O ("Equal (TypeCode): end")); return False; end if; end loop; pragma Debug (C, O ("Equal (TypeCode): end")); return True; end Equal; ------------------- -- Add_Parameter -- ------------------- procedure Add_Parameter (Self : Local_Ref; Param : Any) is S_Parameters : Content_Ptr renames Object_Of (Self).Parameters; begin pragma Debug (C, O ("Add_Parameter: enter")); pragma Debug (C, O ("Add_Parameter: adding " & Image (Param))); if S_Parameters = null then S_Parameters := Allocate_Default_Aggregate_Content (Tk_TypeCode); end if; Add_Aggregate_Element (Default_Aggregate_Content (S_Parameters.all), Get_Container (Param)); pragma Debug (C, O ("Add_Parameter: end")); end Add_Parameter; ---------------------- -- Build_Complex_TC -- ---------------------- function Build_Complex_TC (Kind : TCKind; Parameters : Any_Array) return Local_Ref is Obj : constant Object_Ptr := new Object (Kind); Res : Local_Ref; begin Set (Res, Smart_Pointers.Entity_Ptr (Obj)); for J in Parameters'Range loop TypeCode.Add_Parameter (Res, Parameters (J)); end loop; return Res; end Build_Complex_TC; ----------------------- -- Build_Sequence_TC -- ----------------------- function Build_Sequence_TC (Element_TC : TypeCode.Local_Ref; Max : Natural) return Local_Ref is begin return Build_Complex_TC (Tk_Sequence, (To_Any (Types.Unsigned_Long (Max)), To_Any (Element_TC))); end Build_Sequence_TC; ------------------------ -- Concrete_Base_Type -- ------------------------ function Concrete_Base_Type (Self : Local_Ref) return Local_Ref is begin return To_Ref (Concrete_Base_Type (Object_Of (Self))); end Concrete_Base_Type; function Concrete_Base_Type (Self : Object_Ptr) return Object_Ptr is begin case Kind (Self) is when Tk_Value | Tk_Event => return Get_Parameter (Self, 3); when others => raise BadKind; end case; end Concrete_Base_Type; ------------------ -- Content_Type -- ------------------ function Content_Type (Self : Local_Ref) return Local_Ref is begin return To_Ref (Content_Type (Object_Of (Self))); end Content_Type; function Content_Type (Self : Object_Ptr) return Object_Ptr is begin case Kind (Self) is when Tk_Sequence | Tk_Array => return Get_Parameter (Self, 1); when Tk_Valuebox | Tk_Alias => return Get_Parameter (Self, 2); when others => raise BadKind; end case; end Content_Type; --------------------- -- Build_String_TC -- --------------------- function Build_String_TC (Max : Types.Unsigned_Long) return TypeCode.Local_Ref is begin return Build_Complex_TC (Tk_String, (1 => To_Any (Max))); end Build_String_TC; ---------------------- -- Build_Wstring_TC -- ---------------------- function Build_Wstring_TC (Max : Types.Unsigned_Long) return Local_Ref is begin return Build_Complex_TC (Tk_Wstring, (1 => To_Any (Max))); end Build_Wstring_TC; ------------------- -- Default_Index -- ------------------- function Default_Index (Self : Local_Ref) return Types.Long is begin return Default_Index (Object_Of (Self)); end Default_Index; function Default_Index (Self : Object_Ptr) return Types.Long is begin -- See comments after the declaration of TypeCode.Object in the -- private part of PolyORB.Any.TypeCode to understand the magic -- numbers used here. case Kind (Self) is when Tk_Union => return From_Any (Get_Parameter (Self, 3).all); when others => raise BadKind; end case; end Default_Index; -------------------------------- -- Disable_Reference_Counting -- -------------------------------- procedure Disable_Reference_Counting (Self : in out Object) is begin Smart_Pointers.Disable_Reference_Counting (Self); end Disable_Reference_Counting; ------------------------ -- Discriminator_Type -- ------------------------ function Discriminator_Type (Self : Local_Ref) return Local_Ref is begin return To_Ref (Discriminator_Type (Object_Of (Self))); end Discriminator_Type; function Discriminator_Type (Self : Object_Ptr) return Object_Ptr is begin -- See comments after the declaration of TypeCode.Object in the -- private part of PolyORB.Any.TypeCode to understand the magic -- numbers used here. case Kind (Self) is when Tk_Union => return Get_Parameter (Self, 2); when others => raise BadKind; end case; end Discriminator_Type; --------------------- -- Enumerator_Name -- --------------------- function Enumerator_Name (Self : Local_Ref; Index : Unsigned_Long) return Types.Identifier is begin return Enumerator_Name (Object_Of (Self), Index); end Enumerator_Name; function Enumerator_Name (Self : Object_Ptr; Index : Unsigned_Long) return Types.Identifier is Param_Nb : constant Unsigned_Long := Parameter_Count (Self); begin case Kind (Self) is when Tk_Enum => if Param_Nb < Index + 3 then raise Bounds; end if; return Types.Identifier (Types.String' (From_Any (Get_Parameter (Self, Index + 2).all))); when others => raise BadKind; end case; end Enumerator_Name; ---------------- -- Equivalent -- ---------------- function Equivalent (Left, Right : Local_Ref) return Boolean is begin return Equivalent (Object_Of (Left), Object_Of (Right)); end Equivalent; function Equivalent (Left, Right : Object_Ptr) return Boolean is Nb_Param : constant Unsigned_Long := Member_Count (Left); U_Left : Object_Ptr := Left; U_Right : Object_Ptr := Right; begin -- comments are from the spec CORBA v2.3 - 10.7.1 -- If the result of the kind operation on either TypeCode is -- tk_alias, recursively replace the TypeCode with the result of -- calling content_type, until the kind is no longer tk_alias. while Kind (U_Left) = Tk_Alias loop U_Left := Content_Type (U_Left); end loop; while Kind (U_Right) = Tk_Alias loop U_Right := Content_Type (U_Right); end loop; -- TypeCodes of differents kinds are never equivalent if Kind (U_Left) /= Kind (U_Right) then return False; end if; -- If the id operation is valid for the TypeCode kind, equivalent -- returns TRUE if the results of id for both TypeCodes are non-empty -- strings and both strings are equal. If both ids are non-empty but -- are not equal, then equivalent returns FALSE. case Kind (U_Left) is when Tk_Objref | Tk_Struct | Tk_Union | Tk_Enum | Tk_Value | Tk_Valuebox | Tk_Native | Tk_Abstract_Interface | Tk_Except => declare Id_Left : constant RepositoryId := Id (Left); Id_Right : constant RepositoryId := Id (Right); Null_RepositoryId : constant RepositoryId := RepositoryId'(To_PolyORB_String ("")); begin if Id_Left /= Null_RepositoryId and then Id_Right /= Null_RepositoryId then return Id_Left = Id_Right; end if; end; when others => null; end case; -- If either or both id is an empty string, or the TypeCode kind does -- not support the id operation, equivalent will perform structural -- comparison of the TypeCodes by comparing the results of the other -- TypeCode operations in the following bullet items (ignoring -- aliases as described in the first bullet.). The structural -- comparison only calls operations that are valid for the given -- TypeCode kind. If any of these operations do not return equal -- results, then equivalent returns FALSE. If all comparisons are -- equal, equivalent returns true. -- * The results of the name and member_name operations are ignored -- and not compared. -- * The results of the member_count operation are compared. case Kind (Left) is when Tk_Struct | Tk_Union | Tk_Enum | Tk_Value | Tk_Except => if Member_Count (Left) /= Member_Count (Right) then return False; end if; when others => null; end case; -- * The results of the member_type operation for each member -- index are compared by recursively calling equivalent. case Kind (Left) is when Tk_Struct | Tk_Union | Tk_Value | Tk_Except => for J in 0 .. Nb_Param - 1 loop if not Equivalent (Member_Type (Left, J), Member_Type (Right, J)) then return False; end if; end loop; when others => null; end case; -- * The results of the member_label operation for each member -- index of a union TypeCode are compared for equality. Note that -- this means that unions whose members are not defined in the same -- order are not considered structurally equivalent. if Kind (Left) = Tk_Union then for J in 0 .. Nb_Param - 1 loop if Types.Long (J) /= Default_Index (Left) and then Types.Long (J) /= Default_Index (Right) and then Member_Label (Left, J).all /= Member_Label (Right, J).all then return False; end if; end loop; end if; -- * The results of the discriminator_type operation are compared -- by recursively calling equivalent. if Kind (Left) = Tk_Union and then not Equivalent (Discriminator_Type (Left), Discriminator_Type (Right)) then return False; end if; -- * The results of the default_index operation are compared. if Kind (Left) = Tk_Union and then Default_Index (Left) > -1 and then Default_Index (Right) > -1 and then Default_Index (Left) /= Default_Index (Right) then return False; end if; -- * The results of the length operation are compared. case Kind (Left) is when Tk_String | Tk_Sequence | Tk_Array => if Length (Left) /= Length (Right) then return False; end if; when others => null; end case; -- * The results of the discriminator_type operation are compared -- by recursively calling equivalent. case Kind (Left) is when Tk_Sequence | Tk_Array | Tk_Valuebox => if not Equivalent (Content_Type (Left), Content_Type (Right)) then return False; end if; when others => null; end case; -- * The results of the digits and scale operations are compared. if Kind (Left) = Tk_Fixed then if Fixed_Digits (Left) /= Fixed_Digits (Right) or else Fixed_Scale (Left) /= Fixed_Scale (Right) then return False; end if; end if; -- not in spec but to be compared if Kind (Left) = Tk_Value then -- member_visibility for J in 0 .. Nb_Param - 1 loop if Member_Visibility (Left, J) /= Member_Visibility (Right, J) then return False; end if; end loop; -- type_modifier if Type_Modifier (Left) /= Type_Modifier (Right) then return False; end if; -- concrete base type if not Equivalent (Concrete_Base_Type (Left), Concrete_Base_Type (Right)) then return False; end if; end if; -- All structure parameters are equivalent return True; end Equivalent; -------------- -- Finalize -- -------------- procedure Finalize (Self : in out Object) is begin pragma Debug (C, O ("Finalize (TypeCode.Object): enter")); if Self.Parameters /= null then Finalize_Value (Self.Parameters.all); Free (Self.Parameters); end if; pragma Debug (C, O ("Finalize (TypeCode.Object): leave")); end Finalize; ------------------ -- Fixed_Digits -- ------------------ function Fixed_Digits (Self : Local_Ref) return Unsigned_Short is begin return Fixed_Digits (Object_Of (Self)); end Fixed_Digits; function Fixed_Digits (Self : Object_Ptr) return Unsigned_Short is begin case Kind (Self) is when Tk_Fixed => return From_Any (Get_Parameter (Self, 0).all); when others => raise BadKind; end case; end Fixed_Digits; ----------------- -- Fixed_Scale -- ----------------- function Fixed_Scale (Self : Local_Ref) return Short is begin return Fixed_Scale (Object_Of (Self)); end Fixed_Scale; function Fixed_Scale (Self : Object_Ptr) return Short is begin case Kind (Self) is when Tk_Fixed => return From_Any (Get_Parameter (Self, 1).all); when others => raise BadKind; end case; end Fixed_Scale; ------------------- -- Get_Parameter -- ------------------- function Get_Parameter (Self : Object_Ptr; Index : Unsigned_Long) return Any_Container_Ptr is Int_Index : constant Integer := Integer (Index); T : Content_Table renames Parameters (Self).V; begin if Int_Index > Content_Tables.Last (T) then raise Bounds; end if; return T.Table (Int_Index); end Get_Parameter; function Get_Parameter (Self : Object_Ptr; Index : Unsigned_Long) return Object_Ptr is TC_Container : constant Any_Container_Ptr := Get_Parameter (Self, Index); begin -- Here we have an Any that contains a TypeCode. We extract the -- inner TypeCode.Object_Ptr directly rather than doing a From_Any -- to avoid having to do a costly adjust operation on a -- TypeCode.Local_Ref. return Object_Of (Elementary_Any_TypeCode.Unchecked_Get_V (Elementary_Any_TypeCode.T_Content (TC_Container.The_Value.all)'Access).all); end Get_Parameter; -------- -- Id -- -------- function Id (Self : Local_Ref) return RepositoryId is begin return Id (Object_Of (Self)); end Id; function Id (Self : Object_Ptr) return RepositoryId is begin case Kind (Self) is when Tk_Objref | Tk_Struct | Tk_Union | Tk_Enum | Tk_Alias | Tk_Except | Tk_Value | Tk_Valuebox | Tk_Native | Tk_Abstract_Interface | Tk_Local_Interface | Tk_Component | Tk_Home | Tk_Event => return RepositoryId (Types.String'(From_Any (Get_Parameter (Self, 1).all))); when others => raise BadKind; end case; end Id; ---------------- -- Initialize -- ---------------- procedure Initialize is TC_String, TC_Wide_String : Local_Ref; begin -- Do not ref count / garbage collect our library-level root TCs Smart_Pointers.Disable_Reference_Counting (PTC_Null); Smart_Pointers.Disable_Reference_Counting (PTC_Void); Smart_Pointers.Disable_Reference_Counting (PTC_Short); Smart_Pointers.Disable_Reference_Counting (PTC_Long); Smart_Pointers.Disable_Reference_Counting (PTC_Long_Long); Smart_Pointers.Disable_Reference_Counting (PTC_Unsigned_Short); Smart_Pointers.Disable_Reference_Counting (PTC_Unsigned_Long); Smart_Pointers.Disable_Reference_Counting (PTC_Unsigned_Long_Long); Smart_Pointers.Disable_Reference_Counting (PTC_Float); Smart_Pointers.Disable_Reference_Counting (PTC_Double); Smart_Pointers.Disable_Reference_Counting (PTC_Long_Double); Smart_Pointers.Disable_Reference_Counting (PTC_Boolean); Smart_Pointers.Disable_Reference_Counting (PTC_Char); Smart_Pointers.Disable_Reference_Counting (PTC_Wchar); Smart_Pointers.Disable_Reference_Counting (PTC_Octet); Smart_Pointers.Disable_Reference_Counting (PTC_Any); Smart_Pointers.Disable_Reference_Counting (PTC_TypeCode); TC_String := Build_String_TC (0); TC_Wide_String := Build_Wstring_TC (0); PTC_String := Object_Of (TC_String); PTC_Wide_String := Object_Of (TC_Wide_String); Smart_Pointers.Disable_Reference_Counting (PTC_String.all); Smart_Pointers.Disable_Reference_Counting (PTC_Wide_String.all); end Initialize; ------------ -- Is_Nil -- ------------ function Is_Nil (Self : Local_Ref) return Boolean is begin return Smart_Pointers.Is_Nil (Smart_Pointers.Ref (Self)); end Is_Nil; ---------- -- Kind -- ---------- function Kind (Self : Local_Ref) return TCKind is begin return Kind (Object_Of (Self)); end Kind; function Kind (Self : Object_Ptr) return TCKind is begin -- An unset typecode reference is considered to be equivalent to a -- void typecode (this is a small optimization, so that personalities -- need not set a typecode for the reply of void-valued operations). if Self = null then return Tk_Void; else return Self.Kind; end if; end Kind; ------------ -- Length -- ------------ function Length (Self : Local_Ref) return Unsigned_Long is begin return Length (Object_Of (Self)); end Length; function Length (Self : Object_Ptr) return Unsigned_Long is TK : constant TCKind := TypeCode.Kind (Self); begin case TK is when Tk_String | Tk_Wstring | Tk_Sequence | Tk_Array => return From_Any (Get_Parameter (Self, 0).all); when others => pragma Debug (C, O ("Length: no such attribute for " & TK'Img)); raise BadKind; end case; end Length; ------------------ -- Member_Count -- ------------------ function Member_Count (Self : Local_Ref) return Unsigned_Long is begin return Member_Count (Object_Of (Self)); end Member_Count; function Member_Count (Self : Object_Ptr) return Unsigned_Long is Param_Nb : constant Unsigned_Long := Parameter_Count (Self); begin -- See comments after the declaration of TypeCode.Object in the -- private part of PolyORB.Any to understand the magic numbers -- returned here. case Kind (Self) is when Tk_Struct | Tk_Except => return (Param_Nb / 2) - 1; when Tk_Union => return (Param_Nb - 4) / 3; when Tk_Enum => return Param_Nb - 2; when Tk_Value | Tk_Event => return (Param_Nb - 4) / 3; when others => raise BadKind; end case; end Member_Count; ------------------ -- Member_Label -- ------------------ function Member_Label (Self : Local_Ref; Index : Unsigned_Long) return Any is begin return Member_Label (Object_Of (Self), Index); end Member_Label; ------------------ -- Member_Label -- ------------------ function Member_Label (Self : Local_Ref; Index : Unsigned_Long) return Any_Container_Ptr is begin return Member_Label (Object_Of (Self), Index); end Member_Label; ------------------ -- Member_Label -- ------------------ function Member_Label (Self : Object_Ptr; Index : Unsigned_Long) return Any is Result : Any; begin Set (Result, Smart_Pointers.Entity_Ptr (Any_Container_Ptr'(Member_Label (Self, Index)))); return Result; end Member_Label; ------------------ -- Member_Label -- ------------------ function Member_Label (Self : Object_Ptr; Index : Unsigned_Long) return Any_Container_Ptr is Param_Nb : constant Unsigned_Long := Parameter_Count (Self); begin -- See comments after the declaration of TypeCode.Object in the -- private part of PolyORB.Any.TypeCode to understand the magic -- numbers used here. case Kind (Self) is when Tk_Union => if Param_Nb < 3 * Index + 7 then raise Bounds; end if; return Get_Parameter (Self, 3 * Index + 4); when others => raise BadKind; end case; end Member_Label; ----------------- -- Member_Name -- ----------------- function Member_Name (Self : Local_Ref; Index : Unsigned_Long) return Identifier is begin return Member_Name (Object_Of (Self), Index); end Member_Name; ----------------- -- Member_Name -- ----------------- function Member_Name (Self : Object_Ptr; Index : Unsigned_Long) return Identifier is Param_Nb : constant Unsigned_Long := Parameter_Count (Self); Res : PolyORB.Types.String; begin -- See comments after the declaration of TypeCode.Object in the -- private part of PolyORB.Any to understand the magic numbers used -- here. case Kind (Self) is when Tk_Struct | Tk_Except => if Param_Nb < 2 * Index + 4 then raise Bounds; end if; Res := From_Any (Get_Parameter (Self, 2 * Index + 3).all); return Identifier (Res); when Tk_Union => if Param_Nb < 3 * Index + 7 then raise Bounds; end if; Res := From_Any (Get_Parameter (Self, 3 * Index + 6).all); return Identifier (Res); when Tk_Enum => if Param_Nb < Index + 3 then raise Bounds; end if; Res := From_Any (Get_Parameter (Self, Index + 2).all); return Identifier (Res); when Tk_Value | Tk_Event => if Param_Nb < 3 * Index + 7 then raise Bounds; end if; Res := From_Any (Get_Parameter (Self, 3 * Index + 6).all); return Identifier (Res); when others => raise BadKind; end case; end Member_Name; ----------------- -- Member_Type -- ----------------- function Member_Type (Self : Local_Ref; Index : Unsigned_Long) return Local_Ref is begin return To_Ref (Member_Type (Object_Of (Self), Index)); end Member_Type; ----------------- -- Member_Type -- ----------------- function Member_Type (Self : Object_Ptr; Index : Unsigned_Long) return Object_Ptr is Param_Nb : constant Unsigned_Long := Parameter_Count (Self); K : constant TCKind := Kind (Self); begin pragma Debug (C, O ("Member_Type: enter, Kind is " & TCKind'Image (K) & Param_Nb'Img & " parameters")); -- See the big explanation after the declaration of TypeCode.Object -- in the private part of PolyORB.Any.TypeCode to understand the -- magic numbers used here. case K is when Tk_Struct | Tk_Except => if Param_Nb < 2 * Index + 4 then raise Bounds; end if; return Get_Parameter (Self, 2 * Index + 2); when Tk_Union => if Param_Nb < 3 * Index + 7 then raise Bounds; end if; return Get_Parameter (Self, 3 * Index + 5); when Tk_Value | Tk_Event => if Param_Nb < 3 * Index + 7 then raise Bounds; end if; return Get_Parameter (Self, 3 * Index + 5); when others => raise BadKind; end case; end Member_Type; ---------------------------- -- Member_Type_With_Label -- ---------------------------- function Member_Type_With_Label (Self : Local_Ref; Label : Any) return Local_Ref is begin return To_Ref (Member_Type_With_Label (Object_Of (Self), Get_Container (Label).all)); end Member_Type_With_Label; ---------------------------- -- Member_Type_With_Label -- ---------------------------- function Member_Type_With_Label (Self : Object_Ptr; Label : Any) return Object_Ptr is begin return Member_Type_With_Label (Self, Get_Container (Label).all); end Member_Type_With_Label; ---------------------------- -- Member_Type_With_Label -- ---------------------------- function Member_Type_With_Label (Self : Local_Ref; Label : Any_Container'Class) return Local_Ref is begin return To_Ref (Member_Type_With_Label (Object_Of (Self), Label)); end Member_Type_With_Label; ---------------------------- -- Member_Type_With_Label -- ---------------------------- function Member_Type_With_Label (Self : Object_Ptr; Label : Any_Container'Class) return Object_Ptr is Param_Nb : constant Unsigned_Long := Parameter_Count (Self); Label_Found : Boolean := False; Member_Index : Long; begin pragma Debug (C, O ("Member_Type_With_Label: enter")); pragma Debug (C, O ("Member_Type_With_Label: Param_Nb = " & Unsigned_Long'Image (Param_Nb))); -- See comments after the declaration of TypeCode.Object in the -- private part of PolyORB.Any.TypeCode to understand the magic -- numbers used here. if Kind (Self) /= Tk_Union then raise BadKind; end if; -- Look at the members until we got enough with the right label or we -- reach the end. pragma Debug (C, O ("Member_Type_With_Label: enter loop")); -- ??? This is horribly inefficient, we should have a fast lookup -- mechanism mapping a label value to the appropriate member index. Parameters : for Current_Member in 0 .. (Param_Nb - 4) / 3 - 1 loop -- We ignore the default member, as its placeholder label could -- interfere with a non-default label. if Long (Current_Member) /= Default_Index (Self) and then Member_Label (Self, Current_Member).all = Label then pragma Debug (C, O ("Member_Type_With_Label: matching label")); Label_Found := True; Member_Index := Long (Current_Member); exit Parameters; end if; end loop Parameters; if not Label_Found then Member_Index := Default_Index (Self); pragma Debug (C, O ("Member_Type_With_Label: using default member at index " & Member_Index'Img)); end if; if Member_Index = -1 then -- No member with this label: return void type return PTC_Void'Access; end if; return Get_Parameter (Self, 3 * Unsigned_Long (Member_Index) + 5); end Member_Type_With_Label; ----------------------- -- Member_Visibility -- ----------------------- function Member_Visibility (Self : Local_Ref; Index : Unsigned_Long) return Visibility is begin return Member_Visibility (Object_Of (Self), Index); end Member_Visibility; function Member_Visibility (Self : Object_Ptr; Index : Unsigned_Long) return Visibility is begin -- See comments after the declaration of TypeCode.Object in the -- private part of PolyORB.Any.TypeCode to understand the magic -- numbers used here. case Kind (Self) is when Tk_Value | Tk_Event => declare Param_Nb : constant Unsigned_Long := Parameter_Count (Self); begin if Param_Nb < 3 * Index + 7 then raise Bounds; end if; return Visibility (Short' (From_Any (Get_Parameter (Self, 3 * Index + 3).all))); end; when others => raise BadKind; end case; end Member_Visibility; ---------- -- Name -- ---------- function Name (Self : Local_Ref) return Identifier is begin return Name (Object_Of (Self)); end Name; function Name (Self : Object_Ptr) return Identifier is begin case Kind (Self) is when Tk_Objref | Tk_Struct | Tk_Union | Tk_Enum | Tk_Alias | Tk_Except | Tk_Value | Tk_Valuebox | Tk_Native | Tk_Abstract_Interface | Tk_Local_Interface | Tk_Component | Tk_Home | Tk_Event => declare Res : PolyORB.Types.String; begin Res := From_Any (Get_Parameter (Self, 0).all); return Identifier (Res); end; when others => raise BadKind; end case; end Name; --------------- -- Object_Of -- --------------- function Object_Of (Self : Local_Ref) return Object_Ptr is begin return Object_Ptr (Entity_Of (Self)); end Object_Of; --------------------- -- Parameter_Count -- --------------------- function Parameter_Count (Self : Local_Ref) return Unsigned_Long is begin return Parameter_Count (Object_Of (Self)); end Parameter_Count; function Parameter_Count (Self : Object_Ptr) return Unsigned_Long is use Content_Tables; ACC : constant Default_Aggregate_Content_Ptr := Parameters (Self); begin if ACC = null then return 0; else return Types.Unsigned_Long (Last (ACC.V) - First (ACC.V) + 1); end if; end Parameter_Count; ---------------- -- Parameters -- ---------------- function Parameters (TC : TypeCode.Object_Ptr) return Default_Aggregate_Content_Ptr is begin return Default_Aggregate_Content_Ptr (TC.Parameters); end Parameters; ------------- -- TC_Null -- ------------- function TC_Null return TypeCode.Local_Ref is begin return To_Ref (PTC_Null'Access); end TC_Null; ------------- -- TC_Void -- ------------- function TC_Void return TypeCode.Local_Ref is begin return To_Ref (PTC_Void'Access); end TC_Void; -------------- -- TC_Short -- -------------- function TC_Short return TypeCode.Local_Ref is begin return To_Ref (PTC_Short'Access); end TC_Short; ------------- -- TC_Long -- ------------- function TC_Long return TypeCode.Local_Ref is begin return To_Ref (PTC_Long'Access); end TC_Long; ------------------ -- TC_Long_Long -- ------------------ function TC_Long_Long return TypeCode.Local_Ref is begin return To_Ref (PTC_Long_Long'Access); end TC_Long_Long; ----------------------- -- TC_Unsigned_Short -- ----------------------- function TC_Unsigned_Short return TypeCode.Local_Ref is begin return To_Ref (PTC_Unsigned_Short'Access); end TC_Unsigned_Short; ---------------------- -- TC_Unsigned_Long -- ---------------------- function TC_Unsigned_Long return TypeCode.Local_Ref is begin return To_Ref (PTC_Unsigned_Long'Access); end TC_Unsigned_Long; --------------------------- -- TC_Unsigned_Long_Long -- --------------------------- function TC_Unsigned_Long_Long return TypeCode.Local_Ref is begin return To_Ref (PTC_Unsigned_Long_Long'Access); end TC_Unsigned_Long_Long; -------------- -- TC_Float -- -------------- function TC_Float return TypeCode.Local_Ref is begin return To_Ref (PTC_Float'Access); end TC_Float; --------------- -- TC_Double -- --------------- function TC_Double return TypeCode.Local_Ref is begin return To_Ref (PTC_Double'Access); end TC_Double; -------------------- -- TC_Long_Double -- -------------------- function TC_Long_Double return TypeCode.Local_Ref is begin return To_Ref (PTC_Long_Double'Access); end TC_Long_Double; ---------------- -- TC_Boolean -- ---------------- function TC_Boolean return TypeCode.Local_Ref is begin return To_Ref (PTC_Boolean'Access); end TC_Boolean; ------------- -- TC_Char -- ------------- function TC_Char return TypeCode.Local_Ref is begin return To_Ref (PTC_Char'Access); end TC_Char; -------------- -- TC_Wchar -- -------------- function TC_Wchar return TypeCode.Local_Ref is begin return To_Ref (PTC_Wchar'Access); end TC_Wchar; -------------- -- TC_Octet -- -------------- function TC_Octet return TypeCode.Local_Ref is begin return To_Ref (PTC_Octet'Access); end TC_Octet; ------------ -- TC_Any -- ------------ function TC_Any return TypeCode.Local_Ref is begin return To_Ref (PTC_Any'Access); end TC_Any; ----------------- -- TC_TypeCode -- ----------------- function TC_TypeCode return TypeCode.Local_Ref is begin return To_Ref (PTC_TypeCode'Access); end TC_TypeCode; --------------- -- TC_String -- --------------- function TC_String return Local_Ref is begin return To_Ref (PTC_String); end TC_String; -------------------- -- TC_Wide_String -- -------------------- function TC_Wide_String return Local_Ref is begin return To_Ref (PTC_Wide_String); end TC_Wide_String; ------------------ -- TC_Principal -- ------------------ function TC_Principal return TypeCode.Local_Ref is E : Empty_Any_Array; begin return Build_Complex_TC (Tk_Principal, E); end TC_Principal; --------------- -- TC_Struct -- --------------- function TC_Struct return TypeCode.Local_Ref is E : Empty_Any_Array; begin return Build_Complex_TC (Tk_Struct, E); end TC_Struct; -------------- -- TC_Union -- -------------- function TC_Union return TypeCode.Local_Ref is E : Empty_Any_Array; begin return Build_Complex_TC (Tk_Union, E); end TC_Union; ------------- -- TC_Enum -- ------------- function TC_Enum return TypeCode.Local_Ref is E : Empty_Any_Array; begin return Build_Complex_TC (Tk_Enum, E); end TC_Enum; -------------- -- TC_Alias -- -------------- function TC_Alias return TypeCode.Local_Ref is E : Empty_Any_Array; begin return Build_Complex_TC (Tk_Alias, E); end TC_Alias; --------------- -- TC_Except -- --------------- function TC_Except return TypeCode.Local_Ref is E : Empty_Any_Array; begin return Build_Complex_TC (Tk_Except, E); end TC_Except; --------------- -- TC_Object -- --------------- function TC_Object return TypeCode.Local_Ref is E : Empty_Any_Array; begin return Build_Complex_TC (Tk_Objref, E); end TC_Object; -------------- -- TC_Fixed -- -------------- function TC_Fixed return TypeCode.Local_Ref is E : Empty_Any_Array; begin return Build_Complex_TC (Tk_Fixed, E); end TC_Fixed; ----------------- -- TC_Sequence -- ----------------- function TC_Sequence return TypeCode.Local_Ref is E : Empty_Any_Array; begin return Build_Complex_TC (Tk_Sequence, E); end TC_Sequence; -------------- -- TC_Array -- -------------- function TC_Array return TypeCode.Local_Ref is E : Empty_Any_Array; begin return Build_Complex_TC (Tk_Array, E); end TC_Array; -------------- -- TC_Value -- -------------- function TC_Value return TypeCode.Local_Ref is E : Empty_Any_Array; begin return Build_Complex_TC (Tk_Value, E); end TC_Value; ----------------- -- TC_Valuebox -- ----------------- function TC_Valuebox return TypeCode.Local_Ref is E : Empty_Any_Array; begin return Build_Complex_TC (Tk_Valuebox, E); end TC_Valuebox; --------------- -- TC_Native -- --------------- function TC_Native return TypeCode.Local_Ref is E : Empty_Any_Array; begin return Build_Complex_TC (Tk_Native, E); end TC_Native; --------------------------- -- TC_Abstract_Interface -- --------------------------- function TC_Abstract_Interface return TypeCode.Local_Ref is E : Empty_Any_Array; begin return Build_Complex_TC (Tk_Abstract_Interface, E); end TC_Abstract_Interface; ------------------------ -- TC_Local_Interface -- ------------------------ function TC_Local_Interface return TypeCode.Local_Ref is E : Empty_Any_Array; begin return Build_Complex_TC (Tk_Local_Interface, E); end TC_Local_Interface; ------------------ -- TC_Component -- ------------------ function TC_Component return TypeCode.Local_Ref is E : Empty_Any_Array; begin return Build_Complex_TC (Tk_Component, E); end TC_Component; ------------- -- TC_Home -- ------------- function TC_Home return TypeCode.Local_Ref is E : Empty_Any_Array; begin return Build_Complex_TC (Tk_Home, E); end TC_Home; -------------- -- TC_Event -- -------------- function TC_Event return TypeCode.Local_Ref is E : Empty_Any_Array; begin return Build_Complex_TC (Tk_Event, E); end TC_Event; ------------ -- To_Ref -- ------------ function To_Ref (Self : Object_Ptr) return Local_Ref is Result : Local_Ref; begin Set (Result, Smart_Pointers.Entity_Ptr (Self)); return Result; end To_Ref; ------------------- -- Type_Modifier -- ------------------- function Type_Modifier (Self : Local_Ref) return ValueModifier is begin return Type_Modifier (Object_Of (Self)); end Type_Modifier; function Type_Modifier (Self : Object_Ptr) return ValueModifier is begin case Kind (Self) is when Tk_Value | Tk_Event => return ValueModifier (Short'(From_Any (Get_Parameter (Self, 2).all))); when others => raise BadKind; end case; end Type_Modifier; end TypeCode; end PolyORB.Any; polyorb-2.8~20110207.orig/src/polyorb-rt_poa_policies-priority_model_policy.ads0000644000175000017500000001045411750740340027143 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- POLYORB.RT_POA_POLICIES.PRIORITY_MODEL_POLICY -- -- -- -- S p e c -- -- -- -- Copyright (C) 2004-2005 Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with PolyORB.Errors; with PolyORB.POA_Policies; with PolyORB.Servants; with PolyORB.Tasking.Priorities; package PolyORB.RT_POA_Policies.Priority_Model_Policy is use PolyORB.POA_Policies; use PolyORB.Tasking.Priorities; type Priority_Model is (CLIENT_PROPAGATED, SERVER_DECLARED); type PriorityModelPolicy (Model : Priority_Model) is new PolyORB.POA_Policies.Policy with private; type PriorityModelPolicy_Access is access all PriorityModelPolicy'Class; function Create (Model : Priority_Model; Server_ORB_Priority : ORB_Priority; Server_External_Priority : External_Priority) return Policy_Access; function Policy_Id (Self : PriorityModelPolicy) return String; procedure Check_Compatibility (Self : PriorityModelPolicy; Other_Policies : AllPolicies; Error : in out PolyORB.Errors.Error_Container); procedure Get_Servant_Priority_Information (Servant : Servants.Servant_Access; Model : out Priority_Model; Server_ORB_Priority : out ORB_Priority; Server_External_Priority : out External_Priority; Error : in out PolyORB.Errors.Error_Container); -- Retrieve information on ThreadPoolPolicy stored in Servant procedure Set_Servant_Priority_Information (Self : PriorityModelPolicy; Servant : PolyORB.Servants.Servant_Access); -- Cache Self information into Servant, use Self data procedure Set_Servant_Priority_Information (Self : PriorityModelPolicy; Servant : Servants.Servant_Access; Server_ORB_Priority : ORB_Priority; Server_External_Priority : External_Priority; Error : in out PolyORB.Errors.Error_Container); -- Cache Self information into Servant. Force values to -- Server_ORB_Priority and Server_External_Priority. private type PriorityModelPolicy (Model : Priority_Model) is new PolyORB.POA_Policies.Policy with record Server_ORB_Priority : ORB_Priority; Server_External_Priority : External_Priority := Invalid_Priority; end record; end PolyORB.RT_POA_Policies.Priority_Model_Policy; polyorb-2.8~20110207.orig/src/polyorb-obj_adapters.adb0000644000175000017500000001253411750740340021767 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . O B J _ A D A P T E R S -- -- -- -- B o d y -- -- -- -- Copyright (C) 2001-2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ package body PolyORB.Obj_Adapters is ------------- -- Destroy -- ------------- procedure Destroy (OA : access Obj_Adapter) is begin Annotations.Destroy (OA.Notepad); end Destroy; -------------- -- Finalize -- -------------- procedure Finalize (OA : in out Obj_Adapter) is begin -- Use Unchecked_Access so that passed value can be freely converted -- to named access type within the processing for Destroy. Destroy (Obj_Adapter'Class (OA)'Unchecked_Access); end Finalize; -------------------- -- Oid_To_Rel_URI -- -------------------- -- Default relative URI representation of an object ID: -- "/" & hexadecimal representation of oid value. procedure Oid_To_Rel_URI (OA : access Obj_Adapter; Id : access Objects.Object_Id; URI : out Types.String; Error : in out PolyORB.Errors.Error_Container) is pragma Warnings (Off); pragma Unreferenced (OA, Error); pragma Warnings (On); begin URI := Types.To_PolyORB_String ("/" & Objects.Oid_To_Hex_String (Id.all)); -- XXX should URI_Encode the oid, not hexify it! end Oid_To_Rel_URI; -------------------- -- Rel_URI_To_Oid -- -------------------- function Rel_URI_To_Oid (OA : access Obj_Adapter; URI : String) return Objects.Object_Id_Access is pragma Warnings (Off); pragma Unreferenced (OA); pragma Warnings (On); begin if URI (URI'First) /= '/' then raise Constraint_Error; end if; return new Objects.Object_Id' (Objects.Hex_String_To_Oid (URI (URI'First + 1 .. URI'Last))); end Rel_URI_To_Oid; ------------------ -- Is_Proxy_Oid -- ------------------ function Is_Proxy_Oid (OA : access Obj_Adapter; Oid : access Objects.Object_Id) return Boolean is pragma Warnings (Off); pragma Unreferenced (OA, Oid); pragma Warnings (On); begin return False; -- In the default implementation, proxy object -- Ids are not supported, and thus no oid is -- a proxy oid. end Is_Proxy_Oid; ------------------ -- To_Proxy_Oid -- ------------------ procedure To_Proxy_Oid (OA : access Obj_Adapter; R : References.Ref; Oid : out Objects.Object_Id_Access; Error : in out PolyORB.Errors.Error_Container) is pragma Unreferenced (OA, R, Oid); use PolyORB.Errors; begin Throw (Error, No_Implement_E, System_Exception_Members' (Minor => 0, Completed => Completed_Maybe)); end To_Proxy_Oid; ------------------ -- Proxy_To_Ref -- ------------------ procedure Proxy_To_Ref (OA : access Obj_Adapter; Oid : access Objects.Object_Id; Ref : out References.Ref; Error : in out PolyORB.Errors.Error_Container) is pragma Unreferenced (OA, Ref, Oid); use PolyORB.Errors; begin Throw (Error, No_Implement_E, System_Exception_Members' (Minor => 0, Completed => Completed_Maybe)); end Proxy_To_Ref; ---------------- -- Notepad_Of -- ---------------- function Notepad_Of (OA : access Obj_Adapter) return Annotations.Notepad_Access is begin return OA.Notepad'Access; end Notepad_Of; end PolyORB.Obj_Adapters; polyorb-2.8~20110207.orig/src/polyorb-types.adb0000644000175000017500000001016511750740340020474 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . T Y P E S -- -- -- -- B o d y -- -- -- -- Copyright (C) 2001 Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by ACT Europe. -- -- (email: sales@act-europe.fr) -- -- -- ------------------------------------------------------------------------------ -- Base data types for the whole middleware. package body PolyORB.Types is ----------------------------- -- Trimmed_Image functions -- ----------------------------- function Trimmed_Image (X : Long_Long) return Standard.String is R : constant Standard.String := Long_Long'Image (X); begin if X >= 0 then declare subtype Slide is Standard.String (1 .. R'Length - 1); -- It seems slightly beneficial to make sure the result has -- 'First = 1. begin return Slide (R (R'First + 1 .. R'Last)); end; else return R; end if; end Trimmed_Image; function Trimmed_Image (X : Unsigned_Long_Long) return Standard.String is R : constant Standard.String := Unsigned_Long_Long'Image (X); subtype Slide is Standard.String (1 .. R'Length - 1); -- It seems slightly beneficial to make sure the result has 'First = 1. begin return Slide (R (R'First + 1 .. R'Last)); end Trimmed_Image; --------------------------------- -- String conversion functions -- --------------------------------- function To_PolyORB_String (Source : Standard.String) return Types.String is begin return Types.String (Ada.Strings.Unbounded.To_Unbounded_String (Source)); end To_PolyORB_String; function To_Standard_String (Source : Types.String) return Standard.String is begin return Ada.Strings.Unbounded.To_String (Ada.Strings.Unbounded.Unbounded_String (Source)); end To_Standard_String; function To_PolyORB_Wide_String (Source : Standard.Wide_String) return Types.Wide_String is begin return Types.Wide_String (Ada.Strings.Wide_Unbounded.To_Unbounded_Wide_String (Source)); end To_PolyORB_Wide_String; function To_Standard_Wide_String (Source : Types.Wide_String) return Standard.Wide_String is begin return Ada.Strings.Wide_Unbounded.To_Wide_String (Ada.Strings.Wide_Unbounded.Unbounded_Wide_String (Source)); end To_Standard_Wide_String; end PolyORB.Types; polyorb-2.8~20110207.orig/src/polyorb-poa_policies-id_uniqueness_policy-unique.ads0000644000175000017500000000620711750740340027555 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- POLYORB.POA_POLICIES.ID_UNIQUENESS_POLICY.UNIQUE -- -- -- -- S p e c -- -- -- -- Copyright (C) 2001-2005 Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ package PolyORB.POA_Policies.Id_Uniqueness_Policy.Unique is type Unique_Id_Policy is new IdUniquenessPolicy with null record; type Unique_Id_Policy_Access is access all Unique_Id_Policy; function Create return Unique_Id_Policy_Access; procedure Check_Compatibility (Self : Unique_Id_Policy; Other_Policies : AllPolicies; Error : in out PolyORB.Errors.Error_Container); function Policy_Id (Self : Unique_Id_Policy) return String; procedure Ensure_Servant_Uniqueness (Self : Unique_Id_Policy; OA : PolyORB.POA_Types.Obj_Adapter_Access; P_Servant : Servants.Servant_Access; Error : in out PolyORB.Errors.Error_Container); procedure Activate_Again (Self : Unique_Id_Policy; OA : PolyORB.POA_Types.Obj_Adapter_Access; P_Servant : Servants.Servant_Access; Oid : Object_Id_Access; Result : out Object_Id_Access; Error : in out PolyORB.Errors.Error_Container); end PolyORB.POA_Policies.Id_Uniqueness_Policy.Unique; polyorb-2.8~20110207.orig/src/polyorb-binding_data-neighbour.ads0000644000175000017500000001022611750740340023732 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . B I N D I N G _ D A T A . N E I G H B O U R -- -- -- -- S p e c -- -- -- -- Copyright (C) 2006-2011, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- Neighbour profiles are used to reach partitions for which a local client -- binding object linking to them exists, which we call the target binding -- object. Neighbour profiles allow us to make requests to remote object in -- one of these partitions using this target binding object and an Object_Id. -- Per construction, neighbour profiles always bind to their target BO. with PolyORB.Objects; package PolyORB.Binding_Data.Neighbour is pragma Elaborate_Body; type Neighbour_Profile_Type is new Profile_Type with private; procedure Create_Neighbour_Profile (BO : Smart_Pointers.Ref; Oid : Objects.Object_Id; P : out Neighbour_Profile_Type); -- Create a neighbour profile: BO is the target binding object, and Oid the -- id of the object this profile designates. --------------------------------------------- -- Overridden primitives from Profile_Type -- --------------------------------------------- procedure Release (P : in out Neighbour_Profile_Type); function Duplicate_Profile (P : Neighbour_Profile_Type) return Profile_Access; procedure Bind_Profile (Profile : access Neighbour_Profile_Type; The_ORB : Components.Component_Access; QoS : PolyORB.QoS.QoS_Parameters; BO_Ref : out Smart_Pointers.Ref; Error : out Errors.Error_Container); function Get_Profile_Tag (Profile : Neighbour_Profile_Type) return Profile_Tag; pragma Inline (Get_Profile_Tag); function Get_Profile_Preference (Profile : Neighbour_Profile_Type) return Profile_Preference; pragma Inline (Get_Profile_Preference); function Image (Prof : Neighbour_Profile_Type) return String; function Is_Colocated (Left : Neighbour_Profile_Type; Right : Profile_Type'Class) return Boolean; private type Neighbour_Profile_Type is new Profile_Type with record Target_Binding_Object : Smart_Pointers.Ref; -- The binding object used to create the profile. This BO links to -- the partition the profile designates. The profile always bind to -- this BO. end record; end PolyORB.Binding_Data.Neighbour; polyorb-2.8~20110207.orig/src/polyorb-services-naming-namingcontext-helper.adb0000644000175000017500000004145711750740340026563 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- POLYORB.SERVICES.NAMING.NAMINGCONTEXT.HELPER -- -- -- -- B o d y -- -- -- -- Copyright (C) 2002-2007, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with PolyORB.Any.ObjRef; with PolyORB.Exceptions; with PolyORB.Initialization; -- with PolyORB.Minimal_Servant; with PolyORB.Smart_Pointers; with PolyORB.Types; with PolyORB.Utils.Strings; with PolyORB.Services.Naming.Helper; package body PolyORB.Services.Naming.NamingContext.Helper is use PolyORB.Any; use PolyORB.Any.ObjRef; use PolyORB.Types; use PolyORB.Services.Naming.Helper; ---------------------- -- Unchecked_To_Ref -- ---------------------- function Unchecked_To_Ref (The_Ref : PolyORB.References.Ref) return PolyORB.Services.Naming.NamingContext.Ref is Result : PolyORB.Services.Naming.NamingContext.Ref; begin Set (Result, PolyORB.Smart_Pointers.Entity_Of (Smart_Pointers.Ref (The_Ref))); return Result; end Unchecked_To_Ref; ------------ -- To_Ref -- ------------ function To_Ref (The_Ref : PolyORB.References.Ref) return PolyORB.Services.Naming.NamingContext.Ref is begin -- if CORBA.Object.Is_Nil (The_Ref) -- or else CORBA.Object.Is_A (The_Ref, Repository_Id) then return Unchecked_To_Ref (The_Ref); -- end if; -- PolyORB.Exceptions.Raise_Bad_Param; end To_Ref; -------------- -- From_Any -- -------------- function From_Any (Item : PolyORB.Any.Any) return NamingContext.Ref is begin return To_Ref (PolyORB.Any.ObjRef.From_Any (Item)); end From_Any; function From_Any (Item : PolyORB.Any.Any) return NamingContext.NotFoundReason is Index : constant PolyORB.Any.Any := Get_Aggregate_Element (Item, TypeCode.TC_Unsigned_Long, PolyORB.Types.Unsigned_Long (0)); Position : constant PolyORB.Types.Unsigned_Long := From_Any (Index); begin return NotFoundReason'Val (Position); end From_Any; function From_Any (Item : PolyORB.Any.Any) return NamingContext.NotFound_Members is Index : PolyORB.Any.Any; Result_why : NamingContext.NotFoundReason; Result_rest_of_name : Name; begin Index := Get_Aggregate_Element (Item, TC_NotFoundReason, PolyORB.Types.Unsigned_Long (0)); Result_why := From_Any (Index); Index := Get_Aggregate_Element (Item, TC_Name, PolyORB.Types.Unsigned_Long (1)); Result_rest_of_name := From_Any (Index); return (why => Result_why, rest_of_name => Result_rest_of_name); end From_Any; function From_Any (Item : PolyORB.Any.Any) return NamingContext.CannotProceed_Members is Index : PolyORB.Any.Any; Result_cxt : NamingContext.Ref; Result_rest_of_name : Name; begin Index := Get_Aggregate_Element (Item, TC_NamingContext, PolyORB.Types.Unsigned_Long (0)); Result_cxt := From_Any (Index); Index := Get_Aggregate_Element (Item, TC_Name, PolyORB.Types.Unsigned_Long (1)); Result_rest_of_name := From_Any (Index); return (cxt => Result_cxt, rest_of_name => Result_rest_of_name); end From_Any; function From_Any (Item : PolyORB.Any.Any) return NamingContext.InvalidName_Members is Result : InvalidName_Members; begin pragma Warnings (Off); pragma Unreferenced (Item); pragma Warnings (On); return Result; end From_Any; function From_Any (Item : PolyORB.Any.Any) return NamingContext.AlreadyBound_Members is Result : AlreadyBound_Members; begin pragma Warnings (Off); pragma Unreferenced (Item); pragma Warnings (On); return Result; end From_Any; function From_Any (Item : PolyORB.Any.Any) return NamingContext.NotEmpty_Members is Result : NotEmpty_Members; begin pragma Warnings (Off); pragma Unreferenced (Item); pragma Warnings (On); return Result; end From_Any; --------------------------------- -- Raise_AlreadyBound_From_Any -- --------------------------------- procedure Raise_AlreadyBound_From_Any (Item : PolyORB.Any.Any; Message : Standard.String) is Members : constant AlreadyBound_Members := From_Any (Item); begin PolyORB.Exceptions.User_Raise_Exception (AlreadyBound'Identity, Members, Message); end Raise_AlreadyBound_From_Any; ---------------------------------- -- Raise_CannotProceed_From_Any -- ---------------------------------- procedure Raise_CannotProceed_From_Any (Item : PolyORB.Any.Any; Message : Standard.String) is Members : constant CannotProceed_Members := From_Any (Item); begin PolyORB.Exceptions.User_Raise_Exception (CannotProceed'Identity, Members, Message); end Raise_CannotProceed_From_Any; -------------------------------- -- Raise_InvalidName_From_Any -- -------------------------------- procedure Raise_InvalidName_From_Any (Item : PolyORB.Any.Any; Message : Standard.String) is Members : constant InvalidName_Members := From_Any (Item); begin PolyORB.Exceptions.User_Raise_Exception (InvalidName'Identity, Members, Message); end Raise_InvalidName_From_Any; ----------------------------- -- Raise_NotEmpty_From_Any -- ----------------------------- procedure Raise_NotEmpty_From_Any (Item : PolyORB.Any.Any; Message : Standard.String) is Members : constant NotEmpty_Members := From_Any (Item); begin PolyORB.Exceptions.User_Raise_Exception (NotEmpty'Identity, Members, Message); end Raise_NotEmpty_From_Any; ----------------------------- -- Raise_NotFound_From_Any -- ----------------------------- procedure Raise_NotFound_From_Any (Item : PolyORB.Any.Any; Message : Standard.String) is Members : constant NotFound_Members := From_Any (Item); begin PolyORB.Exceptions.User_Raise_Exception (NotFound'Identity, Members, Message); end Raise_NotFound_From_Any; ------------ -- To_Any -- ------------ function To_Any (Item : NamingContext.Ref) return PolyORB.Any.Any is A : PolyORB.Any.Any := PolyORB.Any.ObjRef.To_Any (PolyORB.References.Ref (Item)); begin Set_Type (A, TC_NamingContext); return A; end To_Any; function To_Any (Item : NamingContext.NotFoundReason) return PolyORB.Any.Any is Result : PolyORB.Any.Any := Get_Empty_Any_Aggregate (TC_NotFoundReason); begin Add_Aggregate_Element (Result, To_Any (PolyORB.Types.Unsigned_Long (NotFoundReason'Pos (Item)))); return Result; end To_Any; function To_Any (Item : NamingContext.NotFound_Members) return PolyORB.Any.Any is Result : PolyORB.Any.Any := Get_Empty_Any_Aggregate (TC_NotFound); begin Add_Aggregate_Element (Result, To_Any (Item.why)); Add_Aggregate_Element (Result, To_Any (Item.rest_of_name)); return Result; end To_Any; function To_Any (Item : NamingContext.CannotProceed_Members) return PolyORB.Any.Any is Result : PolyORB.Any.Any := Get_Empty_Any_Aggregate (TC_CannotProceed); begin Add_Aggregate_Element (Result, To_Any (Item.cxt)); Add_Aggregate_Element (Result, To_Any (Item.rest_of_name)); return Result; end To_Any; function To_Any (Item : NamingContext.InvalidName_Members) return PolyORB.Any.Any is Result : constant PolyORB.Any.Any := Get_Empty_Any_Aggregate (TC_InvalidName); begin pragma Warnings (Off); pragma Unreferenced (Item); pragma Warnings (On); return Result; end To_Any; function To_Any (Item : NamingContext.AlreadyBound_Members) return PolyORB.Any.Any is Result : constant PolyORB.Any.Any := Get_Empty_Any_Aggregate (TC_AlreadyBound); begin pragma Warnings (Off); pragma Unreferenced (Item); pragma Warnings (On); return Result; end To_Any; function To_Any (Item : NamingContext.NotEmpty_Members) return PolyORB.Any.Any is Result : constant PolyORB.Any.Any := Get_Empty_Any_Aggregate (TC_NotEmpty); begin pragma Warnings (Off); pragma Unreferenced (Item); pragma Warnings (On); return Result; end To_Any; ---------------- -- Initialize -- ---------------- procedure Initialize; procedure Initialize is use PolyORB.Any.TypeCode; begin declare Name : constant PolyORB.Types.String := To_PolyORB_String ("NamingContext"); Id : constant PolyORB.Types.String := To_PolyORB_String ("IDL:omg.org/CosNaming/NamingContext:1.0"); begin TC_NamingContext := TypeCode.TC_Object; Add_Parameter (TC_NamingContext, To_Any (Name)); Add_Parameter (TC_NamingContext, To_Any (Id)); Disable_Reference_Counting (Object_Of (TC_NamingContext).all); end; declare Name : constant PolyORB.Types.String := To_PolyORB_String ("NotFoundReason"); Id : constant PolyORB.Types.String := To_PolyORB_String ("IDL:omg.org/CosNaming/NamingContext/NotFoundReason:1.0"); missing_node_Name : constant PolyORB.Types.String := To_PolyORB_String ("missing_node"); not_context_Name : constant PolyORB.Types.String := To_PolyORB_String ("not_context"); not_object_Name : constant PolyORB.Types.String := To_PolyORB_String ("not_object"); begin TC_NotFoundReason := TC_Enum; Add_Parameter (TC_NotFoundReason, To_Any (Name)); Add_Parameter (TC_NotFoundReason, To_Any (Id)); Add_Parameter (TC_NotFoundReason, To_Any (missing_node_Name)); Add_Parameter (TC_NotFoundReason, To_Any (not_context_Name)); Add_Parameter (TC_NotFoundReason, To_Any (not_object_Name)); Disable_Reference_Counting (Object_Of (TC_NotFoundReason).all); end; declare Name : constant PolyORB.Types.String := To_PolyORB_String ("NotFound"); Id : constant PolyORB.Types.String := To_PolyORB_String ("IDL:omg.org/CosNaming/NamingContext/NotFound:1.0"); Arg_Name_why : constant PolyORB.Types.String := To_PolyORB_String ("why"); Arg_Name_rest_of_name : constant PolyORB.Types.String := To_PolyORB_String ("rest_of_name"); begin TC_NotFound := TC_Except; Add_Parameter (TC_NotFound, To_Any (Name)); Add_Parameter (TC_NotFound, To_Any (Id)); Add_Parameter (TC_NotFound, To_Any (TC_NotFoundReason)); Add_Parameter (TC_NotFound, To_Any (Arg_Name_why)); Add_Parameter (TC_NotFound, To_Any (TC_Name)); Add_Parameter (TC_NotFound, To_Any (Arg_Name_rest_of_name)); Disable_Reference_Counting (Object_Of (TC_NotFound).all); end; PolyORB.Exceptions.Register_Exception (TC_NotFound, Raise_NotFound_From_Any'Access); declare Name : constant PolyORB.Types.String := To_PolyORB_String ("CannotProceed"); Id : constant PolyORB.Types.String := To_PolyORB_String ("IDL:omg.org/CosNaming/NamingContext/CannotProceed:1.0"); Arg_Name_cxt : constant PolyORB.Types.String := To_PolyORB_String ("cxt"); Arg_Name_rest_of_name : constant PolyORB.Types.String := To_PolyORB_String ("rest_of_name"); begin TC_CannotProceed := TC_Except; Add_Parameter (TC_CannotProceed, To_Any (Name)); Add_Parameter (TC_CannotProceed, To_Any (Id)); Add_Parameter (TC_CannotProceed, To_Any (TC_NamingContext)); Add_Parameter (TC_CannotProceed, To_Any (Arg_Name_cxt)); Add_Parameter (TC_CannotProceed, To_Any (TC_Name)); Add_Parameter (TC_CannotProceed, To_Any (Arg_Name_rest_of_name)); Disable_Reference_Counting (Object_Of (TC_CannotProceed).all); end; PolyORB.Exceptions.Register_Exception (TC_CannotProceed, Raise_CannotProceed_From_Any'Access); declare Name : constant PolyORB.Types.String := To_PolyORB_String ("InvalidName"); Id : constant PolyORB.Types.String := To_PolyORB_String ("IDL:omg.org/CosNaming/NamingContext/InvalidName:1.0"); begin TC_InvalidName := TC_Except; Add_Parameter (TC_InvalidName, To_Any (Name)); Add_Parameter (TC_InvalidName, To_Any (Id)); Disable_Reference_Counting (Object_Of (TC_InvalidName).all); end; PolyORB.Exceptions.Register_Exception (TC_InvalidName, Raise_InvalidName_From_Any'Access); declare Name : constant PolyORB.Types.String := To_PolyORB_String ("AlreadyBound"); Id : constant PolyORB.Types.String := To_PolyORB_String ("IDL:omg.org/CosNaming/NamingContext/AlreadyBound:1.0"); begin TC_AlreadyBound := TC_Except; Add_Parameter (TC_AlreadyBound, To_Any (Name)); Add_Parameter (TC_AlreadyBound, To_Any (Id)); Disable_Reference_Counting (Object_Of (TC_AlreadyBound).all); end; PolyORB.Exceptions.Register_Exception (TC_AlreadyBound, Raise_AlreadyBound_From_Any'Access); declare Name : constant PolyORB.Types.String := To_PolyORB_String ("NotEmpty"); Id : constant PolyORB.Types.String := To_PolyORB_String ("IDL:omg.org/CosNaming/NamingContext/NotEmpty:1.0"); begin TC_NotEmpty := TC_Except; Add_Parameter (TC_NotEmpty, To_Any (Name)); Add_Parameter (TC_NotEmpty, To_Any (Id)); Disable_Reference_Counting (Object_Of (TC_NotEmpty).all); end; PolyORB.Exceptions.Register_Exception (TC_NotEmpty, Raise_NotEmpty_From_Any'Access); end Initialize; use PolyORB.Initialization; use PolyORB.Initialization.String_Lists; use PolyORB.Utils.Strings; begin Register_Module (Module_Info' (Name => +"naming.NamingContext.Helper", Conflicts => Empty, Depends => +"exceptions" & "any" & "naming.Helper", Provides => Empty, Implicit => False, Init => Initialize'Access, Shutdown => null)); end PolyORB.Services.Naming.NamingContext.Helper; polyorb-2.8~20110207.orig/src/polyorb-sequences-helper.ads0000644000175000017500000001114311750740340022616 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . S E Q U E N C E S . H E L P E R -- -- -- -- S p e c -- -- -- -- Copyright (C) 2003-2009, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- Any conversion subprograms for sequences (both bounded and unbounded) with System; with PolyORB.Any; with PolyORB.Types; generic type Element is private; type Element_Ptr is access all Element; type Sequence is private; with function Length (Seq : Sequence) return Natural; -- Return Seq's current length with function New_Sequence (Length : Natural) return Sequence; -- Create a new sequence of the given Length with procedure Set_Length (Source : in out Sequence; Length : Natural); with function Unchecked_Element_Of (Source : access Sequence; Index : Positive) return Element_Ptr; -- Access to the Index'th (1-based) element in Seq with function Element_From_Any (Item : PolyORB.Any.Any) return Element; with function Element_To_Any (Item : Element) return PolyORB.Any.Any; pragma Unreferenced (Element_To_Any); with function Element_Wrap (X : access Element) return PolyORB.Any.Content'Class; package PolyORB.Sequences.Helper is function From_Any (Item : PolyORB.Any.Any) return Sequence; function To_Any (Item : Sequence) return PolyORB.Any.Any; function Wrap (X : access Sequence) return PolyORB.Any.Content'Class; procedure Initialize (Element_TC, Sequence_TC : PolyORB.Any.TypeCode.Local_Ref); private -- Aggregate container type Sequence_Ptr is access all Sequence; type Sequence_Content is new Any.Aggregate_Content with record V : Sequence_Ptr; Length_Cache : PolyORB.Types.Unsigned_Long; end record; -- Aggregate container primitives function Get_Aggregate_Element (ACC : not null access Sequence_Content; TC : PolyORB.Any.TypeCode.Object_Ptr; Index : PolyORB.Types.Unsigned_Long; Mech : not null access PolyORB.Any.Mechanism) return PolyORB.Any.Content'Class; procedure Set_Aggregate_Element (ACC : in out Sequence_Content; TC : PolyORB.Any.TypeCode.Object_Ptr; Index : Types.Unsigned_Long; From_C : in out PolyORB.Any.Any_Container'Class); function Get_Aggregate_Count (ACC : Sequence_Content) return PolyORB.Types.Unsigned_Long; procedure Set_Aggregate_Count (ACC : in out Sequence_Content; Count : PolyORB.Types.Unsigned_Long); function Clone (ACC : Sequence_Content; Into : PolyORB.Any.Content_Ptr := null) return PolyORB.Any.Content_Ptr; function Unchecked_Get_V (ACC : not null access Sequence_Content) return System.Address; -- Return the address of the first stored element procedure Finalize_Value (ACC : in out Sequence_Content); end PolyORB.Sequences.Helper; polyorb-2.8~20110207.orig/src/polyorb-tasking-profiles-no_tasking-condition_variables.adb0000644000175000017500000001071311750740340030756 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- POLYORB.TASKING.PROFILES.NO_TASKING.CONDITION_VARIABLES -- -- -- -- B o d y -- -- -- -- Copyright (C) 2002-2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- Implementation of POSIX-like synchronisation objects under the -- No_Tasking profile. with PolyORB.Initialization; with PolyORB.Utils.Strings; package body PolyORB.Tasking.Profiles.No_Tasking.Condition_Variables is The_Condition : aliased No_Tasking_Condition_Type; --------------- -- Broadcast -- --------------- procedure Broadcast (C : access No_Tasking_Condition_Type) is pragma Warnings (Off); pragma Unreferenced (C); pragma Warnings (On); begin null; end Broadcast; ------------ -- Create -- ------------ function Create (MF : access No_Tasking_Condition_Factory_Type; Name : String := "") return PTCV.Condition_Access is pragma Warnings (Off); pragma Unreferenced (MF); pragma Unreferenced (Name); pragma Warnings (On); begin return The_Condition'Access; end Create; ------------- -- Destroy -- ------------- procedure Destroy (MF : access No_Tasking_Condition_Factory_Type; C : in out PTCV.Condition_Access) is pragma Warnings (Off); pragma Unreferenced (MF); pragma Warnings (On); begin C := null; end Destroy; ---------------- -- Initialize -- ---------------- procedure Initialize is begin PTCV.Register_Condition_Factory (PTCV.Condition_Factory_Access (The_Condition_Factory)); end Initialize; ------------ -- Signal -- ------------ procedure Signal (C : access No_Tasking_Condition_Type) is pragma Warnings (Off); pragma Unreferenced (C); pragma Warnings (On); begin null; end Signal; ---------- -- Wait -- ---------- procedure Wait (C : access No_Tasking_Condition_Type; M : access PTM.Mutex_Type'Class) is pragma Warnings (Off); pragma Unreferenced (M); pragma Unreferenced (C); pragma Warnings (On); begin raise Tasking_Error; end Wait; use PolyORB.Initialization; use PolyORB.Initialization.String_Lists; use PolyORB.Utils.Strings; begin Register_Module (Module_Info' (Name => +"tasking.profiles.no_tasking.condition_variables", Conflicts => Empty, Depends => Empty, Provides => +"tasking.condition_variables", Implicit => False, Init => Initialize'Access, Shutdown => null)); end PolyORB.Tasking.Profiles.No_Tasking.Condition_Variables; polyorb-2.8~20110207.orig/src/ROADMAP0000644000175000017500000002200011750740337016177 0ustar xavierxavierPolyORB source code roadmap --------------------------- $Id: ROADMAP 33972 2002-11-11 17:35:19Z delallea $ The source code of PolyORB is not for the faint of heart. Caveat emptor. This document gives a very high-level overview of how the code is organized. 1. Support components used throughout PolyORB --------------------------------------------- ./polyorb.ads Empty package, provides a common namespace for generic ORB components. ./polyorb-log.ads Logging facility. Provides a unified means for other units to output debugging, diagnostics and error messages. ./polyorb-configuration.ads User control of various middleware aspects is implemented through a generic configuration framework. At start-up, PolyORB will search for various configuration files, containing application profiles. See 'polyorb.conf' for a detail of PolyORB generic configuration, 'moma/*.conf' for MOMA specific configuration files. ./polyorb-types.ads Base data types used throughout PolyORB. ./polyorb-annotations.ads The Annotation pattern, which allows clients of a data structure to independently enrich it, thus decoupling data extension from type extension. ./polyorb-components.ads The Component pattern, which allows objects to exchange synchronous messages through connections, thus decoupling behaviour profiles from Ada typing. ./polyorb-dynamic_dict.ads Efficient dictionnary of key-value pairs. ./polyorb-initialization.ads Software modules manager for initialization of the middleware. Each module is registered with this package, indicating its dependencies. Initialization is performed as a topological sort of the dependency lattice. A check is performed to control consistency of the tree. ./polyorb-utils-chained_lists.ads Generic chain list facility with generic iterator ./polyorb-utils-dynamic_tables.ads ./polyorb-utils-htables-perfect.ads ./polyorb-utils-htables.ads ./polyorb-utils-semaphores.ads ./polyorb-utils-simple_flags.ads Utility functions to provide binary flag sets. ./polyorb-utils-strings-lists.ads ./polyorb-utils-strings.ads Handling of dynamic string allocation and chained lists of strings. ./polyorb-sequences.ads ./polyorb-sequences-bounded.ads ./polyorb-sequences-unbounded.ads {Bounded,unbounded} variable length arrays (cf. CORBA.Sequences.) Notionally based on Ada.Strings.Unbounded. ./polyorb-tasking-* Tasking runtime, support full tasking, ravenscar tasking subset and no tasking modes. Provides advanced mutexes, mutexes, watchers, r/w locks abstractions. 2. Neutral core --------------- ./polyorb-any*.ads Neutral, self-descriptive data representation. ./polyorb-requests.ads The central data structure in PolyORB: an object representing a method invocation request to be executed by an object in a way that is independant of the application and protocol personalities. ./polyorb-jobs.ads A Job is anything that can keep a task busy (like a Runnable in Java). This unit declares an abstract Job type, and a means to maintain job queues. ./polyorb-asynch_ev.ads Asynchronous event sources objects, which can trigger asynchronous ORB activities to react to external stimuli. ./polyorb-orb.ads The core component: provides the global ORB activites scheduler, as well as registries for personality components (binding object factories, transport access points, object adapters). ./polyorb-binding_data.ads Client-side remote binding object factories. ./polyorb-references.ads Object reference management ./polyorb-references-binding.ads Client-side binding factory. Either binds directly or creates a binding to a remote object. 3. Protocol layer framework and support functionalities ------------------------------------------------------- ./polyorb-opaque-chunk_pools.ads ./polyorb-opaque.ads ./polyorb-buffers.ads Manage memory buffers for various purposes ./polyorb-utils-buffers.ads ./polyorb-utils-text_buffers.ads Utilities for buffer access. ./polyorb-filters.ads Framework for layered components that form a protocol stack. Each filter transmits SDUs (service data units) from its lower layer to its upper layer, and can perform some processing on the SDU and its associated data. The lowest layer is a polyorb.filters.sockets.socket_filter, which does not receive SDUs from a lower layer but directly from the ORB engine. The uppermost layer is a Session, which does not actually transmits SDUs to an upper layer but takes action based on received SDUs. ./polyorb-transport.ads The abstraction of access points and end points in the transport service. An access point is an entity that has an address, to which other nodes can connect. An end point is an entity that represents an established connection with an access point, and can be used to exchange information. ./polyorb-transport-sockets.ads A concrete implementation of the classes defined in PolyORB.Transport, based on TCP sockets. ./polyorb-representations.ads The abstraction of a method to represent data in a form suitable for transmission. Children of this unit are expected to derive the PolyORB.Representations.Representation abstract type into a concrete type implementing one representation mechanism. ./polyorb-protocols.ads The abstraction of a remote invocation protocol. To be derived by concrete personalities. A Protocol is a factory of Session. A Session is the actual object that implements one particular protocols. Protocols are factories of Sessions, and are used as parts of binding object factories. 4. Protocol personalities ------------------------- ./soap/ Directory containing the SOAP protocol personality. ./corba/polyorb-protocol-giop-* GIOP protocol personality. GIOP revisions 1.0, 1.1, 1.2 are implemented. ./srp/ The Simple Request Protocol, a simple HTTP-like protocol for rapid prototyping of PolyORB functionalities. It is incomplete and provided solely to test simple method invocations. May be useful to invoke 'by hand' servants and test some particular configurations. 5. Application layer framework and support functionalities ---------------------------------------------------------- ./polyorb-call_back.ads Interceptor for request processing completion signalling. ./polyorb-obj_adapters.ads The abstract interface of object adapters in PolyORB. ./polyorb-poa.ads The base class for all Portable Object Adapter implementations (generic hierarchical object adapters modeled after the CORBA POA.) ./polyorb-poa_types.ads Base data structures handled by PolyORB.POA. ./polyorb-poa_policies.ads Children of this unit define various policy objects that can be used to customise the behaviour of portable object adapters. ./polyorb-servants.ads Base class for all application objects. 6. Application personalities ---------------------------- * CORBA: ./corba/corba-*.ads Standard CORBA packages. ./corba/polyorb-corba_p-*.ads PolyORB-specific components of the CORBA personality. This includes internal utility components, as well as some tools that can be used directly by application developers (eg PolyORB.CORBA_P.Server_Tools). * DSA: ./dsa/s-polint.ads Wrapper between GNAT generated code and PolyORB internals. ./dsa/polyorb-poa_config-racws.ads Configuration of the POA for RACW. * MOMA: ./moma/moma-configuration* Utility function to extract configuration information from configuration files. ./moma/moma-connection_factories* ./moma/moma-connections* ./moma/moma-destinations* Definition of MOMA Connection_Factory, Connection and Destination types. ./moma/moma-message_consumer* MOMA client objects and API to receive messages from a pool. It contains stub routines to interact with a Message_Consumer servant. It is the façade shown to the client to the message receiving part of MOMA specification. ./moma/moma-message_producer* MOMA client objects and API to send messages to a pool. It contains stub routines to interact with a Message_Producer servant. It is the façade shown to the client to the message sending part of MOMA specification. ./moma/moma-messages* API to construct the different types of MOMA messages. ./moma/moma-provider.ads Base package for MOMA provider, collection of servants providing MOM functionalities on top of PolyORB neutral core layer. ./moma/moma-provider-message_consumer.ads Servant object implementing Message_Consumer object that interacts with message pools. This package contains both its skeleton and implementation subroutines. By construction, its implementation contains parts of a stub to access the Message_Pool object. ./moma/moma-provider-message_producer.ads Servant object implementing Message_Producer object that interacts with message pools. This package contains both its skeleton and implementation subroutines. By construction, its implementation contains parts of a stub to access the Message_Pool object. ./moma/moma-provider-message_pool.ads Servant object implementing Message_Pool object. This package contains both its skeleton and implementation subroutines. ./moma/moma-provider-warehouse.ads Implementation of a placeholder for received messages. ./moma/moma-sessions* Definition of the session type (see JMS definition for more details). ./moma/moma-types.ads All MOMA types. polyorb-2.8~20110207.orig/src/polyorb-orb.adb0000644000175000017500000013177511750740340020125 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . O R B -- -- -- -- B o d y -- -- -- -- Copyright (C) 2001-2011, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- The ORB core module with Ada.Exceptions; with Ada.Finalization; with Ada.Tags; with PolyORB.Any.Initialization; with PolyORB.Binding_Data.Local; with PolyORB.Binding_Object_QoS; with PolyORB.Errors; with PolyORB.Filters.Iface; with PolyORB.Initialization; with PolyORB.Log; with PolyORB.ORB.Iface; with PolyORB.Parameters.Initialization; with PolyORB.References.Binding; with PolyORB.Request_QoS; with PolyORB.Servants.Iface; with PolyORB.Setup; with PolyORB.Smart_Pointers.Initialization; with PolyORB.Tasking.Threads; with PolyORB.Transport.Handlers; with PolyORB.Utils.Strings; -- Units included in closure for module registration purposes only pragma Warnings (Off, PolyORB.Any.Initialization); pragma Warnings (Off, PolyORB.Parameters.Initialization); pragma Warnings (Off, PolyORB.Smart_Pointers.Initialization); package body PolyORB.ORB is use PolyORB.Annotations; use PolyORB.Asynch_Ev; use PolyORB.Binding_Data; use PolyORB.Binding_Objects; use PolyORB.Components; use PolyORB.Filters; use PolyORB.Jobs; use PolyORB.Log; use PolyORB.ORB_Controller; use PolyORB.References; use PolyORB.Requests; use PolyORB.Tasking.Threads; use PolyORB.Transport; use PolyORB.Transport.Handlers; use Unsigned_Long_Flags; package L is new PolyORB.Log.Facility_Log ("polyorb.orb"); procedure O (Message : String; Level : Log_Level := Debug) renames L.Output; function C (Level : Log_Level := Debug) return Boolean renames L.Enabled; ---------------------------------------------- -- Management of asynchronous event sources -- ---------------------------------------------- procedure Insert_Source (ORB : access ORB_Type; AES : PolyORB.Asynch_Ev.Asynch_Ev_Source_Access); -- Insert AES in the set of asynchronous event sources monitored by ORB. -- The caller must not hold the ORB lock. procedure Delete_Source (ORB : access ORB_Type; AES : in out Asynch_Ev_Source_Access); -- Delete AES from the set of asynchronous event sources monitored by ORB. -- AES is destroyed. The caller must not hold the ORB lock. -------------------------------------------- -- Annotations used by the ORB internally -- -------------------------------------------- -- Transport access point note type TAP_Note is new Note with record Profile_Factory : Binding_Data.Profile_Factory_Access; AES : Asynch_Ev.Asynch_Ev_Source_Access; end record; -- Transport endpoint note type TE_Note is new Note with record AES : Asynch_Ev.Asynch_Ev_Source_Access; end record; --------------------------- -- ORB object operations -- --------------------------- procedure Perform_Work (ORB : access ORB_Type; This_Task : in out PTI.Task_Info); pragma Inline (Perform_Work); -- Perform one item of work assigned to This_Task -- Precondition: Must be called from within ORB critical section. -- Postcondition: On exit, ORB critical section has been reasserted. -- Note: tasks running this function may exit ORB critical section -- temporarily. ------------ -- Create -- ------------ procedure Create (ORB : in out ORB_Type) is pragma Unreferenced (ORB); begin -- Note: this function will be completed when implementing support for -- multiple ORB instances, as mandated by the CORBA personality. null; end Create; ---------------------------------- -- Find_Reusable_Binding_Object -- ---------------------------------- function Find_Reusable_Binding_Object (ORB : access ORB_Type; Pro : Binding_Data.Profile_Access; QoS : PolyORB.QoS.QoS_Parameters) return Smart_Pointers.Ref is use PBOL; function Is_Reusable (BO_Acc : Binding_Object_Access) return Boolean; -- True if this BO can be reused to contact the given profile with -- the given QoS. ----------------- -- Is_Reusable -- ----------------- function Is_Reusable (BO_Acc : Binding_Object_Access) return Boolean is begin if Get_Profile (BO_Acc) /= null then -- Until bidirectionnal BO are implemented we cannot reuse the -- server BOs as client BOs and inversely. So for the moment, -- server BOs have a null profile and are not handled here. This -- check shall be removed once bidirectional BO are implemented. return Same_Node (Pro.all, Get_Profile (BO_Acc).all) and then PolyORB.Binding_Object_QoS.Is_Compatible (BO_Acc, QoS); else return False; end if; end Is_Reusable; use BO_Ref_Lists; Reusable_BOs : BO_Ref_List; Result : Smart_Pointers.Ref; -- Start of processing for Find_Reusable_Binding_Object begin pragma Debug (C, O ("Find_Reusable_Binding_Object: enter")); pragma Debug (C, O ("#BO registered = " & Natural'Image (Length (ORB.Binding_Objects)))); Reusable_BOs := Get_Binding_Objects (ORB, Is_Reusable'Access); if not Is_Empty (Reusable_BOs) then Extract_First (Reusable_BOs, Result); -- Get_Binding_Objects with a non-null predicate is expected to -- return at most one object. pragma Assert (Is_Empty (Reusable_BOs)); end if; pragma Debug (C, O ("Find_Reusable_Binding_Object: leave")); -- If no reusable Binding Object has been found, Result is a nil Ref return Result; end Find_Reusable_Binding_Object; ------------------ -- Perform_Work -- ------------------ procedure Perform_Work (ORB : access ORB_Type) is Job : Job_Access; begin Enter_ORB_Critical_Section (ORB.ORB_Controller); Job := Get_Pending_Job (ORB.ORB_Controller); Leave_ORB_Critical_Section (ORB.ORB_Controller); if Job /= null then Run (Job); end if; end Perform_Work; procedure Perform_Work (ORB : access ORB_Type; This_Task : in out Task_Info.Task_Info) is use PolyORB.Task_Info; begin pragma Debug (C, O ("Perform_Work: enter " & Image (This_Task))); pragma Assert (Task_Info.Job (This_Task) /= null); Leave_ORB_Critical_Section (ORB.ORB_Controller); pragma Debug (C, O ("Perform_Work: " & Image (This_Task) & " working on job " & Ada.Tags.External_Tag (Task_Info.Job (This_Task)'Tag))); Run (Task_Info.Job (This_Task)); Enter_ORB_Critical_Section (ORB.ORB_Controller); pragma Debug (C, O ("Perform_Work: leave " & Image (This_Task))); Notify_Event (ORB.ORB_Controller, Event'(Kind => Job_Completed)); end Perform_Work; ----------------------- -- Try_Check_Sources -- ----------------------- procedure Try_Check_Sources (ORB : access ORB_Type; This_Task : in out Task_Info.Task_Info); pragma Inline (Try_Check_Sources); -- Check ORB's AES attached to A_Monitor for any incoming event. -- Precondition: Must be called from within ORB critical section. -- Postcondition: On exit, ORB critical section has been reasserted. -- Note: tasks running this function may exit ORB critical section -- temporarily. procedure Try_Check_Sources (ORB : access ORB_Type; This_Task : in out Task_Info.Task_Info) is use PolyORB.Task_Info; begin -- Inside the ORB critical section pragma Debug (C, O ("Try_Check_Sources: task " & Image (This_Task) & " about to Check_Sources.")); Leave_ORB_Critical_Section (ORB.ORB_Controller); declare Events : constant AES_Array := Check_Sources (Selector (This_Task), Task_Info.Timeout (This_Task)); -- This_Task will block on this action until an event occurs on a -- source monitored by A_Monitor, or Abort_Check_Sources is called -- on A_Monitor. begin -- Reenter critical section to update ORB state Enter_ORB_Critical_Section (ORB.ORB_Controller); pragma Debug (C, O ("Try_Check_Sources: task " & Image (This_Task) & " returned from Check_Sources with" & Integer'Image (Events'Length) & " event(s).")); -- Queue events, if any for J in Events'Range loop Notify_Event (ORB.ORB_Controller, Event'(Kind => Queue_Event_Job, Event_Job => Job_Access (Handler (Events (J).all)), By_Task => Id (This_Task))); end loop; -- Notify ORB controller of completion Notify_Event (ORB.ORB_Controller, Event'(Kind => End_Of_Check_Sources, On_Monitor => Selector (This_Task))); -- Inside ORB critical section end; end Try_Check_Sources; --------- -- Run -- --------- -- Controlled type Task_Witness implements the Scope Lock idiom to handle -- exceptions and asynchronous abort while we are executing the ORB main -- loop. type Task_Witness (This : access Task_Info.Task_Info; ORB_Controller : access POC.ORB_Controller'Class; TI_Reference : access PTI.Task_Info_Access; Req : access Requests.Request) is new Ada.Finalization.Limited_Controlled with record Normal_Exit : Boolean := False; -- Set True when exiting through normal completion of the protected -- block (as opposed to abort or exception). end record; procedure Initialize (TW : in out Task_Witness); -- Register TW.This with OC procedure Finalize (TW : in out Task_Witness); -- Unregister TW.This from OC ---------------- -- Initialize -- ---------------- procedure Initialize (TW : in out Task_Witness) is begin pragma Debug (O ("Initializing task witness for " & PTI.Image (TW.This.all))); Enter_ORB_Critical_Section (TW.ORB_Controller); if TW.TI_Reference /= null then -- This pointer must be reset to null before exiting Run so as to -- not leave a dangling reference. TW.TI_Reference.all := TW.This.all'Unchecked_Access; end if; Register_Task (TW.ORB_Controller, TW.This.all'Unchecked_Access); end Initialize; -------------- -- Finalize -- -------------- procedure Finalize (TW : in out Task_Witness) is begin pragma Debug (O ("Finalizing task witness for " & PTI.Image (TW.This.all) & ", Normal_Exit = " & TW.Normal_Exit'Img)); -- Remove references to TW.This if TW.TI_Reference /= null then TW.TI_Reference.all := null; end if; if not TW.Normal_Exit then -- Reassert critical section to remove current task from ORB -- controller if terminating because of abort or exception. Enter_ORB_Critical_Section (TW.ORB_Controller); if TW.Req /= null and then TW.Req.Surrogate /= null then -- Notify surrogate that request was aborted Emit_No_Reply (TW.Req.Surrogate, Servants.Iface.Abort_Request' (Req => TW.Req.all'Unchecked_Access)); end if; Terminate_Task (TW.ORB_Controller, TW.This.all'Unchecked_Access); end if; Unregister_Task (TW.ORB_Controller, TW.This.all'Unchecked_Access); Leave_ORB_Critical_Section (TW.ORB_Controller); end Finalize; -- An ORB task is Permanent if its Request is null (case True), Transient -- if it is not. -- This is the main loop for all general-purpose ORB tasks. This subprogram -- must not be called recursively. Exceptions must not be propagated from -- within ORB critical section. procedure Run (ORB : access ORB_Type; Request : Requests.Request_Access := null; May_Exit : Boolean) is use PTI; Task_Kinds : constant array (Boolean) of Task_Kind := (False => Transient, True => Permanent); This_Task : aliased PTI.Task_Info (Task_Kinds (Request = null)); TI_Ref : access Task_Info_Access := null; begin pragma Assert (This_Task.Kind = Permanent or else May_Exit); -- May_Exit is expected to always be True for transient tasks -- Set up task information for This_Task Set_Id (This_Task); if Request /= null then Set_Exit_Condition (This_Task, Request.Completed'Access); TI_Ref := Request.Requesting_Task'Access; else Set_Exit_Condition (This_Task, null); end if; Set_May_Exit (This_Task, May_Exit); -- Enter critical section (scope lock using Witness) declare Witness : Task_Witness (This => This_Task'Unchecked_Access, ORB_Controller => ORB.ORB_Controller, TI_Reference => TI_Ref, Req => Request); pragma Unreferenced (Witness); begin -- ORB Main loop Main_Loop : loop Schedule_Task (ORB.ORB_Controller, This_Task'Unchecked_Access); case State (This_Task) is when Running => -- This task will process one job Perform_Work (ORB, This_Task); when Blocked => -- This task will block on event sources, waiting for events Try_Check_Sources (ORB, This_Task); when Idle => -- This task is going idle. We are still inside the ORB -- critical section at this point. The tasking policy will -- release it while we are idle, and re-assert it before -- returning. Idle (ORB.Tasking_Policy, This_Task'Unchecked_Access, ORB_Access (ORB)); -- Note: tasking policy may have decided to terminate this -- task, in which case the ORB controller has already been -- notified. if State (This_Task) /= Terminated then Notify_Event (ORB.ORB_Controller, Event'(Kind => Idle_Awake, Awakened_Task => This_Task'Unchecked_Access)); end if; when Terminated => -- This task has reached its exit condition: leave main loop exit Main_Loop; when Unscheduled => -- This task is still unscheduled, this should not happen! raise Program_Error; end case; -- Condition at end of loop: inside the ORB critical section end loop Main_Loop; Witness.Normal_Exit := True; -- Upon exiting this block, Witness is finalized, causing This_Task -- to be unregistered from the ORB controller. end; pragma Debug (C, O ("Run: leave.")); exception when E : others => O ("ORB.Run got exception:", Error); O (Ada.Exceptions.Exception_Information (E), Error); raise; end Run; ------------------ -- Work_Pending -- ------------------ function Work_Pending (ORB : access ORB_Type) return Boolean is Result : Boolean; begin Enter_ORB_Critical_Section (ORB.ORB_Controller); Result := Has_Pending_Job (ORB.ORB_Controller); Leave_ORB_Critical_Section (ORB.ORB_Controller); return Result; end Work_Pending; -------------- -- Shutdown -- -------------- procedure Shutdown (ORB : access ORB_Type; Wait_For_Completion : Boolean := True) is begin pragma Debug (C, O ("Shutdown: enter")); if ORB = null then raise Program_Error with "ORB not initialized"; end if; -- Stop accepting incoming connections -- XXX TBD -- Shutdown the ORB Enter_ORB_Critical_Section (ORB.ORB_Controller); Notify_Event (ORB.ORB_Controller, Event'(Kind => ORB_Shutdown)); -- Wait for completion of pending requests, if required if Wait_For_Completion then ORB_Controller.Wait_For_Completion (ORB.ORB_Controller); end if; Leave_ORB_Critical_Section (ORB.ORB_Controller); pragma Debug (C, O ("Shutdown: leave")); end Shutdown; ------------------------ -- Profile_Factory_Of -- ------------------------ function Profile_Factory_Of (TAP : Transport.Transport_Access_Point_Access) return Binding_Data.Profile_Factory_Access; pragma Inline (Profile_Factory_Of); function Profile_Factory_Of (TAP : Transport.Transport_Access_Point_Access) return Binding_Data.Profile_Factory_Access is N : TAP_Note; begin Get_Note (Notepad_Of (TAP).all, N); return N.Profile_Factory; end Profile_Factory_Of; --------------------------- -- Register_Access_Point -- --------------------------- procedure Register_Access_Point (ORB : access ORB_Type; TAP : PT.Transport_Access_Point_Access; Chain : PF.Factories_Access; PF : PBD.Profile_Factory_Access) is New_AES : constant Asynch_Ev_Source_Access := Create_Event_Source (TAP); begin pragma Debug (C, O ("Register_Access_Point: enter")); -- Set link from AES to TAP, Chain and PF declare H : constant access AES_Event_Handler'Class := Handler (New_AES.all); TAP_H : TAP_AES_Event_Handler renames TAP_AES_Event_Handler (H.all); begin H.AES := New_AES; TAP_H.ORB := ORB_Access (ORB); TAP_H.TAP := TAP; TAP_H.Filter_Factory_Chain := Chain; TAP_H.Profile_Factory := PF; end; -- Set link from TAP to PF, and from TAP to AES Set_Note (Notepad_Of (TAP).all, TAP_Note'(Note with Profile_Factory => PF, AES => New_AES)); Enter_ORB_Critical_Section (ORB.ORB_Controller); pragma Debug (C, O ("Inserting new source: Access Point")); TAP_Lists.Append (ORB.Transport_Access_Points, TAP); Leave_ORB_Critical_Section (ORB.ORB_Controller); Insert_Source (ORB, New_AES); pragma Debug (C, O ("Register_Access_Point: leave")); end Register_Access_Point; ---------------------- -- Is_Profile_Local -- ---------------------- function Is_Profile_Local (ORB : access ORB_Type; P : access Binding_Data.Profile_Type'Class) return Boolean is begin if Binding_Data.Is_Local_Profile (P.all) then return True; end if; Enter_ORB_Critical_Section (ORB.ORB_Controller); declare use TAP_Lists; It : Iterator := First (ORB.Transport_Access_Points); PF : Profile_Factory_Access; Result : Boolean := False; begin All_Access_Points : while not Last (It) loop PF := Profile_Factory_Of (Value (It).all); if PF /= null then if Binding_Data.Is_Local_Profile (PF, P) then Result := True; exit All_Access_Points; end if; end if; Next (It); end loop All_Access_Points; Leave_ORB_Critical_Section (ORB.ORB_Controller); return Result; end; end Is_Profile_Local; ----------------------------- -- Register_Binding_Object -- ----------------------------- procedure Register_Binding_Object (ORB : access ORB_Type; BO : Smart_Pointers.Ref; Role : Endpoint_Role) is TE : constant Transport.Transport_Endpoint_Access := Binding_Objects.Get_Endpoint (BO); New_AES : constant Asynch_Ev_Source_Access := Create_Event_Source (TE); -- New_AES is null for output-only endpoints ORB_Acc : constant ORB_Access := ORB_Access (ORB); begin pragma Debug (C, O ("Register_Binding_Object (" & Role'Img & "): enter")); declare BO_Acc : constant Binding_Object_Access := Binding_Object_Access (Smart_Pointers.Entity_Of (BO)); begin Enter_ORB_Critical_Section (ORB.ORB_Controller); -- Register BO in the Binding_Objects list of ORB PBOL.Prepend (ORB.Binding_Objects, BO_Acc); Set_Referenced (BO_Acc, Referenced => True); Leave_ORB_Critical_Section (ORB.ORB_Controller); Emit_No_Reply (Component_Access (TE), Filters.Iface.Set_Server' (Server => Component_Access (ORB), Binding_Object => BO_Acc)); end; if New_AES /= null then -- This is not a write only Endpoint declare H : constant access AES_Event_Handler'Class := Handler (New_AES.all); TE_H : TE_AES_Event_Handler renames TE_AES_Event_Handler (H.all); begin -- Register link from AES to TE H.AES := New_AES; TE_H.ORB := ORB_Access (ORB); TE_H.TE := TE; end; end if; -- Register link from TE to AES Set_Note (Notepad_Of (TE).all, TE_Note'(Annotations.Note with AES => New_AES)); -- Assign execution resources to the newly-created connection case Role is when Server => Handle_New_Server_Connection (ORB_Acc.Tasking_Policy, ORB_Acc, Active_Connection'(AES => New_AES, TE => TE)); when Client => Handle_New_Client_Connection (ORB_Acc.Tasking_Policy, ORB_Acc, Active_Connection'(AES => New_AES, TE => TE)); end case; pragma Debug (C, O ("Register_Binding_Object: leave")); end Register_Binding_Object; ------------------------------- -- Unregister_Binding_Object -- ------------------------------- procedure Unregister_Binding_Object (ORB : access ORB_Type; BO : Binding_Object_Access) is ORB_Acc : constant ORB_Access := ORB_Access (ORB); begin pragma Debug (C, O ("Unregister_Binding_Object: enter")); Enter_ORB_Critical_Section (ORB_Acc.ORB_Controller); -- If BO is still referenced, remove it now if Referenced (BO) then pragma Debug (C, O ("removing binding object")); Set_Referenced (BO, Referenced => False); PBOL.Remove_Element (ORB_Acc.Binding_Objects, BO); end if; Leave_ORB_Critical_Section (ORB_Acc.ORB_Controller); pragma Debug (C, O ("Unregister_Binding_Object: leave")); end Unregister_Binding_Object; ------------------------ -- Set_Object_Adapter -- ------------------------ procedure Set_Object_Adapter (ORB : access ORB_Type; OA : Obj_Adapters.Obj_Adapter_Access) is use type Obj_Adapters.Obj_Adapter_Access; begin Enter_ORB_Critical_Section (ORB.ORB_Controller); pragma Assert (ORB.Obj_Adapter = null); ORB.Obj_Adapter := OA; Leave_ORB_Critical_Section (ORB.ORB_Controller); end Set_Object_Adapter; -------------------- -- Object_Adapter -- -------------------- function Object_Adapter (ORB : access ORB_Type) return Obj_Adapters.Obj_Adapter_Access is begin -- Per construction, ORB.Obj_Adapter is a read-only component. -- No critical section is required. return ORB.Obj_Adapter; end Object_Adapter; ------------------- -- Insert_Source -- ------------------- procedure Insert_Source (ORB : access ORB_Type; AES : Asynch_Ev_Source_Access) is begin Enter_ORB_Critical_Section (ORB.ORB_Controller); pragma Debug (C, O ("Insert_Source: enter")); pragma Debug (C, O ("Source type: " & Ada.Tags.External_Tag (AES.all'Tag))); pragma Assert (AES /= null); declare Monitors : constant Monitor_Array := Get_Monitors (ORB.ORB_Controller); Success : Boolean := False; begin for J in Monitors'Range loop -- Try to register the source to an existing monitor Disable_Polling (ORB.ORB_Controller, Monitors (J)); Register_Source (Monitors (J), AES, Success); Enable_Polling (ORB.ORB_Controller, Monitors (J)); if Success then Notify_Event (ORB.ORB_Controller, Event'(Kind => Event_Sources_Added, Add_In_Monitor => Monitors (J))); exit; end if; end loop; if not Success then -- Create a new monitor and register the source pragma Debug (C, O ("Creating new monitor")); declare New_AEM : constant Asynch_Ev_Monitor_Access := AEM_Factory_Of (AES.all).all; begin pragma Debug (C, O ("AEM: " & Ada.Tags.External_Tag (New_AEM.all'Tag))); Create (New_AEM.all); -- In this situation, no task can be polling this monitor yet, -- so no need to disable polling. Register_Source (New_AEM, AES, Success); pragma Assert (Success); Notify_Event (ORB.ORB_Controller, Event'(Kind => Event_Sources_Added, Add_In_Monitor => New_AEM)); -- Enable polling on this new monitor Enable_Polling (ORB.ORB_Controller, New_AEM); end; end if; end; pragma Debug (C, O ("Insert_Source: leave")); Leave_ORB_Critical_Section (ORB.ORB_Controller); end Insert_Source; ------------------- -- Delete_Source -- ------------------- procedure Delete_Source (ORB : access ORB_Type; AES : in out Asynch_Ev_Source_Access) is Success : Boolean; Monitor : constant Asynch_Ev_Monitor_Access := AEM_Of (AES.all); begin Enter_ORB_Critical_Section (ORB.ORB_Controller); pragma Debug (C, O ("Delete_Source: enter")); -- Disable polling to enable safe modification of AES list Disable_Polling (ORB.ORB_Controller, Monitor); -- Remove source Unregister_Source (Monitor.all, AES, Success); if Success then Notify_Event (ORB.ORB_Controller, Event'(Kind => Event_Sources_Deleted)); end if; -- Modification completed, enable polling Enable_Polling (ORB.ORB_Controller, Monitor); Leave_ORB_Critical_Section (ORB.ORB_Controller); -- Actually destroy AES Destroy (AES); pragma Debug (C, O ("Delete_Source: leave")); end Delete_Source; ---------------------------------- -- Job type for object requests -- ---------------------------------- --------- -- Run -- --------- procedure Run (J : not null access Request_Job) is AJ : Job_Access := Job_Access (J); begin Run_Request (J.ORB, J.Request); Free (AJ); exception when E : others => pragma Debug (C, O ("Run: Got exception " & Ada.Exceptions.Exception_Information (E))); Free (AJ); raise; end Run; ----------------- -- Run_Request -- ----------------- procedure Run_Request (ORB : access ORB_Type; Req : Request_Access) is begin pragma Debug (C, O ("Run Request_Job: enter")); pragma Assert (Req /= null); declare use type Task_Info.Task_Info_Access; begin pragma Debug (C, O ("Task " & Image (Current_Task) & " executing: " & Requests.Image (Req.all))); if Req.Requesting_Task /= null then pragma Debug (C, O ("... requested by " & PTI.Image (Req.Requesting_Task.all))); null; end if; if Req.Completed then -- The request can be already marked as completed in the case -- where an error has been detected during immediate argument -- unmarshalling (case of a malformed SOAP argument -- representation, for example). pragma Debug (C, O ("Request completed due to early error")); Emit_No_Reply (Req.Requesting_Component, Servants.Iface.Executed_Request'(Req => Req)); return; elsif Is_Set (Sync_None, Req.Req_Flags) then -- At this point, the request has been queued, the Sync_None -- synchronisation policy has been completed. -- We bounce back the response to the requesting task. pragma Debug (C, O ("Sync_None completed")); Emit_No_Reply (Req.Requesting_Component, Servants.Iface.Executed_Request'(Req => Req)); Req.Completed := True; end if; -- Bind target reference to a servant if this is a local reference, -- or a surrogate if this is remote reference. declare use PolyORB.Errors; Error : Error_Container; begin References.Binding.Bind (Req.Target, ORB_Access (ORB), Request_QoS.Get_Request_QoS (Req.all), Req.Surrogate, Req.Profile, Local_Only => False, Error => Error); -- Potential race condition, we may protect this call, TBD??? if Found (Error) then pragma Debug (C, O ("Run_Request: Got an error when binding: " & Error_Id'Image (Error.Kind))); -- Any error except ForwardLocation_E caught at this level -- implies a problem within the object adapter. We bounce the -- exception to the user for further processing. Set_Exception (Req.all, Error); Catch (Error); Emit_No_Reply (Req.Requesting_Component, Servants.Iface.Executed_Request'(Req => Req)); return; end if; end; -- At this point, the server has been contacted, a binding has been -- created, a servant manager has been reached. We are about to send -- the request to the target. if Is_Set (Sync_With_Server, Req.Req_Flags) and then Is_Profile_Local (ORB, Req.Profile) then -- We are on the server side, and use Sync_With_Server sync scope: -- we can send an Executed_Request message to the client prior to -- running the request. pragma Debug (C, O ("With_Server completed, sending" & " Acknowledge_Request message")); Emit_No_Reply (Req.Requesting_Component, Servants.Iface.Acknowledge_Request'(Req => Req)); end if; -- Setup_Environment (Oid); -- XXX for 'Current' (applicative personality API for access -- to the oid of the current called instance, in the context -- of a servant handling multiple oids.) declare Result : constant Components.Message'Class := Emit (Req.Surrogate, Servants.Iface.Execute_Request' (Req => Req, Pro => Req.Profile)); begin -- Unsetup_Environment (); -- Unbind (J.Req.Target, J.ORB, Servant); -- XXX Unbind must Release_Servant. -- XXX Actually cannot unbind here: if the binding object is -- destroyed that early, we won't have the opportunity to -- receive a reply... pragma Debug (C, O ("Run_Request: got " & Ada.Tags.External_Tag (Result'Tag))); if Result not in Null_Message then begin Emit_No_Reply (Req.Requesting_Component, Result); -- XXX issue: if we are on the server side, and the -- transport layer has detected a disconnection while we -- were processing the request, the Requestor (Session) -- object here could have become invalid. For now we hack -- around this issue in an ugly fashion by catching all -- exceptions. exception when E : others => O ("Got exception sending Executed_Request:" & ASCII.LF & Ada.Exceptions.Exception_Information (E), Error); end; end if; end; pragma Debug (C, O ("Run_Request: task " & Image (Current_Task) & " executed request")); end; end Run_Request; ---------------------- -- Create_Reference -- ---------------------- procedure Create_Reference (ORB : access ORB_Type; Oid : access Objects.Object_Id; Typ : String; Ref : out References.Ref) is begin pragma Debug (C, O ("Create_Reference: enter")); Enter_ORB_Critical_Section (ORB.ORB_Controller); declare use PolyORB.Binding_Data.Local; use TAP_Lists; It : Iterator := First (ORB.Transport_Access_Points); Profiles : References.Profile_Array (1 .. Length (ORB.Transport_Access_Points) + 1); Last_Profile : Integer := Profiles'First - 1; begin while not Last (It) loop declare PF : constant Profile_Factory_Access := Profile_Factory_Of (Value (It).all); begin if PF /= null then -- Null profile factories may occur for access points that -- have an ad hoc protocol stack, but no binding data info. declare P : constant Profile_Access := Create_Profile (PF, Oid.all); begin if P /= null then Last_Profile := Last_Profile + 1; Profiles (Last_Profile) := P; end if; end; end if; end; Next (It); end loop; -- Add a local profile Last_Profile := Last_Profile + 1; Profiles (Last_Profile) := new Local_Profile_Type; Create_Local_Profile (Oid.all, Local_Profile_Type (Profiles (Last_Profile).all)); Leave_ORB_Critical_Section (ORB.ORB_Controller); References.Create_Reference (Profiles (Profiles'First .. Last_Profile), Typ, Ref); end; pragma Debug (C, O ("Create_Reference: leave")); end Create_Reference; -------------------- -- Handle_Message -- -------------------- function Handle_Message (ORB : not null access ORB_Type; Msg : Components.Message'Class) return Components.Message'Class is use Servants.Iface; Nothing : Components.Null_Message; begin pragma Debug (C, O ("Handling message of type " & Ada.Tags.External_Tag (Msg'Tag))); if Msg in Iface.Queue_Request then declare QR : Iface.Queue_Request renames Iface.Queue_Request (Msg); Req : Requests.Request_Access renames QR.Request; begin pragma Debug (C, O ("Queue_Request: enter")); if QR.Requestor = null then -- If the request was queued directly by a client, then the -- ORB is responsible for setting its state to Completed upon -- reception of a reply. Req.Requesting_Component := Component_Access (ORB); Run_Request (ORB, Req); else Req.Requesting_Component := QR.Requestor; declare J : constant Job_Access := new Request_Job'(Job with ORB => ORB_Access (ORB), Request => Req); begin Handle_Request_Execution (ORB.Tasking_Policy, ORB_Access (ORB), Request_Job (J.all)'Access); end; end if; pragma Debug (C, O ("Queue_Request: leave")); end; elsif Msg in Executed_Request then declare use PolyORB.Task_Info; Req : Requests.Request renames Executed_Request (Msg).Req.all; begin -- The processing of Executed_Request must be done in the ORB -- critical section, because it must not take place between the -- time an ORB task checks its exit condition and the moment the -- task goes idle. Enter_ORB_Critical_Section (ORB.ORB_Controller); Req.Completed := True; pragma Debug (C, O ("Request completed.")); if Req.Requesting_Task /= null then -- Notify the requesting task pragma Debug (C, O ("... requesting task is " & Task_State'Image (State (Req.Requesting_Task.all)))); Notify_Event (ORB.ORB_Controller, Event'(Kind => Request_Result_Ready, Requesting_Task => Req.Requesting_Task)); else -- The requesting task has already taken note of the completion -- of the request: nothing to do. null; end if; Leave_ORB_Critical_Section (ORB.ORB_Controller); end; elsif Msg in Iface.Monitor_Endpoint then declare TE : constant Transport_Endpoint_Access := Iface.Monitor_Endpoint (Msg).TE; Note : TE_Note; begin Get_Note (Notepad_Of (TE).all, Note); -- Notes.AES is null for write only Endpoints; we only monitor -- read only and read/write Endpoints. if Note.AES /= null then pragma Debug (C, O ("Inserting source: Monitor_Endpoint")); Insert_Source (ORB, Note.AES); end if; end; elsif Msg in Iface.Monitor_Access_Point then declare TAP : constant Transport_Access_Point_Access := Iface.Monitor_Access_Point (Msg).TAP; Note : TAP_Note; begin Get_Note (Notepad_Of (TAP).all, Note); pragma Debug (C, O ("Inserting source: Monitor_Access_Point")); Insert_Source (ORB, Note.AES); end; elsif Msg in Iface.Unregister_Endpoint then declare Note : TE_Note; begin Get_Note (Notepad_Of (Iface.Unregister_Endpoint (Msg).TE).all, Note); if Note.AES /= null then Delete_Source (ORB, Note.AES); end if; end; else pragma Debug (C, O ("ORB received unhandled message of type " & Ada.Tags.External_Tag (Msg'Tag))); raise Program_Error; end if; return Nothing; end Handle_Message; ------------------------- -- Get_Binding_Objects -- ------------------------- function Get_Binding_Objects (ORB : access ORB_Type; Predicate : access function (BO_Acc : Binding_Object_Access) return Boolean := null) return BO_Ref_List is use PBOL; use Smart_Pointers; It : PBOL.Iterator; Result : BO_Ref_List; begin Enter_ORB_Critical_Section (ORB.ORB_Controller); It := First (ORB.Binding_Objects); All_Binding_Objects : while not Last (It) loop declare BO_Acc : Binding_Object_Access renames Value (It); Ref : Smart_Pointers.Ref; begin if not Valid (BO_Acc) then -- Mark binding object as not referenced anymore and purge. -- Note no "Next (It);" in this case, because Remove does that -- automatically. Set_Referenced (BO_Acc, Referenced => False); Remove (ORB.Binding_Objects, It); else if Predicate = null or else Predicate (BO_Acc) then Smart_Pointers.Reuse_Entity (Ref, Entity_Ptr (Value (It))); -- If binding object is being finalized, Reuse_Entity leaves -- Ref unset. if not Is_Nil (Ref) then BO_Ref_Lists.Prepend (Result, Ref); end if; -- If Predicate is not null, return first matching BO only exit All_Binding_Objects when Predicate /= null; end if; Next (It); end if; end; end loop All_Binding_Objects; Leave_ORB_Critical_Section (ORB.ORB_Controller); return Result; end Get_Binding_Objects; ---------------- -- Notepad_Of -- ---------------- function Notepad_Of (ORB : access ORB_Type) return Annotations.Notepad_Access is begin return ORB.Notepad'Access; end Notepad_Of; ---------------- -- Initialize -- ---------------- procedure Initialize; procedure Initialize is The_Controller : POC.ORB_Controller_Access; begin Create (The_Controller); Setup.The_ORB := new ORB_Type (Setup.The_Tasking_Policy, The_Controller); Create (Setup.The_ORB.all); end Initialize; ------------------------------ -- Queue_Request_To_Handler -- ------------------------------ procedure Queue_Request_To_Handler (ORB : access ORB_Type; Msg : Message'Class) is begin pragma Assert (Msg in Iface.Queue_Request); Emit_No_Reply (Component_Access (ORB), Msg); end Queue_Request_To_Handler; --------------------- -- Shutdown Module -- --------------------- procedure Shutdown_Module (Wait_For_Completion : Boolean); procedure Shutdown_Module (Wait_For_Completion : Boolean) is begin Shutdown (Setup.The_ORB, Wait_For_Completion); end Shutdown_Module; use PolyORB.Initialization; use PolyORB.Initialization.String_Lists; use PolyORB.Utils.Strings; begin Register_Module (Module_Info' (Name => +"orb", Conflicts => Empty, Depends => +"orb.tasking_policy" & "binding_data.soap?" & "binding_data.srp?" & "binding_data.iiop?" & "orb_controller" -- ??? should not have hard-coded dependencies -- on specific protocols! & "protocols.srp?" & "protocols.giop?" & "protocols.soap?" & "smart_pointers" & "tasking.threads", Provides => Empty, Implicit => False, Init => Initialize'Access, Shutdown => Shutdown_Module'Access)); end PolyORB.ORB; polyorb-2.8~20110207.orig/src/polyorb-poa_policies-servant_retention_policy-retain.adb0000644000175000017500000002717711750740340030417 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- POLYORB.POA_POLICIES.SERVANT_RETENTION_POLICY.RETAIN -- -- -- -- B o d y -- -- -- -- Copyright (C) 2001-2008, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with PolyORB.Log; with PolyORB.Object_Maps.System; with PolyORB.Object_Maps.User; with PolyORB.POA; with PolyORB.POA_Policies.Id_Assignment_Policy; with PolyORB.POA_Policies.Id_Uniqueness_Policy; with PolyORB.POA_Policies.Lifespan_Policy; with PolyORB.Tasking.Mutexes; with PolyORB.Types; package body PolyORB.POA_Policies.Servant_Retention_Policy.Retain is use PolyORB.Errors; use PolyORB.Log; use PolyORB.Object_Maps; use PolyORB.Tasking.Mutexes; use PolyORB.Types; package L is new Log.Facility_Log ("polyorb.poa_policies.servant_retention_policy.retain"); procedure O (Message : Standard.String; Level : Log_Level := Debug) renames L.Output; function C (Level : Log_Level := Debug) return Boolean renames L.Enabled; ------------ -- Create -- ------------ function Create return Retain_Policy_Access is begin return new Retain_Policy; end Create; ------------------------- -- Check_Compatibility -- ------------------------- procedure Check_Compatibility (Self : Retain_Policy; Other_Policies : AllPolicies; Error : in out PolyORB.Errors.Error_Container) is pragma Warnings (Off); pragma Unreferenced (Self); pragma Unreferenced (Other_Policies); pragma Unreferenced (Error); pragma Warnings (On); begin null; -- No rule to test. end Check_Compatibility; --------------- -- Policy_Id -- --------------- function Policy_Id (Self : Retain_Policy) return String is pragma Warnings (Off); pragma Unreferenced (Self); pragma Warnings (On); begin return "SERVANT_RETENTION_POLICY.RETAIN"; end Policy_Id; -------------------------------- -- Retain_Servant_Association -- -------------------------------- procedure Retain_Servant_Association (Self : Retain_Policy; OA : PolyORB.POA_Types.Obj_Adapter_Access; P_Servant : Servants.Servant_Access; U_Oid : Unmarshalled_Oid; Error : in out PolyORB.Errors.Error_Container) is pragma Warnings (Off); pragma Unreferenced (Self); pragma Warnings (On); use PolyORB.Object_Maps.System; use PolyORB.Object_Maps.User; use PolyORB.POA_Policies.Id_Assignment_Policy; use PolyORB.POA_Policies.Id_Uniqueness_Policy; use type PolyORB.Servants.Servant_Access; POA : constant PolyORB.POA.Obj_Adapter_Access := PolyORB.POA.Obj_Adapter_Access (OA); begin pragma Debug (C, O ("Retain_Servant_Association: enter")); pragma Debug (C, O ("Inserting object '" & To_Standard_String (U_Oid.Id) & "'")); Ensure_Servant_Uniqueness (POA.Id_Uniqueness_Policy.all, OA, P_Servant, Error); if Found (Error) then return; end if; Enter (POA.Map_Lock); if POA.Active_Object_Map = null then pragma Debug (C, O ("Creating Object Map")); POA.Active_Object_Map := Create_Object_Map (POA.Id_Assignment_Policy.all); end if; pragma Assert (POA.Active_Object_Map /= null); -- Ensure compability between Object_Map and Object Id if (U_Oid.System_Generated and then POA.Active_Object_Map.all not in System_Object_Map'Class) or else ((not U_Oid.System_Generated) and then POA.Active_Object_Map.all not in User_Object_Map'Class) then Throw (Error, Internal_E, System_Exception_Members'(Minor => 0, Completed => Completed_No)); Leave (POA.Map_Lock); return; end if; -- Store Entry in Object Map declare The_Entry : Object_Map_Entry_Access := Get_By_Id (POA.Active_Object_Map.all, U_Oid); begin if The_Entry = null then pragma Debug (C, O ("The entry is null, inserting new entry")); The_Entry := new Object_Map_Entry; The_Entry.Oid := new Unmarshalled_Oid'(U_Oid); The_Entry.Servant := P_Servant; if U_Oid.System_Generated then pragma Debug (C, O ("Insert object at reused index " & To_Standard_String (U_Oid.Id))); Add (System_Object_Map (POA.Active_Object_Map.all)'Access, The_Entry, Integer'Value (To_Standard_String (U_Oid.Id))); else Add (User_Object_Map (POA.Active_Object_Map.all)'Access, The_Entry); end if; else pragma Debug (C, O ("The entry is not null")); if The_Entry.Servant /= null then Throw (Error, ObjectAlreadyActive_E, Null_Members'(Null_Member)); Leave (POA.Map_Lock); return; end if; The_Entry.Servant := P_Servant; end if; end; Leave (POA.Map_Lock); pragma Debug (C, O ("Retain_Servant_Association: leave")); end Retain_Servant_Association; -------------------------------- -- Forget_Servant_Association -- -------------------------------- procedure Forget_Servant_Association (Self : Retain_Policy; OA : PolyORB.POA_Types.Obj_Adapter_Access; U_Oid : Unmarshalled_Oid; Error : in out PolyORB.Errors.Error_Container) is pragma Warnings (Off); pragma Unreferenced (Self); pragma Warnings (On); POA : constant PolyORB.POA.Obj_Adapter_Access := PolyORB.POA.Obj_Adapter_Access (OA); An_Entry : Object_Map_Entry_Access; begin pragma Debug (C, O ("Removing object '" & To_Standard_String (U_Oid.Id) & "'")); Enter (POA.Map_Lock); An_Entry := Object_Maps.Remove_By_Id (POA.Active_Object_Map, U_Oid); Leave (POA.Map_Lock); if An_Entry = null then PolyORB.Errors.Throw (Error, ObjectNotActive_E, Null_Member); else -- Free the Unmarshalled_Oid_Access and the entry. -- Note: The servant has to be freed by the application. Free (An_Entry.Oid); Free (An_Entry); end if; end Forget_Servant_Association; ---------------------------- -- Retained_Servant_To_Id -- ---------------------------- function Retained_Servant_To_Id (Self : Retain_Policy; OA : PolyORB.POA_Types.Obj_Adapter_Access; P_Servant : Servants.Servant_Access) return Object_Id_Access is pragma Warnings (Off); pragma Unreferenced (Self); pragma Warnings (On); use PolyORB.POA_Policies.Id_Uniqueness_Policy; POA : constant PolyORB.POA.Obj_Adapter_Access := PolyORB.POA.Obj_Adapter_Access (OA); An_Entry : Object_Map_Entry_Access; begin if POA.Active_Object_Map /= null then Enter (POA.Map_Lock); An_Entry := Get_By_Servant (POA.Active_Object_Map.all, P_Servant); Leave (POA.Map_Lock); pragma Debug (C, O ("Retained_Servant_To_Id : entry null ? " & Boolean'Image (An_Entry = null))); if An_Entry /= null then pragma Debug (C, O ("Entry name is: " & To_Standard_String (An_Entry.Oid.Id))); return U_Oid_To_Oid (An_Entry.Oid.all); end if; end if; return null; end Retained_Servant_To_Id; ---------------------------- -- Retained_Id_To_Servant -- ---------------------------- procedure Retained_Id_To_Servant (Self : Retain_Policy; OA : PolyORB.POA_Types.Obj_Adapter_Access; U_Oid : Unmarshalled_Oid; Servant : out Servants.Servant_Access; Error : in out PolyORB.Errors.Error_Container) is pragma Unreferenced (Self); use PolyORB.POA_Policies.Lifespan_Policy; An_Entry : Object_Map_Entry_Access; POA : constant PolyORB.POA.Obj_Adapter_Access := PolyORB.POA.Obj_Adapter_Access (OA); begin Ensure_Lifespan (POA.Lifespan_Policy.all, OA, U_Oid, Error); if Found (Error) then return; end if; pragma Debug (C, O ("Looking for object '" & To_Standard_String (U_Oid.Id) & "'")); if POA.Active_Object_Map = null then pragma Debug (C, O ("Active Object Map is null!")); Servant := null; return; end if; Enter (POA.Map_Lock); An_Entry := Get_By_Id (POA.Active_Object_Map.all, U_Oid); Leave (POA.Map_Lock); if An_Entry /= null then pragma Debug (C, O ("Object found")); Servant := An_Entry.Servant; else pragma Debug (C, O ("Object not found")); Servant := null; end if; end Retained_Id_To_Servant; --------------------------------- -- Ensure_Servant_Manager_Type -- --------------------------------- procedure Ensure_Servant_Manager_Type (Self : Retain_Policy; Manager : ServantManager'Class; Error : in out PolyORB.Errors.Error_Container) is pragma Unreferenced (Self); begin if Manager not in ServantActivator'Class then Throw (Error, Obj_Adapter_E, System_Exception_Members'(Minor => 4, Completed => Completed_No)); end if; end Ensure_Servant_Manager_Type; end PolyORB.POA_Policies.Servant_Retention_Policy.Retain; polyorb-2.8~20110207.orig/src/polyorb-lanes.adb0000644000175000017500000002627111750740340020437 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . L A N E S -- -- -- -- B o d y -- -- -- -- Copyright (C) 2004-2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with PolyORB.Log; with PolyORB.ORB; with PolyORB.QoS.Priority; with PolyORB.Request_QoS; package body PolyORB.Lanes is use PolyORB.Log; use PolyORB.Tasking.Condition_Variables; use PolyORB.Tasking.Mutexes; package L is new PolyORB.Log.Facility_Log ("polyorb.lanes"); procedure O (Message : String; Level : Log_Level := Debug) renames L.Output; function C (Level : Log_Level := Debug) return Boolean renames L.Enabled; --------- -- Run -- --------- procedure Run (R : not null access Lane_Runnable) is begin pragma Debug (C, O ("Entering lane's main loop")); Enter (R.L.Lock); loop pragma Debug (C, O ("Inside lane's main loop")); -- Process queued jobs while not Is_Empty (R.L.Job_Queue) loop pragma Debug (C, O ("Thread from lane at priority (" & R.L.ORB_Priority'Img & "," & R.L.Ext_Priority'Img & ")" & " will execute a job")); declare Job : constant Job_Access := Fetch_Job (R.L.Job_Queue); begin Leave (R.L.Lock); PolyORB.ORB.Run (PolyORB.ORB.Request_Job (Job.all)'Access); Enter (R.L.Lock); end; end loop; -- Test whether the task should exit exit when R.L.Clean_Up_In_Progress or else R.Dynamically_Allocated; -- else go idle pragma Debug (C, O ("No job to process, go idle")); R.L.Idle_Tasks := R.L.Idle_Tasks + 1; PTCV.Wait (R.L.CV, R.L.Lock); R.L.Idle_Tasks := R.L.Idle_Tasks - 1; end loop; Leave (R.L.Lock); pragma Debug (C, O ("Exiting from lane's main loop")); end Run; -------------- -- Add_Lane -- -------------- procedure Add_Lane (Set : in out Lanes_Set; L : Lane_Access; Index : Positive) is begin Set.Set (Index) := L; end Add_Lane; ------------------- -- Attach_Thread -- ------------------- procedure Attach_Thread (EL : in out Extensible_Lane; T : Thread_Access) is begin -- XXX hummm, should be some consistency tests to ensure EL's -- priority is compatible with T priority Thread_Lists.Append (EL.Additional_Threads, T); end Attach_Thread; ------------ -- Create -- ------------ function Create (ORB_Priority : ORB_Component_Priority; Ext_Priority : External_Priority; Base_Number_Of_Threads : Natural; Dynamic_Number_Of_Threads : Natural; Stack_Size : Natural; Buffer_Request : Boolean; Max_Buffered_Requests : PolyORB.Types.Unsigned_Long; Max_Buffer_Size : PolyORB.Types.Unsigned_Long) return Lane_Access is Result : constant Lane_Access := new Lane (ORB_Priority => ORB_Priority, Ext_Priority => Ext_Priority, Base_Number_Of_Threads => Base_Number_Of_Threads, Dynamic_Number_Of_Threads => Dynamic_Number_Of_Threads, Stack_Size => Stack_Size, Buffer_Request => Buffer_Request, Max_Buffered_Requests => Max_Buffered_Requests, Max_Buffer_Size => Max_Buffer_Size); begin pragma Debug (C, O ("Creating lane with" & Positive'Image (Base_Number_Of_Threads) & " threads at priority (" & ORB_Priority'Img & "," & Ext_Priority'Img & ")")); Create (Result.Lock); Create (Result.CV); Result.Job_Queue := Create_Queue; for J in 1 .. Base_Number_Of_Threads loop declare New_Runnable : constant Lane_Runnable_Access := new Lane_Runnable; begin New_Runnable.L := Result; New_Runnable.Dynamically_Allocated := False; declare T : constant Thread_Access := Run_In_Task (TF => Get_Thread_Factory, Name => "", Default_Priority => ORB_Priority, Storage_Size => Stack_Size, R => Runnable_Access (New_Runnable)); pragma Unreferenced (T); begin null; end; end; end loop; return Result; end Create; ------------- -- Destroy -- ------------- procedure Destroy (L : access Lane) is begin L.Clean_Up_In_Progress := True; Broadcast (L.CV); end Destroy; procedure Destroy (L : access Lanes_Set) is begin for J in L.Set'Range loop Destroy (L.Set (J)); end loop; end Destroy; --------------- -- Queue_Job -- --------------- procedure Queue_Job (L : access Lane; J : Job_Access; Hint_Priority : External_Priority := Invalid_Priority) is pragma Unreferenced (Hint_Priority); begin pragma Debug (C, O ("Queue job in lane at priority (" & L.ORB_Priority'Img & "," & L.Ext_Priority'Img & ")")); Enter (L.Lock); -- Queue job in common job queue if (not L.Buffer_Request and then Length (L.Job_Queue) < L.Base_Number_Of_Threads) or else (L.Buffer_Request and then Length (L.Job_Queue) < Natural (L.Max_Buffered_Requests)) then pragma Debug (C, O ("Queue job on job queue")); Queue_Job (L.Job_Queue, J); if L.Idle_Tasks > 0 then -- If there are idle tasks, awake one Signal (L.CV); Leave (L.Lock); return; elsif L.Dynamic_Threads_Created < L.Dynamic_Number_Of_Threads then -- Eventually, create a new task declare New_Runnable : constant Lane_Runnable_Access := new Lane_Runnable; begin New_Runnable.L := Lane_Access (L); New_Runnable.Dynamically_Allocated := True; declare T : constant Thread_Access := Run_In_Task (TF => Get_Thread_Factory, Name => "", Default_Priority => L.ORB_Priority, Storage_Size => L.Stack_Size, R => Runnable_Access (New_Runnable)); pragma Unreferenced (T); begin null; end; end; L.Dynamic_Threads_Created := L.Dynamic_Threads_Created + 1; end if; Leave (L.Lock); return; else -- Cannot queue job Leave (L.Lock); pragma Debug (C, O ("Cannot queue job")); raise Program_Error; end if; end Queue_Job; procedure Queue_Job (L : access Lanes_Set; J : Job_Access; Hint_Priority : External_Priority := Invalid_Priority) is use PolyORB.QoS; use PolyORB.QoS.Priority; use PolyORB.Request_QoS; RJ : PolyORB.ORB.Request_Job renames PolyORB.ORB.Request_Job (J.all); Parameter : constant QoS_Parameter_Access := Extract_Request_Parameter (Static_Priority, RJ.Request.all); Queuing_Priority : External_Priority; begin if Parameter /= null then pragma Debug (C, O ("About to queue a job at priority" & QoS_Static_Priority (Parameter.all).EP'Img)); Queuing_Priority := QoS_Static_Priority (Parameter.all).EP; Add_Reply_QoS (RJ.Request.all, Static_Priority, new QoS_Parameter'Class'(Parameter.all)); elsif Hint_Priority /= Invalid_Priority then pragma Debug (C, O ("About to queue a job at priority" & Hint_Priority'Img)); Queuing_Priority := Hint_Priority; else pragma Debug (C, O ("No priority information !")); raise Program_Error; end if; for K in L.Set'Range loop pragma Debug (C, O ("Testing lane, priority" & ORB_Priority'Image (L.Set (K).ORB_Priority))); if L.Set (K).Ext_Priority = Queuing_Priority then Queue_Job (L.Set (K), J); return; end if; end loop; pragma Debug (C, O ("Cannot queue job, no lane matches request priority")); raise Program_Error; end Queue_Job; ----------------------- -- Is_Valid_Priority -- ----------------------- function Is_Valid_Priority (L : access Lane; Priority : External_Priority) return Boolean is begin return L.Ext_Priority = Priority; end Is_Valid_Priority; function Is_Valid_Priority (L : access Lanes_Set; Priority : External_Priority) return Boolean is begin for J in L.Set'Range loop if L.Set (J).all.Ext_Priority = Priority then return True; end if; end loop; return False; end Is_Valid_Priority; end PolyORB.Lanes; polyorb-2.8~20110207.orig/src/polyorb-tasking-profiles-full_tasking-mutexes.ads0000644000175000017500000000726311750740340027007 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- POLYORB.TASKING.PROFILES.FULL_TASKING.MUTEXES -- -- -- -- S p e c -- -- -- -- Copyright (C) 2002-2009, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- Implementation of POSIX-like mutexes with full Ada tasking. -- This variant uses GNAT-specific library facilities. pragma Warnings (Off); -- Depends on System.Task_Primitives, an internal GNAT unit with System.Task_Primitives; pragma Warnings (On); with PolyORB.Tasking.Mutexes; package PolyORB.Tasking.Profiles.Full_Tasking.Mutexes is package PTM renames PolyORB.Tasking.Mutexes; type Full_Tasking_Mutex_Type is new PTM.Mutex_Type with private; type Full_Tasking_Mutex_Access is access all Full_Tasking_Mutex_Type'Class; procedure Enter (M : access Full_Tasking_Mutex_Type); pragma Inline (Enter); procedure Leave (M : access Full_Tasking_Mutex_Type); pragma Inline (Leave); type Full_Tasking_Mutex_Factory_Type is new PTM.Mutex_Factory_Type with private; type Full_Tasking_Mutex_Factory_Access is access all Full_Tasking_Mutex_Factory_Type'Class; The_Mutex_Factory : constant Full_Tasking_Mutex_Factory_Access; function Create (MF : access Full_Tasking_Mutex_Factory_Type; Name : String := "") return PTM.Mutex_Access; procedure Destroy (MF : access Full_Tasking_Mutex_Factory_Type; M : in out PTM.Mutex_Access); private subtype Mutex_Lock is System.Task_Primitives.Lock; type Mutex_Lock_Access is access Mutex_Lock; type Full_Tasking_Mutex_Type is new PTM.Mutex_Type with record The_Lock : Mutex_Lock_Access; end record; type Full_Tasking_Mutex_Factory_Type is new PTM.Mutex_Factory_Type with null record; The_Mutex_Factory : constant Full_Tasking_Mutex_Factory_Access := new Full_Tasking_Mutex_Factory_Type; end PolyORB.Tasking.Profiles.Full_Tasking.Mutexes; polyorb-2.8~20110207.orig/src/polyorb-utils-buffers.adb0000644000175000017500000001540411750740340022123 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . U T I L S . B U F F E R S -- -- -- -- B o d y -- -- -- -- Copyright (C) 2001-2009, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with System; with PolyORB.Opaque; use PolyORB.Opaque; package body PolyORB.Utils.Buffers is ------------------------------- -- Align_Transfer_Elementary -- ------------------------------- package body Align_Transfer_Elementary is subtype SEA is Stream_Element_Array (1 .. T'Size / 8); Alignment_Of_T : constant Alignment_Type := Alignment_Of (T'Size / 8); -------------- -- Marshall -- -------------- procedure Marshall (Buffer : access Buffer_Type; Item : T) is Item_Address : System.Address := Item'Address; Data_Address : Opaque_Pointer; Item_Swapped : aliased T; begin if Alignment_Of_T /= Align_1 and then With_Alignment then Pad_Align (Buffer, Alignment_Of_T); end if; Allocate_And_Insert_Cooked_Data (Buffer, T'Size / 8, Data_Address); -- Note: we can't just have a T object at Data_Address and assign -- it with Item / Swapped (Item) because Data_Address may not be -- suitably aligned. So instead overlay a constrained stream element -- array, and assign that. declare Z_Addr : constant System.Address := Data_Address; Z : SEA; for Z'Address use Z_Addr; pragma Import (Ada, Z); begin if Item'Size > 8 and then Endianness (Buffer) /= Host_Order then Item_Swapped := Swapped (Item); Item_Address := Item_Swapped'Address; end if; declare Item_Storage : SEA; pragma Import (Ada, Item_Storage); for Item_Storage'Address use Item_Address; begin Z := Item_Storage; end; end; end Marshall; ---------------- -- Unmarshall -- ---------------- function Unmarshall (Buffer : access Buffer_Type) return T is Data_Address : Opaque_Pointer; begin if Alignment_Of_T /= Align_1 and then With_Alignment then Align_Position (Buffer, Alignment_Of_T); end if; Extract_Data (Buffer, Data_Address, T'Size / 8); -- Note: Need to go through a stream element array to account for -- possibly misaligned extracted data (see comments in Marshall). declare Z_Addr : constant System.Address := Data_Address; Z : SEA; for Z'Address use Z_Addr; pragma Import (Ada, Z); Item : aliased T; Item_Storage : SEA; pragma Import (Ada, Item_Storage); for Item_Storage'Address use Item'Address; begin Item_Storage := Z; if Item'Size > 8 and then Endianness (Buffer) = Host_Order then return Item; else return Swapped (Item); end if; end; end Unmarshall; end Align_Transfer_Elementary; ------------------------- -- Align_Marshall_Copy -- ------------------------- procedure Align_Marshall_Copy (Buffer : access Buffer_Type; Octets : Stream_Element_Array; Alignment : Alignment_Type := Align_1) is Data_Address : Opaque_Pointer; begin Pad_Align (Buffer, Alignment); Allocate_And_Insert_Cooked_Data (Buffer, Octets'Length, Data_Address); declare Z_Addr : constant System.Address := Data_Address; Z : Stream_Element_Array (Octets'Range); for Z'Address use Z_Addr; pragma Import (Ada, Z); begin Z := Octets; end; end Align_Marshall_Copy; --------------------------- -- Align_Unmarshall_Copy -- --------------------------- procedure Align_Unmarshall_Copy (Buffer : access Buffer_Type; Alignment : Alignment_Type := Align_1; Data : out Stream_Element_Array) is Index : Stream_Element_Offset := Data'First; Size : Stream_Element_Count; Data_Address : Opaque_Pointer; begin Align_Position (Buffer, Alignment); while Index /= Data'Last + 1 loop Size := Data'Last - Index + 1; Partial_Extract_Data (Buffer, Data_Address, Size); pragma Assert (Size > 0); -- Size may be less than what we requested, in case we are at -- a chunk boundary, but at least *some* data must always be -- returned. declare Extracted_Data : Stream_Element_Array (1 .. Size); for Extracted_Data'Address use Data_Address; pragma Import (Ada, Extracted_Data); begin Data (Index .. Index + Size - 1) := Extracted_Data; end; Index := Index + Size; end loop; end Align_Unmarshall_Copy; end PolyORB.Utils.Buffers; polyorb-2.8~20110207.orig/src/polyorb-requests.ads0000644000175000017500000003422111750740340021223 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . R E Q U E S T S -- -- -- -- S p e c -- -- -- -- Copyright (C) 2001-2011, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- The Request object pragma Ada_2005; with Ada.Finalization; with PolyORB.Annotations; with PolyORB.Any.ExceptionList; with PolyORB.Any.NVList; with PolyORB.Binding_Data; with PolyORB.Components; with PolyORB.Errors; with PolyORB.References; with PolyORB.Smart_Pointers; with PolyORB.Task_Info; with PolyORB.Tasking.Abortables; with PolyORB.Tasking.Mutexes; with PolyORB.Types; with PolyORB.Utils.Simple_Flags; with PolyORB.Utils.Strings; package PolyORB.Requests is use PolyORB.Errors; type Arguments_Identification is array (1 .. 2) of Boolean; pragma Pack (Arguments_Identification); Ident_By_Position : constant Arguments_Identification; Ident_By_Name : constant Arguments_Identification; Ident_Unspecified : constant Arguments_Identification; Ident_Both : constant Arguments_Identification; -- These constants are used to indicate how the arguments are -- handled by the personalities (both client and -- server). Ident_Unspecified is not supposed to be used directly -- by a personality, as it means that we do not know how the -- arguments are identified. It is used by the internal mechanisms. type Flags is new Types.Unsigned_Long; package Unsigned_Long_Flags is new PolyORB.Utils.Simple_Flags (Flags); ------------------------------------------ -- Synchronisation of request execution -- ------------------------------------------ Sync_None : constant Flags; Sync_With_Transport : constant Flags; Sync_With_Server : constant Flags; Sync_With_Target : constant Flags; Sync_Call_Back : constant Flags; -- Flags to be used for member Req_Flags of request. -- When a request is not synchronised, the middleware returns to the caller -- before passing the request to the transport layer. The middleware MUST -- guarantee that the call is non-blocking. -- When a request is synchronised With_Transport, the middleware must not -- return to the caller before the corresponding message has been accepted -- by the transport layer. -- When a request is synchronised With_Server, the middleware does not -- return before receiving a confirmation that the request message has been -- received by the server middleware. -- When a request is synchronised With_Target, the middlware does not -- return to the caller before receinving a confirmation that the request -- has been executed by the target object. -- Document Sync_Call_Back??? ------------- -- Request -- ------------- Default_Flags : constant Flags; -- Default flag for member Req_Flags of request. type Request is new Ada.Finalization.Limited_Controlled with record Target : References.Ref; -- A ref designating the target object Operation : PolyORB.Utils.Strings.String_Ptr; -- The name of the method to be invoked Args_Ident : Arguments_Identification := Ident_By_Position; -- To optimize the handling of Args, we can provide a hint about the -- structure of the NV_List. Args : Any.NVList.Ref; -- The arguments to the request, for transmission from caller to callee. -- On the server side, the Protocol layer MAY set this component -- directly OR set the following component instead. The Application -- layer MUST NOT access this component directly, and MUST use operation -- Arguments below to retrieve the arguments from an invocation and set -- up the structure for returned (out-mode) arguments. Out_Args : Any.NVList.Ref; -- Same as Args but for transmission from callee to caller Deferred_Arguments_Session : Components.Component_Access; -- If Args have not been unmarshalled at the time the request is -- created, then this component must be set to the Session on which the -- arguments are waiting to be unmarshalled. Arguments_Called : Boolean := False; Set_Result_Called : Boolean := False; -- Flags to guard against double invocation of Arguments and Set_Result -- on the same request. -- When creating a Request object with deferred arguments, it is the -- Protocol layer's responsibility to ensure that consistent information -- is presented when Unmarshall_Arguments is called. Result : Any.NamedValue; -- The result returned by the object after execution of this request Exc_List : PolyORB.Any.ExceptionList.Ref; -- The list of user exceptions potentially raised by this request -- XXX This is client-side info. How do we construct it on a proxy -- object? Exception_Info : aliased Any.Any; -- If non-empty, information relative to an exception raised during -- execution of this request. Req_Flags : Flags; -- Additional flags Aborted : Boolean := False; -- Set True if the request is aborted Completed : aliased Boolean := False; -- Indicate whether the request is completed or not. -- Note: request execution state when completing the request depends on -- synchronisation flags used. Requesting_Task : aliased PolyORB.Task_Info.Task_Info_Access; -- Task requesting request completion. This task will be executing the -- ORB main loop until the request is completed. -- Note: Requesting_Task is set up when entering ORB main loop, -- see PolyORB.ORB.Run for more details. Requesting_Component : Components.Component_Access; -- Component requesting request execution. The response, if any, will be -- redirected to this component. Surrogate : Components.Component_Access; -- Component handling request execution Profile : Binding_Data.Profile_Access; -- Profile of target ref selected when binding to Surrogate Upcall_Abortable : access Tasking.Abortables.Abortable'Class; Upcall_Abortable_Mutex : Tasking.Mutexes.Mutex_Access; -- While the request is being served by an upcall to an application -- servant, this handle is set to designate the corresponding abortable -- object, to allow the execution to be aborted. Abortion should occur -- under Upcall_Abortable_Mutex protection to ensure that the abortable -- object is not prematurely destroyed. Dependent_Binding_Object : Smart_Pointers.Ref; -- A reference to the binding object from which a server-side request -- was created. Used to prevent said BO from being destroyed will the -- request is still being processed by the application layer. -- XXX study feasibility & cost of merging Dependent_Binding_Object with -- Requestor? Maybe by making all components Non_Controlled_Entities? Notepad : Annotations.Notepad; -- Request objects are manipulated by both the Application layer (which -- creates them on the client side and handles their execution on the -- server side) and the Protocol layer (which sends them out on the -- client side and receives them on the server side). -- -- If only one layer had a need to associate specific information with a -- Request object, one could imagine that this layer would make a type -- extension of Request to store such information. -- -- In our case, /both/ layers may need to attach layer-specific -- information to the same request object. Ada type derivation can -- therefore not be used (this would require actual Request objects to -- derive from both the application-layer derivation and the -- protocol-layer derivation). For this reason, annotations are used -- instead to allow each layer to independently store its specific -- add-on information in a Request. end record; procedure Initialize (Req : in out Request); procedure Finalize (Req : in out Request); type Request_Access is access all Request; procedure Create_Request (Target : References.Ref; Operation : String; Arg_List : Any.NVList.Ref; Result : in out Any.NamedValue; Exc_List : Any.ExceptionList.Ref := Any.ExceptionList.Nil_Ref; Req : out Request_Access; Req_Flags : Flags := Default_Flags; Deferred_Arguments_Session : Components.Component_Access := null; Identification : Arguments_Identification := Ident_By_Position; Dependent_Binding_Object : Smart_Pointers.Entity_Ptr := null); procedure Setup_Request (Req : out Request; Target : References.Ref; Operation : String; Arg_List : Any.NVList.Ref; Result : in out Any.NamedValue; Exc_List : Any.ExceptionList.Ref := Any.ExceptionList.Nil_Ref; Req_Flags : Flags := Default_Flags; Deferred_Arguments_Session : Components.Component_Access := null; Identification : Arguments_Identification := Ident_By_Position; Dependent_Binding_Object : Smart_Pointers.Entity_Ptr := null); procedure Invoke (Self : access Request; Invoke_Flags : Flags := 0; Timeout : Duration := 0.0); -- Run Self. If Timeout is non-zero, and the underlying tasking profile -- supports it, execution is aborted if it exceeds the specified duration. -- XXX Invoke_Flags is currently set to 0, and not used. It is kept -- for future use. procedure Arguments (Self : Request_Access; Args : in out Any.NVList.Ref; Error : in out Error_Container; Identification : Arguments_Identification := Ident_By_Position; Can_Extend : Boolean := False); -- Retrieve the invocation's arguments into Args. Call back the protocol -- layer to do the unmarshalling, if necessary. Should be called exactly -- once from within a servant's Invoke primitive. Args MUST be a -- correctly typed NVList for the signature of the method being invoked. -- If Can_Extend is set to True and Self contains extra arguments that -- are not required by Args, they are appended. Identification is used -- to specify the capailities of the server personality. procedure Set_Result (Self : Request_Access; Val : Any.Any); -- Set the value of Self's result to Val. Assert no error has been thrown procedure Set_Result (Self : Request_Access; Val : Any.Any; Error : in out Error_Container); -- Set the value of Self's result to Val procedure Set_Exception (Self : in out Request; Error : Error_Container); pragma Inline (Set_Exception); procedure Set_Out_Args (Self : Request_Access; Error : in out Error_Container; Identification : Arguments_Identification := Ident_By_Position); -- Copy back the values of out and inout arguments from Out_Args to Args. -- Identification is used to specify the capabilities of the server -- personality. procedure Destroy_Request (Req : in out Request_Access); function Image (Req : Request) return String; -- For debugging purposes procedure Reset_Request (Request : in out PolyORB.Requests.Request); -- Set request to a state where it can be re-issued: exception and -- arguments status are reset. private Sync_None : constant Flags := 1; Sync_With_Transport : constant Flags := 2; Sync_With_Server : constant Flags := 4; Sync_With_Target : constant Flags := 8; Sync_Call_Back : constant Flags := 16; Default_Flags : constant Flags := Sync_With_Target; Ident_By_Position : constant Arguments_Identification := (True, False); Ident_By_Name : constant Arguments_Identification := (False, True); Ident_Unspecified : constant Arguments_Identification := (False, False); Ident_Both : constant Arguments_Identification := (True, True); end PolyORB.Requests; polyorb-2.8~20110207.orig/src/polyorb-transport-connected-sockets.adb0000644000175000017500000003032511750740340024775 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . T R A N S P O R T . C O N N E C T E D . S O C K E T S -- -- -- -- B o d y -- -- -- -- Copyright (C) 2001-2011, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- Socket implementation of transport service access points -- and communication endpoints. with Ada.Exceptions; with System.Storage_Elements; with PolyORB.Asynch_Ev.Sockets; with PolyORB.Initialization; with PolyORB.Log; with PolyORB.Parameters; with PolyORB.Utils.Strings; package body PolyORB.Transport.Connected.Sockets is use Ada.Streams; use PolyORB.Asynch_Ev.Sockets; use PolyORB.Log; use PolyORB.Parameters; use PolyORB.Tasking.Mutexes; use PolyORB.Utils.Sockets; package L is new PolyORB.Log.Facility_Log ("polyorb.transport.connected.sockets"); procedure O (Message : String; Level : Log_Level := Debug) renames L.Output; function C (Level : Log_Level := Debug) return Boolean renames L.Enabled; procedure Initialize; -- Create Dummy_Selector Dummy_Selector : Selector_Type; -- Selector object used for Check_Validity, abortion is never used on this -- selector. -- WAG:6.3 -- Such a dummy selector should be provided by GNAT.Sockets directly. ----------------------- -- Accept_Connection -- ----------------------- procedure Accept_Connection (TAP : Socket_Access_Point; TE : out Transport_Endpoint_Access) is New_Socket : Socket_Type; New_Address : Sock_Addr_Type; begin TE := new Socket_Endpoint; Accept_Socket (Server => TAP.Socket, Socket => New_Socket, Address => New_Address); pragma Debug (C, O ("Accept_Connection: from " & Image (New_Address))); Create (Socket_Endpoint (TE.all), New_Socket); end Accept_Connection; ---------------- -- Address_Of -- ---------------- function Address_Of (SAP : Socket_Access_Point) return Utils.Sockets.Socket_Name is begin return Image (SAP.Addr.Addr) + SAP.Addr.Port; end Address_Of; ------------ -- Create -- ------------ procedure Create (SAP : in out Socket_Access_Point; Socket : Socket_Type; Address : in out Sock_Addr_Type) is begin pragma Debug (C, O ("Create: listening on " & Image (Address))); Bind_Socket (Socket, Address); Listen_Socket (Socket); SAP.Socket := Socket; if Address.Addr = Any_Inet_Addr then -- Address is unspecified, choose one IP for the SAP looking up -- local host name. -- ??? Instead SAP.Addr should be a Socket_Name, and we should keep -- Host_Name unresolved. SAP.Addr.Addr := Local_Inet_Address; Address := SAP.Addr; else -- Use specified IP address for SAP SAP.Addr := Address; end if; SAP.Addr.Port := Get_Socket_Name (Socket).Port; end Create; ------------------------- -- Create_Event_Source -- ------------------------- function Create_Event_Source (TAP : access Socket_Access_Point) return Asynch_Ev_Source_Access is Ev_Src : constant Asynch_Ev_Source_Access := Create_Event_Source (TAP.Socket); begin Set_Handler (Ev_Src.all, TAP.Handler'Access); return Ev_Src; end Create_Event_Source; ------------ -- Create -- ------------ procedure Create (TE : in out Socket_Endpoint; S : Socket_Type) is begin TE.Socket := S; if Get_Conf ("transport", "tcp.nodelay", True) then Set_Socket_Option (Socket => S, Level => IP_Protocol_For_TCP_Level, Option => (Name => No_Delay, Enabled => True)); end if; Create (TE.Mutex); end Create; ------------------------- -- Create_Event_Source -- ------------------------- function Create_Event_Source (TE : access Socket_Endpoint) return Asynch_Ev_Source_Access is Ev_Src : constant Asynch_Ev_Source_Access := Create_Event_Source (TE.Socket); begin Set_Handler (Ev_Src.all, TE.Handler'Access); return Ev_Src; end Create_Event_Source; ----------------------- -- Is_Data_Available -- ----------------------- function Is_Data_Available (TE : Socket_Endpoint; N : Natural) return Boolean is Request : Request_Type (N_Bytes_To_Read); begin Control_Socket (TE.Socket, Request); pragma Debug (C, O ("Found" & Request.Size'Img & " bytes waiting")); return Request.Size >= N; end Is_Data_Available; ---------- -- Read -- ---------- procedure Read (TE : in out Socket_Endpoint; Buffer : Buffers.Buffer_Access; Size : in out Stream_Element_Count; Error : out Errors.Error_Container) is use PolyORB.Buffers; use PolyORB.Errors; Data_Received : Stream_Element_Count; procedure Receive_Socket (V : access Iovec); -- Lowlevel socket receive -------------------- -- Receive_Socket -- -------------------- procedure Receive_Socket (V : access Iovec) is Count : Ada.Streams.Stream_Element_Count; Vecs : Vector_Type (1 .. 1); pragma Import (Ada, Vecs); for Vecs'Address use V.all'Address; begin PolyORB.Sockets.Receive_Vector (TE.Socket, Vecs, Count); V.Iov_Len := System.Storage_Elements.Storage_Offset (Count); end Receive_Socket; procedure Receive_Buffer is new PolyORB.Buffers.Receive_Buffer (Receive_Socket); -- Start of processing for Read begin begin Receive_Buffer (Buffer, Size, Data_Received); exception when E : PolyORB.Sockets.Socket_Error => O ("receive failed: " & Ada.Exceptions.Exception_Message (E), Notice); Throw (Error, Comm_Failure_E, System_Exception_Members' (Minor => 0, Completed => Completed_Maybe)); return; when others => Throw (Error, Unknown_E, System_Exception_Members' (Minor => 0, Completed => Completed_Maybe)); return; end; pragma Assert (Data_Received <= Size); Size := Data_Received; end Read; ----------- -- Write -- ----------- procedure Write (TE : in out Socket_Endpoint; Buffer : Buffers.Buffer_Access; Error : out Errors.Error_Container) is use PolyORB.Errors; use PolyORB.Buffers; procedure Socket_Send (V : access Iovec; N : Integer; Count : out System.Storage_Elements.Storage_Offset); -- Send gathered data ----------------- -- Socket_Send -- ----------------- procedure Socket_Send (V : access Iovec; N : Integer; Count : out System.Storage_Elements.Storage_Offset) is subtype SV_T is PolyORB.Sockets.Vector_Type (1 .. N); SV : SV_T; pragma Import (Ada, SV); for SV'Address use V.all'Address; S_Count : Ada.Streams.Stream_Element_Count; begin PolyORB.Sockets.Send_Vector (TE.Socket, SV, S_Count); Count := System.Storage_Elements.Storage_Offset (S_Count); end Socket_Send; procedure Send_Buffer is new Buffers.Send_Buffer (Socket_Send); -- Start of processing for Write begin pragma Abort_Defer; pragma Debug (C, O ("Write: enter")); -- Send_Buffer is not atomic, needs to be protected. Enter (TE.Mutex); pragma Debug (C, O ("Write: TE mutex acquired")); begin Send_Buffer (Buffer); exception when E : PolyORB.Sockets.Socket_Error => O ("send failed: " & Ada.Exceptions.Exception_Message (E), Notice); Throw (Error, Comm_Failure_E, System_Exception_Members' (Minor => 0, Completed => Completed_Maybe)); when others => Throw (Error, Unknown_E, System_Exception_Members' (Minor => 0, Completed => Completed_Maybe)); end; Leave (TE.Mutex); pragma Debug (C, O ("Write: leave")); end Write; -------------------- -- Check_Validity -- -------------------- procedure Check_Validity (TE : access Socket_Endpoint) is Buf : Stream_Element_Array (1 .. 1); Last : Stream_Element_Offset; R_Set, W_Set : Socket_Set_Type; Status : Selector_Status; begin pragma Assert (TE.Socket /= No_Socket); Set (R_Set, TE.Socket); Check_Selector (Dummy_Selector, R_Set, W_Set, Status, 0.0); if Status = Completed and then Is_Set (R_Set, TE.Socket) then Receive_Socket (TE.Socket, Buf, Last, Peek_At_Incoming_Data); if Last = 0 then -- Connection closed Close (TE); end if; end if; end Check_Validity; ----------- -- Close -- ----------- procedure Close (TE : access Socket_Endpoint) is begin if TE.Closed then return; end if; Enter (TE.Mutex); begin PolyORB.Transport.Connected.Close (Connected_Transport_Endpoint (TE.all)'Access); if TE.Socket /= No_Socket then pragma Debug (C, O ("Closing socket" & PolyORB.Sockets.Image (TE.Socket))); Close_Socket (TE.Socket); TE.Socket := No_Socket; end if; exception when E : others => pragma Debug (C, O ("Close (Socket_Endpoint): got " & Ada.Exceptions.Exception_Information (E))); null; end; Leave (TE.Mutex); end Close; ------------- -- Destroy -- ------------- procedure Destroy (TE : in out Socket_Endpoint) is begin Destroy (TE.Mutex); Connected.Destroy (Connected_Transport_Endpoint (TE)); end Destroy; ---------------- -- Initialize -- ---------------- procedure Initialize is begin Create_Selector (Dummy_Selector); end Initialize; use PolyORB.Initialization; use PolyORB.Initialization.String_Lists; use PolyORB.Utils.Strings; begin Register_Module (Module_Info' (Name => +"transport.connected.sockets", Conflicts => Empty, Depends => Empty, Provides => +"transport", Implicit => False, Init => Initialize'Access, Shutdown => null)); end PolyORB.Transport.Connected.Sockets; polyorb-2.8~20110207.orig/src/polyorb.ads0000644000175000017500000000414011750740340017347 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B -- -- -- -- S p e c -- -- -- -- Copyright (C) 2001-2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- The top of the PolyORB architecture package PolyORB is pragma Pure; end PolyORB; polyorb-2.8~20110207.orig/src/polyorb-poa_policies-lifespan_policy-persistent.adb0000644000175000017500000001027011750740340027347 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- POLYORB.POA_POLICIES.LIFESPAN_POLICY.PERSISTENT -- -- -- -- B o d y -- -- -- -- Copyright (C) 2002-2007, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ package body PolyORB.POA_Policies.Lifespan_Policy.Persistent is ------------ -- Create -- ------------ function Create return Persistent_Policy_Access is begin return new Persistent_Policy; end Create; ------------------------- -- Check_Compatibility -- ------------------------- procedure Check_Compatibility (Self : Persistent_Policy; Other_Policies : AllPolicies; Error : in out PolyORB.Errors.Error_Container) is pragma Warnings (Off); pragma Unreferenced (Self); pragma Unreferenced (Other_Policies); pragma Unreferenced (Error); pragma Warnings (On); begin null; -- No rule to test. end Check_Compatibility; --------------- -- Policy_Id -- --------------- function Policy_Id (Self : Persistent_Policy) return String is pragma Warnings (Off); pragma Unreferenced (Self); pragma Warnings (On); begin return "LIFESPAN_POLICY.PERSISTENT"; end Policy_Id; ------------------------- -- Get_Lifespan_Cookie -- ------------------------- function Get_Lifespan_Cookie (Self : Persistent_Policy; OA : PolyORB.POA_Types.Obj_Adapter_Access) return Time_Stamp is pragma Warnings (Off); pragma Unreferenced (Self, OA); pragma Warnings (On); begin return Null_Time_Stamp; end Get_Lifespan_Cookie; --------------------- -- Ensure_Lifespan -- --------------------- procedure Ensure_Lifespan (Self : Persistent_Policy; OA : PolyORB.POA_Types.Obj_Adapter_Access; U_Oid : Unmarshalled_Oid; Error : in out PolyORB.Errors.Error_Container) is pragma Warnings (Off); pragma Unreferenced (Self, OA); pragma Warnings (On); use PolyORB.Errors; begin if U_Oid.Persistency_Flag /= Null_Time_Stamp then Throw (Error, Object_Not_Exist_E, System_Exception_Members'(Minor => 0, Completed => Completed_No)); end if; end Ensure_Lifespan; end PolyORB.POA_Policies.Lifespan_Policy.Persistent; polyorb-2.8~20110207.orig/src/polyorb-poa.adb0000644000175000017500000014172011750740340020111 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . P O A -- -- -- -- B o d y -- -- -- -- Copyright (C) 2001-2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- Abstract interface for the POA with Ada.Strings.Fixed; with Ada.Unchecked_Deallocation; with PolyORB.Log; with PolyORB.Obj_Adapters; with PolyORB.Obj_Adapter_QoS; with PolyORB.POA_Config; with PolyORB.POA_Manager.Basic_Manager; with PolyORB.Smart_Pointers; with PolyORB.Tasking; with PolyORB.Tasking.Threads; with PolyORB.Utils; package body PolyORB.POA is use PolyORB.Errors; use PolyORB.Log; use PolyORB.POA_Manager; use PolyORB.POA_Policies; use PolyORB.Tasking.Mutexes; use PolyORB.Types; use PolyORB.Utils; package L is new Log.Facility_Log ("polyorb.poa"); procedure O (Message : Standard.String; Level : Log_Level := Debug) renames L.Output; function C (Level : Log_Level := Debug) return Boolean renames L.Enabled; -------------------- -- Oid_To_Rel_URI -- -------------------- procedure Oid_To_Rel_URI (OA : access Obj_Adapter; Id : access Object_Id; URI : out Types.String; Error : in out PolyORB.Errors.Error_Container) is use Ada.Strings; use Ada.Strings.Fixed; pragma Warnings (Off); pragma Unreferenced (OA); pragma Warnings (On); U_Oid : Unmarshalled_Oid; begin Oid_To_U_Oid (Id.all, U_Oid, Error); if Found (Error) then return; end if; URI := To_PolyORB_String ("/"); pragma Debug (C, O ("Oid: Creator: " & To_Standard_String (U_Oid.Creator) & ", Id: " & To_Standard_String (U_Oid.Id) & ", sys = " & Boolean'Image (U_Oid.System_Generated) & ", pf = " & Lifespan_Cookie'Image (U_Oid.Persistency_Flag))); if Length (U_Oid.Creator) /= 0 then URI := URI & U_Oid.Creator & To_PolyORB_String ("/"); end if; URI := URI & URI_Encode (To_Standard_String (U_Oid.Id)); -- XXX Here we make the assumption that Id needs to be URI-escaped, and -- Creator needs not, but there is no reason to. What should actually be -- done is that Creator should be a list, and each of its components -- should be separately URLencoded. if U_Oid.System_Generated then URI := URI & ";sys"; end if; if U_Oid.Persistency_Flag /= Null_Time_Stamp then URI := URI & ";pf=" & Trim (U_Oid.Persistency_Flag'Img, Left); end if; pragma Debug (C, O ("-> URI: " & To_Standard_String (URI))); end Oid_To_Rel_URI; -------------------- -- Rel_URI_To_Oid -- -------------------- function Rel_URI_To_Oid (OA : access Obj_Adapter; URI : String) return Object_Id_Access is pragma Unreferenced (OA); Colon : Integer := Find (URI, URI'First, ';'); Last_Slash : Integer := Colon - 1; Creator_First, Creator_Last : Integer; Id_First, Id_Last : Integer; System_Generated : Boolean; Persistency_Flag : Lifespan_Cookie; begin pragma Debug (C, O ("URI: " & URI)); while URI (Last_Slash) /= '/' and then Last_Slash >= URI'First loop Last_Slash := Last_Slash - 1; end loop; pragma Assert (URI (URI'First) = '/' and then Last_Slash >= URI'First); Creator_First := URI'First + 1; Creator_Last := Last_Slash - 1; Id_First := Last_Slash + 1; Id_Last := Colon - 1; if Colon + 3 <= URI'Last and then URI (Colon + 1 .. Colon + 3) = "sys" then System_Generated := True; Colon := Find (URI, Colon + 1, ';'); else System_Generated := False; end if; if Colon + 3 <= URI'Last and then URI (Colon + 1 .. Colon + 3) = "pf=" then Persistency_Flag := Lifespan_Cookie'Value (URI (Colon + 4 .. URI'Last)); else Persistency_Flag := Null_Time_Stamp; end if; pragma Debug (C, O ("-> Oid: Creator: " & URI (Creator_First .. Creator_Last) & ", Id: " & URI (Id_First .. Id_Last) & ", sys = " & Boolean'Image (System_Generated) & ", pf = " & Lifespan_Cookie'Image (Persistency_Flag))); return Create_Id (Name => URI_Decode (URI (Id_First .. Id_Last)), System_Generated => System_Generated, Persistency_Flag => Persistency_Flag, Creator => URI_Decode (URI (Creator_First .. Creator_Last))); end Rel_URI_To_Oid; ---------------------- -- Global POA Table -- ---------------------- Global_POATable : POATable; -- This table is used to shortcut POA recursive search, when -- possible. It contains all registred POAs with full path name. ------------------------------------ -- Code of additional functions -- ------------------------------------ -------------------- -- POA_Manager_Of -- -------------------- function POA_Manager_Of (OA : access Obj_Adapter) return POA_Manager.POAManager_Access is use Smart_Pointers; E : constant Entity_Ptr := Entity_Of (OA.POA_Manager); begin pragma Assert (E.all in POA_Manager.POAManager'Class); return POAManager_Access (E); end POA_Manager_Of; ------------------ -- Set_Policies -- ------------------ procedure Set_Policies (OA : access Obj_Adapter; Policies : POA_Policies.PolicyList; Default : Boolean) is use Policy_Lists; It : Iterator := First (Policies); A_Policy : Policy_Access; begin Enter (OA.POA_Lock); while not Last (It) loop A_Policy := Value (It).all; if A_Policy.all in ThreadPolicy'Class then if OA.Thread_Policy = null or else not Default then if OA.Thread_Policy /= null then pragma Debug (C, O ("Duplicate in ThreadPolicy: using last one")); null; end if; OA.Thread_Policy := ThreadPolicy_Access (A_Policy); end if; elsif A_Policy.all in LifespanPolicy'Class then if OA.Lifespan_Policy = null or else not Default then if OA.Lifespan_Policy /= null then pragma Debug (C, O ("Duplicate in LifespanPolicy: using last one")); null; end if; OA.Lifespan_Policy := LifespanPolicy_Access (A_Policy); end if; elsif A_Policy.all in IdUniquenessPolicy'Class then if OA.Id_Uniqueness_Policy = null or else not Default then if OA.Id_Uniqueness_Policy /= null then pragma Debug (C, O ("Duplicate in IdUniquenessPolicy: using last one")); null; end if; OA.Id_Uniqueness_Policy := IdUniquenessPolicy_Access (A_Policy); end if; elsif A_Policy.all in IdAssignmentPolicy'Class then if OA.Id_Assignment_Policy = null or else not Default then if OA.Id_Assignment_Policy /= null then pragma Debug (C, O ("Duplicate in IdAssignmentPolicy: using last one")); null; end if; OA.Id_Assignment_Policy := IdAssignmentPolicy_Access (A_Policy); end if; elsif A_Policy.all in ServantRetentionPolicy'Class then if OA.Servant_Retention_Policy = null or else not Default then if OA.Servant_Retention_Policy /= null then pragma Debug (C, O ("Duplicate in ServantRetentionPolicy:" & " using last one")); null; end if; OA.Servant_Retention_Policy := ServantRetentionPolicy_Access (A_Policy); end if; elsif A_Policy.all in RequestProcessingPolicy'Class then if OA.Request_Processing_Policy = null or else not Default then if OA.Request_Processing_Policy /= null then pragma Debug (C, O ("Duplicate in RequestProcessingPolicy:" & " using last one")); null; end if; OA.Request_Processing_Policy := RequestProcessingPolicy_Access (A_Policy); end if; elsif A_Policy.all in ImplicitActivationPolicy'Class then if OA.Implicit_Activation_Policy = null or else not Default then if OA.Implicit_Activation_Policy /= null then pragma Debug (C, O ("Duplicate in ImplicitActivationPolicy:" & "using last one")); null; end if; OA.Implicit_Activation_Policy := ImplicitActivationPolicy_Access (A_Policy); end if; else null; pragma Debug (C, O ("Unknown policy ignored")); end if; Next (It); end loop; Leave (OA.POA_Lock); end Set_Policies; ----------------------------- -- Init_With_User_Policies -- ----------------------------- procedure Init_With_User_Policies (OA : access Obj_Adapter; Policies : POA_Policies.PolicyList) is begin pragma Debug (C, O ("Init POA with user provided policies")); Set_Policies (OA, Policies, Default => False); end Init_With_User_Policies; -------------------------------- -- Init_With_Default_Policies -- -------------------------------- procedure Init_With_Default_Policies (OA : access Obj_Adapter) is begin pragma Debug (C, O ("Init POA with default policies")); Set_Policies (OA, POA_Config.Default_Policies (POA_Config.Configuration.all), Default => True); end Init_With_Default_Policies; ---------------------------------- -- Check_Policies_Compatibility -- ---------------------------------- procedure Check_Policies_Compatibility (OA : Obj_Adapter_Access; Error : in out PolyORB.Errors.Error_Container) is OA_Policies : AllPolicies; begin pragma Debug (C, O ("Check compatibilities between policies: enter")); Enter (OA.POA_Lock); OA_Policies (1) := Policy_Access (OA.Thread_Policy); OA_Policies (2) := Policy_Access (OA.Lifespan_Policy); OA_Policies (3) := Policy_Access (OA.Id_Uniqueness_Policy); OA_Policies (4) := Policy_Access (OA.Id_Assignment_Policy); OA_Policies (5) := Policy_Access (OA.Servant_Retention_Policy); OA_Policies (6) := Policy_Access (OA.Request_Processing_Policy); OA_Policies (7) := Policy_Access (OA.Implicit_Activation_Policy); Check_Compatibility (OA.Thread_Policy.all, OA_Policies, Error); Check_Compatibility (OA.Lifespan_Policy.all, OA_Policies, Error); Check_Compatibility (OA.Id_Uniqueness_Policy.all, OA_Policies, Error); Check_Compatibility (OA.Id_Assignment_Policy.all, OA_Policies, Error); Check_Compatibility (OA.Servant_Retention_Policy.all, OA_Policies, Error); Check_Compatibility (OA.Request_Processing_Policy.all, OA_Policies, Error); Check_Compatibility (OA.Implicit_Activation_Policy.all, OA_Policies, Error); Leave (OA.POA_Lock); pragma Debug (C, O ("Check compatibilities between policies: leave")); end Check_Policies_Compatibility; ---------------------- -- Destroy_Policies -- ---------------------- procedure Destroy_Policies (OA : in out Obj_Adapter) is procedure Free is new Ada.Unchecked_Deallocation (Policy'Class, Policy_Access); begin Free (Policy_Access (OA.Thread_Policy)); Free (Policy_Access (OA.Id_Uniqueness_Policy)); Free (Policy_Access (OA.Id_Assignment_Policy)); Free (Policy_Access (OA.Implicit_Activation_Policy)); Free (Policy_Access (OA.Lifespan_Policy)); Free (Policy_Access (OA.Request_Processing_Policy)); Free (Policy_Access (OA.Servant_Retention_Policy)); end Destroy_Policies; --------------------- -- Create_Root_POA -- --------------------- procedure Create_Root_POA (New_Obj_Adapter : access Obj_Adapter) is use PolyORB.POA_Types.POA_HTables; begin pragma Debug (C, O ("Create Root_POA")); -- Create new Obj Adapter New_Obj_Adapter.Boot_Time := Tasking.Threads.Node_Boot_Time; New_Obj_Adapter.Name := +"RootPOA"; New_Obj_Adapter.Absolute_Address := +""; Create (New_Obj_Adapter.POA_Lock); Create (New_Obj_Adapter.Children_Lock); Create (New_Obj_Adapter.Map_Lock); -- Attach a POA Manager to the root POA Set (New_Obj_Adapter.POA_Manager, new Basic_Manager.Basic_POA_Manager); Create (POA_Manager_Of (New_Obj_Adapter)); Register_POA (POA_Manager_Of (New_Obj_Adapter), POA_Types.Obj_Adapter_Access (New_Obj_Adapter)); -- Create and initialize policies factory POA_Config.Initialize (POA_Config.Configuration.all); -- XXX is this really the role of Create_Root_POA to initialize this ??? -- Use default policies Init_With_Default_Policies (New_Obj_Adapter); -- Initialize Global POA Table Initialize (Global_POATable); end Create_Root_POA; --------------------------------------------- -- CORBA-like POA interface implementation -- --------------------------------------------- -------------------- -- Initialize_POA -- -------------------- procedure Initialize_POA (Self : access Obj_Adapter; Adapter_Name : Standard.String; A_POAManager : POA_Manager.POAManager_Access; Policies : POA_Policies.PolicyList; POA : in out Obj_Adapter_Access; Error : in out PolyORB.Errors.Error_Container) is use PolyORB.POA_Types.POA_HTables; Ref : PolyORB.POA_Types.Obj_Adapter_Ref; begin pragma Debug (C, O ("Creating POA: " & Adapter_Name)); -- Validity checks on Adapter_Name: -- name must be non-empty and may not contain POA_Path_Separator -- or ASCII.NUL if Adapter_Name = "" or else PolyORB.Utils.Find (Adapter_Name, Adapter_Name'First, POA_Path_Separator) <= Adapter_Name'Last or else PolyORB.Utils.Find (Adapter_Name, Adapter_Name'First, ASCII.NUL) <= Adapter_Name'Last then Throw (Error, WrongAdapter_E, Null_Members'(Null_Member)); -- XXX Check error name return; end if; -- Look if there is already a child with this name Enter (Self.Children_Lock); if Self.Children /= null then pragma Debug (C, O ("Check if a POA with the same name exists.")); if not Is_Null (Lookup (Self.Children.all, Adapter_Name, Null_POA_Ref)) then Throw (Error, AdapterAlreadyExists_E, Null_Members'(Null_Member)); Leave (Self.Children_Lock); return; end if; end if; -- Create new object adapter Create (POA.POA_Lock); Create (POA.Children_Lock); Create (POA.Map_Lock); POA.Boot_Time := Self.Boot_Time; POA.Father := POA_Types.Obj_Adapter_Access (Self); POA.Name := +Adapter_Name; if A_POAManager = null then Set (POA.POA_Manager, new Basic_Manager.Basic_POA_Manager); Create (POA_Manager_Of (POA)); Register_POA (POA_Manager_Of (POA), POA_Types.Obj_Adapter_Access (POA)); else Set (POA.POA_Manager, Smart_Pointers.Entity_Ptr (A_POAManager)); Register_POA (A_POAManager, POA_Types.Obj_Adapter_Access (POA)); end if; -- NOTE: POA.Children is initialized iff we -- need it, see the procedure Register_Child for more details. -- Register new obj_adapter as a sibling of the current POA if Self.Children = null then Self.Children := new POATable; Initialize (Self.Children.all); end if; Set (Ref, Smart_Pointers.Entity_Ptr (POA)); Insert (Self.Children.all, POA.Name.all, Ref); Leave (Self.Children_Lock); -- Construct POA Absolute name if Self.Absolute_Address.all'Length > 0 then POA.Absolute_Address := new Standard.String' (Self.Absolute_Address.all & POA_Path_Separator & Adapter_Name); else POA.Absolute_Address := new Standard.String'(Self.Absolute_Address.all & Adapter_Name); end if; pragma Debug (C, O ("Absolute name of new POA is " & POA.Absolute_Address.all)); -- First initialize POA with default policies Init_With_Default_Policies (POA); -- then override POA policies with those given by the user Init_With_User_Policies (POA, Policies); -- Check compatibilities between policies Check_Policies_Compatibility (POA, Error); if Found (Error) then pragma Debug (C, O ("Got Error, destroying POA")); Destroy (POA, Etherealize_Objects => False, Wait_For_Completion => False); return; end if; -- Insert POA into Global_POATable pragma Debug (C, O ("Insert " & POA_Path_Separator & POA.Absolute_Address.all & " into Global_POATable")); Insert (Global_POATable, POA_Path_Separator & POA.Absolute_Address.all, Ref); -- Return the created POA pragma Debug (C, O ("POA " & Adapter_Name & " created.")); end Initialize_POA; ------------- -- Destroy -- ------------- procedure Destroy (Self : access Obj_Adapter; Etherealize_Objects : Types.Boolean; Wait_For_Completion : Types.Boolean) is use PolyORB.Object_Maps; use PolyORB.POA_Types.POA_HTables; procedure Free is new Ada.Unchecked_Deallocation (Object_Map'Class, Object_Map_Access); begin -- We might be finalizing a POA (because of reference counting) -- on which Destroy has already been called (with non-default -- parameters), in which case there is nothing to do. if Self.Name = null then return; end if; pragma Debug (C, O ("Start destroying POA: " & Self.Name.all)); -- Remove Self from Global POA Table pragma Debug (C, O ("Removing POA from Global POA Table")); PolyORB.POA_Types.POA_HTables.Delete (Global_POATable, POA_Path_Separator & Self.Absolute_Address.all); -- Destroy all children if Self.Children /= null and then not Is_Empty (Self.Children.all) then pragma Debug (C, O ("Removing child POAs")); Enter (Self.Children_Lock); declare It : Iterator := First (Self.Children.all); Child_Ref : Obj_Adapter_Ref; Child_Ptr : Obj_Adapter_Access; begin while not Last (It) loop -- Hold a ref on the child while we destroy it to ensure -- that it does not get finalized early. Child_Ref := Value (It); Child_Ptr := Obj_Adapter (Entity_Of (Child_Ref).all)'Access; Destroy (Child_Ptr, Etherealize_Objects, Wait_For_Completion); -- NOTE: The child is detached automatically from the children -- map upon destruction. Next (It); end loop; Finalize (Self.Children.all); Free (Self.Children); Leave (Self.Children_Lock); end; end if; -- Tell father to remove current POA from its list of children if Self.Father /= null then pragma Debug (C, O ("Requesting parent to detach POA: " & Self.Name.all)); POA.Remove_POA_By_Name (POA.Obj_Adapter_Access (Self.Father), Self.Name.all); end if; -- Destroy self (also unregister from the POAManager) pragma Debug (C, O ("About to destroy POA: " & Self.Name.all)); Free (Self.Absolute_Address); Free (Self.Name); -- Destroy POA components if not Is_Nil (Self.POA_Manager) then Remove_POA (POA_Manager_Of (Self), Self.all'Access); Unref (Self.POA_Manager); end if; -- Destroy_Policies (Self.all); -- XXX Cannot destroy_policies here because another -- POA initialised from the default configuration could -- be using the same instances of policy objects! -- XXX if so why don't we make policies a derived type from a -- Smart Pointer ?? -- Destroy Locks -- As Destroy may be called when an exception is raised during OA -- initialization, check for non-null values explicitly. if Self.POA_Lock /= null then Destroy (Self.POA_Lock); end if; if Self.Children_Lock /= null then Destroy (Self.Children_Lock); end if; if Self.Map_Lock /= null then Destroy (Self.Map_Lock); end if; -- These members may be null, test before freeing if Self.Active_Object_Map /= null then Object_Maps.Finalize (Self.Active_Object_Map.all); Free (Self.Active_Object_Map); end if; if Self.Adapter_Activator /= null then Free (Self.Adapter_Activator); end if; if Self.Servant_Manager /= null then Free (Self.Servant_Manager); end if; pragma Debug (C, O ("POA destroyed")); -- XXX Add code for Etherealize_Objects and Wait_For_Completion ??? end Destroy; ---------------------------------- -- Create_Object_Identification -- ---------------------------------- procedure Create_Object_Identification (Self : access Obj_Adapter; Hint : Object_Id_Access; U_Oid : out Unmarshalled_Oid; Error : in out PolyORB.Errors.Error_Container) is begin Assign_Object_Identifier (Self.Id_Assignment_Policy.all, POA_Types.Obj_Adapter_Access (Self), Hint, U_Oid, Error); end Create_Object_Identification; --------------------- -- Activate_Object -- --------------------- procedure Activate_Object (Self : access Obj_Adapter; P_Servant : Servants.Servant_Access; Hint : Object_Id_Access; U_Oid : out Unmarshalled_Oid; Error : in out PolyORB.Errors.Error_Container) is begin pragma Debug (C, O ("Activate_Object: enter")); -- Build a well formed Oid from the 'Hint' provided by the user Assign_Object_Identifier (Self.Id_Assignment_Policy.all, POA_Types.Obj_Adapter_Access (Self), Hint, U_Oid, Error); if Found (Error) then return; end if; Retain_Servant_Association (Self.Servant_Retention_Policy.all, POA_Types.Obj_Adapter_Access (Self), P_Servant, U_Oid, Error); if Found (Error) then return; end if; pragma Debug (C, O ("Activate_Object: leave")); end Activate_Object; ----------------------- -- Deactivate_Object -- ----------------------- procedure Deactivate_Object (Self : access Obj_Adapter; Oid : Object_Id; Error : in out PolyORB.Errors.Error_Container) is U_Oid : Unmarshalled_Oid; begin pragma Debug (C, O ("Deactivate_Object: enter")); Reconstruct_Object_Identifier (Self.Id_Assignment_Policy.all, POA_Types.Obj_Adapter_Access (Self), Oid, U_Oid, Error); if Found (Error) then return; end if; if Self.Servant_Manager /= null and then Self.Servant_Manager.all in ServantActivator'Class then pragma Debug (C, O ("Deactivate_Object: Etherealizing")); declare Activator : aliased ServantActivator'Class := ServantActivator (Self.Servant_Manager.all); Servant : Servants.Servant_Access; begin Id_To_Servant (Self, U_Oid_To_Oid (U_Oid), Servant, Error); if Found (Error) then pragma Debug (C, O ("Deactivate_Object: " & "Failed to retrieve servant")); return; end if; pragma Debug (C, O ("Deactivate_Object: " & "Etherealizing corresponding servant")); Etherealize (Activator'Access, Oid, Self, Servant, Cleanup_In_Progress => True, Remaining_Activations => True ); -- XXX should compute Remaining_Activations value end; end if; pragma Debug (C, O ("Deactivate_Object: Forget_Servant_Association")); Forget_Servant_Association (Self.Servant_Retention_Policy.all, POA_Types.Obj_Adapter_Access (Self), U_Oid, Error); if Found (Error) then return; end if; -- XXX ??? Wait for completion? pragma Debug (C, O ("Deactivate_Object: leave")); end Deactivate_Object; ------------------- -- Servant_To_Id -- ------------------- procedure Servant_To_Id (Self : access Obj_Adapter; P_Servant : Servants.Servant_Access; Oid : out Object_Id_Access; Error : in out PolyORB.Errors.Error_Container) is Temp_Oid, Temp_Oid2 : Object_Id_Access; begin Temp_Oid := Retained_Servant_To_Id (Self.Servant_Retention_Policy.all, POA_Types.Obj_Adapter_Access (Self), P_Servant); Activate_Again (Self.Id_Uniqueness_Policy.all, POA_Types.Obj_Adapter_Access (Self), P_Servant, Temp_Oid, Temp_Oid2, Error); if Found (Error) then return; end if; Oid := Temp_Oid2; if Oid = null then Throw (Error, ServantNotActive_E, Null_Members'(Null_Member)); -- XXX here should also check whether we are in the context of -- executing a dispatched operation on Servant, and if it is the case -- return the 'current' oid (for USE_DEFAULT_SERVANT policy). end if; Object_Identifier (Self.Id_Assignment_Policy.all, Temp_Oid2, Oid, Error); end Servant_To_Id; ------------------- -- Id_To_Servant -- ------------------- procedure Id_To_Servant (Self : access Obj_Adapter; Oid : Object_Id; Servant : out Servants.Servant_Access; Error : in out PolyORB.Errors.Error_Container) is U_Oid : Unmarshalled_Oid; begin Oid_To_U_Oid (Oid, U_Oid, Error); if Found (Error) then return; end if; Ensure_Lifespan (Self.Lifespan_Policy.all, POA_Types.Obj_Adapter_Access (Self), U_Oid, Error); if Found (Error) then return; end if; Id_To_Servant (Self.Request_Processing_Policy.all, POA_Types.Obj_Adapter_Access (Self), U_Oid, Servant, Error); end Id_To_Servant; -------------- -- Find_POA -- -------------- procedure Find_POA (Self : access Obj_Adapter; Name : String; Activate_It : Boolean; POA : out Obj_Adapter_Access; Error : in out PolyORB.Errors.Error_Container) is use PolyORB.POA_Types.POA_HTables; procedure Find_POA_Recursively (Self : access Obj_Adapter; Name : String; Activate_It : Boolean; POA : out Obj_Adapter_Access; Error : in out PolyORB.Errors.Error_Container); -- Looks for 'name', searching from 'Self', using a recursive search. -- If necessary, will invoke AdapterActivator call backs. -------------------------- -- Find_POA_Recursively -- -------------------------- procedure Find_POA_Recursively (Self : access Obj_Adapter; Name : String; Activate_It : Boolean; POA : out Obj_Adapter_Access; Error : in out PolyORB.Errors.Error_Container) is A_Child : Obj_Adapter_Access; Result : Boolean; Split_Point : Integer; begin pragma Debug (C, O ("Find_POA_Recursively: enter, Name = " & Name)); -- Name is null => return Self if Name'Length = 0 then POA := Obj_Adapter_Access (Self); return; end if; Split_Point := PolyORB.Utils.Find (Name, Name'First, POA_Path_Separator); pragma Assert (Split_Point /= Name'First); -- Check Self's children if Self.Children /= null then A_Child := Obj_Adapter_Access (Entity_Of (Lookup (Self.Children.all, Name (Name'First .. Split_Point - 1), Null_POA_Ref))); end if; if A_Child /= null then -- A child corresponds to partial name, follow search Find_POA (Obj_Adapter (A_Child.all)'Access, Name (Split_Point + 1 .. Name'Last), Activate_It, POA, Error); else -- No child corresponds, activate one POA if requested if Activate_It and then Self.Adapter_Activator /= null then Unknown_Adapter (Self.Adapter_Activator, Self, Name (Name'First .. Split_Point - 1), Result, Error); if Found (Error) then return; end if; if not Result then Throw (Error, AdapterNonExistent_E, Null_Member); end if; Find_POA (Self, Name, Activate_It, POA, Error); else POA := null; Throw (Error, AdapterNonExistent_E, Null_Member); end if; end if; end Find_POA_Recursively; begin -- Name is null => return self if Name'Length = 0 then POA := Obj_Adapter_Access (Self); return; end if; -- Then look up name in Global POA Table declare Full_POA_Name : constant String := Self.Absolute_Address.all & POA_Path_Separator & Name; begin pragma Debug (C, O ("Find_POA: enter, Name = " & Full_POA_Name)); POA := PolyORB.POA.Obj_Adapter_Access (Entity_Of (Lookup (Global_POATable, Full_POA_Name, Null_POA_Ref))); if POA /= null then pragma Debug (C, O ("Found POA in Global_POATable")); return; end if; end; -- Then make a recursive look up, activating POA if necessary pragma Debug (C, O ("Looking for " & Name & " recursively")); Find_POA_Recursively (Self, Name, Activate_It, POA, Error); pragma Debug (C, O ("Find_POA: leave")); end Find_POA; ----------------- -- Get_Servant -- ----------------- procedure Get_Servant (Self : access Obj_Adapter; Servant : out Servants.Servant_Access; Error : in out PolyORB.Errors.Error_Container) is begin Get_Servant (Self.Request_Processing_Policy.all, POA_Types.Obj_Adapter_Access (Self), Servant, Error); end Get_Servant; ----------------- -- Set_Servant -- ----------------- procedure Set_Servant (Self : access Obj_Adapter; Servant : Servants.Servant_Access; Error : in out PolyORB.Errors.Error_Container) is begin Set_Servant (Self.Request_Processing_Policy.all, POA_Types.Obj_Adapter_Access (Self), Servant, Error); end Set_Servant; ------------------------- -- Get_Servant_Manager -- ------------------------- procedure Get_Servant_Manager (Self : access Obj_Adapter; Manager : out ServantManager_Access; Error : in out PolyORB.Errors.Error_Container) is begin Ensure_Servant_Manager (Self.Request_Processing_Policy.all, Error); if Found (Error) then return; end if; Manager := Self.Servant_Manager; end Get_Servant_Manager; ------------------------- -- Set_Servant_Manager -- ------------------------- procedure Set_Servant_Manager (Self : access Obj_Adapter; Manager : ServantManager_Access; Error : in out PolyORB.Errors.Error_Container) is begin Ensure_Servant_Manager (Self.Request_Processing_Policy.all, Error); if Found (Error) then return; end if; Ensure_Servant_Manager_Type (Self.Servant_Retention_Policy.all, Manager.all, Error); Self.Servant_Manager := Manager; end Set_Servant_Manager; ---------------------- -- Get_The_Children -- ---------------------- procedure Get_The_Children (Self : access Obj_Adapter; Children : out POAList) is use PolyORB.POA_Types.POA_HTables; begin pragma Debug (C, O ("Get_The_Children: enter")); if Self.Children /= null and then not Is_Empty (Self.Children.all) then PolyORB.Tasking.Mutexes.Enter (Self.Children_Lock); pragma Debug (C, O ("Iterate over existing children")); declare It : Iterator := First (Self.Children.all); begin while not Last (It) loop POA_Lists.Append (Children, Value (It)); Next (It); end loop; end; PolyORB.Tasking.Mutexes.Leave (Self.Children_Lock); end if; pragma Debug (C, O ("Get_The_Children: end")); end Get_The_Children; ---------------------- -- Copy_Obj_Adapter -- ---------------------- procedure Copy_Obj_Adapter (From : Obj_Adapter; To : access Obj_Adapter) is begin Enter (From.POA_Lock); Enter (To.POA_Lock); To.Name := From.Name; To.POA_Manager := From.POA_Manager; To.Boot_Time := From.Boot_Time; To.Absolute_Address := From.Absolute_Address; To.Active_Object_Map := From.Active_Object_Map; To.Thread_Policy := From.Thread_Policy; To.Request_Processing_Policy := From.Request_Processing_Policy; To.Id_Assignment_Policy := From.Id_Assignment_Policy; To.Id_Uniqueness_Policy := From.Id_Uniqueness_Policy; To.Servant_Retention_Policy := From.Servant_Retention_Policy; To.Lifespan_Policy := From.Lifespan_Policy; To.Implicit_Activation_Policy := From.Implicit_Activation_Policy; To.Father := From.Father; To.Children := From.Children; To.Children_Lock := From.Children_Lock; To.Map_Lock := From.Map_Lock; Leave (From.POA_Lock); Leave (To.POA_Lock); end Copy_Obj_Adapter; ------------------------ -- Remove_POA_By_Name -- ------------------------ procedure Remove_POA_By_Name (Self : access Obj_Adapter; Child_Name : Standard.String) is begin pragma Debug (C, O (Self.Name.all & ": removing POA with name " & Child_Name & " from my children.")); PolyORB.POA_Types.POA_HTables.Delete (Self.Children.all, Child_Name); end Remove_POA_By_Name; -------------------------------------------------- -- PolyORB Obj_Adapter interface implementation -- -------------------------------------------------- ------------ -- Create -- ------------ procedure Create (OA : access Obj_Adapter) is begin Create_Root_POA (OA); end Create; ------------- -- Destroy -- ------------- procedure Destroy (OA : access Obj_Adapter) is begin Destroy (OA, Etherealize_Objects => True, Wait_For_Completion => True); Obj_Adapters.Destroy (Obj_Adapters.Obj_Adapter (OA.all)'Access); end Destroy; ------------ -- Export -- ------------ procedure Export (OA : access Obj_Adapter; Obj : Servants.Servant_Access; Key : Objects.Object_Id_Access; Oid : out Objects.Object_Id_Access; Error : in out PolyORB.Errors.Error_Container) is begin -- NOTE: Per construction, this procedure has the same semantics as -- Servant_To_Ref CORBA procedure. -- First find out whether we have retained a previous -- association for this servant. -- NOTE: Per construction, we can retain an Id iff we are using -- UNIQUE Id_Uniqueness policy and RETAIN Servant_Retention -- policy. Thus, a non null Oid implies we are using this two -- policies. There is no need to test them. -- XXX complete explanation Oid := Retained_Servant_To_Id (Self => OA.Servant_Retention_Policy.all, OA => POA_Types.Obj_Adapter_Access (OA), P_Servant => Obj); if Oid /= null then return; end if; Implicit_Activate_Servant (Self => OA.Implicit_Activation_Policy.all, OA => POA_Types.Obj_Adapter_Access (OA), P_Servant => Obj, Hint => Key, Oid => Oid, Error => Error); end Export; -------------- -- Unexport -- -------------- procedure Unexport (OA : access Obj_Adapter; Id : Objects.Object_Id_Access; Error : in out PolyORB.Errors.Error_Container) is begin Deactivate_Object (OA, Id.all, Error); end Unexport; ---------------- -- Object_Key -- ---------------- procedure Object_Key (OA : access Obj_Adapter; Id : Objects.Object_Id_Access; User_Id : out Objects.Object_Id_Access; Error : in out PolyORB.Errors.Error_Container) is pragma Warnings (Off); pragma Unreferenced (OA); pragma Warnings (On); U_Oid : Unmarshalled_Oid; begin Oid_To_U_Oid (Id.all, U_Oid, Error); if Found (Error) then return; end if; if U_Oid.System_Generated then Throw (Error, Invalid_Object_Id_E, Null_Members'(Null_Member)); else User_Id := new Objects.Object_Id' (Objects.Hex_String_To_Oid (To_Standard_String (U_Oid.Id))); end if; end Object_Key; ------------- -- Get_QoS -- ------------- procedure Get_QoS (OA : access Obj_Adapter; Id : Objects.Object_Id; QoS : out PolyORB.QoS.QoS_Parameters; Error : in out PolyORB.Errors.Error_Container) is Obj_OA : PolyORB.POA.Obj_Adapter_Access; begin Find_POA (OA, Get_Creator (Id), True, Obj_OA, Error); if Found (Error) then return; end if; QoS := PolyORB.Obj_Adapter_QoS.Get_Object_Adapter_QoS (Obj_OA); end Get_QoS; ------------------------ -- Get_Empty_Arg_List -- ------------------------ function Get_Empty_Arg_List (OA : access Obj_Adapter; Oid : access Objects.Object_Id; Method : String) return Any.NVList.Ref is pragma Warnings (Off); pragma Unreferenced (OA, Oid, Method); pragma Warnings (On); -- S : Servants.Servant_Access; Nil_Result : Any.NVList.Ref; begin -- pragma Debug (C, O ("Get_Empty_Arg_List for Id " -- & Objects.To_String (Oid.all))); -- S := Servants.Servant_Access (Find_Servant (OA, Oid, NO_CHECK)); -- if S.If_Desc.PP_Desc /= null then -- return S.If_Desc.PP_Desc (Method); -- else return Nil_Result; -- -- If If_Desc is null (eg in the case of an actual -- -- use of the DSI, where no generated code is used on -- -- the server side, another means of determining the -- -- signature must be used, eg a query to an -- -- Interface repository. Here we only return a Nil -- -- NVList.Ref, indicating to the Protocol layer -- -- that arguments unmarshalling is to be deferred -- -- until the request processing in the Application -- -- layer is started (at which time the Application -- -- layer can provide more information as to the -- -- signature of the called method). -- end if; -- XXX Actually, the code above shows that the generic -- POA implementation does not manage a per-servant -- If_Desc at all. If such functionality is desired, -- it should be implemented as an annotation on the -- generic Servants.Servant type (or else -- the generic servant type could contain a -- If_Descriptors.If_Descriptor_Access, where -- applicable. end Get_Empty_Arg_List; ---------------------- -- Get_Empty_Result -- ---------------------- function Get_Empty_Result (OA : access Obj_Adapter; Oid : access Objects.Object_Id; Method : String) return Any.Any is -- S : Servants.Servant_Access; begin -- pragma Debug (C, O ("Get_Empty_Result for Id " -- & Objects.To_String (Oid.all))); -- S := Servants.Servant_Access (Find_Servant (OA, Oid, NO_CHECK)); -- if S.If_Desc.RP_Desc /= null then -- return S.If_Desc.RP_Desc (Method); -- end if; raise Program_Error; pragma Warnings (Off); return Get_Empty_Result (OA, Oid, Method); pragma Warnings (On); -- Cf. comment above end Get_Empty_Result; ------------------ -- Find_Servant -- ------------------ procedure Find_Servant (OA : access Obj_Adapter; Id : access Objects.Object_Id; Servant : out Servants.Servant_Access; Error : in out PolyORB.Errors.Error_Container) is begin Find_Servant (OA, Id, True, Servant, Error); end Find_Servant; procedure Find_Servant (OA : access Obj_Adapter; Id : access Objects.Object_Id; Do_Check : Boolean; Servant : out Servants.Servant_Access; Error : in out PolyORB.Errors.Error_Container) is use type PolyORB.Servants.Servant_Access; Obj_OA : Obj_Adapter_Access; begin pragma Debug (C, O ("Find_Servant: Enter.")); Find_POA (OA, Get_Creator (Id.all), True, Obj_OA, Error); if Found (Error) then return; end if; if Obj_OA = null then Throw (Error, Object_Not_Exist_E, System_Exception_Members'(Minor => 0, Completed => Completed_No)); return; end if; Enter (Obj_OA.POA_Lock); -- Check POA Manager state if Do_Check then case Get_State (POA_Manager_Of (Obj_OA).all) is when DISCARDING | INACTIVE => -- XXX Do we have to do something special for INACTIVE ??? Throw (Error, Transient_E, System_Exception_Members'(Minor => 0, Completed => Completed_No)); Leave (Obj_OA.POA_Lock); return; when HOLDING => Servant := Get_Hold_Servant (POA_Manager_Of (Obj_OA), POA_Types.Obj_Adapter_Access (Obj_OA)); Servants.Set_Executor (Servant, Executor (Obj_OA.Thread_Policy)); Leave (Obj_OA.POA_Lock); return; when others => null; end case; end if; -- Find servant pragma Debug (C, O ("OA : " & Obj_OA.Name.all & " looks for servant associated with Id " & Objects.Oid_To_Hex_String (Id.all))); Id_To_Servant (Obj_OA, Id.all, Servant, Error); Leave (Obj_OA.POA_Lock); if Found (Error) then return; end if; -- Servant not found, we try to activate one, if POA policies allow it if Servant = null and then Obj_OA.Servant_Manager /= null and then Obj_OA.Servant_Manager.all in ServantActivator'Class then pragma Debug (C, O ("Try to activate one servant !")); declare Activator : aliased ServantActivator'Class := ServantActivator (Obj_OA.Servant_Manager.all); Oid : Objects.Object_Id_Access; begin Object_Identifier (Obj_OA.Id_Assignment_Policy.all, Objects.Object_Id_Access (Id), Oid, Error); if Found (Error) then return; end if; Incarnate (Activator'Access, Oid.all, Obj_OA, Servant, Error); Free (Oid); if Found (Error) then pragma Assert (Error.Kind = ForwardRequest_E); return; end if; end; end if; if Servant = null then Throw (Error, Object_Not_Exist_E, System_Exception_Members'(Minor => 0, Completed => Completed_No)); return; end if; Servants.Set_Executor (Servant, Executor (OA.Thread_Policy)); pragma Debug (C, O ("Find_Servant: Leave.")); end Find_Servant; --------------------- -- Release_Servant -- --------------------- procedure Release_Servant (OA : access Obj_Adapter; Id : access Objects.Object_Id; Servant : in out Servants.Servant_Access) is pragma Warnings (Off); pragma Unreferenced (OA); pragma Unreferenced (Id); pragma Unreferenced (Servant); pragma Warnings (On); begin null; -- XXX if servant has been created on the fly, should -- destroy it now (else do nothing). end Release_Servant; end PolyORB.POA; polyorb-2.8~20110207.orig/src/polyorb-services-naming-namingcontext-helper.ads0000644000175000017500000001167011750740340026576 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- POLYORB.SERVICES.NAMING.NAMINGCONTEXT.HELPER -- -- -- -- S p e c -- -- -- -- Copyright (C) 2002-2007, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with PolyORB.Any; package PolyORB.Services.Naming.NamingContext.Helper is pragma Elaborate_Body; function Unchecked_To_Ref (The_Ref : PolyORB.References.Ref) return PolyORB.Services.Naming.NamingContext.Ref; function To_Ref (The_Ref : PolyORB.References.Ref) return PolyORB.Services.Naming.NamingContext.Ref; -- NamingContext type TC_NamingContext : PolyORB.Any.TypeCode.Local_Ref; function From_Any (Item : PolyORB.Any.Any) return NamingContext.Ref; function To_Any (Item : NamingContext.Ref) return PolyORB.Any.Any; -- NotFound exception TC_NotFoundReason : PolyORB.Any.TypeCode.Local_Ref; function From_Any (Item : PolyORB.Any.Any) return NamingContext.NotFoundReason; function To_Any (Item : NamingContext.NotFoundReason) return PolyORB.Any.Any; TC_NotFound : PolyORB.Any.TypeCode.Local_Ref; function From_Any (Item : PolyORB.Any.Any) return NamingContext.NotFound_Members; function To_Any (Item : NamingContext.NotFound_Members) return PolyORB.Any.Any; procedure Raise_NotFound_From_Any (Item : PolyORB.Any.Any; Message : Standard.String); pragma No_Return (Raise_NotFound_From_Any); -- CannotProceed exception TC_CannotProceed : PolyORB.Any.TypeCode.Local_Ref; function From_Any (Item : PolyORB.Any.Any) return NamingContext.CannotProceed_Members; function To_Any (Item : NamingContext.CannotProceed_Members) return PolyORB.Any.Any; procedure Raise_CannotProceed_From_Any (Item : PolyORB.Any.Any; Message : Standard.String); pragma No_Return (Raise_CannotProceed_From_Any); -- InvalidName exception TC_InvalidName : PolyORB.Any.TypeCode.Local_Ref; function From_Any (Item : PolyORB.Any.Any) return NamingContext.InvalidName_Members; function To_Any (Item : NamingContext.InvalidName_Members) return PolyORB.Any.Any; procedure Raise_InvalidName_From_Any (Item : PolyORB.Any.Any; Message : Standard.String); pragma No_Return (Raise_InvalidName_From_Any); -- AlreadyBound exception TC_AlreadyBound : PolyORB.Any.TypeCode.Local_Ref; function From_Any (Item : PolyORB.Any.Any) return NamingContext.AlreadyBound_Members; function To_Any (Item : NamingContext.AlreadyBound_Members) return PolyORB.Any.Any; procedure Raise_AlreadyBound_From_Any (Item : PolyORB.Any.Any; Message : Standard.String); pragma No_Return (Raise_AlreadyBound_From_Any); -- NotEmpty exception TC_NotEmpty : PolyORB.Any.TypeCode.Local_Ref; function From_Any (Item : PolyORB.Any.Any) return NamingContext.NotEmpty_Members; function To_Any (Item : NamingContext.NotEmpty_Members) return PolyORB.Any.Any; procedure Raise_NotEmpty_From_Any (Item : PolyORB.Any.Any; Message : Standard.String); pragma No_Return (Raise_NotEmpty_From_Any); end PolyORB.Services.Naming.NamingContext.Helper; polyorb-2.8~20110207.orig/src/polyorb-poa_policies-lifespan_policy-transient.ads0000644000175000017500000000564511750740340027211 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- POLYORB.POA_POLICIES.LIFESPAN_POLICY.TRANSIENT -- -- -- -- S p e c -- -- -- -- Copyright (C) 2001-2005 Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ package PolyORB.POA_Policies.Lifespan_Policy.Transient is type Transient_Policy is new LifespanPolicy with null record; type Transient_Policy_Access is access all Transient_Policy; function Create return Transient_Policy_Access; procedure Check_Compatibility (Self : Transient_Policy; Other_Policies : AllPolicies; Error : in out PolyORB.Errors.Error_Container); function Policy_Id (Self : Transient_Policy) return String; function Get_Lifespan_Cookie (Self : Transient_Policy; OA : PolyORB.POA_Types.Obj_Adapter_Access) return Lifespan_Cookie; procedure Ensure_Lifespan (Self : Transient_Policy; OA : PolyORB.POA_Types.Obj_Adapter_Access; U_Oid : Unmarshalled_Oid; Error : in out PolyORB.Errors.Error_Container); end PolyORB.POA_Policies.Lifespan_Policy.Transient; polyorb-2.8~20110207.orig/src/polyorb-poa_policies-id_uniqueness_policy-multiple.adb0000644000175000017500000001103611750740340030055 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- POLYORB.POA_POLICIES.ID_UNIQUENESS_POLICY.MULTIPLE -- -- -- -- B o d y -- -- -- -- Copyright (C) 2002-2005 Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with PolyORB.POA; package body PolyORB.POA_Policies.Id_Uniqueness_Policy.Multiple is ------------ -- Create -- ------------ function Create return Multiple_Id_Policy_Access is begin return new Multiple_Id_Policy; end Create; ------------------------- -- Check_Compatibility -- ------------------------- procedure Check_Compatibility (Self : Multiple_Id_Policy; Other_Policies : AllPolicies; Error : in out PolyORB.Errors.Error_Container) is pragma Warnings (Off); pragma Unreferenced (Self, Other_Policies, Error); pragma Warnings (On); begin null; -- No rule to test. end Check_Compatibility; --------------- -- Policy_Id -- --------------- function Policy_Id (Self : Multiple_Id_Policy) return String is pragma Warnings (Off); pragma Unreferenced (Self); pragma Warnings (On); begin return "ID_UNIQUENESS_POLICY.MULTIPLE_ID"; end Policy_Id; ------------------------------- -- Ensure_Servant_Uniqueness -- ------------------------------- procedure Ensure_Servant_Uniqueness (Self : Multiple_Id_Policy; OA : PolyORB.POA_Types.Obj_Adapter_Access; P_Servant : Servants.Servant_Access; Error : in out PolyORB.Errors.Error_Container) is pragma Warnings (Off); pragma Unreferenced (Self, OA, P_Servant, Error); pragma Warnings (On); begin null; -- MULTIPLE_ID: nothing to do. end Ensure_Servant_Uniqueness; -------------------- -- Activate_Again -- -------------------- procedure Activate_Again (Self : Multiple_Id_Policy; OA : PolyORB.POA_Types.Obj_Adapter_Access; P_Servant : Servants.Servant_Access; Oid : Object_Id_Access; Result : out Object_Id_Access; Error : in out PolyORB.Errors.Error_Container) is pragma Warnings (Off); pragma Unreferenced (Self); pragma Warnings (On); U_Oid : Unmarshalled_Oid; begin PolyORB.POA.Activate_Object (PolyORB.POA.Obj_Adapter_Access (OA), P_Servant, Oid, U_Oid, Error); -- Activate servant again, regardless of its current -- activation state. if PolyORB.Errors.Found (Error) then return; end if; Result := U_Oid_To_Oid (U_Oid); end Activate_Again; end PolyORB.POA_Policies.Id_Uniqueness_Policy.Multiple; polyorb-2.8~20110207.orig/src/polyorb-std.ads0000644000175000017500000000471511750740340020147 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . S T D -- -- -- -- S p e c -- -- -- -- Copyright (C) 2007, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- Renaming of Standard for use by generated code, to avoid name clashes -- package PolyORB.Std renames Standard; -- WAG:61 does not work currently package PolyORB.Std is pragma Pure; subtype String is Standard.String; subtype Boolean is Standard.Boolean; subtype Integer is Standard.Integer; subtype Natural is Standard.Natural; subtype Positive is Standard.Positive; package Ascii renames Standard.Ascii; end PolyORB.Std; polyorb-2.8~20110207.orig/src/polyorb-any-initialization.adb0000644000175000017500000000533211750740340023144 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . A N Y . I N I T I A L I Z A T I O N -- -- -- -- B o d y -- -- -- -- Copyright (C) 2004-2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- Initialization code for PolyORB.Any with PolyORB.Initialization; with PolyORB.Utils.Strings; package body PolyORB.Any.Initialization is ---------------- -- Initialize -- ---------------- procedure Initialize; procedure Initialize is begin PolyORB.Any.TypeCode.Initialize; end Initialize; use PolyORB.Initialization; use PolyORB.Initialization.String_Lists; use PolyORB.Utils.Strings; begin Register_Module (Module_Info' (Name => +"any", Conflicts => Empty, Depends => +"smart_pointers", Provides => Empty, Implicit => False, Init => Initialize'Access, Shutdown => null)); end PolyORB.Any.Initialization; polyorb-2.8~20110207.orig/src/polyorb-tasking-profiles-full_tasking-condition_variables.adb0000644000175000017500000001565511750740340031316 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- POLYORB.TASKING.PROFILES.FULL_TASKING.CONDITION_VARIABLES -- -- -- -- B o d y -- -- -- -- Copyright (C) 2002-2011, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- Implementation of condition variables under the Full_Tasking profile. with Ada.Unchecked_Deallocation; with PolyORB.Initialization; with PolyORB.Log; with PolyORB.Utils.Strings; package body PolyORB.Tasking.Profiles.Full_Tasking.Condition_Variables is use PolyORB.Log; package L is new PolyORB.Log.Facility_Log ("polyorb.tasking.profiles.full_tasking.condition_variables"); procedure O (Message : String; Level : Log_Level := Debug) renames L.Output; function C (Level : Log_Level := Debug) return Boolean renames L.Enabled; ----------------------------------------------------------------- -- Underlying protected object for Full_Tasking_Condition_Type -- ----------------------------------------------------------------- protected type Condition_PO is entry Release_Then_Wait (M : PTM.Mutex_Access); -- Atomically release mutex M, then requeue on Wait entry Wait; -- Real wait entry Signal; -- Real implementation of Signal entry Broadcast; -- Real implementation of Broadcast private To_Free : Natural := 0; -- Number of remaining tasks in the queue that must be freed end Condition_PO; ------------------ -- Condition_PO -- ------------------ protected body Condition_PO is --------------- -- Broadcast -- --------------- entry Broadcast when To_Free = 0 is begin To_Free := Condition_PO.Wait'Count; pragma Debug (C, O ("Broadcast: will release:" & Natural'Image (To_Free) & " tasks.")); end Broadcast; ------------ -- Signal -- ------------ entry Signal when To_Free = 0 is begin if Condition_PO.Wait'Count /= 0 then To_Free := 1; end if; pragma Debug (C, O ("Signal.")); end Signal; ----------------------- -- Release_Then_Wait -- ----------------------- entry Release_Then_Wait (M : PTM.Mutex_Access) when True is begin PTM.Leave (M); requeue Condition_PO.Wait with abort; end Release_Then_Wait; ---------- -- Wait -- ---------- entry Wait when To_Free > 0 is begin To_Free := To_Free - 1; end Wait; end Condition_PO; --------------- -- Broadcast -- --------------- procedure Broadcast (Cond : access Full_Tasking_Condition_Type) is begin Cond.The_PO.Broadcast; end Broadcast; ------------ -- Create -- ------------ function Create (MF : access Full_Tasking_Condition_Factory_Type; Name : String := "") return PTCV.Condition_Access is pragma Warnings (Off); pragma Unreferenced (MF); pragma Unreferenced (Name); -- XXX The use of Name is not yet implemented pragma Warnings (On); Cond : constant Full_Tasking_Condition_Access := new Full_Tasking_Condition_Type; begin pragma Debug (C, O ("Create")); Cond.The_PO := new Condition_PO; return PTCV.Condition_Access (Cond); end Create; ------------- -- Destroy -- ------------- procedure Free is new Ada.Unchecked_Deallocation (PTCV.Condition_Type'Class, PTCV.Condition_Access); procedure Free is new Ada.Unchecked_Deallocation (Condition_PO, Condition_PO_Access); procedure Destroy (MF : access Full_Tasking_Condition_Factory_Type; Cond : in out PTCV.Condition_Access) is pragma Warnings (Off); pragma Unreferenced (MF); pragma Warnings (On); begin pragma Debug (C, O ("Destroy")); Free (Full_Tasking_Condition_Access (Cond).The_PO); Free (Cond); end Destroy; ------------ -- Signal -- ------------ procedure Signal (Cond : access Full_Tasking_Condition_Type) is begin Cond.The_PO.Signal; end Signal; ---------- -- Wait -- ---------- procedure Wait (Cond : access Full_Tasking_Condition_Type; M : access PTM.Mutex_Type'Class) is begin pragma Debug (C, O ("Wait: enter")); Cond.The_PO.Release_Then_Wait (PTM.Mutex_Access (M)); pragma Debug (C, O ("Wait: leave")); PTM.Enter (M); end Wait; ---------------- -- Initialize -- ---------------- procedure Initialize; procedure Initialize is begin PTCV.Register_Condition_Factory (PTCV.Condition_Factory_Access (The_Condition_Factory)); end Initialize; use PolyORB.Initialization; use PolyORB.Initialization.String_Lists; use PolyORB.Utils.Strings; begin Register_Module (Module_Info' (Name => +"tasking.profiles.full_tasking.condition_variables", Conflicts => Empty, Depends => Empty, Provides => +"tasking.condition_variables", Implicit => False, Init => Initialize'Access, Shutdown => null)); end PolyORB.Tasking.Profiles.Full_Tasking.Condition_Variables; polyorb-2.8~20110207.orig/src/polyorb-obj_adapters-group_object_adapter.ads0000644000175000017500000001317011750740340026165 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- POLYORB.OBJ_ADAPTERS.GROUP_OBJECT_ADAPTER -- -- -- -- S p e c -- -- -- -- Copyright (C) 2001-2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- Special Object Adapter to manage group servants with PolyORB.Any; with PolyORB.Any.NVList; with PolyORB.Errors; with PolyORB.Objects; with PolyORB.Servants; with PolyORB.Tasking.Mutexes; with PolyORB.Utils.HTables.Perfect; with PolyORB.Utils.HFunctions.Hyper; with PolyORB.References; package PolyORB.Obj_Adapters.Group_Object_Adapter is -------------------------- -- Group_Object_Adapter -- -------------------------- type Group_Object_Adapter is new Obj_Adapter with private; type Group_Object_Adapter_Access is access all Group_Object_Adapter'Class; procedure Create (GOA : access Group_Object_Adapter); procedure Destroy (GOA : access Group_Object_Adapter); -------------------------------------- -- Interface to application objects -- -------------------------------------- procedure Export (GOA : access Group_Object_Adapter; Obj : Servants.Servant_Access; Key : Objects.Object_Id_Access; Oid : out Objects.Object_Id_Access; Error : in out PolyORB.Errors.Error_Container); procedure Unexport (GOA : access Group_Object_Adapter; Id : Objects.Object_Id_Access; Error : in out PolyORB.Errors.Error_Container); procedure Object_Key (GOA : access Group_Object_Adapter; Id : Objects.Object_Id_Access; User_Id : out Objects.Object_Id_Access; Error : in out PolyORB.Errors.Error_Container); procedure Get_QoS (OA : access Group_Object_Adapter; Id : Objects.Object_Id; QoS : out PolyORB.QoS.QoS_Parameters; Error : in out PolyORB.Errors.Error_Container); ---------------------------------------------------- -- Interface to ORB (acting on behalf of clients) -- ---------------------------------------------------- function Get_Empty_Arg_List (GOA : access Group_Object_Adapter; Oid : access Objects.Object_Id; Method : String) return Any.NVList.Ref; function Get_Empty_Result (GOA : access Group_Object_Adapter; Oid : access Objects.Object_Id; Method : String) return Any.Any; procedure Find_Servant (GOA : access Group_Object_Adapter; Id : access Objects.Object_Id; Servant : out Servants.Servant_Access; Error : in out PolyORB.Errors.Error_Container); procedure Release_Servant (GOA : access Group_Object_Adapter; Id : access Objects.Object_Id; Servant : in out Servants.Servant_Access); ------------------------------ -- Group Servant Management -- ------------------------------ function Get_Group (The_Ref : PolyORB.References.Ref; Allow_Group_Creation : Boolean := False) return PolyORB.Servants.Servant_Access; -- Search for a group. If Allow_Group_Creation is true and the -- group is not found, create and register the group. private package Perfect_Htable is new PolyORB.Utils.HTables.Perfect (PolyORB.Servants.Servant_Access, PolyORB.Utils.HFunctions.Hyper.Hash_Hyper_Parameters, PolyORB.Utils.HFunctions.Hyper.Default_Hash_Parameters, PolyORB.Utils.HFunctions.Hyper.Hash, PolyORB.Utils.HFunctions.Hyper.Next_Hash_Parameters); use Perfect_Htable; subtype Simple_Executor is Servants.Executor; type Group_Object_Adapter is new Obj_Adapter with record Lock : PolyORB.Tasking.Mutexes.Mutex_Access; -- Mutex Registered_Groups : Table_Instance; -- List of registered groups S_Exec : aliased Simple_Executor; end record; end PolyORB.Obj_Adapters.Group_Object_Adapter; polyorb-2.8~20110207.orig/src/polyorb-poa_config-proxies.adb0000644000175000017500000001015411750740340023121 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . P O A _ C O N F I G . P R O X I E S -- -- -- -- B o d y -- -- -- -- Copyright (C) 2002-2003 Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by ACT Europe. -- -- (email: sales@act-europe.fr) -- -- -- ------------------------------------------------------------------------------ -- A POA configuration for the Proxy-objects-subPOA. with PolyORB.POA_Policies; with PolyORB.POA_Policies.Id_Assignment_Policy.User; with PolyORB.POA_Policies.Id_Uniqueness_Policy.Multiple; with PolyORB.POA_Policies.Implicit_Activation_Policy.No_Activation; with PolyORB.POA_Policies.Lifespan_Policy.Persistent; with PolyORB.POA_Policies.Request_Processing_Policy.Use_Default_Servant; with PolyORB.POA_Policies.Servant_Retention_Policy.Non_Retain; with PolyORB.POA_Policies.Thread_Policy.ORB_Ctrl; package body PolyORB.POA_Config.Proxies is use PolyORB.POA_Policies; My_Default_Policies : PolicyList; Initialized : Boolean := False; ---------------- -- Initialize -- ---------------- procedure Initialize (C : Configuration) is pragma Warnings (Off); pragma Unreferenced (C); pragma Warnings (On); use PolyORB.POA_Policies.Policy_Lists; begin if Initialized then return; end if; Append (My_Default_Policies, Policy_Access (Id_Assignment_Policy.User.Create)); Append (My_Default_Policies, Policy_Access (Id_Uniqueness_Policy.Multiple.Create)); Append (My_Default_Policies, Policy_Access (Implicit_Activation_Policy.No_Activation.Create)); Append (My_Default_Policies, Policy_Access (Lifespan_Policy.Persistent.Create)); Append (My_Default_Policies, Policy_Access (Request_Processing_Policy.Use_Default_Servant.Create)); Append (My_Default_Policies, Policy_Access (Servant_Retention_Policy.Non_Retain.Create)); Append (My_Default_Policies, Policy_Access (Thread_Policy.ORB_Ctrl.Create)); Initialized := True; end Initialize; ---------------------- -- Default_Policies -- ---------------------- function Default_Policies (C : Configuration) return PolyORB.POA_Policies.PolicyList is begin if not Initialized then Initialize (C); end if; return My_Default_Policies; end Default_Policies; end PolyORB.POA_Config.Proxies; polyorb-2.8~20110207.orig/src/polyorb-tasking-profiles-no_tasking.ads0000644000175000017500000000442711750740340024770 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . T A S K I N G . P R O F I L E S . N O _ T A S K I N G -- -- -- -- S p e c -- -- -- -- Copyright (C) 2002 Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by ACT Europe. -- -- (email: sales@act-europe.fr) -- -- -- ------------------------------------------------------------------------------ -- Base package for the No_Tasking implementation of PolyORB.Tasking. -- This children of this package must compile under GNAT High -- Integrity profile. package PolyORB.Tasking.Profiles.No_Tasking is pragma Preelaborate; end PolyORB.Tasking.Profiles.No_Tasking; polyorb-2.8~20110207.orig/src/polyorb-services-naming-namingcontext-client.adb0000644000175000017500000005426011750740340026556 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- POLYORB.SERVICES.NAMING.NAMINGCONTEXT.CLIENT -- -- -- -- B o d y -- -- -- -- Copyright (C) 2002-2007, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- with PolyORB.Services.Naming.BindingIterator; -- with PolyORB.Services.Naming.BindingIterator.Helper; with PolyORB.Services.Naming.NamingContext.Helper; with PolyORB.Services.Naming.Helper; with PolyORB.Types; with PolyORB.Requests; with PolyORB.Any; with PolyORB.Any.ExceptionList; with PolyORB.Any.NVList; with PolyORB.Any.ObjRef; with PolyORB.Exceptions; package body PolyORB.Services.Naming.NamingContext.Client is use PolyORB.Any; use PolyORB.Any.ExceptionList; use PolyORB.Any.NVList; use PolyORB.Any.ObjRef; use PolyORB.Types; -- use PolyORB.Services.Naming.BindingIterator; use PolyORB.Services.Naming.Helper; use PolyORB.Services.Naming.NamingContext.Helper; Result_Name : constant PolyORB.Types.String := To_PolyORB_String ("Result"); ---------- -- Bind -- ---------- procedure Bind (Self : PolyORB.Services.Naming.NamingContext.Ref; N : Name; Obj : PolyORB.References.Ref) is Arg_Name_N : constant PolyORB.Types.Identifier := PolyORB.Types.To_PolyORB_String ("n"); Argument_N : constant PolyORB.Any.Any := To_Any (N); Arg_Name_Obj : constant PolyORB.Types.Identifier := PolyORB.Types.To_PolyORB_String ("obj"); Argument_Obj : constant PolyORB.Any.Any := PolyORB.Services.Naming.Helper.To_Any (Obj); Operation_Name : constant Standard.String := "bind"; Request : PolyORB.Requests.Request_Access; Arg_List : PolyORB.Any.NVList.Ref; Excp_List : PolyORB.Any.ExceptionList.Ref; Result : PolyORB.Any.NamedValue; begin -- Create argument list PolyORB.Any.NVList.Create (Arg_List); PolyORB.Any.NVList.Add_Item (Arg_List, Arg_Name_N, Argument_N, PolyORB.Any.ARG_IN); PolyORB.Any.NVList.Add_Item (Arg_List, Arg_Name_Obj, Argument_Obj, PolyORB.Any.ARG_IN); -- Create exceptions list Create_List (Excp_List); Add (Excp_List, TC_NotFound); Add (Excp_List, TC_CannotProceed); Add (Excp_List, TC_InvalidName); Add (Excp_List, TC_AlreadyBound); -- Set result type (maybe void) Result := (Name => PolyORB.Types.Identifier (Result_Name), Argument => Get_Empty_Any (PolyORB.Any.TypeCode.TC_Void), Arg_Modes => 0); PolyORB.Requests.Create_Request (Target => PolyORB.References.Ref (Self), Operation => Operation_Name, Arg_List => Arg_List, Result => Result, Exc_List => Excp_List, Req => Request); PolyORB.Requests.Invoke (Request); if not Is_Empty (Request.Exception_Info) then PolyORB.Exceptions.Default_Raise_From_Any (Request.Exception_Info); end if; PolyORB.Requests.Destroy_Request (Request); -- Request has been synchronously invoked end Bind; ------------ -- Rebind -- ------------ procedure Rebind (Self : PolyORB.Services.Naming.NamingContext.Ref; N : Name; Obj : PolyORB.References.Ref) is Arg_Name_n : constant PolyORB.Types.Identifier := PolyORB.Types.To_PolyORB_String ("n"); Argument_n : constant PolyORB.Any.Any := To_Any (N); Arg_Name_obj : constant PolyORB.Types.Identifier := PolyORB.Types.To_PolyORB_String ("obj"); Argument_obj : constant PolyORB.Any.Any := PolyORB.Services.Naming.Helper.To_Any (Obj); Operation_Name : constant Standard.String := "rebind"; Request : PolyORB.Requests.Request_Access; Arg_List : PolyORB.Any.NVList.Ref; Excp_List : PolyORB.Any.ExceptionList.Ref; Result : PolyORB.Any.NamedValue; begin -- Create argument list PolyORB.Any.NVList.Create (Arg_List); PolyORB.Any.NVList.Add_Item (Arg_List, Arg_Name_n, Argument_n, PolyORB.Any.ARG_IN); PolyORB.Any.NVList.Add_Item (Arg_List, Arg_Name_obj, Argument_obj, PolyORB.Any.ARG_IN); -- Create exceptions list Create_List (Excp_List); Add (Excp_List, TC_NotFound); Add (Excp_List, TC_CannotProceed); Add (Excp_List, TC_InvalidName); -- Set result type (maybe void) Result := (Name => PolyORB.Types.Identifier (Result_Name), Argument => Get_Empty_Any (PolyORB.Any.TypeCode.TC_Void), Arg_Modes => 0); PolyORB.Requests.Create_Request (Target => PolyORB.References.Ref (Self), Operation => Operation_Name, Arg_List => Arg_List, Result => Result, Exc_List => Excp_List, Req => Request); PolyORB.Requests.Invoke (Request); if not Is_Empty (Request.Exception_Info) then PolyORB.Exceptions.Default_Raise_From_Any (Request.Exception_Info); end if; PolyORB.Requests.Destroy_Request (Request); -- Request has been synchronously invoked end Rebind; ------------------ -- Bind_Context -- ------------------ procedure Bind_Context (Self : PolyORB.Services.Naming.NamingContext.Ref; N : Name; Nc : NamingContext.Ref) is Arg_Name_n : constant PolyORB.Types.Identifier := PolyORB.Types.To_PolyORB_String ("n"); Argument_n : constant PolyORB.Any.Any := To_Any (N); Arg_Name_nc : constant PolyORB.Types.Identifier := PolyORB.Types.To_PolyORB_String ("nc"); Argument_nc : constant PolyORB.Any.Any := To_Any (Nc); Operation_Name : constant Standard.String := "bind_context"; Request : PolyORB.Requests.Request_Access; Arg_List : PolyORB.Any.NVList.Ref; Excp_List : PolyORB.Any.ExceptionList.Ref; Result : PolyORB.Any.NamedValue; begin -- Create argument list PolyORB.Any.NVList.Create (Arg_List); PolyORB.Any.NVList.Add_Item (Arg_List, Arg_Name_n, Argument_n, PolyORB.Any.ARG_IN); PolyORB.Any.NVList.Add_Item (Arg_List, Arg_Name_nc, Argument_nc, PolyORB.Any.ARG_IN); -- Create exceptions list Create_List (Excp_List); Add (Excp_List, TC_NotFound); Add (Excp_List, TC_CannotProceed); Add (Excp_List, TC_InvalidName); Add (Excp_List, TC_AlreadyBound); -- Set result type (maybe void) Result := (Name => PolyORB.Types.Identifier (Result_Name), Argument => Get_Empty_Any (PolyORB.Any.TypeCode.TC_Void), Arg_Modes => 0); PolyORB.Requests.Create_Request (Target => PolyORB.References.Ref (Self), Operation => Operation_Name, Arg_List => Arg_List, Result => Result, Exc_List => Excp_List, Req => Request); PolyORB.Requests.Invoke (Request); if not Is_Empty (Request.Exception_Info) then PolyORB.Exceptions.Default_Raise_From_Any (Request.Exception_Info); end if; PolyORB.Requests.Destroy_Request (Request); -- Request has been synchronously invoked end Bind_Context; -------------------- -- Rebind_Context -- -------------------- procedure Rebind_Context (Self : PolyORB.Services.Naming.NamingContext.Ref; N : Name; Nc : NamingContext.Ref) is Arg_Name_n : constant PolyORB.Types.Identifier := PolyORB.Types.To_PolyORB_String ("n"); Argument_n : constant PolyORB.Any.Any := To_Any (N); Arg_Name_nc : constant PolyORB.Types.Identifier := PolyORB.Types.To_PolyORB_String ("nc"); Argument_nc : constant PolyORB.Any.Any := To_Any (Nc); Operation_Name : constant Standard.String := "rebind_context"; Request : PolyORB.Requests.Request_Access; Arg_List : PolyORB.Any.NVList.Ref; Excp_List : PolyORB.Any.ExceptionList.Ref; Result : PolyORB.Any.NamedValue; begin -- Create argument list PolyORB.Any.NVList.Create (Arg_List); PolyORB.Any.NVList.Add_Item (Arg_List, Arg_Name_n, Argument_n, PolyORB.Any.ARG_IN); PolyORB.Any.NVList.Add_Item (Arg_List, Arg_Name_nc, Argument_nc, PolyORB.Any.ARG_IN); -- Create exceptions list Create_List (Excp_List); Add (Excp_List, TC_NotFound); Add (Excp_List, TC_CannotProceed); Add (Excp_List, TC_InvalidName); -- Set result type (maybe void) Result := (Name => PolyORB.Types.Identifier (Result_Name), Argument => Get_Empty_Any (PolyORB.Any.TypeCode.TC_Void), Arg_Modes => 0); PolyORB.Requests.Create_Request (Target => PolyORB.References.Ref (Self), Operation => Operation_Name, Arg_List => Arg_List, Result => Result, Exc_List => Excp_List, Req => Request); PolyORB.Requests.Invoke (Request); if not Is_Empty (Request.Exception_Info) then PolyORB.Exceptions.Default_Raise_From_Any (Request.Exception_Info); end if; PolyORB.Requests.Destroy_Request (Request); -- Request has been synchronously invoked end Rebind_Context; ------------- -- Resolve -- ------------- function Resolve (Self : PolyORB.Services.Naming.NamingContext.Ref; N : Name) return PolyORB.References.Ref is Arg_Name_n : constant PolyORB.Types.Identifier := PolyORB.Types.To_PolyORB_String ("n"); Argument_n : constant PolyORB.Any.Any := To_Any (N); Operation_Name : constant Standard.String := "resolve"; Request : PolyORB.Requests.Request_Access; Arg_List : PolyORB.Any.NVList.Ref; Excp_List : PolyORB.Any.ExceptionList.Ref; Result : PolyORB.Any.NamedValue; begin -- Create argument list PolyORB.Any.NVList.Create (Arg_List); PolyORB.Any.NVList.Add_Item (Arg_List, Arg_Name_n, Argument_n, PolyORB.Any.ARG_IN); -- Create exceptions list Create_List (Excp_List); Add (Excp_List, TC_NotFound); Add (Excp_List, TC_CannotProceed); Add (Excp_List, TC_InvalidName); -- Set result type (maybe void) Result := (Name => PolyORB.Types.Identifier (Result_Name), Argument => Get_Empty_Any (PolyORB.Services.Naming.Helper.TC_Object), Arg_Modes => 0); PolyORB.Requests.Create_Request (Target => PolyORB.References.Ref (Self), Operation => Operation_Name, Arg_List => Arg_List, Result => Result, Exc_List => Excp_List, Req => Request); PolyORB.Requests.Invoke (Request); if not Is_Empty (Request.Exception_Info) then PolyORB.Exceptions.Default_Raise_From_Any (Request.Exception_Info); end if; PolyORB.Requests.Destroy_Request (Request); -- Request has been synchronously invoked -- Retrieve return value. return From_Any (Result.Argument); end Resolve; ------------ -- Unbind -- ------------ procedure Unbind (Self : PolyORB.Services.Naming.NamingContext.Ref; N : Name) is Arg_Name_n : constant PolyORB.Types.Identifier := PolyORB.Types.To_PolyORB_String ("n"); Argument_n : constant PolyORB.Any.Any := To_Any (N); Operation_Name : constant Standard.String := "unbind"; Request : PolyORB.Requests.Request_Access; Arg_List : PolyORB.Any.NVList.Ref; Excp_List : PolyORB.Any.ExceptionList.Ref; Result : PolyORB.Any.NamedValue; begin -- Create argument list PolyORB.Any.NVList.Create (Arg_List); PolyORB.Any.NVList.Add_Item (Arg_List, Arg_Name_n, Argument_n, PolyORB.Any.ARG_IN); -- Create exceptions list Create_List (Excp_List); Add (Excp_List, TC_NotFound); Add (Excp_List, TC_CannotProceed); Add (Excp_List, TC_InvalidName); -- Set result type (maybe void) Result := (Name => PolyORB.Types.Identifier (Result_Name), Argument => Get_Empty_Any (PolyORB.Any.TypeCode.TC_Void), Arg_Modes => 0); PolyORB.Requests.Create_Request (Target => PolyORB.References.Ref (Self), Operation => Operation_Name, Arg_List => Arg_List, Result => Result, Exc_List => Excp_List, Req => Request); PolyORB.Requests.Invoke (Request); if not Is_Empty (Request.Exception_Info) then PolyORB.Exceptions.Default_Raise_From_Any (Request.Exception_Info); end if; PolyORB.Requests.Destroy_Request (Request); -- Request has been synchronously invoked end Unbind; ----------------- -- New_Context -- ----------------- function New_Context (Self : PolyORB.Services.Naming.NamingContext.Ref) return NamingContext.Ref is Operation_Name : constant Standard.String := "new_context"; Request : PolyORB.Requests.Request_Access; Arg_List : PolyORB.Any.NVList.Ref; Result : PolyORB.Any.NamedValue; begin -- Create argument list PolyORB.Any.NVList.Create (Arg_List); -- Set result type (maybe void) Result := (Name => PolyORB.Types.Identifier (Result_Name), Argument => Get_Empty_Any (TC_NamingContext), Arg_Modes => 0); PolyORB.Requests.Create_Request (Target => PolyORB.References.Ref (Self), Operation => Operation_Name, Arg_List => Arg_List, Result => Result, Req => Request); PolyORB.Requests.Invoke (Request); if not Is_Empty (Request.Exception_Info) then PolyORB.Exceptions.Default_Raise_From_Any (Request.Exception_Info); end if; PolyORB.Requests.Destroy_Request (Request); -- Request has been synchronously invoked -- Retrieve return value. return From_Any (Result.Argument); end New_Context; ---------------------- -- Bind_New_Context -- ---------------------- function Bind_New_Context (Self : PolyORB.Services.Naming.NamingContext.Ref; N : Name) return NamingContext.Ref is Arg_Name_n : constant PolyORB.Types.Identifier := PolyORB.Types.To_PolyORB_String ("n"); Argument_n : constant PolyORB.Any.Any := To_Any (N); Operation_Name : constant Standard.String := "bind_new_context"; Request : PolyORB.Requests.Request_Access; Arg_List : PolyORB.Any.NVList.Ref; Excp_List : PolyORB.Any.ExceptionList.Ref; Result : PolyORB.Any.NamedValue; begin -- Create argument list PolyORB.Any.NVList.Create (Arg_List); PolyORB.Any.NVList.Add_Item (Arg_List, Arg_Name_n, Argument_n, PolyORB.Any.ARG_IN); -- Create exceptions list Create_List (Excp_List); Add (Excp_List, TC_NotFound); Add (Excp_List, TC_AlreadyBound); Add (Excp_List, TC_CannotProceed); Add (Excp_List, TC_InvalidName); -- Set result type (maybe void) Result := (Name => PolyORB.Types.Identifier (Result_Name), Argument => Get_Empty_Any (TC_NamingContext), Arg_Modes => 0); PolyORB.Requests.Create_Request (Target => PolyORB.References.Ref (Self), Operation => Operation_Name, Arg_List => Arg_List, Result => Result, Exc_List => Excp_List, Req => Request); PolyORB.Requests.Invoke (Request); if not Is_Empty (Request.Exception_Info) then PolyORB.Exceptions.Default_Raise_From_Any (Request.Exception_Info); end if; PolyORB.Requests.Destroy_Request (Request); -- Request has been synchronously invoked -- Retrieve return value return From_Any (Result.Argument); end Bind_New_Context; ------------- -- Destroy -- ------------- procedure Destroy (Self : PolyORB.Services.Naming.NamingContext.Ref) is Operation_Name : constant Standard.String := "destroy"; Request : PolyORB.Requests.Request_Access; Arg_List : PolyORB.Any.NVList.Ref; Excp_List : PolyORB.Any.ExceptionList.Ref; Result : PolyORB.Any.NamedValue; begin -- Create argument list PolyORB.Any.NVList.Create (Arg_List); -- Create exceptions list Create_List (Excp_List); Add (Excp_List, TC_NotEmpty); -- Set result type (maybe void) Result := (Name => PolyORB.Types.Identifier (Result_Name), Argument => Get_Empty_Any (PolyORB.Any.TypeCode.TC_Void), Arg_Modes => 0); PolyORB.Requests.Create_Request (Target => PolyORB.References.Ref (Self), Operation => Operation_Name, Arg_List => Arg_List, Result => Result, Exc_List => Excp_List, Req => Request); PolyORB.Requests.Invoke (Request); if not Is_Empty (Request.Exception_Info) then PolyORB.Exceptions.Default_Raise_From_Any (Request.Exception_Info); end if; PolyORB.Requests.Destroy_Request (Request); -- Request has been synchronously invoked end Destroy; -- procedure list -- (Self : PolyORB.Services.Naming.Ref; -- how_many : CORBA.Unsigned_Long; -- bl : out BindingList; -- bi : out BindingIterator_Forward.Ref) -- is -- Arg_Name_how_many : PolyORB.Types.Identifier -- := PolyORB.Types.To_PolyORB_String ("how_many"); -- Argument_how_many : PolyORB.Any.Any -- := CORBA.To_Any -- (how_many); -- Arg_Name_bl : PolyORB.Types.Identifier -- := PolyORB.Types.To_PolyORB_String ("bl"); -- Argument_bl : PolyORB.Any.Any -- := To_Any -- (bl); -- Arg_Name_bi : PolyORB.Types.Identifier -- := PolyORB.Types.To_PolyORB_String ("bi"); -- Argument_bi : PolyORB.Any.Any -- := To_Any -- (Convert_Forward.From_Forward -- (bi)); -- Operation_Name : constant Standard.String -- := "list"; -- Self_Ref : PolyORB.References.Ref -- := PolyORB.References.Ref (Self); -- Request : PolyORB.Requests.Request_Access; -- Arg_List : PolyORB.Any.NVList.Ref; -- Result : PolyORB.Any.NamedValue; -- Result_Name : PolyORB.Types.String := To_PolyORB_String ("Result"); -- begin -- if CORBA.Object.Is_Nil (Self_Ref) then -- PolyORB.Exceptions.Raise_Inv_Objref; -- end if; -- -- Create argument list -- PolyORB.Any.NVList.Create -- (Arg_List); -- PolyORB.Any.NVList.Add_Item -- (Arg_List, -- Arg_Name_how_many, -- Argument_how_many, -- PolyORB.Any.ARG_IN); -- PolyORB.Any.NVList.Add_Item -- (Arg_List, -- Arg_Name_bl, -- Argument_bl, -- PolyORB.Any.ARG_OUT); -- PolyORB.Any.NVList.Add_Item -- (Arg_List, -- Arg_Name_bi, -- Argument_bi, -- PolyORB.Any.ARG_OUT); -- -- Set result type (maybe void) -- Result -- := (Name => PolyORB.Types.Identifier (Result_Name), -- Argument => Get_Empty_Any -- (PolyORB.Any.TypeCode.TC_Void), -- Arg_Modes => 0); -- PolyORB.Requests.Create_Request -- (Target => CORBA.Object.To_PolyORB_Ref -- (PolyORB.References.Ref (Self)), -- Operation => Operation_Name, -- Arg_List => Arg_List, -- Result => Result, -- Req => Request); -- PolyORB.Requests.Invoke (Request); -- if not Is_Empty (Request.Exception_Info) then -- PolyORB.CORBA_P.Exceptions.Raise_From_Any -- (Request.Exception_Info); -- end if; -- PolyORB.Requests.Destroy_Request -- (Request); -- -- Request has been synchronously invoked. -- -- Retrieve 'out' argument values. -- bl := From_Any -- (Argument_bl); -- bi := Convert_Forward.To_Forward -- (From_Any -- (Argument_bi)); -- end list; end PolyORB.Services.Naming.NamingContext.Client; polyorb-2.8~20110207.orig/src/polyorb-any-nvlist.ads0000644000175000017500000000712411750740340021456 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . A N Y . N V L I S T -- -- -- -- S p e c -- -- -- -- Copyright (C) 2001-2008, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with PolyORB.Any; with PolyORB.Smart_Pointers; with PolyORB.Types; with PolyORB.Utils.Chained_Lists; package PolyORB.Any.NVList is type Ref is new PolyORB.Smart_Pointers.Ref with private; procedure Add_Item (Self : Ref; Item_Name : Types.Identifier; Item : Any; Item_Flags : Flags); -- Create a NamedValue and add it to this NVList procedure Add_Item (Self : Ref; Item : NamedValue); -- Add a NamedValue to this NVList function Get_Count (Self : Ref) return PolyORB.Types.Long; -- Return the number of items in this NVList ------------------------------------------ -- The following is specific to PolyORB -- ------------------------------------------ procedure Create (NVList : out Ref); -- Create a new NVList object and return a reference to it function Image (NVList : Ref) return Standard.String; -- For debugging purposes package Internals is -- The actual implementation of an NVList: a chained list of -- NamedValues. package NV_Lists is new PolyORB.Utils.Chained_Lists (NamedValue); type NV_List_Access is access all NV_Lists.List; function List_Of (NVList : Ref) return NV_List_Access; end Internals; private type Ref is new PolyORB.Smart_Pointers.Ref with null record; type Object is new PolyORB.Smart_Pointers.Non_Controlled_Entity with record List : aliased Internals.NV_Lists.List; end record; type Object_Ptr is access all Object; procedure Finalize (X : in out Object); end PolyORB.Any.NVList; polyorb-2.8~20110207.orig/src/polyorb-poa_types.ads0000644000175000017500000002360111750740340021353 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . P O A _ T Y P E S -- -- -- -- S p e c -- -- -- -- Copyright (C) 2001-2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- Base types for the Portable Object Adapter. with Ada.Unchecked_Deallocation; with PolyORB.Any; with PolyORB.Any.NVList; with PolyORB.Errors; with PolyORB.Obj_Adapters; with PolyORB.Objects; with PolyORB.Servants; with PolyORB.Smart_Pointers; with PolyORB.Types; with PolyORB.Utils.HFunctions.Hyper; with PolyORB.Utils.HTables.Perfect; with PolyORB.Utils.Chained_Lists; package PolyORB.POA_Types is pragma Elaborate_Body; use PolyORB.Objects; use PolyORB.Types; ---------------- -- Time_Stamp -- ---------------- subtype Time_Stamp is Duration; Null_Time_Stamp : constant Time_Stamp; -- A time marker. subtype Lifespan_Cookie is Time_Stamp; -- A piece of information embedded in an object id by the lifespan -- policy for control of reference validity across ORB executions. ----------------- -- Obj_Adapter -- ----------------- type Obj_Adapter is abstract new PolyORB.Obj_Adapters.Obj_Adapter with null record; type Obj_Adapter_Access is access all Obj_Adapter'Class; type Obj_Adapter_Ref is new PolyORB.Smart_Pointers.Ref with null record; Null_POA_Ref : Obj_Adapter_Ref; ---------------------------------- -- Object Interface description -- ---------------------------------- type Parameter_Profile_Description is access function (Method : String) return PolyORB.Any.NVList.Ref; type Result_Profile_Description is access function (Method : String) return PolyORB.Any.Any; type Interface_Description is record PP_Desc : Parameter_Profile_Description; RP_Desc : Result_Profile_Description; end record; -------------- -- POATable -- -------------- package POA_HTables is new PolyORB.Utils.HTables.Perfect (Obj_Adapter_Ref, PolyORB.Utils.HFunctions.Hyper.Hash_Hyper_Parameters, PolyORB.Utils.HFunctions.Hyper.Default_Hash_Parameters, PolyORB.Utils.HFunctions.Hyper.Hash, PolyORB.Utils.HFunctions.Hyper.Next_Hash_Parameters); subtype POATable is POA_HTables.Table_Instance; type POATable_Access is access all POATable; procedure Free is new Ada.Unchecked_Deallocation (POATable, POATable_Access); ------------- -- POAList -- ------------- package POA_Lists is new PolyORB.Utils.Chained_Lists (Obj_Adapter_Ref, "=", True); subtype POAList is POA_Lists.List; ---------------- -- Object Ids -- ---------------- POA_Path_Separator : constant Character := '/'; subtype Object_Id is PolyORB.Objects.Object_Id; subtype Object_Id_Access is PolyORB.Objects.Object_Id_Access; function "=" (X, Y : Object_Id_Access) return Boolean renames PolyORB.Objects."="; type Unmarshalled_Oid is record Id : Types.String; -- Object id within POA Creator : Types.String; -- Creator (POA path delimited with POA_Path_Separator) System_Generated : Boolean; -- System or User managed ? Persistency_Flag : Lifespan_Cookie; -- Object's Lifespan end record; function "=" (Left, Right : Unmarshalled_Oid) return Standard.Boolean; type Unmarshalled_Oid_Access is access Unmarshalled_Oid; procedure Free is new Ada.Unchecked_Deallocation (Unmarshalled_Oid, Unmarshalled_Oid_Access); function Create_Id (Name : Standard.String; System_Generated : Boolean; Persistency_Flag : Time_Stamp; Creator : Standard.String) return Unmarshalled_Oid_Access; pragma Inline (Create_Id); -- Create an Unmarshalled_Oid_Access. function Create_Id (Name : Standard.String; System_Generated : Boolean; Persistency_Flag : Time_Stamp; Creator : Standard.String) return Unmarshalled_Oid; pragma Inline (Create_Id); -- Create an Unmarshalled_Oid. function Create_Id (Name : Standard.String; System_Generated : Boolean; Persistency_Flag : Time_Stamp; Creator : Standard.String) return Object_Id_Access; pragma Inline (Create_Id); -- Create an Unmarshalled_Oid, and then marshall it into an Object_Id procedure Oid_To_U_Oid (Oid : Object_Id; U_Oid : out Unmarshalled_Oid; Error : in out PolyORB.Errors.Error_Container); -- Unmarshall an Object_Id into a Unmarshalled_Oid function Get_Creator (Oid : Object_Id) return String; -- Return Creator name coded in Oid function U_Oid_To_Oid (U_Oid : Unmarshalled_Oid) return Object_Id_Access; -- Marshall an Unmarshalled_Oid into an Object_Id. The caller -- is responsible for deallocating the returned Object_Id_Access -- after use. function U_Oid_To_Oid (U_Oid : Unmarshalled_Oid) return Object_Id; -- Marshall an Unmarshalled_Oid into an Object_Id. procedure Free (X : in out PolyORB.POA_Types.Object_Id_Access) renames PolyORB.Objects.Free; -------------------------- -- POA Callback objects -- -------------------------- -- AdapterActivator type AdapterActivator is abstract new Smart_Pointers.Ref with null record; type AdapterActivator_Access is access all AdapterActivator'Class; procedure Unknown_Adapter (Self : access AdapterActivator; Parent : access Obj_Adapter'Class; Name : String; Result : out Boolean; Error : in out PolyORB.Errors.Error_Container) is abstract; procedure Free is new Ada.Unchecked_Deallocation (AdapterActivator'Class, AdapterActivator_Access); -- Servant Manager type ServantManager is abstract new Smart_Pointers.Ref with null record; type ServantManager_Access is access all ServantManager'Class; procedure Free is new Ada.Unchecked_Deallocation (ServantManager'Class, ServantManager_Access); -- Servant Activator type ServantActivator is abstract new ServantManager with null record; type ServantActivator_Access is access all ServantActivator'Class; procedure Incarnate (Self : access ServantActivator; Oid : Object_Id; Adapter : access Obj_Adapter'Class; Returns : out PolyORB.Servants.Servant_Access; Error : in out PolyORB.Errors.Error_Container) is abstract; -- The Error argument used only for processing location forwarding, thus -- the only valid Error.Kind is ForwardRequest_E. procedure Etherealize (Self : access ServantActivator; Oid : Object_Id; Adapter : access Obj_Adapter'Class; Serv : PolyORB.Servants.Servant_Access; Cleanup_In_Progress : Boolean; Remaining_Activations : Boolean) is abstract; procedure Free is new Ada.Unchecked_Deallocation (ServantActivator'Class, ServantActivator_Access); -- Servant Locator type ServantLocator is abstract new ServantManager with null record; type ServantLocator_Access is access all ServantLocator'Class; type Cookie_Base is tagged null record; -- User defined cookie type type Cookie is access all Cookie_Base'Class; procedure Preinvoke (Self : access ServantLocator; Oid : Object_Id; Adapter : access Obj_Adapter'Class; Operation : PolyORB.Types.Identifier; The_Cookie : out Cookie; Returns : out PolyORB.Servants.Servant_Access; Error : in out PolyORB.Errors.Error_Container) is abstract; -- The Error argument used only for processing location forwarding, thus -- the only valid Error.Kind is ForwardRequest_E. procedure Postinvoke (Self : access ServantLocator; Oid : Object_Id; Adapter : access Obj_Adapter'Class; Operation : PolyORB.Types.Identifier; The_Cookie : Cookie; The_Servant : PolyORB.Servants.Servant_Access) is abstract; procedure Free is new Ada.Unchecked_Deallocation (ServantLocator'Class, ServantLocator_Access); private Null_Time_Stamp : constant Time_Stamp := Time_Stamp'First; end PolyORB.POA_Types; polyorb-2.8~20110207.orig/src/polyorb-references-ior.adb0000644000175000017500000003176211750740340022246 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . R E F E R E N C E S . I O R -- -- -- -- B o d y -- -- -- -- Copyright (C) 2002-2009, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with PolyORB.Initialization; with PolyORB.Log; with PolyORB.Representations.CDR.Common; with PolyORB.Types; with PolyORB.Utils.Chained_Lists; package body PolyORB.References.IOR is use Ada.Streams; use PolyORB.Binding_Data; use PolyORB.Log; use PolyORB.Representations.CDR.Common; use PolyORB.Utils; package L is new PolyORB.Log.Facility_Log ("polyorb.references.ior"); procedure O (Message : String; Level : Log_Level := Debug) renames L.Output; function C (Level : Log_Level := Debug) return Boolean renames L.Enabled; IOR_Prefix : constant String := "IOR:"; type Profile_Record is record Tag : Binding_Data.Profile_Tag; Marshall_Profile_Body : Marshall_Profile_Body_Type; Unmarshall_Profile_Body : Unmarshall_Profile_Body_Type; end record; package Profile_Record_List is new PolyORB.Utils.Chained_Lists (Profile_Record); use Profile_Record_List; Callbacks : Profile_Record_List.List; type IOR_Streamer is new Ref_Streamer with null record; procedure Read (R : access IOR_Streamer; S : access Ada.Streams.Root_Stream_Type'Class; V : out Ref'Class); procedure Write (R : access IOR_Streamer; S : access Ada.Streams.Root_Stream_Type'Class; V : Ref'Class); ---------------------- -- Marshall_Profile -- ---------------------- procedure Marshall_Profile (Buffer : access Buffer_Type; P : Binding_Data.Profile_Access; Success : out Boolean) is use PolyORB.Types; T : Profile_Tag; Iter : Iterator := First (Callbacks); begin pragma Assert (P /= null); pragma Debug (C, O ("Marshall profile with tag :" & Profile_Tag'Image (Get_Profile_Tag (P.all)))); Success := False; T := Get_Profile_Tag (P.all); while not Last (Iter) loop declare Info : constant Profile_Record := Value (Iter).all; begin pragma Debug (C, O ("... with callback whose tag is " & Profile_Tag'Image (Info.Tag))); if T = Info.Tag then Marshall (Buffer, Types.Unsigned_Long (T)); Value (Iter).Marshall_Profile_Body (Buffer, P); Success := True; return; end if; end; Next (Iter); end loop; end Marshall_Profile; ---------- -- Read -- ---------- procedure Read (R : access IOR_Streamer; S : access Ada.Streams.Root_Stream_Type'Class; V : out Ref'Class) is pragma Unreferenced (R); Opaque : aliased Stream_Element_Array := Stream_Element_Array'Input (S); begin Ref (V) := Opaque_To_Object (Opaque'Access); end Read; ------------------------ -- Unmarshall_Profile -- ------------------------ function Unmarshall_Profile (Buffer : access Buffer_Type) return Profile_Access is use PolyORB.Types; Temp_Tag : constant Types.Unsigned_Long := Unmarshall (Buffer); Tag : constant Profile_Tag := Profile_Tag (Temp_Tag); Known : Boolean := False; Prof : Profile_Access; Iter : Iterator := First (Callbacks); begin pragma Debug (C, O ("Considering profile with tag" & Profile_Tag'Image (Tag))); while not Last (Iter) loop pragma Debug (C, O ("... with callback whose tag is " & Profile_Tag'Image (Value (Iter).Tag))); if Value (Iter).Tag = Tag then Prof := Value (Iter).Unmarshall_Profile_Body (Buffer); Known := True; -- Profiles dynamically allocated here -- will be freed when the returned -- reference is finalised. end if; Next (Iter); end loop; if not Known then -- No callback matches this tag. declare pragma Debug (C, O ("Profile with tag" & Profile_Tag'Image (Tag) & " not found")); pragma Warnings (Off); Discarded_Body : constant Encapsulation := Unmarshall (Buffer); -- Consider the profile body as an encapsulation -- (our best bet). pragma Unreferenced (Discarded_Body); pragma Warnings (On); begin return null; end; end if; return Prof; end Unmarshall_Profile; ------------------ -- Marshall_IOR -- ------------------ procedure Marshall_IOR (Buffer : access Buffer_Type; Value : PolyORB.References.Ref) is use PolyORB.Types; begin pragma Debug (C, O ("Marshall IOR: Enter")); if Is_Nil (Value) then Marshall (Buffer, PolyORB.Types.RepositoryId'(To_PolyORB_String (""))); Marshall (Buffer, Types.Unsigned_Long'(0)); pragma Debug (C, O ("Empty IOR")); else Marshall (Buffer, PolyORB.Types.RepositoryId' (To_PolyORB_String (Type_Id_Of (Value)))); Pad_Align (Buffer, Align_4); declare Profs : constant Profile_Array := Profiles_Of (Value); Counter : Types.Unsigned_Long := 0; Count_Buf : Buffer_Access := new Buffer_Type; Reserv : Reservation; Success : Boolean; begin Set_Initial_Position (Count_Buf, CDR_Position (Buffer)); Reserv := Reserve (Buffer, Counter'Size / Types.Octet'Size); pragma Debug (C, O (Type_Id_Of (Value))); for Profile_Index in Profs'Range loop pragma Assert (Profs (Profile_Index) /= null); Marshall_Profile (Buffer, Profs (Profile_Index), Success); if Success then Counter := Counter + 1; else pragma Debug (C, O ("Profile with tag" & Profile_Tag'Image (Get_Profile_Tag (Profs (Profile_Index).all)) & " not found")); null; end if; end loop; pragma Debug (C, O (Types.Unsigned_Long'Image (Counter) & " profile(s)")); Marshall (Count_Buf, Counter); Copy_Data (Count_Buf.all, Reserv); Release (Count_Buf); end; end if; pragma Debug (C, O ("Marshall IOR: Leave")); end Marshall_IOR; -------------------- -- Unmarshall_IOR -- -------------------- function Unmarshall_IOR (Buffer : access Buffer_Type) return PolyORB.References.Ref is use PolyORB.Types; Result : PolyORB.References.Ref; PolyORB_Type_Id : constant Types.String := Types.String (Types.RepositoryId'(Unmarshall (Buffer))); Type_Id : constant String := To_Standard_String (PolyORB_Type_Id); N_Profiles : constant Types.Unsigned_Long := Unmarshall (Buffer); Profs : Profile_Array := (1 .. Integer (N_Profiles) => null); Last_Profile : Integer := Profs'First - 1; begin pragma Debug (C, O ("Decapsulate_IOR: type " & Type_Id & " (" & Unsigned_Long'Image (N_Profiles) & " profiles).")); for N in 1 .. N_Profiles loop declare Pro : Profile_Access; begin Pro := Unmarshall_Profile (Buffer); if Pro /= null then Last_Profile := Last_Profile + 1; Profs (Last_Profile) := Pro; end if; end; end loop; if Last_Profile >= Profs'First then Create_Reference (Profs (Profs'First .. Last_Profile), Type_Id, References.Ref (Result)); end if; return Result; end Unmarshall_IOR; ---------------------- -- Object_To_Opaque -- ---------------------- function Object_To_Opaque (IOR : PolyORB.References.Ref) return Stream_Element_Array is Buf : Buffer_Access := new Buffer_Type; begin Start_Encapsulation (Buf); Marshall (Buf, IOR); declare Octets : constant Encapsulation := Encapsulate (Buf); begin Release (Buf); return Stream_Element_Array (Octets); end; end Object_To_Opaque; ---------------------- -- Opaque_To_Object -- ---------------------- function Opaque_To_Object (Opaque : access Ada.Streams.Stream_Element_Array) return PolyORB.References.Ref is Buf : aliased Buffer_Type; begin Decapsulate (Opaque, Buf'Access); return Unmarshall (Buf'Access); end Opaque_To_Object; ---------------------- -- Object_To_String -- ---------------------- function Object_To_String (IOR : PolyORB.References.Ref) return String is use PolyORB.Types; begin return IOR_Prefix & SEA_To_Hex_String (Object_To_Opaque (IOR)); end Object_To_String; ---------------------- -- String_To_Object -- ---------------------- function String_To_Object (Str : String) return PolyORB.References.Ref is use PolyORB.Types; use PolyORB.Utils.Strings; begin pragma Debug (C, O ("Try to decode IOR")); if Has_Prefix (Str, IOR_Prefix) then pragma Debug (C, O ("IOR Header ok")); declare Octets : aliased Stream_Element_Array := Hex_String_To_SEA (Str (Str'First + IOR_Prefix'Length .. Str'Last)); begin return Opaque_To_Object (Octets'Access); end; end if; raise Constraint_Error; end String_To_Object; -------------- -- Register -- -------------- procedure Register (Profile : Profile_Tag; Marshall_Profile_Body : Marshall_Profile_Body_Type; Unmarshall_Profile_Body : Unmarshall_Profile_Body_Type) is Elt : constant Profile_Record := (Profile, Marshall_Profile_Body, Unmarshall_Profile_Body); begin Append (Callbacks, Elt); end Register; ----------- -- Write -- ----------- procedure Write (R : access IOR_Streamer; S : access Ada.Streams.Root_Stream_Type'Class; V : Ref'Class) is pragma Unreferenced (R); begin Stream_Element_Array'Output (S, Object_To_Opaque (Ref (V))); end Write; ---------------- -- Initialize -- ---------------- procedure Initialize; procedure Initialize is begin Register_String_To_Object (IOR_Prefix, String_To_Object'Access); References.The_Ref_Streamer := new IOR_Streamer; end Initialize; use PolyORB.Initialization; use PolyORB.Initialization.String_Lists; use PolyORB.Utils.Strings; begin Register_Module (Module_Info' (Name => +"references.ior", Conflicts => PolyORB.Initialization.String_Lists.Empty, Depends => PolyORB.Initialization.String_Lists.Empty, Provides => +"references", Implicit => False, Init => Initialize'Access, Shutdown => null)); end PolyORB.References.IOR; polyorb-2.8~20110207.orig/src/polyorb-sequences-unbounded-helper.adb0000644000175000017500000000560411750740340024563 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . S E Q U E N C E S . U N B O U N D E D . H E L P E R -- -- -- -- B o d y -- -- -- -- Copyright (C) 2003-2007, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- Any conversion subprograms for bounded sequences. package body PolyORB.Sequences.Unbounded.Helper is use PolyORB.Any; -------------- -- From_Any -- -------------- function From_Any (Item : Any.Any) return Sequence renames Unbounded_Helper.From_Any; ---------------- -- Initialize -- ---------------- procedure Initialize (Element_TC, Sequence_TC : PolyORB.Any.TypeCode.Local_Ref) is begin Unbounded_Helper.Initialize (Element_TC => Element_TC, Sequence_TC => Sequence_TC); end Initialize; ------------ -- To_Any -- ------------ function To_Any (Item : Sequence) return Any.Any renames Unbounded_Helper.To_Any; ---------- -- Wrap -- ---------- function Wrap (X : access Sequence) return Any.Content'Class renames Unbounded_Helper.Wrap; end PolyORB.Sequences.Unbounded.Helper; polyorb-2.8~20110207.orig/src/polyorb-utils-strings-lists.adb0000644000175000017500000000701111750740340023307 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . U T I L S . S T R I N G S . L I S T S -- -- -- -- B o d y -- -- -- -- Copyright (C) 2002-2009, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- Generic chained list package body PolyORB.Utils.Strings.Lists is ----------- -- Empty -- ----------- function Empty return List is Empty_List : List; begin return Empty_List; end Empty; ----------- -- First -- ----------- function First (L : List) return Iterator is begin return Iterator (String_Ptr_Lists.Iterator'(First (L))); end First; ----------- -- Value -- ----------- function Value (I : Iterator) return String_Ptr is begin return Value (I).all; end Value; ------------- -- Prepend -- ------------- procedure Prepend (L : in out List; I : String) is begin Prepend (L, new String'(I)); end Prepend; ------------ -- Append -- ------------ procedure Append (L : in out List; I : String) is begin Append (L, new String'(I)); end Append; --------- -- "+" -- --------- function "+" (I : String) return List is begin return +new String'(I); end "+"; --------- -- "&" -- --------- function "&" (L : List; I : String) return List is begin return L & new String'(I); end "&"; ---------------- -- Deallocate -- ---------------- procedure Deallocate (L : in out List) is I : Iterator := First (L); begin while not Last (I) loop Free (Value (I).all); Next (I); end loop; String_Ptr_Lists.Deallocate (String_Ptr_Lists.List (L)); end Deallocate; end PolyORB.Utils.Strings.Lists; polyorb-2.8~20110207.orig/src/polyorb-filters.adb0000644000175000017500000001172011750740340020776 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . F I L T E R S -- -- -- -- B o d y -- -- -- -- Copyright (C) 2001-2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- A communication filter (a transport Data_Unit handler/forwarder). with Ada.Tags; with PolyORB.Filters.Iface; with PolyORB.Log; package body PolyORB.Filters is use PolyORB.Components; use PolyORB.Filters.Iface; use PolyORB.Log; package L is new PolyORB.Log.Facility_Log ("polyorb.filters"); procedure O (Message : String; Level : Log_Level := Debug) renames L.Output; function C (Level : Log_Level := Debug) return Boolean renames L.Enabled; ------------------- -- Connect_Lower -- ------------------- procedure Connect_Lower (F : access Filter; Lower : Component_Access) is begin Connect (F.Lower, Lower); end Connect_Lower; ----------- -- Lower -- ----------- function Lower (F : access Filter) return Component_Access is begin return F.Lower; end Lower; ----------- -- Upper -- ----------- function Upper (F : access Filter) return Component_Access is begin return F.Upper; end Upper; ------------- -- Destroy -- ------------- procedure Destroy (F : in out Filter) is begin if F.Upper /= null then pragma Debug (C, O ("Destroying upper of type " & Ada.Tags.External_Tag (F.Upper'Tag))); PolyORB.Components.Destroy (F.Upper); end if; end Destroy; ------------------------- -- Create_Filter_Chain -- ------------------------- procedure Create_Filter_Chain (Factories : Factory_Array; Bottom : out Filter_Access; Top : out Filter_Access) is Lower_F, F : Filter_Access; begin for J in Factories'Range loop Create (Fact => Factories (J), Filt => F); pragma Debug (C, O ("Created filter of type " & Ada.Tags.External_Tag (F'Tag))); Connect_Lower (F, Component_Access (Lower_F)); if Lower_F /= null then Connect (Lower_F.Upper, Component_Access (F)); else Bottom := F; end if; Lower_F := F; end loop; Top := F; end Create_Filter_Chain; -------------------- -- Handle_Message -- -------------------- function Handle_Message (F : not null access Filter; Msg : Message'Class) return Components.Message'Class is begin -- Implement default progagation behaviour if False or else Msg in Data_Indication'Class or else Msg in Connect_Indication'Class or else Msg in Connect_Confirmation'Class or else Msg in Disconnect_Indication'Class or else Msg in Set_Server'Class then return Emit (F.Upper, Msg); elsif False or else Msg in Data_Expected'Class or else Msg in Data_Out'Class or else Msg in Disconnect_Request'Class or else Msg in Check_Validity'Class then return Emit (F.Lower, Msg); else raise Program_Error; end if; end Handle_Message; end PolyORB.Filters; polyorb-2.8~20110207.orig/src/polyorb-sequences.adb0000644000175000017500000004234711750740340021332 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . S E Q U E N C E S -- -- -- -- B o d y -- -- -- -- Copyright (C) 2002-2008, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- PolyORB.Sequences is the parent of the bounded and unbounded sequence -- packages. Some exceptions and types common to both are declared here -- (following the structure of Ada.Strings). -- -- Length_Error is raised when sequence lengths are exceeded. -- Pattern_Error is raised when a null pattern string is passed. -- Index_Error is raised when indexes are out of range. with System; package body PolyORB.Sequences is -- Constants for unbounded sequences allocation Initial_Size : constant := 3; Increment_Size : constant := 2; procedure Check_Length (Max_Length : Natural; Length : Natural; Drop : Truncation := Error); -- Raise Length_Error if Max_Length is non-zero and Length > Max_Length -- and Drop = Error -- Otherwise do nothing procedure Push (Prog : in out Program; A : Assignment); -- Append A as the last operation in P procedure Adjust_For_Max_Length (Prog : in out Program; Max_Length : Natural; Drop : Truncation); -- Adjust the assignments in Prog for a bounded sequence of maximum -- length Max_Length, according to the indicated truncation policy. -- For an unbounded sequence, this subprogram may be called with a -- zero Max_Length parameter, in which case it returns immediately, -- leaving Prog unchanged. --------------------------- -- Adjust_For_Max_Length -- --------------------------- procedure Adjust_For_Max_Length (Prog : in out Program; Max_Length : Natural; Drop : Truncation) is Drop_Length : Natural; begin if Max_Length = 0 or else Prog.Result_Length <= Max_Length then return; end if; Drop_Length := Prog.Result_Length - Max_Length; Prog.Result_Length := Max_Length; for PC in 0 .. Prog.Last loop declare A : Assignment renames Prog.Assignments (PC); begin case Drop is when Left => A.Target_Bounds.Lo := A.Target_Bounds.Lo - Drop_Length; A.Target_Bounds.Hi := A.Target_Bounds.Hi - Drop_Length; -- Case of an assignment that is entirely dropped -- (this assumes that at program execution time, -- Target'First is always 1 -- this is checked in Run). if A.Target_Bounds.Hi < 1 then A.Target_Bounds.Lo := 1; end if; if A.Target_Bounds.Lo < 1 then -- If Source is not replicated, adjust its bounds if Length (A.Target_Bounds) = Length (A.Source_Bounds) then A.Source_Bounds.Lo := A.Source_Bounds.Lo + 1 - A.Target_Bounds.Lo; end if; A.Target_Bounds.Lo := 1; end if; when Right => if A.Target_Bounds.Hi > Max_Length then -- Adjust source bounds if the source is not to be -- replicated. if A.Target_Bounds.Lo <= Max_Length and then Length (A.Target_Bounds) = Length (A.Source_Bounds) then A.Source_Bounds.Hi := A.Source_Bounds.Hi - (A.Target_Bounds.Hi - Max_Length); end if; -- Adjust target bounds in all cases A.Target_Bounds.Hi := Max_Length; end if; when Error => -- Already dealt with earlier, never reached raise Program_Error; end case; -- Check that we did not generate an invalid program pragma Assert (Length (A.Target_Bounds) = 0 or else Length (A.Target_Bounds) mod Length (A.Source_Bounds) = 0); end; end loop; end Adjust_For_Max_Length; ------------------ -- Check_Length -- ------------------ procedure Check_Length (Max_Length : Natural; Length : Natural; Drop : Truncation := Error) is begin if Max_Length > 0 and then Length > Max_Length and then Drop = Error then raise Length_Error; end if; end Check_Length; ----------------- -- Count_Index -- ----------------- function Count_Index (Check_Slice : Check_Slice_Function; Source : Bounds; Pattern : Bounds; What : Search_Kind; Going : Direction := Forward) return Natural is S_Length : constant Natural := Length (Source); P_Length : constant Natural := Length (Pattern); Matches : Natural := 0; From, To : Positive; Next : Natural; Step : Integer; begin if P_Length = 0 then raise Pattern_Error; end if; if S_Length < P_Length then return 0; end if; if Going = Forward then Step := 1; From := 1; To := S_Length - (P_Length - 1); else Step := -1; From := S_Length - (P_Length - 1); To := 1; end if; loop if Check_Slice (From, From + P_Length - 1) then if What = Return_Index then return From; else Matches := Matches + 1; end if; Next := From + Step * P_Length; else Next := From + Step; end if; exit when (Going = Forward and then Next > To) or else (Going = Backward and then Next < To); From := Next; end loop; return Matches; end Count_Index; ----------- -- Round -- ----------- function Round (Length : Natural) return Natural is Times : Natural; begin if Length = 0 then return 0; elsif Length <= Initial_Size then return Initial_Size; else Times := ((Length - Initial_Size) / Increment_Size) + 1; return Initial_Size + (Increment_Size * Times); end if; end Round; --------------- -- Head_Tail -- --------------- function Head_Tail (Max_Length : Natural; Source : Bounds; Count : Natural; Drop : Truncation := Error; What : Extremity; Suppress_Padding : Boolean := False) return Program is Prog : Program; Source_Length : constant Natural := Length (Source); Copy_Length : Natural; Target_Low, Target_High, Source_Low, Source_High : Integer; begin Check_Length (Max_Length, Count, Drop); Prog.Result_Length := Count; -- Copy requested elements if Source_Length < Count then Copy_Length := Source_Length; else Copy_Length := Count; end if; if What = Head then Target_Low := 1; Source_Low := 1; else Target_Low := Count - Copy_Length + 1; Source_Low := Source_Length - Copy_Length + 1; end if; Source_High := Source_Low + Copy_Length - 1; Target_High := Target_Low + Copy_Length - 1; Push (Prog, (Source => Left, Target_Bounds => (Target_Low, Target_High), Source_Bounds => (Source_Low, Source_High))); -- Add padding for remaining elements, unless suppressed if not Suppress_Padding then if What = Head then Target_Low := Copy_Length + 1; Target_High := Count; else Target_Low := 1; Target_High := Count - Copy_Length; end if; Push (Prog, (Source => Right, Target_Bounds => (Target_Low, Target_High), Source_Bounds => (1, 1))); end if; -- Adjust for bounded case Adjust_For_Max_Length (Prog, Max_Length, Drop); return Prog; end Head_Tail; ------------ -- Length -- ------------ function Length (Index_Range : Bounds) return Natural is begin if Index_Range.Hi < Index_Range.Lo then return 0; else return Index_Range.Hi - Index_Range.Lo + 1; end if; end Length; ---------- -- Push -- ---------- procedure Push (Prog : in out Program; A : Assignment) is begin -- No need to add an operation that has no effect if Length (A.Target_Bounds) = 0 then return; end if; Prog.Last := Prog.Last + 1; Prog.Assignments (Prog.Last) := A; end Push; ------------------- -- Replace_Slice -- ------------------- function Replace_Slice (Max_Length : Natural; Source : Bounds; Slice : Bounds; By : Bounds; Drop : Truncation := Error) return Program is Prog : Program; Old_Length : constant Natural := Length (Source); Slice_Length : Natural := Length (Slice); By_Length : constant Natural := Length (By); Low : Positive renames Slice.Lo; High : Natural renames Slice.Hi; begin if Low > Source.Hi + 1 or else High < Source.Lo - 1 then raise Index_Error; end if; -- Slice.Hi may be out of Source's range, in which case we need to -- normalize Slice_Length. if Slice.Hi > Source.Hi then Slice_Length := Slice_Length - (Slice.Hi - Source.Hi); end if; Check_Length (Max_Length, Old_Length + By_Length - Slice_Length, Drop); Prog.Result_Length := Old_Length + By_Length - Slice_Length; Push (Prog, Assignment'( Source => Left, Target_Bounds => (1, Low - 1), Source_Bounds => (1, Low - 1))); Push (Prog, Assignment'(Source => Left, Target_Bounds => (Low + By_Length, Prog.Result_Length), Source_Bounds => (Low + Slice_Length, Old_Length))); if By_Length > 0 then Push (Prog, Assignment'( Source => Right, Target_Bounds => (Low, Low + By_Length - 1), Source_Bounds => By)); end if; Adjust_For_Max_Length (Prog, Max_Length, Drop); return Prog; end Replace_Slice; --------------- -- Replicate -- --------------- function Replicate (Max_Length : Natural; Count : Natural; Item : Bounds; Drop : Truncation := Error) return Program is Prog : Program; Total_Length : Natural := Count * Length (Item); Integral_Count : Natural; Integral_Bounds : Bounds; -- Bounds of the slice of the target that is to be filled with integral -- copies of Item. Fraction_Target_Bounds : Bounds; -- Bounds of the slice of the target that is to be filled with a -- fraction if Item. Fraction_Source_Bounds : Bounds; -- Bounds of the corresponding Item slice begin Check_Length (Max_Length, Total_Length, Drop); if Max_Length > 0 and then Total_Length > Max_Length then Total_Length := Max_Length; end if; -- Case of replicating an element array of zero length: return an empty -- sequence. if Length (Item) = 0 then Prog.Result_Length := 0; return Prog; end if; Integral_Count := Total_Length / Length (Item); -- Here we cannot just generate one (replicated) assignment of item -- into target, because we might require a truncated copy. -- First compute the integral copies bounds Integral_Bounds.Lo := 1; Integral_Bounds.Hi := Length (Item) * Integral_Count; -- In the case of a bounded sequence, we might need to generate a -- copy of a fragment of Item. if Max_Length > 0 and then Integral_Bounds.Hi < Total_Length then if Drop = Left then -- In the Drop = Left case, the integral copies are at the end, -- not at the beginning, so shift them. Integral_Bounds.Lo := Total_Length - Integral_Bounds.Hi + 1; Integral_Bounds.Hi := Total_Length; Fraction_Target_Bounds := (1, Integral_Bounds.Lo - 1); Fraction_Source_Bounds := (Item.Hi - Length (Fraction_Target_Bounds) + 1, Item.Hi); else Fraction_Target_Bounds := (Integral_Bounds.Hi + 1, Max_Length); Fraction_Source_Bounds := (Item.Lo, Item.Lo + Length (Fraction_Target_Bounds) - 1); end if; Push (Prog, Assignment'( Source => Left, Target_Bounds => Fraction_Target_Bounds, Source_Bounds => Fraction_Source_Bounds)); end if; Push (Prog, Assignment'( Source => Left, Target_Bounds => Integral_Bounds, Source_Bounds => Item)); Prog.Result_Length := Total_Length; return Prog; end Replicate; --------- -- Run -- --------- procedure Run (Prog : Program; Target : out Element_Array; Left : Element_Array; Right : Element_Array) is use type System.Address; In_Place : constant Boolean := Target'Address = Left'Address; procedure Assign (Source : Element_Array; Source_Bounds : Bounds; Target_Bounds : Bounds); -- Assign the slice of Source defined by Source_Bounds into the slice -- of Target defined by Target_Bounds, replicating the source slice -- if necessary. ------------ -- Assign -- ------------ procedure Assign (Source : Element_Array; Source_Bounds : Bounds; Target_Bounds : Bounds) is Source_Len_Minus_1 : constant Natural := Source_Bounds.Hi - Source_Bounds.Lo; Target_Lo : Integer := Target_Bounds.Lo; Target_Lo_Last : constant Integer := Target_Bounds.Hi - Source_Len_Minus_1; begin -- Check that we do not leave any element of the target unassigned pragma Assert (Sequences.Length (Target_Bounds) mod Sequences.Length (Source_Bounds) = 0); -- Perform as many assignments of the source slice as necessary into -- the target. while Target_Lo <= Target_Lo_Last loop Target (Target_Lo .. Target_Lo + Source_Len_Minus_1) := Source (Source_Bounds.Lo .. Source_Bounds.Hi); Target_Lo := Target_Lo + Source_Len_Minus_1 + 1; end loop; end Assign; -- Start of processing for Run begin pragma Assert (Target'First = 1); for PC in 0 .. Prog.Last loop declare A : Assignment renames Prog.Assignments (PC); begin if A.Target_Bounds.Lo <= A.Target_Bounds.Hi then case A.Source is when Sequences.Left => if not (In_Place and then A.Target_Bounds = A.Source_Bounds) then Assign (Left, A.Source_Bounds, A.Target_Bounds); end if; when Sequences.Right => Assign (Right, A.Source_Bounds, A.Target_Bounds); end case; end if; end; end loop; end Run; end PolyORB.Sequences; polyorb-2.8~20110207.orig/src/polyorb-utils-buffers.ads0000644000175000017500000001007711750740340022145 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . U T I L S . B U F F E R S -- -- -- -- S p e c -- -- -- -- Copyright (C) 2001-2009, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- Utility subprograms for data representation methods and buffer access. with Ada.Streams; with PolyORB.Buffers; package PolyORB.Utils.Buffers is pragma Elaborate_Body; use PolyORB.Buffers; use Ada.Streams; ---------------------------------------------------- -- Marshalling/unmarshalling of elementary types -- ---------------------------------------------------- -- This generic package provides marshalling and unmarshalling operations -- that transfer the memory representation of T to/from the buffer, -- with optional alignment (equal to the data size), and performing byte -- swapping if the buffer endianness differs from the host order. generic type T is private; with function Swapped (Item : T) return T is <>; With_Alignment : Boolean := True; -- If With_Alignment is False, then don't align the buffer prior to -- transfers in the routines below. package Align_Transfer_Elementary is procedure Marshall (Buffer : access Buffer_Type; Item : T); -- Align buffer on T'Size, then marshall a copy of Item, swapping its -- bytes using the provided procedure if Buffer's endianness is not -- Host_Order. function Unmarshall (Buffer : access Buffer_Type) return T; -- Align buffer on T'Size, then unmarshall a T value, swapping its bytes -- using the provided swapper if Buffer's endianness is not Host_Order. end Align_Transfer_Elementary; procedure Align_Marshall_Copy (Buffer : access Buffer_Type; Octets : Stream_Element_Array; Alignment : Alignment_Type := Align_1); -- Align Buffer on Alignment, then marshall a copy of Octets into it, as is procedure Align_Unmarshall_Copy (Buffer : access Buffer_Type; Alignment : Alignment_Type := Align_1; Data : out Stream_Element_Array); -- Align Buffer on Alignment, then fill Data by extracting Data'Length -- bytes at the current position. The data need not be contiguous in the -- in (it may span multiple chunks). end PolyORB.Utils.Buffers; polyorb-2.8~20110207.orig/src/polyorb-transport-connected-sockets.ads0000644000175000017500000001117411750740340025017 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . T R A N S P O R T . C O N N E C T E D . S O C K E T S -- -- -- -- S p e c -- -- -- -- Copyright (C) 2001-2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- Socket implementation of transport service access points -- and communication endpoints. with PolyORB.Sockets; with PolyORB.Tasking.Mutexes; with PolyORB.Utils.Sockets; package PolyORB.Transport.Connected.Sockets is pragma Elaborate_Body; use PolyORB.Sockets; type Socket_Access_Point is new Connected_Transport_Access_Point with private; -- A listening transport service access point as -- a listening stream-oriented socket. procedure Create (SAP : in out Socket_Access_Point; Socket : Socket_Type; Address : in out Sock_Addr_Type); -- Initialise SAP: bind Socket to Address, listen on it, -- and set up the corresponding Socket_Access_Point. -- On entry, Address.Port may be Any_Port, in which case the system -- will assign an available port number itself. On return, -- Address is always set to the actual address used. function Create_Event_Source (TAP : access Socket_Access_Point) return Asynch_Ev.Asynch_Ev_Source_Access; procedure Accept_Connection (TAP : Socket_Access_Point; TE : out Transport_Endpoint_Access); function Address_Of (SAP : Socket_Access_Point) return Utils.Sockets.Socket_Name; -- Return a socket name denoting SAP type Socket_Endpoint is new Transport_Endpoint with private; -- An opened transport endpoint as a connected stream-oriented socket procedure Create (TE : in out Socket_Endpoint; S : Socket_Type); function Create_Event_Source (TE : access Socket_Endpoint) return Asynch_Ev.Asynch_Ev_Source_Access; function Is_Data_Available (TE : Socket_Endpoint; N : Natural) return Boolean; procedure Read (TE : in out Socket_Endpoint; Buffer : Buffers.Buffer_Access; Size : in out Ada.Streams.Stream_Element_Count; Error : out Errors.Error_Container); procedure Write (TE : in out Socket_Endpoint; Buffer : Buffers.Buffer_Access; Error : out Errors.Error_Container); procedure Close (TE : access Socket_Endpoint); procedure Destroy (TE : in out Socket_Endpoint); procedure Check_Validity (TE : access Socket_Endpoint); private type Socket_Access_Point is new Connected_Transport_Access_Point with record Socket : Socket_Type := No_Socket; Addr : Sock_Addr_Type; end record; type Socket_Endpoint is new Connected_Transport_Endpoint with record Socket : Socket_Type := No_Socket; Addr : Sock_Addr_Type; Mutex : Tasking.Mutexes.Mutex_Access; end record; end PolyORB.Transport.Connected.Sockets; polyorb-2.8~20110207.orig/src/polyorb-tasking-profiles-no_tasking-threads.ads0000644000175000017500000001264011750740340026414 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- POLYORB.TASKING.PROFILES.NO_TASKING.THREADS -- -- -- -- S p e c -- -- -- -- Copyright (C) 2002-2008, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- Implementation of PolyORB.Tasking.Threads for the No_Tasking profile. with System; with PolyORB.Tasking.Threads; package PolyORB.Tasking.Profiles.No_Tasking.Threads is package PTT renames PolyORB.Tasking.Threads; ---------------------------- -- No_Tasking_Thread Type -- ---------------------------- type No_Tasking_Thread_Type is new PTT.Thread_Type with private; type No_Tasking_Thread_Access is access all No_Tasking_Thread_Type'Class; function Get_Thread_Id (T : access No_Tasking_Thread_Type) return PTT.Thread_Id; -- Under No_Tasking profile, this function simply return -- Null_Thread_Id. ------------------------------- -- No_Tasking_Thread_Factory -- ------------------------------- type No_Tasking_Thread_Factory_Type is new PTT.Thread_Factory_Type with private; type No_Tasking_Thread_Factory_Access is access all No_Tasking_Thread_Factory_Type'Class; The_Thread_Factory : constant No_Tasking_Thread_Factory_Access; function Run_In_Task (TF : access No_Tasking_Thread_Factory_Type; Name : String := ""; Default_Priority : System.Any_Priority := System.Default_Priority; Storage_Size : Natural := 0; R : PTT.Runnable_Access) return PTT.Thread_Access; -- This function has no sense in No_Tasking profile. -- It simply raises a Tasking_Error. function Run_In_Task (TF : access No_Tasking_Thread_Factory_Type; Name : String := ""; Default_Priority : System.Any_Priority := System.Default_Priority; Storage_Size : Natural := 0; P : PTT.Parameterless_Procedure) return PTT.Thread_Access; -- This function has no sense in No_Tasking profile. -- It simply raises a Tasking_Error. function Get_Current_Thread_Id (TF : access No_Tasking_Thread_Factory_Type) return PTT.Thread_Id; -- Under No_Tasking profile, this function simply return -- Null_Thread_Id. function Thread_Id_Image (TF : access No_Tasking_Thread_Factory_Type; TID : PTT.Thread_Id) return String; -- Under No_Tasking profile, this function simply return -- "main_task". procedure Set_Priority (TF : access No_Tasking_Thread_Factory_Type; T : PTT.Thread_Id; P : System.Any_Priority); pragma No_Return (Set_Priority); -- Setting priority has no meaning under this profile, raise Tasking_Error function Get_Priority (TF : access No_Tasking_Thread_Factory_Type; T : PTT.Thread_Id) return System.Any_Priority; -- Getting priority has no meaning under this profile, raise Tasking_Error procedure Relative_Delay (TF : access No_Tasking_Thread_Factory_Type; D : Duration); function Awake_Count (TF : access No_Tasking_Thread_Factory_Type) return Natural; -- This function always return 1 under No_Tasking profile function Independent_Count (TF : access No_Tasking_Thread_Factory_Type) return Natural; -- This function always return 0 under No_Tasking profile private type No_Tasking_Thread_Type is new PTT.Thread_Type with null record; type No_Tasking_Thread_Factory_Type is new PTT.Thread_Factory_Type with null record; The_Thread_Factory : constant No_Tasking_Thread_Factory_Access := new No_Tasking_Thread_Factory_Type; end PolyORB.Tasking.Profiles.No_Tasking.Threads; polyorb-2.8~20110207.orig/src/polyorb-orb_controller-no_tasking.adb0000644000175000017500000002201511750740340024504 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . O R B _ C O N T R O L L E R . N O _ T A S K I N G -- -- -- -- B o d y -- -- -- -- Copyright (C) 2004-2008, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with Ada.Tags; with PolyORB.Initialization; with PolyORB.Utils.Strings; package body PolyORB.ORB_Controller.No_Tasking is use PolyORB.Task_Info; use PolyORB.Asynch_Ev; --------------------- -- Disable_Polling -- --------------------- procedure Disable_Polling (O : access ORB_Controller_No_Tasking; M : PAE.Asynch_Ev_Monitor_Access) is pragma Unreferenced (O); pragma Unreferenced (M); begin -- Under this implementation, there is at most one task in the -- partition. Thus, there cannot be one task polling while another -- requests polling to be disabled. null; end Disable_Polling; -------------------- -- Enable_Polling -- -------------------- procedure Enable_Polling (O : access ORB_Controller_No_Tasking; M : PAE.Asynch_Ev_Monitor_Access) is pragma Unreferenced (O); pragma Unreferenced (M); begin -- Under this implementation, there is at most one task in the -- partition. Thus, there cannot be one task polling while another -- requests polling to be disabled. null; end Enable_Polling; ------------------ -- Notify_Event -- ------------------ procedure Notify_Event (O : access ORB_Controller_No_Tasking; E : Event) is begin pragma Debug (C1, O1 ("Notify_Event: " & Event_Kind'Image (E.Kind))); case E.Kind is when End_Of_Check_Sources => declare AEM_Index : constant Natural := Index (O.all, E.On_Monitor); begin -- A task completed polling on a monitor pragma Debug (C1, O1 ("End of check sources on monitor #" & Natural'Image (AEM_Index) & Ada.Tags.External_Tag (O.AEM_Infos (AEM_Index).Monitor.all'Tag))); -- Reset TI O.AEM_Infos (AEM_Index).TI := null; end; when Event_Sources_Added => declare AEM_Index : Natural := Index (O.all, E.Add_In_Monitor); begin if AEM_Index = 0 then -- This monitor was not yet registered, register it pragma Debug (C1, O1 ("Adding new monitor")); for J in O.AEM_Infos'Range loop if O.AEM_Infos (J).Monitor = null then O.AEM_Infos (J).Monitor := E.Add_In_Monitor; AEM_Index := J; exit; end if; end loop; end if; pragma Debug (C1, O1 ("Added monitor at index:" & AEM_Index'Img & " " & Ada.Tags.External_Tag (O.AEM_Infos (AEM_Index).Monitor.all'Tag))); end; when Event_Sources_Deleted => -- An AES has been removed from monitored AES list null; when Job_Completed => -- A task has completed the execution of a job null; when ORB_Shutdown => -- ORB shutdown has been requested O.Shutdown := True; when Queue_Event_Job => -- Queue event to main job queue PJ.Queue_Job (O.Job_Queue, E.Event_Job); when Queue_Request_Job => -- XXX Should we allow the use of a request scheduler for -- this policy ? -- Queue event to main job queue PJ.Queue_Job (O.Job_Queue, E.Request_Job); when Request_Result_Ready => -- Nothing to do. The task will be notified the next time it asks -- for scheduling. null; when Idle_Awake => -- No task should go idle. Receiving this event denotes an -- internal error. raise Program_Error; when Task_Registered => null; -- Under this implementation, there is only one task registered -- with the ORB. when Task_Unregistered => Note_Task_Unregistered (O); end case; pragma Debug (C2, O2 (Status (O.all))); end Notify_Event; ------------------- -- Schedule_Task -- ------------------- procedure Schedule_Task (O : access ORB_Controller_No_Tasking; TI : PTI.Task_Info_Access) is begin pragma Debug (C1, O1 ("Schedule_Task: enter")); if State (TI.all) = Terminated then pragma Debug (C1, O1 ("Schedule_Task: task is terminated")); return; end if; Set_State_Unscheduled (O.Summary, TI.all); -- Recompute TI status if Exit_Condition (TI.all) or else (O.Shutdown and then not Has_Pending_Job (O) and then TI.Kind = Permanent) then Set_State_Terminated (O.Summary, TI.all); pragma Debug (C1, O1 ("Task is now terminated")); pragma Debug (C2, O2 (Status (O.all))); elsif Has_Pending_Job (O) then Set_State_Running (O.Summary, TI.all, PJ.Fetch_Job (O.Job_Queue)); pragma Debug (C1, O1 ("Task is now running a job")); pragma Debug (C2, O2 (Status (O.all))); else declare AEM_Index : constant Natural := Need_Polling_Task (O); begin pragma Assert (AEM_Index /= 0); O.AEM_Infos (AEM_Index).Polling_Scheduled := False; O.AEM_Infos (AEM_Index).TI := TI; Set_State_Blocked (O.Summary, TI.all, O.AEM_Infos (AEM_Index).Monitor, O.AEM_Infos (AEM_Index).Polling_Timeout); pragma Debug (C1, O1 ("Task is now blocked on monitor" & Natural'Image (AEM_Index) & " " & Ada.Tags.External_Tag (O.AEM_Infos (AEM_Index).Monitor.all'Tag))); pragma Debug (C2, O2 (Status (O.all))); end; end if; end Schedule_Task; ------------ -- Create -- ------------ function Create (OCF : ORB_Controller_No_Tasking_Factory) return ORB_Controller_Access is pragma Unreferenced (OCF); OC : ORB_Controller_No_Tasking_Access; RS : PRS.Request_Scheduler_Access; begin PRS.Create (RS); OC := new ORB_Controller_No_Tasking (RS); Initialize (ORB_Controller (OC.all)); return ORB_Controller_Access (OC); end Create; ---------------- -- Initialize -- ---------------- procedure Initialize; procedure Initialize is begin Register_ORB_Controller_Factory (OCF); end Initialize; use PolyORB.Initialization; use PolyORB.Initialization.String_Lists; use PolyORB.Utils.Strings; begin Register_Module (Module_Info' (Name => +"orb_controller.no_tasking", Conflicts => Empty, Depends => +"orb.no_tasking", Provides => +"orb_controller!", Implicit => False, Init => Initialize'Access, Shutdown => null)); end PolyORB.ORB_Controller.No_Tasking; polyorb-2.8~20110207.orig/src/polyorb-rt_poa_policies-thread_pool_policy.adb0000644000175000017500000001142211750740340026355 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- POLYORB.RT_POA_POLICIES.THREAD_POOL_POLICY -- -- -- -- B o d y -- -- -- -- Copyright (C) 2004-2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with PolyORB.Annotations; package body PolyORB.RT_POA_Policies.Thread_Pool_Policy is type Thread_Pool_Policy_Note is new PolyORB.Annotations.Note with record Lanes : PolyORB.Lanes.Lane_Root_Access; end record; Default_TPP : constant Thread_Pool_Policy_Note := (PolyORB.Annotations.Note with Lanes => null); ------------ -- Create -- ------------ function Create (Lanes : Lane_Root_Access) return Policy_Access is Result : constant Policy_Access := new ThreadPoolPolicy; TResult : ThreadPoolPolicy renames ThreadPoolPolicy (Result.all); begin TResult.Lanes := Lanes; return Result; end Create; --------------- -- Policy_Id -- --------------- function Policy_Id (Self : ThreadPoolPolicy) return String is pragma Unreferenced (Self); begin return "THREAD_POOL_POLICY"; end Policy_Id; ------------------------- -- Check_Compatibility -- ------------------------- procedure Check_Compatibility (Self : ThreadPoolPolicy; Other_Policies : AllPolicies; Error : in out PolyORB.Errors.Error_Container) is pragma Unreferenced (Self); pragma Unreferenced (Other_Policies); pragma Unreferenced (Error); begin null; end Check_Compatibility; ---------------------- -- Get_Servant_Lane -- ---------------------- function Get_Servant_Lane (Servant : PolyORB.Servants.Servant_Access) return Lane_Root_Access is Notepad : constant PolyORB.Annotations.Notepad_Access := PolyORB.Servants.Notepad_Of (Servant); Note : Thread_Pool_Policy_Note; begin PolyORB.Annotations.Get_Note (Notepad.all, Note, Default_TPP); if Note /= Default_TPP then return Note.Lanes; else return null; end if; end Get_Servant_Lane; ---------------------- -- Set_Servant_Lane -- ---------------------- procedure Set_Servant_Lane (Self : ThreadPoolPolicy; Servant : PolyORB.Servants.Servant_Access) is Notepad : constant PolyORB.Annotations.Notepad_Access := PolyORB.Servants.Notepad_Of (Servant); Note : Thread_Pool_Policy_Note; begin PolyORB.Annotations.Get_Note (Notepad.all, Note, Default_TPP); if Note = Default_TPP then Note.Lanes := Self.Lanes; PolyORB.Annotations.Set_Note (Notepad.all, Note); end if; end Set_Servant_Lane; ----------------------- -- Is_Valid_Priority -- ----------------------- function Is_Valid_Priority (Self : ThreadPoolPolicy; Priority : External_Priority) return Boolean is begin return Is_Valid_Priority (Self.Lanes, Priority); end Is_Valid_Priority; end PolyORB.RT_POA_Policies.Thread_Pool_Policy; polyorb-2.8~20110207.orig/src/polyorb-binding_data.adb0000644000175000017500000001401111750740340021725 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . B I N D I N G _ D A T A -- -- -- -- B o d y -- -- -- -- Copyright (C) 2001-2011, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- Management of binding data, i. e. the elements of information that denote -- the association of a middleware TSAP address, a protocol, and an object id, -- together constituting a profile. with Ada.Tags; with Ada.Unchecked_Deallocation; with PolyORB.Log; with PolyORB.ORB; with PolyORB.Setup; package body PolyORB.Binding_Data is use PolyORB.Log; package L is new PolyORB.Log.Facility_Log ("polyorb.binding_data"); procedure O (Message : String; Level : Log_Level := Debug) renames L.Output; function C (Level : Log_Level := Debug) return Boolean renames L.Enabled; --------------------- -- Destroy_Profile -- --------------------- procedure Destroy_Profile (P : in out Profile_Access) is procedure Free is new Ada.Unchecked_Deallocation (Profile_Type'Class, Profile_Access); begin pragma Assert (P /= null); pragma Debug (C, O ("Destroying profile of type " & Ada.Tags.External_Tag (P'Tag))); Release (P.all); Free (P); end Destroy_Profile; ------------ -- Get_OA -- ------------ function Get_OA (Profile : Profile_Type) return PolyORB.Smart_Pointers.Entity_Ptr is pragma Unreferenced (Profile); begin return PolyORB.Smart_Pointers.Entity_Ptr (PolyORB.ORB.Object_Adapter (PolyORB.Setup.The_ORB)); end Get_OA; -------------------- -- Get_Object_Key -- -------------------- function Get_Object_Key (Profile : Profile_Type) return Objects.Object_Id_Access is begin return Profile.Object_Id; end Get_Object_Key; ---------------------- -- Is_Local_Profile -- ---------------------- function Is_Local_Profile (P : Profile_Type'Class) return Boolean is begin return P.Known_Local; end Is_Local_Profile; -------------------------- -- Is_Multicast_Profile -- -------------------------- function Is_Multicast_Profile (P : Profile_Type) return Boolean is pragma Unreferenced (P); begin return False; end Is_Multicast_Profile; ---------------- -- Notepad_Of -- ---------------- function Notepad_Of (Prof : access Profile_Type) return Annotations.Notepad_Access is begin return Prof.Notepad'Access; end Notepad_Of; --------------- -- Same_Node -- --------------- function Same_Node (Left : Profile_Type'Class; Right : Profile_Type'Class) return Boolean is begin -- Is_Colocated depends on the order of the arguments. -- Imagine we want to compare a Neighbour profile (N) and a -- SOAP profile (S). N binds to a binding object with a profile on the -- same node than S. -- Is_Colocated (S, N) will return False because the derived -- Is_Colocated for SOAP profiles does not know how to manage neighbour -- profiles. But Is_Colocated (N, S) will return True as the derived -- Is_Colocated for Neighbour profiles does extract the true profile of -- N from its Binding_Object. -- Same_Node takes into account both the derived Is_Colocated for Left -- and Right. Same_Node is therefore a symmetric predicate. return Is_Colocated (Left => Left, Right => Right) or else Is_Colocated (Left => Right, Right => Left); end Same_Node; --------------------- -- Same_Object_Key -- --------------------- function Same_Object_Key (Left, Right : Profile_Type'Class) return Boolean is use PolyORB.Objects; begin if Left.Object_Id = null or else Right.Object_Id = null then return False; else return Left.Object_Id.all = Right.Object_Id.all; end if; end Same_Object_Key; ---------------------- -- Set_Continuation -- ---------------------- procedure Set_Continuation (Prof : access Profile_Type; Continuation : PolyORB.Smart_Pointers.Ref) is begin pragma Assert (Smart_Pointers.Is_Nil (Prof.Continuation)); Prof.Continuation := Continuation; end Set_Continuation; end PolyORB.Binding_Data; polyorb-2.8~20110207.orig/src/polyorb-log-stderr.ads0000644000175000017500000000421011750740340021425 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . L O G . S T D E R R -- -- -- -- S p e c -- -- -- -- Copyright (C) 2004 Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- Logging facility on Standard error output package PolyORB.Log.Stderr is pragma Elaborate_Body; end PolyORB.Log.Stderr; polyorb-2.8~20110207.orig/src/polyorb-tasking-profiles-no_tasking-threads-annotations.ads0000644000175000017500000000517511750740340030754 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- POLYORB.TASKING.PROFILES.NO_TASKING.THREADS.ANNOTATIONS -- -- -- -- S p e c -- -- -- -- Copyright (C) 2004 Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by ACT Europe. -- -- (email: sales@act-europe.fr) -- -- -- ------------------------------------------------------------------------------ with PolyORB.Annotations; with PolyORB.Tasking.Threads.Annotations; package PolyORB.Tasking.Profiles.No_Tasking.Threads.Annotations is type No_Tasking_TAF is new PolyORB.Tasking.Threads.Annotations.Thread_Annotations_Factory with private; type No_Tasking_TAF_Access is access all No_Tasking_TAF; function Get_Current_Thread_Notepad (TAF : access No_Tasking_TAF) return PolyORB.Annotations.Notepad_Access; private type No_Tasking_TAF is new PolyORB.Tasking.Threads.Annotations.Thread_Annotations_Factory with null record; end PolyORB.Tasking.Profiles.No_Tasking.Threads.Annotations; polyorb-2.8~20110207.orig/src/polyorb-binding_data-local.ads0000644000175000017500000000662611750740340023053 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . B I N D I N G _ D A T A . L O C A L -- -- -- -- S p e c -- -- -- -- Copyright (C) 2001-2011, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- Profile type for objects registered with the local ORB with PolyORB.Objects; package PolyORB.Binding_Data.Local is pragma Elaborate_Body; type Local_Profile_Type is new Profile_Type with private; procedure Release (P : in out Local_Profile_Type); procedure Create_Local_Profile (Oid : Objects.Object_Id; P : out Local_Profile_Type); function Duplicate_Profile (P : Local_Profile_Type) return Profile_Access; procedure Bind_Profile (Profile : access Local_Profile_Type; The_ORB : Components.Component_Access; QoS : PolyORB.QoS.QoS_Parameters; BO_Ref : out Smart_Pointers.Ref; Error : out Errors.Error_Container); function Get_Profile_Tag (Profile : Local_Profile_Type) return Profile_Tag; pragma Inline (Get_Profile_Tag); function Get_Profile_Preference (Profile : Local_Profile_Type) return Profile_Preference; pragma Inline (Get_Profile_Preference); function Image (Prof : Local_Profile_Type) return String; function Is_Colocated (Left : Local_Profile_Type; Right : Profile_Type'Class) return Boolean; -- Since Local profiles are not associated with any -- transport endpoint, there is no need to define -- an associated Profile_Factory. private type Local_Profile_Type is new Profile_Type with null record; end PolyORB.Binding_Data.Local; polyorb-2.8~20110207.orig/src/polyorb-poa_policies-id_assignment_policy-user.adb0000644000175000017500000001565111750740340027160 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- POLYORB.POA_POLICIES.ID_ASSIGNMENT_POLICY.USER -- -- -- -- B o d y -- -- -- -- Copyright (C) 2002-2008, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with PolyORB.Log; with PolyORB.Objects; with PolyORB.Object_Maps.User; with PolyORB.POA; with PolyORB.POA_Policies.Lifespan_Policy; with PolyORB.POA_Types; with PolyORB.Types; package body PolyORB.POA_Policies.Id_Assignment_Policy.User is use PolyORB.Log; package L is new Log.Facility_Log ("polyorb.poa_policies.id_assignement_policy.user"); procedure O (Message : Standard.String; Level : Log_Level := Debug) renames L.Output; function C (Level : Log_Level := Debug) return Boolean renames L.Enabled; ------------ -- Create -- ------------ function Create return User_Id_Policy_Access is begin return new User_Id_Policy; end Create; ------------------------- -- Check_Compatibility -- ------------------------- procedure Check_Compatibility (Self : User_Id_Policy; Other_Policies : AllPolicies; Error : in out PolyORB.Errors.Error_Container) is pragma Warnings (Off); pragma Unreferenced (Self, Other_Policies, Error); pragma Warnings (On); begin null; -- No rule to check end Check_Compatibility; --------------- -- Policy_Id -- --------------- function Policy_Id (Self : User_Id_Policy) return String is pragma Warnings (Off); pragma Unreferenced (Self); pragma Warnings (On); begin return "ID_ASSIGNMENT_POLICY.USER_ID"; end Policy_Id; ----------------------- -- Create_Object_Map -- ----------------------- function Create_Object_Map (Self : User_Id_Policy) return PolyORB.Object_Maps.Object_Map_Access is pragma Warnings (Off); pragma Unreferenced (Self); pragma Warnings (On); Result : constant PolyORB.Object_Maps.Object_Map_Access := new PolyORB.Object_Maps.User.User_Object_Map; begin PolyORB.Object_Maps.Initialize (Result.all); return Result; end Create_Object_Map; ------------------------------ -- Assign_Object_Identifier -- ------------------------------ procedure Assign_Object_Identifier (Self : User_Id_Policy; OA : PolyORB.POA_Types.Obj_Adapter_Access; Hint : Object_Id_Access; U_Oid : out Unmarshalled_Oid; Error : in out PolyORB.Errors.Error_Container) is pragma Warnings (Off); pragma Unreferenced (Self); pragma Warnings (On); use PolyORB.Errors; use PolyORB.POA_Policies.Lifespan_Policy; use PolyORB.Types; POA : constant PolyORB.POA.Obj_Adapter_Access := PolyORB.POA.Obj_Adapter_Access (OA); begin pragma Debug (C, O ("Assign_Object_Identifier: enter")); if Hint = null then pragma Debug (C, O ("Hint is null !")); Throw (Error, WrongPolicy_E, Null_Member); return; end if; pragma Debug (C, O ("Object Name is '" & PolyORB.Objects.Oid_To_Hex_String (Hint.all) & "'")); U_Oid := PolyORB.POA_Types.Create_Id (Name => PolyORB.Objects.Oid_To_Hex_String (Hint.all), System_Generated => False, Persistency_Flag => Get_Lifespan_Cookie (POA.Lifespan_Policy.all, OA), Creator => POA.Absolute_Address.all); pragma Debug (C, O ("Assign_Object_Identifier: leave")); end Assign_Object_Identifier; ----------------------------------- -- Reconstruct_Object_Identifier -- ----------------------------------- procedure Reconstruct_Object_Identifier (Self : User_Id_Policy; OA : Obj_Adapter_Access; Oid : Object_Id; U_Oid : out Unmarshalled_Oid; Error : in out PolyORB.Errors.Error_Container) is pragma Unreferenced (Self); pragma Unreferenced (Error); use PolyORB.POA_Policies.Lifespan_Policy; use PolyORB.Types; POA : constant PolyORB.POA.Obj_Adapter_Access := PolyORB.POA.Obj_Adapter_Access (OA); begin U_Oid := PolyORB.POA_Types.Create_Id (Name => PolyORB.Objects.Oid_To_Hex_String (Oid), System_Generated => False, Persistency_Flag => Get_Lifespan_Cookie (POA.Lifespan_Policy.all, OA), Creator => POA.Absolute_Address.all); end Reconstruct_Object_Identifier; ----------------------- -- Object_Identifier -- ----------------------- procedure Object_Identifier (Self : User_Id_Policy; Oid : Object_Id_Access; Result : out Object_Id_Access; Error : in out PolyORB.Errors.Error_Container) is use PolyORB.Errors; pragma Unreferenced (Self); U_Oid : Unmarshalled_Oid; begin Oid_To_U_Oid (Oid.all, U_Oid, Error); if Found (Error) then return; end if; Result := new Object_Id' (PolyORB.Objects.Hex_String_To_Oid (PolyORB.Types.To_Standard_String (U_Oid.Id))); end Object_Identifier; end PolyORB.POA_Policies.Id_Assignment_Policy.User; polyorb-2.8~20110207.orig/src/polyorb-log-initialization.adb0000644000175000017500000000477711750740340023152 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . L O G . I N I T I A L I Z A T I O N -- -- -- -- B o d y -- -- -- -- Copyright (C) 2005-2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with PolyORB.Initialization; with PolyORB.Utils.Strings; package body PolyORB.Log.Initialization is use PolyORB.Initialization; use PolyORB.Initialization.String_Lists; use PolyORB.Utils.Strings; begin Register_Module (Module_Info' (Name => +"log", Conflicts => Empty, Depends => +"log_sink", Provides => Empty, Implicit => True, Init => PolyORB.Log.Initialize'Access, Shutdown => null)); end PolyORB.Log.Initialization; polyorb-2.8~20110207.orig/src/polyorb-references-uri.ads0000644000175000017500000000614411750740340022271 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . R E F E R E N C E S . U R I -- -- -- -- S p e c -- -- -- -- Copyright (C) 2003-2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with PolyORB.Binding_Data; package PolyORB.References.URI is subtype URI_Type is PolyORB.References.Ref; ------------------------------ -- Object reference <-> URI -- ------------------------------ function Object_To_String_With_Best_Profile (URI : URI_Type) return String; -- Returns the URI string for the best profile function Object_To_String (URI : URI_Type) return String renames Object_To_String_With_Best_Profile; function String_To_Object (Str : String) return URI_Type; --------------------- -- Profile Factory -- --------------------- type Profile_To_String_Body_Type is access function (Profile : Binding_Data.Profile_Access) return String; type String_To_Profile_Body_Type is access function (Str : String) return Binding_Data.Profile_Access; procedure Register (Tag : PolyORB.Binding_Data.Profile_Tag; Proto_Ident : String; Profile_To_String_Body : Profile_To_String_Body_Type; String_To_Profile_Body : String_To_Profile_Body_Type); end PolyORB.References.URI; polyorb-2.8~20110207.orig/src/polyorb-qos-priority.ads0000644000175000017500000000515711750740340022037 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . Q O S . P R I O R I T Y -- -- -- -- S p e c -- -- -- -- Copyright (C) 2004-2005 Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with PolyORB.Annotations; with PolyORB.Tasking.Priorities; package PolyORB.QoS.Priority is pragma Elaborate_Body; package PTP renames PolyORB.Tasking.Priorities; use PolyORB.Annotations; use PolyORB.Tasking.Priorities; type QoS_Static_Priority is new QoS_Parameter (Static_Priority) with record EP : PTP.External_Priority; end record; type Thread_Priority_Note is new Note with record Priority : External_Priority; end record; Default_Note : constant Thread_Priority_Note := Thread_Priority_Note'(Note with Priority => Invalid_Priority); end PolyORB.QoS.Priority; polyorb-2.8~20110207.orig/src/polyorb-orb-no_tasking.ads0000644000175000017500000000663311750740340022272 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . O R B . N O _ T A S K I N G -- -- -- -- S p e c -- -- -- -- Copyright (C) 2001-2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- Tasking policy for the ORB core: 'No_Tasking'. package PolyORB.ORB.No_Tasking is pragma Elaborate_Body; use PolyORB.Components; use PolyORB.Jobs; use PolyORB.Transport; --------------------------------------------------------- -- Simple policy for configuration without any tasking -- --------------------------------------------------------- -- This policy may be used for the creation of a low-profile -- ORB that does not depend on the Ada tasking runtime library. -- It is suitable for use in a node that contains only an -- environment task. type No_Tasking is new Tasking_Policy_Type with private; procedure Handle_New_Server_Connection (P : access No_Tasking; ORB : ORB_Access; AC : Active_Connection); procedure Handle_Close_Connection (P : access No_Tasking; TE : Transport_Endpoint_Access); procedure Handle_New_Client_Connection (P : access No_Tasking; ORB : ORB_Access; AC : Active_Connection); procedure Handle_Request_Execution (P : access No_Tasking; ORB : ORB_Access; RJ : access Request_Job'Class); procedure Idle (P : access No_Tasking; This_Task : PTI.Task_Info_Access; ORB : ORB_Access); private type No_Tasking is new Tasking_Policy_Type with null record; end PolyORB.ORB.No_Tasking; polyorb-2.8~20110207.orig/src/polyorb-parameters-command_line.ads0000644000175000017500000000477211750740340024146 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . P A R A M E T E R S . C O M M A N D _ L I N E -- -- -- -- S p e c -- -- -- -- Copyright (C) 2005 Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- PolyORB allows to set up configuration variables on the command -- line. The syntax is close to the one described in -- PolyORB.Parameters.File. A variable Var.Iable in section [Sec] -- can be overriden with flag --polyorb---[=]. -- If no value is provided, then the returned value is set to "true". -- Note that Section and Key have to be in lower case. package PolyORB.Parameters.Command_Line is pragma Elaborate_Body; end PolyORB.Parameters.Command_Line; polyorb-2.8~20110207.orig/src/polyorb-tasking-semaphores.ads0000644000175000017500000000636411750740340023163 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . T A S K I N G . S E M A P H O R E S -- -- -- -- S p e c -- -- -- -- Copyright (C) 2002-2003 Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by ACT Europe. -- -- (email: sales@act-europe.fr) -- -- -- ------------------------------------------------------------------------------ -- This package provides an implementation of counting semaphores. with PolyORB.Tasking.Mutexes; with PolyORB.Tasking.Condition_Variables; package PolyORB.Tasking.Semaphores is pragma Preelaborate; type Semaphore is private; type Semaphore_Access is access all Semaphore; procedure Create (S : out Semaphore_Access); procedure Destroy (S : in out Semaphore_Access); procedure V (S : Semaphore_Access); -- V-operation on the semaphore: increment the value of the -- semaphore in a thread-safe way. procedure P (S : Semaphore_Access); -- P-operation on the semaphore: block until S.Value > 0; then -- decrement the value in a thread-safe way. function State (S : Semaphore_Access) return Natural; -- Return the current value of the semaphore. private package PTM renames PolyORB.Tasking.Mutexes; package PTCV renames PolyORB.Tasking.Condition_Variables; type Semaphore is record Value : Natural; -- Current value of the semaphore. Mutex : PTM.Mutex_Access; -- Used to assure mutual exclusion for Up, Down and State. Condition : PTCV.Condition_Access; -- Used the implement the blocking call to Down. end record; end PolyORB.Tasking.Semaphores; polyorb-2.8~20110207.orig/src/polyorb-orb-no_tasking.adb0000644000175000017500000001361311750740340022245 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . O R B . N O _ T A S K I N G -- -- -- -- B o d y -- -- -- -- Copyright (C) 2001-2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- Tasking policy for the ORB core: 'No_Tasking'. with PolyORB.Components; with PolyORB.Filters.Iface; with PolyORB.Initialization; with PolyORB.Log; with PolyORB.Setup; with PolyORB.Utils.Strings; package body PolyORB.ORB.No_Tasking is use PolyORB.Filters.Iface; use PolyORB.Log; package L is new PolyORB.Log.Facility_Log ("polyorb.orb.no_tasking"); procedure O (Message : String; Level : Log_Level := Debug) renames L.Output; function C (Level : Log_Level := Debug) return Boolean renames L.Enabled; ----------------------------- -- Handle_Close_Connection -- ----------------------------- procedure Handle_Close_Connection (P : access No_Tasking; TE : Transport_Endpoint_Access) is pragma Warnings (Off); pragma Unreferenced (P); pragma Unreferenced (TE); pragma Warnings (On); begin null; end Handle_Close_Connection; ---------------------------------- -- Handle_New_Client_Connection -- ---------------------------------- procedure Handle_New_Client_Connection (P : access No_Tasking; ORB : ORB_Access; AC : Active_Connection) is pragma Warnings (Off); pragma Unreferenced (P, ORB); pragma Warnings (On); begin pragma Debug (C, O ("New client connection")); Components.Emit_No_Reply (Component_Access (AC.TE), Connect_Confirmation'(null record)); -- The newly-created channel will be monitored -- by general-purpose ORB tasks. end Handle_New_Client_Connection; ---------------------------------- -- Handle_New_Server_Connection -- ---------------------------------- procedure Handle_New_Server_Connection (P : access No_Tasking; ORB : ORB_Access; AC : Active_Connection) is pragma Warnings (Off); pragma Unreferenced (P, ORB); pragma Warnings (On); begin pragma Debug (C, O ("New server connection")); Components.Emit_No_Reply (Component_Access (AC.TE), Connect_Indication'(null record)); -- The newly-created channel will be monitored -- by general-purpose ORB tasks. end Handle_New_Server_Connection; ------------------------------ -- Handle_Request_Execution -- ------------------------------ procedure Handle_Request_Execution (P : access No_Tasking; ORB : ORB_Access; RJ : access Request_Job'Class) is pragma Unreferenced (P); J : Job_Access := Job_Access (RJ); begin pragma Debug (C, O ("Request execution")); -- No tasking: execute the request in the current task. Run_Request (ORB, RJ.Request); Free (J); end Handle_Request_Execution; ---------- -- Idle -- ---------- procedure Idle (P : access No_Tasking; This_Task : PTI.Task_Info_Access; ORB : ORB_Access) is pragma Warnings (Off); pragma Unreferenced (P); pragma Unreferenced (This_Task); pragma Unreferenced (ORB); pragma Warnings (On); begin pragma Debug (C, O ("Dead lock detected !")); raise Program_Error; -- When there is no tasking, the (only) task in the -- application may not go idle, since this would -- block the whole system forever. end Idle; ---------------- -- Initialize -- ---------------- procedure Initialize; procedure Initialize is begin Setup.The_Tasking_Policy := new No_Tasking; end Initialize; use PolyORB.Initialization; use PolyORB.Initialization.String_Lists; use PolyORB.Utils.Strings; begin Register_Module (Module_Info' (Name => +"orb.no_tasking", Conflicts => Empty, Depends => Empty, Provides => +"orb.tasking_policy!", Implicit => False, Init => Initialize'Access, Shutdown => null)); end PolyORB.ORB.No_Tasking; polyorb-2.8~20110207.orig/src/polyorb-tasking-idle_tasks_managers.adb0000644000175000017500000001607511750740340024773 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . T A S K I N G . I D L E _ T A S K S _ M A N A G E R S -- -- -- -- B o d y -- -- -- -- Copyright (C) 2004-2009, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with PolyORB.Log; package body PolyORB.Tasking.Idle_Tasks_Managers is use PolyORB.Log; use PolyORB.Task_Info; use PolyORB.Tasking.Condition_Variables; package L is new PolyORB.Log.Facility_Log ("polyorb.tasking.idle_tasks_manager"); procedure O (Message : String; Level : Log_Level := Debug) renames L.Output; function C (Level : Log_Level := Debug) return Boolean renames L.Enabled; procedure Awake_One_Idle_Task (ITM : access Idle_Tasks_Manager; Kind : Task_Kind); -- Awake one idle task of the specified Kind; there must be at least one function Allocate_CV (ITM : access Idle_Tasks_Manager) return PTCV.Condition_Access; pragma Inline (Allocate_CV); -- Return one condition variable ----------------- -- Allocate_CV -- ----------------- function Allocate_CV (ITM : access Idle_Tasks_Manager) return Condition_Access is use type CV_Lists.List; Result : Condition_Access; begin if not CV_Lists.Is_Empty (ITM.Free_CV) then -- Use an existing CV, from Free_CV list CV_Lists.Extract_First (ITM.Free_CV, Result); else -- else allocate a new one Create (Result); end if; return Result; end Allocate_CV; --------------------- -- Awake_Idle_Task -- --------------------- procedure Awake_Idle_Task (ITM : access Idle_Tasks_Manager; TI : Task_Info_Access) is begin pragma Debug (C, O ("Awake_Idle_Task " & TI.Kind'Img & " " & Image (TI.all) & ": enter")); List_Detach (TI, ITM.Idle_Task_Lists (TI.Kind)); Signal (Condition (TI.all)); pragma Debug (C, O ("Awake_Idle_Task: leave")); end Awake_Idle_Task; ------------------------- -- Awake_One_Idle_Task -- ------------------------- procedure Awake_One_Idle_Task (ITM : access Idle_Tasks_Manager; Kind : Task_Kind) is begin pragma Assert (not Is_Empty (ITM.Idle_Task_Lists (Kind))); Awake_Idle_Task (ITM, List_First (ITM.Idle_Task_Lists (Kind)).all'Access); end Awake_One_Idle_Task; ------------------------- -- Awake_One_Idle_Task -- ------------------------- function Awake_One_Idle_Task (ITM : access Idle_Tasks_Manager; Allow_Transient : Boolean) return Boolean is begin -- The choice between Kinds is arbitrary, unless Allow_Transient is -- False. It's simplest to pick the first Permanent one, unless there is -- none, in which case we try Transient. if not Is_Empty (ITM.Idle_Task_Lists (Permanent)) then Awake_One_Idle_Task (ITM, Permanent); return True; elsif Allow_Transient and then not Is_Empty (ITM.Idle_Task_Lists (Transient)) then Awake_One_Idle_Task (ITM, Transient); return True; else -- Failed to find an appropriate idle task return False; end if; end Awake_One_Idle_Task; -------------------------- -- Awake_All_Idle_Tasks -- -------------------------- procedure Awake_All_Idle_Tasks (ITM : access Idle_Tasks_Manager) is begin pragma Debug (C, O ("Awake_All_Idle_Tasks: enter")); -- Awaken tasks, looping until both Kind lists are empty for Kind in Task_Kind loop while not Is_Empty (ITM.Idle_Task_Lists (Kind)) loop Awake_One_Idle_Task (ITM, Kind); end loop; end loop; pragma Debug (C, O ("Awake_All_Idle_Tasks: leave")); end Awake_All_Idle_Tasks; ---------------------- -- Remove_Idle_Task -- ---------------------- procedure Remove_Idle_Task (ITM : access Idle_Tasks_Manager; TI : PTI.Task_Info_Access) is begin -- TI has been detached from the idle list if it is being awakened by -- the ITM or by another task through Awake_Idle_Task, but may still -- be attached if it is terminating now as a result of a spare tasks -- policy limit. In the former case, the call to List_Detach below is -- a no-op. List_Detach (TI, ITM.Idle_Task_Lists (TI.Kind)); -- This procedure is called back by the ORB once an idle task -- has returned from Idle. The caller guarantees that it will -- update its task state to some value other than Idle within -- the same critical section, so we can now safely take over -- the condition variable to reuse it (it won't be used by another -- task trying to signal TI anymore). -- Should limit the growth of the CV_List to some reasonable size??? CV_Lists.Append (ITM.Free_CV, Condition (TI.all)); end Remove_Idle_Task; ---------------------- -- Insert_Idle_Task -- ---------------------- function Insert_Idle_Task (ITM : access Idle_Tasks_Manager; TI : PTI.Task_Info_Access) return PTCV.Condition_Access is Result : constant PTCV.Condition_Access := Allocate_CV (ITM); begin List_Attach (TI, ITM.Idle_Task_Lists (TI.Kind)); return Result; end Insert_Idle_Task; end PolyORB.Tasking.Idle_Tasks_Managers; polyorb-2.8~20110207.orig/src/polyorb-filters-slicers.adb0000644000175000017500000001366211750740340022447 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . F I L T E R S . S L I C E R S -- -- -- -- B o d y -- -- -- -- Copyright (C) 2001-2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- A filter that slices a stream into a set of known-length messages. with PolyORB.Filters.Iface; with PolyORB.Log; package body PolyORB.Filters.Slicers is use Ada.Streams; use PolyORB.Buffers; use PolyORB.Components; use PolyORB.Filters.Iface; use PolyORB.Log; package L is new PolyORB.Log.Facility_Log ("polyorb.filters.slicers"); procedure O (Message : String; Level : Log_Level := Debug) renames L.Output; function C (Level : Log_Level := Debug) return Boolean renames L.Enabled; ------------ -- Create -- ------------ procedure Create (Fact : access Slicer_Factory; Slicer : out Filter_Access) is pragma Warnings (Off); pragma Unreferenced (Fact); pragma Warnings (On); Res : constant Filter_Access := new Slicer_Filter; begin Slicer_Filter (Res.all).Data_Expected := 0; Slicer := Res; end Create; -------------------- -- Handle_Message -- -------------------- function Handle_Message (F : not null access Slicer_Filter; S : Components.Message'Class) return Components.Message'Class is Res : Components.Null_Message; begin if S in Data_Expected'Class then declare DEM : Data_Expected renames Data_Expected (S); begin pragma Debug (C, O ("Expecting" & DEM.Max'Img & " bytes.")); pragma Assert (True and then F.Data_Expected = 0 and then F.In_Buf = null and then DEM.Max /= 0 and then DEM.In_Buf /= null); F.Data_Expected := DEM.Max; F.Initial_Data_Expected := DEM.Max; F.In_Buf := DEM.In_Buf; F.Buffer_Length := Length (F.In_Buf.all); return Emit (F.Lower, Data_Expected' (Max => F.Data_Expected, In_Buf => F.In_Buf)); end; elsif S in Data_Indication then declare Data_Received : constant Stream_Element_Count := Data_Indication (S).Data_Amount; begin pragma Debug (C, O ("Expected" & F.Data_Expected'Img & " bytes, received" & Data_Received'Img)); if F.In_Buf = null or else Data_Received > F.Data_Expected then raise Program_Error; -- This exception will be propagated to the ORB. end if; pragma Assert (Data_Received = Length (F.In_Buf.all) - F.Buffer_Length); -- Integrity check: Receive_Buffer must have increased -- Length (F.In_Buf) by exactly the amount of data received. F.Data_Expected := F.Data_Expected - Data_Received; F.Buffer_Length := Length (F.In_Buf.all); if F.Data_Expected = 0 then declare Total_Data_Amount : Stream_Element_Count; begin if F.Initial_Data_Expected = 0 then Total_Data_Amount := Data_Received; else Total_Data_Amount := F.Initial_Data_Expected; F.Initial_Data_Expected := 0; end if; F.In_Buf := null; return Emit (F.Upper, Data_Indication' (Data_Amount => Total_Data_Amount)); end; else pragma Debug (C, O ("Expecting" & F.Data_Expected'Img & " further bytes.")); Emit_No_Reply (F.Lower, Data_Expected' (Max => F.Data_Expected, In_Buf => F.In_Buf)); end if; end; else return Filters.Handle_Message (Filters.Filter (F.all)'Access, S); end if; return Res; end Handle_Message; end PolyORB.Filters.Slicers; ././@LongLink0000000000000000000000000000015000000000000011561 Lustar rootrootpolyorb-2.8~20110207.orig/src/polyorb-poa_policies-request_processing_policy-active_object_map_only.adspolyorb-2.8~20110207.orig/src/polyorb-poa_policies-request_processing_policy-active_object_map_only.0000644000175000017500000000702211750740340033323 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- POLYORB.POA_POLICIES.REQUEST_PROCESSING_POLICY.ACTIVE_OBJECT_MAP_ONLY -- -- -- -- S p e c -- -- -- -- Copyright (C) 2001-2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ package PolyORB.POA_Policies.Request_Processing_Policy.Active_Object_Map_Only is type Active_Map_Only_Policy is new RequestProcessingPolicy with null record; type Active_Map_Only_Policy_Access is access all Active_Map_Only_Policy; function Create return Active_Map_Only_Policy_Access; procedure Check_Compatibility (Self : Active_Map_Only_Policy; Other_Policies : AllPolicies; Error : in out PolyORB.Errors.Error_Container); function Policy_Id (Self : Active_Map_Only_Policy) return String; procedure Id_To_Servant (Self : Active_Map_Only_Policy; OA : PolyORB.POA_Types.Obj_Adapter_Access; U_Oid : Unmarshalled_Oid; Servant : out Servants.Servant_Access; Error : in out PolyORB.Errors.Error_Container); procedure Set_Servant (Self : Active_Map_Only_Policy; OA : PolyORB.POA_Types.Obj_Adapter_Access; Servant : Servants.Servant_Access; Error : in out PolyORB.Errors.Error_Container); procedure Get_Servant (Self : Active_Map_Only_Policy; OA : PolyORB.POA_Types.Obj_Adapter_Access; Servant : out Servants.Servant_Access; Error : in out PolyORB.Errors.Error_Container); procedure Ensure_Servant_Manager (Self : Active_Map_Only_Policy; Error : in out PolyORB.Errors.Error_Container); end PolyORB.POA_Policies.Request_Processing_Policy.Active_Object_Map_Only; polyorb-2.8~20110207.orig/src/polyorb-orb-thread_per_request.adb0000644000175000017500000001571411750740340024002 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . O R B . T H R E A D _ P E R _ R E Q U E S T -- -- -- -- B o d y -- -- -- -- Copyright (C) 2002-2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with PolyORB.Components; with PolyORB.Filters; with PolyORB.Filters.Iface; with PolyORB.Initialization; with PolyORB.Jobs; with PolyORB.Log; with PolyORB.Setup; with PolyORB.Tasking.Condition_Variables; with PolyORB.Tasking.Threads; with PolyORB.Utils.Strings; package body PolyORB.ORB.Thread_Per_Request is ------------------------ -- Local declarations -- ------------------------ use PolyORB.Asynch_Ev; use PolyORB.Filters; use PolyORB.Filters.Iface; use PolyORB.Log; use PolyORB.Tasking.Condition_Variables; use PolyORB.Tasking.Threads; package L is new PolyORB.Log.Facility_Log ("polyorb.orb.thread_per_request"); procedure O (Message : String; Level : Log_Level := Debug) renames L.Output; function C (Level : Log_Level := Debug) return Boolean renames L.Enabled; type Request_Runnable is new Runnable with record ORB : ORB_Access; A_Job : Jobs.Job_Access; end record; procedure Run (R : not null access Request_Runnable); procedure Initialize; ----------------------------- -- Handle_Close_Connection -- ----------------------------- procedure Handle_Close_Connection (P : access Thread_Per_Request_Policy; TE : Transport_Endpoint_Access) is pragma Unreferenced (P, TE); begin null; end Handle_Close_Connection; ---------------------------------- -- Handle_New_Client_Connection -- ---------------------------------- procedure Handle_New_Client_Connection (P : access Thread_Per_Request_Policy; ORB : ORB_Access; AC : Active_Connection) is pragma Unreferenced (P, ORB); begin pragma Debug (C, O ("New client connection")); Components.Emit_No_Reply (Component_Access (AC.TE), Connect_Confirmation'(null record)); end Handle_New_Client_Connection; ---------------------------------- -- Handle_New_Server_Connection -- ---------------------------------- procedure Handle_New_Server_Connection (P : access Thread_Per_Request_Policy; ORB : ORB_Access; AC : Active_Connection) is pragma Unreferenced (P, ORB); begin pragma Debug (C, O ("New server connection. ")); Components.Emit_No_Reply (Component_Access (AC.TE), Connect_Indication'(null record)); end Handle_New_Server_Connection; ------------------------------ -- Handle_Request_Execution -- ------------------------------ procedure Handle_Request_Execution (P : access Thread_Per_Request_Policy; ORB : ORB_Access; RJ : access Request_Job'Class) is pragma Unreferenced (P); T : Thread_Access; pragma Unreferenced (T); -- T is assigned but never read begin pragma Debug (C, O ("Handle_Request_Execution: enter")); T := Run_In_Task (Get_Thread_Factory, R => new Request_Runnable' (ORB => ORB, A_Job => Job_Access (RJ))); pragma Debug (C, O ("Handle_Request_Execution: leave")); end Handle_Request_Execution; ---------- -- Idle -- ---------- procedure Idle (P : access Thread_Per_Request_Policy; This_Task : PTI.Task_Info_Access; ORB : ORB_Access) is pragma Unreferenced (P, ORB); begin -- In Thread_Per_Request policy, only one task is executing ORB.Run. -- However, it can be set to idle while another thread modifies -- ORB internals. pragma Debug (C, O ("Thread " & Image (PTI.Id (This_Task.all)) & " is going idle.")); Wait (PTI.Condition (This_Task.all), PTI.Mutex (This_Task.all)); pragma Debug (C, O ("Thread " & Image (PTI.Id (This_Task.all)) & " is leaving Idle state")); end Idle; ---------------- -- Initialize -- ---------------- procedure Initialize is begin Setup.The_Tasking_Policy := new Thread_Per_Request_Policy; end Initialize; --------- -- Run -- --------- procedure Run (R : not null access Request_Runnable) is begin -- Running Job pragma Debug (C, O ("Thread " & Image (Current_Task) & " is executing a job")); Run_Request (R.ORB, Request_Job (R.A_Job.all).Request); -- Job Finalization Jobs.Free (R.A_Job); pragma Debug (C, O ("Thread " & Image (Current_Task) & " has executed and destroyed a job")); end Run; use PolyORB.Initialization; use PolyORB.Initialization.String_Lists; use PolyORB.Utils.Strings; begin Register_Module (Module_Info' (Name => +"orb.thread_per_request", Conflicts => +"no_tasking", Depends => +"tasking.condition_variables", Provides => +"orb.tasking_policy!", Implicit => False, Init => Initialize'Access, Shutdown => null)); end PolyORB.ORB.Thread_Per_Request; polyorb-2.8~20110207.orig/src/polyorb-buffers.ads0000644000175000017500000005035511750740340021012 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . B U F F E R S -- -- -- -- S p e c -- -- -- -- Copyright (C) 2001-2009, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- Buffer management. -- A buffer exhibits two views: -- - the representation view, used to handle representation-specific -- marshalling, taking into account data alignment. -- - the transport view, used to interact with transport subsystem. -- Note: Buffers should only be read/written sequentially. with Ada.Streams; with Ada.Unchecked_Conversion; with System.Storage_Elements; with PolyORB.Opaque.Chunk_Pools; package PolyORB.Buffers is pragma Preelaborate; ------------------------- -- General definitions -- ------------------------- type Endianness_Type is new System.Bit_Order; function Little_Endian return Endianness_Type renames Low_Order_First; function Big_Endian return Endianness_Type renames High_Order_First; -- Endianness of a buffer type Alignment_Type is (Align_1, Align_2, Align_4, Align_8); for Alignment_Type use (Align_1 => 1, Align_2 => 2, Align_4 => 4, Align_8 => 8); for Alignment_Type'Size use Short_Short_Integer'Size; -- Alignment of a piece of data within a buffer -- It is assumed that = 2 ** Align_'Pos = representation(Align_) function Alignment_Of is new Ada.Unchecked_Conversion (Short_Short_Integer, Alignment_Type); Host_Order : constant Endianness_Type; -- The byte order of this host. type Buffer_Type is limited private; type Buffer_Access is access all Buffer_Type; -- A pointer to a dynamically allocated buffer. ------------------------ -- General operations -- ------------------------ function Length (Buffer : Buffer_Type) return Ada.Streams.Stream_Element_Count; pragma Inline (Length); -- Return the length of Buffer procedure Set_Endianness (Buffer : access Buffer_Type; E : Endianness_Type); pragma Inline (Set_Endianness); -- Set the endianness of Buffer -- XXX This should be moved to CDR. function Endianness (Buffer : access Buffer_Type) return Endianness_Type; pragma Inline (Endianness); -- Return the endianness of Buffer. -- XXX This should be moved to CDR. procedure Release_Contents (Buffer : in out Buffer_Type); -- Signal that the current contents of a buffer will not be used anymore. -- The associated storage will be deallocated. procedure Initialize_Buffer (Buffer : access Buffer_Type; Size : Ada.Streams.Stream_Element_Count; Data : Opaque.Opaque_Pointer; Endianness : Endianness_Type; Initial_CDR_Position : Ada.Streams.Stream_Element_Offset); -- Sets the contents of Buffer using data passed as a pointer Data and a -- size Size. Buffer must be a fresh, empty buffer. The first element of -- Data corresponds to the indicated Initial_CDR_Position. The byte-order -- of the data is Endianness. The lifespan of the data designated by Data -- must be no less than the lifespan of the resulting buffer. type Reservation is private; function Reserve (Buffer : access Buffer_Type; Amount : Ada.Streams.Stream_Element_Count) return Reservation; -- Reserve Amount contiguous bytes in Buffer at the current -- position, to be filled later through a call to Copy_Data. -- The position of the reservation is the current position -- in Buffer before the call. The length of the reservation -- is Amount. procedure Copy_Data (From : Buffer_Type; Into : Reservation); -- Copy data from From into reservation Into. The position and length of -- From and Into must match. function Copy (Buffer : access Buffer_Type) return Buffer_Access; -- Make a copy of Buffer. The copy's data is allocated -- only from its internal storage pool. There is no -- constraint on the lifespan of the resulting buffer. -- It is the caller's responsibility to call Release -- on the returned Buffer_Access to free the associated -- resources. The initial and current CDR positions of the -- new buffers are set to the initial CDR position of the -- source. procedure Release (A_Buffer : in out Buffer_Access); -- Release the contents of A_Buffer and the associated control -- structures when they won't be used anymore. -- On return, A_Buffer is set to null. function To_Stream_Element_Array (Buffer : Buffer_Type) return Ada.Streams.Stream_Element_Array; -- Dump the contents of Buffer into a Stream_Element_Array. -- Beware of overflowing the stack when using this function. function Peek (Buffer : access Buffer_Type; Position : Ada.Streams.Stream_Element_Offset) return Ada.Streams.Stream_Element; -- Return the octet at the given Position from the buffer. -- Constraint_Error is raised if that position is beyond the -- buffer's end. ------------------------------------- -- Representation view of a buffer -- ------------------------------------- -- A buffer has a current position index called the current -- CDR position. Marshalling data into the buffer and -- unmarshalling data from the buffer first advances the -- current buffer position according to the alignment -- constraints for the data type, then further advance it -- by the size of the data effectively marshalled or -- unmarshalled. procedure Set_Initial_Position (Buffer : access Buffer_Type; Position : Ada.Streams.Stream_Element_Offset); -- Sets the initial and current CDR positions -- of Buffer to Position. No data must have -- been inserted into Buffer yet. procedure Pad_Align (Buffer : access Buffer_Type; Alignment : Alignment_Type); -- Aligns Buffer on specified Alignment before inserting aligned data. -- Padding data is inserted into Buffer if necessary, which is guaranteed -- to be zeroed. procedure Align_Position (Buffer : access Buffer_Type; Alignment : Alignment_Type); -- Aligns Buffer on specified Alignment before retrieving aligned data -- After execution of either of the two above operations, the current CDR -- position of Buffer is advanced to a multiple of Alignment. -- Inserting data into a buffer procedure Insert_Raw_Data (Buffer : access Buffer_Type; Size : Ada.Streams.Stream_Element_Count; Data : Opaque.Opaque_Pointer); -- Inserts data into Buffer by reference at the current CDR position. This -- procedure is used to implement marshalling by reference. procedure Allocate_And_Insert_Cooked_Data (Buffer : access Buffer_Type; Size : Ada.Streams.Stream_Element_Count; Data : out Opaque.Opaque_Pointer); -- Allocates Size bytes within Buffer's memory pool, and inserts this chunk -- of memory into Buffer at the current CDR position. A pointer to the -- allocated space is returned, so the caller can copy data into it. -- This procedure is used to implement marshalling by copy. The current -- position is not changed. procedure Unuse_Allocation (Buffer : access Buffer_Type; Size : Ada.Streams.Stream_Element_Count); -- Cancel the allocation of Size bytes at the end of this Buffer's memory -- pool. Size must be no greater than the size of the last chunk inserted, -- which must have been allocated using Allocate_And_Insert_Cooked_Data. -- XXX Check that this last restriction is enforced. -- Retrieving data from a buffer procedure Extract_Data (Buffer : access Buffer_Type; Data : out Opaque.Opaque_Pointer; Size : Ada.Streams.Stream_Element_Count; Use_Current : Boolean := True; At_Position : Ada.Streams.Stream_Element_Offset := 0); procedure Partial_Extract_Data (Buffer : access Buffer_Type; Data : out Opaque.Opaque_Pointer; Size : in out Ada.Streams.Stream_Element_Count; Use_Current : Boolean := True; At_Position : Ada.Streams.Stream_Element_Offset := 0; Partial : Boolean := True); -- The two procedures above retrieve Size elements of contiguous data from -- Buffer. If Use_Current is True, the extraction starts at the current -- position in the buffer, else it starts at At_Position. -- -- For the Partial version, if Partial is True, less data may be returned -- than requested, in which case Size is adjusted accordingly. If Partial -- is False, the behaviour is the same as Extract_Data. -- -- On return, Data contains an access to the retrieved Data, and if -- Use_Current is True, then the CDR current position is advanced by Size. -- Constraint_Error is raised if less than Size elements of contiguous data -- are available and Partial is not True. function CDR_Position (Buffer : access Buffer_Type) return Ada.Streams.Stream_Element_Offset; -- Return the current CDR position of the buffer -- in the marshalling stream. procedure Set_CDR_Position (Buffer : access Buffer_Type; Position : Ada.Streams.Stream_Element_Offset); -- XXX DO NOT USE -- function used ONLY in MIOP for buffer fragmentation function Remaining (Buffer : access Buffer_Type) return Ada.Streams.Stream_Element_Count; -- Return the number of bytes available from Buffer, -- from the current position to the end of data. procedure Rewind (Buffer : access Buffer_Type); -- Reset the current position in Buffer to the initial -- position. -- XXX Deprecated, should not be used any more, any occurence should -- be removed ------------------------------------ -- The transport view of a buffer -- ------------------------------------ type Iovec is record Iov_Base : Opaque.Opaque_Pointer; Iov_Len : System.Storage_Elements.Storage_Offset; end record; -- This is modeled after the POSIX iovec. generic with procedure Lowlevel_Send (V : access Iovec; N : Integer; Count : out System.Storage_Elements.Storage_Offset); -- Send out data gathered from N contiguous Iovecs, the first of -- which is V. On return, Count contains the amount of data sent. procedure Send_Buffer (Buffer : access Buffer_Type); -- Send the contents of Buffer using the specified low-level procedure. generic with procedure Lowlevel_Receive (V : access Iovec); -- Receive at most V.Iov_Len elements of data and store it -- at V.Iov_Base. On return, V.Iov_Len is the amount of data -- actually received. procedure Receive_Buffer (Buffer : access Buffer_Type; Max : Ada.Streams.Stream_Element_Count; Received : out Ada.Streams.Stream_Element_Count); -- Received at most Max octets of data into Buffer at current position. -- On return, Received is set to the effective amount of data received. -- The current position is unchanged. ------------------------- -- Utility subprograms -- ------------------------- procedure Show (Buffer : access Buffer_Type); -- Display the contents of Buffer for debugging purposes. private ------------------------------------------ -- Determination of the host byte order -- ------------------------------------------ Host_Order : constant Endianness_Type := Endianness_Type (System.Default_Bit_Order); -------------- -- A Buffer -- -------------- type Buffer_Chunk_Metadata is record -- An Iovec pool manipulates chunks of memory allocated -- from a Chunk_Pool. This records holds the metadata -- associated by the Iovec pool and the Buffer (below) -- with each allocated chunk. Last_Used : Ada.Streams.Stream_Element_Offset := 0; -- The index within the chunk of the last -- used element. end record; -- A space pre-reservation within a buffer. type Reservation is record Location : Opaque.Opaque_Pointer; Endianness : Endianness_Type; CDR_Position : Ada.Streams.Stream_Element_Offset; Length : Ada.Streams.Stream_Element_Count; end record; package Buffer_Chunk_Pools is new Opaque.Chunk_Pools (Chunk_Metadata => Buffer_Chunk_Metadata); subtype Chunk_Metadata_Access is Buffer_Chunk_Pools.Metadata_Access; package Iovec_Pools is -- An Iovec_Pool stores a sequence of Iovecs with -- corresponding descriptors. An array of pre-allocated -- storage is used if the pool contains no more than -- Prealloc_Size items, else a dynamically-allocated -- array is used. type Iovec_Pool_Type is private; type Iovec_Access is access all Iovec; procedure Grow_Shrink (Iovec_Pool : access Iovec_Pool_Type; Size : Ada.Streams.Stream_Element_Offset; Data : out Opaque.Opaque_Pointer); -- Augment/reduce the length of the last Iovec in -- Iovec_Pool by Size elements, if possible. -- On success, a pointer to the reserved -- space is returned in Data. On failure, a null -- pointer is returned. procedure Prepend_Pool (Prefix : Iovec_Pool_Type; Iovec_Pool : in out Iovec_Pool_Type); -- Prepends the contents of Prefix in Iovec_Pool. -- Prefix is unchanged. procedure Append (Iovec_Pool : in out Iovec_Pool_Type; An_Iovec : Iovec; A_Chunk : Buffer_Chunk_Pools.Chunk_Access := null); -- Append An_Iovec at the end of Iovec_Pool. -- If A_Chunk is not null, then the Iovec points to -- data within the designated chunk, and can be -- extended towards the end of the chunk if necessary. procedure Extract_Data (Iovec_Pool : in out Iovec_Pool_Type; Data : out Opaque.Opaque_Pointer; Offset : Ada.Streams.Stream_Element_Offset; Size : in out Ada.Streams.Stream_Element_Count); -- Retrieve at most Size octets of contiguous data from Iovec_Pool, -- starting at Offset. The effective amount of available contiguous -- data available at this position is returned in Size. procedure Release (Iovec_Pool : in out Iovec_Pool_Type); -- Signals that Iovec_Pool will not be used anymore. -- The associated Iovec array storage is returned to -- the system. generic with procedure Lowlevel_Send (V : access Iovec; N : Integer; Count : out System.Storage_Elements.Storage_Offset); -- Send out data gathered from N contiguous Iovecs, the first of -- which is V. On return, Count contains the amount of data sent. procedure Send_Iovec_Pool (Iovec_Pool : access Iovec_Pool_Type; Length : Ada.Streams.Stream_Element_Count); -- Write Length elements of the contents of Iovec_Pool onto V --------------------------------------- -- Low-level interfaces to the octet -- -- stream of an Iovec_Pool. -- --------------------------------------- procedure Dump (Iovec_Pool : Iovec_Pool_Type; Into : Opaque.Opaque_Pointer); -- Dump the content of an Iovec_Pool into the designated -- memory location. function Peek (Iovec_Pool : Iovec_Pool_Type; Offset : Ada.Streams.Stream_Element_Offset) return Ada.Streams.Stream_Element; -- Return the octet at the specified Offset from the start of -- Iovec_Pool. Constraint_Error is raised if that offset is -- beyond the pool's end. private Prealloc_Size : constant := 8; -- The number of slots in the preallocated iovec array. type Iovec_Array is array (Positive range <>) of aliased Iovec; type Iovec_Array_Access is access all Iovec_Array; type Iovec_Pool_Type is record Prealloc_Array : aliased Iovec_Array (1 .. Prealloc_Size); Dynamic_Array : Iovec_Array_Access := null; -- The pre-allocated and dynamically allocated Iovec_Arrays Length : Natural := Prealloc_Size; -- The length of the arrays currently in use. Last : Natural := 0; -- The number of the last allocated Iovec in the pool. -- If Last <= Prealloc_Array'Last then the pool's -- Iovecs are stored in Prealloc_Array, else they -- are stored in Dynamic_Array. Last_Chunk : Buffer_Chunk_Pools.Chunk_Access := null; -- If the last Iovec is pointing into user data, -- then we cannot assume that addresses beyond the -- end of the Iovec's buffer is valid: this -- Iovec cannot be grown. In this case, -- Last_Chunk is set to null. -- If the last Iovec is pointing into a memory -- chunk from a Buffer's chunk pool, then we can -- grow the Iovec if its last element is also the -- last allocated element of the chunk. In this -- second case, Last_Chunk is set to an access -- that designates the storage chunk. Last_Extract_Iovec : Positive := 1; Last_Extract_Iovec_Offset : System.Storage_Elements.Storage_Offset := 0; -- In order to speed up data extraction in the usual case, -- the index of the iovec from which data was extracted in -- the last call to Extract_Data, and the offset of the -- first element in that iovec, are cached in these components. end record; end Iovec_Pools; type Buffer_Type is record Endianness : Endianness_Type := Host_Order; -- The byte order of the data stored in the buffer CDR_Position : Ada.Streams.Stream_Element_Offset := 0; -- The current position within the stream for marshalling and -- unmarshalling Initial_CDR_Position : Ada.Streams.Stream_Element_Offset := 0; -- The position within the stream of the first element of Buffer Contents : aliased Iovec_Pools.Iovec_Pool_Type; -- The marshalled data as a pool of Iovecs Storage : aliased Buffer_Chunk_Pools.Pool_Type; -- A set of memory chunks used to store data marshalled by copy Length : Ada.Streams.Stream_Element_Count := 0; -- Length of stored data end record; end PolyORB.Buffers; polyorb-2.8~20110207.orig/src/polyorb-poa_policies-thread_policy-orb_ctrl.ads0000644000175000017500000000527011750740340026450 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- POLYORB.POA_POLICIES.THREAD_POLICY.ORB_CTRL -- -- -- -- S p e c -- -- -- -- Copyright (C) 2001-2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- Implementation of the 'ORB Control' POA Policy. package PolyORB.POA_Policies.Thread_Policy.ORB_Ctrl is type ORB_Ctrl_Policy is new ThreadPolicy with private; type ORB_Ctrl_Policy_Access is access all ORB_Ctrl_Policy; function Create return ORB_Ctrl_Policy_Access; procedure Check_Compatibility (Self : ORB_Ctrl_Policy; Other_Policies : AllPolicies; Error : in out PolyORB.Errors.Error_Container); function Policy_Id (Self : ORB_Ctrl_Policy) return String; private type ORB_Ctrl_Policy is new ThreadPolicy with null record; subtype ORB_Ctrl_Executor is Servants.Executor; end PolyORB.POA_Policies.Thread_Policy.ORB_Ctrl; polyorb-2.8~20110207.orig/src/polyorb-tasking-profiles-ravenscar-index_manager.ads0000644000175000017500000000643711750740340027422 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- POLYORB.TASKING.PROFILES.RAVENSCAR.INDEX_MANAGER -- -- -- -- S p e c -- -- -- -- Copyright (C) 2002-2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- This package provide a thread safe management of a pool of identifiers. generic Number_Of_Indices : Natural; package PolyORB.Tasking.Profiles.Ravenscar.Index_Manager is pragma Preelaborate; subtype Index_Type is Integer range 0 .. Number_Of_Indices - 1; -- Type of the identifiers that are managed by this package procedure Get (Id : out Index_Type); -- Get a unique identifier. No other call to Get will return this -- identifier until this identifier is released. Raise a -- No_More_Indentifier if all identifier are used. -- This procedure is executed in mutual exclusion, so that two tasks -- that make a call on Get will get two different identifiers. procedure Release (Id : Index_Type); -- Release the given identifier. Id will now be available and is -- eligible to be return by Get. Raise a Identifier_Already_Released -- when its is called on a free identifier, that do not need to be -- released. procedure Initialize (Error_On_Initialize : Boolean := True); -- Initialize this package. -- If Error_On_Initialise is set to false, we can call initialize -- several times. In this case, if the package was already -- initialized no initialization is done. end PolyORB.Tasking.Profiles.Ravenscar.Index_Manager; polyorb-2.8~20110207.orig/src/polyorb-tasking-profiles-no_tasking-condition_variables.ads0000644000175000017500000001010511750740340030772 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- POLYORB.TASKING.PROFILES.NO_TASKING.CONDITION_VARIABLES -- -- -- -- S p e c -- -- -- -- Copyright (C) 2002 Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by ACT Europe. -- -- (email: sales@act-europe.fr) -- -- -- ------------------------------------------------------------------------------ -- Implementation of POSIX-like condition variables with no Ada tasking. with PolyORB.Tasking.Condition_Variables; with PolyORB.Tasking.Mutexes; package PolyORB.Tasking.Profiles.No_Tasking.Condition_Variables is package PTCV renames PolyORB.Tasking.Condition_Variables; package PTM renames PolyORB.Tasking.Mutexes; procedure Initialize; -- Initialize this package type No_Tasking_Condition_Type is new PTCV.Condition_Type with private; type No_Tasking_Condition_Access is access all No_Tasking_Condition_Type'Class; -- Type for mutexes with no Ada tasking. procedure Wait (C : access No_Tasking_Condition_Type; M : access PTM.Mutex_Type'Class); -- Have no sense in this profile (would block the only task that can run), -- so raise Tasking_Error. procedure Signal (C : access No_Tasking_Condition_Type); procedure Broadcast (C : access No_Tasking_Condition_Type); type No_Tasking_Condition_Factory_Type is new PTCV.Condition_Factory_Type with private; -- This type is a factory for the Condition type under No_Tasking profile. type No_Tasking_Condition_Factory_Access is access all No_Tasking_Condition_Factory_Type'Class; The_Condition_Factory : constant No_Tasking_Condition_Factory_Access; function Create (MF : access No_Tasking_Condition_Factory_Type; Name : String := "") return PTCV.Condition_Access; -- Create a new condition, or get a preallocated one. -- Name will be used to get the configuration of this -- condition from the configuration module. procedure Destroy (MF : access No_Tasking_Condition_Factory_Type; C : in out PTCV.Condition_Access); -- Destroy C. private type No_Tasking_Condition_Type is new PTCV.Condition_Type with null record; type No_Tasking_Condition_Factory_Type is new PTCV.Condition_Factory_Type with null record; The_Condition_Factory : constant No_Tasking_Condition_Factory_Access := new No_Tasking_Condition_Factory_Type; end PolyORB.Tasking.Profiles.No_Tasking.Condition_Variables; polyorb-2.8~20110207.orig/src/polyorb-poa_policies-id_assignment_policy.ads0000644000175000017500000000640611750740340026223 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- POLYORB.POA_POLICIES.ID_ASSIGNMENT_POLICY -- -- -- -- S p e c -- -- -- -- Copyright (C) 2001-2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with PolyORB.Object_Maps; with PolyORB.POA_Types; package PolyORB.POA_Policies.Id_Assignment_Policy is use PolyORB.POA_Types; type IdAssignmentPolicy is abstract new Policy with null record; type IdAssignmentPolicy_Access is access all IdAssignmentPolicy'Class; function Create_Object_Map (Self : IdAssignmentPolicy) return PolyORB.Object_Maps.Object_Map_Access is abstract; procedure Assign_Object_Identifier (Self : IdAssignmentPolicy; OA : Obj_Adapter_Access; Hint : Object_Id_Access; U_Oid : out Unmarshalled_Oid; Error : in out PolyORB.Errors.Error_Container) is abstract; procedure Reconstruct_Object_Identifier (Self : IdAssignmentPolicy; OA : Obj_Adapter_Access; Oid : Object_Id; U_Oid : out Unmarshalled_Oid; Error : in out PolyORB.Errors.Error_Container) is abstract; procedure Object_Identifier (Self : IdAssignmentPolicy; Oid : Object_Id_Access; Result : out Object_Id_Access; Error : in out PolyORB.Errors.Error_Container) is abstract; -- Return the ObjectId stored in Oid. Note that Result is a newly -- allocated variable that must be deallocated by the caller after use. end PolyORB.POA_Policies.Id_Assignment_Policy; polyorb-2.8~20110207.orig/src/polyorb-sockets_initialization.ads0000644000175000017500000000432011750740340024127 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . S O C K E T S _ I N I T I A L I Z A T I O N -- -- -- -- S p e c -- -- -- -- Copyright (C) 2003 Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by ACT Europe. -- -- (email: sales@act-europe.fr) -- -- -- ------------------------------------------------------------------------------ -- The purpose of this package is to register an initialization module -- for GNAT.Sockets. package PolyORB.Sockets_Initialization is pragma Elaborate_Body; end PolyORB.Sockets_Initialization; polyorb-2.8~20110207.orig/src/web_common/0000755000175000017500000000000011750740340017316 5ustar xavierxavierpolyorb-2.8~20110207.orig/src/web_common/polyorb-web-utils.ads0000644000175000017500000001236411750740340023414 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . W E B . U T I L S -- -- -- -- S p e c -- -- -- -- Copyright (C) 2000-2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with Ada.Streams; with Ada.Unchecked_Deallocation; with System; package PolyORB.Web.Utils is type Random_Integer is range 0 .. Long_Long_Integer'Min (2 ** 48 - 1, System.Max_Int); -- Integer type for random number generation. As GNAT warns us -- about the reliability of random generator for numbers > 2^48, -- we must stay below this limit. -- General helper functions are to be found here. function Random return Random_Integer; -- Returns a random integer number. function Image (N : Natural) return String; -- return image of N without the leading blank. function Image (D : Duration) return String; -- return image of N without the leading blank and with only 2 decimals -- numbers. function Hex (V : Natural; Width : Natural := 0) return String; -- Returns the hexadecimal string representation of the decimal -- number V. if Width /= 0, the result will have exactly Width characters -- eventually padded with leading 0 or trimmed on the right. function Hex_Value (Hex : String) return Natural; -- Returns the value for the hexadecimal number Hex. Raises -- Constraint_Error is Hex is not an hexadecimal number. function Is_Number (S : String) return Boolean; -- Returns True is S contains only decimal digits and is not empty. function Quote (Str : String) return String; pragma Inline (Quote); -- Returns Str with character '"' added at the start and the end. function CRLF_2_Spaces (Str : String) return String; -- Returns an str in a single line. All CR and LF are converted to spaces, -- trailing spaces are removed. --------------- -- Semaphore -- --------------- -- This is a binary semaphore, only a single task can enter it (Seize) and -- must call Release when the resource is not needed anymore. This -- implement a standard semaphore (P/V mutex). protected type Semaphore is entry Seize; procedure Release; private Seized : Boolean := False; end Semaphore; ------------------ -- RW_Semaphore -- ------------------ -- This is a Read/Write semaphore. Many reader tasks can enter (Read) at -- the same time excluding all writers (Write). A single writer can enter -- (Write) excluding all readers (Read). The task must release the -- corresponding resource by calling either Release_Read or Release_Write. -- As soon as a writer arrive all readers will wait for it to complete. -- Writers discriminant is the maximum number of writers accepted into the -- critical section. protected type RW_Semaphore (Writers : Positive) is -- Readers must call Read to enter the critical section and call -- Release_Read at the end. entry Read; procedure Release_Read; -- Writers must call Write to enter the critical section and call -- Release_Write at the end. entry Write; procedure Release_Write; private R, W : Natural := 0; end RW_Semaphore; ------------- -- Streams -- ------------- type Stream_Element_Array_Access is access Ada.Streams.Stream_Element_Array; procedure Free is new Ada.Unchecked_Deallocation (Ada.Streams.Stream_Element_Array, Stream_Element_Array_Access); end PolyORB.Web.Utils; polyorb-2.8~20110207.orig/src/web_common/polyorb-web-mime.adb0000644000175000017500000001221211750740340023152 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . W E B . M I M E -- -- -- -- B o d y -- -- -- -- Copyright (C) 2000-2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with Ada.Characters.Handling; with Ada.Strings.Maps; with Ada.Strings.Fixed; package body PolyORB.Web.MIME is use Ada; type String_Access is access constant String; type Mapping is record File_Type : String_Access; Content_Type : String_Access; end record; -- extensions Dot_Html : aliased constant String := ".html"; Dot_Htm : aliased constant String := ".htm"; Dot_XML : aliased constant String := ".xml"; Dot_Txt : aliased constant String := ".txt"; Dot_Ada : aliased constant String := ".ada"; Dot_Ads : aliased constant String := ".ads"; Dot_Adb : aliased constant String := ".adb"; Dot_C : aliased constant String := ".c"; Dot_H : aliased constant String := ".h"; Dot_Gif : aliased constant String := ".gif"; Dot_Jpg : aliased constant String := ".jpg"; Dot_Jpeg : aliased constant String := ".jpeg"; Dot_Png : aliased constant String := ".png"; Dot_Ps : aliased constant String := ".ps"; Dot_Pdf : aliased constant String := ".pdf"; Dot_Zip : aliased constant String := ".zip"; Dot_Gz : aliased constant String := ".gz"; Dot_Tar : aliased constant String := ".tar"; Dot_Exe : aliased constant String := ".exe"; Type_Table : constant array (1 .. 19) of Mapping := ((Dot_Html'Access, Text_HTML'Access), (Dot_Htm'Access, Text_HTML'Access), (Dot_XML'Access, Text_XML'Access), (Dot_Txt'Access, Text_Plain'Access), (Dot_Ada'Access, Text_Plain'Access), (Dot_Ads'Access, Text_Plain'Access), (Dot_Adb'Access, Text_Plain'Access), (Dot_C'Access, Text_Plain'Access), (Dot_H'Access, Text_Plain'Access), (Dot_Gif'Access, Image_Gif'Access), (Dot_Jpg'Access, Image_Jpeg'Access), (Dot_Jpeg'Access, Image_Jpeg'Access), (Dot_Png'Access, Image_Png'Access), (Dot_Ps'Access, Appl_Postscript'Access), (Dot_Pdf'Access, Appl_Pdf'Access), (Dot_Zip'Access, Appl_Zip'Access), (Dot_Gz'Access, Appl_Octet_Stream'Access), (Dot_Tar'Access, Appl_Octet_Stream'Access), (Dot_Exe'Access, Appl_Octet_Stream'Access)); -------------- -- To_Lower -- -------------- function To_Lower (Item : String) return String renames Ada.Characters.Handling.To_Lower; -- Just a shorter name ------------- -- Content -- ------------- function Content_Type (Filename : String) return String is Default_Content_Type : constant String := "application/octet-stream"; Pos : constant Natural := Strings.Fixed.Index (Filename, Strings.Maps.To_Set ("."), Going => Strings.Backward); begin if Pos > 0 then declare File_Type : constant String := To_Lower (Filename (Pos .. Filename'Last)); begin for I in Type_Table'Range loop if File_Type = Type_Table (I).File_Type.all then return Type_Table (I).Content_Type.all; end if; end loop; end; end if; return Default_Content_Type; end Content_Type; end PolyORB.Web.MIME; polyorb-2.8~20110207.orig/src/web_common/polyorb-web-url.ads0000644000175000017500000001763511750740340023064 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . W E B . U R L -- -- -- -- S p e c -- -- -- -- Copyright (C) 2000-2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with Ada.Strings.Unbounded; package PolyORB.Web.URL is -- The general URL form as described in RFC2616 is: -- -- http_URL = "http:" "//" host [ ":" port ] [ abs_path [ "?" query ]] -- -- Note also that there are different RFC describing URL like the 2616 and -- 1738 but they use different terminologies. Here we try to follow the -- names used in RFC2616 but we have implemented some extensions at the -- end of this package. For example the way Path and File are separated or -- the handling of user/password which is explicitly not allowed in the -- RFC but are used and supported in many browsers. Here are the extended -- URL supported: -- -- http://username:password@www.here.com:80/dir1/dir2/xyz.html?p=8&x=doh -- | | | | | | -- protocol host port path file parameters -- -- <-- pathname --> type Object is private; URL_Error : exception; Default_HTTP_Port : constant := 80; Default_HTTPS_Port : constant := 443; function Parse (URL : String; Check_Validity : Boolean := True; Normalize : Boolean := False) return Object; -- Parse an URL and return an Object representing this URL. It is then -- possible to extract each part of the URL with the services bellow. -- Raises URL_Error if Check_Validity is true and the URL reference a -- resource above the web root directory. procedure Normalize (URL : in out Object); -- Removes all occurrences to parent directory ".." and current directory -- ".". Raises URL_Error if the URL reference a resource above the Web -- root directory. function Is_Valid (URL : Object) return Boolean; -- Returns True if the URL is valid (does not reference directory above -- the Web root). function URL (URL : Object) return String; -- Returns full URL string, this can be different to the URL passed if it -- has been normalized. function Protocol_Name (URL : Object) return String; -- Returns "http" or "https" depending on the protocol used by URL. function Host (URL : Object) return String; -- Returns the hostname. function Protocol (URL : Object) return String; -- returns the protocol used by the connection function Port (URL : Object) return Positive; -- Returns the port as a positive. function Port (URL : Object) return String; -- Returns the port as a string. function Abs_Path (URL : Object; Encode : Boolean := False) return String; -- Returns the absolute path. This is the complete resource reference -- without the query part. function Query (URL : Object; Encode : Boolean := False) return String; -- Returns the Query part of the URL or the empty string if none was -- specified. Note that character '?' is not part of the Query and is -- therefore not returned. -- -- Below are extended API not part of the RFC 2616 URL specification. -- function User (URL : Object) return String; -- Returns user name part of the URL. Returns the empty string if user was -- not specified. function Password (URL : Object) return String; -- Returns user's password part of the URL. Returns the empty string if -- password was not specified. function Server_Name (URL : Object) return String renames Host; function Security (URL : Object) return Boolean; -- Returns True if it is a Secure HTTP (HTTPS) URL. function Path (URL : Object; Encode : Boolean := False) return String; -- Returns the Path (including the leading slash). If Encode is True then -- the URL will be encoded using the Encode routine. function File (URL : Object; Encode : Boolean := False) return String; -- Returns the File. If Encode is True then the URL will be encoded using -- the Encode routine. Not that by File here we mean the latest part of -- the URL, it could be a real file or a diretory into the filesystem. -- Parent and current directories are part of the path. function Parameters (URL : Object; Encode : Boolean := False) return String; -- Returns the Parameters (including the starting ? character). If Encode -- is True then the URL will be encoded using the Encode routine. function Pathname (URL : Object; Encode : Boolean := False) return String renames Abs_Path; function Pathname_And_Parameters (URL : Object; Encode : Boolean := False) return String; -- Returns the pathname and the parameters. This is equivalent to: -- Pathname & Parameters. function URI (URL : Object; Encode : Boolean := False) return String; -- Returns the URI. If Encode is True then the URI will be encoded using -- the Encode routine. -- For the SOAP personnality -- -- URL Encoding and Decoding -- function Encode (Str : String) return String; -- Encode Str into a URL-safe form. Many characters are forbiden into an -- URL and needs to be encoded. A character is encoded by %XY where XY is -- the character's ASCII hexadecimal code. For example a space is encoded -- as %20. function Decode (Str : String) return String; -- This is the oposite of Encode above. private use Ada.Strings.Unbounded; type Path_Status is (Valid, Wrong); type Object is record User : Unbounded_String; Password : Unbounded_String; Host : Unbounded_String; Protocol : Unbounded_String; Port : Positive := Default_HTTP_Port; Security : Boolean := False; Path : Unbounded_String; -- Original path N_Path : Unbounded_String; -- Normalized path File : Unbounded_String; Params : Unbounded_String; Status : Path_Status := Wrong; end record; end PolyORB.Web.URL; polyorb-2.8~20110207.orig/src/web_common/polyorb-web-url-raise_url_error.ads0000644000175000017500000000440411750740340026246 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . W E B . U R L . R A I S E _ U R L _ E R R O R -- -- -- -- S p e c -- -- -- -- Copyright (C) 2000-2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- Raises exception URL_Error, exception message contains reference to URL -- and the specified message. procedure PolyORB.Web.URL.Raise_URL_Error (URL : String; Message : String); pragma No_Return (Raise_URL_Error); pragma Inline (Raise_URL_Error); polyorb-2.8~20110207.orig/src/web_common/polyorb-web.ads0000644000175000017500000000441411750740340022253 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . W E B -- -- -- -- S p e c -- -- -- -- Copyright (C) 2000-2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- This is a copy of some units from AWS, renamed to PolyORB.Web to avoid -- name clashes. package PolyORB.Web is pragma Pure (PolyORB.Web); Version : constant String := "1.3"; HTTP_Version : constant String := "HTTP/1.1"; end PolyORB.Web; polyorb-2.8~20110207.orig/src/web_common/polyorb-web-url-raise_url_error.adb0000644000175000017500000000440611750740340026227 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . W E B . U R L . R A I S E _ U R L _ E R R O R -- -- -- -- B o d y -- -- -- -- Copyright (C) 2000-2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with Ada.Exceptions; procedure PolyORB.Web.URL.Raise_URL_Error (URL : String; Message : String) is begin Ada.Exceptions.Raise_Exception (URL_Error'Identity, "Wrong URL: (" & URL & ") " & Message & '.'); end PolyORB.Web.URL.Raise_URL_Error; polyorb-2.8~20110207.orig/src/web_common/polyorb-web-url.adb0000644000175000017500000005022611750740340023034 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . W E B . U R L -- -- -- -- B o d y -- -- -- -- Copyright (C) 2000-2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with Ada.Characters.Handling; with Ada.Strings.Fixed; with Ada.Strings.Maps; with PolyORB.Web.Utils; pragma Elaborate_All (PolyORB.Web.Utils); with PolyORB.Web.URL.Raise_URL_Error; with PolyORB.Utils; package body PolyORB.Web.URL is use Ada; subtype Escape_Code is String (1 .. 2); Not_Escaped : constant Escape_Code := " "; function Code (C : Character) return Escape_Code; pragma Inline (Code); -- Returns hexadecimal code for character C. function Normalize (Path : Unbounded_String) return Unbounded_String; -- Returns Path with all possible occurences of parent and current -- directories removed. Does not raise exception. -------------- -- Abs_Path -- -------------- function Abs_Path (URL : Object; Encode : Boolean := False) return String is Result : constant String := To_String (URL.Path & URL.File); begin if Encode then return PolyORB.Web.URL.Encode (Result); else return Result; end if; end Abs_Path; ---------- -- Code -- ---------- function Code (C : Character) return Escape_Code is begin return Utils.Hex (Character'Pos (C)); end Code; Hex_Escape : constant array (Character) of Escape_Code := (';' => Code (';'), '/' => Code ('/'), '?' => Code ('?'), ':' => Code (':'), '@' => Code ('@'), '&' => Code ('&'), '=' => Code ('='), '+' => Code ('+'), '$' => Code ('$'), ',' => Code (','), '<' => Code ('<'), '>' => Code ('>'), '#' => Code ('#'), '%' => Code ('%'), '"' => Code ('"'), '{' => Code ('{'), '}' => Code ('}'), '|' => Code ('|'), '\' => Code ('\'), '^' => Code ('^'), '[' => Code ('['), ']' => Code (']'), '`' => Code ('`'), others => Not_Escaped); ------------ -- Decode -- ------------ function Decode (Str : String) return String is Res : String (1 .. Str'Length); K : Natural := 0; I : Positive := Str'First; begin if Str = "" then return ""; end if; loop K := K + 1; if Str (I) = '%' and then I + 2 <= Str'Last and then Characters.Handling.Is_Hexadecimal_Digit (Str (I + 1)) and then Characters.Handling.Is_Hexadecimal_Digit (Str (I + 2)) then Res (K) := Character'Val (Utils.Hex_Value (Str (I + 1 .. I + 2))); I := I + 2; elsif Str (I) = '+' then Res (K) := ' '; else Res (K) := Str (I); end if; I := I + 1; exit when I > Str'Last; end loop; return Res (1 .. K); end Decode; ------------ -- Encode -- ------------ function Encode (Str : String) return String is Res : String (1 .. Str'Length * 3); K : Natural := 0; begin for I in Str'Range loop if Str (I) = ' ' then -- special case for the space that can be encoded as %20 or -- '+'. The later being more readable we use this encoding here. K := K + 1; Res (K) := '+'; elsif Hex_Escape (Str (I)) = Not_Escaped then K := K + 1; Res (K) := Str (I); else K := K + 1; Res (K) := '%'; K := K + 1; Res (K .. K + 1) := Hex_Escape (Str (I)); K := K + 1; end if; end loop; return Res (1 .. K); end Encode; ---------- -- File -- ---------- function File (URL : Object; Encode : Boolean := False) return String is begin if Encode then return PolyORB.Web.URL.Encode (To_String (URL.File)); else return To_String (URL.File); end if; end File; ---------- -- Host -- ---------- function Host (URL : Object) return String is begin return To_String (URL.Host); end Host; -------------- -- Protocol -- -------------- function Protocol (URL : Object) return String is begin return To_String (URL.Protocol); end Protocol; -------------- -- Is_Valid -- -------------- function Is_Valid (URL : Object) return Boolean is begin return URL.Status = Valid; end Is_Valid; --------------- -- Normalize -- --------------- function Normalize (Path : Unbounded_String) return Unbounded_String is URL_Path : Unbounded_String := Path; K : Natural; P : Natural; begin -- Checks for current directory and removes all occurences -- Look for starting ./ if Length (URL_Path) >= 2 and then Slice (URL_Path, 1, 2) = "./" then Delete (URL_Path, 1, 1); end if; -- Look for all /./ references loop K := Index (URL_Path, "/./"); exit when K = 0; Delete (URL_Path, K, K + 1); end loop; -- Checks for parent directory loop K := Index (URL_Path, "/../"); exit when K = 0; -- Look for previous directory, which should be removed. P := Strings.Fixed.Index (Slice (URL_Path, 1, K - 1), "/", Strings.Backward); exit when P = 0; Delete (URL_Path, P, K + 2); end loop; return URL_Path; end Normalize; procedure Normalize (URL : in out Object) is begin URL.Path := URL.N_Path; if URL.Status = Wrong then Raise_URL_Error (To_String (URL.Path), "Reference Web root parent directory"); end if; end Normalize; ---------------- -- Parameters -- ---------------- function Parameters (URL : Object; Encode : Boolean := False) return String is begin if Encode then return PolyORB.Web.URL.Encode (To_String (URL.Params)); else return To_String (URL.Params); end if; end Parameters; ----------- -- Parse -- ----------- function Parse (URL : String; Check_Validity : Boolean := True; Normalize : Boolean := False) return Object is -- HTTP_Token : constant String := "http://"; -- HTTPS_Token : constant String := "https://"; L_URL : constant String := Strings.Fixed.Translate (URL, Strings.Maps.To_Mapping ("\", "/")); P : Natural; O : Object; procedure Parse (URL : String; Protocol_Specified : Boolean); -- Parse URL, the URL must not contain the HTTP_Token prefix. -- Protocol_Specified is set to True when the protocol (http:// or -- https:// prefix) was specified. This is used to raise ambiguity -- while parsing the URL. See comment below. ----------- -- Parse -- ----------- procedure Parse (URL : String; Protocol_Specified : Boolean) is function "+" (S : String) return Unbounded_String renames To_Unbounded_String; procedure Parse_Path_File (Start : Positive); -- Parse Path and File URL information starting at position Start in -- URL. I1, I2, I3 : Natural; F : Positive; --------------------- -- Parse_Path_File -- --------------------- procedure Parse_Path_File (Start : Positive) is PF : constant String := URL (Start .. URL'Last); I3 : constant Natural := Strings.Fixed.Index (PF, "/", Strings.Backward); begin if I3 = 0 then -- No '/' so this is certainly a single file. As a special -- exception we check for current and parent directories -- which must be part of the path. declare File : constant String := URL (Start .. URL'Last); begin if File = ".." or else File = "." then O.Path := +File; O.File := +""; else O.Path := +""; O.File := +File; end if; end; else -- Check that after the last '/' we have not a current or -- parent directories which must be part of the path. declare File : constant String := URL (I3 + 1 .. URL'Last); begin if File = ".." or else File = "." then O.Path := +URL (Start .. URL'Last); O.File := +""; else O.Path := +URL (Start .. I3); O.File := +File; end if; end; end if; end Parse_Path_File; User_Password : Boolean := False; begin I1 := Strings.Fixed.Index (URL, ":"); I2 := Strings.Fixed.Index (URL, "/"); I3 := Strings.Fixed.Index (URL, "@"); -- Check for [user:pawwsord@] if I1 /= 0 and then I3 /= 0 and then I1 < I3 then -- We have [user:password@] O.User := +URL (URL'First .. I1 - 1); O.Password := +URL (I1 + 1 .. I3 - 1); F := I3 + 1; -- Check if there is another ':' specified I1 := Strings.Fixed.Index (URL (F .. URL'Last), ":"); User_Password := True; else F := URL'First; end if; if I1 = 0 and then not User_Password and then not Protocol_Specified then -- No ':', there is no port specified and no host since we did -- not have a [user:password@] parsed and there was no protocol -- specified. Let's just parse the data as a path information. -- -- There is ambiguity here, the data could be either: -- -- some_host_name/some_path -- or -- relative_path/some_more_path -- -- As per explanations above we take the second choice. O.Host := +""; Parse_Path_File (URL'First); elsif I1 = 0 then -- In this case we have not port specified but a [user:password@] -- was found, we expect the first string to be the hostname. if I2 = 0 then -- No path information, case [user:password@host] O.Host := +URL (F .. URL'Last); O.Path := +"/"; else -- A path, case [user:password@host/path] O.Host := +URL (F .. I2 - 1); Parse_Path_File (I2); end if; else -- Here we have a port specified [host:port] O.Host := +URL (F .. I1 - 1); if I2 = 0 then -- No path, we have [host:port] if Utils.Is_Number (URL (I1 + 1 .. URL'Last)) then O.Port := Positive'Value (URL (I1 + 1 .. URL'Last)); else Raise_URL_Error (PolyORB.Web.URL.Parse.URL, "Port is not valid"); end if; O.Path := +"/"; else -- Here we have a complete URL [host:port/path] if Utils.Is_Number (URL (I1 + 1 .. I2 - 1)) then O.Port := Positive'Value (URL (I1 + 1 .. I2 - 1)); else Raise_URL_Error (PolyORB.Web.URL.Parse.URL, "Port is not valid"); end if; Parse_Path_File (I2); end if; end if; end Parse; Index : constant Integer := L_URL'First; Index2 : Integer; begin -- Ada.Text_IO.Put_Line ("PolyORB.Web.URL: URL= " & URL); -- Ada.Text_IO.Put_Line ("PolyORB.Web.URL: L_URL= " & L_URL); Index2 := PolyORB.Utils.Find (L_URL, Index, ':'); if Index2 = L_URL'Last + 1 or else L_URL (Index2 + 1) /= '/' or else L_URL (Index2 + 2) /= '/' then return O; end if; O.Protocol := To_Unbounded_String (L_URL (Index .. Index2 - 1)); declare L3_URL : constant String := (L_URL (Index2 + 3 .. L_URL'Last)); begin O.Security := False; -- Checks for parameters P := Strings.Fixed.Index (L3_URL, "?"); if P = 0 then P := L3_URL'Last; else O.Params := To_Unbounded_String (L3_URL (P .. L3_URL'Last)); P := P - 1; end if; -- Checks for prefix Parse (L3_URL (L3_URL'First .. P), True); end; -- if Messages.Match (L_URL, HTTP_Token) then -- O.Port := Default_HTTP_Port; -- Parse (L_URL (L_URL'First + HTTP_Token'Length .. P), True); -- elsif Messages.Match (L_URL, HTTPS_Token) then -- O.Port := Default_HTTPS_Port; -- Parse (L_URL (L_URL'First + HTTPS_Token'Length .. P), True); -- O.Security := True; -- elsif L_URL /= "" then -- -- Prefix is not recognied, this is either because there is no -- -- protocol specified or the protocol is not supported by AWS. -- -- For example a javascript reference start with "javascript:". -- -- This will be catched on the next parsing level. -- -- -- -- At least we know that it is not a Secure HTTP protocol URL. -- O.Security := False; -- Parse (L_URL (L_URL'First .. P), False); -- end if; -- Normalize the URL path O.N_Path := PolyORB.Web.URL.Normalize (O.Path); -- Set status declare Path_Len : constant Natural := Length (O.N_Path); begin if (Path_Len >= 4 and then Slice (O.N_Path, 1, 4) = "/../") or else (Path_Len = 3 and then Slice (O.N_Path, 1, 3) = "/..") then O.Status := Wrong; else O.Status := Valid; end if; end; -- If Normalize is activated, the active URL Path is the normalized one if Normalize then O.Path := O.N_Path; end if; -- Raise URL_Error is the URL is suspicious if Check_Validity and then O.Status = Wrong then Raise_URL_Error (To_String (O.N_Path), "Reference Web root parent directory"); end if; return O; end Parse; -------------- -- Password -- -------------- function Password (URL : Object) return String is begin return To_String (URL.Password); end Password; ---------- -- Path -- ---------- function Path (URL : Object; Encode : Boolean := False) return String is begin if Encode then return PolyORB.Web.URL.Encode (To_String (URL.Path)); else return To_String (URL.Path); end if; end Path; ----------------------------- -- Pathname_And_Parameters -- ----------------------------- function Pathname_And_Parameters (URL : Object; Encode : Boolean := False) return String is begin return Pathname (URL, Encode) & Parameters (URL, Encode); end Pathname_And_Parameters; ---------- -- Port -- ---------- function Port (URL : Object) return Positive is begin return URL.Port; end Port; function Port (URL : Object) return String is P_Image : constant String := Positive'Image (URL.Port); begin return P_Image (2 .. P_Image'Last); end Port; ------------------- -- Protocol_Name -- ------------------- function Protocol_Name (URL : Object) return String is begin if URL.Security then return "https"; else return "http"; end if; end Protocol_Name; ----------- -- Query -- ----------- function Query (URL : Object; Encode : Boolean := False) return String is P : constant String := Parameters (URL, Encode); begin return P (P'First + 1 .. P'Last); end Query; -------------- -- Security -- -------------- function Security (URL : Object) return Boolean is begin return URL.Security; end Security; --------- -- URI -- --------- function URI (URL : Object; Encode : Boolean := False) return String is begin if Encode then return PolyORB.Web.URL.Encode (To_String (URL.Path)); else return To_String (URL.Path); end if; end URI; --------- -- URL -- --------- function URL (URL : Object) return String is function Port return String; pragma Inline (Port); -- Returns the port number if not the standard HTTP or HTTPS Port and -- the empty string otherwise. function User_Password return String; pragma Inline (User_Password); -- Returns the user:password@ if present and the empty string otherwise ---------- -- Port -- ---------- function Port return String is begin if URL.Security then if URL.Port /= Default_HTTPS_Port then return ':' & Port (URL); else return ""; end if; else if URL.Port /= Default_HTTP_Port then return ':' & Port (URL); else return ""; end if; end if; end Port; ------------------- -- User_Password -- ------------------- function User_Password return String is User : constant String := To_String (URL.User); Password : constant String := To_String (URL.Password); begin if User = "" then if Password = "" then return ""; else return ':' & Password & '@'; end if; else if Password = "" then return User & ":@"; else return User & ':' & Password & '@'; end if; end if; end User_Password; begin if Host (URL) = "" then return Pathname_And_Parameters (URL); else return Protocol_Name (URL) & "://" & User_Password & Host (URL) & Port & Pathname (URL) & Parameters (URL); end if; end URL; ---------- -- User -- ---------- function User (URL : Object) return String is begin return To_String (URL.User); end User; end PolyORB.Web.URL; polyorb-2.8~20110207.orig/src/web_common/polyorb-web-utils.adb0000644000175000017500000001615211750740340023372 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . W E B . U T I L S -- -- -- -- B o d y -- -- -- -- Copyright (C) 2000-2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with Ada.Integer_Text_IO; with Ada.Strings.Fixed; with Ada.Strings.Maps.Constants; with Ada.Numerics.Discrete_Random; package body PolyORB.Web.Utils is use Ada; package Integer_Random is new Ada.Numerics.Discrete_Random (Random_Integer); Random_Generator : Integer_Random.Generator; ------------------- -- CRLF_2_Spaces -- ------------------- function CRLF_2_Spaces (Str : String) return String is begin return Strings.Fixed.Trim (Strings.Fixed.Translate (Str, Strings.Maps.To_Mapping (From => ASCII.CR & ASCII.LF, To => " ")), Strings.Right); end CRLF_2_Spaces; --------- -- Hex -- --------- function Hex (V : Natural; Width : Natural := 0) return String is use Strings; Hex_V : String (1 .. Integer'Size / 4 + 4); begin Ada.Integer_Text_IO.Put (Hex_V, V, 16); declare Result : constant String := Hex_V (Fixed.Index (Hex_V, "#") + 1 .. Fixed.Index (Hex_V, "#", Backward) - 1); begin if Width = 0 then return Result; elsif Result'Length < Width then declare use Ada.Strings.Fixed; Zero : constant String := (Width - Result'Length) * '0'; begin return Zero & Result; end; else return Result (Result'Last - Width + 1 .. Result'Last); end if; end; end Hex; --------------- -- Hex_Value -- --------------- function Hex_Value (Hex : String) return Natural is function Value (C : Character) return Natural; pragma Inline (Value); -- Return value for single character C. function Value (C : Character) return Natural is begin case C is when '0' => return 0; when '1' => return 1; when '2' => return 2; when '3' => return 3; when '4' => return 4; when '5' => return 5; when '6' => return 6; when '7' => return 7; when '8' => return 8; when '9' => return 9; when 'a' | 'A' => return 10; when 'b' | 'B' => return 11; when 'c' | 'C' => return 12; when 'd' | 'D' => return 13; when 'e' | 'E' => return 14; when 'f' | 'F' => return 15; when others => raise Constraint_Error; end case; end Value; R : Natural := 0; Exp : Natural := 1; begin for K in reverse Hex'Range loop R := R + Exp * Value (Hex (K)); Exp := Exp * 16; end loop; return R; end Hex_Value; ----------- -- Image -- ----------- function Image (N : Natural) return String is N_Img : constant String := Natural'Image (N); begin return N_Img (N_Img'First + 1 .. N_Img'Last); end Image; ----------- -- Image -- ----------- function Image (D : Duration) return String is D_Img : constant String := Duration'Image (D); K : constant Natural := Strings.Fixed.Index (D_Img, "."); begin if K = 0 then return D_Img (D_Img'First + 1 .. D_Img'Last); else return D_Img (D_Img'First + 1 .. K + 2); end if; end Image; --------------- -- Is_Number -- --------------- function Is_Number (S : String) return Boolean is use Strings.Maps; begin return S'Length > 0 and then Is_Subset (To_Set (S), Constants.Decimal_Digit_Set); end Is_Number; ----------- -- Quote -- ----------- function Quote (Str : String) return String is begin return '"' & Str & '"'; end Quote; ------------ -- Random -- ------------ function Random return Random_Integer is begin return Integer_Random.Random (Random_Generator); end Random; ------------------ -- RW_Semaphore -- ------------------ protected body RW_Semaphore is ---------- -- Read -- ---------- entry Read when W = 0 and then Write'Count = 0 is begin R := R + 1; end Read; ------------------ -- Release_Read -- ------------------ procedure Release_Read is begin R := R - 1; end Release_Read; ------------------- -- Release_Write -- ------------------- procedure Release_Write is begin W := W - 1; end Release_Write; ----------- -- Write -- ----------- entry Write when R = 0 and then W < Writers is begin W := W + 1; end Write; end RW_Semaphore; --------------- -- Semaphore -- --------------- protected body Semaphore is ------------- -- Release -- ------------- procedure Release is begin Seized := False; end Release; ----------- -- Seize -- ----------- entry Seize when not Seized is begin Seized := True; end Seize; end Semaphore; begin Integer_Random.Reset (Random_Generator); end PolyORB.Web.Utils; polyorb-2.8~20110207.orig/src/web_common/polyorb-web-mime.ads0000644000175000017500000000631511750740340023202 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . W E B . M I M E -- -- -- -- S p e c -- -- -- -- Copyright (C) 2000-2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ package PolyORB.Web.MIME is pragma Preelaborate; Text_HTML : aliased constant String := "text/html"; Text_XML : aliased constant String := "text/xml"; Text_Plain : aliased constant String := "text/plain"; Image_Gif : aliased constant String := "image/gif"; Image_Jpeg : aliased constant String := "image/jpeg"; Image_Png : aliased constant String := "image/png"; Appl_Postscript : aliased constant String := "application/postscript"; Appl_Pdf : aliased constant String := "application/pdf"; Appl_Zip : aliased constant String := "application/zip"; Appl_Octet_Stream : aliased constant String := "application/octet-stream"; Appl_Form_Data : aliased constant String := "application/x-www-form-urlencoded"; Multipart_Form_Data : aliased constant String := "multipart/form-data"; Multipart_Mixed_Replace : constant String := "multipart/x-mixed-replace"; function Content_Type (Filename : String) return String; -- Determine the MIME Content Type from the file's type extension. -- Returns "application/octet-stream" if the file type is unknown. end PolyORB.Web.MIME; polyorb-2.8~20110207.orig/src/polyorb-components.adb0000644000175000017500000001025311750740340021513 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . C O M P O N E N T S -- -- -- -- B o d y -- -- -- -- Copyright (C) 2001-2008, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- A communication filter (a transport Data_Unit handler/forwarder). with Ada.Tags; pragma Warnings (Off, Ada.Tags); -- Only used within pragma Debug. with Ada.Unchecked_Deallocation; with PolyORB.Log; package body PolyORB.Components is use Ada.Tags; use PolyORB.Log; package L is new PolyORB.Log.Facility_Log ("polyorb.components"); procedure O (Message : String; Level : Log_Level := Debug) renames L.Output; function C (Level : Log_Level := Debug) return Boolean renames L.Enabled; ------------- -- Connect -- ------------- procedure Connect (Port : out Component_Access; Target : Component_Access) is begin Port := Target; end Connect; ------------- -- Destroy -- ------------- procedure Destroy (Comp : in out Component) is pragma Unreferenced (Comp); begin null; end Destroy; ------------- -- Destroy -- ------------- procedure Destroy (Comp : in out Component_Access) is procedure Free is new Ada.Unchecked_Deallocation (Component'Class, Component_Access); begin pragma Debug (C, O ("Destroying component " & Ada.Tags.External_Tag (Comp'Tag))); Destroy (Comp.all); Free (Comp); end Destroy; ---------- -- Emit -- ---------- function Emit (Port : Component_Access; Msg : Message'Class) return Message'Class is Res : constant Null_Message := (null record); begin if Port /= null then pragma Debug (C, O ("Sending message " & External_Tag (Msg'Tag) & " to target " & External_Tag (Port.all'Tag))); return Handle_Message (Port, Msg); else pragma Debug (C, O ("Message " & External_Tag (Msg'Tag) & " ignored (null target)")); return Res; end if; end Emit; ------------------- -- Emit_No_Reply -- ------------------- procedure Emit_No_Reply (Port : Component_Access; Msg : Message'Class) is Reply : constant Message'Class := Emit (Port, Msg); begin pragma Assert (Reply in Null_Message); null; end Emit_No_Reply; end PolyORB.Components; polyorb-2.8~20110207.orig/src/polyorb-initialization.adb0000644000175000017500000004662511750740340022371 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . I N I T I A L I Z A T I O N -- -- -- -- B o d y -- -- -- -- Copyright (C) 2002-2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- Automatic initialization of PolyORB subsystems with PolyORB.Log; with PolyORB.Platform; with PolyORB.Utils.Chained_Lists; package body PolyORB.Initialization is use PolyORB.Log; package L is new PolyORB.Log.Facility_Log ("polyorb.initialization"); procedure O (Message : String; Level : Log_Level := Debug) renames L.Output; function C (Level : Log_Level := Debug) return Boolean renames L.Enabled; use String_Lists; ----------------------------- -- Private data structures -- ----------------------------- type Module; type Module_Access is access all Module; package Module_Lists is new PolyORB.Utils.Chained_Lists (Module_Access); use Module_Lists; type Dependency is record Target : Module_Access; -- The module being depended upon Optional : Boolean; -- If True, failure to initialize the target is not a fatal error end record; package Dep_Lists is new PolyORB.Utils.Chained_Lists (Dependency); use Dep_Lists; type Module (Virtual : Boolean) is record Deps : Dep_Lists.List; -- Dependencies Visited : Boolean := False; -- Has this module been traversed? Initialized : Boolean := False; -- Has this module been actually initialized (differs from Visited if -- module is disabled). Deps_In_Progress : Boolean := False; -- Are the dependencies of this module being traversed? case Virtual is when False => Info : Module_Info; when True => Name : Utils.Strings.String_Ptr; end case; end record; Initialized : Boolean := False; type Init_Info_T is record World : Module_Lists.List; -- The list of all modules Shutdown_Order : Module_Lists.List; -- List of finalization procedures for all initialized modules, in -- reverse initialization order. Implicit_Deps : Dep_Lists.List; -- The list of modules marked as implicit dependencies end record; type Init_Info_A is access Init_Info_T; Init_Info : Init_Info_A; -- For Initialization to be preelaborable, it may not contain object -- declarations of a private type or a non-static initializer, so -- instead the data structures used here are allocated upon the first -- call to Register_Module. -------------------------- -- Internal subprograms -- -------------------------- procedure Raise_Program_Error (Msg : String); pragma No_Return (Raise_Program_Error); -- Raise Program_Error with the given exception message procedure Check_Conflicts; -- For each module, check that it does not conflict with any other -- registered module. If no conflicts are detected, the name of the modules -- and its aliases (the names of the subsystems it implements) are entered -- into the global World list. procedure Resolve_Dependencies; -- For each registered module, construct the list of its -- direct dependencies. procedure Run_Initializers; -- Perform a topological sort on the dependency graph and -- initialize each module. function Module_Name (Module : Module_Access) return Utils.Strings.String_Ptr; -- Return the name of Module. function Lookup_Module (Name : String) return Module_Access; -- Look up module 'Name' in modules list, return null if not found. procedure Check_Duplicate (Name : String); -- Check that no module with the given name already exists, otherwise -- raise an exception. procedure Visit (M : Module_Access; Circular_Dependency_Detected : out Boolean); -- Visit 'M' dependencies and run the corresponding initializers; -- Circular_Dependency_Detected reports circularity between modules. procedure Raise_Unresolved_Dependency (From, Upon : String); pragma No_Return (Raise_Unresolved_Dependency); -- Output a diagnostic message for an unresolved dependency, and -- raise the appropriate exception. ------------------- -- Lookup_Module -- ------------------- function Lookup_Module (Name : String) return Module_Access is It : Module_Lists.Iterator := First (Init_Info.World); begin while not Last (It) loop if Module_Name (Value (It).all).all = Name then return Value (It).all; end if; Next (It); end loop; return null; end Lookup_Module; --------------------- -- Register_Module -- --------------------- procedure Register_Module (Info : Module_Info) is M : Module (Virtual => False); begin if Initialized then -- If we call Register_Module after Initialization is done, -- then there is a deep problem. Raise_Program_Error ("Initialization already done, cannot register " & Info.Name.all); end if; if Init_Info = null then Init_Info := new Init_Info_T; end if; M.Info := Info; declare New_M : constant Module_Access := new Module'(M); begin Check_Duplicate (Info.Name.all); Append (Init_Info.World, New_M); if Info.Implicit then Append (Init_Info.Implicit_Deps, Dependency'( Target => New_M, Optional => True)); -- We know for sure that the target module is present, but -- we need to make the dependency optional for the case where -- the module is disabled. end if; end; end Register_Module; --------------------- -- Check_Conflicts -- --------------------- procedure Check_Conflicts is MI : Module_Lists.Iterator := First (Init_Info.World); SI : String_Lists.Iterator; Current : Module_Access; Conflicting : Module_Access; begin -- Register all modules and aliases while not Last (MI) loop Current := Value (MI).all; exit when Current.Virtual; SI := First (Current.Info.Provides); while not Last (SI) loop declare Name : String renames Value (SI).all; Last : Integer := Name'Last; Virtual : Module_Access; begin if Name (Last) = '!' then Last := Last - 1; String_Lists.Append (Current.Info.Conflicts, Name (Name'First .. Last)); end if; Virtual := Lookup_Module (Name (Name'First .. Last)); if Virtual = null then Virtual := new Module (Virtual => True); Virtual.Name := new String'(Name (Name'First .. Last)); Check_Duplicate (Virtual.Name.all); Append (Init_Info.World, Virtual); end if; Prepend (Virtual.Deps, Dependency'( Target => Current, Optional => False)); end; Next (SI); end loop; Next (MI); end loop; -- Walk each conflict list, looking for a conflicting registered module MI := First (Init_Info.World); loop -- Skip over virtual modules (they do not have a conflicts list) while not Last (MI) loop Current := Value (MI).all; exit when not Current.Virtual; Next (MI); end loop; exit when Last (MI); -- Check for conflicting modules SI := First (Current.Info.Conflicts); while not Last (SI) loop Conflicting := Lookup_Module (Value (SI).all); if Conflicting /= null then if Conflicting.Virtual then declare First_Provider : constant Module_Access := Value (First (Conflicting.Deps)).Target; begin -- For a conflict against a virtual module, do not fail -- if Current is the only provider: the conflict entry -- means in this case "conflict with any other provider". if First_Provider = Current and then Length (Conflicting.Deps) = 1 then null; else Raise_Program_Error ("Conflict between " & Module_Name (Current).all & " and " & Module_Name (Conflicting).all & " provided by " & Module_Name (First_Provider).all); end if; end; else Raise_Program_Error ("Conflict between " & Module_Name (Current).all & " and " & Module_Name (Conflicting).all); end if; end if; Next (SI); end loop; Next (MI); end loop; end Check_Conflicts; --------------------- -- Check_Duplicate -- --------------------- procedure Check_Duplicate (Name : String) is Duplicate : constant Module_Access := Lookup_Module (Name); begin pragma Debug (C, O ("Registering " & Name)); if Duplicate /= null then Raise_Program_Error ("Conflict: " & Name & " already registered."); end if; end Check_Duplicate; ------------------------- -- Raise_Program_Error -- ------------------------- procedure Raise_Program_Error (Msg : String) is begin raise Program_Error with Msg; end Raise_Program_Error; -------------------------- -- Resolve_Dependencies -- -------------------------- procedure Resolve_Dependencies is MI : Module_Lists.Iterator := First (Init_Info.World); IDI : Dep_Lists.Iterator; SI : String_Lists.Iterator; Current : Module_Access; begin while not Last (MI) loop Current := Value (MI).all; if not Current.Virtual then SI := First (Current.Info.Depends); while not Last (SI) loop declare Dep_Name : String renames Value (SI).all; Last : Integer := Dep_Name'Last; Dep_Module : Module_Access; Optional : Boolean := False; begin if Last in Dep_Name'Range and then Dep_Name (Last) = '?' then Optional := True; Last := Last - 1; end if; Dep_Module := Lookup_Module (Dep_Name (Dep_Name'First .. Last)); if Dep_Module /= null then Prepend (Current.Deps, Dependency'( Target => Dep_Module, Optional => Optional)); elsif not Optional then Raise_Unresolved_Dependency (From => Module_Name (Current).all, Upon => Dep_Name); end if; end; if not Current.Info.Implicit then IDI := First (Init_Info.Implicit_Deps); while not Last (IDI) loop Prepend (Current.Deps, Value (IDI).all); Next (IDI); end loop; end if; Next (SI); end loop; end if; Next (MI); end loop; end Resolve_Dependencies; ----------- -- Visit -- ----------- procedure Visit (M : Module_Access; Circular_Dependency_Detected : out Boolean) is MI : Dep_Lists.Iterator; Dep : Dependency; One_Dep_Initialized : Boolean := False; begin if M.Deps_In_Progress then O (M.Info.Name.all & " is part of a cycle:", Critical); Circular_Dependency_Detected := True; return; end if; Circular_Dependency_Detected := False; -- Note that we visit the dependencies of a module even if the module -- is disabled. This is necessary to ensure that it is possible to -- disable any module that depends on "parameters". M.Deps_In_Progress := True; MI := First (M.Deps); while not Last (MI) loop Dep := Value (MI).all; pragma Debug (C, O ("DEP: """ & Module_Name (M).all & """ -> """ & Module_Name (Dep.Target).all & """;")); if not Dep.Target.Visited then begin Visit (Dep.Target, Circular_Dependency_Detected); if Circular_Dependency_Detected then O ("... depended upon by " & Module_Name (Dep.Target).all, Critical); return; end if; if not (False or else Dep.Optional or else M.Virtual or else Dep.Target.Initialized) then -- Non-optional dependency of a non-virtual module upon a -- module that is disabled. Raise_Unresolved_Dependency (From => Module_Name (M).all, Upon => Module_Name (Dep.Target).all); return; end if; end; end if; if Dep.Target.Initialized then One_Dep_Initialized := True; end if; Next (MI); end loop; M.Deps_In_Progress := False; pragma Debug (C, O ("Processed dependencies of " & Module_Name (M).all)); if Get_Conf_Hook /= null and then not Utils.Strings.To_Boolean (Get_Conf_Hook ("modules", Module_Name (M).all, "enable")) then -- This module is not enabled. return; end if; if M.Virtual then -- A virtual module is considered as initialized if at least -- one of its providers had been initialized. M.Initialized := One_Dep_Initialized; else begin M.Info.Init.all; M.Initialized := True; exception when others => -- XXX When all supported compilers honor the pragma -- Preelaborate_05 in Ada.Exceptions, we can add exception -- information to this message. O ("Initialization of " & Module_Name (M).all & " raised an exception"); raise; end; -- If module needs to be shut down, we add it to the shutdown list if M.Info.Shutdown /= null then Prepend (Init_Info.Shutdown_Order, M); end if; end if; O ("Initialization of " & Module_Name (M).all & " was successful."); M.Visited := True; end Visit; ---------------------- -- Run_Initializers -- ---------------------- procedure Run_Initializers is MI : Module_Lists.Iterator := First (Init_Info.World); M : Module_Access; Circular_Dependency_Detected : Boolean; begin while not Last (MI) loop M := Value (MI).all; if not M.Visited then Visit (M, Circular_Dependency_Detected); if Circular_Dependency_Detected then Raise_Program_Error ("Circular dependency detected"); end if; end if; Next (MI); end loop; end Run_Initializers; ---------------------- -- Initialize_World -- ---------------------- procedure Initialize_World is begin if Initialized then Raise_Program_Error ("Already initialized"); end if; pragma Debug (C, O ("Initializing PolyORB " & Platform.Version)); if Init_Info /= null then -- Initialize registered modules: -- Recursive traversal of the dependency graph then initialize -- each module in reverse topological order. Check_Conflicts; Resolve_Dependencies; Run_Initializers; end if; Initialized := True; end Initialize_World; -------------------- -- Is_Initialized -- -------------------- function Is_Initialized return Boolean is begin return Initialized; end Is_Initialized; ----------------- -- Module_Name -- ----------------- function Module_Name (Module : Module_Access) return Utils.Strings.String_Ptr is begin if Module.Virtual then return Module.Name; else return Module.Info.Name; end if; end Module_Name; --------------------------------- -- Raise_Unresolved_Dependency -- --------------------------------- procedure Raise_Unresolved_Dependency (From, Upon : String) is begin Raise_Program_Error ("Unresolved dependency: " & From & " -> " & Upon); end Raise_Unresolved_Dependency; -------------------- -- Shutdown_World -- -------------------- procedure Shutdown_World (Wait_For_Completion : Boolean := True) is L : Module_Lists.List renames Init_Info.Shutdown_Order; M : Module_Access; begin pragma Debug (C, O ("Shutting down PolyORB")); while not Is_Empty (L) loop Extract_First (L, M); pragma Debug (C, O ("Shutting down module " & Module_Name (M).all)); M.Info.Shutdown (Wait_For_Completion); end loop; pragma Debug (C, O ("Shutdown of PolyORB completed")); end Shutdown_World; end PolyORB.Initialization; polyorb-2.8~20110207.orig/src/polyorb-if_descriptors.ads0000644000175000017500000000621511750740340022371 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . I F _ D E S C R I P T O R S -- -- -- -- S p e c -- -- -- -- Copyright (C) 2002-2009, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- Abstract interface for Interface Descriptors: services -- that provide meta-data regarding the signatures of methods. with PolyORB.Any; with PolyORB.Any.NVList; with PolyORB.References; with PolyORB.Smart_Pointers; package PolyORB.If_Descriptors is type If_Descriptor is abstract new Smart_Pointers.Non_Controlled_Entity with private; type If_Descriptor_Access is access all If_Descriptor'Class; Default_If_Descriptor : If_Descriptor_Access; function Get_Empty_Arg_List (If_Desc : access If_Descriptor; Object : PolyORB.References.Ref; Method : String) return Any.NVList.Ref is abstract; -- Return the paramter profile of the given method, so the -- protocol layer can unmarshall the message into a Request object. function Get_Empty_Result (If_Desc : access If_Descriptor; Object : PolyORB.References.Ref; Method : String) return Any.Any is abstract; -- Return the result profile of the given method. private type If_Descriptor is abstract new Smart_Pointers.Non_Controlled_Entity with null record; end PolyORB.If_Descriptors; polyorb-2.8~20110207.orig/src/polyorb-filters-fragmenter.adb0000644000175000017500000001765011750740340023136 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . F I L T E R S . F R A G M E N T E R -- -- -- -- B o d y -- -- -- -- Copyright (C) 2001-2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- Fragmenter filter -- Fragment data which comes from endpoint whithout read length control -- For example UDP sockets with PolyORB.Filters.Iface; with PolyORB.Log; with PolyORB.Types; with PolyORB.Representations.CDR.Common; package body PolyORB.Filters.Fragmenter is use Ada.Streams; use PolyORB.Buffers; use PolyORB.Components; use PolyORB.Filters.Iface; use PolyORB.Log; package L is new PolyORB.Log.Facility_Log ("polyorb.filters.fragmenter"); procedure O (Message : String; Level : Log_Level := Debug) renames L.Output; function C (Level : Log_Level := Debug) return Boolean renames L.Enabled; ------------ -- Create -- ------------ procedure Create (Fact : access Fragmenter_Factory; Fragmenter : out Filter_Access) is pragma Unreferenced (Fact); Res : constant Filter_Access := new Fragmenter_Filter; begin Fragmenter_Filter (Res.all).Data_Expected := 0; -- Create buffer for lower filter Fragmenter_Filter (Res.all).Socket_Buf := new Buffer_Type; Fragmenter := Res; end Create; procedure Copy (From : access Buffer_Type; To : access Buffer_Type; Len : Ada.Streams.Stream_Element_Count); -- Copy data from From to To, leaving CDR position of To unchanged ---------- -- Copy -- ---------- procedure Copy (From : access Buffer_Type; To : access Buffer_Type; Len : Ada.Streams.Stream_Element_Count) is use PolyORB.Representations.CDR.Common; K : constant Stream_Element_Offset := CDR_Position (To); Temp : Types.Octet; begin for J in 1 .. Integer (Len) loop Temp := Unmarshall (From); Marshall (To, Temp); end loop; Set_CDR_Position (To, K); end Copy; ------------------ -- Process_Data -- ------------------ -- this function process data -- ask for other data if there is not enough data -- or send data to upper fiter function Process_Data (F : access Fragmenter_Filter) return Components.Message'Class; function Process_Data (F : access Fragmenter_Filter) return Components.Message'Class is -- Data ready in buffer Ready : constant Stream_Element_Count := Remaining (F.Socket_Buf); begin if Ready /= 0 then -- There is some data ready if Ready <= F.Data_Expected then -- Copy data to destination Copy (F.Socket_Buf, F.In_Buf, Ready); if Ready = F.Data_Expected then -- Just enough data Release_Contents (F.Socket_Buf.all); F.Data_Expected := 0; F.In_Buf := null; pragma Debug (C, O ("Sending" & F.Initial_Data_Expected'Img & ", buffer empty")); -- Send data to upper filter return Emit (F.Upper, Data_Indication' (Data_Amount => F.Initial_Data_Expected)); else -- Not enough data -- This case must not happend raise Constraint_Error; end if; else -- Too much data, fragmenting -- Copy data asked by upper layer Copy (F.Socket_Buf, F.In_Buf, F.Data_Expected); F.Data_Expected := 0; F.In_Buf := null; pragma Debug (C, O ("Sending" & F.Initial_Data_Expected'Img & "," & Remaining (F.Socket_Buf)'Img & " bytes remaining in buffer")); -- Send data to upper layer return Emit (F.Upper, Data_Indication' (Data_Amount => F.Initial_Data_Expected)); end if; else -- No data are present, ask for them to lower layer pragma Debug (C, O ("Asking for " & F.Data_Expected'Img & " bytes")); return Emit (F.Lower, Data_Expected' (Max => F.Data_Expected, In_Buf => F.Socket_Buf)); end if; end Process_Data; -------------------- -- Handle_Message -- -------------------- function Handle_Message (F : not null access Fragmenter_Filter; S : Components.Message'Class) return Components.Message'Class is begin if S in Data_Expected'Class then declare DEM : Data_Expected renames Data_Expected (S); begin -- Upper layer ask for data pragma Debug (C, O ("Upper filter expects" & DEM.Max'Img & " bytes")); if DEM.Max = 0 then -- No data asked, return to upper layer return Emit (F.Upper, Data_Indication' (Data_Amount => DEM.Max)); end if; pragma Assert (True and then F.Data_Expected = 0 and then F.In_Buf = null and then DEM.In_Buf /= null); F.Data_Expected := DEM.Max; F.Initial_Data_Expected := DEM.Max; F.In_Buf := DEM.In_Buf; -- Try to satisfy demand return Process_Data (F); end; elsif S in Data_Indication then declare Data_Received : constant Stream_Element_Count := Data_Indication (S).Data_Amount; begin -- Some data received pragma Debug (C, O ("Received" & Data_Received'Img & " bytes")); -- Try to satisfy demand return Process_Data (F); end; else return Filters.Handle_Message (Filters.Filter (F.all)'Access, S); end if; end Handle_Message; end PolyORB.Filters.Fragmenter; polyorb-2.8~20110207.orig/src/polyorb-tasking-condition_variables.adb0000644000175000017500000000676111750740340025013 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . T A S K I N G . C O N D I T I O N _ V A R I A B L E S -- -- -- -- B o d y -- -- -- -- Copyright (C) 2002-2008, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- A complete implementation of this package is provided for all -- tasking profiles. with PolyORB.Log; package body PolyORB.Tasking.Condition_Variables is use PolyORB.Log; package L is new PolyORB.Log.Facility_Log ("polyorb.tasking.condition_variables"); procedure O (Message : String; Level : Log_Level := Debug) renames L.Output; function C (Level : Log_Level := Debug) return Boolean renames L.Enabled; My_Factory : Condition_Factory_Access; -- Real factory, corresponding to the chosen tasking profile. ------------ -- Create -- ------------ procedure Create (Cond : out Condition_Access; Name : String := "") is begin pragma Debug (C, O ("Create: enter")); pragma Assert (My_Factory /= null); Cond := Create (My_Factory, Name); pragma Debug (C, O ("Create: leave")); end Create; ------------- -- Destroy -- ------------- procedure Destroy (Cond : in out Condition_Access) is begin pragma Debug (C, O ("Destroy: enter")); pragma Assert (My_Factory /= null); Destroy (My_Factory, Cond); pragma Debug (C, O ("Destroy: leave")); end Destroy; -------------------------------- -- Register_Condition_Factory -- -------------------------------- procedure Register_Condition_Factory (MF : Condition_Factory_Access) is begin pragma Assert (My_Factory = null); My_Factory := MF; end Register_Condition_Factory; end PolyORB.Tasking.Condition_Variables; polyorb-2.8~20110207.orig/src/polyorb-setup-access_points.ads0000644000175000017500000000424611750740340023347 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . S E T U P . A C C E S S _ P O I N T S -- -- -- -- S p e c -- -- -- -- Copyright (C) 2003 Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by ACT Europe. -- -- (email: sales@act-europe.fr) -- -- -- ------------------------------------------------------------------------------ -- Root name space for protocol personality packages that create access -- points. package PolyORB.Setup.Access_Points is end PolyORB.Setup.Access_Points; polyorb-2.8~20110207.orig/src/polyorb-transport-connected.adb0000644000175000017500000001513311750740340023324 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . T R A N S P O R T . C O N N E C T E D -- -- -- -- B o d y -- -- -- -- Copyright (C) 2003-2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- Abstract connected transport service access points and transport -- endpoints. with PolyORB.Binding_Objects; with PolyORB.Components; with PolyORB.Log; with PolyORB.Filters; with PolyORB.Filters.Iface; with PolyORB.ORB.Iface; package body PolyORB.Transport.Connected is use PolyORB.Log; package L is new PolyORB.Log.Facility_Log ("polyorb.transport.connected"); procedure O (Message : String; Level : Log_Level := Debug) renames L.Output; function C (Level : Log_Level := Debug) return Boolean renames L.Enabled; ------------------ -- Handle_Event -- ------------------ procedure Handle_Event (H : access Connected_TAP_AES_Event_Handler) is use PolyORB.Components; use PolyORB.ORB; use PolyORB.ORB.Iface; use PolyORB.Filters; New_TE : Transport_Endpoint_Access; begin pragma Debug (C, O ("Handle_Event: Connected TAP AES")); -- Create transport endpoint Accept_Connection (Connected_Transport_Access_Point'Class (H.TAP.all), New_TE); if New_TE /= null then -- Build a binding object based on the newly-created endpoint Binding_Objects.Setup_Binding_Object (ORB => Components.Component_Access (H.ORB), TE => New_TE, FFC => H.Filter_Factory_Chain.all, BO_Ref => New_TE.Dependent_Binding_Object, Pro => null); -- XXX Until bidirectional BOs are implemented, -- We mark Server BOs as having a null Profile -- cf. PolyORB.ORB.Find_Reusable_Binding_Object. ORB.Register_Binding_Object (H.ORB, New_TE.Dependent_Binding_Object, ORB.Server); end if; -- Continue monitoring the TAP's AES Emit_No_Reply (Component_Access (H.ORB), Monitor_Access_Point'(TAP => H.TAP)); end Handle_Event; -------------------- -- Handle_Message -- -------------------- function Handle_Message (TE : not null access Connected_Transport_Endpoint; Msg : Components.Message'Class) return Components.Message'Class is use PolyORB.Buffers; use PolyORB.Components; use PolyORB.Errors; use PolyORB.Filters; use PolyORB.Filters.Iface; Nothing : Components.Null_Message; begin if Msg in Data_Expected then declare DE : Data_Expected renames Data_Expected (Msg); begin pragma Assert (DE.In_Buf /= null); TE.In_Buf := DE.In_Buf; TE.Max := DE.Max; end; return Emit (TE.Server, ORB.Iface.Monitor_Endpoint' (TE => Transport_Endpoint_Access (TE))); elsif Msg in Data_Indication then pragma Debug (C, O ("Data received")); declare use type Ada.Streams.Stream_Element_Count; Size : Ada.Streams.Stream_Element_Count := TE.Max; Error : Error_Container; begin if TE.In_Buf /= null then Read (Transport_Endpoint'Class (TE.all), TE.In_Buf, Size, Error); end if; if TE.In_Buf = null or else (Size = 0 and then not Is_Error (Error)) then Throw (Error, Comm_Failure_E, System_Exception_Members' (Minor => 0, Completed => Completed_Maybe)); end if; if not Is_Error (Error) then return Emit (TE.Upper, Data_Indication'(Data_Amount => Size)); else return Filter_Error'(Error => Error); end if; end; elsif Msg in Data_Out then declare Error : Error_Container; begin Write (Transport_Endpoint'Class (TE.all), Data_Out (Msg).Out_Buf, Error); if Is_Error (Error) then return Filter_Error'(Error => Error); end if; end; elsif Msg in Set_Server then TE.Server := Set_Server (Msg).Server; TE.Binding_Object := Smart_Pointers.Entity_Ptr (Set_Server (Msg).Binding_Object); return Emit (TE.Upper, Msg); elsif Msg in Disconnect_Indication then Close (Transport_Endpoint'Class (TE.all)'Access); return Emit (TE.Upper, Msg); elsif Msg in Disconnect_Request then Close (Transport_Endpoint'Class (TE.all)'Access); else return Transport.Handle_Message (Transport_Endpoint (TE.all)'Access, Msg); end if; return Nothing; end Handle_Message; end PolyORB.Transport.Connected; polyorb-2.8~20110207.orig/src/polyorb-references-corbaloc.adb0000644000175000017500000002533211750740340023235 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . R E F E R E N C E S . C O R B A L O C -- -- -- -- B o d y -- -- -- -- Copyright (C) 2003-2008, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with PolyORB.Initialization; with PolyORB.Log; with PolyORB.Utils.Chained_Lists; with PolyORB.Types; package body PolyORB.References.Corbaloc is use PolyORB.Binding_Data; use PolyORB.Log; use PolyORB.Utils.Strings; package L is new PolyORB.Log.Facility_Log ("polyorb.references.corbaloc"); procedure O (Message : String; Level : Log_Level := Debug) renames L.Output; function C (Level : Log_Level := Debug) return Boolean renames L.Enabled; Corbaloc_Prefix : constant String := "corbaloc:"; -- A descriptor is kept for each profile kind that is supported within -- the corbaloc: scheme. type Profile_Record is record Tag : PolyORB.Binding_Data.Profile_Tag; -- Profile tag Proto_Ident : String_Ptr; -- Protocol token Profile_To_String_Body : Profile_To_String_Body_Type; String_To_Profile_Body : String_To_Profile_Body_Type; -- _addr <-> profile conversion functions end record; package Profile_Record_List is new PolyORB.Utils.Chained_Lists (Profile_Record); use Profile_Record_List; Callbacks : Profile_Record_List.List; Null_String : constant Types.String := PolyORB.Types.To_PolyORB_String (""); type Tag_Array is array (Natural range <>) of Profile_Tag; type String_Array is array (Integer range <>) of Types.String; ----------------------- -- Local subprograms -- ----------------------- procedure Get_Corbaloc_List (Corbaloc : Corbaloc_Type; Corbaloc_List : out String_Array; Tag_List : out Tag_Array; N : out Natural); -- Return the list of all corbaloc obj_addrs found in Corbaloc function String_To_Profile (Obj_Addr : String) return Binding_Data.Profile_Access; -- Return null if failed function Profile_To_String (P : Binding_Data.Profile_Access) return Types.String; function String_To_Object (Str : String) return Corbaloc_Type; ----------------------- -- Get_Corbaloc_List -- ----------------------- procedure Get_Corbaloc_List (Corbaloc : Corbaloc_Type; Corbaloc_List : out String_Array; Tag_List : out Tag_Array; N : out Natural) is use PolyORB.Types; Profs : constant Profile_Array := Profiles_Of (Corbaloc); Str : Types.String; begin N := 0; for J in Profs'Range loop Str := Profile_To_String (Profs (J)); if Length (Str) /= 0 then N := N + 1; Corbaloc_List (N) := Str; Tag_List (N) := Get_Profile_Tag (Profs (J).all); end if; end loop; pragma Debug (C, O ("Profile found :" & Natural'Image (N))); end Get_Corbaloc_List; ----------------------- -- Profile_To_String -- ----------------------- function Profile_To_String (P : Binding_Data.Profile_Access) return Types.String is use PolyORB.Types; T : Profile_Tag; Iter : Iterator := First (Callbacks); begin pragma Assert (P /= null); pragma Debug (C, O ("Profile to string with tag:" & Profile_Tag'Image (Get_Profile_Tag (P.all)))); T := Get_Profile_Tag (P.all); while not Last (Iter) loop declare Info : constant Profile_Record := Value (Iter).all; begin if T = Info.Tag then return To_PolyORB_String (Info.Profile_To_String_Body (P)); end if; end; Next (Iter); end loop; pragma Debug (C, O ("Profile not ok")); return Null_String; end Profile_To_String; ----------------------- -- String_To_Profile -- ----------------------- function String_To_Profile (Obj_Addr : String) return Binding_Data.Profile_Access is use PolyORB.Utils; Prot_Id : String_Ptr; Sep : Integer := Find (Obj_Addr, Obj_Addr'First, ':'); Iter : Iterator := First (Callbacks); begin pragma Debug (C, O ("String_To_Profile: enter, parsing " & Obj_Addr)); if Obj_Addr (Obj_Addr'First .. Obj_Addr'First + 1) = "//" or else (Sep = Obj_Addr'First and then Sep <= Obj_Addr'Last) then Prot_Id := new String'("iiop"); if Obj_Addr (Obj_Addr'First) = '/' then Sep := Obj_Addr'First + 1; end if; elsif Sep in Obj_Addr'First + 1 .. Obj_Addr'Last then Prot_Id := new String'((Obj_Addr (Obj_Addr'First .. Sep - 1))); else return null; end if; while Iter /= Last (Callbacks) loop if Prot_Id.all = Value (Iter).Proto_Ident.all then pragma Debug (C, O ("Try to unmarshall profile with profile factory tag " & Profile_Tag'Image (Value (Iter).Tag))); Free (Prot_Id); return Value (Iter).String_To_Profile_Body (Obj_Addr (Sep + 1 .. Obj_Addr'Last)); end if; Next (Iter); end loop; Free (Prot_Id); pragma Debug (C, O ("Profile not found for " & Obj_Addr)); return null; end String_To_Profile; ---------------------------------------- -- Object_To_String_With_Best_Profile -- ---------------------------------------- function Object_To_String_With_Best_Profile (Corbaloc : Corbaloc_Type) return String is begin pragma Debug (C, O ("Create corbaloc with best profile: Enter")); if Is_Nil (Corbaloc) then pragma Debug (C, O ("Corbaloc Empty")); return Corbaloc_Prefix; else declare use PolyORB.Types; N : Natural; TL : Tag_Array (1 .. Length (Callbacks)); SL : String_Array (1 .. Length (Callbacks)); Profs : constant Profile_Array := Profiles_Of (Corbaloc); Best_Preference : Profile_Preference := Profile_Preference'First; Best_Profile_Index : Integer := 0; begin Get_Corbaloc_List (Corbaloc, SL, TL, N); for J in Profs'Range loop declare P : constant Profile_Preference := Get_Profile_Preference (Profs (J).all); begin if P > Best_Preference then for K in 1 .. N loop if TL (K) = Get_Profile_Tag (Profs (J).all) then Best_Preference := P; Best_Profile_Index := K; end if; end loop; end if; end; end loop; if Best_Profile_Index > 0 then return Corbaloc_Prefix & To_Standard_String (SL (Best_Profile_Index)); end if; pragma Debug (C, O ("Create corbaloc with best profile: Leave")); return Corbaloc_Prefix; end; end if; end Object_To_String_With_Best_Profile; ---------------------- -- String_To_Object -- ---------------------- function String_To_Object (Str : String) return Corbaloc_Type is use PolyORB.Types; Result : Corbaloc_Type; Pro : Profile_Access; begin pragma Debug (C, O ("Try to decode Corbaloc: enter ")); if Utils.Has_Prefix (Str, Corbaloc_Prefix) then Pro := String_To_Profile (Str (Corbaloc_Prefix'Length + Str'First .. Str'Last)); if Pro /= null then Create_Reference ((1 => Pro), "", References.Ref (Result)); end if; end if; pragma Debug (C, O ("Try to decode Corbaloc: leave ")); return Result; end String_To_Object; -------------- -- Register -- -------------- procedure Register (Tag : PolyORB.Binding_Data.Profile_Tag; Proto_Ident : String; Profile_To_String_Body : Profile_To_String_Body_Type; String_To_Profile_Body : String_To_Profile_Body_Type) is begin Append (Callbacks, Profile_Record'(Tag, new String'(Proto_Ident), Profile_To_String_Body, String_To_Profile_Body)); end Register; ---------------- -- Initialize -- ---------------- procedure Initialize; procedure Initialize is begin Register_String_To_Object (Corbaloc_Prefix, String_To_Object'Access); end Initialize; use PolyORB.Initialization; use PolyORB.Initialization.String_Lists; begin Register_Module (Module_Info' (Name => +"references.corbaloc", Conflicts => PolyORB.Initialization.String_Lists.Empty, Depends => PolyORB.Initialization.String_Lists.Empty, Provides => +"references", Implicit => False, Init => Initialize'Access, Shutdown => null)); end PolyORB.References.Corbaloc; polyorb-2.8~20110207.orig/src/polyorb-objects.ads0000644000175000017500000000576111750740340021010 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . O B J E C T S -- -- -- -- S p e c -- -- -- -- Copyright (C) 2001-2009, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- Object identifier type. An Object_Id is an opaque data container -- identifying one concrete object whithin a specific namespace. with Ada.Streams; with Ada.Unchecked_Deallocation; package PolyORB.Objects is pragma Preelaborate; type Object_Id is new Ada.Streams.Stream_Element_Array; type Object_Id_Access is access all Object_Id; procedure Free is new Ada.Unchecked_Deallocation (Object_Id, Object_Id_Access); function Oid_To_Hex_String (Oid : Object_Id) return String; pragma Inline (Oid_To_Hex_String); -- Convert an OID to a printable hex string representation function Hex_String_To_Oid (S : String) return Object_Id; pragma Inline (Hex_String_To_Oid); -- Convert an OID from a printable hex string representation function String_To_Oid (S : String) return Object_Id; pragma Inline (String_To_Oid); -- Convert an OID from a string function Image (Oid : Object_Id) return String; -- For debugging purposes end PolyORB.Objects; polyorb-2.8~20110207.orig/src/polyorb-representations-cdr-common.adb0000644000175000017500000006655011750740340024622 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . R E P R E S E N T A T I O N S . C D R . C O M M O N -- -- -- -- B o d y -- -- -- -- Copyright (C) 2002-2009, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with GNAT.Byte_Swapping; with PolyORB.Fixed_Point; with PolyORB.Log; with PolyORB.References.IOR; with PolyORB.Utils.Buffers; pragma Elaborate_All (PolyORB.Utils.Buffers); package body PolyORB.Representations.CDR.Common is use PolyORB.Any; use PolyORB.Log; use PolyORB.Types; use PolyORB.Utils.Buffers; package L is new PolyORB.Log.Facility_Log ("polyorb.representations.cdr.common"); procedure O (Message : String; Level : Log_Level := Debug) renames L.Output; function C (Level : Log_Level := Debug) return Boolean renames L.Enabled; ----------------- -- Encapsulate -- ----------------- function Encapsulate (Buffer : access Buffer_Type) return Encapsulation is begin return Encapsulation'(To_Stream_Element_Array (Buffer.all)); end Encapsulate; ------------------------- -- Start_Encapsulation -- ------------------------- procedure Start_Encapsulation (Buffer : access Buffer_Type) is begin Set_Initial_Position (Buffer, 0); Marshall (Buffer, PolyORB.Types.Boolean (Endianness (Buffer) = Little_Endian)); -- An encapsulation starts with a Boolean value -- which is True if the remainder of the buffer is -- Little_Endian, and False otherwise. end Start_Encapsulation; -- Internal utility functions ----------------- -- Decapsulate -- ----------------- procedure Decapsulate (Octets : access Encapsulation; Buffer : access Buffer_Type) is Endianness : Endianness_Type; begin if PolyORB.Types.Boolean'Val (PolyORB.Types.Octet (Octets (Octets'First))) then Endianness := Little_Endian; else Endianness := Big_Endian; end if; Initialize_Buffer (Buffer => Buffer, Size => Octets'Length - 1, Data => Octets (Octets'First + 1)'Address, Endianness => Endianness, Initial_CDR_Position => 1); end Decapsulate; -- procedure Marshall_From_Any -- (Buffer : access Buffer_Type; -- Data : PolyORB.Any.Any; -- Marshalled_List : in out False_List; -- Depth : PolyORB.Types.Long) -- is -- Success : Boolean; -- begin -- Success := Marshall_Indirection (Buffer, Data, Already_Marshalled); -- if not Success then -- declare -- Aggregate_Nb, Member_Nb : PolyORB.Types.Unsigned_Long; -- Value : PolyORB.Any.Any; -- begin -- pragma Debug -- (C, O ("Marshall_From_Any : dealing with a value")); -- Marshall (Buffer, Default_Value_Tag); -- Aggregate_Nb := PolyORB.Any.Get_Aggregate_Count(Data); -- Member_Nb := (Aggregate_Nb - 3) / 3; -- I := 5; -- J := 0; -- while (J < Member_Nb) loop -- Member_Value := PolyORB.Any.Get_Aggregate_Element -- (Data, -- PolyORB.Any.TypeCode.Member_Type (Data_Type, I + 3 * J), -- J); -- declare -- Member_Type : constant PolyORB.Any.TypeCode.Local_Ref -- := PolyORB.Any.Get_Unwound_Type (Member_Value); -- begin -- case PolyORB.Any.TypeCode.Kind (Member_Type) is -- when Tk_Value => -- Marshall_From_Any -- (Buffer, To_Real (Value), -- Marshalled_List, Depth + 1); -- when others => -- Marshall_From_Any (Buffer, Member_Value); -- end case; -- end; -- end loop; -- end; -- end if; -- end Marshall_From_Any; -------------- -- Marshall -- -------------- -- Marshall-by-copy subprograms for all elementary types. -- Marshalling of a Boolean procedure Marshall (Buffer : access Buffer_Type; Data : PolyORB.Types.Boolean) is begin pragma Debug (C, O ("Marshall (Boolean) : enter")); Marshall (Buffer, PolyORB.Types.Octet'(PolyORB.Types.Boolean'Pos (Data))); pragma Debug (C, O ("Marshall (Boolean) : end")); end Marshall; -- Marshalling of a Character procedure Marshall_Latin_1_Char (Buffer : access Buffer_Type; Data : PolyORB.Types.Char) is begin pragma Debug (C, O ("Marshall (Char) : enter")); Marshall (Buffer, PolyORB.Types.Octet'(PolyORB.Types.Char'Pos (Data))); pragma Debug (C, O ("Marshall (Char) : end")); end Marshall_Latin_1_Char; -- Marshalling of an Octet procedure Marshall (Buffer : access Buffer_Type; Data : PolyORB.Types.Octet) is begin pragma Debug (C, O ("Marshall (Octet) : enter")); Align_Marshall_Copy (Buffer, (1 => Stream_Element (PolyORB.Types.Octet'(Data))), Align_1); pragma Debug (C, O ("Marshall (Octet) : end")); end Marshall; -- Transfer of elementary integer types function Swapped (X : Types.Octet) return Types.Octet; pragma Inline (Swapped); -- Identity function! package CDR_Octet is new Align_Transfer_Elementary (T => PolyORB.Types.Octet); function Swapped is new GNAT.Byte_Swapping.Swapped2 (PolyORB.Types.Unsigned_Short); package CDR_Unsigned_Short is new Align_Transfer_Elementary (T => PolyORB.Types.Unsigned_Short); function Swapped is new GNAT.Byte_Swapping.Swapped2 (PolyORB.Types.Short); package CDR_Short is new Align_Transfer_Elementary (T => PolyORB.Types.Short); function Swapped is new GNAT.Byte_Swapping.Swapped4 (PolyORB.Types.Unsigned_Long); package CDR_Unsigned_Long is new Align_Transfer_Elementary (T => PolyORB.Types.Unsigned_Long); function Swapped is new GNAT.Byte_Swapping.Swapped4 (PolyORB.Types.Long); package CDR_Long is new Align_Transfer_Elementary (T => PolyORB.Types.Long); function Swapped is new GNAT.Byte_Swapping.Swapped4 (PolyORB.Types.Float); package CDR_Float is new Align_Transfer_Elementary (T => PolyORB.Types.Float); function Swapped is new GNAT.Byte_Swapping.Swapped8 (PolyORB.Types.Unsigned_Long_Long); package CDR_Unsigned_Long_Long is new Align_Transfer_Elementary (T => PolyORB.Types.Unsigned_Long_Long); function Swapped is new GNAT.Byte_Swapping.Swapped8 (PolyORB.Types.Long_Long); package CDR_Long_Long is new Align_Transfer_Elementary (T => PolyORB.Types.Long_Long); function Swapped is new GNAT.Byte_Swapping.Swapped8 (PolyORB.Types.Double); package CDR_Double is new Align_Transfer_Elementary (T => PolyORB.Types.Double); procedure Marshall (Buffer : access Buffer_Type; Data : PolyORB.Types.Unsigned_Short) renames CDR_Unsigned_Short.Marshall; procedure Marshall (Buffer : access Buffer_Type; Data : PolyORB.Types.Short) renames CDR_Short.Marshall; procedure Marshall (Buffer : access Buffer_Type; Data : PolyORB.Types.Unsigned_Long) renames CDR_Unsigned_Long.Marshall; procedure Marshall (Buffer : access Buffer_Type; Data : PolyORB.Types.Long) renames CDR_Long.Marshall; procedure Marshall (Buffer : access Buffer_Type; Data : PolyORB.Types.Float) renames CDR_Float.Marshall; procedure Marshall (Buffer : access Buffer_Type; Data : PolyORB.Types.Unsigned_Long_Long) renames CDR_Unsigned_Long_Long.Marshall; procedure Marshall (Buffer : access Buffer_Type; Data : PolyORB.Types.Long_Long) renames CDR_Long_Long.Marshall; procedure Marshall (Buffer : access Buffer_Type; Data : PolyORB.Types.Double) renames CDR_Double.Marshall; -- Marshalling of a Long Double procedure Marshall (Buffer : access Buffer_Type; Data : PolyORB.Types.Long_Double) is -- FIXME LONG DOUBLE -- Buf : Long_Double_Buf := To_Long_Double_Buf (Data); begin raise Program_Error; -- pragma Debug (C, O ("Marshall (LongDouble) : enter")); -- Align_Marshall_Host_Endian_Copy (Buffer, Buf, 8); -- pragma Debug (C, O ("Marshall (LongDouble) : end")); end Marshall; -- Marshalling of a Standard String procedure Marshall_Latin_1_String (Buffer : access Buffer_Type; Data : Standard.String) is Str : Stream_Element_Array (1 .. Data'Length); -- WAG:62 -- Str should be a deferred constant, whose completion is the -- pragma Import below. Declaring Str as a variable object loses -- valuable information (we are overlaying it over a constant, which -- might warrant a compiler warning...). However GNAT incorrectly -- rejects a deferred constant declaration here. for Str'Address use Data'Address; pragma Import (Ada, Str); begin pragma Debug (C, O ("Marshall (String) : enter")); Marshall (Buffer, PolyORB.Types.Unsigned_Long'(Data'Length + 1)); Align_Marshall_Copy (Buffer, Str); Marshall_Latin_1_Char (Buffer, PolyORB.Types.Char (ASCII.NUL)); pragma Debug (C, O ("Marshall (String) : end")); end Marshall_Latin_1_String; -- Marshalling of a PolyORB.Types.String procedure Marshall_Latin_1_String (Buffer : access Buffer_Type; Data : PolyORB.Types.String) is begin pragma Debug (C, O ("Marshall (PolyORB.Types.String) : enter")); Marshall_Latin_1_String (Buffer, PolyORB.Types.To_Standard_String (Data)); pragma Debug (C, O ("Marshall (PolyORB.Types.String) : end")); end Marshall_Latin_1_String; -- Marshalling of an Identifier procedure Marshall (Buffer : access Buffer_Type; Data : PolyORB.Types.Identifier) is begin pragma Debug (C, O ("Marshall (Identifier) : enter")); Marshall_Latin_1_String (Buffer, PolyORB.Types.String (Data)); pragma Debug (C, O ("Marshall (Identifier) : end")); end Marshall; -- Marshalling of a Repository Identifier procedure Marshall (Buffer : access Buffer_Type; Data : PolyORB.Types.RepositoryId) is begin pragma Debug (C, O ("Marshall (RepositoryId) : enter")); Marshall_Latin_1_String (Buffer, PolyORB.Types.String (Data)); pragma Debug (C, O ("Marshall (RepositoryId) : end")); end Marshall; -- Marshalling of a Value Modifier type (short) procedure Marshall (Buffer : access Buffer_Type; Data : PolyORB.Any.ValueModifier) is begin pragma Debug (C, O ("Marshall (ValueModifier) : enter")); Marshall (Buffer, PolyORB.Types.Short (Data)); pragma Debug (C, O ("Marshall (ValueModifier) : end")); end Marshall; -- Marshalling of a Visibility Type (short) procedure Marshall (Buffer : access Buffer_Type; Data : PolyORB.Any.Visibility) is begin pragma Debug (C, O ("Marshall (Visibility) : enter")); Marshall (Buffer, PolyORB.Types.Short (Data)); pragma Debug (C, O ("Marshall (Visibility) : end")); end Marshall; -- Marshall a sequence of octets procedure Marshall (Buffer : access Buffer_Type; Data : Stream_Element_Array) is begin pragma Debug (C, O ("Marshall (Encapsulation) : enter")); Marshall (Buffer, PolyORB.Types.Unsigned_Long (Data'Length)); Align_Marshall_Copy (Buffer, Data); pragma Debug (C, O ("Marshall (Encapsulation) : end")); end Marshall; -- procedure Marshall -- (Buffer : access Buffer_Type; -- Data : Encapsulation) is -- begin -- pragma Debug (C, O ("Marshall (Encapsulation) : enter")); -- Marshall (Buffer, PolyORB.Types.Unsigned_Long (Data'Length)); -- for I in Data'Range loop -- Marshall (Buffer, PolyORB.Types.Octet (Data (I))); -- end loop; -- pragma Debug (C, O ("Marshall (Encapsulation) : end")); -- end Marshall; procedure Marshall (Buffer : access Buffer_Type; Data : PolyORB.References.Ref'Class) is begin -- !!!!!!!!!!!!!!!!! -- FIXME: I've just noticed that abstract interfaces must be -- encoded as unions -- with a boolean discriminator, cf spec and change code below. -- !!!!!!!!!!!!!!!!! -- ValueTypes are not implemented in PolyORB. -- -- 1. if Data is a valuetype, call the valuetype marshalling function -- if Data in CORBA.Value.Base'Class then -- -- PolyORB.CORBA_P.Value.Stream.Marshall -- -- (Buffer, PolyORB.Types.Value.Base'Class (Data)); -- raise PolyORB.Not_Implemented; -- -- 2. check if Data is a nil ref, raise marshall if true -- elsif CORBA.AbstractBase.Is_Nil (Data) then -- raise Constraint_Error; -- -- 3. If Data is an abstract interface and the referenced object is -- -- a valuetype, then call the valuetype marshalling function. -- -- In practice, just check if the referenced object is a valuetype. -- elsif CORBA.AbstractBase.Object_Of (Data).all -- in CORBA.Value.Impl_Base'Class then -- -- PolyORB.CORBA_P.Value.Stream.Marshall (Buffer, -- -- Data); -- raise PolyORB.Not_Implemented; -- -- Not implemented yet -- -- 4. Call the interface marshalling function -- else References.IOR.Marshall_IOR (Buffer, References.Ref (Data)); -- end if; end Marshall; --------------------------------------------------- -- Marshall-by-reference subprograms -- -- (for elementary types, these are placeholders -- -- that actually perform marshalling by copy. -- --------------------------------------------------- procedure Marshall (Buffer : access Buffer_Type; Data : access PolyORB.Types.Octet) is begin Marshall (Buffer, Data.all); end Marshall; procedure Marshall (Buffer : access Buffer_Type; Data : access PolyORB.Types.Boolean) is begin Marshall (Buffer, Data.all); end Marshall; procedure Marshall (Buffer : access Buffer_Type; Data : access PolyORB.Types.Short) is begin Marshall (Buffer, Data.all); end Marshall; procedure Marshall (Buffer : access Buffer_Type; Data : access PolyORB.Types.Unsigned_Short) is begin Marshall (Buffer, Data.all); end Marshall; procedure Marshall (Buffer : access Buffer_Type; Data : access PolyORB.Types.Long) is begin Marshall (Buffer, Data.all); end Marshall; procedure Marshall (Buffer : access Buffer_Type; Data : access PolyORB.Types.Long_Long) is begin Marshall (Buffer, Data.all); end Marshall; procedure Marshall (Buffer : access Buffer_Type; Data : access PolyORB.Types.Unsigned_Long) is begin Marshall (Buffer, Data.all); end Marshall; procedure Marshall (Buffer : access Buffer_Type; Data : access PolyORB.Types.Unsigned_Long_Long) is begin Marshall (Buffer, Data.all); end Marshall; procedure Marshall (Buffer : access Buffer_Type; Data : access PolyORB.Types.Float) is begin Marshall (Buffer, Data.all); end Marshall; procedure Marshall (Buffer : access Buffer_Type; Data : access PolyORB.Types.Double) is begin Marshall (Buffer, Data.all); end Marshall; procedure Marshall (Buffer : access Buffer_Type; Data : access PolyORB.Types.Long_Double) is begin Marshall (Buffer, Data.all); end Marshall; procedure Marshall (Buffer : access Buffer_Type; Data : access PolyORB.Types.Identifier) is begin Marshall (Buffer, Data.all); end Marshall; procedure Marshall (Buffer : access Buffer_Type; Data : access PolyORB.Types.RepositoryId) is begin Marshall (Buffer, Data.all); end Marshall; procedure Marshall (Buffer : access Buffer_Type; Data : access PolyORB.Any.ValueModifier) is begin Marshall (Buffer, Data.all); end Marshall; procedure Marshall (Buffer : access Buffer_Type; Data : access PolyORB.Any.Visibility) is begin Marshall (Buffer, Data.all); end Marshall; procedure Marshall (Buffer : access Buffer_Type; Data : access Stream_Element_Array) is begin Marshall (Buffer, Data.all); end Marshall; ------------------------------------ -- Unmarshall-by-copy subprograms -- ------------------------------------ function Unmarshall (Buffer : access Buffer_Type) return PolyORB.Types.Boolean is begin pragma Debug (C, O ("Unmarshall (Boolean) : enter & end")); return PolyORB.Types.Boolean'Val (PolyORB.Types.Octet'(Unmarshall (Buffer))); end Unmarshall; function Unmarshall_Latin_1_Char (Buffer : access Buffer_Type) return PolyORB.Types.Char is begin pragma Debug (C, O ("Unmarshall (Char) : enter & end")); return PolyORB.Types.Char'Val (PolyORB.Types.Octet'(Unmarshall (Buffer))); end Unmarshall_Latin_1_Char; function Unmarshall (Buffer : access Buffer_Type) return PolyORB.Types.Octet renames CDR_Octet.Unmarshall; function Unmarshall (Buffer : access Buffer_Type) return PolyORB.Types.Unsigned_Short renames CDR_Unsigned_Short.Unmarshall; function Unmarshall (Buffer : access Buffer_Type) return PolyORB.Types.Unsigned_Long renames CDR_Unsigned_Long.Unmarshall; function Unmarshall (Buffer : access Buffer_Type) return PolyORB.Types.Unsigned_Long_Long renames CDR_Unsigned_Long_Long.Unmarshall; function Unmarshall (Buffer : access Buffer_Type) return PolyORB.Types.Short renames CDR_Short.Unmarshall; function Unmarshall (Buffer : access Buffer_Type) return PolyORB.Types.Long renames CDR_Long.Unmarshall; function Unmarshall (Buffer : access Buffer_Type) return PolyORB.Types.Float renames CDR_Float.Unmarshall; function Unmarshall (Buffer : access Buffer_Type) return PolyORB.Types.Long_Long renames CDR_Long_Long.Unmarshall; function Unmarshall (Buffer : access Buffer_Type) return PolyORB.Types.Double renames CDR_Double.Unmarshall; function Unmarshall (Buffer : access Buffer_Type) return PolyORB.Types.Long_Double is -- Octets : constant Stream_Element_Array := -- Align_Unmarshall_Host_Endian_Copy (Buffer, 12, 8); begin -- pragma Debug (C, O ("Unmarshall (LongDouble) : enter & end")); -- return To_Long_Double (Long_Double_Buf (Octets)); raise Program_Error; pragma Warnings (Off); return Unmarshall (Buffer); -- "Possible infinite recursion". pragma Warnings (On); end Unmarshall; function Unmarshall_Latin_1_String (Buffer : access Buffer_Type) return Standard.String is Length : constant PolyORB.Types.Unsigned_Long := Unmarshall (Buffer); Equiv : String (1 .. Natural (Length) - 1); begin pragma Debug (C, O ("Unmarshall (String): enter")); pragma Debug (C, O ("Unmarshall (String): length is " & PolyORB.Types.Unsigned_Long'Image (Length))); if Length = 0 then return ""; end if; for J in Equiv'Range loop Equiv (J) := Character'Val (PolyORB.Types.Char'Pos (Unmarshall_Latin_1_Char (Buffer))); end loop; if Character'Val (PolyORB.Types.Char'Pos (Unmarshall_Latin_1_Char (Buffer))) /= ASCII.NUL then raise Constraint_Error; end if; pragma Debug (C, O ("Unmarshall (String): -> " & Equiv)); return Equiv; end Unmarshall_Latin_1_String; function Unmarshall_Latin_1_String (Buffer : access Buffer_Type) return PolyORB.Types.String is begin return PolyORB.Types.To_PolyORB_String (Unmarshall_Latin_1_String (Buffer)); end Unmarshall_Latin_1_String; function Unmarshall (Buffer : access Buffer_Type) return PolyORB.Types.Identifier is begin pragma Debug (C, O ("Unmarshall (Identifier) : enter & end")); return PolyORB.Types.Identifier (PolyORB.Types.String'(Unmarshall_Latin_1_String (Buffer))); end Unmarshall; function Unmarshall (Buffer : access Buffer_Type) return PolyORB.Types.RepositoryId is begin pragma Debug (C, O ("Unmarshall (RepositoryId) : enter & end")); return PolyORB.Types.RepositoryId (PolyORB.Types.String'(Unmarshall_Latin_1_String (Buffer))); end Unmarshall; function Unmarshall (Buffer : access Buffer_Type) return PolyORB.Any.ValueModifier is begin pragma Debug (C, O ("Unmarshall (ValueModifier) : enter & end")); return PolyORB.Any.ValueModifier (PolyORB.Types.Short'(Unmarshall (Buffer))); end Unmarshall; function Unmarshall (Buffer : access Buffer_Type) return PolyORB.Any.Visibility is begin pragma Debug (C, O ("Unmarshall (Visibility) : enter & end")); return PolyORB.Any.Visibility (PolyORB.Types.Short'(Unmarshall (Buffer))); end Unmarshall; -- function Unmarshall (Buffer : access Buffer_Type) -- return Encapsulation -- is -- Length : constant PolyORB.Types.Unsigned_Long -- := Unmarshall (Buffer); -- begin -- pragma Debug (C, O ("Unmarshall (Encapsulation): -- length is" & Length'Img)); -- declare -- E : Encapsulation (1 .. Stream_Element_Offset(Length)); -- begin -- for I in E'Range loop -- E (I) := Stream_Element(PolyORB.Types.Octet' -- (Unmarshall (Buffer))); -- end loop; -- pragma Debug (C, O ("Unmarshall (Encapsulation): end")); -- return E; -- end; -- end Unmarshall; procedure Unmarshall (Buffer : access Buffer_Type; Data : in out PolyORB.References.Ref'Class) is use PolyORB.References; use PolyORB.References.IOR; IOR : constant Ref := Unmarshall_IOR (Buffer); begin PolyORB.References.Set (Data, Entity_Of (IOR)); end Unmarshall; function Unmarshall (Buffer : access Buffer_Type) return PolyORB.References.Ref is Result : PolyORB.References.Ref; begin Unmarshall (Buffer, Result); return Result; end Unmarshall; function Unmarshall (Buffer : access Buffer_Type) return Stream_Element_Array is Length : constant PolyORB.Types.Unsigned_Long := Unmarshall (Buffer); begin pragma Debug (C, O ("Unmarshall (Encapsulation): length" & Length'Img)); declare E : Stream_Element_Array (1 .. Stream_Element_Offset (Length)); begin for J in E'Range loop E (J) := Stream_Element (PolyORB.Types.Octet'(Unmarshall (Buffer))); end loop; pragma Debug (C, O ("Unmarshall (Encapsulation): end")); return E; end; end Unmarshall; ----------------- -- Fixed_Point -- ----------------- package body Fixed_Point is Max_Digits : constant := 31; -- 31 is the maximum number of digits for a fixed type -------------- -- Marshall -- -------------- procedure Marshall (Buffer : access Buffer_Type; Data : access F) is begin Marshall (Buffer, Data.all); end Marshall; procedure Marshall (Buffer : access Buffer_Type; Data : F) is begin Align_Marshall_Copy (Buffer, Fixed_To_Octets (Data), Align_1); end Marshall; ---------------- -- Unmarshall -- ---------------- function Unmarshall (Buffer : access Buffer_Type) return F is Octets : Stream_Element_Array (1 .. Max_Digits) := (others => 0); J : Stream_Element_Count := 0; begin loop J := J + 1; Octets (J) := Stream_Element (PolyORB.Types.Octet'(Unmarshall (Buffer))); exit when Octets (J) mod 16 > 9; end loop; return Octets_To_Fixed (Octets (1 .. J)); end Unmarshall; package FPC is new PolyORB.Fixed_Point.Fixed_Point_Conversion (F); --------------------- -- Fixed_To_Octets -- --------------------- function Fixed_To_Octets (Data : F) return Stream_Element_Array is use PolyORB.Fixed_Point; use FPC; N : constant PolyORB.Fixed_Point.Nibbles := Fixed_To_Nibbles (Data); B : Stream_Element_Array (0 .. N'Length / 2 - 1); begin for J in B'Range loop B (J) := Stream_Element (N (N'First + 2 * Integer (J))) * 16 + Stream_Element (N (N'First + 2 * Integer (J) + 1)); end loop; return B; end Fixed_To_Octets; --------------------- -- Octets_To_Fixed -- --------------------- function Octets_To_Fixed (Octets : Stream_Element_Array) return F is use PolyORB.Fixed_Point; use FPC; N : PolyORB.Fixed_Point.Nibbles (0 .. Octets'Length * 2 - 1); begin for J in Octets'Range loop N (2 * Integer (J - Octets'First)) := Nibble (Octets (J) / 16); N (2 * Integer (J - Octets'First) + 1) := Nibble (Octets (J) mod 16); end loop; return Nibbles_To_Fixed (N); end Octets_To_Fixed; end Fixed_Point; function Swapped (X : Types.Octet) return Types.Octet is begin return X; end Swapped; end PolyORB.Representations.CDR.Common; polyorb-2.8~20110207.orig/src/polyorb-tasking-semaphores.adb0000644000175000017500000001031211750740340023126 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . T A S K I N G . S E M A P H O R E S -- -- -- -- B o d y -- -- -- -- Copyright (C) 2002-2008, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- This package provides an implementation of counting semaphores. with Ada.Unchecked_Deallocation; with PolyORB.Log; package body PolyORB.Tasking.Semaphores is use PolyORB.Log; package L is new PolyORB.Log.Facility_Log ("polyorb.tasking.semaphores"); procedure O (Message : String; Level : Log_Level := Debug) renames L.Output; function C (Level : Log_Level := Debug) return Boolean renames L.Enabled; ---------- -- Free -- ---------- procedure Free is new Ada.Unchecked_Deallocation (Semaphore, Semaphore_Access); ------------ -- Create -- ------------ procedure Create (S : out Semaphore_Access) is begin pragma Debug (C, O ("Create")); S := new Semaphore; S.Value := 0; PTM.Create (S.Mutex); PTCV.Create (S.Condition); end Create; ------------- -- Destroy -- ------------- procedure Destroy (S : in out Semaphore_Access) is begin pragma Debug (C, O ("Destroy semaphore, Value was " & Integer'Image (S.Value))); PTM.Destroy (S.Mutex); PTCV.Destroy (S.Condition); Free (S); end Destroy; ------- -- V -- ------- procedure V (S : Semaphore_Access) is begin PTM.Enter (S.Mutex); pragma Debug (C, O ("V (sem), value =" & Integer'Image (S.Value))); S.Value := S.Value + 1; PTCV.Signal (S.Condition); PTM.Leave (S.Mutex); end V; ------- -- P -- -------- procedure P (S : Semaphore_Access) is begin PTM.Enter (S.Mutex); pragma Debug (C, O ("P (sem)")); while S.Value = 0 loop pragma Debug (C, O ("Value is null, wait in semaphore")); PTCV.Wait (S.Condition, S.Mutex); end loop; S.Value := S.Value - 1; PTM.Leave (S.Mutex); end P; ----------- -- State -- ----------- function State (S : Semaphore_Access) return Natural is Result : Integer; begin PTM.Enter (S.Mutex); Result := S.Value; pragma Debug (C, O ("Get Semaphore value, value =" & Integer'Image (S.Value))); PTM.Leave (S.Mutex); return Result; end State; end PolyORB.Tasking.Semaphores; polyorb-2.8~20110207.orig/src/polyorb-parameters-environment.ads0000644000175000017500000000416111750740340024055 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . P A R A M E T E R S . E N V I R O N M E N T -- -- -- -- S p e c -- -- -- -- Copyright (C) 2004 Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ package PolyORB.Parameters.Environment is pragma Elaborate_Body; end PolyORB.Parameters.Environment; polyorb-2.8~20110207.orig/src/polyorb-smart_pointers-initialization.adb0000644000175000017500000000740411750740340025430 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- POLYORB.SMART_POINTERS.INITIALIZATION -- -- -- -- B o d y -- -- -- -- Copyright (C) 2004-2009, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- Initialization code for PolyORB.Smart_Pointers with Ada.Tags; with PolyORB.Initialization; with PolyORB.Utils.Strings; package body PolyORB.Smart_Pointers.Initialization is ------------------------------------ -- Debugging hooks implementation -- ------------------------------------ function Entity_External_Tag (X : Unsafe_Entity'Class) return String; function Ref_External_Tag (X : Ref'Class) return String; -- Return the external representation of X'Tag. ------------------------- -- Entity_External_Tag -- ------------------------- function Entity_External_Tag (X : Unsafe_Entity'Class) return String is begin return Ada.Tags.External_Tag (X'Tag); end Entity_External_Tag; ---------------------- -- Ref_External_Tag -- ---------------------- function Ref_External_Tag (X : Ref'Class) return String is begin return Ada.Tags.External_Tag (X'Tag); end Ref_External_Tag; ---------------- -- Initialize -- ---------------- procedure Initialize; -- Initialize Smart_Pointers module procedure Initialize is begin Smart_Pointers.Initialize (The_Entity_External_Tag => Entity_External_Tag'Access, The_Ref_External_Tag => Ref_External_Tag'Access, The_Default_Trace => Get_Trace ("default")); end Initialize; use PolyORB.Initialization; use PolyORB.Initialization.String_Lists; use PolyORB.Utils.Strings; begin Register_Module (Module_Info' (Name => +"smart_pointers", Conflicts => Empty, Depends => +"tasking.mutexes" & "parameters", Provides => Empty, Implicit => False, Init => Initialize'Access, Shutdown => null)); end PolyORB.Smart_Pointers.Initialization; polyorb-2.8~20110207.orig/src/polyorb-poa_policies-servant_retention_policy-non_retain.adb0000644000175000017500000001616311750740340031262 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- POLYORB.POA_POLICIES.SERVANT_RETENTION_POLICY.NON_RETAIN -- -- -- -- B o d y -- -- -- -- Copyright (C) 2002-2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with Ada.Tags; with PolyORB.POA_Policies.Request_Processing_Policy.Use_Default_Servant; with PolyORB.POA_Policies.Request_Processing_Policy.Use_Servant_Manager; package body PolyORB.POA_Policies.Servant_Retention_Policy.Non_Retain is ------------ -- Create -- ------------ function Create return Non_Retain_Policy_Access is begin return new Non_Retain_Policy; end Create; ------------------------- -- Check_Compatibility -- ------------------------- procedure Check_Compatibility (Self : Non_Retain_Policy; Other_Policies : AllPolicies; Error : in out PolyORB.Errors.Error_Container) is pragma Warnings (Off); pragma Unreferenced (Self); pragma Warnings (On); use Ada.Tags; use PolyORB.Errors; use PolyORB.POA_Policies.Request_Processing_Policy; use PolyORB.POA_Policies.Request_Processing_Policy.Use_Default_Servant; use PolyORB.POA_Policies.Request_Processing_Policy.Use_Servant_Manager; begin -- Compatiblity between Non_Retain and Id_Uniqueness done in -- PolyORB.POA_Policies.Id_Uniqueness_Policy.Unique. -- Non_Retain requires either Use_Default_Servant -- or Use_Servant_Manager. for J in Other_Policies'Range loop if Other_Policies (J).all in RequestProcessingPolicy'Class and then not (Other_Policies (J).all'Tag = Use_Default_Servant_Policy'Tag or else Other_Policies (J).all'Tag = Use_Servant_Manager_Policy'Tag) then Throw (Error, InvalidPolicy_E, InvalidPolicy_Members'(Index => 0)); end if; end loop; end Check_Compatibility; --------------- -- Policy_Id -- --------------- function Policy_Id (Self : Non_Retain_Policy) return String is pragma Warnings (Off); pragma Unreferenced (Self); pragma Warnings (On); begin return "SERVANT_RETENTION_POLICY.NON_RETAIN"; end Policy_Id; -------------------------------- -- Retain_Servant_Association -- -------------------------------- procedure Retain_Servant_Association (Self : Non_Retain_Policy; OA : PolyORB.POA_Types.Obj_Adapter_Access; P_Servant : Servants.Servant_Access; U_Oid : Unmarshalled_Oid; Error : in out PolyORB.Errors.Error_Container) is pragma Warnings (Off); pragma Unreferenced (Self, OA, P_Servant, U_Oid, Error); pragma Warnings (On); begin -- NON_RETAIN: No active object map, nothing to retain, -- no way of checking ID uniqueness. null; end Retain_Servant_Association; -------------------------------- -- Forget_Servant_Association -- -------------------------------- procedure Forget_Servant_Association (Self : Non_Retain_Policy; OA : PolyORB.POA_Types.Obj_Adapter_Access; U_Oid : Unmarshalled_Oid; Error : in out PolyORB.Errors.Error_Container) is pragma Warnings (Off); pragma Unreferenced (Self, OA, U_Oid, Error); pragma Warnings (On); begin -- NON_RETAIN: Nothing to do. null; end Forget_Servant_Association; ---------------------------- -- Retained_Servant_To_Id -- ---------------------------- function Retained_Servant_To_Id (Self : Non_Retain_Policy; OA : PolyORB.POA_Types.Obj_Adapter_Access; P_Servant : Servants.Servant_Access) return Object_Id_Access is pragma Warnings (Off); pragma Unreferenced (Self, OA, P_Servant); pragma Warnings (On); begin -- NON_RETAIN: No retained object id available. return null; end Retained_Servant_To_Id; ---------------------------- -- Retained_Id_To_Servant -- ---------------------------- procedure Retained_Id_To_Servant (Self : Non_Retain_Policy; OA : PolyORB.POA_Types.Obj_Adapter_Access; U_Oid : Unmarshalled_Oid; Servant : out Servants.Servant_Access; Error : in out PolyORB.Errors.Error_Container) is pragma Warnings (Off); pragma Unreferenced (Self, OA, U_Oid, Error); pragma Warnings (On); begin -- NON_RETAIN: No retained servant available. Servant := null; end Retained_Id_To_Servant; --------------------------------- -- Ensure_Servant_Manager_Type -- --------------------------------- procedure Ensure_Servant_Manager_Type (Self : Non_Retain_Policy; Manager : ServantManager'Class; Error : in out PolyORB.Errors.Error_Container) is pragma Unreferenced (Self); use PolyORB.Errors; begin if Manager not in ServantLocator'Class then Throw (Error, Obj_Adapter_E, System_Exception_Members'(Minor => 4, Completed => Completed_No)); end if; end Ensure_Servant_Manager_Type; end PolyORB.POA_Policies.Servant_Retention_Policy.Non_Retain; polyorb-2.8~20110207.orig/src/polyorb-sequences-unbounded-helper.ads0000644000175000017500000000642611750740340024607 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . S E Q U E N C E S . U N B O U N D E D . H E L P E R -- -- -- -- S p e c -- -- -- -- Copyright (C) 2003-2007, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- Any conversion subprograms for unbounded sequences with PolyORB.Any; with PolyORB.Sequences.Helper; generic with function Element_From_Any (Item : PolyORB.Any.Any) return Element; with function Element_To_Any (Item : Element) return PolyORB.Any.Any; with function Element_Wrap (X : access Element) return PolyORB.Any.Content'Class; package PolyORB.Sequences.Unbounded.Helper is function From_Any (Item : PolyORB.Any.Any) return Sequence; function To_Any (Item : Sequence) return PolyORB.Any.Any; function Wrap (X : access Sequence) return PolyORB.Any.Content'Class; procedure Initialize (Element_TC, Sequence_TC : PolyORB.Any.TypeCode.Local_Ref); private -- Element accessors to be passed to generic helper package package Unbounded_Helper is new Sequences.Helper (Element => Element, Element_Ptr => Element_Ptr, Sequence => Sequence, Length => Length, New_Sequence => To_Sequence, Set_Length => Set_Length, Unchecked_Element_Of => Unchecked_Element_Of, Element_From_Any => Element_From_Any, Element_To_Any => Element_To_Any, Element_Wrap => Element_Wrap); end PolyORB.Sequences.Unbounded.Helper; polyorb-2.8~20110207.orig/src/polyorb-tasking-profiles-full_tasking-threads-static_priorities.ads0000644000175000017500000000506011750740340032476 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- POLYORB.TASKING.PROFILES.FULL_TASKING.THREADS.DYNAMIC_PRIORITIES -- -- -- -- S p e c -- -- -- -- Copyright (C) 2003-2004 Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by ACT Europe. -- -- (email: sales@act-europe.fr) -- -- -- ------------------------------------------------------------------------------ -- This packages provides a thread library for an Ada full tasking -- runtime, using Ada.Dynamic_Priorities. package PolyORB.Tasking.Profiles.Full_Tasking.Threads.Static_Priorities is procedure Set_Priority (TF : access Full_Tasking_Thread_Factory_Type; T : PTT.Thread_Id; P : System.Any_Priority); function Get_Priority (TF : access Full_Tasking_Thread_Factory_Type; T : PTT.Thread_Id) return System.Any_Priority; end PolyORB.Tasking.Profiles.Full_Tasking.Threads.Static_Priorities; polyorb-2.8~20110207.orig/src/polyorb-representations.adb0000644000175000017500000000437311750740340022561 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . R E P R E S E N T A T I O N S -- -- -- -- B o d y -- -- -- -- Copyright (C) 2004 Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by ACT Europe. -- -- (email: sales@act-europe.fr) -- -- -- ------------------------------------------------------------------------------ package body PolyORB.Representations is ------------- -- Release -- ------------- procedure Release (R : in out Representation) is pragma Unreferenced (R); begin null; end Release; end PolyORB.Representations; polyorb-2.8~20110207.orig/src/polyorb-minimal_servant-tools.adb0000644000175000017500000000743111750740340023660 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . M I N I M A L _ S E R V A N T . T O O L S -- -- -- -- B o d y -- -- -- -- Copyright (C) 2002-2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with PolyORB.Objects; with PolyORB.ORB; with PolyORB.Servants; with PolyORB.Setup; package body PolyORB.Minimal_Servant.Tools is use PolyORB.Minimal_Servant; use PolyORB.Objects; use PolyORB.Servants; use PolyORB.Setup; ---------------------- -- Initiate_Servant -- ---------------------- procedure Initiate_Servant (Obj : access PolyORB.Minimal_Servant.Servant'Class; Type_Id : PolyORB.Types.String; Ref : out PolyORB.References.Ref; Error : in out PolyORB.Errors.Error_Container) is begin Initiate_Servant (Obj, PolyORB.ORB.Object_Adapter (The_ORB), Type_Id, Ref, Error); end Initiate_Servant; procedure Initiate_Servant (Obj : access PolyORB.Minimal_Servant.Servant'Class; Obj_Adapter : PolyORB.Obj_Adapters.Obj_Adapter_Access; Type_Id : PolyORB.Types.String; Ref : out PolyORB.References.Ref; Error : in out PolyORB.Errors.Error_Container) is use PolyORB.Errors; Servant : constant PolyORB.Servants.Servant_Access := To_PolyORB_Servant (Obj); Servant_Id : Object_Id_Access; begin PolyORB.Obj_Adapters.Export (Obj_Adapter.all'Access, Servant, null, Servant_Id, Error); if Found (Error) then return; end if; -- Register object PolyORB.ORB.Create_Reference (The_ORB, Servant_Id, PolyORB.Types.To_Standard_String (Type_Id), Ref); Free (Servant_Id); end Initiate_Servant; ---------------- -- Run_Server -- ---------------- procedure Run_Server is begin PolyORB.ORB.Run (PolyORB.Setup.The_ORB, May_Exit => False); end Run_Server; end PolyORB.Minimal_Servant.Tools; polyorb-2.8~20110207.orig/src/polyorb-storage_pools.ads0000644000175000017500000000435511750740340022235 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . S T O R A G E _ P O O L S -- -- -- -- S p e c -- -- -- -- Copyright (C) 2001 Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by ACT Europe. -- -- (email: sales@act-europe.fr) -- -- -- ------------------------------------------------------------------------------ -- The storage pool to be used for dynamic allocation in PolyORB. -- with System.Storage_Pools; with GNAT.Debug_Pools; package PolyORB.Storage_Pools is Debug_Pool : GNAT.Debug_Pools.Debug_Pool; end PolyORB.Storage_Pools; polyorb-2.8~20110207.orig/src/polyorb-request_qos.adb0000644000175000017500000001614511750740340021706 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . R E Q U E S T _ Q O S -- -- -- -- B o d y -- -- -- -- Copyright (C) 2004-2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with PolyORB.Annotations; with PolyORB.Log; package body PolyORB.Request_QoS is use PolyORB.Annotations; use PolyORB.Log; use PolyORB.QoS; package L is new PolyORB.Log.Facility_Log ("polyorb.request_qos"); procedure O (Message : Standard.String; Level : Log_Level := Debug) renames L.Output; function C (Level : Log_Level := Debug) return Boolean renames L.Enabled; Call_Back_Array : array (QoS_Kind'Range) of Fetch_QoS_CB; type QoS_Note is new Note with record Request_QoS : QoS_Parameters; Reply_QoS : QoS_Parameters; end record; procedure Destroy (N : in out QoS_Note); Empty : constant QoS_Parameters := (others => null); Default_Note : constant QoS_Note := QoS_Note'(Note with Empty, Empty); ------------------- -- Add_Reply_QoS -- ------------------- procedure Add_Reply_QoS (Req : in out Requests.Request; Kind : QoS_Kind; QoS : QoS_Parameter_Access) is Note : QoS_Note; begin pragma Assert (QoS = null or else QoS.Kind = Kind); Get_Note (Req.Notepad, Note, Default_Note); Release (Note.Reply_QoS (Kind)); Note.Reply_QoS (Kind) := QoS; Set_Note (Req.Notepad, Note); end Add_Reply_QoS; --------------------- -- Add_Request_QoS -- --------------------- procedure Add_Request_QoS (Req : in out Requests.Request; Kind : QoS_Kind; QoS : QoS_Parameter_Access) is Note : QoS_Note; begin pragma Assert (QoS = null or else QoS.Kind = Kind); Get_Note (Req.Notepad, Note, Default_Note); Release (Note.Request_QoS (Kind)); Note.Request_QoS (Kind) := QoS; Set_Note (Req.Notepad, Note); end Add_Request_QoS; ------------- -- Destroy -- ------------- procedure Destroy (N : in out QoS_Note) is begin for J in QoS_Kind loop Release (N.Request_QoS (J)); Release (N.Reply_QoS (J)); end loop; end Destroy; ----------------------------- -- Extract_Reply_Parameter -- ----------------------------- function Extract_Reply_Parameter (Kind : QoS_Kind; Req : Requests.Request) return QoS_Parameter_Access is Note : QoS_Note; begin Get_Note (Req.Notepad, Note, Default_Note); return Note.Reply_QoS (Kind); end Extract_Reply_Parameter; ------------------------------- -- Extract_Request_Parameter -- ------------------------------- function Extract_Request_Parameter (Kind : QoS_Kind; Req : Requests.Request) return QoS_Parameter_Access is Note : QoS_Note; begin Get_Note (Req.Notepad, Note, Default_Note); return Note.Request_QoS (Kind); end Extract_Request_Parameter; --------------- -- Fetch_QoS -- --------------- function Fetch_QoS (Ref : PolyORB.References.Ref) return QoS_Parameters is Result : QoS_Parameters; A_Parameter : QoS_Parameter_Access; begin pragma Debug (C, O ("Fetch_QoS: enter")); for J in Call_Back_Array'Range loop if Call_Back_Array (J) /= null then pragma Debug (C, O ("Fetching QoS parameters for " & QoS_Kind'Image (J))); A_Parameter := Call_Back_Array (J) (Ref); if A_Parameter /= null then pragma Assert (J = A_Parameter.Kind); Result (A_Parameter.Kind) := A_Parameter; end if; end if; end loop; pragma Debug (C, O ("Fetch_QoS: leave")); return Result; end Fetch_QoS; ------------------- -- Get_Reply_QoS -- ------------------- function Get_Reply_QoS (Req : Requests.Request) return QoS_Parameters is Note : QoS_Note; begin Get_Note (Req.Notepad, Note, Default_Note); return Note.Reply_QoS; end Get_Reply_QoS; --------------------- -- Get_Request_QoS -- --------------------- function Get_Request_QoS (Req : Requests.Request) return QoS_Parameters is Note : QoS_Note; begin Get_Note (Req.Notepad, Note, Default_Note); return Note.Request_QoS; end Get_Request_QoS; -------------- -- Register -- -------------- procedure Register (Kind : QoS_Kind; CB : Fetch_QoS_CB) is begin pragma Debug (C, O ("Registering call back for " & QoS_Kind'Image (Kind))); pragma Assert (Call_Back_Array (Kind) = null); Call_Back_Array (Kind) := CB; end Register; ------------------- -- Set_Reply_QoS -- ------------------- procedure Set_Reply_QoS (Req : in out Requests.Request; QoS : QoS_Parameters) is Note : QoS_Note; begin Get_Note (Req.Notepad, Note, Default_Note); Note.Reply_QoS := QoS; Set_Note (Req.Notepad, Note); end Set_Reply_QoS; --------------------- -- Set_Request_QoS -- --------------------- procedure Set_Request_QoS (Req : in out Requests.Request; QoS : QoS_Parameters) is Note : QoS_Note; begin Get_Note (Req.Notepad, Note, Default_Note); Note.Request_QoS := QoS; Set_Note (Req.Notepad, Note); end Set_Request_QoS; end PolyORB.Request_QoS; polyorb-2.8~20110207.orig/src/ssl/0000755000175000017500000000000011750740340015772 5ustar xavierxavierpolyorb-2.8~20110207.orig/src/ssl/polyorb-transport-connected-sockets-ssl.adb0000644000175000017500000002245311750740340026400 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- POLYORB.TRANSPORT.CONNECTED.SOCKETS.SSL -- -- -- -- B o d y -- -- -- -- Copyright (C) 2005-2008, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with Ada.Exceptions; with Ada.Streams; with System.Storage_Elements; with PolyORB.Asynch_Ev.Sockets.SSL; with PolyORB.Log; package body PolyORB.Transport.Connected.Sockets.SSL is use PolyORB.Asynch_Ev.Sockets.SSL; use PolyORB.Log; use PolyORB.SSL; use PolyORB.Tasking.Mutexes; package L is new PolyORB.Log.Facility_Log ("polyorb.transport.connected.sockets.ssl"); procedure O (Message : String; Level : Log.Log_Level := Log.Debug) renames L.Output; function C (Level : Log_Level := Debug) return Boolean renames L.Enabled; ----------------------- -- Accept_Connection -- ----------------------- procedure Accept_Connection (TAP : SSL_Access_Point; TE : out Transport_Endpoint_Access) is New_Socket : SSL_Socket_Type; New_Address : Sock_Addr_Type; begin TE := new SSL_Endpoint; Accept_Socket (TAP.Socket, TAP.Context, New_Socket, New_Address); Create (SSL_Endpoint (TE.all), New_Socket); exception when SSL_Error => Destroy (TE); end Accept_Connection; ----------- -- Close -- ----------- procedure Close (TE : access SSL_Endpoint) is begin if TE.Closed then return; end if; Enter (TE.Mutex); begin if TE.SSL_Socket /= No_SSL_Socket then pragma Debug (C, O ("Closing socket" & PolyORB.Sockets.Image (TE.Socket))); Close_Socket (TE.SSL_Socket); TE.SSL_Socket := No_SSL_Socket; TE.Socket := No_Socket; end if; Leave (TE.Mutex); PolyORB.Transport.Connected.Close (Connected_Transport_Endpoint (TE.all)'Access); exception when E : others => pragma Debug (C, O ("Close (Socket_Endpoint): got " & Ada.Exceptions.Exception_Information (E))); null; end; end Close; ------------ -- Create -- ------------ procedure Create (SAP : in out SSL_Access_Point; Socket : PolyORB.Sockets.Socket_Type; Address : in out PolyORB.Sockets.Sock_Addr_Type; Context : PolyORB.SSL.SSL_Context_Type) is begin Create (Socket_Access_Point (SAP), Socket, Address); SAP.Context := Context; end Create; procedure Create (TE : in out SSL_Endpoint; S : SSL_Socket_Type) is begin Create (Socket_Endpoint (TE), Socket_Of (S)); TE.SSL_Socket := S; end Create; ------------------------- -- Create_Event_Source -- ------------------------- function Create_Event_Source (TAP : access SSL_Access_Point) return Asynch_Ev_Source_Access is Ev_Src : constant Asynch_Ev_Source_Access := Create_Event_Source (TAP.Socket); begin Set_Handler (Ev_Src.all, TAP.Handler'Access); return Ev_Src; end Create_Event_Source; ------------------------- -- Create_Event_Source -- ------------------------- function Create_Event_Source (TE : access SSL_Endpoint) return Asynch_Ev_Source_Access is Ev_Src : constant Asynch_Ev_Source_Access := Create_Event_Source (TE.SSL_Socket); begin Set_Handler (Ev_Src.all, TE.Handler'Access); return Ev_Src; end Create_Event_Source; --------------------- -- Get_SSL_Context -- --------------------- function Get_SSL_Context (SAP : SSL_Access_Point) return PolyORB.SSL.SSL_Context_Type is begin return SAP.Context; end Get_SSL_Context; ----------------------- -- Is_Data_Available -- ----------------------- function Is_Data_Available (TE : SSL_Endpoint; N : Natural) return Boolean is begin return Pending_Length (TE.SSL_Socket) >= N; end Is_Data_Available; ---------- -- Read -- ---------- procedure Read (TE : in out SSL_Endpoint; Buffer : Buffers.Buffer_Access; Size : in out Ada.Streams.Stream_Element_Count; Error : out Errors.Error_Container) is use type Ada.Streams.Stream_Element_Count; Data_Received : Ada.Streams.Stream_Element_Count; procedure Receive_Socket (V : access PolyORB.Buffers.Iovec); -- Lowlevel socket receive procedure Receive_Socket (V : access PolyORB.Buffers.Iovec) is Count : Ada.Streams.Stream_Element_Count; Vecs : PolyORB.Sockets.Vector_Type (1 .. 1); pragma Import (Ada, Vecs); for Vecs'Address use V.all'Address; begin PolyORB.SSL.Receive_Vector (TE.SSL_Socket, Vecs, Count); V.Iov_Len := System.Storage_Elements.Storage_Offset (Count); end Receive_Socket; procedure Receive_Buffer is new PolyORB.Buffers.Receive_Buffer (Receive_Socket); begin begin Receive_Buffer (Buffer, Size, Data_Received); exception when PolyORB.Sockets.Socket_Error => PolyORB.Errors.Throw (Error, PolyORB.Errors.Comm_Failure_E, PolyORB.Errors.System_Exception_Members' (Minor => 0, Completed => PolyORB.Errors.Completed_Maybe)); return; when others => PolyORB.Errors.Throw (Error, PolyORB.Errors.Unknown_E, PolyORB.Errors.System_Exception_Members' (Minor => 0, Completed => PolyORB.Errors.Completed_Maybe)); return; end; pragma Assert (Data_Received <= Size); Size := Data_Received; end Read; ----------- -- Write -- ----------- procedure Write (TE : in out SSL_Endpoint; Buffer : Buffers.Buffer_Access; Error : out Errors.Error_Container) is procedure Socket_Send (V : access PolyORB.Buffers.Iovec; N : Integer; Count : out System.Storage_Elements.Storage_Offset); -- Send gathered data ----------------- -- Socket_Send -- ----------------- procedure Socket_Send (V : access PolyORB.Buffers.Iovec; N : Integer; Count : out System.Storage_Elements.Storage_Offset) is subtype SV_T is PolyORB.Sockets.Vector_Type (1 .. N); SV : SV_T; pragma Import (Ada, SV); for SV'Address use V.all'Address; S_Count : Ada.Streams.Stream_Element_Count; begin PolyORB.SSL.Send_Vector (TE.SSL_Socket, SV, S_Count); Count := System.Storage_Elements.Storage_Offset (S_Count); end Socket_Send; procedure Send_Buffer is new Buffers.Send_Buffer (Socket_Send); begin pragma Debug (C, O ("Write: enter")); -- Send_Buffer is not atomic, needs to be protected. Enter (TE.Mutex); pragma Debug (C, O ("TE mutex acquired")); begin Send_Buffer (Buffer); exception when PolyORB.Sockets.Socket_Error => PolyORB.Errors.Throw (Error, PolyORB.Errors.Comm_Failure_E, PolyORB.Errors.System_Exception_Members' (Minor => 0, Completed => PolyORB.Errors.Completed_Maybe)); when others => PolyORB.Errors.Throw (Error, PolyORB.Errors.Unknown_E, PolyORB.Errors.System_Exception_Members' (Minor => 0, Completed => PolyORB.Errors.Completed_Maybe)); end; Leave (TE.Mutex); end Write; end PolyORB.Transport.Connected.Sockets.SSL; polyorb-2.8~20110207.orig/src/ssl/polyorb-ssl.adb0000644000175000017500000006436211750740340020742 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . S S L -- -- -- -- B o d y -- -- -- -- Copyright (C) 2005-2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with Ada.Exceptions; with Interfaces.C.Strings; with PolyORB.Initialization; with PolyORB.Platform.SSL_Linker_Options; pragma Warnings (Off, PolyORB.Platform.SSL_Linker_Options); -- No entity referenced with PolyORB.Utils.Strings; package body PolyORB.SSL is use type Interfaces.C.int; package Thin is type SSL_Error_Code is new Interfaces.C.unsigned_long; type SSL_Verify_Mode is new Interfaces.C.unsigned_long; SSL_Verify_None : constant SSL_Verify_Mode := 0; SSL_Verify_Peer : constant SSL_Verify_Mode := 1; SSL_Verify_Fail_If_No_Peer_Cert : constant SSL_Verify_Mode := 2; SSL_Verify_Client_Once : constant SSL_Verify_Mode := 4; type SSL_Method is private; type X509_STORE_CTX is private; type Stack_Of_X509_NAME is private; No_Stack_Of_X509_NAME : constant Stack_Of_X509_NAME; type SSL_Verify_Callback is access function (Preverify : Interfaces.C.int; Ctx : X509_STORE_CTX) return Interfaces.C.int; pragma Convention (C, SSL_Verify_Callback); type Stack_Of_SSL_Cipher is private; No_Stack_Of_SSL_Cipher : constant Stack_Of_SSL_Cipher; -- General initialization subprograms procedure SSL_library_init; procedure SSL_load_error_strings; -- Context subprograms function SSL_CTX_new (Method : SSL_Method) return SSL_Context_Type; procedure SSL_CTX_free (Context : SSL_Context_Type); function SSL_CTX_use_certificate_file (Ctx : SSL_Context_Type; File : Interfaces.C.char_array; T : Interfaces.C.int) return Interfaces.C.int; function SSL_CTX_use_PrivateKey_file (Ctx : SSL_Context_Type; File : Interfaces.C.char_array; T : Interfaces.C.int) return Interfaces.C.int; function SSL_CTX_check_private_key (Ctx : SSL_Context_Type) return Interfaces.C.int; procedure SSL_CTX_set_verify (Ctx : SSL_Context_Type; Mode : SSL_Verify_Mode; Callback : SSL_Verify_Callback := null); procedure SSL_CTX_set_client_CA_list (Ctx : SSL_Context_Type; List : Stack_Of_X509_NAME); function SSL_CTX_load_verify_locations (Ctx : SSL_Context_Type; CAFile : Interfaces.C.Strings.chars_ptr; CAPath : Interfaces.C.Strings.chars_ptr) return Interfaces.C.int; function SSL_CTX_set_default_verify_paths (Ctx : SSL_Context_Type) return Interfaces.C.int; function SSL_CTX_get_verify_mode (Ctx : SSL_Context_Type) return SSL_Verify_Mode; -- Methods function SSLv2_method return SSL_Method; function SSLv2_client_method return SSL_Method; function SSLv2_server_method return SSL_Method; function SSLv23_method return SSL_Method; function SSLv23_client_method return SSL_Method; function SSLv23_server_method return SSL_Method; function SSLv3_method return SSL_Method; function SSLv3_client_method return SSL_Method; function SSLv3_server_method return SSL_Method; function TLSv1_method return SSL_Method; function TLSv1_client_method return SSL_Method; function TLSv1_server_method return SSL_Method; -- Sockets subprograms function SSL_new (Ctx : SSL_Context_Type) return SSL_Socket_Type; procedure SSL_free (Context : SSL_Socket_Type); function SSL_set_fd (SSL : SSL_Socket_Type; FD : Sockets.Socket_Type) return Interfaces.C.int; function SSL_get_fd (SSL : SSL_Socket_Type) return Sockets.Socket_Type; function SSL_accept (SSL : SSL_Socket_Type) return Interfaces.C.int; function SSL_connect (SSL : SSL_Socket_Type) return Interfaces.C.int; function SSL_pending (SSL : SSL_Socket_Type) return Interfaces.C.int; function SSL_shutdown (SSL : SSL_Socket_Type) return Interfaces.C.int; function SSL_read (SSL : SSL_Socket_Type; Buffer : Sockets.Stream_Element_Reference; Length : Interfaces.C.int) return Interfaces.C.int; function SSL_write (SSL : SSL_Socket_Type; Buffer : Sockets.Stream_Element_Reference; Length : Interfaces.C.int) return Interfaces.C.int; function SSL_get_ciphers (SSL : SSL_Socket_Type) return Stack_Of_SSL_Cipher; -- Error handling subprograms function ERR_get_error return SSL_Error_Code; function ERR_error_string (Error_Code : SSL_Error_Code) return String; -- Others subprograms function SSL_load_client_CA_file (File : Interfaces.C.char_array) return Stack_Of_X509_NAME; -- Ciphers subprograms function SSL_CIPHER_description (Cipher : SSL_Cipher_Type) return String; -- Stack subprograms function sk_SSL_CIPHER_num (Stack : Stack_Of_SSL_Cipher) return Interfaces.C.int; function sk_SSL_CIPHER_value (Stack : Stack_Of_SSL_Cipher; Index : Interfaces.C.int) return SSL_Cipher_Type; private type SSL_Method_Record is null record; pragma Convention (C, SSL_Method_Record); type SSL_Method is access all SSL_Method_Record; type X509_STORE_CTX_Record is null record; pragma Convention (C, X509_STORE_CTX_Record); type X509_STORE_CTX is access all X509_STORE_CTX_Record; type Stack_Of_X509_NAME_Record is null record; type Stack_Of_X509_NAME is access all Stack_Of_X509_NAME_Record; No_Stack_Of_X509_NAME : constant Stack_Of_X509_NAME := null; type Stack_Of_SSL_Cipher_Record is null record; pragma Convention (C, Stack_Of_SSL_Cipher_Record); type Stack_Of_SSL_Cipher is access all Stack_Of_SSL_Cipher_Record; No_Stack_Of_SSL_Cipher : constant Stack_Of_SSL_Cipher := null; pragma Import (C, ERR_get_error, "ERR_get_error"); pragma Import (C, SSL_CTX_check_private_key, "SSL_CTX_check_private_key"); pragma Import (C, SSL_CTX_free, "SSL_CTX_free"); pragma Import (C, SSL_CTX_get_verify_mode, "SSL_CTX_get_verify_mode"); pragma Import (C, SSL_CTX_load_verify_locations, "SSL_CTX_load_verify_locations"); pragma Import (C, SSL_CTX_new, "SSL_CTX_new"); pragma Import (C, SSL_CTX_set_client_CA_list, "SSL_CTX_set_client_CA_list"); pragma Import (C, SSL_CTX_set_default_verify_paths, "SSL_CTX_set_default_verify_paths"); pragma Import (C, SSL_CTX_set_verify, "SSL_CTX_set_verify"); pragma Import (C, SSL_CTX_use_certificate_file, "SSL_CTX_use_certificate_file"); pragma Import (C, SSL_CTX_use_PrivateKey_file, "SSL_CTX_use_PrivateKey_file"); pragma Import (C, SSL_accept, "SSL_accept"); pragma Import (C, SSL_connect, "SSL_connect"); pragma Import (C, SSL_free, "SSL_free"); pragma Import (C, SSL_get_fd, "SSL_get_fd"); pragma Import (C, SSL_get_ciphers, "SSL_get_ciphers"); pragma Import (C, SSL_library_init, "SSL_library_init"); pragma Import (C, SSL_load_error_strings, "SSL_load_error_strings"); pragma Import (C, SSL_load_client_CA_file, "SSL_load_client_CA_file"); pragma Import (C, SSL_new, "SSL_new"); pragma Import (C, SSL_pending, "SSL_pending"); pragma Import (C, SSL_read, "SSL_read"); pragma Import (C, SSL_set_fd, "SSL_set_fd"); pragma Import (C, SSL_shutdown, "SSL_shutdown"); pragma Import (C, SSL_write, "SSL_write"); pragma Import (C, SSLv2_method, "SSLv2_method"); pragma Import (C, SSLv2_client_method, "SSLv2_client_method"); pragma Import (C, SSLv2_server_method, "SSLv2_server_method"); pragma Import (C, SSLv23_method, "SSLv23_method"); pragma Import (C, SSLv23_client_method, "SSLv23_client_method"); pragma Import (C, SSLv23_server_method, "SSLv23_server_method"); pragma Import (C, SSLv3_method, "SSLv3_method"); pragma Import (C, SSLv3_client_method, "SSLv3_client_method"); pragma Import (C, SSLv3_server_method, "SSLv3_server_method"); pragma Import (C, TLSv1_method, "TLSv1_method"); pragma Import (C, TLSv1_client_method, "TLSv1_client_method"); pragma Import (C, TLSv1_server_method, "TLSv1_server_method"); pragma Import (C, sk_SSL_CIPHER_num, "__PolyORB_sk_SSL_CIPHER_num"); pragma Import (C, sk_SSL_CIPHER_value, "__PolyORB_sk_SSL_CIPHER_value"); end Thin; -- Library initialization procedure Initialize; -- Initialize must be called before using any other SSL socket routines function To_SSL_Verify_Mode (Value : SSL_Verification_Mode) return Thin.SSL_Verify_Mode; -- Convert user friendly SSL_Verification_Mode structure into SSL internal -- representation. function To_SSL_Verification_Mode (Value : Thin.SSL_Verify_Mode) return SSL_Verification_Mode; -- Convert SSL internal representation of SSL_Verify_Mode into -- SSL_Verification_Mode ------------------- -- Accept_Socket -- ------------------- procedure Accept_Socket (Server : Sockets.Socket_Type; Context : SSL_Context_Type; Socket : out SSL_Socket_Type; Address : out Sockets.Sock_Addr_Type) is Sock : Sockets.Socket_Type; begin Sockets.Accept_Socket (Server, Sock, Address); Socket := Thin.SSL_new (Context); if Socket = null then Ada.Exceptions.Raise_Exception (SSL_Error'Identity, Get_Errors_String); end if; if Thin.SSL_set_fd (Socket, Sock) /= 1 then Thin.SSL_free (Socket); Ada.Exceptions.Raise_Exception (SSL_Error'Identity, Get_Errors_String); end if; if Thin.SSL_accept (Socket) /= 1 then Thin.SSL_free (Socket); Ada.Exceptions.Raise_Exception (SSL_Error'Identity, Get_Errors_String); end if; end Accept_Socket; ---------------- -- Ciphers_Of -- ---------------- function Ciphers_Of (Context : SSL_Context_Type) return SSL_Cipher_Array is Socket : constant SSL_Socket_Type := Thin.SSL_new (Context); Result : constant SSL_Cipher_Array := Ciphers_Of (Socket); begin Thin.SSL_free (Socket); return Result; end Ciphers_Of; function Ciphers_Of (Socket : SSL_Socket_Type) return SSL_Cipher_Array is use type Thin.Stack_Of_SSL_Cipher; Stack : constant Thin.Stack_Of_SSL_Cipher := Thin.SSL_get_ciphers (Socket); begin if Stack = Thin.No_Stack_Of_SSL_Cipher then return SSL_Cipher_Array'(1 .. 0 => No_SSL_Cipher); end if; declare Length : constant Interfaces.C.int := Thin.sk_SSL_CIPHER_num (Stack); Result : SSL_Cipher_Array (1 .. Integer (Length)); begin for J in 0 .. Length - 1 loop Result (Natural (J + 1)) := Thin.sk_SSL_CIPHER_value (Stack, J); end loop; return Result; end; end Ciphers_Of; ------------------ -- Close_Socket -- ------------------ procedure Close_Socket (Socket : SSL_Socket_Type) is Status : Interfaces.C.int; begin -- Shutdown procedure may not complete in one call, thus call it -- again until it return complete or error status loop Status := Thin.SSL_shutdown (Socket); exit when Status = 1; if Status /= 0 then Ada.Exceptions.Raise_Exception (SSL_Error'Identity, Get_Errors_String); end if; end loop; Sockets.Close_Socket (Socket_Of (Socket)); Thin.SSL_free (Socket); end Close_Socket; -------------------- -- Connect_Socket -- -------------------- procedure Connect_Socket (Sock : in out Sockets.Socket_Type; Context : SSL_Context_Type; Socket : out SSL_Socket_Type; Address : Utils.Sockets.Socket_Name) is begin Utils.Sockets.Connect_Socket (Sock, Address); Socket := Thin.SSL_new (Context); if Socket = null then Ada.Exceptions.Raise_Exception (SSL_Error'Identity, Get_Errors_String); end if; if Thin.SSL_set_fd (Socket, Sock) /= 1 then Thin.SSL_free (Socket); Ada.Exceptions.Raise_Exception (SSL_Error'Identity, Get_Errors_String); end if; if Thin.SSL_connect (Socket) /= 1 then Thin.SSL_free (Socket); Ada.Exceptions.Raise_Exception (SSL_Error'Identity, Get_Errors_String); end if; end Connect_Socket; -------------------- -- Create_Context -- -------------------- procedure Create_Context (Context : out SSL_Context_Type; Method : SSL_Method_Type; Private_Key_File : String; Certificate_File : String; CA_File : String := ""; CA_Path : String := ""; Verification_Mode : SSL_Verification_Mode := (others => False)) is M : Thin.SSL_Method; begin case Method is when SSL_2 => M := Thin.SSLv2_method; when SSL_2_Client => M := Thin.SSLv2_client_method; when SSL_2_Server => M := Thin.SSLv2_server_method; when SSL_3 => M := Thin.SSLv3_method; when SSL_3_Client => M := Thin.SSLv3_client_method; when SSL_3_Server => M := Thin.SSLv3_server_method; when TLS_1 => M := Thin.TLSv1_method; when TLS_1_Client => M := Thin.TLSv1_client_method; when TLS_1_Server => M := Thin.TLSv1_server_method; when Any => M := Thin.SSLv23_method; when Any_Client => M := Thin.SSLv23_client_method; when Any_Server => M := Thin.SSLv23_server_method; end case; Context := Thin.SSL_CTX_new (M); if Context = null then Ada.Exceptions.Raise_Exception (SSL_Error'Identity, Get_Errors_String); end if; -- Set certificate verification level Thin.SSL_CTX_set_verify (Context, To_SSL_Verify_Mode (Verification_Mode)); -- Setting up locations for trusted CA certificates if CA_File /= "" or else CA_Path /= "" then declare File : Interfaces.C.Strings.chars_ptr := Interfaces.C.Strings.Null_Ptr; Path : Interfaces.C.Strings.chars_ptr := Interfaces.C.Strings.Null_Ptr; Status : Interfaces.C.int; begin if CA_File /= "" then File := Interfaces.C.Strings.New_String (CA_File); end if; if CA_Path /= "" then Path := Interfaces.C.Strings.New_String (CA_Path); end if; Status := Thin.SSL_CTX_load_verify_locations (Context, File, Path); Interfaces.C.Strings.Free (File); Interfaces.C.Strings.Free (Path); if Status /= 1 then Ada.Exceptions.Raise_Exception (SSL_Error'Identity, Get_Errors_String); end if; end; else if Thin.SSL_CTX_set_default_verify_paths (Context) /= 1 then Ada.Exceptions.Raise_Exception (SSL_Error'Identity, Get_Errors_String); end if; end if; -- Loading Certificate and Private Key files only if both are specified if Certificate_File = "" or else Private_Key_File = "" then return; end if; -- Loading Certificate file if Thin.SSL_CTX_use_certificate_file (Context, Interfaces.C.To_C (Certificate_File), 1) /= 1 then Thin.SSL_CTX_free (Context); Ada.Exceptions.Raise_Exception (SSL_Error'Identity, Get_Errors_String); end if; -- Loading Private Key file if Thin.SSL_CTX_use_PrivateKey_file (Context, Interfaces.C.To_C (Private_Key_File), 1) /= 1 then Thin.SSL_CTX_free (Context); Ada.Exceptions.Raise_Exception (SSL_Error'Identity, Get_Errors_String); end if; -- Check consistency of Certificate and Private Key if Thin.SSL_CTX_check_private_key (Context) /= 1 then Thin.SSL_CTX_free (Context); Ada.Exceptions.Raise_Exception (SSL_Error'Identity, Get_Errors_String); end if; end Create_Context; -------------------- -- Description_Of -- -------------------- function Description_Of (Cipher : SSL_Cipher_Type) return String renames Thin.SSL_CIPHER_description; --------------------- -- Destroy_Context -- --------------------- procedure Destroy_Context (Context : SSL_Context_Type) is begin Thin.SSL_CTX_free (Context); end Destroy_Context; ----------------------- -- Get_Errors_String -- ----------------------- function Get_Errors_String return String is use type Thin.SSL_Error_Code; Error : constant Thin.SSL_Error_Code := Thin.ERR_get_error; begin if Error /= 0 then return Get_Errors_String & Thin.ERR_error_string (Error); else return ""; end if; end Get_Errors_String; ---------------- -- Initialize -- ---------------- procedure Initialize is begin Thin.SSL_load_error_strings; Thin.SSL_library_init; -- XXX actions_to_seed_PRNG end Initialize; -------------------- -- Load_Client_CA -- -------------------- procedure Load_Client_CA (Context : SSL_Context_Type; CA_File : String) is use type Thin.Stack_Of_X509_NAME; List : constant Thin.Stack_Of_X509_NAME := Thin.SSL_load_client_CA_file (Interfaces.C.To_C (CA_File)); begin if List = Thin.No_Stack_Of_X509_NAME then Ada.Exceptions.Raise_Exception (SSL_Error'Identity, Get_Errors_String); end if; Thin.SSL_CTX_set_client_CA_list (Context, List); end Load_Client_CA; -------------------- -- Pending_Length -- -------------------- function Pending_Length (Socket : SSL_Socket_Type) return Natural is begin return Natural (Thin.SSL_pending (Socket)); end Pending_Length; -------------------- -- Receive_Vector -- -------------------- procedure Receive_Vector (Socket : SSL_Socket_Type; Vector : Sockets.Vector_Type; Count : out Ada.Streams.Stream_Element_Count) is use type Ada.Streams.Stream_Element_Count; Bytes_Readed : Interfaces.C.int; begin Count := 0; for J in Vector'Range loop Bytes_Readed := Thin.SSL_read (Socket, Vector (J).Base, Interfaces.C.int (Vector (J).Length)); if Bytes_Readed <= 0 then Ada.Exceptions.Raise_Exception (SSL_Error'Identity, Get_Errors_String); end if; Count := Count + Ada.Streams.Stream_Element_Count (Bytes_Readed); if Bytes_Readed < Interfaces.C.int (Vector (J).Length) then -- Where are no more data for reading. Exiting. return; end if; end loop; end Receive_Vector; ----------------- -- Send_Vector -- ----------------- procedure Send_Vector (Socket : SSL_Socket_Type; Vector : Sockets.Vector_Type; Count : out Ada.Streams.Stream_Element_Count) is use type Ada.Streams.Stream_Element_Count; Bytes_Written : Interfaces.C.int; begin Count := 0; for J in Vector'Range loop Bytes_Written := Thin.SSL_write (Socket, Vector (J).Base, Interfaces.C.int (Vector (J).Length)); if Bytes_Written <= 0 then Ada.Exceptions.Raise_Exception (SSL_Error'Identity, Get_Errors_String); end if; Count := Count + Ada.Streams.Stream_Element_Count (Bytes_Written); if Bytes_Written < Interfaces.C.int (Vector (J).Length) then -- The actually written number of bytes differ from requested -- number. The operation was successful, but incomplete for some -- reasons. Report this to caller. return; end if; end loop; end Send_Vector; --------------- -- Socket_Of -- --------------- function Socket_Of (Socket : SSL_Socket_Type) return Sockets.Socket_Type is begin return Thin.SSL_get_fd (Socket); end Socket_Of; ---------- -- Thin -- ---------- package body Thin is ---------------------- -- ERR_error_string -- ---------------------- function ERR_error_string (Error_Code : SSL_Error_Code) return String is procedure ERR_error_string_n (Error_Code : SSL_Error_Code; Buf : Interfaces.C.char_array; Len : Interfaces.C.size_t); pragma Import (C, ERR_error_string_n, "ERR_error_string_n"); Buffer : Interfaces.C.char_array (1 .. 1024); pragma Warnings (Off, Buffer); -- Buffer not needed to be initialized and modified, because -- of side effect of C function ERR_error_string_n begin ERR_error_string_n (Error_Code, Buffer, Buffer'Length); return Interfaces.C.To_Ada (Buffer); end ERR_error_string; ---------------------------- -- SSL_CIPHER_description -- ---------------------------- function SSL_CIPHER_description (Cipher : SSL_Cipher_Type) return String is procedure SSL_CIPHER_description (Cipher : SSL_Cipher_Type; Buf : Interfaces.C.char_array; Size : Interfaces.C.int); pragma Import (C, SSL_CIPHER_description, "SSL_CIPHER_description"); Buffer : Interfaces.C.char_array (1 .. 512); pragma Warnings (Off, Buffer); -- Buffer not needed to be initialized and modified, because -- of side effect of C function SSL_CIPHER_description begin SSL_CIPHER_description (Cipher, Buffer, Buffer'Length); return Interfaces.C.To_Ada (Buffer); end SSL_CIPHER_description; end Thin; ------------------------ -- To_SSL_Verify_Mode -- ------------------------ function To_SSL_Verify_Mode (Value : SSL_Verification_Mode) return Thin.SSL_Verify_Mode is use type Thin.SSL_Verify_Mode; Result : Thin.SSL_Verify_Mode := Thin.SSL_Verify_None; begin if Value (Peer) then Result := Thin.SSL_Verify_Peer; if Value (Fail_If_No_Peer_Certificate) then Result := Result or Thin.SSL_Verify_Fail_If_No_Peer_Cert; end if; if Value (Client_Once) then Result := Result or Thin.SSL_Verify_Client_Once; end if; end if; return Result; end To_SSL_Verify_Mode; ------------------------------ -- To_SSL_Verification_Mode -- ------------------------------ function To_SSL_Verification_Mode (Value : Thin.SSL_Verify_Mode) return SSL_Verification_Mode is use type Thin.SSL_Verify_Mode; Result : SSL_Verification_Mode := (others => False); begin if (Value and Thin.SSL_Verify_Peer) = Thin.SSL_Verify_Peer then Result (Peer) := True; if (Value and Thin.SSL_Verify_Fail_If_No_Peer_Cert) = Thin.SSL_Verify_Fail_If_No_Peer_Cert then Result (Fail_If_No_Peer_Certificate) := True; end if; if (Value and Thin.SSL_Verify_Client_Once) = Thin.SSL_Verify_Client_Once then Result (Client_Once) := True; end if; end if; return Result; end To_SSL_Verification_Mode; -------------------------- -- Verification_Mode_Of -- -------------------------- function Verification_Mode_Of (Context : SSL_Context_Type) return SSL_Verification_Mode is begin return To_SSL_Verification_Mode (Thin.SSL_CTX_get_verify_mode (Context)); end Verification_Mode_Of; begin declare use PolyORB.Initialization; use PolyORB.Initialization.String_Lists; use PolyORB.Utils.Strings; begin Register_Module (Module_Info' (Name => +"ssl", Conflicts => Empty, Depends => +"sockets", Provides => Empty, Implicit => False, Init => Initialize'Access, Shutdown => null)); end; end PolyORB.SSL; polyorb-2.8~20110207.orig/src/ssl/polyorb-ssl.ads0000644000175000017500000001604511750740340020756 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . S S L -- -- -- -- S p e c -- -- -- -- Copyright (C) 2005-2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- A binding for the OpenSSL library with Ada.Streams; with PolyORB.Sockets; with PolyORB.Utils.Sockets; package PolyORB.SSL is type SSL_Context_Type is private; type SSL_Socket_Type is private; No_SSL_Socket : constant SSL_Socket_Type; type SSL_Method_Type is (SSL_2, SSL_2_Client, SSL_2_Server, SSL_3, SSL_3_Client, SSL_3_Server, TLS_1, TLS_1_Client, TLS_1_Server, Any, Any_Client, Any_Server); type SSL_Verification_Mode_Flag is (Peer, Fail_If_No_Peer_Certificate, Client_Once); type SSL_Verification_Mode is array (SSL_Verification_Mode_Flag) of Boolean; type SSL_Cipher_Type is private; No_SSL_Cipher : constant SSL_Cipher_Type; type SSL_Cipher_Array is array (Positive range <>) of SSL_Cipher_Type; SSL_Error : exception; ------------------------ -- Context operations -- ------------------------ procedure Create_Context (Context : out SSL_Context_Type; Method : SSL_Method_Type; Private_Key_File : String; Certificate_File : String; CA_File : String := ""; CA_Path : String := ""; Verification_Mode : SSL_Verification_Mode := (others => False)); -- Create a new SSL context with the specified Method; load private key -- and certificate from files. CA_File and CA_Path define file and path -- of trusted CA sertificates repository. Raises SSL_Error on any -- error. procedure Load_Client_CA (Context : SSL_Context_Type; CA_File : String); -- Set the list of CAs sent to the client when requesting a client -- certificate from file. Relevant only to servers. Raises SSL_Error on -- any error. procedure Destroy_Context (Context : SSL_Context_Type); -- Destroy SSL context function Ciphers_Of (Context : SSL_Context_Type) return SSL_Cipher_Array; -- Return list of available ciphers function Verification_Mode_Of (Context : SSL_Context_Type) return SSL_Verification_Mode; -- Return current verification mode value --------------------------- -- SSL socket operations -- --------------------------- procedure Accept_Socket (Server : Sockets.Socket_Type; Context : SSL_Context_Type; Socket : out SSL_Socket_Type; Address : out Sockets.Sock_Addr_Type); -- Extract the first pending incoming connection from the queue. -- Create a new connected socket with the same properties as Server, -- allocates a new SSL context, and negotiate an SSL connection. -- On return, Address is the address of the remote endpoint. -- Raises Socket_Error on socket error and SSL_Error on SSL connection -- negotiation error. procedure Connect_Socket (Sock : in out Sockets.Socket_Type; Context : SSL_Context_Type; Socket : out SSL_Socket_Type; Address : Utils.Sockets.Socket_Name); -- Make a connection to a remote SSL access point with the given -- Address, using SSL parameters specified by Context. -- Raises Socket_Error on socket error and SSL_Error on SSL connection -- negotiation error. procedure Close_Socket (Socket : SSL_Socket_Type); -- Close a socket function Socket_Of (Socket : SSL_Socket_Type) return Sockets.Socket_Type; -- Return the underlying socket for the given SSL connection function Pending_Length (Socket : SSL_Socket_Type) return Natural; -- Return number of readable bytes buffered in Socket procedure Receive_Vector (Socket : SSL_Socket_Type; Vector : Sockets.Vector_Type; Count : out Ada.Streams.Stream_Element_Count); -- Receive data from a socket and scatter it into the set of vector -- elements Vector. Count is set to the count of received stream elements. -- Raise SSL_Error on SSL socket error. procedure Send_Vector (Socket : SSL_Socket_Type; Vector : Sockets.Vector_Type; Count : out Ada.Streams.Stream_Element_Count); -- Transmit data gathered from the set of vector elements Vector to a -- socket. Count is set to the count of transmitted stream elements. -- Raise SSL_Error on SSL socket error. function Ciphers_Of (Socket : SSL_Socket_Type) return SSL_Cipher_Array; -- Return list of available ciphers ------------------------------ -- Miscellaneous operations -- ------------------------------ function Get_Errors_String return String; -- Return description string for all errors from error queue function Description_Of (Cipher : SSL_Cipher_Type) return String; -- XXX comment required??? private type Context_Record is null record; pragma Convention (C, Context_Record); type SSL_Context_Type is access all Context_Record; type Socket_Record is null record; pragma Convention (C, Socket_Record); type SSL_Socket_Type is access all Socket_Record; type SSL_Cipher_Record is null record; pragma Convention (C, SSL_Cipher_Record); type SSL_Cipher_Type is access all SSL_Cipher_Record; No_SSL_Cipher : constant SSL_Cipher_Type := null; No_SSL_Socket : constant SSL_Socket_Type := null; end PolyORB.SSL; polyorb-2.8~20110207.orig/src/ssl/polyorb-asynch_ev-sockets-ssl.adb0000644000175000017500000001447711750740340024372 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . A S Y N C H _ E V . S O C K E T S . S S L -- -- -- -- B o d y -- -- -- -- Copyright (C) 2005-2009, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with PolyORB.Log; package body PolyORB.Asynch_Ev.Sockets.SSL is use PolyORB.Log; use PolyORB.Sockets; use PolyORB.SSL; package L is new PolyORB.Log.Facility_Log ("polyorb.asynch_ev.sockets.ssl"); procedure O (Message : String; Level : Log_Level := Debug) renames L.Output; function C (Level : Log_Level := Debug) return Boolean renames L.Enabled; type Socket_Event_Monitor_Access is access all Socket_Event_Monitor; function Create_SSL_Event_Monitor return Asynch_Ev_Monitor_Access; -------------------- -- AEM_Factory_Of -- -------------------- function AEM_Factory_Of (AES : SSL_Event_Source) return AEM_Factory is pragma Unreferenced (AES); begin return Create_SSL_Event_Monitor'Access; end AEM_Factory_Of; ------------------------- -- Create_Event_Source -- ------------------------- function Create_Event_Source (Socket : PolyORB.SSL.SSL_Socket_Type) return Asynch_Ev_Source_Access is Result : constant Asynch_Ev_Source_Access := new SSL_Event_Source; begin SSL_Event_Source (Result.all).SSL_Socket := Socket; SSL_Event_Source (Result.all).Socket := Socket_Of (Socket); return Result; end Create_Event_Source; function Create_Event_Source (Socket : PolyORB.Sockets.Socket_Type) return Asynch_Ev_Source_Access is Result : constant Asynch_Ev_Source_Access := new SSL_Event_Source; begin SSL_Event_Source (Result.all).SSL_Socket := No_SSL_Socket; SSL_Event_Source (Result.all).Socket := Socket; return Result; end Create_Event_Source; ------------------------------ -- Create_SSL_Event_Monitor -- ------------------------------ function Create_SSL_Event_Monitor return Asynch_Ev_Monitor_Access is begin return new SSL_Event_Monitor; end Create_SSL_Event_Monitor; --------------------- -- Register_Source -- --------------------- procedure Register_Source (AEM : access SSL_Event_Monitor; AES : Asynch_Ev_Source_Access; Success : out Boolean) is begin pragma Debug (C, O ("Register_Source: enter")); Success := False; if AES.all not in SSL_Event_Source then pragma Debug (C, O ("Register_Source: leave")); return; end if; Set (AEM.Monitored_Set, SSL_Event_Source (AES.all).Socket); Source_Lists.Append (AEM.Sources, Socket_Event_Source (AES.all)'Access); pragma Debug (C, O ("Register_Source: Sources'Length:=" & Integer'Image (Source_Lists.Length (AEM.Sources)))); AES.Monitor := Asynch_Ev_Monitor_Access (AEM); Success := True; pragma Debug (C, O ("Register_Source: leave")); end Register_Source; ------------------- -- Check_Sources -- ------------------- function Check_Sources (AEM : access SSL_Event_Monitor; Timeout : Duration) return AES_Array is use Source_Lists; Result : AES_Array (1 .. Length (AEM.Sources)); Last : Integer := 0; begin pragma Debug (C, O ("Check_Sources: enter")); -- SSL transport may cache data in the internal buffer, so if cached -- data available then adding event source to the result. declare Iter : Iterator := First (AEM.Sources); begin while not Source_Lists.Last (Iter) loop if SSL_Event_Source (Value (Iter).all).SSL_Socket /= No_SSL_Socket and then Pending_Length (SSL_Event_Source (Value (Iter).all).SSL_Socket) /= 0 then Last := Last + 1; Result (Last) := Value (Iter).all'Access; Clear (AEM.Monitored_Set, SSL_Event_Source (Value (Iter).all).Socket); Remove (AEM.Sources, Iter); else Next (Iter); end if; end loop; end; -- If at least one event source has cached data, then -- immediately return (because checking of sockets may produce -- time delay), otherwise, call Check_Sources. if Last /= 0 then return Result (1 .. Last); else return Check_Sources (Socket_Event_Monitor_Access (AEM), Timeout); end if; end Check_Sources; end PolyORB.Asynch_Ev.Sockets.SSL; polyorb-2.8~20110207.orig/src/ssl/polyorb-asynch_ev-sockets-ssl.ads0000644000175000017500000000632511750740340024404 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . A S Y N C H _ E V . S O C K E T S . S S L -- -- -- -- S p e c -- -- -- -- Copyright (C) 2005 Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- An asynchrous event source that is a set of SSL sockets. with PolyORB.SSL; package PolyORB.Asynch_Ev.Sockets.SSL is pragma Elaborate_Body; type SSL_Event_Monitor is new Socket_Event_Monitor with private; type SSL_Event_Source is new Socket_Event_Source with private; procedure Register_Source (AEM : access SSL_Event_Monitor; AES : Asynch_Ev_Source_Access; Success : out Boolean); function Check_Sources (AEM : access SSL_Event_Monitor; Timeout : Duration) return AES_Array; function Create_Event_Source (Socket : PolyORB.SSL.SSL_Socket_Type) return Asynch_Ev_Source_Access; function Create_Event_Source (Socket : PolyORB.Sockets.Socket_Type) return Asynch_Ev_Source_Access; -- XXX This subprogram can be removed once multiple event source -- monitors are implemented in ORB Controllers function AEM_Factory_Of (AES : SSL_Event_Source) return AEM_Factory; private type SSL_Event_Source is new Socket_Event_Source with record SSL_Socket : PolyORB.SSL.SSL_Socket_Type; end record; type SSL_Event_Monitor is new Socket_Event_Monitor with null record; end PolyORB.Asynch_Ev.Sockets.SSL; polyorb-2.8~20110207.orig/src/ssl/polyorb-utils-ssl_access_points.adb0000644000175000017500000000761511750740340025013 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . U T I L S . S S L _ A C C E S S _ P O I N T S -- -- -- -- B o d y -- -- -- -- Copyright (C) 2005-2007, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with PolyORB.Components; with PolyORB.Setup; with PolyORB.Transport.Connected.Sockets.SSL; package body PolyORB.Utils.SSL_Access_Points is use PolyORB.Binding_Data; use PolyORB.Sockets; use PolyORB.SSL; use PolyORB.Transport; use PolyORB.Transport.Connected.Sockets.SSL; ----------------------- -- Initialize_Socket -- ----------------------- procedure Initialize_Socket (API : out Access_Point_Info; Address : Inet_Addr_Type; Port_Hint : Port_Interval; Context : SSL_Context_Type) is begin -- ??? Most of the code below is copied directly from TCP_Access_Points -- and should be factored. Create_Socket (API.Socket); API.Address := Sock_Addr_Type'(Addr => Address, Port => Port_Hint.Lo, Family => Family_Inet); -- Allow reuse of local addresses Set_Socket_Option (API.Socket, Socket_Level, (Reuse_Address, True)); if API.SAP = null then API.SAP := new SSL_Access_Point; end if; loop begin Create (SSL_Access_Point (API.SAP.all), API.Socket, API.Address, Context); exit; exception when Sockets.Socket_Error => -- If a specific port range was given, try next port in range if API.Address.Port /= Any_Port and then API.Address.Port < Port_Hint.Hi then API.Address.Port := API.Address.Port + 1; else raise; end if; end; end loop; if API.PF /= null then Create_Factory (API.PF.all, API.SAP, Components.Component_Access (Setup.The_ORB)); end if; end Initialize_Socket; end PolyORB.Utils.SSL_Access_Points; polyorb-2.8~20110207.orig/src/ssl/polyorb-utils-ssl_access_points.ads0000644000175000017500000000606011750740340025025 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . U T I L S . S S L _ A C C E S S _ P O I N T S -- -- -- -- S p e c -- -- -- -- Copyright (C) 2005-2007, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- Helper subprograms to set up access points based on SSL sockets -- for a PolyORB server. with PolyORB.Binding_Data; with PolyORB.Sockets; with PolyORB.SSL; with PolyORB.Transport; with PolyORB.Utils.Socket_Access_Points; package PolyORB.Utils.SSL_Access_Points is use PolyORB.Utils.Socket_Access_Points; ---------------------------------- -- Access_Point_Info descriptor -- ---------------------------------- type Access_Point_Info is record Socket : Sockets.Socket_Type; Address : Sockets.Sock_Addr_Type; SAP : Transport.Transport_Access_Point_Access; PF : Binding_Data.Profile_Factory_Access; end record; procedure Initialize_Socket (API : out Access_Point_Info; Address : Sockets.Inet_Addr_Type; Port_Hint : Port_Interval; Context : SSL.SSL_Context_Type); -- Initialize API.Socket and bind it to a free port, using one of -- the address corresponding to hostname, or use Address and -- Port_Hint if possible. end PolyORB.Utils.SSL_Access_Points; polyorb-2.8~20110207.orig/src/ssl/polyorb_ssl.c0000644000175000017500000000450211750740340020506 0ustar xavierxavier/***************************************************************************** ** ** ** POLYORB COMPONENTS ** ** ** ** P O L Y O R B _ S S L ** ** ** ** C s u p p o r t f i l e ** ** ** ** Copyright (C) 2005 Free Software Foundation, Inc. ** ** ** ** PolyORB is free software; you can redistribute it and/or modify it ** ** under terms of the GNU General Public License as published by the Free ** ** Software Foundation; either version 2, or (at your option) any later ** ** version. PolyORB is distributed in the hope that it will be useful, ** ** but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- ** ** TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public ** ** License for more details. You should have received a copy of the GNU ** ** General Public License distributed with PolyORB; see file COPYING. If ** ** not, write to the Free Software Foundation, 59 Temple Place - Suite 330, ** ** Boston, MA 02111-1307, USA. ** ** ** ** ** ** PolyORB is maintained by AdaCore ** ** (email: sales@adacore.com) ** ** ** *****************************************************************************/ /* This module provides a functional binding for two OpenSSL macros */ #include int __PolyORB_sk_SSL_CIPHER_num (STACK_OF(SSL_CIPHER) *sk) { return sk_SSL_CIPHER_num(sk); } SSL_CIPHER *__PolyORB_sk_SSL_CIPHER_value (STACK_OF(SSL_CIPHER) *sk, int i) { return sk_SSL_CIPHER_value(sk, i); } polyorb-2.8~20110207.orig/src/ssl/polyorb-transport-connected-sockets-ssl.ads0000644000175000017500000000740611750740340026422 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- POLYORB.TRANSPORT.CONNECTED.SOCKETS.SSL -- -- -- -- S p e c -- -- -- -- Copyright (C) 2005 Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- SSL transport service access points and transport endpoints. with PolyORB.SSL; package PolyORB.Transport.Connected.Sockets.SSL is pragma Elaborate_Body; type SSL_Access_Point is new Socket_Access_Point with private; procedure Create (SAP : in out SSL_Access_Point; Socket : PolyORB.Sockets.Socket_Type; Address : in out PolyORB.Sockets.Sock_Addr_Type; Context : PolyORB.SSL.SSL_Context_Type); function Create_Event_Source (TAP : access SSL_Access_Point) return Asynch_Ev.Asynch_Ev_Source_Access; procedure Accept_Connection (TAP : SSL_Access_Point; TE : out Transport_Endpoint_Access); function Get_SSL_Context (SAP : SSL_Access_Point) return PolyORB.SSL.SSL_Context_Type; type SSL_Endpoint is new Socket_Endpoint with private; procedure Create (TE : in out SSL_Endpoint; S : PolyORB.SSL.SSL_Socket_Type); function Create_Event_Source (TE : access SSL_Endpoint) return Asynch_Ev.Asynch_Ev_Source_Access; function Is_Data_Available (TE : SSL_Endpoint; N : Natural) return Boolean; procedure Read (TE : in out SSL_Endpoint; Buffer : Buffers.Buffer_Access; Size : in out Ada.Streams.Stream_Element_Count; Error : out Errors.Error_Container); procedure Write (TE : in out SSL_Endpoint; Buffer : Buffers.Buffer_Access; Error : out Errors.Error_Container); procedure Close (TE : access SSL_Endpoint); private type SSL_Access_Point is new Socket_Access_Point with record Context : PolyORB.SSL.SSL_Context_Type; end record; type SSL_Endpoint is new Socket_Endpoint with record SSL_Socket : PolyORB.SSL.SSL_Socket_Type; end record; end PolyORB.Transport.Connected.Sockets.SSL; polyorb-2.8~20110207.orig/src/polyorb-tasking-profiles-ravenscar-index_manager.adb0000644000175000017500000001365311750740340027377 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- POLYORB.TASKING.PROFILES.RAVENSCAR.INDEX_MANAGER -- -- -- -- B o d y -- -- -- -- Copyright (C) 2002-2008, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- Implementation of a thread safe index manager. with PolyORB.Log; package body PolyORB.Tasking.Profiles.Ravenscar.Index_Manager is use PolyORB.Log; package L is new PolyORB.Log.Facility_Log ("polyorb.tasking.profiles.ravenscar.index_manager"); procedure O (Message : String; Level : Log_Level := Debug) renames L.Output; function C (Level : Log_Level := Debug) return Boolean renames L.Enabled; type Flag_Array is array (Index_Type) of Boolean; type Index_Type_Array is array (Index_Type) of Index_Type; protected Index_Manager is -- This protected object manage the pool of Index, -- and the "allocations" of ID. -- this manager uses a stack of fixed size -- "release" push an ID in this stack, -- and "get" pop an ID. -- this stack is implemented by an array, with an offset -- pointing at the next ID available. procedure Get (Id : out Index_Type); -- Get a free Index_Type procedure Release (Id : Index_Type); -- Release Id procedure Init (Error_On_Initialize : Boolean := True); -- Initialize the Index_Manager private Initialized : Boolean := False; Free_Stack : Index_Type_Array; Offset : Index_Type; Number_Of_Used : Integer; Used : Flag_Array; end Index_Manager; function Modular (I : Integer) return Index_Type; pragma Inline (Modular); -- Convert an Integer to an Index_Type, returning -- I mod Number_Of_Indices --------- -- Get -- --------- procedure Get (Id : out Index_Type) is begin Index_Manager.Get (Id); end Get; ------------------- -- Index_Manager -- ------------------- protected body Index_Manager is ----------------------- -- Index_Manager.Get -- ----------------------- procedure Get (Id : out Index_Type) is begin pragma Assert (Initialized); if Number_Of_Used > Index_Type'Last then raise Tasking_Error; end if; Id := Free_Stack (Offset); Offset := Modular (Integer (Offset) - 1); Number_Of_Used := Number_Of_Used + 1; pragma Debug (C, O ("Get " & Integer'Image (Id))); Used (Id) := True; end Get; ------------------------ -- Index_Manager.Init -- ------------------------ procedure Init (Error_On_Initialize : Boolean := True) is begin pragma Assert (not (Initialized and then Error_On_Initialize)); if not Initialized then for J in Free_Stack'Range loop Free_Stack (J) := J; Used (J) := False; end loop; Number_Of_Used := 0; Offset := Free_Stack'Last; Initialized := True; end if; end Init; --------------------------- -- Index_Manager.Release -- --------------------------- procedure Release (Id : Index_Type) is begin pragma Debug (C, O ("Release" & Integer'Image (Id))); pragma Assert (Initialized); if not Used (Id) then raise Program_Error; end if; Offset := Modular (Integer (Offset) + 1); Free_Stack (Offset) := Id; Number_Of_Used := Number_Of_Used - 1; Used (Id) := False; end Release; end Index_Manager; ---------------- -- Initialize -- ---------------- procedure Initialize (Error_On_Initialize : Boolean := True) is begin Index_Manager.Init (Error_On_Initialize); end Initialize; ------------- -- Modular -- ------------- function Modular (I : Integer) return Index_Type is begin return Index_Type (I mod Number_Of_Indices); end Modular; ------------- -- Release -- ------------- procedure Release (Id : Index_Type) is begin Index_Manager.Release (Id); end Release; end PolyORB.Tasking.Profiles.Ravenscar.Index_Manager; polyorb-2.8~20110207.orig/src/polyorb-binding_objects-lists.ads0000644000175000017500000000431211750740340023625 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . B I N D I N G _ O B J E C T S . L I S T S -- -- -- -- S p e c -- -- -- -- Copyright (C) 2004-2009, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ package PolyORB.Binding_Objects.Lists is new PolyORB.Utils.Ilists.Lists (T => Binding_Object'Class, T_Acc => Binding_Object_Access, Doubly_Linked => True); polyorb-2.8~20110207.orig/src/aws/0000755000175000017500000000000011750740340015763 5ustar xavierxavierpolyorb-2.8~20110207.orig/src/aws/aws-status.ads0000644000175000017500000002406411750740337020603 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- A W S . S T A T U S -- -- -- -- S p e c -- -- -- -- Copyright (C) 2000-2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- This package is used to keep the HTTP protocol status. Client can then -- request the status for various values like the requested URI, the -- Content_Length and the Session ID for example. -- to be changed, as we use aws.net with Ada.Streams; with Ada.Strings.Unbounded; with AWS.Headers; -- with AWS.Net with AWS.Parameters; with AWS.Session; with AWS.URL; with AWS.Utils; with SOAP.Message.Payload; package AWS.Status is type Data is private; type Data_Access is access all Data; type Request_Method is (GET, HEAD, POST, PUT); type Authorization_Type is (None, Basic, Digest); function Check_Digest (D : Data; Password : String) return Boolean; -- This function is used by the digest authentication to check if the -- client password is correct. -- The password is not transferred between the client and the server, -- the server check that the client knows the right password using the -- MD5 checksum. function Authorization_Mode (D : Data) return Authorization_Type; pragma Inline (Authorization_Mode); -- Get the type of the "Authorization:" parameter function Authorization_Name (D : Data) return String; pragma Inline (Authorization_Name); -- Get the value for the name in the "Authorization:" parameter function Authorization_Password (D : Data) return String; pragma Inline (Authorization_Password); -- Get the value for the password in the "Authorization:" parameter function Authorization_Realm (D : Data) return String; pragma Inline (Authorization_Realm); -- Get the value for the "realm" in the "Authorization:" parameter function Authorization_Nonce (D : Data) return String; pragma Inline (Authorization_Nonce); -- Get the value for the "nonce" in the "Authorization:" parameter function Authorization_NC (D : Data) return String; pragma Inline (Authorization_NC); -- Get the value for the "nc" in the "Authorization:" parameter function Authorization_CNonce (D : Data) return String; pragma Inline (Authorization_CNonce); -- Get the value for the "cnonce" in the "Authorization:" parameter function Authorization_QOP (D : Data) return String; pragma Inline (Authorization_QOP); -- Get the value for the "qop" in the "Authorization:" parameter function Authorization_Response (D : Data) return String; pragma Inline (Authorization_Response); -- Get the value for the "response" in the "Authorization:" parameter function Connection (D : Data) return String; pragma Inline (Connection); -- Get the value for "Connection:" parameter function Content_Length (D : Data) return Natural; pragma Inline (Content_Length); -- Get the value for "Content-Length:" parameter, this is the number of -- bytes in the message body. function Content_Type (D : Data) return String; pragma Inline (Content_Type); -- Get value for "Content-Type:" parameter function Has_Session (D : Data) return Boolean; pragma Inline (Has_Session); -- Returns true if a session ID has been received. function Host (D : Data) return String; pragma Inline (Host); -- Get value for "Host:" parameter function HTTP_Version (D : Data) return String; pragma Inline (HTTP_Version); -- Returns the HTTP version used by the client. function If_Modified_Since (D : Data) return String; pragma Inline (If_Modified_Since); -- Get value for "If-Modified-Since:" parameter function Keep_Alive (D : Data) return Boolean; pragma Inline (Keep_Alive); -- Returns the flag if the current HTTP connection is keep-alive. function Method (D : Data) return Request_Method; pragma Inline (Method); -- Returns the request method. function Multipart_Boundary (D : Data) return String; pragma Inline (Multipart_Boundary); -- Get value for the boundary part in "Content-Type: ...; boundary=..." -- parameter. This is a string that will be used to separate each chunk of -- data in a multipart message. function Parameters (D : Data) return Parameters.List; pragma Inline (Parameters); -- Returns the list of parameters for the request. This list can be empty -- if there was no form or URL parameters. function Peername (D : Data) return String; pragma Inline (Peername); -- Returns the name of the peer (the name of the client computer) function Session (D : Data) return Session.ID; pragma Inline (Session); -- Returns the Session ID for the request. function Session_Created (D : Data) return Boolean; -- Returns True if session was just created and is going to be sent to -- client. -- function Socket (D : Data) return Net.Socket_Type'Class; -- pragma Inline (Socket); -- Returns the socket used to transfert data between the client and -- server. function URI (D : Data) return String; pragma Inline (URI); -- Returns the requested resource. function URI (D : Data) return URL.Object; pragma Inline (URI); -- As above but return an URL object. function User_Agent (D : Data) return String; pragma Inline (User_Agent); -- Get value for "User-Agent:" parameter function Referer (D : Data) return String; pragma Inline (Referer); -- Get value for "Referer:" parameter function Is_SOAP (D : Data) return Boolean; pragma Inline (Is_SOAP); -- Returns True if it is a SOAP request. In this case SOAPAction return -- the SOAPAction header and Payload returns the XML SOAP Payload message. function SOAPAction (D : Data) return String; pragma Inline (SOAPAction); -- Get value for "SOAPAction:" parameter. This is a standard header to -- support SOAP over HTTP protocol. function Payload (D : Data) return String; pragma Inline (Payload); -- Returns the XML Payload message. XML payload is the actual SOAP request function Payload (D : Data) return SOAP.Message.Payload.Object; -- Returns the AWS_SOAP structure of the payload. This is meant for -- PolyORB/AWS, as we have to decode the payload before creating the -- status, while original AWS does it afterwards. subtype Stream_Element_Array is Ada.Streams.Stream_Element_Array; function Binary_Data (D : Data) return Stream_Element_Array; pragma Inline (Binary_Data); -- Returns the binary data message content. function Header (D : Data) return Headers.List; pragma Inline (Header); -- Returns the list of header lines for the request. private use Ada.Strings.Unbounded; type Data is record Peername : Unbounded_String; Method : Request_Method := GET; URI : URL.Object; Parameters : AWS.Parameters.List; Header : Headers.List; Binary_Data : Utils.Stream_Element_Array_Access := null; HTTP_Version : Unbounded_String; Content_Length : Natural := 0; Keep_Alive : Boolean; File_Up_To_Date : Boolean := False; SOAP_Action : Boolean := False; -- Socket : Net.Socket_Access; Auth_Mode : Authorization_Type := None; Auth_Name : Unbounded_String; -- for Basic and Digest Auth_Password : Unbounded_String; -- for Basic Auth_Realm : Unbounded_String; -- for Digest Auth_Nonce : Unbounded_String; -- for Digest Auth_NC : Unbounded_String; -- for Digest Auth_CNonce : Unbounded_String; -- for Digest Auth_QOP : Unbounded_String; -- for Digest Auth_Response : Unbounded_String; -- for Digest Session_ID : AWS.Session.ID := AWS.Session.No_Session; Session_Created : Boolean := False; -- Payload : Unbounded_String; SOAP_Payload : SOAP.Message.Payload.Object; end record; end AWS.Status; polyorb-2.8~20110207.orig/src/aws/soap-message.ads0000644000175000017500000000654111750740337021054 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- S O A P . M E S S A G E -- -- -- -- S p e c -- -- -- -- Copyright (C) 2000-2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with Ada.Strings.Unbounded; with SOAP.Parameters; package SOAP.Message is use Ada.Strings.Unbounded; type Object is tagged private; Default_Name_Space : constant String := "http://mns.org/"; -- Default name space used by AWS if none as been specified. function XML_Image (M : Object) return Unbounded_String; -- Returns the XML image for the wrapper and parameters. This is designed -- to be used by Payload and Response object. function Name_Space (M : Object'Class) return String; -- Returns message Namespace. function Wrapper_Name (M : Object'class) return String; -- Returns wrapper name. function Parameters (M : Object'class) return SOAP.Parameters.List; -- Returns the parameter. procedure Set_Name_Space (M : in out Object'Class; Name : String); -- Set message's Namespace. procedure Set_Wrapper_Name (M : in out Object'Class; Name : String); -- Set message's wrapper name. procedure Set_Parameters (M : in out Object'Class; P_Set : SOAP.Parameters.List); -- Set message's parameters. private type Object is tagged record Name_Space : Unbounded_String := To_Unbounded_String (Default_Name_Space); Wrapper_Name : Unbounded_String; P : SOAP.Parameters.List; end record; end SOAP.Message; polyorb-2.8~20110207.orig/src/aws/soap-parameters.adb0000644000175000017500000002112311750740337021543 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- S O A P . P A R A M E T E R S -- -- -- -- B o d y -- -- -- -- Copyright (C) 2000-2009, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with Ada.Tags; with Ada.Exceptions; package body SOAP.Parameters is use Ada; --------- -- "&" -- --------- function "&" (P : List; O : Types.Object'Class) return List is NP : List := P; begin NP.N := NP.N + 1; NP.V (NP.N) := Types."+" (O); return NP; end "&"; --------- -- "+" -- --------- function "+" (O : Types.Object'Class) return List is P : List; begin P.V (1) := Types."+" (O); P.N := 1; return P; end "+"; -------------- -- Argument -- -------------- function Argument (P : List; Name : String) return Types.Object'Class is use type Types.Object_Safe_Pointer; begin for K in 1 .. P.N loop if Types.Name (-P.V (K)) = Name then return -P.V (K); end if; end loop; Exceptions.Raise_Exception (Types.Data_Error'Identity, "Argument named '" & Name & "' not found."); end Argument; -------------- -- Argument -- -------------- function Argument (P : List; N : Positive) return Types.Object'Class is use type Types.Object_Safe_Pointer; begin return -P.V (N); end Argument; -------------------- -- Argument_Count -- -------------------- function Argument_Count (P : List) return Natural is begin return P.N; end Argument_Count; ----------- -- Check -- ----------- procedure Check (P : List; N : Natural) is begin if P.N /= N then Exceptions.Raise_Exception (Types.Data_Error'Identity, "(check) Too many arguments."); end if; end Check; ----------------- -- Check_Array -- ----------------- procedure Check_Array (P : List; Name : String) is O : constant Types.Object'Class := Argument (P, Name); begin if O not in Types.SOAP_Array then Exceptions.Raise_Exception (Types.Data_Error'Identity, "(check) SOAP_Array expected, found object " & Ada.Tags.Expanded_Name (O'Tag)); end if; end Check_Array; ------------------ -- Check_Base64 -- ------------------ procedure Check_Base64 (P : List; Name : String) is O : constant Types.Object'Class := Argument (P, Name); begin if O not in Types.SOAP_Base64 then Exceptions.Raise_Exception (Types.Data_Error'Identity, "(check) SOAP_Base64 expected, found object " & Ada.Tags.Expanded_Name (O'Tag)); end if; end Check_Base64; ------------------- -- Check_Boolean -- ------------------- procedure Check_Boolean (P : List; Name : String) is O : constant Types.Object'Class := Argument (P, Name); begin if O not in Types.XSD_Boolean then Exceptions.Raise_Exception (Types.Data_Error'Identity, "(check) XSD_Boolean expected, found object " & Ada.Tags.Expanded_Name (O'Tag)); end if; end Check_Boolean; ----------------- -- Check_Float -- ----------------- procedure Check_Float (P : List; Name : String) is O : constant Types.Object'Class := Argument (P, Name); begin if O not in Types.XSD_Float then Exceptions.Raise_Exception (Types.Data_Error'Identity, "(check) XSD_Float expected, found object " & Ada.Tags.Expanded_Name (O'Tag)); end if; end Check_Float; ------------------- -- Check_Integer -- ------------------- procedure Check_Integer (P : List; Name : String) is O : constant Types.Object'Class := Argument (P, Name); begin if O not in Types.XSD_Integer then Exceptions.Raise_Exception (Types.Data_Error'Identity, "(check) XSD_Integer expected, found object " & Ada.Tags.Expanded_Name (O'Tag)); end if; end Check_Integer; ---------------- -- Check_Null -- ---------------- procedure Check_Null (P : List; Name : String) is O : constant Types.Object'Class := Argument (P, Name); begin if O not in Types.XSD_Null then Exceptions.Raise_Exception (Types.Data_Error'Identity, "(check) XSD_Null expected, found object " & Ada.Tags.Expanded_Name (O'Tag)); end if; end Check_Null; ------------------ -- Check_Record -- ------------------ procedure Check_Record (P : List; Name : String) is O : constant Types.Object'Class := Argument (P, Name); begin if O not in Types.SOAP_Record then Exceptions.Raise_Exception (Types.Data_Error'Identity, "(check) SOAP_Record expected, found object " & Ada.Tags.Expanded_Name (O'Tag)); end if; end Check_Record; ------------------------ -- Check_Time_Instant -- ------------------------ -- procedure Check_Time_Instant (P : List; Name : String) is -- O : Types.Object'Class := Argument (P, Name); -- begin -- if O not in Types.XSD_Time_Instant then -- Exceptions.Raise_Exception -- (Types.Data_Error'Identity, -- "(check) XSD_Time_Instant expected, found object " -- & Ada.Tags.Expanded_Name (O'Tag)); -- end if; -- end Check_Time_Instant; -- As PolyORN does not handles the notion of time data type, this -- has been disabled ----------- -- Exist -- ----------- function Exist (P : List; Name : String) return Boolean is use type Types.Object_Safe_Pointer; begin for K in 1 .. P.N loop if Types.Name (-P.V (K)) = Name then return True; end if; end loop; return False; end Exist; --------- -- Get -- --------- function Get (P : List; Name : String) return Integer is begin return Types.Get (Argument (P, Name)); end Get; function Get (P : List; Name : String) return Long_Float is begin return Types.Get (Argument (P, Name)); end Get; function Get (P : List; Name : String) return String is begin return Types.Get (Argument (P, Name)); end Get; function Get (P : List; Name : String) return Boolean is begin return Types.Get (Argument (P, Name)); end Get; function Get (P : List; Name : String) return Types.SOAP_Base64 is begin return Types.Get (Argument (P, Name)); end Get; function Get (P : List; Name : String) return Types.SOAP_Record is begin return Types.Get (Argument (P, Name)); end Get; function Get (P : List; Name : String) return Types.SOAP_Array is begin return Types.Get (Argument (P, Name)); end Get; end SOAP.Parameters; polyorb-2.8~20110207.orig/src/aws/aws-server.adb0000644000175000017500000004754311750740337020554 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- A W S . S E R V E R -- -- -- -- B o d y -- -- -- -- Copyright (C) 2000-2009, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with Ada.Text_IO; with Ada.Unchecked_Deallocation; with AWS.Config.Set; with AWS.Dispatchers.Callback; with AWS.Messages; with AWS.MIME; with AWS.OS_Lib; with AWS.Session.Control; with AWS.Status; with AWS.Status.Translate_Table; with AWS.Templates; with AWS.Object_Adapter; with PolyORB.Errors; with PolyORB.ORB; with PolyORB.Setup; with PolyORB.Initialization; with PolyORB.Utils.Strings; with PolyORB.Obj_Adapters; with PolyORB.Log; with PolyORB.POA; with PolyORB.POA.Basic_POA; with PolyORB.POA_Policies; with PolyORB.POA_Policies.Request_Processing_Policy.Use_Default_Servant; with PolyORB.POA_Policies.Id_Uniqueness_Policy.Multiple; with PolyORB.POA_Policies.Lifespan_Policy.Persistent; with PolyORB.POA_Policies.Implicit_Activation_Policy.No_Activation; with PolyORB.POA_Policies.Servant_Retention_Policy.Non_Retain; with PolyORB.POA_Manager.Basic_Manager; with PolyORB.POA_Types; package body AWS.Server is use Ada; use PolyORB.Log; package L is new PolyORB.Log.Facility_Log ("aws.server"); procedure O (Message : Standard.String; Level : Log_Level := Debug) renames L.Output; function C (Level : Log_Level := Debug) return Boolean renames L.Enabled; Security_Initialized : Boolean := False; procedure Free is new Ada.Unchecked_Deallocation (Dispatchers.Handler'Class, Dispatchers.Handler_Class_Access); -- protected File_Upload_UID is -- procedure Get (ID : out Natural); -- -- returns a UID for file upload. This is to ensure that files -- -- coming from clients will always have different name. -- private -- UID : Natural := 0; -- end File_Upload_UID; procedure Start (The_Server : in out HTTP'Class; Dispatcher : Dispatchers.Handler'Class); -- Start web server with current configuration. procedure Init_AWS; -- this procedure is called when the personality is started -------------------- -- Initialization -- -------------------- procedure Initialization is use PolyORB.Initialization; use PolyORB.Initialization.String_Lists; use PolyORB.Utils.Strings; use PolyORB.Log.Internals; begin pragma Debug (C, O ("AWS.initialization: initializing PolyORB")); if not Is_Initialized then Initialize_World; end if; -- We initialize PolyORB end Initialization; --------- -- Run -- --------- procedure Run is begin pragma Debug (C, O ("AWS.Server.Run")); PolyORB.ORB.Run (PolyORB.Setup.The_ORB, May_Exit => False); end Run; -------------- -- Init_AWS -- -------------- procedure Init_AWS is begin null; end Init_AWS; protected Counter is procedure Add; -- Add one to the server counter. procedure Remove; -- Removes one to the server counter. entry Zero; -- Accepted only when counter is equal to 0 (no more active server) private C : Natural := 0; end Counter; ------------ -- Config -- ------------ function Config (The_Server : HTTP'Class) return AWS.Config.Object is begin return The_Server.Properties; end Config; ------------- -- Counter -- ------------- protected body Counter is --------- -- Add -- --------- procedure Add is begin C := C + 1; end Add; ------------ -- Remove -- ------------ procedure Remove is begin C := C - 1; end Remove; ---------- -- Zero -- ---------- entry Zero when C = 0 is begin null; end Zero; end Counter; ------------------------------------------ -- Default_Unexpected_Exception_Handler -- ------------------------------------------ procedure Default_Unexpected_Exception_Handler (E : Ada.Exceptions.Exception_Occurrence; Log : in out AWS.Log.Object; Error : Exceptions.Data; Answer : in out Response.Data) is use Ada.Exceptions; use type Templates.Translate_Table; pragma Unreferenced (Log); Fatal_Error_Template : constant String := "500.tmplt"; begin if Error.Fatal then Text_IO.Put_Line (Text_IO.Current_Error, "Fatal error, slot" & Positive'Image (Error.Slot) & " is dead now."); Text_IO.New_Line (Text_IO.Current_Error); Text_IO.Put_Line (Text_IO.Current_Error, Exception_Information (E)); else if AWS.OS_Lib.Is_Regular_File (Fatal_Error_Template) then Answer := Response.Build (MIME.Text_HTML, String'(Templates.Parse (Fatal_Error_Template, Status.Translate_Table (Error.Request) & Templates.Assoc ("EXCEPTION", Exception_Information (E)))), Messages.S500); else Answer := Response.Build (MIME.Text_HTML, "Internal Server Error.
" & "Please, send the following information to the Web " & "Master, thanks.

" & "
" & Exception_Information (E) & "
" & "
", Messages.S500); end if; end if; end Default_Unexpected_Exception_Handler; --------------------- -- File_Upload_UID -- --------------------- -- protected body File_Upload_UID is -- --------- -- -- Get -- -- --------- -- procedure Get (ID : out Natural) is -- begin -- ID := UID; -- UID := UID + 1; -- end Get; -- end File_Upload_UID; --------- -- Set -- --------- procedure Set (The_Server : in out HTTP'Class; Dispatcher : Dispatchers.Handler'Class) is Old : Dispatchers.Handler_Class_Access := The_Server.Dispatcher; begin The_Server.Dispatcher_Sem.Write; The_Server.Dispatcher := new Dispatchers.Handler'Class'(Dispatcher); The_Server.Dispatcher_Sem.Release_Write; Free (Old); end Set; ------------------ -- Set_Security -- ------------------ procedure Set_Security (Certificate_Filename : String) is pragma Warnings (Off); pragma Unreferenced (Certificate_Filename); pragma Warnings (On); begin Security_Initialized := True; -- Net.SSL.Initialize (Certificate_Filename); end Set_Security; -------------------------------------- -- Set_Unexpected_Exception_Handler -- -------------------------------------- procedure Set_Unexpected_Exception_Handler (The_Server : in out HTTP'Class; Handler : Exceptions.Unexpected_Exception_Handler) is begin if The_Server.Shutdown then The_Server.Exception_Handler := Handler; else Ada.Exceptions.Raise_Exception (Constraint_Error'Identity, "Could not change exception handler on the active server."); end if; end Set_Unexpected_Exception_Handler; -------------------------- -- Get_Server_Reference -- -------------------------- function Get_Server_Reference (The_Server : HTTP'Class) return PolyORB.References.Ref is begin return The_Server.Reference; end Get_Server_Reference; -------------- -- Shutdown -- -------------- procedure Shutdown (The_Server : in out HTTP'Class) is begin The_Server.Shutdown := True; if CNF.Session (The_Server.Properties) then Session.Control.Shutdown; end if; -- Close logs, this ensure that all data will be written to the file. Stop_Log (The_Server); Stop_Error_Log (The_Server); -- Server removed Counter.Remove; end Shutdown; ----------- -- Start -- ----------- procedure Start (The_Server : in out HTTP'Class; Name : String; Callback : Response.Callback; Max_Connection : Positive := Default.Max_Connection; Admin_URI : String := Default.Admin_URI; Port : Positive := Default.Server_Port; Security : Boolean := False; Session : Boolean := False; Case_Sensitive_Parameters : Boolean := True; Upload_Directory : String := Default.Upload_Directory; Line_Stack_Size : Positive := Default.Line_Stack_Size) is begin CNF.Set.Server_Name (The_Server.Properties, Name); CNF.Set.Admin_URI (The_Server.Properties, Admin_URI); CNF.Set.Server_Port (The_Server.Properties, Port); CNF.Set.Security (The_Server.Properties, Security); CNF.Set.Session (The_Server.Properties, Session); CNF.Set.Upload_Directory (The_Server.Properties, Upload_Directory); CNF.Set.Max_Connection (The_Server.Properties, Max_Connection); CNF.Set.Line_Stack_Size (The_Server.Properties, Line_Stack_Size); CNF.Set.Case_Sensitive_Parameters (The_Server.Properties, Case_Sensitive_Parameters); Start (The_Server, Dispatchers.Callback.Create (Callback)); end Start; ----------- -- Start -- ----------- procedure Start (The_Server : in out HTTP'Class; Callback : Response.Callback; Config : AWS.Config.Object) is begin The_Server.Properties := Config; Start (The_Server, Dispatchers.Callback.Create (Callback)); end Start; ----------- -- Start -- ----------- procedure Start (The_Server : in out HTTP'Class; Dispatcher : Dispatchers.Handler'Class; Config : AWS.Config.Object) is begin The_Server.Properties := Config; Start (The_Server, Dispatcher); end Start; ----------- -- Start -- ----------- procedure Start (The_Server : in out HTTP'Class; Dispatcher : Dispatchers.Handler'Class) is begin -- If it is an SSL connection, initialize the SSL library if not Security_Initialized and then CNF.Security (The_Server.Properties) then Security_Initialized := True; -- Net.SSL.Initialize (CNF.Certificate); end if; The_Server.Dispatcher := new Dispatchers.Handler'Class'(Dispatcher); -- Started time The_Server.Start_Time := Calendar.Clock; -- Initialize session server. if AWS.Config.Session (The_Server.Properties) then AWS.Session.Control.Start (Session_Check_Interval => CNF.Session_Cleanup_Interval, Session_Lifetime => CNF.Session_Lifetime); end if; Counter.Add; pragma Debug (C, O ("Start: attempting to create a new POA")); declare use PolyORB.POA.Basic_POA; use PolyORB.POA_Policies; use PolyORB.POA_Manager; use PolyORB.POA_Manager.Basic_Manager; use PolyORB.Setup; use PolyORB.Obj_Adapters; The_POA : PolyORB.POA.Obj_Adapter_Access; Root_POA : constant PolyORB.Obj_Adapters.Obj_Adapter_Access := PolyORB.ORB.Object_Adapter (PolyORB.Setup.The_ORB); Error : PolyORB.Errors.Error_Container; Policies : PolicyList; The_POA_Manager : constant Basic_POA_Manager_Access := new Basic_POA_Manager; begin pragma Assert (Root_POA /= null); PolyORB.POA_Policies.Policy_Lists.Append (Policies, PolyORB.POA_Policies.Request_Processing_Policy. Use_Default_Servant.Create.all'Access); -- This is what we need PolyORB.POA_Policies.Policy_Lists.Append (Policies, PolyORB.POA_Policies.Id_Uniqueness_Policy. Multiple.Create.all'Access); -- This is required by Use_Default_Servant PolyORB.POA_Policies.Policy_Lists.Append (Policies, PolyORB.POA_Policies.Lifespan_Policy. Persistent.Create.all'Access); -- To get rid of the ";pf=..." in URIs PolyORB.POA_Policies.Policy_Lists.Append (Policies, PolyORB.POA_Policies.Servant_Retention_Policy. Non_Retain.Create.all'Access); -- To get rid of the ";sys" in URIs PolyORB.POA_Policies.Policy_Lists.Append (Policies, PolyORB.POA_Policies.Implicit_Activation_Policy. No_Activation.Create.all'Access); -- Activation policy is incompatible with Non_Retain, so we -- use No_Activation. pragma Debug (C, O ("Start: set POA policies")); Create (The_POA_Manager); pragma Debug (C, O ("Start: Created a new POA Manager")); PolyORB.POA.Basic_POA.Create_POA (PolyORB.POA.Basic_POA.Basic_Obj_Adapter (Root_POA.all)'Access, CNF.Server_Name (The_Server.Properties), POAManager_Access (The_POA_Manager), Policies, The_POA, Error); The_POA.Adapter_Activator := new Object_Adapter.AWS_AdapterActivator; -- Set an Adapter Activator which will allow to bypass subpath -- errors when looking for the right POA. if PolyORB.Errors.Found (Error) then O ("Start: unable to create new POA", Critical); else pragma Debug (C, O ("Start: a new POA has been created")); PolyORB.POA_Manager.Basic_Manager.Activate (The_POA_Manager, Error); if PolyORB.Errors.Found (Error) then pragma Debug (C, O ("AWS_Init: " & "unable to activate the POA Manager", Critical)); null; end if; PolyORB.POA.Basic_POA.Set_Servant (PolyORB.POA.Basic_POA.Basic_Obj_Adapter (The_POA.all)'Access, The_Server'Unchecked_Access, Error); The_POA.Default_Servant := The_Server'Unchecked_Access; if PolyORB.Errors.Found (Error) then pragma Debug (C, O ("Start: unable to register the servant")); return; else declare use PolyORB.ORB; use PolyORB.POA_Types; Servant_Id : Object_Id_Access; begin Servant_To_Id (PolyORB.POA.Basic_POA.Basic_Obj_Adapter (The_POA.all)'Access, The_Server'Unchecked_Access, Servant_Id, Error); if PolyORB.Errors.Found (Error) then pragma Debug (C, O ("Start: unable to register the servant")); null; else Create_Reference (The_ORB, Servant_Id, "aws", The_Server.Reference); end if; end; end if; end if; end; end Start; --------------------- -- Start_Error_Log -- --------------------- procedure Start_Error_Log (The_Server : in out HTTP'Class; Split_Mode : Log.Split_Mode := Log.None; Filename_Prefix : String := "") is use type AWS.Log.Split_Mode; begin if Split_Mode /= Log.None then CNF.Set.Error_Log_Split_Mode (The_Server.Properties, Log.Split_Mode'Image (Split_Mode)); end if; if Filename_Prefix /= "" then CNF.Set.Error_Log_Filename_Prefix (The_Server.Properties, Filename_Prefix); end if; Log.Start (The_Server.Error_Log, Log.Split_Mode'Value (CNF.Error_Log_Split_Mode (The_Server.Properties)), CNF.Log_File_Directory (The_Server.Properties), CNF.Error_Log_Filename_Prefix (The_Server.Properties)); end Start_Error_Log; --------------- -- Start_Log -- --------------- procedure Start_Log (The_Server : in out HTTP'Class; Split_Mode : Log.Split_Mode := Log.None; Filename_Prefix : String := "") is use type AWS.Log.Split_Mode; begin if Split_Mode /= Log.None then CNF.Set.Log_Split_Mode (The_Server.Properties, Log.Split_Mode'Image (Split_Mode)); end if; if Filename_Prefix /= "" then CNF.Set.Log_Filename_Prefix (The_Server.Properties, Filename_Prefix); end if; Log.Start (The_Server.Log, Log.Split_Mode'Value (CNF.Log_Split_Mode (The_Server.Properties)), CNF.Log_File_Directory (The_Server.Properties), CNF.Log_Filename_Prefix (The_Server.Properties)); end Start_Log; -------------------- -- Stop_Error_Log -- -------------------- procedure Stop_Error_Log (The_Server : in out HTTP'Class) is begin Log.Stop (The_Server.Error_Log); end Stop_Error_Log; -------------- -- Stop_Log -- -------------- procedure Stop_Log (The_Server : in out HTTP'Class) is begin Log.Stop (The_Server.Log); end Stop_Log; ---------- -- Wait -- ---------- procedure Wait (Mode : Termination := No_Server) is begin case Mode is when No_Server => Counter.Zero; when Q_Key_Pressed => declare K : Character; begin loop Text_IO.Get_Immediate (K); exit when K = 'q' or else K = 'Q'; end loop; end; when Forever => loop delay Duration'Last; end loop; end case; end Wait; use PolyORB.Initialization; use PolyORB.Initialization.String_Lists; use PolyORB.Utils.Strings; begin Register_Module (Module_Info' (Name => +"aws", Conflicts => Empty, Depends => +"poa", Provides => Empty, Implicit => False, Init => Init_AWS'Access, Shutdown => null)); end AWS.Server; polyorb-2.8~20110207.orig/src/aws/aws-headers-set.ads0000644000175000017500000000654011750740337021463 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- A W S . H E A D E R S . S E T -- -- -- -- S p e c -- -- -- -- Copyright (C) 2000-2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ package AWS.Headers.Set is procedure Add (Headers : in out List; Name, Value : String); pragma Inline (Add); -- Add HTTP header name/value at the end of the Headers container. Note -- that there is no check about validity of this header. This service is -- provided to be able to create user-defined headers. procedure Update (Headers : in out List; Name : String; Value : String; N : Positive := 1); pragma Inline (Update); -- Update the N-th HTTP header Value with the given Name. -- The header could already have more than one value associated with -- this name. If there is M values with this Name, then if: -- N <= M => update the value -- N = M + 1 => the pair name=value is appended to the table -- N > M + 1 => Constraint_Error raised -- procedure Read (Socket : Net.Socket_Type'Class; Headers : in out List); -- Read and parse HTTP header from the socket. procedure Reset (Headers : in out List); pragma Inline (Reset); -- Removes all object from Headers. Headers will be reinitialized and will -- be ready for new use. procedure Free (Headers : in out List); pragma Inline (Free); -- Release all memory used by the List container. procedure Debug (Activate : Boolean); -- Turn on Debug output. end AWS.Headers.Set; polyorb-2.8~20110207.orig/src/aws/aws-status-set.ads0000644000175000017500000000677011750740337021400 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- A W S . S T A T U S . S E T -- -- -- -- S p e c -- -- -- -- Copyright (C) 2000-2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- This package is used when parsing the HTTP protocol from the client. It is -- used to keep the values for the currently handled HTTP parameters. with SOAP.Message.Payload; package AWS.Status.Set is procedure Reset (D : in out Data); -- Reset the status data for a new use. procedure Free (D : in out Data); -- Free all allocated memory. procedure Keep_Alive (D : in out Data; Flag : Boolean); -- Set the Keep-Alive flag for the current HTTP connection. procedure Session (D : in out Data); -- Generate new Session ID procedure Peername (D : in out Data; Peername : String); -- Set peername field procedure Request (D : in out Data; Method : Request_Method; URI : String; HTTP_Version : String); -- Set values for the request line: -- -- GET URI[?parametrers] [HTTP/1.0 or HTTP/1.1] -- POST URI [HTTP/1.0 or HTTP/1.1] procedure Parameters (D : in out Data; Set : AWS.Parameters.List); -- Associate the parameters in Set to the status data procedure Binary (D : in out Data; Parameter : Stream_Element_Array); -- This procedure is used to store any binary data sent with the -- request. For example this will be used by the PUT method if a binary -- file is sent to the server. procedure Payload (D : in out Data; Payload : SOAP.Message.Payload.Object); -- Set the Payload message. end AWS.Status.Set; polyorb-2.8~20110207.orig/src/aws/aws-object_adapter.ads0000644000175000017500000000504011750740337022217 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- A W S . O B J E C T _ A D A P T E R -- -- -- -- S p e c -- -- -- -- Copyright (C) 2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with PolyORB.Errors; with PolyORB.POA_Types; -- with PolyORB.POA; package AWS.Object_Adapter is use PolyORB.POA_Types; type AWS_AdapterActivator is new PolyORB.POA_Types.AdapterActivator with null record; procedure Unknown_Adapter (Self : access AWS_AdapterActivator; Parent : access Obj_Adapter'Class; Name : String; Result : out Boolean; Error : in out PolyORB.Errors.Error_Container); -- Called by the POA when no appropriate child POA can be found end AWS.Object_Adapter; polyorb-2.8~20110207.orig/src/aws/soap-message-response.adb0000644000175000017500000000517111750740337022665 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- S O A P . M E S S A G E . R E S P O N S E -- -- -- -- B o d y -- -- -- -- Copyright (C) 2000-2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- with AWS.MIME; -- with SOAP.Message.XML; package body SOAP.Message.Response is ---------- -- From -- ---------- function From (P : Message.Payload.Object) return Object is NP : Object; begin Set_Wrapper_Name (NP, Payload.Procedure_Name (P) & "Response"); Set_Parameters (NP, Parameters (P)); Set_Name_Space (NP, Name_Space (P)); return NP; end From; -------------- -- Is_Error -- -------------- function Is_Error (R : Object) return Boolean is pragma Warnings (Off, R); begin return False; end Is_Error; end SOAP.Message.Response; polyorb-2.8~20110207.orig/src/aws/aws-exceptions.ads0000644000175000017500000000656211750740337021444 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- A W S . E X C E P T I O N S -- -- -- -- S p e c -- -- -- -- Copyright (C) 2003-2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with Ada.Exceptions; with AWS.Log; with AWS.Response; with AWS.Status; package AWS.Exceptions is type Data is record Fatal : Boolean; -- If True it means that we go a fatal error. The slot will be -- terminated so AWS will loose one of it's simultaneous connection. -- This is clearly an AWS internal error that should be fixed in AWS. Slot : Positive; -- The failing slot number Request : Status.Data; -- The complete request information that was served when the slot has -- failed. This variable is set only when Fatal is False. end record; type Unexpected_Exception_Handler is access procedure (E : Ada.Exceptions.Exception_Occurrence; Log : in out AWS.Log.Object; Error : Data; Answer : in out Response.Data); -- Unexpected exception handler can be set to monitor server errors. -- Answer can be set with the answer to send back to the client's -- browser. Note that this is possible only for non fatal error -- (i.e. Error.Fatal is False). -- Log is the error log object for the failing server, it can be used -- to log user's information (if error log is activated for this -- server). Note that the server will have already logged information -- about the problem. end AWS.Exceptions; polyorb-2.8~20110207.orig/src/aws/aws-response-set.adb0000644000175000017500000002272711750740337021672 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- A W S . R E S P O N S E . S E T -- -- -- -- B o d y -- -- -- -- Copyright (C) 2002-2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with AWS.Translator; with AWS.Headers.Set; with AWS.Digest; package body AWS.Response.Set is -- procedure Update_Data_From_Header (D : in out Data); -- Update some Data fields from the internal Data header container. -- The Update_Data_From_Header should be called after the complete -- header parsing. ---------------- -- Add_Header -- ---------------- procedure Add_Header (D : in out Data; Name : String; Value : String) is begin Headers.Set.Add (D.Header, Name, Value); end Add_Header; -------------------- -- Authentication -- -------------------- procedure Authentication (D : in out Data; Realm : String; Mode : Authentication_Mode := Basic; Stale : Boolean := False) is N : Positive := 1; -- The index for the update of WWW-Authenticate header values. -- We are not using AWS.Headers.Set.Add routine for add WWW-Authenticate -- header lines, becouse user could call this routine more than once. begin -- In case of Authenticate = Any -- We should create both header lines -- WWW-Authenticate: Basic -- and -- WWW-Authenticate: Digest if Mode = Digest or Mode = Any then Headers.Set.Update (D.Header, Name => Messages.WWW_Authenticate_Token, Value => "Digest qop=""auth"", realm=""" & Realm & """, stale=""" & Boolean'Image (Stale) & """, nonce=""" & AWS.Digest.Create_Nonce & """", N => N); N := N + 1; end if; if Mode = Basic or Mode = Any then Headers.Set.Update (D.Header, Name => Messages.WWW_Authenticate_Token, Value => "Basic realm=""" & Realm & """", N => N); end if; D.Status_Code := Messages.S401; end Authentication; ------------------- -- Cache_Control -- ------------------- procedure Cache_Control (D : in out Data; Value : Messages.Cache_Option) is begin Headers.Set.Update (D.Header, Name => Messages.Cache_Control_Token, Value => String (Value)); end Cache_Control; -------------------- -- Content_Length -- -------------------- procedure Content_Length (D : in out Data; Value : Natural) is begin D.Content_Length := Value; end Content_Length; ------------------ -- Content_Type -- ------------------ procedure Content_Type (D : in out Data; Value : String) is begin Headers.Set.Update (D.Header, Name => Messages.Content_Type_Token, Value => Value); end Content_Type; -------------- -- Filename -- -------------- procedure Filename (D : in out Data; Value : String) is begin D.Filename := To_Unbounded_String (Value); D.Mode := File; D.Content_Length := Integer (Resources.File_Size (Value)); end Filename; -------------- -- Is_Valid -- -------------- function Is_Valid (D : Data) return Boolean is use type Messages.Status_Code; Redirection_Code : Boolean; begin case D.Status_Code is when Messages.S300 | -- Section 10.3.1: Multiple Choices Messages.S301 | -- Section 10.3.2: Moved Permanently Messages.S302 | -- Section 10.3.3: Found Messages.S303 | -- Section 10.3.4: See Other Messages.S305 | -- Section 10.3.6: Use Proxy Messages.S307 -- Section 10.3.8: Temporary Redirect => Redirection_Code := True; when others => Redirection_Code := False; end case; return (Redirection_Code xor not Headers.Exist (D.Header, Messages.Location_Token)) and then (D.Status_Code = Messages.S401 xor not Headers.Exist (D.Header, Messages.WWW_Authenticate_Token)); end Is_Valid; -------------- -- Location -- -------------- procedure Location (D : in out Data; Value : String) is begin Headers.Set.Update (D.Header, Name => Messages.Location_Token, Value => Value); end Location; ------------------ -- Message_Body -- ------------------ procedure Message_Body (D : in out Data; Value : Streams.Stream_Element_Array) is begin Utils.Free (D.Message_Body); D.Message_Body := new Streams.Stream_Element_Array'(Value); D.Content_Length := Value'Length; D.Mode := Message; end Message_Body; procedure Message_Body (D : in out Data; Value : Utils.Stream_Element_Array_Access) is begin Utils.Free (D.Message_Body); D.Message_Body := Value; D.Content_Length := Value'Length; D.Mode := Message; end Message_Body; procedure Message_Body (D : in out Data; Value : String) is begin Message_Body (D, Translator.To_Stream_Element_Array (Value)); end Message_Body; procedure Message_Body (D : in out Data; Value : Strings.Unbounded.Unbounded_String) is begin Message_Body (D, To_String (Value)); end Message_Body; procedure Message_Body (D : in out Data; Value : SOAP.Message.Response.Object) is begin D.SOAP_Message := SOAP.Message.Response.Object'(Value); D.Mode := SOAP_Message; end Message_Body; ---------- -- Mode -- ---------- procedure Mode (D : in out Data; Value : Data_Mode) is begin D.Mode := Value; end Mode; ----------------- -- Read_Header -- ----------------- -- procedure Read_Header -- (Socket : Net.Socket_Type'Class; -- D : in out Data) is -- begin -- pragma Warnings (Off); -- pragma Unreferenced (Socket); -- pragma Warnings (On); -- Headers.Set.Read (Socket, D.Header); -- Update_Data_From_Header (D); -- end Read_Header; ----------------- -- Status_Code -- ----------------- procedure Status_Code (D : in out Data; Value : Messages.Status_Code) is begin D.Status_Code := Value; end Status_Code; ------------ -- Stream -- ------------ procedure Stream (D : in out Data; Handle : Resources.Streams.Stream_Access; Content_Length : Content_Length_Type) is begin D.Stream := Handle; D.Content_Length := Content_Length; D.Mode := Stream; end Stream; ----------------------------- -- Update_Data_From_Header -- ----------------------------- -- procedure Update_Data_From_Header (D : in out Data) is -- Content_Length_Image : constant String -- := Headers.Get (D.Header, Messages.Content_Length_Token); -- begin -- if Content_Length_Image = "" then -- D.Content_Length := Undefined_Length; -- else -- D.Content_Length := Content_Length_Type'Value (Content_Length_Image); -- end if; -- end Update_Data_From_Header; ------------------- -- Update_Header -- ------------------- procedure Update_Header (D : in out Data; Name : String; Value : String; N : Positive := 1) is begin Headers.Set.Update (D.Header, Name, Value, N); end Update_Header; end AWS.Response.Set; polyorb-2.8~20110207.orig/src/aws/aws-server.ads0000644000175000017500000002433511750740337020567 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- A W S . S E R V E R -- -- -- -- S p e c -- -- -- -- Copyright (C) 2000-2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with Ada.Calendar; with Ada.Exceptions; with AWS.Config; with AWS.Default; with AWS.Dispatchers; with AWS.Exceptions; with AWS.Hotplug; with AWS.Log; with AWS.Response; with AWS.Utils; with PolyORB.Servants; with PolyORB.References; package AWS.Server is type HTTP is abstract new PolyORB.Servants.Servant with private; -- A Web server is an abstract servant procedure Run; -- Runs PolyORB procedure Initialization; -- Initializes PolyORB --------------------------- -- Server initialization -- --------------------------- procedure Start (The_Server : in out HTTP'Class; Callback : Response.Callback; Config : AWS.Config.Object); -- Start server using a full configuration object. With this routine it is -- possible to control all features of the server. A simplified version of -- Start is also provided below with the most common options. -- User_Config_Filename is a specific configuration file that will parsed -- after 'aws.ini', 'prognam.ini', '.ini' files. procedure Start (The_Server : in out HTTP'Class; Dispatcher : Dispatchers.Handler'Class; Config : AWS.Config.Object); -- Idem, but using the dispatcher tagged type instead of callback. See -- AWS.Services.Dispatchers and AWS.Dispatchers hierarchies for built-in -- services and interface to build your own dispatcher models. -- Note that a copy of the Dispatcher is keept into Web_Server. Any -- changes done to the Dispatcher object will not be part of the Web -- server dispatcher. procedure Start (The_Server : in out HTTP'Class; Name : String; Callback : Response.Callback; Max_Connection : Positive := Default.Max_Connection; Admin_URI : String := Default.Admin_URI; Port : Positive := Default.Server_Port; Security : Boolean := False; Session : Boolean := False; Case_Sensitive_Parameters : Boolean := True; Upload_Directory : String := Default.Upload_Directory; Line_Stack_Size : Positive := Default.Line_Stack_Size); -- Start the Web server. Max_Connection is the number of simultaneous -- connections the server's will handle (the number of slots in AWS). -- Name is just a string used to identify the server. This is used -- for example in the administrative page. Admin_URI must be set to enable -- the administrative status page. Callback is the procedure to call for -- each resource requested. Port is the Web server port. If Security is -- set to True the server will use an HTTPS/SSL connection. If Session is -- set to True the server will be able to get a status for each client -- connected. A session ID is used for that, on the client side it is a -- cookie. Case_Sensitive_Parameters if set to False it means that the CGI -- parameters name will be handled without case sensitivity. Upload -- directory point to a directory where uploaded files will be stored. ------------------------ -- Server termination -- ------------------------ procedure Shutdown (The_Server : in out HTTP'Class); -- Stop the server and release all associated memory. This routine can -- take some time to terminate because it waits for all tasks to terminate -- properly before releasing the memory. The log facilities will be -- automatically stopped by calling Stop_Log below. type Termination is (No_Server, Q_Key_Pressed, Forever); procedure Wait (Mode : Termination := No_Server); -- The purpose of this procedure is to control the main procedure -- termination. This procedure will return only when no server are running -- (No_Server mode) or the 'q' key has been pressed. If mode is set to -- Forever, Wait will never return and the process will have to be killed. -------------------------- -- Server configuration -- -------------------------- function Config (The_Server : HTTP'Class) return AWS.Config.Object; -- Returns configuration object for The_Server. procedure Set_Unexpected_Exception_Handler (The_Server : in out HTTP'Class; Handler : Exceptions.Unexpected_Exception_Handler); -- Set the unexpected exception handler. It is called whenever an -- unrecoverable error has been detected. The default handler just display -- (on standard output) an error message with the location of the -- error. By changing this handler it is possible to log or display full -- symbolic stack backtrace if needed. procedure Set (The_Server : in out HTTP'Class; Dispatcher : Dispatchers.Handler'Class); -- Dynamically associate a new dispatcher object to the server. With the -- feature it is possible to change server behavior at runtime. The -- complete set of callback procedures will be changed when calling this -- routine. procedure Set_Security (Certificate_Filename : String); -- Set security option for AWS. Certificate_Filename is the name of a file -- containing a certificate and the private key. This must be called -- before starting the first secure server. After that the call will have -- no effect. function Get_Server_Reference (The_Server : HTTP'Class) return PolyORB.References.Ref; -- returns the reference to the server. So the application can -- then convert it into an IOR, URI or whatever. This should be -- called for a running server (i.e. after the Start procedure) ----------------- -- Server Logs -- ----------------- procedure Start_Log (The_Server : in out HTTP'Class; Split_Mode : Log.Split_Mode := Log.None; Filename_Prefix : String := ""); -- Activate server's logging activity. See AWS.Log. procedure Stop_Log (The_Server : in out HTTP'Class); -- Stop server's logging activity. See AWS.Log. procedure Start_Error_Log (The_Server : in out HTTP'Class; Split_Mode : Log.Split_Mode := Log.None; Filename_Prefix : String := ""); -- Activate server's logging activity. See AWS.Log. procedure Stop_Error_Log (The_Server : in out HTTP'Class); -- Stop server's logging activity. See AWS.Log. type HTTP_Access is access all HTTP; private procedure Default_Unexpected_Exception_Handler (E : Ada.Exceptions.Exception_Occurrence; Log : in out AWS.Log.Object; Error : Exceptions.Data; Answer : in out Response.Data); -- Default unexpected exception handler. package CNF renames AWS.Config; ---------- -- HTTP -- ---------- type HTTP is abstract new PolyORB.Servants.Servant with record Self : HTTP_Access := HTTP'Unchecked_Access; -- Point to the record. Reference : PolyORB.References.Ref; -- the reference to the servant Start_Time : Ada.Calendar.Time; -- Date and Time when server was started. Shutdown : Boolean := True; -- True when server is shutdown. This will be set to False when server -- will be started. Properties : CNF.Object := CNF.Get_Current; -- All server properties controled by the configuration file. Log : AWS.Log.Object; -- Loggin support. Error_Log : aliased AWS.Log.Object; -- Error loggin support. Dispatcher : Dispatchers.Handler_Class_Access; -- Dispatcher for the user actions. Dispatcher_Sem : Utils.RW_Semaphore (Writers => 1); -- RW semaphore to be able to change dynamically the Dispatcher object. Filters : Hotplug.Filter_Set; -- Hotplug filters are recorded here. -- Lines : Line_Set_Access; -- The tasks doing the job. -- Slots : Slots_Access; -- Information about each tasks above. This is a protected object to -- support concurrency. Exception_Handler : Exceptions.Unexpected_Exception_Handler := Default_Unexpected_Exception_Handler'Access; -- Exception handle used for unexpected errors found on the server -- implementation. end record; end AWS.Server; polyorb-2.8~20110207.orig/src/aws/soap-parameters.ads0000644000175000017500000001331711750740337021572 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- S O A P . P A R A M E T E R S -- -- -- -- S p e c -- -- -- -- Copyright (C) 2000-2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with SOAP.Types; package SOAP.Parameters is Max_Parameters : constant := 50; -- This is the maximum number of parameters supported by this -- implementation. type List is private; function Argument_Count (P : List) return Natural; -- Returns the number of parameters in P. function Argument (P : List; Name : String) return Types.Object'Class; -- Returns parameters named Name in P. Raises Types.Data_Error if not -- found. function Argument (P : List; N : Positive) return Types.Object'Class; -- Returns Nth parameters in P. Raises Types.Data_Error if not found. function Exist (P : List; Name : String) return Boolean; -- Returns True if parameter named Name exist in P and False otherwise. function Get (P : List; Name : String) return Integer; -- Returns parameter named Name in P as an Integer value. Raises -- Types.Data_Error if this parameter does not exist or is not an Integer. function Get (P : List; Name : String) return Long_Float; -- Returns parameter named Name in P as a Float value. Raises -- Types.Data_Error if this parameter does not exist or is not a Float. function Get (P : List; Name : String) return String; -- Returns parameter named Name in P as a String value. Raises -- Types.Data_Error if this parameter does not exist or is not a String. function Get (P : List; Name : String) return Boolean; -- Returns parameter named Name in P as a Boolean value. Raises -- Types.Data_Error if this parameter does not exist or is not a Boolean. function Get (P : List; Name : String) return Types.SOAP_Base64; -- Returns parameter named Name in P as a SOAP Base64 value. Raises -- Types.Data_Error if this parameter does not exist or is not a SOAP -- Base64. function Get (P : List; Name : String) return Types.SOAP_Record; -- Returns parameter named Name in P as a SOAP Struct value. Raises -- Types.Data_Error if this parameter does not exist or is not a SOAP -- Struct. function Get (P : List; Name : String) return Types.SOAP_Array; -- Returns parameter named Name in P as a SOAP Array value. Raises -- Types.Data_Error if this parameter does not exist or is not a SOAP -- Array. ------------------ -- Constructors -- ------------------ function "&" (P : List; O : Types.Object'Class) return List; function "+" (O : Types.Object'Class) return List; ---------------- -- Validation -- ---------------- procedure Check (P : List; N : Natural); -- Checks that there is exactly N parameters or raise Types.Data_Error. procedure Check_Integer (P : List; Name : String); -- Checks that parameter named Name exist and is an Integer value. procedure Check_Float (P : List; Name : String); -- Checks that parameter named Name exist and is a Float value. procedure Check_Boolean (P : List; Name : String); -- Checks that parameter named Name exist and is a Boolean value. -- procedure Check_Time_Instant (P : List; Name : String); -- Checks that parameter named Name exist and is a Time_Instant value. procedure Check_Base64 (P : List; Name : String); -- Checks that parameter named Name exist and is a Base64 value. procedure Check_Null (P : List; Name : String); -- Checks that parameter named Name exist and is a Null value. procedure Check_Record (P : List; Name : String); -- Checks that parameter named Name exist and is a Record value. procedure Check_Array (P : List; Name : String); -- Checks that parameter named Name exist and is an Array value. private pragma Inline (Get); type List is record V : Types.Object_Set (1 .. Max_Parameters); N : Natural := 0; end record; end SOAP.Parameters; polyorb-2.8~20110207.orig/src/aws/aws-headers-set.adb0000644000175000017500000001337111750740337021442 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- A W S . H E A D E R S . S E T -- -- -- -- B o d y -- -- -- -- Copyright (C) 2000-2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- with Ada.Strings.Fixed; -- with Ada.Text_IO; with AWS.Containers.Tables.Set; -- with AWS.Net.Buffered; package body AWS.Headers.Set is use AWS.Containers; subtype P_List is Tables.Table_Type; Debug_Flag : Boolean := False; -- Set to True to output debug information to the standard output. --------- -- Add -- --------- procedure Add (Headers : in out List; Name, Value : String) is begin Tables.Set.Add (P_List (Headers), Name, Value); end Add; ----------- -- Debug -- ----------- procedure Debug (Activate : Boolean) is begin Debug_Flag := not Debug_Flag; -- just to lure the compiler Debug_Flag := Activate; end Debug; ---------- -- Free -- ---------- procedure Free (Headers : in out List) is begin Tables.Set.Free (P_List (Headers)); end Free; ---------- -- Read -- ---------- -- procedure Read (Socket : Net.Socket_Type'Class; Headers : in out List) -- is -- procedure Parse_Header_Lines (Line : String); -- -- Parse the Line eventually catenated with the next line if it is a -- -- continuation line see [RFC 2616 - 4.2]. -- ------------------------ -- -- Parse_Header_Lines -- -- ------------------------ -- procedure Parse_Header_Lines (Line : String) is -- End_Of_Message : constant String := ""; -- begin -- if Line = End_Of_Message then -- return; -- else -- declare -- use Ada.Strings; -- Next_Line : constant String -- := Net.Buffered.Get_Line (Socket); -- Delimiter_Index : Natural; -- begin -- if Next_Line /= End_Of_Message -- and then -- (Next_Line (1) = ' ' or else Next_Line (1) = ASCII.HT) -- then -- -- Continuing value on the next line. Header fields can be -- -- extended over multiple lines by preceding each extra -- -- line with at least one SP or HT. -- Parse_Header_Lines (Line & Next_Line); -- else -- if Debug_Flag then -- Ada.Text_IO.Put_Line ('>' & Line); -- end if; -- -- Put name and value to the container separately. -- Delimiter_Index := Fixed.Index (Line, ":"); -- if Delimiter_Index = 0 then -- -- No delimiter, this is not a valid Header Line -- raise Format_Error; -- end if; -- Add (Headers, -- Name => Line (Line'First .. Delimiter_Index - 1), -- Value => Fixed.Trim -- (Line (Delimiter_Index + 1 .. Line'Last), -- Side => Both)); -- -- Parse next header line. -- Parse_Header_Lines (Next_Line); -- end if; -- end; -- end if; -- end Parse_Header_Lines; -- begin -- Reset (Headers); -- Parse_Header_Lines (Net.Buffered.Get_Line (Socket)); -- end Read; ----------- -- Reset -- ----------- procedure Reset (Headers : in out List) is begin Tables.Set.Reset (P_List (Headers)); Tables.Set.Case_Sensitive (P_List (Headers), False); end Reset; ------------ -- Update -- ------------ procedure Update (Headers : in out List; Name : String; Value : String; N : Positive := 1) is begin Tables.Set.Update (P_List (Headers), Name, Value, N); end Update; end AWS.Headers.Set; polyorb-2.8~20110207.orig/src/aws/aws-headers.adb0000644000175000017500000000744111750740337020652 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- A W S . H E A D E R S -- -- -- -- B o d y -- -- -- -- Copyright (C) 2000-2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- to be changed, as we use aws.net.* with Ada.Strings.Unbounded; -- with AWS.Net.Buffered; package body AWS.Headers is -------------- -- Get_Line -- -------------- function Get_Line (Headers : List; N : Positive) return String is Pair : constant Element := Get (Headers, N); begin if Pair.Name = "" then return ""; else return Pair.Name & ": " & Pair.Value; end if; end Get_Line; ---------------- -- Get_Values -- ---------------- function Get_Values (Headers : List; Name : String) return String is Values : constant VString_Array := Get_Values (Headers, Name); function Get_Values (Start_From : Positive) return String; -- Return string of header values comma separated -- concateneted starting from Start_From index. ---------------- -- Get_Values -- ---------------- function Get_Values (Start_From : Positive) return String is Value : constant String := Ada.Strings.Unbounded.To_String (Values (Start_From)); begin if Start_From = Values'Last then return Value; else return Value & ", " & Get_Values (Start_From + 1); end if; end Get_Values; begin if Values'Length > 0 then return Get_Values (Values'First); else return ""; end if; end Get_Values; ----------------- -- Send_Header -- ----------------- -- procedure Send_Header -- (Socket : Net.Socket_Type'Class; -- Headers : List) is -- begin -- for J in 1 .. Count (Headers) loop -- Net.Buffered.Put_Line (Socket, Get_Line (Headers, J)); -- end loop; -- end Send_Header; end AWS.Headers; polyorb-2.8~20110207.orig/src/aws/aws-headers-values.adb0000644000175000017500000003302311750740337022142 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- A W S . H E A D E R S . V A L U E S -- -- -- -- B o d y -- -- -- -- Copyright (C) 2002-2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with Ada.Exceptions; with Ada.Strings.Fixed; with Ada.Strings.Maps.Constants; package body AWS.Headers.Values is use Ada.Strings; Spaces : constant Maps.Character_Set := Maps.To_Set (' ' & ASCII.HT & ASCII.LF & ASCII.CR); -- Set of spaces to ignore during parsing procedure Next_Value (Data : String; First : in out Natural; Name_First : out Positive; Name_Last : out Natural; Value_First : out Positive; Value_Last : out Natural); -- Returns the next named or un-named value from Data. It start the search -- from First index. Returns First = 0 if it has reached the end of -- Data. Returns Name_Last = 0 if an un-named value has been found. ----------------------- -- Get_Unnamed_Value -- ----------------------- function Get_Unnamed_Value (Header_Value : String; N : Positive := 1) return String is First : Natural; Name_First : Positive; Name_Last : Natural; Value_First : Positive; Value_Last : Natural; Count : Natural := 0; begin First := Fixed.Index (Source => Header_Value, Set => Spaces, Test => Outside); if First = 0 then -- Value is empty or contains only spaces return ""; end if; loop Next_Value (Header_Value, First, Name_First, Name_Last, Value_First, Value_Last); if Name_Last = 0 then Count := Count + 1; if Count = N then return Header_Value (Value_First .. Value_Last); end if; end if; exit when First = 0; end loop; -- There is not such value, return the empty string return ""; end Get_Unnamed_Value; ------------ -- Index -- ------------ function Index (Set : Values.Set; Name : String; Case_Sensitive : Boolean := True) return Natural is Map : Maps.Character_Mapping; M_Name : Unbounded_String; begin if Case_Sensitive then Map := Maps.Identity; M_Name := To_Unbounded_String (Name); else Map := Maps.Constants.Upper_Case_Map; M_Name := Translate (To_Unbounded_String (Name), Map); end if; for I in Set'Range loop if Set (I).Named_Value and then Translate (Set (I).Name, Map) = M_Name then return I; end if; end loop; -- Name was not found, return 0 return 0; end Index; ---------------- -- Next_Value -- ---------------- procedure Next_Value (Data : String; First : in out Natural; Name_First : out Positive; Name_Last : out Natural; Value_First : out Positive; Value_Last : out Natural) is EDel : constant Maps.Character_Set := Maps.To_Set (",;"); -- Delimiter between name/value pairs in the HTTP header lines. -- In WWW-Authenticate, header delimiter between name="Value" -- pairs is a comma. -- In the Set-Cookie header, value delimiter between name="Value" -- pairs is a semi-colon. UVDel : constant Character := ' '; -- Delimiter of the un-named value NVDel : constant Character := '='; -- Delimiter between name and Value for a named value VDel : constant Maps.Character_Set := Maps.To_Set (UVDel & NVDel); -- Delimiter between name and value is '=' and it is a space between -- un-named values. Last : Natural; begin Last := Fixed.Index (Data (First .. Data'Last), VDel); Name_Last := 0; if Last = 0 then -- This is the last single value. Value_First := First; Value_Last := Data'Last; First := 0; -- Mean end of line elsif Data (Last) = UVDel then -- This is an un-named value Value_First := First; Value_Last := Last - 1; First := Last + 1; -- Do not return the delimiter as part of the value while Maps.Is_In (Data (Value_Last), EDel) loop Value_Last := Value_Last - 1; end loop; else -- Here we have a named value Name_First := First; Name_Last := Last - 1; First := Last + 1; -- Check if this is a quoted or unquoted value if First < Data'Last and then Data (First) = '"' then -- Quoted value Value_First := First + 1; Last := Fixed.Index (Data (Value_First .. Data'Last), """"); if Last = 0 then -- Format error as there is no closing quote Ada.Exceptions.Raise_Exception (Format_Error'Identity, "HTTP header line format error : " & Data); else Value_Last := Last - 1; end if; First := Last + 2; else -- Unquoted value Value_First := First; Last := Ada.Strings.Fixed.Index (Data (First .. Data'Last), EDel); if Last = 0 then Value_Last := Data'Last; First := 0; else Value_Last := Last - 1; First := Last + 1; end if; end if; end if; if First > Data'Last then -- We have reached the end-of-line First := 0; elsif First > 0 then -- Ignore the next leading spaces First := Fixed.Index (Source => Data (First .. Data'Last), Set => Spaces, Test => Outside); end if; end Next_Value; ----------- -- Parse -- ----------- procedure Parse (Header_Value : String) is First : Natural; Name_First : Positive; Name_Last : Natural; Value_First : Positive; Value_Last : Natural; Quit : Boolean; begin -- Ignore the leading spaces First := Fixed.Index (Source => Header_Value, Set => Spaces, Test => Outside); if First = 0 then -- Value is empty or contains only spaces return; end if; loop Next_Value (Header_Value, First, Name_First, Name_Last, Value_First, Value_Last); Quit := False; if Name_Last > 0 then Named_Value (Header_Value (Name_First .. Name_Last), Header_Value (Value_First .. Value_Last), Quit); else Value (Header_Value (Value_First .. Value_Last), Quit); end if; exit when Quit or else First = 0; end loop; end Parse; ------------ -- Search -- ------------ function Search (Header_Value : String; Name : String; Case_Sensitive : Boolean := True) return String is First : Natural; Name_First : Positive; Name_Last : Natural; Value_First : Positive; Value_Last : Natural; Map : Maps.Character_Mapping; M_Name : String (Name'Range); -- Mapped name begin First := Fixed.Index (Source => Header_Value, Set => Spaces, Test => Outside); if First = 0 then -- Value is empty or contains only spaces return ""; end if; if Case_Sensitive then Map := Maps.Identity; M_Name := Name; else Map := Maps.Constants.Upper_Case_Map; M_Name := Fixed.Translate (Name, Map); end if; loop Next_Value (Header_Value, First, Name_First, Name_Last, Value_First, Value_Last); if Name_Last > 0 and then M_Name = Fixed.Translate (Header_Value (Name_First .. Name_Last), Map) then return Header_Value (Value_First .. Value_Last); end if; exit when First = 0; end loop; -- Name not found, returns the empty string return ""; end Search; ----------- -- Split -- ----------- function Split (Header_Value : String) return Set is First : Natural; Null_Set : Set (1 .. 0); function To_Set return Set; -- Parse the Header_Value and return a set of named and un-named -- value. Note that this routine is recursive as the final Set size is -- not known. This should not be a problem as the number of token on an -- Header_Line is quite small. ------------ -- To_Set -- ------------ function To_Set return Set is Name_First : Positive; Name_Last : Natural; Value_First : Positive; Value_Last : Natural; function Element return Data; -- Returns the Data element from the substrings defined by -- Name_First, Name_Last, Value_First, Value_Last. ------------- -- Element -- ------------- function Element return Data is function "+" (Item : String) return Unbounded_String renames To_Unbounded_String; begin if Name_Last = 0 then return Data' (Named_Value => False, Value => +Header_Value (Value_First .. Value_Last)); else return Data' (True, Name => +Header_Value (Name_First .. Name_Last), Value => +Header_Value (Value_First .. Value_Last)); end if; end Element; begin if First = 0 then -- This is the end of recursion. return Null_Set; end if; Next_Value (Header_Value, First, Name_First, Name_Last, Value_First, Value_Last); return Element & To_Set; end To_Set; begin First := Fixed.Index (Source => Header_Value, Set => Spaces, Test => Outside); return To_Set; end Split; -------------------------- -- Unnamed_Value_Exists -- -------------------------- function Unnamed_Value_Exists (Header_Value : String; Value : String; Case_Sensitive : Boolean := True) return Boolean is First : Natural; Name_First : Positive; Name_Last : Natural; Value_First : Positive; Value_Last : Natural; Map : Maps.Character_Mapping; M_Value : String (Value'Range); begin First := Fixed.Index (Source => Header_Value, Set => Spaces, Test => Outside); if First = 0 then -- Value is empty or contains only spaces return False; end if; if Case_Sensitive then Map := Maps.Identity; M_Value := Value; else Map := Maps.Constants.Upper_Case_Map; M_Value := Fixed.Translate (Value, Map); end if; loop Next_Value (Header_Value, First, Name_First, Name_Last, Value_First, Value_Last); if Name_Last = 0 and then M_Value = Fixed.Translate (Header_Value (Value_First .. Value_Last), Map) then return True; end if; exit when First = 0; end loop; -- There is not such value return False; end Unnamed_Value_Exists; end AWS.Headers.Values; polyorb-2.8~20110207.orig/src/aws/soap-message-response-error.ads0000644000175000017500000000651611750740337024041 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- S O A P . M E S S A G E . R E S P O N S E . E R R O R -- -- -- -- S p e c -- -- -- -- Copyright (C) 2000-2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with SOAP.Message.Payload; with SOAP.Message.Response; package SOAP.Message.Response.Error is type Object is new Message.Response.Object with private; type Faultcode is new String; function From (P : Message.Payload.Object) return Object; -- Build an Error response from a Payload object. function XML_Image (E : Object) return Unbounded_String; -- Returns the Fault env and associated data (faultcode, faultstring...). function Build (Faultcode : Error.Faultcode; Faultstring : String) return Object; -- Returns an Error object built using Faultcode and Faultstring. function Is_Error (E : Object) return Boolean; -- Always returns True. This overrides Response.Object's method. ----------------- -- Fault Codes -- ----------------- function Version_Mismatch (Subname : String := "") return Faultcode; -- Returns the Version_Mismatch faultcode. function Must_Understand (Subname : String := "") return Faultcode; -- Returns the Must_Understand faultcode. function Client (Subname : String := "") return Faultcode; -- Returns the Client faultcode. function Server (Subname : String := "") return Faultcode; -- Returns the Server faultcode. private type Object is new Message.Response.Object with null record; end SOAP.Message.Response.Error; polyorb-2.8~20110207.orig/src/aws/aws-response.ads0000644000175000017500000002652011750740337021115 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- A W S . R E S P O N S E -- -- -- -- S p e c -- -- -- -- Copyright (C) 2000-2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- This package is to be used to build answer to be sent to the client -- browser. with Ada.Strings.Unbounded; with Ada.Streams; with Ada.Finalization; with AWS.Headers; with AWS.Status; with AWS.Messages; with AWS.MIME; -- with AWS.Net; with AWS.Resources.Streams; with AWS.Utils; with SOAP.Message.Response; package AWS.Response is use Ada; type Data is private; -- Note that this type use a reference counter which is not thread safe. type Data_Access is access all Data; type Data_Mode is (Header, Message, File, Stream, Socket_Taken, No_Data, SOAP_Message); type Authentication_Mode is (Any, Basic, Digest); -- The authentication mode. -- "Basic" and "Digest" mean that server must accept the requested -- authentication mode. "Any" mean that server could accept any -- authentication from client. -- Note the order here should not be changed as it is used in AWS.Client. subtype Content_Length_Type is Integer range -1 .. Integer'Last; Undefined_Length : constant Content_Length_Type; -- Undefined length could be used when we do not know the message length -- at the start of transfer. The end of message could be determined by the -- chunked transfer-encoding in the HTTP/1.1, or by the closing connection -- in the HTTP/1.0. Default_Moved_Message : constant String := "Page moved
Click here"; -- This is a template message, _@_ will be replaced by the Location (see -- function Build with Location below). ------------------ -- Constructors -- ------------------ function Build (Content_Type : String; Message_Body : String; Status_Code : Messages.Status_Code := Messages.S200; Cache_Control : Messages.Cache_Option := Messages.Unspecified) return Data; function Build (Content_Type : String; UString_Message : Strings.Unbounded.Unbounded_String; Status_Code : Messages.Status_Code := Messages.S200; Cache_Control : Messages.Cache_Option := Messages.Unspecified) return Data; -- Return a message whose body is passed into Message_Body. The -- Content_Type parameter is the MIME type for the message -- body. Status_Code is the response status (see Messages.Status_Code -- definition). function Build (Content_Type : String; Message_Body : Streams.Stream_Element_Array; Status_Code : Messages.Status_Code := Messages.S200; Cache_Control : Messages.Cache_Option := Messages.Unspecified) return Data; -- Idem above, but the message body is a stream element array. function Build (SOAP_Body : SOAP.Message.Response.Object) return Data; -- new function to build a soap response function URL (Location : String) return Data; -- This ask the server for a redirection to the specified URL. function Moved (Location : String; Message : String := Default_Moved_Message) return Data; -- This send back a moved message (Messages.S301) with the specified -- message body. function Acknowledge (Status_Code : Messages.Status_Code; Message_Body : String := ""; Content_Type : String := MIME.Text_HTML) return Data; -- Returns a message to the Web browser. This routine must be used to -- send back an error message to the Web browser. For example if a -- requested resource cannot be served a message with status code S404 -- must be sent. function Authenticate (Realm : String; Mode : Authentication_Mode := Basic; Stale : Boolean := False) return Data; -- Returns an authentification message (Messages.S401), the Web browser -- will then ask for an authentification. Realm string will be displayed -- by the Web Browser in the authentification dialog box. function File (Content_Type : String; Filename : String; Status_Code : Messages.Status_Code := Messages.S200) return Data; -- Returns a message whose message body is the content of the file. The -- Content_Type must indicate the MIME type for the file. function Stream (Content_Type : String; Stream_Handle : Resources.Streams.Stream_Access; Stream_Size : Content_Length_Type := Undefined_Length; Status_Code : Messages.Status_Code := Messages.S200; Cache_Control : Messages.Cache_Option := Messages.No_Cache) return Data; -- Returns a message whose message body is the content of the user -- defined stream. The Content_Type must indicate the MIME type for -- the data stream, Stream_Size the total number of bytes and Status_Code -- the header status code which should be send back to client's browser. function Socket_Taken return Data; -- Must be used to say that the connection socket has been taken by user -- inside of user callback. No operations should be performed on this -- socket, and associated slot should be released for further operations. function Empty return Data; -- Returns an empty message (Data_Mode = No_Data and Status_Code is 204). -- It is used to say that user's handlers were not able to do something -- with the request. This is used by the callback's chain in the -- dispatcher and should not be used by users. --------------- -- Other API -- --------------- function Header (D : Data; Name : String; N : Positive) return String; pragma Inline (Header); -- Return the N-th value for header Name. function Header (D : Data; Name : String) return String; pragma Inline (Header); -- Return all values as a comma-separated string for header Name. -- See [RFC 2616 - 4.2] last paragraph. -- procedure Send_Header (Socket : Net.Socket_Type'Class; D : Data); -- pragma Inline (Send_Header); -- Send all header lines to the socket. function Mode (D : Data) return Data_Mode; pragma Inline (Mode); -- Returns the data mode, either Header, Message or File. function Authentication (D : Data) return Authentication_Mode; pragma Inline (Authentication); -- Returns the authentication mode requested by server. function Authentication_Stale (D : Data) return Boolean; pragma Inline (Authentication_Stale); -- Returns the stale parameter for authentication. function Status_Code (D : Data) return Messages.Status_Code; pragma Inline (Status_Code); -- Returns the status code. function Content_Length (D : Data) return Content_Length_Type; pragma Inline (Content_Length); -- Returns the content length (i.e. the message body length). A value of 0 -- indicate that there is no message body. function Content_Type (D : Data) return String; pragma Inline (Content_Type); -- Returns the MIME type for the message body. function Cache_Control (D : Data) return Messages.Cache_Option; pragma Inline (Cache_Control); -- Returns the cache control specified for the response function Filename (D : Data) return String; pragma Inline (Filename); -- Returns the filename which should be sent back. function Location (D : Data) return String; pragma Inline (Location); -- Returns the location for the new page in the case of a moved -- message. See Moved constructor above. function Message_Body (D : Data) return String; pragma Inline (Message_Body); -- Returns the message body content as a string. function Message_Body (D : Data) return Strings.Unbounded.Unbounded_String; pragma Inline (Message_Body); -- Returns the message body content as a unbounded_string. function Message_Body (D : Data) return Streams.Stream_Element_Array; pragma Inline (Message_Body); -- Returns message body as a binary content. function SOAP_Message (D : Data) return SOAP.Message.Response.Object; pragma Inline (SOAP_Message); -- returns the soap objects carried by D procedure Create_Resource (File : out AWS.Resources.File_Type; D : Data); pragma Inline (Create_Resource); -- Creates the resource object (either a file or in-memory object) for -- the data to be sent to the client. The resource should be closed after -- use. function Realm (D : Data) return String; pragma Inline (Realm); -- Returns the Realm for the current authentification request. type Callback is access function (Request : Status.Data) return Data; -- This is the Web Server Callback procedure. A client must declare and -- pass such procedure to the HTTP record. private use Ada.Strings.Unbounded; Undefined_Length : constant Content_Length_Type := -1; type Natural_Access is access Natural; type Data is new Ada.Finalization.Controlled with record Ref_Counter : Natural_Access; Mode : Data_Mode := No_Data; Status_Code : Messages.Status_Code := Messages.S200; Content_Length : Content_Length_Type := 0; Filename : Unbounded_String; Stream : Resources.Streams.Stream_Access; Message_Body : Utils.Stream_Element_Array_Access; SOAP_Message : SOAP.Message.Response.Object; -- new field Header : AWS.Headers.List; end record; procedure Initialize (Object : in out Data); procedure Adjust (Object : in out Data); procedure Finalize (Object : in out Data); end AWS.Response; polyorb-2.8~20110207.orig/src/aws/soap-types.ads0000644000175000017500000002635311750740337020577 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- S O A P . T Y P E S -- -- -- -- S p e c -- -- -- -- Copyright (C) 2002-2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with Ada.Strings.Unbounded; with Ada.Finalization; with PolyORB.Any; package SOAP.Types is Data_Error : exception; -- Raised when a variable has not the expected type. type Object is abstract tagged private; type Object_Access is access all Object'Class; type Object_Safe_Pointer is tagged private; type Object_Set is array (Positive range <>) of Object_Safe_Pointer; function Image (O : Object) return String; -- Returns O value image. function XML_Image (O : Object) return String; -- Returns O value encoded for use by the Payload object or Response -- object. function To_NamedValue (O : Object'Class) return PolyORB.Any.NamedValue; -- general function that converts a SOAP object into a -- NamedValue. It calls To_Any to convert data function From_NamedValue (NV : PolyORB.Any.NamedValue) return Object'Class; -- general function that converts a PolyORB NamedValue into a SOAP -- object. It calls To_Any to convert data function To_Any (Obj : Object'Class) return PolyORB.Any.Any; -- general function that converts a SOAP object into a PolyORB Any function From_Any (Item : PolyORB.Any.Any) return Object_Access; -- general function that converts a PolyORB Any into a SOAP -- object, the name of which is set to "item" function XML_Type (O : Object) return String; -- Returns the XML type for the object. function Name (O : Object'Class) return String; -- Returns name for object O. function "+" (O : Object'Class) return Object_Safe_Pointer; -- Allocate an object into the heap and return a safe pointer to it. function "-" (O : Object_Safe_Pointer) return Object'Class; -- Returns the object associated with the safe pointer. type Scalar is abstract new Object with private; -- Scalar types are using a by-copy semantic. type Composite is abstract new Object with private; -- Composite types are using a by-reference semantic for efficiency -- reason. Not that these types are not thread safe. ------------- -- Integer -- ------------- XML_Int : constant String := "xsd:int"; type XSD_Integer is new Scalar with private; function Image (O : XSD_Integer) return String; function XML_Image (O : XSD_Integer) return String; function XML_Type (O : XSD_Integer) return String; function I (V : Integer; Name : String := "item") return XSD_Integer; function V (O : XSD_Integer) return Integer; ----------- -- Float -- ----------- XML_Float : constant String := "xsd:float"; type XSD_Float is new Scalar with private; function Image (O : XSD_Float) return String; function XML_Image (O : XSD_Float) return String; function XML_Type (O : XSD_Float) return String; function F (V : Long_Float; Name : String := "item") return XSD_Float; function V (O : XSD_Float) return Long_Float; ------------ -- String -- ------------ XML_String : constant String := "xsd:string"; type XSD_String is new Scalar with private; function Image (O : XSD_String) return String; function XML_Image (O : XSD_String) return String; function XML_Type (O : XSD_String) return String; function S (V : String; Name : String := "item"; Encode : Boolean := True) return XSD_String; function V (O : XSD_String) return String; ------------- -- Boolean -- ------------- XML_Boolean : constant String := "xsd:boolean"; type XSD_Boolean is new Scalar with private; function Image (O : XSD_Boolean) return String; function XML_Image (O : XSD_Boolean) return String; function XML_Type (O : XSD_Boolean) return String; function B (V : Boolean; Name : String := "item") return XSD_Boolean; function V (O : XSD_Boolean) return Boolean; ----------------- -- TimeInstant -- ----------------- -- XML_Time_Instant : constant String := "xsd:timeInstant"; -- -- type XSD_Time_Instant is new Scalar with private; -- -- function Image (O : XSD_Time_Instant) return String; -- function XML_Image (O : XSD_Time_Instant) return String; -- function XML_Type (O : XSD_Time_Instant) return String; -- -- subtype TZ is Integer range -11 .. +11; -- GMT : constant TZ := 0; -- -- function T -- (V : Ada.Calendar.Time; -- Name : String := "item"; -- Timezone : TZ := GMT) -- return XSD_Time_Instant; -- function V (O : XSD_Time_Instant) return Ada.Calendar.Time; -- Returns a GMT date and time. -- TimeInstant has been disabled, since PolyORB does not have any -- time data type for now. ---------- -- Null -- ---------- XML_Null : constant String := "1"; type XSD_Null is new Scalar with private; function XML_Image (O : XSD_Null) return String; function XML_Type (O : XSD_Null) return String; function N (Name : String := "item") return XSD_Null; ------------ -- Base64 -- ------------ XML_Base64 : constant String := "SOAP-ENC:base64"; type SOAP_Base64 is new Scalar with private; function Image (O : SOAP_Base64) return String; function XML_Image (O : SOAP_Base64) return String; function XML_Type (O : SOAP_Base64) return String; function B64 (V : String; Name : String := "item") return SOAP_Base64; function V (O : SOAP_Base64) return String; ----------- -- Array -- ----------- XML_Array : constant String := "SOAP-ENC:Array"; XML_Undefined : constant String := "xsd:ur-type"; type SOAP_Array is new Composite with private; function Image (O : SOAP_Array) return String; function XML_Image (O : SOAP_Array) return String; function XML_Type (O : SOAP_Array) return String; function A (V : Object_Set; Name : String) return SOAP_Array; function Size (O : SOAP_Array) return Natural; -- Returns the number of item into the array function V (O : SOAP_Array; N : Positive) return Object'Class; -- Returns SOAP_Array item at position N function V (O : SOAP_Array) return Object_Set; ------------ -- Record -- ------------ type SOAP_Record is new Composite with private; function Image (O : SOAP_Record) return String; function XML_Image (O : SOAP_Record) return String; function XML_Type (O : SOAP_Record) return String; function R (V : Object_Set; Name : String) return SOAP_Record; function V (O : SOAP_Record; Name : String) return Object'Class; -- Returns SOAP_Record field named Name function V (O : SOAP_Record) return Object_Set; --------- -- Get -- --------- function Get (O : Object'Class) return Integer; -- Returns O value as an Integer. Raises Data_Error if O is not a SOAP -- Integer. function Get (O : Object'Class) return Long_Float; -- Returns O value as an Integer. Raises Data_Error if O is not a SOAP -- Float. function Get (O : Object'Class) return String; -- Returns O value as a String. Raises Data_Error if O is not a SOAP -- String. function Get (O : Object'Class) return Boolean; -- Returns O value as a Boolean. Raises Data_Error if O is not a SOAP -- Boolean. function Get (O : Object'Class) return SOAP_Base64; -- Returns O value as a SOAP Base64. Raises Data_Error if O is not a SOAP -- Base64 object. function Get (O : Object'Class) return SOAP_Record; -- Returns O value as a SOAP Struct. Raises Data_Error if O is not a SOAP -- Struct. function Get (O : Object'Class) return SOAP_Array; -- Returns O value as a SOAP Array. Raises Data_Error if O is not a SOAP -- Array. private use Ada.Strings.Unbounded; type Object_Safe_Pointer is new Ada.Finalization.Controlled with record O : Object_Access; end record; procedure Adjust (O : in out Object_Safe_Pointer); pragma Inline (Adjust); procedure Finalize (O : in out Object_Safe_Pointer); pragma Inline (Finalize); type Object is abstract new Ada.Finalization.Controlled with record Name : Unbounded_String; end record; type Scalar is abstract new Object with null record; type Counter_Access is access Natural; type Object_Set_Access is access Object_Set; type Composite is abstract new Object with record Ref_Counter : Counter_Access; O : Object_Set_Access; end record; procedure Initialize (O : in out Composite); pragma Inline (Initialize); procedure Adjust (O : in out Composite); pragma Inline (Adjust); procedure Finalize (O : in out Composite); pragma Inline (Finalize); type XSD_Integer is new Scalar with record V : Integer; end record; type XSD_Float is new Scalar with record V : Long_Float; end record; type XSD_String is new Scalar with record V : Unbounded_String; end record; type XSD_Boolean is new Scalar with record V : Boolean; end record; -- type XSD_Time_Instant is new Scalar with record -- T : Ada.Calendar.Time; -- Timezone : TZ; -- end record; type XSD_Null is new Scalar with null record; type SOAP_Base64 is new Scalar with record V : Unbounded_String; end record; type SOAP_Array is new Composite with null record; type SOAP_Record is new Composite with null record; end SOAP.Types; polyorb-2.8~20110207.orig/src/aws/aws-server-get_status.adb0000644000175000017500000002530711750740337022726 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- A W S . S E R V E R . G E T _ S T A T U S -- -- -- -- B o d y -- -- -- -- Copyright (C) 2000-2009, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with GNAT.Calendar.Time_IO; with AWS.Hotplug.Get_Status; with AWS.Session; with AWS.Templates; with AWS.Utils; function AWS.Server.Get_Status (Server : HTTP) return String is use Ada; use AWS.Templates; -- function Slot_Table return Translate_Table; -- returns the information for each slot function Session_Table return Translate_Table; -- returns session information ------------------- -- Session_Table -- ------------------- function Session_Table return Translate_Table is Sessions : Vector_Tag; Sessions_TS : Vector_Tag; Sessions_Terminate : Vector_Tag; Keys : Vector_Tag; Values : Vector_Tag; M_Keys : Matrix_Tag; M_Values : Matrix_Tag; procedure For_Each_Key_Value (N : Positive; Key, Value : String; Quit : in out Boolean); -- add key/value pair to the list procedure For_Each_Session (N : Positive; SID : Session.ID; Time_Stamp : Calendar.Time; Quit : in out Boolean); -- add session SID to the list ------------------------ -- For_Each_Key_Value -- ------------------------ procedure For_Each_Key_Value (N : Positive; Key, Value : String; Quit : in out Boolean) is pragma Warnings (Off, N); pragma Warnings (Off, Quit); begin Keys := Keys & Key; Values := Values & Value; end For_Each_Key_Value; -------------------------- -- Build_Key_Value_List -- -------------------------- procedure Build_Key_Value_List is new Session.For_Every_Session_Data (For_Each_Key_Value); ---------------------- -- For_Each_Session -- ---------------------- procedure For_Each_Session (N : Positive; SID : Session.ID; Time_Stamp : Calendar.Time; Quit : in out Boolean) is pragma Warnings (Off, N); pragma Warnings (Off, Quit); use type Calendar.Time; begin Sessions := Sessions & Session.Image (SID); Sessions_TS := Sessions_TS & GNAT.Calendar.Time_IO.Image (Time_Stamp, "%a %D %T"); Sessions_Terminate := Sessions_Terminate & GNAT.Calendar.Time_IO.Image (Time_Stamp + Session.Get_Lifetime, "%a %D %T"); Build_Key_Value_List (SID); M_Keys := M_Keys & Keys; M_Values := M_Values & Values; Clear (Keys); Clear (Values); end For_Each_Session; ------------------------ -- Build_Session_List -- ------------------------ procedure Build_Session_List is new Session.For_Every_Session (For_Each_Session); begin Build_Session_List; return Translate_Table' (Assoc ("SESSIONS_V", Sessions), Assoc ("SESSIONS_TS_V", Sessions_TS), Assoc ("SESSIONS_TERMINATE_V", Sessions_Terminate), Assoc ("KEYS_M", M_Keys), Assoc ("VALUES_M", M_Values)); end Session_Table; ---------------- -- Slot_Table -- ---------------- -- function Slot_Table return Translate_Table is -- Sock : Vector_Tag; -- Phase : Vector_Tag; -- Abortable : Vector_Tag; -- Activity_Counter : Vector_Tag; -- Slot_Activity_Counter : Vector_Tag; -- Activity_Time_Stamp : Vector_Tag; -- Peer_Name : Vector_Tag; -- -- Avoid : may be referenced before it has a value -- pragma Warnings (Off, Sock); -- pragma Warnings (Off, Phase); -- pragma Warnings (Off, Abortable); -- pragma Warnings (Off, Activity_Counter); -- pragma Warnings (Off, Slot_Activity_Counter); -- pragma Warnings (Off, Activity_Time_Stamp); -- pragma Warnings (Off, Peer_Name); -- Slot_Data : Slot; -- begin -- for K in 1 .. CNF.Max_Connection (Server.Properties) loop -- Slot_Data := Server.Slots.Get (Index => K); -- declare -- SD : constant Socket_Data -- := Server.Slots.Get_Socket_Info (Index => K); -- begin -- Sock := Sock & SD.FD; -- Peer_Name := Peer_Name & SD.Peername; -- end; -- Phase := Phase & Slot_Phase'Image (Slot_Data.Phase); -- Abortable := Abortable -- & Server.Slots.Is_Abortable (Index => K, Mode => Force); -- Activity_Counter := Activity_Counter & Slot_Data.Activity_Counter; -- Slot_Activity_Counter := Slot_Activity_Counter -- & Slot_Data.Slot_Activity_Counter; -- Activity_Time_Stamp := Activity_Time_Stamp & -- GNAT.Calendar.Time_IO.Image (Slot_Data.Phase_Time_Stamp, -- "%a %D %T"); -- end loop; -- return Translate_Table' -- (Assoc ("SOCK_V", Sock), -- Assoc ("PEER_NAME_V", Peer_Name), -- Assoc ("PHASE_V", Phase), -- Assoc ("ABORTABLE_V", Abortable), -- Assoc ("SLOT_ACTIVITY_COUNTER_V", Slot_Activity_Counter), -- Assoc ("ACTIVITY_COUNTER_V", Activity_Counter), -- Assoc ("ACTIVITY_TIME_STAMP_V", Activity_Time_Stamp)); -- end Slot_Table; Admin_URI : constant String := CNF.Admin_URI (Server.Properties); Translations : constant Templates.Translate_Table := (Assoc ("SERVER_NAME", CNF.Server_Name (Server.Properties)), Assoc ("START_TIME", GNAT.Calendar.Time_IO.Image (Server.Start_Time, "%A %-d %B %Y, %T")), Assoc ("MAX_CONNECTION", CNF.Max_Connection (Server.Properties)), Assoc ("SERVER_PORT", CNF.Server_Port (Server.Properties)), Assoc ("SECURITY", CNF.Security (Server.Properties)), -- Assoc ("SERVER_SOCK", -- Integer (Net.Std.Get_FD (Server.Sock))), Assoc ("VERSION", Version), Assoc ("SESSION", CNF.Session (Server.Properties)), Assoc ("SESSION_LIFETIME", Utils.Image (Session.Get_Lifetime)), Assoc ("SESSION_CLEANUP_INTERVAL", Utils.Image (CNF.Session_Cleanup_Interval)), Assoc ("CLEANER_WAIT_FOR_CLIENT_TIMEOUT", Utils.Image (CNF.Cleaner_Wait_For_Client_Timeout (Server.Properties))), Assoc ("CLEANER_CLIENT_HEADER_TIMEOUT", Utils.Image (CNF.Cleaner_Client_Header_Timeout (Server.Properties))), Assoc ("CLEANER_CLIENT_DATA_TIMEOUT", Utils.Image (CNF.Cleaner_Client_Data_Timeout (Server.Properties))), Assoc ("CLEANER_SERVER_RESPONSE_TIMEOUT", Utils.Image (CNF.Cleaner_Server_Response_Timeout (Server.Properties))), Assoc ("FORCE_WAIT_FOR_CLIENT_TIMEOUT", Utils.Image (CNF.Force_Wait_For_Client_Timeout (Server.Properties))), Assoc ("FORCE_CLIENT_HEADER_TIMEOUT", Utils.Image (CNF.Force_Client_Header_Timeout (Server.Properties))), Assoc ("FORCE_CLIENT_DATA_TIMEOUT", Utils.Image (CNF.Force_Client_Data_Timeout (Server.Properties))), Assoc ("FORCE_SERVER_RESPONSE_TIMEOUT", Utils.Image (CNF.Force_Server_Response_Timeout (Server.Properties))), Assoc ("SEND_TIMEOUT", Utils.Image (CNF.Send_Timeout (Server.Properties))), Assoc ("RECEIVE_TIMEOUT", Utils.Image (CNF.Receive_Timeout (Server.Properties))), Assoc ("ACCEPT_QUEUE_SIZE", Utils.Image (CNF.Accept_Queue_Size (Server.Properties))), Assoc ("STATUS_PAGE", CNF.Status_Page (Server.Properties)), Assoc ("LOGO", Admin_URI & "-logo"), Assoc ("LOG", Log.Is_Active (Server.Log)), Assoc ("LOG_FILE", Log.Filename (Server.Log)), Assoc ("LOG_MODE", Log.Split_Mode'Image (Log.Mode (Server.Log))), Assoc ("ADMIN", Admin_URI), Assoc ("UPLOAD_DIRECTORY", CNF.Upload_Directory (Server.Properties))) -- & Slot_Table & Session_Table & Hotplug.Get_Status (Server.Filters); begin return Templates.Parse (CNF.Status_Page (Server.Properties), Translations); end AWS.Server.Get_Status; polyorb-2.8~20110207.orig/src/aws/aws-status-translate_table.adb0000644000175000017500000000513511750740337023722 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- A W S . S T A T U S . T R A N S L A T E _ T A B L E -- -- -- -- B o d y -- -- -- -- Copyright (C) 2003-2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ function AWS.Status.Translate_Table (Status : Data) return Templates.Translate_Table is use Templates; begin return (Assoc ("PEERNAME", To_String (Status.Peername)), Assoc ("METHOD", Request_Method'Image (Status.Method)), Assoc ("URI", URL.URL (Status.URI)), Assoc ("HTTP_VERSION", To_String (Status.HTTP_Version)), Assoc ("AUTH_MODE", Authorization_Type'Image (Status.Auth_Mode)), Assoc ("SOAP_ACTION", Status.SOAP_Action), Assoc ("PAYLOAD", "soap_payload")); end AWS.Status.Translate_Table; polyorb-2.8~20110207.orig/src/aws/aws-server-servants.ads0000644000175000017500000000524011750740337022424 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- A W S . S E R V E R . S E R V A N T S -- -- -- -- S p e c -- -- -- -- Copyright (C) 2009-2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ pragma Ada_2005; with PolyORB; use PolyORB; with PolyORB.Requests; package AWS.Server.Servants is type Web_Servant is new HTTP with null record; type SOAP_Servant is new HTTP with null record; -- 2 servants are associated to an AWS Web server private type Web_Servant_Acc is access all Web_Servant; type SOAP_Servant_Acc is access all SOAP_Servant; overriding function Execute_Servant (S : not null access Web_Servant; Req : Requests.Request_Access) return Boolean; overriding function Execute_Servant (S : not null access SOAP_Servant; Req : Requests.Request_Access) return Boolean; end AWS.Server.Servants; polyorb-2.8~20110207.orig/src/aws/soap-types.adb0000644000175000017500000010151011750740337020543 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- S O A P . T Y P E S -- -- -- -- B o d y -- -- -- -- Copyright (C) 2000-2009, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with Ada.Long_Float_Text_IO; with Ada.Exceptions; with Ada.Strings.Fixed; with Ada.Tags; with Ada.Unchecked_Deallocation; with Ada.Streams; with AWS.Utils; with AWS.Translator; with SOAP.Utils; with PolyORB.Types; with PolyORB.Log; package body SOAP.Types is use Ada; use PolyORB.Log; package L is new PolyORB.Log.Facility_Log ("aws.soap"); procedure O (Message : Standard.String; Level : Log_Level := Debug) renames L.Output; function C (Level : Log_Level := Debug) return Boolean renames L.Enabled; -- the polyorb logging facility procedure Free is new Ada.Unchecked_Deallocation (Object_Set, Object_Set_Access); procedure Free is new Ada.Unchecked_Deallocation (Natural, Counter_Access); function xsi_type (Name : String) return String; pragma Inline (xsi_type); -- Returns the xsi:type field for the XML type representation whose name -- is passed as argument. function Spaces (N : Natural) return String; pragma Inline (Spaces); -- Returns N * 3 spaces. --------------------- -- From_NamedValue -- --------------------- function From_NamedValue (NV : PolyORB.Any.NamedValue) return Object'Class is use PolyORB.Any; use PolyORB.Types; use PolyORB.Any.TypeCode; O : constant Object_Access := From_Any (NV.Argument); begin pragma Debug (L.Output ("From_NamedValue: processing nv_arg named " & To_String (NV.Name))); O.Name := To_Unbounded_String (PolyORB.Types.To_String (NV.Name)); return O.all; end From_NamedValue; ------------------- -- To_NamedValue -- ------------------- function To_NamedValue (O : Object'Class) return PolyORB.Any.NamedValue is use PolyORB.Any; NV : PolyORB.Any.NamedValue; begin NV.Name := PolyORB.Types.To_PolyORB_String (To_String (O.Name)); NV.Arg_Modes := ARG_IN; NV.Argument := To_Any (O); return NV; end To_NamedValue; --------- -- "+" -- --------- function "+" (O : Object'Class) return Object_Safe_Pointer is begin return (Finalization.Controlled with new Object'Class'(O)); end "+"; ------- -- - -- ------- function "-" (O : Object_Safe_Pointer) return Object'Class is begin return O.O.all; end "-"; ------- -- A -- ------- function A (V : Object_Set; Name : String) return SOAP_Array is begin return (Finalization.Controlled with To_Unbounded_String (Name), new Natural'(1), new Object_Set'(V)); end A; ------------ -- Adjust -- ------------ procedure Adjust (O : in out Object_Safe_Pointer) is begin if O.O /= null then O.O := new Object'Class'(O.O.all); end if; end Adjust; procedure Adjust (O : in out Composite) is begin O.Ref_Counter.all := O.Ref_Counter.all + 1; end Adjust; ------- -- B -- ------- function B (V : Boolean; Name : String := "item") return XSD_Boolean is begin return (Finalization.Controlled with To_Unbounded_String (Name), V); end B; --------- -- B64 -- --------- function B64 (V : String; Name : String := "item") return SOAP_Base64 is begin return (Finalization.Controlled with To_Unbounded_String (Name), To_Unbounded_String (V)); end B64; ------- -- F -- ------- function F (V : Long_Float; Name : String := "item") return XSD_Float is begin return (Finalization.Controlled with To_Unbounded_String (Name), V); end F; -------------- -- Finalize -- -------------- procedure Finalize (O : in out Object_Safe_Pointer) is procedure Free is new Ada.Unchecked_Deallocation (Object'Class, Object_Access); begin if O.O /= null then Free (O.O); end if; end Finalize; procedure Finalize (O : in out Composite) is begin O.Ref_Counter.all := O.Ref_Counter.all - 1; if O.Ref_Counter.all = 0 then Free (O.O); Free (O.Ref_Counter); end if; end Finalize; --------- -- Get -- --------- function Get (O : Object'Class) return Integer is use type Ada.Tags.Tag; begin if O'Tag = Types.XSD_Integer'Tag then return V (XSD_Integer (O)); else Exceptions.Raise_Exception (Data_Error'Identity, "Integer expected, found " & Tags.Expanded_Name (O'Tag)); end if; end Get; function Get (O : Object'Class) return Long_Float is use type Ada.Tags.Tag; begin if O'Tag = Types.XSD_Float'Tag then return V (XSD_Float (O)); else Exceptions.Raise_Exception (Data_Error'Identity, "Float expected, found " & Tags.Expanded_Name (O'Tag)); end if; end Get; function Get (O : Object'Class) return String is use type Ada.Tags.Tag; begin if O'Tag = Types.XSD_String'Tag then return V (XSD_String (O)); else Exceptions.Raise_Exception (Data_Error'Identity, "String expected, found " & Tags.Expanded_Name (O'Tag)); end if; end Get; function Get (O : Object'Class) return Boolean is use type Ada.Tags.Tag; begin if O'Tag = Types.XSD_Boolean'Tag then return V (XSD_Boolean (O)); else Exceptions.Raise_Exception (Data_Error'Identity, "Boolean expected, found " & Tags.Expanded_Name (O'Tag)); end if; end Get; function Get (O : Object'Class) return SOAP_Base64 is use type Ada.Tags.Tag; begin if O'Tag = Types.SOAP_Base64'Tag then return SOAP_Base64 (O); else Exceptions.Raise_Exception (Data_Error'Identity, "SOAP Base64 expected, found " & Tags.Expanded_Name (O'Tag)); end if; end Get; function Get (O : Object'Class) return SOAP_Record is use type Ada.Tags.Tag; begin if O'Tag = Types.SOAP_Record'Tag then return SOAP_Record (O); else Exceptions.Raise_Exception (Data_Error'Identity, "SOAP Struct expected, found " & Tags.Expanded_Name (O'Tag)); end if; end Get; function Get (O : Object'Class) return SOAP_Array is use type Ada.Tags.Tag; begin if O'Tag = Types.SOAP_Array'Tag then return SOAP_Array (O); else Exceptions.Raise_Exception (Data_Error'Identity, "SOAP Array expected, found " & Tags.Expanded_Name (O'Tag)); end if; end Get; ------- -- I -- ------- function I (V : Integer; Name : String := "item") return XSD_Integer is begin return (Finalization.Controlled with To_Unbounded_String (Name), V); end I; ----------- -- Image -- ----------- function Image (O : Object) return String is pragma Warnings (Off, O); begin return ""; end Image; function Image (O : XSD_Integer) return String is V : constant String := Integer'Image (O.V); begin if O.V >= 0 then return V (V'First + 1 .. V'Last); else return V; end if; end Image; function Image (O : XSD_Float) return String is Result : String (1 .. Long_Float'Width); begin Long_Float_Text_IO.Put (Result, O.V, Exp => 0); return Strings.Fixed.Trim (Result, Strings.Both); end Image; function Image (O : XSD_String) return String is begin return To_String (O.V); end Image; function Image (O : XSD_Boolean) return String is begin if O.V then return "1"; else return "0"; end if; end Image; -- function Image (O : XSD_Time_Instant) return String is -- function Image (Timezone : TZ) return String; -- -- Returns Image for the TZ -- function Image (Timezone : TZ) return String is -- subtype Str2 is String (1 .. 2); -- function I2D (N : Natural) return Str2; -- function I2D (N : Natural) return Str2 is -- V : constant String := Natural'Image (N); -- begin -- if N > 9 then -- return V (V'First + 1 .. V'Last); -- else -- return '0' & V (V'First + 1 .. V'Last); -- end if; -- end I2D; -- begin -- if Timezone >= 0 then -- return '+' & I2D (Timezone) & ":00"; -- else -- return '-' & I2D (abs Timezone) & ":00"; -- end if; -- end Image; -- begin -- return GNAT.Calendar.Time_IO.Image (O.T, "%Y-%m-%dT%H:%M:%S") -- & Image (O.Timezone); -- end Image; function Image (O : SOAP_Base64) return String is begin return To_String (O.V); end Image; function Image (O : SOAP_Array) return String is Result : Unbounded_String; begin Append (Result, '('); for K in O.O'Range loop Append (Result, Integer'Image (K)); Append (Result, " => "); Append (Result, Image (O.O (K).O.all)); if K /= O.O'Last then Append (Result, ", "); end if; end loop; Append (Result, ')'); return To_String (Result); end Image; function Image (O : SOAP_Record) return String is Result : Unbounded_String; begin Append (Result, '('); for K in O.O'Range loop Append (Result, Name (O)); Append (Result, " => "); Append (Result, Image (O.O (K).O.all)); if K /= O.O'Last then Append (Result, ", "); end if; end loop; Append (Result, ')'); return To_String (Result); end Image; ---------------- -- Initialize -- ---------------- procedure Initialize (O : in out Composite) is begin O.Ref_Counter := new Natural'(1); end Initialize; ------- -- N -- ------- function N (Name : String := "item") return XSD_Null is begin return (Finalization.Controlled with Name => To_Unbounded_String (Name)); end N; ---------- -- Name -- ---------- function Name (O : Object'Class) return String is begin return To_String (O.Name); end Name; ------- -- R -- ------- function R (V : Object_Set; Name : String) return SOAP_Record is begin return (Finalization.Controlled with To_Unbounded_String (Name), new Natural'(1), new Object_Set'(V)); end R; ------- -- S -- ------- function S (V : String; Name : String := "item"; Encode : Boolean := True) return XSD_String is begin if Encode then return (Finalization.Controlled with To_Unbounded_String (Name), To_Unbounded_String (Utils.Encode (V))); else return (Finalization.Controlled with To_Unbounded_String (Name), To_Unbounded_String (V)); end if; end S; ---------- -- Size -- ---------- function Size (O : SOAP_Array) return Natural is begin return O.O'Length; end Size; ------------ -- Spaces -- ------------ function Spaces (N : Natural) return String is use Ada.Strings.Fixed; begin return (3 * N) * ' '; end Spaces; ------- -- T -- ------- -- function T -- (V : Calendar.Time; -- Name : String := "item"; -- Timezone : TZ := GMT) -- return XSD_Time_Instant is -- begin -- return (Finalization.Controlled -- with To_Unbounded_String (Name), V, Timezone); -- end T; ------- -- V -- ------- function V (O : XSD_Integer) return Integer is begin return O.V; end V; function V (O : XSD_Float) return Long_Float is begin return O.V; end V; function V (O : XSD_String) return String is begin return To_String (O.V); end V; function V (O : XSD_Boolean) return Boolean is begin return O.V; end V; -- function V (O : XSD_Time_Instant) return Calendar.Time is -- begin -- return O.T; -- end V; function V (O : SOAP_Base64) return String is begin return To_String (O.V); end V; function V (O : SOAP_Array) return Object_Set is begin return O.O.all; end V; function V (O : SOAP_Array; N : Positive) return Object'Class is begin return O.O (N).O.all; end V; function V (O : SOAP_Record; Name : String) return Object'Class is begin for K in O.O'Range loop if Types.Name (O.O (K).O.all) = Name then return O.O (K).O.all; end if; end loop; Exceptions.Raise_Exception (Types.Data_Error'Identity, "(V) Struct object " & Name & " not found"); end V; function V (O : SOAP_Record) return Object_Set is begin return O.O.all; end V; --------------- -- XML_Image -- --------------- function XML_Image (O : Object) return String is Indent : constant Natural := 0; -- XML_Indent.Value; OC : constant Object'Class := Object'Class (O); begin return Spaces (Indent) & "<" & Name (OC) & xsi_type (XML_Type (OC)) & '>' & Image (OC) & "'; end XML_Image; --------------- -- XML_Image -- --------------- function XML_Image (O : XSD_Integer) return String is begin return XML_Image (Object (O)); end XML_Image; --------------- -- XML_Image -- --------------- function XML_Image (O : XSD_Float) return String is begin return XML_Image (Object (O)); end XML_Image; --------------- -- XML_Image -- --------------- function XML_Image (O : XSD_String) return String is begin return XML_Image (Object (O)); end XML_Image; --------------- -- XML_Image -- --------------- function XML_Image (O : XSD_Boolean) return String is begin return XML_Image (Object (O)); end XML_Image; --------------- -- XML_Image -- --------------- -- function XML_Image (O : XSD_Time_Instant) return String is -- begin -- return XML_Image (Object (O)); -- end XML_Image; --------------- -- XML_Image -- --------------- function XML_Image (O : XSD_Null) return String is Indent : constant Natural := 0; -- XML_Indent.Value; OC : constant Object'Class := Object'Class (O); begin return Spaces (Indent) & "<" & Name (OC) & " xsi_null=""1""/>"; end XML_Image; --------------- -- XML_Image -- --------------- function XML_Image (O : SOAP_Base64) return String is begin return XML_Image (Object (O)); end XML_Image; --------------- -- XML_Image -- --------------- New_Line : constant String := ASCII.CR & ASCII.LF; function XML_Image (O : SOAP_Array) return String is Indent : constant Natural := 0; -- XML_Indent.Value; function Array_Type return String; -- Returns the right SOAP array type. ---------------- -- Array_Type -- ---------------- function Array_Type return String is use type Ada.Tags.Tag; T : Ada.Tags.Tag; begin if O.O'Length = 0 then -- This is a zero length array, type is undefined. return XML_Undefined; end if; T := O.O (O.O'First).O'Tag; if T = SOAP_Record'Tag then -- This is a record, no need to parse further. return XML_Undefined; end if; for K in O.O'First + 1 .. O.O'Last loop -- Not same type if type different or is a composite type. if T /= O.O (K).O'Tag or else O.O (K).O.all in SOAP.Types.Composite'Class then return XML_Undefined; end if; end loop; -- We have the same type. return XML_Type (O.O (O.O'First).O.all); end Array_Type; Result : Unbounded_String; begin -- Open array element Append (Result, Spaces (Indent)); Append (Result, '<'); Append (Result, O.Name); Append (Result, " SOAP-ENC:arrayType="""); Append (Result, Array_Type); Append (Result, '['); Append (Result, AWS.Utils.Image (O.O'Length)); Append (Result, "]"""); Append (Result, xsi_type (XML_Array)); Append (Result, '>'); Append (Result, New_Line); -- Add all elements -- XML_Indent.Set_Value (Indent + 1); for K in O.O'Range loop Append (Result, XML_Image (O.O (K).O.all)); Append (Result, New_Line); end loop; -- XML_Indent.Set_Value (Indent); -- End array element Append (Result, Spaces (Indent)); Append (Result, Utils.Tag (To_String (O.Name), Start => False)); return To_String (Result); end XML_Image; --------------- -- XML_Image -- --------------- function XML_Image (O : SOAP_Record) return String is Indent : constant Natural := 0; -- XML_Indent.Value; Result : Unbounded_String; begin Append (Result, Spaces (Indent)); Append (Result, Utils.Tag (Name (O), Start => True)); Append (Result, New_Line); -- XML_Indent.Set_Value (Indent + 1); for K in O.O'Range loop Append (Result, XML_Image (O.O (K).O.all)); Append (Result, New_Line); end loop; -- XML_Indent.Set_Value (Indent); Append (Result, Spaces (Indent)); Append (Result, Utils.Tag (Name (O), Start => False)); return To_String (Result); end XML_Image; -------------- -- XML_Type -- -------------- function XML_Type (O : Object) return String is pragma Warnings (Off, O); begin return ""; end XML_Type; function XML_Type (O : XSD_Integer) return String is pragma Warnings (Off, O); begin return XML_Int; end XML_Type; function XML_Type (O : XSD_Float) return String is pragma Warnings (Off, O); begin return XML_Float; end XML_Type; function XML_Type (O : XSD_String) return String is pragma Warnings (Off, O); begin return XML_String; end XML_Type; function XML_Type (O : XSD_Boolean) return String is pragma Warnings (Off, O); begin return XML_Boolean; end XML_Type; -- function XML_Type (O : XSD_Time_Instant) return String is -- pragma Warnings (Off, O); -- begin -- return XML_Time_Instant; -- end XML_Type; function XML_Type (O : XSD_Null) return String is pragma Warnings (Off, O); begin return XML_Null; end XML_Type; function XML_Type (O : SOAP_Base64) return String is pragma Warnings (Off, O); begin return XML_Base64; end XML_Type; function XML_Type (O : SOAP_Array) return String is pragma Warnings (Off, O); begin return XML_Array; end XML_Type; function XML_Type (O : SOAP_Record) return String is pragma Warnings (Off, O); begin return ""; end XML_Type; -------------- -- xsi_type -- -------------- function xsi_type (Name : String) return String is begin return " xsi:type=""" & Name & '"'; end xsi_type; ------------ -- To_Any -- ------------ function To_Any (Obj : Object'Class) return PolyORB.Any.Any is use PolyORB.Types; -- This is a general dispatch function. This is mandatory, -- since complex types such as SOAP_Array need to refer to a -- general To_Any function that handles Object'Class elements begin if Obj in XSD_Boolean then return PolyORB.Any.To_Any (XSD_Boolean (Obj).V); elsif Obj in XSD_Integer then return PolyORB.Any.To_Any (PolyORB.Types.Long (XSD_Integer (Obj).V)); -- As integers are 32 bit signed integers in GNAT. elsif Obj in XSD_Float then return PolyORB.Any.To_Any (PolyORB.Types.Double (XSD_Float (Obj).V)); -- As long_floats are 64 bit floats in GNAT. elsif Obj in XSD_String then return PolyORB.Any.To_Any (To_PolyORB_String (To_String (XSD_String (Obj).V))); elsif Obj in XSD_Null then return PolyORB.Any.Get_Empty_Any (PolyORB.Any.TC_Null); -- elsif Obj in XSD_Time_Instant then -- not coded yet -- return PolyORB.Any.Get_Empty_Any (PolyORB.Any.TC_Null); elsif Obj in SOAP_Base64 then declare use Ada.Streams; Sq_Type : constant PolyORB.Any.TypeCode.Local_Ref := PolyORB.Any.TypeCode.TC_Sequence; Byte_Stream : constant Ada.Streams.Stream_Element_Array := AWS.Translator.Base64_Decode (V (SOAP_Base64 (Obj))); begin PolyORB.Any.TypeCode.Add_Parameter (Sq_Type, PolyORB.Any.To_Any (PolyORB.Types.Unsigned_Long (Byte_Stream'Last - Byte_Stream'First + 1))); PolyORB.Any.TypeCode.Add_Parameter (Sq_Type, PolyORB.Any.To_Any (PolyORB.Any.TypeCode.TC_Octet)); declare Sq : PolyORB.Any.Any := PolyORB.Any.Get_Empty_Any_Aggregate (Sq_Type); begin for K in Byte_Stream'Range loop PolyORB.Any.Add_Aggregate_Element (Sq, PolyORB.Any.To_Any (PolyORB.Types.Octet (Byte_Stream (K)))); end loop; return Sq; end; end; elsif Obj in SOAP_Array then declare use PolyORB.Any; Ar_Type : constant PolyORB.Any.TypeCode.Local_Ref := PolyORB.Any.TypeCode.TC_Array; begin pragma Debug (C, O ("To_Any: SOAP_Array: nb of elements= " & Natural'Image (Size (SOAP_Array (Obj))))); PolyORB.Any.TypeCode.Add_Parameter (Ar_Type, PolyORB.Any.To_Any (PolyORB.Types.Unsigned_Long (Size (SOAP_Array (Obj))))); PolyORB.Any.TypeCode.Add_Parameter (Ar_Type, To_Any (TypeCode.To_Ref (Get_Unwound_Type (To_Any (-(SOAP_Array (Obj).O (SOAP_Array (Obj).O'First))))))); -- We first build the typecode. declare Ar : PolyORB.Any.Any := PolyORB.Any.Get_Empty_Any_Aggregate (Ar_Type); begin for K in SOAP_Array (Obj).O'Range loop PolyORB.Any.Add_Aggregate_Element (Ar, To_Any (-(SOAP_Array (Obj).O (K)))); end loop; return Ar; end; end; elsif Obj in SOAP_Record then declare use PolyORB.Any; St_Type : constant PolyORB.Any.TypeCode.Local_Ref := PolyORB.Any.TypeCode.TC_Struct; begin PolyORB.Any.TypeCode.Add_Parameter (St_Type, PolyORB.Any.To_Any (PolyORB.Types.To_PolyORB_String (To_String (SOAP_Record (Obj).Name)))); PolyORB.Any.TypeCode.Add_Parameter (St_Type, PolyORB.Any.To_Any (PolyORB.Types.To_PolyORB_String ("repository_id"))); for K in SOAP_Record (Obj).O'Range loop PolyORB.Any.TypeCode.Add_Parameter (St_Type, To_Any (TypeCode.To_Ref (Get_Unwound_Type (To_Any (-(SOAP_Record (Obj).O (K))))))); -- thus we get the type declare The_Element : constant Object'Class := -(SOAP_Record (Obj).O (K)); begin PolyORB.Any.TypeCode.Add_Parameter (St_Type, PolyORB.Any.To_Any (PolyORB.Types.To_PolyORB_String (To_String (The_Element.Name)))); -- Then we add the parameter name end; end loop; -- we first build the typecode declare St : PolyORB.Any.Any := PolyORB.Any.Get_Empty_Any_Aggregate (St_Type); begin for K in SOAP_Record (Obj).O'Range loop PolyORB.Any.Add_Aggregate_Element (St, To_Any (-(SOAP_Record (Obj).O (K)))); end loop; -- Finally we store the values return St; end; end; else raise Data_Error; end if; end To_Any; -------------- -- From_Any -- -------------- function From_Any (Item : PolyORB.Any.Any) return Object_Access is use PolyORB.Any; Obj : Object_Access; Kind_Of_Any : constant PolyORB.Any.TCKind := PolyORB.Any.TypeCode.Kind (PolyORB.Any.Get_Unwound_Type (Item)); begin pragma Debug (C, O ("From_Any: handling an Any of type " & PolyORB.Any.Image (Get_Unwound_Type (Item)))); if Kind_Of_Any = Tk_Null then -- declare -- Obj : XSD_Null; -- begin Obj := new XSD_Null; Obj.Name := To_Unbounded_String ("item"); return Obj; -- end; elsif Kind_Of_Any = Tk_String then declare Obj : XSD_String; Value : constant PolyORB.Types.String := PolyORB.Any.From_Any (Item); begin Obj.V := To_Unbounded_String (PolyORB.Types.To_String (Value)); Obj.Name := To_Unbounded_String ("item"); return new XSD_String'(Obj); end; elsif Kind_Of_Any = Tk_Long then declare Obj : XSD_Integer; Value : constant PolyORB.Types.Long := PolyORB.Any.From_Any (Item); begin Obj.V := Integer (Value); Obj.Name := To_Unbounded_String ("item"); return new XSD_Integer'(Obj); end; elsif Kind_Of_Any = Tk_Double then declare Obj : XSD_Float; Value : constant PolyORB.Types.Double := PolyORB.Any.From_Any (Item); begin Obj.V := Long_Float (Value); Obj.Name := To_Unbounded_String ("item"); return new XSD_Float'(Obj); end; elsif Kind_Of_Any = Tk_Boolean then declare Obj : XSD_Boolean; begin Obj.V := PolyORB.Any.From_Any (Item); Obj.Name := To_Unbounded_String ("item"); return new XSD_Boolean'(Obj); end; elsif Kind_Of_Any = Tk_Sequence then declare use AWS.Translator; use Ada.Streams; use PolyORB.Types; Number_Of_Elements : constant Unsigned_Long := PolyORB.Any.Get_Aggregate_Count (Item); Byte_Stream : Stream_Element_Array (0 .. Stream_Element_Offset (Number_Of_Elements) - 1); begin if PolyORB.Any.TypeCode.Kind (PolyORB.Any.TypeCode.Content_Type (PolyORB.Any.Get_Type (Item))) /= Tk_Octet then raise Data_Error; else pragma Debug (C, O ("From_Any: Tk_Sequence (base 64): " & "attempting to retrieve" & Unsigned_Long'Image (Number_Of_Elements) & " octets")); for Index in 0 .. Number_Of_Elements - 1 loop declare Element : constant PolyORB.Types.Octet := PolyORB.Any.From_Any (PolyORB.Any.Get_Aggregate_Element (Item, PolyORB.Any.TypeCode.TC_Octet, Index)); begin Byte_Stream (Stream_Element_Offset (Index)) := Stream_Element (Element); end; end loop; return new SOAP_Base64' (B64 (Base64_Encode (Byte_Stream), "item")); end if; end; elsif Kind_Of_Any = Tk_Array then declare use PolyORB.Types; Number_Of_Elements : constant Unsigned_Long := Unsigned_Long (PolyORB.Any.TypeCode.Length (PolyORB.Any.Get_Type (Item))); pragma Debug (C, O ("From_Any: Tk_Array: nb of elements= " & Unsigned_Long'Image (Number_Of_Elements))); OS : Object_Set (1 .. Integer (Number_Of_Elements)); PolyORB_Type_Of_Elements : constant PolyORB.Any.TypeCode.Local_Ref := PolyORB.Any.TypeCode.Content_Type (PolyORB.Any.Get_Type (Item)); begin for Index in 1 .. Number_Of_Elements loop declare New_Object : constant Object_Access := From_Any (PolyORB.Any.Get_Aggregate_Element (Item, PolyORB_Type_Of_Elements, PolyORB.Types.Unsigned_Long (Index - 1))); begin New_Object.Name := To_Unbounded_String ("item"); pragma Debug (C, O ("From_Any: Tk_Array: index=" & Positive'Image (Positive (Index)))); OS (Positive (Index)) := +(New_Object.all); end; end loop; return new SOAP_Array'(A (OS, "item")); end; elsif Kind_Of_Any = Tk_Struct then declare use PolyORB.Types; Number_Of_Elements : constant Unsigned_Long := Unsigned_Long (PolyORB.Any.TypeCode.Member_Count (PolyORB.Any.Get_Type (Item))); OS : Object_Set (1 .. Integer (Number_Of_Elements)); begin for Index in 1 .. Number_Of_Elements loop declare Element : constant PolyORB.Any.Any := (PolyORB.Any.Get_Aggregate_Element (Item, PolyORB.Any.TypeCode.Member_Type (PolyORB.Any.Get_Type (Item), Index - 1), PolyORB.Types.Unsigned_Long (Index - 1))); New_Object : constant Object_Access := From_Any (Element); begin New_Object.Name := To_Unbounded_String (PolyORB.Types.To_String (PolyORB.Any.TypeCode.Member_Name (PolyORB.Any.Get_Type (Item), Index - 1))); OS (Positive (Index)) := +(New_Object.all); end; end loop; return new SOAP_Record'(R (OS, "item")); end; else pragma Debug (C, O ("From_Any: no handler found for TCKind " & Image (Get_Unwound_Type (Item)), Critical)); raise Data_Error; end if; end From_Any; end SOAP.Types; polyorb-2.8~20110207.orig/src/aws/soap-client.adb0000644000175000017500000001754411750740337020672 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- S O A P . C L I E N T -- -- -- -- B o d y -- -- -- -- Copyright (C) 2000-2009, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with SOAP.Parameters; with SOAP.Types; with AWS.URL; with PolyORB.Any.NVList; with PolyORB.Any; with PolyORB.Types; with PolyORB.References.URI; with PolyORB.Requests; with PolyORB.Log; package body SOAP.Client is use PolyORB.Log; package L is new PolyORB.Log.Facility_Log ("aws.soap_client"); procedure O (Message : Standard.String; Level : Log_Level := Debug) renames L.Output; function C (Level : Log_Level := Debug) return Boolean renames L.Enabled; -- the polyorb logging facility -- use Ada.Strings.Unbounded; function Handle_Request (Connection : access AWS.Client.HTTP_Connection; P : SOAP.Message.Payload.Object; SOAPAction : String) return SOAP.Message.Response.Object'Class; -- sends the soap payload to the host specified in Connection, -- calling the method called SOAPAction function Handle_Request (Connection : access AWS.Client.HTTP_Connection; P : SOAP.Message.Payload.Object; SOAPAction : String) return SOAP.Message.Response.Object'Class is -- we read the method name stored in P, as we are sure it is -- set (cf. soap.message.payload.build) use PolyORB.Any.NVList; use PolyORB.Any; use PolyORB.Types; use PolyORB.References.URI; use PolyORB.Requests; use AWS.URL; use AWS.Client; use SOAP.Message.Payload; Args : PolyORB.Any.NVList.Ref; PolyORB_Request : PolyORB.Requests.Request_Access; PolyORB_Response : PolyORB.Any.NamedValue; SOAP_Params : constant SOAP.Parameters.List := SOAP.Message.Parameters (P); Reference : constant String := Protocol (Host_URL (Connection.all)) & "://" & Host (Host_URL (Connection.all)) & ":" & Port (Host_URL ((Connection.all))) & Path (Host_URL (Connection.all)) & File (Host_URL (Connection.all)); begin pragma Debug (C, O ("Handle_Request: building a request named " & SOAPAction)); pragma Debug (C, O ("Handle_Request: Reference is " & Reference)); Create (Args); for Index in 1 .. SOAP.Parameters.Argument_Count (SOAP_Params) loop Add_Item (Args, SOAP.Types.To_NamedValue (Parameters.Argument (SOAP_Params, Index))); end loop; Create_Request (Target => PolyORB.References.URI.String_To_Object (Reference), Operation => SOAPAction, Arg_List => Args, Result => PolyORB_Response, Req => PolyORB_Request); Invoke (PolyORB_Request); pragma Debug (C, O ("Type of response is " & Image (Get_Unwound_Type (PolyORB_Request.Result.Argument)))); declare use SOAP.Parameters; use SOAP.Message; SOAP_Response : SOAP.Message.Response.Object; begin Set_Parameters (SOAP_Response, +(SOAP.Types.From_NamedValue (PolyORB_Request.Result))); Set_Wrapper_Name (SOAP_Response, PolyORB.Types.To_String (PolyORB_Response.Name)); return SOAP_Response; end; end Handle_Request; ---------- -- Call -- ---------- function Call (URL : String; P : SOAP.Message.Payload.Object; SOAPAction : String := Not_Specified) return SOAP.Message.Response.Object'Class is use AWS.Client; use SOAP.Message.Payload; -- procedure RPC_Call; -- Does the actual RPC over HTTP call. -- Message_Body : Unbounded_String; -------------- -- RPC_Call -- -------------- -- procedure RPC_Call is -- begin -- if SOAPAction = Not_Specified then -- declare -- URL_Object : constant AWS.URL.Object := AWS.URL.Parse (URL); -- begin -- Response := AWS.Client.SOAP_Post -- (URL, -- To_String (Message_Body), -- AWS.URL.URL (URL_Object) -- & '#' & SOAP.Message.Payload.Procedure_Name (P)); -- end; -- else -- Response := AWS.Client.SOAP_Post -- (URL, -- To_String (Message_Body), -- SOAPAction); -- end if; -- end RPC_Call; Connection : aliased HTTP_Connection; begin -- Message_Body := SOAP.Message.XML.Image (P); -- RPC_Call; -- return Message.XML.Load_Response (AWS.Response.Message_Body (Response)); if SOAPAction = Not_Specified then declare The_SOAPAction : constant String := Procedure_Name (P); -- If no SOAP Action was specified, we retrieve the one -- stored in the SOAP Object begin Create (Connection, Host => URL, SOAPAction => The_SOAPAction); return Handle_Request (Connection'Access, P, The_SOAPAction); end; else Create (Connection, Host => URL, SOAPAction => SOAPAction); return Handle_Request (Connection'Access, P, SOAPAction); end if; end Call; ---------- -- Call -- ---------- function Call (Connection : access AWS.Client.HTTP_Connection; P : SOAP.Message.Payload.Object) return SOAP.Message.Response.Object'Class is use SOAP.Message.Payload; -- Message_Body : Unbounded_String; begin -- Message_Body := SOAP.Message.XML.Image (P); -- Response := AWS.Client.SOAP_Post (Connection, To_String (Message_Body)); -- return Message.XML.Load_Response (AWS.Response.Message_Body (Response)); pragma Debug (C, O ("Call: processing a request named " & Procedure_Name (P))); return Handle_Request (Connection, P, Procedure_Name (P)); end Call; end SOAP.Client; polyorb-2.8~20110207.orig/src/aws/aws-headers.ads0000644000175000017500000000755611750740337020702 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- A W S . H E A D E R S -- -- -- -- S p e c -- -- -- -- Copyright (C) 2000-2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- to be changed, as we use aws.net with AWS.Containers.Tables; -- with AWS.Net; package AWS.Headers is type List is new AWS.Containers.Tables.Table_Type with private; -- Header container. This set handles a set of HTTP header line, each new -- header line is inserted at the end of the list (see AWS.Headers.Set API) -- and can be retrieved by the following services. Header lines are -- numbered from 1 to N. subtype VString_Array is AWS.Containers.Tables.VString_Array; subtype Element is AWS.Containers.Tables.Element; Format_Error : exception; -- Raised when header line format is wrong -- procedure Send_Header -- (Socket : Net.Socket_Type'Class; -- Headers : List); -- Send all header lines in Headers list to the socket function Get_Line (Headers : List; N : Positive) return String; -- Returns the Nth header line in Headers container. The returned value is -- formatted as a correct header line: -- -- message-header = field-name ":" [ field-value ] -- -- That is the header-name followed with character ':' and the header -- values. If there is less than Nth header line it returns the empty -- string. Note that this routine does returns all header line values, for -- example it would return: -- -- Content_Type: multipart/mixed; boundary="0123_The_Boundary_Value_" -- -- For a file upload content type header style. function Get_Values (Headers : List; Name : String) return String; -- Returns all values for the specified header field Name in a -- comma-separated string. This format is conformant to [RFC 2616 - 4.2] -- (see last paragraph). -- See AWS.Containers.Tables for inherited routines. private type List is new AWS.Containers.Tables.Table_Type with null record; end AWS.Headers; polyorb-2.8~20110207.orig/src/aws/soap-client.ads0000644000175000017500000000566511750740337020714 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- S O A P . C L I E N T -- -- -- -- S p e c -- -- -- -- Copyright (C) 2000-2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with AWS.Client; with SOAP.Message.Payload; with SOAP.Message.Response; package SOAP.Client is Not_Specified : constant String; function Call (URL : String; P : Message.Payload.Object; SOAPAction : String := Not_Specified) return Message.Response.Object'Class; -- Send a SOAP HTTP request to URL address. The P is the Payload and -- SOAPAction is the required HTTP field. If it is not specified then the -- URI (URL resource) will be used for the SOAPAction field. The complete -- format is "URL & '#' & Procedure_Name" (Procedure_Name is retrieved -- from the Payload object. function Call (Connection : access AWS.Client.HTTP_Connection; P : Message.Payload.Object) return Message.Response.Object'Class; -- Idem as above, but use an already opened connection. private Not_Specified : constant String := ""; end SOAP.Client; polyorb-2.8~20110207.orig/src/aws/soap-message-payload.ads0000644000175000017500000000530711750740337022502 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- S O A P . M E S S A G E . P A Y L O A D -- -- -- -- S p e c -- -- -- -- Copyright (C) 2000-2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with SOAP.Parameters; package SOAP.Message.Payload is type Object is new Message.Object with private; function Procedure_Name (P : Object'Class) return String; -- Retruns the Payload procedure name. procedure Set_Procedure_Name (P : in out Object'Class; Name : String); -- Set the payload procedure name. function Build (Procedure_Name : String; P_Set : SOAP.Parameters.List; Name_Space : String := Default_Name_Space) return Object; -- Retruns a Payload object initialized with the procedure name, -- parameters and name space. private type Object is new Message.Object with null record; end SOAP.Message.Payload; polyorb-2.8~20110207.orig/src/aws/aws-client.ads0000644000175000017500000003416611750740337020542 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- A W S . C L I E N T -- -- -- -- S p e c -- -- -- -- Copyright (C) 2000-2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with Ada.Streams; with Ada.Strings.Unbounded; -- with AWS.Net; with AWS.Response; with AWS.URL; package AWS.Client is use Ada.Strings.Unbounded; Connection_Error : exception; -- Raised if the connection with the server cannot be established Protocol_Error : exception; -- Raised if the client receives wrong HTTP protocol data No_Data : constant String; -- Used as the default parameter when no data specified for a specific -- parameter. Retry_Default : constant := 0; -- Number of time a data is requested from the Server if the first -- time fails. type Authentication_Mode is new AWS.Response.Authentication_Mode; type Timeouts_Values is record Send : Natural; Receive : Natural; end record; -- Defined the number of seconds for the send and receive timeout No_Timeout : constant Timeouts_Values; -- No timeout, allow infinite time to send or retreive data function Get (URL : String; User : String := No_Data; Pwd : String := No_Data; Proxy : String := No_Data; Proxy_User : String := No_Data; Proxy_Pwd : String := No_Data; Timeouts : Timeouts_Values := No_Timeout; Follow_Redirection : Boolean := False) return Response.Data; -- retreive the message data given a specific URL. It open a connection -- with the server and ask for the resource specified in the URL it then -- return it in the Response.Data structure. -- If User/Pwd are given then it uses it to access the URL. -- -- Eventually it connect through a PROXY using if necessary the Proxy -- authentification Proxy_User:Proxy_Pwd. -- -- Only Basic authetification is supported (i.e. Digest is not). Digest -- authentication is supported with the keep-alive client API, see below. -- -- If Follow_Redirection is set to True, Get will follow the redirection -- information for 301 status code response. Note that this is not -- supported for keep-alive connections as the redirection could point to -- another server. -- -- Get will retry one time if it fails. function Head (URL : String; User : String := No_Data; Pwd : String := No_Data; Proxy : String := No_Data; Proxy_User : String := No_Data; Proxy_Pwd : String := No_Data; Timeouts : Timeouts_Values := No_Timeout) return Response.Data; -- Idem as above but we do not get the message body. -- Head will retry one time if it fails. function Put (URL : String; Data : String; User : String := No_Data; Pwd : String := No_Data; Proxy : String := No_Data; Proxy_User : String := No_Data; Proxy_Pwd : String := No_Data; Timeouts : Timeouts_Values := No_Timeout) return Response.Data; -- Send to the server URL a PUT request with Data -- Put will retry one time if it fails. function Post (URL : String; Data : String; User : String := No_Data; Pwd : String := No_Data; Proxy : String := No_Data; Proxy_User : String := No_Data; Proxy_Pwd : String := No_Data; Timeouts : Timeouts_Values := No_Timeout) return Response.Data; -- Send to the server URL a POST request with Data -- Post will retry one time if it fails. function Post (URL : String; Data : Ada.Streams.Stream_Element_Array; User : String := No_Data; Pwd : String := No_Data; Proxy : String := No_Data; Proxy_User : String := No_Data; Proxy_Pwd : String := No_Data; Timeouts : Timeouts_Values := No_Timeout) return Response.Data; -- Idem as above but with binary data. function SOAP_Post (URL : String; Data : String; SOAPAction : String; User : String := No_Data; Pwd : String := No_Data; Proxy : String := No_Data; Proxy_User : String := No_Data; Proxy_Pwd : String := No_Data; Timeouts : Timeouts_Values := No_Timeout) return Response.Data; -- Send to the server URL a POST request with Data -- Post will retry one time if it fails. -- function Upload -- (URL : String; -- Filename : String; -- User : String := No_Data; -- Pwd : String := No_Data; -- Proxy : String := No_Data; -- Proxy_User : String := No_Data; -- Proxy_Pwd : String := No_Data; -- Timeouts : Timeouts_Values := No_Timeout) -- return Response.Data; -- This is a file upload request. Filename file's content will be send to -- the server at address URL. --------------------------------------- -- Keep-Alive client implementation -- --------------------------------------- type HTTP_Connection is limited private; procedure Create (Connection : in out HTTP_Connection; Host : String; User : String := No_Data; Pwd : String := No_Data; Proxy : String := No_Data; Proxy_User : String := No_Data; Proxy_Pwd : String := No_Data; Retry : Natural := Retry_Default; SOAPAction : String := No_Data; Persistent : Boolean := True; Timeouts : Timeouts_Values := No_Timeout; Server_Push : Boolean := False); -- Create a new connection. This is to be used with Keep-Alive client API -- below. The request will be tried Retry time if it fails. procedure Set_WWW_Authentication (Connection : in out HTTP_Connection; User : String; Pwd : String; Mode : Authentication_Mode); -- Sets the username password and authentication mode for the Web -- authentication. -- -- "Any" mean that user want to use Digest server authentication mode but -- could use Basic if the server does not support Digest authentication. -- -- "Basic" mean that client will send basic authentication. "Basic" -- authentication is send with the first request and is a fast -- authentication protocol. -- -- "Digest" mean that the client ask for Digest authentication, it -- requires that a first unauthorized request be sent to the server. The -- server will answer "nonce" for the authentication protocol to continue. procedure Set_Proxy_Authentication (Connection : in out HTTP_Connection; User : String; Pwd : String; Mode : Authentication_Mode); -- Sets the username, password and authentication mode for the proxy -- authentication. procedure Copy_Cookie (Source : HTTP_Connection; Destination : in out HTTP_Connection); -- Copy a session ID from connection Source to connection Destination. -- Allow both connections to share the same user environment. Note that -- user's environment are thread-safe. function Read_Until (Connection : HTTP_Connection; Delimiter : String) return String; -- Read data on the Connection until the delimiter (including the -- delimiter). It can be used to retreive the next piece of data from a -- push server. If returned data is empty or does not termintate with the -- delimiter the server push connection is closed. procedure Read_Until (Connection : in out HTTP_Connection; Delimiter : String; Result : in out Ada.Strings.Unbounded.Unbounded_String); -- Idem as above but returns the result as an Unbounded_String. procedure Get (Connection : in out HTTP_Connection; Result : out Response.Data; URI : String := No_Data); -- Same as Get above but using a Connection. procedure Head (Connection : in out HTTP_Connection; Result : out Response.Data; URI : String := No_Data); -- Same as Head above but using a Connection. procedure Put (Connection : in out HTTP_Connection; Result : out Response.Data; Data : String; URI : String := No_Data); -- Same as Put above but using a Connection. procedure Post (Connection : in out HTTP_Connection; Result : out Response.Data; Data : String; URI : String := No_Data); -- Same as Post above but using a Connection. procedure Post (Connection : in out HTTP_Connection; Result : out Response.Data; Data : Ada.Streams.Stream_Element_Array; URI : String := No_Data); -- Same as Post above but using a Connection. -- procedure Upload -- (Connection : in out HTTP_Connection; -- Result : out Response.Data; -- Filename : String; -- URI : String := No_Data); -- Same as Upload above but using a Connection. function SOAP_Post (Connection : access HTTP_Connection; Data : String) return Response.Data; -- Same as SOAP_Post above but using a Connection. procedure Close (Connection : in out HTTP_Connection); -- Close connection, it releases all associated resources. procedure Set_Debug (On : Boolean); -- Set debug mode on/off. If debug is activated the request header and the -- server response header will be displayed. function Host (Connection : HTTP_Connection) return Unbounded_String; -- returns the host name function Host_URL (Connection : HTTP_Connection) return AWS.URL.Object; -- returns the URL of the host private No_Timeout : constant Timeouts_Values := (0, 0); No_Data : constant String := ""; type Client_Phase is (Not_Monitored, Send, Receive, Stopped); type HTTP_Connection_Access is access all HTTP_Connection; -- ??? Cleaner_Task is used to monitor the timeouts during the Send and -- Receive phase. This is the current implementation and should be fixed -- at some point. Right now there is no cross-platforms implementation of -- a Socket timeout. -- task type Cleaner_Task is -- entry Start (Connection : HTTP_Connection_Access); -- -- Task initialization, pass the HTTP_Connection to monitor. -- entry Next_Phase; -- -- Change the client phase. -- end Cleaner_Task; -- type Cleaner_Access is access Cleaner_Task; type Authentication_Level is (WWW, Proxy); type Authentication_Type is record User : Unbounded_String; Pwd : Unbounded_String; -- Mode the user want to use Init_Mode : Authentication_Mode := Any; -- "Any" mean without authentication Work_Mode : Authentication_Mode := Any; Requested : Boolean := False; -- Fields below are for digest authentication only Realm : Unbounded_String; Nonce : Unbounded_String; QOP : Unbounded_String; NC : Natural := 0; end record; type Authentication_Set is array (Authentication_Level) of Authentication_Type; type HTTP_Connection is limited record Self : HTTP_Connection_Access := HTTP_Connection'Unchecked_Access; Connect_URL : AWS.URL.Object; Host : Unbounded_String; Host_URL : AWS.URL.Object; Proxy : Unbounded_String; Proxy_URL : AWS.URL.Object; Auth : Authentication_Set; Opened : Boolean; Persistent : Boolean; Server_Push : Boolean; SOAPAction : Unbounded_String; Cookie : Unbounded_String; -- Socket : Net.Socket_Access; Retry : Natural; Current_Phase : Client_Phase; Timeouts : Timeouts_Values; -- Cleaner : Cleaner_Access; end record; end AWS.Client; polyorb-2.8~20110207.orig/src/aws/aws-server-get_status.ads0000644000175000017500000000432111750740337022740 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- A W S . S E R V E R . G E T _ S T A T U S -- -- -- -- S p e c -- -- -- -- Copyright (C) 2000-2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ private function AWS.Server.Get_Status (Server : HTTP) return String; -- Returns Server status information. Data returned by this function will -- be displayed when in the administrative server page. polyorb-2.8~20110207.orig/src/aws/soap-message.adb0000644000175000017500000001044011750740337021024 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- S O A P . M E S S A G E -- -- -- -- B o d y -- -- -- -- Copyright (C) 2000-2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with SOAP.Types; with SOAP.Utils; package body SOAP.Message is ---------------- -- Name_Space -- ---------------- function Name_Space (M : Object'Class) return String is begin return To_String (M.Name_Space); end Name_Space; ---------------- -- Parameters -- ---------------- function Parameters (M : Object'Class) return SOAP.Parameters.List is begin return M.P; end Parameters; -------------------- -- Set_Name_Space -- -------------------- procedure Set_Name_Space (M : in out Object'Class; Name : String) is begin M.Name_Space := To_Unbounded_String (Name); end Set_Name_Space; -------------------- -- Set_Parameters -- -------------------- procedure Set_Parameters (M : in out Object'Class; P_Set : SOAP.Parameters.List) is begin M.P := P_Set; end Set_Parameters; ---------------------- -- Set_Wrapper_Name -- ---------------------- procedure Set_Wrapper_Name (M : in out Object'Class; Name : String) is begin M.Wrapper_Name := To_Unbounded_String (Name); end Set_Wrapper_Name; ------------------ -- Wrapper_Name -- ------------------ function Wrapper_Name (M : Object'class) return String is begin return To_String (M.Wrapper_Name); end Wrapper_Name; --------------- -- XML_Image -- --------------- function XML_Image (M : Object) return Unbounded_String is New_Line : constant String := ASCII.CR & ASCII.LF; NS : constant String := Name_Space (M); Message_Body : Unbounded_String; begin -- Procedure Append (Message_Body, "" & New_Line); -- Procedure's parameters declare P : constant SOAP.Parameters.List := Parameters (M); begin for K in 1 .. SOAP.Parameters.Argument_Count (P) loop Append (Message_Body, Types.XML_Image (SOAP.Parameters.Argument (P, K)) & New_Line); end loop; end; -- Close payload objects. Append (Message_Body, Utils.Tag ("awsns:" & Wrapper_Name (M), False) & New_Line); return Message_Body; end XML_Image; end SOAP.Message; polyorb-2.8~20110207.orig/src/aws/aws-client.adb0000644000175000017500000022230711750740337020515 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- A W S . C L I E N T -- -- -- -- B o d y -- -- -- -- Copyright (C) 2000-2009, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with PolyORB.Requests; with PolyORB.References.URI; with PolyORB.Any; with PolyORB.Any.NVList; with PolyORB.Types; with PolyORB.Log; with AWS.Headers.Set; with AWS.Messages; with AWS.Response.Set; with AWS.Translator; package body AWS.Client is use Ada; use PolyORB.Log; package L is new PolyORB.Log.Facility_Log ("aws.web_client"); procedure O (Message : Standard.String; Level : Log_Level := Debug) renames L.Output; function C (Level : Log_Level := Debug) return Boolean renames L.Enabled; -- type Auth_Attempts_Count is -- array (Authentication_Level) of Natural range 0 .. 2; Debug_On : Boolean := False; -- procedure Debug_Message (Prefix, Message : String); -- pragma Inline (Debug_Message); -- Output Message prefixed with Prefix if Debug_On is True and does -- nothing otherwise. procedure Handle_Request (Connection : in out HTTP_Connection; Method : String; Parameters : Unbounded_String; Result : out Response.Data); -- creates a PolyORB neutral request from parameters, sends it and -- fill in Result with the response -- procedure Get_Response -- (Connection : in out HTTP_Connection; -- Result : out Response.Data; -- Get_Body : Boolean := True); -- Receives response from server for GET and POST and HEAD commands. -- If Get_Body is set then the message body will be read. -- procedure Decrement_Authentication_Attempt -- (Connection : in out HTTP_Connection; -- Counter : in out Auth_Attempts_Count; -- Over : out Boolean); -- Counts the authentication attempts. Over is set to True when -- authentication attempts are over. procedure Set_Authentication (Auth : out Authentication_Type; User : String; Pwd : String; Mode : Authentication_Mode); -- Internal procedure to set authentication parameters. -- procedure Parse_Header -- (Connection : in out HTTP_Connection; -- Answer : out Response.Data; -- Keep_Alive : out Boolean); -- Read server answer and set corresponding variable with the value -- read. Most of the fields are ignored right now. procedure Connect (Connection : in out HTTP_Connection); -- Open the connection. Raises Connection_Error if it is not possible to -- establish the connection. In this case all resources are released and -- Connection.Opened is set to False. procedure Disconnect (Connection : in out HTTP_Connection); -- Close connection. Further use is not possible. -- procedure Open_Send_Common_Header -- (Connection : in out HTTP_Connection; -- Method : String; -- URI : String); -- Open the the Connection if it is not open. Send the common HTTP headers -- for all requests like the proxy, authentification, user agent, host. procedure Set_Phase (Connection : in out HTTP_Connection; Phase : Client_Phase); pragma Inline (Set_Phase); -- Set the phase for the connection. This will activate the Send and -- Receive timeouts of the cleaner task if needed. -- procedure Send_Header -- (Sock : Net.Socket_Type'Class; -- Data : String); -- pragma Inline (Send_Header); -- Send header Data to socket and call Debug_Message. ------------------ -- Cleaner_Task -- ------------------ -- task body Cleaner_Task is -- Connection : HTTP_Connection_Access; -- Forever : constant Duration := Duration'Last; -- P : Client_Phase := Not_Monitored; -- W : Duration; -- Timeout : Boolean; -- begin -- accept Start (Connection : HTTP_Connection_Access) do -- Cleaner_Task.Connection := Connection; -- end Start; -- Phase_Loop : loop -- -- Wait for the job to be done -- case P is -- when Stopped => -- exit Phase_Loop; -- when Not_Monitored => -- W := Forever; -- when Receive => -- W := Duration (Connection.Timeouts.Receive); -- when Send => -- W := Duration (Connection.Timeouts.Send); -- end case; -- if W = 0.0 then -- P := Not_Monitored; -- W := Forever; -- end if; -- select -- accept Next_Phase do -- P := Connection.Current_Phase; -- Timeout := False; -- end Next_Phase; -- or -- delay W; -- Timeout := True; -- end select; -- -- Still in the same phase after the delay, just close the socket -- -- now. -- if Timeout -- and then P /= Not_Monitored -- and then Connection.Opened -- then -- Disconnect (Connection.all); -- end if; -- end loop Phase_Loop; -- exception -- when E : others => -- Text_IO.Put_Line (Exceptions.Exception_Information (E)); -- end Cleaner_Task; ----------- -- Close -- ----------- procedure Close (Connection : in out HTTP_Connection) is -- procedure Free is new Ada.Unchecked_Deallocation -- (Cleaner_Task, Cleaner_Access); begin Connection.Current_Phase := Stopped; -- if Connection.Cleaner /= null then -- begin -- -- We don't want to fail here, we really want to free the cleaner -- -- object. -- if not Connection.Cleaner'Terminated then -- Connection.Cleaner.Next_Phase; -- end if; -- exception -- when others => -- null; -- end; -- while not Connection.Cleaner'Terminated loop -- delay 0.01; -- end loop; -- Free (Connection.Cleaner); -- end if; Disconnect (Connection); -- Net.Free (Connection.Socket); end Close; ------------- -- Connect -- ------------- procedure Connect (Connection : in out HTTP_Connection) is -- use type Net.Socket_Access; -- Connect_URL : AWS.URL.Object renames Connection.Connect_URL; begin null; -- pragma Assert (not Connection.Opened); -- -- This should never be called with an open connection. -- -- Keep-alive reconnection will be with old socket. We cannot reuse it, -- -- and have to free it. -- if Connection.Socket /= null then -- Net.Free (Connection.Socket); -- end if; -- Connection.Socket := Net.Socket (AWS.URL.Security (Connect_URL)); -- Net.Connect (Connection.Socket.all, -- AWS.URL.Host (Connect_URL), -- AWS.URL.Port (Connect_URL)); Connection.Opened := True; -- exception -- when E : Net.Socket_Error => -- Connection.Opened := False; -- Exceptions.Raise_Exception -- (Connection_Error'Identity, -- "can't connect to " & AWS.URL.URL (Connect_URL) -- & " -> " & Exceptions.Exception_Information (E)); end Connect; ----------------- -- Copy_Cookie -- ----------------- procedure Copy_Cookie (Source : HTTP_Connection; Destination : in out HTTP_Connection) is begin Destination.Cookie := Source.Cookie; end Copy_Cookie; ------------ -- Create -- ------------ procedure Create (Connection : in out HTTP_Connection; Host : String; User : String := No_Data; Pwd : String := No_Data; Proxy : String := No_Data; Proxy_User : String := No_Data; Proxy_Pwd : String := No_Data; Retry : Natural := Retry_Default; SOAPAction : String := No_Data; Persistent : Boolean := True; Timeouts : Timeouts_Values := No_Timeout; Server_Push : Boolean := False) is function Set (V : String) return Unbounded_String; -- Returns V as an Unbounded_String if V is not the empty string -- otherwise it returns Null_Unbounded_String. --------- -- Set -- --------- function Set (V : String) return Unbounded_String is begin if V = No_Data then return Null_Unbounded_String; else return To_Unbounded_String (V); end if; end Set; Connect_URL : AWS.URL.Object; Host_URL : AWS.URL.Object := AWS.URL.Parse (Host); Proxy_URL : AWS.URL.Object := AWS.URL.Parse (Proxy); begin -- If there is a proxy, the host to connect to is the proxy otherwise -- we connect to the Web server. if Proxy = No_Data then Connect_URL := Host_URL; else Connect_URL := Proxy_URL; end if; Connection.Host := To_Unbounded_String (Host); Connection.Host_URL := Host_URL; Connection.Connect_URL := Connect_URL; Connection.Auth (WWW).User := Set (User); Connection.Auth (WWW).Pwd := Set (Pwd); Connection.Proxy := Set (Proxy); Connection.Proxy_URL := Proxy_URL; Connection.Auth (Client.Proxy).User := Set (Proxy_User); Connection.Auth (Client.Proxy).Pwd := Set (Proxy_Pwd); Connection.Retry := Create.Retry; Connection.Cookie := Null_Unbounded_String; Connection.SOAPAction := Set (SOAPAction); Connection.Persistent := Persistent; Connection.Current_Phase := Not_Monitored; Connection.Server_Push := Server_Push; Connection.Timeouts := Timeouts; -- Establish the connection now Connect (Connection); if Persistent and then Connection.Retry = 0 then -- In this case the connection termination can be initiated by the -- server or the client after a period. So the connection could be -- closed while trying to get some data from the server. To be nicer -- from user's point of view just make sure we retry at least one -- time before reporting an error. Connection.Retry := 1; end if; if Connection.Timeouts /= No_Timeout then null; -- If we have some timeouts, initialize the cleaner task. -- Connection.Cleaner := new Cleaner_Task; -- Connection.Cleaner.Start (Connection.Self); end if; end Create; ------------------- -- Debug_Message -- ------------------- -- procedure Debug_Message (Prefix, Message : String) is -- begin -- if Debug_On then -- Text_IO.Put_Line (Prefix & Message); -- end if; -- end Debug_Message; -------------------------------------- -- Decrement_Authentication_Attempt -- -------------------------------------- -- procedure Decrement_Authentication_Attempt -- (Connection : in out HTTP_Connection; -- Counter : in out Auth_Attempts_Count; -- Over : out Boolean) -- is -- type Over_Data is array (Authentication_Level) of Boolean; -- Is_Over : constant Over_Data := (others => True); -- Over_Level : Over_Data := (others => True); -- begin -- for Level in Authentication_Level'Range loop -- if Connection.Auth (Level).Requested then -- Counter (Level) := Counter (Level) - 1; -- Over_Level (Level) := Counter (Level) = 0; -- end if; -- end loop; -- Over := Over_Level = Is_Over; -- end Decrement_Authentication_Attempt; ---------------- -- Disconnect -- ---------------- procedure Disconnect (Connection : in out HTTP_Connection) is -- use type Net.Socket_Access; begin if Connection.Opened then Connection.Opened := False; -- if Connection.Socket /= null then -- Net.Shutdown (Connection.Socket.all); -- end if; end if; end Disconnect; -------------------- -- Handle_Request -- -------------------- procedure Handle_Request (Connection : in out HTTP_Connection; Method : String; Parameters : Unbounded_String; Result : out Response.Data) is use PolyORB.Any.NVList; use PolyORB.Any; use PolyORB.Any.TypeCode; use PolyORB.Types; use PolyORB.References; use PolyORB.Requests; use AWS.URL; Args : PolyORB.Any.NVList.Ref; PolyORB_Request : PolyORB.Requests.Request_Access; PolyORB_Response : PolyORB.Any.NamedValue; Reference : constant String := Protocol (Connection.Host_URL) & "://" & Host (Connection.Host_URL) & ":" & Port (Connection.Host_URL) & Path (Connection.Host_URL) & File (Connection.Host_URL); begin pragma Debug (C, O ("Handle_Request: building a " & Method & " request")); pragma Debug (C, O ("Handle_Request: Reference is " & Reference)); Create (Args); declare use AWS.Translator; Eq_Idx, Amp_Idx : Natural; Params : Unbounded_String := Parameters; begin -- Params is supposed to be like this : -- param=value¶m=value... Append (Params, "&"); -- here we add an extra ampersand at then of the parameters -- string in order to handle uniform pattern for parameters: -- name=value& pragma Debug (C, O ("Handle_Request: parameter string is <" & To_String (Params) & ">")); while Length (Params) > 1 loop Eq_Idx := Ada.Strings.Unbounded.Index (Params, "="); Amp_Idx := Ada.Strings.Unbounded.Index (Params, "&"); pragma Debug (C, O ("Handle_Request: parameter name: " & (Slice (Params, 1, Eq_Idx - 1)))); pragma Debug (C, O ("Handle_Request: parameter val.: " & (Slice (Params, Eq_Idx + 1, Amp_Idx - 1)))); Add_Item (Args, (Name => To_PolyORB_String (Slice (Params, 1, Eq_Idx - 1)), Argument => To_Any (To_PolyORB_String (Slice (Params, Eq_Idx + 1, Amp_Idx - 1))), Arg_Modes => PolyORB.Any.ARG_IN)); Delete (Params, 1, Amp_Idx); -- we purge the parameter that has just been read if Amp_Idx = 0 then raise URL_Error; -- this is not supposed to happen, as we added an -- extra '&' at the end of the parameters. But then we -- would get an infinite loop, since Delete (Params, -- 1, 0) does not delete anything end if; end loop; -- we parse each parameter line to retreive the name -- and the content of the parameters, and then we -- create an any of typecode string pragma Debug (C, O ("Handle_Request: parameter string is now <" & To_String (Params) & ">")); end; Create_Request (Target => PolyORB.References.URI.String_To_Object (Reference), Operation => Method, Arg_List => Args, Result => PolyORB_Response, Req => PolyORB_Request); Invoke (PolyORB_Request); pragma Debug (C, O ("Type of response is " & Image (Get_Unwound_Type (PolyORB_Request.Result.Argument)))); declare Kind_Of_Result : constant PolyORB.Any.TCKind := Kind (Get_Unwound_Type (PolyORB_Request.Result.Argument)); begin if Kind_Of_Result = Tk_String then -- Typical situation: we get an html page, or any kind of -- text. Response.Set.Message_Body (Result, To_Standard_String (From_Any (PolyORB_Request.Result.Argument))); elsif Kind_Of_Result = Tk_Sequence and then PolyORB.Any.TypeCode.Kind (PolyORB.Any.TypeCode.Content_Type (PolyORB.Any.Get_Type (PolyORB_Request.Result.Argument))) /= Tk_Octet then -- If we get a binary file, e.g. an image. That is to -- say a sequence of octets. declare use Ada.Streams; Number_Of_Elements : constant Unsigned_Long := PolyORB.Any.Get_Aggregate_Count (PolyORB_Request.Result.Argument); Byte_Stream : Stream_Element_Array (0 .. Stream_Element_Offset (Number_Of_Elements) - 1); begin pragma Debug (C, O ("Handle_Request: Tk_Sequence: " & "attempting to retrieve" & Unsigned_Long'Image (Number_Of_Elements) & " bytes")); for Index in 0 .. Number_Of_Elements - 1 loop declare Element : constant PolyORB.Types.Octet := PolyORB.Any.From_Any (PolyORB.Any.Get_Aggregate_Element (PolyORB_Request.Result.Argument, PolyORB.Any.TypeCode.TC_Octet, Index)); begin Byte_Stream (Stream_Element_Offset (Index)) := Stream_Element (Element); end; end loop; Response.Set.Message_Body (Result, Byte_Stream); end; else raise Program_Error; -- If we get an unhandled type, we fail. end if; end; end Handle_Request; --------- -- Get -- --------- function Get (URL : String; User : String := No_Data; Pwd : String := No_Data; Proxy : String := No_Data; Proxy_User : String := No_Data; Proxy_Pwd : String := No_Data; Timeouts : Timeouts_Values := No_Timeout; Follow_Redirection : Boolean := False) return Response.Data is use type Messages.Status_Code; Result : Response.Data; begin declare Connection : HTTP_Connection; begin Create (Connection, URL, User, Pwd, Proxy, Proxy_User, Proxy_Pwd, Persistent => False, Timeouts => Timeouts); Get (Connection, Result); Close (Connection); exception when others => Close (Connection); raise; end; if Follow_Redirection and then Response.Status_Code (Result) = Messages.S305 then -- This is "Use Proxy" message, Location point to the proxy to use. -- We do not have the login/password for the proxy. return Get (URL, User, Pwd, Response.Location (Result), Timeouts => Timeouts, Follow_Redirection => Follow_Redirection); elsif Follow_Redirection and then Response.Status_Code (Result) in Messages.S301 .. Messages.S307 and then Response.Status_Code (Result) /= Messages.S304 then -- All other redirections, 304 is not one of them. return Get (Response.Location (Result), User, Pwd, Proxy, Proxy_User, Proxy_Pwd, Timeouts, Follow_Redirection); else return Result; end if; end Get; --------- -- Get -- --------- procedure Get (Connection : in out HTTP_Connection; Result : out Response.Data; URI : String := No_Data) is -- this is the main 'get' function. All other get functions call -- this one use AWS.URL; begin if URI /= No_Data then declare Overriding_URI : URL.Object := Parse (URI); Parameters : constant Unbounded_String := To_Unbounded_String (URL.Query (Overriding_URI)); begin Connection.Host_URL := Overriding_URI; Connection.Host := To_Unbounded_String (Host (Overriding_URI)); Handle_Request (Connection, "GET", Parameters, Result); end; else declare Parameters : constant Unbounded_String := To_Unbounded_String (URL.Query (Connection.Host_URL)); begin Handle_Request (Connection, "GET", Parameters, Result); end; end if; end Get; ------------------ -- Get_Response -- ------------------ -- procedure Get_Response -- (Connection : in out HTTP_Connection; -- Result : out Response.Data; -- Get_Body : Boolean := True) -- is -- subtype Stream_Element_Array_Access is Utils.Stream_Element_Array_Access; -- function Read_Chunk return Stream_Element_Array_Access; -- -- Read a chunk object from the stream -- function Read_Binary_Message -- (Len : Positive) -- return Stream_Element_Array_Access; -- pragma Inline (Read_Binary_Message); -- -- Read a binary message of Len bytes from the socket. -- procedure Disconnect; -- -- close connection socket. -- -- Sock : Net.Socket_Type'Class renames Connection.Socket.all; -- Keep_Alive : constant Boolean := False; -- ---------------- -- -- Disconnect -- -- ---------------- -- procedure Disconnect is -- begin -- if not Keep_Alive and not Connection.Server_Push then -- Disconnect (Connection); -- end if; -- end Disconnect; -- ------------------------- -- -- Read_Binary_Message -- -- ------------------------- -- function Read_Binary_Message -- (Len : Positive) -- return Stream_Element_Array_Access -- is -- use Streams; -- Elements : Stream_Element_Array_Access -- := new Stream_Element_Array (1 .. Stream_Element_Offset (Len)); -- S, E : Stream_Element_Offset; -- begin -- S := 1; -- -- Read the message, 10k at a time -- loop -- E := Stream_Element_Offset'Min -- (Stream_Element_Offset (Len), S + 10_239); -- -- Net.Buffered.Read (Sock, Elements (S .. E)); -- S := E + 1; -- exit when S > Stream_Element_Offset (Len); -- end loop; -- return Elements; -- exception -- -- when Net.Socket_Error => -- when others => -- -- Could have been killed by a timeout. -- Utils.Free (Elements); -- raise; -- end Read_Binary_Message; -- ---------------- -- -- Read_Chunk -- -- ---------------- -- function Read_Chunk return Stream_Element_Array_Access is -- use Streams; -- use type Stream_Element_Array; -- use type Stream_Element_Offset; -- procedure Skip_Line; -- -- skip a line on the socket -- Data : Stream_Element_Array_Access -- := new Streams.Stream_Element_Array (1 .. 10_000); -- Data_Last : Streams.Stream_Element_Offset := 0; -- --------------- -- -- Skip_Line -- -- --------------- -- procedure Skip_Line is -- -- D : constant String := Net.Buffered.Get_Line (Sock); -- D : constant String := "toto"; -- pragma Warnings (Off, D); -- begin -- null; -- end Skip_Line; -- Size : Stream_Element_Offset; -- Tmp : Stream_Element_Array_Access; -- begin -- loop -- -- Read the chunk size that is an hex number -- declare -- -- L : constant String := Net.Buffered.Get_Line (Sock); -- L : constant String := "toto"; -- begin -- Size := Stream_Element_Offset -- (Utils.Hex_Value (Strings.Fixed.Trim (L, Strings.Both))); -- end; -- if Size = 0 then -- Skip_Line; -- exit; -- else -- if Data_Last + Size > Data'Last then -- Tmp := new Stream_Element_Array -- (1 .. -- Stream_Element_Offset'Max -- (Data_Last + Size, 2 * Data'Length)); -- Tmp (1 .. Data_Last) := Data (1 .. Data_Last); -- Utils.Free (Data); -- Data := Tmp; -- end if; -- -- Net.Buffered.Read -- -- (Sock, Data (Data_Last + 1 .. Data_Last + Size)); -- Skip_Line; -- Data_Last := Data_Last + Size; -- end if; -- end loop; -- -- Strip the unused bytes -- declare -- Copy : constant Stream_Element_Array_Access -- := new Stream_Element_Array (1 .. Data_Last); -- begin -- Copy.all := Data (1 .. Data_Last); -- Utils.Free (Data); -- return Copy; -- end; -- exception -- when others => -- -- Could have been killed by a timeout. -- Utils.Free (Data); -- raise; -- end Read_Chunk; -- begin -- Set_Phase (Connection, Receive); -- -- Parse_Header -- -- (Connection, Result, Keep_Alive); -- if not Get_Body then -- Disconnect; -- Set_Phase (Connection, Not_Monitored); -- return; -- end if; -- -- -- Read the message body -- declare -- TE : constant String -- := Response.Header (Result, Messages.Transfer_Encoding_Token); -- CT_Len : constant Integer := Response.Content_Length (Result); -- begin -- if TE = "chunked" then -- -- -- A chuncked message is written on the stream as list of data -- -- -- chunk. Each chunk has the following format: -- -- -- -- -- -- CRLF -- -- -- CRLF -- -- -- -- -- -- The termination chunk is: -- -- -- -- -- -- 0 CRLF -- -- -- CRLF -- -- -- -- Response.Set.Message_Body (Result, Read_Chunk); -- else -- if CT_Len = Response.Undefined_Length then -- declare -- package Stream_Element_Table is new GNAT.Table -- (Streams.Stream_Element, -- Natural, -- Table_Low_Bound => 1, -- Table_Initial => 30_000, -- Table_Increment => 25); -- procedure Add (B : Streams.Stream_Element_Array); -- -- Add B to Data -- procedure Read_Until_Close; -- -- Read data on socket, stop when the socket is closed. -- --------- -- -- Add -- -- --------- -- procedure Add (B : Streams.Stream_Element_Array) is -- begin -- for K in B'Range loop -- Stream_Element_Table.Append (B (K)); -- end loop; -- end Add; -- ---------------------- -- -- Read_Until_Close -- -- ---------------------- -- procedure Read_Until_Close is -- begin -- loop -- declare -- Data : constant Streams.Stream_Element_Array -- := (45, 56); -- -- Data : constant Streams.Stream_Element_Array -- -- := Net.Buffered.Read (Sock); -- begin -- Add (Data); -- end; -- end loop; -- exception -- -- when Net.Socket_Error => -- when others => -- null; -- end Read_Until_Close; -- begin -- Read_Until_Close; -- Response.Set.Message_Body (Result, -- (Streams.Stream_Element_Array -- (Stream_Element_Table.Table -- (1 .. Stream_Element_Table.Last)))); -- Stream_Element_Table.Free; -- end; -- else -- if CT_Len = 0 then -- Response.Set.Message_Body -- (Result, Streams.Stream_Element_Array'(1 .. 0 => 0)); -- else -- declare -- Elements : constant Stream_Element_Array_Access -- := Read_Binary_Message (CT_Len); -- begin -- Response.Set.Message_Body (Result, Elements); -- end; -- end if; -- end if; -- end if; -- end; -- Disconnect; -- Set_Phase (Connection, Not_Monitored); -- end Get_Response; ---------- -- Head -- ---------- function Head (URL : String; User : String := No_Data; Pwd : String := No_Data; Proxy : String := No_Data; Proxy_User : String := No_Data; Proxy_Pwd : String := No_Data; Timeouts : Timeouts_Values := No_Timeout) return Response.Data is Connection : HTTP_Connection; Result : Response.Data; begin Create (Connection, URL, User, Pwd, Proxy, Proxy_User, Proxy_Pwd, Persistent => False, Timeouts => Timeouts); Head (Connection, Result); Close (Connection); return Result; exception when others => Close (Connection); raise; end Head; ---------- -- Head -- ---------- procedure Head (Connection : in out HTTP_Connection; Result : out Response.Data; URI : String := No_Data) is -- this is the main 'head' function. HEAD is like GET, but -- without message body in the response use AWS.URL; begin if URI /= No_Data then declare Overriding_URI : URL.Object := Parse (URI); Parameters : constant Unbounded_String := To_Unbounded_String (URL.Query (Overriding_URI)); begin Connection.Host_URL := Overriding_URI; Connection.Host := To_Unbounded_String (Host (Overriding_URI)); Handle_Request (Connection, "HEAD", Parameters, Result); end; else declare Parameters : constant Unbounded_String := To_Unbounded_String (URL.Query (Connection.Host_URL)); begin Handle_Request (Connection, "HEAD", Parameters, Result); end; end if; end Head; ----------------------------- -- Open_Send_Common_Header -- ----------------------------- -- procedure Open_Send_Common_Header -- (Connection : in out HTTP_Connection; -- Method : String; -- URI : String) -- is -- pragma Warnings (Off); -- pragma Unreferenced (Method); -- pragma Warnings (On); -- -- Sock : Net.Socket_Access renames Connection.Socket; -- No_Data : Unbounded_String renames Null_Unbounded_String; -- procedure Send_Authentication_Header -- (Token : String; -- Data : in out Authentication_Type); -- -- Send the authentication header for proxy or for server. -- -- function HTTP_Prefix (Security : Boolean) return String; -- -- Returns "http://" or "https://" if Security is set to True. -- -- function Persistence return String; -- -- Returns "Keep-Alive" is we have a persistent connection and "Close" -- -- otherwise. -- -- function Port_Not_Default (Port : Positive) return String; -- -- Returns the port image (preceded by character ':') if it is not the -- -- default port. -- ----------------- -- -- HTTP_Prefix -- -- ----------------- -- -- function HTTP_Prefix (Security : Boolean) return String is -- -- begin -- -- if Security then -- -- return "https://"; -- -- else -- -- return "http://"; -- -- end if; -- -- end HTTP_Prefix; -- ----------------- -- -- Persistence -- -- ----------------- -- -- function Persistence return String is -- -- begin -- -- if Connection.Persistent then -- -- return "Keep-Alive"; -- -- else -- -- return "Close"; -- -- end if; -- -- end Persistence; -- ---------------------- -- -- Port_Not_Default -- -- ---------------------- -- -- function Port_Not_Default (Port : Positive) return String is -- -- begin -- -- if Port = 80 then -- -- return ""; -- -- else -- -- declare -- -- Port_Image : constant String := Positive'Image (Port); -- -- begin -- -- return ':' & Port_Image (2 .. Port_Image'Last); -- -- end; -- -- end if; -- -- end Port_Not_Default; -- -------------------------------- -- -- Send_Authentication_Header -- -- -------------------------------- -- procedure Send_Authentication_Header -- (Token : String; -- Data : in out Authentication_Type) -- is -- pragma Warnings (Off); -- pragma Unreferenced (Token); -- pragma Warnings (On); -- -- Username : constant String := To_String (Data.User); -- begin -- if Data.User /= No_Data -- and then Data.Pwd /= No_Data -- then -- if Data.Work_Mode = Basic then -- null; -- -- Send_Header -- -- (Sock.all, -- -- Token & ": Basic " -- -- & AWS.Translator.Base64_Encode -- -- (Username -- -- & ':' & To_String (Data.Pwd))); -- elsif Data.Work_Mode = Digest then -- declare -- -- Nonce : constant String := To_String (Data.Nonce); -- -- Realm : constant String := To_String (Data.Realm); -- -- QOP : constant String := To_String (Data.QOP); -- -- function Get_URI return String; -- -- Returns the real URI where the request is going to be -- -- sent. It is either Open_Send_Common_Header.URI parameter -- -- if it exists (without the HTTP parameters part), or URI -- -- part of the Connection.Connect_URL field. -- -- function QOP_Data return String; -- -- Returns string with qop, cnonce and nc parameters -- -- if qop parameter exists in the server auth request, -- -- or empty string if not [RFC 2617 - 3.2.2]. -- -- Response : AWS.Digest.Digest_String; -- -- Response : constant AWS.Digest.Digest_String := "t"; -- ------------- -- -- Get_URI -- -- ------------- -- -- function Get_URI return String is -- -- URI_Last : Natural; -- -- begin -- -- if URI = "" then -- -- return URL.Path (Connection.Connect_URL) -- -- & URL.File (Connection.Connect_URL); -- -- else -- -- URI_Last := Strings.Fixed.Index (URI, "?"); -- -- if URI_Last = 0 then -- -- URI_Last := URI'Last; -- -- else -- -- URI_Last := URI_Last - 1; -- -- end if; -- -- return URI (URI'First .. URI_Last); -- -- end if; -- -- end Get_URI; -- -- URI : constant String := Get_URI; -- -------------- -- -- QOP_Data -- -- -------------- -- -- function QOP_Data return String is -- -- CNonce : constant String := AWS.Digest.Create_Nonce; -- -- begin -- -- if QOP = No_Data then -- -- Response := AWS.Digest.Create_Digest -- -- (Username => Username, -- -- Realm => Realm, -- -- Password => To_String (Data.Pwd), -- -- Nonce => Nonce, -- -- Method => Method, -- -- URI => URI); -- -- return ""; -- -- else -- -- Data.NC := Data.NC + 1; -- -- declare -- -- NC : constant String := Utils.Hex (Data.NC, 8); -- -- begin -- -- Response := AWS.Digest.Create_Digest -- -- (Username => Username, -- -- Realm => Realm, -- -- Password => To_String (Data.Pwd), -- -- Nonce => Nonce, -- -- CNonce => CNonce, -- -- NC => NC, -- -- QOP => QOP, -- -- Method => Method, -- -- URI => URI); -- -- return "qop=""" & QOP -- -- & """, cnonce=""" & CNonce -- -- & """, nc=" & NC -- -- & ", "; -- -- end; -- -- end if; -- -- end QOP_Data; -- begin -- null; -- -- Send_Header -- -- (Sock.all, -- -- Token & ": Digest " -- -- & QOP_Data -- -- & "nonce=""" & Nonce -- -- & """, username=""" & Username -- -- & """, realm=""" & Realm -- -- & """, uri=""" & URI -- -- & """, response=""" & Response -- -- & """"); -- end; -- end if; -- end if; -- end Send_Authentication_Header; -- -- Host_Address : constant String -- -- := AWS.URL.Host (Connection.Host_URL) -- -- & Port_Not_Default (AWS.URL.Port (Connection.Host_URL)); -- begin -- -- Open connection if needed. -- if not Connection.Opened then -- Connect (Connection); -- end if; -- Set_Phase (Connection, Send); -- -- Header command. -- if Connection.Proxy = No_Data then -- if URI = "" then -- null; -- -- Send_Header -- -- (Sock.all, -- -- Method & ' ' -- -- & AWS.URL.Pathname_And_Parameters (Connection.Host_URL, False) -- -- & ' ' & HTTP_Version); -- else -- -- URI should already be encoded, but to help a bit Windows -- -- systems who tend to have spaces into URL we encode them here. -- declare -- E_URI : String := URI; -- begin -- for K in E_URI'Range loop -- if E_URI (K) = ' ' then -- E_URI (K) := '+'; -- end if; -- end loop; -- -- Send_Header -- -- (Sock.all, -- -- Method & ' ' & E_URI & ' ' & HTTP_Version); -- end; -- end if; -- -- Send_Header -- -- (Sock.all, Messages.Connection (Persistence)); -- else -- if URI = "" then -- null; -- -- Send_Header (Sock.all, -- -- Method & ' ' -- -- & To_String (Connection.Host) -- -- & ' ' & HTTP_Version); -- else -- null; -- -- Send_Header -- -- (Sock.all, -- -- Method & ' ' -- -- & HTTP_Prefix (AWS.URL.Security (Connection.Host_URL)) -- -- & Host_Address & URI -- -- & ' ' & HTTP_Version); -- end if; -- -- Send_Header -- -- (Sock.all, Messages.Proxy_Connection (Persistence)); -- end if; -- -- Cookie -- if Connection.Cookie /= No_Data then -- null; -- -- Send_Header -- -- (Sock.all, Messages.Cookie (To_String (Connection.Cookie))); -- end if; -- -- Send_Header (Sock.all, -- -- Messages.Host (Host_Address)); -- -- Send_Header (Sock.all, -- -- Messages.Accept_Type ("text/html, */*")); -- -- Send_Header (Sock.all, -- -- Messages.Accept_Language ("fr, us")); -- -- Send_Header (Sock.all, -- -- Messages.User_Agent ("AWS (Ada Web Server) v" & Version)); -- -- User Authentification -- Send_Authentication_Header -- (Messages.Authorization_Token, Connection.Auth (WWW)); -- -- Proxy Authentification -- Send_Authentication_Header -- (Messages.Proxy_Authorization_Token, Connection.Auth (Proxy)); -- -- SOAP header -- if Connection.SOAPAction /= No_Data then -- null; -- -- Send_Header -- -- (Sock.all, -- -- Messages.SOAPAction (To_String (Connection.SOAPAction))); -- end if; -- Set_Phase (Connection, Not_Monitored); -- end Open_Send_Common_Header; ------------------ -- Parse_Header -- ------------------ -- procedure Parse_Header -- (Connection : in out HTTP_Connection; -- Answer : out Response.Data; -- Keep_Alive : out Boolean) -- is -- -- Sock : Net.Socket_Type'Class renames Connection.Socket.all; -- Status : Messages.Status_Code; -- Request_Auth_Mode : array (Authentication_Level) of Authentication_Mode -- := (others => Any); -- procedure Parse_Authenticate_Line -- (Level : Authentication_Level; -- Auth_Line : String); -- -- Parses Authentication request line and fill Connection.Auth (Level) -- -- field with the information read on the line. Handle WWW and Proxy -- -- authentication. -- procedure Read_Status_Line; -- -- Read the status line. -- procedure Set_Keep_Alive (Data : String); -- -- Set the Parse_Header.Keep_Alive depending on data from the -- -- Proxy-Connection or Connection header line. -- function "+" (S : String) return Unbounded_String -- renames To_Unbounded_String; -- ----------------------------- -- -- Parse_Authenticate_Line -- -- ----------------------------- -- procedure Parse_Authenticate_Line -- (Level : Authentication_Level; -- Auth_Line : String) -- is -- use Ada.Characters.Handling; -- Basic_Token : constant String := "BASIC"; -- Digest_Token : constant String := "DIGEST"; -- Auth : Authentication_Type renames Connection.Auth (Level); -- Request_Mode : Authentication_Mode; -- Read_Params : Boolean := False; -- -- Set it to true when the authentication -- -- mode is stronger then before. -- procedure Value -- (Item : String; -- Quit : in out Boolean); -- -- Routine receiving unnamed value during parsing of -- -- authentication line. -- procedure Named_Value -- (Name : String; -- Value : String; -- Quit : in out Boolean); -- -- Routine receiving name/value pairs during parsing of -- -- authentication line. -- ----------------- -- -- Named_Value -- -- ----------------- -- procedure Named_Value -- (Name : String; -- Value : String; -- Quit : in out Boolean) -- is -- pragma Warnings (Off, Quit); -- U_Name : constant String := To_Upper (Name); -- begin -- if not Read_Params then -- return; -- end if; -- if U_Name = "REALM" then -- Auth.Realm := +Value; -- elsif U_Name = "NONCE" then -- Auth.Nonce := +Value; -- elsif U_Name = "QOP" then -- Auth.QOP := +Value; -- elsif U_Name = "ALGORITHM" then -- if Value /= "MD5" then -- Ada.Exceptions.Raise_Exception -- (Constraint_Error'Identity, -- "Only MD5 algorithm is supported."); -- end if; -- -- The parameter Stale is true when the Digest value is correct -- -- but the nonce value is too old or incorrect. -- -- -- -- This mean that an interactive HTTP client should not ask -- -- name/password from the user, and try to use name/password from -- -- the previous successful authentication attempt. -- -- We do not need to check Stale authentication parameter -- -- for now, because our client is not interactive, so we are not -- -- going to ask user to input the name/password anyway. We could -- -- uncomment it later, when we would provide some interactive -- -- behavior to AWS.Client or interface to the interactive -- -- programs by callback to the AWS.Client. -- -- -- -- elsif U_Name = "STALE" then -- -- null; -- end if; -- end Named_Value; -- ----------- -- -- Value -- -- ----------- -- procedure Value -- (Item : String; -- Quit : in out Boolean) -- is -- pragma Warnings (Off, Quit); -- Mode_Image : constant String := To_Upper (Item); -- begin -- if Mode_Image = Digest_Token then -- Request_Mode := Digest; -- elsif Mode_Image = Basic_Token then -- Request_Mode := Basic; -- end if; -- Read_Params := Request_Mode > Request_Auth_Mode (Level); -- if Read_Params then -- Request_Auth_Mode (Level) := Request_Mode; -- Auth.Requested := True; -- Auth.Work_Mode := Request_Mode; -- Auth.NC := 0; -- end if; -- end Value; -- ----------- -- -- Parse -- -- ----------- -- procedure Parse is new Headers.Values.Parse (Value, Named_Value); -- begin -- Parse (Auth_Line); -- end Parse_Authenticate_Line; -- ----------------------- -- -- Read_Status_Line -- -- ----------------------- -- procedure Read_Status_Line is -- function Get_Full_Line return String; -- -- Returns a full HTTP line (handle continuation line) -- -- -- -- ??? This is non-standard and as been implemented because some -- -- Lotus Domino servers do send a Reason-Phrase with continuation -- -- line. This is clearly not valid see [RFC 2616 - 6.1]. -- ------------------- -- -- Get_Full_Line -- -- ------------------- -- function Get_Full_Line return String is -- -- Line : constant String := Net.Buffered.Get_Line (Sock); -- -- N_Char : constant Character := Net.Buffered.Peek_Char (Sock); -- Line : constant String := "toto"; -- -- N_Char : constant Character := 'T'; -- begin -- -- if N_Char = ' ' or else N_Char = ASCII.HT then -- -- Next line is a continuation line [RFC 2616 - 2.2], but -- -- again this is non standard here, see comment above. -- -- return Line & Get_Full_Line; -- -- else -- return Line; -- -- end if; -- end Get_Full_Line; -- Line : constant String := Get_Full_Line; -- begin -- Debug_Message ("< ", Line); -- -- Checking the first line in the HTTP header. -- -- It must match Messages.HTTP_Token. -- if Messages.Match (Line, Messages.HTTP_Token) then -- Status := Messages.Status_Code'Value -- ('S' & Line (Messages.HTTP_Token'Last + 5 -- .. Messages.HTTP_Token'Last + 7)); -- Response.Set.Status_Code (Answer, Status); -- -- By default HTTP/1.0 connection is not keep-alive but -- -- HTTP/1.1 is keep-alive -- Keep_Alive -- := Line (Messages.HTTP_Token'Last + 1 -- .. Messages.HTTP_Token'Last + 3) >= "1.1"; -- else -- -- or else it is wrong answer from server. -- Ada.Exceptions.Raise_Exception (Protocol_Error'Identity, Line); -- end if; -- end Read_Status_Line; -- -------------------- -- -- Set_Keep_Alive -- -- -------------------- -- procedure Set_Keep_Alive (Data : String) is -- begin -- if Messages.Match (Data, "Close") then -- Keep_Alive := False; -- elsif Messages.Match (Data, "Keep-Alive") then -- Keep_Alive := True; -- end if; -- end Set_Keep_Alive; -- use type Messages.Status_Code; -- begin -- for Level in Authentication_Level'Range loop -- Connection.Auth (Level).Requested := False; -- end loop; -- Read_Status_Line; -- -- Response.Set.Read_Header (Sock, Answer); -- -- ??? we should not expect 100 response message after the body sent. -- -- This code needs to be fixed. -- -- We should expect 100 status line only before sending the message -- -- body to server. -- -- And we should send Expect: header line in the header if we could -- -- deal with 100 status code. -- -- See [RFC 2616 - 8.2.3] use of the 100 (Continue) Status. -- if Status = Messages.S100 then -- Read_Status_Line; -- -- Response.Set.Read_Header (Sock, Answer); -- end if; -- Set_Keep_Alive (Response.Header (Answer, Messages.Connection_Token)); -- Set_Keep_Alive (Response.Header -- (Answer, Messages.Proxy_Connection_Token)); -- Connection.Cookie := +Response.Header -- (Answer, Messages.Set_Cookie_Token); -- Parse_Authenticate_Line -- (WWW, -- Response.Header (Answer, Messages.WWW_Authenticate_Token)); -- Parse_Authenticate_Line -- (Proxy, -- Response.Header (Answer, Messages.Proxy_Authenticate_Token)); -- end Parse_Header; ---------- -- Post -- ---------- function Post (URL : String; Data : String; User : String := No_Data; Pwd : String := No_Data; Proxy : String := No_Data; Proxy_User : String := No_Data; Proxy_Pwd : String := No_Data; Timeouts : Timeouts_Values := No_Timeout) return Response.Data is use Streams; begin return Post (URL, Translator.To_Stream_Element_Array (Data), User, Pwd, Proxy, Proxy_User, Proxy_Pwd, Timeouts); end Post; ---------- -- Post -- ---------- function Post (URL : String; Data : Streams.Stream_Element_Array; User : String := No_Data; Pwd : String := No_Data; Proxy : String := No_Data; Proxy_User : String := No_Data; Proxy_Pwd : String := No_Data; Timeouts : Timeouts_Values := No_Timeout) return Response.Data is Connection : HTTP_Connection; Result : Response.Data; begin Create (Connection, URL, User, Pwd, Proxy, Proxy_User, Proxy_Pwd, Persistent => False, Timeouts => Timeouts); Post (Connection, Result, Data); Close (Connection); return Result; exception when others => Close (Connection); raise; end Post; ---------- -- Post -- ---------- procedure Post (Connection : in out HTTP_Connection; Result : out Response.Data; Data : Streams.Stream_Element_Array; URI : String := No_Data) is -- this is the main 'post' function, as all other 'post' -- functions call this one -- No_Data : Unbounded_String renames Null_Unbounded_String; -- Try_Count : Natural := Connection.Retry; -- Auth_Attempts : Auth_Attempts_Count := (others => 2); -- Auth_Is_Over : Boolean; use AWS.URL; begin if URI /= No_Data then declare Overriding_URI : URL.Object := Parse (URI); begin Connection.Host_URL := Overriding_URI; Connection.Host := To_Unbounded_String (Host (Overriding_URI)); end; -- the parameter URI overrides the host set in -- Connection. This is not meant for parameters end if; Handle_Request (Connection, "POST", AWS.Translator.To_Unbounded_String (Data), Result); -- Retry : loop -- begin -- Open_Send_Common_Header (Connection, "POST", URI); -- declare -- -- Sock : Net.Socket_Type'Class renames Connection.Socket.all; -- begin -- if Connection.SOAPAction = No_Data then -- null; -- -- Send_Header -- -- (Sock, -- -- Messages.Content_Type (MIME.Appl_Form_Data)); -- else -- null; -- -- Send_Header -- -- (Sock, -- -- Messages.Content_Type (MIME.Text_XML)); -- end if; -- -- Send message Content_Length -- -- Send_Header (Sock, Messages.Content_Length (Data'Length)); -- -- Net.Buffered.New_Line (Sock); -- -- Send message body -- -- Net.Buffered.Write (Sock, Data); -- end; -- -- Get answer from server -- Get_Response (Connection, Result, not Connection.Server_Push); -- Decrement_Authentication_Attempt -- (Connection, Auth_Attempts, Auth_Is_Over); -- if Auth_Is_Over then -- return; -- end if; -- exception -- when others => raise; -- -- when Net.Socket_Error => -- -- Disconnect (Connection); -- -- if Try_Count = 0 then -- -- Result := Response.Build -- -- (MIME.Text_HTML, "Post Timeout", Messages.S408); -- -- Set_Phase (Connection, Not_Monitored); -- -- exit Retry; -- -- end if; -- -- Try_Count := Try_Count - 1; -- end; -- end loop Retry; end Post; ---------- -- Post -- ---------- procedure Post (Connection : in out HTTP_Connection; Result : out Response.Data; Data : String; URI : String := No_Data) is begin Post (Connection, Result, Translator.To_Stream_Element_Array (Data), URI); end Post; --------- -- Put -- --------- function Put (URL : String; Data : String; User : String := No_Data; Pwd : String := No_Data; Proxy : String := No_Data; Proxy_User : String := No_Data; Proxy_Pwd : String := No_Data; Timeouts : Timeouts_Values := No_Timeout) return Response.Data is Connection : HTTP_Connection; Result : Response.Data; begin Create (Connection, URL, User, Pwd, Proxy, Proxy_User, Proxy_Pwd, Persistent => False, Timeouts => Timeouts); Put (Connection, Result, Data); Close (Connection); return Result; exception when others => Close (Connection); raise; end Put; --------- -- Put -- --------- procedure Put (Connection : in out HTTP_Connection; Result : out Response.Data; Data : String; URI : String := No_Data) is -- this is the main 'put' function -- Keep_Alive : Boolean; -- Try_Count : Natural := Connection.Retry; -- Auth_Attempts : Auth_Attempts_Count := (others => 2); -- Auth_Is_Over : Boolean; use AWS.URL; begin if URI /= No_Data then declare Overriding_URI : URL.Object := Parse (URI); begin Connection.Host_URL := Overriding_URI; Connection.Host := To_Unbounded_String (Host (Overriding_URI)); end; -- the parameter URI overrides the host set in -- Connection. This is not meant for parameters end if; Handle_Request (Connection, "PUT", To_Unbounded_String (Data), Result); -- Retry : loop -- begin -- Open_Send_Common_Header (Connection, "PUT", URI); -- -- Send message Content_Length -- -- Send_Header -- -- (Connection.Socket.all, Messages.Content_Length (Data'Length)); -- -- Net.Buffered.New_Line (Connection.Socket.all); -- -- Send message body -- -- Net.Buffered.Put_Line (Connection.Socket.all, Data); -- -- Get answer from server -- Parse_Header -- (Connection, Result, Keep_Alive); -- if not Keep_Alive then -- Disconnect (Connection); -- end if; -- Decrement_Authentication_Attempt -- (Connection, Auth_Attempts, Auth_Is_Over); -- if Auth_Is_Over then -- return; -- end if; -- exception -- when others => raise; -- -- when Net.Socket_Error => -- -- Disconnect (Connection); -- -- if Try_Count = 0 then -- -- Result := Response.Build -- -- (MIME.Text_HTML, "Put Timeout", Messages.S408); -- -- Set_Phase (Connection, Not_Monitored); -- -- exit Retry; -- -- end if; -- -- Try_Count := Try_Count - 1; -- end; -- end loop Retry; end Put; ---------------- -- Read_Until -- ---------------- function Read_Until (Connection : HTTP_Connection; Delimiter : String) return String is Result : Unbounded_String; begin Read_Until (Connection.Self.all, Delimiter, Result); return To_String (Result); end Read_Until; procedure Read_Until (Connection : in out HTTP_Connection; Delimiter : String; Result : in out Ada.Strings.Unbounded.Unbounded_String) is Sample_Idx : Natural := Delimiter'First; Buffer : String (1 .. 1024); begin Set_Phase (Connection, Receive); Main : loop for I in Buffer'Range loop begin -- Buffer (I) := Net.Buffered.Get_Char (Connection.Socket.all); Buffer (I) := 'T'; exception when others => -- when Net.Socket_Error => -- Append (Result, Buffer (Buffer'First .. I - 1)); exit Main; end; if Buffer (I) = Delimiter (Sample_Idx) then if Sample_Idx = Delimiter'Last then Append (Result, Buffer (Buffer'First .. I)); exit Main; else Sample_Idx := Sample_Idx + 1; end if; else Sample_Idx := Delimiter'First; end if; end loop; Append (Result, Buffer); end loop Main; Set_Phase (Connection, Not_Monitored); end Read_Until; ----------------- -- Send_Header -- ----------------- -- procedure Send_Header -- (Sock : Net.Socket_Type'Class; -- Data : String) is -- begin -- Net.Buffered.Put_Line (Sock, Data); -- Debug_Message ("> ", Data); -- end Send_Header; ------------------------ -- Set_Authentication -- ------------------------ procedure Set_Authentication (Auth : out Authentication_Type; User : String; Pwd : String; Mode : Authentication_Mode) is begin Auth.User := To_Unbounded_String (User); Auth.Pwd := To_Unbounded_String (Pwd); Auth.Init_Mode := Mode; -- The Digest authentication could not be send without -- server authentication request, becouse client have to have nonce -- value, so in the Digest and Any authentication modes we are not -- setting up Work_Mode to the exact value. -- But for Basic authentication we are sending just username/password, -- and do not need any information from server for do it. -- So if the client want to authenticate "Basic", we are setting up -- Work_Mode right now. if Mode = Basic then Auth.Work_Mode := Basic; end if; end Set_Authentication; --------------- -- Set_Debug -- --------------- procedure Set_Debug (On : Boolean) is begin Debug_On := not Debug_On; Debug_On := On; AWS.Headers.Set.Debug (On); end Set_Debug; --------------- -- Set_Phase -- --------------- procedure Set_Phase (Connection : in out HTTP_Connection; Phase : Client_Phase) is begin Connection.Current_Phase := Phase; -- if Connection.Cleaner /= null then -- Connection.Cleaner.Next_Phase; -- end if; end Set_Phase; ------------------------------ -- Set_Proxy_Authentication -- ------------------------------ procedure Set_Proxy_Authentication (Connection : in out HTTP_Connection; User : String; Pwd : String; Mode : Authentication_Mode) is begin Set_Authentication (Auth => Connection.Auth (Proxy), User => User, Pwd => Pwd, Mode => Mode); end Set_Proxy_Authentication; ---------------------------- -- Set_WWW_Authentication -- ---------------------------- procedure Set_WWW_Authentication (Connection : in out HTTP_Connection; User : String; Pwd : String; Mode : Authentication_Mode) is begin Set_Authentication (Auth => Connection.Auth (WWW), User => User, Pwd => Pwd, Mode => Mode); end Set_WWW_Authentication; --------------- -- SOAP_Post -- --------------- function SOAP_Post (URL : String; Data : String; SOAPAction : String; User : String := No_Data; Pwd : String := No_Data; Proxy : String := No_Data; Proxy_User : String := No_Data; Proxy_Pwd : String := No_Data; Timeouts : Timeouts_Values := No_Timeout) return Response.Data is Connection : HTTP_Connection; Result : Response.Data; begin Create (Connection, URL, User, Pwd, Proxy, Proxy_User, Proxy_Pwd, SOAPAction => SOAPAction, Persistent => False, Timeouts => Timeouts); Post (Connection, Result, Data); Close (Connection); return Result; end SOAP_Post; function SOAP_Post (Connection : access HTTP_Connection; Data : String) return Response.Data is Result : Response.Data; begin Post (Connection.all, Result, Data); return Result; end SOAP_Post; function Host (Connection : HTTP_Connection) return Unbounded_String is begin return Connection.Host; end Host; function Host_URL (Connection : HTTP_Connection) return AWS.URL.Object is begin return Connection.Host_URL; end Host_URL; ------------ -- Upload -- ------------ -- procedure Upload -- (Connection : in out HTTP_Connection; -- Result : out Response.Data; -- Filename : String; -- URI : String := No_Data) -- is -- -- Pref_Suf : constant String := "--"; -- -- Now : constant Calendar.Time := Calendar.Clock; -- -- Boundary : constant String -- -- := "AWS_File_Upload-" & GNAT.Calendar.Time_IO.Image (Now, "%s"); -- -- CT : constant String -- -- := Messages.Content_Type (MIME.Content_Type (Filename)); -- -- CD : constant String -- -- := Messages.Content_Disposition ("form-data", "filename", Filename); -- -- Try_Count : Natural := Connection.Retry; -- Auth_Attempts : Auth_Attempts_Count := (others => 2); -- Auth_Is_Over : Boolean; -- -- function Content_Length return Integer; -- -- Returns the total message content length. -- procedure Send_File; -- -- Send file content to the server. -- -------------------- -- -- Content_Length -- -- -------------------- -- -- function Content_Length return Integer is -- -- begin -- -- return 2 * Boundary'Length -- 2 boundaries -- -- + 2 -- second one end with "--" -- -- + 10 -- 5 lines with CR+LF -- -- + CT'Length -- content length header -- -- + CD'Length -- content disposition head -- -- + Integer (OS_Lib.File_Size (Filename)) -- file size -- -- + 2; -- CR+LF after file data -- -- end Content_Length; -- --------------- -- -- Send_File -- -- --------------- -- procedure Send_File is -- -- Sock : Net.Socket_Type'Class renames Connection.Socket.all; -- Buffer : Streams.Stream_Element_Array (1 .. 4_096); -- Last : Streams.Stream_Element_Offset; -- File : Streams.Stream_IO.File_Type; -- begin -- -- Send multipart message start boundary -- -- Net.Buffered.Put_Line (Sock, Pref_Suf & Boundary); -- -- Send Content-Disposition header -- -- Net.Buffered.Put_Line (Sock, CD); -- -- Send Content-Type: header -- -- Net.Buffered.Put_Line (Sock, CT); -- -- Net.Buffered.New_Line (Sock); -- -- Send file content -- Streams.Stream_IO.Open (File, Streams.Stream_IO.In_File, Filename); -- while not Streams.Stream_IO.End_Of_File (File) loop -- Streams.Stream_IO.Read (File, Buffer, Last); -- -- Net.Buffered.Write (Sock, Buffer (1 .. Last)); -- end loop; -- Streams.Stream_IO.Close (File); -- -- Net.Buffered.New_Line (Sock); -- -- Send multipart message end boundary -- -- Net.Buffered.Put_Line (Sock, Pref_Suf & Boundary & Pref_Suf); -- -- exception -- -- when others => -- -- when Net.Socket_Error => -- -- -- Properly close the file if needed -- -- if Streams.Stream_IO.Is_Open (File) then -- -- Streams.Stream_IO.Close (File); -- -- end if; -- -- raise; -- end Send_File; -- begin -- Retry : loop -- begin -- Open_Send_Common_Header (Connection, "POST", URI); -- declare -- -- Sock : Net.Socket_Type'Class renames Connection.Socket.all; -- begin -- -- Send message Content-Type (Multipart/form-data) -- -- Send_Header -- -- (Sock, -- -- Messages.Content_Type (MIME.Multipart_Form_Data, Boundary)); -- -- Send message Content-Length -- -- Send_Header (Sock, Messages.Content_Length (Content_Length)); -- -- Net.Buffered.New_Line (Sock); -- -- Send message body -- Send_File; -- end; -- -- Get answer from server -- Get_Response (Connection, Result, not Connection.Server_Push); -- Decrement_Authentication_Attempt -- (Connection, Auth_Attempts, Auth_Is_Over); -- if Auth_Is_Over then -- return; -- end if; -- -- exception -- -- when others => raise; -- -- when Net.Socket_Error => -- -- Disconnect (Connection); -- -- if Try_Count = 0 then -- -- Result := Response.Build -- -- (MIME.Text_HTML, "Upload Timeout", Messages.S408); -- -- Set_Phase (Connection, Not_Monitored); -- -- exit Retry; -- -- end if; -- -- Try_Count := Try_Count - 1; -- end; -- end loop Retry; -- end Upload; -- function Upload -- (URL : String; -- Filename : String; -- User : String := No_Data; -- Pwd : String := No_Data; -- Proxy : String := No_Data; -- Proxy_User : String := No_Data; -- Proxy_Pwd : String := No_Data; -- Timeouts : Timeouts_Values := No_Timeout) -- return Response.Data -- is -- Connection : HTTP_Connection; -- Result : Response.Data; -- begin -- Create (Connection, -- URL, User, Pwd, Proxy, Proxy_User, Proxy_Pwd, -- Persistent => False, -- Timeouts => Timeouts); -- Upload (Connection, Result, Filename); -- Close (Connection); -- return Result; -- exception -- when others => -- Close (Connection); -- raise; -- end Upload; end AWS.Client; polyorb-2.8~20110207.orig/src/aws/aws-status.adb0000644000175000017500000002476211750740337020567 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- A W S . S T A T U S -- -- -- -- B o d y -- -- -- -- Copyright (C) 2000-2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with Ada.Strings; with AWS.Digest; with AWS.Headers.Values; with AWS.Messages; package body AWS.Status is use Ada.Strings; -------------------------- -- Authorization_CNonce -- -------------------------- function Authorization_CNonce (D : Data) return String is begin return To_String (D.Auth_CNonce); end Authorization_CNonce; ------------------------ -- Authorization_Mode -- ------------------------ function Authorization_Mode (D : Data) return Authorization_Type is begin return D.Auth_Mode; end Authorization_Mode; ------------------------ -- Authorization_Name -- ------------------------ function Authorization_Name (D : Data) return String is begin return To_String (D.Auth_Name); end Authorization_Name; ---------------------- -- Authorization_NC -- ---------------------- function Authorization_NC (D : Data) return String is begin return To_String (D.Auth_NC); end Authorization_NC; ------------------------- -- Authorization_Nonce -- ------------------------- function Authorization_Nonce (D : Data) return String is begin return To_String (D.Auth_Nonce); end Authorization_Nonce; ---------------------------- -- Authorization_Password -- ---------------------------- function Authorization_Password (D : Data) return String is begin return To_String (D.Auth_Password); end Authorization_Password; ----------------------- -- Authorization_QOP -- ----------------------- function Authorization_QOP (D : Data) return String is begin return To_String (D.Auth_QOP); end Authorization_QOP; ------------------------- -- Authorization_Realm -- ------------------------- function Authorization_Realm (D : Data) return String is begin return To_String (D.Auth_Realm); end Authorization_Realm; ---------------------------- -- Authorization_Response -- ---------------------------- function Authorization_Response (D : Data) return String is begin return To_String (D.Auth_Response); end Authorization_Response; ----------------- -- Binary_Data -- ----------------- function Binary_Data (D : Data) return Stream_Element_Array is begin return D.Binary_Data.all; end Binary_Data; ------------------ -- Check_Digest -- ------------------ function Check_Digest (D : Data; Password : String) return Boolean is function Get_Nonce return String; -- returns Nonce for the Digest authentication without "qop" -- parameter, or [nonce]:[nc]:[cnonce]:[qop] for the Digest -- authentication with qop parameter. -- It is just for convinience to implement RFC 2617 3.2.2.1. --------------- -- Get_Nonce -- --------------- function Get_Nonce return String is Nonce : constant String := Authorization_Nonce (D); QOP : constant String := Authorization_QOP (D); begin if QOP = "" then return Nonce; else return Nonce & ':' & Authorization_NC (D) & ':' & Authorization_CNonce (D) & ':' & QOP; end if; end Get_Nonce; begin return Authorization_Response (D) = AWS.Digest.Create_Digest (Username => Authorization_Name (D), Realm => Authorization_Realm (D), Password => Password, Nonce => Get_Nonce, Method => Request_Method'Image (D.Method), URI => URI (D)); end Check_Digest; ---------------- -- Connection -- ---------------- function Connection (D : Data) return String is begin return Headers.Get (D.Header, Messages.Connection_Token); end Connection; -------------------- -- Content_Length -- -------------------- function Content_Length (D : Data) return Natural is begin return D.Content_Length; end Content_Length; ------------------ -- Content_Type -- ------------------ function Content_Type (D : Data) return String is begin return Headers.Get (D.Header, Messages.Content_Type_Token); end Content_Type; ----------------- -- Has_Session -- ----------------- function Has_Session (D : Data) return Boolean is use type AWS.Session.ID; begin return D.Session_ID /= AWS.Session.No_Session; end Has_Session; ------------ -- Header -- ------------ function Header (D : Data) return Headers.List is begin return D.Header; end Header; ---------- -- Host -- ---------- function Host (D : Data) return String is begin return Headers.Get (D.Header, Messages.Host_Token); end Host; ------------------ -- HTTP_Version -- ------------------ function HTTP_Version (D : Data) return String is begin return To_String (D.HTTP_Version); end HTTP_Version; ----------------------- -- If_Modified_Since -- ----------------------- function If_Modified_Since (D : Data) return String is begin return Headers.Get (D.Header, Messages.If_Modified_Since_Token); end If_Modified_Since; ------------- -- Is_SOAP -- ------------- function Is_SOAP (D : Data) return Boolean is begin return D.SOAP_Action; end Is_SOAP; ---------------- -- Keep_Alive -- ---------------- function Keep_Alive (D : Data) return Boolean is begin return D.Keep_Alive; end Keep_Alive; ------------ -- Method -- ------------ function Method (D : Data) return Request_Method is begin return D.Method; end Method; ------------------------ -- Multipart_Boundary -- ------------------------ function Multipart_Boundary (D : Data) return String is use Headers; begin -- Get the Boundary value from the Contant_Type header value. -- We do not need to have the boundary in the Status.Data preparsed, -- becouse the AWS is not using function Multipart_Boundary internally. return Values.Search (Get (D.Header, Messages.Content_Type_Token), "Boundary", Case_Sensitive => False); end Multipart_Boundary; ---------------- -- Parameters -- ---------------- function Parameters (D : Data) return AWS.Parameters.List is begin return D.Parameters; end Parameters; ------------- -- Payload -- ------------- function Payload (D : Data) return String is pragma Warnings (Off); pragma Unreferenced (D); pragma Warnings (On); begin return "SOAP Payload"; -- return To_String (D.Payload); end Payload; function Payload (D : Data) return SOAP.Message.Payload.Object is begin return D.SOAP_Payload; end Payload; -------------- -- Peername -- -------------- function Peername (D : Data) return String is begin return To_String (D.Peername); end Peername; ------------- -- Referer -- ------------- function Referer (D : Data) return String is begin return Headers.Get (D.Header, Messages.Referer_Token); end Referer; ------------- -- Session -- ------------- function Session (D : Data) return AWS.Session.ID is begin return D.Session_ID; end Session; --------------------- -- Session_Created -- --------------------- function Session_Created (D : Data) return Boolean is begin return D.Session_Created; end Session_Created; ---------------- -- SOAPAction -- ---------------- function SOAPAction (D : Data) return String is Result : constant String := Headers.Get (D.Header, Messages.SOAPAction_Token); begin if Result'First < Result'Last and then Result (Result'First) = '"' and then Result (Result'Last) = '"' then return Result (Result'First + 1 .. Result'Last - 1); else return Result; end if; end SOAPAction; ------------ -- Socket -- ------------ -- function Socket (D : Data) return Net.Socket_Type'Class is -- begin -- return D.Socket.all; -- end Socket; --------- -- URI -- --------- function URI (D : Data) return String is begin return URL.URL (D.URI); end URI; function URI (D : Data) return URL.Object is begin return D.URI; end URI; ---------------- -- User_Agent -- ---------------- function User_Agent (D : Data) return String is begin return Headers.Get (D.Header, Messages.User_Agent_Token); end User_Agent; end AWS.Status; polyorb-2.8~20110207.orig/src/aws/aws-object_adapter.adb0000644000175000017500000001506211750740337022203 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- A W S . O B J E C T _ A D A P T E R -- -- -- -- B o d y -- -- -- -- Copyright (C) 2006-2008, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with PolyORB.Errors; use PolyORB.Errors; with PolyORB.Log; with PolyORB.POA; with PolyORB.POA.Basic_POA; with PolyORB.POA_Manager; use PolyORB.POA_Manager; with PolyORB.POA_Manager.Basic_Manager; use PolyORB.POA_Manager.Basic_Manager; with PolyORB.POA_Policies; use PolyORB.POA_Policies; with PolyORB.POA_Policies.Request_Processing_Policy.Use_Default_Servant; with PolyORB.POA_Policies.Id_Uniqueness_Policy.Multiple; with PolyORB.POA_Policies.Lifespan_Policy.Persistent; with PolyORB.POA_Policies.Implicit_Activation_Policy.No_Activation; with PolyORB.POA_Policies.Servant_Retention_Policy.Non_Retain; with PolyORB.Servants; package body AWS.Object_Adapter is use PolyORB.Log; package L is new PolyORB.Log.Facility_Log ("aws.object_adapter"); procedure O (Message : Standard.String; Level : Log_Level := Debug) renames L.Output; function C (Level : Log_Level := Debug) return Boolean renames L.Enabled; -- the polyorb logging facility --------------------- -- Unknown_Adapter -- --------------------- procedure Unknown_Adapter (Self : access AWS_AdapterActivator; Parent : access Obj_Adapter'Class; Name : String; Result : out Boolean; Error : in out PolyORB.Errors.Error_Container) is pragma Warnings (Off); pragma Unreferenced (Self); pragma Warnings (On); The_Poa : PolyORB.POA.Obj_Adapter_Access; The_Servant : PolyORB.Servants.Servant_Access; Policies : PolicyList; The_Poa_Manager : constant Basic_POA_Manager_Access := new Basic_POA_Manager; begin pragma Debug (C, O ("Unknown_Adapter: asked for <" & Name & ">")); PolyORB.POA_Policies.Policy_Lists.Append (Policies, PolyORB.POA_Policies.Request_Processing_Policy. Use_Default_Servant.Create.all'Access); -- This is what we need PolyORB.POA_Policies.Policy_Lists.Append (Policies, PolyORB.POA_Policies.Id_Uniqueness_Policy. Multiple.Create.all'Access); -- This is required by Use_Default_Servant PolyORB.POA_Policies.Policy_Lists.Append (Policies, PolyORB.POA_Policies.Lifespan_Policy. Persistent.Create.all'Access); -- To get rid of the ";pf=..." in URIs PolyORB.POA_Policies.Policy_Lists.Append (Policies, PolyORB.POA_Policies.Servant_Retention_Policy. Non_Retain.Create.all'Access); -- To get rid of the ";sys" in URIs PolyORB.POA_Policies.Policy_Lists.Append (Policies, PolyORB.POA_Policies.Implicit_Activation_Policy. No_Activation.Create.all'Access); -- Activation policy is incompatible with Non_Retain, so we -- use No_Activation. pragma Debug (C, O ("Unknown_Adapter: set POA policies")); Create (The_Poa_Manager); pragma Debug (C, O ("Unknown_Adapter: creating a new sub-POA")); PolyORB.POA.Basic_POA.Create_POA (PolyORB.POA.Basic_POA.Basic_Obj_Adapter (Parent.all)'Access, Name, POAManager_Access (The_Poa_Manager), Policies, The_Poa, Error); if Found (Error) then pragma Debug (C, O ("Error when creating the POA")); null; end if; The_Poa.Adapter_Activator := new Object_Adapter.AWS_AdapterActivator; PolyORB.POA_Manager.Basic_Manager.Activate (The_Poa_Manager, Error); if Found (Error) then pragma Debug (C, O ("AWS_Init: " & "unable to activate the POA Manager", Critical)); null; end if; pragma Debug (C, O ("Unknown_Adapter: " & "retrieving the servant from the parent POA")); PolyORB.POA.Basic_POA.Get_Servant (PolyORB.POA.Basic_POA.Basic_Obj_Adapter (Parent.all)'Access, The_Servant, Error); if Found (Error) then pragma Debug (C, O ("Error when getting the servant")); null; end if; pragma Debug (C, O ("Unknown_Adapter: " & "setting the servant for the new POA")); PolyORB.POA.Basic_POA.Set_Servant (PolyORB.POA.Basic_POA.Basic_Obj_Adapter (The_Poa.all)'Access, The_Servant, Error); if Found (Error) then pragma Debug (C, O ("Error when setting the servant")); null; end if; Result := True; -- We always return 'true', as it is up to the AWS servant to tell -- whether an object exists or not, whatever the path to it may be. end Unknown_Adapter; end AWS.Object_Adapter; polyorb-2.8~20110207.orig/src/aws/aws-parameters-set.adb0000644000175000017500000001011711750740337022165 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- A W S . P A R A M E T E R S . S E T -- -- -- -- B o d y -- -- -- -- Copyright (C) 2000-2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with Ada.Strings.Fixed; with AWS.URL; with AWS.Containers.Tables.Set; package body AWS.Parameters.Set is use AWS.Containers; --------- -- Add -- --------- procedure Add (Parameter_List : in out List; Name, Value : String) is begin Tables.Set.Add (Tables.Table_Type (Parameter_List), URL.Decode (Name), URL.Decode (Value)); end Add; --------- -- Add -- --------- procedure Add (Parameter_List : in out List; Parameters : String) is use Ada.Strings; P : String renames Parameters; C : Positive := P'First; I : Natural; S : Positive := P'First; E : Natural; begin -- Skip leading question mark if present. if P /= "" and then P (C) = '?' then C := Positive'Succ (C); S := Positive'Succ (S); end if; Parameter_List.Parameters := To_Unbounded_String ('?' & P (C .. P'Last)); loop I := Fixed.Index (P (C .. P'Last), "="); exit when I = 0; S := I + 1; E := Fixed.Index (P (S .. P'Last), "&"); if E = 0 then -- last parameter Add (Parameter_List, P (C .. I - 1), P (S .. P'Last)); exit; else Add (Parameter_List, P (C .. I - 1), P (S .. E - 1)); C := E + 1; end if; end loop; end Add; -------------------- -- Case_Sensitive -- -------------------- procedure Case_Sensitive (Parameter_List : in out List; Mode : Boolean) is begin Tables.Set.Case_Sensitive (Tables.Table_Type (Parameter_List), Mode); end Case_Sensitive; ---------- -- Free -- ---------- procedure Free (Parameter_List : in out List) is begin Tables.Set.Free (Tables.Table_Type (Parameter_List)); end Free; ----------- -- Reset -- ----------- procedure Reset (Parameter_List : in out List) is begin Tables.Set.Reset (Tables.Table_Type (Parameter_List)); Parameter_List.Parameters := Null_Unbounded_String; end Reset; end AWS.Parameters.Set; polyorb-2.8~20110207.orig/src/aws/aws-parameters-set.ads0000644000175000017500000000613011750740337022206 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- A W S . P A R A M E T E R S . S E T -- -- -- -- S p e c -- -- -- -- Copyright (C) 2000-2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ package AWS.Parameters.Set is procedure Add (Parameter_List : in out List; Name, Value : String); -- Add a new Key/Value pair into the parameter set. procedure Add (Parameter_List : in out List; Parameters : String); -- Set parameters for the current request. This is used for a POST method -- because the parameters are found in the message body and are not known -- when we parse the request line. The Parameters string has the form -- "name1=value1&name2=value2...". The paramaters are added to the list. -- The parameters can start with a '?' (standard Web character separator) -- which is just ignored. procedure Case_Sensitive (Parameter_List : in out List; Mode : Boolean); -- If Mode is True it will use all parameters with case sensitivity. procedure Reset (Parameter_List : in out List); -- Removes all object from the Set. Set will be reinitialized and will be -- ready for new use. procedure Free (Parameter_List : in out List); -- Release all memory used by the list. end AWS.Parameters.Set; polyorb-2.8~20110207.orig/src/aws/soap-message-response.ads0000644000175000017500000000470311750740337022706 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- S O A P . M E S S A G E . R E S P O N S E -- -- -- -- S p e c -- -- -- -- Copyright (C) 2000-2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- with AWS.Response; with SOAP.Message.Payload; package SOAP.Message.Response is type Object is new Message.Object with null record; -- function Build (R : Object'Class) return AWS.Response.Data; -- now in aws-response function From (P : Message.Payload.Object) return Object; -- Returns a Response object, initialized from a payload object. function Is_Error (R : Object) return Boolean; end SOAP.Message.Response; polyorb-2.8~20110207.orig/src/aws/aws-server-servants.adb0000644000175000017500000003662111750740337022412 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- A W S . S E R V E R . S E R V A N T S -- -- -- -- B o d y -- -- -- -- Copyright (C) 2006-2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with Ada.Streams; with AWS.Status; with AWS.Status.Set; with AWS.Parameters; with AWS.Parameters.Set; with AWS.Resources; with SOAP.Types; with SOAP.Message.Payload; with SOAP.Parameters; with PolyORB.Errors.Helper; with PolyORB.Any.NVList; with PolyORB.Requests; with PolyORB.Objects; with PolyORB.Obj_Adapters; with PolyORB.ORB; with PolyORB.Types; with PolyORB.Setup; with PolyORB.Log; with PolyORB.References; with PolyORB.Binding_Data; package body AWS.Server.Servants is use PolyORB.Log; package L is new PolyORB.Log.Facility_Log ("aws.server"); procedure O (Message : Standard.String; Level : Log_Level := Debug) renames L.Output; function C (Level : Log_Level := Debug) return Boolean renames L.Enabled; -- the polyorb logging facility procedure Request_Handler (PolyORB_Servant : access HTTP'Class; PolyORB_Request : PolyORB.Requests.Request_Access); -- handles the requests made to the servants. Replaces protocol_handler --------------------- -- Request_Handler -- --------------------- procedure Request_Handler (PolyORB_Servant : access AWS.Server.HTTP'Class; PolyORB_Request : PolyORB.Requests.Request_Access) is use PolyORB.Errors; use PolyORB.Errors.Helper; HTTP_10 : constant String := "HTTP/1.0"; AWS_Request : AWS.Status.Data; AWS_Response : AWS.Response.Data; Error : Error_Container; procedure Extract_Context; procedure Extract_Data; procedure Call_Callback; procedure Integrate_Context; procedure Integrate_Data; --------------------- -- Extract_Context -- --------------------- procedure Extract_Context is use AWS.Status.Set; begin -- we do nothing for now, as contexts are not implemented Reset (AWS_Request); end Extract_Context; ------------------ -- Extract_Data -- ------------------ procedure Extract_Data is use AWS.Parameters; use AWS.Parameters.Set; use AWS.Status; use AWS.Status.Set; use PolyORB.Types; use PolyORB.Any.NVList; use PolyORB.Any.NVList.Internals; use PolyORB.Any.NVList.Internals.NV_Lists; use PolyORB.Requests; use PolyORB.Objects; P_List : AWS.Parameters.List; Args : PolyORB.Any.NVList.Ref; Nth_Arg : PolyORB.Any.NVList.Internals.NV_Lists.Iterator; HTTP_Method : Request_Method; Number_Of_Args : Long; URI_Path : PolyORB.Types.String; The_Oid : PolyORB.Objects.Object_Id_Access; -- The_Reference : PolyORB.References.Ref; begin pragma Debug (C, O (PolyORB.References.Image (PolyORB_Request.Target))); declare Profiles : constant PolyORB.References.Profile_Array := PolyORB.References.Profiles_Of (PolyORB_Request.Target); begin for Prof_Index in Profiles'Range loop if PolyORB.Binding_Data.Get_Object_Key (Profiles (Prof_Index).all) /= null then The_Oid := PolyORB.Binding_Data.Get_Object_Key (Profiles (Prof_Index).all); exit; end if; end loop; end; Obj_Adapters.Oid_To_Rel_URI (PolyORB.ORB.Object_Adapter (Setup.The_ORB), The_Oid, URI_Path, Error); if Found (Error) then Catch (Error); return; end if; declare URI : constant String := To_String (URI_Path); begin Parameters.Set.Reset (P_List); pragma Debug (C, O ("Extract_Data: structures have been initialized")); Create (Args); Arguments (PolyORB_Request, Args, Error, Can_Extend => True); if Found (Error) then return; end if; Number_Of_Args := Get_Count (Args); pragma Debug (C, O ("Extract_Data: parameters have been fetched")); pragma Debug (C, O ("Extract_Data: " & Long'Image (Number_Of_Args) & " parameters")); if PolyORB_Servant.all in Web_Servant'Class then pragma Debug (C, O ("Extract_Data: got a Web request")); if PolyORB_Request.Operation.all = "GET" then HTTP_Method := GET; elsif PolyORB_Request.Operation.all = "HEAD" then HTTP_Method := HEAD; elsif PolyORB_Request.Operation.all = "POST" then HTTP_Method := POST; elsif PolyORB_Request.Operation.all = "PUT" then HTTP_Method := PUT; else raise Program_Error; -- if none of the recognized method names is -- provided, then we raise an error end if; Nth_Arg := First (List_Of (Args).all); while not Last (Nth_Arg) loop AWS.Parameters.Set.Add (P_List, To_Standard_String (Value (Nth_Arg).Name), To_Standard_String (PolyORB.Any.From_Any (Value (Nth_Arg).Argument))); Next (Nth_Arg); end loop; AWS.Status.Set.Request (AWS_Request, HTTP_Method, URI, HTTP_10); -- we fill in the basic parameters of the request : -- the method name and the URI AWS.Status.Set.Parameters (AWS_Request, P_List); -- then we set the parameter list elsif PolyORB_Servant.all in SOAP_Servant'Class then pragma Debug (C, O ("Extract_Data: got a SOAP request named " & PolyORB_Request.Operation.all)); AWS.Status.Set.Request (AWS_Request, POST, URI, HTTP_10); -- We fill in the basic parameters of the request: -- the method name and the URI. -- -- SOAP relies on the POST method, according to w3c. declare SOAP_Params : SOAP.Parameters.List; SOAP_Object : SOAP.Message.Payload.Object; begin Nth_Arg := First (List_Of (Args).all); while not Last (Nth_Arg) loop SOAP_Params := SOAP.Parameters."&" (SOAP_Params, SOAP.Types.From_NamedValue (Value (Nth_Arg).all)); Next (Nth_Arg); end loop; SOAP.Message.Set_Parameters (SOAP_Object, SOAP_Params); SOAP.Message.Set_Wrapper_Name (SOAP_Object, PolyORB_Request.Operation.all); AWS.Status.Set.Payload (AWS_Request, SOAP_Object); end; else raise Program_Error; -- there is only two kinds of AWS servants: Web and SOAP. We -- are not supposed to handle anything else end if; PolyORB_Request.Arguments_Called := True; end; end Extract_Data; ------------------- -- Call_Callback -- ------------------- procedure Call_Callback is begin AWS_Response := Dispatchers.Dispatch (PolyORB_Servant.Dispatcher.all, AWS_Request); end Call_Callback; ----------------------- -- Integrate_Context -- ----------------------- procedure Integrate_Context is begin -- we do nothing for now, as contexts are not implemented null; end Integrate_Context; -------------------- -- Integrate_Data -- -------------------- procedure Integrate_Data is use PolyORB.Any; use PolyORB.Any.NVList; use PolyORB.Types; use PolyORB.Requests; use AWS.Response; begin if Mode (AWS_Response) = Message then pragma Debug (C, O ("Integrate_Data: classical Web response")); Set_Result (PolyORB_Request, To_Any (To_PolyORB_String (Message_Body (AWS_Response)))); elsif Mode (AWS_Response) = Header or else Mode (AWS_Response) = No_Data then pragma Debug (C, O ("Integrate_Data: Header or No_Data response")); Set_Result (PolyORB_Request, Get_Empty_Any (TC_Null)); elsif Mode (AWS_Response) = File then pragma Debug (C, O ("Integrate_Data:" & " byte sequence response (file)")); declare Sq_Type : constant PolyORB.Any.TypeCode.Local_Ref := PolyORB.Any.TypeCode.TC_Sequence; begin PolyORB.Any.TypeCode.Add_Parameter (Sq_Type, PolyORB.Any.To_Any (PolyORB.Types.Unsigned_Long (0))); -- We cannot guess the size of the whole stream, so we -- create an unbounded sequence. PolyORB.Any.TypeCode.Add_Parameter (Sq_Type, PolyORB.Any.To_Any (PolyORB.Any.TypeCode.TC_Octet)); declare use Ada.Streams; Sq : PolyORB.Any.Any := PolyORB.Any.Get_Empty_Any_Aggregate (Sq_Type); Last : Stream_Element_Offset; Buffer_Size : constant := 4 * 1_1024; -- from aws.server.protocol_handler File : AWS.Resources.File_Type; Buffer : Stream_Element_Array (1 .. Buffer_Size); begin AWS.Response.Create_Resource (File, AWS_Response); loop AWS.Resources.Read (File, Buffer, Last); exit when Last < Buffer'First; for K in Buffer'First .. Last loop PolyORB.Any.Add_Aggregate_Element (Sq, PolyORB.Any.To_Any (PolyORB.Types.Octet (Buffer (K)))); end loop; end loop; Set_Result (PolyORB_Request, Sq); AWS.Resources.Close (File); end; end; elsif AWS.Response.Mode (AWS_Response) = SOAP_Message then pragma Debug (C, O ("Integrate_Data: SOAP response")); Set_Result (PolyORB_Request, SOAP.Types.To_Any (SOAP.Parameters.Argument (SOAP.Message.Parameters (SOAP_Message (AWS_Response)), 1))); -- note that we transmit only the first soap object of -- the parameters list, as a function is not supposed to -- return more than one element end if; Create (PolyORB_Request.Out_Args); AWS.Status.Set.Free (AWS_Request); end Integrate_Data; use PolyORB.Requests; begin pragma Debug (C, O ("Request_Handler: received a request")); Extract_Context; if Found (Error) then Set_Result (PolyORB_Request, Error_To_Any (Error)); return; end if; Extract_Data; if Found (Error) then Set_Result (PolyORB_Request, Error_To_Any (Error)); return; end if; Call_Callback; if Found (Error) then Set_Result (PolyORB_Request, Error_To_Any (Error)); return; end if; Integrate_Context; if Found (Error) then Set_Result (PolyORB_Request, Error_To_Any (Error)); return; end if; Integrate_Data; if Found (Error) then Set_Result (PolyORB_Request, Error_To_Any (Error)); return; end if; end Request_Handler; --------------------- -- Execute_Servant -- --------------------- function Execute_Servant (S : not null access Web_Servant; Req : Requests.Request_Access) return Boolean is use PolyORB.Requests; use PolyORB.Errors; R : constant Request_Access := Req; Error : Error_Container; begin pragma Debug (C, O ("Execute_Servant: processing a Web request")); Request_Handler (S, R); pragma Debug (C, O ("Execute_Servant:" & " executed, setting out args")); Set_Out_Args (R, Error); if Found (Error) then raise Program_Error; end if; pragma Debug (C, O ("Execute_Servant: leave")); return True; end Execute_Servant; function Execute_Servant (S : not null access SOAP_Servant; Req : Requests.Request_Access) return Boolean is use PolyORB.Requests; use PolyORB.Errors; R : constant Request_Access := Req; Error : Error_Container; begin pragma Debug (C, O ("Execute_Servant: processing a SOAP request")); Request_Handler (S, R); pragma Debug (C, O ("Execute_Servant:" & " executed, setting out args")); Set_Out_Args (R, Error); if Found (Error) then raise Program_Error; end if; pragma Debug (C, O ("Execute_Servant: leave")); return True; end Execute_Servant; end AWS.Server.Servants; polyorb-2.8~20110207.orig/src/aws/soap-message-payload.adb0000644000175000017500000000555711750740337022470 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- S O A P . M E S S A G E . P A Y L O A D -- -- -- -- B o d y -- -- -- -- Copyright (C) 2000-2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ package body SOAP.Message.Payload is ----------- -- Build -- ----------- function Build (Procedure_Name : String; P_Set : SOAP.Parameters.List; Name_Space : String := Default_Name_Space) return Object is begin return (To_Unbounded_String (Name_Space), To_Unbounded_String (Procedure_Name), P_Set); end Build; -------------------- -- Procedure_Name -- -------------------- function Procedure_Name (P : Object'Class) return String is begin return Wrapper_Name (P); end Procedure_Name; ------------------------ -- Set_Procedure_Name -- ------------------------ procedure Set_Procedure_Name (P : in out Object'Class; Name : String) is begin Set_Wrapper_Name (P, Name); end Set_Procedure_Name; end SOAP.Message.Payload; polyorb-2.8~20110207.orig/src/aws/aws-status-set.adb0000644000175000017500000002253411750740337021353 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- A W S . S T A T U S . S E T -- -- -- -- B o d y -- -- -- -- Copyright (C) 2000-2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with AWS.Parameters.Set; package body AWS.Status.Set is use Ada.Strings; -- procedure Authorization (D : in out Data); -- Parse the Authorization parameters from the Authorization header value. -- procedure Update_Data_From_Header (D : in out Data); -- Update some Data fields from the internal Data header container. -- The Update_Data_From_Header should be called after the complete -- header parsing. ------------------- -- Authorization -- ------------------- -- procedure Authorization (D : in out Data) is -- Header_Value : constant String -- := AWS.Headers.Get (D.Header, Messages.Authorization_Token); -- procedure Named_Value (Name, Value : String; Quit : in out Boolean); -- procedure Value (Item : String; Quit : in out Boolean); -- ----------------- -- -- Named_Value -- -- ----------------- -- procedure Named_Value -- (Name, Value : String; -- Quit : in out Boolean) -- is -- type Digest_Attribute -- is (Username, Realm, Nonce, NC, CNonce, -- QOP, URI, Response, Algorithm); -- -- The enumeration type is using to be able to -- -- use the name in the case statement. -- -- The case statement has usially faster implementation. -- Attribute : Digest_Attribute; -- function "+" -- (Item : String) -- return Unbounded_String -- renames To_Unbounded_String; -- begin -- begin -- Attribute := Digest_Attribute'Value (Name); -- exception -- when Constraint_Error => -- -- Ignoring unrecognized attribute -- return; -- end; -- -- Check if the attributes is for the Digest authenticatio schema. -- -- AWS does not support othe authentication schemas with attributes -- -- now. -- if D.Auth_Mode /= Digest then -- Quit := True; -- end if; -- case Attribute is -- when Username => D.Auth_Name := +Value; -- when Realm => D.Auth_Realm := +Value; -- when NC => D.Auth_NC := +Value; -- when CNonce => D.Auth_CNonce := +Value; -- when QOP => D.Auth_QOP := +Value; -- when Nonce => D.Auth_Nonce := +Value; -- when Response => D.Auth_Response := +Value; -- when URI => D.URI -- := URL.Parse (Value, False, False); -- when Algorithm => -- if Value /= "MD5" then -- Ada.Exceptions.Raise_Exception -- (Constraint_Error'Identity, -- "Only MD5 algorithm is supported."); -- end if; -- end case; -- end Named_Value; -- ----------- -- -- Value -- -- ----------- -- procedure Value (Item : String; Quit : in out Boolean) is -- Upper_Item : constant String -- := Ada.Characters.Handling.To_Upper (Item); -- begin -- if Upper_Item = "BASIC" then -- D.Auth_Mode := Basic; -- Quit := True; -- -- We could not continue to parse Basic authentication -- -- by the regular way, becouse next value is Base64 -- -- encoded username:password, it is possibe to be -- -- symbol '=' there, our parser could -- -- think that it is name/value delimiter. -- declare -- use Ada.Streams; -- Auth_Str : constant String -- := Translator.To_String (Translator.Base64_Decode -- (Header_Value (Item'Length + 2 .. Header_Value'Last))); -- Delimit : constant Natural := Fixed.Index (Auth_Str, ":"); -- begin -- if Delimit = 0 then -- D.Auth_Name := To_Unbounded_String (Auth_Str); -- else -- D.Auth_Name -- := To_Unbounded_String (Auth_Str (1 .. Delimit - 1)); -- D.Auth_Password -- := To_Unbounded_String -- (Auth_Str (Delimit + 1 .. Auth_Str'Last)); -- end if; -- end; -- elsif Upper_Item = "DIGEST" then -- D.Auth_Mode := Digest; -- end if; -- end Value; -- procedure Parse is new Headers.Values.Parse (Value, Named_Value); -- begin -- Parse (Header_Value); -- end Authorization; ------------ -- Binary -- ------------ procedure Binary (D : in out Data; Parameter : Stream_Element_Array) is begin D.Binary_Data := new Stream_Element_Array'(Parameter); end Binary; ---------- -- Free -- ---------- procedure Free (D : in out Data) is begin Utils.Free (D.Binary_Data); AWS.Parameters.Set.Free (D.Parameters); -- AWS.Headers.Set.Free (D.Header); end Free; ---------------- -- Keep_Alive -- ---------------- procedure Keep_Alive (D : in out Data; Flag : Boolean) is begin D.Keep_Alive := Flag; end Keep_Alive; ---------------- -- Parameters -- ---------------- procedure Parameters (D : in out Data; Set : AWS.Parameters.List) is begin D.Parameters := Set; end Parameters; ------------- -- Payload -- ------------- procedure Payload (D : in out Data; Payload : SOAP.Message.Payload.Object) is begin D.SOAP_Payload := Payload; D.SOAP_Action := True; end Payload; -------------- -- Peername -- -------------- procedure Peername (D : in out Data; Peername : String) is begin D.Peername := To_Unbounded_String (Peername); end Peername; ------------- -- Request -- ------------- procedure Request (D : in out Data; Method : Request_Method; URI : String; HTTP_Version : String) is begin D.Method := Method; D.URI := URL.Parse (URI, False, False); D.HTTP_Version := To_Unbounded_String (HTTP_Version); end Request; ----------- -- Reset -- ----------- procedure Reset (D : in out Data) is begin Utils.Free (D.Binary_Data); D.Method := GET; D.HTTP_Version := Null_Unbounded_String; D.Content_Length := 0; D.Auth_Mode := None; D.Auth_Name := Null_Unbounded_String; D.Auth_Password := Null_Unbounded_String; D.Auth_Realm := Null_Unbounded_String; D.Auth_Nonce := Null_Unbounded_String; D.Auth_NC := Null_Unbounded_String; D.Auth_CNonce := Null_Unbounded_String; D.Auth_QOP := Null_Unbounded_String; D.Auth_Response := Null_Unbounded_String; D.Session_ID := AWS.Session.No_Session; D.Session_Created := False; AWS.Parameters.Set.Reset (D.Parameters); -- AWS.Headers.Set.Reset (D.Header); end Reset; ------------- -- Session -- ------------- procedure Session (D : in out Data) is begin D.Session_ID := AWS.Session.Create; D.Session_Created := True; end Session; end AWS.Status.Set; polyorb-2.8~20110207.orig/src/aws/soap-message-response-error.adb0000644000175000017500000001362611750740337024020 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- S O A P . M E S S A G E . R E S P O N S E . E R R O R -- -- -- -- B o d y -- -- -- -- Copyright (C) 2000-2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with SOAP.Types; with SOAP.Utils; package body SOAP.Message.Response.Error is Version_Mismatch_Faultcode : constant String := "VersionMismatch"; Must_Understand_Faultcode : constant String := "MustUnderstand"; Client_Faultcode : constant String := "Client"; Server_Faultcode : constant String := "Server"; Start_Fault_Env : constant String := ""; End_Fault_Env : constant String := ""; function Fault_Code (Name, Subname : String) return Faultcode; -- Returns the Faultcode for Name and Subname. If Subname is empty it -- returns Name otherwise it returns Name & '.' & Subname. ----------- -- Build -- ----------- function Build (Faultcode : Error.Faultcode; Faultstring : String) return Object is use SOAP.Types; use type SOAP.Parameters.List; O : Object; P : SOAP.Parameters.List; begin -- Set Wrapper Name Set_Wrapper_Name (O, "Fault"); -- Set Faultcode and Faultstring P := P & S (String (Faultcode), "faultcode") & S (Faultstring, "faultstring"); -- Set parameters for this error object Set_Parameters (O, P); return O; end Build; ------------ -- Client -- ------------ function Client (Subname : String := "") return Faultcode is begin return Fault_Code (Client_Faultcode, Subname); end Client; ---------------- -- Fault_Code -- ---------------- function Fault_Code (Name, Subname : String) return Faultcode is begin if Subname = "" then return Faultcode (Name); else return Faultcode (Name & '.' & Subname); end if; end Fault_Code; ---------- -- From -- ---------- function From (P : Message.Payload.Object) return Object is pragma Unreferenced (P); N : Object; begin return N; end From; -------------- -- Is_Error -- -------------- function Is_Error (E : Object) return Boolean is pragma Unreferenced (E); begin return True; end Is_Error; --------------------- -- Must_Understand -- --------------------- function Must_Understand (Subname : String := "") return Faultcode is begin return Fault_Code (Must_Understand_Faultcode, Subname); end Must_Understand; ------------ -- Server -- ------------ function Server (Subname : String := "") return Faultcode is begin return Fault_Code (Server_Faultcode, Subname); end Server; ---------------------- -- Version_Mismatch -- ---------------------- function Version_Mismatch (Subname : String := "") return Faultcode is begin return Fault_Code (Version_Mismatch_Faultcode, Subname); end Version_Mismatch; --------------- -- XML_Image -- --------------- function XML_Image (E : Object) return Unbounded_String is NL : constant String := ASCII.CR & ASCII.LF; Message_Body : Unbounded_String; begin -- Fault Env Append (Message_Body, Start_Fault_Env & NL); -- Fault's parameters declare P : constant SOAP.Parameters.List := Parameters (E); begin for K in 1 .. SOAP.Parameters.Argument_Count (P) loop declare P_K : constant SOAP.Types.Object'Class := SOAP.Parameters.Argument (P, K); P_Name : constant String := SOAP.Types.Name (P_K); begin Append (Message_Body, " " & Utils.Tag (P_Name, Start => True) & Types.Image (P_K) & Utils.Tag (P_Name, Start => False) & NL); end; end loop; end; -- End Fault Env Append (Message_Body, End_Fault_Env & NL); return Message_Body; end XML_Image; end SOAP.Message.Response.Error; polyorb-2.8~20110207.orig/src/aws/aws-headers-values.ads0000644000175000017500000001114511750740337022164 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- A W S . H E A D E R S . V A L U E S -- -- -- -- S p e c -- -- -- -- Copyright (C) 2002-2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with Ada.Strings.Unbounded; package AWS.Headers.Values is use Ada.Strings.Unbounded; -- Data represent a token from an header line. There is two kinds of -- token, either named or un-named. -- -- Content-Type: xyz boundary="uvt" -- -- Here xyz is an un-named value and uvt a named value the name is -- boundary. type Data (Named_Value : Boolean := True) is record Value : Unbounded_String; case Named_Value is when True => Name : Unbounded_String; when False => null; end case; end record; type Set is array (Positive range <>) of Data; ----------- -- Parse -- ----------- generic with procedure Value (Item : String; Quit : in out Boolean); -- Called for every un-named value read from the header value with procedure Named_Value (Name : String; Value : String; Quit : in out Boolean); -- Called for every named value read from the header value procedure Parse (Header_Value : String); -- Look for un-named values and named ones (Name="Value" pairs) in the -- header line, and call appropriate routines when found. Quit is set to -- False before calling Value or Named_Value, the parsing can be stopped -- by setting Quit to True. ------------------- -- Split / Index -- ------------------- function Split (Header_Value : String) return Set; -- Returns a Set with each named and un-named values splited from Data. function Index (Set : Values.Set; Name : String; Case_Sensitive : Boolean := True) return Natural; -- Returns index for Name in the set or 0 if Name not found. -- If Case_Sensitive is false the find is case_insensitive. --------------------------- -- Other search routines -- --------------------------- function Search (Header_Value : String; Name : String; Case_Sensitive : Boolean := True) return String; -- Returns Value for Name in Header_Value or the empty string if Name not -- found. If Case_Sensitive is False the search is case insensitive. function Get_Unnamed_Value (Header_Value : String; N : Positive := 1) return String; -- Returns N-th un-named value from Header_Value. function Unnamed_Value_Exists (Header_Value : String; Value : String; Case_Sensitive : Boolean := True) return Boolean; -- Returns True if the unnamed value specified has been found in -- Header_Value. end AWS.Headers.Values; polyorb-2.8~20110207.orig/src/aws/aws-status-translate_table.ads0000644000175000017500000000447511750740337023751 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- A W S . S T A T U S . T R A N S L A T E _ T A B L E -- -- -- -- S p e c -- -- -- -- Copyright (C) 2003-2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with AWS.Templates; function AWS.Status.Translate_Table (Status : Data) return Templates.Translate_Table; -- Returns a translate table with some status data. Here are a list of the -- tags: PEERNAME, METHOD, URI, HTTP_VERSION, AUTH_MODE, SOAP_ACTION, PAYLOAD. -- They correspond to the Status fields. polyorb-2.8~20110207.orig/src/aws/aws-response-set.ads0000644000175000017500000001366411750740337021713 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- A W S . R E S P O N S E . S E T -- -- -- -- S p e c -- -- -- -- Copyright (C) 2002-2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- with AWS.Net; package AWS.Response.Set is procedure Add_Header (D : in out Data; Name : String; Value : String); pragma Inline (Add_Header); -- Add header name/value to the header container. -- Should be used inside of server's callback when the user want -- to add its own header lines to the response. procedure Update_Header (D : in out Data; Name : String; Value : String; N : Positive := 1); pragma Inline (Update_Header); -- Update N-th header name/value in the header container. -- Should be used inside of server's callback when the user want -- to add/modify its own header lines to the response. -- procedure Read_Header (Socket : Net.Socket_Type'Class; D : in out Data); -- Read all header data from the socket and fill appropriate -- data's fields. procedure Mode (D : in out Data; Value : Data_Mode); pragma Inline (Mode); -- Set the data mode. -- Header, Message, File, Stream, Socket_Taken or No_Data. procedure Status_Code (D : in out Data; Value : Messages.Status_Code); pragma Inline (Status_Code); -- Set the status code procedure Content_Type (D : in out Data; Value : String); pragma Inline (Content_Type); -- Set the MIME type for the message body procedure Cache_Control (D : in out Data; Value : Messages.Cache_Option); pragma Inline (Cache_Control); -- Set the Cache_Control mode for the message procedure Content_Length (D : in out Data; Value : Natural); pragma Inline (Content_Length); -- Set the MIME content length for the message body procedure Filename (D : in out Data; Value : String); pragma Inline (Filename); -- Set the filename which should be sent back. -- set the Mode field to File. procedure Location (D : in out Data; Value : String); pragma Inline (Location); -- Set the location for the new page in the case of a moved -- message. Should be used with redirection 3xx status codes. procedure Authentication (D : in out Data; Realm : String; Mode : Authentication_Mode := Basic; Stale : Boolean := False); pragma Inline (Authentication); -- Set the authentication mode requested by server. Set the status code to -- the 401. procedure Stream (D : in out Data; Handle : Resources.Streams.Stream_Access; Content_Length : Content_Length_Type); pragma Inline (Stream); -- Set the user defined data stream. Set the Mode field to Stream. procedure Message_Body (D : in out Data; Value : Streams.Stream_Element_Array); pragma Inline (Message_Body); -- Set message body as a binary content. Set the Mode field to Message. procedure Message_Body (D : in out Data; Value : Utils.Stream_Element_Array_Access); pragma Inline (Message_Body); -- Set message body as a binary content. Set the Mode field to Message. -- Note that there is no need to free Value object. This will be done when -- the response object will have been sent. procedure Message_Body (D : in out Data; Value : Strings.Unbounded.Unbounded_String); pragma Inline (Message_Body); -- Set the message body content as a unbounded_string. Set the Mode field -- to Message. procedure Message_Body (D : in out Data; Value : String); pragma Inline (Message_Body); -- Set the message body content as a string. Set the Mode field to Message. procedure Message_Body (D : in out Data; Value : SOAP.Message.Response.Object); pragma Inline (Message_Body); -- Set the SOAP message body content as a soap response object. Set the -- Mode field to SOAP_Message function Is_Valid (D : Data) return Boolean; -- Checking validity of the HTTP response end AWS.Response.Set; polyorb-2.8~20110207.orig/src/aws/aws-response.adb0000644000175000017500000003537111750740337021100 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- A W S . R E S P O N S E -- -- -- -- B o d y -- -- -- -- Copyright (C) 2000-2009, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with Ada.Strings.Fixed; with Ada.Unchecked_Deallocation; with AWS.Headers.Set; with AWS.Headers.Values; with AWS.Resources.Embedded; with AWS.Response.Set; with AWS.Translator; package body AWS.Response is use Streams; ----------------- -- Acknowledge -- ----------------- function Acknowledge (Status_Code : Messages.Status_Code; Message_Body : String := ""; Content_Type : String := MIME.Text_HTML) return Data is Result : Data; begin Set.Status_Code (Result, Status_Code); if Message_Body = "" then Set.Mode (Result, Header); else Set.Message_Body (Result, Message_Body); Set.Content_Type (Result, Content_Type); end if; return Result; end Acknowledge; ------------ -- Adjust -- ------------ procedure Adjust (Object : in out Data) is begin Object.Ref_Counter.all := Object.Ref_Counter.all + 1; end Adjust; ------------------ -- Authenticate -- ------------------ function Authenticate (Realm : String; Mode : Authentication_Mode := Basic; Stale : Boolean := False) return Data is Result : Data; CRLF : constant String := ASCII.CR & ASCII.LF; Auth_Mess : constant String := "" & CRLF & "401 Authorization Required" & CRLF & "" & CRLF & "

Authorization Required

" & CRLF & "This server could not verify that you" & CRLF & "are authorized to access the document you" & CRLF & "requested. Either you supplied the wrong" & CRLF & "credentials (e.g., bad password), or your" & CRLF & "browser doesn't understand how to supply" & CRLF & "the credentials required.

" & CRLF & "" & CRLF; begin Set.Authentication (Result, Realm, Mode, Stale); Set.Content_Type (Result, AWS.MIME.Text_HTML); Set.Message_Body (Result, Auth_Mess); return Result; end Authenticate; -------------------- -- Authentication -- -------------------- function Authentication (D : Data) return Authentication_Mode is use AWS.Headers; Auth_Values : constant VString_Array := Get_Values (D.Header, Messages.WWW_Authenticate_Token); begin if Auth_Values'Length = 1 then return Authentication_Mode'Value (Values.Get_Unnamed_Value (To_String (Auth_Values (1)), 1)); else return Any; end if; end Authentication; -------------------------- -- Authentication_Stale -- -------------------------- function Authentication_Stale (D : Data) return Boolean is use AWS.Headers; Auth_Values : constant VString_Array := Get_Values (D.Header, Messages.WWW_Authenticate_Token); begin for J in Auth_Values'Range loop declare Stale_Image : constant String := Values.Search (To_String (Auth_Values (J)), "stale", False); begin if Stale_Image /= "" then return Boolean'Value (Stale_Image); end if; end; end loop; return False; end Authentication_Stale; ----------- -- Build -- ----------- function Build (Content_Type : String; Message_Body : String; Status_Code : Messages.Status_Code := Messages.S200; Cache_Control : Messages.Cache_Option := Messages.Unspecified) return Data is Result : Data; begin Set.Status_Code (Result, Status_Code); Set.Content_Type (Result, Content_Type); Set.Message_Body (Result, Message_Body); Set.Cache_Control (Result, Cache_Control); return Result; end Build; function Build (Content_Type : String; UString_Message : Strings.Unbounded.Unbounded_String; Status_Code : Messages.Status_Code := Messages.S200; Cache_Control : Messages.Cache_Option := Messages.Unspecified) return Data is Result : Data; begin Set.Status_Code (Result, Status_Code); Set.Content_Type (Result, Content_Type); Set.Message_Body (Result, UString_Message); Set.Cache_Control (Result, Cache_Control); return Result; end Build; function Build (Content_Type : String; Message_Body : Streams.Stream_Element_Array; Status_Code : Messages.Status_Code := Messages.S200; Cache_Control : Messages.Cache_Option := Messages.Unspecified) return Data is Result : Data; begin Set.Status_Code (Result, Status_Code); Set.Content_Type (Result, Content_Type); Set.Message_Body (Result, Message_Body); Set.Cache_Control (Result, Cache_Control); return Result; end Build; function Build (SOAP_Body : SOAP.Message.Response.Object) return Data is Result : Data; begin Set.Status_Code (Result, Messages.S200); Set.Content_Type (Result, AWS.MIME.Text_XML); Set.Message_Body (Result, SOAP_Body); Set.Cache_Control (Result, Messages.Unspecified); return Result; end Build; ------------------- -- Cache_Control -- ------------------- function Cache_Control (D : Data) return Messages.Cache_Option is begin return Messages.Cache_Option (Headers.Get (D.Header, Messages.Cache_Control_Token)); end Cache_Control; -------------------- -- Content_Length -- -------------------- function Content_Length (D : Data) return Content_Length_Type is begin return D.Content_Length; end Content_Length; ------------------ -- Content_Type -- ------------------ function Content_Type (D : Data) return String is begin return Headers.Get (D.Header, Messages.Content_Type_Token); end Content_Type; ---------------------- -- Create_Resource -- ---------------------- procedure Create_Resource (File : out AWS.Resources.File_Type; D : Data) is use AWS.Resources; begin case D.Mode is when Response.File => Open (File, Filename (D), "shared=no"); when Response.Stream => Resources.Streams.Create (File, D.Stream); when Response.Message => Embedded.Create (File, Embedded.Buffer_Access (D.Message_Body)); when others => -- Should not be called for others response modes. raise Constraint_Error; end case; end Create_Resource; ----------- -- Empty -- ----------- function Empty return Data is Result : Data; begin Set.Status_Code (Result, Messages.S204); return Result; end Empty; ---------- -- File -- ---------- function File (Content_Type : String; Filename : String; Status_Code : Messages.Status_Code := Messages.S200) return Data is Result : Data; begin Set.Status_Code (Result, Status_Code); Set.Content_Type (Result, Content_Type); Set.Filename (Result, Filename); return Result; exception when Resources.Resource_Error => return Acknowledge (Messages.S404, "

" & Filename & " not found"); end File; -------------- -- Filename -- -------------- function Filename (D : Data) return String is begin return To_String (D.Filename); end Filename; -------------- -- Finalize -- -------------- procedure Finalize (Object : in out Data) is procedure Free is new Ada.Unchecked_Deallocation (Natural, Natural_Access); begin Object.Ref_Counter.all := Object.Ref_Counter.all - 1; if Object.Ref_Counter.all = 0 then Free (Object.Ref_Counter); Utils.Free (Object.Message_Body); AWS.Headers.Set.Free (Object.Header); end if; end Finalize; ------------ -- Header -- ------------ function Header (D : Data; Name : String; N : Positive) return String is begin return Headers.Get (D.Header, Name, N); end Header; function Header (D : Data; Name : String) return String is begin return Headers.Get_Values (D.Header, Name); end Header; ---------------- -- Initialize -- ---------------- procedure Initialize (Object : in out Data) is begin Object.Ref_Counter := new Natural'(1); AWS.Headers.Set.Reset (Object.Header); end Initialize; -------------- -- Location -- -------------- function Location (D : Data) return String is begin return Headers.Get (D.Header, Messages.Location_Token); end Location; ------------------ -- Message_Body -- ------------------ function Message_Body (D : Data) return String is use type Utils.Stream_Element_Array_Access; begin if D.Message_Body = null then return ""; else return Translator.To_String (D.Message_Body.all); end if; end Message_Body; function Message_Body (D : Data) return Unbounded_String is use type Utils.Stream_Element_Array_Access; begin if D.Message_Body = null then return Null_Unbounded_String; else return Translator.To_Unbounded_String (D.Message_Body.all); end if; end Message_Body; function Message_Body (D : Data) return Streams.Stream_Element_Array is use type Utils.Stream_Element_Array_Access; No_Data : constant Streams.Stream_Element_Array := (1 .. 0 => 0); begin if D.Message_Body = null then return No_Data; else return D.Message_Body.all; end if; end Message_Body; ------------------ -- SOAP_Message -- ------------------ function SOAP_Message (D : Data) return SOAP.Message.Response.Object is begin return D.SOAP_Message; end SOAP_Message; ---------- -- Mode -- ---------- function Mode (D : Data) return Data_Mode is begin return D.Mode; end Mode; ----------- -- Moved -- ----------- function Moved (Location : String; Message : String := Default_Moved_Message) return Data is use Ada.Strings; Result : Data; function Build_Message_Body return String; -- Returns proper message body using Message template. It replaces _@_ -- in Message by Location. ------------------------ -- Build_Message_Body -- ------------------------ function Build_Message_Body return String is Start : constant Natural := Fixed.Index (Message, "_@_"); begin if Start = 0 then return Message; else return Fixed.Replace_Slice (Message, Start, Start + 2, Location); end if; end Build_Message_Body; Message_Body : constant String := Build_Message_Body; begin Set.Location (Result, Location); Set.Status_Code (Result, Messages.S301); Set.Message_Body (Result, Message_Body); Set.Content_Type (Result, AWS.MIME.Text_HTML); return Result; end Moved; ----------- -- Realm -- ----------- function Realm (D : Data) return String is use Headers; begin return Values.Search (Header_Value => Get (D.Header, Messages.WWW_Authenticate_Token), Name => "realm", Case_Sensitive => False); end Realm; ----------------- -- Send_Header -- ----------------- -- procedure Send_Header (Socket : Net.Socket_Type'Class; D : Data) is -- begin -- Headers.Send_Header (Socket, D.Header); -- end Send_Header; ------------------ -- Socket_Taken -- ------------------ function Socket_Taken return Data is Result : Data; begin Set.Mode (Result, Socket_Taken); return Result; end Socket_Taken; ----------------- -- Status_Code -- ----------------- function Status_Code (D : Data) return Messages.Status_Code is begin return D.Status_Code; end Status_Code; ------------ -- Stream -- ------------ function Stream (Content_Type : String; Stream_Handle : Resources.Streams.Stream_Access; Stream_Size : Content_Length_Type := Undefined_Length; Status_Code : Messages.Status_Code := Messages.S200; Cache_Control : Messages.Cache_Option := Messages.No_Cache) return Data is Result : Data; begin Set.Stream (Result, Stream_Handle, Stream_Size); Set.Status_Code (Result, Status_Code); Set.Content_Type (Result, Content_Type); Set.Cache_Control (Result, Cache_Control); return Result; end Stream; --------- -- URL -- --------- function URL (Location : String) return Data is Result : Data; begin Set.Status_Code (Result, Messages.S301); Set.Location (Result, Location); Set.Mode (Result, Header); return Result; end URL; end AWS.Response; polyorb-2.8~20110207.orig/src/polyorb-annotations.adb0000644000175000017500000001141211750740340021661 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . A N N O T A T I O N S -- -- -- -- B o d y -- -- -- -- Copyright (C) 2001-2009, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- Support the addition of external information ("annotations") -- to objects by their client. The object does not need to have -- visibility on the client in order to allow itself to be annotated; -- it only needs to expose a Notepad attribute. with Ada.Tags; with Ada.Unchecked_Deallocation; package body PolyORB.Annotations is use Ada.Tags; use Note_Lists; -------------- -- Set_Note -- -------------- procedure Set_Note (NP : in out Notepad; N : Note'Class) is It : Iterator := First (NP); begin while not Last (It) loop if Value (It).all'Tag = N'Tag then Value (It).all.all := N; -- Here we have checked that The_Notes (I).all and N -- are of the same type, but this does not guarantee -- that the assignment will succeed: Constraint_Error -- may be raised if that type has known discriminants -- without default values. return; end if; Next (It); end loop; Append (NP, new Note'Class'(N)); end Set_Note; ------------------------- -- Get_Note_If_Present -- ------------------------- procedure Get_Note_If_Present (NP : Notepad; N : out Note'Class; Present : out Boolean); procedure Get_Note_If_Present (NP : Notepad; N : out Note'Class; Present : out Boolean) is It : Iterator := First (NP); begin while not Last (It) loop if Value (It).all'Tag = N'Tag then N := Value (It).all.all; Present := True; return; end if; Next (It); end loop; Present := False; end Get_Note_If_Present; -------------- -- Get_Note -- -------------- procedure Get_Note (NP : Notepad; N : out Note'Class) is Present : Boolean; begin Get_Note_If_Present (NP, N, Present); if not Present then raise Constraint_Error; end if; end Get_Note; procedure Get_Note (NP : Notepad; N : out Note'Class; Default : Note'Class) is Present : Boolean; begin Get_Note_If_Present (NP, N, Present); if not Present then N := Default; end if; end Get_Note; ------------- -- Destroy -- ------------- procedure Destroy (NP : in out Notepad) is It : Iterator := First (NP); procedure Free is new Ada.Unchecked_Deallocation (Note'Class, Note_Access); begin while not Last (It) loop Destroy (Value (It).all.all); Free (Value (It).all); Next (It); end loop; Deallocate (NP); end Destroy; procedure Destroy (N : in out Note) is pragma Unreferenced (N); begin null; end Destroy; end PolyORB.Annotations; polyorb-2.8~20110207.orig/src/polyorb-poa_types.adb0000644000175000017500000003744611750740340021346 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . P O A _ T Y P E S -- -- -- -- B o d y -- -- -- -- Copyright (C) 2001-2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with Ada.Streams; with Ada.Unchecked_Conversion; with PolyORB.Log; package body PolyORB.POA_Types is use Ada.Streams; use PolyORB.Log; package L is new PolyORB.Log.Facility_Log ("polyorb.poa_types"); procedure O (Message : String; Level : Log_Level := Debug) renames L.Output; function C (Level : Log_Level := Debug) return Boolean renames L.Enabled; -- Object ids are represented as stream element arrays -- using a private representation, that need not be -- compatible with anything external. The only constraint -- is that the Get_* and Put_* subprograms below be -- consistent. -- We assume that a time stamp's size is always an integral multiple of -- the size of an unsigned long integer. ULongs_In_Time_Stamp : constant := Time_Stamp'Size / Types.Unsigned_Long'Size; type Time_Stamp_As_ULongs is array (1 .. ULongs_In_Time_Stamp) of Types.Unsigned_Long; function To_ULongs is new Ada.Unchecked_Conversion (Time_Stamp, Time_Stamp_As_ULongs); function From_ULongs is new Ada.Unchecked_Conversion (Time_Stamp_As_ULongs, Time_Stamp); -- The Get_* procedures operate at index SEI in array SEA, -- and advance SEI by the number of consumed Stream_Elements. procedure Get_Time_Stamp (SEA : Object_Id; SEI : in out Stream_Element_Offset; TS : out Time_Stamp; Error : in out PolyORB.Errors.Error_Container); -- Extract a time stamp function Put_Time_Stamp (TS : Time_Stamp) return Object_Id; -- Store a time stamp procedure Get_ULong (SEA : Object_Id; SEI : in out Stream_Element_Offset; ULo : out Types.Unsigned_Long; Error : in out PolyORB.Errors.Error_Container); -- Extract an unsigned long. function Put_ULong (ULo : Types.Unsigned_Long) return Object_Id; -- Store an unsigned long as 8 hexadecimal digits procedure Get_Boolean (SEA : Object_Id; SEI : in out Stream_Element_Offset; Boo : out Types.Boolean; Error : in out PolyORB.Errors.Error_Container); -- Extract a boolean function Put_Boolean (Boo : Types.Boolean) return Object_Id; -- Store a boolean procedure Get_String_With_Length (SEA : Object_Id; SEI : in out Stream_Element_Offset; Str : out Types.String; Error : in out PolyORB.Errors.Error_Container); -- Extract a string stored with prefixed U_Long length function Put_String (Str : Types.String; With_Length : Boolean := True) return Object_Id; -- Store a string (with optional U_Long length prefixed) -- If a string is stored without length, it is the caller's responsibility -- to delimit it as appropriate. --------- -- "=" -- --------- function "=" (Left, Right : Unmarshalled_Oid) return Standard.Boolean is begin return True and then Left.Id = Right.Id and then Left.System_Generated = Right.System_Generated and then Left.Persistency_Flag = Right.Persistency_Flag; end "="; --------------- -- Create_Id -- --------------- function Create_Id (Name : Standard.String; System_Generated : Types.Boolean; Persistency_Flag : Lifespan_Cookie; Creator : Standard.String) return Unmarshalled_Oid_Access is begin return new Unmarshalled_Oid' (Id => To_PolyORB_String (Name), System_Generated => System_Generated, Persistency_Flag => Persistency_Flag, Creator => To_PolyORB_String (Creator)); end Create_Id; function Create_Id (Name : Standard.String; System_Generated : Boolean; Persistency_Flag : Time_Stamp; Creator : Standard.String) return Unmarshalled_Oid is begin return Unmarshalled_Oid' (Id => To_PolyORB_String (Name), System_Generated => System_Generated, Persistency_Flag => Persistency_Flag, Creator => To_PolyORB_String (Creator)); end Create_Id; function Create_Id (Name : Standard.String; System_Generated : Types.Boolean; Persistency_Flag : Lifespan_Cookie; Creator : Standard.String) return Object_Id_Access is begin return U_Oid_To_Oid (Unmarshalled_Oid' (Id => To_PolyORB_String (Name), System_Generated => System_Generated, Persistency_Flag => Persistency_Flag, Creator => To_PolyORB_String (Creator))); end Create_Id; -------------------- -- Get_Time_Stamp -- -------------------- procedure Get_Time_Stamp (SEA : Object_Id; SEI : in out Stream_Element_Offset; TS : out Time_Stamp; Error : in out PolyORB.Errors.Error_Container) is ULongs : Time_Stamp_As_ULongs; begin for J in ULongs'Range loop Get_ULong (SEA, SEI, ULongs (J), Error); if Errors.Found (Error) then pragma Warnings (Off); -- "TS" not set before return return; pragma Warnings (On); end if; end loop; TS := From_ULongs (ULongs); end Get_Time_Stamp; -------------------- -- Put_Time_Stamp -- -------------------- function Put_Time_Stamp (TS : Time_Stamp) return Object_Id is ULongs : constant Time_Stamp_As_ULongs := To_ULongs (TS); Result : Object_Id (1 .. 8 * ULongs'Length); First : Stream_Element_Offset := Result'First; begin for J in ULongs'Range loop Result (First .. First + 7) := Put_ULong (ULongs (J)); First := First + 8; end loop; return Result; end Put_Time_Stamp; --------------- -- Get_ULong -- --------------- Hex_Val : constant array (Stream_Element) of Types.Unsigned_Long := (Character'Pos ('0') => 0, Character'Pos ('1') => 1, Character'Pos ('2') => 2, Character'Pos ('3') => 3, Character'Pos ('4') => 4, Character'Pos ('5') => 5, Character'Pos ('6') => 6, Character'Pos ('7') => 7, Character'Pos ('8') => 8, Character'Pos ('9') => 9, Character'Pos ('A') => 10, Character'Pos ('a') => 10, Character'Pos ('B') => 11, Character'Pos ('b') => 11, Character'Pos ('C') => 12, Character'Pos ('c') => 12, Character'Pos ('D') => 13, Character'Pos ('d') => 13, Character'Pos ('E') => 14, Character'Pos ('e') => 14, Character'Pos ('F') => 15, Character'Pos ('f') => 15, others => 0); procedure Get_ULong (SEA : Object_Id; SEI : in out Stream_Element_Offset; ULo : out Types.Unsigned_Long; Error : in out PolyORB.Errors.Error_Container) is R : Types.Unsigned_Long := 0; begin if SEI + 7 > SEA'Last then PolyORB.Errors.Throw (Error, PolyORB.Errors.Invalid_Object_Id_E, PolyORB.Errors.Null_Member); ULo := 0; return; end if; for J in Stream_Element_Offset range 0 .. 7 loop R := R * 16 + Hex_Val (SEA (SEI + J)); end loop; ULo := R; SEI := SEI + 8; end Get_ULong; --------------- -- Put_ULong -- --------------- Hex : constant array (Types.Unsigned_Long range 0 .. 15) of Stream_Element := (Character'Pos ('0'), Character'Pos ('1'), Character'Pos ('2'), Character'Pos ('3'), Character'Pos ('4'), Character'Pos ('5'), Character'Pos ('6'), Character'Pos ('7'), Character'Pos ('8'), Character'Pos ('9'), Character'Pos ('a'), Character'Pos ('b'), Character'Pos ('c'), Character'Pos ('d'), Character'Pos ('e'), Character'Pos ('f')); function Put_ULong (ULo : Types.Unsigned_Long) return Object_Id is R : Object_Id (0 .. 7); U : Types.Unsigned_Long := ULo; begin for J in reverse R'Range loop R (J) := Hex (U mod 16); U := U / 16; end loop; return R; end Put_ULong; ----------------- -- Get_Boolean -- ----------------- procedure Get_Boolean (SEA : Object_Id; SEI : in out Stream_Element_Offset; Boo : out Types.Boolean; Error : in out PolyORB.Errors.Error_Container) is begin case SEA (SEI) is when Character'Pos ('F') => Boo := False; when Character'Pos ('T') => Boo := True; when others => Boo := False; PolyORB.Errors.Throw (Error, PolyORB.Errors.Invalid_Object_Id_E, PolyORB.Errors.Null_Member); end case; SEI := SEI + 1; end Get_Boolean; ----------------- -- Put_Boolean -- ----------------- Bool_To_SE : constant array (Boolean) of Stream_Element := (False => Character'Pos ('F'), True => Character'Pos ('T')); function Put_Boolean (Boo : Types.Boolean) return Object_Id is begin return Object_Id'(0 .. 0 => Bool_To_SE (Boo)); end Put_Boolean; ---------------------------- -- Get_String_With_Length -- ---------------------------- procedure Get_String_With_Length (SEA : Object_Id; SEI : in out Stream_Element_Offset; Str : out Types.String; Error : in out PolyORB.Errors.Error_Container) is Len : Types.Unsigned_Long; begin Get_ULong (SEA, SEI, Len, Error); if SEI + Stream_Element_Offset (Len) > SEA'Last + Stream_Element_Offset (1) or else PolyORB.Errors.Found (Error) then Str := Types.To_PolyORB_String (""); PolyORB.Errors.Throw (Error, PolyORB.Errors.Invalid_Object_Id_E, PolyORB.Errors.Null_Member); return; end if; if Len > 0 then declare S : Standard.String (1 .. Integer (Len)); pragma Import (Ada, S); for S'Address use SEA (SEI)'Address; begin Str := To_PolyORB_String (S); end; end if; SEI := SEI + Stream_Element_Offset (Len); end Get_String_With_Length; ---------------- -- Put_String -- ---------------- function Put_String (Str : Types.String; With_Length : Boolean := True) return Object_Id is S : constant Standard.String := To_Standard_String (Str); begin if S'Length = 0 then if With_Length then return Put_ULong (0); else return Object_Id'(1 .. 0 => 0); end if; end if; declare R : Object_Id (1 .. S'Length); pragma Import (Ada, R); for R'Address use S (S'First)'Address; begin if With_Length then return Put_ULong (S'Length) & R; else return R; end if; end; end Put_String; ----------------- -- Get_Creator -- ----------------- function Get_Creator (Oid : Object_Id) return String is Sep : Integer; Oid_Str : String (1 .. Oid'Length); pragma Import (Ada, Oid_Str); for Oid_Str'Address use Oid (Oid'First)'Address; begin -- Determine last character of Creator by looking for last -- occurrence of POA_Path_Separator. If there is no occurrence, -- the whole string is the Creator. Sep := Utils.Find (Oid_Str, Oid_Str'Last, POA_Path_Separator, Skip => False, Direction => Utils.Backward); if Sep < Oid_Str'First then -- No POA_Path_Separator: the whole string is the Creator Sep := Oid_Str'Last + 1; end if; if Sep = Oid_Str'First then -- Empty creator, we may not index Oid_Str with Sep - 1 as it is -- out of range. return ""; else return Oid_Str (Oid_Str'First .. Sep - 1); end if; end Get_Creator; ------------------ -- Oid_To_U_Oid -- ------------------ procedure Oid_To_U_Oid (Oid : Object_Id; U_Oid : out Unmarshalled_Oid; Error : in out PolyORB.Errors.Error_Container) is Index : Stream_Element_Offset := Oid'First; Creator : constant String := Get_Creator (Oid); begin U_Oid.System_Generated := False; U_Oid.Persistency_Flag := Null_Time_Stamp; U_Oid.Creator := To_PolyORB_String (Creator); Index := Oid'First + Stream_Element_Offset (Creator'Length) + 1; if Index <= Oid'Last then Get_String_With_Length (Oid, Index, U_Oid.Id, Error); if PolyORB.Errors.Found (Error) then return; end if; Get_Boolean (Oid, Index, U_Oid.System_Generated, Error); if PolyORB.Errors.Found (Error) then return; end if; Get_Time_Stamp (Oid, Index, U_Oid.Persistency_Flag, Error); if PolyORB.Errors.Found (Error) then return; end if; end if; pragma Assert (Index > Oid'Last); end Oid_To_U_Oid; ------------------ -- U_Oid_To_Oid -- ------------------ function U_Oid_To_Oid (U_Oid : Unmarshalled_Oid) return Object_Id_Access is Oid : constant Object_Id := U_Oid_To_Oid (U_Oid); Oid_A : constant Object_Id_Access := new Object_Id'(Oid); begin pragma Debug (C, O ("Oid is " & Image (Oid))); return Oid_A; end U_Oid_To_Oid; function U_Oid_To_Oid (U_Oid : Unmarshalled_Oid) return Object_Id is begin return Put_String (U_Oid.Creator, With_Length => False) & Character'Pos (POA_Path_Separator) & Put_String (U_Oid.Id) & Put_Boolean (U_Oid.System_Generated) & Put_Time_Stamp (U_Oid.Persistency_Flag); end U_Oid_To_Oid; end PolyORB.POA_Types; polyorb-2.8~20110207.orig/src/polyorb-sequences-unbounded-search.ads0000644000175000017500000000505011750740340024565 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . S E Q U E N C E S . U N B O U N D E D . S E A R C H -- -- -- -- S p e c -- -- -- -- Copyright (C) 2002-2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ generic type Needle_Type is private; with function Match (Item : Element; Needle : Needle_Type) return Boolean; package PolyORB.Sequences.Unbounded.Search is function Index (Haystack : Sequence; Needle : Needle_Type; Going : Direction := Forward) return Natural; function Sub_Sequence (Haystack : Sequence; Needle : Needle_Type) return Sequence; function Count (Haystack : Sequence; Needle : Needle_Type) return Natural; end PolyORB.Sequences.Unbounded.Search; polyorb-2.8~20110207.orig/src/polyorb-object_maps.adb0000644000175000017500000000556511750740340021626 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . O B J E C T _ M A P S -- -- -- -- B o d y -- -- -- -- Copyright (C) 2002-2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ package body PolyORB.Object_Maps is use PolyORB.POA_Types; ------------- -- Is_Null -- ------------- function Is_Null (Item : Object_Map_Entry_Access) return Boolean is begin return Item = null; end Is_Null; ------------------- -- Is_Servant_In -- ------------------- function Is_Servant_In (O_Map : Object_Map; Item : PolyORB.Servants.Servant_Access) return Boolean is begin return not Is_Null (Get_By_Servant (Object_Map'Class (O_Map), Item)); end Is_Servant_In; --------------------- -- Is_Object_Id_In -- --------------------- function Is_Object_Id_In (O_Map : Object_Map; Item : PolyORB.POA_Types.Unmarshalled_Oid) return Boolean is begin return not Is_Null (Get_By_Id (Object_Map'Class (O_Map), Item)); end Is_Object_Id_In; end PolyORB.Object_Maps; polyorb-2.8~20110207.orig/src/polyorb-fixed_point.adb0000644000175000017500000000772511750740340021650 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . F I X E D _ P O I N T -- -- -- -- B o d y -- -- -- -- Copyright (C) 2002-2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- Generic representation for fixed point types as an array -- of BCD nibbles followed by a sign indication. package body PolyORB.Fixed_Point is package body Fixed_Point_Conversion is Max_Nibbles : constant Integer := 2 * ((F'Digits + 2) / 2); -- F'Digits + sign indication, rounded up towards an even -- number. ---------------------- -- Fixed_To_Nibbles -- ---------------------- function Fixed_To_Nibbles (Data : F) return Nibbles is Result : Nibbles (1 .. Max_Nibbles) := (others => 0); First_Digit : Integer := Result'Last; Val : F := Data; begin if Data >= 0.0 then Result (First_Digit) := Fixed_Positive_Zero; else Result (First_Digit) := Fixed_Negative; Val := -Val; end if; while Val /= 0.0 loop First_Digit := First_Digit - 1; Result (First_Digit) := Nibble ((Val - 10 * (Val / 10)) / F'Small); Val := Val / 10; end loop; -- Always return a full length array, including leading zeroes return Result; end Fixed_To_Nibbles; ---------------------- -- Nibbles_To_Fixed -- ---------------------- function Nibbles_To_Fixed (Data : Nibbles) return F is Result : F := 0.0; begin for J in Data'First .. Data'Last - 1 loop if Data (J) not in Decimal_Nibble then raise Constraint_Error; end if; Result := (Result * 10.0) + (Integer (Data (J)) * F'Small); end loop; case Data (Data'Last) is when Fixed_Positive_Zero => null; when Fixed_Negative => Result := -Result; when others => raise Constraint_Error; end case; return Result; end Nibbles_To_Fixed; end Fixed_Point_Conversion; end PolyORB.Fixed_Point; polyorb-2.8~20110207.orig/src/polyorb-utils-configuration_file.ads0000644000175000017500000000671311750740340024361 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . U T I L S . C O N F I G U R A T I O N _ F I L E -- -- -- -- S p e c -- -- -- -- Copyright (C) 2005-2011, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with PolyORB.Utils.Strings; with PolyORB.Utils.HTables.Perfect; with PolyORB.Utils.HFunctions.Hyper; package PolyORB.Utils.Configuration_File is package Configuration_Table is new PolyORB.Utils.HTables.Perfect ( PolyORB.Utils.Strings.String_Ptr, PolyORB.Utils.HFunctions.Hyper.Hash_Hyper_Parameters, PolyORB.Utils.HFunctions.Hyper.Default_Hash_Parameters, PolyORB.Utils.HFunctions.Hyper.Hash, PolyORB.Utils.HFunctions.Hyper.Next_Hash_Parameters); procedure Load_Configuration_Table (Configuration_Filename : String; Is_Default : Boolean; Table : in out Configuration_Table.Table_Instance); -- Load Configuration_Filename configuration file into Table. -- Is_Default is True if the Configuration_Filename is the default one. -- The following helper functions allow the manipulation of a -- configuration table and then writes it into a configuration -- file that can be further read by a PolyORB-based application. procedure Set_Conf (Configuration_Filename, Section, Key, Value : String); -- Add or rewrite a configuration (Section, Key) tuple with Value procedure Reset; -- Reset local configuration table procedure Display; -- Display the configuration table (only for debugging purposes) procedure Generate_Configuration_File (Configuration_Filename : String); -- Generate the configuration file end PolyORB.Utils.Configuration_File; polyorb-2.8~20110207.orig/src/polyorb-utils-tcp_access_points.ads0000644000175000017500000000620711750740340024214 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . U T I L S . T C P _ A C C E S S _ P O I N T S -- -- -- -- S p e c -- -- -- -- Copyright (C) 2003-2007, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- Helper subprograms to set up access points based on TCP sockets -- for a PolyORB server. with PolyORB.Binding_Data; with PolyORB.Sockets; with PolyORB.Transport; with PolyORB.Utils.Socket_Access_Points; package PolyORB.Utils.TCP_Access_Points is use PolyORB.Binding_Data; use PolyORB.Sockets; use PolyORB.Transport; use PolyORB.Utils.Socket_Access_Points; ---------------------------------- -- Access_Point_Info descriptor -- ---------------------------------- type Access_Point_Info is record Socket : Socket_Type; Address : Sock_Addr_Type; SAP : Transport_Access_Point_Access; PF : Profile_Factory_Access; end record; procedure Initialize_Socket (API : in out Access_Point_Info; Address : Sockets.Inet_Addr_Type := Any_Inet_Addr; Port_Hint : Port_Interval); -- Initialize API.Socket and bind it to a free port, using one of -- the address corresponding to hostname, or use Address, and within -- the range given by Port_Hint if applicable (if Port_Hint.Lo is -- Any_Port, then Port_Hing.Hi is ignored). end PolyORB.Utils.TCP_Access_Points; polyorb-2.8~20110207.orig/src/polyorb-servants.ads0000644000175000017500000001135311750740340021216 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . S E R V A N T S -- -- -- -- S p e c -- -- -- -- Copyright (C) 2002-2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- Root type for concrete object implementations (servants) with PolyORB.Annotations; with PolyORB.Components; with PolyORB.Requests; package PolyORB.Servants is ------------- -- Servant -- ------------- -- A Servant is a Component that supports the messages defined in -- PolyORB.Servants.Interface. This type may be further derived by -- units implementing a specific applicative personality. type Servant is abstract new PolyORB.Components.Component with private; type Servant_Access is access all Servant'Class; function Handle_Message (S : not null access Servant; Msg : Components.Message'Class) return Components.Message'Class; function Execute_Servant (S : not null access Servant; Req : Requests.Request_Access) return Boolean is abstract; -- This primitive is redispatched to by Handle_Message to process -- the Execute_Request message. Note that we explicitly specify -- null-exclusion here so that the semantics of this declaration are -- consistent when compiled in Ada 95 and in Ada 2005 mode. This is -- needed because Servant is derived in the PolyORB version of -- System.Partition_Interface, which is always processed in Ada 2005 mode. -- Returns True if the request has been executed (and can be destroyed), -- False if the request has been queued for later execution. function Abortable_Execute_Servant (S : not null access Servant'Class; Req : Requests.Request_Access) return Boolean; -- Call Execute_Servant within an Abortable object function Notepad_Of (S : Servant_Access) return PolyORB.Annotations.Notepad_Access; pragma Inline (Notepad_Of); -- Return Notepad associated to a servant -------------- -- Executor -- -------------- -- An Executor is responsible for establishing the proper context to -- perform a call to Abortable_Execute_Servant, depending on object adapter -- thread policy. By default, Execute_In_Context just makes the call in the -- current task. Object adapters may provide derived executor types, e.g. -- to grab appropriate locks. type Executor is tagged limited private; type Executor_Access is access all Executor'Class; function Execute_In_Context (Self : access Executor; Req : Requests.Request_Access; Requestor : Components.Component_Access) return Boolean; procedure Set_Executor (S : access Servant; Exec : Executor_Access); pragma Inline (Set_Executor); private type Executor is tagged limited null record; type Servant is abstract new PolyORB.Components.Component with record Exec : Executor_Access; Notepad : aliased PolyORB.Annotations.Notepad; end record; end PolyORB.Servants; polyorb-2.8~20110207.orig/src/polyorb-tasking.ads0000644000175000017500000000552411750740340021014 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . T A S K I N G -- -- -- -- S p e c -- -- -- -- Copyright (C) 2002-2004 Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by ACT Europe. -- -- (email: sales@act-europe.fr) -- -- -- ------------------------------------------------------------------------------ -- The children of this package provides soft links for the tasking. -- Coding guidelines for children of this package: -- ----------------------------------------------- -- In order to compile in High Integrity mode, it should not use: -- * exception handlers; -- * string concatenation (&); -- * outputs; -- * implicit loops (for example, the initialisation of an array must use -- an explicit loop); -- * controled types. -- Dynamic allocation should be avoided; they should either be placed -- in profile specific parts (if the profile allows it), or it should -- be the responsability of the client of these packages. -- As a special exception, some allocation and initialization for -- these packages can be done at elaboration. They should be minimal. package PolyORB.Tasking is pragma Pure; end PolyORB.Tasking; polyorb-2.8~20110207.orig/src/polyorb-utils-htables.ads0000644000175000017500000000642011750740340022130 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . U T I L S . H T A B L E S -- -- -- -- S p e c -- -- -- -- Copyright (C) 2002-2003 Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by ACT Europe. -- -- (email: sales@act-europe.fr) -- -- -- ------------------------------------------------------------------------------ -- Parent package for Hash Tables. package PolyORB.Utils.HTables is pragma Pure; -- Every hash table HTable on a given Item type must define -- the following procedures and functions. -- function Lookup -- (T : HTable; -- Key : String; -- Error_Value : Item) -- return Item; -- -- Find Key in hash table and return its associated Item. -- -- When Key does not exist, the function returns Error_Value. -- function Lookup -- (T : HTable; -- Key : String) -- return Item; -- -- Find Key in hash table and return its associated Item. -- -- When Key does not exist, the function raise No_Key exception. -- procedure Insert -- (T : HTable; -- Key : String; -- Value : Item); -- -- Insert (Key, Value) in hash table. -- -- Key is the string to hash and Value its associated Item. -- -- If Key already exists, nothing is done. -- procedure Delete -- (T : HTable; -- Key : String); -- -- Delete key in hash table. In case of a non-existing Key, Delete -- -- ignores deletion. Key is the string to hash. end PolyORB.Utils.HTables; polyorb-2.8~20110207.orig/src/polyorb-utils-sockets.adb0000644000175000017500000002111511750740340022136 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . U T I L S . S O C K E T S -- -- -- -- B o d y -- -- -- -- Copyright (C) 2003-2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with Ada.Exceptions; with Ada.Strings.Fixed; with PolyORB.Log; with PolyORB.Representations.CDR.Common; with PolyORB.Types; package body PolyORB.Utils.Sockets is use Ada.Strings; use Ada.Strings.Fixed; use PolyORB.Buffers; use PolyORB.Log; use PolyORB.Sockets; use PolyORB.Representations.CDR.Common; package L is new PolyORB.Log.Facility_Log ("polyorb.utils.sockets"); procedure O (Message : String; Level : Log_Level := Debug) renames L.Output; function C (Level : Log_Level := Debug) return Boolean renames L.Enabled; --------- -- "+" -- --------- function "+" (Host_Name : String; Port : PolyORB.Sockets.Port_Type) return Socket_Name is begin return Socket_Name'(Name_Len => Host_Name'Length, Host_Name => Host_Name, Port => Port); end "+"; -------------------- -- Connect_Socket -- -------------------- procedure Connect_Socket (Sock : in out PolyORB.Sockets.Socket_Type; Remote_Name : Socket_Name) is function Try_One_Address (Remote_Addr : Sock_Addr_Type; Last : Boolean) return Boolean; -- Try one of Remote_Name's aliases. Return True for a successful -- connection. For a failed connection, if Last is False, there are -- other addresses to try, so we return False to indicate non-fatal -- failure. Otherwise an exception is propagated. --------------------- -- Try_One_Address -- --------------------- function Try_One_Address (Remote_Addr : Sock_Addr_Type; Last : Boolean) return Boolean is Remote_Addr_Var : Sock_Addr_Type := Remote_Addr; pragma Warnings (Off, Remote_Addr_Var); -- WAG:61 -- Connect_Socket should take a parameter of mode IN, not IN OUT. -- This is fixed in GNAT 6.2, and we can do away with this variable -- when earlier versions aren't supported anymore. In the meantime, -- we need to keep the variable, and for 6.2 and later compilers we -- kill the "variable not modified" warning. begin pragma Debug (C, O ("... trying " & Image (Remote_Addr))); PolyORB.Sockets.Connect_Socket (Sock, Remote_Addr_Var); return True; exception when Socket_Error => if Last then raise; else return False; end if; end Try_One_Address; Host_Name : String renames Remote_Name.Host_Name; begin pragma Debug (C, O ("connect socket" & Image (Sock) & " to " & Image (Remote_Name))); if Is_IP_Address (Host_Name) then if not Try_One_Address ((Family => Family_Inet, Addr => Inet_Addr (Host_Name), Port => Remote_Name.Port), Last => True) then -- Should never happen, Last = True so in case of error, -- an exception is expected. raise Program_Error; end if; else declare Host_Entry : constant Host_Entry_Type := Get_Host_By_Name (Host_Name); Addresses_Len : constant Natural := PolyORB.Sockets.Addresses_Length (Host_Entry); begin -- Iterate over all addresses associated with name for J in 1 .. Addresses_Len loop if Try_One_Address ((Family => Family_Inet, Addr => Addresses (Host_Entry, J), Port => Remote_Name.Port), Last => J = Addresses_Len) then -- Success return; end if; end loop; -- Never reached, last iteration above must either exit -- succesfully or raise Socket_Error. raise Program_Error; end; end if; exception when E : PolyORB.Sockets.Socket_Error => pragma Debug (C, O ("connect to " & Host_Name & " failed: " & Ada.Exceptions.Exception_Message (E))); PolyORB.Sockets.Close_Socket (Sock); raise; end Connect_Socket; ----------- -- Image -- ----------- function Image (SN : Socket_Name) return String is begin return SN.Host_Name & ":" & Trim (SN.Port'Img, Left); end Image; ------------------- -- Is_IP_Address -- ------------------- function Is_IP_Address (Name : String) return Boolean is begin for J in Name'Range loop if Name (J) /= '.' and then Name (J) not in '0' .. '9' then return False; end if; end loop; return True; end Is_IP_Address; ------------------------ -- Local_Inet_Address -- ------------------------ function Local_Inet_Address return Inet_Addr_Type is Host_Entry : constant Host_Entry_Type := Get_Host_By_Name (Host_Name); Candidate : Inet_Addr_Type := No_Inet_Addr; begin for J in 1 .. Host_Entry.Addresses_Length loop Candidate := Addresses (Host_Entry, J); exit when not Has_Prefix (Image (Candidate), Prefix => "127."); -- Should use netmask manipulation on Candidate instead of string -- image??? end loop; return Candidate; end Local_Inet_Address; --------------------- -- Marshall_Socket -- --------------------- procedure Marshall_Socket (Buffer : access Buffer_Type; Sock : Socket_Name) is begin -- Marshall the host name as a string Marshall_Latin_1_String (Buffer, Sock.Host_Name); -- Marshall the port Marshall (Buffer, Types.Unsigned_Short (Sock.Port)); end Marshall_Socket; ----------------------- -- Unmarshall_Socket -- ----------------------- function Unmarshall_Socket (Buffer : access Buffer_Type) return Socket_Name is Host_Name : constant String := Unmarshall_Latin_1_String (Buffer); Port : constant Types.Unsigned_Short := Unmarshall (Buffer); begin return Host_Name + Port_Type (Port); end Unmarshall_Socket; ---------------- -- To_Address -- ---------------- function To_Address (SN : Socket_Name) return Sock_Addr_Type is begin return Result : Sock_Addr_Type do if Is_IP_Address (SN.Host_Name) then Result.Addr := Inet_Addr (SN.Host_Name); else Result.Addr := Addresses (Get_Host_By_Name (SN.Host_Name), 1); end if; Result.Port := SN.Port; end return; end To_Address; end PolyORB.Utils.Sockets; polyorb-2.8~20110207.orig/src/polyorb-sockets.ads0000644000175000017500000000427211750740340021026 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . S O C K E T S -- -- -- -- S p e c -- -- -- -- Copyright (C) 2001 Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by ACT Europe. -- -- (email: sales@act-europe.fr) -- -- -- ------------------------------------------------------------------------------ with GNAT.Sockets; with PolyORB.Sockets_Initialization; pragma Warnings (Off, PolyORB.Sockets_Initialization); -- Not referenced. package PolyORB.Sockets renames GNAT.Sockets; polyorb-2.8~20110207.orig/src/polyorb-poa_policies-lifespan_policy-persistent.ads0000644000175000017500000000564511750740340027402 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- POLYORB.POA_POLICIES.LIFESPAN_POLICY.PERSISTENT -- -- -- -- S p e c -- -- -- -- Copyright (C) 2002-2005 Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ package PolyORB.POA_Policies.Lifespan_Policy.Persistent is type Persistent_Policy is new LifespanPolicy with null record; type Persistent_Policy_Access is access all Persistent_Policy; function Create return Persistent_Policy_Access; procedure Check_Compatibility (Self : Persistent_Policy; Other_Policies : AllPolicies; Error : in out PolyORB.Errors.Error_Container); function Policy_Id (Self : Persistent_Policy) return String; function Get_Lifespan_Cookie (Self : Persistent_Policy; OA : PolyORB.POA_Types.Obj_Adapter_Access) return Time_Stamp; procedure Ensure_Lifespan (Self : Persistent_Policy; OA : PolyORB.POA_Types.Obj_Adapter_Access; U_Oid : Unmarshalled_Oid; Error : in out PolyORB.Errors.Error_Container); end PolyORB.POA_Policies.Lifespan_Policy.Persistent; polyorb-2.8~20110207.orig/src/polyorb-tasking-abortables.ads0000644000175000017500000000763511750740340023135 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . T A S K I N G . A B O R T A B L E S -- -- -- -- S p e c -- -- -- -- Copyright (C) 2002-2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- Runnables with optional support for abortion pragma Ada_2005; with Ada.Tags.Generic_Dispatching_Constructor; with PolyORB.Tasking.Threads; package PolyORB.Tasking.Abortables is -- pragma Preelaborate; -- WAG:64 -- pragma Preelaborate_05 in Ada.Tags is not always obeyed package PTT renames PolyORB.Tasking.Threads; --------------- -- Abortable -- --------------- -- A Runnable that can be asynchronously aborted (if supported by the -- underlying tasking profile). type Abortable (R : not null access PTT.Runnable'Class) is new PTT.Runnable with null record; function Create (R : not null access PTT.Runnable'Class) return Abortable; overriding procedure Run (AR : not null access Abortable); -- Runs R, but abort if Abort_Run is called procedure Run_With_Timeout (AR : not null access Abortable; Timeout : Duration; Expired : out Boolean); -- Like Run but additionally abort if Timeout expires (if supported by the -- underlying tasking profile). Timeout = Constants.Forever means no -- timeout. procedure Abort_Run (AR : not null access Abortable); -- Abort current call to Run ----------------------- -- Abortable factory -- ----------------------- Abortable_Tag : Ada.Tags.Tag := Abortable'Tag; procedure Register_Abortable_Tag (T : Ada.Tags.Tag); function Make_Abortable is new Ada.Tags.Generic_Dispatching_Constructor (T => Abortable, Parameters => PTT.Runnable'Class, Constructor => Create); -- WAG:64 -- Ideally, variable Abortable_Tag should be hidden in the body of this -- package, and the instantiation and call to the generic dispatching -- constructor hidden in a subprogram. However in GNAT 6.4 a bug causes -- this architecture to cause an unwanted early finalization of the -- returned Abortable. end PolyORB.Tasking.Abortables; polyorb-2.8~20110207.orig/src/polyorb-poa-basic_poa.adb0000644000175000017500000001440011750740340022021 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . P O A . B A S I C _ P O A -- -- -- -- B o d y -- -- -- -- Copyright (C) 2001-2008, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- Basic POA implementation. with Ada.Streams; with PolyORB.Log; with PolyORB.References.IOR; package body PolyORB.POA.Basic_POA is use PolyORB.Errors; use PolyORB.Log; use PolyORB.Types; package L is new Log.Facility_Log ("polyorb.poa.basic_poa"); procedure O (Message : Standard.String; Level : Log_Level := Debug) renames L.Output; function C (Level : Log_Level := Debug) return Boolean renames L.Enabled; ---------------- -- Create_POA -- ---------------- procedure Create_POA (Self : access Basic_Obj_Adapter; Adapter_Name : Standard.String; A_POAManager : POA_Manager.POAManager_Access; Policies : POA_Policies.PolicyList; POA : out Obj_Adapter_Access; Error : in out PolyORB.Errors.Error_Container) is begin POA := new Basic_Obj_Adapter; Initialize_POA (Obj_Adapter (Self.all)'Access, Adapter_Name, A_POAManager, Policies, Obj_Adapter_Access (POA), Error); end Create_POA; -------------------- -- Set_Proxies_OA -- -------------------- procedure Set_Proxies_OA (OA : access Basic_Obj_Adapter; Proxies_OA : Basic_Obj_Adapter_Access) is begin pragma Assert (OA.Proxies_OA = null and then Proxies_OA /= null); OA.Proxies_OA := Proxies_OA; end Set_Proxies_OA; ------------------ -- Is_Proxy_Oid -- ------------------ function Is_Proxy_Oid (OA : access Basic_Obj_Adapter; Oid : access Objects.Object_Id) return Boolean is begin if OA.Proxies_OA = null then return False; end if; declare Obj_OA : Obj_Adapter_Access; Error : PolyORB.Errors.Error_Container; begin Find_POA (OA, Get_Creator (Oid.all), False, Obj_OA, Error); if Found (Error) then Catch (Error); return False; end if; return Basic_Obj_Adapter_Access (Obj_OA) = OA.Proxies_OA; end; end Is_Proxy_Oid; ------------------ -- To_Proxy_Oid -- ------------------ procedure To_Proxy_Oid (OA : access Basic_Obj_Adapter; R : References.Ref; Oid : out Object_Id_Access; Error : in out PolyORB.Errors.Error_Container) is begin pragma Debug (C, O ("To_Proxy_Oid: enter")); if OA.Proxies_OA = null then pragma Debug (C, O ("No Proxies_OA.")); Oid := null; return; end if; declare Oid_Data : aliased Object_Id := Object_Id (References.IOR.Object_To_Opaque (R)); U_Oid : Unmarshalled_Oid; begin pragma Debug (C, O ("To_Proxy_Oid: Oid data length:" & Integer'Image (Oid_Data'Length))); Assign_Object_Identifier (OA.Id_Assignment_Policy.all, POA_Types.Obj_Adapter_Access (OA), Oid_Data'Unchecked_Access, U_Oid, Error); if Found (Error) then return; end if; pragma Debug (C, O ("To_Proxy_Oid: leave")); Oid := U_Oid_To_Oid (U_Oid); end; end To_Proxy_Oid; ------------------ -- Proxy_To_Ref -- ------------------ procedure Proxy_To_Ref (OA : access Basic_Obj_Adapter; Oid : access Objects.Object_Id; Ref : out References.Ref; Error : in out PolyORB.Errors.Error_Container) is pragma Warnings (Off); pragma Unreferenced (OA); pragma Warnings (On); U_Oid : Unmarshalled_Oid; begin Oid_To_U_Oid (Oid.all, U_Oid, Error); if Found (Error) then return; end if; declare use Ada.Streams; Oid_Data : aliased Stream_Element_Array := Stream_Element_Array ( Objects.Hex_String_To_Oid ( To_Standard_String (U_Oid.Id))); begin pragma Debug (C, O ("PTR: Oid data length:" & Integer'Image (Oid_Data'Length))); Ref := References.IOR.Opaque_To_Object (Oid_Data'Access); end; end Proxy_To_Ref; end PolyORB.POA.Basic_POA; polyorb-2.8~20110207.orig/src/polyorb-services.ads0000644000175000017500000000411311750740340021170 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . S E R V I C E S -- -- -- -- S p e c -- -- -- -- Copyright (C) 2002 Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by ACT Europe. -- -- (email: sales@act-europe.fr) -- -- -- ------------------------------------------------------------------------------ package PolyORB.Services is pragma Pure; end PolyORB.Services; polyorb-2.8~20110207.orig/src/polyorb-utils-ilists.ads0000644000175000017500000001164411750740340022021 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . U T I L S . I L I S T S -- -- -- -- S p e c -- -- -- -- Copyright (C) 2009, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- In-place chained lists -- This unit provides a chained list data type operating on any limited type -- that exposes Next and (for the doubly linked case) Previous pointers. -- None of the provided list operations use any dynamic memory allocation. pragma Ada_2005; package PolyORB.Utils.Ilists is pragma Preelaborate; type Link_Type is (Prev, Next); generic type T (<>) is limited private; type T_Acc is access all T; with function Link (X : access T; Which : Link_Type) return access T_Acc is <>; -- Accessor for the list pointers. For a doubly linked list, Prev and -- Next must be supported. For a simply linked list, only Next needs to -- be supported. Doubly_Linked : Boolean; -- If True, the list is doubly linked package Lists is type List is private; pragma Preelaborable_Initialization (List); -- A list of objects of type T type Iterator is private; -- Iterator over List procedure Append (L : in out List; X : access T); -- Append X to L. Note that any given object cannot be appended to more -- than one list (from the same instance of this unit) at a given time. procedure Prepend (L : in out List; X : access T); -- Prepend X to L. Note that any given object cannot be appended to more -- than one list (from the same instance of this unit) at a given time. procedure Remove (L : in out List; It : in out Iterator); -- Remove the element denoted by L and advance It to the next element -- in L. procedure Remove_Element (L : in out List; X : access T); -- Remove X from L (L needs to be doubly linked) procedure Remove_Element (L : in out List; X : access T; PX : access T); -- Remove X from L (L may be simply linked). PX is the previous element -- in L. function First (L : List) return Iterator; -- Return an iterator denoting the first element of L function Last (L : List) return Iterator; -- Return an iterator denoting a position past the last element of L procedure Next (It : in out Iterator); -- Advance It to the next element in its list function Last (It : Iterator) return Boolean; -- True when It is past the last element in its list function Value (It : Iterator) return T_Acc; -- Return the element at It function Length (L : List) return Natural; -- Return the length of L function Is_Empty (L : List) return Boolean; -- True when L has no elements private pragma Inline (First); pragma Inline (Next); pragma Inline (Last); pragma Inline (Value); pragma Inline (Length); pragma Inline (Is_Empty); type Iterator is new T_Acc; type List is record First, Last : T_Acc; Length : Natural := 0; end record; end Lists; end PolyORB.Utils.Ilists; polyorb-2.8~20110207.orig/src/polyorb-tasking-profiles-ravenscar-mutexes.ads0000644000175000017500000001035611750740340026306 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- POLYORB.TASKING.PROFILES.RAVENSCAR.MUTEXES -- -- -- -- S p e c -- -- -- -- Copyright (C) 2002-2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- Implementation of POSIX-like mutexes under the Ravenscar -- profile. For more details see PolyORB.Tasking.Mutexes. with PolyORB.Initialization; with PolyORB.Tasking.Mutexes; with PolyORB.Tasking.Profiles.Ravenscar.Index_Manager; with PolyORB.Tasking.Profiles.Ravenscar.Threads; generic with package Threads_For_Mutexes is new PolyORB.Tasking.Profiles.Ravenscar.Threads (<>); Number_Of_Mutexes : Integer; package PolyORB.Tasking.Profiles.Ravenscar.Mutexes is use PolyORB.Tasking.Mutexes; type Ravenscar_Mutex_Type is new Mutex_Type with private; type Ravenscar_Mutex_Access is access all Ravenscar_Mutex_Type'Class; procedure Enter (M : access Ravenscar_Mutex_Type); procedure Leave (M : access Ravenscar_Mutex_Type); type Ravenscar_Mutex_Factory_Type is new Mutex_Factory_Type with private; type Ravenscar_Mutex_Factory_Access is access all Ravenscar_Mutex_Factory_Type'Class; The_Mutex_Factory : constant Ravenscar_Mutex_Factory_Access; function Create (MF : access Ravenscar_Mutex_Factory_Type; Name : String := "") return Mutex_Access; procedure Destroy (MF : access Ravenscar_Mutex_Factory_Type; M : in out Mutex_Access); private use Threads_For_Mutexes; subtype Extended_Synchro_Index is Integer range Integer (Synchro_Index_Type'First) - 1 .. Integer (Synchro_Index_Type'Last); Null_Synchro_Index : constant Extended_Synchro_Index := Extended_Synchro_Index'First; package Mutex_Index_Manager is new PolyORB.Tasking.Profiles.Ravenscar.Index_Manager (Number_Of_Mutexes); subtype Mutex_Index_Type is Mutex_Index_Manager.Index_Type; type Ravenscar_Mutex_Type is new Mutex_Type with record Id : Mutex_Index_Type; -- Rank of the protected object used by this mutex -- in the preallocated array. end record; type Ravenscar_Mutex_Factory_Type is new Mutex_Factory_Type with null record; The_Mutex_Factory : constant Ravenscar_Mutex_Factory_Access := new Ravenscar_Mutex_Factory_Type; procedure Initialize; -- Initialize the package Initializer : constant PolyORB.Initialization.Initializer := Initialize'Access; end PolyORB.Tasking.Profiles.Ravenscar.Mutexes; polyorb-2.8~20110207.orig/src/polyorb-tasking-profiles-ravenscar-threads.ads0000644000175000017500000002203111750740340026237 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- POLYORB.TASKING.PROFILES.RAVENSCAR.THREADS -- -- -- -- S p e c -- -- -- -- Copyright (C) 2002-2009, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- Abstraction types for Ravenscar tasking. -- Under the Ravenscar profile, "Threads" are associated with an -- unique synchronisation object which is the only one they can wait -- on. This assures that only one task wait on every entry, as -- required in the Ravenscar profile. with System; pragma Warnings (Off); -- System.Tasking is an internal GNAT unit with System.Tasking; pragma Warnings (On); with PolyORB.Initialization; with PolyORB.Tasking.Threads; with PolyORB.Tasking.Profiles.Ravenscar.Index_Manager; generic Number_Of_Application_Tasks : Integer; -- Number of tasks created by the user Number_Of_System_Tasks : Integer; -- Number of tasks created by the PolyORB run-time library Task_Priority : System.Priority; -- Priority of the system tasks Storage_Size : Natural; -- Stack size of the system tasks package PolyORB.Tasking.Profiles.Ravenscar.Threads is pragma Elaborate_Body; use PolyORB.Tasking.Threads; package PTT renames PolyORB.Tasking.Threads; -- Ravenscar tasking profile -- The documentation for the following declarations can be -- found in PolyORB.Tasking.Threads. type Ravenscar_Thread_Type is new Thread_Type with private; type Ravenscar_Thread_Access is access all Ravenscar_Thread_Type'Class; function Get_Thread_Id (T : access Ravenscar_Thread_Type) return Thread_Id; type Ravenscar_Thread_Factory_Type is new Thread_Factory_Type with private; type Ravenscar_Thread_Factory_Access is access all Ravenscar_Thread_Factory_Type'Class; The_Thread_Factory : constant Ravenscar_Thread_Factory_Access; function Run_In_Task (TF : access Ravenscar_Thread_Factory_Type; Name : String := ""; Default_Priority : System.Any_Priority := System.Default_Priority; Storage_Size : Natural := 0; R : Runnable_Access) return Thread_Access; function Run_In_Task (TF : access Ravenscar_Thread_Factory_Type; Name : String := ""; Default_Priority : System.Any_Priority := System.Default_Priority; Storage_Size : Natural := 0; P : Parameterless_Procedure) return Thread_Access; function Get_Current_Thread_Id (TF : access Ravenscar_Thread_Factory_Type) return Thread_Id; function Thread_Id_Image (TF : access Ravenscar_Thread_Factory_Type; TID : PTT.Thread_Id) return String; procedure Set_Priority (TF : access Ravenscar_Thread_Factory_Type; T : PTT.Thread_Id; P : System.Any_Priority); pragma No_Return (Set_Priority); -- Setting priority has no meaning under this profile, raise Tasking_Error function Get_Priority (TF : access Ravenscar_Thread_Factory_Type; T : PTT.Thread_Id) return System.Any_Priority; procedure Relative_Delay (TF : access Ravenscar_Thread_Factory_Type; D : Duration); function Awake_Count (TF : access Ravenscar_Thread_Factory_Type) return Natural; function Independent_Count (TF : access Ravenscar_Thread_Factory_Type) return Natural; ------------------------------------------------- -- Ravenscar specific synchronization objects -- ------------------------------------------------- -- The following procedures make access to the -- profile-specific synchronisation objects, so it should -- only be used by other packages that thread pool ones, -- and synchronisations. -- Semantics: -- A thread has three states : Prepared, Waiting, Free. It is -- initialy Free. -- If it is Free, it can become Prepared after a call to Prepare_Suspend. -- If it is Prepared, it can become Waiting after a call to Suspend, -- or it can become Free by a call to Abort_Suspend. -- If it is Waiting, it can become Free by a call (by another thread) -- to Resume. -- Any other transition makes no sense, and will raise an Assertion -- failure, which will (most likely) be a bug in the Ravenscar profile. -- -- To illustrate it, those typical sequences are authorized -- (from the state Free): -- -- 1: -- prepare_suspend -- suspend -- -- -- 2: -- prepare_suspend -- abort_suspend -- -- 3: -- prepare_suspend -- abort_suspend -- prepare_suspend -- suspend -- These one will raise an assertion failure : -- (From Free) -- -- 1: -- suspend -- -- 2: -- abort_suspend -- -- 3: -- prepare_suspend -- abort_suspend -- abort_suspend package Synchro_Index_Manager is new PolyORB.Tasking.Profiles.Ravenscar.Index_Manager (Number_Of_System_Tasks + Number_Of_Application_Tasks); -- The number of synchronization objects is the maximum number of -- tasks. Note that if a task have a synchronization object handle -- and it may NOT be blocked; this mean that if all the tasks have -- an handle, it is not an error per se. type Synchro_Index_Type is new Synchro_Index_Manager.Index_Type; -- A Synchro_Index_Type represents an index in a pool of synchro objects. -- The synchro objects are managed by pools, and are reallocated -- at every call to a suspension functionality. function Prepare_Suspend return Synchro_Index_Type; -- This function registers thread-safely the current task -- as a suspending task. It MUST be called before a -- corresponding Suspend. procedure Abort_Suspend (S : Synchro_Index_Type); -- This function abort the previous call to Prepare_Suspend. procedure Suspend (S : Synchro_Index_Type); -- Calling this procedure, the current task awaits on S (that is, -- wait that another thread call Resume on S). The task that calls -- Suspend MUST have called Prepare_Suspend before; Otherwise, it -- will raise an assertion. procedure Resume (S : Synchro_Index_Type); -- The call to this procedure free the task waiting -- on S. -- If no task is about to Wait (that is, if no call to -- Prepare_Suspend were done before the call to Resume), -- the signal is lost. function Get_Thread_Index (T : Thread_Id) return Integer; -- Return a different integer for each Thread_Id private type Ravenscar_Thread_Factory_Type is new Thread_Factory_Type with record Environment_Task : System.Tasking.Task_Id; -- The environment task end record; The_Thread_Factory : constant Ravenscar_Thread_Factory_Access := new Ravenscar_Thread_Factory_Type; type Ravenscar_Thread_Type is new Thread_Type with record Id : PTT.Thread_Id; -- Id of the Thread Sync_Id : Synchro_Index_Type; pragma Atomic (Sync_Id); -- if the thread is available to be allocated to a caller of -- Run_In_Task, Sync_Id is the Id of the Synchro on which the -- corresponding task is waiting. end record; procedure Initialize; Initializer : constant PolyORB.Initialization.Initializer := Initialize'Access; end PolyORB.Tasking.Profiles.Ravenscar.Threads; polyorb-2.8~20110207.orig/src/polyorb-utils-configuration_file.adb0000644000175000017500000004053111750740340024334 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . U T I L S . C O N F I G U R A T I O N _ F I L E -- -- -- -- B o d y -- -- -- -- Copyright (C) 2005-2011, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with Ada.Text_IO; with GNAT.OS_Lib; with PolyORB.Initialization; with PolyORB.Log; with PolyORB.Utils.Chained_Lists; package body PolyORB.Utils.Configuration_File is use Ada.Text_IO; use PolyORB.Log; use PolyORB.Utils.Strings; package L is new PolyORB.Log.Facility_Log ("polyorb.utils.configuration_file"); procedure O (Message : String; Level : Log_Level := Debug) renames L.Output; function C (Level : Log_Level := Debug) return Boolean renames L.Enabled; use Configuration_Table; Local_Configuration_Table : Table_Instance; type Section_Entry_Props is record Name : PolyORB.Utils.Strings.String_Ptr; Val : PolyORB.Utils.Strings.String_Ptr; end record; package Section_Entries is new PolyORB.Utils.Chained_Lists (Section_Entry_Props); type Conf_Entry is record Section : PolyORB.Utils.Strings.String_Ptr; Entries : Section_Entries.List; end record; package Sections is new PolyORB.Utils.Chained_Lists (Conf_Entry); Sections_List : Sections.List; procedure Reset_Sections_List; -- Reset the chained list built from the configuration table to -- ease displaying and generating configuration files. procedure Make_Global_List (K : String; V : String_Ptr); procedure Reset_Table (Table : in out Configuration_Table.Table_Instance); -- Reset configuration table -------------------- -- Make_Global_Key -- --------------------- function Make_Global_Key (Section, Key : String) return String; function Make_Global_Key (Section, Key : String) return String is begin return "[" & Section & "]" & Key; end Make_Global_Key; ----------------- -- Reset_Table -- ----------------- procedure Reset_Table (Table : in out Configuration_Table.Table_Instance) is It : Iterator := First (Table); begin -- Deallocate elements from the table while not Last (It) loop declare V : String_Ptr := Value (It); begin Free (V); Next (It); end; end loop; -- Reset the configuration table Finalize (Table); Initialize (Table); end Reset_Table; ----------- -- Reset -- ----------- procedure Reset is begin Reset_Table (Local_Configuration_Table); Reset_Sections_List; end Reset; ------------------------------ -- Load_Configuration_Table -- ------------------------------ procedure Load_Configuration_Table (Configuration_Filename : String; Is_Default : Boolean; Table : in out Configuration_Table.Table_Instance) is Current_Section : String_Ptr := null; Current_Line : Integer := 0; procedure Set_Current_Section (S : String); -- Enter a new section named S procedure Set_Current_Section (S : String) is begin Free (Current_Section); Current_Section := +S; end Set_Current_Section; Conf_File : File_Type; Line : String (1 .. 1_024); Last : Integer; use PolyORB.Utils; begin -- Reset the table and the sections list Reset_Table (Table); Reset_Sections_List; if not GNAT.OS_Lib.Is_Regular_File (Configuration_Filename) then if not Is_Default then O (Configuration_Filename & " is not a regular file", Error); end if; return; end if; pragma Debug (C, O ("Loading configuration from " & Configuration_Filename)); Open (Conf_File, In_File, Configuration_Filename); while not End_Of_File (Conf_File) loop Get_Line (Conf_File, Line, Last); Current_Line := Current_Line + 1; if Last - Line'First >= 0 then case Line (Line'First) is when '#' => null; when '[' => declare Bra : constant Integer := Line'First; Ket : constant Integer := Find (Line (Line'First .. Last), Bra, ']'); begin if False or else Ket > Last or else Ket = Bra + 1 or else Ket /= Last then O ("Syntax error on line" & Integer'Image (Current_Line) & ": " & Line (Line'First .. Last)); raise Constraint_Error; end if; Set_Current_Section (Line (Bra + 1 .. Ket - 1)); end; when others => declare Eq : constant Integer := Find (Line (Line'First .. Last), Line'First, '='); begin if Current_Section = null then O ("Assignment out of any section on line" & Current_Line'Img & ": " & Line (Line'First .. Last), Error); raise Constraint_Error; end if; if Eq not in Line'First + 1 .. Last then O ("Syntax error on line" & Current_Line'Img & ": " & Line (Line'First .. Last), Error); raise Constraint_Error; end if; declare K : constant String := Make_Global_Key (Section => Current_Section.all, Key => Line (Line'First .. Eq - 1)); V : String_Ptr := Configuration_Table.Lookup (Table, K, null); begin if V /= null then Free (V); end if; Configuration_Table.Insert (Table, K, +Line (Eq + 1 .. Last)); end; end; end case; end if; end loop; Free (Current_Section); Close (Conf_File); end Load_Configuration_Table; -------------- -- Set_Conf -- -------------- procedure Set_Conf (Configuration_Filename, Section, Key, Value : String) is pragma Unreferenced (Configuration_Filename); V : constant String_Ptr := Lookup (Local_Configuration_Table, Make_Global_Key (Section, Key), null); begin if V /= null then -- Remove the entry from the table Delete (Local_Configuration_Table, Make_Global_Key (Section, Key)); end if; Insert (Local_Configuration_Table, Make_Global_Key (Section, Key), new String'(Value)); end Set_Conf; ------------------------- -- Reset_Sections_List -- ------------------------- procedure Reset_Sections_List is Iter : Sections.Iterator := Sections.First (Sections_List); begin while not Sections.Last (Iter) loop declare S : String_Ptr := Sections.Value (Iter).Section; begin Free (S); end; declare Iter2 : Section_Entries.Iterator := Section_Entries.First (Sections.Value (Iter).Entries); begin while not Section_Entries.Last (Iter2) loop declare N : String_Ptr := Section_Entries.Value (Iter2).Name; V : String_Ptr := Section_Entries.Value (Iter2).Val; begin Free (V); Free (N); Section_Entries.Next (Iter2); end; end loop; end; Section_Entries.Deallocate (Sections.Value (Iter).Entries); Sections.Next (Iter); end loop; Sections.Deallocate (Sections_List); end Reset_Sections_List; ---------------------- -- Make_Global_List -- ---------------------- procedure Make_Global_List (K : String; V : String_Ptr) is Iter : Sections.Iterator := Sections.First (Sections_List); Section_Found : Boolean := False; Entry_Found : Boolean := False; Current_Section : String_Ptr := null; procedure Set_Current_Section (S : String); -- Enter a new section named S procedure Set_Current_Section (S : String) is begin Free (Current_Section); Current_Section := +S; end Set_Current_Section; begin -- For each section we build a list of entries if K (K'First) = '[' then declare Bra : constant Integer := K'First; Ket : constant Integer := Find (K (K'First .. K'Last), Bra, ']'); begin if False or else Ket > K'Last or else Ket = Bra + 1 then O ("Syntax error : " & K (K'First .. K'Last)); raise Constraint_Error; end if; Set_Current_Section (K (Bra + 1 .. Ket - 1)); -- Lookup the current section in the entries Section_Found := False; Entry_Found := False; while not Sections.Last (Iter) loop if Sections.Value (Iter).Section.all = Current_Section.all then Section_Found := True; -- Lookup if the entry is already present, if yes rewrite it declare Iter2 : Section_Entries.Iterator := Section_Entries.First (Sections.Value (Iter).Entries); begin while not Section_Entries.Last (Iter2) loop if Section_Entries.Value (Iter2).Name.all = K (Ket + 1 .. K'Last) then -- Rewrite Section_Entries.Value (Iter2).Val := new String'(V.all); Entry_Found := True; end if; Section_Entries.Next (Iter2); end loop; -- The section is found but not the entry if not Entry_Found then Section_Entries.Append (Sections.Value (Iter).Entries, Section_Entry_Props' (Name => new String'(K (Ket + 1 .. K'Last)), Val => new String'(V.all))); end if; end; end if; Sections.Next (Iter); end loop; -- The section is not found, add a new section -- in the chained list if not Section_Found then declare Entries_List : Section_Entries.List; begin Section_Entries.Append (Entries_List, Section_Entry_Props' (Name => new String'(K (Ket + 1 .. K'Last)), Val => new String'(V.all))); Sections.Append (Sections_List, Conf_Entry' (Section => new String'(Current_Section.all), Entries => Entries_List)); end; end if; end; end if; end Make_Global_List; ------------- -- Display -- ------------- procedure Display is It : Iterator := First (Local_Configuration_Table); begin Reset_Sections_List; while not Last (It) loop Make_Global_List (K => Key (It), V => Value (It)); Next (It); end loop; declare Iter : Sections.Iterator := Sections.First (Sections_List); begin while not Sections.Last (Iter) loop Put_Line ("[" & Sections.Value (Iter).Section.all & "]"); declare Iter2 : Section_Entries.Iterator := Section_Entries.First (Sections.Value (Iter).Entries); begin while not Section_Entries.Last (Iter2) loop Put_Line (Section_Entries.Value (Iter2).Name.all & "=" & Section_Entries.Value (Iter2).Val.all); Section_Entries.Next (Iter2); end loop; end; Sections.Next (Iter); end loop; end; end Display; --------------------------------- -- Generate_Configuration_File -- --------------------------------- procedure Generate_Configuration_File (Configuration_Filename : String) is Fd : File_Type; It : Iterator := First (Local_Configuration_Table); begin Reset_Sections_List; Create (Fd, Out_File, Configuration_Filename, Configuration_Filename); while not Last (It) loop Make_Global_List (K => Key (It), V => Value (It)); Next (It); end loop; declare Iter : Sections.Iterator := Sections.First (Sections_List); begin while not Sections.Last (Iter) loop Put_Line (Fd, "[" & Sections.Value (Iter).Section.all & "]"); declare Iter2 : Section_Entries.Iterator := Section_Entries.First (Sections.Value (Iter).Entries); begin while not Section_Entries.Last (Iter2) loop Put_Line (Fd, Section_Entries.Value (Iter2).Name.all & "=" & Section_Entries.Value (Iter2).Val.all); Section_Entries.Next (Iter2); end loop; end; Sections.Next (Iter); end loop; end; Close (Fd); end Generate_Configuration_File; ---------------- -- Initialize -- ---------------- procedure Initialize; procedure Initialize is begin Initialize (Local_Configuration_Table); end Initialize; use PolyORB.Initialization; use PolyORB.Initialization.String_Lists; begin Register_Module (Module_Info' (Name => +"utils.configuration_file", Conflicts => Empty, Depends => Empty, Provides => Empty, Implicit => True, Init => Initialize'Access, Shutdown => null)); end PolyORB.Utils.Configuration_File; polyorb-2.8~20110207.orig/src/polyorb-obj_adapters-group_object_adapter.adb0000644000175000017500000002664511750740340026157 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- POLYORB.OBJ_ADAPTERS.GROUP_OBJECT_ADAPTER -- -- -- -- B o d y -- -- -- -- Copyright (C) 2001-2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- Special Object Adapter to manage group servants with PolyORB.Binding_Data; with PolyORB.Log; with PolyORB.Obj_Adapter_QoS; with PolyORB.Servants.Group_Servants; with PolyORB.Utils; package body PolyORB.Obj_Adapters.Group_Object_Adapter is use PolyORB.Errors; use PolyORB.Log; use PolyORB.Tasking.Mutexes; package L is new PolyORB.Log.Facility_Log ("polyorb.obj_adapters.group_object_adapter"); procedure O (Message : String; Level : Log_Level := Debug) renames L.Output; function C (Level : Log_Level := Debug) return Boolean renames L.Enabled; ------------ -- Create -- ------------ procedure Create (GOA : access Group_Object_Adapter) is begin Initialize (GOA.Registered_Groups); Create (GOA.Lock); end Create; ------------- -- Destroy -- ------------- procedure Destroy (GOA : access Group_Object_Adapter) is begin Finalize (GOA.Registered_Groups); Destroy (GOA.Lock); Destroy (Obj_Adapter (GOA.all)'Access); end Destroy; -------------------------------------- -- Interface to application objects -- -------------------------------------- ------------ -- Export -- ------------ procedure Export (GOA : access Group_Object_Adapter; Obj : Servants.Servant_Access; Key : Objects.Object_Id_Access; Oid : out Objects.Object_Id_Access; Error : in out PolyORB.Errors.Error_Container) is pragma Warnings (Off); pragma Unreferenced (Key); pragma Warnings (On); use PolyORB.Objects; use type PolyORB.Servants.Servant_Access; GS : PolyORB.Servants.Servant_Access; begin PolyORB.Servants.Group_Servants.Get_Group_Object_Id (Obj, Oid, Error); if Found (Error) then Throw (Error, NotAGroupObject_E, Null_Members'(Null_Member)); return; end if; Enter (GOA.Lock); GS := Lookup (GOA.Registered_Groups, Image (Oid.all), null); if GS /= null then pragma Debug (C, O ("Group " & Image (Oid.all) & " has been registered before")); Throw (Error, NotAGroupObject_E, Null_Members'(Null_Member)); -- XXX Need to add a GroupAlreadyRegistered exception ? else -- Register the group pragma Debug (C, O ("Group servant : " & Image (Oid.all) & " exported")); Insert (GOA.Registered_Groups, Image (Oid.all), Obj); PolyORB.Servants.Set_Executor (Obj, GOA.S_Exec'Access); -- XXX questionable end if; Leave (GOA.Lock); end Export; -------------- -- Unexport -- -------------- procedure Unexport (GOA : access Group_Object_Adapter; Id : Objects.Object_Id_Access; Error : in out PolyORB.Errors.Error_Container) is use PolyORB.Objects; use PolyORB.Servants.Group_Servants; use type PolyORB.Servants.Servant_Access; GS : PolyORB.Servants.Servant_Access; begin Enter (GOA.Lock); GS := Lookup (GOA.Registered_Groups, Oid_To_Hex_String (Id.all), null); if GS = null then pragma Debug (C, O ("Invalid group : " & Oid_To_Hex_String (Id.all))); Throw (Error, Invalid_Object_Id_E, Null_Members'(Null_Member)); else Destroy_Group_Servant (GS); Delete (GOA.Registered_Groups, Oid_To_Hex_String (Id.all)); pragma Debug (C, O ("Group removed with success : " & Oid_To_Hex_String (Id.all))); end if; Leave (GOA.Lock); end Unexport; ---------------- -- Object_Key -- ---------------- procedure Object_Key (GOA : access Group_Object_Adapter; Id : Objects.Object_Id_Access; User_Id : out Objects.Object_Id_Access; Error : in out PolyORB.Errors.Error_Container) is pragma Warnings (Off); pragma Unreferenced (GOA, Id); pragma Warnings (On); begin -- No user id in this OA User_Id := null; Throw (Error, Invalid_Object_Id_E, Null_Members'(Null_Member)); end Object_Key; ------------- -- Get_QoS -- ------------- procedure Get_QoS (OA : access Group_Object_Adapter; Id : Objects.Object_Id; QoS : out PolyORB.QoS.QoS_Parameters; Error : in out PolyORB.Errors.Error_Container) is pragma Unreferenced (Id); pragma Unreferenced (Error); begin QoS := PolyORB.Obj_Adapter_QoS.Get_Object_Adapter_QoS (OA); end Get_QoS; ---------------------------------------------------- -- Interface to ORB (acting on behalf of clients) -- ---------------------------------------------------- ------------------------ -- Get_Empty_Arg_List -- ------------------------ function Get_Empty_Arg_List (GOA : access Group_Object_Adapter; Oid : access Objects.Object_Id; Method : String) return Any.NVList.Ref is pragma Warnings (Off); pragma Unreferenced (GOA, Oid, Method); pragma Warnings (On); Result : Any.NVList.Ref; begin pragma Debug (C, O ("Get empty args list called, return empty list")); return Result; end Get_Empty_Arg_List; ---------------------- -- Get_Empty_Result -- ---------------------- function Get_Empty_Result (GOA : access Group_Object_Adapter; Oid : access Objects.Object_Id; Method : String) return Any.Any is pragma Warnings (Off); pragma Unreferenced (GOA, Oid, Method); pragma Warnings (On); Result : Any.Any; begin pragma Debug (C, O ("Get empty result list called, return no type")); return Result; end Get_Empty_Result; ------------------ -- Find_Servant -- ------------------ procedure Find_Servant (GOA : access Group_Object_Adapter; Id : access Objects.Object_Id; Servant : out Servants.Servant_Access; Error : in out PolyORB.Errors.Error_Container) is use PolyORB.Objects; use type PolyORB.Servants.Servant_Access; begin pragma Debug (C, O ("Find_Servant " & Image (Id.all))); Enter (GOA.Lock); Servant := Lookup (GOA.Registered_Groups, Image (Id.all), null); if Servant = null then pragma Debug (C, O ("Servant not found")); Throw (Error, Invalid_Object_Id_E, Null_Members'(Null_Member)); else pragma Debug (C, O ("Servant found")); null; end if; Leave (GOA.Lock); end Find_Servant; --------------------- -- Release_Servant -- --------------------- procedure Release_Servant (GOA : access Group_Object_Adapter; Id : access Objects.Object_Id; Servant : in out Servants.Servant_Access) is pragma Warnings (Off); pragma Unreferenced (GOA, Id); pragma Warnings (On); begin -- Nothing to do Servant := null; end Release_Servant; --------------- -- Get_Group -- --------------- function Get_Group (The_Ref : PolyORB.References.Ref; Allow_Group_Creation : Boolean := False) return PolyORB.Servants.Servant_Access is use PolyORB.Binding_Data; use PolyORB.Objects; use PolyORB.References; use PolyORB.Smart_Pointers; Profs : constant Profile_Array := Profiles_Of (The_Ref); Error : Error_Container; GS : PolyORB.Servants.Servant_Access; begin pragma Debug (C, O ("Get group from reference")); for J in Profs'Range loop declare OA_Entity : constant PolyORB.Smart_Pointers.Entity_Ptr := Get_OA (Profs (J).all); begin if OA_Entity /= null and then OA_Entity.all in Group_Object_Adapter'Class then pragma Debug (C, O ("Searching group using a group profile")); Find_Servant (Group_Object_Adapter (OA_Entity.all)'Access, Get_Object_Key (Profs (J).all), GS, Error); if not Found (Error) then pragma Debug (C, O ("Group found")); return GS; end if; if Allow_Group_Creation then pragma Debug (C, O ("Create a new group")); GS := PolyORB.Servants.Group_Servants.Create_Group_Servant (Get_Object_Key (Profs (J).all)); declare Oid : Object_Id_Access; Error : Error_Container; begin Export (Group_Object_Adapter (OA_Entity.all)'Access, GS, null, Oid, Error); if Found (Error) or else Oid.all /= Get_Object_Key (Profs (J).all).all then pragma Debug (C, O ("Exporting group error")); return null; end if; pragma Debug (C, O ("Group Exported")); return GS; end; end if; end if; end; end loop; pragma Debug (C, O ("Group not found")); return null; end Get_Group; end PolyORB.Obj_Adapters.Group_Object_Adapter; polyorb-2.8~20110207.orig/src/polyorb-platform-ssl_linker_options.ads.in0000644000175000017500000000447611750740340025530 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . P L A T F O R M . S S L _ L I N K E R _ O P T I O N S -- -- -- -- S p e c -- -- -- -- Copyright (C) 2007, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- Linker options for OpenSSL pragma Style_Checks ("M2048"); -- Configure substitutions may yield long lines -- @configure_input@ package PolyORB.Platform.SSL_Linker_Options is pragma Pure; @NO_SSL_LINKER_OPTIONS@pragma Linker_Options (@SSL_LINKER_OPTIONS@); end PolyORB.Platform.SSL_Linker_Options; polyorb-2.8~20110207.orig/src/polyorb-services-naming-tools.adb0000644000175000017500000002103111750740340023552 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . S E R V I C E S . N A M I N G . T O O L S -- -- -- -- B o d y -- -- -- -- Copyright (C) 2002-2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with PolyORB.Services.Naming.NamingContext.Client; with PolyORB.Services.Naming.NamingContext.Helper; package body PolyORB.Services.Naming.Tools is use PolyORB.Services.Naming.NamingContext.Helper; use PolyORB.Services.Naming.NamingContext.Client; use PolyORB.Services.Naming.NamingContext; subtype NameComponent_Array is PolyORB.Services.Naming.SEQUENCE_NameComponent.Element_Array; RNS : PolyORB.Services.Naming.NamingContext.Ref; -- Reference to the Naming Service in use. -- XXX use a mechanism similar to Resolve_Initial_References. function Retrieve_Context (Name : PolyORB.Services.Naming.Name) return PolyORB.Services.Naming.NamingContext.Ref; -- Return a CosNaming.NamingContext.Ref that designates the -- NamingContext registered as Name. ---------- -- Init -- ---------- procedure Init (Ref : PolyORB.References.Ref) is begin RNS := To_Ref (Ref); end Init; ------------ -- Locate -- ------------ function Locate (Name : PolyORB.Services.Naming.Name) return PolyORB.References.Ref is begin return Resolve (RNS, Name); end Locate; ------------ -- Locate -- ------------ function Locate (Context : PolyORB.Services.Naming.NamingContext.Ref; Name : PolyORB.Services.Naming.Name) return PolyORB.References.Ref is begin return Resolve (Context, Name); end Locate; ------------ -- Locate -- ------------ function Locate (IOR_Or_Name : String; Sep : Character := '/') return PolyORB.References.Ref is Res : PolyORB.References.Ref; begin if IOR_Or_Name (IOR_Or_Name'First .. IOR_Or_Name'First + 3) = "IOR:" then PolyORB.References.String_To_Object (IOR_Or_Name, Res); return Res; end if; return Locate (Parse_Name (IOR_Or_Name, Sep)); end Locate; ------------ -- Locate -- ------------ function Locate (Context : PolyORB.Services.Naming.NamingContext.Ref; IOR_Or_Name : String; Sep : Character := '/') return PolyORB.References.Ref is Res : PolyORB.References.Ref; begin if IOR_Or_Name (IOR_Or_Name'First .. IOR_Or_Name'First + 3) = "IOR:" then PolyORB.References.String_To_Object (IOR_Or_Name, Res); return Res; end if; return Locate (Context, Parse_Name (IOR_Or_Name, Sep)); end Locate; ---------------------- -- Retrieve_Context -- ---------------------- function Retrieve_Context (Name : PolyORB.Services.Naming.Name) return PolyORB.Services.Naming.NamingContext.Ref is Cur : PolyORB.Services.Naming.NamingContext.Ref := RNS; Ref : PolyORB.Services.Naming.NamingContext.Ref; N : PolyORB.Services.Naming.Name; NCA : constant NameComponent_Array := PolyORB.Services.Naming.To_Element_Array (Name); begin for I in NCA'Range loop N := PolyORB.Services.Naming.To_Sequence ((1 => NCA (I))); begin Ref := To_Ref (Resolve (Cur, N)); exception when NotFound => Ref := Bind_New_Context (Cur, N); end; Cur := Ref; end loop; return Cur; end Retrieve_Context; -------------- -- Register -- -------------- procedure Register (Name : String; Ref : PolyORB.References.Ref; Rebind : Boolean := False; Sep : Character := '/') is Context : NamingContext.Ref; NCA : constant NameComponent_Array := PolyORB.Services.Naming.To_Element_Array (Parse_Name (Name, Sep)); N : constant PolyORB.Services.Naming.Name := PolyORB.Services.Naming.To_Sequence ((1 => NCA (NCA'Last))); begin if NCA'Length = 1 then Context := RNS; else Context := Retrieve_Context (PolyORB.Services.Naming.To_Sequence (NCA (NCA'First .. NCA'Last - 1))); end if; Bind (Context, N, Ref); exception when NamingContext.AlreadyBound => if Rebind then PolyORB.Services.Naming.NamingContext.Client.Rebind (Context, N, Ref); else raise; end if; end Register; ---------------- -- Parse_Name -- ---------------- function Parse_Name (Name : String; Sep : Character := '/') return PolyORB.Services.Naming.Name is Result : PolyORB.Services.Naming.Name; Unescaped : String (Name'Range); First : Integer := Unescaped'First; Last : Integer := Unescaped'First - 1; Last_Unescaped_Period : Integer := Unescaped'First - 1; Seen_Backslash : Boolean := False; End_Of_NC : Boolean := False; begin for I in Name'Range loop if not Seen_Backslash and then Name (I) = '\' then Seen_Backslash := True; else -- Seen_Backslash and seeing an escaped character -- *or* seeing a non-escaped non-backslash character. if not Seen_Backslash and then Name (I) = Sep then -- Seeing a non-escaped Sep End_Of_NC := True; else -- Seeing a non-escaped non-backslash, non-Sep -- character, or seeing an escaped character. Last := Last + 1; Unescaped (Last) := Name (I); End_Of_NC := I = Name'Last; end if; if not Seen_Backslash and then Name (I) = '.' then Last_Unescaped_Period := Last; end if; if End_Of_NC then if Last_Unescaped_Period < First then Last_Unescaped_Period := Last + 1; end if; Append (Result, NameComponent' (id => To_PolyORB_String (Unescaped (First .. Last_Unescaped_Period - 1)), kind => To_PolyORB_String (Unescaped (Last_Unescaped_Period + 1 .. Last)))); Last_Unescaped_Period := Last; First := Last + 1; end if; Seen_Backslash := Name (I) = '\' and then not Seen_Backslash; end if; end loop; return Result; end Parse_Name; ---------------- -- Unregister -- ---------------- procedure Unregister (Name : String) is N : PolyORB.Services.Naming.Name; NC : NameComponent; begin NC.kind := To_PolyORB_String (""); NC.id := To_PolyORB_String (Name); Append (N, NC); Unbind (RNS, N); end Unregister; end PolyORB.Services.Naming.Tools; polyorb-2.8~20110207.orig/src/polyorb-services-naming-namingcontext-servant.ads0000644000175000017500000000630211750740340026775 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- POLYORB.SERVICES.NAMING.NAMINGCONTEXT.SERVANT -- -- -- -- S p e c -- -- -- -- Copyright (C) 2002-2009, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with PolyORB.Minimal_Servant; with PolyORB.Obj_Adapters.Simple; with PolyORB.Requests; package PolyORB.Services.Naming.NamingContext.Servant is Key_Size : constant := 4; type Key_Type is new String (1 .. Key_Size); type Bound_Object; type Bound_Object_Ptr is access Bound_Object; type Object; type Object_Ptr is access all Object'Class; type Bound_Object is record BN : NameComponent; BT : BindingType; Obj : PolyORB.References.Ref; Prev : Bound_Object_Ptr; Next : Bound_Object_Ptr; NC : Object_Ptr; end record; type Object is new PolyORB.Minimal_Servant.Servant with record Key : Key_Type; Self : Object_Ptr; Prev : Object_Ptr; Next : Object_Ptr; Head : Bound_Object_Ptr; Tail : Bound_Object_Ptr; end record; procedure Invoke (Self : access Object; Request : PolyORB.Requests.Request_Access); function If_Desc return PolyORB.Obj_Adapters.Simple.Interface_Description; pragma Inline (If_Desc); -- Middleware 'glue' function Create return Object_Ptr; end PolyORB.Services.Naming.NamingContext.Servant; polyorb-2.8~20110207.orig/src/polyorb-binding_data-neighbour.adb0000644000175000017500000001344111750740340023713 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . B I N D I N G _ D A T A . N E I G H B O U R -- -- -- -- B o d y -- -- -- -- Copyright (C) 2006-2011, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with PolyORB.Binding_Objects; package body PolyORB.Binding_Data.Neighbour is use PolyORB.Objects; ------------- -- Release -- ------------- procedure Release (P : in out Neighbour_Profile_Type) is begin Free (P.Object_Id); end Release; ------------------------------ -- Create_Neighbour_Profile -- ------------------------------ procedure Create_Neighbour_Profile (BO : Smart_Pointers.Ref; Oid : Objects.Object_Id; P : out Neighbour_Profile_Type) is begin P.Target_Binding_Object := BO; P.Object_Id := new Object_Id'(Oid); end Create_Neighbour_Profile; ----------------------- -- Duplicate_Profile -- ----------------------- function Duplicate_Profile (P : Neighbour_Profile_Type) return Profile_Access is Result : constant Profile_Access := new Neighbour_Profile_Type; TResult : Neighbour_Profile_Type renames Neighbour_Profile_Type (Result.all); begin TResult.Object_Id := new Object_Id'(P.Object_Id.all); TResult.Target_Binding_Object := P.Target_Binding_Object; return Result; end Duplicate_Profile; ------------------ -- Bind_Profile -- ------------------ procedure Bind_Profile (Profile : access Neighbour_Profile_Type; The_ORB : Components.Component_Access; QoS : PolyORB.QoS.QoS_Parameters; BO_Ref : out Smart_Pointers.Ref; Error : out Errors.Error_Container) is pragma Unreferenced (The_ORB, QoS, Error); begin -- Always bind to the target binding object BO_Ref := Profile.Target_Binding_Object; pragma Assert (not Smart_Pointers.Is_Null (BO_Ref)); end Bind_Profile; --------------------- -- Get_Profile_Tag -- --------------------- function Get_Profile_Tag (Profile : Neighbour_Profile_Type) return Profile_Tag is pragma Unreferenced (Profile); begin return Tag_Neighbour; end Get_Profile_Tag; ---------------------------- -- Get_Profile_Preference -- ---------------------------- function Get_Profile_Preference (Profile : Neighbour_Profile_Type) return Profile_Preference is pragma Unreferenced (Profile); begin return Profile_Preference'Last; -- A neighbour profile is always preferred to any other. We can return -- any value because we never actually bind a neighbour profile. -- (Instead we select it in the context of a binding object reuse -- operation.) end Get_Profile_Preference; ----------- -- Image -- ----------- function Image (Prof : Neighbour_Profile_Type) return String is use Binding_Objects; BO_Acc : constant Binding_Object_Access := Binding_Object_Access (Smart_Pointers.Entity_Of (Prof.Target_Binding_Object)); begin return "Neighbour (from " & Image (Get_Profile (BO_Acc).all) & ") - Object_Id: " & PolyORB.Objects.Image (Prof.Object_Id.all); end Image; ------------------ -- Is_Colocated -- ------------------ function Is_Colocated (Left : Neighbour_Profile_Type; Right : Profile_Type'Class) return Boolean is use PolyORB.Binding_Objects; use PolyORB.Smart_Pointers; BO_Acc : constant Binding_Object_Access := Binding_Object_Access (Entity_Of (Left.Target_Binding_Object)); begin -- The profile of the target binding object is the real profile that was -- used when the BO was created. Neighbours profiles will never provoke -- the creation of a new BO because by construction they already have -- one. Therefore this recursion is safe. return Is_Colocated (Get_Profile (BO_Acc).all, Right); end Is_Colocated; end PolyORB.Binding_Data.Neighbour; polyorb-2.8~20110207.orig/src/polyorb-sequences-unbounded.adb0000644000175000017500000004673211750740340023315 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . S E Q U E N C E S . U N B O U N D E D -- -- -- -- B o d y -- -- -- -- Copyright (C) 2002-2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ package body PolyORB.Sequences.Unbounded is Dummy_Element_Ptr : Element_Ptr; pragma Warnings (Off, Dummy_Element_Ptr); -- This variable is only used to provide a placeholder expression of type -- Element that is preelaborable (but is never actually evaluated). Empty_Element_Array : aliased Element_Array := (1 .. 0 => Dummy_Element_Ptr.all); Empty : constant Element_Array_Access := Empty_Element_Array'Access; ------------------------------------------------ -- SVM implementation for unbounded sequences -- ------------------------------------------------ procedure Run is new Sequences.Run (Element, Element_Array); -- Core execution engine function Run_Copy (Prog : Program; Left : Element_Array; Right : Element_Array := Null_Element_Array) return Sequence; -- Execute Prog and return a new sequence containing the result procedure Run_In_Place (Prog : Program; Left : in out Sequence; Right : Element_Array := Null_Element_Array); -- Execute Prog in-place on Left's storage ----------------------- -- Local subprograms -- ----------------------- function Allocate (Length : Natural) return Element_Array_Access; -- Return a newly allocated element array of the given length, except -- if Length is 0, in which case Empty is returned. function Array_Bounds (A : Element_Array) return Bounds; -- Return (A'First, A'Last) function Sequence_Bounds (S : Sequence) return Bounds; -- Return (1, Length (S)) function "&" (Left, Right : Element_Array) return Sequence; -- Return To_Sequence (Left & Right) function Count_Index (Source : Sequence; Pattern : Element_Array; What : Search_Kind; Going : Direction := Forward) return Natural; -- Common subprogram used to implement Count and Index, depending on -- the What parameter. --------- -- "&" -- --------- function "&" (Left, Right : Element_Array) return Sequence is Left_Bounds : constant Bounds := Array_Bounds (Left); begin -- Replace a null-length slice of Left located right after the last -- element with Right. return Run_Copy (Prog => Replace_Slice (0, Left_Bounds, Bounds'(Left_Bounds.Hi + 1, Left_Bounds.Hi), Array_Bounds (Right)), Left => Left, Right => Right); end "&"; --------- -- "&" -- --------- function "&" (Left, Right : Sequence) return Sequence is begin return Left.Content (1 .. Left.Length) & Right.Content (1 .. Right.Length); end "&"; --------- -- "&" -- --------- function "&" (Left : Sequence; Right : Element_Array) return Sequence is begin return Sequence'(Left.Content (1 .. Left.Length) & Right); end "&"; --------- -- "&" -- --------- function "&" (Left : Element_Array; Right : Sequence) return Sequence is begin return Sequence'(Left & Right.Content (1 .. Right.Length)); end "&"; --------- -- "&" -- --------- function "&" (Left : Sequence; Right : Element) return Sequence is begin return Left & Element_Array'(1 => Right); end "&"; --------- -- "&" -- --------- function "&" (Left : Element; Right : Sequence) return Sequence is begin return Element_Array'(1 => Left) & Right; end "&"; --------- -- "*" -- --------- function "*" (Left : Natural; Right : Element) return Sequence is begin return Left * Element_Array'(1 => Right); end "*"; --------- -- "*" -- --------- function "*" (Left : Natural; Right : Element_Array) return Sequence is begin return Run_Copy (Prog => Replicate (0, Left, Array_Bounds (Right)), Left => Right); end "*"; --------- -- "*" -- --------- function "*" (Left : Natural; Right : Sequence) return Sequence is begin return Run_Copy (Prog => Replicate (0, Left, Sequence_Bounds (Right)), Left => Right.Content (1 .. Right.Length)); end "*"; --------- -- "=" -- --------- function "=" (Left, Right : Sequence) return Boolean is L : Natural renames Left.Length; begin return L = Right.Length and then Left.Content (1 .. L) = Right.Content (1 .. L); end "="; --------- -- "=" -- --------- function "=" (Left : Element_Array; Right : Sequence) return Boolean is L : Natural renames Right.Length; begin return Left'Length = L and then Left = Right.Content (1 .. L); end "="; --------- -- "=" -- --------- function "=" (Left : Sequence; Right : Element_Array) return Boolean is begin return Right = Left; end "="; ------------ -- Adjust -- ------------ procedure Adjust (X : in out Sequence) is begin if X.Length > 0 then X.Content := new Element_Array'(X.Content.all); end if; end Adjust; -------------- -- Allocate -- -------------- function Allocate (Length : Natural) return Element_Array_Access is begin if Length > 0 then return new Element_Array (1 .. Length); else return Empty; end if; end Allocate; ------------ -- Append -- ------------ procedure Append (Source : in out Sequence; New_Item : Sequence) is begin Append (Source, New_Item.Content (1 .. New_Item.Length)); end Append; ------------ -- Append -- ------------ procedure Append (Source : in out Sequence; New_Item : Element_Array) is Left_Bounds : constant Bounds := Sequence_Bounds (Source); begin Run_In_Place (Prog => Replace_Slice (0, Left_Bounds, Bounds'(Left_Bounds.Hi + 1, Left_Bounds.Hi), Array_Bounds (New_Item)), Left => Source, Right => New_Item); end Append; ------------ -- Append -- ------------ procedure Append (Source : in out Sequence; New_Item : Element) is begin Append (Source, Element_Array'(1 => New_Item)); end Append; ------------------ -- Array_Bounds -- ------------------ function Array_Bounds (A : Element_Array) return Bounds is begin return (Lo => A'First, Hi => A'Last); end Array_Bounds; ----------- -- Count -- ----------- function Count (Source : Sequence; Pattern : Element_Array) return Natural is begin return Count_Index (Source, Pattern, What => Return_Count); end Count; ----------------- -- Count_Index -- ----------------- function Count_Index (Source : Sequence; Pattern : Element_Array; What : Search_Kind; Going : Direction := Forward) return Natural is function Check_For_Pattern (Lo, Hi : Positive) return Boolean; -- True when Source (Lo .. Hi) = Pattern ----------------------- -- Check_For_Pattern -- ----------------------- function Check_For_Pattern (Lo, Hi : Positive) return Boolean is begin return Source.Content (Lo .. Hi) = Pattern; end Check_For_Pattern; begin return Sequences.Count_Index (Check_Slice => Check_For_Pattern'Unrestricted_Access, Source => Sequence_Bounds (Source), Pattern => Array_Bounds (Pattern), What => What, Going => Going); end Count_Index; ------------ -- Delete -- ------------ procedure Delete (Source : in out Sequence; From : Positive; Through : Natural) is begin Replace_Slice (Source, Low => From, High => Through, By => Null_Element_Array); end Delete; ------------ -- Delete -- ------------ function Delete (Source : Sequence; From : Positive; Through : Natural) return Sequence is begin return Replace_Slice (Source, Low => From, High => Through, By => Null_Element_Array); end Delete; -------------- -- Finalize -- -------------- procedure Finalize (X : in out Sequence) is begin -- Note: X.Content'Length is the allocated length of the sequence, can -- be greater than X.Length (the current length). If X.Content'Length -- is 0, we know that X.Content is Empty, not an access to a dynamically -- allocated array. if X.Content'Length > 0 then Free (X.Content); end if; X.Length := 0; X.Content := Empty; end Finalize; ----------------- -- Get_Element -- ----------------- function Get_Element (Source : Sequence; Index : Positive) return Element is begin if Index > Source.Length then raise Index_Error; end if; return Source.Content (Index); end Get_Element; ---------- -- Head -- ---------- procedure Head (Source : in out Sequence; Count : Natural; Pad : Element) is begin Run_In_Place (Prog => Head_Tail (0, Sequence_Bounds (Source), Count, What => Head), Left => Source, Right => Element_Array'(1 => Pad)); end Head; ---------- -- Head -- ---------- function Head (Source : Sequence; Count : Natural; Pad : Element) return Sequence is begin return Run_Copy (Prog => Head_Tail (0, Sequence_Bounds (Source), Count, What => Head), Left => Source.Content (1 .. Source.Length), Right => Element_Array'(1 => Pad)); end Head; ----------- -- Index -- ----------- function Index (Source : Sequence; Pattern : Element_Array; Going : Direction := Forward) return Natural is begin return Count_Index (Source, Pattern, Return_Index, Going); end Index; ---------------- -- Initialize -- ---------------- procedure Initialize (X : in out Sequence) is begin X.Length := 0; X.Content := Allocate (0); end Initialize; ------------ -- Insert -- ------------ function Insert (Source : Sequence; Before : Positive; New_Item : Element_Array) return Sequence is begin return Replace_Slice (Source, Low => Before, High => Before - 1, By => New_Item); end Insert; ------------ -- Insert -- ------------ procedure Insert (Source : in out Sequence; Before : Positive; New_Item : Element_Array) is begin Replace_Slice (Source, Low => Before, High => Before - 1, By => New_Item); end Insert; ------------- -- Is_Null -- ------------- function Is_Null (Source : Sequence) return Boolean is begin return Source.Length = 0; end Is_Null; ------------ -- Length -- ------------ function Length (Source : Sequence) return Natural is begin return Source.Length; end Length; ------------------- -- Null_Sequence -- ------------------- function Null_Sequence return Sequence is begin return To_Sequence (0); end Null_Sequence; --------------- -- Overwrite -- --------------- procedure Overwrite (Source : in out Sequence; Position : Positive; New_Item : Element_Array) is begin Replace_Slice (Source => Source, Low => Position, High => Position + New_Item'Length - 1, By => New_Item); end Overwrite; --------------- -- Overwrite -- --------------- function Overwrite (Source : Sequence; Position : Positive; New_Item : Element_Array) return Sequence is begin return Replace_Slice (Source, Low => Position, High => Position + New_Item'Length - 1, By => New_Item); end Overwrite; --------------------- -- Replace_Element -- --------------------- procedure Replace_Element (Source : in out Sequence; Index : Positive; By : Element) is begin if Index > Source.Length then raise Index_Error; end if; Source.Content (Index) := By; end Replace_Element; ------------------- -- Replace_Slice -- ------------------- function Replace_Slice (Source : Sequence; Low : Positive; High : Natural; By : Element_Array) return Sequence is begin return Run_Copy (Prog => Replace_Slice (0, Sequence_Bounds (Source), Bounds'(Low, High), Array_Bounds (By)), Left => Source.Content (1 .. Source.Length), Right => By); end Replace_Slice; ------------------- -- Replace_Slice -- ------------------- procedure Replace_Slice (Source : in out Sequence; Low : Positive; High : Natural; By : Element_Array) is begin Run_In_Place (Prog => Replace_Slice (0, Sequence_Bounds (Source), Bounds'(Low, High), Array_Bounds (By)), Left => Source, Right => By); end Replace_Slice; -------------- -- Run_Copy -- -------------- function Run_Copy (Prog : Program; Left : Element_Array; Right : Element_Array := Null_Element_Array) return Sequence is Result : constant Sequence := To_Sequence (Prog.Result_Length); begin Run (Prog, Result.Content.all, Left, Right); return Result; end Run_Copy; ------------------ -- Run_In_Place -- ------------------ procedure Run_In_Place (Prog : Program; Left : in out Sequence; Right : Element_Array := Null_Element_Array) is Old_Contents : Element_Array_Access := Left.Content; New_Contents : Element_Array_Access; Old_Alloc : constant Natural := Old_Contents'Length; New_Alloc : constant Natural := Round (Prog.Result_Length); begin if New_Alloc = Old_Alloc then New_Contents := Old_Contents; else New_Contents := Allocate (New_Alloc); end if; Run (Prog, New_Contents.all, Old_Contents (1 .. Left.Length), Right); Left.Length := Prog.Result_Length; Left.Content := New_Contents; if New_Contents /= Old_Contents and then Old_Contents'Length > 0 then Free (Old_Contents); end if; end Run_In_Place; --------------------- -- Sequence_Bounds -- --------------------- function Sequence_Bounds (S : Sequence) return Bounds is begin return (Lo => 1, Hi => S.Length); end Sequence_Bounds; --------- -- Set -- --------- procedure Set (Item : in out Sequence; Source : Element_Array) is begin Item := To_Sequence (Source); end Set; ---------------- -- Set_Length -- ---------------- procedure Set_Length (Source : in out Sequence; Length : Natural) is begin Run_In_Place (Prog => Head_Tail (0, Sequence_Bounds (Source), Length, What => Head, Suppress_Padding => True), Left => Source, Right => Empty_Element_Array); end Set_Length; ----------- -- Slice -- ----------- function Slice (Source : Sequence; Low : Positive; High : Natural) return Element_Array is begin if Low > Source.Length + 1 or else High > Source.Length then raise Index_Error; end if; return Source.Content (Low .. High); end Slice; ---------------------- -- To_Element_Array -- ---------------------- function To_Element_Array (Source : Sequence) return Element_Array is begin return Source.Content (1 .. Source.Length); end To_Element_Array; ----------------- -- To_Sequence -- ----------------- function To_Sequence (Source : Element_Array) return Sequence is begin return 1 * Source; end To_Sequence; ----------------- -- To_Sequence -- ----------------- function To_Sequence (Length : Natural) return Sequence is begin return (Ada.Finalization.Controlled with Length => Length, Content => Allocate (Length)); end To_Sequence; ---------- -- Tail -- ---------- procedure Tail (Source : in out Sequence; Count : Natural; Pad : Element) is begin Run_In_Place (Prog => Head_Tail (0, Sequence_Bounds (Source), Count, What => Tail), Left => Source, Right => Element_Array'(1 => Pad)); end Tail; ---------- -- Tail -- ---------- function Tail (Source : Sequence; Count : Natural; Pad : Element) return Sequence is begin return Run_Copy (Prog => Head_Tail (0, Sequence_Bounds (Source), Count, What => Tail), Left => Source.Content (1 .. Source.Length), Right => Element_Array'(1 => Pad)); end Tail; -------------------------- -- Unchecked_Element_Of -- -------------------------- function Unchecked_Element_Of (Source : access Sequence; Index : Positive) return Element_Ptr is begin if Index > Source.Length then raise Index_Error; end if; return Element_Ptr'(Source.Content (Index)'Unrestricted_Access); end Unchecked_Element_Of; end PolyORB.Sequences.Unbounded; polyorb-2.8~20110207.orig/src/polyorb-opaque.ads0000644000175000017500000000545511750740340020651 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . O P A Q U E -- -- -- -- S p e c -- -- -- -- Copyright (C) 2001-2008, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- Utility declarations for low-level memory management. with Ada.Streams; with Ada.Unchecked_Deallocation; with System; package PolyORB.Opaque is pragma Preelaborate; ---------------------------------------- -- All-purpose memory allocation type -- ---------------------------------------- type Zone_Access is access all Ada.Streams.Stream_Element_Array; -- A storage zone: an array of bytes. procedure Free is new Ada.Unchecked_Deallocation (Ada.Streams.Stream_Element_Array, Zone_Access); -------------------------------------- -- All-purpose memory location type -- -------------------------------------- subtype Opaque_Pointer is System.Address; function Is_Null (P : Opaque_Pointer) return Boolean; pragma Inline (Is_Null); end PolyORB.Opaque; polyorb-2.8~20110207.orig/src/polyorb-minimal_servant.adb0000644000175000017500000000574611750740340022531 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . M I N I M A L _ S E R V A N T -- -- -- -- B o d y -- -- -- -- Copyright (C) 2002-2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with PolyORB.Errors; package body PolyORB.Minimal_Servant is --------------------- -- Execute_Servant -- --------------------- function Execute_Servant (Self : not null access Implementation; Req : Requests.Request_Access) return Boolean is begin return Execute_Servant (Self.As_Servant, Req); end Execute_Servant; function Execute_Servant (Self : not null access Servant; Req : Requests.Request_Access) return Boolean is use PolyORB.Errors; use PolyORB.Requests; Error : Error_Container; begin Invoke (Servant'Class (Self.all)'Access, Req); Set_Out_Args (Req, Error); return True; end Execute_Servant; ------------------------ -- To_PolyORB_Servant -- ------------------------ function To_PolyORB_Servant (S : access Servant) return PolyORB.Servants.Servant_Access is begin return S.Neutral_View'Access; end To_PolyORB_Servant; end PolyORB.Minimal_Servant; polyorb-2.8~20110207.orig/src/polyorb-poa_policies-thread_policy.adb0000644000175000017500000000447311750740340024627 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . P O A _ P O L I C I E S . T H R E A D _ P O L I C Y -- -- -- -- B o d y -- -- -- -- Copyright (C) 2004 Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by ACT Europe. -- -- (email: sales@act-europe.fr) -- -- -- ------------------------------------------------------------------------------ package body PolyORB.POA_Policies.Thread_Policy is -------------- -- Executor -- -------------- function Executor (Self : access ThreadPolicy) return PolyORB.Servants.Executor_Access is begin return Self.Executor; end Executor; end PolyORB.POA_Policies.Thread_Policy; polyorb-2.8~20110207.orig/src/polyorb-errors-helper.ads0000644000175000017500000001104711750740340022142 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . E R R O R S . H E L P E R -- -- -- -- S p e c -- -- -- -- Copyright (C) 2005-2007, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with PolyORB.Any; package PolyORB.Errors.Helper is ----------------------- -- Completion_Status -- ----------------------- To_Completion_Status : constant array (PolyORB.Types.Unsigned_Long range 0 .. 2) of Completion_Status := (0 => Completed_Yes, 1 => Completed_No, 2 => Completed_Maybe); To_Unsigned_Long : constant array (Completion_Status) of PolyORB.Types.Unsigned_Long := (Completed_Yes => 0, Completed_No => 1, Completed_Maybe => 2); function From_Any (Item : PolyORB.Any.Any) return Completion_Status; function To_Any (Item : Completion_Status) return Any.Any; function TC_Completion_Status return PolyORB.Any.TypeCode.Local_Ref; -- The typecode for standard enumeration type completion_status -- Null_Members function To_Any (Name : Standard.String; Member : Null_Members) return PolyORB.Any.Any; -- System_Exception_Members function System_Exception_TypeCode (Name : Standard.String) return PolyORB.Any.TypeCode.Local_Ref; -- Return the TypeCode corresponding to the indicated -- system exception name. function From_Any (Item : Any.Any) return System_Exception_Members; function To_Any (Name : Standard.String; Member : System_Exception_Members) return PolyORB.Any.Any; -- Standard exceptions function TC_Comm_Failure return PolyORB.Any.TypeCode.Local_Ref; function TC_Transient return PolyORB.Any.TypeCode.Local_Ref; function TC_No_Response return PolyORB.Any.TypeCode.Local_Ref; function TC_Obj_Adapter return PolyORB.Any.TypeCode.Local_Ref; -- ForwardRequest_Members function To_Any (Item : ForwardRequest_Members) return PolyORB.Any.Any; function From_Any (Item : PolyORB.Any.Any) return ForwardRequest_Members; function TC_ForwardRequest return PolyORB.Any.TypeCode.Local_Ref; -- ForwardRequestPerm_Members function To_Any (Item : ForwardRequestPerm_Members) return PolyORB.Any.Any; function From_Any (Item : PolyORB.Any.Any) return ForwardRequestPerm_Members; function TC_ForwardRequestPerm return PolyORB.Any.TypeCode.Local_Ref; -- NeedsAddressingMode_Members function To_Any (Item : NeedsAddressingMode_Members) return PolyORB.Any.Any; function From_Any (Item : PolyORB.Any.Any) return NeedsAddressingMode_Members; function TC_NeedsAddressingMode return PolyORB.Any.TypeCode.Local_Ref; function Error_To_Any (Error : Error_Container) return PolyORB.Any.Any; end PolyORB.Errors.Helper; polyorb-2.8~20110207.orig/src/polyorb-poa_policies-request_processing_policy-use_default_servant.adb0000644000175000017500000001510111750740340033332 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- B O D Y -- -- -- -- B o d y -- -- -- -- Copyright (C) 2002-2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with Ada.Tags; with PolyORB.POA; with PolyORB.POA_Policies.Id_Uniqueness_Policy.Multiple; with PolyORB.POA_Policies.Servant_Retention_Policy; package body PolyORB.POA_Policies.Request_Processing_Policy.Use_Default_Servant is use PolyORB.Errors; ------------ -- Create -- ------------ function Create return Use_Default_Servant_Policy_Access is begin return new Use_Default_Servant_Policy; end Create; ------------------------- -- Check_Compatibility -- ------------------------- procedure Check_Compatibility (Self : Use_Default_Servant_Policy; Other_Policies : AllPolicies; Error : in out PolyORB.Errors.Error_Container) is pragma Warnings (Off); pragma Unreferenced (Self); pragma Warnings (On); use Ada.Tags; use PolyORB.POA_Policies.Id_Uniqueness_Policy; use PolyORB.POA_Policies.Id_Uniqueness_Policy.Multiple; begin -- Use_Default_Servant requires Multiple_Id for J in Other_Policies'Range loop if Other_Policies (J).all in IdUniquenessPolicy'Class and then Other_Policies (J).all'Tag /= Multiple_Id_Policy'Tag then Throw (Error, InvalidPolicy_E, InvalidPolicy_Members'(Index => 0)); end if; end loop; end Check_Compatibility; --------------- -- Policy_Id -- --------------- function Policy_Id (Self : Use_Default_Servant_Policy) return String is pragma Warnings (Off); pragma Unreferenced (Self); pragma Warnings (On); begin return "REQUEST_PROCESSING_POLICY.USE_DEFAULT_SERVANT"; end Policy_Id; ------------------- -- Id_To_Servant -- ------------------- procedure Id_To_Servant (Self : Use_Default_Servant_Policy; OA : PolyORB.POA_Types.Obj_Adapter_Access; U_Oid : Unmarshalled_Oid; Servant : out Servants.Servant_Access; Error : in out PolyORB.Errors.Error_Container) is pragma Warnings (Off); pragma Unreferenced (Self); pragma Warnings (On); use PolyORB.POA_Policies.Servant_Retention_Policy; use type PolyORB.Servants.Servant_Access; begin -- Lookup object in Active Object Map Retained_Id_To_Servant (POA.Obj_Adapter_Access (OA).Servant_Retention_Policy.all, OA, U_Oid, Servant, Error); if Found (Error) then return; end if; -- Under USE_DEFAULT_SERVANT policy, if no servant is found in -- the Active Object Map, we return the POA's default servant. if Servant = null then if POA.Obj_Adapter_Access (OA).Default_Servant /= null then Servant := POA.Obj_Adapter_Access (OA).Default_Servant; else Throw (Error, NoServant_E, Null_Members'(Null_Member)); end if; end if; end Id_To_Servant; ----------------- -- Set_Servant -- ----------------- procedure Set_Servant (Self : Use_Default_Servant_Policy; OA : PolyORB.POA_Types.Obj_Adapter_Access; Servant : Servants.Servant_Access; Error : in out PolyORB.Errors.Error_Container) is pragma Unreferenced (Self); pragma Unreferenced (Error); begin POA.Obj_Adapter_Access (OA).Default_Servant := Servant; end Set_Servant; ----------------- -- Get_Servant -- ----------------- procedure Get_Servant (Self : Use_Default_Servant_Policy; OA : PolyORB.POA_Types.Obj_Adapter_Access; Servant : out Servants.Servant_Access; Error : in out PolyORB.Errors.Error_Container) is pragma Unreferenced (Self); use type PolyORB.Servants.Servant_Access; begin if POA.Obj_Adapter_Access (OA).Default_Servant /= null then Servant := POA.Obj_Adapter_Access (OA).Default_Servant; else Throw (Error, NoServant_E, Null_Members'(Null_Member)); end if; end Get_Servant; ---------------------------- -- Ensure_Servant_Manager -- ---------------------------- procedure Ensure_Servant_Manager (Self : Use_Default_Servant_Policy; Error : in out PolyORB.Errors.Error_Container) is pragma Unreferenced (Self); begin Throw (Error, WrongPolicy_E, Null_Members'(Null_Member)); end Ensure_Servant_Manager; end PolyORB.POA_Policies.Request_Processing_Policy.Use_Default_Servant; polyorb-2.8~20110207.orig/src/polyorb-qos-exception_informations.ads0000644000175000017500000000634311750740340024742 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . Q O S . E X C E P T I O N _ I N F O R M A T I O N S -- -- -- -- S p e c -- -- -- -- Copyright (C) 2006-2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with Ada.Exceptions; with PolyORB.Requests; with PolyORB.Types; package PolyORB.QoS.Exception_Informations is pragma Elaborate_Body; type QoS_Ada_Exception_Information_Parameter is new QoS_Parameter (Ada_Exception_Information) with record Exception_Information : PolyORB.Types.String; end record; type QoS_Ada_Exception_Information_Parameter_Access is access all QoS_Ada_Exception_Information_Parameter'Class; procedure Set_Exception_Information (Request : in out Requests.Request; Occurrence : Ada.Exceptions.Exception_Occurrence); -- Add additional exception information to Ada_Exception_Information reply -- service context. function Get_Exception_Information (R : Requests.Request) return String; -- Utility function to extract the above QoS parameter from a request. -- A zero-length string is returned if no such QoS parameter is present. function Get_Exception_Message (R : Requests.Request) return String; -- Utility function to extract just the Exception_Message part from the -- Exception_Information. Like the above, returns a zero length string -- if no suitable QoS parameter is available. end PolyORB.QoS.Exception_Informations; polyorb-2.8~20110207.orig/src/polyorb-representations-test.ads0000644000175000017500000000674711750740340023566 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . R E P R E S E N T A T I O N S . T E S T -- -- -- -- S p e c -- -- -- -- Copyright (C) 2001-2007, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- A dummy data representation method, just for show. with PolyORB.Buffers; package PolyORB.Representations.Test is pragma Elaborate_Body; use PolyORB.Buffers; type Rep_Test is new Representation with private; type Rep_Test_Access is access all Rep_Test; -- A real representation function should implement the -- following two subprograms. procedure Marshall_From_Any (R : access Rep_Test; Buffer : access Buffers.Buffer_Type; Data : Any.Any_Container'Class; Error : in out Errors.Error_Container); procedure Unmarshall_To_Any (R : access Rep_Test; Buffer : access Buffers.Buffer_Type; Data : in out Any.Any_Container'Class; Error : in out Errors.Error_Container); -- The following methods are specific to Rep_Test and are -- here only to facilitate testing of other parts of the ORB. procedure Marshall_Char (B : access Buffer_Type; C : Character); -- Marshall one character. function Unmarshall_Char (B : access Buffer_Type) return Character; -- Unmarshall one character. procedure Marshall_String (R : Rep_Test; B : access Buffer_Type; S : String); -- Marshall a string. function Unmarshall_String (R : Rep_Test; B : access Buffer_Type) return String; -- Unmarshall a string terminated by a CR/LF sequence. private type Rep_Test is new Representation with null record; end PolyORB.Representations.Test; polyorb-2.8~20110207.orig/src/polyorb-tasking-profiles-full_tasking_atc.ads0000644000175000017500000000437311750740340026145 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- POLYORB.TASKING.PROFILES.FULL_TASKING_ATC -- -- -- -- S p e c -- -- -- -- Copyright (C) 2002-2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- Base package for the implementation of PolyORB.Tasking with full tasking -- and asynchronous transfer of control. package PolyORB.Tasking.Profiles.Full_Tasking_ATC is pragma Preelaborate; end PolyORB.Tasking.Profiles.Full_Tasking_ATC; polyorb-2.8~20110207.orig/src/polyorb-orb.ads0000644000175000017500000003147211750740340020137 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . O R B -- -- -- -- S p e c -- -- -- -- Copyright (C) 2001-2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- The ORB core module: main loop and scheduler. -- Role: * to coordinate operation of the various subsystems. -- * to gateway asynchronous external events to the -- synchronous messaging architecture used within PolyORB. pragma Ada_2005; with PolyORB.Annotations; with PolyORB.Asynch_Ev; with PolyORB.Binding_Data; with PolyORB.Binding_Objects; with PolyORB.Binding_Objects.Lists; with PolyORB.Components; with PolyORB.Filters; with PolyORB.Jobs; with PolyORB.ORB_Controller; with PolyORB.Obj_Adapters; with PolyORB.Objects; with PolyORB.QoS; with PolyORB.References; with PolyORB.Requests; with PolyORB.Smart_Pointers; with PolyORB.Task_Info; with PolyORB.Transport; with PolyORB.Utils.Chained_Lists; package PolyORB.ORB is package PAE renames PolyORB.Asynch_Ev; package PBD renames PolyORB.Binding_Data; package PBO renames PolyORB.Binding_Objects; package PBOL renames PolyORB.Binding_Objects.Lists; package PC renames PolyORB.Components; package PF renames PolyORB.Filters; package PJ renames PolyORB.Jobs; package POC renames PolyORB.ORB_Controller; package PT renames PolyORB.Transport; package PTI renames PolyORB.Task_Info; ---------------------------------- -- Abstract tasking policy type -- ---------------------------------- -- A tasking policy defines a set of associations between the reception of -- certain messages or the detection of events on the ORB_Type component -- defined above and the resources used to process them. Each association -- is embodied in a specific subprogram. This subprogram may do all kinds -- of actions to handle the message: job, task creation or schedule it for -- execution by a general-purpose ORB task. type Tasking_Policy_Type is abstract tagged limited private; type Tasking_Policy_Access is access all Tasking_Policy_Type'Class; --------------------- -- A server object -- --------------------- -- XXX this is not a server object !!! type ORB_Type (Tasking_Policy : access Tasking_Policy_Type'Class; ORB_Controller : POC.ORB_Controller_Access) is new PolyORB.Components.Component with private; type ORB_Access is access all ORB_Type; ----------------- -- Request_Job -- ----------------- type Request_Job is new PJ.Job with record ORB : ORB_Access; Request : Requests.Request_Access; end record; ------------------------------- -- Tasking policy operations -- ------------------------------- type Active_Connection is record AES : PAE.Asynch_Ev_Source_Access; TE : PT.Transport_Endpoint_Access; end record; procedure Handle_New_Server_Connection (P : access Tasking_Policy_Type; ORB : ORB_Access; AC : Active_Connection) is abstract; -- Create the necessary processing resources for newly-created -- communication endpoint AS on server side. procedure Handle_Close_Connection (P : access Tasking_Policy_Type; TE : PT.Transport_Endpoint_Access) is abstract; -- Do necessary processing when a connection is closed procedure Handle_New_Client_Connection (P : access Tasking_Policy_Type; ORB : ORB_Access; AC : Active_Connection) is abstract; -- Create the necessary processing resources for newly-created -- communication endpoint AS on client side. procedure Handle_Request_Execution (P : access Tasking_Policy_Type; ORB : ORB_Access; RJ : access Request_Job'Class) is abstract; -- Create the necessary processing resources for the execution of request -- execution job RJ, which must be an upcall, and start this execution. -- RJ is freed automatically after completion. procedure Idle (P : access Tasking_Policy_Type; This_Task : PTI.Task_Info_Access; ORB : ORB_Access) is abstract; -- Called by a task that has nothing to do. -- The calling task must be in the ORB critical section at the call point; -- the tasking policy shall release it while the task is idling, and -- re-assert it before Idle returns. This_Task holds information on the -- idling task. ------------------------------ -- Server object operations -- ------------------------------ procedure Create (ORB : in out ORB_Type); -- Initialize a newly-allocated ORB object procedure Queue_Request_To_Handler (ORB : access ORB_Type; Msg : PolyORB.Components.Message'Class); -- Assign the handling of a Request (i.e. an upcall to an application -- object) to the appropriate task. -- ??? This is also used on the client side in Invoke_Request to submit -- a request to the ORB. function Find_Reusable_Binding_Object (ORB : access ORB_Type; Pro : Binding_Data.Profile_Access; QoS : PolyORB.QoS.QoS_Parameters) return Smart_Pointers.Ref; -- Try to find a binding object with a profile compatible with Pro, to -- determine if it can be reused for binding Pro. Return a reference to a -- Binding Object if found, or a nil reference if not. procedure Run (ORB : access ORB_Type; Request : Requests.Request_Access := null; May_Exit : Boolean); -- Execute the ORB until: -- - Exit_Condition.Condition.all becomes True -- (if Exit_Condition.Condition /= null), or -- - Shutdown is called on this ORB. -- This procedure is executed by permanent ORB tasks (those with a null -- Request parameter), and is also entered by user tasks that need to wait -- need to wait for the completion of a Request ("transient" tasks). -- If Request is not null, its Requesting_Task component is set on entry -- into Run to designate this task's Task_Info structure while it is -- executing ORB.Run. -- For a permanent task, if May_Exit is False then the task remains in this -- procedure until ORB shutdown, else it may return earlier (in which case -- it is expected to complete). -- For a transient task, May_Exit has no effect and is expected to always -- be set True. function Work_Pending (ORB : access ORB_Type) return Boolean; -- Return True if, and only if, some ORB processing is -- pending. procedure Perform_Work (ORB : access ORB_Type); -- Perform one ORB job and return. procedure Shutdown (ORB : access ORB_Type; Wait_For_Completion : Boolean := True); -- Shutdown ORB. If Wait_For_Completion is True, do not return before the -- shutdown is completed. procedure Register_Access_Point (ORB : access ORB_Type; TAP : PT.Transport_Access_Point_Access; Chain : PF.Factories_Access; PF : PBD.Profile_Factory_Access); -- Register a newly-created transport access point with ORB. When a -- connection is received on TAP, a filter chain is instantiated using -- Chain, and associated to the corresponding transport endpoint. function Is_Profile_Local (ORB : access ORB_Type; P : access Binding_Data.Profile_Type'Class) return Boolean; -- True iff P designates an object managed by this ORB. type Endpoint_Role is (Client, Server); procedure Register_Binding_Object (ORB : access ORB_Type; BO : Smart_Pointers.Ref; Role : Endpoint_Role); -- Register a newly-created transport endpoint with ORB. -- A filter chain is instantiated using Chain, and associated with TE. procedure Unregister_Binding_Object (ORB : access ORB_Type; BO : Binding_Objects.Binding_Object_Access); -- Unregister a Binding Object from the ORB package BO_Ref_Lists is new PolyORB.Utils.Chained_Lists (Smart_Pointers.Ref, Smart_Pointers."="); subtype BO_Ref_List is BO_Ref_Lists.List; -- A list of References to Binding Objects function Get_Binding_Objects (ORB : access ORB_Type; Predicate : access function (BO_Acc : Binding_Objects.Binding_Object_Access) return Boolean := null) return BO_Ref_List; -- Return a list of references to the BOs owned by this ORB. If Predicate -- is not null, look for BOs matching the predicate, and stop at the first -- valid matching one. procedure Set_Object_Adapter (ORB : access ORB_Type; OA : Obj_Adapters.Obj_Adapter_Access); -- Associate object adapter (OA) with ORB. -- Objects registered with OA become visible through ORB for external -- request invocation. -- Note: only one Object Adapter can be associated with an ORB. function Object_Adapter (ORB : access ORB_Type) return Obj_Adapters.Obj_Adapter_Access; -- Return the object adapter associated with ORB procedure Create_Reference (ORB : access ORB_Type; Oid : access Objects.Object_Id; Typ : String; Ref : out References.Ref); -- Create an object reference that designates object Oid within this ORB function Handle_Message (ORB : not null access ORB_Type; Msg : Components.Message'Class) return Components.Message'Class; ---------------------------- -- Annotations management -- ---------------------------- function Notepad_Of (ORB : access ORB_Type) return Annotations.Notepad_Access; private -------------------------------------------- -- Job type for method execution requests -- -------------------------------------------- procedure Run (J : not null access Request_Job); -- Override the abstract Run primitive for Job: -- dispatch through ORB's tasking policy. procedure Run_Request (ORB : access ORB_Type; Req : Requests.Request_Access); -- Execute Req within the current task of ORB. The ORB is responsible for -- the destruction of the request after execution. --------------------------------------- -- Tasking policy abstract interface -- --------------------------------------- type Tasking_Policy_Type is abstract tagged limited null record; package TAP_Lists is new PolyORB.Utils.Chained_Lists (PT.Transport_Access_Point_Access, PT."="); subtype TAP_List is TAP_Lists.List; --------------------- -- A server object -- --------------------- type ORB_Type (Tasking_Policy : access Tasking_Policy_Type'Class; ORB_Controller : POC.ORB_Controller_Access) is new PolyORB.Components.Component with record Transport_Access_Points : TAP_List; -- The set of transport access points managed by this ORB Binding_Objects : PBOL.List; -- The set of binding objects managed by this ORB Obj_Adapter : Obj_Adapters.Obj_Adapter_Access; -- The object adapter that manages objects registered with this ORB Notepad : aliased Annotations.Notepad; -- ORB's notepad. The user must ensure there is no race condition when -- accessing it. end record; end PolyORB.ORB; polyorb-2.8~20110207.orig/src/polyorb-platform.ads.in0000644000175000017500000000444211750740340021603 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . P L A T F O R M -- -- -- -- S p e c -- -- -- -- Copyright (C) 2007-2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- Platform-specific definitions package PolyORB.Platform is pragma Pure; Version : constant String := "@POLYORB_VERSION@"; Windows_On_Target : constant Boolean := @WINDOWS_ON_TARGET@; -- True when target operating system is Microsoft Windows end PolyORB.Platform; polyorb-2.8~20110207.orig/src/polyorb-parameters-initialization.ads0000644000175000017500000000437111750740340024543 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . P A R A M E T E R S . I N I T I A L I Z A T I O N -- -- -- -- S p e c -- -- -- -- Copyright (C) 2002-2007, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- Initialization of PolyORB.Parameters. -- This is a separate package so that PolyORB.Parameters can be made -- preelaborable. package PolyORB.Parameters.Initialization is pragma Elaborate_Body; end PolyORB.Parameters.Initialization; polyorb-2.8~20110207.orig/src/polyorb-setup-oa-simple_oa.adb0000644000175000017500000000576711750740340023047 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . S E T U P . O A . S I M P L E _ O A -- -- -- -- B o d y -- -- -- -- Copyright (C) 2003-2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with PolyORB.Initialization; with PolyORB.Obj_Adapters.Simple; with PolyORB.Utils.Strings; package body PolyORB.Setup.OA.Simple_OA is ---------------- -- Initialize -- ---------------- procedure Initialize; procedure Initialize is Obj_Adapter : PolyORB.Obj_Adapters.Obj_Adapter_Access; begin -- Create SOA object adapter Obj_Adapter := new PolyORB.Obj_Adapters.Simple.Simple_Obj_Adapter; PolyORB.Obj_Adapters.Create (Obj_Adapter); -- Link object adapter with ORB. PolyORB.ORB.Set_Object_Adapter (The_ORB, Obj_Adapter); end Initialize; use PolyORB.Initialization; use PolyORB.Initialization.String_Lists; use PolyORB.Utils.Strings; begin Register_Module (Module_Info' (Name => +"simple_oa", Conflicts => Empty, Depends => +"orb", Provides => +"object_adapter", Implicit => False, Init => Initialize'Access, Shutdown => null)); end PolyORB.Setup.OA.Simple_OA; polyorb-2.8~20110207.orig/src/polyorb-smart_pointers-sync_counters__mutex.adb0000644000175000017500000000552211750740340026657 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- POLYORB.SMART_POINTERS.SYNC_COUNTERS -- -- -- -- B o d y -- -- -- -- Copyright (C) 2009, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with PolyORB.Tasking.Mutexes; use PolyORB.Tasking.Mutexes; separate (PolyORB.Smart_Pointers) package body Sync_Counters is Counter_Lock : Mutex_Access; -- Global lock used to protect concurrent accesses to reference counters ---------------- -- Initialize -- ---------------- procedure Initialize is begin Create (Counter_Lock); end Initialize; ------------------------ -- Sync_Add_And_Fetch -- ------------------------ function Sync_Add_And_Fetch (Ptr : access Interfaces.Integer_32; Value : Interfaces.Integer_32) return Interfaces.Integer_32 is Result : Interfaces.Integer_32; begin Enter (Counter_Lock); Ptr.all := Ptr.all + Value; Result := Ptr.all; Leave (Counter_Lock); return Result; end Sync_Add_And_Fetch; end Sync_Counters; polyorb-2.8~20110207.orig/src/polyorb-request_qos.ads0000644000175000017500000001050411750740340021720 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . R E Q U E S T _ Q O S -- -- -- -- S p e c -- -- -- -- Copyright (C) 2004-2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- This package defines the Quality of Service (QoS) parameters to be -- passed along with a PolyORB request, and the call-back functions -- used to retrieve them. with PolyORB.QoS; with PolyORB.References; with PolyORB.Requests; package PolyORB.Request_QoS is function Fetch_QoS (Ref : PolyORB.References.Ref) return PolyORB.QoS.QoS_Parameters; -- Return the list of the QoS parameters to be applied when -- sending a request to the target denoted by Ref. This functions -- iterated over the different call-backs. procedure Set_Request_QoS (Req : in out Requests.Request; QoS : PolyORB.QoS.QoS_Parameters); procedure Add_Request_QoS (Req : in out Requests.Request; Kind : PolyORB.QoS.QoS_Kind; QoS : PolyORB.QoS.QoS_Parameter_Access); -- Add (replace if exists) passed QoS to the list of request QoSs. procedure Add_Reply_QoS (Req : in out Requests.Request; Kind : PolyORB.QoS.QoS_Kind; QoS : PolyORB.QoS.QoS_Parameter_Access); -- Add (replace if exists) passed QoS to the list of reply QoSs. function Extract_Request_Parameter (Kind : PolyORB.QoS.QoS_Kind; Req : Requests.Request) return PolyORB.QoS.QoS_Parameter_Access; -- Return QoS parameter of type Kind from request QoS, or a null -- if no parameter matches Kind. function Extract_Reply_Parameter (Kind : PolyORB.QoS.QoS_Kind; Req : Requests.Request) return PolyORB.QoS.QoS_Parameter_Access; -- Return QoS parameter of type Kind from reply QoS, or a null -- if no parameter matches Kind. type Fetch_QoS_CB is access function (Ref : PolyORB.References.Ref) return PolyORB.QoS.QoS_Parameter_Access; -- This call-back function retrieves one QoS_Parameter to be applied when -- sending a request to the target denoted by Ref. Return null if QoS -- parameter is not applicable for Ref. procedure Register (Kind : PolyORB.QoS.QoS_Kind; CB : Fetch_QoS_CB); -- Register one call-back function attached to QoS_Kind Kind function Get_Request_QoS (Req : Requests.Request) return PolyORB.QoS.QoS_Parameters; function Get_Reply_QoS (Req : Requests.Request) return PolyORB.QoS.QoS_Parameters; procedure Set_Reply_QoS (Req : in out Requests.Request; QoS : PolyORB.QoS.QoS_Parameters); end PolyORB.Request_QoS; polyorb-2.8~20110207.orig/src/polyorb-request_scheduler.adb0000644000175000017500000000527411750740340023063 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . R E Q U E S T _ S C H E D U L E R -- -- -- -- B o d y -- -- -- -- Copyright (C) 2004-2008, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ package body PolyORB.Request_Scheduler is My_Factory : Request_Scheduler_Factory_Access; ------------ -- Create -- ------------ procedure Create (RS : out Request_Scheduler_Access) is begin if My_Factory /= null then RS := Create (My_Factory); end if; end Create; ---------------------------------------- -- Register_Request_Scheduler_Factory -- ---------------------------------------- procedure Register_Request_Scheduler_Factory (RSF : Request_Scheduler_Factory_Access) is begin pragma Assert (My_Factory = null); My_Factory := RSF; end Register_Request_Scheduler_Factory; end PolyORB.Request_Scheduler; polyorb-2.8~20110207.orig/src/polyorb-binding_data.ads0000644000175000017500000002502111750740340021751 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . B I N D I N G _ D A T A -- -- -- -- S p e c -- -- -- -- Copyright (C) 2001-2011, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- Management of binding data, i. e. the elements of information -- that designate a remote middleware TSAP. with PolyORB.Annotations; with PolyORB.Components; with PolyORB.Errors; with PolyORB.Objects; with PolyORB.QoS; with PolyORB.Smart_Pointers; pragma Elaborate_All (PolyORB.Smart_Pointers); with PolyORB.Transport; with PolyORB.Types; package PolyORB.Binding_Data is ---------------------------------------------- -- Abstract inter-ORB protocol profile type -- ---------------------------------------------- type Profile_Type is abstract tagged limited private; type Profile_Access is access all Profile_Type'Class; -- A profile is an element of information that contains: -- - a profile tag identifying a communication system and a -- method invocation protocol stack; -- - an unambiguous name of one TSAP within the communication -- system; -- - a key that identifies one object among all those accessible -- on that TSAP; -- - a priority, locally assigned, that denotes the preferrence -- expressed by the user for the choice of a profile type -- among a set of profiles. procedure Release (P : in out Profile_Type) is abstract; -- Free profile data subtype Profile_Tag is Types.Unsigned_Long; Tag_Internet_IOP : constant Profile_Tag; Tag_UIPMC : constant Profile_Tag; Tag_Multiple_Components : constant Profile_Tag; Tag_Local : constant Profile_Tag; Tag_SRP : constant Profile_Tag; Tag_SOAP : constant Profile_Tag; Tag_DIOP : constant Profile_Tag; Tag_Neighbour : constant Profile_Tag; Tag_UDNS : constant Profile_Tag; Tag_MDNS : constant Profile_Tag; Tag_Test : constant Profile_Tag; type Profile_Preference is new Integer range 0 .. Integer'Last; -- Profile_Preference'First means "unsupported profile type". Preference_Default : constant Profile_Preference; -- Default value for profile preference. function Get_OA (Profile : Profile_Type) return PolyORB.Smart_Pointers.Entity_Ptr; -- For object group profiles, return the group object adapter that controls -- Profile's OID. For other profiles, return null. function Get_Object_Key (Profile : Profile_Type) return Objects.Object_Id_Access; -- Retrieve the opaque object key from Profile. procedure Bind_Profile (Profile : access Profile_Type; The_ORB : Components.Component_Access; QoS : PolyORB.QoS.QoS_Parameters; BO_Ref : out Smart_Pointers.Ref; Error : out Errors.Error_Container) is abstract; -- Retrieve a transport endpoint and an attached protocol stack instance -- (or create new ones) that match this profile, in order to send a message -- to the middleware that hosts the designated object. The Filter at the -- top of the protocol stack (i.e. the Session) is returned. Concrete -- implementations are responsible for registering the TE with the ORB if -- necessary. function Get_Profile_Tag (Profile : Profile_Type) return Profile_Tag is abstract; pragma Inline (Get_Profile_Tag); -- Return the profile tag associated with this profile type function Get_Profile_Preference (Profile : Profile_Type) return Profile_Preference is abstract; pragma Inline (Get_Profile_Preference); -- Return the profile priority associated with this profile type type Profile_Factory is abstract tagged limited private; type Profile_Factory_Access is access all Profile_Factory'Class; procedure Create_Factory (PF : out Profile_Factory; TAP : Transport.Transport_Access_Point_Access; ORB : Components.Component_Access) is abstract; -- Initialize PF to act as profile factory for transport access point TAP -- managed by ORB. function Create_Profile (PF : access Profile_Factory; Oid : Objects.Object_Id) return Profile_Access is abstract; -- Create a profile of the type determined by PF, using Oid as the object -- specification. function Duplicate_Profile (P : Profile_Type) return Profile_Access is abstract; -- Return a copy of the user-provided data used to build P, it -- does not duplicate any internal structure. procedure Destroy_Profile (P : in out Profile_Access); pragma Inline (Destroy_Profile); function Is_Multicast_Profile (P : Profile_Type) return Boolean; -- True if this profile designates a group of objects that may exist on -- different nodes. False by default, overridden for group profiles. function Is_Local_Profile (PF : access Profile_Factory; P : access Profile_Type'Class) return Boolean is abstract; -- True iff P designates an object that can be contacted at the access -- point associated with PF. function Is_Local_Profile (P : Profile_Type'Class) return Boolean; -- True if a previous call to Is_Local_Profile (two-argument version) -- has previously returned True (optimization, used to avoid traversing -- the list of all profile factories again). function Image (Prof : Profile_Type) return String is abstract; -- Used for debugging purposes function Is_Colocated (Left : Profile_Type; Right : Profile_Type'Class) return Boolean is abstract; -- True if, knowing Left, we determine that Right (a profile of any type) -- designates an object that resides on the same node. function Same_Node (Left, Right : Profile_Type'Class) return Boolean; -- True if we can determine that Left and Right are profiles -- targetting the same node. function Same_Object_Key (Left, Right : Profile_Type'Class) return Boolean; -- True if Left and Right have the same object key. Note that some profile -- types (e.g. Multiple_Components) have null object keys, in which case -- this function cannot match and returns False. procedure Set_Continuation (Prof : access Profile_Type; Continuation : PolyORB.Smart_Pointers.Ref); -- Associate profile Profile (a profile designating an object on the local -- ORB) with the designated object as its actual Continuation. Used for -- proxy profiles (which are actually indirect pointers to remote objects). function Notepad_Of (Prof : access Profile_Type) return Annotations.Notepad_Access; private use type Types.Unsigned_Long; -- Standard tags defined by CORBA Tag_Internet_IOP : constant Profile_Tag := 0; Tag_Multiple_Components : constant Profile_Tag := 1; Tag_UIPMC : constant Profile_Tag := 3; -- TAO value : -- Tag_UIPMC : constant Profile_Tag := 1413566220; -- Tags defined by PolyORB (see docs/OMG_TAGS for assigned ranges) Tag_PolyORB_First : constant Profile_Tag := 16#504f0000#; -- "PO\x00\x00" Tag_Local : constant Profile_Tag := Tag_PolyORB_First + 0; Tag_SRP : constant Profile_Tag := Tag_PolyORB_First + 1; Tag_SOAP : constant Profile_Tag := Tag_PolyORB_First + 2; Tag_DIOP : constant Profile_Tag := Tag_PolyORB_First + 3; Tag_Neighbour : constant Profile_Tag := Tag_PolyORB_First + 4; Tag_UDNS : constant Profile_Tag := Tag_PolyORB_First + 5; Tag_MDNS : constant Profile_Tag := Tag_PolyORB_First + 6; Tag_Test : constant Profile_Tag := Tag_PolyORB_First + 255; Tag_PolyORB_Last : constant Profile_Tag := 16#504f00ff#; -- "PO\x00\xff" Preference_Default : constant Profile_Preference := (Profile_Preference'First + Profile_Preference'Last) / 2; type Profile_Type is abstract tagged limited record Object_Id : Objects.Object_Id_Access; -- The object identifier for this object, relative to a node's -- name space. Notepad : aliased PolyORB.Annotations.Notepad; -- Profile's notepad. It is the user's responsibility to protect this -- component against invalid concurrent accesses. Continuation : PolyORB.Smart_Pointers.Ref; -- If the profile has been bound, this component designates its -- continuation (which is either a local servant, or a binding object). Known_Local : Boolean := False; -- Set True by Is_Local_Profile when it is determined that this profile -- is local. end record; type Profile_Factory is abstract tagged limited null record; end PolyORB.Binding_Data; polyorb-2.8~20110207.orig/src/config.adc.in0000644000175000017500000000031711750740337017523 0ustar xavierxavier-- Set assertion and debug policies pragma Assertion_Policy (@ASSERTION_POLICY@); pragma Debug_Policy (@DEBUG_POLICY@); -- Set Initialize_Scalars for debug builds @DEBUG_ONLY@pragma Initialize_Scalars; polyorb-2.8~20110207.orig/src/polyorb.conf0000644000175000017500000004155011750740340017533 0ustar xavierxavier############################################################################### # PolyORB configuration file. # $Id: polyorb.conf 170012 2011-02-02 17:00:14Z quinot $ ############################################################################### # The syntax of the configuration file is: # - empty lines and lines that have a '#' in column 1 are # ignored; # - sections can be started by lines of the form # '[' SECTION-NAME ']'; # - variable assignments can be performed by lines of the # form VARIABLE-NAME '=' VALUE. # Any variable assignment is local to a section. # # Assignments that occur before the first section declaration # are relative to section [environment]. # Section and variable names are case sensitive. # # A variable Var.Iable in section [Sec] can be overridden by # setting environment variable "POLYORB_SEC_VAR_IABLE" # (see Make_Env_Name in body). # Furthermore, each time a resolved in that section value # starts with "file:", the contents of the file is used instead. ############################################################################### # Logging facility # # Note: debug will work iff PolyORB has been configured with 'debug' enabled [log] #default=notice #timestamp=false # # Middleware core # #polyorb.any=debug #polyorb.any.exceptionlist=debug #polyorb.any.nvlist=debug #polyorb.asynch_ev.sockets=debug #polyorb.binding_data=debug #polyorb.binding_objects=debug #polyorb.buffers=debug #polyorb.buffers_show=debug #polyorb.call_back=debug #polyorb.components=debug #polyorb.configuration=debug #polyorb.errors=debug #polyorb.errors.helper=debug #polyorb.exceptions=debug #polyorb.exceptions.stack=debug #polyorb.filters=debug #polyorb.filters.slicers=debug #polyorb.filters.fragmenter=debug #polyorb.initialization=debug #polyorb.lanes=debug #polyorb.orb=debug #polyorb.orb_controller=debug #polyorb.orb_controller_status=debug #polyorb.orb.no_tasking=debug #polyorb.orb.thread_per_request=debug #polyorb.orb.thread_per_session=debug #polyorb.orb.thread_pool=debug #polyorb.protocols=debug #polyorb.protocols.echo=debug #polyorb.references=debug #polyorb.references.binding=debug #polyorb.references.corbaloc=debug #polyorb.references.ior=debug #polyorb.references.uri=debug #polyorb.representations.cdr=debug #polyorb.requests=debug #polyorb.request_qos=debug #polyorb.request_scheduler.servant_lane=debug #polyorb.servants.group_servants=debug #polyorb.smart_pointers=debug #polyorb.tasking.advanced_mutexes=debug #polyorb.tasking.condition_variables=debug #polyorb.tasking.mutexes=debug #polyorb.tasking.rw_locks=debug #polyorb.tasking.semaphores=debug #polyorb.tasking.watchers=debug #polyorb.tasking.profiles.full_tasking.threads=debug #polyorb.transport.connected=debug #polyorb.transport.connected.sockets=debug #polyorb.transport.connected.sockets.ssl=debug #polyorb.transport.datagram.sockets=debug #polyorb.utils.configuration_file=debug #polyorb.utils.sockets=debug #polyorb.utils.tcp_access_points=debug # # POA # #polyorb.obj_adapters.group_object_adapter=debug #polyorb.object_maps.system=debug #polyorb.object_maps.user=debug #polyorb.poa=debug #polyorb.poa.basic_poa=debug #polyorb.poa_manager.basic_manager=debug #polyorb.poa_types=debug #polyorb.poa_policies.thread_policy.single_thread=debug #polyorb.poa_policies.thread_policy.main_thread=debug #polyorb.rt_poa.basic_rt_poa=debug # # CORBA personality # #corba.fixed_point=debug #corba.orb=debug #corba.serverrequest=debug #polyorb.corba_p.exceptions=debug #polyorb.corba_p.initial_references=debug #polyorb.corba_p.server_tools=debug #polyorb.if_descriptors.corba_ir=debug #portableserver=debug #portableserver.poa=debug # # DSA personality # #polyorb.dsa_p.partitions=debug #polyorb.dsa_p.remote_launch=debug #polyorb.dsa_p.storages=debug #polyorb.dsa_p.storages.dsm=debug #polyorb.dsa_p.storages.dfs=debug #system.dsa_services=debug #system.partition_interface=debug # #polyorb.qos.term_manager_info=debug #polyorb.termination_manager=debug #polyorb.termination_manager.bootstrap=debug # # GIOP personality # #polyorb.binding_data.giop.common_sockets=debug #polyorb.giop_p.exceptions=debug #polyorb.giop_p.service_contexts=debug #polyorb.giop_p.tagged_components=debug #polyorb.protocols.giop=debug #polyorb.protocols.giop.common=debug #polyorb.protocols.giop.giop_1_0=debug #polyorb.protocols.giop.giop_1_1=debug #polyorb.protocols.giop.giop_1_2=debug #polyorb.representations.cdr.giop_utils=debug # # IIOP Personality # #polyorb.binding_data.giop.iiop=debug # # DIOP Personality # #polyorb.binding_data.giop.diop=debug # # MIOP Personality # #polyorb.binding_data.giop.uipmc=debug #polyorb.filters.miop=debug #polyorb.filters.miop.miop_in=debug #polyorb.filters.miop.miop_out=debug #polyorb.miop_p.tagged_components=debug # # MOMA personality # #moma.configuration.server=debug #moma.configuration=debug #moma.message_consumers=debug #moma.message_producers=debug #moma.provider.message_consumer=debug #moma.provider.message_handler=debug #moma.provider.message_pool=debug #moma.provider.message_producer=debug #moma.provider.routers=debug #moma.provider.topic_datas=debug #moma.types=debug # # SOAP personality # #polyorb.filters.http=debug #polyorb.protocols.soap_pr=debug #soap.message.xml=debug #soap.types=debug # # SRP personality # #polyorb.protocols.srp=debug #polyorb.representations.srp=debug # # Tasking profiles # #polyorb.tasking.profiles.full_tasking.condition_variables=debug #polyorb.tasking.profiles.full_tasking.mutexes=debug #polyorb.tasking.profiles.full_tasking.threads=debug #polyorb.tasking.profiles.ravenscar.condition_variables=debug #polyorb.tasking.profiles.ravenscar.index_manager=debug #polyorb.tasking.profiles.ravenscar.mutexes=debug #polyorb.tasking.profiles.ravenscar.threads=debug # # Security Service # #polyorb.security.authentication_mechanisms=debug #polyorb.security.credentials=debug #polyorb.security.exported_names=debug [smart_pointers] # Fine-grained control of debugging traces for smart pointers events #default.trace=false #POLYORB.ANY.ANY_CONTAINER.trace=true #POLYORB.ANY.NVLIST.OBJECT.trace=true #POLYORB.BINDING_OBJECTS.BINDING_OBJECT.trace=true #POLYORB.CORBA_P.POLICY.POLICY_OBJECT_TYPE.trace=true #POLYORB.OBJ_ADAPTERS.GROUP_OBJECT_ADAPTER.GROUP_OBJECT_ADAPTER.trace=true #POLYORB.POA.BASIC_POA.BASIC_OBJ_ADAPTER.trace=true #POLYORB.POA_MANAGER.BASIC_MANAGER.BASIC_POA_MANAGER.trace=true #POLYORB.REFERENCES.REFERENCE_INFO.trace=true ############################################################################### # CORBA parameters # [corba] #name_service=IOR:xxx #ir_service=IOR:xxx #policy_domain_manager=IOR:xxx #replication_manager=IOR:xxx ############################################################################### # DSA parameters # [dsa] #rpc_timeout=0 #name_service=IOR:xxx #delay_between_failed_requests=1000 #max_failed_requests=10 #termination_initiator=false #termination_policy=global_termination #tm_time_between_waves=1000 #tm_time_before_start=5000 #detach=false #rsh_command=ssh #rsh_options=-f #force_rsh=false ############################################################################### # CDR parameters # [cdr] enable_fast_path=true # Set to FALSE to disable fast path CDR (un)marshalling ############################################################################### # GIOP parameters # [giop] ############################################################### # Native code sets # # Available char data code sets: # 16#00010001# ISO 8859-1:1987; Latin Alphabet No. 1 # 16#05010001# X/Open UTF-8; UCS Transformation Format 8 (UTF-8) # # Available wchar data code sets: # 16#00010100# ISO/IEC 10646-1:1993; UCS-2, Level 1 # 16#00010109# ISO/IEC 10646-1:1993; # UTF-16, UCS Transformation Format 16-bit form # #giop.native_char_code_set=16#00010001# #giop.native_wchar_code_set=16#00010100# # # The following parameters force the inclusion of fallback code sets # as supported conversion code sets. This is required to enable # interoperability with ORBs whose code sets negotiation support is # broken. See PolyORB Users Guide for additional information. # #giop.add_char_fallback_code_set=false #giop.add_wchar_fallback_code_set=false ############################################################################### # IIOP parameters # [iiop] ############################################################### # IIOP Global Settings # Preference level for IIOP #polyorb.binding_data.iiop.preference=0 # IIOP default address #polyorb.protocols.iiop.default_addr=127.0.0.1 # IIOP default port #polyorb.protocols.iiop.default_port=2809 # Single port number: bind only to that port, fail if already bound #polyorb.protocols.iiop.default_port=2809-2811 # Port range: bind to first available port in range # IIOP alternate addresses #polyorb.protocols.iiop.alternate_listen_addresses=127.0.0.1:2810 127.0.0.1:2820 # Default GIOP/IIOP Version #polyorb.protocols.iiop.giop.default_version.major=1 #polyorb.protocols.iiop.giop.default_version.minor=2 ############################################################### # IIOP 1.2 specific parameters # Set to True to enable IIOP 1.2 #polyorb.protocols.iiop.giop.1.2.enable=true # Set to True to send a locate message prior to the request #polyorb.protocols.iiop.giop.1.2.locate_then_request=true # Maximum message size before fragmenting request #polyorb.protocols.iiop.giop.1.2.max_message_size=1000 ############################################################### # IIOP 1.1 specific parameters # Set to True to enable IIOP 1.1 #polyorb.protocols.iiop.giop.1.1.enable=true # Set to True to send a locate message prior to the request #polyorb.protocols.iiop.giop.1.1.locate_then_request=true # Maximum message size before fragmenting request #polyorb.protocols.iiop.giop.1.1.max_message_size=1000 ############################################################### # IIOP 1.0 specific parameters # Set to True to enable IIOP 1.0 #polyorb.protocols.iiop.giop.1.0.enable=true # Set to True to send a locate message prior to the request #polyorb.protocols.iiop.giop.1.0.locate_then_request=true ############################################################################### # SSLIOP parameters # [ssliop] ############################################################### # SSLIOP Global Settings # SSLIOP default port #polyorb.protocols.ssliop.default_port=2810 # Single port number: bind only to that port, fail if already bound #polyorb.protocols.ssliop.default_port=2810-2812 # Port range: bind to first available port in range # If no SSLIOP default address is provided, the one speficied for IIOP # is reused. # Private Key file name #polyorb.protocols.ssliop.privatekeyfile=privkey.pem # Certificate file name #polyorb.protocols.ssliop.certificatefile=cert.pem # Trusted CA certificates file #polyorb.protocols.ssliop.cafile=cacert.pem # Trusted CA certificates path #polyorb.protocols.ssliop.capath=demoCA/certs # Disable unprotected invocations #polyorb.protocols.ssliop.disable_unprotected_invocations=true ############################################################### # Peer certificate verification mode # Verify peer certificate #polyorb.protocols.ssliop.verify=false # Fail if client did not return certificate. (server side option) #polyorb.protocols.ssliop.verify_fail_if_no_peer_cert=false # Request client certificate only once. (server side option) #polyorb.protocols.ssliop.verify_client_once=false ############################################################################### # DIOP parameters # [diop] ############################################################### # DIOP Global Settings # Preference level for DIOP #polyorb.binding_data.diop.preference=0 # DIOP default address #polyorb.protocols.diop.default_addr=127.0.0.1 # DIOP default port #polyorb.protocols.diop.default_port=12345 # Single port number: bind only to that port, fail if already bound #polyorb.protocols.diop.default_port=12345-12347 # Port range: bind to first available port in range # Default GIOP/DIOP Version #polyorb.protocols.diop.giop.default_version.major=1 #polyorb.protocols.diop.giop.default_version.minor=2 ############################################################### # DIOP 1.2 specific parameters # Set to True to enable DIOP 1.2 #polyorb.protocols.diop.giop.1.2.enable=true # Maximum message size #polyorb.protocols.diop.giop.1.2.max_message_size=1000 ############################################################### # DIOP 1.1 specific parameters # Set to True to enable DIOP 1.1 #polyorb.protocols.diop.giop.1.1.enable=true # Maximum message size #polyorb.protocols.diop.giop.1.1.max_message_size=1000 ############################################################### # DIOP 1.0 specific parameters # Set to True to enable DIOP 1.0 #polyorb.protocols.diop.giop.1.0.enable=true ############################################################################### # MIOP parameters # [miop] ############################################################### # MIOP Global Settings # Preference level for MIOP #polyorb.binding_data.uipmc.preference=0 # Maximum message size #polyorb.miop.max_message_size=6000 # Time To Leave parameter #polyorb.miop.ttl=15 # Multicast address to use # These two parameters must be set explicitly, no default value is provided. # If either parameter is unset, the MIOP access point is disabled. #polyorb.miop.multicast_addr= #polyorb.miop.multicast_port= # Set to True to enable MIOP #polyorb.protocols.miop.giop.1.2.enable=false # Maximum message size #polyorb.protocols.miop.giop.1.2.max_message_size=1000 ############################################################################### # SOAP parameters # [soap] ############################################################### # SOAP Global Settings # Preference level for SOAP #polyorb.binding_data.soap.preference=0 # SOAP default address #polyorb.protocols.soap.default_addr=127.0.0.1 # SOAP default port #polyorb.protocols.soap.default_port=8080 # Single port number: bind only to that port, fail if already bound #polyorb.protocols.soap.default_port=8080-8082 # Port range: bind to first available port in range ############################################################################### # Enable/Disable access points # [access_points] #srp=disable #soap=disable #iiop=disable #iiop.ssliop=disable #diop=disable #uipmc=disable ############################################################################### # Enable/Disable modules # [modules] #binding_data.srp=disable #binding_data.soap=disable #binding_data.iiop=disable #binding_data.iiop.ssliop=disable #binding_data.diop=disable #binding_data.uipmc=disable ############################################################################### # Parameters for tasking # [tasking] #storage_size=262144 # Default storage size for all threads spawned by PolyORB #abortable_rpcs=true # If set True, allows abortion of remote calls on the server side # Control of Thead_Pool #start_threads=4 # Count of initially created anonymous threads in pool #min_spare_threads=2 # Minimum number of idle anonymous threads to maintain #max_spare_threads=4 # Maximum number of idle anonymous threads to maintain #max_threads=10 # Upper limit on number of anonymous threads ############################################################################### # Parameters for ORB Controllers # [orb_controller] # Interval between two polling actions on one monitor (milliseconds) #polyorb.orb_controller.polling_interval=0 # Timeout when polling on one monitor (milliseconds) #polyorb.orb_controller.polling_timeout=0 ############################################################################### # Parameters for transport mechanisms # [transport] # Set TCP_NODELAY option on TCP sockets to disable Nagle buffering # (this is true by default) #tcp.nodelay=false ############################################################################### # Enable/Disable proxies # [proxies] #enable_proxies=false ############################################################################### # Security Service configuration [security_manager] #own_credentials=my_credentials #integrity_required=true #confidentiality_required=true #detect_replay_required=true #detect_misordering_required=true #establish_trust_in_target_required=true #establish_trust_in_client_required=true #identity_assertion_required=true #delegation_by_client_required=true #[my_credentials] #transport_credentials_type=tls #tls.method=tls1 #tls.certificate_file=my.crt #tls.certificate_chain_file= #tls.private_key_file=my.key #tls.certificate_authority_file=root.crt #tls.certificate_authority_path #tls.ciphers=ALL #tls.verify_peer=true #tls.verify_fail_if_no_peer_certificate=true # #authentication_credentials_type=gssup #gssup.username=username@domain #gssup.password=password #gssup.target_name=@domain [tlsiop] #addresses=127.0.0.1:3456 #[my_gssup] #mechanism=gssup #gssup.target_name=@domain #gssup.passwd_file=passwd.pwd #[MySecurePOA] #unprotected_invocation_allowed=true #transport_mechanism=tlsiop #authentication_mechanism=my_gssup #authentication_required=true #backward_trust_rules_file=file.btr #privilege_authorities= polyorb-2.8~20110207.orig/src/polyorb-minimal_servant.ads0000644000175000017500000000776311750740340022553 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . M I N I M A L _ S E R V A N T -- -- -- -- S p e c -- -- -- -- Copyright (C) 2002-2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ pragma Ada_2005; -- A Minimal_Servant is servant independant from any application -- personalities. It allows the creation of servants on top of PolyORB's -- neutral core layer. -- -- Hence, these servants can be made available to all applications -- personalities, without the need of a specific one, allowing easy -- deployment of common services. -- -- However, it is a 'minimal' servant : it is incomplete and you will have -- to write Invoke function corresponding to your servant. -- This allows you to precisely control the servants created. with PolyORB.Servants; with PolyORB.Smart_Pointers; with PolyORB.Smart_Pointers.Controlled_Entities; with PolyORB.Requests; package PolyORB.Minimal_Servant is pragma Elaborate_Body; type Servant is abstract new Smart_Pointers.Controlled_Entities.Entity with private; type Servant_Acc is access all Servant; function Execute_Servant (Self : not null access Servant; Req : Requests.Request_Access) return Boolean; function To_PolyORB_Servant (S : access Servant) return PolyORB.Servants.Servant_Access; procedure Invoke (Self : access Servant; Request : PolyORB.Requests.Request_Access) is abstract; private type Implementation (As_Servant : access Servant'Class) is new Servants.Servant with null record; overriding function Execute_Servant (Self : not null access Implementation; Req : Requests.Request_Access) return Boolean; type Servant is abstract new Smart_Pointers.Controlled_Entities.Entity with record Neutral_View : aliased Implementation (Servant'Access); -- The PolyORB (personality-neutral) view of this servant. -- This instance of the multiple views idiom allows the -- implementation of a multiple inheritance relationship: -- here, Servant inherits from both Entity (a reference-counted -- thing) and Servant (a Component that implements the -- Objects interface). end record; end PolyORB.Minimal_Servant; polyorb-2.8~20110207.orig/src/polyorb-representations-test.adb0000644000175000017500000001034011750740340023525 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . R E P R E S E N T A T I O N S . T E S T -- -- -- -- B o d y -- -- -- -- Copyright (C) 2001-2009, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- A dummy data representation method, just for show. with Ada.Streams; with PolyORB.Utils.Buffers; package body PolyORB.Representations.Test is use Ada.Streams; use PolyORB.Utils.Buffers; procedure Marshall_From_Any (R : access Rep_Test; Buffer : access Buffers.Buffer_Type; Data : Any.Any_Container'Class; Error : in out Errors.Error_Container) is begin raise Program_Error; end Marshall_From_Any; procedure Unmarshall_To_Any (R : access Rep_Test; Buffer : access Buffers.Buffer_Type; Data : in out Any.Any_Container'Class; Error : in out Errors.Error_Container) is begin raise Program_Error; end Unmarshall_To_Any; procedure Marshall_Char (B : access Buffer_Type; C : Character) is begin Align_Marshall_Copy (B, Stream_Element_Array'(1 => Stream_Element (Character'Pos (C)))); end Marshall_Char; function Unmarshall_Char (B : access Buffer_Type) return Character is A : Stream_Element_Array (1 .. 1); begin Align_Unmarshall_Copy (B, Align_1, A); return Character'Val (A (1)); end Unmarshall_Char; procedure Marshall_String (R : Rep_Test; B : access Buffer_Type; S : String) is begin pragma Warnings (Off); pragma Unreferenced (R); pragma Warnings (On); for I in S'Range loop Marshall_Char (B, S (I)); end loop; end Marshall_String; function Unmarshall_String (R : Rep_Test; B : access Buffer_Type) return String is S : String (1 .. 1024); C : Character; Last : Integer := S'First - 1; Max : constant Stream_Element_Count := Length (B.all); begin pragma Warnings (Off); pragma Unreferenced (R); pragma Warnings (On); loop exit when Last - S'First + 1 = Integer (Max); C := Unmarshall_Char (B); if C = ASCII.CR then C := Unmarshall_Char (B); pragma Assert (C = ASCII.LF); exit; end if; Last := Last + 1; S (Last) := C; exit when Last = S'Last; end loop; return S (S'First .. Last); end Unmarshall_String; end PolyORB.Representations.Test; polyorb-2.8~20110207.orig/src/polyorb-servants-iface.ads0000644000175000017500000000752611750740340022272 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . S E R V A N T S . I F A C E -- -- -- -- S p e c -- -- -- -- Copyright (C) 2003-2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- The messages supported by Servants (object implementations). with PolyORB.Binding_Data; with PolyORB.Components; with PolyORB.Requests; package PolyORB.Servants.Iface is type Execute_Request is new Components.Message with record Req : Requests.Request_Access; Pro : PolyORB.Binding_Data.Profile_Access; end record; -- Request the receiving Servant to execute Req. On the client side, Pro is -- the profile of the target object reference that was used to establish a -- binding object with the target. The expected reply is Executed_Request, -- or Null_Message if the request was not processed immediately. type Abort_Request is new Components.Message with record Req : Requests.Request_Access; end record; -- Request the receiving Servant to abort ongoing processing of Req. The -- expected reply is Null_Message. type Executed_Request is new Components.Message with record Req : Requests.Request_Access; end record; -- Notify the completion of Req's execution. This message can -- be a synchronous reply to Execute_Request, or it can be -- emitted asynchronously to the requesting component if -- Null_Message was returned as the reply for Execute_Request. -- Note: for a request that has been transmitted through a binding -- object, notifying completion to the requestor may cause the binding -- object to be destroyed. Protocol personalities therefore may not -- execute any operation on a binding object through which a reply has -- been received once they have emitted an Executed_Request message. type Acknowledge_Request is new Components.Message with record Req : Requests.Request_Access; end record; -- Acknowledge the reception of Req. This message can be a -- synchronous reply to Execute_Request. end PolyORB.Servants.Iface; polyorb-2.8~20110207.orig/src/polyorb-tasking-profiles-full_tasking-mutexes.adb0000644000175000017500000001323211750740340026757 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- POLYORB.TASKING.PROFILES.FULL_TASKING.MUTEXES -- -- -- -- B o d y -- -- -- -- Copyright (C) 2002-2008, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- Implementation of POSIX-like mutexes with full Ada tasking. -- This variant uses GNAT-specific library facilities. -- WAG:601 -- pragma Warnings (Off) with pattern not supported in that compiler version -- so use plain pragma Warnings (Off/On) instead. -- pragma Warnings (Off, "* is an internal GNAT unit"); -- pragma Warnings (Off, "use of this unit is non-portable*"); pragma Warnings (Off); -- Depends on System.Task_Primitives.Operations, an internal GNAT unit with System.Task_Primitives.Operations; pragma Warnings (On); with System; with Ada.Unchecked_Deallocation; with PolyORB.Initialization; with PolyORB.Log; with PolyORB.Utils.Strings; package body PolyORB.Tasking.Profiles.Full_Tasking.Mutexes is use System.Task_Primitives.Operations; use PolyORB.Log; package L is new PolyORB.Log.Facility_Log ("polyorb.tasking.profiles.full_tasking.mutexes"); procedure O (Message : String; Level : Log_Level := Debug) renames L.Output; function C (Level : Log_Level := Debug) return Boolean renames L.Enabled; ---------- -- Free -- ---------- procedure Free is new Ada.Unchecked_Deallocation (PTM.Mutex_Type'Class, PTM.Mutex_Access); procedure Free is new Ada.Unchecked_Deallocation (Mutex_Lock, Mutex_Lock_Access); ------------ -- Create -- ------------ function Create (MF : access Full_Tasking_Mutex_Factory_Type; Name : String := "") return PTM.Mutex_Access is pragma Warnings (Off); pragma Unreferenced (MF); pragma Unreferenced (Name); -- XXX The use of Name is not yet implemented pragma Warnings (On); M : constant Full_Tasking_Mutex_Access := new Full_Tasking_Mutex_Type; begin pragma Debug (C, O ("Create Mutex")); M.The_Lock := new Mutex_Lock; Initialize_Lock (Prio => System.Any_Priority'Last, L => M.The_Lock); return PTM.Mutex_Access (M); end Create; ------------- -- Destroy -- ------------- procedure Destroy (MF : access Full_Tasking_Mutex_Factory_Type; M : in out PTM.Mutex_Access) is pragma Warnings (Off); pragma Unreferenced (MF); pragma Warnings (On); begin pragma Debug (C, O ("Destroy mutex")); Finalize_Lock (Full_Tasking_Mutex_Access (M).The_Lock); Free (Full_Tasking_Mutex_Access (M).The_Lock); Free (M); end Destroy; ----------- -- Enter -- ----------- procedure Enter (M : access Full_Tasking_Mutex_Type) is Ceiling_Violation : Boolean; begin pragma Debug (C, O ("Enter mutex")); Write_Lock (M.The_Lock, Ceiling_Violation); if Ceiling_Violation then raise Program_Error; end if; end Enter; ----------- -- Leave -- ----------- procedure Leave (M : access Full_Tasking_Mutex_Type) is begin pragma Debug (C, O ("Leave mutex")); Unlock (M.The_Lock); end Leave; ---------------- -- Initialize -- ---------------- procedure Initialize; procedure Initialize is begin pragma Debug (C, O ("Initialize package Profiles.Full_Tasking.Mutexes")); PTM.Register_Mutex_Factory (PTM.Mutex_Factory_Access (The_Mutex_Factory)); end Initialize; use PolyORB.Initialization; use PolyORB.Initialization.String_Lists; use PolyORB.Utils.Strings; begin Register_Module (Module_Info' (Name => +"tasking.profiles.full_tasking.mutexes", Conflicts => Empty, Depends => Empty, Provides => +"tasking.mutexes", Implicit => False, Init => Initialize'Access, Shutdown => null)); end PolyORB.Tasking.Profiles.Full_Tasking.Mutexes; polyorb-2.8~20110207.orig/src/polyorb-poa_policies-thread_policy.ads0000644000175000017500000000473111750740340024645 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . P O A _ P O L I C I E S . T H R E A D _ P O L I C Y -- -- -- -- S p e c -- -- -- -- Copyright (C) 2001-2004 Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by ACT Europe. -- -- (email: sales@act-europe.fr) -- -- -- ------------------------------------------------------------------------------ with PolyORB.Servants; package PolyORB.POA_Policies.Thread_Policy is type ThreadPolicy is abstract new Policy with private; type ThreadPolicy_Access is access all ThreadPolicy'Class; function Executor (Self : access ThreadPolicy) return PolyORB.Servants.Executor_Access; private type ThreadPolicy is abstract new Policy with record Executor : PolyORB.Servants.Executor_Access; end record; end PolyORB.POA_Policies.Thread_Policy; polyorb-2.8~20110207.orig/src/polyorb-tasking-abortables.adb0000644000175000017500000000653111750740340023106 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . T A S K I N G . A B O R T A B L E S -- -- -- -- B o d y -- -- -- -- Copyright (C) 2002-2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ package body PolyORB.Tasking.Abortables is Initialized : Boolean := False; --------------- -- Abort_Run -- --------------- procedure Abort_Run (AR : not null access Abortable) is begin -- By default abortion is not supported and this opeartion has no effect null; end Abort_Run; ------------ -- Create -- ------------ function Create (R : not null access PTT.Runnable'Class) return Abortable is begin return Abortable'(R => PTT.Runnable_Access (R)); end Create; ---------------------------- -- Register_Abortable_Tag -- ---------------------------- procedure Register_Abortable_Tag (T : Ada.Tags.Tag) is begin pragma Assert (not Initialized); if not Initialized then Abortable_Tag := T; Initialized := True; end if; end Register_Abortable_Tag; --------- -- Run -- --------- procedure Run (AR : not null access Abortable) is begin PTT.Run (AR.R); end Run; ---------------------- -- Run_With_Timeout -- ---------------------- procedure Run_With_Timeout (AR : not null access Abortable; Timeout : Duration; Expired : out Boolean) is pragma Unreferenced (Timeout); begin Expired := False; AR.Run; end Run_With_Timeout; end PolyORB.Tasking.Abortables; polyorb-2.8~20110207.orig/src/polyorb-rt_poa.ads0000644000175000017500000001144611750740340020640 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . R T _ P O A -- -- -- -- S p e c -- -- -- -- Copyright (C) 2004-2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- Abstract interface for the RT POA Object Adapter. -- This package provides an extension to PolyORB's POA, and allow the -- user to affect priorities to servants. It is notionnally -- equivalent to RTCORBA specification of the RT-POA. with PolyORB.Errors; with PolyORB.POA; with PolyORB.POA_Types; with PolyORB.Servants; with PolyORB.RT_POA_Policies.Priority_Model_Policy; with PolyORB.RT_POA_Policies.Thread_Pool_Policy; with PolyORB.Tasking.Priorities; package PolyORB.RT_POA is use PolyORB.POA_Types; use PolyORB.RT_POA_Policies.Priority_Model_Policy; use PolyORB.RT_POA_Policies.Thread_Pool_Policy; use PolyORB.Tasking.Priorities; type RT_Obj_Adapter is abstract new PolyORB.POA.Obj_Adapter with record -- Note: RT_POA may be used as a basic POA. Thus, RT-POA -- specifications do not require these policies to be set. Priority_Model_Policy : PriorityModelPolicy_Access; Thread_Pool_Policy : ThreadPoolPolicy_Access; end record; type RT_Obj_Adapter_Access is access all RT_Obj_Adapter'Class; procedure Create_Object_Identification_With_Priority (Self : access RT_Obj_Adapter; Hint : Object_Id_Access; Server_ORB_Priority : ORB_Priority; Server_External_Priority : External_Priority; U_Oid : out Unmarshalled_Oid; Error : in out PolyORB.Errors.Error_Container) is abstract; -- Reserve a complete object identifier, possibly using -- the given Hint (if not null) for the construction of -- the object identifier included in the Object_Id. procedure Activate_Object_With_Id_And_Priority (Self : access RT_Obj_Adapter; P_Servant : Servants.Servant_Access; Hint : Object_Id_Access; Server_ORB_Priority : ORB_Priority; Server_External_Priority : External_Priority; U_Oid : out Unmarshalled_Oid; Error : in out PolyORB.Errors.Error_Container) is abstract; -- Activate an object, i.e. associate it with a local -- identification, possibly using the given Hint (if not null) for -- the construction of the object identifier included in the procedure Get_Scheduling_Parameters (Self : access RT_Obj_Adapter; Id : Object_Id_Access; Model : out Priority_Model; Server_ORB_Priority : out ORB_Priority; Server_External_Priority : out External_Priority; Error : in out PolyORB.Errors.Error_Container) is abstract; -- Return scheduling parameters associated to servant P_Servant -- stored in Self. end PolyORB.RT_POA; polyorb-2.8~20110207.orig/src/polyorb-setup-oa-simple_oa.ads0000644000175000017500000000421511750740340023053 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . S E T U P . O A . S I M P L E _ O A -- -- -- -- S p e c -- -- -- -- Copyright (C) 2003 Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by ACT Europe. -- -- (email: sales@act-europe.fr) -- -- -- ------------------------------------------------------------------------------ -- Set up a Simple Object Adapter package PolyORB.Setup.OA.Simple_OA is pragma Elaborate_Body; end PolyORB.Setup.OA.Simple_OA; polyorb-2.8~20110207.orig/src/polyorb-task_info.ads0000644000175000017500000002642611750740340021335 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . T A S K _ I N F O -- -- -- -- S p e c -- -- -- -- Copyright (C) 2001-2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- This package provides a facility for associating information with each -- task executing the ORB main loop. pragma Ada_2005; with PolyORB.Asynch_Ev; with PolyORB.Jobs; with PolyORB.Tasking.Condition_Variables; with PolyORB.Tasking.Mutexes; with PolyORB.Tasking.Threads; with PolyORB.Types; with PolyORB.Utils.Ilists; package PolyORB.Task_Info is pragma Preelaborate; package PAE renames PolyORB.Asynch_Ev; package PTCV renames PolyORB.Tasking.Condition_Variables; package PTM renames PolyORB.Tasking.Mutexes; type Any_Task_Kind is (Any, Permanent, Transient); subtype Task_Kind is Any_Task_Kind range Permanent .. Transient; -- A Permanent task executes ORB.Run indefinitely. -- A Transient task executes ORB.Run until a given exit condition is met. -- Transient tasks are lent to neutral core middleware by user code. type Any_Task_State is (Any, Unscheduled, Running, Blocked, Idle, Terminated); subtype Task_State is Any_Task_State range Unscheduled .. Terminated; -- An Unscheduled task is waiting for rescheduling. -- A Running task is executing an ORB activity. -- A Blocked task is waiting for an external asynchronous event. -- An Idle task is waiting on a condition variable expecting another task -- to request ORB action. -- A Terminated task has been notified its exit condition is true. type Task_Info (Kind : Task_Kind) is limited private; type Task_Info_Access is access all Task_Info; -- Task Info holds information on tasks that run ORB.Run function Kind_Match (TI : Task_Info; Kind : Any_Task_Kind) return Boolean; -- True if Kind matches TI's Kind (Any matches any kind) type Task_Summary is limited private; -- Summary information: counter of registered tasks and of how many tasks -- of each kind are in each state. function Get_Count (Summary : Task_Summary; Kind : Any_Task_Kind := Any; State : Any_Task_State := Any) return Natural; -- Return the count of tasks with the given kind and state. If Kind or -- State is Any, return sum for all Kinds, respectively for all States. function Task_Summary_Valid (Summary : Task_Summary) return Boolean; -- Check the total count against the sum of the partial counts (for -- assertions purpose). procedure Task_Created (Summary : in out Task_Summary; TI : Task_Info); procedure Task_Removed (Summary : in out Task_Summary; TI : Task_Info); -- Record creation / task removal of the given task ------------------------------------ -- Task_Info components accessors -- ------------------------------------ function State (TI : Task_Info) return Task_State; -- Return the state of the task referred by TI procedure Set_State_Blocked (Summary : in out Task_Summary; TI : in out Task_Info; Selector : Asynch_Ev.Asynch_Ev_Monitor_Access; Timeout : Duration); -- The task referred by TI will be blocked on Selector for Timeout seconds procedure Set_State_Idle (Summary : in out Task_Summary; TI : in out Task_Info; Condition : PTCV.Condition_Access; Mutex : PTM.Mutex_Access); -- The task referred by TI will go Idle until Condition is signalled procedure Set_State_Running (Summary : in out Task_Summary; TI : in out Task_Info; Job : Jobs.Job_Access); -- The task referred by TI is now in Running state, and will execute Job; -- this procedure resets Selector or Condition it was blocked on. procedure Set_State_Unscheduled (Summary : in out Task_Summary; TI : in out Task_Info); -- The task referred by TI is now in Unscheduled state. procedure Set_State_Terminated (Summary : in out Task_Summary; TI : in out Task_Info); -- The task referred by TI has terminated its job. function Selector (TI : Task_Info) return Asynch_Ev.Asynch_Ev_Monitor_Access; -- Return Selector the task referred by TI is blocked on function Timeout (TI : Task_Info) return Duration; -- Return Timeout before stopping blocking function Condition (TI : Task_Info) return PTCV.Condition_Access; -- Return Condition Variable the Task referred by TI is blocked on function Mutex (TI : Task_Info) return PTM.Mutex_Access; -- Return Mutex used by the Task referred by TI when blocking. procedure Set_Id (TI : in out Task_Info); -- Task_Info will hold Id of the current task, as provided by the PolyORB -- tasking subsystem. procedure Set_May_Exit (TI : in out Task_Info; May_Exit : Boolean); -- Set the corresponding flags on TI function May_Exit (TI : Task_Info) return Boolean; -- Return the corresponding flags for TI procedure Set_Exit_Condition (TI : in out Task_Info; Exit_Condition : Types.Boolean_Ptr); -- Attach Exit_Condition to TI function Exit_Condition (TI : Task_Info) return Boolean; -- Return the value of TI's exit condition procedure Request_Abort_Polling (TI : in out Task_Info); -- Request TI to abort polling. Meaningful only if TI is in blocked state function Abort_Polling (TI : Task_Info) return Boolean; -- Return true if TI must abort polling and leave blocked state. -- Meaningful only if TI is in blocked state. function Id (TI : Task_Info) return PolyORB.Tasking.Threads.Thread_Id; -- Return thread id associated to TI function Job (TI : Task_Info) return Jobs.Job_Access; -- Return job associated to TI type Task_List is private; -- A list of tasks function Is_Empty (List : Task_List) return Boolean; -- True when List has no elements function List_First (List : Task_List) return access Task_Info; -- Return the first element of List procedure List_Attach (TI : access Task_Info; List : in out Task_List); -- Attach TI to the List. It must not already be on a list. Order of -- attachment and detachment is arbitrary. procedure List_Detach (TI : access Task_Info; List : in out Task_List); -- Remove TI from the list it was attached to (if any) function On_List (TI : Task_Info) return Boolean; -- True if TI is attached on a list (for assertions) function Image (TI : Task_Info) return String; -- For debug purposes private type Links_Type is array (Utils.Ilists.Link_Type) of aliased Task_Info_Access; type Task_Info (Kind : Task_Kind) is limited record Id : PolyORB.Tasking.Threads.Thread_Id; -- Task referred by Task_Info record State : Task_State := Unscheduled; -- Current Task status, not permitted to be changed except by internal -- procedure Task_State_Change, which in turn is called by each of the -- Set_State_xxx external procedures. May_Exit : Boolean := False; -- True iff ORB contoller is allowed to decide to terminate this task Abort_Polling : Boolean := False; -- True iff must abort polling Exit_Condition : PolyORB.Types.Boolean_Ptr := null; -- Null for Permanent tasks, in which case the exit condition is -- considered to be False. For Transient tasks, points to an initially -- False Boolean, which is set True when the task should exit ORB.Run. Job : Jobs.Job_Access; -- Job to run, meaningful only when State is Running Selector : Asynch_Ev.Asynch_Ev_Monitor_Access; -- Monitor on which Task referred by Id is blocked; -- meaningful only when State is Blocked. Timeout : Duration; -- Timeout before stopping polling when Blocked Condition : Tasking.Condition_Variables.Condition_Access; -- CV on which Task referred by Id is waiting in Idle state Mutex : Tasking.Mutexes.Mutex_Access; -- Mutex used by the Task referred by TI when blocking; -- meaningful only when State is Idle. Links : Links_Type; -- Pointers allowing the task to be attached to a (single) task list On_List : Boolean := False; -- True when task is attached to a task list end record; function Link (S : access Task_Info; Which : Utils.Ilists.Link_Type) return access Task_Info_Access; pragma Inline (Link); -- Accessor for Links package Task_Lists is new Utils.Ilists.Lists (T => Task_Info, T_Acc => Task_Info_Access, Doubly_Linked => True); type Task_List is new Task_Lists.List; type Task_Counters is array (Any_Task_Kind, Any_Task_State) of Natural; type Task_Summary is limited record Counters : Task_Counters := (others => (others => 0)); -- Count of tasks of each kind and state end record; pragma Inline (Get_Count); pragma Inline (Set_State_Blocked); pragma Inline (Set_State_Idle); pragma Inline (Set_State_Running); pragma Inline (Set_State_Unscheduled); pragma Inline (Set_State_Terminated); pragma Inline (State); pragma Inline (Selector); pragma Inline (Timeout); pragma Inline (Condition); pragma Inline (Mutex); pragma Inline (Set_Id); pragma Inline (Set_May_Exit); pragma Inline (May_Exit); pragma Inline (Set_Exit_Condition); pragma Inline (Exit_Condition); pragma Inline (Request_Abort_Polling); pragma Inline (Abort_Polling); pragma Inline (Image); pragma Inline (Id); pragma Inline (Job); end PolyORB.Task_Info; polyorb-2.8~20110207.orig/src/polyorb-utils-random.ads0000644000175000017500000000622211750740340021766 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . U T I L S . R A N D O M -- -- -- -- S p e c -- -- -- -- Copyright (C) 2003-2009, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- A pseudo-random generator based on Makoto Matsumoto and Takuji Nishimura -- `Mersenne Twister' random number generator MT19937. -- Note: we cannot depend on Ada.Numerics.Discrete_Random because of -- its wrong categorization. PolyORB components require a preelaborable -- pseudo-random generator. with PolyORB.Types; package PolyORB.Utils.Random is pragma Preelaborate; type Generator is limited private; type Seed_Type is new PolyORB.Types.Unsigned_Long; Default_Seed : constant Seed_Type; function Random (G : access Generator) return PolyORB.Types.Unsigned_Long; procedure Reset (G : access Generator; Seed : Seed_Type := Default_Seed); private N : constant := 624; -- Length of state vector Invalid : constant := N + 1; type Vector is array (0 .. N) of PolyORB.Types.Unsigned_Long; type State is record Vector_N : Vector := (others => 0); Condition : Integer := Invalid; Seed : Seed_Type := Default_Seed; end record; type Generator is limited record Gen_State : State; end record; Default_Seed : constant Seed_Type := 19_650_218; end PolyORB.Utils.Random; polyorb-2.8~20110207.orig/src/polyorb-setup-oa-basic_rt_poa.ads0000644000175000017500000000423311750740340023530 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . S E T U P . O A . B A S I C _ R T _ P O A -- -- -- -- S p e c -- -- -- -- Copyright (C) 2004 Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by ACT Europe. -- -- (email: sales@act-europe.fr) -- -- -- ------------------------------------------------------------------------------ -- Set up a Basic Portable Object Adapter package PolyORB.Setup.OA.Basic_RT_POA is pragma Elaborate_Body; end PolyORB.Setup.OA.Basic_RT_POA; polyorb-2.8~20110207.orig/src/polyorb-parameters-initialization.adb0000644000175000017500000000521411750740340024517 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . P A R A M E T E R S . I N I T I A L I Z A T I O N -- -- -- -- B o d y -- -- -- -- Copyright (C) 2002-2009, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- PolyORB runtime configuration facility with PolyORB.Initialization; with PolyORB.Utils; with PolyORB.Utils.Strings; pragma Elaborate_All (PolyORB.Initialization); package body PolyORB.Parameters.Initialization is use PolyORB.Initialization; use PolyORB.Initialization.String_Lists; use PolyORB.Utils.Strings; begin Register_Module (Module_Info' (Name => +"parameters", Conflicts => Empty, Depends => +"parameters_sources?", Provides => Empty, Implicit => True, Init => Parameters.Initialize'Access, Shutdown => null)); end PolyORB.Parameters.Initialization; polyorb-2.8~20110207.orig/src/polyorb-utils-hfunctions-hyper.ads0000644000175000017500000000665711750740340024027 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . U T I L S . H F U N C T I O N S . H Y P E R -- -- -- -- S p e c -- -- -- -- Copyright (C) 2003 Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by ACT Europe. -- -- (email: sales@act-europe.fr) -- -- -- ------------------------------------------------------------------------------ -- This package provides a class of hashing functions for strings. -- Hash_Hyper computes for string S = (Si)i the sum of the elements -- Hi (S) = (( Ai * Si ) mod Prime) mod Size -- where A = (A0, A1, ..) is a random vector of dimension S'Length -- Note: this class of function is universal. with PolyORB.Types; package PolyORB.Utils.HFunctions.Hyper is pragma Preelaborate; function Hash_Hyper (S : String; Seed : PolyORB.Types.Unsigned_Long; Prime : Natural; Size : Natural) return Natural; -- Hash function implemented by this package. -- S : key to hash, -- Seed : seed for the pseudo-random generator to use, -- Prime : a prime number -- Size : restrict results to range O .. Size - 1. -- -- Note that Prime is an implicit upper bound of the length of the -- string to be hashed. type Hash_Hyper_Parameters is new Hash_Parameters with private; function Hash (S : String; Param : Hash_Hyper_Parameters; Size : Natural) return Natural; function Default_Hash_Parameters return Hash_Hyper_Parameters; function Next_Hash_Parameters (Param : Hash_Hyper_Parameters) return Hash_Hyper_Parameters; private type Hash_Hyper_Parameters is new Hash_Parameters with record Seed : PolyORB.Types.Unsigned_Long := 0; Prime : Natural := 0; end record; end PolyORB.Utils.HFunctions.Hyper; polyorb-2.8~20110207.orig/src/polyorb-qos-addressing_modes.ads0000644000175000017500000000525211750740340023464 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . Q O S . A D D R E S S I N G _ M O D E S -- -- -- -- S p e c -- -- -- -- Copyright (C) 2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- This parameter used for selection of GIOP addressing mode for request -- marshalling. As client request parameter it define addressing mode which -- should be used for request marshalling. As server request parameter it -- specify which addressing mode have been used by client in request. with PolyORB.Errors; package PolyORB.QoS.Addressing_Modes is type QoS_GIOP_Addressing_Mode_Parameter is new QoS_Parameter (GIOP_Addressing_Mode) with record Mode : PolyORB.Errors.Addressing_Mode; end record; type QoS_GIOP_Addressing_Mode_Parameter_Access is access all QoS_GIOP_Addressing_Mode_Parameter'Class; end PolyORB.QoS.Addressing_Modes; polyorb-2.8~20110207.orig/src/polyorb-object_maps-user.adb0000644000175000017500000001117011750740340022567 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . O B J E C T _ M A P S . U S E R -- -- -- -- B o d y -- -- -- -- Copyright (C) 2003-2008, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with PolyORB.Log; with PolyORB.Types; package body PolyORB.Object_Maps.User is use Map_Entry_HTables; use PolyORB.Log; use PolyORB.Types; package L is new Log.Facility_Log ("polyorb.object_maps.user"); procedure O (Message : Standard.String; Level : Log_Level := Debug) renames L.Output; function C (Level : Log_Level := Debug) return Boolean renames L.Enabled; ---------------- -- Initialize -- ---------------- procedure Initialize (O_Map : in out User_Object_Map) is begin Initialize (O_Map.User_Map); end Initialize; -------------- -- Finalize -- -------------- procedure Finalize (O_Map : in out User_Object_Map) is begin Finalize (O_Map.User_Map); end Finalize; --------- -- Add -- --------- procedure Add (O_Map : access User_Object_Map; Obj : Object_Map_Entry_Access) is begin Insert (O_Map.User_Map, To_Standard_String (Obj.Oid.Id), Obj); end Add; --------------- -- Get_By_Id -- --------------- function Get_By_Id (O_Map : User_Object_Map; Item : PolyORB.POA_Types.Unmarshalled_Oid) return Object_Map_Entry_Access is begin pragma Debug (C, O ("User generated OID, look up in table")); return Lookup (O_Map.User_Map, To_Standard_String (Item.Id), null); end Get_By_Id; -------------------- -- Get_By_Servant -- -------------------- function Get_By_Servant (O_Map : User_Object_Map; Item : PolyORB.Servants.Servant_Access) return Object_Map_Entry_Access is use type PolyORB.Servants.Servant_Access; It : Iterator := First (O_Map.User_Map); begin while not Last (It) loop if not Is_Null (Value (It)) then pragma Debug (C, O ("Examinating elt: " & To_Standard_String (Value (It).Oid.Id))); if Value (It).Servant = Item then pragma Debug (C, O ("Found !")); return Value (It); end if; end if; Next (It); end loop; pragma Debug (C, O ("Not Found !")); return null; end Get_By_Servant; ------------------ -- Remove_By_Id -- ------------------ function Remove_By_Id (O_Map : access User_Object_Map; Item : PolyORB.POA_Types.Unmarshalled_Oid) return Object_Map_Entry_Access is Old_Entry : Object_Map_Entry_Access; Name : constant String := To_Standard_String (Item.Id); begin Old_Entry := Lookup (O_Map.User_Map, Name, null); Delete (O_Map.User_Map, Name); return Old_Entry; end Remove_By_Id; end PolyORB.Object_Maps.User; polyorb-2.8~20110207.orig/src/polyorb-sequences.ads0000644000175000017500000001750311750740340021347 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . S E Q U E N C E S -- -- -- -- S p e c -- -- -- -- Copyright (C) 2002-2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- PolyORB.Sequences is the parent of the bounded and unbounded sequence -- packages. Some exceptions and types common to both are declared here -- (following the structure of Ada.Strings). -- -- Length_Error is raised when sequence lengths are exceeded. -- Pattern_Error is raised when a null pattern string is -- passed. Index_Error is raised when indexes are out of range. package PolyORB.Sequences is pragma Preelaborate; Length_Error, Pattern_Error, Index_Error : exception; type Alignment is (Left, Right, Center); type Truncation is (Left, Right, Error); type Membership is (Inside, Outside); type Direction is (Forward, Backward); type Trim_End is (Left, Right, Both); type Extremity is (Head, Tail); type Search_Kind is (Return_Count, Return_Index); -- The low and high bound of an element array or slice thereof type Bounds is record Lo, Hi : Integer; end record; private function Length (Index_Range : Bounds) return Natural; -- Return the length of the slice or array whose bounds are given function Round (Length : Natural) return Natural; -- Compute appropriate Length. If Length = 0, return 0. If not, return -- Initial_Size + N * Increment_Size where N is the smallest integer -- such that Length < Initial_Size + N * Increment_Size. ----------------------------------- -- The Sequences Virtual Machine -- ----------------------------------- -- All sequences operations can be represented without reference to -- the sequence element type as a sequence of slice assignments from -- at most two "operand" element arrays into a "target" element array. -- Non-generic versions of all sequence operations are provided in this -- package which operate only on element array indices; the generic -- versions of these operations, operating on actual element arrays, can -- thus be implemented by computing the appropriate sequence of assignments -- and then applying it to the actual arrays. Max_Program_Length : constant := 3; type Any_Program_Index is new Integer range -1 .. Max_Program_Length - 1; subtype Program_Index is Any_Program_Index range 0 .. Any_Program_Index'Last; -- A sequence operation consists in at most three slice assignments type Operand_Reference is (Left, Right); -- The source of one assignment is either the left operand or the right -- operand of the operation. -- Description of an elementary operation: -- A slice of the result array is assigned from a slice of either operand; -- if the source slice is shorter than the target slice, it is replicated -- as necessary to fill the target slice. In that case, the length of the -- target slice must always be an integral multiple of the length of the -- source slice. type Assignment is record Source : Operand_Reference; Target_Bounds, Source_Bounds : Bounds; end record; type Assignment_Array is array (Program_Index) of Assignment; -- A program describes a sequence operation in terms of successive -- slice assignments. type Program is record Result_Length : Natural; -- Length of the resulting sequence Last : Any_Program_Index := -1; -- Index of last assignment in program (i.e. program length - 1) Assignments : Assignment_Array; -- Description of each slice assignments. Only items indexed -- 0 .. Program_Length - 1 are meaningful. end record; generic type Element is private; type Element_Array is array (Positive range <>) of Element; procedure Run (Prog : Program; Target : out Element_Array; Left : Element_Array; Right : Element_Array); -- Generic execution engine to be instantiated with appropriate element -- and element array types. -- For all functions below, Max_Length is the maximum length for the case -- of bounded sequences, or 0 for the case of unbounded sequences. The -- Left and Right indications designate what arguments should be assigned -- to the Left and Right operands when running the returned program. function Head_Tail (Max_Length : Natural; Source : Bounds; Count : Natural; Drop : Truncation := Error; What : Extremity; Suppress_Padding : Boolean := False) return Program; -- Get Head or Tail, depending on What. -- Left: Source -- Right: Padding element (bounds 1 .. 1) -- If Suppress_Padding is True, the operation to copy the provided -- padding value into the target sequence is not generated, and the -- Right operand will be ignored at execution. function Replace_Slice (Max_Length : Natural; Source : Bounds; Slice : Bounds; By : Bounds; Drop : Truncation := Error) return Program; -- Replace Slice in Source with By. -- Left: Source -- Right: By function Replicate (Max_Length : Natural; Count : Natural; Item : Bounds; Drop : Truncation := Error) return Program; -- Replicate Item Count times. -- Left: Item -- Right: unused type Check_Slice_Function is access function (Lo, Hi : Positive) return Boolean; -- Test for a given slice of a certain sequence against a certain property function Count_Index (Check_Slice : Check_Slice_Function; Source : Bounds; Pattern : Bounds; What : Search_Kind; Going : Direction := Forward) return Natural; -- Common subprogram used to implement Count and Index, depending on -- the What parameter. In both cases Check_Slice should return True if -- the indicated slice of the sequence being processed matches the -- desired pattern, whose bounds are indicated. end PolyORB.Sequences; polyorb-2.8~20110207.orig/src/polyorb-qos-service_contexts.ads0000644000175000017500000001201611750740340023535 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . Q O S . S E R V I C E _ C O N T E X T S -- -- -- -- S p e c -- -- -- -- Copyright (C) 2004-2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with PolyORB.Requests; with PolyORB.Representations.CDR.Common; with PolyORB.Types; with PolyORB.Utils.Chained_Lists; package PolyORB.QoS.Service_Contexts is subtype Service_Id is Types.Unsigned_Long; -- List of supported Service Contexts CodeSets : constant Service_Id; RTCorbaPriority : constant Service_Id; FTGroupVersion : constant Service_Id; FTRequest : constant Service_Id; SecurityAttributeService : constant Service_Id; AdaExceptionInformation : constant Service_Id; TMInfo : constant Service_Id; type Encapsulation_Access is access all PolyORB.Representations.CDR.Common.Encapsulation; type Service_Context is record Context_Id : Service_Id; Context_Data : Encapsulation_Access; end record; package Service_Context_Lists is new Utils.Chained_Lists (Service_Context, "=", True); type QoS_GIOP_Service_Contexts_Parameter is new QoS_Parameter (GIOP_Service_Contexts) with record Service_Contexts : Service_Context_Lists.List; end record; type QoS_GIOP_Service_Contexts_Parameter_Access is access all QoS_GIOP_Service_Contexts_Parameter'Class; procedure Release_Contents (QoS : access QoS_GIOP_Service_Contexts_Parameter); procedure Rebuild_Request_Service_Contexts (Req : in out Requests.Request); -- Reconstruct list of GIOP Service Contexts from the list of QoS -- Parameters. procedure Rebuild_Reply_Service_Contexts (Req : in out Requests.Request); -- Reconstruct list of GIOP Service Contexts from the list of QoS -- Parameters. procedure Rebuild_Request_QoS_Parameters (Req : in out Requests.Request); -- Reconstruct list of QoS Parameters from list of GIOP Service Contexts procedure Rebuild_Reply_QoS_Parameters (Req : in out Requests.Request); -- Reconstruct list of QoS Parameters from list of GIOP Service Contexts type To_Service_Context is access function (QoS : QoS_Parameter_Access) return Service_Context; type To_QoS_Parameter is access function (SC : Service_Context) return QoS_Parameter_Access; procedure Register (QoS : QoS_Kind; Converter : To_Service_Context); procedure Register (Id : Service_Id; Converter : To_QoS_Parameter); private use type Types.Unsigned_Long; -- Standard service tags CodeSets : constant Service_Id := 1; RTCorbaPriority : constant Service_Id := 10; FTGroupVersion : constant Service_Id := 12; FTRequest : constant Service_Id := 13; SecurityAttributeService : constant Service_Id := 15; -- PolyORB-specific service tags (see docs/OMG_TAGS) PolyORB_First : constant Service_Id := 16#504f0000#; -- "PO\x00\x00" AdaExceptionInformation : constant Service_Id := PolyORB_First + 0; TMInfo : constant Service_Id := PolyORB_First + 1; PolyORB_Last : constant Service_Id := 16#504f00ff#; -- "PO\x00\xff" end PolyORB.QoS.Service_Contexts; polyorb-2.8~20110207.orig/src/polyorb-tasking-threads-annotations.ads0000644000175000017500000000541111750740340024772 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . T A S K I N G . T H R E A D S . A N N O T A T I O N S -- -- -- -- S p e c -- -- -- -- Copyright (C) 2004 Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by ACT Europe. -- -- (email: sales@act-europe.fr) -- -- -- ------------------------------------------------------------------------------ -- This package provides mechanisms to attach a PolyORB's Notepad to -- a thread. with PolyORB.Annotations; package PolyORB.Tasking.Threads.Annotations is type Thread_Annotations_Factory is abstract tagged limited null record; type TAF_Access is access all Thread_Annotations_Factory'Class; procedure Register (TAF : TAF_Access); function Get_Current_Thread_Notepad (TAF : access Thread_Annotations_Factory) return PolyORB.Annotations.Notepad_Access is abstract; -- Return the annotation object associated with current thread. If no -- object associated with current thread, allocate new object. function Get_Current_Thread_Notepad return PolyORB.Annotations.Notepad_Access; end PolyORB.Tasking.Threads.Annotations; polyorb-2.8~20110207.orig/src/polyorb-tasking-profiles-ravenscar-condition_variables.ads0000644000175000017500000001115711750740340030632 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- POLYORB.TASKING.PROFILES.RAVENSCAR.CONDITION_VARIABLES -- -- -- -- S p e c -- -- -- -- Copyright (C) 2002-2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- Implementation of POSIX-like condition variables under the Ravenscar -- profile. For more details see PolyORB.Tasking.Condition_Variables with PolyORB.Initialization; with PolyORB.Tasking.Condition_Variables; with PolyORB.Tasking.Mutexes; with PolyORB.Tasking.Profiles.Ravenscar.Index_Manager; with PolyORB.Tasking.Profiles.Ravenscar.Threads; generic with package Threads_For_CV is new PolyORB.Tasking.Profiles.Ravenscar.Threads (<>); Number_Of_Conditions : Integer; package PolyORB.Tasking.Profiles.Ravenscar.Condition_Variables is use PolyORB.Tasking.Condition_Variables; use PolyORB.Tasking.Mutexes; type Ravenscar_Condition_Type is new Condition_Type with private; type Ravenscar_Condition_Access is access all Ravenscar_Condition_Type'Class; procedure Wait (Cond : access Ravenscar_Condition_Type; M : access Mutex_Type'Class); procedure Signal (Cond : access Ravenscar_Condition_Type); procedure Broadcast (Cond : access Ravenscar_Condition_Type); type Ravenscar_Condition_Factory_Type is new Condition_Factory_Type with private; type Ravenscar_Condition_Factory_Access is access all Ravenscar_Condition_Factory_Type'Class; The_Condition_Factory : constant Ravenscar_Condition_Factory_Access; function Create (MF : access Ravenscar_Condition_Factory_Type; Name : String := "") return Condition_Access; procedure Destroy (MF : access Ravenscar_Condition_Factory_Type; Cond : in out Condition_Access); private use Threads_For_CV; subtype Extended_Synchro_Index is Integer range Integer (Synchro_Index_Type'First) - 1 .. Integer (Synchro_Index_Type'Last); Null_Synchro_Index : constant Extended_Synchro_Index := Integer (Synchro_Index_Type'First) - 1; package Condition_Index_Manager is new PolyORB.Tasking.Profiles.Ravenscar.Index_Manager (Number_Of_Conditions); subtype Condition_Index_Type is Condition_Index_Manager.Index_Type; type Ravenscar_Condition_Type is new Condition_Type with record Id : Condition_Index_Type; -- Rank of the protected object used by this condition variable in the -- preallocated array. end record; type Ravenscar_Condition_Factory_Type is new Condition_Factory_Type with null record; The_Condition_Factory : constant Ravenscar_Condition_Factory_Access := new Ravenscar_Condition_Factory_Type; procedure Initialize; -- Initialize the package Initializer : constant PolyORB.Initialization.Initializer := Initialize'Access; end PolyORB.Tasking.Profiles.Ravenscar.Condition_Variables; polyorb-2.8~20110207.orig/src/srp/0000755000175000017500000000000011750740340015775 5ustar xavierxavierpolyorb-2.8~20110207.orig/src/srp/polyorb-representations-srp.ads0000644000175000017500000002012111750740340024175 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . R E P R E S E N T A T I O N S . S R P -- -- -- -- S p e c -- -- -- -- Copyright (C) 2002-2008, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- A representation for our own Simple Request Protocol (SRP). with Ada.Streams; with PolyORB.Any; with PolyORB.Buffers; with PolyORB.Types; with PolyORB.Utils.SRP; package PolyORB.Representations.SRP is pragma Elaborate_Body; use Ada.Streams; use PolyORB.Any; use PolyORB.Buffers; use PolyORB.Types; use PolyORB.Utils.SRP; type Rep_SRP is new Representation with private; type Rep_SRP_Access is access all Rep_SRP; ------------------------------------------ -- Part taken from AWS (Ada Web Server) -- ------------------------------------------ function Decode_URL (Str : String) return String; -- The translations are: -- + should be changed to a space -- %xy should be replaced by the character whose code is xy function Base64_Encode (Data : Ada.Streams.Stream_Element_Array) return String; -- Encode Data using the base64 algorithm function Base64_Encode (Data : String) return String; -- Same as above but takes a string as input function Base64_Decode (B64_Data : String) return Ada.Streams.Stream_Element_Array; -- Decode B64_Data using the base64 algorithm function Encode_URL (SRP_Info : Split_SRP) return Types.String; -- Only encodes the parameters' values -- Is less error prone than the previous function procedure Encode_URL (SRP_Info : in out Split_SRP); -- Encodes the entire string function Encode_String (Str : String; Also_Escape : String := "/") return String; ------------------- -- UNMARSHALLING -- ------------------- procedure Unmarshall (Buffer : access Buffer_Type; NV : in out NamedValue); function Unmarshall (Buffer : access Buffer_Type) return PolyORB.Types.Boolean; function Unmarshall (Buffer : access Buffer_Type) return PolyORB.Types.Octet; function Unmarshall (Buffer : access Buffer_Type) return PolyORB.Types.Char; function Unmarshall (Buffer : access Buffer_Type) return PolyORB.Types.Unsigned_Short; function Unmarshall (Buffer : access Buffer_Type) return PolyORB.Types.Unsigned_Long; function Unmarshall (Buffer : access Buffer_Type) return PolyORB.Types.Short; function Unmarshall (Buffer : access Buffer_Type) return PolyORB.Types.Long; function Unmarshall (Buffer : access Buffer_Type) return Stream_Element_Array; function Unmarshall (Buffer : access Buffer_Type) return Standard.String; -- function Unmarshall (Buffer : access Buffer_Type) -- return Types.String; function Unmarshall (Buffer : access Buffer_Type) return Types.String; function Unmarshall (Buffer : access Buffer_Type) return PolyORB.Any.TypeCode.Local_Ref; function Unmarshall (Buffer : access Buffer_Type) return PolyORB.Any.Any; ----------------- -- MARSHALLING -- ----------------- procedure Marshall (Buffer : access Buffer_Type; Info_SRP : Split_SRP); procedure Marshall (Buffer : access Buffer_Type; Data : PolyORB.Types.Boolean); procedure Marshall (Buffer : access Buffer_Type; Data : PolyORB.Types.Char); procedure Marshall (Buffer : access Buffer_Type; Data : PolyORB.Types.Octet); procedure Marshall (Buffer : access Buffer_Type; Data : PolyORB.Types.Unsigned_Short); procedure Marshall (Buffer : access Buffer_Type; Data : PolyORB.Types.Unsigned_Long); procedure Marshall (Buffer : access Buffer_Type; Data : PolyORB.Types.Short); procedure Marshall (Buffer : access Buffer_Type; Data : PolyORB.Types.Long); procedure Marshall (Buffer : access Buffer_Type; Data : Standard.String); procedure Marshall (Buffer : access Buffer_Type; Data : PolyORB.Types.String); procedure Marshall (Buffer : access Buffer_Type; Data : Stream_Element_Array); procedure Marshall (Buffer : access Buffer_Type; Data : PolyORB.Any.Any); procedure Marshall (Buffer : access Buffer_Type; Data : PolyORB.Any.TypeCode.Local_Ref); procedure Marshall_From_Any (R : access Rep_SRP; Buffer : access Buffers.Buffer_Type; Data : Any.Any_Container'Class; Error : in out Errors.Error_Container); procedure Marshall_From_Any (Buffer : access Buffer_Type; Data : PolyORB.Any.Any_Container'Class); procedure Unmarshall_To_Any (R : access Rep_SRP; Buffer : access Buffers.Buffer_Type; Data : in out Any.Any_Container'Class; Error : in out Errors.Error_Container); procedure Unmarshall_To_Any (Buffer : access Buffer_Type; Result : in out PolyORB.Any.Any_Container'Class); -- The following methods are specific to Rep_SRP and are -- here only to facilitate testing of other parts of the ORB. procedure Marshall_Char (B : access Buffer_Type; C : Character); -- Marshall one character. function Unmarshall_Char (B : access Buffer_Type) return Character; -- Unmarshall one character. procedure Marshall_String (R : access Rep_SRP; B : access Buffer_Type; S : String); -- Marshall a string. function Unmarshall_String (R : Rep_SRP; B : access Buffer_Type) return String; -- Unmarshall a string terminated by a CR/LF sequence. function Unmarshall_To_Any (R : access Rep_SRP; Buffer : access Buffers.Buffer_Type) return Any.Any; -- Temporary procedure. Should be replaces by Marshall_From_Any when -- we will be able to [un]marshall Split_SRP [from] to Any procedure Marshall_From_Split_SRP (R : Rep_SRP; Buffer : access Buffers.Buffer_Type; SRP_Info : Split_SRP); private type Rep_SRP is new Representation with null record; end PolyORB.Representations.SRP; polyorb-2.8~20110207.orig/src/srp/polyorb-protocols-srp.adb0000644000175000017500000003421611750740340022765 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . P R O T O C O L S . S R P -- -- -- -- B o d y -- -- -- -- Copyright (C) 2002-2009, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with Ada.Streams; use Ada.Streams; with PolyORB.Binding_Data.Local; with PolyORB.Filters; with PolyORB.Filters.Iface; with PolyORB.Log; with PolyORB.Obj_Adapters; with PolyORB.ORB; with PolyORB.ORB.Iface; with PolyORB.References; with PolyORB.Requests; with PolyORB.Representations.SRP; with PolyORB.Smart_Pointers; with PolyORB.Utils; package body PolyORB.Protocols.SRP is use PolyORB.Any; use PolyORB.Components; use PolyORB.Filters.Iface; use PolyORB.Log; use PolyORB.ORB; use PolyORB.ORB.Iface; use PolyORB.Representations.SRP; use PolyORB.Types; package L is new PolyORB.Log.Facility_Log ("polyorb.protocols.srp"); procedure O (Message : String; Level : Log_Level := Debug) renames L.Output; function C (Level : Log_Level := Debug) return Boolean renames L.Enabled; Rep : constant Rep_SRP_Access := new Rep_SRP; ------------ -- Create -- ------------ procedure Create (Proto : access SRP_Protocol; Session : out Filter_Access) is begin pragma Warnings (Off); pragma Unreferenced (Proto); pragma Warnings (On); -- This should be factored in PolyORB.Protocols. Session := new SRP_Session; SRP_Session (Session.all).Buffer_In := new Buffers.Buffer_Type; SRP_Session (Session.all).Buffer_Out := new Buffers.Buffer_Type; end Create; ------------- -- Connect -- ------------- procedure Connect (S : access SRP_Session) is begin pragma Warnings (Off); pragma Unreferenced (S); pragma Warnings (On); null; end Connect; -------------------- -- Invoke_Request -- -------------------- procedure Invoke_Request (S : access SRP_Session; R : Requests.Request_Access; P : access Binding_Data.Profile_Type'Class) is begin pragma Warnings (Off); pragma Unreferenced (S); pragma Unreferenced (R); pragma Unreferenced (P); pragma Warnings (On); null; end Invoke_Request; ------------------- -- Abort_Request -- ------------------- procedure Abort_Request (S : access SRP_Session; R : Requests.Request_Access) is begin pragma Warnings (Off); pragma Unreferenced (S); pragma Unreferenced (R); pragma Warnings (On); null; end Abort_Request; ------------------ -- Handle_Flush -- ------------------ procedure Handle_Flush (S : access SRP_Session) is pragma Unreferenced (S); begin raise Program_Error; end Handle_Flush; ---------------------- -- Request_Received -- ---------------------- procedure Request_Received (S : access SRP_Session); procedure Request_Received (S : access SRP_Session) is use Binding_Data.Local; use PolyORB.Obj_Adapters; -- used to store the arg list needed by the method called Args : Any.NVList.Ref; Result : Any.NamedValue; Deferred_Arguments_Session : Component_Access; ORB : constant ORB_Access := ORB_Access (S.Server); Request_String : String_Ptr; Req : Request_Access; Target_Profile : constant Binding_Data.Profile_Access := new Local_Profile_Type; Target : References.Ref; begin -- Get the entire request string Request_String := new Types.String'(Unmarshall (S.Buffer_In)); -- Split the string in its different parts and store them in -- a Split_SRP record S.SRP_Info := Split (Request_String.all); -- Get the arg profile needed by the method called Args := Obj_Adapters.Get_Empty_Arg_List (Object_Adapter (ORB), S.SRP_Info.Oid, To_Standard_String (S.SRP_Info.Method.all)); if not PolyORB.Smart_Pointers.Is_Nil (PolyORB.Smart_Pointers.Ref (Args)) then -- The signature of the method is known: unmarshall -- the arguments right now. Unmarshall (Args, S.SRP_Info); else -- Unable to obtain the list of arguments at this point. -- Defer the unmarshalling until the Servant has a chance -- to provide its own arg list. Deferred_Arguments_Session := Components.Component_Access (S); end if; -- Get the result profile for the method called and create an -- appropriate Any.NamedValue for the result -- Result := (Name => To_PolyORB_String ("Result"), -- Argument => Obj_Adapters.Get_Empty_Result -- (Object_Adapter (ORB), SRP_Info.Oid, -- To_Standard_String (SRP_Info.Method.all)), -- Arg_Modes => 0); -- Create a local profile for the request. Indeed, the request isnnow -- local Create_Local_Profile (S.SRP_Info.Oid.all, Local_Profile_Type (Target_Profile.all)); References.Create_Reference ((1 => Target_Profile), "", Target); -- Create a Request Create_Request (Target => Target, Operation => To_Standard_String (S.SRP_Info.Method.all), Arg_List => Args, Result => Result, Deferred_Arguments_Session => Deferred_Arguments_Session, Req => Req, Dependent_Binding_Object => Smart_Pointers.Entity_Ptr (S.Dependent_Binding_Object)); -- Queue the request for execution Queue_Request_To_Handler (ORB, Queue_Request' (Request => Req, Requestor => Component_Access (S))); end Request_Received; ---------------- -- Send_Reply -- ---------------- procedure Send_Reply (S : access SRP_Session; R : Request_Access) is SRP_Info : Split_SRP; B : Buffer_Access renames S.Buffer_Out; begin Release_Contents (B.all); Set_SRP_Method (To_PolyORB_String ("Reply"), SRP_Info); Set_SRP_Oid (Object_Id'(1 .. 4 => 0), SRP_Info); Set_SRP_Arg (To_PolyORB_String ("Data"), To_Any (To_PolyORB_String ("200 OK" & Image (R.all) & " " & PolyORB.Any.Image (R.Result))), SRP_Info); -- Data := Join (SRP_Info); -- XXX Before using this procedure, we must be able to -- [un]marshall Split_SRP [from] to Any -- Marshall_From_Any (Rep.all, B, Data); Marshall_From_Split_SRP (Rep.all, B, SRP_Info); Emit_No_Reply (Lower (S), Data_Out'(Out_Buf => B)); end Send_Reply; ------------------------------- -- Handle_Connect_Indication -- ------------------------------- procedure Handle_Connect_Indication (S : access SRP_Session) is begin pragma Debug (C, O ("Received new connection to SRP service...")); -- 1. Send greetings to client. -- Send_String ("Hello, please type data." & ASCII.LF); -- 2. Notify transport layer that more data is expected. Expect_Data (S, S.Buffer_In, 1024); -- Exact => False -- Note that there is no race condition here. One might -- expect the following unfortunate sequence of events: -- 10. Greetings sent to client -- 11. Client answers -- 20. Expect_Data -- (in 11: transport gets unexpected data). -- This does not actually happen because the TE is not -- being monitored while Send_Greetings and Expect_Data -- are done; it becomes monitored again /after/ the -- Connect_Indication has been processed. -- -- The same goes for the handling of a Data_Indication. end Handle_Connect_Indication; --------------------------------- -- Handle_Connect_Confirmation -- --------------------------------- procedure Handle_Connect_Confirmation (S : access SRP_Session) is begin pragma Warnings (Off); pragma Unreferenced (S); pragma Warnings (On); null; -- No setup is necessary for newly-created client connections. end Handle_Connect_Confirmation; ---------------------------- -- Handle_Data_Indication -- ---------------------------- procedure Handle_Data_Indication (S : access SRP_Session; Data_Amount : Stream_Element_Count; Error : in out Errors.Error_Container) is begin pragma Warnings (Off); pragma Unreferenced (Data_Amount, Error); pragma Warnings (On); pragma Debug (C, O ("Received data on SRP service...")); pragma Debug (Buffers.Show (S.Buffer_In)); Request_Received (S); Buffers.Release_Contents (S.Buffer_In.all); -- Clean up Expect_Data (S, S.Buffer_In, 1024); -- XXX DUMMY size end Handle_Data_Indication; ----------------------- -- Handle_Disconnect -- ----------------------- procedure Handle_Disconnect (S : access SRP_Session; Error : Errors.Error_Container) is pragma Unreferenced (Error); begin pragma Debug (C, O ("Received disconnect.")); -- Cleanup protocol Buffers.Release (S.Buffer_In); end Handle_Disconnect; --------------------------------- -- Handle_Unmarshall_Arguments -- --------------------------------- procedure Handle_Unmarshall_Arguments (Ses : access SRP_Session; Args : in out Any.NVList.Ref; Error : in out Errors.Error_Container) is pragma Unreferenced (Error); begin Unmarshall (Args, Ses.SRP_Info); end Handle_Unmarshall_Arguments; -------------------------------- -- Unmarshall_Request_Message -- -------------------------------- procedure Unmarshall_Request_Message (Buffer : access Buffer_Type; Oid : access Object_Id; Method : access Types.String) is begin Method.all := Unmarshall (Buffer); declare Obj : constant Stream_Element_Array := Unmarshall (Buffer); begin Oid.all := Object_Id (Obj); end; end Unmarshall_Request_Message; --------------------- -- Unmarshall_Args -- --------------------- procedure Unmarshall_Args (Buffer : access Buffer_Type; Args : in out Any.NVList.Ref) is use PolyORB.Any.NVList; use PolyORB.Any.NVList.Internals; use PolyORB.Any.NVList.Internals.NV_Lists; It : Iterator := First (List_Of (Args).all); begin -- By modifing Args_list, we modify directly Args while not Last (It) loop Unmarshall (Buffer, Value (It).all); Next (It); end loop; end Unmarshall_Args; ---------------- -- Unmarshall -- ---------------- procedure Unmarshall (Args : in out Any.NVList.Ref; SRP_Info : Split_SRP) is use PolyORB.Any.NVList; use PolyORB.Any.NVList.Internals; use PolyORB.Any.NVList.Internals.NV_Lists; use PolyORB.Utils; function To_SEA (S : Types.String) return Stream_Element_Array; function To_SEA (S : Types.String) return Stream_Element_Array is Temp_S : constant Standard.String := To_Standard_String (S); Value : Stream_Element_Array (1 .. Temp_S'Length); begin for I in Value'Range loop Value (I) := Stream_Element (Character'Pos (Temp_S (Temp_S'First + Integer (I - Value'First)))); end loop; return Value; end To_SEA; It : Iterator := First (List_Of (Args).all); Current_Arg : Arg_Info_Ptr := SRP_Info.Args; Temp_Arg : Element_Access; Temp_Buffer : aliased Buffer_Type; -- XXX BAD BAD buffer allocated on the stack begin while not Last (It) loop Temp_Arg := Value (It); declare Value : aliased Stream_Element_Array := To_SEA (Current_Arg.all.Value.all & ASCII.NUL); begin Initialize_Buffer (Buffer => Temp_Buffer'Access, Size => Value'Length, Data => Value (Value'First)'Address, Endianness => Little_Endian, Initial_CDR_Position => 0); Show (Temp_Buffer'Access); Unmarshall (Temp_Buffer'Access, Temp_Arg.all); end; Next (It); Current_Arg := Current_Arg.all.Next; end loop; end Unmarshall; end PolyORB.Protocols.SRP; polyorb-2.8~20110207.orig/src/srp/polyorb-setup-access_points-srp.adb0000644000175000017500000001007511750740340024731 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . S E T U P . A C C E S S _ P O I N T S . S R P -- -- -- -- B o d y -- -- -- -- Copyright (C) 2003-2007, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- Setup for SRP access point. with PolyORB.Binding_Data.SRP; with PolyORB.Protocols.SRP; with PolyORB.Filters; with PolyORB.Initialization; with PolyORB.ORB; with PolyORB.Parameters; with PolyORB.Protocols; with PolyORB.Sockets; with PolyORB.Transport.Connected.Sockets; with PolyORB.Utils.Strings; with PolyORB.Utils.TCP_Access_Points; package body PolyORB.Setup.Access_Points.SRP is use PolyORB.Filters; use PolyORB.ORB; use PolyORB.Sockets; use PolyORB.Transport.Connected.Sockets; use PolyORB.Utils.TCP_Access_Points; -- The 'SRP' access point. SRP_Access_Point : Access_Point_Info := (Socket => No_Socket, Address => No_Sock_Addr, SAP => new Socket_Access_Point, PF => new Binding_Data.SRP.SRP_Profile_Factory); SRP_Protocol : aliased Protocols.SRP.SRP_Protocol; SRP_Factories : aliased Filters.Factory_Array := (0 => SRP_Protocol'Access); ------------------------------ -- Initialize_Access_Points -- ------------------------------ procedure Initialize_Access_Points; procedure Initialize_Access_Points is use PolyORB.Parameters; begin if Get_Conf ("access_points", "srp", True) then Initialize_Socket (SRP_Access_Point, Any_Inet_Addr, (Any_Port, Any_Port)); Register_Access_Point (ORB => The_ORB, TAP => SRP_Access_Point.SAP, Chain => SRP_Factories'Access, PF => SRP_Access_Point.PF); -- Register socket with ORB object, associating a protocol -- to the transport service access point. end if; end Initialize_Access_Points; use PolyORB.Initialization; use PolyORB.Initialization.String_Lists; use PolyORB.Utils.Strings; begin Register_Module (Module_Info' (Name => +"access_points.srp", Conflicts => Empty, Depends => +"orb", Provides => +"access_points", Implicit => False, Init => Initialize_Access_Points'Access, Shutdown => null)); end PolyORB.Setup.Access_Points.SRP; polyorb-2.8~20110207.orig/src/srp/polyorb-setup-access_points-srp.ads0000644000175000017500000000422611750740340024753 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . S E T U P . A C C E S S _ P O I N T S . S R P -- -- -- -- S p e c -- -- -- -- Copyright (C) 2003 Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by ACT Europe. -- -- (email: sales@act-europe.fr) -- -- -- ------------------------------------------------------------------------------ -- Set up SRP TCP Access points. package PolyORB.Setup.Access_Points.SRP is pragma Elaborate_Body; end PolyORB.Setup.Access_Points.SRP; polyorb-2.8~20110207.orig/src/srp/polyorb-binding_data-srp.ads0000644000175000017500000000757311750740340023373 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . B I N D I N G _ D A T A . S R P -- -- -- -- S p e c -- -- -- -- Copyright (C) 2002-2011, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- Binding data for the Simple Request Protocol over TCP with PolyORB.Utils.Sockets; package PolyORB.Binding_Data.SRP is pragma Elaborate_Body; type SRP_Profile_Type is new Profile_Type with private; procedure Duplicate (P1 : SRP_Profile_Type; P2 : out SRP_Profile_Type); procedure Release (P : in out SRP_Profile_Type); procedure Bind_Profile (Profile : access SRP_Profile_Type; The_ORB : Components.Component_Access; QoS : PolyORB.QoS.QoS_Parameters; BO_Ref : out Smart_Pointers.Ref; Error : out Errors.Error_Container); function Get_Profile_Tag (Profile : SRP_Profile_Type) return Profile_Tag; pragma Inline (Get_Profile_Tag); function Get_Profile_Preference (Profile : SRP_Profile_Type) return Profile_Preference; pragma Inline (Get_Profile_Preference); type SRP_Profile_Factory is new Profile_Factory with private; procedure Create_Factory (PF : out SRP_Profile_Factory; TAP : Transport.Transport_Access_Point_Access; ORB : Components.Component_Access); function Create_Profile (PF : access SRP_Profile_Factory; Oid : Objects.Object_Id) return Profile_Access; function Duplicate_Profile (P : SRP_Profile_Type) return Profile_Access; function Is_Local_Profile (PF : access SRP_Profile_Factory; P : access Profile_Type'Class) return Boolean; function Image (Prof : SRP_Profile_Type) return String; function Is_Colocated (Left : SRP_Profile_Type; Right : Profile_Type'Class) return Boolean; private type SRP_Profile_Type is new Profile_Type with record Address : Utils.Sockets.Socket_Name_Ptr; end record; type SRP_Profile_Factory is new Profile_Factory with record Address : Utils.Sockets.Socket_Name_Ptr; end record; end PolyORB.Binding_Data.SRP; polyorb-2.8~20110207.orig/src/srp/polyorb-utils-srp.adb0000644000175000017500000001561311750740340022101 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . U T I L S . S R P -- -- -- -- B o d y -- -- -- -- Copyright (C) 2002-2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- Utilities for the Simple Request Protocol. with GNAT.Regpat; package body PolyORB.Utils.SRP is use PolyORB.Any; -------------------- -- Set_SRP_Method -- -------------------- procedure Set_SRP_Method (Method : Types.String; SRP_Info : in out Split_SRP) is begin SRP_Info.Method := new Types.String'(Method); end Set_SRP_Method; ----------------- -- Set_SRP_Oid -- ----------------- procedure Set_SRP_Oid (Oid : Object_Id; SRP_Info : in out Split_SRP) is begin SRP_Info.Oid := new Object_Id'(Oid); end Set_SRP_Oid; ----------------- -- Set_SRP_Arg -- ----------------- procedure Set_SRP_Arg (Name : Types.String; Value : Any.Any; SRP_Info : in out Split_SRP) is Current_Arg : Arg_Info_Ptr := SRP_Info.Args; begin if Current_Arg /= null then while Current_Arg.all.Next /= null loop Current_Arg := Current_Arg.all.Next; end loop; -- ??? revoir la maniere d'obtenir Value Current_Arg.all.Next := new Arg_Info'(new Types.String'(Name), new Types.String'(From_Any (Value)), null); else SRP_Info.Args := new Arg_Info'(new Types.String'(Name), new Types.String'(From_Any (Value)), null); end if; end Set_SRP_Arg; ----------- -- Split -- ----------- function Split (S : Types.String) return Split_SRP is use GNAT.Regpat; Result : Split_SRP; Args : constant Arg_Info_Ptr := new Arg_Info; Current : Arg_Info_Ptr := Args; Last : Arg_Info_Ptr; Matches : Match_Array (1 .. 255); Regexp_Req_OID : constant Standard.String := "(\w+) (\w+)\?(.*)"; Regexp_Args : constant Standard.String := "(\w+)=(\w+)&?(.*)"; Args_Ptr : Types.String_Ptr; begin Match (Compile (Regexp_Req_OID), To_Standard_String (S), Matches); -- Stores the name of the function/procedure called Result.Method := new Types.String'(To_PolyORB_String (Slice (S, Matches (1).First, Matches (1).Last))); -- Stores the Object Id Result.Oid := new Object_Id'(Hex_String_To_Oid (String'(To_Standard_String (S) (Matches (2).First .. Matches (2).Last)))); -- Stores the last string containing the arguments Args_Ptr := new Types.String'(To_PolyORB_String (Slice (S, Matches (3).First, Matches (3).Last))); pragma Warnings (Off, Args_Ptr); -- We want Args_Ptr to be able to be null -- ??? Could be optimized while Args_Ptr.all /= "" loop Match (Compile (Regexp_Args), To_Standard_String (Args_Ptr.all), Matches); Current.Name := new Types.String'(To_PolyORB_String (Slice (Args_Ptr.all, Matches (1).First, Matches (1).Last))); Current.Value := new Types.String'(To_PolyORB_String (Slice (Args_Ptr.all, Matches (2).First, Matches (2).Last))); -- Create a new String with the remaining arguments Args_Ptr := new Types.String'(To_PolyORB_String (Slice (Args_Ptr.all, Matches (3).First, Matches (3).Last))); Current.Next := new Arg_Info; Last := Current; Current := Current.Next; end loop; Last.Next := null; -- Destroy the last record (is empty) Free_Arg_Info (Current); Result.Args := Args; return Result; end Split; ---------- -- Join -- ---------- function Join (Data : Split_SRP) return Any.Any is URL : Types.String; -- Current_Arg : Arg_Info_Ptr := Data.Args; begin Append (URL, Data.Method.all & " " & Oid_To_Hex_String (Data.Oid.all) & "?"); raise Program_Error; -- while Current_Arg /= null loop -- Append (URL, Current_Arg.all.Name.all & "=" & -- Current_Arg.all.Value.all); -- if Current_Arg.all.Next /= null then -- Append (URL, "&"); -- end if; -- Current_Arg := Current_Arg.Next; -- end loop; return Any.To_Any (Types.To_PolyORB_String (To_String (URL))); end Join; end PolyORB.Utils.SRP; polyorb-2.8~20110207.orig/src/srp/polyorb-utils-srp.ads0000644000175000017500000000742111750740340022120 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . U T I L S . S R P -- -- -- -- S p e c -- -- -- -- Copyright (C) 2002 Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by ACT Europe. -- -- (email: sales@act-europe.fr) -- -- -- ------------------------------------------------------------------------------ -- Utilities for the Simple Request Protocol. with Ada.Unchecked_Deallocation; with PolyORB.Any; with PolyORB.Objects; use PolyORB.Objects; with PolyORB.Types; use PolyORB.Types; package PolyORB.Utils.SRP is pragma Elaborate_Body; Unmarshall_Error : exception; Deprecated : exception; -- Record use to store the URL when it is splitted type Arg_Info; type Arg_Info_Ptr is access Arg_Info; type Arg_Info is record Name : String_Ptr; Value : String_Ptr; -- Value : Any.Any; Next : Arg_Info_Ptr := null; end record; -- XXX should be reimplemented in terms of -- PolyORB.Utils.Chained_Lists. -- Record use to store the URL when it is splitted type Split_SRP is record Method : String_Ptr; Oid : Object_Id_Access; Args : Arg_Info_Ptr; end record; -- Set the Method in the SRP information structure procedure Set_SRP_Method (Method : Types.String; SRP_Info : in out Split_SRP); -- Set the Object Id in the SRP information structure procedure Set_SRP_Oid (Oid : Object_Id; SRP_Info : in out Split_SRP); -- Set an argument in the SRP information structure procedure Set_SRP_Arg (Name : Types.String; Value : Any.Any; SRP_Info : in out Split_SRP); -- Split the incoming string in according to the SRP protocol function Split (S : Types.String) return Split_SRP; -- Same as above, but takes an Any.Any as an input parameter -- function Split (Data : Any.Any) return Split_SRP; -- Does just the reverse of Split function Join (Data : Split_SRP) return Any.Any; procedure Free_Arg_Info is new Ada.Unchecked_Deallocation (Arg_Info, Arg_Info_Ptr); end PolyORB.Utils.SRP; polyorb-2.8~20110207.orig/src/srp/polyorb-protocols-srp.ads0000644000175000017500000001226511750740340023006 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . P R O T O C O L S . S R P -- -- -- -- S p e c -- -- -- -- Copyright (C) 2002-2007, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- A protocol similar to the HTTP protocol -- SRP : Simple Request Protocol (from M. Friess report) -- SRP is inspired by HTTP. A SRP request has the following form : -- method object_Id?arg1=val1&arg2=val2 -- -- The following rules apply : -- Argument name is not significant, only the order is. -- -- Following types can be marshalled and unmarshalled : -- byte, boolean, short, long, unsigned short, unsigned long with PolyORB.Any; with PolyORB.Any.NVList; with PolyORB.Buffers; with PolyORB.Objects; with PolyORB.Types; with PolyORB.Utils.SRP; package PolyORB.Protocols.SRP is pragma Elaborate_Body; use PolyORB.Buffers; use PolyORB.Objects; use PolyORB.Utils.SRP; SRP_Error : exception; type SRP_Protocol is new Protocol with private; -- Message types that can be used with SRP type Msg_Type is (Req, Reply); type Reply_Status_Type is (Ack, Error); type SRP_Session is new Session with private; procedure Create (Proto : access SRP_Protocol; Session : out Filter_Access); procedure Connect (S : access SRP_Session); -- Do nothing. procedure Invoke_Request (S : access SRP_Session; R : Request_Access; P : access Binding_Data.Profile_Type'Class); -- Do nothing. procedure Abort_Request (S : access SRP_Session; R : Request_Access); -- Do nothing. procedure Send_Reply (S : access SRP_Session; R : Request_Access); -- Send a reply to the user. procedure Handle_Connect_Indication (S : access SRP_Session); -- Send a greeting banner to user. procedure Handle_Connect_Confirmation (S : access SRP_Session); -- Setup client dialog. procedure Handle_Data_Indication (S : access SRP_Session; Data_Amount : Ada.Streams.Stream_Element_Count; Error : in out Errors.Error_Container); -- Handle data received from user procedure Handle_Disconnect (S : access SRP_Session; Error : Errors.Error_Container); -- Handle disconnection from user procedure Handle_Unmarshall_Arguments (Ses : access SRP_Session; Args : in out Any.NVList.Ref; Error : in out Errors.Error_Container); procedure Handle_Flush (S : access SRP_Session); procedure Unmarshall_Request_Message (Buffer : access Buffer_Type; Oid : access Object_Id; Method : access Types.String); -- Get from the buffer the Object_Id and the Method to be called procedure Unmarshall_Args (Buffer : access Buffer_Type; Args : in out Any.NVList.Ref); -- Unmarshall the arguments from Buffer in Args -- Args must be an arg list with empty any(s), but with their type set procedure Unmarshall (Args : in out Any.NVList.Ref; SRP_Info : Split_SRP); -- Get the values stored in Info_SRP and unmarshall them in Args -- Attention: Args already should contain the types -- (cf. Obj_Adapters.Get_Empty_Arg_List) private type SRP_Protocol is new Protocol with null record; type SRP_Session is new Session with record Buffer_In : Buffers.Buffer_Access; Buffer_Out : Buffers.Buffer_Access; SRP_Info : Split_SRP; end record; end PolyORB.Protocols.SRP; polyorb-2.8~20110207.orig/src/srp/polyorb-representations-srp.adb0000644000175000017500000025117511750740340024173 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . R E P R E S E N T A T I O N S . S R P -- -- -- -- B o d y -- -- -- -- Copyright (C) 2002-2009, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with Ada.Strings.Unbounded; with Ada.Unchecked_Conversion; with PolyORB.Log; with PolyORB.Objects; with PolyORB.Representations.CDR.Common; -- ??? reusing elementary types' marshalling/unmarshalling functions with PolyORB.Utils; with PolyORB.Utils.Buffers; use PolyORB.Utils.Buffers; with Interfaces; package body PolyORB.Representations.SRP is use Ada; use Ada.Strings.Unbounded; use PolyORB.Log; package L is new PolyORB.Log.Facility_Log ("polyorb.representations.srp"); procedure O (Message : String; Level : Log_Level := Debug) renames L.Output; function C (Level : Log_Level := Debug) return Boolean renames L.Enabled; ---------------- -- Decode_URL -- ---------------- function Decode_URL (Str : String) return String renames PolyORB.Utils.URI_Decode; ------------------------------------------ -- Part taken from AWS (Ada Web Server) -- ------------------------------------------ ------------------- -- Base64_Encode -- ------------------- function Base64_Encode (Data : Streams.Stream_Element_Array) return String is function Base64 (E : Stream_Element) return Character; -- returns the base64 character given a number function Shift_Left (Value : Stream_Element; Amount : Natural) return Stream_Element; function Shift_Right (Value : Stream_Element; Amount : Natural) return Stream_Element; pragma Inline (Shift_Left); pragma Inline (Shift_Right); function Shift_Left (Value : Stream_Element; Amount : Natural) return Stream_Element is begin return Stream_Element (Interfaces.Shift_Left (Interfaces.Unsigned_8 (Value), Amount)); end Shift_Left; function Shift_Right (Value : Stream_Element; Amount : Natural) return Stream_Element is begin return Stream_Element (Interfaces.Shift_Right (Interfaces.Unsigned_8 (Value), Amount)); end Shift_Right; Result : Unbounded_String; Length : Natural := 0; State : Positive range 1 .. 3 := 1; E, Old : Stream_Element := 0; function Base64 (E : Stream_Element) return Character is V : constant Natural := Natural (E); begin case V is when 0 .. 25 => return Character'Val (V + Character'Pos ('A')); when 26 .. 51 => return Character'Val (V - 26 + Character'Pos ('a')); when 52 .. 61 => return Character'Val (V - 52 + Character'Pos ('0')); when 62 => return '+'; when others => return '/'; end case; end Base64; begin for C in Data'Range loop E := Data (C); case State is when 1 => Append (Result, Base64 (Shift_Right (E, 2) and 16#3F#)); State := 2; when 2 => Append (Result, Base64 ((Shift_Left (Old, 4) and 16#30#) or (Shift_Right (E, 4) and 16#F#))); State := 3; when 3 => Append (Result, Base64 ((Shift_Left (Old, 2) and 16#3C#) or (Shift_Right (E, 6) and 16#3#))); Append (Result, Base64 (E and 16#3F#)); State := 1; end case; Old := E; Length := Length + 1; if Length >= 72 then Append (Result, ASCII.LF); Length := 0; end if; end loop; case State is when 1 => null; when 2 => Append (Result, Base64 (Shift_Left (Old, 4) and 16#30#) & "=="); when 3 => Append (Result, Base64 (Shift_Left (Old, 2) and 16#3C#) & '='); end case; return To_String (Result); end Base64_Encode; function Base64_Encode (Data : String) return String is Stream_Data : Streams.Stream_Element_Array (1 .. Streams.Stream_Element_Offset (Data'Length)); I : Streams.Stream_Element_Offset := 1; begin for K in Data'Range loop Stream_Data (I) := Character'Pos (Data (K)); I := I + 1; end loop; return Base64_Encode (Stream_Data); end Base64_Encode; ------------------- -- Base64_Decode -- ------------------- function Base64_Decode (B64_Data : String) return Streams.Stream_Element_Array is use type Interfaces.Unsigned_32; function Base64 (C : Character) return Interfaces.Unsigned_32; -- returns the base64 stream element given a character function Shift_Left (Value : Interfaces.Unsigned_32; Amount : Natural) return Interfaces.Unsigned_32 renames Interfaces.Shift_Left; function Shift_Right (Value : Interfaces.Unsigned_32; Amount : Natural) return Interfaces.Unsigned_32 renames Interfaces.Shift_Right; Result : Stream_Element_Array (Stream_Element_Offset range 1 .. B64_Data'Length); R : Stream_Element_Offset := 1; Group : Interfaces.Unsigned_32 := 0; J : Integer := 18; Pad : Stream_Element_Offset := 0; function Base64 (C : Character) return Interfaces.Unsigned_32 is begin if C in 'A' .. 'Z' then return Character'Pos (C) - Character'Pos ('A'); elsif C in 'a' .. 'z' then return Character'Pos (C) - Character'Pos ('a') + 26; elsif C in '0' .. '9' then return Character'Pos (C) - Character'Pos ('0') + 52; elsif C = '+' then return 62; else return 63; end if; end Base64; begin for C in B64_Data'Range loop if B64_Data (C) = ASCII.LF or else B64_Data (C) = ASCII.CR then null; else case B64_Data (C) is when '=' => Pad := Pad + 1; when others => Group := Group or Shift_Left (Base64 (B64_Data (C)), J); end case; J := J - 6; if J < 0 then Result (R .. R + 2) := (Stream_Element (Shift_Right (Group and 16#FF0000#, 16)), Stream_Element (Shift_Right (Group and 16#00FF00#, 8)), Stream_Element (Group and 16#0000FF#)); R := R + 3; Group := 0; J := 18; end if; end if; end loop; return Result (1 .. R - 1 - Pad); end Base64_Decode; ---------------- -- Encode_URL -- ---------------- function Encode_URL (SRP_Info : Split_SRP) return Types.String is use PolyORB.Objects; Result : Types.String; Current_Arg : Arg_Info_Ptr := SRP_Info.Args; begin Append (Result, SRP_Info.Method.all & " " & Objects.Oid_To_Hex_String (SRP_Info.Oid.all)); if Current_Arg /= null then Append (Result, "?"); end if; while Current_Arg /= null loop -- ??? Free mem ? Append (Result, Current_Arg.all.Name.all & "="); Append (Result, Encode_String (To_Standard_String (Current_Arg.all.Value.all))); if Current_Arg.all.Next /= null then Append (Result, "&"); end if; Current_Arg := Current_Arg.all.Next; end loop; -- return Types.To_Standard_String (Any.From_Any (Join (Split_URL))); return Result; end Encode_URL; ---------------- -- Encode_URL -- ---------------- procedure Encode_URL (SRP_Info : in out Split_SRP) is -- Current_Arg : Arg_Info_Ptr := SRP_Info.Args; begin raise Deprecated; -- while Current_Arg /= null loop -- -- ??? Free mem ? -- Current_Arg.all.Value := -- new String'(Encode_String (Current_Arg.all.Value.all)); -- Current_Arg := Current_Arg.all.Next; -- end loop; end Encode_URL; ------------------- -- Encode_String -- ------------------- function Encode_String (Str : String; Also_Escape : String := "/") return String renames Utils.URI_Encode; ------------------------------------------- -- Conversions between PolyORB signed and -- -- unsigned integer types. -- ------------------------------------------- function To_Long_Long is new Ada.Unchecked_Conversion (PolyORB.Types.Unsigned_Long_Long, PolyORB.Types.Long_Long); pragma Warnings (Off); pragma Unreferenced (To_Long_Long); pragma Warnings (On); function To_Unsigned_Long_Long is new Ada.Unchecked_Conversion (PolyORB.Types.Long_Long, PolyORB.Types.Unsigned_Long_Long); pragma Warnings (Off); pragma Unreferenced (To_Unsigned_Long_Long); pragma Warnings (On); function To_Long is new Ada.Unchecked_Conversion (PolyORB.Types.Unsigned_Long, PolyORB.Types.Long); pragma Warnings (Off); pragma Unreferenced (To_Long); pragma Warnings (On); function To_Unsigned_Long is new Ada.Unchecked_Conversion (PolyORB.Types.Long, PolyORB.Types.Unsigned_Long); function To_Short is new Ada.Unchecked_Conversion (PolyORB.Types.Unsigned_Short, PolyORB.Types.Short); function To_Unsigned_Short is new Ada.Unchecked_Conversion (PolyORB.Types.Short, PolyORB.Types.Unsigned_Short); ---------------- -- Unmarshall -- ---------------- procedure Unmarshall (Buffer : access Buffer_Type; NV : in out NamedValue) is begin pragma Debug (C, O ("Unmarshall (NamedValue): enter")); pragma Debug (C, O ("Unmarshall (NamedValue): is_empty := " & Boolean'Image (PolyORB.Any.Is_Empty (NV.Argument)))); Unmarshall_To_Any (Buffer, Get_Container (NV.Argument).all); pragma Debug (C, O ("Unmarshall (NamedValue): is_empty := " & Boolean'Image (PolyORB.Any.Is_Empty (NV.Argument)))); pragma Debug (C, O ("Unmarshall (NamedValue): end")); end Unmarshall; function Unmarshall (Buffer : access Buffer_Type) return PolyORB.Types.Boolean is begin pragma Debug (C, O ("Unmarshall (Boolean): enter & end")); return PolyORB.Types.Boolean'Val (PolyORB.Types.Octet'(Unmarshall (Buffer))); end Unmarshall; function Unmarshall (Buffer : access Buffer_Type) return PolyORB.Types.Octet is Result : Stream_Element_Array (1 .. 1); begin Align_Unmarshall_Copy (Buffer, Align_1, Result); pragma Debug (C, O ("Unmarshall (Octet): enter & end")); return PolyORB.Types.Octet (Result (Result'First)); end Unmarshall; function Unmarshall (Buffer : access Buffer_Type) return PolyORB.Types.Unsigned_Short renames CDR.Common.Unmarshall; function Unmarshall (Buffer : access Buffer_Type) return PolyORB.Types.Char is begin pragma Debug (C, O ("Unmarshall (Char): enter & end")); return PolyORB.Types.Char'Val (PolyORB.Types.Octet'(Unmarshall (Buffer))); end Unmarshall; function Unmarshall (Buffer : access Buffer_Type) return PolyORB.Types.Unsigned_Long renames CDR.Common.Unmarshall; function Unmarshall (Buffer : access Buffer_Type) return PolyORB.Types.Short is begin pragma Debug (C, O ("Unmarshall (Short): enter & end")); return To_Short (Unmarshall (Buffer)); end Unmarshall; function Unmarshall (Buffer : access Buffer_Type) return Stream_Element_Array is Length : constant PolyORB.Types.Unsigned_Long := Unmarshall (Buffer); E : Stream_Element_Array (1 .. Stream_Element_Offset (Length)); begin for I in E'Range loop E (I) := Stream_Element (PolyORB.Types.Octet'(Unmarshall (Buffer))); end loop; return E; end Unmarshall; function Unmarshall (Buffer : access Buffer_Type) return PolyORB.Types.Long is Long_String : constant Types.String := Unmarshall (Buffer); begin pragma Debug (C, O ("Unmarshall (Long): enter & end")); return Long'Value (To_Standard_String (Long_String)); -- return To_Long (Unmarshall (Buffer)); end Unmarshall; function Unmarshall (Buffer : access Buffer_Type) return Standard.String is Length : constant PolyORB.Types.Unsigned_Long := Unmarshall (Buffer); Equiv : String (1 .. Natural (Length) - 1); begin pragma Debug (C, O ("Unmarshall (String): enter")); pragma Debug (C, O ("Unmarshall (String): length is " & PolyORB.Types.Unsigned_Long'Image (Length))); for I in Equiv'Range loop Equiv (I) := Character'Val (PolyORB.Types.Char'Pos (Unmarshall (Buffer))); end loop; if Character'Val (PolyORB.Types.Char'Pos (Unmarshall (Buffer))) /= ASCII.NUL then raise Unmarshall_Error; end if; pragma Debug (C, O ("Unmarshall (String): -> " & Equiv)); return Equiv; end Unmarshall; -- function Unmarshall -- (Buffer : access Buffer_Type) -- return Types.String is -- begin -- return PolyORB.Types.To_PolyORB_String (Unmarshall (Buffer)); -- end Unmarshall; function Unmarshall (Buffer : access Buffer_Type) return PolyORB.Any.TypeCode.Local_Ref is Nb : constant PolyORB.Types.Unsigned_Long := Unmarshall (Buffer); Result : PolyORB.Any.TypeCode.Local_Ref; begin -- XXX The hardcoded values in this case should be replaced -- by symbolic constants. pragma Debug (C, O ("Unmarshall (TypeCode): enter")); case Nb is when 0 => Result := PolyORB.Any.TypeCode.TC_Null; when 1 => Result := PolyORB.Any.TypeCode.TC_Void; when 2 => Result := PolyORB.Any.TypeCode.TC_Short; when 3 => Result := PolyORB.Any.TypeCode.TC_Long; when 4 => Result := PolyORB.Any.TypeCode.TC_Unsigned_Short; when 5 => Result := PolyORB.Any.TypeCode.TC_Unsigned_Long; when 6 => Result := PolyORB.Any.TypeCode.TC_Float; when 7 => Result := PolyORB.Any.TypeCode.TC_Double; when 8 => Result := PolyORB.Any.TypeCode.TC_Boolean; when 9 => Result := PolyORB.Any.TypeCode.TC_Char; when 10 => Result := PolyORB.Any.TypeCode.TC_Octet; when 11 => Result := PolyORB.Any.TypeCode.TC_Any; when 12 => Result := PolyORB.Any.TypeCode.TC_TypeCode; when 13 => Result := PolyORB.Any.TypeCode.TC_Principal; when 14 => Result := PolyORB.Any.TypeCode.TC_Object; declare Id : constant PolyORB.Types.String := Unmarshall (Buffer); Name : constant PolyORB.Types.String := Unmarshall (Buffer); begin PolyORB.Any.TypeCode.Add_Parameter (Result, To_Any (Name)); PolyORB.Any.TypeCode.Add_Parameter (Result, To_Any (Id)); end; when 15 => raise Program_Error; -- Result := PolyORB.Any.TypeCode.TC_Struct; -- declare -- Complex_Encap : aliased Encapsulation -- := Unmarshall (Buffer); -- Complex_Buffer : Buffer_Access := null; -- Id, Name, Member_Name : PolyORB.Types.String; -- Nb : PolyORB.Types.Unsigned_Long; -- Member_Type : PolyORB.Any.TypeCode.Local_Ref; -- begin -- pragma Debug (C, O ("unmarshall (TypeCode): dealing " -- & "with a struct")); -- Decapsulate (Complex_Encap'Access, Complex_Buffer); -- Id := Unmarshall (Complex_Buffer); -- Name := Unmarshall (Complex_Buffer); -- Nb := Unmarshall (Complex_Buffer); -- PolyORB.Any.TypeCode.Add_Parameter -- (Result, To_Any (Name)); -- PolyORB.Any.TypeCode.Add_Parameter -- (Result, To_Any (Id)); -- if Nb /= 0 then -- for I in 0 .. Nb - 1 loop -- Member_Name := Unmarshall (Complex_Buffer); -- Member_Type := Unmarshall (Complex_Buffer); -- PolyORB.Any.TypeCode.Add_Parameter -- (Result, To_Any (Member_Type)); -- PolyORB.Any.TypeCode.Add_Parameter -- (Result, To_Any (Member_Name)); -- end loop; -- end if; -- end; when 16 => raise Program_Error; -- Result := PolyORB.Any.TypeCode.TC_Union; -- declare -- Complex_Encap : aliased Encapsulation -- := Unmarshall (Buffer); -- Complex_Buffer : Buffer_Access := null; -- Id, Name, Member_Name : PolyORB.Types.String; -- Nb, Default_Index : PolyORB.Types.Unsigned_Long; -- Discriminator_Type, -- Member_Type : PolyORB.Any.TypeCode.Local_Ref; -- Member_Label : PolyORB.Any.Any; -- begin -- Decapsulate (Complex_Encap'Access, Complex_Buffer); -- Id := Unmarshall (Complex_Buffer); -- Name := Unmarshall (Complex_Buffer); -- Discriminator_Type := Unmarshall (Complex_Buffer); -- Default_Index := Unmarshall (Complex_Buffer); -- Nb := Unmarshall (Complex_Buffer); -- PolyORB.Any.TypeCode.Add_Parameter -- (Result, To_Any (Name)); -- PolyORB.Any.TypeCode.Add_Parameter -- (Result, To_Any (Id)); -- PolyORB.Any.TypeCode.Add_Parameter -- (Result, To_Any (Discriminator_Type)); -- PolyORB.Any.TypeCode.Add_Parameter -- (Result, To_Any (Default_Index)); -- if Nb /= 0 then -- for I in 0 .. Nb - 1 loop -- Member_Label := Get_Empty_Any (Discriminator_Type); -- Unmarshall_To_Any (Complex_Buffer, Member_Label); -- Member_Name := Unmarshall (Complex_Buffer); -- Member_Type := Unmarshall (Complex_Buffer); -- PolyORB.Any.TypeCode.Add_Parameter -- (Result, Member_Label); -- PolyORB.Any.TypeCode.Add_Parameter -- (Result, To_Any (Member_Type)); -- PolyORB.Any.TypeCode.Add_Parameter -- (Result, To_Any (Member_Name)); -- end loop; -- end if; -- end; when 17 => raise Program_Error; -- Result := PolyORB.Any.TypeCode.TC_Enum; -- declare -- Complex_Encap : aliased Encapsulation -- := Unmarshall (Buffer); -- Complex_Buffer : Buffer_Access := null; -- Id, Name, Member_Name : PolyORB.Types.String; -- Nb : PolyORB.Types.Unsigned_Long; -- begin -- Decapsulate (Complex_Encap'Access, Complex_Buffer); -- Id := Unmarshall (Complex_Buffer); -- Name := Unmarshall (Complex_Buffer); -- Nb := Unmarshall (Complex_Buffer); -- PolyORB.Any.TypeCode.Add_Parameter -- (Result, To_Any (Name)); -- PolyORB.Any.TypeCode.Add_Parameter -- (Result, To_Any (Id)); -- if Nb /= 0 then -- for I in 0 .. Nb - 1 loop -- Member_Name := Unmarshall (Complex_Buffer); -- PolyORB.Any.TypeCode.Add_Parameter -- (Result, To_Any (Member_Name)); -- end loop; -- end if; -- end; when 18 => Result := PolyORB.Any.TypeCode.TC_String; declare Length : PolyORB.Types.Unsigned_Long; begin Length := Unmarshall (Buffer); PolyORB.Any.TypeCode.Add_Parameter (Result, To_Any (Length)); end; when 19 => raise Program_Error; -- Result := PolyORB.Any.TypeCode.TC_Sequence; -- declare -- Complex_Encap : aliased Encapsulation -- := Unmarshall (Buffer); -- Complex_Buffer : Buffer_Access := null; -- Length : PolyORB.Types.Unsigned_Long; -- Content_Type : PolyORB.Any.TypeCode.Local_Ref; -- begin -- Decapsulate (Complex_Encap'Access, Complex_Buffer); -- Content_Type := Unmarshall (Complex_Buffer); -- Length := Unmarshall (Complex_Buffer); -- PolyORB.Any.TypeCode.Add_Parameter -- (Result, To_Any (Length)); -- PolyORB.Any.TypeCode.Add_Parameter -- (Result, To_Any (Content_Type)); -- end; when 20 => raise Program_Error; -- Result := PolyORB.Any.TypeCode.TC_Array; -- declare -- Complex_Encap : aliased Encapsulation -- := Unmarshall (Buffer); -- Complex_Buffer : Buffer_Access := null; -- Length : PolyORB.Types.Unsigned_Long; -- Content_Type : PolyORB.Any.TypeCode.Local_Ref; -- begin -- Decapsulate (Complex_Encap'Access, Complex_Buffer); -- Content_Type := Unmarshall (Complex_Buffer); -- Length := Unmarshall (Complex_Buffer); -- PolyORB.Any.TypeCode.Add_Parameter -- (Result, To_Any (Length)); -- PolyORB.Any.TypeCode.Add_Parameter -- (Result, To_Any (Content_Type)); -- end; when 21 => raise Program_Error; -- Result := PolyORB.Any.TypeCode.TC_Alias; -- declare -- Complex_Encap : aliased Encapsulation -- := Unmarshall (Buffer); -- Complex_Buffer : Buffer_Access := null; -- Id, Name : PolyORB.Types.String; -- Content_Type : PolyORB.Any.TypeCode.Local_Ref; -- begin -- Decapsulate (Complex_Encap'Access, Complex_Buffer); -- Id := Unmarshall (Complex_Buffer); -- Name := Unmarshall (Complex_Buffer); -- Content_Type := Unmarshall (Complex_Buffer); -- PolyORB.Any.TypeCode.Add_Parameter -- (Result, To_Any (Name)); -- PolyORB.Any.TypeCode.Add_Parameter -- (Result, To_Any (Id)); -- PolyORB.Any.TypeCode.Add_Parameter -- (Result, To_Any (Content_Type)); -- end; when 22 => raise Program_Error; -- Result := PolyORB.Any.TypeCode.TC_Except; -- declare -- Complex_Encap : aliased Encapsulation -- := Unmarshall (Buffer); -- Complex_Buffer : Buffer_Access := null; -- Id, Name, Member_Name : PolyORB.Types.String; -- Nb : PolyORB.Types.Unsigned_Long; -- Member_Type : PolyORB.Any.TypeCode.Local_Ref; -- begin -- Decapsulate (Complex_Encap'Access, Complex_Buffer); -- Id := Unmarshall (Complex_Buffer); -- Name := Unmarshall (Complex_Buffer); -- Nb := Unmarshall (Complex_Buffer); -- PolyORB.Any.TypeCode.Add_Parameter -- (Result, To_Any (Name)); -- PolyORB.Any.TypeCode.Add_Parameter -- (Result, To_Any (Id)); -- if Nb /= 0 then -- for I in 0 .. Nb - 1 loop -- Member_Name := Unmarshall (Complex_Buffer); -- Member_Type := Unmarshall (Complex_Buffer); -- PolyORB.Any.TypeCode.Add_Parameter -- (Result, To_Any (Member_Type)); -- PolyORB.Any.TypeCode.Add_Parameter -- (Result, To_Any (Member_Name)); -- end loop; -- end if; -- end; when 23 => Result := PolyORB.Any.TypeCode.TC_Long_Long; when 24 => Result := PolyORB.Any.TypeCode.TC_Unsigned_Long_Long; when 25 => Result := PolyORB.Any.TypeCode.TC_Long_Double; when 26 => Result := PolyORB.Any.TypeCode.TC_Wchar; when 27 => Result := PolyORB.Any.TypeCode.TC_Wide_String; declare Length : PolyORB.Types.Unsigned_Long; begin Length := Unmarshall (Buffer); PolyORB.Any.TypeCode.Add_Parameter (Result, To_Any (Length)); end; when 28 => Result := PolyORB.Any.TypeCode.TC_Fixed; declare Fixed_Digits : PolyORB.Types.Unsigned_Short; Fixed_Scale : PolyORB.Types.Short; begin Fixed_Digits := Unmarshall (Buffer); Fixed_Scale := Unmarshall (Buffer); PolyORB.Any.TypeCode.Add_Parameter (Result, To_Any (Fixed_Digits)); PolyORB.Any.TypeCode.Add_Parameter (Result, To_Any (Fixed_Scale)); end; when 29 => raise Program_Error; -- Result := PolyORB.Any.TypeCode.TC_Value; -- declare -- Complex_Encap : aliased Encapsulation -- := Unmarshall (Buffer); -- Complex_Buffer : Buffer_Access := null; -- Id, Name, Member_Name : PolyORB.Types.String; -- Type_Modifier, Visibility : PolyORB.Types.Short; -- Nb : PolyORB.Types.Unsigned_Long; -- Concrete_Base_Type, -- Member_Type : PolyORB.Any.TypeCode.Local_Ref; -- begin -- Decapsulate (Complex_Encap'Access, Complex_Buffer); -- Id := Unmarshall (Complex_Buffer); -- Name := Unmarshall (Complex_Buffer); -- Type_Modifier := Unmarshall (Complex_Buffer); -- Concrete_Base_Type := Unmarshall (Complex_Buffer); -- Nb := Unmarshall (Complex_Buffer); -- PolyORB.Any.TypeCode.Add_Parameter -- (Result, To_Any (Name)); -- PolyORB.Any.TypeCode.Add_Parameter -- (Result, To_Any (Id)); -- PolyORB.Any.TypeCode.Add_Parameter -- (Result, To_Any (Type_Modifier)); -- PolyORB.Any.TypeCode.Add_Parameter -- (Result, To_Any (Concrete_Base_Type)); -- if Nb /= 0 then -- for I in 0 .. Nb - 1 loop -- Member_Name := Unmarshall (Complex_Buffer); -- Member_Type := Unmarshall (Complex_Buffer); -- Visibility := Unmarshall (Complex_Buffer); -- PolyORB.Any.TypeCode.Add_Parameter -- (Result, To_Any (Visibility)); -- PolyORB.Any.TypeCode.Add_Parameter -- (Result, To_Any (Member_Type)); -- PolyORB.Any.TypeCode.Add_Parameter -- (Result, To_Any (Member_Name)); -- end loop; -- end if; -- end; when 30 => raise Program_Error; -- Result := PolyORB.Any.TypeCode.TC_Valuebox; -- declare -- Complex_Encap : aliased Encapsulation -- := Unmarshall (Buffer); -- Complex_Buffer : Buffer_Access := null; -- Id, Name : PolyORB.Types.String; -- Content_Type : PolyORB.Any.TypeCode.Local_Ref; -- begin -- Decapsulate (Complex_Encap'Access, Complex_Buffer); -- Id := Unmarshall (Complex_Buffer); -- Name := Unmarshall (Complex_Buffer); -- Content_Type := Unmarshall (Complex_Buffer); -- PolyORB.Any.TypeCode.Add_Parameter -- (Result, To_Any (Name)); -- PolyORB.Any.TypeCode.Add_Parameter -- (Result, To_Any (Id)); -- PolyORB.Any.TypeCode.Add_Parameter -- (Result, To_Any (Content_Type)); -- end; when 31 => raise Program_Error; -- Result := PolyORB.Any.TypeCode.TC_Native; -- declare -- Complex_Encap : aliased Encapsulation -- := Unmarshall (Buffer); -- Complex_Buffer : Buffer_Access := null; -- Id, Name : PolyORB.Types.String; -- begin -- Decapsulate (Complex_Encap'Access, Complex_Buffer); -- Id := Unmarshall (Complex_Buffer); -- Name := Unmarshall (Complex_Buffer); -- PolyORB.Any.TypeCode.Add_Parameter -- (Result, To_Any (Name)); -- PolyORB.Any.TypeCode.Add_Parameter -- (Result, To_Any (Id)); -- end; when 32 => raise Program_Error; -- Result := PolyORB.Any.TypeCode.TC_Abstract_Interface; -- declare -- Complex_Encap : aliased Encapsulation -- := Unmarshall (Buffer); -- Complex_Buffer : Buffer_Access := null; -- Id, Name : PolyORB.Types.String; -- begin -- Decapsulate (Complex_Encap'Access, Complex_Buffer); -- Id := Unmarshall (Complex_Buffer); -- Name := Unmarshall (Complex_Buffer); -- PolyORB.Any.TypeCode.Add_Parameter -- (Result, To_Any (Name)); -- PolyORB.Any.TypeCode.Add_Parameter -- (Result, To_Any (Id)); -- end; when others => raise Unmarshall_Error; end case; pragma Debug (C, O ("Unmarshall (TypeCode): end")); return Result; end Unmarshall; function Unmarshall (Buffer : access Buffer_Type) return PolyORB.Any.Any is Result : PolyORB.Any.Any; Tc : constant PolyORB.Any.TypeCode.Local_Ref := Unmarshall (Buffer); begin pragma Debug (C, O ("Unmarshall (Any): enter")); Result := Get_Empty_Any (Tc); Unmarshall_To_Any (Buffer, Get_Container (Result).all); pragma Debug (C, O ("Unmarshall (Any): end")); return Result; end Unmarshall; ----------------- -- MARSHALLING -- ----------------- procedure Marshall (Buffer : access Buffer_Type; Info_SRP : Split_SRP) is Current_Arg : Arg_Info_Ptr := Info_SRP.Args; begin Marshall (Buffer, Info_SRP.Method.all); -- ??? This Marshall seems to marshall a String -- should marshall a Char Marshall (Buffer, " "); Marshall (Buffer, Stream_Element_Array (Info_SRP.Oid.all)); if Current_Arg /= null then Marshall (Buffer, "?"); end if; while Current_Arg /= null loop Marshall (Buffer, Current_Arg.all.Name.all); Marshall (Buffer, "="); Marshall (Buffer, Current_Arg.all.Value.all); if Current_Arg.all.Next /= null then Marshall (Buffer, "&"); end if; Current_Arg := Current_Arg.all.Next; end loop; Marshall (Buffer, ASCII.CR & ASCII.LF); end Marshall; -- Marshalling of a Boolean procedure Marshall (Buffer : access Buffer_Type; Data : PolyORB.Types.Boolean) is begin pragma Debug (C, O ("Marshall (Boolean): enter")); Marshall (Buffer, PolyORB.Types.Octet'(PolyORB.Types.Boolean'Pos (Data))); pragma Debug (C, O ("Marshall (Boolean): end")); end Marshall; -- Marshalling of a character procedure Marshall (Buffer : access Buffer_Type; Data : PolyORB.Types.Char) is begin pragma Debug (C, O ("Marshall (Char): enter")); Marshall (Buffer, PolyORB.Types.Octet'(PolyORB.Types.Char'Pos (Data))); pragma Debug (C, O ("Marshall (Char): end")); end Marshall; -- Marshalling of a Octet procedure Marshall (Buffer : access Buffer_Type; Data : PolyORB.Types.Octet) is begin pragma Debug (C, O ("Marshall (Octet): enter")); Align_Marshall_Copy (Buffer, (1 => Stream_Element (PolyORB.Types.Octet'(Data))), Align_1); pragma Debug (C, O ("Marshall (Octet): end")); end Marshall; -- Marshalling of an unsigned short procedure Marshall (Buffer : access Buffer_Type; Data : PolyORB.Types.Unsigned_Short) renames CDR.Common.Marshall; -- Marshalling of an unsigned long procedure Marshall (Buffer : access Buffer_Type; Data : PolyORB.Types.Unsigned_Long) renames CDR.Common.Marshall; -- Marshalling of a short procedure Marshall (Buffer : access Buffer_Type; Data : PolyORB.Types.Short) is begin pragma Debug (C, O ("Marshall (Short): enter")); Marshall (Buffer, To_Unsigned_Short (Data)); pragma Debug (C, O ("Marshall (Short): end")); end Marshall; -- Marshalling of a long procedure Marshall (Buffer : access Buffer_Type; Data : PolyORB.Types.Long) is begin pragma Debug (C, O ("Marshall (Long): enter")); Marshall (Buffer, To_Unsigned_Long (Data)); pragma Debug (C, O ("Marshall (Long): end")); end Marshall; -- Marshalling of a standard string procedure Marshall (Buffer : access Buffer_Type; Data : Standard.String) is begin pragma Debug (C, O ("Marshall (String): enter")); Marshall (Buffer, PolyORB.Types.Unsigned_Long'(Data'Length + 1)); for I in Data'Range loop Marshall (Buffer, PolyORB.Types.Char (Data (I))); end loop; Marshall (Buffer, PolyORB.Types.Char (ASCII.NUL)); pragma Debug (C, O ("Marshall (String): end")); end Marshall; -- Marshalling of PolyORB.Types.String procedure Marshall (Buffer : access Buffer_Type; Data : PolyORB.Types.String) is begin pragma Debug (C, O ("Marshall (PolyORB.Types.String): enter")); Marshall (Buffer, PolyORB.Types.To_Standard_String (Data)); pragma Debug (C, O ("Marshall (PolyORB.Types.String): end")); end Marshall; -- Marshalling a sequence of octets procedure Marshall (Buffer : access Buffer_Type; Data : Stream_Element_Array) is begin pragma Debug (C, O ("Marshall (Encapsulation): enter")); Marshall (Buffer, PolyORB.Types.Unsigned_Long (Data'Length)); for I in Data'Range loop Marshall (Buffer, PolyORB.Types.Octet (Data (I))); end loop; pragma Debug (C, O ("Marshall (Encapsulation): end")); end Marshall; -- Marshalling of an Any procedure Marshall (Buffer : access Buffer_Type; Data : PolyORB.Any.Any) is begin pragma Debug (C, O ("Marshall (Any): enter")); Marshall (Buffer, Get_Type (Data)); pragma Debug (C, O ("Marshall (Any): type marshalled")); Marshall_From_Any (Buffer, Get_Container (Data).all); pragma Debug (C, O ("Marshall (Any): end")); end Marshall; -- Puts the right TypeCode in the buffer procedure Marshall (Buffer : access Buffer_Type; Data : PolyORB.Any.TypeCode.Local_Ref) is -- Complex_Buffer : Buffer_Access; begin pragma Debug (C, O ("Marshall (Typecode): enter")); pragma Debug (C, O ("Marshall (Typecode): kind is " & TCKind'Image (PolyORB.Any.TypeCode.Kind (Data)))); case PolyORB.Any.TypeCode.Kind (Data) is when Tk_Null => Marshall (Buffer, PolyORB.Types.Unsigned_Long'(0)); when Tk_Void => Marshall (Buffer, PolyORB.Types.Unsigned_Long'(1)); when Tk_Short => Marshall (Buffer, PolyORB.Types.Unsigned_Long'(2)); when Tk_Long => Marshall (Buffer, PolyORB.Types.Unsigned_Long'(3)); when Tk_Ushort => -- Marshall (Buffer, PolyORB.Types.Unsigned_Long'(4)); raise Program_Error; when Tk_Ulong => -- Marshall (Buffer, PolyORB.Types.Unsigned_Long'(5)); raise Program_Error; when Tk_Float => -- Marshall (Buffer, PolyORB.Types.Unsigned_Long'(6)); raise Program_Error; when Tk_Double => -- Marshall (Buffer, PolyORB.Types.Unsigned_Long'(7)); raise Program_Error; when Tk_Boolean => Marshall (Buffer, PolyORB.Types.Unsigned_Long'(8)); when Tk_Char => Marshall (Buffer, PolyORB.Types.Unsigned_Long'(9)); when Tk_Octet => Marshall (Buffer, PolyORB.Types.Unsigned_Long'(10)); when Tk_Any => Marshall (Buffer, PolyORB.Types.Unsigned_Long'(11)); when Tk_TypeCode => Marshall (Buffer, PolyORB.Types.Unsigned_Long'(12)); when Tk_Principal => -- Marshall (Buffer, PolyORB.Types.Unsigned_Long'(13)); raise Program_Error; when Tk_Objref => -- Marshall (Buffer, PolyORB.Types.Unsigned_Long'(14)); -- pragma Debug (C, O ("Marshall (TypeCode): it has " -- & PolyORB.Types.Unsigned_Long'Image -- (PolyORB.Any.TypeCode.Parameter_Count (Data)) -- & " parameters")); -- Marshall (Buffer, PolyORB.Any.TypeCode.Id (Data)); -- Marshall (Buffer, PolyORB.Any.TypeCode.Name (Data)); raise Program_Error; when Tk_Struct => raise Program_Error; -- Marshall (Buffer, PolyORB.Types.Unsigned_Long'(15)); -- Start_Encapsulation (Complex_Buffer); -- pragma Debug (C, O ("Marshall (TypeCode): marshalling the id")); -- Marshall (Complex_Buffer, -- PolyORB.Any.TypeCode.Id (Data)); -- Marshall (Complex_Buffer, -- PolyORB.Any.TypeCode.Name (Data)); -- declare -- Nb : PolyORB.Types.Unsigned_Long := -- PolyORB.Any.TypeCode.Member_Count (Data); -- begin -- pragma Debug (C, O ("Marshall (TypeCode): " & -- "marshalling the members. Nb = " -- & PolyORB.Types.Unsigned_Long'Image (Nb))); -- Marshall (Complex_Buffer, Nb); -- if Nb /= 0 then -- for I in 0 .. Nb - 1 loop -- pragma Debug (C, O ("Marshall (TypeCode): about " -- & "to marshall a new member")); -- Marshall (Complex_Buffer, -- PolyORB.Any.TypeCode.Member_Name (Data, I)); -- pragma Debug -- (C, O ("Marshall (TypeCode): marshalling " -- & "the type (" -- & TCKind'Image -- (TypeCode.Kind -- (PolyORB.Any.TypeCode.Member_Type (Data, I))) -- & ")")); -- Marshall (Complex_Buffer, -- PolyORB.Any.TypeCode.Member_Type (Data, I)); -- pragma Debug (C, O ("Marshall (TypeCode): " -- & "member marshalled")); -- end loop; -- end if; -- end; -- pragma Debug (C, O ("Marshall: all members marshalled")); -- Marshall (Buffer, Encapsulate (Complex_Buffer)); -- Release (Complex_Buffer); when Tk_Union => raise Program_Error; -- Marshall (Buffer, PolyORB.Types.Unsigned_Long'(16)); -- Start_Encapsulation (Complex_Buffer); -- Marshall -- (Complex_Buffer, -- PolyORB.Any.TypeCode.Id (Data)); -- Marshall -- (Complex_Buffer, -- PolyORB.Any.TypeCode.Name (Data)); -- Marshall -- (Complex_Buffer, -- PolyORB.Any.TypeCode.Discriminator_Type (Data)); -- Marshall -- (Complex_Buffer, -- PolyORB.Any.TypeCode.Default_Index (Data)); -- declare -- Nb : PolyORB.Types.Unsigned_Long := -- PolyORB.Any.TypeCode.Member_Count (Data); -- begin -- Marshall (Complex_Buffer, Nb); -- if Nb /= 0 then -- for I in 0 .. Nb - 1 loop -- Marshall_From_Any -- (Complex_Buffer, -- PolyORB.Any.TypeCode.Member_Label (Data, I)); -- Marshall -- (Complex_Buffer, -- PolyORB.Any.TypeCode.Member_Name (Data, I)); -- Marshall -- (Complex_Buffer, -- PolyORB.Any.TypeCode.Member_Type (Data, I)); -- end loop; -- end if; -- end; -- Marshall (Buffer, Encapsulate (Complex_Buffer)); -- Release (Complex_Buffer); when Tk_Enum => raise Program_Error; -- Marshall (Buffer, PolyORB.Types.Unsigned_Long'(17)); -- Start_Encapsulation (Complex_Buffer); -- Marshall (Complex_Buffer, -- PolyORB.Any.TypeCode.Id (Data)); -- Marshall (Complex_Buffer, -- PolyORB.Any.TypeCode.Name (Data)); -- declare -- Nb : PolyORB.Types.Unsigned_Long := -- PolyORB.Any.TypeCode.Member_Count (Data); -- begin -- Marshall (Complex_Buffer, Nb); -- if Nb /= 0 then -- for I in 0 .. Nb - 1 loop -- Marshall (Complex_Buffer, -- PolyORB.Any.TypeCode.Member_Name (Data, I)); -- end loop; -- end if; -- end; -- Marshall (Buffer, Encapsulate (Complex_Buffer)); -- Release (Complex_Buffer); when Tk_String => Marshall (Buffer, PolyORB.Types.Unsigned_Long'(18)); pragma Debug (C, O ("marshall (typecode): " & "about to marshall length: " & PolyORB.Types.Unsigned_Long'Image (PolyORB.Any.TypeCode.Length (Data)))); Marshall (Buffer, PolyORB.Any.TypeCode.Length (Data)); pragma Debug (C, O ("marshall (typecode): length marshalled")); when Tk_Sequence => raise Program_Error; -- Marshall (Buffer, PolyORB.Types.Unsigned_Long'(19)); -- Start_Encapsulation (Complex_Buffer); -- Marshall (Complex_Buffer, -- PolyORB.Any.TypeCode.Content_Type (Data)); -- Marshall (Complex_Buffer, -- PolyORB.Any.TypeCode.Length (Data)); -- Marshall (Buffer, Encapsulate (Complex_Buffer)); -- Release (Complex_Buffer); when Tk_Array => raise Program_Error; -- Marshall (Buffer, PolyORB.Types.Unsigned_Long'(20)); -- Start_Encapsulation (Complex_Buffer); -- Marshall (Complex_Buffer, -- PolyORB.Any.TypeCode.Content_Type (Data)); -- Marshall (Complex_Buffer, -- PolyORB.Any.TypeCode.Length (Data)); -- Marshall (Buffer, Encapsulate (Complex_Buffer)); -- Release (Complex_Buffer); when Tk_Alias => raise Program_Error; -- Marshall (Buffer, PolyORB.Types.Unsigned_Long'(21)); -- Start_Encapsulation (Complex_Buffer); -- Marshall (Complex_Buffer, -- PolyORB.Any.TypeCode.Id (Data)); -- Marshall (Complex_Buffer, -- PolyORB.Any.TypeCode.Name (Data)); -- Marshall (Complex_Buffer, -- PolyORB.Any.TypeCode.Content_Type (Data)); -- Marshall (Buffer, Encapsulate (Complex_Buffer)); -- Release (Complex_Buffer); when Tk_Except => raise Program_Error; -- Marshall (Buffer, PolyORB.Types.Unsigned_Long'(22)); -- Start_Encapsulation (Complex_Buffer); -- Marshall (Complex_Buffer, -- PolyORB.Any.TypeCode.Id (Data)); -- Marshall (Complex_Buffer, -- PolyORB.Any.TypeCode.Name (Data)); -- declare -- Nb : PolyORB.Types.Unsigned_Long := -- PolyORB.Any.TypeCode.Member_Count (Data); -- begin -- Marshall (Complex_Buffer, Nb); -- if Nb /= 0 then -- for I in 0 .. Nb - 1 loop -- Marshall (Complex_Buffer, -- PolyORB.Any.TypeCode.Member_Name (Data, I)); -- Marshall (Complex_Buffer, -- PolyORB.Any.TypeCode.Member_Type (Data, I)); -- end loop; -- end if; -- end; -- Marshall (Buffer, Encapsulate (Complex_Buffer)); -- Release (Complex_Buffer); when Tk_Longlong => raise Program_Error; -- Marshall (Buffer, PolyORB.Types.Unsigned_Long'(23)); when Tk_Ulonglong => raise Program_Error; -- Marshall (Buffer, PolyORB.Types.Unsigned_Long'(24)); when Tk_Longdouble => raise Program_Error; -- Marshall (Buffer, PolyORB.Types.Unsigned_Long'(25)); when Tk_Widechar => raise Program_Error; -- Marshall (Buffer, PolyORB.Types.Unsigned_Long'(26)); when Tk_Wstring => raise Program_Error; -- Marshall (Buffer, PolyORB.Types.Unsigned_Long'(27)); -- Marshall (Buffer, PolyORB.Any.TypeCode.Length (Data)); when Tk_Fixed => raise Program_Error; -- Marshall (Buffer, PolyORB.Types.Unsigned_Long'(28)); -- Marshall (Buffer, PolyORB.Any.TypeCode.Fixed_Digits (Data)); -- Marshall (Buffer, PolyORB.Any.TypeCode.Fixed_Scale (Data)); when Tk_Value => raise Program_Error; -- Marshall (Buffer, PolyORB.Types.Unsigned_Long'(29)); -- Start_Encapsulation (Complex_Buffer); -- Marshall -- (Complex_Buffer, -- PolyORB.Any.TypeCode.Id (Data)); -- Marshall -- (Complex_Buffer, -- PolyORB.Any.TypeCode.Name (Data)); -- Marshall -- (Complex_Buffer, -- PolyORB.Any.TypeCode.Type_Modifier (Data)); -- Marshall -- (Complex_Buffer, -- PolyORB.Any.TypeCode.Concrete_Base_Type (Data)); -- declare -- Nb : PolyORB.Types.Unsigned_Long := -- PolyORB.Any.TypeCode.Member_Count (Data); -- begin -- Marshall (Complex_Buffer, Nb); -- if Nb /= 0 then -- for I in 0 .. Nb - 1 loop -- Marshall -- (Complex_Buffer, -- PolyORB.Any.TypeCode.Member_Name (Data, I)); -- Marshall -- (Complex_Buffer, -- PolyORB.Any.TypeCode.Member_Type (Data, I)); -- Marshall -- (Complex_Buffer, -- PolyORB.Any.TypeCode.Member_Visibility (Data, I)); -- end loop; -- end if; -- end; -- Marshall (Buffer, Encapsulate (Complex_Buffer)); -- Release (Complex_Buffer); when Tk_Valuebox => raise Program_Error; -- Marshall (Buffer, PolyORB.Types.Unsigned_Long'(30)); -- Start_Encapsulation (Complex_Buffer); -- Marshall (Complex_Buffer, -- PolyORB.Any.TypeCode.Id (Data)); -- Marshall (Complex_Buffer, -- PolyORB.Any.TypeCode.Name (Data)); -- Marshall (Complex_Buffer, -- PolyORB.Any.TypeCode.Content_Type (Data)); -- Marshall (Buffer, Encapsulate (Complex_Buffer)); -- Release (Complex_Buffer); when Tk_Native => raise Program_Error; -- Marshall (Buffer, PolyORB.Types.Unsigned_Long'(31)); -- Start_Encapsulation (Complex_Buffer); -- Marshall (Complex_Buffer, -- PolyORB.Any.TypeCode.Id (Data)); -- Marshall (Complex_Buffer, -- PolyORB.Any.TypeCode.Name (Data)); -- Marshall (Buffer, Encapsulate (Complex_Buffer)); -- Release (Complex_Buffer); when Tk_Abstract_Interface => raise Program_Error; -- Marshall (Buffer, PolyORB.Types.Unsigned_Long'(32)); -- Start_Encapsulation (Complex_Buffer); -- Marshall (Complex_Buffer, -- PolyORB.Any.TypeCode.Id (Data)); -- Marshall (Complex_Buffer, -- PolyORB.Any.TypeCode.Name (Data)); -- Marshall (Buffer, Encapsulate (Complex_Buffer)); -- Release (Complex_Buffer); when Tk_Local_Interface => raise Program_Error; when Tk_Component => raise Program_Error; when Tk_Home => raise Program_Error; when Tk_Event => raise Program_Error; end case; pragma Debug (C, O ("Marshall (Typecode): end")); end Marshall; ----------------------- -- Marshall_From_Any -- ----------------------- procedure Marshall_From_Any (R : access Rep_SRP; Buffer : access Buffers.Buffer_Type; Data : Any.Any_Container'Class; Error : in out Errors.Error_Container) is begin raise Program_Error; end Marshall_From_Any; procedure Marshall_From_Any (Buffer : access Buffer_Type; Data : PolyORB.Any.Any_Container'Class) is Data_Type : constant PolyORB.Any.TypeCode.Local_Ref := Unwind_Typedefs (Get_Type (Data)); begin pragma Debug (C, O ("Marshall_From_Any: enter")); -- pragma Debug -- (0 (Debug_Any(PolyORB.Any.TypeCode.Kind (Data_Type)'Pos))) case PolyORB.Any.TypeCode.Kind (Data_Type) is when Tk_Null | Tk_Void => null; when Tk_Short => Marshall (Buffer, PolyORB.Types.Short'(From_Any (Data))); when Tk_Long => Marshall (Buffer, PolyORB.Types.Long'(From_Any (Data))); when Tk_Ushort => Marshall (Buffer, PolyORB.Types.Unsigned_Short'(From_Any (Data))); when Tk_Ulong => Marshall (Buffer, PolyORB.Types.Unsigned_Long'(From_Any (Data))); when Tk_Float => -- Marshall (Buffer, PolyORB.Types.Float'(From_Any (Data))); raise Program_Error; when Tk_Double => -- Marshall (Buffer, PolyORB.Types.Double'(From_Any (Data))); raise Program_Error; when Tk_Boolean => Marshall (Buffer, PolyORB.Types.Boolean'(From_Any (Data))); when Tk_Char => Marshall (Buffer, PolyORB.Types.Char'(From_Any (Data))); when Tk_Octet => Marshall (Buffer, PolyORB.Types.Octet'(From_Any (Data))); when Tk_Any => Marshall (Buffer, PolyORB.Any.Any'(From_Any (Data))); when Tk_TypeCode => -- FIXME : to be done raise Program_Error; when Tk_Principal => -- FIXME : to be done raise Program_Error; when Tk_Objref => -- Marshall (Buffer, PolyORB.Types.Object.Helper.From_Any (Data)); raise Program_Error; when Tk_Struct => -- declare -- Nb : constant PolyORB.Types.Unsigned_Long -- := PolyORB.Any.Get_Aggregate_Count (Data); -- Value : PolyORB.Any.Any; -- begin -- for I in 0 .. Nb - 1 loop -- Value := PolyORB.Any.Get_Aggregate_Element -- (Data, PolyORB.Any.TypeCode.Member_Type (Data_Type, I), I); -- Marshall_From_Any (Buffer, Value); -- end loop; -- end; raise Program_Error; when Tk_Union => -- declare -- Nb : PolyORB.Types.Unsigned_Long; -- Value, Label_Value : PolyORB.Any.Any; -- begin -- Label_Value := Get_Aggregate_Element -- (Data, -- PolyORB.Any.TypeCode.Discriminator_Type (Data_Type), -- PolyORB.Types.Unsigned_Long (0)); -- pragma Debug (C, O ("Marshall_From_Any: got the label")); -- Marshall_From_Any (Buffer, Label_Value); -- pragma Debug (C, O ("Marshall_From_Any: label marshalled")); -- Nb := PolyORB.Any.Get_Aggregate_Count (Data); -- pragma Debug (C, O ("Marshall_From_Any: aggregate count = " -- & PolyORB.Types.Unsigned_Long'Image (Nb))); -- if Nb > 1 then -- for I in 1 .. Nb - 1 loop -- Value := PolyORB.Any.Get_Aggregate_Element -- (Data, -- PolyORB.Any.TypeCode.Member_Type_With_Label -- (Data_Type, Label_Value, I - 1), -- I); -- pragma Debug (C, O ("Marshall_From_Any: about " -- & "to marshall from any")); -- Marshall_From_Any (Buffer, Value); -- end loop; -- end if; -- end; raise Program_Error; when Tk_Enum => -- Marshall_From_Any -- (Buffer, -- PolyORB.Any.Get_Aggregate_Element -- (Data, -- PolyORB.Any.TypeCode.TC_Unsigned_Long, -- PolyORB.Types.Unsigned_Long (0))); raise Program_Error; when Tk_String => Marshall (Buffer, PolyORB.Types.String'(From_Any (Data))); when Tk_Sequence => -- declare -- Nb : constant PolyORB.Types.Unsigned_Long := -- PolyORB.Any.Get_Aggregate_Count (Data); -- Value : PolyORB.Any.Any; -- begin -- Value := PolyORB.Any.Get_Aggregate_Element -- (Data, -- PolyORB.Any.TypeCode.TC_Unsigned_Long, -- PolyORB.Types.Unsigned_Long (0)); -- Marshall_From_Any (Buffer, Value); -- if Nb /= 0 then -- for I in 1 .. Nb - 1 loop -- Value := PolyORB.Any.Get_Aggregate_Element -- (Data, -- PolyORB.Any.TypeCode.Content_Type (Data_Type), -- I); -- Marshall_From_Any (Buffer, Value); -- end loop; -- end if; -- end; raise Program_Error; when Tk_Array => -- declare -- Nb : constant PolyORB.Types.Unsigned_Long := -- PolyORB.Any.Get_Aggregate_Count (Data); -- Value : PolyORB.Any.Any; -- Content_True_Type : PolyORB.Any.TypeCode.Local_Ref := -- PolyORB.Any.TypeCode.Content_Type (Data_Type); -- begin -- while PolyORB.Any.TypeCode.Kind -- (Content_True_Type) = Tk_Array -- loop -- Content_True_Type := -- PolyORB.Any.TypeCode.Content_Type (Content_True_Type); -- end loop; -- for I in 0 .. Nb - 1 loop -- Value := PolyORB.Any.Get_Aggregate_Element -- (Data, -- Content_True_Type, -- I); -- pragma Debug (C, O ("Marshall_From_Any: value kind is " -- & PolyORB.Any.TCKind'Image -- (PolyORB.Any.TypeCode.Kind -- (PolyORB.Any.Get_Type (Value))))); -- Marshall_From_Any (Buffer, Value); -- end loop; -- end; raise Program_Error; when Tk_Alias => -- we should never reach this point pragma Assert (False); raise Program_Error; when Tk_Except => -- declare -- Nb : constant PolyORB.Types.Unsigned_Long := -- PolyORB.Any.Get_Aggregate_Count (Data); -- Value : PolyORB.Any.Any; -- begin -- pragma Debug -- for I in 0 .. Nb - 1 loop -- Value := PolyORB.Any.Get_Aggregate_Element -- (Data, -- PolyORB.Any.TypeCode.Member_Type (Data_Type, I), -- I); -- Marshall_From_Any (Buffer, Value); -- end loop; -- end; raise Program_Error; when Tk_Longlong => -- Marshall (Buffer, PolyORB.Types.Long_Long'(From_Any (Data))); raise Program_Error; when Tk_Ulonglong => -- Marshall -- (Buffer, -- PolyORB.Types.Unsigned_Long_Long'(From_Any (Data))); raise Program_Error; when Tk_Longdouble => -- Marshall (Buffer, PolyORB.Types.Long_Double'(From_Any (Data))); raise Program_Error; when Tk_Widechar => -- Marshall (Buffer, PolyORB.Types.Wchar'(From_Any (Data))); raise Program_Error; when Tk_Wstring => -- Marshall (Buffer, PolyORB.Types.Wide_String'(From_Any (Data))); raise Program_Error; when Tk_Fixed => -- declare -- Digit,Scale: PolyORB.Any.Any; -- begin -- Digit:=Get_Aggregate_Element -- (Data, -- PolyORB.Any.TypeCode.TC_Unsigned_Long, -- PolyORB.Any.TypeCode.Fixed_Digits(Data_Type), -- PolyORB.Types.Unsigned_Long(0)); -- Marshall_From_Any(Buffer,Digit); -- Scale:=Get_Aggregate_Element -- (Data, -- PolyORB.Any.TypeCode.Fixed_Scale(Data_Type), -- PolyORB.Types.Unsigned_Long(1)); -- Marshall_From_Any(Buffer,Scale); -- end; raise Program_Error; when Tk_Value => -- declare -- Nb: PolyORB.Types.Unsigned_Long; -- Value_Modifier, Value_TypeCode, -- Value_Visibility : PolyORB.Any.Any; -- begin -- Value_Modifier:= PolyORB.Any.Get_Aggregate_Element -- (Data, -- PolyORB.Any.TypeCode.Type_Modifier(Data_Type), -- PolyORB.Types.Unsigned_Long(0)); -- pragma Debug (0 ("Marshall_From_Any: got the value_modifier")); -- Marshall_From_Any(Buffer,Val_Modifier); -- Nb := PolyORB.Any.Get_Aggregate_Count(Data); -- if Nb>1 then -- while I -- Marshall_From_Any (Buffer, PolyORB.Any.Get_Aggregate_Element -- (Data, PolyORB.Any.TypeCode.Member_Type (Data_Type, -- PolyORB.Types.Unsigned_Long (0)), -- PolyORB.Types.Unsigned_Long (0))); raise Program_Error; when Tk_Native => -- FIXME : to be done raise Program_Error; when Tk_Abstract_Interface => -- FIXME : to be done raise Program_Error; when Tk_Local_Interface => raise Program_Error; when Tk_Component => raise Program_Error; when Tk_Home => raise Program_Error; when Tk_Event => raise Program_Error; end case; pragma Debug (C, O ("Marshall_From_Any: end")); end Marshall_From_Any; -- procedure Marshall_From_Any -- (R : Rep_SRP; -- Buffer : access Buffers.Buffer_Type; -- Data : Any.Any) -- is -- URL : Types.String := Any.From_Any (Data); -- Coded_URL : String_Ptr; -- begin -- -- ??? For now we don't use the Base64 coding -- -- Coded_URL := -- -- new String'(Base64_Encode (CORBA.To_Standard_String (URL))); -- Coded_URL := new String'(Encode_URL (Types.To_Standard_String (URL))); -- pragma Debug (C, O ("Coded URL: " & Coded_URL.all)); -- for I in Coded_URL.all'Range loop -- Align_Marshall_Copy -- (Buffer, Stream_Element_Array' -- (1 => Stream_Element (Character'Pos (Coded_URL.all (I))))); -- end loop; -- end Marshall_From_Any; ----------------------- -- Unmarshall_To_Any -- ----------------------- procedure Unmarshall_To_Any (R : access Rep_SRP; Buffer : access Buffers.Buffer_Type; Data : in out Any.Any_Container'Class; Error : in out Errors.Error_Container) is -- Encoded_URL : String_Ptr; -- Decoded_URL : String_Ptr; begin raise Program_Error; -- Encoded_URL := new Types.String'(Unmarshall_String (R, Buffer)); -- Decoded_URL := new Types.String'(Decode_URL (Encoded_URL.all)); -- Data := Any.To_Any -- (Types.To_PolyORB_String (Decode_URL (Decoded_URL.all))); end Unmarshall_To_Any; procedure Unmarshall_To_Any (Buffer : access Buffer_Type; Result : in out PolyORB.Any.Any_Container'Class) is Tc : constant PolyORB.Any.TypeCode.Local_Ref := Unwind_Typedefs (Get_Type (Result)); begin pragma Debug (C, O ("Unmarshall_To_Any: enter")); pragma Debug (C, O ("Unmarshall_To_Any: Any_Type is " & PolyORB.Any.TCKind'Image (TypeCode.Kind (Tc)))); case Any.TypeCode.Kind (Tc) is when Tk_Null | Tk_Void => null; when Tk_Short => declare S : constant Short := Unmarshall (Buffer); begin pragma Debug (C, O ("Unmarshall_To_Any: its value is " & PolyORB.Types.Short'Image (S))); Set_Any_Value (S, Result); end; when Tk_Long => declare L : constant Long := Unmarshall (Buffer); begin Set_Any_Value (L, Result); end; when Tk_Ushort => raise Program_Error; -- declare -- Us : Unsigned_Short := Unmarshall (Buffer); -- begin -- Set_Any_Value (Result, Us); -- end; when Tk_Ulong => raise Program_Error; -- declare -- Ul : Unsigned_Long := Unmarshall (Buffer); -- begin -- Set_Any_Value (Result, Ul); -- end; when Tk_Float => raise Program_Error; -- declare -- F : PolyORB.Types.Float := Unmarshall (Buffer); -- begin -- Set_Any_Value (Result, F); -- end; when Tk_Double => raise Program_Error; -- declare -- D : Double := Unmarshall (Buffer); -- begin -- Set_Any_Value (Result, D); -- end; when Tk_Boolean => declare B : constant PolyORB.Types.Boolean := Unmarshall (Buffer); begin Set_Any_Value (B, Result); end; when Tk_Char => declare C : constant Char := Unmarshall (Buffer); begin Set_Any_Value (C, Result); end; when Tk_Octet => declare O : constant PolyORB.Types.Octet := Unmarshall (Buffer); begin Set_Any_Value (O, Result); end; when Tk_Any => declare A : constant Any.Any := Unmarshall (Buffer); begin Set_Any_Value (A, Result); end; when Tk_TypeCode => declare T : constant TypeCode.Local_Ref := Unmarshall (Buffer); begin Set_Any_Value (T, Result); end; when Tk_Principal => -- FIXME : to be done raise Program_Error; when Tk_Objref => -- declare -- O : PolyORB.Types.Object.Ref := Unmarshall (Buffer); -- begin -- PolyORB.Types.Object.Helper.Set_Any_Value (Result, O); -- end; raise Program_Error; when Tk_Struct => raise Program_Error; -- declare -- Nb : Unsigned_Long := -- TypeCode.Member_Count (Tc); -- Arg : PolyORB.Any.Any; -- begin -- PolyORB.Any.Set_Any_Aggregate_Value (Result); -- pragma Debug (C, O ("unmarshall_to_any: about to " -- & "unmarshall parameters")); -- if Nb /= 0 then -- for I in 0 .. Nb - 1 loop -- if Is_Empty then -- Arg := Get_Empty_Any (TypeCode.Member_Type (Tc, I)); -- else -- Arg := Get_Aggregate_Element -- (Result, -- TypeCode.Member_Type (Tc, I), -- I); -- end if; -- pragma Debug (C, O ("unmarshall_to_any: about to " -- & "unmarshall a parameter")); -- Unmarshall_To_Any (Buffer, -- Arg); -- if Is_Empty then -- Add_Aggregate_Element (Result, Arg); -- end if; -- end loop; -- end if; -- end; when Tk_Union => raise Program_Error; -- declare -- Nb : Unsigned_Long; -- Label, Arg : PolyORB.Any.Any; -- begin -- Set_Any_Aggregate_Value (Result); -- if Is_Empty then -- Label := Get_Empty_Any (TypeCode.Discriminator_Type (Tc)); -- else -- Label := Get_Aggregate_Element -- (Result, -- TypeCode.Discriminator_Type (Tc), -- PolyORB.Types.Unsigned_Long (0)); -- end if; -- Unmarshall_To_Any (Buffer, Label); -- if Is_Empty then -- pragma Debug (C, O ("Unmarshall_To_Any: about to call " -- & "add_aggregate")); -- Add_Aggregate_Element (Result, Label); -- end if; -- pragma Debug (C, O ("Unmarshall_To_Any: about to call " -- & "member_count_with_label")); -- Nb := PolyORB.Any.TypeCode.Member_Count_With_Label (Tc, Label); -- if Nb > 0 then -- for I in 0 .. Nb - 1 loop -- if Is_Empty then -- Arg := Get_Empty_Any -- (TypeCode.Member_Type_With_Label (Tc, Label, I)); -- else -- Arg := Get_Aggregate_Element -- (Result, -- TypeCode.Member_Type_With_Label (Tc, Label, I), -- I + 1); -- end if; -- Unmarshall_To_Any (Buffer, Arg); -- if Is_Empty then -- Add_Aggregate_Element (Result, Arg); -- end if; -- end loop; -- end if; -- end; when Tk_Enum => raise Program_Error; -- declare -- Arg : PolyORB.Any.Any; -- begin -- Set_Any_Aggregate_Value (Result); -- if Is_Empty then -- Arg := Get_Empty_Any (TC_Unsigned_Long); -- else -- Arg := Get_Aggregate_Element -- (Result, -- TC_Unsigned_Long, -- PolyORB.Types.Unsigned_Long (0)); -- end if; -- Unmarshall_To_Any (Buffer, Arg); -- if Is_Empty then -- Add_Aggregate_Element (Result, Arg); -- end if; -- end; when Tk_String => declare S : constant PolyORB.Types.String := Unmarshall (Buffer); begin Set_Any_Value (S, Result); end; when Tk_Sequence => raise Program_Error; -- declare -- Nb : Unsigned_Long := Unmarshall (Buffer); -- Max_Nb : Unsigned_Long := TypeCode.Length (Tc); -- Arg : PolyORB.Any.Any; -- begin -- if Max_Nb > 0 and then Nb > Max_Nb then -- PolyORB.CORBA_P.Exceptions.Raise_Marshal; -- end if; -- Set_Any_Aggregate_Value (Result); -- if Is_Empty then -- Add_Aggregate_Element (Result, To_Any (Nb)); -- else -- Arg := Get_Aggregate_Element -- (Result, -- TC_Unsigned_Long, -- PolyORB.Types.Unsigned_Long (0)); -- Set_Any_Value (Arg, Nb); -- end if; -- if Nb /= 0 then -- for I in 0 .. Nb - 1 loop -- if Is_Empty then -- Arg := Get_Empty_Any (TypeCode.Content_Type (Tc)); -- else -- Arg := Get_Aggregate_Element -- (Result, TypeCode.Content_Type (Tc), I + 1); -- end if; -- Unmarshall_To_Any (Buffer, Arg); -- if Is_Empty then -- Add_Aggregate_Element (Result, Arg); -- end if; -- end loop; -- end if; -- end; when Tk_Array => raise Program_Error; -- declare -- Nb : Unsigned_Long := TypeCode.Length (Tc); -- Content_True_Type : PolyORB.Any.TypeCode.Local_Ref := -- TypeCode.Content_Type (Tc); -- Arg : PolyORB.Any.Any; -- begin -- while PolyORB.Any.TypeCode.Kind -- (Content_True_Type) = Tk_Array -- loop -- Nb := Nb * TypeCode.Length (Content_True_Type); -- Content_True_Type := -- TypeCode.Content_Type (Content_True_Type); -- end loop; -- Set_Any_Aggregate_Value (Result); -- if Nb /= 0 then -- for I in 0 .. Nb - 1 loop -- if Is_Empty then -- Arg := Get_Empty_Any (Content_True_Type); -- else -- Arg := Get_Aggregate_Element -- (Result, Content_True_Type, I); -- end if; -- Unmarshall_To_Any (Buffer, Arg); -- if Is_Empty then -- Add_Aggregate_Element (Result, Arg); -- end if; -- end loop; -- end if; -- end; when Tk_Alias => -- we should never reach this point raise Program_Error; when Tk_Except => raise Program_Error; -- declare -- Nb : Unsigned_Long := -- TypeCode.Member_Count (Tc); -- Arg : PolyORB.Any.Any; -- begin -- Set_Any_Aggregate_Value (Result); -- if Nb /= 0 then -- for I in 0 .. Nb - 1 loop -- if Is_Empty then -- Arg := Get_Empty_Any (TypeCode.Member_Type (Tc, I)); -- else -- Arg := Get_Aggregate_Element -- (Result, -- TypeCode.Member_Type (Tc, I), -- I); -- end if; -- Unmarshall_To_Any (Buffer, -- Arg); -- if Is_Empty then -- Add_Aggregate_Element (Result, Arg); -- end if; -- end loop; -- end if; -- end; when Tk_Longlong => raise Program_Error; -- declare -- Ll : Long_Long := Unmarshall (Buffer); -- begin -- Set_Any_Value (Result, Ll); -- end; when Tk_Ulonglong => raise Program_Error; -- declare -- Ull : Unsigned_Long_Long := Unmarshall (Buffer); -- begin -- Set_Any_Value (Result, Ull); -- end; when Tk_Longdouble => raise Program_Error; -- declare -- Ld : Long_Double := Unmarshall (Buffer); -- begin -- Set_Any_Value (Result, Ld); -- end; when Tk_Widechar => raise Program_Error; -- declare -- Wc : Wchar := Unmarshall (Buffer); -- begin -- Set_Any_Value (Result, Wc); -- end; when Tk_Wstring => raise Program_Error; -- declare -- Ws : PolyORB.Types.Wide_String := Unmarshall (Buffer); -- begin -- Set_Any_Value (Result, Ws); -- end; when Tk_Fixed => -- FIXME : to be done -- declare -- Arg1,Arg2:PolyORB.Any.Any; -- begin -- Set_Any_Aggregate_Value(Result); -- if Is_Empty then -- Arg1:= Get_Empty_Any(TypeCode.Fixed_Digits(Tc)); -- else -- Arg1:= Get_Aggregate_Element -- (Result, -- TypeCode.Fixed_Digits(Tc), -- PolyORB.Types.Unsigned_Long(0)); -- end if; -- Unmarshall_To_Any(Buffer, Arg1); -- if Is_Empty then -- Add_Aggregate_Element(Result,Arg1); -- end if; -- if Is_Empty then -- Arg2:= Get_Empty_Any(TypeCode.Fixed_Scale(Tc)); -- else -- Arg2:= Get_Aggregate_Element -- (Result, -- TypeCode.Fixed_Digits(Tc), -- PolyORB.Types.Unsigned_Long(0)); -- end if; -- Unmarshall_To_Any(Buffer, Arg2); -- if Is_Empty then -- Add_Aggregate_Element(Result,Arg2); -- end if; -- end; raise Program_Error; when Tk_Value => -- declare -- Val_Modifier,Arg: PolyORB.Any.Any; -- Nb: PolyORB.Types.Unsigned_Long:= -- TypeCode.Member_Count(Tc); -- begin -- Set_Any_Aggregate_Value(Result); -- if Is_Empty then -- Val_Modifier:= Get_Empty_Any(TypeCode.Type_Modifier(Tc)); -- else -- Val_Modifier:= Get_Aggregate_Element -- (Result, -- TypeCode.Discriminator_Type(Tc), -- PolyORB.Types.Unsigned_Long(0)); -- end if; -- Unmarshall_To_Any(Buffer,Val_Modifier); -- if Is_Empty then -- Add_Aggregate_Element(Result,Val_Modifier); -- end if; -- if Nb /=0 then -- for I in 0 .. Nb-1 loop -- if Is_Empty then -- Arg:= Get_Empty_Any( TypeCode.Member_Visibility(Tc)); -- else -- Arg:= Get_Aggregate_Element -- (Result, -- TypeCode.Member_Visibility(Tc,I+1), -- I+1); -- end if; -- Unmarshall_To_Any(Buffer,Arg); -- if Is_Empty then -- Add_Aggregate_Element(Result,Arg); -- end if; -- end loop; -- end if; -- end; null; when Tk_Valuebox => -- declare -- Arg: Corba.Any; -- begin -- Set_Any_Aggregate_Value(Result); -- if Is_Empty then -- Arg:= Get_Empty_Any(TypeCode.Member_Type -- (Tc,PolyORB.Types.Unsigned_Long(0))); -- else -- Arg:= PolyORB.Any.Get_Aggregate_Element -- (Result, -- PolyORB.Any.TypeCode.Member_Type(Tc, -- PolyORB.Types.Unsigned_Long(0))); -- end if; -- Unmarshall_To_Any(Buffer,Arg); -- if Is_Empty then -- Add_Aggregate_Element(Result, Arg); -- end if; -- end; null; when Tk_Native => -- FIXME : to be done null; when Tk_Abstract_Interface => -- FIXME : to be done null; when Tk_Local_Interface => -- FIXME : to be done null; when Tk_Component => -- FIXME : to be done null; when Tk_Home => -- FIXME : to be done null; when Tk_Event => -- FIXME : to be done null; end case; pragma Debug (C, O ("Unmarshall_To_Any: end")); end Unmarshall_To_Any; ------------------- -- Marshall_Char -- ------------------- procedure Marshall_Char (B : access Buffer_Type; C : Character) is begin Align_Marshall_Copy (B, Stream_Element_Array'(1 => Stream_Element (Character'Pos (C)))); end Marshall_Char; --------------------- -- Unmarshall_Char -- --------------------- function Unmarshall_Char (B : access Buffer_Type) return Character is A : Stream_Element_Array (1 .. 1); begin Align_Unmarshall_Copy (B, Align_1, A); return Character'Val (A (A'First)); end Unmarshall_Char; --------------------- -- Marshall_String -- --------------------- procedure Marshall_String (R : access Rep_SRP; B : access Buffer_Type; S : String) is begin pragma Warnings (Off); pragma Unreferenced (R); pragma Warnings (On); for I in S'Range loop Marshall_Char (B, S (I)); end loop; end Marshall_String; ----------------------- -- Unmarshall_String -- ----------------------- function Unmarshall_String (R : Rep_SRP; B : access Buffer_Type) return String is S : String (1 .. 1024); C : Character; Last : Integer := S'First - 1; Max : constant Stream_Element_Count := Length (B.all); begin pragma Warnings (Off); pragma Unreferenced (R); pragma Warnings (On); loop exit when Last - S'First + 1 = Integer (Max); C := Unmarshall_Char (B); if C = ASCII.CR then C := Unmarshall_Char (B); pragma Assert (C = ASCII.LF); exit; end if; Last := Last + 1; S (Last) := C; exit when Last = S'Last; end loop; return S (S'First .. Last); end Unmarshall_String; -- Specific to SRP function Unmarshall (Buffer : access Buffer_Type) return Types.String is Result : Types.String; Ch : Types.Char; begin pragma Debug (C, O ("Marshall (PolyORB.Types.String): enter")); Ch := Unmarshall (Buffer); while Ch /= ASCII.CR and then Ch /= ASCII.NUL loop Append (Result, Ch); Ch := Unmarshall (Buffer); end loop; if Ch = ASCII.CR then Ch := Unmarshall (Buffer); pragma Assert (Ch = ASCII.LF); end if; pragma Debug (C, O ("Marshall (PolyORB.Types.String): end")); return Result; end Unmarshall; ----------------------- -- Unmarshall_To_Any -- ----------------------- function Unmarshall_To_Any (R : access Rep_SRP; Buffer : access Buffers.Buffer_Type) return Any.Any is Data : Any.Any; Error : Errors.Error_Container; begin Unmarshall_To_Any (R, Buffer, Get_Container (Data).all, Error); return Data; end Unmarshall_To_Any; ------------------------- -- Marshall_From_Split -- ------------------------- -- Temporary procedure. Should be replaces by Marshall_From_Any when -- we will be able to [un]marshall Split_SRP [from] to Any procedure Marshall_From_Split_SRP (R : Rep_SRP; Buffer : access Buffers.Buffer_Type; SRP_Info : Split_SRP) is Local_SRP_Info : constant Split_SRP := SRP_Info; Coded_URL : String_Ptr; begin pragma Warnings (Off); pragma Unreferenced (R); pragma Warnings (On); -- Encode_URL (Local_SRP_Info); -- Coded_URL := -- new Types.String'((From_Any (Join (Local_SRP_Info)))); Coded_URL := new Types.String'(Encode_URL (Local_SRP_Info)); pragma Debug (C, O ("Coded URL: " & To_Standard_String (Coded_URL.all))); for I in To_Standard_String (Coded_URL.all)'Range loop Align_Marshall_Copy (Buffer, Stream_Element_Array' (1 => Stream_Element (Character'Pos (To_Standard_String (Coded_URL.all) (I))))); end loop; end Marshall_From_Split_SRP; end PolyORB.Representations.SRP; polyorb-2.8~20110207.orig/src/srp/polyorb-binding_data-srp.adb0000644000175000017500000001665011750740340023346 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . B I N D I N G _ D A T A . S R P -- -- -- -- B o d y -- -- -- -- Copyright (C) 2002-2011, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with PolyORB.Binding_Objects; with PolyORB.Filters; with PolyORB.ORB; with PolyORB.Protocols.SRP; with PolyORB.Sockets; with PolyORB.Transport.Connected.Sockets; package body PolyORB.Binding_Data.SRP is use PolyORB.Objects; use PolyORB.Sockets; use PolyORB.Transport; use PolyORB.Transport.Connected.Sockets; use PolyORB.Utils.Sockets; --------------- -- Duplicate -- --------------- procedure Duplicate (P1 : SRP_Profile_Type; P2 : out SRP_Profile_Type) is begin P2.Continuation := P1.Continuation; if P1.Object_Id /= null then P2.Object_Id := new Object_Id'(P1.Object_Id.all); else P2.Object_Id := null; end if; end Duplicate; ------------- -- Release -- ------------- procedure Release (P : in out SRP_Profile_Type) is begin Free (P.Address); Free (P.Object_Id); end Release; Pro : aliased Protocols.SRP.SRP_Protocol; SRP_Factories : constant Filters.Factory_Array := (0 => Pro'Access); ------------------ -- Bind_Profile -- ------------------ procedure Bind_Profile (Profile : access SRP_Profile_Type; The_ORB : Components.Component_Access; QoS : PolyORB.QoS.QoS_Parameters; BO_Ref : out Smart_Pointers.Ref; Error : out Errors.Error_Container) is pragma Unreferenced (QoS); use PolyORB.Binding_Objects; use PolyORB.Components; use PolyORB.Errors; use PolyORB.ORB; S : Socket_Type; TE : constant Transport_Endpoint_Access := new Socket_Endpoint; begin Create_Socket (S); Utils.Sockets.Connect_Socket (S, Profile.Address.all); Create (Socket_Endpoint (TE.all), S); -- Create (P'Access, Filters.Filter_Access (Session)); Binding_Objects.Setup_Binding_Object (The_ORB, TE, SRP_Factories, BO_Ref, Profile_Access (Profile)); ORB.Register_Binding_Object (ORB.ORB_Access (The_ORB), BO_Ref, ORB.Client); exception when Sockets.Socket_Error => Throw (Error, Comm_Failure_E, System_Exception_Members' (Minor => 0, Completed => Completed_Maybe)); end Bind_Profile; --------------------- -- Get_Profile_Tag -- --------------------- function Get_Profile_Tag (Profile : SRP_Profile_Type) return Profile_Tag is begin pragma Warnings (Off); pragma Unreferenced (Profile); pragma Warnings (On); return Tag_SRP; end Get_Profile_Tag; ---------------------------- -- Get_Profile_Preference -- ---------------------------- function Get_Profile_Preference (Profile : SRP_Profile_Type) return Profile_Preference is begin pragma Warnings (Off); pragma Unreferenced (Profile); pragma Warnings (On); return Preference_Default; end Get_Profile_Preference; -------------------- -- Create_Factory -- -------------------- procedure Create_Factory (PF : out SRP_Profile_Factory; TAP : Transport.Transport_Access_Point_Access; ORB : Components.Component_Access) is begin pragma Warnings (Off); pragma Unreferenced (ORB); pragma Warnings (On); PF.Address := new Socket_Name'(Address_Of (Socket_Access_Point (TAP.all))); end Create_Factory; -------------------- -- Create_Profile -- -------------------- function Create_Profile (PF : access SRP_Profile_Factory; Oid : Objects.Object_Id) return Profile_Access is Result : constant Profile_Access := new SRP_Profile_Type; TResult : SRP_Profile_Type renames SRP_Profile_Type (Result.all); begin TResult.Object_Id := new Object_Id'(Oid); TResult.Address := new Socket_Name'(PF.Address.all); return Result; end Create_Profile; ----------------------- -- Duplicate_Profile -- ----------------------- function Duplicate_Profile (P : SRP_Profile_Type) return Profile_Access is Result : constant Profile_Access := new SRP_Profile_Type; TResult : SRP_Profile_Type renames SRP_Profile_Type (Result.all); PP : SRP_Profile_Type renames P; begin TResult.Object_Id := new Object_Id'(PP.Object_Id.all); TResult.Address := new Socket_Name'(PP.Address.all); return Result; end Duplicate_Profile; ---------------------- -- Is_Local_Profile -- ---------------------- function Is_Local_Profile (PF : access SRP_Profile_Factory; P : access Profile_Type'Class) return Boolean is begin if P.all in SRP_Profile_Type and then SRP_Profile_Type (P.all).Address = PF.Address then P.Known_Local := True; return True; end if; return False; end Is_Local_Profile; ----------- -- Image -- ----------- function Image (Prof : SRP_Profile_Type) return String is begin return "Address : " & Image (Prof.Address.all) & ", Object_Id : " & PolyORB.Objects.Image (Prof.Object_Id.all); end Image; ------------------ -- Is_Colocated -- ------------------ function Is_Colocated (Left : SRP_Profile_Type; Right : Profile_Type'Class) return Boolean is use PolyORB.Types; begin return Right in SRP_Profile_Type'Class and then Left.Address = SRP_Profile_Type (Right).Address; end Is_Colocated; end PolyORB.Binding_Data.SRP; polyorb-2.8~20110207.orig/src/polyorb-parameters-file.adb0000644000175000017500000001313011750740340022403 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . P A R A M E T E R S . F I L E -- -- -- -- B o d y -- -- -- -- Copyright (C) 2002-2011, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with Ada.Text_IO; with PolyORB.Initialization; with PolyORB.Utils.Strings; with PolyORB.Utils.Configuration_File; package body PolyORB.Parameters.File is use Ada.Text_IO; use PolyORB.Utils.Strings; use PolyORB.Utils.Configuration_File.Configuration_Table; -------------------------------------------------------- -- Table of configuration parameters loaded from file -- -------------------------------------------------------- Configuration_Table : Table_Instance; ---------------------- -- File data source -- ---------------------- type File_Source is new Parameters_Source with null record; function Get_Conf (Source : access File_Source; Section, Key : String) return String; The_File_Source : aliased File_Source; --------------------- -- Fetch_From_File -- --------------------- function Fetch_From_File (Value : String) return String; -- Given a value of the form "file:", return the first line -- of the named file. function Fetch_From_File (Value : String) return String is Filename : constant String := Value (Value'First + 5 .. Value'Last); File : File_Type; Result : String (1 .. 1024); Last : Natural; begin Open (File, In_File, Filename); Get_Line (File, Result, Last); Close (File); return Result (1 .. Last); exception when Name_Error => return ""; end Fetch_From_File; -------------- -- Get_Conf -- -------------- function Get_Conf (Source : access File_Source; Section, Key : String) return String is pragma Unreferenced (Source); V : constant String_Ptr := Lookup (Configuration_Table, Make_Global_Key (Section, Key), null); begin if V /= null then return V.all; else return ""; end if; end Get_Conf; ----------------------------- -- Load_Configuration_File -- ----------------------------- procedure Load_Configuration_File (Conf_File_Name : String) is begin PolyORB.Utils.Configuration_File.Load_Configuration_Table (Conf_File_Name, Conf_File_Name = PolyORB_Conf_Default_Filename, Configuration_Table); end Load_Configuration_File; ----------------------------- -- Configuration_File_Name -- ----------------------------- function Configuration_File_Name return String is begin -- The key and section here are chosen so that the associated -- environment variable (in the context of the Parameters.Environment -- data source) is POLYORB_CONF. return Get_Conf (Section => "conf", Key => "", Default => PolyORB_Conf_Default_Filename); end Configuration_File_Name; ---------------- -- Initialize -- ---------------- procedure Initialize; procedure Initialize is begin Initialize (Configuration_Table); Load_Configuration_File (Configuration_File_Name); Register_Source (The_File_Source'Access); Fetch_From_File_Hook := Fetch_From_File'Access; end Initialize; use PolyORB.Initialization; use PolyORB.Initialization.String_Lists; begin Register_Module (Module_Info' (Name => +"parameters.file", Conflicts => Empty, Depends => Empty & "parameters.command_line?" & "parameters.environment?" & "parameters.overrides?" & "utils.configuration_file", Provides => +"parameters_sources", Implicit => True, Init => Initialize'Access, Shutdown => null)); end PolyORB.Parameters.File; polyorb-2.8~20110207.orig/src/polyorb-asynch_ev-sockets.adb0000644000175000017500000002300011750740340022750 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . A S Y N C H _ E V . S O C K E T S -- -- -- -- B o d y -- -- -- -- Copyright (C) 2001-2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- An asynchrous event source that is a set of socket descriptors. with Ada.Exceptions; with PolyORB.Constants; with PolyORB.Log; package body PolyORB.Asynch_Ev.Sockets is use PolyORB.Log; use PolyORB.Sockets; package L is new PolyORB.Log.Facility_Log ("polyorb.asynch_ev.sockets"); procedure O (Message : String; Level : Log_Level := Debug) renames L.Output; function C (Level : Log_Level := Debug) return Boolean renames L.Enabled; ------------ -- Create -- ------------ procedure Create (AEM : out Socket_Event_Monitor) is begin Empty (AEM.Monitored_Set); Create_Selector (AEM.Selector); end Create; ------------- -- Destroy -- ------------- procedure Destroy (AEM : in out Socket_Event_Monitor) is begin Empty (AEM.Monitored_Set); Close_Selector (AEM.Selector); end Destroy; ----------------- -- Has_Sources -- ----------------- function Has_Sources (AEM : Socket_Event_Monitor) return Boolean is begin return not Source_Lists.Is_Empty (AEM.Sources); end Has_Sources; ---------- -- Link -- ---------- function Link (S : access Socket_Event_Source'Class; Which : Ilists.Link_Type) return access SES_Access is begin return S.Links (Which)'Unchecked_Access; end Link; --------------------- -- Register_Source -- --------------------- procedure Register_Source (AEM : access Socket_Event_Monitor; AES : Asynch_Ev_Source_Access; Success : out Boolean) is begin pragma Debug (C, O ("Register_Source: enter")); Success := False; if AES.all not in Socket_Event_Source then pragma Debug (C, O ("Register_Source: leave")); return; end if; declare S_AES : Socket_Event_Source'Class renames Socket_Event_Source'Class (AES.all); begin Set (AEM.Monitored_Set, S_AES.Socket); Source_Lists.Append (AEM.Sources, S_AES'Access); end; pragma Debug (C, O ("Register_Source: Sources'Length =" & Integer'Image (Source_Lists.Length (AEM.Sources)))); AES.Monitor := Asynch_Ev_Monitor_Access (AEM); Success := True; pragma Debug (C, O ("Register_Source: leave")); end Register_Source; ----------------------- -- Unregister_Source -- ----------------------- procedure Unregister_Source (AEM : in out Socket_Event_Monitor; AES : Asynch_Ev_Source_Access; Success : out Boolean) is S_AES : Socket_Event_Source'Class renames Socket_Event_Source'Class (AES.all); begin pragma Debug (C, O ("Unregister_Source: enter")); if not Is_Set (AEM.Monitored_Set, Socket_Event_Source (AES.all).Socket) then Success := False; else Clear (AEM.Monitored_Set, S_AES.Socket); Source_Lists.Remove_Element (AEM.Sources, S_AES'Access); pragma Debug (C, O ("Unregister_Source: Sources'Length:=" & Source_Lists.Length (AEM.Sources)'Img)); Success := True; end if; pragma Debug (C, O ("Unregister_Source: leave, Success: " & Success'Img)); end Unregister_Source; ------------------- -- Check_Sources -- ------------------- function Check_Sources (AEM : access Socket_Event_Monitor; Timeout : Duration) return AES_Array is use Source_Lists; Result : AES_Array (1 .. Length (AEM.Sources)); Last : Integer := 0; T : Duration := Timeout; R_Set : Socket_Set_Type; W_Set : Socket_Set_Type; Status : Selector_Status; begin pragma Debug (C, O ("Check_Sources: enter")); PolyORB.Sockets.Copy (Source => AEM.Monitored_Set, Target => R_Set); PolyORB.Sockets.Empty (W_Set); if T = Constants.Forever then -- Convert special value of Timeout T := PolyORB.Sockets.Forever; end if; -- We want to retry the Check_Selector call if it is interrupted -- (happens when the application is being profiled). Retry_Loop : loop begin Check_Selector (Selector => AEM.Selector, R_Socket_Set => R_Set, W_Socket_Set => W_Set, Status => Status, Timeout => T); exit Retry_Loop; exception when E : Socket_Error => if Resolve_Exception (E) = Interrupted_System_Call then -- Retry null; else O ("unexpected Socket_Error raised by Check_Selector: " & Ada.Exceptions.Exception_Message (E), Error); raise; end if; end; end loop Retry_Loop; pragma Debug (C, O ("Selector returned status " & Selector_Status'Image (Status))); if Status = Completed then pragma Debug (C, O ("Iterate over source list")); declare It : Source_Lists.Iterator := First (AEM.Sources); begin while not Source_Lists.Last (It) loop declare S_AES : Socket_Event_Source'Class renames Value (It).all; Sock : Socket_Type renames S_AES.Socket; begin if Is_Set (R_Set, Sock) then pragma Debug (C, O ("Got event on socket" & Image (Sock))); Last := Last + 1; Result (Last) := S_AES'Access; Clear (AEM.Monitored_Set, Sock); Remove (AEM.Sources, It); else Next (It); end if; end; end loop; end; pragma Assert (Last >= Result'First); end if; -- Free the storage space associated with our socket sets. PolyORB.Sockets.Empty (R_Set); PolyORB.Sockets.Empty (W_Set); pragma Debug (C, O ("Check_Sources: end")); return Result (1 .. Last); end Check_Sources; ------------------------- -- Abort_Check_Sources -- ------------------------- procedure Abort_Check_Sources (AEM : Socket_Event_Monitor) is begin -- XXX check that selector is currently blocking! -- (and do it in a thread-safe manner, if applicable!) Abort_Selector (AEM.Selector); end Abort_Check_Sources; ------------------------- -- Create_Event_Source -- ------------------------- function Create_Event_Source (Socket : PolyORB.Sockets.Socket_Type) return Asynch_Ev_Source_Access is Result : constant Asynch_Ev_Source_Access := new Socket_Event_Source; begin Socket_Event_Source (Result.all).Socket := Socket; return Result; end Create_Event_Source; --------------------------------- -- Create_Socket_Event_Monitor -- --------------------------------- function Create_Socket_Event_Monitor return Asynch_Ev_Monitor_Access; function Create_Socket_Event_Monitor return Asynch_Ev_Monitor_Access is begin return new Socket_Event_Monitor; end Create_Socket_Event_Monitor; -------------------- -- AEM_Factory_Of -- -------------------- function AEM_Factory_Of (AES : Socket_Event_Source) return AEM_Factory is pragma Warnings (Off); pragma Unreferenced (AES); pragma Warnings (On); begin return Create_Socket_Event_Monitor'Access; end AEM_Factory_Of; end PolyORB.Asynch_Ev.Sockets; polyorb-2.8~20110207.orig/src/polyorb-tasking-profiles-full_tasking_atc-abortables.adb0000644000175000017500000001246111750740340030235 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- POLYORB.TASKING.PROFILES.FULL_TASKING_ATC.ABORTABLES -- -- -- -- B o d y -- -- -- -- Copyright (C) 2002-2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with PolyORB.Constants; with PolyORB.Initialization; with PolyORB.Parameters; with PolyORB.Tasking.Abortables; with PolyORB.Tasking.Threads; with PolyORB.Utils.Strings; package body PolyORB.Tasking.Profiles.Full_Tasking_ATC.Abortables is package PTA renames PolyORB.Tasking.Abortables; package PTT renames PolyORB.Tasking.Threads; procedure Initialize; -- Initialize module -- Abortable_PO is a simple barrier used for Abortable control protected type Abortable_PO is entry Wait; procedure Signal; private Signalled : Boolean := False; end Abortable_PO; ------------------ -- Abortable_PO -- ------------------ protected body Abortable_PO is ---------- -- Wait -- ---------- entry Wait when Signalled is begin null; end Wait; ------------ -- Signal -- ------------ procedure Signal is begin Signalled := True; end Signal; end Abortable_PO; type ATC_Abortable is new PTA.Abortable with record P : Abortable_PO; end record; overriding procedure Run (AR : not null access ATC_Abortable); overriding procedure Run_With_Timeout (AR : not null access ATC_Abortable; Timeout : Duration; Expired : out Boolean); overriding procedure Abort_Run (AR : not null access ATC_Abortable); overriding function Create (R : not null access PTT.Runnable'Class) return ATC_Abortable; --------------- -- Abort_Run -- --------------- procedure Abort_Run (AR : not null access ATC_Abortable) is begin AR.P.Signal; end Abort_Run; ------------ -- Create -- ------------ function Create (R : not null access PTT.Runnable'Class) return ATC_Abortable is begin return ATC_Abortable'(R => R, others => <>); end Create; ---------------- -- Initialize -- ---------------- procedure Initialize is begin if Parameters.Get_Conf (Section => "tasking", Key => "abortable_rpcs", Default => True) then PTA.Register_Abortable_Tag (ATC_Abortable'Tag); end if; end Initialize; --------- -- Run -- --------- procedure Run (AR : not null access ATC_Abortable) is begin select AR.P.Wait; then abort AR.R.Run; end select; end Run; ---------------------- -- Run_With_Timeout -- ---------------------- procedure Run_With_Timeout (AR : not null access ATC_Abortable; Timeout : Duration; Expired : out Boolean) is begin Expired := False; if Timeout = Constants.Forever then AR.Run; else select delay Timeout; Expired := True; then abort AR.Run; end select; end if; end Run_With_Timeout; use PolyORB.Initialization; use PolyORB.Initialization.String_Lists; use PolyORB.Utils.Strings; begin Register_Module (Module_Info' (Name => +"tasking.profiles.full_tasking_atc.abortables", Conflicts => Empty, Depends => Empty, Provides => +"tasking.threads", Implicit => False, Init => Initialize'Access, Shutdown => null)); end PolyORB.Tasking.Profiles.Full_Tasking_ATC.Abortables; polyorb-2.8~20110207.orig/src/polyorb-utils-chained_lists.adb0000644000175000017500000001651711750740340023306 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . U T I L S . C H A I N E D _ L I S T S -- -- -- -- B o d y -- -- -- -- Copyright (C) 2001-2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- Generic chained list with Ada.Unchecked_Deallocation; package body PolyORB.Utils.Chained_Lists is procedure Free is new Ada.Unchecked_Deallocation (Node, Node_Access); --------- -- "+" -- --------- function "+" (I : T) return List is begin return Result : List do Append (Result, Node_Access'(new Node'(Value => I, others => <>))); end return; end "+"; --------- -- "&" -- --------- function "&" (L : List; I : T) return List is begin return LL : List := L do Append (LL, I); end return; end "&"; ------------ -- Append -- ------------ procedure Append (L : in out List; I : T) is begin Append (L, Node_Access'(new Node'(Value => I, others => <>))); end Append; ---------------- -- Deallocate -- ---------------- procedure Deallocate (L : in out List) is It : Iterator := First (L); begin while not Last (It) loop Remove (L, It); end loop; end Deallocate; --------------- -- Duplicate -- --------------- function Duplicate (L : List) return List is D : List; -- New list It : Iterator := First (L); -- Iterator on original list begin while not Last (It) loop Append (D, Node_Access'(new Node'(Value => Value (It).Value, others => <>))); Next (It); end loop; return D; end Duplicate; ------------- -- Element -- ------------- function Element (L : List; Index : Natural) return Element_Access is It : Iterator := First (L); C : Natural := 0; begin while not Last (It) loop if C = Index then return Value (It).Value'Access; end if; C := C + 1; Next (It); end loop; raise Constraint_Error; end Element; ----------- -- Empty -- ----------- function Empty return List is Empty_List : List; begin return Empty_List; end Empty; ------------------- -- Extract_First -- ------------------- procedure Extract_First (L : in out List; Result : out T) is It : Iterator := First (L); begin if Last (It) then raise Constraint_Error; end if; Result := Value (It).Value; Remove (L, It); end Extract_First; ----------- -- First -- ----------- function First (L : List) return Iterator is begin return First (Node_Lists.List (L)); end First; -------------- -- Is_Empty -- -------------- function Is_Empty (L : List) return Boolean is begin return Node_Lists.Is_Empty (Node_Lists.List (L)); end Is_Empty; ---------- -- Last -- ---------- function Last (L : List) return Iterator is begin return Iterator (Node_Lists.Last (Node_Lists.List (L))); end Last; ---------- -- Last -- ---------- function Last (I : Iterator) return Boolean is begin return Node_Lists.Last (Node_Lists.Iterator (I)); end Last; ------------ -- Length -- ------------ function Length (L : List) return Natural is begin return Node_Lists.Length (Node_Lists.List (L)); end Length; ---------- -- Link -- ---------- function Link (N : access Node; Which : Ilists.Link_Type) return access Node_Access is begin return N.Links (Which)'Unchecked_Access; end Link; ---------- -- Next -- ---------- procedure Next (I : in out Iterator) is begin Node_Lists.Next (Node_Lists.Iterator (I)); end Next; ------------- -- Prepend -- ------------- procedure Prepend (L : in out List; I : T) is begin Prepend (L, Node_Access'(new Node'(Value => I, others => <>))); end Prepend; -------------- -- Remove_G -- -------------- procedure Remove_G (L : in out List; All_Occurrences : Boolean := True) is Item, Prev_Item : Node_Access; Iter : Iterator; begin Iter := First (L); Prev_Item := null; All_Items : while not Last (Iter) loop Item := Value (Iter); if Predicate (Item.Value) then Next (Iter); Remove_Element (L, Item, Prev_Item); Free (Item); exit All_Items when not All_Occurrences; else Prev_Item := Value (Iter); Next (Iter); end if; end loop All_Items; end Remove_G; ------------ -- Remove -- ------------ procedure Remove (L : in out List; I : in out Iterator) is N : Node_Access := Value (I); begin Node_Lists.Remove (Node_Lists.List (L), Node_Lists.Iterator (I)); Free (N); end Remove; ------------------------ -- Remove_Occurrences -- ------------------------ procedure Remove_Occurrences (L : in out List; I : T; All_Occurrences : Boolean := True) is function Equality (X : T) return Boolean; -- True iff X = I function Equality (X : T) return Boolean is begin return X = I; end Equality; procedure Remove is new Remove_G (Equality); begin Remove (L, All_Occurrences); end Remove_Occurrences; ----------- -- Value -- ----------- function Value (I : Iterator) return Element_Access is begin return Value (I).Value'Unchecked_Access; end Value; end PolyORB.Utils.Chained_Lists; polyorb-2.8~20110207.orig/src/polyorb-sequences-bounded-helper.ads0000644000175000017500000000662511750740340024245 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . S E Q U E N C E S . B O U N D E D . H E L P E R -- -- -- -- S p e c -- -- -- -- Copyright (C) 2003-2007, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- Any conversion subprograms for bounded sequences with PolyORB.Any; with PolyORB.Sequences.Helper; generic with function Element_From_Any (Item : PolyORB.Any.Any) return Element; with function Element_To_Any (Item : Element) return PolyORB.Any.Any; with function Element_Wrap (X : access Element) return PolyORB.Any.Content'Class; package PolyORB.Sequences.Bounded.Helper is function From_Any (Item : PolyORB.Any.Any) return Sequence; function To_Any (Item : Sequence) return PolyORB.Any.Any; function Wrap (X : access Sequence) return PolyORB.Any.Content'Class; procedure Initialize (Element_TC, Sequence_TC : PolyORB.Any.TypeCode.Local_Ref); private function Check_Length (Length : Natural) return Sequence; -- Return an empty sequence initialized with the given Length, unless -- Length > Max, in which case Constraint_Error is raised. package Bounded_Helper is new Sequences.Helper (Element => Element, Element_Ptr => Element_Ptr, Sequence => Sequence, Length => Length, New_Sequence => Check_Length, Set_Length => Set_Length, Unchecked_Element_Of => Unchecked_Element_Of, Element_From_Any => Element_From_Any, Element_To_Any => Element_To_Any, Element_Wrap => Element_Wrap); end PolyORB.Sequences.Bounded.Helper; polyorb-2.8~20110207.orig/src/polyorb-buffers.adb0000644000175000017500000010625511750740340020772 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . B U F F E R S -- -- -- -- B o d y -- -- -- -- Copyright (C) 2001-2011, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with Ada.Unchecked_Deallocation; pragma Warnings (Off); -- Depends on System.Unsigned_Types, an internal GNAT unit with System.Unsigned_Types; pragma Warnings (On); with PolyORB.Log; package body PolyORB.Buffers is use Ada.Streams; use System.Storage_Elements; use System.Unsigned_Types; use PolyORB.Opaque; use PolyORB.Log; use Buffer_Chunk_Pools; use Iovec_Pools; package L is new PolyORB.Log.Facility_Log ("polyorb.buffers"); procedure O (Message : String; Level : Log_Level := Debug) renames L.Output; function C (Level : Log_Level := Debug) return Boolean renames L.Enabled; package L2 is new PolyORB.Log.Facility_Log ("polyorb.buffers_show"); procedure O2 (Message : String; Level : Log_Level := Debug) renames L2.Output; function C2 (Level : Log_Level := Debug) return Boolean renames L2.Enabled; ----------------------- -- Local subprograms -- ----------------------- function To_Stream_Element_Array (Buffer : Buffer_Type) return Opaque.Zone_Access; -- Dump the contents of Buffer into a Stream_Element_Array, and return a -- pointer to it. The caller must take care of deallocating the pointer -- after use. function Padding_Size (Pos : Stream_Element_Offset; Alignment : Alignment_Type) return Stream_Element_Count; pragma Inline (Padding_Size); -- Return size of padding required to bring buffer position Pos to the -- desired alignment. procedure Show (Octets : Zone_Access); -- Display the contents of Octets for debugging purposes. -------------------- -- Align_Position -- -------------------- procedure Align_Position (Buffer : access Buffer_Type; Alignment : Alignment_Type) is Padding : constant Stream_Element_Count := Padding_Size (Buffer.CDR_Position, Alignment); begin pragma Debug (C, O ("Align_Position: pos = " & Stream_Element_Offset'Image (Buffer.CDR_Position) & ", padding by" & Stream_Element_Count'Image (Padding) & " for " & Alignment_Type'Image (Alignment))); pragma Assert (Buffer.CDR_Position + Padding <= Buffer.Initial_CDR_Position + Buffer.Length); -- Advance the CDR position to the new aligned position Buffer.CDR_Position := Buffer.CDR_Position + Padding; pragma Debug (C, O ("Align_Position: now at" & Stream_Element_Offset'Image (Buffer.CDR_Position))); end Align_Position; ------------------------------------- -- Allocate_And_Insert_Cooked_Data -- ------------------------------------- procedure Allocate_And_Insert_Cooked_Data (Buffer : access Buffer_Type; Size : Stream_Element_Count; Data : out Opaque_Pointer) is A_Data : Opaque_Pointer; begin Grow_Shrink (Buffer.Contents'Access, Size, A_Data); -- First try to grow an existing Iovec. if Is_Null (A_Data) then declare A_Chunk : Chunk_Access; Data_Iovec : Iovec; begin Allocate (Buffer.Storage'Access, A_Chunk, Size); pragma Assert (A_Chunk /= null and then A_Chunk.Size >= Size); Data_Iovec := (Iov_Base => Chunk_Storage (A_Chunk), Iov_Len => Storage_Offset (Size)); A_Data := Chunk_Storage (A_Chunk); Metadata (A_Chunk).all := (Last_Used => Size); Append (Iovec_Pool => Buffer.Contents, An_Iovec => Data_Iovec, A_Chunk => A_Chunk); pragma Assert (not Is_Null (A_Data)); end; end if; Data := A_Data; Buffer.CDR_Position := Buffer.CDR_Position + Size; Buffer.Length := Buffer.Length + Size; end Allocate_And_Insert_Cooked_Data; ------------------ -- CDR_Position -- ------------------ function CDR_Position (Buffer : access Buffer_Type) return Stream_Element_Offset is begin return Buffer.CDR_Position; end CDR_Position; ---------- -- Copy -- ---------- function Copy (Buffer : access Buffer_Type) return Buffer_Access is Into : constant Buffer_Access := new Buffer_Type; Copy_Address : Opaque_Pointer; begin Into.Endianness := Buffer.Endianness; Set_Initial_Position (Into, Buffer.Initial_CDR_Position); Allocate_And_Insert_Cooked_Data (Into, Buffer.Length, Copy_Address); Iovec_Pools.Dump (Buffer.Contents, Copy_Address); Into.CDR_Position := Buffer.Initial_CDR_Position; return Into; end Copy; --------------- -- Copy_Data -- --------------- procedure Copy_Data (From : Buffer_Type; Into : Reservation) is begin pragma Assert (True and then From.Endianness = Into.Endianness and then From.Initial_CDR_Position = Into.CDR_Position and then From.Length = Into.Length); Iovec_Pools.Dump (From.Contents, Into.Location); end Copy_Data; ---------------- -- Endianness -- ---------------- function Endianness (Buffer : access Buffer_Type) return Endianness_Type is begin return Buffer.Endianness; end Endianness; ------------------ -- Extract_Data -- ------------------ procedure Extract_Data (Buffer : access Buffer_Type; Data : out Opaque_Pointer; Size : Stream_Element_Count; Use_Current : Boolean := True; At_Position : Stream_Element_Offset := 0) is Extracted_Size : Stream_Element_Count := Size; begin Partial_Extract_Data (Buffer, Data, Extracted_Size, Use_Current, At_Position, Partial => False); pragma Assert (Extracted_Size = Size); end Extract_Data; ------------ -- Length -- ------------ function Length (Buffer : Buffer_Type) return Stream_Element_Count is begin return Buffer.Length; end Length; ----------------------- -- Initialize_Buffer -- ----------------------- procedure Initialize_Buffer (Buffer : access Buffer_Type; Size : Stream_Element_Count; Data : Opaque_Pointer; Endianness : Endianness_Type; Initial_CDR_Position : Stream_Element_Offset) is Data_Iovec : constant Iovec := (Iov_Base => Data, Iov_Len => Storage_Offset (Size)); begin pragma Assert (True and then Buffer.CDR_Position = 0 and then Buffer.Initial_CDR_Position = 0); Buffer.Endianness := Endianness; Buffer.CDR_Position := Initial_CDR_Position; Buffer.Initial_CDR_Position := Initial_CDR_Position; Append (Iovec_Pool => Buffer.Contents, An_Iovec => Data_Iovec); Buffer.Length := Size; end Initialize_Buffer; --------------------- -- Insert_Raw_Data -- --------------------- procedure Insert_Raw_Data (Buffer : access Buffer_Type; Size : Stream_Element_Count; Data : Opaque_Pointer) is Data_Iovec : constant Iovec := (Iov_Base => Data, Iov_Len => Storage_Offset (Size)); begin pragma Assert (Buffer.Endianness = Host_Order); Append (Iovec_Pool => Buffer.Contents, An_Iovec => Data_Iovec); Buffer.CDR_Position := Buffer.CDR_Position + Size; Buffer.Length := Buffer.Length + Size; end Insert_Raw_Data; --------------- -- Pad_Align -- --------------- Null_Data : aliased Stream_Element_Array (1 .. 2 ** Alignment_Type'Pos (Alignment_Type'Last)) := (others => 0); -- Null data used for padding procedure Pad_Align (Buffer : access Buffer_Type; Alignment : Alignment_Type) is Padding : constant Stream_Element_Count := Padding_Size (Buffer.CDR_Position, Alignment); Padding_Space : Opaque_Pointer; begin pragma Debug (C, O ("Pad_Align: pos = " & Stream_Element_Offset'Image (Buffer.CDR_Position) & ", padding by" & Stream_Element_Count'Image (Padding) & " for " & Alignment_Type'Image (Alignment))); if Padding = 0 then -- Buffer is already aligned return; end if; -- Try to extend Buffer.Content's last Iovec to provide proper alignment Grow_Shrink (Buffer.Contents'Access, Padding, Padding_Space); if Is_Null (Padding_Space) then -- Grow_Shrink was unable to extend the last Iovec: -- insert a non-growable iovec corresponding to static null data. declare Padding_Iovec : constant Iovec := (Iov_Base => Null_Data'Address, Iov_Len => Storage_Offset (Padding)); begin Append (Iovec_Pool => Buffer.Contents, An_Iovec => Padding_Iovec); end; else -- Ensure padding space is zeroed out for deterministic behaviour. declare Z : Stream_Element_Array (1 .. Padding); for Z'Address use Padding_Space; pragma Import (Ada, Z); begin Z := (others => 0); end; end if; Buffer.Length := Buffer.Length + Padding; Align_Position (Buffer, Alignment); end Pad_Align; ------------------ -- Padding_Size -- ------------------ function Padding_Size (Pos : Stream_Element_Offset; Alignment : Alignment_Type) return Stream_Element_Count is subtype Alignment_Modular is System.Unsigned_Types.Long_Unsigned; Alignment_Mask : constant Alignment_Modular := Shift_Left (1, Alignment_Type'Pos (Alignment)) - 1; Padding : constant Alignment_Modular := (-Alignment_Modular (Pos)) and Alignment_Mask; begin return Stream_Element_Count (Padding); end Padding_Size; -------------------------- -- Partial_Extract_Data -- -------------------------- procedure Partial_Extract_Data (Buffer : access Buffer_Type; Data : out Opaque_Pointer; Size : in out Stream_Element_Count; Use_Current : Boolean := True; At_Position : Stream_Element_Offset := 0; Partial : Boolean := True) is Start_Position : Stream_Element_Offset; Requested_Size : constant Stream_Element_Count := Size; begin if Use_Current then Start_Position := Buffer.CDR_Position; else Start_Position := At_Position; end if; Extract_Data (Buffer.Contents, Data, Start_Position - Buffer.Initial_CDR_Position, Size); if Size < Requested_Size and then not Partial then raise Constraint_Error with "buffer underflow (requested" & Requested_Size'Img & ", got" & Size'Img & ")"; end if; if Use_Current then Buffer.CDR_Position := Buffer.CDR_Position + Size; end if; end Partial_Extract_Data; ---------- -- Peek -- ---------- function Peek (Buffer : access Buffer_Type; Position : Ada.Streams.Stream_Element_Offset) return Ada.Streams.Stream_Element is begin return Iovec_Pools.Peek (Iovec_Pool => Buffer.Contents, Offset => Position - Buffer.Initial_CDR_Position); end Peek; -------------------- -- Receive_Buffer -- -------------------- procedure Receive_Buffer (Buffer : access Buffer_Type; Max : Stream_Element_Count; Received : out Stream_Element_Count) is V : aliased Iovec; Saved_CDR_Position : constant Stream_Element_Offset := Buffer.CDR_Position; begin pragma Debug (C, O ("Receive_Buffer: Max =" & Max'Img)); Allocate_And_Insert_Cooked_Data (Buffer, Max, V.Iov_Base); V.Iov_Len := Storage_Offset (Max); Lowlevel_Receive (V'Access); Received := Stream_Element_Offset (V.Iov_Len); pragma Debug (C, O ("Receive_Buffer: Received =" & Received'Img)); Unuse_Allocation (Buffer, Max - Received); Buffer.CDR_Position := Saved_CDR_Position; end Receive_Buffer; ------------- -- Release -- ------------- procedure Release (A_Buffer : in out Buffer_Access) is procedure Free is new Ada.Unchecked_Deallocation (Buffer_Type, Buffer_Access); begin if A_Buffer /= null then Release_Contents (A_Buffer.all); Free (A_Buffer); end if; end Release; ---------------------- -- Release_Contents -- ---------------------- procedure Release_Contents (Buffer : in out Buffer_Type) is begin Release (Buffer.Contents); Buffer_Chunk_Pools.Release (Buffer.Storage'Access); Buffer.CDR_Position := 0; Buffer.Initial_CDR_Position := 0; Buffer.Endianness := Host_Order; Buffer.Length := 0; end Release_Contents; --------------- -- Remaining -- --------------- function Remaining (Buffer : access Buffer_Type) return Stream_Element_Count is begin return Buffer.Initial_CDR_Position + Buffer.Length - Buffer.CDR_Position; end Remaining; ------------- -- Reserve -- ------------- function Reserve (Buffer : access Buffer_Type; Amount : Stream_Element_Count) return Reservation is Copy_Address : Opaque_Pointer; Initial_Position : constant Stream_Element_Offset := Buffer.CDR_Position; begin Allocate_And_Insert_Cooked_Data (Buffer, Amount, Copy_Address); return Reservation' (Location => Copy_Address, Endianness => Buffer.Endianness, CDR_Position => Initial_Position, Length => Amount); end Reserve; ------------ -- Rewind -- ------------ procedure Rewind (Buffer : access Buffer_Type) is begin Buffer.CDR_Position := Buffer.Initial_CDR_Position; end Rewind; ----------------- -- Send_Buffer -- ----------------- procedure Send_Buffer (Buffer : access Buffer_Type) is procedure Send_Iovec_Pool is new Iovec_Pools.Send_Iovec_Pool (Lowlevel_Send); begin Send_Iovec_Pool (Buffer.Contents'Access, Buffer.Length); end Send_Buffer; ---------------------- -- Set_CDR_Position -- ---------------------- procedure Set_CDR_Position (Buffer : access Buffer_Type; Position : Stream_Element_Offset) is begin Buffer.CDR_Position := Position; end Set_CDR_Position; -------------------- -- Set_Endianness -- -------------------- procedure Set_Endianness (Buffer : access Buffer_Type; E : Endianness_Type) is begin pragma Assert (Buffer.CDR_Position = Buffer.Initial_CDR_Position); Buffer.Endianness := E; end Set_Endianness; -------------------------- -- Set_Initial_Position -- -------------------------- procedure Set_Initial_Position (Buffer : access Buffer_Type; Position : Stream_Element_Offset) is begin pragma Assert (Buffer.Initial_CDR_Position = Buffer.CDR_Position); Buffer.Initial_CDR_Position := Position; Buffer.CDR_Position := Position; end Set_Initial_Position; ---------- -- Show -- ---------- procedure Show (Octets : Zone_Access) is subtype Hexa_Line is String (1 .. 50); subtype ASCII_Line is String (1 .. 17); Hex : constant String := "0123456789ABCDEF"; Nil_Hexa : constant Hexa_Line := (others => ' '); Nil_ASCII : constant ASCII_Line := (others => ' '); Hexa : Hexa_Line := Nil_Hexa; ASCII : ASCII_Line := Nil_ASCII; Index_Hexa : Natural := 1; Index_ASCII : Natural := 1; begin for J in Octets'Range loop Hexa (Index_Hexa) := ' '; Hexa (Index_Hexa + 1) := Hex (Natural (Octets (J) / 16) + 1); Hexa (Index_Hexa + 2) := Hex (Natural (Octets (J) mod 16) + 1); Index_Hexa := Index_Hexa + 3; if Octets (J) < 32 or else Octets (J) > 127 then ASCII (Index_ASCII) := '.'; else ASCII (Index_ASCII) := Character'Val (Natural (Octets (J))); end if; Index_ASCII := Index_ASCII + 1; if Index_Hexa = 25 then Hexa (Index_Hexa) := ' '; Hexa (Index_Hexa + 1) := ' '; Index_Hexa := Index_Hexa + 2; ASCII (Index_ASCII) := ' '; Index_ASCII := Index_ASCII + 1; end if; if Index_Hexa > Hexa'Length then pragma Debug (C2, O2 (Hexa & " " & ASCII)); Index_Hexa := 1; Hexa := Nil_Hexa; Index_ASCII := 1; ASCII := Nil_ASCII; end if; end loop; if Index_Hexa /= 1 then pragma Debug (C2, O2 (Hexa & " " & ASCII)); null; end if; end Show; ---------- -- Show -- ---------- procedure Show (Buffer : access Buffer_Type) is begin pragma Debug (C2, O2 ("Dumping " & Endianness_Type'Image (Buffer.Endianness) & " buffer, CDR position is " & Stream_Element_Offset'Image (Buffer.CDR_Position) & " (length is" & Buffer.Length'Img & ")")); if Buffer.Length = 0 then return; end if; declare Dumped : Zone_Access := To_Stream_Element_Array (Buffer.all); begin Show (Dumped); Free (Dumped); end; end Show; ----------------------------- -- To_Stream_Element_Array -- ----------------------------- function To_Stream_Element_Array (Buffer : Buffer_Type) return Opaque.Zone_Access is Result : Opaque.Zone_Access; begin pragma Assert (Buffer.Initial_CDR_Position = 0); Result := new Stream_Element_Array (1 .. Length (Buffer)); Iovec_Pools.Dump (Buffer.Contents, Result (Result'First)'Address); return Result; end To_Stream_Element_Array; ----------------------------- -- To_Stream_Element_Array -- ----------------------------- function To_Stream_Element_Array (Buffer : Buffer_Type) return Stream_Element_Array is Contents : Zone_Access := To_Stream_Element_Array (Buffer); Result : constant Stream_Element_Array := Contents.all; begin Free (Contents); return Result; end To_Stream_Element_Array; ---------------------- -- Unuse_Allocation -- ---------------------- procedure Unuse_Allocation (Buffer : access Buffer_Type; Size : Stream_Element_Count) is Data : Opaque_Pointer; begin if Size /= 0 then Grow_Shrink (Buffer.Contents'Access, -Size, Data); Buffer.CDR_Position := Buffer.CDR_Position - Size; Buffer.Length := Buffer.Length - Size; end if; end Unuse_Allocation; ----------------- -- Iovec_Pools -- ----------------- package body Iovec_Pools is procedure Free is new Ada.Unchecked_Deallocation (Iovec_Array, Iovec_Array_Access); ---------------------------------------- -- Utility Subprograms (declarations) -- ---------------------------------------- function Is_Dynamic (Iovec_Pool : Iovec_Pool_Type) return Boolean; pragma Inline (Is_Dynamic); -- True iff Iovec pool uses dynamically allocated storage for the Iovecs -- and descriptors. function Iovecs_Address (Iovec_Pool : Iovec_Pool_Type) return System.Address; pragma Inline (Iovecs_Address); -- Returns the address of the first element of Iovec_Pool's Iovec_Array procedure Extend (Iovec_Pool : in out Iovec_Pool_Type; Require : Natural; Allocate : Natural); -- Check the number of available Iovecs in Iovec_Pool and possibly -- extend it. If Iovec_Pool's length is at least Require, then do -- nothing, else make it Allocate Iovecs long. procedure Dump (Iovecs : Iovec_Array; Into : Opaque_Pointer); -- Dump the content of Iovecs into Into ------------ -- Append -- ------------ procedure Append (Iovec_Pool : in out Iovec_Pool_Type; An_Iovec : Iovec; A_Chunk : Buffer_Chunk_Pools.Chunk_Access := null) is New_Last : constant Natural := Iovec_Pool.Last + 1; begin Extend (Iovec_Pool, New_Last, 2 * Iovec_Pool.Length); -- Append new Iovec Iovec_Pool.Last := New_Last; Iovec_Pool.Last_Chunk := A_Chunk; declare Pool_Iovecs_Address : constant System.Address := Iovecs_Address (Iovec_Pool); Pool_Iovecs : Iovec_Array (1 .. Iovec_Pool.Length); for Pool_Iovecs'Address use Pool_Iovecs_Address; pragma Import (Ada, Pool_Iovecs); begin Pool_Iovecs (Iovec_Pool.Last) := An_Iovec; end; end Append; ---------- -- Dump -- ---------- procedure Dump (Iovecs : Iovec_Array; Into : Opaque_Pointer) is Offset : Storage_Offset := 0; begin for J in Iovecs'Range loop declare L : constant Stream_Element_Offset := Stream_Element_Offset (Iovecs (J).Iov_Len); S_Addr : constant System.Address := Iovecs (J).Iov_Base; S : Stream_Element_Array (0 .. L - 1); for S'Address use S_Addr; pragma Import (Ada, S); D_Addr : constant System.Address := Into + Offset; D : Stream_Element_Array (0 .. L - 1); for D'Address use D_Addr; pragma Import (Ada, D); begin D := S; Offset := Offset + Storage_Offset (L); end; end loop; end Dump; ---------- -- Dump -- ---------- procedure Dump (Iovec_Pool : Iovec_Pool_Type; Into : Opaque_Pointer) is Vecs_Address : constant System.Address := Iovecs_Address (Iovec_Pool); Vecs : Iovec_Array (1 .. Iovec_Pool.Last); for Vecs'Address use Vecs_Address; pragma Import (Ada, Vecs); begin Dump (Vecs, Into); end Dump; ------------ -- Extend -- ------------ procedure Extend (Iovec_Pool : in out Iovec_Pool_Type; Require : Natural; Allocate : Natural) is begin pragma Assert (Allocate >= Require); if Require > Iovec_Pool.Length then declare New_Array : constant Iovec_Array_Access := new Iovec_Array (1 .. Allocate); Old_Array_Address : constant System.Address := Iovecs_Address (Iovec_Pool); Old_Array : Iovec_Array (1 .. Iovec_Pool.Length); for Old_Array'Address use Old_Array_Address; pragma Import (Ada, Old_Array); begin New_Array (1 .. Iovec_Pool.Last) := Old_Array (Old_Array'Range); if Is_Dynamic (Iovec_Pool) then Free (Iovec_Pool.Dynamic_Array); end if; Iovec_Pool.Dynamic_Array := New_Array; Iovec_Pool.Length := New_Array'Length; end; end if; end Extend; ------------------ -- Extract_Data -- ------------------ procedure Extract_Data (Iovec_Pool : in out Iovec_Pool_Type; Data : out Opaque_Pointer; Offset : Stream_Element_Offset; Size : in out Stream_Element_Count) is Vecs_Address : constant System.Address := Iovecs_Address (Iovec_Pool); Vecs : Iovec_Array (1 .. Iovec_Pool.Last); for Vecs'Address use Vecs_Address; pragma Import (Ada, Vecs); Offset_Remainder : Storage_Offset := Storage_Offset (Offset); Last_Index : Positive renames Iovec_Pool.Last_Extract_Iovec; Last_Offset : Storage_Offset renames Iovec_Pool.Last_Extract_Iovec_Offset; begin if Offset_Remainder < Last_Offset then Last_Index := 1; Last_Offset := 0; else Offset_Remainder := Offset_Remainder - Last_Offset; end if; while Last_Index <= Vecs'Last and then Offset_Remainder >= Vecs (Last_Index).Iov_Len loop Offset_Remainder := Offset_Remainder - Vecs (Last_Index).Iov_Len; Last_Offset := Last_Offset + Vecs (Last_Index).Iov_Len; Last_Index := Last_Index + 1; end loop; if Last_Index > Vecs'Last then -- Attempt to extract data past end of buffer Data := System.Null_Address; Size := 0; else declare Contiguous_Size : constant Stream_Element_Count := Stream_Element_Count (Vecs (Last_Index).Iov_Len - Offset_Remainder); begin if Size > Contiguous_Size then Size := Contiguous_Size; end if; end; Data := Vecs (Last_Index).Iov_Base + Offset_Remainder; end if; end Extract_Data; ----------------- -- Grow_Shrink -- ----------------- procedure Grow_Shrink (Iovec_Pool : access Iovec_Pool_Type; Size : Stream_Element_Offset; Data : out Opaque_Pointer) is function First_Address_After (An_Iovec : Iovec) return Opaque_Pointer; pragma Inline (First_Address_After); -- Return the address of the storage element immediately following -- the last element of An_Iovec. procedure Do_Grow (Last_Iovec : in out Iovec; Last_Chunk : Chunk_Access); pragma Inline (Do_Grow); -- ??? comment needed ------------- -- Do_Grow -- ------------- procedure Do_Grow (Last_Iovec : in out Iovec; Last_Chunk : Chunk_Access) is begin if Last_Chunk /= null then declare Chunk_Metadata : constant Chunk_Metadata_Access := Metadata (Last_Chunk); begin if False or else (Size > 0 and then Chunk_Metadata.Last_Used + Size <= Last_Chunk.Size) or else (Size < 0 and then Chunk_Metadata.Last_Used + Size >= 0 and then Last_Iovec.Iov_Len + Storage_Offset (Size) >= 0) then Chunk_Metadata.Last_Used := Chunk_Metadata.Last_Used + Size; Data := First_Address_After (Last_Iovec); Last_Iovec.Iov_Len := Last_Iovec.Iov_Len + Storage_Offset (Size); else -- Cannot grow last chunk: leave Data unchanged. pragma Debug (C, O ("Cannot satisfy growth request of size" & Stream_Element_Offset'Image (Size))); null; end if; end; end if; end Do_Grow; ------------------------- -- First_Address_After -- ------------------------- function First_Address_After (An_Iovec : Iovec) return Opaque_Pointer is begin return An_Iovec.Iov_Base + An_Iovec.Iov_Len; end First_Address_After; -- Start of processing for Grow_Shrink begin Data := System.Null_Address; if Iovec_Pool.Last = 0 then -- Empty Iovec pool. return; end if; if Iovec_Pool.Last <= Iovec_Pool.Prealloc_Array'Last then Do_Grow (Iovec_Pool.Prealloc_Array (Iovec_Pool.Last), Iovec_Pool.Last_Chunk); else Do_Grow (Iovec_Pool.Dynamic_Array (Iovec_Pool.Last), Iovec_Pool.Last_Chunk); end if; end Grow_Shrink; -------------------- -- Iovecs_Address -- -------------------- function Iovecs_Address (Iovec_Pool : Iovec_Pool_Type) return System.Address is begin if Is_Dynamic (Iovec_Pool) then return Iovec_Pool.Dynamic_Array (1)'Address; else return Iovec_Pool.Prealloc_Array (1)'Address; end if; end Iovecs_Address; ---------------- -- Is_Dynamic -- ---------------- function Is_Dynamic (Iovec_Pool : Iovec_Pool_Type) return Boolean is begin return Iovec_Pool.Dynamic_Array /= null; end Is_Dynamic; ---------- -- Peek -- ---------- function Peek (Iovec_Pool : Iovec_Pool_Type; Offset : Stream_Element_Offset) return Stream_Element is Vecs_Address : constant System.Address := Iovecs_Address (Iovec_Pool); Iovecs : Iovec_Array (1 .. Iovec_Pool.Last); for Iovecs'Address use Vecs_Address; pragma Import (Ada, Iovecs); Current_Offset : Stream_Element_Offset := 0; begin for J in Iovecs'Range loop declare L : constant Stream_Element_Offset := Stream_Element_Offset (Iovecs (J).Iov_Len); begin if Offset < L + Current_Offset then declare S_Addr : constant System.Address := Iovecs (J).Iov_Base; S : Stream_Element_Array (0 .. L - 1); for S'Address use S_Addr; pragma Import (Ada, S); begin return S (Offset - Current_Offset); end; end if; Current_Offset := Current_Offset + L; end; end loop; raise Constraint_Error; end Peek; ------------------ -- Prepend_Pool -- ------------------ procedure Prepend_Pool (Prefix : Iovec_Pool_Type; Iovec_Pool : in out Iovec_Pool_Type) is New_Last : constant Natural := Iovec_Pool.Last + Prefix.Last; begin Extend (Iovec_Pool, New_Last, New_Last + 1); -- An Iovec pool that has been prefixed will likely not be appended -- to anymore. declare Prefix_Iovecs_Address : constant System.Address := Iovecs_Address (Prefix); Prefix_Iovecs : Iovec_Array (1 .. Prefix.Length); for Prefix_Iovecs'Address use Prefix_Iovecs_Address; pragma Import (Ada, Prefix_Iovecs); Pool_Iovecs_Address : constant System.Address := Iovecs_Address (Iovec_Pool); Pool_Iovecs : Iovec_Array (1 .. Iovec_Pool.Length); for Pool_Iovecs'Address use Pool_Iovecs_Address; pragma Import (Ada, Pool_Iovecs); begin -- Append new Iovec Pool_Iovecs (1 .. New_Last) := Prefix_Iovecs (Prefix_Iovecs'Range) & Pool_Iovecs (1 .. Iovec_Pool.Last); Iovec_Pool.Last := New_Last; end; end Prepend_Pool; ------------- -- Release -- ------------- procedure Release (Iovec_Pool : in out Iovec_Pool_Type) is begin if Is_Dynamic (Iovec_Pool) then Free (Iovec_Pool.Dynamic_Array); end if; Iovec_Pool.Last := 0; Iovec_Pool.Length := Iovec_Pool.Prealloc_Array'Length; Iovec_Pool.Last_Extract_Iovec := 1; Iovec_Pool.Last_Extract_Iovec_Offset := 0; end Release; --------------------- -- Send_Iovec_Pool -- --------------------- procedure Send_Iovec_Pool (Iovec_Pool : access Iovec_Pool_Type; Length : Stream_Element_Count) is Vecs_Address : constant System.Address := Iovecs_Address (Iovec_Pool.all); Vecs : Iovec_Array (1 .. Iovec_Pool.Last); for Vecs'Address use Vecs_Address; pragma Import (Ada, Vecs); Index : Natural := Vecs'First; Count : Storage_Offset; Remainder : Storage_Offset := Storage_Offset (Length); -- Number of Stream_Elements yet to be written. begin while Remainder > 0 loop Lowlevel_Send (Vecs (1)'Access, Vecs'Last - Index + 1, Count); while Index <= Vecs'Last and then Count >= Vecs (Index).Iov_Len loop Remainder := Remainder - Vecs (Index).Iov_Len; Count := Count - Vecs (Index).Iov_Len; Index := Index + 1; end loop; if Count > 0 then Vecs (Index).Iov_Base := Vecs (Index).Iov_Base + Count; Vecs (Index).Iov_Len := Vecs (Index).Iov_Len - Count; end if; end loop; end Send_Iovec_Pool; end Iovec_Pools; end PolyORB.Buffers; polyorb-2.8~20110207.orig/src/polyorb-exceptions.adb0000644000175000017500000004453411750740340021520 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . E X C E P T I O N S -- -- -- -- B o d y -- -- -- -- Copyright (C) 2002-2009, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with Ada.Unchecked_Conversion; with Ada.Characters.Latin_1; pragma Warnings (Off); with System.Exception_Table; with System.Standard_Library; pragma Warnings (On); -- Mapping between exception names and exception ids. -- GNAT internal exception table is used to maintain a list of all exceptions. with PolyORB.Initialization; with PolyORB.Log; with PolyORB.Tasking.Mutexes; with PolyORB.Utils.Chained_Lists; with PolyORB.Utils.Strings; package body PolyORB.Exceptions is use Ada.Exceptions; use PolyORB.Any; use PolyORB.Log; use PolyORB.Tasking.Mutexes; use PolyORB.Types; use PolyORB.Utils; package L is new PolyORB.Log.Facility_Log ("polyorb.exceptions"); procedure O (Message : Standard.String; Level : Log_Level := Debug) renames L.Output; function C (Level : Log_Level := Debug) return Boolean renames L.Enabled; ----------------------------- -- User exception handling -- ----------------------------- type Exception_Info is record TC : PolyORB.Any.TypeCode.Local_Ref; Raiser : Raise_From_Any_Procedure; end record; package Exception_Lists is new PolyORB.Utils.Chained_Lists (Exception_Info); function Find_Exception_Info (For_Exception : PolyORB.Types.RepositoryId) return Exception_Info; -- Return Exception_Info associated to 'For_Exception' All_Exceptions : Exception_Lists.List; -- Exception list, use to associate an exception typecode with a raiser -- function that retrieves member data from an Any and raises the exception -- with the appropriate information in the occurrence. All_Exceptions_Lock : Mutex_Access; -- Mutex used to safely access All_Exceptions list. -- When an exception with members is raised (Raise_Exception), we allocate -- an exception occurrence id and attach to the exception occurrence a -- message with a magic string and the id. The member is stored in dynamic -- structure with the id. When we call Get_Members, we retrieve the -- exception occurrence id from the attached message. The member may have -- been removed in the meantime if too many exceptions were raised between -- the call to Raise_Exception and Get_Members (very rare). We have to keep -- the list size in a max size because the user may not retrieve the member -- of an exception with members. In this case, the members will never be -- deallocated. This limit forces some kind of garbage collection. -- If exception is raised with optional user defined message then this -- message is appended to exception occurrence message after a magic string -- and the id, separating from id by the LF character. This character is -- used to detect the end of id. Magic : constant String := "PO_Exc_Occ"; type Exc_Occ_Id_Type is new Natural; Seed_Id : Exc_Occ_Id_Type := 1; Null_Id : constant Exc_Occ_Id_Type := 0; type Exc_Occ_Node is record Id : Exc_Occ_Id_Type; Mbr : Exception_Members_Access; Msg : Types.String; end record; package Exc_Occ_Lists is new PolyORB.Utils.Chained_Lists (Exc_Occ_Node, Doubly_Chained => True); use Exc_Occ_Lists; Exc_Occ_List : Exc_Occ_Lists.List; Exc_Occ_Lock : Mutex_Access; -- Mutex used to safely access Exc_Occ list Max_Exc_Occ_List_Size : constant Natural := 100; function Image (V : Exc_Occ_Id_Type) return String; -- Store the magic string and the exception occurrence id function Value (M : String) return Exc_Occ_Id_Type; -- Extract the exception occurrence id from the exception message. Return -- Null_Id if the exception message has no the expected format. procedure Dump_All_Occurrences; -- Dump the occurrence list (not protected) procedure Get_Or_Purge_Members (Exc_Occ : Ada.Exceptions.Exception_Occurrence; Exc_Mbr : out Exception_Members'Class; Get_Members : Boolean); -- Internal implementation of Get_Members and Purge_Members. If Get_Members -- is true, the retrieved members object is assigned to Exc_Mbr, else the -- object is discarded and no assignment is made. function Get_ExcepId_By_RepositoryId (RepoId : Standard.String) return Ada.Exceptions.Exception_Id; -- Return the corresponding Ada Exception_Id for a repository id -------------------------- -- Dump_All_Occurrences -- -------------------------- procedure Dump_All_Occurrences is It : Iterator := First (Exc_Occ_List); begin O ("Dump_All_Occurrences:"); if Is_Empty (Exc_Occ_List) then O ("No stored exceptions."); return; end if; while not Last (It) loop O (" " & Image (Value (It).all.Id)); Next (It); end loop; end Dump_All_Occurrences; -------------------------- -- Get_Or_Purge_Members -- -------------------------- procedure Get_Or_Purge_Members (Exc_Occ : Ada.Exceptions.Exception_Occurrence; Exc_Mbr : out Exception_Members'Class; Get_Members : Boolean) is Exc_Occ_Id : Exc_Occ_Id_Type; It : Iterator; begin Enter (Exc_Occ_Lock); pragma Debug (C, O ("Get_Members: " & Ada.Exceptions.Exception_Name (Exc_Occ))); pragma Debug (C, O (" message: " & Ada.Exceptions.Exception_Message (Exc_Occ))); pragma Debug (Dump_All_Occurrences); -- If Exc_Occ_Id = Null_Id, the exception has no member Exc_Occ_Id := Value (Ada.Exceptions.Exception_Message (Exc_Occ)); if Exc_Occ_Id = Null_Id then Leave (Exc_Occ_Lock); return; end if; -- Scan the list using the exception occurrence id It := First (Exc_Occ_List); while not Last (It) loop exit when Value (It).all.Id = Exc_Occ_Id; Next (It); end loop; if Value (It).all.Id /= Exc_Occ_Id then Leave (Exc_Occ_Lock); -- Too many exceptions were raised and this member is no longer -- available. -- PolyORB.Exceptions.Raise_Imp_Limit; raise Program_Error; end if; -- Update out parameter if Get_Members then Exc_Mbr := Value (It).all.Mbr.all; -- May raise Constraint_Error if the tags do not match end if; -- Remove member from list Free (Value (It).all.Mbr); Remove (Exc_Occ_List, It); Leave (Exc_Occ_Lock); exception when others => -- Remove member from list Free (Value (It).all.Mbr); Remove (Exc_Occ_List, It); Leave (Exc_Occ_Lock); raise; end Get_Or_Purge_Members; ----------- -- Image -- ----------- function Image (V : Exc_Occ_Id_Type) return String is begin return Magic & Exc_Occ_Id_Type'Image (V); end Image; ----------- -- Value -- ----------- function Value (M : String) return Exc_Occ_Id_Type is V : Exc_Occ_Id_Type := 0; N : Natural := M'First; begin if M'Length <= Magic'Length + 1 then return Null_Id; end if; -- Look for the magic string for J in Magic'Range loop if Magic (J) /= M (N) then return Null_Id; end if; N := N + 1; end loop; if M (N) /= ' ' then return Null_Id; end if; N := N + 1; -- Scan the exception occurrence id until end of id or LF character is -- found. while N <= M'Last and then M (N) /= Ada.Characters.Latin_1.LF loop if M (N) not in '0' .. '9' then return Null_Id; end if; V := V * 10 + Character'Pos (M (N)) - Character'Pos ('0'); N := N + 1; end loop; return V; end Value; ---------------------- -- User_Get_Members -- ---------------------- procedure User_Get_Members (Occurrence : Ada.Exceptions.Exception_Occurrence; Members : out Exception_Members'Class) is begin Get_Or_Purge_Members (Occurrence, Members, Get_Members => True); end User_Get_Members; ------------------------ -- User_Purge_Members -- ------------------------ procedure User_Purge_Members (Occurrence : Ada.Exceptions.Exception_Occurrence) is begin declare Dummy : System_Exception_Members; begin Get_Or_Purge_Members (Occurrence, Dummy, Get_Members => False); exception when others => null; end; end User_Purge_Members; -------------------------- -- User_Raise_Exception -- -------------------------- procedure User_Raise_Exception (Id : Ada.Exceptions.Exception_Id; Members : Exception_Members'Class; Message : String := "") is New_Node : Exc_Occ_Node; begin Enter (Exc_Occ_Lock); -- Keep the list size to a max size. Otherwise, remove the oldest member -- (first in the list). if Length (Exc_Occ_List) = Max_Exc_Occ_List_Size then Extract_First (Exc_Occ_List, New_Node); Free (New_Node.Mbr); end if; pragma Debug (C, O ("Assigning ID: " & Image (Seed_Id))); pragma Debug (Dump_All_Occurrences); -- Generate a fresh exception occurrence id New_Node.Id := Seed_Id; New_Node.Mbr := new Exception_Members'Class'(Members); New_Node.Msg := To_PolyORB_String (Message); if Seed_Id = Exc_Occ_Id_Type'Last then Seed_Id := Null_Id; end if; Seed_Id := Seed_Id + 1; -- Append to the list Append (Exc_Occ_List, New_Node); pragma Debug (C, O ("Raise (" & Ada.Exceptions.Exception_Name (Id) & ", " & Image (New_Node.Id) & ").")); pragma Debug (Dump_All_Occurrences); Leave (Exc_Occ_Lock); if Message = "" then Ada.Exceptions.Raise_Exception (Id, Image (New_Node.Id)); else Ada.Exceptions.Raise_Exception (Id, Image (New_Node.Id) & Ada.Characters.Latin_1.LF & Message); end if; raise Program_Error; end User_Raise_Exception; ----------------------------------- -- Raise_User_Exception_From_Any -- ----------------------------------- procedure Raise_User_Exception_From_Any (Repository_Id : PolyORB.Types.RepositoryId; Occurence : PolyORB.Any.Any; Message : Standard.String := "") is begin Find_Exception_Info (Repository_Id).Raiser.all (Occurence, Message); end Raise_User_Exception_From_Any; ---------------------------- -- Default_Raise_From_Any -- ---------------------------- procedure Default_Raise_From_Any (Occurrence : Any.Any) is begin if not Is_Empty (Occurrence) then Ada.Exceptions.Raise_Exception (Get_ExcepId_By_RepositoryId (To_Standard_String (TypeCode.Id (Get_Type_Obj (Occurrence))))); end if; end Default_Raise_From_Any; ------------------------ -- Register_Exception -- ------------------------ procedure Register_Exception (TC : PolyORB.Any.TypeCode.Local_Ref; Raiser : Raise_From_Any_Procedure) is begin pragma Debug (C, O ("Registering exception: " & Types.To_Standard_String (TypeCode.Id (TC)))); Enter (All_Exceptions_Lock); Exception_Lists.Append (All_Exceptions, (TC => TC, Raiser => Raiser)); Leave (All_Exceptions_Lock); end Register_Exception; ------------------------- -- Find_Exception_Info -- ------------------------- function Find_Exception_Info (For_Exception : PolyORB.Types.RepositoryId) return Exception_Info is use Exception_Lists; Id : constant Types.RepositoryId := For_Exception; It : Exception_Lists.Iterator; Info : Exception_Info; begin pragma Debug (C, O ("Looking up einfo for " & To_Standard_String (For_Exception))); Enter (All_Exceptions_Lock); It := First (All_Exceptions); while not Last (It) loop exit when PolyORB.Any.TypeCode.Id (Value (It).TC) = Id; Next (It); end loop; if Last (It) then Leave (All_Exceptions_Lock); pragma Debug (C, O ("no einfo found, returning 'Unknown' exception")); -- Raise_Unknown; end if; Info := Value (It).all; Leave (All_Exceptions_Lock); return Info; end Find_Exception_Info; --------------------------------- -- Exception utility functions -- --------------------------------- -------------------- -- Exception_Name -- -------------------- function Exception_Name (Repository_Id : Standard.String) return Standard.String is Colon1 : constant Integer := Find (Repository_Id, Repository_Id'First, ':'); Colon2 : constant Integer := Find (Repository_Id, Colon1 + 1, ':'); begin pragma Debug (C, O ("Exception_Name " & Repository_Id)); if Repository_Id'First <= Colon1 and then Colon1 <= Colon2 and then Colon2 <= Repository_Id'Last then return Repository_Id (Colon1 + 1 .. Colon2 - 1); else return Repository_Id; end if; end Exception_Name; -------------------------------- -- Exception_Name_To_Error_Id -- -------------------------------- procedure Exception_Name_To_Error_Id (Name : String; Is_Error : out Boolean; Id : out Error_Id) is Prefix_Length : constant Natural := PolyORB_Exc_Prefix'Length; Version_Length : constant Natural := PolyORB_Exc_Version'Length; begin if Name'Length > Prefix_Length + Version_Length and then Name (Name'First .. Name'First + Prefix_Length - 1) = PolyORB_Exc_Prefix then declare Error_Id_Name : constant String := Name (Name'First + Prefix_Length .. Name'Last - Version_Length) & "_E"; begin pragma Debug (C, O ("Error_Id_Name : " & Error_Id_Name)); Is_Error := True; Id := Error_Id'Value (Error_Id_Name); end; else Is_Error := False; Id := No_Error; end if; pragma Debug (C, O (Name & " is a PolyORB error ? " & Boolean'Image (Is_Error))); end Exception_Name_To_Error_Id; ------------------------- -- Get_ExcepId_By_Name -- ------------------------- function Get_ExcepId_By_Name (Name : Standard.String) return Ada.Exceptions.Exception_Id is function To_Exception_Id is new Ada.Unchecked_Conversion (System.Standard_Library.Exception_Data_Ptr, Ada.Exceptions.Exception_Id); Internal_Name : String := Name; begin if Internal_Name = "" then return Ada.Exceptions.Null_Id; end if; for J in Internal_Name'Range loop if Internal_Name (J) = '/' then Internal_Name (J) := '.'; end if; end loop; pragma Debug (C, O ("Exception Id : " & Internal_Name)); return To_Exception_Id (System.Exception_Table.Internal_Exception (Internal_Name)); end Get_ExcepId_By_Name; --------------------------------- -- Get_ExcepId_By_RepositoryId -- --------------------------------- function Get_ExcepId_By_RepositoryId (RepoId : Standard.String) return Ada.Exceptions.Exception_Id is begin return Get_ExcepId_By_Name (Exception_Name (RepoId)); end Get_ExcepId_By_RepositoryId; ------------------------ -- Occurrence_To_Name -- ------------------------ function Occurrence_To_Name (Occurrence : Ada.Exceptions.Exception_Occurrence) return String is Name : String := Ada.Exceptions.Exception_Name (Occurrence); begin for J in Name'Range loop if Name (J) = '.' then Name (J) := '/'; end if; end loop; return Name; end Occurrence_To_Name; ---------------- -- Initialize -- ---------------- procedure Initialize; procedure Initialize is begin Create (All_Exceptions_Lock); Create (Exc_Occ_Lock); end Initialize; use PolyORB.Initialization; use PolyORB.Initialization.String_Lists; use PolyORB.Utils.Strings; begin Register_Module (Module_Info' (Name => +"exceptions", Conflicts => PolyORB.Initialization.String_Lists.Empty, Depends => +"tasking.mutexes", Provides => PolyORB.Initialization.String_Lists.Empty, Implicit => False, Init => Initialize'Access, Shutdown => null)); end PolyORB.Exceptions; polyorb-2.8~20110207.orig/src/soap/0000755000175000017500000000000011750740340016133 5ustar xavierxavierpolyorb-2.8~20110207.orig/src/soap/polyorb-soap_p-message-response-error.adb0000644000175000017500000001552211750740340026162 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- POLYORB.SOAP_P.MESSAGE.RESPONSE.ERROR -- -- -- -- B o d y -- -- -- -- Copyright (C) 2000-2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with PolyORB.Any; use PolyORB.Any; with PolyORB.Types; use PolyORB.Types; with PolyORB.SOAP_P.Types; package body PolyORB.SOAP_P.Message.Response.Error is Version_Mismatch_Faultcode : constant String := "VersionMismatch"; Must_Understand_Faultcode : constant String := "MustUnderstand"; Client_Faultcode : constant String := "Client"; Server_Faultcode : constant String := "Server"; Start_Fault_Env : constant String := ""; End_Fault_Env : constant String := ""; Start_Faultcode : constant String := ""; End_Faultcode : constant String := ""; Start_Faultstring : constant String := ""; End_Faultstring : constant String := ""; pragma Warnings (Off); pragma Unreferenced (Start_Faultcode, End_Faultcode, Start_Faultstring, End_Faultstring); pragma Warnings (On); function Fault_Code (Name, Subname : String) return Faultcode; -- Returns the Faultcode for Name and Subname. If Subname is empty it -- returns Name otherwise it returns Name & '.' & Subname. ----------- -- Build -- ----------- function Build (Faultcode : Error.Faultcode; Faultstring : String) return Object is use SOAP_P.Types; use type SOAP_P.Parameters.List; O : Object; P : SOAP_P.Parameters.List; begin -- Set Wrapper Name Set_Wrapper_Name (O, "Fault"); -- Set Faultcode and Faultstring P := +NamedValue' (To_PolyORB_String ("faultcode"), To_Any (To_PolyORB_String (String (Faultcode))), ARG_IN) & NamedValue' (To_PolyORB_String ("faultstring"), To_Any (To_PolyORB_String (Faultstring)), ARG_IN); -- Set parameters for this error object Set_Parameters (O, P); return O; end Build; ------------ -- Client -- ------------ function Client (Subname : String := "") return Faultcode is begin return Fault_Code (Client_Faultcode, Subname); end Client; ---------------- -- Fault_Code -- ---------------- function Fault_Code (Name, Subname : String) return Faultcode is begin if Subname = "" then return Faultcode (Name); else return Faultcode (Name & '.' & Subname); end if; end Fault_Code; ---------- -- From -- ---------- function From (P : Message.Payload.Object) return Object is pragma Warnings (Off); pragma Unreferenced (P); pragma Warnings (On); N : Object; pragma Warnings (Off, N); -- Not initialized. -- XXX check whether any information from P should -- be included in N. begin return N; end From; -------------- -- Is_Error -- -------------- function Is_Error (E : Object) return Boolean is pragma Warnings (Off); pragma Unreferenced (E); pragma Warnings (On); begin return True; end Is_Error; --------------------- -- Must_Understand -- --------------------- function Must_Understand (Subname : String := "") return Faultcode is begin return Fault_Code (Must_Understand_Faultcode, Subname); end Must_Understand; ------------ -- Server -- ------------ function Server (Subname : String := "") return Faultcode is begin return Fault_Code (Server_Faultcode, Subname); end Server; ---------------------- -- Version_Mismatch -- ---------------------- function Version_Mismatch (Subname : String := "") return Faultcode is begin return Fault_Code (Version_Mismatch_Faultcode, Subname); end Version_Mismatch; --------------- -- XML_Image -- --------------- function XML_Image (E : Object) return Unbounded_String is NL : constant String := ASCII.CR & ASCII.LF; Message_Body : Unbounded_String; begin -- Fault Env Append (Message_Body, Start_Fault_Env & NL); -- Fault's parameters declare P : constant SOAP_P.Parameters.List := Parameters (E); begin for K in 1 .. SOAP_P.Parameters.Argument_Count (P) loop declare P_K : constant PolyORB.Any.NamedValue := SOAP_P.Parameters.Argument (P, K); P_Name : constant String := SOAP_P.Types.Name (P_K); begin Append (Message_Body, " " & Tag (P_Name, Start => True) & Types.Value_Image (P_K) & Tag (P_Name, Start => False) & NL); end; end loop; end; -- End Fault Env Append (Message_Body, End_Fault_Env & NL); return Message_Body; end XML_Image; end PolyORB.SOAP_P.Message.Response.Error; polyorb-2.8~20110207.orig/src/soap/polyorb-soap_p-parameters.adb0000644000175000017500000001527611750740340023724 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . S O A P _ P . P A R A M E T E R S -- -- -- -- B o d y -- -- -- -- Copyright (C) 2001-2007, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with PolyORB.Types; with PolyORB.SOAP_P.Types; package body PolyORB.SOAP_P.Parameters is use PolyORB.Any; use PolyORB.Any.NVList; use PolyORB.Any.NVList.Internals; use PolyORB.Any.NVList.Internals.NV_Lists; function Argument_Count (P : List) return Natural is begin return Natural (Get_Count (Ref (P))); end Argument_Count; function Argument (P : List; Name : String) return NamedValue is use PolyORB.Types; Arg_Id : constant Identifier := To_PolyORB_String (Name); It : Iterator := First (List_Of (Ref (P)).all); begin while not Last (It) loop if Value (It).Name = Arg_Id then return Value (It).all; end if; Next (It); end loop; raise SOAP_P.Types.Data_Error; end Argument; function Argument (P : List; N : Positive) return NamedValue is begin return Element (List_Of (Ref (P)).all, N - 1).all; exception when others => raise SOAP_P.Types.Data_Error; end Argument; function Exist (P : List; Name : String) return Boolean is begin declare NV : constant NamedValue := Argument (P, Name); begin pragma Warnings (Off, NV); -- Not referenced. We are only interested in knowing -- whether the call to Argument raised an exception. return True; end; exception when SOAP_P.Types.Data_Error => return False; end Exist; function Get (P : List; Name : String) return Integer is begin return Integer (PolyORB.Types.Long'(From_Any (Argument (P, Name).Argument))); end Get; function Get (P : List; Name : String) return Long_Float is begin return Long_Float (PolyORB.Types.Double'(From_Any (Argument (P, Name).Argument))); end Get; function Get (P : List; Name : String) return String is begin return PolyORB.Types.To_Standard_String (From_Any (Argument (P, Name).Argument)); end Get; function Get (P : List; Name : String) return Boolean is begin return From_Any (Argument (P, Name).Argument); end Get; -- function Get (P : List; Name : String) return Types.SOAP_Record; -- -- Returns parameter named Name in P as a SOAP Struct value. Raises -- -- Types.Data_Error if this parameter does not exist or is not a SOAP -- -- Struct. -- function Get (P : List; Name : String) return Types.SOAP_Array; -- -- Returns parameter named Name in P as a SOAP Array value. Raises -- -- Types.Data_Error if this parameter does not exist or is not a SOAP -- -- Array. ------------------ -- Constructors -- ------------------ function "&" (P : List; O : NamedValue) return List is Res : constant List := P; begin Append (List_Of (Ref (Res)).all, O); return Res; end "&"; function "+" (O : NamedValue) return List is Res : Ref; begin Create (Res); Add_Item (Res, O); return List'(Res with null record); end "+"; ---------------- -- Validation -- ---------------- procedure Check (P : List; N : Natural) is begin if Argument_Count (P) /= N then raise SOAP_P.Types.Data_Error; end if; end Check; procedure Check_Typecode_Kind (P : List; Name : String; Tk : PolyORB.Any.TCKind); procedure Check_Typecode_Kind (P : List; Name : String; Tk : PolyORB.Any.TCKind) is begin if PolyORB.Any.TypeCode.Kind (Get_Type (Argument (P, Name).Argument)) /= Tk then raise SOAP_P.Types.Data_Error; end if; end Check_Typecode_Kind; procedure Check_Integer (P : List; Name : String) is begin Check_Typecode_Kind (P, Name, Tk_Long); end Check_Integer; procedure Check_Float (P : List; Name : String) is begin Check_Typecode_Kind (P, Name, Tk_Double); end Check_Float; procedure Check_Boolean (P : List; Name : String) is begin Check_Typecode_Kind (P, Name, Tk_Boolean); end Check_Boolean; procedure Check_Time_Instant (P : List; Name : String) is begin -- XXX ??? raise SOAP_P.Types.Data_Error; end Check_Time_Instant; procedure Check_Base64 (P : List; Name : String) is begin -- XXX ??? raise SOAP_P.Types.Data_Error; end Check_Base64; procedure Check_Null (P : List; Name : String) is begin -- XXX ??? raise SOAP_P.Types.Data_Error; end Check_Null; procedure Check_Record (P : List; Name : String) is begin Check_Typecode_Kind (P, Name, Tk_Struct); end Check_Record; procedure Check_Array (P : List; Name : String) is begin Check_Typecode_Kind (P, Name, Tk_Array); end Check_Array; end PolyORB.SOAP_P.Parameters; polyorb-2.8~20110207.orig/src/soap/polyorb-soap_p.ads0000644000175000017500000000515711750740340021601 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . S O A P _ P -- -- -- -- S p e c -- -- -- -- Copyright (C) 2000-2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- This package hierarchy is taken from the SOAP implementation of AWS. -- Original authors: Pascal Obry and Dmitry Anisimkov. package PolyORB.SOAP_P is SOAP_Error : exception; -- Will be raised when an error occurs in the SOAP implementation. The -- exception message will described the problem. Version : constant String := "0.8"; private function Tag (Name : String; Start : Boolean) return String; -- Returns XML tag named Name. If Start is True then an XML start element -- is returned otherwise an XML end element is returned. -- (From AWS' SOAP.Utils) end PolyORB.SOAP_P; polyorb-2.8~20110207.orig/src/soap/polyorb-soap_p-types.adb0000644000175000017500000006103411750740340022716 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . S O A P _ P . T Y P E S -- -- -- -- B o d y -- -- -- -- Copyright (C) 2000-2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with Ada.Long_Float_Text_IO; with Ada.Exceptions; with Ada.Strings.Fixed; with Ada.Strings.Unbounded; with PolyORB.Any.ObjRef; with PolyORB.Errors; with PolyORB.References; with PolyORB.References.Binding; with PolyORB.Binding_Data.SOAP; with PolyORB.Log; with PolyORB.Types; package body PolyORB.SOAP_P.Types is use Ada; use PolyORB.Types; use PolyORB.Log; package L is new PolyORB.Log.Facility_Log ("soap.types"); procedure O (Message : String; Level : Log_Level := Debug) renames L.Output; function C (Level : Log_Level := Debug) return Boolean renames L.Enabled; function xsi_type (Name : String) return String; -- Returns the xsi:type field for the XML type representation whose name -- is passed as argument. -- --------- -- -- "+" -- -- --------- -- function "+" (O : Object'Class) return Object_Controlled is -- begin -- return (Finalization.Controlled with new Object'Class'(O)); -- end "+"; -- ------- -- -- A -- -- ------- -- function A -- (V : Object_Set; -- Name : String) -- return SOAP_Array is -- begin -- return (To_Unbounded_String (Name), -- (Finalization.Controlled with new Object_Set'(V))); -- end A; -- ------------ -- -- Adjust -- -- ------------ -- procedure Adjust (O : in out Object_Controlled) is -- begin -- if NV.O /= null then -- NV.O := new Object'Class'(NV.NV.all); -- end if; -- end Adjust; -- procedure Adjust (O : in out Object_Set_Controlled) is -- begin -- if NV.O /= null then -- NV.O := new Object_Set'(NV.NV.all); -- end if; -- end Adjust; -- ------- -- -- B -- -- ------- -- function B -- (V : Boolean; -- Name : String := "item") -- return XSD_Boolean is -- begin -- return (To_Unbounded_String (Name), V); -- end B; -- --------- -- -- B64 -- -- --------- -- function B64 -- (V : String; -- Name : String := "item") -- return SOAP_Base64 is -- begin -- return (To_Unbounded_String (Name), To_Unbounded_String (V)); -- end B64; -- ------- -- -- F -- -- ------- -- function F -- (V : Long_Float; -- Name : String := "item") -- return XSD_Float is -- begin -- return (To_Unbounded_String (Name), V); -- end F; -- -------------- -- -- Finalize -- -- -------------- -- procedure Finalize (O : in out Object_Controlled) is -- procedure Free is -- new Ada.Unchecked_Deallocation (Object'Class, Object_Access); -- begin -- if NV.O /= null then -- Free (NV.O); -- end if; -- end Finalize; -- procedure Finalize (O : in out Object_Set_Controlled) is -- procedure Free is -- new Ada.Unchecked_Deallocation (Object_Set, Object_Set_Access); -- begin -- if NV.O /= null then -- Free (NV.O); -- end if; -- end Finalize; function TCK (A : PolyORB.Any.Any) return TCKind; pragma Warnings (Off); pragma Unreferenced (TCK); pragma Warnings (On); function UTCK (A : PolyORB.Any.Any) return TCKind; -- Return the typecode kind of A. UTCK returns the -- kind after unwinding all levels of typedef. function TCK (A : PolyORB.Any.Any) return TCKind is begin return TypeCode.Kind (Get_Type (A)); end TCK; function UTCK (A : PolyORB.Any.Any) return TCKind is begin return TypeCode.Kind (Get_Unwound_Type (A)); end UTCK; --------- -- Get -- --------- function Get (NV : NamedValue) return Integer is Kind : constant TCKind := UTCK (NV.Argument); begin case Kind is when Tk_Short => return Integer (Short'(From_Any (NV.Argument))); when Tk_Long => return Integer (Long'(From_Any (NV.Argument))); when Tk_Ushort => return Integer (Unsigned_Short'(From_Any (NV.Argument))); when Tk_Ulong => return Integer (Unsigned_Long'(From_Any (NV.Argument))); when Tk_Octet => return Integer (Octet'(From_Any (NV.Argument))); when others => Ada.Exceptions.Raise_Exception (Data_Error'Identity, "Integer expected, found " & TCKind'Image (Kind)); end case; end Get; function Get (NV : NamedValue) return Long_Float is Kind : constant TCKind := UTCK (NV.Argument); begin case Kind is when Tk_Float => return Long_Float (PolyORB.Types.Float'(From_Any (NV.Argument))); when Tk_Double => return Long_Float (PolyORB.Types.Double'(From_Any (NV.Argument))); when others => Ada.Exceptions.Raise_Exception (Data_Error'Identity, "Float expected, found " & TCKind'Image (Kind)); end case; end Get; function Get (NV : NamedValue) return String is Kind : constant TCKind := UTCK (NV.Argument); begin case Kind is when Tk_String => return To_Standard_String (From_Any (NV.Argument)); when Tk_Char => return (1 => PolyORB.Types.Char'(From_Any (NV.Argument))); when others => Ada.Exceptions.Raise_Exception (Data_Error'Identity, "String/character expected, found " & TCKind'Image (Kind)); end case; end Get; function Get (NV : NamedValue) return Boolean is Kind : constant TCKind := UTCK (NV.Argument); begin case Kind is when Tk_Boolean => return From_Any (NV.Argument); when others => Ada.Exceptions.Raise_Exception (Data_Error'Identity, "Boolean expected, found " & TCKind'Image (Kind)); end case; end Get; -- function Get (NV : NamedValue) return SOAP_Record is -- begin -- if O'Tag = Types.SOAP_Record'Tag then -- return SOAP_Record (O); -- else -- Exceptions.Raise_Exception -- (Data_Error'Identity, -- "SOAP Struct expected, found " -- & TCKind'Image (TCK (NV.Argument))); -- end if; -- end Get; -- function Get (NV : NamedValue) return SOAP_Array is -- begin -- if O'Tag = Types.SOAP_Array'Tag then -- return SOAP_Array (O); -- else -- Exceptions.Raise_Exception -- (Data_Error'Identity, -- "SOAP Array expected, found " -- & TCKind'Image (TCK (NV.Argument))); -- end if; -- end Get; -- ------- -- -- I -- -- ------- -- function I -- (V : Integer; -- Name : String := "item") -- return XSD_Integer is -- begin -- return (To_Unbounded_String (Name), V); -- end I; -- ----------- -- -- Image -- -- ----------- function Value_Image (NV : NamedValue) return String is TC : constant TypeCode.Object_Ptr := Get_Unwound_Type (NV.Argument); Kind : constant TCKind := TypeCode.Kind (TC); begin pragma Debug (C, O ("Image: enter, Kind is " & TCKind'Image (Kind))); case Kind is when Tk_Long | Tk_Short | Tk_Ulong | Tk_Ushort | Tk_Octet => return PolyORB.Types.Trimmed_Image (Long_Long (Integer'(Get (NV)))); when Tk_Float | Tk_Double => declare Result : String (1 .. Long_Float'Width); begin Long_Float_Text_IO.Put (Result, Get (NV), Exp => 0); return Strings.Fixed.Trim (Result, Strings.Both); end; when Tk_String | Tk_Char => return Get (NV); when Tk_Boolean => if Get (NV) then return "1"; else return "0"; end if; when Tk_Enum => return To_Standard_String (TypeCode.Enumerator_Name (TC, Get_Aggregate_Element (NV.Argument, 0))); when Tk_Void => return ""; when others => -- XXX ??? return "Image: Unsupported TCKind:" & TCKind'Image (Kind); end case; end Value_Image; -- function Image (O : XSD_Time_Instant) return String is -- function Image (Timezone : TZ) return String; -- -- Returns Image for the TZ -- function Image (Timezone : TZ) return String is -- subtype Str2 is String (1 .. 2); -- function I2D (N : Natural) return Str2; -- function I2D (N : Natural) return Str2 is -- V : constant String := Natural'Image (N); -- begin -- if N > 9 then -- return V (V'First + 1 .. V'Last); -- else -- return '0' & V (V'First + 1 .. V'Last); -- end if; -- end I2D; -- begin -- if Timezone >= 0 then -- return '+' & I2D (Timezone) & ":00"; -- else -- return '-' & I2D (abs Timezone) & ":00"; -- end if; -- end Image; -- begin -- return GNAT.Calendar.Time_IO.Image (NV.T, "%Y-%m-%dT%H:%M:%S") -- & Image (NV.Timezone); -- end Image; -- function Image (O : SOAP_Base64) return String is -- begin -- return To_String (NV.V); -- end Image; -- function Image (O : SOAP_Array) return String is -- Result : Unbounded_String; -- begin -- Append (Result, '('); -- for K in NV.Items.O'Range loop -- Append (Result, Integer'Image (K)); -- Append (Result, " => "); -- Append (Result, Image (NV.Items.O (K).NV.all)); -- if K /= NV.Items.O'Last then -- Append (Result, ", "); -- end if; -- end loop; -- Append (Result, ')'); -- return To_String (Result); -- end Image; -- function Image (O : SOAP_Record) return String is -- Result : Unbounded_String; -- begin -- Append (Result, '('); -- for K in NV.Items.O'Range loop -- Append (Result, Name (O)); -- Append (Result, " => "); -- Append (Result, Image (NV.Items.O (K).NV.all)); -- if K /= NV.Items.O'Last then -- Append (Result, ", "); -- end if; -- end loop; -- Append (Result, ')'); -- return To_String (Result); -- end Image; -- ------- -- -- N -- -- ------- -- function N (Name : String := "item") return XSD_Null is -- begin -- return (Name => To_Unbounded_String (Name)); -- end N; ---------- -- Name -- ---------- function Name (NV : NamedValue) return String is begin return To_Standard_String (NV.Name); end Name; -- ------- -- -- R -- -- ------- -- function R -- (V : Object_Set; -- Name : String) -- return SOAP_Record is -- begin -- return (To_Unbounded_String (Name), -- (Finalization.Controlled with new Object_Set'(V))); -- end R; -- ------- -- -- S -- -- ------- -- function S -- (V : String; -- Name : String := "item"; -- Encode : Boolean := True) -- return XSD_String is -- begin -- if Encode then -- return (To_Unbounded_String (Name), -- To_Unbounded_String (Utils.Encode (V))); -- else -- return (To_Unbounded_String (Name), -- To_Unbounded_String (V)); -- end if; -- end S; -- ------- -- -- T -- -- ------- -- function T -- (V : Calendar.Time; -- Name : String := "item"; -- Timezone : TZ := GMT) -- return XSD_Time_Instant is -- begin -- return (To_Unbounded_String (Name), V, Timezone); -- end T; -- ------- -- -- V -- -- ------- -- function V (O : XSD_Integer) return Integer is -- begin -- return NV.V; -- end V; -- function V (O : XSD_Float) return Long_Float is -- begin -- return NV.V; -- end V; -- function V (O : XSD_String) return String is -- begin -- return To_String (NV.V); -- end V; -- function V (O : XSD_Boolean) return Boolean is -- begin -- return NV.V; -- end V; -- function V (O : XSD_Time_Instant) return Calendar.Time is -- begin -- return NV.T; -- end V; -- function V (O : SOAP_Base64) return String is -- begin -- return To_String (NV.V); -- end V; -- function V (O : SOAP_Array) return Object_Set is -- begin -- return NV.Items.NV.all; -- end V; -- function V (O : SOAP_Record; Name : String) return NamedValue is -- begin -- for K in NV.Items.O'Range loop -- if Types.Name (NV.Items.O (K).NV.all) = Name then -- return NV.Items.O (K).NV.all; -- end if; -- end loop; -- Exceptions.Raise_Exception -- (Types.Data_Error'Identity, -- "(V) Struct object " & Name & " not found"); -- end V; --------------- -- XML_Image -- --------------- function XML_Record_Image (NV : NamedValue) return String; function XML_Enum_Image (NV : NamedValue) return String; function XML_ObjRef_Image (NV : NamedValue) return String; function XML_Sequence_Image (NV : NamedValue) return String; function XML_Image (NV : NamedValue) return String is Kind : constant TCKind := TypeCode.Kind (Get_Unwound_Type (NV.Argument)); begin pragma Debug (C, O ("XML_Image: arg """ & To_Standard_String (XML_Image.NV.Name) & """ is a " & TCKind'Image (Kind))); case Kind is when Tk_Struct => return XML_Record_Image (NV); when Tk_Enum => return XML_Enum_Image (NV); when Tk_Objref => return XML_ObjRef_Image (NV); when Tk_Sequence => return XML_Sequence_Image (NV); when Tk_Void => return "<" & To_Standard_String (NV.Name) & " xsi:null=""1""/>"; when others => pragma Debug (C, O ("Defaulting.")); return "<" & To_Standard_String (NV.Name) & xsi_type (XML_Type (NV)) & '>' & Value_Image (NV) & "'; end case; end XML_Image; -- function XML_Image (O : XSD_Null) return String is -- OC : constant NamedValue := NamedValue (O); -- begin -- return "<" & Name (OC) & " xsi_null=""1""/>"; -- end XML_Image; -- New_Line : constant String := ASCII.CR & ASCII.LF; -- function XML_Image (O : SOAP_Array) return String is -- function Array_Type return String; -- -- Returns the right SOAP array type. -- function Array_Type return String is -- T : Ada.Tags.Tag; -- Same_Type : Boolean := True; -- begin -- T := NV.Items.O (NV.Items.O'First).O'Tag; -- for K in NV.Items.O'First + 1 .. NV.Items.O'Last loop -- if T /= NV.Items.O (K).O'Tag then -- Same_Type := False; -- exit; -- end if; -- end loop; -- if Same_Type then -- return XML_Type (NV.Items.O (NV.Items.O'First).NV.all); -- else -- return XML_Undefined; -- end if; -- end Array_Type; -- Result : Unbounded_String; -- begin -- -- Open array element -- Append (Result, '<'); -- Append (Result, NV.Name); -- Append (Result, " SOAP-ENC:arrayType="""); -- Append (Result, Array_Type); -- Append (Result, '['); -- Append (Result, AWS.Utils.Image (NV.Items.O'Length)); -- Append (Result, "]"" "); -- Append (Result, xsi_type (XML_Array)); -- Append (Result, '>'); -- Append (Result, New_Line); -- -- Add all elements -- for K in NV.Items.O'Range loop -- Append (Result, XML_Image (NV.Items.O (K).NV.all)); -- Append (Result, New_Line); -- end loop; -- -- End array element -- Append (Result, Utils.Tag (To_String (NV.Name), Start => False)); -- return To_String (Result); -- end XML_Image; function XML_Enum_Image (NV : NamedValue) return String is Tag_Name : constant Standard.String := To_Standard_String (NV.Name); Pos : constant PolyORB.Types.Unsigned_Long := 1 + From_Any (Get_Aggregate_Element (NV.Argument, TC_Unsigned_Long, 0)); begin return "<" & Tag_Name & " id=""" & PolyORB.Types.Trimmed_Image (Unsigned_Long_Long (Pos)) & """>" & Value_Image (NV) & ""; end XML_Enum_Image; function XML_ObjRef_Image (NV : NamedValue) return String is Tag_Name : constant Standard.String := To_Standard_String (NV.Name); Ref : constant PolyORB.References.Ref := PolyORB.Any.ObjRef.From_Any (NV.Argument); SOAP_Profile : PolyORB.Binding_Data.Profile_Access; Result : PolyORB.Types.String; use type PolyORB.Binding_Data.Profile_Access; use PolyORB.Binding_Data.SOAP; use PolyORB.Errors; Error : Error_Container; begin Result := To_PolyORB_String ("<" & Tag_Name & " xsi:type=""" & PolyORB.References.Type_Id_Of (Ref) & """>"); PolyORB.References.Binding.Get_Tagged_Profile (Ref, PolyORB.Binding_Data.Tag_SOAP, SOAP_Profile, Error); -- If the real reference (Ref) does not contain a SOAP -- profile, then Get_Tagged_Profile tries to create -- a proxy profile instead. Only if it is not possible -- to create such a proxy profile do we get a null pointer -- in SOAP_Profile. if Found (Error) then raise Program_Error; end if; if SOAP_Profile /= null then declare URI : constant String := To_URI (SOAP_Profile_Type (SOAP_Profile.all)); begin pragma Debug (C, O ("Exporting object with URI: " & URI)); Append (Result, URI); end; else Append (Result, "#IOR:"); -- XXX Is there a possibility to include a stringified IOR -- here anyway? end if; Append (Result, ""); return To_Standard_String (Result); end XML_ObjRef_Image; function XML_Sequence_Image (NV : NamedValue) return String is use Ada.Strings.Unbounded; Result : Unbounded_String; Element_Type : constant PolyORB.Any.TypeCode.Local_Ref := PolyORB.Any.TypeCode.To_Ref (TypeCode.Content_Type (Get_Unwound_Type (NV.Argument))); New_Line : constant String := ASCII.CR & ASCII.LF; begin Append (Result, Tag (To_Standard_String (NV.Name), Start => True)); Append (Result, New_Line); declare Nb : constant PolyORB.Types.Unsigned_Long := PolyORB.Any.Get_Aggregate_Count (NV.Argument); begin -- Note: element 0 in a Tk_Sequence aggregate holds the -- length of the sequence, so we can assume that Nb > 0. pragma Assert (Nb > 0); for I in 1 .. Nb - 1 loop Append (Result, XML_Image (PolyORB.Any.NamedValue' (Name => To_PolyORB_String ("e"), Argument => PolyORB.Any.Get_Aggregate_Element (NV.Argument, Element_Type, I), Arg_Modes => ARG_IN))); Append (Result, New_Line); end loop; end; Append (Result, Tag (To_Standard_String (NV.Name), Start => False)); return To_String (Result); end XML_Sequence_Image; function XML_Record_Image (NV : NamedValue) return String is use Ada.Strings.Unbounded; Result : Unbounded_String; Data_Type : constant PolyORB.Any.TypeCode.Object_Ptr := Get_Unwound_Type (NV.Argument); New_Line : constant String := ASCII.CR & ASCII.LF; begin pragma Debug (C, O ("XML_Record_Image: enter")); Append (Result, Tag (To_Standard_String (NV.Name), Start => True)); Append (Result, New_Line); declare Nb : constant PolyORB.Types.Unsigned_Long := PolyORB.Any.Get_Aggregate_Count (NV.Argument); begin for I in 0 .. Nb - 1 loop Append (Result, XML_Image (PolyORB.Any.NamedValue' (Name => PolyORB.Any.TypeCode.Member_Name (Data_Type, I), Argument => PolyORB.Any.Get_Aggregate_Element (NV.Argument, PolyORB.Any.TypeCode.To_Ref (PolyORB.Any.TypeCode.Member_Type (Data_Type, I)), I), Arg_Modes => ARG_IN))); Append (Result, New_Line); end loop; end; Append (Result, Tag (To_Standard_String (NV.Name), Start => False)); pragma Debug (C, O ("XML_Record_Image: leave")); return To_String (Result); end XML_Record_Image; -------------- -- XML_Type -- -------------- function XML_Type (NV : NamedValue) return String is K : constant TCKind := TypeCode.Kind (Get_Unwound_Type (NV.Argument)); begin case K is when Tk_Long => return XML_Int; when Tk_Short => return XML_Short; when Tk_Ulong => return XML_UInt; when Tk_Ushort => return XML_UShort; when Tk_Octet => return XML_UByte; when Tk_Float => return XML_Float; when Tk_Double => return XML_Double; when Tk_String | Tk_Char => return XML_String; when Tk_Boolean => return XML_Boolean; when Tk_Array => return XML_Array; when others => return ""; -- XXX ??? end case; end XML_Type; -- function XML_Type (O : XSD_Time_Instant) return String is -- begin -- return XML_Time_Instant; -- end XML_Type; -- function XML_Type (O : XSD_Null) return String is -- begin -- return XML_Null; -- end XML_Type; -- function XML_Type (O : SOAP_Base64) return String is -- begin -- return XML_Base64; -- end XML_Type; -- function XML_Type (O : SOAP_Array) return String is -- begin -- return XML_Array; -- end XML_Type; -- function XML_Type (O : SOAP_Record) return String is -- begin -- return ""; -- end XML_Type; -------------- -- xsi_type -- -------------- function xsi_type (Name : String) return String is begin return " xsi:type=""" & Name & '"'; end xsi_type; end PolyORB.SOAP_P.Types; polyorb-2.8~20110207.orig/src/soap/gen_http_body0000755000175000017500000000434211750740340020711 0ustar xavierxavier#!/bin/sh # gen_http_body # Generate a perfect hash function in an Ada body from a specially # formatted Ada spec that defines an enumerated type and a list # of corresponding strings. usage() { echo "Usage: $0 " exit 1 } if [ $# != 3 ] then usage fi GNATPRFH=$1 SRCDIR=$2 NAME=$3 name=`echo ${NAME} | tr '[:upper:]' '[:lower:]'` SPEC=${SRCDIR}/polyorb-http_${name}s.ads BODY=polyorb-http_${name}s.adb UNIT=PolyORB.HTTP_${NAME}s AWK=${AWK:-awk} ${AWK} ' BEGIN{FS="\"";enum=0} /ENUM>/{enum=1-enum;next} /-- >>/{if (enum == 1) {print $2}} ' ${SPEC} | ${GNATPRFH} - rm -f ${BODY} cat >${BODY} <>${BODY} cat >>${BODY} </{enum=1-enum;next} /-- >>/{if (enum == 1) {print " Set (" $1 " " $4 ");"}} ' ${SPEC} >>${BODY} cat >>${BODY} < +"http_${name}s", Conflicts => Empty, Depends => Empty, Provides => Empty, Implicit => False, Init => Initialize'Access, Shutdown => null)); end ${UNIT}; EOF chmod -w ${BODY} polyorb-2.8~20110207.orig/src/soap/polyorb-filters-aws_interface.ads0000644000175000017500000000575711750740340024606 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . F I L T E R S . A W S _ I N T E R F A C E -- -- -- -- S p e c -- -- -- -- Copyright (C) 2001-2002 Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by ACT Europe. -- -- (email: sales@act-europe.fr) -- -- -- ------------------------------------------------------------------------------ -- Messages exchanged by AWS-based filters and components. with PolyORB.SOAP_P.Response; with PolyORB.Filters.Iface; with PolyORB.HTTP_Methods; with PolyORB.Types; package PolyORB.Filters.AWS_Interface is use PolyORB.Filters.Iface; type AWS_Get_SOAP_Action is new Root_Data_Unit with null record; type AWS_SOAP_Action is new Root_Data_Unit with record SOAP_Action : Types.String; end record; type AWS_Request_Out is new Root_Data_Unit with record Request_Method : PolyORB.HTTP_Methods.Method; Relative_URI : Types.String; Data : Types.String; SOAP_Action : Types.String; -- User : ; -- Passwd : ; -- Proxy : ; -- Proxy_User : ; -- Proxy_Passwd : ; end record; type AWS_Response_Out is new Root_Data_Unit with record -- Direction: from upper to lower. -- Semantics: send AWS response out. Data : PolyORB.SOAP_P.Response.Data; end record; end PolyORB.Filters.AWS_Interface; polyorb-2.8~20110207.orig/src/soap/polyorb-soap_p-message-xml.ads0000644000175000017500000000727511750740340024024 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . S O A P _ P . M E S S A G E . X M L -- -- -- -- S p e c -- -- -- -- Copyright (C) 2000-2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with PolyORB.SOAP_P.Message.Payload; with PolyORB.SOAP_P.Message.Response; with Input_Sources; with PolyORB.Any.NVList; package PolyORB.SOAP_P.Message.XML is procedure Load_Payload (Source : access Input_Sources.Input_Source'Class; Args : in out PolyORB.Any.NVList.Ref; R_Payload : out Message.Payload.Object_Access); -- Build a Payload object by parsing an XML payload from source. -- Args is expected to designate a list of empty Any's, -- whose typecodes are used to determine how to decode the -- XML elements into typed data. On return, the values -- of these Any's are set according to the decoded XML -- elements. function Load_Response (Source : access Input_Sources.Input_Source'Class; Args : PolyORB.Any.NVList.Ref) return Message.Response.Object_Access; -- Build a Response object (either a standard response or an error -- response) by parsing an XML response from Source. -- Args are used as above (for returned arguments). -- XXX warning, return value vs. out args? Does the return -- value need to be the first OUT element of the Args list? procedure Load_Response (Source : access Input_Sources.Input_Source'Class; Args : in out PolyORB.Any.NVList.Ref); -- Same as the function, except that we do not build any -- Object_Access, and we edit the Args list with the arguments -- found in the xml tree function Image (Obj : Object'Class) return String; -- Returns XML representation of object O. function Image (Obj : Object'Class) return Unbounded_String; -- Idem as above but returns an Unbounded_String instead of a String. end PolyORB.SOAP_P.Message.XML; polyorb-2.8~20110207.orig/src/soap/polyorb-soap_p-message-reader.ads0000644000175000017500000000702711750740340024461 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . S O A P _ P . M E S S A G E . R E A D E R -- -- -- -- S p e c -- -- -- -- Copyright (C) 2000-2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- This package is based on Tree_Reader from the XMLada package. It is used -- to create a DOM object using the SAX parser. with Sax.Readers; use Sax.Readers; with Sax.Attributes; with Unicode.CES; with DOM.Core; use DOM.Core; private package PolyORB.SOAP_P.Message.Reader is type Tree_Reader is new Sax.Readers.Reader with private; -- Tree_Reader create a DOM tree using the SAX parser. function Get_Tree (Read : Tree_Reader) return Document; private type Tree_Reader is new Sax.Readers.Reader with record Tree : Document; Current_Node : Node; Internal_Encoding : Unicode.CES.Encoding_Scheme; end record; procedure Start_Document (Handler : in out Tree_Reader); procedure Start_Element (Handler : in out Tree_Reader; Namespace_URI : Unicode.CES.Byte_Sequence := ""; Local_Name : Unicode.CES.Byte_Sequence := ""; Qname : Unicode.CES.Byte_Sequence := ""; Atts : Sax.Attributes.Attributes'Class); procedure End_Element (Handler : in out Tree_Reader; Namespace_URI : Unicode.CES.Byte_Sequence := ""; Local_Name : Unicode.CES.Byte_Sequence := ""; Qname : Unicode.CES.Byte_Sequence := ""); procedure Characters (Handler : in out Tree_Reader; Ch : Unicode.CES.Byte_Sequence); procedure Ignorable_Whitespace (Handler : in out Tree_Reader; Ch : Unicode.CES.Byte_Sequence); end PolyORB.SOAP_P.Message.Reader; polyorb-2.8~20110207.orig/src/soap/polyorb-setup-access_points-soap.adb0000644000175000017500000001251511750740340025226 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . S E T U P . A C C E S S _ P O I N T S . S O A P -- -- -- -- B o d y -- -- -- -- Copyright (C) 2003-2007, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- Setup for SOAP access point. with PolyORB.Binding_Data.SOAP; with PolyORB.Filters.HTTP; with PolyORB.Protocols.SOAP_Pr; with PolyORB.Parameters; with PolyORB.Initialization; with PolyORB.ORB; with PolyORB.Protocols; with PolyORB.Sockets; with PolyORB.Transport.Connected.Sockets; with PolyORB.Utils.Strings; with PolyORB.Utils.Socket_Access_Points; with PolyORB.Utils.TCP_Access_Points; package body PolyORB.Setup.Access_Points.SOAP is use PolyORB.Filters; use PolyORB.ORB; use PolyORB.Sockets; use PolyORB.Transport.Connected.Sockets; use PolyORB.Utils.Socket_Access_Points; use PolyORB.Utils.TCP_Access_Points; -- The SOAP access point SOAP_Access_Point : Access_Point_Info := (Socket => No_Socket, Address => No_Sock_Addr, SAP => new Socket_Access_Point, PF => new Binding_Data.SOAP.SOAP_Profile_Factory); HTTP_Filter : aliased PolyORB.Filters.HTTP.HTTP_Filter_Factory; SOAP_Protocol : aliased Protocols.SOAP_Pr.SOAP_Protocol; -- XXX -- It is not a very satisfying thing to have to declare -- HTTP_Filter and SOAP_Protocol explicitly on the server -- side. On the client side, this is done in Binding_Data.SOAP -- (as an effect of binding a SOAP object reference). -- Since Binding_Data encapsulates the association of a protocol -- with a complete transport stack, it should also provide -- the corresponding server-side primitive (eg as a constant -- filter chain created at initialisation.) SOAP_Factories : aliased Filters.Factory_Array := (0 => HTTP_Filter'Access, 1 => SOAP_Protocol'Access); ------------------------------ -- Initialize_Access_Points -- ------------------------------ procedure Initialize_Access_Points; procedure Initialize_Access_Points is use PolyORB.Parameters; begin if Get_Conf ("access_points", "soap", True) then declare Port_Hint : constant Port_Interval := To_Port_Interval (Get_Conf ("soap", "polyorb.protocols.soap.default_port", (Integer (Any_Port), Integer (Any_Port)))); Addr : constant Inet_Addr_Type := Inet_Addr (String'(Get_Conf ("soap", "polyorb.protocols.soap.default_addr", Image (No_Inet_Addr)))); begin Initialize_Socket (SOAP_Access_Point, Addr, Port_Hint); Register_Access_Point (ORB => The_ORB, TAP => SOAP_Access_Point.SAP, Chain => SOAP_Factories'Access, PF => SOAP_Access_Point.PF); -- Register socket with ORB object, associating a protocol -- to the transport service access point. end; end if; end Initialize_Access_Points; use PolyORB.Initialization; use PolyORB.Initialization.String_Lists; use PolyORB.Utils.Strings; begin Register_Module (Module_Info' (Name => +"access_points.soap", Conflicts => Empty, Depends => +"orb", Provides => +"access_points", Implicit => False, Init => Initialize_Access_Points'Access, Shutdown => null)); end PolyORB.Setup.Access_Points.SOAP; polyorb-2.8~20110207.orig/src/soap/polyorb-soap_p-message-response-error.ads0000644000175000017500000000656511750740340026212 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- POLYORB.SOAP_P.MESSAGE.RESPONSE.ERROR -- -- -- -- S p e c -- -- -- -- Copyright (C) 2000-2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with PolyORB.SOAP_P.Message.Payload; with PolyORB.SOAP_P.Message.Response; package PolyORB.SOAP_P.Message.Response.Error is type Object is new Message.Response.Object with private; type Faultcode is new String; function From (P : Message.Payload.Object) return Object; -- Build an Error response from a Payload object. function XML_Image (E : Object) return Unbounded_String; -- Returns the Fault env and associated data (faultcode, faultstring...). function Build (Faultcode : Error.Faultcode; Faultstring : String) return Object; -- Returns an Error object built using Faultcode and Faultstring. function Is_Error (E : Object) return Boolean; -- Always returns True. This overrides Response.Object's method. ----------------- -- Fault Codes -- ----------------- function Version_Mismatch (Subname : String := "") return Faultcode; -- Returns the Version_Mismatch faultcode. function Must_Understand (Subname : String := "") return Faultcode; -- Returns the Must_Understand faultcode. function Client (Subname : String := "") return Faultcode; -- Returns the Client faultcode. function Server (Subname : String := "") return Faultcode; -- Returns the Server faultcode. private type Object is new Message.Response.Object with null record; end PolyORB.SOAP_P.Message.Response.Error; polyorb-2.8~20110207.orig/src/soap/polyorb-filters-http.adb0000644000175000017500000011560011750740340022717 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . F I L T E R S . H T T P -- -- -- -- B o d y -- -- -- -- Copyright (C) 2001-2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with Ada.Characters.Handling; with Ada.Exceptions; with Ada.Unchecked_Conversion; with System; with PolyORB.Web.MIME; with PolyORB.SOAP_P.Response; with PolyORB.Filters.AWS_Interface; with PolyORB.Filters.Iface; with PolyORB.HTTP_Headers; with PolyORB.Log; with PolyORB.Opaque; with PolyORB.Utils; with PolyORB.Utils.Text_Buffers; package body PolyORB.Filters.HTTP is use Ada.Streams; use PolyORB.Buffers; use PolyORB.Components; use PolyORB.Filters.AWS_Interface; use PolyORB.Filters.Iface; use PolyORB.Log; use PolyORB.ORB; use PolyORB.Types; use PolyORB.Utils; use String_Lists; package L is new PolyORB.Log.Facility_Log ("polyorb.filters.http"); procedure O (Message : String; Level : Log_Level := Debug) renames L.Output; function C (Level : Log_Level := Debug) return Boolean renames L.Enabled; HTTP_Error : exception; ----------------------------------------- -- Declaration of internal subprograms -- ----------------------------------------- procedure Handle_Data_Indication (F : access HTTP_Filter; S : Filters.Iface.Data_Indication); -- Process a Data_Indication message from lower layers. procedure Process_Line (F : access HTTP_Filter; Line_Length : Stream_Element_Count); -- Process one start-line or header line in an HTTP message, -- starting at the current input buffer position of F, -- and spanning Line_Length characters. procedure Message_Complete (F : access HTTP_Filter); -- A message has been completely received and processed by F: -- send the upper layer a Data_Indication. -------------------------------------- -- Preparation of outgoing messages -- -------------------------------------- function Image (I : Long_Long) return String renames PolyORB.Types.Trimmed_Image; procedure Prepare_Request (Buf : access Buffer_Type; Version : HTTP_Version; RO : PolyORB.Filters.AWS_Interface.AWS_Request_Out); procedure Prepare_Header_Only (Buf : access Buffer_Type; Version : HTTP_Version; RD : PolyORB.SOAP_P.Response.Data); procedure Prepare_General_Header (Buf : access Buffer_Type; RD : PolyORB.SOAP_P.Response.Data); procedure Prepare_Message (Buf : access Buffer_Type; Version : HTTP_Version; RD : PolyORB.SOAP_P.Response.Data); procedure Error (F : access HTTP_Filter; Status : HTTP_Status_Code); -- Send an error message to F. -- XXX should a message body be included with the error status? -- General filter management procedure Create (Fact : access HTTP_Filter_Factory; Filt : out Filter_Access) is pragma Warnings (Off); pragma Unreferenced (Fact); pragma Warnings (On); Res : constant Filter_Access := new HTTP_Filter; begin Initialize (HTTP_Filter (Res.all)); Filt := Res; end Create; procedure Clear_Message_State (F : in out HTTP_Filter) is Empty : PolyORB.Types.String; begin F.Version := Default_HTTP_Version; F.Status := S_Unknown; F.Request_Method := PolyORB.HTTP_Methods.Extension_Method; Utils.Strings.Free (F.Request_URI); F.Content_Length := -1; Deallocate (F.Transfer_Encoding); F.Chunked := False; F.Transfer_Length := -1; F.Entity := Empty; F.SOAP_Action := Empty; end Clear_Message_State; procedure Initialize (F : in out HTTP_Filter) is begin Clear_Message_State (F); end Initialize; procedure Destroy (F : in out HTTP_Filter) is begin Clear_Message_State (F); PolyORB.Filters.Destroy (Filter (F)); end Destroy; Buffer_Size : constant := 1024; -- Main filter message processing function Handle_Message (F : not null access HTTP_Filter; S : Components.Message'Class) return Components.Message'Class is Res : Components.Null_Message; begin if False or else S in Connect_Indication or else S in Connect_Confirmation then if S in Connect_Indication then F.Role := Server; else F.Role := Client; end if; F.State := Start_Line; F.Data_Received := 0; F.In_Buf := new PolyORB.Buffers.Buffer_Type; -- HTTP has its own buffer for protocol stuff; -- the upper layer provides another buffer for -- message payload. Expect_Data (F, F.In_Buf, Buffer_Size); -- Wait for first line of message. Emit_No_Reply (F.Upper, S); elsif S in Data_Expected then F.Message_Buf := Data_Expected (S).In_Buf; elsif S in Data_Indication then Handle_Data_Indication (F, Data_Indication (S)); elsif S in AWS_Request_Out then declare Buf : Buffer_Access := new Buffer_Type; begin Prepare_Request (Buf, F.Version, AWS_Request_Out (S)); Emit_No_Reply (Lower (F), Data_Out'(Out_Buf => Buf)); Release (Buf); end; elsif S in AWS_Response_Out then declare Buf : Buffer_Access := new Buffer_Type; RD : constant PolyORB.SOAP_P.Response.Data := AWS_Response_Out (S).Data; begin case PolyORB.SOAP_P.Response.Mode (RD) is when PolyORB.SOAP_P.Response.Header => Prepare_Header_Only (Buf, F.Version, RD); when PolyORB.SOAP_P.Response.Message => Prepare_Message (Buf, F.Version, RD); end case; Emit_No_Reply (Lower (F), Data_Out'(Out_Buf => Buf)); Release (Buf); end; elsif S in AWS_Get_SOAP_Action then return AWS_SOAP_Action'(SOAP_Action => F.SOAP_Action); else return Filters.Handle_Message (Filters.Filter (F.all)'Access, S); end if; return Res; end Handle_Message; ----------------------------- -- HTTP message processing -- ----------------------------- function Is_LWS (C : Character) return Boolean; pragma Inline (Is_LWS); -- True iff C is a linear whitespace character (space or tab). procedure Skip_LWS (S : String; First : in out Integer); -- Increment First until it points to a non-LWS position in S -- or equals S'Last + 1. procedure Trim_LWS (S : String; Last : in out Integer); -- Decrement Last until it points to a non-LWS position in S -- or equals S'First - 1. procedure Parse_CSL_Item (S : String; Pos : in out Integer; First : out Integer; Last : out Integer); -- Get one item from a comma-separated list, starting at Pos. -- On return, First and Last are the indices of the start and -- end of the parsed token (possibly empty), and Pos is -- the position at which parsing should proceed for the next -- token. If Pos > S'Last on return then the string has been -- completely parsed. function Parse_Hex (S : String) return Natural; -- chunk-size ::= 1*HEX function Parse_HTTP_Version (S : String) return HTTP_Version; -- HTTP-Version function To_HTTP_Status_Code (Status : Integer) return HTTP_Status_Code; -- HTTP status codes. -- Integers corresponding to known codes are translated to the -- corresponding enum value. Integers corresponding to unknown -- codes in a valid class are translated to the 'other' code for -- that class. For other values of Status, Constraint_Error is raised. procedure Parse_Request_Line (F : access HTTP_Filter; S : String); -- Request-Line procedure Parse_Status_Line (F : access HTTP_Filter; S : String); -- Status-Line procedure Parse_Header_Line (F : access HTTP_Filter; S : String); -- {general,request,response,entity}-header procedure Parse_Chunk_Size (F : access HTTP_Filter; S : String); -- chunk-size --------------------- -- Implementations -- --------------------- procedure Handle_Data_Indication (F : access HTTP_Filter; S : Filters.Iface.Data_Indication) is Data_Received : Stream_Element_Count := S.Data_Amount; New_Data : PolyORB.Opaque.Opaque_Pointer; New_Data_Position : Stream_Element_Offset := Length (F.In_Buf.all) - Data_Received; begin --------------------------- -- Process received data -- --------------------------- Show (F.In_Buf); <> if F.State in Line_By_Line then ------------------------------------------ -- Processing data in line-by-line mode -- -- (header or chunk size line). -- ------------------------------------------ Extract_Data (F.In_Buf, New_Data, Data_Received, Use_Current => False, At_Position => New_Data_Position); -- Peek at the newly-received data. declare Z_Addr : constant System.Address := New_Data; Z : Stream_Element_Array (0 .. Data_Received - 1); for Z'Address use Z_Addr; pragma Import (Ada, Z); begin Scan_Line : for J in Z'Range loop case Z (J) is when Character'Pos (ASCII.CR) => if F.CR_Seen then raise HTTP_Error; -- Two consecutive CRs. end if; F.CR_Seen := True; when Character'Pos (ASCII.LF) => if not F.CR_Seen then raise HTTP_Error; -- LF not preceded with CR. end if; F.CR_Seen := False; begin Process_Line (F, Line_Length => New_Data_Position - CDR_Position (F.In_Buf) + J + 1); exception when E : others => O ("Received exception in " & HTTP_State'Image (F.State) & " state:", Error); O (Ada.Exceptions.Exception_Information (E), Error); Clear_Message_State (F.all); if F.Role = Server then Error (F, S_400_Bad_Request); else -- XXX what to do on client side? raise; end if; -- XXX close??? end; -- Calculation of the length of the current line: -- New_Data_Position - CDR_Position = amount of data -- received but not yet processed -- (the beginning of this line) -- I - I'First + 1 = amount of data now appended -- (the end of this line). New_Data_Position := CDR_Position (F.In_Buf); Data_Received := Length (F.In_Buf.all) - New_Data_Position; if Data_Received > 0 then pragma Debug (C, O ("Restarting HTTP processing")); pragma Debug (C, O ("Transfer length:" & F.Transfer_Length'Img)); pragma Debug (C, O ("Pending data:" & Data_Received'Img)); goto Process_Received_Data; end if; -- Update state, and restart data processing if -- necessary (Process_Line may have changed F.State, -- so we cannot simply continue running Scan_Line). when others => F.CR_Seen := False; end case; end loop Scan_Line; end; if CDR_Position (F.In_Buf) = Length (F.In_Buf.all) then -- All data currently in F.In_Buf has been processed, -- so release it (NB: in the HTTP filter, the initial -- position in the buffer is always 0.) Release_Contents (F.In_Buf.all); end if; else ------------------------------------------------------ -- Not in a line-by-line state: transferring entity -- ------------------------------------------------------ pragma Debug (C, O ("Transferring entity")); declare Data : PolyORB.Opaque.Opaque_Pointer; Data_Processed : Stream_Element_Count := Data_Received; begin if Data_Processed > F.Transfer_Length then Data_Processed := F.Transfer_Length; end if; PolyORB.Buffers.Extract_Data (F.In_Buf, Data, Data_Processed, Use_Current => True); declare S : String (1 .. Integer (Data_Processed)); for S'Address use Data; pragma Import (Ada, S); begin Append (F.Entity, S); end; F.Transfer_Length := F.Transfer_Length - Data_Processed; pragma Debug (C, O ("F.State:" & F.State'Img)); pragma Debug (C, O ("F.Transfer_Length:" & F.Transfer_Length'Img)); if F.Transfer_Length = 0 then if F.Chunked then -- Got a complete chunk declare L : constant Integer := Length (F.Entity); begin if Slice (F.Entity, L - 1, L) /= CRLF then raise HTTP_Error; -- XXX chunk data not terminated by CRLF; end if; Delete (F.Entity, L - 1, L); end; -- End of chunk data, wait for next. F.State := Chunk_Size; F.Transfer_Length := -1; else Message_Complete (F); end if; end if; New_Data_Position := CDR_Position (F.In_Buf); Data_Received := Data_Received - Data_Processed; if Data_Received > 0 then pragma Debug (C, O ("Restarting HTTP processing")); goto Process_Received_Data; end if; end; end if; ---------------------------------------- -- Prepare for further data reception -- ---------------------------------------- -- At this point, all the received data have -- been processed. Further data must now be Expected -- according to the current state information (which -- may have been modified by the above processing. pragma Debug (C, O ("F.State:" & F.State'Img)); pragma Debug (C, O ("F.Transfer_Length:" & F.Transfer_Length'Img)); case F.Transfer_Length is when -1 => -- Either state is Start_Line, Header, Chunk_Size -- or (state is entity -- and transfer length is unknown). Expect_Data (F, F.In_Buf, Buffer_Size); when 0 => -- All expected data was received, upper layer -- has been notified (see calls to Message_Complete -- above). null; when others => Expect_Data (F, F.In_Buf, F.Transfer_Length); end case; end Handle_Data_Indication; procedure Process_Line (F : access HTTP_Filter; Line_Length : Stream_Element_Count) is Data : PolyORB.Opaque.Opaque_Pointer; begin pragma Debug (C, O ("Processing line at position " & Stream_Element_Offset'Image (PolyORB.Buffers.CDR_Position (F.In_Buf)))); PolyORB.Buffers.Extract_Data (F.In_Buf, Data, Line_Length, Use_Current => True); declare S : String (1 .. Integer (Line_Length) - 2); -- Ignore last 2 characters (CR/LF). for S'Address use Data; pragma Import (Ada, S); begin pragma Debug (C, O ("HTTP line received: " & S)); case F.State is when Start_Line => if F.Role = Server then Parse_Request_Line (F, S); else Parse_Status_Line (F, S); end if; when Chunk_Size => Parse_Chunk_Size (F, S); when Header | Trailer => if S'Length > 2 then Parse_Header_Line (F, S); else -- End of headers (an empty line). pragma Debug (C, O ("Headers complete.")); -- Determine the message body transfer length -- (RFC 2616 4.4) -- if Is_Response_Without_Body (F) then -- XXX implement predicate Is_Resp_WO_Body if False then F.Transfer_Length := 0; -- Response received complete, does not (and -- MUST not) contain a body. -- XXX now we must send Data_Indication to -- the upper layer, and switch to Start_Line -- state. elsif Length (F.Transfer_Encoding) > 0 then if Value (First (F.Transfer_Encoding)).all = Encoding_Chunked then F.Chunked := True; F.State := Chunk_Size; end if; elsif F.Content_Length > 0 then F.Transfer_Length := F.Content_Length; -- Expect content-length octets, NO trailing CRLF. F.State := Entity; -- elsif Media-Type is multipart/byteranges -- ... use that to determine the transfer-length else if F.Role = Server then -- XXX 400 Bad request: the client cannot -- indicate the transfer length by closing -- the connection at the end of the message, -- because then there would be no channel -- for sending a response. raise HTTP_Error; end if; -- We are on the client side, and the -- transfer-length will be indicated by the -- server closing the connection. F.Transfer_Length := -1; F.State := Entity; end if; end if; pragma Debug (C, O ("F.State: " & F.State'Img)); when others => raise Program_Error; end case; end; end Process_Line; -- Linear white space function Is_LWS (C : Character) return Boolean is begin return C = ' ' or else C = ASCII.HT; end Is_LWS; procedure Skip_LWS (S : String; First : in out Integer) is begin while First in S'Range and then Is_LWS (S (First)) loop First := First + 1; end loop; end Skip_LWS; procedure Trim_LWS (S : String; Last : in out Integer) is begin while Last in S'Range and then Is_LWS (S (Last)) loop Last := Last - 1; end loop; end Trim_LWS; procedure Parse_CSL_Item (S : String; Pos : in out Integer; First : out Integer; Last : out Integer) is Item_First : Integer := Pos; Item_Last : Integer; -- Start and end of current item. Separator : Integer; -- Position of separator after current token. begin pragma Assert (Pos in S'Range); -- Skip initial linear white space while Item_First <= S'Last and then Is_LWS (S (Item_First)) loop Item_First := Item_First + 1; end loop; First := Item_First; if Item_First > S'Last then -- There was only LWS from Pos to the end of the string. Pos := S'Last + 1; pragma Warnings (Off); -- "Last" not set before return return; pragma Warnings (On); end if; Separator := Item_First; loop exit when Separator > S'Last or else S (Separator) = ','; Separator := Separator + 1; end loop; Item_Last := Separator - 1; Pos := Separator + 1; while Item_Last > Item_First and then Is_LWS (S (Item_Last)) loop Item_Last := Item_Last - 1; end loop; Last := Item_Last; Pos := Separator + 1; end Parse_CSL_Item; function Image (V : HTTP_Version) return String is begin return HTTP_Slash & Image (Long_Long (V.Major)) & "." & Image (Long_Long (V.Minor)); end Image; function Parse_Hex (S : String) return Natural is Res : Natural := 0; begin for I in S'Range loop Res := Res * 16#10# + PolyORB.Utils.Hex_Value (S (I)); end loop; return Res; end Parse_Hex; function Parse_HTTP_Version (S : String) return HTTP_Version is Version : constant Integer := S'First + HTTP_Slash'Length; Dot : Integer; Result : HTTP_Version; begin if S (S'First .. Version - 1) /= HTTP_Slash then raise HTTP_Error; end if; Dot := Find (S, Version, '.'); if Dot >= S'Last then raise HTTP_Error; end if; Result.Major := Natural'Value (S (Version .. Dot - 1)); Result.Minor := Natural'Value (S (Dot + 1 .. S'Last)); return Result; end Parse_HTTP_Version; procedure Parse_Request_Line (F : access HTTP_Filter; S : String) is Space : Integer; URI : Integer; Version : Integer; begin -- Ignore empty lines received instead of Request_Line. if S'Length = 0 then return; end if; Space := Find_Whitespace (S, S'First); F.Request_Method := PolyORB.HTTP_Methods.In_Word_Set (S (S'First .. Space - 1)); URI := Skip_Whitespace (S, Space); Space := Find_Whitespace (S, URI); Version := Skip_Whitespace (S, Space); if Version > S'Last then -- XXX bad request raise HTTP_Error; end if; Utils.Strings.Free (F.Request_URI); F.Request_URI := new String'(S (URI .. Space - 1)); F.Version := Parse_HTTP_Version (S (Version .. S'Last)); F.State := Header; pragma Debug (C, O ("Parsed request-line:")); pragma Debug (C, O (F.Request_Method'Img & " " & F.Request_URI.all & " " & Image (F.Version))); end Parse_Request_Line; procedure Parse_Status_Line (F : access HTTP_Filter; S : String) is Space : Integer; Status_Pos : Integer; begin Space := Find_Whitespace (S, S'First); if Space > S'Last then raise HTTP_Error; end if; F.Version := Parse_HTTP_Version (S (S'First .. Space - 1)); Status_Pos := Skip_Whitespace (S, Space); Space := Find_Whitespace (S, Status_Pos); if Space > S'Last or else Space - Status_Pos /= 3 then raise HTTP_Error; end if; F.Status := To_HTTP_Status_Code (Natural'Value (S (Status_Pos .. Space - 1))); -- The remainder of the line is the response-phrase -- and is ignored. F.State := Header; pragma Debug (C, O ("Parsed status-line:")); pragma Debug (C, O (Image (F.Version) & " " & F.Status'Img & S (Space .. S'Last))); end Parse_Status_Line; procedure Parse_Header_Line (F : access HTTP_Filter; S : String) is use PolyORB.HTTP_Headers; pragma Debug (C, O ("Parse_Header_Line: S=" & S)); Colon : constant Integer := Find (S, S'First, ':'); Header_Kind : PolyORB.HTTP_Headers.Header; Pos : Integer; Tok_First, Tok_Last : Integer; begin if Colon > S'Last then raise HTTP_Error with "Malformed HTTP header: " & S; end if; Header_Kind := PolyORB.HTTP_Headers.In_Word_Set (S (S'First .. Colon - 1)); if (F.Role = Client and then Header_Kind in Request_Header) or else (F.Role = Server and then Header_Kind in Response_Header) then raise HTTP_Error; end if; Pos := Colon + 1; Skip_LWS (S, Pos); case Header_Kind is when H_Content_Length => Tok_Last := S'Last; Trim_LWS (S, Tok_Last); if Pos > Tok_Last then raise HTTP_Error; end if; F.Content_Length := Stream_Element_Count'Value (S (Pos .. Tok_Last)); when H_Transfer_Encoding => Pos := Colon + 1; if Length (F.Transfer_Encoding) /= 0 then raise HTTP_Error; -- XXX duplicate Transfer-Encoding header. end if; while Pos <= S'Last loop Parse_CSL_Item (S, Pos, Tok_First, Tok_Last); String_Lists.Prepend (F.Transfer_Encoding, Ada.Characters.Handling.To_Lower (S (Tok_First .. Tok_Last))); end loop; declare Nb_Encodings : constant Natural := Length (F.Transfer_Encoding); begin if Nb_Encodings = 0 then raise HTTP_Error; -- XXX at least one token is required. end if; if Value (First (F.Transfer_Encoding)).all /= Encoding_Chunked then raise HTTP_Error; -- XXX RFC 2616 3.6 When one or more -- are specified, "chunked" must be specified -- exactly once and must be the last specified. -- XXX Respond 501 not implemented per RFC 2616 3.6? end if; end; when H_SOAPAction => Tok_Last := S'Last; Trim_LWS (S, Tok_Last); if Pos > Tok_Last then raise HTTP_Error; end if; pragma Debug (C, O ("SOAP action is " & S (Pos .. Tok_Last))); if S (Pos) = '"' and then S (Tok_Last) = '"' then pragma Debug (C, O ("SOAP action is now " & S (Pos + 1 .. Tok_Last - 1))); F.SOAP_Action := PolyORB.Types.To_PolyORB_String (S (Pos + 1 .. Tok_Last - 1)); else F.SOAP_Action := PolyORB.Types.To_PolyORB_String (S (Pos .. Tok_Last)); end if; when others => pragma Debug (C, O ("Ignoring HTTP header " & Header_Kind'Img & ":")); pragma Debug (C, O (S)); null; -- Ignore non-recognised headers. end case; end Parse_Header_Line; procedure Parse_Chunk_Size (F : access HTTP_Filter; S : String) is Chunk_Size : Stream_Element_Count; Semicolon : constant Integer := Find (S, S'First, ';'); -- Optional: chunk-extensions begin Chunk_Size := Stream_Element_Count (Parse_Hex (S (S'First .. Semicolon - 1))); if Chunk_Size > 0 then F.Transfer_Length := Chunk_Size + 2; -- Expect chunk-data + CRLF F.State := Entity; else -- Last chunk received, go to trailer state. -- When in trailer state and headers are completed, -- finally call Message_Complete. F.Transfer_Length := -1; F.State := Trailer; end if; end Parse_Chunk_Size; procedure Message_Complete (F : access HTTP_Filter) is use type PolyORB.Utils.Strings.String_Ptr; begin pragma Debug (C, O ("Message_Complete: enter")); -- Check validity of message body buffer now. if F.Message_Buf = null then raise Program_Error; end if; Release_Contents (F.Message_Buf.all); declare S : constant String := To_Standard_String (F.Entity); -- XXX BAD BAD do not allocate that on the stack! begin PolyORB.Utils.Text_Buffers.Marshall_String (F.Message_Buf, S); Rewind (F.Message_Buf); if F.Request_URI /= null then Emit_No_Reply (F.Upper, Set_Target_Object' (Target => To_PolyORB_String (F.Request_URI.all))); end if; Emit_No_Reply (F.Upper, Data_Indication'(Data_Amount => S'Length)); Release_Contents (F.In_Buf.all); end; -- XXX it is unfortunate that we: -- 1. receive entity data in In_Buf; -- 2. copy it to Unbounded_String entity; -- 3. copy it back to buffer Message_Buf. -- Alternative solutions: -- * receive directly in Message_Buf (BUT we may -- have to copy the first few bytes of the entity -- body from In_Buf) (or insert them as a foreign chunk!) -- (but then we do not guarantee the contiguousness of -- Message_Buf) -- * no Message_Buf, send a Data_Indication containing -- he Entity unbounded-string (for efficiency's sake, -- check that unbounded strings are copy-on-write.) Clear_Message_State (F.all); F.State := Start_Line; end Message_Complete; function To_HTTP_Status_Code (Status : Integer) return HTTP_Status_Code is function Cvt is new Ada.Unchecked_Conversion (Integer, HTTP_Status_Code); Res : constant HTTP_Status_Code := Cvt (Status); Unknown_Codes : constant array (Integer range <>) of HTTP_Status_Code := (1 => S_1xx_Other_Informational, 2 => S_2xx_Other_Successful, 3 => S_3xx_Other_Redirection, 4 => S_4xx_Other_Client_Error, 5 => S_5xx_Other_Server_Error); begin if Res'Valid then return Res; else declare Class : constant Integer := Status / 100; begin if Class in Unknown_Codes'Range then return Unknown_Codes (Class); else raise Constraint_Error; end if; end; end if; end To_HTTP_Status_Code; function To_Integer is new Ada.Unchecked_Conversion (HTTP_Status_Code, Integer); -------------------------------------- -- Preparation of outgoing messages -- -------------------------------------- procedure Put (Buf : access Buffer_Type; S : String); procedure New_Line (Buf : access Buffer_Type); procedure Put_Line (Buf : access Buffer_Type; S : String); function Header (H : PolyORB.HTTP_Headers.Header; Value : String) return String; procedure Put_Status_Line (Buf : access Buffer_Type; Version : HTTP_Version; Status : HTTP_Status_Code); function Header (H : PolyORB.HTTP_Headers.Header; Value : String) return String is begin return PolyORB.HTTP_Headers.To_String (H) & ": " & Value; end Header; procedure Put_Status_Line (Buf : access Buffer_Type; Version : HTTP_Version; Status : HTTP_Status_Code) is begin Put_Line (Buf, Image (Version) -- XXX Should we reply with that version? & Integer'Image (To_Integer (Status)) & " " & HTTP_Status_Code'Image (Status)); end Put_Status_Line; procedure Error (F : access HTTP_Filter; Status : HTTP_Status_Code) is Buf : Buffer_Access := new Buffer_Type; begin Put_Status_Line (Buf, F.Version, Status); Clear_Message_State (F.all); Emit_No_Reply (Lower (F), Data_Out'(Out_Buf => Buf)); Release (Buf); end Error; procedure Put (Buf : access Buffer_Type; S : String) is begin PolyORB.Utils.Text_Buffers.Marshall_String (Buf, S); end Put; procedure New_Line (Buf : access Buffer_Type) is use PolyORB.Utils.Text_Buffers; begin Marshall_Char (Buf, ASCII.CR); Marshall_Char (Buf, ASCII.LF); end New_Line; procedure Put_Line (Buf : access Buffer_Type; S : String) is begin Put (Buf, S); New_Line (Buf); end Put_Line; use PolyORB.HTTP_Headers; -- The procedures Prepare_* are adapted from code in -- AWS.Server.Protocol_Handler and AWS.Client. procedure Prepare_Request (Buf : access Buffer_Type; Version : HTTP_Version; RO : PolyORB.Filters.AWS_Interface.AWS_Request_Out) is use PolyORB.HTTP_Methods; SOAP_Action : constant String := To_Standard_String (RO.SOAP_Action); begin Put_Line (Buf, To_String (RO.Request_Method) & " " & Types.To_Standard_String (RO.Relative_URI) & " " & Image (Version)); -- Put_Line (F, H_Host (Host_Address)); -- XXX When binding an HTTP profile, the Host -- info (from the URL or a Tag_SOAP or a Tag_HTTP -- profile) should be propagated down the protocol -- stack so we can generate a proper Host: header. -- XXX Cookie?? -- Put_Line (Buf, H_Accept_Type ("text/html, */*")); Put_Line (Buf, Header (H_Accept_Language, "fr, us")); Put_Line (Buf, Header (H_User_Agent, "PolyORB")); -- XXX BAD BAD too much hardcoded stuff. if False then Put_Line (Buf, Header (H_Connection, "Keep-Alive")); -- XXX should provide keepalive mechanism! -- (it should even be the default). else Put_Line (Buf, Header (H_Connection, "Close")); end if; -- XXX Authentication?? if SOAP_Action'Length /= 0 then Put_Line (Buf, Header (H_SOAPAction, SOAP_Action)); end if; case RO.Request_Method is when GET => New_Line (Buf); when POST => if SOAP_Action'Length /= 0 then Put_Line (Buf, Header (H_Content_Type, PolyORB.Web.MIME.Text_XML)); else Put_Line (Buf, Header (H_Content_Type, PolyORB.Web.MIME.Appl_Form_Data)); end if; Put_Line (Buf, Header (H_Content_Length, Image (Long_Long (Length (RO.Data))))); New_Line (Buf); Put (Buf, To_Standard_String (RO.Data)); -- XXX bad bad passing complete SOAP request -- on the stack!! Would be better off inserting -- it directly as a chunk!! (Marshall-by-address -- for Types.String!) when others => raise Program_Error; end case; end Prepare_Request; procedure Prepare_General_Header (Buf : access Buffer_Type; RD : PolyORB.SOAP_P.Response.Data) is pragma Warnings (Off); pragma Unreferenced (RD); pragma Warnings (On); begin -- Put_Line (Buf, Header (H_Date, To_HTTP_Date (OS_Lib.GMT_Clock))); Put_Line (Buf, Header (H_Server, "PolyORB")); -- Connection -- if Will_Close then -- -- If there is no connection received we assume a non -- -- Keep-Alive connection. -- Put_Line (Buf, Header (H_Connection, "close")); -- else -- Put_Line (Buf, Messages.Connection -- (AWS.Status.Connection (C_Stat))); -- end if; -- XXX What should we truly do here? end Prepare_General_Header; procedure Prepare_Header_Only (Buf : access Buffer_Type; Version : HTTP_Version; RD : PolyORB.SOAP_P.Response.Data) is Status : constant HTTP_Status_Code := PolyORB.SOAP_P.Response.Status_Code (RD); begin Put_Status_Line (Buf, Version, Status); Prepare_General_Header (Buf, RD); -- There is no content Put_Line (Buf, Header (H_Content_Length, "0")); if Status = S_401_Unauthorized then Put_Line (Buf, Header (H_WWW_Authenticate, "Basic realm=""" & PolyORB.SOAP_P.Response.Realm (RD) & """")); end if; -- End of header New_Line (Buf); end Prepare_Header_Only; procedure Prepare_Message (Buf : access Buffer_Type; Version : HTTP_Version; RD : PolyORB.SOAP_P.Response.Data) is Status : constant HTTP_Status_Code := PolyORB.SOAP_P.Response.Status_Code (RD); begin Put_Status_Line (Buf, Version, Status); if Status = S_301_Moved_Permanently then Put_Line (Buf, Header (H_Location, PolyORB.SOAP_P.Response.Location (RD))); end if; Prepare_General_Header (Buf, RD); Put_Line (Buf, Header (H_Content_Length, Image (Long_Long (PolyORB.SOAP_P.Response.Content_Length (RD))))); Put_Line (Buf, Header (H_Content_Type, PolyORB.SOAP_P.Response.Content_Type (RD))); if Status = S_401_Unauthorized then Put_Line (Buf, Header (H_WWW_Authenticate, "Basic realm=""" & PolyORB.SOAP_P.Response.Realm (RD) & """")); end if; -- End of headers. New_Line (Buf); Put (Buf, PolyORB.SOAP_P.Response.Message_Body (RD)); -- XXX could be more clever and send it chunked... end Prepare_Message; end PolyORB.Filters.HTTP; polyorb-2.8~20110207.orig/src/soap/polyorb-soap_p-message-response.adb0000644000175000017500000000575411750740340025041 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . S O A P _ P . M E S S A G E . R E S P O N S E -- -- -- -- B o d y -- -- -- -- Copyright (C) 2000-2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with PolyORB.Web.MIME; with PolyORB.SOAP_P.Message.XML; package body PolyORB.SOAP_P.Message.Response is ----------- -- Build -- ----------- function Build (R : Object'Class) return PolyORB.SOAP_P.Response.Data is begin return PolyORB.SOAP_P.Response.Build (PolyORB.Web.MIME.Text_XML, String'(PolyORB.SOAP_P.Message.XML.Image (R))); end Build; ---------- -- From -- ---------- function From (P : Message.Payload.Object) return Object is NP : Object; begin Set_Wrapper_Name (NP, Payload.Procedure_Name (P) & "Response"); Set_Parameters (NP, Parameters (P)); Set_Name_Space (NP, Name_Space (P)); return NP; end From; -------------- -- Is_Error -- -------------- function Is_Error (R : Object) return Boolean is pragma Warnings (Off); pragma Unreferenced (R); pragma Warnings (On); begin return False; end Is_Error; end PolyORB.SOAP_P.Message.Response; polyorb-2.8~20110207.orig/src/soap/polyorb-http_methods.ads0000644000175000017500000000503111750740340023011 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . H T T P _ M E T H O D S -- -- -- -- S p e c -- -- -- -- Copyright (C) 2001-2002 Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by ACT Europe. -- -- (email: sales@act-europe.fr) -- -- -- ------------------------------------------------------------------------------ package PolyORB.HTTP_Methods is pragma Elaborate_Body; type Method is ( -- OPTIONS, -- >> "OPTIONS" GET, -- >> "GET" HEAD, -- >> "HEAD" POST, -- >> "POST" PUT, -- >> "PUT" DELETE, -- >> "DELETE" TRACE, -- >> "TRACE" CONNECT, -- >> "CONNECT" Extension_Method -- ); function To_String (Id : Method) return String; function In_Word_Set (S : String) return Method; end PolyORB.HTTP_Methods; polyorb-2.8~20110207.orig/src/soap/polyorb-filters-http.ads0000644000175000017500000002506011750740340022740 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . F I L T E R S . H T T P -- -- -- -- S p e c -- -- -- -- Copyright (C) 2001-2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- HTTP protocol implementation (as a filter so higher-level protocol -- engines can be plugged on it.) with Ada.Streams; with PolyORB.Buffers; with PolyORB.HTTP_Methods; with PolyORB.ORB; with PolyORB.Types; with PolyORB.Utils.Strings.Lists; with PolyORB.Utils.Strings; package PolyORB.Filters.HTTP is type HTTP_Filter_Factory is new Factory with private; procedure Create (Fact : access HTTP_Filter_Factory; Filt : out Filter_Access); type HTTP_Status_Code is (S_Unknown, S_100_Continue, S_101_Switching_Protocols, S_1xx_Other_Informational, S_200_OK, S_201_Created, S_202_Accepted, S_203_Non_Authoritative_Information, S_204_No_Content, S_205_Reset_Content, S_206_Partial_Content, S_2xx_Other_Successful, S_300_Multiple_Choices, S_301_Moved_Permanently, S_302_Found, S_303_See_Other, S_304_Not_Modified, S_305_Use_Proxy, S_306_Unused, S_307_Temporary_Redirect, S_3xx_Other_Redirection, S_400_Bad_Request, S_401_Unauthorized, S_402_Payment_Required, S_403_Forbidden, S_404_Not_Found, S_405_Method_Not_Allowed, S_406_Not_Acceptable, S_407_Proxy_Authentication_Required, S_408_Request_Timeout, S_409_Conflict, S_410_Gone, S_411_Length_Required, S_412_Precondition_Failed, S_413_Request_Entity_Too_Large, S_414_Request_URI_Too_Long, S_415_Unsupported_Media_Type, S_416_Request_Range_Not_Satisfiable, S_417_Expectation_Failed, S_4xx_Other_Client_Error, S_500_Internal_Server_Error, S_501_Not_Implemented, S_502_Bad_Gateway, S_503_Service_Unavailable, S_504_Gateway_Timeout, S_505_HTTP_Version_Not_Supprted, S_5xx_Other_Server_Error); for HTTP_Status_Code'Size use Integer'Size; for HTTP_Status_Code use (S_Unknown => 0, S_100_Continue => 100, S_101_Switching_Protocols => 101, S_1xx_Other_Informational => 199, S_200_OK => 200, S_201_Created => 201, S_202_Accepted => 202, S_203_Non_Authoritative_Information => 203, S_204_No_Content => 204, S_205_Reset_Content => 205, S_206_Partial_Content => 206, S_2xx_Other_Successful => 299, S_300_Multiple_Choices => 300, S_301_Moved_Permanently => 301, S_302_Found => 302, S_303_See_Other => 303, S_304_Not_Modified => 304, S_305_Use_Proxy => 305, S_306_Unused => 306, S_307_Temporary_Redirect => 307, S_3xx_Other_Redirection => 399, S_400_Bad_Request => 400, S_401_Unauthorized => 401, S_402_Payment_Required => 402, S_403_Forbidden => 403, S_404_Not_Found => 404, S_405_Method_Not_Allowed => 405, S_406_Not_Acceptable => 406, S_407_Proxy_Authentication_Required => 407, S_408_Request_Timeout => 408, S_409_Conflict => 409, S_410_Gone => 410, S_411_Length_Required => 411, S_412_Precondition_Failed => 412, S_413_Request_Entity_Too_Large => 413, S_414_Request_URI_Too_Long => 414, S_415_Unsupported_Media_Type => 415, S_416_Request_Range_Not_Satisfiable => 416, S_417_Expectation_Failed => 417, S_4xx_Other_Client_Error => 499, S_500_Internal_Server_Error => 500, S_501_Not_Implemented => 501, S_502_Bad_Gateway => 502, S_503_Service_Unavailable => 503, S_504_Gateway_Timeout => 504, S_505_HTTP_Version_Not_Supprted => 505, S_5xx_Other_Server_Error => 599); subtype Informational_Status_Code is HTTP_Status_Code range S_100_Continue .. S_1xx_Other_Informational; subtype Successful_Status_Code is HTTP_Status_Code range S_200_OK .. S_2xx_Other_Successful; subtype Redirection_Status_Code is HTTP_Status_Code range S_300_Multiple_Choices .. S_3xx_Other_Redirection; subtype Client_Error_Status_Code is HTTP_Status_Code range S_400_Bad_Request .. S_4xx_Other_Client_Error; subtype Server_Error_Status_Code is HTTP_Status_Code range S_500_Internal_Server_Error .. S_5xx_Other_Server_Error; private type HTTP_Version is record Major : Natural; Minor : Natural; end record; ------------------------------------- -- Terminals of the message syntax -- ------------------------------------- CRLF : constant String := ASCII.CR & ASCII.LF; HTTP_Slash : constant String := "HTTP/"; -- in HTTP-Version Encoding_Chunked : constant String := "chunked"; Encoding_Identity : constant String := "identity"; -- in transfer-coding Default_HTTP_Version : constant HTTP_Version := (Major => 1, Minor => 1); ----------- -- Types -- ----------- type HTTP_Filter_Factory is new Factory with null record; type HTTP_State is (Start_Line, Header, Chunk_Size, Entity, Trailer); -- An HTTP session is either expecting a (request or response) -- message start line, a generic message header, the start of -- a data chunk (in chunked transfer encoding), entity data -- or a trailer of entity-headers following the last chunk -- of chunked data. subtype Line_By_Line is HTTP_State range Start_Line .. Chunk_Size; -- In these states, message data is processed by entire lines -- terminated by CRLF. function Image (V : HTTP_Version) return String; package String_Lists renames PolyORB.Utils.Strings.Lists; type HTTP_Filter is new Filter with record Role : PolyORB.ORB.Endpoint_Role; -- The role associated with this protocol engine. State : HTTP_State; -- Current state of the HTTP session. CR_Seen : Boolean := False; -- In Start_Line or Header state, True iff the last character -- seen is a CR. In_Buf : PolyORB.Buffers.Buffer_Access; Data_Received : Ada.Streams.Stream_Element_Count; -- Data received in In_Buf and not processed yet -- (reset when changing states). Message_Buf : PolyORB.Buffers.Buffer_Access; -- This buffer is used for communication of complete -- received message bodies to the upper layer. ---------------------------------------------------------- -- Parameters concerning the HTTP message -- -- currently being processed. -- -- Whenever a member is added here, its -- -- initialization must be added to Clear_Message_State. -- ---------------------------------------------------------- Version : HTTP_Version; Status : HTTP_Status_Code; Request_Method : PolyORB.HTTP_Methods.Method; Request_URI : Utils.Strings.String_Ptr; Content_Length : Ada.Streams.Stream_Element_Offset; Transfer_Encoding : String_Lists.List; -- Values of the corresponding HTTP headers. Chunked : Boolean := False; -- Applied transfer encodings, in REVERSE order -- (consequence: if Length (Transfer_Encoding) > 0 then -- First (Tranfer_Encoding) MUST have the value "chunked" -- (RFC 2616 3.6), and in this case Chunked is True). Transfer_Length : Ada.Streams.Stream_Element_Offset; -- The size of the currently expected chunk of data. -- -1 means expect data of unspecified length; -- 0 means that all the expected data for this message -- has been received, and can now be signalled to the -- upper layer. Entity : PolyORB.Types.String; -- The contents of the entity, as transferred by the -- peer, according to the encoding specified in -- Transfer_Encoding. SOAP_Action : PolyORB.Types.String; -- The contents of a received SOAPAction HTTP header -- (server-side only, optional). -- XXX Having that here is a violation of abstraction. -- Instead, we should keep a dictionnary of (key, value) -- pairs consisting of all the headers (or all the headers -- not interpreted by the HTTP filter itself). -- The burden would then be shifted onto the message -- consumer to retrieve whatever information he needs -- from the headers. end record; procedure Clear_Message_State (F : in out HTTP_Filter); -- Reset all message state members in F to their -- initialization values. procedure Initialize (F : in out HTTP_Filter); procedure Destroy (F : in out HTTP_Filter); function Handle_Message (F : not null access HTTP_Filter; S : Components.Message'Class) return Components.Message'Class; end PolyORB.Filters.HTTP; polyorb-2.8~20110207.orig/src/soap/polyorb-utils-text_buffers.adb0000644000175000017500000000677411750740340024143 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . U T I L S . T E X T _ B U F F E R S -- -- -- -- B o d y -- -- -- -- Copyright (C) 2001-2009, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with Ada.Streams; with PolyORB.Utils.Buffers; package body PolyORB.Utils.Text_Buffers is use Ada.Streams; use PolyORB.Utils.Buffers; ------------------- -- Marshall_Char -- ------------------- procedure Marshall_Char (B : access Buffer_Type; C : Character) is begin Align_Marshall_Copy (B, Stream_Element_Array'(1 => Stream_Element (Character'Pos (C)))); end Marshall_Char; --------------------- -- Unmarshall_Char -- --------------------- function Unmarshall_Char (B : access Buffer_Type) return Character is A : Stream_Element_Array (1 .. 1); begin Align_Unmarshall_Copy (B, Align_1, A); return Character'Val (A (1)); end Unmarshall_Char; --------------------- -- Marshall_String -- --------------------- procedure Marshall_String (B : access Buffer_Type; S : String) is subtype SEA is Stream_Element_Array (1 .. S'Length); A : SEA; for A'Address use S'Address; pragma Import (Ada, A); begin Align_Marshall_Copy (B, A); end Marshall_String; ----------------------- -- Unmarshall_String -- ----------------------- procedure Unmarshall_String (B : access Buffer_Type; S : out String) is subtype SEA is Stream_Element_Array (1 .. S'Length); A : SEA; for A'Address use S'Address; pragma Import (Ada, A); begin Align_Unmarshall_Copy (B, Align_1, A); end Unmarshall_String; end PolyORB.Utils.Text_Buffers; polyorb-2.8~20110207.orig/src/soap/polyorb-buffer_sources.ads0000644000175000017500000000521111750740340023323 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . B U F F E R _ S O U R C E S -- -- -- -- S p e c -- -- -- -- Copyright (C) 2002 Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by ACT Europe. -- -- (email: sales@act-europe.fr) -- -- -- ------------------------------------------------------------------------------ -- An XML/Ada input source type based on PolyORB buffers. with PolyORB.Buffers; with Input_Sources; with Unicode; package PolyORB.Buffer_Sources is type Input_Source is new Input_Sources.Input_Source with private; procedure Set_Buffer (S : in out Input_Source; B : PolyORB.Buffers.Buffer_Access); procedure Next_Char (From : in out Input_Source; C : out Unicode.Unicode_Char); function Eof (From : Input_Source) return Boolean; private type Input_Source is new Input_Sources.Input_Source with record Buf : PolyORB.Buffers.Buffer_Access; end record; end PolyORB.Buffer_Sources; polyorb-2.8~20110207.orig/src/soap/polyorb-soap_p-response.ads0000644000175000017500000001551111750740340023430 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . S O A P _ P . R E S P O N S E -- -- -- -- S p e c -- -- -- -- Copyright (C) 2000-2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- This package is to be used to build answer to be sent to the client -- browser. with Ada.Strings.Unbounded; with Ada.Streams; with PolyORB.Filters.HTTP; -- with AWS.Status; -- with AWS.Messages; with PolyORB.Web.MIME; package PolyORB.SOAP_P.Response is use Ada; use PolyORB.Filters.HTTP; type Data is private; type Data_Mode is (Header, Message); -- , File, Socket_Taken); Default_Moved_Message : constant String := "Page moved
Click here"; -- This is a template message, _@_ will be replaced by the Location (see -- function Build with Location below). ------------------ -- Constructors -- ------------------ function Build (Content_Type : String; Message_Body : String; Status_Code : HTTP_Status_Code := S_200_OK) return Data; function Build (Content_Type : String; UString_Message : Strings.Unbounded.Unbounded_String; Status_Code : HTTP_Status_Code := S_200_OK) return Data; -- Return a message whose body is passed into Message_Body. The -- Content_Type parameter is the MIME type for the message -- body. Status_Code is the response status (see HTTP_Status_Code -- definition). function Build (Content_Type : String; Message_Body : Streams.Stream_Element_Array; Status_Code : HTTP_Status_Code := S_200_OK) return Data; -- Idem above, but the message body is a stream element array. function URL (Location : String) return Data; -- This ask the server for a redirection to the specified URL. function Moved (Location : String; Message : String := Default_Moved_Message) return Data; -- This send back a moved message (S_301) with the specified -- message body. function Acknowledge (Status_Code : HTTP_Status_Code; Message_Body : String := ""; Content_Type : String := PolyORB.Web.MIME.Text_HTML) return Data; -- Returns a message to the Web browser. This routine must be used to -- send back an error message to the Web browser. For example if a -- requested resource cannot be served a message with status code S404 -- must be sent. function Authenticate (Realm : String) return Data; -- Returns an authentification message (S_401), the Web browser -- will then ask for an authentification. Realm string will be displayed -- by the Web Browser in the authentification dialog box. -- function File (Content_Type : String; -- Filename : String) return Data; -- Returns a message whose message body is the content of the file. The -- Content_Type must indicate the MIME type for the file. -- function Socket_Taken return Data; -- Must be used to say that the connection socket has been taken by user -- inside of user callback. No operations should be performed on this -- socket, and associated slot should be released for further operations. --------------- -- Other API -- --------------- function Mode (D : Data) return Data_Mode; -- Returns the data mode, either Header, Message or File. function Status_Code (D : Data) return HTTP_Status_Code; -- Returns the status code. function Content_Length (D : Data) return Natural; -- Returns the content length (i.e. the message body length). A value of 0 -- indicate that there is no message body. function Content_Type (D : Data) return String; -- Returns the MIME type for the message body. function Location (D : Data) return String; -- Returns the location for the new page in the case of a moved -- message. See Moved constructor above. function Message_Body (D : Data) return String; -- Returns the message body content as a string. function Message_Body (D : Data) return Strings.Unbounded.Unbounded_String; -- Returns the message body content as a unbounded_string. function Realm (D : Data) return String; -- Returns the Realm for the current authentification request. function Binary (D : Data) return Streams.Stream_Element_Array; -- Returns the binary message body content. -- type Callback is access function (Request : Status.Data) return Data; -- This is the Web Server Callback procedure. A client must declare and -- pass such procedure to the HTTP record. private use Ada.Strings.Unbounded; type Stream_Element_Array_Access is access Streams.Stream_Element_Array; type Data is record Mode : Data_Mode; Status_Code : HTTP_Status_Code; Content_Length : Natural; Content_Type : Unbounded_String; Message_Body : Unbounded_String; Location : Unbounded_String; Realm : Unbounded_String; Elements : Stream_Element_Array_Access; end record; end PolyORB.SOAP_P.Response; polyorb-2.8~20110207.orig/src/soap/polyorb-soap_p-message-response.ads0000644000175000017500000000517511750740340025057 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . S O A P _ P . M E S S A G E . R E S P O N S E -- -- -- -- S p e c -- -- -- -- Copyright (C) 2000-2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with Ada.Unchecked_Deallocation; with PolyORB.SOAP_P.Response; with PolyORB.SOAP_P.Message.Payload; package PolyORB.SOAP_P.Message.Response is type Object is new Message.Object with null record; type Object_Access is access Object'Class; function Build (R : Object'Class) return PolyORB.SOAP_P.Response.Data; function From (P : Message.Payload.Object) return Object; -- Returns a Response object, initialized from a payload object. function Is_Error (R : Object) return Boolean; procedure Free is new Ada.Unchecked_Deallocation (Object'Class, Object_Access); end PolyORB.SOAP_P.Message.Response; polyorb-2.8~20110207.orig/src/soap/polyorb-buffer_sources.adb0000644000175000017500000000536711750740340023316 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . B U F F E R _ S O U R C E S -- -- -- -- B o d y -- -- -- -- Copyright (C) 2002 Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by ACT Europe. -- -- (email: sales@act-europe.fr) -- -- -- ------------------------------------------------------------------------------ -- An XML/Ada input source type based on PolyORB buffers. with Ada.Streams; with PolyORB.Utils.Text_Buffers; package body PolyORB.Buffer_Sources is use PolyORB.Buffers; use PolyORB.Utils.Text_Buffers; use type Ada.Streams.Stream_Element_Offset; procedure Set_Buffer (S : in out Input_Source; B : PolyORB.Buffers.Buffer_Access) is begin S.Buf := B; end Set_Buffer; procedure Next_Char (From : in out Input_Source; C : out Unicode.Unicode_Char) is begin C := Unicode.To_Unicode (Unmarshall_Char (From.Buf)); end Next_Char; function Eof (From : Input_Source) return Boolean is begin return Remaining (From.Buf) = 0; end Eof; end PolyORB.Buffer_Sources; polyorb-2.8~20110207.orig/src/soap/polyorb-soap_p-message.ads0000644000175000017500000000632111750740340023215 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . S O A P _ P . M E S S A G E -- -- -- -- S p e c -- -- -- -- Copyright (C) 2000-2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with Ada.Strings.Unbounded; with PolyORB.SOAP_P.Parameters; package PolyORB.SOAP_P.Message is use Ada.Strings.Unbounded; type Object is tagged private; function XML_Image (M : Object) return Unbounded_String; -- Returns the XML image for the wrapper and parameters. This is designed -- to be used by Payload and Response object. function Name_Space (M : Object'Class) return String; -- Returns message Namespace. function Wrapper_Name (M : Object'class) return String; -- Returns wrapper name. function Parameters (M : Object'class) return SOAP_P.Parameters.List; -- Returns the parameter. procedure Set_Name_Space (M : in out Object'Class; Name : String); -- Set message's Namespace. procedure Set_Wrapper_Name (M : in out Object'Class; Name : String); -- Set message's wrapper name. procedure Set_Parameters (M : in out Object'Class; P_Set : SOAP_P.Parameters.List); -- Set message's parameters. private type Object is tagged record Name_Space : Unbounded_String; Wrapper_Name : Unbounded_String; P : SOAP_P.Parameters.List; end record; end PolyORB.SOAP_P.Message; polyorb-2.8~20110207.orig/src/soap/polyorb-soap_p.adb0000644000175000017500000000445511750740340021560 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . S O A P _ P -- -- -- -- B o d y -- -- -- -- Copyright (C) 2000-2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ package body PolyORB.SOAP_P is --------- -- Tag -- --------- function Tag (Name : String; Start : Boolean) return String is begin if Start then return '<' & Name & '>'; else return "'; end if; end Tag; end PolyORB.SOAP_P; polyorb-2.8~20110207.orig/src/soap/polyorb-utils-text_buffers.ads0000644000175000017500000000515611750740340024155 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . U T I L S . T E X T _ B U F F E R S -- -- -- -- S p e c -- -- -- -- Copyright (C) 2001-2008, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- Utility functions for storing strings into buffers and retrieving them with PolyORB.Buffers; use PolyORB.Buffers; package PolyORB.Utils.Text_Buffers is pragma Elaborate_Body; procedure Marshall_Char (B : access Buffer_Type; C : Character); -- Marshall one character function Unmarshall_Char (B : access Buffer_Type) return Character; -- Unmarshall one character procedure Marshall_String (B : access Buffer_Type; S : String); -- Marshall a string procedure Unmarshall_String (B : access Buffer_Type; S : out String); -- Unmarshall a string end PolyORB.Utils.Text_Buffers; polyorb-2.8~20110207.orig/src/soap/polyorb-setup-access_points-soap.ads0000644000175000017500000000423111750740340025243 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . S E T U P . A C C E S S _ P O I N T S . S O A P -- -- -- -- S p e c -- -- -- -- Copyright (C) 2003 Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by ACT Europe. -- -- (email: sales@act-europe.fr) -- -- -- ------------------------------------------------------------------------------ -- Set up SOAP TCP Access points. package PolyORB.Setup.Access_Points.SOAP is pragma Elaborate_Body; end PolyORB.Setup.Access_Points.SOAP; polyorb-2.8~20110207.orig/src/soap/polyorb-binding_data-soap.adb0000644000175000017500000004145311750740340023641 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . B I N D I N G _ D A T A . S O A P -- -- -- -- B o d y -- -- -- -- Copyright (C) 2001-2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- Binding data concrete implementation for SOAP over HTTP. with Ada.Streams; with PolyORB.Binding_Objects; with PolyORB.Buffers; with PolyORB.Errors; with PolyORB.Filters.HTTP; with PolyORB.Initialization; with PolyORB.ORB; with PolyORB.Obj_Adapters; with PolyORB.Parameters; with PolyORB.Protocols; with PolyORB.Protocols.SOAP_Pr; with PolyORB.Setup; with PolyORB.Sockets; with PolyORB.References.IOR; with PolyORB.References.URI; with PolyORB.Representations.CDR.Common; -- XXX Unfortunate dependency on CDR code. Should provide -- To_Any methods instead!!!!!! (but actually the Any in question -- would be specific of how IORs are constructed) (but we could -- say that the notion of IOR is cross-platform!). with PolyORB.Transport.Connected.Sockets; with PolyORB.Utils.Strings; with PolyORB.Log; with PolyORB.Web.URL; package body PolyORB.Binding_Data.SOAP is use Ada.Streams; use PolyORB.Log; use PolyORB.Buffers; use PolyORB.Filters.HTTP; use PolyORB.Objects; use PolyORB.Protocols.SOAP_Pr; use PolyORB.Representations.CDR.Common; use PolyORB.Transport; use PolyORB.Transport.Connected.Sockets; use PolyORB.Types; use PolyORB.Utils.Sockets; package L is new PolyORB.Log.Facility_Log ("polyorb.binding_data.soap"); procedure O (Message : Standard.String; Level : Log_Level := Debug) renames L.Output; function C (Level : Log_Level := Debug) return Boolean renames L.Enabled; Preference : Profile_Preference; -- Global variable: the preference to be returned -- by Get_Profile_Preference for SOAP profiles. function Profile_To_URI (P : Profile_Access) return String; function URI_To_Profile (Str : String) return Profile_Access; procedure Marshall_SOAP_Profile_Body (Buf : access Buffers.Buffer_Type; Profile : Profile_Access); function Unmarshall_SOAP_Profile_Body (Buffer : access Buffers.Buffer_Type) return Profile_Access; SOAP_URI_Prefix : constant String := "http://"; ------------- -- Release -- ------------- procedure Release (P : in out SOAP_Profile_Type) is begin Free (P.Address); Free (P.Object_Id); end Release; ------------------ -- Bind_Profile -- ------------------ Htt : aliased Filters.HTTP.HTTP_Filter_Factory; Pro : aliased Protocols.SOAP_Pr.SOAP_Protocol; SOAP_Factories : constant Filters.Factory_Array := (0 => Htt'Access, 1 => Pro'Access); procedure Bind_Profile (Profile : access SOAP_Profile_Type; The_ORB : Components.Component_Access; QoS : PolyORB.QoS.QoS_Parameters; BO_Ref : out Smart_Pointers.Ref; Error : out Errors.Error_Container) is pragma Unreferenced (QoS); use PolyORB.Components; use PolyORB.Binding_Objects; use PolyORB.Errors; use PolyORB.Filters; use PolyORB.ORB; use PolyORB.Protocols; use PolyORB.Sockets; Sock : Socket_Type; TE : constant Transport.Transport_Endpoint_Access := new Socket_Endpoint; begin Create_Socket (Sock); Utils.Sockets.Connect_Socket (Sock, Profile.Address.all); Create (Socket_Endpoint (TE.all), Sock); Binding_Objects.Setup_Binding_Object (The_ORB, TE, SOAP_Factories, BO_Ref, Profile_Access (Profile)); ORB.Register_Binding_Object (ORB.ORB_Access (The_ORB), BO_Ref, ORB.Client); exception when Sockets.Socket_Error => Throw (Error, Comm_Failure_E, System_Exception_Members' (Minor => 0, Completed => Completed_Maybe)); end Bind_Profile; --------------------- -- Get_Profile_Tag -- --------------------- function Get_Profile_Tag (Profile : SOAP_Profile_Type) return Profile_Tag is pragma Warnings (Off); pragma Unreferenced (Profile); pragma Warnings (On); begin return Tag_SOAP; end Get_Profile_Tag; ---------------------------- -- Get_Profile_Preference -- ---------------------------- function Get_Profile_Preference (Profile : SOAP_Profile_Type) return Profile_Preference is pragma Warnings (Off); pragma Unreferenced (Profile); pragma Warnings (On); begin return Preference; end Get_Profile_Preference; ------------------ -- Is_Colocated -- ------------------ function Is_Colocated (Left : SOAP_Profile_Type; Right : Profile_Type'Class) return Boolean is use Sockets; begin return Right in SOAP_Profile_Type and then Left.Address = SOAP_Profile_Type (Right).Address; end Is_Colocated; ------------------ -- Get_URI_Path -- ------------------ function Get_URI_Path (Profile : SOAP_Profile_Type) return Types.String is begin return Profile.URI_Path; end Get_URI_Path; -------------------- -- Create_Factory -- -------------------- procedure Create_Factory (PF : out SOAP_Profile_Factory; TAP : Transport.Transport_Access_Point_Access; ORB : PolyORB.Components.Component_Access) is pragma Warnings (Off); pragma Unreferenced (ORB); pragma Warnings (On); begin PF.Address := new Socket_Name'(Address_Of (Socket_Access_Point (TAP.all))); end Create_Factory; -------------------- -- Create_Profile -- -------------------- function Create_Profile (PF : access SOAP_Profile_Factory; Oid : Objects.Object_Id) return Profile_Access is use PolyORB.Errors; Error : Error_Container; Result : constant Profile_Access := new SOAP_Profile_Type; TResult : SOAP_Profile_Type renames SOAP_Profile_Type (Result.all); begin TResult.Object_Id := new Object_Id'(Oid); TResult.Address := new Socket_Name'(PF.Address.all); Obj_Adapters.Oid_To_Rel_URI (PolyORB.ORB.Object_Adapter (Setup.The_ORB), TResult.Object_Id, TResult.URI_Path, Error); if Found (Error) then Catch (Error); return null; else return Result; end if; end Create_Profile; -------------------- -- Create_Profile -- -------------------- function Create_Profile (URI : Types.String) return Profile_Access is use PolyORB.Web.URL; use Sockets; URL : PolyORB.Web.URL.Object := Parse (To_Standard_String (URI)); Result : constant Profile_Access := new SOAP_Profile_Type; TResult : SOAP_Profile_Type renames SOAP_Profile_Type (Result.all); begin Normalize (URL); TResult.Address := new Socket_Name' (Server_Name (URL) + Port_Type (Positive'(Port (URL)))); TResult.URI_Path := To_PolyORB_String (PolyORB.Web.URL.URI (URL)); if ORB.Is_Profile_Local (Setup.The_ORB, Result) then -- Fill Oid from URI for a local profile. TResult.Object_Id := PolyORB.Obj_Adapters.Rel_URI_To_Oid (PolyORB.ORB.Object_Adapter (Setup.The_ORB), PolyORB.Types.To_Standard_String (TResult.URI_Path)); end if; return Result; end Create_Profile; ----------------------- -- Duplicate_Profile -- ----------------------- function Duplicate_Profile (P : SOAP_Profile_Type) return Profile_Access is Result : constant Profile_Access := new SOAP_Profile_Type; TResult : SOAP_Profile_Type renames SOAP_Profile_Type (Result.all); PP : SOAP_Profile_Type renames P; begin TResult.Object_Id := new Object_Id'(PP.Object_Id.all); TResult.Address := new Socket_Name'(PP.Address.all); TResult.URI_Path := PP.URI_Path; return Result; end Duplicate_Profile; ---------------------- -- Is_Local_Profile -- ---------------------- function Is_Local_Profile (PF : access SOAP_Profile_Factory; P : access Profile_Type'Class) return Boolean is use type PolyORB.Sockets.Sock_Addr_Type; begin if P.all in SOAP_Profile_Type and then SOAP_Profile_Type (P.all).Address = PF.Address then P.Known_Local := True; return True; end if; return False; end Is_Local_Profile; -------------------------------- -- Marshall_SOAP_Profile_Body -- -------------------------------- procedure Marshall_SOAP_Profile_Body (Buf : access Buffer_Type; Profile : Profile_Access) is SOAP_Profile : SOAP_Profile_Type renames SOAP_Profile_Type (Profile.all); Profile_Body : Buffer_Access := new Buffer_Type; begin -- A Tag_SOAP Profile Body is an encapsulation. Start_Encapsulation (Profile_Body); -- Marshalling the socket address Marshall_Socket (Profile_Body, SOAP_Profile.Address.all); -- Marshalling the Object Id Marshall (Profile_Body, Stream_Element_Array (SOAP_Profile.Object_Id.all)); Marshall_Latin_1_String (Profile_Body, SOAP_Profile.URI_Path); -- Marshall the Profile_Body into IOR. Marshall (Buf, Encapsulate (Profile_Body)); Release (Profile_Body); end Marshall_SOAP_Profile_Body; ---------------------------------- -- Unmarshall_SOAP_Profile_Body -- ---------------------------------- function Unmarshall_SOAP_Profile_Body (Buffer : access Buffer_Type) return Profile_Access is Profile_Body : aliased Encapsulation := Unmarshall (Buffer); Profile_Buffer : Buffer_Access := new Buffers.Buffer_Type; Result : constant Profile_Access := new SOAP_Profile_Type; TResult : SOAP_Profile_Type renames SOAP_Profile_Type (Result.all); begin -- A Tag_SOAP Profile Body is an encapsulation. Decapsulate (Profile_Body'Access, Profile_Buffer); -- Unmarshalling the socket address TResult.Address := new Socket_Name'(Unmarshall_Socket (Profile_Buffer)); -- Unmarshalling the Object Id declare Str : aliased constant Stream_Element_Array := Unmarshall (Profile_Buffer); begin TResult.Object_Id := new Object_Id'(Object_Id (Str)); end; TResult.URI_Path := Unmarshall_Latin_1_String (Profile_Buffer); Release (Profile_Buffer); return Result; end Unmarshall_SOAP_Profile_Body; -------------------- -- Profile_To_URI -- -------------------- function Profile_To_URI (P : Profile_Access) return String is use PolyORB.Sockets; use PolyORB.Utils; use PolyORB.Utils.Strings; SOAP_Profile : SOAP_Profile_Type renames SOAP_Profile_Type (P.all); begin pragma Debug (C, O ("SOAP Profile to URI")); return SOAP_URI_Prefix & Image (SOAP_Profile.Address.all) & To_Standard_String (SOAP_Profile.URI_Path); end Profile_To_URI; -------------------- -- URI_To_Profile -- -------------------- function URI_To_Profile (Str : String) return Profile_Access is use PolyORB.Utils; use PolyORB.Utils.Strings; Host_First, Host_Last : Natural; begin if Str'Length > SOAP_URI_Prefix'Length and then Str (Str'First .. Str'First + SOAP_URI_Prefix'Length - 1) = SOAP_URI_Prefix then declare Result : constant Profile_Access := new SOAP_Profile_Type; TResult : SOAP_Profile_Type renames SOAP_Profile_Type (Result.all); S : constant String := Str (Str'First + SOAP_URI_Prefix'Length .. Str'Last); Index : Integer := S'First; Index2 : Integer; begin pragma Debug (C, O ("SOAP URI to profile: enter")); Index2 := Find (S, Index, ':'); if Index2 = S'Last + 1 then return null; end if; pragma Debug (C, O ("Address = " & S (Index .. Index2 - 1))); Host_First := Index; Host_Last := Index2 - 1; Index := Index2 + 1; Index2 := Find (S, Index, '/'); if Index2 = S'Last + 1 then return null; end if; pragma Debug (C, O ("Port = " & S (Index .. Index2 - 1))); TResult.Address := new Socket_Name'(S (Host_First .. Host_Last) + Sockets.Port_Type'Value (S (Index .. Index2 - 1))); Index := Index2; TResult.URI_Path := To_PolyORB_String (S (Index .. S'Last)); pragma Debug (C, O ("URI_Path is " & S (Index .. S'Last))); pragma Debug (C, O ("SOAP URI to profile: leave")); return Result; end; else return null; end if; end URI_To_Profile; ----------- -- Image -- ----------- function Image (Prof : SOAP_Profile_Type) return String is Result : PolyORB.Types.String := To_PolyORB_String ("Address: " & Image (Prof.Address.all)); begin if Prof.Object_Id /= null then Append (Result, ", Object_Id : " & PolyORB.Objects.Image (Prof.Object_Id.all)); else Append (Result, ", object id not available."); end if; return To_Standard_String (Result); end Image; ------------ -- To_URI -- ------------ function To_URI (Prof : SOAP_Profile_Type) return String is begin return "http://" & Image (Prof.Address.all) & To_Standard_String (Prof.URI_Path); end To_URI; ------------ -- Get_OA -- ------------ function Get_OA (Profile : SOAP_Profile_Type) return PolyORB.Smart_Pointers.Entity_Ptr is pragma Unreferenced (Profile); begin return PolyORB.Smart_Pointers.Entity_Ptr (PolyORB.ORB.Object_Adapter (PolyORB.Setup.The_ORB)); end Get_OA; ---------------- -- Initialize -- ---------------- procedure Initialize; procedure Initialize is use PolyORB.References.URI; Preference_Offset : constant String := PolyORB.Parameters.Get_Conf (Section => "soap", Key => "polyorb.binding_data.soap.preference", Default => "0"); begin Preference := Preference_Default + Profile_Preference'Value (Preference_Offset); References.IOR.Register (Tag_SOAP, Marshall_SOAP_Profile_Body'Access, Unmarshall_SOAP_Profile_Body'Access); References.URI.Register (Tag_SOAP, SOAP_URI_Prefix, Profile_To_URI'Access, URI_To_Profile'Access); end Initialize; use PolyORB.Initialization; use PolyORB.Initialization.String_Lists; use PolyORB.Utils.Strings; begin Register_Module (Module_Info' (Name => +"binding_data.soap", Conflicts => Empty, Depends => +"sockets", Provides => +"binding_factories", Implicit => False, Init => Initialize'Access, Shutdown => null)); end PolyORB.Binding_Data.SOAP; polyorb-2.8~20110207.orig/src/soap/polyorb-soap_p-types.ads0000644000175000017500000002337111750740340022741 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . S O A P _ P . T Y P E S -- -- -- -- S p e c -- -- -- -- Copyright (C) 2000-2008, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- This is a partial implementation of the Representation function -- for the SOAP protocol personality of PolyORB. with PolyORB.Any; use PolyORB.Any; package PolyORB.SOAP_P.Types is Data_Error : exception; -- Raised when a variable has not the expected type. function Value_Image (NV : NamedValue) return String; -- Returns O value image. function XML_Image (NV : NamedValue) return String; -- Returns O value encoded for use by the Payload object -- or Response object. This is notionally the Marshall_From_Any -- representation operation. function XML_Type (NV : NamedValue) return String; -- Returns the XML type for the object. function Name (NV : NamedValue) return String; -- Returns name for object O. function Get (NV : NamedValue) return Integer; -- Returns O value as an Integer. -- Raises Data_Error if O is not a SOAP Integer. function Get (NV : NamedValue) return Long_Float; -- Returns O value as an Integer. -- Raises Data_Error if O is not a SOAP Float. function Get (NV : NamedValue) return String; -- Returns O value as a String. -- Raises Data_Error if O is not a SOAP String. function Get (NV : NamedValue) return Boolean; -- Returns O value as a Boolean. -- Raises Data_Error if O is not a SOAP Boolean. -- function "+" (NV : NamedValue) return NamedValue_Controlled; -- -- Allocate an object into the heap and return an access to it. -- function Image (NV : NamedValue) return String; -- function XML_Image (NV : NamedValue) return String; -- function XML_Type (NV : NamedValue) return String; ------------- -- Integer -- ------------- XML_Long : constant String := "xsd:long"; -- -9_223_372_036_854_775_808 .. 9_223_372_036_854_775_807 XML_ULong : constant String := "xsd:unsignedLong"; -- 0 .. 18_446_744_073_709_551_615 XML_Int : constant String := "xsd:int"; -- -2_147_483_648 .. 2_147_483_647 XML_UInt : constant String := "xsd:unsignedInt"; -- 0 .. 4_294_967_295 XML_Short : constant String := "xsd:short"; -- -32_768 .. 32_767 XML_UShort : constant String := "xsd:unsignedShort"; -- 0 .. 65535 XML_UByte : constant String := "xsd:unsignedByte"; -- 0 .. 255 -- type XSD_Integer is new Scalar with private; -- function Image (O : XSD_Integer) return String; -- function XML_Image (O : XSD_Integer) return String; -- function XML_Type (O : XSD_Integer) return String; -- function I (V : Integer; Name : String := "item") -- return XSD_Integer; -- function V (O : XSD_Integer) return Integer; -- ----------- -- -- Float -- -- ----------- XML_Float : constant String := "xsd:float"; XML_Double : constant String := "xsd:double"; -- type XSD_Float is new Scalar with private; -- function Image (O : XSD_Float) return String; -- function XML_Image (O : XSD_Float) return String; -- function XML_Type (O : XSD_Float) return String; -- function F (V : Long_Float; Name : String := "item") -- return XSD_Float; -- function V (O : XSD_Float) return Long_Float; ------------ -- String -- ------------ XML_String : constant String := "xsd:string"; -- type XSD_String is new Scalar with private; -- function Image (O : XSD_String) return String; -- function XML_Image (O : XSD_String) return String; -- function XML_Type (O : XSD_String) return String; -- function S -- (V : String; -- Name : String := "item"; -- Encode : Boolean := True) -- return XSD_String; -- function V (O : XSD_String) return String; ------------- -- Boolean -- ------------- XML_Boolean : constant String := "xsd:boolean"; -- type XSD_Boolean is new Scalar with private; -- function Image (O : XSD_Boolean) return String; -- function XML_Image (O : XSD_Boolean) return String; -- function XML_Type (O : XSD_Boolean) return String; -- function B (V : Boolean; Name : String := "item") -- return XSD_Boolean; -- function V (O : XSD_Boolean) return Boolean; -- ----------------- -- -- TimeInstant -- -- ----------------- -- XML_Time_Instant : constant String := "xsd:timeInstant"; -- type XSD_Time_Instant is new Scalar with private; -- function Image (O : XSD_Time_Instant) return String; -- function XML_Image (O : XSD_Time_Instant) return String; -- function XML_Type (O : XSD_Time_Instant) return String; -- subtype TZ is Integer range -11 .. +11; -- GMT : constant TZ := 0; -- function T -- (V : Ada.Calendar.Time; -- Name : String := "item"; -- Timezone : TZ := GMT) -- return XSD_Time_Instant; -- function V (O : XSD_Time_Instant) return Ada.Calendar.Time; -- -- Returns a GMT date and time. ---------- -- Null -- ---------- XML_Null : constant String := "1"; -- type XSD_Null is new Scalar with private; -- function XML_Image (O : XSD_Null) return String; -- function XML_Type (O : XSD_Null) return String; -- function N (Name : String := "item") return XSD_Null; -- ------------ -- -- Base64 -- -- ------------ -- XML_Base64 : constant String := "SOAP-ENC:base64"; -- type SOAP_Base64 is new Scalar with private; -- function Image (O : SOAP_Base64) return String; -- function XML_Image (O : SOAP_Base64) return String; -- function XML_Type (O : SOAP_Base64) return String; -- function B64 -- (V : String; -- Name : String := "item") -- return SOAP_Base64; -- function V (O : SOAP_Base64) return String; -- ----------- -- -- Array -- -- ----------- XML_Array : constant String := "SOAP-ENC:Array"; XML_Undefined : constant String := "xsd:ur-type"; -- type SOAP_Array is new Composite with private; -- function Image (O : SOAP_Array) return String; -- function XML_Image (O : SOAP_Array) return String; -- function XML_Type (O : SOAP_Array) return String; -- function A -- (V : NamedValue_Set; -- Name : String) -- return SOAP_Array; -- function V (O : SOAP_Array) return NamedValue_Set; XML_AnyURI : constant String := "xsd:anyURI"; -- private -- use Ada.Strings.Unbounded; -- procedure Adjust (O : in out NamedValue_Controlled); -- procedure Finalize (O : in out NamedValue_Controlled); -- type NamedValue is tagged record -- Name : Unbounded_String; -- end record; -- type Scalar is abstract new NamedValue with null record; -- type Composite is abstract new NamedValue with null record; -- type XSD_Integer is new Scalar with record -- V : Integer; -- end record; -- type XSD_Float is new Scalar with record -- V : Long_Float; -- end record; -- type XSD_String is new Scalar with record -- V : Unbounded_String; -- end record; -- type XSD_Boolean is new Scalar with record -- V : Boolean; -- end record; -- type XSD_Time_Instant is new Scalar with record -- T : Ada.Calendar.Time; -- Timezone : TZ; -- end record; -- type XSD_Null is new Scalar with null record; -- type SOAP_Base64 is new Scalar with record -- V : Unbounded_String; -- end record; -- type NamedValue_Set_Access is access NamedValue_Set; -- type NamedValue_Set_Controlled is -- new Ada.Finalization.Controlled with record -- O : NamedValue_Set_Access; -- end record; -- procedure Adjust (O : in out NamedValue_Set_Controlled); -- procedure Finalize (O : in out NamedValue_Set_Controlled); -- type SOAP_Array is new Composite with record -- Items : NamedValue_Set_Controlled; -- end record; -- type SOAP_Record is new Composite with record -- Items : NamedValue_Set_Controlled; -- end record; end PolyORB.SOAP_P.Types; polyorb-2.8~20110207.orig/src/soap/polyorb-soap_p-parameters.ads0000644000175000017500000001266411750740340023743 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . S O A P _ P . P A R A M E T E R S -- -- -- -- S p e c -- -- -- -- Copyright (C) 2000-2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with PolyORB.Any; with PolyORB.Any.NVList; package PolyORB.SOAP_P.Parameters is type List is new PolyORB.Any.NVList.Ref with null record; function Argument_Count (P : List) return Natural; -- Returns the number of parameters in P. function Argument (P : List; Name : String) return PolyORB.Any.NamedValue; -- Returns parameters named Name in P. Raises SOAP.Types.Data_Error if not -- found. function Argument (P : List; N : Positive) return PolyORB.Any.NamedValue; -- Returns Nth parameters in P. Raises SOAP.Types.Data_Error if not found. function Exist (P : List; Name : String) return Boolean; -- Returns True if parameter named Name exist in P and False otherwise. function Get (P : List; Name : String) return Integer; -- Returns parameter named Name in P as an Integer value. Raises -- SOAP.Types.Data_Error if this parameter does not exist or -- is not an Integer. function Get (P : List; Name : String) return Long_Float; -- Returns parameter named Name in P as a Float value. Raises -- SOAP.Types.Data_Error if this parameter does not exist or -- is not a Float. function Get (P : List; Name : String) return String; -- Returns parameter named Name in P as a String value. Raises -- SOAP.Types.Data_Error if this parameter does not exist or -- is not a String. function Get (P : List; Name : String) return Boolean; -- Returns parameter named Name in P as a Boolean value. Raises -- SOAP.Types.Data_Error if this parameter does not exist or -- is not a Boolean. -- function Get (P : List; Name : String) return Types.SOAP_Record; -- -- Returns parameter named Name in P as a SOAP Struct value. Raises -- -- SOAP.Types.Data_Error if this parameter does not exist or -- -- is not a SOAP Struct. -- function Get (P : List; Name : String) return Types.SOAP_Array; -- -- Returns parameter named Name in P as a SOAP Array value. Raises -- -- SOAP.Types.Data_Error if this parameter does not exist or is -- -- not a SOAP Array. ------------------ -- Constructors -- ------------------ function "&" (P : List; O : PolyORB.Any.NamedValue) return List; function "+" (O : PolyORB.Any.NamedValue) return List; ---------------- -- Validation -- ---------------- procedure Check (P : List; N : Natural); -- Checks that there is exactly N parameters or raise -- SOAP.Types.Data_Error. procedure Check_Integer (P : List; Name : String); -- Checks that parameter named Name exist and is an Integer value. procedure Check_Float (P : List; Name : String); -- Checks that parameter named Name exist and is a Float value. procedure Check_Boolean (P : List; Name : String); -- Checks that parameter named Name exist and is a Boolean value. procedure Check_Time_Instant (P : List; Name : String); -- Checks that parameter named Name exist and is a Time_Instant value. procedure Check_Base64 (P : List; Name : String); -- Checks that parameter named Name exist and is a Base64 value. procedure Check_Null (P : List; Name : String); -- Checks that parameter named Name exist and is a Null value. procedure Check_Record (P : List; Name : String); -- Checks that parameter named Name exist and is a Record value. procedure Check_Array (P : List; Name : String); -- Checks that parameter named Name exist and is an Array value. end PolyORB.SOAP_P.Parameters; polyorb-2.8~20110207.orig/src/soap/polyorb-soap_p-message.adb0000644000175000017500000001144711750740340023201 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . S O A P _ P . M E S S A G E -- -- -- -- B o d y -- -- -- -- Copyright (C) 2000-2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with PolyORB.Any; with PolyORB.SOAP_P.Types; with PolyORB.SOAP_P.Message.Response; package body PolyORB.SOAP_P.Message is ---------------- -- Name_Space -- ---------------- function Name_Space (M : Object'Class) return String is begin return To_String (M.Name_Space); end Name_Space; ---------------- -- Parameters -- ---------------- function Parameters (M : Object'Class) return SOAP_P.Parameters.List is begin return M.P; end Parameters; -------------------- -- Set_Name_Space -- -------------------- procedure Set_Name_Space (M : in out Object'Class; Name : String) is begin M.Name_Space := To_Unbounded_String (Name); end Set_Name_Space; -------------------- -- Set_Parameters -- -------------------- procedure Set_Parameters (M : in out Object'Class; P_Set : SOAP_P.Parameters.List) is begin M.P := P_Set; end Set_Parameters; ---------------------- -- Set_Wrapper_Name -- ---------------------- procedure Set_Wrapper_Name (M : in out Object'Class; Name : String) is begin M.Wrapper_Name := To_Unbounded_String (Name); end Set_Wrapper_Name; ------------------ -- Wrapper_Name -- ------------------ function Wrapper_Name (M : Object'class) return String is begin return To_String (M.Wrapper_Name); end Wrapper_Name; --------------- -- XML_Image -- --------------- function XML_Image (M : Object) return Unbounded_String is NL : constant String := ASCII.CR & ASCII.LF; Message_Body : Unbounded_String; begin -- Procedure Append (Message_Body, "" & NL); -- Procedure's parameters declare P : constant SOAP_P.Parameters.List := Parameters (M); begin for K in 1 .. SOAP_P.Parameters.Argument_Count (P) loop declare Param : constant PolyORB.Any.NamedValue := SOAP_P.Parameters.Argument (P, K); use PolyORB.Any; begin if Param.Arg_Modes = ARG_INOUT or else (Param.Arg_Modes = ARG_IN xor (SOAP_P.Message.Object'Class (M) in SOAP_P.Message.Response.Object'Class)) then Append (Message_Body, " " & Types.XML_Image (Param) & NL); end if; end; end loop; end; -- Close payload objects. Append (Message_Body, Tag ("awsns:" & Wrapper_Name (M), False) & NL); return Message_Body; end XML_Image; end PolyORB.SOAP_P.Message; polyorb-2.8~20110207.orig/src/soap/polyorb-protocols-soap_pr.ads0000644000175000017500000001002611750740340023774 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . P R O T O C O L S . S O A P _ P R -- -- -- -- S p e c -- -- -- -- Copyright (C) 2001-2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with PolyORB.Buffers; with PolyORB.ORB; with PolyORB.Requests; with PolyORB.Types; with PolyORB.SOAP_P.Message.Payload; package PolyORB.Protocols.SOAP_Pr is -- Elaboration: Protocols.SOAP_Pr (spec), -- Binding_Data.SOAP (spec+body), Protocols.SOAP_Pr (body). type SOAP_Protocol is new Protocol with private; type SOAP_Session is new Session with private; procedure Create (Proto : access SOAP_Protocol; Session : out Filter_Access); procedure Invoke_Request (S : access SOAP_Session; R : Requests.Request_Access; Pro : access Binding_Data.Profile_Type'Class); procedure Abort_Request (S : access SOAP_Session; R : Requests.Request_Access); procedure Send_Reply (S : access SOAP_Session; R : Requests.Request_Access); procedure Handle_Connect_Indication (S : access SOAP_Session); procedure Handle_Connect_Confirmation (S : access SOAP_Session); procedure Handle_Data_Indication (S : access SOAP_Session; Data_Amount : Ada.Streams.Stream_Element_Count; Error : in out Errors.Error_Container); procedure Handle_Unmarshall_Arguments (S : access SOAP_Session; Args : in out PolyORB.Any.NVList.Ref; Error : in out PolyORB.Errors.Error_Container); procedure Handle_Disconnect (S : access SOAP_Session; Error : Errors.Error_Container); procedure Handle_Flush (S : access SOAP_Session); private type SOAP_Protocol is new Protocol with null record; type SOAP_Session is new Session with record In_Buf : PolyORB.Buffers.Buffer_Access; Entity_Length : Ada.Streams.Stream_Element_Count; Role : PolyORB.ORB.Endpoint_Role; Target : PolyORB.Types.String; Current_SOAP_Req : PolyORB.SOAP_P.Message.Payload.Object_Access; Pending_Rq : PolyORB.Requests.Request_Access; end record; function Handle_Message (Sess : not null access SOAP_Session; S : Components.Message'Class) return Components.Message'Class; end PolyORB.Protocols.SOAP_Pr; polyorb-2.8~20110207.orig/src/soap/polyorb-soap_p-message-payload.ads0000644000175000017500000000575511750740340024656 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . S O A P _ P . M E S S A G E . P A Y L O A D -- -- -- -- S p e c -- -- -- -- Copyright (C) 2000-2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with Ada.Unchecked_Deallocation; with PolyORB.SOAP_P.Parameters; package PolyORB.SOAP_P.Message.Payload is type Object is new Message.Object with private; type Object_Access is access Object'Class; function Procedure_Name (P : Object'Class) return String; -- Retruns the Payload procedure name. procedure Set_Procedure_Name (P : in out Object'Class; Name : String); -- Set the payload procedure name. function Build (Procedure_Name : String; P_Set : SOAP_P.Parameters.List; Name_Space : String := "") return Object; -- Retruns a Payload object initialized with the procedure name, -- parameters and name space. procedure Free (X : in out Object_Access); private type Object is new Message.Object with null record; procedure Do_Free is new Ada.Unchecked_Deallocation (Object'Class, Object_Access); procedure Free (X : in out Object_Access) renames Do_Free; end PolyORB.SOAP_P.Message.Payload; polyorb-2.8~20110207.orig/src/soap/polyorb-soap_p-message-payload.adb0000644000175000017500000000556411750740340024633 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . S O A P _ P . M E S S A G E . P A Y L O A D -- -- -- -- B o d y -- -- -- -- Copyright (C) 2000-2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ package body PolyORB.SOAP_P.Message.Payload is ----------- -- Build -- ----------- function Build (Procedure_Name : String; P_Set : SOAP_P.Parameters.List; Name_Space : String := "") return Object is begin return (To_Unbounded_String (Name_Space), To_Unbounded_String (Procedure_Name), P_Set); end Build; -------------------- -- Procedure_Name -- -------------------- function Procedure_Name (P : Object'Class) return String is begin return Wrapper_Name (P); end Procedure_Name; ------------------------ -- Set_Procedure_Name -- ------------------------ procedure Set_Procedure_Name (P : in out Object'Class; Name : String) is begin Set_Wrapper_Name (P, Name); end Set_Procedure_Name; end PolyORB.SOAP_P.Message.Payload; polyorb-2.8~20110207.orig/src/soap/polyorb-soap_p-message-xml.adb0000644000175000017500000010463511750740340024001 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . S O A P _ P . M E S S A G E . X M L -- -- -- -- B o d y -- -- -- -- Copyright (C) 2000-2008, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with Ada.Exceptions; with DOM.Core.Nodes; with Sax.Readers; with PolyORB.Any; with PolyORB.Any.ObjRef; with PolyORB.Binding_Data; with PolyORB.Binding_Data.SOAP; with PolyORB.Log; with PolyORB.References; with PolyORB.Types; with PolyORB.SOAP_P.Message.Reader; with PolyORB.SOAP_P.Message.Response.Error; with PolyORB.SOAP_P.Types; package body PolyORB.SOAP_P.Message.XML is use DOM.Core.Nodes; use SOAP_P.Message.Reader; use PolyORB.Any; use PolyORB.Log; use PolyORB.Types; package L is new PolyORB.Log.Facility_Log ("soap.message.xml"); procedure O (Message : String; Level : Log_Level := Debug) renames L.Output; function C (Level : Log_Level := Debug) return Boolean renames L.Enabled; NL : constant String := ASCII.CR & ASCII.LF; XML_Header : constant String := ""; URL_Enc : constant String := "http://schemas.xmlsoap.org/soap/encoding/"; URL_Env : constant String := "http://schemas.xmlsoap.org/soap/envelope/"; URL_xsd : constant String := "http://www.w3.org/1999/XMLSchema"; URL_xsi : constant String := "http://www.w3.org/1999/XMLSchema-instance"; Start_Env : constant String := ""; Start_Body : constant String := ""; End_Body : constant String := ""; Start_Fault_Env : constant String := ""; pragma Warnings (Off); pragma Unreferenced (Start_Fault_Env); pragma Warnings (On); type Array_State is (Void, A_Undefined, A_Int, A_Short, A_UInt, A_UShort, A_UByte, A_Float, A_Double, A_String, A_Boolean, A_Time_Instant, A_Base64); pragma Warnings (Off); pragma Unreferenced (A_Int, A_Short, A_UInt, A_UShort, A_UByte, A_Float, A_Double, A_String, A_Boolean, A_Time_Instant, A_Base64); -- Parsing of arrays is currently disabled. pragma Warnings (On); type Message_Kind is (Payload, Response); type State is record Wrapper_Name : Unbounded_String; Parameters : SOAP_P.Parameters.List; Kind : Message_Kind; A_State : Array_State := Void; end record; procedure Parse_Envelope (N : DOM.Core.Node; S : in out State); procedure Parse_Document (N : DOM.Core.Node; S : in out State); procedure Parse_Body (N : DOM.Core.Node; S : in out State); procedure Parse_Wrapper (N : DOM.Core.Node; S : in out State); -------------------------------------- -- Elementary data parsing routines -- -------------------------------------- procedure Parse_Int (N : DOM.Core.Node; NV : in out NamedValue); procedure Parse_Short (N : DOM.Core.Node; NV : in out PolyORB.Any.NamedValue); procedure Parse_UInt (N : DOM.Core.Node; NV : in out PolyORB.Any.NamedValue); procedure Parse_UShort (N : DOM.Core.Node; NV : in out PolyORB.Any.NamedValue); procedure Parse_UByte (N : DOM.Core.Node; NV : in out PolyORB.Any.NamedValue); procedure Parse_Float (N : DOM.Core.Node; NV : in out PolyORB.Any.NamedValue); procedure Parse_Double (N : DOM.Core.Node; NV : in out PolyORB.Any.NamedValue); procedure Parse_String (N : DOM.Core.Node; NV : in out PolyORB.Any.NamedValue); procedure Parse_Char (N : DOM.Core.Node; NV : in out PolyORB.Any.NamedValue); procedure Parse_ObjRef (N : DOM.Core.Node; NV : in out PolyORB.Any.NamedValue; Type_Id : String); procedure Parse_Boolean (N : DOM.Core.Node; NV : in out PolyORB.Any.NamedValue); procedure Parse_Enum (N : DOM.Core.Node; NV : in out PolyORB.Any.NamedValue); -- function Parse_Base64 (N : DOM.Core.Node) -- return PolyORB.Any.NamedValue; -- function Parse_Time_Instant -- (N : DOM.Core.Node) -- return PolyORB.Any.NamedValue; -------------------------------------------------------- -- Aggregates and data containers parsing subprograms -- -------------------------------------------------------- function Parse_Param (N : DOM.Core.Node; S : State; Expected_Type : PolyORB.Any.TypeCode.Local_Ref) return PolyORB.Any.NamedValue; -- Parse any parameter. This is notionally the Unmashall_To_Any -- representation operation. -- function Parse_Array -- (N : DOM.Core.Node; -- S : State) -- return PolyORB.Any.NamedValue; function Parse_Record (N : DOM.Core.Node; S : State; Expected_Type : PolyORB.Any.TypeCode.Local_Ref) return PolyORB.Any.NamedValue; function Parse_Sequence (N : DOM.Core.Node; S : State; Expected_Type : PolyORB.Any.TypeCode.Local_Ref) return PolyORB.Any.NamedValue; procedure Error (Node : DOM.Core.Node; Message : String); pragma No_Return (Error); -- Raises SOAP_Error with the Message as exception message. ----------- -- Image -- ----------- function Image (Obj : Object'Class) return String is begin return To_String (XML.Image (Obj)); end Image; ----------- -- Image -- ----------- function Image (Obj : Object'Class) return Unbounded_String is Message_Body : Unbounded_String; begin -- Header Append (Message_Body, XML_Header & NL); Append (Message_Body, Header & NL); -- Body Append (Message_Body, Start_Body & NL); -- Wrapper Append (Message_Body, Message.XML_Image (Obj)); -- End of Body and Envelope Append (Message_Body, End_Body & NL); Append (Message_Body, End_Env & NL); return Message_Body; end Image; ------------------ -- Load_Payload -- ------------------ procedure Load_Payload (Source : access Input_Sources.Input_Source'Class; Args : in out PolyORB.Any.NVList.Ref; R_Payload : out Message.Payload.Object_Access) is Reader : Tree_Reader; S : State; Doc : DOM.Core.Document; begin -- If True, xmlns:* attributes will be reported in Start_Element Set_Feature (Reader, Sax.Readers.Namespace_Prefixes_Feature, True); Set_Feature (Reader, Sax.Readers.Validation_Feature, False); Parse (Reader, Source.all); Doc := Get_Tree (Reader); S.Parameters := SOAP_P.Parameters.List'(Args with null record); S.Kind := Payload; Parse_Document (Doc, S); Args := PolyORB.Any.NVList.Ref (S.Parameters); -- May have been modified by Parse_Document (if it was -- initially empty). Free (Doc); R_Payload := new Message.Payload.Object' (Message.Payload.Build (To_String (S.Wrapper_Name), S.Parameters)); end Load_Payload; ------------------- -- Load_Response -- ------------------- function Load_Response (Source : access Input_Sources.Input_Source'Class; Args : PolyORB.Any.NVList.Ref) return Message.Response.Object_Access is Reader : Tree_Reader; S : State; Doc : DOM.Core.Document; begin -- If True, xmlns:* attributes will be reported in Start_Element Set_Feature (Reader, Sax.Readers.Namespace_Prefixes_Feature, True); Set_Feature (Reader, Sax.Readers.Validation_Feature, False); Parse (Reader, Source.all); Doc := Get_Tree (Reader); SOAP_P.Parameters.Create (S.Parameters); S.Parameters := SOAP_P.Parameters.List'(Args with null record); S.Kind := Response; Parse_Document (Doc, S); Free (Doc); if SOAP_P.Parameters.Exist (S.Parameters, "faultcode") then return new Message.Response.Error.Object' (Message.Response.Error.Build (Faultcode => Message.Response.Error.Faultcode (String'(SOAP_P.Parameters.Get (S.Parameters, "faultcode"))), Faultstring => SOAP_P.Parameters.Get (S.Parameters, "faultstring"))); else return new Message.Response.Object' (Null_Unbounded_String, S.Wrapper_Name, S.Parameters); end if; exception when E : others => return new Message.Response.Error.Object' (Message.Response.Error.Build (Faultcode => Message.Response.Error.Client, Faultstring => Ada.Exceptions.Exception_Message (E))); end Load_Response; procedure Load_Response (Source : access Input_Sources.Input_Source'Class; Args : in out PolyORB.Any.NVList.Ref) is Reader : Tree_Reader; S : State; Doc : DOM.Core.Document; begin -- If True, xmlns:* attributes will be reported in Start_Element Set_Feature (Reader, Sax.Readers.Namespace_Prefixes_Feature, True); Set_Feature (Reader, Sax.Readers.Validation_Feature, False); Parse (Reader, Source.all); Doc := Get_Tree (Reader); SOAP_P.Parameters.Create (S.Parameters); S.Parameters := SOAP_P.Parameters.List'(Args with null record); S.Kind := Response; Parse_Document (Doc, S); Args := PolyORB.Any.NVList.Ref (S.Parameters); -- May have been modified by Parse_Document (if it was -- initially empty). Free (Doc); end Load_Response; ----------------- -- Parse_Array -- ----------------- -- function Parse_Array -- (N : DOM.Core.Node; -- S : State) -- return PolyORB.Any.NamedValue -- is -- use type DOM.Core.Node; -- use SOAP.Types; -- function A_State (A_Type : String) return Array_State; -- -- Returns the Array_State given the SOAP-ENC:arrayType value. -- function A_State (A_Type : String) return Array_State is -- N : constant Positive := Strings.Fixed.Index (A_Type, "["); -- T : constant String := A_Type (A_Type'First .. N - 1); -- begin -- if T = Types.XML_Int then -- return A_Int; -- elsif T = Types.XML_Float then -- return A_Float; -- elsif T = Types.XML_String then -- return A_String; -- elsif T = Types.XML_Boolean then -- return A_Boolean; -- elsif T = Types.XML_Time_Instant then -- return A_Time_Instant; -- elsif T = Types.XML_Base64 then -- return A_Base64; -- elsif T = Types.XML_Undefined then -- return A_Undefined; -- end if; -- Error (Parse_Array.N, -- "Wrong type or not supported type in an array"); -- end A_State; -- Name : constant String := Local_Name (N); -- OS : Types.Object_Set (1 .. Max_Object_Size); -- K : Natural := 0; -- Field : DOM.Core.Node; -- Atts : constant DOM.Core.Named_Node_Map := Attributes (N); -- A_Type : constant Array_State -- := A_State (Node_Value (Get_Named_Item -- (Atts, "SOAP-ENC:arrayType"))); -- begin -- Field := First_Child (N); -- while Field /= null loop -- K := K + 1; -- OS (K) := +Parse_Param (Field, -- (S.Wrapper_Name, S.Parameters, A_Type)); -- Field := Next_Sibling (Field); -- end loop; -- return Types.A (OS (1 .. K), Name); -- end Parse_Array; -- ------------------ -- -- Parse_Base64 -- -- ------------------ -- function Parse_Base64 -- (N : DOM.Core.Node) return PolyORB.Any.NamedValue is -- Name : constant String := Local_Name (N); -- Value : DOM.Core.Node; -- begin -- Normalize (N); -- Value := First_Child (N); -- return Types.B64 (Node_Value (Value), Name); -- end Parse_Base64; ---------------- -- Parse_Body -- ---------------- procedure Parse_Body (N : DOM.Core.Node; S : in out State) is begin Parse_Wrapper (First_Child (N), S); end Parse_Body; ------------------- -- Parse_Boolean -- ------------------- procedure Parse_Boolean (N : DOM.Core.Node; NV : in out PolyORB.Any.NamedValue) is Value : constant DOM.Core.Node := First_Child (N); begin Set_Any_Value (Node_Value (Value) = "1", Get_Container (NV.Argument).all); end Parse_Boolean; procedure Parse_Enum (N : DOM.Core.Node; NV : in out PolyORB.Any.NamedValue) is use PolyORB.Any.TypeCode; use type DOM.Core.Node; begin declare TC : constant PolyORB.Any.TypeCode.Object_Ptr := Get_Unwound_Type (NV.Argument); A : PolyORB.Any.Any := Get_Empty_Any_Aggregate (Get_Type (NV.Argument)); Atts : constant DOM.Core.Named_Node_Map := Attributes (N); Value : constant DOM.Core.Node := First_Child (N); Enumerator_Id_Node : constant DOM.Core.Node := Get_Named_Item (Atts, "id"); Enumerator_Literal : constant String := Node_Value (Value); begin if Enumerator_Id_Node /= null then Add_Aggregate_Element (A, To_Any (Unsigned_Long'Value (Node_Value (Enumerator_Id_Node)) - 1)); else for J in 0 .. Member_Count (TC) - 1 loop declare Enumerator : constant String := To_Standard_String (Enumerator_Name (TC, J)); begin if Enumerator_Literal = Enumerator then Add_Aggregate_Element (A, To_Any (J)); exit; end if; end; end loop; end if; Move_Any_Value (NV.Argument, A); end; end Parse_Enum; -------------------- -- Parse_Sequence -- -------------------- function Parse_Sequence (N : DOM.Core.Node; S : State; Expected_Type : PolyORB.Any.TypeCode.Local_Ref) return PolyORB.Any.NamedValue is use PolyORB.Any.TypeCode; use type DOM.Core.Node; Name : constant PolyORB.Types.Identifier := To_PolyORB_String (Local_Name (N)); A : PolyORB.Any.Any := Get_Empty_Any_Aggregate (Expected_Type); Unwound_Expected_Type : constant PolyORB.Any.TypeCode.Local_Ref := Unwind_Typedefs (Expected_Type); Content_Type : constant PolyORB.Any.TypeCode.Local_Ref := TypeCode.Content_Type (Unwound_Expected_Type); Values : constant DOM.Core.Node_List := Child_Nodes (N); Length : constant Unsigned_Long := Unsigned_Long (DOM.Core.Nodes.Length (Values)); Bound : constant Unsigned_Long := PolyORB.Any.TypeCode.Length (Unwound_Expected_Type); Child : DOM.Core.Node := First_Child (N); begin if Bound > 0 and then Length > Bound then raise Constraint_Error; end if; Add_Aggregate_Element (A, To_Any (Length)); for I in 1 .. Length loop Add_Aggregate_Element (A, Parse_Param (Child, S, Content_Type).Argument); Child := Next_Sibling (Child); end loop; return (Name => Name, Argument => A, Arg_Modes => ARG_IN); end Parse_Sequence; -------------------- -- Parse_Document -- -------------------- procedure Parse_Document (N : DOM.Core.Node; S : in out State) is NL : constant DOM.Core.Node_List := Child_Nodes (N); begin if Length (NL) = 1 then Parse_Envelope (First_Child (N), S); else Error (N, "Document must have a single node, found " & Natural'Image (Length (NL))); end if; end Parse_Document; -------------------- -- Parse_Envelope -- -------------------- procedure Parse_Envelope (N : DOM.Core.Node; S : in out State) is NL : constant DOM.Core.Node_List := Child_Nodes (N); begin if Length (NL) = 1 then Parse_Body (First_Child (N), S); else Error (N, "Envelope must have a single node, found " & Natural'Image (Length (NL))); end if; end Parse_Envelope; ----------------- -- Parse_Float -- ----------------- procedure Parse_Float (N : DOM.Core.Node; NV : in out PolyORB.Any.NamedValue) is Value : constant DOM.Core.Node := First_Child (N); begin Set_Any_Value (PolyORB.Types.Float'Value (Node_Value (Value)), Get_Container (NV.Argument).all); end Parse_Float; ------------------ -- Parse_Double -- ------------------ procedure Parse_Double (N : DOM.Core.Node; NV : in out PolyORB.Any.NamedValue) is Value : constant DOM.Core.Node := First_Child (N); begin Set_Any_Value (PolyORB.Types.Double'Value (Node_Value (Value)), Get_Container (NV.Argument).all); end Parse_Double; --------------- -- Parse_Int -- --------------- procedure Parse_Int (N : DOM.Core.Node; NV : in out PolyORB.Any.NamedValue) is Value : constant DOM.Core.Node := First_Child (N); begin Set_Any_Value (PolyORB.Types.Long'Value (Node_Value (Value)), Get_Container (NV.Argument).all); end Parse_Int; ----------------- -- Parse_Short -- ----------------- procedure Parse_Short (N : DOM.Core.Node; NV : in out PolyORB.Any.NamedValue) is Value : constant DOM.Core.Node := First_Child (N); begin Set_Any_Value (PolyORB.Types.Short'Value (Node_Value (Value)), Get_Container (NV.Argument).all); end Parse_Short; ---------------- -- Parse_UInt -- ---------------- procedure Parse_UInt (N : DOM.Core.Node; NV : in out PolyORB.Any.NamedValue) is Value : constant DOM.Core.Node := First_Child (N); begin Set_Any_Value (PolyORB.Types.Unsigned_Long'Value (Node_Value (Value)), Get_Container (NV.Argument).all); end Parse_UInt; ------------------ -- Parse_UShort -- ------------------ procedure Parse_UShort (N : DOM.Core.Node; NV : in out PolyORB.Any.NamedValue) is Value : constant DOM.Core.Node := First_Child (N); begin Set_Any_Value (PolyORB.Types.Unsigned_Short'Value (Node_Value (Value)), Get_Container (NV.Argument).all); end Parse_UShort; ----------------- -- Parse_UByte -- ----------------- procedure Parse_UByte (N : DOM.Core.Node; NV : in out PolyORB.Any.NamedValue) is Value : constant DOM.Core.Node := First_Child (N); begin Set_Any_Value (PolyORB.Types.Octet'Value (Node_Value (Value)), Get_Container (NV.Argument).all); end Parse_UByte; ------------------ -- Parse_String -- ------------------ procedure Parse_String (N : DOM.Core.Node; NV : in out PolyORB.Any.NamedValue) is use type DOM.Core.Node; Value : DOM.Core.Node; Bound : constant PolyORB.Types.Unsigned_Long := TypeCode.Length (Get_Unwound_Type (NV.Argument)); begin Normalize (N); Value := First_Child (N); if Value /= null then declare S : constant String := Node_Value (Value); begin if Bound > 0 and then S'Length > Bound then raise Constraint_Error; end if; Set_Any_Value (To_PolyORB_String (Node_Value (Value)), Get_Container (NV.Argument).all); end; else Set_Any_Value (To_PolyORB_String (""), Get_Container (NV.Argument).all); end if; end Parse_String; ---------------- -- Parse_Char -- ---------------- procedure Parse_Char (N : DOM.Core.Node; NV : in out PolyORB.Any.NamedValue) is use type DOM.Core.Node; Value : DOM.Core.Node; begin Normalize (N); Value := First_Child (N); if Value /= null then declare Str : constant String := Node_Value (Value); begin if Str'Length = 1 then Set_Any_Value (PolyORB.Types.Char (Str (Str'First)), Get_Container (NV.Argument).all); return; end if; end; end if; raise Constraint_Error; end Parse_Char; ------------------ -- Parse_ObjRef -- ------------------ procedure Parse_ObjRef (N : DOM.Core.Node; NV : in out PolyORB.Any.NamedValue; Type_Id : String) is P : PolyORB.Binding_Data.Profile_Access; R : PolyORB.References.Ref; begin pragma Debug (C, O ("Parse_ObjRef: Type_Id = " & Type_Id)); Normalize (N); P := PolyORB.Binding_Data.SOAP.Create_Profile (To_PolyORB_String (Node_Value (First_Child (N)))); PolyORB.References.Create_Reference (Profiles => (1 => P), Type_Id => Type_Id, R => R); PolyORB.Any.ObjRef.Set_Any_Value (R, Get_Container (NV.Argument).all); end Parse_ObjRef; ------------------------ -- Parse_Time_Instant -- ------------------------ -- function Parse_Time_Instant -- (N : DOM.Core.Node) -- return PolyORB.Any.NamedValue -- is -- use Ada.Calendar; -- Name : constant PolyORB.Types.Identifier -- := To_PolyORB_String (Local_Name (N)); -- Value : constant DOM.Core.Node := First_Child (N); -- TI : constant String := Node_Value (Value); -- begin -- return Types.T -- (Time_Of (Year => Year_Number'Value (TI (1 .. 4)), -- Month => Month_Number'Value (TI (6 .. 7)), -- Day => Day_Number'Value (TI (9 .. 10)), -- Seconds => Duration (Natural'Value (TI (12 .. 13)) * 3600 -- + Natural'Value (TI (15 .. 16)) * 60 -- + Natural'Value (TI (18 .. 19)))), -- Name, -- Types.TZ'Value (TI (20 .. 22))); -- end Parse_Time_Instant; ----------------- -- Parse_Param -- ----------------- function Parse_Param (N : DOM.Core.Node; S : State; Expected_Type : PolyORB.Any.TypeCode.Local_Ref) return PolyORB.Any.NamedValue is use type DOM.Core.Node; Atts : constant DOM.Core.Named_Node_Map := Attributes (N); NV : PolyORB.Any.NamedValue; procedure Get_Empty_Any_With_Default (Expected_Type, Default_Expected_Type : PolyORB.Any.TypeCode.Local_Ref; NV : in out PolyORB.Any.NamedValue); procedure Get_Empty_Any_With_Default (Expected_Type, Default_Expected_Type : PolyORB.Any.TypeCode.Local_Ref; NV : in out PolyORB.Any.NamedValue) is TCK : constant TCKind := TypeCode.Kind (Expected_Type); begin if TCK /= Tk_Void then NV.Argument := Get_Empty_Any (Expected_Type); else NV.Argument := Get_Empty_Any (Default_Expected_Type); NV.Arg_Modes := ARG_IN; end if; end Get_Empty_Any_With_Default; begin if To_String (S.Wrapper_Name) = "Fault" then NV.Name := To_PolyORB_String (Local_Name (N)); NV.Argument := Get_Empty_Any (TC_String); Parse_String (N, NV); return NV; end if; case S.A_State is -- XXX PARSING ARRAYS: not implemened. -- when A_Int => -- return Parse_Int (N); -- when A_Short => -- return Parse_Short (N); -- when A_UInt => -- return Parse_UInt (N); -- when A_UShort => -- return Parse_UShort (N); -- when A_UByte => -- return Parse_UByte (N); -- when A_Float => -- return Parse_Float (N); -- when A_Double => -- return Parse_Double (N); -- when A_String => -- return Parse_String (N); -- when A_AnyURI => -- return Parse_AnyURI (N); -- when A_Boolean => -- return Parse_Boolean (N); -- when A_Time_Instant => -- -- XXX return Parse_Time_Instant (N); -- raise PolyORB.Not_Implemented; -- when A_Base64 => -- -- XXX return Parse_Base64 (N); -- raise PolyORB.Not_Implemented; when Void | A_Undefined => declare XSI_Type : constant DOM.Core.Node := Get_Named_Item (Atts, "xsi:type"); Expected_TCKind : constant TCKind := PolyORB.Any.TypeCode.Kind (Unwind_Typedefs (Expected_Type)); begin if XSI_Type = null then if Get_Named_Item (Atts, "xsi:null") /= null then NV.Name := To_PolyORB_String (Local_Name (N)); NV.Argument := Get_Empty_Any (TC_Void); else case Expected_TCKind is when Tk_Enum => NV.Name := To_PolyORB_String (Local_Name (N)); NV.Argument := Get_Empty_Any (Expected_Type); Parse_Enum (N, NV); when Tk_Sequence => return Parse_Sequence (N, S, Expected_Type); when Tk_Struct => return Parse_Record (N, S, Expected_Type); when others => Error (N, "Wrong or not supported type, expected " & TCKind'Image (Expected_TCKind)); -- Raises an exception. end case; end if; return NV; else declare xsd : constant String := Node_Value (XSI_Type); begin NV.Name := To_PolyORB_String (Local_Name (N)); if xsd = Types.XML_Int then Get_Empty_Any_With_Default (Expected_Type, PolyORB.Any.TC_Long, NV); Parse_Int (N, NV); elsif xsd = Types.XML_Short then Get_Empty_Any_With_Default (Expected_Type, PolyORB.Any.TC_Short, NV); Parse_Short (N, NV); elsif xsd = Types.XML_UInt then Get_Empty_Any_With_Default (Expected_Type, PolyORB.Any.TC_Unsigned_Long, NV); Parse_UInt (N, NV); elsif xsd = Types.XML_UShort then Get_Empty_Any_With_Default (Expected_Type, PolyORB.Any.TC_Unsigned_Short, NV); Parse_UShort (N, NV); elsif xsd = Types.XML_UByte then Get_Empty_Any_With_Default (Expected_Type, PolyORB.Any.TC_Octet, NV); Parse_UByte (N, NV); elsif xsd = Types.XML_Float then Get_Empty_Any_With_Default (Expected_Type, PolyORB.Any.TC_Float, NV); Parse_Float (N, NV); elsif xsd = Types.XML_Double then Get_Empty_Any_With_Default (Expected_Type, PolyORB.Any.TC_Double, NV); Parse_Double (N, NV); elsif xsd = Types.XML_String then Get_Empty_Any_With_Default (Expected_Type, PolyORB.Any.TC_String, NV); if Expected_TCKind = Tk_Char then Parse_Char (N, NV); else Parse_String (N, NV); end if; elsif xsd = Types.XML_Boolean then Get_Empty_Any_With_Default (Expected_Type, PolyORB.Any.TC_Boolean, NV); Parse_Boolean (N, NV); elsif Expected_TCKind = Tk_Objref then NV.Argument := Get_Empty_Any (Expected_Type); Parse_ObjRef (N, NV, Type_Id => xsd); else Error (N, "Wrong or not supported type"); end if; end; end if; end; when others => raise Program_Error; end case; return NV; end Parse_Param; ------------------ -- Parse_Record -- ------------------ function Parse_Record (N : DOM.Core.Node; S : State; Expected_Type : TypeCode.Local_Ref) return PolyORB.Any.NamedValue is use type DOM.Core.Node; use SOAP_P.Types; use PolyORB.Any.TypeCode; Unwound_Expected_Type : constant TypeCode.Local_Ref := Unwind_Typedefs (Expected_Type); Name : constant PolyORB.Types.Identifier := To_PolyORB_String (Local_Name (N)); Any_Record : PolyORB.Any.Any := Get_Empty_Any_Aggregate (Expected_Type); Field : DOM.Core.Node; I : Unsigned_Long := 0; begin pragma Debug (C, O ("Parse_Record: enter")); Field := First_Child (N); while Field /= null loop pragma Debug (C, O ("Parsing field" & Unsigned_Long'Image (I))); declare Field_TC : constant PolyORB.Any.TypeCode.Local_Ref := Member_Type (Unwound_Expected_Type, I); Field_Value : constant NamedValue := Parse_Param (Field, S, Field_TC); begin Add_Aggregate_Element (Any_Record, Field_Value.Argument); end; I := I + 1; Field := Next_Sibling (Field); end loop; pragma Debug (C, O ("Parse_Record: leaver")); return NamedValue' (Name => Name, Argument => Any_Record, Arg_Modes => ARG_IN); end Parse_Record; ------------------- -- Parse_Wrapper -- ------------------- procedure Parse_Wrapper (N : DOM.Core.Node; S : in out State) is use type SOAP_P.Parameters.List; use PolyORB.Any.NVList.Internals; use PolyORB.Any.NVList.Internals.NV_Lists; NL : constant DOM.Core.Node_List := Child_Nodes (N); Name : constant String := Local_Name (N); It : Iterator; Constructing_Args_List : Boolean; -- True iff the args list is initially empty and we have -- to determine the types of the arguments using only the -- XML attributes in the message. NV : Element_Access; No_TypeCode : PolyORB.Any.TypeCode.Local_Ref; begin S.Wrapper_Name := To_Unbounded_String (Name); Constructing_Args_List := SOAP_P.Parameters.Is_Nil (S.Parameters); if Constructing_Args_List then SOAP_P.Parameters.Create (S.Parameters); end if; It := First (List_Of (PolyORB.Any.NVList.Ref (S.Parameters)).all); for J in 0 .. Length (NL) - 1 loop if not Constructing_Args_List then loop -- Ignore any element in S.Args that is not of the -- proper mode (i.e. OUT elements when parsing a -- request, IN elements when parsing a response; -- INOUT elements are never skipped.) exit when Last (It); NV := Value (It); exit when NV.Arg_Modes = ARG_INOUT or else (S.Kind = Payload xor NV.Arg_Modes = ARG_OUT); Next (It); end loop; exit when Last (It); Move_Any_Value (NV.Argument, Parse_Param (Item (NL, J), S, Get_Type (NV.Argument)).Argument); else SOAP_P.Parameters.Add_Item (S.Parameters, Parse_Param (Item (NL, J), S, No_TypeCode)); end if; end loop; end Parse_Wrapper; ----------- -- Error -- ----------- procedure Error (Node : DOM.Core.Node; Message : String) is Name : constant String := Local_Name (Node); begin Ada.Exceptions.Raise_Exception (SOAP_Error'Identity, Name & " - " & Message); end Error; end PolyORB.SOAP_P.Message.XML; polyorb-2.8~20110207.orig/src/soap/polyorb-binding_data-soap.ads0000644000175000017500000001163611750740340023662 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . B I N D I N G _ D A T A . S O A P -- -- -- -- S p e c -- -- -- -- Copyright (C) 2001-2008, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- Binding data concrete implementation for SOAP over HTTP. with PolyORB.Types; with PolyORB.Utils.Sockets; package PolyORB.Binding_Data.SOAP is pragma Elaborate_Body; type SOAP_Profile_Type is new Profile_Type with private; -- A profile that designates an object accessible through -- SOAP RPC over HTTP. procedure Release (P : in out SOAP_Profile_Type); ---------------------------------------------------- -- Overloaded abstract operations of Profile_Type -- ---------------------------------------------------- procedure Bind_Profile (Profile : access SOAP_Profile_Type; The_ORB : Components.Component_Access; QoS : PolyORB.QoS.QoS_Parameters; BO_Ref : out Smart_Pointers.Ref; Error : out Errors.Error_Container); function Get_Profile_Tag (Profile : SOAP_Profile_Type) return Profile_Tag; pragma Inline (Get_Profile_Tag); function Get_Profile_Preference (Profile : SOAP_Profile_Type) return Profile_Preference; pragma Inline (Get_Profile_Preference); function Is_Colocated (Left : SOAP_Profile_Type; Right : Profile_Type'Class) return Boolean; ----------------------------------------------- -- Supplementary operations of SOAP profiles -- ----------------------------------------------- function Get_URI_Path (Profile : SOAP_Profile_Type) return Types.String; -- Return the 'path' component of the object URI. function To_URI (Prof : SOAP_Profile_Type) return String; -- Convert a SOAP profile to an equivalent URI. function Create_Profile (URI : Types.String) return Profile_Access; -- Create a SOAP RPC/HTTP profile from an absolute URI. function Image (Prof : SOAP_Profile_Type) return String; -- Represent Prof as a string, for debugging purposes. function Get_OA (Profile : SOAP_Profile_Type) return PolyORB.Smart_Pointers.Entity_Ptr; pragma Inline (Get_OA); ---------------------------- -- SOAP profile factories -- ---------------------------- type SOAP_Profile_Factory is new Profile_Factory with private; procedure Create_Factory (PF : out SOAP_Profile_Factory; TAP : Transport.Transport_Access_Point_Access; ORB : Components.Component_Access); function Create_Profile (PF : access SOAP_Profile_Factory; Oid : Objects.Object_Id) return Profile_Access; function Duplicate_Profile (P : SOAP_Profile_Type) return Profile_Access; function Is_Local_Profile (PF : access SOAP_Profile_Factory; P : access Profile_Type'Class) return Boolean; private type SOAP_Profile_Type is new Profile_Type with record Address : Utils.Sockets.Socket_Name_Ptr; URI_Path : Types.String; end record; type SOAP_Profile_Factory is new Profile_Factory with record Address : Utils.Sockets.Socket_Name_Ptr; end record; end PolyORB.Binding_Data.SOAP; polyorb-2.8~20110207.orig/src/soap/polyorb-protocols-soap_pr.adb0000644000175000017500000004340411750740340023761 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . P R O T O C O L S . S O A P _ P R -- -- -- -- B o d y -- -- -- -- Copyright (C) 2001-2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with Ada.Strings.Unbounded; with Ada.Exceptions; with PolyORB.SOAP_P.Response; with PolyORB.SOAP_P.Message; with PolyORB.SOAP_P.Message.XML; with PolyORB.SOAP_P.Message.Response; with PolyORB.SOAP_P.Parameters; with PolyORB.Any; with PolyORB.Any.NVList; with PolyORB.Binding_Data; with PolyORB.Binding_Data.Local; with PolyORB.Binding_Data.SOAP; with PolyORB.Buffer_Sources; with PolyORB.Filters.AWS_Interface; with PolyORB.Filters.Iface; with PolyORB.HTTP_Methods; with PolyORB.Initialization; with PolyORB.Log; with PolyORB.Objects; with PolyORB.ORB.Iface; with PolyORB.Obj_Adapters; with PolyORB.References; with PolyORB.References.Binding; with PolyORB.Servants.Iface; with PolyORB.Smart_Pointers; with PolyORB.Utils.Strings; package body PolyORB.Protocols.SOAP_Pr is use PolyORB.Filters.Iface; use PolyORB.Log; use PolyORB.ORB; package L is new PolyORB.Log.Facility_Log ("polyorb.protocols.soap_pr"); procedure O (Message : String; Level : Log_Level := Debug) renames L.Output; function C (Level : Log_Level := Debug) return Boolean renames L.Enabled; procedure Initialize; procedure Process_Reply (S : access SOAP_Session); -- ??? comment needed ------------------- -- Abort_Request -- ------------------- procedure Abort_Request (S : access SOAP_Session; R : Requests.Request_Access) is begin raise Program_Error; end Abort_Request; ------------ -- Create -- ------------ procedure Create (Proto : access SOAP_Protocol; Session : out Filter_Access) is pragma Warnings (Off); pragma Unreferenced (Proto); pragma Warnings (On); Result : constant Filter_Access := new SOAP_Session; begin SOAP_Session (Result.all).In_Buf := new Buffers.Buffer_Type; Session := Result; end Create; ---------------------------- -- Handle_Data_Indication -- ---------------------------- procedure Handle_Data_Indication (S : access SOAP_Session; Data_Amount : Ada.Streams.Stream_Element_Count; Error : in out Errors.Error_Container) is pragma Unreferenced (Error); begin if S.Role = Server then declare use Ada.Streams; use PolyORB.Binding_Data.Local; use PolyORB.Types; Req : Request_Access; Result : Any.NamedValue; -- Dummy NamedValue for Create_Request; the actual Result -- is set by the called method. The_ORB : constant ORB_Access := ORB_Access (S.Server); Target : References.Ref; Target_Profile : constant Binding_Data.Profile_Access := new Local_Profile_Type; -- Should be free'd when Target is finalized. function Path_To_Oid (Path : Types.String) return Objects.Object_Id_Access; ----------------- -- Path_To_Oid -- ----------------- function Path_To_Oid (Path : Types.String) return Objects.Object_Id_Access is begin pragma Debug (C, O ("Path_To_Oid: " & To_Standard_String (Path))); return PolyORB.Obj_Adapters.Rel_URI_To_Oid (PolyORB.ORB.Object_Adapter (The_ORB), PolyORB.Types.To_Standard_String (Path)); end Path_To_Oid; The_Oid : Objects.Object_Id_Access := Path_To_Oid (S.Target); SOAP_Action_Msg : constant AWS_Interface.AWS_SOAP_Action := AWS_Interface.AWS_SOAP_Action (Components.Emit (Lower (S), AWS_Interface.AWS_Get_SOAP_Action' (null record))); Args : Any.NVList.Ref; -- Nil (not initialised). Unmarshall_Error : PolyORB.Errors.Error_Container; use PolyORB.Errors; begin Create_Local_Profile (The_Oid.all, Local_Profile_Type (Target_Profile.all)); Objects.Free (The_Oid); References.Create_Reference ((1 => Target_Profile), Type_Id => "", R => Target); -- Create a temporary, typeless reference for this object. Result.Name := To_PolyORB_String ("Result"); Handle_Unmarshall_Arguments (S, Args, Unmarshall_Error); -- As SOAP is a self-described protocol, we can set the argument -- list without waiting for the someone to tell us how to do it. -- If an error occurred, we need to note it now. Create_Request (Target => Target, Operation => To_Standard_String (SOAP_Action_Msg.SOAP_Action), Arg_List => Args, Result => Result, Deferred_Arguments_Session => null, Req => Req, Dependent_Binding_Object => Smart_Pointers.Entity_Ptr (S.Dependent_Binding_Object)); if Found (Unmarshall_Error) then System_Exception_Members (Unmarshall_Error.Member.all).Completed := Completed_No; Set_Exception (Req.all, Unmarshall_Error); Req.Completed := True; Catch (Unmarshall_Error); end if; S.Target := Types.To_PolyORB_String (""); S.Entity_Length := Data_Amount; ORB.Queue_Request_To_Handler (The_ORB, ORB.Iface.Queue_Request' (Request => Req, Requestor => Components.Component_Access (S))); end; else Process_Reply (S); end if; end Handle_Data_Indication; ------------------------------- -- Handle_Connect_Indication -- ------------------------------- procedure Handle_Connect_Indication (S : access SOAP_Session) is begin S.Role := Server; Expect_Data (S, S.In_Buf, 0); -- Buffer used to receive request from the client end Handle_Connect_Indication; --------------------------------- -- Handle_Connect_Confirmation -- --------------------------------- procedure Handle_Connect_Confirmation (S : access SOAP_Session) is begin S.Role := Client; Expect_Data (S, S.In_Buf, 0); -- Buffer used to receive reply from the server end Handle_Connect_Confirmation; ----------------------- -- Handle_Disconnect -- ----------------------- procedure Handle_Disconnect (S : access SOAP_Session; Error : Errors.Error_Container) is use type Buffers.Buffer_Access; use SOAP_P.Message.Payload; P : Requests.Request_Access; ORB : constant ORB_Access := ORB_Access (S.Server); begin if S.In_Buf /= null then Buffers.Release (S.In_Buf); end if; if S.Current_SOAP_Req /= null then Free (S.Current_SOAP_Req); end if; if S.Pending_Rq /= null then P := S.Pending_Rq; S.Pending_Rq := null; Set_Exception (P.all, Error); -- After the following call, S may become invalid References.Binding.Unbind (P.Target); -- After the following call, P is destroyed Components.Emit_No_Reply (Components.Component_Access (ORB), Servants.Iface.Executed_Request'(Req => P)); end if; end Handle_Disconnect; ------------------ -- Handle_Flush -- ------------------ procedure Handle_Flush (S : access SOAP_Session) is begin raise Program_Error; end Handle_Flush; -------------------- -- Handle_Message -- -------------------- function Handle_Message (Sess : not null access SOAP_Session; S : Components.Message'Class) return Components.Message'Class is use PolyORB.Protocols; Result : Components.Null_Message; begin if S in Set_Target_Object then Sess.Target := Set_Target_Object (S).Target; return Result; else return PolyORB.Protocols.Handle_Message (Session (Sess.all)'Access, S); -- Call ancestor method. end if; end Handle_Message; --------------------------------- -- Handle_Unmarshall_Arguments -- --------------------------------- procedure Handle_Unmarshall_Arguments (S : access SOAP_Session; Args : in out PolyORB.Any.NVList.Ref; Error : in out PolyORB.Errors.Error_Container) is use PolyORB.Errors; Src : aliased Buffer_Sources.Input_Source; begin Buffer_Sources.Set_Buffer (Src, S.In_Buf); begin PolyORB.SOAP_P.Message.XML.Load_Payload (Src'Access, Args, S.Current_SOAP_Req); exception when others => Throw (Error, Marshal_E, System_Exception_Members' (Minor => 1, Completed => Completed_No)); end; Buffers.Release_Contents (S.In_Buf.all); end Handle_Unmarshall_Arguments; ---------------- -- Initialize -- ---------------- procedure Initialize is begin -- No initialization necessary for this module null; end Initialize; -------------------- -- Invoke_Request -- -------------------- procedure Invoke_Request (S : access SOAP_Session; R : Requests.Request_Access; Pro : access Binding_Data.Profile_Type'Class) is P : PolyORB.SOAP_P.Message.Payload.Object; SPro : Binding_Data.SOAP.SOAP_Profile_Type'Class renames Binding_Data.SOAP.SOAP_Profile_Type'Class (Pro.all); begin pragma Assert (S.Pending_Rq = null); S.Pending_Rq := R; -- Actually should support concurrent calls to invoke_request -- with a mutex on Session.Pending_Request that would be taken -- here in Invoke_Request and released when the answer is -- received. begin P := PolyORB.SOAP_P.Message.Payload.Build (R.Operation.all, PolyORB.SOAP_P.Parameters.List'(R.Args with null record)); exception when E : others => pragma Debug (C, O ("SOAP message: exception in Image:")); pragma Debug (C, O (Ada.Exceptions.Exception_Information (E))); -- Cleanup before propagating exception to caller. S.Pending_Rq := null; raise; end; -- RD := (R_Headers, R_Body => SOAP.Message.XML.Image (P)); Components.Emit_No_Reply (Lower (S), Filters.AWS_Interface.AWS_Request_Out' (Request_Method => HTTP_Methods.POST, Relative_URI => Binding_Data.SOAP.Get_URI_Path (SPro), Data => Types.String (Ada.Strings.Unbounded.Unbounded_String' (PolyORB.SOAP_P.Message.XML.Image (P))), SOAP_Action => Types.To_PolyORB_String (R.Operation.all))); end Invoke_Request; ------------------- -- Process_Reply -- ------------------- procedure Process_Reply (S : access SOAP_Session) is use PolyORB.Any; use PolyORB.Any.NVList; use PolyORB.Any.NVList.Internals; use PolyORB.Any.NVList.Internals.NV_Lists; R : constant Requests.Request_Access := S.Pending_Rq; Return_Args : PolyORB.Any.NVList.Ref; -- This is an empty NVList, since SOAP is a self-described -- protocol. Thus it can fill the returned arguments by itself Src : aliased Buffer_Sources.Input_Source; begin if R = null then raise PolyORB.SOAP_P.SOAP_Error; -- Received a reply with no pending request. end if; R.Result.Arg_Modes := ARG_OUT; -- Ensure proper mode for Result. Buffer_Sources.Set_Buffer (Src, S.In_Buf); PolyORB.SOAP_P.Message.XML.Load_Response (Src'Access, Return_Args); pragma Debug (C, O ("Process_Reply: processed " & PolyORB.Types.Long'Image (PolyORB.Any.NVList.Get_Count (Return_Args)) & " arguments")); -- XXX BAD BAD this subprogram does not take into account -- the case where a FAULT or EXCEPTION has been received -- instead of a normal reply!! declare Res : NamedValue; begin Extract_First (List_Of (Return_Args).all, Res); if TypeCode.Kind (Get_Type (R.Result.Argument)) = Tk_Void then R.Result := (Name => PolyORB.Types.To_PolyORB_String ("result"), Argument => Res.Argument, Arg_Modes => ARG_OUT); else Move_Any_Value (R.Result.Argument, Res.Argument); end if; end; -- Some applicative personnalities, like AWS, do not specify -- the type of the result they are expecting; other do, like -- CORBA. So we either copy the any data if the type of the -- namedvalue is specified, or simply set the namedvalue if its -- type is not specified. -- XXX We should consider changing this, by moving this kind of -- mechanism into the neutral layer. Thus, protocol -- personalities would send data to the neutral layer, like -- applicative personalities do for incoming arguments. S.Pending_Rq := null; Buffers.Release_Contents (S.In_Buf.all); Components.Emit_No_Reply (R.Requesting_Component, Servants.Iface.Executed_Request'(Req => R)); end Process_Reply; ---------------- -- Send_Reply -- ---------------- procedure Send_Reply (S : access SOAP_Session; R : Requests.Request_Access) is use PolyORB.Components; use type PolyORB.SOAP_P.Message.Payload.Object_Access; begin if S.Current_SOAP_Req = null then -- Fatal error, no known current request -- ??? we should send some feedback to the client. For now we just -- give up and close the connection. Emit_No_Reply (Component_Access (S), Disconnect_Request'(null record)); return; end if; declare use PolyORB.Any; use PolyORB.Any.NVList; use PolyORB.Any.NVList.Internals; use PolyORB.Any.NVList.Internals.NV_Lists; use PolyORB.SOAP_P.Parameters; RO : PolyORB.SOAP_P.Message.Response.Object := PolyORB.SOAP_P.Message.Response.From (PolyORB.SOAP_P.Message.Payload.Object (S.Current_SOAP_Req.all)); RP : PolyORB.SOAP_P.Parameters.List; It : Iterator := First (List_Of (R.Args).all); Arg : Element_Access; begin PolyORB.SOAP_P.Message.Payload.Free (S.Current_SOAP_Req); RP := +R.Result; while not Last (It) loop Arg := Value (It); if False or else Arg.Arg_Modes = ARG_INOUT or else Arg.Arg_Modes = ARG_OUT then RP := RP & Arg.all; end if; Next (It); end loop; PolyORB.SOAP_P.Message.Set_Parameters (RO, RP); declare RD : constant PolyORB.SOAP_P.Response.Data := PolyORB.SOAP_P.Message.Response.Build (RO); -- Here we depend on a violation of abstraction: we construct an -- AWS response object, and AWS is HTTP-specific. This is a -- shortcoming of the AWS SOAP engine. It is unknown yet whether -- this violation can be easily removed. begin Components.Emit_No_Reply (Lower (S), Filters.AWS_Interface.AWS_Response_Out' (Data => RD)); end; end; end Send_Reply; use PolyORB.Initialization; use PolyORB.Initialization.String_Lists; use PolyORB.Utils.Strings; begin Register_Module (Module_Info' (Name => +"protocols.soap", Conflicts => Empty, Depends => +"http_methods" & "http_headers", Provides => Empty, Implicit => False, Init => Initialize'Access, Shutdown => null)); end PolyORB.Protocols.SOAP_Pr; polyorb-2.8~20110207.orig/src/soap/polyorb-http_headers.ads0000644000175000017500000001177311750740340022773 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . H T T P _ H E A D E R S -- -- -- -- S p e c -- -- -- -- Copyright (C) 2001-2002 Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by ACT Europe. -- -- (email: sales@act-europe.fr) -- -- -- ------------------------------------------------------------------------------ package PolyORB.HTTP_Headers is pragma Elaborate_Body; type Header is ( -- -- general-header H_Cache_Control, -- >> "Cache-Control" H_Connection, -- >> "Connection" H_Date, -- >> "Date" H_Pragma, -- >> "Pragma" H_Trailer, -- >> "Trailer" H_Transfer_Encoding, -- >> "Transfer-Encoding" H_Upgrade, -- >> "Upgrade" H_Via, -- >> "Via" H_Warning, -- >> "Warning" -- request-header H_Accept, -- >> "Accept" H_Accept_Charset, -- >> "Accept-Charset" H_Accept_Language, -- >> "Accept-Language" H_Authorization, -- >> "Authorization" H_Expect, -- >> "Expect" H_From, -- >> "From" H_Host, -- >> "Host" H_If_Match, -- >> "If-Match" H_If_Modified_Since, -- >> "If-Modified-Since" H_If_None_Match, -- >> "If-None-Match" H_If_Range, -- >> "If-Range" H_If_Unmodified_Since, -- >> "If-Unmodified-Since" H_Max_Forwards, -- >> "Max-Forwards" H_Proxy_Authorization, -- >> "Proxy-Authorization" H_Range, -- >> "Range" H_Referer, -- >> "Referer" H_TE, -- >> "TE" H_User_Agent, -- >> "User-Agent" -- response-header H_Accept_Ranges, -- >> "Accept-Ranges" H_Age, -- >> "Age" H_ETag, -- >> "ETag" H_Location, -- >> "Location" H_Proxy_Authenticate, -- >> "Proxy-Authenticate" H_Retry_After, -- >> "Retry-After" H_Server, -- >> "Server" H_Vary, -- >> "Vary" H_WWW_Authenticate, -- >> "WWW-Authenticate" -- entity-header H_Allow, -- >> "Allow" H_Content_Encoding, -- >> "Content-Encoding" H_Content_Language, -- >> "Content-Language" H_Content_Length, -- >> "Content-Length" H_Content_Location, -- >> "Content-Location" H_Content_MD5, -- >> "Content-MD5" H_Content_Range, -- >> "Content-Range" H_Content_Type, -- >> "Content-Type" H_Expires, -- >> "Expires" H_Last_Modified, -- >> "Last-Modified" H_SOAPAction, -- >> "SOAPAction" Extension_Header -- ); subtype General_Header is Header range H_Cache_Control .. H_Warning; subtype Request_Header is Header range H_Accept .. H_User_Agent; subtype Response_Header is Header range H_Accept_Ranges .. H_WWW_Authenticate; subtype Entity_Header is Header range H_Allow .. Extension_Header; function To_String (Id : Header) return String; function In_Word_Set (S : String) return Header; end PolyORB.HTTP_Headers; polyorb-2.8~20110207.orig/src/soap/polyorb-soap_p-message-reader.adb0000644000175000017500000001305311750740340024434 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . S O A P _ P . M E S S A G E . R E A D E R -- -- -- -- B o d y -- -- -- -- Copyright (C) 2000-2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- This package is based on Tree_Reader from the XMLada package. with Sax.Attributes; use Sax.Attributes; with Unicode; use Unicode; with Unicode.CES; use Unicode.CES; with DOM.Core.Nodes; use DOM.Core.Nodes; with DOM.Core.Documents; use DOM.Core.Documents; with DOM.Core.Elements; use DOM.Core.Elements; package body PolyORB.SOAP_P.Message.Reader is ---------------- -- Characters -- ---------------- procedure Characters (Handler : in out Tree_Reader; Ch : Unicode.CES.Byte_Sequence) is pragma Warnings (Off); Tmp : constant Node := Append_Child (Handler.Current_Node, Create_Text_Node (Handler.Tree, Ch)); pragma Unreferenced (Tmp); pragma Warnings (On); begin null; end Characters; ----------------- -- End_Element -- ----------------- procedure End_Element (Handler : in out Tree_Reader; Namespace_URI : Unicode.CES.Byte_Sequence := ""; Local_Name : Unicode.CES.Byte_Sequence := ""; Qname : Unicode.CES.Byte_Sequence := "") is pragma Warnings (Off); pragma Unreferenced (Namespace_URI, Local_Name, Qname); pragma Warnings (On); begin Handler.Current_Node := Parent_Node (Handler.Current_Node); end End_Element; -------------- -- Get_Tree -- -------------- function Get_Tree (Read : Tree_Reader) return Document is begin return Read.Tree; end Get_Tree; -------------------------- -- Ignorable_Whitespace -- -------------------------- procedure Ignorable_Whitespace (Handler : in out Tree_Reader; Ch : Unicode.CES.Byte_Sequence) is begin -- Ignore these white spaces at the toplevel if Ch'Length = 1 and then Ch (Ch'First) /= ASCII.LF and then Handler.Current_Node /= Handler.Tree then declare pragma Warnings (Off); Tmp : constant Node := Append_Child (Handler.Current_Node, Create_Text_Node (Handler.Tree, Ch)); pragma Unreferenced (Tmp); pragma Warnings (On); begin null; end; end if; end Ignorable_Whitespace; -------------------- -- Start_Document -- -------------------- procedure Start_Document (Handler : in out Tree_Reader) is Implementation : DOM_Implementation; begin Handler.Tree := Create_Document (Implementation); Handler.Current_Node := Handler.Tree; end Start_Document; ------------------- -- Start_Element -- ------------------- procedure Start_Element (Handler : in out Tree_Reader; Namespace_URI : Unicode.CES.Byte_Sequence := ""; Local_Name : Unicode.CES.Byte_Sequence := ""; Qname : Unicode.CES.Byte_Sequence := ""; Atts : Sax.Attributes.Attributes'Class) is pragma Warnings (Off); pragma Unreferenced (Local_Name); pragma Warnings (On); begin Handler.Current_Node := Append_Child (Handler.Current_Node, Create_Element_NS (Handler.Tree, Namespace_URI => Namespace_URI, Qualified_Name => Qname)); -- Insert the attributes in the right order. for J in 0 .. Get_Length (Atts) - 1 loop Set_Attribute_NS (Handler.Current_Node, Get_URI (Atts, J), Get_Qname (Atts, J), Get_Value (Atts, J)); end loop; end Start_Element; end PolyORB.SOAP_P.Message.Reader; polyorb-2.8~20110207.orig/src/soap/polyorb-soap_p-response.adb0000644000175000017500000002361211750740340023410 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . S O A P _ P . R E S P O N S E -- -- -- -- B o d y -- -- -- -- Copyright (C) 2000-2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- taken from aws.response with Ada.Strings.Fixed; -- with AWS.OS_Lib; package body PolyORB.SOAP_P.Response is ----------------- -- Acknowledge -- ----------------- function Acknowledge (Status_Code : HTTP_Status_Code; Message_Body : String := ""; Content_Type : String := PolyORB.Web.MIME.Text_HTML) return Data is begin if Message_Body = "" then return Data'(Header, Status_Code, 0, Null_Unbounded_String, Null_Unbounded_String, Null_Unbounded_String, Null_Unbounded_String, null); else return Data'(Message, Status_Code, Message_Body'Length, To_Unbounded_String (Content_Type), To_Unbounded_String (Message_Body), Null_Unbounded_String, Null_Unbounded_String, null); end if; end Acknowledge; ------------------ -- Authenticate -- ------------------ function Authenticate (Realm : String) return Data is CRLF : constant String := ASCII.CR & ASCII.LF; Auth_Mess : constant String := "" & CRLF & "401 Authorization Required" & CRLF & "" & CRLF & "

Authorization Required

" & CRLF & "This server could not verify that you" & CRLF & "are authorized to access the document you" & CRLF & "requested. Either you supplied the wrong" & CRLF & "credentials (e.g., bad password), or your" & CRLF & "browser doesn't understand how to supply" & CRLF & "the credentials required.

" & CRLF & "" & CRLF; begin return Data'(Message, S_401_Unauthorized, Auth_Mess'Length, To_Unbounded_String (PolyORB.Web.MIME.Text_HTML), To_Unbounded_String (Auth_Mess), Null_Unbounded_String, To_Unbounded_String (Realm), null); end Authenticate; ------------ -- Binary -- ------------ function Binary (D : Data) return Streams.Stream_Element_Array is No_Data : constant Streams.Stream_Element_Array := (1 .. 0 => 0); begin if D.Elements = null then return No_Data; else return D.Elements.all; end if; end Binary; ----------- -- Build -- ----------- function Build (Content_Type : String; Message_Body : String; Status_Code : HTTP_Status_Code := S_200_OK) return Data is begin return Data'(Message, Status_Code, Message_Body'Length, To_Unbounded_String (Content_Type), To_Unbounded_String (Message_Body), Null_Unbounded_String, Null_Unbounded_String, null); end Build; function Build (Content_Type : String; UString_Message : Strings.Unbounded.Unbounded_String; Status_Code : HTTP_Status_Code := S_200_OK) return Data is begin return Data'(Message, Status_Code, Length (UString_Message), To_Unbounded_String (Content_Type), UString_Message, Null_Unbounded_String, Null_Unbounded_String, null); end Build; function Build (Content_Type : String; Message_Body : Streams.Stream_Element_Array; Status_Code : HTTP_Status_Code := S_200_OK) return Data is begin return Data'(Message, Status_Code, Message_Body'Length, To_Unbounded_String (Content_Type), Null_Unbounded_String, Null_Unbounded_String, Null_Unbounded_String, new Streams.Stream_Element_Array'(Message_Body)); end Build; -------------------- -- Content_Length -- -------------------- function Content_Length (D : Data) return Natural is begin return D.Content_Length; end Content_Length; ------------------ -- Content_Type -- ------------------ function Content_Type (D : Data) return String is begin return To_String (D.Content_Type); end Content_Type; ---------- -- File -- ---------- -- function File -- (Content_Type : String; -- Filename : String) return Data is -- begin -- return Data'(File, -- Messages.S200, -- Integer (OS_Lib.File_Size (Filename)), -- To_Unbounded_String (Content_Type), -- To_Unbounded_String (Filename), -- Null_Unbounded_String, -- Null_Unbounded_String, -- null); -- end File; -------------- -- Location -- -------------- function Location (D : Data) return String is begin return To_String (D.Location); end Location; ------------------ -- Message_Body -- ------------------ function Message_Body (D : Data) return String is begin return To_String (D.Message_Body); end Message_Body; function Message_Body (D : Data) return Unbounded_String is begin return D.Message_Body; end Message_Body; ---------- -- Mode -- ---------- function Mode (D : Data) return Data_Mode is begin return D.Mode; end Mode; ----------- -- Moved -- ----------- function Moved (Location : String; Message : String := Default_Moved_Message) return Data is use Ada.Strings; function Build_Message_Body return String; -- Return proper message body using Message template. It replaces _@_ -- in Message by Location. function Build_Message_Body return String is Start : constant Natural := Fixed.Index (Message, "_@_"); begin if Start = 0 then return Message; else return Fixed.Replace_Slice (Message, Start, Start + 2, Location); end if; end Build_Message_Body; Message_Body : constant String := Build_Message_Body; begin return Data'(Response.Message, S_301_Moved_Permanently, Message_Body'Length, To_Unbounded_String (PolyORB.Web.MIME.Text_HTML), To_Unbounded_String (Message_Body), To_Unbounded_String (Location), Null_Unbounded_String, null); end Moved; ----------- -- Realm -- ----------- function Realm (D : Data) return String is begin return To_String (D.Realm); end Realm; ------------------ -- Socket_Taken -- ------------------ -- function Socket_Taken return Data is -- begin -- return Data'(Response.Socket_Taken, -- Messages.S200, -- 0, -- Null_Unbounded_String, -- Null_Unbounded_String, -- Null_Unbounded_String, -- Null_Unbounded_String, -- null); -- end Socket_Taken; ----------------- -- Status_Code -- ----------------- function Status_Code (D : Data) return HTTP_Status_Code is begin return D.Status_Code; end Status_Code; --------- -- URL -- --------- function URL (Location : String) return Data is begin return Data'(Response.Message, S_301_Moved_Permanently, 0, Null_Unbounded_String, Null_Unbounded_String, To_Unbounded_String (Location), Null_Unbounded_String, null); end URL; end PolyORB.SOAP_P.Response; polyorb-2.8~20110207.orig/src/polyorb-parameters.ads0000644000175000017500000001350511750740340021515 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . P A R A M E T E R S -- -- -- -- S p e c -- -- -- -- Copyright (C) 2002-2009, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- PolyORB runtime configuration facility. pragma Ada_2005; package PolyORB.Parameters is pragma Preelaborate; ------------------ -- Consumer API -- ------------------ -- Used by modules that retrieve configuration information function Get_Conf (Section, Key : String; Default : String := "") return String; -- Return the value of the global variable Key or Default if this -- variable is not defined. function Get_Conf (Section, Key : String; Default : Boolean := False) return Boolean; -- Return the value of the global variable Key or Default if this -- variable is not defined, interpreting the value as a Boolean: -- * True if the value starts with '1' or 'Y' or 'y', -- or is "on" or "enable" or "true" -- * False if the value starts with '0' or 'n' or 'N', -- or is "off" or "disable" or "false" or empty. -- Constraint_Error is raised if the value is set to anything else. -- (see also PolyORB.Utils.Strings.To_Boolean). function Get_Conf (Section, Key : String; Default : Duration := 0.0) return Duration; -- Return the value of the global variable Key or Default if this -- variable is not defined, interpreting the value as an integer -- milliseconds duration. -- Constraint_Error is raised if the value is set to anything else. function Get_Conf (Section, Key : String; Default : Integer := 0) return Integer; -- Return the value of the global variable Key or Default if this -- variable is not defined, interpreting the value as the decimal -- representation of an integer number. -- Constraint_Error is raised if the value is set to anything else. type Interval is record Lo, Hi : Integer; end record; function Get_Conf (Section, Key : String; Default : Interval := (0, 0)) return Interval; -- Return the value of the global variable Key or Default if this -- variable is not defined, interpreting the value as an integer interval -- defined by its bounds in decimal representation, separated by an hyphen. -- If a single integer is given, it is used as both the low and high -- bounds. -- Constraint_Error is raised if the value is set to anything else. function Make_Global_Key (Section, Key : String) return String; -- Build dynamic key from (Section, Key) tuple ------------------ -- Provider API -- ------------------ -- Used by modules that provide configuration information type Parameters_Source is abstract tagged limited private; type Parameters_Source_Access is access all Parameters_Source'Class; function Get_Conf (Source : access Parameters_Source; Section, Key : String) return String is abstract; -- Return the value of the global variable Key in the specified Section. -- For unknown (Section, Key) couples, an empty string shall be returned. procedure Register_Source (Source : Parameters_Source_Access); -- Register one source of configuration parameters. Sources are queried -- at run time in the order they were registered. private type Parameters_Source is abstract tagged limited null record; type Fetch_From_File_T is access function (Key : String) return String; Fetch_From_File_Hook : Fetch_From_File_T := null; -- The fetch-from-file hook allows the value of a configuration parameter -- to be loaded indirectly from a file; this is independent of the use of a -- PolyORB configuration file as a source of configuration parameters (but -- both facilities are provided by the PolyORB.Parameters.File package). procedure Initialize; -- Complete the initialization of the configuration parameters framework, -- after all sources have been initialized. -- See PolyORB.Parameters.Initialization. end PolyORB.Parameters; polyorb-2.8~20110207.orig/src/polyorb-qos-priority.adb0000644000175000017500000001265711750740340022021 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . Q O S . P R I O R I T Y -- -- -- -- B o d y -- -- -- -- Copyright (C) 2004-2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with PolyORB.Buffers; with PolyORB.Initialization; with PolyORB.References; with PolyORB.Representations.CDR.Common; with PolyORB.Request_QoS; with PolyORB.QoS.Service_Contexts; with PolyORB.Tasking.Threads.Annotations; with PolyORB.Utils.Strings.Lists; with PolyORB.Types; package body PolyORB.QoS.Priority is use PolyORB.Buffers; use PolyORB.Representations.CDR.Common; use PolyORB.QoS.Service_Contexts; function To_RTCorbaPriority_Service_Context (QoS : QoS_Parameter_Access) return Service_Context; function To_QoS_Static_Priority_Parameter (SC : Service_Context) return QoS_Parameter_Access; -------------------- -- Fetch_Priority -- -------------------- function Fetch_Priority (Ref : PolyORB.References.Ref) return QoS_Parameter_Access; function Fetch_Priority (Ref : PolyORB.References.Ref) return QoS_Parameter_Access is use PolyORB.Tasking.Threads; use PolyORB.Tasking.Threads.Annotations; pragma Unreferenced (Ref); Note : Thread_Priority_Note; begin Get_Note (Get_Current_Thread_Notepad.all, Note, Default_Note); if Note /= Default_Note then return new QoS_Static_Priority'(Kind => Static_Priority, EP => Note.Priority); else return null; end if; end Fetch_Priority; -------------------------------------- -- To_QoS_Static_Priority_Parameter -- -------------------------------------- function To_QoS_Static_Priority_Parameter (SC : Service_Context) return QoS_Parameter_Access is Buffer : aliased Buffer_Type; EP : PolyORB.Types.Short; begin Decapsulate (SC.Context_Data, Buffer'Access); EP := Unmarshall (Buffer'Access); return new QoS_Static_Priority' (Kind => Static_Priority, EP => PolyORB.Tasking.Priorities.External_Priority (EP)); end To_QoS_Static_Priority_Parameter; ---------------------------------------- -- To_RTCorbaPriority_Service_Context -- ---------------------------------------- function To_RTCorbaPriority_Service_Context (QoS : QoS_Parameter_Access) return Service_Context is Buffer : Buffer_Access; Result : Service_Context := (RTCorbaPriority, null); begin if QoS = null then return Result; end if; Buffer := new Buffer_Type; Start_Encapsulation (Buffer); Marshall (Buffer, PolyORB.Types.Short (QoS_Static_Priority (QoS.all).EP)); Result.Context_Data := new Encapsulation'(Encapsulate (Buffer)); Release (Buffer); return Result; end To_RTCorbaPriority_Service_Context; ---------------- -- Initialize -- ---------------- procedure Initialize; procedure Initialize is begin PolyORB.Request_QoS.Register (Static_Priority, Fetch_Priority'Access); Register (Static_Priority, To_RTCorbaPriority_Service_Context'Access); Register (RTCorbaPriority, To_QoS_Static_Priority_Parameter'Access); end Initialize; use PolyORB.Initialization; use PolyORB.Utils.Strings; use PolyORB.Utils.Strings.Lists; begin Register_Module (Module_Info' (Name => +"request_qos.priority", Conflicts => Empty, Depends => +"tasking.annotations", Provides => Empty, Implicit => False, Init => Initialize'Access, Shutdown => null)); end PolyORB.QoS.Priority; polyorb-2.8~20110207.orig/src/polyorb-smart_pointers.ads0000644000175000017500000002034311750740340022421 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . S M A R T _ P O I N T E R S -- -- -- -- S p e c -- -- -- -- Copyright (C) 2001-2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with Ada.Finalization; with Interfaces; package PolyORB.Smart_Pointers is pragma Preelaborate; ------------------------ -- Task-unsafe entity -- ------------------------ type Unsafe_Entity is abstract tagged limited private; function Is_Controlled (X : Unsafe_Entity) return Boolean; -- False expect for derived type from Smart_Pointers.Controlled_Entities procedure Finalize (X : in out Unsafe_Entity); -- Unsafe_Entity is the base type of all objects that can be referenced. -- It contains a Counter, which is the number of references to this -- object, and is automatically destroyed when the counter reaches 0. -- Before the entity is destroyed, the Finalize operation is called. -- NOTE however that Unsafe_Entity is *not* a controlled type: Finalize -- is *only* called when an Entity is destroyed as a result of its -- reference counter dropping to 0. type Entity_Ptr is access all Unsafe_Entity'Class; procedure Disable_Reference_Counting (Obj : in out Unsafe_Entity'Class); -- Disable reference counting on Obj. No attempt will then be made to keep -- track of references, and no automatic deallocation will occur after the -- last reference is used. This is intended primarily for library-level -- entities. ---------------------- -- Task-safe entity -- ---------------------- type Non_Controlled_Entity is abstract new Unsafe_Entity with private; -- Same as Unsafe_Entity --------- -- Ref -- --------- type Ref is new Ada.Finalization.Controlled with private; pragma Preelaborable_Initialization (Ref); -- The base type of all references. This type is often derived but never -- extended. It contains one field, which designates the referenced object. procedure Adjust (The_Ref : in out Ref); procedure Finalize (The_Ref : in out Ref); procedure Set (The_Ref : in out Ref; The_Entity : Entity_Ptr); -- Make The_Ref designate The_Entity, and increment The_Entity's usage -- counter. The_Entity's reference counter is allowed to be 0 only when -- creating the first reference to it. procedure Reuse_Entity (The_Ref : in out Ref; The_Entity : Entity_Ptr); -- Equivalent to Set (The_Ref, The_Entity) if The_Entity's usage counter -- is strictly greater than 0. Otherwise, The_Ref is left unchanged. -- It is the caller's responsibility to ensure that The_Entity points -- to a valid Entity object (even in the latter case). This allows a -- reference to be reconstructed from a saved Entity_Ptr value, ensuring -- that the designated entity is not being finalized. -- The_Ref is expected to be nil before the call. procedure Use_Entity (The_Ref : in out Ref; The_Entity : Entity_Ptr); -- Equivalent to Set (The_Ref, The_Entity), but requires The_Entity's usage -- counter to be zero, and The_Ref to be a null reference. Does not require -- the ORB to have been initialized. The caller is responsible to ensure -- task safety (this subprogram is expected to be used only to associate -- a reference to a newly allocated object). procedure Unref (The_Ref : in out Ref) renames Finalize; procedure Release (The_Ref : in out Ref) renames Finalize; function Is_Nil (The_Ref : Ref) return Boolean; -- True iff The_Ref is a nil reference function Is_Null (The_Ref : Ref) return Boolean renames Is_Nil; function Entity_Of (The_Ref : Ref) return Entity_Ptr; -- Return the entity designated by The_Ref function Same_Entity (Left, Right : Ref) return Boolean; -- True if Left and Right designate the same entity -- The following two low-level functions are exposed for cases where -- controlled types cannot be directly used in a personality. Great care -- must be taken when using them outside of this unit! procedure Inc_Usage (Obj : Entity_Ptr); -- Increment Obj's reference counter procedure Dec_Usage (Obj : in out Entity_Ptr); -- Decremement Obj's reference counter; if it drops to zero, deallocate -- the designated object, and reset Obj to null. private type Unsafe_Entity is abstract tagged limited record Counter : aliased Interfaces.Integer_32 := 0; -- Reference counter. -- If set to -1, no reference counting is performed for this entity: -- Inc_Usage and Dec_Usage are both no-ops in that case. end record; type Non_Controlled_Entity is abstract new Unsafe_Entity with null record; type Ref is new Ada.Finalization.Controlled with record A_Ref : Entity_Ptr := null; -- The entity designated by this reference end record; --------------------- -- Debugging hooks -- --------------------- -- For debugging purposes, the body of this unit needs to call -- Ada.Tags.External_Tag for entities and references. However, we do not -- want any dependence on Ada.Tags, because that would prevent this unit -- from being preelaborable. So, we call External_Tag indirectly through -- a hook that is set during PolyORB initialization. -- -- Note: Ada.Tags is preelaborable in Ada 2005, we need to review this -- dependency. type Entity_External_Tag_Hook is access function (X : Unsafe_Entity'Class) return String; -- A function returning External_Tag (X'Tag) type Ref_External_Tag_Hook is access function (X : Ref'Class) return String; -- A function returning External_Tag (Entity_Of (X)'Tag) procedure Initialize (The_Entity_External_Tag : Entity_External_Tag_Hook; The_Ref_External_Tag : Ref_External_Tag_Hook; The_Default_Trace : Boolean); -- Initialize internal structures and set debugging hooks (to be called by -- child elaboration package) -- Determination of whether to trace smart pointers event for a specific -- entity type: in [smart_pointers] section, whether type T is traced -- is determined by parameter T.trace, or if not set, by default.trace. -- By default event is traced. Trace_Section : constant String := "smart_pointers"; Trace_Suffix : constant String := ".trace"; function Get_Trace (Entity_Type : String) return Boolean; -- Return indication of whether to trace events for the given entity type end PolyORB.Smart_Pointers; polyorb-2.8~20110207.orig/src/polyorb-utils-socket_access_points.adb0000644000175000017500000000462311750740340024675 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . U T I L S . S O C K E T _ A C C E S S _ P O I N T S -- -- -- -- B o d y -- -- -- -- Copyright (C) 2007-2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- Common definitions for all socket-based access points package body PolyORB.Utils.Socket_Access_Points is ---------------------- -- To_Port_Interval -- ---------------------- function To_Port_Interval (I : Interval) return Port_Interval is begin return (Lo => Port_Type (I.Lo), Hi => Port_Type (I.Hi)); end To_Port_Interval; end PolyORB.Utils.Socket_Access_Points; polyorb-2.8~20110207.orig/src/polyorb-tasking-profiles-full_tasking_atc-abortables.ads0000644000175000017500000000466111750740340030261 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- POLYORB.TASKING.PROFILES.FULL_TASKING_ATC.ABORTABLES -- -- -- -- S p e c -- -- -- -- Copyright (C) 2002-2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- Abortable object using ATC pragma Ada_2005; package PolyORB.Tasking.Profiles.Full_Tasking_ATC.Abortables is pragma Elaborate_Body; -- The elaboration of this unit registers a new Abortable_Tag so that -- PolyORB.Tasking.Abortables.Make_Abortable returns an abortable object -- that uses asynchronous transfer of control to implement Abort_Run. end PolyORB.Tasking.Profiles.Full_Tasking_ATC.Abortables; polyorb-2.8~20110207.orig/src/polyorb-poa_policies.ads0000644000175000017500000000610611750740340022017 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . P O A _ P O L I C I E S -- -- -- -- S p e c -- -- -- -- Copyright (C) 2001-2008, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- Base types for the various configuration axes (policies) -- of the PolyORB Portable Object Adapter (liberally inspired from -- the POA specification in CORBA). with PolyORB.Errors; with PolyORB.Utils.Chained_Lists; package PolyORB.POA_Policies is -- No proper body: no elaboration control. type Policy is abstract tagged limited private; type Policy_Access is access all Policy'Class; package Policy_Lists is new PolyORB.Utils.Chained_Lists (Policy_Access); subtype PolicyList is Policy_Lists.List; type AllPolicies is array (1 .. 7) of Policy_Access; function Policy_Id (Self : Policy) return String is abstract; -- Return Policy name. procedure Check_Compatibility (Self : Policy; Other_Policies : AllPolicies; Error : in out PolyORB.Errors.Error_Container) is abstract; -- Check the compatibility of the current policy with the -- other policies of the object adapter. private type Policy is abstract tagged limited null record; end PolyORB.POA_Policies; polyorb-2.8~20110207.orig/src/polyorb-task_info.adb0000644000175000017500000003015711750740340021310 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . T A S K _ I N F O -- -- -- -- B o d y -- -- -- -- Copyright (C) 2001-2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ package body PolyORB.Task_Info is procedure Increment (C : in out Natural); procedure Decrement (C : in out Natural); -- Increment / decrement C procedure Task_State_Change (Summary : in out Task_Summary; TI : in out Task_Info; New_State : Task_State); -- Set TI's state to New_State and record transition in Summary --------------- -- Decrement -- --------------- procedure Decrement (C : in out Natural) is begin C := C - 1; end Decrement; --------------- -- Increment -- --------------- procedure Increment (C : in out Natural) is begin C := C + 1; end Increment; --------------- -- Get_Count -- --------------- function Get_Count (Summary : Task_Summary; Kind : Any_Task_Kind := Any; State : Any_Task_State := Any) return Natural is begin return Summary.Counters (Kind, State); end Get_Count; ----------- -- Image -- ----------- function Image (TI : Task_Info) return String is begin return Tasking.Threads.Image (TI.Id); end Image; ---------------- -- Kind_Match -- ---------------- function Kind_Match (TI : Task_Info; Kind : Any_Task_Kind) return Boolean is begin return Kind = Any or else Kind = TI.Kind; end Kind_Match; ----------------- -- List_Attach -- ----------------- procedure List_Attach (TI : access Task_Info; List : in out Task_List) is pragma Assert (not TI.On_List); begin Prepend (List, TI); TI.On_List := True; end List_Attach; ----------------- -- List_Detach -- ----------------- procedure List_Detach (TI : access Task_Info; List : in out Task_List) is begin if TI.On_List then Remove_Element (List, TI); TI.On_List := False; end if; end List_Detach; ---------------- -- List_First -- ---------------- function List_First (List : Task_List) return access Task_Info is begin return Task_Lists.Value (First (List)); end List_First; -------------- -- May_Exit -- -------------- function May_Exit (TI : Task_Info) return Boolean is begin return TI.May_Exit; end May_Exit; ------------- -- On_List -- ------------- function On_List (TI : Task_Info) return Boolean is begin return TI.On_List; end On_List; -------------- -- Selector -- -------------- function Selector (TI : Task_Info) return Asynch_Ev.Asynch_Ev_Monitor_Access is begin pragma Assert (TI.State = Blocked); return TI.Selector; end Selector; ------------- -- Timeout -- ------------- function Timeout (TI : Task_Info) return Duration is begin pragma Assert (TI.State = Blocked); return TI.Timeout; end Timeout; ----------------------- -- Set_State_Blocked -- ----------------------- procedure Set_State_Blocked (Summary : in out Task_Summary; TI : in out Task_Info; Selector : Asynch_Ev.Asynch_Ev_Monitor_Access; Timeout : Duration) is begin Task_State_Change (Summary, TI, New_State => Blocked); TI.Selector := Selector; TI.Timeout := Timeout; end Set_State_Blocked; -------------------- -- Set_State_Idle -- -------------------- procedure Set_State_Idle (Summary : in out Task_Summary; TI : in out Task_Info; Condition : PTCV.Condition_Access; Mutex : PTM.Mutex_Access) is begin Task_State_Change (Summary, TI, New_State => Idle); TI.Condition := Condition; TI.Mutex := Mutex; end Set_State_Idle; ----------------------- -- Set_State_Running -- ----------------------- procedure Set_State_Running (Summary : in out Task_Summary; TI : in out Task_Info; Job : Jobs.Job_Access) is begin Task_State_Change (Summary, TI, New_State => Running); TI.Job := Job; TI.Selector := null; TI.Condition := null; TI.Mutex := null; end Set_State_Running; ----------- -- State -- ----------- function State (TI : Task_Info) return Task_State is begin return TI.State; end State; --------------- -- Condition -- --------------- function Condition (TI : Task_Info) return PTCV.Condition_Access is begin return TI.Condition; end Condition; -------------------- -- Exit_Condition -- -------------------- function Exit_Condition (TI : Task_Info) return Boolean is use type PolyORB.Types.Boolean_Ptr; begin return TI.Exit_Condition /= null and then TI.Exit_Condition.all; end Exit_Condition; ---------- -- Link -- ---------- function Link (S : access Task_Info; Which : Utils.Ilists.Link_Type) return access Task_Info_Access is begin return S.Links (Which)'Unchecked_Access; end Link; ----------- -- Mutex -- ----------- function Mutex (TI : Task_Info) return PTM.Mutex_Access is begin return TI.Mutex; end Mutex; ------------------------ -- Set_Exit_Condition -- ------------------------ procedure Set_Exit_Condition (TI : in out Task_Info; Exit_Condition : Types.Boolean_Ptr) is use type Types.Boolean_Ptr; begin pragma Assert ((TI.Kind = Permanent) = (Exit_Condition = null)); TI.Exit_Condition := Exit_Condition; end Set_Exit_Condition; ------------ -- Set_Id -- ------------ procedure Set_Id (TI : in out Task_Info) is begin TI.Id := Tasking.Threads.Current_Task; end Set_Id; ------------------ -- Set_May_Exit -- ------------------ procedure Set_May_Exit (TI : in out Task_Info; May_Exit : Boolean) is begin TI.May_Exit := May_Exit; end Set_May_Exit; --------------------------- -- Set_State_Unscheduled -- --------------------------- procedure Set_State_Unscheduled (Summary : in out Task_Summary; TI : in out Task_Info) is begin -- Note: TI may already be in Unscheduled state, because this is the -- initial state of a newly-created task. Task_State_Change (Summary, TI, New_State => Unscheduled); TI.Job := null; TI.Selector := null; TI.Condition := null; TI.Mutex := null; end Set_State_Unscheduled; -------------------------- -- Set_State_Terminated -- -------------------------- procedure Set_State_Terminated (Summary : in out Task_Summary; TI : in out Task_Info) is begin Task_State_Change (Summary, TI, Terminated); end Set_State_Terminated; --------------------------- -- Request_Abort_Polling -- --------------------------- procedure Request_Abort_Polling (TI : in out Task_Info) is begin pragma Assert (TI.State = Blocked); TI.Abort_Polling := True; end Request_Abort_Polling; ------------------- -- Abort_Polling -- ------------------- function Abort_Polling (TI : Task_Info) return Boolean is begin pragma Assert (TI.State = Blocked); return TI.Abort_Polling; end Abort_Polling; -------- -- Id -- -------- function Id (TI : Task_Info) return PolyORB.Tasking.Threads.Thread_Id is begin return TI.Id; end Id; -------------- -- Is_Empty -- -------------- function Is_Empty (List : Task_List) return Boolean is begin return Task_Lists.Is_Empty (Task_Lists.List (List)); end Is_Empty; --------- -- Job -- --------- function Job (TI : Task_Info) return Jobs.Job_Access is begin return TI.Job; end Job; ------------------ -- Task_Created -- ------------------ procedure Task_Created (Summary : in out Task_Summary; TI : Task_Info) is begin pragma Assert (TI.State = Unscheduled); Increment (Summary.Counters (TI.Kind, TI.State)); Increment (Summary.Counters (TI.Kind, Any)); Increment (Summary.Counters (Any, TI.State)); Increment (Summary.Counters (Any, Any)); end Task_Created; ------------------ -- Task_Removed -- ------------------ procedure Task_Removed (Summary : in out Task_Summary; TI : Task_Info) is begin pragma Assert (TI.State = Terminated); Decrement (Summary.Counters (TI.Kind, TI.State)); Decrement (Summary.Counters (TI.Kind, Any)); Decrement (Summary.Counters (Any, TI.State)); Decrement (Summary.Counters (Any, Any)); end Task_Removed; ----------------------- -- Task_State_Change -- ----------------------- procedure Task_State_Change (Summary : in out Task_Summary; TI : in out Task_Info; New_State : Task_State) is begin Decrement (Summary.Counters (TI.Kind, TI.State)); Decrement (Summary.Counters (Any, TI.State)); TI.State := New_State; Increment (Summary.Counters (TI.Kind, TI.State)); Increment (Summary.Counters (Any, TI.State)); pragma Assert (Task_Summary_Valid (Summary)); end Task_State_Change; ------------------------ -- Task_Summary_Valid -- ------------------------ function Task_Summary_Valid (Summary : Task_Summary) return Boolean is Count : Natural; Total_Count : Natural; begin -- Check per-kind summary for K in Task_Kind'Range loop Count := 0; for S in Task_State'Range loop Count := Count + Summary.Counters (K, S); end loop; if Summary.Counters (K, Any) /= Count then return False; end if; end loop; -- Check per-state summary and compute total count Total_Count := 0; for S in Task_State'Range loop Count := 0; for K in Task_Kind'Range loop Count := Count + Summary.Counters (K, S); Total_Count := Total_Count + Summary.Counters (K, S); end loop; if Summary.Counters (Any, S) /= Count then return False; end if; end loop; -- Check total count return Summary.Counters (Any, Any) = Total_Count; end Task_Summary_Valid; end PolyORB.Task_Info; polyorb-2.8~20110207.orig/src/polyorb-utils-udp_access_points.ads0000644000175000017500000000562111750740340024215 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . U T I L S . U D P _ A C C E S S _ P O I N T S -- -- -- -- S p e c -- -- -- -- Copyright (C) 2003-2008, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- Helper subprograms to set up access points based on UDP sockets with PolyORB.Binding_Data; with PolyORB.Sockets; with PolyORB.Transport; with PolyORB.Utils.Socket_Access_Points; package PolyORB.Utils.UDP_Access_Points is use PolyORB.Utils.Socket_Access_Points; type UDP_Access_Point_Info is record Socket : Sockets.Socket_Type; Address : Sockets.Sock_Addr_Type; SAP : Transport.Transport_Access_Point_Access; PF : Binding_Data.Profile_Factory_Access; end record; procedure Initialize_Unicast_Socket (AP_Info : in out UDP_Access_Point_Info; Port_Hint : Port_Interval; Address : Sockets.Inet_Addr_Type := Sockets.Any_Inet_Addr); procedure Initialize_Multicast_Socket (AP_Info : in out UDP_Access_Point_Info; Address : Sockets.Inet_Addr_Type; Port : Sockets.Port_Type); end PolyORB.Utils.UDP_Access_Points; polyorb-2.8~20110207.orig/src/polyorb-utils-htables-perfect.ads0000644000175000017500000002123211750740340023554 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . U T I L S . H T A B L E S . P E R F E C T -- -- -- -- S p e c -- -- -- -- Copyright (C) 2002-2007, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by ACT Europe. -- -- (email: sales@act-europe.fr) -- -- -- ------------------------------------------------------------------------------ -- This package provides dynamic perfect hash tables; it implements -- the Dietzfelbinger algorithm as described in "Dynamic Perfect -- Hashing: Upper and Lower Bounds", Dietzfelbinger et al. in SIAM -- Journal on Computing, 1994, pp 738-761. -- This algorithm provides dynamic perfect hash table with -- - O (1) worst-case time for lookups and deletions, -- - O (1) amortized expected time for insertions. -- Note: A major hypothesis made by this algorithm is that the class -- of hashing functions provided during instantiation is universal. with PolyORB.Utils.Dynamic_Tables; with PolyORB.Utils.Strings; generic type Item is private; type Hash_Parameters is private; with function Default_Hash_Parameters return Hash_Parameters; with function Hash (Key : String; Param : Hash_Parameters; Size : Natural) return Natural; with function Next_Hash_Parameters (Param : Hash_Parameters) return Hash_Parameters; package PolyORB.Utils.HTables.Perfect is pragma Preelaborate; type Item_Access is access all Item; type Table is private; type Table_Access is access all Table; type Table_Instance is record T : Table_Access; end record; Default_Max : constant := 10; procedure Initialize (T : out Table_Instance; HParam : Hash_Parameters := Default_Hash_Parameters; Max : Natural := Default_Max); -- Initialize the hash table. -- HParam are the hash function parameters, Max is the maximum number -- of elements to store. procedure Finalize (T : in out Table_Instance); -- Finalize the hash table function Lookup (T : Table_Instance; Key : String; Error_Value : Item) return Item; -- Find Key in hash table and return its associated Item. -- When Key does not exist, the function returns Error_Value. procedure Insert (T : Table_Instance; Key : String; Value : Item); -- Insert (Key, Value) in hash table. -- Key is the string to hash and Value its associated Item. -- If Key already exists, nothing is done. -- Note: this procedure may reorganize or extend, when necessary, the table -- or the sub_tables, leading to amortized O (1) complexity only. procedure Delete (T : Table_Instance; Key : String); -- Delete key in hash table. Does nothing if Key is not present in T. -- This procedure only unsets the entry's Used flag; deallocation is -- actually performed only after the table or a sub-table is reorganized -- (procedure Insert). function Is_Empty (T : Table_Instance) return Boolean; -- True if, and only if, T has no element ----------------------------------------- -- Iterator on Table_Instance elements -- ----------------------------------------- type Iterator is private; -- This Iterator type provides a way to traverse the hash tables -- and access the elements stored in the hash table. -- Note that elements are traversed in an implementation-defined arbitrary -- order. function First (T : Table_Instance) return Iterator; -- Return an Iterator placed on the first non null element found in T. -- If there is no such element, the Iterator is placed outside the bounds -- of T. function Value (I : Iterator) return Item; -- Return the Item on which I is placed function Key (I : Iterator) return String; -- Return the Key of the item on which I is placed function Last (I : Iterator) return Boolean; -- True if I is past the last element of the Table_Instance on which -- it operates. procedure Next (I : in out Iterator); -- Jump to the next non null element of the Table_Instance on which -- it operates. private -- A hash table containts a non-generic index of type Hash_Table and an -- an array of (generic) items providing the stored values. -- As described in the Dietzfelbinger algorithm, the Hash Table is divided -- into several sub-tables, each of which contains indices for several -- items. -- Element type type Element is record Key : Utils.Strings.String_Ptr; -- Key of the element to hash. Used : Boolean; -- Is the slot really used ? ST_Index : Natural; -- Index in the Sub Table. ST_Offset : Natural; -- Offset in the Sub Table. Item_Index : Natural; -- Index of the element. end record; Empty : constant Element := Element'(null, False, 0, 0, 0); package Dynamic_Element_Array is new PolyORB.Utils.Dynamic_Tables (Element, Natural, 0, 10, 50); use Dynamic_Element_Array; subtype Element_Array is Dynamic_Element_Array.Instance; -- Subtable type type Subtable is record First : Natural; -- 'First subtable index. Last : Natural; -- 'Last subtable index. Count : Natural; -- Number of keys stored. High : Natural; -- Highest count before reorganization. Max : Natural; -- Subtable maximum size. HParam : Hash_Parameters; -- Hash parameters. end record; package Dynamic_Subtable_Array is new PolyORB.Utils.Dynamic_Tables (Subtable, Natural, 0, 10, 50); use Dynamic_Subtable_Array; subtype Subtable_Array is Dynamic_Subtable_Array.Instance; -- Table_Info type type Table_Info is record Count : Natural; -- Number of keys stored in Subtables. High : Natural; -- Highest Count before resizing. N_Subtables : Natural; -- Number of subtables. HParam : Hash_Parameters; -- Hash parameters. end record; -- The Hash table index. type Hash_Table is record Info : Table_Info; -- Table information. Elements : Element_Array; -- Placeholder for elements. Subtables : Subtable_Array; -- Sub tables information. end record; -- Per construction, we have: -- ..< Subtables.all (i).First < Subtables.all (i).Last < -- Subtables.all (i+1).First < Subtables.all (i+1).Last <.. -- Item_Array package Dynamic_Item_Array is new PolyORB.Utils.Dynamic_Tables (Item_Access, Natural, 0, 10, 50); use Dynamic_Item_Array; subtype Item_Array is Dynamic_Item_Array.Instance; -- Table type type Table is record HTable : Hash_Table; -- Index associating key values to indices in Items Items : Item_Array; -- Stored item values end record; -- Note: HTable.Elements.all and Items.all have the same length. type Iterator is record On_Table : Table_Instance; Position : Natural := 0; end record; end PolyORB.Utils.HTables.Perfect; polyorb-2.8~20110207.orig/src/polyorb-tasking-profiles-full_tasking-threads-dynamic_priorities.adb0000644000175000017500000000730011750740340032611 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- POLYORB.TASKING.PROFILES.FULL_TASKING.THREADS.DYNAMIC_PRIORITIES -- -- -- -- B o d y -- -- -- -- Copyright (C) 2003-2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with Ada.Dynamic_Priorities; with PolyORB.Initialization; with PolyORB.Utils.Strings; package body PolyORB.Tasking.Profiles.Full_Tasking.Threads.Dynamic_Priorities is ------------------ -- Set_Priority -- ------------------ procedure Set_Priority (TF : access Full_Tasking_Thread_Factory_Type; T : PTT.Thread_Id; P : System.Any_Priority) is pragma Unreferenced (TF); begin Ada.Dynamic_Priorities.Set_Priority (P, P_To_A_Task_Id (T)); end Set_Priority; ------------------ -- Get_Priority -- ------------------ function Get_Priority (TF : access Full_Tasking_Thread_Factory_Type; T : PTT.Thread_Id) return System.Any_Priority is pragma Unreferenced (TF); begin return Ada.Dynamic_Priorities.Get_Priority (P_To_A_Task_Id (T)); end Get_Priority; ---------------- -- Initialize -- ---------------- procedure Initialize; procedure Initialize is begin PolyORB.Tasking.Profiles.Full_Tasking.Threads.Set_Priority_P := Set_Priority'Access; PolyORB.Tasking.Profiles.Full_Tasking.Threads.Get_Priority_P := Get_Priority'Access; end Initialize; use PolyORB.Initialization; use PolyORB.Initialization.String_Lists; use PolyORB.Utils.Strings; begin Register_Module (Module_Info' (Name => +"tasking.profiles.full_tasking.thread.dynamic_priorities", Conflicts => Empty, Depends => Empty, Provides => +"full_tasking.threads.priorities", Implicit => False, Init => Initialize'Access, Shutdown => null)); end PolyORB.Tasking.Profiles.Full_Tasking.Threads.Dynamic_Priorities; polyorb-2.8~20110207.orig/src/polyorb-poa_policies-request_processing_policy-use_servant_manager.adb0000644000175000017500000001315211750740340033324 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- B O D Y -- -- -- -- B o d y -- -- -- -- Copyright (C) 2003-2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with PolyORB.POA; with PolyORB.POA_Policies.Servant_Retention_Policy; package body PolyORB.POA_Policies.Request_Processing_Policy.Use_Servant_Manager is use PolyORB.Errors; ------------ -- Create -- ------------ function Create return Use_Servant_Manager_Policy_Access is begin return new Use_Servant_Manager_Policy; end Create; ------------------------- -- Check_Compatibility -- ------------------------- procedure Check_Compatibility (Self : Use_Servant_Manager_Policy; Other_Policies : AllPolicies; Error : in out PolyORB.Errors.Error_Container) is pragma Warnings (Off); pragma Unreferenced (Self); pragma Unreferenced (Other_Policies); pragma Unreferenced (Error); pragma Warnings (On); begin null; end Check_Compatibility; --------------- -- Policy_Id -- --------------- function Policy_Id (Self : Use_Servant_Manager_Policy) return String is pragma Warnings (Off); pragma Unreferenced (Self); pragma Warnings (On); begin return "REQUEST_PROCESSING_POLICY.USE__SERVANT_MANAGER"; end Policy_Id; ------------------- -- Id_To_Servant -- ------------------- procedure Id_To_Servant (Self : Use_Servant_Manager_Policy; OA : PolyORB.POA_Types.Obj_Adapter_Access; U_Oid : Unmarshalled_Oid; Servant : out Servants.Servant_Access; Error : in out PolyORB.Errors.Error_Container) is pragma Warnings (Off); pragma Unreferenced (Self); pragma Warnings (On); use PolyORB.POA_Policies.Servant_Retention_Policy; begin -- Lookup object in Active Object Map Retained_Id_To_Servant (POA.Obj_Adapter_Access (OA).Servant_Retention_Policy.all, OA, U_Oid, Servant, Error); if Found (Error) then return; end if; -- Under USE_SERVANT_MANAGER policy, if no servant is found and -- if we are processing a request, we may try to activate -- one. This is done by the POA. end Id_To_Servant; ----------------- -- Set_Servant -- ----------------- procedure Set_Servant (Self : Use_Servant_Manager_Policy; OA : PolyORB.POA_Types.Obj_Adapter_Access; Servant : Servants.Servant_Access; Error : in out PolyORB.Errors.Error_Container) is pragma Unreferenced (Self); pragma Unreferenced (OA); pragma Unreferenced (Servant); begin Throw (Error, WrongPolicy_E, Null_Members'(Null_Member)); end Set_Servant; ----------------- -- Get_Servant -- ----------------- procedure Get_Servant (Self : Use_Servant_Manager_Policy; OA : PolyORB.POA_Types.Obj_Adapter_Access; Servant : out Servants.Servant_Access; Error : in out PolyORB.Errors.Error_Container) is pragma Unreferenced (Self); pragma Unreferenced (OA); begin Servant := null; Throw (Error, WrongPolicy_E, Null_Members'(Null_Member)); end Get_Servant; ---------------------------- -- Ensure_Servant_Manager -- ---------------------------- procedure Ensure_Servant_Manager (Self : Use_Servant_Manager_Policy; Error : in out PolyORB.Errors.Error_Container) is pragma Unreferenced (Self); pragma Unreferenced (Error); begin null; end Ensure_Servant_Manager; end PolyORB.POA_Policies.Request_Processing_Policy.Use_Servant_Manager; polyorb-2.8~20110207.orig/src/polyorb-servants-group_servants.ads0000644000175000017500000001452511750740340024301 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . S E R V A N T S . G R O U P _ S E R V A N T S -- -- -- -- S p e c -- -- -- -- Copyright (C) 2002-2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ pragma Ada_2005; -- A servant that manages a group of servants, and acts as a proxy for them with PolyORB.Any.NVList; with PolyORB.Components; with PolyORB.Errors; with PolyORB.Objects; with PolyORB.References; with PolyORB.Utils.Chained_Lists; with PolyORB.Tasking.Mutexes; package PolyORB.Servants.Group_Servants is use PolyORB.Objects; -- This package use one exception in polyorb-exceptions : -- NotAGroupObject_E : used by some functions when a parameter is not a -- group object or when a group is not found ------------------------------ -- Group servants interface -- ------------------------------ function Create_Group_Servant (Oid : Object_Id_Access) return PolyORB.Servants.Servant_Access; -- Create a new group servant procedure Destroy_Group_Servant (Group : in out PolyORB.Servants.Servant_Access); -- Destroy group servant procedure Get_Group_Object_Id (Group : PolyORB.Servants.Servant_Access; Oid : out Object_Id_Access; Error : in out PolyORB.Errors.Error_Container); -- Return group object id procedure Get_Group_Length (Group : PolyORB.Servants.Servant_Access; L : out Natural; Error : in out PolyORB.Errors.Error_Container); -- Return group length -------------------------- -- Group servants tools -- -------------------------- procedure Associate (Group : PolyORB.Servants.Servant_Access; Ref : PolyORB.References.Ref; Error : in out PolyORB.Errors.Error_Container); -- Associate a servant ref with a group procedure Disassociate (Group : PolyORB.Servants.Servant_Access; Ref : PolyORB.References.Ref; Error : in out PolyORB.Errors.Error_Container); -- Disassociate a servant ref with a group -- Iterator on a group servant type Iterator is private; procedure First (Group : PolyORB.Servants.Servant_Access; It : out Iterator; Error : in out PolyORB.Errors.Error_Container); -- Create Iterator and set it on the first element function Value (It : Iterator) return PolyORB.References.Ref; -- Return current iterator reference procedure Next (It : in out Iterator); -- Increment iterator function Last (It : Iterator) return Boolean; -- Return True if iterator is in group range private ------------------- -- Group Servant -- ------------------- -- State of argument proxy type Proxy_State is (Not_Ready, Wait_First, Wait_Other); -- List of servants registered in group package Target_List_Package is new PolyORB.Utils.Chained_Lists (PolyORB.References.Ref, PolyORB.References."="); -- XXX questionnable. works with CORBA GOA, but need to -- be replaced by Is_Same_Object function type Group_Servant is new PolyORB.Servants.Servant with record -- Object_Id Oid : Object_Id_Access; -- List of target objects Target_List : Target_List_Package.List; -- Request response counter Counter : Natural; -------------------- -- For args proxy -- -------------------- Args_Src : PolyORB.Components.Component_Access; -- Current Args list Args : PolyORB.Any.NVList.Ref; Error : PolyORB.Errors.Error_Container; -- Proxy state State : Proxy_State := Not_Ready; -- Mutex to avoid concurrent proxy access Mutex : Tasking.Mutexes.Mutex_Access; Group_Lock : Tasking.Mutexes.Mutex_Access; end record; type Group_Servant_Access is access all Group_Servant; function Handle_Message (Self : not null access Group_Servant; Msg : Components.Message'Class) return Components.Message'Class; -- Function used to intercept Unmarshall_Arguments message overriding function Execute_Servant (Self : not null access Group_Servant; Req : Requests.Request_Access) return Boolean; -- Dispatch request to targets procedure Register (Self : access Group_Servant; Ref : PolyORB.References.Ref); -- Add a target ref to a group procedure Unregister (Self : access Group_Servant; Ref : PolyORB.References.Ref); -- Remove a target ref from a group type Iterator is record It : Target_List_Package.Iterator; end record; end PolyORB.Servants.Group_Servants; polyorb-2.8~20110207.orig/src/polyorb-utils-hfunctions.ads0000644000175000017500000000657011750740340022674 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . U T I L S . H F U N C T I O N S -- -- -- -- S p e c -- -- -- -- Copyright (C) 2003 Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by ACT Europe. -- -- (email: sales@act-europe.fr) -- -- -- ------------------------------------------------------------------------------ -- Root package of Hash functions. -- Some definitions used in child packages: -- Universality: -- Note : this definition is extracted from "Universal Classes of -- Hash Functions" by J.L Carter and M. N. Wegman, Proceedings of the -- ninth annual ACM symposium on Theory of computing, 1977. -- A class H of hashing functions {(h_i) : U -> R, i in I} is -- universal if for any (x,y) from U, x /= y, and h randomly chosen in H, -- P[ h (x) = h (y) ] < 1/|R| package PolyORB.Utils.HFunctions is pragma Pure; -- Each child package must implement the following functions to be -- used as hash functions class by HTables packages: type Hash_Parameters is abstract tagged private; -- Hash_Parameters holds information that uniquely identify one -- member of a hash functions class. It is a placeholder for this -- specific hash function parameters. function Hash (S : String; Param : Hash_Parameters; Size : Natural) return Natural is abstract; -- Hash the key S. function Default_Hash_Parameters return Hash_Parameters is abstract; -- Return default Hash_Parameters. function Next_Hash_Parameters (Param : Hash_Parameters) return Hash_Parameters is abstract; -- Return next Hash_Parameters. private type Hash_Parameters is abstract tagged null record; end PolyORB.Utils.HFunctions; polyorb-2.8~20110207.orig/src/polyorb-tasking-profiles-full_tasking-threads-annotations.ads0000644000175000017500000000521311750740340031273 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- POLYORB.TASKING.PROFILES.FULL_TASKING.THREADS.ANNOTATIONS -- -- -- -- S p e c -- -- -- -- Copyright (C) 2004 Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by ACT Europe. -- -- (email: sales@act-europe.fr) -- -- -- ------------------------------------------------------------------------------ with PolyORB.Annotations; with PolyORB.Tasking.Threads.Annotations; package PolyORB.Tasking.Profiles.Full_Tasking.Threads.Annotations is type Full_Tasking_TAF is new PolyORB.Tasking.Threads.Annotations.Thread_Annotations_Factory with private; type Full_Tasking_TAF_Access is access all Full_Tasking_TAF; function Get_Current_Thread_Notepad (TAF : access Full_Tasking_TAF) return PolyORB.Annotations.Notepad_Access; private type Full_Tasking_TAF is new PolyORB.Tasking.Threads.Annotations.Thread_Annotations_Factory with null record; end PolyORB.Tasking.Profiles.Full_Tasking.Threads.Annotations; polyorb-2.8~20110207.orig/src/polyorb-utils-ilists.adb0000644000175000017500000001513211750740340021774 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . U T I L S . I L I S T S -- -- -- -- B o d y -- -- -- -- Copyright (C) 2009, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ package body PolyORB.Utils.Ilists is package body Lists is function "+" (X : access T) return T_Acc; pragma Inline ("+"); -- Convert X to a general access type, bypassing accessibility checks function Link (X : access T; Which : Link_Type) return T_Acc; procedure Set_Link (X : access T; Which : Link_Type; To : T_Acc); pragma Inline (Link); pragma Inline (Set_Link); -- Short-hand notation for read and write usage of the Link accessor ---------- -- Link -- ---------- function Link (X : access T; Which : Link_Type) return T_Acc is begin return Link (X, Which).all; end Link; -------------- -- Set_Link -- -------------- procedure Set_Link (X : access T; Which : Link_Type; To : T_Acc) is begin Link (X, Which).all := To; end Set_Link; --------- -- "+" -- --------- function "+" (X : access T) return T_Acc is pragma Suppress (Access_Check); begin return X.all'Unchecked_Access; end "+"; ------------ -- Append -- ------------ procedure Append (L : in out List; X : access T) is begin if L.Last /= null then if Doubly_Linked then Set_Link (X, Prev, L.Last); end if; Set_Link (L.Last, Next, +X); end if; L.Last := +X; if L.First = null then L.First := +X; end if; L.Length := L.Length + 1; end Append; ----------- -- First -- ----------- function First (L : List) return Iterator is begin return Iterator (L.First); end First; -------------- -- Is_Empty -- -------------- function Is_Empty (L : List) return Boolean is begin return L.Length = 0; end Is_Empty; ---------- -- Last -- ---------- function Last (L : List) return Iterator is pragma Unreferenced (L); begin return null; end Last; ---------- -- Last -- ---------- function Last (It : Iterator) return Boolean is begin return It = null; end Last; ------------ -- Length -- ------------ function Length (L : List) return Natural is begin return L.Length; end Length; ---------- -- Next -- ---------- procedure Next (It : in out Iterator) is begin It := Iterator (T_Acc'(Link (It, Next))); end Next; ------------- -- Prepend -- ------------- procedure Prepend (L : in out List; X : access T) is begin Set_Link (X, Next, L.First); if Doubly_Linked and then L.First /= null then Set_Link (L.First, Prev, +X); end if; L.First := +X; if L.Last = null then L.Last := +X; end if; L.Length := L.Length + 1; end Prepend; ------------ -- Remove -- ------------ procedure Remove (L : in out List; It : in out Iterator) is Element : constant access T := It; begin Next (It); Remove_Element (L, Element); end Remove; -------------------- -- Remove_Element -- -------------------- procedure Remove_Element (L : in out List; X : access T) is Previous : T_Acc; begin if Doubly_Linked then Previous := Link (X, Prev); else pragma Assert (X = L.First); Previous := null; end if; Remove_Element (L, X => X, PX => Previous); end Remove_Element; -------------------- -- Remove_Element -- -------------------- procedure Remove_Element (L : in out List; X : access T; PX : access T) is begin if PX = null then L.First := Link (X, Next); else Set_Link (PX, Next, Link (X, Next)); end if; if L.Last = X then L.Last := +PX; end if; if Doubly_Linked then if Link (X, Next) /= T_Acc'(null) then Set_Link (Link (X, Next), Prev, +PX); end if; Set_Link (X, Prev, null); end if; Set_Link (X, Next, null); L.Length := L.Length - 1; end Remove_Element; ----------- -- Value -- ----------- function Value (It : Iterator) return T_Acc is begin return T_Acc (It); end Value; end Lists; end PolyORB.Utils.Ilists; polyorb-2.8~20110207.orig/src/polyorb-poa_policies-lifespan_policy.ads0000644000175000017500000000555011750740340025177 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- POLYORB.POA_POLICIES.LIFESPAN_POLICY -- -- -- -- S p e c -- -- -- -- Copyright (C) 2001-2005 Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with PolyORB.POA_Types; package PolyORB.POA_Policies.Lifespan_Policy is use PolyORB.POA_Types; type LifespanPolicy is abstract new Policy with null record; type LifespanPolicy_Access is access all LifespanPolicy'Class; function Get_Lifespan_Cookie (P : LifespanPolicy; OA : PolyORB.POA_Types.Obj_Adapter_Access) return Lifespan_Cookie is abstract; procedure Ensure_Lifespan (P : LifespanPolicy; OA : PolyORB.POA_Types.Obj_Adapter_Access; U_Oid : Unmarshalled_Oid; Error : in out PolyORB.Errors.Error_Container) is abstract; -- TRANSIENT: -- Ensure that the Oid has been generated by the current instantiation -- of the POA. If not, raises a OBJECT_NOT_EXIST exception. -- PERSISTENT: -- Does nothing. end PolyORB.POA_Policies.Lifespan_Policy; polyorb-2.8~20110207.orig/src/polyorb-asynch_ev.ads0000644000175000017500000001660111750740340021331 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . A S Y N C H _ E V -- -- -- -- S p e c -- -- -- -- Copyright (C) 2001-2009, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- Abstract data type for an asynchrous event source pragma Ada_2005; with PolyORB.Jobs; package PolyORB.Asynch_Ev is pragma Preelaborate; -- Some environment components can produce events in an -- asynchronous fashion, i.e. independently of middleware actions -- currently in progress. A typical example of such components is -- a connection from the outside world. -- Such components are represented within PolyORB as Asynch_Ev_Source -- objects. These objects are registered in collections called -- Asynch_Ev_Monitors. -- Monitors provide an interface for the middleware to check whether -- events have occured on any of their member Asynch_Ev_Sources. type Asynch_Ev_Monitor is abstract tagged limited private; function Has_Sources (AEM : Asynch_Ev_Monitor) return Boolean is abstract; -- Return True iff AEM has sources to monitor type Asynch_Ev_Monitor_Access is access all Asynch_Ev_Monitor'Class; type AEM_Factory is access function return Asynch_Ev_Monitor_Access; -- A function that allocates an instance of a concrete AEM type type Asynch_Ev_Source is abstract tagged limited private; type Asynch_Ev_Source_Access is access all Asynch_Ev_Source'Class; type AES_Event_Handler; procedure Set_Handler (AES : in out Asynch_Ev_Source'Class; H : access AES_Event_Handler'Class); -- Associate handler H to events occurring on AES pragma Inline (Set_Handler); function Handler (AES : Asynch_Ev_Source'Class) return access AES_Event_Handler'Class; -- Retrieve handler associated with events occurring on AES pragma Inline (Handler); function AEM_Factory_Of (AES : Asynch_Ev_Source) return AEM_Factory is abstract; pragma Inline (AEM_Factory_Of); -- Return a factory capable of creating an AEM that can monitor AES procedure Create (AEM : out Asynch_Ev_Monitor) is abstract; -- Initialize AEM procedure Destroy (AEM : in out Asynch_Ev_Monitor) is abstract; -- Finalize AEM function AEM_Of (AES : Asynch_Ev_Source) return Asynch_Ev_Monitor_Access; procedure Register_Source (AEM : access Asynch_Ev_Monitor; AES : Asynch_Ev_Source_Access; Success : out Boolean) is abstract; -- Try to register AES for monitoring by AEM. -- On exit, Success is True iff AEM accepts AES for monitoring. procedure Unregister_Source (AEM : in out Asynch_Ev_Monitor; AES : Asynch_Ev_Source_Access; Success : out Boolean) is abstract; -- Remove AES from the set of sources monitored by AEM. On exit, -- Success is True iff AES was previously registered with this AEM. function Unregister_Source (AES : Asynch_Ev_Source_Access) return Boolean; -- Remove AES from any AEM that it is currently in. Returns True if -- AES actually has been unregistered from an AEM, False otherwise. procedure Destroy (AES : in out Asynch_Ev_Source_Access); -- Destroy AES type AES_Array is array (Integer range <>) of Asynch_Ev_Source_Access; function Check_Sources (AEM : access Asynch_Ev_Monitor; Timeout : Duration) return AES_Array is abstract; -- Wait for events on sources monitored by AEM. -- Return when one event source in AEM has had an event. -- If no event happened within Timeout, an empty array is returned. -- Otherwise, the returned array contains those sources on which -- events have occurred, and these sources are removed from AEM. -- Note that a Timeout of 0.0 returns immediatly. -- A Timeout of PolyORB.Constants.Forever means to not return -- until an event occurs. procedure Abort_Check_Sources (AEM : Asynch_Ev_Monitor) is abstract; -- Send a persistent abort signal to AEM. This signal aborts any -- task currently executing Check_Sources on AEM, or will abort -- next call to Check_Sources. ------------------------------------- -- Reactor for asynchronous events -- ------------------------------------- -- The middleware core implements the Reactor pattern to handle -- events occurring on asynchronous event sources. An event -- handler is associated with each asynchronous event source. The -- handling of an event constitutes a Job that can be performed by -- an ORB task. type AES_Event_Handler is abstract new PolyORB.Jobs.Job with record AES : Asynch_Ev_Source_Access; end record; procedure Handle_Event (H : access AES_Event_Handler) is abstract; -- Handle an event that has occurred on this asynchronous event -- source. If AES is null on exit, then the asynchronous event -- source has been destroyed, and the handler must be deallocated. -- In this implementation of the Reactor pattern, the association -- between an event source and its event handler is made using an -- Annotation on the event source. procedure Run (AEH : not null access AES_Event_Handler); -- Call Handle_Event private type Asynch_Ev_Source is abstract tagged limited record Monitor : Asynch_Ev_Monitor_Access; -- The AEM with which this source was registered. A concrete -- implementation of Register_Source returning with Success = -- True must set this member of its AES argument to the value -- of its AEM argument. Handler : access AES_Event_Handler'Class; end record; type Asynch_Ev_Monitor is abstract tagged limited null record; end PolyORB.Asynch_Ev; polyorb-2.8~20110207.orig/src/setup/0000755000175000017500000000000011750740340016331 5ustar xavierxavierpolyorb-2.8~20110207.orig/src/setup/polyorb-setup-tasking-ravenscar.ads0000644000175000017500000000674411750740340025301 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . S E T U P . T A S K I N G . R A V E N S C A R -- -- -- -- S p e c -- -- -- -- Copyright (C) 2002-2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- You should instantiate this package to set up a ravenscar profile. with System; with PolyORB.Tasking.Profiles.Ravenscar.Threads.Annotations; with PolyORB.Tasking.Profiles.Ravenscar.Threads; with PolyORB.Tasking.Profiles.Ravenscar.Mutexes; with PolyORB.Tasking.Profiles.Ravenscar.Condition_Variables; generic Number_Of_Application_Tasks : Integer; -- Number of tasks created by the user. Number_Of_System_Tasks : Integer; -- Number of tasks created by the PolyORB run-time library. Number_Of_Conditions : Integer; -- Number of preallocated conditions. Number_Of_Mutexes : Integer; -- Number of preallocated mutexes. Task_Priority : System.Priority; -- Priority of the tasks of the pool. Storage_Size : Natural; -- Stack size of the system tasks. package PolyORB.Setup.Tasking.Ravenscar is package Threads_Package is new PolyORB.Tasking.Profiles.Ravenscar.Threads (Number_Of_Application_Tasks, Number_Of_System_Tasks, Task_Priority, Storage_Size); package Thread_Annotations_Package is new Threads_Package.Annotations; package Conditions_Package is new PolyORB.Tasking.Profiles.Ravenscar.Condition_Variables (Threads_Package, Number_Of_Conditions); package Mutexes_Package is new PolyORB.Tasking.Profiles.Ravenscar.Mutexes (Threads_Package, Number_Of_Mutexes); end PolyORB.Setup.Tasking.Ravenscar; polyorb-2.8~20110207.orig/src/setup/polyorb-setup-common_base.ads0000644000175000017500000000426211750740340024132 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . S E T U P . C O M M O N _ B A S E -- -- -- -- S p e c -- -- -- -- Copyright (C) 2005-2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- Base setup, common to all platforms and all middleware configurations package PolyORB.Setup.Common_Base is pragma Elaborate_Body; end PolyORB.Setup.Common_Base; polyorb-2.8~20110207.orig/src/setup/polyorb-setup-thread_pool_client.ads0000644000175000017500000000425311750740340025506 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . S E T U P . T H R E A D _ P O O L _ C L I E N T -- -- -- -- S p e c -- -- -- -- Copyright (C) 2009, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- Complete setup for a client partition with tasking package PolyORB.Setup.Thread_Pool_Client is pragma Elaborate_Body; end PolyORB.Setup.Thread_Pool_Client; polyorb-2.8~20110207.orig/src/setup/polyorb-setup-common_base.adb0000644000175000017500000000514111750740340024106 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . S E T U P . C O M M O N _ B A S E -- -- -- -- B o d y -- -- -- -- Copyright (C) 2005-2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with PolyORB.Log.Stderr; pragma Warnings (Off, PolyORB.Log.Stderr); pragma Elaborate_All (PolyORB.Log.Stderr); with PolyORB.Log.Initialization; pragma Warnings (Off, PolyORB.Log.Initialization); pragma Elaborate_All (PolyORB.Log.Initialization); with PolyORB.Setup.Default_Parameters; pragma Warnings (Off, PolyORB.Setup.Default_Parameters); pragma Elaborate_All (PolyORB.Setup.Default_Parameters); with PolyORB.References.File; pragma Warnings (Off, PolyORB.References.File); pragma Elaborate_All (PolyORB.References.File); package body PolyORB.Setup.Common_Base is end PolyORB.Setup.Common_Base; polyorb-2.8~20110207.orig/src/setup/polyorb-setup-thread_per_request_server.adb0000644000175000017500000000543311750740340027103 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- POLYORB.SETUP.THREAD_PER_REQUEST_SERVER -- -- -- -- B o d y -- -- -- -- Copyright (C) 2002-2005 Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- Elaborate a complete server with the ``thread-per-request'' -- tasking policy and a full tasking runtime. with PolyORB.ORB.Thread_Per_Request; pragma Elaborate_All (PolyORB.ORB.Thread_Per_Request); pragma Warnings (Off, PolyORB.ORB.Thread_Per_Request); with PolyORB.ORB_Controller.Workers; pragma Warnings (Off, PolyORB.ORB_Controller.Workers); pragma Elaborate_All (PolyORB.ORB_Controller.Workers); with PolyORB.Setup.Server; pragma Elaborate_All (PolyORB.Setup.Server); pragma Warnings (Off, PolyORB.Setup.Server); with PolyORB.Setup.Tasking.Full_Tasking; pragma Elaborate_All (PolyORB.Setup.Tasking.Full_Tasking); pragma Warnings (Off, PolyORB.Setup.Tasking.Full_Tasking); package body PolyORB.Setup.Thread_Per_Request_Server is end PolyORB.Setup.Thread_Per_Request_Server; polyorb-2.8~20110207.orig/src/setup/polyorb-setup-base.ads0000644000175000017500000000420011750740340022552 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . S E T U P . B A S E -- -- -- -- S p e c -- -- -- -- Copyright (C) 2008, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- Platform-specific base setup unit package PolyORB.Setup.Base is pragma Elaborate_Body; end PolyORB.Setup.Base; polyorb-2.8~20110207.orig/src/setup/polyorb-setup-default_parameters.adb0000644000175000017500000000610211750740340025471 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . S E T U P . D E F A U L T _ P A R A M E T E R S -- -- -- -- B o d y -- -- -- -- Copyright (C) 2005-2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with PolyORB.Parameters.Command_Line; pragma Warnings (Off, PolyORB.Parameters.Command_Line); pragma Elaborate_All (PolyORB.Parameters.Command_Line); with PolyORB.Parameters.Environment; pragma Warnings (Off, PolyORB.Parameters.Environment); pragma Elaborate_All (PolyORB.Parameters.Environment); with PolyORB.Parameters.File; pragma Warnings (Off, PolyORB.Parameters.File); pragma Elaborate_All (PolyORB.Parameters.File); -- For embedded platforms, an additional parameter source, "Static", -- is provided in the platform-specific base setup to support hard-coded -- parameters provided by the application (see PolyORB.Parameters.Static -- for usage details). For native platforms, this unit is not included by -- default because in such context, a filesystem can be assumed to be -- available, and so a configuration file is the preferred way of tuning -- PolyORB. Additionally, the Static parameters source uses a weak external -- symbol, which is not supported on all platforms. package body PolyORB.Setup.Default_Parameters is end PolyORB.Setup.Default_Parameters; polyorb-2.8~20110207.orig/src/setup/security/0000755000175000017500000000000011750740340020200 5ustar xavierxavierpolyorb-2.8~20110207.orig/src/setup/security/polyorb-setup-secure_server.ads0000644000175000017500000000415311750740340026372 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . S E T U P . S E C U R E _ S E R V E R -- -- -- -- S p e c -- -- -- -- Copyright (C) 2005-2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ package PolyORB.Setup.Secure_Server is pragma Elaborate_Body; end PolyORB.Setup.Secure_Server; polyorb-2.8~20110207.orig/src/setup/security/polyorb-setup-secure_client.ads0000644000175000017500000000415311750740340026342 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . S E T U P . S E C U R E _ C L I E N T -- -- -- -- S p e c -- -- -- -- Copyright (C) 2005-2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ package PolyORB.Setup.Secure_Client is pragma Elaborate_Body; end PolyORB.Setup.Secure_Client; polyorb-2.8~20110207.orig/src/setup/security/polyorb-setup-security_base.adb0000644000175000017500000000656511750740340026347 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . S E T U P . S E C U R I T Y _ B A S E -- -- -- -- B o d y -- -- -- -- Copyright (C) 2005-2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- Neutral Core Setup -- with PolyORB.Security.Authorization_Elements; -- pragma Warnings (Off, PolyORB.Security.Authorization_Elements); -- with PolyORB.Security.Credentials.GSSUP; -- pragma Warnings (Off, PolyORB.Security.Credentials.GSSUP); -- with PolyORB.Security.Credentials.X509; -- pragma Warnings (Off, PolyORB.Security.Credentials.X509); -- with PolyORB.Security.Identities.Anonymous; -- pragma Warnings (Off, PolyORB.Security.Identities.Anonymous); -- with PolyORB.Security.Identities.Principal_Name; -- pragma Warnings (Off, PolyORB.Security.Identities.Principal_Name); -- with PolyORB.Security.Privilege_Authorities; -- pragma Warnings (Off, PolyORB.Security.Privilege_Authorities); with PolyORB.Security.Security_Manager; pragma Warnings (Off, PolyORB.Security.Security_Manager); -- GIOP Protocol Personality Setup with PolyORB.GIOP_P.Tagged_Components.CSI_Sec_Mech_List; pragma Warnings (Off, PolyORB.GIOP_P.Tagged_Components.CSI_Sec_Mech_List); with PolyORB.GIOP_P.Tagged_Components.Null_Tag; pragma Warnings (Off, PolyORB.GIOP_P.Tagged_Components.Null_Tag); -- with PolyORB.GIOP_P.Tagged_Components.SECIOP_Sec_Trans; -- pragma Warnings (Off, PolyORB.GIOP_P.Tagged_Components.SECIOP_Sec_Trans); with PolyORB.Setup.TLSIOP; pragma Warnings (Off, PolyORB.Setup.TLSIOP); package body PolyORB.Setup.Security_Base is end PolyORB.Setup.Security_Base; polyorb-2.8~20110207.orig/src/setup/security/polyorb-setup-secure_server.adb0000644000175000017500000000550111750740340026347 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . S E T U P . S E C U R E _ S E R V E R -- -- -- -- B o d y -- -- -- -- Copyright (C) 2005-2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- Setup Secure Server with PolyORB.Setup.Secure_Client; pragma Warnings (Off, PolyORB.Setup.Secure_Client); -- Neutral Core Setup with PolyORB.Security.Authentication_Mechanisms.GSSUP_Target; pragma Warnings (Off, PolyORB.Security.Authentication_Mechanisms.GSSUP_Target); -- GIOP Protocol Personality Setup with PolyORB.Setup.Access_Points.TLSIOP; pragma Warnings (Off, PolyORB.Setup.Access_Points.TLSIOP); -- CORBA Application Personality Setup (server side only) with PolyORB.CORBA_P.TSS_State_Machine; pragma Warnings (Off, PolyORB.CORBA_P.TSS_State_Machine); -- ATLAS Privilege Authority -- with PolyORB.Security.Authority_Mechanisms.ATLAS_Target; -- pragma Warnings (Off, PolyORB.Security.Authority_Mechanisms.ATLAS_Target); package body PolyORB.Setup.Secure_Server is end PolyORB.Setup.Secure_Server; polyorb-2.8~20110207.orig/src/setup/security/polyorb-setup-security_base.ads0000644000175000017500000000415311750740340026357 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . S E T U P . S E C U R I T Y _ B A S E -- -- -- -- S p e c -- -- -- -- Copyright (C) 2005-2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ package PolyORB.Setup.Security_Base is pragma Elaborate_Body; end PolyORB.Setup.Security_Base; polyorb-2.8~20110207.orig/src/setup/security/polyorb-setup-secure_client.adb0000644000175000017500000000524411750740340026323 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . S E T U P . S E C U R E _ C L I E N T -- -- -- -- B o d y -- -- -- -- Copyright (C) 2005-2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- Setup secure client with PolyORB.Setup.Security_Base; pragma Warnings (Off, PolyORB.Setup.Security_Base); -- Neutral Core Setup with PolyORB.Security.Authentication_Mechanisms.GSSUP_Client; pragma Warnings (Off, PolyORB.Security.Authentication_Mechanisms.GSSUP_Client); -- CORBA Application Personality Setup with PolyORB.CORBA_P.CSS_State_Machine; pragma Warnings (Off, PolyORB.CORBA_P.CSS_State_Machine); -- ATLAS Privilege Authority -- with PolyORB.Security.Authority_Mechanisms.ATLAS_Client; -- pragma Warnings (Off, PolyORB.Security.Authority_Mechanisms.ATLAS_Client); package body PolyORB.Setup.Secure_Client is end PolyORB.Setup.Secure_Client; polyorb-2.8~20110207.orig/src/setup/polyorb-setup-client.ads0000644000175000017500000000434711750740340023132 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . S E T U P . C L I E N T -- -- -- -- S p e c -- -- -- -- Copyright (C) 2002-2009, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- Legacy renaming provided for compatibility (package has been renamed to -- PolyORB.Setup.No_Tasking_Client). with PolyORB.Setup.No_Tasking_Client; package PolyORB.Setup.Client renames PolyORB.Setup.No_Tasking_Client; polyorb-2.8~20110207.orig/src/setup/polyorb-setup-thread_per_session_server.ads0000644000175000017500000000433011750740340027112 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- POLYORB.SETUP.THREAD_PER_SESSION_SERVER -- -- -- -- S p e c -- -- -- -- Copyright (C) 2001-2004 Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by ACT Europe. -- -- (email: sales@act-europe.fr) -- -- -- ------------------------------------------------------------------------------ -- Elaborate a complete server with the ``thread-per-session'' -- tasking policy. package PolyORB.Setup.Thread_Per_Session_Server is pragma Elaborate_Body; end PolyORB.Setup.Thread_Per_Session_Server; polyorb-2.8~20110207.orig/src/setup/polyorb-setup-tasking-full_tasking.ads0000644000175000017500000000423411750740340025767 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . S E T U P . T A S K I N G . F U L L _ T A S K I N G -- -- -- -- S p e c -- -- -- -- Copyright (C) 2002-2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- Set up a full tasking profile package PolyORB.Setup.Tasking.Full_Tasking is pragma Elaborate_Body; end PolyORB.Setup.Tasking.Full_Tasking; polyorb-2.8~20110207.orig/src/setup/polyorb-setup-ravenscar_tp_server.adb0000644000175000017500000000627511750740340025712 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . S E T U P . R A V E N S C A R _ T P _ S E R V E R -- -- -- -- B o d y -- -- -- -- Copyright (C) 2002-2005 Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- Elaborate a complete server with the ``thread pool'' tasking -- policy and the Ravenscar tasking profile. with System; with PolyORB.ORB.Thread_Pool; pragma Warnings (Off, PolyORB.ORB.Thread_Pool); pragma Elaborate_All (PolyORB.ORB.Thread_Pool); with PolyORB.ORB_Controller.Workers; pragma Warnings (Off, PolyORB.ORB_Controller.Workers); pragma Elaborate_All (PolyORB.ORB_Controller.Workers); with PolyORB.Setup.Tasking.Ravenscar; pragma Elaborate_All (PolyORB.Setup.Tasking.Ravenscar); with PolyORB.Setup.Server; pragma Elaborate_All (PolyORB.Setup.Server); pragma Warnings (Off, PolyORB.Setup.Server); package body PolyORB.Setup.Ravenscar_TP_Server is package Ravenscar_Profile_Instance is new PolyORB.Setup.Tasking.Ravenscar (Number_Of_Application_Tasks => 4, Number_Of_System_Tasks => 20, Number_Of_Conditions => 1_000, Number_Of_Mutexes => 1_000, Task_Priority => System.Default_Priority, Storage_Size => 262_144); pragma Unreferenced (Ravenscar_Profile_Instance); -- There is no direct reference on this package: it only -- initializes hooks end PolyORB.Setup.Ravenscar_TP_Server; polyorb-2.8~20110207.orig/src/setup/polyorb-setup-client_base.ads0000644000175000017500000000423311750740340024116 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . S E T U P . C L I E N T _ B A S E -- -- -- -- S p e c -- -- -- -- Copyright (C) 2002-2009, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- Common setup for non-tasking and tasking clients package PolyORB.Setup.Client_Base is pragma Elaborate_Body; end PolyORB.Setup.Client_Base; polyorb-2.8~20110207.orig/src/setup/polyorb-setup-no_tasking_client.adb0000644000175000017500000000522411750740340025320 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . S E T U P . N O _ T A S K I N G _ C L I E N T -- -- -- -- B o d y -- -- -- -- Copyright (C) 2002-2009, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with PolyORB.Setup.Client_Base; pragma Warnings (Off, PolyORB.Setup.Client_Base); pragma Elaborate_All (PolyORB.Setup.Client_Base); with PolyORB.Setup.Tasking.No_Tasking; pragma Warnings (Off, PolyORB.Setup.Tasking.No_Tasking); pragma Elaborate_All (PolyORB.Setup.Tasking.No_Tasking); with PolyORB.ORB.No_Tasking; pragma Warnings (Off, PolyORB.ORB.No_Tasking); pragma Elaborate_All (PolyORB.ORB.No_Tasking); with PolyORB.ORB_Controller.No_Tasking; pragma Warnings (Off, PolyORB.ORB_Controller.No_Tasking); pragma Elaborate_All (PolyORB.ORB_Controller.No_Tasking); package body PolyORB.Setup.No_Tasking_Client is end PolyORB.Setup.No_Tasking_Client; polyorb-2.8~20110207.orig/src/setup/polyorb-setup-client_base.adb.in0000644000175000017500000000452511750740340024506 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . S E T U P . C L I E N T _ B A S E -- -- -- -- B o d y -- -- -- -- Copyright (C) 2001-2009, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ pragma Style_Checks ("M2048"); -- Configure substitutions may yield long lines -- @configure_input@ with PolyORB.Setup.Base; pragma Warnings (Off, PolyORB.Setup.Base); pragma Elaborate_All (PolyORB.Setup.Base); -- Personalities setup @PROTO_CLIENT_WITHS@ package body PolyORB.Setup.Client_Base is end PolyORB.Setup.Client_Base; polyorb-2.8~20110207.orig/src/setup/polyorb-setup-tasking.ads0000644000175000017500000000417511750740340023313 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . S E T U P . T A S K I N G -- -- -- -- S p e c -- -- -- -- Copyright (C) 2002-2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- Root package for the setup of the tasking profiles. package PolyORB.Setup.Tasking is end PolyORB.Setup.Tasking; polyorb-2.8~20110207.orig/src/setup/polyorb-setup-thread_pool_server.adb0000644000175000017500000000536411750740340025521 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . S E T U P . T H R E A D _ P O O L _ S E R V E R -- -- -- -- B o d y -- -- -- -- Copyright (C) 2001-2005 Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- Elaborate a complete server with the ``thread pool'' ORB tasking -- policy and a full tasking runtime. with PolyORB.Setup.Server; pragma Elaborate_All (PolyORB.Setup.Server); pragma Warnings (Off, PolyORB.Setup.Server); with PolyORB.ORB.Thread_Pool; pragma Elaborate_All (PolyORB.ORB.Thread_Pool); pragma Warnings (Off, PolyORB.ORB.Thread_Pool); with PolyORB.Setup.Tasking.Full_Tasking; pragma Elaborate_All (PolyORB.Setup.Tasking.Full_Tasking); pragma Warnings (Off, PolyORB.Setup.Tasking.Full_Tasking); with PolyORB.ORB_Controller.Workers; pragma Warnings (Off, PolyORB.ORB_Controller.Workers); pragma Elaborate_All (PolyORB.ORB_Controller.Workers); package body PolyORB.Setup.Thread_Pool_Server is end PolyORB.Setup.Thread_Pool_Server; polyorb-2.8~20110207.orig/src/setup/polyorb-setup-server.ads0000644000175000017500000000431311750740340023153 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . S E T U P . S E R V E R -- -- -- -- S p e c -- -- -- -- Copyright (C) 2001-2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- Set up a simple ORB to act as a server. -- The user must take care of also setting up a tasking policy. package PolyORB.Setup.Server is pragma Elaborate_Body; end PolyORB.Setup.Server; polyorb-2.8~20110207.orig/src/setup/polyorb-setup-no_tasking_server.adb0000644000175000017500000000527011750740340025351 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . S E T U P . N O _ T A S K I N G _ S E R V E R -- -- -- -- B o d y -- -- -- -- Copyright (C) 2001-2005 Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- Elaborate a complete server with no tasking. with PolyORB.ORB.No_Tasking; pragma Warnings (Off, PolyORB.ORB.No_Tasking); pragma Elaborate_All (PolyORB.ORB.No_Tasking); with PolyORB.ORB_Controller.No_Tasking; pragma Warnings (Off, PolyORB.ORB_Controller.No_Tasking); pragma Elaborate_All (PolyORB.ORB_Controller.No_Tasking); with PolyORB.Setup.Server; pragma Elaborate_All (PolyORB.Setup.Server); pragma Warnings (Off, PolyORB.Setup.Server); with PolyORB.Setup.Tasking.No_Tasking; pragma Warnings (Off, PolyORB.Setup.Tasking.No_Tasking); pragma Elaborate_All (PolyORB.Setup.Tasking.No_Tasking); package body PolyORB.Setup.No_Tasking_Server is end PolyORB.Setup.No_Tasking_Server; polyorb-2.8~20110207.orig/src/setup/polyorb-setup-no_tasking_server.ads0000644000175000017500000000424511750740340025373 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . S E T U P . N O _ T A S K I N G _ S E R V E R -- -- -- -- S p e c -- -- -- -- Copyright (C) 2001 Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by ACT Europe. -- -- (email: sales@act-europe.fr) -- -- -- ------------------------------------------------------------------------------ -- Elaborate a complete server with no tasking. package PolyORB.Setup.No_Tasking_Server is pragma Elaborate_Body; end PolyORB.Setup.No_Tasking_Server; polyorb-2.8~20110207.orig/src/setup/polyorb-setup-tasking-full_tasking.adb.in0000644000175000017500000000571611750740340026361 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . S E T U P . T A S K I N G . F U L L _ T A S K I N G -- -- -- -- B o d y -- -- -- -- Copyright (C) 2002-2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with PolyORB.Tasking.Profiles.Full_Tasking.Threads.Annotations; pragma Unreferenced (PolyORB.Tasking.Profiles.Full_Tasking.Threads.Annotations); with PolyORB.Tasking.Profiles.Full_Tasking.Threads.Static_Priorities; pragma Unreferenced (PolyORB.Tasking.Profiles.Full_Tasking.Threads.Static_Priorities); with PolyORB.Tasking.Profiles.Full_Tasking.Threads; pragma Unreferenced (PolyORB.Tasking.Profiles.Full_Tasking.Threads); with PolyORB.Tasking.Profiles.Full_Tasking.Mutexes; pragma Unreferenced (PolyORB.Tasking.Profiles.Full_Tasking.Mutexes); with PolyORB.Tasking.Profiles.Full_Tasking.Condition_Variables; pragma Unreferenced (PolyORB.Tasking.Profiles.Full_Tasking.Condition_Variables); @ADA_ATC@with PolyORB.Tasking.Profiles.Full_Tasking_ATC.Abortables; @ADA_ATC@pragma Unreferenced (PolyORB.Tasking.Profiles.Full_Tasking_ATC.Abortables); package body PolyORB.Setup.Tasking.Full_Tasking is end PolyORB.Setup.Tasking.Full_Tasking; polyorb-2.8~20110207.orig/src/setup/polyorb-setup-server.adb.in0000644000175000017500000000513711750740340023544 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . S E T U P . S E R V E R -- -- -- -- B o d y -- -- -- -- Copyright (C) 2001-2007, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- Set up a simple ORB to act as a server -- The user must take care of also setting up a tasking runtime and a -- ORB tasking policy. pragma Style_Checks ("M2048"); -- Configure substitutions may yield long lines -- @configure_input@ with PolyORB.Setup.Base; pragma Warnings (Off, PolyORB.Setup.Base); pragma Elaborate_All (PolyORB.Setup.Base); with PolyORB.Setup.OA.Basic_POA; pragma Warnings (Off, PolyORB.Setup.OA.Basic_POA); pragma Elaborate_All (PolyORB.Setup.OA.Basic_POA); -- Personalities setup @PROTO_SERVER_WITHS@ package body PolyORB.Setup.Server is end PolyORB.Setup.Server; polyorb-2.8~20110207.orig/src/setup/polyorb-setup-tasking-no_tasking.ads0000644000175000017500000000423111750740340025436 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . S E T U P . T A S K I N G . N O _ T A S K I N G -- -- -- -- S p e c -- -- -- -- Copyright (C) 2002-2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- Set up a "no tasking" profile. package PolyORB.Setup.Tasking.No_Tasking is pragma Elaborate_Body; end PolyORB.Setup.Tasking.No_Tasking; polyorb-2.8~20110207.orig/src/setup/polyorb-setup-client.adb0000644000175000017500000000002011750740340023071 0ustar xavierxavierpragma No_Body; polyorb-2.8~20110207.orig/src/setup/polyorb-setup-no_tasking_client.ads0000644000175000017500000000425411750740340025343 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . S E T U P . N O _ T A S K I N G _ C L I E N T -- -- -- -- S p e c -- -- -- -- Copyright (C) 2002-2009, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- Complete setup for a client partition without tasking package PolyORB.Setup.No_Tasking_Client is pragma Elaborate_Body; end PolyORB.Setup.No_Tasking_Client; polyorb-2.8~20110207.orig/src/setup/polyorb-setup-thread_pool_client.adb0000644000175000017500000000522611750740340025466 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . S E T U P . T H R E A D _ P O O L _ C L I E N T -- -- -- -- B o d y -- -- -- -- Copyright (C) 2009, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with PolyORB.Setup.Client_Base; pragma Warnings (Off, PolyORB.Setup.Client_Base); pragma Elaborate_All (PolyORB.Setup.Client_Base); with PolyORB.ORB.Thread_Pool; pragma Elaborate_All (PolyORB.ORB.Thread_Pool); pragma Warnings (Off, PolyORB.ORB.Thread_Pool); with PolyORB.Setup.Tasking.Full_Tasking; pragma Elaborate_All (PolyORB.Setup.Tasking.Full_Tasking); pragma Warnings (Off, PolyORB.Setup.Tasking.Full_Tasking); with PolyORB.ORB_Controller.Workers; pragma Warnings (Off, PolyORB.ORB_Controller.Workers); pragma Elaborate_All (PolyORB.ORB_Controller.Workers); package body PolyORB.Setup.Thread_Pool_Client is end PolyORB.Setup.Thread_Pool_Client; polyorb-2.8~20110207.orig/src/setup/polyorb-setup-base.adb.in0000644000175000017500000000455011750740340023146 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . S E T U P . B A S E -- -- -- -- B o d y -- -- -- -- Copyright (C) 2008, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ pragma Style_Checks ("M2048"); -- Configure substitutions may yield long lines -- @configure_input@ with PolyORB.Setup.Common_Base; pragma Warnings (Off, PolyORB.Setup.Common_Base); pragma Elaborate_All (PolyORB.Setup.Common_Base); -- Platform-specific dependencies @PLATFORM_BASE_WITHS@ package body PolyORB.Setup.Base is end PolyORB.Setup.Base; polyorb-2.8~20110207.orig/src/setup/polyorb-setup-thread_per_request_server.ads0000644000175000017500000000433011750740340027117 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- POLYORB.SETUP.THREAD_PER_REQUEST_SERVER -- -- -- -- S p e c -- -- -- -- Copyright (C) 2002-2004 Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by ACT Europe. -- -- (email: sales@act-europe.fr) -- -- -- ------------------------------------------------------------------------------ -- Elaborate a complete server with the ``thread-per-request'' -- tasking policy. package PolyORB.Setup.Thread_Per_Request_Server is pragma Elaborate_Body; end PolyORB.Setup.Thread_Per_Request_Server; polyorb-2.8~20110207.orig/src/setup/polyorb-setup-ravenscar_tp_server.ads0000644000175000017500000000434711750740340025731 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . S E T U P . R A V E N S C A R _ T P _ S E R V E R -- -- -- -- S p e c -- -- -- -- Copyright (C) 2002 Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by ACT Europe. -- -- (email: sales@act-europe.fr) -- -- -- ------------------------------------------------------------------------------ -- Elaborate a complete server with the ``thread pool'' -- tasking policy and the Ravenscar tasking profile. package PolyORB.Setup.Ravenscar_TP_Server is pragma Elaborate_Body; end PolyORB.Setup.Ravenscar_TP_Server; polyorb-2.8~20110207.orig/src/setup/polyorb-setup-thread_per_session_server.adb0000644000175000017500000000543711750740340027102 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- POLYORB.SETUP.THREAD_PER_SESSION_SERVER -- -- -- -- B o d y -- -- -- -- Copyright (C) 2001-2005 Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- Elaborate a complete server with the ``thread-per-session'' ORB -- tasking policy and a full tasking runtime. with PolyORB.ORB.Thread_Per_Session; pragma Elaborate_All (PolyORB.ORB.Thread_Per_Session); pragma Warnings (Off, PolyORB.ORB.Thread_Per_Session); with PolyORB.ORB_Controller.Workers; pragma Warnings (Off, PolyORB.ORB_Controller.Workers); pragma Elaborate_All (PolyORB.ORB_Controller.Workers); with PolyORB.Setup.Server; pragma Elaborate_All (PolyORB.Setup.Server); pragma Warnings (Off, PolyORB.Setup.Server); with PolyORB.Setup.Tasking.Full_Tasking; pragma Elaborate_All (PolyORB.Setup.Tasking.Full_Tasking); pragma Warnings (Off, PolyORB.Setup.Tasking.Full_Tasking); package body PolyORB.Setup.Thread_Per_Session_Server is end PolyORB.Setup.Thread_Per_Session_Server; polyorb-2.8~20110207.orig/src/setup/polyorb-setup-default_parameters.ads0000644000175000017500000000416511750740340025521 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . S E T U P . D E F A U L T _ P A R A M E T E R S -- -- -- -- S p e c -- -- -- -- Copyright (C) 2005-2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ package PolyORB.Setup.Default_Parameters is pragma Elaborate_Body; end PolyORB.Setup.Default_Parameters; polyorb-2.8~20110207.orig/src/setup/polyorb-setup-tasking-no_tasking.adb0000644000175000017500000000562711750740340025427 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . S E T U P . T A S K I N G . N O _ T A S K I N G -- -- -- -- B o d y -- -- -- -- Copyright (C) 2002-2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with PolyORB.Tasking.Profiles.No_Tasking.Threads.Annotations; pragma Elaborate_All (PolyORB.Tasking.Profiles.No_Tasking.Threads.Annotations); pragma Warnings (Off, PolyORB.Tasking.Profiles.No_Tasking.Threads.Annotations); with PolyORB.Tasking.Profiles.No_Tasking.Threads; pragma Elaborate_All (PolyORB.Tasking.Profiles.No_Tasking.Threads); pragma Warnings (Off, PolyORB.Tasking.Profiles.No_Tasking.Threads); with PolyORB.Tasking.Profiles.No_Tasking.Mutexes; pragma Elaborate_All (PolyORB.Tasking.Profiles.No_Tasking.Mutexes); pragma Warnings (Off, PolyORB.Tasking.Profiles.No_Tasking.Mutexes); with PolyORB.Tasking.Profiles.No_Tasking.Condition_Variables; pragma Elaborate_All (PolyORB.Tasking.Profiles.No_Tasking.Condition_Variables); pragma Warnings (Off, PolyORB.Tasking.Profiles.No_Tasking.Condition_Variables); package body PolyORB.Setup.Tasking.No_Tasking is end PolyORB.Setup.Tasking.No_Tasking; polyorb-2.8~20110207.orig/src/setup/polyorb-setup-thread_pool_server.ads0000644000175000017500000000430311750740340025532 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . S E T U P . T H R E A D _ P O O L _ S E R V E R -- -- -- -- S p e c -- -- -- -- Copyright (C) 2001-2002 Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by ACT Europe. -- -- (email: sales@act-europe.fr) -- -- -- ------------------------------------------------------------------------------ -- Elaborate a complete server with the ``thread pool'' -- tasking policy. package PolyORB.Setup.Thread_Pool_Server is pragma Elaborate_Body; end PolyORB.Setup.Thread_Pool_Server; polyorb-2.8~20110207.orig/src/polyorb-tasking-profiles-no_tasking-threads.adb0000644000175000017500000001704711750740340026401 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- POLYORB.TASKING.PROFILES.NO_TASKING.THREADS -- -- -- -- B o d y -- -- -- -- Copyright (C) 2002-2011, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- Implementation of Threads under the No_Tasking profile with Ada.Calendar; with Ada.Unchecked_Conversion; with PolyORB.Initialization; with PolyORB.Utils.Strings; package body PolyORB.Tasking.Profiles.No_Tasking.Threads is -- For the no-tasking profile, there is only one valid Thread_Id, -- Main_Thread_Id, which is arbitrarily defined but must be different from -- Null_Thread_Id. function To_Thread_Id is new Ada.Unchecked_Conversion (System.Address, PTT.Thread_Id); Main_Thread_Id : constant PTT.Thread_Id := To_Thread_Id (The_Thread_Factory'Address); --------------------------- -- Get_Current_Thread_Id -- --------------------------- function Get_Current_Thread_Id (TF : access No_Tasking_Thread_Factory_Type) return PTT.Thread_Id is pragma Warnings (Off); pragma Unreferenced (TF); pragma Warnings (On); begin return Main_Thread_Id; end Get_Current_Thread_Id; ------------------- -- Get_Thread_Id -- ------------------- function Get_Thread_Id (T : access No_Tasking_Thread_Type) return PTT.Thread_Id is pragma Warnings (Off); pragma Unreferenced (T); pragma Warnings (On); begin return Main_Thread_Id; end Get_Thread_Id; --------------------- -- Thread_Id_Image -- --------------------- function Thread_Id_Image (TF : access No_Tasking_Thread_Factory_Type; TID : PTT.Thread_Id) return String is use PTT; pragma Warnings (Off); pragma Unreferenced (TF); pragma Warnings (On); begin if TID = Null_Thread_Id then return ""; else return "main_task"; end if; end Thread_Id_Image; ----------------- -- Run_In_Task -- ----------------- function Run_In_Task (TF : access No_Tasking_Thread_Factory_Type; Name : String := ""; Default_Priority : System.Any_Priority := System.Default_Priority; Storage_Size : Natural := 0; R : PTT.Runnable_Access) return PTT.Thread_Access is pragma Warnings (Off); pragma Unreferenced (TF); pragma Unreferenced (Name); pragma Unreferenced (Default_Priority); pragma Unreferenced (Storage_Size); pragma Unreferenced (R); pragma Warnings (On); begin raise Tasking_Error; return null; end Run_In_Task; function Run_In_Task (TF : access No_Tasking_Thread_Factory_Type; Name : String := ""; Default_Priority : System.Any_Priority := System.Default_Priority; Storage_Size : Natural := 0; P : PTT.Parameterless_Procedure) return PTT.Thread_Access is pragma Warnings (Off); pragma Unreferenced (TF); pragma Unreferenced (Name); pragma Unreferenced (Default_Priority); pragma Unreferenced (Storage_Size); pragma Unreferenced (P); pragma Warnings (On); begin raise Tasking_Error; return null; end Run_In_Task; ------------------ -- Set_Priority -- ------------------ procedure Set_Priority (TF : access No_Tasking_Thread_Factory_Type; T : PTT.Thread_Id; P : System.Any_Priority) is pragma Warnings (Off); pragma Unreferenced (TF); pragma Unreferenced (T); pragma Unreferenced (P); pragma Warnings (On); begin raise Tasking_Error; end Set_Priority; ------------------ -- Get_Priority -- ------------------ function Get_Priority (TF : access No_Tasking_Thread_Factory_Type; T : PTT.Thread_Id) return System.Any_Priority is pragma Warnings (Off); pragma Unreferenced (TF); pragma Unreferenced (T); pragma Warnings (On); begin raise Tasking_Error; return 0; end Get_Priority; -------------------- -- Relative_Delay -- -------------------- procedure Relative_Delay (TF : access No_Tasking_Thread_Factory_Type; D : Duration) is pragma Unreferenced (TF); begin delay D; end Relative_Delay; ----------------- -- Awake_Count -- ----------------- function Awake_Count (TF : access No_Tasking_Thread_Factory_Type) return Natural is pragma Unreferenced (TF); begin -- With the no tasking profile we can assume that there is always one -- awaken task if this function is called. return 1; end Awake_Count; ----------------------- -- Independent_Count -- ----------------------- function Independent_Count (TF : access No_Tasking_Thread_Factory_Type) return Natural is pragma Unreferenced (TF); begin return 0; end Independent_Count; ---------------- -- Initialize -- ---------------- procedure Initialize; procedure Initialize is use Ada.Calendar; Epoch : constant Time := Time_Of (1970, 1, 1); begin PTT.Node_Boot_Time := Clock - Epoch; PTT.Register_Thread_Factory (PTT.Thread_Factory_Access (The_Thread_Factory)); end Initialize; use PolyORB.Initialization; use PolyORB.Initialization.String_Lists; use PolyORB.Utils.Strings; begin Register_Module (Module_Info' (Name => +"tasking.profiles.no_tasking.threads", Conflicts => Empty, Depends => Empty, Provides => +"tasking.threads", Implicit => False, Init => Initialize'Access, Shutdown => null)); end PolyORB.Tasking.Profiles.No_Tasking.Threads; polyorb-2.8~20110207.orig/src/polyorb-tasking-threads.adb0000644000175000017500000001143311750740340022417 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . T A S K I N G . T H R E A D S -- -- -- -- B o d y -- -- -- -- Copyright (C) 2002-2011, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ package body PolyORB.Tasking.Threads is My_Thread_Factory : Thread_Factory_Access; -- Thread_Factory of the chosen profile. Initialised : Boolean := False; ----------------- -- Awake_Count -- ----------------- function Awake_Count return Natural is begin return Awake_Count (My_Thread_Factory); end Awake_Count; ----------------- -- Create_Task -- ----------------- procedure Create_Task (Main : Parameterless_Procedure) is T : constant Thread_Access := Run_In_Task (TF => My_Thread_Factory, P => Main); pragma Warnings (Off); pragma Unreferenced (T); pragma Warnings (On); begin null; end Create_Task; ------------------ -- Current_Task -- ------------------ function Current_Task return Thread_Id is begin return Get_Current_Thread_Id (My_Thread_Factory); end Current_Task; ------------------------ -- Get_Thread_Factory -- ------------------------ function Get_Thread_Factory return Thread_Factory_Access is begin pragma Assert (Initialised); return My_Thread_Factory; end Get_Thread_Factory; ----------- -- Image -- ----------- function Image (TID : Thread_Id) return String is begin return Thread_Id_Image (My_Thread_Factory, TID); end Image; ----------------------- -- Independent_Count -- ----------------------- function Independent_Count return Natural is begin return Independent_Count (My_Thread_Factory); end Independent_Count; ----------------------------- -- Register_Thread_Factory -- ----------------------------- procedure Register_Thread_Factory (TF : Thread_Factory_Access) is begin pragma Assert (not Initialised); if not Initialised then My_Thread_Factory := TF; Initialised := True; end if; end Register_Thread_Factory; -------------------- -- Relative_Delay -- -------------------- procedure Relative_Delay (D : Duration) is begin Relative_Delay (My_Thread_Factory, D); end Relative_Delay; -------------------- -- Null_Thread_Id -- -------------------- function Null_Thread_Id return Thread_Id is begin return Thread_Id (System.Null_Address); end Null_Thread_Id; ---------------- -- To_Address -- ---------------- function To_Address (TID : Thread_Id) return System.Address is begin return System.Address (TID); end To_Address; ------------------ -- To_Thread_Id -- ------------------ function To_Thread_Id (A : System.Address) return Thread_Id is begin return Thread_Id (A); end To_Thread_Id; end PolyORB.Tasking.Threads; polyorb-2.8~20110207.orig/src/polyorb-any-objref.adb0000644000175000017500000000565611750740340021375 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . A N Y . O B J R E F -- -- -- -- B o d y -- -- -- -- Copyright (C) 2001-2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- Any's that contain object references. package body PolyORB.Any.ObjRef is -- 'Object Reference' content package Elementary_Any_Ref is new Elementary_Any (References.Ref, Tk_Objref); procedure Set_Any_Value (X : References.Ref; C : in out Any_Container'Class) renames Elementary_Any_Ref.Set_Any_Value; function To_Any_Instance is new To_Any_G (References.Ref, TypeCode.TC_Object, Set_Any_Value); function To_Any (X : References.Ref) return Any renames To_Any_Instance; function From_Any (A : Any) return References.Ref renames Elementary_Any_Ref.From_Any; function From_Any (C : Any_Container'Class) return References.Ref renames Elementary_Any_Ref.From_Any; --------- -- Wrap -- ---------- function Wrap (X : not null access References.Ref) return Content'Class renames Elementary_Any_Ref.Wrap; end PolyORB.Any.ObjRef; polyorb-2.8~20110207.orig/src/polyorb-poa_policies-lifespan_policy-transient.adb0000644000175000017500000001043311750740340027157 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- POLYORB.POA_POLICIES.LIFESPAN_POLICY.TRANSIENT -- -- -- -- B o d y -- -- -- -- Copyright (C) 2001-2007, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with PolyORB.POA; package body PolyORB.POA_Policies.Lifespan_Policy.Transient is ------------ -- Create -- ------------ function Create return Transient_Policy_Access is begin return new Transient_Policy; end Create; ------------------------- -- Check_Compatibility -- ------------------------- procedure Check_Compatibility (Self : Transient_Policy; Other_Policies : AllPolicies; Error : in out PolyORB.Errors.Error_Container) is pragma Warnings (Off); pragma Unreferenced (Self); pragma Unreferenced (Other_Policies); pragma Unreferenced (Error); pragma Warnings (On); begin null; -- No rule to test. end Check_Compatibility; --------------- -- Policy_Id -- --------------- function Policy_Id (Self : Transient_Policy) return String is pragma Warnings (Off); pragma Unreferenced (Self); pragma Warnings (On); begin return "LIFESPAN_POLICY.TRANSIENT"; end Policy_Id; ------------------------- -- Get_Lifespan_Cookie -- ------------------------- function Get_Lifespan_Cookie (Self : Transient_Policy; OA : PolyORB.POA_Types.Obj_Adapter_Access) return Lifespan_Cookie is pragma Warnings (Off); pragma Unreferenced (Self); pragma Warnings (On); begin return Lifespan_Cookie (PolyORB.POA.Obj_Adapter_Access (OA).Boot_Time); end Get_Lifespan_Cookie; --------------------- -- Ensure_Lifespan -- --------------------- procedure Ensure_Lifespan (Self : Transient_Policy; OA : PolyORB.POA_Types.Obj_Adapter_Access; U_Oid : Unmarshalled_Oid; Error : in out PolyORB.Errors.Error_Container) is pragma Warnings (Off); pragma Unreferenced (Self); pragma Warnings (On); use PolyORB.Errors; begin if U_Oid.Persistency_Flag /= PolyORB.POA.Obj_Adapter_Access (OA).Boot_Time then Throw (Error, Object_Not_Exist_E, System_Exception_Members'(Minor => 0, Completed => Completed_No)); end if; end Ensure_Lifespan; end PolyORB.POA_Policies.Lifespan_Policy.Transient; polyorb-2.8~20110207.orig/src/polyorb-setup-proxies_poa.ads0000644000175000017500000000431411750740340023036 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . S E T U P . P R O X I E S _ P O A -- -- -- -- S p e c -- -- -- -- Copyright (C) 2002-2005 Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with PolyORB.Errors; with PolyORB.POA; procedure PolyORB.Setup.Proxies_POA (Root_POA_Object : PolyORB.POA.Obj_Adapter_Access; Error : in out PolyORB.Errors.Error_Container); polyorb-2.8~20110207.orig/src/polyorb-orb_controller.adb0000644000175000017500000004375211750740340022365 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . O R B _ C O N T R O L L E R -- -- -- -- B o d y -- -- -- -- Copyright (C) 2004-2011, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with PolyORB.Constants; with PolyORB.ORB; with PolyORB.Parameters; package body PolyORB.ORB_Controller is use PolyORB.Task_Info; use PolyORB.Tasking.Mutexes; use PolyORB.Tasking.Threads; My_Factory : ORB_Controller_Factory_Access; type Tracked_Mutex is new Mutex_Type with record Mutex : Mutex_Access; Owner : Thread_Id := Null_Thread_Id; end record; overriding procedure Enter (M : access Tracked_Mutex); overriding procedure Leave (M : access Tracked_Mutex); ------------ -- Create -- ------------ procedure Create (O : out ORB_Controller_Access) is begin O := Create (My_Factory.all); end Create; ----------- -- Enter -- ----------- overriding procedure Enter (M : access Tracked_Mutex) is Self : constant Thread_Id := Current_Task; begin pragma Abort_Defer; pragma Debug (C1, O1 ("Enter Tracked_Mutex: " & Image (Self) & ", current owner " & Image (M.Owner))); if M.Owner = Self then O1 ("attempt to re-enter critical section", Warning); else M.Mutex.Enter; M.Owner := Self; end if; end Enter; ----------- -- Leave -- ----------- overriding procedure Leave (M : access Tracked_Mutex) is begin pragma Abort_Defer; pragma Debug (C1, O1 ("Leave Tracked_Mutex " & Image (Current_Task))); M.Owner := Null_Thread_Id; M.Mutex.Leave; end Leave; -------------------- -- Terminate_Task -- -------------------- procedure Terminate_Task (O : access ORB_Controller; TI : PTI.Task_Info_Access) is begin -- If terminating an idle or blocked task, notify ourselves case State (TI.all) is when Idle => Notify_Event (ORB_Controller'Class (O.all)'Access, Event'(Kind => Idle_Awake, Awakened_Task => TI)); when Blocked => Notify_Event (ORB_Controller'Class (O.all)'Access, Event'(Kind => End_Of_Check_Sources, On_Monitor => Selector (TI.all))); when others => null; end case; Set_State_Terminated (O.Summary, TI.all); end Terminate_Task; -------------------------------- -- Enter_ORB_Critical_Section -- -------------------------------- procedure Enter_ORB_Critical_Section (O : access ORB_Controller) is begin O.ORB_Lock.Enter; end Enter_ORB_Critical_Section; ------------------ -- Get_Monitors -- ------------------ function Get_Monitors (O : access ORB_Controller) return Monitor_Array is use type PAE.Asynch_Ev_Monitor_Access; Result : Monitor_Array (1 .. O.AEM_Infos'Length); Last : Natural := 0; begin for J in O.AEM_Infos'Range loop if O.AEM_Infos (J).Monitor /= null then Last := Last + 1; Result (Last) := O.AEM_Infos (J).Monitor; end if; end loop; return Result (1 .. Last); end Get_Monitors; --------------------- -- Get_Pending_Job -- --------------------- function Get_Pending_Job (O : access ORB_Controller) return PJ.Job_Access is begin if not Has_Pending_Job (O) then return null; end if; return PJ.Fetch_Job (O.Job_Queue); end Get_Pending_Job; --------------------- -- Get_Tasks_Count -- --------------------- function Get_Tasks_Count (OC : ORB_Controller; Kind : PTI.Any_Task_Kind := PTI.Any; State : PTI.Any_Task_State := PTI.Any) return Natural is begin return Get_Count (OC.Summary, Kind, State); end Get_Tasks_Count; --------------------- -- Has_Pending_Job -- --------------------- function Has_Pending_Job (O : access ORB_Controller) return Boolean is begin return not PJ.Is_Empty (O.Job_Queue); end Has_Pending_Job; ----------- -- Index -- ----------- function Index (O : ORB_Controller; M : PAE.Asynch_Ev_Monitor_Access) return Natural is use type PAE.Asynch_Ev_Monitor_Access; begin for J in O.AEM_Infos'Range loop if O.AEM_Infos (J).Monitor = M then return J; end if; end loop; return 0; end Index; ---------------- -- Initialize -- ---------------- procedure Initialize (OC : in out ORB_Controller) is use PolyORB.Parameters; Polling_Interval : constant Duration := Get_Conf ("orb_controller", "polyorb.orb_controller.polling_interval", PolyORB.Constants.Forever); Polling_Timeout : constant Duration := Get_Conf ("orb_controller", "polyorb.orb_controller.polling_timeout", PolyORB.Constants.Forever); begin OC.ORB_Lock := new Tracked_Mutex; PTM.Create (Tracked_Mutex (OC.ORB_Lock.all).Mutex); for J in OC.AEM_Infos'Range loop PTCV.Create (OC.AEM_Infos (J).Polling_Completed); end loop; OC.Idle_Tasks := new Idle_Tasks_Manager; OC.Job_Queue := PolyORB.Jobs.Create_Queue; for J in OC.AEM_Infos'Range loop OC.AEM_Infos (J).Polling_Interval := Polling_Interval; OC.AEM_Infos (J).Polling_Timeout := Polling_Timeout; end loop; end Initialize; --------------------------- -- Is_Locally_Terminated -- --------------------------- function Is_Locally_Terminated (O : access ORB_Controller; Expected_Running_Tasks : Natural) return Boolean is Result : Boolean; begin pragma Debug (C1, O1 ("Is_Locally_Terminated (exp" & Expected_Running_Tasks'Img & "R): " & Status (O.all))); if Get_Count (O.Summary, Kind => Transient) > 0 or else Get_Count (O.Summary, State => Running) > Expected_Running_Tasks or else Get_Count (O.Summary, State => Unscheduled) > 0 or else Has_Pending_Job (O) then Result := False; else Result := (Awake_Count - Independent_Count - Get_Count (O.Summary, State => Idle) - Get_Count (O.Summary, State => Blocked) = Expected_Running_Tasks); end if; pragma Debug (C1, O1 ("-> " & Result'Img)); return Result; end Is_Locally_Terminated; --------------- -- Is_Upcall -- --------------- function Is_Upcall (J : PJ.Job'Class) return Boolean is begin -- Request_Jobs are queued on the general ORB controller job queue only -- on the server side, so we know that if we have a Request_Job here, -- it must be an upcall. return J in ORB.Request_Job; end Is_Upcall; -------------------------------- -- Leave_ORB_Critical_Section -- -------------------------------- procedure Leave_ORB_Critical_Section (O : access ORB_Controller) is begin O.ORB_Lock.Leave; end Leave_ORB_Critical_Section; ----------------------- -- Need_Polling_Task -- ----------------------- function Need_Polling_Task (O : access ORB_Controller) return Natural is use type PAE.Asynch_Ev_Monitor_Access; function Needs_Polling (Index : Natural) return Boolean; -- True when polling is required for the AEM at the given index ------------------- -- Needs_Polling -- ------------------- function Needs_Polling (Index : Natural) return Boolean is begin return True and then O.AEM_Infos (Index).Monitor /= null and then PAE.Has_Sources (O.AEM_Infos (Index).Monitor.all) and then O.AEM_Infos (Index).Polling_Abort_Counter = 0 and then O.AEM_Infos (Index).TI = null; end Needs_Polling; begin -- To promote fairness among AEM, we retain the value of the last -- last monitored AEM, and test it iff no other AEM need polling. -- Check whether any AEM but the last monitored needs a polling task for J in O.AEM_Infos'Range loop if J /= O.Last_Monitored_AEM and then Needs_Polling (J) then O.Last_Monitored_AEM := J; return J; end if; end loop; -- Check whether the last monitored AEM needs a polling task if Needs_Polling (O.Last_Monitored_AEM) then return O.Last_Monitored_AEM; end if; -- No AEM needs polling return 0; end Need_Polling_Task; ---------------------------- -- Note_Task_Unregistered -- ---------------------------- procedure Note_Task_Unregistered (O : access ORB_Controller'Class) is use PTCV; begin if Get_Count (O.Summary) = 0 and then O.Shutdown and then O.Shutdown_CV /= null then Broadcast (O.Shutdown_CV); end if; end Note_Task_Unregistered; ------------------------------------- -- Register_ORB_Controller_Factory -- ------------------------------------- procedure Register_ORB_Controller_Factory (OCF : ORB_Controller_Factory_Access) is begin pragma Assert (My_Factory = null); My_Factory := OCF; end Register_ORB_Controller_Factory; ------------------- -- Register_Task -- ------------------- procedure Register_Task (O : access ORB_Controller; TI : PTI.Task_Info_Access) is begin pragma Debug (C1, O1 ("Register_Task: enter")); pragma Assert (State (TI.all) = Unscheduled); Task_Created (O.Summary, TI.all); Notify_Event (ORB_Controller'Class (O.all)'Access, Event'(Kind => Task_Registered, Registered_Task => TI)); pragma Debug (C2, O2 (Status (O.all))); pragma Debug (C1, O1 ("Register_Task: leave")); end Register_Task; --------------------- -- Reschedule_Task -- --------------------- procedure Reschedule_Task (O : access ORB_Controller; TI : PTI.Task_Info_Access) is use type PAE.Asynch_Ev_Monitor_Access; begin case State (TI.all) is when Running => -- Let the task complete its current job null; when Blocked => -- Abort wait on AEM declare Sel : PAE.Asynch_Ev_Monitor_Access renames Selector (TI.all); begin pragma Debug (C1, O1 ("About to abort block")); pragma Assert (Sel /= null); PAE.Abort_Check_Sources (Sel.all); pragma Debug (C1, O1 ("Aborted.")); end; when Idle => -- Awake task pragma Debug (C1, O1 ("Signal idle task")); Awake_Idle_Task (O.Idle_Tasks, TI); when Terminated | Unscheduled => -- Really should not happen raise Program_Error; end case; end Reschedule_Task; ------------ -- Status -- ------------ function Status (O : ORB_Controller) return String is function Counters_For_State (S : Any_Task_State) return String; -- Return the task counters for state S function Counters_For_State (S : Any_Task_State) return String is State_Name : constant String := S'Img; function Counter_For_Kind (K : Task_Kind) return String; -- Return the task counter for kind K and state S ---------------------- -- Counter_For_Kind -- ---------------------- function Counter_For_Kind (K : Task_Kind) return String is Kind_Name : constant String := K'Img; Count : constant String := Natural'Image (Get_Count (O.Summary, K, S)); begin pragma Assert (Count (1) = ' '); return Count (2 .. Count'Last) & Kind_Name (1); end Counter_For_Kind; begin return State_Name (1) & ": " & Counter_For_Kind (Permanent) & "/" & Counter_For_Kind (Transient); end Counters_For_State; begin return Counters_For_State (Any) & " " & Counters_For_State (Unscheduled) & " " & Counters_For_State (Running) & " " & Counters_For_State (Blocked) & " " & Counters_For_State (Idle) & " " & Counters_For_State (Terminated) & " | PJ:" & Natural'Image (PJ.Length (O.Job_Queue)) & " | Tra:" & Natural'Image (Get_Count (O.Summary, Kind => Transient)) & " Awk:" & Natural'Image (Awake_Count) & " Ind:" & Natural'Image (Independent_Count); end Status; ------------------- -- Shutting_Down -- ------------------- function Shutting_Down (O : ORB_Controller) return Boolean is begin return O.Shutdown; end Shutting_Down; --------------------- -- Unregister_Task -- --------------------- procedure Unregister_Task (O : access ORB_Controller; TI : PTI.Task_Info_Access) is begin pragma Debug (C1, O1 ("Unregister_Task: enter")); pragma Assert (State (TI.all) = Terminated); Task_Removed (O.Summary, TI.all); Notify_Event (ORB_Controller'Class (O.all)'Access, Event'(Kind => Task_Unregistered, Unregistered_Task => TI)); pragma Debug (C2, O2 (Status (O.all))); pragma Debug (C1, O1 ("Unregister_Task: leave")); end Unregister_Task; --------------------------- -- Try_Allocate_One_Task -- --------------------------- procedure Try_Allocate_One_Task (O : access ORB_Controller; Allow_Transient : Boolean) is Requested_Kind : Any_Task_Kind; begin pragma Debug (C1, O1 ("Try_Allocate_One_Task: enter")); if Allow_Transient then Requested_Kind := Any; else Requested_Kind := Permanent; end if; if Get_Count (O.Summary, Kind => Requested_Kind, State => Unscheduled) > 0 then -- Some tasks are not scheduled. We assume one of them will be -- allocated to handle current event. -- ??? Can this really happen? -- ??? If so, case of Allow_Transient = False and the only -- unscheduled tasks are transient? pragma Debug (C1, O1 ("Unassigned task will handle event")); null; elsif Get_Count (O.Summary, Kind => Requested_Kind, State => Idle) > 0 and then Awake_One_Idle_Task (O.Idle_Tasks, Allow_Transient) then -- An idle task was awakened -- If we awaken a transient task here, do we guarantee that it -- won't unexpectedly terminate when it reschedules (we should -- really post some token to the awakened task so that it know it -- needs to stay within the ORB for a bit)??? null; elsif Get_Count (O.Summary, Kind => Permanent, State => Running) > 0 then -- A permanent task is running: it will pick up the queued job next -- time it reschedules. null; elsif Get_Count (O.Summary, Kind => Requested_Kind, State => Blocked) > 0 then -- Find appropriate task and force it to reschedule -- If we unblock a transient task here, do we guarantee that it -- won't unexpectedly terminate when it reschedules (we should -- really post some token to the awakened task so that it know it -- needs to stay within the ORB for a bit)??? for J in O.AEM_Infos'Range loop if O.AEM_Infos (J).TI /= null and then Kind_Match (O.AEM_Infos (J).TI.all, Requested_Kind) then Reschedule_Task (O, O.AEM_Infos (J).TI); exit; end if; end loop; else pragma Debug (C1, O1 ("Try_Allocate_One_Task: no task available, deadlock?")); null; end if; pragma Debug (C1, O1 ("Try_Allocate_One_Task: end")); end Try_Allocate_One_Task; ------------------------- -- Wait_For_Completion -- ------------------------- procedure Wait_For_Completion (O : access ORB_Controller) is use PTCV; begin pragma Assert (O.Shutdown); if O.Shutdown_CV = null then Create (O.Shutdown_CV); end if; while Get_Count (O.Summary) > 0 loop Wait (O.Shutdown_CV, O.ORB_Lock); end loop; end Wait_For_Completion; end PolyORB.ORB_Controller; polyorb-2.8~20110207.orig/src/polyorb-poa_policies-thread_policy-orb_ctrl.adb0000644000175000017500000000663411750740340026434 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- POLYORB.POA_POLICIES.THREAD_POLICY.ORB_CTRL -- -- -- -- B o d y -- -- -- -- Copyright (C) 2001-2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- Implementation of the 'ORB Control' POA Policy. -- Under this policy, the ORB is responsible for the creation, management, -- and destruction of threads used with one or more POAs. with PolyORB.Servants; package body PolyORB.POA_Policies.Thread_Policy.ORB_Ctrl is ------------ -- Create -- ------------ function Create return ORB_Ctrl_Policy_Access is Result : constant ORB_Ctrl_Policy_Access := new ORB_Ctrl_Policy; begin ThreadPolicy (Result.all).Executor := new ORB_Ctrl_Executor; return Result; end Create; --------------- -- Policy_Id -- --------------- function Policy_Id (Self : ORB_Ctrl_Policy) return String is pragma Warnings (Off); pragma Unreferenced (Self); pragma Warnings (On); begin return "THREAD_POLICY.ORB_CTRL"; end Policy_Id; ------------------------- -- Check_Compatibility -- ------------------------- procedure Check_Compatibility (Self : ORB_Ctrl_Policy; Other_Policies : AllPolicies; Error : in out PolyORB.Errors.Error_Container) is pragma Warnings (Off); pragma Unreferenced (Self); pragma Unreferenced (Other_Policies); pragma Unreferenced (Error); pragma Warnings (On); begin -- No rule to test null; end Check_Compatibility; end PolyORB.POA_Policies.Thread_Policy.ORB_Ctrl; polyorb-2.8~20110207.orig/src/polyorb-any-exceptionlist.adb0000644000175000017500000001227411750740340023012 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . A N Y . E X C E P T I O N L I S T -- -- -- -- B o d y -- -- -- -- Copyright (C) 2002-2008, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with PolyORB.Log; package body PolyORB.Any.ExceptionList is use PolyORB.Log; use PolyORB.Types; use Exception_Lists; package L is new PolyORB.Log.Facility_Log ("polyorb.any.exceptionlist"); procedure O (Message : Standard.String; Level : Log_Level := Debug) renames L.Output; function C (Level : Log_Level := Debug) return Boolean renames L.Enabled; --------------- -- Get_Count -- --------------- function Get_Count (Self : Ref) return PolyORB.Types.Unsigned_Long is Obj : constant Object_Ptr := Object_Ptr (Entity_Of (Self)); begin if Obj = null then return 0; end if; return PolyORB.Types.Unsigned_Long (Exception_Lists.Length (Obj.List)); end Get_Count; --------- -- Add -- --------- procedure Add (Self : Ref; Exc : PolyORB.Any.TypeCode.Local_Ref) is begin Exception_Lists.Append (Object_Ptr (Entity_Of (Self)).List, Exc); end Add; ---------- -- Item -- ---------- function Item (Self : Ref; Index : PolyORB.Types.Unsigned_Long) return TypeCode.Local_Ref is Obj : constant Object_Ptr := Object_Ptr (Entity_Of (Self)); It : Iterator := First (Obj.List); Counter : PolyORB.Types.Unsigned_Long := 1; begin while not Last (It) loop exit when Counter = Index; Counter := Counter + 1; Next (It); end loop; return Value (It).all; end Item; ------------ -- Remove -- ------------ procedure Remove (Self : Ref; Index : PolyORB.Types.Unsigned_Long) is Obj : constant Object_Ptr := Object_Ptr (Entity_Of (Self)); It : Iterator := First (Obj.List); Counter : PolyORB.Types.Unsigned_Long := 1; begin while not Last (It) loop exit when Counter = Index; Counter := Counter + 1; Next (It); end loop; Remove (Obj.List, It); end Remove; ----------------- -- Create_List -- ----------------- procedure Create_List (Self : out Ref) is begin Set (Self, PolyORB.Smart_Pointers.Entity_Ptr'(new Object)); end Create_List; ------------------------- -- Search_Exception_Id -- ------------------------- function Search_Exception_Id (Self : Ref; Name : Types.String) return Types.Unsigned_Long is Obj : constant Object_Ptr := Object_Ptr (Entity_Of (Self)); begin pragma Debug (C, O ("Search_Exception_Id : Obj.list length is " & PolyORB.Types.Unsigned_Long'Image (Get_Count (Self)))); pragma Debug (C, O ("Search_Exception_Id : Name = """ & To_Standard_String (Name) & """")); if Obj = null then pragma Debug (C, O ("Search_Exception_Id: null list.")); return 0; end if; declare It : Iterator := First (Obj.List); Counter : PolyORB.Types.Unsigned_Long := 1; begin while not Last (It) loop exit when PolyORB.Any.TypeCode.Id (Value (It).all) = RepositoryId (Name); Counter := Counter + 1; Next (It); end loop; return Counter; end; end Search_Exception_Id; end PolyORB.Any.ExceptionList; polyorb-2.8~20110207.orig/src/polyorb-errors.adb0000644000175000017500000000662711750740340020654 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . E R R O R S -- -- -- -- B o d y -- -- -- -- Copyright (C) 2005-2008, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with PolyORB.Log; package body PolyORB.Errors is use PolyORB.Log; package L is new PolyORB.Log.Facility_Log ("polyorb.errors"); procedure O (Message : Standard.String; Level : Log_Level := Debug) renames L.Output; function C (Level : Log_Level := Debug) return Boolean renames L.Enabled; ----------- -- Found -- ----------- function Found (Error : Error_Container) return Boolean is begin return Error.Kind /= No_Error; end Found; ----------- -- Throw -- ----------- procedure Throw (Error : in out Error_Container; Kind : Error_Id; Member : Exception_Members'Class) is begin if Error.Kind /= No_Error then pragma Debug (C, O ("*** Abort *** " & Error_Id'Image (Error.Kind))); Free (Error.Member); end if; Error.Kind := Kind; Error.Member := new Exception_Members'Class'(Member); pragma Debug (C, O ("*** Throw *** " & Error_Id'Image (Error.Kind))); end Throw; ----------- -- Catch -- ----------- procedure Catch (Error : in out Error_Container) is begin Error.Kind := No_Error; Free (Error.Member); end Catch; -------------- -- Is_Error -- -------------- function Is_Error (Error : Error_Container) return Boolean is begin return Error.Kind /= No_Error; end Is_Error; end PolyORB.Errors; polyorb-2.8~20110207.orig/src/polyorb-any-nvlist.adb0000644000175000017500000001221211750740340021427 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . A N Y . N V L I S T -- -- -- -- B o d y -- -- -- -- Copyright (C) 2001-2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with PolyORB.Log; package body PolyORB.Any.NVList is use PolyORB.Log; use PolyORB.Types; use Internals; package L is new PolyORB.Log.Facility_Log ("polyorb.any.nvlist"); procedure O (Message : Standard.String; Level : Log_Level := Debug) renames L.Output; function C (Level : Log_Level := Debug) return Boolean renames L.Enabled; -------------- -- Add_Item -- -------------- procedure Add_Item (Self : Ref; Item_Name : Identifier; Item : Any; Item_Flags : Flags) is begin pragma Debug (C, O ("Add_Item (4 params) : enter")); Add_Item (Self, (Name => Item_Name, Argument => Item, Arg_Modes => Item_Flags)); pragma Debug (C, O ("Add_Item (4 params) : end")); end Add_Item; procedure Add_Item (Self : Ref; Item : NamedValue) is Obj : constant Object_Ptr := Object_Ptr (Entity_Of (Self)); begin pragma Debug (C, O ("Add_Item (2 params) : enter")); NV_Lists.Append (Obj.List, Item); pragma Debug (C, O ("Add_Item (2 params) : end")); end Add_Item; -------------- -- Finalize -- -------------- procedure Finalize (X : in out Object) is begin Internals.NV_Lists.Deallocate (X.List); end Finalize; --------------- -- Get_Count -- --------------- function Get_Count (Self : Ref) return Types.Long is begin if Is_Null (Self) then return 0; else return Types.Long (NV_Lists.Length (List_Of (Self).all)); end if; end Get_Count; ------------ -- Create -- ------------ procedure Create (NVList : out Ref) is begin Set (NVList, PolyORB.Smart_Pointers.Entity_Ptr'(new Object)); end Create; ----------- -- Image -- ----------- function Image (NVList : Ref) return Standard.String is use NV_Lists; Obj : constant Object_Ptr := Object_Ptr (Entity_Of (NVList)); Result : PolyORB.Types.String := To_PolyORB_String (""); begin if Obj /= null then declare It : Iterator := First (Obj.List); begin while not Last (It) loop Result := Result & Image (Value (It).all); Next (It); if not Last (It) then Result := Result & " "; end if; end loop; return PolyORB.Types.To_Standard_String (Result); end; else return ("(null list)"); end if; end Image; -------------------------------- -- Package body for Internals -- -------------------------------- package body Internals is ------------- -- List_Of -- ------------- function List_Of (NVList : Ref) return NV_List_Access is use type PolyORB.Smart_Pointers.Entity_Ptr; Entity : constant PolyORB.Smart_Pointers.Entity_Ptr := Entity_Of (NVList); begin if Entity /= null then return Object_Ptr (Entity_Of (NVList)).List'Access; end if; return null; end List_Of; end Internals; end PolyORB.Any.NVList; polyorb-2.8~20110207.orig/src/polyorb-utils.adb0000644000175000017500000002103411750740340020465 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . U T I L S -- -- -- -- B o d y -- -- -- -- Copyright (C) 2001-2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ package body PolyORB.Utils is use Ada.Streams; ------------------------ -- Local declarations -- ------------------------ Hex : constant array (16#0# .. 16#f#) of Character := "0123456789abcdef"; Hex_Val : constant array (Character) of Integer := ('0' => 0, '1' => 1, '2' => 2, '3' => 3, '4' => 4, '5' => 5, '6' => 6, '7' => 7, '8' => 8, '9' => 9, 'A' => 10, 'a' => 10, 'B' => 11, 'b' => 11, 'C' => 12, 'c' => 12, 'D' => 13, 'd' => 13, 'E' => 14, 'e' => 14, 'F' => 15, 'f' => 15, others => -1); type Escape_Map is array (Character) of Boolean; Default_Escape_Map : constant Escape_Map := (Character'Val (0) .. Character'Val (16#1f#) | ';' | '?' | ':' | '@' | '&' | '=' | '+' | '$' | ',' | '<' | '>' | '#' | '%' | '"' | '{' | '}' | '|' | '\' | '^' | '[' | ']' | '`' => True, others => False); --------------- -- Hex_Value -- --------------- function Hex_Value (C : Character) return Integer is V : constant Integer := Hex_Val (C); begin if V = -1 then raise Constraint_Error; else return V; end if; end Hex_Value; ----------------------- -- SEA_To_Hex_String -- ----------------------- function SEA_To_Hex_String (A : Stream_Element_Array) return String is S : String (1 .. 2 * A'Length); begin for J in A'Range loop S (S'First + 2 * Integer (J - A'First)) := Hex (Integer (A (J)) / 16); S (S'First + 2 * Integer (J - A'First) + 1) := Hex (Integer (A (J)) mod 16); end loop; return S; end SEA_To_Hex_String; ----------------------- -- Hex_String_To_SEA -- ----------------------- function Hex_String_To_SEA (S : String) return Stream_Element_Array is A : Stream_Element_Array (1 .. S'Length / 2); begin for J in A'Range loop A (J) := Stream_Element (Hex_Value (S (S'First + 2 * Integer (J - A'First))) * 16 + Hex_Value (S (S'First + 2 * Integer (J - A'First) + 1))); end loop; return A; end Hex_String_To_SEA; ---------------- -- URI_Encode -- ---------------- function URI_Encode (S : String; Also_Escape : String := "/") return String is Need_Escape : Escape_Map := Default_Escape_Map; Result : String (1 .. 3 * S'Length); DI : Integer := Result'First; begin for J in Also_Escape'Range loop Need_Escape (Also_Escape (J)) := True; end loop; for SI in S'Range loop if Need_Escape (S (SI)) then Result (DI .. DI + 2) := '%' & Hex (Character'Pos (S (SI)) / 16) & Hex (Character'Pos (S (SI)) mod 16); DI := DI + 3; else Result (DI) := S (SI); DI := DI + 1; end if; end loop; return Result (Result'First .. DI - 1); end URI_Encode; ---------------- -- URI_Decode -- ---------------- function URI_Decode (S : String) return String is Result : String (S'Range); SI : Integer := S'First; DI : Integer := Result'First; begin while SI <= S'Last loop if S (SI) = '%' then if SI > S'Last - 2 then raise Constraint_Error; end if; Result (DI) := Character'Val (Hex_Value (S (SI + 1)) * 16 + Hex_Value (S (SI + 2))); SI := SI + 3; else Result (DI) := S (SI); SI := SI + 1; end if; DI := DI + 1; end loop; return Result (Result'First .. DI - 1); end URI_Decode; --------------- -- Find_Skip -- --------------- function Find_Skip (S : String; Start : Integer; What : Character; Skip : Boolean; Direction : Direction_Type) return Integer is I : Integer := Start; begin loop exit when I not in S'Range or else (S (I) = What xor Skip); I := I + Integer (Direction); end loop; return I; end Find_Skip; ---------------- -- Has_Prefix -- ---------------- function Has_Prefix (S : String; Prefix : String) return Boolean is begin return S'Length >= Prefix'Length and then S (S'First .. S'First + Prefix'Length - 1) = Prefix; end Has_Prefix; -------------- -- To_Lower -- -------------- function To_Lower (S : String) return String is function To_Lower (C : Character) return Character; -- Return C converted to lowercase, or unchanged if not an uppercase -- letter. -------------- -- To_Lower -- -------------- function To_Lower (C : Character) return Character is C_Val : constant Natural := Character'Pos (C); begin if C in 'A' .. 'Z' or else C_Val in 16#C0# .. 16#D6# or else C_Val in 16#D8# .. 16#DE# then return Character'Val (C_Val + 16#20#); else return C; end if; end To_Lower; Result : String := S; begin for J in Result'Range loop Result (J) := To_Lower (Result (J)); end loop; return Result; end To_Lower; -------------- -- To_Upper -- -------------- function To_Upper (S : String) return String is function To_Upper (C : Character) return Character; -- Return C converted to uppercase, or unchanged if not a lowercase -- letter. -------------- -- To_Upper -- -------------- function To_Upper (C : Character) return Character is C_Val : constant Natural := Character'Pos (C); begin if C in 'a' .. 'z' or else C_Val in 16#E0# .. 16#F6# or else C_Val in 16#F8# .. 16#FE# then return Character'Val (C_Val - 16#20#); else return C; end if; end To_Upper; Result : String := S; begin for J in Result'Range loop Result (J) := To_Upper (Result (J)); end loop; return Result; end To_Upper; end PolyORB.Utils; polyorb-2.8~20110207.orig/src/polyorb-references-file.adb0000644000175000017500000000653611750740340022375 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . R E F E R E N C E S . F I L E -- -- -- -- B o d y -- -- -- -- Copyright (C) 2005-2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with Ada.Text_IO; with PolyORB.Initialization; with PolyORB.Utils.Strings; package body PolyORB.References.File is File_Prefix : constant String := "file://"; ---------------------- -- String_To_Object -- ---------------------- function String_To_Object (Str : String) return Ref; function String_To_Object (Str : String) return Ref is use Ada.Text_IO; File : File_Type; Item : String (1 .. 4 * 1024); Last : Natural; Result : Ref; begin Open (File, In_File, Str (Str'First + File_Prefix'Length .. Str'Last)); Get_Line (File, Item, Last); Close (File); PolyORB.References.String_To_Object (Item (1 .. Last), Result); return Result; end String_To_Object; ---------------- -- Initialize -- ---------------- procedure Initialize; procedure Initialize is begin Register_String_To_Object (File_Prefix, String_To_Object'Access); end Initialize; use PolyORB.Initialization; use PolyORB.Initialization.String_Lists; use PolyORB.Utils.Strings; begin Register_Module (Module_Info' (Name => +"references.file", Conflicts => Empty, Depends => Empty, Provides => +"references", Implicit => False, Init => Initialize'Access, Shutdown => null)); end PolyORB.References.File; polyorb-2.8~20110207.orig/src/polyorb-parameters.adb0000644000175000017500000001706611750740340021502 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . P A R A M E T E R S -- -- -- -- B o d y -- -- -- -- Copyright (C) 2002-2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- PolyORB runtime configuration facility pragma Ada_2005; with PolyORB.Constants; with PolyORB.Initialization; with PolyORB.Utils.Chained_Lists; with PolyORB.Utils.Strings; package body PolyORB.Parameters is package Source_Lists is new PolyORB.Utils.Chained_Lists (Parameters_Source_Access); type Source_List_Access is access Source_Lists.List; Sources : Source_List_Access; -- Manage an ordered list of configuration parameter sources. When looking -- up the value of a parameter, the first match is returned, hence sources -- closer to the head of the list take precendence over subsequent ones. -- The designated List object is allocated on the first call to -- Register_Source (we can't declare a List object directly here because -- List is a private type, and this would make Parameters non-preelaborable -- in Ada 95). function Fetch (Key : String) return String; -- Get the string from a file (if Key starts with file: and the file -- exists, otherwise it is an empty string), or the string itself -- otherwise. ----------- -- Fetch -- ----------- function Fetch (Key : String) return String is begin if PolyORB.Utils.Has_Prefix (Key, "file:") and then Fetch_From_File_Hook /= null then return Fetch_From_File_Hook.all (Key); else return Key; end if; end Fetch; ----------------------- -- Get_Conf (String) -- ----------------------- function Get_Conf (Section, Key : String; Default : String := "") return String is use Source_Lists; It : Iterator; begin if Sources = null then return Default; end if; It := First (Sources.all); while not Last (It) loop declare V : constant String := Get_Conf (Value (It).all, Section, Key); begin if V'Length > 0 then return Fetch (V); end if; end; Next (It); end loop; return Default; end Get_Conf; ------------------------ -- Get_Conf (Boolean) -- ------------------------ function Get_Conf (Section, Key : String; Default : Boolean := False) return Boolean is Default_Value : constant array (Boolean'Range) of String (1 .. 1) := (False => "0", True => "1"); begin return Utils.Strings.To_Boolean (Get_Conf (Section, Key, Default_Value (Default))); end Get_Conf; ------------------------- -- Get_Conf (Duration) -- ------------------------- function Get_Conf (Section, Key : String; Default : Duration := 0.0) return Duration is Default_Milliseconds : Integer; Milliseconds : Integer; begin if Default = Constants.Forever then Default_Milliseconds := -1; else Default_Milliseconds := Natural (Default * 1000); end if; Milliseconds := Get_Conf (Section, Key, Default_Milliseconds); if Milliseconds < 0 then return Constants.Forever; else return Milliseconds * 0.001; end if; end Get_Conf; ------------------------ -- Get_Conf (Integer) -- ------------------------ function Get_Conf (Section, Key : String; Default : Integer := 0) return Integer is begin return Integer'Value (Get_Conf (Section, Key, Integer'Image (Default))); end Get_Conf; ------------------------- -- Get_Conf (Interval) -- ------------------------- function Get_Conf (Section, Key : String; Default : Interval := (0, 0)) return Interval is Default_Str : constant String := Default.Lo'Img & "-" & Default.Hi'Img; -- Default value as a string Str_Value : String renames Get_Conf (Section, Key, Default_Str); -- Effective value as a string Hyphen : Integer := Str_Value'Last + 1; -- Index of hyphen in Str_Value, or Str_Value'Last + 1 if none Result : Interval; begin -- Find hyphen in Str_Value for J in Str_Value'Range loop if Str_Value (J) = '-' then if J = Str_Value'First or else J = Str_Value'Last then -- Malformed interval: if hyphen is present, it must be -- preceded and followed by bounds. raise Constraint_Error; end if; Hyphen := J; exit; end if; end loop; -- Set result Result.Lo := Integer'Value (Str_Value (Str_Value'First .. Hyphen - 1)); -- If Hyphen is present, high bound is given explicitly, else we have -- a plain integer literal, and treat it as a single-value interval. if Hyphen < Str_Value'Last then Result.Hi := Integer'Value (Str_Value (Hyphen + 1 .. Str_Value'Last)); else Result.Hi := Result.Lo; end if; return Result; end Get_Conf; ---------------- -- Initialize -- ---------------- procedure Initialize is begin PolyORB.Initialization.Get_Conf_Hook := Get_Conf'Access; end Initialize; --------------------- -- Make_Global_Key -- --------------------- function Make_Global_Key (Section, Key : String) return String is begin return "[" & Section & "]" & Key; end Make_Global_Key; --------------------- -- Register_Source -- --------------------- procedure Register_Source (Source : Parameters_Source_Access) is begin if Sources = null then Sources := new Source_Lists.List; end if; Source_Lists.Append (Sources.all, Source); end Register_Source; end PolyORB.Parameters; polyorb-2.8~20110207.orig/src/polyorb-services-naming-namingcontext-client.ads0000644000175000017500000001124011750740340026566 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- POLYORB.SERVICES.NAMING.NAMINGCONTEXT.CLIENT -- -- -- -- S p e c -- -- -- -- Copyright (C) 2002-2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with PolyORB.References; package PolyORB.Services.Naming.NamingContext.Client is procedure Bind (Self : PolyORB.Services.Naming.NamingContext.Ref; N : Name; Obj : PolyORB.References.Ref); Bind_Repository_Id : constant Standard.String := "IDL:omg.org/CosNaming/NamingContext/bind:1.0"; procedure Rebind (Self : PolyORB.Services.Naming.NamingContext.Ref; N : Name; Obj : PolyORB.References.Ref); Rebind_Repository_Id : constant Standard.String := "IDL:omg.org/CosNaming/NamingContext/rebind:1.0"; procedure Bind_Context (Self : PolyORB.Services.Naming.NamingContext.Ref; N : Name; Nc : NamingContext.Ref); Bind_Context_Repository_Id : constant Standard.String := "IDL:omg.org/CosNaming/NamingContext/bind_context:1.0"; procedure Rebind_Context (Self : PolyORB.Services.Naming.NamingContext.Ref; N : Name; Nc : NamingContext.Ref); Rebind_Context_Repository_Id : constant Standard.String := "IDL:omg.org/CosNaming/NamingContext/rebind_context:1.0"; function Resolve (Self : PolyORB.Services.Naming.NamingContext.Ref; N : Name) return PolyORB.References.Ref; Resolve_Repository_Id : constant Standard.String := "IDL:omg.org/CosNaming/NamingContext/resolve:1.0"; procedure Unbind (Self : PolyORB.Services.Naming.NamingContext.Ref; N : Name); Unbind_Repository_Id : constant Standard.String := "IDL:omg.org/CosNaming/NamingContext/unbind:1.0"; function New_Context (Self : PolyORB.Services.Naming.NamingContext.Ref) return NamingContext.Ref; New_Context_Repository_Id : constant Standard.String := "IDL:omg.org/CosNaming/NamingContext/new_context:1.0"; function Bind_New_Context (Self : PolyORB.Services.Naming.NamingContext.Ref; N : Name) return NamingContext.Ref; Bind_New_Context_Repository_Id : constant Standard.String := "IDL:omg.org/CosNaming/NamingContext/bind_new_context:1.0"; procedure Destroy (Self : PolyORB.Services.Naming.NamingContext.Ref); Destroy_Repository_Id : constant Standard.String := "IDL:omg.org/CosNaming/NamingContext/destroy:1.0"; -- procedure List -- (Self : PolyORB.Services.Naming.NamingContext.Ref; -- How_Many : PolyORB.Types.Unsigned_Long; -- Bl : out BindingList; -- Bi : out BindingIterator_Forward.Ref); List_Repository_Id : constant Standard.String := "IDL:omg.org/CosNaming/NamingContext/list:1.0"; Repository_Id : constant Standard.String := "IDL:omg.org/CosNaming/NamingContext:1.0"; end PolyORB.Services.Naming.NamingContext.Client; polyorb-2.8~20110207.orig/src/polyorb-sequences-unbounded.ads0000644000175000017500000002227111750740340023326 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . S E Q U E N C E S . U N B O U N D E D -- -- -- -- S p e c -- -- -- -- Copyright (C) 2002-2008, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- This package provides the definitions required by the IDL-to-Ada -- mapping specification for unbounded sequences. This package is -- instantiated for each IDL unbounded sequence type. This package -- defines the sequence type and the operations upon it. This package -- is modelled after Ada.Strings.Unbounded and is compliant with the -- specifications of CORBA.Sequences.Unounded defined in the CORBA -- Ada Mapping. -- -- Most query operations are not usable until the sequence object has been -- initialized through an assignment. -- -- Value semantics apply to assignment, that is, assignment of a sequence -- value to a sequence object yields a copy of the value. -- -- The user should not assume safety under tasking, i.e. the -- implementation only support sequential semantics. -- -- Indices of elements of sequences are from 1 .. n, i.e. they follow the -- normal Ada convention. -- -- The exception INDEX_ERROR is raised when indexes are not in the range -- of the object being manipulated. -- -- Sequences are automatically initialized to zero length, so users should -- not see Constraint_Error raised. with Ada.Finalization; with Ada.Unchecked_Deallocation; generic type Element is private; package PolyORB.Sequences.Unbounded is pragma Preelaborate; type Element_Array is array (Positive range <>) of Element; -- Can't be "of aliased Element" because Element may be an unconstrained -- mutable record type. -- The element array below has a null index range, so no elements are -- ever actually initialized, and we can safely ignore a warning about an -- implicit call to Initialize (for a controlled element type) possibly -- causing a Program_Error depending on elaboration order. pragma Warnings (Off); Null_Element_Array : Element_Array (1 .. 0); pragma Warnings (On); type Element_Array_Access is access all Element_Array; procedure Free is new Ada.Unchecked_Deallocation (Element_Array, Element_Array_Access); type Sequence is private; function Null_Sequence return Sequence; function Length (Source : Sequence) return Natural; -- Return the length of Source procedure Set_Length (Source : in out Sequence; Length : Natural); -- Set the length of Source to the indicated value, truncating it if the -- current length is greater, and extending it with elements of unspecified -- value if it is shorter. -- Note that this subprogram is PolyORB-specific and not part of the -- CORBA sequences API. -------------------------------------------------------- -- Conversion, Concatenation, and Selection functions -- -------------------------------------------------------- procedure Set (Item : in out Sequence; Source : Element_Array); function To_Sequence (Source : Element_Array) return Sequence; function To_Sequence (Length : Natural) return Sequence; function To_Element_Array (Source : Sequence) return Element_Array; procedure Append (Source : in out Sequence; New_Item : Sequence); procedure Append (Source : in out Sequence; New_Item : Element_Array); procedure Append (Source : in out Sequence; New_Item : Element); function "&" (Left : Sequence; Right : Sequence) return Sequence; function "&" (Left : Sequence; Right : Element_Array) return Sequence; function "&" (Left : Element_Array; Right : Sequence) return Sequence; function "&" (Left : Sequence; Right : Element) return Sequence; function "&" (Left : Element; Right : Sequence) return Sequence; function Get_Element (Source : Sequence; Index : Positive) return Element; procedure Replace_Element (Source : in out Sequence; Index : Positive; By : Element); function Slice (Source : Sequence; Low : Positive; High : Natural) return Element_Array; function "=" (Left : Sequence; Right : Sequence) return Boolean; function "=" (Left : Element_Array; Right : Sequence) return Boolean; function "=" (Left : Sequence; Right : Element_Array) return Boolean; function Is_Null (Source : Sequence) return Boolean; -- Equivalent to (Source = Null_Sequence). ---------------------- -- Search functions -- ---------------------- function Index (Source : Sequence; Pattern : Element_Array; Going : Direction := Forward) return Natural; function Count (Source : Sequence; Pattern : Element_Array) return Natural; ----------------------------------------- -- Sequence transformation subprograms -- ----------------------------------------- procedure Delete (Source : in out Sequence; From : Positive; Through : Natural); function Replace_Slice (Source : Sequence; Low : Positive; High : Natural; By : Element_Array) return Sequence; procedure Replace_Slice (Source : in out Sequence; Low : Positive; High : Natural; By : Element_Array); function Insert (Source : Sequence; Before : Positive; New_Item : Element_Array) return Sequence; procedure Insert (Source : in out Sequence; Before : Positive; New_Item : Element_Array); function Overwrite (Source : Sequence; Position : Positive; New_Item : Element_Array) return Sequence; procedure Overwrite (Source : in out Sequence; Position : Positive; New_Item : Element_Array); function Delete (Source : Sequence; From : Positive; Through : Natural) return Sequence; ----------------------------------- -- Sequence selector subprograms -- ----------------------------------- function Head (Source : Sequence; Count : Natural; Pad : Element) return Sequence; procedure Head (Source : in out Sequence; Count : Natural; Pad : Element); function Tail (Source : Sequence; Count : Natural; Pad : Element) return Sequence; procedure Tail (Source : in out Sequence; Count : Natural; Pad : Element); -------------------------------------- -- Sequence constructor subprograms -- -------------------------------------- function "*" (Left : Natural; Right : Element) return Sequence; function "*" (Left : Natural; Right : Element_Array) return Sequence; function "*" (Left : Natural; Right : Sequence) return Sequence; -------------------------------------- -- Accessor to stored element space -- -------------------------------------- type Element_Ptr is access all Element; function Unchecked_Element_Of (Source : access Sequence; Index : Positive) return Element_Ptr; -- Return an access to the element at the specified index in Source private pragma Inline (Null_Sequence); Prealloc_Length : constant := 5; type Sequence is new Ada.Finalization.Controlled with record Length : Natural; Content : Element_Array_Access; end record; procedure Initialize (X : in out Sequence); procedure Adjust (X : in out Sequence); procedure Finalize (X : in out Sequence); end PolyORB.Sequences.Unbounded; polyorb-2.8~20110207.orig/src/polyorb-orb-iface.ads0000644000175000017500000000707011750740340021201 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . O R B . I F A C E -- -- -- -- S p e c -- -- -- -- Copyright (C) 2001-2005 Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- The messages supported by ORBs (middleware core module). with PolyORB.Components; with PolyORB.Requests; with PolyORB.Transport; package PolyORB.ORB.Iface is type Queue_Request is new Components.Message with record Request : Requests.Request_Access; Requestor : Components.Component_Access; end record; -- Queue method invocation request Req for execution by Server -- on behalf of a remote caller. No reply expected. -- When the request is executed, a message will be sent -- back to Requestor (asynchronously). If this request comes -- from a Session, Requestor must be set to that Session. -- If the request is submitted directly by a local client task, -- Requestor must be set to null. -- The client the responsible of the destruction of -- the Request after its execution is completed. type Unregister_Endpoint is new Components.Message with record TE : Transport.Transport_Endpoint_Access; end record; -- Request that TE be removed from the set of endpoints -- managed by the ORB. type Monitor_Access_Point is new Components.Message with record TAP : Transport.Transport_Access_Point_Access; end record; -- A binding object requests that the designated transport -- access point be monitored for incoming data. type Monitor_Endpoint is new Components.Message with record TE : Transport.Transport_Endpoint_Access; end record; -- A binding object requests that the designated transport -- endpoint be monitored for incoming data. end PolyORB.ORB.Iface; polyorb-2.8~20110207.orig/src/polyorb-utils-simple_flags.ads0000644000175000017500000000647211750740340023162 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . U T I L S . S I M P L E _ F L A G S -- -- -- -- S p e c -- -- -- -- Copyright (C) 2002-2008, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- Utility to provide support for simple binary flags generic type Flags_Type is mod <>; with function Shift_Left (Value : Flags_Type; N : Natural) return Flags_Type is <>; package PolyORB.Utils.Simple_Flags is pragma Pure; type Bit_Count is new Natural range 0 .. (Flags_Type'Size - 1); function Mask (N : Bit_Count) return Flags_Type; pragma Inline (Mask); -- Create a binary mask equal to 2 ** N function Is_Set (Flag_To_Test : Flags_Type; In_Flags : Flags_Type) return Boolean; pragma Inline (Is_Set); -- Test if Flag_To_Test has been set in In_Flags -- Flag_To_Test is a mask function Is_Set (N : Bit_Count; In_Flags : Flags_Type) return Boolean; pragma Inline (Is_Set); -- Test if bit N has been set in In_Flags function Set (Flag_To_Set : Flags_Type; In_Flags : Flags_Type) return Flags_Type; pragma Inline (Set); -- Set Flag_To_Set in In_Flags -- Flag_To_Set is a mask function Set (N : Bit_Count; In_Flags : Flags_Type) return Flags_Type; pragma Inline (Set); -- Set bit N in In_Flags procedure Set (Flag_Field : in out Flags_Type; N : Bit_Count; Value : Boolean); -- Set bit N of Flag_Field to Value end PolyORB.Utils.Simple_Flags; polyorb-2.8~20110207.orig/src/polyorb-tasking-profiles-full_tasking.ads0000644000175000017500000000432211750740340025310 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- POLYORB.TASKING.PROFILES.FULL_TASKING -- -- -- -- S p e c -- -- -- -- Copyright (C) 2002 Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by ACT Europe. -- -- (email: sales@act-europe.fr) -- -- -- ------------------------------------------------------------------------------ -- Base package for the implementation of PolyORB.Tasking -- with full Ada tasking. package PolyORB.Tasking.Profiles.Full_Tasking is pragma Preelaborate; end PolyORB.Tasking.Profiles.Full_Tasking; polyorb-2.8~20110207.orig/src/polyorb-references-binding.ads0000644000175000017500000001045211750740340023101 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . R E F E R E N C E S . B I N D I N G -- -- -- -- S p e c -- -- -- -- Copyright (C) 2001-2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- Object references (binding operation). with PolyORB.Binding_Data; with PolyORB.Components; with PolyORB.Errors; with PolyORB.ORB; with PolyORB.QoS; package PolyORB.References.Binding is pragma Elaborate_Body; procedure Bind (R : Ref'Class; Local_ORB : ORB.ORB_Access; QoS : PolyORB.QoS.QoS_Parameters; Servant : out Components.Component_Access; Pro : out Binding_Data.Profile_Access; Local_Only : Boolean; Error : in out PolyORB.Errors.Error_Container); -- Bind R to a servant, and return that servant (or a surrogate -- thereof) and the object id corresponding to the profile of R -- that was used. -- Local_ORB is the local middleware. It is used to determine -- whether reference profiles are local. Its object adapter -- is queried to resolve local object ids into servants. -- When a remote reference is to be bound, Local_ORB is in -- charge of all the transport and communication aspects -- of the binding operation. It must then return a remote -- surrogate of the object designated by R. If Local_Only -- is set to True, no remote binding is done. In that -- case, only references to local objects can be bound, -- and the returned Servant will be an actual local servant -- (not a surrogate). procedure Unbind (R : Ref'Class); -- Dissociate R from its continuation procedure Get_Tagged_Profile (R : Ref; Tag : Binding_Data.Profile_Tag; Pro : out Binding_Data.Profile_Access; Error : in out PolyORB.Errors.Error_Container); -- Find a profile in R that matches Tag, and return it. -- If R has no profile with a matching tag, create a -- proxy profile that designates R using this ORB as -- a proxy. If R has no profile matching Tag, and this -- ORB cannot behave as a proxy either, null is returned. function Get_Preferred_Profile (R : Ref'Class; Ignore_Local : Boolean) return Binding_Data.Profile_Access; -- Compute preferred profile which will be used in object binding -- operation. If Ignore_Local is True then ignore local profile even -- if it is a most preferred profile. end PolyORB.References.Binding; polyorb-2.8~20110207.orig/src/polyorb-opaque-chunk_pools.adb0000644000175000017500000001045511750740340023146 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . O P A Q U E . C H U N K _ P O O L S -- -- -- -- B o d y -- -- -- -- Copyright (C) 2001-2009, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- Pools of memory chunks, with associated client metadata. with Ada.Unchecked_Deallocation; with System; package body PolyORB.Opaque.Chunk_Pools is use Ada.Streams; use Chunk_Lists; -------------- -- Allocate -- -------------- procedure Allocate (Pool : access Pool_Type; A_Chunk : out Chunk_Access; Size : Stream_Element_Count := Default_Chunk_Size) is Allocation_Size : Stream_Element_Count; New_Chunk : Chunk_Access; begin if Size <= Default_Chunk_Size then Allocation_Size := Default_Chunk_Size; else Allocation_Size := Size; end if; if Allocation_Size = Default_Chunk_Size and then not Pool.Prealloc_Used then New_Chunk := Pool.Prealloc'Access; Pool.Prealloc_Used := True; else New_Chunk := new Chunk (Size => Allocation_Size); Append (Pool.Dynamic_Chunks, New_Chunk); end if; A_Chunk := New_Chunk; end Allocate; ------------------- -- Chunk_Storage -- ------------------- function Chunk_Storage (A_Chunk : Chunk_Access) return Opaque_Pointer is begin pragma Assert (A_Chunk /= null); return A_Chunk.Data (A_Chunk.Data'First)'Address; end Chunk_Storage; ---------- -- Link -- ---------- function Link (C : access Chunk; Which : Utils.Ilists.Link_Type) return access Chunk_Access is use Utils.Ilists; begin pragma Assert (Which = Next); return C.Next'Unchecked_Access; end Link; -------------- -- Metadata -- -------------- function Metadata (A_Chunk : Chunk_Access) return Metadata_Access is begin return A_Chunk.Metadata'Access; end Metadata; ------------- -- Release -- ------------- procedure Release (Pool : access Pool_Type) is procedure Free is new Ada.Unchecked_Deallocation (Chunk, Chunk_Access); It : Chunk_Lists.Iterator := First (Pool.Dynamic_Chunks); begin while not Last (It) loop declare use type System.Address; This : Chunk_Access := Value (It); begin Remove (Pool.Dynamic_Chunks, It); Free (This); end; end loop; Pool.Prealloc_Used := False; end Release; end PolyORB.Opaque.Chunk_Pools; polyorb-2.8~20110207.orig/src/polyorb-binding_objects.ads0000644000175000017500000001333411750740340022475 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . B I N D I N G _ O B J E C T S -- -- -- -- S p e c -- -- -- -- Copyright (C) 2004-2009, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- Binding objects: protocol stacks seen globally as a reference-counted -- entity. pragma Ada_2005; with PolyORB.Annotations; with PolyORB.Binding_Data; with PolyORB.Components; with PolyORB.Filters; with PolyORB.Smart_Pointers; with PolyORB.Transport; with PolyORB.Utils.Ilists; package PolyORB.Binding_Objects is type Binding_Object is new Smart_Pointers.Non_Controlled_Entity with private; type Binding_Object_Access is access all Binding_Object'Class; -- A protocol session and associated transport and filter stack, -- seen globally as a reference-counted entity. function Link (X : access Binding_Object'Class; Which : Utils.Ilists.Link_Type) return access Binding_Object_Access; pragma Inline (Link); -- Accessor for chaining pointers in binding objects allowing them to be -- attached to the ORB's binding objects list. function Get_Component (X : Smart_Pointers.Ref) return Components.Component_Access; -- Return the top component of the Binding_Object -- designated by reference X. function Get_Endpoint (X : Smart_Pointers.Ref) return Transport.Transport_Endpoint_Access; -- Return the transport endpoint of the Binding_Object -- designated by reference X. function Get_Profile (BO : Binding_Object_Access) return Binding_Data.Profile_Access; -- Return profile associated with Binding Object BO procedure Set_Profile (BO : Binding_Object_Access; P : Binding_Data.Profile_Access); -- Set the profile associated with Binding Object BO procedure Set_Referenced (BO : Binding_Object_Access; Referenced : Boolean); -- Record that BO is attached to the ORB's BO list function Referenced (BO : Binding_Object_Access) return Boolean; -- Test whether BO is attached to the ORB's BO list procedure Setup_Binding_Object (ORB : Components.Component_Access; TE : Transport.Transport_Endpoint_Access; FFC : Filters.Factory_Array; BO_Ref : out Smart_Pointers.Ref; Pro : Binding_Data.Profile_Access); -- Create a binding object associating TE with a protocol stack -- instantiated using FFC. function Notepad_Of (BO : Binding_Object_Access) return Annotations.Notepad_Access; -- Returns the notepad of given Binding Object function Valid (BO : Binding_Object_Access) return Boolean; -- True if BO can be used to forward requests to an object private type Links_Type is array (Utils.Ilists.Link_Type) of aliased Binding_Object_Access; type Binding_Object is new Smart_Pointers.Non_Controlled_Entity with record ORB : Components.Component_Access; -- The ORB owning this BO Transport_Endpoint : Transport.Transport_Endpoint_Access; -- Bottom of the binding object: a transport endpoint Top : Filters.Filter_Access; -- Top of the binding object: a protocol session Profile : Binding_Data.Profile_Access; -- The Profile associated with this Binding Object. This profile is -- used to determine if the Binding Object can be reused for another -- profile. Links : aliased Links_Type; -- Pointers for chaining of this Binding Object in the -- Binding_Objects list of the ORB. -- Note: this component must be accessed under the protection of the -- critical section of the Referenced_In ORB. Referenced : Boolean := False; -- True when attached to the ORB's BO list Notepad : aliased Annotations.Notepad; -- Binding_Object's notepad. The user is responsible for ensuring -- proper protection against incorrect concurrent accesses. end record; procedure Finalize (X : in out Binding_Object); end PolyORB.Binding_Objects; polyorb-2.8~20110207.orig/src/polyorb-servants-group_servants.adb0000644000175000017500000004337411750740340024264 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . S E R V A N T S . G R O U P _ S E R V A N T S -- -- -- -- B o d y -- -- -- -- Copyright (C) 2002-2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with Ada.Tags; with PolyORB.Log; with PolyORB.ORB.Iface; with PolyORB.Protocols.Iface; with PolyORB.Requests; with PolyORB.Servants.Iface; with PolyORB.Setup; with PolyORB.Types; package body PolyORB.Servants.Group_Servants is use PolyORB.Any.NVList; use PolyORB.Components; use PolyORB.Errors; use PolyORB.Log; use PolyORB.Setup; use PolyORB.Tasking.Mutexes; use PolyORB.Types; package L is new PolyORB.Log.Facility_Log ("polyorb.servants.group_servants"); procedure O (Message : Standard.String; Level : Log.Log_Level := Log.Debug) renames L.Output; function C (Level : Log_Level := Debug) return Boolean renames L.Enabled; package TPL renames Target_List_Package; --------------------------------- -- Handle_Unmarshall_Arguments -- --------------------------------- function Handle_Unmarshall_Arguments (Self : access Group_Servant; Msg : Components.Message'Class) return Components.Message'Class; -- Dispatch arguments between targets function Handle_Unmarshall_Arguments (Self : access Group_Servant; Msg : Components.Message'Class) return Components.Message'Class is use PolyORB.Protocols.Iface; begin pragma Assert (Msg in Unmarshall_Arguments); Enter (Self.Mutex); case Self.State is when Not_Ready => Leave (Self.Mutex); raise Program_Error; when Wait_First => -- Wait for first argument ask pragma Debug (C, O ("Try to unmarshall arguments")); pragma Assert (Self.Args_Src /= null); -- Check that request is oneway declare use PolyORB.Any; use PolyORB.Any.NVList.Internals.NV_Lists; It : PolyORB.Any.NVList.Internals.NV_Lists.Iterator := First (PolyORB.Any.NVList.Internals.List_Of (Unmarshall_Arguments (Msg).Args).all); begin while not Last (It) loop if Value (It).Arg_Modes = ARG_OUT or else Value (It).Arg_Modes = ARG_INOUT then Leave (Self.Mutex); raise Constraint_Error; end if; Next (It); end loop; end; -- Unmarshall arguments from protocol stack declare use PolyORB.Any.NVList.Internals.NV_Lists; Reply : constant Message'Class := Emit (Self.Args_Src, Msg); Req_Args : Ref renames Unmarshalled_Arguments (Reply).Args; It : PolyORB.Any.NVList.Internals.NV_Lists.Iterator; begin pragma Assert (Reply in Unmarshalled_Arguments or else Reply in Arguments_Error); if Reply in Unmarshalled_Arguments then pragma Debug (C, O ("Arguments unmarshalled, copying")); Create (Self.Args); It := First (PolyORB.Any.NVList.Internals.List_Of (Req_Args).all); while not Last (It) loop Add_Item (Self.Args, Value (It).all); Next (It); end loop; -- Replace the Argument component with a by-value -- copy of the original one (thus ensuring that the -- value remains valid even after exiting the -- current scope). It := First (PolyORB.Any.NVList.Internals.List_Of (Self.Args).all); while not Last (It) loop Value (It).all.Argument := PolyORB.Any.Copy_Any (Value (It).all.Argument); Next (It); end loop; pragma Debug (C, O ("Send arguments to first servant in group")); Self.State := Wait_Other; Leave (Self.Mutex); -- Send result return Unmarshalled_Arguments'(Args => Req_Args); else pragma Debug (C, O ("Arguments unmarshalling error")); -- Reply in Arguments_Error Self.Error := Arguments_Error (Reply).Error; Self.State := Wait_Other; -- Copy error and send result declare Aux : Error_Container; begin Throw (Aux, Self.Error.Kind, Self.Error.Member.all); Leave (Self.Mutex); return Arguments_Error'(Error => Aux); end; end if; end; when Wait_Other => -- Copy arguments (or error) and send it if not Found (Self.Error) then pragma Debug (C, O ("Get previously unmarshalled arguments")); declare use PolyORB.Any; use PolyORB.Any.NVList.Internals.NV_Lists; Req_Args : Ref renames Unmarshall_Arguments (Msg).Args; It1 : PolyORB.Any.NVList.Internals.NV_Lists.Iterator; It2 : PolyORB.Any.NVList.Internals.NV_Lists.Iterator; begin pragma Assert (Get_Count (Self.Args) = Get_Count (Req_Args)); It1 := First (PolyORB.Any.NVList.Internals.List_Of (Self.Args).all); It2 := First (PolyORB.Any.NVList.Internals.List_Of (Req_Args).all); while not Last (It1) loop pragma Assert (Value (It1).Name = Value (It2).Name); pragma Assert (Value (It1).Arg_Modes = Value (It2).Arg_Modes); Copy_Any_Value (Value (It2).Argument, Value (It1).Argument); Next (It1); Next (It2); end loop; Leave (Self.Mutex); return Unmarshalled_Arguments'(Args => Req_Args); end; else pragma Debug (C, O ("Copy unmarshalling arguments error")); declare Aux : Error_Container; begin Throw (Aux, Self.Error.Kind, Self.Error.Member.all); Leave (Self.Mutex); return Arguments_Error'(Error => Aux); end; end if; end case; end Handle_Unmarshall_Arguments; --------------------- -- Execute_Servant -- --------------------- function Execute_Servant (Self : not null access Group_Servant; Req : Requests.Request_Access) return Boolean is use PolyORB.Requests; use PolyORB.ORB; use PolyORB.Any; use PolyORB.ORB.Iface; use PolyORB.Servants.Iface; use Unsigned_Long_Flags; It : TPL.Iterator; begin if TPL.Length (Self.Target_List) = 0 then pragma Debug (C, O ("Request received in empty group !!!", PolyORB.Log.Warning)); return True; end if; -- Initialize argument proxy Enter (Self.Group_Lock); Enter (Self.Mutex); pragma Debug (C, O ("Request received on group servant : " & PolyORB.Objects.Image (Self.Oid.all))); -- Check if request is oneway if not Is_Set (Sync_With_Transport, Req.Req_Flags) then Leave (Self.Group_Lock); Leave (Self.Mutex); raise Constraint_Error; end if; if Self.State = Wait_Other then Catch (Self.Error); end if; Self.Counter := 0; Self.State := Wait_First; Self.Args_Src := Req.Deferred_Arguments_Session; It := TPL.First (Self.Target_List); -- Create sub-requests while not TPL.Last (It) loop declare Sub_Req : Request_Access; Args : Ref; begin if not Is_Nil (Req.Args) then -- We are in the case where a request is issued locally, on the -- same node, we copy directly the argument NV list. Args := Req.Args; end if; pragma Debug (C, O ("Forward to : " & PolyORB.References.Image (TPL.Value (It).all))); Create_Request (Target => PolyORB.References.Ref'(TPL.Value (It).all), Operation => Req.Operation.all, Arg_List => Args, Result => Req.Result, Deferred_Arguments_Session => PolyORB.Components.Component_Access (Self), Req => Sub_Req, Req_Flags => Req.Req_Flags); -- XXX Notepad is not copied, neither are QoS parameters .. -- Requeue request to ORB Queue_Request_To_Handler (The_ORB, Queue_Request' (Request => Sub_Req, Requestor => PolyORB.Components.Component_Access (Self))); pragma Debug (C, O ("Request sent")); TPL.Next (It); end; end loop; Leave (Self.Mutex); pragma Debug (C, O ("Request dispatched to all servants in group")); return False; end Execute_Servant; -------------------- -- Handle_Message -- -------------------- function Handle_Message (Self : not null access Group_Servant; Msg : Components.Message'Class) return Components.Message'Class is use PolyORB.Servants.Iface; use PolyORB.Protocols.Iface; Res : PolyORB.Components.Null_Message; begin pragma Debug (C, O ("Handling message of type " & Ada.Tags.External_Tag (Msg'Tag))); if Msg in Unmarshall_Arguments then return Handle_Unmarshall_Arguments (Self, Msg); elsif Msg in Executed_Request then Enter (Self.Mutex); declare use PolyORB.Requests; Req : Request_Access := Executed_Request (Msg).Req; begin pragma Debug (C, O ("Destroy request")); Destroy_Request (Req); end; Self.Counter := Self.Counter + 1; if Self.Counter = TPL.Length (Self.Target_List) then Leave (Self.Group_Lock); end if; Leave (Self.Mutex); return Res; else -- Dispatch return PolyORB.Servants.Handle_Message (Servant (Self.all)'Access, Msg); end if; end Handle_Message; -------------- -- Register -- -------------- procedure Register (Self : access Group_Servant; Ref : PolyORB.References.Ref) is begin pragma Debug (C, O ("Register on group servant : " & PolyORB.Objects.Image (Self.Oid.all))); pragma Debug (C, O ("Ref : " & PolyORB.References.Image (Ref))); Enter (Self.Group_Lock); TPL.Append (Self.Target_List, Ref); pragma Debug (C, O ("Group size:" & TPL.Length (Self.Target_List)'Img)); Leave (Self.Group_Lock); end Register; ---------------- -- Unregister -- ---------------- procedure Unregister (Self : access Group_Servant; Ref : References.Ref) is use PolyORB.References; begin pragma Debug (C, O ("Unregister on group servant: " & PolyORB.Objects.Image (Self.Oid.all))); pragma Debug (C, O ("Ref : " & PolyORB.References.Image (Ref))); Enter (Self.Group_Lock); TPL.Remove_Occurrences (Self.Target_List, Ref); pragma Debug (C, O ("Group size:" & TPL.Length (Self.Target_List)'Img)); Leave (Self.Group_Lock); end Unregister; --------------------------- -- Destroy_Group_Servant -- --------------------------- procedure Destroy_Group_Servant (Group : in out PolyORB.Servants.Servant_Access) is GS : constant Group_Servant_Access := Group_Servant (Group.all)'Access; begin TPL.Deallocate (GS.Target_List); Destroy (GS.Mutex); Destroy (GS.Group_Lock); Group := null; end Destroy_Group_Servant; -------------------------- -- Create_Group_Servant -- -------------------------- function Create_Group_Servant (Oid : Object_Id_Access) return PolyORB.Servants.Servant_Access is GS : constant Group_Servant_Access := new Group_Servant; begin pragma Debug (C, O ("Create group servant : " & PolyORB.Objects.Image (Oid.all))); GS.Oid := Oid; Create (GS.Mutex); Create (GS.Group_Lock); return PolyORB.Servants.Servant_Access (GS); end Create_Group_Servant; ------------------------- -- Get_Group_Object_Id -- ------------------------- procedure Get_Group_Object_Id (Group : PolyORB.Servants.Servant_Access; Oid : out Object_Id_Access; Error : in out PolyORB.Errors.Error_Container) is begin if not (Group.all in Group_Servant) then Throw (Error, NotAGroupObject_E, Null_Members'(Null_Member)); return; end if; Oid := Group_Servant_Access (Group).Oid; end Get_Group_Object_Id; ---------------------- -- Get_Group_Length -- ---------------------- procedure Get_Group_Length (Group : PolyORB.Servants.Servant_Access; L : out Natural; Error : in out PolyORB.Errors.Error_Container) is begin if not (Group.all in Group_Servant) then Throw (Error, NotAGroupObject_E, Null_Members'(Null_Member)); pragma Warnings (Off); -- "L" not set before return return; pragma Warnings (On); end if; L := TPL.Length (Group_Servant_Access (Group).Target_List); end Get_Group_Length; --------------- -- Associate -- --------------- procedure Associate (Group : PolyORB.Servants.Servant_Access; Ref : PolyORB.References.Ref; Error : in out PolyORB.Errors.Error_Container) is begin if not (Group.all in Group_Servant) then Throw (Error, NotAGroupObject_E, Null_Members'(Null_Member)); return; end if; Register (Group_Servant_Access (Group), Ref); end Associate; ------------------ -- Disassociate -- ------------------ procedure Disassociate (Group : PolyORB.Servants.Servant_Access; Ref : PolyORB.References.Ref; Error : in out PolyORB.Errors.Error_Container) is begin if not (Group.all in Group_Servant) then Throw (Error, NotAGroupObject_E, Null_Members'(Null_Member)); return; end if; Unregister (Group_Servant_Access (Group), Ref); end Disassociate; -------------------- -- Group Iterator -- -------------------- ----------- -- First -- ----------- procedure First (Group : PolyORB.Servants.Servant_Access; It : out Iterator; Error : in out PolyORB.Errors.Error_Container) is begin if not (Group.all in Group_Servant) then Throw (Error, NotAGroupObject_E, Null_Members'(Null_Member)); return; end if; It.It := TPL.First (Group_Servant_Access (Group).Target_List); end First; ----------- -- Value -- ----------- function Value (It : Iterator) return PolyORB.References.Ref is begin return TPL.Value (It.It).all; end Value; ---------- -- Next -- ---------- procedure Next (It : in out Iterator) is begin TPL.Next (It.It); end Next; ---------- -- Last -- ---------- function Last (It : Iterator) return Boolean is begin return TPL.Last (It.It); end Last; end PolyORB.Servants.Group_Servants; polyorb-2.8~20110207.orig/src/polyorb-poa_policies-implicit_activation_policy.ads0000644000175000017500000000560311750740340027430 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- POLYORB.POA_POLICIES.IMPLICIT_ACTIVATION_POLICY -- -- -- -- S p e c -- -- -- -- Copyright (C) 2001-2005 Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with PolyORB.POA_Types; with PolyORB.Servants; package PolyORB.POA_Policies.Implicit_Activation_Policy is use PolyORB.POA_Types; type ImplicitActivationPolicy is abstract new Policy with null record; type ImplicitActivationPolicy_Access is access all ImplicitActivationPolicy'Class; procedure Implicit_Activate_Servant (Self : ImplicitActivationPolicy; OA : PolyORB.POA_Types.Obj_Adapter_Access; P_Servant : Servants.Servant_Access; Hint : Object_Id_Access; Oid : out Object_Id_Access; Error : in out PolyORB.Errors.Error_Container) is abstract; procedure Ensure_No_Implicit_Activation (Self : ImplicitActivationPolicy; Error : in out PolyORB.Errors.Error_Container) is abstract; end PolyORB.POA_Policies.Implicit_Activation_Policy; polyorb-2.8~20110207.orig/src/polyorb-poa-basic_poa.ads0000644000175000017500000000766311750740340022057 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . P O A . B A S I C _ P O A -- -- -- -- S p e c -- -- -- -- Copyright (C) 2001-2005 Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- Basic POA implementation. -- As an implementation package of abstract functions defined in -- PolyORB.POA, this package provides an implementation for both the -- CORBA-like POA API (defined in PolyORB.POA) and PolyORB Obj_Adapter -- (defined in PolyORB.Obj_Adapters) upon which the Basic POA depends. with PolyORB.Errors; with PolyORB.Objects; with PolyORB.References; package PolyORB.POA.Basic_POA is pragma Elaborate_Body; type Basic_Obj_Adapter is new POA.Obj_Adapter with private; type Basic_Obj_Adapter_Access is access all Basic_Obj_Adapter; -- The POA object procedure Create_POA (Self : access Basic_Obj_Adapter; Adapter_Name : Standard.String; A_POAManager : POA_Manager.POAManager_Access; Policies : POA_Policies.PolicyList; POA : out Obj_Adapter_Access; Error : in out PolyORB.Errors.Error_Container); -------------------------------- -- Proxy namespace management -- -------------------------------- procedure Set_Proxies_OA (OA : access Basic_Obj_Adapter; Proxies_OA : Basic_Obj_Adapter_Access); function Is_Proxy_Oid (OA : access Basic_Obj_Adapter; Oid : access Objects.Object_Id) return Boolean; procedure To_Proxy_Oid (OA : access Basic_Obj_Adapter; R : References.Ref; Oid : out Object_Id_Access; Error : in out PolyORB.Errors.Error_Container); procedure Proxy_To_Ref (OA : access Basic_Obj_Adapter; Oid : access Objects.Object_Id; Ref : out References.Ref; Error : in out PolyORB.Errors.Error_Container); private type Basic_Obj_Adapter is new POA.Obj_Adapter with record Proxies_OA : Basic_Obj_Adapter_Access; -- The child POA used for management of the proxy objects -- namespace (used only in the Root POA instance.) end record; end PolyORB.POA.Basic_POA; polyorb-2.8~20110207.orig/src/polyorb-setup-oa-basic_rt_poa.adb0000644000175000017500000001004411750740340023504 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . S E T U P . O A . B A S I C _ R T _ P O A -- -- -- -- B o d y -- -- -- -- Copyright (C) 2004-2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with PolyORB.Initialization; with PolyORB.Errors; with PolyORB.Obj_Adapters; with PolyORB.ORB; with PolyORB.POA; with PolyORB.POA_Config.Root_POA; -- The configuration for the RootPOA. with PolyORB.POA_Manager; with PolyORB.RT_POA.Basic_RT_POA; with PolyORB.Setup; with PolyORB.Setup.Proxies_POA; -- XXX should be depended upon only when proxies are desired. with PolyORB.Utils.Strings; package body PolyORB.Setup.OA.Basic_RT_POA is use PolyORB.RT_POA.Basic_RT_POA; use type PolyORB.POA.Obj_Adapter_Access; ---------------- -- Initialize -- ---------------- procedure Initialize; procedure Initialize is use PolyORB.Errors; Root_POA_Object : PolyORB.POA.Obj_Adapter_Access; Error : Error_Container; begin PolyORB.POA_Config.Set_Configuration (new PolyORB.POA_Config.Root_POA.Root_POA_Configuration); Root_POA_Object := new PolyORB.RT_POA.Basic_RT_POA.Basic_RT_Obj_Adapter; PolyORB.POA.Create (Root_POA_Object); PolyORB.POA_Manager.Activate (PolyORB.POA_Manager.POAManager_Access (PolyORB.POA_Manager.Entity_Of (Root_POA_Object.POA_Manager)), Error); if Found (Error) then Catch (Error); raise Program_Error; end if; -- Link object adapter with ORB. PolyORB.ORB.Set_Object_Adapter (PolyORB.Setup.The_ORB, PolyORB.Obj_Adapters.Obj_Adapter_Access (Root_POA_Object)); PolyORB.Setup.Proxies_POA (Root_POA_Object, Error); if Found (Error) then Catch (Error); raise Program_Error; end if; end Initialize; use PolyORB.Initialization; use PolyORB.Initialization.String_Lists; use PolyORB.Utils.Strings; begin Register_Module (Module_Info' (Name => +"rt_basic_poa", Conflicts => Empty, Depends => +"orb", Provides => +"object_adapter" & "poa" & "rt_poa", Implicit => False, Init => Initialize'Access, Shutdown => null)); end PolyORB.Setup.OA.Basic_RT_POA; polyorb-2.8~20110207.orig/src/polyorb-opaque-chunk_pools.ads0000644000175000017500000001135411750740340023166 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . O P A Q U E . C H U N K _ P O O L S -- -- -- -- S p e c -- -- -- -- Copyright (C) 2001-2009, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- Pools of memory chunks, with associated client metadata. pragma Ada_2005; with PolyORB.Utils.Ilists; generic type Chunk_Metadata is private; -- The metadata associated with each storage chunk package PolyORB.Opaque.Chunk_Pools is pragma Preelaborate; type Chunk (Size : Ada.Streams.Stream_Element_Count) is limited private; type Chunk_Access is access all Chunk; Default_Chunk_Size : constant Ada.Streams.Stream_Element_Count := 512; type Pool_Type is limited private; -- A Pool of chunks with one preallocated chunk and a -- set of dynamically created ones. type Metadata_Access is access all Chunk_Metadata; procedure Allocate (Pool : access Pool_Type; A_Chunk : out Chunk_Access; Size : Ada.Streams.Stream_Element_Count := Default_Chunk_Size); -- Create a chunk in Pool and return an access to it. -- On the first call where Size is no more than Default_Chunk_Size, -- the Prealloc chunk is returned. On all other calls, a chunk of -- size Default_Chunk_Size or Size, whichever is greater, is -- dynamically allocated. function Chunk_Storage (A_Chunk : Chunk_Access) return Opaque.Opaque_Pointer; -- Return a pointer to a chunk's storage space. procedure Release (Pool : access Pool_Type); -- Signals that Pool will not be used anymore. -- The associated storage is returned to the system. function Metadata (A_Chunk : Chunk_Access) return Metadata_Access; -- Returns an access to the metadata associated -- with A_Chunk by the client of the Chunk_Pool -- package. private pragma Inline (Metadata); -- A chunk pool is managed as a linked list -- of chunks. type Chunk (Size : Ada.Streams.Stream_Element_Count) is limited record Next : aliased Chunk_Access; -- Used to link Chunk on pool's dynamic chunks list Metadata : aliased Chunk_Metadata; -- Metadata associated by a client to this chunk. Data : aliased Ada.Streams.Stream_Element_Array (1 .. Size); -- The storage space of the chunk. end record; function Link (C : access Chunk; Which : Utils.Ilists.Link_Type) return access Chunk_Access; pragma Inline (Link); -- Accessor for Next package Chunk_Lists is new Utils.Ilists.Lists (T => Chunk, T_Acc => Chunk_Access, Doubly_Linked => False); type Pool_Type is limited record Prealloc : aliased Chunk (Default_Chunk_Size); -- A pre-allocated chunk Prealloc_Used : Boolean := False; -- The pre-allocated chunk has been used Dynamic_Chunks : Chunk_Lists.List; -- The list of all dynamically allocated chunks in this pool end record; end PolyORB.Opaque.Chunk_Pools; polyorb-2.8~20110207.orig/src/ravenscar_compatible.adc.in0000644000175000017500000000222111750740340022427 0ustar xavierxavier-- Warn for violations of restrictions imposed by the Ravenscar profile. -- This check is to be made on all units except those specifically -- implementing the full tasking profile. -- @configure_input@ -- EXCLUDE: polyorb-tasking-profiles-full_tasking-condition_variables.adb -- EXCLUDE: polyorb-tasking-profiles-full_tasking-portable_mutexes.adb -- EXCLUDE: polyorb-tasking-profiles-full_tasking-mutexes.adb -- EXCLUDE: polyorb-tasking-profiles-full_tasking-threads.adb -- EXCLUDE: polyorb-tasking-profiles-full_tasking-threads-annotations.adb -- EXCLUDE: polyorb-tasking-profiles-full_tasking-threads-dynamic_priorities.adb -- EXCLUDE: polyorb-tasking-profiles-no_tasking-threads.adb -- EXCLUDE: polyorb-setup-tasking-no_tasking.adb -- EXCLUDE: polyorb-tasking-profiles-no_tasking-calendar.adb -- EXCLUDE: aws-utils.adb -- EXCLUDE: aws-server.adb -- We use GNAT-specific pragma Restriction_Warnings to avoid actually -- imposing the restrictions of units shared between Ravenscar and -- full-tasking applications, so the same set of compiled objects can -- be used in both cases. @DISABLE_PROFILE_WARNINGS@pragma Profile_Warnings (Ravenscar); polyorb-2.8~20110207.orig/src/polyorb-dynamic_dict.ads0000644000175000017500000000545211750740340022003 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . D Y N A M I C _ D I C T -- -- -- -- S p e c -- -- -- -- Copyright (C) 2001-2005 Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by ACT Europe. -- -- (email: sales@act-europe.fr) -- -- -- ------------------------------------------------------------------------------ -- A dynamic dictionnary of objects, indexed by Strings. generic type Value is private; package PolyORB.Dynamic_Dict is pragma Preelaborate; procedure Register (K : String; V : Value); -- Associate key K with value V. procedure Unregister (K : String); -- Remove any association for K. function Lookup (K : String; Default : Value) return Value; -- Lookup K in the dictionary, and return the associated value. -- Default is returned for non-registered keys. procedure Reset; -- Remove all key associations type Dict_Action is access procedure (K : String; V : Value); procedure For_Each (Action : Dict_Action); -- Execute Action for each association that exists in the dictionary end PolyORB.Dynamic_Dict; polyorb-2.8~20110207.orig/src/polyorb-protocols-echo.ads0000644000175000017500000000717511750740340022320 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . P R O T O C O L S . E C H O -- -- -- -- S p e c -- -- -- -- Copyright (C) 2001-2007, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- A dummy protocol, just for testing. with PolyORB.Buffers; package PolyORB.Protocols.Echo is pragma Elaborate_Body; -- Echo_Protocol: -- A very simple protocol that echoes text lines received -- from the user. type Echo_Protocol is new Protocol with private; procedure Create (Proto : access Echo_Protocol; Session : out Filter_Access); type Echo_Session is new Session with private; procedure Invoke_Request (S : access Echo_Session; R : Request_Access; P : access Binding_Data.Profile_Type'Class); procedure Abort_Request (S : access Echo_Session; R : Request_Access); -- These are just for show and do nothing procedure Send_Reply (S : access Echo_Session; R : Request_Access); -- Send a reply to the user procedure Handle_Flush (S : access Echo_Session); -- ??? procedure Handle_Connect_Indication (S : access Echo_Session); -- Send a greeting banner to user procedure Handle_Connect_Confirmation (S : access Echo_Session); -- Setup client dialog procedure Handle_Data_Indication (S : access Echo_Session; Data_Amount : Ada.Streams.Stream_Element_Count; Error : in out Errors.Error_Container); -- Handle data received from user procedure Handle_Disconnect (S : access Echo_Session; Error : Errors.Error_Container); -- Handle disconnection from user private type Echo_Protocol is new Protocol with null record; type Echo_Session is new Session with record Buffer : Buffers.Buffer_Access; Out_Buffer : Buffers.Buffer_Access; end record; end PolyORB.Protocols.Echo; polyorb-2.8~20110207.orig/src/polyorb-utils-dynamic_tables.adb0000644000175000017500000002167011750740340023447 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . U T I L S . D Y N A M I C _ T A B L E S -- -- -- -- B o d y -- -- -- -- Copyright (C) 2002-2008, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- This package provides one-dimensional, variable-size arrays support. -- See the package specification for more details. pragma Ada_2005; with Ada.Unchecked_Deallocation; with System; package body PolyORB.Utils.Dynamic_Tables is ----------------------- -- Local Subprograms -- ----------------------- function Table_First return Integer; pragma Inline (Table_First); -- Subscript of the first entry in the currently allocated table -- Note: the value here is a conversion to Integer of a generic formal, -- which is not preelaborable in Ada 2005 as the actual might involve a -- function call. So, we cannot use a constant here. procedure Reallocate (T : in out Instance); -- Reallocate the existing table according to the current value stored -- in Max. Works correctly to do an initial allocation if the table -- is currently null. type Table_Ptr is access all Table_Type; -- The table is actually represented as a pointer to allow -- reallocation. procedure Free_Table is new Ada.Unchecked_Deallocation (Table_Type, Table_Ptr); -------------- -- Allocate -- -------------- procedure Allocate (T : in out Instance; Num : Integer := 1) is begin T.P.Last_Val := T.P.Last_Val + Num; if T.P.Last_Val > T.P.Max then Reallocate (T); end if; end Allocate; ---------------- -- Deallocate -- ---------------- procedure Deallocate (T : in out Instance) is begin Free_Table (Table_Ptr (T.Table)); T.P.Length := 0; end Deallocate; -------------------- -- Decrement_Last -- -------------------- procedure Decrement_Last (T : in out Instance) is begin T.P.Last_Val := T.P.Last_Val - 1; end Decrement_Last; ----------- -- First -- ----------- function First (T : Instance) return Table_Index_Type is pragma Unreferenced (T); begin return First_Index; end First; -------------------- -- Increment_Last -- -------------------- procedure Increment_Last (T : in out Instance) is begin T.P.Last_Val := T.P.Last_Val + 1; if T.P.Last_Val > T.P.Max then Reallocate (T); end if; end Increment_Last; ---------------- -- Initialize -- ---------------- procedure Initialize (T : in out Instance) is Old_Length : constant Integer := T.P.Length; begin T.P.Last_Val := Table_First - 1; T.P.Max := Table_First + Table_Initial - 1; T.P.Length := T.P.Max - Table_First + 1; if Old_Length = T.P.Length then -- If table is same size as before (happens when table is never -- expanded which is a common case), then simply reuse it. Note -- that this also means that an explicit Init call right after -- the implicit one in the package body is harmless. return; else -- Otherwise we can use Reallocate to get a table of the right size. -- Note that Reallocate works fine to allocate a table of the right -- initial size when it is first allocated. Reallocate (T); end if; T.P.Initialized := True; end Initialize; ----------------- -- Initialized -- ----------------- function Initialized (T : Instance) return Boolean is begin return T.P.Initialized; end Initialized; ---------- -- Last -- ---------- function Last (T : Instance) return Table_Index_Type is begin return Table_Index_Type (T.P.Last_Val); end Last; --------------- -- Duplicate -- --------------- function Duplicate (T : Instance) return Instance is Result : Instance; begin Initialize (Result); Set_Last (Result, Last (T)); Result.Table.all := T.Table.all; return Result; end Duplicate; ---------- -- Read -- ---------- procedure Read (S : access Ada.Streams.Root_Stream_Type'Class; X : out Instance) is Last_Index : Table_Index_Type; begin Initialize (X); Table_Index_Type'Read (S, Last_Index); Set_Last (X, Last_Index); for J in First (X) .. Last (X) loop Table_Component_Type'Read (S, X.Table (J)); end loop; end Read; ---------------- -- Reallocate -- ---------------- procedure Reallocate (T : in out Instance) is use type System.Address; Table_Address : System.Address; for Table_Address'Address use T.Table'Address; pragma Import (Ada, Table_Address); begin if T.P.Max < T.P.Last_Val then while T.P.Max < T.P.Last_Val loop T.P.Length := Integer'Max (T.P.Length * (100 + Table_Increment) / 100, T.P.Length + 10); -- We use the maximum of these 2 values to ensure -- T.P.Length (and then T.P.Max) increases; avoiding -- infinite loop in case Table_Increment is too small, -- implying Increment = 1. T.P.Max := Table_First + T.P.Length - 1; end loop; end if; if Table_Address = System.Null_Address then -- WAG:62 -- Here we need to test if Table is null. In equality below, "null" -- is a valid literal for the anonymous access type of the record -- component in Ada 2005, but when the instance of this generic -- package is compiled in Ada 95 mode, this generates an -- instantiation error. T.Table := new Table_Type (Table_Low_Bound .. Table_Index_Type (T.P.Max)); elsif T.P.Max >= Table_First then declare Old_Table : Table_Ptr := T.Table.all'Unchecked_Access; begin T.Table := new Table_Type (Table_Low_Bound .. Table_Index_Type (T.P.Max)); T.Table (Old_Table'Range) := Old_Table (Old_Table'Range); Free_Table (Old_Table); end; end if; end Reallocate; ------------- -- Release -- ------------- procedure Release (T : in out Instance) is begin T.P.Length := T.P.Last_Val - Table_First + 1; T.P.Max := T.P.Last_Val; Reallocate (T); end Release; -------------- -- Set_Last -- -------------- procedure Set_Last (T : in out Instance; New_Val : Table_Index_Type) is begin T.P.Last_Val := Integer (New_Val); if T.P.Last_Val > T.P.Max then Reallocate (T); end if; end Set_Last; ----------------- -- Table_First -- ----------------- function Table_First return Integer is begin return Integer (Table_Low_Bound); end Table_First; ----------- -- Write -- ----------- procedure Write (S : access Ada.Streams.Root_Stream_Type'Class; X : Instance) is begin Table_Index_Type'Write (S, Last (X)); for J in First (X) .. Last (X) loop Table_Component_Type'Write (S, X.Table (J)); end loop; end Write; end PolyORB.Utils.Dynamic_Tables; polyorb-2.8~20110207.orig/src/polyorb-parameters-file.ads0000644000175000017500000000707411750740340022436 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . P A R A M E T E R S . F I L E -- -- -- -- S p e c -- -- -- -- Copyright (C) 2002-2005 Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ package PolyORB.Parameters.File is pragma Elaborate_Body; PolyORB_Conf_Default_Filename : constant String := "polyorb.conf"; PolyORB_Conf_Filename_Variable : constant String := "POLYORB_CONF"; -- PolyORB supports a global runtime configuration file. -- By default, the location of this file is Default_Filename. -- This default value can be overridden by setting the environment -- named by PolyORB_Conf_Filename_Variable. -- -- The syntax of the configuration file is: -- - empty lines and lines that have a '#' in column 1 are -- ignored; -- - sections can be started by lines of the form -- '[' SECTION-NAME ']'; -- - variable assignments can be performed by lines of the -- form VARIABLE-NAME '=' VALUE. -- -- Anything else raises Syntax_Error. -- -- Any variable assignment is local to a section. -- Assignments that occur before the first section declaration -- are relative to section [environment]. -- Section and variable names are case sensitive. -- -- A variable Var.Iable in section [Sec] can be overridden by -- setting environment variable "POLYORB_SEC_VAR_IABLE" -- (see Make_Env_Name in body). -- Furthermore, each time a resolved in that section value -- starts with "file:", the contents of the file is used instead. procedure Load_Configuration_File (Conf_File_Name : String); -- Load Conf_File_Name configuration file function Configuration_File_Name return String; -- Return PolyORB Configuration file name end PolyORB.Parameters.File; polyorb-2.8~20110207.orig/src/polyorb-fixed_point.ads0000644000175000017500000000556611750740340021672 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . F I X E D _ P O I N T -- -- -- -- S p e c -- -- -- -- Copyright (C) 2002-2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- Generic representation for fixed point types as an array -- of BCD nibbles followed by a sign indication. package PolyORB.Fixed_Point is pragma Pure; type Nibble is range 16#0# .. 16#f#; subtype Decimal_Nibble is Nibble range 0 .. 9; Positive_Zero : constant Nibble; Negative : constant Nibble; type Nibbles is array (Integer range <>) of Nibble; pragma Pack (Nibbles); generic type F is delta <> digits <>; package Fixed_Point_Conversion is function Fixed_To_Nibbles (Data : F) return Nibbles; function Nibbles_To_Fixed (Data : Nibbles) return F; end Fixed_Point_Conversion; private Fixed_Positive_Zero : constant := 16#c#; Fixed_Negative : constant := 16#d#; Positive_Zero : constant Nibble := Fixed_Positive_Zero; Negative : constant Nibble := Fixed_Negative; end PolyORB.Fixed_Point; polyorb-2.8~20110207.orig/src/polyorb-objects.adb0000644000175000017500000000657611750740340020774 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . O B J E C T S -- -- -- -- B o d y -- -- -- -- Copyright (C) 2001-2008, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with PolyORB.Utils; package body PolyORB.Objects is use Ada.Streams; ----------------------- -- Oid_To_Hex_String -- ----------------------- function Oid_To_Hex_String (Oid : Object_Id) return String is begin return Utils.SEA_To_Hex_String (Stream_Element_Array (Oid)); end Oid_To_Hex_String; ----------------------- -- Hex_String_To_Oid -- ----------------------- function Hex_String_To_Oid (S : String) return Object_Id is begin return Object_Id (Utils.Hex_String_To_SEA (S)); end Hex_String_To_Oid; ------------------- -- String_To_Oid -- ------------------- function String_To_Oid (S : String) return Object_Id is A : Object_Id (Stream_Element_Offset (S'First) .. Stream_Element_Offset (S'Last)); for A'Address use S'Address; pragma Import (Ada, A); begin return A; end String_To_Oid; ----------- -- Image -- ----------- function Image (Oid : Object_Id) return String is Oid_S : String (1 .. Oid'Length); for Oid_S'Address use Oid'Address; pragma Import (Ada, Oid_S); Result : String (1 .. Oid'Length) := Oid_S; begin for J in Result'Range loop if Character'Pos (Result (J)) not in 32 .. 127 then Result (J) := '.'; end if; end loop; return Result; end Image; end PolyORB.Objects; polyorb-2.8~20110207.orig/src/polyorb-orb-thread_per_request.ads0000644000175000017500000000656511750740340024027 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . O R B . T H R E A D _ P E R _ R E Q U E S T -- -- -- -- S p e c -- -- -- -- Copyright (C) 2002-2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ package PolyORB.ORB.Thread_Per_Request is pragma Elaborate_Body; use PolyORB.Components; use PolyORB.Jobs; use PolyORB.Transport; ----------------------------------------------------------- -- Implementation of a thread-per-request tasking policy -- ----------------------------------------------------------- -- In this policy, a task is created for each request and the request -- is executed by this task. type Thread_Per_Request_Policy is new Tasking_Policy_Type with private; procedure Handle_New_Server_Connection (P : access Thread_Per_Request_Policy; ORB : ORB_Access; AC : Active_Connection); procedure Handle_Close_Connection (P : access Thread_Per_Request_Policy; TE : Transport_Endpoint_Access); procedure Handle_New_Client_Connection (P : access Thread_Per_Request_Policy; ORB : ORB_Access; AC : Active_Connection); procedure Handle_Request_Execution (P : access Thread_Per_Request_Policy; ORB : ORB_Access; RJ : access Request_Job'Class); procedure Idle (P : access Thread_Per_Request_Policy; This_Task : PTI.Task_Info_Access; ORB : ORB_Access); private type Thread_Per_Request_Policy is new Tasking_Policy_Type with null record; end PolyORB.ORB.Thread_Per_Request; polyorb-2.8~20110207.orig/src/polyorb-utils-dynamic_tables.ads0000644000175000017500000002065311750740340023470 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . U T I L S . D Y N A M I C _ T A B L E S -- -- -- -- S p e c -- -- -- -- Copyright (C) 2002-2008, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- This package provides one-dimensional, variable-size arrays support. -- This package provides an implementation of dynamically resizable one -- dimensional arrays. The idea is to mimic the normal Ada semantics for -- arrays as closely as possible with the one additional capability of -- dynamically modifying the value of the Last attribute. -- This package is notionnaly equivalent to GNAT.Dynamic_Table's, yet -- * it is Preelaborate (GNAT.Dynamic_Table can't because it depends -- on System.Memory). -- * declares a type that can be used to define dynamic instances of -- the table, while an instantiation of GNAT.Table creates a single -- instance of the table type. -- Note: controlled types are not supported by this package. In particular -- the type provided for Table_Component_Type may not be a controlled type. -- This is a derived version of GNAT.Dynamic_Table, simplified in order -- to be preelaborable. pragma Ada_2005; generic type Table_Component_Type is private; type Table_Index_Type is range <>; Table_Low_Bound : Table_Index_Type; Table_Initial : Positive; Table_Increment : Natural; -- Table_Component_Type and Table_Index_Type specify the type of the -- array, Table_Low_Bound is the lower bound. Index_type must be an -- integer type. The effect is roughly to declare: -- Table : array (Table_Low_Bound .. <>) of Table_Component_Type; -- The Table_Component_Type can be any Ada type but note that default -- initialization will NOT occur for the array elements. -- The Table_Initial values controls the allocation of the table when -- it is first allocated, either by default, or by an explicit Init -- call. -- The Table_Increment value controls the amount of increase, if the -- table has to be increased in size. The value given is a percentage -- value (e.g. 100 = increase table size by 100%, i.e. double it). -- The Last and Set_Last subprograms provide control over the current -- logical allocation. They are quite efficient, so they can be used -- freely (expensive reallocation occurs only at major granularity -- chunks controlled by the allocation parameters). -- Note: we do not make the table components aliased, since this would -- restrict the use of table for discriminated types. If it is necessary -- to take the access of a table element, use Unrestricted_Access. package PolyORB.Utils.Dynamic_Tables is pragma Preelaborate; pragma Remote_Types; type Table_Type is array (Table_Index_Type range <>) of Table_Component_Type; type Table_Private is private; -- Table private data that is not exported in Instance type Instance is record Table : access Table_Type; -- The table itself. The lower bound is the value of Low_Bound. -- Logically the upper bound is the current value of Last (although -- the actual size of the allocated table may be larger than this). -- The program may only access and modify Table entries in the -- range First .. Last. P : Table_Private; end record; procedure Read (S : access Ada.Streams.Root_Stream_Type'Class; X : out Instance); procedure Write (S : access Ada.Streams.Root_Stream_Type'Class; X : Instance); for Instance'Read use Read; for Instance'Write use Write; procedure Initialize (T : in out Instance); -- This procedure allocates a new table of size Initial (freeing any -- previously allocated larger table). Init must be called before using -- the table. Init is convenient in reestablishing a table for new use. function Initialized (T : Instance) return Boolean; pragma Inline (Initialized); -- Return True iff T has been initialized First_Index : constant Table_Index_Type := Table_Low_Bound; -- Export First as synonym for Low_Bound (parallel with use of Last) function First (T : Instance) return Table_Index_Type; pragma Inline (First); -- Returns the 'First value of the table, basically this function -- returns First_Index. This function is a facility to access this -- value. function Last (T : Instance) return Table_Index_Type; pragma Inline (Last); -- Returns the current value of the last used entry in the table, -- which can then be used as a subscript for Table. Note that the -- only way to modify Last is to call the Set_Last procedure. Last -- must always be used to determine the logical last entry. procedure Set_Last (T : in out Instance; New_Val : Table_Index_Type); pragma Inline (Set_Last); -- This procedure sets Last to the indicated value. If necessary the -- table is reallocated to accomodate the new value (i.e. on return -- the allocated table has an upper bound of at least Last). If -- Set_Last reduces the size of the table, then logically entries are -- removed from the table. If Set_Last increases the size of the -- table, then new entries are logically added to the table. procedure Increment_Last (T : in out Instance); pragma Inline (Increment_Last); -- Adds 1 to Last (same as Set_Last (T, Last (T) + 1) procedure Decrement_Last (T : in out Instance); pragma Inline (Decrement_Last); -- Subtracts 1 from Last (same as Set_Last (T, Last (T) - 1)) procedure Release (T : in out Instance); -- Storage is allocated in chunks according to the values given in the -- Initial and Increment parameters. A call to Release releases all -- storage that is allocated, but is not logically part of the current -- array value. Current array values are not affected by this call. procedure Allocate (T : in out Instance; Num : Integer := 1); pragma Inline (Allocate); -- Allocate room for Num Table_Component_Type in table T, -- eventually reallocate T. function Duplicate (T : Instance) return Instance; -- Return a copy of T procedure Deallocate (T : in out Instance); -- Deallocate T instance private type Table_Private is record Initialized : Boolean := False; Max : Integer := 0; -- Subscript of the maximum entry in the currently allocated table Length : Integer := 0; -- Number of entries in currently allocated table. The value of zero -- ensures that we initially allocate the table. Last_Val : Integer := Integer (Table_Low_Bound) - 1; -- Current value of Last (table is initially empty) end record; end PolyORB.Utils.Dynamic_Tables; polyorb-2.8~20110207.orig/src/polyorb-components.ads0000644000175000017500000001026311750740340021535 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . C O M P O N E N T S -- -- -- -- S p e c -- -- -- -- Copyright (C) 2001-2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- Abstract components communicating through synchronous messages. package PolyORB.Components is pragma Preelaborate; ------------------------------------- -- Abstract message and components -- ------------------------------------- type Message is abstract tagged null record; -- The root type for all messages that can be exchanged -- between components. type Null_Message is new Message with null record; type Component is abstract tagged limited private; type Component_Access is access all Component'Class; function Handle_Message (C : not null access Component; M : Message'Class) return Message'Class is abstract; -- Called internally when component C is to receive message M. -- Return a reply (possibly Null_Message if no specific contents -- are to be returned to the sender) if M has been handled. -- Otherwise, exception Unhandled_Message is raised. -- Each component type overloads this primitive, and -- thus defines its behaviour in terms of replies to -- a set of external stimuli (messages). -- This subprogram must not be called directly. To send a message -- to a component, Emit or Emit_No_Reply must be used. procedure Connect (Port : out Component_Access; Target : Component_Access); -- Connect Port to Target: when Port is emitted with message -- M, Target receives M. function Emit (Port : Component_Access; Msg : Message'Class) return Message'Class; -- Emit message Msg on Port. The reply is returned. procedure Emit_No_Reply (Port : Component_Access; Msg : Message'Class); -- Emit message Msg on Port. The expected reply must be -- Null_Message, and will be discarded. procedure Destroy (Comp : in out Component); -- Destroy component Comp procedure Destroy (Comp : in out Component_Access); -- Destroy the component designated by Comp and deallocate it. ------------------------- -- Component factories -- ------------------------- type Component_Factory is access function return Component_Access; private type Component is abstract tagged limited null record; end PolyORB.Components; polyorb-2.8~20110207.orig/src/polyorb-tasking-threads.ads0000644000175000017500000002202411750740340022436 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . T A S K I N G . T H R E A D S -- -- -- -- S p e c -- -- -- -- Copyright (C) 2002-2011, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- This package provides the base abstract interface for threads, as well -- as clock time abstractions. -- Real implementations for the different profiles are given by extending -- Thread_Type and by registering the implementations of some procedures. -- Some terminology issues: -- in this package, and in its profile-specific implementations, -- a task designates the common abstraction of processors as provided -- by the Ada 95 language. -- A Thread will only denote the type defined in this package, -- which is only a container for the parameters of the task. with Ada.Unchecked_Deallocation; with System; package PolyORB.Tasking.Threads is pragma Preelaborate; type Parameterless_Procedure is access procedure; Default_Storage_Size : constant := 262_144; -------------- -- Runnable -- -------------- type Runnable is abstract tagged limited null record; procedure Run (R : not null access Runnable) is abstract; -- Runnable is a type for elementary work units. type Runnable_Access is access all Runnable'Class; procedure Free is new Ada.Unchecked_Deallocation (Runnable'Class, Runnable_Access); ---------------- -- Thread Ids -- ---------------- type Thread_Id is private; -- Type used for identifying Threads. An unique Thread_Id is assigned to -- each thread at creation time. function Null_Thread_Id return Thread_Id; pragma Inline (Null_Thread_Id); function Image (TID : Thread_Id) return String; -- Return a human-readable representation of TID function Current_Task return Thread_Id; -- Return the Thread associated to the current task function To_Address (TID : Thread_Id) return System.Address; pragma Inline (To_Address); function To_Thread_Id (A : System.Address) return Thread_Id; pragma Inline (To_Thread_Id); ----------------- -- Thread Type -- ----------------- type Thread_Type is abstract tagged limited null record; -- This type is a task proxy. It should be given to a task creation -- procedure, so that its main procedure will be run in a different task. -- The difference between a Runnable and a Thread is that a thread has some -- information about the scheduling, such as its priority. This type is -- derived by each concrete tasking profile. type Thread_Access is access all Thread_Type'Class; function Get_Thread_Id (T : access Thread_Type) return Thread_Id is abstract; -- Get the Thread_Id assigned to T -------------------- -- Thread_Factory -- -------------------- type Thread_Factory_Type is abstract tagged limited null record; -- A factory of Thread_Type objects. -- This type is derived by each concrete tasking profile. type Thread_Factory_Access is access all Thread_Factory_Type'Class; procedure Create_Task (Main : Parameterless_Procedure); -- Call Run_In_Task with the Thread_Factory object registered in this -- package, to run the code in Main, with other parameters defaulted. -- The resulting Thread_Access is discarded. function Run_In_Task (TF : access Thread_Factory_Type; Name : String := ""; Default_Priority : System.Any_Priority := System.Default_Priority; Storage_Size : Natural := 0; R : Runnable_Access) return Thread_Access is abstract; -- Create a Thread according to the tasking profile. R is the -- Runnable that will be executed by the task associated to the -- created Thread. Name is used as a key to look up configuration -- information. Default_Priority will be the priority of the task -- if no priority is given in the configuration file. A -- Storage_Size of 0 means the Thread will use default value for -- its stack size, else it will use the value provided by -- Storage_Size. -- If a preallocated task with appropriate parameters exists, the -- Runnable is executed by that task. -- Otherwise, if the tasking profile allows dynamic task allocation, -- a new task is created and executes the Runnable. -- Otherwise, a profile-dependant exception is raised. -- The deallocation of R after completion is delegated to C. -- It is assumed that C is dynamically allocated. function Run_In_Task (TF : access Thread_Factory_Type; Name : String := ""; Default_Priority : System.Any_Priority := System.Default_Priority; Storage_Size : Natural := 0; P : Parameterless_Procedure) return Thread_Access is abstract; -- This function plays the same role that the first one; the difference is -- that the code of the Thread is P. In some profiles, this function -- ensures that no dynamic allocation is done. A Storage_Size of 0 means -- the Thread will use the default value for its stack size, else it will -- use the value provided by Storage_Size. function Get_Current_Thread_Id (TF : access Thread_Factory_Type) return Thread_Id is abstract; -- Get the Thread object associated with the current task function Thread_Id_Image (TF : access Thread_Factory_Type; TID : Thread_Id) return String is abstract; -- Return a human-readable interpretation of TID function Get_Thread_Factory return Thread_Factory_Access; pragma Inline (Get_Thread_Factory); -- Get the Thread_Factory object registered in this package. -- This function can be called only after tasking has been initialized. procedure Register_Thread_Factory (TF : Thread_Factory_Access); -- Register the factory corresponding to the chosen tasking profile. -- Must be called exactly once per partition. procedure Set_Priority (TF : access Thread_Factory_Type; T : Thread_Id; P : System.Any_Priority) is abstract; -- Change the priority of the task T. Raise Tasking_Error if it is not -- permitted by the tasking profile in use. function Get_Priority (TF : access Thread_Factory_Type; T : Thread_Id) return System.Any_Priority is abstract; -- Return the priority of the task T. Raise Tasking_Error if it is not -- permitted by the tasking profile in use. procedure Relative_Delay (D : Duration); procedure Relative_Delay (TF : access Thread_Factory_Type; D : Duration) is abstract; -- Delay the calling task for duration D Node_Boot_Time : Duration; -- Node boot time as a duration elapsed since some unspecified epoch, set -- at initialization. ------------------- -- Task Counting -- ------------------- function Awake_Count return Natural; function Independent_Count return Natural; -- Wrappers for the functions below, passing the registered Thread_Factory function Awake_Count (TF : access Thread_Factory_Type) return Natural is abstract; -- Returns the number of awake tasks function Independent_Count (TF : access Thread_Factory_Type) return Natural is abstract; -- Returns the number of independent tasks private type Thread_Id is new System.Address; end PolyORB.Tasking.Threads; polyorb-2.8~20110207.orig/src/polyorb-dynamic_dict.adb0000644000175000017500000001014011750740340021750 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . D Y N A M I C _ D I C T -- -- -- -- B o d y -- -- -- -- Copyright (C) 2001-2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- A dynamic dictionnary of objects, indexed by Strings. with PolyORB.Utils.HFunctions.Hyper; with PolyORB.Utils.HTables.Perfect; package body PolyORB.Dynamic_Dict is -- A hash table that stores the Value associated with a String key package Perfect_HTable is new PolyORB.Utils.HTables.Perfect (Value, PolyORB.Utils.HFunctions.Hyper.Hash_Hyper_Parameters, PolyORB.Utils.HFunctions.Hyper.Default_Hash_Parameters, PolyORB.Utils.HFunctions.Hyper.Hash, PolyORB.Utils.HFunctions.Hyper.Next_Hash_Parameters); use Perfect_HTable; T : Table_Instance; T_Initialized : Boolean := False; procedure Ensure_Initialization; pragma Inline (Ensure_Initialization); -- Ensure that T is initialized. --------------------------- -- Ensure_Initialization -- --------------------------- procedure Ensure_Initialization is begin if T_Initialized then return; end if; Initialize (T); T_Initialized := True; end Ensure_Initialization; -------------- -- For_Each -- -------------- procedure For_Each (Action : Dict_Action) is It : Iterator; begin Ensure_Initialization; It := First (T); while not Last (It) loop Action (K => Key (It), V => Perfect_HTable.Value (It)); Next (It); end loop; end For_Each; ------------ -- Lookup -- ------------ function Lookup (K : String; Default : Value) return Value is begin Ensure_Initialization; return Lookup (T, K, Default); end Lookup; -------------- -- Register -- -------------- procedure Register (K : String; V : Value) is begin Ensure_Initialization; Insert (T, K, V); end Register; ----------- -- Reset -- ----------- procedure Reset is begin Finalize (T); Initialize (T); end Reset; ---------------- -- Unregister -- ---------------- procedure Unregister (K : String) is begin Ensure_Initialization; Delete (T, K); end Unregister; end PolyORB.Dynamic_Dict; polyorb-2.8~20110207.orig/src/polyorb-transport-connected.ads0000644000175000017500000001050011750740340023336 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . T R A N S P O R T . C O N N E C T E D -- -- -- -- S p e c -- -- -- -- Copyright (C) 2003-2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- Abstract connected transport service access points and transport -- endpoints. with PolyORB.Transport.Handlers; package PolyORB.Transport.Connected is use PolyORB.Asynch_Ev; ------------------ -- Access Point -- ------------------ type Connected_Transport_Access_Point is abstract new Transport_Access_Point with private; type Connected_Transport_Access_Point_Access is access all Connected_Transport_Access_Point'Class; procedure Accept_Connection (TAP : Connected_Transport_Access_Point; TE : out Transport_Endpoint_Access) is abstract; -- Accept a pending new connection on TAP and create a new associated -- TE. In case of error, TE is null on return. --------------- -- End Point -- --------------- type Connected_Transport_Endpoint is abstract new Transport_Endpoint with private; type Connected_Transport_Endpoint_Access is access all Connected_Transport_Endpoint'Class; -- Connected End point function Handle_Message (TE : not null access Connected_Transport_Endpoint; Msg : Components.Message'Class) return Components.Message'Class; function Is_Data_Available (TE : Connected_Transport_Endpoint; N : Natural) return Boolean is abstract; -- Return True iff N bytes or more are available on TE for direct read. -- Return False otherwise, or if TE does not support such a mechanism. private ----------------------------------------------- -- Connected transport service access points -- ----------------------------------------------- type Connected_TAP_AES_Event_Handler is new Handlers.TAP_AES_Event_Handler with null record; procedure Handle_Event (H : access Connected_TAP_AES_Event_Handler); type Connected_Transport_Access_Point is abstract new Transport_Access_Point with record Handler : aliased Connected_TAP_AES_Event_Handler; end record; ----------------------------------- -- Connected transport endpoints -- ----------------------------------- subtype Connected_TE_AES_Event_Handler is Handlers.TE_AES_Event_Handler; type Connected_Transport_Endpoint is abstract new Transport_Endpoint with record Handler : aliased Connected_TE_AES_Event_Handler; end record; end PolyORB.Transport.Connected; polyorb-2.8~20110207.orig/src/polyorb-representations-cdr.adb0000644000175000017500000027250511750740340023333 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . R E P R E S E N T A T I O N S . C D R -- -- -- -- B o d y -- -- -- -- Copyright (C) 2002-2011, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with Ada.Streams; with System.Address_Image; with PolyORB.Any.ObjRef; with PolyORB.Initialization; with PolyORB.Log; with PolyORB.Parameters; with PolyORB.Representations.CDR.Common; with PolyORB.Utils.Buffers; with PolyORB.Utils.Chained_Lists; with PolyORB.Utils.Strings; package body PolyORB.Representations.CDR is use Ada.Streams; use PolyORB.Any; use PolyORB.Any.TypeCode; use PolyORB.Buffers; use PolyORB.Errors; use PolyORB.Log; use PolyORB.Parameters; use PolyORB.Representations.CDR.Common; use PolyORB.Types; package L is new PolyORB.Log.Facility_Log ("polyorb.representations.cdr"); procedure O (Message : String; Level : Log_Level := Debug) renames L.Output; function C (Level : Log_Level := Debug) return Boolean renames L.Enabled; type Registry_Item is record Major : Octet; Minor : Octet; Factory : CDR_Representation_Factory; end record; package Factory_Lists is new Utils.Chained_Lists (Registry_Item); Factory_Registry : Factory_Lists.List; Enable_Fast_Path : Boolean; -- If True, some aggregates are allowed to be marshalled in one lump of -- data (instead of element per element), if they have a suitable memory -- representation. function Fast_Path_Element_Size (El_TCK : TCKind) return Types.Unsigned_Long; -- For a type that is a suitable element type for fast path marshalling -- of a sequence or array, return the type size. Otherwise return 0. procedure Fast_Path_Get_Info (ACC : access Aggregate_Content'Class; TC : TypeCode.Object_Ptr; Buffer : access Buffer_Type; Aggregate_Data : out System.Address; Aggregate_Size : out Stream_Element_Count; Aggregate_Alignment : out Alignment_Type); -- Obtain the data address, data length and CDR alignment to be used -- for fast path (un)marshalling of ACC, an aggregate of type TC, from/to -- Buffer. -- Note that Aggregate_Size and Aggregate_Alignment are set only when -- Aggregate_Data is not null. ------------------ -- TypeCode Ids -- ------------------ -- Numerical value associated to TypeCodes, as defined in CDR TC_Null_Id : constant PolyORB.Types.Unsigned_Long := 0; TC_Void_Id : constant PolyORB.Types.Unsigned_Long := 1; TC_Short_Id : constant PolyORB.Types.Unsigned_Long := 2; TC_Long_Id : constant PolyORB.Types.Unsigned_Long := 3; TC_Unsigned_Short_Id : constant PolyORB.Types.Unsigned_Long := 4; TC_Unsigned_Long_Id : constant PolyORB.Types.Unsigned_Long := 5; TC_Float_Id : constant PolyORB.Types.Unsigned_Long := 6; TC_Double_Id : constant PolyORB.Types.Unsigned_Long := 7; TC_Boolean_Id : constant PolyORB.Types.Unsigned_Long := 8; TC_Char_Id : constant PolyORB.Types.Unsigned_Long := 9; TC_Octet_Id : constant PolyORB.Types.Unsigned_Long := 10; TC_Any_Id : constant PolyORB.Types.Unsigned_Long := 11; TC_TypeCode_Id : constant PolyORB.Types.Unsigned_Long := 12; TC_Principal_Id : constant PolyORB.Types.Unsigned_Long := 13; TC_Object_Id : constant PolyORB.Types.Unsigned_Long := 14; TC_Struct_Id : constant PolyORB.Types.Unsigned_Long := 15; TC_Union_Id : constant PolyORB.Types.Unsigned_Long := 16; TC_Enum_Id : constant PolyORB.Types.Unsigned_Long := 17; TC_String_Id : constant PolyORB.Types.Unsigned_Long := 18; TC_Sequence_Id : constant PolyORB.Types.Unsigned_Long := 19; TC_Array_Id : constant PolyORB.Types.Unsigned_Long := 20; TC_Alias_Id : constant PolyORB.Types.Unsigned_Long := 21; TC_Except_Id : constant PolyORB.Types.Unsigned_Long := 22; TC_Long_Long_Id : constant PolyORB.Types.Unsigned_Long := 23; TC_Unsigned_Long_Long_Id : constant PolyORB.Types.Unsigned_Long := 24; TC_Long_Double_Id : constant PolyORB.Types.Unsigned_Long := 25; TC_Wchar_Id : constant PolyORB.Types.Unsigned_Long := 26; TC_Wide_String_Id : constant PolyORB.Types.Unsigned_Long := 27; TC_Fixed_Id : constant PolyORB.Types.Unsigned_Long := 28; TC_Value_Id : constant PolyORB.Types.Unsigned_Long := 29; TC_Valuebox_Id : constant PolyORB.Types.Unsigned_Long := 30; TC_Native_Id : constant PolyORB.Types.Unsigned_Long := 31; TC_Abstract_Interface_Id : constant PolyORB.Types.Unsigned_Long := 32; TC_Local_Interface_Id : constant PolyORB.Types.Unsigned_Long := 33; TC_Component_Id : constant PolyORB.Types.Unsigned_Long := 34; TC_Home_Id : constant PolyORB.Types.Unsigned_Long := 35; TC_Event_Id : constant PolyORB.Types.Unsigned_Long := 36; -- Additional value used in CDR to represent an indirect pointer to a -- previously marhsalled typecode. TC_Indirect : constant PolyORB.Types.Unsigned_Long := 16#ffffffff#; ----------------------------- -- Typecode map management -- ----------------------------- function Find_TC (Representation : access CDR_Representation'Class; Offset : Types.Long) return TypeCode.Object_Ptr; -- Return recorded TC at the specified offset. Constraint_Error is raised -- if there is no TC at that offset in the map. procedure Start_TC (Representation : access CDR_Representation'Class; TC_Ref : TypeCode.Object_Ptr; Offset : Types.Long; Complex : Boolean); -- Append a new typecode to the current typecode map. -- Offset is relative to the buffer where TC is being marshalled. If this -- is a nested TC (within an enclosing complex TC), this is the -- encapsulation buffer for the enclosing complex TC. -- Complex indicates whether this TC is itself a complex one, in which -- case the Current_Complex index in Representation is updated to point to -- the new entry. -- Implementation note: when unmarshalling a typecode, proper reference -- semantics on typecode objects are provided only after a parameter has -- been added to the typecode, as the parameters aggregate is allocated -- lazily. procedure End_TC (Representation : access CDR_Representation'Class; Complex : Boolean); -- Note that processing of current typecode has been completed. -- If Complex is True, Representation.Current_Complex is restored to -- the index of the enclosing complex TC. -- When unmarshalling a TypeCode, Start_TC and End_TC must each be -- called exactly once, and if the typecode encloses any nested typecode, -- then the nested typecode must be unmarshalled after the Start_TC call -- and before the End_TC call. function To_Absolute_Offset (Representation : access CDR_Representation'Class; Relative_Offset : Types.Long) return Types.Long; -- Convert the offset of a typecode relative to the innermost enclosing -- buffer (i.e. the innermost enclosing complex typecode) to an offset -- relative to the buffer containing the outermost complex typecode. function Image (E : TC_Map_Entry) return String; -- Return string representation of E, for debugging purposes --------------------------- -- Create_Representation -- --------------------------- function Create_Representation (Major : Types.Octet; Minor : Types.Octet) return CDR_Representation_Access is use Factory_Lists; use TC_Maps; Iter : Iterator := First (Factory_Registry); Result : CDR_Representation_Access; begin while not Last (Iter) loop if Value (Iter).Major = Major and then Value (Iter).Minor = Minor then Result := Value (Iter).Factory.all; return Result; end if; Next (Iter); end loop; return null; end Create_Representation; ------------ -- End_TC -- ------------ procedure End_TC (Representation : access CDR_Representation'Class; Complex : Boolean) is use TC_Maps; T : TC_Maps.Instance renames Representation.TC_Map; begin pragma Debug (C, O ("End_TC: Complex = " & Complex'Img & ", Current_Complex =" & Representation.Current_Complex'Img)); if not Complex then return; end if; Representation.Current_Complex := T.Table (Representation.Current_Complex).Enclosing_Complex; if Representation.Current_Complex = -1 then -- Outermost complex typecode completed pragma Debug (C, O ("End_TC: left outermost complex")); Deallocate (T); end if; end End_TC; ---------------------------- -- Fast_Path_Element_Size -- ---------------------------- function Fast_Path_Element_Size (El_TCK : TCKind) return Types.Unsigned_Long is begin case El_TCK is when Tk_Char | Tk_Octet => return 1; when Tk_Short | Tk_Ushort => return 2; when Tk_Long | Tk_Ulong => return 4; when others => return 0; end case; end Fast_Path_Element_Size; ------------------------ -- Fast_Path_Get_Info -- ------------------------ procedure Fast_Path_Get_Info (ACC : access Aggregate_Content'Class; TC : TypeCode.Object_Ptr; Buffer : access Buffer_Type; Aggregate_Data : out System.Address; Aggregate_Size : out Stream_Element_Count; Aggregate_Alignment : out Alignment_Type) is TCK : constant TCKind := TypeCode.Kind (TC); begin Aggregate_Data := System.Null_Address; if not Enable_Fast_Path then pragma Warnings (Off); -- OUT parameters Aggregate_Size and Aggregate_Element not set as -- they are meaningless when Aggregate_Data is null. return; pragma Warnings (On); end if; if TCK = Tk_Array or else TCK = Tk_Sequence then declare El_TC : constant TypeCode.Object_Ptr := Unwind_Typedefs (TypeCode.Content_Type (TC)); El_Size : constant Types.Unsigned_Long := Fast_Path_Element_Size (TypeCode.Kind (El_TC)); El_Count : Types.Unsigned_Long; begin if El_Size = 0 then -- Case of element type that does not allow fast path return; elsif El_Size > 1 and then Endianness (Buffer) /= Host_Order then -- Case of multi-byte elements, where the expected buffer -- endianness is not the host endianness: need to perform -- per-element byte swapping. return; end if; if TCK = Tk_Array then El_Count := TypeCode.Length (TC); else -- Aggregate elements count for a sequence has one additional -- element corresponding to the sequence length, which is not -- part of the fast path data. El_Count := Get_Aggregate_Count (ACC.all) - 1; end if; Aggregate_Data := Unchecked_Get_V (ACC); Aggregate_Alignment := Alignment_Of (Short_Short_Integer (El_Size)); Aggregate_Size := Stream_Element_Count (El_Count * El_Size); pragma Debug (C, O ("Fast_Path_Get_Info:" & Aggregate_Size'Img & " bytes (" & El_Count'Img & " elements) at " & System.Address_Image (Aggregate_Data) & ", align on" & Aggregate_Alignment'Img)); end; end if; end Fast_Path_Get_Info; ------------- -- Find_TC -- ------------- function Find_TC (Representation : access CDR_Representation'Class; Offset : Types.Long) return TypeCode.Object_Ptr is use TC_Maps; T : TC_Maps.Instance renames Representation.TC_Map; Lo : Types.Long := First (T); Hi : Types.Long := Last (T); Cur : Types.Long; begin pragma Debug (C, O ("Find_TC: Offset =" & Offset'Img)); -- Dichotomic search in map, assumes that entries are in ascending -- offset order. while Lo <= Hi loop Cur := (Lo + Hi) / 2; if T.Table (Cur).Offset = Offset then pragma Debug (C, O ("Find_TC: found at" & Cur'Img)); return T.Table (Cur).TC_Ref; elsif T.Table (Cur).Offset < Offset then Lo := Cur + 1; else Hi := Cur - 1; end if; end loop; pragma Debug (C, O ("Find_TC: not found")); raise Constraint_Error; end Find_TC; ----------- -- Image -- ----------- function Image (E : TC_Map_Entry) return String is begin return "TC@" & E.Offset'Img & ": " & System.Address_Image (E.TC_Ref.all'Address) & " encl =" & E.Enclosing_Complex'Img; end Image; ---------------- -- Initialize -- ---------------- procedure Initialize; procedure Initialize is begin Enable_Fast_Path := Get_Conf ("cdr", "enable_fast_path", Default => True); end Initialize; -------------- -- Marshall -- -------------- procedure Marshall (Buffer : access Buffer_Type; Representation : access CDR_Representation'Class; Data : PolyORB.Any.Any) is E : Errors.Error_Container; Data_C : Any_Container'Class renames Get_Container (Data).all; begin pragma Debug (C, O ("Marshall (Any): enter")); Marshall (Buffer, Representation, Get_Type_Obj (Data_C), E); pragma Assert (not Found (E)); -- ??? should propagate error appropriately pragma Debug (C, O ("Marshall (Any): type marshalled")); Marshall_From_Any (Representation, Buffer, Data_C, E); pragma Assert (not Found (E)); -- ??? should propagate error appropriately pragma Debug (C, O ("Marshall (Any): end")); end Marshall; -------------- -- Marshall -- -------------- procedure Marshall (Buffer : access Buffer_Type; R : access CDR_Representation'Class; Data : TypeCode.Object_Ptr; Error : in out Errors.Error_Container) is Complex_Buffer : Buffer_Access; Nb : PolyORB.Types.Unsigned_Long; begin pragma Debug (C, O ("Marshall (Typecode): enter, kind = " & TCKind'Image (TypeCode.Kind (Data)))); case TypeCode.Kind (Data) is when Tk_Null => Marshall (Buffer, TC_Null_Id); when Tk_Void => Marshall (Buffer, TC_Void_Id); when Tk_Short => Marshall (Buffer, TC_Short_Id); when Tk_Long => Marshall (Buffer, TC_Long_Id); when Tk_Ushort => Marshall (Buffer, TC_Unsigned_Short_Id); when Tk_Ulong => Marshall (Buffer, TC_Unsigned_Long_Id); when Tk_Float => Marshall (Buffer, TC_Float_Id); when Tk_Double => Marshall (Buffer, TC_Double_Id); when Tk_Boolean => Marshall (Buffer, TC_Boolean_Id); when Tk_Char => Marshall (Buffer, TC_Char_Id); when Tk_Octet => Marshall (Buffer, TC_Octet_Id); when Tk_Any => Marshall (Buffer, TC_Any_Id); when Tk_TypeCode => Marshall (Buffer, TC_TypeCode_Id); when Tk_Principal => Marshall (Buffer, TC_Principal_Id); when Tk_Objref => Marshall (Buffer, TC_Object_Id); Complex_Buffer := new Buffer_Type; Start_Encapsulation (Complex_Buffer); pragma Debug (C, O ("Marshall (TypeCode): marshalling the id")); Marshall (Complex_Buffer, Any.TypeCode.Id (Data)); pragma Debug (C, O ("Marshall (TypeCode): marshalling the name")); Marshall (Complex_Buffer, Any.TypeCode.Name (Data)); Marshall (Buffer, Encapsulate (Complex_Buffer)); Release (Complex_Buffer); when Tk_Struct => Marshall (Buffer, TC_Struct_Id); Complex_Buffer := new Buffer_Type; Start_Encapsulation (Complex_Buffer); pragma Debug (C, O ("Marshall (TypeCode): marshalling the id")); Marshall (Complex_Buffer, Any.TypeCode.Id (Data)); pragma Debug (C, O ("Marshall (TypeCode): marshalling the name")); Marshall (Complex_Buffer, Any.TypeCode.Name (Data)); Nb := Any.TypeCode.Member_Count (Data); pragma Debug (C, O ("Marshall (TypeCode): " & "marshalling" & Nb'Img & " members")); Marshall (Complex_Buffer, Nb); if Nb /= 0 then for J in 0 .. Nb - 1 loop pragma Debug (C, O ("Marshall (TypeCode): marshalling" & " member #" & J'Img & ": " & To_Standard_String (TypeCode.Member_Name (Data, J)))); Marshall (Complex_Buffer, TypeCode.Member_Name (Data, J)); pragma Debug (C, O ("Marshall (TypeCode): marshalling " & "member type: " & TCKind'Image (TypeCode.Kind (TypeCode.Member_Type (Data, J))))); Marshall (Complex_Buffer, R, TypeCode.Member_Type (Data, J), Error); exit when Found (Error); pragma Debug (C, O ("Marshall (TypeCode): " & "member marshalled")); end loop; end if; pragma Debug (C, O ("Marshall: all members marshalled")); Marshall (Buffer, Encapsulate (Complex_Buffer)); Release (Complex_Buffer); when Tk_Union => Marshall (Buffer, TC_Union_Id); Complex_Buffer := new Buffer_Type; Start_Encapsulation (Complex_Buffer); Marshall (Complex_Buffer, Any.TypeCode.Id (Data)); Marshall (Complex_Buffer, Any.TypeCode.Name (Data)); Marshall (Complex_Buffer, R, TypeCode.Discriminator_Type (Data), Error); if Found (Error) then -- Do not proceed further in error case Nb := 0; else Marshall (Complex_Buffer, TypeCode.Default_Index (Data)); Nb := Any.TypeCode.Member_Count (Data); Marshall (Complex_Buffer, Nb); end if; -- Need an explicit guard for the 0 case because Nb is a -- Types.Unsigned_Long, and Nb - 1 underflows in that case. if Nb /= 0 then for J in 0 .. Nb - 1 loop Marshall_From_Any (R, Complex_Buffer, TypeCode.Member_Label (Data, J).all, Error); exit when Found (Error); Marshall (Complex_Buffer, TypeCode.Member_Name (Data, J)); Marshall (Complex_Buffer, R, TypeCode.Member_Type (Data, J), Error); exit when Found (Error); end loop; end if; Marshall (Buffer, Encapsulate (Complex_Buffer)); Release (Complex_Buffer); when Tk_Enum => Marshall (Buffer, TC_Enum_Id); Complex_Buffer := new Buffer_Type; Start_Encapsulation (Complex_Buffer); Marshall (Complex_Buffer, Any.TypeCode.Id (Data)); Marshall (Complex_Buffer, Any.TypeCode.Name (Data)); Nb := TypeCode.Member_Count (Data); Marshall (Complex_Buffer, Nb); if Nb /= 0 then for J in 0 .. Nb - 1 loop Marshall (Complex_Buffer, Any.TypeCode.Member_Name (Data, J)); end loop; end if; Marshall (Buffer, Encapsulate (Complex_Buffer)); Release (Complex_Buffer); when Tk_String => Marshall (Buffer, TC_String_Id); Marshall (Buffer, TypeCode.Length (Data)); when Tk_Sequence => Marshall (Buffer, TC_Sequence_Id); Complex_Buffer := new Buffer_Type; Start_Encapsulation (Complex_Buffer); Marshall (Complex_Buffer, R, TypeCode.Content_Type (Data), Error); Marshall (Complex_Buffer, TypeCode.Length (Data)); Marshall (Buffer, Encapsulate (Complex_Buffer)); Release (Complex_Buffer); when Tk_Array => Marshall (Buffer, TC_Array_Id); Complex_Buffer := new Buffer_Type; Start_Encapsulation (Complex_Buffer); Marshall (Complex_Buffer, R, TypeCode.Content_Type (Data), Error); Marshall (Complex_Buffer, TypeCode.Length (Data)); Marshall (Buffer, Encapsulate (Complex_Buffer)); Release (Complex_Buffer); when Tk_Alias => Marshall (Buffer, TC_Alias_Id); Complex_Buffer := new Buffer_Type; Start_Encapsulation (Complex_Buffer); Marshall (Complex_Buffer, Any.TypeCode.Id (Data)); Marshall (Complex_Buffer, Any.TypeCode.Name (Data)); Marshall (Complex_Buffer, R, TypeCode.Content_Type (Data), Error); Marshall (Buffer, Encapsulate (Complex_Buffer)); Release (Complex_Buffer); when Tk_Except => Marshall (Buffer, TC_Except_Id); Complex_Buffer := new Buffer_Type; Start_Encapsulation (Complex_Buffer); Marshall (Complex_Buffer, Any.TypeCode.Id (Data)); Marshall (Complex_Buffer, Any.TypeCode.Name (Data)); Nb := TypeCode.Member_Count (Data); Marshall (Complex_Buffer, Nb); if Nb /= 0 then for J in 0 .. Nb - 1 loop Marshall (Complex_Buffer, Any.TypeCode.Member_Name (Data, J)); Marshall (Complex_Buffer, R, Any.TypeCode.Member_Type (Data, J), Error); exit when Found (Error); end loop; end if; Marshall (Buffer, Encapsulate (Complex_Buffer)); Release (Complex_Buffer); when Tk_Longlong => Marshall (Buffer, TC_Long_Long_Id); when Tk_Ulonglong => Marshall (Buffer, TC_Unsigned_Long_Long_Id); when Tk_Longdouble => Marshall (Buffer, TC_Long_Double_Id); when Tk_Widechar => Marshall (Buffer, TC_Wchar_Id); when Tk_Wstring => Marshall (Buffer, TC_Wide_String_Id); Marshall (Buffer, TypeCode.Length (Data)); when Tk_Fixed => Marshall (Buffer, TC_Fixed_Id); Marshall (Buffer, TypeCode.Fixed_Digits (Data)); Marshall (Buffer, TypeCode.Fixed_Scale (Data)); when Tk_Value => Marshall (Buffer, TC_Value_Id); Complex_Buffer := new Buffer_Type; Start_Encapsulation (Complex_Buffer); Marshall (Complex_Buffer, Any.TypeCode.Id (Data)); Marshall (Complex_Buffer, Any.TypeCode.Name (Data)); Marshall (Complex_Buffer, TypeCode.Type_Modifier (Data)); Marshall (Complex_Buffer, R, TypeCode.Concrete_Base_Type (Data), Error); if Found (Error) then -- Do not proceed further in error case Nb := 0; else Nb := TypeCode.Member_Count (Data); end if; Marshall (Complex_Buffer, Nb); if Nb /= 0 then for J in 0 .. Nb - 1 loop Marshall (Complex_Buffer, TypeCode.Member_Name (Data, J)); Marshall (Complex_Buffer, R, TypeCode.Member_Type (Data, J), Error); exit when Found (Error); Marshall (Complex_Buffer, TypeCode.Member_Visibility (Data, J)); end loop; end if; Marshall (Buffer, Encapsulate (Complex_Buffer)); Release (Complex_Buffer); when Tk_Valuebox => Marshall (Buffer, TC_Valuebox_Id); Complex_Buffer := new Buffer_Type; Start_Encapsulation (Complex_Buffer); Marshall (Complex_Buffer, Any.TypeCode.Id (Data)); Marshall (Complex_Buffer, Any.TypeCode.Name (Data)); Marshall (Complex_Buffer, R, TypeCode.Content_Type (Data), Error); if not Found (Error) then Marshall (Buffer, Encapsulate (Complex_Buffer)); end if; Release (Complex_Buffer); when Tk_Native => Marshall (Buffer, TC_Native_Id); Complex_Buffer := new Buffer_Type; Start_Encapsulation (Complex_Buffer); Marshall (Complex_Buffer, Any.TypeCode.Id (Data)); Marshall (Complex_Buffer, Any.TypeCode.Name (Data)); Marshall (Buffer, Encapsulate (Complex_Buffer)); Release (Complex_Buffer); when Tk_Abstract_Interface => Marshall (Buffer, TC_Abstract_Interface_Id); Complex_Buffer := new Buffer_Type; Start_Encapsulation (Complex_Buffer); Marshall (Complex_Buffer, Any.TypeCode.Id (Data)); Marshall (Complex_Buffer, Any.TypeCode.Name (Data)); Marshall (Buffer, Encapsulate (Complex_Buffer)); Release (Complex_Buffer); when Tk_Local_Interface => Marshall (Buffer, TC_Local_Interface_Id); Complex_Buffer := new Buffer_Type; Start_Encapsulation (Complex_Buffer); Marshall (Complex_Buffer, Any.TypeCode.Id (Data)); Marshall (Complex_Buffer, Any.TypeCode.Name (Data)); Marshall (Buffer, Encapsulate (Complex_Buffer)); Release (Complex_Buffer); when Tk_Component => Marshall (Buffer, TC_Component_Id); Complex_Buffer := new Buffer_Type; Start_Encapsulation (Complex_Buffer); Marshall (Complex_Buffer, Any.TypeCode.Id (Data)); Marshall (Complex_Buffer, Any.TypeCode.Name (Data)); Marshall (Buffer, Encapsulate (Complex_Buffer)); Release (Complex_Buffer); when Tk_Home => Marshall (Buffer, TC_Home_Id); Complex_Buffer := new Buffer_Type; Start_Encapsulation (Complex_Buffer); Marshall (Complex_Buffer, Any.TypeCode.Id (Data)); Marshall (Complex_Buffer, Any.TypeCode.Name (Data)); Marshall (Buffer, Encapsulate (Complex_Buffer)); Release (Complex_Buffer); when Tk_Event => Marshall (Buffer, TC_Event_Id); Complex_Buffer := new Buffer_Type; Start_Encapsulation (Complex_Buffer); Marshall (Complex_Buffer, Any.TypeCode.Id (Data)); Marshall (Complex_Buffer, Any.TypeCode.Name (Data)); Marshall (Complex_Buffer, TypeCode.Type_Modifier (Data)); Marshall (Complex_Buffer, R, TypeCode.Concrete_Base_Type (Data), Error); declare Nb : constant PolyORB.Types.Unsigned_Long := TypeCode.Member_Count (Data); begin Marshall (Complex_Buffer, Nb); if Nb /= 0 then for J in 0 .. Nb - 1 loop Marshall (Complex_Buffer, TypeCode.Member_Name (Data, J)); Marshall (Complex_Buffer, R, TypeCode.Member_Type (Data, J), Error); exit when Found (Error); Marshall (Complex_Buffer, TypeCode.Member_Visibility (Data, J)); end loop; end if; end; Marshall (Buffer, Encapsulate (Complex_Buffer)); Release (Complex_Buffer); end case; pragma Debug (C, O ("Marshall (Typecode): end")); end Marshall; ----------------------- -- Marshall_From_Any -- ----------------------- procedure Marshall_From_Any (R : access CDR_Representation; Buffer : access Buffer_Type; CData : Any.Any_Container'Class; Error : in out Errors.Error_Container) is Data_Type : constant TypeCode.Object_Ptr := Any.Unwind_Typedefs (Get_Type_Obj (CData)); procedure Marshall_Aggregate_Element (TC : TypeCode.Object_Ptr; ACC : access Aggregate_Content'Class; Index : Types.Unsigned_Long); -- Marshall the Index'th element for aggregate ACC, of type TC procedure Marshall_Aggregate_Element (TC : TypeCode.Object_Ptr; ACC : access Aggregate_Content'Class; Index : Types.Unsigned_Long) is El_M : aliased Mechanism := By_Value; El_CC : aliased Content'Class := Get_Aggregate_Element (ACC, TC, Index, El_M'Access); El_C : Any_Container; begin Set_Type (El_C, TC); Set_Value (El_C, El_CC'Unchecked_Access); Marshall_From_Any (R, Buffer, El_C, Error); end Marshall_Aggregate_Element; TCK : constant TCKind := TypeCode.Kind (Data_Type); begin pragma Debug (C, O ("Marshall_From_Any: enter")); pragma Debug (C, O ("Marshall_From_Any: CData = " & Image (CData))); case TCK is when Tk_Null | Tk_Void => null; when Tk_Short => Marshall (Buffer, PolyORB.Types.Short'(From_Any (CData))); when Tk_Long => Marshall (Buffer, PolyORB.Types.Long'(From_Any (CData))); when Tk_Ushort => Marshall (Buffer, PolyORB.Types.Unsigned_Short'(From_Any (CData))); when Tk_Ulong => Marshall (Buffer, PolyORB.Types.Unsigned_Long'(From_Any (CData))); when Tk_Float => Marshall (Buffer, PolyORB.Types.Float'(From_Any (CData))); when Tk_Double => Marshall (Buffer, PolyORB.Types.Double'(From_Any (CData))); when Tk_Boolean => Marshall (Buffer, PolyORB.Types.Boolean'(From_Any (CData))); when Tk_Char => Marshall (CDR_Representation'Class (R.all), Buffer, PolyORB.Types.Char'(From_Any (CData)), Error); when Tk_Octet => Marshall (Buffer, PolyORB.Types.Octet'(From_Any (CData))); when Tk_Any => Marshall (Buffer, CDR_Representation'Class (R.all)'Access, PolyORB.Any.Any'(From_Any (CData))); when Tk_TypeCode => Marshall (Buffer, CDR_Representation'Class (R.all)'Access, Object_Of (TypeCode.Local_Ref'(From_Any (CData))), Error); when Tk_Principal => -- FIXME: TBD raise Program_Error; when Tk_Objref => Marshall (Buffer, PolyORB.Any.ObjRef.From_Any (CData)); when Tk_Union => declare ACC : Aggregate_Content'Class renames Aggregate_Content'Class (Get_Value (CData).all); Label_TC : constant TypeCode.Object_Ptr := Any.TypeCode.Discriminator_Type (Data_Type); Label_M : aliased Mechanism := By_Value; Label_CC : aliased Content'Class := Get_Aggregate_Element (ACC'Access, Label_TC, 0, Label_M'Access); Label_C : Any_Container; begin Set_Type (Label_C, Label_TC); Set_Value (Label_C, Label_CC'Unchecked_Access); Marshall_From_Any (R, Buffer, Label_C, Error); if Found (Error) then return; end if; pragma Debug (C, O ("Marshall_From_Any: " & "union label marshalled")); declare Member_TC : constant Any.TypeCode.Object_Ptr := Any.TypeCode.Member_Type_With_Label (Data_Type, Label_C); begin -- Member_TC may be void in case there is no union member -- for this label. if Any.TypeCode.Kind (Member_TC) /= Tk_Void then pragma Assert (Any.Get_Aggregate_Count (ACC) = 2); Marshall_Aggregate_Element (Member_TC, ACC'Access, 1); else pragma Assert (Any.Get_Aggregate_Count (ACC) = 1); pragma Debug (C, O ("Marshall_From_Any: " & "union with no member for this label")); null; end if; end; if Found (Error) then return; end if; pragma Debug (C, O ("Marshall_From_Any: union member value marshalled")); end; when Tk_Enum => Marshall_Aggregate_Element (TypeCode.PTC_Unsigned_Long'Access, Aggregate_Content'Class (Get_Value (CData).all)'Access, 0); when Tk_String => -- We need to call the From_Any variant returning Standard.String -- here to account for both the bounded and unbounded cases. Marshall (CDR_Representation'Class (R.all), Buffer, To_PolyORB_String (From_Any (CData)), Error); when Tk_Struct | Tk_Except | Tk_Sequence | Tk_Array | Tk_Fixed => declare Nb : Types.Unsigned_Long; El_TC : TypeCode.Object_Ptr; ACC : Aggregate_Content'Class renames Aggregate_Content'Class (Get_Value (CData).all); begin -- Set Nb and El_TC case TCK is when Tk_Struct | Tk_Except => Nb := TypeCode.Member_Count (Data_Type); -- El_TC will be set once for each member, in the loop when Tk_Array => Nb := TypeCode.Length (Data_Type); El_TC := Unwind_Typedefs (TypeCode.Content_Type (Data_Type)); when Tk_Fixed => Nb := (Types.Unsigned_Long (TypeCode.Fixed_Digits (Data_Type)) + 2) / 2; El_TC := TypeCode.PTC_Octet'Access; when Tk_Sequence => Nb := Get_Aggregate_Count (ACC); El_TC := Unwind_Typedefs (TypeCode.Content_Type (Data_Type)); -- Except for first element, which is an unsigned long when others => -- Never happens raise Program_Error; end case; pragma Assert (Nb = Get_Aggregate_Count (ACC)); -- Avoid a check failure in the computation of the index loop -- below, in the case of a struct or exception without members. -- Nothing to marshall if Nb = 0. if Nb = 0 then return; end if; -- Check whether to use fast path marshalling declare use type System.Address; Aggregate_Data : System.Address; Aggregate_Size : Stream_Element_Count; Aggregate_Alignment : Alignment_Type; begin Fast_Path_Get_Info (ACC => ACC'Access, TC => Data_Type, Buffer => Buffer, Aggregate_Data => Aggregate_Data, Aggregate_Size => Aggregate_Size, Aggregate_Alignment => Aggregate_Alignment); if Aggregate_Data /= System.Null_Address then -- Here we can do fast path marshalling, and we have the -- underlying data address. -- Special case for sequences: first marshall element -- count. Note that there is an extra element in the -- aggregate, which is the count itself, and is not part -- of the fast path data. if TCK = Tk_Sequence then Marshall (Buffer, Nb - 1); end if; -- Now insert reference to data Pad_Align (Buffer, Aggregate_Alignment); Insert_Raw_Data (Buffer, Size => Aggregate_Size, Data => Aggregate_Data); return; end if; -- Fall through to per-element marshalling end; -- Here if marshalling aggregate element per element for J in 0 .. Nb - 1 loop if J = 0 and then TCK = Tk_Sequence then -- Special case of the first element of the sequence: -- check consistency (it must be equal to the actual -- element count). declare Count_C : Any_Container; Count_M : aliased Mechanism := By_Value; Count_CC : aliased Content'Class := Any.Get_Aggregate_Element (ACC'Access, TypeCode.PTC_Unsigned_Long'Access, 0, Count_M'Access); begin Set_Type (Count_C, TypeCode.TC_Unsigned_Long); Set_Value (Count_C, Count_CC'Unchecked_Access); if Nb - 1 /= From_Any (Count_C) then raise Constraint_Error; end if; end; Marshall_Aggregate_Element (TypeCode.PTC_Unsigned_Long'Access, ACC'Access, J); else case TCK is when Tk_Struct | Tk_Except => El_TC := TypeCode.Member_Type (Data_Type, J); when others => null; end case; Marshall_Aggregate_Element (El_TC, ACC'Access, J); end if; end loop; exception when others => -- Translate exception into a PolyORB runtime error. -- We conservatively set the completion status to -- Completed_Maybe, because at this point we do not have -- enough information to do a better determination. However, -- the caller may replace this value with a more specific -- one when the error is caught (Completed_No when failure -- is detected while marshalling a request, Completed_Yes -- when it occurs while marshalling a No_Exception reply). -- See similar discussion in Unmarshall_To_Any. Throw (Error, Marshal_E, System_Exception_Members' (Minor => 0, Completed => Completed_Maybe)); -- XXX What is the proper minor here? end; when Tk_Alias => -- Should never happen raise Program_Error; when Tk_Longlong => Marshall (Buffer, PolyORB.Types.Long_Long'(From_Any (CData))); when Tk_Ulonglong => Marshall (Buffer, PolyORB.Types.Unsigned_Long_Long'(From_Any (CData))); when Tk_Longdouble => Marshall (Buffer, PolyORB.Types.Long_Double'(From_Any (CData))); when Tk_Widechar => Marshall (CDR_Representation'Class (R.all), Buffer, PolyORB.Types.Wchar'(From_Any (CData)), Error); when Tk_Wstring => -- We need to call the From_Any variant returning -- Standard.Wide_String here to account for both the bounded and -- unbounded cases. Marshall (CDR_Representation'Class (R.all), Buffer, To_PolyORB_Wide_String (From_Any (CData)), Error); when Tk_Value => declare -- Aggregate_Nb, Member_Nb : PolyORB.Types.Unsigned_Long; -- Value_Modifier, Value_Type, -- Value_Visibility : PolyORB.Any.Any; -- Already_Marshalled : False_Seq := Empty_Seq; begin -- Marshall (Buffer, Default_Value_Tag); -- Aggregate_Nb := PolyORB.Any.Get_Aggregate_Count (Data); -- Member_Nb := (Aggregate_Nb - 3) / 3; -- I := 5; -- J := 0; -- while (J < Member_Nb) loop -- Member_Value := PolyORB.Any.Get_Aggregate_Element -- (Data, -- TypeCode.Member_Type (Data_Type, I + 3 * J), -- J); -- declare -- Member_Type : constant TypeCode.Local_Ref -- := PolyORB.Any.Get_Unwound_Type (Member_Value); -- begin -- case TypeCode.Kind (Member_Type) is -- when Tk_Value => -- Marshall_From_Any -- (Buffer, Value, Already_Marshalled, 0); -- when others => -- Marshall_From_Any (Buffer, Value); -- end case; -- end; -- end loop; raise Program_Error; end; when Tk_Valuebox => Marshall_Aggregate_Element (TypeCode.Member_Type (Data_Type, 0), Aggregate_Content'Class (Get_Value (CData).all)'Access, 0); when Tk_Native => -- FIXME: TBD raise Program_Error; when Tk_Abstract_Interface => -- FIXME: TBD raise Program_Error; when Tk_Local_Interface => Throw (Error, Marshal_E, System_Exception_Members' (Minor => 4, Completed => Completed_No)); when Tk_Component => -- FIXME : to be done raise Program_Error; when Tk_Home => -- FIXME : to be done raise Program_Error; when Tk_Event => -- FIXME : to be done raise Program_Error; end case; pragma Debug (C, O ("Marshall_From_Any: end")); end Marshall_From_Any; ---------------------- -- Register_Factory -- ---------------------- procedure Register_Factory (Major : Types.Octet; Minor : Types.Octet; Factory : CDR_Representation_Factory) is use Factory_Lists; Iter : Iterator := First (Factory_Registry); begin while not Last (Iter) loop if Value (Iter).Major = Major and then Value (Iter).Minor = Minor then raise Program_Error; end if; Next (Iter); end loop; Append (Factory_Registry, (Major, Minor, Factory)); end Register_Factory; ------------- -- Release -- ------------- procedure Release (Representation : in out CDR_Representation) is use TC_Maps; begin Deallocate (Representation.TC_Map); end Release; -------------- -- Start_TC -- -------------- procedure Start_TC (Representation : access CDR_Representation'Class; TC_Ref : Any.TypeCode.Object_Ptr; Offset : Types.Long; Complex : Boolean) is use TC_Maps; T : TC_Maps.Instance renames Representation.TC_Map; begin pragma Debug (C, O ("Start_TC: Complex = " & Complex'Img & ", Current_Complex =" & Representation.Current_Complex'Img & ", (rel) Offset =" & Offset'Img)); -- No mapping required for a simple typecode at the outermost level if Representation.Current_Complex = -1 then if not Complex then return; end if; Initialize (T); end if; Increment_Last (T); T.Table (Last (T)) := (Enclosing_Complex => Representation.Current_Complex, TC_Ref => TC_Ref, Offset => To_Absolute_Offset (Representation, Offset)); pragma Debug (C, O ("Start_TC: new entry @" & Last (T)'Img & ": " & Image (T.Table (Last (T))))); if Complex then Representation.Current_Complex := Last (T); end if; end Start_TC; ------------------------ -- To_Absolute_Offset -- ------------------------ function To_Absolute_Offset (Representation : access CDR_Representation'Class; Relative_Offset : Types.Long) return Types.Long is use TC_Maps; T : TC_Maps.Instance renames Representation.TC_Map; begin if Representation.Current_Complex /= -1 then -- Offset is relative to the start of the encapsulation buffer of the -- of the immediately enclosing typecode, which itself is offset by -- 8 bytes from its own absolute offset (typecode kind + -- encapsulation length). return Relative_Offset + T.Table (Representation.Current_Complex).Offset + 8; else return Relative_Offset; end if; end To_Absolute_Offset; ---------------- -- Unmarshall -- ---------------- function Unmarshall (Buffer : access Buffer_Type; Representation : access CDR_Representation'Class) return PolyORB.Any.Any is Result : Any.Any; TC : TypeCode.Local_Ref; E : Errors.Error_Container; begin pragma Debug (C, O ("Unmarshall (Any): enter")); Unmarshall (Buffer, Representation, TC, E); pragma Assert (not Found (E)); -- ??? Propagate error? Result := Get_Empty_Any (TC); Unmarshall_To_Any (Representation, Buffer, Get_Container (Result).all, E); pragma Assert (not Found (E)); -- ??? Propagate error? pragma Debug (C, O ("Unmarshall (Any): end")); return Result; end Unmarshall; ---------------- -- Unmarshall -- ---------------- procedure Unmarshall (Buffer : access Buffer_Type; R : access CDR_Representation'Class; Data : out TypeCode.Local_Ref; Error : in out Errors.Error_Container) is Complex : Boolean := False; -- Set true in the case of a complex typecode that may contain nested -- typecodes (False for empty and simple typecodes, but also for complex -- typecodes that contain only elementary types). Complex_Buffer : aliased Buffer_Type; TypeCode_Id : constant Types.Unsigned_Long := Unmarshall (Buffer); Offset : constant Types.Long := Types.Long (CDR_Position (Buffer)) - (TypeCode_Id'Size / 8); -- Offset is the start position of TypeCode_Id in the buffer. Note that -- we cannot take the position before the call to Unmarshall, because -- we might need to skip some alignment padding first. begin pragma Debug (C, O ("Unmarshall (TypeCode): enter")); case TypeCode_Id is when TC_Null_Id => Data := TypeCode.TC_Null; when TC_Void_Id => Data := TypeCode.TC_Void; when TC_Short_Id => Data := TypeCode.TC_Short; when TC_Long_Id => Data := TypeCode.TC_Long; when TC_Unsigned_Short_Id => Data := TypeCode.TC_Unsigned_Short; when TC_Unsigned_Long_Id => Data := TypeCode.TC_Unsigned_Long; when TC_Float_Id => Data := TypeCode.TC_Float; when TC_Double_Id => Data := TypeCode.TC_Double; when TC_Boolean_Id => Data := TypeCode.TC_Boolean; when TC_Char_Id => Data := TypeCode.TC_Char; when TC_Octet_Id => Data := TypeCode.TC_Octet; when TC_Any_Id => Data := TypeCode.TC_Any; when TC_TypeCode_Id => Data := TypeCode.TC_TypeCode; when TC_Principal_Id => Data := TypeCode.TC_Principal; when TC_Object_Id => Data := TypeCode.TC_Object; declare Complex_Encap : aliased Encapsulation := Unmarshall (Buffer); Id, Name : Types.String; begin Decapsulate (Complex_Encap'Access, Complex_Buffer'Access); Id := Types.String (Types.RepositoryId'(Unmarshall (Complex_Buffer'Access))); Name := Types.String (Types.Identifier'(Unmarshall (Complex_Buffer'Access))); TypeCode.Add_Parameter (Data, To_Any (Name)); TypeCode.Add_Parameter (Data, To_Any (Id)); end; when TC_Struct_Id => Data := TypeCode.TC_Struct; declare Complex_Encap : aliased Encapsulation := Unmarshall (Buffer); Id, Name : Types.String; Nb : Types.Unsigned_Long; Member_Name : Types.String; Member_Type : TypeCode.Local_Ref; begin Decapsulate (Complex_Encap'Access, Complex_Buffer'Access); Id := Types.String (Types.RepositoryId'(Unmarshall (Complex_Buffer'Access))); Name := Types.String (Types.Identifier'(Unmarshall (Complex_Buffer'Access))); TypeCode.Add_Parameter (Data, To_Any (Name)); TypeCode.Add_Parameter (Data, To_Any (Id)); Complex := True; Start_TC (R, Object_Of (Data), Offset, Complex => True); Nb := Unmarshall (Complex_Buffer'Access); if Nb /= 0 then for J in 0 .. Nb - 1 loop Member_Name := Types.String (Types.Identifier' (Unmarshall (Complex_Buffer'Access))); Unmarshall (Complex_Buffer'Access, R, Member_Type, Error); exit when Found (Error); Any.TypeCode.Add_Parameter (Data, To_Any (Member_Type)); Any.TypeCode.Add_Parameter (Data, To_Any (Member_Name)); end loop; end if; End_TC (R, Complex => True); end; when TC_Union_Id => Data := TypeCode.TC_Union; declare Complex_Encap : aliased Encapsulation := Unmarshall (Buffer); Id, Name, Member_Name : PolyORB.Types.String; Nb : PolyORB.Types.Unsigned_Long; -- Parameters for union TypeCode Default_Index : PolyORB.Types.Long; Discriminator_Type, Member_Type : TypeCode.Local_Ref; Member_Label : Any.Any; E : Error_Container; begin Decapsulate (Complex_Encap'Access, Complex_Buffer'Access); Id := Types.String (Types.RepositoryId'(Unmarshall (Complex_Buffer'Access))); Name := Types.String (Types.Identifier'(Unmarshall (Complex_Buffer'Access))); Any.TypeCode.Add_Parameter (Data, To_Any (Name)); Any.TypeCode.Add_Parameter (Data, To_Any (Id)); Complex := True; Start_TC (R, Object_Of (Data), Offset, Complex => True); Unmarshall (Complex_Buffer'Access, R, Discriminator_Type, Error); if Found (Error) then -- Do not proceed further in error case Nb := 0; else Default_Index := Unmarshall (Complex_Buffer'Access); Nb := Unmarshall (Complex_Buffer'Access); TypeCode.Add_Parameter (Data, To_Any (Discriminator_Type)); TypeCode.Add_Parameter (Data, To_Any (Default_Index)); end if; if Nb /= 0 then for J in 0 .. Nb - 1 loop Member_Label := Get_Empty_Any (Discriminator_Type); Unmarshall_To_Any (R, Complex_Buffer'Access, Get_Container (Member_Label).all, E); pragma Assert (not Found (E)); Member_Name := Types.String (Types.Identifier' (Unmarshall (Complex_Buffer'Access))); Unmarshall (Complex_Buffer'Access, R, Member_Type, Error); exit when Found (Error); TypeCode.Add_Parameter (Data, Member_Label); TypeCode.Add_Parameter (Data, To_Any (Member_Type)); TypeCode.Add_Parameter (Data, To_Any (Member_Name)); end loop; end if; End_TC (R, Complex => True); end; when TC_Enum_Id => Data := TypeCode.TC_Enum; declare Complex_Encap : aliased Encapsulation := Unmarshall (Buffer); Id, Name, Member_Name : PolyORB.Types.String; Nb : PolyORB.Types.Unsigned_Long; begin Decapsulate (Complex_Encap'Access, Complex_Buffer'Access); Id := Types.String (Types.RepositoryId'(Unmarshall (Complex_Buffer'Access))); Name := Types.String (Types.Identifier'(Unmarshall (Complex_Buffer'Access))); Any.TypeCode.Add_Parameter (Data, To_Any (Name)); Any.TypeCode.Add_Parameter (Data, To_Any (Id)); Complex := True; Start_TC (R, Object_Of (Data), Offset, Complex => True); Nb := Unmarshall (Complex_Buffer'Access); if Nb /= 0 then for J in 0 .. Nb - 1 loop Member_Name := Types.String (Types.Identifier' (Unmarshall (Complex_Buffer'Access))); TypeCode.Add_Parameter (Data, To_Any (Member_Name)); end loop; end if; End_TC (R, Complex => True); end; when TC_String_Id => declare Length : constant PolyORB.Types.Unsigned_Long := Unmarshall (Buffer); begin Data := Build_Complex_TC (Tk_String, (1 .. 1 => To_Any (Length))); end; when TC_Sequence_Id => Data := TypeCode.TC_Sequence; declare Complex_Encap : aliased Encapsulation := Unmarshall (Buffer); Length : PolyORB.Types.Unsigned_Long; Content_Type : TypeCode.Local_Ref; begin Decapsulate (Complex_Encap'Access, Complex_Buffer'Access); Complex := True; Start_TC (R, Object_Of (Data), Offset, Complex => True); Unmarshall (Complex_Buffer'Access, R, Content_Type, Error); if not Found (Error) then Length := Unmarshall (Complex_Buffer'Access); TypeCode.Add_Parameter (Data, To_Any (Length)); TypeCode.Add_Parameter (Data, To_Any (Content_Type)); end if; End_TC (R, Complex => True); end; when TC_Array_Id => Data := TypeCode.TC_Array; declare Complex_Encap : aliased Encapsulation := Unmarshall (Buffer); Length : PolyORB.Types.Unsigned_Long; Content_Type : TypeCode.Local_Ref; begin Decapsulate (Complex_Encap'Access, Complex_Buffer'Access); Complex := True; Start_TC (R, Object_Of (Data), Offset, Complex => True); Unmarshall (Complex_Buffer'Access, R, Content_Type, Error); if not Found (Error) then Length := Unmarshall (Complex_Buffer'Access); Any.TypeCode.Add_Parameter (Data, To_Any (Length)); Any.TypeCode.Add_Parameter (Data, To_Any (Content_Type)); end if; End_TC (R, Complex => True); end; when TC_Alias_Id => Data := TypeCode.TC_Alias; declare Complex_Encap : aliased Encapsulation := Unmarshall (Buffer); Id, Name : PolyORB.Types.String; Content_Type : TypeCode.Local_Ref; begin Decapsulate (Complex_Encap'Access, Complex_Buffer'Access); Id := Types.String (Types.RepositoryId'(Unmarshall (Complex_Buffer'Access))); Name := Types.String (Types.Identifier'(Unmarshall (Complex_Buffer'Access))); TypeCode.Add_Parameter (Data, To_Any (Name)); TypeCode.Add_Parameter (Data, To_Any (Id)); Complex := True; Start_TC (R, Object_Of (Data), Offset, Complex => True); Unmarshall (Complex_Buffer'Access, R, Content_Type, Error); if not Found (Error) then Any.TypeCode.Add_Parameter (Data, To_Any (Content_Type)); end if; End_TC (R, Complex => True); end; when TC_Except_Id => Data := TypeCode.TC_Except; declare Complex_Encap : aliased Encapsulation := Unmarshall (Buffer); Id, Name, Member_Name : PolyORB.Types.String; Nb : PolyORB.Types.Unsigned_Long; Member_Type : TypeCode.Local_Ref; begin Decapsulate (Complex_Encap'Access, Complex_Buffer'Access); Id := Types.String (Types.RepositoryId'(Unmarshall (Complex_Buffer'Access))); Name := Types.String (Types.Identifier'(Unmarshall (Complex_Buffer'Access))); Any.TypeCode.Add_Parameter (Data, To_Any (Name)); Any.TypeCode.Add_Parameter (Data, To_Any (Id)); Complex := True; Start_TC (R, Object_Of (Data), Offset, Complex => True); Nb := Unmarshall (Complex_Buffer'Access); if Nb /= 0 then for J in 0 .. Nb - 1 loop Member_Name := Types.String (Types.Identifier' (Unmarshall (Complex_Buffer'Access))); Unmarshall (Complex_Buffer'Access, R, Member_Type, Error); exit when Found (Error); TypeCode.Add_Parameter (Data, To_Any (Member_Type)); TypeCode.Add_Parameter (Data, To_Any (Member_Name)); end loop; end if; End_TC (R, Complex => True); end; when TC_Long_Long_Id => Data := TypeCode.TC_Long_Long; when TC_Unsigned_Long_Long_Id => Data := TypeCode.TC_Unsigned_Long_Long; when TC_Long_Double_Id => Data := TypeCode.TC_Long_Double; when TC_Wchar_Id => Data := TypeCode.TC_Wchar; when TC_Wide_String_Id => declare Length : constant PolyORB.Types.Unsigned_Long := Unmarshall (Buffer); begin Data := Build_Complex_TC (Tk_Wstring, (1 .. 1 => To_Any (Length))); end; when TC_Fixed_Id => Data := TypeCode.TC_Fixed; declare Fixed_Digits : PolyORB.Types.Unsigned_Short; Fixed_Scale : PolyORB.Types.Short; begin Fixed_Digits := Unmarshall (Buffer); Fixed_Scale := Unmarshall (Buffer); TypeCode.Add_Parameter (Data, To_Any (Fixed_Digits)); TypeCode.Add_Parameter (Data, To_Any (Fixed_Scale)); end; when TC_Value_Id => Data := TypeCode.TC_Value; declare Complex_Encap : aliased Encapsulation := Unmarshall (Buffer); Id, Name, Member_Name : PolyORB.Types.String; Type_Modifier, Visibility : PolyORB.Types.Short; Nb : PolyORB.Types.Unsigned_Long; Concrete_Base_Type, Member_Type : TypeCode.Local_Ref; begin Decapsulate (Complex_Encap'Access, Complex_Buffer'Access); Id := Types.String (Types.RepositoryId'(Unmarshall (Complex_Buffer'Access))); Name := Types.String (Types.Identifier'(Unmarshall (Complex_Buffer'Access))); Any.TypeCode.Add_Parameter (Data, To_Any (Name)); Any.TypeCode.Add_Parameter (Data, To_Any (Id)); Complex := True; Start_TC (R, Object_Of (Data), Offset, Complex => True); Type_Modifier := Unmarshall (Complex_Buffer'Access); Unmarshall (Complex_Buffer'Access, R, Concrete_Base_Type, Error); if Found (Error) then -- Do not proceed further in error case Nb := 0; else Nb := Unmarshall (Complex_Buffer'Access); end if; TypeCode.Add_Parameter (Data, To_Any (Type_Modifier)); TypeCode.Add_Parameter (Data, To_Any (Concrete_Base_Type)); if Nb /= 0 then for J in 0 .. Nb - 1 loop Member_Name := Types.String (Types.Identifier' (Unmarshall (Complex_Buffer'Access))); Unmarshall (Complex_Buffer'Access, R, Member_Type, Error); exit when Found (Error); Visibility := Unmarshall (Complex_Buffer'Access); TypeCode.Add_Parameter (Data, To_Any (Visibility)); TypeCode.Add_Parameter (Data, To_Any (Member_Type)); TypeCode.Add_Parameter (Data, To_Any (Member_Name)); end loop; end if; End_TC (R, Complex => True); end; when TC_Valuebox_Id => Data := TypeCode.TC_Valuebox; declare Complex_Encap : aliased Encapsulation := Unmarshall (Buffer); Id, Name : PolyORB.Types.String; Content_Type : TypeCode.Local_Ref; begin Decapsulate (Complex_Encap'Access, Complex_Buffer'Access); Id := Types.String (Types.RepositoryId'(Unmarshall (Complex_Buffer'Access))); Name := Types.String (Types.Identifier'(Unmarshall (Complex_Buffer'Access))); Any.TypeCode.Add_Parameter (Data, To_Any (Name)); Any.TypeCode.Add_Parameter (Data, To_Any (Id)); Complex := True; Start_TC (R, Object_Of (Data), Offset, Complex => True); Unmarshall (Complex_Buffer'Access, R, Content_Type, Error); if not Found (Error) then TypeCode.Add_Parameter (Data, To_Any (Content_Type)); end if; End_TC (R, Complex => True); end; when TC_Native_Id => Data := TypeCode.TC_Native; declare Complex_Encap : aliased Encapsulation := Unmarshall (Buffer); Id, Name : PolyORB.Types.String; begin Decapsulate (Complex_Encap'Access, Complex_Buffer'Access); Id := Types.String (Types.RepositoryId'(Unmarshall (Complex_Buffer'Access))); Name := Types.String (Types.Identifier'(Unmarshall (Complex_Buffer'Access))); TypeCode.Add_Parameter (Data, To_Any (Name)); TypeCode.Add_Parameter (Data, To_Any (Id)); end; when TC_Abstract_Interface_Id => Data := TypeCode.TC_Abstract_Interface; declare Complex_Encap : aliased Encapsulation := Unmarshall (Buffer); Id, Name : PolyORB.Types.String; begin Decapsulate (Complex_Encap'Access, Complex_Buffer'Access); Id := Types.String (Types.RepositoryId'(Unmarshall (Complex_Buffer'Access))); Name := Types.String (Types.Identifier'(Unmarshall (Complex_Buffer'Access))); TypeCode.Add_Parameter (Data, To_Any (Name)); TypeCode.Add_Parameter (Data, To_Any (Id)); end; when TC_Local_Interface_Id => Data := TypeCode.TC_Local_Interface; declare Complex_Encap : aliased Encapsulation := Unmarshall (Buffer); Id, Name : PolyORB.Types.String; begin Decapsulate (Complex_Encap'Access, Complex_Buffer'Access); Id := Types.String (Types.RepositoryId'(Unmarshall (Complex_Buffer'Access))); Name := Types.String (Types.Identifier'(Unmarshall (Complex_Buffer'Access))); TypeCode.Add_Parameter (Data, To_Any (Name)); TypeCode.Add_Parameter (Data, To_Any (Id)); end; when TC_Component_Id => Data := TypeCode.TC_Component; declare Complex_Encap : aliased Encapsulation := Unmarshall (Buffer); Id, Name : PolyORB.Types.String; begin Decapsulate (Complex_Encap'Access, Complex_Buffer'Access); Id := Types.String (Types.RepositoryId'(Unmarshall (Complex_Buffer'Access))); Name := Types.String (Types.Identifier'(Unmarshall (Complex_Buffer'Access))); TypeCode.Add_Parameter (Data, To_Any (Name)); TypeCode.Add_Parameter (Data, To_Any (Id)); end; when TC_Home_Id => Data := TypeCode.TC_Home; declare Complex_Encap : aliased Encapsulation := Unmarshall (Buffer); Id, Name : PolyORB.Types.String; begin Decapsulate (Complex_Encap'Access, Complex_Buffer'Access); Id := Types.String (Types.RepositoryId'(Unmarshall (Complex_Buffer'Access))); Name := Types.String (Types.Identifier'(Unmarshall (Complex_Buffer'Access))); TypeCode.Add_Parameter (Data, To_Any (Name)); TypeCode.Add_Parameter (Data, To_Any (Id)); end; when TC_Event_Id => Data := TypeCode.TC_Event; declare Complex_Encap : aliased Encapsulation := Unmarshall (Buffer); Id, Name, Member_Name : PolyORB.Types.String; Type_Modifier, Visibility : PolyORB.Types.Short; Nb : PolyORB.Types.Unsigned_Long; Concrete_Base_Type, Member_Type : TypeCode.Local_Ref; begin Decapsulate (Complex_Encap'Access, Complex_Buffer'Access); Id := Types.String (Types.RepositoryId'(Unmarshall (Complex_Buffer'Access))); Name := Types.String (Types.Identifier'(Unmarshall (Complex_Buffer'Access))); Type_Modifier := Unmarshall (Complex_Buffer'Access); Unmarshall (Complex_Buffer'Access, R, Concrete_Base_Type, Error); if Found (Error) then -- Do not attempt to proceed further in error case Nb := 0; else Nb := Unmarshall (Complex_Buffer'Access); end if; TypeCode.Add_Parameter (Data, To_Any (Name)); TypeCode.Add_Parameter (Data, To_Any (Id)); TypeCode.Add_Parameter (Data, To_Any (Type_Modifier)); TypeCode.Add_Parameter (Data, To_Any (Concrete_Base_Type)); if Nb /= 0 then for J in 0 .. Nb - 1 loop Member_Name := Types.String (Types.Identifier' (Unmarshall (Complex_Buffer'Access))); Unmarshall (Complex_Buffer'Access, R, Member_Type, Error); exit when Found (Error); Visibility := Unmarshall (Complex_Buffer'Access); TypeCode.Add_Parameter (Data, To_Any (Visibility)); TypeCode.Add_Parameter (Data, To_Any (Member_Type)); TypeCode.Add_Parameter (Data, To_Any (Member_Name)); end loop; end if; end; when TC_Indirect => declare Current : constant Types.Long := Types.Long (CDR_Position (Buffer)); Offset : constant Types.Long := Unmarshall (Buffer); begin if Offset >= -4 then raise Constraint_Error; end if; pragma Debug (C, O ("Unmarshall (TypeCode): @" & Current'Img & ": found indirect reference with relative offset " & Offset'Img)); Data := To_Ref (Find_TC (R, Offset => To_Absolute_Offset (R, Current) + Offset)); end; when others => raise Constraint_Error; end case; -- For an empty of simple typecode, record in map now if not Complex then Start_TC (R, Object_Of (Data), Offset, Complex => False); End_TC (R, Complex => False); end if; pragma Debug (C, O ("Unmarshall (TypeCode): end")); end Unmarshall; ----------------------- -- Unmarshall_To_Any -- ----------------------- procedure Unmarshall_To_Any (R : access CDR_Representation; Buffer : access Buffer_Type; CData : in out Any.Any_Container'Class; Error : in out Errors.Error_Container) is TC : constant TypeCode.Object_Ptr := Unwind_Typedefs (Get_Type_Obj (CData)); TCK : constant TCKind := TypeCode.Kind (TC); begin pragma Debug (C, O ("Unmarshall_To_Any: Any_Type is " & PolyORB.Any.TCKind'Image (TypeCode.Kind (TC)))); case TCK is when Tk_Null | Tk_Void => null; when Tk_Short => declare S : constant Short := Unmarshall (Buffer); begin pragma Debug (C, O ("Unmarshall_To_Any: value is " & PolyORB.Types.Short'Image (S))); Set_Any_Value (S, CData); end; when Tk_Long => declare L : constant Long := Unmarshall (Buffer); begin Set_Any_Value (L, CData); end; when Tk_Ushort => declare Us : constant Unsigned_Short := Unmarshall (Buffer); begin Set_Any_Value (Us, CData); end; when Tk_Ulong => declare Ul : constant Unsigned_Long := Unmarshall (Buffer); begin Set_Any_Value (Ul, CData); end; when Tk_Float => declare F : constant PolyORB.Types.Float := Unmarshall (Buffer); begin Set_Any_Value (F, CData); end; when Tk_Double => declare D : constant Double := Unmarshall (Buffer); begin pragma Debug (C, O ("Unmarshall_To_Any: value is " & Double'Image (D))); Set_Any_Value (D, CData); end; when Tk_Boolean => declare B : constant PolyORB.Types.Boolean := Unmarshall (Buffer); begin Set_Any_Value (B, CData); end; when Tk_Char => declare C : Char; begin Unmarshall (CDR_Representation'Class (R.all), Buffer, C, Error); Set_Any_Value (C, CData); end; when Tk_Octet => declare O : constant PolyORB.Types.Octet := Unmarshall (Buffer); begin Set_Any_Value (O, CData); end; when Tk_Any => declare A : constant Any.Any := Unmarshall (Buffer, CDR_Representation'Class (R.all)'Access); begin Set_Any_Value (A, CData); end; when Tk_TypeCode => declare TC : TypeCode.Local_Ref; begin Unmarshall (Buffer, R, TC, Error); if not Found (Error) then Set_Any_Value (TC, CData); end if; end; when Tk_Principal => -- FIXME : to be done raise Program_Error; when Tk_Objref => PolyORB.Any.ObjRef.Set_Any_Value (Unmarshall (Buffer), CData); when Tk_Struct | Tk_Except | Tk_Enum | Tk_Union | Tk_Sequence | Tk_Array | Tk_Fixed => -- Common code for aggregates -- See comments in PolyORB.Any spec for detailed structure of -- aggregate for each TCKind. declare Nb : Unsigned_Long; First_Index : Unsigned_Long; El_TC : TypeCode.Object_Ptr; begin -- For most aggregates, elements are stored at indices starting -- at 0, with the exception of sequences, where index 0 holds -- a copy of the sequence length, and elements are stored -- starting at index 1. First_Index := 0; case TCK is when Tk_Struct | Tk_Except => Nb := TypeCode.Member_Count (TC); when Tk_Enum => Nb := 1; El_TC := TypeCode.PTC_Unsigned_Long'Access; when Tk_Union => Nb := 2; -- Note: reset to 1 if there is no element associated -- with the unmarshalled switch value. when Tk_Sequence => declare Max_Length : constant Types.Unsigned_Long := TypeCode.Length (TC); begin Nb := Unmarshall (Buffer); if Max_Length > 0 and then Nb > Max_Length then raise Constraint_Error; end if; end; Nb := Nb + 1; First_Index := 1; El_TC := TypeCode.Content_Type (TC); when Tk_Array => Nb := TypeCode.Length (TC); El_TC := TypeCode.Content_Type (TC); when Tk_Fixed => Nb := (Types.Unsigned_Long (TypeCode.Fixed_Digits (TC)) + 2) / 2; El_TC := TypeCode.PTC_Octet'Access; when others => -- Never happens raise Program_Error; end case; if Is_Empty (CData) then Set_Any_Aggregate_Value (CData); end if; declare use type System.Address; ACC : Aggregate_Content'Class renames Aggregate_Content'Class (Get_Value (CData).all); Val_TC : TypeCode.Object_Ptr; -- Value typecode, computed from label TC in case of a union Aggregate_Data : System.Address; Aggregate_Size : Stream_Element_Count; Aggregate_Alignment : Alignment_Type; -- Information used for fast path unmarshalling begin Set_Aggregate_Count (ACC, Nb); -- Now that we have an aggregate of the correct size (i.e. -- in particular we have allocated space to store the -- unmarshalled data), check whether to use fast path -- unmarshalling. Fast_Path_Get_Info (ACC => ACC'Access, TC => TC, Buffer => Buffer, Aggregate_Data => Aggregate_Data, Aggregate_Size => Aggregate_Size, Aggregate_Alignment => Aggregate_Alignment); if Aggregate_Data /= System.Null_Address then -- Here we can do fast path unmarshalling, and we have -- the underlying data address. Note that in the case of -- fast path unmarshalling, data may be fragmented in the -- buffer, so do reassembly now. declare Data : Stream_Element_Array (1 .. Aggregate_Size); for Data'Address use Aggregate_Data; pragma Import (Ada, Data); begin Utils.Buffers.Align_Unmarshall_Copy (Buffer, Aggregate_Alignment, Data); end; return; end if; -- Fall through to per-element unmarshalling if TCK = Tk_Sequence then declare Len_M : aliased Mechanism := By_Reference; Len_CC : aliased Content'Class := Get_Aggregate_Element (ACC'Access, TypeCode.PTC_Unsigned_Long'Access, 0, Len_M'Access); Len_C : Any_Container; begin Set_Type (Len_C, TypeCode.TC_Unsigned_Long); if Len_CC not in No_Content then Set_Value (Len_C, Len_CC'Unchecked_Access); end if; Set_Any_Value (Nb - 1, Len_C); if Len_M = By_Value then Set_Aggregate_Element (ACC, TypeCode.PTC_Unsigned_Long'Access, 0, From_C => Len_C); Finalize_Value (Len_C); end if; end; end if; -- If there are no elements to get, return here. -- Note: Nb is a Types.Unsigned_Long, which is a modular -- integer type, so we must be careful to not underflow it -- by writing "Nb - 1" for the case of the zero value. if First_Index + 1 > Nb then return; end if; Unmarshall_Elements : for J in First_Index .. Nb - 1 loop pragma Debug (C, O ("Unmarshall_To_Any: get element")); -- Determine aggregate element typecode case TCK is when Tk_Struct | Tk_Except => El_TC := TypeCode.Member_Type (TC, J); when Tk_Union => if J = 0 then El_TC := TypeCode.Discriminator_Type (TC); else El_TC := Val_TC; end if; when Tk_Sequence | Tk_Array | Tk_Fixed | Tk_Enum => -- El_TC has been set once and for all before -- entering the elements loop null; when others => -- Never happens raise Program_Error; end case; -- Unmarshall element into shadow container declare El_C : Any_Container; El_M : aliased Mechanism := By_Reference; El_CC : aliased Content'Class := Get_Aggregate_Element (ACC'Access, El_TC, J, El_M'Access); begin Set_Type (El_C, El_TC); if El_CC not in No_Content then Set_Value (El_C, El_CC'Unchecked_Access); end if; pragma Debug (C, O ("Unmarshall_To_Any: about to " & "unmarshall a member")); Unmarshall_To_Any (CDR_Representation'Class (R.all)'Access, Buffer, El_C, Error); if Found (Error) then if El_M = By_Value then Finalize_Value (El_C); end if; return; end if; if TCK = Tk_Union and then J = 0 then Val_TC := TypeCode.Member_Type_With_Label (TC, El_C); end if; if El_M = By_Value then pragma Debug (C, O ("Setting element By_Value")); Set_Aggregate_Element (ACC, El_TC, J, From_C => El_C); Finalize_Value (El_C); end if; -- Handle the case of a union with no member for -- this label: nothing to do once the switch element -- has been set. if TCK = Tk_Union and then J = 0 and then Any.TypeCode.Kind (Val_TC) = Tk_Void then Set_Aggregate_Count (ACC, 1); exit Unmarshall_Elements; end if; end; end loop Unmarshall_Elements; end; exception when others => -- Translate exception into a PolyORB runtime error. -- We conservatively set the completion status to -- Completed_Maybe, because at this point we do not have -- enough information to do a better determination. -- However, the caller may replace this value with a more -- specific one when the error is caught (Completed_No -- when failure is detected while unmarshalling a request, -- Completed_Yes when it occurs while unmarshalling a -- No_Exception reply). See similar discussion in -- Marshall_From_Any. Throw (Error, Marshal_E, System_Exception_Members' (Minor => 0, Completed => Completed_Maybe)); -- XXX What is the proper minor here? end; when Tk_String => declare S : PolyORB.Types.String; begin Unmarshall (CDR_Representation'Class (R.all), Buffer, S, Error); declare Bound : constant Types.Unsigned_Long := TypeCode.Length (TC); begin if Bound = 0 then Set_Any_Value (S, CData); else Set_Any_Value (Types.To_Standard_String (S), Positive (Bound), CData); end if; end; end; when Tk_Alias => -- We should never reach this point raise Program_Error; when Tk_Longlong => declare Ll : constant Long_Long := Unmarshall (Buffer); begin Set_Any_Value (Ll, CData); end; when Tk_Ulonglong => declare Ull : constant Unsigned_Long_Long := Unmarshall (Buffer); begin Set_Any_Value (Ull, CData); end; when Tk_Longdouble => declare Ld : constant Long_Double := Unmarshall (Buffer); begin Set_Any_Value (Ld, CData); end; when Tk_Widechar => declare Wc : Wchar; begin Unmarshall (CDR_Representation'Class (R.all), Buffer, Wc, Error); Set_Any_Value (Wc, CData); end; when Tk_Wstring => declare Ws : PolyORB.Types.Wide_String; begin Unmarshall (CDR_Representation'Class (R.all), Buffer, Ws, Error); declare Bound : constant Types.Unsigned_Long := TypeCode.Length (TC); begin if Bound = 0 then Set_Any_Value (Ws, CData); else Set_Any_Value (Types.To_Wide_String (Ws), Positive (Bound), CData); end if; end; end; when Tk_Value => -- declare -- Val_Modifier,Arg: PolyORB.Any.Any; -- Nb: PolyORB.Types.Unsigned_Long:= -- TypeCode.Member_Count(TC); -- begin -- Set_Any_Aggregate_Value(Result); -- if Is_Empty then -- Val_Modifier:= Get_Empty_Any(TypeCode.Type_Modifier(TC)); -- else -- Val_Modifier:= Get_Aggregate_Element -- (Result, -- TypeCode.Discriminator_Type(TC), -- PolyORB.Types.Unsigned_Long(0)); -- end if; -- Unmarshall_To_Any(Buffer,Val_Modifier); -- if Is_Empty then -- Add_Aggregate_Element(Result,Val_Modifier); -- end if; -- if Nb /=0 then -- for I in 0 .. Nb-1 loop -- if Is_Empty then -- Arg:= Get_Empty_Any( TypeCode.Member_Visibility(TC)); -- else -- Arg:= Get_Aggregate_Element -- (Result, -- TypeCode.Member_Visibility(TC,I+1), -- I+1); -- end if; -- Unmarshall_To_Any(Buffer,Arg); -- if Is_Empty then -- Add_Aggregate_Element(Result,Arg); -- end if; -- end loop; -- end if; -- end; raise Program_Error; when Tk_Valuebox => -- declare -- Arg: Corba.Any; -- begin -- Set_Any_Aggregate_Value(Result); -- if Is_Empty then -- Arg:= Get_Empty_Any(TypeCode.Member_Type -- (TC,PolyORB.Types.Unsigned_Long(0))); -- else -- Arg:= PolyORB.Any.Get_Aggregate_Element -- (Result, -- TypeCode.Member_Type(TC, -- PolyORB.Types.Unsigned_Long(0))); -- end if; -- Unmarshall_To_Any(Buffer,Arg); -- if Is_Empty then -- Add_Aggregate_Element(Result, Arg); -- end if; -- end; raise Program_Error; when Tk_Native => -- FIXME : to be done raise Program_Error; when Tk_Abstract_Interface => -- FIXME : to be done raise Program_Error; when Tk_Local_Interface => Throw (Error, Marshal_E, System_Exception_Members' (Minor => 4, Completed => Completed_No)); when Tk_Component => raise Program_Error; when Tk_Home => raise Program_Error; when Tk_Event => raise Program_Error; end case; pragma Debug (C, O ("Unmarshall_To_Any: end")); end Unmarshall_To_Any; use PolyORB.Initialization; use PolyORB.Initialization.String_Lists; use PolyORB.Utils.Strings; begin Register_Module (Module_Info' (Name => +"representations.cdr", Conflicts => Empty, Depends => Empty, Provides => Empty, Implicit => False, Init => Initialize'Access, Shutdown => null)); end PolyORB.Representations.CDR; polyorb-2.8~20110207.orig/src/polyorb-call_back.adb0000644000175000017500000001053211750740340021221 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . C A L L _ B A C K -- -- -- -- B o d y -- -- -- -- Copyright (C) 2002-2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with Ada.Tags; with PolyORB.Log; with PolyORB.Servants.Iface; package body PolyORB.Call_Back is use PolyORB.Log; use PolyORB.Servants.Iface; use PolyORB.Requests; package L is new PolyORB.Log.Facility_Log ("polyorb.call_back"); procedure O (Message : String; Level : Log_Level := Debug) renames L.Output; function C (Level : Log_Level := Debug) return Boolean renames L.Enabled; -------------------- -- Handle_Message -- -------------------- function Handle_Message (CB_Handler : not null access Call_Back_Handler; S : Components.Message'Class) return Components.Message'Class is Nothing : Components.Null_Message; begin pragma Debug (C, O ("Handling message of type " & Ada.Tags.External_Tag (S'Tag))); if S in Executed_Request then declare Req : constant Request_Access := Executed_Request (S).Req; begin pragma Debug (C, O (Requests.Image (Req.all))); -- Execute Call Back function CB_Handler.CB_Function.all (Req.all, CB_Handler); -- Complete Request execution Req.Completed := True; -- Note : a complete terminaison may be required, it is left to -- the call back handler procedure. end; end if; return Nothing; end Handle_Message; -------------------------- -- Attach_Request_To_CB -- -------------------------- procedure Attach_Request_To_CB (Req : access PolyORB.Requests.Request; CB_Handler : PolyORB.Call_Back.CBH_Access) is begin Req.Requesting_Component := PolyORB.Components.Component_Access (CB_Handler); end Attach_Request_To_CB; -------------------------- -- Attach_Handler_To_CB -- -------------------------- procedure Attach_Handler_To_CB (CB_Handler : in out PolyORB.Call_Back.Call_Back_Handler; CB_Function : Handler) is begin CB_Handler.CB_Function := CB_Function; end Attach_Handler_To_CB; ---------------- -- Notepad_Of -- ---------------- function Notepad_Of (CB_Handler : access PolyORB.Call_Back.Call_Back_Handler) return PolyORB.Annotations.Notepad_Access is begin return CB_Handler.Notepad'Access; end Notepad_Of; end PolyORB.Call_Back; polyorb-2.8~20110207.orig/src/polyorb-tasking-mutexes.adb0000644000175000017500000000651411750740340022463 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . T A S K I N G . M U T E X E S -- -- -- -- B o d y -- -- -- -- Copyright (C) 2002-2008, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- A complete implementation of this package is provided for all -- tasking profiles. with PolyORB.Log; package body PolyORB.Tasking.Mutexes is use PolyORB.Log; package L is new PolyORB.Log.Facility_Log ("polyorb.tasking.mutexes"); procedure O (Message : String; Level : Log_Level := Debug) renames L.Output; function C (Level : Log_Level := Debug) return Boolean renames L.Enabled; My_Factory : Mutex_Factory_Access; -- Real factory, corresponding to the chosen tasking profile. ------------ -- Create -- ------------ procedure Create (M : out Mutex_Access; Name : String := "") is begin pragma Debug (C, O ("Create")); pragma Assert (My_Factory /= null); M := Create (My_Factory, Name); end Create; ------------- -- Destroy -- ------------- procedure Destroy (M : in out Mutex_Access) is begin pragma Debug (C, O ("Destroy")); pragma Assert (My_Factory /= null); Destroy (My_Factory, M); end Destroy; ---------------------------- -- Register_Mutex_Factory -- ---------------------------- procedure Register_Mutex_Factory (MF : Mutex_Factory_Access) is begin pragma Assert (My_Factory = null); My_Factory := MF; end Register_Mutex_Factory; end PolyORB.Tasking.Mutexes; polyorb-2.8~20110207.orig/src/polyorb-tasking-profiles-full_tasking-threads-static_priorities.adb0000644000175000017500000000727111750740340032463 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- POLYORB.TASKING.PROFILES.FULL_TASKING.THREADS.STATIC_PRIORITIES -- -- -- -- B o d y -- -- -- -- Copyright (C) 2003-2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with PolyORB.Initialization; with PolyORB.Utils.Strings; package body PolyORB.Tasking.Profiles.Full_Tasking.Threads.Static_Priorities is ------------------ -- Set_Priority -- ------------------ procedure Set_Priority (TF : access Full_Tasking_Thread_Factory_Type; T : PTT.Thread_Id; P : System.Any_Priority) is pragma Unreferenced (TF); pragma Unreferenced (T); pragma Unreferenced (P); begin raise Tasking_Error; end Set_Priority; ------------------ -- Get_Priority -- ------------------ function Get_Priority (TF : access Full_Tasking_Thread_Factory_Type; T : PTT.Thread_Id) return System.Any_Priority is pragma Unreferenced (TF); pragma Unreferenced (T); begin raise Tasking_Error; return 0; end Get_Priority; ---------------- -- Initialize -- ---------------- procedure Initialize; procedure Initialize is begin PolyORB.Tasking.Profiles.Full_Tasking.Threads.Set_Priority_P := Set_Priority'Access; PolyORB.Tasking.Profiles.Full_Tasking.Threads.Get_Priority_P := Get_Priority'Access; end Initialize; use PolyORB.Initialization; use PolyORB.Initialization.String_Lists; use PolyORB.Utils.Strings; begin Register_Module (Module_Info' (Name => +"tasking.profiles.full_tasking.thread.static_priorities", Conflicts => Empty, Depends => Empty, Provides => +"full_tasking.threads.priorities", Implicit => False, Init => Initialize'Access, Shutdown => null)); end PolyORB.Tasking.Profiles.Full_Tasking.Threads.Static_Priorities; polyorb-2.8~20110207.orig/src/polyorb-poa_policies-implicit_activation_policy-activation.adb0000644000175000017500000001230611750740340031544 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- POLYORB.POA_POLICIES.IMPLICIT_ACTIVATION_POLICY.ACTIVATION -- -- -- -- B o d y -- -- -- -- Copyright (C) 2003-2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with Ada.Tags; with PolyORB.POA; with PolyORB.POA_Policies.Id_Assignment_Policy.System; with PolyORB.POA_Policies.Servant_Retention_Policy.Retain; package body PolyORB.POA_Policies.Implicit_Activation_Policy.Activation is ------------ -- Create -- ------------ function Create return Activation_Policy_Access is begin return new Activation_Policy; end Create; ------------------------- -- Check_Compatibility -- ------------------------- procedure Check_Compatibility (Self : Activation_Policy; Other_Policies : AllPolicies; Error : in out PolyORB.Errors.Error_Container) is pragma Warnings (Off); pragma Unreferenced (Self); pragma Warnings (On); use Ada.Tags; use PolyORB.Errors; use PolyORB.POA_Policies.Servant_Retention_Policy; use PolyORB.POA_Policies.Servant_Retention_Policy.Retain; use PolyORB.POA_Policies.Id_Assignment_Policy; use PolyORB.POA_Policies.Id_Assignment_Policy.System; begin -- Implcit activation requires System_ID and Retain Policies. for J in Other_Policies'Range loop if Other_Policies (J).all in ServantRetentionPolicy'Class and then Other_Policies (J).all'Tag /= Retain_Policy'Tag then Throw (Error, InvalidPolicy_E, InvalidPolicy_Members'(Index => 0)); end if; if Other_Policies (J).all in IdAssignmentPolicy'Class and then Other_Policies (J).all'Tag /= System_Id_Policy'Tag then Throw (Error, InvalidPolicy_E, InvalidPolicy_Members'(Index => 0)); end if; end loop; end Check_Compatibility; --------------- -- Policy_Id -- --------------- function Policy_Id (Self : Activation_Policy) return String is pragma Warnings (Off); pragma Unreferenced (Self); pragma Warnings (On); begin return "IMPLICIT_ACTIVATION_POLICY.ACTIVATION"; end Policy_Id; ------------------------------- -- Implicit_Activate_Servant -- ------------------------------- procedure Implicit_Activate_Servant (Self : Activation_Policy; OA : PolyORB.POA_Types.Obj_Adapter_Access; P_Servant : Servants.Servant_Access; Hint : Object_Id_Access; Oid : out Object_Id_Access; Error : in out PolyORB.Errors.Error_Container) is pragma Unreferenced (Self); U_Oid : Unmarshalled_Oid; begin PolyORB.POA.Activate_Object (PolyORB.POA.Obj_Adapter_Access (OA), P_Servant, Hint, U_Oid, Error); Oid := U_Oid_To_Oid (U_Oid); end Implicit_Activate_Servant; ----------------------------------- -- Ensure_No_Implicit_Activation -- ----------------------------------- procedure Ensure_No_Implicit_Activation (Self : Activation_Policy; Error : in out PolyORB.Errors.Error_Container) is use PolyORB.Errors; pragma Unreferenced (Self); begin Throw (Error, WrongPolicy_E, Null_Members'(Null_Member)); end Ensure_No_Implicit_Activation; end PolyORB.POA_Policies.Implicit_Activation_Policy.Activation; polyorb-2.8~20110207.orig/src/polyorb-references.ads0000644000175000017500000002124611750740340021474 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . R E F E R E N C E S -- -- -- -- S p e c -- -- -- -- Copyright (C) 2001-2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- References on object exported by the ORB. with Ada.Streams; with Ada.Unchecked_Deallocation; with PolyORB.Annotations; with PolyORB.Binding_Data; with PolyORB.Components; with PolyORB.QoS; with PolyORB.Smart_Pointers; with PolyORB.Utils.Chained_Lists; with PolyORB.Utils.Strings; package PolyORB.References is type Profile_Array is array (Integer range <>) of Binding_Data.Profile_Access; type Profile_Array_Access is access all Profile_Array; procedure Free is new Ada.Unchecked_Deallocation (Profile_Array, Profile_Array_Access); type Ref is new PolyORB.Smart_Pointers.Ref with null record; -- An object reference of any kind. Nil_Ref : constant Ref; -- Nil reference function Is_Exported_Reference (The_Ref : Ref'Class) return Boolean; -- True iff The_Ref is a non null reference on an object -- exported by the ORB function Is_Equivalent (Left, Right : Ref'Class) return Boolean; -- True if we can conclusively determine locally that Left and Right -- are two references to the same object. function Same_Node (Left, Right : Ref'Class) return Boolean; -- True if we can determine that Left and Right designate entities on the -- same node. procedure Create_Reference (Profiles : Profile_Array; Type_Id : String; R : out Ref); -- Create a reference with Profiles as its profiles. -- The returned ref R is nil iff Profiles'Length = 0. function Profiles_Of (R : Ref) return Profile_Array; -- Return the list of profiles constituting Ref function Type_Id_Of (R : Ref) return String; -- Return the type identifier of Ref procedure Set_Type_Id (R : Ref; Type_Id : String); -- Set the Type_Id of the reference function Image (R : Ref) return String; -- For debugging purposes procedure String_To_Object (Str : String; The_Ref : out Ref); -- Convert a stringified representation of an object reference into an -- actual reference. -- Note: String_To_Object is a procedure so that it can be inherited -- when Ref is derived without requiring overload (Ada 95). -------------------------------------- -- Stream attributes for references -- -------------------------------------- -- PolyORB.References does not mandate any particular external -- representation for references. Instead, the stream attributes make -- indirect calls through a Ref_Streamer object, which must provide -- appropriate primitives. procedure Read (S : access Ada.Streams.Root_Stream_Type'Class; V : out Ref); for Ref'Read use Read; procedure Write (S : access Ada.Streams.Root_Stream_Type'Class; V : Ref); for Ref'Write use Write; ---------------------------- -- Annotations management -- ---------------------------- function Notepad_Of (R : Ref) return Annotations.Notepad_Access; type Ref_Ptr is access all Ref; procedure Deallocate is new Ada.Unchecked_Deallocation (Ref, Ref_Ptr); private type Binding_Info is record Binding_Object_Ref : Smart_Pointers.Ref; Binding_Profile : Binding_Data.Profile_Access; -- If a reference is already bound, the Binding_Object_Ref will -- designate the component that serves as the binding object, and -- Binding_Profile will designate the profile used to bind this -- reference. Binding_Profile is kept so we can determine the -- Object_Id of the object designated by the reference. end record; package Binding_Info_Lists is new Utils.Chained_Lists (Binding_Info, Doubly_Chained => True); procedure Get_Binding_Info (R : Ref'Class; QoS : PolyORB.QoS.QoS_Parameters; BOC : out Components.Component_Access; Pro : out Binding_Data.Profile_Access); -- Retrieve the binding object associated with R, if R is bound. -- Otherwise, return null. procedure Share_Binding_Info (Dest : Ref'Class; Source : Ref'Class); -- Needs comment??? Nil_Ref : constant Ref := (PolyORB.Smart_Pointers.Ref with null record); type Reference_Info is new PolyORB.Smart_Pointers.Non_Controlled_Entity with record Type_Id : Utils.Strings.String_Ptr; Profiles : Profile_Array_Access; -- The collection of tagged profiles that designate -- transport access points where this object can be -- contacted, together with the object ids to be used. -- A reference constitutes a surrogate for an object. -- When the surrogate is free, it is not linked -- to a binding object, and this component is null. -- When the profile (and thus the surrogate) is bound, -- this component denotes the associated binding object -- on the local ORB (= the Session). Binding_Info : Binding_Info_Lists.List; -- The list of binding objects used for reference bound. Notepad : aliased Annotations.Notepad; -- Reference_Info's notepad. The user is responsible for ensuring -- proper protection against incorrect concurrent accesses. end record; type Reference_Info_Access is access all Reference_Info'Class; function Ref_Info_Of (R : Ref'Class) return Reference_Info_Access; -- Obtain the object reference information from R. procedure Finalize (RI : in out Reference_Info); -- When an object reference is bound (i.e. associated at runtime with a -- transport service endpoint and a protocol stack), it becomes associated -- with a Binding_Object which will remain in existence until all -- references to the object have been finalized (at which time the -- transport connection and protocol stack will be torn down, as a result -- of finalizing the binding object). -- Note that Reference_Info must not be an Entity, because the Finalize -- operation would then be called *after*, not *before*, the controlled -- components of Reference_Info (including Profiles and -- Binding_Object_Ref) have been finalized. -- XXX the following declarations must be documented. type String_To_Object_Func is access function (Str : String) return Ref; procedure Register_String_To_Object (Prefix : String; Func : String_To_Object_Func); type Ref_Streamer is abstract tagged limited null record; type Ref_Streamer_Access is access all Ref_Streamer'Class; procedure Read (R : access Ref_Streamer; S : access Ada.Streams.Root_Stream_Type'Class; V : out Ref'Class) is abstract; procedure Write (R : access Ref_Streamer; S : access Ada.Streams.Root_Stream_Type'Class; V : Ref'Class) is abstract; The_Ref_Streamer : Ref_Streamer_Access; end PolyORB.References; polyorb-2.8~20110207.orig/src/polyorb-tasking-profiles.ads0000644000175000017500000000424611750740340022635 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . T A S K I N G . P R O F I L E S -- -- -- -- S p e c -- -- -- -- Copyright (C) 2002 Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by ACT Europe. -- -- (email: sales@act-europe.fr) -- -- -- ------------------------------------------------------------------------------ -- Childs of this packages are tasking profile specific packages package PolyORB.Tasking.Profiles is pragma Preelaborate; end PolyORB.Tasking.Profiles; polyorb-2.8~20110207.orig/src/polyorb-filters-iface.adb0000644000175000017500000000465711750740340022056 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . F I L T E R S . I F A C E -- -- -- -- B o d y -- -- -- -- Copyright (C) 2001-2005 Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by ACT Europe. -- -- (email: sales@act-europe.fr) -- -- -- ------------------------------------------------------------------------------ -- Messages exchanged by Filter components. package body PolyORB.Filters.Iface is procedure Expect_Data (Self : access Filter'Class; In_Buf : Buffers.Buffer_Access; Max : Ada.Streams.Stream_Element_Count) is begin Emit_No_Reply (Port => Lower (Self), Msg => Data_Expected' (In_Buf => In_Buf, Max => Max)); end Expect_Data; end PolyORB.Filters.Iface; polyorb-2.8~20110207.orig/src/polyorb-obj_adapters-simple.ads0000644000175000017500000001254411750740340023300 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . O B J _ A D A P T E R S . S I M P L E -- -- -- -- S p e c -- -- -- -- Copyright (C) 2001-2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- Simple implementation of a PolyORB Object Adapter. with PolyORB.Tasking.Mutexes; with PolyORB.Utils.Dynamic_Tables; package PolyORB.Obj_Adapters.Simple is pragma Elaborate_Body; type Simple_Obj_Adapter is new Obj_Adapter with private; procedure Create (OA : access Simple_Obj_Adapter); procedure Destroy (OA : access Simple_Obj_Adapter); procedure Export (OA : access Simple_Obj_Adapter; Obj : Servants.Servant_Access; Key : Objects.Object_Id_Access; Oid : out Objects.Object_Id_Access; Error : in out PolyORB.Errors.Error_Container); procedure Unexport (OA : access Simple_Obj_Adapter; Id : Objects.Object_Id_Access; Error : in out PolyORB.Errors.Error_Container); procedure Object_Key (OA : access Simple_Obj_Adapter; Id : Objects.Object_Id_Access; User_Id : out Objects.Object_Id_Access; Error : in out PolyORB.Errors.Error_Container); procedure Get_QoS (OA : access Simple_Obj_Adapter; Id : Objects.Object_Id; QoS : out PolyORB.QoS.QoS_Parameters; Error : in out PolyORB.Errors.Error_Container); -- In the Simple Object Adapter, the methods of an object -- are described using two factory functions (provided by -- the application layer) that construct an argument list -- and a result Any for a given method. type Parameter_Profile_Description is access function (Method : String) return Any.NVList.Ref; type Result_Profile_Description is access function (Method : String) return Any.Any; type Interface_Description is record PP_Desc : Parameter_Profile_Description; RP_Desc : Result_Profile_Description; end record; procedure Set_Interface_Description (OA : in out Simple_Obj_Adapter; Id : access Objects.Object_Id; If_Desc : Interface_Description); function Get_Empty_Arg_List (OA : access Simple_Obj_Adapter; Oid : access Objects.Object_Id; Method : String) return Any.NVList.Ref; function Get_Empty_Result (OA : access Simple_Obj_Adapter; Oid : access Objects.Object_Id; Method : String) return Any.Any; procedure Find_Servant (OA : access Simple_Obj_Adapter; Id : access Objects.Object_Id; Servant : out Servants.Servant_Access; Error : in out PolyORB.Errors.Error_Container); procedure Release_Servant (OA : access Simple_Obj_Adapter; Id : access Objects.Object_Id; Servant : in out Servants.Servant_Access); private type Object_Map_Entry is record Servant : Servants.Servant_Access; -- May be null (for empty entries) If_Desc : Interface_Description; end record; package Object_Map_Entry_Arrays is new PolyORB.Utils.Dynamic_Tables (Object_Map_Entry, Natural, 1, 10, 1); subtype Object_Map_Entry_Array is Object_Map_Entry_Arrays.Instance; subtype Simple_Executor is Servants.Executor; type Simple_Obj_Adapter is new Obj_Adapter with record Object_Map : Object_Map_Entry_Array; -- Object_Ids are the indices of the objects within the object map S_Exec : aliased Simple_Executor; Lock : PolyORB.Tasking.Mutexes.Mutex_Access; end record; end PolyORB.Obj_Adapters.Simple; polyorb-2.8~20110207.orig/src/polyorb-tasking-profiles-full_tasking-portable_mutexes.adb0000644000175000017500000001376311750740340030660 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- POLYORB.TASKING.PROFILES.FULL_TASKING.PORTABLE_MUTEXES -- -- -- -- B o d y -- -- -- -- Copyright (C) 2002-2008, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- Implementation of mutexes under the Full_Tasking profile. -- This is a variant that uses only standard Ada constructs. It is not -- used by default. with Ada.Unchecked_Deallocation; with PolyORB.Initialization; with PolyORB.Log; with PolyORB.Utils.Strings; package body PolyORB.Tasking.Profiles.Full_Tasking.Portable_Mutexes is use PolyORB.Log; package L is new PolyORB.Log.Facility_Log ("polyorb.tasking.profiles.full_tasking.mutexes"); procedure O (Message : String; Level : Log_Level := Debug) renames L.Output; function C (Level : Log_Level := Debug) return Boolean renames L.Enabled; ------------------------------------------------------------- -- Underlying protected object for Full_Tasking_Mutex_Type -- ------------------------------------------------------------- protected type Mutex_PO is -- Protected object which is the real implementation of -- Mutex_Type entry Enter; -- Real implementation of Enter (Mutex_Type). procedure Leave; -- Real implementation of Leave (Mutex_Type). private Locked : Boolean := False; -- False when the lock is free; else True; end Mutex_PO; ---------- -- Free -- ---------- procedure Free is new Ada.Unchecked_Deallocation (PTM.Mutex_Type'Class, PTM.Mutex_Access); procedure Free is new Ada.Unchecked_Deallocation (Mutex_PO, Mutex_PO_Access); ------------ -- Create -- ------------ function Create (MF : access Full_Tasking_Mutex_Factory_Type; Name : String := "") return PTM.Mutex_Access is pragma Warnings (Off); pragma Unreferenced (MF); pragma Unreferenced (Name); -- XXX The use of Name is not yet implemented pragma Warnings (On); M : constant Full_Tasking_Mutex_Access := new Full_Tasking_Mutex_Type; begin pragma Debug (C, O ("Create Mutex")); M.The_PO := new Mutex_PO; return PTM.Mutex_Access (M); end Create; ------------- -- Destroy -- ------------- procedure Destroy (MF : access Full_Tasking_Mutex_Factory_Type; M : in out PTM.Mutex_Access) is pragma Warnings (Off); pragma Unreferenced (MF); pragma Warnings (On); begin pragma Debug (C, O ("Destroy mutex")); Free (Full_Tasking_Mutex_Access (M).The_PO); Free (M); end Destroy; ----------- -- Enter -- ----------- procedure Enter (M : access Full_Tasking_Mutex_Type) is begin M.The_PO.Enter; end Enter; ----------- -- Leave -- ----------- procedure Leave (M : access Full_Tasking_Mutex_Type) is begin M.The_PO.Leave; end Leave; --------------- -- Mutex_PO -- --------------- protected body Mutex_PO is -------------------- -- Mutex_PO.Enter -- -------------------- entry Enter when not Locked is begin pragma Debug (C, O ("Enter mutex")); Locked := True; end Enter; -------------------- -- Mutex_PO.Leave -- -------------------- procedure Leave is begin pragma Assert (Locked); pragma Debug (C, O ("Leave mutex")); Locked := False; end Leave; end Mutex_PO; ---------------- -- Initialize -- ---------------- procedure Initialize; procedure Initialize is begin pragma Debug (C, O ("Initialize package Profiles.Full_Tasking.Mutexes")); PTM.Register_Mutex_Factory (PTM.Mutex_Factory_Access (The_Mutex_Factory)); end Initialize; use PolyORB.Initialization; use PolyORB.Initialization.String_Lists; use PolyORB.Utils.Strings; begin Register_Module (Module_Info' (Name => +"tasking.profiles.full_tasking.mutexes", Conflicts => Empty, Depends => Empty, Provides => +"tasking.mutexes", Implicit => False, Init => Initialize'Access, Shutdown => null)); end PolyORB.Tasking.Profiles.Full_Tasking.Portable_Mutexes; polyorb-2.8~20110207.orig/src/polyorb-poa_policies-thread_policy-main_thread.ads0000644000175000017500000000601111750740340027107 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- POLYORB.POA_POLICIES.THREAD_POLICY.MAIN_THREAD -- -- -- -- S p e c -- -- -- -- Copyright (C) 2003-2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ pragma Ada_2005; -- Implementation of the 'Main thread' POA Policy. with PolyORB.Components; with PolyORB.Requests; package PolyORB.POA_Policies.Thread_Policy.Main_Thread is type Main_Thread_Policy is new ThreadPolicy with private; type Main_Thread_Policy_Access is access all Main_Thread_Policy; function Create return Main_Thread_Policy_Access; procedure Check_Compatibility (Self : Main_Thread_Policy; Other_Policies : AllPolicies; Error : in out PolyORB.Errors.Error_Container); function Policy_Id (Self : Main_Thread_Policy) return String; private type Main_Thread_Policy is new ThreadPolicy with null record; type Main_Thread_Executor is new Servants.Executor with null record; overriding function Execute_In_Context (Self : access Main_Thread_Executor; Req : Requests.Request_Access; Requestor : Components.Component_Access) return Boolean; end PolyORB.POA_Policies.Thread_Policy.Main_Thread; ././@LongLink0000000000000000000000000000015000000000000011561 Lustar rootrootpolyorb-2.8~20110207.orig/src/polyorb-poa_policies-request_processing_policy-active_object_map_only.adbpolyorb-2.8~20110207.orig/src/polyorb-poa_policies-request_processing_policy-active_object_map_only.0000644000175000017500000001435011750740340033325 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- B O D Y -- -- -- -- B o d y -- -- -- -- Copyright (C) 2001-2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with Ada.Tags; with PolyORB.POA; with PolyORB.POA_Policies.Servant_Retention_Policy.Retain; package body PolyORB.POA_Policies.Request_Processing_Policy.Active_Object_Map_Only is use PolyORB.Errors; ------------ -- Create -- ------------ function Create return Active_Map_Only_Policy_Access is begin return new Active_Map_Only_Policy; end Create; ------------------------- -- Check_Compatibility -- ------------------------- procedure Check_Compatibility (Self : Active_Map_Only_Policy; Other_Policies : AllPolicies; Error : in out PolyORB.Errors.Error_Container) is pragma Warnings (Off); pragma Unreferenced (Self); pragma Warnings (On); use Ada.Tags; use PolyORB.POA_Policies.Servant_Retention_Policy; use PolyORB.POA_Policies.Servant_Retention_Policy.Retain; begin -- Active_Object_Map_Only requires Retain policy for J in Other_Policies'Range loop if Other_Policies (J).all in ServantRetentionPolicy'Class and then Other_Policies (J).all'Tag /= Retain_Policy'Tag then Throw (Error, InvalidPolicy_E, InvalidPolicy_Members'(Index => 0)); end if; end loop; end Check_Compatibility; --------------- -- Policy_Id -- --------------- function Policy_Id (Self : Active_Map_Only_Policy) return String is pragma Warnings (Off); pragma Unreferenced (Self); pragma Warnings (On); begin return "REQUEST_PROCESSING_POLICY.ACTIVE_MAP_ONLY"; end Policy_Id; ------------------- -- Id_To_Servant -- ------------------- procedure Id_To_Servant (Self : Active_Map_Only_Policy; OA : PolyORB.POA_Types.Obj_Adapter_Access; U_Oid : Unmarshalled_Oid; Servant : out Servants.Servant_Access; Error : in out PolyORB.Errors.Error_Container) is pragma Warnings (Off); pragma Unreferenced (Self); pragma Warnings (On); use PolyORB.POA_Policies.Servant_Retention_Policy; use type PolyORB.Servants.Servant_Access; begin -- Lookup object in Active Object Map Retained_Id_To_Servant (POA.Obj_Adapter_Access (OA).Servant_Retention_Policy.all, OA, U_Oid, Servant, Error); if Found (Error) then return; end if; -- Under USE_ACTIVE_OBJECT_MAP_ONLY policy, we only look up the -- oid in the object map. A null servant is an error. if Servant = null then Throw (Error, ObjectNotActive_E, Null_Members'(Null_Member)); end if; end Id_To_Servant; ----------------- -- Set_Servant -- ----------------- procedure Set_Servant (Self : Active_Map_Only_Policy; OA : PolyORB.POA_Types.Obj_Adapter_Access; Servant : Servants.Servant_Access; Error : in out PolyORB.Errors.Error_Container) is pragma Unreferenced (Self); pragma Unreferenced (OA); pragma Unreferenced (Servant); begin Throw (Error, WrongPolicy_E, Null_Members'(Null_Member)); end Set_Servant; ----------------- -- Get_Servant -- ----------------- procedure Get_Servant (Self : Active_Map_Only_Policy; OA : PolyORB.POA_Types.Obj_Adapter_Access; Servant : out Servants.Servant_Access; Error : in out PolyORB.Errors.Error_Container) is pragma Unreferenced (Self); pragma Unreferenced (OA); begin Servant := null; Throw (Error, WrongPolicy_E, Null_Members'(Null_Member)); end Get_Servant; ---------------------------- -- Ensure_Servant_Manager -- ---------------------------- procedure Ensure_Servant_Manager (Self : Active_Map_Only_Policy; Error : in out PolyORB.Errors.Error_Container) is pragma Unreferenced (Self); begin Throw (Error, WrongPolicy_E, Null_Members'(Null_Member)); end Ensure_Servant_Manager; end PolyORB.POA_Policies.Request_Processing_Policy.Active_Object_Map_Only; polyorb-2.8~20110207.orig/src/polyorb-binding_data_qos.ads0000644000175000017500000000536611750740340022645 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . B I N D I N G _ D A T A _ Q O S -- -- -- -- S p e c -- -- -- -- Copyright (C) 2005 Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with PolyORB.Binding_Data; with PolyORB.QoS; package PolyORB.Binding_Data_QoS is procedure Set_Profile_QoS (Prof : access PolyORB.Binding_Data.Profile_Type'Class; QoS : PolyORB.QoS.QoS_Parameters); function Get_Profile_QoS (Prof : access PolyORB.Binding_Data.Profile_Type'Class) return PolyORB.QoS.QoS_Parameters; procedure Set_Profile_QoS (Prof : access PolyORB.Binding_Data.Profile_Type'Class; Kind : PolyORB.QoS.QoS_Kind; QoS : PolyORB.QoS.QoS_Parameter_Access); function Get_Profile_QoS (Prof : access PolyORB.Binding_Data.Profile_Type'Class; Kind : PolyORB.QoS.QoS_Kind) return PolyORB.QoS.QoS_Parameter_Access; end PolyORB.Binding_Data_QoS; polyorb-2.8~20110207.orig/src/polyorb-tasking-profiles-ravenscar-mutexes.adb0000644000175000017500000003001511750740340026257 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- POLYORB.TASKING.PROFILES.RAVENSCAR.MUTEXES -- -- -- -- B o d y -- -- -- -- Copyright (C) 2002-2008, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- Implementation of synchronisation objects under the ravenscar profile with PolyORB.Log; with PolyORB.Utils.Strings; package body PolyORB.Tasking.Profiles.Ravenscar.Mutexes is use PolyORB.Log; package L is new PolyORB.Log.Facility_Log ("polyorb.tasking.profiles.ravenscar.mutexes"); procedure O (Message : String; Level : Log_Level := Debug) renames L.Output; function C (Level : Log_Level := Debug) return Boolean renames L.Enabled; package PTM renames PolyORB.Tasking.Mutexes; type Queued_Thread is record -- Element of a queue of Thread; see comment for Thread_Queue Sync : Synchro_Index_Type; -- Synchro object the Thread is waiting on Next : Extended_Synchro_Index; -- Next Thread in the queue Is_Waiting : Boolean; -- True if the thread is waiting end record; type Thread_Queue is array (Synchro_Index_Type) of Queued_Thread; -- Implementation of a queue using an array. -- Each element of the array represent a waiting thread, and -- contain an access to the synchro object on which it is waiting, -- and the index of the Thread following it in the queue. -- This queue is used by a Mutex to record the tasks that -- wait for it. -- The place of a Thread in the array change at every suspending -- call; It is determinated by the index of its current synchro -- object. Each element of the array contain an access to a -- Thread, and the index of the Thread following it in the queue. type Mutex_Pool_Type is array (Mutex_Index_Type) of aliased Ravenscar_Mutex_Type; The_Mutex_Pool : Mutex_Pool_Type; -- The pool of preallocated mutexes protected type Mutex_PO is -- Provide thread safe primitives for a Mutex, -- and manage its Thread_Queue. function Check_Queue_Consistency return Boolean; -- Make some tests on the consistency of the queue. procedure Test_And_Set_Entry (Result : out Boolean; Place : Synchro_Index_Type); -- Test if the task can enter the Mutex (i.e, if no other -- task own the monitor). If so, it take it; If it cannot, -- it is queued. procedure Leave (Someone_Is_Waiting : out Boolean; To_Free : out Synchro_Index_Type); -- Free the Mutex procedure Initialize (N : Mutex_Index_Type); -- Initialize the Mutex private My_Index : Mutex_Index_Type; -- Index of the Mutex in the pool Next : Extended_Synchro_Index; -- Index of the next Thread to resume in Waiters Waiters : Thread_Queue; -- Queue of the Threads waiting for the mutex Is_Taken : Boolean := False; -- is True if someone owns the Mutex; False otherwise end Mutex_PO; type Mutex_PO_Arr is array (Mutex_Index_Manager.Index_Type) of Mutex_PO; The_Mutex_PO_Arr : Mutex_PO_Arr; -- Pool of Mutex_PO ------------ -- Create -- ------------ function Create (MF : access Ravenscar_Mutex_Factory_Type; Name : String := "") return Mutex_Access is pragma Warnings (Off); pragma Unreferenced (MF); pragma Unreferenced (Name); pragma Warnings (On); -- XXX The use of names is not implemented yet Index : Mutex_Index_Type; M : Ravenscar_Mutex_Access; begin Mutex_Index_Manager.Get (Index); M := The_Mutex_Pool (Index)'Access; M.Id := Index; The_Mutex_PO_Arr (M.Id).Initialize (M.Id); return Mutex_Access (M); end Create; ------------- -- Destroy -- ------------- procedure Destroy (MF : access Ravenscar_Mutex_Factory_Type; M : in out Mutex_Access) is pragma Warnings (Off); pragma Unreferenced (MF); pragma Warnings (On); begin Mutex_Index_Manager.Release (Ravenscar_Mutex_Access (M).Id); end Destroy; ----------- -- Enter -- ----------- procedure Enter (M : access Ravenscar_Mutex_Type) is Exit_Condition : Boolean; S : Synchro_Index_Type; begin pragma Debug (C, O ("Enter")); S := Prepare_Suspend; The_Mutex_PO_Arr (M.Id).Test_And_Set_Entry (Exit_Condition, S); if not Exit_Condition then Suspend (S); else Abort_Suspend (S); end if; end Enter; ---------------- -- Initialize -- ---------------- procedure Initialize is begin Mutex_Index_Manager.Initialize; for J in The_Mutex_PO_Arr'Range loop The_Mutex_PO_Arr (J).Initialize (J); end loop; PTM.Register_Mutex_Factory (PTM.Mutex_Factory_Access (The_Mutex_Factory)); end Initialize; ----------- -- Leave -- ----------- procedure Leave (M : access Ravenscar_Mutex_Type) is To_Free : Synchro_Index_Type; Someone_Is_Waiting : Boolean; begin pragma Debug (C, O ("Leave")); The_Mutex_PO_Arr (M.Id).Leave (Someone_Is_Waiting, To_Free); if Someone_Is_Waiting then Resume (To_Free); end if; end Leave; -------------- -- Mutex_PO -- -------------- protected body Mutex_PO is ------------------------------ -- Check_Queue_Consistency -- ------------------------------ function Check_Queue_Consistency return Boolean is type Bool_Arr is array (Waiters'Range) of Boolean; Marked : Bool_Arr; Current : Extended_Synchro_Index := Next; begin for J in Marked'Range loop Marked (J) := False; end loop; while Current /= Null_Synchro_Index loop if Marked (Synchro_Index_Type (Current)) then -- Loop in the queue pragma Debug (C, O ("loop in the queue!!!")); return False; end if; if not Waiters (Synchro_Index_Type (Current)).Is_Waiting then -- Someone is in the queue, but does not wait pragma Debug (C, O ("active task in the queue!!! Id= " & Integer'Image (Current))); return False; end if; Marked (Synchro_Index_Type (Current)) := True; Current := Waiters (Synchro_Index_Type (Current)).Next; end loop; return Is_Taken or else Next = Null_Synchro_Index; -- The queue is not empty only if the mutex is not taken end Check_Queue_Consistency; ------------------------- -- Mutex_PO.Initialize -- ------------------------- procedure Initialize (N : Mutex_Index_Type) is begin My_Index := N; Next := Null_Synchro_Index; Is_Taken := False; for J in Waiters'Range loop Waiters (J).Next := Null_Synchro_Index; Waiters (J).Is_Waiting := False; end loop; pragma Assert (Check_Queue_Consistency); end Initialize; -------------------- -- Mutex_PO.Leave -- -------------------- procedure Leave (Someone_Is_Waiting : out Boolean; To_Free : out Synchro_Index_Type) is Former_Next : constant Extended_Synchro_Index := Next; begin pragma Assert (Check_Queue_Consistency); if Former_Next /= Null_Synchro_Index then Next := Waiters (Synchro_Index_Type (Former_Next)).Next; pragma Assert (Waiters (Synchro_Index_Type (Former_Next)).Is_Waiting); Is_Taken := True; To_Free := Waiters (Synchro_Index_Type (Former_Next)).Sync; Waiters (Synchro_Index_Type (Former_Next)).Is_Waiting := False; Waiters (Synchro_Index_Type (Former_Next)).Next := Null_Synchro_Index; else Is_Taken := False; Next := Null_Synchro_Index; end if; Someone_Is_Waiting := Is_Taken; pragma Assert (Check_Queue_Consistency); end Leave; --------------------------------- -- Mutex_PO.Test_And_Set_Entry -- --------------------------------- procedure Test_And_Set_Entry (Result : out Boolean; Place : Synchro_Index_Type) is Current : Extended_Synchro_Index; Precedent : Extended_Synchro_Index; begin pragma Assert (Check_Queue_Consistency); Result := not Is_Taken; Waiters (Place).Is_Waiting := True; Waiters (Place).Sync := Place; if not Result then -- Search the rank of T in the queue: Current := Next; Precedent := Null_Synchro_Index; while Current /= Null_Synchro_Index loop -- XXX compare the Priorities Precedent := Current; Current := Waiters (Synchro_Index_Type (Current)).Next; end loop; end if; -- Insert T in the queue if Result then Is_Taken := True; pragma Assert (Next = Null_Synchro_Index); -- XXX useless -- If this assertion fails, it means that the mutex -- is not taken BUT the queue is not empty! elsif Precedent = Null_Synchro_Index then Waiters (Place).Is_Waiting := True; Waiters (Place).Next := Next; Next := Extended_Synchro_Index (Place); else Waiters (Place).Is_Waiting := True; Waiters (Synchro_Index_Type (Precedent)).Next := Extended_Synchro_Index (Place); Waiters (Place).Next := Current; end if; pragma Assert (Check_Queue_Consistency); end Test_And_Set_Entry; end Mutex_PO; use PolyORB.Initialization; use PolyORB.Initialization.String_Lists; use PolyORB.Utils.Strings; begin Register_Module (Module_Info' (Name => +"tasking.profiles.ravenscar.mutexes", Conflicts => Empty, Depends => Empty, Provides => +"tasking.mutexes", Implicit => False, Init => Initializer, Shutdown => null)); end PolyORB.Tasking.Profiles.Ravenscar.Mutexes; polyorb-2.8~20110207.orig/src/polyorb-parameters-command_line.adb0000644000175000017500000001156411750740340024122 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . P A R A M E T E R S . C O M M A N D _ L I N E -- -- -- -- B o d y -- -- -- -- Copyright (C) 2005-2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with PolyORB.Initialization; with PolyORB.Utils.Strings; with Ada.Command_Line; -- with System.IO; package body PolyORB.Parameters.Command_Line is function Make_Flag (Section, Key : String) return String; -- Build flag string from (Section, Key) tuple ------------------------- -- Command line source -- ------------------------- type Cmd_Line_Source is new Parameters_Source with null record; function Get_Conf (Source : access Cmd_Line_Source; Section, Key : String) return String; The_Cmd_Line_Source : aliased Cmd_Line_Source; function Get_Conf (Source : access Cmd_Line_Source; Section, Key : String) return String is pragma Unreferenced (Source); use Ada.Command_Line; Flag : constant String := Make_Flag (Section, Key); F_Len : constant Natural := Flag'Length; begin for J in 1 .. Argument_Count loop declare Arg : constant String := Argument (J); A_Len : constant Natural := Arg'Length; begin if F_Len <= A_Len and then Flag = Arg (Arg'First .. Arg'First + F_Len - 1) then -- System.IO.Put_Line ("arg = " & Arg); -- System.IO.Put_Line ("flag = " & Flag); if F_Len = A_Len then return "true"; elsif Arg (Arg'First + F_Len) = '=' then return Arg (Arg'First + F_Len + 1 .. Arg'Last); end if; end if; end; end loop; return ""; end Get_Conf; ---------------- -- Initialize -- ---------------- procedure Initialize; procedure Initialize is begin Register_Source (The_Cmd_Line_Source'Access); end Initialize; --------------- -- Make_Flag -- --------------- function Make_Flag (Section, Key : String) return String is Result : String := "--polyorb-" & PolyORB.Utils.To_Lower (Section & "-" & Key); Last : Positive := Result'Last; begin for J in Result'Range loop case Result (J) is when '0' .. '9' | 'A' .. 'Z' | 'a' .. 'z' | '_' => null; when others => Result (J) := '-'; end case; end loop; while Result (Last) = '-' loop Last := Last - 1; end loop; return Result (Result'First .. Last); end Make_Flag; use PolyORB.Initialization; use PolyORB.Initialization.String_Lists; use PolyORB.Utils.Strings; begin Register_Module (Module_Info' (Name => +"parameters.command_line", Conflicts => Empty, Depends => Empty, Provides => +"parameters_sources", Implicit => True, Init => Initialize'Access, Shutdown => null)); end PolyORB.Parameters.Command_Line; polyorb-2.8~20110207.orig/src/polyorb-qos-tagged_components.adb0000644000175000017500000000527311750740340023634 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . Q O S . T A G G E D _ C O M P O N E N T S -- -- -- -- B o d y -- -- -- -- Copyright (C) 2005 Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with Ada.Unchecked_Deallocation; package body PolyORB.QoS.Tagged_Components is use PolyORB.Representations.CDR.Common; use GIOP_Tagged_Component_Lists; procedure Free is new Ada.Unchecked_Deallocation (Encapsulation, Encapsulation_Access); ---------------------- -- Release_Contents -- ---------------------- procedure Release_Contents (QoS : access QoS_GIOP_Tagged_Components_Parameter) is Iter : Iterator := First (QoS.Components); begin while not Last (Iter) loop Free (Value (Iter).Data); Next (Iter); end loop; Deallocate (QoS.Components); end Release_Contents; end PolyORB.QoS.Tagged_Components; polyorb-2.8~20110207.orig/src/polyorb-tasking-profiles-ravenscar.ads0000644000175000017500000000461511750740340024617 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . T A S K I N G . P R O F I L E S . R A V E N S C A R -- -- -- -- S p e c -- -- -- -- Copyright (C) 2002-2004 Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by ACT Europe. -- -- (email: sales@act-europe.fr) -- -- -- ------------------------------------------------------------------------------ -- Base package for the Ravenscar implementation of PolyORB.Tasking. -- This children of this package must compile under the Ravenscar profile, -- and must avoid to use dynamic allocation. If dynamic allocation cannot -- be avoided, it must be done at initialisation time. package PolyORB.Tasking.Profiles.Ravenscar is pragma Preelaborate; end PolyORB.Tasking.Profiles.Ravenscar; polyorb-2.8~20110207.orig/src/polyorb-services-naming-helper.adb0000644000175000017500000004104611750740340023701 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . S E R V I C E S . N A M I N G . H E L P E R -- -- -- -- B o d y -- -- -- -- Copyright (C) 2002-2008, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with PolyORB.Initialization; pragma Elaborate_All (PolyORB.Initialization); with PolyORB.Any.ObjRef; -- with PolyORB.Exceptions; with PolyORB.Log; with PolyORB.Types; with PolyORB.Utils.Strings; package body PolyORB.Services.Naming.Helper is use PolyORB.Any; use PolyORB.Log; use PolyORB.Types; package L is new PolyORB.Log.Facility_Log ("polyorb.services.naming.helper"); procedure O (Message : Standard.String; Level : Log_Level := Debug) renames L.Output; function C (Level : Log_Level := Debug) return Boolean renames L.Enabled; -------------- -- From_Any -- -------------- function From_Any (Item : PolyORB.Any.Any) return Istring is Result : constant PolyORB.Types.String := From_Any (Item); begin pragma Debug (C, O ("From Any : (Istring)")); return Istring (Result); end From_Any; function From_Any (Item : PolyORB.Any.Any) return NameComponent is Index : PolyORB.Any.Any; Result_id : Istring; Result_kind : Istring; begin pragma Debug (C, O ("From Any : (NameComponent)")); Index := Get_Aggregate_Element (Item, TC_Istring, PolyORB.Types.Unsigned_Long (0)); Result_id := Helper.From_Any (Index); Index := Get_Aggregate_Element (Item, TC_Istring, PolyORB.Types.Unsigned_Long (1)); Result_kind := Helper.From_Any (Index); return (id => Result_id, kind => Result_kind); end From_Any; function From_Any (Item : PolyORB.Any.Any) return Name is Result : constant SEQUENCE_NameComponent.Sequence := Helper.From_Any (Item); begin pragma Debug (C, O ("From Any : (Name)")); return Name (Result); end From_Any; function From_Any (Item : PolyORB.Any.Any) return BindingType is pragma Debug (C, O ("From Any : (BindingType)")); Index : constant PolyORB.Any.Any := Get_Aggregate_Element (Item, TypeCode.TC_Unsigned_Long, PolyORB.Types.Unsigned_Long (0)); Position : constant PolyORB.Types.Unsigned_Long := From_Any (Index); begin return BindingType'Val (Position); end From_Any; function From_Any (Item : PolyORB.Any.Any) return Binding is Index : PolyORB.Any.Any; Result_binding_name : Name; Result_binding_type : BindingType; begin pragma Debug (C, O ("From Any : (Binding)")); Index := Get_Aggregate_Element (Item, Helper.TC_Name, PolyORB.Types.Unsigned_Long (0)); Result_binding_name := Helper.From_Any (Index); Index := Get_Aggregate_Element (Item, Helper.TC_BindingType, PolyORB.Types.Unsigned_Long (1)); Result_binding_type := Helper.From_Any (Index); return (binding_name => Result_binding_name, binding_type => Result_binding_type); end From_Any; function From_Any (Item : PolyORB.Any.Any) return SEQUENCE_Binding.Sequence is use SEQUENCE_Binding; Count : constant PolyORB.Types.Unsigned_Long := From_Any (Get_Aggregate_Element (Item, TypeCode.TC_Unsigned_Long, PolyORB.Types.Unsigned_Long (0))); Result : Element_Array (1 .. Integer (Count)); begin pragma Debug (C, O ("From Any : (SequenceBinding)")); for J in Result'Range loop Result (J) := Helper.From_Any (Get_Aggregate_Element (Item, Helper.TC_Binding, PolyORB.Types.Unsigned_Long (J))); end loop; return To_Sequence (Result); end From_Any; function From_Any (Item : PolyORB.Any.Any) return SEQUENCE_NameComponent.Sequence is use SEQUENCE_NameComponent; Count : constant PolyORB.Types.Unsigned_Long := From_Any (Get_Aggregate_Element (Item, TypeCode.TC_Unsigned_Long, PolyORB.Types.Unsigned_Long (0))); Result : Element_Array (1 .. Integer (Count)); begin pragma Debug (C, O ("From Any : (Sequence namecomponent)")); for J in Result'Range loop Result (J) := Helper.From_Any (Get_Aggregate_Element (Item, Helper.TC_Binding, PolyORB.Types.Unsigned_Long (J))); end loop; return To_Sequence (Result); end From_Any; function From_Any (Item : PolyORB.Any.Any) return BindingList is Result : constant SEQUENCE_Binding.Sequence := Helper.From_Any (Item); begin return BindingList (Result); end From_Any; ------------ -- To_Any -- ------------ function To_Any (Item : Istring) return PolyORB.Any.Any is Result : PolyORB.Any.Any := To_Any (PolyORB.Types.String (Item)); begin pragma Debug (C, O ("To Any : (Istring)")); PolyORB.Any.Set_Type (Result, TC_Istring); return Result; end To_Any; function To_Any (Item : NameComponent) return PolyORB.Any.Any is Result : PolyORB.Any.Any := Get_Empty_Any_Aggregate (TC_NameComponent); begin pragma Debug (C, O ("To Any : (NameComponent)")); Add_Aggregate_Element (Result, To_Any (Item.id)); Add_Aggregate_Element (Result, To_Any (Item.kind)); return Result; end To_Any; function To_Any (Item : SEQUENCE_NameComponent.Sequence) return PolyORB.Any.Any is use SEQUENCE_NameComponent; Array_Item : constant Element_Array := To_Element_Array (Item); Result : PolyORB.Any.Any := Get_Empty_Any_Aggregate (TC_SEQUENCE_NameComponent); begin pragma Debug (C, O ("To Any : (Sequence NameComponent)")); Add_Aggregate_Element (Result, To_Any (PolyORB.Types.Unsigned_Long (Length (Item)))); for I in Array_Item'Range loop Add_Aggregate_Element (Result, Helper.To_Any (Array_Item (I))); end loop; return Result; end To_Any; function To_Any (Item : Name) return PolyORB.Any.Any is Result : PolyORB.Any.Any := To_Any (SEQUENCE_NameComponent.Sequence (Item)); begin pragma Debug (C, O ("To Any : (Name)")); Set_Type (Result, TC_Name); return Result; end To_Any; function To_Any (Item : BindingType) return PolyORB.Any.Any is Result : PolyORB.Any.Any := Get_Empty_Any_Aggregate (TC_BindingType); begin pragma Debug (C, O ("To Any : (BindingType)")); Add_Aggregate_Element (Result, To_Any (PolyORB.Types.Unsigned_Long (BindingType'Pos (Item)))); return Result; end To_Any; function To_Any (Item : Binding) return PolyORB.Any.Any is Result : PolyORB.Any.Any := Get_Empty_Any_Aggregate (TC_Binding); begin pragma Debug (C, O ("To Any : (Binding)")); Add_Aggregate_Element (Result, Helper.To_Any (Item.binding_name)); Add_Aggregate_Element (Result, Helper.To_Any (Item.binding_type)); return Result; end To_Any; function To_Any (Item : SEQUENCE_Binding.Sequence) return PolyORB.Any.Any is use SEQUENCE_Binding; Array_Item : constant Element_Array := To_Element_Array (Item); Result : PolyORB.Any.Any := Get_Empty_Any_Aggregate (TC_SEQUENCE_Binding); begin pragma Debug (C, O ("To Any : (SequenceBinding)")); Add_Aggregate_Element (Result, To_Any (PolyORB.Types.Unsigned_Long (Length (Item)))); for I in Array_Item'Range loop Add_Aggregate_Element (Result, Helper.To_Any (Array_Item (I))); end loop; return Result; end To_Any; function To_Any (Item : BindingList) return PolyORB.Any.Any is Result : PolyORB.Any.Any := To_Any (SEQUENCE_Binding.Sequence (Item)); begin pragma Debug (C, O ("To Any : (BindingList)")); Set_Type (Result, TC_BindingList); return Result; end To_Any; function To_Any (Item : PolyORB.References.Ref) return PolyORB.Any.Any is A : Any.Any := Any.ObjRef.To_Any (Item); begin Set_Type (A, Services.Naming.Helper.TC_Object); return A; end To_Any; ---------------- -- Initialize -- ---------------- procedure Initialize; procedure Initialize is use PolyORB.Any.TypeCode; begin declare Name : constant PolyORB.Types.String := To_PolyORB_String ("Istring"); Id : constant PolyORB.Types.String := To_PolyORB_String ("IDL:omg.org/CosNaming/Istring:1.0"); begin TC_Istring := TC_Alias; Add_Parameter (TC_Istring, To_Any (Name)); Add_Parameter (TC_Istring, To_Any (Id)); Add_Parameter (TC_Istring, To_Any (TypeCode.TC_String)); Disable_Reference_Counting (Object_Of (TC_Istring).all); end; declare Name : constant PolyORB.Types.String := To_PolyORB_String ("NameComponent"); Id : constant PolyORB.Types.String := To_PolyORB_String ("IDL:omg.org/CosNaming/NameComponent:1.0"); Arg_Name_id : constant PolyORB.Types.String := To_PolyORB_String ("id"); Arg_Name_kind : constant PolyORB.Types.String := To_PolyORB_String ("kind"); begin TC_NameComponent := TC_Struct; Add_Parameter (TC_NameComponent, To_Any (Name)); Add_Parameter (TC_NameComponent, To_Any (Id)); Add_Parameter (TC_NameComponent, To_Any (TC_Istring)); Add_Parameter (TC_NameComponent, To_Any (Arg_Name_id)); Add_Parameter (TC_NameComponent, To_Any (TC_Istring)); Add_Parameter (TC_NameComponent, To_Any (Arg_Name_kind)); Disable_Reference_Counting (Object_Of (TC_NameComponent).all); end; TC_SEQUENCE_NameComponent := TC_Sequence; Add_Parameter (TC_SEQUENCE_NameComponent, To_Any (Types.Unsigned_Long'(0))); Add_Parameter (TC_SEQUENCE_NameComponent, To_Any (TC_NameComponent)); Disable_Reference_Counting (Object_Of (TC_SEQUENCE_NameComponent).all); declare Name : constant PolyORB.Types.String := To_PolyORB_String ("Name"); Id : constant PolyORB.Types.String := To_PolyORB_String ("IDL:omg.org/CosNaming/Name:1.0"); begin TC_Name := TC_Alias; Add_Parameter (TC_Name, To_Any (Name)); Add_Parameter (TC_Name, To_Any (Id)); Add_Parameter (TC_Name, To_Any (TC_SEQUENCE_NameComponent)); Disable_Reference_Counting (Object_Of (TC_Name).all); end; declare Name : constant PolyORB.Types.String := To_PolyORB_String ("BindingType"); Id : constant PolyORB.Types.String := To_PolyORB_String ("IDL:omg.org/CosNaming/BindingType:1.0"); nobject_Name : constant PolyORB.Types.String := To_PolyORB_String ("nobject"); ncontext_Name : constant PolyORB.Types.String := To_PolyORB_String ("ncontext"); begin TC_BindingType := TC_Enum; Add_Parameter (TC_BindingType, To_Any (Name)); Add_Parameter (TC_BindingType, To_Any (Id)); Add_Parameter (TC_BindingType, To_Any (nobject_Name)); Add_Parameter (TC_BindingType, To_Any (ncontext_Name)); Disable_Reference_Counting (Object_Of (TC_BindingType).all); end; declare Name : constant PolyORB.Types.String := To_PolyORB_String ("Binding"); Id : constant PolyORB.Types.String := To_PolyORB_String ("IDL:omg.org/CosNaming/Binding:1.0"); Arg_Name_binding_name : constant PolyORB.Types.String := To_PolyORB_String ("binding_name"); Arg_Name_binding_type : constant PolyORB.Types.String := To_PolyORB_String ("binding_type"); begin TC_Binding := TC_Struct; Add_Parameter (TC_Binding, To_Any (Name)); Add_Parameter (TC_Binding, To_Any (Id)); Add_Parameter (TC_Binding, To_Any (Helper.TC_Name)); Add_Parameter (TC_Binding, To_Any (Arg_Name_binding_name)); Add_Parameter (TC_Binding, To_Any (Helper.TC_BindingType)); Add_Parameter (TC_Binding, To_Any (Arg_Name_binding_type)); Disable_Reference_Counting (Object_Of (TC_Binding).all); end; TC_SEQUENCE_Binding := TC_Sequence; Add_Parameter (TC_SEQUENCE_Binding, To_Any (PolyORB.Types.Unsigned_Long (0))); Add_Parameter (TC_SEQUENCE_Binding, To_Any (TC_Binding)); Disable_Reference_Counting (Object_Of (TC_SEQUENCE_Binding).all); declare Name : constant PolyORB.Types.String := To_PolyORB_String ("BindingList"); Id : constant PolyORB.Types.String := To_PolyORB_String ("IDL:omg.org/CosNaming/BindingList:1.0"); begin TC_BindingList := TC_Alias; Add_Parameter (TC_BindingList, To_Any (Name)); Add_Parameter (TC_BindingList, To_Any (Id)); Add_Parameter (TC_BindingList, To_Any (TC_SEQUENCE_Binding)); Disable_Reference_Counting (Object_Of (TC_BindingList).all); end; -- XXX to be declared in minimal servant ??? declare Name : constant PolyORB.Types.String := To_PolyORB_String ("Object"); Id : constant PolyORB.Types.String := To_PolyORB_String ("IDL:CORBA/Object:1.0"); begin Naming.Helper.TC_Object := TypeCode.TC_Object; Add_Parameter (Naming.Helper.TC_Object, To_Any (Name)); Add_Parameter (Naming.Helper.TC_Object, To_Any (Id)); Disable_Reference_Counting (Object_Of (Naming.Helper.TC_Object).all); end; end Initialize; use PolyORB.Initialization; use PolyORB.Initialization.String_Lists; use PolyORB.Utils.Strings; begin Register_Module (Module_Info' (Name => +"naming.Helper", Conflicts => Empty, Depends => +"any", Provides => Empty, Implicit => False, Init => Initialize'Access, Shutdown => null)); end PolyORB.Services.Naming.Helper; polyorb-2.8~20110207.orig/src/polyorb-tasking-profiles-no_tasking-mutexes.ads0000644000175000017500000000723411750740340026457 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- POLYORB.TASKING.PROFILES.NO_TASKING.MUTEXES -- -- -- -- S p e c -- -- -- -- Copyright (C) 2002 Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by ACT Europe. -- -- (email: sales@act-europe.fr) -- -- -- ------------------------------------------------------------------------------ -- Implementation of POSIX-like mutexes with no Ada tasking. -- For more information see PolyORB.Tasking.Mutexes. with PolyORB.Tasking.Mutexes; package PolyORB.Tasking.Profiles.No_Tasking.Mutexes is package PTM renames PolyORB.Tasking.Mutexes; procedure Initialize; -- Initialize this package type No_Tasking_Mutex_Type is new PTM.Mutex_Type with private; type No_Tasking_Mutex_Access is access all No_Tasking_Mutex_Type'Class; -- Type for mutexes with no Ada tasking. procedure Enter (M : access No_Tasking_Mutex_Type); procedure Leave (M : access No_Tasking_Mutex_Type); type No_Tasking_Mutex_Factory_Type is new PTM.Mutex_Factory_Type with private; -- This type is a factory for the Mutex type under No_Tasking profile. type No_Tasking_Mutex_Factory_Access is access all No_Tasking_Mutex_Factory_Type'Class; The_Mutex_Factory : constant No_Tasking_Mutex_Factory_Access; function Create (MF : access No_Tasking_Mutex_Factory_Type; Name : String := "") return PTM.Mutex_Access; -- Create a new mutex, or get a preallocated one. -- Name will be used to get the configuration of this -- Mutex from the configuration module. procedure Destroy (MF : access No_Tasking_Mutex_Factory_Type; M : in out PTM.Mutex_Access); -- Destroy M. private type No_Tasking_Mutex_Type is new PTM.Mutex_Type with null record; type No_Tasking_Mutex_Factory_Type is new PTM.Mutex_Factory_Type with null record; The_Mutex_Factory : constant No_Tasking_Mutex_Factory_Access := new No_Tasking_Mutex_Factory_Type; end PolyORB.Tasking.Profiles.No_Tasking.Mutexes; polyorb-2.8~20110207.orig/src/polyorb-log-stderr.adb0000644000175000017500000001423411750740340021413 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . L O G . S T D E R R -- -- -- -- B o d y -- -- -- -- Copyright (C) 2004-2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with Interfaces.C; with System; with PolyORB.Initialization; with PolyORB.Parameters; with PolyORB.Utils.Strings; package body PolyORB.Log.Stderr is use PolyORB.Parameters; Enable_Timestamps : Boolean := False; -- If set true, all messages are prefixed with a timestamp Failed_Message : constant String := "polyorb.log.stderr: write failed" & ASCII.LF; Interrupted_Message : constant String := "polyorb.log.stderr: write interrupted" & ASCII.LF; type Write_Status is (Success, Interrupted, Failed); function Write (S : String) return Write_Status; -- Outputs string to standard error. Output operation can be interrupted -- by a signal, in which case we try to complete output and return -- Interrupted status. -------------- -- Put_Line -- -------------- procedure Put_Line (S : String); -- Write S to output, possibly prefixed with a timestamp. -- If write operation fails or is interrupted, generate an additional -- informational message. procedure Put_Line (S : String) is function Timestamp return String; -- If timestamps are enabled, return a timestamp for this message, -- else return an empty string. function Timestamp return String is Result : String := "0000-00-00 00:00:00 "; -- Note additional empty space at end of string to account for the -- fact that we will use strftime(2) to fill in this string, which -- will append a NUL character. procedure C_Timestamp (Buf : System.Address; Bufsize : Interfaces.C.int); pragma Import (C, C_Timestamp, "__PolyORB_timestamp"); begin if Enable_Timestamps then C_Timestamp (Result'Address, Result'Length); return Result (Result'First .. Result'Last - 1); else return ""; end if; end Timestamp; SS : aliased constant String := Timestamp & S & ASCII.LF; X : Write_Status; pragma Unreferenced (X); -- Start of processing for Put_Line begin case Write (SS) is when Success => null; when Interrupted => X := Write (Interrupted_Message); when Failed => X := Write (Failed_Message); end case; end Put_Line; ----------- -- Write -- ----------- function Write (S : String) return Write_Status is use type Interfaces.C.int; use type Interfaces.C.size_t; function C_Write (Fd : Interfaces.C.int; P : System.Address; Len : Interfaces.C.int) return Interfaces.C.size_t; pragma Import (C, C_Write, "write"); -- write(2) system call P : Natural := 0; C : Interfaces.C.int := 0; R : Interfaces.C.size_t; -- Comments needed??? -- Start of processing for Write begin loop R := C_Write (2, S (S'First + Integer (C))'Address, S'Length - C); P := P + 1; if R = -1 then -- Operation was failed. return Failed; end if; C := C + Interfaces.C.int (R); if C = S'Length then -- Output complete if P = 1 then return Success; else return Interrupted; end if; end if; end loop; end Write; ---------------- -- Initialize -- ---------------- procedure Initialize; procedure Initialize is use type PolyORB.Log.Internals.Log_Hook_T; begin if PolyORB.Log.Internals.Log_Hook = null then PolyORB.Log.Internals.Log_Hook := Put_Line'Access; end if; Enable_Timestamps := Get_Conf ("log", "timestamp", Default => False); end Initialize; use PolyORB.Initialization; use PolyORB.Initialization.String_Lists; use PolyORB.Utils.Strings; begin Register_Module (Module_Info' (Name => +"log.stderr", Conflicts => Empty, Depends => +"parameters", Provides => +"log_sink", Implicit => True, Init => Initialize'Access, Shutdown => null)); end PolyORB.Log.Stderr; polyorb-2.8~20110207.orig/src/polyorb-tasking-profiles-full_tasking-threads-annotations.adb0000644000175000017500000001062311750740340031253 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- POLYORB.TASKING.PROFILES.FULL_TASKING.THREADS.ANNOTATIONS -- -- -- -- B o d y -- -- -- -- Copyright (C) 2004-2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with Ada.Task_Attributes; with Ada.Unchecked_Deallocation; with PolyORB.Initialization; with PolyORB.Smart_Pointers; with PolyORB.Utils.Strings; package body PolyORB.Tasking.Profiles.Full_Tasking.Threads.Annotations is use PolyORB.Annotations; use PolyORB.Smart_Pointers; type Notepad_Entity is new Non_Controlled_Entity with record Notepad : PolyORB.Annotations.Notepad_Access := null; end record; procedure Finalize (Object : in out Notepad_Entity); Nil_Ref : Ref; package Task_Notepad_Wrapper is new Ada.Task_Attributes (Ref, Nil_Ref); Current_TAF : Full_Tasking_TAF_Access; -------------- -- Finalize -- -------------- procedure Finalize (Object : in out Notepad_Entity) is procedure Free is new Ada.Unchecked_Deallocation (Notepad, Notepad_Access); begin if Object.Notepad /= null then Destroy (Object.Notepad.all); Free (Object.Notepad); end if; end Finalize; -------------------------------- -- Get_Current_Thread_Notepad -- -------------------------------- function Get_Current_Thread_Notepad (TAF : access Full_Tasking_TAF) return PolyORB.Annotations.Notepad_Access is pragma Unreferenced (TAF); Thread_Entity : Entity_Ptr := Entity_Of (Task_Notepad_Wrapper.Value); begin if Thread_Entity = null then Thread_Entity := new Notepad_Entity; Notepad_Entity (Thread_Entity.all).Notepad := new Notepad; Set (Task_Notepad_Wrapper.Reference.all, Thread_Entity); end if; return Notepad_Entity (Thread_Entity.all).Notepad; end Get_Current_Thread_Notepad; ---------------- -- Initialize -- ---------------- procedure Initialize; procedure Initialize is begin Current_TAF := new Full_Tasking_TAF; PolyORB.Tasking.Threads.Annotations.Register (PolyORB.Tasking.Threads.Annotations.TAF_Access (Current_TAF)); end Initialize; use PolyORB.Initialization; use PolyORB.Initialization.String_Lists; use PolyORB.Utils.Strings; begin Register_Module (Module_Info' (Name => +"tasking.profiles.full_tasking.annotations", Conflicts => Empty, Depends => Empty, Provides => +"tasking.annotations", Implicit => False, Init => Initialize'Access, Shutdown => null)); end PolyORB.Tasking.Profiles.Full_Tasking.Threads.Annotations; polyorb-2.8~20110207.orig/src/polyorb-services-naming-tools.ads0000644000175000017500000000773411750740340023611 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . S E R V I C E S . N A M I N G . T O O L S -- -- -- -- S p e c -- -- -- -- Copyright (C) 2002-2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- with Ada.Finalization; with PolyORB.References; with PolyORB.Services.Naming; with PolyORB.Services.Naming.NamingContext; package PolyORB.Services.Naming.Tools is -- This package allows an object to be chosen either by its IOR or by -- its name in the naming service. procedure Init (Ref : PolyORB.References.Ref); function Locate (Name : PolyORB.Services.Naming.Name) return PolyORB.References.Ref; function Locate (Context : PolyORB.Services.Naming.NamingContext.Ref; Name : PolyORB.Services.Naming.Name) return PolyORB.References.Ref; -- Locate an object given its name, given as an array of name components. function Locate (IOR_Or_Name : String; Sep : Character := '/') return PolyORB.References.Ref; function Locate (Context : PolyORB.Services.Naming.NamingContext.Ref; IOR_Or_Name : String; Sep : Character := '/') return PolyORB.References.Ref; -- Locate an object by IOR or name. If the string does not start with -- "IOR:", the name will be parsed before it is looked up, using -- Parse_Name below. procedure Register (Name : String; Ref : PolyORB.References.Ref; Rebind : Boolean := False; Sep : Character := '/'); -- Register an object by its name by binding or rebinding. -- The name will be parsed by Parse_Name below; any necessary contexts -- will be created on the name server. -- If Rebind is True, then a rebind will be performed if the name -- is already bound. procedure Unregister (Name : String); -- Unregister an object by its name by unbinding it. function Parse_Name (Name : String; Sep : Character := '/') return PolyORB.Services.Naming.Name; -- Split a sequence of name component specifications separated -- with Sep characters into a name component array. Any leading -- Sep is ignored. end PolyORB.Services.Naming.Tools; polyorb-2.8~20110207.orig/src/polyorb-types.ads0000644000175000017500000002002411750740340020510 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . T Y P E S -- -- -- -- S p e c -- -- -- -- Copyright (C) 2001-2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- Base data types for the whole middleware with Interfaces; with System; with Ada.Strings.Unbounded; with Ada.Strings.Wide_Unbounded; with Ada.Unchecked_Deallocation; package PolyORB.Types is pragma Preelaborate; subtype Address is System.Address; -- Provided as a subtype here so that generated code can avoid a direct -- dependency on System, which may clash with a used-defined identifier. type Short is new Interfaces.Integer_16; type Long is new Interfaces.Integer_32; type Long_Long is new Interfaces.Integer_64; type Unsigned_Short is new Interfaces.Unsigned_16; type Unsigned_Long is new Interfaces.Unsigned_32; type Unsigned_Long_Long is new Interfaces.Unsigned_64; type Float is new Interfaces.IEEE_Float_32; type Double is new Interfaces.IEEE_Float_64; type Long_Double is new Interfaces.IEEE_Extended_Float; subtype Char is Standard.Character; subtype Wchar is Standard.Wide_Character; type Octet is new Interfaces.Unsigned_8; subtype Boolean is Standard.Boolean; type String is new Ada.Strings.Unbounded.Unbounded_String; type Wide_String is new Ada.Strings.Wide_Unbounded.Unbounded_Wide_String; type Short_Ptr is access all Short; type Long_Ptr is access all Long; type Long_Long_Ptr is access all Long_Long; type Unsigned_Short_Ptr is access all Unsigned_Short; type Unsigned_Long_Ptr is access all Unsigned_Long; type Unsigned_Long_Long_Ptr is access all Unsigned_Long_Long; type Float_Ptr is access all Float; type Double_Ptr is access all Double; type Long_Double_Ptr is access all Long_Double; type Char_Ptr is access all Char; type Wchar_Ptr is access all Wchar; type Octet_Ptr is access all Octet; type Boolean_Ptr is access all Boolean; type String_Ptr is access all String; type Wide_String_Ptr is access all Wide_String; -- and the deallocation method for each pointer type procedure Deallocate is new Ada.Unchecked_Deallocation (Short, Short_Ptr); procedure Deallocate is new Ada.Unchecked_Deallocation (Long, Long_Ptr); procedure Deallocate is new Ada.Unchecked_Deallocation (Long_Long, Long_Long_Ptr); procedure Deallocate is new Ada.Unchecked_Deallocation (Unsigned_Short, Unsigned_Short_Ptr); procedure Deallocate is new Ada.Unchecked_Deallocation (Unsigned_Long, Unsigned_Long_Ptr); procedure Deallocate is new Ada.Unchecked_Deallocation (Unsigned_Long_Long, Unsigned_Long_Long_Ptr); procedure Deallocate is new Ada.Unchecked_Deallocation (Float, Float_Ptr); procedure Deallocate is new Ada.Unchecked_Deallocation (Double, Double_Ptr); procedure Deallocate is new Ada.Unchecked_Deallocation (Long_Double, Long_Double_Ptr); procedure Deallocate is new Ada.Unchecked_Deallocation (Char, Char_Ptr); procedure Deallocate is new Ada.Unchecked_Deallocation (Wchar, Wchar_Ptr); procedure Deallocate is new Ada.Unchecked_Deallocation (Octet, Octet_Ptr); procedure Deallocate is new Ada.Unchecked_Deallocation (Boolean, Boolean_Ptr); procedure Deallocate is new Ada.Unchecked_Deallocation (String, String_Ptr); procedure Deallocate is new Ada.Unchecked_Deallocation (Wide_String, Wide_String_Ptr); ----------------------------- -- Trimmed_Image functions -- ----------------------------- -- The following return 'Image (X) without the leading space. The intent is -- that they are called with a type conversion (unless the type is already -- Long_Long or Unsigned_Long_Long). function Trimmed_Image (X : Long_Long) return Standard.String; function Trimmed_Image (X : Unsigned_Long_Long) return Standard.String; --------------------------------- -- String conversion functions -- --------------------------------- function To_PolyORB_String (Source : Standard.String) return String; function To_Standard_String (Source : String) return Standard.String; function To_PolyORB_Wide_String (Source : Standard.Wide_String) return Wide_String; function To_Standard_Wide_String (Source : Wide_String) return Standard.Wide_String; type Identifier is new PolyORB.Types.String; type RepositoryId is new PolyORB.Types.String; ------------------------------------------ -- Synchronisation of request execution -- ------------------------------------------ -- XXX Do we really need this type ? -- Should be already managed in PolyORB.Any ... -- This type is declared here because it must be visible in the specs of -- Requests and References. type Synchronisation_Scope is (None, With_Transport, With_Server, With_Target); -- A 'synchronistaion scope' value is associated with each request object. -- When a request is not synchronised, the middleware returns to the caller -- before passing the request to the transport layer. The middleware MUST -- guarantee that the call is non-blocking. -- When a request is synchronised With_Transport, the middleware must not -- return to the caller before the corresponding message message has been -- accepted by the transport layer. -- When a request is synchronised With_Server, the middleware does not -- return before receiving a confirmation that the request message has been -- received by the server middleware. -- When a request is synchronised With_Target, the middlware does not -- return to the caller before receinving a confirmation that the request -- has been executed by the target object. private pragma Inline (To_PolyORB_String); pragma Inline (To_Standard_String); pragma Inline (To_PolyORB_Wide_String); pragma Inline (To_Standard_Wide_String); end PolyORB.Types; polyorb-2.8~20110207.orig/src/polyorb-binding_objects.adb0000644000175000017500000001665211750740340022462 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . B I N D I N G _ O B J E C T S -- -- -- -- B o d y -- -- -- -- Copyright (C) 2004-2009, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- Binding object: A protocol stacks considered as a reference-counted entity with PolyORB.Errors; with PolyORB.Filters.Iface; with PolyORB.Log; with PolyORB.ORB; package body PolyORB.Binding_Objects is use PolyORB.Log; package L is new PolyORB.Log.Facility_Log ("polyorb.binding_objects"); procedure O (Message : String; Level : Log_Level := Debug) renames L.Output; function C (Level : Log_Level := Debug) return Boolean renames L.Enabled; use PolyORB.Binding_Data; use type PolyORB.Components.Component_Access; -------------- -- Finalize -- -------------- procedure Finalize (X : in out Binding_Object) is use PolyORB.Annotations; use PolyORB.Components; use PolyORB.Errors; Error : Error_Container; begin pragma Debug (C, O ("Finalizing binding object")); -- First remove the reference to this BO from its ORB so that is does -- not get reused while being finalized. ORB.Unregister_Binding_Object (ORB.ORB_Access (X.ORB), X'Unchecked_Access); -- Notify protocol stack that it is about to be dismantled Throw (Error, Comm_Failure_E, System_Exception_Members'(Minor => 0, Completed => Completed_Maybe)); Emit_No_Reply (Component_Access (X.Transport_Endpoint), Filters.Iface.Disconnect_Indication'(Error => Error)); -- Destroy the transport endpoint at the bottom of the protocol stack -- (and all other components connected up). pragma Debug (C, O ("Destroying protocol stack")); Transport.Destroy (X.Transport_Endpoint); -- Finalize the data (profile and annotations) if X.Profile /= null then Destroy_Profile (X.Profile); end if; Destroy (X.Notepad); pragma Debug (C, O ("RIP")); end Finalize; ------------------- -- Get_Component -- ------------------- function Get_Component (X : Smart_Pointers.Ref) return Components.Component_Access is begin return Components.Component_Access (Binding_Object_Access (Smart_Pointers.Entity_Of (X)).Top); end Get_Component; ------------------ -- Get_Endpoint -- ------------------ function Get_Endpoint (X : Smart_Pointers.Ref) return Transport.Transport_Endpoint_Access is begin return Binding_Object_Access (Smart_Pointers.Entity_Of (X)).Transport_Endpoint; end Get_Endpoint; ----------------- -- Get_Profile -- ----------------- function Get_Profile (BO : Binding_Object_Access) return Binding_Data.Profile_Access is begin return BO.Profile; end Get_Profile; ---------- -- Link -- ---------- function Link (X : access Binding_Object'Class; Which : Utils.Ilists.Link_Type) return access Binding_Object_Access is begin return X.Links (Which)'Unchecked_Access; end Link; ---------------- -- Referenced -- ---------------- function Referenced (BO : Binding_Object_Access) return Boolean is begin return BO.Referenced; end Referenced; -------------------- -- Set_Referenced -- -------------------- procedure Set_Referenced (BO : Binding_Object_Access; Referenced : Boolean) is begin BO.Referenced := Referenced; end Set_Referenced; -------------------------- -- Setup_Binding_Object -- -------------------------- procedure Setup_Binding_Object (ORB : Components.Component_Access; TE : Transport.Transport_Endpoint_Access; FFC : Filters.Factory_Array; BO_Ref : out Smart_Pointers.Ref; Pro : Binding_Data.Profile_Access) is BO : Binding_Object_Access; Bottom : Filters.Filter_Access; begin BO := new Binding_Object; Smart_Pointers.Set (BO_Ref, Smart_Pointers.Entity_Ptr (BO)); Set_Profile (BO, Pro); BO.ORB := ORB; BO.Transport_Endpoint := TE; Filters.Create_Filter_Chain (FFC, Bottom => Bottom, Top => BO.Top); Transport.Connect_Upper (TE, Components.Component_Access (Bottom)); Filters.Connect_Lower (Bottom, Components.Component_Access (TE)); end Setup_Binding_Object; ----------------- -- Set_Profile -- ----------------- procedure Set_Profile (BO : Binding_Object_Access; P : Binding_Data.Profile_Access) is begin if BO.Profile /= null then Destroy_Profile (BO.Profile); end if; -- We need to take a copy of P, rather than point into the original -- reference that was used to create this binding object, since the -- original reference may be destroyed after the binding object gets -- reused for another reference. if P /= null then BO.Profile := Duplicate_Profile (P.all); else BO.Profile := null; end if; end Set_Profile; ---------------- -- Notepad_Of -- ---------------- function Notepad_Of (BO : Binding_Object_Access) return Annotations.Notepad_Access is begin return BO.Notepad'Access; end Notepad_Of; ----------- -- Valid -- ----------- function Valid (BO : Binding_Object_Access) return Boolean is use Components; use Filters.Iface; Reply : constant Message'Class := Emit (Component_Access (BO.Top), Check_Validity'(null record)); begin return Reply in Components.Null_Message; end Valid; end PolyORB.Binding_Objects; polyorb-2.8~20110207.orig/src/polyorb-smart_pointers-initialization.ads0000644000175000017500000000426111750740340025447 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- POLYORB.SMART_POINTERS.INITIALIZATION -- -- -- -- S p e c -- -- -- -- Copyright (C) 2004 Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by ACT Europe. -- -- (email: sales@act-europe.fr) -- -- -- ------------------------------------------------------------------------------ -- Initialization code for PolyORB.Smart_Pointers package PolyORB.Smart_Pointers.Initialization is pragma Elaborate_Body; end PolyORB.Smart_Pointers.Initialization; polyorb-2.8~20110207.orig/src/polyorb-utils-report.ads0000644000175000017500000001002611750740340022016 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . U T I L S . R E P O R T -- -- -- -- S p e c -- -- -- -- Copyright (C) 2003-2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- This package provides utility functions to display example and -- testsuite outputs, and manipulate some statistical data. package PolyORB.Utils.Report is procedure New_Test (Test_Name : String); -- Begin a new test procedure Output (Message : String; Result : Boolean); -- Output a formatted string with message and the result procedure End_Report; -- Close a report, returning FALSE if at least one test failed, -- TRUE otherwise. generic type T is delta <>; package Statistics is type Stat_Vector is array (Natural range <>) of T; function Min (V : Stat_Vector) return T; -- Return the minimum of statistical vector V function Max (V : Stat_Vector) return T; -- Return the maximum of statistical vector V function Avg (V : Stat_Vector) return Float; -- Return the average value of statistical vector V function Std_Dev (V : Stat_Vector) return Float; -- Return the standard deviation of statistical vector V procedure To_GNUPlot (V : Stat_Vector; Filename : String); -- Output V as a file ready for GNUPlot, this file will be called -- 'Filename'.gnuplot. When running 'gnuplot filename.gnuplot', -- 'Filename'.eps is created. type Bin is record Value : Natural := 0; Index : T; end record; type Partitions is array (Natural range <>) of Bin; function Partition (V : Stat_Vector; Number_Of_Bins : Natural; Low : Float; High : Float) return Partitions; -- Partition V into a set of Number_Of_Bins bins, data are -- considered inside the [Low; High] interval. procedure To_GNUPlot (P : Partitions; Filename : String); -- Output V as a file ready for GNUPlot, this file will be called -- 'Filename.gnuplot'. procedure Analyse_Vector (V : Stat_Vector; Filename : String); -- Output statistiacal information about V, store them in 'Filename' end Statistics; end PolyORB.Utils.Report; polyorb-2.8~20110207.orig/src/polyorb-transport.adb0000644000175000017500000001334211750740340021364 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . T R A N S P O R T -- -- -- -- B o d y -- -- -- -- Copyright (C) 2001-2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- Abstract transport service access points and communication endpoints with PolyORB.Filters.Iface; with PolyORB.ORB.Iface; package body PolyORB.Transport is use PolyORB.Components; ---------------- -- Notepad_Of -- ---------------- function Notepad_Of (TAP : Transport_Access_Point_Access) return Annotations.Notepad_Access is begin return TAP.Notepad'Access; end Notepad_Of; ------------------- -- Handle_Mesage -- ------------------- function Handle_Message (TAP : not null access Transport_Access_Point; Msg : Components.Message'Class) return Components.Message'Class is begin raise Program_Error; -- Small is beautiful. pragma Warnings (Off); -- Recent GNAT versions emit a warning for possible -- infinite recursion here. return Handle_Message (TAP, Msg); -- Keep the compiler happy. pragma Warnings (On); end Handle_Message; function Handle_Message (TE : not null access Transport_Endpoint; Msg : Components.Message'Class) return Components.Message'Class is use Filters.Iface; begin if Msg in Filters.Iface.Check_Validity then if not TE.Closed then -- If TE is not closed yet, check that it is still valid, which -- may cause it to close. Check_Validity (Transport_Endpoint'Class (TE.all)'Access); end if; if TE.Closed then declare use Errors; Reply : Filter_Error; begin Throw (Reply.Error, Comm_Failure_E, System_Exception_Members' (Minor => 0, Completed => Completed_No)); return Reply; end; else declare Reply : Components.Null_Message; begin return Reply; end; end if; elsif False or else Msg in Connect_Indication or else Msg in Connect_Confirmation then return Emit (TE.Upper, Msg); else raise Program_Error; end if; end Handle_Message; -------------------- -- Check_Validity -- -------------------- procedure Check_Validity (TE : access Transport_Endpoint) is begin null; end Check_Validity; ----------- -- Close -- ----------- procedure Close (TE : access Transport_Endpoint) is begin if TE.Closed then return; end if; Emit_No_Reply (TE.Server, ORB.Iface.Unregister_Endpoint' (TE => Transport_Endpoint_Access (TE))); TE.Closed := True; end Close; ------------------- -- Connect_Upper -- ------------------- procedure Connect_Upper (TE : access Transport_Endpoint; Upper : Components.Component_Access) is begin Components.Connect (TE.Upper, Upper); end Connect_Upper; ------------- -- Destroy -- ------------- procedure Destroy (TE : in out Transport_Endpoint) is begin Annotations.Destroy (TE.Notepad); Destroy (TE.Upper); end Destroy; ------------- -- Destroy -- ------------- procedure Destroy (TE : in out Transport_Endpoint_Access) is begin Components.Destroy (Components.Component_Access (TE)); end Destroy; ---------------- -- Notepad_Of -- ---------------- function Notepad_Of (TE : Transport_Endpoint_Access) return Annotations.Notepad_Access is begin return TE.Notepad'Access; end Notepad_Of; ----------- -- Upper -- ----------- function Upper (TE : Transport_Endpoint_Access) return Components.Component_Access is begin return TE.Upper; end Upper; end PolyORB.Transport; polyorb-2.8~20110207.orig/src/polyorb-utils-chained_lists.ads0000644000175000017500000001447011750740340023323 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . U T I L S . C H A I N E D _ L I S T S -- -- -- -- S p e c -- -- -- -- Copyright (C) 2001-2009, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- Generic chained list of nonlimited values with dynamic allocation pragma Ada_2005; with PolyORB.Utils.Ilists; generic type T is private; with function "=" (X, Y : T) return Boolean is <>; Doubly_Chained : Boolean := False; package PolyORB.Utils.Chained_Lists is pragma Preelaborate; type List is private; -- pragma Preelaborable_Initialization (List); -- WAG:61 -- Compiler fails to note that a type derived from a private type with -- preelaborable initialization also has. type Iterator is private; type Element_Access is access all T; function Length (L : List) return Natural; -- Return the number of elements in L function Element (L : List; Index : Natural) return Element_Access; -- Return the element at position Index (0-based) in L procedure Extract_First (L : in out List; Result : out T); -- Return the first element of L into Result, and remove if from L function First (L : List) return Iterator; -- Return an iterator on L positioned at L's first element. If L is empty, -- returns the same value as Last (L). function Last (L : List) return Iterator; -- Return an iterator on L positioned past L's last element function Value (I : Iterator) return Element_Access; -- Return an access to the value of the element designated by I procedure Next (I : in out Iterator); -- Move I to the next element in the list function Last (I : Iterator) return Boolean; -- True when I is positioned at the end of L (i.e. after the last element) procedure Prepend (L : in out List; I : T); -- Prepend value I at the beginning of L procedure Append (L : in out List; I : T); -- Append value I at the end of L procedure Remove (L : in out List; I : in out Iterator); -- Remove the item designated by I from L, and advance I to the next item -- in L. This procedure can be used only if Doubly_Chained is True (else -- Program_Error is raised). generic with function Predicate (X : T) return Boolean; procedure Remove_G (L : in out List; All_Occurrences : Boolean := True); -- Remove from L items for which Predicate is True. If All_Occurrences is -- True, remove all such items, else only the first such item (if any). procedure Remove_Occurrences (L : in out List; I : T; All_Occurrences : Boolean := True); -- Remove first/all occurences of value I from list L function Is_Empty (L : List) return Boolean; -- True iff L contains no elements function "+" (I : T) return List; -- Make a list with I as its only element function "&" (L : List; I : T) return List; -- Append I to L and return L function Duplicate (L : List) return List; -- Return a copy of list L procedure Deallocate (L : in out List); -- Release the storage associated with L function Empty return List; private pragma Inline (First); pragma Inline (Value); pragma Inline (Last); pragma Inline (Next); pragma Inline (Prepend); pragma Inline (Append); pragma Inline (Empty); pragma Inline (Remove); pragma Inline ("+"); pragma Inline ("&"); type Node; type Node_Access is access all Node; -- For simply chained lists, we only have one Next pointer in each node; -- for doubly chained lists, we have Next and Prev. Links_Type_Low : constant array (Boolean) of Ilists.Link_Type := (False => Ilists.Next, True => Ilists.Prev); type Links_Type is array (Ilists.Link_Type range Links_Type_Low (Doubly_Chained) .. Ilists.Next) of aliased Node_Access; -- If Doubly_Chained, Links_Type has indices Prev and Next, else just Next type Node is limited record Value : aliased T; -- Value associated with this list node Links : Links_Type; -- Next and (optional) Prev nodes. end record; function Link (N : access Node; Which : Ilists.Link_Type) return access Node_Access; pragma Inline (Link); -- Accessor for Links package Node_Lists is new Ilists.Lists (T => Node, T_Acc => Node_Access, Doubly_Linked => Doubly_Chained); type List is new Node_Lists.List; type Iterator is new Node_Lists.Iterator; end PolyORB.Utils.Chained_Lists; polyorb-2.8~20110207.orig/src/polyorb-binding_data_qos.adb0000644000175000017500000001054011750740340022612 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . B I N D I N G _ D A T A _ Q O S -- -- -- -- B o d y -- -- -- -- Copyright (C) 2005 Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with PolyORB.Annotations; package body PolyORB.Binding_Data_QoS is type Profile_QoS_Note is new Annotations.Note with record QoS : PolyORB.QoS.QoS_Parameters; end record; procedure Destroy (N : in out Profile_QoS_Note); Empty_Profile_QoS_Note : constant Profile_QoS_Note := (Annotations.Note with QoS => (others => null)); ------------- -- Destroy -- ------------- procedure Destroy (N : in out Profile_QoS_Note) is begin for J in PolyORB.QoS.QoS_Kind loop PolyORB.QoS.Release (N.QoS (J)); end loop; end Destroy; --------------------- -- Get_Profile_QoS -- --------------------- function Get_Profile_QoS (Prof : access PolyORB.Binding_Data.Profile_Type'Class) return PolyORB.QoS.QoS_Parameters is Note : Profile_QoS_Note; begin PolyORB.Annotations.Get_Note (PolyORB.Binding_Data.Notepad_Of (Prof).all, Note, Empty_Profile_QoS_Note); return Note.QoS; end Get_Profile_QoS; function Get_Profile_QoS (Prof : access PolyORB.Binding_Data.Profile_Type'Class; Kind : PolyORB.QoS.QoS_Kind) return PolyORB.QoS.QoS_Parameter_Access is Note : Profile_QoS_Note; begin PolyORB.Annotations.Get_Note (PolyORB.Binding_Data.Notepad_Of (Prof).all, Note, Empty_Profile_QoS_Note); return Note.QoS (Kind); end Get_Profile_QoS; --------------------- -- Set_Profile_QoS -- --------------------- procedure Set_Profile_QoS (Prof : access PolyORB.Binding_Data.Profile_Type'Class; QoS : PolyORB.QoS.QoS_Parameters) is Note : Profile_QoS_Note; begin Note.QoS := QoS; PolyORB.Annotations.Set_Note (PolyORB.Binding_Data.Notepad_Of (Prof).all, Note); end Set_Profile_QoS; procedure Set_Profile_QoS (Prof : access PolyORB.Binding_Data.Profile_Type'Class; Kind : PolyORB.QoS.QoS_Kind; QoS : PolyORB.QoS.QoS_Parameter_Access) is Note : Profile_QoS_Note; begin PolyORB.Annotations.Get_Note (PolyORB.Binding_Data.Notepad_Of (Prof).all, Note, Empty_Profile_QoS_Note); Note.QoS (Kind) := QoS; PolyORB.Annotations.Set_Note (PolyORB.Binding_Data.Notepad_Of (Prof).all, Note); end Set_Profile_QoS; end PolyORB.Binding_Data_QoS; polyorb-2.8~20110207.orig/src/polyorb-tasking-profiles-ravenscar-threads.adb0000644000175000017500000006313411750740340026227 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- POLYORB.TASKING.PROFILES.RAVENSCAR.THREADS -- -- -- -- B o d y -- -- -- -- Copyright (C) 2002-2011, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- Implementation of Threads under the Ravenscar profile. -- WAG:601 -- pragma Warnings (Off) with pattern not supported in that compiler version -- so use plain pragma Warnings (Off/On) instead. -- pragma Warnings (Off, "* is an internal GNAT unit"); -- pragma Warnings (Off, "use of this unit is non-portable*"); pragma Warnings (Off); -- Depends on System.Tasking.Utilities, an internal GNAT unit with System.Tasking.Utilities; pragma Warnings (On); with Ada.Real_Time; with Ada.Task_Identification; with Ada.Unchecked_Conversion; with PolyORB.Log; with PolyORB.Utils.Strings; package body PolyORB.Tasking.Profiles.Ravenscar.Threads is use PolyORB.Log; package L is new PolyORB.Log.Facility_Log ("polyorb.tasking.profiles.ravenscar.threads"); procedure O (Message : String; Level : Log_Level := Debug) renames L.Output; function C (Level : Log_Level := Debug) return Boolean renames L.Enabled; --------- -- Ids -- --------- -- Id are associated to the tasks created from this package. -- The last Id is reserved to the main context, which -- is the task that execute the Initialize procedure of this package. -- In this package, it is called the main task, and the Thread object -- associated to it is called the main Thread. package Thread_Index_Manager is new PolyORB.Tasking.Profiles.Ravenscar.Index_Manager (Number_Of_System_Tasks - 1); subtype Task_Index_Type is Thread_Index_Manager.Index_Type; -- Type of the Ids of the Threads that are not the one of the main task. subtype Thread_Index_Type is Integer range Task_Index_Type'First .. Task_Index_Type'Last + 1; -- Type of the Ids of all the Threads, including the one -- of the main task -- Paramaters associated to this main task : Main_Task_Index : constant Integer := Thread_Index_Type'Last; Main_Task_Tid : Ada.Task_Identification.Task_Id; -- XXX These two functions are duplicated from Full_Tasking function P_To_A_Task_Id (TID : PTT.Thread_Id) return Ada.Task_Identification.Task_Id; pragma Inline (P_To_A_Task_Id); -- Convert PolyORB Task_Id to Ada Task_Id function A_To_P_Task_Id (ATID : Ada.Task_Identification.Task_Id) return PTT.Thread_Id; pragma Inline (A_To_P_Task_Id); -- Convert Ada Task_Id to PolyORB Task_Id -------------------- -- P_To_A_Task_Id -- -------------------- function P_To_A_Task_Id (TID : PTT.Thread_Id) return Ada.Task_Identification.Task_Id is function STID_To_ATID is new Ada.Unchecked_Conversion (System.Tasking.Task_Id, Ada.Task_Identification.Task_Id); begin -- Casing of To_Task_ID has changed. return STID_To_ATID (System.Tasking.To_Task_Id (PTT.To_Address (TID))); end P_To_A_Task_Id; -------------------- -- A_To_P_Task_Id -- -------------------- function A_To_P_Task_Id (ATID : Ada.Task_Identification.Task_Id) return PTT.Thread_Id is function ATID_To_STID is new Ada.Unchecked_Conversion (Ada.Task_Identification.Task_Id, System.Tasking.Task_Id); begin return PTT.To_Thread_Id (System.Tasking.To_Address (ATID_To_STID (ATID))); end A_To_P_Task_Id; ------------------- -- Tasking Types -- ------------------- -- Tasking type used in the pools preallocated by this package: task type Simple_Task is pragma Storage_Size (Storage_Size); pragma Priority (Task_Priority); end Simple_Task; -- Type of the task that run the submitted threads protected type Barrier is -- Type of the internal synchronisation object of the tasks -- allocated through this package. -- A call to Suspend will result in a call to Wait; -- a call to Resume will result in a call to Signal. procedure Prepare_Wait; -- Initialize the barrier for a call to Wait. If it is already -- prepared to Wait, raise an assertion failure. procedure Abort_Wait; -- Abort the previous call to Prepare_Wait. If no call to Prepare_Wait -- has been done, raise an assertion failure. entry Wait; -- Wait until it is signaled procedure Signal; -- Signal the Suspension_Object function Get_Waiting return Boolean; function Get_Signaled return Boolean; private Signaled : Boolean := False; Waiting : Boolean := False; end Barrier; ----------- -- Pools -- ----------- -- Every object used in this package is preallocated at initialisation -- time, in a pool. type Task_Id_Arr is array (Thread_Index_Type) of Ada.Task_Identification.Task_Id; -- Table of the Task_Id of the task of the pool protected Pool_Manager is -- Protected manager for the pool procedure Initialize_Id (Tid : Ada.Task_Identification.Task_Id; Idx : out Thread_Index_Type); -- This procedure is called at initialization time -- by the tasks, to get a unique id. procedure End_Initialization (Id : Thread_Index_Type); -- Signal that the task which id is Id has finished its initialization entry Wait_For_Package_Initialization; -- This entry block the initialisation loop -- until all the Thread are initialised. procedure Create_Thread (Id : Thread_Index_Type; Run : Runnable_Access; T : out Thread_Access); -- This is the protected section of the Create_Thread procedure. procedure Create_Thread (Id : Thread_Index_Type; P : Parameterless_Procedure; T : out Thread_Access); -- This is the protected section of the Create_Thread procedure function Lookup (Tid : Ada.Task_Identification.Task_Id) return Integer; -- Get the Thread_Access associated to the given Task_Id procedure Initialize; -- Initialisation procedure of Pool_Manager private Package_Initialized : Boolean := False; Current : Integer := Task_Index_Type'First; My_Task_Id_Arr : Task_Id_Arr; end Pool_Manager; type Thread_Arr is array (Thread_Index_Type) of aliased Ravenscar_Thread_Type; My_Thread_Arr : Thread_Arr; -- Pool of Threads type Runnable_Arr is array (Thread_Index_Type) of Runnable_Access; type Job_Passing is (Use_Runnable, Use_PP); -- There is two way to pass a job to the tasks: -- by a Runnable or by a Parameterless_Procedure. -- This type is used to discriminate. type Job_Passing_Arr is array (Thread_Index_Type) of Job_Passing; My_Job_Passing_Arr : Job_Passing_Arr; My_Runnable_Arr : Runnable_Arr; -- Pool of Runnables type PP_Arr is array (Thread_Index_Type) of Parameterless_Procedure; My_PP_Arr : PP_Arr; -- Pool of Parameterless_Procedure Task_Pool : array (Task_Index_Type) of Simple_Task; pragma Warnings (Off); pragma Unreferenced (Task_Pool); pragma Warnings (On); -- Pool of preallocated tasks type Barrier_Arr is array (Synchro_Index_Type) of Barrier; Sync_Pool : Barrier_Arr; -- Pool of Barrier used for synchronisations ------------------- -- Abort_Suspend -- ------------------- procedure Abort_Suspend (S : Synchro_Index_Type) is begin pragma Debug (C, O ("abort suspend on " & Integer'Image (Integer (S)))); Sync_Pool (S).Abort_Wait; pragma Debug (C, O ("abort done on " & Integer'Image (Integer (S)))); Synchro_Index_Manager.Release (Synchro_Index_Manager.Index_Type (S)); end Abort_Suspend; ------------- -- Barrier -- ------------- protected body Barrier is ------------------------- -- Barrier.Get_Waiting -- ------------------------- function Get_Waiting return Boolean is begin return Waiting; end Get_Waiting; -------------------------- -- Barrier.Get_Signaled -- -------------------------- function Get_Signaled return Boolean is begin return Signaled; end Get_Signaled; -------------------------- -- Barrier.Prepare_Wait -- -------------------------- procedure Prepare_Wait is begin pragma Assert (not Signaled); -- Why should we be signaled if we are not waiting yet? -- It would definitely be an error. pragma Assert (not Waiting); -- Fail if it is the second call to Prepare_Wait Waiting := True; end Prepare_Wait; ------------------------ -- Barrier.Abort_Wait -- ------------------------ procedure Abort_Wait is begin pragma Assert (Waiting); -- Fail if we try to abort, but no call to suspend were prepared. Waiting := False; end Abort_Wait; -------------------- -- Barrier.Signal -- -------------------- procedure Signal is begin pragma Assert (not Signaled); -- XXX This assertion is a temporary one; it is just to see -- if some signal are lost. If it is raised in one of your -- tests, comment this line and tell me (JG) how you this -- assertion was raised. -- Received two signals before being released. One will be lost. -- Is it a normal behaviour? It should be the reponsibility of -- the synchro objects (Mutexes, CV) to take care of this loss, -- not the thread's. pragma Assert (Waiting); -- XXX This assertion is a temporary one; it is just to see -- if some signal are lost. If it is raised in one of your -- tests, comment this line and tell me (JG) how this -- assertion was raised. if Waiting then Signaled := True; end if; end Signal; ------------------ -- Barrier.Wait -- ------------------ entry Wait when Signaled is begin pragma Assert (Waiting); -- Error : Prepare_Wait have not been called before. pragma Debug (C, O ("wait done!")); Signaled := False; Waiting := False; end Wait; end Barrier; --------------------------- -- Get_Current_Thread_Id -- --------------------------- function Get_Current_Thread_Id (TF : access Ravenscar_Thread_Factory_Type) return Thread_Id is pragma Warnings (Off); pragma Unreferenced (TF); pragma Warnings (On); begin return A_To_P_Task_Id (Ada.Task_Identification.Current_Task); end Get_Current_Thread_Id; --------------------- -- Thread_Id_Image -- --------------------- function Thread_Id_Image (TF : access Ravenscar_Thread_Factory_Type; TID : PTT.Thread_Id) return String is pragma Warnings (Off); pragma Unreferenced (TF); pragma Warnings (On); Index_Image : constant String := Integer'Image (Get_Thread_Index (TID)); begin if TID = Null_Thread_Id then return ""; else return Ada.Task_Identification.Image (P_To_A_Task_Id (TID)) & "(" & Index_Image (Index_Image'First + 1 .. Index_Image'Last) & ")"; end if; end Thread_Id_Image; ------------------- -- Get_Thread_Id -- ------------------- function Get_Thread_Id (T : access Ravenscar_Thread_Type) return Thread_Id is begin return T.Id; end Get_Thread_Id; ------------------ -- Set_Priority -- ------------------ procedure Set_Priority (TF : access Ravenscar_Thread_Factory_Type; T : PTT.Thread_Id; P : System.Any_Priority) is pragma Warnings (Off); pragma Unreferenced (TF); pragma Unreferenced (T); pragma Unreferenced (P); pragma Warnings (On); begin raise Tasking_Error; end Set_Priority; ------------------ -- Get_Priority -- ------------------ function Get_Priority (TF : access Ravenscar_Thread_Factory_Type; T : PTT.Thread_Id) return System.Any_Priority is pragma Warnings (Off); pragma Unreferenced (TF); pragma Warnings (On); Index : constant Integer := Get_Thread_Index (T); pragma Unreferenced (Index); -- Note: we compute index only to check T belongs to system -- tasks. If not, getting its priority is meaningless. begin return Task_Priority; end Get_Priority; ---------------------- -- Get_Thread_Index -- ---------------------- function Get_Thread_Index (T : Thread_Id) return Integer is begin return Pool_Manager.Lookup (P_To_A_Task_Id (T)); end Get_Thread_Index; ------------- -- Stopper -- ------------- protected Stopper is procedure Can_Stop (B : out Boolean); entry Stop; private My : Boolean := True; end Stopper; protected body Stopper is procedure Can_Stop (B : out Boolean) is begin B := My; My := False; end Can_Stop; entry Stop when False is begin null; end Stop; end Stopper; --------------------- -- Prepare_Suspend -- --------------------- function Prepare_Suspend return Synchro_Index_Type is S : Synchro_Index_Type; B : Boolean; begin Synchro_Index_Manager.Get (Synchro_Index_Manager.Index_Type (S)); pragma Debug (C, O ("prepare suspend on" & S'Img)); Sync_Pool (S).Prepare_Wait; pragma Debug (C, O ("prepared susped on" & S'Img)); return S; exception when others => Stopper.Can_Stop (B); if B then Stopper.Stop; end if; raise; end Prepare_Suspend; ------------------ -- Pool_Manager -- ------------------ protected body Pool_Manager is ------------------- -- Create_Thread -- ------------------- procedure Create_Thread (Id : Thread_Index_Type; Run : Runnable_Access; T : out Thread_Access) is Result : Ravenscar_Thread_Access; begin pragma Assert (Package_Initialized); My_Job_Passing_Arr (Id) := Use_Runnable; My_Runnable_Arr (Id) := Run; Result := My_Thread_Arr (Id)'Access; T := Thread_Access (Result); end Create_Thread; ------------------- -- Create_Thread -- ------------------- procedure Create_Thread (Id : Thread_Index_Type; P : Parameterless_Procedure; T : out Thread_Access) is Result : Ravenscar_Thread_Access; begin pragma Assert (Package_Initialized); My_Job_Passing_Arr (Id) := Use_PP; My_PP_Arr (Id) := P; Result := My_Thread_Arr (Id)'Access; T := Thread_Access (Result); end Create_Thread; ------------------------ -- End_Initialization -- ------------------------ procedure End_Initialization (Id : Thread_Index_Type) is pragma Warnings (Off); pragma Unreferenced (Id); pragma Warnings (On); begin Package_Initialized := Current >= Thread_Index_Type'Last; end End_Initialization; ----------------------------- -- Pool_Manager.Initialize -- ----------------------------- procedure Initialize is begin My_Task_Id_Arr (Main_Task_Index) := Main_Task_Tid; My_Thread_Arr (Main_Task_Index).Id := A_To_P_Task_Id (Main_Task_Tid); end Initialize; -------------------------------- -- Pool_Manager.Initialize_Id -- -------------------------------- procedure Initialize_Id (Tid : Ada.Task_Identification.Task_Id; Idx : out Thread_Index_Type) is begin pragma Assert (not Package_Initialized); pragma Assert (Current <= Thread_Index_Type'Last); Idx := Current; My_Thread_Arr (Current).Id := A_To_P_Task_Id (Tid); My_Task_Id_Arr (Current) := Tid; Current := Current + 1; pragma Debug (C, O ("number of tasks initialized : " & Integer'Image (Current))); end Initialize_Id; ------------------------- -- Pool_Manager.Lookup -- ------------------------- function Lookup (Tid : Ada.Task_Identification.Task_Id) return Integer is J : Integer := Thread_Index_Type'First; use Ada.Task_Identification; begin pragma Assert (Package_Initialized); while My_Task_Id_Arr (J) /= Tid loop if J = Thread_Index_Type'Last then -- Tis is not managed by this pool raise Tasking_Error; end if; J := J + 1; end loop; return J; end Lookup; -------------------------------------------------- -- Pool_Manager.Wait_For_Package_Initialization -- -------------------------------------------------- entry Wait_For_Package_Initialization when Package_Initialized is begin null; end Wait_For_Package_Initialization; end Pool_Manager; ----------------- -- Run_In_Task -- ----------------- -- XXX TOO MUCH CODE DUPLICATION! -- Should be a simple call to the Runnable version! function Run_In_Task (TF : access Ravenscar_Thread_Factory_Type; Name : String := ""; Default_Priority : System.Any_Priority := System.Default_Priority; Storage_Size : Natural := 0; P : Parameterless_Procedure) return Thread_Access is pragma Warnings (Off); pragma Unreferenced (TF); pragma Unreferenced (Name); pragma Warnings (On); -- XXX The use of names is not implemented yet. Id : Thread_Index_Type; T : Thread_Access; begin if Default_Priority /= Task_Priority or else (Storage_Size /= 0 and then Storage_Size /= Tasking.Profiles.Ravenscar.Threads.Storage_Size) then raise Tasking_Error; end if; -- The following call should not be executed in a protected -- object, because it can be blocking. Thread_Index_Manager.Get (Id); Pool_Manager.Create_Thread (Id, P, T); declare RT : constant Ravenscar_Thread_Access := Ravenscar_Thread_Access (T); begin pragma Assert (Get_Thread_Index (RT.Id) /= Main_Task_Index); pragma Debug (C, O ("launch task " & Image (RT.Id) &" waiting on " & Integer'Image (Integer (RT.Sync_Id)))); -- Sync_Pool (RT.Id.Sync_Id).Signal; Resume (RT.Sync_Id); return T; end; end Run_In_Task; function Run_In_Task (TF : access Ravenscar_Thread_Factory_Type; Name : String := ""; Default_Priority : System.Any_Priority := System.Default_Priority; Storage_Size : Natural := 0; R : Runnable_Access) return Thread_Access is pragma Warnings (Off); pragma Unreferenced (TF); pragma Unreferenced (Name); pragma Warnings (On); -- XXX The use of names is not implemented yet. Id : Thread_Index_Type; T : Thread_Access; begin if Default_Priority /= Task_Priority or else (Storage_Size /= 0 and then Storage_Size /= Tasking.Profiles.Ravenscar.Threads.Storage_Size) then raise Tasking_Error; end if; -- The following call should not be executed in a protected -- object, because it can be blocking. Thread_Index_Manager.Get (Id); Pool_Manager.Create_Thread (Id, R, T); declare RT : constant Ravenscar_Thread_Access := Ravenscar_Thread_Access (T); begin pragma Assert (Get_Thread_Index (RT.Id) /= Main_Task_Index); pragma Debug (C, O ("launch task " & Image (RT.Id) &" waiting on " & Integer'Image (Integer (RT.Sync_Id)))); -- Sync_Pool (RT.Id.Sync_Id).Signal; Resume (RT.Sync_Id); return T; end; end Run_In_Task; ----------------- -- Simple_Task -- ----------------- task body Simple_Task is Index : Integer; Tid : constant Ada.Task_Identification.Task_Id := Ada.Task_Identification.Current_Task; begin Pool_Manager.Initialize_Id (Tid, Index); Synchro_Index_Manager.Initialize (False); My_Thread_Arr (Index).Sync_Id := Prepare_Suspend; Pool_Manager.End_Initialization (Index); loop Suspend (My_Thread_Arr (Index).Sync_Id); if My_Job_Passing_Arr (Index) = Use_Runnable then Run (My_Runnable_Arr (Index)); else My_PP_Arr (Index).all; end if; Free (My_Runnable_Arr (Index)); My_Thread_Arr (Index).Sync_Id := Prepare_Suspend; Thread_Index_Manager.Release (Index); end loop; end Simple_Task; ------------ -- Resume -- ------------ procedure Resume (S : Synchro_Index_Type) is begin pragma Debug (C, O ("Resume on " & Integer'Image (Integer (S)))); Sync_Pool (S).Signal; end Resume; ------------- -- Suspend -- ------------- procedure Suspend (S : Synchro_Index_Type) is begin pragma Debug (C, O ("will suspend: " & Integer'Image (Integer (S)))); Sync_Pool (S).Wait; pragma Assert (not Sync_Pool (S).Get_Signaled and then not Sync_Pool (S).Get_Waiting); pragma Debug (C, O ("end suspend: " & Integer'Image (Integer (S)))); Synchro_Index_Manager.Release (Synchro_Index_Manager.Index_Type (S)); end Suspend; -------------------- -- Relative_Delay -- -------------------- procedure Relative_Delay (TF : access Ravenscar_Thread_Factory_Type; D : Duration) is pragma Unreferenced (TF); use Ada.Real_Time; Deadline : constant Time := Clock + To_Time_Span (D); begin delay until Deadline; end Relative_Delay; ----------------- -- Awake_Count -- ----------------- function Awake_Count (TF : access Ravenscar_Thread_Factory_Type) return Natural is begin -- If the environment task is not callable we do not count it as awake if TF.Environment_Task.Callable then return TF.Environment_Task.Awake_Count; else return TF.Environment_Task.Awake_Count - 1; end if; end Awake_Count; ----------------------- -- Independent_Count -- ----------------------- function Independent_Count (TF : access Ravenscar_Thread_Factory_Type) return Natural is pragma Unreferenced (TF); begin return System.Tasking.Utilities.Independent_Task_Count; end Independent_Count; ---------------- -- Initialize -- ---------------- procedure Initialize is use Ada.Real_Time; begin PTT.Node_Boot_Time := To_Duration (Clock - Time_First); Thread_Index_Manager.Initialize; Synchro_Index_Manager.Initialize (False); Main_Task_Tid := Ada.Task_Identification.Current_Task; The_Thread_Factory.Environment_Task := System.Tasking.Self; Pool_Manager.Initialize; PTT.Register_Thread_Factory (PTT.Thread_Factory_Access (The_Thread_Factory)); Pool_Manager.Wait_For_Package_Initialization; end Initialize; use PolyORB.Initialization; use PolyORB.Initialization.String_Lists; use PolyORB.Utils.Strings; begin Register_Module (Module_Info' (Name => +"tasking.profiles.ravenscar.threads", Conflicts => Empty, Depends => Empty, Provides => +"tasking.threads", Implicit => False, Init => Initializer, Shutdown => null)); end PolyORB.Tasking.Profiles.Ravenscar.Threads; polyorb-2.8~20110207.orig/src/polyorb-tasking-advanced_mutexes.adb0000644000175000017500000001155211750740340024306 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . T A S K I N G . A D V A N C E D _ M U T E X E S -- -- -- -- B o d y -- -- -- -- Copyright (C) 2002-2008, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- This package provides an implementation of advanced mutexes. with Ada.Unchecked_Deallocation; with PolyORB.Log; package body PolyORB.Tasking.Advanced_Mutexes is use PolyORB.Log; package PTT renames PolyORB.Tasking.Threads; package L is new PolyORB.Log.Facility_Log ("polyorb.tasking.advanced_mutexes"); procedure O (Message : String; Level : Log_Level := Debug) renames L.Output; function C (Level : Log_Level := Debug) return Boolean renames L.Enabled; ------------ -- Create -- ------------ procedure Create (M : out Adv_Mutex_Access) is use PolyORB.Tasking.Threads; begin pragma Debug (C, O ("Create")); M := new Adv_Mutex_Type; M.Current := Current_Task; M.Empty := True; PTM.Create (M.MMutex); PTCV.Create (M.MCondition); M.Level := 0; M.Await_Count := 0; M.Passing := True; end Create; ------------- -- Destroy -- ------------- procedure Destroy (M : in out Adv_Mutex_Access) is procedure Free is new Ada.Unchecked_Deallocation (Adv_Mutex_Type, Adv_Mutex_Access); begin pragma Debug (C, O ("Destroy")); PTM.Destroy (M.MMutex); PTCV.Destroy (M.MCondition); Free (M); end Destroy; ----------- -- Enter -- ----------- procedure Enter (M : access Adv_Mutex_Type) is use PolyORB.Tasking.Threads; Self : constant Thread_Id := Current_Task; begin PTM.Enter (M.MMutex); pragma Debug (C, O (PTT.Image (Self) & " tries to Enter Adv_Mutex")); while not M.Empty and then M.Current /= Self loop pragma Debug (C, O (PTT.Image (Self) & " will wait for Adv_Mutex, current owner is " & PTT.Image (M.Current))); if not M.Passing then PTCV.Wait (M.MCondition, M.MMutex); end if; M.Passing := False; end loop; M.Empty := False; M.Level := M.Level + 1; M.Current := Self; pragma Debug (C, O ("Enter: " & PTT.Image (M.Current))); pragma Debug (C, O (" new level:" & Integer'Image (M.Level))); PTM.Leave (M.MMutex); end Enter; ----------- -- Leave -- ----------- procedure Leave (M : access Adv_Mutex_Type) is use PolyORB.Tasking.Threads; Self : constant Thread_Id := Current_Task; begin PTM.Enter (M.MMutex); pragma Debug (C, O ("Leave, owner was " & PTT.Image (Self))); pragma Assert (M.Current = Self); pragma Assert (M.Level > 0); M.Level := M.Level - 1; if M.Level = 0 then M.Empty := True; M.Passing := True; PTCV.Signal (M.MCondition); end if; pragma Debug (C, O (" new level:" & Integer'Image (M.Level))); PTM.Leave (M.MMutex); end Leave; end PolyORB.Tasking.Advanced_Mutexes; polyorb-2.8~20110207.orig/src/polyorb-transport-datagram-sockets.ads0000644000175000017500000001156511750740340024641 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . T R A N S P O R T . D A T A G R A M . S O C K E T S -- -- -- -- S p e c -- -- -- -- Copyright (C) 2003-2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- Datagram Socket Access Point and End Point to receive data from network with PolyORB.Sockets; with PolyORB.Utils.Sockets; package PolyORB.Transport.Datagram.Sockets is pragma Elaborate_Body; use PolyORB.Sockets; ------------------ -- Access Point -- ------------------ type Socket_Access_Point is new Datagram_Transport_Access_Point with private; -- Datagram Socket Access Point to receive data procedure Init_Socket (SAP : in out Socket_Access_Point; Socket : Socket_Type; Address : in out Sock_Addr_Type; Bind_Address : Sock_Addr_Type := No_Sock_Addr; Update_Addr : Boolean := True); -- Init datagram socket socket -- If Update_Addr is set, Address will be updated with the assigned socket -- address. If Bind_Address is not No_Sock_Addr, then that address is used -- to bind the access point, Address. This is used for multicast sockets -- on Windows, where we need to use IN_ADDR_ANY for Bind_Address, while -- still recording the proper group address in SAP. function Create_Event_Source (TAP : access Socket_Access_Point) return Asynch_Ev.Asynch_Ev_Source_Access; function Address_Of (SAP : Socket_Access_Point) return Utils.Sockets.Socket_Name; -- Return a Socket_Name designating SAP --------------- -- End Point -- --------------- type Socket_Endpoint is new Datagram_Transport_Endpoint with private; -- Datagram Socket Transport Endpoint for receiving data procedure Create (TE : in out Socket_Endpoint; S : Socket_Type; Addr : Sock_Addr_Type); -- Called on client side to assign remote server address function Create_Event_Source (TE : access Socket_Endpoint) return Asynch_Ev.Asynch_Ev_Source_Access; procedure Read (TE : in out Socket_Endpoint; Buffer : Buffers.Buffer_Access; Size : in out Ada.Streams.Stream_Element_Count; Error : out Errors.Error_Container); -- Read data from datagram socket procedure Write (TE : in out Socket_Endpoint; Buffer : Buffers.Buffer_Access; Error : out Errors.Error_Container); -- Write data to datagram socket procedure Close (TE : access Socket_Endpoint); function Create_Endpoint (TAP : access Socket_Access_Point) return Datagram_Transport_Endpoint_Access; -- Called on server side to initialize socket private type Socket_Access_Point is new Datagram_Transport_Access_Point with record Socket : Socket_Type := No_Socket; Addr : Sock_Addr_Type; end record; type Socket_Endpoint is new Datagram_Transport_Endpoint with record Handler : aliased Datagram_TE_AES_Event_Handler; Socket : Socket_Type := No_Socket; Remote_Address : Sock_Addr_Type; end record; end PolyORB.Transport.Datagram.Sockets; polyorb-2.8~20110207.orig/src/polyorb-tasking-profiles-full_tasking-threads.adb0000644000175000017500000003377711750740340026737 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- POLYORB.TASKING.PROFILES.FULL_TASKING.THREADS -- -- -- -- B o d y -- -- -- -- Copyright (C) 2002-2011, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- Implementation of Threads under the Full_Tasking profile. -- WAG:601 -- pragma Warnings (Off) with pattern not supported in that compiler version -- so use plain pragma Warnings (Off/On) instead. -- pragma Warnings (Off, "* is an internal GNAT unit"); -- pragma Warnings (Off, "use of this unit is non-portable*"); pragma Warnings (Off); -- Depends on System.Tasking.Utilities, an internal GNAT unit with System.Tasking.Utilities; pragma Warnings (On); with Ada.Exceptions; with Ada.Real_Time; with Ada.Unchecked_Deallocation; with Ada.Unchecked_Conversion; with PolyORB.Initialization; with PolyORB.Log; with PolyORB.Parameters; with PolyORB.Utils.Strings; package body PolyORB.Tasking.Profiles.Full_Tasking.Threads is use PolyORB.Log; package L is new PolyORB.Log.Facility_Log ("polyorb.tasking.profiles.full_tasking.threads"); procedure O (Message : String; Level : Log_Level := Debug) renames L.Output; function C (Level : Log_Level := Debug) return Boolean renames L.Enabled; -- Task type task type Generic_Task (P : System.Priority; S : Natural) is -- All purpose generic task that executes a 'Runnable' pragma Priority (P); pragma Storage_Size (S); entry Initialize (T : PTT.Thread_Access); -- Initialize the task entry Start (Run : PTT.Runnable_Access); -- Start the task end Generic_Task; type Generic_Task_Access is access Generic_Task; procedure Free_Generic_Task is new Ada.Unchecked_Deallocation (Generic_Task, Generic_Task_Access); type Full_Tasking_Thread_Type is new PTT.Thread_Type with record Id : PTT.Thread_Id; Self : Generic_Task_Access; Priority : System.Any_Priority; Stack_Size : Natural; end record; function Get_Thread_Id (T : access Full_Tasking_Thread_Type) return PTT.Thread_Id; type Full_Tasking_Thread_Access is access all Full_Tasking_Thread_Type'Class; procedure Free is new Ada.Unchecked_Deallocation (Full_Tasking_Thread_Type'Class, Full_Tasking_Thread_Access); function A_To_P_Task_Id (ATID : Ada.Task_Identification.Task_Id) return PTT.Thread_Id; pragma Inline (A_To_P_Task_Id); -- Convert Ada Task_Id to PolyORB Task_Id. type Simple_Runnable is new PTT.Runnable with record Main_Subprogram : PTT.Parameterless_Procedure; end record; -- Simplified runnable for parameterless procedure procedure Run (SR : not null access Simple_Runnable); task Reaper is entry Free (GT : Generic_Task_Access); -- Busy-wait for the designated task to terminate, then free it end Reaper; ------------ -- Reaper -- ------------ task body Reaper is Terminated_Task : Generic_Task_Access; begin loop select accept Free (GT : Generic_Task_Access) do Terminated_Task := GT; end Free; for Tries in 1 .. 3 loop if Terminated_Task'Terminated then pragma Debug (C, O ("Reaper: freeing generic task " & Ada.Task_Identification.Image (Terminated_Task'Identity))); Free_Generic_Task (Terminated_Task); exit; end if; delay 0.1; end loop; if Terminated_Task /= null then O ("Reaper: giving up on non-terminating task " & Ada.Task_Identification.Image (Terminated_Task'Identity), Notice); end if; or terminate; end select; end loop; end Reaper; -------------------- -- P_To_A_Task_Id -- -------------------- function P_To_A_Task_Id (TID : PTT.Thread_Id) return Ada.Task_Identification.Task_Id is function STID_To_ATID is new Ada.Unchecked_Conversion (System.Tasking.Task_Id, Ada.Task_Identification.Task_Id); begin return STID_To_ATID (System.Tasking.To_Task_Id (PTT.To_Address (TID))); end P_To_A_Task_Id; -------------------- -- A_To_P_Task_Id -- -------------------- function A_To_P_Task_Id (ATID : Ada.Task_Identification.Task_Id) return PTT.Thread_Id is function ATID_To_STID is new Ada.Unchecked_Conversion (Ada.Task_Identification.Task_Id, System.Tasking.Task_Id); begin return PTT.To_Thread_Id (System.Tasking.To_Address (ATID_To_STID (ATID))); end A_To_P_Task_Id; --------- -- Run -- --------- procedure Run (SR : not null access Simple_Runnable) is use type PTT.Parameterless_Procedure; begin if SR.Main_Subprogram /= null then SR.Main_Subprogram.all; end if; end Run; ----------------- -- Run_In_Task -- ----------------- function Run_In_Task (TF : access Full_Tasking_Thread_Factory_Type; Name : String := ""; Default_Priority : System.Any_Priority := System.Default_Priority; Storage_Size : Natural := 0; R : PTT.Runnable_Access) return PTT.Thread_Access is pragma Warnings (Off); pragma Unreferenced (TF); pragma Warnings (On); T : constant Full_Tasking_Thread_Access := new Full_Tasking_Thread_Type; GT : Generic_Task_Access; begin T.Priority := System.Priority (Parameters.Get_Conf ("tasking", "polyorb.tasking.threads." & Name & ".priority", Default_Priority)); if Storage_Size = 0 then T.Stack_Size := Parameters.Get_Conf ("tasking", "storage_size", PTT.Default_Storage_Size); else T.Stack_Size := Storage_Size; end if; GT := new Generic_Task (T.Priority, T.Stack_Size); T.Self := GT; GT.Initialize (PTT.Thread_Access (T)); GT.Start (R); return PTT.Thread_Access (T); end Run_In_Task; function Run_In_Task (TF : access Full_Tasking_Thread_Factory_Type; Name : String := ""; Default_Priority : System.Any_Priority := System.Default_Priority; Storage_Size : Natural := 0; P : PTT.Parameterless_Procedure) return PTT.Thread_Access is R : constant PTT.Runnable_Access := new Simple_Runnable; begin Simple_Runnable (R.all).Main_Subprogram := P; return Run_In_Task (TF, Name, Default_Priority, Storage_Size, R); end Run_In_Task; ------------------ -- Generic_Task -- ------------------ task body Generic_Task is The_Thread : Full_Tasking_Thread_Access; The_Runnable : PTT.Runnable_Access; Self : Generic_Task_Access; begin accept Initialize (T : PTT.Thread_Access) do The_Thread := Full_Tasking_Thread_Access (T); The_Thread.Id := A_To_P_Task_Id (Ada.Task_Identification.Current_Task); -- XXX Maybe The_Thread.Id could be suppressed altogether!! Self := The_Thread.Self; end Initialize; accept Start (Run : PTT.Runnable_Access) do The_Runnable := Run; end Start; begin PTT.Run (The_Runnable); exception when E : others => pragma Debug (C, O ("Generic_Task: " & PTT.Image (The_Thread.Id) & " abnormal termination: " & Ada.Exceptions.Exception_Information (E))); null; end; PTT.Free (The_Runnable); -- Generic task is about to terminate: after this point, the value of -- The_Thread that Run_In_Task returned to the caller is becoming -- invalid. Hopefully we've discarded it by then. Free (The_Thread); -- Here we should really signal the GNAT runtime that it can forget -- this task altogether, but GNAT.Threads.Unregister_Thread can't be -- called by an Ada task??? So, we use a specific reaper task instead. Reaper.Free (Self); end Generic_Task; --------------------------- -- Get_Current_Thread_Id -- --------------------------- function Get_Current_Thread_Id (TF : access Full_Tasking_Thread_Factory_Type) return PTT.Thread_Id is pragma Warnings (Off); pragma Unreferenced (TF); pragma Warnings (On); begin return A_To_P_Task_Id (Ada.Task_Identification.Current_Task); end Get_Current_Thread_Id; ------------------- -- Get_Thread_Id -- ------------------- function Get_Thread_Id (T : access Full_Tasking_Thread_Type) return PTT.Thread_Id is begin return T.Id; end Get_Thread_Id; ----------- -- Image -- ----------- function Thread_Id_Image (TF : access Full_Tasking_Thread_Factory_Type; TID : PTT.Thread_Id) return String is use PTT; pragma Warnings (Off); pragma Unreferenced (TF); pragma Warnings (On); begin if TID = Null_Thread_Id then return ""; else return Ada.Task_Identification.Image (P_To_A_Task_Id (TID)); end if; end Thread_Id_Image; ------------------ -- Set_Priority -- ------------------ procedure Set_Priority (TF : access Full_Tasking_Thread_Factory_Type; T : PTT.Thread_Id; P : System.Any_Priority) is begin Set_Priority_P.all (TF, T, P); end Set_Priority; ------------------ -- Get_Priority -- ------------------ function Get_Priority (TF : access Full_Tasking_Thread_Factory_Type; T : PTT.Thread_Id) return System.Any_Priority is begin return Get_Priority_P.all (TF, T); end Get_Priority; -------------------- -- Relative_Delay -- -------------------- procedure Relative_Delay (TF : access Full_Tasking_Thread_Factory_Type; D : Duration) is pragma Unreferenced (TF); begin delay D; end Relative_Delay; ----------------- -- Awake_Count -- ----------------- function Awake_Count (TF : access Full_Tasking_Thread_Factory_Type) return Natural is begin -- If the environment task is not callable, we do not count it as awake if TF.Environment_Task.Callable then return TF.Environment_Task.Awake_Count; else return TF.Environment_Task.Awake_Count - 1; end if; end Awake_Count; ----------------------- -- Independent_Count -- ----------------------- function Independent_Count (TF : access Full_Tasking_Thread_Factory_Type) return Natural is pragma Unreferenced (TF); begin return System.Tasking.Utilities.Independent_Task_Count; end Independent_Count; ---------------- -- Initialize -- ---------------- procedure Initialize; procedure Initialize is use Ada.Real_Time; use System.Tasking; Time_0 : constant Time := Time_Of (0, Time_Span_Zero); S_TID : System.Tasking.Task_Id; A_TID : Ada.Task_Identification.Task_Id; for A_TID'Address use S_TID'Address; pragma Import (Ada, A_TID); -- Task identifier used to climb up task tree until we reach the -- environment task. begin PTT.Node_Boot_Time := To_Duration (Clock - Time_0); PTT.Register_Thread_Factory (PTT.Thread_Factory_Access (The_Thread_Factory)); S_TID := System.Tasking.Self; while S_TID.Common.Parent /= null loop S_TID := S_TID.Common.Parent; end loop; The_Thread_Factory.Environment_Task := S_TID; pragma Debug (C, O ("Environment task: " & Ada.Task_Identification.Image (A_TID))); end Initialize; use PolyORB.Initialization; use PolyORB.Initialization.String_Lists; use PolyORB.Utils.Strings; begin Register_Module (Module_Info' (Name => +"tasking.profiles.full_tasking.threads", Conflicts => Empty, Depends => +"full_tasking.threads.priorities", Provides => +"tasking.threads", Implicit => False, Init => Initialize'Access, Shutdown => null)); end PolyORB.Tasking.Profiles.Full_Tasking.Threads; polyorb-2.8~20110207.orig/src/polyorb-references.adb0000644000175000017500000003235311750740340021454 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . R E F E R E N C E S -- -- -- -- B o d y -- -- -- -- Copyright (C) 2001-2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- Object references. with Ada.Tags; with PolyORB.Binding_Object_QoS; with PolyORB.Binding_Objects; with PolyORB.Log; with PolyORB.Types; package body PolyORB.References is use type PolyORB.Components.Component_Access; use PolyORB.Binding_Objects; use PolyORB.Log; use PolyORB.Smart_Pointers; use PolyORB.Utils.Strings; package L is new PolyORB.Log.Facility_Log ("polyorb.references"); procedure O (Message : String; Level : Log_Level := Debug) renames L.Output; function C (Level : Log_Level := Debug) return Boolean renames L.Enabled; function Reference_Equivalence (Left, Right : Ref'Class; Node_Only : Boolean) return Boolean; -- Returns true if we can determine that Left and Right are equivalent. -- If Node_Only is true, we only test that Left and Right are on the same -- node. -------------------------------- -- System location management -- -------------------------------- type Prefix_Info is record Prefix : Utils.Strings.String_Ptr; Func : String_To_Object_Func; end record; package Prefix_Info_Lists is new PolyORB.Utils.Chained_Lists (Prefix_Info); Prefixes : Prefix_Info_Lists.List; -------------- -- Register -- -------------- procedure Register_String_To_Object (Prefix : String; Func : String_To_Object_Func) is begin Prefix_Info_Lists.Append (Prefixes, Prefix_Info'(Prefix => new String'(Prefix), Func => Func)); pragma Debug (C, O ("register prefix: " & Prefix)); end Register_String_To_Object; ---------------------- -- Create_Reference -- ---------------------- procedure Create_Reference (Profiles : Profile_Array; Type_Id : String; R : out Ref) is use type Binding_Data.Profile_Access; begin if Profiles'Length = 0 then Set (R, null); else for J in Profiles'Range loop null; pragma Assert (Profiles (J) /= null); end loop; declare RIP : constant Entity_Ptr := new Reference_Info; TRIP : Reference_Info renames Reference_Info (RIP.all); begin TRIP.Type_Id := new String'(Type_Id); TRIP.Profiles := new Profile_Array'(Profiles); Set (R, RIP); end; end if; pragma Debug (C, O ("New " & Image (R))); end Create_Reference; -------------- -- Finalize -- -------------- procedure Finalize (RI : in out Reference_Info) is begin pragma Debug (C, O ("Finalize (Reference_Info): enter")); Free (RI.Type_Id); for J in RI.Profiles'Range loop pragma Debug (C, O ("Destroying profile of type " & Ada.Tags.External_Tag (RI.Profiles (J)'Tag))); Binding_Data.Destroy_Profile (RI.Profiles (J)); end loop; Free (RI.Profiles); Binding_Info_Lists.Deallocate (RI.Binding_Info); Annotations.Destroy (RI.Notepad); pragma Debug (C, O ("Finalize (Reference_Info): leave")); end Finalize; ---------------------- -- Get_Binding_Info -- ---------------------- procedure Get_Binding_Info (R : Ref'Class; QoS : PolyORB.QoS.QoS_Parameters; BOC : out Components.Component_Access; Pro : out Binding_Data.Profile_Access) is use Binding_Info_Lists; RI : constant Reference_Info_Access := Ref_Info_Of (R); Iter : Binding_Info_Lists.Iterator := First (RI.Binding_Info); BO : Binding_Object_Access; begin while not Last (Iter) loop BO := Binding_Object_Access (Entity_Of (Value (Iter).Binding_Object_Ref)); -- If the binding object has become invalid, forget about it if not Valid (BO) then pragma Debug (C, O ("Removing invalid binding object")); Remove (RI.Binding_Info, Iter); -- If existing BO QoS is compatible with requested QoS, reuse it elsif PolyORB.Binding_Object_QoS.Is_Compatible (BO, QoS) then BOC := Get_Component (Value (Iter).Binding_Object_Ref); Pro := Value (Iter).all.Binding_Profile; return; else Next (Iter); end if; end loop; BOC := null; Pro := null; end Get_Binding_Info; ----------- -- Image -- ----------- function Image (R : Ref) return String is use type PolyORB.Types.String; P : constant Profile_Array := Profiles_Of (R); Res : PolyORB.Types.String; begin if P'Length = 0 then return "Object reference: "; else Res := PolyORB.Types.To_PolyORB_String ("Object reference: ") & Type_Id_Of (R) & ASCII.LF; for J in P'Range loop Res := Res & PolyORB.Types.To_PolyORB_String (" " & Ada.Tags.External_Tag (P (J).all'Tag) & ASCII.LF & " " & Binding_Data.Image (P (J).all) & ASCII.LF); end loop; end if; return PolyORB.Types.To_Standard_String (Res); end Image; ------------------- -- Is_Equivalent -- ------------------- function Is_Equivalent (Left, Right : Ref'Class) return Boolean is Left_RI : constant Reference_Info_Access := Ref_Info_Of (Left); Right_RI : constant Reference_Info_Access := Ref_Info_Of (Right); begin -- First match Type_Ids if Left_RI.Type_Id = null or else Right_RI.Type_Id = null then return Left_RI.Type_Id = Right_RI.Type_Id; elsif Left_RI.Type_Id.all /= Right_RI.Type_Id.all then return False; end if; -- Fault Tolerance IOGR equivalence -- (not yet integrated) -- -- if Is_FT_IOGR (Left) and then Is_FT_IOGR (Right) then -- return PolyORB.Fault_Tolerance.IOGR.Is_Equivalent (Left, Right); -- end if; return Reference_Equivalence (Left, Right, Node_Only => False); end Is_Equivalent; --------------------------- -- Is_Exported_Reference -- --------------------------- function Is_Exported_Reference (The_Ref : Ref'Class) return Boolean is begin if not Is_Nil (The_Ref) then return Entity_Of (The_Ref).all in Reference_Info'Class; else return False; end if; end Is_Exported_Reference; ---------------- -- Notepad_Of -- ---------------- function Notepad_Of (R : Ref) return Annotations.Notepad_Access is begin return Ref_Info_Of (R).Notepad'Access; end Notepad_Of; ----------------- -- Profiles_Of -- ----------------- function Profiles_Of (R : Ref) return Profile_Array is RI : constant Reference_Info_Access := Ref_Info_Of (R); begin if RI /= null then return RI.Profiles.all; else declare Null_Profile_Array : Profile_Array (1 .. 0); begin return Null_Profile_Array; end; end if; end Profiles_Of; ---------- -- Read -- ---------- procedure Read (S : access Ada.Streams.Root_Stream_Type'Class; V : out Ref) is begin Read (The_Ref_Streamer, S, V); end Read; --------------------------- -- Reference_Equivalence -- --------------------------- function Reference_Equivalence (Left, Right : Ref'Class; Node_Only : Boolean) return Boolean is use PolyORB.Binding_Data; Left_RI : constant Reference_Info_Access := Ref_Info_Of (Left); Right_RI : constant Reference_Info_Access := Ref_Info_Of (Right); begin -- Two references are equivalent when they have a pair of profiles that -- designate the same node (reached though the same protocol) and have -- the same object key. for J in Left_RI.Profiles'Range loop for K in Right_RI.Profiles'Range loop if Same_Node (Left_RI.Profiles (J).all, Right_RI.Profiles (K).all) then if Node_Only or else Same_Object_Key (Left_RI.Profiles (J).all, Right_RI.Profiles (K).all) then return True; end if; end if; end loop; end loop; return False; end Reference_Equivalence; ----------------- -- Ref_Info_Of -- ----------------- function Ref_Info_Of (R : Ref'Class) return Reference_Info_Access is E : constant Entity_Ptr := Entity_Of (R); begin if E /= null then if E.all in Reference_Info'Class then return Reference_Info_Access (E); else pragma Debug (C, O ("Ref_Info_Of: entity is a " & Ada.Tags.External_Tag (E'Tag))); -- XXX does it make sense to have a non-child of -- Reference_Info stored into a PolyORB.ReferenceS.Ref ? null; end if; else pragma Debug (C, O ("Ref_Info_Of: nil ref.")); null; end if; return null; end Ref_Info_Of; --------------- -- Same_Node -- --------------- function Same_Node (Left, Right : Ref'Class) return Boolean is begin return Reference_Equivalence (Left, Right, Node_Only => True); end Same_Node; ------------------------ -- Share_Binding_Info -- ------------------------ procedure Share_Binding_Info (Dest : Ref'Class; Source : Ref'Class) is RD : constant Reference_Info_Access := Ref_Info_Of (Dest); RS : constant Reference_Info_Access := Ref_Info_Of (Source); begin RD.Binding_Info := Binding_Info_Lists.Duplicate (RS.Binding_Info); if RD.Type_Id'Length = 0 then Free (RD.Type_Id); RD.Type_Id := new String'(RS.Type_Id.all); end if; end Share_Binding_Info; ---------------------- -- String_To_Object -- ---------------------- procedure String_To_Object (Str : String; The_Ref : out Ref) is use Prefix_Info_Lists; It : Iterator := First (Prefixes); begin while not Last (It) loop declare Prefix : String renames Value (It).Prefix.all; begin if Utils.Has_Prefix (Str, Prefix) then Set (The_Ref, Entity_Of (Value (It).Func (Str))); return; end if; end; Next (It); end loop; raise Constraint_Error; end String_To_Object; ---------------- -- Type_Id_Of -- ---------------- function Type_Id_Of (R : Ref) return String is begin return Ref_Info_Of (R).Type_Id.all; -- XXX Perhaps some cases of R not designating -- a ref_info should be supported here? end Type_Id_Of; ----------------- -- Set_Type_Id -- ----------------- procedure Set_Type_Id (R : Ref; Type_Id : String) is begin if not Is_Null (R) then Ref_Info_Of (R).Type_Id := new String'(Type_Id); else pragma Debug (C, O ("Set_Type_Id: nil ref.")); null; end if; end Set_Type_Id; ----------- -- Write -- ----------- procedure Write (S : access Ada.Streams.Root_Stream_Type'Class; V : Ref) is begin Write (The_Ref_Streamer, S, V); end Write; end PolyORB.References; polyorb-2.8~20110207.orig/src/polyorb-services-naming-helper.ads0000644000175000017500000001002611750740340023714 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . S E R V I C E S . N A M I N G . H E L P E R -- -- -- -- S p e c -- -- -- -- Copyright (C) 2002-2007, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with PolyORB.Any; with PolyORB.References; package PolyORB.Services.Naming.Helper is pragma Elaborate_Body; -- Istring type TC_Istring : PolyORB.Any.TypeCode.Local_Ref; function From_Any (Item : PolyORB.Any.Any) return Istring; function To_Any (Item : Istring) return PolyORB.Any.Any; -- NameComponent type TC_NameComponent : PolyORB.Any.TypeCode.Local_Ref; function From_Any (Item : PolyORB.Any.Any) return NameComponent; function To_Any (Item : NameComponent) return PolyORB.Any.Any; -- Sequence of NameComponent type TC_SEQUENCE_NameComponent : PolyORB.Any.TypeCode.Local_Ref; function From_Any (Item : PolyORB.Any.Any) return SEQUENCE_NameComponent.Sequence; function To_Any (Item : SEQUENCE_NameComponent.Sequence) return PolyORB.Any.Any; -- Name type TC_Name : PolyORB.Any.TypeCode.Local_Ref; function From_Any (Item : PolyORB.Any.Any) return Name; function To_Any (Item : Name) return PolyORB.Any.Any; -- BindingType type TC_BindingType : PolyORB.Any.TypeCode.Local_Ref; function From_Any (Item : PolyORB.Any.Any) return BindingType; function To_Any (Item : BindingType) return PolyORB.Any.Any; -- Binding type TC_Binding : PolyORB.Any.TypeCode.Local_Ref; function From_Any (Item : PolyORB.Any.Any) return Binding; function To_Any (Item : Binding) return PolyORB.Any.Any; -- Sequence of Binding type TC_SEQUENCE_Binding : PolyORB.Any.TypeCode.Local_Ref; function From_Any (Item : PolyORB.Any.Any) return SEQUENCE_Binding.Sequence; function To_Any (Item : SEQUENCE_Binding.Sequence) return PolyORB.Any.Any; -- BindingList type TC_BindingList : PolyORB.Any.TypeCode.Local_Ref; function From_Any (Item : PolyORB.Any.Any) return BindingList; function To_Any (Item : BindingList) return PolyORB.Any.Any; -- ??? Naming::Object ??? TC_Object : PolyORB.Any.TypeCode.Local_Ref; function To_Any (Item : PolyORB.References.Ref) return PolyORB.Any.Any; end PolyORB.Services.Naming.Helper; polyorb-2.8~20110207.orig/src/polyorb-protocols-echo.adb0000644000175000017500000002365411750740340022277 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . P R O T O C O L S . E C H O -- -- -- -- B o d y -- -- -- -- Copyright (C) 2001-2009, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- A dummy protocol, just for testing. with Ada.Exceptions; with PolyORB.Any.NVList; with PolyORB.Binding_Data.Local; with PolyORB.Filters; with PolyORB.Filters.Iface; with PolyORB.Log; with PolyORB.Obj_Adapters; with PolyORB.Objects; with PolyORB.ORB; with PolyORB.ORB.Iface; with PolyORB.References; with PolyORB.Representations.Test; use PolyORB.Representations.Test; with PolyORB.Types; use PolyORB.Types; with PolyORB.Utils.Strings; use PolyORB.Utils.Strings; package body PolyORB.Protocols.Echo is use PolyORB.Components; use PolyORB.Filters.Iface; use PolyORB.Log; use PolyORB.ORB; use PolyORB.ORB.Iface; package L is new PolyORB.Log.Facility_Log ("polyorb.protocols.echo"); procedure O (Message : String; Level : Log_Level := Debug) renames L.Output; function C (Level : Log_Level := Debug) return Boolean renames L.Enabled; Rep : Rep_Test; procedure Create (Proto : access Echo_Protocol; Session : out Filter_Access) is begin pragma Warnings (Off); pragma Unreferenced (Proto); pragma Warnings (On); -- This should be factored in PolyORB.Protocols. Session := new Echo_Session; -- That is Echo-specific. Or is it? Echo_Session (Session.all).Buffer := new Buffers.Buffer_Type; Echo_Session (Session.all).Out_Buffer := new Buffers.Buffer_Type; end Create; procedure Invoke_Request (S : access Echo_Session; R : Request_Access; P : access Binding_Data.Profile_Type'Class) is begin pragma Warnings (Off); pragma Unreferenced (S); pragma Unreferenced (R); pragma Unreferenced (P); pragma Warnings (On); null; end Invoke_Request; procedure Abort_Request (S : access Echo_Session; R : Request_Access) is begin pragma Warnings (Off); pragma Unreferenced (S); pragma Unreferenced (R); pragma Warnings (On); null; end Abort_Request; procedure Send_Reply (S : access Echo_Session; R : Request_Access) is use Buffers; B : Buffer_Access renames S.Out_Buffer; begin Release_Contents (B.all); Marshall_String (Rep, B, "200 OK" & ASCII.CR & ASCII.LF); Marshall_String (Rep, B, "Request: " & Image (R.all) & ASCII.CR & ASCII.LF); Emit_No_Reply (Lower (S), Data_Out'(Out_Buf => B)); end Send_Reply; procedure Handle_Connect_Indication (S : access Echo_Session) is begin pragma Debug (C, O ("Received new connection to echo service...")); -- 1. Send greetings to client. -- Send_String ("Hello, please type data." & ASCII.LF); -- 2. Notify transport layer that more data is expected. Expect_Data (S, S.Buffer, 1024); -- Exact => False -- Note that there is no race condition here. One might -- expect the following unfortunate sequence of events: -- 10. Greetings sent to client -- 11. Client answers -- 20. Expect_Data -- (in 11: transport gets unexpected data). -- This does not actually happen because the TE is not -- being monitored while Send_Greetings and Expect_Data -- are done; it becomes monitored again /after/ the -- Connect_Indication has been processed. -- -- The same goes for the handling of a Data_Indication. end Handle_Connect_Indication; procedure Handle_Connect_Confirmation (S : access Echo_Session) is begin pragma Warnings (Off); pragma Unreferenced (S); pragma Warnings (On); null; -- No setup is necessary for newly-created client connections. end Handle_Connect_Confirmation; type String_Array is array (Integer range <>) of Utils.Strings.String_Ptr; function Split (S : String) return String_Array; function Split (S : String) return String_Array is Result : String_Array (1 .. S'Length); Last : Integer := Result'First - 1; Word_First : Integer := S'First; Word_Last : Integer; begin while Word_First <= S'Last loop Word_Last := Word_First - 1; Last := Last + 1; while Word_Last < S'Last and then S (Word_Last + 1) /= ' ' loop Word_Last := Word_Last + 1; end loop; Result (Last) := new String'(S (Word_First .. Word_Last)); Word_First := Word_Last + 1; while Word_First <= S'Last and then S (Word_First) = ' ' loop Word_First := Word_First + 1; end loop; end loop; return Result (Result'First .. Last); end Split; procedure Free (SA : in out String_Array); procedure Free (SA : in out String_Array) is begin for I in SA'Range loop Free (SA (I)); end loop; end Free; procedure Handle_Data_Indication (S : access Echo_Session; Data_Amount : Ada.Streams.Stream_Element_Count; Error : in out Errors.Error_Container) is use Binding_Data.Local; use Objects; use References; begin pragma Warnings (Off); pragma Unreferenced (Data_Amount, Error); pragma Warnings (On); pragma Debug (C, O ("Received data on echo service...")); pragma Debug (Buffers.Show (S.Buffer)); declare Argv : String_Array := Split (Unmarshall_String (Rep, S.Buffer)); Method : constant String := Argv (1).all; Oid : aliased Object_Id := Hex_String_To_Oid (Argv (2).all); Arg_String : constant String := Argv (3).all; Req : Request_Access := null; Args : Any.NVList.Ref; Result : Any.NamedValue; Target_Profile : constant Binding_Data.Profile_Access := new Local_Profile_Type; Target : References.Ref; ORB : constant ORB_Access := ORB_Access (S.Server); begin Buffers.Release_Contents (S.Buffer.all); -- Clear buffer begin pragma Debug (C, O ("Received request " & Method & " on object " & Image (Oid) & " with args " & Arg_String)); Args := Obj_Adapters.Get_Empty_Arg_List (Object_Adapter (ORB), Oid'Access, Method); Result := (Name => To_PolyORB_String ("Result"), Argument => Obj_Adapters.Get_Empty_Result (Object_Adapter (ORB), Oid'Access, Method), Arg_Modes => 0); Create_Local_Profile (Oid, Local_Profile_Type (Target_Profile.all)); Create_Reference (Profiles => (1 => Target_Profile), Type_Id => "", -- Unknown (not carried by this protocol) R => Target); Create_Request (Target => Target, Operation => Method, Arg_List => Args, Result => Result, Req => Req); -- This request is submitted to the ORB by internal activity, -- not by a transient task lent by the application: -- set Requesting_Task to null. Queue_Request_To_Handler (ORB, Queue_Request'(Request => Req, Requestor => Component_Access (S))); exception when E : others => O ("Got exception: " & Ada.Exceptions.Exception_Information (E)); end; Free (Argv); end; Expect_Data (S, S.Buffer, 1024); -- XXX Not exact amount. -- Prepare to receive next message. end Handle_Data_Indication; procedure Handle_Disconnect (S : access Echo_Session; Error : Errors.Error_Container) is pragma Unreferenced (Error); begin pragma Debug (C, O ("Received disconnect.")); -- Cleanup protocol Buffers.Release (S.Buffer); end Handle_Disconnect; procedure Handle_Flush (S : access Echo_Session) is begin raise Program_Error; end Handle_Flush; end PolyORB.Protocols.Echo; polyorb-2.8~20110207.orig/src/polyorb-poa_manager-basic_manager.adb0000644000175000017500000003013111750740340024345 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . P O A _ M A N A G E R . B A S I C _ M A N A G E R -- -- -- -- B o d y -- -- -- -- Copyright (C) 2001-2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with Ada.Unchecked_Deallocation; with PolyORB.Components; with PolyORB.Log; with PolyORB.ORB.Iface; with PolyORB.Setup; package body PolyORB.POA_Manager.Basic_Manager is use PolyORB.Errors; use PolyORB.Log; use PolyORB.Tasking.Mutexes; package L is new PolyORB.Log.Facility_Log ("polyorb.poa_manager.basic_manager"); procedure O (Message : Standard.String; Level : Log_Level := Debug) renames L.Output; function C (Level : Log_Level := Debug) return Boolean renames L.Enabled; procedure Do_Wait_For_Completion (Self : access Basic_POA_Manager); -- Wait for completion procedure Do_Etherealize_Objects (Self : access Basic_POA_Manager); -- Etherealize the objects of the associated POAs -- (in case a Servant Manager is used with a RETAIN policy) procedure Reemit_Requests (Self : access Basic_POA_Manager); -- Reemit requests stored by the Hold Servant attached to -- Self. Note: this function assumes Self.Lock is held. -------------- -- Activate -- -------------- procedure Activate (Self : access Basic_POA_Manager; Error : in out PolyORB.Errors.Error_Container) is use Requests_Queues; begin pragma Debug (C, O ("Activate POAManager: enter")); Enter (Self.Lock); pragma Debug (C, O ("Activate POAManager: locked, state is " & Self.Current_State'Img)); -- Test invocation validity if Self.Current_State = INACTIVE then -- If the POAManager state is INACTIVE, raise an exception Throw (Error, AdapterInactive_E, Null_Members'(Null_Member)); Leave (Self.Lock); return; end if; -- else set the POAManager state to ACTIVE Self.Current_State := ACTIVE; -- If we were holding requests, reemit them pragma Debug (C, O ("Activate POAManager: checking for held requests")); if Self.PM_Hold_Servant /= null and then not Is_Empty (Self.Held_Requests) then Reemit_Requests (Self); end if; Leave (Self.Lock); pragma Debug (C, O ("Activate POAManager: leave")); end Activate; ------------------- -- Hold_Requests -- ------------------- procedure Hold_Requests (Self : access Basic_POA_Manager; Wait_For_Completion : Boolean; Error : in out PolyORB.Errors.Error_Container) is begin pragma Debug (C, O ("Hold requests, Wait_For_Completion is " & Boolean'Image (Wait_For_Completion))); if Wait_For_Completion then Do_Wait_For_Completion (Self); end if; Enter (Self.Lock); -- Test invocation validity if Self.Current_State = INACTIVE then -- If the POAManager state is INACTIVE, raise an exception Throw (Error, AdapterInactive_E, Null_Members'(Null_Member)); else -- else set the POAManager state to HOLDING Self.Current_State := HOLDING; end if; Leave (Self.Lock); end Hold_Requests; ---------------------- -- Discard_Requests -- ---------------------- procedure Discard_Requests (Self : access Basic_POA_Manager; Wait_For_Completion : Boolean; Error : in out PolyORB.Errors.Error_Container) is begin pragma Debug (C, O ("Discard requests, Wait_For_Completion is " & Boolean'Image (Wait_For_Completion))); if Wait_For_Completion then Do_Wait_For_Completion (Self); end if; Enter (Self.Lock); -- Test invocation validity if Self.Current_State = INACTIVE then -- If the POAManager state is INACTIVE, raise an exception Throw (Error, AdapterInactive_E, Null_Members'(Null_Member)); else -- else set the POAManager state to DISCARDING Self.Current_State := DISCARDING; end if; Leave (Self.Lock); end Discard_Requests; ---------------- -- Deactivate -- ---------------- procedure Deactivate (Self : access Basic_POA_Manager; Etherealize_Objects : Boolean; Wait_For_Completion : Boolean) is begin pragma Debug (C, O ("Deactivate: Wait_For_Completion is " & Boolean'Image (Wait_For_Completion) & ", Etherealize_Objects is " & Boolean'Image (Etherealize_Objects))); Enter (Self.Lock); if Self.Current_State /= INACTIVE then Self.Current_State := INACTIVE; end if; Leave (Self.Lock); if Etherealize_Objects then Do_Etherealize_Objects (Self); end if; if Wait_For_Completion then Do_Wait_For_Completion (Self); end if; end Deactivate; --------------- -- Get_State -- --------------- function Get_State (Self : Basic_POA_Manager) return State is Result : State; begin Enter (Self.Lock); Result := Self.Current_State; Leave (Self.Lock); return Result; end Get_State; ------------ -- Create -- ------------ procedure Create (M : access Basic_POA_Manager) is use Requests_Queues; begin pragma Debug (C, O ("Create a new Basic_POA_Manager")); Create (M.Lock); pragma Assert (Is_Empty (M.Held_Requests)); M.Current_State := HOLDING; end Create; ------------------ -- Register_POA -- ------------------ procedure Register_POA (Self : access Basic_POA_Manager; OA : Obj_Adapter_Access) is use POA_Lists; begin pragma Debug (C, O ("Register a new POA")); Enter (Self.Lock); Append (Self.Managed_POAs, OA); Leave (Self.Lock); end Register_POA; ---------------- -- Remove_POA -- ---------------- procedure Remove_POA (Self : access Basic_POA_Manager; OA : Obj_Adapter_Access) is use POA_Lists; A_Child : Obj_Adapter_Access; It : Iterator := First (Self.Managed_POAs); begin pragma Debug (C, O ("Remove a POA: enter")); Enter (Self.Lock); while not Last (It) loop A_Child := Value (It).all; if A_Child = OA then Remove (Self.Managed_POAs, It); Leave (Self.Lock); pragma Debug (C, O ("Remove a POA: end")); return; end if; Next (It); end loop; Leave (Self.Lock); raise Program_Error; end Remove_POA; ---------------------- -- Get_Hold_Servant -- ---------------------- function Get_Hold_Servant (Self : access Basic_POA_Manager; OA : Obj_Adapter_Access) return Servants.Servant_Access is pragma Warnings (Off); pragma Unreferenced (OA); pragma Warnings (On); begin pragma Debug (C, O ("Get a Hold_Servant")); Enter (Self.Lock); if Self.PM_Hold_Servant = null then Self.PM_Hold_Servant := new Hold_Servant; Self.PM_Hold_Servant.PM := Basic_POA_Manager_Access (Self); end if; Leave (Self.Lock); return Servants.Servant_Access (Self.PM_Hold_Servant); end Get_Hold_Servant; ---------------------------- -- Do_Wait_For_Completion -- ---------------------------- procedure Do_Wait_For_Completion (Self : access Basic_POA_Manager) is pragma Warnings (Off); pragma Unreferenced (Self); pragma Warnings (On); begin -- XXX What's this thing about the threads ? Ignored for now. -- XXX Iterates through the POAs to wait for completion null; end Do_Wait_For_Completion; ---------------------------- -- Do_Etherealize_Objects -- ---------------------------- procedure Do_Etherealize_Objects (Self : access Basic_POA_Manager) is pragma Warnings (Off); pragma Unreferenced (Self); pragma Warnings (On); begin null; -- XXX To be implemented end Do_Etherealize_Objects; -------------- -- Finalize -- -------------- procedure Finalize (Self : in out Basic_POA_Manager) is use Requests_Queues; use POA_Lists; procedure Free is new Ada.Unchecked_Deallocation (Hold_Servant, Hold_Servant_Access); R : Request_Access; begin pragma Debug (C, O ("POAManager is no longer used, destroying it")); Destroy (Self.Lock); if Self.PM_Hold_Servant /= null then Free (Self.PM_Hold_Servant); end if; Deallocate (Self.Managed_POAs); while not Is_Empty (Self.Held_Requests) loop Extract_First (Self.Held_Requests, R); Destroy_Request (R); end loop; Deallocate (Self.Held_Requests); pragma Debug (C, O ("POAManager destroyed.")); end Finalize; ---------------------------------- -- Holding state implementation -- ---------------------------------- --------------------- -- Reemit_Requests -- --------------------- procedure Reemit_Requests (Self : access Basic_POA_Manager) is use PolyORB.Components; use PolyORB.ORB.Iface; use Requests_Queues; R : Request_Access; begin pragma Debug (C, O ("Number of requests to reemit:" & Integer'Image (Length (Self.Held_Requests)))); while not Is_Empty (Self.Held_Requests) loop Extract_First (Self.Held_Requests, R); Emit_No_Reply (Component_Access (PolyORB.Setup.The_ORB), Queue_Request' (Request => R, Requestor => R.Requesting_Component)); end loop; end Reemit_Requests; --------------------- -- Execute_Servant -- --------------------- function Execute_Servant (Obj : not null access Hold_Servant; Req : Requests.Request_Access) return Boolean is use Requests_Queues; S : constant Hold_Servant_Access := Hold_Servant_Access (Obj); begin pragma Debug (C, O ("Hold_Servant: Queuing request")); Enter (S.PM.Lock); Append (S.PM.Held_Requests, Req); Leave (S.PM.Lock); return False; end Execute_Servant; end PolyORB.POA_Manager.Basic_Manager; polyorb-2.8~20110207.orig/src/polyorb-call_back.ads0000644000175000017500000000715311750740340021247 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . C A L L _ B A C K -- -- -- -- S p e c -- -- -- -- Copyright (C) 2002-2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- Call back component. -- -- A Call back component act as a request 'bouncer'. It is associated to a -- call back function that will receive the Executed_Message message in -- place of the emitter, and will bounce this message to another destination -- using its handler. with PolyORB.Annotations; with PolyORB.Components; with PolyORB.Requests; package PolyORB.Call_Back is type Call_Back_Handler is new PolyORB.Components.Component with private; type CBH_Access is access all Call_Back_Handler'Class; type Handler is access procedure (Req : PolyORB.Requests.Request; CBH : access Call_Back_Handler); function Handle_Message (CB_Handler : not null access Call_Back_Handler; S : Components.Message'Class) return Components.Message'Class; procedure Attach_Request_To_CB (Req : access PolyORB.Requests.Request; CB_Handler : PolyORB.Call_Back.CBH_Access); -- Attach a specific request to call back component. procedure Attach_Handler_To_CB (CB_Handler : in out PolyORB.Call_Back.Call_Back_Handler; CB_Function : Handler); -- Attach a handler to call back component. function Notepad_Of (CB_Handler : access PolyORB.Call_Back.Call_Back_Handler) return PolyORB.Annotations.Notepad_Access; private type Call_Back_Handler is new PolyORB.Components.Component with record CB_Function : Handler; Notepad : aliased Annotations.Notepad; end record; pragma Inline (Attach_Request_To_CB); pragma Inline (Attach_Handler_To_CB); pragma Inline (Notepad_Of); end PolyORB.Call_Back; polyorb-2.8~20110207.orig/src/polyorb-services-naming-namingcontext.adb0000644000175000017500000000625311750740340025301 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- POLYORB.SERVICES.NAMING.NAMINGCONTEXT -- -- -- -- B o d y -- -- -- -- Copyright (C) 2002-2005 Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with PolyORB.Exceptions; package body PolyORB.Services.Naming.NamingContext is ------------------ -- Get_Members -- ------------------ procedure Get_Members (From : Ada.Exceptions.Exception_Occurrence; To : out NotFound_Members) is begin PolyORB.Exceptions.User_Get_Members (From, To); end Get_Members; procedure Get_Members (From : Ada.Exceptions.Exception_Occurrence; To : out CannotProceed_Members) is begin PolyORB.Exceptions.User_Get_Members (From, To); end Get_Members; procedure Get_Members (From : Ada.Exceptions.Exception_Occurrence; To : out InvalidName_Members) is begin PolyORB.Exceptions.User_Get_Members (From, To); end Get_Members; procedure Get_Members (From : Ada.Exceptions.Exception_Occurrence; To : out AlreadyBound_Members) is begin PolyORB.Exceptions.User_Get_Members (From, To); end Get_Members; procedure Get_Members (From : Ada.Exceptions.Exception_Occurrence; To : out NotEmpty_Members) is begin PolyORB.Exceptions.User_Get_Members (From, To); end Get_Members; end PolyORB.Services.Naming.NamingContext; polyorb-2.8~20110207.orig/src/polyorb-sequences-bounded-helper.adb0000644000175000017500000000632411750740340024220 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . S E Q U E N C E S . B O U N D E D . H E L P E R -- -- -- -- B o d y -- -- -- -- Copyright (C) 2003-2007, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- Any conversion subprograms for bounded sequences package body PolyORB.Sequences.Bounded.Helper is use PolyORB.Any; ------------------ -- Check_Length -- ------------------ function Check_Length (Length : Natural) return Sequence is begin if Length > Max then raise Constraint_Error; end if; declare Seq : Sequence; begin Seq.Length := Length; return Seq; end; end Check_Length; -------------- -- From_Any -- -------------- function From_Any (Item : Any.Any) return Sequence renames Bounded_Helper.From_Any; ---------------- -- Initialize -- ---------------- procedure Initialize (Element_TC, Sequence_TC : PolyORB.Any.TypeCode.Local_Ref) is begin Bounded_Helper.Initialize (Element_TC => Element_TC, Sequence_TC => Sequence_TC); end Initialize; ------------ -- To_Any -- ------------ function To_Any (Item : Sequence) return Any.Any renames Bounded_Helper.To_Any; ---------- -- Wrap -- ---------- function Wrap (X : access Sequence) return Any.Content'Class renames Bounded_Helper.Wrap; end PolyORB.Sequences.Bounded.Helper; polyorb-2.8~20110207.orig/src/polyorb-poa_policies-servant_retention_policy.ads0000644000175000017500000001011411750740340027137 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- POLYORB.POA_POLICIES.SERVANT_RETENTION_POLICY -- -- -- -- S p e c -- -- -- -- Copyright (C) 2001-2005 Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with PolyORB.Errors; with PolyORB.POA_Types; with PolyORB.Servants; package PolyORB.POA_Policies.Servant_Retention_Policy is use PolyORB.POA_Types; type ServantRetentionPolicy is abstract new Policy with null record; type ServantRetentionPolicy_Access is access all ServantRetentionPolicy'Class; procedure Retain_Servant_Association (Self : ServantRetentionPolicy; OA : PolyORB.POA_Types.Obj_Adapter_Access; P_Servant : Servants.Servant_Access; U_Oid : Unmarshalled_Oid; Error : in out PolyORB.Errors.Error_Container) is abstract; procedure Forget_Servant_Association (Self : ServantRetentionPolicy; OA : PolyORB.POA_Types.Obj_Adapter_Access; Oid : Unmarshalled_Oid; Error : in out PolyORB.Errors.Error_Container) is abstract; -- Remove a previously-retained servant/oid association. function Retained_Servant_To_Id (Self : ServantRetentionPolicy; OA : PolyORB.POA_Types.Obj_Adapter_Access; P_Servant : Servants.Servant_Access) return Object_Id_Access is abstract; -- Case RETAIN: -- Look up the active object map for an oid associated with -- P_Servant. -- Case NON_RETAIN: -- Returns null procedure Retained_Id_To_Servant (Self : ServantRetentionPolicy; OA : PolyORB.POA_Types.Obj_Adapter_Access; U_Oid : Unmarshalled_Oid; Servant : out Servants.Servant_Access; Error : in out PolyORB.Errors.Error_Container) is abstract; -- Case RETAIN: -- Asks the Id_Assignment_Policy to look for the given Object_Id. -- If found, returns the associated servant. Otherwisem returns null. -- Case NON_RETAIN: -- Raises WrongPolicy. procedure Ensure_Servant_Manager_Type (Self : ServantRetentionPolicy; Manager : ServantManager'Class; Error : in out PolyORB.Errors.Error_Container) is abstract; end PolyORB.POA_Policies.Servant_Retention_Policy; polyorb-2.8~20110207.orig/src/polyorb-utils-tcp_access_points.adb0000644000175000017500000001023611750740340024170 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . U T I L S . T C P _ A C C E S S _ P O I N T S -- -- -- -- B o d y -- -- -- -- Copyright (C) 2003-2009, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- Utility routines to set up TCP listening sockets with Ada.Exceptions; with PolyORB.Components; with PolyORB.Log; with PolyORB.Setup; with PolyORB.Transport.Connected.Sockets; package body PolyORB.Utils.TCP_Access_Points is use PolyORB.Log; use PolyORB.Transport.Connected.Sockets; package L is new PolyORB.Log.Facility_Log ("polyorb.utils.tcp_access_points"); procedure O (Message : String; Level : Log_Level := Debug) renames L.Output; -- function C (Level : Log_Level := Debug) return Boolean -- renames L.Enabled; ----------------------- -- Initialize_Socket -- ----------------------- procedure Initialize_Socket (API : in out Access_Point_Info; Address : Sockets.Inet_Addr_Type := Any_Inet_Addr; Port_Hint : Port_Interval) is begin Create_Socket (API.Socket); API.Address := Sock_Addr_Type'(Addr => Address, Port => Port_Hint.Lo, Family => Family_Inet); -- Allow reuse of local addresses Set_Socket_Option (API.Socket, Socket_Level, (Reuse_Address, True)); if API.SAP = null then API.SAP := new Socket_Access_Point; end if; loop begin Create (Socket_Access_Point (API.SAP.all), API.Socket, API.Address); exit; exception when E : Sockets.Socket_Error => -- If a specific port range was given, try next port in range if API.Address.Port /= Any_Port and then API.Address.Port < Port_Hint.Hi then API.Address.Port := API.Address.Port + 1; else O ("bind failed: " & Ada.Exceptions.Exception_Message (E), Notice); raise; end if; end; end loop; -- Create profile factory if API.PF /= null then Create_Factory (API.PF.all, API.SAP, Components.Component_Access (Setup.The_ORB)); end if; end Initialize_Socket; end PolyORB.Utils.TCP_Access_Points; polyorb-2.8~20110207.orig/src/polyorb-log.adb0000644000175000017500000001657611750740340020125 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . L O G -- -- -- -- B o d y -- -- -- -- Copyright (C) 2001-2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with Ada.Unchecked_Deallocation; with PolyORB.Initialization; with PolyORB.Utils.Chained_Lists; with PolyORB.Utils.Strings; package body PolyORB.Log is use PolyORB.Utils.Strings; type Log_Level_Ptr is access all Log_Level; procedure Output (Facility_Level : Log_Level_Ptr; Facility : String; Message : String; Level : Log_Level); -- Common code shared by all instances of Facility_Log: -- * if Facility_Level is Unknown, look up log level for Facility, -- and cache it in Facility_Level if now known; -- * if still unknown, buffer message for further processing; -- * else output Message if Level >= Facility_Level. ------------------- -- Get_Log_Level -- ------------------- function Get_Log_Level (Facility : String) return Log_Level; -- Returns the user-requested log level for facility Flag. function Get_Log_Level (Facility : String) return Log_Level is use type Initialization.Configuration_Hook; Level : Log_Level; begin if Initialization.Get_Conf_Hook /= null then declare Level_Name : constant String := Initialization.Get_Conf_Hook (Section => Log_Section, Key => Facility, Default => Log_Level'Image (Default_Log_Level)); begin Level := Log_Level'Value (Level_Name); if Level = Unknown then Level := Default_Log_Level; end if; exception when others => Level := Default_Log_Level; end; return Level; else return Unknown; end if; end Get_Log_Level; ------------------------------- -- Generic body Facility_Log -- ------------------------------- package body Facility_Log is Facility_Level : aliased Log_Level := Unknown; ------------- -- Enabled -- ------------- function Enabled (Level : Log_Level := Debug) return Boolean is begin return Facility_Level = Unknown or else Level >= Facility_Level; end Enabled; ------------ -- Output -- ------------ procedure Output (Message : String; Level : Log_Level := Debug) is begin -- Unchecked_Access needed here because the lifetime of -- Facility_Level is that of the Facility_Log instance, and the -- compiler has no means of knowing that it is not less than the -- lifetime of PolyORB.Log. Log.Output (Facility_Level'Unchecked_Access, Facility, Message, Level); end Output; end Facility_Log; -------------------------------- -- Package body for Internals -- -------------------------------- package body Internals is -------------- -- Put_Line -- -------------- procedure Put_Line (S : String) is begin if Log_Hook /= null then Log_Hook.all (S); end if; end Put_Line; end Internals; type Log_Request is record Facility_Level : Log_Level_Ptr; Facility : String_Ptr; Message : String_Ptr; Level : Log_Level; end record; -- During initialization (before the configuration and logging modules -- are initialized), messages are captured in a buffer. Once initialization -- has been completed, the buffer is flushed. package Request_Lists is new PolyORB.Utils.Chained_Lists (Log_Request); type Request_List_Access is access Request_Lists.List; procedure Free is new Ada.Unchecked_Deallocation (Request_Lists.List, Request_List_Access); Buffer : Request_List_Access; Buffer_Enable : Boolean := True; -- Buffering is disabled as soon as Initialize is called ---------------- -- Initialize -- ---------------- procedure Initialize is use Request_Lists; It : Request_Lists.Iterator; begin -- Get default log level from configuration Default_Log_Level := Get_Log_Level ("default"); -- No more buffering after this point Buffer_Enable := False; if Buffer = null then return; end if; It := First (Buffer.all); while not Last (It) loop declare R : Log_Request renames Value (It).all; begin Output (R.Facility_Level, R.Facility.all, R.Message.all, R.Level); Free (R.Facility); Free (R.Message); end; Next (It); end loop; Deallocate (Buffer.all); Free (Buffer); end Initialize; ------------ -- Output -- ------------ procedure Output (Facility_Level : Log_Level_Ptr; Facility : String; Message : String; Level : Log_Level) is begin if Facility_Level.all = Unknown then Facility_Level.all := Get_Log_Level (Facility); end if; if Buffer_Enable then if Buffer = null then Buffer := new Request_Lists.List; end if; Request_Lists.Append (Buffer.all, Log_Request'(Facility_Level => Facility_Level, Facility => +Facility, Message => +Message, Level => Level)); elsif Level >= Facility_Level.all then Internals.Put_Line (Facility & ": " & Message); end if; end Output; end PolyORB.Log; polyorb-2.8~20110207.orig/src/polyorb-orb_controller-workers.ads0000644000175000017500000000640411750740340024071 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . O R B _ C O N T R O L L E R . W O R K E R S -- -- -- -- S p e c -- -- -- -- Copyright (C) 2004-2008, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- Workers ORB Controller for PolyORB ORB main loop. -- It is an all-purpose ORB Controller implementation, it supports: -- multi-tasking and mono-tasking ORB. package PolyORB.ORB_Controller.Workers is type ORB_Controller_Workers is new ORB_Controller with private; type ORB_Controller_Workers_Access is access all ORB_Controller_Workers'Class; procedure Notify_Event (O : access ORB_Controller_Workers; E : Event); procedure Schedule_Task (O : access ORB_Controller_Workers; TI : PTI.Task_Info_Access); procedure Disable_Polling (O : access ORB_Controller_Workers; M : PAE.Asynch_Ev_Monitor_Access); procedure Enable_Polling (O : access ORB_Controller_Workers; M : PAE.Asynch_Ev_Monitor_Access); type ORB_Controller_Workers_Factory is new ORB_Controller_Factory with private; function Create (OCF : ORB_Controller_Workers_Factory) return ORB_Controller_Access; private type ORB_Controller_Workers is new ORB_Controller with null record; type ORB_Controller_Workers_Factory is new ORB_Controller_Factory with null record; OCF : constant ORB_Controller_Factory_Access := new ORB_Controller_Workers_Factory; end PolyORB.ORB_Controller.Workers; polyorb-2.8~20110207.orig/tools/0000755000175000017500000000000011750740340015542 5ustar xavierxavierpolyorb-2.8~20110207.orig/tools/README0000644000175000017500000000066111750740340016425 0ustar xavierxavierREADME for PolyORB Tools ------------------------ $Id: //droopi/main/tools/README#2 $ PolyORB provides some helper tools po_catref : output information held in a stringified reference, e.g. CORBA IOR, corbaloc or URI po_dumpir : output information held in a CORBA Interface Repository instance. po_names : generic naming server, compatible with CORBA COS Naming API. To be used when no dependences on CORBA is required. polyorb-2.8~20110207.orig/tools/po_names/0000755000175000017500000000000011750740340017343 5ustar xavierxavierpolyorb-2.8~20110207.orig/tools/po_names/po_names.adb0000644000175000017500000000640711750740340021623 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O _ N A M E S -- -- -- -- B o d y -- -- -- -- Copyright (C) 2002-2005 Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- Naming server. -- Provides an interface similar to CORBA COS Naming without dependencies -- on the CORBA application personality. with Ada.Text_IO; with PolyORB.Errors; with PolyORB.Initialization; with PolyORB.Minimal_Servant.Tools; with PolyORB.References; with PolyORB.References.IOR; with PolyORB.Types; with PolyORB.Setup.No_Tasking_Server; pragma Warnings (Off, PolyORB.Setup.No_Tasking_Server); with PolyORB.Services.Naming.NamingContext.Servant; procedure PO_Names is use PolyORB.Errors; use PolyORB.Minimal_Servant.Tools; use PolyORB.Types; package NC renames PolyORB.Services.Naming.NamingContext.Servant; NC_Ref : PolyORB.References.Ref; Root_NC : NC.Object_Ptr; Error : Error_Container; begin PolyORB.Initialization.Initialize_World; -- Initialize the Root Naming Context Root_NC := NC.Create; Initiate_Servant (Root_NC, To_PolyORB_String ("NAMING"), NC_Ref, Error); if Found (Error) then raise Program_Error; end if; -- Output its reference Ada.Text_IO.Put_Line ("POLYORB_CORBA_NAME_SERVICE=" & PolyORB.References.IOR.Object_To_String (NC_Ref)); -- Run node as a stand alone server Run_Server; end PO_Names; polyorb-2.8~20110207.orig/tools/po_catref/0000755000175000017500000000000011750740340017504 5ustar xavierxavierpolyorb-2.8~20110207.orig/tools/po_catref/polyorb-binding_data-giop-diop-print.ads0000644000175000017500000000423411750740340027306 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- POLYORB.BINDING_DATA.GIOP.DIOP.PRINT -- -- -- -- S p e c -- -- -- -- Copyright (C) 2004 Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by ACT Europe. -- -- (email: sales@act-europe.fr) -- -- -- ------------------------------------------------------------------------------ package PolyORB.Binding_Data.GIOP.DIOP.Print is procedure Print_DIOP_Profile (Prof : Profile_Access); end PolyORB.Binding_Data.GIOP.DIOP.Print; polyorb-2.8~20110207.orig/tools/po_catref/polyorb-binding_data-giop-iiop-print.adb0000644000175000017500000001312411750740340027270 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- POLYORB.BINDING_DATA.GIOP.IIOP.PRINT -- -- -- -- B o d y -- -- -- -- Copyright (C) 2004-2008, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with Common; with Output; with PolyORB.Binding_Data.Print; with PolyORB.Initialization; with PolyORB.GIOP_P.Tagged_Components.Print; with PolyORB.GIOP_P.Transport_Mechanisms.IIOP; with PolyORB.GIOP_P.Tagged_Components.SSL_Sec_Trans.Print; with PolyORB.Sockets; with PolyORB.Types; use PolyORB.Types; with PolyORB.Utils.Sockets; with PolyORB.Utils.Strings; package body PolyORB.Binding_Data.GIOP.IIOP.Print is use PolyORB.GIOP_P.Tagged_Components; use PolyORB.GIOP_P.Tagged_Components.SSL_Sec_Trans; use PolyORB.GIOP_P.Tagged_Components.SSL_Sec_Trans.Print; use PolyORB.GIOP_P.Transport_Mechanisms.IIOP; use PolyORB.Sockets; function Get_Primary_IIOP_Address (Prof : IIOP_Profile_Type) return Utils.Sockets.Socket_Name; ------------------------------ -- Get_Primary_IIOP_Address -- ------------------------------ function Get_Primary_IIOP_Address (Prof : IIOP_Profile_Type) return Utils.Sockets.Socket_Name is begin return Primary_Address_Of (IIOP_Transport_Mechanism (Get_Primary_Transport_Mechanism (Prof).all)); end Get_Primary_IIOP_Address; ------------------------ -- Print_IIOP_Profile -- ------------------------ procedure Print_IIOP_Profile (Prof : Profile_Access) is use Common; use Output; use PolyORB.Utils; use PolyORB.GIOP_P.Tagged_Components.Print; IIOP_Prof : IIOP_Profile_Type renames IIOP_Profile_Type (Prof.all); SSL_TC : constant Tagged_Component_Access := Get_Component (IIOP_Prof, Tag_SSL_Sec_Trans); begin Inc_Indent; if SSL_TC = null then Put_Line ("IIOP Version", Trimmed_Image (Unsigned_Long_Long (IIOP_Prof.Version_Major)) & "." & Trimmed_Image (Unsigned_Long_Long (IIOP_Prof.Version_Minor))); Output_Address_Information (Get_Primary_IIOP_Address (IIOP_Prof)); else Put_Line ("IIOP/SSLIOP Version", Trimmed_Image (Unsigned_Long_Long (IIOP_Prof.Version_Major)) & "." & Trimmed_Image (Unsigned_Long_Long (IIOP_Prof.Version_Minor))); if Get_Primary_IIOP_Address (IIOP_Prof).Port /= 0 then Put_Line ("Unprotected invocations", ""); Output_Address_Information (Get_Primary_IIOP_Address (IIOP_Prof)); else Put_Line ("Unprotected invocations", "Not Supported"); end if; Put_Line ("Protected invocations", ""); Output_TC (TC_SSL_Sec_Trans (SSL_TC.all), Get_Primary_IIOP_Address (IIOP_Prof)); end if; Output_Object_Information (IIOP_Prof.Object_Id.all); Output_Tagged_Components (IIOP_Prof.Components); Dec_Indent; end Print_IIOP_Profile; ---------------- -- Initialize -- ---------------- procedure Initialize; procedure Initialize is begin PolyORB.Binding_Data.Print.Register (Tag_Internet_IOP, Print_IIOP_Profile'Access); end Initialize; use PolyORB.Initialization; use PolyORB.Initialization.String_Lists; use PolyORB.Utils.Strings; begin Register_Module (Module_Info' (Name => +"polyorb.binding_data.iiop.print", Conflicts => PolyORB.Initialization.String_Lists.Empty, Depends => PolyORB.Initialization.String_Lists.Empty, Provides => PolyORB.Initialization.String_Lists.Empty, Implicit => False, Init => Initialize'Access, Shutdown => null)); end PolyORB.Binding_Data.GIOP.IIOP.Print; polyorb-2.8~20110207.orig/tools/po_catref/output.adb0000644000175000017500000000622411750740340021520 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- O U T P U T -- -- -- -- B o d y -- -- -- -- Copyright (C) 3-2004 Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by ACT Europe. -- -- (email: sales@act-europe.fr) -- -- -- ------------------------------------------------------------------------------ with Ada.Text_IO; with Ada.Strings.Unbounded; package body Output is use Ada.Text_IO; use Ada.Strings.Unbounded; Indent_Size : constant Natural := 3; Indent_Level : Natural := 0; Text : Unbounded_String; ---------------- -- Inc_Indent -- ---------------- procedure Inc_Indent is begin Indent_Level := Indent_Level + 1; end Inc_Indent; ---------------- -- Dec_Indent -- ---------------- procedure Dec_Indent is begin Indent_Level := Indent_Level - 1; end Dec_Indent; -------------- -- Put_Line -- -------------- procedure Put_Line (Tag_C : String; Information : String) is Indent_String : constant String (1 .. Indent_Size * Indent_Level) := (others => ' '); begin Append (Text, Indent_String); Append (Text, Tag_C & ": " & Information & ASCII.LF); end Put_Line; -------------- -- New_Line -- -------------- procedure New_Line is begin Append (Text, ASCII.LF); end New_Line; ----------- -- Flush -- ----------- procedure Flush is begin Ada.Text_IO.Put (To_String (Text)); end Flush; end Output; polyorb-2.8~20110207.orig/tools/po_catref/polyorb-binding_data-srp-print.ads0000644000175000017500000000421711750740340026224 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . B I N D I N G _ D A T A . S R P . P R I N T -- -- -- -- S p e c -- -- -- -- Copyright (C) 2004 Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by ACT Europe. -- -- (email: sales@act-europe.fr) -- -- -- ------------------------------------------------------------------------------ package PolyORB.Binding_Data.SRP.Print is procedure Print_SRP_Profile (Prof : Profile_Access); end PolyORB.Binding_Data.SRP.Print; polyorb-2.8~20110207.orig/tools/po_catref/polyorb-giop_p-tagged_components-print.ads0000644000175000017500000000432211750740340027767 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- POLYORB.GIOP_P.TAGGED_COMPONENTS.PRINT -- -- -- -- S p e c -- -- -- -- Copyright (C) 2004 Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by ACT Europe. -- -- (email: sales@act-europe.fr) -- -- -- ------------------------------------------------------------------------------ package PolyORB.GIOP_P.Tagged_Components.Print is procedure Output_Tagged_Components (TCs : PolyORB.GIOP_P.Tagged_Components.Tagged_Component_List); end PolyORB.GIOP_P.Tagged_Components.Print; polyorb-2.8~20110207.orig/tools/po_catref/polyorb-binding_data-print.ads0000644000175000017500000000452411750740340025423 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . B I N D I N G _ D A T A . P R I N T -- -- -- -- S p e c -- -- -- -- Copyright (C) 2004-2008, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ package PolyORB.Binding_Data.Print is type Print_Procedure is access procedure (Profile : PolyORB.Binding_Data.Profile_Access); procedure Register (Profile : PolyORB.Binding_Data.Profile_Tag; Print : Print_Procedure); procedure Print_Profile (Profile : Profile_Access); end PolyORB.Binding_Data.Print; polyorb-2.8~20110207.orig/tools/po_catref/common.ads0000644000175000017500000000443211750740340021470 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- C O M M O N -- -- -- -- S p e c -- -- -- -- Copyright (C) 2004-2008, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- Common output routines with PolyORB.Objects; with PolyORB.Utils.Sockets; package Common is procedure Output_Address_Information (Addr : PolyORB.Utils.Sockets.Socket_Name); procedure Output_Object_Information (Obj : PolyORB.Objects.Object_Id); end Common; ././@LongLink0000000000000000000000000000015400000000000011565 Lustar rootrootpolyorb-2.8~20110207.orig/tools/po_catref/polyorb-giop_p-tagged_components-alternate_iiop_address-print.adspolyorb-2.8~20110207.orig/tools/po_catref/polyorb-giop_p-tagged_components-alternate_iiop_address-pr0000644000175000017500000000431611750740340033213 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- POLYORB.GIOP_P.TAGGED_COMPONENTS.ALTERNATE_IIOP_ADDRESS.PRINT -- -- -- -- S p e c -- -- -- -- Copyright (C) 2005 Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ package PolyORB.GIOP_P.Tagged_Components.Alternate_IIOP_Address.Print is procedure Output_TC (TC : TC_Alternate_IIOP_Address); end PolyORB.GIOP_P.Tagged_Components.Alternate_IIOP_Address.Print; polyorb-2.8~20110207.orig/tools/po_catref/polyorb-giop_p-tagged_components-ssl_sec_trans-print.adb0000644000175000017500000001411411750740340032606 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- POLYORB.GIOP_P.TAGGED_COMPONENTS.SSL_SEC_TRANS.PRINT -- -- -- -- B o d y -- -- -- -- Copyright (C) 2005-2008, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with Ada.Strings.Unbounded; with Common; with Output; package body PolyORB.GIOP_P.Tagged_Components.SSL_Sec_Trans.Print is use Ada.Strings.Unbounded; use Common; use Output; function Image (Options : Association_Options) return String; function Image (Options : Association_Options) return String is Result : Unbounded_String := To_Unbounded_String (Association_Options'Image (Options)); begin if Is_Set (No_Protection, Options) then Append (Result, " NoProtection"); end if; if Is_Set (Integrity, Options) then Append (Result, " Integrity"); end if; if Is_Set (Confidentiality, Options) then Append (Result, " Confidentiality"); end if; if Is_Set (Detect_Replay, Options) then Append (Result, " DetectReplay"); end if; if Is_Set (Detect_Misordering, Options) then Append (Result, " DetectMisordering"); end if; if Is_Set (Establish_Trust_In_Target, Options) then Append (Result, " EstablishTrustInTarget"); end if; if Is_Set (Establish_Trust_In_Client, Options) then Append (Result, " EstablishTrustInClient"); end if; if Is_Set (No_Delegation, Options) then Append (Result, " NoDelegation"); end if; if Is_Set (Simple_Delegation, Options) then Append (Result, " SimpleDelegation"); end if; if Is_Set (Composite_Delegation, Options) then Append (Result, " CompositeDelegation"); end if; if Is_Set (Identity_Assertion, Options) then Append (Result, " IdentityAssertion"); end if; if Is_Set (Delegation_By_Client, Options) then Append (Result, " DelegationByClient"); end if; return To_String (Result); end Image; --------------- -- Output_TC -- --------------- procedure Output_TC (TC : TC_SSL_Sec_Trans; Primary_Address : Utils.Sockets.Socket_Name) is procedure Output_Support_State (Option : Association_Options; Name : String); procedure Output_Support_State (Option : Association_Options; Name : String) is begin if not Is_Set (Option, TC.Target_Supports) then Put_Line (Name, "Not Supported"); elsif not Is_Set (Option, TC.Target_Requires) then Put_Line (Name, "Supported"); else Put_Line (Name, "Required"); end if; end Output_Support_State; Aux : Utils.Sockets.Socket_Name := Primary_Address; begin Inc_Indent; Aux.Port := TC.Port; Output_Address_Information (Aux); Put_Line ("Target Supports", Image (TC.Target_Supports)); Put_Line ("Target Requires", Image (TC.Target_Requires)); Inc_Indent; Put_Line ("Target Summary", ""); Inc_Indent; Output_Support_State (No_Protection, "No Protection "); Output_Support_State (Integrity, "Integrity "); Output_Support_State (Confidentiality, "Confidentiality "); Output_Support_State (Detect_Replay, "Detect Replay "); Output_Support_State (Detect_Misordering, "Detect Misordering "); Output_Support_State (Establish_Trust_In_Target, "Establish Trust In Target"); Output_Support_State (Establish_Trust_In_Client, "Establish Trust In Client"); Output_Support_State (No_Delegation, "No Delegation "); Output_Support_State (Simple_Delegation, "Simple Delegation "); Output_Support_State (Composite_Delegation, "Composite Delegation "); Output_Support_State (Identity_Assertion, "Identity Assertion "); Output_Support_State (Delegation_By_Client, "Delegation By Client "); Dec_Indent; Dec_Indent; Dec_Indent; end Output_TC; end PolyORB.GIOP_P.Tagged_Components.SSL_Sec_Trans.Print; polyorb-2.8~20110207.orig/tools/po_catref/polyorb-giop_p-tagged_components-ssl_sec_trans-print.ads0000644000175000017500000000442411750740340032632 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- POLYORB.GIOP_P.TAGGED_COMPONENTS.SSL_SEC_TRANS.PRINT -- -- -- -- S p e c -- -- -- -- Copyright (C) 2005-2008, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with PolyORB.Utils.Sockets; package PolyORB.GIOP_P.Tagged_Components.SSL_Sec_Trans.Print is procedure Output_TC (TC : TC_SSL_Sec_Trans; Primary_Address : Utils.Sockets.Socket_Name); end PolyORB.GIOP_P.Tagged_Components.SSL_Sec_Trans.Print; polyorb-2.8~20110207.orig/tools/po_catref/po_catref_setup.adb.in0000644000175000017500000000431611750740340023747 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O _ C A T R E F _ S E T U P -- -- -- -- B o d y -- -- -- -- Copyright (C) 2004-2007, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- Personalities setup pragma Style_Checks ("M2048"); -- Configure substitutions may yield long lines -- @configure_input@ @PO_CATREF_WITHS@ package body PO_CatRef_Setup is end PO_CatRef_Setup; polyorb-2.8~20110207.orig/tools/po_catref/polyorb-giop_p-tagged_components-code_sets-print.adb0000644000175000017500000001134211750740340031714 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- POLYORB.GIOP_P.TAGGED_COMPONENTS.CODE_SETS.PRINT -- -- -- -- B o d y -- -- -- -- Copyright (C) 2004-2008, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with Ada.Text_IO; with Output; with PolyORB.GIOP_P.Code_Sets; with PolyORB.GIOP_P.Code_Sets.Description_Data; package body PolyORB.GIOP_P.Tagged_Components.Code_Sets.Print is use Output; use PolyORB.GIOP_P.Code_Sets; use PolyORB.GIOP_P.Code_Sets.Code_Set_Id_Lists; function C_Hex_Image (Value : Code_Set_Id) return String; -- Return 16-based C-style image of Code_Set_Id value. procedure Output (List : Code_Set_Id_List; Data : Character); function Description (Code_Set : Code_Set_Id) return String; -- Return code set description. ----------------- -- C_Hex_Image -- ----------------- function C_Hex_Image (Value : Code_Set_Id) return String is package Code_Set_Id_IO is new Ada.Text_IO.Modular_IO (Code_Set_Id); use Code_Set_Id_IO; Buf : String (1 .. 13); Aux : Character; begin Put (Buf, Value, 16); for J in Buf'Range loop Aux := Buf (J); Buf (J) := '0'; exit when Aux = '#'; end loop; return "0x" & Buf (5 .. 12); end C_Hex_Image; ----------------- -- Description -- ----------------- function Description (Code_Set : Code_Set_Id) return String is package PGSD renames PolyORB.GIOP_P.Code_Sets.Description_Data; begin for J in PGSD.Info'Range loop if PGSD.Info (J).Code_Set = Code_Set then return PGSD.Description (PGSD.Info (J).First .. PGSD.Info (J).Last); end if; end loop; return "Unknown code set"; end Description; ------------ -- Output -- ------------ procedure Output (List : Code_Set_Id_List; Data : Character) is Iter : Code_Set_Id_Lists.Iterator; begin Inc_Indent; Iter := First (List); while not Last (Iter) loop declare Code_Set : constant Code_Set_Id := Value (Iter).all; begin Put_Line ("SCCS-" & Data, C_Hex_Image (Code_Set) & "; " & Description (Code_Set)); end; Next (Iter); end loop; Dec_Indent; end Output; --------------- -- Output_TC -- --------------- procedure Output_TC (TC : TC_Code_Sets) is begin Inc_Indent; Put_Line ("SNCS-C", C_Hex_Image (TC.For_Char_Data.Native_Code_Set) & "; " & Description (TC.For_Char_Data.Native_Code_Set)); Output (TC.For_Char_Data.Conversion_Code_Sets, 'C'); Put_Line ("SNCS-W", C_Hex_Image (TC.For_Wchar_Data.Native_Code_Set) & "; " & Description (TC.For_Wchar_Data.Native_Code_Set)); Output (TC.For_Wchar_Data.Conversion_Code_Sets, 'W'); Dec_Indent; end Output_TC; end PolyORB.GIOP_P.Tagged_Components.Code_Sets.Print; polyorb-2.8~20110207.orig/tools/po_catref/po_catref_setup.ads0000644000175000017500000000412311750740340023357 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O _ C A T R E F _ S E T U P -- -- -- -- S p e c -- -- -- -- Copyright (C) 2004 Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by ACT Europe. -- -- (email: sales@act-europe.fr) -- -- -- ------------------------------------------------------------------------------ package PO_CatRef_Setup is pragma Elaborate_Body; end PO_CatRef_Setup; polyorb-2.8~20110207.orig/tools/po_catref/po_catref.adb0000644000175000017500000000736711750740340022133 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O _ C A T R E F -- -- -- -- B o d y -- -- -- -- Copyright (C) 2004-2005 Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- Utility tool to display information held in a stringified -- reference, e.g. CORBA IOR, corbaloc or URI. with Ada.Command_Line; with Ada.Text_IO; with Output; with PolyORB.References; with PolyORB.Setup.Client; pragma Warnings (Off, PolyORB.Setup.Client); with PolyORB.Initialization; with PolyORB.Binding_Data.Print; with PolyORB.Types; use PolyORB.Types; with PO_CatRef_Setup; pragma Warnings (Off, PO_CatRef_Setup); procedure PO_CatRef is use Ada.Command_Line; use Output; use PolyORB.References; use PolyORB.Binding_Data; use PolyORB.Binding_Data.Print; Obj_Ref : Ref; begin PolyORB.Initialization.Initialize_World; if Argument_Count /= 1 then Ada.Text_IO.Put_Line ("usage: po_catref "); Ada.Text_IO.Put_Line (" is a stringified reference:" & " CORBA IOR, corbaloc or URI"); return; end if; Put_Line ("Parsing stringified reference", Ada.Command_Line.Argument (1)); New_Line; begin String_To_Object (Ada.Command_Line.Argument (1), Obj_Ref); exception when others => Put_Line ("Error", "Invalid reference !"); Flush; return; end; if Is_Nil (Obj_Ref) then Put_Line ("Error", "Null reference !"); Flush; return; end if; declare Profiles : constant Profile_Array := Profiles_Of (Obj_Ref); begin Put_Line ("Type Id", Type_Id_Of (Obj_Ref)); New_Line; Put_Line ("Found", Profiles'Length'Img & " profiles in IOR"); New_Line; for J in Profiles'Range loop Put_Line ("Profile number", Trimmed_Image (Long_Long (J))); Print_Profile (Profiles (J)); New_Line; end loop; end; Flush; end PO_CatRef; polyorb-2.8~20110207.orig/tools/po_catref/polyorb-giop_p-tagged_components-policies-print.adb0000644000175000017500000000754611750740340031566 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- POLYORB.GIOP_P.TAGGED_COMPONENTS.POLICIES.PRINT -- -- -- -- B o d y -- -- -- -- Copyright (C) 2004 Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by ACT Europe. -- -- (email: sales@act-europe.fr) -- -- -- ------------------------------------------------------------------------------ with Output; with PolyORB.Representations.CDR.Common; with PolyORB.Types; package body PolyORB.GIOP_P.Tagged_Components.Policies.Print is --------------- -- Output_TC -- --------------- procedure Output_TC (TC : TC_Policies) is use Policy_Value_Seq; use Output; use PolyORB.Representations.CDR.Common; use PolyORB.Types; use PolyORB.Utils; begin Inc_Indent; Put_Line ("Length", Length (TC.Policies)'Img); declare It : Policy_Value_Seq.Iterator := First (TC.Policies); P_Type : PolyORB.Types.Unsigned_Long; Counter : Long_Long := 1; begin Inc_Indent; while not Last (It) loop P_Type := Value (It).P_Type; if P_Type = 40 then Put_Line ("Policy #" & Trimmed_Image (Counter), "Priority_Model_Policy_Type (40)"); declare Buffer : aliased Buffer_Type; Model : PolyORB.Types.Unsigned_Long; Priority : PolyORB.Types.Short; begin Decapsulate (Value (It).P_Value, Buffer'Access); Model := Unmarshall (Buffer'Access); if Model = 0 then Put_Line ("Model", "CLIENT"); elsif Model = 1 then Put_Line ("Model", "SERVER_DECLARED"); else Put_Line ("Inconsistent value", Model'Img); end if; Priority := Unmarshall (Buffer'Access); Put_Line ("Priority", Priority'Img); end; end if; Next (It); Counter := Counter + 1; end loop; Dec_Indent; end; Dec_Indent; end Output_TC; end PolyORB.GIOP_P.Tagged_Components.Policies.Print; polyorb-2.8~20110207.orig/tools/po_catref/polyorb-binding_data-giop-iiop-print.ads0000644000175000017500000000423411750740340027313 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- POLYORB.BINDING_DATA.GIOP.IIOP.PRINT -- -- -- -- S p e c -- -- -- -- Copyright (C) 2004 Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by ACT Europe. -- -- (email: sales@act-europe.fr) -- -- -- ------------------------------------------------------------------------------ package PolyORB.Binding_Data.GIOP.IIOP.Print is procedure Print_IIOP_Profile (Prof : Profile_Access); end PolyORB.Binding_Data.GIOP.IIOP.Print; polyorb-2.8~20110207.orig/tools/po_catref/polyorb-giop_p-tagged_components-policies-print.ads0000644000175000017500000000424411750740340031577 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- POLYORB.GIOP_P.TAGGED_COMPONENTS.POLICIES.PRINT -- -- -- -- S p e c -- -- -- -- Copyright (C) 2004 Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by ACT Europe. -- -- (email: sales@act-europe.fr) -- -- -- ------------------------------------------------------------------------------ package PolyORB.GIOP_P.Tagged_Components.Policies.Print is procedure Output_TC (TC : TC_Policies); end PolyORB.GIOP_P.Tagged_Components.Policies.Print; polyorb-2.8~20110207.orig/tools/po_catref/polyorb-binding_data-soap-print.ads0000644000175000017500000000422211750740340026356 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . B I N D I N G _ D A T A . S O A P . P R I N T -- -- -- -- S p e c -- -- -- -- Copyright (C) 2004 Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by ACT Europe. -- -- (email: sales@act-europe.fr) -- -- -- ------------------------------------------------------------------------------ package PolyORB.Binding_Data.SOAP.Print is procedure Print_SOAP_Profile (Prof : Profile_Access); end PolyORB.Binding_Data.SOAP.Print; ././@LongLink0000000000000000000000000000015400000000000011565 Lustar rootrootpolyorb-2.8~20110207.orig/tools/po_catref/polyorb-giop_p-tagged_components-alternate_iiop_address-print.adbpolyorb-2.8~20110207.orig/tools/po_catref/polyorb-giop_p-tagged_components-alternate_iiop_address-pr0000644000175000017500000000467311750740340033221 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- POLYORB.GIOP_P.TAGGED_COMPONENTS.ALTERNATE_IIOP_ADDRESS.PRINT -- -- -- -- B o d y -- -- -- -- Copyright (C) 2005-2008, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with Common; with Output; package body PolyORB.GIOP_P.Tagged_Components.Alternate_IIOP_Address.Print is use Common; use Output; --------------- -- Output_TC -- --------------- procedure Output_TC (TC : TC_Alternate_IIOP_Address) is begin Inc_Indent; Output_Address_Information (TC.Address.all); Dec_Indent; end Output_TC; end PolyORB.GIOP_P.Tagged_Components.Alternate_IIOP_Address.Print; polyorb-2.8~20110207.orig/tools/po_catref/polyorb-binding_data-giop-uipmc-print.adb0000644000175000017500000001022611750740340027445 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- POLYORB.BINDING_DATA.GIOP.UIPMC.PRINT -- -- -- -- B o d y -- -- -- -- Copyright (C) 2004-2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with Common; with Output; with PolyORB.Binding_Data.Print; with PolyORB.GIOP_P.Transport_Mechanisms.UIPMC; with PolyORB.Initialization; with PolyORB.MIOP_P.Groups; with PolyORB.Types; use PolyORB.Types; with PolyORB.Utils.Strings; with PolyORB.GIOP_P.Tagged_Components.Print; package body PolyORB.Binding_Data.GIOP.UIPMC.Print is ------------------------- -- Print_UIPMC_Profile -- ------------------------- procedure Print_UIPMC_Profile (Prof : Profile_Access) is use Common; use Output; use PolyORB.Utils; use PolyORB.GIOP_P.Tagged_Components.Print; use PolyORB.GIOP_P.Transport_Mechanisms; use PolyORB.GIOP_P.Transport_Mechanisms.UIPMC; use PolyORB.MIOP_P.Groups; UIPMC_Prof : UIPMC_Profile_Type renames UIPMC_Profile_Type (Prof.all); begin Inc_Indent; Put_Line ("UIPMC Version", Trimmed_Image (Unsigned_Long_Long (UIPMC_Prof.Version_Major)) & "." & Trimmed_Image (Unsigned_Long_Long (UIPMC_Prof.Version_Minor))); Output_Address_Information (Address_Of (UIPMC_Transport_Mechanism (Element (UIPMC_Prof.Mechanisms, 0).all.all))); Put_Line ("Group info", PolyORB.MIOP_P.Groups.Image (UIPMC_Prof.G_I.all)); Output_Tagged_Components (UIPMC_Prof.Components); Dec_Indent; end Print_UIPMC_Profile; ---------------- -- Initialize -- ---------------- procedure Initialize; procedure Initialize is begin PolyORB.Binding_Data.Print.Register (Tag_UIPMC, Print_UIPMC_Profile'Access); end Initialize; use PolyORB.Initialization; use PolyORB.Initialization.String_Lists; use PolyORB.Utils.Strings; begin Register_Module (Module_Info' (Name => +"polyorb.binding_data.uipmc.print", Conflicts => PolyORB.Initialization.String_Lists.Empty, Depends => PolyORB.Initialization.String_Lists.Empty, Provides => PolyORB.Initialization.String_Lists.Empty, Implicit => False, Init => Initialize'Access, Shutdown => null)); end PolyORB.Binding_Data.GIOP.UIPMC.Print; polyorb-2.8~20110207.orig/tools/po_catref/polyorb-binding_data-soap-print.adb0000644000175000017500000000675011750740340026345 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . B I N D I N G _ D A T A . S O A P . P R I N T -- -- -- -- B o d y -- -- -- -- Copyright (C) 2004-2008, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with Common; with Output; with PolyORB.Binding_Data.Print; with PolyORB.Initialization; with PolyORB.Utils.Strings; package body PolyORB.Binding_Data.SOAP.Print is ------------------------ -- Print_SOAP_Profile -- ------------------------ procedure Print_SOAP_Profile (Prof : Profile_Access) is use Common; use Output; SOAP_Prof : SOAP_Profile_Type renames SOAP_Profile_Type (Prof.all); begin Inc_Indent; Put_Line ("SOAP", "(no version information)"); Output_Address_Information (SOAP_Prof.Address.all); Put_Line ("SOAP URI", PolyORB.Types.To_String (SOAP_Prof.URI_Path)); Output_Object_Information (SOAP_Prof.Object_Id.all); Dec_Indent; end Print_SOAP_Profile; ---------------- -- Initialize -- ---------------- procedure Initialize; procedure Initialize is begin PolyORB.Binding_Data.Print.Register (Tag_SOAP, Print_SOAP_Profile'Access); end Initialize; use PolyORB.Initialization; use PolyORB.Initialization.String_Lists; use PolyORB.Utils.Strings; begin Register_Module (Module_Info' (Name => +"polyorb.binding_data.soap.print", Conflicts => PolyORB.Initialization.String_Lists.Empty, Depends => PolyORB.Initialization.String_Lists.Empty, Provides => PolyORB.Initialization.String_Lists.Empty, Implicit => False, Init => Initialize'Access, Shutdown => null)); end PolyORB.Binding_Data.SOAP.Print; polyorb-2.8~20110207.orig/tools/po_catref/output.ads0000644000175000017500000000464611750740340021547 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- O U T P U T -- -- -- -- S p e c -- -- -- -- Copyright (C) 2004 Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by ACT Europe. -- -- (email: sales@act-europe.fr) -- -- -- ------------------------------------------------------------------------------ -- Output functions package Output is procedure Inc_Indent; procedure Dec_Indent; -- Increment or decrement the indentation level procedure Put_Line (Tag_C : String; Information : String); -- Append a Information to output, prepended by Tag_C procedure New_Line; -- Append a blank line procedure Flush; -- Real output function: output everything on Standard Output end Output; polyorb-2.8~20110207.orig/tools/po_catref/polyorb-giop_p-tagged_components-print.adb0000644000175000017500000001024511750740340027747 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- POLYORB.GIOP_P.TAGGED_COMPONENTS.PRINT -- -- -- -- B o d y -- -- -- -- Copyright (C) 2004-2005 Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with Output; with PolyORB.GIOP_P.Tagged_Components.Alternate_IIOP_Address.Print; with PolyORB.GIOP_P.Tagged_Components.Code_Sets.Print; with PolyORB.GIOP_P.Tagged_Components.Policies.Print; with PolyORB.Types; package body PolyORB.GIOP_P.Tagged_Components.Print is ------------------------------ -- Output_Tagged_Components -- ------------------------------ procedure Output_Tagged_Components (TCs : PolyORB.GIOP_P.Tagged_Components.Tagged_Component_List) is use Output; use PolyORB.GIOP_P.Tagged_Components.Alternate_IIOP_Address.Print; use PolyORB.GIOP_P.Tagged_Components.Alternate_IIOP_Address; use PolyORB.GIOP_P.Tagged_Components.Code_Sets.Print; use PolyORB.GIOP_P.Tagged_Components.Code_Sets; use PolyORB.GIOP_P.Tagged_Components.Policies.Print; use PolyORB.GIOP_P.Tagged_Components.Policies; use PolyORB.Utils; use PolyORB.Types; TC : Tagged_Component_Access; It : Iterator := First (TCs); J : Long_Long := 1; begin Put_Line ("Tagged components", Integer'Image (Length (TCs))); while not Last (It) loop TC := Value (It).all; Inc_Indent; Put_Line ("Component #" & Trimmed_Image (J), ""); J := J + 1; Inc_Indent; Put_Line ("Tag", TC.Tag'Img); case TC.Tag is when Tag_Code_Sets => Put_Line ("Type", "TAG_Code_Sets"); Output_TC (TC_Code_Sets (TC.all)); when Tag_Policies => Put_Line ("Type", "TAG_Policies"); Output_TC (TC_Policies (TC.all)); when Tag_Alternate_IIOP_Address => Put_Line ("Type", "TAG_Alternate_IIOP_Address"); Output_TC (TC_Alternate_IIOP_Address (TC.all)); when Tag_SSL_Sec_Trans => Put_Line ("Type", "TAG_SSL_Sec_Trans"); when Tag_Group => Put_Line ("Type", "TAG_Group"); when others => null; end case; Dec_Indent; Dec_Indent; Next (It); end loop; end Output_Tagged_Components; end PolyORB.GIOP_P.Tagged_Components.Print; polyorb-2.8~20110207.orig/tools/po_catref/polyorb-binding_data-print.adb0000644000175000017500000000625311750740340025403 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . B I N D I N G _ D A T A . P R I N T -- -- -- -- B o d y -- -- -- -- Copyright (C) 2004-2008, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with PolyORB.Utils.Chained_Lists; with Output; package body PolyORB.Binding_Data.Print is use Output; type Node is record Profile : Profile_Tag; Print : Print_Procedure; end record; package Lists is new PolyORB.Utils.Chained_Lists (Node); use Lists; Callbacks : Lists.List; -------------- -- Register -- -------------- procedure Register (Profile : Profile_Tag; Print : Print_Procedure) is begin Append (Callbacks, Node'(Profile => Profile, Print => Print)); end Register; ------------------- -- Print_Profile -- ------------------- procedure Print_Profile (Profile : Profile_Access) is Tag : constant Profile_Tag := Get_Profile_Tag (Profile.all); It : Iterator := First (Callbacks); begin while not Last (It) loop declare Info : constant Node := Value (It).all; begin if Tag = Info.Profile then Value (It).Print (Profile); return; end if; end; Next (It); end loop; Put_Line ("Unknown tag", Tag'Img); end Print_Profile; end PolyORB.Binding_Data.Print; polyorb-2.8~20110207.orig/tools/po_catref/polyorb-binding_data-srp-print.adb0000644000175000017500000000654711750740340026213 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . B I N D I N G _ D A T A . S R P . P R I N T -- -- -- -- B o d y -- -- -- -- Copyright (C) 2004-2008, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with Common; with Output; with PolyORB.Binding_Data.Print; with PolyORB.Initialization; with PolyORB.Utils.Strings; package body PolyORB.Binding_Data.SRP.Print is ----------------------- -- Print_SRP_Profile -- ----------------------- procedure Print_SRP_Profile (Prof : Profile_Access) is use Common; use Output; use PolyORB.Types; SRP_Prof : SRP_Profile_Type renames SRP_Profile_Type (Prof.all); begin Inc_Indent; Put_Line ("SRP", "(no version information"); Output_Address_Information (SRP_Prof.Address.all); Dec_Indent; end Print_SRP_Profile; ---------------- -- Initialize -- ---------------- procedure Initialize; procedure Initialize is begin PolyORB.Binding_Data.Print.Register (Tag_SRP, Print_SRP_Profile'Access); end Initialize; use PolyORB.Initialization; use PolyORB.Initialization.String_Lists; use PolyORB.Utils.Strings; begin Register_Module (Module_Info' (Name => +"polyorb.binding_data.srp.print", Conflicts => PolyORB.Initialization.String_Lists.Empty, Depends => PolyORB.Initialization.String_Lists.Empty, Provides => PolyORB.Initialization.String_Lists.Empty, Implicit => False, Init => Initialize'Access, Shutdown => null)); end PolyORB.Binding_Data.SRP.Print; polyorb-2.8~20110207.orig/tools/po_catref/polyorb-giop_p-tagged_components-code_sets-print.ads0000644000175000017500000000424711750740340031743 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- POLYORB.GIOP_P.TAGGED_COMPONENTS.CODE_SETS.PRINT -- -- -- -- S p e c -- -- -- -- Copyright (C) 2004-2008, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ package PolyORB.GIOP_P.Tagged_Components.Code_Sets.Print is procedure Output_TC (TC : TC_Code_Sets); end PolyORB.GIOP_P.Tagged_Components.Code_Sets.Print; polyorb-2.8~20110207.orig/tools/po_catref/common.adb0000644000175000017500000000523611750740340021452 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- C O M M O N -- -- -- -- B o d y -- -- -- -- Copyright (C) 2004-2008, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with Output; package body Common is use Output; -------------------------------- -- Output_Address_Information -- -------------------------------- procedure Output_Address_Information (Addr : PolyORB.Utils.Sockets.Socket_Name) is begin Put_Line ("Address", PolyORB.Utils.Sockets.Image (Addr)); end Output_Address_Information; ------------------------------- -- Output_Object_Information -- ------------------------------- procedure Output_Object_Information (Obj : PolyORB.Objects.Object_Id) is begin Put_Line ("Object_Id", PolyORB.Objects.Image (Obj)); end Output_Object_Information; end Common; polyorb-2.8~20110207.orig/tools/po_catref/polyorb-binding_data-giop-diop-print.adb0000644000175000017500000000771211750740340027271 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- POLYORB.BINDING_DATA.GIOP.DIOP.PRINT -- -- -- -- B o d y -- -- -- -- Copyright (C) 2004-2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with Common; with Output; with PolyORB.Binding_Data.Print; with PolyORB.GIOP_P.Transport_Mechanisms.DIOP; with PolyORB.Initialization; with PolyORB.Types; use PolyORB.Types; with PolyORB.Utils.Strings; with PolyORB.GIOP_P.Tagged_Components.Print; package body PolyORB.Binding_Data.GIOP.DIOP.Print is ------------------------ -- Print_DIOP_Profile -- ------------------------ procedure Print_DIOP_Profile (Prof : Profile_Access) is use Common; use Output; use PolyORB.GIOP_P.Tagged_Components.Print; use PolyORB.GIOP_P.Transport_Mechanisms; use PolyORB.GIOP_P.Transport_Mechanisms.DIOP; use PolyORB.Utils; DIOP_Prof : DIOP_Profile_Type renames DIOP_Profile_Type (Prof.all); begin Inc_Indent; Put_Line ("DIOP Version", Trimmed_Image (Unsigned_Long_Long (DIOP_Prof.Version_Major)) & "." & Trimmed_Image (Unsigned_Long_Long (DIOP_Prof.Version_Minor))); Output_Address_Information (Address_Of (DIOP_Transport_Mechanism (Element (DIOP_Prof.Mechanisms, 0).all.all))); Output_Tagged_Components (DIOP_Prof.Components); Dec_Indent; end Print_DIOP_Profile; ---------------- -- Initialize -- ---------------- procedure Initialize; procedure Initialize is begin PolyORB.Binding_Data.Print.Register (Tag_DIOP, Print_DIOP_Profile'Access); end Initialize; use PolyORB.Initialization; use PolyORB.Initialization.String_Lists; use PolyORB.Utils.Strings; begin Register_Module (Module_Info' (Name => +"polyorb.binding_data.diop.print", Conflicts => PolyORB.Initialization.String_Lists.Empty, Depends => PolyORB.Initialization.String_Lists.Empty, Provides => PolyORB.Initialization.String_Lists.Empty, Implicit => False, Init => Initialize'Access, Shutdown => null)); end PolyORB.Binding_Data.GIOP.DIOP.Print; polyorb-2.8~20110207.orig/tools/po_catref/polyorb-binding_data-giop-uipmc-print.ads0000644000175000017500000000423711750740340027473 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- POLYORB.BINDING_DATA.GIOP.UIPMC.PRINT -- -- -- -- S p e c -- -- -- -- Copyright (C) 2004 Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by ACT Europe. -- -- (email: sales@act-europe.fr) -- -- -- ------------------------------------------------------------------------------ package PolyORB.Binding_Data.GIOP.UIPMC.Print is procedure Print_UIPMC_Profile (Prof : Profile_Access); end PolyORB.Binding_Data.GIOP.UIPMC.Print; polyorb-2.8~20110207.orig/tools/po_dumpir/0000755000175000017500000000000011750740340017540 5ustar xavierxavierpolyorb-2.8~20110207.orig/tools/po_dumpir/po_dumpir.adb0000644000175000017500000003766111750740340022223 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O _ D U M P I R -- -- -- -- B o d y -- -- -- -- Copyright (C) 1999-2007, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with Ada.Command_Line; with Ada.Text_IO; with CORBA.ORB; with CORBA.Repository_Root; with CORBA.Repository_Root.Helper; with CORBA.Repository_Root.Repository; with CORBA.Repository_Root.Container; with CORBA.Repository_Root.Container.Helper; with CORBA.Repository_Root.Contained; with CORBA.Repository_Root.UnionDef.Helper; with CORBA.Repository_Root.StructDef.Helper; with CORBA.Repository_Root.InterfaceDef.Helper; with CORBA.Repository_Root.ExceptionDef.Helper; with CORBA.Repository_Root.ValueDef.Helper; with CORBA.Repository_Root.ModuleDef.Helper; with PolyORB.Setup.Client; pragma Warnings (Off, PolyORB.Setup.Client); procedure PO_DumpIR is use Ada.Text_IO; use CORBA; use CORBA.Repository_Root; procedure Print_TypeCode (TC : CORBA.TypeCode.Object; Inc : Standard.String); procedure Print_ParDescriptionSeq (Des : ParDescriptionSeq; Inc : Standard.String); procedure Print_Contents (In_Seq : ContainedSeq; Inc : Standard.String); procedure Print_Description (Des : Contained.Description; Inc : Standard.String); -------------------- -- Print_TypeCode -- -------------------- procedure Print_TypeCode (TC : CORBA.TypeCode.Object; Inc : Standard.String) is begin case CORBA.TypeCode.Kind (TC) is when Tk_Null => Put ("Null"); when Tk_Void => Put ("Void"); when Tk_Short => Put ("Short"); when Tk_Long => Put ("Long"); when Tk_Ushort => Put ("Ushort"); when Tk_Ulong => Put ("Ulong"); when Tk_Float => Put ("Float"); when Tk_Double => Put ("Double"); when Tk_Boolean => Put ("Boolean"); when Tk_Char => Put ("Char"); when Tk_Octet => Put ("Octet"); when Tk_Any => Put ("Any"); when Tk_TypeCode => Put ("TypeCode"); when Tk_Principal => Put ("Principal"); when Tk_Objref => Put ("ObjRef"); when Tk_Struct => declare L : constant CORBA.Unsigned_Long := CORBA.TypeCode.Member_Count (TC); begin Put ("Struct :"); if L /= 0 then for J in 0 .. L - 1 loop Put_Line (" "); Put (Inc & " "); Print_TypeCode (TypeCode.Member_Type (TC, J), Inc & " "); end loop; else Put_Line (" null record"); end if; end; when Tk_Union => declare L : constant Unsigned_Long := TypeCode.Member_Count (TC); begin Put ("Union :"); Put (" discr : "); Print_TypeCode (TypeCode.Discriminator_Type (TC), Inc & " "); if L /= 0 then for J in 0 .. L - 1 loop Put_Line (" "); Put (Inc & " "); Print_TypeCode (TypeCode.Member_Type (TC, J), Inc & " "); end loop; else Put_Line (" null record"); end if; end; when Tk_Enum => Put ("Enum"); when Tk_String => Put ("String"); when Tk_Sequence => Put ("Sequence ("); Print_TypeCode (CORBA.TypeCode.Content_Type (TC), Inc & " "); Put (")"); when Tk_Array => Put ("Array ("); Print_TypeCode (CORBA.TypeCode.Content_Type (TC), Inc & " "); Put (")"); when Tk_Alias => Put ("Alias ("); Print_TypeCode (CORBA.TypeCode.Content_Type (TC), Inc & " "); Put (")"); when Tk_Except => declare L : constant Unsigned_Long := TypeCode.Member_Count (TC); begin Put ("Exception :"); if L /= 0 then for J in 0 .. L - 1 loop Put_Line (" "); Put (Inc & " "); Print_TypeCode (TypeCode.Member_Type (TC, J), Inc & " "); end loop; else Put_Line (" null record"); end if; end; when Tk_Longlong => Put ("LongLong"); when Tk_Ulonglong => Put ("Ulonglonh"); when Tk_Longdouble => Put ("LongDouble"); when Tk_Widechar => Put ("Widechar"); when Tk_Wstring => Put ("Wstring"); when Tk_Fixed => Put ("Fixed"); when Tk_Value => Put ("value"); when Tk_Valuebox => Put ("valueBox"); Print_TypeCode (CORBA.TypeCode.Content_Type (TC), Inc & " "); Put (")"); when Tk_Native => Put ("Native"); when Tk_Abstract_Interface => Put ("Abstr-Ref"); when others => raise Program_Error; -- XXX for now, the IR does not support -- values in Tk_Local_Interface .. Tk_Event end case; end Print_TypeCode; ----------------------------- -- Print_ParDescriptionSeq -- ----------------------------- procedure Print_ParDescriptionSeq (Des : ParDescriptionSeq; Inc : Standard.String) is package PDS renames IDL_SEQUENCE_CORBA_ParameterDescription; A : constant PDS.Element_Array := PDS.To_Element_Array (PDS.Sequence (Des)); begin for J in A'Range loop Put_Line (Inc & "Param " & Integer'Image (J) & " : "); Put (Inc & " type : "); Print_TypeCode (A (J).IDL_Type, Inc & " "); Put_Line (" "); Put_Line (Inc & " name : " & CORBA.To_Standard_String (CORBA.String ((A (J).Name)))); Put_Line (Inc & " mode : " & ParameterMode'Image (A (J).Mode)); end loop; end Print_ParDescriptionSeq; ----------------------- -- Print_Description -- ----------------------- procedure Print_Description (Des : Contained.Description; Inc : Standard.String) is begin case Des.kind is when dk_Repository | dk_Primitive | dk_String | dk_Sequence | dk_Array | dk_Wstring | dk_Fixed | dk_Typedef | dk_all | dk_none => null; when dk_Attribute => declare D : constant AttributeDescription := Helper.From_Any (Des.value); begin Put (Inc & "Type :"); Print_TypeCode (D.IDL_Type, Inc & " "); Put_Line (" "); Put_Line (Inc & "Mode :" & AttributeMode'Image (D.Mode)); end; when dk_Constant | dk_ValueMember => null; when dk_Operation => declare D : constant OperationDescription := Helper.From_Any (Des.value); begin Put (Inc & "Result_type : "); Print_TypeCode (D.Result, Inc & " "); Put_Line (" "); Print_ParDescriptionSeq (D.Parameters, Inc); end; when dk_Alias | dk_Struct | dk_Union | dk_Enum | dk_ValueBox | dk_Native => declare D : constant TypeDescription := Helper.From_Any (Des.value); begin Put_Line (Inc & "TC_Type : " & TCKind'Image (TypeCode.Kind (D.IDL_type))); end; -- when -- dk_Exception => -- declare -- D : constant ExceptionDescription := -- Helper.From_Any (Des.value); -- begin -- null; -- end; -- when -- dk_Module => -- declare -- D : constant ModuleDescription := -- Helper.From_Any (Des.value); -- begin -- null; -- end; -- when -- dk_value => -- declare -- D : constant valueDescription := -- Helper.From_Any (Des.value); -- begin -- null; -- end; -- when -- dk_Interface => -- declare -- D : constant InterfaceDescription := -- Helper.From_Any (Des.value); -- begin -- null; -- end; when others => null; end case; end Print_Description; -------------------- -- Print_Contents -- -------------------- procedure Print_Contents (In_Seq : ContainedSeq; Inc : Standard.String) is package Contained_For_Seq renames CORBA.Repository_Root.IDL_SEQUENCE_CORBA_Contained_Forward; Cont_Array : constant Contained_For_Seq.Element_Array := Contained_For_Seq.To_Element_Array (Contained_For_Seq.Sequence (In_Seq)); use Contained; begin for J in Cont_Array'Range loop declare The_Ref : constant Contained.Ref := Convert_Forward.To_Ref (Cont_Array (J)); begin Put_Line (Inc & "Node : " & DefinitionKind'Image (Get_def_kind (The_Ref))); Put_Line (Inc & "Name : " & CORBA.To_Standard_String (CORBA.String (Get_name (The_Ref)))); Put_Line (Inc & "Id : " & CORBA.To_Standard_String (CORBA.String (Get_id (The_Ref)))); Put_Line (Inc & "Vers : " & CORBA.To_Standard_String (CORBA.String (Get_version (The_Ref)))); Put_Line (Inc & "Abs-Name : " & CORBA.To_Standard_String (CORBA.String (Get_absolute_name (The_Ref)))); Print_Description (Contained.describe (The_Ref), Inc); Put_Line (" "); -- Recursivity case Contained.Get_def_kind (The_Ref) is when dk_Module => declare R : constant Container.Ref := Container.Helper.To_Ref (ModuleDef.Helper.To_Ref (The_Ref)); begin Print_Contents (Container.contents (R, dk_all, True), Inc & " "); end; when dk_Exception => declare R : constant Container.Ref := Container.Helper.To_Ref (ExceptionDef.Helper.To_Ref (The_Ref)); begin Print_Contents (Container.contents (R, dk_all, True), Inc & " "); end; when dk_Interface => declare R : constant Container.Ref := Container.Helper.To_Ref (InterfaceDef.Helper.To_Ref (The_Ref)); begin Print_Contents (Container.contents (R, dk_all, True), Inc & " "); end; when dk_Value => declare R : constant Container.Ref := Container.Helper.To_Ref (ValueDef.Helper.To_Ref (The_Ref)); begin Print_Contents (Container.contents (R, dk_all, True), Inc & " "); end; when dk_Struct => declare R : constant Container.Ref := Container.Helper.To_Ref (StructDef.Helper.To_Ref (The_Ref)); begin Print_Contents (Container.contents (R, dk_all, True), Inc & " "); end; when dk_Union => declare R : constant Container.Ref := Container.Helper.To_Ref (UnionDef.Helper.To_Ref (The_Ref)); begin Print_Contents (Container.contents (R, dk_all, True), Inc & " "); end; when others => null; end case; end; end loop; end Print_Contents; Interface_Repo : Repository.Ref; begin CORBA.ORB.Initialize ("ORB"); if Ada.Command_Line.Argument_Count < 1 then Put_Line ("usage : po_dumpir "); return; end if; -- Getting the CORBA.Object CORBA.ORB.String_To_Object (CORBA.To_CORBA_String (Ada.Command_Line.Argument (1)), Interface_Repo); -- Checking if it worked if Repository.Is_Nil (Interface_Repo) then Put_Line ("main : cannot invoke on a nil reference"); return; end if; -- Dumping Interface Repository content Put_Line ("Start IR dump"); Print_Contents (Repository.contents (Interface_Repo, dk_all, True), " "); New_Line; Put_Line ("End of Print Interface Repository client!"); end PO_DumpIR; polyorb-2.8~20110207.orig/tools/po_cos_naming/0000755000175000017500000000000011750740340020355 5ustar xavierxavierpolyorb-2.8~20110207.orig/tools/po_cos_naming/po_cos_naming_shell.adb0000644000175000017500000005056411750740340025041 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O _ C O S _ N A M I N G _ S H E L L -- -- -- -- B o d y -- -- -- -- Copyright (C) 2001-2008, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with Ada.Exceptions; use Ada.Exceptions; with Ada.Text_IO; with GNAT.Command_Line; use GNAT.Command_Line; with Menu; use Menu; with CORBA; with CORBA.Object; with CORBA.ORB; with PortableServer; with CosNaming; use CosNaming; with CosNaming.NamingContext; use CosNaming.NamingContext; with CosNaming.NamingContext.Helper; with CosNaming.BindingIterator; use CosNaming.BindingIterator; with CosNaming.NamingContext.Impl; with File; use File; with File.Impl; with File.Helper; with PolyORB.CORBA_P.Naming_Tools; use PolyORB.CORBA_P.Naming_Tools; with PolyORB.CORBA_P.Server_Tools; with PolyORB.Setup.Thread_Pool_Server; pragma Elaborate_All (PolyORB.Setup.Thread_Pool_Server); pragma Warnings (Off, PolyORB.Setup.Thread_Pool_Server); procedure PO_COS_Naming_Shell is package Names renames CosNaming.IDL_SEQUENCE_CosNaming_NameComponent; Null_Name : constant Name := Name (Names.Null_Sequence); Null_Istring : constant Istring := Istring (CORBA.Null_String); Null_NC : constant NameComponent := (Null_Istring, Null_Istring); Test_Name : constant String := "test_naming"; type Command is (Help, Quit, Pwd, Read, Write, List, Ls, Namei, Lmkdir, Mkdir, Md, Rmkdir, Chdir, Cd, Rmdir, Mount, Bind, Df); Syntax_Error : exception; ------- -- M -- ------- function M (S : String) return String_Access; function M (S : String) return String_Access is begin return new String'(S); end M; Help_Messages : constant array (Command) of String_Access := (Help => M ("print this message"), Quit => M ("quit this shell"), Pwd => M ("print working directory"), Read => M ("read , read string from file F"), Write => M ("write , write string S in file F"), List => M ("list [], list files in dir D [def = <.>]"), Ls => M (" (alias for LIST)"), Namei => M ("namei , show IOR bound to "), Lmkdir => M ("lmdir , make local dir and bind it to "), Mkdir => M (" (alias for LMKDIR)"), Md => M (" (alias for LMKDIR)"), Rmkdir => M ("rmkdir , make dir in parent dir and bind it to "), Chdir => M ("chdir , change current dir to "), Cd => M (" (alias for CHDIR)"), Rmdir => M ("rmdir , remove dir "), Mount => M ("mount , bind dir name to dir "), Bind => M ("bind , bind object name to object "), Df => M ("df [], print of a given dir [def = <.>]")); function From (S : String; Sep : Character := '/') return NamingContext.Ref; function Parent (S : String; Sep : Character := '/') return NamingContext.Ref; function To_Dir (S : String; Sep : Character := '/') return NamingContext.Ref; function To_File (S : String; Sep : Character := '/') return File.Ref; function To_Object (S : String; Sep : Character := '/') return CORBA.Object.Ref; function To_Name (S : String; Sep : Character := '/') return Name; function To_String (N : Names.Element_Array; Sep : Character := '/') return String; function To_String (N : Name; Sep : Character := '/') return String; procedure Usage; -- Print help on console's functions procedure Cmd_Line_Usage; -- Print help on command line's parameters Argv : String_Access; Argc : Natural; Dir : NamingContext.Ref; Obj : CORBA.Object.Ref; Fil : File.Ref; WDR : NamingContext.Ref; WDN : constant Name := Null_Name; Root : NamingContext.Ref; ------------ -- Parent -- ------------ function Parent (S : String; Sep : Character := '/') return NamingContext.Ref is N : constant Name := To_Name (S, Sep); begin if Length (N) = 1 then return From (S, Sep); else return CosNaming.NamingContext.Helper.To_Ref (resolve (From (S, Sep), Name'(Head (N, Length (N) - 1, Null_NC)))); end if; end Parent; ---------- -- From -- ---------- function From (S : String; Sep : Character := '/') return NamingContext.Ref is begin if S (S'First) = Sep then return Root; else return WDR; end if; end From; ------------ -- To_Dir -- ------------ function To_Dir (S : String; Sep : Character := '/') return NamingContext.Ref is begin return NamingContext.Helper.To_Ref (resolve (From (S, Sep), To_Name (S, Sep))); exception when others => Ada.Text_IO.Put_Line ("No such directory " & S); raise; end To_Dir; ------------- -- To_File -- ------------- function To_File (S : String; Sep : Character := '/') return File.Ref is begin return File.Helper.To_Ref (To_Object (S, Sep)); end To_File; --------------- -- To_Object -- --------------- function To_Object (S : String; Sep : Character := '/') return CORBA.Object.Ref is begin return resolve (From (S, Sep), To_Name (S, Sep)); exception when others => Ada.Text_IO.Put_Line ("No such object " & S); raise; end To_Object; ------------- -- To_Name -- ------------- function To_Name (S : String; Sep : Character := '/') return Name renames PolyORB.CORBA_P.Naming_Tools.Parse_Name; --------------- -- To_String -- --------------- function To_String (N : Name; Sep : Character := '/') return String is begin return To_String (Names.To_Element_Array (Names.Sequence (N)), Sep); end To_String; --------------- -- To_String -- --------------- function To_String (N : Names.Element_Array; Sep : Character := '/') return String is begin if N'Length = 0 then return ""; elsif N'Length = 1 then return To_Standard_String (N (N'First).id) & ASCII.HT & To_Standard_String (N (N'First).kind); else return To_Standard_String (N (N'First).id) & Sep & To_String (N (N'First + 1 .. N'Last), Sep); end if; end To_String; ----------- -- Usage -- ----------- procedure Usage is begin for I in Help_Messages'Range loop Ada.Text_IO.Put_Line (I'Img & ASCII.HT & Help_Messages (I).all); end loop; Ada.Text_IO.New_Line; end Usage; Back : constant Name := To_Name ("...subcontext"); Here : constant Name := To_Name ("..subcontext"); Cmmd : Command; Register_Service : Boolean := False; --------------- -- Bind_Self -- --------------- procedure Bind_Self (Self : CosNaming.NamingContext.Ref; As : Name); procedure Bind_Self (Self : CosNaming.NamingContext.Ref; As : Name) is begin bind_context (Self, As, Self); exception when E : others => Ada.Text_IO.Put ("Warning: could not bind " & To_String (As) & ": "); Ada.Text_IO.Put_Line (Ada.Exceptions.Exception_Information (E)); Ada.Text_IO.Put_Line (Ada.Exceptions.Exception_Message (E)); end Bind_Self; -------------------- -- Cmd_Line_Usage -- -------------------- procedure Cmd_Line_Usage is begin Ada.Text_IO.Put_Line ("po_cos_naming_shell [-s] [-i] [-I ] [-n]"); Ada.Text_IO.Put_Line (" -s register root directory initial reference"); Ada.Text_IO.Put_Line (" -i retrieve root directory initial reference"); Ada.Text_IO.Put_Line (" -I , use object denoted by IOR as" & " root directory"); Ada.Text_IO.Put_Line (" -n retrieve root directory by name"); Ada.Text_IO.New_Line; Ada.Text_IO.Put_Line ("Note: if no Root is provided, create a new one"); end Cmd_Line_Usage; -- Start of processing for Test_Naming_CORBA_I begin CORBA.ORB.Initialize ("ORB"); PolyORB.CORBA_P.Server_Tools.Initiate_Server (Start_New_Task => True); -- Parse the command line begin Initialize_Option_Scan ('-', False, ""); loop case Getopt ("i n s I:") is when ASCII.NUL => exit; when 's' => Register_Service := True; when 'i' => begin Ada.Text_IO.Put ("retrieving root directory initial reference..."); Ada.Text_IO.Flush; if not Is_Nil (WDR) then raise Program_Error; end if; WDR := NamingContext.Helper.To_Ref (CORBA.ORB.Resolve_Initial_References (CORBA.ORB.ObjectId (CORBA.String' (CORBA.To_CORBA_String ("NamingService"))))); Ada.Text_IO.Put_Line (" done"); exception when others => Ada.Text_IO.Put_Line ("error"); raise; end; when 'I' => begin Ada.Text_IO.Put ("locating main service by IOR..."); Ada.Text_IO.Flush; if not Is_Nil (WDR) then raise Program_Error; end if; CORBA.ORB.String_To_Object (CORBA.To_CORBA_String (Parameter), WDR); Ada.Text_IO.Put_Line (" done"); exception when others => Ada.Text_IO.Put_Line (" error"); raise; end; when 'n' => begin Ada.Text_IO.Put ("locating main service by name..."); Ada.Text_IO.Flush; if not Is_Nil (WDR) then raise Program_Error; end if; WDR := NamingContext.Helper.To_Ref (Locate (Test_Name)); Ada.Text_IO.Put_Line (" done"); exception when others => Ada.Text_IO.Put_Line (" error"); raise; end; when others => -- This never happens raise Program_Error; end case; end loop; exception when Invalid_Switch => Ada.Text_IO.Put_Line (Ada.Text_IO.Current_Error, "Invalid Switch " & Full_Switch); Cmd_Line_Usage; return; when Invalid_Parameter => Ada.Text_IO.Put_Line (Ada.Text_IO.Current_Error, "No parameter for " & Full_Switch); Cmd_Line_Usage; return; end; -- If no root naming context is set up, create one if Is_Nil (WDR) then Ada.Text_IO.Put_Line ("creating root directory"); PolyORB.CORBA_P.Server_Tools.Servant_To_Reference (PortableServer.Servant (NamingContext.Impl.Create), WDR); if Register_Service then Ada.Text_IO.Put ("registering main service by name..."); Ada.Text_IO.Flush; Register (Test_Name, CORBA.Object.Ref (WDR), Rebind => True); Ada.Text_IO.Put_Line (" done"); end if; end if; Bind_Self (WDR, Here); Bind_Self (WDR, Back); -- Console main loop: read inputs and process them loop Argc := Count; if Argc > 0 then begin Argv := Argument (1); begin Cmmd := Command'Value (Argv.all); exception when Constraint_Error => raise Syntax_Error; end; case Cmmd is when Help => Usage; when Quit => exit; when Pwd => if Argc /= 1 then raise Syntax_Error; end if; Ada.Text_IO.Put_Line ('/' & To_String (WDN)); when Chdir | Cd => if Argc /= 2 then raise Syntax_Error; end if; Argv := Argument (2); WDR := To_Dir (Argv.all); when Rmkdir => if Argc /= 2 then raise Syntax_Error; end if; Argv := Argument (2); Dir := NamingContext.Ref (new_context (From (Argv.all))); bind_context (From (Argv.all), To_Name (Argv.all), Dir); bind_context (Dir, Here, Dir); bind_context (Dir, Back, Parent (Argv.all)); when Lmkdir | Mkdir | Md => if Argc /= 2 then raise Syntax_Error; end if; Argv := Argument (2); PolyORB.CORBA_P.Server_Tools.Servant_To_Reference (PortableServer.Servant (NamingContext.Impl.Create), Dir); bind_context (From (Argv.all), To_Name (Argv.all), Dir); bind_context (Dir, Here, Dir); bind_context (Dir, Back, Parent (Argv.all)); when Write => if Argc /= 3 then raise Syntax_Error; end if; Argv := Argument (2); begin Fil := To_File (Argv.all); exception when others => Ada.Text_IO.Put_Line ("Creating file " & Argv.all); Fil := File.Impl.New_File; bind (From (Argv.all), To_Name (Argv.all), CORBA.Object.Ref (Fil)); end; Argv := Argument (3); Set_Image (Fil, CORBA.To_CORBA_String (Argv.all)); when Read => if Argc /= 2 then raise Syntax_Error; end if; Argv := Argument (2); Fil := To_File (Argv.all); Ada.Text_IO.Put_Line (CORBA.To_Standard_String (Get_Image (Fil))); when Namei => if Argc /= 2 then raise Syntax_Error; end if; Argv := Argument (2); Ada.Text_IO.Put_Line (CORBA.To_Standard_String (CORBA.Object.Object_To_String (To_Object (Argv.all)))); when List | Ls => if Argc >= 3 then raise Syntax_Error; end if; if Argc = 1 then Dir := WDR; else Argv := Argument (2); Dir := To_Dir (Argv.all); end if; declare Empty : BindingList; Iterator : BindingIterator.Ref; Forward : BindingIterator_Forward.Ref; Done : CORBA.Boolean; Object : Binding; begin list (Dir, 0, Empty, Forward); Iterator := Convert_Forward.To_Ref (Forward); Ada.Text_IO.New_Line; Done := True; while Done loop next_one (Iterator, Object, Done); Ada.Text_IO.Put (To_String (Object.binding_name)); if Object.binding_type = ncontext then Ada.Text_IO.Put ('/'); end if; Ada.Text_IO.New_Line; end loop; destroy (Iterator); end; when Mount | Bind => if Argc /= 3 then raise Syntax_Error; end if; Argv := Argument (3); CORBA.ORB.String_To_Object (CORBA.To_CORBA_String (Argv.all), Obj); Argv := Argument (2); if Cmmd = Mount then Dir := NamingContext.Helper.To_Ref (Obj); bind_context (From (Argv.all), To_Name (Argv.all), Dir); else bind (From (Argv.all), To_Name (Argv.all), Obj); end if; when Df => if Argc >= 3 then raise Syntax_Error; end if; if Argc = 1 then Dir := WDR; Ada.Text_IO.Put (To_String (WDN)); else Argv := Argument (2); Dir := To_Dir (Argv.all); Ada.Text_IO.Put (Argv.all); end if; Ada.Text_IO.Put_Line (ASCII.HT & CORBA.To_Standard_String (CORBA.ORB.Object_To_String (Dir))); when Rmdir => if Argc /= 2 then raise Syntax_Error; end if; Argv := Argument (2); Obj := resolve (From (Argv.all), To_Name (Argv.all)); Dir := NamingContext.Helper.To_Ref (Obj); declare Bindings : BindingList; Forward : BindingIterator_Forward.Ref; begin list (Dir, 3, Bindings, Forward); if Length (Bindings) /= 2 then Ada.Text_IO.Put_Line ("directory not empty"); else unbind (From (Argv.all), To_Name (Argv.all) & Here); unbind (From (Argv.all), To_Name (Argv.all) & Back); unbind (From (Argv.all), To_Name (Argv.all)); destroy (Dir); end if; end; end case; exception when Syntax_Error => Ada.Text_IO.Put_Line ("syntax error"); when E : others => Ada.Text_IO.Put_Line ("raised "& Exception_Information (E)); Ada.Text_IO.Put_Line (Exception_Message (E)); end; end if; end loop; end PO_COS_Naming_Shell; polyorb-2.8~20110207.orig/tools/po_cos_naming/po_cos_naming.adb0000644000175000017500000001145611750740340023647 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O _ C O S _ N A M I N G -- -- -- -- B o d y -- -- -- -- Copyright (C) 2001-2007, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- Stand-alone server with a CORBA COS Naming's Root Context with Ada.Command_Line; with Ada.Text_IO; with Ada.Strings.Unbounded; with CORBA.Object; with CORBA.ORB; with PortableServer; with PolyORB.CORBA_P.Server_Tools; with PolyORB.CORBA_P.CORBALOC; with PolyORB.Setup.No_Tasking_Server; pragma Elaborate_All (PolyORB.Setup.No_Tasking_Server); pragma Warnings (Off, PolyORB.Setup.No_Tasking_Server); with CosNaming.NamingContextExt.Impl; procedure PO_COS_Naming is use Ada.Text_IO; Print_To_File : Boolean := False; Filename : Ada.Strings.Unbounded.Unbounded_String; procedure Scan_Command_Line; -- Scan the command line procedure Usage; -- Print usage information ----------------------- -- Scan_Command_Line -- ----------------------- procedure Scan_Command_Line is use Ada.Command_Line; begin if Argument_Count > 0 then for J in 1 .. Argument_Count loop if Argument (J) = "-file" then Print_To_File := True; Filename := Ada.Strings.Unbounded.To_Unbounded_String (Argument (J + 1)); elsif Argument (J) = "-help" then Usage; end if; end loop; end if; end Scan_Command_Line; ----------- -- Usage -- ----------- procedure Usage is begin New_Line; Put_Line (Standard_Error, "Usage: po_cos_naming" & ASCII.LF & " -file : output COS Naming IOR to 'filename'" & ASCII.LF & " -help : print this help" & ASCII.LF & " [PolyORB command line configuration variables]"); New_Line; end Usage; -- Main procedure begins here Root_NC : CosNaming.NamingContextExt.Impl.Object_Ptr; Ref : CORBA.Object.Ref; begin Scan_Command_Line; CORBA.ORB.Initialize ("ORB"); Root_NC := CosNaming.NamingContextExt.Impl.Create; PolyORB.CORBA_P.Server_Tools.Initiate_Well_Known_Service (PortableServer.Servant (Root_NC), "NameService", Ref); CORBA.ORB.Register_Initial_Reference (CORBA.ORB.To_CORBA_String ("NamingService"), Ref); Ada.Text_IO.Put_Line ("POLYORB_CORBA_NAME_SERVICE=" & CORBA.To_Standard_String (CORBA.Object.Object_To_String (Ref))); Ada.Text_IO.Put_Line ("POLYORB_CORBA_NAME_SERVICE=" & CORBA.To_Standard_String (PolyORB.CORBA_P.CORBALOC.Object_To_Corbaloc (Ref))); if Print_To_File then declare File : File_Type; begin Create (File, Out_File, Ada.Strings.Unbounded.To_String (Filename)); Put_Line (File, CORBA.To_Standard_String (CORBA.Object.Object_To_String (Ref))); Close (File); end; end if; PolyORB.CORBA_P.Server_Tools.Initiate_Server; end PO_COS_Naming; polyorb-2.8~20110207.orig/tools/po_cos_naming/ir_ab_names.adb0000644000175000017500000000500111750740340023260 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- I R _ A B _ N A M E S -- -- -- -- B o d y -- -- -- -- Copyright (C) 2002-2007, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by ACT Europe. -- -- (email: sales@act-europe.fr) -- -- -- ------------------------------------------------------------------------------ with PO_COS_Naming; with PolyORB.CORBA_P.Server_Tools; with PolyORB.If_Descriptors; with PolyORB.If_Descriptors.CORBA_IR; procedure IR_AB_Names is procedure IR_AB_Names_Setup; procedure IR_AB_Names_Setup is begin PolyORB.If_Descriptors.Default_If_Descriptor := new PolyORB.If_Descriptors.CORBA_IR.IR_If_Descriptor; end IR_AB_Names_Setup; begin PolyORB.CORBA_P.Server_Tools.Initiate_Server_Hook := IR_AB_Names_Setup'Unrestricted_Access; PO_COS_Naming; end IR_AB_Names; polyorb-2.8~20110207.orig/tools/po_createref/0000755000175000017500000000000011750740340020200 5ustar xavierxavierpolyorb-2.8~20110207.orig/tools/po_createref/po_createref_parse_cmd.adb0000644000175000017500000003734611750740340025340 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O _ C R E A T E R E F _ P A R S E _ C M D -- -- -- -- B o d y -- -- -- -- Copyright (C) 2007-2008, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with Ada.Text_IO; with Ada.Unchecked_Deallocation; with GNAT.Command_Line; package body PO_CreateRef_Parse_Cmd is use Ada.Text_IO; use GNAT.Command_Line; procedure Free is new Ada.Unchecked_Deallocation (Codeset_Array, Codeset_Array_Access); procedure Free is new Ada.Unchecked_Deallocation (Policies_Array, Policies_Array_Access); procedure Free is new Ada.Unchecked_Deallocation (Component_Array, Ptr_Components); procedure Free is new Ada.Unchecked_Deallocation (Profiles_Array, Ptr_Profiles); -- Current profile data Profile_Index : Natural := 0; Component_Index : Natural; procedure Usage; procedure Free (Obj : in out Policy_Subcomponent); procedure Free (Obj : in out Parameter_Component); procedure Free (Obj : in out Parameter_Profile); ------------------------ -- Parse_Command_Line -- ------------------------ procedure Parse_Command_Line (Param : out Parameter_Ref) is begin -- Globals parameters -- t => (reference) type -- pn => profile number -- h => help -- Profile parameters -- pt => profile type -- i => (profile) index -- g => system generated? -- cr => (profile) POA creator name -- vmj => version major -- vmn => version minor -- a => (profile) inet adress -- p => (profile) listening port -- cn => components number -- pe => end of profile -- Component parameters (generics) -- ct => component type -- ce => end of component -- codeset parameters -- char => requires C code -- wchar => requires W code -- s => supported [C|W] codeset {} -- policies parameters -- pol_nb => policies number -- model => priority model -- priority => priority value -- alternate address parameters -- a => inet address -- p => port -- SSL parameters -- supports => SSL supports flag -- requires => SSL requires flag -- p => port Initialize_Option_Scan; loop case Getopt ("a: char: ce cn: cr: ct: g h i: inet:requires: " & "supports: p: pe pt: pn: pol_nb: port: t: vmj: " & "vmn: wchar:") is when ASCII.NUL => exit; when 'p' => if Full_Switch = "pn" then Param.Profiles := new Profiles_Array (1 .. Natural'Value (Parameter)); elsif Full_Switch = "pt" then if Param.Profiles = null then Put_Line ("Profile number (pn) must be" & " specified before profiles"); exit; end if; Profile_Index := Profile_Index + 1; Param.Profiles.all (Profile_Index).Profile_Type := new String'(Parameter); elsif Full_Switch = "p" then Param.Profiles.all (Profile_Index).Address.Port := Positive'Value (Parameter); elsif Full_Switch = "pe" then null; elsif Full_Switch = "pol_nb" then Param.Profiles.all (Profile_Index). Components.all (Component_Index).Policies := new Policies_Array (1 .. Natural'Value (Parameter)); for I in Param.Profiles.all (Profile_Index). Components.all (Component_Index).Policies.all'Range loop for J in 1 .. 2 loop case Getopt ("model: priority:") is when 'm' => if Full_Switch = "model" then Param.Profiles.all (Profile_Index). Components.all (Component_Index). Policies.all (I).Priority_Model := new String'(Parameter); end if; when 'p' => if Full_Switch = "priority" then Param.Profiles.all (Profile_Index). Components.all (Component_Index). Policies.all (I).Priority_Value := Positive'Value (Parameter); end if; when ASCII.NUL => -- it should not happen! raise Program_Error; when others => raise Program_Error; end case; end loop; end loop; elsif Full_Switch = "p" then Param.Profiles.all (Profile_Index). Components.all (Component_Index).Address.Port := Positive'Value (Parameter); end if; when 't' => if Full_Switch = "t" then Param.Ref_Type := new String'(Parameter); end if; when 'h' => Usage; return; when 'a' => if Full_Switch = "a" then Param.Profiles.all (Profile_Index).Address.Inet_Addr := new String'(Parameter); end if; when 'c' => if Full_Switch = "cr" then Param.Profiles.all (Profile_Index).Creator_Name := new String'(Parameter); elsif Full_Switch = "cn" then Param.Profiles.all (Profile_Index).Components := new Component_Array (1 .. Natural'Value (Parameter)); Component_Index := 0; elsif Full_Switch = "ct" then if Param.Profiles.all (Profile_Index).Components = null then Put_Line ("No component should be defined before " & "component number"); raise Program_Error; end if; Component_Index := Component_Index + 1; Param.Profiles.all (Profile_Index).Components.all (Component_Index).C_Type := new String'(Parameter); elsif Full_Switch = "char" then Param.Profiles.all (Profile_Index). Components.all (Component_Index).Cchar := new String'(Parameter); case Getopt ("s:") is when 's' => Param.Profiles.all (Profile_Index). Components.all (Component_Index).C_Supported := new Codeset_Array (1 .. Positive'Value (Parameter)); for I in Param.Profiles.all (Profile_Index). Components.all (Component_Index). C_Supported.all'Range loop Param.Profiles.all (Profile_Index). Components.all (Component_Index). C_Supported.all (I) := new String'(Get_Argument); end loop; when others => Put_Line ("coin"); raise Program_Error; end case; elsif Full_Switch = "ce" then null; end if; when 'g' => if Full_Switch = "g" then Param.Profiles.all (Profile_Index).Is_Generated := True; end if; when 'i' => if Full_Switch = "i" then Param.Profiles.all (Profile_Index).Index := new String'(Parameter); end if; when 'v' => if Full_Switch = "vmj" then Param.Profiles.all (Profile_Index).Version_Major := PolyORB.Types.Octet'Value (Parameter); elsif Full_Switch = "vmn" then Param.Profiles.all (Profile_Index).Version_Minor := PolyORB.Types.Octet'Value (Parameter); end if; when 'w' => if Full_Switch = "wchar" then Param.Profiles.all (Profile_Index). Components.all (Component_Index).Wchar := new String'(Parameter); case Getopt ("s:") is when ASCII.NUL => Param.Profiles.all (Profile_Index). Components.all (Component_Index). W_Supported := null; exit; when 's' => Param.Profiles.all (Profile_Index). Components.all (Component_Index). W_Supported := new Codeset_Array (1 .. Positive'Value (Parameter)); for I in Param.Profiles.all (Profile_Index). Components.all (Component_Index). W_Supported.all'Range loop Param.Profiles.all (Profile_Index). Components.all (Component_Index). W_Supported.all (I) := new String'(Get_Argument); end loop; when others => raise Program_Error; end case; end if; when 's' => if Full_Switch = "supports" then Param.Profiles.all (Profile_Index). Components.all (Component_Index).SSL_Supports := new String'(Parameter); end if; when 'r' => if Full_Switch = "requires" then Param.Profiles.all (Profile_Index). Components.all (Component_Index).SSL_Requires := new String'(Parameter); end if; when others => raise Program_Error; end case; end loop; if Param.Profiles = null then Usage; end if; exception when Invalid_Switch => Put_Line ("Unknown switch used : " & Full_Switch); raise; when Invalid_Parameter => Put_Line ("No parameter provided for " & Full_Switch); raise; end Parse_Command_Line; ----------- -- Usage -- ----------- procedure Usage is begin Put_Line ("usage: po_createref -t -pn " & "{profile_description}"); New_Line; Put_Line ("GIOP/IIOP profile : " & "-pt iiop -i -g -cr " & "-vmj -vmn -a " & "-p -cn " & "{-ct ce} pe"); New_Line; Put_Line ("Policies component : policies -pol_nb " & "{-model -priority }"); New_Line; Put_Line ("Code_Sets component : -char " & "-s {}" & "-wchar -s {}"); New_Line; Put_Line ("SSL component : ssl_trans -requires -supports " & " -p "); New_Line; Put_Line ("Alternate Address component : alternate_address -a " & " -p "); New_Line; GNAT.OS_Lib.OS_Exit (1); end Usage; ---------- -- Free -- ---------- procedure Free (Ptr : in out Parameter_Ref) is begin Free (Ptr.Ref_Type); for J in Ptr.Profiles.all'Range loop Free (Ptr.Profiles.all (J)); end loop; Free (Ptr.Profiles); end Free; procedure Free (Obj : in out Parameter_Profile) is begin Free (Obj.Profile_Type); Free (Obj.Index); Free (Obj.Creator_Name); for J in Obj.Components.all'Range loop Free (Obj.Components.all (J)); end loop; Free (Obj.Components); end Free; procedure Free (Obj : in out Parameter_Component) is begin Free (Obj.C_Type); if Obj.Policies /= null then for J in Obj.Policies.all'Range loop Free (Obj.Policies.all (J)); end loop; Free (Obj.Policies); end if; if Obj.Cchar /= null then Free (Obj.Cchar); end if; if Obj.Wchar /= null then Free (Obj.Wchar); end if; if Obj.C_Supported /= null then for J in Obj.C_Supported.all'Range loop Free (Obj.C_Supported.all (J)); end loop; Free (Obj.C_Supported); end if; if Obj.W_Supported /= null then for J in Obj.W_Supported.all'Range loop Free (Obj.W_Supported.all (J)); end loop; Free (Obj.W_Supported); end if; if Obj.SSL_Supports /= null then Free (Obj.SSL_Supports); end if; if Obj.SSL_Requires /= null then Free (Obj.SSL_Requires); end if; if Obj.Address.Inet_Addr /= null then Free (Obj.Address.Inet_Addr); end if; end Free; procedure Free (Obj : in out Policy_Subcomponent) is begin Free (Obj.Priority_Model); end Free; end PO_CreateRef_Parse_Cmd; polyorb-2.8~20110207.orig/tools/po_createref/polyorb-giop_p-tagged_components-policies-create.adb0000644000175000017500000000761111750740340032362 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- POLYORB.GIOP_P.TAGGED_COMPONENTS.POLICIES.CREATE -- -- -- -- B o d y -- -- -- -- Copyright (C) 2007, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with PolyORB.Types; with PolyORB.GIOP_P.Tagged_Components.Policies.Priority_Model_Policy; with PolyORB.Representations.CDR.Common; package body PolyORB.GIOP_P.Tagged_Components.Policies.Create is use PolyORB.GIOP_P.Tagged_Components.Policies; use PolyORB.GIOP_P.Tagged_Components.Policies.Priority_Model_Policy; use PolyORB.Representations.CDR.Common; use PolyORB.Types; use Policy_Value_Seq; procedure Create_TC (Param : Parameter_Component; TC : in out TC_Policies; Error : out Boolean) is Buffer : Buffer_Access := new Buffer_Type; Policy_V : Policy_Value; Model : Natural; begin -- Policy component BNF : -- -pol_nb {Policies} -- Policy subcomponent BNF : -- -model -priority -- where := CLIENT|SERVER_DECLARED Error := False; for J in Param.Policies.all'Range loop if Param.Policies.all (J).Priority_Model.all = "CLIENT" then Model := 0; elsif Param.Policies.all (J).Priority_Model.all = "SERVER_DECLARED" then Model := 1; else Error := True; return; end if; -- Create a Policy value Start_Encapsulation (Buffer); Marshall (Buffer, PolyORB.Types.Unsigned_Long (Model)); Marshall (Buffer, PolyORB.Types.Short (Param.Policies.all (J).Priority_Value)); Policy_V := Policy_Value'(P_Type => 40, P_Value => new Encapsulation'(Encapsulate (Buffer))); Release (Buffer); -- add policy value to the tagged component Append (TC.Policies, Policy_V); end loop; end Create_TC; end PolyORB.GIOP_P.Tagged_Components.Policies.Create; ././@LongLink0000000000000000000000000000014700000000000011567 Lustar rootrootpolyorb-2.8~20110207.orig/tools/po_createref/polyorb-giop_p-tagged_components-ssl_sec_trans-create.adbpolyorb-2.8~20110207.orig/tools/po_createref/polyorb-giop_p-tagged_components-ssl_sec_trans-create.a0000644000175000017500000000542511750740340033110 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- POLYORB.GIOP_P.TAGGED_COMPONENTS.SSL_SEC_TRANS.CREATE -- -- -- -- B o d y -- -- -- -- Copyright (C) 2007, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with PolyORB.Sockets; package body PolyORB.GIOP_P.Tagged_Components.SSL_Sec_Trans.Create is use PolyORB.GIOP_P.Tagged_Components.SSL_Sec_Trans; --------------- -- Create_TC -- --------------- procedure Create_TC (Param : Parameter_Component; TC : in out TC_SSL_Sec_Trans; Error : out Boolean) is use PolyORB.Sockets; begin -- -supports -requires -port Error := False; TC.Target_Supports := Association_Options'Value (Param.SSL_Supports.all); TC.Target_Requires := Association_Options'Value (Param.SSL_Requires.all); TC.Port := Port_Type (Param.Address.Port); end Create_TC; end PolyORB.GIOP_P.Tagged_Components.SSL_Sec_Trans.Create; polyorb-2.8~20110207.orig/tools/po_createref/polyorb-giop_p-tagged_components-code_sets-create.adb0000644000175000017500000000640111750740340032517 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- POLYORB.GIOP_P.TAGGED_COMPONENTS.CODE_SETS.CREATE -- -- -- -- B o d y -- -- -- -- Copyright (C) 2007, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with PolyORB.GIOP_P.Code_Sets; package body PolyORB.GIOP_P.Tagged_Components.Code_Sets.Create is use PolyORB.GIOP_P.Tagged_Components.Code_Sets; use PolyORB.GIOP_P.Code_Sets; procedure Create_TC (Param : Parameter_Component; TC : in out TC_Code_Sets; Error : out Boolean) is begin -- Code Set component BNF : -- -char Supported_Code_Sets -- - wchar Supported_Code_Sets -- Where "Supported_Code_Sets" : -- -s { } Error := False; -- Char_Data TC.For_Char_Data.Native_Code_Set := Code_Set_Id'Value (Param.Cchar.all); for J in Param.C_Supported.all'Range loop Append (TC.For_Char_Data.Conversion_Code_Sets, Code_Set_Id'Value (Param.C_Supported.all (J).all)); end loop; -- Wchar_Data TC.For_Wchar_Data.Native_Code_Set := Code_Set_Id'Value (Param.Wchar.all); for J in Param.W_Supported.all'Range loop Append (TC.For_Wchar_Data.Conversion_Code_Sets, Code_Set_Id'Value (Param.W_Supported.all (J).all)); end loop; end Create_TC; end PolyORB.GIOP_P.Tagged_Components.Code_Sets.Create; polyorb-2.8~20110207.orig/tools/po_createref/polyorb-giop_p-tagged_components-code_sets-create.ads0000644000175000017500000000464311750740340032546 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- POLYORB.GIOP_P.TAGGED_COMPONENTS.CODE_SETS.CREATE -- -- -- -- S p e c -- -- -- -- Copyright (C) 2007, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with PO_CreateRef_Parse_Cmd; use PO_CreateRef_Parse_Cmd; with PolyORB.GIOP_P.Tagged_Components.Code_Sets; package PolyORB.GIOP_P.Tagged_Components.Code_Sets.Create is use PolyORB.GIOP_P.Tagged_Components.Code_Sets; procedure Create_TC (Param : Parameter_Component; TC : in out TC_Code_Sets; Error : out Boolean); end PolyORB.GIOP_P.Tagged_Components.Code_Sets.Create; polyorb-2.8~20110207.orig/tools/po_createref/po_createref_setup.adb.in0000644000175000017500000000432711750740340025141 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O _ C R E A T E R E F _ S E T U P -- -- -- -- B o d y -- -- -- -- Copyright (C) 2007, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- Personalities setup pragma Style_Checks ("M2048"); -- Configure substitutions may yield long lines -- @configure_input@ @PO_CREATEREF_WITHS@ package body PO_CreateRef_Setup is end PO_CreateRef_Setup; polyorb-2.8~20110207.orig/tools/po_createref/polyorb-binding_data-giop-diop-create.ads0000644000175000017500000000451711750740340030115 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- POLYORB.BINDING_DATA.GIOP.DIOP.CREATE -- -- -- -- S p e c -- -- -- -- Copyright (C) 2007, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with PO_CreateRef_Parse_Cmd; use PO_CreateRef_Parse_Cmd; package PolyORB.Binding_Data.GIOP.DIOP.Create is procedure Create_DIOP_Profile (Param : Parameter_Profile; Profile : out PolyORB.Binding_Data.Profile_Access; Error : out Boolean); end PolyORB.Binding_Data.GIOP.DIOP.Create; polyorb-2.8~20110207.orig/tools/po_createref/polyorb-giop_p-tagged_components-create.adb0000644000175000017500000001075611750740340030561 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- POLYORB.GIOP_P.TAGGED_COMPONENTS.CREATE -- -- -- -- B o d y -- -- -- -- Copyright (C) 2007, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with PolyORB.GIOP_P.Tagged_Components.SSL_Sec_Trans; with PolyORB.GIOP_P.Tagged_Components.SSL_Sec_Trans.Create; with PolyORB.GIOP_P.Tagged_Components.Alternate_IIOP_Address; with PolyORB.GIOP_P.Tagged_Components.Alternate_IIOP_Address.Create; with PolyORB.GIOP_P.Tagged_Components.Code_Sets; with PolyORB.GIOP_P.Tagged_Components.Code_Sets.Create; with PolyORB.GIOP_P.Tagged_Components.Policies; with PolyORB.GIOP_P.Tagged_Components.Policies.Create; package body PolyORB.GIOP_P.Tagged_Components.Create is ------------------------------ -- Create_Tagged_Components -- ------------------------------ procedure Create_Tagged_Components (Param : Component_Array; TCs : in out Tagged_Component_List; Error : out Boolean) is use PolyORB.GIOP_P.Tagged_Components.SSL_Sec_Trans.Create; use PolyORB.GIOP_P.Tagged_Components.SSL_Sec_Trans; use PolyORB.GIOP_P.Tagged_Components.Alternate_IIOP_Address.Create; use PolyORB.GIOP_P.Tagged_Components.Alternate_IIOP_Address; use PolyORB.GIOP_P.Tagged_Components.Code_Sets.Create; use PolyORB.GIOP_P.Tagged_Components.Code_Sets; use PolyORB.GIOP_P.Tagged_Components.Policies.Create; use PolyORB.GIOP_P.Tagged_Components.Policies; use PolyORB.GIOP_P.Tagged_Components; use PolyORB.Utils; use PolyORB.Types; TC : Tagged_Component_Access; V_Error : Boolean; begin Error := False; for J in Param'Range loop if Param (J).C_Type.all = "policies" then TC := new TC_Policies; Create_TC (Param (J), TC_Policies (TC.all), V_Error); elsif Param (J).C_Type.all = "code_set" then TC := new TC_Code_Sets; Create_TC (Param (J), TC_Code_Sets (TC.all), V_Error); elsif Param (J).C_Type.all = "alternate_address" then TC := new TC_Alternate_IIOP_Address; Create_TC (Param (J), TC_Alternate_IIOP_Address (TC.all), V_Error); elsif Param (J).C_Type.all = "ssl_trans" then TC := new TC_SSL_Sec_Trans; Create_TC (Param (J), TC_SSL_Sec_Trans (TC.all), V_Error); else Error := True; return; end if; if V_Error then Error := True; return; end if; -- We add the built component into the component list Add (TCs, TC); end loop; end Create_Tagged_Components; end PolyORB.GIOP_P.Tagged_Components.Create; polyorb-2.8~20110207.orig/tools/po_createref/po_createref_parse_cmd.ads0000644000175000017500000001010711750740340025343 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O _ C R E A T E R E F _ P A R S E _ C M D -- -- -- -- S p e c -- -- -- -- Copyright (C) 2007-2008, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with GNAT.OS_Lib; use GNAT.OS_Lib; with PolyORB.Types; use PolyORB.Types; package PO_CreateRef_Parse_Cmd is type Parameter_Address is record Inet_Addr : String_Access; Port : Positive; end record; -- ??? Should use PolyORB.Sockets.Socket_Name instead! type Policy_Subcomponent is record Priority_Model : String_Access; Priority_Value : Positive; end record; type Policies_Array is array (Natural range <>) of Policy_Subcomponent; type Policies_Array_Access is access Policies_Array; type Codeset_Array is array (Natural range <>) of String_Access; type Codeset_Array_Access is access Codeset_Array; type Parameter_Component is record C_Type : String_Access; -- Policies component Policies : Policies_Array_Access; -- Code_Set component Cchar : String_Access; C_Supported : Codeset_Array_Access; Wchar : String_Access; W_Supported : Codeset_Array_Access; -- SSL SSL_Supports : String_Access; SSL_Requires : String_Access; -- alternate iiop address Address : Parameter_Address; end record; type Component_Array is array (Natural range <>) of Parameter_Component; type Ptr_Components is access Component_Array; type Parameter_Profile is record Profile_Type : String_Access; Index : String_Access; Is_Generated : Boolean := False; Creator_Name : String_Access; Version_Major : PolyORB.Types.Octet; Version_Minor : PolyORB.Types.Octet; Address : Parameter_Address; Components : Ptr_Components; end record; type Profiles_Array is array (Natural range <>) of Parameter_Profile; type Ptr_Profiles is access Profiles_Array; type Parameter_Ref is record Ref_Type : String_Access; Profiles : Ptr_Profiles; end record; procedure Parse_Command_Line (Param : out Parameter_Ref); procedure Free (Ptr : in out Parameter_Ref); end PO_CreateRef_Parse_Cmd; polyorb-2.8~20110207.orig/tools/po_createref/polyorb-giop_p-tagged_components-policies-create.ads0000644000175000017500000000463611750740340032407 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- POLYORB.GIOP_P.TAGGED_COMPONENTS.POLICIES.CREATE -- -- -- -- S p e c -- -- -- -- Copyright (C) 2007, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with PO_CreateRef_Parse_Cmd; use PO_CreateRef_Parse_Cmd; with PolyORB.GIOP_P.Tagged_Components.Policies; package PolyORB.GIOP_P.Tagged_Components.Policies.Create is use PolyORB.GIOP_P.Tagged_Components.Policies; procedure Create_TC (Param : Parameter_Component; TC : in out TC_Policies; Error : out Boolean); end PolyORB.GIOP_P.Tagged_Components.Policies.Create; ././@LongLink0000000000000000000000000000016000000000000011562 Lustar rootrootpolyorb-2.8~20110207.orig/tools/po_createref/polyorb-giop_p-tagged_components-alternate_iiop_address-create.adspolyorb-2.8~20110207.orig/tools/po_createref/polyorb-giop_p-tagged_components-alternate_iiop_address0000644000175000017500000000474411750740340033275 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- POLYORB.GIOP_P.TAGGED_COMPONENTS.ALTERNATE_IIOP_ADDRESS.CREATE -- -- -- -- S p e c -- -- -- -- Copyright (C) 2007, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with PO_CreateRef_Parse_Cmd; use PO_CreateRef_Parse_Cmd; with PolyORB.GIOP_P.Tagged_Components.Alternate_IIOP_Address; package PolyORB.GIOP_P.Tagged_Components.Alternate_IIOP_Address.Create is use PolyORB.GIOP_P.Tagged_Components.Alternate_IIOP_Address; procedure Create_TC (Param : Parameter_Component; TC : in out TC_Alternate_IIOP_Address; Error : out Boolean); end PolyORB.GIOP_P.Tagged_Components.Alternate_IIOP_Address.Create; polyorb-2.8~20110207.orig/tools/po_createref/polyorb-binding_data-create.adb0000644000175000017500000000652411750740340026207 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . B I N D I N G _ D A T A . C R E A T E -- -- -- -- B o d y -- -- -- -- Copyright (C) 2007-2008, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with PolyORB.Utils.Chained_Lists; with Ada.Text_IO; package body PolyORB.Binding_Data.Create is type Node is record Profile : String (1 .. 4); Create : Create_Procedure; end record; package Lists is new PolyORB.Utils.Chained_Lists (Node); use Lists; Callbacks : Lists.List; -------------- -- Register -- -------------- procedure Register (Profile : String; Create : Create_Procedure) is begin Append (Callbacks, Node'(Profile => Profile, Create => Create)); end Register; -------------------- -- Create_Profile -- -------------------- procedure Create_Profile (Param : Parameter_Profile; Profile : out PolyORB.Binding_Data.Profile_Access; Error : out Boolean) is Tag : constant String := Param.Profile_Type.all; It : Iterator := First (Callbacks); begin Error := True; while not Last (It) loop declare Info : constant Node := Value (It).all; begin if Tag = Info.Profile then Value (It).Create (Param, Profile, Error); return; end if; end; Next (It); end loop; Ada.Text_IO.Put_Line ("Unknown tag : " & Tag); end Create_Profile; end PolyORB.Binding_Data.Create; ././@LongLink0000000000000000000000000000016000000000000011562 Lustar rootrootpolyorb-2.8~20110207.orig/tools/po_createref/polyorb-giop_p-tagged_components-alternate_iiop_address-create.adbpolyorb-2.8~20110207.orig/tools/po_createref/polyorb-giop_p-tagged_components-alternate_iiop_address0000644000175000017500000000532511750740340033271 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- POLYORB.GIOP_P.TAGGED_COMPONENTS.ALTERNATE_IIOP_ADDRESS.CREATE -- -- -- -- B o d y -- -- -- -- Copyright (C) 2007-2008, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with PolyORB.Sockets; with PolyORB.Utils.Sockets; package body PolyORB.GIOP_P.Tagged_Components.Alternate_IIOP_Address.Create is use PolyORB.GIOP_P.Tagged_Components.Alternate_IIOP_Address; --------------- -- Create_TC -- --------------- procedure Create_TC (Param : Parameter_Component; TC : in out TC_Alternate_IIOP_Address; Error : out Boolean) is use PolyORB.Sockets; use PolyORB.Utils.Sockets; begin TC.Address := new Socket_Name'(Param.Address.Inet_Addr.all + Port_Type (Param.Address.Port)); Error := False; end Create_TC; end PolyORB.GIOP_P.Tagged_Components.Alternate_IIOP_Address.Create; polyorb-2.8~20110207.orig/tools/po_createref/polyorb-binding_data-giop-diop-create.adb0000644000175000017500000001171111750740340030066 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- POLYORB.BINDING_DATA.GIOP.DIOP.CREATE -- -- -- -- B o d y -- -- -- -- Copyright (C) 2007-2008, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with PolyORB.Binding_Data.Create; with PolyORB.Initialization; with PolyORB.GIOP_P.Tagged_Components.Create; with PolyORB.GIOP_P.Transport_Mechanisms; with PolyORB.GIOP_P.Transport_Mechanisms.DIOP; with PolyORB.POA_Types; with PolyORB.Sockets; with PolyORB.Utils.Sockets; with PolyORB.Utils.Strings; package body PolyORB.Binding_Data.GIOP.DIOP.Create is use PolyORB.GIOP_P.Tagged_Components; use PolyORB.GIOP_P.Tagged_Components.Create; use PolyORB.GIOP_P.Transport_Mechanisms.DIOP; use PolyORB.GIOP_P.Transport_Mechanisms; use PolyORB.POA_Types; use PolyORB.Sockets; use PolyORB.Utils.Sockets; ------------------------- -- Create_DIOP_Profile -- ------------------------- procedure Create_DIOP_Profile (Param : Parameter_Profile; Profile : out PolyORB.Binding_Data.Profile_Access; Error : out Boolean) is use PolyORB.Utils; begin -- -vmj -vmn -- -a -p -cn -- {components} pe -- where object_id := -- -i [-g] -cr Error := False; Profile := new DIOP_Profile_Type; declare UOid : Unmarshalled_Oid; TProfile : DIOP_Profile_Type renames DIOP_Profile_Type (Profile.all); begin -- We build a DIOP profile UOid := Create_Id (Name => Param.Index.all, System_Generated => Param.Is_Generated, Persistency_Flag => Time_Stamp'First, Creator => Param.Creator_Name.all); TProfile.Object_Id := U_Oid_To_Oid (UOid); -- Set version TProfile.Version_Major := Param.Version_Major; TProfile.Version_Minor := Param.Version_Minor; -- Create server address and add transport mechanism Append (TProfile.Mechanisms, GIOP_P.Transport_Mechanisms.DIOP.Create_Transport_Mechanism (Param.Address.Inet_Addr.all + Port_Type (Param.Address.Port))); -- Add Tagged_Components Create_Tagged_Components (Param.Components.all, TProfile.Components, Error); end; end Create_DIOP_Profile; ---------------- -- Initialize -- ---------------- procedure Initialize; procedure Initialize is begin PolyORB.Binding_Data.Create.Register ("diop", Create_DIOP_Profile'Access); end Initialize; use PolyORB.Initialization; use PolyORB.Initialization.String_Lists; use PolyORB.Utils.Strings; begin Register_Module (Module_Info' (Name => +"polyorb.binding_data.diop.create", Conflicts => PolyORB.Initialization.String_Lists.Empty, Depends => PolyORB.Initialization.String_Lists.Empty, Provides => PolyORB.Initialization.String_Lists.Empty, Implicit => False, Init => Initialize'Access, Shutdown => null)); end PolyORB.Binding_Data.GIOP.DIOP.Create; polyorb-2.8~20110207.orig/tools/po_createref/polyorb-binding_data-create.ads0000644000175000017500000000506611750740340026230 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . B I N D I N G _ D A T A . C R E A T E -- -- -- -- S p e c -- -- -- -- Copyright (C) 2007-2008, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with PolyORB.Binding_Data; with PO_CreateRef_Parse_Cmd; use PO_CreateRef_Parse_Cmd; package PolyORB.Binding_Data.Create is type Create_Procedure is access procedure (Param : Parameter_Profile; Profile : out PolyORB.Binding_Data.Profile_Access; Error : out Boolean); procedure Register (Profile : String; Create : Create_Procedure); procedure Create_Profile (Param : Parameter_Profile; Profile : out PolyORB.Binding_Data.Profile_Access; Error : out Boolean); end PolyORB.Binding_Data.Create; polyorb-2.8~20110207.orig/tools/po_createref/polyorb-binding_data-giop-iiop-create.adb0000644000175000017500000001171611750740340030100 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- POLYORB.BINDING_DATA.GIOP.IIOP.CREATE -- -- -- -- B o d y -- -- -- -- Copyright (C) 2007-2008, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with PolyORB.Binding_Data.Create; with PolyORB.Initialization; with PolyORB.GIOP_P.Tagged_Components.Create; with PolyORB.GIOP_P.Transport_Mechanisms; with PolyORB.GIOP_P.Transport_Mechanisms.IIOP; with PolyORB.Sockets; with PolyORB.POA_Types; with PolyORB.Utils.Sockets; with PolyORB.Utils.Strings; package body PolyORB.Binding_Data.GIOP.IIOP.Create is use PolyORB.GIOP_P.Tagged_Components; use PolyORB.GIOP_P.Tagged_Components.Create; use PolyORB.GIOP_P.Transport_Mechanisms.IIOP; use PolyORB.GIOP_P.Transport_Mechanisms; use PolyORB.POA_Types; use PolyORB.Sockets; use PolyORB.Utils.Sockets; ------------------------- -- Create_IIOP_Profile -- ------------------------- procedure Create_IIOP_Profile (Param : Parameter_Profile; Profile : out PolyORB.Binding_Data.Profile_Access; Error : out Boolean) is use PolyORB.Utils; begin -- -vmj -vmn -- -a -p -cn -- {components} pe -- where object_id := -- -i [-g] -cr Error := False; Profile := new IIOP_Profile_Type; declare UOid : Unmarshalled_Oid; TProfile : IIOP_Profile_Type renames IIOP_Profile_Type (Profile.all); begin -- We build a IIOP profile UOid := Create_Id (Name => Param.Index.all, System_Generated => Param.Is_Generated, Persistency_Flag => Time_Stamp'First, Creator => Param.Creator_Name.all); TProfile.Object_Id := U_Oid_To_Oid (UOid); -- Set version TProfile.Version_Major := Param.Version_Major; TProfile.Version_Minor := Param.Version_Minor; -- Create server address and add transport mechanism Append (TProfile.Mechanisms, PolyORB.GIOP_P.Transport_Mechanisms.IIOP.Create_Transport_Mechanism (Param.Address.Inet_Addr.all + Port_Type (Param.Address.Port))); -- Add Tagged_Components Create_Tagged_Components (Param.Components.all, TProfile.Components, Error); end; end Create_IIOP_Profile; ---------------- -- Initialize -- ---------------- procedure Initialize; procedure Initialize is begin PolyORB.Binding_Data.Create.Register ("iiop", Create_IIOP_Profile'Access); end Initialize; use PolyORB.Initialization; use PolyORB.Initialization.String_Lists; use PolyORB.Utils.Strings; begin Register_Module (Module_Info' (Name => +"polyorb.binding_data.iiop.create", Conflicts => PolyORB.Initialization.String_Lists.Empty, Depends => PolyORB.Initialization.String_Lists.Empty, Provides => PolyORB.Initialization.String_Lists.Empty, Implicit => False, Init => Initialize'Access, Shutdown => null)); end PolyORB.Binding_Data.GIOP.IIOP.Create; polyorb-2.8~20110207.orig/tools/po_createref/po_createref_setup.ads0000644000175000017500000000413111750740340024546 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O _ C R E A T E R E F _ S E T U P -- -- -- -- S p e c -- -- -- -- Copyright (C) 2007, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ package PO_CreateRef_Setup is pragma Elaborate_Body; end PO_CreateRef_Setup; polyorb-2.8~20110207.orig/tools/po_createref/po_createref.adb0000644000175000017500000000662411750740340023316 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O _ C R E A T E R E F -- -- -- -- B o d y -- -- -- -- Copyright (C) 2007-2008, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with Ada.Text_IO; with PolyORB.References; with PolyORB.References.IOR; with PolyORB.Setup.Client; pragma Elaborate_All (PolyORB.Setup.Client); pragma Warnings (Off, PolyORB.Setup.Client); with PolyORB.Initialization; with PolyORB.Binding_Data.Create; with PO_CreateRef_Setup; pragma Elaborate_All (PO_CreateRef_Setup); pragma Warnings (Off, PO_CreateRef_Setup); with PO_CreateRef_Parse_Cmd; procedure PO_CreateRef is use PO_CreateRef_Parse_Cmd; Params : Parameter_Ref; begin PolyORB.Initialization.Initialize_World; Parse_Command_Line (Params); declare use PolyORB.Binding_Data.Create; Reference : PolyORB.References.Ref; Error : Boolean; Profiles : PolyORB.References.Profile_Array (1 .. Params.Profiles.all'Length); begin for J in Profiles'Range loop Create_Profile (Params.Profiles (J), Profiles (J), Error); if Error then Ada.Text_IO.Put_Line ("Syntax error"); return; end if; end loop; -- Build reference PolyORB.References.Create_Reference (Profiles, Params.Ref_Type.all, Reference); Free (Params); declare -- use PolyORB.Objects; Str : constant String := PolyORB.References.IOR.Object_To_String (Reference); begin Ada.Text_IO.Put_Line (Str); end; end; end PO_CreateRef; polyorb-2.8~20110207.orig/tools/po_createref/polyorb-giop_p-tagged_components-create.ads0000644000175000017500000000461711750740340030601 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- POLYORB.GIOP_P.TAGGED_COMPONENTS.CREATE -- -- -- -- S p e c -- -- -- -- Copyright (C) 2007, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with PolyORB.GIOP_P.Tagged_Components; with PO_CreateRef_Parse_Cmd; use PO_CreateRef_Parse_Cmd; package PolyORB.GIOP_P.Tagged_Components.Create is use PolyORB.GIOP_P.Tagged_Components; procedure Create_Tagged_Components (Param : Component_Array; TCs : in out Tagged_Component_List; Error : out Boolean); end PolyORB.GIOP_P.Tagged_Components.Create; ././@LongLink0000000000000000000000000000014700000000000011567 Lustar rootrootpolyorb-2.8~20110207.orig/tools/po_createref/polyorb-giop_p-tagged_components-ssl_sec_trans-create.adspolyorb-2.8~20110207.orig/tools/po_createref/polyorb-giop_p-tagged_components-ssl_sec_trans-create.a0000644000175000017500000000466711750740340033117 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- POLYORB.GIOP_P.TAGGED_COMPONENTS.SSL_SEC_TRANS.CREATE -- -- -- -- S p e c -- -- -- -- Copyright (C) 2007, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with PO_CreateRef_Parse_Cmd; use PO_CreateRef_Parse_Cmd; with PolyORB.GIOP_P.Tagged_Components.SSL_Sec_Trans; package PolyORB.GIOP_P.Tagged_Components.SSL_Sec_Trans.Create is use PolyORB.GIOP_P.Tagged_Components.SSL_Sec_Trans; procedure Create_TC (Param : Parameter_Component; TC : in out TC_SSL_Sec_Trans; Error : out Boolean); end PolyORB.GIOP_P.Tagged_Components.SSL_Sec_Trans.Create; polyorb-2.8~20110207.orig/tools/po_createref/polyorb-binding_data-giop-iiop-create.ads0000644000175000017500000000451711750740340030122 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- POLYORB.BINDING_DATA.GIOP.IIOP.CREATE -- -- -- -- S p e c -- -- -- -- Copyright (C) 2007, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with PO_CreateRef_Parse_Cmd; use PO_CreateRef_Parse_Cmd; package PolyORB.Binding_Data.GIOP.IIOP.Create is procedure Create_IIOP_Profile (Param : Parameter_Profile; Profile : out PolyORB.Binding_Data.Profile_Access; Error : out Boolean); end PolyORB.Binding_Data.GIOP.IIOP.Create; polyorb-2.8~20110207.orig/tools/po_ir/0000755000175000017500000000000011750740340016652 5ustar xavierxavierpolyorb-2.8~20110207.orig/tools/po_ir/po_ir.adb0000644000175000017500000000675211750740340020444 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O _ I R -- -- -- -- B o d y -- -- -- -- Copyright (C) 2007, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with Ada.Text_IO; with CORBA.Object; with CORBA.ORB; with CORBA.Repository_Root.Contained.Impl; with CORBA.Repository_Root.IRObject.Impl; with CORBA.Repository_Root.Repository.Impl; with PolyORB.CORBA_P.CORBALOC; with PolyORB.CORBA_P.Server_Tools; with PortableServer; with PolyORB.Setup.No_Tasking_Server; pragma Warnings (Off, PolyORB.Setup.No_Tasking_Server); pragma Elaborate_All (PolyORB.Setup.No_Tasking_Server); procedure PO_IR is Repository_Obj : CORBA.Repository_Root.Repository.Impl.Object_Ptr; Ref : CORBA.Object.Ref; begin CORBA.ORB.Initialize ("ORB"); Repository_Obj := new CORBA.Repository_Root.Repository.Impl.Object; CORBA.Repository_Root.Repository.Impl.Init (Repository_Obj, CORBA.Repository_Root.IRObject.Impl.Object_Ptr (Repository_Obj), CORBA.Repository_Root.dk_Repository, CORBA.Repository_Root.Contained.Impl.Contained_Seq.Null_Sequence); PolyORB.CORBA_P.Server_Tools.Initiate_Well_Known_Service (PortableServer.Servant (Repository_Obj), "InterfaceRepository", Ref); CORBA.ORB.Register_Initial_Reference (CORBA.ORB.To_CORBA_String ("InterfaceRepository"), Ref); Ada.Text_IO.Put_Line ("POLYORB_CORBA_IR_SERVICE=" & CORBA.To_Standard_String (CORBA.Object.Object_To_String (Ref))); Ada.Text_IO.Put_Line ("POLYORB_CORBA_IR_SERVICE=" & CORBA.To_Standard_String (PolyORB.CORBA_P.CORBALOC.Object_To_Corbaloc (Ref))); PolyORB.CORBA_P.Server_Tools.Initiate_Server; end PO_IR; polyorb-2.8~20110207.orig/features-270000644000175000017500000000666011750740337016407 0ustar xavierxavier============================= PolyORB 2.7 NEW FEATURES LIST ============================= Copyright (C) 2009-2010, AdaCore This file contains a complete list of new features in version 2.7 of PolyORB. See also file NEWS for various information about this release. An ISO date (YYYY-MM-DD) appears in parentheses after the description line. This date shows the implementation date of the feature. Any 2.7 wavefront subsequent to this date will contain the indicated feature, as will any subsequent releases. NF-27-J817-001 Abortable RPC (2010-09-03) Remote subprogram calls can now safely be aborted using asynchronous transfer of control. The abortion is notified to the server, and an attempt is made to cancel the server side execution of the call. NF-27-J723-021 Time stamps in traces (2010-07-28) Time stamps can now optionally be generated for trace messages logged to standard error. This feature is enabled by setting "timestamp=true" in section [log] of the PolyORB configuration. NF-27-J521-019 DSA starter does not depend on Bourne shell (2010-08-31) The generated Ada and shell starters for DSA applications do not require the remote node to provide a Bourne shell anymore. NF-27-J511-001 po_gnatdist reports Name_Server setting (2010-05-12) If a pragma Name_Server is given in the configuration file, po_gnatdist reports this information in its output. NF-27-J317-029 Better selection of local IP address (2010-04-27) PolyORB now tries to avoid using a loopback address when creating profiles designating local listening sockets, so that the generated IORs or URLs are valid beyond the local host. NF-27-J225-018 Allow CORBA.Any to be used at library level (2010-02-27) Objects of CORBA.Any type can be declared at library level now, and be elaborated before initialization of ORB. NF-27-J118-027 Use minimal perfect hash functions (2010-03-11) The Ada code generated by iac now uses minimal perfect hash functions rather than cascading 'if' statements in the Skel. This is a speed improvement, especially when there are a large number of methods. NF-27-IC22-022 Disable style checks in po_gnatdist generated files (2009-12-23) Style checks are now turned off for source files generated by po_gnatdist to avoid spurious messages if user enables such checks from the command line using -gnaty. NF-27-IC17-020 Allow child library procedure as partition mains (2010-01-13) A child library procedure can now be used as the main subprogram of a partition (this was not previously supported). NF-27-IC17-019 Renamed PolyORB project files (2009-12-17) The project files distributed with PolyORB have been renamed to include a "polyorb_" prefix, to avoid clashes with user project files. NF-27-IB23-017 Embedded name server for DSA applications (2009-12-04) A small embedded name server can be optionally integrated in the main partition of a DSA application, to remove the requirement for a separate name server. This is achieved using pragma Name_Server (Embedded). Note that this currently also requires pragma Starter (Ada). NF-27-IA16-043 Use atomic builtins for reference counting (2009-11-13) Atomic increment and decrement operations are now used for reference counting within the PolyORB runtime, instead of mutex-protected counters, on platforms where such operations are supported by GCC. This affords improved performances when using tasking on these platforms. polyorb-2.8~20110207.orig/configure.ac0000644000175000017500000005565411750740337016715 0ustar xavierxavier# $Id: configure.ac 168980 2011-01-11 12:10:10Z quinot $ define(POLYORB_RELEASE, ifdef([OVERRIDE_RELEASE],OVERRIDE_RELEASE,[2.8.0w])) AC_PREREQ(2.57) AC_INIT(PolyORB, pkg_version(POLYORB_RELEASE), polyorb-bugs@lists.adacore.com) AC_CONFIG_SRCDIR(src/polyorb.ads) AC_CONFIG_AUX_DIR(support) AM_SUBVERSION POLYORB_VERSION="$PACKAGE_VERSION (rev. $SVNREVISION)" AC_SUBST(POLYORB_VERSION) AC_MSG_NOTICE([Configuring PolyORB $POLYORB_VERSION]) ifdef([LONGEST_FILE_NAME],[ if test ! -f ${srcdir}/LONGEST_FILE_NAME; then AC_MSG_ERROR([Source directory sanity check failed, check your distribution! Note that this package must be extracted with GNU tar.]) fi]) ########################################## # Initialization. ########################################## AC_CANONICAL_SYSTEM AM_INIT_AUTOMAKE # Disable Automake rules to rebuild Makefile.in and configure. # We handle this manually using support/reconfig. AM_MAINTAINER_MODE LIBVERSIONINFO=1:4:0 AC_SUBST(LIBVERSIONINFO) # Check for developer (debug) mode. # This must come before AC_PROG_CC so we can set the default CFLAGS ourselves. # Note that these default CFLAGS are used for both the native and the cross # compilers. define(DEBUG_OPTIONS, [dnl if test "${CFLAGS-unset}" = "unset"; then CFLAGS="-g -O0"; fi BASE_ADAFLAGS="-XBuild=DEBUG" BARGS=-E ASSERTION_POLICY_DEFAULT=Check DEBUG_POLICY_DEFAULT=Check DEBUG_ONLY="" INSTALL_BIN='${INSTALL_PROGRAM}' debug=true]) define(NODEBUG_OPTIONS, [dnl if test "${CFLAGS-unset}" = "unset"; then CFLAGS="-g -O2"; fi BASE_ADAFLAGS="-XBuild=PRODUCTION" BARGS= DEBUG_ONLY="-- " INSTALL_BIN='${]ifdef([STRIP_PRODUCTION_BINARIES], [INSTALL_STRIP_PROGRAM], [INSTALL_PROGRAM])[}' debug=false]) AC_ARG_ENABLE(debug, AS_HELP_STRING([--enable-debug], [Turn on debugging options]), [if [[ "$enableval" = "yes" ]]; then DEBUG_OPTIONS else NODEBUG_OPTIONS fi], [NODEBUG_OPTIONS]) # WARNINGS_MODE can be set to: # e (treat warnings as errors) # n (normal processing) # s (suppress all warnings) # Here we set WARNINGS_MODE to "e", unless another default has been set # in aclocal.m4 (see prepare_distrib). WARNINGS_MODE=ifdef([DEFAULT_WARNINGS_MODE],DEFAULT_WARNINGS_MODE,e) AC_ARG_ENABLE(warnings, AS_HELP_STRING([--enable-warnings=X], [Set warnings processing to X (e/n/s)]), [case "$enableval" in yes) WARNINGS_MODE=e ;; no) WARNINGS_MODE=s ;; [[ens]]) WARNINGS_MODE="$enableval" ;; *) AC_ERROR([invalid argument to --enable-warnings: $enableval]) ;; esac]) AC_SUBST(WARNINGS_MODE) AM_ARG_ENABLE_POLICY(assertion, Ignore) AM_ARG_ENABLE_POLICY(debug, Check) AC_SUBST(INSTALL_BIN) ####################################### # Additional configuration pragmas file ####################################### AC_ARG_ENABLE(conf-pragmas, AS_HELP_STRING([--enable-conf-pragmas=F], [Additional Ada configuration pragmas file for target]), [ if test -f "${enableval}"; then # Set switch that will be incorporated into ADAFLAGS_FOR_TARGET (for # configure's own purposes). ADDITIONAL_CONF_PRAGMAS_SWITCH="-gnatec=${enableval}" # Set substitution for project file ADDITIONAL_CONF_PRAGMAS="\"${ADDITIONAL_CONF_PRAGMAS_SWITCH}\"" else AC_ERROR([valid file name required for --enable-conf-pragmas]) fi ], [ADDITIONAL_CONF_PRAGAMS=""]) AC_SUBST(ADDITIONAL_CONF_PRAGMAS) ########################################## # Set platform-specific supplementary CFLAGS and options ########################################## # Host case "$host_os" in cygwin* | mingw*) HOST_EXE_SUFFIX=.exe WINDOWS_ON_HOST=True # Make sure every call to ln(1) fails, and falls back to cp(1), because # the compiler does not know how to handle Cygwin symbolic links. SYMLINK_ALIAS="alias ln=/bin/false" ;; *) HOST_EXE_SUFFIX= WINDOWS_ON_HOST=False ;; esac AC_SUBST(WINDOWS_ON_HOST) AM_CONDITIONAL(WINDOWS, test x$WINDOWS_ON_HOST = xTrue) # Target WINDOWS_ON_TARGET=False TARGET_EXE_SUFFIX= case $target_os in aix*) CFLAGS_FOR_TARGET="-mminimal-toc" ;; vxworks*) CFLAGS_FOR_TARGET="-mlongcall" TARGET_EXE_SUFFIX=.out PLATFORM_BASE_LIST="PolyORB.Parameters.Static" ;; cygwin* | mingw* ) WINDOWS_ON_TARGET=True TARGET_EXE_SUFFIX=.exe ;; esac ADAFLAGS_FOR_TARGET="${CFLAGS_FOR_TARGET} ${ADDITIONAL_CONF_PRAGMAS_SWITCH}" AC_SUBST(CFLAGS_FOR_TARGET) AC_SUBST(ADAFLAGS_FOR_TARGET) AC_SUBST(WINDOWS_ON_TARGET) # Implementation note: the *vxworks* rule above is for VxWorks 5, it can # present some problems for VxWorks 6. # Compilers are always built using the native Ada compiler. Therefore, # their executable suffix depends on the host operating system. COMPILER_EXE_SUFFIX=$HOST_EXE_SUFFIX AC_SUBST(COMPILER_EXE_SUFFIX) # Tools are using the cross Ada compiler. Therefore, their executable # suffix depends on the target operating system. TOOL_EXE_SUFFIX=$TARGET_EXE_SUFFIX AC_SUBST(TOOL_EXE_SUFFIX) # By default treat all warnings as errors when building directly from the # source repository. The packaging procedure changes the default to "n". # so that builds from packaged sources do not stop on warnings. BASE_ADAFLAGS="${BASE_ADAFLAGS} -XWarnings_Mode=${WARNINGS_MODE}" # ADAFLAGS will be set later, once AC_PROG_CC has set the definitive CFLAGS AC_SUBST(CFLAGS) AC_SUBST(ADAFLAGS) AC_SUBST(BARGS) AC_SUBST(DEBUG_ONLY) AM_CONDITIONAL(DEBUG, test x$debug = xtrue) ########################################## # Check for various programs ########################################## AC_PROG_CC if test "${ADAFLAGS-unset}" = unset; then ADAFLAGS="${CFLAGS} ${BASE_ADAFLAGS}" else ADAFLAGS="${ADAFLAGS} ${BASE_ADAFLAGS}" fi AC_PROG_INSTALL AC_PROG_AWK AC_CHECK_PROG(RM, rm, rm) AC_CHECK_PROG(SED, sed, sed) AC_CHECK_PROG(FIND, find, find) AC_CHECK_PROG(PYTHON, python, python) AC_CHECK_PROG(GREP, grep, grep) AM_PROG_GNATCHOP AM_PROG_ADA AM_CROSS_PROG_ADA AM_PROG_WORKING_ADA AM_CROSS_PROG_WORKING_ADA AM_PROG_GNATMAKE AM_CROSS_PROG_GNATMAKE AM_CROSS_PROG_CC AM_PROG_IDLCPP AM_PROG_XARGS_I ########################################## # Check Ada environment features ########################################## AM_HAS_GNAT_PERFECT_HASH_GENERATORS AM_HAS_PRAGMA_PROFILE_RAVENSCAR AM_HAS_PRAGMA_PROFILE_WARNINGS AM_HAS_PRAGMA_SUPPRESS_VALIDITY_CHECK AM_HAS_STYLESW_YG AM_HAS_INTRINSIC_SYNC_COUNTERS AM_HAS_ADA_DYNAMIC_PRIORITIES ########################################## # Check C environment features (for target) ########################################## save_CC="$CC" CC="$CC_FOR_TARGET" # Need to provide a non-empty 4th argument to AC_CHECK_HEADERS # so that a real compilation test is performed using CC, not a # junk preprocessor test that will use the host preprocessor # instead of the target compiler. # Mandatory features AC_CHECK_HEADERS([fcntl.h], [], [AC_ERROR([One or more required header file could not be found.])], [/*relax*/]) # Optional features AC_CHECK_FUNCS([setsid strftime]) CC="$save_CC" ########################################## # Check platform properties ########################################## AC_EXEEXT AM_ENABLE_SHARED(no) AM_ENABLE_STATIC(yes) ########################################## # Tools list: contains libraries that are # needed by some personnalities. ########################################## LIBS_LIST="" ########################################## # Protocol personalities list. ########################################## AC_MSG_CHECKING([default protocol personalities]) AC_ARG_WITH(proto-perso, AS_HELP_STRING([--with-proto-perso=X], [Enumerate protocol personalities]), [ PROTO_LIST="" newwithval=`echo ${withval} | tr "[A-Z]" "[a-z]"` for P in ${newwithval} do if ${FIND} ${srcdir}/src/${P} -name 'polyorb-binding_data-*.ads' > /dev/null; then PROTO_LIST="${PROTO_LIST}${P} " else AC_MSG_ERROR([unknown protocol personality ${P}]) fi done PROTO_LIST=`echo "$PROTO_LIST" | sed 's/ $//'` ], [ PROTO_LIST="giop" ]) AC_MSG_RESULT(${PROTO_LIST}) AC_SUBST(PROTO_LIST) ########################################## # Application personalities list ########################################## AC_MSG_CHECKING([default application personalities]) AC_ARG_WITH(appli-perso, AS_HELP_STRING([--with-appli-perso=X], [Enumerate application personalities]), [ APPLI_LIST="" newwithval=`echo ${withval} | tr "[A-Z]" "[a-z]"` for P in ${newwithval} do if test -d "${srcdir}/src/${P}" then APPLI_LIST="${APPLI_LIST}${P} " else AC_MSG_ERROR([unknown application personality ${P}]) fi done APPLI_LIST=`echo "$APPLI_LIST" | sed 's/ $//'` ], [ APPLI_LIST="corba" ]) AC_MSG_RESULT(${APPLI_LIST}) AC_SUBST(APPLI_LIST) ############################################ # Internal configuration of the IDL compiler ############################################ AC_ARG_WITH(idl-compiler, AS_HELP_STRING([--with-idl-compiler=X], [Select IDL compiler]), [ IDLAC=${withval} ], [ IDLAC=iac ]) AC_SUBST(IDLAC) AM_IDLCPP_NEEDS_DOT ########################################## # Services list. ########################################## AC_MSG_CHECKING([default services]) AC_ARG_WITH(corba-services, AS_HELP_STRING([--with-corba-services=X], [Enumerate services]), [ SERVICE_LIST="" newwithval=`echo ${withval} | tr "[A-Z]" "[a-z]"` for S in ${newwithval} do if test -d "${srcdir}/cos/${S}" then SERVICE_LIST="${SERVICE_LIST}${S} " else AC_MSG_ERROR([unknown service ${S}]) fi done SERVICE_LIST=`echo "$SERVICE_LIST" | sed 's/ $//'` ], [ SERVICE_LIST=" " ]) AC_MSG_RESULT(${SERVICE_LIST}) AC_SUBST(SERVICE_LIST) ########################################## # If the SOAP or the AWS personnality is # selected, then we have to add the # WEB_COMMON library ########################################## soap_enabled=`echo ${PROTO_LIST} | ${AWK} '/soap/ {print "yes"}'` aws_enabled=`echo ${APPLI_LIST} | ${AWK} '/aws/ {print "yes"}'` if test x"$soap_enabled" = xyes -o x"$aws_enabled" = xyes then AC_MSG_CHECKING([tools libraries]) LIBS_LIST="${LIBS_LIST} web_common" fi AC_MSG_RESULT(${LIBS_LIST}) AC_SUBST(LIBS_LIST) ########################################## # Update Makefiles' subdirectory lists ########################################## get_perso_prjs() { perso_name=$1 result= sep="" for gpr in ${srcdir}/projects/polyorb_src_${perso_name}*.gpr; do result="${result}${sep}\"`basename $gpr .gpr`\"" sep="," done echo $result } APPLI_DIRS="" APPLI_INCS="" APPLI_LIBS="" APPLI_EXES="\$(poly_exe) " APPLI_PRJS="" sep="" for P in ${APPLI_LIST} do APPLI_DIRS="${APPLI_DIRS} "'$'"(${P}_dir)" APPLI_INCS="${APPLI_INCS} "'$'"(${P}_inc)" APPLI_LIBS="${APPLI_LIBS} "'$'"(${P}_lib)" APPLI_EXES="${APPLI_EXES} "'$'"(${P}_exe)" APPLI_PRJS="${APPLI_PRJS}${sep}`get_perso_prjs ${P}`" sep="," done if test x"$APPLI_PRJS" = x then WITH_APPLI_PRJS="" else WITH_APPLI_PRJS="with $APPLI_PRJS;" fi AC_SUBST(APPLI_DIRS) AC_SUBST(APPLI_INCS) AC_SUBST(APPLI_LIBS) AC_SUBST(APPLI_EXES) AC_SUBST(APPLI_PRJS) AC_SUBST(WITH_APPLI_PRJS) PROTO_DIRS="" PROTO_INCS="" PROTO_LIBS="" PROTO_PRJS="" sep="" for P in ${PROTO_LIST} do PROTO_DIRS="${PROTO_DIRS} "'$'"(${P}_dir)" PROTO_INCS="${PROTO_INCS} "'$'"(${P}_inc)" PROTO_LIBS="${PROTO_LIBS} "'$'"(${P}_lib)" PROTO_PRJS="${PROTO_PRJS}${sep}`get_perso_prjs ${P}`" sep="," done if test x"$PROTO_PRJS" = x then WITH_PROTO_PRJS="" else WITH_PROTO_PRJS="with $PROTO_PRJS;" fi AC_SUBST(PROTO_DIRS) AC_SUBST(PROTO_INCS) AC_SUBST(PROTO_LIBS) AC_SUBST(PROTO_PRJS) AC_SUBST(WITH_PROTO_PRJS) SERVICE_DIRS="" SERVICE_INCS="" SERVICE_LIBS="" SERVICE_EXES="" SERVICE_PRJS="" sep="" for P in ${SERVICE_LIST} do SERVICE_DIRS="${SERVICE_DIRS} "'$'"(${P}_dir)" SERVICE_INCS="${SERVICE_INCS} "'$'"(${P}_inc)" SERVICE_LIBS="${SERVICE_LIBS} "'$'"(${P}_lib)" SERVICE_EXES="${SERVICE_EXES} "'$'"(${P}_exe)" if test "$P" != ir then SERVICE_PRJS="${SERVICE_PRJS}${sep}\"polyorb_idls_cos_${P}\"" sep="," fi done if test x"$SERVICE_PRJS" = x then WITH_SERVICE_PRJS="" else WITH_SERVICE_PRJS="with $SERVICE_PRJS;" fi AC_SUBST(SERVICE_DIRS) AC_SUBST(SERVICE_INCS) AC_SUBST(SERVICE_LIBS) AC_SUBST(SERVICE_EXES) AC_SUBST(SERVICE_PRJS) AC_SUBST(WITH_SERVICE_PRJS) LIBS_DIRS="" LIBS_INCS="" LIBS_LIBS="" LIBS_EXES="" for P in ${LIBS_LIST} do LIBS_DIRS="${LIBS_DIRS} "'$'"(${P}_dir)" LIBS_INCS="${LIBS_INCS} "'$'"(${P}_inc)" LIBS_LIBS="${LIBS_LIBS} "'$'"(${P}_lib)" LIBS_EXES="${LIBS_EXES} "'$'"(${P}_exe)" done AC_SUBST(LIBS_DIRS) AC_SUBST(LIBS_INCS) AC_SUBST(LIBS_LIBS) AC_SUBST(LIBS_EXES) ########################################## # gnatdist flags ########################################## PCSNAME="polyorb" AC_SUBST(PCSNAME) # # Remote shell command # AC_CHECK_PROGS(DEFAULT_RSH_CMD, [remsh rsh ssh], rsh) AC_MSG_CHECKING(for remote shell command to use) AC_ARG_WITH(rshcmd, AS_HELP_STRING([--with-rshcmd=command], [Set alternate remote shell command]), [RSH_CMD="${withval}"], [RSH_CMD="${DEFAULT_RSH_CMD}"]) AC_SUBST(RSH_CMD) AC_MSG_RESULT([${RSH_CMD}]) # # Remote shell flags # AC_MSG_CHECKING(for remote shell options to use) AC_ARG_WITH(rshopt, AS_HELP_STRING([--with-rshopt=command], [Set remote shell options]), [RSH_OPT="${withval}"], [RSH_OPT=""]) AC_SUBST(RSH_OPT) AC_MSG_RESULT([${RSH_OPT}]) # # Default storage location. # DEFSTORAGENAME="dsm" DEFSTORAGEDATA="" AC_SUBST(DEFSTORAGENAME) AC_SUBST(DEFSTORAGEDATA) DEFPROTOCOLNAME="tcp" DEFPROTOCOLDATA="" AC_SUBST(DEFPROTOCOLDATA) AC_SUBST(DEFPROTOCOLNAME) # # Check whether we remove support for RPC abortion # AC_ARG_ENABLE(rpc-abortion, AS_HELP_STRING([--enable-rpc-abortion], [Enable RPC abortion even when not supported]), [SUPPORT_RPC_ABORTION="True"], [SUPPORT_RPC_ABORTION="Default"]) AM_SUPPORT_RPC_ABORTION AC_MSG_CHECKING(whether we support RPC abortion) if test "$SUPPORT_RPC_ABORTION" = "True"; then AC_MSG_RESULT([yes]) else AC_MSG_RESULT([no]) fi AC_SUBST(SUPPORT_RPC_ABORTION) # # Check for exception model # AC_MSG_CHECKING(for exception model to use) AC_MSG_RESULT($EXCEPTION_MODEL) AC_SUBST(GNAT_RTS_FLAG) # # If ATC or dynamic priritoes are not supported, remove corresponding units. # Note: can't use a multi-line value for an AC_SUBST variable, this works only # with recent versions of autoconf (which use awk(1) for all substitutions). # Older versions that rely on sed(1) don't handle multi-line substitutions # correctly. # EXCLUDED_SOURCE_FILES=config.excluded_source_files if $HAVE_ADA_ATC; then : No excluded files else cat <<__EOF__ polyorb-tasking-profiles-full_tasking_atc.ads polyorb-tasking-profiles-full_tasking_atc-abortables.ads polyorb-tasking-profiles-full_tasking_atc-abortables.adb __EOF__ fi > ${EXCLUDED_SOURCE_FILES} if $HAVE_ADA_DYNAMIC_PRIORITIES; then : No excluded files else cat <<__EOF__ polyorb-tasking-profiles-full_tasking-threads-dynamic_priorities.ads polyorb-tasking-profiles-full_tasking-threads-dynamic_priorities.adb __EOF__ fi >> ${EXCLUDED_SOURCE_FILES} AC_SUBST_FILE(EXCLUDED_SOURCE_FILES) ########################################## # XML/Ada ########################################## dnl Projects-based build infrastructure: find XML/Ada project in project path soap_enabled=`echo ${PROTO_LIST} | ${AWK} '/soap/ {print "yes"}'` if test x"$soap_enabled" = xyes; then AC_MSG_CHECKING([for XML/Ada]) AM_HAS_GNAT_PROJECT([xmlada]) if test x"$HAVE_GNAT_PROJECT_xmlada" != xyes; then AC_MSG_ERROR(["Protocol personality SOAP requires XML/Ada"]) fi fi ########################################## # SSL/TLS Support with OpenSSL ########################################## AM_WITH_OPENSSL AM_CONDITIONAL(HAVE_SSL, [test "x$HAVE_SSL" = "xyes"]) ########################################## # Test : if a CORBA COS is built # then CORBA must be built ########################################## corba_enabled=`echo ${APPLI_LIST} | ${AWK} '/corba/{print "yes"}'` if test x"$SERVICE_LIST" != x" " -a x$corba_enabled != xyes then AC_MSG_ERROR("CORBA COS require CORBA application personality") fi ########################################## # Extra gnatmake parameters provided by the user ########################################## AC_SUBST(EXTRA_GNATMAKE_FLAGS) ########################################## # We change $host in order to force the generation of a libtool for the # target, and not for the host. # XXX if someone knows a clean way to do that, be my guest... ########################################## host_tmp=$host host=$target AM_PROG_LIBTOOL AC_LIBTOOL_HAS_TAG host=$host_tmp ################################################# # Build code fragments to be substituted in # src/setup/polyorb-setup-client_base.adb # src/setup/polyorb-setup-server.adb # tools/po_catref/po_catref_setup.adb # tools/po_createref/po_createref_setup.adb ################################################# PLATFORM_BASE_WITHS=config.platform_base_withs.adb PROTO_CLIENT_WITHS=config.proto_client_withs.adb PROTO_SERVER_WITHS=config.proto_server_withs.adb PO_CATREF_WITHS=config.po_catref_withs.adb PO_CREATEREF_WITHS=config.po_createref_withs.adb # Dependency files related to protocol personalities ALL_PROTO_WITHS=" ${PROTO_CLIENT_WITHS} ${PROTO_SERVER_WITHS} ${PO_CATREF_WITHS} ${PO_CREATEREF_WITHS}" # All generated dependency files ALL_WITHS=" ${PLATFORM_BASE_WITHS} ${ALL_PROTO_WITHS}" rm -f ${ALL_WITHS} if test -z "${PLATFORM_BASE_LIST}" then # Generate a comment line to avoid consecutive white lines # in the resulting file. cat >>${PLATFORM_BASE_WITHS} <>${PLATFORM_BASE_WITHS} <>${f} <>${PROTO_SERVER_WITHS} <>${PROTO_CLIENT_WITHS} <>${PROTO_CLIENT_WITHS} <>${PROTO_SERVER_WITHS} <>${PO_CATREF_WITHS} <>${PO_CREATEREF_WITHS} < ${F}.new mv ${F}.new ${F} fi done AC_SUBST_FILE(PLATFORM_BASE_WITHS) AC_SUBST_FILE(PROTO_CLIENT_WITHS) AC_SUBST_FILE(PROTO_SERVER_WITHS) AC_SUBST_FILE(PO_CATREF_WITHS) AC_SUBST_FILE(PO_CREATEREF_WITHS) ################################################# # Build code fragments to be substituted in # Makefile ################################################# LOCAL_MAKEFILES=config.local.makefiles (cd ${srcdir} && find . -name Makefile.local) | sed "s,^\./,," | \ while read mklocal; do testdir="`dirname ${mklocal}`/" echo "current_dir := ${testdir}" echo "test_target := ${testdir}build-test" echo "test_targets += ${testdir}build-test" echo "include \$(top_srcdir)/${mklocal}" done > ${LOCAL_MAKEFILES} AC_SUBST_FILE(LOCAL_MAKEFILES) # GNATDIST version # This is set differently for the GLADE and PolyORB distributions, which # share the same source tree. GNATDIST_VERSION="$POLYORB_VERSION" AC_SUBST(GNATDIST_VERSION) ########################################## # Output generated files ########################################## AC_CONFIG_HEADERS([src/config.h]) AC_CONFIG_LINKS([src/polyorb-smart_pointers-sync_counters.adb:src/polyorb-smart_pointers-sync_counters__$SYNC_COUNTERS_IMPL.adb]) AC_OUTPUT(FILTER_OUTPUT_FILES(OUTPUT_FILTER,[ Makefile Makefile.common.project compilers/common_files/platform.ads compilers/config.adc compilers/gnatdist/xe_defs-defaults.ads compilers/gnatprfh/gnatprfh.adb docs/Makefile docs/polyorb_version.texi projects/polyorb.gpr projects/polyorb_config.gpr projects/polyorb_src_setup.gpr projects-distrib/polyorb.gpr projects-distrib/polyorb/polyorb_src_setup.gpr src/config.adc src/src.exclude src/setup/polyorb-setup-base.adb src/setup/polyorb-setup-client_base.adb src/setup/polyorb-setup-server.adb src/setup/polyorb-setup-tasking-full_tasking.adb src/polyorb-platform.ads src/polyorb-platform-ssl_linker_options.ads src/ravenscar.adc src/ravenscar_compatible.adc contrib/idlac_wrapper/idlac_wrapper examples/corba/secure_echo/gssup.conf examples/corba/secure_echo/gssup_example examples/corba/secure_echo/tls.conf examples/corba/secure_echo/tls_example examples/corba/secure_echo/tls_gssup.conf examples/corba/secure_echo/tls_gssup_example tools/po_catref/po_catref_setup.adb tools/po_createref/po_createref_setup.adb support/adacompiler support/linker polyorb-config ]), [ ########################################## # Copy files ########################################## for a in support/linker support/adacompiler support/gentexifile \ support/move-if-change contrib/idlac_wrapper/idlac_wrapper \ examples/corba/secure_echo/gssup_example \ examples/corba/secure_echo/tls_example \ examples/corba/secure_echo/tls_gssup_example do echo "==> updating $a" if test ! -f $a; then ${RM} -f $a 2> /dev/null cp ${srcdir}/$a $a fi chmod a+x $a done chmod a+x polyorb-config for a in adacompiler linker; do na=support/native-$a echo "==> symlinking $na" # The following 'ln -s' command needs to happen in the support subdirectory, # so that we can replace it with 'cp' on machines where 'ln -s' doesn't work # (such as Windows). That is, 'ln -s $a support/native-$a' would work, but # 'cp $a support/native-$a' does not; hence the "cd support...". (cd support ; ${RM} -f native-$a ; ${LN_S} $a native-$a) done ], [ RM="${RM}" LN_S="${LN_S}" ${SYMLINK_ALIAS} ]) polyorb-2.8~20110207.orig/cos/0000755000175000017500000000000011750740340015166 5ustar xavierxavierpolyorb-2.8~20110207.orig/cos/event/0000755000175000017500000000000011750740340016307 5ustar xavierxavierpolyorb-2.8~20110207.orig/cos/event/costypedeventchanneladmin-typedproxypullsupplier-impl.adb0000644000175000017500000001626111750740337032076 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- COSTYPEDEVENTCHANNELADMIN.TYPEDPROXYPULLSUPPLIER.IMPL -- -- -- -- B o d y -- -- -- -- Copyright (C) 2003-2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with CosTypedEventChannelAdmin; with PolyORB.CORBA_P.Server_Tools; with PolyORB.Log; with PolyORB.Tasking.Mutexes; with PolyORB.Tasking.Semaphores; with CosTypedEventChannelAdmin.TypedProxyPullSupplier.Skel; pragma Warnings (Off, CosTypedEventChannelAdmin.TypedProxyPullSupplier.Skel); package body CosTypedEventChannelAdmin.TypedProxyPullSupplier.Impl is use CosEventComm; use CosEventChannelAdmin; use PolyORB.CORBA_P.Server_Tools; use PolyORB.Tasking.Mutexes; use PolyORB.Tasking.Semaphores; use PortableServer; use PolyORB.Log; package L is new PolyORB.Log.Facility_Log ("typedproxypullsupplier"); procedure O (Message : Standard.String; Level : Log_Level := Debug) renames L.Output; function C (Level : Log_Level := Debug) return Boolean renames L.Enabled; pragma Unreferenced (C); -- For conditional pragma Debug type TypedProxy_Pull_Supplier_Record is record This : Object_Ptr; Peer : PullConsumer.Ref; Admin : TypedConsumerAdmin.Impl.Object_Ptr; Semaphore : Semaphore_Access; supported_interface : CosTypedEventChannelAdmin.Key; end record; --------------------------- -- Ensure_Initialization -- --------------------------- procedure Ensure_Initialization; pragma Inline (Ensure_Initialization); -- Ensure that the Mutexes are initialized T_Initialized : Boolean := False; Self_Mutex : Mutex_Access; procedure Ensure_Initialization is begin if not T_Initialized then Create (Self_Mutex); T_Initialized := True; end if; end Ensure_Initialization; --------------------------- -- Connect_Pull_Consumer -- --------------------------- procedure Connect_Pull_Consumer (Self : access Object; Pull_Consumer : PullConsumer.Ref) is begin pragma Debug (O ("connect pull consumer to typed proxy pull supplier")); Ensure_Initialization; Enter (Self_Mutex); if not PullConsumer.Is_Nil (Self.X.Peer) then Leave (Self_Mutex); raise AlreadyConnected; end if; Self.X.Peer := Pull_Consumer; Leave (Self_Mutex); end Connect_Pull_Consumer; ------------ -- Create -- ------------ function Create (Admin : TypedConsumerAdmin.Impl.Object_Ptr; supported_interface : CosTypedEventChannelAdmin.Key) return Object_Ptr is Supplier : Object_Ptr; My_Ref : ProxyPullSupplier.Ref; begin pragma Debug (O ("create typedproxy pull supplier")); Supplier := new Object; Supplier.X := new TypedProxy_Pull_Supplier_Record; Supplier.X.This := Supplier; Supplier.X.Admin := Admin; Supplier.X.supported_interface := supported_interface; Create (Supplier.X.Semaphore); Initiate_Servant (Servant (Supplier), My_Ref); return Supplier; end Create; ------------------------------ -- Disconnect_Pull_Supplier -- ------------------------------ procedure Disconnect_Pull_Supplier (Self : access Object) is Peer : PullConsumer.Ref; Nil_Ref : PullConsumer.Ref; begin pragma Debug (O ("disconnect typedproxy pull supplier")); Ensure_Initialization; Enter (Self_Mutex); Peer := Self.X.Peer; Self.X.Peer := Nil_Ref; Leave (Self_Mutex); V (Self.X.Semaphore); if not PullConsumer.Is_Nil (Peer) then PullConsumer.disconnect_pull_consumer (Peer); end if; end Disconnect_Pull_Supplier; ------------------------ -- Get_Typed_Supplier -- ------------------------ function Get_Typed_Supplier (Self : access Object) return CORBA.Object.Ref is Ref : CORBA.Object.Ref; begin pragma Debug (O ("Get the mutually agreed Interface TypedPullSupplier")); Ensure_Initialization; Enter (Self_Mutex); Ref := TypedConsumerAdmin.Impl.Pull (Self.X.Admin, Self.X.supported_interface); Leave (Self_Mutex); return Ref; end Get_Typed_Supplier; ---------- -- Pull -- ---------- function Pull (Self : access Object) return CORBA.Any is pragma Unreferenced (Self); Event : CORBA.Any; begin pragma Debug (O ("attempt to pull new data from "& "typedproxypull supplier")); pragma Debug (O ("no need to use generic pull in typed pullsupplier")); Ensure_Initialization; -- No need to implement generic pull in Typed ProxyPullSupplier raise Program_Error; return Event; end Pull; -------------- -- Try_Pull -- -------------- procedure Try_Pull (Self : access Object; Has_Event : out CORBA.Boolean; Returns : out CORBA.Any) is pragma Unreferenced (Self); pragma Unreferenced (Has_Event); pragma Unreferenced (Returns); begin pragma Debug (O ("try to pull new data from typedproxypull supplier")); pragma Debug (O ("no need to use try_pull in typed pullsupplier")); Ensure_Initialization; -- No need to implement generic try_pull in Typed ProxyPullSupplier raise Program_Error; end Try_Pull; end CosTypedEventChannelAdmin.TypedProxyPullSupplier.Impl; polyorb-2.8~20110207.orig/cos/event/coseventchanneladmin-proxypushconsumer-impl.adb0000644000175000017500000001270411750740337027753 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- COSEVENTCHANNELADMIN.PROXYPUSHCONSUMER.IMPL -- -- -- -- B o d y -- -- -- -- Copyright (C) 2001-2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with CosEventComm; with CosEventComm.PushSupplier; with CosEventChannelAdmin; with PolyORB.CORBA_P.Server_Tools; with PolyORB.Log; with PolyORB.Tasking.Mutexes; with CosEventChannelAdmin.ProxyPushConsumer.Skel; pragma Warnings (Off, CosEventChannelAdmin.ProxyPushConsumer.Skel); package body CosEventChannelAdmin.ProxyPushConsumer.Impl is use PortableServer; use CosEventComm; use CosEventChannelAdmin; use PolyORB.CORBA_P.Server_Tools; use PolyORB.Tasking.Mutexes; use PolyORB.Log; package L is new PolyORB.Log.Facility_Log ("proxypushconsumer"); procedure O (Message : Standard.String; Level : Log_Level := Debug) renames L.Output; function C (Level : Log_Level := Debug) return Boolean renames L.Enabled; pragma Unreferenced (C); -- For conditional pragma Debug type Proxy_Push_Consumer_Record is record This : Object_Ptr; Peer : PushSupplier.Ref; Admin : SupplierAdmin.Impl.Object_Ptr; end record; --------------------------- -- Ensure_Initialization -- --------------------------- procedure Ensure_Initialization; pragma Inline (Ensure_Initialization); -- Ensure that the Mutexes are initialized T_Initialized : Boolean := False; Self_Mutex : Mutex_Access; procedure Ensure_Initialization is begin if not T_Initialized then Create (Self_Mutex); T_Initialized := True; end if; end Ensure_Initialization; --------------------------- -- Connect_Push_Supplier -- --------------------------- procedure Connect_Push_Supplier (Self : access Object; Push_Supplier : CosEventComm.PushSupplier.Ref) is begin pragma Debug (O ("connect push supplier to proxy push consumer")); Ensure_Initialization; Enter (Self_Mutex); if not PushSupplier.Is_Nil (Self.X.Peer) then Leave (Self_Mutex); raise AlreadyConnected; end if; Self.X.Peer := Push_Supplier; Leave (Self_Mutex); end Connect_Push_Supplier; ------------ -- Create -- ------------ function Create (Admin : SupplierAdmin.Impl.Object_Ptr) return Object_Ptr is Consumer : Object_Ptr; My_Ref : ProxyPushConsumer.Ref; begin pragma Debug (O ("create proxy push consumer")); Consumer := new Object; Consumer.X := new Proxy_Push_Consumer_Record; Consumer.X.This := Consumer; Consumer.X.Admin := Admin; Initiate_Servant (Servant (Consumer), My_Ref); return Consumer; end Create; ------------------------------ -- Disconnect_Push_Consumer -- ------------------------------ procedure Disconnect_Push_Consumer (Self : access Object) is Peer : PushSupplier.Ref; Nil_Ref : PushSupplier.Ref; begin pragma Debug (O ("disconnect proxy push consumer")); Ensure_Initialization; Enter (Self_Mutex); Peer := Self.X.Peer; Self.X.Peer := Nil_Ref; Leave (Self_Mutex); if not PushSupplier.Is_Nil (Peer) then PushSupplier.disconnect_push_supplier (Peer); end if; end Disconnect_Push_Consumer; ---------- -- Push -- ---------- procedure Push (Self : access Object; Data : CORBA.Any) is begin pragma Debug (O ("push new data from proxy push consumer to supplier admin")); SupplierAdmin.Impl.Post (Self.X.Admin, Data); end Push; end CosEventChannelAdmin.ProxyPushConsumer.Impl; polyorb-2.8~20110207.orig/cos/event/costypedeventcomm-typedpullsupplier-impl.ads0000644000175000017500000000711011750740337027320 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- COSTYPEDEVENTCOMM.TYPEDPULLSUPPLIER.IMPL -- -- -- -- S p e c -- -- -- -- Copyright (C) 2003 Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by ACT Europe. -- -- (email: sales@act-europe.fr) -- -- -- ------------------------------------------------------------------------------ with CORBA; with PortableServer; with CosTypedEventChannelAdmin; with CosTypedEventChannelAdmin.TypedEventChannel.Impl; package CosTypedEventComm.TypedPullSupplier.Impl is type Object is new PortableServer.Servant_Base with private; type Object_Ptr is access all Object'Class; -- IDL operations function Get_Typed_Supplier (Self : access Object) return CORBA.Object.Ref; -- Inherited IDL operations from CosEventComm::PullSupplier procedure Disconnect_Pull_Supplier (Self : access Object); -- Call by proxy to disconnect function Pull (Self : access Object) return CORBA.Any; -- Call by proxy to pull an event -- No need to implement it in this case procedure Try_Pull (Self : access Object; Has_Event : out CORBA.Boolean; Returns : out CORBA.Any); -- Call by proxy to try to pull an event -- No need to implement it in this case ------------------------ -- PolyORB specific -- ------------------------ function Create return Object_Ptr; -- Call by application to create an object and activate servant procedure SetInterface_Ptr (Self : access Object; I_Ptr : CosTypedEventChannelAdmin.TypedEventChannel.Impl.Interface_Ptr); -- Appopriately set the supported interface pointer private type Typed_Pull_Supplier_Record; type Typed_Pull_Supplier_Access is access Typed_Pull_Supplier_Record; type Object is new PortableServer.Servant_Base with record X : Typed_Pull_Supplier_Access; end record; end CosTypedEventComm.TypedPullSupplier.Impl; polyorb-2.8~20110207.orig/cos/event/costypedeventchanneladmin-typedconsumeradmin-impl.ads0000644000175000017500000001012111750740337031106 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- COSTYPEDEVENTCHANNELADMIN.TYPEDCONSUMERADMIN.IMPL -- -- -- -- S p e c -- -- -- -- Copyright (C) 2003-2008, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by ACT Europe. -- -- (email: sales@act-europe.fr) -- -- -- ------------------------------------------------------------------------------ with CORBA; with CORBA.Object; with CosEventChannelAdmin.ProxyPullSupplier; with CosEventChannelAdmin.ProxyPushSupplier; with CosTypedEventChannelAdmin; with CosTypedEventChannelAdmin.TypedEventChannel.Impl; with PortableServer; package CosTypedEventChannelAdmin.TypedConsumerAdmin.Impl is type Object is new PortableServer.Servant_Base with private; type Object_Ptr is access all Object'Class; -- IDL operations function obtain_typed_pull_supplier (Self : access Object; supported_interface : CosTypedEventChannelAdmin.Key) return TypedProxyPullSupplier.Ref; function obtain_typed_push_supplier (Self : access Object; uses_interface : CosTypedEventChannelAdmin.Key) return CosEventChannelAdmin.ProxyPushSupplier.Ref; -- Inherited IDL Operations from -- CosEventchannelAdmin::ConsumerAdmin function Obtain_Push_Supplier (Self : access Object) return CosEventChannelAdmin.ProxyPushSupplier.Ref; -- Return ProxyPushSupplier -- No need to implement it in this case function Obtain_Pull_Supplier (Self : access Object) return CosEventChannelAdmin.ProxyPullSupplier.Ref; -- Return ProxyPullSupplier -- No need to implement it in this case ---------------------- -- PolyORB specific -- ---------------------- function Post (Self : access Object; uses_interface : CosTypedEventChannelAdmin.Key) return CORBA.Object.Ref; -- Get mutually agreed interface from Typed PushConsumers function Pull (Self : access Object; uses_interface : CosTypedEventChannelAdmin.Key) return CORBA.Object.Ref; -- Get mutually agreed interface from Typed PullSuppliers function Create (Channel : CosTypedEventChannelAdmin.TypedEventChannel.Impl.Object_Ptr) return Object_Ptr; private type TypedConsumer_Admin_Record; type TypedConsumer_Admin_Access is access all TypedConsumer_Admin_Record; type Object is new PortableServer.Servant_Base with record X : TypedConsumer_Admin_Access; end record; end CosTypedEventChannelAdmin.TypedConsumerAdmin.Impl; polyorb-2.8~20110207.orig/cos/event/coseventchanneladmin-proxypushsupplier-impl.adb0000644000175000017500000001450011750740337027757 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- COSEVENTCHANNELADMIN.PROXYPUSHSUPPLIER.IMPL -- -- -- -- B o d y -- -- -- -- Copyright (C) 2001-2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with CORBA.Impl; with CosEventComm.PushConsumer; with CosTypedEventComm.TypedPushConsumer; with CosTypedEventComm.TypedPushConsumer.Impl; with PolyORB.CORBA_P.Server_Tools; with PolyORB.Log; with PolyORB.Tasking.Mutexes; with CosEventChannelAdmin.ProxyPushSupplier.Skel; pragma Warnings (Off, CosEventChannelAdmin.ProxyPushSupplier.Skel); package body CosEventChannelAdmin.ProxyPushSupplier.Impl is use CosEventComm; use CosEventChannelAdmin; use CosTypedEventComm; use PortableServer; use PolyORB.CORBA_P.Server_Tools; use PolyORB.Tasking.Mutexes; use PolyORB.Log; package L is new PolyORB.Log.Facility_Log ("proxypushsupplier"); procedure O (Message : Standard.String; Level : Log_Level := Debug) renames L.Output; function C (Level : Log_Level := Debug) return Boolean renames L.Enabled; pragma Unreferenced (C); -- For conditional pragma Debug type Proxy_Push_Supplier_Record is record This : Object_Ptr; Peer : PushConsumer.Ref; Admin : ConsumerAdmin.Ref; end record; --------------------------- -- Ensure_Initialization -- --------------------------- procedure Ensure_Initialization; pragma Inline (Ensure_Initialization); -- Ensure that the Mutexes are initialized T_Initialized : Boolean := False; Self_Mutex : Mutex_Access; procedure Ensure_Initialization is begin if not T_Initialized then Create (Self_Mutex); T_Initialized := True; end if; end Ensure_Initialization; --------------------------- -- Connect_Push_Consumer -- --------------------------- procedure Connect_Push_Consumer (Self : access Object; Push_Consumer : CosEventComm.PushConsumer.Ref) is begin pragma Debug (O ("connect push consumer to proxy push supplier")); Ensure_Initialization; Enter (Self_Mutex); if not PushConsumer.Is_Nil (Self.X.Peer) then Leave (Self_Mutex); raise AlreadyConnected; end if; Self.X.Peer := Push_Consumer; Leave (Self_Mutex); end Connect_Push_Consumer; ------------ -- Create -- ------------ function Create (Admin : ConsumerAdmin.Ref) return Object_Ptr is Supplier : ProxyPushSupplier.Impl.Object_Ptr; My_Ref : ProxyPushSupplier.Ref; begin pragma Debug (O ("create proxy push supplier")); Supplier := new Object; Supplier.X := new Proxy_Push_Supplier_Record; Supplier.X.This := Supplier; Supplier.X.Admin := Admin; Initiate_Servant (Servant (Supplier), My_Ref); return Supplier; end Create; ------------------------------ -- Disconnect_Push_Supplier -- ------------------------------ procedure Disconnect_Push_Supplier (Self : access Object) is Peer : PushConsumer.Ref; Nil_Ref : PushConsumer.Ref; begin pragma Debug (O ("disconnect proxy push supplier")); Ensure_Initialization; Enter (Self_Mutex); Peer := Self.X.Peer; Self.X.Peer := Nil_Ref; Leave (Self_Mutex); if PushConsumer.Is_Nil (Peer) then PushConsumer.disconnect_push_consumer (Peer); end if; end Disconnect_Push_Supplier; ---------- -- Post -- ---------- procedure Post (Self : access Object; Data : CORBA.Any) is begin pragma Debug (O ("post new data from proxy push supplier to push consumer")); begin PushConsumer.push (Self.X.Peer, Data); exception when others => pragma Debug (O ("Got exception in Post")); raise; end; end Post; ---------- -- Post -- ---------- function Post (Self : access Object) return CORBA.Object.Ref is Ref : CORBA.Object.Ref; Obj : CORBA.Impl.Object_Ptr; begin pragma Debug (O ("calling get_typed_consumer from" & " proxy pushsupplier to typed push consumer")); begin Reference_To_Servant (Self.X.Peer, Servant (Obj)); Ref := TypedPushConsumer.Impl.Get_Typed_Consumer (TypedPushConsumer.Impl.Object_Ptr (Obj)); exception when others => pragma Debug (O ("Got exception in Post")); raise; end; return Ref; end Post; end CosEventChannelAdmin.ProxyPushSupplier.Impl; polyorb-2.8~20110207.orig/cos/event/coseventchanneladmin-proxypullconsumer-impl.ads0000644000175000017500000000625511750740337027775 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- COSEVENTCHANNELADMIN.PROXYPULLCONSUMER.IMPL -- -- -- -- S p e c -- -- -- -- Copyright (C) 2001-2008, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by ACT Europe. -- -- (email: sales@act-europe.fr) -- -- -- ------------------------------------------------------------------------------ with CORBA.Object; with CosEventChannelAdmin.SupplierAdmin; with PortableServer; package CosEventChannelAdmin.ProxyPullConsumer.Impl is type Object is new PortableServer.Servant_Base with private; type Object_Ptr is access all Object'Class; ----------------------- -- ProxyPullConsumer -- ----------------------- procedure Connect_Pull_Supplier (Self : access Object; Pull_Supplier : CosEventComm.PullSupplier.Ref); ------------------ -- PullConsumer -- ------------------ procedure Disconnect_Pull_Consumer (Self : access Object); ---------------------- -- PolyORB specific -- ---------------------- function Create (Admin : CosEventChannelAdmin.SupplierAdmin.Ref) return Object_Ptr; function Pull (Self : access Object) return CORBA.Object.Ref; -- Get mutually agreed interface from Typed PullSuppliers private type Proxy_Pull_Consumer_Record; type Proxy_Pull_Consumer_Access is access all Proxy_Pull_Consumer_Record; type Object is new PortableServer.Servant_Base with record X : Proxy_Pull_Consumer_Access; end record; end CosEventChannelAdmin.ProxyPullConsumer.Impl; polyorb-2.8~20110207.orig/cos/event/coseventcomm-pushconsumer-impl.adb0000644000175000017500000001610011750740337025155 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- C O S E V E N T C O M M . P U S H C O N S U M E R . I M P L -- -- -- -- B o d y -- -- -- -- Copyright (C) 2001-2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with CosEventChannelAdmin; with PolyORB.CORBA_P.Server_Tools; with PolyORB.Log; with PolyORB.Tasking.Mutexes; with PolyORB.Tasking.Semaphores; with CosEventComm.PushConsumer.Skel; pragma Warnings (Off, CosEventComm.PushConsumer.Skel); package body CosEventComm.PushConsumer.Impl is use PortableServer; use CosEventChannelAdmin; use PolyORB.CORBA_P.Server_Tools; use PolyORB.Tasking.Mutexes; use PolyORB.Tasking.Semaphores; use PolyORB.Log; package L is new PolyORB.Log.Facility_Log ("pushconsumer"); procedure O (Message : Standard.String; Level : Log_Level := Debug) renames L.Output; function C (Level : Log_Level := Debug) return Boolean renames L.Enabled; pragma Unreferenced (C); -- For conditional pragma Debug type Push_Consumer_Record is record This : Object_Ptr; Peer : ProxyPushSupplier.Ref; Empty : Boolean; Event : CORBA.Any; Semaphore : Semaphore_Access; end record; --------------------------- -- Ensure_Initialization -- --------------------------- procedure Ensure_Initialization; pragma Inline (Ensure_Initialization); -- Ensure that the Mutexes are initialized T_Initialized : Boolean := False; Self_Mutex : Mutex_Access; procedure Ensure_Initialization is begin if not T_Initialized then Create (Self_Mutex); T_Initialized := True; end if; end Ensure_Initialization; --------------------------------- -- Connect_Proxy_Push_Supplier -- --------------------------------- procedure Connect_Proxy_Push_Supplier (Self : access Object; Proxy : CosEventChannelAdmin.ProxyPushSupplier.Ref) is My_Ref : PushConsumer.Ref; begin pragma Debug (O ("connect proxy push consumer to push supplier")); Ensure_Initialization; Enter (Self_Mutex); if not ProxyPushSupplier.Is_Nil (Self.X.Peer) then Leave (Self_Mutex); raise AlreadyConnected; end if; Self.X.Peer := Proxy; Leave (Self_Mutex); Servant_To_Reference (Servant (Self.X.This), My_Ref); ProxyPushSupplier.connect_push_consumer (Proxy, My_Ref); end Connect_Proxy_Push_Supplier; ------------ -- Create -- ------------ function Create return Object_Ptr is Consumer : Object_Ptr; My_Ref : PushConsumer.Ref; begin pragma Debug (O ("create push consumer")); Consumer := new Object; Consumer.X := new Push_Consumer_Record; Consumer.X.This := Consumer; Consumer.X.Empty := True; Create (Consumer.X.Semaphore); Initiate_Servant (Servant (Consumer), My_Ref); return Consumer; end Create; ------------------------------ -- Disconnect_Push_Consumer -- ------------------------------ procedure Disconnect_Push_Consumer (Self : access Object) is Peer : ProxyPushSupplier.Ref; Nil_Ref : ProxyPushSupplier.Ref; begin pragma Debug (O ("disconnect push consumer")); Ensure_Initialization; Enter (Self_Mutex); Peer := Self.X.Peer; Self.X.Peer := Nil_Ref; Leave (Self_Mutex); V (Self.X.Semaphore); if not ProxyPushSupplier.Is_Nil (Peer) then ProxyPushSupplier.disconnect_push_supplier (Peer); end if; end Disconnect_Push_Consumer; ---------- -- Pull -- ---------- function Pull (Self : access Object) return CORBA.Any is Event : CORBA.Any; begin Ensure_Initialization; loop pragma Debug (O ("attempt to pull new data from push consumer")); P (Self.X.Semaphore); Enter (Self_Mutex); if ProxyPushSupplier.Is_Nil (Self.X.Peer) then Leave (Self_Mutex); raise Disconnected; end if; if not Self.X.Empty then Self.X.Empty := True; Event := Self.X.Event; Leave (Self_Mutex); exit; end if; Leave (Self_Mutex); end loop; pragma Debug (O ("succeed to pull new data from push consumer")); return Event; end Pull; ---------- -- Push -- ---------- procedure Push (Self : access Object; Data : CORBA.Any) is begin pragma Debug (O ("push new data to push consumer")); Ensure_Initialization; Enter (Self_Mutex); Self.X.Empty := False; Self.X.Event := Data; Leave (Self_Mutex); V (Self.X.Semaphore); end Push; -------------- -- Try_Pull -- -------------- procedure Try_Pull (Self : access Object; Done : out CORBA.Boolean; Data : out CORBA.Any) is begin pragma Debug (O ("try to pull new data from push consumer")); Ensure_Initialization; Enter (Self_Mutex); if ProxyPushSupplier.Is_Nil (Self.X.Peer) then Leave (Self_Mutex); raise Disconnected; end if; Done := not Self.X.Empty; if Done then Self.X.Empty := True; Data := Self.X.Event; end if; Leave (Self_Mutex); end Try_Pull; end CosEventComm.PushConsumer.Impl; polyorb-2.8~20110207.orig/cos/event/costypedeventcomm-typedpullsupplier-impl.adb0000644000175000017500000001600511750740337027302 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- COSTYPEDEVENTCOMM.TYPEDPULLSUPPLIER.IMPL -- -- -- -- B o d y -- -- -- -- Copyright (C) 2003-2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with CORBA.Impl; with CosEventChannelAdmin.ProxyPullConsumer; with CosTypedEventChannelAdmin.TypedEventChannel; with PolyORB.CORBA_P.Server_Tools; with PolyORB.Log; with PolyORB.Tasking.Semaphores; with PolyORB.Tasking.Mutexes; with CosTypedEventComm.TypedPullSupplier.Skel; pragma Warnings (Off, CosTypedEventComm.TypedPullSupplier.Skel); package body CosTypedEventComm.TypedPullSupplier.Impl is use CosEventChannelAdmin; use CosTypedEventChannelAdmin; use PortableServer; use PolyORB.CORBA_P.Server_Tools; use PolyORB.Tasking.Semaphores; use PolyORB.Tasking.Mutexes; use PolyORB.Log; package L is new PolyORB.Log.Facility_Log ("typedpullsupplier"); procedure O (Message : Standard.String; Level : Log_Level := Debug) renames L.Output; function C (Level : Log_Level := Debug) return Boolean renames L.Enabled; pragma Unreferenced (C); -- For conditional pragma Debug type Typed_Pull_Supplier_Record is record This : Object_Ptr; Peer : ProxyPullConsumer.Ref; Empty : Boolean; Event : CORBA.Any; Semaphore : Semaphore_Access; Supports_Interface : TypedEventChannel.Impl.Interface_Ptr; end record; --------------------------- -- Ensure_Initialization -- --------------------------- procedure Ensure_Initialization; pragma Inline (Ensure_Initialization); -- Ensure that the Mutexes are initialized T_Initialized : Boolean := False; Self_Mutex : Mutex_Access; procedure Ensure_Initialization is begin if not T_Initialized then Create (Self_Mutex); T_Initialized := True; end if; end Ensure_Initialization; ------------ -- Create -- ------------ function Create return Object_Ptr is Supplier : Object_Ptr; My_Ref : TypedPullSupplier.Ref; begin pragma Debug (O ("Create typedpull supplier")); Supplier := new Object; Supplier.X := new Typed_Pull_Supplier_Record; Supplier.X.This := Supplier; Supplier.X.Empty := True; Create (Supplier.X.Semaphore); Initiate_Servant (Servant (Supplier), My_Ref); return Supplier; end Create; ---------------------- -- SetInterface_Ptr -- ---------------------- procedure SetInterface_Ptr (Self : access Object; I_Ptr : TypedEventChannel.Impl.Interface_Ptr) is begin pragma Debug (O ("set the supported interface pointer in " & "typed pullsupplier")); Ensure_Initialization; Enter (Self_Mutex); Self.X.Supports_Interface := I_Ptr; Leave (Self_Mutex); end SetInterface_Ptr; ------------------------ -- Get_Typed_Supplier -- ------------------------ function Get_Typed_Supplier (Self : access Object) return CORBA.Object.Ref is InterfaceObject : CORBA.Impl.Object_Ptr; Ref : CORBA.Object.Ref; begin pragma Debug (O ("get the mutually agreed interface from " & "typed pullsupplier")); Ensure_Initialization; Enter (Self_Mutex); InterfaceObject := Self.X.Supports_Interface.all; Leave (Self_Mutex); Initiate_Servant (PortableServer.Servant (InterfaceObject), Ref); return Ref; end Get_Typed_Supplier; ---------- -- Pull -- ---------- function Pull (Self : access Object) return CORBA.Any is pragma Unreferenced (Self); Event : CORBA.Any; begin pragma Debug (O ("attempt to pull new data from typed pullsupplier")); pragma Debug (O ("no need to use generic pull in typed pullsupplier")); Ensure_Initialization; -- No need to implement generic pull in Typed PullSupplier raise Program_Error; return Event; end Pull; -------------- -- Try_Pull -- -------------- procedure Try_Pull (Self : access Object; Has_Event : out CORBA.Boolean; Returns : out CORBA.Any) is pragma Unreferenced (Self); pragma Unreferenced (Has_Event); pragma Unreferenced (Returns); begin pragma Debug (O ("try to pull new data from typed pullsupplier")); pragma Debug (O ("No need to use try_pull in typed pullsupplier")); Ensure_Initialization; -- No need to implement generic try_pull in Typed PullSupplier raise Program_Error; end Try_Pull; ------------------------------ -- Disconnect_Pull_Supplier -- ------------------------------ procedure Disconnect_Pull_Supplier (Self : access Object) is Peer : ProxyPullConsumer.Ref; Nil_Ref : ProxyPullConsumer.Ref; begin pragma Debug (O ("disconnect typedpull supplier")); Ensure_Initialization; Enter (Self_Mutex); Peer := Self.X.Peer; Self.X.Peer := Nil_Ref; Leave (Self_Mutex); V (Self.X.Semaphore); if not ProxyPullConsumer.Is_Nil (Peer) then ProxyPullConsumer.disconnect_pull_consumer (Peer); end if; end Disconnect_Pull_Supplier; end CosTypedEventComm.TypedPullSupplier.Impl; polyorb-2.8~20110207.orig/cos/event/coseventchanneladmin-supplieradmin-impl.adb0000644000175000017500000001366311750740337026777 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- COSEVENTCHANNELADMIN.SUPPLIERADMIN.IMPL -- -- -- -- B o d y -- -- -- -- Copyright (C) 2001-2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with CORBA.Sequences.Unbounded; with CosEventChannelAdmin.ProxyPullConsumer.Impl; with CosEventChannelAdmin.ProxyPushConsumer.Impl; with PolyORB.CORBA_P.Server_Tools; with PolyORB.Log; with PolyORB.Tasking.Mutexes; with CosEventChannelAdmin.SupplierAdmin.Skel; pragma Warnings (Off, CosEventChannelAdmin.SupplierAdmin.Skel); package body CosEventChannelAdmin.SupplierAdmin.Impl is use CosEventChannelAdmin; use PortableServer; use PolyORB.CORBA_P.Server_Tools; use PolyORB.Tasking.Mutexes; use PolyORB.Log; package L is new PolyORB.Log.Facility_Log ("supplieradmin"); procedure O (Message : Standard.String; Level : Log_Level := Debug) renames L.Output; function C (Level : Log_Level := Debug) return Boolean renames L.Enabled; pragma Unreferenced (C); -- For conditional pragma Debug package PullConsumers is new CORBA.Sequences.Unbounded (ProxyPullConsumer.Impl.Object_Ptr); package PushConsumers is new CORBA.Sequences.Unbounded (ProxyPushConsumer.Impl.Object_Ptr); type Supplier_Admin_Record is record This : Object_Ptr; ThisRef : SupplierAdmin.Ref; Channel : EventChannel.Impl.Object_Ptr; Pushs : PushConsumers.Sequence; Pulls : PullConsumers.Sequence; end record; --------------------------- -- Ensure_Initialization -- --------------------------- procedure Ensure_Initialization; pragma Inline (Ensure_Initialization); -- Ensure that the Mutexes are initialized T_Initialized : Boolean := False; Self_Mutex : Mutex_Access; procedure Ensure_Initialization is begin if not T_Initialized then Create (Self_Mutex); T_Initialized := True; end if; end Ensure_Initialization; ------------ -- Create -- ------------ function Create (Channel : EventChannel.Impl.Object_Ptr) return Object_Ptr is Supplier : Object_Ptr; My_Ref : SupplierAdmin.Ref; begin pragma Debug (O ("create supplier admin")); Supplier := new Object; Supplier.X := new Supplier_Admin_Record; Supplier.X.This := Supplier; Supplier.X.Channel := Channel; Initiate_Servant (Servant (Supplier), My_Ref); Supplier.X.ThisRef := My_Ref; return Supplier; end Create; -------------------------- -- Obtain_Pull_Consumer -- -------------------------- function Obtain_Pull_Consumer (Self : access Object) return CosEventChannelAdmin.ProxyPullConsumer.Ref is Consumer : ProxyPullConsumer.Impl.Object_Ptr; Its_Ref : ProxyPullConsumer.Ref; begin pragma Debug (O ("obtain proxy pull consumer from supplier admin")); Ensure_Initialization; Enter (Self_Mutex); Consumer := ProxyPullConsumer.Impl.Create (Self.X.ThisRef); PullConsumers.Append (Self.X.Pulls, Consumer); Leave (Self_Mutex); Servant_To_Reference (Servant (Consumer), Its_Ref); return Its_Ref; end Obtain_Pull_Consumer; -------------------------- -- Obtain_Push_Consumer -- -------------------------- function Obtain_Push_Consumer (Self : access Object) return ProxyPushConsumer.Ref is Consumer : ProxyPushConsumer.Impl.Object_Ptr; Its_Ref : ProxyPushConsumer.Ref; begin pragma Debug (O ("obtain proxy push consumer from supplier admin")); Ensure_Initialization; Enter (Self_Mutex); Consumer := ProxyPushConsumer.Impl.Create (Self.X.This); PushConsumers.Append (Self.X.Pushs, Consumer); Leave (Self_Mutex); Servant_To_Reference (Servant (Consumer), Its_Ref); return Its_Ref; end Obtain_Push_Consumer; ---------- -- Post -- ---------- procedure Post (Self : access Object; Data : CORBA.Any) is begin pragma Debug (O ("post new data from supplier admin to channel")); EventChannel.Impl.Post (Self.X.Channel, Data); end Post; end CosEventChannelAdmin.SupplierAdmin.Impl; polyorb-2.8~20110207.orig/cos/event/costypedeventchanneladmin-typedeventchannel-impl.ads0000644000175000017500000000747311750740337030734 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- COSTYPEDEVENTCHANNELADMIN.TYPEDEVENTCHANNEL.IMPL -- -- -- -- S p e c -- -- -- -- Copyright (C) 2003-2008, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by ACT Europe. -- -- (email: sales@act-europe.fr) -- -- -- ------------------------------------------------------------------------------ with CORBA; with CORBA.Impl; with CORBA.Object; with CosTypedEventChannelAdmin.TypedSupplierAdmin; with CosTypedEventChannelAdmin.TypedConsumerAdmin; with PortableServer; package CosTypedEventChannelAdmin.TypedEventChannel.Impl is type Object is new PortableServer.Servant_Base with private; type Object_Ptr is access all Object'Class; function For_Consumers (Self : access Object) return CosTypedEventChannelAdmin.TypedConsumerAdmin.Ref; function For_Suppliers (Self : access Object) return CosTypedEventChannelAdmin.TypedSupplierAdmin.Ref; procedure Destroy (Self : access Object); ---------------------- -- PolyORB specific -- ---------------------- function Create return Object_Ptr; function Post (Self : access Object; uses_interface : CosTypedEventChannelAdmin.Key) return CORBA.Object.Ref; -- Get mutually agreed interface from Typed PushConsumers function Pull (Self : access Object; uses_interface : CosTypedEventChannelAdmin.Key) return CORBA.Object.Ref; -- Get mutually agreed interface from Typed PullSuppliers type Interface_Ptr is access function return CORBA.Impl.Object_Ptr; procedure Register (RepositoryID : CosTypedEventChannelAdmin.Key; Create_Ptr : Interface_Ptr); -- Register a couple of Repository ID and -- Pointer_to_Create function in a HashTable function Lookup (RepositoryID : CosTypedEventChannelAdmin.Key) return Interface_Ptr; -- Lookup an entry in the HashTable private type TypedEvent_Channel_Record; type TypedEvent_Channel_Access is access TypedEvent_Channel_Record; type Object is new PortableServer.Servant_Base with record X : TypedEvent_Channel_Access; end record; end CosTypedEventChannelAdmin.TypedEventChannel.Impl; polyorb-2.8~20110207.orig/cos/event/coseventcomm-pushsupplier-impl.ads0000644000175000017500000000576411750740337025224 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- C O S E V E N T C O M M . P U S H S U P P L I E R . I M P L -- -- -- -- S p e c -- -- -- -- Copyright (C) 2001-2008, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by ACT Europe. -- -- (email: sales@act-europe.fr) -- -- -- ------------------------------------------------------------------------------ with CORBA; with PortableServer; with CosEventChannelAdmin.ProxyPushConsumer; package CosEventComm.PushSupplier.Impl is -- This implementation is supposed to be application -- dependent. This is an example used to test the event service. type Object is new PortableServer.Servant_Base with private; type Object_Ptr is access all Object'Class; procedure disconnect_push_supplier (Self : access Object); ------------------------ -- AdaBroker specific -- ------------------------ procedure Connect_Proxy_Push_Consumer (Self : access Object; Proxy : CosEventChannelAdmin.ProxyPushConsumer.Ref); function Create return Object_Ptr; procedure Push (Self : access Object; Data : CORBA.Any); private type Push_Supplier_Record; type Push_Supplier_Access is access Push_Supplier_Record; type Object is new PortableServer.Servant_Base with record X : Push_Supplier_Access; end record; end CosEventComm.PushSupplier.Impl; polyorb-2.8~20110207.orig/cos/event/costypedeventchanneladmin-typedconsumeradmin-impl.adb0000644000175000017500000002252211750740337031075 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- COSTYPEDEVENTCHANNELADMIN.TYPEDCONSUMERADMIN.IMPL -- -- -- -- B o d y -- -- -- -- Copyright (C) 2003-2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with CosEventChannelAdmin; with CosEventChannelAdmin.ConsumerAdmin.Helper; with CosEventChannelAdmin.ProxyPushSupplier.Impl; with CosTypedEventChannelAdmin.TypedEventChannel; with CosTypedEventChannelAdmin.TypedProxyPullSupplier; with CosTypedEventChannelAdmin.TypedProxyPullSupplier.Impl; with PolyORB.CORBA_P.Server_Tools; with PolyORB.Dynamic_Dict; with PolyORB.Log; with PolyORB.Tasking.Mutexes; with CosTypedEventChannelAdmin.TypedConsumerAdmin.Skel; pragma Warnings (Off, CosTypedEventChannelAdmin.TypedConsumerAdmin.Skel); package body CosTypedEventChannelAdmin.TypedConsumerAdmin.Impl is use CosEventChannelAdmin; use CosEventChannelAdmin.ProxyPushSupplier.Impl; use CosTypedEventChannelAdmin.TypedEventChannel.Impl; use PortableServer; use PolyORB.CORBA_P.Server_Tools; use PolyORB.Tasking.Mutexes; use PolyORB.Log; package L is new PolyORB.Log.Facility_Log ("typedconsumeradmin"); procedure O (Message : Standard.String; Level : Log_Level := Debug) renames L.Output; function C (Level : Log_Level := Debug) return Boolean renames L.Enabled; pragma Unreferenced (C); -- For conditional pragma Debug package ProxyPushSuppliersTable is new PolyORB.Dynamic_Dict (ProxyPushSupplier.Impl.Object_Ptr); type TypedConsumer_Admin_Record is record This : Object_Ptr; ThisRef : TypedConsumerAdmin.Ref; Channel : TypedEventChannel.Impl.Object_Ptr; end record; --------------------------- -- Ensure_Initialization -- --------------------------- procedure Ensure_Initialization; pragma Inline (Ensure_Initialization); -- Ensure that the Mutexes are initialized. T_Initialized : Boolean := False; Self_Mutex : Mutex_Access; procedure Ensure_Initialization is begin if not T_Initialized then Create (Self_Mutex); T_Initialized := True; end if; end Ensure_Initialization; ------------ -- Create -- ------------ function Create (Channel : TypedEventChannel.Impl.Object_Ptr) return Object_Ptr is Consumer : Object_Ptr; My_Ref : TypedConsumerAdmin.Ref; begin pragma Debug (O ("create typedconsumer admin")); Consumer := new Object; Consumer.X := new TypedConsumer_Admin_Record; Consumer.X.This := Consumer; Consumer.X.Channel := Channel; Initiate_Servant (Servant (Consumer), My_Ref); Consumer.X.ThisRef := My_Ref; return Consumer; end Create; -------------------------------- -- Obtain_Typed_Pull_Supplier -- -------------------------------- function obtain_typed_pull_supplier (Self : access Object; supported_interface : CosTypedEventChannelAdmin.Key) return TypedProxyPullSupplier.Ref is Supplier : TypedProxyPullSupplier.Impl.Object_Ptr; Its_Ref : TypedProxyPullSupplier.Ref; MyCreate_Ptr : TypedEventChannel.Impl.Interface_Ptr; begin pragma Debug (O ("obtain typed proxypullsupplier from " & "typed consumeradmin")); Ensure_Initialization; Enter (Self_Mutex); MyCreate_Ptr := TypedEventChannel.Impl.Lookup (supported_interface); if MyCreate_Ptr = null then raise InterfaceNotSupported; end if; Supplier := TypedProxyPullSupplier.Impl.Create (Self.X.This, supported_interface); Leave (Self_Mutex); Servant_To_Reference (Servant (Supplier), Its_Ref); return Its_Ref; end obtain_typed_pull_supplier; -------------------------------- -- Obtain_Typed_Push_Supplier -- -------------------------------- function obtain_typed_push_supplier (Self : access Object; uses_interface : CosTypedEventChannelAdmin.Key) return ProxyPushSupplier.Ref is Supplier : ProxyPushSupplier.Impl.Object_Ptr; Its_Ref : ProxyPushSupplier.Ref; MyCreate_Ptr : TypedEventChannel.Impl.Interface_Ptr; MyRef : ConsumerAdmin.Ref; begin pragma Debug (O ("obtain proxypush supplier from " & "typed consumeradmin")); Ensure_Initialization; Enter (Self_Mutex); MyCreate_Ptr := TypedEventChannel.Impl.Lookup (uses_interface); if MyCreate_Ptr = null then raise InterfaceNotSupported; end if; MyRef := ConsumerAdmin.Helper.To_Ref (Self.X.ThisRef); Supplier := ProxyPushSupplier.Impl.Create (MyRef); ProxyPushSuppliersTable.Register (To_String (uses_interface), Supplier); Leave (Self_Mutex); Servant_To_Reference (Servant (Supplier), Its_Ref); return Its_Ref; end obtain_typed_push_supplier; -------------------------- -- Obtain_Pull_Supplier -- -------------------------- function Obtain_Pull_Supplier (Self : access Object) return ProxyPullSupplier.Ref is pragma Unreferenced (Self); Its_Ref : ProxyPullSupplier.Ref; begin pragma Debug (O ("obtain proxy pull supplier from typed consumeradmin")); pragma Debug (O ("no need to get generic proxy pullsupplier "& "from typed consumeradmin")); Ensure_Initialization; -- No need to implement generic Obtain_Pull_Supplier in -- Typed ConsumerAdmin raise Program_Error; return Its_Ref; end Obtain_Pull_Supplier; -------------------------- -- Obtain_Push_Supplier -- -------------------------- function Obtain_Push_Supplier (Self : access Object) return ProxyPushSupplier.Ref is pragma Unreferenced (Self); Its_Ref : ProxyPushSupplier.Ref; begin pragma Debug (O ("obtain proxy push supplier from typed consumeradmin")); pragma Debug (O ("no need to get generic proxy pushsupplier "& "from typed consumeradmin")); Ensure_Initialization; -- No need to implement generic Obtain_Push_Supplier in -- Typed ConsumerAdmin raise Program_Error; return Its_Ref; end Obtain_Push_Supplier; ---------- -- Post -- ---------- function Post (Self : access Object; uses_interface : CosTypedEventChannelAdmin.Key) return CORBA.Object.Ref is pragma Unreferenced (Self); Ref : CORBA.Object.Ref; MyProxyPushSupplier : ProxyPushSupplier.Impl.Object_Ptr; begin Ensure_Initialization; pragma Debug (O ("push mutually agreed interface from " & "typed consumeradmin to proxy pushsupplier")); Enter (Self_Mutex); MyProxyPushSupplier := ProxyPushSuppliersTable.Lookup (To_String (uses_interface), null); if MyProxyPushSupplier = null then raise InterfaceNotSupported; end if; Leave (Self_Mutex); Ref := ProxyPushSupplier.Impl.Post (MyProxyPushSupplier); return Ref; end Post; ---------- -- Pull -- ---------- function Pull (Self : access Object; uses_interface : CosTypedEventChannelAdmin.Key) return CORBA.Object.Ref is Ref : CORBA.Object.Ref; begin Ensure_Initialization; Enter (Self_Mutex); pragma Debug (O ("pull mutually agreed interface from " & "typed consumeradmin to typed eventchannel")); Ref := TypedEventChannel.Impl.Pull (Self.X.Channel, uses_interface); Leave (Self_Mutex); return Ref; end Pull; end CosTypedEventChannelAdmin.TypedConsumerAdmin.Impl; polyorb-2.8~20110207.orig/cos/event/costypedeventchanneladmin-typedeventchannel-impl.adb0000644000175000017500000001462311750740337030706 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- COSTYPEDEVENTCHANNELADMIN.TYPEDEVENTCHANNEL.IMPL -- -- -- -- B o d y -- -- -- -- Copyright (C) 2003-2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with CosTypedEventChannelAdmin.TypedEventChannel; with CosTypedEventChannelAdmin.TypedSupplierAdmin.Impl; with CosTypedEventChannelAdmin.TypedConsumerAdmin.Impl; with PolyORB.CORBA_P.Server_Tools; with PolyORB.Dynamic_Dict; with PolyORB.Log; with CosTypedEventChannelAdmin.TypedEventChannel.Skel; pragma Warnings (Off, CosTypedEventChannelAdmin.TypedEventChannel.Skel); package body CosTypedEventChannelAdmin.TypedEventChannel.Impl is use PortableServer; use PolyORB.CORBA_P.Server_Tools; use PolyORB.Log; package L is new PolyORB.Log.Facility_Log ("typedeventchannel"); procedure O (Message : Standard.String; Level : Log_Level := Debug) renames L.Output; function C (Level : Log_Level := Debug) return Boolean renames L.Enabled; pragma Unreferenced (C); -- For conditional pragma Debug package InterfaceTable is new PolyORB.Dynamic_Dict (Interface_Ptr); type TypedEvent_Channel_Record is record This : Object_Ptr; Consumer : TypedConsumerAdmin.Impl.Object_Ptr; Supplier : TypedSupplierAdmin.Impl.Object_Ptr; end record; ------------ -- Create -- ------------ function Create return Object_Ptr is Channel : Object_Ptr; My_Ref : TypedEventChannel.Ref; begin pragma Debug (O ("create typed eventchannel")); Channel := new Object; Channel.X := new TypedEvent_Channel_Record; Channel.X.This := Channel; Channel.X.Consumer := TypedConsumerAdmin.Impl.Create (Channel); Channel.X.Supplier := TypedSupplierAdmin.Impl.Create (Channel); Initiate_Servant (Servant (Channel), My_Ref); return Channel; end Create; ------------- -- Destroy -- ------------- procedure Destroy (Self : access Object) is pragma Unreferenced (Self); begin null; end Destroy; ------------------- -- For_Consumers -- ------------------- function For_Consumers (Self : access Object) return TypedConsumerAdmin.Ref is R : TypedConsumerAdmin.Ref; begin pragma Debug (O ("create typedconsumer admin for typedchannel")); Servant_To_Reference (Servant (Self.X.Consumer), R); return R; end For_Consumers; ------------------- -- For_Suppliers -- ------------------- function For_Suppliers (Self : access Object) return CosTypedEventChannelAdmin.TypedSupplierAdmin.Ref is R : TypedSupplierAdmin.Ref; begin pragma Debug (O ("create typedsupplier admin for typedchannel")); Servant_To_Reference (Servant (Self.X.Supplier), R); return R; end For_Suppliers; ---------- -- Post -- ---------- function Post (Self : access Object; uses_interface : CosTypedEventChannelAdmin.Key) return CORBA.Object.Ref is Ref : CORBA.Object.Ref; begin pragma Debug (O ("Push Mutually Agreed Interface from "& "TypedEventChannel to TypedConsumerAdmin")); Ref := TypedConsumerAdmin.Impl.Post (Self.X.Consumer, uses_interface); return Ref; end Post; ---------- -- Pull -- ---------- function Pull (Self : access Object; uses_interface : CosTypedEventChannelAdmin.Key) return CORBA.Object.Ref is Ref : CORBA.Object.Ref; begin pragma Debug (O ("Pull Mutually Agreed Interface from "& "TypedEventChannel to TypedSupplierAdmin")); Ref := TypedSupplierAdmin.Impl.Pull (Self.X.Supplier, uses_interface); return Ref; end Pull; -------------- -- Register -- -------------- procedure Register (RepositoryID : CosTypedEventChannelAdmin.Key; Create_Ptr : Interface_Ptr) is begin pragma Debug (O ("register a mutually agreed interface in "& "typed eventchannel interfacetable")); InterfaceTable.Register (To_String (RepositoryID), Create_Ptr); end Register; ------------ -- Lookup -- ------------ function Lookup (RepositoryID : CosTypedEventChannelAdmin.Key) return Interface_Ptr is Create_Ptr : Interface_Ptr; begin pragma Debug (O ("attempt to retreive a mutually agreed interface "& "from typed eventchannel interfacetable")); Create_Ptr := InterfaceTable.Lookup (To_String (RepositoryID), null); return Create_Ptr; end Lookup; end CosTypedEventChannelAdmin.TypedEventChannel.Impl; polyorb-2.8~20110207.orig/cos/event/coseventchanneladmin-eventchannel-impl.adb0000644000175000017500000001113211750740337026562 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- COSEVENTCHANNELADMIN.EVENTCHANNEL.IMPL -- -- -- -- B o d y -- -- -- -- Copyright (C) 2001-2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with CosEventChannelAdmin.SupplierAdmin.Impl; with CosEventChannelAdmin.ConsumerAdmin.Impl; with CosEventChannelAdmin.EventChannel; with PolyORB.CORBA_P.Server_Tools; with PolyORB.Log; with CosEventChannelAdmin.EventChannel.Skel; pragma Warnings (Off, CosEventChannelAdmin.EventChannel.Skel); package body CosEventChannelAdmin.EventChannel.Impl is use PortableServer; use PolyORB.CORBA_P.Server_Tools; use PolyORB.Log; package L is new PolyORB.Log.Facility_Log ("eventchannel"); procedure O (Message : Standard.String; Level : Log_Level := Debug) renames L.Output; function C (Level : Log_Level := Debug) return Boolean renames L.Enabled; pragma Unreferenced (C); -- For conditional pragma Debug type Event_Channel_Record is record This : Object_Ptr; Consumer : ConsumerAdmin.Impl.Object_Ptr; Supplier : SupplierAdmin.Impl.Object_Ptr; end record; ------------ -- Create -- ------------ function Create return Object_Ptr is Channel : Object_Ptr; My_Ref : EventChannel.Ref; begin pragma Debug (O ("create channel")); Channel := new Object; Channel.X := new Event_Channel_Record; Channel.X.This := Channel; Channel.X.Consumer := ConsumerAdmin.Impl.Create (Channel); Channel.X.Supplier := SupplierAdmin.Impl.Create (Channel); Initiate_Servant (Servant (Channel), My_Ref); return Channel; end Create; ------------- -- Destroy -- ------------- procedure Destroy (Self : access Object) is pragma Unreferenced (Self); begin null; end Destroy; ------------------- -- For_Consumers -- ------------------- function For_Consumers (Self : access Object) return ConsumerAdmin.Ref is R : ConsumerAdmin.Ref; begin pragma Debug (O ("create consumer admin for channel")); Servant_To_Reference (Servant (Self.X.Consumer), R); return R; end For_Consumers; ------------------- -- For_Suppliers -- ------------------- function For_Suppliers (Self : access Object) return CosEventChannelAdmin.SupplierAdmin.Ref is R : SupplierAdmin.Ref; begin pragma Debug (O ("create supplier for channel")); Servant_To_Reference (Servant (Self.X.Supplier), R); return R; end For_Suppliers; ---------- -- Post -- ---------- procedure Post (Self : access Object; Data : CORBA.Any) is begin ConsumerAdmin.Impl.Post (Self.X.Consumer, Data); end Post; end CosEventChannelAdmin.EventChannel.Impl; polyorb-2.8~20110207.orig/cos/event/coseventcomm-pushconsumer-impl.ads0000644000175000017500000000672411750740337025211 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- C O S E V E N T C O M M . P U S H C O N S U M E R . I M P L -- -- -- -- S p e c -- -- -- -- Copyright (C) 2001-2008, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by ACT Europe. -- -- (email: sales@act-europe.fr) -- -- -- ------------------------------------------------------------------------------ with CORBA; with PortableServer; with CosEventChannelAdmin.ProxyPushSupplier; package CosEventComm.PushConsumer.Impl is -- This implementation is supposed to be application -- dependent. This is an example used to test the event service. type Object is new PortableServer.Servant_Base with private; type Object_Ptr is access all Object'Class; procedure Push (Self : access Object; Data : CORBA.Any); -- Call by proxy to push an event procedure Disconnect_Push_Consumer (Self : access Object); -- Call by proxy to disconnect ------------------------ -- AdaBroker specific -- ------------------------ procedure Connect_Proxy_Push_Supplier (Self : access Object; Proxy : CosEventChannelAdmin.ProxyPushSupplier.Ref); -- Call by application to connect object with proxy function Create return Object_Ptr; -- Call by application to create an object and activate servant function Pull (Self : access Object) return CORBA.Any; -- Call by application to consume an event procedure Try_Pull (Self : access Object; Done : out CORBA.Boolean; Data : out CORBA.Any); -- Call by application to try to consume an event private type Push_Consumer_Record; type Push_Consumer_Access is access Push_Consumer_Record; type Object is new PortableServer.Servant_Base with record X : Push_Consumer_Access; end record; end CosEventComm.PushConsumer.Impl; polyorb-2.8~20110207.orig/cos/event/coseventcomm-pullconsumer-impl.adb0000644000175000017500000001413611750740337025161 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- C O S E V E N T C O M M . P U L L C O N S U M E R . I M P L -- -- -- -- B o d y -- -- -- -- Copyright (C) 2001-2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with CosEventChannelAdmin; with PolyORB.CORBA_P.Server_Tools; with PolyORB.Tasking.Mutexes; with PolyORB.Log; with CosEventComm.PullConsumer.Skel; pragma Warnings (Off, CosEventComm.PullConsumer.Skel); package body CosEventComm.PullConsumer.Impl is use CosEventChannelAdmin; use PortableServer; use PolyORB.CORBA_P.Server_Tools; use PolyORB.Tasking.Mutexes; use PolyORB.Log; package L is new PolyORB.Log.Facility_Log ("pullconsumer"); procedure O (Message : Standard.String; Level : Log_Level := Debug) renames L.Output; function C (Level : Log_Level := Debug) return Boolean renames L.Enabled; pragma Unreferenced (C); -- For conditional pragma Debug type Pull_Consumer_Record is record This : Object_Ptr; Peer : ProxyPullSupplier.Ref; end record; --------------------------- -- Ensure_Initialization -- --------------------------- procedure Ensure_Initialization; pragma Inline (Ensure_Initialization); -- Ensure that the Mutexes are initialized T_Initialized : Boolean := False; Self_Mutex : Mutex_Access; procedure Ensure_Initialization is begin if not T_Initialized then Create (Self_Mutex); T_Initialized := True; end if; end Ensure_Initialization; --------------------------------- -- Connect_Proxy_Pull_Supplier -- --------------------------------- procedure Connect_Proxy_Pull_Supplier (Self : access Object; Proxy : ProxyPullSupplier.Ref) is My_Ref : PullConsumer.Ref; begin pragma Debug (O ("connect proxy pull consumer to pull supplier")); Ensure_Initialization; Enter (Self_Mutex); if not ProxyPullSupplier.Is_Nil (Self.X.Peer) then Leave (Self_Mutex); raise AlreadyConnected; end if; Self.X.Peer := Proxy; Leave (Self_Mutex); Servant_To_Reference (Servant (Self.X.This), My_Ref); ProxyPullSupplier.connect_pull_consumer (Proxy, My_Ref); end Connect_Proxy_Pull_Supplier; ------------ -- Create -- ------------ function Create return Object_Ptr is Consumer : Object_Ptr; My_Ref : PullConsumer.Ref; begin pragma Debug (O ("create pull consumer")); Consumer := new Object; Consumer.X := new Pull_Consumer_Record; Consumer.X.This := Consumer; Initiate_Servant (Servant (Consumer), My_Ref); return Consumer; end Create; ------------------------------ -- Disconnect_Pull_Consumer -- ------------------------------ procedure Disconnect_Pull_Consumer (Self : access Object) is Peer : ProxyPullSupplier.Ref; Nil_Ref : ProxyPullSupplier.Ref; begin pragma Debug (O ("disconnect pull consumer")); Ensure_Initialization; Enter (Self_Mutex); Peer := Self.X.Peer; Self.X.Peer := Nil_Ref; Leave (Self_Mutex); if not ProxyPullSupplier.Is_Nil (Peer) then ProxyPullSupplier.disconnect_pull_supplier (Peer); end if; end Disconnect_Pull_Consumer; ---------- -- Pull -- ---------- function Pull (Self : access Object) return CORBA.Any is Peer : ProxyPullSupplier.Ref; begin pragma Debug (O ("pull new data from pull consumer")); Ensure_Initialization; Enter (Self_Mutex); Peer := Self.X.Peer; Leave (Self_Mutex); if ProxyPullSupplier.Is_Nil (Peer) then raise Disconnected; end if; return ProxyPullSupplier.pull (Peer); end Pull; -------------- -- Try_Pull -- -------------- procedure Try_Pull (Self : access Object; Done : out CORBA.Boolean; Returns : out CORBA.Any) is Peer : ProxyPullSupplier.Ref; begin pragma Debug (O ("try to pull new data from pull consumer")); Ensure_Initialization; Enter (Self_Mutex); Peer := Self.X.Peer; Leave (Self_Mutex); if ProxyPullSupplier.Is_Nil (Peer) then raise Disconnected; end if; ProxyPullSupplier.try_pull (Peer, Done, Returns); end Try_Pull; end CosEventComm.PullConsumer.Impl; polyorb-2.8~20110207.orig/cos/event/costypedeventcomm-typedpushconsumer-impl.adb0000644000175000017500000001464211750740337027302 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- COSTYPEDEVENTCOMM.TYPEDPUSHCONSUMER.IMPL -- -- -- -- B o d y -- -- -- -- Copyright (C) 2003-2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with CORBA.Impl; with CosEventChannelAdmin; with CosEventChannelAdmin.ProxyPushSupplier; with CosEventComm.PushConsumer.Skel; with CosTypedEventChannelAdmin.TypedEventChannel; with PolyORB.CORBA_P.Server_Tools; with PolyORB.Log; with PolyORB.Tasking.Mutexes; with PolyORB.Tasking.Semaphores; with CosTypedEventComm.TypedPushConsumer.Skel; pragma Warnings (Off, CosTypedEventComm.TypedPushConsumer.Skel); package body CosTypedEventComm.TypedPushConsumer.Impl is use CosEventChannelAdmin; use CosTypedEventChannelAdmin; use PortableServer; use PolyORB.CORBA_P.Server_Tools; use PolyORB.Tasking.Mutexes; use PolyORB.Tasking.Semaphores; use PolyORB.Log; package L is new PolyORB.Log.Facility_Log ("typedpushconsumer"); procedure O (Message : Standard.String; Level : Log_Level := Debug) renames L.Output; function C (Level : Log_Level := Debug) return Boolean renames L.Enabled; pragma Unreferenced (C); -- For conditional pragma Debug type Typed_Push_Consumer_Record is record This : Object_Ptr; Peer : ProxyPushSupplier.Ref; Empty : Boolean; Event : CORBA.Any; Semaphore : Semaphore_Access; Uses_Interface : TypedEventChannel.Impl.Interface_Ptr; end record; --------------------------- -- Ensure_Initialization -- --------------------------- procedure Ensure_Initialization; pragma Inline (Ensure_Initialization); -- Ensure that the Mutexes are initialized T_Initialized : Boolean := False; Self_Mutex : Mutex_Access; procedure Ensure_Initialization is begin if not T_Initialized then Create (Self_Mutex); T_Initialized := True; end if; end Ensure_Initialization; ------------------------ -- Get_Typed_Consumer -- ------------------------ function Get_Typed_Consumer (Self : access Object) return CORBA.Object.Ref is InterfaceObject : CORBA.Impl.Object_Ptr; Ref : CORBA.Object.Ref; begin pragma Debug (O ("get the mutually agreed Interface from" & "TypedPushConsumer")); Ensure_Initialization; Enter (Self_Mutex); InterfaceObject := Self.X.Uses_Interface.all; Leave (Self_Mutex); Initiate_Servant (PortableServer.Servant (InterfaceObject), Ref); return Ref; end Get_Typed_Consumer; ---------- -- Push -- ---------- procedure Push (Self : access Object; Data : CORBA.Any) is pragma Unreferenced (Self, Data); begin pragma Debug (O ("trying to push new data to Typed PushConsumer")); pragma Debug (O ("no need to use generic push in Typed PushConsumer")); Ensure_Initialization; -- No need to implement push in TypedPushConsumer raise Program_Error; end Push; ------------------------------ -- Disconnect_Push_Consumer -- ------------------------------ procedure Disconnect_Push_Consumer (Self : access Object) is Peer : ProxyPushSupplier.Ref; Nil_Ref : ProxyPushSupplier.Ref; begin pragma Debug (O ("disconnect typedpush consumer")); Ensure_Initialization; Enter (Self_Mutex); Peer := Self.X.Peer; Self.X.Peer := Nil_Ref; Leave (Self_Mutex); V (Self.X.Semaphore); if not ProxyPushSupplier.Is_Nil (Peer) then ProxyPushSupplier.disconnect_push_supplier (Peer); end if; end Disconnect_Push_Consumer; ------------ -- Create -- ------------ function Create return Object_Ptr is Consumer : Object_Ptr; My_Ref : TypedPushConsumer.Ref; begin pragma Debug (O ("create typedpushconsumer")); Consumer := new Object; Consumer.X := new Typed_Push_Consumer_Record; Consumer.X.This := Consumer; Consumer.X.Empty := True; Create (Consumer.X.Semaphore); Initiate_Servant (Servant (Consumer), My_Ref); return Consumer; end Create; ---------------------- -- SetInterface_Ptr -- ---------------------- procedure SetInterface_Ptr (Self : access Object; I_Ptr : TypedEventChannel.Impl.Interface_Ptr) is begin pragma Debug (O ("set the supported interface pointer in" & "typedpushconsumer")); Ensure_Initialization; Enter (Self_Mutex); Self.X.Uses_Interface := I_Ptr; Leave (Self_Mutex); end SetInterface_Ptr; end CosTypedEventComm.TypedPushConsumer.Impl; polyorb-2.8~20110207.orig/cos/event/coseventchanneladmin-proxypushsupplier-impl.ads0000644000175000017500000000616011750740337030003 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- COSEVENTCHANNELADMIN.PROXYPUSHSUPPLIER.IMPL -- -- -- -- S p e c -- -- -- -- Copyright (C) 2001-2008, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by ACT Europe. -- -- (email: sales@act-europe.fr) -- -- -- ------------------------------------------------------------------------------ with CORBA; with CORBA.Object; with PortableServer; with CosEventChannelAdmin.ConsumerAdmin; package CosEventChannelAdmin.ProxyPushSupplier.Impl is type Object is new PortableServer.Servant_Base with private; type Object_Ptr is access all Object'Class; procedure Connect_Push_Consumer (Self : access Object; Push_Consumer : CosEventComm.PushConsumer.Ref); procedure Disconnect_Push_Supplier (Self : access Object); ---------------------- -- PolyORB specific -- ---------------------- procedure Post (Self : access Object; Data : CORBA.Any); function Post (Self : access Object) return CORBA.Object.Ref; -- Get mutually agreed interface from Typed PushConsumers function Create (Admin : CosEventChannelAdmin.ConsumerAdmin.Ref) return Object_Ptr; private type Proxy_Push_Supplier_Record; type Proxy_Push_Supplier_Access is access Proxy_Push_Supplier_Record; type Object is new PortableServer.Servant_Base with record X : Proxy_Push_Supplier_Access; end record; end CosEventChannelAdmin.ProxyPushSupplier.Impl; polyorb-2.8~20110207.orig/cos/event/coseventcomm-pullconsumer-impl.ads0000644000175000017500000000653511750740337025206 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- C O S E V E N T C O M M . P U L L C O N S U M E R . I M P L -- -- -- -- S p e c -- -- -- -- Copyright (C) 2001-2008, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by ACT Europe. -- -- (email: sales@act-europe.fr) -- -- -- ------------------------------------------------------------------------------ with PortableServer; with CosEventChannelAdmin.ProxyPullSupplier; package CosEventComm.PullConsumer.Impl is -- This implementation is supposed to be application -- dependent. This is an example used to test the event service. type Object is new PortableServer.Servant_Base with private; type Object_Ptr is access all Object'Class; procedure Disconnect_Pull_Consumer (Self : access Object); -- Call by proxy to disconnect ------------------------ -- AdaBroker specific -- ------------------------ procedure Connect_Proxy_Pull_Supplier (Self : access Object; Proxy : CosEventChannelAdmin.ProxyPullSupplier.Ref); -- Call by application to connect object with proxy function Create return Object_Ptr; -- Call by application to create an object and activate servant function Pull (Self : access Object) return CORBA.Any; -- Call by application to consume an event procedure Try_Pull (Self : access Object; Done : out CORBA.Boolean; Returns : out CORBA.Any); -- Call by application to try to consume an event private type Pull_Consumer_Record; type Pull_Consumer_Access is access Pull_Consumer_Record; type Object is new PortableServer.Servant_Base with record X : Pull_Consumer_Access; end record; end CosEventComm.PullConsumer.Impl; polyorb-2.8~20110207.orig/cos/event/coseventcomm-pushsupplier-impl.adb0000644000175000017500000001306511750740337025174 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- C O S E V E N T C O M M . P U S H S U P P L I E R . I M P L -- -- -- -- B o d y -- -- -- -- Copyright (C) 2001-2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with CosEventChannelAdmin; with PolyORB.CORBA_P.Server_Tools; with PolyORB.Log; with PolyORB.Tasking.Mutexes; with CosEventComm.PushSupplier.Skel; pragma Warnings (Off, CosEventComm.PushSupplier.Skel); package body CosEventComm.PushSupplier.Impl is use CosEventChannelAdmin; use PortableServer; use PolyORB.CORBA_P.Server_Tools; use PolyORB.Tasking.Mutexes; use PolyORB.Log; package L is new PolyORB.Log.Facility_Log ("pushsupplier"); procedure O (Message : Standard.String; Level : Log_Level := Debug) renames L.Output; function C (Level : Log_Level := Debug) return Boolean renames L.Enabled; pragma Unreferenced (C); -- For conditional pragma Debug type Push_Supplier_Record is record This : Object_Ptr; Peer : ProxyPushConsumer.Ref; end record; --------------------------- -- Ensure_Initialization -- --------------------------- procedure Ensure_Initialization; pragma Inline (Ensure_Initialization); -- Ensure that the Mutexes are initialized T_Initialized : Boolean := False; Self_Mutex : Mutex_Access; procedure Ensure_Initialization is begin if not T_Initialized then Create (Self_Mutex); T_Initialized := True; end if; end Ensure_Initialization; --------------------------------- -- Connect_Proxy_Push_Consumer -- --------------------------------- procedure Connect_Proxy_Push_Consumer (Self : access Object; Proxy : CosEventChannelAdmin.ProxyPushConsumer.Ref) is My_Ref : PushSupplier.Ref; begin pragma Debug (O ("connect proxy push supplier to push consumer")); Ensure_Initialization; Enter (Self_Mutex); if not ProxyPushConsumer.Is_Nil (Self.X.Peer) then Leave (Self_Mutex); raise AlreadyConnected; end if; Self.X.Peer := Proxy; Leave (Self_Mutex); Servant_To_Reference (Servant (Self.X.This), My_Ref); ProxyPushConsumer.connect_push_supplier (Proxy, My_Ref); end Connect_Proxy_Push_Consumer; ------------ -- Create -- ------------ function Create return Object_Ptr is Supplier : Object_Ptr; My_Ref : PushSupplier.Ref; begin pragma Debug (O ("create push supplier")); Supplier := new Object; Supplier.X := new Push_Supplier_Record; Supplier.X.This := Supplier; Initiate_Servant (Servant (Supplier), My_Ref); return Supplier; end Create; ------------------------------ -- Disconnect_Push_Supplier -- ------------------------------ procedure disconnect_push_supplier (Self : access Object) is Peer : ProxyPushConsumer.Ref; Nil_Ref : ProxyPushConsumer.Ref; begin pragma Debug (O ("disconnect push supplier")); Ensure_Initialization; Enter (Self_Mutex); Peer := Self.X.Peer; Self.X.Peer := Nil_Ref; Leave (Self_Mutex); if not ProxyPushConsumer.Is_Nil (Peer) then ProxyPushConsumer.disconnect_push_consumer (Peer); end if; end disconnect_push_supplier; ---------- -- Push -- ---------- procedure Push (Self : access Object; Data : CORBA.Any) is Peer : ProxyPushConsumer.Ref; begin pragma Debug (O ("push new data to push supplier")); Ensure_Initialization; Enter (Self_Mutex); Peer := Self.X.Peer; Leave (Self_Mutex); if ProxyPushConsumer.Is_Nil (Peer) then raise Disconnected; end if; ProxyPushConsumer.push (Peer, Data); end Push; end CosEventComm.PushSupplier.Impl; polyorb-2.8~20110207.orig/cos/event/coseventchanneladmin-proxypushconsumer-impl.ads0000644000175000017500000000574311750740337030001 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- COSEVENTCHANNELADMIN.PROXYPUSHCONSUMER.IMPL -- -- -- -- S p e c -- -- -- -- Copyright (C) 2001-2008, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by ACT Europe. -- -- (email: sales@act-europe.fr) -- -- -- ------------------------------------------------------------------------------ with PortableServer; with CosEventChannelAdmin.SupplierAdmin.Impl; package CosEventChannelAdmin.ProxyPushConsumer.Impl is type Object is new PortableServer.Servant_Base with private; type Object_Ptr is access all Object'Class; procedure Connect_Push_Supplier (Self : access Object; Push_Supplier : CosEventComm.PushSupplier.Ref); procedure Push (Self : access Object; Data : CORBA.Any); procedure Disconnect_Push_Consumer (Self : access Object); ------------------------ -- AdaBroker specific -- ------------------------ function Create (Admin : CosEventChannelAdmin.SupplierAdmin.Impl.Object_Ptr) return Object_Ptr; private type Proxy_Push_Consumer_Record; type Proxy_Push_Consumer_Access is access all Proxy_Push_Consumer_Record; type Object is new PortableServer.Servant_Base with record X : Proxy_Push_Consumer_Access; end record; end CosEventChannelAdmin.ProxyPushConsumer.Impl; polyorb-2.8~20110207.orig/cos/event/coseventcomm-pullsupplier-impl.ads0000644000175000017500000000673711750740337025222 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- C O S E V E N T C O M M . P U L L S U P P L I E R . I M P L -- -- -- -- S p e c -- -- -- -- Copyright (C) 2001-2008, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by ACT Europe. -- -- (email: sales@act-europe.fr) -- -- -- ------------------------------------------------------------------------------ with CORBA; with PortableServer; with CosEventChannelAdmin.ProxyPullConsumer; package CosEventComm.PullSupplier.Impl is -- This implementation is supposed to be application -- dependent. This is an example used to test the event service. type Object is new PortableServer.Servant_Base with private; type Object_Ptr is access all Object'Class; procedure Disconnect_Pull_Supplier (Self : access Object); -- Call by proxy to disconnect function Pull (Self : access Object) return CORBA.Any; -- Call by proxy to pull an event procedure Try_Pull (Self : access Object; Has_Event : out CORBA.Boolean; Returns : out CORBA.Any); -- Call by proxy to try yo pull an event ------------------------ -- AdaBroker specific -- ------------------------ procedure Connect_Proxy_Pull_Consumer (Self : access Object; Proxy : CosEventChannelAdmin.ProxyPullConsumer.Ref); -- Call by application to connect object with proxy function Create return Object_Ptr; -- Call by application to create an object and activate servant procedure Push (Self : access Object; Data : CORBA.Any); -- Call by application to produce an event private type Pull_Supplier_Record; type Pull_Supplier_Access is access Pull_Supplier_Record; type Object is new PortableServer.Servant_Base with record X : Pull_Supplier_Access; end record; end CosEventComm.PullSupplier.Impl; polyorb-2.8~20110207.orig/cos/event/costypedeventchanneladmin-typedproxypushconsumer-impl.adb0000644000175000017500000001500111750740337032060 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- COSTYPEDEVENTCHANNELADMIN.TYPEDPROXYPUSHCONSUMER.IMPL -- -- -- -- B o d y -- -- -- -- Copyright (C) 2003-2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with CosEventChannelAdmin; with CosEventComm; with PolyORB.CORBA_P.Server_Tools; with PolyORB.Log; with PolyORB.Tasking.Mutexes; with CosTypedEventChannelAdmin.TypedProxyPushConsumer.Skel; pragma Warnings (Off, CosTypedEventChannelAdmin.TypedProxyPushConsumer.Skel); package body CosTypedEventChannelAdmin.TypedProxyPushConsumer.Impl is use CosEventChannelAdmin; use CosEventComm; use PortableServer; use PolyORB.CORBA_P.Server_Tools; use PolyORB.Tasking.Mutexes; use PolyORB.Log; package L is new PolyORB.Log.Facility_Log ("typedproxypushconsumer"); procedure O (Message : Standard.String; Level : Log_Level := Debug) renames L.Output; function C (Level : Log_Level := Debug) return Boolean renames L.Enabled; pragma Unreferenced (C); -- For conditional pragma Debug type TypedProxy_Push_Consumer_Record is record This : Object_Ptr; Peer : PushSupplier.Ref; Admin : TypedSupplierAdmin.Impl.Object_Ptr; supported_interface : CosTypedEventChannelAdmin.Key; end record; --------------------------- -- Ensure_Initialization -- --------------------------- procedure Ensure_Initialization; pragma Inline (Ensure_Initialization); -- Ensure that the Mutexes are initialized T_Initialized : Boolean := False; Self_Mutex : Mutex_Access; procedure Ensure_Initialization is begin if not T_Initialized then Create (Self_Mutex); T_Initialized := True; end if; end Ensure_Initialization; --------------------------- -- Connect_Push_Supplier -- --------------------------- procedure Connect_Push_Supplier (Self : access Object; Push_Supplier : CosEventComm.PushSupplier.Ref) is begin pragma Debug (O ("connect pushsupplier to typedproxy push consumer")); Ensure_Initialization; Enter (Self_Mutex); if not PushSupplier.Is_Nil (Self.X.Peer) then Leave (Self_Mutex); raise AlreadyConnected; end if; Self.X.Peer := Push_Supplier; Leave (Self_Mutex); end Connect_Push_Supplier; ------------ -- Create -- ------------ function Create (Admin : TypedSupplierAdmin.Impl.Object_Ptr; supported_interface : CosTypedEventChannelAdmin.Key) return Object_Ptr is Consumer : Object_Ptr; My_Ref : TypedProxyPushConsumer.Ref; begin pragma Debug (O ("create typedproxy push consumer")); Consumer := new Object; Consumer.X := new TypedProxy_Push_Consumer_Record; Consumer.X.This := Consumer; Consumer.X.Admin := Admin; Consumer.X.supported_interface := supported_interface; Initiate_Servant (Servant (Consumer), My_Ref); return Consumer; end Create; ------------------------------ -- Disconnect_Push_Consumer -- ------------------------------ procedure Disconnect_Push_Consumer (Self : access Object) is Peer : PushSupplier.Ref; Nil_Ref : PushSupplier.Ref; begin pragma Debug (O ("disconnect typedproxy push consumer")); Ensure_Initialization; Enter (Self_Mutex); Peer := Self.X.Peer; Self.X.Peer := Nil_Ref; Leave (Self_Mutex); if not PushSupplier.Is_Nil (Peer) then PushSupplier.disconnect_push_supplier (Peer); end if; end Disconnect_Push_Consumer; ---------- -- Push -- ---------- procedure Push (Self : access Object; Data : CORBA.Any) is pragma Unreferenced (Self, Data); begin pragma Debug (O ("attempt to push new data to typed pushconsumer")); pragma Debug (O ("no need to use generic push in typed pushconsumer")); Ensure_Initialization; -- No need to implement push in Typed PushConsumer raise Program_Error; end Push; ------------------------ -- Get_Typed_Consumer -- ------------------------ function Get_Typed_Consumer (Self : access Object) return CORBA.Object.Ref is Ref : CORBA.Object.Ref; begin pragma Debug (O ("get the mutually agreed interface from "& "typed pushconsumer")); pragma Debug (O ("push mutually agreed interface from " & "typed proxy pushconsumer to typed supplieradmin")); Ensure_Initialization; Enter (Self_Mutex); Ref := TypedSupplierAdmin.Impl.Post (Self.X.Admin, Self.X.supported_interface); Leave (Self_Mutex); return Ref; end Get_Typed_Consumer; end CosTypedEventChannelAdmin.TypedProxyPushConsumer.Impl; polyorb-2.8~20110207.orig/cos/event/costypedeventchanneladmin-typedproxypullsupplier-impl.ads0000644000175000017500000000720611750740337032116 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- COSTYPEDEVENTCHANNELADMIN.TYPEDPROXYPULLSUPPLIER.IMPL -- -- -- -- S p e c -- -- -- -- Copyright (C) 2003-2008, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by ACT Europe. -- -- (email: sales@act-europe.fr) -- -- -- ------------------------------------------------------------------------------ with CosEventComm.PullConsumer; with CosTypedEventChannelAdmin.TypedConsumerAdmin.Impl; with PortableServer; package CosTypedEventChannelAdmin.TypedProxyPullSupplier.Impl is type Object is new PortableServer.Servant_Base with private; type Object_Ptr is access all Object'Class; -- Inherited IDL operations from -- CosEventchannelAdmin::ProxyPullSupplier procedure Connect_Pull_Consumer (Self : access Object; Pull_Consumer : CosEventComm.PullConsumer.Ref); function Pull (Self : access Object) return CORBA.Any; -- Call by consumer to pull an event -- No need to implement it in this case procedure Try_Pull (Self : access Object; Has_Event : out CORBA.Boolean; Returns : out CORBA.Any); -- Call by consumer to try_pull an event -- No need to implement it in this case procedure Disconnect_Pull_Supplier (Self : access Object); -- Inherited IDL operations from -- CosTypedEventComm::TypedPullSupplier function Get_Typed_Supplier (Self : access Object) return CORBA.Object.Ref; ---------------------- -- PolyORB specific -- ---------------------- function Create (Admin : TypedConsumerAdmin.Impl.Object_Ptr; supported_interface : CosTypedEventChannelAdmin.Key) return Object_Ptr; private type TypedProxy_Pull_Supplier_Record; type TypedProxy_Pull_Supplier_Access is access all TypedProxy_Pull_Supplier_Record; type Object is new PortableServer.Servant_Base with record X : TypedProxy_Pull_Supplier_Access; end record; end CosTypedEventChannelAdmin.TypedProxyPullSupplier.Impl; polyorb-2.8~20110207.orig/cos/event/coseventchanneladmin-proxypullsupplier-impl.adb0000644000175000017500000001635511750740337027766 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- COSEVENTCHANNELADMIN.PROXYPULLSUPPLIER.IMPL -- -- -- -- B o d y -- -- -- -- Copyright (C) 2001-2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with CosEventComm.PullConsumer; with CosEventChannelAdmin; with PolyORB.Log; with PolyORB.CORBA_P.Server_Tools; with PolyORB.Tasking.Mutexes; with PolyORB.Tasking.Semaphores; with PolyORB.Utils.Chained_Lists; with CosEventChannelAdmin.ProxyPullSupplier.Skel; pragma Warnings (Off, CosEventChannelAdmin.ProxyPullSupplier.Skel); package body CosEventChannelAdmin.ProxyPullSupplier.Impl is use PortableServer; use CosEventComm; use CosEventChannelAdmin; use PolyORB.CORBA_P.Server_Tools; use PolyORB.Tasking.Mutexes; use PolyORB.Tasking.Semaphores; use PolyORB.Log; package L is new PolyORB.Log.Facility_Log ("proxypullsupplier"); procedure O (Message : Standard.String; Level : Log_Level := Debug) renames L.Output; function C (Level : Log_Level := Debug) return Boolean renames L.Enabled; pragma Unreferenced (C); -- For conditional pragma Debug package Event_Queues is new PolyORB.Utils.Chained_Lists (CORBA.Any, CORBA."="); use Event_Queues; subtype Event_Queue is Event_Queues.List; type Proxy_Pull_Supplier_Record is record This : Object_Ptr; Peer : PullConsumer.Ref; Admin : ConsumerAdmin.Impl.Object_Ptr; Queue : Event_Queue; Semaphore : Semaphore_Access; end record; --------------------------- -- Ensure_Initialization -- --------------------------- procedure Ensure_Initialization; pragma Inline (Ensure_Initialization); -- Ensure that the Mutexes are initialized T_Initialized : Boolean := False; Self_Mutex : Mutex_Access; procedure Ensure_Initialization is begin if not T_Initialized then Create (Self_Mutex); T_Initialized := True; end if; end Ensure_Initialization; --------------------------- -- Connect_Pull_Consumer -- --------------------------- procedure Connect_Pull_Consumer (Self : access Object; Pull_Consumer : PullConsumer.Ref) is begin pragma Debug (O ("connect pull consumer to proxy pull supplier")); Ensure_Initialization; Enter (Self_Mutex); if not PullConsumer.Is_Nil (Self.X.Peer) then Leave (Self_Mutex); raise AlreadyConnected; end if; Self.X.Peer := Pull_Consumer; Leave (Self_Mutex); end Connect_Pull_Consumer; ------------ -- Create -- ------------ function Create (Admin : ConsumerAdmin.Impl.Object_Ptr) return Object_Ptr is Supplier : Object_Ptr; My_Ref : ProxyPullSupplier.Ref; begin pragma Debug (O ("create proxy pull supplier")); Supplier := new Object; Supplier.X := new Proxy_Pull_Supplier_Record; Supplier.X.This := Supplier; Supplier.X.Admin := Admin; Create (Supplier.X.Semaphore); Initiate_Servant (Servant (Supplier), My_Ref); return Supplier; end Create; ------------------------------ -- Disconnect_Pull_Supplier -- ------------------------------ procedure Disconnect_Pull_Supplier (Self : access Object) is Peer : PullConsumer.Ref; Nil_Ref : PullConsumer.Ref; begin pragma Debug (O ("disconnect proxy pull supplier")); Ensure_Initialization; Enter (Self_Mutex); Peer := Self.X.Peer; Self.X.Peer := Nil_Ref; Leave (Self_Mutex); V (Self.X.Semaphore); if not PullConsumer.Is_Nil (Peer) then PullConsumer.disconnect_pull_consumer (Peer); end if; end Disconnect_Pull_Supplier; ---------- -- Post -- ---------- procedure Post (Self : access Object; Data : CORBA.Any) is begin pragma Debug (O ("post new data to proxy pull supplier")); Ensure_Initialization; Enter (Self_Mutex); Append (Self.X.Queue, Data); Leave (Self_Mutex); V (Self.X.Semaphore); end Post; ---------- -- Pull -- ---------- function Pull (Self : access Object) return CORBA.Any is Event : CORBA.Any; begin pragma Debug (O ("attempt to pull new data from proxy pull supplier")); Ensure_Initialization; P (Self.X.Semaphore); Enter (Self_Mutex); if PullConsumer.Is_Nil (Self.X.Peer) then Leave (Self_Mutex); raise Disconnected; end if; if State (Self.X.Semaphore) >= 0 then Extract_First (Self.X.Queue, Event); pragma Debug (O ("succeed to pull data from proxy pull supplier")); end if; Leave (Self_Mutex); -- XXX what if nothing was pulled ? return Event; end Pull; -------------- -- Try_Pull -- -------------- procedure Try_Pull (Self : access Object; Has_Event : out CORBA.Boolean; Returns : out CORBA.Any) is begin pragma Debug (O ("try to pull new data from proxy pull supplier")); Ensure_Initialization; Enter (Self_Mutex); if PullConsumer.Is_Nil (Self.X.Peer) then Leave (Self_Mutex); raise Disconnected; end if; Has_Event := State (Self.X.Semaphore) > 0; if Has_Event then Extract_First (Self.X.Queue, Returns); Leave (Self_Mutex); P (Self.X.Semaphore); end if; end Try_Pull; end CosEventChannelAdmin.ProxyPullSupplier.Impl; polyorb-2.8~20110207.orig/cos/event/costypedeventchanneladmin-typedsupplieradmin-impl.ads0000644000175000017500000001021711750740337031124 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- COSTYPEDEVENTCHANNELADMIN.TYPEDSUPPLIERADMIN.IMPL -- -- -- -- S p e c -- -- -- -- Copyright (C) 2003-2008, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by ACT Europe. -- -- (email: sales@act-europe.fr) -- -- -- ------------------------------------------------------------------------------ with CORBA; with CORBA.Object; with CosEventChannelAdmin.ProxyPullConsumer; with CosEventChannelAdmin.ProxyPushConsumer; with CosTypedEventChannelAdmin; with CosTypedEventChannelAdmin.TypedEventChannel.Impl; with CosTypedEventChannelAdmin.TypedProxyPushConsumer; with PortableServer; package CosTypedEventChannelAdmin.TypedSupplierAdmin.Impl is type Object is new PortableServer.Servant_Base with private; type Object_Ptr is access all Object'Class; -- IDL operations function obtain_typed_push_consumer (Self : access Object; supported_interface : CosTypedEventChannelAdmin.Key) return TypedProxyPushConsumer.Ref; function obtain_typed_pull_consumer (Self : access Object; uses_interface : CosTypedEventChannelAdmin.Key) return CosEventChannelAdmin.ProxyPullConsumer.Ref; -- Iherited IDL operations from -- CosEventchannelAdmin::SupplierAdmin function Obtain_Push_Consumer (Self : access Object) return CosEventChannelAdmin.ProxyPushConsumer.Ref; -- Return ProxyPushConsumer -- No need to implement it in this case function Obtain_Pull_Consumer (Self : access Object) return CosEventChannelAdmin.ProxyPullConsumer.Ref; -- Return ProxyPullConsumer -- No need to implement it in this case ---------------------- -- PolyORB specific -- ---------------------- function Create (Channel : CosTypedEventChannelAdmin.TypedEventChannel.Impl.Object_Ptr) return Object_Ptr; function Post (Self : access Object; uses_interface : CosTypedEventChannelAdmin.Key) return CORBA.Object.Ref; -- Get mutually agreed interface from Typed PushConsumers function Pull (Self : access Object; uses_interface : CosTypedEventChannelAdmin.Key) return CORBA.Object.Ref; -- Get mutually agreed interface from Typed PullSuppliers private type TypedSupplier_Admin_Record; type TypedSupplier_Admin_Access is access all TypedSupplier_Admin_Record; type Object is new PortableServer.Servant_Base with record X : TypedSupplier_Admin_Access; end record; end CosTypedEventChannelAdmin.TypedSupplierAdmin.Impl; polyorb-2.8~20110207.orig/cos/event/coseventchanneladmin-consumeradmin-impl.adb0000644000175000017500000001501111750740337026754 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- COSEVENTCHANNELADMIN.CONSUMERADMIN.IMPL -- -- -- -- B o d y -- -- -- -- Copyright (C) 2001-2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with CORBA.Sequences.Unbounded; with CosEventChannelAdmin; with CosEventChannelAdmin.ProxyPullSupplier.Impl; with CosEventChannelAdmin.ProxyPushSupplier.Impl; with CosEventChannelAdmin.ConsumerAdmin.Skel; pragma Warnings (Off, CosEventChannelAdmin.ConsumerAdmin.Skel); with PolyORB.Log; with PolyORB.Tasking.Mutexes; with PolyORB.CORBA_P.Server_Tools; package body CosEventChannelAdmin.ConsumerAdmin.Impl is use CosEventChannelAdmin; use PortableServer; use PolyORB.CORBA_P.Server_Tools; use PolyORB.Tasking.Mutexes; use PolyORB.Log; package L is new PolyORB.Log.Facility_Log ("consumeradmin"); procedure O (Message : Standard.String; Level : Log_Level := Debug) renames L.Output; function C (Level : Log_Level := Debug) return Boolean renames L.Enabled; pragma Unreferenced (C); -- For conditional pragma Debug package PushSuppliers is new CORBA.Sequences.Unbounded (ProxyPushSupplier.Impl.Object_Ptr); package PullSuppliers is new CORBA.Sequences.Unbounded (ProxyPullSupplier.Impl.Object_Ptr); type Consumer_Admin_Record is record This : Object_Ptr; ThisRef : ConsumerAdmin.Ref; Channel : EventChannel.Impl.Object_Ptr; Pushs : PushSuppliers.Sequence; Pulls : PullSuppliers.Sequence; end record; --------------------------- -- Ensure_Initialization -- --------------------------- procedure Ensure_Initialization; pragma Inline (Ensure_Initialization); -- Ensure that the Mutexes are initialized. T_Initialized : Boolean := False; Self_Mutex : Mutex_Access; procedure Ensure_Initialization is begin if not T_Initialized then Create (Self_Mutex); T_Initialized := True; end if; end Ensure_Initialization; ------------ -- Create -- ------------ function Create (Channel : EventChannel.Impl.Object_Ptr) return Object_Ptr is Consumer : Object_Ptr; My_Ref : ConsumerAdmin.Ref; begin pragma Debug (O ("create consumer admin")); Consumer := new Object; Consumer.X := new Consumer_Admin_Record; Consumer.X.This := Consumer; Consumer.X.Channel := Channel; Initiate_Servant (Servant (Consumer), My_Ref); Consumer.X.ThisRef := My_Ref; return Consumer; end Create; -------------------------- -- Obtain_Pull_Supplier -- -------------------------- function Obtain_Pull_Supplier (Self : access Object) return ProxyPullSupplier.Ref is Supplier : ProxyPullSupplier.Impl.Object_Ptr; Its_Ref : ProxyPullSupplier.Ref; begin pragma Debug (O ("obtain proxy pull supplier from consumer admin")); Ensure_Initialization; Enter (Self_Mutex); Supplier := ProxyPullSupplier.Impl.Create (Self.X.This); PullSuppliers.Append (Self.X.Pulls, Supplier); Leave (Self_Mutex); Servant_To_Reference (Servant (Supplier), Its_Ref); return Its_Ref; end Obtain_Pull_Supplier; -------------------------- -- Obtain_Push_Supplier -- -------------------------- function Obtain_Push_Supplier (Self : access Object) return ProxyPushSupplier.Ref is Supplier : ProxyPushSupplier.Impl.Object_Ptr; Its_Ref : ProxyPushSupplier.Ref; begin pragma Debug (O ("obtain proxy push supplier from consumer admin")); Ensure_Initialization; Enter (Self_Mutex); Supplier := ProxyPushSupplier.Impl.Create (Self.X.ThisRef); PushSuppliers.Append (Self.X.Pushs, Supplier); Leave (Self_Mutex); Servant_To_Reference (Servant (Supplier), Its_Ref); return Its_Ref; end Obtain_Push_Supplier; ---------- -- Post -- ---------- procedure Post (Self : access Object; Data : CORBA.Any) is begin Ensure_Initialization; Enter (Self_Mutex); declare Pulls : constant PullSuppliers.Element_Array := PullSuppliers.To_Element_Array (Self.X.Pulls); Pushs : constant PushSuppliers.Element_Array := PushSuppliers.To_Element_Array (Self.X.Pushs); begin Leave (Self_Mutex); pragma Debug (O ("post new data to proxy pull suppliers")); for J in Pulls'Range loop ProxyPullSupplier.Impl.Post (Pulls (J), Data); end loop; pragma Debug (O ("post new data to proxy push suppliers")); for J in Pushs'Range loop ProxyPushSupplier.Impl.Post (Pushs (J), Data); end loop; end; end Post; end CosEventChannelAdmin.ConsumerAdmin.Impl; polyorb-2.8~20110207.orig/cos/event/coseventchanneladmin-proxypullsupplier-impl.ads0000644000175000017500000000625511750740337030005 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- COSEVENTCHANNELADMIN.PROXYPULLSUPPLIER.IMPL -- -- -- -- S p e c -- -- -- -- Copyright (C) 2001-2008, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by ACT Europe. -- -- (email: sales@act-europe.fr) -- -- -- ------------------------------------------------------------------------------ with PortableServer; with CosEventChannelAdmin.ConsumerAdmin.Impl; package CosEventChannelAdmin.ProxyPullSupplier.Impl is type Object is new PortableServer.Servant_Base with private; type Object_Ptr is access all Object'Class; procedure Connect_Pull_Consumer (Self : access Object; Pull_Consumer : CosEventComm.PullConsumer.Ref); function Pull (Self : access Object) return CORBA.Any; procedure Try_Pull (Self : access Object; Has_Event : out CORBA.Boolean; Returns : out CORBA.Any); procedure Disconnect_Pull_Supplier (Self : access Object); ------------------------ -- AdaBroker specific -- ------------------------ procedure Post (Self : access Object; Data : CORBA.Any); function Create (Admin : CosEventChannelAdmin.ConsumerAdmin.Impl.Object_Ptr) return Object_Ptr; private type Proxy_Pull_Supplier_Record; type Proxy_Pull_Supplier_Access is access all Proxy_Pull_Supplier_Record; type Object is new PortableServer.Servant_Base with record X : Proxy_Pull_Supplier_Access; end record; end CosEventChannelAdmin.ProxyPullSupplier.Impl; polyorb-2.8~20110207.orig/cos/event/costypedeventcomm-typedpushconsumer-impl.ads0000644000175000017500000000655111750740337027323 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- COSTYPEDEVENTCOMM.TYPEDPUSHCONSUMER.IMPL -- -- -- -- S p e c -- -- -- -- Copyright (C) 2003-2008, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by ACT Europe. -- -- (email: sales@act-europe.fr) -- -- -- ------------------------------------------------------------------------------ with CORBA; with CosTypedEventChannelAdmin; with CosTypedEventChannelAdmin.TypedEventChannel.Impl; with PortableServer; package CosTypedEventComm.TypedPushConsumer.Impl is type Object is new PortableServer.Servant_Base with private; type Object_Ptr is access all Object'Class; -- IDL operations function Get_Typed_Consumer (Self : access Object) return CORBA.Object.Ref; -- Inherited IDL operations from CosEventComm::PushConsumer procedure Push (Self : access Object; Data : CORBA.Any); -- Call by proxy to push an event -- No need to implement it in this case procedure Disconnect_Push_Consumer (Self : access Object); -- Call by proxy to disconnect ---------------------- -- PolyORB specific -- ---------------------- function Create return Object_Ptr; -- Call by application to create an object and activate servant procedure SetInterface_Ptr (Self : access Object; I_Ptr : CosTypedEventChannelAdmin.TypedEventChannel.Impl.Interface_Ptr); -- Appopriately set the supported Interface Pointer private type Typed_Push_Consumer_Record; type Typed_Push_Consumer_Access is access Typed_Push_Consumer_Record; type Object is new PortableServer.Servant_Base with record X : Typed_Push_Consumer_Access; end record; end CosTypedEventComm.TypedPushConsumer.Impl; polyorb-2.8~20110207.orig/cos/event/costypedeventchanneladmin-typedproxypushconsumer-impl.ads0000644000175000017500000000674511750740337032120 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- COSTYPEDEVENTCHANNELADMIN.TYPEDPROXYPUSHCONSUMER.IMPL -- -- -- -- S p e c -- -- -- -- Copyright (C) 2003-2008, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by ACT Europe. -- -- (email: sales@act-europe.fr) -- -- -- ------------------------------------------------------------------------------ with CosEventComm.PushSupplier; with CosTypedEventChannelAdmin; with CosTypedEventChannelAdmin.TypedSupplierAdmin.Impl; with PortableServer; package CosTypedEventChannelAdmin.TypedProxyPushConsumer.Impl is type Object is new PortableServer.Servant_Base with private; type Object_Ptr is access all Object'Class; -- Inherited IDL operations from -- CosEventchannelAdmin::ProxyPushConsumer procedure Connect_Push_Supplier (Self : access Object; Push_Supplier : CosEventComm.PushSupplier.Ref); procedure Push (Self : access Object; Data : CORBA.Any); -- Call by supplier to push an event -- No need to implement it in this case procedure Disconnect_Push_Consumer (Self : access Object); -- Inherited IDL operations from -- CosTypedEventComm::TypedPushConsumer function Get_Typed_Consumer (Self : access Object) return CORBA.Object.Ref; ---------------------- -- PolyORB specific -- ---------------------- function Create (Admin : CosTypedEventChannelAdmin.TypedSupplierAdmin.Impl.Object_Ptr; supported_interface : CosTypedEventChannelAdmin.Key) return Object_Ptr; private type TypedProxy_Push_Consumer_Record; type TypedProxy_Push_Consumer_Access is access all TypedProxy_Push_Consumer_Record; type Object is new PortableServer.Servant_Base with record X : TypedProxy_Push_Consumer_Access; end record; end CosTypedEventChannelAdmin.TypedProxyPushConsumer.Impl; polyorb-2.8~20110207.orig/cos/event/coseventcomm-pullsupplier-impl.adb0000644000175000017500000001610411750740337025166 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- C O S E V E N T C O M M . P U L L S U P P L I E R . I M P L -- -- -- -- B o d y -- -- -- -- Copyright (C) 2001-2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with PolyORB.CORBA_P.Server_Tools; with PolyORB.Log; with PolyORB.Tasking.Mutexes; with PolyORB.Tasking.Semaphores; with CosEventComm.PullSupplier.Skel; pragma Warnings (Off, CosEventComm.PullSupplier.Skel); package body CosEventComm.PullSupplier.Impl is use CosEventChannelAdmin; use PortableServer; use PolyORB.CORBA_P.Server_Tools; use PolyORB.Tasking.Semaphores; use PolyORB.Tasking.Mutexes; use PolyORB.Log; package L is new PolyORB.Log.Facility_Log ("pullsupplier"); procedure O (Message : Standard.String; Level : Log_Level := Debug) renames L.Output; function C (Level : Log_Level := Debug) return Boolean renames L.Enabled; pragma Unreferenced (C); -- For conditional pragma Debug type Pull_Supplier_Record is record This : Object_Ptr; Peer : ProxyPullConsumer.Ref; Empty : Boolean; Event : CORBA.Any; Semaphore : Semaphore_Access; end record; --------------------------- -- Ensure_Initialization -- --------------------------- procedure Ensure_Initialization; pragma Inline (Ensure_Initialization); -- Ensure that the Mutexes are initialized T_Initialized : Boolean := False; Self_Mutex : Mutex_Access; procedure Ensure_Initialization is begin if not T_Initialized then Create (Self_Mutex); T_Initialized := True; end if; end Ensure_Initialization; --------------------------------- -- Connect_Proxy_Pull_Consumer -- --------------------------------- procedure Connect_Proxy_Pull_Consumer (Self : access Object; Proxy : CosEventChannelAdmin.ProxyPullConsumer.Ref) is My_Ref : PullSupplier.Ref; begin pragma Debug (O ("connect proxy pull supplier to pull consumer")); Ensure_Initialization; Enter (Self_Mutex); if not ProxyPullConsumer.Is_Nil (Self.X.Peer) then Leave (Self_Mutex); raise AlreadyConnected; end if; Self.X.Peer := Proxy; Leave (Self_Mutex); Servant_To_Reference (Servant (Self.X.This), My_Ref); ProxyPullConsumer.connect_pull_supplier (Proxy, My_Ref); end Connect_Proxy_Pull_Consumer; ------------ -- Create -- ------------ function Create return Object_Ptr is Supplier : Object_Ptr; My_Ref : PullSupplier.Ref; begin pragma Debug (O ("create pull supplier")); Supplier := new Object; Supplier.X := new Pull_Supplier_Record; Supplier.X.This := Supplier; Supplier.X.Empty := True; Create (Supplier.X.Semaphore); Initiate_Servant (Servant (Supplier), My_Ref); return Supplier; end Create; ------------------------------ -- Disconnect_Pull_Supplier -- ------------------------------ procedure Disconnect_Pull_Supplier (Self : access Object) is Peer : ProxyPullConsumer.Ref; Nil_Ref : ProxyPullConsumer.Ref; begin pragma Debug (O ("disconnect pull supplier")); Ensure_Initialization; Enter (Self_Mutex); Peer := Self.X.Peer; Self.X.Peer := Nil_Ref; Leave (Self_Mutex); V (Self.X.Semaphore); if not ProxyPullConsumer.Is_Nil (Peer) then ProxyPullConsumer.disconnect_pull_consumer (Peer); end if; end Disconnect_Pull_Supplier; ---------- -- Pull -- ---------- function Pull (Self : access Object) return CORBA.Any is Event : CORBA.Any; begin Ensure_Initialization; loop pragma Debug (O ("attempt to pull new data from pull supplier")); P (Self.X.Semaphore); Enter (Self_Mutex); if ProxyPullConsumer.Is_Nil (Self.X.Peer) then Leave (Self_Mutex); raise Disconnected; end if; if not Self.X.Empty then Event := Self.X.Event; Self.X.Empty := True; Leave (Self_Mutex); exit; end if; Leave (Self_Mutex); end loop; pragma Debug (O ("succeed to pull new data from pull supplier")); return Event; end Pull; ---------- -- Push -- ---------- procedure Push (Self : access Object; Data : CORBA.Any) is begin pragma Debug (O ("push new data to pull supplier")); Ensure_Initialization; Enter (Self_Mutex); Self.X.Empty := False; Self.X.Event := Data; Leave (Self_Mutex); V (Self.X.Semaphore); end Push; -------------- -- Try_Pull -- -------------- procedure Try_Pull (Self : access Object; Has_Event : out CORBA.Boolean; Returns : out CORBA.Any) is begin pragma Debug (O ("try to pull new data from pull supplier")); Ensure_Initialization; Enter (Self_Mutex); if ProxyPullConsumer.Is_Nil (Self.X.Peer) then Leave (Self_Mutex); raise Disconnected; end if; Has_Event := not Self.X.Empty; if Has_Event then Returns := Self.X.Event; Self.X.Empty := True; end if; Leave (Self_Mutex); end Try_Pull; end CosEventComm.PullSupplier.Impl; polyorb-2.8~20110207.orig/cos/event/coseventchanneladmin-consumeradmin-impl.ads0000644000175000017500000000603211750740337027000 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- COSEVENTCHANNELADMIN.CONSUMERADMIN.IMPL -- -- -- -- S p e c -- -- -- -- Copyright (C) 2001-2008, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by ACT Europe. -- -- (email: sales@act-europe.fr) -- -- -- ------------------------------------------------------------------------------ with CosEventChannelAdmin.ProxyPullSupplier; with CosEventChannelAdmin.ProxyPushSupplier; with CosEventChannelAdmin.EventChannel.Impl; with PortableServer; package CosEventChannelAdmin.ConsumerAdmin.Impl is type Object is new PortableServer.Servant_Base with private; type Object_Ptr is access all Object'Class; function Obtain_Push_Supplier (Self : access Object) return ProxyPushSupplier.Ref; function Obtain_Pull_Supplier (Self : access Object) return ProxyPullSupplier.Ref; ---------------------- -- PolyORB specific -- ---------------------- procedure Post (Self : access Object; Data : CORBA.Any); function Create (Channel : CosEventChannelAdmin.EventChannel.Impl.Object_Ptr) return Object_Ptr; private type Consumer_Admin_Record; type Consumer_Admin_Access is access all Consumer_Admin_Record; type Object is new PortableServer.Servant_Base with record X : Consumer_Admin_Access; end record; end CosEventChannelAdmin.ConsumerAdmin.Impl; polyorb-2.8~20110207.orig/cos/event/costypedeventchanneladmin-typedsupplieradmin-impl.adb0000644000175000017500000002235511750740337031111 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- COSTYPEDEVENTCHANNELADMIN.TYPEDSUPPLIERADMIN.IMPL -- -- -- -- B o d y -- -- -- -- Copyright (C) 2003-2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with CosEventChannelAdmin.ProxyPullConsumer.Impl; with CosEventChannelAdmin.SupplierAdmin.Helper; with CosTypedEventChannelAdmin.TypedEventChannel; with CosTypedEventChannelAdmin.TypedProxyPushConsumer.Impl; with PolyORB.CORBA_P.Server_Tools; with PolyORB.Dynamic_Dict; with PolyORB.Log; with PolyORB.Tasking.Mutexes; with CosTypedEventChannelAdmin.TypedSupplierAdmin.Skel; pragma Warnings (Off, CosTypedEventChannelAdmin.TypedSupplierAdmin.Skel); package body CosTypedEventChannelAdmin.TypedSupplierAdmin.Impl is use CosEventChannelAdmin; use CosEventChannelAdmin.ProxyPullConsumer.Impl; use CosTypedEventChannelAdmin.TypedEventChannel.Impl; use PortableServer; use PolyORB.CORBA_P.Server_Tools; use PolyORB.Tasking.Mutexes; use PolyORB.Log; package L is new PolyORB.Log.Facility_Log ("typedsupplieradmin"); procedure O (Message : Standard.String; Level : Log_Level := Debug) renames L.Output; function C (Level : Log_Level := Debug) return Boolean renames L.Enabled; pragma Unreferenced (C); -- For conditional pragma Debug package ProxyPullConsumersTable is new PolyORB.Dynamic_Dict (ProxyPullConsumer.Impl.Object_Ptr); type TypedSupplier_Admin_Record is record This : Object_Ptr; ThisRef : TypedSupplierAdmin.Ref; Channel : TypedEventChannel.Impl.Object_Ptr; end record; --------------------------- -- Ensure_Initialization -- --------------------------- procedure Ensure_Initialization; pragma Inline (Ensure_Initialization); -- Ensure that the Mutexes are initialized T_Initialized : Boolean := False; Self_Mutex : Mutex_Access; procedure Ensure_Initialization is begin if not T_Initialized then Create (Self_Mutex); T_Initialized := True; end if; end Ensure_Initialization; ------------ -- Create -- ------------ function Create (Channel : TypedEventChannel.Impl.Object_Ptr) return Object_Ptr is Supplier : Object_Ptr; My_Ref : TypedSupplierAdmin.Ref; begin pragma Debug (O ("create typedsupplier admin")); Supplier := new Object; Supplier.X := new TypedSupplier_Admin_Record; Supplier.X.This := Supplier; Supplier.X.Channel := Channel; Initiate_Servant (Servant (Supplier), My_Ref); Supplier.X.ThisRef := My_Ref; return Supplier; end Create; -------------------------- -- Obtain_Typed_Push_Consumer -- -------------------------- function obtain_typed_push_consumer (Self : access Object; supported_interface : CosTypedEventChannelAdmin.Key) return TypedProxyPushConsumer.Ref is Its_Ref : TypedProxyPushConsumer.Ref; MyConsumer : TypedProxyPushConsumer.Impl.Object_Ptr; MyCreate_Ptr : TypedEventChannel.Impl.Interface_Ptr; begin pragma Debug (O ("obtain typed proxypushconsumer from "& "typed supplieradmin")); Ensure_Initialization; Enter (Self_Mutex); MyCreate_Ptr := TypedEventChannel.Impl.Lookup (supported_interface); if MyCreate_Ptr = null then raise InterfaceNotSupported; end if; MyConsumer := TypedProxyPushConsumer.Impl.Create (Self.X.This, supported_interface); Leave (Self_Mutex); Servant_To_Reference (Servant (MyConsumer), Its_Ref); return Its_Ref; end obtain_typed_push_consumer; -------------------------------- -- Obtain_Typed_Pull_Consumer -- -------------------------------- function obtain_typed_pull_consumer (Self : access Object; uses_interface : CosTypedEventChannelAdmin.Key) return ProxyPullConsumer.Ref is Consumer : ProxyPullConsumer.Impl.Object_Ptr; Its_Ref : ProxyPullConsumer.Ref; MyRef : SupplierAdmin.Ref; MyCreate_Ptr : TypedEventChannel.Impl.Interface_Ptr; begin pragma Debug (O ("obtain proxypullconsumer from typed supplieradmin")); Ensure_Initialization; Enter (Self_Mutex); MyCreate_Ptr := TypedEventChannel.Impl.Lookup (uses_interface); if MyCreate_Ptr = null then raise InterfaceNotSupported; end if; MyRef := SupplierAdmin.Helper.To_Ref (Self.X.ThisRef); Consumer := ProxyPullConsumer.Impl.Create (MyRef); ProxyPullConsumersTable.Register (To_String (uses_interface), Consumer); Leave (Self_Mutex); Servant_To_Reference (Servant (Consumer), Its_Ref); return Its_Ref; end obtain_typed_pull_consumer; -------------------------- -- Obtain_Pull_Consumer -- -------------------------- function Obtain_Pull_Consumer (Self : access Object) return CosEventChannelAdmin.ProxyPullConsumer.Ref is pragma Unreferenced (Self); Its_Ref : ProxyPullConsumer.Ref; begin pragma Debug (O ("obtain proxy pull consumer from typed supplieradmin")); pragma Debug (O ("No need to get generic proxy pullconsumer "& "from typed supplieradmin")); Ensure_Initialization; -- No need to implement generic Obtain_Pull_Consumer in -- typed supplieradmin raise Program_Error; return Its_Ref; end Obtain_Pull_Consumer; -------------------------- -- Obtain_Push_Consumer -- -------------------------- function Obtain_Push_Consumer (Self : access Object) return ProxyPushConsumer.Ref is pragma Unreferenced (Self); Its_Ref : ProxyPushConsumer.Ref; begin pragma Debug (O ("obtain proxy push consumer from typed supplieradmin")); pragma Debug (O ("No need to get generic proxy pushconsumer "& "from typed supplieradmin")); Ensure_Initialization; -- No need to implement generic Obtain_Push_Consumer in -- typed supplieradmin raise Program_Error; return Its_Ref; end Obtain_Push_Consumer; ---------- -- Post -- ---------- function Post (Self : access Object; uses_interface : CosTypedEventChannelAdmin.Key) return CORBA.Object.Ref is Ref : CORBA.Object.Ref; begin pragma Debug (O ("push mutually agreed interface from " & "typed supplieradmin to typed eventchannel")); Ensure_Initialization; Enter (Self_Mutex); Ref := TypedEventChannel.Impl.Post (Self.X.Channel, uses_interface); Leave (Self_Mutex); return Ref; end Post; ---------- -- Pull -- ---------- function Pull (Self : access Object; uses_interface : CosTypedEventChannelAdmin.Key) return CORBA.Object.Ref is pragma Unreferenced (Self); Ref : CORBA.Object.Ref; MyProxyPullConsumer : ProxyPullConsumer.Impl.Object_Ptr; begin pragma Debug (O ("pull mutually agreed interface from " & "typed supplieradmin to proxy pullconsumer")); Ensure_Initialization; Enter (Self_Mutex); MyProxyPullConsumer := ProxyPullConsumersTable.Lookup (To_String (uses_interface), null); if MyProxyPullConsumer = null then raise InterfaceNotSupported; end if; Leave (Self_Mutex); Ref := ProxyPullConsumer.Impl.Pull (MyProxyPullConsumer); return Ref; end Pull; end CosTypedEventChannelAdmin.TypedSupplierAdmin.Impl; polyorb-2.8~20110207.orig/cos/event/coseventchanneladmin-supplieradmin-impl.ads0000644000175000017500000000603111750740337027007 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- COSEVENTCHANNELADMIN.SUPPLIERADMIN.IMPL -- -- -- -- S p e c -- -- -- -- Copyright (C) 2001-2008, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by ACT Europe. -- -- (email: sales@act-europe.fr) -- -- -- ------------------------------------------------------------------------------ with CosEventChannelAdmin.ProxyPullConsumer; with CosEventChannelAdmin.ProxyPushConsumer; with CosEventChannelAdmin.EventChannel.Impl; with PortableServer; package CosEventChannelAdmin.SupplierAdmin.Impl is type Object is new PortableServer.Servant_Base with private; type Object_Ptr is access all Object'Class; function Obtain_Push_Consumer (Self : access Object) return ProxyPushConsumer.Ref; function Obtain_Pull_Consumer (Self : access Object) return ProxyPullConsumer.Ref; ---------------------- -- PolyORB specific -- ---------------------- function Create (Channel : CosEventChannelAdmin.EventChannel.Impl.Object_Ptr) return Object_Ptr; procedure Post (Self : access Object; Data : CORBA.Any); private type Supplier_Admin_Record; type Supplier_Admin_Access is access all Supplier_Admin_Record; type Object is new PortableServer.Servant_Base with record X : Supplier_Admin_Access; end record; end CosEventChannelAdmin.SupplierAdmin.Impl; polyorb-2.8~20110207.orig/cos/event/coseventchanneladmin-proxypullconsumer-impl.adb0000644000175000017500000002071111750740337027745 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- COSEVENTCHANNELADMIN.PROXYPULLCONSUMER.IMPL -- -- -- -- B o d y -- -- -- -- Copyright (C) 2001-2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with CORBA.Impl; with CosEventChannelAdmin; with CosEventChannelAdmin.SupplierAdmin.Impl; with CosEventComm; with CosEventComm.PullSupplier; with CosTypedEventComm.TypedPullSupplier; with CosTypedEventComm.TypedPullSupplier.Impl; with PolyORB.CORBA_P.Server_Tools; with PolyORB.Log; with PolyORB.Tasking.Condition_Variables; with PolyORB.Tasking.Mutexes; with PolyORB.Tasking.Threads; with CosEventChannelAdmin.ProxyPullConsumer.Skel; pragma Warnings (Off, CosEventChannelAdmin.ProxyPullConsumer.Skel); package body CosEventChannelAdmin.ProxyPullConsumer.Impl is use CosEventComm; use CosEventChannelAdmin; use CosTypedEventComm; use PortableServer; use PolyORB.Tasking.Condition_Variables; use PolyORB.Tasking.Mutexes; use PolyORB.Tasking.Threads; use PolyORB.CORBA_P.Server_Tools; use PolyORB.Log; package L is new PolyORB.Log.Facility_Log ("proxypullconsumer"); procedure O (Message : Standard.String; Level : Log_Level := Debug) renames L.Output; function C (Level : Log_Level := Debug) return Boolean renames L.Enabled; pragma Unreferenced (C); -- For conditional pragma Debug type Proxy_Pull_Consumer_Record is record This : Object_Ptr; Peer : PullSupplier.Ref; Admin : SupplierAdmin.Ref; Engin_Launched : Boolean := False; -- is there a thread launch for the engine end record; A_S : Object_Ptr := null; -- This variable is used to initialize the threads local variable. -- it is used to replace the 'accept' statement. Session_Mutex : Mutex_Access; Session_Taken : Condition_Access; -- Synchornisation of task initialization. Peer_Mutex : Mutex_Access; -- Protect access on a peer component T_Initialized : Boolean := False; procedure Ensure_Initialization; pragma Inline (Ensure_Initialization); -- Ensure that the Mutexes are initialized --------------------------- -- Ensure_Initialization -- --------------------------- procedure Ensure_Initialization is begin if T_Initialized then return; end if; Create (Session_Mutex); Create (Session_Taken); Create (Peer_Mutex); T_Initialized := True; end Ensure_Initialization; ------------------------------- -- Proxy_Pull_Consumer_Engin -- ------------------------------- procedure Proxy_Pull_Consumer_Engine; procedure Proxy_Pull_Consumer_Engine is This : Object_Ptr; Peer : PullSupplier.Ref; Event : CORBA.Any; Obj : CORBA.Impl.Object_Ptr; begin pragma Debug (O ("Session Thread number " & Image (Current_Task) & " is starting")); -- Signal end of thread initialization. Ensure_Initialization; -- Thread initialization. -- A_S is a global variable used to pass an argument to this task This := A_S; -- This is initialized -- we can let Connect_Pull_Supplier go Enter (Session_Mutex); Signal (Session_Taken); Leave (Session_Mutex); loop -- Session thread main loop. Enter (Peer_Mutex); Peer := This.X.Peer; Leave (Peer_Mutex); exit when PullSupplier.Is_Nil (Peer); pragma Debug (O ("pull new data from proxy pull consumer engin")); begin Event := PullSupplier.pull (Peer); exception when others => exit; end; pragma Debug (O ("post new data from proxy pull consumer to admin")); Reference_To_Servant (This.X.Admin, Servant (Obj)); SupplierAdmin.Impl.Post (SupplierAdmin.Impl.Object_Ptr (Obj), Event); end loop; This.X.Engin_Launched := False; end Proxy_Pull_Consumer_Engine; --------------------------- -- Connect_Pull_Supplier -- --------------------------- procedure Connect_Pull_Supplier (Self : access Object; Pull_Supplier : CosEventComm.PullSupplier.Ref) is begin pragma Debug (O ("connect pull supplier to proxy pull consumer")); Ensure_Initialization; Enter (Session_Mutex); if not PullSupplier.Is_Nil (Self.X.Peer) then Leave (Session_Mutex); raise AlreadyConnected; end if; Self.X.Peer := Pull_Supplier; A_S := Self.X.This; -- Start engin if not Self.X.Engin_Launched then Create_Task (Proxy_Pull_Consumer_Engine'Access); Self.X.Engin_Launched := True; -- thread created end if; -- wait A_S initialization in Proxy_Pull_Consumer_Engin Wait (Session_Taken, Session_Mutex); Leave (Session_Mutex); end Connect_Pull_Supplier; ------------ -- Create -- ------------ function Create (Admin : SupplierAdmin.Ref) return Object_Ptr is Consumer : Object_Ptr; My_Ref : ProxyPullConsumer.Ref; begin pragma Debug (O ("create proxy pull consumer")); Consumer := new Object; Consumer.X := new Proxy_Pull_Consumer_Record; Consumer.X.This := Consumer; Consumer.X.Admin := Admin; Initiate_Servant (Servant (Consumer), My_Ref); return Consumer; end Create; ---------- -- Pull -- ---------- function Pull (Self : access Object) return CORBA.Object.Ref is Ref : CORBA.Object.Ref; Obj : CORBA.Impl.Object_Ptr; begin pragma Debug (O ("calling get_typed_supplier from " & "proxy pullconsumer to typed pullsupplier")); begin Reference_To_Servant (Self.X.Peer, Servant (Obj)); Ref := TypedPullSupplier.Impl.Get_Typed_Supplier (TypedPullSupplier.Impl.Object_Ptr (Obj)); exception when others => pragma Debug (O ("Got exception in Pull")); raise; end; return Ref; end Pull; ------------------------------ -- Disconnect_Pull_Consumer -- ------------------------------ procedure Disconnect_Pull_Consumer (Self : access Object) is Peer : PullSupplier.Ref; Nil_Ref : PullSupplier.Ref; begin pragma Debug (O ("disconnect proxy pull consumer")); Enter (Peer_Mutex); Peer := Self.X.Peer; Self.X.Peer := Nil_Ref; Leave (Peer_Mutex); if not PullSupplier.Is_Nil (Peer) then PullSupplier.disconnect_pull_supplier (Peer); end if; end Disconnect_Pull_Consumer; end CosEventChannelAdmin.ProxyPullConsumer.Impl; polyorb-2.8~20110207.orig/cos/event/coseventchanneladmin-eventchannel-impl.ads0000644000175000017500000000573711750740337026621 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- COSEVENTCHANNELADMIN.EVENTCHANNEL.IMPL -- -- -- -- S p e c -- -- -- -- Copyright (C) 2001-2008, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by ACT Europe. -- -- (email: sales@act-europe.fr) -- -- -- ------------------------------------------------------------------------------ with CosEventChannelAdmin.SupplierAdmin; with CosEventChannelAdmin.ConsumerAdmin; with PortableServer; package CosEventChannelAdmin.EventChannel.Impl is type Object is new PortableServer.Servant_Base with private; type Object_Ptr is access all Object'Class; function For_Consumers (Self : access Object) return CosEventChannelAdmin.ConsumerAdmin.Ref; function For_Suppliers (Self : access Object) return CosEventChannelAdmin.SupplierAdmin.Ref; procedure Destroy (Self : access Object); ------------------------ -- AdaBroker specific -- ------------------------ procedure Post (Self : access Object; Data : CORBA.Any); function Create return Object_Ptr; private type Event_Channel_Record; type Event_Channel_Access is access Event_Channel_Record; type Object is new PortableServer.Servant_Base with record X : Event_Channel_Access; end record; end CosEventChannelAdmin.EventChannel.Impl; polyorb-2.8~20110207.orig/cos/ir/0000755000175000017500000000000011750740340015600 5ustar xavierxavierpolyorb-2.8~20110207.orig/cos/ir/corba-repository_root-idltype-impl.ads0000644000175000017500000000664011750740337025262 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- C O R B A . R E P O S I T O R Y _ R O O T . I D L T Y P E . I M P L -- -- -- -- S p e c -- -- -- -- Copyright (C) 2006-2008, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the CORBA Specification, and adapted -- -- for use with PolyORB. The copyright notice above, and the license -- -- provisions that follow apply solely to the contents neither explicitly -- -- nor implicitly specified by the CORBA Specification defined by the OMG. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with CORBA.Repository_Root.IRObject.Impl; package CORBA.Repository_Root.IDLType.Impl is type Object is new CORBA.Repository_Root.IRObject.Impl.Object with private; type Object_Ptr is access all Object'Class; -- should only be called if the cast is safe! function To_IDLType (Self : CORBA.Repository_Root.IRObject.Impl.Object_Ptr) return Object_Ptr; -- method used to initialize recursively the object fields. -- procedure Init (Self : access Object; -- Real_Object : -- CORBA.Repository_Root.IRObject.Impl.Object_Ptr; -- Def_Kind : CORBA.Repository_Root.DefinitionKind); function get_type (Self : access Object) return CORBA.TypeCode.Object; private type Object is new CORBA.Repository_Root.IRObject.Impl.Object with null record; -- the Type attribute is computed dynamically in each child, -- because it can be changed by setting specific attributes after -- the beginning. end CORBA.Repository_Root.IDLType.Impl; polyorb-2.8~20110207.orig/cos/ir/corba-repository_root-arraydef-impl.ads0000644000175000017500000000773211750740337025410 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- C O R B A . R E P O S I T O R Y _ R O O T . A R R A Y D E F . I M P L -- -- -- -- S p e c -- -- -- -- Copyright (C) 2006-2008, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the CORBA Specification, and adapted -- -- for use with PolyORB. The copyright notice above, and the license -- -- provisions that follow apply solely to the contents neither explicitly -- -- nor implicitly specified by the CORBA Specification defined by the OMG. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with CORBA.Repository_Root.IRObject.Impl; with CORBA.Repository_Root.IDLType; with CORBA.Repository_Root.IDLType.Impl; package CORBA.Repository_Root.ArrayDef.Impl is type Object is new CORBA.Repository_Root.IDLType.Impl.Object with private; type Object_Ptr is access all Object'Class; -- method used to initialize recursively the object fields. procedure Init (Self : access Object; Real_Object : CORBA.Repository_Root.IRObject.Impl.Object_Ptr; Def_Kind : CORBA.Repository_Root.DefinitionKind; Length : CORBA.Unsigned_Long; Element_Type_Def : CORBA.Repository_Root.IDLType.Ref); -- overload the get_type from IDLType function get_type (Self : access Object) return CORBA.TypeCode.Object; function get_length (Self : access Object) return CORBA.Unsigned_Long; procedure set_length (Self : access Object; To : CORBA.Unsigned_Long); function get_element_type (Self : access Object) return CORBA.TypeCode.Object; function get_element_type_def (Self : access Object) return CORBA.Repository_Root.IDLType.Ref; procedure set_element_type_def (Self : access Object; To : CORBA.Repository_Root.IDLType.Ref); private type Object is new CORBA.Repository_Root.IDLType.Impl.Object with record Length : CORBA.Unsigned_Long; -- the Element_Type field is the one from the IDLType Element_Type_Def : CORBA.Repository_Root.IDLType.Ref; end record; end CORBA.Repository_Root.ArrayDef.Impl; polyorb-2.8~20110207.orig/cos/ir/corba-repository_root-extinterfacedef-impl.ads0000644000175000017500000001062011750740337026741 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- CORBA.REPOSITORY_ROOT.EXTINTERFACEDEF.IMPL -- -- -- -- S p e c -- -- -- -- Copyright (C) 2006-2008, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the CORBA Specification, and adapted -- -- for use with PolyORB. The copyright notice above, and the license -- -- provisions that follow apply solely to the contents neither explicitly -- -- nor implicitly specified by the CORBA Specification defined by the OMG. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with CORBA.Repository_Root.Contained.Impl; with CORBA.Repository_Root.ExtAttributeDef; with CORBA.Repository_Root.IDLType.Impl; with CORBA.Repository_Root.InterfaceAttrExtension.Impl; with CORBA.Repository_Root.InterfaceDef.Impl; with CORBA.Repository_Root.IRObject.Impl; package CORBA.Repository_Root.ExtInterfaceDef.Impl is type Object is new InterfaceDef.Impl.Object with private; type Object_Ptr is access all Object'Class; function describe_ext_interface (Self : access Object) return InterfaceAttrExtension.ExtFullInterfaceDescription; function create_ext_attribute (Self : access Object; id : RepositoryId; name : Identifier; version : VersionSpec; IDL_type : IDLType.Ref; mode : AttributeMode; get_exceptions : ExceptionDefSeq; set_exceptions : ExceptionDefSeq) return ExtAttributeDef.Ref; package Internals is procedure Init (Self : access Object'Class; Real_Object : IRObject.Impl.Object_Ptr; Def_Kind : DefinitionKind; Id : RepositoryId; Name : Identifier; Version : VersionSpec; Defined_In : Container_Forward.Ref; Contents : Contained.Impl.Contained_Seq.Sequence; Contained_View : Contained.Impl.Object_Ptr; IDLType_View : IDLType.Impl.Object_Ptr; Base_Interfaces : InterfaceDefSeq; Is_Abstract : Boolean; InterfaceAttrExtension_View : InterfaceAttrExtension.Impl.Object_Ptr); -- Recursively initialize object fields end Internals; private type Object is new InterfaceDef.Impl.Object with record InterfaceAttrExtension_View : InterfaceAttrExtension.Impl.Object_Ptr; end record; end CORBA.Repository_Root.ExtInterfaceDef.Impl; polyorb-2.8~20110207.orig/cos/ir/corba-repository_root-valueboxdef-impl.ads0000644000175000017500000001015011750740337026103 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- CORBA.REPOSITORY_ROOT.VALUEBOXDEF.IMPL -- -- -- -- S p e c -- -- -- -- Copyright (C) 2006-2008, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the CORBA Specification, and adapted -- -- for use with PolyORB. The copyright notice above, and the license -- -- provisions that follow apply solely to the contents neither explicitly -- -- nor implicitly specified by the CORBA Specification defined by the OMG. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with CORBA.Repository_Root.IDLType; with CORBA.Repository_Root.IDLType.Impl; with CORBA.Repository_Root.IRObject.Impl; with CORBA.Repository_Root.TypedefDef.Impl; package CORBA.Repository_Root.ValueBoxDef.Impl is type Object is new CORBA.Repository_Root.TypedefDef.Impl.Object with private; type Object_Ptr is access all Object'Class; -- Transform the forward to an impl.object.ptr. function To_Object (Fw_Ref : ValueBoxDef_Forward.Ref) return Object_Ptr; -- To transform an object_ptr into Forward_ref function To_Forward (Obj : Object_Ptr) return ValueBoxDef_Forward.Ref; -- method used to initialize recursively the object fields. procedure Init (Self : access Object; Real_Object : CORBA.Repository_Root.IRObject.Impl.Object_Ptr; Def_Kind : CORBA.Repository_Root.DefinitionKind; Id : CORBA.RepositoryId; Name : CORBA.Identifier; Version : CORBA.Repository_Root.VersionSpec; Defined_In : CORBA.Repository_Root.Container_Forward.Ref; IDLType_View : CORBA.Repository_Root.IDLType.Impl.Object_Ptr; Original_Type_Def : CORBA.Repository_Root.IDLType.Ref); -- overload the get_type from IDLType function get_type (Self : access Object) return CORBA.TypeCode.Object; function get_original_type_def (Self : access Object) return CORBA.Repository_Root.IDLType.Ref; procedure set_original_type_def (Self : access Object; To : CORBA.Repository_Root.IDLType.Ref); private type Object is new CORBA.Repository_Root.TypedefDef.Impl.Object with record Original_Type_Def : CORBA.Repository_Root.IDLType.Ref; end record; end CORBA.Repository_Root.ValueBoxDef.Impl; polyorb-2.8~20110207.orig/cos/ir/corba-repository_root-abstractinterfacedef-impl.adb0000644000175000017500000000754711750740337027741 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- CORBA.REPOSITORY_ROOT.ABSTRACTINTERFACEDEF.IMPL -- -- -- -- B o d y -- -- -- -- Copyright (C) 2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ package body CORBA.Repository_Root.AbstractInterfaceDef.Impl is package body Internals is function To_InterfaceDefSeq (Item : AbstractInterfaceDefSeq) return InterfaceDefSeq; ---------- -- Init -- ---------- procedure Init (Self : access Object'Class; Real_Object : IRObject.Impl.Object_Ptr; Def_Kind : DefinitionKind; Id : RepositoryId; Name : Identifier; Version : VersionSpec; Defined_In : Container_Forward.Ref; Contents : Contained.Impl.Contained_Seq.Sequence; Contained_View : Contained.Impl.Object_Ptr; IDLType_View : IDLType.Impl.Object_Ptr; Base_Interfaces : AbstractInterfaceDefSeq) is begin InterfaceDef.Impl.Init (InterfaceDef.Impl.Object_Ptr (Self), Real_Object, Def_Kind, Id, Name, Version, Defined_In, Contents, Contained_View, IDLType_View, To_InterfaceDefSeq (Base_Interfaces), True); end Init; ------------------------ -- To_InterfaceDefSeq -- ------------------------ function To_InterfaceDefSeq (Item : AbstractInterfaceDefSeq) return InterfaceDefSeq is Result : InterfaceDefSeq; begin for J in 1 .. Length (Item) loop Append (Result, InterfaceDef.Convert_Forward.To_Forward (InterfaceDef.Ref (AbstractInterfaceDef.Convert_Forward.To_Ref (Get_Element (Item, J))))); end loop; return Result; end To_InterfaceDefSeq; end Internals; end CORBA.Repository_Root.AbstractInterfaceDef.Impl; polyorb-2.8~20110207.orig/cos/ir/corba-repository_root-attributedef-impl.adb0000644000175000017500000001210111750740337026236 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- CORBA.REPOSITORY_ROOT.ATTRIBUTEDEF.IMPL -- -- -- -- B o d y -- -- -- -- Copyright (C) 2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ pragma Style_Checks (Off); with PortableServer; with CORBA.Repository_Root.IDLType.Impl; with CORBA.Repository_Root.Helper; with CORBA.Repository_Root.AttributeDef.Skel; pragma Warnings (Off, CORBA.Repository_Root.AttributeDef.Skel); with PolyORB.CORBA_P.Server_Tools; package body CORBA.Repository_Root.AttributeDef.Impl is ---------------------- -- Procedure init -- ---------------------- procedure Init (Self : access Object; Real_Object : IRObject.Impl.Object_Ptr; Def_Kind : CORBA.Repository_Root.DefinitionKind; Id : CORBA.RepositoryId; Name : CORBA.Identifier; Version : CORBA.Repository_Root.VersionSpec; Defined_In : CORBA.Repository_Root.Container_Forward.Ref; Type_Def : CORBA.Repository_Root.IDLType.Ref; Mode : CORBA.Repository_Root.AttributeMode) is begin Contained.Impl.Init (Contained.Impl.Object_Ptr(Self), Real_Object, Def_Kind, Id, Name, Version, Defined_In); Self.Type_Def := Type_Def; Self.Mode := Mode; end Init; function get_type (Self : access Object) return CORBA.TypeCode.Object is Obj : PortableServer.Servant; begin PolyORB.CORBA_P.Server_Tools.Reference_To_Servant (Self.Type_Def, Obj); -- The type should be the type of the Type_def return IDLType.Impl.Get_Type (IDLType.Impl.To_IDLType (IRObject.Impl.Object_Ptr (Obj))); end get_type; function get_type_def (Self : access Object) return CORBA.Repository_Root.IDLType.Ref is begin return Self.Type_Def; end get_type_def; procedure set_type_def (Self : access Object; To : CORBA.Repository_Root.IDLType.Ref) is begin Self.Type_Def := To; end set_type_def; function get_mode (Self : access Object) return CORBA.Repository_Root.AttributeMode is begin return Self.Mode; end get_mode; procedure set_mode (Self : access Object; To : CORBA.Repository_Root.AttributeMode) is begin Self.Mode := To; end set_mode; ---------------- -- Describe -- ---------------- function describe (Self : access Object) return CORBA.Repository_Root.Contained.Description is Result : CORBA.Repository_Root.Contained.Description; Desc : CORBA.Repository_Root.AttributeDescription; begin Desc := (Name => Get_Name (Self), Id => Get_Id (Self), Defined_In => Get_Defined_In (Self), Version => Get_Version (Self), IDL_Type => Get_Type (Self), Mode => Self.Mode); Result := (Kind => Get_Def_Kind (Self), Value => CORBA.Repository_Root.Helper.To_Any (Desc)); return Result; end describe; end CORBA.Repository_Root.AttributeDef.Impl; polyorb-2.8~20110207.orig/cos/ir/polyorb-corba_p-ir_tools.ads0000644000175000017500000000427011750740337023223 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . C O R B A _ P . I R _ T O O L S -- -- -- -- S p e c -- -- -- -- Copyright (C) 2002-2004 Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by ACT Europe. -- -- (email: sales@act-europe.fr) -- -- -- ------------------------------------------------------------------------------ with CORBA.Repository_Root.Repository; package PolyORB.CORBA_P.IR_Tools is function Get_IR_Root return CORBA.Repository_Root.Repository.Ref; end PolyORB.CORBA_P.IR_Tools; polyorb-2.8~20110207.orig/cos/ir/corba-repository_root-interfacedef-impl.adb0000644000175000017500000003604411750740337026207 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- CORBA.REPOSITORY_ROOT.INTERFACEDEF.IMPL -- -- -- -- B o d y -- -- -- -- Copyright (C) 2005-2007, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ pragma Style_Checks (Off); with CORBA.ORB; with PortableServer; with CORBA.Repository_Root.Helper; with CORBA.Repository_Root.OperationDef.Impl; with CORBA.Repository_Root.AttributeDef.Impl; with CORBA.Repository_Root.InterfaceDef.Skel; pragma Warnings (Off, CORBA.Repository_Root.InterfaceDef.Skel); with PolyORB.Log; pragma Elaborate_All (PolyORB.Log); with PolyORB.CORBA_P.Server_Tools; package body CORBA.Repository_Root.InterfaceDef.Impl is ----------- -- Debug -- ----------- use PolyORB.Log; package L is new PolyORB.Log.Facility_Log ("interfacedef.impl"); procedure O (Message : Standard.String; Level : Log_Level := Debug) renames L.Output; function C (Level : Log_Level := Debug) return Boolean renames L.Enabled; pragma Unreferenced (C); -- For conditional pragma Debug package L2 is new PolyORB.Log.Facility_Log ("interfacedef.impl_method_trace"); procedure O2 (Message : Standard.String; Level : Log_Level := Debug) renames L2.Output; function C2 (Level : Log_Level := Debug) return Boolean renames L2.Enabled; pragma Unreferenced (C2); -- For conditional pragma Debug package IntDef renames IDL_SEQUENCE_CORBA_InterfaceDef_Forward; package IdSeq renames IDL_SEQUENCE_CORBA_RepositoryId; ------------ -- INIT -- ------------ procedure Init (Self : access Object; Real_Object : CORBA.Repository_Root.IRObject.Impl.Object_Ptr; Def_Kind : CORBA.Repository_Root.DefinitionKind; Id : CORBA.RepositoryId; Name : CORBA.Identifier; Version : CORBA.Repository_Root.VersionSpec; Defined_In : CORBA.Repository_Root.Container_Forward.Ref; Contents : CORBA.Repository_Root.Contained.Impl.Contained_Seq.Sequence; Contained_View : CORBA.Repository_Root.Contained.Impl.Object_Ptr; IDLType_View : CORBA.Repository_Root.IDLType.Impl.Object_Ptr; Base_Interfaces : CORBA.Repository_Root.InterfaceDefSeq; Is_Abstract : CORBA.Boolean) is begin pragma Debug (O2 ("init enter")); Container.Impl.Init (Container.Impl.Object_Ptr (Self), Real_Object, Def_Kind, Contents); pragma Debug (O ("init : before contained init")); Contained.Impl.Init (Contained_View, Real_Object, Def_Kind, Id, Name, Version, Defined_In); pragma Debug (O2 ("init : before idltype init")); IDLType.Impl.Init (IDLType_View, Real_Object, Def_Kind); pragma Debug (O2 ("init : after idltype init")); Self.Contained_View := Contained_View; Self.IDLType_View := IDLType_View; Self.Is_Abstract := Is_Abstract; Self.Base_Interfaces := Base_Interfaces; pragma Debug (O2 ("init end")); end Init; ----------------- -- To_Object -- ----------------- function To_Object (Fw_Ref : InterfaceDef_Forward.Ref) return Object_Ptr is Result : Portableserver.Servant; begin PolyORB.CORBA_P.Server_Tools.Reference_To_Servant (InterfaceDef.Convert_Forward.To_Ref (Fw_Ref), Result); return Object_Ptr (Result); end To_Object; ------------------ -- To_Forward -- ------------------ function To_Forward (Obj : Object_Ptr) return InterfaceDef_Forward.Ref is Ref : InterfaceDef.Ref; begin PolyORB.CORBA_P.Server_Tools.Initiate_Servant (PortableServer.Servant (Obj), Ref); return InterfaceDef.Convert_Forward.To_Forward (Ref); end To_Forward; --------------------------------- -- To get the secondary views -- --------------------------------- function Get_Contained_View (Self : access Object) return CORBA.Repository_Root.Contained.Impl.Object_Ptr is begin return Self.Contained_View; end Get_Contained_View; function Get_IDLType_View (Self : access Object) return CORBA.Repository_Root.IDLType.Impl.Object_Ptr is begin return Self.IDLType_View; end Get_IDLType_View; function get_base_interfaces (Self : access Object) return CORBA.Repository_Root.InterfaceDefSeq is begin return Self.Base_Interfaces; end get_base_interfaces; procedure set_base_interfaces (Self : access Object; To : CORBA.Repository_Root.InterfaceDefSeq) is begin Self.Base_Interfaces := To; end set_base_interfaces; function get_is_abstract (Self : access Object) return CORBA.Boolean is begin return Self.Is_Abstract; end get_is_abstract; procedure set_is_abstract (Self : access Object; To : CORBA.Boolean) is begin Self.Is_Abstract := To; end set_is_abstract; function is_a (Self : access Object; interface_id : CORBA.RepositoryId) return CORBA.Boolean is Result : CORBA.Boolean; begin -- Insert implementation of is_a raise Program_Error; return Result; end is_a; function describe_interface (Self : access Object) return CORBA.Repository_Root.InterfaceDef.FullInterfaceDescription is pragma Unreferenced (Self); Result : CORBA.Repository_Root.InterfaceDef.FullInterfaceDescription; pragma Warnings (Off, Result); -- Dummy value, use default initialization begin -- Insert implementation of describe_interface -- XXX not implemented yet raise Program_Error; return Result; end describe_interface; function create_attribute (Self : access Object; id : CORBA.RepositoryId; name : CORBA.Identifier; version : CORBA.Repository_Root.VersionSpec; IDL_type : CORBA.Repository_Root.IDLType.Ref; mode : CORBA.Repository_Root.AttributeMode) return CORBA.Repository_Root.AttributeDef.Ref is begin Check_Structure (Self, Dk_Attribute); Check_Id (Self, Id); Check_Name (Self, Name); declare Result : CORBA.Repository_Root.AttributeDef.Ref; Obj : constant AttributeDef.Impl.Object_Ptr := new AttributeDef.Impl.Object; begin -- initialization of the object AttributeDef.Impl.Init (Obj, IRObject.Impl.Object_Ptr (Obj), Dk_Attribute, Id, Name, Version, Container.Impl.To_Forward (Container.Impl.Object_Ptr (Self)), IDL_Type, Mode); -- add it to the contents field of this container Container.Impl.Append_To_Contents (Container.Impl.Object_Ptr (Self), Contained.Impl.To_Contained (IRObject.Impl.Object_Ptr (Obj))); -- activate it PolyORB.CORBA_P.Server_Tools.Initiate_Servant (PortableServer.Servant (Obj), Result); return Result; end; end create_attribute; function create_operation (Self : access Object; id : CORBA.RepositoryId; name : CORBA.Identifier; version : CORBA.Repository_Root.VersionSpec; IDL_result : CORBA.Repository_Root.IDLType.Ref; mode : CORBA.Repository_Root.OperationMode; params : CORBA.Repository_Root.ParDescriptionSeq; exceptions : CORBA.Repository_Root.ExceptionDefSeq; contexts : CORBA.Repository_Root.ContextIdSeq) return CORBA.Repository_Root.OperationDef.Ref is begin Check_Structure (Self, Dk_Operation); Check_Id (Self, Id); Check_Name (Self, Name); declare Result : CORBA.Repository_Root.OperationDef.Ref; Obj : constant OperationDef.Impl.Object_Ptr := new OperationDef.Impl.Object; begin -- initialization of the object OperationDef.Impl.Init (Obj, IRObject.Impl.Object_Ptr (Obj), Dk_Operation, Id, Name, Version, Container.Impl.To_Forward (Container.Impl.Object_Ptr (Self)), IDL_Result, Params, Mode, Contexts, Exceptions); -- add it to the contents field of this container Container.Impl.Append_To_Contents (Container.Impl.Object_Ptr (Self), Contained.Impl.To_Contained (IRObject.Impl.Object_Ptr (Obj))); -- activate it PolyORB.CORBA_P.Server_Tools.Initiate_Servant (PortableServer.Servant (Obj), Result); return Result; end; end create_operation; -------------------------------- -- inherited from contained -- -------------------------------- function get_id (Self : access Object) return CORBA.RepositoryId is begin return Contained.Impl.Get_Id (Self.Contained_View); end get_id; procedure set_id (Self : access Object; To : CORBA.RepositoryId) is begin Contained.Impl.Set_Id (Self.Contained_View, To); end set_id; function get_name (Self : access Object) return CORBA.Identifier is begin return Contained.Impl.Get_Name (Self.Contained_View); end get_name; procedure set_name (Self : access Object; To : CORBA.Identifier) is begin Contained.Impl.Set_Name (Self.Contained_View, To); end set_name; function get_version (Self : access Object) return CORBA.Repository_Root.VersionSpec is begin return Contained.Impl.Get_Version (Self.Contained_View); end get_version; procedure set_version (Self : access Object; To : CORBA.Repository_Root.VersionSpec) is begin Contained.Impl.Set_Version (Self.Contained_View, To); end set_version; function get_defined_in (Self : access Object) return CORBA.Repository_Root.Container_Forward.Ref is begin return Contained.Impl.Get_Defined_In (Self.Contained_View); end get_defined_in; function get_absolute_name (Self : access Object) return CORBA.ScopedName is begin return Contained.Impl.Get_Absolute_Name (Self.Contained_View); end get_absolute_name; function get_containing_repository (Self : access Object) return CORBA.Repository_Root.Repository_Forward.Ref is begin return Contained.Impl.Get_Containing_Repository (Self.Contained_View); end get_containing_repository; function describe (Self : access Object) return CORBA.Repository_Root.Contained.Description is Result : CORBA.Repository_Root.Contained.Description; Desc : CORBA.Repository_Root.InterfaceDescription; begin Desc := (Name => Get_Name (Self), Id => Get_Id (Self), Defined_In => Contained.Impl.Get_Defined_In (Self.Contained_View), Version => Get_Version (Self), Base_Interfaces => Get_RepositoryIdSeq (Self.Base_Interfaces), Is_Abstract => Self.Is_Abstract); Result := (Kind => Get_Def_Kind (Self), Value => CORBA.Repository_Root.Helper.To_Any (Desc)); return Result; end describe; procedure move (Self : access Object; new_container : CORBA.Repository_Root.Container_Forward.Ref; new_name : CORBA.Identifier; new_version : CORBA.Repository_Root.VersionSpec) is begin Contained.Impl.Move (Self.Contained_View, New_Container, New_Name, New_Version); end move; ---------------------------- -- Inherited from IDLType -- ---------------------------- function get_type (Self : access Object) return CORBA.TypeCode.Object is begin return CORBA.ORB.Create_Interface_Tc (Get_Id (Self), Get_Name (Self)); end get_type; ------------------------- -- Get_RepositoryIdSeq -- ------------------------- function Get_RepositoryIdSeq (IntDefSeq : InterfaceDefSeq) return RepositoryIdSeq is Result : RepositoryIdSeq; Int_Array : constant IntDef.Element_Array := IntDef.To_Element_Array (IntDef.Sequence (IntDefSeq)); begin for I in Int_Array'Range loop declare Int : constant Object_Ptr := To_Object (Int_Array (I)); begin IdSeq.Append (IdSeq.Sequence (Result), Get_Id (Int)); end; end loop; return Result; end Get_RepositoryIdSeq; end CORBA.Repository_Root.InterfaceDef.Impl; polyorb-2.8~20110207.orig/cos/ir/corba-repository_root-idltype-impl.adb0000644000175000017500000001741511750740337025243 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- C O R B A . R E P O S I T O R Y _ R O O T . I D L T Y P E . I M P L -- -- -- -- B o d y -- -- -- -- Copyright (C) 2006-2007, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ pragma Style_Checks (Off); with CORBA.Repository_Root.Interfacedef.Impl; with CORBA.Repository_Root.Valuedef.Impl; with CORBA.Repository_Root.UnionDef.Impl; with CORBA.Repository_Root.StructDef.Impl; with CORBA.Repository_Root.EnumDef.Impl; with CORBA.Repository_Root.AliasDef.Impl; with CORBA.Repository_Root.NativeDef.Impl; with CORBA.Repository_Root.ValueBoxDef.Impl; with CORBA.Repository_Root.TypedefDef.Impl; with CORBA.Repository_Root.IDLType.Skel; pragma Warnings (Off, CORBA.Repository_Root.IDLType.Skel); package body CORBA.Repository_Root.IDLType.Impl is ------------------ -- To_IDLType -- ------------------ function To_IDLType (Self : IRObject.Impl.Object_Ptr) return Object_ptr is begin case IRObject.Impl.Get_Def_Kind (Self) is when Dk_Repository | Dk_Attribute | dk_ValueMember| Dk_Typedef | Dk_Constant | Dk_Operation | Dk_Exception | Dk_Module | Dk_All | Dk_None => CORBA.Raise_Internal (CORBA.Default_Sys_Member); return null; when -- inherited types Dk_Primitive | Dk_String | Dk_Sequence | Dk_Array | Dk_Wstring | Dk_Fixed => return Object_Ptr (Self); -- types containing a "idltype_view" field when Dk_Alias | Dk_Struct | Dk_Union | Dk_Enum | Dk_ValueBox | dk_Native => declare Interm : constant TypedefDef.Impl.Object_Ptr := TypedefDef.Impl.Object_Ptr (Self); begin return TypedefDef.Impl.Get_IDLType_View (Interm); end; when Dk_Value => declare Interm : constant Valuedef.Impl.Object_Ptr := Valuedef.Impl.Object_Ptr (Self); begin return Valuedef.Impl.Get_IDLType_View (Interm); end; when Dk_Interface => declare Interm : constant Interfacedef.Impl.Object_Ptr := Interfacedef.Impl.Object_Ptr (Self); begin return Interfacedef.Impl.Get_IDLType_View (Interm); end; when Dk_AbstractInterface .. Dk_Event => raise Program_Error; end case; end To_IDLType; ---------------------- -- Procedure init -- ---------------------- -- procedure Init (Self : access Object; -- Real_Object : IRObject.Impl.Object_Ptr; -- Def_Kind : CORBA.Repository_Root.DefinitionKind) is -- begin -- pragma Debug (O2 ("init enter")); -- IRObject.Impl.Init (IRObject.Impl.Object_Ptr (Self), -- Real_Object, -- Def_Kind); -- pragma Debug (O2 ("init end")); -- end Init; function get_type (Self : access Object) return CORBA.TypeCode.Object is begin -- we are going to dispatch manually this call case Get_Def_Kind (Self) is when Dk_Primitive | Dk_String | Dk_Sequence | Dk_Array | Dk_Wstring | Dk_Fixed => -- dispatching call return Get_Type (Object_Ptr (Self)); when Dk_Interface => declare Interm : constant Interfacedef.Impl.Object_Ptr := Interfacedef.Impl.Object_Ptr (Get_Real_Object (Self)); begin return Interfacedef.Impl.Get_Type (Interm); end; when Dk_Value => declare Interm : constant Valuedef.Impl.Object_Ptr := Valuedef.Impl.Object_Ptr (Get_Real_Object (Self)); begin return Valuedef.Impl.Get_Type (Interm); end; when Dk_Struct => declare Interm : constant Structdef.Impl.Object_Ptr := Structdef.Impl.Object_Ptr (Get_Real_Object (Self)); begin return Structdef.Impl.Get_Type (Interm); end; when Dk_Union => declare Interm : constant Uniondef.Impl.Object_Ptr := Uniondef.Impl.Object_Ptr (Get_Real_Object (Self)); begin return Uniondef.Impl.Get_Type (Interm); end; when Dk_Enum => declare Interm : constant Enumdef.Impl.Object_Ptr := Enumdef.Impl.Object_Ptr (Get_Real_Object (Self)); begin return Enumdef.Impl.Get_Type (Interm); end; when Dk_Alias => declare Interm : constant Aliasdef.Impl.Object_Ptr := Aliasdef.Impl.Object_Ptr (Get_Real_Object (Self)); begin return Aliasdef.Impl.Get_Type (Interm); end; when Dk_Native => declare Interm : constant Nativedef.Impl.Object_Ptr := Nativedef.Impl.Object_Ptr (Get_Real_Object (Self)); begin return Nativedef.Impl.Get_Type (Interm); end; when Dk_ValueBox => declare Interm : constant ValueBoxdef.Impl.Object_Ptr := ValueBoxdef.Impl.Object_Ptr (Get_Real_Object (Self)); begin return ValueBoxdef.Impl.Get_Type (Interm); end; when others => CORBA.Raise_Internal (Default_Sys_Member); return CORBA.TC_Void; end case; end get_type; end CORBA.Repository_Root.IDLType.Impl; polyorb-2.8~20110207.orig/cos/ir/corba-repository_root-stringdef-impl.adb0000644000175000017500000000634611750740337025557 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- CORBA.REPOSITORY_ROOT.STRINGDEF.IMPL -- -- -- -- B o d y -- -- -- -- Copyright (C) 2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with CORBA.ORB; with CORBA.Repository_Root.StringDef.Skel; pragma Warnings (Off, CORBA.Repository_Root.StringDef.Skel); package body CORBA.Repository_Root.StringDef.Impl is ---------------------- -- Procedure init -- ---------------------- procedure Init (Self : access Object; Real_Object : CORBA.Repository_Root.IRObject.Impl.Object_Ptr; Def_Kind : CORBA.Repository_Root.DefinitionKind; Bound : CORBA.Unsigned_Long) is begin IDLType.Impl.Init (IDLType.Impl.Object_Ptr (Self), Real_Object, Def_Kind); Self.Bound := Bound; end Init; ---------------- -- get_type -- ---------------- function get_type (Self : access Object) return CORBA.TypeCode.Object is begin return CORBA.ORB.Create_String_Tc (Self.Bound); end get_type; function get_bound (Self : access Object) return CORBA.Unsigned_Long is begin return Self.Bound; end get_bound; procedure set_bound (Self : access Object; To : CORBA.Unsigned_Long) is begin Self.Bound := To; end set_bound; end CORBA.Repository_Root.StringDef.Impl; polyorb-2.8~20110207.orig/cos/ir/corba-repository_root-enumdef-impl.ads0000644000175000017500000001002711750740337025225 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- C O R B A . R E P O S I T O R Y _ R O O T . E N U M D E F . I M P L -- -- -- -- S p e c -- -- -- -- Copyright (C) 2006-2008, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the CORBA Specification, and adapted -- -- for use with PolyORB. The copyright notice above, and the license -- -- provisions that follow apply solely to the contents neither explicitly -- -- nor implicitly specified by the CORBA Specification defined by the OMG. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with CORBA.Repository_Root.IRObject.Impl; with CORBA.Repository_Root.IDLType.Impl; with CORBA.Repository_Root.TypedefDef.Impl; package CORBA.Repository_Root.EnumDef.Impl is type Object is new CORBA.Repository_Root.TypedefDef.Impl.Object with private; type Object_Ptr is access all Object'Class; -- To transform a forward_ref in impl.object_ptr. function To_Object (Fw_Ref : EnumDef_Forward.Ref) return Object_Ptr; -- To transform an object_ptr into Forward_ref function To_Forward (Obj : Object_Ptr) return EnumDef_Forward.Ref; -- method used to initialize recursively the object fields. procedure Init (Self : access Object; Real_Object : CORBA.Repository_Root.IRObject.Impl.Object_Ptr; Def_Kind : CORBA.Repository_Root.DefinitionKind; Id : CORBA.RepositoryId; Name : CORBA.Identifier; Version : CORBA.Repository_Root.VersionSpec; Defined_In : CORBA.Repository_Root.Container_Forward.Ref; IDLType_View : CORBA.Repository_Root.IDLType.Impl.Object_Ptr; Members : CORBA.Repository_Root.EnumMemberSeq); -- overload the get_type from IDLType function get_type (Self : access Object) return CORBA.TypeCode.Object; function get_members (Self : access Object) return CORBA.Repository_Root.EnumMemberSeq; procedure set_members (Self : access Object; To : CORBA.Repository_Root.EnumMemberSeq); private type Object is new CORBA.Repository_Root.TypedefDef.Impl.Object with record Members : CORBA.Repository_Root.EnumMemberSeq; end record; end CORBA.Repository_Root.EnumDef.Impl; polyorb-2.8~20110207.orig/cos/ir/corba-repository_root-extlocalinterfacedef-impl.adb0000644000175000017500000001152511750740337027740 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- CORBA.REPOSITORY_ROOT.EXTLOCALINTERFACEDEF.IMPL -- -- -- -- B o d y -- -- -- -- Copyright (C) 2006-2008, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with CORBA.Repository_Root.IDLType; with CORBA.Repository_Root.InterfaceAttrExtension; with CORBA.Repository_Root.ExtLocalInterfaceDef.Skel; pragma Warnings (Off, CORBA.Repository_Root.ExtLocalInterfaceDef.Skel); package body CORBA.Repository_Root.ExtLocalInterfaceDef.Impl is -------------------------- -- create_ext_attribute -- -------------------------- function create_ext_attribute (Self : access Object; id : RepositoryId; name : Identifier; version : VersionSpec; IDL_type : IDLType.Ref; mode : AttributeMode; get_exceptions : ExceptionDefSeq; set_exceptions : ExceptionDefSeq) return ExtAttributeDef.Ref is begin return InterfaceAttrExtension.Impl.create_ext_attribute (Self.InterfaceAttrExtension_View, id, name, version, IDL_type, mode, get_exceptions, set_exceptions); end create_ext_attribute; ---------------------------- -- describe_ext_interface -- ---------------------------- function describe_ext_interface (Self : access Object) return InterfaceAttrExtension.ExtFullInterfaceDescription is begin return InterfaceAttrExtension.Impl.describe_ext_interface (Self.InterfaceAttrExtension_View); end describe_ext_interface; package body Internals is ---------- -- Init -- ---------- procedure Init (Self : access Object'Class; Real_Object : IRObject.Impl.Object_Ptr; Def_Kind : DefinitionKind; Id : RepositoryId; Name : Identifier; Version : VersionSpec; Defined_In : Container_Forward.Ref; Contents : Contained.Impl.Contained_Seq.Sequence; Contained_View : Contained.Impl.Object_Ptr; IDLType_View : IDLType.Impl.Object_Ptr; Base_Interfaces : InterfaceDefSeq; InterfaceAttrExtension_View : InterfaceAttrExtension.Impl.Object_Ptr) is begin LocalInterfaceDef.Impl.Internals.Init (LocalInterfaceDef.Impl.Object_Ptr (Self), Real_Object, Def_Kind, Id, Name, Version, Defined_In, Contents, Contained_View, IDLType_View, Base_Interfaces); InterfaceAttrExtension.Impl.Internals.Init (InterfaceAttrExtension_View, Real_Object); Self.InterfaceAttrExtension_View := InterfaceAttrExtension_View; end Init; end Internals; end CORBA.Repository_Root.ExtLocalInterfaceDef.Impl; polyorb-2.8~20110207.orig/cos/ir/corba-repository_root-constantdef-impl.adb0000644000175000017500000001407411750740337026077 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- CORBA.REPOSITORY_ROOT.CONSTANTDEF.IMPL -- -- -- -- B o d y -- -- -- -- Copyright (C) 2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ pragma Style_Checks (Off); with PortableServer; with CORBA.Repository_Root.IDLType.Impl; with CORBA.Repository_Root.Helper; with CORBA.Repository_Root.ConstantDef.Skel; pragma Warnings (Off, CORBA.Repository_Root.ConstantDef.Skel); with PolyORB.CORBA_P.Server_Tools; package body CORBA.Repository_Root.ConstantDef.Impl is ----------------- -- To_Object -- ----------------- function To_Object (Fw_Ref : ConstantDef_Forward.Ref) return Object_Ptr is Result : Portableserver.Servant; begin PolyORB.CORBA_P.Server_Tools.Reference_To_Servant (ConstantDef.Convert_Forward.To_Ref (Fw_Ref), Result); return Object_Ptr (Result); end To_Object; ------------------ -- To_Forward -- ------------------ function To_Forward (Obj : Object_Ptr) return ConstantDef_Forward.Ref is Ref : ConstantDef.Ref; begin PolyORB.CORBA_P.Server_Tools.Initiate_Servant (PortableServer.Servant (Obj), Ref); return ConstantDef.Convert_Forward.To_Forward (Ref); end To_Forward; ---------------------- -- Procedure init -- ---------------------- procedure Init (Self : access Object; Real_Object : IRObject.Impl.Object_Ptr; Def_Kind : CORBA.Repository_Root.DefinitionKind; Id : CORBA.RepositoryId; Name : CORBA.Identifier; Version : CORBA.Repository_Root.VersionSpec; Defined_In : CORBA.Repository_Root.Container_Forward.Ref; Type_Def : CORBA.Repository_Root.IDLType.Ref; Value : CORBA.Any) is begin Contained.Impl.Init (Contained.Impl.Object_Ptr(Self), Real_Object, Def_Kind, Id, Name, Version, Defined_In); Self.Type_Def := Type_Def; Set_Value (Self, Value); end Init; function get_type (Self : access Object) return CORBA.TypeCode.Object is Obj : Portableserver.Servant; begin PolyORB.CORBA_P.Server_Tools.Reference_To_Servant (Self.Type_Def, Obj); -- The type should be the type of the Type_def return IDLType.Impl.Get_Type (IDLType.Impl.To_IDLType (IRObject.Impl.Object_Ptr (Obj))); end get_type; function get_type_def (Self : access Object) return CORBA.Repository_Root.IDLType.Ref is begin return Self.Type_Def; end get_type_def; procedure set_type_def (Self : access Object; To : CORBA.Repository_Root.IDLType.Ref) is begin Self.Type_Def := To; end set_type_def; function get_value (Self : access Object) return CORBA.Any is begin return Self.Value; end get_value; procedure set_value (Self : access Object; To : CORBA.Any) is use CORBA.Typecode; begin if CORBA.Get_Type (Self.Value) = Get_Type (Self) then Self.Value := To; else CORBA.Raise_Bad_Param (CORBA.System_Exception_Members' (Minor => 2, Completed => CORBA.Completed_No)); end if; end set_value; ---------------- -- Describe -- ---------------- function describe (Self : access Object) return CORBA.Repository_Root.Contained.Description is Result : CORBA.Repository_Root.Contained.Description; Desc : CORBA.Repository_Root.ConstantDescription; begin Desc := (Name => Get_Name (Self), Id => Get_Id (Self), Defined_In => Get_Defined_In (Self), Version => Get_Version (Self), IDL_Type => Get_Type (Self), Value => Self.Value); Result := (Kind => Get_Def_Kind (Self), Value => CORBA.Repository_Root.Helper.To_Any (Desc)); return Result; end describe; end CORBA.Repository_Root.ConstantDef.Impl; polyorb-2.8~20110207.orig/cos/ir/polyorb-corba_p-ir_tools.adb0000644000175000017500000000773411750740337023212 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . C O R B A _ P . I R _ T O O L S -- -- -- -- B o d y -- -- -- -- Copyright (C) 2002-2008, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with PolyORB.Initialization; with PolyORB.Utils.Strings; with CORBA.Object; with CORBA.ORB; with CORBA.Repository_Root.Repository.Helper; with PolyORB.CORBA_P.IR_Hooks; package body PolyORB.CORBA_P.IR_Tools is function Get_Interface_Definition (Id : CORBA.RepositoryId) return CORBA.Object.Ref'Class; -- Actual implementation of the Interface Repository hook routine -- to be used when the Interface Repository is available. procedure Initialize; Repo_Root_Ref : CORBA.Repository_Root.Repository.Ref; ---------------- -- Initialize -- ---------------- procedure Initialize is begin PolyORB.CORBA_P.IR_Hooks.Get_Interface_Definition := Get_Interface_Definition'Access; end Initialize; ------------------------------ -- Get_Interface_Definition -- ------------------------------ function Get_Interface_Definition (Id : CORBA.RepositoryId) return CORBA.Object.Ref'Class is begin return CORBA.Repository_Root.Repository.lookup_id (Get_IR_Root, Id); end Get_Interface_Definition; ----------------- -- Get_IR_Root -- ----------------- function Get_IR_Root return CORBA.Repository_Root.Repository.Ref is begin if CORBA.Repository_Root.Repository.Is_Nil (Repo_Root_Ref) then Repo_Root_Ref := CORBA.Repository_Root.Repository.Helper.To_Ref (CORBA.ORB.Resolve_Initial_References (CORBA.ORB.To_CORBA_String ("InterfaceRepository"))); end if; return Repo_Root_Ref; end Get_IR_Root; begin declare use PolyORB.Initialization; use PolyORB.Initialization.String_Lists; use PolyORB.Utils.Strings; begin Register_Module (Module_Info' (Name => +"corba_p.ir_tools", Conflicts => Empty, Depends => Empty, Provides => Empty, Implicit => False, Init => Initialize'Access, Shutdown => null)); end; end PolyORB.CORBA_P.IR_Tools; polyorb-2.8~20110207.orig/cos/ir/corba-repository_root-localinterfacedef-impl.adb0000644000175000017500000000616511750740337027223 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- CORBA.REPOSITORY_ROOT.LOCALINTERFACEDEF.IMPL -- -- -- -- B o d y -- -- -- -- Copyright (C) 2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ package body CORBA.Repository_Root.LocalInterfaceDef.Impl is package body Internals is ---------- -- Init -- ---------- procedure Init (Self : access Object'Class; Real_Object : IRObject.Impl.Object_Ptr; Def_Kind : DefinitionKind; Id : RepositoryId; Name : Identifier; Version : VersionSpec; Defined_In : Container_Forward.Ref; Contents : Contained.Impl.Contained_Seq.Sequence; Contained_View : Contained.Impl.Object_Ptr; IDLType_View : IDLType.Impl.Object_Ptr; Base_Interfaces : InterfaceDefSeq) is begin InterfaceDef.Impl.Init (InterfaceDef.Impl.Object_Ptr (Self), Real_Object, Def_Kind, Id, Name, Version, Defined_In, Contents, Contained_View, IDLType_View, Base_Interfaces, False); end Init; end Internals; end CORBA.Repository_Root.LocalInterfaceDef.Impl; polyorb-2.8~20110207.orig/cos/ir/corba-repository_root-operationdef-impl.adb0000644000175000017500000001440411750740337026243 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- CORBA.REPOSITORY_ROOT.OPERATIONDEF.IMPL -- -- -- -- B o d y -- -- -- -- Copyright (C) 2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ pragma Style_Checks (Off); with CORBA.Repository_Root.Helper; with CORBA.Repository_Root.ExceptionDef.Impl; with CORBA.Repository_Root.OperationDef.Skel; pragma Warnings (Off, CORBA.Repository_Root.OperationDef.Skel); package body CORBA.Repository_Root.OperationDef.Impl is ---------------------- -- Procedure init -- ---------------------- procedure Init (Self : access Object; Real_Object : CORBA.Repository_Root.IRObject.Impl.Object_Ptr; Def_Kind : CORBA.Repository_Root.DefinitionKind; Id : CORBA.RepositoryId; Name : CORBA.Identifier; Version : CORBA.Repository_Root.VersionSpec; Defined_In : CORBA.Repository_Root.Container_Forward.Ref; Result_Def : CORBA.Repository_Root.IDLType.Ref; Params : CORBA.Repository_Root.ParDescriptionSeq; Mode : CORBA.Repository_Root.OperationMode; Contexts : CORBA.Repository_Root.ContextIdSeq; Exceptions : CORBA.Repository_Root.ExceptionDefSeq) is begin Contained.Impl.Init (Contained.Impl.Object_Ptr(Self), Real_Object, Def_Kind, Id, Name, Version, Defined_In); Self.Result_Def := Result_Def; Self.Params := Params; Self.Mode := Mode; Self.Contexts := Contexts; Self.Exceptions := Exceptions; end Init; function get_result (Self : access Object) return CORBA.TypeCode.Object is begin return IDLType.Get_Type (get_result_def (Self)); end get_result; function get_result_def (Self : access Object) return CORBA.Repository_Root.IDLType.Ref is begin return Self.Result_Def; end get_result_def; procedure set_result_def (Self : access Object; To : CORBA.Repository_Root.IDLType.Ref) is begin Self.Result_Def := To; end set_result_def; function get_params (Self : access Object) return CORBA.Repository_Root.ParDescriptionSeq is begin return Self.Params; end get_params; procedure set_params (Self : access Object; To : CORBA.Repository_Root.ParDescriptionSeq) is begin Self.Params := To; end set_params; function get_mode (Self : access Object) return CORBA.Repository_Root.OperationMode is begin return Self.Mode; end get_mode; procedure set_mode (Self : access Object; To : CORBA.Repository_Root.OperationMode) is begin Self.Mode := To; end set_mode; function get_contexts (Self : access Object) return CORBA.Repository_Root.ContextIdSeq is begin return Self.Contexts; end get_contexts; procedure set_contexts (Self : access Object; To : CORBA.Repository_Root.ContextIdSeq) is begin Self.Contexts := To; end set_contexts; function get_exceptions (Self : access Object) return CORBA.Repository_Root.ExceptionDefSeq is begin return Self.Exceptions; end get_exceptions; procedure set_exceptions (Self : access Object; To : CORBA.Repository_Root.ExceptionDefSeq) is begin Self.Exceptions := To; end set_exceptions; ---------------- -- Describe -- ---------------- function describe (Self : access Object) return CORBA.Repository_Root.Contained.Description is Result : CORBA.Repository_Root.Contained.Description; Desc : CORBA.Repository_Root.OperationDescription; begin Desc := (Name => Get_Name (Self), Id => Get_Id (Self), Defined_In => Get_Defined_In (Self), Version => Get_Version (Self), Result => Get_Result (Self), Mode => Self.Mode, Contexts => Self.Contexts, Parameters => Self.Params, Exceptions => ExceptionDef.Impl.Get_ExcDescriptionSeq (Self.Exceptions)); Result := (Kind => Get_Def_Kind (Self), Value => CORBA.Repository_Root.Helper.To_Any (Desc)); return Result; end describe; end CORBA.Repository_Root.OperationDef.Impl; polyorb-2.8~20110207.orig/cos/ir/corba-repository_root-constantdef-impl.ads0000644000175000017500000001066011750740337026115 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- CORBA.REPOSITORY_ROOT.CONSTANTDEF.IMPL -- -- -- -- S p e c -- -- -- -- Copyright (C) 2006-2008, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the CORBA Specification, and adapted -- -- for use with PolyORB. The copyright notice above, and the license -- -- provisions that follow apply solely to the contents neither explicitly -- -- nor implicitly specified by the CORBA Specification defined by the OMG. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with CORBA.Repository_Root.IDLType; with CORBA.Repository_Root.IRObject.Impl; with CORBA.Repository_Root.Contained.Impl; package CORBA.Repository_Root.ConstantDef.Impl is type Object is new CORBA.Repository_Root.Contained.Impl.Object with private; type Object_Ptr is access all Object'Class; -- To transform a forward_ref in impl.object_ptr. function To_Object (Fw_Ref : ConstantDef_Forward.Ref) return Object_Ptr; -- To transform an object_ptr into Forward_ref function To_Forward (Obj : Object_Ptr) return ConstantDef_Forward.Ref; -- method used to initialize recursively the object fields. procedure Init (Self : access Object; Real_Object : CORBA.Repository_Root.IRObject.Impl.Object_Ptr; Def_Kind : CORBA.Repository_Root.DefinitionKind; Id : CORBA.RepositoryId; Name : CORBA.Identifier; Version : CORBA.Repository_Root.VersionSpec; Defined_In : CORBA.Repository_Root.Container_Forward.Ref; Type_Def : CORBA.Repository_Root.IDLType.Ref; Value : CORBA.Any); function get_type (Self : access Object) return CORBA.TypeCode.Object; function get_type_def (Self : access Object) return CORBA.Repository_Root.IDLType.Ref; procedure set_type_def (Self : access Object; To : CORBA.Repository_Root.IDLType.Ref); function get_value (Self : access Object) return CORBA.Any; procedure set_value (Self : access Object; To : CORBA.Any); -- override this from contained function describe (Self : access Object) return CORBA.Repository_Root.Contained.Description; private type Object is new CORBA.Repository_Root.Contained.Impl.Object with record Type_Def : CORBA.Repository_Root.IDLType.Ref; -- the Type attribute is the Type of the value Value : CORBA.Any; end record; end CORBA.Repository_Root.ConstantDef.Impl; polyorb-2.8~20110207.orig/cos/ir/corba-repository_root-extlocalinterfacedef-impl.ads0000644000175000017500000001057111750740337027761 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- CORBA.REPOSITORY_ROOT.EXTLOCALINTERFACEDEF.IMPL -- -- -- -- S p e c -- -- -- -- Copyright (C) 2006-2008, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the CORBA Specification, and adapted -- -- for use with PolyORB. The copyright notice above, and the license -- -- provisions that follow apply solely to the contents neither explicitly -- -- nor implicitly specified by the CORBA Specification defined by the OMG. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with CORBA.Repository_Root.Contained.Impl; with CORBA.Repository_Root.ExtAttributeDef; with CORBA.Repository_Root.IDLType.Impl; with CORBA.Repository_Root.InterfaceAttrExtension.Impl; with CORBA.Repository_Root.IRObject.Impl; with CORBA.Repository_Root.LocalInterfaceDef.Impl; package CORBA.Repository_Root.ExtLocalInterfaceDef.Impl is type Object is new LocalInterfaceDef.Impl.Object with private; type Object_Ptr is access all Object'Class; function describe_ext_interface (Self : access Object) return InterfaceAttrExtension.ExtFullInterfaceDescription; function create_ext_attribute (Self : access Object; id : RepositoryId; name : Identifier; version : VersionSpec; IDL_type : IDLType.Ref; mode : AttributeMode; get_exceptions : ExceptionDefSeq; set_exceptions : ExceptionDefSeq) return ExtAttributeDef.Ref; package Internals is procedure Init (Self : access Object'Class; Real_Object : IRObject.Impl.Object_Ptr; Def_Kind : DefinitionKind; Id : RepositoryId; Name : Identifier; Version : VersionSpec; Defined_In : Container_Forward.Ref; Contents : Contained.Impl.Contained_Seq.Sequence; Contained_View : Contained.Impl.Object_Ptr; IDLType_View : IDLType.Impl.Object_Ptr; Base_Interfaces : InterfaceDefSeq; InterfaceAttrExtension_View : InterfaceAttrExtension.Impl.Object_Ptr); -- Recursively initialize object fields end Internals; private type Object is new LocalInterfaceDef.Impl.Object with record InterfaceAttrExtension_View : InterfaceAttrExtension.Impl.Object_Ptr; end record; end CORBA.Repository_Root.ExtLocalInterfaceDef.Impl; polyorb-2.8~20110207.orig/cos/ir/corba-repository_root-wstringdef-impl.adb0000644000175000017500000000635511750740337025746 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- CORBA.REPOSITORY_ROOT.WSTRINGDEF.IMPL -- -- -- -- B o d y -- -- -- -- Copyright (C) 2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with CORBA.ORB; with CORBA.Repository_Root.WstringDef.Skel; pragma Warnings (Off, CORBA.Repository_Root.WstringDef.Skel); package body CORBA.Repository_Root.WstringDef.Impl is ---------------------- -- Procedure init -- ---------------------- procedure Init (Self : access Object; Real_Object : CORBA.Repository_Root.IRObject.Impl.Object_Ptr; Def_Kind : CORBA.Repository_Root.DefinitionKind; Bound : CORBA.Unsigned_Long) is begin IDLType.Impl.Init (IDLType.Impl.Object_Ptr (Self), Real_Object, Def_Kind); Self.Bound := Bound; end Init; ---------------- -- get_type -- ---------------- function get_type (Self : access Object) return CORBA.TypeCode.Object is begin return CORBA.ORB.Create_Wstring_Tc (Self.Bound); end get_type; function get_bound (Self : access Object) return CORBA.Unsigned_Long is begin return Self.Bound; end get_bound; procedure set_bound (Self : access Object; To : CORBA.Unsigned_Long) is begin Self.Bound := To; end set_bound; end CORBA.Repository_Root.WstringDef.Impl; polyorb-2.8~20110207.orig/cos/ir/corba-repository_root-arraydef-impl.adb0000644000175000017500000001026611750740337025363 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- C O R B A . R E P O S I T O R Y _ R O O T . A R R A Y D E F . I M P L -- -- -- -- B o d y -- -- -- -- Copyright (C) 2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with CORBA.ORB; with PortableServer; with CORBA.Repository_Root.ArrayDef.Skel; pragma Warnings (Off, CORBA.Repository_Root.ArrayDef.Skel); with PolyORB.CORBA_P.Server_Tools; package body CORBA.Repository_Root.ArrayDef.Impl is ---------------------- -- Procedure init -- ---------------------- procedure Init (Self : access Object; Real_Object : CORBA.Repository_Root.IRObject.Impl.Object_Ptr; Def_Kind : CORBA.Repository_Root.DefinitionKind; Length : CORBA.Unsigned_Long; Element_Type_Def : CORBA.Repository_Root.IDLType.Ref) is begin IDLType.Impl.Init (IDLType.Impl.Object_Ptr (Self), Real_Object, Def_Kind); Self.Length := Length; Self.Element_Type_Def := Element_Type_Def; end Init; ---------------- -- get_type -- ---------------- function get_type (Self : access Object) return CORBA.TypeCode.Object is begin return CORBA.ORB.Create_Array_Tc (Self.Length, get_element_type (Self)); end get_type; function get_length (Self : access Object) return CORBA.Unsigned_Long is begin return Self.Length; end get_length; procedure set_length (Self : access Object; To : CORBA.Unsigned_Long) is begin Self.Length := To; end set_length; function get_element_type (Self : access Object) return CORBA.TypeCode.Object is Obj : PortableServer.Servant; begin PolyORB.CORBA_P.Server_Tools.Reference_To_Servant (Self.Element_Type_Def, Obj); return IDLType.Impl.get_type (IDLType.Impl.To_IDLType (IRObject.Impl.Object_Ptr (Obj))); end get_element_type; function get_element_type_def (Self : access Object) return CORBA.Repository_Root.IDLType.Ref is begin return Self.Element_Type_Def; end get_element_type_def; procedure set_element_type_def (Self : access Object; To : CORBA.Repository_Root.IDLType.Ref) is begin Self.Element_Type_Def := To; end set_element_type_def; end CORBA.Repository_Root.ArrayDef.Impl; polyorb-2.8~20110207.orig/cos/ir/corba-repository_root-fixeddef-impl.ads0000644000175000017500000000725611750740337025372 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- C O R B A . R E P O S I T O R Y _ R O O T . F I X E D D E F . I M P L -- -- -- -- S p e c -- -- -- -- Copyright (C) 2006-2008, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the CORBA Specification, and adapted -- -- for use with PolyORB. The copyright notice above, and the license -- -- provisions that follow apply solely to the contents neither explicitly -- -- nor implicitly specified by the CORBA Specification defined by the OMG. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with CORBA.Repository_Root.IRObject.Impl; with CORBA.Repository_Root.IDLType.Impl; package CORBA.Repository_Root.FixedDef.Impl is type Object is new CORBA.Repository_Root.IDLType.Impl.Object with private; type Object_Ptr is access all Object'Class; -- method used to initialize recursively the object fields. procedure Init (Self : access Object; Real_Object : CORBA.Repository_Root.IRObject.Impl.Object_Ptr; Def_Kind : CORBA.Repository_Root.DefinitionKind; IDL_Digits : CORBA.Unsigned_Short; Scale : CORBA.Short); -- overload the get_type from IDLType function get_type (Self : access Object) return CORBA.TypeCode.Object; function get_digits (Self : access Object) return CORBA.Unsigned_Short; procedure set_digits (Self : access Object; To : CORBA.Unsigned_Short); function get_scale (Self : access Object) return CORBA.Short; procedure set_scale (Self : access Object; To : CORBA.Short); private type Object is new CORBA.Repository_Root.IDLType.Impl.Object with record IDL_Digits : CORBA.Unsigned_Short; Scale : CORBA.Short; end record; end CORBA.Repository_Root.FixedDef.Impl; polyorb-2.8~20110207.orig/cos/ir/corba-repository_root-typedefdef-impl.adb0000644000175000017500000001061311750740337025701 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- CORBA.REPOSITORY_ROOT.TYPEDEFDEF.IMPL -- -- -- -- B o d y -- -- -- -- Copyright (C) 2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ pragma Style_Checks (Off); with CORBA.Repository_Root.Helper; with CORBA.Repository_Root.TypedefDef.Skel; pragma Warnings (Off, CORBA.Repository_Root.TypedefDef.Skel); package body CORBA.Repository_Root.TypedefDef.Impl is ------------ -- INIT -- ------------ procedure Init (Self : access Object; Real_Object : CORBA.Repository_Root.IRObject.Impl.Object_Ptr; Def_Kind : CORBA.Repository_Root.DefinitionKind; Id : CORBA.RepositoryId; Name : CORBA.Identifier; Version : CORBA.Repository_Root.VersionSpec; Defined_In : CORBA.Repository_Root.Container_Forward.Ref; IDLType_View : CORBA.Repository_Root.IDLType.Impl.Object_Ptr) is begin Contained.Impl.Init (Contained.Impl.Object_Ptr(Self), Real_Object, Def_Kind, Id, Name, Version, Defined_In); IDLType.Impl.Init (IDLType_View, Real_Object, Def_Kind); Self.IDLType_View := IDLType_View; end Init; --------------------------------- -- To get the secondary views -- --------------------------------- function Get_IDLType_View (Self : access Object) return CORBA.Repository_Root.IDLType.Impl.Object_Ptr is begin return Self.IDLType_View; end Get_IDLType_View; ----------------------------- -- Inherited from IDLType -- ----------------------------- function get_type (Self : access Object) return CORBA.TypeCode.Object is begin return IDLType.Impl.Get_Type (Self.IDLType_View); end get_type; ---------------- -- Describe -- ---------------- function describe (Self : access Object) return CORBA.Repository_Root.Contained.Description is Result : CORBA.Repository_Root.Contained.Description; Desc : CORBA.Repository_Root.TypeDescription; begin Desc := (Name => Get_Name (Self), Id => Get_Id (Self), Defined_In => Get_Defined_In (Self), Version => Get_Version (Self), IDL_Type => IDLType.Impl.Get_Type (Self.IDLType_View)); Result := (Kind => Get_Def_Kind (Self), Value => CORBA.Repository_Root.Helper.To_Any (Desc)); return Result; end describe; end CORBA.Repository_Root.TypedefDef.Impl; polyorb-2.8~20110207.orig/cos/ir/corba-repository_root-operationdef-impl.ads0000644000175000017500000001233111750740337026261 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- CORBA.REPOSITORY_ROOT.OPERATIONDEF.IMPL -- -- -- -- S p e c -- -- -- -- Copyright (C) 2006-2008, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the CORBA Specification, and adapted -- -- for use with PolyORB. The copyright notice above, and the license -- -- provisions that follow apply solely to the contents neither explicitly -- -- nor implicitly specified by the CORBA Specification defined by the OMG. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with CORBA.Repository_Root.IDLType; with CORBA.Repository_Root.IRObject.Impl; with CORBA.Repository_Root.Contained.Impl; package CORBA.Repository_Root.OperationDef.Impl is type Object is new CORBA.Repository_Root.Contained.Impl.Object with private; type Object_Ptr is access all Object'Class; -- method used to initialize recursively the object fields. procedure Init (Self : access Object; Real_Object : CORBA.Repository_Root.IRObject.Impl.Object_Ptr; Def_Kind : CORBA.Repository_Root.DefinitionKind; Id : CORBA.RepositoryId; Name : CORBA.Identifier; Version : CORBA.Repository_Root.VersionSpec; Defined_In : CORBA.Repository_Root.Container_Forward.Ref; Result_Def : CORBA.Repository_Root.IDLType.Ref; Params : CORBA.Repository_Root.ParDescriptionSeq; Mode : CORBA.Repository_Root.OperationMode; Contexts : CORBA.Repository_Root.ContextIdSeq; Exceptions : CORBA.Repository_Root.ExceptionDefSeq); function get_result (Self : access Object) return CORBA.TypeCode.Object; function get_result_def (Self : access Object) return CORBA.Repository_Root.IDLType.Ref; procedure set_result_def (Self : access Object; To : CORBA.Repository_Root.IDLType.Ref); function get_params (Self : access Object) return CORBA.Repository_Root.ParDescriptionSeq; procedure set_params (Self : access Object; To : CORBA.Repository_Root.ParDescriptionSeq); function get_mode (Self : access Object) return CORBA.Repository_Root.OperationMode; procedure set_mode (Self : access Object; To : CORBA.Repository_Root.OperationMode); function get_contexts (Self : access Object) return CORBA.Repository_Root.ContextIdSeq; procedure set_contexts (Self : access Object; To : CORBA.Repository_Root.ContextIdSeq); function get_exceptions (Self : access Object) return CORBA.Repository_Root.ExceptionDefSeq; procedure set_exceptions (Self : access Object; To : CORBA.Repository_Root.ExceptionDefSeq); -- override this from contained function describe (Self : access Object) return CORBA.Repository_Root.Contained.Description; private type Object is new CORBA.Repository_Root.Contained.Impl.Object with record -- the Result is the type of the result_def Result_Def : CORBA.Repository_Root.IDLType.Ref; Params : CORBA.Repository_Root.ParDescriptionSeq; Mode : CORBA.Repository_Root.OperationMode; Contexts : CORBA.Repository_Root.ContextIdSeq; Exceptions : CORBA.Repository_Root.ExceptionDefSeq; end record; end CORBA.Repository_Root.OperationDef.Impl; polyorb-2.8~20110207.orig/cos/ir/corba-repository_root-extinterfacedef-impl.adb0000644000175000017500000001156611750740337026732 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- CORBA.REPOSITORY_ROOT.EXTINTERFACEDEF.IMPL -- -- -- -- B o d y -- -- -- -- Copyright (C) 2006-2008, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with CORBA.Repository_Root.IDLType; with CORBA.Repository_Root.InterfaceAttrExtension; with CORBA.Repository_Root.ExtInterfaceDef.Skel; pragma Warnings (Off, CORBA.Repository_Root.ExtInterfaceDef.Skel); package body CORBA.Repository_Root.ExtInterfaceDef.Impl is -------------------------- -- create_ext_attribute -- -------------------------- function create_ext_attribute (Self : access Object; id : RepositoryId; name : Identifier; version : VersionSpec; IDL_type : IDLType.Ref; mode : AttributeMode; get_exceptions : ExceptionDefSeq; set_exceptions : ExceptionDefSeq) return ExtAttributeDef.Ref is begin return InterfaceAttrExtension.Impl.create_ext_attribute (Self.InterfaceAttrExtension_View, id, name, version, IDL_type, mode, get_exceptions, set_exceptions); end create_ext_attribute; ---------------------------- -- describe_ext_interface -- ---------------------------- function describe_ext_interface (Self : access Object) return InterfaceAttrExtension.ExtFullInterfaceDescription is begin return InterfaceAttrExtension.Impl.describe_ext_interface (Self.InterfaceAttrExtension_View); end describe_ext_interface; package body Internals is ---------- -- Init -- ---------- procedure Init (Self : access Object'Class; Real_Object : IRObject.Impl.Object_Ptr; Def_Kind : DefinitionKind; Id : RepositoryId; Name : Identifier; Version : VersionSpec; Defined_In : Container_Forward.Ref; Contents : Contained.Impl.Contained_Seq.Sequence; Contained_View : Contained.Impl.Object_Ptr; IDLType_View : IDLType.Impl.Object_Ptr; Base_Interfaces : InterfaceDefSeq; Is_Abstract : Boolean; InterfaceAttrExtension_View : InterfaceAttrExtension.Impl.Object_Ptr) is begin InterfaceDef.Impl.Init (InterfaceDef.Impl.Object_Ptr (Self), Real_Object, Def_Kind, Id, Name, Version, Defined_In, Contents, Contained_View, IDLType_View, Base_Interfaces, Is_Abstract); InterfaceAttrExtension.Impl.Internals.Init (InterfaceAttrExtension_View, Real_Object); Self.InterfaceAttrExtension_View := InterfaceAttrExtension_View; end Init; end Internals; end CORBA.Repository_Root.ExtInterfaceDef.Impl; polyorb-2.8~20110207.orig/cos/ir/corba-repository_root-valueboxdef-impl.adb0000644000175000017500000001172611750740337026074 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- CORBA.REPOSITORY_ROOT.VALUEBOXDEF.IMPL -- -- -- -- B o d y -- -- -- -- Copyright (C) 2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ pragma Style_Checks (Off); with CORBA.ORB.TypeCode; with PortableServer; with CORBA.Repository_Root.ValueBoxDef.Skel; pragma Warnings (Off, CORBA.Repository_Root.ValueBoxDef.Skel); with PolyORB.CORBA_P.Server_Tools; package body CORBA.Repository_Root.ValueBoxDef.Impl is ----------------- -- To_Object -- ----------------- function To_Object (Fw_Ref : ValueBoxDef_Forward.Ref) return Object_Ptr is Result : Portableserver.Servant; begin PolyORB.CORBA_P.Server_Tools.Reference_To_Servant (ValueBoxDef.Convert_Forward.To_Ref (Fw_Ref), Result); return ValueBoxDef.Impl.Object_Ptr (Result); end To_Object; ------------------ -- To_Forward -- ------------------ function To_Forward (Obj : Object_Ptr) return ValueBoxDef_Forward.Ref is Ref : ValueBoxDef.Ref; begin PolyORB.CORBA_P.Server_Tools.Initiate_Servant (PortableServer.Servant (Obj), Ref); return ValueBoxDef.Convert_Forward.To_Forward (Ref); end To_Forward; ------------ -- INIT -- ------------ procedure Init (Self : access Object; Real_Object : CORBA.Repository_Root.IRObject.Impl.Object_Ptr; Def_Kind : CORBA.Repository_Root.DefinitionKind; Id : CORBA.RepositoryId; Name : CORBA.Identifier; Version : CORBA.Repository_Root.VersionSpec; Defined_In : CORBA.Repository_Root.Container_Forward.Ref; IDLType_View : CORBA.Repository_Root.IDLType.Impl.Object_Ptr; Original_Type_Def : CORBA.Repository_Root.IDLType.Ref) is begin Typedefdef.Impl.Init (Typedefdef.Impl.Object_Ptr (Self), Real_Object, Def_Kind, Id, Name, Version, Defined_In, IDLType_View); Self.Original_Type_Def := Original_Type_Def; end Init; ---------------- -- get_type -- ---------------- function get_type (Self : access Object) return CORBA.TypeCode.Object is Obj : Portableserver.Servant; Orig_TC : CORBA.TypeCode.Object; begin PolyORB.CORBA_P.Server_Tools.Reference_To_Servant (Self.Original_Type_Def, Obj); Orig_TC := IDLType.Impl.Get_Type (IDLType.Impl.To_IDLType (IRObject.Impl.Object_Ptr (Obj))); return CORBA.ORB.TypeCode.Create_Value_Box_Tc (Get_Id (Self), Get_Name (Self), Orig_TC); end get_type; function get_original_type_def (Self : access Object) return CORBA.Repository_Root.IDLType.Ref is begin return Self.Original_Type_Def; end get_original_type_def; procedure set_original_type_def (Self : access Object; To : CORBA.Repository_Root.IDLType.Ref) is begin Self.Original_Type_Def := To; end set_original_type_def; end CORBA.Repository_Root.ValueBoxDef.Impl; polyorb-2.8~20110207.orig/cos/ir/corba-repository_root-uniondef-impl.adb0000644000175000017500000004166311750740337025402 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- C O R B A . R E P O S I T O R Y _ R O O T . U N I O N D E F . I M P L -- -- -- -- B o d y -- -- -- -- Copyright (C) 2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ pragma Style_Checks (Off); with CORBA.ORB.TypeCode; with PortableServer; with CORBA.Repository_Root.UnionDef.Skel; pragma Warnings (Off, CORBA.Repository_Root.UnionDef.Skel); with PolyORB.CORBA_P.Server_Tools; package body CORBA.Repository_Root.UnionDef.Impl is ----------------- -- To_Object -- ----------------- function To_Object (Fw_Ref : UnionDef_Forward.Ref) return Object_Ptr is Result : Portableserver.Servant; begin PolyORB.CORBA_P.Server_Tools.Reference_To_Servant (UnionDef.Convert_Forward.To_Ref (Fw_Ref), Result); return Object_Ptr (Result); end To_Object; ------------------ -- To_Forward -- ------------------ function To_Forward (Obj : Object_Ptr) return UnionDef_Forward.Ref is Ref : UnionDef.Ref; begin PolyORB.CORBA_P.Server_Tools.Initiate_Servant (PortableServer.Servant (Obj), Ref); return UnionDef.Convert_Forward.To_Forward (Ref); end To_Forward; ------------ -- INIT -- ------------ procedure Init (Self : access Object; Real_Object : CORBA.Repository_Root.IRObject.Impl.Object_Ptr; Def_Kind : CORBA.Repository_Root.DefinitionKind; Id : CORBA.RepositoryId; Name : CORBA.Identifier; Version : CORBA.Repository_Root.VersionSpec; Defined_In : CORBA.Repository_Root.Container_Forward.Ref; IDLType_View : CORBA.Repository_Root.IDLType.Impl.Object_Ptr; Contents : CORBA.Repository_Root.Contained.Impl.Contained_Seq.Sequence; Container_View : CORBA.Repository_Root.Container.Impl.Object_Ptr; Discriminator_Type_Def : CORBA.Repository_Root.IDLType.Ref; Members : CORBA.Repository_Root.UnionMemberSeq) is begin Typedefdef.Impl.Init (Typedefdef.Impl.Object_Ptr (Self), Real_Object, Def_Kind, Id, Name, Version, Defined_In, IDLType_View); Container.Impl.Init (Container_View, Real_Object, Def_Kind, Contents); Self.Container_View := Container_View; Self.Discriminator_Type_Def := Discriminator_Type_Def; Initialize_Members (Self, Members); end Init; --------------------------------- -- To get the secondary views -- --------------------------------- function Get_Container_View (Self : access Object) return CORBA.Repository_Root.Container.Impl.Object_Ptr is begin return Self.Container_View; end Get_Container_View; -------------------------- -- Initialize_Members -- -------------------------- procedure Initialize_Members (Self : access Object; Seq : UnionMemberSeq) is -- package UMS renames -- IDL_SEQUENCE_CORBA_Repository_Root_UnionMember; -- Memb_Array : UMS.Element_Array -- := UMS.To_Element_Array (UMS.Sequence (Seq)); begin -- FIXME>>>>>>>>>>>>>>>>> -- if we set the typecodes to TC_Void, we will loose -- the type of the members... -- for I in Memb_Array'Range loop -- Memb_Array (I).IDL_Type := CORBA.TC_Void; -- end loop; -- Self.Members := UnionMemberSeq (UMS.To_Sequence (Memb_Array)); Self.Members := Seq; end Initialize_Members; ---------------- -- get_type -- ---------------- function get_type (Self : access Object) return CORBA.TypeCode.Object is begin return CORBA.ORB.Typecode.Create_Union_Tc (Get_Id (Self), Get_Name (Self), Get_Discriminator_Type (Self), Self.Members); end get_type; function get_discriminator_type (Self : access Object) return CORBA.TypeCode.Object is Obj : Portableserver.Servant; begin PolyORB.CORBA_P.Server_Tools.Reference_To_Servant (Self.Discriminator_Type_Def, Obj); return IDLType.Impl.Get_Type (IDLType.Impl.To_IDLType (IRObject.Impl.Object_Ptr (Obj))); end get_discriminator_type; function get_discriminator_type_def (Self : access Object) return CORBA.Repository_Root.IDLType.Ref is begin return Self.Discriminator_Type_Def; end get_discriminator_type_def; procedure set_discriminator_type_def (Self : access Object; To : CORBA.Repository_Root.IDLType.Ref) is begin Self.Discriminator_Type_Def := To; end set_discriminator_type_def; function get_members (Self : access Object) return CORBA.Repository_Root.UnionMemberSeq is begin return Self.Members; end get_members; procedure set_members (Self : access Object; To : CORBA.Repository_Root.UnionMemberSeq) is begin Initialize_Members (Self, To); end set_members; -------------------------------- -- Inherited from container -- -------------------------------- function lookup (Self : access Object; search_name : CORBA.ScopedName) return CORBA.Repository_Root.Contained.Ref is begin return Container.Impl.Lookup (Self.Container_View, Search_Name); end lookup; function contents (Self : access Object; limit_type : CORBA.Repository_Root.DefinitionKind; exclude_inherited : CORBA.Boolean) return CORBA.Repository_Root.ContainedSeq is begin return Container.Impl.Contents (Self.Container_View, Limit_Type, Exclude_Inherited); end contents; function lookup_name (Self : access Object; search_name : CORBA.Identifier; levels_to_search : CORBA.Long; limit_type : CORBA.Repository_Root.DefinitionKind; exclude_inherited : CORBA.Boolean) return CORBA.Repository_Root.ContainedSeq is begin return Container.Impl.Lookup_Name (Self.Container_View, Search_Name, Levels_To_Search, Limit_Type, Exclude_Inherited); end lookup_name; function describe_contents (Self : access Object; limit_type : CORBA.Repository_Root.DefinitionKind; exclude_inherited : CORBA.Boolean; max_returned_objs : CORBA.Long) return CORBA.Repository_Root.Container.DescriptionSeq is begin return Container.Impl.Describe_Contents (Self.Container_View, Limit_Type, Exclude_Inherited, Max_Returned_Objs); end describe_contents; function create_module (Self : access Object; id : CORBA.RepositoryId; name : CORBA.Identifier; version : CORBA.Repository_Root.VersionSpec) return CORBA.Repository_Root.ModuleDef_Forward.Ref is begin return Container.Impl.Create_Module (Self.Container_View, Id, Name, Version); end create_module; function create_constant (Self : access Object; id : CORBA.RepositoryId; name : CORBA.Identifier; version : CORBA.Repository_Root.VersionSpec; IDL_type : CORBA.Repository_Root.IDLType_Forward.Ref; value : CORBA.Any) return CORBA.Repository_Root.ConstantDef_Forward.Ref is begin return Container.Impl.Create_Constant (Self.Container_View, Id, Name, Version, IDL_Type, Value); end create_constant; function create_struct (Self : access Object; id : CORBA.RepositoryId; name : CORBA.Identifier; version : CORBA.Repository_Root.VersionSpec; members : CORBA.Repository_Root.StructMemberSeq) return CORBA.Repository_Root.StructDef_Forward.Ref is begin return Container.Impl.Create_Struct (Self.Container_View, Id, Name, Version, Members); end create_struct; function create_union (Self : access Object; id : CORBA.RepositoryId; name : CORBA.Identifier; version : CORBA.Repository_Root.VersionSpec; discriminator_type : CORBA.Repository_Root.IDLType_Forward.Ref; members : CORBA.Repository_Root.UnionMemberSeq) return CORBA.Repository_Root.UnionDef_Forward.Ref is begin return Container.Impl.Create_Union (Self.Container_View, Id, Name, Version, Discriminator_Type, Members); end create_union; function create_enum (Self : access Object; id : CORBA.RepositoryId; name : CORBA.Identifier; version : CORBA.Repository_Root.VersionSpec; members : CORBA.Repository_Root.EnumMemberSeq) return CORBA.Repository_Root.EnumDef_Forward.Ref is begin return Container.Impl.Create_Enum (Self.Container_View, Id, Name, Version, Members); end create_enum; function create_alias (Self : access Object; id : CORBA.RepositoryId; name : CORBA.Identifier; version : CORBA.Repository_Root.VersionSpec; original_type : CORBA.Repository_Root.IDLType_Forward.Ref) return CORBA.Repository_Root.AliasDef_Forward.Ref is begin return Container.Impl.Create_Alias (Self.Container_View, Id, Name, Version, Original_Type); end create_alias; function create_interface (Self : access Object; id : CORBA.RepositoryId; name : CORBA.Identifier; version : CORBA.Repository_Root.VersionSpec; base_interfaces : CORBA.Repository_Root.InterfaceDefSeq; is_abstract : CORBA.Boolean) return CORBA.Repository_Root.InterfaceDef_Forward.Ref is begin return Container.Impl.Create_Interface (Self.Container_View, Id, Name, Version, Base_Interfaces, Is_Abstract); end create_interface; function create_value (Self : access Object; id : CORBA.RepositoryId; name : CORBA.Identifier; version : CORBA.Repository_Root.VersionSpec; is_custom : CORBA.Boolean; is_abstract : CORBA.Boolean; base_value : CORBA.Repository_Root.ValueDef_Forward.Ref; is_truncatable : CORBA.Boolean; abstract_base_values : CORBA.Repository_Root.ValueDefSeq; supported_interfaces : CORBA.Repository_Root.InterfaceDefSeq; initializers : CORBA.Repository_Root.InitializerSeq) return CORBA.Repository_Root.ValueDef_Forward.Ref is begin return Container.Impl.Create_Value (Self.Container_View, Id, Name, Version, Is_Custom, Is_Abstract, Base_Value, Is_Truncatable, Abstract_Base_Values, Supported_Interfaces, Initializers); end create_value; function create_value_box (Self : access Object; id : CORBA.RepositoryId; name : CORBA.Identifier; version : CORBA.Repository_Root.VersionSpec; original_type_def : CORBA.Repository_Root.IDLType_Forward.Ref) return CORBA.Repository_Root.ValueBoxDef_Forward.Ref is begin return Container.Impl.Create_Value_Box (Self.Container_View, Id, Name, Version, Original_Type_Def); end create_value_box; function create_exception (Self : access Object; id : CORBA.RepositoryId; name : CORBA.Identifier; version : CORBA.Repository_Root.VersionSpec; members : CORBA.Repository_Root.StructMemberSeq) return CORBA.Repository_Root.ExceptionDef_Forward.Ref is begin return Container.Impl.Create_Exception (Self.Container_View, Id, Name, Version, Members); end create_exception; function create_native (Self : access Object; id : CORBA.RepositoryId; name : CORBA.Identifier; version : CORBA.Repository_Root.VersionSpec) return CORBA.Repository_Root.NativeDef_Forward.Ref is begin return Container.Impl.Create_Native (Self.Container_View, Id, Name, Version); end create_native; ------------------------------- -- create_abstract_interface -- ------------------------------- function create_abstract_interface (Self : access Object; id : RepositoryId; name : Identifier; version : VersionSpec; base_interfaces : AbstractInterfaceDefSeq) return AbstractInterfaceDef_Forward.Ref is begin return Container.Impl.create_abstract_interface (Self.Container_View, id, name, version, base_interfaces); end create_abstract_interface; ---------------------------- -- create_local_interface -- ---------------------------- function create_local_interface (Self : access Object; id : RepositoryId; name : Identifier; version : VersionSpec; base_interfaces : InterfaceDefSeq) return LocalInterfaceDef_Forward.Ref is begin return Container.Impl.create_local_interface (Self.Container_View, id, name, version, base_interfaces); end create_local_interface; end CORBA.Repository_Root.UnionDef.Impl; polyorb-2.8~20110207.orig/cos/ir/corba-repository_root-extattributedef-impl.adb0000644000175000017500000001163111750740337026766 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- CORBA.REPOSITORY_ROOT.EXTATTRIBUTEDEF.IMPL -- -- -- -- B o d y -- -- -- -- Copyright (C) 2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with CORBA.Repository_Root.ExceptionDef.Impl; with CORBA.Repository_Root.ExtAttributeDef.Skel; pragma Warnings (Off, CORBA.Repository_Root.ExtAttributeDef.Skel); package body CORBA.Repository_Root.ExtAttributeDef.Impl is ------------------------ -- describe_attribute -- ------------------------ function describe_attribute (Self : access Object) return ExtAttributeDescription is begin return (name => get_name (Self), id => get_id (Self), defined_in => get_defined_in (Self), version => get_version (Self), IDL_type => get_type (Self), mode => get_mode (Self), get_exceptions => Self.Get_Exceptions, put_exceptions => Self.Set_Exceptions); end describe_attribute; ------------------------ -- get_get_exceptions -- ------------------------ function get_get_exceptions (Self : access Object) return ExcDescriptionSeq is begin return Self.Get_Exceptions; end get_get_exceptions; ------------------------ -- get_set_exceptions -- ------------------------ function get_set_exceptions (Self : access Object) return ExcDescriptionSeq is begin return Self.Set_Exceptions; end get_set_exceptions; ------------------------ -- set_get_exceptions -- ------------------------ procedure set_get_exceptions (Self : access Object; To : ExcDescriptionSeq) is begin Self.Get_Exceptions := To; end set_get_exceptions; ------------------------ -- set_set_exceptions -- ------------------------ procedure set_set_exceptions (Self : access Object; To : ExcDescriptionSeq) is begin Self.Set_Exceptions := To; end set_set_exceptions; package body Internals is ---------- -- Init -- ---------- procedure Init (Self : access Object'Class; Real_Object : IRObject.Impl.Object_Ptr; Def_Kind : DefinitionKind; Id : RepositoryId; Name : Identifier; Version : VersionSpec; Defined_In : Container_Forward.Ref; Type_Def : IDLType.Ref; Mode : AttributeMode; Get_Exceptions : ExceptionDefSeq; Set_Exceptions : ExceptionDefSeq) is begin AttributeDef.Impl.Init (AttributeDef.Impl.Object_Ptr (Self), Real_Object, Def_Kind, Id, Name, Version, Defined_In, Type_Def, Mode); Self.Get_Exceptions := ExceptionDef.Impl.Get_ExcDescriptionSeq (Get_Exceptions); Self.Set_Exceptions := ExceptionDef.Impl.Get_ExcDescriptionSeq (Set_Exceptions); end Init; end Internals; end CORBA.Repository_Root.ExtAttributeDef.Impl; polyorb-2.8~20110207.orig/cos/ir/corba-repository_root-interfaceattrextension-impl.ads0000644000175000017500000000716211750740337030400 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- CORBA.REPOSITORY_ROOT.INTERFACEATTREXTENSION.IMPL -- -- -- -- S p e c -- -- -- -- Copyright (C) 2006-2008, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the CORBA Specification, and adapted -- -- for use with PolyORB. The copyright notice above, and the license -- -- provisions that follow apply solely to the contents neither explicitly -- -- nor implicitly specified by the CORBA Specification defined by the OMG. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with CORBA.Repository_Root.Container.Impl; with CORBA.Repository_Root.ExtAttributeDef; with CORBA.Repository_Root.IDLType; with CORBA.Repository_Root.IRObject.Impl; with PortableServer; package CORBA.Repository_Root.InterfaceAttrExtension.Impl is type Object is new PortableServer.Servant_Base with private; type Object_Ptr is access all Object'Class; function describe_ext_interface (Self : access Object) return InterfaceAttrExtension.ExtFullInterfaceDescription; function create_ext_attribute (Self : access Object; id : RepositoryId; name : Identifier; version : VersionSpec; IDL_type : IDLType.Ref; mode : AttributeMode; get_exceptions : ExceptionDefSeq; set_exceptions : ExceptionDefSeq) return ExtAttributeDef.Ref; package Internals is procedure Init (Self : access Object'Class; Real_Object : IRObject.Impl.Object_Ptr); -- Recursively initialize object fields end Internals; private type Object is new PortableServer.Servant_Base with record Real : Container.Impl.Object_Ptr; end record; end CORBA.Repository_Root.InterfaceAttrExtension.Impl; polyorb-2.8~20110207.orig/cos/ir/corba-repository_root-sequencedef-impl.adb0000644000175000017500000001027311750740337026053 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- CORBA.REPOSITORY_ROOT.SEQUENCEDEF.IMPL -- -- -- -- B o d y -- -- -- -- Copyright (C) 2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with CORBA.ORB; with PortableServer; with CORBA.Repository_Root.SequenceDef.Skel; pragma Warnings (Off, CORBA.Repository_Root.SequenceDef.Skel); with PolyORB.CORBA_P.Server_Tools; package body CORBA.Repository_Root.SequenceDef.Impl is ---------------------- -- Procedure init -- ---------------------- procedure Init (Self : access Object; Real_Object : CORBA.Repository_Root.IRObject.Impl.Object_Ptr; Def_Kind : CORBA.Repository_Root.DefinitionKind; Bound : CORBA.Unsigned_Long; Element_Type_Def : CORBA.Repository_Root.IDLType.Ref) is begin IDLType.Impl.Init (IDLType.Impl.Object_Ptr (Self), Real_Object, Def_Kind); Self.Bound := Bound; Self.Element_Type_Def := Element_Type_Def; end Init; ---------------- -- get_type -- ---------------- function get_type (Self : access Object) return CORBA.TypeCode.Object is begin return CORBA.ORB.Create_Sequence_Tc (Self.Bound, get_element_type (Self)); end get_type; function get_bound (Self : access Object) return CORBA.Unsigned_Long is begin return Self.Bound; end get_bound; procedure set_bound (Self : access Object; To : CORBA.Unsigned_Long) is begin Self.Bound := To; end set_bound; function get_element_type (Self : access Object) return CORBA.TypeCode.Object is Obj : PortableServer.Servant; begin PolyORB.CORBA_P.Server_Tools.Reference_To_Servant (Self.Element_Type_Def, Obj); return IDLType.Impl.get_type (IDLType.Impl.To_IDLType (IRObject.Impl.Object_Ptr (Obj))); end get_element_type; function get_element_type_def (Self : access Object) return CORBA.Repository_Root.IDLType.Ref is begin return Self.Element_Type_Def; end get_element_type_def; procedure set_element_type_def (Self : access Object; To : CORBA.Repository_Root.IDLType.Ref) is begin Self.Element_Type_Def := To; end set_element_type_def; end CORBA.Repository_Root.SequenceDef.Impl; polyorb-2.8~20110207.orig/cos/ir/corba-repository_root-valuedef-impl.adb0000644000175000017500000004672611750740337025373 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- C O R B A . R E P O S I T O R Y _ R O O T . V A L U E D E F . I M P L -- -- -- -- B o d y -- -- -- -- Copyright (C) 2006-2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ pragma Style_Checks (Off); with CORBA.ORB.TypeCode; with PortableServer; with CORBA.Repository_Root.OperationDef.Impl; with CORBA.Repository_Root.AttributeDef.Impl; with CORBA.Repository_Root.ValueMemberDef.Impl; with CORBA.Repository_Root.InterfaceDef; with CORBA.Repository_Root.InterfaceDef.Impl; with CORBA.Repository_Root.Helper; with CORBA.Repository_Root.ValueDef.Skel; pragma Warnings (Off, CORBA.Repository_Root.ValueDef.Skel); with PolyORB.CORBA_P.Server_Tools; package body CORBA.Repository_Root.ValueDef.Impl is package ValDef renames IDL_SEQUENCE_CORBA_ValueDef_Forward; package IdSeq renames IDL_SEQUENCE_CORBA_RepositoryId; ------------ -- INIT -- ------------ procedure Init (Self : access Object; Real_Object : CORBA.Repository_Root.IRObject.Impl.Object_Ptr; Def_Kind : CORBA.Repository_Root.DefinitionKind; Id : CORBA.RepositoryId; Name : CORBA.Identifier; Version : CORBA.Repository_Root.VersionSpec; Defined_In : CORBA.Repository_Root.Container_Forward.Ref; Contents : CORBA.Repository_Root.Contained.Impl.Contained_Seq.Sequence; Contained_View : CORBA.Repository_Root.Contained.Impl.Object_Ptr; IDLType_View : CORBA.Repository_Root.IDLType.Impl.Object_Ptr; Supported_Interfaces : CORBA.Repository_Root.InterfaceDefSeq; Initializers : CORBA.Repository_Root.InitializerSeq; Base_Value : CORBA.Repository_Root.ValueDef.Ref; Abstract_Base_Values : CORBA.Repository_Root.ValueDefSeq; Is_Abstract : CORBA.Boolean; Is_Custom : CORBA.Boolean; Is_Truncatable : CORBA.Boolean) is begin Container.Impl.Init (Container.Impl.Object_Ptr (Self), Real_Object, Def_Kind, Contents); Contained.Impl.Init (Contained_View, Real_Object, Def_Kind, Id, Name, Version, Defined_In); IDLType.Impl.Init (IDLType_View, Real_Object, Def_Kind); Self.Contained_View := Contained_View; Self.IDLType_View := IDLType_View; Self.Supported_Interfaces := Supported_Interfaces; Self.Initializers := Initializers; Self.Base_Value := Base_Value; Self.Abstract_Base_Values := Abstract_Base_Values; Self.Is_Abstract := Is_Abstract; Self.Is_Custom := Is_Custom; Self.Is_Truncatable := Is_Truncatable; end Init; ----------------- -- To_Object -- ----------------- function To_Object (Fw_Ref : ValueDef_Forward.Ref) return Object_Ptr is Result : Portableserver.Servant; begin PolyORB.CORBA_P.Server_Tools.Reference_To_Servant (ValueDef.Convert_Forward.To_Ref (Fw_Ref), Result); return ValueDef.Impl.Object_Ptr (Result); end To_Object; ------------------ -- To_Forward -- ------------------ function To_Forward (Obj : Object_Ptr) return ValueDef_Forward.Ref is Ref : ValueDef.Ref; begin PolyORB.CORBA_P.Server_Tools.Initiate_Servant (PortableServer.Servant (Obj), Ref); return ValueDef.Convert_Forward.To_Forward (Ref); end To_Forward; --------------------------------- -- To get the secondary views -- --------------------------------- function Get_Contained_View (Self : access Object) return CORBA.Repository_Root.Contained.Impl.Object_Ptr is begin return Self.Contained_View; end Get_Contained_View; function Get_IDLType_View (Self : access Object) return CORBA.Repository_Root.IDLType.Impl.Object_Ptr is begin return Self.IDLType_View; end Get_IDLType_View; function get_supported_interfaces (Self : access Object) return CORBA.Repository_Root.InterfaceDefSeq is begin return Self.Supported_Interfaces; end get_supported_interfaces; procedure set_supported_interfaces (Self : access Object; To : CORBA.Repository_Root.InterfaceDefSeq) is begin Self.Supported_Interfaces := To; end set_supported_interfaces; function get_initializers (Self : access Object) return CORBA.Repository_Root.InitializerSeq is begin return Self.Initializers; end get_initializers; procedure set_initializers (Self : access Object; To : CORBA.Repository_Root.InitializerSeq) is begin Self.Initializers := To; end set_initializers; function get_base_value (Self : access Object) return CORBA.Repository_Root.ValueDef.Ref'Class is begin return Self.Base_Value; end get_base_value; procedure set_base_value (Self : access Object; To : CORBA.Repository_Root.ValueDef.Ref) is begin Self.Base_Value := To; end set_base_value; function get_abstract_base_values (Self : access Object) return CORBA.Repository_Root.ValueDefSeq is begin return Self.Abstract_Base_Values; end get_abstract_base_values; procedure set_abstract_base_values (Self : access Object; To : CORBA.Repository_Root.ValueDefSeq) is begin Self.Abstract_Base_Values := To; end set_abstract_base_values; function get_is_abstract (Self : access Object) return CORBA.Boolean is begin return Self.Is_Abstract; end get_is_abstract; procedure set_is_abstract (Self : access Object; To : CORBA.Boolean) is begin Self.Is_Abstract := To; end set_is_abstract; function get_is_custom (Self : access Object) return CORBA.Boolean is begin return Self.Is_Custom; end get_is_custom; procedure set_is_custom (Self : access Object; To : CORBA.Boolean) is begin Self.Is_Custom := To; end set_is_custom; function get_is_truncatable (Self : access Object) return CORBA.Boolean is begin return Self.Is_Truncatable; end get_is_truncatable; procedure set_is_truncatable (Self : access Object; To : CORBA.Boolean) is begin Self.Is_Truncatable := To; end set_is_truncatable; function is_a (Self : access Object; id : CORBA.RepositoryId) return CORBA.Boolean is pragma Unreferenced (Self, Id); begin -- Insert implementation of is_a -- XXX not implemented yet! raise Program_Error; return False; end is_a; function describe_value (Self : access Object) return CORBA.Repository_Root.ValueDef.FullValueDescription is pragma Unreferenced (Self); Result : CORBA.Repository_Root.ValueDef.FullValueDescription; pragma Warnings (Off, Result); -- Dummy value, use default initialization begin -- Insert implementation of describe_value -- XXX describe_value is not implemented yet raise Program_Error; return Result; end describe_value; function create_value_member (Self : access Object; id : CORBA.RepositoryId; name : CORBA.Identifier; version : CORBA.Repository_Root.VersionSpec; IDL_type : CORBA.Repository_Root.IDLType.Ref; IDL_access : CORBA.Visibility) return CORBA.Repository_Root.ValueMemberDef.Ref is begin Check_Structure (Self, Dk_ValueMember); Check_Id (Self, Id); Check_Name (Self, Name); declare Result : CORBA.Repository_Root.ValueMemberDef.Ref; Obj : constant ValueMemberDef.Impl.Object_Ptr := new ValueMemberDef.Impl.Object; begin -- initialization of the object ValueMemberDef.Impl.Init (Obj, IRObject.Impl.Object_Ptr (Obj), Dk_ValueMember, Id, Name, Version, Container.Impl.To_Forward (Container.Impl.Object_Ptr (Self)), IDL_type, IDL_access); -- add it to the contents field of this container Container.Impl.Append_To_Contents (Container.Impl.Object_Ptr (Self), Contained.Impl.To_Contained (IRObject.Impl.Object_Ptr (Obj))); -- activate it PolyORB.CORBA_P.Server_Tools.Initiate_Servant (PortableServer.Servant (Obj), Result); return Result; end; end create_value_member; function create_attribute (Self : access Object; id : CORBA.RepositoryId; name : CORBA.Identifier; version : CORBA.Repository_Root.VersionSpec; IDL_type_1 : CORBA.Repository_Root.IDLType.Ref; mode : CORBA.Repository_Root.AttributeMode) return CORBA.Repository_Root.AttributeDef.Ref is begin Check_Structure (Self, Dk_Attribute); Check_Id (Self, Id); Check_Name (Self, Name); declare Result : CORBA.Repository_Root.AttributeDef.Ref; Obj : constant AttributeDef.Impl.Object_Ptr := new AttributeDef.Impl.Object; begin -- initialization of the object AttributeDef.Impl.Init (Obj, IRObject.Impl.Object_Ptr (Obj), Dk_Attribute, Id, Name, Version, Container.Impl.To_Forward (Container.Impl.Object_Ptr (Self)), IDL_Type_1, Mode); -- add it to the contents field of this container Container.Impl.Append_To_Contents (Container.Impl.Object_Ptr (Self), Contained.Impl.To_Contained (IRObject.Impl.Object_Ptr (Obj))); -- activate it PolyORB.CORBA_P.Server_Tools.Initiate_Servant (PortableServer.Servant (Obj), Result); return Result; end; end create_attribute; function create_operation (Self : access Object; id : CORBA.RepositoryId; name : CORBA.Identifier; version : CORBA.Repository_Root.VersionSpec; IDL_result : CORBA.Repository_Root.IDLType.Ref; mode : CORBA.Repository_Root.OperationMode; params : CORBA.Repository_Root.ParDescriptionSeq; exceptions : CORBA.Repository_Root.ExceptionDefSeq; contexts : CORBA.Repository_Root.ContextIdSeq) return CORBA.Repository_Root.OperationDef.Ref is begin Check_Structure (Self, Dk_Operation); Check_Id (Self, Id); Check_Name (Self, Name); declare Result : CORBA.Repository_Root.OperationDef.Ref; Obj : constant OperationDef.Impl.Object_Ptr := new OperationDef.Impl.Object; begin -- initialization of the object OperationDef.Impl.Init (Obj, IRObject.Impl.Object_Ptr (Obj), Dk_Operation, Id, Name, Version, Container.Impl.To_Forward (Container.Impl.Object_Ptr (Self)), IDL_Result, Params, Mode, Contexts, Exceptions); -- add it to the contents field of this container Container.Impl.Append_To_Contents (Container.Impl.Object_Ptr (Self), Contained.Impl.To_Contained (IRObject.Impl.Object_Ptr (Obj))); -- activate it PolyORB.CORBA_P.Server_Tools.Initiate_Servant (PortableServer.Servant (Obj), Result); return Result; end; end create_operation; -------------------------------- -- inherited from contained -- -------------------------------- function get_id (Self : access Object) return CORBA.RepositoryId is begin return Contained.Impl.Get_Id (Self.Contained_View); end get_id; procedure set_id (Self : access Object; To : CORBA.RepositoryId) is begin Contained.Impl.Set_Id (Self.Contained_View, To); end set_id; function get_name (Self : access Object) return CORBA.Identifier is begin return Contained.Impl.Get_Name (Self.Contained_View); end get_name; procedure set_name (Self : access Object; To : CORBA.Identifier) is begin Contained.Impl.Set_Name (Self.Contained_View, To); end set_name; function get_version (Self : access Object) return CORBA.Repository_Root.VersionSpec is begin return Contained.Impl.Get_Version (Self.Contained_View); end get_version; procedure set_version (Self : access Object; To : CORBA.Repository_Root.VersionSpec) is begin Contained.Impl.Set_Version (Self.Contained_View, To); end set_version; function get_defined_in (Self : access Object) return CORBA.Repository_Root.Container_Forward.Ref is begin return Contained.Impl.Get_Defined_In (Self.Contained_View); end get_defined_in; function get_absolute_name (Self : access Object) return CORBA.ScopedName is begin return Contained.Impl.Get_Absolute_Name (Self.Contained_View); end get_absolute_name; function get_containing_repository (Self : access Object) return CORBA.Repository_Root.Repository_Forward.Ref is begin return Contained.Impl.Get_Containing_Repository (Self.Contained_View); end get_containing_repository; function describe (Self : access Object) return CORBA.Repository_Root.Contained.Description is Result : CORBA.Repository_Root.Contained.Description; Desc : CORBA.Repository_Root.ValueDescription; Obj : Portableserver.Servant; begin PolyORB.CORBA_P.Server_Tools.Reference_To_Servant (Self.Base_Value, Obj); Desc := (Name => Get_Name (Self), Id => Get_Id (Self), Is_Abstract => Self.Is_Abstract, Is_Custom => Self.Is_Custom, Defined_In => Contained.Impl.Get_Defined_In (Self.Contained_View), Version => Get_Version (Self), Supported_Interfaces => InterfaceDef.Impl.Get_RepositoryIdSeq (Self.Supported_Interfaces), Abstract_Base_Values => Get_RepositoryIdSeq (Self.Abstract_Base_Values), Is_Truncatable => Self.Is_Truncatable, Base_Value => Get_Id (ValueDef.Impl.Object_Ptr (Obj))); Result := (Kind => Get_Def_Kind (Self), Value => CORBA.Repository_Root.Helper.To_Any (Desc)); return Result; end describe; procedure move (Self : access Object; new_container : CORBA.Repository_Root.Container_Forward.Ref; new_name : CORBA.Identifier; new_version : CORBA.Repository_Root.VersionSpec) is begin Contained.Impl.Move (Self.Contained_View, New_Container, New_Name, New_Version); end move; ------------------------------ -- inherited from IDLType -- ------------------------------ function get_type (Self : access Object) return CORBA.TypeCode.Object is Val : CORBA.ValueModifier; Base_TC : CORBA.TypeCode.Object; package VMS renames IDL_SEQUENCE_CORBA_ValueMember; begin if not ValueDef.Is_Nil (Self.Base_Value) then declare Obj : Portableserver.Servant; begin PolyORB.CORBA_P.Server_Tools.Reference_To_Servant (Self.Base_Value, Obj); Base_TC := ValueDef.Impl.Get_Type (ValueDef.Impl.Object_Ptr (Obj)); end; else Base_TC := CORBA.TC_Void; end if; if Self.Is_Custom then Val := VTM_CUSTOM; elsif Self.Is_Abstract then Val := VTM_ABSTRACT; elsif Self.Is_Truncatable then Val := VTM_TRUNCATABLE; else Val := VTM_NONE; end if; return CORBA.ORB.TypeCode.Create_Value_Tc (Get_Id (Self), Get_Name (Self), Val, Base_TC, -- FIXME >>>>>>>> calculate the valuememberseq... ValueMemberSeq (VMS.Null_Sequence)); end get_type; ------------------------- -- Get_RepositoryIdSeq -- ------------------------- function Get_RepositoryIdSeq (ValDefSeq : ValueDefSeq) return RepositoryIdSeq is Result : RepositoryIdSeq; Val_Array : constant ValDef.Element_Array := ValDef.To_Element_Array (ValDef.Sequence (ValDefSeq)); begin for I in Val_Array'Range loop declare Val : constant Object_Ptr := To_Object (Val_Array (I)); begin IdSeq.Append (IdSeq.Sequence (Result), Get_Id (Val)); end; end loop; return Result; end Get_RepositoryIdSeq; end CORBA.Repository_Root.ValueDef.Impl; polyorb-2.8~20110207.orig/cos/ir/corba-repository_root-repository-impl.ads0000644000175000017500000001063711750740337026030 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- CORBA.REPOSITORY_ROOT.REPOSITORY.IMPL -- -- -- -- S p e c -- -- -- -- Copyright (C) 2006-2008, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the CORBA Specification, and adapted -- -- for use with PolyORB. The copyright notice above, and the license -- -- provisions that follow apply solely to the contents neither explicitly -- -- nor implicitly specified by the CORBA Specification defined by the OMG. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with CORBA.Repository_Root.IDLType; with CORBA.Repository_Root.Contained; with CORBA.Repository_Root.Container.Impl; package CORBA.Repository_Root.Repository.Impl is type Object is new CORBA.Repository_Root.Container.Impl.Object with private; type Object_Ptr is access all Object'Class; -- Transform the forward to an impl.object.ptr. function To_Object (Fw_Ref : Repository_Forward.Ref) return Repository.Impl.Object_Ptr; -- To transform an object_ptr into Forward_ref function To_Forward (Obj : Object_Ptr) return Repository_Forward.Ref; function lookup_id (Self : access Object; search_id : CORBA.RepositoryId) return CORBA.Repository_Root.Contained.Ref; function get_canonical_typecode (Self : access Object; tc : CORBA.TypeCode.Object) return CORBA.TypeCode.Object; function get_primitive (Self : access Object; kind : CORBA.Repository_Root.PrimitiveKind) return CORBA.Repository_Root.PrimitiveDef_Forward.Ref; function create_string (Self : access Object; bound : CORBA.Unsigned_Long) return CORBA.Repository_Root.StringDef_Forward.Ref; function create_wstring (Self : access Object; bound : CORBA.Unsigned_Long) return CORBA.Repository_Root.WstringDef_Forward.Ref; function create_sequence (Self : access Object; bound : CORBA.Unsigned_Long; element_type : CORBA.Repository_Root.IDLType.Ref) return CORBA.Repository_Root.SequenceDef_Forward.Ref; function create_array (Self : access Object; length : CORBA.Unsigned_Long; element_type : CORBA.Repository_Root.IDLType.Ref) return CORBA.Repository_Root.ArrayDef_Forward.Ref; function create_fixed (Self : access Object; IDL_digits : CORBA.Unsigned_Short; scale : CORBA.Short) return CORBA.Repository_Root.FixedDef_Forward.Ref; private type Object is new CORBA.Repository_Root.Container.Impl.Object with null record; end CORBA.Repository_Root.Repository.Impl; polyorb-2.8~20110207.orig/cos/ir/corba-repository_root-contained-impl.adb0000644000175000017500000010603211750740337025527 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- CORBA.REPOSITORY_ROOT.CONTAINED.IMPL -- -- -- -- B o d y -- -- -- -- Copyright (C) 2005-2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ pragma Style_Checks (Off); with Ada.Text_IO; with Ada.Strings.Unbounded; with PortableServer; with CORBA.Repository_Root.Contained.Helper; with CORBA.Repository_Root.Container.Impl; with CORBA.Repository_Root.Exceptiondef.Impl; with CORBA.Repository_Root.Interfacedef.Impl; with CORBA.Repository_Root.Valuedef.Impl; with CORBA.Repository_Root.Moduledef.Impl; with CORBA.Repository_Root.Repository.Impl; with CORBA.Repository_Root.ConstantDef; with CORBA.Repository_Root.AttributeDef; with CORBA.Repository_Root.OperationDef; with CORBA.Repository_Root.ValueMemberDef; with CORBA.Repository_Root.EnumDef; with CORBA.Repository_Root.AliasDef; with CORBA.Repository_Root.NativeDef; with CORBA.Repository_Root.ValueBoxDef; with CORBA.Repository_Root.ModuleDef; with CORBA.Repository_Root.ExceptionDef; with CORBA.Repository_Root.InterfaceDef; with CORBA.Repository_Root.ValueDef; with CORBA.Repository_Root.StructDef; with CORBA.Repository_Root.UnionDef; with PolyORB.Log; pragma Elaborate_All (PolyORB.Log); with PolyORB.CORBA_P.Server_Tools; package body CORBA.Repository_Root.Contained.Impl is package Contained_For_Seq renames IDL_SEQUENCE_CORBA_Contained_Forward; ----------- -- Debug -- ----------- use PolyORB.Log; package L is new PolyORB.Log.Facility_Log ("contained.impl"); procedure O (Message : Standard.String; Level : Log_Level := Debug) renames L.Output; function C (Level : Log_Level := Debug) return Boolean renames L.Enabled; pragma Unreferenced (C); -- For conditional pragma Debug package L2 is new PolyORB.Log.Facility_Log ("contained.impl_method_trace"); procedure O2 (Message : Standard.String; Level : Log_Level := Debug) renames L2.Output; function C2 (Level : Log_Level := Debug) return Boolean renames L2.Enabled; pragma Unreferenced (C2); -- For conditional pragma Debug ---------------------- -- Procedure init -- ---------------------- procedure Init (Self : access Object; Real_Object : IRObject.Impl.Object_Ptr; Def_Kind : CORBA.Repository_Root.DefinitionKind; Id : CORBA.RepositoryId; Name : CORBA.Identifier; Version : CORBA.Repository_Root.VersionSpec; Defined_In : CORBA.Repository_Root.Container_Forward.Ref) is begin pragma Debug (O2 ("init (contained) enter")); IRObject.Impl.Init (IRObject.Impl.Object_Ptr (Self), Real_Object, Def_Kind); Self.Id := Id; Self.Name := Name; Self.Version := Version; Self.Defined_In := Defined_In; pragma Debug (O2 ("init (contained) end")); end Init; ----------------- -- To_Object -- ----------------- function To_Object (Fw_Ref : Contained_Forward.Ref) return Object_Ptr is Result : Portableserver.Servant; The_Ref : Contained.Ref; begin pragma Debug (O2 ("to_object (contained)")); The_Ref := Contained.Convert_Forward.To_Ref (Fw_Ref); pragma Debug (O2 ("to_object, before object_of")); PolyORB.CORBA_P.Server_Tools.Reference_To_Servant (The_Ref, Result); pragma Debug (O ("to_object end;")); return To_Contained (IROBject.Impl.Object_Ptr (Result)); end To_Object; ------------------ -- To_Forward -- ------------------ function To_Forward (Obj : Object_Ptr) return Contained_Forward.Ref is Result : Contained_Forward.Ref; begin case Get_Def_Kind (Obj) is when Dk_Primitive | Dk_String | Dk_Sequence | Dk_Array | Dk_Wstring | Dk_Fixed | Dk_Repository | Dk_All | Dk_Typedef | Dk_None => CORBA.Raise_Internal (CORBA.Default_Sys_Member); return Result; when Dk_Interface => declare The_Ref : InterfaceDef.Ref; begin PolyORB.CORBA_P.Server_Tools.Initiate_Servant (PortableServer.Servant (Get_Real_Object (Obj)), The_Ref); return Contained.Convert_Forward.To_Forward (Contained.Helper.To_Ref (The_Ref)); end; when Dk_Value => declare The_Ref : ValueDef.Ref; begin PolyORB.CORBA_P.Server_Tools.Initiate_Servant (PortableServer.Servant (Get_Real_Object (Obj)), The_Ref); return Contained.Convert_Forward.To_Forward (Contained.Helper.To_Ref (The_Ref)); end; when Dk_Struct => declare The_Ref : StructDef.Ref; begin PolyORB.CORBA_P.Server_Tools.Initiate_Servant (PortableServer.Servant (Get_Real_Object (Obj)), The_Ref); return Contained.Convert_Forward.To_Forward (Contained.Helper.To_Ref (The_Ref)); end; when Dk_Union => declare The_Ref : UnionDef.Ref; begin PolyORB.CORBA_P.Server_Tools.Initiate_Servant (PortableServer.Servant (Get_Real_Object (Obj)), The_Ref); return Contained.Convert_Forward.To_Forward (Contained.Helper.To_Ref (The_Ref)); end; when Dk_Enum => declare The_Ref : EnumDef.Ref; begin PolyORB.CORBA_P.Server_Tools.Initiate_Servant (PortableServer.Servant (Get_Real_Object (Obj)), The_Ref); return Contained.Convert_Forward.To_Forward (Contained.Helper.To_Ref (The_Ref)); end; when Dk_Alias => declare The_Ref : AliasDef.Ref; begin PolyORB.CORBA_P.Server_Tools.Initiate_Servant (PortableServer.Servant (Get_Real_Object (Obj)), The_Ref); return Contained.Convert_Forward.To_Forward (Contained.Helper.To_Ref (The_Ref)); end; when Dk_Native => declare The_Ref : NativeDef.Ref; begin PolyORB.CORBA_P.Server_Tools.Initiate_Servant (PortableServer.Servant (Get_Real_Object (Obj)), The_Ref); return Contained.Convert_Forward.To_Forward (Contained.Helper.To_Ref (The_Ref)); end; when Dk_ValueBox => declare The_Ref : ValueBoxDef.Ref; begin PolyORB.CORBA_P.Server_Tools.Initiate_Servant (PortableServer.Servant (Get_Real_Object (Obj)), The_Ref); return Contained.Convert_Forward.To_Forward (Contained.Helper.To_Ref (The_Ref)); end; when Dk_Exception => declare The_Ref : ExceptionDef.Ref; begin PolyORB.CORBA_P.Server_Tools.Initiate_Servant (PortableServer.Servant (Get_Real_Object (Obj)), The_Ref); return Contained.Convert_Forward.To_Forward (Contained.Helper.To_Ref (The_Ref)); end; when Dk_Module => declare The_Ref : ModuleDef.Ref; begin PolyORB.CORBA_P.Server_Tools.Initiate_Servant (PortableServer.Servant (Get_Real_Object (Obj)), The_Ref); return Contained.Convert_Forward.To_Forward (Contained.Helper.To_Ref (The_Ref)); end; when Dk_Attribute => declare The_Ref : AttributeDef.Ref; begin PolyORB.CORBA_P.Server_Tools.Initiate_Servant (PortableServer.Servant (Get_Real_Object (Obj)), The_Ref); return Contained.Convert_Forward.To_Forward (Contained.Helper.To_Ref (The_Ref)); end; when Dk_Constant => declare The_Ref : ConstantDef.Ref; begin PolyORB.CORBA_P.Server_Tools.Initiate_Servant (PortableServer.Servant (Get_Real_Object (Obj)), The_Ref); return Contained.Convert_Forward.To_Forward (Contained.Helper.To_Ref (The_Ref)); end; when Dk_Operation => declare The_Ref : OperationDef.Ref; begin PolyORB.CORBA_P.Server_Tools.Initiate_Servant (PortableServer.Servant (Get_Real_Object (Obj)), The_Ref); return Contained.Convert_Forward.To_Forward (Contained.Helper.To_Ref (The_Ref)); end; when Dk_ValueMember => declare The_Ref : ValueMemberDef.Ref; begin PolyORB.CORBA_P.Server_Tools.Initiate_Servant (PortableServer.Servant (Get_Real_Object (Obj)), The_Ref); return Contained.Convert_Forward.To_Forward (Contained.Helper.To_Ref (The_Ref)); end; when Dk_AbstractInterface .. Dk_Event => raise Program_Error; end case; end To_Forward; -------------------- -- To_Contained -- -------------------- procedure To_Contained (Self : IRObject.Impl.Object_Ptr; Success : out Boolean; Result : out Object_ptr) is begin pragma Debug (O2 ("to_contained (contained)")); Success := True; case IRObject.Impl.Get_Def_Kind (Self) is when Dk_Repository | Dk_Primitive | Dk_String | Dk_Sequence | Dk_Array | Dk_Wstring | Dk_Fixed | Dk_All | Dk_None => Success := False; Result := null; when -- inherited types Dk_Attribute | Dk_Constant | Dk_Operation | Dk_Typedef | Dk_Alias | Dk_Struct | Dk_Union | Dk_Enum | Dk_ValueBox | dk_ValueMember| dk_Native => Result := Object_Ptr (Self); -- types containing a "contained_view" field when Dk_Exception => declare Interm : constant Exceptiondef.Impl.Object_Ptr := Exceptiondef.Impl.Object_Ptr (Self); begin Result := Exceptiondef.Impl.Get_Contained_View (Interm); end; when Dk_Module => declare Interm : constant Moduledef.Impl.Object_Ptr := Moduledef.Impl.Object_Ptr (Self); begin Result := Moduledef.Impl.Get_Contained_View (Interm); end; when Dk_Value => declare Interm : constant Valuedef.Impl.Object_Ptr := Valuedef.Impl.Object_Ptr (Self); begin Result := Valuedef.Impl.Get_Contained_View (Interm); end; when Dk_Interface => declare Interm : constant Interfacedef.Impl.Object_Ptr := Interfacedef.Impl.Object_Ptr (Self); begin Result := Interfacedef.Impl.Get_Contained_View (Interm); end; when Dk_AbstractInterface .. Dk_Event => raise Program_Error; end case; return; end To_Contained; function To_Contained (Self : IRObject.Impl.Object_Ptr) return Object_ptr is begin pragma Debug (O2 ("to_contained (contained)")); case IRObject.Impl.Get_Def_Kind (Self) is when Dk_Repository | Dk_Primitive | Dk_String | Dk_Sequence | Dk_Array | Dk_Wstring | Dk_Fixed | Dk_All | Dk_None => CORBA.Raise_Internal (CORBA.Default_Sys_Member); return null; when -- inherited types Dk_Attribute | Dk_Constant | Dk_Operation | Dk_Typedef | Dk_Alias | Dk_Struct | Dk_Union | Dk_Enum | Dk_ValueBox | dk_ValueMember| dk_Native => return Object_Ptr (Self); -- types containing a "contained_view" field when Dk_Exception => declare Interm : constant Exceptiondef.Impl.Object_Ptr := Exceptiondef.Impl.Object_Ptr (Self); begin return Exceptiondef.Impl.Get_Contained_View (Interm); end; when Dk_Module => declare Interm : constant Moduledef.Impl.Object_Ptr := Moduledef.Impl.Object_Ptr (Self); begin return Moduledef.Impl.Get_Contained_View (Interm); end; when Dk_Value => declare Interm : constant Valuedef.Impl.Object_Ptr := Valuedef.Impl.Object_Ptr (Self); begin return Valuedef.Impl.Get_Contained_View (Interm); end; when Dk_Interface => declare Interm : constant Interfacedef.Impl.Object_Ptr := Interfacedef.Impl.Object_Ptr (Self); begin return Interfacedef.Impl.Get_Contained_View (Interm); end; when Dk_AbstractInterface .. Dk_Event => raise Program_Error; end case; end To_Contained; ----------------------- -- IR implementation -- ----------------------- function get_id (Self : access Object) return CORBA.RepositoryId is begin return Self.Id; end get_id; procedure set_id (Self : access Object; To : CORBA.RepositoryId) is begin -- If the Id is already used, raise an exception. if Contained.Is_Nil (Repository.Impl.Lookup_Id -- Convert the ref to object (must cast). (Repository.Impl.To_Object (Get_Containing_Repository (Self)), To)) then Self.Id := To; else CORBA.Raise_Bad_Param (CORBA.System_Exception_Members'(Minor => 2, Completed => CORBA.Completed_No)); end if; end set_id; function get_name (Self : access Object) return CORBA.Identifier is begin return Self.Name; end get_name; procedure set_name (Self : access Object; To : CORBA.Identifier) is Other : ContainedSeq; use Contained_For_Seq; begin -- Must check if the name is not already used in this scope -- So we check all the nodes in this container with the same name Other := Container.Impl.Lookup_Name (Container.Impl.To_Object (Self.Defined_In), To, 1, Dk_All, False); if Contained_For_Seq.Null_Sequence = (Contained_For_Seq.Sequence (Other)) then Self.Name := To; else CORBA.Raise_Bad_Param (CORBA.System_Exception_Members'(Minor => 1, Completed => CORBA.Completed_No)); end if; end set_name; function get_version (Self : access Object) return VersionSpec is begin return Self.Version; end get_version; procedure set_version (Self : access Object; To : VersionSpec) is begin Self.Version := To; end set_version; ---------------------- -- get_defined_in -- ---------------------- function get_defined_in (Self : access Object) return Container_Forward.Ref is begin return Self.Defined_In; end get_defined_in; function get_defined_in (Self : access Object) return CORBA.RepositoryId is Cont : constant Container.Impl.Object_Ptr := Container.Impl.To_Object (Self.Defined_In); use Container.Impl; begin if Get_Def_Kind (Cont) = Dk_Repository then return CORBA.Null_RepositoryId; end if; return Get_Id (To_Contained (Get_Real_Object (Cont))); end get_defined_in; function get_absolute_name (Self : access Object) return CORBA.ScopedName is use Container.Impl; begin pragma Debug (O2 ("get_absolute_name enter")); if Container_Forward.Is_Nil (Self.Defined_In) then pragma Debug (O ("get_absolute_name defined_in is null;")); null; end if; if Get_Def_Kind (To_Object (Self.Defined_In)) = Dk_Repository then -- if we are in the repository, then just append "::" to the name... pragma Debug (O ("get_absolute_name : it's a repository")); return CORBA.ScopedName (CORBA.To_CORBA_String ("::") & CORBA.String (Self.Name)); else declare Scope : constant Object_Ptr := To_Contained (Get_Real_Object (To_Object (Self.Defined_In))); begin pragma Debug (O2 ("get_absolute_name : it is not a repository")); -- ... else append "::" and the name to the previous absolute_name. return CORBA.ScopedName (CORBA.String (Get_Absolute_Name (Scope)) & CORBA.To_CORBA_String ("::") & CORBA.String (Self.Name)); end; end if; end get_absolute_name; function get_containing_repository (Self : access Object) return Repository_Forward.Ref is use Container.Impl; begin if Get_Def_Kind (To_Object (Self.Defined_In)) = Dk_Repository then -- the define_in is the repository return Repository.Impl.To_Forward (Repository.Impl.Object_Ptr (To_Object (Self.Defined_In))); else -- returns the repository of the parent return Get_Containing_Repository (To_Contained (Get_Real_Object (To_Object (Self.Defined_In)))); end if; end get_containing_repository; ---------------- -- describe -- ---------------- function describe (Self : access Object) return Contained.Description is begin case Get_Def_Kind (Self) is when -- not contained types Dk_Repository | Dk_Primitive | Dk_String | Dk_Sequence | Dk_Array | Dk_Wstring | Dk_Fixed | Dk_All | Dk_None => CORBA.Raise_Internal (CORBA.Default_Sys_Member); when -- child objects Dk_Attribute | Dk_Constant | Dk_Operation | Dk_Typedef | Dk_Alias | Dk_Struct | Dk_Union | Dk_Enum | Dk_ValueBox | Dk_ValueMember| dk_Native => -- dispatching call... return describe (Object_Ptr (Self)); -- types containing a "contained_view" field when Dk_Exception => declare Interm : constant Exceptiondef.Impl.Object_Ptr := Exceptiondef.Impl.Object_Ptr (Get_Real_Object (Self)); begin return Exceptiondef.Impl.Describe (Interm); end; when Dk_Module => declare Interm : constant Moduledef.Impl.Object_Ptr := Moduledef.Impl.Object_Ptr (Get_Real_Object (Self)); begin return Moduledef.Impl.Describe (Interm); end; when Dk_Value => declare Interm : constant Valuedef.Impl.Object_Ptr := Valuedef.Impl.Object_Ptr (Get_Real_Object (Self)); begin return Valuedef.Impl.Describe (Interm); end; when Dk_Interface => declare Interm : constant Interfacedef.Impl.Object_Ptr := Interfacedef.Impl.Object_Ptr (Get_Real_Object (Self)); begin return Interfacedef.Impl.Describe (Interm); end; when Dk_AbstractInterface .. Dk_Event => raise Program_Error; end case; end describe; ---------- -- move -- ---------- procedure move (Self : access Object; new_container : Container_Forward.Ref; new_name : CORBA.Identifier; new_version : VersionSpec) is use Repository.Impl; For_Container_Ptr : constant Container.Impl.Object_Ptr := Container.Impl.To_Object (Self.Defined_In); New_Container_Ptr : constant Container.Impl.Object_Ptr := Container.Impl.To_Object (New_Container); Rep1 : constant Repository.Impl.Object_Ptr := Repository.Impl.To_Object (Get_Containing_Repository (Self)); Rep2 : Repository.Impl.Object_Ptr; begin if Container.Impl.Get_Def_Kind (New_Container_Ptr) = dk_Repository then Rep2 := Repository.Impl.Object_Ptr (New_Container_Ptr); else Rep2 := Repository.Impl.To_Object (Get_Containing_Repository (To_Contained (Container.Impl.Get_Real_Object (New_Container_Ptr)))); end if; -- It must be in the same Repository if Rep1 /= Rep2 then CORBA.Raise_Bad_Param (CORBA.System_Exception_Members'(Minor => 4, Completed => CORBA.Completed_No)); end if; -- The move should comply with CORBA 3.0 10.4.4 -- (Structure and Navigation of the Interface Repository) Container.Impl.Check_Structure (New_Container_Ptr, Get_Def_Kind (Self)); -- Check if the name is not already used in this scope. Container.Impl.Check_Name (New_Container_Ptr, New_Name); -- Remove the contained from the previous container Container.Impl.Delete_From_Contents (For_Container_Ptr, Object_Ptr (Self)); -- We can move this contained to this container Self.Defined_In := New_Container; Self.Name := New_Name; Self.Version := New_Version; -- Add the contained to the new container Container.Impl.Append_To_Contents (New_Container_Ptr, Object_Ptr (Self)); end move; ------------------------ -- A Seq of contained -- ------------------------ ------------------------------ -- Simplify_Contained_Seq -- ------------------------------ procedure Simplify_ContainedSeq (In_Seq : in out ContainedSeq) is Cont_Array : constant Contained_For_Seq.Element_Array := Contained_For_Seq.To_Element_Array (Contained_For_Seq.Sequence (In_Seq)); begin for I in Cont_Array'Range loop for J in (I + 1) .. (Cont_Array'Last) loop if To_Object (Cont_Array (I)) = To_Object (Cont_Array (J)) then declare Ind : Natural; Del_Array : Contained_For_Seq.Element_Array (1 .. 1); begin Del_Array (1) := Cont_Array (J); Ind := Contained_For_Seq.Index (Contained_For_Seq.Sequence (In_Seq), Del_Array, PolyORB.Sequences.Backward); Contained_For_Seq.Delete (Contained_For_Seq.Sequence (In_Seq), Ind, Ind); end; end if; end loop; end loop; end; ----------------- -- Lookup_id -- ----------------- function Lookup_Id (In_Seq : Contained_Seq.Sequence; Search_Id : CORBA.RepositoryId) return Object_Ptr is Result : Object_Ptr := null; Success : Boolean; Container_Object : Container.Impl.Object_Ptr; Cont_Array : constant Contained_Seq.Element_Array := Contained_Seq.To_Element_Array (In_Seq); begin for I in Cont_Array'Range loop exit when Result /= null; if Is_Equivalent (Cont_Array (I).Id, Search_Id) then Result := Cont_Array (I); else Container.Impl.To_Container (Get_Real_Object (Cont_Array (I)), Success, Container_Object); if Success then Result := Lookup_Id (Container.Impl.Get_Contents (Container_Object), Search_Id); end if; end if; end loop; return Result; end Lookup_Id; ------------------------- -- Lookup_Scoped_Name -- ------------------------- function Lookup_ScopedName (In_Seq : Contained_Seq.Sequence; Name : ScopedName) return Object_Ptr is use Ada.Strings.Unbounded; Result : Object_Ptr := null; Search : Unbounded_String := Unbounded_String (Name); Look : Unbounded_String; Ind : Natural; begin -- Should not begin with :: if Head (Search, 2) = "::" then CORBA.Raise_Internal (Default_Sys_Member); end if; -- Calculate the Index of "::" Ind := Index (Search, "::"); if Ind /= 0 then -- create the name to look at in the In_Seq Look := Head (Search, Ind - To_String (Search)'First); -- create the new search Tail (Search, Length (Search) - Length (Look) - 2); else -- create the name to look at in the In_Seq Look := Search; end if; declare Cont_Array : constant Contained_Seq.Element_Array := Contained_Seq.To_Element_Array (In_Seq); begin for I in Cont_Array'Range loop if Cont_Array (I).Name = Identifier (Look) then Result := Cont_Array (I); exit; end if; end loop; end; if Result = null then return null; end if; if Ind = 0 then -- we finally found the right object return Result; else -- the scopedName is no empty, we have to continue the query declare Success : Boolean; Obj : Container.Impl.Object_Ptr; begin -- What we found should be a container... Container.Impl.To_Container (Get_Real_Object (Result), Success, Obj); if not Success then return null; else return Lookup_ScopedName (Container.Impl.Get_Contents (Obj), ScopedName (Search)); end if; end; end if; end Lookup_ScopedName; ----------------- -- Lookup_Name -- ----------------- function Lookup_Name (In_Seq : Contained_Seq.Sequence; Name : Identifier; Limit_Type : DefinitionKind) return ContainedSeq is Result : Contained_Seq.Sequence := Contained_Seq.Null_Sequence; Cont_Array : constant Contained_Seq.Element_Array := Contained_Seq.To_Element_Array (In_Seq); begin for I in Cont_Array'Range loop if Cont_Array (I).Name = Name then -- if limit_type is dk_all or if we get the right limit_type... if (Limit_Type = Dk_All) or (Limit_Type = Get_Def_Kind (Cont_Array (I))) then -- ...we should append this contained to the list Contained_Seq.Append (Result, Cont_Array (I)); end if; end if; end loop; return To_ContainedSeq (Result); end; ---------------- -- Contents -- ---------------- function Contents (In_Seq : Contained_Seq.Sequence; Limit_Type : DefinitionKind) return ContainedSeq is begin if Limit_Type = Dk_All then return To_ContainedSeq (In_Seq); else -- we can only select the containeds with the right def_kind declare Result : Contained_Seq.Sequence := Contained_Seq.Null_Sequence; Cont_Array : constant Contained_Seq.Element_Array := Contained_Seq.To_Element_Array (In_Seq); begin for I in Cont_Array'Range loop -- if we get the right limit_type... if Limit_Type = Get_Def_Kind (Cont_Array (I)) then -- ...we should append this contained to the list Contained_Seq.Append (Result, Cont_Array (I)); end if; end loop; return To_ContainedSeq (Result); end; end if; end; ----------------------- -- To_ContainedSeq -- ----------------------- function To_ContainedSeq (In_Seq : Contained_Seq.Sequence) return CORBA.Repository_Root.ContainedSeq is Cont_Array : constant Contained_Seq.Element_Array := Contained_Seq.To_Element_Array (In_Seq); Result : CORBA.Repository_Root.ContainedSeq := CORBA.Repository_Root.ContainedSeq (Contained_For_Seq.Null_Sequence); begin for I in Cont_Array'Range loop declare Cont : constant Object_Ptr := Cont_Array (I); begin Contained_For_Seq.Append (Contained_For_Seq.Sequence (Result), To_Forward (Cont)); end; end loop; return Result; end To_ContainedSeq; ----------------------------- -- To_Contained_Sequence -- ----------------------------- function To_Contained_Sequence (In_Seq : ContainedSeq) return Contained_Seq.Sequence is Cont_Array : constant Contained_For_Seq.Element_Array := Contained_For_Seq.To_Element_Array (Contained_For_Seq.Sequence (In_Seq)); Result : Contained_Seq.Sequence := Contained_Seq.Null_Sequence; begin for I in Cont_Array'Range loop Contained_Seq.Append (Result, To_Object (Cont_Array (I))); end loop; return Result; end To_Contained_Sequence; --------------------- -- Print_content -- --------------------- procedure Print_Content (In_Seq : Contained_Seq.Sequence; Inc : Standard.String) is use Ada.Text_IO; Cont_Array : constant Contained_Seq.Element_Array := Contained_Seq.To_Element_Array (In_Seq); begin for I in Cont_Array'Range loop declare Success : Boolean; Container_Object : Container.Impl.Object_Ptr; begin Put_Line (Inc & "Node : " & DefinitionKind'Image (Get_Def_Kind (Cont_Array (I)))); Put_Line (Inc & "Name : " & CORBA.To_Standard_String (CORBA.String (Get_Name (Cont_Array (I))))); Put_Line (Inc & "Id : " & CORBA.To_Standard_String (CORBA.String (Get_Id (Cont_Array (I))))); Put_Line (Inc & "Vers : " & CORBA.To_Standard_String (CORBA.String (Get_Version (Cont_Array (I))))); Put_Line (Inc & "Abs-Name : " & CORBA.To_Standard_String (CORBA.String (Get_Absolute_Name (Cont_Array (I))))); Container.Impl.To_Container (Get_Real_Object (Cont_Array (I)), Success, Container_Object); if Success then Print_Content (Container.Impl.Get_Contents (Container_Object), Inc & " "); end if; end; end loop; end; end CORBA.Repository_Root.Contained.Impl; polyorb-2.8~20110207.orig/cos/ir/corba-repository_root-uniondef-impl.ads0000644000175000017500000002543211750740337025417 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- C O R B A . R E P O S I T O R Y _ R O O T . U N I O N D E F . I M P L -- -- -- -- S p e c -- -- -- -- Copyright (C) 2006-2008, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the CORBA Specification, and adapted -- -- for use with PolyORB. The copyright notice above, and the license -- -- provisions that follow apply solely to the contents neither explicitly -- -- nor implicitly specified by the CORBA Specification defined by the OMG. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with CORBA.Repository_Root.Container; with CORBA.Repository_Root.Contained; with CORBA.Repository_Root.IDLType; with CORBA.Repository_Root.IRObject.Impl; with CORBA.Repository_Root.Contained.Impl; with CORBA.Repository_Root.IDLType.Impl; with CORBA.Repository_Root.Container.Impl; with CORBA.Repository_Root.TypedefDef.Impl; package CORBA.Repository_Root.UnionDef.Impl is type Object is new CORBA.Repository_Root.TypedefDef.Impl.Object with private; type Object_Ptr is access all Object'Class; -- To transform a forward_ref in impl.object_ptr. function To_Object (Fw_Ref : UnionDef_Forward.Ref) return Object_Ptr; -- To transform an object_ptr into Forward_ref function To_Forward (Obj : Object_Ptr) return UnionDef_Forward.Ref; -- method used to initialize recursively the object fields. procedure Init (Self : access Object; Real_Object : CORBA.Repository_Root.IRObject.Impl.Object_Ptr; Def_Kind : CORBA.Repository_Root.DefinitionKind; Id : CORBA.RepositoryId; Name : CORBA.Identifier; Version : CORBA.Repository_Root.VersionSpec; Defined_In : CORBA.Repository_Root.Container_Forward.Ref; IDLType_View : CORBA.Repository_Root.IDLType.Impl.Object_Ptr; Contents : CORBA.Repository_Root.Contained.Impl.Contained_Seq.Sequence; Container_View : CORBA.Repository_Root.Container.Impl.Object_Ptr; Discriminator_Type_Def : CORBA.Repository_Root.IDLType.Ref; Members : CORBA.Repository_Root.UnionMemberSeq); -- For multiple inheritance, to access the different views function Get_Container_View (Self : access Object) return CORBA.Repository_Root.Container.Impl.Object_Ptr; -- Set the members attribute while putting the "type" field -- of the member to TC_Void procedure Initialize_Members (Self : access Object; Seq : UnionMemberSeq); -- overload the get_type from IDLType function get_type (Self : access Object) return CORBA.TypeCode.Object; function get_discriminator_type (Self : access Object) return CORBA.TypeCode.Object; function get_discriminator_type_def (Self : access Object) return CORBA.Repository_Root.IDLType.Ref; procedure set_discriminator_type_def (Self : access Object; To : CORBA.Repository_Root.IDLType.Ref); function get_members (Self : access Object) return CORBA.Repository_Root.UnionMemberSeq; procedure set_members (Self : access Object; To : CORBA.Repository_Root.UnionMemberSeq); function lookup (Self : access Object; search_name : CORBA.ScopedName) return CORBA.Repository_Root.Contained.Ref; function contents (Self : access Object; limit_type : CORBA.Repository_Root.DefinitionKind; exclude_inherited : CORBA.Boolean) return CORBA.Repository_Root.ContainedSeq; function lookup_name (Self : access Object; search_name : CORBA.Identifier; levels_to_search : CORBA.Long; limit_type : CORBA.Repository_Root.DefinitionKind; exclude_inherited : CORBA.Boolean) return CORBA.Repository_Root.ContainedSeq; function describe_contents (Self : access Object; limit_type : CORBA.Repository_Root.DefinitionKind; exclude_inherited : CORBA.Boolean; max_returned_objs : CORBA.Long) return CORBA.Repository_Root.Container.DescriptionSeq; function create_module (Self : access Object; id : CORBA.RepositoryId; name : CORBA.Identifier; version : CORBA.Repository_Root.VersionSpec) return CORBA.Repository_Root.ModuleDef_Forward.Ref; function create_constant (Self : access Object; id : CORBA.RepositoryId; name : CORBA.Identifier; version : CORBA.Repository_Root.VersionSpec; IDL_type : CORBA.Repository_Root.IDLType_Forward.Ref; value : CORBA.Any) return CORBA.Repository_Root.ConstantDef_Forward.Ref; function create_struct (Self : access Object; id : CORBA.RepositoryId; name : CORBA.Identifier; version : CORBA.Repository_Root.VersionSpec; members : CORBA.Repository_Root.StructMemberSeq) return CORBA.Repository_Root.StructDef_Forward.Ref; function create_union (Self : access Object; id : CORBA.RepositoryId; name : CORBA.Identifier; version : CORBA.Repository_Root.VersionSpec; discriminator_type : CORBA.Repository_Root.IDLType_Forward.Ref; members : CORBA.Repository_Root.UnionMemberSeq) return CORBA.Repository_Root.UnionDef_Forward.Ref; function create_enum (Self : access Object; id : CORBA.RepositoryId; name : CORBA.Identifier; version : CORBA.Repository_Root.VersionSpec; members : CORBA.Repository_Root.EnumMemberSeq) return CORBA.Repository_Root.EnumDef_Forward.Ref; function create_alias (Self : access Object; id : CORBA.RepositoryId; name : CORBA.Identifier; version : CORBA.Repository_Root.VersionSpec; original_type : CORBA.Repository_Root.IDLType_Forward.Ref) return CORBA.Repository_Root.AliasDef_Forward.Ref; function create_interface (Self : access Object; id : CORBA.RepositoryId; name : CORBA.Identifier; version : CORBA.Repository_Root.VersionSpec; base_interfaces : CORBA.Repository_Root.InterfaceDefSeq; is_abstract : CORBA.Boolean) return CORBA.Repository_Root.InterfaceDef_Forward.Ref; function create_value (Self : access Object; id : CORBA.RepositoryId; name : CORBA.Identifier; version : CORBA.Repository_Root.VersionSpec; is_custom : CORBA.Boolean; is_abstract : CORBA.Boolean; base_value : CORBA.Repository_Root.ValueDef_Forward.Ref; is_truncatable : CORBA.Boolean; abstract_base_values : CORBA.Repository_Root.ValueDefSeq; supported_interfaces : CORBA.Repository_Root.InterfaceDefSeq; initializers : CORBA.Repository_Root.InitializerSeq) return CORBA.Repository_Root.ValueDef_Forward.Ref; function create_value_box (Self : access Object; id : CORBA.RepositoryId; name : CORBA.Identifier; version : CORBA.Repository_Root.VersionSpec; original_type_def : CORBA.Repository_Root.IDLType_Forward.Ref) return CORBA.Repository_Root.ValueBoxDef_Forward.Ref; function create_exception (Self : access Object; id : CORBA.RepositoryId; name : CORBA.Identifier; version : CORBA.Repository_Root.VersionSpec; members : CORBA.Repository_Root.StructMemberSeq) return CORBA.Repository_Root.ExceptionDef_Forward.Ref; function create_native (Self : access Object; id : CORBA.RepositoryId; name : CORBA.Identifier; version : CORBA.Repository_Root.VersionSpec) return CORBA.Repository_Root.NativeDef_Forward.Ref; function create_abstract_interface (Self : access Object; id : RepositoryId; name : Identifier; version : VersionSpec; base_interfaces : AbstractInterfaceDefSeq) return AbstractInterfaceDef_Forward.Ref; function create_local_interface (Self : access Object; id : RepositoryId; name : Identifier; version : VersionSpec; base_interfaces : InterfaceDefSeq) return LocalInterfaceDef_Forward.Ref; -- Implementation Notes: create_ext_value commented out because of error -- in idlac/ALM (see CORBA_InterfaceRepository.idl) -- function create_ext_value -- (Self : access Object; -- id : RepositoryId; -- name : Identifier; -- version : VersionSpec; -- is_custom : CORBA.Boolean; -- is_abstract : CORBA.Boolean; -- base_value : ValueDef_Forward.Ref; -- is_truncatable : CORBA.Boolean; -- abstract_base_values : ValueDefSeq; -- supported_interfaces : InterfaceDefSeq; -- initializers : ExtInitializerSeq) -- return ExtValueDef_Forward.Ref; private type Object is new CORBA.Repository_Root.TypedefDef.Impl.Object with record Container_View : CORBA.Repository_Root.Container.Impl.Object_Ptr; -- The discriminator typecode is the one of the IDLType Discriminator_Type_Def : CORBA.Repository_Root.IDLType.Ref; Members : CORBA.Repository_Root.UnionMemberSeq; end record; end CORBA.Repository_Root.UnionDef.Impl; polyorb-2.8~20110207.orig/cos/ir/corba-repository_root-fixeddef-impl.adb0000644000175000017500000000702011750740337025336 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- C O R B A . R E P O S I T O R Y _ R O O T . F I X E D D E F . I M P L -- -- -- -- B o d y -- -- -- -- Copyright (C) 2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with CORBA.ORB; with CORBA.Repository_Root.FixedDef.Skel; pragma Warnings (Off, CORBA.Repository_Root.FixedDef.Skel); package body CORBA.Repository_Root.FixedDef.Impl is procedure Init (Self : access Object; Real_Object : CORBA.Repository_Root.IRObject.Impl.Object_Ptr; Def_Kind : CORBA.Repository_Root.DefinitionKind; IDL_Digits : CORBA.Unsigned_Short; Scale : CORBA.Short) is begin IDLType.Impl.Init (IDLType.Impl.Object_Ptr (Self), Real_Object, Def_Kind); Self.IDL_Digits := IDL_Digits; Self.Scale := Scale; end Init; ---------------- -- get_type -- ---------------- function get_type (Self : access Object) return CORBA.TypeCode.Object is begin return CORBA.ORB.Create_Fixed_Tc (Self.IDL_Digits, Self.Scale); end get_type; function get_digits (Self : access Object) return CORBA.Unsigned_Short is begin return Self.IDL_Digits; end get_digits; procedure set_digits (Self : access Object; To : CORBA.Unsigned_Short) is begin Self.IDL_Digits := To; end set_digits; function get_scale (Self : access Object) return CORBA.Short is begin return Self.Scale; end get_scale; procedure set_scale (Self : access Object; To : CORBA.Short) is begin Self.Scale := To; end set_scale; end CORBA.Repository_Root.FixedDef.Impl; polyorb-2.8~20110207.orig/cos/ir/corba-repository_root-interfaceattrextension-impl.adb0000644000175000017500000001230711750740337030354 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- CORBA.REPOSITORY_ROOT.INTERFACEATTREXTENSION.IMPL -- -- -- -- B o d y -- -- -- -- Copyright (C) 2006-2008, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with CORBA.Repository_Root.Contained.Impl; with CORBA.Repository_Root.ExtAttributeDef.Impl; with CORBA.Repository_Root.InterfaceAttrExtension.Skel; pragma Warnings (Off, CORBA.Repository_Root.InterfaceAttrExtension.Skel); with PolyORB.CORBA_P.Server_Tools; package body CORBA.Repository_Root.InterfaceAttrExtension.Impl is -------------------------- -- create_ext_attribute -- -------------------------- function create_ext_attribute (Self : access Object; id : RepositoryId; name : Identifier; version : VersionSpec; IDL_type : IDLType.Ref; mode : AttributeMode; get_exceptions : ExceptionDefSeq; set_exceptions : ExceptionDefSeq) return ExtAttributeDef.Ref is begin Container.Impl.Check_Structure (Self.Real, dk_Attribute); Container.Impl.Check_Id (Self.Real, id); Container.Impl.Check_Name (Self.Real, name); declare Result : CORBA.Repository_Root.ExtAttributeDef.Ref; Obj : constant ExtAttributeDef.Impl.Object_Ptr := new ExtAttributeDef.Impl.Object; begin -- Initialize object ExtAttributeDef.Impl.Internals.Init (Obj, IRObject.Impl.Object_Ptr (Obj), dk_Attribute, id, name, version, Container.Impl.To_Forward (Self.Real), IDL_type, mode, get_exceptions, set_exceptions); -- Add it to contents of this container Container.Impl.Append_To_Contents (Self.Real, Contained.Impl.To_Contained (IRObject.Impl.Object_Ptr (Obj))); -- Activate it PolyORB.CORBA_P.Server_Tools.Initiate_Servant (PortableServer.Servant (Obj), Result); return Result; end; end create_ext_attribute; ---------------------------- -- describe_ext_interface -- ---------------------------- function describe_ext_interface (Self : access Object) return InterfaceAttrExtension.ExtFullInterfaceDescription is pragma Unreferenced (Self); Nil_Ref : InterfaceAttrExtension.ExtFullInterfaceDescription; pragma Warnings (Off, Nil_Ref); -- XXX this operation need to be implemented begin -- Insert implementation of describe_ext_interface return Nil_Ref; -- return -- (name => get_name (Self.Associated_Interface), -- id => get_id (Self.Associated_Interface), -- defined_in => -- Contained.Impl.get_defined_in ((Self.Associated_Interface), -- version => get_version (Self.Associated_Interface), -- operations => XXX -- attributes => XXX -- base_interfaces end describe_ext_interface; package body Internals is ---------- -- Init -- ---------- procedure Init (Self : access Object'Class; Real_Object : IRObject.Impl.Object_Ptr) is begin Self.Real := Container.Impl.Object_Ptr (Real_Object); end Init; end Internals; end CORBA.Repository_Root.InterfaceAttrExtension.Impl; polyorb-2.8~20110207.orig/cos/ir/corba-repository_root-repository-impl.adb0000644000175000017500000003126411750740337026006 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- CORBA.REPOSITORY_ROOT.REPOSITORY.IMPL -- -- -- -- B o d y -- -- -- -- Copyright (C) 2005-2007, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with CORBA.Object; with PortableServer; with CORBA.Repository_Root.FixedDef; with CORBA.Repository_Root.FixedDef.Impl; with CORBA.Repository_Root.ArrayDef.Impl; with CORBA.Repository_Root.ArrayDef; with CORBA.Repository_Root.SequenceDef; with CORBA.Repository_Root.SequenceDef.Impl; with CORBA.Repository_Root.WstringDef; with CORBA.Repository_Root.WstringDef.Impl; with CORBA.Repository_Root.StringDef; with CORBA.Repository_Root.StringDef.Impl; with CORBA.Repository_Root.PrimitiveDef; with CORBA.Repository_Root.PrimitiveDef.Impl; with CORBA.Repository_Root.Contained.Impl; with CORBA.Repository_Root.IRObject.Impl; with CORBA.Repository_Root.Repository.Skel; pragma Warnings (Off, CORBA.Repository_Root.Repository.Skel); with PolyORB.Log; pragma Elaborate_All (PolyORB.Log); with PolyORB.CORBA_P.Server_Tools; package body CORBA.Repository_Root.Repository.Impl is ----------- -- Debug -- ----------- use PolyORB.Log; -- package L is new PolyORB.Log.Facility_Log ("repository.impl"); -- procedure O (Message : Standard.String; Level : Log_Level := Debug) -- renames L.Output; -- function C (Level : Log_Level := Debug) return Boolean -- renames L.Enabled; -- pragma Unreferenced (C); -- For conditional pragma Debug package L2 is new PolyORB.Log.Facility_Log ("repository.impl_method_trace"); procedure O2 (Message : Standard.String; Level : Log_Level := Debug) renames L2.Output; function C2 (Level : Log_Level := Debug) return Boolean renames L2.Enabled; pragma Unreferenced (C2); -- For conditional pragma Debug ----------------- -- To_Object -- ----------------- function To_Object (Fw_Ref : Repository_Forward.Ref) return Object_Ptr is Result : PortableServer.Servant; begin pragma Debug (O2 ("to_object (repository)")); PolyORB.CORBA_P.Server_Tools.Reference_To_Servant (Repository.Convert_Forward.To_Ref (Fw_Ref), Result); return Object_Ptr (Result); end To_Object; ------------------ -- To_Forward -- ------------------ function To_Forward (Obj : Object_Ptr) return Repository_Forward.Ref is Ref : Repository.Ref; begin pragma Debug (O2 ("to_forward (repository)")); PolyORB.CORBA_P.Server_Tools.Initiate_Servant (PortableServer.Servant (Obj), Ref); return Repository.Convert_Forward.To_Forward (Ref); end To_Forward; function lookup_id (Self : access Object; search_id : CORBA.RepositoryId) return CORBA.Repository_Root.Contained.Ref is Result_Object : Contained.Impl.Object_Ptr; Nil_Ref : CORBA.Repository_Root.Contained.Ref; pragma Warnings (Off, Nil_Ref); -- Not initialized explicitly. use Contained.Impl; begin Result_Object := Contained.Impl.Lookup_Id (Get_Contents (Self), search_id); -- Return a nil_ref if not found if Result_Object = null then return Nil_Ref; end if; return Contained.Convert_Forward.To_Ref (Contained.Impl.To_Forward (Result_Object)); end lookup_id; function get_canonical_typecode (Self : access Object; tc : CORBA.TypeCode.Object) return CORBA.TypeCode.Object is pragma Warnings (Off); pragma Unreferenced (Self, tc); pragma Warnings (On); Result : CORBA.TypeCode.Object; begin -- Insert implementation of get_canonical_typecode return Result; end get_canonical_typecode; --------------------- -- get_primitive -- --------------------- function get_primitive (Self : access Object; kind : CORBA.Repository_Root.PrimitiveKind) return CORBA.Repository_Root.PrimitiveDef_Forward.Ref is pragma Warnings (Off); pragma Unreferenced (Self); pragma Warnings (On); Result : CORBA.Repository_Root.PrimitiveDef.Ref; Obj : constant PrimitiveDef.Impl.Object_Ptr := new PrimitiveDef.Impl.Object; IDL_Type : CORBA.TypeCode.Object; begin -- Create the appropriate TypeCode case kind is when pk_null => IDL_Type := TC_Null; when pk_void => IDL_Type := TC_Void; when pk_short => IDL_Type := TC_Short; when pk_long => IDL_Type := TC_Long; when pk_ushort => IDL_Type := TC_Unsigned_Short; when pk_ulong => IDL_Type := TC_Unsigned_Long; when pk_float => IDL_Type := TC_Float; when pk_double => IDL_Type := TC_Double; when pk_boolean => IDL_Type := TC_Boolean; when pk_char => IDL_Type := TC_Char; when pk_octet => IDL_Type := TC_Octet; when pk_any => IDL_Type := TC_Any; when pk_TypeCode => IDL_Type := TC_TypeCode; when pk_string => IDL_Type := TC_String; when pk_objref => IDL_Type := CORBA.Object.TC_Object; when pk_longlong => IDL_Type := TC_Long_Long; when pk_ulonglong => IDL_Type := TC_Unsigned_Long_Long; when pk_longdouble => IDL_Type := TC_Long_Double; when pk_wchar => IDL_Type := TC_Wchar; when pk_wstring => IDL_Type := TC_Wide_String; -- ??? dubious: the following are not valid typecodes, they lack -- some parameters. when pk_value_base => IDL_Type := CORBA.TypeCode.Internals.To_CORBA_Object (PolyORB.Any.TypeCode.TC_Value); when pk_Principal => IDL_Type := CORBA.TypeCode.Internals.To_CORBA_Object (PolyORB.Any.TypeCode.TC_Principal); end case; -- initialize the object PrimitiveDef.Impl.Init (Obj, IRObject.Impl.Object_Ptr (Obj), dk_Primitive, IDL_Type, kind); -- activate it PolyORB.CORBA_P.Server_Tools.Initiate_Servant (PortableServer.Servant (Obj), Result); return PrimitiveDef.Convert_Forward.To_Forward (Result); end get_primitive; function create_string (Self : access Object; bound : CORBA.Unsigned_Long) return CORBA.Repository_Root.StringDef_Forward.Ref is pragma Warnings (Off); pragma Unreferenced (Self); pragma Warnings (On); Result : StringDef.Ref; Obj : constant StringDef.Impl.Object_Ptr := new StringDef.Impl.Object; begin -- initialization of the string StringDef.Impl.Init (Obj, IRObject.Impl.Object_Ptr (Obj), dk_String, bound); -- activate it PolyORB.CORBA_P.Server_Tools.Initiate_Servant (PortableServer.Servant (Obj), Result); return StringDef.Convert_Forward.To_Forward (Result); end create_string; function create_wstring (Self : access Object; bound : CORBA.Unsigned_Long) return CORBA.Repository_Root.WstringDef_Forward.Ref is pragma Warnings (Off); pragma Unreferenced (Self); pragma Warnings (On); Result : CORBA.Repository_Root.WstringDef.Ref; Obj : constant WstringDef.Impl.Object_Ptr := new WstringDef.Impl.Object; begin -- initialization of the wstring WstringDef.Impl.Init (Obj, IRObject.Impl.Object_Ptr (Obj), dk_Wstring, bound); -- activate it PolyORB.CORBA_P.Server_Tools.Initiate_Servant (PortableServer.Servant (Obj), Result); return WstringDef.Convert_Forward.To_Forward (Result); end create_wstring; function create_sequence (Self : access Object; bound : CORBA.Unsigned_Long; element_type : CORBA.Repository_Root.IDLType.Ref) return CORBA.Repository_Root.SequenceDef_Forward.Ref is pragma Warnings (Off); pragma Unreferenced (Self); pragma Warnings (On); Result : CORBA.Repository_Root.SequenceDef.Ref; Elem_Obj : PortableServer.Servant; Obj : constant SequenceDef.Impl.Object_Ptr := new SequenceDef.Impl.Object; begin PolyORB.CORBA_P.Server_Tools.Reference_To_Servant (element_type, Elem_Obj); -- initialization of the Sequence SequenceDef.Impl.Init (Obj, IRObject.Impl.Object_Ptr (Obj), dk_Sequence, bound, element_type); -- activate it PolyORB.CORBA_P.Server_Tools.Initiate_Servant (PortableServer.Servant (Obj), Result); return SequenceDef.Convert_Forward.To_Forward (Result); end create_sequence; function create_array (Self : access Object; length : CORBA.Unsigned_Long; element_type : CORBA.Repository_Root.IDLType.Ref) return CORBA.Repository_Root.ArrayDef_Forward.Ref is pragma Warnings (Off); pragma Unreferenced (Self); pragma Warnings (On); Result : CORBA.Repository_Root.ArrayDef.Ref; Obj : constant ArrayDef.Impl.Object_Ptr := new ArrayDef.Impl.Object; Elem_Obj : PortableServer.Servant; begin PolyORB.CORBA_P.Server_Tools.Reference_To_Servant (element_type, Elem_Obj); -- initialization of the Array ArrayDef.Impl.Init (Obj, IRObject.Impl.Object_Ptr (Obj), dk_Array, length, element_type); -- activate it PolyORB.CORBA_P.Server_Tools.Initiate_Servant (PortableServer.Servant (Obj), Result); return ArrayDef.Convert_Forward.To_Forward (Result); end create_array; function create_fixed (Self : access Object; IDL_digits : CORBA.Unsigned_Short; scale : CORBA.Short) return CORBA.Repository_Root.FixedDef_Forward.Ref is pragma Warnings (Off); pragma Unreferenced (Self); pragma Warnings (On); Result : CORBA.Repository_Root.FixedDef.Ref; Obj : constant FixedDef.Impl.Object_Ptr := new FixedDef.Impl.Object; begin -- initialization of the Fixed FixedDef.Impl.Init (Obj, IRObject.Impl.Object_Ptr (Obj), dk_Fixed, IDL_digits, scale); -- Activate it PolyORB.CORBA_P.Server_Tools.Initiate_Servant (PortableServer.Servant (Obj), Result); return FixedDef.Convert_Forward.To_Forward (Result); end create_fixed; end CORBA.Repository_Root.Repository.Impl; polyorb-2.8~20110207.orig/cos/ir/corba-repository_root-container-impl.ads0000644000175000017500000002541011750740337025566 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- CORBA.REPOSITORY_ROOT.CONTAINER.IMPL -- -- -- -- S p e c -- -- -- -- Copyright (C) 2006-2008, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the CORBA Specification, and adapted -- -- for use with PolyORB. The copyright notice above, and the license -- -- provisions that follow apply solely to the contents neither explicitly -- -- nor implicitly specified by the CORBA Specification defined by the OMG. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with CORBA.Repository_Root.Contained; with CORBA.Repository_Root.Contained.Impl; with CORBA.Repository_Root.IRObject.Impl; package CORBA.Repository_Root.Container.Impl is type Object is new CORBA.Repository_Root.IRObject.Impl.Object with private; type Object_Ptr is access all Object'Class; -- method used to initialize recursively the object fields. procedure Init (Self : access Object; Real_Object : CORBA.Repository_Root.IRObject.Impl.Object_Ptr; Def_Kind : CORBA.Repository_Root.DefinitionKind; Contents : CORBA.Repository_Root.Contained.Impl.Contained_Seq.Sequence); -- To transform a forward_ref in impl.object_ptr. function To_Object (Fw_Ref : Container_Forward.Ref) return Container.Impl.Object_Ptr; -- To transform an object_ptr into Forward_ref function To_Forward (Obj : Object_Ptr) return Container_Forward.Ref; -- Our function to get the contents list. function Get_Contents (Self : access Object) return CORBA.Repository_Root.Contained.Impl.Contained_Seq.Sequence; -- Our function to set the contents list. procedure Set_Contents (Self : access Object; New_List : in CORBA.Repository_Root.Contained.Impl.Contained_Seq.Sequence); -- Procedure to append an element to the contents procedure Append_To_Contents (Self : access Object; Element : Contained.Impl.Object_Ptr); -- Procedure to delete an element from the contents procedure Delete_From_Contents (Self : access Object; Element : Contained.Impl.Object_Ptr); -- usefull for the multiple inhertance -- transform an IRObject to a container -- success is true if it is possible procedure To_Container (Self : CORBA.Repository_Root.IRObject.Impl.Object_Ptr; Success : out Boolean; Result : out Object_Ptr); -- should only be called if the cast is safe! function To_Container (Self : CORBA.Repository_Root.IRObject.Impl.Object_Ptr) return Object_Ptr; -- Check if a node of this Id already exists in self. -- If yes, raise BAD_PARAM (Minor => 2). procedure Check_Id (Self : access Object; Id : RepositoryId); -- Check if a node of this name already exists in self. -- If yes, raise BAD_PARAM (Minor => 3). procedure Check_Name (Self : access Object; Name : Identifier); -- Check if a node of kind "Kind", can be created or moved in Self, -- according to the navigation and structure rules. -- Raise BAD_PARAM (Minor => 4) if not compliant. procedure Check_Structure (Self : access Object; Kind : DefinitionKind); ------------- -- IR spec -- ------------- function lookup (Self : access Object; search_name : CORBA.ScopedName) return CORBA.Repository_Root.Contained.Ref; function contents (Self : access Object; limit_type : CORBA.Repository_Root.DefinitionKind; exclude_inherited : CORBA.Boolean) return CORBA.Repository_Root.ContainedSeq; function lookup_name (Self : access Object; search_name : CORBA.Identifier; levels_to_search : CORBA.Long; limit_type : CORBA.Repository_Root.DefinitionKind; exclude_inherited : CORBA.Boolean) return CORBA.Repository_Root.ContainedSeq; function describe_contents (Self : access Object; limit_type : CORBA.Repository_Root.DefinitionKind; exclude_inherited : CORBA.Boolean; max_returned_objs : CORBA.Long) return CORBA.Repository_Root.Container.DescriptionSeq; function create_module (Self : access Object; id : CORBA.RepositoryId; name : CORBA.Identifier; version : CORBA.Repository_Root.VersionSpec) return CORBA.Repository_Root.ModuleDef_Forward.Ref; function create_constant (Self : access Object; id : CORBA.RepositoryId; name : CORBA.Identifier; version : CORBA.Repository_Root.VersionSpec; IDL_type : CORBA.Repository_Root.IDLType_Forward.Ref; value : CORBA.Any) return CORBA.Repository_Root.ConstantDef_Forward.Ref; function create_struct (Self : access Object; id : CORBA.RepositoryId; name : CORBA.Identifier; version : CORBA.Repository_Root.VersionSpec; members : CORBA.Repository_Root.StructMemberSeq) return CORBA.Repository_Root.StructDef_Forward.Ref; function create_union (Self : access Object; id : CORBA.RepositoryId; name : CORBA.Identifier; version : CORBA.Repository_Root.VersionSpec; discriminator_type : CORBA.Repository_Root.IDLType_Forward.Ref; members : CORBA.Repository_Root.UnionMemberSeq) return CORBA.Repository_Root.UnionDef_Forward.Ref; function create_enum (Self : access Object; id : CORBA.RepositoryId; name : CORBA.Identifier; version : CORBA.Repository_Root.VersionSpec; members : CORBA.Repository_Root.EnumMemberSeq) return CORBA.Repository_Root.EnumDef_Forward.Ref; function create_alias (Self : access Object; id : CORBA.RepositoryId; name : CORBA.Identifier; version : CORBA.Repository_Root.VersionSpec; original_type : CORBA.Repository_Root.IDLType_Forward.Ref) return CORBA.Repository_Root.AliasDef_Forward.Ref; function create_interface (Self : access Object; id : CORBA.RepositoryId; name : CORBA.Identifier; version : CORBA.Repository_Root.VersionSpec; base_interfaces : CORBA.Repository_Root.InterfaceDefSeq; is_abstract : CORBA.Boolean) return CORBA.Repository_Root.InterfaceDef_Forward.Ref; function create_value (Self : access Object; id : CORBA.RepositoryId; name : CORBA.Identifier; version : CORBA.Repository_Root.VersionSpec; is_custom : CORBA.Boolean; is_abstract : CORBA.Boolean; base_value : CORBA.Repository_Root.ValueDef_Forward.Ref; is_truncatable : CORBA.Boolean; abstract_base_values : CORBA.Repository_Root.ValueDefSeq; supported_interfaces : CORBA.Repository_Root.InterfaceDefSeq; initializers : CORBA.Repository_Root.InitializerSeq) return CORBA.Repository_Root.ValueDef_Forward.Ref; function create_value_box (Self : access Object; id : CORBA.RepositoryId; name : CORBA.Identifier; version : CORBA.Repository_Root.VersionSpec; original_type_def : CORBA.Repository_Root.IDLType_Forward.Ref) return CORBA.Repository_Root.ValueBoxDef_Forward.Ref; function create_exception (Self : access Object; id : CORBA.RepositoryId; name : CORBA.Identifier; version : CORBA.Repository_Root.VersionSpec; members : CORBA.Repository_Root.StructMemberSeq) return CORBA.Repository_Root.ExceptionDef_Forward.Ref; function create_native (Self : access Object; id : CORBA.RepositoryId; name : CORBA.Identifier; version : CORBA.Repository_Root.VersionSpec) return CORBA.Repository_Root.NativeDef_Forward.Ref; function create_abstract_interface (Self : access Object; id : RepositoryId; name : Identifier; version : VersionSpec; base_interfaces : AbstractInterfaceDefSeq) return AbstractInterfaceDef_Forward.Ref; function create_local_interface (Self : access Object; id : RepositoryId; name : Identifier; version : VersionSpec; base_interfaces : InterfaceDefSeq) return LocalInterfaceDef_Forward.Ref; -- Implementation Notes: create_ext_value commented out because of error -- in idlac/ALM (see CORBA_InterfaceRepository.idl) -- function create_ext_value -- (Self : access Object; -- id : RepositoryId; -- name : Identifier; -- version : VersionSpec; -- is_custom : CORBA.Boolean; -- is_abstract : CORBA.Boolean; -- base_value : ValueDef_Forward.Ref; -- is_truncatable : CORBA.Boolean; -- abstract_base_values : ValueDefSeq; -- supported_interfaces : InterfaceDefSeq; -- initializers : ExtInitializerSeq) -- return ExtValueDef_Forward.Ref; private type Object is new CORBA.Repository_Root.IRObject.Impl.Object with record Contents : CORBA.Repository_Root.Contained.Impl.Contained_Seq.Sequence; end record; end CORBA.Repository_Root.Container.Impl; polyorb-2.8~20110207.orig/cos/ir/corba-repository_root-localinterfacedef-impl.ads0000644000175000017500000000667011750740337027245 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- CORBA.REPOSITORY_ROOT.LOCALINTERFACEDEF.IMPL -- -- -- -- S p e c -- -- -- -- Copyright (C) 2006-2008, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the CORBA Specification, and adapted -- -- for use with PolyORB. The copyright notice above, and the license -- -- provisions that follow apply solely to the contents neither explicitly -- -- nor implicitly specified by the CORBA Specification defined by the OMG. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with CORBA.Repository_Root.Contained.Impl; with CORBA.Repository_Root.IDLType.Impl; with CORBA.Repository_Root.InterfaceDef.Impl; with CORBA.Repository_Root.IRObject.Impl; package CORBA.Repository_Root.LocalInterfaceDef.Impl is type Object is new InterfaceDef.Impl.Object with private; type Object_Ptr is access all Object'Class; package Internals is procedure Init (Self : access Object'Class; Real_Object : IRObject.Impl.Object_Ptr; Def_Kind : DefinitionKind; Id : RepositoryId; Name : Identifier; Version : VersionSpec; Defined_In : Container_Forward.Ref; Contents : Contained.Impl.Contained_Seq.Sequence; Contained_View : Contained.Impl.Object_Ptr; IDLType_View : IDLType.Impl.Object_Ptr; Base_Interfaces : InterfaceDefSeq); end Internals; private type Object is new InterfaceDef.Impl.Object with null record; end CORBA.Repository_Root.LocalInterfaceDef.Impl; polyorb-2.8~20110207.orig/cos/ir/corba-orb-typecode.adb0000644000175000017500000003152511750740337021744 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- C O R B A . O R B . T Y P E C O D E -- -- -- -- B o d y -- -- -- -- Copyright (C) 1999-2008, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ package body CORBA.ORB.Typecode is function Create_Struct_Tc (Id : CORBA.RepositoryId; Name : CORBA.Identifier; Members : CORBA.Repository_Root.StructMemberSeq) return CORBA.TypeCode.Object is Result : CORBA.TypeCode.Object; package SMS renames CORBA.Repository_Root.IDL_SEQUENCE_CORBA_StructMember; begin Result := CORBA.TypeCode.Internals.To_CORBA_Object (PolyORB.Any.TypeCode.TC_Struct); CORBA.Internals.Add_Parameter (Result, To_Any (CORBA.String (Name))); CORBA.Internals.Add_Parameter (Result, To_Any (CORBA.String (Id))); declare Memb_Array : constant SMS.Element_Array := SMS.To_Element_Array (SMS.Sequence (Members)); begin for I in Memb_Array'Range loop CORBA.Internals.Add_Parameter (Result, To_Any (Memb_Array (I).IDL_Type)); CORBA.Internals.Add_Parameter (Result, To_Any (CORBA.String (Memb_Array (I).Name))); end loop; end; return Result; end Create_Struct_Tc; function Create_Union_Tc (Id : CORBA.RepositoryId; Name : CORBA.Identifier; Discriminator_Type : CORBA.TypeCode.Object; Members : CORBA.Repository_Root.UnionMemberSeq) return CORBA.TypeCode.Object is Result : CORBA.TypeCode.Object; package UMS renames CORBA.Repository_Root.IDL_SEQUENCE_CORBA_UnionMember; begin Result := CORBA.TypeCode.Internals.To_CORBA_Object (PolyORB.Any.TypeCode.TC_Union); CORBA.Internals.Add_Parameter (Result, To_Any (CORBA.String (Name))); CORBA.Internals.Add_Parameter (Result, To_Any (CORBA.String (Id))); CORBA.Internals.Add_Parameter (Result, To_Any (Discriminator_Type)); declare Memb_Array : constant UMS.Element_Array := UMS.To_Element_Array (UMS.Sequence (Members)); begin for I in Memb_Array'Range loop CORBA.Internals.Add_Parameter (Result, To_Any (Memb_Array (I).IDL_Type)); CORBA.Internals.Add_Parameter (Result, To_Any (Memb_Array (I).Label)); CORBA.Internals.Add_Parameter (Result, To_Any (CORBA.String (Memb_Array (I).Name))); end loop; end; return Result; end Create_Union_Tc; function Create_Enum_Tc (Id : CORBA.RepositoryId; Name : CORBA.Identifier; Members : CORBA.Repository_Root.EnumMemberSeq) return CORBA.TypeCode.Object is Result : CORBA.TypeCode.Object; package EMS renames CORBA.Repository_Root.IDL_SEQUENCE_CORBA_Identifier; Memb_Array : constant EMS.Element_Array := EMS.To_Element_Array (EMS.Sequence (Members)); begin Result := CORBA.TypeCode.Internals.To_CORBA_Object (PolyORB.Any.TypeCode.TC_Enum); CORBA.Internals.Add_Parameter (Result, To_Any (CORBA.String (Name))); CORBA.Internals.Add_Parameter (Result, To_Any (CORBA.String (Id))); for I in Memb_Array'Range loop CORBA.Internals.Add_Parameter (Result, To_Any (CORBA.String (Memb_Array (I)))); end loop; return Result; end Create_Enum_Tc; function Create_Alias_Tc (Id : CORBA.RepositoryId; Name : CORBA.Identifier; Original_Type : CORBA.TypeCode.Object) return CORBA.TypeCode.Object is begin return CORBA.TypeCode.Internals.Build_Alias_TC (Name => CORBA.String (Name), Id => CORBA.String (Id), Parent => Original_Type); end Create_Alias_Tc; function Create_Exception_Tc (Id : CORBA.RepositoryId; Name : CORBA.Identifier; Members : CORBA.Repository_Root.StructMemberSeq) return CORBA.TypeCode.Object is Result : CORBA.TypeCode.Object; package SMS renames CORBA.Repository_Root.IDL_SEQUENCE_CORBA_StructMember; begin Result := CORBA.TypeCode.Internals.To_CORBA_Object (PolyORB.Any.TypeCode.TC_Except); CORBA.Internals.Add_Parameter (Result, To_Any (CORBA.String (Name))); CORBA.Internals.Add_Parameter (Result, To_Any (CORBA.String (Id))); declare Memb_Array : constant SMS.Element_Array := SMS.To_Element_Array (SMS.Sequence (Members)); begin for I in Memb_Array'Range loop CORBA.Internals.Add_Parameter (Result, To_Any (Memb_Array (I).IDL_Type)); CORBA.Internals.Add_Parameter (Result, To_Any (CORBA.String (Memb_Array (I).Name))); end loop; end; return Result; end Create_Exception_Tc; function Create_Interface_Tc (Id : CORBA.RepositoryId; Name : CORBA.Identifier) return CORBA.TypeCode.Object is Result : CORBA.TypeCode.Object; begin Result := CORBA.TypeCode.Internals.To_CORBA_Object (PolyORB.Any.TypeCode.TC_Object); CORBA.Internals.Add_Parameter (Result, To_Any (CORBA.String (Name))); CORBA.Internals.Add_Parameter (Result, To_Any (CORBA.String (Id))); return Result; end Create_Interface_Tc; function Create_String_Tc (Bound : CORBA.Unsigned_Long) return CORBA.TypeCode.Object is Result : CORBA.TypeCode.Object; begin Result := CORBA.TypeCode.Internals.To_CORBA_Object (PolyORB.Any.TypeCode.TC_String); CORBA.Internals.Add_Parameter (Result, To_Any (Bound)); return Result; end Create_String_Tc; function Create_Wstring_Tc (Bound : CORBA.Unsigned_Long) return CORBA.TypeCode.Object is Result : CORBA.TypeCode.Object; begin Result := TC_Wide_String; CORBA.Internals.Add_Parameter (Result, To_Any (Bound)); return Result; end Create_Wstring_Tc; function Create_Fixed_Tc (IDL_Digits : CORBA.Unsigned_Short; Scale : CORBA.Short) return CORBA.TypeCode.Object is Result : CORBA.TypeCode.Object; begin Result := CORBA.TypeCode.Internals.To_CORBA_Object (PolyORB.Any.TypeCode.TC_Fixed); CORBA.Internals.Add_Parameter (Result, To_Any (IDL_Digits)); CORBA.Internals.Add_Parameter (Result, To_Any (Scale)); return Result; end Create_Fixed_Tc; function Create_Sequence_Tc (Bound : CORBA.Unsigned_Long; Elementtype : CORBA.TypeCode.Object) return CORBA.TypeCode.Object is Result : CORBA.TypeCode.Object; begin Result := CORBA.TypeCode.Internals.To_CORBA_Object (PolyORB.Any.TypeCode.TC_Sequence); CORBA.Internals.Add_Parameter (Result, To_Any (Bound)); CORBA.Internals.Add_Parameter (Result, To_Any (Elementtype)); return Result; end Create_Sequence_Tc; function Create_Recursive_Sequence_Tc (Bound : CORBA.Unsigned_Long; Offset : CORBA.Unsigned_Long) return CORBA.TypeCode.Object is pragma Warnings (Off); pragma Unreferenced (Bound, Offset); pragma Warnings (On); begin return TC_Null; end Create_Recursive_Sequence_Tc; function Create_Array_Tc (Length : CORBA.Unsigned_Long; Element_Type : CORBA.TypeCode.Object) return CORBA.TypeCode.Object is Result : CORBA.TypeCode.Object; begin Result := CORBA.TypeCode.Internals.To_CORBA_Object (PolyORB.Any.TypeCode.TC_Array); CORBA.Internals.Add_Parameter (Result, To_Any (Length)); CORBA.Internals.Add_Parameter (Result, To_Any (Element_Type)); return Result; end Create_Array_Tc; function Create_Value_Tc (Id : CORBA.RepositoryId; Name : CORBA.Identifier; Type_Modifier : CORBA.ValueModifier; Concrete_Base : CORBA.TypeCode.Object; Members : CORBA.Repository_Root.ValueMemberSeq) return CORBA.TypeCode.Object is Result : CORBA.TypeCode.Object; package VMS renames CORBA.Repository_Root.IDL_SEQUENCE_CORBA_ValueMember; begin Result := CORBA.TypeCode.Internals.To_CORBA_Object (PolyORB.Any.TypeCode.TC_Value); CORBA.Internals.Add_Parameter (Result, To_Any (CORBA.String (Name))); CORBA.Internals.Add_Parameter (Result, To_Any (CORBA.String (Id))); CORBA.Internals.Add_Parameter (Result, To_Any (CORBA.Short (Type_Modifier))); CORBA.Internals.Add_Parameter (Result, To_Any (Concrete_Base)); declare Memb_Array : constant VMS.Element_Array := VMS.To_Element_Array (VMS.Sequence (Members)); begin for I in Memb_Array'Range loop CORBA.Internals.Add_Parameter (Result, To_Any (CORBA.Short (Memb_Array (I).IDL_Access))); CORBA.Internals.Add_Parameter (Result, To_Any (Memb_Array (I).IDL_Type)); CORBA.Internals.Add_Parameter (Result, To_Any (CORBA.String (Memb_Array (I).Name))); end loop; end; return Result; end Create_Value_Tc; function Create_Value_Box_Tc (Id : CORBA.RepositoryId; Name : CORBA.Identifier; Boxed_Type : CORBA.TypeCode.Object) return CORBA.TypeCode.Object is Result : CORBA.TypeCode.Object; begin Result := CORBA.TypeCode.Internals.To_CORBA_Object (PolyORB.Any.TypeCode.TC_Valuebox); CORBA.Internals.Add_Parameter (Result, To_Any (CORBA.String (Name))); CORBA.Internals.Add_Parameter (Result, To_Any (CORBA.String (Id))); CORBA.Internals.Add_Parameter (Result, To_Any (Boxed_Type)); return Result; end Create_Value_Box_Tc; function Create_Native_Tc (Id : CORBA.RepositoryId; Name : CORBA.Identifier) return CORBA.TypeCode.Object is Result : CORBA.TypeCode.Object; begin Result := CORBA.TypeCode.Internals.To_CORBA_Object (PolyORB.Any.TypeCode.TC_Native); CORBA.Internals.Add_Parameter (Result, To_Any (CORBA.String (Name))); CORBA.Internals.Add_Parameter (Result, To_Any (CORBA.String (Id))); return Result; end Create_Native_Tc; function Create_Recursive_Tc (Id : CORBA.RepositoryId) return CORBA.TypeCode.Object is pragma Warnings (Off); pragma Unreferenced (Id); pragma Warnings (On); begin return TC_Null; end Create_Recursive_Tc; function Create_Abstract_Interface_Tc (Id : CORBA.RepositoryId; Name : CORBA.Identifier) return CORBA.TypeCode.Object is begin return CORBA.TypeCode.Internals.To_CORBA_Object (PolyORB.Any.TypeCode.Build_Complex_TC (Tk_Abstract_Interface, (0 => PolyORB.Any.To_Any (PolyORB.Types.String (Name)), 1 => PolyORB.Any.To_Any (PolyORB.Types.String (Id))))); end Create_Abstract_Interface_Tc; end CORBA.ORB.Typecode; polyorb-2.8~20110207.orig/cos/ir/corba-repository_root-wstringdef-impl.ads0000644000175000017500000000670511750740337025766 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- CORBA.REPOSITORY_ROOT.WSTRINGDEF.IMPL -- -- -- -- S p e c -- -- -- -- Copyright (C) 2006-2008, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the CORBA Specification, and adapted -- -- for use with PolyORB. The copyright notice above, and the license -- -- provisions that follow apply solely to the contents neither explicitly -- -- nor implicitly specified by the CORBA Specification defined by the OMG. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with CORBA.Repository_Root.IRObject.Impl; with CORBA.Repository_Root.IDLType.Impl; package CORBA.Repository_Root.WstringDef.Impl is type Object is new CORBA.Repository_Root.IDLType.Impl.Object with private; type Object_Ptr is access all Object'Class; -- method used to initialize recursively the object fields. procedure Init (Self : access Object; Real_Object : CORBA.Repository_Root.IRObject.Impl.Object_Ptr; Def_Kind : CORBA.Repository_Root.DefinitionKind; Bound : CORBA.Unsigned_Long); -- overload the get_type from IDLType function get_type (Self : access Object) return CORBA.TypeCode.Object; function get_bound (Self : access Object) return CORBA.Unsigned_Long; procedure set_bound (Self : access Object; To : CORBA.Unsigned_Long); private type Object is new CORBA.Repository_Root.IDLType.Impl.Object with record Bound : CORBA.Unsigned_Long; end record; end CORBA.Repository_Root.WstringDef.Impl; polyorb-2.8~20110207.orig/cos/ir/corba-repository_root-moduledef-impl.adb0000644000175000017500000002125511750740337025532 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- CORBA.REPOSITORY_ROOT.MODULEDEF.IMPL -- -- -- -- B o d y -- -- -- -- Copyright (C) 2005-2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ pragma Style_Checks (Off); with Ada.Tags; with PortableServer; with CORBA.Repository_Root.Helper; with CORBA.Repository_Root.ModuleDef.Skel; pragma Warnings (Off, CORBA.Repository_Root.ModuleDef.Skel); with PolyORB.Log; pragma Elaborate_All (PolyORB.Log); with PolyORB.CORBA_P.Server_Tools; package body CORBA.Repository_Root.ModuleDef.Impl is ----------- -- Debug -- ----------- use PolyORB.Log; package L is new PolyORB.Log.Facility_Log ("moduledef.impl"); procedure O (Message : Standard.String; Level : Log_Level := Debug) renames L.Output; function C (Level : Log_Level := Debug) return Boolean renames L.Enabled; pragma Unreferenced (C); -- For conditional pragma Debug package L2 is new PolyORB.Log.Facility_Log ("moduledef.impl_method_trace"); procedure O2 (Message : Standard.String; Level : Log_Level := Debug) renames L2.Output; function C2 (Level : Log_Level := Debug) return Boolean renames L2.Enabled; pragma Unreferenced (C2); -- For conditional pragma Debug ----------------- -- To_Object -- ----------------- function To_Object (Fw_Ref : ModuleDef_Forward.Ref) return Object_Ptr is Result : Portableserver.Servant; begin pragma Debug (O2 ("to_object (moduledef)")); PolyORB.CORBA_P.Server_Tools.Reference_To_Servant (ModuleDef.Convert_Forward.To_Ref (Fw_Ref), Result); return Object_Ptr (Result); end To_Object; ------------------ -- To_Forward -- ------------------ function To_Forward (Obj : Object_Ptr) return ModuleDef_Forward.Ref is Ref : ModuleDef.Ref; begin pragma Debug (O2 ("to_forward (moduledef)")); PolyORB.CORBA_P.Server_Tools.Initiate_Servant (PortableServer.Servant (Obj), Ref); pragma Debug (O ("before return (to_forward)")); return ModuleDef.Convert_Forward.To_Forward (Ref); end To_Forward; ---------------------- -- Procedure init -- ---------------------- procedure Init (Self : access Object; Real_Object : CORBA.Repository_Root.IRObject.Impl.Object_Ptr; Def_Kind : CORBA.Repository_Root.DefinitionKind; Id : CORBA.RepositoryId; Name : CORBA.Identifier; Version : CORBA.Repository_Root.VersionSpec; Defined_In : CORBA.Repository_Root.Container_Forward.Ref; Contents : CORBA.Repository_Root.Contained.Impl.Contained_Seq.Sequence; Contained_View : CORBA.Repository_Root.Contained.Impl.Object_Ptr) is begin pragma Debug (O2 ("init (moduledef)")); Container.Impl.Init (Container.Impl.Object_Ptr (Self), Real_Object, Def_Kind, Contents); pragma Debug (O ("Type of the defined_in : " & Ada.Tags.External_Tag (Container.Impl.To_Object (Defined_In).all'Tag))); Contained.Impl.Init (Contained_View, Real_Object, Def_Kind, Id, Name, Version, Defined_In); Self.Contained_View := Contained_View; end Init; --------------------------------- -- To get the secondary views -- --------------------------------- function Get_Contained_View (Self : access Object) return CORBA.Repository_Root.Contained.Impl.Object_Ptr is begin return Self.Contained_View; end Get_Contained_View; -------------------------------- -- inherited from Contained -- -------------------------------- function get_id (Self : access Object) return CORBA.RepositoryId is begin return Contained.Impl.Get_Id (Self.Contained_View); end get_id; procedure set_id (Self : access Object; To : CORBA.RepositoryId) is begin Contained.Impl.Set_Id (Self.Contained_View, To); end set_id; function get_name (Self : access Object) return CORBA.Identifier is begin return Contained.Impl.Get_Name (Self.Contained_View); end get_name; procedure set_name (Self : access Object; To : CORBA.Identifier) is begin Contained.Impl.Set_Name (Self.Contained_View, To); end set_name; function get_version (Self : access Object) return CORBA.Repository_Root.VersionSpec is begin return Contained.Impl.Get_Version (Self.Contained_View); end get_version; procedure set_version (Self : access Object; To : CORBA.Repository_Root.VersionSpec) is begin Contained.Impl.Set_Version (Self.Contained_View, To); end set_version; function get_defined_in (Self : access Object) return CORBA.Repository_Root.Container_Forward.Ref is begin return Contained.Impl.Get_Defined_In (Self.Contained_View); end get_defined_in; function get_absolute_name (Self : access Object) return CORBA.ScopedName is use Contained.Impl; begin pragma Debug (O ("get_absolute_name : enter")); if Self.Contained_View = null then null; pragma Debug (O ("get_absolute_name : Contained_view is null")); end if; return Contained.Impl.Get_Absolute_Name (Self.Contained_View); end get_absolute_name; function get_containing_repository (Self : access Object) return CORBA.Repository_Root.Repository_Forward.Ref is begin return Contained.Impl.Get_Containing_Repository (Self.Contained_View); end get_containing_repository; function describe (Self : access Object) return CORBA.Repository_Root.Contained.Description is Result : CORBA.Repository_Root.Contained.Description; Desc : CORBA.Repository_Root.ModuleDescription; begin Desc := (Name => Get_Name (Self), Id => Get_Id (Self), Defined_In => Contained.Impl.Get_Defined_In (Self.Contained_View), Version => Get_Version (Self)); Result := (Kind => Get_Def_Kind (Self), Value => CORBA.Repository_Root.Helper.To_Any (Desc)); return Result; end describe; procedure move (Self : access Object; new_container : CORBA.Repository_Root.Container_Forward.Ref; new_name : CORBA.Identifier; new_version : CORBA.Repository_Root.VersionSpec) is begin Contained.Impl.Move (Self.Contained_View, New_Container, New_Name, New_Version); end move; end CORBA.Repository_Root.ModuleDef.Impl; polyorb-2.8~20110207.orig/cos/ir/corba-repository_root-structdef-impl.adb0000644000175000017500000004007511750740337025572 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- CORBA.REPOSITORY_ROOT.STRUCTDEF.IMPL -- -- -- -- B o d y -- -- -- -- Copyright (C) 2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ pragma Style_Checks (Off); with CORBA.ORB.TypeCode; with PortableServer; with CORBA.Repository_Root.StructDef.Skel; pragma Warnings (Off, CORBA.Repository_Root.StructDef.Skel); with PolyORB.CORBA_P.Server_Tools; package body CORBA.Repository_Root.StructDef.Impl is ----------------- -- To_Object -- ----------------- function To_Object (Fw_Ref : StructDef_Forward.Ref) return Object_Ptr is Result : Portableserver.Servant; begin PolyORB.CORBA_P.Server_Tools.Reference_To_Servant (StructDef.Convert_Forward.To_Ref (Fw_Ref), Result); return Object_Ptr (Result); end To_Object; ------------------ -- To_Forward -- ------------------ function To_Forward (Obj : Object_Ptr) return StructDef_Forward.Ref is Ref : StructDef.Ref; begin PolyORB.CORBA_P.Server_Tools.Initiate_Servant (PortableServer.Servant (Obj), Ref); return StructDef.Convert_Forward.To_Forward (Ref); end To_Forward; ------------ -- INIT -- ------------ procedure Init (Self : access Object; Real_Object : CORBA.Repository_Root.IRObject.Impl.Object_Ptr; Def_Kind : CORBA.Repository_Root.DefinitionKind; Id : CORBA.RepositoryId; Name : CORBA.Identifier; Version : CORBA.Repository_Root.VersionSpec; Defined_In : CORBA.Repository_Root.Container_Forward.Ref; IDLType_View : CORBA.Repository_Root.IDLType.Impl.Object_Ptr; Contents : CORBA.Repository_Root.Contained.Impl.Contained_Seq.Sequence; Container_View : CORBA.Repository_Root.Container.Impl.Object_Ptr; Members : CORBA.Repository_Root.StructMemberSeq) is begin Typedefdef.Impl.Init (Typedefdef.Impl.Object_Ptr (Self), Real_Object, Def_Kind, Id, Name, Version, Defined_In, IDLType_View); Container.Impl.Init (Container_View, Real_Object, Def_Kind, Contents); Self.Container_View := Container_View; Initialize_Members (Self, Members); end Init; --------------------------------- -- To get the secondary views -- --------------------------------- function Get_Container_View (Self : access Object) return CORBA.Repository_Root.Container.Impl.Object_Ptr is begin return Self.Container_View; end Get_Container_View; -------------------------- -- Initialize_Members -- -------------------------- procedure Initialize_Members (Self : access Object; Seq : StructMemberSeq) is -- package SMS renames -- IDL_SEQUENCE_CORBA_Repository_Root_StructMember; -- Memb_Array : SMS.Element_Array -- := SMS.To_Element_Array (SMS.Sequence (Seq)); begin -- FIXME>>>>>>>>>>>>>>>>> -- if we set the typecodes to TC_Void, we will loose -- the type of the members... -- for I in Memb_Array'Range loop -- Memb_Array (I).IDL_Type := CORBA.TC_Void; -- end loop; -- Self.Members := StructMemberSeq (SMS.To_Sequence (Memb_Array)); Self.Members := Seq; end Initialize_Members; ---------------- -- get_type -- ---------------- function get_type (Self : access Object) return CORBA.TypeCode.Object is begin return CORBA.ORB.TypeCode.Create_Struct_Tc (Get_Id (Self), Get_Name (Self), Self.Members); end get_type; ---------------- -- members -- ---------------- function get_members (Self : access Object) return CORBA.Repository_Root.StructMemberSeq is begin return Self.Members; end get_members; procedure set_members (Self : access Object; To : CORBA.Repository_Root.StructMemberSeq) is begin Initialize_Members (Self, To); end set_members; -------------------------------- -- Inherited from container -- -------------------------------- function lookup (Self : access Object; search_name : CORBA.ScopedName) return CORBA.Repository_Root.Contained.Ref is begin return Container.Impl.Lookup (Self.Container_View, Search_Name); end lookup; function contents (Self : access Object; limit_type : CORBA.Repository_Root.DefinitionKind; exclude_inherited : CORBA.Boolean) return CORBA.Repository_Root.ContainedSeq is begin return Container.Impl.Contents (Self.Container_View, Limit_Type, Exclude_Inherited); end contents; function lookup_name (Self : access Object; search_name : CORBA.Identifier; levels_to_search : CORBA.Long; limit_type : CORBA.Repository_Root.DefinitionKind; exclude_inherited : CORBA.Boolean) return CORBA.Repository_Root.ContainedSeq is begin return Container.Impl.Lookup_Name (Self.Container_View, Search_Name, Levels_To_Search, Limit_Type, Exclude_Inherited); end lookup_name; function describe_contents (Self : access Object; limit_type : CORBA.Repository_Root.DefinitionKind; exclude_inherited : CORBA.Boolean; max_returned_objs : CORBA.Long) return CORBA.Repository_Root.Container.DescriptionSeq is begin return Container.Impl.Describe_Contents (Self.Container_View, Limit_Type, Exclude_Inherited, Max_Returned_Objs); end describe_contents; function create_module (Self : access Object; id : CORBA.RepositoryId; name : CORBA.Identifier; version : CORBA.Repository_Root.VersionSpec) return CORBA.Repository_Root.ModuleDef_Forward.Ref is begin return Container.Impl.Create_Module (Self.Container_View, Id, Name, Version); end create_module; function create_constant (Self : access Object; id : CORBA.RepositoryId; name : CORBA.Identifier; version : CORBA.Repository_Root.VersionSpec; IDL_type : CORBA.Repository_Root.IDLType_Forward.Ref; value : CORBA.Any) return CORBA.Repository_Root.ConstantDef_Forward.Ref is begin return Container.Impl.Create_Constant (Self.Container_View, Id, Name, Version, IDL_Type, Value); end create_constant; function create_struct (Self : access Object; id : CORBA.RepositoryId; name : CORBA.Identifier; version : CORBA.Repository_Root.VersionSpec; members : CORBA.Repository_Root.StructMemberSeq) return CORBA.Repository_Root.StructDef_Forward.Ref is begin return Container.Impl.Create_Struct (Self.Container_View, Id, Name, Version, Members); end create_struct; function create_union (Self : access Object; id : CORBA.RepositoryId; name : CORBA.Identifier; version : CORBA.Repository_Root.VersionSpec; discriminator_type : CORBA.Repository_Root.IDLType_Forward.Ref; members : CORBA.Repository_Root.UnionMemberSeq) return CORBA.Repository_Root.UnionDef_Forward.Ref is begin return Container.Impl.Create_Union (Self.Container_View, Id, Name, Version, Discriminator_Type, Members); end create_union; function create_enum (Self : access Object; id : CORBA.RepositoryId; name : CORBA.Identifier; version : CORBA.Repository_Root.VersionSpec; members : CORBA.Repository_Root.EnumMemberSeq) return CORBA.Repository_Root.EnumDef_Forward.Ref is begin return Container.Impl.Create_Enum (Self.Container_View, Id, Name, Version, Members); end create_enum; function create_alias (Self : access Object; id : CORBA.RepositoryId; name : CORBA.Identifier; version : CORBA.Repository_Root.VersionSpec; original_type : CORBA.Repository_Root.IDLType_Forward.Ref) return CORBA.Repository_Root.AliasDef_Forward.Ref is begin return Container.Impl.Create_Alias (Self.Container_View, Id, Name, Version, Original_Type); end create_alias; function create_interface (Self : access Object; id : CORBA.RepositoryId; name : CORBA.Identifier; version : CORBA.Repository_Root.VersionSpec; base_interfaces : CORBA.Repository_Root.InterfaceDefSeq; is_abstract : CORBA.Boolean) return CORBA.Repository_Root.InterfaceDef_Forward.Ref is begin return Container.Impl.Create_Interface (Self.Container_View, Id, Name, Version, Base_Interfaces, Is_Abstract); end create_interface; function create_value (Self : access Object; id : CORBA.RepositoryId; name : CORBA.Identifier; version : CORBA.Repository_Root.VersionSpec; is_custom : CORBA.Boolean; is_abstract : CORBA.Boolean; base_value : CORBA.Repository_Root.ValueDef_Forward.Ref; is_truncatable : CORBA.Boolean; abstract_base_values : CORBA.Repository_Root.ValueDefSeq; supported_interfaces : CORBA.Repository_Root.InterfaceDefSeq; initializers : CORBA.Repository_Root.InitializerSeq) return CORBA.Repository_Root.ValueDef_Forward.Ref is begin return Container.Impl.Create_Value (Self.Container_View, Id, Name, Version, Is_Custom, Is_Abstract, Base_Value, Is_Truncatable, Abstract_Base_Values, Supported_Interfaces, Initializers); end create_value; function create_value_box (Self : access Object; id : CORBA.RepositoryId; name : CORBA.Identifier; version : CORBA.Repository_Root.VersionSpec; original_type_def : CORBA.Repository_Root.IDLType_Forward.Ref) return CORBA.Repository_Root.ValueBoxDef_Forward.Ref is begin return Container.Impl.Create_Value_Box (Self.Container_View, Id, Name, Version, Original_Type_Def); end create_value_box; function create_exception (Self : access Object; id : CORBA.RepositoryId; name : CORBA.Identifier; version : CORBA.Repository_Root.VersionSpec; members : CORBA.Repository_Root.StructMemberSeq) return CORBA.Repository_Root.ExceptionDef_Forward.Ref is begin return Container.Impl.Create_Exception (Self.Container_View, Id, Name, Version, Members); end create_exception; function create_native (Self : access Object; id : CORBA.RepositoryId; name : CORBA.Identifier; version : CORBA.Repository_Root.VersionSpec) return CORBA.Repository_Root.NativeDef_Forward.Ref is begin return Container.Impl.Create_Native (Self.Container_View, Id, Name, Version); end create_native; ------------------------------- -- create_abstract_interface -- ------------------------------- function create_abstract_interface (Self : access Object; id : RepositoryId; name : Identifier; version : VersionSpec; base_interfaces : AbstractInterfaceDefSeq) return AbstractInterfaceDef_Forward.Ref is begin return Container.Impl.create_abstract_interface (Self.Container_View, id, name, version, base_interfaces); end create_abstract_interface; ---------------------------- -- create_local_interface -- ---------------------------- function create_local_interface (Self : access Object; id : RepositoryId; name : Identifier; version : VersionSpec; base_interfaces : InterfaceDefSeq) return LocalInterfaceDef_Forward.Ref is begin return Container.Impl.create_local_interface (Self.Container_View, id, name, version, base_interfaces); end create_local_interface; end CORBA.Repository_Root.StructDef.Impl; polyorb-2.8~20110207.orig/cos/ir/corba-repository_root-enumdef-impl.adb0000644000175000017500000001121711750740337025206 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- C O R B A . R E P O S I T O R Y _ R O O T . E N U M D E F . I M P L -- -- -- -- B o d y -- -- -- -- Copyright (C) 2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ pragma Style_Checks (Off); with CORBA.ORB.TypeCode; with PolyORB.CORBA_P.Server_Tools; with PortableServer; with CORBA.Repository_Root.EnumDef.Skel; pragma Warnings (Off, CORBA.Repository_Root.EnumDef.Skel); package body CORBA.Repository_Root.EnumDef.Impl is ----------------- -- To_Object -- ----------------- function To_Object (Fw_Ref : EnumDef_Forward.Ref) return Object_Ptr is Result : Portableserver.Servant; begin PolyORB.CORBA_P.Server_Tools.Reference_To_Servant (EnumDef.Convert_Forward.To_Ref (Fw_Ref), Result); return Object_Ptr (Result); end To_Object; ------------------ -- To_Forward -- ------------------ function To_Forward (Obj : Object_Ptr) return EnumDef_Forward.Ref is Ref : EnumDef.Ref; begin PolyORB.CORBA_P.Server_Tools.Initiate_Servant (PortableServer.Servant (Obj), Ref); return EnumDef.Convert_Forward.To_Forward (Ref); end To_Forward; ------------ -- INIT -- ------------ procedure Init (Self : access Object; Real_Object : CORBA.Repository_Root.IRObject.Impl.Object_Ptr; Def_Kind : CORBA.Repository_Root.DefinitionKind; Id : CORBA.RepositoryId; Name : CORBA.Identifier; Version : CORBA.Repository_Root.VersionSpec; Defined_In : CORBA.Repository_Root.Container_Forward.Ref; IDLType_View : CORBA.Repository_Root.IDLType.Impl.Object_Ptr; Members : CORBA.Repository_Root.EnumMemberSeq) is begin Typedefdef.Impl.Init (Typedefdef.Impl.Object_Ptr (Self), Real_Object, Def_Kind, Id, Name, Version, Defined_In, IDLType_View); Self.Members := Members; end Init; ---------------- -- get_type -- ---------------- function get_type (Self : access Object) return CORBA.TypeCode.Object is begin return CORBA.ORB.TypeCode.Create_Enum_Tc (Get_Id (Self), Get_Name (Self), Self.Members); end get_type; function get_members (Self : access Object) return CORBA.Repository_Root.EnumMemberSeq is begin return Self.Members; end get_members; procedure set_members (Self : access Object; To : CORBA.Repository_Root.EnumMemberSeq) is begin Self.Members := To; end set_members; end CORBA.Repository_Root.EnumDef.Impl; polyorb-2.8~20110207.orig/cos/ir/corba-repository_root-primitivedef-impl.ads0000644000175000017500000000676511750740337026307 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- CORBA.REPOSITORY_ROOT.PRIMITIVEDEF.IMPL -- -- -- -- S p e c -- -- -- -- Copyright (C) 2006-2008, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the CORBA Specification, and adapted -- -- for use with PolyORB. The copyright notice above, and the license -- -- provisions that follow apply solely to the contents neither explicitly -- -- nor implicitly specified by the CORBA Specification defined by the OMG. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with CORBA.Repository_Root.IDLType.Impl; with CORBA.Repository_Root.IRObject.Impl; package CORBA.Repository_Root.PrimitiveDef.Impl is type Object is new CORBA.Repository_Root.IDLType.Impl.Object with private; type Object_Ptr is access all Object'Class; -- method used to initialize recursively the object fields. procedure Init (Self : access Object; Real_Object : CORBA.Repository_Root.IRObject.Impl.Object_Ptr; Def_Kind : CORBA.Repository_Root.DefinitionKind; IDL_Type : CORBA.TypeCode.Object; Kind : CORBA.Repository_Root.PrimitiveKind); -- overload the get_type from IDLType function get_type (Self : access Object) return CORBA.TypeCode.Object; function get_kind (Self : access Object) return CORBA.Repository_Root.PrimitiveKind; private type Object is new CORBA.Repository_Root.IDLType.Impl.Object with record Kind : CORBA.Repository_Root.PrimitiveKind; IDL_Type : CORBA.TypeCode.Object; end record; end CORBA.Repository_Root.PrimitiveDef.Impl; polyorb-2.8~20110207.orig/cos/ir/corba-repository_root-typedefdef-impl.ads0000644000175000017500000000742211750740337025726 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- CORBA.REPOSITORY_ROOT.TYPEDEFDEF.IMPL -- -- -- -- S p e c -- -- -- -- Copyright (C) 2006-2008, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the CORBA Specification, and adapted -- -- for use with PolyORB. The copyright notice above, and the license -- -- provisions that follow apply solely to the contents neither explicitly -- -- nor implicitly specified by the CORBA Specification defined by the OMG. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with CORBA.Repository_Root.IRObject.Impl; with CORBA.Repository_Root.IDLType.Impl; with CORBA.Repository_Root.Contained.Impl; package CORBA.Repository_Root.TypedefDef.Impl is type Object is new CORBA.Repository_Root.Contained.Impl.Object with private; type Object_Ptr is access all Object'Class; -- method used to initialize recursively the object fields. procedure Init (Self : access Object; Real_Object : CORBA.Repository_Root.IRObject.Impl.Object_Ptr; Def_Kind : CORBA.Repository_Root.DefinitionKind; Id : CORBA.RepositoryId; Name : CORBA.Identifier; Version : CORBA.Repository_Root.VersionSpec; Defined_In : CORBA.Repository_Root.Container_Forward.Ref; IDLType_View : CORBA.Repository_Root.IDLType.Impl.Object_Ptr); -- For multiple inheritance, to access the different views function Get_IDLType_View (Self : access Object) return CORBA.Repository_Root.IDLType.Impl.Object_Ptr; function get_type (Self : access Object) return CORBA.TypeCode.Object; -- override this from contained function describe (Self : access Object) return CORBA.Repository_Root.Contained.Description; private type Object is new CORBA.Repository_Root.Contained.Impl.Object with record IDLType_View : CORBA.Repository_Root.IDLType.Impl.Object_Ptr; end record; end CORBA.Repository_Root.TypedefDef.Impl; polyorb-2.8~20110207.orig/cos/ir/corba-repository_root-stringdef-impl.ads0000644000175000017500000000670311750740337025575 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- CORBA.REPOSITORY_ROOT.STRINGDEF.IMPL -- -- -- -- S p e c -- -- -- -- Copyright (C) 2006-2008, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the CORBA Specification, and adapted -- -- for use with PolyORB. The copyright notice above, and the license -- -- provisions that follow apply solely to the contents neither explicitly -- -- nor implicitly specified by the CORBA Specification defined by the OMG. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with CORBA.Repository_Root.IDLType.Impl; with CORBA.Repository_Root.IRObject.Impl; package CORBA.Repository_Root.StringDef.Impl is type Object is new CORBA.Repository_Root.IDLType.Impl.Object with private; type Object_Ptr is access all Object'Class; -- method used to initialize recursively the object fields. procedure Init (Self : access Object; Real_Object : CORBA.Repository_Root.IRObject.Impl.Object_Ptr; Def_Kind : CORBA.Repository_Root.DefinitionKind; Bound : CORBA.Unsigned_Long); -- overload the get_type from IDLType function get_type (Self : access Object) return CORBA.TypeCode.Object; function get_bound (Self : access Object) return CORBA.Unsigned_Long; procedure set_bound (Self : access Object; To : CORBA.Unsigned_Long); private type Object is new CORBA.Repository_Root.IDLType.Impl.Object with record Bound : CORBA.Unsigned_Long; end record; end CORBA.Repository_Root.StringDef.Impl; polyorb-2.8~20110207.orig/cos/ir/corba-repository_root-container-impl.adb0000644000175000017500000015751511750740337025561 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- CORBA.REPOSITORY_ROOT.CONTAINER.IMPL -- -- -- -- B o d y -- -- -- -- Copyright (C) 2005-2007, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ pragma Style_Checks (Off); with Ada.Strings.Unbounded; with CORBA.Repository_Root.AbstractInterfaceDef; with CORBA.Repository_Root.AliasDef.Impl; with CORBA.Repository_Root.ConstantDef.Impl; with CORBA.Repository_Root.Container.Helper; with CORBA.Repository_Root.Container.Skel; pragma Warnings (Off, CORBA.Repository_Root.Container.Skel); with CORBA.Repository_Root.EnumDef.Impl; with CORBA.Repository_Root.ExceptionDef.Impl; with CORBA.Repository_Root.ExtAbstractInterfaceDef.Impl; with CORBA.Repository_Root.ExtInterfaceDef.Impl; with CORBA.Repository_Root.ExtLocalInterfaceDef.Impl; with CORBA.Repository_Root.IDLType.Impl; with CORBA.Repository_Root.InterfaceAttrExtension.Impl; with CORBA.Repository_Root.InterfaceDef.Impl; with CORBA.Repository_Root.LocalInterfaceDef; with CORBA.Repository_Root.ModuleDef.Impl; with CORBA.Repository_Root.NativeDef.Impl; with CORBA.Repository_Root.Repository.Impl; with CORBA.Repository_Root.StructDef.Impl; with CORBA.Repository_Root.UnionDef.Impl; with CORBA.Repository_Root.ValueBoxDef.Impl; with CORBA.Repository_Root.ValueDef.Impl; with PolyORB.Log; pragma Elaborate_All (PolyORB.Log); with PolyORB.CORBA_P.Server_Tools; with PortableServer; package body CORBA.Repository_Root.Container.Impl is ----------- -- Debug -- ----------- use PolyORB.Log; package L is new PolyORB.Log.Facility_Log ("container.impl"); procedure O (Message : Standard.String; Level : Log_Level := Debug) renames L.Output; function C (Level : Log_Level := Debug) return Boolean renames L.Enabled; pragma Unreferenced (C); -- For conditional pragma Debug package L2 is new PolyORB.Log.Facility_Log ("container.impl_method_trace"); procedure O2 (Message : Standard.String; Level : Log_Level := Debug) renames L2.Output; function C2 (Level : Log_Level := Debug) return Boolean renames L2.Enabled; pragma Unreferenced (C2); -- For conditional pragma Debug ---------------------- -- Procedure init -- ---------------------- procedure Init (Self : access Object; Real_Object : IRObject.Impl.Object_Ptr; Def_Kind : CORBA.Repository_Root.DefinitionKind; Contents : CORBA.Repository_Root.Contained.Impl.Contained_Seq.Sequence) is begin pragma Debug (O2 ("init (container)")); IRObject.Impl.Init (IRObject.Impl.Object_Ptr (Self), Real_Object, Def_kind); Self.Contents := Contents; end Init; ----------------- -- To_Object -- ----------------- function To_Object (Fw_Ref : Container_Forward.Ref) return Object_Ptr is -- Result : IRObject.Impl.Object_Ptr; The_Ref : Container.Ref; Obj : PortableServer.Servant; begin pragma Debug (O2 ("to_object (container)")); The_Ref := Container.Convert_Forward.To_Ref (Fw_Ref); pragma Debug (O2 ("to_object, before object_of")); PolyORB.CORBA_P.Server_Tools.Reference_To_Servant (The_Ref, Obj); return To_Container (IRObject.Impl.Object_Ptr (Obj)); end To_Object; ------------------ -- To_Forward -- ------------------ function To_Forward (Obj : Object_Ptr) return Container_Forward.Ref is Result : Container_Forward.Ref; begin case get_def_kind (Obj) is when dk_Primitive | dk_String | dk_Sequence | dk_Array | dk_Wstring | dk_Fixed | dk_all | dk_Typedef | dk_Enum | dk_Alias | dk_Native | dk_ValueBox | dk_Attribute | dk_Constant | dk_Operation | dk_ValueMember| dk_none => CORBA.Raise_Internal (CORBA.Default_Sys_Member); return Result; when dk_Interface => declare The_Ref : InterfaceDef.Ref; begin PolyORB.CORBA_P.Server_Tools.Initiate_Servant (PortableServer.Servant (Get_Real_Object (Obj)), The_Ref); return Container.Convert_Forward.To_Forward (Container.Helper.To_Ref (The_Ref)); end; when dk_Value => declare The_Ref : ValueDef.Ref; begin PolyORB.CORBA_P.Server_Tools.Initiate_Servant (PortableServer.Servant (Get_Real_Object (Obj)), The_Ref); return Container.Convert_Forward.To_Forward (Container.Helper.To_Ref (The_Ref)); end; when dk_Struct => declare The_Ref : StructDef.Ref; begin PolyORB.CORBA_P.Server_Tools.Initiate_Servant (PortableServer.Servant (Get_Real_Object (Obj)), The_Ref); return Container.Convert_Forward.To_Forward (Container.Helper.To_Ref (The_Ref)); end; when dk_Union => declare The_Ref : UnionDef.Ref; begin PolyORB.CORBA_P.Server_Tools.Initiate_Servant (PortableServer.Servant (Get_Real_Object (Obj)), The_Ref); return Container.Convert_Forward.To_Forward (Container.Helper.To_Ref (The_Ref)); end; when dk_Exception => declare The_Ref : ExceptionDef.Ref; begin PolyORB.CORBA_P.Server_Tools.Initiate_Servant (PortableServer.Servant (Get_Real_Object (Obj)), The_Ref); return Container.Convert_Forward.To_Forward (Container.Helper.To_Ref (The_Ref)); end; when dk_Module => declare The_Ref : ModuleDef.Ref; begin PolyORB.CORBA_P.Server_Tools.Initiate_Servant (PortableServer.Servant (Get_Real_Object (Obj)), The_Ref); return Container.Convert_Forward.To_Forward (Container.Helper.To_Ref (The_Ref)); end; when dk_Repository => declare The_Ref : Repository.Ref; begin PolyORB.CORBA_P.Server_Tools.Initiate_Servant (PortableServer.Servant (Get_Real_Object (Obj)), The_Ref); return Container.Convert_Forward.To_Forward (Container.Helper.To_Ref (The_Ref)); end; when dk_AbstractInterface .. dk_Event => raise Program_Error; end case; end To_Forward; ------------------------------------------ -- manipulation of the contents field -- ------------------------------------------ function Get_Contents (Self : access Object) return CORBA.Repository_Root.Contained.Impl.Contained_Seq.Sequence is begin return Self.Contents; end Get_Contents; procedure Set_Contents (Self : access Object; New_List : CORBA.Repository_Root.Contained.Impl.Contained_Seq.Sequence) is begin Self.Contents := New_List; end Set_Contents; procedure Append_To_Contents (Self : access Object; Element : Contained.Impl.Object_Ptr) is begin pragma Debug (O2 ("Append_To_Contents (container)")); Contained.Impl.Contained_Seq.Append (Self.Contents, Element); end Append_To_Contents; procedure Delete_From_Contents (Self : access Object; Element : Contained.Impl.Object_Ptr) is Index : Positive; Cont_Array : Contained.Impl.Contained_Seq.Element_Array (1 .. 1); begin Cont_Array (1) := Element; Index := Contained.Impl.Contained_Seq.Index (Self.Contents, Cont_Array); Contained.Impl.Contained_Seq.Delete (Self.Contents, Index, Natural (Index)); end Delete_From_Contents; ------------------ -- To_Container -- ------------------ procedure To_Container (Self : IRObject.Impl.Object_Ptr; Success : out Boolean; Result : out Object_Ptr) is begin pragma Debug (O2 ("to_container (container)")); Success := True; case IRObject.Impl.get_def_kind (Self) is when dk_Attribute | dk_Constant | dk_Operation | dk_Typedef | dk_Alias | dk_Primitive | dk_String | dk_Sequence | dk_Array | dk_Wstring | dk_Fixed | dk_Enum | dk_ValueBox | dk_ValueMember| dk_Native | dk_all | dk_none => Success := False; Result := null; when -- inherited types dk_Repository | dk_Value | dk_Module | dk_Exception | dk_Interface => Result := Object_Ptr (Self); when -- types containing a "container_view" field dk_Struct => declare Interm : constant StructDef.Impl.Object_Ptr := StructDef.Impl.Object_Ptr (Self); begin Result := StructDef.Impl.Get_Container_View (Interm); end; when -- types containing a "container_view" field dk_Union => declare Interm : constant UnionDef.Impl.Object_Ptr := UnionDef.Impl.Object_Ptr (Self); begin Result := UnionDef.Impl.Get_Container_View (Interm); end; when dk_AbstractInterface .. dk_Event => raise Program_Error; end case; return; end To_Container; function To_Container (Self : IRObject.Impl.Object_Ptr) return Object_Ptr is begin pragma Debug (O2 ("to_container (container)")); case IRObject.Impl.get_def_kind (Self) is when dk_Attribute | dk_Constant | dk_Operation | dk_Typedef | dk_Alias | dk_Primitive | dk_String | dk_Sequence | dk_Array | dk_Wstring | dk_Fixed | dk_Enum | dk_ValueBox | dk_ValueMember| dk_Native | dk_all | dk_none => CORBA.Raise_Internal (CORBA.Default_Sys_Member); return null; when -- inherited types dk_Repository | dk_Value | dk_Module | dk_Exception | dk_Interface => return Object_Ptr (Self); when -- types containing a "container_view" field dk_Struct => declare Interm : constant StructDef.Impl.Object_Ptr := StructDef.Impl.Object_Ptr (Self); begin return StructDef.Impl.Get_Container_View (Interm); end; when -- types containing a "container_view" field dk_Union => declare Interm : constant UnionDef.Impl.Object_Ptr := UnionDef.Impl.Object_Ptr (Self); begin return UnionDef.Impl.Get_Container_View (Interm); end; when dk_AbstractInterface .. dk_Event => raise Program_Error; end case; end To_Container; -------------- -- Check_Id -- -------------- procedure Check_Id (Self : access Object; Id : RepositoryId) is Rep : Repository.Impl.Object_Ptr; use Contained.Impl; begin pragma Debug (O2 ("Check_Id (container)")); if get_def_kind (Self) = dk_Repository then Rep := Repository.Impl.Object_Ptr (Object_Ptr (Self)); else Rep := Repository.Impl.To_Object (get_containing_repository (To_Contained (Get_Real_Object (Self)))); end if; if not Contained.Is_Nil (Repository.Impl.lookup_Id (Rep, id)) then -- The same Id already exists in this repository CORBA.Raise_Bad_Param (CORBA.System_Exception_Members' (Minor => 2, Completed => CORBA.Completed_No)); end if; end Check_Id; ---------------- -- Check_Name -- ---------------- procedure Check_Name (Self : access Object; Name : Identifier) is package Contained_For_Seq renames IDL_SEQUENCE_CORBA_Contained_Forward; use Contained_For_Seq; begin pragma Debug (O2 ("Check_Name (container)")); if Contained_For_Seq.Sequence (Lookup_Name (Self, name, -1, dk_all, True)) /= Contained_For_Seq.Null_Sequence then -- There is already a node using this Name in this scope CORBA.Raise_Bad_Param (CORBA.System_Exception_Members' (Minor => 3, Completed => CORBA.Completed_No)); end if; end Check_Name; --------------------- -- Check_Structure -- --------------------- procedure Check_Structure (Self : access Object; Kind : DefinitionKind) is Self_DK : constant DefinitionKind := get_def_kind (Self); Not_Allowed : Boolean := False; begin pragma Debug (O2 ("Check_Structure (container)")); -- The move or creation should comply with CORBA 3.0 10.4.4 -- (Structure and Navigation of the Interface Repository) case Kind is when dk_Operation | dk_Attribute => if Self_DK = dk_Repository or else Self_DK = dk_Module then Not_Allowed := True; end if; when dk_ValueMember => if Self_DK /= dk_value then Not_Allowed := True; end if; when dk_Module | dk_Interface | dk_Value => if Self_DK = dk_Interface or else Self_DK = dk_Value then Not_Allowed := True; end if; when others => null; end case; -- Exception, union or struct can only contain union, struct or enum if Self_DK = dk_Struct or else Self_DK = dk_Union or else Self_DK = dk_Exception then if kind /= dk_Struct and then kind /= dk_Union and then kind /= dk_Enum then Not_Allowed := True; end if; end if; if Not_Allowed then CORBA.Raise_Bad_Param (CORBA.System_Exception_Members' (Minor => 4, Completed => CORBA.Completed_No)); end if; end Check_Structure; ------------- -- IR spec -- ------------- -------------- -- Lookup -- -------------- function lookup (Self : access Object; search_name : CORBA.ScopedName) return CORBA.Repository_Root.Contained.Ref is Result_Obj : Contained.Impl.Object_Ptr := null; Nil_Ref : CORBA.Repository_Root.Contained.Ref; use Contained.Impl; use Ada.Strings.Unbounded; begin -- if it begins with :: then lookup in all the repository if Head (Unbounded_String (search_name), 2) = "::" then declare New_Search : constant ScopedName := Tail (search_name, Length (search_name) - 2); begin if get_def_kind (Self) = dk_Repository then Result_Obj := Lookup_ScopedName (Self.Contents, New_Search); else Result_Obj := Lookup_ScopedName (Repository.Impl.Get_Contents (Repository.Impl.To_Object (get_containing_repository (To_Contained (Get_Real_Object (Self))))), New_Search); end if; end; else Result_Obj := Lookup_ScopedName (Self.Contents, search_name); end if; -- return a nil_ref if not found if Result_Obj = null then return Nil_Ref; end if; return Contained.Convert_Forward.To_Ref (Contained.Impl.To_Forward (Result_Obj)); end lookup; ---------------- -- contents -- ---------------- function contents (Self : access Object; limit_type : CORBA.Repository_Root.DefinitionKind; exclude_inherited : CORBA.Boolean) return CORBA.Repository_Root.ContainedSeq is Result : CORBA.Repository_Root.ContainedSeq; package Contained_For_Seq renames IDL_SEQUENCE_CORBA_Contained_Forward; package IdF renames IDL_SEQUENCE_CORBA_InterfaceDef_Forward; package VDF renames IDL_SEQUENCE_CORBA_ValueDef_Forward; begin -- Get the direct contained Result := Contained.Impl.contents (Self.Contents, limit_type); -- Do we look into the inherited if not exclude_inherited then case get_def_kind (Self) is when dk_Interface => declare IntDefSeq : constant InterfaceDefSeq := InterfaceDef.Impl.get_base_interfaces (InterfaceDef.Impl.Object_Ptr (Get_Real_Object (Self))); -- create the array of the parent interfaces Int_Array : constant IdF.Element_Array := IdF.To_Element_Array (IdF.Sequence (IntDefSeq)); begin for I in Int_Array'Range loop declare Int : constant InterfaceDef.Impl.Object_Ptr := InterfaceDef.Impl.To_Object (Int_Array (I)); Res : ContainedSeq; begin -- we will get all the contained of the inherited interface Res := contents (Object_Ptr (Int), limit_type, exclude_inherited); -- append the current result to the global one Contained_For_Seq.Append (Contained_For_Seq.Sequence (Result), Contained_For_Seq.Sequence (Res)); end; end loop; end; when dk_Value => -- check the supported interfaces declare IntDefSeq : constant InterfaceDefSeq := ValueDef.Impl.get_supported_interfaces (ValueDef.Impl.Object_Ptr (Get_Real_Object (Self))); -- create the array of the supported interfaces Int_Array : constant IdF.Element_Array := IdF.To_Element_Array (IdF.Sequence (IntDefSeq)); begin for I in Int_Array'Range loop declare Int : constant InterfaceDef.Impl.Object_Ptr := InterfaceDef.Impl.To_Object (Int_Array (I)); Res : ContainedSeq; begin -- we will get all the definition of the inherited interface Res := contents (Object_Ptr (Int), limit_type, exclude_inherited); -- append the current result to the global one Contained_For_Seq.Append (Contained_For_Seq.Sequence (Result), Contained_For_Seq.Sequence (Res)); end; end loop; end; -- check the abstract_base_value declare ValDefSeq : constant ValueDefSeq := ValueDef.Impl.get_abstract_base_values (ValueDef.Impl.Object_Ptr (Get_Real_Object (Self))); -- create the array of the supported values Val_Array : constant VDF.Element_Array := VDF.To_Element_Array (VDF.Sequence (ValDefSeq)); begin for I in Val_Array'Range loop declare Val : constant ValueDef.Impl.Object_Ptr := ValueDef.Impl.To_Object (Val_Array (I)); Res : ContainedSeq; begin -- we will get all the definition of the inherited value Res := contents (Object_Ptr (Val), limit_type, exclude_inherited); -- append the current result to the global one Contained_For_Seq.Append (Contained_For_Seq.Sequence (Result), Contained_For_Seq.Sequence (Res)); end; end loop; end; -- check the base_value declare Obj : PortableServer.Servant; Res : ContainedSeq; begin PolyORB.CORBA_P.Server_Tools.Reference_To_Servant (ValueDef.Impl.get_base_value (ValueDef.Impl.Object_Ptr (Get_Real_Object (Self))), Obj); -- we will get all the definition of the inherited value Res := contents (Object_Ptr (Obj), limit_type, exclude_inherited); -- append the current result to the global one Contained_For_Seq.Append (Contained_For_Seq.Sequence (Result), Contained_For_Seq.Sequence (Res)); end; when others => null; end case; end if; -- remove the twins (in case of a diamond inheritance) Contained.Impl.Simplify_ContainedSeq (Result); return Result; end contents; ------------------- -- Lookup_Name -- ------------------- function lookup_name (Self : access Object; search_name : CORBA.Identifier; levels_to_search : CORBA.Long; limit_type : CORBA.Repository_Root.DefinitionKind; exclude_inherited : CORBA.Boolean) return CORBA.Repository_Root.ContainedSeq is package Contained_For_Seq renames IDL_SEQUENCE_CORBA_Contained_Forward; package IdF renames IDL_SEQUENCE_CORBA_InterfaceDef_Forward; package VDF renames IDL_SEQUENCE_CORBA_ValueDef_Forward; Result : CORBA.Repository_Root.ContainedSeq; begin Result := Contained.Impl.Lookup_Name (Self.Contents, search_name, limit_type); -- Do we look into the inherited if not exclude_inherited then case get_def_kind (Self) is when dk_Interface => declare IntDefSeq : constant InterfaceDefSeq := InterfaceDef.Impl.get_base_interfaces (InterfaceDef.Impl.Object_Ptr (Get_Real_Object (Self))); -- create the array of the parent interfaces Int_Array : constant IdF.Element_Array := IdF.To_Element_Array (IdF.Sequence (IntDefSeq)); begin for I in Int_Array'Range loop declare Int : constant InterfaceDef.Impl.Object_Ptr := InterfaceDef.Impl.To_Object (Int_Array (I)); Res : ContainedSeq; begin -- we will get all the definition of the inherited interface Res := lookup_name (Object_Ptr (Int), search_name, -1, limit_type, exclude_inherited); -- append the current result to the global one Contained_For_Seq.Append (Contained_For_Seq.Sequence (Result), Contained_For_Seq.Sequence (Res)); end; end loop; end; when dk_Value => -- check the supported interfaces declare IntDefSeq : constant InterfaceDefSeq := ValueDef.Impl.get_supported_interfaces (ValueDef.Impl.Object_Ptr (Get_Real_Object (Self))); -- create the array of the supported interfaces Int_Array : constant IdF.Element_Array := IdF.To_Element_Array (IdF.Sequence (IntDefSeq)); begin for I in Int_Array'Range loop declare Int : constant InterfaceDef.Impl.Object_Ptr := InterfaceDef.Impl.To_Object (Int_Array (I)); Res : ContainedSeq; begin -- we will get all the definition of the inherited interface Res := lookup_name (Object_Ptr (Int), search_name, -1, limit_type, exclude_inherited); -- append the current result to the global one Contained_For_Seq.Append (Contained_For_Seq.Sequence (Result), Contained_For_Seq.Sequence (Res)); end; end loop; end; -- check the abstract_base_value declare ValDefSeq : constant ValueDefSeq := ValueDef.Impl.get_abstract_base_values (ValueDef.Impl.Object_Ptr (Get_Real_Object (Self))); -- create the array of the supported values Val_Array : constant VDF.Element_Array := VDF.To_Element_Array (VDF.Sequence (ValDefSeq)); begin for I in Val_Array'Range loop declare Val : constant ValueDef.Impl.Object_Ptr := ValueDef.Impl.To_Object (Val_Array (I)); Res : ContainedSeq; begin -- we will get all the definition of the inherited value Res := lookup_name (Object_Ptr (Val), search_name, -1, limit_type, exclude_inherited); -- append the current result to the global one Contained_For_Seq.Append (Contained_For_Seq.Sequence (Result), Contained_For_Seq.Sequence (Res)); end; end loop; end; -- check the base_value declare Obj : PortableServer.Servant; Res : ContainedSeq; begin PolyORB.CORBA_P.Server_Tools.Reference_To_Servant (ValueDef.Impl.get_base_value (ValueDef.Impl.Object_Ptr (Get_Real_Object (Self))), Obj); -- we will get all the definition of the inherited value Res := lookup_name (Object_Ptr (Obj), search_name, -1, limit_type, exclude_inherited); -- append the current result to the global one Contained_For_Seq.Append (Contained_For_Seq.Sequence (Result), Contained_For_Seq.Sequence (Res)); end; when others => null; end case; end if; -- check the different levels (if there is one) if (levels_to_search > 0) and get_def_kind (Self) /= dk_Repository then declare New_Level : Long; Parent : constant Object_Ptr := To_Object (Contained.Impl.get_defined_in (Contained.Impl.To_Contained (Get_Real_Object (Self)))); Res : ContainedSeq; begin if levels_to_search = 1 then New_Level := -1; else New_Level := levels_to_search - 1; end if; Res := lookup_name (Parent, search_name, New_Level, limit_type, exclude_inherited); -- append the current result to the global one Contained_For_Seq.Append (Contained_For_Seq.Sequence (Result), Contained_For_Seq.Sequence (Res)); end; end if; -- remove the twins (in case of a diamond inheritance) Contained.Impl.Simplify_ContainedSeq (Result); return Result; end lookup_name; ------------------------- -- describe_contents -- ------------------------- function describe_contents (Self : access Object; limit_type : CORBA.Repository_Root.DefinitionKind; exclude_inherited : CORBA.Boolean; max_returned_objs : CORBA.Long) return CORBA.Repository_Root.Container.DescriptionSeq is Content : Contained.Impl.Contained_Seq.Sequence; package CD renames IDL_SEQUENCE_CORBA_Container_Description; Result : DescriptionSeq := DescriptionSeq (CD.Null_Sequence); use Contained.Impl; begin -- get the contents of the container Content := Contained.Impl.To_Contained_Sequence (contents (Self, limit_type, exclude_inherited)); -- reduce it to max_returned_objs if max_returned_objs > 0 then if CORBA.Long (Contained_Seq.Length (Content)) > max_returned_objs then Contained_Seq.Head (Content, Natural (max_returned_objs), null); end if; end if; -- get the description and populate the result. declare Cont_Array : constant Contained_Seq.Element_Array := Contained_Seq.To_Element_Array (Content); Des : Contained.Description; Ref : Contained.Ref; Res_Des : Description; begin for I in Cont_Array'Range loop Des := Contained.Impl.describe (Cont_Array (I)); -- get a reference of the object Ref := Contained.Convert_Forward.To_Ref (Contained.Impl.To_Forward (Cont_Array (I))); -- Create the container.description ... Res_Des := (Contained_Object => Ref, kind => Des.kind, value => Des.value); -- end add it to the result. CD.Append (CD.Sequence (Result), Res_Des); end loop; end; return Result; end describe_contents; --------------------- -- create_ -- --------------------- function create_module (Self : access Object; id : CORBA.RepositoryId; name : CORBA.Identifier; version : CORBA.Repository_Root.VersionSpec) return CORBA.Repository_Root.ModuleDef_Forward.Ref is begin pragma Debug (O2 ("Create_Module (container)")); -- is the new structure allowed? Check_Structure (Self, dk_Module); Check_Id (Self, id); Check_Name (Self, name); declare Result : ModuleDef_Forward.Ref; Obj : constant ModuleDef.Impl.Object_Ptr := new ModuleDef.Impl.Object; Cont_Obj : constant Contained.Impl.Object_Ptr := new Contained.Impl.Object; begin -- initialization of the object pragma Debug (O ("before_init (create_module)")); ModuleDef.Impl.Init (Obj, IRObject.Impl.Object_Ptr (Obj), dk_Module, id, name, version, To_Forward (Object_Ptr (Self)), Contained.Impl.Contained_Seq.Null_Sequence, Cont_Obj); pragma Debug (O ("after_init (create_module)")); -- add it to the contents field of this container Append_To_Contents (Self, Contained.Impl.To_Contained (IRObject.Impl.Object_Ptr (Obj))); pragma Debug (O ("after append_to_contents (create_module)")); Result := ModuleDef.Impl.To_Forward (Obj); pragma Debug (O ("after to_forward (create_module)")); pragma Debug (O ("end (create_module)")); return Result; end; end create_module; function create_constant (Self : access Object; id : CORBA.RepositoryId; name : CORBA.Identifier; version : CORBA.Repository_Root.VersionSpec; IDL_type : CORBA.Repository_Root.IDLType_Forward.Ref; value : CORBA.Any) return CORBA.Repository_Root.ConstantDef_Forward.Ref is begin -- is the new structure allowed? Check_Structure (Self, dk_Constant); Check_Id (Self, id); Check_Name (Self, name); declare Obj : constant ConstantDef.Impl.Object_Ptr := new ConstantDef.Impl.Object; begin -- initialization of the object ConstantDef.Impl.Init (Obj, IRObject.Impl.Object_Ptr (Obj), dk_Constant, id, name, version, To_Forward (Object_Ptr (Self)), IDLType.Convert_Forward.To_Ref (IDL_type), value); -- add it to the contents field of this container Append_To_Contents (Self, Contained.Impl.To_Contained (IRObject.Impl.Object_Ptr (Obj))); return ConstantDef.Impl.To_Forward (Obj); end; end create_constant; function create_struct (Self : access Object; id : CORBA.RepositoryId; name : CORBA.Identifier; version : CORBA.Repository_Root.VersionSpec; members : CORBA.Repository_Root.StructMemberSeq) return CORBA.Repository_Root.StructDef_Forward.Ref is begin -- is the new structure allowed? Check_Structure (Self, dk_Struct); Check_Id (Self, id); Check_Name (Self, name); declare Obj : constant StructDef.Impl.Object_Ptr := new StructDef.Impl.Object; Container_Obj : constant Object_Ptr := new Object; IDLType_Obj : constant IDLType.Impl.Object_Ptr := new IDLType.Impl.Object; begin -- initialization of the object StructDef.Impl.Init (Obj, IRObject.Impl.Object_Ptr (Obj), dk_Struct, id, name, version, To_Forward (Object_Ptr (Self)), IDLType_Obj, Contained.Impl.Contained_Seq.Null_Sequence, Container_Obj, members); -- add it to the contents field of this container Append_To_Contents (Self, Contained.Impl.To_Contained (IRObject.Impl.Object_Ptr (Obj))); return StructDef.Impl.To_Forward (Obj); end; end create_struct; function create_union (Self : access Object; id : CORBA.RepositoryId; name : CORBA.Identifier; version : CORBA.Repository_Root.VersionSpec; discriminator_type : CORBA.Repository_Root.IDLType_Forward.Ref; members : CORBA.Repository_Root.UnionMemberSeq) return CORBA.Repository_Root.UnionDef_Forward.Ref is begin -- is the new structure allowed? Check_Structure (Self, dk_Union); Check_Id (Self, id); Check_Name (Self, name); declare Obj : constant UnionDef.Impl.Object_Ptr := new UnionDef.Impl.Object; Container_Obj : constant Object_Ptr := new Object; IDLType_Obj : constant IDLType.Impl.Object_Ptr := new IDLType.Impl.Object; begin -- initialization of the object UnionDef.Impl.Init (Obj, IRObject.Impl.Object_Ptr (Obj), dk_Union, id, name, version, To_Forward (Object_Ptr (Self)), IDLType_Obj, Contained.Impl.Contained_Seq.Null_Sequence, Container_Obj, IDLType.Convert_Forward.To_Ref (discriminator_type), members); -- add it to the contents field of this container Append_To_Contents (Self, Contained.Impl.To_Contained (IRObject.Impl.Object_Ptr (Obj))); return UnionDef.Impl.To_Forward (Obj); end; end create_union; function create_enum (Self : access Object; id : CORBA.RepositoryId; name : CORBA.Identifier; version : CORBA.Repository_Root.VersionSpec; members : CORBA.Repository_Root.EnumMemberSeq) return CORBA.Repository_Root.EnumDef_Forward.Ref is begin -- is the new structure allowed? Check_Structure (Self, dk_Enum); Check_Id (Self, id); Check_Name (Self, name); declare Obj : constant EnumDef.Impl.Object_Ptr := new EnumDef.Impl.Object; IDLType_Obj : constant IDLType.Impl.Object_Ptr := new IDLType.Impl.Object; begin -- initialization of the object EnumDef.Impl.Init (Obj, IRObject.Impl.Object_Ptr (Obj), dk_Enum, id, name, version, To_Forward (Object_Ptr (Self)), IDLType_Obj, members); -- add it to the contents field of this container Append_To_Contents (Self, Contained.Impl.To_Contained (IRObject.Impl.Object_Ptr (Obj))); return EnumDef.Impl.To_Forward (Obj); end; end create_enum; function create_alias (Self : access Object; id : CORBA.RepositoryId; name : CORBA.Identifier; version : CORBA.Repository_Root.VersionSpec; original_type : CORBA.Repository_Root.IDLType_Forward.Ref) return CORBA.Repository_Root.AliasDef_Forward.Ref is begin -- is the new structure allowed? Check_Structure (Self, dk_Alias); Check_Id (Self, id); Check_Name (Self, name); declare Obj : constant AliasDef.Impl.Object_Ptr := new AliasDef.Impl.Object; IDLType_Obj : constant IDLType.Impl.Object_Ptr := new IDLType.Impl.Object; begin -- initialization of the object AliasDef.Impl.Init (Obj, IRObject.Impl.Object_Ptr (Obj), dk_Alias, id, name, version, To_Forward (Object_Ptr (Self)), IDLType_Obj, IDLType.Convert_Forward.To_Ref (original_type)); -- add it to the contents field of this container Append_To_Contents (Self, Contained.Impl.To_Contained (IRObject.Impl.Object_Ptr (Obj))); return AliasDef.Impl.To_Forward (Obj); end; end create_alias; ---------------------- -- create_interface -- ---------------------- function create_interface (Self : access Object; id : RepositoryId; name : Identifier; version : VersionSpec; base_interfaces : InterfaceDefSeq; is_abstract : CORBA.Boolean) return InterfaceDef_Forward.Ref is begin pragma Debug (O2 ("Create_interface (container)")); -- Is the new structure allowed? Check_Structure (Self, dk_Interface); Check_Id (Self, id); Check_Name (Self, name); declare Obj : constant ExtInterfaceDef.Impl.Object_Ptr := new ExtInterfaceDef.Impl.Object; Cont_Obj : constant Contained.Impl.Object_Ptr := new Contained.Impl.Object; IDLType_Obj : constant IDLType.Impl.Object_Ptr := new IDLType.Impl.Object; InterfaceAttrExtension_Obj : constant InterfaceAttrExtension.Impl.Object_Ptr := new InterfaceAttrExtension.Impl.Object; begin pragma Debug (O ("Create_interface : before init")); -- initialization of the object ExtInterfaceDef.Impl.Internals.Init (Obj, IRObject.Impl.Object_Ptr (Obj), dk_Interface, id, name, version, To_Forward (Object_Ptr (Self)), Contained.Impl.Contained_Seq.Null_Sequence, Cont_Obj, IDLType_Obj, base_interfaces, is_abstract, InterfaceAttrExtension_Obj); pragma Debug (O ("Create_interface : before append")); -- add it to the contents field of this container Append_To_Contents (Self, Contained.Impl.To_Contained (IRObject.Impl.Object_Ptr (Obj))); return InterfaceDef.Impl.To_Forward (InterfaceDef.Impl.Object_Ptr (Obj)); end; end create_interface; function create_value (Self : access Object; id : CORBA.RepositoryId; name : CORBA.Identifier; version : CORBA.Repository_Root.VersionSpec; is_custom : CORBA.Boolean; is_abstract : CORBA.Boolean; base_value : CORBA.Repository_Root.ValueDef_Forward.Ref; is_truncatable : CORBA.Boolean; abstract_base_values : CORBA.Repository_Root.ValueDefSeq; supported_interfaces : CORBA.Repository_Root.InterfaceDefSeq; initializers : CORBA.Repository_Root.InitializerSeq) return CORBA.Repository_Root.ValueDef_Forward.Ref is begin -- is the new structure allowed? Check_Structure (Self, dk_Value); Check_Id (Self, id); Check_Name (Self, name); declare Obj : constant ValueDef.Impl.Object_Ptr := new ValueDef.Impl.Object; Cont_Obj : constant Contained.Impl.Object_Ptr := new Contained.Impl.Object; IDLType_Obj : constant IDLType.Impl.Object_Ptr := new IDLType.Impl.Object; begin -- there cannot be more then one "true" in those boolean! if (is_custom and is_abstract) or (is_custom and is_truncatable) or (is_abstract and is_truncatable) then -- Spec is not precise... CORBA.Raise_Bad_Param (CORBA.System_Exception_Members' (Minor => 2, Completed => CORBA.Completed_No)); end if; -- initialization of the object ValueDef.Impl.Init (Obj, IRObject.Impl.Object_Ptr (Obj), dk_Value, id, name, version, To_Forward (Object_Ptr (Self)), Contained.Impl.Contained_Seq.Null_Sequence, Cont_Obj, IDLType_Obj, supported_interfaces, initializers, ValueDef.Convert_Forward.To_Ref (base_value), abstract_base_values, is_abstract, is_custom, is_truncatable); -- add it to the contents field of this container Append_To_Contents (Self, Contained.Impl.To_Contained (IRObject.Impl.Object_Ptr (Obj))); return ValueDef.Impl.To_Forward (Obj); end; end create_value; function create_value_box (Self : access Object; id : CORBA.RepositoryId; name : CORBA.Identifier; version : CORBA.Repository_Root.VersionSpec; original_type_def : CORBA.Repository_Root.IDLType_Forward.Ref) return CORBA.Repository_Root.ValueBoxDef_Forward.Ref is begin -- is the new structure allowed? Check_Structure (Self, dk_ValueBox); Check_Id (Self, id); Check_Name (Self, name); declare Obj : constant ValueBoxDef.Impl.Object_Ptr := new ValueBoxDef.Impl.Object; IDLType_Obj : constant IDLType.Impl.Object_Ptr := new IDLType.Impl.Object; begin -- initialization of the object ValueBoxDef.Impl.Init (Obj, IRObject.Impl.Object_Ptr (Obj), dk_ValueBox, id, name, version, To_Forward (Object_Ptr (Self)), IDLType_Obj, IDLType.Convert_Forward.To_Ref (original_type_def)); -- add it to the contents field of this container Append_To_Contents (Self, Contained.Impl.To_Contained (IRObject.Impl.Object_Ptr (Obj))); return ValueBoxDef.Impl.To_Forward (Obj); end; end create_value_box; function create_exception (Self : access Object; id : CORBA.RepositoryId; name : CORBA.Identifier; version : CORBA.Repository_Root.VersionSpec; members : CORBA.Repository_Root.StructMemberSeq) return CORBA.Repository_Root.ExceptionDef_Forward.Ref is begin -- is the new structure allowed? Check_Structure (Self, dk_Exception); Check_Id (Self, id); Check_Name (Self, name); declare Obj : constant ExceptionDef.Impl.Object_Ptr := new ExceptionDef.Impl.Object; Cont_Obj : constant Contained.Impl.Object_Ptr := new Contained.Impl.Object; begin -- initialization of the object ExceptionDef.Impl.Init (Obj, IRObject.Impl.Object_Ptr (Obj), dk_Exception, id, name, version, To_Forward (Object_Ptr (Self)), Contained.Impl.Contained_Seq.Null_Sequence, Cont_Obj, members); -- add it to the contents field of this container Append_To_Contents (Self, Contained.Impl.To_Contained (IRObject.Impl.Object_Ptr (Obj))); return ExceptionDef.Impl.To_Forward (Obj); end; end create_exception; function create_native (Self : access Object; id : CORBA.RepositoryId; name : CORBA.Identifier; version : CORBA.Repository_Root.VersionSpec) return CORBA.Repository_Root.NativeDef_Forward.Ref is begin -- is the new structure allowed? Check_Structure (Self, dk_Native); Check_Id (Self, id); Check_Name (Self, name); declare Obj : constant NativeDef.Impl.Object_Ptr := new NativeDef.Impl.Object; IDLType_Obj : constant IDLType.Impl.Object_Ptr := new IDLType.Impl.Object; begin -- initialization of the object NativeDef.Impl.Init (Obj, IRObject.Impl.Object_Ptr (Obj), dk_Native, id, name, version, To_Forward (Object_Ptr (Self)), IDLType_Obj); -- add it to the contents field of this container Append_To_Contents (Self, Contained.Impl.To_Contained (IRObject.Impl.Object_Ptr (Obj))); return NativeDef.Impl.To_Forward (Obj); end; end create_native; ------------------------------- -- create_abstract_interface -- ------------------------------- function create_abstract_interface (Self : access Object; id : RepositoryId; name : Identifier; version : VersionSpec; base_interfaces : AbstractInterfaceDefSeq) return AbstractInterfaceDef_Forward.Ref is begin -- Is the new structure allowed? Check_Structure (Self, dk_AbstractInterface); Check_Id (Self, id); Check_Name (Self, name); declare Ref : AbstractInterfaceDef.Ref; Obj : constant ExtAbstractInterfaceDef.Impl.Object_Ptr := new ExtAbstractInterfaceDef.Impl.Object; Cont_Obj : constant Contained.Impl.Object_Ptr := new Contained.Impl.Object; IDLType_Obj : constant IDLType.Impl.Object_Ptr := new IDLType.Impl.Object; IntAttrExt_Obj : constant InterfaceAttrExtension.Impl.Object_Ptr := new InterfaceAttrExtension.Impl.Object; begin -- Initialization and activation of the servant ExtAbstractInterfaceDef.Impl.Internals.Init (Obj, IRObject.Impl.Object_Ptr (Obj), dk_Interface, id, name, version, To_Forward (Object_Ptr (Self)), Contained.Impl.Contained_Seq.Null_Sequence, Cont_Obj, IDLType_Obj, base_interfaces, IntAttrExt_Obj); PolyORB.CORBA_P.Server_Tools.Initiate_Servant (PortableServer.Servant (Obj), Ref); -- Add it to the contents field of this container Append_To_Contents (Self, Contained.Impl.To_Contained (IRObject.Impl.Object_Ptr (Obj))); return AbstractInterfaceDef.Convert_Forward.To_Forward (Ref); end; end create_abstract_interface; ---------------------------- -- create_local_interface -- ---------------------------- function create_local_interface (Self : access Object; id : RepositoryId; name : Identifier; version : VersionSpec; base_interfaces : InterfaceDefSeq) return LocalInterfaceDef_Forward.Ref is begin -- Is the new structure allowed? Check_Structure (Self, dk_LocalInterface); Check_Id (Self, id); Check_Name (Self, name); declare Ref : LocalInterfaceDef.Ref; Obj : constant ExtLocalInterfaceDef.Impl.Object_Ptr := new ExtLocalInterfaceDef.Impl.Object; Cont_Obj : constant Contained.Impl.Object_Ptr := new Contained.Impl.Object; IDLType_Obj : constant IDLType.Impl.Object_Ptr := new IDLType.Impl.Object; IntAttrExt_Obj : constant InterfaceAttrExtension.Impl.Object_Ptr := new InterfaceAttrExtension.Impl.Object; begin -- Initialization and activation of the servant ExtLocalInterfaceDef.Impl.Internals.Init (Obj, IRObject.Impl.Object_Ptr (Obj), dk_Interface, id, name, version, To_Forward (Object_Ptr (Self)), Contained.Impl.Contained_Seq.Null_Sequence, Cont_Obj, IDLType_Obj, base_interfaces, IntAttrExt_Obj); PolyORB.CORBA_P.Server_Tools.Initiate_Servant (PortableServer.Servant (Obj), Ref); -- Add it to the contents field of this container Append_To_Contents (Self, Contained.Impl.To_Contained (IRObject.Impl.Object_Ptr (Obj))); return LocalInterfaceDef.Convert_Forward.To_Forward (Ref); end; end create_local_interface; end CORBA.Repository_Root.Container.Impl; polyorb-2.8~20110207.orig/cos/ir/corba-repository_root-abstractinterfacedef-impl.ads0000644000175000017500000000670611750740337027756 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- CORBA.REPOSITORY_ROOT.ABSTRACTINTERFACEDEF.IMPL -- -- -- -- S p e c -- -- -- -- Copyright (C) 2006-2008, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the CORBA Specification, and adapted -- -- for use with PolyORB. The copyright notice above, and the license -- -- provisions that follow apply solely to the contents neither explicitly -- -- nor implicitly specified by the CORBA Specification defined by the OMG. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with CORBA.Repository_Root.Contained.Impl; with CORBA.Repository_Root.IDLType.Impl; with CORBA.Repository_Root.InterfaceDef.Impl; with CORBA.Repository_Root.IRObject.Impl; package CORBA.Repository_Root.AbstractInterfaceDef.Impl is type Object is new InterfaceDef.Impl.Object with private; type Object_Ptr is access all Object'Class; package Internals is procedure Init (Self : access Object'Class; Real_Object : IRObject.Impl.Object_Ptr; Def_Kind : DefinitionKind; Id : RepositoryId; Name : Identifier; Version : VersionSpec; Defined_In : Container_Forward.Ref; Contents : Contained.Impl.Contained_Seq.Sequence; Contained_View : Contained.Impl.Object_Ptr; IDLType_View : IDLType.Impl.Object_Ptr; Base_Interfaces : AbstractInterfaceDefSeq); end Internals; private type Object is new InterfaceDef.Impl.Object with null record; end CORBA.Repository_Root.AbstractInterfaceDef.Impl; polyorb-2.8~20110207.orig/cos/ir/corba-repository_root-aliasdef-impl.ads0000644000175000017500000001013611750740337025353 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- C O R B A . R E P O S I T O R Y _ R O O T . A L I A S D E F . I M P L -- -- -- -- S p e c -- -- -- -- Copyright (C) 2006-2008, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the CORBA Specification, and adapted -- -- for use with PolyORB. The copyright notice above, and the license -- -- provisions that follow apply solely to the contents neither explicitly -- -- nor implicitly specified by the CORBA Specification defined by the OMG. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with CORBA.Repository_Root.IDLType; with CORBA.Repository_Root.IDLType.Impl; with CORBA.Repository_Root.IRObject.Impl; with CORBA.Repository_Root.TypedefDef.Impl; package CORBA.Repository_Root.AliasDef.Impl is type Object is new CORBA.Repository_Root.TypedefDef.Impl.Object with private; type Object_Ptr is access all Object'Class; -- To transform a forward_ref in impl.object_ptr. function To_Object (Fw_Ref : AliasDef_Forward.Ref) return Object_Ptr; -- To transform an object_ptr into Forward_ref function To_Forward (Obj : Object_Ptr) return AliasDef_Forward.Ref; -- method used to initialize recursively the object fields. procedure Init (Self : access Object; Real_Object : CORBA.Repository_Root.IRObject.Impl.Object_Ptr; Def_Kind : CORBA.Repository_Root.DefinitionKind; Id : CORBA.RepositoryId; Name : CORBA.Identifier; Version : CORBA.Repository_Root.VersionSpec; Defined_In : CORBA.Repository_Root.Container_Forward.Ref; IDLType_View : CORBA.Repository_Root.IDLType.Impl.Object_Ptr; Original_Type_Def : CORBA.Repository_Root.IDLType.Ref); -- overload the get_type from IDLType function get_type (Self : access Object) return CORBA.TypeCode.Object; function get_original_type_def (Self : access Object) return CORBA.Repository_Root.IDLType.Ref; procedure set_original_type_def (Self : access Object; To : CORBA.Repository_Root.IDLType.Ref); private type Object is new CORBA.Repository_Root.TypedefDef.Impl.Object with record Original_Type_Def : CORBA.Repository_Root.IDLType.Ref; end record; end CORBA.Repository_Root.AliasDef.Impl; polyorb-2.8~20110207.orig/cos/ir/corba-repository_root-exceptiondef-impl.adb0000644000175000017500000002400011750740337026232 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- CORBA.REPOSITORY_ROOT.EXCEPTIONDEF.IMPL -- -- -- -- B o d y -- -- -- -- Copyright (C) 2006-2007, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ pragma Style_Checks (Off); with CORBA.ORB.TypeCode; with PortableServer; with CORBA.Repository_Root.Helper; with CORBA.Repository_Root.ExceptionDef.Skel; pragma Warnings (Off, CORBA.Repository_Root.ExceptionDef.Skel); with PolyORB.CORBA_P.Server_Tools; package body CORBA.Repository_Root.ExceptionDef.Impl is package ExcDef renames IDL_SEQUENCE_CORBA_ExceptionDef_Forward; package ExcDes renames IDL_SEQUENCE_CORBA_ExceptionDescription; ---------------------- -- Procedure init -- ---------------------- procedure Init (Self : access Object; Real_Object : CORBA.Repository_Root.IRObject.Impl.Object_Ptr; Def_Kind : CORBA.Repository_Root.DefinitionKind; Id : CORBA.RepositoryId; Name : CORBA.Identifier; Version : CORBA.Repository_Root.VersionSpec; Defined_In : CORBA.Repository_Root.Container_Forward.Ref; Contents : CORBA.Repository_Root.Contained.Impl.Contained_Seq.Sequence; Contained_View : CORBA.Repository_Root.Contained.Impl.Object_Ptr; Members : CORBA.Repository_Root.StructMemberSeq) is begin Container.Impl.Init (Container.Impl.Object_Ptr (Self), Real_Object, Def_Kind, Contents); Contained.Impl.Init (Contained_View, Real_Object, Def_Kind, Id, Name, Version, Defined_In); Self.Contained_View := Contained_View; Initialize_Members (Self, Members); end Init; ----------------- -- To_Object -- ----------------- function To_Object (Fw_Ref : ExceptionDef_Forward.Ref) return Object_Ptr is Result : Portableserver.Servant; begin PolyORB.CORBA_P.Server_Tools.Reference_To_Servant (ExceptionDef.Convert_Forward.To_Ref (Fw_Ref), Result); return ExceptionDef.Impl.Object_Ptr (Result); end To_Object; ------------------ -- To_Forward -- ------------------ function To_Forward (Obj : Object_Ptr) return ExceptionDef_Forward.Ref is Ref : ExceptionDef.Ref; begin PolyORB.CORBA_P.Server_Tools.Initiate_Servant (PortableServer.Servant (Obj), Ref); return ExceptionDef.Convert_Forward.To_Forward (Ref); end To_Forward; --------------------------------- -- To get the secondary views -- --------------------------------- function Get_Contained_View (Self : access Object) return CORBA.Repository_Root.Contained.Impl.Object_Ptr is begin return Self.Contained_View; end Get_Contained_View; -------------------------- -- Initialize_Members -- -------------------------- procedure Initialize_Members (Self : access Object; Seq : StructMemberSeq) is -- package SMS renames -- IDL_SEQUENCE_CORBA_Repository_Root_StructMember; -- Memb_Array : SMS.Element_Array -- := SMS.To_Element_Array (SMS.Sequence (Seq)); begin -- FIXME>>>>>>>>>>>>>>>>> -- if we set the typecodes to TC_Void, we will loose -- the type of the members... -- for I in Memb_Array'Range loop -- Memb_Array (I).IDL_Type := CORBA.TC_Void; -- end loop; -- Self.Members := StructMemberSeq (SMS.To_Sequence (Memb_Array)); Self.Members := Seq; end Initialize_Members; function get_type (Self : access Object) return CORBA.TypeCode.Object is begin return CORBA.ORB.TypeCode.Create_Exception_Tc (Get_Id (Self), Get_Name (Self), Self.Members); end get_type; function get_members (Self : access Object) return CORBA.Repository_Root.StructMemberSeq is begin return Self.Members; end get_members; procedure set_members (Self : access Object; To : CORBA.Repository_Root.StructMemberSeq) is begin Initialize_Members (Self, To); end set_members; ------------------------------ -- inherited by contained -- ------------------------------ function get_id (Self : access Object) return CORBA.RepositoryId is begin return Contained.Impl.Get_Id (Self.Contained_View); end get_id; procedure set_id (Self : access Object; To : CORBA.RepositoryId) is begin Contained.Impl.Set_Id (Self.Contained_View, To); end set_id; function get_name (Self : access Object) return CORBA.Identifier is begin return Contained.Impl.Get_Name (Self.Contained_View); end get_name; procedure set_name (Self : access Object; To : CORBA.Identifier) is begin Contained.Impl.Set_Name (Self.Contained_View, To); end set_name; function get_version (Self : access Object) return CORBA.Repository_Root.VersionSpec is begin return Contained.Impl.Get_Version (Self.Contained_View); end get_version; procedure set_version (Self : access Object; To : CORBA.Repository_Root.VersionSpec) is begin Contained.Impl.Set_Version (Self.Contained_View, To); end set_version; function get_defined_in (Self : access Object) return CORBA.Repository_Root.Container_Forward.Ref is begin return Contained.Impl.Get_Defined_In (Self.Contained_View); end get_defined_in; function get_absolute_name (Self : access Object) return CORBA.ScopedName is begin return Contained.Impl.Get_Absolute_Name (Self.Contained_View); end get_absolute_name; function get_containing_repository (Self : access Object) return CORBA.Repository_Root.Repository_Forward.Ref is begin return Contained.Impl.Get_Containing_Repository (Self.Contained_View); end get_containing_repository; function describe (Self : access Object) return CORBA.Repository_Root.Contained.Description is Result : CORBA.Repository_Root.Contained.Description; Desc : CORBA.Repository_Root.ExceptionDescription; begin Desc := (Name => Get_Name (Self), Id => Get_Id (Self), Defined_In => Contained.Impl.Get_Defined_In (Self.Contained_View), Version => Get_Version (Self), IDL_Type => Get_Type (Self)); Result := (Kind => Get_Def_Kind (Self), Value => CORBA.Repository_Root.Helper.To_Any (Desc)); return Result; end describe; procedure move (Self : access Object; new_container : CORBA.Repository_Root.Container_Forward.Ref; new_name : CORBA.Identifier; new_version : CORBA.Repository_Root.VersionSpec) is begin Contained.Impl.Move (Self.Contained_View, New_Container, New_Name, New_Version); end move; ----------------------------- -- Get_ExcDescritpionSeq -- ----------------------------- function Get_ExcDescriptionSeq (ExcDefSeq : ExceptionDefSeq) return ExcDescriptionSeq is Result : ExcDescriptionSeq; Exc_Array : constant ExcDef.Element_Array := ExcDef.To_Element_Array (ExcDef.Sequence (ExcDefSeq)); begin for I in Exc_Array'Range loop declare Exc : constant Object_Ptr := To_Object (Exc_Array (I)); Des : ExceptionDescription; begin Des := (Name => Get_Name (Exc), Id => Get_Id (Exc), Defined_In => Contained.Impl.Get_Defined_In (Get_Contained_View (Exc)), Version => Get_Version (Exc), IDL_Type => Get_Type (Exc)); ExcDes.Append (ExcDes.Sequence (Result), Des); end; end loop; return Result; end Get_ExcDescriptionSeq; end CORBA.Repository_Root.ExceptionDef.Impl; polyorb-2.8~20110207.orig/cos/ir/corba-repository_root-extattributedef-impl.ads0000644000175000017500000000765511750740337027022 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- CORBA.REPOSITORY_ROOT.EXTATTRIBUTEDEF.IMPL -- -- -- -- S p e c -- -- -- -- Copyright (C) 2006-2008, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the CORBA Specification, and adapted -- -- for use with PolyORB. The copyright notice above, and the license -- -- provisions that follow apply solely to the contents neither explicitly -- -- nor implicitly specified by the CORBA Specification defined by the OMG. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with CORBA.Repository_Root.AttributeDef.Impl; with CORBA.Repository_Root.IDLType; with CORBA.Repository_Root.IRObject.Impl; package CORBA.Repository_Root.ExtAttributeDef.Impl is type Object is new AttributeDef.Impl.Object with private; type Object_Ptr is access all Object'Class; function get_get_exceptions (Self : access Object) return ExcDescriptionSeq; procedure set_get_exceptions (Self : access Object; To : ExcDescriptionSeq); function get_set_exceptions (Self : access Object) return ExcDescriptionSeq; procedure set_set_exceptions (Self : access Object; To : ExcDescriptionSeq); function describe_attribute (Self : access Object) return ExtAttributeDescription; package Internals is procedure Init (Self : access Object'Class; Real_Object : IRObject.Impl.Object_Ptr; Def_Kind : DefinitionKind; Id : RepositoryId; Name : Identifier; Version : VersionSpec; Defined_In : Container_Forward.Ref; Type_Def : IDLType.Ref; Mode : AttributeMode; Get_Exceptions : ExceptionDefSeq; Set_Exceptions : ExceptionDefSeq); -- Recursively initialize object fields end Internals; private type Object is new AttributeDef.Impl.Object with record Get_Exceptions : ExcDescriptionSeq; Set_Exceptions : ExcDescriptionSeq; end record; end CORBA.Repository_Root.ExtAttributeDef.Impl; polyorb-2.8~20110207.orig/cos/ir/corba-repository_root-aliasdef-impl.adb0000644000175000017500000001156111750740337025335 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- C O R B A . R E P O S I T O R Y _ R O O T . A L I A S D E F . I M P L -- -- -- -- B o d y -- -- -- -- Copyright (C) 2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with CORBA.ORB; with PortableServer; with CORBA.Repository_Root.AliasDef.Skel; pragma Warnings (Off, CORBA.Repository_Root.AliasDef.Skel); with PolyORB.CORBA_P.Server_Tools; package body CORBA.Repository_Root.AliasDef.Impl is ----------------- -- To_Object -- ----------------- function To_Object (Fw_Ref : AliasDef_Forward.Ref) return Object_Ptr is Result : PortableServer.Servant; begin PolyORB.CORBA_P.Server_Tools.Reference_To_Servant (AliasDef.Convert_Forward.To_Ref (Fw_Ref), Result); return Object_Ptr (Result); end To_Object; ------------------ -- To_Forward -- ------------------ function To_Forward (Obj : Object_Ptr) return AliasDef_Forward.Ref is Ref : AliasDef.Ref; begin PolyORB.CORBA_P.Server_Tools.Initiate_Servant (PortableServer.Servant (Obj), Ref); return AliasDef.Convert_Forward.To_Forward (Ref); end To_Forward; ------------ -- INIT -- ------------ procedure Init (Self : access Object; Real_Object : CORBA.Repository_Root.IRObject.Impl.Object_Ptr; Def_Kind : CORBA.Repository_Root.DefinitionKind; Id : CORBA.RepositoryId; Name : CORBA.Identifier; Version : CORBA.Repository_Root.VersionSpec; Defined_In : CORBA.Repository_Root.Container_Forward.Ref; IDLType_View : CORBA.Repository_Root.IDLType.Impl.Object_Ptr; Original_Type_Def : CORBA.Repository_Root.IDLType.Ref) is begin TypedefDef.Impl.Init (TypedefDef.Impl.Object_Ptr (Self), Real_Object, Def_Kind, Id, Name, Version, Defined_In, IDLType_View); Self.Original_Type_Def := Original_Type_Def; end Init; ---------------- -- get_type -- ---------------- function get_type (Self : access Object) return CORBA.TypeCode.Object is Obj : PortableServer.Servant; Orig_TC : CORBA.TypeCode.Object; begin PolyORB.CORBA_P.Server_Tools.Reference_To_Servant (Self.Original_Type_Def, Obj); Orig_TC := IDLType.Impl.get_type (IDLType.Impl.To_IDLType (IRObject.Impl.Object_Ptr (Obj))); return CORBA.ORB.Create_Alias_Tc (get_id (Self), get_name (Self), Orig_TC); end get_type; function get_original_type_def (Self : access Object) return CORBA.Repository_Root.IDLType.Ref is begin return Self.Original_Type_Def; end get_original_type_def; procedure set_original_type_def (Self : access Object; To : CORBA.Repository_Root.IDLType.Ref) is begin Self.Original_Type_Def := To; end set_original_type_def; end CORBA.Repository_Root.AliasDef.Impl; polyorb-2.8~20110207.orig/cos/ir/corba-repository_root-valuememberdef-impl.adb0000644000175000017500000001221011750740337026540 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- CORBA.REPOSITORY_ROOT.VALUEMEMBERDEF.IMPL -- -- -- -- B o d y -- -- -- -- Copyright (C) 2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ pragma Style_Checks (Off); with PortableServer; with CORBA.Repository_Root.IDLType.Impl; with CORBA.Repository_Root.Helper; with CORBA.Repository_Root.ValueMemberDef.Skel; pragma Warnings (Off, CORBA.Repository_Root.ValueMemberDef.Skel); with PolyORB.CORBA_P.Server_Tools; package body CORBA.Repository_Root.ValueMemberDef.Impl is ---------------------- -- Procedure init -- ---------------------- procedure Init (Self : access Object; Real_Object : IRObject.Impl.Object_Ptr; Def_Kind : CORBA.Repository_Root.DefinitionKind; Id : CORBA.RepositoryId; Name : CORBA.Identifier; Version : CORBA.Repository_Root.VersionSpec; Defined_In : CORBA.Repository_Root.Container_Forward.Ref; Type_Def : CORBA.Repository_Root.IDLType.Ref; IDL_Access : CORBA.Visibility) is begin Contained.Impl.Init (Contained.Impl.Object_Ptr(Self), Real_Object, Def_Kind, Id, Name, Version, Defined_In); Self.Type_Def := Type_Def; Self.IDL_Access := IDL_Access; end Init; function get_type (Self : access Object) return CORBA.TypeCode.Object is Obj : PortableServer.Servant; begin PolyORB.CORBA_P.Server_Tools.Reference_To_Servant (Self.Type_Def, Obj); -- The type should be the type of the Type_def return IDLType.Impl.Get_Type (IDLType.Impl.To_IDLType (IRObject.Impl.Object_Ptr (Obj))); end get_type; function get_type_def (Self : access Object) return CORBA.Repository_Root.IDLType.Ref is begin return Self.Type_Def; end get_type_def; procedure set_type_def (Self : access Object; To : CORBA.Repository_Root.IDLType.Ref) is begin Self.Type_Def := To; end set_type_def; function get_access (Self : access Object) return CORBA.Visibility is begin return Self.IDL_Access; end get_access; procedure set_access (Self : access Object; To : CORBA.Visibility) is begin Self.IDL_Access := To; end set_access; ---------------- -- Describe -- ---------------- function describe (Self : access Object) return CORBA.Repository_Root.Contained.Description is Result : CORBA.Repository_Root.Contained.Description; Desc : CORBA.Repository_Root.ValueMember; begin Desc := (Name => Get_Name (Self), Id => Get_Id (Self), Defined_In => Get_Defined_In (Self), Version => Get_Version (Self), IDL_Type => Get_Type (Self), Type_Def => IDLType.Convert_Forward.To_Forward (Self.Type_Def), IDL_Access => Self.IDL_Access); Result := (Kind => Get_Def_Kind (Self), Value => CORBA.Repository_Root.Helper.To_Any (Desc)); return Result; end describe; end CORBA.Repository_Root.ValueMemberDef.Impl; polyorb-2.8~20110207.orig/cos/ir/corba-repository_root-exceptiondef-impl.ads0000644000175000017500000001365511750740337026271 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- CORBA.REPOSITORY_ROOT.EXCEPTIONDEF.IMPL -- -- -- -- S p e c -- -- -- -- Copyright (C) 2006-2008, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the CORBA Specification, and adapted -- -- for use with PolyORB. The copyright notice above, and the license -- -- provisions that follow apply solely to the contents neither explicitly -- -- nor implicitly specified by the CORBA Specification defined by the OMG. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with CORBA.Repository_Root.IRObject.Impl; with CORBA.Repository_Root.Contained; with CORBA.Repository_Root.Contained.Impl; with CORBA.Repository_Root.Container.Impl; package CORBA.Repository_Root.ExceptionDef.Impl is type Object is new CORBA.Repository_Root.Container.Impl.Object with private; type Object_Ptr is access all Object'Class; -- method used to initialize recursively the object fields. procedure Init (Self : access Object; Real_Object : CORBA.Repository_Root.IRObject.Impl.Object_Ptr; Def_Kind : CORBA.Repository_Root.DefinitionKind; Id : CORBA.RepositoryId; Name : CORBA.Identifier; Version : CORBA.Repository_Root.VersionSpec; Defined_In : CORBA.Repository_Root.Container_Forward.Ref; Contents : CORBA.Repository_Root.Contained.Impl.Contained_Seq.Sequence; Contained_View : CORBA.Repository_Root.Contained.Impl.Object_Ptr; Members : CORBA.Repository_Root.StructMemberSeq); -- Transform the forward to an impl.object.ptr. function To_Object (Fw_Ref : ExceptionDef_Forward.Ref) return Object_Ptr; -- To transform an object_ptr into Forward_ref function To_Forward (Obj : Object_Ptr) return ExceptionDef_Forward.Ref; -- for accessing the secondary parents view function Get_Contained_View (Self : access Object) return CORBA.Repository_Root.Contained.Impl.Object_Ptr; -- Set the members attribute while putting the "type" field -- of the member to TC_Void procedure Initialize_Members (Self : access Object; Seq : StructMemberSeq); function get_type (Self : access Object) return CORBA.TypeCode.Object; function get_members (Self : access Object) return CORBA.Repository_Root.StructMemberSeq; procedure set_members (Self : access Object; To : CORBA.Repository_Root.StructMemberSeq); function get_id (Self : access Object) return CORBA.RepositoryId; procedure set_id (Self : access Object; To : CORBA.RepositoryId); function get_name (Self : access Object) return CORBA.Identifier; procedure set_name (Self : access Object; To : CORBA.Identifier); function get_version (Self : access Object) return CORBA.Repository_Root.VersionSpec; procedure set_version (Self : access Object; To : CORBA.Repository_Root.VersionSpec); function get_defined_in (Self : access Object) return CORBA.Repository_Root.Container_Forward.Ref; function get_absolute_name (Self : access Object) return CORBA.ScopedName; function get_containing_repository (Self : access Object) return CORBA.Repository_Root.Repository_Forward.Ref; function describe (Self : access Object) return CORBA.Repository_Root.Contained.Description; procedure move (Self : access Object; new_container : CORBA.Repository_Root.Container_Forward.Ref; new_name : CORBA.Identifier; new_version : CORBA.Repository_Root.VersionSpec); -- Transform a ExceptionDefSeq ExcDescriptionSeq function Get_ExcDescriptionSeq (ExcDefSeq : ExceptionDefSeq) return ExcDescriptionSeq; private type Object is new CORBA.Repository_Root.Container.Impl.Object with record Contained_View : CORBA.Repository_Root.Contained.Impl.Object_Ptr; -- the Type will be computed dynamically ... Members : CORBA.Repository_Root.StructMemberSeq; end record; end CORBA.Repository_Root.ExceptionDef.Impl; polyorb-2.8~20110207.orig/cos/ir/corba-repository_root-nativedef-impl.adb0000644000175000017500000000644711750740337025541 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- CORBA.REPOSITORY_ROOT.NATIVEDEF.IMPL -- -- -- -- B o d y -- -- -- -- Copyright (C) 2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with CORBA.ORB; with PolyORB.CORBA_P.Server_Tools; with PortableServer; with CORBA.Repository_Root.NativeDef.Skel; pragma Warnings (Off, CORBA.Repository_Root.NativeDef.Skel); package body CORBA.Repository_Root.NativeDef.Impl is ----------------- -- To_Object -- ----------------- function To_Object (Fw_Ref : NativeDef_Forward.Ref) return Object_Ptr is Result : PortableServer.Servant; begin PolyORB.CORBA_P.Server_Tools.Reference_To_Servant (NativeDef.Convert_Forward.To_Ref (Fw_Ref), Result); return NativeDef.Impl.Object_Ptr (Result); end To_Object; ------------------ -- To_Forward -- ------------------ function To_Forward (Obj : Object_Ptr) return NativeDef_Forward.Ref is Ref : NativeDef.Ref; begin PolyORB.CORBA_P.Server_Tools.Initiate_Servant (PortableServer.Servant (Obj), Ref); return NativeDef.Convert_Forward.To_Forward (Ref); end To_Forward; ---------------- -- get_type -- ---------------- function get_type (Self : access Object) return CORBA.TypeCode.Object is begin return CORBA.ORB.Create_Native_Tc (get_id (Self), get_name (Self)); end get_type; end CORBA.Repository_Root.NativeDef.Impl; polyorb-2.8~20110207.orig/cos/ir/polyorb-if_descriptors-corba_ir.adb0000644000175000017500000001666611750740337024556 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . I F _ D E S C R I P T O R S . C O R B A _ I R -- -- -- -- B o d y -- -- -- -- Copyright (C) 2002-2007, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- An Interface Descriptor that uses the CORBA Interface Repository. with PolyORB.Any; with PolyORB.Any.NVList; with PolyORB.CORBA_P.IR_Tools; with PolyORB.Log; with PolyORB.Types; with CORBA.Repository_Root; with CORBA.Repository_Root.Helper; with CORBA.Repository_Root.Contained; with CORBA.Repository_Root.Contained.Helper; with CORBA.Repository_Root.InterfaceDef; with CORBA.Repository_Root.InterfaceDef.Helper; with CORBA.Repository_Root.Repository; package body PolyORB.If_Descriptors.CORBA_IR is use PolyORB.Log; use CORBA.Repository_Root; package L is new PolyORB.Log.Facility_Log ("polyorb.if_descriptors.corba_ir"); procedure O (Message : String; Level : Log_Level := Debug) renames L.Output; function C (Level : Log_Level := Debug) return Boolean renames L.Enabled; pragma Unreferenced (C); -- For conditional pragma Debug package ContainedSeq_Seq renames IDL_SEQUENCE_CORBA_Contained_Forward; package InterfaceDefSeq_Seq renames IDL_SEQUENCE_CORBA_InterfaceDef_Forward; package ParDescriptionSeq_Seq renames IDL_SEQUENCE_CORBA_ParameterDescription; function Corresponding_InterfaceDef (Object : PolyORB.References.Ref) return InterfaceDef.Ref; function Find_Operation (Intf : InterfaceDef.Ref; Method : CORBA.Identifier) return OperationDescription; function Corresponding_InterfaceDef (Object : PolyORB.References.Ref) return InterfaceDef.Ref is RId : constant String := References.Type_Id_Of (Object); begin -- return InterfaceDef.Helper.To_Ref -- (CORBA.Object.get_interface (To_CORBA_Ref (Object)); pragma Debug (O ("Corresponding_IfDef for " & RId)); return InterfaceDef.Helper.To_Ref (Repository.lookup_id (CORBA_P.IR_Tools.Get_IR_Root, CORBA.To_CORBA_String (RId))); -- XXX actually we should do a call to get_interface here, -- and use Lookup_Id or whatever only on the /server/. end Corresponding_InterfaceDef; function Find_Operation (Intf : InterfaceDef.Ref; Method : CORBA.Identifier) return OperationDescription is Contents : constant ContainedSeq_Seq.Element_Array := To_Element_Array (InterfaceDef.contents (Intf, dk_Operation, True)); Base_Intfs : constant InterfaceDefSeq_Seq.Element_Array := To_Element_Array (InterfaceDef.Get_base_interfaces (Intf)); begin -- First try to find the method in this InterfaceDef... for I in Contents'Range loop declare use type CORBA.Identifier; R : constant Contained.Ref := Contained.Helper.To_Ref (Contents (I)); begin if Contained.Get_name (R) = Method then return Helper.From_Any (Contained.describe (R).value); end if; end; end loop; -- Then try ancestors in turn. Base_Intfs_Loop : for I in Base_Intfs'Range loop begin return Find_Operation (InterfaceDef.Helper.To_Ref (Base_Intfs (I)), Method); exception when CORBA.Bad_Operation => null; end; end loop Base_Intfs_Loop; CORBA.Raise_Bad_Operation (CORBA.Default_Sys_Member); end Find_Operation; ------------------------------------------- -- Public primitives of IR_If_Descriptor -- ------------------------------------------- Mode_Map : constant array (ParameterMode) of PolyORB.Any.Flags := (PARAM_IN => Any.ARG_IN, PARAM_OUT => Any.ARG_OUT, PARAM_INOUT => Any.ARG_INOUT); function Get_Empty_Arg_List (If_Desc : access IR_If_Descriptor; Object : PolyORB.References.Ref; Method : String) return Any.NVList.Ref is pragma Warnings (Off); pragma Unreferenced (If_Desc); pragma Warnings (On); Oper : constant OperationDescription := Find_Operation (Corresponding_InterfaceDef (Object), CORBA.Identifier'(CORBA.To_CORBA_String (Method))); Args : constant ParDescriptionSeq_Seq.Element_Array := To_Element_Array (Oper.Parameters); Result : Any.NVList.Ref; begin Any.NVList.Create (Result); for I in Args'Range loop Any.NVList.Add_Item (Result, PolyORB.Any.NamedValue' (Name => PolyORB.Types.Identifier (Args (I).Name), Argument => Any.Get_Empty_Any (CORBA.TypeCode.Internals.To_PolyORB_Object (Args (I).IDL_Type)), Arg_Modes => Mode_Map (Args (I).Mode))); end loop; return Result; end Get_Empty_Arg_List; function Get_Empty_Result (If_Desc : access IR_If_Descriptor; Object : PolyORB.References.Ref; Method : String) return Any.Any is pragma Warnings (Off); pragma Unreferenced (If_Desc); pragma Warnings (On); Oper : constant OperationDescription := Find_Operation (Corresponding_InterfaceDef (Object), CORBA.Identifier'(CORBA.To_CORBA_String (Method))); begin pragma Debug (O ("Get_Empty_Result: TC is of kind " & PolyORB.Any.TCKind'Image (PolyORB.Any.TypeCode.Kind (CORBA.TypeCode.Internals.To_PolyORB_Object (Oper.Result))))); return Any.Get_Empty_Any (CORBA.TypeCode.Internals.To_PolyORB_Object (Oper.Result)); end Get_Empty_Result; end PolyORB.If_Descriptors.CORBA_IR; polyorb-2.8~20110207.orig/cos/ir/corba-repository_root-sequencedef-impl.ads0000644000175000017500000000773411750740337026104 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- CORBA.REPOSITORY_ROOT.SEQUENCEDEF.IMPL -- -- -- -- S p e c -- -- -- -- Copyright (C) 2006-2008, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the CORBA Specification, and adapted -- -- for use with PolyORB. The copyright notice above, and the license -- -- provisions that follow apply solely to the contents neither explicitly -- -- nor implicitly specified by the CORBA Specification defined by the OMG. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with CORBA.Repository_Root.IDLType; with CORBA.Repository_Root.IDLType.Impl; with CORBA.Repository_Root.IRObject.Impl; package CORBA.Repository_Root.SequenceDef.Impl is type Object is new CORBA.Repository_Root.IDLType.Impl.Object with private; type Object_Ptr is access all Object'Class; -- method used to initialize recursively the object fields. procedure Init (Self : access Object; Real_Object : CORBA.Repository_Root.IRObject.Impl.Object_Ptr; Def_Kind : CORBA.Repository_Root.DefinitionKind; Bound : CORBA.Unsigned_Long; Element_Type_Def : CORBA.Repository_Root.IDLType.Ref); -- overload the get_type from IDLType function get_type (Self : access Object) return CORBA.TypeCode.Object; function get_bound (Self : access Object) return CORBA.Unsigned_Long; procedure set_bound (Self : access Object; To : CORBA.Unsigned_Long); function get_element_type (Self : access Object) return CORBA.TypeCode.Object; function get_element_type_def (Self : access Object) return CORBA.Repository_Root.IDLType.Ref; procedure set_element_type_def (Self : access Object; To : CORBA.Repository_Root.IDLType.Ref); private type Object is new CORBA.Repository_Root.IDLType.Impl.Object with record Bound : CORBA.Unsigned_Long; -- the Element_Type field is the one from the IDLType Element_Type_Def : CORBA.Repository_Root.IDLType.Ref; end record; end CORBA.Repository_Root.SequenceDef.Impl; polyorb-2.8~20110207.orig/cos/ir/corba-orb-typecode.ads0000644000175000017500000001234511750740337021764 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- C O R B A . O R B . T Y P E C O D E -- -- -- -- S p e c -- -- -- -- Copyright (C) 1999-2008, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the CORBA Specification, and adapted -- -- for use with PolyORB. The copyright notice above, and the license -- -- provisions that follow apply solely to the contents neither explicitly -- -- nor implicitly specified by the CORBA Specification defined by the OMG. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with CORBA.Repository_Root; package CORBA.ORB.Typecode is function Create_Struct_Tc (Id : CORBA.RepositoryId; Name : CORBA.Identifier; Members : CORBA.Repository_Root.StructMemberSeq) return CORBA.TypeCode.Object; function Create_Union_Tc (Id : CORBA.RepositoryId; Name : CORBA.Identifier; Discriminator_Type : CORBA.TypeCode.Object; Members : CORBA.Repository_Root.UnionMemberSeq) return CORBA.TypeCode.Object; function Create_Enum_Tc (Id : CORBA.RepositoryId; Name : CORBA.Identifier; Members : CORBA.Repository_Root.EnumMemberSeq) return CORBA.TypeCode.Object; function Create_Alias_Tc (Id : CORBA.RepositoryId; Name : CORBA.Identifier; Original_Type : CORBA.TypeCode.Object) return CORBA.TypeCode.Object; function Create_Exception_Tc (Id : CORBA.RepositoryId; Name : CORBA.Identifier; Members : CORBA.Repository_Root.StructMemberSeq) return CORBA.TypeCode.Object; function Create_Interface_Tc (Id : CORBA.RepositoryId; Name : CORBA.Identifier) return CORBA.TypeCode.Object; function Create_String_Tc (Bound : CORBA.Unsigned_Long) return CORBA.TypeCode.Object; function Create_Wstring_Tc (Bound : CORBA.Unsigned_Long) return CORBA.TypeCode.Object; function Create_Fixed_Tc (IDL_Digits : CORBA.Unsigned_Short; Scale : CORBA.Short) return CORBA.TypeCode.Object; function Create_Sequence_Tc (Bound : CORBA.Unsigned_Long; Elementtype : CORBA.TypeCode.Object) return CORBA.TypeCode.Object; function Create_Recursive_Sequence_Tc (Bound : CORBA.Unsigned_Long; Offset : CORBA.Unsigned_Long) return CORBA.TypeCode.Object; function Create_Array_Tc (Length : CORBA.Unsigned_Long; Element_Type : CORBA.TypeCode.Object) return CORBA.TypeCode.Object; function Create_Value_Tc (Id : CORBA.RepositoryId; Name : CORBA.Identifier; Type_Modifier : CORBA.ValueModifier; Concrete_Base : CORBA.TypeCode.Object; Members : CORBA.Repository_Root.ValueMemberSeq) return CORBA.TypeCode.Object; function Create_Value_Box_Tc (Id : CORBA.RepositoryId; Name : CORBA.Identifier; Boxed_Type : CORBA.TypeCode.Object) return CORBA.TypeCode.Object; function Create_Native_Tc (Id : CORBA.RepositoryId; Name : CORBA.Identifier) return CORBA.TypeCode.Object; function Create_Recursive_Tc (Id : CORBA.RepositoryId) return CORBA.TypeCode.Object; function Create_Abstract_Interface_Tc (Id : CORBA.RepositoryId; Name : CORBA.Identifier) return CORBA.TypeCode.Object; end CORBA.ORB.Typecode; polyorb-2.8~20110207.orig/cos/ir/polyorb-if_descriptors-corba_ir.ads0000644000175000017500000000521011750740337024556 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . I F _ D E S C R I P T O R S . C O R B A _ I R -- -- -- -- S p e c -- -- -- -- Copyright (C) 2002-2007, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by ACT Europe. -- -- (email: sales@act-europe.fr) -- -- -- ------------------------------------------------------------------------------ -- An Interface Descriptor that uses the CORBA Interface Repository. package PolyORB.If_Descriptors.CORBA_IR is type IR_If_Descriptor is new If_Descriptor with private; function Get_Empty_Arg_List (If_Desc : access IR_If_Descriptor; Object : PolyORB.References.Ref; Method : String) return Any.NVList.Ref; function Get_Empty_Result (If_Desc : access IR_If_Descriptor; Object : PolyORB.References.Ref; Method : String) return Any.Any; private type IR_If_Descriptor is new If_Descriptor with null record; end PolyORB.If_Descriptors.CORBA_IR; polyorb-2.8~20110207.orig/cos/ir/corba-repository_root-irobject-impl.ads0000644000175000017500000000726711750740337025417 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- C O R B A . R E P O S I T O R Y _ R O O T . I R O B J E C T . I M P L -- -- -- -- S p e c -- -- -- -- Copyright (C) 2006-2008, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the CORBA Specification, and adapted -- -- for use with PolyORB. The copyright notice above, and the license -- -- provisions that follow apply solely to the contents neither explicitly -- -- nor implicitly specified by the CORBA Specification defined by the OMG. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with PortableServer; package CORBA.Repository_Root.IRObject.Impl is type Object is new PortableServer.Servant_Base with private; type Object_Ptr is access all Object'Class; -- method used to initialize recursively the object fields. procedure Init (Self : access Object; Real_Object : IRObject.Impl.Object_Ptr; Def_Kind : CORBA.Repository_Root.DefinitionKind); function Get_Real_Object (Self : access Object) return Object_Ptr; function get_def_kind (Self : access Object) return CORBA.Repository_Root.DefinitionKind; procedure destroy (Self : access Object); private -- The "real_object" is a pointer to the real object -- The Def_Kind is an attribute type Object is new PortableServer.Servant_Base with record Real_Object : Object_Ptr; Def_Kind : CORBA.Repository_Root.DefinitionKind; end record; ------------------- -- IRObject list -- ------------------- type IRObject_List_Cell; type IRObject_List is access IRObject_List_Cell; type IRObject_List_Cell is record Car : Object_Ptr; Cdr : IRObject_List; end record; Nil_List : constant IRObject_List := null; type IRObject_Iterator is new IRObject_List; end CORBA.Repository_Root.IRObject.Impl; polyorb-2.8~20110207.orig/cos/ir/corba-repository_root-irobject-impl.adb0000644000175000017500000001200511750740337025360 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- C O R B A . R E P O S I T O R Y _ R O O T . I R O B J E C T . I M P L -- -- -- -- B o d y -- -- -- -- Copyright (C) 2005-2007, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with CORBA.Repository_Root.Contained.Impl; with CORBA.Repository_Root.Container.Impl; with CORBA.Repository_Root.IRObject.Skel; pragma Warnings (Off, CORBA.Repository_Root.IRObject.Skel); with PolyORB.Log; pragma Elaborate_All (PolyORB.Log); package body CORBA.Repository_Root.IRObject.Impl is ----------- -- Debug -- ----------- use PolyORB.Log; -- package L is new PolyORB.Log.Facility_Log ("irobject.impl"); -- procedure O (Message : Standard.String; Level : Log_Level := Debug) -- renames L.Output; -- function C (Level : Log_Level := Debug) return Boolean -- renames L.Enabled; -- pragma Unreferenced (C); -- For conditional pragma Debug package L2 is new PolyORB.Log.Facility_Log ("irobject.impl_method_trace"); procedure O2 (Message : Standard.String; Level : Log_Level := Debug) renames L2.Output; function C2 (Level : Log_Level := Debug) return Boolean renames L2.Enabled; pragma Unreferenced (C2); -- For conditional pragma Debug ------------- -- destroy -- ------------- procedure destroy (Self : access Object) is begin pragma Debug (O2 ("IRObject destroy: enter")); -- This is overriden in each necessary defs case Self.Def_Kind is when dk_Repository | dk_Primitive => -- Can't destroy Repository or Primitive object CORBA.Raise_Bad_Inv_Order (CORBA.System_Exception_Members' (Minor => 2, Completed => CORBA.Completed_No)); when others => -- Redispatch -- Destroy (Object_Ptr (Self)); -- ??? implementation is not complete -- FIXME memory leak, should remove the contained from the -- previous container. declare Cont : constant Contained.Impl.Object_Ptr := Contained.Impl.To_Contained (Get_Real_Object (Self)); begin Container.Impl.Delete_From_Contents (Container.Impl.To_Object (Contained.Impl.get_defined_in (Cont)), Cont); end; end case; end destroy; ------------------ -- get_def_kind -- ------------------ function get_def_kind (Self : access Object) return CORBA.Repository_Root.DefinitionKind is begin return Self.Def_Kind; end get_def_kind; --------------------- -- Get_Real_Object -- --------------------- function Get_Real_Object (Self : access Object) return Object_Ptr is begin return Self.Real_Object; end Get_Real_Object; ---------- -- Init -- ---------- procedure Init (Self : access Object; Real_Object : IRObject.Impl.Object_Ptr; Def_Kind : CORBA.Repository_Root.DefinitionKind) is begin pragma Debug (O2 ("Init: enter")); Self.Def_Kind := Def_Kind; Self.Real_Object := Real_Object; pragma Debug (O2 ("Init: end")); end Init; end CORBA.Repository_Root.IRObject.Impl; polyorb-2.8~20110207.orig/cos/ir/corba-repository_root-valuedef-impl.ads0000644000175000017500000002234611750740337025404 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- C O R B A . R E P O S I T O R Y _ R O O T . V A L U E D E F . I M P L -- -- -- -- S p e c -- -- -- -- Copyright (C) 2006-2010, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the CORBA Specification, and adapted -- -- for use with PolyORB. The copyright notice above, and the license -- -- provisions that follow apply solely to the contents neither explicitly -- -- nor implicitly specified by the CORBA Specification defined by the OMG. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with CORBA.Repository_Root.IRObject.Impl; with CORBA.Repository_Root.Contained; with CORBA.Repository_Root.OperationDef; with CORBA.Repository_Root.AttributeDef; with CORBA.Repository_Root.ValueMemberDef; with CORBA.Repository_Root.IDLType; with CORBA.Repository_Root.IDLType.Impl; with CORBA.Repository_Root.Contained.Impl; with CORBA.Repository_Root.Container.Impl; package CORBA.Repository_Root.ValueDef.Impl is type Object is new CORBA.Repository_Root.Container.Impl.Object with private; type Object_Ptr is access all Object'Class; -- method used to initialize recursively the object fields. procedure Init (Self : access Object; Real_Object : CORBA.Repository_Root.IRObject.Impl.Object_Ptr; Def_Kind : CORBA.Repository_Root.DefinitionKind; Id : CORBA.RepositoryId; Name : CORBA.Identifier; Version : CORBA.Repository_Root.VersionSpec; Defined_In : CORBA.Repository_Root.Container_Forward.Ref; Contents : CORBA.Repository_Root.Contained.Impl.Contained_Seq.Sequence; Contained_View : CORBA.Repository_Root.Contained.Impl.Object_Ptr; IDLType_View : CORBA.Repository_Root.IDLType.Impl.Object_Ptr; Supported_Interfaces : CORBA.Repository_Root.InterfaceDefSeq; Initializers : CORBA.Repository_Root.InitializerSeq; Base_Value : CORBA.Repository_Root.ValueDef.Ref; Abstract_Base_Values : CORBA.Repository_Root.ValueDefSeq; Is_Abstract : CORBA.Boolean; Is_Custom : CORBA.Boolean; Is_Truncatable : CORBA.Boolean); -- Transform the forward to an impl.object.ptr. function To_Object (Fw_Ref : ValueDef_Forward.Ref) return Object_Ptr; -- To transform an object_ptr into Forward_ref function To_Forward (Obj : Object_Ptr) return ValueDef_Forward.Ref; -- For multiple inheritance, to access the different views function Get_Contained_View (Self : access Object) return CORBA.Repository_Root.Contained.Impl.Object_Ptr; function Get_IDLType_View (Self : access Object) return CORBA.Repository_Root.IDLType.Impl.Object_Ptr; -- functions inherited from the secondary parents function get_supported_interfaces (Self : access Object) return CORBA.Repository_Root.InterfaceDefSeq; procedure set_supported_interfaces (Self : access Object; To : CORBA.Repository_Root.InterfaceDefSeq); function get_initializers (Self : access Object) return CORBA.Repository_Root.InitializerSeq; procedure set_initializers (Self : access Object; To : CORBA.Repository_Root.InitializerSeq); function get_base_value (Self : access Object) return CORBA.Repository_Root.ValueDef.Ref'Class; procedure set_base_value (Self : access Object; To : CORBA.Repository_Root.ValueDef.Ref); function get_abstract_base_values (Self : access Object) return CORBA.Repository_Root.ValueDefSeq; procedure set_abstract_base_values (Self : access Object; To : CORBA.Repository_Root.ValueDefSeq); function get_is_abstract (Self : access Object) return CORBA.Boolean; procedure set_is_abstract (Self : access Object; To : CORBA.Boolean); function get_is_custom (Self : access Object) return CORBA.Boolean; procedure set_is_custom (Self : access Object; To : CORBA.Boolean); function get_is_truncatable (Self : access Object) return CORBA.Boolean; procedure set_is_truncatable (Self : access Object; To : CORBA.Boolean); function is_a (Self : access Object; id : CORBA.RepositoryId) return CORBA.Boolean; function describe_value (Self : access Object) return CORBA.Repository_Root.ValueDef.FullValueDescription; function create_value_member (Self : access Object; id : CORBA.RepositoryId; name : CORBA.Identifier; version : CORBA.Repository_Root.VersionSpec; IDL_type : CORBA.Repository_Root.IDLType.Ref; IDL_access : CORBA.Visibility) return CORBA.Repository_Root.ValueMemberDef.Ref; function create_attribute (Self : access Object; id : CORBA.RepositoryId; name : CORBA.Identifier; version : CORBA.Repository_Root.VersionSpec; IDL_type_1 : CORBA.Repository_Root.IDLType.Ref; mode : CORBA.Repository_Root.AttributeMode) return CORBA.Repository_Root.AttributeDef.Ref; function create_operation (Self : access Object; id : CORBA.RepositoryId; name : CORBA.Identifier; version : CORBA.Repository_Root.VersionSpec; IDL_result : CORBA.Repository_Root.IDLType.Ref; mode : CORBA.Repository_Root.OperationMode; params : CORBA.Repository_Root.ParDescriptionSeq; exceptions : CORBA.Repository_Root.ExceptionDefSeq; contexts : CORBA.Repository_Root.ContextIdSeq) return CORBA.Repository_Root.OperationDef.Ref; function get_id (Self : access Object) return CORBA.RepositoryId; procedure set_id (Self : access Object; To : CORBA.RepositoryId); function get_name (Self : access Object) return CORBA.Identifier; procedure set_name (Self : access Object; To : CORBA.Identifier); function get_version (Self : access Object) return CORBA.Repository_Root.VersionSpec; procedure set_version (Self : access Object; To : CORBA.Repository_Root.VersionSpec); function get_defined_in (Self : access Object) return CORBA.Repository_Root.Container_Forward.Ref; function get_absolute_name (Self : access Object) return CORBA.ScopedName; function get_containing_repository (Self : access Object) return CORBA.Repository_Root.Repository_Forward.Ref; function describe (Self : access Object) return CORBA.Repository_Root.Contained.Description; procedure move (Self : access Object; new_container : CORBA.Repository_Root.Container_Forward.Ref; new_name : CORBA.Identifier; new_version : CORBA.Repository_Root.VersionSpec); function get_type (Self : access Object) return CORBA.TypeCode.Object; -- Transform the ValueDefSeq into a RepositoryIdSeq function Get_RepositoryIdSeq (ValDefSeq : ValueDefSeq) return RepositoryIdSeq; private type Object is new CORBA.Repository_Root.Container.Impl.Object with record Contained_View : CORBA.Repository_Root.Contained.Impl.Object_Ptr; IDLType_View : CORBA.Repository_Root.IDLType.Impl.Object_Ptr; Supported_Interfaces : CORBA.Repository_Root.InterfaceDefSeq; Initializers : CORBA.Repository_Root.InitializerSeq; Base_Value : CORBA.Repository_Root.ValueDef.Ref; Abstract_Base_Values : CORBA.Repository_Root.ValueDefSeq; Is_Abstract : CORBA.Boolean; Is_Custom : CORBA.Boolean; Is_Truncatable : CORBA.Boolean; end record; end CORBA.Repository_Root.ValueDef.Impl; polyorb-2.8~20110207.orig/cos/ir/corba-repository_root-extabstractinterfacedef-impl.adb0000644000175000017500000001155711750740337030456 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- CORBA.REPOSITORY_ROOT.EXTABSTRACTINTERFACEDEF.IMPL -- -- -- -- B o d y -- -- -- -- Copyright (C) 2006-2008, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with CORBA.Repository_Root.IDLType; with CORBA.Repository_Root.InterfaceAttrExtension; with CORBA.Repository_Root.ExtAbstractInterfaceDef.Skel; pragma Warnings (Off, CORBA.Repository_Root.ExtAbstractInterfaceDef.Skel); package body CORBA.Repository_Root.ExtAbstractInterfaceDef.Impl is -------------------------- -- create_ext_attribute -- -------------------------- function create_ext_attribute (Self : access Object; id : RepositoryId; name : Identifier; version : VersionSpec; IDL_type : IDLType.Ref; mode : AttributeMode; get_exceptions : ExceptionDefSeq; set_exceptions : ExceptionDefSeq) return ExtAttributeDef.Ref is begin return InterfaceAttrExtension.Impl.create_ext_attribute (Self.InterfaceAttrExtension_View, id, name, version, IDL_type, mode, get_exceptions, set_exceptions); end create_ext_attribute; ---------------------------- -- describe_ext_interface -- ---------------------------- function describe_ext_interface (Self : access Object) return InterfaceAttrExtension.ExtFullInterfaceDescription is begin return InterfaceAttrExtension.Impl.describe_ext_interface (Self.InterfaceAttrExtension_View); end describe_ext_interface; package body Internals is ---------- -- Init -- ---------- procedure Init (Self : access Object'Class; Real_Object : IRObject.Impl.Object_Ptr; Def_Kind : DefinitionKind; Id : RepositoryId; Name : Identifier; Version : VersionSpec; Defined_In : Container_Forward.Ref; Contents : Contained.Impl.Contained_Seq.Sequence; Contained_View : Contained.Impl.Object_Ptr; IDLType_View : IDLType.Impl.Object_Ptr; Base_Interfaces : AbstractInterfaceDefSeq; InterfaceAttrExtension_View : InterfaceAttrExtension.Impl.Object_Ptr) is begin AbstractInterfaceDef.Impl.Internals.Init (AbstractInterfaceDef.Impl.Object_Ptr (Self), Real_Object, Def_Kind, Id, Name, Version, Defined_In, Contents, Contained_View, IDLType_View, Base_Interfaces); InterfaceAttrExtension.Impl.Internals.Init (InterfaceAttrExtension_View, Real_Object); Self.InterfaceAttrExtension_View := InterfaceAttrExtension_View; end Init; end Internals; end CORBA.Repository_Root.ExtAbstractInterfaceDef.Impl; polyorb-2.8~20110207.orig/cos/ir/corba-repository_root-interfacedef-impl.ads0000644000175000017500000001662611750740337026234 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- CORBA.REPOSITORY_ROOT.INTERFACEDEF.IMPL -- -- -- -- S p e c -- -- -- -- Copyright (C) 2006-2008, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the CORBA Specification, and adapted -- -- for use with PolyORB. The copyright notice above, and the license -- -- provisions that follow apply solely to the contents neither explicitly -- -- nor implicitly specified by the CORBA Specification defined by the OMG. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with CORBA.Repository_Root.IRObject.Impl; with CORBA.Repository_Root.Contained; with CORBA.Repository_Root.OperationDef; with CORBA.Repository_Root.AttributeDef; with CORBA.Repository_Root.IDLType; with CORBA.Repository_Root.IDLType.Impl; with CORBA.Repository_Root.Contained.Impl; with CORBA.Repository_Root.Container.Impl; package CORBA.Repository_Root.InterfaceDef.Impl is type Object is new CORBA.Repository_Root.Container.Impl.Object with private; type Object_Ptr is access all Object'Class; -- method used to initialize recursively the object fields. procedure Init (Self : access Object; Real_Object : CORBA.Repository_Root.IRObject.Impl.Object_Ptr; Def_Kind : CORBA.Repository_Root.DefinitionKind; Id : CORBA.RepositoryId; Name : CORBA.Identifier; Version : CORBA.Repository_Root.VersionSpec; Defined_In : CORBA.Repository_Root.Container_Forward.Ref; Contents : CORBA.Repository_Root.Contained.Impl.Contained_Seq.Sequence; Contained_View : CORBA.Repository_Root.Contained.Impl.Object_Ptr; IDLType_View : CORBA.Repository_Root.IDLType.Impl.Object_Ptr; Base_Interfaces : CORBA.Repository_Root.InterfaceDefSeq; Is_Abstract : CORBA.Boolean); -- Transform the forward to an impl.object.ptr. function To_Object (Fw_Ref : InterfaceDef_Forward.Ref) return Object_Ptr; -- To transform an object_ptr into Forward_ref function To_Forward (Obj : Object_Ptr) return InterfaceDef_Forward.Ref; -- For multiple inheritance, to access the different views function Get_Contained_View (Self : access Object) return CORBA.Repository_Root.Contained.Impl.Object_Ptr; function Get_IDLType_View (Self : access Object) return CORBA.Repository_Root.IDLType.Impl.Object_Ptr; -- functions inherited from the secondary parents function get_base_interfaces (Self : access Object) return CORBA.Repository_Root.InterfaceDefSeq; procedure set_base_interfaces (Self : access Object; To : CORBA.Repository_Root.InterfaceDefSeq); function get_is_abstract (Self : access Object) return CORBA.Boolean; procedure set_is_abstract (Self : access Object; To : CORBA.Boolean); function is_a (Self : access Object; interface_id : CORBA.RepositoryId) return CORBA.Boolean; function describe_interface (Self : access Object) return CORBA.Repository_Root.InterfaceDef.FullInterfaceDescription; function create_attribute (Self : access Object; id : CORBA.RepositoryId; name : CORBA.Identifier; version : CORBA.Repository_Root.VersionSpec; IDL_type : CORBA.Repository_Root.IDLType.Ref; mode : CORBA.Repository_Root.AttributeMode) return CORBA.Repository_Root.AttributeDef.Ref; function create_operation (Self : access Object; id : CORBA.RepositoryId; name : CORBA.Identifier; version : CORBA.Repository_Root.VersionSpec; IDL_result : CORBA.Repository_Root.IDLType.Ref; mode : CORBA.Repository_Root.OperationMode; params : CORBA.Repository_Root.ParDescriptionSeq; exceptions : CORBA.Repository_Root.ExceptionDefSeq; contexts : CORBA.Repository_Root.ContextIdSeq) return CORBA.Repository_Root.OperationDef.Ref; function get_id (Self : access Object) return CORBA.RepositoryId; procedure set_id (Self : access Object; To : CORBA.RepositoryId); function get_name (Self : access Object) return CORBA.Identifier; procedure set_name (Self : access Object; To : CORBA.Identifier); function get_version (Self : access Object) return CORBA.Repository_Root.VersionSpec; procedure set_version (Self : access Object; To : CORBA.Repository_Root.VersionSpec); function get_defined_in (Self : access Object) return CORBA.Repository_Root.Container_Forward.Ref; function get_absolute_name (Self : access Object) return CORBA.ScopedName; function get_containing_repository (Self : access Object) return CORBA.Repository_Root.Repository_Forward.Ref; function describe (Self : access Object) return CORBA.Repository_Root.Contained.Description; procedure move (Self : access Object; new_container : CORBA.Repository_Root.Container_Forward.Ref; new_name : CORBA.Identifier; new_version : CORBA.Repository_Root.VersionSpec); function get_type (Self : access Object) return CORBA.TypeCode.Object; -- Transform an InterfaceDefSeq into a RepositoryIdSeq function Get_RepositoryIdSeq (IntDefSeq : InterfaceDefSeq) return RepositoryIdSeq; private type Object is new CORBA.Repository_Root.Container.Impl.Object with record Contained_View : CORBA.Repository_Root.Contained.Impl.Object_Ptr; IDLType_View : CORBA.Repository_Root.IDLType.Impl.Object_Ptr; Base_Interfaces : CORBA.Repository_Root.InterfaceDefSeq; Is_Abstract : CORBA.Boolean; end record; end CORBA.Repository_Root.InterfaceDef.Impl; polyorb-2.8~20110207.orig/cos/ir/corba-repository_root-attributedef-impl.ads0000644000175000017500000001034311750740337026265 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- CORBA.REPOSITORY_ROOT.ATTRIBUTEDEF.IMPL -- -- -- -- S p e c -- -- -- -- Copyright (C) 2006-2008, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the CORBA Specification, and adapted -- -- for use with PolyORB. The copyright notice above, and the license -- -- provisions that follow apply solely to the contents neither explicitly -- -- nor implicitly specified by the CORBA Specification defined by the OMG. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with CORBA.Repository_Root.IDLType; with CORBA.Repository_Root.IRObject.Impl; with CORBA.Repository_Root.Contained.Impl; package CORBA.Repository_Root.AttributeDef.Impl is type Object is new CORBA.Repository_Root.Contained.Impl.Object with private; type Object_Ptr is access all Object'Class; -- method used to initialize recursively the object fields. procedure Init (Self : access Object; Real_Object : CORBA.Repository_Root.IRObject.Impl.Object_Ptr; Def_Kind : CORBA.Repository_Root.DefinitionKind; Id : CORBA.RepositoryId; Name : CORBA.Identifier; Version : CORBA.Repository_Root.VersionSpec; Defined_In : CORBA.Repository_Root.Container_Forward.Ref; Type_Def : CORBA.Repository_Root.IDLType.Ref; Mode : CORBA.Repository_Root.AttributeMode); function get_type (Self : access Object) return CORBA.TypeCode.Object; function get_type_def (Self : access Object) return CORBA.Repository_Root.IDLType.Ref; procedure set_type_def (Self : access Object; To : CORBA.Repository_Root.IDLType.Ref); function get_mode (Self : access Object) return CORBA.Repository_Root.AttributeMode; procedure set_mode (Self : access Object; To : CORBA.Repository_Root.AttributeMode); -- override this from contained function describe (Self : access Object) return CORBA.Repository_Root.Contained.Description; private type Object is new CORBA.Repository_Root.Contained.Impl.Object with record -- the IDL_Type is the type of the type_def Type_Def : CORBA.Repository_Root.IDLType.Ref; Mode : CORBA.Repository_Root.AttributeMode; end record; end CORBA.Repository_Root.AttributeDef.Impl; polyorb-2.8~20110207.orig/cos/ir/corba-repository_root-nativedef-impl.ads0000644000175000017500000000637611750740337025563 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- CORBA.REPOSITORY_ROOT.NATIVEDEF.IMPL -- -- -- -- S p e c -- -- -- -- Copyright (C) 2006-2008, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the CORBA Specification, and adapted -- -- for use with PolyORB. The copyright notice above, and the license -- -- provisions that follow apply solely to the contents neither explicitly -- -- nor implicitly specified by the CORBA Specification defined by the OMG. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with CORBA.Repository_Root.TypedefDef.Impl; package CORBA.Repository_Root.NativeDef.Impl is type Object is new CORBA.Repository_Root.TypedefDef.Impl.Object with private; type Object_Ptr is access all Object'Class; -- Transform the forward to an impl.object.ptr. function To_Object (Fw_Ref : NativeDef_Forward.Ref) return Object_Ptr; -- To transform an object_ptr into Forward_ref function To_Forward (Obj : Object_Ptr) return NativeDef_Forward.Ref; -- overload the get_type from IDLType function get_type (Self : access Object) return CORBA.TypeCode.Object; private type Object is new CORBA.Repository_Root.TypedefDef.Impl.Object with null record; -- Insert components to hold the state -- of the implementation object. end CORBA.Repository_Root.NativeDef.Impl; polyorb-2.8~20110207.orig/cos/ir/corba-repository_root-primitivedef-impl.adb0000644000175000017500000000620411750740337026252 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- CORBA.REPOSITORY_ROOT.PRIMITIVEDEF.IMPL -- -- -- -- B o d y -- -- -- -- Copyright (C) 2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with CORBA.Repository_Root.PrimitiveDef.Skel; pragma Warnings (Off, CORBA.Repository_Root.PrimitiveDef.Skel); package body CORBA.Repository_Root.PrimitiveDef.Impl is ---------------------- -- Procedure init -- ---------------------- procedure Init (Self : access Object; Real_Object : IRObject.Impl.Object_Ptr; Def_Kind : CORBA.Repository_Root.DefinitionKind; IDL_Type : CORBA.TypeCode.Object; Kind : CORBA.Repository_Root.PrimitiveKind) is begin IDLType.Impl.Init (IDLType.Impl.Object_Ptr (Self), Real_Object, Def_Kind); Self.Kind := Kind; Self.IDL_Type := IDL_Type; end Init; ---------------- -- get_type -- ---------------- function get_type (Self : access Object) return CORBA.TypeCode.Object is begin return Self.IDL_Type; end get_type; function get_kind (Self : access Object) return CORBA.Repository_Root.PrimitiveKind is begin return Self.Kind; end get_kind; end CORBA.Repository_Root.PrimitiveDef.Impl; polyorb-2.8~20110207.orig/cos/ir/corba-repository_root-moduledef-impl.ads0000644000175000017500000001215711750740337025554 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- CORBA.REPOSITORY_ROOT.MODULEDEF.IMPL -- -- -- -- S p e c -- -- -- -- Copyright (C) 2006-2008, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the CORBA Specification, and adapted -- -- for use with PolyORB. The copyright notice above, and the license -- -- provisions that follow apply solely to the contents neither explicitly -- -- nor implicitly specified by the CORBA Specification defined by the OMG. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with CORBA.Repository_Root.Contained; with CORBA.Repository_Root.IRObject.Impl; with CORBA.Repository_Root.Contained.Impl; with CORBA.Repository_Root.Container.Impl; package CORBA.Repository_Root.ModuleDef.Impl is type Object is new CORBA.Repository_Root.Container.Impl.Object with private; type Object_Ptr is access all Object'Class; -- To transform a forward_ref in impl.object_ptr. function To_Object (Fw_Ref : ModuleDef_Forward.Ref) return Object_Ptr; -- To transform an object_ptr into Forward_ref function To_Forward (Obj : Object_Ptr) return ModuleDef_Forward.Ref; -- method used to initialize recursively the object fields. procedure Init (Self : access Object; Real_Object : CORBA.Repository_Root.IRObject.Impl.Object_Ptr; Def_Kind : CORBA.Repository_Root.DefinitionKind; Id : CORBA.RepositoryId; Name : CORBA.Identifier; Version : CORBA.Repository_Root.VersionSpec; Defined_In : CORBA.Repository_Root.Container_Forward.Ref; Contents : CORBA.Repository_Root.Contained.Impl.Contained_Seq.Sequence; Contained_View : CORBA.Repository_Root.Contained.Impl.Object_Ptr); -- For multiple inheritance, to access the different views function Get_Contained_View (Self : access Object) return CORBA.Repository_Root.Contained.Impl.Object_Ptr; function get_id (Self : access Object) return CORBA.RepositoryId; procedure set_id (Self : access Object; To : CORBA.RepositoryId); function get_name (Self : access Object) return CORBA.Identifier; procedure set_name (Self : access Object; To : CORBA.Identifier); function get_version (Self : access Object) return CORBA.Repository_Root.VersionSpec; procedure set_version (Self : access Object; To : CORBA.Repository_Root.VersionSpec); function get_defined_in (Self : access Object) return CORBA.Repository_Root.Container_Forward.Ref; function get_absolute_name (Self : access Object) return CORBA.ScopedName; function get_containing_repository (Self : access Object) return CORBA.Repository_Root.Repository_Forward.Ref; function describe (Self : access Object) return CORBA.Repository_Root.Contained.Description; procedure move (Self : access Object; new_container : CORBA.Repository_Root.Container_Forward.Ref; new_name : CORBA.Identifier; new_version : CORBA.Repository_Root.VersionSpec); private type Object is new CORBA.Repository_Root.Container.Impl.Object with record Contained_View : CORBA.Repository_Root.Contained.Impl.Object_Ptr; end record; end CORBA.Repository_Root.ModuleDef.Impl; polyorb-2.8~20110207.orig/cos/ir/corba-repository_root-structdef-impl.ads0000644000175000017500000002437511750740337025620 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- CORBA.REPOSITORY_ROOT.STRUCTDEF.IMPL -- -- -- -- S p e c -- -- -- -- Copyright (C) 2006-2008, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the CORBA Specification, and adapted -- -- for use with PolyORB. The copyright notice above, and the license -- -- provisions that follow apply solely to the contents neither explicitly -- -- nor implicitly specified by the CORBA Specification defined by the OMG. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with CORBA.Repository_Root.Container; with CORBA.Repository_Root.Contained; with CORBA.Repository_Root.Contained.Impl; with CORBA.Repository_Root.IRObject.Impl; with CORBA.Repository_Root.IDLType.Impl; with CORBA.Repository_Root.Container.Impl; with CORBA.Repository_Root.TypedefDef.Impl; package CORBA.Repository_Root.StructDef.Impl is type Object is new CORBA.Repository_Root.TypedefDef.Impl.Object with private; type Object_Ptr is access all Object'Class; -- To transform a forward_ref in impl.object_ptr. function To_Object (Fw_Ref : StructDef_Forward.Ref) return Object_Ptr; -- To transform an object_ptr into Forward_ref function To_Forward (Obj : Object_Ptr) return StructDef_Forward.Ref; -- method used to initialize recursively the object fields. procedure Init (Self : access Object; Real_Object : CORBA.Repository_Root.IRObject.Impl.Object_Ptr; Def_Kind : CORBA.Repository_Root.DefinitionKind; Id : CORBA.RepositoryId; Name : CORBA.Identifier; Version : CORBA.Repository_Root.VersionSpec; Defined_In : CORBA.Repository_Root.Container_Forward.Ref; IDLType_View : CORBA.Repository_Root.IDLType.Impl.Object_Ptr; Contents : CORBA.Repository_Root.Contained.Impl.Contained_Seq.Sequence; Container_View : CORBA.Repository_Root.Container.Impl.Object_Ptr; Members : CORBA.Repository_Root.StructMemberSeq); -- For multiple inheritance, to access the different views function Get_Container_View (Self : access Object) return CORBA.Repository_Root.Container.Impl.Object_Ptr; -- Set the members attribute while putting the "type" field -- of the member to TC_Void procedure Initialize_Members (Self : access Object; Seq : StructMemberSeq); -- overload the get_type from IDLType function get_type (Self : access Object) return CORBA.TypeCode.Object; function get_members (Self : access Object) return CORBA.Repository_Root.StructMemberSeq; procedure set_members (Self : access Object; To : CORBA.Repository_Root.StructMemberSeq); function lookup (Self : access Object; search_name : CORBA.ScopedName) return CORBA.Repository_Root.Contained.Ref; function contents (Self : access Object; limit_type : CORBA.Repository_Root.DefinitionKind; exclude_inherited : CORBA.Boolean) return CORBA.Repository_Root.ContainedSeq; function lookup_name (Self : access Object; search_name : CORBA.Identifier; levels_to_search : CORBA.Long; limit_type : CORBA.Repository_Root.DefinitionKind; exclude_inherited : CORBA.Boolean) return CORBA.Repository_Root.ContainedSeq; function describe_contents (Self : access Object; limit_type : CORBA.Repository_Root.DefinitionKind; exclude_inherited : CORBA.Boolean; max_returned_objs : CORBA.Long) return CORBA.Repository_Root.Container.DescriptionSeq; function create_module (Self : access Object; id : CORBA.RepositoryId; name : CORBA.Identifier; version : CORBA.Repository_Root.VersionSpec) return CORBA.Repository_Root.ModuleDef_Forward.Ref; function create_constant (Self : access Object; id : CORBA.RepositoryId; name : CORBA.Identifier; version : CORBA.Repository_Root.VersionSpec; IDL_type : CORBA.Repository_Root.IDLType_Forward.Ref; value : CORBA.Any) return CORBA.Repository_Root.ConstantDef_Forward.Ref; function create_struct (Self : access Object; id : CORBA.RepositoryId; name : CORBA.Identifier; version : CORBA.Repository_Root.VersionSpec; members : CORBA.Repository_Root.StructMemberSeq) return CORBA.Repository_Root.StructDef_Forward.Ref; function create_union (Self : access Object; id : CORBA.RepositoryId; name : CORBA.Identifier; version : CORBA.Repository_Root.VersionSpec; discriminator_type : CORBA.Repository_Root.IDLType_Forward.Ref; members : CORBA.Repository_Root.UnionMemberSeq) return CORBA.Repository_Root.UnionDef_Forward.Ref; function create_enum (Self : access Object; id : CORBA.RepositoryId; name : CORBA.Identifier; version : CORBA.Repository_Root.VersionSpec; members : CORBA.Repository_Root.EnumMemberSeq) return CORBA.Repository_Root.EnumDef_Forward.Ref; function create_alias (Self : access Object; id : CORBA.RepositoryId; name : CORBA.Identifier; version : CORBA.Repository_Root.VersionSpec; original_type : CORBA.Repository_Root.IDLType_Forward.Ref) return CORBA.Repository_Root.AliasDef_Forward.Ref; function create_interface (Self : access Object; id : CORBA.RepositoryId; name : CORBA.Identifier; version : CORBA.Repository_Root.VersionSpec; base_interfaces : CORBA.Repository_Root.InterfaceDefSeq; is_abstract : CORBA.Boolean) return CORBA.Repository_Root.InterfaceDef_Forward.Ref; function create_value (Self : access Object; id : CORBA.RepositoryId; name : CORBA.Identifier; version : CORBA.Repository_Root.VersionSpec; is_custom : CORBA.Boolean; is_abstract : CORBA.Boolean; base_value : CORBA.Repository_Root.ValueDef_Forward.Ref; is_truncatable : CORBA.Boolean; abstract_base_values : CORBA.Repository_Root.ValueDefSeq; supported_interfaces : CORBA.Repository_Root.InterfaceDefSeq; initializers : CORBA.Repository_Root.InitializerSeq) return CORBA.Repository_Root.ValueDef_Forward.Ref; function create_value_box (Self : access Object; id : CORBA.RepositoryId; name : CORBA.Identifier; version : CORBA.Repository_Root.VersionSpec; original_type_def : CORBA.Repository_Root.IDLType_Forward.Ref) return CORBA.Repository_Root.ValueBoxDef_Forward.Ref; function create_exception (Self : access Object; id : CORBA.RepositoryId; name : CORBA.Identifier; version : CORBA.Repository_Root.VersionSpec; members : CORBA.Repository_Root.StructMemberSeq) return CORBA.Repository_Root.ExceptionDef_Forward.Ref; function create_native (Self : access Object; id : CORBA.RepositoryId; name : CORBA.Identifier; version : CORBA.Repository_Root.VersionSpec) return CORBA.Repository_Root.NativeDef_Forward.Ref; function create_abstract_interface (Self : access Object; id : RepositoryId; name : Identifier; version : VersionSpec; base_interfaces : AbstractInterfaceDefSeq) return AbstractInterfaceDef_Forward.Ref; function create_local_interface (Self : access Object; id : RepositoryId; name : Identifier; version : VersionSpec; base_interfaces : InterfaceDefSeq) return LocalInterfaceDef_Forward.Ref; -- Implementation Notes: create_ext_value commented out because of error -- in idlac/ALM (see CORBA_InterfaceRepository.idl) -- function create_ext_value -- (Self : access Object; -- id : RepositoryId; -- name : Identifier; -- version : VersionSpec; -- is_custom : CORBA.Boolean; -- is_abstract : CORBA.Boolean; -- base_value : ValueDef_Forward.Ref; -- is_truncatable : CORBA.Boolean; -- abstract_base_values : ValueDefSeq; -- supported_interfaces : InterfaceDefSeq; -- initializers : ExtInitializerSeq) -- return ExtValueDef_Forward.Ref; private type Object is new CORBA.Repository_Root.TypedefDef.Impl.Object with record Container_View : CORBA.Repository_Root.Container.Impl.Object_Ptr; Members : CORBA.Repository_Root.StructMemberSeq; end record; end CORBA.Repository_Root.StructDef.Impl; polyorb-2.8~20110207.orig/cos/ir/corba-repository_root-valuememberdef-impl.ads0000644000175000017500000001025311750740337026566 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- CORBA.REPOSITORY_ROOT.VALUEMEMBERDEF.IMPL -- -- -- -- S p e c -- -- -- -- Copyright (C) 2006-2008, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the CORBA Specification, and adapted -- -- for use with PolyORB. The copyright notice above, and the license -- -- provisions that follow apply solely to the contents neither explicitly -- -- nor implicitly specified by the CORBA Specification defined by the OMG. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with CORBA.Repository_Root.IDLType; with CORBA.Repository_Root.IRObject.Impl; with CORBA.Repository_Root.Contained.Impl; package CORBA.Repository_Root.ValueMemberDef.Impl is type Object is new CORBA.Repository_Root.Contained.Impl.Object with private; type Object_Ptr is access all Object'Class; -- method used to initialize recursively the object fields. procedure Init (Self : access Object; Real_Object : CORBA.Repository_Root.IRObject.Impl.Object_Ptr; Def_Kind : CORBA.Repository_Root.DefinitionKind; Id : CORBA.RepositoryId; Name : CORBA.Identifier; Version : CORBA.Repository_Root.VersionSpec; Defined_In : CORBA.Repository_Root.Container_Forward.Ref; Type_Def : CORBA.Repository_Root.IDLType.Ref; IDL_Access : CORBA.Visibility); function get_type (Self : access Object) return CORBA.TypeCode.Object; function get_type_def (Self : access Object) return CORBA.Repository_Root.IDLType.Ref; procedure set_type_def (Self : access Object; To : CORBA.Repository_Root.IDLType.Ref); function get_access (Self : access Object) return CORBA.Visibility; procedure set_access (Self : access Object; To : CORBA.Visibility); -- override this from contained function describe (Self : access Object) return CORBA.Repository_Root.Contained.Description; private type Object is new CORBA.Repository_Root.Contained.Impl.Object with record -- the IDL_Type is the type of the type_def Type_Def : CORBA.Repository_Root.IDLType.Ref; IDL_Access : CORBA.Visibility; end record; end CORBA.Repository_Root.ValueMemberDef.Impl; polyorb-2.8~20110207.orig/cos/ir/corba-repository_root-extabstractinterfacedef-impl.ads0000644000175000017500000001062011750740337030465 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- CORBA.REPOSITORY_ROOT.EXTABSTRACTINTERFACEDEF.IMPL -- -- -- -- S p e c -- -- -- -- Copyright (C) 2006-2008, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the CORBA Specification, and adapted -- -- for use with PolyORB. The copyright notice above, and the license -- -- provisions that follow apply solely to the contents neither explicitly -- -- nor implicitly specified by the CORBA Specification defined by the OMG. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with CORBA.Repository_Root.Contained.Impl; with CORBA.Repository_Root.ExtAttributeDef; with CORBA.Repository_Root.IDLType.Impl; with CORBA.Repository_Root.InterfaceAttrExtension.Impl; with CORBA.Repository_Root.IRObject.Impl; with CORBA.Repository_Root.AbstractInterfaceDef.Impl; package CORBA.Repository_Root.ExtAbstractInterfaceDef.Impl is type Object is new AbstractInterfaceDef.Impl.Object with private; type Object_Ptr is access all Object'Class; function describe_ext_interface (Self : access Object) return InterfaceAttrExtension.ExtFullInterfaceDescription; function create_ext_attribute (Self : access Object; id : RepositoryId; name : Identifier; version : VersionSpec; IDL_type : IDLType.Ref; mode : AttributeMode; get_exceptions : ExceptionDefSeq; set_exceptions : ExceptionDefSeq) return ExtAttributeDef.Ref; package Internals is procedure Init (Self : access Object'Class; Real_Object : IRObject.Impl.Object_Ptr; Def_Kind : DefinitionKind; Id : RepositoryId; Name : Identifier; Version : VersionSpec; Defined_In : Container_Forward.Ref; Contents : Contained.Impl.Contained_Seq.Sequence; Contained_View : Contained.Impl.Object_Ptr; IDLType_View : IDLType.Impl.Object_Ptr; Base_Interfaces : AbstractInterfaceDefSeq; InterfaceAttrExtension_View : InterfaceAttrExtension.Impl.Object_Ptr); -- Recursively initialize object fields end Internals; private type Object is new AbstractInterfaceDef.Impl.Object with record InterfaceAttrExtension_View : InterfaceAttrExtension.Impl.Object_Ptr; end record; end CORBA.Repository_Root.ExtAbstractInterfaceDef.Impl; polyorb-2.8~20110207.orig/cos/ir/corba-repository_root-contained-impl.ads0000644000175000017500000001703511750740337025554 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- CORBA.REPOSITORY_ROOT.CONTAINED.IMPL -- -- -- -- S p e c -- -- -- -- Copyright (C) 2006-2008, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the CORBA Specification, and adapted -- -- for use with PolyORB. The copyright notice above, and the license -- -- provisions that follow apply solely to the contents neither explicitly -- -- nor implicitly specified by the CORBA Specification defined by the OMG. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with CORBA.Repository_Root.IRObject.Impl; with PolyORB.Sequences.Unbounded; package CORBA.Repository_Root.Contained.Impl is type Object is new CORBA.Repository_Root.IRObject.Impl.Object with private; type Object_Ptr is access all Object'Class; -- method used to initialize recursively the object fields. procedure Init (Self : access Object; Real_Object : CORBA.Repository_Root.IRObject.Impl.Object_Ptr; Def_Kind : CORBA.Repository_Root.DefinitionKind; Id : CORBA.RepositoryId; Name : CORBA.Identifier; Version : CORBA.Repository_Root.VersionSpec; Defined_In : CORBA.Repository_Root.Container_Forward.Ref); -- Transform the forward to an impl.object.ptr. function To_Object (Fw_Ref : Contained_Forward.Ref) return Object_Ptr; -- To transform an object_ptr into Forward_ref function To_Forward (Obj : Object_Ptr) return Contained_Forward.Ref; -- usefull for the multiple inhertance -- transform an IRObject to a container -- success is true if it is possible procedure To_Contained (Self : CORBA.Repository_Root.IRObject.Impl.Object_Ptr; Success : out Boolean; Result : out Object_Ptr); -- should only be called if the cast is safe! function To_Contained (Self : CORBA.Repository_Root.IRObject.Impl.Object_Ptr) return Object_Ptr; function get_id (Self : access Object) return CORBA.RepositoryId; procedure set_id (Self : access Object; To : CORBA.RepositoryId); function get_name (Self : access Object) return CORBA.Identifier; procedure set_name (Self : access Object; To : CORBA.Identifier); function get_version (Self : access Object) return CORBA.Repository_Root.VersionSpec; procedure set_version (Self : access Object; To : CORBA.Repository_Root.VersionSpec); function get_defined_in (Self : access Object) return CORBA.Repository_Root.Container_Forward.Ref; function get_defined_in (Self : access Object) return CORBA.RepositoryId; -- XXX This attribute not defined in IR IDL function get_absolute_name (Self : access Object) return CORBA.ScopedName; function get_containing_repository (Self : access Object) return CORBA.Repository_Root.Repository_Forward.Ref; function describe (Self : access Object) return CORBA.Repository_Root.Contained.Description; procedure move (Self : access Object; new_container : CORBA.Repository_Root.Container_Forward.Ref; new_name : CORBA.Identifier; new_version : CORBA.Repository_Root.VersionSpec); ------------------------------------ -- A useful sequence of contained -- ------------------------------------ -- This package is used to store the content of the container. -- It is better to store the Objct_ptr instead of the ref_forward -- as it is declared in the corba.Repository_Root module. package Contained_Seq is new PolyORB.Sequences.Unbounded (Object_Ptr); -- return null if RepId not found in In_Seq function Lookup_Id (In_Seq : Contained_Seq.Sequence; Search_Id : CORBA.RepositoryId) return Object_Ptr; -- Look for the given scopedName in the Sequence. -- Returns nil object reference if not found. -- The Name should not begin with :: function Lookup_ScopedName (In_Seq : Contained_Seq.Sequence; Name : ScopedName) return Object_Ptr; -- Look for the given name in the given contained sequence -- Check also if the definition_kind correspond to the limit -- Returns the result in a ContainedSeq function Lookup_Name (In_Seq : Contained_Seq.Sequence; Name : Identifier; Limit_Type : DefinitionKind) return ContainedSeq; -- This function returns the In_Seq as containedSeq if limit_type is dk_all -- else it returns the specific limit_type containeds within In_Seq. function Contents (In_Seq : Contained_Seq.Sequence; Limit_Type : DefinitionKind) return ContainedSeq; -- This procedure removes the twins procedure Simplify_ContainedSeq (In_Seq : in out ContainedSeq); function To_ContainedSeq (In_Seq : Contained_Seq.Sequence) return CORBA.Repository_Root.ContainedSeq; -- Transform a Contained_Seq.Sequence into a ContainedSeq function To_Contained_Sequence (In_Seq : ContainedSeq) return Contained_Seq.Sequence; -- Transform a Contained_Seq.Sequence into a ContainedSeq procedure Print_Content (In_Seq : Contained_Seq.Sequence; Inc : Standard.String); -- Dump recursively a contained_seq.sequence private type Object is new CORBA.Repository_Root.IRObject.Impl.Object with record Id : CORBA.RepositoryId; Name : CORBA.Identifier; Version : CORBA.Repository_Root.VersionSpec; Defined_In : CORBA.Repository_Root.Container_Forward.Ref; end record; end CORBA.Repository_Root.Contained.Impl; polyorb-2.8~20110207.orig/cos/notification/0000755000175000017500000000000011750740340017654 5ustar xavierxavierpolyorb-2.8~20110207.orig/cos/notification/cosnotifychanneladmin-sequenceproxypushconsumer-impl.adb0000644000175000017500000006237011750740337033244 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- COSNOTIFYCHANNELADMIN.SEQUENCEPROXYPUSHCONSUMER.IMPL -- -- -- -- B o d y -- -- -- -- Copyright (C) 2003-2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with CosEventChannelAdmin.Helper; with CosNotification; with CosNotification.Helper; with CosNotifyChannelAdmin.SupplierAdmin.Impl; with PolyORB.CORBA_P.Server_Tools; with PolyORB.Log; with PolyORB.Tasking.Mutexes; with CosNotifyChannelAdmin.SequenceProxyPushConsumer.Skel; pragma Warnings (Off, CosNotifyChannelAdmin.SequenceProxyPushConsumer.Skel); package body CosNotifyChannelAdmin.SequenceProxyPushConsumer.Impl is use CosNotification; use IDL_SEQUENCE_CosNotification_Property; use IDL_SEQUENCE_CosNotification_PropertyError; use IDL_SEQUENCE_CosNotification_NamedPropertyRange; use CORBA; use PortableServer; package Convert is new SupplierAdmin_Forward.Convert (CosNotifyChannelAdmin.SupplierAdmin.Ref); use PolyORB.CORBA_P.Server_Tools; use PolyORB.Tasking.Mutexes; use PolyORB.Log; package L is new PolyORB.Log.Facility_Log ("sequenceproxypushconsumer"); procedure O (Message : Standard.String; Level : Log_Level := Debug) renames L.Output; function C (Level : Log_Level := Debug) return Boolean renames L.Enabled; pragma Unreferenced (C); -- For conditional pragma Debug type Sequence_Proxy_Push_Consumer_Record is record This : Object_Ptr; Admin : CosNotifyChannelAdmin.SupplierAdmin.Ref; MyId : CosNotifyChannelAdmin.ProxyID; MyType : CosNotifyChannelAdmin.ProxyType; Peer : CosNotifyComm.SequencePushSupplier.Ref; QoSPropSeq : CosNotification.QoSProperties; end record; --------------------------- -- Ensure_Initialization -- --------------------------- procedure Ensure_Initialization; pragma Inline (Ensure_Initialization); -- Ensure that the Mutexes are initialized T_Initialized : Boolean := False; Self_Mutex : Mutex_Access; procedure Ensure_Initialization is begin if not T_Initialized then Create (Self_Mutex); T_Initialized := True; end if; end Ensure_Initialization; ------------------------------------ -- Connect_Sequence_Push_Supplier -- ------------------------------------ procedure Connect_Sequence_Push_Supplier (Self : access Object; Push_Supplier : CosNotifyComm.SequencePushSupplier.Ref) is begin Ensure_Initialization; pragma Debug (O ("connect_sequence_push_supplier in sequenceproxypushconsumer")); Enter (Self_Mutex); if not CosNotifyComm.SequencePushSupplier.Is_Nil (Self.X.Peer) then Leave (Self_Mutex); CosEventChannelAdmin.Helper.Raise_AlreadyConnected ((CORBA.IDL_Exception_Members with null record)); end if; Self.X.Peer := Push_Supplier; Leave (Self_Mutex); end Connect_Sequence_Push_Supplier; ---------------- -- Get_MyType -- ---------------- function Get_MyType (Self : access Object) return CosNotifyChannelAdmin.ProxyType is MyType : CosNotifyChannelAdmin.ProxyType; begin Ensure_Initialization; pragma Debug (O ("get_mytype in sequenceproxypushconsumer")); Enter (Self_Mutex); MyType := Self.X.MyType; Leave (Self_Mutex); return MyType; end Get_MyType; ----------------- -- Get_MyAdmin -- ----------------- function Get_MyAdmin (Self : access Object) return CosNotifyChannelAdmin.SupplierAdmin_Forward.Ref is MyAdmin : CosNotifyChannelAdmin.SupplierAdmin_Forward.Ref; begin Ensure_Initialization; pragma Debug (O ("get_myadmin in sequenceproxypushconsumer")); Enter (Self_Mutex); MyAdmin := Convert.To_Forward (Self.X.Admin); Leave (Self_Mutex); return MyAdmin; end Get_MyAdmin; ------------------------------- -- Obtain_Subscription_Types -- ------------------------------- function Obtain_Subscription_Types (Self : access Object; Mode : CosNotifyChannelAdmin.ObtainInfoMode) return CosNotification.EventTypeSeq is pragma Warnings (Off); -- WAG:3.14 pragma Unreferenced (Self, Mode); pragma Warnings (On); -- WAG:3.14 MySeq : CosNotification.EventTypeSeq; begin Ensure_Initialization; pragma Debug (O ("obtain_subscription_types in sequenceproxypushconsumer")); Enter (Self_Mutex); Leave (Self_Mutex); return MySeq; end Obtain_Subscription_Types; ------------------------ -- Validate_Event_QoS -- ------------------------ procedure Validate_Event_QoS (Self : access Object; Required_QoS : CosNotification.QoSProperties; Available_QoS : out CosNotification.NamedPropertyRangeSeq) is pragma Warnings (Off); -- WAG:3.14 pragma Unreferenced (Self, Required_QoS, Available_QoS); pragma Warnings (On); -- WAG:3.14 begin Ensure_Initialization; pragma Debug (O ("validate_event_qos in sequenceproxypushconsumer")); Enter (Self_Mutex); Leave (Self_Mutex); end Validate_Event_QoS; ------------- -- Get_QoS -- ------------- function Get_QoS (Self : access Object) return CosNotification.QoSProperties is MyQoS : CosNotification.QoSProperties; begin Ensure_Initialization; pragma Debug (O ("get_qos in sequenceproxypushconsumer")); Enter (Self_Mutex); MyQoS := Self.X.QoSPropSeq; Leave (Self_Mutex); return MyQoS; end Get_QoS; ------------- -- Set_QoS -- ------------- procedure Set_QoS (Self : access Object; QoS : CosNotification.QoSProperties) is MyProp : CosNotification.Property; MyError : CosNotification.PropertyError; MyErrCode : CosNotification.QoSError_code; MyRange : CosNotification.PropertyRange; MyErrorSeq : CosNotification.PropertyErrorSeq; SeqLen : Integer; begin Ensure_Initialization; pragma Debug (O ("set_qos in sequenceproxypushconsumer")); SeqLen := Length (QoS); for Index in 1 .. SeqLen loop MyProp := Get_Element (QoS, Index); if MyProp.name = "EventReliability" then MyErrCode := UNAVAILABLE_PROPERTY; MyRange := (To_Any (CORBA.Short (0)), To_Any (CORBA.Short (0))); MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); elsif MyProp.name = "ConnectionReliability" then if CORBA.Short'(From_Any (MyProp.value)) /= 0 and then CORBA.Short'(From_Any (MyProp.value)) /= 1 then MyErrCode := BAD_VALUE; MyRange := (To_Any (CORBA.Short (0)), To_Any (CORBA.Short (0))); MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); end if; elsif MyProp.name = "Priority" then if CORBA.Short'(From_Any (MyProp.value)) not in -32_767 .. 32_767 then MyErrCode := BAD_VALUE; MyRange := (To_Any (CORBA.Short (-32767)), To_Any (CORBA.Short (32767))); MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); end if; elsif MyProp.name = "StartTime" then MyErrCode := UNAVAILABLE_PROPERTY; MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); elsif MyProp.name = "StopTime" then MyErrCode := UNAVAILABLE_PROPERTY; MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); elsif MyProp.name = "Timeout" then MyErrCode := UNSUPPORTED_PROPERTY; MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); elsif MyProp.name = "OrderPolicy" then if CORBA.Short'(From_Any (MyProp.value)) /= 0 and then CORBA.Short'(From_Any (MyProp.value)) /= 1 and then CORBA.Short'(From_Any (MyProp.value)) /= 2 and then CORBA.Short'(From_Any (MyProp.value)) /= 3 then MyErrCode := BAD_VALUE; MyRange := (To_Any (CORBA.Short (0)), To_Any (CORBA.Short (3))); MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); end if; elsif MyProp.name = "DiscardPolicy" then if CORBA.Short'(From_Any (MyProp.value)) /= 0 and then CORBA.Short'(From_Any (MyProp.value)) /= 1 and then CORBA.Short'(From_Any (MyProp.value)) /= 2 and then CORBA.Short'(From_Any (MyProp.value)) /= 3 and then CORBA.Short'(From_Any (MyProp.value)) /= 4 then MyErrCode := BAD_VALUE; MyRange := (To_Any (CORBA.Short (0)), To_Any (CORBA.Short (4))); MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); end if; elsif MyProp.name = "MaximumBatchSize" then MyErrCode := UNSUPPORTED_PROPERTY; MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); elsif MyProp.name = "PacingInterval" then MyErrCode := UNSUPPORTED_PROPERTY; MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); elsif MyProp.name = "StartTimeSupported" then MyErrCode := UNSUPPORTED_PROPERTY; MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); elsif MyProp.name = "StopTimeSupported" then MyErrCode := UNSUPPORTED_PROPERTY; MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); elsif MyProp.name = "MaxEventsPerConsumer" then MyErrCode := UNSUPPORTED_PROPERTY; MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); else MyErrCode := BAD_PROPERTY; MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); end if; end loop; if Length (MyErrorSeq) > 0 then CosNotification.Helper.Raise_UnsupportedQoS ((CORBA.IDL_Exception_Members with qos_err => MyErrorSeq)); end if; SeqLen := Length (QoS); Enter (Self_Mutex); for Index in 1 .. SeqLen loop MyProp := Get_Element (QoS, Index); if MyProp.name = "ConnectionReliability" then Replace_Element (Self.X.QoSPropSeq, 2, MyProp); elsif MyProp.name = "Priority" then Replace_Element (Self.X.QoSPropSeq, 3, MyProp); elsif MyProp.name = "OrderPolicy" then Replace_Element (Self.X.QoSPropSeq, 4, MyProp); elsif MyProp.name = "DiscardPolicy" then Replace_Element (Self.X.QoSPropSeq, 5, MyProp); end if; end loop; Leave (Self_Mutex); end Set_QoS; ------------------ -- Validate_QoS -- ------------------ procedure Validate_QoS (Self : access Object; Required_QoS : CosNotification.QoSProperties; Available_QoS : out CosNotification.NamedPropertyRangeSeq) is MyProp : CosNotification.Property; MyError : CosNotification.PropertyError; MyErrCode : CosNotification.QoSError_code; MyNamedRange : CosNotification.NamedPropertyRange; MyRange : CosNotification.PropertyRange; MyErrorSeq : CosNotification.PropertyErrorSeq; SeqLen : Integer; begin Ensure_Initialization; pragma Debug (O ("validate_qos in sequenceproxypushconsumer")); SeqLen := Length (Required_QoS); for Index in 1 .. SeqLen loop MyProp := Get_Element (Required_QoS, Index); if MyProp.name = "EventReliability" then MyErrCode := UNAVAILABLE_PROPERTY; MyRange := (To_Any (CORBA.Short (0)), To_Any (CORBA.Short (0))); MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); elsif MyProp.name = "ConnectionReliability" then if CORBA.Short'(From_Any (MyProp.value)) /= 0 and then CORBA.Short'(From_Any (MyProp.value)) /= 1 then MyErrCode := BAD_VALUE; MyRange := (To_Any (CORBA.Short (0)), To_Any (CORBA.Short (0))); MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); end if; elsif MyProp.name = "Priority" then if CORBA.Short'(From_Any (MyProp.value)) not in -32_767 .. 32_767 then MyErrCode := BAD_VALUE; MyRange := (To_Any (CORBA.Short (-32767)), To_Any (CORBA.Short (32767))); MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); end if; elsif MyProp.name = "StartTime" then MyErrCode := UNAVAILABLE_PROPERTY; MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); elsif MyProp.name = "StopTime" then MyErrCode := UNAVAILABLE_PROPERTY; MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); elsif MyProp.name = "Timeout" then MyErrCode := UNSUPPORTED_PROPERTY; MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); elsif MyProp.name = "OrderPolicy" then if CORBA.Short'(From_Any (MyProp.value)) /= 0 and then CORBA.Short'(From_Any (MyProp.value)) /= 1 and then CORBA.Short'(From_Any (MyProp.value)) /= 2 and then CORBA.Short'(From_Any (MyProp.value)) /= 3 then MyErrCode := BAD_VALUE; MyRange := (To_Any (CORBA.Short (0)), To_Any (CORBA.Short (3))); MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); end if; elsif MyProp.name = "DiscardPolicy" then if CORBA.Short'(From_Any (MyProp.value)) /= 0 and then CORBA.Short'(From_Any (MyProp.value)) /= 1 and then CORBA.Short'(From_Any (MyProp.value)) /= 2 and then CORBA.Short'(From_Any (MyProp.value)) /= 3 and then CORBA.Short'(From_Any (MyProp.value)) /= 4 then MyErrCode := BAD_VALUE; MyRange := (To_Any (CORBA.Short (0)), To_Any (CORBA.Short (4))); MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); end if; elsif MyProp.name = "MaximumBatchSize" then MyErrCode := UNSUPPORTED_PROPERTY; MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); elsif MyProp.name = "PacingInterval" then MyErrCode := UNSUPPORTED_PROPERTY; MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); elsif MyProp.name = "StartTimeSupported" then MyErrCode := UNSUPPORTED_PROPERTY; MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); elsif MyProp.name = "StopTimeSupported" then MyErrCode := UNSUPPORTED_PROPERTY; MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); elsif MyProp.name = "MaxEventsPerConsumer" then MyErrCode := UNSUPPORTED_PROPERTY; MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); else MyErrCode := BAD_PROPERTY; MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); end if; end loop; if Length (MyErrorSeq) > 0 then CosNotification.Helper.Raise_UnsupportedQoS ((CORBA.IDL_Exception_Members with qos_err => MyErrorSeq)); end if; Enter (Self_Mutex); SeqLen := Length (Self.X.QoSPropSeq); for Index in 1 .. SeqLen loop MyProp := Get_Element (Self.X.QoSPropSeq, Index); if MyProp.name = "ConnectionReliability" then MyRange := (From_Any (MyProp.value), To_Any (CORBA.Short (0))); MyNamedRange := (MyProp.name, MyRange); Append (Available_QoS, MyNamedRange); elsif MyProp.name = "Priority" then MyRange := (To_Any (CORBA.Short (-32767)), To_Any (CORBA.Short (32767))); MyNamedRange := (MyProp.name, MyRange); Append (Available_QoS, MyNamedRange); elsif MyProp.name = "OrderPolicy" then MyRange := (To_Any (CORBA.Short (0)), To_Any (CORBA.Short (3))); MyNamedRange := (MyProp.name, MyRange); Append (Available_QoS, MyNamedRange); elsif MyProp.name = "DiscardPolicy" then MyRange := (To_Any (CORBA.Short (0)), To_Any (CORBA.Short (4))); MyNamedRange := (MyProp.name, MyRange); Append (Available_QoS, MyNamedRange); end if; end loop; Leave (Self_Mutex); end Validate_QoS; ---------------- -- Add_Filter -- ---------------- function Add_Filter (Self : access Object; New_Filter : CosNotifyFilter.Filter.Ref) return CosNotifyFilter.FilterID is pragma Warnings (Off); -- WAG:3.14 pragma Unreferenced (Self, New_Filter); pragma Warnings (On); -- WAG:3.14 MyFilterID : CosNotifyFilter.FilterID; MyID : CORBA.Long; begin Ensure_Initialization; pragma Debug (O ("add_filter in sequenceproxypushconsumer")); Enter (Self_Mutex); Leave (Self_Mutex); MyID := 0; MyFilterID := CosNotifyFilter.FilterID (MyID); return MyFilterID; end Add_Filter; ------------------- -- Remove_Filter -- ------------------- procedure Remove_Filter (Self : access Object; Filter : CosNotifyFilter.FilterID) is pragma Warnings (Off); -- WAG:3.14 pragma Unreferenced (Self, Filter); pragma Warnings (On); -- WAG:3.14 begin Ensure_Initialization; pragma Debug (O ("remove_filter in sequenceproxypushconsumer")); Enter (Self_Mutex); Leave (Self_Mutex); end Remove_Filter; ---------------- -- Get_Filter -- ---------------- function Get_Filter (Self : access Object; Filter : CosNotifyFilter.FilterID) return CosNotifyFilter.Filter.Ref is pragma Warnings (Off); -- WAG:3.14 pragma Unreferenced (Self, Filter); pragma Warnings (On); -- WAG:3.14 MyFilter : CosNotifyFilter.Filter.Ref; begin Ensure_Initialization; pragma Debug (O ("get_filter in sequenceproxypushconsumer")); Enter (Self_Mutex); Leave (Self_Mutex); return MyFilter; end Get_Filter; --------------------- -- Get_All_Filters -- --------------------- function Get_All_Filters (Self : access Object) return CosNotifyFilter.FilterIDSeq is pragma Warnings (Off); -- WAG:3.14 pragma Unreferenced (Self); pragma Warnings (On); -- WAG:3.14 MyFilterSeq : CosNotifyFilter.FilterIDSeq; begin Ensure_Initialization; pragma Debug (O ("get_all_filters in sequenceproxypushconsumer")); Enter (Self_Mutex); Leave (Self_Mutex); return MyFilterSeq; end Get_All_Filters; ------------------------ -- Remove_All_Filters -- ------------------------ procedure Remove_All_Filters (Self : access Object) is pragma Warnings (Off); -- WAG:3.14 pragma Unreferenced (Self); pragma Warnings (On); -- WAG:3.14 begin Ensure_Initialization; pragma Debug (O ("remove_all_filters in sequenceproxypushconsumer")); Enter (Self_Mutex); Leave (Self_Mutex); end Remove_All_Filters; ------------------ -- Offer_Change -- ------------------ procedure Offer_Change (Self : access Object; Added : CosNotification.EventTypeSeq; Removed : CosNotification.EventTypeSeq) is pragma Warnings (Off); -- WAG:3.14 pragma Unreferenced (Self, Added, Removed); pragma Warnings (On); -- WAG:3.14 begin Ensure_Initialization; pragma Debug (O ("offer_change in sequenceproxypushconsumer")); Enter (Self_Mutex); Leave (Self_Mutex); end Offer_Change; ---------------------------- -- Push_Structured_Events -- ---------------------------- procedure Push_Structured_Events (Self : access Object; Notifications : CosNotification.EventBatch) is Admin : CosNotifyChannelAdmin.SupplierAdmin.Impl.Object_Ptr; Admin_Ref : CosNotifyChannelAdmin.SupplierAdmin.Ref; begin Ensure_Initialization; pragma Debug (O ("push new structured event from sequenceproxypushconsumer " & "to supplier admin")); Enter (Self_Mutex); Admin_Ref := Self.X.Admin; Leave (Self_Mutex); Reference_To_Servant (Admin_Ref, Servant (Admin)); CosNotifyChannelAdmin.SupplierAdmin.Impl.Sequence_Post (Admin, Notifications); end Push_Structured_Events; --------------------------------------- -- Disconnect_Sequence_Push_Consumer -- --------------------------------------- procedure Disconnect_Sequence_Push_Consumer (Self : access Object) is Peer : CosNotifyComm.SequencePushSupplier.Ref; Nil_Ref : CosNotifyComm.SequencePushSupplier.Ref; begin Ensure_Initialization; pragma Debug (O ("disconnect sequenceproxypushconsumer")); Enter (Self_Mutex); Peer := Self.X.Peer; Self.X.Peer := Nil_Ref; Leave (Self_Mutex); if not CosNotifyComm.SequencePushSupplier.Is_Nil (Peer) then CosNotifyComm.SequencePushSupplier. disconnect_sequence_push_supplier (Peer); end if; end Disconnect_Sequence_Push_Consumer; ------------ -- Create -- ------------ function Create (Admin : CosNotifyChannelAdmin.SupplierAdmin.Ref; Initial_QoS : CosNotification.QoSProperties; Ptype : CosNotifyChannelAdmin.ProxyType; Proxy_Id : CosNotifyChannelAdmin.ProxyID) return Object_Ptr is Consumer : Object_Ptr; My_Ref : SequenceProxyPushConsumer.Ref; begin pragma Debug (O ("create sequenceproxypushconsumer")); Consumer := new Object; Consumer.X := new Sequence_Proxy_Push_Consumer_Record; Consumer.X.Admin := Admin; Consumer.X.MyId := Proxy_Id; Consumer.X.MyType := Ptype; Consumer.X.This := Consumer; Consumer.X.QoSPropSeq := Initial_QoS; Initiate_Servant (Servant (Consumer), My_Ref); return Consumer; end Create; end CosNotifyChannelAdmin.SequenceProxyPushConsumer.Impl; polyorb-2.8~20110207.orig/cos/notification/cosnotifychanneladmin-sequenceproxypullconsumer-impl.adb0000644000175000017500000007035511750740337033243 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- COSNOTIFYCHANNELADMIN.SEQUENCEPROXYPULLCONSUMER.IMPL -- -- -- -- B o d y -- -- -- -- Copyright (C) 2003-2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with CORBA.Impl; with CosEventChannelAdmin.Helper; with CosNotifyChannelAdmin.SupplierAdmin.Impl; with CosNotification; with CosNotification.Helper; with PolyORB.CORBA_P.Server_Tools; with PolyORB.Log; with PolyORB.Tasking.Threads; with PolyORB.Tasking.Mutexes; with PolyORB.Tasking.Condition_Variables; with CosNotifyChannelAdmin.SequenceProxyPullConsumer.Skel; pragma Warnings (Off, CosNotifyChannelAdmin.SequenceProxyPullConsumer.Skel); package body CosNotifyChannelAdmin.SequenceProxyPullConsumer.Impl is use CosNotification; use IDL_SEQUENCE_CosNotification_Property; use IDL_SEQUENCE_CosNotification_PropertyError; use IDL_SEQUENCE_CosNotification_NamedPropertyRange; use CORBA; use PortableServer; package Convert is new SupplierAdmin_Forward.Convert (CosNotifyChannelAdmin.SupplierAdmin.Ref); use PolyORB.Tasking.Condition_Variables; use PolyORB.Tasking.Mutexes; use PolyORB.Tasking.Threads; use PolyORB.CORBA_P.Server_Tools; use PolyORB.Log; package L is new PolyORB.Log.Facility_Log ("sequenceproxypullconsumer"); procedure O (Message : Standard.String; Level : Log_Level := Debug) renames L.Output; function C (Level : Log_Level := Debug) return Boolean renames L.Enabled; pragma Unreferenced (C); -- For conditional pragma Debug type Sequence_Proxy_Pull_Consumer_Record is record This : Object_Ptr; Admin : CosNotifyChannelAdmin.SupplierAdmin.Ref; MyId : CosNotifyChannelAdmin.ProxyID; MyType : CosNotifyChannelAdmin.ProxyType; Peer : CosNotifyComm.SequencePullSupplier.Ref; QoSPropSeq : CosNotification.QoSProperties; Engin_Launched : Boolean := False; -- is there a thread launch for the engine end record; A_S : Object_Ptr := null; -- This variable is used to initialize the threads local variable. -- it is used to replace the 'accept' statement. Session_Mutex : Mutex_Access; Session_Taken : Condition_Access; -- Synchornisation of task initialization. Peer_Mutex : Mutex_Access; -- Protect access on a peer component T_Initialized : Boolean := False; procedure Ensure_Initialization; pragma Inline (Ensure_Initialization); -- Ensure that the Mutexes are initialized --------------------------- -- Ensure_Initialization -- --------------------------- procedure Ensure_Initialization is begin if T_Initialized then return; end if; Create (Session_Mutex); Create (Session_Taken); Create (Peer_Mutex); T_Initialized := True; end Ensure_Initialization; -------------------------------- -- Proxy_Pull_Consumer_Engine -- -------------------------------- procedure Proxy_Pull_Consumer_Engine; procedure Proxy_Pull_Consumer_Engine is This : Object_Ptr; Peer : CosNotifyComm.SequencePullSupplier.Ref; Max_Number : constant CORBA.Long := 2; Event : CosNotification.EventBatch; Obj : CORBA.Impl.Object_Ptr; begin pragma Debug (O ("Session Thread number " & Image (Current_Task) & " is starting")); -- Signal end of thread initialization. Ensure_Initialization; -- Thread initialization. -- A_S is a global variable used to pass an argument to this task This := A_S; -- This is initialized -- we can let Connect_Sequence_Pull_Supplier go Enter (Session_Mutex); Signal (Session_Taken); Leave (Session_Mutex); loop -- Session thread main loop. Enter (Peer_Mutex); Peer := This.X.Peer; Leave (Peer_Mutex); exit when CosNotifyComm.SequencePullSupplier.Is_Nil (Peer); pragma Debug (O ("pull sequence of structured event from " & "sequenceproxypullconsumer engin")); begin Event := CosNotifyComm.SequencePullSupplier.pull_structured_events (Peer, Max_Number); exception when others => exit; end; pragma Debug (O ("post sequence of structured events from " & "sequenceproxypullconsumer to admin")); Reference_To_Servant (This.X.Admin, Servant (Obj)); CosNotifyChannelAdmin.SupplierAdmin.Impl.Sequence_Post (CosNotifyChannelAdmin.SupplierAdmin.Impl.Object_Ptr (Obj), Event); end loop; This.X.Engin_Launched := False; end Proxy_Pull_Consumer_Engine; ------------------------------------ -- Connect_Sequence_Pull_Supplier -- ------------------------------------ procedure Connect_Sequence_Pull_Supplier (Self : access Object; Pull_Supplier : CosNotifyComm.SequencePullSupplier.Ref) is begin Ensure_Initialization; pragma Debug (O ("connect_sequence_pull_supplier in sequenceproxypullconsumer")); Enter (Session_Mutex); if not CosNotifyComm.SequencePullSupplier.Is_Nil (Self.X.Peer) then Leave (Session_Mutex); CosEventChannelAdmin.Helper.Raise_AlreadyConnected ((CORBA.IDL_Exception_Members with null record)); end if; Self.X.Peer := Pull_Supplier; A_S := Self.X.This; -- Start engin if not Self.X.Engin_Launched then Create_Task (Proxy_Pull_Consumer_Engine'Access); Self.X.Engin_Launched := True; -- thread created end if; -- wait A_S initialization in Proxy_Pull_Consumer_Engin Wait (Session_Taken, Session_Mutex); Leave (Session_Mutex); end Connect_Sequence_Pull_Supplier; ------------------------ -- Suspend_Connection -- ------------------------ procedure Suspend_Connection (Self : access Object) is pragma Warnings (Off); -- WAG:3.14 pragma Unreferenced (Self); pragma Warnings (On); -- WAG:3.14 begin Ensure_Initialization; pragma Debug (O ("suspend_connection in sequenceproxypullconsumer")); Enter (Peer_Mutex); Leave (Peer_Mutex); end Suspend_Connection; ----------------------- -- Resume_Connection -- ----------------------- procedure Resume_Connection (Self : access Object) is pragma Warnings (Off); -- WAG:3.14 pragma Unreferenced (Self); pragma Warnings (On); -- WAG:3.14 begin Ensure_Initialization; pragma Debug (O ("resume_connection in sequenceproxypullconsumer")); Enter (Peer_Mutex); Leave (Peer_Mutex); end Resume_Connection; ---------------- -- Get_MyType -- ---------------- function Get_MyType (Self : access Object) return CosNotifyChannelAdmin.ProxyType is MyType : CosNotifyChannelAdmin.ProxyType; begin Ensure_Initialization; pragma Debug (O ("get_mytype in sequenceproxypullconsumer")); Enter (Peer_Mutex); MyType := Self.X.MyType; Leave (Peer_Mutex); return MyType; end Get_MyType; ----------------- -- Get_MyAdmin -- ----------------- function Get_MyAdmin (Self : access Object) return CosNotifyChannelAdmin.SupplierAdmin_Forward.Ref is MyAdmin : CosNotifyChannelAdmin.SupplierAdmin_Forward.Ref; begin Ensure_Initialization; pragma Debug (O ("get_myadmin in sequenceproxypullconsumer")); Enter (Peer_Mutex); MyAdmin := Convert.To_Forward (Self.X.Admin); Leave (Peer_Mutex); return MyAdmin; end Get_MyAdmin; ------------------------------- -- Obtain_Subscription_Types -- ------------------------------- function Obtain_Subscription_Types (Self : access Object; Mode : CosNotifyChannelAdmin.ObtainInfoMode) return CosNotification.EventTypeSeq is pragma Warnings (Off); -- WAG:3.14 pragma Unreferenced (Self, Mode); pragma Warnings (On); -- WAG:3.14 MySeq : CosNotification.EventTypeSeq; begin Ensure_Initialization; pragma Debug (O ("obtain_subscription_types in sequenceproxypullconsumer")); Enter (Peer_Mutex); Leave (Peer_Mutex); return MySeq; end Obtain_Subscription_Types; ------------------------ -- Validate_Event_QoS -- ------------------------ procedure Validate_Event_QoS (Self : access Object; Required_QoS : CosNotification.QoSProperties; Available_QoS : out CosNotification.NamedPropertyRangeSeq) is pragma Warnings (Off); -- WAG:3.14 pragma Unreferenced (Self, Required_QoS, Available_QoS); pragma Warnings (On); -- WAG:3.14 begin Ensure_Initialization; pragma Debug (O ("validate_event_qos in sequenceproxypullconsumer")); Enter (Peer_Mutex); Leave (Peer_Mutex); end Validate_Event_QoS; ------------- -- Get_QoS -- ------------- function Get_QoS (Self : access Object) return CosNotification.QoSProperties is MyQoS : CosNotification.QoSProperties; begin Ensure_Initialization; pragma Debug (O ("get_qos in sequenceproxypullconsumer")); Enter (Peer_Mutex); MyQoS := Self.X.QoSPropSeq; Leave (Peer_Mutex); return MyQoS; end Get_QoS; ------------- -- Set_QoS -- ------------- procedure Set_QoS (Self : access Object; QoS : CosNotification.QoSProperties) is MyProp : CosNotification.Property; MyError : CosNotification.PropertyError; MyErrCode : CosNotification.QoSError_code; MyRange : CosNotification.PropertyRange; MyErrorSeq : CosNotification.PropertyErrorSeq; SeqLen : Integer; begin Ensure_Initialization; pragma Debug (O ("set_qos in sequenceproxypullconsumer")); SeqLen := Length (QoS); for Index in 1 .. SeqLen loop MyProp := Get_Element (QoS, Index); if MyProp.name = "EventReliability" then MyErrCode := UNAVAILABLE_PROPERTY; MyRange := (To_Any (CORBA.Short (0)), To_Any (CORBA.Short (0))); MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); elsif MyProp.name = "ConnectionReliability" then if CORBA.Short'(From_Any (MyProp.value)) /= 0 and then CORBA.Short'(From_Any (MyProp.value)) /= 1 then MyErrCode := BAD_VALUE; MyRange := (To_Any (CORBA.Short (0)), To_Any (CORBA.Short (0))); MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); end if; elsif MyProp.name = "Priority" then if CORBA.Short'(From_Any (MyProp.value)) not in -32_767 .. 32_767 then MyErrCode := BAD_VALUE; MyRange := (To_Any (CORBA.Short (-32767)), To_Any (CORBA.Short (32767))); MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); end if; elsif MyProp.name = "StartTime" then MyErrCode := UNAVAILABLE_PROPERTY; MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); elsif MyProp.name = "StopTime" then MyErrCode := UNAVAILABLE_PROPERTY; MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); elsif MyProp.name = "Timeout" then MyErrCode := UNSUPPORTED_PROPERTY; MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); elsif MyProp.name = "OrderPolicy" then if CORBA.Short'(From_Any (MyProp.value)) /= 0 and then CORBA.Short'(From_Any (MyProp.value)) /= 1 and then CORBA.Short'(From_Any (MyProp.value)) /= 2 and then CORBA.Short'(From_Any (MyProp.value)) /= 3 then MyErrCode := BAD_VALUE; MyRange := (To_Any (CORBA.Short (0)), To_Any (CORBA.Short (3))); MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); end if; elsif MyProp.name = "DiscardPolicy" then if CORBA.Short'(From_Any (MyProp.value)) /= 0 and then CORBA.Short'(From_Any (MyProp.value)) /= 1 and then CORBA.Short'(From_Any (MyProp.value)) /= 2 and then CORBA.Short'(From_Any (MyProp.value)) /= 3 and then CORBA.Short'(From_Any (MyProp.value)) /= 4 then MyErrCode := BAD_VALUE; MyRange := (To_Any (CORBA.Short (0)), To_Any (CORBA.Short (4))); MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); end if; elsif MyProp.name = "MaximumBatchSize" then MyErrCode := UNSUPPORTED_PROPERTY; MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); elsif MyProp.name = "PacingInterval" then MyErrCode := UNSUPPORTED_PROPERTY; MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); elsif MyProp.name = "StartTimeSupported" then MyErrCode := UNSUPPORTED_PROPERTY; MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); elsif MyProp.name = "StopTimeSupported" then MyErrCode := UNSUPPORTED_PROPERTY; MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); elsif MyProp.name = "MaxEventsPerConsumer" then MyErrCode := UNSUPPORTED_PROPERTY; MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); else MyErrCode := BAD_PROPERTY; MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); end if; end loop; if Length (MyErrorSeq) > 0 then CosNotification.Helper.Raise_UnsupportedQoS ((CORBA.IDL_Exception_Members with qos_err => MyErrorSeq)); end if; SeqLen := Length (QoS); Enter (Peer_Mutex); for Index in 1 .. SeqLen loop MyProp := Get_Element (QoS, Index); if MyProp.name = "ConnectionReliability" then Replace_Element (Self.X.QoSPropSeq, 2, MyProp); elsif MyProp.name = "Priority" then Replace_Element (Self.X.QoSPropSeq, 3, MyProp); elsif MyProp.name = "OrderPolicy" then Replace_Element (Self.X.QoSPropSeq, 4, MyProp); elsif MyProp.name = "DiscardPolicy" then Replace_Element (Self.X.QoSPropSeq, 5, MyProp); end if; end loop; Leave (Peer_Mutex); end Set_QoS; ------------------ -- Validate_QoS -- ------------------ procedure Validate_QoS (Self : access Object; Required_QoS : CosNotification.QoSProperties; Available_QoS : out CosNotification.NamedPropertyRangeSeq) is MyProp : CosNotification.Property; MyError : CosNotification.PropertyError; MyErrCode : CosNotification.QoSError_code; MyNamedRange : CosNotification.NamedPropertyRange; MyRange : CosNotification.PropertyRange; MyErrorSeq : CosNotification.PropertyErrorSeq; SeqLen : Integer; begin Ensure_Initialization; pragma Debug (O ("validate_qos in sequenceproxypullconsumer")); SeqLen := Length (Required_QoS); for Index in 1 .. SeqLen loop MyProp := Get_Element (Required_QoS, Index); if MyProp.name = "EventReliability" then MyErrCode := UNAVAILABLE_PROPERTY; MyRange := (To_Any (CORBA.Short (0)), To_Any (CORBA.Short (0))); MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); elsif MyProp.name = "ConnectionReliability" then if CORBA.Short'(From_Any (MyProp.value)) /= 0 and then CORBA.Short'(From_Any (MyProp.value)) /= 1 then MyErrCode := BAD_VALUE; MyRange := (To_Any (CORBA.Short (0)), To_Any (CORBA.Short (0))); MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); end if; elsif MyProp.name = "Priority" then if CORBA.Short'(From_Any (MyProp.value)) not in -32_767 .. 32_767 then MyErrCode := BAD_VALUE; MyRange := (To_Any (CORBA.Short (-32767)), To_Any (CORBA.Short (32767))); MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); end if; elsif MyProp.name = "StartTime" then MyErrCode := UNAVAILABLE_PROPERTY; MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); elsif MyProp.name = "StopTime" then MyErrCode := UNAVAILABLE_PROPERTY; MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); elsif MyProp.name = "Timeout" then MyErrCode := UNSUPPORTED_PROPERTY; MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); elsif MyProp.name = "OrderPolicy" then if CORBA.Short'(From_Any (MyProp.value)) /= 0 and then CORBA.Short'(From_Any (MyProp.value)) /= 1 and then CORBA.Short'(From_Any (MyProp.value)) /= 2 and then CORBA.Short'(From_Any (MyProp.value)) /= 3 then MyErrCode := BAD_VALUE; MyRange := (To_Any (CORBA.Short (0)), To_Any (CORBA.Short (3))); MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); end if; elsif MyProp.name = "DiscardPolicy" then if CORBA.Short'(From_Any (MyProp.value)) /= 0 and then CORBA.Short'(From_Any (MyProp.value)) /= 1 and then CORBA.Short'(From_Any (MyProp.value)) /= 2 and then CORBA.Short'(From_Any (MyProp.value)) /= 3 and then CORBA.Short'(From_Any (MyProp.value)) /= 4 then MyErrCode := BAD_VALUE; MyRange := (To_Any (CORBA.Short (0)), To_Any (CORBA.Short (4))); MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); end if; elsif MyProp.name = "MaximumBatchSize" then MyErrCode := UNSUPPORTED_PROPERTY; MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); elsif MyProp.name = "PacingInterval" then MyErrCode := UNSUPPORTED_PROPERTY; MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); elsif MyProp.name = "StartTimeSupported" then MyErrCode := UNSUPPORTED_PROPERTY; MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); elsif MyProp.name = "StopTimeSupported" then MyErrCode := UNSUPPORTED_PROPERTY; MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); elsif MyProp.name = "MaxEventsPerConsumer" then MyErrCode := UNSUPPORTED_PROPERTY; MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); else MyErrCode := BAD_PROPERTY; MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); end if; end loop; if Length (MyErrorSeq) > 0 then CosNotification.Helper.Raise_UnsupportedQoS ((CORBA.IDL_Exception_Members with qos_err => MyErrorSeq)); end if; Enter (Peer_Mutex); SeqLen := Length (Self.X.QoSPropSeq); for Index in 1 .. SeqLen loop MyProp := Get_Element (Self.X.QoSPropSeq, Index); if MyProp.name = "ConnectionReliability" then MyRange := (From_Any (MyProp.value), To_Any (CORBA.Short (0))); MyNamedRange := (MyProp.name, MyRange); Append (Available_QoS, MyNamedRange); elsif MyProp.name = "Priority" then MyRange := (To_Any (CORBA.Short (-32767)), To_Any (CORBA.Short (32767))); MyNamedRange := (MyProp.name, MyRange); Append (Available_QoS, MyNamedRange); elsif MyProp.name = "OrderPolicy" then MyRange := (To_Any (CORBA.Short (0)), To_Any (CORBA.Short (3))); MyNamedRange := (MyProp.name, MyRange); Append (Available_QoS, MyNamedRange); elsif MyProp.name = "DiscardPolicy" then MyRange := (To_Any (CORBA.Short (0)), To_Any (CORBA.Short (4))); MyNamedRange := (MyProp.name, MyRange); Append (Available_QoS, MyNamedRange); end if; end loop; Leave (Peer_Mutex); end Validate_QoS; ---------------- -- Add_Filter -- ---------------- function Add_Filter (Self : access Object; New_Filter : CosNotifyFilter.Filter.Ref) return CosNotifyFilter.FilterID is pragma Warnings (Off); -- WAG:3.14 pragma Unreferenced (Self, New_Filter); pragma Warnings (On); -- WAG:3.14 MyFilterID : CosNotifyFilter.FilterID; MyID : CORBA.Long; begin Ensure_Initialization; pragma Debug (O ("add_filter in sequenceproxypullconsumer")); Enter (Peer_Mutex); Leave (Peer_Mutex); MyID := 0; MyFilterID := CosNotifyFilter.FilterID (MyID); return MyFilterID; end Add_Filter; ------------------- -- Remove_Filter -- ------------------- procedure Remove_Filter (Self : access Object; Filter : CosNotifyFilter.FilterID) is pragma Warnings (Off); -- WAG:3.14 pragma Unreferenced (Self, Filter); pragma Warnings (On); -- WAG:3.14 begin Ensure_Initialization; pragma Debug (O ("remove_filter in sequenceproxypullconsumer")); Enter (Peer_Mutex); Leave (Peer_Mutex); end Remove_Filter; ---------------- -- Get_Filter -- ---------------- function Get_Filter (Self : access Object; Filter : CosNotifyFilter.FilterID) return CosNotifyFilter.Filter.Ref is pragma Warnings (Off); -- WAG:3.14 pragma Unreferenced (Self, Filter); pragma Warnings (On); -- WAG:3.14 MyFilter : CosNotifyFilter.Filter.Ref; begin Ensure_Initialization; pragma Debug (O ("get_filter in sequenceproxypullconsumer")); Enter (Peer_Mutex); Leave (Peer_Mutex); return MyFilter; end Get_Filter; --------------------- -- Get_All_Filters -- --------------------- function Get_All_Filters (Self : access Object) return CosNotifyFilter.FilterIDSeq is pragma Warnings (Off); -- WAG:3.14 pragma Unreferenced (Self); pragma Warnings (On); -- WAG:3.14 MyFilterSeq : CosNotifyFilter.FilterIDSeq; begin Ensure_Initialization; pragma Debug (O ("get_all_filters in sequenceproxypullconsumer")); Enter (Peer_Mutex); Leave (Peer_Mutex); return MyFilterSeq; end Get_All_Filters; ------------------------ -- Remove_All_Filters -- ------------------------ procedure Remove_All_Filters (Self : access Object) is pragma Warnings (Off); -- WAG:3.14 pragma Unreferenced (Self); pragma Warnings (On); -- WAG:3.14 begin Ensure_Initialization; pragma Debug (O ("remove_all_filters in sequenceproxypullconsumer")); Enter (Peer_Mutex); Leave (Peer_Mutex); end Remove_All_Filters; ------------------ -- Offer_Change -- ------------------ procedure Offer_Change (Self : access Object; Added : CosNotification.EventTypeSeq; Removed : CosNotification.EventTypeSeq) is pragma Warnings (Off); -- WAG:3.14 pragma Unreferenced (Self, Added, Removed); pragma Warnings (On); -- WAG:3.14 begin pragma Debug (O ("offer_change in sequenceproxypullconsumer")); Ensure_Initialization; Enter (Peer_Mutex); Leave (Peer_Mutex); end Offer_Change; --------------------------------------- -- Disconnect_Sequence_Pull_Consumer -- --------------------------------------- procedure Disconnect_Sequence_Pull_Consumer (Self : access Object) is Peer : CosNotifyComm.SequencePullSupplier.Ref; Nil_Ref : CosNotifyComm.SequencePullSupplier.Ref; begin pragma Debug (O ("disconnect sequenceproxypullconsumer")); Ensure_Initialization; Enter (Peer_Mutex); Peer := Self.X.Peer; Self.X.Peer := Nil_Ref; Leave (Peer_Mutex); if not CosNotifyComm.SequencePullSupplier.Is_Nil (Peer) then CosNotifyComm.SequencePullSupplier. disconnect_sequence_pull_supplier (Peer); end if; end Disconnect_Sequence_Pull_Consumer; ------------ -- Create -- ------------ function Create (Admin : CosNotifyChannelAdmin.SupplierAdmin.Ref; Initial_QoS : CosNotification.QoSProperties; Ptype : CosNotifyChannelAdmin.ProxyType; Proxy_Id : CosNotifyChannelAdmin.ProxyID) return Object_Ptr is Consumer : Object_Ptr; My_Ref : SequenceProxyPullConsumer.Ref; begin pragma Debug (O ("create sequenceproxypullconsumer")); Consumer := new Object; Consumer.X := new Sequence_Proxy_Pull_Consumer_Record; Consumer.X.Admin := Admin; Consumer.X.MyId := Proxy_Id; Consumer.X.MyType := Ptype; Consumer.X.This := Consumer; Consumer.X.QoSPropSeq := Initial_QoS; Initiate_Servant (Servant (Consumer), My_Ref); return Consumer; end Create; end CosNotifyChannelAdmin.SequenceProxyPullConsumer.Impl; polyorb-2.8~20110207.orig/cos/notification/cosnotifychanneladmin-eventchannelfactory-impl.ads0000644000175000017500000000623311750740337031735 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- COSNOTIFYCHANNELADMIN.EVENTCHANNELFACTORY.IMPL -- -- -- -- S p e c -- -- -- -- Copyright (C) 2003-2008, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by ACT Europe. -- -- (email: sales@act-europe.fr) -- -- -- ------------------------------------------------------------------------------ -- with CORBA; with PortableServer; package CosNotifyChannelAdmin.EventChannelFactory.Impl is type Object is new PortableServer.Servant_Base with private; type Object_Ptr is access all Object'Class; -- IDL operations procedure Create_Channel (Self : access Object; Initial_QoS : CosNotification.QoSProperties; Initial_Admin : CosNotification.AdminProperties; Id : out ChannelID; Returns : out CosNotifyChannelAdmin.EventChannel.Ref); function Get_All_Channels (Self : access Object) return CosNotifyChannelAdmin.ChannelIDSeq; function Get_Event_Channel (Self : access Object; Id : ChannelID) return CosNotifyChannelAdmin.EventChannel.Ref; ---------------------- -- PolyORB specific -- ---------------------- function Create return Object_Ptr; private type Event_Channel_Factory_Record; type Event_Channel_Factory_Access is access Event_Channel_Factory_Record; type Object is new PortableServer.Servant_Base with record X : Event_Channel_Factory_Access; end record; end CosNotifyChannelAdmin.EventChannelFactory.Impl; polyorb-2.8~20110207.orig/cos/notification/cosnotifycomm-structuredpushconsumer-impl.ads0000644000175000017500000000723511750740337031070 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- COSNOTIFYCOMM.STRUCTUREDPUSHCONSUMER.IMPL -- -- -- -- S p e c -- -- -- -- Copyright (C) 2003-2008, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by ACT Europe. -- -- (email: sales@act-europe.fr) -- -- -- ------------------------------------------------------------------------------ with PortableServer; with CosNotifyChannelAdmin.StructuredProxyPushSupplier; with CosNotification; package CosNotifyComm.StructuredPushConsumer.Impl is type Object is new PortableServer.Servant_Base with private; type Object_Ptr is access all Object'Class; -- Inherited IDL operations from CosNotifyComm::NotifyPublish procedure Offer_Change (Self : access Object; Added : CosNotification.EventTypeSeq; Removed : CosNotification.EventTypeSeq); -- IDL operations procedure Push_Structured_Event (Self : access Object; Notification : CosNotification.StructuredEvent); procedure Disconnect_Structured_Push_Consumer (Self : access Object); ---------------------- -- PolyORB specific -- ---------------------- function Create return Object_Ptr; procedure Connect_Structured_Proxy_Push_Supplier (Self : access Object; Proxy : CosNotifyChannelAdmin.StructuredProxyPushSupplier.Ref); -- Call by application to connect object with proxy function Pull (Self : access Object) return CosNotification.StructuredEvent; -- Call by application to consume an event procedure Try_Pull (Self : access Object; Done : out CORBA.Boolean; Data : out CosNotification.StructuredEvent); -- Call by application to try to consume a structured event private type Structured_Push_Consumer_Record; type Structured_Push_Consumer_Access is access Structured_Push_Consumer_Record; type Object is new PortableServer.Servant_Base with record X : Structured_Push_Consumer_Access; end record; end CosNotifyComm.StructuredPushConsumer.Impl; ././@LongLink0000000000000000000000000000014600000000000011566 Lustar rootrootpolyorb-2.8~20110207.orig/cos/notification/cosnotifychanneladmin-structuredproxypushconsumer-impl.adspolyorb-2.8~20110207.orig/cos/notification/cosnotifychanneladmin-structuredproxypushconsumer-impl.ad0000644000175000017500000001203211750740337033464 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- COSNOTIFYCHANNELADMIN.STRUCTUREDPROXYPUSHCONSUMER.IMPL -- -- -- -- S p e c -- -- -- -- Copyright (C) 2003-2008, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by ACT Europe. -- -- (email: sales@act-europe.fr) -- -- -- ------------------------------------------------------------------------------ with CosNotifyChannelAdmin.SupplierAdmin; with CosNotifyFilter.Filter; with PortableServer; package CosNotifyChannelAdmin.StructuredProxyPushConsumer.Impl is type Object is new PortableServer.Servant_Base with private; type Object_Ptr is access all Object'Class; -- IDL Operations procedure Connect_Structured_Push_Supplier (Self : access Object; Push_Supplier : CosNotifyComm.StructuredPushSupplier.Ref); -- IDL operations inherited from CosNotifyChannelAdmin::ProxyConsumer function Get_MyType (Self : access Object) return CosNotifyChannelAdmin.ProxyType; function Get_MyAdmin (Self : access Object) return CosNotifyChannelAdmin.SupplierAdmin_Forward.Ref; function Obtain_Subscription_Types (Self : access Object; Mode : CosNotifyChannelAdmin.ObtainInfoMode) return CosNotification.EventTypeSeq; procedure Validate_Event_QoS (Self : access Object; Required_QoS : CosNotification.QoSProperties; Available_QoS : out CosNotification.NamedPropertyRangeSeq); function Get_QoS (Self : access Object) return CosNotification.QoSProperties; procedure Set_QoS (Self : access Object; QoS : CosNotification.QoSProperties); procedure Validate_QoS (Self : access Object; Required_QoS : CosNotification.QoSProperties; Available_QoS : out CosNotification.NamedPropertyRangeSeq); function Add_Filter (Self : access Object; New_Filter : CosNotifyFilter.Filter.Ref) return CosNotifyFilter.FilterID; procedure Remove_Filter (Self : access Object; Filter : CosNotifyFilter.FilterID); function Get_Filter (Self : access Object; Filter : CosNotifyFilter.FilterID) return CosNotifyFilter.Filter.Ref; function Get_All_Filters (Self : access Object) return CosNotifyFilter.FilterIDSeq; procedure Remove_All_Filters (Self : access Object); -- Inherited IDL operations from CosNotifyComm::StructuredPushConsumer procedure Offer_Change (Self : access Object; Added : CosNotification.EventTypeSeq; Removed : CosNotification.EventTypeSeq); procedure Push_Structured_Event (Self : access Object; Notification : CosNotification.StructuredEvent); procedure Disconnect_Structured_Push_Consumer (Self : access Object); ---------------------- -- PolyORB specific -- ---------------------- function Create (Admin : CosNotifyChannelAdmin.SupplierAdmin.Ref; Initial_QoS : CosNotification.QoSProperties; Ptype : CosNotifyChannelAdmin.ProxyType; Proxy_Id : CosNotifyChannelAdmin.ProxyID) return Object_Ptr; private type Structured_Proxy_Push_Consumer_Record; type Structured_Proxy_Push_Consumer_Access is access Structured_Proxy_Push_Consumer_Record; type Object is new PortableServer.Servant_Base with record X : Structured_Proxy_Push_Consumer_Access; end record; end CosNotifyChannelAdmin.StructuredProxyPushConsumer.Impl; polyorb-2.8~20110207.orig/cos/notification/cosnotifycomm-sequencepushsupplier-impl.adb0000644000175000017500000001607611750740337030466 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- COSNOTIFYCOMM.SEQUENCEPUSHSUPPLIER.IMPL -- -- -- -- B o d y -- -- -- -- Copyright (C) 2003-2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with CosEventChannelAdmin.Helper; with CosEventComm.Helper; with PolyORB.CORBA_P.Server_Tools; with PolyORB.Log; with PolyORB.Tasking.Mutexes; with CosNotifyComm.SequencePushSupplier.Skel; pragma Warnings (Off, CosNotifyComm.SequencePushSupplier.Skel); package body CosNotifyComm.SequencePushSupplier.Impl is use PolyORB.CORBA_P.Server_Tools; use PolyORB.Tasking.Mutexes; use PolyORB.Log; package L is new PolyORB.Log.Facility_Log ("sequencepushsupplier"); procedure O (Message : Standard.String; Level : Log_Level := Debug) renames L.Output; function C (Level : Log_Level := Debug) return Boolean renames L.Enabled; pragma Unreferenced (C); -- For conditional pragma Debug type Sequence_Push_Supplier_Record is record This : Object_Ptr; Peer : CosNotifyChannelAdmin.SequenceProxyPushConsumer.Ref; end record; --------------------------- -- Ensure_Initialization -- --------------------------- procedure Ensure_Initialization; pragma Inline (Ensure_Initialization); -- Ensure that the Mutexes are initialized T_Initialized : Boolean := False; Self_Mutex : Mutex_Access; procedure Ensure_Initialization is begin if not T_Initialized then Create (Self_Mutex); T_Initialized := True; end if; end Ensure_Initialization; ------------------------- -- Subscription_Change -- ------------------------- procedure Subscription_Change (Self : access Object; Added : CosNotification.EventTypeSeq; Removed : CosNotification.EventTypeSeq) is pragma Warnings (Off); -- WAG:3.14 pragma Unreferenced (Self, Added, Removed); pragma Warnings (On); -- WAG:3.14 begin Ensure_Initialization; pragma Debug (O ("subscription_change in sequencepushsupplier")); Enter (Self_Mutex); Leave (Self_Mutex); end Subscription_Change; --------------------------------------- -- Disconnect_Sequence_Push_Supplier -- --------------------------------------- procedure Disconnect_Sequence_Push_Supplier (Self : access Object) is Peer : CosNotifyChannelAdmin.SequenceProxyPushConsumer.Ref; Nil_Ref : CosNotifyChannelAdmin.SequenceProxyPushConsumer.Ref; begin Ensure_Initialization; pragma Debug (O ("disconnect sequencepushsupplier")); Enter (Self_Mutex); Peer := Self.X.Peer; Self.X.Peer := Nil_Ref; Leave (Self_Mutex); if not CosNotifyChannelAdmin.SequenceProxyPushConsumer.Is_Nil (Peer) then CosNotifyChannelAdmin.SequenceProxyPushConsumer. disconnect_sequence_push_consumer (Peer); end if; end Disconnect_Sequence_Push_Supplier; ------------ -- Create -- ------------ function Create return Object_Ptr is Supplier : Object_Ptr; My_Ref : SequencePushSupplier.Ref; My_Peer : CosNotifyChannelAdmin.SequenceProxyPushConsumer.Ref; begin pragma Debug (O ("create sequencepushsupplier")); Supplier := new Object; Supplier.X := new Sequence_Push_Supplier_Record; Supplier.X.This := Supplier; Supplier.X.Peer := My_Peer; Initiate_Servant (PortableServer.Servant (Supplier), My_Ref); return Supplier; end Create; ------------------------------------------ -- Connect_Sequence_Proxy_Push_Consumer -- ------------------------------------------ procedure Connect_Sequence_Proxy_Push_Consumer (Self : access Object; Proxy : CosNotifyChannelAdmin.SequenceProxyPushConsumer.Ref) is My_Ref : SequencePushSupplier.Ref; begin Ensure_Initialization; pragma Debug (O ("connect_sequence_proxy_push_consumer in sequencepushsupplier")); Enter (Self_Mutex); if not CosNotifyChannelAdmin.SequenceProxyPushConsumer.Is_Nil (Self.X.Peer) then Leave (Self_Mutex); CosEventChannelAdmin.Helper.Raise_AlreadyConnected ((CORBA.IDL_Exception_Members with null record)); end if; Self.X.Peer := Proxy; Servant_To_Reference (PortableServer.Servant (Self.X.This), My_Ref); Leave (Self_Mutex); CosNotifyChannelAdmin.SequenceProxyPushConsumer. connect_sequence_push_supplier (Proxy, My_Ref); end Connect_Sequence_Proxy_Push_Consumer; ---------- -- Push -- ---------- procedure Push (Self : access Object; Notifications : CosNotification.EventBatch) is Peer : CosNotifyChannelAdmin.SequenceProxyPushConsumer.Ref; begin Ensure_Initialization; pragma Debug (O ("push sequence of structuredevents " & "to sequencepushsupplier")); Enter (Self_Mutex); Peer := Self.X.Peer; Leave (Self_Mutex); if CosNotifyChannelAdmin.SequenceProxyPushConsumer.Is_Nil (Peer) then CosEventComm.Helper.Raise_Disconnected ((CORBA.IDL_Exception_Members with null record)); end if; CosNotifyChannelAdmin.SequenceProxyPushConsumer.push_structured_events (Peer, Notifications); end Push; end CosNotifyComm.SequencePushSupplier.Impl; polyorb-2.8~20110207.orig/cos/notification/cosnotifychanneladmin-proxypullconsumer-impl.adb0000644000175000017500000006716011750740337031512 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- COSNOTIFYCHANNELADMIN.PROXYPULLCONSUMER.IMPL -- -- -- -- B o d y -- -- -- -- Copyright (C) 2003-2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with CORBA.Impl; with CosEventChannelAdmin.Helper; with CosNotifyChannelAdmin.SupplierAdmin.Impl; with CosNotification; with CosNotification.Helper; with PolyORB.CORBA_P.Server_Tools; with PolyORB.Log; with PolyORB.Tasking.Condition_Variables; with PolyORB.Tasking.Mutexes; with PolyORB.Tasking.Threads; with CosNotifyChannelAdmin.ProxyPullConsumer.Skel; pragma Warnings (Off, CosNotifyChannelAdmin.ProxyPullConsumer.Skel); package body CosNotifyChannelAdmin.ProxyPullConsumer.Impl is use CosNotification; use IDL_SEQUENCE_CosNotification_Property; use IDL_SEQUENCE_CosNotification_PropertyError; use IDL_SEQUENCE_CosNotification_NamedPropertyRange; use CORBA; use PortableServer; package Convert is new SupplierAdmin_Forward.Convert (CosNotifyChannelAdmin.SupplierAdmin.Ref); use PolyORB.Tasking.Condition_Variables; use PolyORB.Tasking.Mutexes; use PolyORB.Tasking.Threads; use PolyORB.CORBA_P.Server_Tools; use PolyORB.Log; package L is new PolyORB.Log.Facility_Log ("proxypullconsumer"); procedure O (Message : Standard.String; Level : Log_Level := Debug) renames L.Output; function C (Level : Log_Level := Debug) return Boolean renames L.Enabled; pragma Unreferenced (C); -- For conditional pragma Debug type Proxy_Pull_Consumer_Record is record This : Object_Ptr; Admin : CosNotifyChannelAdmin.SupplierAdmin.Ref; MyId : CosNotifyChannelAdmin.ProxyID; MyType : CosNotifyChannelAdmin.ProxyType; Peer : CosEventComm.PullSupplier.Ref; QoSPropSeq : CosNotification.QoSProperties; Engin_Launched : Boolean := False; -- is there a thread launch for the engine end record; A_S : Object_Ptr := null; -- This variable is used to initialize the threads local variable. -- it is used to replace the 'accept' statement. Session_Mutex : Mutex_Access; Session_Taken : Condition_Access; -- Synchornisation of task initialization. Peer_Mutex : Mutex_Access; -- Protect access on a peer component T_Initialized : Boolean := False; procedure Ensure_Initialization; pragma Inline (Ensure_Initialization); -- Ensure that the Mutexes are initialized --------------------------- -- Ensure_Initialization -- --------------------------- procedure Ensure_Initialization is begin if T_Initialized then return; end if; Create (Session_Mutex); Create (Session_Taken); Create (Peer_Mutex); T_Initialized := True; end Ensure_Initialization; -------------------------------- -- Proxy_Pull_Consumer_Engine -- -------------------------------- procedure Proxy_Pull_Consumer_Engine; procedure Proxy_Pull_Consumer_Engine is This : Object_Ptr; Peer : CosEventComm.PullSupplier.Ref; Event : CORBA.Any; Obj : CORBA.Impl.Object_Ptr; begin pragma Debug (O ("Session Thread number " & Image (Current_Task) & " is starting")); -- Signal end of thread initialization. Ensure_Initialization; -- Thread initialization. -- A_S is a global variable used to pass an argument to this task This := A_S; -- This is initialized -- we can let Connect_Pull_Supplier go Enter (Session_Mutex); Signal (Session_Taken); Leave (Session_Mutex); loop -- Session thread main loop. Enter (Peer_Mutex); Peer := This.X.Peer; Leave (Peer_Mutex); exit when CosEventComm.PullSupplier.Is_Nil (Peer); pragma Debug (O ("pull new data from proxy pull consumer engin")); begin Event := CosEventComm.PullSupplier.pull (Peer); exception when others => exit; end; pragma Debug (O ("post new data from proxy pull consumer to admin")); Reference_To_Servant (This.X.Admin, Servant (Obj)); CosNotifyChannelAdmin.SupplierAdmin.Impl.Post (CosNotifyChannelAdmin.SupplierAdmin.Impl.Object_Ptr (Obj), Event); end loop; This.X.Engin_Launched := False; end Proxy_Pull_Consumer_Engine; ------------------------------- -- Connect_Any_Pull_Supplier -- ------------------------------- procedure Connect_Any_Pull_Supplier (Self : access Object; Pull_Supplier : CosEventComm.PullSupplier.Ref) is begin pragma Debug (O ("connect_any_pull_supplier in proxypullconsumer")); Ensure_Initialization; Enter (Session_Mutex); if not CosEventComm.PullSupplier.Is_Nil (Self.X.Peer) then Leave (Session_Mutex); CosEventChannelAdmin.Helper.Raise_AlreadyConnected ((CORBA.IDL_Exception_Members with null record)); end if; Self.X.Peer := Pull_Supplier; A_S := Self.X.This; -- Start engin if not Self.X.Engin_Launched then Create_Task (Proxy_Pull_Consumer_Engine'Access); Self.X.Engin_Launched := True; -- thread created end if; -- wait A_S initialization in Proxy_Pull_Consumer_Engin Wait (Session_Taken, Session_Mutex); Leave (Session_Mutex); end Connect_Any_Pull_Supplier; ------------------------ -- Suspend_Connection -- ------------------------ procedure Suspend_Connection (Self : access Object) is pragma Warnings (Off); -- WAG:3.14 pragma Unreferenced (Self); pragma Warnings (On); -- WAG:3.14 begin Ensure_Initialization; pragma Debug (O ("suspend_connection in proxypullconsumer")); Enter (Peer_Mutex); Leave (Peer_Mutex); end Suspend_Connection; ----------------------- -- Resume_Connection -- ----------------------- procedure Resume_Connection (Self : access Object) is pragma Warnings (Off); -- WAG:3.14 pragma Unreferenced (Self); pragma Warnings (On); -- WAG:3.14 begin Ensure_Initialization; pragma Debug (O ("resume_connection in proxypullconsumer")); Enter (Peer_Mutex); Leave (Peer_Mutex); end Resume_Connection; ---------------- -- Get_MyType -- ---------------- function Get_MyType (Self : access Object) return CosNotifyChannelAdmin.ProxyType is MyType : CosNotifyChannelAdmin.ProxyType; begin Ensure_Initialization; pragma Debug (O ("get_mytype in proxypullconsumer")); Enter (Peer_Mutex); MyType := Self.X.MyType; Leave (Peer_Mutex); return MyType; end Get_MyType; ----------------- -- Get_MyAdmin -- ----------------- function Get_MyAdmin (Self : access Object) return CosNotifyChannelAdmin.SupplierAdmin_Forward.Ref is MyAdmin : CosNotifyChannelAdmin.SupplierAdmin_Forward.Ref; begin Ensure_Initialization; pragma Debug (O ("get_myadmin in proxypullconsumer")); Enter (Peer_Mutex); MyAdmin := Convert.To_Forward (Self.X.Admin); Leave (Peer_Mutex); return MyAdmin; end Get_MyAdmin; ------------------------------- -- Obtain_Subscription_Types -- ------------------------------- function Obtain_Subscription_Types (Self : access Object; Mode : CosNotifyChannelAdmin.ObtainInfoMode) return CosNotification.EventTypeSeq is pragma Warnings (Off); -- WAG:3.14 pragma Unreferenced (Self, Mode); pragma Warnings (On); -- WAG:3.14 MySeq : CosNotification.EventTypeSeq; begin Ensure_Initialization; pragma Debug (O ("obtain_subscription_types in proxypullconsumer")); Enter (Peer_Mutex); Leave (Peer_Mutex); return MySeq; end Obtain_Subscription_Types; ------------------------ -- Validate_Event_QoS -- ------------------------ procedure Validate_Event_QoS (Self : access Object; Required_QoS : CosNotification.QoSProperties; Available_QoS : out CosNotification.NamedPropertyRangeSeq) is pragma Warnings (Off); -- WAG:3.14 pragma Unreferenced (Self, Required_QoS, Available_QoS); pragma Warnings (On); -- WAG:3.14 begin Ensure_Initialization; pragma Debug (O ("validate_event_qos in proxypullconsumer")); Enter (Peer_Mutex); Leave (Peer_Mutex); end Validate_Event_QoS; ------------- -- Get_QoS -- ------------- function Get_QoS (Self : access Object) return CosNotification.QoSProperties is MyQoS : CosNotification.QoSProperties; begin Ensure_Initialization; pragma Debug (O ("get_qos in proxypullconsumer")); Enter (Peer_Mutex); MyQoS := Self.X.QoSPropSeq; Leave (Peer_Mutex); return MyQoS; end Get_QoS; ------------- -- Set_QoS -- ------------- procedure Set_QoS (Self : access Object; QoS : CosNotification.QoSProperties) is MyProp : CosNotification.Property; MyError : CosNotification.PropertyError; MyErrCode : CosNotification.QoSError_code; MyRange : CosNotification.PropertyRange; MyErrorSeq : CosNotification.PropertyErrorSeq; SeqLen : Integer; begin Ensure_Initialization; pragma Debug (O ("set_qos in proxypullconsumer")); SeqLen := Length (QoS); for Index in 1 .. SeqLen loop MyProp := Get_Element (QoS, Index); if MyProp.name = "EventReliability" then MyErrCode := UNAVAILABLE_PROPERTY; MyRange := (To_Any (CORBA.Short (0)), To_Any (CORBA.Short (0))); MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); elsif MyProp.name = "ConnectionReliability" then if CORBA.Short'(From_Any (MyProp.value)) /= 0 and then CORBA.Short'(From_Any (MyProp.value)) /= 1 then MyErrCode := BAD_VALUE; MyRange := (To_Any (CORBA.Short (0)), To_Any (CORBA.Short (0))); MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); end if; elsif MyProp.name = "Priority" then if CORBA.Short'(From_Any (MyProp.value)) not in -32_767 .. 32_767 then MyErrCode := BAD_VALUE; MyRange := (To_Any (CORBA.Short (-32767)), To_Any (CORBA.Short (32767))); MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); end if; elsif MyProp.name = "StartTime" then MyErrCode := UNAVAILABLE_PROPERTY; MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); elsif MyProp.name = "StopTime" then MyErrCode := UNAVAILABLE_PROPERTY; MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); elsif MyProp.name = "Timeout" then MyErrCode := UNSUPPORTED_PROPERTY; MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); elsif MyProp.name = "OrderPolicy" then if CORBA.Short'(From_Any (MyProp.value)) /= 0 and then CORBA.Short'(From_Any (MyProp.value)) /= 1 and then CORBA.Short'(From_Any (MyProp.value)) /= 2 and then CORBA.Short'(From_Any (MyProp.value)) /= 3 then MyErrCode := BAD_VALUE; MyRange := (To_Any (CORBA.Short (0)), To_Any (CORBA.Short (3))); MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); end if; elsif MyProp.name = "DiscardPolicy" then if CORBA.Short'(From_Any (MyProp.value)) /= 0 and then CORBA.Short'(From_Any (MyProp.value)) /= 1 and then CORBA.Short'(From_Any (MyProp.value)) /= 2 and then CORBA.Short'(From_Any (MyProp.value)) /= 3 and then CORBA.Short'(From_Any (MyProp.value)) /= 4 then MyErrCode := BAD_VALUE; MyRange := (To_Any (CORBA.Short (0)), To_Any (CORBA.Short (4))); MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); end if; elsif MyProp.name = "MaximumBatchSize" then MyErrCode := UNSUPPORTED_PROPERTY; MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); elsif MyProp.name = "PacingInterval" then MyErrCode := UNSUPPORTED_PROPERTY; MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); elsif MyProp.name = "StartTimeSupported" then MyErrCode := UNSUPPORTED_PROPERTY; MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); elsif MyProp.name = "StopTimeSupported" then MyErrCode := UNSUPPORTED_PROPERTY; MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); elsif MyProp.name = "MaxEventsPerConsumer" then MyErrCode := UNSUPPORTED_PROPERTY; MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); else MyErrCode := BAD_PROPERTY; MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); end if; end loop; if Length (MyErrorSeq) > 0 then CosNotification.Helper.Raise_UnsupportedQoS ((CORBA.IDL_Exception_Members with qos_err => MyErrorSeq)); end if; SeqLen := Length (QoS); Enter (Peer_Mutex); for Index in 1 .. SeqLen loop MyProp := Get_Element (QoS, Index); if MyProp.name = "ConnectionReliability" then Replace_Element (Self.X.QoSPropSeq, 2, MyProp); elsif MyProp.name = "Priority" then Replace_Element (Self.X.QoSPropSeq, 3, MyProp); elsif MyProp.name = "OrderPolicy" then Replace_Element (Self.X.QoSPropSeq, 4, MyProp); elsif MyProp.name = "DiscardPolicy" then Replace_Element (Self.X.QoSPropSeq, 5, MyProp); end if; end loop; Leave (Peer_Mutex); end Set_QoS; ------------------ -- Validate_QoS -- ------------------ procedure Validate_QoS (Self : access Object; Required_QoS : CosNotification.QoSProperties; Available_QoS : out CosNotification.NamedPropertyRangeSeq) is MyProp : CosNotification.Property; MyError : CosNotification.PropertyError; MyErrCode : CosNotification.QoSError_code; MyNamedRange : CosNotification.NamedPropertyRange; MyRange : CosNotification.PropertyRange; MyErrorSeq : CosNotification.PropertyErrorSeq; SeqLen : Integer; begin Ensure_Initialization; pragma Debug (O ("validate_qos in proxypullconsumer")); SeqLen := Length (Required_QoS); for Index in 1 .. SeqLen loop MyProp := Get_Element (Required_QoS, Index); if MyProp.name = "EventReliability" then MyErrCode := UNAVAILABLE_PROPERTY; MyRange := (To_Any (CORBA.Short (0)), To_Any (CORBA.Short (0))); MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); elsif MyProp.name = "ConnectionReliability" then if CORBA.Short'(From_Any (MyProp.value)) /= 0 and then CORBA.Short'(From_Any (MyProp.value)) /= 1 then MyErrCode := BAD_VALUE; MyRange := (To_Any (CORBA.Short (0)), To_Any (CORBA.Short (0))); MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); end if; elsif MyProp.name = "Priority" then if CORBA.Short'(From_Any (MyProp.value)) not in -32_767 .. 32_767 then MyErrCode := BAD_VALUE; MyRange := (To_Any (CORBA.Short (-32767)), To_Any (CORBA.Short (32767))); MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); end if; elsif MyProp.name = "StartTime" then MyErrCode := UNAVAILABLE_PROPERTY; MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); elsif MyProp.name = "StopTime" then MyErrCode := UNAVAILABLE_PROPERTY; MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); elsif MyProp.name = "Timeout" then MyErrCode := UNSUPPORTED_PROPERTY; MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); elsif MyProp.name = "OrderPolicy" then if CORBA.Short'(From_Any (MyProp.value)) /= 0 and then CORBA.Short'(From_Any (MyProp.value)) /= 1 and then CORBA.Short'(From_Any (MyProp.value)) /= 2 and then CORBA.Short'(From_Any (MyProp.value)) /= 3 then MyErrCode := BAD_VALUE; MyRange := (To_Any (CORBA.Short (0)), To_Any (CORBA.Short (3))); MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); end if; elsif MyProp.name = "DiscardPolicy" then if CORBA.Short'(From_Any (MyProp.value)) /= 0 and then CORBA.Short'(From_Any (MyProp.value)) /= 1 and then CORBA.Short'(From_Any (MyProp.value)) /= 2 and then CORBA.Short'(From_Any (MyProp.value)) /= 3 and then CORBA.Short'(From_Any (MyProp.value)) /= 4 then MyErrCode := BAD_VALUE; MyRange := (To_Any (CORBA.Short (0)), To_Any (CORBA.Short (4))); MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); end if; elsif MyProp.name = "MaximumBatchSize" then MyErrCode := UNSUPPORTED_PROPERTY; MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); elsif MyProp.name = "PacingInterval" then MyErrCode := UNSUPPORTED_PROPERTY; MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); elsif MyProp.name = "StartTimeSupported" then MyErrCode := UNSUPPORTED_PROPERTY; MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); elsif MyProp.name = "StopTimeSupported" then MyErrCode := UNSUPPORTED_PROPERTY; MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); elsif MyProp.name = "MaxEventsPerConsumer" then MyErrCode := UNSUPPORTED_PROPERTY; MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); else MyErrCode := BAD_PROPERTY; MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); end if; end loop; if Length (MyErrorSeq) > 0 then CosNotification.Helper.Raise_UnsupportedQoS ((CORBA.IDL_Exception_Members with qos_err => MyErrorSeq)); end if; Enter (Peer_Mutex); SeqLen := Length (Self.X.QoSPropSeq); for Index in 1 .. SeqLen loop MyProp := Get_Element (Self.X.QoSPropSeq, Index); if MyProp.name = "ConnectionReliability" then MyRange := (From_Any (MyProp.value), To_Any (CORBA.Short (0))); MyNamedRange := (MyProp.name, MyRange); Append (Available_QoS, MyNamedRange); elsif MyProp.name = "Priority" then MyRange := (To_Any (CORBA.Short (-32767)), To_Any (CORBA.Short (32767))); MyNamedRange := (MyProp.name, MyRange); Append (Available_QoS, MyNamedRange); elsif MyProp.name = "OrderPolicy" then MyRange := (To_Any (CORBA.Short (0)), To_Any (CORBA.Short (3))); MyNamedRange := (MyProp.name, MyRange); Append (Available_QoS, MyNamedRange); elsif MyProp.name = "DiscardPolicy" then MyRange := (To_Any (CORBA.Short (0)), To_Any (CORBA.Short (4))); MyNamedRange := (MyProp.name, MyRange); Append (Available_QoS, MyNamedRange); end if; end loop; Leave (Peer_Mutex); end Validate_QoS; ---------------- -- Add_Filter -- ---------------- function Add_Filter (Self : access Object; New_Filter : CosNotifyFilter.Filter.Ref) return CosNotifyFilter.FilterID is pragma Warnings (Off); -- WAG:3.14 pragma Unreferenced (Self, New_Filter); pragma Warnings (On); -- WAG:3.14 MyFilterID : CosNotifyFilter.FilterID; MyID : CORBA.Long; begin Ensure_Initialization; pragma Debug (O ("add_filter in proxypullconsumer")); Enter (Peer_Mutex); Leave (Peer_Mutex); MyID := 0; MyFilterID := CosNotifyFilter.FilterID (MyID); return MyFilterID; end Add_Filter; ------------------- -- Remove_Filter -- ------------------- procedure Remove_Filter (Self : access Object; Filter : CosNotifyFilter.FilterID) is pragma Warnings (Off); -- WAG:3.14 pragma Unreferenced (Self, Filter); pragma Warnings (On); -- WAG:3.14 begin Ensure_Initialization; pragma Debug (O ("remove_filter in proxypullconsumer")); Enter (Peer_Mutex); Leave (Peer_Mutex); end Remove_Filter; ---------------- -- Get_Filter -- ---------------- function Get_Filter (Self : access Object; Filter : CosNotifyFilter.FilterID) return CosNotifyFilter.Filter.Ref is pragma Warnings (Off); -- WAG:3.14 pragma Unreferenced (Self, Filter); pragma Warnings (On); -- WAG:3.14 MyFilter : CosNotifyFilter.Filter.Ref; begin Ensure_Initialization; pragma Debug (O ("get_filter in proxypullconsumer")); Enter (Peer_Mutex); Leave (Peer_Mutex); return MyFilter; end Get_Filter; --------------------- -- Get_All_Filters -- --------------------- function Get_All_Filters (Self : access Object) return CosNotifyFilter.FilterIDSeq is pragma Warnings (Off); -- WAG:3.14 pragma Unreferenced (Self); pragma Warnings (On); -- WAG:3.14 MyFilterSeq : CosNotifyFilter.FilterIDSeq; begin Ensure_Initialization; pragma Debug (O ("get_all_filters in proxypullconsumer")); Enter (Peer_Mutex); Leave (Peer_Mutex); return MyFilterSeq; end Get_All_Filters; ------------------------ -- Remove_All_Filters -- ------------------------ procedure Remove_All_Filters (Self : access Object) is pragma Warnings (Off); -- WAG:3.14 pragma Unreferenced (Self); pragma Warnings (On); -- WAG:3.14 begin Ensure_Initialization; pragma Debug (O ("remove_all_filters in proxypullconsumer")); Enter (Peer_Mutex); Leave (Peer_Mutex); end Remove_All_Filters; ------------------ -- Offer_Change -- ------------------ procedure Offer_Change (Self : access Object; Added : CosNotification.EventTypeSeq; Removed : CosNotification.EventTypeSeq) is pragma Warnings (Off); -- WAG:3.14 pragma Unreferenced (Self, Added, Removed); pragma Warnings (On); -- WAG:3.14 begin pragma Debug (O ("offer_change in proxypullconsumer")); Ensure_Initialization; Enter (Peer_Mutex); Leave (Peer_Mutex); end Offer_Change; ------------------------------ -- Disconnect_Pull_Consumer -- ------------------------------ procedure Disconnect_Pull_Consumer (Self : access Object) is Peer : CosEventComm.PullSupplier.Ref; Nil_Ref : CosEventComm.PullSupplier.Ref; begin pragma Debug (O ("disconnect proxypullconsumer")); Ensure_Initialization; Enter (Peer_Mutex); Peer := Self.X.Peer; Self.X.Peer := Nil_Ref; Leave (Peer_Mutex); if not CosEventComm.PullSupplier.Is_Nil (Peer) then CosEventComm.PullSupplier.disconnect_pull_supplier (Peer); end if; end Disconnect_Pull_Consumer; ------------ -- Create -- ------------ function Create (Admin : CosNotifyChannelAdmin.SupplierAdmin.Ref; Initial_QoS : CosNotification.QoSProperties; Ptype : CosNotifyChannelAdmin.ProxyType; Proxy_Id : CosNotifyChannelAdmin.ProxyID) return Object_Ptr is Consumer : Object_Ptr; My_Ref : ProxyPullConsumer.Ref; begin pragma Debug (O ("create proxypullconsumer")); Consumer := new Object; Consumer.X := new Proxy_Pull_Consumer_Record; Consumer.X.Admin := Admin; Consumer.X.MyId := Proxy_Id; Consumer.X.MyType := Ptype; Consumer.X.This := Consumer; Consumer.X.QoSPropSeq := Initial_QoS; Initiate_Servant (Servant (Consumer), My_Ref); return Consumer; end Create; end CosNotifyChannelAdmin.ProxyPullConsumer.Impl; polyorb-2.8~20110207.orig/cos/notification/cosnotifycomm-pushsupplier-impl.adb0000644000175000017500000001546111750740337026732 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- C O S N O T I F Y C O M M . P U S H S U P P L I E R . I M P L -- -- -- -- B o d y -- -- -- -- Copyright (C) 2003-2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with CosEventChannelAdmin.Helper; with CosEventComm.Helper; with CosEventComm.PushSupplier.Helper; with PolyORB.CORBA_P.Server_Tools; with PolyORB.Log; with PolyORB.Tasking.Mutexes; with CosNotifyComm.PushSupplier.Skel; pragma Warnings (Off, CosNotifyComm.PushSupplier.Skel); package body CosNotifyComm.PushSupplier.Impl is use PolyORB.CORBA_P.Server_Tools; use PolyORB.Tasking.Mutexes; use PolyORB.Log; package L is new PolyORB.Log.Facility_Log ("pushsupplier"); procedure O (Message : Standard.String; Level : Log_Level := Debug) renames L.Output; function C (Level : Log_Level := Debug) return Boolean renames L.Enabled; pragma Unreferenced (C); -- For conditional pragma Debug type Push_Supplier_Record is record This : Object_Ptr; Peer : CosNotifyChannelAdmin.ProxyPushConsumer.Ref; end record; --------------------------- -- Ensure_Initialization -- --------------------------- procedure Ensure_Initialization; pragma Inline (Ensure_Initialization); -- Ensure that the Mutexes are initialized T_Initialized : Boolean := False; Self_Mutex : Mutex_Access; procedure Ensure_Initialization is begin if not T_Initialized then Create (Self_Mutex); T_Initialized := True; end if; end Ensure_Initialization; ------------------------- -- Subscription_Change -- ------------------------- procedure Subscription_Change (Self : access Object; Added : CosNotification.EventTypeSeq; Removed : CosNotification.EventTypeSeq) is pragma Warnings (Off); -- WAG:3.14 pragma Unreferenced (Self, Added, Removed); pragma Warnings (On); -- WAG:3.14 begin Ensure_Initialization; pragma Debug (O ("subscription_change in pushsupplier")); Enter (Self_Mutex); Leave (Self_Mutex); end Subscription_Change; ------------------------------ -- Disconnect_Push_Supplier -- ------------------------------ procedure Disconnect_Push_Supplier (Self : access Object) is Peer : CosNotifyChannelAdmin.ProxyPushConsumer.Ref; Nil_Ref : CosNotifyChannelAdmin.ProxyPushConsumer.Ref; begin Ensure_Initialization; pragma Debug (O ("disconnect push supplier")); Enter (Self_Mutex); Peer := Self.X.Peer; Self.X.Peer := Nil_Ref; Leave (Self_Mutex); if not CosNotifyChannelAdmin.ProxyPushConsumer.Is_Nil (Peer) then CosNotifyChannelAdmin.ProxyPushConsumer.disconnect_push_consumer (Peer); end if; end Disconnect_Push_Supplier; ------------ -- Create -- ------------ function Create return Object_Ptr is Supplier : Object_Ptr; My_Ref : PushSupplier.Ref; My_Peer : CosNotifyChannelAdmin.ProxyPushConsumer.Ref; begin pragma Debug (O ("create pushsupplier")); Supplier := new Object; Supplier.X := new Push_Supplier_Record; Supplier.X.This := Supplier; Supplier.X.Peer := My_Peer; Initiate_Servant (PortableServer.Servant (Supplier), My_Ref); return Supplier; end Create; ------------------------------------- -- Connect_Any_Proxy_Push_Consumer -- ------------------------------------- procedure Connect_Any_Proxy_Push_Consumer (Self : access Object; Proxy : CosNotifyChannelAdmin.ProxyPushConsumer.Ref) is My_Ref : PushSupplier.Ref; Sup_Ref : CosEventComm.PushSupplier.Ref; begin Ensure_Initialization; pragma Debug (O ("connect_any_proxy_push_consumer in pushsupplier")); Enter (Self_Mutex); if not CosNotifyChannelAdmin.ProxyPushConsumer.Is_Nil (Self.X.Peer) then Leave (Self_Mutex); CosEventChannelAdmin.Helper.Raise_AlreadyConnected ((CORBA.IDL_Exception_Members with null record)); end if; Self.X.Peer := Proxy; Servant_To_Reference (PortableServer.Servant (Self.X.This), My_Ref); Leave (Self_Mutex); Sup_Ref := CosEventComm.PushSupplier.Helper.To_Ref (My_Ref); CosNotifyChannelAdmin.ProxyPushConsumer.connect_any_push_supplier (Proxy, Sup_Ref); end Connect_Any_Proxy_Push_Consumer; ---------- -- Push -- ---------- procedure Push (Self : access Object; Data : CORBA.Any) is My_Peer : CosNotifyChannelAdmin.ProxyPushConsumer.Ref; begin Ensure_Initialization; pragma Debug (O ("push new data to pushsupplier")); Enter (Self_Mutex); My_Peer := Self.X.Peer; Leave (Self_Mutex); if CosNotifyChannelAdmin.ProxyPushConsumer.Is_Nil (My_Peer) then CosEventComm.Helper.Raise_Disconnected ((CORBA.IDL_Exception_Members with null record)); end if; CosNotifyChannelAdmin.ProxyPushConsumer.push (My_Peer, Data); end Push; end CosNotifyComm.PushSupplier.Impl; polyorb-2.8~20110207.orig/cos/notification/cosnotifychanneladmin-proxysupplier-impl.adb0000644000175000017500000003034111750740337030614 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- COSNOTIFYCHANNELADMIN.PROXYSUPPLIER.IMPL -- -- -- -- B o d y -- -- -- -- Copyright (C) 2003-2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with PolyORB.CORBA_P.Server_Tools; with PolyORB.Log; with PolyORB.Tasking.Mutexes; with CosNotifyChannelAdmin.ProxySupplier.Skel; pragma Warnings (Off, CosNotifyChannelAdmin.ProxySupplier.Skel); package body CosNotifyChannelAdmin.ProxySupplier.Impl is use PolyORB.CORBA_P.Server_Tools; use PolyORB.Tasking.Mutexes; use PolyORB.Log; package L is new PolyORB.Log.Facility_Log ("proxysupplier"); procedure O (Message : Standard.String; Level : Log_Level := Debug) renames L.Output; function C (Level : Log_Level := Debug) return Boolean renames L.Enabled; pragma Unreferenced (C); -- For conditional pragma Debug type Proxy_Supplier_Record is record This : Object_Ptr; end record; --------------------------- -- Ensure_Initialization -- --------------------------- procedure Ensure_Initialization; pragma Inline (Ensure_Initialization); -- Ensure that the Mutexes are initialized T_Initialized : Boolean := False; Self_Mutex : Mutex_Access; procedure Ensure_Initialization is begin if not T_Initialized then Create (Self_Mutex); T_Initialized := True; end if; end Ensure_Initialization; ---------------- -- Get_MyType -- ---------------- function Get_MyType (Self : access Object) return CosNotifyChannelAdmin.ProxyType is pragma Warnings (Off); -- WAG:3.14 pragma Unreferenced (Self); pragma Warnings (On); -- WAG:3.14 MyType : CosNotifyChannelAdmin.ProxyType; begin pragma Debug (O ("get_mytype in proxysupplier")); Ensure_Initialization; Enter (Self_Mutex); Leave (Self_Mutex); MyType := PUSH_ANY; return MyType; end Get_MyType; ----------------- -- Get_MyAdmin -- ----------------- function Get_MyAdmin (Self : access Object) return CosNotifyChannelAdmin.ConsumerAdmin_Forward.Ref is pragma Warnings (Off); -- WAG:3.14 pragma Unreferenced (Self); pragma Warnings (On); -- WAG:3.14 MyAdmin : CosNotifyChannelAdmin.ConsumerAdmin_Forward.Ref; begin pragma Debug (O ("get_myadmin in proxysupplier")); Ensure_Initialization; Enter (Self_Mutex); Leave (Self_Mutex); return MyAdmin; end Get_MyAdmin; ------------------------- -- Get_Priority_Filter -- ------------------------- function Get_Priority_Filter (Self : access Object) return CosNotifyFilter.MappingFilter.Ref is pragma Warnings (Off); -- WAG:3.14 pragma Unreferenced (Self); pragma Warnings (On); -- WAG:3.14 MyFilter : CosNotifyFilter.MappingFilter.Ref; begin pragma Debug (O ("get_priority_filter in proxysupplier")); Ensure_Initialization; Enter (Self_Mutex); Leave (Self_Mutex); return MyFilter; end Get_Priority_Filter; ------------------------- -- Set_Priority_Filter -- ------------------------- procedure Set_Priority_Filter (Self : access Object; To : CosNotifyFilter.MappingFilter.Ref) is pragma Warnings (Off); -- WAG:3.14 pragma Unreferenced (Self, To); pragma Warnings (On); -- WAG:3.14 begin pragma Debug (O ("set_priority_filter in proxysupplier")); Ensure_Initialization; Enter (Self_Mutex); Leave (Self_Mutex); end Set_Priority_Filter; ------------------------- -- Get_Lifetime_Filter -- ------------------------- function Get_Lifetime_Filter (Self : access Object) return CosNotifyFilter.MappingFilter.Ref is pragma Warnings (Off); -- WAG:3.14 pragma Unreferenced (Self); pragma Warnings (On); -- WAG:3.14 MyFilter : CosNotifyFilter.MappingFilter.Ref; begin pragma Debug (O ("get_lifetime_filter in proxysupplier")); Ensure_Initialization; Enter (Self_Mutex); Leave (Self_Mutex); return MyFilter; end Get_Lifetime_Filter; ------------------------- -- Set_Lifetime_Filter -- ------------------------- procedure Set_Lifetime_Filter (Self : access Object; To : CosNotifyFilter.MappingFilter.Ref) is pragma Warnings (Off); -- WAG:3.14 pragma Unreferenced (Self, To); pragma Warnings (On); -- WAG:3.14 begin pragma Debug (O ("set_lifetime_filter in proxysupplier")); Ensure_Initialization; Enter (Self_Mutex); Leave (Self_Mutex); end Set_Lifetime_Filter; -------------------------- -- Obtain_Offered_Types -- -------------------------- function Obtain_Offered_Types (Self : access Object; Mode : CosNotifyChannelAdmin.ObtainInfoMode) return CosNotification.EventTypeSeq is pragma Warnings (Off); -- WAG:3.14 pragma Unreferenced (Self, Mode); pragma Warnings (On); -- WAG:3.14 MySeq : CosNotification.EventTypeSeq; begin pragma Debug (O ("obtain_offered_types in proxysupplier")); Ensure_Initialization; Enter (Self_Mutex); Leave (Self_Mutex); return MySeq; end Obtain_Offered_Types; ------------------------ -- Validate_Event_QoS -- ------------------------ procedure Validate_Event_QoS (Self : access Object; Required_QoS : CosNotification.QoSProperties; Available_QoS : out CosNotification.NamedPropertyRangeSeq) is pragma Warnings (Off); -- WAG:3.14 pragma Unreferenced (Self, Required_QoS, Available_QoS); pragma Warnings (On); -- WAG:3.14 begin pragma Debug (O ("validate_event_qos in proxysupplier")); Ensure_Initialization; Enter (Self_Mutex); Leave (Self_Mutex); end Validate_Event_QoS; ------------- -- Get_QoS -- ------------- function Get_QoS (Self : access Object) return CosNotification.QoSProperties is pragma Warnings (Off); -- WAG:3.14 pragma Unreferenced (Self); pragma Warnings (On); -- WAG:3.14 MyProp : CosNotification.QoSProperties; begin pragma Debug (O ("get_qos in proxysupplier")); Ensure_Initialization; Enter (Self_Mutex); Leave (Self_Mutex); return MyProp; end Get_QoS; ------------- -- Set_QoS -- ------------- procedure Set_QoS (Self : access Object; QoS : CosNotification.QoSProperties) is pragma Warnings (Off); -- WAG:3.14 pragma Unreferenced (Self, QoS); pragma Warnings (On); -- WAG:3.14 begin pragma Debug (O ("set_qos in proxysupplier")); Ensure_Initialization; Enter (Self_Mutex); Leave (Self_Mutex); end Set_QoS; ------------------ -- Validate_QoS -- ------------------ procedure Validate_QoS (Self : access Object; Required_QoS : CosNotification.QoSProperties; Available_QoS : out CosNotification.NamedPropertyRangeSeq) is pragma Warnings (Off); -- WAG:3.14 pragma Unreferenced (Self, Required_QoS, Available_QoS); pragma Warnings (On); -- WAG:3.14 begin pragma Debug (O ("validate_qos in proxysupplier")); Ensure_Initialization; Enter (Self_Mutex); Leave (Self_Mutex); end Validate_QoS; ---------------- -- Add_Filter -- ---------------- function Add_Filter (Self : access Object; New_Filter : CosNotifyFilter.Filter.Ref) return CosNotifyFilter.FilterID is pragma Warnings (Off); -- WAG:3.14 pragma Unreferenced (Self, New_Filter); pragma Warnings (On); -- WAG:3.14 MyFilterID : CosNotifyFilter.FilterID; MyID : CORBA.Long; begin pragma Debug (O ("add_filter in proxysupplier")); Ensure_Initialization; Enter (Self_Mutex); Leave (Self_Mutex); MyID := 0; MyFilterID := CosNotifyFilter.FilterID (MyID); return MyFilterID; end Add_Filter; ------------------- -- Remove_Filter -- ------------------- procedure Remove_Filter (Self : access Object; Filter : CosNotifyFilter.FilterID) is pragma Warnings (Off); -- WAG:3.14 pragma Unreferenced (Self, Filter); pragma Warnings (On); -- WAG:3.14 begin pragma Debug (O ("remove_filter in proxysupplier")); Ensure_Initialization; Enter (Self_Mutex); Leave (Self_Mutex); end Remove_Filter; ---------------- -- Get_Filter -- ---------------- function Get_Filter (Self : access Object; Filter : CosNotifyFilter.FilterID) return CosNotifyFilter.Filter.Ref is pragma Warnings (Off); -- WAG:3.14 pragma Unreferenced (Self, Filter); pragma Warnings (On); -- WAG:3.14 MyFilter : CosNotifyFilter.Filter.Ref; begin pragma Debug (O ("get_filter in proxysupplier")); Ensure_Initialization; Enter (Self_Mutex); Leave (Self_Mutex); return MyFilter; end Get_Filter; --------------------- -- Get_All_Filters -- --------------------- function Get_All_Filters (Self : access Object) return CosNotifyFilter.FilterIDSeq is pragma Warnings (Off); -- WAG:3.14 pragma Unreferenced (Self); pragma Warnings (On); -- WAG:3.14 MyFilterSeq : CosNotifyFilter.FilterIDSeq; begin pragma Debug (O ("get_all_filters in proxysupplier")); Ensure_Initialization; Enter (Self_Mutex); Leave (Self_Mutex); return MyFilterSeq; end Get_All_Filters; ------------------------ -- Remove_All_Filters -- ------------------------ procedure Remove_All_Filters (Self : access Object) is pragma Warnings (Off); -- WAG:3.14 pragma Unreferenced (Self); pragma Warnings (On); -- WAG:3.14 begin pragma Debug (O ("remove_all_filters in proxysupplier")); Ensure_Initialization; Enter (Self_Mutex); Leave (Self_Mutex); end Remove_All_Filters; ------------ -- Create -- ------------ function Create return Object_Ptr is Supplier : Object_Ptr; My_Ref : ProxySupplier.Ref; begin pragma Debug (O ("create proxysupplier")); Supplier := new Object; Supplier.X := new Proxy_Supplier_Record; Supplier.X.This := Supplier; Initiate_Servant (PortableServer.Servant (Supplier), My_Ref); return Supplier; end Create; end CosNotifyChannelAdmin.ProxySupplier.Impl; polyorb-2.8~20110207.orig/cos/notification/cosnotification-adminpropertiesadmin-impl.ads0000644000175000017500000000551111750740337030723 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- COSNOTIFICATION.ADMINPROPERTIESADMIN.IMPL -- -- -- -- S p e c -- -- -- -- Copyright (C) 2003-2008, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by ACT Europe. -- -- (email: sales@act-europe.fr) -- -- -- ------------------------------------------------------------------------------ -- with CORBA; with PortableServer; package CosNotification.AdminPropertiesAdmin.Impl is type Object is new PortableServer.Servant_Base with private; type Object_Ptr is access all Object'Class; -- IDL operations function Get_Admin (Self : access Object) return CosNotification.AdminProperties; procedure Set_Admin (Self : access Object; Admin : CosNotification.AdminProperties); ---------------------- -- PolyORB specific -- ---------------------- function Create return Object_Ptr; private type AdminProperties_Admin_Record; type AdminProperties_Admin_Access is access AdminProperties_Admin_Record; type Object is new PortableServer.Servant_Base with record X : AdminProperties_Admin_Access; end record; end CosNotification.AdminPropertiesAdmin.Impl; polyorb-2.8~20110207.orig/cos/notification/cosnotifyfilter-mappingfilter-impl.adb0000644000175000017500000002324211750740337027356 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- C O S N O T I F Y F I L T E R . M A P P I N G F I L T E R . I M P L -- -- -- -- B o d y -- -- -- -- Copyright (C) 2003-2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with PolyORB.CORBA_P.Server_Tools; with PolyORB.Log; with PolyORB.Tasking.Mutexes; with CosNotifyFilter.MappingFilter.Skel; pragma Warnings (Off, CosNotifyFilter.MappingFilter.Skel); package body CosNotifyFilter.MappingFilter.Impl is use PolyORB.CORBA_P.Server_Tools; use PolyORB.Tasking.Mutexes; use PolyORB.Log; package L is new PolyORB.Log.Facility_Log ("mappingfilter"); procedure O (Message : Standard.String; Level : Log_Level := Debug) renames L.Output; function C (Level : Log_Level := Debug) return Boolean renames L.Enabled; pragma Unreferenced (C); -- For conditional pragma Debug type Mapping_Filter_Record is record This : Object_Ptr; end record; --------------------------- -- Ensure_Initialization -- --------------------------- procedure Ensure_Initialization; pragma Inline (Ensure_Initialization); -- Ensure that the Mutexes are initialized T_Initialized : Boolean := False; Self_Mutex : Mutex_Access; procedure Ensure_Initialization is begin if not T_Initialized then Create (Self_Mutex); T_Initialized := True; end if; end Ensure_Initialization; ---------------------------- -- Get_Constraint_Grammar -- ---------------------------- function Get_Constraint_Grammar (Self : access Object) return CORBA.String is pragma Unreferenced (Self); MyGrammar : CORBA.String; begin pragma Debug (O ("get_constraint_grammar in mappingfilter")); Ensure_Initialization; Enter (Self_Mutex); Leave (Self_Mutex); return MyGrammar; end Get_Constraint_Grammar; -------------------- -- Get_Value_Type -- -------------------- -- NK Should get it checked because of TypeCode Problems function Get_Value_Type (Self : access Object) return CORBA.TypeCode.Object is pragma Unreferenced (Self); MyObj : CORBA.TypeCode.Object; begin pragma Debug (O ("get_value_type in mappingfilter")); Ensure_Initialization; Enter (Self_Mutex); Leave (Self_Mutex); return MyObj; end Get_Value_Type; ----------------------- -- Get_Default_Value -- ----------------------- function Get_Default_Value (Self : access Object) return CORBA.Any is pragma Unreferenced (Self); MyValue : CORBA.Any; begin pragma Debug (O ("get_default_value in mappingfilter")); Ensure_Initialization; Enter (Self_Mutex); Leave (Self_Mutex); return MyValue; end Get_Default_Value; ----------------------------- -- Add_Mapping_Constraints -- ----------------------------- function Add_Mapping_Constraints (Self : access Object; Pair_List : CosNotifyFilter.MappingConstraintPairSeq) return CosNotifyFilter.MappingConstraintInfoSeq is pragma Unreferenced (Self, Pair_List); MySeq : CosNotifyFilter.MappingConstraintInfoSeq; begin pragma Debug (O ("add_mapping_constraints in mappingfilter")); Ensure_Initialization; Enter (Self_Mutex); Leave (Self_Mutex); return MySeq; end Add_Mapping_Constraints; -------------------------------- -- Modify_Mapping_Constraints -- -------------------------------- procedure Modify_Mapping_Constraints (Self : access Object; Del_List : CosNotifyFilter.ConstraintIDSeq; Modify_List : CosNotifyFilter.MappingConstraintInfoSeq) is pragma Unreferenced (Self, Del_List, Modify_List); begin pragma Debug (O ("modify_mapping_constraints in mappingfilter")); Ensure_Initialization; Enter (Self_Mutex); Leave (Self_Mutex); end Modify_Mapping_Constraints; ----------------------------- -- Get_Mapping_Constraints -- ----------------------------- function Get_Mapping_Constraints (Self : access Object; Id_List : CosNotifyFilter.ConstraintIDSeq) return CosNotifyFilter.MappingConstraintInfoSeq is pragma Unreferenced (Self, Id_List); MySeq : CosNotifyFilter.MappingConstraintInfoSeq; begin pragma Debug (O ("get_mapping_constraints in mappingfilter")); Ensure_Initialization; Enter (Self_Mutex); Leave (Self_Mutex); return MySeq; end Get_Mapping_Constraints; --------------------------------- -- Get_All_Mapping_Constraints -- --------------------------------- function Get_All_Mapping_Constraints (Self : access Object) return CosNotifyFilter.MappingConstraintInfoSeq is pragma Unreferenced (Self); MySeq : CosNotifyFilter.MappingConstraintInfoSeq; begin pragma Debug (O ("get_all_mapping_constraints in mappingfilter")); Ensure_Initialization; Enter (Self_Mutex); Leave (Self_Mutex); return MySeq; end Get_All_Mapping_Constraints; ------------------------------------ -- Remove_All_Mapping_Constraints -- ------------------------------------ procedure Remove_All_Mapping_Constraints (Self : access Object) is pragma Unreferenced (Self); begin pragma Debug (O ("remove_all_mapping_constraints in mappingfilter")); Ensure_Initialization; Enter (Self_Mutex); Leave (Self_Mutex); end Remove_All_Mapping_Constraints; ------------- -- Destroy -- ------------- procedure Destroy (Self : access Object) is pragma Unreferenced (Self); begin pragma Debug (O ("destroy in mappingfilter")); Ensure_Initialization; Enter (Self_Mutex); Leave (Self_Mutex); end Destroy; ----------- -- Match -- ----------- procedure Match (Self : access Object; Filterable_Data : CORBA.Any; Result_To_Set : out CORBA.Any; Returns : out CORBA.Boolean) is pragma Unreferenced (Self, Filterable_Data); ResSet : CORBA.Any; begin pragma Debug (O ("match in mappingfilter")); Ensure_Initialization; Enter (Self_Mutex); Leave (Self_Mutex); Result_To_Set := ResSet; Returns := True; end Match; ---------------------- -- Match_Structured -- ---------------------- procedure Match_Structured (Self : access Object; Filterable_Data : CosNotification.StructuredEvent; Result_To_Set : out CORBA.Any; Returns : out CORBA.Boolean) is pragma Unreferenced (Self, Filterable_Data); ResSet : CORBA.Any; begin pragma Debug (O ("match_structured in mappingfilter")); Ensure_Initialization; Enter (Self_Mutex); Leave (Self_Mutex); Result_To_Set := ResSet; Returns := True; end Match_Structured; ----------------- -- Match_Typed -- ----------------- procedure Match_Typed (Self : access Object; Filterable_Data : CosNotification.PropertySeq; Result_To_Set : out CORBA.Any; Returns : out CORBA.Boolean) is pragma Unreferenced (Self, Filterable_Data); ResSet : CORBA.Any; begin pragma Debug (O ("match_typed in mappingfilter")); Ensure_Initialization; Enter (Self_Mutex); Leave (Self_Mutex); Result_To_Set := ResSet; Returns := True; end Match_Typed; ------------ -- Create -- ------------ function Create return Object_Ptr is Filter : Object_Ptr; My_Ref : CosNotifyFilter.MappingFilter.Ref; begin pragma Debug (O ("create mappingfilter")); Filter := new Object; Filter.X := new Mapping_Filter_Record; Filter.X.This := Filter; Initiate_Servant (PortableServer.Servant (Filter), My_Ref); return Filter; end Create; end CosNotifyFilter.MappingFilter.Impl; polyorb-2.8~20110207.orig/cos/notification/cosnotifycomm-structuredpullconsumer-impl.adb0000644000175000017500000001753411750740337031047 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- COSNOTIFYCOMM.STRUCTUREDPULLCONSUMER.IMPL -- -- -- -- B o d y -- -- -- -- Copyright (C) 2003-2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with CosEventChannelAdmin.Helper; with CosEventComm.Helper; with PolyORB.CORBA_P.Server_Tools; with PolyORB.Log; with PolyORB.Tasking.Mutexes; with CosNotifyComm.StructuredPullConsumer.Skel; pragma Warnings (Off, CosNotifyComm.StructuredPullConsumer.Skel); package body CosNotifyComm.StructuredPullConsumer.Impl is use PolyORB.CORBA_P.Server_Tools; use PolyORB.Tasking.Mutexes; use PolyORB.Log; package L is new PolyORB.Log.Facility_Log ("structuredpullconsumer"); procedure O (Message : Standard.String; Level : Log_Level := Debug) renames L.Output; function C (Level : Log_Level := Debug) return Boolean renames L.Enabled; pragma Unreferenced (C); -- For conditional pragma Debug type Structured_Pull_Consumer_Record is record This : Object_Ptr; Peer : CosNotifyChannelAdmin.StructuredProxyPullSupplier.Ref; end record; --------------------------- -- Ensure_Initialization -- --------------------------- procedure Ensure_Initialization; pragma Inline (Ensure_Initialization); -- Ensure that the Mutexes are initialized T_Initialized : Boolean := False; Self_Mutex : Mutex_Access; procedure Ensure_Initialization is begin if not T_Initialized then Create (Self_Mutex); T_Initialized := True; end if; end Ensure_Initialization; ----------------------------------------- -- Disconnect_Structured_Pull_Consumer -- ----------------------------------------- procedure Disconnect_Structured_Pull_Consumer (Self : access Object) is Peer : CosNotifyChannelAdmin.StructuredProxyPullSupplier.Ref; Nil_Ref : CosNotifyChannelAdmin.StructuredProxyPullSupplier.Ref; begin Ensure_Initialization; pragma Debug (O ("disconnect structuredpullconsumer")); Enter (Self_Mutex); Peer := Self.X.Peer; Self.X.Peer := Nil_Ref; Leave (Self_Mutex); if not CosNotifyChannelAdmin.StructuredProxyPullSupplier.Is_Nil (Peer) then CosNotifyChannelAdmin.StructuredProxyPullSupplier. disconnect_structured_pull_supplier (Peer); end if; end Disconnect_Structured_Pull_Consumer; ------------------ -- Offer_Change -- ------------------ procedure Offer_Change (Self : access Object; Added : CosNotification.EventTypeSeq; Removed : CosNotification.EventTypeSeq) is pragma Warnings (Off); -- WAG:3.14 pragma Unreferenced (Self, Added, Removed); pragma Warnings (On); -- WAG:3.14 begin Ensure_Initialization; pragma Debug (O ("offer_change in structuredpullconsumer")); Enter (Self_Mutex); Leave (Self_Mutex); end Offer_Change; -------------------------------------------- -- Connect_Structured_Proxy_Pull_Supplier -- -------------------------------------------- procedure Connect_Structured_Proxy_Pull_Supplier (Self : access Object; Proxy : CosNotifyChannelAdmin.StructuredProxyPullSupplier.Ref) is My_Ref : StructuredPullConsumer.Ref; begin Ensure_Initialization; pragma Debug (O ("connect_structured_proxy_pull_supplier in structuredpullconsumer")); Enter (Self_Mutex); if not CosNotifyChannelAdmin.StructuredProxyPullSupplier.Is_Nil (Self.X.Peer) then Leave (Self_Mutex); CosEventChannelAdmin.Helper.Raise_AlreadyConnected ((CORBA.IDL_Exception_Members with null record)); end if; Self.X.Peer := Proxy; Servant_To_Reference (PortableServer.Servant (Self.X.This), My_Ref); Leave (Self_Mutex); CosNotifyChannelAdmin.StructuredProxyPullSupplier. connect_structured_pull_consumer (Proxy, My_Ref); end Connect_Structured_Proxy_Pull_Supplier; ------------ -- Create -- ------------ function Create return Object_Ptr is Consumer : Object_Ptr; My_Ref : StructuredPullConsumer.Ref; Peer_Ref : CosNotifyChannelAdmin.StructuredProxyPullSupplier.Ref; begin pragma Debug (O ("create structuredpullconsumer")); Consumer := new Object; Consumer.X := new Structured_Pull_Consumer_Record; Consumer.X.This := Consumer; Consumer.X.Peer := Peer_Ref; Initiate_Servant (PortableServer.Servant (Consumer), My_Ref); return Consumer; end Create; ---------- -- Pull -- ---------- function Pull (Self : access Object) return CosNotification.StructuredEvent is Peer : CosNotifyChannelAdmin.StructuredProxyPullSupplier.Ref; begin Ensure_Initialization; pragma Debug (O ("pull structured event from structuredpullconsumer")); Enter (Self_Mutex); Peer := Self.X.Peer; Leave (Self_Mutex); if CosNotifyChannelAdmin.StructuredProxyPullSupplier.Is_Nil (Peer) then CosEventComm.Helper.Raise_Disconnected ((CORBA.IDL_Exception_Members with null record)); end if; return CosNotifyChannelAdmin.StructuredProxyPullSupplier. pull_structured_event (Peer); end Pull; -------------- -- Try_Pull -- -------------- procedure Try_Pull (Self : access Object; Done : out CORBA.Boolean; Returns : out CosNotification.StructuredEvent) is Peer : CosNotifyChannelAdmin.StructuredProxyPullSupplier.Ref; begin pragma Debug (O ("try to pull structured event from structuredpullconsumer")); Ensure_Initialization; Enter (Self_Mutex); Peer := Self.X.Peer; Leave (Self_Mutex); if CosNotifyChannelAdmin.StructuredProxyPullSupplier.Is_Nil (Peer) then CosEventComm.Helper.Raise_Disconnected ((CORBA.IDL_Exception_Members with null record)); end if; CosNotifyChannelAdmin.StructuredProxyPullSupplier. try_pull_structured_event (Peer, Done, Returns); end Try_Pull; end CosNotifyComm.StructuredPullConsumer.Impl; polyorb-2.8~20110207.orig/cos/notification/cosnotifyfilter-filteradmin-impl.ads0000644000175000017500000000614311750740337027035 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- C O S N O T I F Y F I L T E R . F I L T E R A D M I N . I M P L -- -- -- -- S p e c -- -- -- -- Copyright (C) 2003-2008, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by ACT Europe. -- -- (email: sales@act-europe.fr) -- -- -- ------------------------------------------------------------------------------ -- with CORBA; with PortableServer; package CosNotifyFilter.FilterAdmin.Impl is type Object is new PortableServer.Servant_Base with private; type Object_Ptr is access all Object'Class; -- IDL operations function Add_Filter (Self : access Object; New_Filter : CosNotifyFilter.Filter.Ref) return CosNotifyFilter.FilterID; procedure Remove_Filter (Self : access Object; Filter : CosNotifyFilter.FilterID); function Get_Filter (Self : access Object; Filter : CosNotifyFilter.FilterID) return CosNotifyFilter.Filter.Ref; function Get_All_Filters (Self : access Object) return CosNotifyFilter.FilterIDSeq; procedure Remove_All_Filters (Self : access Object); ---------------------- -- PolyORB specific -- ---------------------- function Create return Object_Ptr; private type Filter_Admin_Record; type Filter_Admin_Access is access Filter_Admin_Record; type Object is new PortableServer.Servant_Base with record X : Filter_Admin_Access; end record; end CosNotifyFilter.FilterAdmin.Impl; polyorb-2.8~20110207.orig/cos/notification/cosnotifyfilter-filterfactory-impl.ads0000644000175000017500000000567311750740337027423 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- COSNOTIFYFILTER.FILTERFACTORY.IMPL -- -- -- -- S p e c -- -- -- -- Copyright (C) 2003-2008, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by ACT Europe. -- -- (email: sales@act-europe.fr) -- -- -- ------------------------------------------------------------------------------ -- with CORBA; with PortableServer; package CosNotifyFilter.FilterFactory.Impl is type Object is new PortableServer.Servant_Base with private; type Object_Ptr is access all Object'Class; -- IDL operations function Create_Filter (Self : access Object; Constraint_Grammar : CORBA.String) return CosNotifyFilter.Filter.Ref; function Create_Mapping_Filter (Self : access Object; Constraint_Grammar : CORBA.String; Default_Value : CORBA.Any) return CosNotifyFilter.MappingFilter.Ref; ---------------------- -- PolyORB specific -- ---------------------- function Create return Object_Ptr; private type Filter_Factory_Record; type Filter_Factory_Access is access Filter_Factory_Record; type Object is new PortableServer.Servant_Base with record X : Filter_Factory_Access; end record; end CosNotifyFilter.FilterFactory.Impl; polyorb-2.8~20110207.orig/cos/notification/cosnotifychanneladmin-sequenceproxypullconsumer-impl.ads0000644000175000017500000001200711750740337033252 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- COSNOTIFYCHANNELADMIN.SEQUENCEPROXYPULLCONSUMER.IMPL -- -- -- -- S p e c -- -- -- -- Copyright (C) 2003-2008, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by ACT Europe. -- -- (email: sales@act-europe.fr) -- -- -- ------------------------------------------------------------------------------ with CosNotifyChannelAdmin.SupplierAdmin; with CosNotifyFilter.Filter; with PortableServer; package CosNotifyChannelAdmin.SequenceProxyPullConsumer.Impl is type Object is new PortableServer.Servant_Base with private; type Object_Ptr is access all Object'Class; -- IDL Operations procedure Connect_Sequence_Pull_Supplier (Self : access Object; Pull_Supplier : CosNotifyComm.SequencePullSupplier.Ref); procedure Suspend_Connection (Self : access Object); procedure Resume_Connection (Self : access Object); -- IDL operations inherited from CosNotifyChannelAdmin::ProxyConsumer function Get_MyType (Self : access Object) return CosNotifyChannelAdmin.ProxyType; function Get_MyAdmin (Self : access Object) return CosNotifyChannelAdmin.SupplierAdmin_Forward.Ref; function Obtain_Subscription_Types (Self : access Object; Mode : CosNotifyChannelAdmin.ObtainInfoMode) return CosNotification.EventTypeSeq; procedure Validate_Event_QoS (Self : access Object; Required_QoS : CosNotification.QoSProperties; Available_QoS : out CosNotification.NamedPropertyRangeSeq); function Get_QoS (Self : access Object) return CosNotification.QoSProperties; procedure Set_QoS (Self : access Object; QoS : CosNotification.QoSProperties); procedure Validate_QoS (Self : access Object; Required_QoS : CosNotification.QoSProperties; Available_QoS : out CosNotification.NamedPropertyRangeSeq); function Add_Filter (Self : access Object; New_Filter : CosNotifyFilter.Filter.Ref) return CosNotifyFilter.FilterID; procedure Remove_Filter (Self : access Object; Filter : CosNotifyFilter.FilterID); function Get_Filter (Self : access Object; Filter : CosNotifyFilter.FilterID) return CosNotifyFilter.Filter.Ref; function Get_All_Filters (Self : access Object) return CosNotifyFilter.FilterIDSeq; procedure Remove_All_Filters (Self : access Object); -- Inherited IDL operations from CosNotifyComm::SequencePullConsumer procedure Offer_Change (Self : access Object; Added : CosNotification.EventTypeSeq; Removed : CosNotification.EventTypeSeq); procedure Disconnect_Sequence_Pull_Consumer (Self : access Object); ---------------------- -- PolyORB specific -- ---------------------- function Create (Admin : CosNotifyChannelAdmin.SupplierAdmin.Ref; Initial_QoS : CosNotification.QoSProperties; Ptype : CosNotifyChannelAdmin.ProxyType; Proxy_Id : CosNotifyChannelAdmin.ProxyID) return Object_Ptr; private type Sequence_Proxy_Pull_Consumer_Record; type Sequence_Proxy_Pull_Consumer_Access is access Sequence_Proxy_Pull_Consumer_Record; type Object is new PortableServer.Servant_Base with record X : Sequence_Proxy_Pull_Consumer_Access; end record; end CosNotifyChannelAdmin.SequenceProxyPullConsumer.Impl; polyorb-2.8~20110207.orig/cos/notification/cosnotification-qosadmin-impl.adb0000644000175000017500000001212611750740337026277 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- C O S N O T I F I C A T I O N . Q O S A D M I N . I M P L -- -- -- -- B o d y -- -- -- -- Copyright (C) 2003-2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with PolyORB.CORBA_P.Server_Tools; with PolyORB.Log; with PolyORB.Tasking.Mutexes; with CosNotification.QoSAdmin.Skel; pragma Warnings (Off, CosNotification.QoSAdmin.Skel); package body CosNotification.QoSAdmin.Impl is use PolyORB.CORBA_P.Server_Tools; use PolyORB.Tasking.Mutexes; use PolyORB.Log; package L is new PolyORB.Log.Facility_Log ("qosadmin"); procedure O (Message : Standard.String; Level : Log_Level := Debug) renames L.Output; function C (Level : Log_Level := Debug) return Boolean renames L.Enabled; pragma Unreferenced (C); -- For conditional pragma Debug type QoS_Admin_Record is record This : Object_Ptr; end record; --------------------------- -- Ensure_Initialization -- --------------------------- procedure Ensure_Initialization; pragma Inline (Ensure_Initialization); -- Ensure that the Mutexes are initialized T_Initialized : Boolean := False; Self_Mutex : Mutex_Access; procedure Ensure_Initialization is begin if not T_Initialized then Create (Self_Mutex); T_Initialized := True; end if; end Ensure_Initialization; ------------- -- Get_QoS -- ------------- function Get_QoS (Self : access Object) return CosNotification.QoSProperties is pragma Warnings (Off); -- WAG:3.14 pragma Unreferenced (Self); pragma Warnings (On); -- WAG:3.14 MyProp : CosNotification.QoSProperties; begin pragma Debug (O ("get_qos in qosadmin")); Ensure_Initialization; Enter (Self_Mutex); Leave (Self_Mutex); return MyProp; end Get_QoS; ------------- -- Set_QoS -- ------------- procedure Set_QoS (Self : access Object; QoS : CosNotification.QoSProperties) is pragma Warnings (Off); -- WAG:3.14 pragma Unreferenced (Self, QoS); pragma Warnings (On); -- WAG:3.14 begin pragma Debug (O ("set_qos in qosadmin")); Ensure_Initialization; Enter (Self_Mutex); Leave (Self_Mutex); end Set_QoS; ------------------ -- Validate_QoS -- ------------------ procedure Validate_QoS (Self : access Object; Required_QoS : CosNotification.QoSProperties; Available_QoS : out CosNotification.NamedPropertyRangeSeq) is pragma Warnings (Off); -- WAG:3.14 pragma Unreferenced (Self, Required_QoS, Available_QoS); pragma Warnings (On); -- WAG:3.14 begin pragma Debug (O ("validate_qos in qosadmin")); Ensure_Initialization; Enter (Self_Mutex); Leave (Self_Mutex); end Validate_QoS; ------------ -- Create -- ------------ function Create return Object_Ptr is QoSAdmin : Object_Ptr; My_Ref : CosNotification.QoSAdmin.Ref; begin pragma Debug (O ("create qosadmin")); QoSAdmin := new Object; QoSAdmin.X := new QoS_Admin_Record; QoSAdmin.X.This := QoSAdmin; Initiate_Servant (PortableServer.Servant (QoSAdmin), My_Ref); return QoSAdmin; end Create; end CosNotification.QoSAdmin.Impl; polyorb-2.8~20110207.orig/cos/notification/cosnotifychanneladmin-sequenceproxypullsupplier-impl.adb0000644000175000017500000007330511750740337033251 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- COSNOTIFYCHANNELADMIN.SEQUENCEPROXYPULLSUPPLIER.IMPL -- -- -- -- B o d y -- -- -- -- Copyright (C) 2003-2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with CosEventChannelAdmin.Helper; with CosEventComm.Helper; with CosNotification; with CosNotification.Helper; with PolyORB.CORBA_P.Server_Tools; with PolyORB.Log; with PolyORB.Tasking.Mutexes; with PolyORB.Tasking.Semaphores; with PolyORB.Utils.Chained_Lists; with CosNotifyChannelAdmin.SequenceProxyPullSupplier.Skel; pragma Warnings (Off, CosNotifyChannelAdmin.SequenceProxyPullSupplier.Skel); package body CosNotifyChannelAdmin.SequenceProxyPullSupplier.Impl is use CosNotification; use IDL_SEQUENCE_CosNotification_Property; use IDL_SEQUENCE_CosNotification_PropertyError; use IDL_SEQUENCE_CosNotification_NamedPropertyRange; use CORBA; use PolyORB.CORBA_P.Server_Tools; use PolyORB.Tasking.Mutexes; use PolyORB.Tasking.Semaphores; package Convert is new ConsumerAdmin_Forward.Convert (CosNotifyChannelAdmin.ConsumerAdmin.Ref); use PolyORB.Log; package L is new PolyORB.Log.Facility_Log ("sequenceproxypullsupplier"); procedure O (Message : Standard.String; Level : Log_Level := Debug) renames L.Output; function C (Level : Log_Level := Debug) return Boolean renames L.Enabled; pragma Unreferenced (C); -- For conditional pragma Debug package Event_Queues is new PolyORB.Utils.Chained_Lists (CosNotification.EventBatch); use Event_Queues; subtype Event_Queue is Event_Queues.List; type Sequence_Proxy_Pull_Supplier_Record is record This : Object_Ptr; Admin : CosNotifyChannelAdmin.ConsumerAdmin.Ref; MyId : CosNotifyChannelAdmin.ProxyID; MyType : CosNotifyChannelAdmin.ProxyType; Peer : CosNotifyComm.SequencePullConsumer.Ref; QoSPropSeq : CosNotification.QoSProperties; Queue : Event_Queue; Semaphore : Semaphore_Access; end record; --------------------------- -- Ensure_Initialization -- --------------------------- procedure Ensure_Initialization; pragma Inline (Ensure_Initialization); -- Ensure that the Mutexes are initialized T_Initialized : Boolean := False; Self_Mutex : Mutex_Access; procedure Ensure_Initialization is begin if not T_Initialized then Create (Self_Mutex); T_Initialized := True; end if; end Ensure_Initialization; ------------------------------------ -- Connect_Sequence_Pull_Consumer -- ------------------------------------ procedure Connect_Sequence_Pull_Consumer (Self : access Object; Pull_Consumer : CosNotifyComm.SequencePullConsumer.Ref) is begin Ensure_Initialization; pragma Debug (O ("connect_sequence_pull_consumer in sequenceproxypullsupplier")); Enter (Self_Mutex); if not CosNotifyComm.SequencePullConsumer.Is_Nil (Self.X.Peer) then Leave (Self_Mutex); CosEventChannelAdmin.Helper.Raise_AlreadyConnected ((CORBA.IDL_Exception_Members with null record)); end if; Self.X.Peer := Pull_Consumer; Leave (Self_Mutex); end Connect_Sequence_Pull_Consumer; ---------------- -- Get_MyType -- ---------------- function Get_MyType (Self : access Object) return CosNotifyChannelAdmin.ProxyType is MyType : CosNotifyChannelAdmin.ProxyType; begin Ensure_Initialization; pragma Debug (O ("get_mytype in sequenceproxypullsupplier")); Enter (Self_Mutex); MyType := Self.X.MyType; Leave (Self_Mutex); return MyType; end Get_MyType; ----------------- -- Get_MyAdmin -- ----------------- function Get_MyAdmin (Self : access Object) return CosNotifyChannelAdmin.ConsumerAdmin_Forward.Ref is MyAdmin : CosNotifyChannelAdmin.ConsumerAdmin_Forward.Ref; begin pragma Debug (O ("get_myadmin in sequenceproxypullsupplier")); Ensure_Initialization; Enter (Self_Mutex); MyAdmin := Convert.To_Forward (Self.X.Admin); Leave (Self_Mutex); return MyAdmin; end Get_MyAdmin; ------------------------- -- Get_Priority_Filter -- ------------------------- function Get_Priority_Filter (Self : access Object) return CosNotifyFilter.MappingFilter.Ref is pragma Warnings (Off); -- WAG:3.14 pragma Unreferenced (Self); pragma Warnings (On); -- WAG:3.14 MyFilter : CosNotifyFilter.MappingFilter.Ref; begin Ensure_Initialization; pragma Debug (O ("get_priority_filter in sequenceproxypullsupplier")); Enter (Self_Mutex); Leave (Self_Mutex); return MyFilter; end Get_Priority_Filter; ------------------------- -- Set_Priority_Filter -- ------------------------- procedure Set_Priority_Filter (Self : access Object; To : CosNotifyFilter.MappingFilter.Ref) is pragma Warnings (Off); -- WAG:3.14 pragma Unreferenced (Self, To); pragma Warnings (On); -- WAG:3.14 begin Ensure_Initialization; pragma Debug (O ("set_priority_filter in sequenceproxypullsupplier")); Enter (Self_Mutex); Leave (Self_Mutex); end Set_Priority_Filter; ------------------------- -- Get_Lifetime_Filter -- ------------------------- function Get_Lifetime_Filter (Self : access Object) return CosNotifyFilter.MappingFilter.Ref is pragma Warnings (Off); -- WAG:3.14 pragma Unreferenced (Self); pragma Warnings (On); -- WAG:3.14 MyFilter : CosNotifyFilter.MappingFilter.Ref; begin Ensure_Initialization; pragma Debug (O ("get_lifetime_filter in sequenceproxypullsupplier")); Enter (Self_Mutex); Leave (Self_Mutex); return MyFilter; end Get_Lifetime_Filter; ------------------------- -- Set_Lifetime_Filter -- ------------------------- procedure Set_Lifetime_Filter (Self : access Object; To : CosNotifyFilter.MappingFilter.Ref) is pragma Warnings (Off); -- WAG:3.14 pragma Unreferenced (Self, To); pragma Warnings (On); -- WAG:3.14 begin Ensure_Initialization; pragma Debug (O ("set_lifetime_filter in sequenceproxypullsupplier")); Enter (Self_Mutex); Leave (Self_Mutex); end Set_Lifetime_Filter; -------------------------- -- Obtain_Offered_Types -- -------------------------- function Obtain_Offered_Types (Self : access Object; Mode : CosNotifyChannelAdmin.ObtainInfoMode) return CosNotification.EventTypeSeq is pragma Warnings (Off); -- WAG:3.14 pragma Unreferenced (Self, Mode); pragma Warnings (On); -- WAG:3.14 MySeq : CosNotification.EventTypeSeq; begin Ensure_Initialization; pragma Debug (O ("obtain_offered_types in sequenceproxypullsupplier")); Enter (Self_Mutex); Leave (Self_Mutex); return MySeq; end Obtain_Offered_Types; ------------------------ -- Validate_Event_QoS -- ------------------------ procedure Validate_Event_QoS (Self : access Object; Required_QoS : CosNotification.QoSProperties; Available_QoS : out CosNotification.NamedPropertyRangeSeq) is pragma Warnings (Off); -- WAG:3.14 pragma Unreferenced (Self, Required_QoS, Available_QoS); pragma Warnings (On); -- WAG:3.14 begin Ensure_Initialization; pragma Debug (O ("validate_event_qos in sequenceproxypullsupplier")); Enter (Self_Mutex); Leave (Self_Mutex); end Validate_Event_QoS; ------------- -- Get_QoS -- ------------- function Get_QoS (Self : access Object) return CosNotification.QoSProperties is MyQoS : CosNotification.QoSProperties; begin Ensure_Initialization; pragma Debug (O ("get_qos in sequenceproxypullsupplier")); Enter (Self_Mutex); MyQoS := Self.X.QoSPropSeq; Leave (Self_Mutex); return MyQoS; end Get_QoS; ------------- -- Set_QoS -- ------------- procedure Set_QoS (Self : access Object; QoS : CosNotification.QoSProperties) is MyProp : CosNotification.Property; MyError : CosNotification.PropertyError; MyErrCode : CosNotification.QoSError_code; MyRange : CosNotification.PropertyRange; MyErrorSeq : CosNotification.PropertyErrorSeq; SeqLen : Integer; begin Ensure_Initialization; pragma Debug (O ("set_qos in sequenceproxypullsupplier")); SeqLen := Length (QoS); for Index in 1 .. SeqLen loop MyProp := Get_Element (QoS, Index); if MyProp.name = "EventReliability" then MyErrCode := UNAVAILABLE_PROPERTY; MyRange := (To_Any (CORBA.Short (0)), To_Any (CORBA.Short (0))); MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); elsif MyProp.name = "ConnectionReliability" then if CORBA.Short'(From_Any (MyProp.value)) /= 0 and then CORBA.Short'(From_Any (MyProp.value)) /= 1 then MyErrCode := BAD_VALUE; MyRange := (To_Any (CORBA.Short (0)), To_Any (CORBA.Short (0))); MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); end if; elsif MyProp.name = "Priority" then if CORBA.Short'(From_Any (MyProp.value)) not in -32_767 .. 32_767 then MyErrCode := BAD_VALUE; MyRange := (To_Any (CORBA.Short (-32767)), To_Any (CORBA.Short (32767))); MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); end if; elsif MyProp.name = "StartTime" then MyErrCode := UNAVAILABLE_PROPERTY; MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); elsif MyProp.name = "StopTime" then MyErrCode := UNAVAILABLE_PROPERTY; MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); elsif MyProp.name = "Timeout" then MyErrCode := UNSUPPORTED_PROPERTY; MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); elsif MyProp.name = "OrderPolicy" then if CORBA.Short'(From_Any (MyProp.value)) /= 0 and then CORBA.Short'(From_Any (MyProp.value)) /= 1 and then CORBA.Short'(From_Any (MyProp.value)) /= 2 and then CORBA.Short'(From_Any (MyProp.value)) /= 3 then MyErrCode := BAD_VALUE; MyRange := (To_Any (CORBA.Short (0)), To_Any (CORBA.Short (3))); MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); end if; elsif MyProp.name = "DiscardPolicy" then if CORBA.Short'(From_Any (MyProp.value)) /= 0 and then CORBA.Short'(From_Any (MyProp.value)) /= 1 and then CORBA.Short'(From_Any (MyProp.value)) /= 2 and then CORBA.Short'(From_Any (MyProp.value)) /= 3 and then CORBA.Short'(From_Any (MyProp.value)) /= 4 then MyErrCode := BAD_VALUE; MyRange := (To_Any (CORBA.Short (0)), To_Any (CORBA.Short (4))); MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); end if; elsif MyProp.name = "MaximumBatchSize" then MyErrCode := UNSUPPORTED_PROPERTY; MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); elsif MyProp.name = "PacingInterval" then MyErrCode := UNSUPPORTED_PROPERTY; MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); elsif MyProp.name = "StartTimeSupported" then MyErrCode := UNSUPPORTED_PROPERTY; MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); elsif MyProp.name = "StopTimeSupported" then MyErrCode := UNSUPPORTED_PROPERTY; MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); elsif MyProp.name = "MaxEventsPerConsumer" then MyErrCode := UNSUPPORTED_PROPERTY; MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); else MyErrCode := BAD_PROPERTY; MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); end if; end loop; if Length (MyErrorSeq) > 0 then CosNotification.Helper.Raise_UnsupportedQoS ((CORBA.IDL_Exception_Members with qos_err => MyErrorSeq)); end if; SeqLen := Length (QoS); Enter (Self_Mutex); for Index in 1 .. SeqLen loop MyProp := Get_Element (QoS, Index); if MyProp.name = "ConnectionReliability" then Replace_Element (Self.X.QoSPropSeq, 2, MyProp); elsif MyProp.name = "Priority" then Replace_Element (Self.X.QoSPropSeq, 3, MyProp); elsif MyProp.name = "OrderPolicy" then Replace_Element (Self.X.QoSPropSeq, 4, MyProp); elsif MyProp.name = "DiscardPolicy" then Replace_Element (Self.X.QoSPropSeq, 5, MyProp); end if; end loop; Leave (Self_Mutex); end Set_QoS; ------------------ -- Validate_QoS -- ------------------ procedure Validate_QoS (Self : access Object; Required_QoS : CosNotification.QoSProperties; Available_QoS : out CosNotification.NamedPropertyRangeSeq) is MyProp : CosNotification.Property; MyError : CosNotification.PropertyError; MyErrCode : CosNotification.QoSError_code; MyNamedRange : CosNotification.NamedPropertyRange; MyRange : CosNotification.PropertyRange; MyErrorSeq : CosNotification.PropertyErrorSeq; SeqLen : Integer; begin Ensure_Initialization; pragma Debug (O ("validate_qos in sequenceproxypullsupplier")); SeqLen := Length (Required_QoS); for Index in 1 .. SeqLen loop MyProp := Get_Element (Required_QoS, Index); if MyProp.name = "EventReliability" then MyErrCode := UNAVAILABLE_PROPERTY; MyRange := (To_Any (CORBA.Short (0)), To_Any (CORBA.Short (0))); MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); elsif MyProp.name = "ConnectionReliability" then if CORBA.Short'(From_Any (MyProp.value)) /= 0 and then CORBA.Short'(From_Any (MyProp.value)) /= 1 then MyErrCode := BAD_VALUE; MyRange := (To_Any (CORBA.Short (0)), To_Any (CORBA.Short (0))); MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); end if; elsif MyProp.name = "Priority" then if CORBA.Short'(From_Any (MyProp.value)) not in -32_767 .. 32_767 then MyErrCode := BAD_VALUE; MyRange := (To_Any (CORBA.Short (-32767)), To_Any (CORBA.Short (32767))); MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); end if; elsif MyProp.name = "StartTime" then MyErrCode := UNAVAILABLE_PROPERTY; MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); elsif MyProp.name = "StopTime" then MyErrCode := UNAVAILABLE_PROPERTY; MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); elsif MyProp.name = "Timeout" then MyErrCode := UNSUPPORTED_PROPERTY; MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); elsif MyProp.name = "OrderPolicy" then if CORBA.Short'(From_Any (MyProp.value)) /= 0 and then CORBA.Short'(From_Any (MyProp.value)) /= 1 and then CORBA.Short'(From_Any (MyProp.value)) /= 2 and then CORBA.Short'(From_Any (MyProp.value)) /= 3 then MyErrCode := BAD_VALUE; MyRange := (To_Any (CORBA.Short (0)), To_Any (CORBA.Short (3))); MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); end if; elsif MyProp.name = "DiscardPolicy" then if CORBA.Short'(From_Any (MyProp.value)) /= 0 and then CORBA.Short'(From_Any (MyProp.value)) /= 1 and then CORBA.Short'(From_Any (MyProp.value)) /= 2 and then CORBA.Short'(From_Any (MyProp.value)) /= 3 and then CORBA.Short'(From_Any (MyProp.value)) /= 4 then MyErrCode := BAD_VALUE; MyRange := (To_Any (CORBA.Short (0)), To_Any (CORBA.Short (4))); MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); end if; elsif MyProp.name = "MaximumBatchSize" then MyErrCode := UNSUPPORTED_PROPERTY; MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); elsif MyProp.name = "PacingInterval" then MyErrCode := UNSUPPORTED_PROPERTY; MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); elsif MyProp.name = "StartTimeSupported" then MyErrCode := UNSUPPORTED_PROPERTY; MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); elsif MyProp.name = "StopTimeSupported" then MyErrCode := UNSUPPORTED_PROPERTY; MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); elsif MyProp.name = "MaxEventsPerConsumer" then MyErrCode := UNSUPPORTED_PROPERTY; MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); else MyErrCode := BAD_PROPERTY; MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); end if; end loop; if Length (MyErrorSeq) > 0 then CosNotification.Helper.Raise_UnsupportedQoS ((CORBA.IDL_Exception_Members with qos_err => MyErrorSeq)); end if; Enter (Self_Mutex); SeqLen := Length (Self.X.QoSPropSeq); for Index in 1 .. SeqLen loop MyProp := Get_Element (Self.X.QoSPropSeq, Index); if MyProp.name = "ConnectionReliability" then MyRange := (From_Any (MyProp.value), To_Any (CORBA.Short (0))); MyNamedRange := (MyProp.name, MyRange); Append (Available_QoS, MyNamedRange); elsif MyProp.name = "Priority" then MyRange := (To_Any (CORBA.Short (-32767)), To_Any (CORBA.Short (32767))); MyNamedRange := (MyProp.name, MyRange); Append (Available_QoS, MyNamedRange); elsif MyProp.name = "OrderPolicy" then MyRange := (To_Any (CORBA.Short (0)), To_Any (CORBA.Short (3))); MyNamedRange := (MyProp.name, MyRange); Append (Available_QoS, MyNamedRange); elsif MyProp.name = "DiscardPolicy" then MyRange := (To_Any (CORBA.Short (0)), To_Any (CORBA.Short (4))); MyNamedRange := (MyProp.name, MyRange); Append (Available_QoS, MyNamedRange); end if; end loop; Leave (Self_Mutex); end Validate_QoS; ---------------- -- Add_Filter -- ---------------- function Add_Filter (Self : access Object; New_Filter : CosNotifyFilter.Filter.Ref) return CosNotifyFilter.FilterID is pragma Warnings (Off); -- WAG:3.14 pragma Unreferenced (Self, New_Filter); pragma Warnings (On); -- WAG:3.14 MyFilterID : CosNotifyFilter.FilterID; MyID : CORBA.Long; begin Ensure_Initialization; pragma Debug (O ("add_filter in sequenceproxypullsupplier")); Enter (Self_Mutex); Leave (Self_Mutex); MyID := 0; MyFilterID := CosNotifyFilter.FilterID (MyID); return MyFilterID; end Add_Filter; ------------------- -- Remove_Filter -- ------------------- procedure Remove_Filter (Self : access Object; Filter : CosNotifyFilter.FilterID) is pragma Warnings (Off); -- WAG:3.14 pragma Unreferenced (Self, Filter); pragma Warnings (On); -- WAG:3.14 begin Ensure_Initialization; pragma Debug (O ("remove_filter in sequenceproxypullsupplier")); Enter (Self_Mutex); Leave (Self_Mutex); end Remove_Filter; ---------------- -- Get_Filter -- ---------------- function Get_Filter (Self : access Object; Filter : CosNotifyFilter.FilterID) return CosNotifyFilter.Filter.Ref is pragma Warnings (Off); -- WAG:3.14 pragma Unreferenced (Self, Filter); pragma Warnings (On); -- WAG:3.14 MyFilter : CosNotifyFilter.Filter.Ref; begin Ensure_Initialization; pragma Debug (O ("get_filter in sequenceproxypullsupplier")); Enter (Self_Mutex); Leave (Self_Mutex); return MyFilter; end Get_Filter; --------------------- -- Get_All_Filters -- --------------------- function Get_All_Filters (Self : access Object) return CosNotifyFilter.FilterIDSeq is pragma Warnings (Off); -- WAG:3.14 pragma Unreferenced (Self); pragma Warnings (On); -- WAG:3.14 MyFilterSeq : CosNotifyFilter.FilterIDSeq; begin Ensure_Initialization; pragma Debug (O ("get_all_filters in sequenceproxypullsupplier")); Enter (Self_Mutex); Leave (Self_Mutex); return MyFilterSeq; end Get_All_Filters; ------------------------ -- Remove_All_Filters -- ------------------------ procedure Remove_All_Filters (Self : access Object) is pragma Warnings (Off); -- WAG:3.14 pragma Unreferenced (Self); pragma Warnings (On); -- WAG:3.14 begin Ensure_Initialization; pragma Debug (O ("remove_all_filters in sequenceproxypullsupplier")); Enter (Self_Mutex); Leave (Self_Mutex); end Remove_All_Filters; ------------------------- -- Subscription_Change -- ------------------------- procedure Subscription_Change (Self : access Object; Added : CosNotification.EventTypeSeq; Removed : CosNotification.EventTypeSeq) is pragma Warnings (Off); -- WAG:3.14 pragma Unreferenced (Self, Added, Removed); pragma Warnings (On); -- WAG:3.14 begin Ensure_Initialization; pragma Debug (O ("subscription_change in sequenceproxypullsupplier")); Enter (Self_Mutex); Leave (Self_Mutex); end Subscription_Change; ---------------------------- -- Pull_Structured_Events -- ---------------------------- function Pull_Structured_Events (Self : access Object; Max_Number : CORBA.Long) return CosNotification.EventBatch is pragma Warnings (Off); -- WAG:3.14 pragma Unreferenced (Max_Number); pragma Warnings (On); -- WAG:3.14 Event : CosNotification.EventBatch; begin Ensure_Initialization; pragma Debug (O ("attempt to pull sequence of structuredevents " & "from sequenceproxypullsupplier")); P (Self.X.Semaphore); Enter (Self_Mutex); if CosNotifyComm.SequencePullConsumer.Is_Nil (Self.X.Peer) then Leave (Self_Mutex); CosEventComm.Helper.Raise_Disconnected ((CORBA.IDL_Exception_Members with null record)); end if; if State (Self.X.Semaphore) >= 0 then Extract_First (Self.X.Queue, Event); pragma Debug (O ("succeed to pull sequence of structuredevents from "& "sequenceproxypullsupplier")); end if; Leave (Self_Mutex); return Event; end Pull_Structured_Events; -------------------------------- -- Try_Pull_Structured_Events -- -------------------------------- procedure Try_Pull_Structured_Events (Self : access Object; Max_Number : CORBA.Long; Has_Event : out CORBA.Boolean; Returns : out CosNotification.EventBatch) is pragma Warnings (Off); -- WAG:3.14 pragma Unreferenced (Max_Number); pragma Warnings (On); -- WAG:3.14 begin pragma Debug (O ("try to pull sequence of structuredevents " & "from sequenceproxypullsupplier")); Ensure_Initialization; Enter (Self_Mutex); if CosNotifyComm.SequencePullConsumer.Is_Nil (Self.X.Peer) then Leave (Self_Mutex); CosEventComm.Helper.Raise_Disconnected ((CORBA.IDL_Exception_Members with null record)); end if; Has_Event := State (Self.X.Semaphore) > 0; if Has_Event then Extract_First (Self.X.Queue, Returns); Leave (Self_Mutex); P (Self.X.Semaphore); else Leave (Self_Mutex); end if; end Try_Pull_Structured_Events; --------------------------------------- -- Disconnect_Sequence_Pull_Supplier -- --------------------------------------- procedure Disconnect_Sequence_Pull_Supplier (Self : access Object) is Peer : CosNotifyComm.SequencePullConsumer.Ref; Nil_Ref : CosNotifyComm.SequencePullConsumer.Ref; begin Ensure_Initialization; pragma Debug (O ("disconnect sequenceproxypullsupplier")); Enter (Self_Mutex); Peer := Self.X.Peer; Self.X.Peer := Nil_Ref; Leave (Self_Mutex); V (Self.X.Semaphore); if not CosNotifyComm.SequencePullConsumer.Is_Nil (Peer) then CosNotifyComm.SequencePullConsumer. disconnect_sequence_pull_consumer (Peer); end if; end Disconnect_Sequence_Pull_Supplier; ------------ -- Create -- ------------ function Create (Admin : CosNotifyChannelAdmin.ConsumerAdmin.Ref; Initial_QoS : CosNotification.QoSProperties; Ptype : CosNotifyChannelAdmin.ProxyType; Proxy_Id : CosNotifyChannelAdmin.ProxyID) return Object_Ptr is Supplier : Object_Ptr; My_Ref : SequenceProxyPullSupplier.Ref; begin pragma Debug (O ("create sequenceproxypullsupplier")); Supplier := new Object; Supplier.X := new Sequence_Proxy_Pull_Supplier_Record; Supplier.X.Admin := Admin; Supplier.X.MyId := Proxy_Id; Supplier.X.MyType := Ptype; Supplier.X.This := Supplier; Supplier.X.QoSPropSeq := Initial_QoS; Create (Supplier.X.Semaphore); Initiate_Servant (PortableServer.Servant (Supplier), My_Ref); return Supplier; end Create; ------------------- -- Sequence_Post -- ------------------- procedure Sequence_Post (Self : access Object; Data : CosNotification.EventBatch) is begin pragma Debug (O ("post sequence of structuredevent to sequenceproxypullsupplier")); Ensure_Initialization; Enter (Self_Mutex); Append (Self.X.Queue, Data); Leave (Self_Mutex); V (Self.X.Semaphore); end Sequence_Post; end CosNotifyChannelAdmin.SequenceProxyPullSupplier.Impl; polyorb-2.8~20110207.orig/cos/notification/cosnotifycomm-pullconsumer-impl.ads0000644000175000017500000000673011750740337026737 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- C O S N O T I F Y C O M M . P U L L C O N S U M E R . I M P L -- -- -- -- S p e c -- -- -- -- Copyright (C) 2003-2008, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by ACT Europe. -- -- (email: sales@act-europe.fr) -- -- -- ------------------------------------------------------------------------------ with PortableServer; with CosNotifyChannelAdmin.ProxyPullSupplier; package CosNotifyComm.PullConsumer.Impl is type Object is new PortableServer.Servant_Base with private; type Object_Ptr is access all Object'Class; -- Inherited IDL operations from CosNotifyComm::NotifyPublish procedure Offer_Change (Self : access Object; Added : CosNotification.EventTypeSeq; Removed : CosNotification.EventTypeSeq); -- Inherited IDL operations from CosEventComm::PullConsumer procedure Disconnect_Pull_Consumer (Self : access Object); ---------------------- -- PolyORB specific -- ---------------------- function Create return Object_Ptr; -- Call by application to create an object and activate servant procedure Connect_Any_Proxy_Pull_Supplier (Self : access Object; Proxy : CosNotifyChannelAdmin.ProxyPullSupplier.Ref); -- Call by application to connect object to proxy function Pull (Self : access Object) return CORBA.Any; -- Call by application to consume an event procedure Try_Pull (Self : access Object; Done : out CORBA.Boolean; Returns : out CORBA.Any); -- Call by application to try to consume an event private type Pull_Consumer_Record; type Pull_Consumer_Access is access Pull_Consumer_Record; type Object is new PortableServer.Servant_Base with record X : Pull_Consumer_Access; end record; end CosNotifyComm.PullConsumer.Impl; polyorb-2.8~20110207.orig/cos/notification/cosnotifycomm-sequencepushconsumer-impl.ads0000644000175000017500000000724111750740337030471 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- COSNOTIFYCOMM.SEQUENCEPUSHCONSUMER.IMPL -- -- -- -- S p e c -- -- -- -- Copyright (C) 2003-2008, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by ACT Europe. -- -- (email: sales@act-europe.fr) -- -- -- ------------------------------------------------------------------------------ with PortableServer; with CosNotifyChannelAdmin.SequenceProxyPushSupplier; with CosNotification; package CosNotifyComm.SequencePushConsumer.Impl is type Object is new PortableServer.Servant_Base with private; type Object_Ptr is access all Object'Class; -- Inherited IDL operations from CosNotifyComm::NotifyPublish procedure Offer_Change (Self : access Object; Added : CosNotification.EventTypeSeq; Removed : CosNotification.EventTypeSeq); -- IDL operations procedure Push_Structured_Events (Self : access Object; Notifications : CosNotification.EventBatch); procedure Disconnect_Sequence_Push_Consumer (Self : access Object); ---------------------- -- PolyORB specific -- ---------------------- function Create return Object_Ptr; procedure Connect_Sequence_Proxy_Push_Supplier (Self : access Object; Proxy : CosNotifyChannelAdmin.SequenceProxyPushSupplier.Ref); -- Call by application to connect object with proxy function Pull (Self : access Object) return CosNotification.EventBatch; -- Call by application to consume a sequence of structured events procedure Try_Pull (Self : access Object; Done : out CORBA.Boolean; Data : out CosNotification.EventBatch); -- Call by application to try to consume a sequence of structured events private type Sequence_Push_Consumer_Record; type Sequence_Push_Consumer_Access is access Sequence_Push_Consumer_Record; type Object is new PortableServer.Servant_Base with record X : Sequence_Push_Consumer_Access; end record; end CosNotifyComm.SequencePushConsumer.Impl; ././@LongLink0000000000000000000000000000014600000000000011566 Lustar rootrootpolyorb-2.8~20110207.orig/cos/notification/cosnotifychanneladmin-structuredproxypushsupplier-impl.adspolyorb-2.8~20110207.orig/cos/notification/cosnotifychanneladmin-structuredproxypushsupplier-impl.ad0000644000175000017500000001316111750740337033500 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- COSNOTIFYCHANNELADMIN.STRUCTUREDPROXYPUSHSUPPLIER.IMPL -- -- -- -- S p e c -- -- -- -- Copyright (C) 2003-2008, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by ACT Europe. -- -- (email: sales@act-europe.fr) -- -- -- ------------------------------------------------------------------------------ with CosNotifyChannelAdmin.ConsumerAdmin; with CosNotifyFilter.Filter; with CosNotifyFilter.MappingFilter; with PortableServer; package CosNotifyChannelAdmin.StructuredProxyPushSupplier.Impl is type Object is new PortableServer.Servant_Base with private; type Object_Ptr is access all Object'Class; -- IDL operations procedure Connect_Structured_Push_consumer (Self : access Object; Push_Consumer : CosNotifyComm.StructuredPushConsumer.Ref); procedure Suspend_Connection (Self : access Object); procedure Resume_Connection (Self : access Object); -- IDL operations inherited from CosNotifyChannelAdmin::ProxySupplier function Get_MyType (Self : access Object) return CosNotifyChannelAdmin.ProxyType; function Get_MyAdmin (Self : access Object) return CosNotifyChannelAdmin.ConsumerAdmin_Forward.Ref; function Get_Priority_Filter (Self : access Object) return CosNotifyFilter.MappingFilter.Ref; procedure Set_Priority_Filter (Self : access Object; To : CosNotifyFilter.MappingFilter.Ref); function Get_Lifetime_Filter (Self : access Object) return CosNotifyFilter.MappingFilter.Ref; procedure Set_Lifetime_Filter (Self : access Object; To : CosNotifyFilter.MappingFilter.Ref); function Obtain_Offered_Types (Self : access Object; Mode : CosNotifyChannelAdmin.ObtainInfoMode) return CosNotification.EventTypeSeq; procedure Validate_Event_QoS (Self : access Object; Required_QoS : CosNotification.QoSProperties; Available_QoS : out CosNotification.NamedPropertyRangeSeq); function Get_QoS (Self : access Object) return CosNotification.QoSProperties; procedure Set_QoS (Self : access Object; QoS : CosNotification.QoSProperties); procedure Validate_QoS (Self : access Object; Required_QoS : CosNotification.QoSProperties; Available_QoS : out CosNotification.NamedPropertyRangeSeq); function Add_Filter (Self : access Object; New_Filter : CosNotifyFilter.Filter.Ref) return CosNotifyFilter.FilterID; procedure Remove_Filter (Self : access Object; Filter : CosNotifyFilter.FilterID); function Get_Filter (Self : access Object; Filter : CosNotifyFilter.FilterID) return CosNotifyFilter.Filter.Ref; function Get_All_Filters (Self : access Object) return CosNotifyFilter.FilterIDSeq; procedure Remove_All_Filters (Self : access Object); -- IDL operations inherited from CosNotifyComm::StructuredPushSupplier procedure Subscription_Change (Self : access Object; Added : CosNotification.EventTypeSeq; Removed : CosNotification.EventTypeSeq); procedure Disconnect_Structured_Push_Supplier (Self : access Object); ---------------------- -- PolyORB specific -- ---------------------- function Create (Admin : CosNotifyChannelAdmin.ConsumerAdmin.Ref; Initial_QoS : CosNotification.QoSProperties; Ptype : CosNotifyChannelAdmin.ProxyType; Proxy_Id : CosNotifyChannelAdmin.ProxyID) return Object_Ptr; procedure Structured_Post (Self : access Object; Notification : CosNotification.StructuredEvent); private type Structured_Proxy_Push_Supplier_Record; type Structured_Proxy_Push_Supplier_Access is access Structured_Proxy_Push_Supplier_Record; type Object is new PortableServer.Servant_Base with record X : Structured_Proxy_Push_Supplier_Access; end record; end CosNotifyChannelAdmin.StructuredProxyPushSupplier.Impl; polyorb-2.8~20110207.orig/cos/notification/cosnotifyfilter-filter-impl.adb0000644000175000017500000002526111750740337026005 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- C O S N O T I F Y F I L T E R . F I L T E R . I M P L -- -- -- -- B o d y -- -- -- -- Copyright (C) 2003-2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with PolyORB.CORBA_P.Server_Tools; with PolyORB.Log; with PolyORB.Tasking.Mutexes; with CosNotifyFilter.Filter.Skel; pragma Warnings (Off, CosNotifyFilter.Filter.Skel); package body CosNotifyFilter.Filter.Impl is use PolyORB.CORBA_P.Server_Tools; use PolyORB.Tasking.Mutexes; use PolyORB.Log; package L is new PolyORB.Log.Facility_Log ("filter"); procedure O (Message : Standard.String; Level : Log_Level := Debug) renames L.Output; function C (Level : Log_Level := Debug) return Boolean renames L.Enabled; pragma Unreferenced (C); -- For conditional pragma Debug type Filter_Record is record This : Object_Ptr; end record; --------------------------- -- Ensure_Initialization -- --------------------------- procedure Ensure_Initialization; pragma Inline (Ensure_Initialization); -- Ensure that the Mutexes are initialized T_Initialized : Boolean := False; Self_Mutex : Mutex_Access; procedure Ensure_Initialization is begin if not T_Initialized then Create (Self_Mutex); T_Initialized := True; end if; end Ensure_Initialization; ---------------------------- -- Get_Constraint_Grammar -- ---------------------------- function Get_Constraint_Grammar (Self : access Object) return CORBA.String is pragma Warnings (Off); -- WAG:3.14 pragma Unreferenced (Self); pragma Warnings (On); -- WAG:3.14 MyGrammar : CORBA.String; begin pragma Debug (O ("get_constraint_grammar in filter")); Ensure_Initialization; Enter (Self_Mutex); Leave (Self_Mutex); return MyGrammar; end Get_Constraint_Grammar; --------------------- -- Add_Constraints -- --------------------- function Add_Constraints (Self : access Object; Constraint_List : CosNotifyFilter.ConstraintExpSeq) return CosNotifyFilter.ConstraintInfoSeq is pragma Warnings (Off); -- WAG:3.14 pragma Unreferenced (Self, Constraint_List); pragma Warnings (On); -- WAG:3.14 MySeq : CosNotifyFilter.ConstraintInfoSeq; begin pragma Debug (O ("add_constraints in filter")); Ensure_Initialization; Enter (Self_Mutex); Leave (Self_Mutex); return MySeq; end Add_Constraints; ------------------------ -- Modify_Constraints -- ------------------------ procedure Modify_Constraints (Self : access Object; Del_List : CosNotifyFilter.ConstraintIDSeq; Modify_List : CosNotifyFilter.ConstraintInfoSeq) is pragma Warnings (Off); -- WAG:3.14 pragma Unreferenced (Self, Del_List, Modify_List); pragma Warnings (On); -- WAG:3.14 begin pragma Debug (O ("modify_constraints in filter")); Ensure_Initialization; Enter (Self_Mutex); Leave (Self_Mutex); end Modify_Constraints; --------------------- -- Get_Constraints -- --------------------- function Get_Constraints (Self : access Object; Id_List : CosNotifyFilter.ConstraintIDSeq) return CosNotifyFilter.ConstraintInfoSeq is pragma Warnings (Off); -- WAG:3.14 pragma Unreferenced (Self, Id_List); pragma Warnings (On); -- WAG:3.14 MySeq : CosNotifyFilter.ConstraintInfoSeq; begin pragma Debug (O ("get_constraints in filter")); Ensure_Initialization; Enter (Self_Mutex); Leave (Self_Mutex); return MySeq; end Get_Constraints; ------------------------- -- Get_All_Constraints -- ------------------------- function Get_All_Constraints (Self : access Object) return CosNotifyFilter.ConstraintInfoSeq is pragma Warnings (Off); -- WAG:3.14 pragma Unreferenced (Self); pragma Warnings (On); -- WAG:3.14 MySeq : CosNotifyFilter.ConstraintInfoSeq; begin pragma Debug (O ("get_all_constraints in filter")); Ensure_Initialization; Enter (Self_Mutex); Leave (Self_Mutex); return MySeq; end Get_All_Constraints; ---------------------------- -- Remove_All_Constraints -- ---------------------------- procedure Remove_All_Constraints (Self : access Object) is pragma Warnings (Off); -- WAG:3.14 pragma Unreferenced (Self); pragma Warnings (On); -- WAG:3.14 begin pragma Debug (O ("remove_all_constraints in filter")); Ensure_Initialization; Enter (Self_Mutex); Leave (Self_Mutex); end Remove_All_Constraints; ------------- -- Destroy -- ------------- procedure Destroy (Self : access Object) is pragma Warnings (Off); -- WAG:3.14 pragma Unreferenced (Self); pragma Warnings (On); -- WAG:3.14 begin pragma Debug (O ("destroy in filter")); Ensure_Initialization; Enter (Self_Mutex); Leave (Self_Mutex); end Destroy; ----------- -- Match -- ----------- function Match (Self : access Object; Filterable_Data : CORBA.Any) return CORBA.Boolean is pragma Warnings (Off); -- WAG:3.14 pragma Unreferenced (Self, Filterable_Data); pragma Warnings (On); -- WAG:3.14 Res : constant CORBA.Boolean := True; begin pragma Debug (O ("match in filter")); Ensure_Initialization; Enter (Self_Mutex); Leave (Self_Mutex); raise Program_Error; return Res; end Match; ---------------------- -- Match_Structured -- ---------------------- function Match_Structured (Self : access Object; Filterable_Data : CosNotification.StructuredEvent) return CORBA.Boolean is pragma Warnings (Off); -- WAG:3.14 pragma Unreferenced (Self, Filterable_Data); pragma Warnings (On); -- WAG:3.14 Res : constant CORBA.Boolean := True; begin pragma Debug (O ("match_structured in filter")); Ensure_Initialization; Enter (Self_Mutex); Leave (Self_Mutex); raise Program_Error; return Res; end Match_Structured; ----------------- -- Match_Typed -- ----------------- function Match_Typed (Self : access Object; Filterable_Data : CosNotification.PropertySeq) return CORBA.Boolean is pragma Warnings (Off); -- WAG:3.14 pragma Unreferenced (Self, Filterable_Data); pragma Warnings (On); -- WAG:3.14 Res : constant CORBA.Boolean := True; begin pragma Debug (O ("match_typed in filter")); Ensure_Initialization; Enter (Self_Mutex); Leave (Self_Mutex); raise Program_Error; return Res; end Match_Typed; --------------------- -- Attach_Callback -- --------------------- function Attach_Callback (Self : access Object; Callback : CosNotifyComm.NotifySubscribe.Ref) return CosNotifyFilter.CallbackID is pragma Warnings (Off); -- WAG:3.14 pragma Unreferenced (Self, Callback); pragma Warnings (On); -- WAG:3.14 MyID : constant CosNotifyFilter.CallbackID := CosNotifyFilter.CallbackID'First; begin pragma Debug (O ("attach_callback in filter")); Ensure_Initialization; Enter (Self_Mutex); Leave (Self_Mutex); raise Program_Error; return MyID; end Attach_Callback; --------------------- -- Detach_Callback -- --------------------- procedure Detach_Callback (Self : access Object; Callback : CosNotifyFilter.CallbackID) is pragma Warnings (Off); -- WAG:3.14 pragma Unreferenced (Self, Callback); pragma Warnings (On); -- WAG:3.14 begin pragma Debug (O ("detach_callback in filter")); Ensure_Initialization; Enter (Self_Mutex); Leave (Self_Mutex); end Detach_Callback; ------------------- -- Get_Callbacks -- ------------------- function Get_Callbacks (Self : access Object) return CosNotifyFilter.CallbackIDSeq is pragma Warnings (Off); -- WAG:3.14 pragma Unreferenced (Self); pragma Warnings (On); -- WAG:3.14 MySeq : CosNotifyFilter.CallbackIDSeq; begin pragma Debug (O ("get_callbacks in filter")); Ensure_Initialization; Enter (Self_Mutex); Leave (Self_Mutex); return MySeq; end Get_Callbacks; ------------ -- Create -- ------------ function Create return Object_Ptr is Filter : Object_Ptr; My_Ref : CosNotifyFilter.Filter.Ref; begin pragma Debug (O ("create filter")); Filter := new Object; Filter.X := new Filter_Record; Filter.X.This := Filter; Initiate_Servant (PortableServer.Servant (Filter), My_Ref); return Filter; end Create; end CosNotifyFilter.Filter.Impl; polyorb-2.8~20110207.orig/cos/notification/cosnotifychanneladmin-eventchannelfactory-impl.adb0000644000175000017500000001475211750740337031721 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- COSNOTIFYCHANNELADMIN.EVENTCHANNELFACTORY.IMPL -- -- -- -- B o d y -- -- -- -- Copyright (C) 2003-2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with CosNotifyChannelAdmin.EventChannel.Impl; with CosNotifyChannelAdmin.Helper; with PolyORB.CORBA_P.Server_Tools; with PolyORB.Log; with PolyORB.Tasking.Mutexes; with CosNotifyChannelAdmin.EventChannelFactory.Skel; pragma Warnings (Off, CosNotifyChannelAdmin.EventChannelFactory.Skel); package body CosNotifyChannelAdmin.EventChannelFactory.Impl is use PortableServer; use IDL_SEQUENCE_CosNotifyChannelAdmin_ChannelID; use PolyORB.CORBA_P.Server_Tools; use PolyORB.Tasking.Mutexes; use PolyORB.Log; package L is new PolyORB.Log.Facility_Log ("eventchannelfactory"); procedure O (Message : Standard.String; Level : Log_Level := Debug) renames L.Output; function C (Level : Log_Level := Debug) return Boolean renames L.Enabled; pragma Unreferenced (C); -- For conditional pragma Debug package EventChannels is new CORBA.Sequences.Unbounded (CosNotifyChannelAdmin.EventChannel.Ref); type Event_Channel_Factory_Record is record Channels : EventChannels.Sequence; IDSeq : CosNotifyChannelAdmin.ChannelIDSeq; This : Object_Ptr; end record; --------------------------- -- Ensure_Initialization -- --------------------------- procedure Ensure_Initialization; pragma Inline (Ensure_Initialization); -- Ensure that the Mutexes are initialized T_Initialized : Boolean := False; Self_Mutex : Mutex_Access; procedure Ensure_Initialization is begin if not T_Initialized then Create (Self_Mutex); T_Initialized := True; end if; end Ensure_Initialization; -------------------- -- Create_Channel -- -------------------- procedure Create_Channel (Self : access Object; Initial_QoS : CosNotification.QoSProperties; Initial_Admin : CosNotification.AdminProperties; Id : out ChannelID; Returns : out CosNotifyChannelAdmin.EventChannel.Ref) is Channel : CosNotifyChannelAdmin.EventChannel.Impl.Object_Ptr; My_Ref : CosNotifyChannelAdmin.EventChannelFactory.Ref; begin pragma Debug (O ("create_channel in eventchannelfactory")); Ensure_Initialization; Enter (Self_Mutex); Servant_To_Reference (Servant (Self.X.This), My_Ref); Channel := CosNotifyChannelAdmin.EventChannel.Impl.Create (My_Ref, Initial_QoS, Initial_Admin); Servant_To_Reference (Servant (Channel), Returns); EventChannels.Append (Self.X.Channels, Returns); Id := CosNotifyChannelAdmin.ChannelID (EventChannels.Length (Self.X.Channels)); Append (Self.X.IDSeq, Id); Leave (Self_Mutex); end Create_Channel; ---------------------- -- Get_All_Channels -- ---------------------- function Get_All_Channels (Self : access Object) return CosNotifyChannelAdmin.ChannelIDSeq is MyChannelSeq : CosNotifyChannelAdmin.ChannelIDSeq; begin pragma Debug (O ("get_all_channels from eventchannelfactory")); Ensure_Initialization; Enter (Self_Mutex); MyChannelSeq := Self.X.IDSeq; Leave (Self_Mutex); return MyChannelSeq; end Get_All_Channels; ----------------------- -- Get_Event_Channel -- ----------------------- function Get_Event_Channel (Self : access Object; Id : ChannelID) return CosNotifyChannelAdmin.EventChannel.Ref is MyChannel : CosNotifyChannelAdmin.EventChannel.Ref; SeqLen : CosNotifyChannelAdmin.ChannelID; begin pragma Debug (O ("get_event_channel from eventchannelfactory")); Ensure_Initialization; Enter (Self_Mutex); SeqLen := CosNotifyChannelAdmin.ChannelID (Length (Self.X.IDSeq)); if Id > SeqLen then CosNotifyChannelAdmin.Helper.Raise_ChannelNotFound ((CORBA.IDL_Exception_Members with null record)); end if; MyChannel := EventChannels.Get_Element (Self.X.Channels, Integer (Id)); Leave (Self_Mutex); return MyChannel; end Get_Event_Channel; ------------ -- Create -- ------------ function Create return Object_Ptr is Factory : Object_Ptr; My_Ref : CosNotifyChannelAdmin.EventChannelFactory.Ref; begin pragma Debug (O ("create eventchannelfactory")); Factory := new Object; Factory.X := new Event_Channel_Factory_Record; Factory.X.This := Factory; Initiate_Servant (Servant (Factory), My_Ref); return Factory; end Create; end CosNotifyChannelAdmin.EventChannelFactory.Impl; polyorb-2.8~20110207.orig/cos/notification/cosnotifycomm-structuredpushconsumer-impl.adb0000644000175000017500000002161611750740337031046 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- COSNOTIFYCOMM.STRUCTUREDPUSHCONSUMER.IMPL -- -- -- -- B o d y -- -- -- -- Copyright (C) 2003-2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with CosEventChannelAdmin.Helper; with CosEventComm.Helper; with PolyORB.CORBA_P.Server_Tools; with PolyORB.Log; with PolyORB.Tasking.Mutexes; with PolyORB.Tasking.Semaphores; with CosNotifyComm.StructuredPushConsumer.Skel; pragma Warnings (Off, CosNotifyComm.StructuredPushConsumer.Skel); package body CosNotifyComm.StructuredPushConsumer.Impl is use PolyORB.CORBA_P.Server_Tools; use PolyORB.Tasking.Mutexes; use PolyORB.Tasking.Semaphores; use PolyORB.Log; package L is new PolyORB.Log.Facility_Log ("structuredpushconsumer"); procedure O (Message : Standard.String; Level : Log_Level := Debug) renames L.Output; function C (Level : Log_Level := Debug) return Boolean renames L.Enabled; pragma Unreferenced (C); -- For conditional pragma Debug type Structured_Push_Consumer_Record is record This : Object_Ptr; Empty : Boolean; Event : CosNotification.StructuredEvent; Peer : CosNotifyChannelAdmin.StructuredProxyPushSupplier.Ref; Semaphore : Semaphore_Access; end record; --------------------------- -- Ensure_Initialization -- --------------------------- procedure Ensure_Initialization; pragma Inline (Ensure_Initialization); -- Ensure that the Mutexes are initialized T_Initialized : Boolean := False; Self_Mutex : Mutex_Access; procedure Ensure_Initialization is begin if not T_Initialized then Create (Self_Mutex); T_Initialized := True; end if; end Ensure_Initialization; ------------------ -- Offer_Change -- ------------------ procedure Offer_Change (Self : access Object; Added : CosNotification.EventTypeSeq; Removed : CosNotification.EventTypeSeq) is pragma Warnings (Off); -- WAG:3.14 pragma Unreferenced (Self, Added, Removed); pragma Warnings (On); -- WAG:3.14 begin Ensure_Initialization; pragma Debug (O ("offer_change in structuredpushconsumer")); Enter (Self_Mutex); Leave (Self_Mutex); end Offer_Change; --------------------------- -- Push_Structured_Event -- --------------------------- procedure Push_Structured_Event (Self : access Object; Notification : CosNotification.StructuredEvent) is begin Ensure_Initialization; pragma Debug (O ("push structuredevent to structuredpushconsumer")); Enter (Self_Mutex); Self.X.Empty := False; Self.X.Event := Notification; Leave (Self_Mutex); V (Self.X.Semaphore); end Push_Structured_Event; ----------------------------------------- -- Disconnect_Structured_Push_Consumer -- ----------------------------------------- procedure Disconnect_Structured_Push_Consumer (Self : access Object) is Peer : CosNotifyChannelAdmin.StructuredProxyPushSupplier.Ref; Nil_Ref : CosNotifyChannelAdmin.StructuredProxyPushSupplier.Ref; begin Ensure_Initialization; pragma Debug (O ("disconnect structuredpushconsumer")); Enter (Self_Mutex); Peer := Self.X.Peer; Self.X.Peer := Nil_Ref; Leave (Self_Mutex); V (Self.X.Semaphore); if not CosNotifyChannelAdmin.StructuredProxyPushSupplier.Is_Nil (Peer) then CosNotifyChannelAdmin.StructuredProxyPushSupplier. disconnect_structured_push_supplier (Peer); end if; end Disconnect_Structured_Push_Consumer; ------------ -- Create -- ------------ function Create return Object_Ptr is Consumer : Object_Ptr; My_Ref : StructuredPushConsumer.Ref; Peer_Ref : CosNotifyChannelAdmin.StructuredProxyPushSupplier.Ref; begin pragma Debug (O ("create structuredpushconsumer")); Consumer := new Object; Consumer.X := new Structured_Push_Consumer_Record; Consumer.X.This := Consumer; Consumer.X.Empty := True; Consumer.X.Peer := Peer_Ref; Create (Consumer.X.Semaphore); Initiate_Servant (PortableServer.Servant (Consumer), My_Ref); return Consumer; end Create; -------------------------------------------- -- Connect_Structured_Proxy_Push_Supplier -- -------------------------------------------- procedure Connect_Structured_Proxy_Push_Supplier (Self : access Object; Proxy : CosNotifyChannelAdmin.StructuredProxyPushSupplier.Ref) is My_Ref : StructuredPushConsumer.Ref; begin Ensure_Initialization; pragma Debug (O ("connect_structured_proxy_push_supplier in structuredpushconsumer")); Enter (Self_Mutex); if not CosNotifyChannelAdmin.StructuredProxyPushSupplier.Is_Nil (Self.X.Peer) then Leave (Self_Mutex); CosEventChannelAdmin.Helper.Raise_AlreadyConnected ((CORBA.IDL_Exception_Members with null record)); end if; Self.X.Peer := Proxy; Servant_To_Reference (PortableServer.Servant (Self.X.This), My_Ref); Leave (Self_Mutex); CosNotifyChannelAdmin.StructuredProxyPushSupplier. connect_structured_push_consumer (Proxy, My_Ref); end Connect_Structured_Proxy_Push_Supplier; ---------- -- Pull -- ---------- function Pull (Self : access Object) return CosNotification.StructuredEvent is Notification : CosNotification.StructuredEvent; begin Ensure_Initialization; loop pragma Debug (O ("attempt to pull structured event from structuredpushconsumer")); P (Self.X.Semaphore); Enter (Self_Mutex); if CosNotifyChannelAdmin.StructuredProxyPushSupplier.Is_Nil (Self.X.Peer) then Leave (Self_Mutex); CosEventComm.Helper.Raise_Disconnected ((CORBA.IDL_Exception_Members with null record)); end if; if not Self.X.Empty then Self.X.Empty := True; Notification := Self.X.Event; Leave (Self_Mutex); exit; end if; Leave (Self_Mutex); end loop; pragma Debug (O ("succeded to pull structured event from structuredpushconsumer")); return Notification; end Pull; -------------- -- Try_Pull -- -------------- procedure Try_Pull (Self : access Object; Done : out CORBA.Boolean; Data : out CosNotification.StructuredEvent) is begin Ensure_Initialization; pragma Debug (O ("try to pull structured event from structuredpushconsumer")); Enter (Self_Mutex); if CosNotifyChannelAdmin.StructuredProxyPushSupplier.Is_Nil (Self.X.Peer) then Leave (Self_Mutex); CosEventComm.Helper.Raise_Disconnected ((CORBA.IDL_Exception_Members with null record)); end if; Done := not Self.X.Empty; if Done then Self.X.Empty := True; Data := Self.X.Event; end if; Leave (Self_Mutex); end Try_Pull; end CosNotifyComm.StructuredPushConsumer.Impl; polyorb-2.8~20110207.orig/cos/notification/cosnotification-qosadmin-impl.ads0000644000175000017500000000565611750740337026332 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- C O S N O T I F I C A T I O N . Q O S A D M I N . I M P L -- -- -- -- S p e c -- -- -- -- Copyright (C) 2003-2008, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by ACT Europe. -- -- (email: sales@act-europe.fr) -- -- -- ------------------------------------------------------------------------------ -- with CORBA; with PortableServer; package CosNotification.QoSAdmin.Impl is type Object is new PortableServer.Servant_Base with private; type Object_Ptr is access all Object'Class; -- IDL operations function Get_QoS (Self : access Object) return CosNotification.QoSProperties; procedure Set_QoS (Self : access Object; QoS : CosNotification.QoSProperties); procedure Validate_QoS (Self : access Object; Required_QoS : CosNotification.QoSProperties; Available_QoS : out CosNotification.NamedPropertyRangeSeq); ---------------------- -- PolyORB specific -- ---------------------- function Create return Object_Ptr; private type QoS_Admin_Record; type QoS_Admin_Access is access QoS_Admin_Record; type Object is new PortableServer.Servant_Base with record X : QoS_Admin_Access; end record; end CosNotification.QoSAdmin.Impl; polyorb-2.8~20110207.orig/cos/notification/cosnotification-adminpropertiesadmin-impl.adb0000644000175000017500000001144111750740337030701 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- COSNOTIFICATION.ADMINPROPERTIESADMIN.IMPL -- -- -- -- B o d y -- -- -- -- Copyright (C) 2003-2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with PolyORB.CORBA_P.Server_Tools; with PolyORB.Log; with PolyORB.Tasking.Mutexes; with CosNotification.AdminPropertiesAdmin.Skel; pragma Warnings (Off, CosNotification.AdminPropertiesAdmin.Skel); package body CosNotification.AdminPropertiesAdmin.Impl is use PolyORB.CORBA_P.Server_Tools; use PolyORB.Tasking.Mutexes; use PolyORB.Log; package L is new PolyORB.Log.Facility_Log ("adminpropertiesadmin"); procedure O (Message : Standard.String; Level : Log_Level := Debug) renames L.Output; function C (Level : Log_Level := Debug) return Boolean renames L.Enabled; pragma Unreferenced (C); -- For conditional pragma Debug type AdminProperties_Admin_Record is record This : Object_Ptr; end record; --------------------------- -- Ensure_Initialization -- --------------------------- procedure Ensure_Initialization; pragma Inline (Ensure_Initialization); -- Ensure that the Mutexes are initialized T_Initialized : Boolean := False; Self_Mutex : Mutex_Access; procedure Ensure_Initialization is begin if not T_Initialized then Create (Self_Mutex); T_Initialized := True; end if; end Ensure_Initialization; --------------- -- Get_Admin -- --------------- function Get_Admin (Self : access Object) return CosNotification.AdminProperties is pragma Warnings (Off); -- WAG:3.14 pragma Unreferenced (Self); pragma Warnings (On); -- WAG:3.14 MyProp : CosNotification.AdminProperties; begin pragma Debug (O ("get_admin in adminpropertiesadmin")); Ensure_Initialization; Enter (Self_Mutex); Leave (Self_Mutex); return MyProp; end Get_Admin; --------------- -- Set_Admin -- --------------- procedure Set_Admin (Self : access Object; Admin : CosNotification.AdminProperties) is pragma Warnings (Off); -- WAG:3.14 pragma Unreferenced (Self, Admin); pragma Warnings (On); -- WAG:3.14 begin pragma Debug (O ("set_admin in adminpropertiesadmin")); Ensure_Initialization; Enter (Self_Mutex); Leave (Self_Mutex); end Set_Admin; ------------ -- Create -- ------------ function Create return Object_Ptr is AdminPropertiesAdmin : Object_Ptr; My_Ref : CosNotification.AdminPropertiesAdmin.Ref; begin pragma Debug (O ("create adminpropertiesadmin")); AdminPropertiesAdmin := new Object; AdminPropertiesAdmin.X := new AdminProperties_Admin_Record; AdminPropertiesAdmin.X.This := AdminPropertiesAdmin; Initiate_Servant (PortableServer.Servant (AdminPropertiesAdmin), My_Ref); return AdminPropertiesAdmin; end Create; end CosNotification.AdminPropertiesAdmin.Impl; polyorb-2.8~20110207.orig/cos/notification/cosnotifycomm-notifypublish-impl.ads0000644000175000017500000000535511750740337027110 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- C O S N O T I F Y C O M M . N O T I F Y P U B L I S H . I M P L -- -- -- -- S p e c -- -- -- -- Copyright (C) 2003 Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by ACT Europe. -- -- (email: sales@act-europe.fr) -- -- -- ------------------------------------------------------------------------------ -- with CORBA; with PortableServer; package CosNotifyComm.NotifyPublish.Impl is type Object is new PortableServer.Servant_Base with private; type Object_Ptr is access all Object'Class; -- IDL operations procedure Offer_Change (Self : access Object; Added : CosNotification.EventTypeSeq; Removed : CosNotification.EventTypeSeq); ---------------------- -- PolyORB specific -- ---------------------- function Create return Object_Ptr; private type Notify_Publish_Record; type Notify_Publish_Access is access Notify_Publish_Record; type Object is new PortableServer.Servant_Base with record X : Notify_Publish_Access; end record; end CosNotifyComm.NotifyPublish.Impl; polyorb-2.8~20110207.orig/cos/notification/cosnotifychanneladmin-proxysupplier-impl.ads0000644000175000017500000001124511750740337030637 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- COSNOTIFYCHANNELADMIN.PROXYSUPPLIER.IMPL -- -- -- -- S p e c -- -- -- -- Copyright (C) 2003-2008, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by ACT Europe. -- -- (email: sales@act-europe.fr) -- -- -- ------------------------------------------------------------------------------ -- with CORBA; -- with CosNotifyChannelAdmin.ConsumerAdmin; with CosNotifyFilter.MappingFilter; with PortableServer; package CosNotifyChannelAdmin.ProxySupplier.Impl is type Object is new PortableServer.Servant_Base with private; type Object_Ptr is access all Object'Class; -- IDL operations function Get_MyType (Self : access Object) return CosNotifyChannelAdmin.ProxyType; function Get_MyAdmin (Self : access Object) return CosNotifyChannelAdmin.ConsumerAdmin_Forward.Ref; function Get_Priority_Filter (Self : access Object) return CosNotifyFilter.MappingFilter.Ref; procedure Set_Priority_Filter (Self : access Object; To : CosNotifyFilter.MappingFilter.Ref); function Get_Lifetime_Filter (Self : access Object) return CosNotifyFilter.MappingFilter.Ref; procedure Set_Lifetime_Filter (Self : access Object; To : CosNotifyFilter.MappingFilter.Ref); function Obtain_Offered_Types (Self : access Object; Mode : CosNotifyChannelAdmin.ObtainInfoMode) return CosNotification.EventTypeSeq; procedure Validate_Event_QoS (Self : access Object; Required_QoS : CosNotification.QoSProperties; Available_QoS : out CosNotification.NamedPropertyRangeSeq); -- IDL Operations inherited from CosNotification::QoSAdmin function Get_QoS (Self : access Object) return CosNotification.QoSProperties; procedure Set_QoS (Self : access Object; QoS : CosNotification.QoSProperties); procedure Validate_QoS (Self : access Object; Required_QoS : CosNotification.QoSProperties; Available_QoS : out CosNotification.NamedPropertyRangeSeq); -- Inherited IDL operations from CosNotifyFilter::FilterAdmin function Add_Filter (Self : access Object; New_Filter : CosNotifyFilter.Filter.Ref) return CosNotifyFilter.FilterID; procedure Remove_Filter (Self : access Object; Filter : CosNotifyFilter.FilterID); function Get_Filter (Self : access Object; Filter : CosNotifyFilter.FilterID) return CosNotifyFilter.Filter.Ref; function Get_All_Filters (Self : access Object) return CosNotifyFilter.FilterIDSeq; procedure Remove_All_Filters (Self : access Object); ---------------------- -- PolyORB specific -- ---------------------- function Create return Object_Ptr; private type Proxy_Supplier_Record; type Proxy_Supplier_Access is access Proxy_Supplier_Record; type Object is new PortableServer.Servant_Base with record X : Proxy_Supplier_Access; end record; end CosNotifyChannelAdmin.ProxySupplier.Impl; ././@LongLink0000000000000000000000000000014600000000000011566 Lustar rootrootpolyorb-2.8~20110207.orig/cos/notification/cosnotifychanneladmin-structuredproxypullsupplier-impl.adspolyorb-2.8~20110207.orig/cos/notification/cosnotifychanneladmin-structuredproxypullsupplier-impl.ad0000644000175000017500000001337311750740337033502 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- COSNOTIFYCHANNELADMIN.STRUCTUREDPROXYPULLSUPPLIER.IMPL -- -- -- -- S p e c -- -- -- -- Copyright (C) 2003-2008, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by ACT Europe. -- -- (email: sales@act-europe.fr) -- -- -- ------------------------------------------------------------------------------ with CosNotifyChannelAdmin.ConsumerAdmin; with CosNotifyFilter.Filter; with CosNotifyFilter.MappingFilter; with PortableServer; package CosNotifyChannelAdmin.StructuredProxyPullSupplier.Impl is type Object is new PortableServer.Servant_Base with private; type Object_Ptr is access all Object'Class; -- IDL operations procedure Connect_Structured_Pull_Consumer (Self : access Object; Pull_Consumer : CosNotifyComm.StructuredPullConsumer.Ref); -- IDL operations inherited from CosNotifyChannelAdmin::ProxySupplier function Get_MyType (Self : access Object) return CosNotifyChannelAdmin.ProxyType; function Get_MyAdmin (Self : access Object) return CosNotifyChannelAdmin.ConsumerAdmin_Forward.Ref; function Get_Priority_Filter (Self : access Object) return CosNotifyFilter.MappingFilter.Ref; procedure Set_Priority_Filter (Self : access Object; To : CosNotifyFilter.MappingFilter.Ref); function Get_Lifetime_Filter (Self : access Object) return CosNotifyFilter.MappingFilter.Ref; procedure Set_Lifetime_Filter (Self : access Object; To : CosNotifyFilter.MappingFilter.Ref); function Obtain_Offered_Types (Self : access Object; Mode : CosNotifyChannelAdmin.ObtainInfoMode) return CosNotification.EventTypeSeq; procedure Validate_Event_QoS (Self : access Object; Required_QoS : CosNotification.QoSProperties; Available_QoS : out CosNotification.NamedPropertyRangeSeq); function Get_QoS (Self : access Object) return CosNotification.QoSProperties; procedure Set_QoS (Self : access Object; QoS : CosNotification.QoSProperties); procedure Validate_QoS (Self : access Object; Required_QoS : CosNotification.QoSProperties; Available_QoS : out CosNotification.NamedPropertyRangeSeq); function Add_Filter (Self : access Object; New_Filter : CosNotifyFilter.Filter.Ref) return CosNotifyFilter.FilterID; procedure Remove_Filter (Self : access Object; Filter : CosNotifyFilter.FilterID); function Get_Filter (Self : access Object; Filter : CosNotifyFilter.FilterID) return CosNotifyFilter.Filter.Ref; function Get_All_Filters (Self : access Object) return CosNotifyFilter.FilterIDSeq; procedure Remove_All_Filters (Self : access Object); -- IDL operations inherited from CosNotifyComm::StructuredPullSupplier procedure Subscription_Change (Self : access Object; Added : CosNotification.EventTypeSeq; Removed : CosNotification.EventTypeSeq); function Pull_Structured_Event (Self : access Object) return CosNotification.StructuredEvent; procedure Try_Pull_Structured_Event (Self : access Object; Has_Event : out CORBA.Boolean; Returns : out CosNotification.StructuredEvent); procedure Disconnect_Structured_Pull_Supplier (Self : access Object); ---------------------- -- PolyORB specific -- ---------------------- function Create (Admin : CosNotifyChannelAdmin.ConsumerAdmin.Ref; Initial_QoS : CosNotification.QoSProperties; Ptype : CosNotifyChannelAdmin.ProxyType; Proxy_Id : CosNotifyChannelAdmin.ProxyID) return Object_Ptr; procedure Structured_Post (Self : access Object; Data : CosNotification.StructuredEvent); private type Structured_Proxy_Pull_Supplier_Record; type Structured_Proxy_Pull_Supplier_Access is access Structured_Proxy_Pull_Supplier_Record; type Object is new PortableServer.Servant_Base with record X : Structured_Proxy_Pull_Supplier_Access; end record; end CosNotifyChannelAdmin.StructuredProxyPullSupplier.Impl; polyorb-2.8~20110207.orig/cos/notification/cosnotifychanneladmin-proxypushconsumer-impl.ads0000644000175000017500000001160511750740337031527 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- COSNOTIFYCHANNELADMIN.PROXYPUSHCONSUMER.IMPL -- -- -- -- S p e c -- -- -- -- Copyright (C) 2003-2008, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by ACT Europe. -- -- (email: sales@act-europe.fr) -- -- -- ------------------------------------------------------------------------------ -- with CORBA; with CosNotifyChannelAdmin.SupplierAdmin; with CosNotifyFilter.Filter; with PortableServer; package CosNotifyChannelAdmin.ProxyPushConsumer.Impl is type Object is new PortableServer.Servant_Base with private; type Object_Ptr is access all Object'Class; -- IDL Operations procedure Connect_Any_Push_Supplier (Self : access Object; Push_Supplier : CosEventComm.PushSupplier.Ref); -- IDL operations inherited from CosNotifyChannelAdmin::ProxyConsumer function Get_MyType (Self : access Object) return CosNotifyChannelAdmin.ProxyType; function Get_MyAdmin (Self : access Object) return CosNotifyChannelAdmin.SupplierAdmin_Forward.Ref; function Obtain_Subscription_Types (Self : access Object; Mode : CosNotifyChannelAdmin.ObtainInfoMode) return CosNotification.EventTypeSeq; procedure Validate_Event_QoS (Self : access Object; Required_QoS : CosNotification.QoSProperties; Available_QoS : out CosNotification.NamedPropertyRangeSeq); function Get_QoS (Self : access Object) return CosNotification.QoSProperties; procedure Set_QoS (Self : access Object; QoS : CosNotification.QoSProperties); procedure Validate_QoS (Self : access Object; Required_QoS : CosNotification.QoSProperties; Available_QoS : out CosNotification.NamedPropertyRangeSeq); function Add_Filter (Self : access Object; New_Filter : CosNotifyFilter.Filter.Ref) return CosNotifyFilter.FilterID; procedure Remove_Filter (Self : access Object; Filter : CosNotifyFilter.FilterID); function Get_Filter (Self : access Object; Filter : CosNotifyFilter.FilterID) return CosNotifyFilter.Filter.Ref; function Get_All_Filters (Self : access Object) return CosNotifyFilter.FilterIDSeq; procedure Remove_All_Filters (Self : access Object); -- Inherited IDL operations from CosNotifyComm::PushConsumer procedure Offer_Change (Self : access Object; Added : CosNotification.EventTypeSeq; Removed : CosNotification.EventTypeSeq); procedure Push (Self : access Object; Data : CORBA.Any); procedure Disconnect_Push_Consumer (Self : access Object); ---------------------- -- PolyORB specific -- ---------------------- function Create (Admin : CosNotifyChannelAdmin.SupplierAdmin.Ref; Initial_QoS : CosNotification.QoSProperties; Ptype : CosNotifyChannelAdmin.ProxyType; Proxy_Id : CosNotifyChannelAdmin.ProxyID) return Object_Ptr; private type Proxy_Push_Consumer_Record; type Proxy_Push_Consumer_Access is access Proxy_Push_Consumer_Record; type Object is new PortableServer.Servant_Base with record X : Proxy_Push_Consumer_Access; end record; end CosNotifyChannelAdmin.ProxyPushConsumer.Impl; polyorb-2.8~20110207.orig/cos/notification/cosnotifychanneladmin-sequenceproxypullsupplier-impl.ads0000644000175000017500000001343711750740337033272 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- COSNOTIFYCHANNELADMIN.SEQUENCEPROXYPULLSUPPLIER.IMPL -- -- -- -- S p e c -- -- -- -- Copyright (C) 2003-2008, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by ACT Europe. -- -- (email: sales@act-europe.fr) -- -- -- ------------------------------------------------------------------------------ with CosNotifyChannelAdmin.ConsumerAdmin; with CosNotifyFilter.Filter; with CosNotifyFilter.MappingFilter; with PortableServer; package CosNotifyChannelAdmin.SequenceProxyPullSupplier.Impl is type Object is new PortableServer.Servant_Base with private; type Object_Ptr is access all Object'Class; -- IDL operations procedure Connect_Sequence_Pull_Consumer (Self : access Object; Pull_Consumer : CosNotifyComm.SequencePullConsumer.Ref); -- IDL operations inherited from CosNotifyChannelAdmin::ProxySupplier function Get_MyType (Self : access Object) return CosNotifyChannelAdmin.ProxyType; function Get_MyAdmin (Self : access Object) return CosNotifyChannelAdmin.ConsumerAdmin_Forward.Ref; function Get_Priority_Filter (Self : access Object) return CosNotifyFilter.MappingFilter.Ref; procedure Set_Priority_Filter (Self : access Object; To : CosNotifyFilter.MappingFilter.Ref); function Get_Lifetime_Filter (Self : access Object) return CosNotifyFilter.MappingFilter.Ref; procedure Set_Lifetime_Filter (Self : access Object; To : CosNotifyFilter.MappingFilter.Ref); function Obtain_Offered_Types (Self : access Object; Mode : CosNotifyChannelAdmin.ObtainInfoMode) return CosNotification.EventTypeSeq; procedure Validate_Event_QoS (Self : access Object; Required_QoS : CosNotification.QoSProperties; Available_QoS : out CosNotification.NamedPropertyRangeSeq); function Get_QoS (Self : access Object) return CosNotification.QoSProperties; procedure Set_QoS (Self : access Object; QoS : CosNotification.QoSProperties); procedure Validate_QoS (Self : access Object; Required_QoS : CosNotification.QoSProperties; Available_QoS : out CosNotification.NamedPropertyRangeSeq); function Add_Filter (Self : access Object; New_Filter : CosNotifyFilter.Filter.Ref) return CosNotifyFilter.FilterID; procedure Remove_Filter (Self : access Object; Filter : CosNotifyFilter.FilterID); function Get_Filter (Self : access Object; Filter : CosNotifyFilter.FilterID) return CosNotifyFilter.Filter.Ref; function Get_All_Filters (Self : access Object) return CosNotifyFilter.FilterIDSeq; procedure Remove_All_Filters (Self : access Object); -- IDL operations inherited from CosNotifyComm::SequencePullSupplier procedure Subscription_Change (Self : access Object; Added : CosNotification.EventTypeSeq; Removed : CosNotification.EventTypeSeq); function Pull_Structured_Events (Self : access Object; Max_Number : CORBA.Long) return CosNotification.EventBatch; procedure Try_Pull_Structured_Events (Self : access Object; Max_Number : CORBA.Long; Has_Event : out CORBA.Boolean; Returns : out CosNotification.EventBatch); procedure Disconnect_Sequence_Pull_Supplier (Self : access Object); ---------------------- -- PolyORB specific -- ---------------------- function Create (Admin : CosNotifyChannelAdmin.ConsumerAdmin.Ref; Initial_QoS : CosNotification.QoSProperties; Ptype : CosNotifyChannelAdmin.ProxyType; Proxy_Id : CosNotifyChannelAdmin.ProxyID) return Object_Ptr; procedure Sequence_Post (Self : access Object; Data : CosNotification.EventBatch); private type Sequence_Proxy_Pull_Supplier_Record; type Sequence_Proxy_Pull_Supplier_Access is access Sequence_Proxy_Pull_Supplier_Record; type Object is new PortableServer.Servant_Base with record X : Sequence_Proxy_Pull_Supplier_Access; end record; end CosNotifyChannelAdmin.SequenceProxyPullSupplier.Impl; ././@LongLink0000000000000000000000000000014600000000000011566 Lustar rootrootpolyorb-2.8~20110207.orig/cos/notification/cosnotifychanneladmin-structuredproxypullconsumer-impl.adspolyorb-2.8~20110207.orig/cos/notification/cosnotifychanneladmin-structuredproxypullconsumer-impl.ad0000644000175000017500000001203311750740337033462 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- COSNOTIFYCHANNELADMIN.STRUCTUREDPROXYPULLCONSUMER.IMPL -- -- -- -- S p e c -- -- -- -- Copyright (C) 2003-2008, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by ACT Europe. -- -- (email: sales@act-europe.fr) -- -- -- ------------------------------------------------------------------------------ with CosNotifyChannelAdmin.SupplierAdmin; with CosNotifyFilter.Filter; with PortableServer; package CosNotifyChannelAdmin.StructuredProxyPullConsumer.Impl is type Object is new PortableServer.Servant_Base with private; type Object_Ptr is access all Object'Class; -- IDL Operations procedure Connect_Structured_Pull_Supplier (Self : access Object; Pull_Supplier : CosNotifyComm.StructuredPullSupplier.Ref); procedure Suspend_Connection (Self : access Object); procedure Resume_Connection (Self : access Object); -- IDL operations inherited from CosNotifyChannelAdmin::ProxyConsumer function Get_MyType (Self : access Object) return CosNotifyChannelAdmin.ProxyType; function Get_MyAdmin (Self : access Object) return CosNotifyChannelAdmin.SupplierAdmin_Forward.Ref; function Obtain_Subscription_Types (Self : access Object; Mode : CosNotifyChannelAdmin.ObtainInfoMode) return CosNotification.EventTypeSeq; procedure Validate_Event_QoS (Self : access Object; Required_QoS : CosNotification.QoSProperties; Available_QoS : out CosNotification.NamedPropertyRangeSeq); function Get_QoS (Self : access Object) return CosNotification.QoSProperties; procedure Set_QoS (Self : access Object; QoS : CosNotification.QoSProperties); procedure Validate_QoS (Self : access Object; Required_QoS : CosNotification.QoSProperties; Available_QoS : out CosNotification.NamedPropertyRangeSeq); function Add_Filter (Self : access Object; New_Filter : CosNotifyFilter.Filter.Ref) return CosNotifyFilter.FilterID; procedure Remove_Filter (Self : access Object; Filter : CosNotifyFilter.FilterID); function Get_Filter (Self : access Object; Filter : CosNotifyFilter.FilterID) return CosNotifyFilter.Filter.Ref; function Get_All_Filters (Self : access Object) return CosNotifyFilter.FilterIDSeq; procedure Remove_All_Filters (Self : access Object); -- Inherited IDL operations from CosNotifyComm::StructuredPullConsumer procedure Offer_Change (Self : access Object; Added : CosNotification.EventTypeSeq; Removed : CosNotification.EventTypeSeq); procedure Disconnect_Structured_Pull_Consumer (Self : access Object); ---------------------- -- PolyORB specific -- ---------------------- function Create (Admin : CosNotifyChannelAdmin.SupplierAdmin.Ref; Initial_QoS : CosNotification.QoSProperties; Ptype : CosNotifyChannelAdmin.ProxyType; Proxy_Id : CosNotifyChannelAdmin.ProxyID) return Object_Ptr; private type Structured_Proxy_Pull_Consumer_Record; type Structured_Proxy_Pull_Consumer_Access is access Structured_Proxy_Pull_Consumer_Record; type Object is new PortableServer.Servant_Base with record X : Structured_Proxy_Pull_Consumer_Access; end record; end CosNotifyChannelAdmin.StructuredProxyPullConsumer.Impl; polyorb-2.8~20110207.orig/cos/notification/cosnotifyfilter-mappingfilter-impl.ads0000644000175000017500000001031011750740337027367 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- COSNOTIFYFILTER.MAPPINGFILTER.IMPL -- -- -- -- S p e c -- -- -- -- Copyright (C) 2003-2008, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by ACT Europe. -- -- (email: sales@act-europe.fr) -- -- -- ------------------------------------------------------------------------------ -- with CORBA; with PortableServer; package CosNotifyFilter.MappingFilter.Impl is type Object is new PortableServer.Servant_Base with private; type Object_Ptr is access all Object'Class; -- IDL operations function Get_Constraint_Grammar (Self : access Object) return CORBA.String; function Get_Value_Type (Self : access Object) return CORBA.TypeCode.Object; function Get_Default_Value (Self : access Object) return CORBA.Any; function Add_Mapping_Constraints (Self : access Object; Pair_List : CosNotifyFilter.MappingConstraintPairSeq) return CosNotifyFilter.MappingConstraintInfoSeq; procedure Modify_Mapping_Constraints (Self : access Object; Del_List : CosNotifyFilter.ConstraintIDSeq; Modify_List : CosNotifyFilter.MappingConstraintInfoSeq); function Get_Mapping_Constraints (Self : access Object; Id_List : CosNotifyFilter.ConstraintIDSeq) return CosNotifyFilter.MappingConstraintInfoSeq; function Get_All_Mapping_Constraints (Self : access Object) return CosNotifyFilter.MappingConstraintInfoSeq; procedure Remove_All_Mapping_Constraints (Self : access Object); procedure Destroy (Self : access Object); procedure Match (Self : access Object; Filterable_Data : CORBA.Any; Result_To_Set : out CORBA.Any; Returns : out CORBA.Boolean); procedure Match_Structured (Self : access Object; Filterable_Data : CosNotification.StructuredEvent; Result_To_Set : out CORBA.Any; Returns : out CORBA.Boolean); procedure Match_Typed (Self : access Object; Filterable_Data : CosNotification.PropertySeq; Result_To_Set : out CORBA.Any; Returns : out CORBA.Boolean); ---------------------- -- PolyORB specific -- ---------------------- function Create return Object_Ptr; private type Mapping_Filter_Record; type Mapping_Filter_Access is access Mapping_Filter_Record; type Object is new PortableServer.Servant_Base with record X : Mapping_Filter_Access; end record; end CosNotifyFilter.MappingFilter.Impl; polyorb-2.8~20110207.orig/cos/notification/cosnotifyfilter-filterfactory-impl.adb0000644000175000017500000001172011750740337027370 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- C O S N O T I F Y F I L T E R . F I L T E R F A C T O R Y . I M P L -- -- -- -- B o d y -- -- -- -- Copyright (C) 2003-2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with PolyORB.CORBA_P.Server_Tools; with PolyORB.Log; with PolyORB.Tasking.Mutexes; with CosNotifyFilter.FilterFactory.Skel; pragma Warnings (Off, CosNotifyFilter.FilterFactory.Skel); package body CosNotifyFilter.FilterFactory.Impl is use PolyORB.CORBA_P.Server_Tools; use PolyORB.Tasking.Mutexes; use PolyORB.Log; package L is new PolyORB.Log.Facility_Log ("filterfactory"); procedure O (Message : Standard.String; Level : Log_Level := Debug) renames L.Output; function C (Level : Log_Level := Debug) return Boolean renames L.Enabled; pragma Unreferenced (C); -- For conditional pragma Debug type Filter_Factory_Record is record This : Object_Ptr; end record; --------------------------- -- Ensure_Initialization -- --------------------------- procedure Ensure_Initialization; pragma Inline (Ensure_Initialization); -- Ensure that the Mutexes are initialized T_Initialized : Boolean := False; Self_Mutex : Mutex_Access; procedure Ensure_Initialization is begin if not T_Initialized then Create (Self_Mutex); T_Initialized := True; end if; end Ensure_Initialization; ------------------- -- Create_Filter -- ------------------- function Create_Filter (Self : access Object; Constraint_Grammar : CORBA.String) return CosNotifyFilter.Filter.Ref is pragma Warnings (Off); -- WAG:3.14 pragma Unreferenced (Self, Constraint_Grammar); pragma Warnings (On); -- WAG:3.14 MyFilter : CosNotifyFilter.Filter.Ref; begin pragma Debug (O ("create_filter in filterfactory")); Ensure_Initialization; Enter (Self_Mutex); Leave (Self_Mutex); return MyFilter; end Create_Filter; --------------------------- -- Create_Mapping_Filter -- --------------------------- function Create_Mapping_Filter (Self : access Object; Constraint_Grammar : CORBA.String; Default_Value : CORBA.Any) return CosNotifyFilter.MappingFilter.Ref is pragma Warnings (Off); -- WAG:3.14 pragma Unreferenced (Self, Constraint_Grammar, Default_Value); pragma Warnings (On); -- WAG:3.14 MyFilter : CosNotifyFilter.MappingFilter.Ref; begin pragma Debug (O ("create_mapping_filter in filterfactory")); Ensure_Initialization; Enter (Self_Mutex); Leave (Self_Mutex); return MyFilter; end Create_Mapping_Filter; ------------ -- Create -- ------------ function Create return Object_Ptr is Factory : Object_Ptr; My_Ref : CosNotifyFilter.FilterFactory.Ref; begin pragma Debug (O ("create filterfactory")); Factory := new Object; Factory.X := new Filter_Factory_Record; Factory.X.This := Factory; Initiate_Servant (PortableServer.Servant (Factory), My_Ref); return Factory; end Create; end CosNotifyFilter.FilterFactory.Impl; polyorb-2.8~20110207.orig/cos/notification/cosnotifychanneladmin-proxyconsumer-impl.adb0000644000175000017500000002471211750740337030611 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- COSNOTIFYCHANNELADMIN.PROXYCONSUMER.IMPL -- -- -- -- B o d y -- -- -- -- Copyright (C) 2003-2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with PolyORB.CORBA_P.Server_Tools; with PolyORB.Log; with PolyORB.Tasking.Mutexes; with CosNotifyChannelAdmin.ProxyConsumer.Skel; pragma Warnings (Off, CosNotifyChannelAdmin.ProxyConsumer.Skel); package body CosNotifyChannelAdmin.ProxyConsumer.Impl is use PolyORB.CORBA_P.Server_Tools; use PolyORB.Tasking.Mutexes; package Convert is new SupplierAdmin_Forward.Convert (CosNotifyChannelAdmin.SupplierAdmin.Ref); use PolyORB.Log; package L is new PolyORB.Log.Facility_Log ("proxyconsumer"); procedure O (Message : Standard.String; Level : Log_Level := Debug) renames L.Output; function C (Level : Log_Level := Debug) return Boolean renames L.Enabled; pragma Unreferenced (C); -- For conditional pragma Debug type Proxy_Consumer_Record is record This : Object_Ptr; Admin : CosNotifyChannelAdmin.SupplierAdmin.Ref; MyId : CosNotifyChannelAdmin.ProxyID; MyType : CosNotifyChannelAdmin.ProxyType; end record; --------------------------- -- Ensure_Initialization -- --------------------------- procedure Ensure_Initialization; pragma Inline (Ensure_Initialization); -- Ensure that the Mutexes are initialized T_Initialized : Boolean := False; Self_Mutex : Mutex_Access; procedure Ensure_Initialization is begin if not T_Initialized then Create (Self_Mutex); T_Initialized := True; end if; end Ensure_Initialization; ---------------- -- Get_MyType -- ---------------- function Get_MyType (Self : access Object) return CosNotifyChannelAdmin.ProxyType is MyType : CosNotifyChannelAdmin.ProxyType; begin pragma Debug (O ("get_mytype in proxyconsumer")); Ensure_Initialization; Enter (Self_Mutex); MyType := Self.X.MyType; Leave (Self_Mutex); return MyType; end Get_MyType; ----------------- -- Get_MyAdmin -- ----------------- function Get_MyAdmin (Self : access Object) return CosNotifyChannelAdmin.SupplierAdmin_Forward.Ref is MyAdmin : CosNotifyChannelAdmin.SupplierAdmin_Forward.Ref; begin pragma Debug (O ("get_myadmin in proxyconsumer")); Ensure_Initialization; Enter (Self_Mutex); MyAdmin := Convert.To_Forward (Self.X.Admin); Leave (Self_Mutex); return MyAdmin; end Get_MyAdmin; ------------------------------- -- Obtain_Subscription_Types -- ------------------------------- function Obtain_Subscription_Types (Self : access Object; Mode : CosNotifyChannelAdmin.ObtainInfoMode) return CosNotification.EventTypeSeq is pragma Warnings (Off); -- WAG:3.14 pragma Unreferenced (Self, Mode); pragma Warnings (On); -- WAG:3.14 MySeq : CosNotification.EventTypeSeq; begin pragma Debug (O ("obtain_subscription_types in proxyconsumer")); Ensure_Initialization; Enter (Self_Mutex); Leave (Self_Mutex); return MySeq; end Obtain_Subscription_Types; ------------------------ -- Validate_Event_QoS -- ------------------------ procedure Validate_Event_QoS (Self : access Object; Required_QoS : CosNotification.QoSProperties; Available_QoS : out CosNotification.NamedPropertyRangeSeq) is pragma Warnings (Off); -- WAG:3.14 pragma Unreferenced (Self, Required_QoS, Available_QoS); pragma Warnings (On); -- WAG:3.14 begin pragma Debug (O ("validate_event_qos in proxyconsumer")); Ensure_Initialization; Enter (Self_Mutex); Leave (Self_Mutex); end Validate_Event_QoS; ------------- -- Get_QoS -- ------------- function Get_QoS (Self : access Object) return CosNotification.QoSProperties is pragma Warnings (Off); -- WAG:3.14 pragma Unreferenced (Self); pragma Warnings (On); -- WAG:3.14 MyProp : CosNotification.QoSProperties; begin pragma Debug (O ("get_qos in proxyconsumer")); Ensure_Initialization; Enter (Self_Mutex); Leave (Self_Mutex); return MyProp; end Get_QoS; ------------- -- Set_QoS -- ------------- procedure Set_QoS (Self : access Object; QoS : CosNotification.QoSProperties) is pragma Warnings (Off); -- WAG:3.14 pragma Unreferenced (Self, QoS); pragma Warnings (On); -- WAG:3.14 begin pragma Debug (O ("set_qos in proxyconsumer")); Ensure_Initialization; Enter (Self_Mutex); Leave (Self_Mutex); end Set_QoS; ------------------ -- Validate_QoS -- ------------------ procedure Validate_QoS (Self : access Object; Required_QoS : CosNotification.QoSProperties; Available_QoS : out CosNotification.NamedPropertyRangeSeq) is pragma Warnings (Off); -- WAG:3.14 pragma Unreferenced (Self, Required_QoS, Available_QoS); pragma Warnings (On); -- WAG:3.14 begin pragma Debug (O ("validate_qos in proxyconsumer")); Ensure_Initialization; Enter (Self_Mutex); Leave (Self_Mutex); end Validate_QoS; ---------------- -- Add_Filter -- ---------------- function Add_Filter (Self : access Object; New_Filter : CosNotifyFilter.Filter.Ref) return CosNotifyFilter.FilterID is pragma Warnings (Off); -- WAG:3.14 pragma Unreferenced (Self, New_Filter); pragma Warnings (On); -- WAG:3.14 MyFilterID : CosNotifyFilter.FilterID; MyID : CORBA.Long; begin pragma Debug (O ("add_filter in proxyconsumer")); Ensure_Initialization; Enter (Self_Mutex); Leave (Self_Mutex); MyID := 0; MyFilterID := CosNotifyFilter.FilterID (MyID); return MyFilterID; end Add_Filter; ------------------- -- Remove_Filter -- ------------------- procedure Remove_Filter (Self : access Object; Filter : CosNotifyFilter.FilterID) is pragma Warnings (Off); -- WAG:3.14 pragma Unreferenced (Self, Filter); pragma Warnings (On); -- WAG:3.14 begin pragma Debug (O ("remove_filter in proxyconsumer")); Ensure_Initialization; Enter (Self_Mutex); Leave (Self_Mutex); end Remove_Filter; ---------------- -- Get_Filter -- ---------------- function Get_Filter (Self : access Object; Filter : CosNotifyFilter.FilterID) return CosNotifyFilter.Filter.Ref is pragma Warnings (Off); -- WAG:3.14 pragma Unreferenced (Self, Filter); pragma Warnings (On); -- WAG:3.14 MyFilter : CosNotifyFilter.Filter.Ref; begin pragma Debug (O ("get_filter in proxyconsumer")); Ensure_Initialization; Enter (Self_Mutex); Leave (Self_Mutex); return MyFilter; end Get_Filter; --------------------- -- Get_All_Filters -- --------------------- function Get_All_Filters (Self : access Object) return CosNotifyFilter.FilterIDSeq is pragma Warnings (Off); -- WAG:3.14 pragma Unreferenced (Self); pragma Warnings (On); -- WAG:3.14 MyFilterSeq : CosNotifyFilter.FilterIDSeq; begin pragma Debug (O ("get_all_filters in proxyconsumer")); Ensure_Initialization; Enter (Self_Mutex); Leave (Self_Mutex); return MyFilterSeq; end Get_All_Filters; ------------------------ -- Remove_All_Filters -- ------------------------ procedure Remove_All_Filters (Self : access Object) is pragma Warnings (Off); -- WAG:3.14 pragma Unreferenced (Self); pragma Warnings (On); -- WAG:3.14 begin pragma Debug (O ("remove_all_filters in proxyconsumer")); Ensure_Initialization; Enter (Self_Mutex); Leave (Self_Mutex); end Remove_All_Filters; ------------ -- Create -- ------------ function Create (Admin : CosNotifyChannelAdmin.SupplierAdmin.Ref; Ptype : CosNotifyChannelAdmin.ProxyType; Proxy_Id : CosNotifyChannelAdmin.ProxyID) return Object_Ptr is Consumer : Object_Ptr; My_Ref : ProxyConsumer.Ref; begin pragma Debug (O ("create proxyconsumer")); Consumer := new Object; Consumer.X := new Proxy_Consumer_Record; Consumer.X.Admin := Admin; Consumer.X.MyId := Proxy_Id; Consumer.X.MyType := Ptype; Consumer.X.This := Consumer; Initiate_Servant (PortableServer.Servant (Consumer), My_Ref); return Consumer; end Create; end CosNotifyChannelAdmin.ProxyConsumer.Impl; polyorb-2.8~20110207.orig/cos/notification/cosnotifychanneladmin-sequenceproxypushconsumer-impl.ads0000644000175000017500000001200411750740337033252 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- COSNOTIFYCHANNELADMIN.SEQUENCEPROXYPUSHCONSUMER.IMPL -- -- -- -- S p e c -- -- -- -- Copyright (C) 2003-2008, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by ACT Europe. -- -- (email: sales@act-europe.fr) -- -- -- ------------------------------------------------------------------------------ with CosNotifyChannelAdmin.SupplierAdmin; with CosNotifyFilter.Filter; with PortableServer; package CosNotifyChannelAdmin.SequenceProxyPushConsumer.Impl is type Object is new PortableServer.Servant_Base with private; type Object_Ptr is access all Object'Class; -- IDL Operations procedure Connect_Sequence_Push_Supplier (Self : access Object; Push_Supplier : CosNotifyComm.SequencePushSupplier.Ref); -- IDL operations inherited from CosNotifyChannelAdmin::ProxyConsumer function Get_MyType (Self : access Object) return CosNotifyChannelAdmin.ProxyType; function Get_MyAdmin (Self : access Object) return CosNotifyChannelAdmin.SupplierAdmin_Forward.Ref; function Obtain_Subscription_Types (Self : access Object; Mode : CosNotifyChannelAdmin.ObtainInfoMode) return CosNotification.EventTypeSeq; procedure Validate_Event_QoS (Self : access Object; Required_QoS : CosNotification.QoSProperties; Available_QoS : out CosNotification.NamedPropertyRangeSeq); function Get_QoS (Self : access Object) return CosNotification.QoSProperties; procedure Set_QoS (Self : access Object; QoS : CosNotification.QoSProperties); procedure Validate_QoS (Self : access Object; Required_QoS : CosNotification.QoSProperties; Available_QoS : out CosNotification.NamedPropertyRangeSeq); function Add_Filter (Self : access Object; New_Filter : CosNotifyFilter.Filter.Ref) return CosNotifyFilter.FilterID; procedure Remove_Filter (Self : access Object; Filter : CosNotifyFilter.FilterID); function Get_Filter (Self : access Object; Filter : CosNotifyFilter.FilterID) return CosNotifyFilter.Filter.Ref; function Get_All_Filters (Self : access Object) return CosNotifyFilter.FilterIDSeq; procedure Remove_All_Filters (Self : access Object); -- Inherited IDL operations from CosNotifyComm::SequencePushConsumer procedure Offer_Change (Self : access Object; Added : CosNotification.EventTypeSeq; Removed : CosNotification.EventTypeSeq); procedure Push_Structured_Events (Self : access Object; Notifications : CosNotification.EventBatch); procedure Disconnect_Sequence_Push_Consumer (Self : access Object); ---------------------- -- PolyORB specific -- ---------------------- function Create (Admin : CosNotifyChannelAdmin.SupplierAdmin.Ref; Initial_QoS : CosNotification.QoSProperties; Ptype : CosNotifyChannelAdmin.ProxyType; Proxy_Id : CosNotifyChannelAdmin.ProxyID) return Object_Ptr; private type Sequence_Proxy_Push_Consumer_Record; type Sequence_Proxy_Push_Consumer_Access is access Sequence_Proxy_Push_Consumer_Record; type Object is new PortableServer.Servant_Base with record X : Sequence_Proxy_Push_Consumer_Access; end record; end CosNotifyChannelAdmin.SequenceProxyPushConsumer.Impl; polyorb-2.8~20110207.orig/cos/notification/cosnotifychanneladmin-consumeradmin-impl.adb0000644000175000017500000013545311750740337030525 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- COSNOTIFYCHANNELADMIN.CONSUMERADMIN.IMPL -- -- -- -- B o d y -- -- -- -- Copyright (C) 2003-2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with CosNotification; with CosNotification.Helper; with CosNotifyChannelAdmin.EventChannel.Impl; with CosNotifyChannelAdmin.ProxyPushSupplier.Impl; with CosNotifyChannelAdmin.ProxyPushSupplier.Helper; with CosNotifyChannelAdmin.ProxyPullSupplier.Impl; with CosNotifyChannelAdmin.ProxyPullSupplier.Helper; with CosNotifyChannelAdmin.SequenceProxyPullSupplier.Impl; with CosNotifyChannelAdmin.SequenceProxyPullSupplier.Helper; with CosNotifyChannelAdmin.SequenceProxyPushSupplier.Impl; with CosNotifyChannelAdmin.SequenceProxyPushSupplier.Helper; with CosNotifyChannelAdmin.StructuredProxyPullSupplier.Impl; with CosNotifyChannelAdmin.StructuredProxyPullSupplier.Helper; with CosNotifyChannelAdmin.StructuredProxyPushSupplier.Impl; with CosNotifyChannelAdmin.StructuredProxyPushSupplier.Helper; with PolyORB.CORBA_P.Server_Tools; with PolyORB.Log; with PolyORB.Tasking.Mutexes; with CosNotifyChannelAdmin.ConsumerAdmin.Skel; pragma Warnings (Off, CosNotifyChannelAdmin.ConsumerAdmin.Skel); package body CosNotifyChannelAdmin.ConsumerAdmin.Impl is use IDL_SEQUENCE_CosNotifyChannelAdmin_ProxyID; use CosNotification; use IDL_SEQUENCE_CosNotification_Property; use IDL_SEQUENCE_CosNotification_PropertyError; use IDL_SEQUENCE_CosNotification_NamedPropertyRange; use IDL_SEQUENCE_CosNotification_StructuredEvent; use CORBA; use PortableServer; use PolyORB.CORBA_P.Server_Tools; use PolyORB.Tasking.Mutexes; package Convert is new EventChannel_Forward.Convert (CosNotifyChannelAdmin.EventChannel.Ref); use PolyORB.Log; package L is new PolyORB.Log.Facility_Log ("consumeradmin"); procedure O (Message : Standard.String; Level : Log_Level := Debug) renames L.Output; function C (Level : Log_Level := Debug) return Boolean renames L.Enabled; pragma Unreferenced (C); -- For conditional pragma Debug package AllProxies is new CORBA.Sequences.Unbounded (CORBA.Long); package PullSuppliers is new CORBA.Sequences.Unbounded (CosNotifyChannelAdmin.ProxyPullSupplier.Ref); package PushSuppliers is new CORBA.Sequences.Unbounded (CosNotifyChannelAdmin.ProxyPushSupplier.Ref); package SequencePullSuppliers is new CORBA.Sequences.Unbounded (CosNotifyChannelAdmin.SequenceProxyPullSupplier.Ref); package SequencePushSuppliers is new CORBA.Sequences.Unbounded (CosNotifyChannelAdmin.SequenceProxyPushSupplier.Ref); package StructuredPullSuppliers is new CORBA.Sequences.Unbounded (CosNotifyChannelAdmin.StructuredProxyPullSupplier.Ref); package StructuredPushSuppliers is new CORBA.Sequences.Unbounded (CosNotifyChannelAdmin.StructuredProxyPushSupplier.Ref); type Consumer_Admin_Record is record This : Object_Ptr; Channel : CosNotifyChannelAdmin.EventChannel.Ref; Id : CosNotifyChannelAdmin.AdminID; Op : CosNotifyChannelAdmin.InterFilterGroupOperator; AllPxs : AllProxies.Sequence; Pulls : PullSuppliers.Sequence; Pushs : PushSuppliers.Sequence; SequencePulls : SequencePullSuppliers.Sequence; SequencePushs : SequencePushSuppliers.Sequence; StructPulls : StructuredPullSuppliers.Sequence; StructPushs : StructuredPushSuppliers.Sequence; PullIDSeq : CosNotifyChannelAdmin.ProxyIDSeq; PushIDSeq : CosNotifyChannelAdmin.ProxyIDSeq; QoSPropSeq : CosNotification.QoSProperties; end record; --------------------------- -- Ensure_Initialization -- --------------------------- procedure Ensure_Initialization; pragma Inline (Ensure_Initialization); -- Ensure that the Mutexes are initialized T_Initialized : Boolean := False; Self_Mutex : Mutex_Access; procedure Ensure_Initialization is begin if not T_Initialized then Create (Self_Mutex); T_Initialized := True; end if; end Ensure_Initialization; -------------- -- Get_MyID -- -------------- function Get_MyID (Self : access Object) return CosNotifyChannelAdmin.AdminID is MyID : CosNotifyChannelAdmin.AdminID; begin Ensure_Initialization; pragma Debug (O ("get_myid in consumeradmin")); Enter (Self_Mutex); MyID := Self.X.Id; Leave (Self_Mutex); return MyID; end Get_MyID; ------------------- -- Get_MyChannel -- ------------------- function Get_MyChannel (Self : access Object) return CosNotifyChannelAdmin.EventChannel_Forward.Ref is MyChannel : CosNotifyChannelAdmin.EventChannel_Forward.Ref; begin Ensure_Initialization; pragma Debug (O ("get_mychannel in consumeradmin")); Enter (Self_Mutex); MyChannel := Convert.To_Forward (Self.X.Channel); Leave (Self_Mutex); return MyChannel; end Get_MyChannel; -------------------- -- Get_MyOperator -- -------------------- function Get_MyOperator (Self : access Object) return CosNotifyChannelAdmin.InterFilterGroupOperator is MyOperator : CosNotifyChannelAdmin.InterFilterGroupOperator; begin Ensure_Initialization; pragma Debug (O ("get_myoperator in consumeradmin")); Enter (Self_Mutex); MyOperator := Self.X.Op; Leave (Self_Mutex); return MyOperator; end Get_MyOperator; ------------------------- -- Get_Priority_Filter -- ------------------------- function Get_Priority_Filter (Self : access Object) return CosNotifyFilter.MappingFilter.Ref is pragma Warnings (Off); -- WAG:3.14 pragma Unreferenced (Self); pragma Warnings (On); -- WAG:3.14 MyFilter : CosNotifyFilter.MappingFilter.Ref; begin Ensure_Initialization; pragma Debug (O ("get_priority_filter in consumeradmin")); Enter (Self_Mutex); Leave (Self_Mutex); return MyFilter; end Get_Priority_Filter; ------------------------- -- Set_Priority_Filter -- ------------------------- procedure Set_Priority_Filter (Self : access Object; To : CosNotifyFilter.MappingFilter.Ref) is pragma Warnings (Off); -- WAG:3.14 pragma Unreferenced (Self, To); pragma Warnings (On); -- WAG:3.14 begin Ensure_Initialization; pragma Debug (O ("set_priority_filter in consumeradmin")); Enter (Self_Mutex); Leave (Self_Mutex); end Set_Priority_Filter; ------------------------- -- Get_Lifetime_Filter -- ------------------------- function Get_Lifetime_Filter (Self : access Object) return CosNotifyFilter.MappingFilter.Ref is pragma Warnings (Off); -- WAG:3.14 pragma Unreferenced (Self); pragma Warnings (On); -- WAG:3.14 MyFilter : CosNotifyFilter.MappingFilter.Ref; begin Ensure_Initialization; pragma Debug (O ("get_lifetime_filter in consumeradmin")); Enter (Self_Mutex); Leave (Self_Mutex); return MyFilter; end Get_Lifetime_Filter; ------------------------- -- Set_Lifetime_Filter -- ------------------------- procedure Set_Lifetime_Filter (Self : access Object; To : CosNotifyFilter.MappingFilter.Ref) is pragma Warnings (Off); -- WAG:3.14 pragma Unreferenced (Self, To); pragma Warnings (On); -- WAG:3.14 begin Ensure_Initialization; pragma Debug (O ("set_lifetime_filter in consumeradmin")); Enter (Self_Mutex); Leave (Self_Mutex); end Set_Lifetime_Filter; ------------------------- -- Get_Pull_Suppliers -- ------------------------- function Get_Pull_Suppliers (Self : access Object) return CosNotifyChannelAdmin.ProxyIDSeq is MySeq : CosNotifyChannelAdmin.ProxyIDSeq; begin Ensure_Initialization; pragma Debug (O ("get_pull_suppliers in consumeradmin")); Enter (Self_Mutex); MySeq := Self.X.PullIDSeq; Leave (Self_Mutex); return MySeq; end Get_Pull_Suppliers; ------------------------- -- Get_Push_Suppliers -- ------------------------- function Get_Push_Suppliers (Self : access Object) return CosNotifyChannelAdmin.ProxyIDSeq is MySeq : CosNotifyChannelAdmin.ProxyIDSeq; begin Ensure_Initialization; pragma Debug (O ("get_push_suppliers in consumeradmin")); Enter (Self_Mutex); MySeq := Self.X.PushIDSeq; Leave (Self_Mutex); return MySeq; end Get_Push_Suppliers; ------------------------ -- Get_Proxy_Supplier -- ------------------------ function Get_Proxy_Supplier (Self : access Object; Proxy_Id : CosNotifyChannelAdmin.ProxyID) return CosNotifyChannelAdmin.ProxySupplier.Ref is pragma Warnings (Off); -- WAG:3.14 pragma Unreferenced (Self, Proxy_Id); pragma Warnings (On); -- WAG:3.14 MySupplier : CosNotifyChannelAdmin.ProxySupplier.Ref; begin Ensure_Initialization; pragma Debug (O ("get_proxy_supplier in consumeradmin")); Enter (Self_Mutex); Leave (Self_Mutex); return MySupplier; end Get_Proxy_Supplier; --------------------------------------- -- Obtain_Notification_Pull_Supplier -- --------------------------------------- procedure Obtain_Notification_Pull_Supplier (Self : access Object; Ctype : CosNotifyChannelAdmin.ClientType; Proxy_Id : out CosNotifyChannelAdmin.ProxyID; Returns : out CosNotifyChannelAdmin.ProxySupplier.Ref) is Channel : CosNotifyChannelAdmin.EventChannel.Impl.Object_Ptr; MyRef : CosNotifyChannelAdmin.ConsumerAdmin.Ref; Ptype : CosNotifyChannelAdmin.ProxyType; Res : CORBA.Boolean; Supplier : CosNotifyChannelAdmin.ProxyPullSupplier. Impl.Object_Ptr; Seq_Supplier : CosNotifyChannelAdmin.SequenceProxyPullSupplier. Impl.Object_Ptr; Struct_Supplier : CosNotifyChannelAdmin.StructuredProxyPullSupplier. Impl.Object_Ptr; SRef : CosNotifyChannelAdmin.ProxyPullSupplier.Ref; Seq_SRef : CosNotifyChannelAdmin.SequenceProxyPullSupplier.Ref; Struct_SRef : CosNotifyChannelAdmin.StructuredProxyPullSupplier.Ref; begin Ensure_Initialization; pragma Debug (O ("obtain_notification_pull_supplier in consumeradmin")); Enter (Self_Mutex); Reference_To_Servant (Self.X.Channel, Servant (Channel)); Res := CosNotifyChannelAdmin.EventChannel.Impl. TestSupplierLimit (Channel); if Res = False then Leave (Self_Mutex); raise AdminLimitExceeded; end if; case Ctype is when ANY_EVENT => Ptype := PULL_ANY; Proxy_Id := CosNotifyChannelAdmin.ProxyID (AllProxies.Length (Self.X.AllPxs)); Servant_To_Reference (Servant (Self.X.This), MyRef); Supplier := CosNotifyChannelAdmin.ProxyPullSupplier.Impl.Create (MyRef, Self.X.QoSPropSeq, Ptype, Proxy_Id); Servant_To_Reference (Servant (Supplier), Returns); SRef := CosNotifyChannelAdmin.ProxyPullSupplier.Helper.To_Ref (Returns); PullSuppliers.Append (Self.X.Pulls, SRef); Append (Self.X.PullIDSeq, Proxy_Id); AllProxies.Append (Self.X.AllPxs, CORBA.Long (Proxy_Id)); when STRUCTURED_EVENT => Ptype := PULL_STRUCTURED; Proxy_Id := CosNotifyChannelAdmin.ProxyID (AllProxies.Length (Self.X.AllPxs)); Servant_To_Reference (Servant (Self.X.This), MyRef); Struct_Supplier := CosNotifyChannelAdmin.StructuredProxyPullSupplier.Impl.Create (MyRef, Self.X.QoSPropSeq, Ptype, Proxy_Id); Servant_To_Reference (Servant (Struct_Supplier), Returns); Struct_SRef := CosNotifyChannelAdmin.StructuredProxyPullSupplier. Helper.To_Ref (Returns); StructuredPullSuppliers.Append (Self.X.StructPulls, Struct_SRef); Append (Self.X.PullIDSeq, Proxy_Id); AllProxies.Append (Self.X.AllPxs, CORBA.Long (Proxy_Id)); when SEQUENCE_EVENT => Ptype := PULL_SEQUENCE; Proxy_Id := CosNotifyChannelAdmin.ProxyID (AllProxies.Length (Self.X.AllPxs)); Servant_To_Reference (Servant (Self.X.This), MyRef); Seq_Supplier := CosNotifyChannelAdmin.SequenceProxyPullSupplier.Impl.Create (MyRef, Self.X.QoSPropSeq, Ptype, Proxy_Id); Servant_To_Reference (Servant (Seq_Supplier), Returns); Seq_SRef := CosNotifyChannelAdmin.SequenceProxyPullSupplier. Helper.To_Ref (Returns); SequencePullSuppliers.Append (Self.X.SequencePulls, Seq_SRef); Append (Self.X.PullIDSeq, Proxy_Id); AllProxies.Append (Self.X.AllPxs, CORBA.Long (Proxy_Id)); end case; Leave (Self_Mutex); end Obtain_Notification_Pull_Supplier; --------------------------------------- -- Obtain_Notification_Push_Supplier -- --------------------------------------- procedure Obtain_Notification_Push_Supplier (Self : access Object; Ctype : CosNotifyChannelAdmin.ClientType; Proxy_Id : out CosNotifyChannelAdmin.ProxyID; Returns : out CosNotifyChannelAdmin.ProxySupplier.Ref) is Channel : CosNotifyChannelAdmin.EventChannel.Impl.Object_Ptr; MyRef : CosNotifyChannelAdmin.ConsumerAdmin.Ref; Ptype : CosNotifyChannelAdmin.ProxyType; Res : CORBA.Boolean; Supplier : CosNotifyChannelAdmin.ProxyPushSupplier. Impl.Object_Ptr; Seq_Supplier : CosNotifyChannelAdmin.SequenceProxyPushSupplier. Impl.Object_Ptr; Struct_Supplier : CosNotifyChannelAdmin.StructuredProxyPushSupplier. Impl.Object_Ptr; SRef : CosNotifyChannelAdmin.ProxyPushSupplier.Ref; Seq_SRef : CosNotifyChannelAdmin.SequenceProxyPushSupplier.Ref; Struct_SRef : CosNotifyChannelAdmin.StructuredProxyPushSupplier.Ref; begin Ensure_Initialization; pragma Debug (O ("obtain_notification_push_supplier in consumeradmin")); Enter (Self_Mutex); Reference_To_Servant (Self.X.Channel, Servant (Channel)); Res := CosNotifyChannelAdmin.EventChannel.Impl. TestSupplierLimit (Channel); if Res = False then Leave (Self_Mutex); raise AdminLimitExceeded; end if; case Ctype is when ANY_EVENT => Ptype := PUSH_ANY; Proxy_Id := CosNotifyChannelAdmin.ProxyID (AllProxies.Length (Self.X.AllPxs)); Servant_To_Reference (Servant (Self.X.This), MyRef); Supplier := CosNotifyChannelAdmin.ProxyPushSupplier.Impl.Create (MyRef, Self.X.QoSPropSeq, Ptype, Proxy_Id); Servant_To_Reference (Servant (Supplier), Returns); SRef := CosNotifyChannelAdmin.ProxyPushSupplier.Helper.To_Ref (Returns); PushSuppliers.Append (Self.X.Pushs, SRef); Append (Self.X.PushIDSeq, Proxy_Id); AllProxies.Append (Self.X.AllPxs, CORBA.Long (Proxy_Id)); when STRUCTURED_EVENT => Ptype := PUSH_STRUCTURED; Proxy_Id := CosNotifyChannelAdmin.ProxyID (AllProxies.Length (Self.X.AllPxs)); Servant_To_Reference (Servant (Self.X.This), MyRef); Struct_Supplier := CosNotifyChannelAdmin.StructuredProxyPushSupplier.Impl.Create (MyRef, Self.X.QoSPropSeq, Ptype, Proxy_Id); Servant_To_Reference (Servant (Struct_Supplier), Returns); Struct_SRef := CosNotifyChannelAdmin.StructuredProxyPushSupplier. Helper.To_Ref (Returns); StructuredPushSuppliers.Append (Self.X.StructPushs, Struct_SRef); Append (Self.X.PushIDSeq, Proxy_Id); AllProxies.Append (Self.X.AllPxs, CORBA.Long (Proxy_Id)); when SEQUENCE_EVENT => Ptype := PUSH_SEQUENCE; Proxy_Id := CosNotifyChannelAdmin.ProxyID (AllProxies.Length (Self.X.AllPxs)); Servant_To_Reference (Servant (Self.X.This), MyRef); Seq_Supplier := CosNotifyChannelAdmin.SequenceProxyPushSupplier.Impl.Create (MyRef, Self.X.QoSPropSeq, Ptype, Proxy_Id); Servant_To_Reference (Servant (Seq_Supplier), Returns); Seq_SRef := CosNotifyChannelAdmin.SequenceProxyPushSupplier. Helper.To_Ref (Returns); SequencePushSuppliers.Append (Self.X.SequencePushs, Seq_SRef); Append (Self.X.PushIDSeq, Proxy_Id); AllProxies.Append (Self.X.AllPxs, CORBA.Long (Proxy_Id)); end case; Leave (Self_Mutex); end Obtain_Notification_Push_Supplier; ------------- -- Destroy -- ------------- procedure Destroy (Self : access Object) is pragma Warnings (Off); -- WAG:3.14 pragma Unreferenced (Self); pragma Warnings (On); -- WAG:3.14 begin Ensure_Initialization; pragma Debug (O ("destroy in consumeradmin")); Enter (Self_Mutex); Leave (Self_Mutex); end Destroy; ------------- -- Get_QoS -- ------------- function Get_QoS (Self : access Object) return CosNotification.QoSProperties is MyQoS : CosNotification.QoSProperties; begin Ensure_Initialization; pragma Debug (O ("get_qos in consumeradmin")); Enter (Self_Mutex); MyQoS := Self.X.QoSPropSeq; Leave (Self_Mutex); return MyQoS; end Get_QoS; ------------- -- Set_QoS -- ------------- procedure Set_QoS (Self : access Object; QoS : CosNotification.QoSProperties) is My_Ptr : ConsumerAdmin.Impl.Object_Ptr; MyProp : CosNotification.Property; MyError : CosNotification.PropertyError; MyErrCode : CosNotification.QoSError_code; MyRange : CosNotification.PropertyRange; MyErrorSeq : CosNotification.PropertyErrorSeq; SeqLen : Integer; Suppliers : CORBA.Long; begin Ensure_Initialization; pragma Debug (O ("set_qos in consumeradmin")); Enter (Self_Mutex); My_Ptr := Self.X.This; Leave (Self_Mutex); Suppliers := GetTotalSuppliers (My_Ptr); SeqLen := Length (QoS); for Index in 1 .. SeqLen loop MyProp := Get_Element (QoS, Index); if MyProp.name = "EventReliability" then MyErrCode := UNAVAILABLE_PROPERTY; MyRange := (To_Any (CORBA.Short (0)), To_Any (CORBA.Short (0))); MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); elsif MyProp.name = "ConnectionReliability" then if Suppliers > 0 then MyErrCode := UNAVAILABLE_PROPERTY; MyRange := (To_Any (CORBA.Short (0)), To_Any (CORBA.Short (0))); MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); elsif CORBA.Short'(From_Any (MyProp.value)) /= 0 and then CORBA.Short'(From_Any (MyProp.value)) /= 1 then MyErrCode := BAD_VALUE; MyRange := (To_Any (CORBA.Short (0)), To_Any (CORBA.Short (0))); MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); end if; elsif MyProp.name = "Priority" then if CORBA.Short'(From_Any (MyProp.value)) not in -32_767 .. 32_767 then MyErrCode := BAD_VALUE; MyRange := (To_Any (CORBA.Short (-32767)), To_Any (CORBA.Short (32767))); MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); end if; elsif MyProp.name = "StartTime" then MyErrCode := UNAVAILABLE_PROPERTY; MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); elsif MyProp.name = "StopTime" then MyErrCode := UNAVAILABLE_PROPERTY; MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); elsif MyProp.name = "Timeout" then MyErrCode := UNSUPPORTED_PROPERTY; MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); elsif MyProp.name = "OrderPolicy" then if CORBA.Short'(From_Any (MyProp.value)) /= 0 and then CORBA.Short'(From_Any (MyProp.value)) /= 1 and then CORBA.Short'(From_Any (MyProp.value)) /= 2 and then CORBA.Short'(From_Any (MyProp.value)) /= 3 then MyErrCode := BAD_VALUE; MyRange := (To_Any (CORBA.Short (0)), To_Any (CORBA.Short (3))); MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); end if; elsif MyProp.name = "DiscardPolicy" then if CORBA.Short'(From_Any (MyProp.value)) /= 0 and then CORBA.Short'(From_Any (MyProp.value)) /= 1 and then CORBA.Short'(From_Any (MyProp.value)) /= 2 and then CORBA.Short'(From_Any (MyProp.value)) /= 3 and then CORBA.Short'(From_Any (MyProp.value)) /= 4 then MyErrCode := BAD_VALUE; MyRange := (To_Any (CORBA.Short (0)), To_Any (CORBA.Short (4))); MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); end if; elsif MyProp.name = "MaximumBatchSize" then MyErrCode := UNSUPPORTED_PROPERTY; MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); elsif MyProp.name = "PacingInterval" then MyErrCode := UNSUPPORTED_PROPERTY; MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); elsif MyProp.name = "StartTimeSupported" then MyErrCode := UNSUPPORTED_PROPERTY; MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); elsif MyProp.name = "StopTimeSupported" then MyErrCode := UNSUPPORTED_PROPERTY; MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); elsif MyProp.name = "MaxEventsPerConsumer" then MyErrCode := UNSUPPORTED_PROPERTY; MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); else MyErrCode := BAD_PROPERTY; MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); end if; end loop; if Length (MyErrorSeq) > 0 then CosNotification.Helper.Raise_UnsupportedQoS ((CORBA.IDL_Exception_Members with qos_err => MyErrorSeq)); end if; SeqLen := Length (QoS); Enter (Self_Mutex); for Index in 1 .. SeqLen loop MyProp := Get_Element (QoS, Index); if MyProp.name = "ConnectionReliability" then Replace_Element (Self.X.QoSPropSeq, 2, MyProp); elsif MyProp.name = "Priority" then Replace_Element (Self.X.QoSPropSeq, 3, MyProp); elsif MyProp.name = "OrderPolicy" then Replace_Element (Self.X.QoSPropSeq, 4, MyProp); elsif MyProp.name = "DiscardPolicy" then Replace_Element (Self.X.QoSPropSeq, 5, MyProp); end if; end loop; Leave (Self_Mutex); end Set_QoS; ------------------ -- Validate_QoS -- ------------------ procedure Validate_QoS (Self : access Object; Required_QoS : CosNotification.QoSProperties; Available_QoS : out CosNotification.NamedPropertyRangeSeq) is My_Ptr : ConsumerAdmin.Impl.Object_Ptr; MyProp : CosNotification.Property; MyError : CosNotification.PropertyError; MyErrCode : CosNotification.QoSError_code; MyNamedRange : CosNotification.NamedPropertyRange; MyRange : CosNotification.PropertyRange; MyErrorSeq : CosNotification.PropertyErrorSeq; SeqLen : Integer; Suppliers : CORBA.Long; begin Ensure_Initialization; pragma Debug (O ("validate_qos in consumeradmin")); Enter (Self_Mutex); My_Ptr := Self.X.This; Leave (Self_Mutex); Suppliers := GetTotalSuppliers (My_Ptr); SeqLen := Length (Required_QoS); for Index in 1 .. SeqLen loop MyProp := Get_Element (Required_QoS, Index); if MyProp.name = "EventReliability" then MyErrCode := UNAVAILABLE_PROPERTY; MyRange := (To_Any (CORBA.Short (0)), To_Any (CORBA.Short (0))); MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); elsif MyProp.name = "ConnectionReliability" then if Suppliers > 0 then MyErrCode := UNAVAILABLE_PROPERTY; MyRange := (To_Any (CORBA.Short (0)), To_Any (CORBA.Short (0))); MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); elsif CORBA.Short'(From_Any (MyProp.value)) /= 0 and then CORBA.Short'(From_Any (MyProp.value)) /= 1 then MyErrCode := BAD_VALUE; MyRange := (To_Any (CORBA.Short (0)), To_Any (CORBA.Short (0))); MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); end if; elsif MyProp.name = "Priority" then if CORBA.Short'(From_Any (MyProp.value)) not in -32_767 .. 32_767 then MyErrCode := BAD_VALUE; MyRange := (To_Any (CORBA.Short (-32767)), To_Any (CORBA.Short (32767))); MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); end if; elsif MyProp.name = "StartTime" then MyErrCode := UNAVAILABLE_PROPERTY; MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); elsif MyProp.name = "StopTime" then MyErrCode := UNAVAILABLE_PROPERTY; MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); elsif MyProp.name = "Timeout" then MyErrCode := UNSUPPORTED_PROPERTY; MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); elsif MyProp.name = "OrderPolicy" then if CORBA.Short'(From_Any (MyProp.value)) /= 0 and then CORBA.Short'(From_Any (MyProp.value)) /= 1 and then CORBA.Short'(From_Any (MyProp.value)) /= 2 and then CORBA.Short'(From_Any (MyProp.value)) /= 3 then MyErrCode := BAD_VALUE; MyRange := (To_Any (CORBA.Short (0)), To_Any (CORBA.Short (3))); MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); end if; elsif MyProp.name = "DiscardPolicy" then if CORBA.Short'(From_Any (MyProp.value)) /= 0 and then CORBA.Short'(From_Any (MyProp.value)) /= 1 and then CORBA.Short'(From_Any (MyProp.value)) /= 2 and then CORBA.Short'(From_Any (MyProp.value)) /= 3 and then CORBA.Short'(From_Any (MyProp.value)) /= 4 then MyErrCode := BAD_VALUE; MyRange := (To_Any (CORBA.Short (0)), To_Any (CORBA.Short (4))); MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); end if; elsif MyProp.name = "MaximumBatchSize" then MyErrCode := UNSUPPORTED_PROPERTY; MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); elsif MyProp.name = "PacingInterval" then MyErrCode := UNSUPPORTED_PROPERTY; MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); elsif MyProp.name = "StartTimeSupported" then MyErrCode := UNSUPPORTED_PROPERTY; MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); elsif MyProp.name = "StopTimeSupported" then MyErrCode := UNSUPPORTED_PROPERTY; MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); elsif MyProp.name = "MaxEventsPerConsumer" then MyErrCode := UNSUPPORTED_PROPERTY; MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); else MyErrCode := BAD_PROPERTY; MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); end if; end loop; if Length (MyErrorSeq) > 0 then CosNotification.Helper.Raise_UnsupportedQoS ((CORBA.IDL_Exception_Members with qos_err => MyErrorSeq)); end if; Enter (Self_Mutex); SeqLen := Length (Self.X.QoSPropSeq); for Index in 1 .. SeqLen loop MyProp := Get_Element (Self.X.QoSPropSeq, Index); if MyProp.name = "ConnectionReliability" then MyRange := (From_Any (MyProp.value), To_Any (CORBA.Short (0))); MyNamedRange := (MyProp.name, MyRange); Append (Available_QoS, MyNamedRange); elsif MyProp.name = "Priority" then MyRange := (To_Any (CORBA.Short (-32767)), To_Any (CORBA.Short (32767))); MyNamedRange := (MyProp.name, MyRange); Append (Available_QoS, MyNamedRange); elsif MyProp.name = "OrderPolicy" then MyRange := (To_Any (CORBA.Short (0)), To_Any (CORBA.Short (3))); MyNamedRange := (MyProp.name, MyRange); Append (Available_QoS, MyNamedRange); elsif MyProp.name = "DiscardPolicy" then MyRange := (To_Any (CORBA.Short (0)), To_Any (CORBA.Short (4))); MyNamedRange := (MyProp.name, MyRange); Append (Available_QoS, MyNamedRange); end if; end loop; Leave (Self_Mutex); end Validate_QoS; ------------------------- -- Subscription_Change -- ------------------------- procedure Subscription_Change (Self : access Object; Added : CosNotification.EventTypeSeq; Removed : CosNotification.EventTypeSeq) is pragma Warnings (Off); -- WAG:3.14 pragma Unreferenced (Self, Added, Removed); pragma Warnings (On); -- WAG:3.14 begin Ensure_Initialization; pragma Debug (O ("subscription_change in consumeradmin")); Enter (Self_Mutex); Leave (Self_Mutex); end Subscription_Change; ---------------- -- Add_Filter -- ---------------- function Add_Filter (Self : access Object; New_Filter : CosNotifyFilter.Filter.Ref) return CosNotifyFilter.FilterID is pragma Warnings (Off); -- WAG:3.14 pragma Unreferenced (Self, New_Filter); pragma Warnings (On); -- WAG:3.14 MyFilterID : CosNotifyFilter.FilterID; MyID : CORBA.Long; begin Ensure_Initialization; pragma Debug (O ("add_filter in consumeradmin")); Enter (Self_Mutex); Leave (Self_Mutex); MyID := 0; MyFilterID := CosNotifyFilter.FilterID (MyID); return MyFilterID; end Add_Filter; ------------------- -- Remove_Filter -- ------------------- procedure Remove_Filter (Self : access Object; Filter : CosNotifyFilter.FilterID) is pragma Warnings (Off); -- WAG:3.14 pragma Unreferenced (Self, Filter); pragma Warnings (On); -- WAG:3.14 begin Ensure_Initialization; pragma Debug (O ("remove_filter in consumeradmin")); Enter (Self_Mutex); Leave (Self_Mutex); end Remove_Filter; ---------------- -- Get_Filter -- ---------------- function Get_Filter (Self : access Object; Filter : CosNotifyFilter.FilterID) return CosNotifyFilter.Filter.Ref is pragma Warnings (Off); -- WAG:3.14 pragma Unreferenced (Self, Filter); pragma Warnings (On); -- WAG:3.14 MyFilter : CosNotifyFilter.Filter.Ref; begin Ensure_Initialization; pragma Debug (O ("get_filter in consumeradmin")); Enter (Self_Mutex); Leave (Self_Mutex); return MyFilter; end Get_Filter; --------------------- -- Get_All_Filters -- --------------------- function Get_All_Filters (Self : access Object) return CosNotifyFilter.FilterIDSeq is pragma Warnings (Off); -- WAG:3.14 pragma Unreferenced (Self); pragma Warnings (On); -- WAG:3.14 MyFilterSeq : CosNotifyFilter.FilterIDSeq; begin Ensure_Initialization; pragma Debug (O ("get_all_filters in consumeradmin")); Enter (Self_Mutex); Leave (Self_Mutex); return MyFilterSeq; end Get_All_Filters; ------------------------ -- Remove_All_Filters -- ------------------------ procedure Remove_All_Filters (Self : access Object) is pragma Warnings (Off); -- WAG:3.14 pragma Unreferenced (Self); pragma Warnings (On); -- WAG:3.14 begin Ensure_Initialization; pragma Debug (O ("remove_all_filters in consumeradmin")); Enter (Self_Mutex); Leave (Self_Mutex); end Remove_All_Filters; -------------------------- -- Obtain_Push_Supplier -- -------------------------- function Obtain_Push_Supplier (Self : access Object) return CosEventChannelAdmin.ProxyPushSupplier.Ref is pragma Warnings (Off); -- WAG:3.14 pragma Unreferenced (Self); pragma Warnings (On); -- WAG:3.14 MySupplier : CosEventChannelAdmin.ProxyPushSupplier.Ref; begin Ensure_Initialization; pragma Debug (O ("obtain_push_supplier in consumeradmin")); Enter (Self_Mutex); Leave (Self_Mutex); return MySupplier; end Obtain_Push_Supplier; -------------------------- -- Obtain_Pull_Supplier -- -------------------------- function Obtain_Pull_Supplier (Self : access Object) return CosEventChannelAdmin.ProxyPullSupplier.Ref is pragma Warnings (Off); -- WAG:3.14 pragma Unreferenced (Self); pragma Warnings (On); -- WAG:3.14 MySupplier : CosEventChannelAdmin.ProxyPullSupplier.Ref; begin Ensure_Initialization; pragma Debug (O ("obtain_pull_supplier in consumeradmin")); Enter (Self_Mutex); Leave (Self_Mutex); return MySupplier; end Obtain_Pull_Supplier; ------------ -- Create -- ------------ function Create (Channel : CosNotifyChannelAdmin.EventChannel.Ref; Initial_QoS : CosNotification.QoSProperties; MyID : CosNotifyChannelAdmin.AdminID; MyOp : CosNotifyChannelAdmin.InterFilterGroupOperator := AND_OP) return Object_Ptr is Consumer : Object_Ptr; My_Ref : CosNotifyChannelAdmin.ConsumerAdmin.Ref; begin pragma Debug (O ("create consumeradmin")); Consumer := new Object; Consumer.X := new Consumer_Admin_Record; Consumer.X.This := Consumer; Consumer.X.Channel := Channel; Consumer.X.Id := MyID; Consumer.X.Op := MyOp; Consumer.X.QoSPropSeq := Initial_QoS; Initiate_Servant (Servant (Consumer), My_Ref); return Consumer; end Create; ----------------------- -- GetTotalSuppliers -- ----------------------- function GetTotalSuppliers (Self : access Object) return CORBA.Long is MyCount : CORBA.Long; begin Ensure_Initialization; pragma Debug (O ("gettotalsuppliers from consumeradmin")); MyCount := CORBA.Long (AllProxies.Length (Self.X.AllPxs)); return MyCount; end GetTotalSuppliers; ---------- -- Post -- ---------- procedure Post (Self : access Object; Data : CORBA.Any; Internal_Post : CORBA.Boolean := False) is PullSupplier : CosNotifyChannelAdmin.ProxyPullSupplier.Impl.Object_Ptr; PushSupplier : CosNotifyChannelAdmin.ProxyPushSupplier.Impl.Object_Ptr; begin Ensure_Initialization; Enter (Self_Mutex); declare Pulls : constant PullSuppliers.Element_Array := PullSuppliers.To_Element_Array (Self.X.Pulls); Pushs : constant PushSuppliers.Element_Array := PushSuppliers.To_Element_Array (Self.X.Pushs); begin Leave (Self_Mutex); pragma Debug (O ("post new data from consumeradmin to proxy pull suppliers")); for J in Pulls'Range loop Reference_To_Servant (Pulls (J), Servant (PullSupplier)); CosNotifyChannelAdmin.ProxyPullSupplier.Impl.Post (PullSupplier, Data); end loop; pragma Debug (O ("post new data from consumeradmin to proxy push suppliers")); for J in Pushs'Range loop Reference_To_Servant (Pushs (J), Servant (PushSupplier)); CosNotifyChannelAdmin.ProxyPushSupplier.Impl.Post (PushSupplier, Data); end loop; end; if not Internal_Post then declare MyEventHeader : CosNotification.EventHeader; MyFixedEventHeader : CosNotification.FixedEventHeader; MyOpt_HeaderFields : CosNotification.OptionalHeaderFields; MyEventType : CosNotification.EventType; MyFilterableEventBody : CosNotification.FilterableEventBody; MyRemainder_Of_Body : constant CORBA.Any := Data; MyStructuredEvent : CosNotification.StructuredEvent; MyStruct_Sequence : CosNotification.EventBatch; Intern_Post : constant CORBA.Boolean := True; begin MyEventType.domain_name := To_CORBA_String (""); MyEventType.type_name := To_CORBA_String ("%ANY"); MyFixedEventHeader.event_type := MyEventType; MyFixedEventHeader.event_name := To_CORBA_String (""); MyEventHeader := (MyFixedEventHeader, MyOpt_HeaderFields); MyStructuredEvent.header := MyEventHeader; MyStructuredEvent.filterable_data := MyFilterableEventBody; MyStructuredEvent.remainder_of_body := MyRemainder_Of_Body; -- After converting every Any into StructuredEvent call -- Structured_Post to deliver it to all structured proxy supplier Structured_Post (Self.X.This, MyStructuredEvent, Intern_Post); -- Create a Sequence of Structured Events and append the newly -- created structured event into this sequence and send it to -- all sequence proxy suppliers by calling Sequence_Post Append (MyStruct_Sequence, MyStructuredEvent); Sequence_Post (Self.X.This, MyStruct_Sequence, Intern_Post); end; end if; end Post; --------------------- -- Structured_Post -- --------------------- procedure Structured_Post (Self : access Object; Notification : CosNotification.StructuredEvent; Internal_Post : CORBA.Boolean := False) is PushSupplier : CosNotifyChannelAdmin.StructuredProxyPushSupplier. Impl.Object_Ptr; PullSupplier : CosNotifyChannelAdmin.StructuredProxyPullSupplier. Impl.Object_Ptr; begin Ensure_Initialization; Enter (Self_Mutex); declare StructPushs : constant StructuredPushSuppliers.Element_Array := StructuredPushSuppliers.To_Element_Array (Self.X.StructPushs); StructPulls : constant StructuredPullSuppliers.Element_Array := StructuredPullSuppliers.To_Element_Array (Self.X.StructPulls); begin Leave (Self_Mutex); pragma Debug (O ("post new structedevent from consumeradmin " & "to structedproxypull suppliers")); for J in StructPulls'Range loop Reference_To_Servant (StructPulls (J), Servant (PullSupplier)); CosNotifyChannelAdmin.StructuredProxyPullSupplier.Impl. Structured_Post (PullSupplier, Notification); end loop; pragma Debug (O ("post new structedevent from consumeradmin " & "to structedproxypush suppliers")); for J in StructPushs'Range loop Reference_To_Servant (StructPushs (J), Servant (PushSupplier)); CosNotifyChannelAdmin.StructuredProxyPushSupplier.Impl. Structured_Post (PushSupplier, Notification); end loop; end; if not Internal_Post then declare Data : constant CORBA.Any := CosNotification.Helper. To_Any (Notification); MyStruct_Sequence : CosNotification.EventBatch; Intern_Post : constant CORBA.Boolean := True; begin -- After converting notification into Any call -- post for delivery to all untyped proxy suppliers Post (Self.X.This, Data, Intern_Post); -- Create a Sequence of Structured Events and append -- notification into this sequence. Send it to -- all sequence proxy suppliers by calling Sequence_Post Append (MyStruct_Sequence, Notification); Sequence_Post (Self.X.This, MyStruct_Sequence, Intern_Post); end; end if; end Structured_Post; ------------------- -- Sequence_Post -- ------------------- procedure Sequence_Post (Self : access Object; Notifications : CosNotification.EventBatch; Internal_Post : CORBA.Boolean := False) is PushSupplier : CosNotifyChannelAdmin.SequenceProxyPushSupplier. Impl.Object_Ptr; PullSupplier : CosNotifyChannelAdmin.SequenceProxyPullSupplier. Impl.Object_Ptr; begin Ensure_Initialization; Enter (Self_Mutex); declare SequencePushs : constant SequencePushSuppliers.Element_Array := SequencePushSuppliers.To_Element_Array (Self.X.SequencePushs); SequencePulls : constant SequencePullSuppliers.Element_Array := SequencePullSuppliers.To_Element_Array (Self.X.SequencePulls); begin Leave (Self_Mutex); pragma Debug (O ("post new sequence of structedevent from consumeradmin " & "to sequenceproxypull suppliers")); for J in SequencePulls'Range loop Reference_To_Servant (SequencePulls (J), Servant (PullSupplier)); CosNotifyChannelAdmin.SequenceProxyPullSupplier.Impl. Sequence_Post (PullSupplier, Notifications); end loop; pragma Debug (O ("post new sequence of structedevent from consumeradmin " & "to sequenceproxypush suppliers")); for J in SequencePushs'Range loop Reference_To_Servant (SequencePushs (J), Servant (PushSupplier)); CosNotifyChannelAdmin.SequenceProxyPushSupplier.Impl. Sequence_Post (PushSupplier, Notifications); end loop; end; if not Internal_Post then declare Data : CORBA.Any; Intern_Post : constant CORBA.Boolean := True; Notification : CosNotification.StructuredEvent; SeqLen : constant Integer := Length (Notifications); begin for Index in 1 .. SeqLen loop Notification := Get_Element (Notifications, Index); -- Send every structedevent to all structured proxy suppliers -- by calling Structured_Post every time Structured_Post (Self.X.This, Notification, Intern_Post); -- Convert every structedevent into any and call post -- for delivery to all untyped proxy suppliers Data := CosNotification.Helper.To_Any (Notification); Post (Self.X.This, Data, Intern_Post); end loop; end; end if; end Sequence_Post; end CosNotifyChannelAdmin.ConsumerAdmin.Impl; polyorb-2.8~20110207.orig/cos/notification/cosnotifychanneladmin-proxypushconsumer-impl.adb0000644000175000017500000006134211750740337031511 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- COSNOTIFYCHANNELADMIN.PROXYPUSHCONSUMER.IMPL -- -- -- -- B o d y -- -- -- -- Copyright (C) 2003-2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with CosEventChannelAdmin.Helper; with CosNotification; with CosNotification.Helper; with CosNotifyChannelAdmin.SupplierAdmin.Impl; with PolyORB.CORBA_P.Server_Tools; with PolyORB.Log; with PolyORB.Tasking.Mutexes; with CosNotifyChannelAdmin.ProxyPushConsumer.Skel; pragma Warnings (Off, CosNotifyChannelAdmin.ProxyPushConsumer.Skel); package body CosNotifyChannelAdmin.ProxyPushConsumer.Impl is use CosNotification; use IDL_SEQUENCE_CosNotification_Property; use IDL_SEQUENCE_CosNotification_PropertyError; use IDL_SEQUENCE_CosNotification_NamedPropertyRange; use CORBA; use PortableServer; package Convert is new SupplierAdmin_Forward.Convert (CosNotifyChannelAdmin.SupplierAdmin.Ref); use PolyORB.CORBA_P.Server_Tools; use PolyORB.Tasking.Mutexes; use PolyORB.Log; package L is new PolyORB.Log.Facility_Log ("proxypushconsumer"); procedure O (Message : Standard.String; Level : Log_Level := Debug) renames L.Output; function C (Level : Log_Level := Debug) return Boolean renames L.Enabled; pragma Unreferenced (C); -- For conditional pragma Debug type Proxy_Push_Consumer_Record is record This : Object_Ptr; Admin : CosNotifyChannelAdmin.SupplierAdmin.Ref; MyId : CosNotifyChannelAdmin.ProxyID; MyType : CosNotifyChannelAdmin.ProxyType; Peer : CosEventComm.PushSupplier.Ref; QoSPropSeq : CosNotification.QoSProperties; end record; --------------------------- -- Ensure_Initialization -- --------------------------- procedure Ensure_Initialization; pragma Inline (Ensure_Initialization); -- Ensure that the Mutexes are initialized T_Initialized : Boolean := False; Self_Mutex : Mutex_Access; procedure Ensure_Initialization is begin if not T_Initialized then Create (Self_Mutex); T_Initialized := True; end if; end Ensure_Initialization; ------------------------------- -- Connect_Any_Push_Supplier -- ------------------------------- procedure Connect_Any_Push_Supplier (Self : access Object; Push_Supplier : CosEventComm.PushSupplier.Ref) is begin pragma Debug (O ("connect_any_push_supplier in proxypushconsumer")); Ensure_Initialization; Enter (Self_Mutex); if not CosEventComm.PushSupplier.Is_Nil (Self.X.Peer) then Leave (Self_Mutex); CosEventChannelAdmin.Helper.Raise_AlreadyConnected ((CORBA.IDL_Exception_Members with null record)); end if; Self.X.Peer := Push_Supplier; Leave (Self_Mutex); end Connect_Any_Push_Supplier; ---------------- -- Get_MyType -- ---------------- function Get_MyType (Self : access Object) return CosNotifyChannelAdmin.ProxyType is MyType : CosNotifyChannelAdmin.ProxyType; begin pragma Debug (O ("get_mytype in proxypushconsumer")); Ensure_Initialization; Enter (Self_Mutex); MyType := Self.X.MyType; Leave (Self_Mutex); return MyType; end Get_MyType; ----------------- -- Get_MyAdmin -- ----------------- function Get_MyAdmin (Self : access Object) return CosNotifyChannelAdmin.SupplierAdmin_Forward.Ref is MyAdmin : CosNotifyChannelAdmin.SupplierAdmin_Forward.Ref; begin pragma Debug (O ("get_myadmin in proxypushconsumer")); Ensure_Initialization; Enter (Self_Mutex); MyAdmin := Convert.To_Forward (Self.X.Admin); Leave (Self_Mutex); return MyAdmin; end Get_MyAdmin; ------------------------------- -- Obtain_Subscription_Types -- ------------------------------- function Obtain_Subscription_Types (Self : access Object; Mode : CosNotifyChannelAdmin.ObtainInfoMode) return CosNotification.EventTypeSeq is pragma Warnings (Off); -- WAG:3.14 pragma Unreferenced (Self, Mode); pragma Warnings (On); -- WAG:3.14 MySeq : CosNotification.EventTypeSeq; begin pragma Debug (O ("obtain_subscription_types in proxypushconsumer")); Ensure_Initialization; Enter (Self_Mutex); Leave (Self_Mutex); return MySeq; end Obtain_Subscription_Types; ------------------------ -- Validate_Event_QoS -- ------------------------ procedure Validate_Event_QoS (Self : access Object; Required_QoS : CosNotification.QoSProperties; Available_QoS : out CosNotification.NamedPropertyRangeSeq) is pragma Warnings (Off); -- WAG:3.14 pragma Unreferenced (Self, Required_QoS, Available_QoS); pragma Warnings (On); -- WAG:3.14 begin pragma Debug (O ("validate_event_qos in proxypushconsumer")); Ensure_Initialization; Enter (Self_Mutex); Leave (Self_Mutex); end Validate_Event_QoS; ------------- -- Get_QoS -- ------------- function Get_QoS (Self : access Object) return CosNotification.QoSProperties is MyQoS : CosNotification.QoSProperties; begin pragma Debug (O ("get_qos in proxypushconsumer")); Ensure_Initialization; Enter (Self_Mutex); MyQoS := Self.X.QoSPropSeq; Leave (Self_Mutex); return MyQoS; end Get_QoS; ------------- -- Set_QoS -- ------------- procedure Set_QoS (Self : access Object; QoS : CosNotification.QoSProperties) is MyProp : CosNotification.Property; MyError : CosNotification.PropertyError; MyErrCode : CosNotification.QoSError_code; MyRange : CosNotification.PropertyRange; MyErrorSeq : CosNotification.PropertyErrorSeq; SeqLen : Integer; begin pragma Debug (O ("set_qos in proxypushconsumer")); Ensure_Initialization; SeqLen := Length (QoS); for Index in 1 .. SeqLen loop MyProp := Get_Element (QoS, Index); if MyProp.name = "EventReliability" then MyErrCode := UNAVAILABLE_PROPERTY; MyRange := (To_Any (CORBA.Short (0)), To_Any (CORBA.Short (0))); MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); elsif MyProp.name = "ConnectionReliability" then if CORBA.Short'(From_Any (MyProp.value)) /= 0 and then CORBA.Short'(From_Any (MyProp.value)) /= 1 then MyErrCode := BAD_VALUE; MyRange := (To_Any (CORBA.Short (0)), To_Any (CORBA.Short (0))); MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); end if; elsif MyProp.name = "Priority" then if CORBA.Short'(From_Any (MyProp.value)) not in -32_767 .. 32_767 then MyErrCode := BAD_VALUE; MyRange := (To_Any (CORBA.Short (-32767)), To_Any (CORBA.Short (32767))); MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); end if; elsif MyProp.name = "StartTime" then MyErrCode := UNAVAILABLE_PROPERTY; MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); elsif MyProp.name = "StopTime" then MyErrCode := UNAVAILABLE_PROPERTY; MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); elsif MyProp.name = "Timeout" then MyErrCode := UNSUPPORTED_PROPERTY; MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); elsif MyProp.name = "OrderPolicy" then if CORBA.Short'(From_Any (MyProp.value)) /= 0 and then CORBA.Short'(From_Any (MyProp.value)) /= 1 and then CORBA.Short'(From_Any (MyProp.value)) /= 2 and then CORBA.Short'(From_Any (MyProp.value)) /= 3 then MyErrCode := BAD_VALUE; MyRange := (To_Any (CORBA.Short (0)), To_Any (CORBA.Short (3))); MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); end if; elsif MyProp.name = "DiscardPolicy" then if CORBA.Short'(From_Any (MyProp.value)) /= 0 and then CORBA.Short'(From_Any (MyProp.value)) /= 1 and then CORBA.Short'(From_Any (MyProp.value)) /= 2 and then CORBA.Short'(From_Any (MyProp.value)) /= 3 and then CORBA.Short'(From_Any (MyProp.value)) /= 4 then MyErrCode := BAD_VALUE; MyRange := (To_Any (CORBA.Short (0)), To_Any (CORBA.Short (4))); MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); end if; elsif MyProp.name = "MaximumBatchSize" then MyErrCode := UNSUPPORTED_PROPERTY; MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); elsif MyProp.name = "PacingInterval" then MyErrCode := UNSUPPORTED_PROPERTY; MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); elsif MyProp.name = "StartTimeSupported" then MyErrCode := UNSUPPORTED_PROPERTY; MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); elsif MyProp.name = "StopTimeSupported" then MyErrCode := UNSUPPORTED_PROPERTY; MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); elsif MyProp.name = "MaxEventsPerConsumer" then MyErrCode := UNSUPPORTED_PROPERTY; MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); else MyErrCode := BAD_PROPERTY; MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); end if; end loop; if Length (MyErrorSeq) > 0 then CosNotification.Helper.Raise_UnsupportedQoS ((CORBA.IDL_Exception_Members with qos_err => MyErrorSeq)); end if; SeqLen := Length (QoS); Enter (Self_Mutex); for Index in 1 .. SeqLen loop MyProp := Get_Element (QoS, Index); if MyProp.name = "ConnectionReliability" then Replace_Element (Self.X.QoSPropSeq, 2, MyProp); elsif MyProp.name = "Priority" then Replace_Element (Self.X.QoSPropSeq, 3, MyProp); elsif MyProp.name = "OrderPolicy" then Replace_Element (Self.X.QoSPropSeq, 4, MyProp); elsif MyProp.name = "DiscardPolicy" then Replace_Element (Self.X.QoSPropSeq, 5, MyProp); end if; end loop; Leave (Self_Mutex); end Set_QoS; ------------------ -- Validate_QoS -- ------------------ procedure Validate_QoS (Self : access Object; Required_QoS : CosNotification.QoSProperties; Available_QoS : out CosNotification.NamedPropertyRangeSeq) is MyProp : CosNotification.Property; MyError : CosNotification.PropertyError; MyErrCode : CosNotification.QoSError_code; MyNamedRange : CosNotification.NamedPropertyRange; MyRange : CosNotification.PropertyRange; MyErrorSeq : CosNotification.PropertyErrorSeq; SeqLen : Integer; begin pragma Debug (O ("validate_qos in proxypushconsumer")); Ensure_Initialization; SeqLen := Length (Required_QoS); for Index in 1 .. SeqLen loop MyProp := Get_Element (Required_QoS, Index); if MyProp.name = "EventReliability" then MyErrCode := UNAVAILABLE_PROPERTY; MyRange := (To_Any (CORBA.Short (0)), To_Any (CORBA.Short (0))); MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); elsif MyProp.name = "ConnectionReliability" then if CORBA.Short'(From_Any (MyProp.value)) /= 0 and then CORBA.Short'(From_Any (MyProp.value)) /= 1 then MyErrCode := BAD_VALUE; MyRange := (To_Any (CORBA.Short (0)), To_Any (CORBA.Short (0))); MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); end if; elsif MyProp.name = "Priority" then if CORBA.Short'(From_Any (MyProp.value)) not in -32_767 .. 32_767 then MyErrCode := BAD_VALUE; MyRange := (To_Any (CORBA.Short (-32767)), To_Any (CORBA.Short (32767))); MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); end if; elsif MyProp.name = "StartTime" then MyErrCode := UNAVAILABLE_PROPERTY; MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); elsif MyProp.name = "StopTime" then MyErrCode := UNAVAILABLE_PROPERTY; MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); elsif MyProp.name = "Timeout" then MyErrCode := UNSUPPORTED_PROPERTY; MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); elsif MyProp.name = "OrderPolicy" then if CORBA.Short'(From_Any (MyProp.value)) /= 0 and then CORBA.Short'(From_Any (MyProp.value)) /= 1 and then CORBA.Short'(From_Any (MyProp.value)) /= 2 and then CORBA.Short'(From_Any (MyProp.value)) /= 3 then MyErrCode := BAD_VALUE; MyRange := (To_Any (CORBA.Short (0)), To_Any (CORBA.Short (3))); MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); end if; elsif MyProp.name = "DiscardPolicy" then if CORBA.Short'(From_Any (MyProp.value)) /= 0 and then CORBA.Short'(From_Any (MyProp.value)) /= 1 and then CORBA.Short'(From_Any (MyProp.value)) /= 2 and then CORBA.Short'(From_Any (MyProp.value)) /= 3 and then CORBA.Short'(From_Any (MyProp.value)) /= 4 then MyErrCode := BAD_VALUE; MyRange := (To_Any (CORBA.Short (0)), To_Any (CORBA.Short (4))); MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); end if; elsif MyProp.name = "MaximumBatchSize" then MyErrCode := UNSUPPORTED_PROPERTY; MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); elsif MyProp.name = "PacingInterval" then MyErrCode := UNSUPPORTED_PROPERTY; MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); elsif MyProp.name = "StartTimeSupported" then MyErrCode := UNSUPPORTED_PROPERTY; MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); elsif MyProp.name = "StopTimeSupported" then MyErrCode := UNSUPPORTED_PROPERTY; MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); elsif MyProp.name = "MaxEventsPerConsumer" then MyErrCode := UNSUPPORTED_PROPERTY; MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); else MyErrCode := BAD_PROPERTY; MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); end if; end loop; if Length (MyErrorSeq) > 0 then CosNotification.Helper.Raise_UnsupportedQoS ((CORBA.IDL_Exception_Members with qos_err => MyErrorSeq)); end if; Enter (Self_Mutex); SeqLen := Length (Self.X.QoSPropSeq); for Index in 1 .. SeqLen loop MyProp := Get_Element (Self.X.QoSPropSeq, Index); if MyProp.name = "ConnectionReliability" then MyRange := (From_Any (MyProp.value), To_Any (CORBA.Short (0))); MyNamedRange := (MyProp.name, MyRange); Append (Available_QoS, MyNamedRange); elsif MyProp.name = "Priority" then MyRange := (To_Any (CORBA.Short (-32767)), To_Any (CORBA.Short (32767))); MyNamedRange := (MyProp.name, MyRange); Append (Available_QoS, MyNamedRange); elsif MyProp.name = "OrderPolicy" then MyRange := (To_Any (CORBA.Short (0)), To_Any (CORBA.Short (3))); MyNamedRange := (MyProp.name, MyRange); Append (Available_QoS, MyNamedRange); elsif MyProp.name = "DiscardPolicy" then MyRange := (To_Any (CORBA.Short (0)), To_Any (CORBA.Short (4))); MyNamedRange := (MyProp.name, MyRange); Append (Available_QoS, MyNamedRange); end if; end loop; Leave (Self_Mutex); end Validate_QoS; ---------------- -- Add_Filter -- ---------------- function Add_Filter (Self : access Object; New_Filter : CosNotifyFilter.Filter.Ref) return CosNotifyFilter.FilterID is pragma Warnings (Off); -- WAG:3.14 pragma Unreferenced (Self, New_Filter); pragma Warnings (On); -- WAG:3.14 MyFilterID : CosNotifyFilter.FilterID; MyID : CORBA.Long; begin pragma Debug (O ("add_filter in proxypushconsumer")); Ensure_Initialization; Enter (Self_Mutex); Leave (Self_Mutex); MyID := 0; MyFilterID := CosNotifyFilter.FilterID (MyID); return MyFilterID; end Add_Filter; ------------------- -- Remove_Filter -- ------------------- procedure Remove_Filter (Self : access Object; Filter : CosNotifyFilter.FilterID) is pragma Warnings (Off); -- WAG:3.14 pragma Unreferenced (Self, Filter); pragma Warnings (On); -- WAG:3.14 begin pragma Debug (O ("remove_filter in proxypushconsumer")); Ensure_Initialization; Enter (Self_Mutex); Leave (Self_Mutex); end Remove_Filter; ---------------- -- Get_Filter -- ---------------- function Get_Filter (Self : access Object; Filter : CosNotifyFilter.FilterID) return CosNotifyFilter.Filter.Ref is pragma Warnings (Off); -- WAG:3.14 pragma Unreferenced (Self, Filter); pragma Warnings (On); -- WAG:3.14 MyFilter : CosNotifyFilter.Filter.Ref; begin pragma Debug (O ("get_filter in proxypushconsumer")); Ensure_Initialization; Enter (Self_Mutex); Leave (Self_Mutex); return MyFilter; end Get_Filter; --------------------- -- Get_All_Filters -- --------------------- function Get_All_Filters (Self : access Object) return CosNotifyFilter.FilterIDSeq is pragma Warnings (Off); -- WAG:3.14 pragma Unreferenced (Self); pragma Warnings (On); -- WAG:3.14 MyFilterSeq : CosNotifyFilter.FilterIDSeq; begin pragma Debug (O ("get_all_filters in proxypushconsumer")); Ensure_Initialization; Enter (Self_Mutex); Leave (Self_Mutex); return MyFilterSeq; end Get_All_Filters; ------------------------ -- Remove_All_Filters -- ------------------------ procedure Remove_All_Filters (Self : access Object) is pragma Warnings (Off); -- WAG:3.14 pragma Unreferenced (Self); pragma Warnings (On); -- WAG:3.14 begin pragma Debug (O ("remove_all_filters in proxypushconsumer")); Ensure_Initialization; Enter (Self_Mutex); Leave (Self_Mutex); end Remove_All_Filters; ------------------ -- Offer_Change -- ------------------ procedure Offer_Change (Self : access Object; Added : CosNotification.EventTypeSeq; Removed : CosNotification.EventTypeSeq) is pragma Warnings (Off); -- WAG:3.14 pragma Unreferenced (Self, Added, Removed); pragma Warnings (On); -- WAG:3.14 begin pragma Debug (O ("offer_change in proxypushconsumer")); Ensure_Initialization; Enter (Self_Mutex); Leave (Self_Mutex); end Offer_Change; ---------- -- Push -- ---------- procedure Push (Self : access Object; Data : CORBA.Any) is Admin : CosNotifyChannelAdmin.SupplierAdmin.Impl.Object_Ptr; Admin_Ref : CosNotifyChannelAdmin.SupplierAdmin.Ref; begin pragma Debug (O ("push new data from proxy pushconsumer to supplier admin")); Ensure_Initialization; Enter (Self_Mutex); Admin_Ref := Self.X.Admin; Leave (Self_Mutex); Reference_To_Servant (Admin_Ref, Servant (Admin)); CosNotifyChannelAdmin.SupplierAdmin.Impl.Post (Admin, Data); end Push; ------------------------------ -- Disconnect_Push_Consumer -- ------------------------------ procedure Disconnect_Push_Consumer (Self : access Object) is Peer : CosEventComm.PushSupplier.Ref; Nil_Ref : CosEventComm.PushSupplier.Ref; begin pragma Debug (O ("disconnect proxypushconsumer")); Ensure_Initialization; Enter (Self_Mutex); Peer := Self.X.Peer; Self.X.Peer := Nil_Ref; Leave (Self_Mutex); if not CosEventComm.PushSupplier.Is_Nil (Peer) then CosEventComm.PushSupplier.disconnect_push_supplier (Peer); end if; end Disconnect_Push_Consumer; ------------ -- Create -- ------------ function Create (Admin : CosNotifyChannelAdmin.SupplierAdmin.Ref; Initial_QoS : CosNotification.QoSProperties; Ptype : CosNotifyChannelAdmin.ProxyType; Proxy_Id : CosNotifyChannelAdmin.ProxyID) return Object_Ptr is Consumer : Object_Ptr; My_Ref : ProxyPushConsumer.Ref; begin pragma Debug (O ("create proxypushconsumer")); Consumer := new Object; Consumer.X := new Proxy_Push_Consumer_Record; Consumer.X.Admin := Admin; Consumer.X.MyId := Proxy_Id; Consumer.X.MyType := Ptype; Consumer.X.This := Consumer; Consumer.X.QoSPropSeq := Initial_QoS; Initiate_Servant (Servant (Consumer), My_Ref); return Consumer; end Create; end CosNotifyChannelAdmin.ProxyPushConsumer.Impl; polyorb-2.8~20110207.orig/cos/notification/cosnotifycomm-pushsupplier-impl.ads0000644000175000017500000000647211750740337026755 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- C O S N O T I F Y C O M M . P U S H S U P P L I E R . I M P L -- -- -- -- S p e c -- -- -- -- Copyright (C) 2003-2008, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by ACT Europe. -- -- (email: sales@act-europe.fr) -- -- -- ------------------------------------------------------------------------------ with CORBA; with PortableServer; with CosNotifyChannelAdmin.ProxyPushConsumer; package CosNotifyComm.PushSupplier.Impl is type Object is new PortableServer.Servant_Base with private; type Object_Ptr is access all Object'Class; -- Inherited IDL operations from CosNotifyComm::NotifySubscribe procedure Subscription_Change (Self : access Object; Added : CosNotification.EventTypeSeq; Removed : CosNotification.EventTypeSeq); -- Inherited IDL operations from CosEventComm::PushSupplier procedure Disconnect_Push_Supplier (Self : access Object); ---------------------- -- PolyORB specific -- ---------------------- function Create return Object_Ptr; -- Call by application to create an object and activate servant procedure Connect_Any_Proxy_Push_Consumer (Self : access Object; Proxy : CosNotifyChannelAdmin.ProxyPushConsumer.Ref); -- Call by application to connect object with proxy procedure Push (Self : access Object; Data : CORBA.Any); -- Call by application to push data private type Push_Supplier_Record; type Push_Supplier_Access is access Push_Supplier_Record; type Object is new PortableServer.Servant_Base with record X : Push_Supplier_Access; end record; end CosNotifyComm.PushSupplier.Impl; polyorb-2.8~20110207.orig/cos/notification/cosnotifycomm-structuredpullsupplier-impl.adb0000644000175000017500000002174511750740337031056 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- COSNOTIFYCOMM.STRUCTUREDPULLSUPPLIER.IMPL -- -- -- -- B o d y -- -- -- -- Copyright (C) 2003-2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with CosEventChannelAdmin.Helper; with CosEventComm.Helper; with PolyORB.CORBA_P.Server_Tools; with PolyORB.Log; with PolyORB.Tasking.Mutexes; with PolyORB.Tasking.Semaphores; with CosNotifyComm.StructuredPullSupplier.Skel; pragma Warnings (Off, CosNotifyComm.StructuredPullSupplier.Skel); package body CosNotifyComm.StructuredPullSupplier.Impl is use PolyORB.CORBA_P.Server_Tools; use PolyORB.Tasking.Mutexes; use PolyORB.Tasking.Semaphores; use PolyORB.Log; package L is new PolyORB.Log.Facility_Log ("structuredpullsupplier"); procedure O (Message : Standard.String; Level : Log_Level := Debug) renames L.Output; function C (Level : Log_Level := Debug) return Boolean renames L.Enabled; pragma Unreferenced (C); -- For conditional pragma Debug type Structured_Pull_Supplier_Record is record This : Object_Ptr; Peer : CosNotifyChannelAdmin.StructuredProxyPullConsumer.Ref; Empty : Boolean; Event : CosNotification.StructuredEvent; Semaphore : Semaphore_Access; end record; --------------------------- -- Ensure_Initialization -- --------------------------- procedure Ensure_Initialization; pragma Inline (Ensure_Initialization); -- Ensure that the Mutexes are initialized T_Initialized : Boolean := False; Self_Mutex : Mutex_Access; procedure Ensure_Initialization is begin if not T_Initialized then Create (Self_Mutex); T_Initialized := True; end if; end Ensure_Initialization; -------------------------------------------- -- Connect_Structured_Proxy_Pull_Consumer -- -------------------------------------------- procedure Connect_Structured_Proxy_Pull_Consumer (Self : access Object; Proxy : CosNotifyChannelAdmin.StructuredProxyPullConsumer.Ref) is My_Ref : StructuredPullSupplier.Ref; begin Ensure_Initialization; pragma Debug (O ("connect_structured_proxy_pull_consumer in structuredpullsupplier")); Enter (Self_Mutex); if not CosNotifyChannelAdmin.StructuredProxyPullConsumer.Is_Nil (Self.X.Peer) then Leave (Self_Mutex); CosEventChannelAdmin.Helper.Raise_AlreadyConnected ((CORBA.IDL_Exception_Members with null record)); end if; Self.X.Peer := Proxy; Servant_To_Reference (PortableServer.Servant (Self.X.This), My_Ref); Leave (Self_Mutex); CosNotifyChannelAdmin.StructuredProxyPullConsumer. connect_structured_pull_supplier (Proxy, My_Ref); end Connect_Structured_Proxy_Pull_Consumer; ------------------------- -- Subscription_Change -- ------------------------- procedure Subscription_Change (Self : access Object; Added : CosNotification.EventTypeSeq; Removed : CosNotification.EventTypeSeq) is pragma Warnings (Off); -- WAG:3.14 pragma Unreferenced (Self, Added, Removed); pragma Warnings (On); -- WAG:3.14 begin Ensure_Initialization; pragma Debug (O ("subscription_change in structuredpullsupplier")); Enter (Self_Mutex); Leave (Self_Mutex); end Subscription_Change; ----------------------------------------- -- Disconnect_Structured_Pull_Supplier -- ----------------------------------------- procedure Disconnect_Structured_Pull_Supplier (Self : access Object) is Peer : CosNotifyChannelAdmin.StructuredProxyPullConsumer.Ref; Nil_Ref : CosNotifyChannelAdmin.StructuredProxyPullConsumer.Ref; begin Ensure_Initialization; pragma Debug (O ("disconnect structuredpullsupplier")); Enter (Self_Mutex); Peer := Self.X.Peer; Self.X.Peer := Nil_Ref; Leave (Self_Mutex); V (Self.X.Semaphore); if not CosNotifyChannelAdmin.StructuredProxyPullConsumer.Is_Nil (Peer) then CosNotifyChannelAdmin.StructuredProxyPullConsumer. disconnect_structured_pull_consumer (Peer); end if; end Disconnect_Structured_Pull_Supplier; --------------------------- -- Pull_Structured_Event -- --------------------------- function Pull_Structured_Event (Self : access Object) return CosNotification.StructuredEvent is Event : CosNotification.StructuredEvent; begin Ensure_Initialization; loop pragma Debug (O ("attempt to pull new structured event from pull supplier")); P (Self.X.Semaphore); Enter (Self_Mutex); if CosNotifyChannelAdmin.StructuredProxyPullConsumer.Is_Nil (Self.X.Peer) then Leave (Self_Mutex); CosEventComm.Helper.Raise_Disconnected ((CORBA.IDL_Exception_Members with null record)); end if; if not Self.X.Empty then Event := Self.X.Event; Self.X.Empty := True; Leave (Self_Mutex); exit; end if; Leave (Self_Mutex); end loop; pragma Debug (O ("succeed to pull new structured event from pull supplier")); return Event; end Pull_Structured_Event; ---------- -- Push -- ---------- procedure Push (Self : access Object; Data : CosNotification.StructuredEvent) is begin pragma Debug (O ("push new structured event to structuredpullsupplier")); Ensure_Initialization; Enter (Self_Mutex); Self.X.Empty := False; Self.X.Event := Data; Leave (Self_Mutex); V (Self.X.Semaphore); end Push; ------------------------------- -- Try_Pull_Structured_Event -- ------------------------------- procedure Try_Pull_Structured_Event (Self : access Object; Has_Event : out CORBA.Boolean; Returns : out CosNotification.StructuredEvent) is begin Ensure_Initialization; pragma Debug (O ("try to pull new structured event from structuredpullsupplier")); Enter (Self_Mutex); if CosNotifyChannelAdmin.StructuredProxyPullConsumer.Is_Nil (Self.X.Peer) then Leave (Self_Mutex); CosEventComm.Helper.Raise_Disconnected ((CORBA.IDL_Exception_Members with null record)); end if; Has_Event := not Self.X.Empty; if Has_Event then Returns := Self.X.Event; Self.X.Empty := True; end if; Leave (Self_Mutex); end Try_Pull_Structured_Event; ------------ -- Create -- ------------ function Create return Object_Ptr is Supplier : Object_Ptr; My_Ref : StructuredPullSupplier.Ref; Peer_Ref : CosNotifyChannelAdmin.StructuredProxyPullConsumer.Ref; begin pragma Debug (O ("create structuredpullsupplier")); Supplier := new Object; Supplier.X := new Structured_Pull_Supplier_Record; Supplier.X.This := Supplier; Supplier.X.Empty := True; Supplier.X.Peer := Peer_Ref; Create (Supplier.X.Semaphore); Initiate_Servant (PortableServer.Servant (Supplier), My_Ref); return Supplier; end Create; end CosNotifyComm.StructuredPullSupplier.Impl; polyorb-2.8~20110207.orig/cos/notification/cosnotifycomm-structuredpushsupplier-impl.adb0000644000175000017500000001615011750740337031053 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- COSNOTIFYCOMM.STRUCTUREDPUSHSUPPLIER.IMPL -- -- -- -- B o d y -- -- -- -- Copyright (C) 2003-2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with CosEventChannelAdmin.Helper; with CosEventComm.Helper; with PolyORB.CORBA_P.Server_Tools; with PolyORB.Log; with PolyORB.Tasking.Mutexes; with CosNotifyComm.StructuredPushSupplier.Skel; pragma Warnings (Off, CosNotifyComm.StructuredPushSupplier.Skel); package body CosNotifyComm.StructuredPushSupplier.Impl is use PolyORB.CORBA_P.Server_Tools; use PolyORB.Tasking.Mutexes; use PolyORB.Log; package L is new PolyORB.Log.Facility_Log ("structuredpushsupplier"); procedure O (Message : Standard.String; Level : Log_Level := Debug) renames L.Output; function C (Level : Log_Level := Debug) return Boolean renames L.Enabled; pragma Unreferenced (C); -- For conditional pragma Debug type Structured_Push_Supplier_Record is record This : Object_Ptr; Peer : CosNotifyChannelAdmin.StructuredProxyPushConsumer.Ref; end record; --------------------------- -- Ensure_Initialization -- --------------------------- procedure Ensure_Initialization; pragma Inline (Ensure_Initialization); -- Ensure that the Mutexes are initialized T_Initialized : Boolean := False; Self_Mutex : Mutex_Access; procedure Ensure_Initialization is begin if not T_Initialized then Create (Self_Mutex); T_Initialized := True; end if; end Ensure_Initialization; ------------------------- -- Subscription_Change -- ------------------------- procedure Subscription_Change (Self : access Object; Added : CosNotification.EventTypeSeq; Removed : CosNotification.EventTypeSeq) is pragma Warnings (Off); -- WAG:3.14 pragma Unreferenced (Self, Added, Removed); pragma Warnings (On); -- WAG:3.14 begin Ensure_Initialization; pragma Debug (O ("subscription_change in structuredpushsupplier")); Enter (Self_Mutex); Leave (Self_Mutex); end Subscription_Change; ----------------------------------------- -- Disconnect_Structured_Push_Supplier -- ----------------------------------------- procedure Disconnect_Structured_Push_Supplier (Self : access Object) is Peer : CosNotifyChannelAdmin.StructuredProxyPushConsumer.Ref; Nil_Ref : CosNotifyChannelAdmin.StructuredProxyPushConsumer.Ref; begin Ensure_Initialization; pragma Debug (O ("disconnect structuredpushsupplier")); Enter (Self_Mutex); Peer := Self.X.Peer; Self.X.Peer := Nil_Ref; Leave (Self_Mutex); if not CosNotifyChannelAdmin.StructuredProxyPushConsumer.Is_Nil (Peer) then CosNotifyChannelAdmin.StructuredProxyPushConsumer. disconnect_structured_push_consumer (Peer); end if; end Disconnect_Structured_Push_Supplier; ------------ -- Create -- ------------ function Create return Object_Ptr is Supplier : Object_Ptr; My_Ref : StructuredPushSupplier.Ref; My_Peer : CosNotifyChannelAdmin.StructuredProxyPushConsumer.Ref; begin pragma Debug (O ("create structuredpushsupplier")); Supplier := new Object; Supplier.X := new Structured_Push_Supplier_Record; Supplier.X.This := Supplier; Supplier.X.Peer := My_Peer; Initiate_Servant (PortableServer.Servant (Supplier), My_Ref); return Supplier; end Create; -------------------------------------------- -- Connect_Structured_Proxy_Push_Consumer -- -------------------------------------------- procedure Connect_Structured_Proxy_Push_Consumer (Self : access Object; Proxy : CosNotifyChannelAdmin.StructuredProxyPushConsumer.Ref) is My_Ref : StructuredPushSupplier.Ref; begin Ensure_Initialization; pragma Debug (O ("connect_structured_proxy_push_consumer in structuredpushsupplier")); Enter (Self_Mutex); if not CosNotifyChannelAdmin.StructuredProxyPushConsumer.Is_Nil (Self.X.Peer) then Leave (Self_Mutex); CosEventChannelAdmin.Helper.Raise_AlreadyConnected ((CORBA.IDL_Exception_Members with null record)); end if; Self.X.Peer := Proxy; Servant_To_Reference (PortableServer.Servant (Self.X.This), My_Ref); Leave (Self_Mutex); CosNotifyChannelAdmin.StructuredProxyPushConsumer. connect_structured_push_supplier (Proxy, My_Ref); end Connect_Structured_Proxy_Push_Consumer; ---------- -- Push -- ---------- procedure Push (Self : access Object; Notification : CosNotification.StructuredEvent) is Peer : CosNotifyChannelAdmin.StructuredProxyPushConsumer.Ref; begin Ensure_Initialization; pragma Debug (O ("push new structuredevent to structuredpushsupplier")); Enter (Self_Mutex); Peer := Self.X.Peer; Leave (Self_Mutex); if CosNotifyChannelAdmin.StructuredProxyPushConsumer.Is_Nil (Peer) then CosEventComm.Helper.Raise_Disconnected ((CORBA.IDL_Exception_Members with null record)); end if; CosNotifyChannelAdmin.StructuredProxyPushConsumer.push_structured_event (Peer, Notification); end Push; end CosNotifyComm.StructuredPushSupplier.Impl; polyorb-2.8~20110207.orig/cos/notification/cosnotifychanneladmin-supplieradmin-impl.ads0000644000175000017500000001406411750740337030550 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- COSNOTIFYCHANNELADMIN.SUPPLIERADMIN.IMPL -- -- -- -- S p e c -- -- -- -- Copyright (C) 2003-2008, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by ACT Europe. -- -- (email: sales@act-europe.fr) -- -- -- ------------------------------------------------------------------------------ with CosNotifyChannelAdmin.EventChannel; with PortableServer; package CosNotifyChannelAdmin.SupplierAdmin.Impl is type Object is new PortableServer.Servant_Base with private; type Object_Ptr is access all Object'Class; -- IDL operations function Get_MyID (Self : access Object) return CosNotifyChannelAdmin.AdminID; function Get_MyChannel (Self : access Object) return CosNotifyChannelAdmin.EventChannel_Forward.Ref; function Get_MyOperator (Self : access Object) return CosNotifyChannelAdmin.InterFilterGroupOperator; function Get_Pull_Consumers (Self : access Object) return CosNotifyChannelAdmin.ProxyIDSeq; function Get_Push_Consumers (Self : access Object) return CosNotifyChannelAdmin.ProxyIDSeq; function Get_Proxy_Consumer (Self : access Object; Proxy_Id : CosNotifyChannelAdmin.ProxyID) return CosNotifyChannelAdmin.ProxyConsumer.Ref; procedure Obtain_Notification_Pull_Consumer (Self : access Object; Ctype : CosNotifyChannelAdmin.ClientType; Proxy_Id : out CosNotifyChannelAdmin.ProxyID; Returns : out CosNotifyChannelAdmin.ProxyConsumer.Ref); procedure Obtain_Notification_Push_Consumer (Self : access Object; Ctype : CosNotifyChannelAdmin.ClientType; Proxy_Id : out CosNotifyChannelAdmin.ProxyID; Returns : out CosNotifyChannelAdmin.ProxyConsumer.Ref); procedure Destroy (Self : access Object); -- IDL Operations inherited from CosNotification::QoSAdmin function Get_QoS (Self : access Object) return CosNotification.QoSProperties; procedure Set_QoS (Self : access Object; QoS : CosNotification.QoSProperties); procedure Validate_QoS (Self : access Object; Required_QoS : CosNotification.QoSProperties; Available_QoS : out CosNotification.NamedPropertyRangeSeq); -- Inherited IDL operations from CosNotifyComm::NotifyPublish procedure Offer_Change (Self : access Object; Added : CosNotification.EventTypeSeq; Removed : CosNotification.EventTypeSeq); -- Inherited IDL operations from CosNotifyFilter::FilterAdmin function Add_Filter (Self : access Object; New_Filter : CosNotifyFilter.Filter.Ref) return CosNotifyFilter.FilterID; procedure Remove_Filter (Self : access Object; Filter : CosNotifyFilter.FilterID); function Get_Filter (Self : access Object; Filter : CosNotifyFilter.FilterID) return CosNotifyFilter.Filter.Ref; function Get_All_Filters (Self : access Object) return CosNotifyFilter.FilterIDSeq; procedure Remove_All_Filters (Self : access Object); -- Inherited IDL operations from CosEventChannelAdmin::SupplierAdmin function Obtain_Push_Consumer (Self : access Object) return CosEventChannelAdmin.ProxyPushConsumer.Ref; function Obtain_Pull_Consumer (Self : access Object) return CosEventChannelAdmin.ProxyPullConsumer.Ref; ---------------------- -- PolyORB specific -- ---------------------- function Create (Channel : CosNotifyChannelAdmin.EventChannel.Ref; Initial_QoS : CosNotification.QoSProperties; MyID : CosNotifyChannelAdmin.AdminID; MyOp : CosNotifyChannelAdmin.InterFilterGroupOperator := AND_OP) return Object_Ptr; function GetTotalConsumers (Self : access Object) return CORBA.Long; -- Returns the total number of Consumers created by this Admin procedure Post (Self : access Object; Data : CORBA.Any); procedure Structured_Post (Self : access Object; Notification : CosNotification.StructuredEvent); procedure Sequence_Post (Self : access Object; Notifications : CosNotification.EventBatch); private type Supplier_Admin_Record; type Supplier_Admin_Access is access Supplier_Admin_Record; type Object is new PortableServer.Servant_Base with record X : Supplier_Admin_Access; end record; end CosNotifyChannelAdmin.SupplierAdmin.Impl; polyorb-2.8~20110207.orig/cos/notification/cosnotifychanneladmin-proxypullsupplier-impl.adb0000644000175000017500000007106611750740337031522 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- COSNOTIFYCHANNELADMIN.PROXYPULLSUPPLIER.IMPL -- -- -- -- B o d y -- -- -- -- Copyright (C) 2003-2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with CosEventChannelAdmin.Helper; with CosEventComm.Helper; with CosEventComm.PullConsumer; with CosNotification; with CosNotification.Helper; with PolyORB.CORBA_P.Server_Tools; with PolyORB.Log; with PolyORB.Tasking.Mutexes; with PolyORB.Tasking.Semaphores; with PolyORB.Utils.Chained_Lists; with CosNotifyChannelAdmin.ProxyPullSupplier.Skel; pragma Warnings (Off, CosNotifyChannelAdmin.ProxyPullSupplier.Skel); package body CosNotifyChannelAdmin.ProxyPullSupplier.Impl is use CosNotification; use IDL_SEQUENCE_CosNotification_Property; use IDL_SEQUENCE_CosNotification_PropertyError; use IDL_SEQUENCE_CosNotification_NamedPropertyRange; use CORBA; use PolyORB.CORBA_P.Server_Tools; use PolyORB.Tasking.Mutexes; use PolyORB.Tasking.Semaphores; package Convert is new ConsumerAdmin_Forward.Convert (CosNotifyChannelAdmin.ConsumerAdmin.Ref); use PolyORB.Log; package L is new PolyORB.Log.Facility_Log ("proxypullsupplier"); procedure O (Message : Standard.String; Level : Log_Level := Debug) renames L.Output; function C (Level : Log_Level := Debug) return Boolean renames L.Enabled; pragma Unreferenced (C); -- For conditional pragma Debug package Event_Queues is new PolyORB.Utils.Chained_Lists (CORBA.Any, CORBA."="); use Event_Queues; subtype Event_Queue is Event_Queues.List; type Proxy_Pull_Supplier_Record is record This : Object_Ptr; Admin : CosNotifyChannelAdmin.ConsumerAdmin.Ref; MyId : CosNotifyChannelAdmin.ProxyID; MyType : CosNotifyChannelAdmin.ProxyType; Peer : CosEventComm.PullConsumer.Ref; QoSPropSeq : CosNotification.QoSProperties; Queue : Event_Queue; Semaphore : Semaphore_Access; end record; --------------------------- -- Ensure_Initialization -- --------------------------- procedure Ensure_Initialization; pragma Inline (Ensure_Initialization); -- Ensure that the Mutexes are initialized T_Initialized : Boolean := False; Self_Mutex : Mutex_Access; procedure Ensure_Initialization is begin if not T_Initialized then Create (Self_Mutex); T_Initialized := True; end if; end Ensure_Initialization; ------------------------------- -- Connect_Any_Pull_Consumer -- ------------------------------- procedure Connect_Any_Pull_Consumer (Self : access Object; Pull_Consumer : CosEventComm.PullConsumer.Ref) is begin Ensure_Initialization; pragma Debug (O ("connect_any_pull_consumer in proxypullsupplier")); Enter (Self_Mutex); if not CosEventComm.PullConsumer.Is_Nil (Self.X.Peer) then Leave (Self_Mutex); CosEventChannelAdmin.Helper.Raise_AlreadyConnected ((CORBA.IDL_Exception_Members with null record)); end if; Self.X.Peer := Pull_Consumer; Leave (Self_Mutex); end Connect_Any_Pull_Consumer; ---------------- -- Get_MyType -- ---------------- function Get_MyType (Self : access Object) return CosNotifyChannelAdmin.ProxyType is MyType : CosNotifyChannelAdmin.ProxyType; begin Ensure_Initialization; pragma Debug (O ("get_mytype in proxypullsupplier")); Enter (Self_Mutex); MyType := Self.X.MyType; Leave (Self_Mutex); return MyType; end Get_MyType; ----------------- -- Get_MyAdmin -- ----------------- function Get_MyAdmin (Self : access Object) return CosNotifyChannelAdmin.ConsumerAdmin_Forward.Ref is MyAdmin : CosNotifyChannelAdmin.ConsumerAdmin_Forward.Ref; begin pragma Debug (O ("get_myadmin in proxypullsupplier")); Ensure_Initialization; Enter (Self_Mutex); MyAdmin := Convert.To_Forward (Self.X.Admin); Leave (Self_Mutex); return MyAdmin; end Get_MyAdmin; ------------------------- -- Get_Priority_Filter -- ------------------------- function Get_Priority_Filter (Self : access Object) return CosNotifyFilter.MappingFilter.Ref is pragma Warnings (Off); -- WAG:3.14 pragma Unreferenced (Self); pragma Warnings (On); -- WAG:3.14 MyFilter : CosNotifyFilter.MappingFilter.Ref; begin Ensure_Initialization; pragma Debug (O ("get_priority_filter in proxypullsupplier")); Enter (Self_Mutex); Leave (Self_Mutex); return MyFilter; end Get_Priority_Filter; ------------------------- -- Set_Priority_Filter -- ------------------------- procedure Set_Priority_Filter (Self : access Object; To : CosNotifyFilter.MappingFilter.Ref) is pragma Warnings (Off); -- WAG:3.14 pragma Unreferenced (Self, To); pragma Warnings (On); -- WAG:3.14 begin Ensure_Initialization; pragma Debug (O ("set_priority_filter in proxypullsupplier")); Enter (Self_Mutex); Leave (Self_Mutex); end Set_Priority_Filter; ------------------------- -- Get_Lifetime_Filter -- ------------------------- function Get_Lifetime_Filter (Self : access Object) return CosNotifyFilter.MappingFilter.Ref is pragma Warnings (Off); -- WAG:3.14 pragma Unreferenced (Self); pragma Warnings (On); -- WAG:3.14 MyFilter : CosNotifyFilter.MappingFilter.Ref; begin Ensure_Initialization; pragma Debug (O ("get_lifetime_filter in proxypullsupplier")); Enter (Self_Mutex); Leave (Self_Mutex); return MyFilter; end Get_Lifetime_Filter; ------------------------- -- Set_Lifetime_Filter -- ------------------------- procedure Set_Lifetime_Filter (Self : access Object; To : CosNotifyFilter.MappingFilter.Ref) is pragma Warnings (Off); -- WAG:3.14 pragma Unreferenced (Self, To); pragma Warnings (On); -- WAG:3.14 begin Ensure_Initialization; pragma Debug (O ("set_lifetime_filter in proxypullsupplier")); Enter (Self_Mutex); Leave (Self_Mutex); end Set_Lifetime_Filter; -------------------------- -- Obtain_Offered_Types -- -------------------------- function Obtain_Offered_Types (Self : access Object; Mode : CosNotifyChannelAdmin.ObtainInfoMode) return CosNotification.EventTypeSeq is pragma Warnings (Off); -- WAG:3.14 pragma Unreferenced (Self, Mode); pragma Warnings (On); -- WAG:3.14 MySeq : CosNotification.EventTypeSeq; begin Ensure_Initialization; pragma Debug (O ("obtain_offered_types in proxypullsupplier")); Enter (Self_Mutex); Leave (Self_Mutex); return MySeq; end Obtain_Offered_Types; ------------------------ -- Validate_Event_QoS -- ------------------------ procedure Validate_Event_QoS (Self : access Object; Required_QoS : CosNotification.QoSProperties; Available_QoS : out CosNotification.NamedPropertyRangeSeq) is pragma Warnings (Off); -- WAG:3.14 pragma Unreferenced (Self, Required_QoS, Available_QoS); pragma Warnings (On); -- WAG:3.14 begin Ensure_Initialization; pragma Debug (O ("validate_event_qos in proxypullsupplier")); Enter (Self_Mutex); Leave (Self_Mutex); end Validate_Event_QoS; ------------- -- Get_QoS -- ------------- function Get_QoS (Self : access Object) return CosNotification.QoSProperties is MyQoS : CosNotification.QoSProperties; begin Ensure_Initialization; pragma Debug (O ("get_qos in proxypullsupplier")); Enter (Self_Mutex); MyQoS := Self.X.QoSPropSeq; Leave (Self_Mutex); return MyQoS; end Get_QoS; ------------- -- Set_QoS -- ------------- procedure Set_QoS (Self : access Object; QoS : CosNotification.QoSProperties) is MyProp : CosNotification.Property; MyError : CosNotification.PropertyError; MyErrCode : CosNotification.QoSError_code; MyRange : CosNotification.PropertyRange; MyErrorSeq : CosNotification.PropertyErrorSeq; SeqLen : Integer; begin Ensure_Initialization; pragma Debug (O ("set_qos in proxypullsupplier")); SeqLen := Length (QoS); for Index in 1 .. SeqLen loop MyProp := Get_Element (QoS, Index); if MyProp.name = "EventReliability" then MyErrCode := UNAVAILABLE_PROPERTY; MyRange := (To_Any (CORBA.Short (0)), To_Any (CORBA.Short (0))); MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); elsif MyProp.name = "ConnectionReliability" then if CORBA.Short'(From_Any (MyProp.value)) /= 0 and then CORBA.Short'(From_Any (MyProp.value)) /= 1 then MyErrCode := BAD_VALUE; MyRange := (To_Any (CORBA.Short (0)), To_Any (CORBA.Short (0))); MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); end if; elsif MyProp.name = "Priority" then if CORBA.Short'(From_Any (MyProp.value)) not in -32_767 .. 32_767 then MyErrCode := BAD_VALUE; MyRange := (To_Any (CORBA.Short (-32767)), To_Any (CORBA.Short (32767))); MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); end if; elsif MyProp.name = "StartTime" then MyErrCode := UNAVAILABLE_PROPERTY; MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); elsif MyProp.name = "StopTime" then MyErrCode := UNAVAILABLE_PROPERTY; MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); elsif MyProp.name = "Timeout" then MyErrCode := UNSUPPORTED_PROPERTY; MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); elsif MyProp.name = "OrderPolicy" then if CORBA.Short'(From_Any (MyProp.value)) /= 0 and then CORBA.Short'(From_Any (MyProp.value)) /= 1 and then CORBA.Short'(From_Any (MyProp.value)) /= 2 and then CORBA.Short'(From_Any (MyProp.value)) /= 3 then MyErrCode := BAD_VALUE; MyRange := (To_Any (CORBA.Short (0)), To_Any (CORBA.Short (3))); MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); end if; elsif MyProp.name = "DiscardPolicy" then if CORBA.Short'(From_Any (MyProp.value)) /= 0 and then CORBA.Short'(From_Any (MyProp.value)) /= 1 and then CORBA.Short'(From_Any (MyProp.value)) /= 2 and then CORBA.Short'(From_Any (MyProp.value)) /= 3 and then CORBA.Short'(From_Any (MyProp.value)) /= 4 then MyErrCode := BAD_VALUE; MyRange := (To_Any (CORBA.Short (0)), To_Any (CORBA.Short (4))); MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); end if; elsif MyProp.name = "MaximumBatchSize" then MyErrCode := UNSUPPORTED_PROPERTY; MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); elsif MyProp.name = "PacingInterval" then MyErrCode := UNSUPPORTED_PROPERTY; MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); elsif MyProp.name = "StartTimeSupported" then MyErrCode := UNSUPPORTED_PROPERTY; MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); elsif MyProp.name = "StopTimeSupported" then MyErrCode := UNSUPPORTED_PROPERTY; MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); elsif MyProp.name = "MaxEventsPerConsumer" then MyErrCode := UNSUPPORTED_PROPERTY; MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); else MyErrCode := BAD_PROPERTY; MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); end if; end loop; if Length (MyErrorSeq) > 0 then CosNotification.Helper.Raise_UnsupportedQoS ((CORBA.IDL_Exception_Members with qos_err => MyErrorSeq)); end if; SeqLen := Length (QoS); Enter (Self_Mutex); for Index in 1 .. SeqLen loop MyProp := Get_Element (QoS, Index); if MyProp.name = "ConnectionReliability" then Replace_Element (Self.X.QoSPropSeq, 2, MyProp); elsif MyProp.name = "Priority" then Replace_Element (Self.X.QoSPropSeq, 3, MyProp); elsif MyProp.name = "OrderPolicy" then Replace_Element (Self.X.QoSPropSeq, 4, MyProp); elsif MyProp.name = "DiscardPolicy" then Replace_Element (Self.X.QoSPropSeq, 5, MyProp); end if; end loop; Leave (Self_Mutex); end Set_QoS; ------------------ -- Validate_QoS -- ------------------ procedure Validate_QoS (Self : access Object; Required_QoS : CosNotification.QoSProperties; Available_QoS : out CosNotification.NamedPropertyRangeSeq) is MyProp : CosNotification.Property; MyError : CosNotification.PropertyError; MyErrCode : CosNotification.QoSError_code; MyNamedRange : CosNotification.NamedPropertyRange; MyRange : CosNotification.PropertyRange; MyErrorSeq : CosNotification.PropertyErrorSeq; SeqLen : Integer; begin Ensure_Initialization; pragma Debug (O ("validate_qos in proxypullsupplier")); SeqLen := Length (Required_QoS); for Index in 1 .. SeqLen loop MyProp := Get_Element (Required_QoS, Index); if MyProp.name = "EventReliability" then MyErrCode := UNAVAILABLE_PROPERTY; MyRange := (To_Any (CORBA.Short (0)), To_Any (CORBA.Short (0))); MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); elsif MyProp.name = "ConnectionReliability" then if CORBA.Short'(From_Any (MyProp.value)) /= 0 and then CORBA.Short'(From_Any (MyProp.value)) /= 1 then MyErrCode := BAD_VALUE; MyRange := (To_Any (CORBA.Short (0)), To_Any (CORBA.Short (0))); MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); end if; elsif MyProp.name = "Priority" then if CORBA.Short'(From_Any (MyProp.value)) not in -32_767 .. 32_767 then MyErrCode := BAD_VALUE; MyRange := (To_Any (CORBA.Short (-32767)), To_Any (CORBA.Short (32767))); MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); end if; elsif MyProp.name = "StartTime" then MyErrCode := UNAVAILABLE_PROPERTY; MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); elsif MyProp.name = "StopTime" then MyErrCode := UNAVAILABLE_PROPERTY; MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); elsif MyProp.name = "Timeout" then MyErrCode := UNSUPPORTED_PROPERTY; MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); elsif MyProp.name = "OrderPolicy" then if CORBA.Short'(From_Any (MyProp.value)) /= 0 and then CORBA.Short'(From_Any (MyProp.value)) /= 1 and then CORBA.Short'(From_Any (MyProp.value)) /= 2 and then CORBA.Short'(From_Any (MyProp.value)) /= 3 then MyErrCode := BAD_VALUE; MyRange := (To_Any (CORBA.Short (0)), To_Any (CORBA.Short (3))); MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); end if; elsif MyProp.name = "DiscardPolicy" then if CORBA.Short'(From_Any (MyProp.value)) /= 0 and then CORBA.Short'(From_Any (MyProp.value)) /= 1 and then CORBA.Short'(From_Any (MyProp.value)) /= 2 and then CORBA.Short'(From_Any (MyProp.value)) /= 3 and then CORBA.Short'(From_Any (MyProp.value)) /= 4 then MyErrCode := BAD_VALUE; MyRange := (To_Any (CORBA.Short (0)), To_Any (CORBA.Short (4))); MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); end if; elsif MyProp.name = "MaximumBatchSize" then MyErrCode := UNSUPPORTED_PROPERTY; MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); elsif MyProp.name = "PacingInterval" then MyErrCode := UNSUPPORTED_PROPERTY; MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); elsif MyProp.name = "StartTimeSupported" then MyErrCode := UNSUPPORTED_PROPERTY; MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); elsif MyProp.name = "StopTimeSupported" then MyErrCode := UNSUPPORTED_PROPERTY; MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); elsif MyProp.name = "MaxEventsPerConsumer" then MyErrCode := UNSUPPORTED_PROPERTY; MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); else MyErrCode := BAD_PROPERTY; MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); end if; end loop; if Length (MyErrorSeq) > 0 then CosNotification.Helper.Raise_UnsupportedQoS ((CORBA.IDL_Exception_Members with qos_err => MyErrorSeq)); end if; Enter (Self_Mutex); SeqLen := Length (Self.X.QoSPropSeq); for Index in 1 .. SeqLen loop MyProp := Get_Element (Self.X.QoSPropSeq, Index); if MyProp.name = "ConnectionReliability" then MyRange := (From_Any (MyProp.value), To_Any (CORBA.Short (0))); MyNamedRange := (MyProp.name, MyRange); Append (Available_QoS, MyNamedRange); elsif MyProp.name = "Priority" then MyRange := (To_Any (CORBA.Short (-32767)), To_Any (CORBA.Short (32767))); MyNamedRange := (MyProp.name, MyRange); Append (Available_QoS, MyNamedRange); elsif MyProp.name = "OrderPolicy" then MyRange := (To_Any (CORBA.Short (0)), To_Any (CORBA.Short (3))); MyNamedRange := (MyProp.name, MyRange); Append (Available_QoS, MyNamedRange); elsif MyProp.name = "DiscardPolicy" then MyRange := (To_Any (CORBA.Short (0)), To_Any (CORBA.Short (4))); MyNamedRange := (MyProp.name, MyRange); Append (Available_QoS, MyNamedRange); end if; end loop; Leave (Self_Mutex); end Validate_QoS; ---------------- -- Add_Filter -- ---------------- function Add_Filter (Self : access Object; New_Filter : CosNotifyFilter.Filter.Ref) return CosNotifyFilter.FilterID is pragma Warnings (Off); -- WAG:3.14 pragma Unreferenced (Self, New_Filter); pragma Warnings (On); -- WAG:3.14 MyFilterID : CosNotifyFilter.FilterID; MyID : CORBA.Long; begin Ensure_Initialization; pragma Debug (O ("add_filter in proxypullsupplier")); Enter (Self_Mutex); Leave (Self_Mutex); MyID := 0; MyFilterID := CosNotifyFilter.FilterID (MyID); return MyFilterID; end Add_Filter; ------------------- -- Remove_Filter -- ------------------- procedure Remove_Filter (Self : access Object; Filter : CosNotifyFilter.FilterID) is pragma Warnings (Off); -- WAG:3.14 pragma Unreferenced (Self, Filter); pragma Warnings (On); -- WAG:3.14 begin Ensure_Initialization; pragma Debug (O ("remove_filter in proxypullsupplier")); Enter (Self_Mutex); Leave (Self_Mutex); end Remove_Filter; ---------------- -- Get_Filter -- ---------------- function Get_Filter (Self : access Object; Filter : CosNotifyFilter.FilterID) return CosNotifyFilter.Filter.Ref is pragma Warnings (Off); -- WAG:3.14 pragma Unreferenced (Self, Filter); pragma Warnings (On); -- WAG:3.14 MyFilter : CosNotifyFilter.Filter.Ref; begin Ensure_Initialization; pragma Debug (O ("get_filter in proxypullsupplier")); Enter (Self_Mutex); Leave (Self_Mutex); return MyFilter; end Get_Filter; --------------------- -- Get_All_Filters -- --------------------- function Get_All_Filters (Self : access Object) return CosNotifyFilter.FilterIDSeq is pragma Warnings (Off); -- WAG:3.14 pragma Unreferenced (Self); pragma Warnings (On); -- WAG:3.14 MyFilterSeq : CosNotifyFilter.FilterIDSeq; begin Ensure_Initialization; pragma Debug (O ("get_all_filters in proxypullsupplier")); Enter (Self_Mutex); Leave (Self_Mutex); return MyFilterSeq; end Get_All_Filters; ------------------------ -- Remove_All_Filters -- ------------------------ procedure Remove_All_Filters (Self : access Object) is pragma Warnings (Off); -- WAG:3.14 pragma Unreferenced (Self); pragma Warnings (On); -- WAG:3.14 begin Ensure_Initialization; pragma Debug (O ("remove_all_filters in proxypullsupplier")); Enter (Self_Mutex); Leave (Self_Mutex); end Remove_All_Filters; ------------------------- -- Subscription_Change -- ------------------------- procedure Subscription_Change (Self : access Object; Added : CosNotification.EventTypeSeq; Removed : CosNotification.EventTypeSeq) is pragma Warnings (Off); -- WAG:3.14 pragma Unreferenced (Self, Added, Removed); pragma Warnings (On); -- WAG:3.14 begin Ensure_Initialization; pragma Debug (O ("subscription_change in proxypullsupplier")); Enter (Self_Mutex); Leave (Self_Mutex); end Subscription_Change; ---------- -- Pull -- ---------- function Pull (Self : access Object) return CORBA.Any is Event : CORBA.Any; begin Ensure_Initialization; pragma Debug (O ("attempt to pull new data from proxy pull supplier")); P (Self.X.Semaphore); Enter (Self_Mutex); if CosEventComm.PullConsumer.Is_Nil (Self.X.Peer) then Leave (Self_Mutex); CosEventComm.Helper.Raise_Disconnected ((CORBA.IDL_Exception_Members with null record)); end if; if State (Self.X.Semaphore) >= 0 then Extract_First (Self.X.Queue, Event); pragma Debug (O ("succeed to pull data from proxy pull supplier")); end if; Leave (Self_Mutex); return Event; end Pull; -------------- -- Try_Pull -- -------------- procedure Try_Pull (Self : access Object; Has_Event : out CORBA.Boolean; Returns : out CORBA.Any) is begin pragma Debug (O ("try to pull new data from proxy pull supplier")); Ensure_Initialization; Enter (Self_Mutex); if CosEventComm.PullConsumer.Is_Nil (Self.X.Peer) then Leave (Self_Mutex); CosEventComm.Helper.Raise_Disconnected ((CORBA.IDL_Exception_Members with null record)); end if; Has_Event := State (Self.X.Semaphore) > 0; if Has_Event then Extract_First (Self.X.Queue, Returns); Leave (Self_Mutex); P (Self.X.Semaphore); else Leave (Self_Mutex); end if; end Try_Pull; ------------------------------ -- Disconnect_Pull_Supplier -- ------------------------------ procedure Disconnect_Pull_Supplier (Self : access Object) is Peer : CosEventComm.PullConsumer.Ref; Nil_Ref : CosEventComm.PullConsumer.Ref; begin Ensure_Initialization; pragma Debug (O ("disconnect proxypullsupplier")); Enter (Self_Mutex); Peer := Self.X.Peer; Self.X.Peer := Nil_Ref; Leave (Self_Mutex); V (Self.X.Semaphore); if not CosEventComm.PullConsumer.Is_Nil (Peer) then CosEventComm.PullConsumer.disconnect_pull_consumer (Peer); end if; end Disconnect_Pull_Supplier; ------------ -- Create -- ------------ function Create (Admin : CosNotifyChannelAdmin.ConsumerAdmin.Ref; Initial_QoS : CosNotification.QoSProperties; Ptype : CosNotifyChannelAdmin.ProxyType; Proxy_Id : CosNotifyChannelAdmin.ProxyID) return Object_Ptr is Supplier : Object_Ptr; My_Ref : ProxyPullSupplier.Ref; begin pragma Debug (O ("create proxy pullsupplier")); Supplier := new Object; Supplier.X := new Proxy_Pull_Supplier_Record; Supplier.X.Admin := Admin; Supplier.X.MyId := Proxy_Id; Supplier.X.MyType := Ptype; Supplier.X.This := Supplier; Supplier.X.QoSPropSeq := Initial_QoS; Create (Supplier.X.Semaphore); Initiate_Servant (PortableServer.Servant (Supplier), My_Ref); return Supplier; end Create; ---------- -- Post -- ---------- procedure Post (Self : access Object; Data : CORBA.Any) is begin pragma Debug (O ("post new data to proxy pull supplier")); Ensure_Initialization; Enter (Self_Mutex); Append (Self.X.Queue, Data); Leave (Self_Mutex); V (Self.X.Semaphore); end Post; end CosNotifyChannelAdmin.ProxyPullSupplier.Impl; ././@LongLink0000000000000000000000000000014600000000000011566 Lustar rootrootpolyorb-2.8~20110207.orig/cos/notification/cosnotifychanneladmin-structuredproxypushsupplier-impl.adbpolyorb-2.8~20110207.orig/cos/notification/cosnotifychanneladmin-structuredproxypushsupplier-impl.ad0000644000175000017500000007064411750740337033511 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- COSNOTIFYCHANNELADMIN.STRUCTUREDPROXYPUSHSUPPLIER.IMPL -- -- -- -- B o d y -- -- -- -- Copyright (C) 2003-2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with CosEventChannelAdmin.Helper; with CosNotification; with CosNotification.Helper; with PolyORB.CORBA_P.Server_Tools; with PolyORB.Log; with PolyORB.Tasking.Mutexes; with CosNotifyChannelAdmin.StructuredProxyPushSupplier.Skel; pragma Warnings (Off, CosNotifyChannelAdmin.StructuredProxyPushSupplier.Skel); package body CosNotifyChannelAdmin.StructuredProxyPushSupplier.Impl is use CosNotification; use IDL_SEQUENCE_CosNotification_Property; use IDL_SEQUENCE_CosNotification_PropertyError; use IDL_SEQUENCE_CosNotification_NamedPropertyRange; use CORBA; use PolyORB.CORBA_P.Server_Tools; use PolyORB.Tasking.Mutexes; package Convert is new ConsumerAdmin_Forward.Convert (CosNotifyChannelAdmin.ConsumerAdmin.Ref); use PolyORB.Log; package L is new PolyORB.Log.Facility_Log ("structuredproxypushsupplier"); procedure O (Message : Standard.String; Level : Log_Level := Debug) renames L.Output; function C (Level : Log_Level := Debug) return Boolean renames L.Enabled; pragma Unreferenced (C); -- For conditional pragma Debug type Structured_Proxy_Push_Supplier_Record is record This : Object_Ptr; Admin : CosNotifyChannelAdmin.ConsumerAdmin.Ref; MyId : CosNotifyChannelAdmin.ProxyID; MyType : CosNotifyChannelAdmin.ProxyType; Peer : CosNotifyComm.StructuredPushConsumer.Ref; QoSPropSeq : CosNotification.QoSProperties; end record; --------------------------- -- Ensure_Initialization -- --------------------------- procedure Ensure_Initialization; pragma Inline (Ensure_Initialization); -- Ensure that the Mutexes are initialized T_Initialized : Boolean := False; Self_Mutex : Mutex_Access; procedure Ensure_Initialization is begin if not T_Initialized then Create (Self_Mutex); T_Initialized := True; end if; end Ensure_Initialization; -------------------------------------- -- Connect_Structured_Push_consumer -- -------------------------------------- procedure Connect_Structured_Push_consumer (Self : access Object; Push_Consumer : CosNotifyComm.StructuredPushConsumer.Ref) is begin Ensure_Initialization; pragma Debug (O ("connect_structured_push_consumer in structuredproxypushsupplier")); Enter (Self_Mutex); if not CosNotifyComm.StructuredPushConsumer.Is_Nil (Self.X.Peer) then Leave (Self_Mutex); CosEventChannelAdmin.Helper.Raise_AlreadyConnected ((CORBA.IDL_Exception_Members with null record)); end if; Self.X.Peer := Push_Consumer; Leave (Self_Mutex); end Connect_Structured_Push_consumer; ------------------------ -- Suspend_Connection -- ------------------------ procedure Suspend_Connection (Self : access Object) is pragma Warnings (Off); -- WAG:3.14 pragma Unreferenced (Self); pragma Warnings (On); -- WAG:3.14 begin Ensure_Initialization; pragma Debug (O ("suspend_connection in structuredproxypushsupplier")); Enter (Self_Mutex); Leave (Self_Mutex); end Suspend_Connection; ----------------------- -- Resume_Connection -- ----------------------- procedure Resume_Connection (Self : access Object) is pragma Warnings (Off); -- WAG:3.14 pragma Unreferenced (Self); pragma Warnings (On); -- WAG:3.14 begin Ensure_Initialization; pragma Debug (O ("resume_connection in structuredproxypushsupplier")); Enter (Self_Mutex); Leave (Self_Mutex); end Resume_Connection; ---------------- -- Get_MyType -- ---------------- function Get_MyType (Self : access Object) return CosNotifyChannelAdmin.ProxyType is MyType : CosNotifyChannelAdmin.ProxyType; begin Ensure_Initialization; pragma Debug (O ("get_mytype in structuredproxypushsupplier")); Enter (Self_Mutex); MyType := Self.X.MyType; Leave (Self_Mutex); return MyType; end Get_MyType; ----------------- -- Get_MyAdmin -- ----------------- function Get_MyAdmin (Self : access Object) return CosNotifyChannelAdmin.ConsumerAdmin_Forward.Ref is MyAdmin : CosNotifyChannelAdmin.ConsumerAdmin_Forward.Ref; begin Ensure_Initialization; pragma Debug (O ("get_myadmin in structuredproxypushsupplier")); Enter (Self_Mutex); MyAdmin := Convert.To_Forward (Self.X.Admin); Leave (Self_Mutex); return MyAdmin; end Get_MyAdmin; ------------------------- -- Get_Priority_Filter -- ------------------------- function Get_Priority_Filter (Self : access Object) return CosNotifyFilter.MappingFilter.Ref is pragma Warnings (Off); -- WAG:3.14 pragma Unreferenced (Self); pragma Warnings (On); -- WAG:3.14 MyFilter : CosNotifyFilter.MappingFilter.Ref; begin Ensure_Initialization; pragma Debug (O ("get_priority_filter in structuredproxypushsupplier")); Enter (Self_Mutex); Leave (Self_Mutex); return MyFilter; end Get_Priority_Filter; ------------------------- -- Set_Priority_Filter -- ------------------------- procedure Set_Priority_Filter (Self : access Object; To : CosNotifyFilter.MappingFilter.Ref) is pragma Warnings (Off); -- WAG:3.14 pragma Unreferenced (Self, To); pragma Warnings (On); -- WAG:3.14 begin Ensure_Initialization; pragma Debug (O ("set_priority_filter in structuredproxypushsupplier")); Enter (Self_Mutex); Leave (Self_Mutex); end Set_Priority_Filter; ------------------------- -- Get_Lifetime_Filter -- ------------------------- function Get_Lifetime_Filter (Self : access Object) return CosNotifyFilter.MappingFilter.Ref is pragma Warnings (Off); -- WAG:3.14 pragma Unreferenced (Self); pragma Warnings (On); -- WAG:3.14 MyFilter : CosNotifyFilter.MappingFilter.Ref; begin Ensure_Initialization; pragma Debug (O ("get_lifetime_filter in structuredproxypushsupplier")); Enter (Self_Mutex); Leave (Self_Mutex); return MyFilter; end Get_Lifetime_Filter; ------------------------- -- Set_Lifetime_Filter -- ------------------------- procedure Set_Lifetime_Filter (Self : access Object; To : CosNotifyFilter.MappingFilter.Ref) is pragma Warnings (Off); -- WAG:3.14 pragma Unreferenced (Self, To); pragma Warnings (On); -- WAG:3.14 begin Ensure_Initialization; pragma Debug (O ("set_lifetime_filter in structuredproxypushsupplier")); Enter (Self_Mutex); Leave (Self_Mutex); end Set_Lifetime_Filter; -------------------------- -- Obtain_Offered_Types -- -------------------------- function Obtain_Offered_Types (Self : access Object; Mode : CosNotifyChannelAdmin.ObtainInfoMode) return CosNotification.EventTypeSeq is pragma Warnings (Off); -- WAG:3.14 pragma Unreferenced (Self, Mode); pragma Warnings (On); -- WAG:3.14 MySeq : CosNotification.EventTypeSeq; begin Ensure_Initialization; pragma Debug (O ("obtain_offered_types in structuredproxypushsupplier")); Enter (Self_Mutex); Leave (Self_Mutex); return MySeq; end Obtain_Offered_Types; ------------------------ -- Validate_Event_QoS -- ------------------------ procedure Validate_Event_QoS (Self : access Object; Required_QoS : CosNotification.QoSProperties; Available_QoS : out CosNotification.NamedPropertyRangeSeq) is pragma Warnings (Off); -- WAG:3.14 pragma Unreferenced (Self, Required_QoS, Available_QoS); pragma Warnings (On); -- WAG:3.14 begin Ensure_Initialization; pragma Debug (O ("validate_event_qos in structuredproxypushsupplier")); Enter (Self_Mutex); Leave (Self_Mutex); end Validate_Event_QoS; ------------- -- Get_QoS -- ------------- function Get_QoS (Self : access Object) return CosNotification.QoSProperties is MyQoS : CosNotification.QoSProperties; begin Ensure_Initialization; pragma Debug (O ("get_qos in structuredproxypushsupplier")); Enter (Self_Mutex); MyQoS := Self.X.QoSPropSeq; Leave (Self_Mutex); return MyQoS; end Get_QoS; ------------- -- Set_QoS -- ------------- procedure Set_QoS (Self : access Object; QoS : CosNotification.QoSProperties) is MyProp : CosNotification.Property; MyError : CosNotification.PropertyError; MyErrCode : CosNotification.QoSError_code; MyRange : CosNotification.PropertyRange; MyErrorSeq : CosNotification.PropertyErrorSeq; SeqLen : Integer; begin Ensure_Initialization; pragma Debug (O ("set_qos in structuredproxypushsupplier")); SeqLen := Length (QoS); for Index in 1 .. SeqLen loop MyProp := Get_Element (QoS, Index); if MyProp.name = "EventReliability" then MyErrCode := UNAVAILABLE_PROPERTY; MyRange := (To_Any (CORBA.Short (0)), To_Any (CORBA.Short (0))); MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); elsif MyProp.name = "ConnectionReliability" then if CORBA.Short'(From_Any (MyProp.value)) /= 0 and then CORBA.Short'(From_Any (MyProp.value)) /= 1 then MyErrCode := BAD_VALUE; MyRange := (To_Any (CORBA.Short (0)), To_Any (CORBA.Short (0))); MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); end if; elsif MyProp.name = "Priority" then if CORBA.Short'(From_Any (MyProp.value)) not in -32_767 .. 32_767 then MyErrCode := BAD_VALUE; MyRange := (To_Any (CORBA.Short (-32767)), To_Any (CORBA.Short (32767))); MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); end if; elsif MyProp.name = "StartTime" then MyErrCode := UNAVAILABLE_PROPERTY; MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); elsif MyProp.name = "StopTime" then MyErrCode := UNAVAILABLE_PROPERTY; MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); elsif MyProp.name = "Timeout" then MyErrCode := UNSUPPORTED_PROPERTY; MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); elsif MyProp.name = "OrderPolicy" then if CORBA.Short'(From_Any (MyProp.value)) /= 0 and then CORBA.Short'(From_Any (MyProp.value)) /= 1 and then CORBA.Short'(From_Any (MyProp.value)) /= 2 and then CORBA.Short'(From_Any (MyProp.value)) /= 3 then MyErrCode := BAD_VALUE; MyRange := (To_Any (CORBA.Short (0)), To_Any (CORBA.Short (3))); MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); end if; elsif MyProp.name = "DiscardPolicy" then if CORBA.Short'(From_Any (MyProp.value)) /= 0 and then CORBA.Short'(From_Any (MyProp.value)) /= 1 and then CORBA.Short'(From_Any (MyProp.value)) /= 2 and then CORBA.Short'(From_Any (MyProp.value)) /= 3 and then CORBA.Short'(From_Any (MyProp.value)) /= 4 then MyErrCode := BAD_VALUE; MyRange := (To_Any (CORBA.Short (0)), To_Any (CORBA.Short (4))); MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); end if; elsif MyProp.name = "MaximumBatchSize" then MyErrCode := UNSUPPORTED_PROPERTY; MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); elsif MyProp.name = "PacingInterval" then MyErrCode := UNSUPPORTED_PROPERTY; MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); elsif MyProp.name = "StartTimeSupported" then MyErrCode := UNSUPPORTED_PROPERTY; MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); elsif MyProp.name = "StopTimeSupported" then MyErrCode := UNSUPPORTED_PROPERTY; MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); elsif MyProp.name = "MaxEventsPerConsumer" then MyErrCode := UNSUPPORTED_PROPERTY; MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); else MyErrCode := BAD_PROPERTY; MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); end if; end loop; if Length (MyErrorSeq) > 0 then CosNotification.Helper.Raise_UnsupportedQoS ((CORBA.IDL_Exception_Members with qos_err => MyErrorSeq)); end if; SeqLen := Length (QoS); Enter (Self_Mutex); for Index in 1 .. SeqLen loop MyProp := Get_Element (QoS, Index); if MyProp.name = "ConnectionReliability" then Replace_Element (Self.X.QoSPropSeq, 2, MyProp); elsif MyProp.name = "Priority" then Replace_Element (Self.X.QoSPropSeq, 3, MyProp); elsif MyProp.name = "OrderPolicy" then Replace_Element (Self.X.QoSPropSeq, 4, MyProp); elsif MyProp.name = "DiscardPolicy" then Replace_Element (Self.X.QoSPropSeq, 5, MyProp); end if; end loop; Leave (Self_Mutex); end Set_QoS; ------------------ -- Validate_QoS -- ------------------ procedure Validate_QoS (Self : access Object; Required_QoS : CosNotification.QoSProperties; Available_QoS : out CosNotification.NamedPropertyRangeSeq) is MyProp : CosNotification.Property; MyError : CosNotification.PropertyError; MyErrCode : CosNotification.QoSError_code; MyNamedRange : CosNotification.NamedPropertyRange; MyRange : CosNotification.PropertyRange; MyErrorSeq : CosNotification.PropertyErrorSeq; SeqLen : Integer; begin Ensure_Initialization; pragma Debug (O ("validate_qos in structuredproxypushsupplier")); SeqLen := Length (Required_QoS); for Index in 1 .. SeqLen loop MyProp := Get_Element (Required_QoS, Index); if MyProp.name = "EventReliability" then MyErrCode := UNAVAILABLE_PROPERTY; MyRange := (To_Any (CORBA.Short (0)), To_Any (CORBA.Short (0))); MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); elsif MyProp.name = "ConnectionReliability" then if CORBA.Short'(From_Any (MyProp.value)) /= 0 and then CORBA.Short'(From_Any (MyProp.value)) /= 1 then MyErrCode := BAD_VALUE; MyRange := (To_Any (CORBA.Short (0)), To_Any (CORBA.Short (0))); MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); end if; elsif MyProp.name = "Priority" then if CORBA.Short'(From_Any (MyProp.value)) not in -32_767 .. 32_767 then MyErrCode := BAD_VALUE; MyRange := (To_Any (CORBA.Short (-32767)), To_Any (CORBA.Short (32767))); MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); end if; elsif MyProp.name = "StartTime" then MyErrCode := UNAVAILABLE_PROPERTY; MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); elsif MyProp.name = "StopTime" then MyErrCode := UNAVAILABLE_PROPERTY; MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); elsif MyProp.name = "Timeout" then MyErrCode := UNSUPPORTED_PROPERTY; MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); elsif MyProp.name = "OrderPolicy" then if CORBA.Short'(From_Any (MyProp.value)) /= 0 and then CORBA.Short'(From_Any (MyProp.value)) /= 1 and then CORBA.Short'(From_Any (MyProp.value)) /= 2 and then CORBA.Short'(From_Any (MyProp.value)) /= 3 then MyErrCode := BAD_VALUE; MyRange := (To_Any (CORBA.Short (0)), To_Any (CORBA.Short (3))); MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); end if; elsif MyProp.name = "DiscardPolicy" then if CORBA.Short'(From_Any (MyProp.value)) /= 0 and then CORBA.Short'(From_Any (MyProp.value)) /= 1 and then CORBA.Short'(From_Any (MyProp.value)) /= 2 and then CORBA.Short'(From_Any (MyProp.value)) /= 3 and then CORBA.Short'(From_Any (MyProp.value)) /= 4 then MyErrCode := BAD_VALUE; MyRange := (To_Any (CORBA.Short (0)), To_Any (CORBA.Short (4))); MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); end if; elsif MyProp.name = "MaximumBatchSize" then MyErrCode := UNSUPPORTED_PROPERTY; MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); elsif MyProp.name = "PacingInterval" then MyErrCode := UNSUPPORTED_PROPERTY; MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); elsif MyProp.name = "StartTimeSupported" then MyErrCode := UNSUPPORTED_PROPERTY; MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); elsif MyProp.name = "StopTimeSupported" then MyErrCode := UNSUPPORTED_PROPERTY; MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); elsif MyProp.name = "MaxEventsPerConsumer" then MyErrCode := UNSUPPORTED_PROPERTY; MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); else MyErrCode := BAD_PROPERTY; MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); end if; end loop; if Length (MyErrorSeq) > 0 then CosNotification.Helper.Raise_UnsupportedQoS ((CORBA.IDL_Exception_Members with qos_err => MyErrorSeq)); end if; Enter (Self_Mutex); SeqLen := Length (Self.X.QoSPropSeq); for Index in 1 .. SeqLen loop MyProp := Get_Element (Self.X.QoSPropSeq, Index); if MyProp.name = "ConnectionReliability" then MyRange := (From_Any (MyProp.value), To_Any (CORBA.Short (0))); MyNamedRange := (MyProp.name, MyRange); Append (Available_QoS, MyNamedRange); elsif MyProp.name = "Priority" then MyRange := (To_Any (CORBA.Short (-32767)), To_Any (CORBA.Short (32767))); MyNamedRange := (MyProp.name, MyRange); Append (Available_QoS, MyNamedRange); elsif MyProp.name = "OrderPolicy" then MyRange := (To_Any (CORBA.Short (0)), To_Any (CORBA.Short (3))); MyNamedRange := (MyProp.name, MyRange); Append (Available_QoS, MyNamedRange); elsif MyProp.name = "DiscardPolicy" then MyRange := (To_Any (CORBA.Short (0)), To_Any (CORBA.Short (4))); MyNamedRange := (MyProp.name, MyRange); Append (Available_QoS, MyNamedRange); end if; end loop; Leave (Self_Mutex); end Validate_QoS; ---------------- -- Add_Filter -- ---------------- function Add_Filter (Self : access Object; New_Filter : CosNotifyFilter.Filter.Ref) return CosNotifyFilter.FilterID is pragma Warnings (Off); -- WAG:3.14 pragma Unreferenced (Self, New_Filter); pragma Warnings (On); -- WAG:3.14 MyFilterID : CosNotifyFilter.FilterID; MyID : CORBA.Long; begin Ensure_Initialization; pragma Debug (O ("add_filter in structuredproxypushsupplier")); Enter (Self_Mutex); Leave (Self_Mutex); MyID := 0; MyFilterID := CosNotifyFilter.FilterID (MyID); return MyFilterID; end Add_Filter; ------------------- -- Remove_Filter -- ------------------- procedure Remove_Filter (Self : access Object; Filter : CosNotifyFilter.FilterID) is pragma Warnings (Off); -- WAG:3.14 pragma Unreferenced (Self, Filter); pragma Warnings (On); -- WAG:3.14 begin Ensure_Initialization; pragma Debug (O ("remove_filter in structuredproxypushsupplier")); Enter (Self_Mutex); Leave (Self_Mutex); end Remove_Filter; ---------------- -- Get_Filter -- ---------------- function Get_Filter (Self : access Object; Filter : CosNotifyFilter.FilterID) return CosNotifyFilter.Filter.Ref is pragma Warnings (Off); -- WAG:3.14 pragma Unreferenced (Self, Filter); pragma Warnings (On); -- WAG:3.14 MyFilter : CosNotifyFilter.Filter.Ref; begin Ensure_Initialization; pragma Debug (O ("get_filter in structuredproxypushsupplier")); Enter (Self_Mutex); Leave (Self_Mutex); return MyFilter; end Get_Filter; --------------------- -- Get_All_Filters -- --------------------- function Get_All_Filters (Self : access Object) return CosNotifyFilter.FilterIDSeq is pragma Warnings (Off); -- WAG:3.14 pragma Unreferenced (Self); pragma Warnings (On); -- WAG:3.14 MyFilterSeq : CosNotifyFilter.FilterIDSeq; begin Ensure_Initialization; pragma Debug (O ("get_all_filters in structuredproxypushsupplier")); Enter (Self_Mutex); Leave (Self_Mutex); return MyFilterSeq; end Get_All_Filters; ------------------------ -- Remove_All_Filters -- ------------------------ procedure Remove_All_Filters (Self : access Object) is pragma Warnings (Off); -- WAG:3.14 pragma Unreferenced (Self); pragma Warnings (On); -- WAG:3.14 begin Ensure_Initialization; pragma Debug (O ("remove_all_filters in structuredproxypushsupplier")); Enter (Self_Mutex); Leave (Self_Mutex); end Remove_All_Filters; ------------------------- -- Subscription_Change -- ------------------------- procedure Subscription_Change (Self : access Object; Added : CosNotification.EventTypeSeq; Removed : CosNotification.EventTypeSeq) is pragma Warnings (Off); -- WAG:3.14 pragma Unreferenced (Self, Added, Removed); pragma Warnings (On); -- WAG:3.14 begin Ensure_Initialization; pragma Debug (O ("subscription_change in structuredproxypushsupplier")); Enter (Self_Mutex); Leave (Self_Mutex); end Subscription_Change; ----------------------------------------- -- Disconnect_Structured_Push_Supplier -- ----------------------------------------- procedure Disconnect_Structured_Push_Supplier (Self : access Object) is Peer : CosNotifyComm.StructuredPushConsumer.Ref; Nil_Ref : CosNotifyComm.StructuredPushConsumer.Ref; begin pragma Debug (O ("disconnect structuredproxypushsupplier")); Ensure_Initialization; Enter (Self_Mutex); Peer := Self.X.Peer; Self.X.Peer := Nil_Ref; Leave (Self_Mutex); if not CosNotifyComm.StructuredPushConsumer.Is_Nil (Peer) then CosNotifyComm.StructuredPushConsumer. disconnect_structured_push_consumer (Peer); end if; end Disconnect_Structured_Push_Supplier; ------------ -- Create -- ------------ function Create (Admin : CosNotifyChannelAdmin.ConsumerAdmin.Ref; Initial_QoS : CosNotification.QoSProperties; Ptype : CosNotifyChannelAdmin.ProxyType; Proxy_Id : CosNotifyChannelAdmin.ProxyID) return Object_Ptr is Supplier : Object_Ptr; My_Ref : StructuredProxyPushSupplier.Ref; begin pragma Debug (O ("create structuredproxypushsupplier")); Supplier := new Object; Supplier.X := new Structured_Proxy_Push_Supplier_Record; Supplier.X.Admin := Admin; Supplier.X.MyId := Proxy_Id; Supplier.X.MyType := Ptype; Supplier.X.This := Supplier; Supplier.X.QoSPropSeq := Initial_QoS; Initiate_Servant (PortableServer.Servant (Supplier), My_Ref); return Supplier; end Create; --------------------- -- Structured_Post -- --------------------- procedure Structured_Post (Self : access Object; Notification : CosNotification.StructuredEvent) is MyPeer : CosNotifyComm.StructuredPushConsumer.Ref; begin pragma Debug (O ("post new structured event from structuredproxypushsupplier" & "to structured pushconsumer")); Ensure_Initialization; Enter (Self_Mutex); MyPeer := Self.X.Peer; Leave (Self_Mutex); begin CosNotifyComm.StructuredPushConsumer.push_structured_event (MyPeer, Notification); exception when others => pragma Debug (O ("Got exception in post at structuredproxypushsupplier")); raise; end; end Structured_Post; end CosNotifyChannelAdmin.StructuredProxyPushSupplier.Impl; polyorb-2.8~20110207.orig/cos/notification/cosnotifycomm-notifypublish-impl.adb0000644000175000017500000001023311750740337027056 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- C O S N O T I F Y C O M M . N O T I F Y P U B L I S H . I M P L -- -- -- -- B o d y -- -- -- -- Copyright (C) 2003-2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with PolyORB.CORBA_P.Server_Tools; with PolyORB.Log; with PolyORB.Tasking.Mutexes; with CosNotifyComm.NotifyPublish.Skel; pragma Warnings (Off, CosNotifyComm.NotifyPublish.Skel); package body CosNotifyComm.NotifyPublish.Impl is use PolyORB.CORBA_P.Server_Tools; use PolyORB.Tasking.Mutexes; use PolyORB.Log; package L is new PolyORB.Log.Facility_Log ("notifypublish"); procedure O (Message : Standard.String; Level : Log_Level := Debug) renames L.Output; function C (Level : Log_Level := Debug) return Boolean renames L.Enabled; pragma Unreferenced (C); -- For conditional pragma Debug type Notify_Publish_Record is record This : Object_Ptr; end record; --------------------------- -- Ensure_Initialization -- --------------------------- procedure Ensure_Initialization; pragma Inline (Ensure_Initialization); -- Ensure that the Mutexes are initialized T_Initialized : Boolean := False; Self_Mutex : Mutex_Access; procedure Ensure_Initialization is begin if not T_Initialized then Create (Self_Mutex); T_Initialized := True; end if; end Ensure_Initialization; ------------------ -- Offer_Change -- ------------------ procedure Offer_Change (Self : access Object; Added : CosNotification.EventTypeSeq; Removed : CosNotification.EventTypeSeq) is pragma Warnings (Off); -- WAG:3.14 pragma Unreferenced (Self, Added, Removed); pragma Warnings (On); -- WAG:3.14 begin pragma Debug (O ("offer_change in notifypublish")); Ensure_Initialization; Enter (Self_Mutex); Leave (Self_Mutex); end Offer_Change; ------------ -- Create -- ------------ function Create return Object_Ptr is Publish : Object_Ptr; My_Ref : NotifyPublish.Ref; begin pragma Debug (O ("create notifypublish")); Publish := new Object; Publish.X := new Notify_Publish_Record; Publish.X.This := Publish; Initiate_Servant (PortableServer.Servant (Publish), My_Ref); return Publish; end Create; end CosNotifyComm.NotifyPublish.Impl; polyorb-2.8~20110207.orig/cos/notification/cosnotifychanneladmin-consumeradmin-impl.ads0000644000175000017500000001527311750740337030543 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- COSNOTIFYCHANNELADMIN.CONSUMERADMIN.IMPL -- -- -- -- S p e c -- -- -- -- Copyright (C) 2003-2008, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by ACT Europe. -- -- (email: sales@act-europe.fr) -- -- -- ------------------------------------------------------------------------------ with CosNotifyChannelAdmin.EventChannel; with CosNotifyFilter.MappingFilter; with PortableServer; package CosNotifyChannelAdmin.ConsumerAdmin.Impl is type Object is new PortableServer.Servant_Base with private; type Object_Ptr is access all Object'Class; -- IDL operations function Get_MyID (Self : access Object) return CosNotifyChannelAdmin.AdminID; function Get_MyChannel (Self : access Object) return CosNotifyChannelAdmin.EventChannel_Forward.Ref; function Get_MyOperator (Self : access Object) return CosNotifyChannelAdmin.InterFilterGroupOperator; function Get_Priority_Filter (Self : access Object) return CosNotifyFilter.MappingFilter.Ref; procedure Set_Priority_Filter (Self : access Object; To : CosNotifyFilter.MappingFilter.Ref); function Get_Lifetime_Filter (Self : access Object) return CosNotifyFilter.MappingFilter.Ref; procedure Set_Lifetime_Filter (Self : access Object; To : CosNotifyFilter.MappingFilter.Ref); function Get_Pull_Suppliers (Self : access Object) return CosNotifyChannelAdmin.ProxyIDSeq; function Get_Push_Suppliers (Self : access Object) return CosNotifyChannelAdmin.ProxyIDSeq; function Get_Proxy_Supplier (Self : access Object; Proxy_Id : CosNotifyChannelAdmin.ProxyID) return CosNotifyChannelAdmin.ProxySupplier.Ref; procedure Obtain_Notification_Pull_Supplier (Self : access Object; Ctype : CosNotifyChannelAdmin.ClientType; Proxy_Id : out CosNotifyChannelAdmin.ProxyID; Returns : out CosNotifyChannelAdmin.ProxySupplier.Ref); procedure Obtain_Notification_Push_Supplier (Self : access Object; Ctype : CosNotifyChannelAdmin.ClientType; Proxy_Id : out CosNotifyChannelAdmin.ProxyID; Returns : out CosNotifyChannelAdmin.ProxySupplier.Ref); procedure Destroy (Self : access Object); -- IDL Operations inherited from CosNotification::QoSAdmin function Get_QoS (Self : access Object) return CosNotification.QoSProperties; procedure Set_QoS (Self : access Object; QoS : CosNotification.QoSProperties); procedure Validate_QoS (Self : access Object; Required_QoS : CosNotification.QoSProperties; Available_QoS : out CosNotification.NamedPropertyRangeSeq); -- Inherited IDL operations from CosNotifyComm::NotifySubscribe procedure Subscription_Change (Self : access Object; Added : CosNotification.EventTypeSeq; Removed : CosNotification.EventTypeSeq); -- Inherited IDL operations from CosNotifyFilter::FilterAdmin function Add_Filter (Self : access Object; New_Filter : CosNotifyFilter.Filter.Ref) return CosNotifyFilter.FilterID; procedure Remove_Filter (Self : access Object; Filter : CosNotifyFilter.FilterID); function Get_Filter (Self : access Object; Filter : CosNotifyFilter.FilterID) return CosNotifyFilter.Filter.Ref; function Get_All_Filters (Self : access Object) return CosNotifyFilter.FilterIDSeq; procedure Remove_All_Filters (Self : access Object); -- Inherited IDL operations from CosEventChannelAdmin::ConsumerAdmin function Obtain_Push_Supplier (Self : access Object) return CosEventChannelAdmin.ProxyPushSupplier.Ref; function Obtain_Pull_Supplier (Self : access Object) return CosEventChannelAdmin.ProxyPullSupplier.Ref; ---------------------- -- PolyORB specific -- ---------------------- function Create (Channel : CosNotifyChannelAdmin.EventChannel.Ref; Initial_QoS : CosNotification.QoSProperties; MyID : CosNotifyChannelAdmin.AdminID; MyOp : CosNotifyChannelAdmin.InterFilterGroupOperator := AND_OP) return Object_Ptr; function GetTotalSuppliers (Self : access Object) return CORBA.Long; -- Returns the total number of Suppliers created by this Admin procedure Post (Self : access Object; Data : CORBA.Any; Internal_Post : CORBA.Boolean := False); procedure Structured_Post (Self : access Object; Notification : CosNotification.StructuredEvent; Internal_Post : CORBA.Boolean := False); procedure Sequence_Post (Self : access Object; Notifications : CosNotification.EventBatch; Internal_Post : CORBA.Boolean := False); private type Consumer_Admin_Record; type Consumer_Admin_Access is access Consumer_Admin_Record; type Object is new PortableServer.Servant_Base with record X : Consumer_Admin_Access; end record; end CosNotifyChannelAdmin.ConsumerAdmin.Impl; polyorb-2.8~20110207.orig/cos/notification/cosnotifycomm-structuredpullsupplier-impl.ads0000644000175000017500000000750011750740337031070 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- COSNOTIFYCOMM.STRUCTUREDPULLSUPPLIER.IMPL -- -- -- -- S p e c -- -- -- -- Copyright (C) 2003-2008, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by ACT Europe. -- -- (email: sales@act-europe.fr) -- -- -- ------------------------------------------------------------------------------ with PortableServer; with CosNotifyChannelAdmin.StructuredProxyPullConsumer; package CosNotifyComm.StructuredPullSupplier.Impl is type Object is new PortableServer.Servant_Base with private; type Object_Ptr is access all Object'Class; -- Inherited IDL operations from CosNotifyComm::NotifySubscribe procedure Subscription_Change (Self : access Object; Added : CosNotification.EventTypeSeq; Removed : CosNotification.EventTypeSeq); -- IDL operations function Pull_Structured_Event (Self : access Object) return CosNotification.StructuredEvent; -- Call by proxy to pull a structured event procedure Try_Pull_Structured_Event (Self : access Object; Has_Event : out CORBA.Boolean; Returns : out CosNotification.StructuredEvent); -- Call by proxy to try to pull a structured event procedure Disconnect_Structured_Pull_Supplier (Self : access Object); -- Call by proxy to disconnect ---------------------- -- PolyORB specific -- ---------------------- procedure Connect_Structured_Proxy_Pull_Consumer (Self : access Object; Proxy : CosNotifyChannelAdmin.StructuredProxyPullConsumer.Ref); -- Call by application to connect object with proxy function Create return Object_Ptr; -- Call by application to create an object and activate servant procedure Push (Self : access Object; Data : CosNotification.StructuredEvent); -- Call by application to produce a structured event private type Structured_Pull_Supplier_Record; type Structured_Pull_Supplier_Access is access Structured_Pull_Supplier_Record; type Object is new PortableServer.Servant_Base with record X : Structured_Pull_Supplier_Access; end record; end CosNotifyComm.StructuredPullSupplier.Impl; polyorb-2.8~20110207.orig/cos/notification/cosnotifychanneladmin-eventchannel-impl.ads0000644000175000017500000001432611750740337030347 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- COSNOTIFYCHANNELADMIN.EVENTCHANNEL.IMPL -- -- -- -- S p e c -- -- -- -- Copyright (C) 2003-2008, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by ACT Europe. -- -- (email: sales@act-europe.fr) -- -- -- ------------------------------------------------------------------------------ with CORBA; with CosNotifyChannelAdmin.EventChannelFactory; with PortableServer; package CosNotifyChannelAdmin.EventChannel.Impl is type Object is new PortableServer.Servant_Base with private; type Object_Ptr is access all Object'Class; -- IDL operations function Get_MyFactory (Self : access Object) return CosNotifyChannelAdmin.EventChannelFactory_Forward.Ref; function Get_Default_Consumer_Admin (Self : access Object) return CosNotifyChannelAdmin.ConsumerAdmin.Ref; function Get_Default_Supplier_Admin (Self : access Object) return CosNotifyChannelAdmin.SupplierAdmin.Ref; function Get_Default_Filter_Factory (Self : access Object) return CosNotifyFilter.FilterFactory.Ref; procedure New_For_Consumers (Self : access Object; Op : CosNotifyChannelAdmin.InterFilterGroupOperator; Id : out CosNotifyChannelAdmin.AdminID; Returns : out CosNotifyChannelAdmin.ConsumerAdmin.Ref); procedure New_For_Suppliers (Self : access Object; Op : CosNotifyChannelAdmin.InterFilterGroupOperator; Id : out CosNotifyChannelAdmin.AdminID; Returns : out CosNotifyChannelAdmin.SupplierAdmin.Ref); function Get_ConsumerAdmin (Self : access Object; Id : CosNotifyChannelAdmin.AdminID) return CosNotifyChannelAdmin.ConsumerAdmin.Ref; function Get_SupplierAdmin (Self : access Object; Id : CosNotifyChannelAdmin.AdminID) return CosNotifyChannelAdmin.SupplierAdmin.Ref; function Get_All_ConsumerAdmins (Self : access Object) return CosNotifyChannelAdmin.AdminIDSeq; function Get_All_SupplierAdmins (Self : access Object) return CosNotifyChannelAdmin.AdminIDSeq; -- IDL Operations inherited from CosNotification::QoSAdmin function Get_QoS (Self : access Object) return CosNotification.QoSProperties; procedure Set_QoS (Self : access Object; QoS : CosNotification.QoSProperties); procedure Validate_QoS (Self : access Object; Required_QoS : CosNotification.QoSProperties; Available_QoS : out CosNotification.NamedPropertyRangeSeq); -- IDL Operations inherited from CosNotification::AdminPropertiesAdmin function Get_Admin (Self : access Object) return CosNotification.AdminProperties; procedure Set_Admin (Self : access Object; Admin : CosNotification.AdminProperties); -- IDL Operations inherited from CosEventChannelAdmin::EventChannel function For_Consumers (Self : access Object) return CosEventChannelAdmin.ConsumerAdmin.Ref; function For_Suppliers (Self : access Object) return CosEventChannelAdmin.SupplierAdmin.Ref; procedure Destroy (Self : access Object); ---------------------- -- PolyORB specific -- ---------------------- function Create (Factory : CosNotifyChannelAdmin.EventChannelFactory.Ref; Initial_QoS : CosNotification.QoSProperties; Initial_Admin : CosNotification.AdminProperties) return Object_Ptr; function GetTotalConsumers (Self : access Object) return CORBA.Long; -- Returns total number of proxy consumers connected to channel function GetTotalSuppliers (Self : access Object) return CORBA.Long; -- Returns total number of proxy suppliers connected to channel procedure Post (Self : access Object; Data : CORBA.Any); procedure Structured_Post (Self : access Object; Notification : CosNotification.StructuredEvent); procedure Sequence_Post (Self : access Object; Notifications : CosNotification.EventBatch); function TestConsumerLimit (Self : access Object) return CORBA.Boolean; -- Tests whether more consumers can be created by SupplierAdmin function TestSupplierLimit (Self : access Object) return CORBA.Boolean; -- Tests whether more suppliers can be created by ConsumerAdmin private type Event_Channel_Record; type Event_Channel_Access is access Event_Channel_Record; type Object is new PortableServer.Servant_Base with record X : Event_Channel_Access; end record; end CosNotifyChannelAdmin.EventChannel.Impl; polyorb-2.8~20110207.orig/cos/notification/cosnotifycomm-pullconsumer-impl.adb0000644000175000017500000001672311750740337026721 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- C O S N O T I F Y C O M M . P U L L C O N S U M E R . I M P L -- -- -- -- B o d y -- -- -- -- Copyright (C) 2003-2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with CosEventChannelAdmin.Helper; with CosEventComm.Helper; with CosEventComm.PullConsumer.Helper; with PolyORB.CORBA_P.Server_Tools; with PolyORB.Log; with PolyORB.Tasking.Mutexes; with CosNotifyComm.PullConsumer.Skel; pragma Warnings (Off, CosNotifyComm.PullConsumer.Skel); package body CosNotifyComm.PullConsumer.Impl is use PolyORB.CORBA_P.Server_Tools; use PolyORB.Tasking.Mutexes; use PolyORB.Log; package L is new PolyORB.Log.Facility_Log ("pullconsumer"); procedure O (Message : Standard.String; Level : Log_Level := Debug) renames L.Output; function C (Level : Log_Level := Debug) return Boolean renames L.Enabled; pragma Unreferenced (C); -- For conditional pragma Debug type Pull_Consumer_Record is record This : Object_Ptr; Peer : CosNotifyChannelAdmin.ProxyPullSupplier.Ref; end record; --------------------------- -- Ensure_Initialization -- --------------------------- procedure Ensure_Initialization; pragma Inline (Ensure_Initialization); -- Ensure that the Mutexes are initialized T_Initialized : Boolean := False; Self_Mutex : Mutex_Access; procedure Ensure_Initialization is begin if not T_Initialized then Create (Self_Mutex); T_Initialized := True; end if; end Ensure_Initialization; ------------------------------ -- Disconnect_Pull_Consumer -- ------------------------------ procedure Disconnect_Pull_Consumer (Self : access Object) is Peer : CosNotifyChannelAdmin.ProxyPullSupplier.Ref; Nil_Ref : CosNotifyChannelAdmin.ProxyPullSupplier.Ref; begin pragma Debug (O ("disconnect pull consumer")); Ensure_Initialization; Enter (Self_Mutex); Peer := Self.X.Peer; Self.X.Peer := Nil_Ref; Leave (Self_Mutex); if not CosNotifyChannelAdmin.ProxyPullSupplier.Is_Nil (Peer) then CosNotifyChannelAdmin.ProxyPullSupplier.disconnect_pull_supplier (Peer); end if; end Disconnect_Pull_Consumer; ------------------ -- Offer_Change -- ------------------ procedure Offer_Change (Self : access Object; Added : CosNotification.EventTypeSeq; Removed : CosNotification.EventTypeSeq) is pragma Warnings (Off); -- WAG:3.14 pragma Unreferenced (Self, Added, Removed); pragma Warnings (On); -- WAG:3.14 begin pragma Debug (O ("offer_change in pullconsumer")); Ensure_Initialization; Enter (Self_Mutex); Leave (Self_Mutex); end Offer_Change; ------------------------------------- -- Connect_Any_Proxy_Pull_Supplier -- ------------------------------------- procedure Connect_Any_Proxy_Pull_Supplier (Self : access Object; Proxy : CosNotifyChannelAdmin.ProxyPullSupplier.Ref) is Cons_Ref : CosEventComm.PullConsumer.Ref; My_Ref : PullConsumer.Ref; begin Ensure_Initialization; pragma Debug (O ("connect_any_proxy_pull_supplier in pullconsumer")); Enter (Self_Mutex); if not CosNotifyChannelAdmin.ProxyPullSupplier.Is_Nil (Self.X.Peer) then Leave (Self_Mutex); CosEventChannelAdmin.Helper.Raise_AlreadyConnected ((CORBA.IDL_Exception_Members with null record)); end if; Self.X.Peer := Proxy; Servant_To_Reference (PortableServer.Servant (Self.X.This), My_Ref); Leave (Self_Mutex); Cons_Ref := CosEventComm.PullConsumer.Helper.To_Ref (My_Ref); CosNotifyChannelAdmin.ProxyPullSupplier.connect_any_pull_consumer (Proxy, Cons_Ref); end Connect_Any_Proxy_Pull_Supplier; ------------ -- Create -- ------------ function Create return Object_Ptr is Consumer : Object_Ptr; My_Ref : PullConsumer.Ref; Peer_Ref : CosNotifyChannelAdmin.ProxyPullSupplier.Ref; begin pragma Debug (O ("create pullconsumer")); Consumer := new Object; Consumer.X := new Pull_Consumer_Record; Consumer.X.This := Consumer; Consumer.X.Peer := Peer_Ref; Initiate_Servant (PortableServer.Servant (Consumer), My_Ref); return Consumer; end Create; ---------- -- Pull -- ---------- function Pull (Self : access Object) return CORBA.Any is Peer : CosNotifyChannelAdmin.ProxyPullSupplier.Ref; begin pragma Debug (O ("pull new data from pull consumer")); Ensure_Initialization; Enter (Self_Mutex); Peer := Self.X.Peer; Leave (Self_Mutex); if CosNotifyChannelAdmin.ProxyPullSupplier.Is_Nil (Peer) then CosEventComm.Helper.Raise_Disconnected ((CORBA.IDL_Exception_Members with null record)); end if; return CosNotifyChannelAdmin.ProxyPullSupplier.pull (Peer); end Pull; -------------- -- Try_Pull -- -------------- procedure Try_Pull (Self : access Object; Done : out CORBA.Boolean; Returns : out CORBA.Any) is Peer : CosNotifyChannelAdmin.ProxyPullSupplier.Ref; begin pragma Debug (O ("try to pull new data from pull consumer")); Ensure_Initialization; Enter (Self_Mutex); Peer := Self.X.Peer; Leave (Self_Mutex); if CosNotifyChannelAdmin.ProxyPullSupplier.Is_Nil (Peer) then CosEventComm.Helper.Raise_Disconnected ((CORBA.IDL_Exception_Members with null record)); end if; CosNotifyChannelAdmin.ProxyPullSupplier.try_pull (Peer, Done, Returns); end Try_Pull; end CosNotifyComm.PullConsumer.Impl; polyorb-2.8~20110207.orig/cos/notification/cosnotifycomm-pullsupplier-impl.adb0000644000175000017500000002061511750740337026724 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- C O S N O T I F Y C O M M . P U L L S U P P L I E R . I M P L -- -- -- -- B o d y -- -- -- -- Copyright (C) 2003-2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with CosEventChannelAdmin.Helper; with CosEventComm.Helper; with CosEventComm.PullSupplier.Helper; with PolyORB.CORBA_P.Server_Tools; with PolyORB.Log; with PolyORB.Tasking.Mutexes; with PolyORB.Tasking.Semaphores; with CosNotifyComm.PullSupplier.Skel; pragma Warnings (Off, CosNotifyComm.PullSupplier.Skel); package body CosNotifyComm.PullSupplier.Impl is use PolyORB.CORBA_P.Server_Tools; use PolyORB.Tasking.Mutexes; use PolyORB.Tasking.Semaphores; use PolyORB.Log; package L is new PolyORB.Log.Facility_Log ("pullsupplier"); procedure O (Message : Standard.String; Level : Log_Level := Debug) renames L.Output; function C (Level : Log_Level := Debug) return Boolean renames L.Enabled; pragma Unreferenced (C); -- For conditional pragma Debug type Pull_Supplier_Record is record This : Object_Ptr; Peer : CosNotifyChannelAdmin.ProxyPullConsumer.Ref; Empty : Boolean; Event : CORBA.Any; Semaphore : Semaphore_Access; end record; --------------------------- -- Ensure_Initialization -- --------------------------- procedure Ensure_Initialization; pragma Inline (Ensure_Initialization); -- Ensure that the Mutexes are initialized T_Initialized : Boolean := False; Self_Mutex : Mutex_Access; procedure Ensure_Initialization is begin if not T_Initialized then Create (Self_Mutex); T_Initialized := True; end if; end Ensure_Initialization; ------------------------------------- -- Connect_Any_Proxy_Pull_Consumer -- ------------------------------------- procedure Connect_Any_Proxy_Pull_Consumer (Self : access Object; Proxy : CosNotifyChannelAdmin.ProxyPullConsumer.Ref) is My_Ref : PullSupplier.Ref; Sup_Ref : CosEventComm.PullSupplier.Ref; begin Ensure_Initialization; pragma Debug (O ("connect_any_proxy_pull_consumer in pullsupplier")); Enter (Self_Mutex); if not CosNotifyChannelAdmin.ProxyPullConsumer.Is_Nil (Self.X.Peer) then Leave (Self_Mutex); CosEventChannelAdmin.Helper.Raise_AlreadyConnected ((CORBA.IDL_Exception_Members with null record)); end if; Self.X.Peer := Proxy; Servant_To_Reference (PortableServer.Servant (Self.X.This), My_Ref); Leave (Self_Mutex); Sup_Ref := CosEventComm.PullSupplier.Helper.To_Ref (My_Ref); CosNotifyChannelAdmin.ProxyPullConsumer.connect_any_pull_supplier (Proxy, Sup_Ref); end Connect_Any_Proxy_Pull_Consumer; ------------------------- -- Subscription_Change -- ------------------------- procedure Subscription_Change (Self : access Object; Added : CosNotification.EventTypeSeq; Removed : CosNotification.EventTypeSeq) is pragma Warnings (Off); -- WAG:3.14 pragma Unreferenced (Self, Added, Removed); pragma Warnings (On); -- WAG:3.14 begin pragma Debug (O ("subscription_change in pullsupplier")); Ensure_Initialization; Enter (Self_Mutex); Leave (Self_Mutex); end Subscription_Change; ------------------------------ -- Disconnect_Pull_Supplier -- ------------------------------ procedure Disconnect_Pull_Supplier (Self : access Object) is Peer : CosNotifyChannelAdmin.ProxyPullConsumer.Ref; Nil_Ref : CosNotifyChannelAdmin.ProxyPullConsumer.Ref; begin Ensure_Initialization; pragma Debug (O ("disconnect pull supplier")); Enter (Self_Mutex); Peer := Self.X.Peer; Self.X.Peer := Nil_Ref; Leave (Self_Mutex); V (Self.X.Semaphore); if not CosNotifyChannelAdmin.ProxyPullConsumer.Is_Nil (Peer) then CosNotifyChannelAdmin.ProxyPullConsumer.disconnect_pull_consumer (Peer); end if; end Disconnect_Pull_Supplier; ---------- -- Pull -- ---------- function Pull (Self : access Object) return CORBA.Any is Event : CORBA.Any; begin Ensure_Initialization; loop pragma Debug (O ("attempt to pull new data from pull supplier")); P (Self.X.Semaphore); Enter (Self_Mutex); if CosNotifyChannelAdmin.ProxyPullConsumer.Is_Nil (Self.X.Peer) then Leave (Self_Mutex); CosEventComm.Helper.Raise_Disconnected ((CORBA.IDL_Exception_Members with null record)); end if; if not Self.X.Empty then Event := Self.X.Event; Self.X.Empty := True; Leave (Self_Mutex); exit; end if; Leave (Self_Mutex); end loop; pragma Debug (O ("succeed to pull new data from pull supplier")); return Event; end Pull; ---------- -- Push -- ---------- procedure Push (Self : access Object; Data : CORBA.Any) is begin pragma Debug (O ("push new data to pull supplier")); Ensure_Initialization; Enter (Self_Mutex); Self.X.Empty := False; Self.X.Event := Data; Leave (Self_Mutex); V (Self.X.Semaphore); end Push; -------------- -- Try_Pull -- -------------- procedure Try_Pull (Self : access Object; Has_Event : out CORBA.Boolean; Returns : out CORBA.Any) is begin Ensure_Initialization; pragma Debug (O ("try to pull new data from pull supplier")); Enter (Self_Mutex); if CosNotifyChannelAdmin.ProxyPullConsumer.Is_Nil (Self.X.Peer) then Leave (Self_Mutex); CosEventComm.Helper.Raise_Disconnected ((CORBA.IDL_Exception_Members with null record)); end if; Has_Event := not Self.X.Empty; if Has_Event then Returns := Self.X.Event; Self.X.Empty := True; end if; Leave (Self_Mutex); end Try_Pull; ------------ -- Create -- ------------ function Create return Object_Ptr is Supplier : Object_Ptr; My_Ref : PullSupplier.Ref; Peer_Ref : CosNotifyChannelAdmin.ProxyPullConsumer.Ref; begin pragma Debug (O ("create pullsupplier")); Supplier := new Object; Supplier.X := new Pull_Supplier_Record; Supplier.X.This := Supplier; Supplier.X.Empty := True; Supplier.X.Peer := Peer_Ref; Create (Supplier.X.Semaphore); Initiate_Servant (PortableServer.Servant (Supplier), My_Ref); return Supplier; end Create; end CosNotifyComm.PullSupplier.Impl; polyorb-2.8~20110207.orig/cos/notification/cosnotifychanneladmin-supplieradmin-impl.adb0000644000175000017500000011504711750740337030532 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- COSNOTIFYCHANNELADMIN.SUPPLIERADMIN.IMPL -- -- -- -- B o d y -- -- -- -- Copyright (C) 2003-2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with CosNotification; with CosNotification.Helper; with CosNotifyChannelAdmin.EventChannel.Impl; with CosNotifyChannelAdmin.Helper; with CosNotifyChannelAdmin.ProxyPushConsumer.Impl; with CosNotifyChannelAdmin.ProxyPushConsumer.Helper; with CosNotifyChannelAdmin.ProxyPullConsumer.Impl; with CosNotifyChannelAdmin.ProxyPullConsumer.Helper; with CosNotifyChannelAdmin.SequenceProxyPullConsumer.Impl; with CosNotifyChannelAdmin.SequenceProxyPullConsumer.Helper; with CosNotifyChannelAdmin.SequenceProxyPushConsumer.Impl; with CosNotifyChannelAdmin.SequenceProxyPushConsumer.Helper; with CosNotifyChannelAdmin.StructuredProxyPushConsumer.Impl; with CosNotifyChannelAdmin.StructuredProxyPushConsumer.Helper; with CosNotifyChannelAdmin.StructuredProxyPullConsumer.Impl; with CosNotifyChannelAdmin.StructuredProxyPullConsumer.Helper; with PolyORB.CORBA_P.Server_Tools; with PolyORB.Tasking.Mutexes; with PolyORB.Log; with CosNotifyChannelAdmin.SupplierAdmin.Skel; pragma Warnings (Off, CosNotifyChannelAdmin.SupplierAdmin.Skel); package body CosNotifyChannelAdmin.SupplierAdmin.Impl is use IDL_SEQUENCE_CosNotifyChannelAdmin_ProxyID; use CosNotification; use IDL_SEQUENCE_CosNotification_Property; use IDL_SEQUENCE_CosNotification_PropertyError; use IDL_SEQUENCE_CosNotification_NamedPropertyRange; use CORBA; use PortableServer; use PolyORB.CORBA_P.Server_Tools; use PolyORB.Tasking.Mutexes; package Convert is new EventChannel_Forward.Convert (CosNotifyChannelAdmin.EventChannel.Ref); use PolyORB.Log; package L is new PolyORB.Log.Facility_Log ("supplieradmin"); procedure O (Message : Standard.String; Level : Log_Level := Debug) renames L.Output; function C (Level : Log_Level := Debug) return Boolean renames L.Enabled; pragma Unreferenced (C); -- For conditional pragma Debug package AllProxies is new CORBA.Sequences.Unbounded (CORBA.Long); package PullConsumers is new CORBA.Sequences.Unbounded (CosNotifyChannelAdmin.ProxyPullConsumer.Ref); package PushConsumers is new CORBA.Sequences.Unbounded (CosNotifyChannelAdmin.ProxyPushConsumer.Ref); package SequencePullConsumers is new CORBA.Sequences.Unbounded (CosNotifyChannelAdmin.SequenceProxyPullConsumer.Ref); package SequencePushConsumers is new CORBA.Sequences.Unbounded (CosNotifyChannelAdmin.SequenceProxyPushConsumer.Ref); package StructuredPullConsumers is new CORBA.Sequences.Unbounded (CosNotifyChannelAdmin.StructuredProxyPullConsumer.Ref); package StructuredPushConsumers is new CORBA.Sequences.Unbounded (CosNotifyChannelAdmin.StructuredProxyPushConsumer.Ref); type Supplier_Admin_Record is record This : Object_Ptr; Channel : CosNotifyChannelAdmin.EventChannel.Ref; Id : CosNotifyChannelAdmin.AdminID; Op : CosNotifyChannelAdmin.InterFilterGroupOperator; AllPxs : AllProxies.Sequence; Pulls : PullConsumers.Sequence; Pushs : PushConsumers.Sequence; SequencePulls : SequencePullConsumers.Sequence; SequencePushs : SequencePushConsumers.Sequence; StructPulls : StructuredPullConsumers.Sequence; StructPushs : StructuredPushConsumers.Sequence; PullIDSeq : CosNotifyChannelAdmin.ProxyIDSeq; PushIDSeq : CosNotifyChannelAdmin.ProxyIDSeq; QoSPropSeq : CosNotification.QoSProperties; end record; --------------------------- -- Ensure_Initialization -- --------------------------- procedure Ensure_Initialization; pragma Inline (Ensure_Initialization); -- Ensure that the Mutexes are initialized T_Initialized : Boolean := False; Self_Mutex : Mutex_Access; procedure Ensure_Initialization is begin if not T_Initialized then Create (Self_Mutex); T_Initialized := True; end if; end Ensure_Initialization; -------------- -- Get_MyID -- -------------- function Get_MyID (Self : access Object) return CosNotifyChannelAdmin.AdminID is MyID : CosNotifyChannelAdmin.AdminID; begin Ensure_Initialization; pragma Debug (O ("get_myid in supplieradmin")); Enter (Self_Mutex); MyID := Self.X.Id; Leave (Self_Mutex); return MyID; end Get_MyID; ------------------- -- Get_MyChannel -- ------------------- function Get_MyChannel (Self : access Object) return CosNotifyChannelAdmin.EventChannel_Forward.Ref is MyChannel : CosNotifyChannelAdmin.EventChannel_Forward.Ref; begin Ensure_Initialization; pragma Debug (O ("get_mychannel in supplieradmin")); Enter (Self_Mutex); MyChannel := Convert.To_Forward (Self.X.Channel); Leave (Self_Mutex); return MyChannel; end Get_MyChannel; -------------------- -- Get_MyOperator -- -------------------- function Get_MyOperator (Self : access Object) return CosNotifyChannelAdmin.InterFilterGroupOperator is MyOperator : CosNotifyChannelAdmin.InterFilterGroupOperator; begin Ensure_Initialization; pragma Debug (O ("get_myoperator in supplieradmin")); Enter (Self_Mutex); MyOperator := Self.X.Op; Leave (Self_Mutex); return MyOperator; end Get_MyOperator; ------------------------- -- Get_Pull_Consumers -- ------------------------- function Get_Pull_Consumers (Self : access Object) return CosNotifyChannelAdmin.ProxyIDSeq is MySeq : CosNotifyChannelAdmin.ProxyIDSeq; begin Ensure_Initialization; pragma Debug (O ("get_pull_consumers in supplieradmin")); Enter (Self_Mutex); MySeq := Self.X.PullIDSeq; Leave (Self_Mutex); return MySeq; end Get_Pull_Consumers; ------------------------- -- Get_Push_Consumers -- ------------------------- function Get_Push_Consumers (Self : access Object) return CosNotifyChannelAdmin.ProxyIDSeq is MySeq : CosNotifyChannelAdmin.ProxyIDSeq; begin Ensure_Initialization; pragma Debug (O ("get_push_consumers in supplieradmin")); Enter (Self_Mutex); MySeq := Self.X.PushIDSeq; Leave (Self_Mutex); return MySeq; end Get_Push_Consumers; ------------------------ -- Get_Proxy_Consumer -- ------------------------ function Get_Proxy_Consumer (Self : access Object; Proxy_Id : CosNotifyChannelAdmin.ProxyID) return CosNotifyChannelAdmin.ProxyConsumer.Ref is MyConsumer : CosNotifyChannelAdmin.ProxyConsumer.Ref; SeqLen : CosNotifyChannelAdmin.ProxyID; begin Ensure_Initialization; pragma Debug (O ("get_proxy_consumer in supplieradmin")); Enter (Self_Mutex); SeqLen := CosNotifyChannelAdmin.ProxyID (AllProxies.Length (Self.X.AllPxs)); if Proxy_Id >= SeqLen then Leave (Self_Mutex); CosNotifyChannelAdmin.Helper.Raise_ProxyNotFound ((CORBA.IDL_Exception_Members with null record)); end if; -- NK How to search an element in Sequence -- Here we have to search in two sequences : Pushs and Pulls -- to find and return a suitable Proxy Ref Leave (Self_Mutex); return MyConsumer; end Get_Proxy_Consumer; --------------------------------------- -- Obtain_Notification_Pull_Consumer -- --------------------------------------- procedure Obtain_Notification_Pull_Consumer (Self : access Object; Ctype : CosNotifyChannelAdmin.ClientType; Proxy_Id : out CosNotifyChannelAdmin.ProxyID; Returns : out CosNotifyChannelAdmin.ProxyConsumer.Ref) is Channel : CosNotifyChannelAdmin.EventChannel.Impl.Object_Ptr; Consumer : CosNotifyChannelAdmin.ProxyPullConsumer. Impl.Object_Ptr; Seq_Consumer : CosNotifyChannelAdmin.SequenceProxyPullConsumer. Impl.Object_Ptr; Struct_Consumer : CosNotifyChannelAdmin.StructuredProxyPullConsumer. Impl.Object_Ptr; CRef : CosNotifyChannelAdmin.ProxyPullConsumer.Ref; Seq_CRef : CosNotifyChannelAdmin.SequenceProxyPullConsumer.Ref; Struct_CRef : CosNotifyChannelAdmin.StructuredProxyPullConsumer.Ref; MyRef : CosNotifyChannelAdmin.SupplierAdmin.Ref; Ptype : CosNotifyChannelAdmin.ProxyType; Res : CORBA.Boolean; begin Ensure_Initialization; pragma Debug (O ("obtain_notification_pull_consumer in supplieradmin")); Enter (Self_Mutex); Reference_To_Servant (Self.X.Channel, Servant (Channel)); Res := CosNotifyChannelAdmin.EventChannel.Impl. TestConsumerLimit (Channel); if Res = False then Leave (Self_Mutex); raise AdminLimitExceeded; end if; case Ctype is when ANY_EVENT => Ptype := PULL_ANY; Proxy_Id := CosNotifyChannelAdmin.ProxyID (AllProxies.Length (Self.X.AllPxs)); Servant_To_Reference (Servant (Self.X.This), MyRef); Consumer := CosNotifyChannelAdmin.ProxyPullConsumer.Impl.Create (MyRef, Self.X.QoSPropSeq, Ptype, Proxy_Id); Servant_To_Reference (Servant (Consumer), Returns); CRef := CosNotifyChannelAdmin.ProxyPullConsumer.Helper.To_Ref (Returns); PullConsumers.Append (Self.X.Pulls, CRef); Append (Self.X.PullIDSeq, Proxy_Id); AllProxies.Append (Self.X.AllPxs, CORBA.Long (Proxy_Id)); when STRUCTURED_EVENT => Ptype := PULL_STRUCTURED; Proxy_Id := CosNotifyChannelAdmin.ProxyID (AllProxies.Length (Self.X.AllPxs)); Servant_To_Reference (Servant (Self.X.This), MyRef); Struct_Consumer := CosNotifyChannelAdmin.StructuredProxyPullConsumer.Impl.Create (MyRef, Self.X.QoSPropSeq, Ptype, Proxy_Id); Servant_To_Reference (Servant (Struct_Consumer), Returns); Struct_CRef := CosNotifyChannelAdmin.StructuredProxyPullConsumer. Helper.To_Ref (Returns); StructuredPullConsumers.Append (Self.X.StructPulls, Struct_CRef); Append (Self.X.PullIDSeq, Proxy_Id); AllProxies.Append (Self.X.AllPxs, CORBA.Long (Proxy_Id)); when SEQUENCE_EVENT => Ptype := PULL_SEQUENCE; Proxy_Id := CosNotifyChannelAdmin.ProxyID (AllProxies.Length (Self.X.AllPxs)); Servant_To_Reference (Servant (Self.X.This), MyRef); Seq_Consumer := CosNotifyChannelAdmin.SequenceProxyPullConsumer.Impl.Create (MyRef, Self.X.QoSPropSeq, Ptype, Proxy_Id); Servant_To_Reference (Servant (Seq_Consumer), Returns); Seq_CRef := CosNotifyChannelAdmin.SequenceProxyPullConsumer. Helper.To_Ref (Returns); SequencePullConsumers.Append (Self.X.SequencePulls, Seq_CRef); Append (Self.X.PullIDSeq, Proxy_Id); AllProxies.Append (Self.X.AllPxs, CORBA.Long (Proxy_Id)); end case; Leave (Self_Mutex); end Obtain_Notification_Pull_Consumer; --------------------------------------- -- Obtain_Notification_Push_Consumer -- --------------------------------------- procedure Obtain_Notification_Push_Consumer (Self : access Object; Ctype : CosNotifyChannelAdmin.ClientType; Proxy_Id : out CosNotifyChannelAdmin.ProxyID; Returns : out CosNotifyChannelAdmin.ProxyConsumer.Ref) is Channel : CosNotifyChannelAdmin.EventChannel.Impl.Object_Ptr; Consumer : CosNotifyChannelAdmin.ProxyPushConsumer. Impl.Object_Ptr; Seq_Consumer : CosNotifyChannelAdmin.SequenceProxyPushConsumer. Impl.Object_Ptr; Struct_Consumer : CosNotifyChannelAdmin.StructuredProxyPushConsumer. Impl.Object_Ptr; CRef : CosNotifyChannelAdmin.ProxyPushConsumer.Ref; Seq_CRef : CosNotifyChannelAdmin.SequenceProxyPushConsumer.Ref; Struct_CRef : CosNotifyChannelAdmin.StructuredProxyPushConsumer.Ref; MyRef : CosNotifyChannelAdmin.SupplierAdmin.Ref; Ptype : CosNotifyChannelAdmin.ProxyType; Res : CORBA.Boolean; begin Ensure_Initialization; pragma Debug (O ("obtain_notification_push_consumer in supplieradmin")); Enter (Self_Mutex); Reference_To_Servant (Self.X.Channel, Servant (Channel)); Res := CosNotifyChannelAdmin.EventChannel.Impl. TestConsumerLimit (Channel); if Res = False then Leave (Self_Mutex); raise AdminLimitExceeded; end if; case Ctype is when ANY_EVENT => Ptype := PUSH_ANY; Proxy_Id := CosNotifyChannelAdmin.ProxyID (AllProxies.Length (Self.X.AllPxs)); Servant_To_Reference (Servant (Self.X.This), MyRef); Consumer := CosNotifyChannelAdmin.ProxyPushConsumer.Impl.Create (MyRef, Self.X.QoSPropSeq, Ptype, Proxy_Id); Servant_To_Reference (Servant (Consumer), Returns); CRef := CosNotifyChannelAdmin.ProxyPushConsumer.Helper.To_Ref (Returns); PushConsumers.Append (Self.X.Pushs, CRef); Append (Self.X.PushIDSeq, Proxy_Id); AllProxies.Append (Self.X.AllPxs, CORBA.Long (Proxy_Id)); when STRUCTURED_EVENT => Ptype := PUSH_STRUCTURED; Proxy_Id := CosNotifyChannelAdmin.ProxyID (AllProxies.Length (Self.X.AllPxs)); Servant_To_Reference (Servant (Self.X.This), MyRef); Struct_Consumer := CosNotifyChannelAdmin.StructuredProxyPushConsumer.Impl.Create (MyRef, Self.X.QoSPropSeq, Ptype, Proxy_Id); Servant_To_Reference (Servant (Struct_Consumer), Returns); Struct_CRef := CosNotifyChannelAdmin.StructuredProxyPushConsumer. Helper.To_Ref (Returns); StructuredPushConsumers.Append (Self.X.StructPushs, Struct_CRef); Append (Self.X.PushIDSeq, Proxy_Id); AllProxies.Append (Self.X.AllPxs, CORBA.Long (Proxy_Id)); when SEQUENCE_EVENT => Ptype := PUSH_SEQUENCE; Proxy_Id := CosNotifyChannelAdmin.ProxyID (AllProxies.Length (Self.X.AllPxs)); Servant_To_Reference (Servant (Self.X.This), MyRef); Seq_Consumer := CosNotifyChannelAdmin.SequenceProxyPushConsumer.Impl.Create (MyRef, Self.X.QoSPropSeq, Ptype, Proxy_Id); Servant_To_Reference (Servant (Seq_Consumer), Returns); Seq_CRef := CosNotifyChannelAdmin.SequenceProxyPushConsumer.Helper. To_Ref (Returns); SequencePushConsumers.Append (Self.X.SequencePushs, Seq_CRef); Append (Self.X.PushIDSeq, Proxy_Id); AllProxies.Append (Self.X.AllPxs, CORBA.Long (Proxy_Id)); end case; Leave (Self_Mutex); end Obtain_Notification_Push_Consumer; ------------- -- Destroy -- ------------- procedure Destroy (Self : access Object) is pragma Warnings (Off); -- WAG:3.14 pragma Unreferenced (Self); pragma Warnings (On); -- WAG:3.14 begin Ensure_Initialization; pragma Debug (O ("destroy in supplieradmin")); Enter (Self_Mutex); Leave (Self_Mutex); end Destroy; ------------- -- Get_QoS -- ------------- function Get_QoS (Self : access Object) return CosNotification.QoSProperties is MyQoS : CosNotification.QoSProperties; begin Ensure_Initialization; pragma Debug (O ("get_qos in supplieradmin")); Enter (Self_Mutex); MyQoS := Self.X.QoSPropSeq; Leave (Self_Mutex); return MyQoS; end Get_QoS; ------------- -- Set_QoS -- ------------- procedure Set_QoS (Self : access Object; QoS : CosNotification.QoSProperties) is Consumers : CORBA.Long; My_Ptr : SupplierAdmin.Impl.Object_Ptr; MyProp : CosNotification.Property; MyError : CosNotification.PropertyError; MyErrCode : CosNotification.QoSError_code; MyRange : CosNotification.PropertyRange; MyErrorSeq : CosNotification.PropertyErrorSeq; SeqLen : Integer; begin Ensure_Initialization; pragma Debug (O ("set_qos in supplieradmin")); Enter (Self_Mutex); My_Ptr := Self.X.This; Leave (Self_Mutex); Consumers := GetTotalConsumers (My_Ptr); SeqLen := Length (QoS); for Index in 1 .. SeqLen loop MyProp := Get_Element (QoS, Index); if MyProp.name = "EventReliability" then MyErrCode := UNAVAILABLE_PROPERTY; MyRange := (To_Any (CORBA.Short (0)), To_Any (CORBA.Short (0))); MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); elsif MyProp.name = "ConnectionReliability" then if Consumers > 0 then MyErrCode := UNAVAILABLE_PROPERTY; MyRange := (To_Any (CORBA.Short (0)), To_Any (CORBA.Short (0))); MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); elsif CORBA.Short'(From_Any (MyProp.value)) /= 0 and then CORBA.Short'(From_Any (MyProp.value)) /= 1 then MyErrCode := BAD_VALUE; MyRange := (To_Any (CORBA.Short (0)), To_Any (CORBA.Short (0))); MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); end if; elsif MyProp.name = "Priority" then if CORBA.Short'(From_Any (MyProp.value)) not in -32_767 .. 32_767 then MyErrCode := BAD_VALUE; MyRange := (To_Any (CORBA.Short (-32767)), To_Any (CORBA.Short (32767))); MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); end if; elsif MyProp.name = "StartTime" then MyErrCode := UNAVAILABLE_PROPERTY; MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); elsif MyProp.name = "StopTime" then MyErrCode := UNAVAILABLE_PROPERTY; MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); elsif MyProp.name = "Timeout" then MyErrCode := UNSUPPORTED_PROPERTY; MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); elsif MyProp.name = "OrderPolicy" then if CORBA.Short'(From_Any (MyProp.value)) /= 0 and then CORBA.Short'(From_Any (MyProp.value)) /= 1 and then CORBA.Short'(From_Any (MyProp.value)) /= 2 and then CORBA.Short'(From_Any (MyProp.value)) /= 3 then MyErrCode := BAD_VALUE; MyRange := (To_Any (CORBA.Short (0)), To_Any (CORBA.Short (3))); MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); end if; elsif MyProp.name = "DiscardPolicy" then if CORBA.Short'(From_Any (MyProp.value)) /= 0 and then CORBA.Short'(From_Any (MyProp.value)) /= 1 and then CORBA.Short'(From_Any (MyProp.value)) /= 2 and then CORBA.Short'(From_Any (MyProp.value)) /= 3 and then CORBA.Short'(From_Any (MyProp.value)) /= 4 then MyErrCode := BAD_VALUE; MyRange := (To_Any (CORBA.Short (0)), To_Any (CORBA.Short (4))); MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); end if; elsif MyProp.name = "MaximumBatchSize" then MyErrCode := UNSUPPORTED_PROPERTY; MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); elsif MyProp.name = "PacingInterval" then MyErrCode := UNSUPPORTED_PROPERTY; MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); elsif MyProp.name = "StartTimeSupported" then MyErrCode := UNSUPPORTED_PROPERTY; MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); elsif MyProp.name = "StopTimeSupported" then MyErrCode := UNSUPPORTED_PROPERTY; MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); elsif MyProp.name = "MaxEventsPerConsumer" then MyErrCode := UNSUPPORTED_PROPERTY; MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); else MyErrCode := BAD_PROPERTY; MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); end if; end loop; if Length (MyErrorSeq) > 0 then CosNotification.Helper.Raise_UnsupportedQoS ((CORBA.IDL_Exception_Members with qos_err => MyErrorSeq)); end if; SeqLen := Length (QoS); Enter (Self_Mutex); for Index in 1 .. SeqLen loop MyProp := Get_Element (QoS, Index); if MyProp.name = "ConnectionReliability" then Replace_Element (Self.X.QoSPropSeq, 2, MyProp); elsif MyProp.name = "Priority" then Replace_Element (Self.X.QoSPropSeq, 3, MyProp); elsif MyProp.name = "OrderPolicy" then Replace_Element (Self.X.QoSPropSeq, 4, MyProp); elsif MyProp.name = "DiscardPolicy" then Replace_Element (Self.X.QoSPropSeq, 5, MyProp); end if; end loop; Leave (Self_Mutex); end Set_QoS; ------------------ -- Validate_QoS -- ------------------ procedure Validate_QoS (Self : access Object; Required_QoS : CosNotification.QoSProperties; Available_QoS : out CosNotification.NamedPropertyRangeSeq) is Consumers : CORBA.Long; My_Ptr : SupplierAdmin.Impl.Object_Ptr; MyProp : CosNotification.Property; MyError : CosNotification.PropertyError; MyErrCode : CosNotification.QoSError_code; MyNamedRange : CosNotification.NamedPropertyRange; MyRange : CosNotification.PropertyRange; MyErrorSeq : CosNotification.PropertyErrorSeq; SeqLen : Integer; begin Ensure_Initialization; pragma Debug (O ("validate_qos in supplieradmin")); Enter (Self_Mutex); My_Ptr := Self.X.This; Leave (Self_Mutex); Consumers := GetTotalConsumers (My_Ptr); SeqLen := Length (Required_QoS); for Index in 1 .. SeqLen loop MyProp := Get_Element (Required_QoS, Index); if MyProp.name = "EventReliability" then MyErrCode := UNAVAILABLE_PROPERTY; MyRange := (To_Any (CORBA.Short (0)), To_Any (CORBA.Short (0))); MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); elsif MyProp.name = "ConnectionReliability" then if Consumers > 0 then MyErrCode := UNAVAILABLE_PROPERTY; MyRange := (To_Any (CORBA.Short (0)), To_Any (CORBA.Short (0))); MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); elsif CORBA.Short'(From_Any (MyProp.value)) /= 0 and then CORBA.Short'(From_Any (MyProp.value)) /= 1 then MyErrCode := BAD_VALUE; MyRange := (To_Any (CORBA.Short (0)), To_Any (CORBA.Short (0))); MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); end if; elsif MyProp.name = "Priority" then if CORBA.Short'(From_Any (MyProp.value)) not in -32_767 .. 32_767 then MyErrCode := BAD_VALUE; MyRange := (To_Any (CORBA.Short (-32767)), To_Any (CORBA.Short (32767))); MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); end if; elsif MyProp.name = "StartTime" then MyErrCode := UNAVAILABLE_PROPERTY; MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); elsif MyProp.name = "StopTime" then MyErrCode := UNAVAILABLE_PROPERTY; MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); elsif MyProp.name = "Timeout" then MyErrCode := UNSUPPORTED_PROPERTY; MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); elsif MyProp.name = "OrderPolicy" then if CORBA.Short'(From_Any (MyProp.value)) /= 0 and then CORBA.Short'(From_Any (MyProp.value)) /= 1 and then CORBA.Short'(From_Any (MyProp.value)) /= 2 and then CORBA.Short'(From_Any (MyProp.value)) /= 3 then MyErrCode := BAD_VALUE; MyRange := (To_Any (CORBA.Short (0)), To_Any (CORBA.Short (3))); MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); end if; elsif MyProp.name = "DiscardPolicy" then if CORBA.Short'(From_Any (MyProp.value)) /= 0 and then CORBA.Short'(From_Any (MyProp.value)) /= 1 and then CORBA.Short'(From_Any (MyProp.value)) /= 2 and then CORBA.Short'(From_Any (MyProp.value)) /= 3 and then CORBA.Short'(From_Any (MyProp.value)) /= 4 then MyErrCode := BAD_VALUE; MyRange := (To_Any (CORBA.Short (0)), To_Any (CORBA.Short (4))); MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); end if; elsif MyProp.name = "MaximumBatchSize" then MyErrCode := UNSUPPORTED_PROPERTY; MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); elsif MyProp.name = "PacingInterval" then MyErrCode := UNSUPPORTED_PROPERTY; MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); elsif MyProp.name = "StartTimeSupported" then MyErrCode := UNSUPPORTED_PROPERTY; MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); elsif MyProp.name = "StopTimeSupported" then MyErrCode := UNSUPPORTED_PROPERTY; MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); elsif MyProp.name = "MaxEventsPerConsumer" then MyErrCode := UNSUPPORTED_PROPERTY; MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); else MyErrCode := BAD_PROPERTY; MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); end if; end loop; if Length (MyErrorSeq) > 0 then CosNotification.Helper.Raise_UnsupportedQoS ((CORBA.IDL_Exception_Members with qos_err => MyErrorSeq)); end if; Enter (Self_Mutex); SeqLen := Length (Self.X.QoSPropSeq); for Index in 1 .. SeqLen loop MyProp := Get_Element (Self.X.QoSPropSeq, Index); if MyProp.name = "ConnectionReliability" then MyRange := (From_Any (MyProp.value), To_Any (CORBA.Short (0))); MyNamedRange := (MyProp.name, MyRange); Append (Available_QoS, MyNamedRange); elsif MyProp.name = "Priority" then MyRange := (To_Any (CORBA.Short (-32767)), To_Any (CORBA.Short (32767))); MyNamedRange := (MyProp.name, MyRange); Append (Available_QoS, MyNamedRange); elsif MyProp.name = "OrderPolicy" then MyRange := (To_Any (CORBA.Short (0)), To_Any (CORBA.Short (3))); MyNamedRange := (MyProp.name, MyRange); Append (Available_QoS, MyNamedRange); elsif MyProp.name = "DiscardPolicy" then MyRange := (To_Any (CORBA.Short (0)), To_Any (CORBA.Short (4))); MyNamedRange := (MyProp.name, MyRange); Append (Available_QoS, MyNamedRange); end if; end loop; Leave (Self_Mutex); end Validate_QoS; ------------------ -- Offer_Change -- ------------------ procedure Offer_Change (Self : access Object; Added : CosNotification.EventTypeSeq; Removed : CosNotification.EventTypeSeq) is pragma Warnings (Off); -- WAG:3.14 pragma Unreferenced (Self, Added, Removed); pragma Warnings (On); -- WAG:3.14 begin Ensure_Initialization; pragma Debug (O ("offer_change in supplieradmin")); Enter (Self_Mutex); Leave (Self_Mutex); end Offer_Change; ---------------- -- Add_Filter -- ---------------- function Add_Filter (Self : access Object; New_Filter : CosNotifyFilter.Filter.Ref) return CosNotifyFilter.FilterID is pragma Warnings (Off); -- WAG:3.14 pragma Unreferenced (Self, New_Filter); pragma Warnings (On); -- WAG:3.14 MyFilterID : CosNotifyFilter.FilterID; MyID : CORBA.Long; begin Ensure_Initialization; pragma Debug (O ("add_filter in supplieradmin")); Enter (Self_Mutex); Leave (Self_Mutex); MyID := 0; MyFilterID := CosNotifyFilter.FilterID (MyID); return MyFilterID; end Add_Filter; ------------------- -- Remove_Filter -- ------------------- procedure Remove_Filter (Self : access Object; Filter : CosNotifyFilter.FilterID) is pragma Warnings (Off); -- WAG:3.14 pragma Unreferenced (Self, Filter); pragma Warnings (On); -- WAG:3.14 begin Ensure_Initialization; pragma Debug (O ("remove_filter in supplieradmin")); Enter (Self_Mutex); Leave (Self_Mutex); end Remove_Filter; ---------------- -- Get_Filter -- ---------------- function Get_Filter (Self : access Object; Filter : CosNotifyFilter.FilterID) return CosNotifyFilter.Filter.Ref is pragma Warnings (Off); -- WAG:3.14 pragma Unreferenced (Self, Filter); pragma Warnings (On); -- WAG:3.14 MyFilter : CosNotifyFilter.Filter.Ref; begin Ensure_Initialization; pragma Debug (O ("get_filter in supplieradmin")); Enter (Self_Mutex); Leave (Self_Mutex); return MyFilter; end Get_Filter; --------------------- -- Get_All_Filters -- --------------------- function Get_All_Filters (Self : access Object) return CosNotifyFilter.FilterIDSeq is pragma Warnings (Off); -- WAG:3.14 pragma Unreferenced (Self); pragma Warnings (On); -- WAG:3.14 MyFilterSeq : CosNotifyFilter.FilterIDSeq; begin Ensure_Initialization; pragma Debug (O ("get_all_filters in supplieradmin")); Enter (Self_Mutex); Leave (Self_Mutex); return MyFilterSeq; end Get_All_Filters; ------------------------ -- Remove_All_Filters -- ------------------------ procedure Remove_All_Filters (Self : access Object) is pragma Warnings (Off); -- WAG:3.14 pragma Unreferenced (Self); pragma Warnings (On); -- WAG:3.14 begin Ensure_Initialization; pragma Debug (O ("remove_all_filters in supplieradmin")); Enter (Self_Mutex); Leave (Self_Mutex); end Remove_All_Filters; -------------------------- -- Obtain_Push_Consumer -- -------------------------- function Obtain_Push_Consumer (Self : access Object) return CosEventChannelAdmin.ProxyPushConsumer.Ref is pragma Warnings (Off); -- WAG:3.14 pragma Unreferenced (Self); pragma Warnings (On); -- WAG:3.14 MyProxy : CosEventChannelAdmin.ProxyPushConsumer.Ref; begin Ensure_Initialization; pragma Debug (O ("obtain_push_consumer in supplieradmin")); Enter (Self_Mutex); Leave (Self_Mutex); return MyProxy; end Obtain_Push_Consumer; -------------------------- -- Obtain_Pull_Consumer -- -------------------------- function Obtain_Pull_Consumer (Self : access Object) return CosEventChannelAdmin.ProxyPullConsumer.Ref is pragma Warnings (Off); -- WAG:3.14 pragma Unreferenced (Self); pragma Warnings (On); -- WAG:3.14 MyProxy : CosEventChannelAdmin.ProxyPullConsumer.Ref; begin Ensure_Initialization; pragma Debug (O ("obtain_pull_consumer in supplieradmin")); Enter (Self_Mutex); Leave (Self_Mutex); return MyProxy; end Obtain_Pull_Consumer; ------------ -- Create -- ------------ function Create (Channel : CosNotifyChannelAdmin.EventChannel.Ref; Initial_QoS : CosNotification.QoSProperties; MyID : CosNotifyChannelAdmin.AdminID; MyOp : CosNotifyChannelAdmin.InterFilterGroupOperator := AND_OP) return Object_Ptr is Supplier : Object_Ptr; My_Ref : CosNotifyChannelAdmin.SupplierAdmin.Ref; begin pragma Debug (O ("create supplieradmin")); Supplier := new Object; Supplier.X := new Supplier_Admin_Record; Supplier.X.This := Supplier; Supplier.X.Channel := Channel; Supplier.X.Id := MyID; Supplier.X.Op := MyOp; Supplier.X.QoSPropSeq := Initial_QoS; Initiate_Servant (Servant (Supplier), My_Ref); return Supplier; end Create; ----------------------- -- GetTotalConsumers -- ----------------------- function GetTotalConsumers (Self : access Object) return CORBA.Long is MyCount : CORBA.Long; begin Ensure_Initialization; pragma Debug (O ("gettotalconsumers from supplieradmin")); MyCount := CORBA.Long (AllProxies.Length (Self.X.AllPxs)); return MyCount; end GetTotalConsumers; ---------- -- Post -- ---------- procedure Post (Self : access Object; Data : CORBA.Any) is Channel : CosNotifyChannelAdmin.EventChannel.Impl.Object_Ptr; begin Ensure_Initialization; pragma Debug (O ("post new data from supplieradmin to eventchannel")); Enter (Self_Mutex); Reference_To_Servant (Self.X.Channel, Servant (Channel)); Leave (Self_Mutex); CosNotifyChannelAdmin.EventChannel.Impl.Post (Channel, Data); end Post; --------------------- -- Structured_Post -- --------------------- procedure Structured_Post (Self : access Object; Notification : CosNotification.StructuredEvent) is Channel : CosNotifyChannelAdmin.EventChannel.Impl.Object_Ptr; begin Ensure_Initialization; pragma Debug (O ("post new structured data from supplieradmin to eventchannel")); Enter (Self_Mutex); Reference_To_Servant (Self.X.Channel, Servant (Channel)); Leave (Self_Mutex); CosNotifyChannelAdmin.EventChannel.Impl.Structured_Post (Channel, Notification); end Structured_Post; ------------------- -- Sequence_Post -- ------------------- procedure Sequence_Post (Self : access Object; Notifications : CosNotification.EventBatch) is Channel : CosNotifyChannelAdmin.EventChannel.Impl.Object_Ptr; begin Ensure_Initialization; pragma Debug (O ("post new sequence of structured data from " & "supplieradmin to eventchannel")); Enter (Self_Mutex); Reference_To_Servant (Self.X.Channel, Servant (Channel)); Leave (Self_Mutex); CosNotifyChannelAdmin.EventChannel.Impl.Sequence_Post (Channel, Notifications); end Sequence_Post; end CosNotifyChannelAdmin.SupplierAdmin.Impl; polyorb-2.8~20110207.orig/cos/notification/cosnotifycomm-pushconsumer-impl.ads0000644000175000017500000000674111750740337026744 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- C O S N O T I F Y C O M M . P U S H C O N S U M E R . I M P L -- -- -- -- S p e c -- -- -- -- Copyright (C) 2003-2008, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by ACT Europe. -- -- (email: sales@act-europe.fr) -- -- -- ------------------------------------------------------------------------------ with CORBA; with PortableServer; with CosNotifyChannelAdmin.ProxyPushSupplier; package CosNotifyComm.PushConsumer.Impl is type Object is new PortableServer.Servant_Base with private; type Object_Ptr is access all Object'Class; -- Inherited IDL operations from CosNotifyComm::NotifyPublish procedure Offer_Change (Self : access Object; Added : CosNotification.EventTypeSeq; Removed : CosNotification.EventTypeSeq); -- Inherited IDL operations from CosEventComm::PushConsumer procedure Push (Self : access Object; Data : CORBA.Any); procedure Disconnect_Push_Consumer (Self : access Object); ---------------------- -- PolyORB specific -- ---------------------- function Create return Object_Ptr; procedure Connect_Any_Proxy_Push_Supplier (Self : access Object; Proxy : CosNotifyChannelAdmin.ProxyPushSupplier.Ref); -- Call by application to connect object with proxy function Pull (Self : access Object) return CORBA.Any; -- Call by application to consume an event procedure Try_Pull (Self : access Object; Done : out CORBA.Boolean; Data : out CORBA.Any); -- Call by application to try to consume an event private type Push_Consumer_Record; type Push_Consumer_Access is access Push_Consumer_Record; type Object is new PortableServer.Servant_Base with record X : Push_Consumer_Access; end record; end CosNotifyComm.PushConsumer.Impl; polyorb-2.8~20110207.orig/cos/notification/cosnotifycomm-pullsupplier-impl.ads0000644000175000017500000000717111750740337026747 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- C O S N O T I F Y C O M M . P U L L S U P P L I E R . I M P L -- -- -- -- S p e c -- -- -- -- Copyright (C) 2003-2008, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by ACT Europe. -- -- (email: sales@act-europe.fr) -- -- -- ------------------------------------------------------------------------------ with PortableServer; with CosNotifyChannelAdmin.ProxyPullConsumer; package CosNotifyComm.PullSupplier.Impl is type Object is new PortableServer.Servant_Base with private; type Object_Ptr is access all Object'Class; -- Inherited IDL operations from CosNotifyComm::NotifySubscribe procedure Subscription_Change (Self : access Object; Added : CosNotification.EventTypeSeq; Removed : CosNotification.EventTypeSeq); -- Inherited IDL operations from CosEventComm::PullSupplier function Pull (Self : access Object) return CORBA.Any; -- Call by proxy to pull an event procedure Try_Pull (Self : access Object; Has_Event : out CORBA.Boolean; Returns : out CORBA.Any); -- Call by proxy to try to pull an event procedure Disconnect_Pull_Supplier (Self : access Object); -- Call by proxy to disconnect ---------------------- -- PolyORB specific -- ---------------------- procedure Connect_Any_Proxy_Pull_Consumer (Self : access Object; Proxy : CosNotifyChannelAdmin.ProxyPullConsumer.Ref); -- Call by application to connect object with proxy function Create return Object_Ptr; -- Call by application to create an object and activate servant procedure Push (Self : access Object; Data : CORBA.Any); -- Call by application to produce an event private type Pull_Supplier_Record; type Pull_Supplier_Access is access Pull_Supplier_Record; type Object is new PortableServer.Servant_Base with record X : Pull_Supplier_Access; end record; end CosNotifyComm.PullSupplier.Impl; polyorb-2.8~20110207.orig/cos/notification/cosnotifyfilter-filteradmin-impl.adb0000644000175000017500000001450411750740337027014 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- C O S N O T I F Y F I L T E R . F I L T E R A D M I N . I M P L -- -- -- -- B o d y -- -- -- -- Copyright (C) 2003-2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with PolyORB.CORBA_P.Server_Tools; with PolyORB.Log; with PolyORB.Tasking.Mutexes; with CosNotifyFilter.FilterAdmin.Skel; pragma Warnings (Off, CosNotifyFilter.FilterAdmin.Skel); package body CosNotifyFilter.FilterAdmin.Impl is use PolyORB.CORBA_P.Server_Tools; use PolyORB.Tasking.Mutexes; use PolyORB.Log; package L is new PolyORB.Log.Facility_Log ("filteradmin"); procedure O (Message : Standard.String; Level : Log_Level := Debug) renames L.Output; function C (Level : Log_Level := Debug) return Boolean renames L.Enabled; pragma Unreferenced (C); -- For conditional pragma Debug type Filter_Admin_Record is record This : Object_Ptr; end record; --------------------------- -- Ensure_Initialization -- --------------------------- procedure Ensure_Initialization; pragma Inline (Ensure_Initialization); -- Ensure that the Mutexes are initialized T_Initialized : Boolean := False; Self_Mutex : Mutex_Access; procedure Ensure_Initialization is begin if not T_Initialized then Create (Self_Mutex); T_Initialized := True; end if; end Ensure_Initialization; ---------------- -- Add_Filter -- ---------------- function Add_Filter (Self : access Object; New_Filter : CosNotifyFilter.Filter.Ref) return CosNotifyFilter.FilterID is pragma Warnings (Off); -- WAG:3.14 pragma Unreferenced (Self, New_Filter); pragma Warnings (On); -- WAG:3.14 MyFilterID : CosNotifyFilter.FilterID; MyID : CORBA.Long; begin pragma Debug (O ("add_filter in filteradmin")); Ensure_Initialization; Enter (Self_Mutex); Leave (Self_Mutex); MyID := 0; MyFilterID := CosNotifyFilter.FilterID (MyID); return MyFilterID; end Add_Filter; ------------------- -- Remove_Filter -- ------------------- procedure Remove_Filter (Self : access Object; Filter : CosNotifyFilter.FilterID) is pragma Warnings (Off); -- WAG:3.14 pragma Unreferenced (Self, Filter); pragma Warnings (On); -- WAG:3.14 begin pragma Debug (O ("remove_filter in filteradmin")); Ensure_Initialization; Enter (Self_Mutex); Leave (Self_Mutex); end Remove_Filter; ---------------- -- Get_Filter -- ---------------- function Get_Filter (Self : access Object; Filter : CosNotifyFilter.FilterID) return CosNotifyFilter.Filter.Ref is pragma Warnings (Off); -- WAG:3.14 pragma Unreferenced (Self, Filter); pragma Warnings (On); -- WAG:3.14 MyFilter : CosNotifyFilter.Filter.Ref; begin pragma Debug (O ("get_filter in filteradmin")); Ensure_Initialization; Enter (Self_Mutex); Leave (Self_Mutex); return MyFilter; end Get_Filter; --------------------- -- Get_All_Filters -- --------------------- function Get_All_Filters (Self : access Object) return CosNotifyFilter.FilterIDSeq is pragma Warnings (Off); -- WAG:3.14 pragma Unreferenced (Self); pragma Warnings (On); -- WAG:3.14 MyFilterSeq : CosNotifyFilter.FilterIDSeq; begin pragma Debug (O ("get_all_filters in filteradmin")); Ensure_Initialization; Enter (Self_Mutex); Leave (Self_Mutex); return MyFilterSeq; end Get_All_Filters; ------------------------ -- Remove_All_Filters -- ------------------------ procedure Remove_All_Filters (Self : access Object) is pragma Warnings (Off); -- WAG:3.14 pragma Unreferenced (Self); pragma Warnings (On); -- WAG:3.14 begin pragma Debug (O ("remove_all_filters in filteradmin")); Ensure_Initialization; Enter (Self_Mutex); Leave (Self_Mutex); end Remove_All_Filters; ------------ -- Create -- ------------ function Create return Object_Ptr is FilterAdmin : Object_Ptr; My_Ref : CosNotifyFilter.FilterAdmin.Ref; begin pragma Debug (O ("create filteradmin")); FilterAdmin := new Object; FilterAdmin.X := new Filter_Admin_Record; FilterAdmin.X.This := FilterAdmin; Initiate_Servant (PortableServer.Servant (FilterAdmin), My_Ref); return FilterAdmin; end Create; end CosNotifyFilter.FilterAdmin.Impl; polyorb-2.8~20110207.orig/cos/notification/cosnotifychanneladmin-eventchannel-impl.adb0000644000175000017500000015036011750740337030325 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- COSNOTIFYCHANNELADMIN.EVENTCHANNEL.IMPL -- -- -- -- B o d y -- -- -- -- Copyright (C) 2003-2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with CosNotification; with CosNotification.Helper; with CosNotifyChannelAdmin.ConsumerAdmin.Impl; with CosNotifyChannelAdmin.Helper; with CosNotifyChannelAdmin.SupplierAdmin.Impl; with PolyORB.CORBA_P.Server_Tools; with PolyORB.Log; with PolyORB.Tasking.Mutexes; with CosNotifyChannelAdmin.EventChannel.Skel; pragma Warnings (Off, CosNotifyChannelAdmin.EventChannel.Skel); package body CosNotifyChannelAdmin.EventChannel.Impl is use IDL_SEQUENCE_CosNotifyChannelAdmin_AdminID; use CosNotification; use IDL_SEQUENCE_CosNotification_Property; use IDL_SEQUENCE_CosNotification_PropertyError; use IDL_SEQUENCE_CosNotification_NamedPropertyRange; use CORBA; use CORBA.TypeCode; use PortableServer; use PolyORB.CORBA_P.Server_Tools; use PolyORB.Tasking.Mutexes; use PolyORB.Log; package L is new PolyORB.Log.Facility_Log ("eventchannel"); procedure O (Message : Standard.String; Level : Log_Level := Debug) renames L.Output; function C (Level : Log_Level := Debug) return Boolean renames L.Enabled; pragma Unreferenced (C); -- For conditional pragma Debug package Convert is new EventChannelFactory_Forward.Convert (CosNotifyChannelAdmin.EventChannelFactory.Ref); package ConsumerAdmins is new CORBA.Sequences.Unbounded (CosNotifyChannelAdmin.ConsumerAdmin.Ref); package SupplierAdmins is new CORBA.Sequences.Unbounded (CosNotifyChannelAdmin.SupplierAdmin.Ref); type Event_Channel_Record is record This : Object_Ptr; AdmPropSeq : CosNotification.AdminProperties; Consumer : CosNotifyChannelAdmin.ConsumerAdmin.Ref; Supplier : CosNotifyChannelAdmin.SupplierAdmin.Ref; Consumers : ConsumerAdmins.Sequence; Suppliers : SupplierAdmins.Sequence; CIDSeq : CosNotifyChannelAdmin.AdminIDSeq; SIDSeq : CosNotifyChannelAdmin.AdminIDSeq; Factory : CosNotifyChannelAdmin.EventChannelFactory.Ref; QoSPropSeq : CosNotification.QoSProperties; end record; --------------------------- -- Ensure_Initialization -- --------------------------- procedure Ensure_Initialization; pragma Inline (Ensure_Initialization); -- Ensure that the Mutexes are initialized T_Initialized : Boolean := False; Self_Mutex : Mutex_Access; procedure Ensure_Initialization is begin if not T_Initialized then Create (Self_Mutex); T_Initialized := True; end if; end Ensure_Initialization; ------------------- -- Get_MyFactory -- ------------------- function Get_MyFactory (Self : access Object) return CosNotifyChannelAdmin.EventChannelFactory_Forward.Ref is MyFactory : CosNotifyChannelAdmin.EventChannelFactory_Forward.Ref; begin pragma Debug (O ("get_myfactory in eventchannel")); Ensure_Initialization; Enter (Self_Mutex); MyFactory := Convert.To_Forward (Self.X.Factory); Leave (Self_Mutex); return MyFactory; end Get_MyFactory; -------------------------------- -- Get_Default_Consumer_Admin -- -------------------------------- function Get_Default_Consumer_Admin (Self : access Object) return CosNotifyChannelAdmin.ConsumerAdmin.Ref is MyAdmin : CosNotifyChannelAdmin.ConsumerAdmin.Ref; begin pragma Debug (O ("get_default_consumer_admin in eventchannel")); Ensure_Initialization; Enter (Self_Mutex); MyAdmin := Self.X.Consumer; Leave (Self_Mutex); return MyAdmin; end Get_Default_Consumer_Admin; -------------------------------- -- Get_Default_Supplier_Admin -- -------------------------------- function Get_Default_Supplier_Admin (Self : access Object) return CosNotifyChannelAdmin.SupplierAdmin.Ref is MyAdmin : CosNotifyChannelAdmin.SupplierAdmin.Ref; begin pragma Debug (O ("get_default_supplier_admin in eventchannel")); Ensure_Initialization; Enter (Self_Mutex); MyAdmin := Self.X.Supplier; Leave (Self_Mutex); return MyAdmin; end Get_Default_Supplier_Admin; -------------------------------- -- Get_Default_Filter_Factory -- -------------------------------- function Get_Default_Filter_Factory (Self : access Object) return CosNotifyFilter.FilterFactory.Ref is pragma Warnings (Off); -- WAG:3.14 pragma Unreferenced (Self); pragma Warnings (On); -- WAG:3.14 MyFilter : CosNotifyFilter.FilterFactory.Ref; begin pragma Debug (O ("get_default_filter_factory in eventchannel")); Ensure_Initialization; Enter (Self_Mutex); Leave (Self_Mutex); return MyFilter; end Get_Default_Filter_Factory; ----------------------- -- New_For_Consumers -- ----------------------- procedure New_For_Consumers (Self : access Object; Op : CosNotifyChannelAdmin.InterFilterGroupOperator; Id : out CosNotifyChannelAdmin.AdminID; Returns : out CosNotifyChannelAdmin.ConsumerAdmin.Ref) is Consumer : CosNotifyChannelAdmin.ConsumerAdmin.Impl.Object_Ptr; MyRef : CosNotifyChannelAdmin.EventChannel.Ref; begin pragma Debug (O ("new_for_consumers in eventchannel")); Ensure_Initialization; Enter (Self_Mutex); Id := CosNotifyChannelAdmin.AdminID (ConsumerAdmins.Length (Self.X.Consumers)); Append (Self.X.CIDSeq, Id); Servant_To_Reference (Servant (Self.X.This), MyRef); Consumer := CosNotifyChannelAdmin.ConsumerAdmin.Impl.Create (MyRef, Self.X.QoSPropSeq, Id, Op); Servant_To_Reference (Servant (Consumer), Returns); ConsumerAdmins.Append (Self.X.Consumers, Returns); Leave (Self_Mutex); end New_For_Consumers; ----------------------- -- New_For_Suppliers -- ----------------------- procedure New_For_Suppliers (Self : access Object; Op : CosNotifyChannelAdmin.InterFilterGroupOperator; Id : out CosNotifyChannelAdmin.AdminID; Returns : out CosNotifyChannelAdmin.SupplierAdmin.Ref) is Supplier : CosNotifyChannelAdmin.SupplierAdmin.Impl.Object_Ptr; MyRef : CosNotifyChannelAdmin.EventChannel.Ref; begin pragma Debug (O ("new_for_suppliers in eventchannel")); Ensure_Initialization; Enter (Self_Mutex); Id := CosNotifyChannelAdmin.AdminID (SupplierAdmins.Length (Self.X.Suppliers)); Append (Self.X.SIDSeq, Id); Servant_To_Reference (Servant (Self.X.This), MyRef); Supplier := CosNotifyChannelAdmin.SupplierAdmin.Impl.Create (MyRef, Self.X.QoSPropSeq, Id, Op); Servant_To_Reference (Servant (Supplier), Returns); SupplierAdmins.Append (Self.X.Suppliers, Returns); Leave (Self_Mutex); end New_For_Suppliers; ----------------------- -- Get_ConsumerAdmin -- ----------------------- function Get_ConsumerAdmin (Self : access Object; Id : CosNotifyChannelAdmin.AdminID) return CosNotifyChannelAdmin.ConsumerAdmin.Ref is MyConsumerAdmin : CosNotifyChannelAdmin.ConsumerAdmin.Ref; SeqLen : CosNotifyChannelAdmin.AdminID; begin pragma Debug (O ("get_consumeradmin in eventchannel")); Ensure_Initialization; Enter (Self_Mutex); SeqLen := CosNotifyChannelAdmin.AdminID (Length (Self.X.CIDSeq)); if Id >= SeqLen then Leave (Self_Mutex); CosNotifyChannelAdmin.Helper.Raise_AdminNotFound ((CORBA.IDL_Exception_Members with null record)); end if; -- AdminID of the ConsumerAdmin will always be 1 less than -- the index number of its ConsumerAdmin Sequence as the -- first consumeradmin created must have the AdminID of 0 MyConsumerAdmin := ConsumerAdmins.Get_Element (Self.X.Consumers, Integer (Id + 1)); Leave (Self_Mutex); return MyConsumerAdmin; end Get_ConsumerAdmin; ----------------------- -- Get_SupplierAdmin -- ----------------------- function Get_SupplierAdmin (Self : access Object; Id : CosNotifyChannelAdmin.AdminID) return CosNotifyChannelAdmin.SupplierAdmin.Ref is MySupplierAdmin : CosNotifyChannelAdmin.SupplierAdmin.Ref; SeqLen : CosNotifyChannelAdmin.AdminID; begin pragma Debug (O ("get_supplieradmin in eventchannel")); Ensure_Initialization; Enter (Self_Mutex); SeqLen := CosNotifyChannelAdmin.AdminID (Length (Self.X.SIDSeq)); if Id >= SeqLen then Leave (Self_Mutex); CosNotifyChannelAdmin.Helper.Raise_AdminNotFound ((CORBA.IDL_Exception_Members with null record)); end if; -- AdminID of the SupplierAdmin will always be 1 less than -- the index number of its SupplierAdmin Sequence as the -- first supplieradmin created must have the AdminID of 0 MySupplierAdmin := SupplierAdmins.Get_Element (Self.X.Suppliers, Integer (Id + 1)); Leave (Self_Mutex); return MySupplierAdmin; end Get_SupplierAdmin; ---------------------------- -- Get_All_ConsumerAdmins -- ---------------------------- function Get_All_ConsumerAdmins (Self : access Object) return CosNotifyChannelAdmin.AdminIDSeq is MySeq : CosNotifyChannelAdmin.AdminIDSeq; begin pragma Debug (O ("get_all_consumeradmins in eventchannel")); Ensure_Initialization; Enter (Self_Mutex); MySeq := Self.X.CIDSeq; Leave (Self_Mutex); return MySeq; end Get_All_ConsumerAdmins; ---------------------------- -- Get_All_SupplierAdmins -- ---------------------------- function Get_All_SupplierAdmins (Self : access Object) return CosNotifyChannelAdmin.AdminIDSeq is MySeq : CosNotifyChannelAdmin.AdminIDSeq; begin pragma Debug (O ("get_all_supplieradmins in eventchannel")); Ensure_Initialization; Enter (Self_Mutex); MySeq := Self.X.SIDSeq; Leave (Self_Mutex); return MySeq; end Get_All_SupplierAdmins; ------------- -- Get_QoS -- ------------- function Get_QoS (Self : access Object) return CosNotification.QoSProperties is MyProp : CosNotification.QoSProperties; begin pragma Debug (O ("get_qos in eventchannel")); Ensure_Initialization; Enter (Self_Mutex); MyProp := Self.X.QoSPropSeq; Leave (Self_Mutex); return MyProp; end Get_QoS; ------------- -- Set_QoS -- ------------- procedure Set_QoS (Self : access Object; QoS : CosNotification.QoSProperties) is Consumers : CORBA.Long; My_Ptr : EventChannel.Impl.Object_Ptr; MyProp : CosNotification.Property; MyError : CosNotification.PropertyError; MyErrCode : CosNotification.QoSError_code; MyRange : CosNotification.PropertyRange; MyErrorSeq : CosNotification.PropertyErrorSeq; SeqLen : Integer; Suppliers : CORBA.Long; begin pragma Debug (O ("set_qos in eventchannel")); Ensure_Initialization; Enter (Self_Mutex); My_Ptr := Self.X.This; Leave (Self_Mutex); Consumers := GetTotalConsumers (My_Ptr); Suppliers := GetTotalSuppliers (My_Ptr); SeqLen := Length (QoS); for Index in 1 .. SeqLen loop MyProp := Get_Element (QoS, Index); if MyProp.name = "EventReliability" then if CORBA.Short'(From_Any (MyProp.value)) /= 0 and then CORBA.Short'(From_Any (MyProp.value)) /= 1 then MyErrCode := BAD_VALUE; MyRange := (To_Any (CORBA.Short (0)), To_Any (CORBA.Short (0))); MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); end if; elsif MyProp.name = "ConnectionReliability" then if Consumers > 0 or else Suppliers > 0 then MyErrCode := UNAVAILABLE_PROPERTY; MyRange := (To_Any (CORBA.Short (0)), To_Any (CORBA.Short (0))); MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); elsif CORBA.Short'(From_Any (MyProp.value)) /= 0 and then CORBA.Short'(From_Any (MyProp.value)) /= 1 then MyErrCode := BAD_VALUE; MyRange := (To_Any (CORBA.Short (0)), To_Any (CORBA.Short (0))); MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); end if; elsif MyProp.name = "Priority" then if CORBA.Short'(From_Any (MyProp.value)) not in -32_767 .. 32_767 then MyErrCode := BAD_VALUE; MyRange := (To_Any (CORBA.Short (-32767)), To_Any (CORBA.Short (32767))); MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); end if; elsif MyProp.name = "StartTime" then MyErrCode := UNAVAILABLE_PROPERTY; MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); elsif MyProp.name = "StopTime" then MyErrCode := UNAVAILABLE_PROPERTY; MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); elsif MyProp.name = "Timeout" then MyErrCode := UNSUPPORTED_PROPERTY; MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); elsif MyProp.name = "OrderPolicy" then if CORBA.Short'(From_Any (MyProp.value)) /= 0 and then CORBA.Short'(From_Any (MyProp.value)) /= 1 and then CORBA.Short'(From_Any (MyProp.value)) /= 2 and then CORBA.Short'(From_Any (MyProp.value)) /= 3 then MyErrCode := BAD_VALUE; MyRange := (To_Any (CORBA.Short (0)), To_Any (CORBA.Short (3))); MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); end if; elsif MyProp.name = "DiscardPolicy" then if CORBA.Short'(From_Any (MyProp.value)) /= 0 and then CORBA.Short'(From_Any (MyProp.value)) /= 1 and then CORBA.Short'(From_Any (MyProp.value)) /= 2 and then CORBA.Short'(From_Any (MyProp.value)) /= 3 and then CORBA.Short'(From_Any (MyProp.value)) /= 4 then MyErrCode := BAD_VALUE; MyRange := (To_Any (CORBA.Short (0)), To_Any (CORBA.Short (4))); MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); end if; elsif MyProp.name = "MaximumBatchSize" then MyErrCode := UNSUPPORTED_PROPERTY; MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); elsif MyProp.name = "PacingInterval" then MyErrCode := UNSUPPORTED_PROPERTY; MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); elsif MyProp.name = "StartTimeSupported" then MyErrCode := UNSUPPORTED_PROPERTY; MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); elsif MyProp.name = "StopTimeSupported" then MyErrCode := UNSUPPORTED_PROPERTY; MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); elsif MyProp.name = "MaxEventsPerConsumer" then MyErrCode := UNSUPPORTED_PROPERTY; MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); else MyErrCode := BAD_PROPERTY; MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); end if; end loop; if Length (MyErrorSeq) > 0 then CosNotification.Helper.Raise_UnsupportedQoS ((CORBA.IDL_Exception_Members with qos_err => MyErrorSeq)); end if; SeqLen := Length (QoS); Enter (Self_Mutex); for Index in 1 .. SeqLen loop MyProp := Get_Element (QoS, Index); if MyProp.name = "EventReliability" then Replace_Element (Self.X.QoSPropSeq, 1, MyProp); elsif MyProp.name = "ConnectionReliability" then Replace_Element (Self.X.QoSPropSeq, 2, MyProp); elsif MyProp.name = "Priority" then Replace_Element (Self.X.QoSPropSeq, 3, MyProp); elsif MyProp.name = "OrderPolicy" then Replace_Element (Self.X.QoSPropSeq, 4, MyProp); else Replace_Element (Self.X.QoSPropSeq, 5, MyProp); end if; end loop; Leave (Self_Mutex); end Set_QoS; ------------------ -- Validate_QoS -- ------------------ procedure Validate_QoS (Self : access Object; Required_QoS : CosNotification.QoSProperties; Available_QoS : out CosNotification.NamedPropertyRangeSeq) is Consumers : CORBA.Long; My_Ptr : EventChannel.Impl.Object_Ptr; MyProp : CosNotification.Property; MyError : CosNotification.PropertyError; MyErrCode : CosNotification.QoSError_code; MyNamedRange : CosNotification.NamedPropertyRange; MyRange : CosNotification.PropertyRange; MyErrorSeq : CosNotification.PropertyErrorSeq; SeqLen : Integer; Suppliers : CORBA.Long; begin pragma Debug (O ("validate_qos in eventchannel")); Ensure_Initialization; Enter (Self_Mutex); My_Ptr := Self.X.This; Leave (Self_Mutex); Consumers := GetTotalConsumers (My_Ptr); Suppliers := GetTotalSuppliers (My_Ptr); SeqLen := Length (Required_QoS); for Index in 1 .. SeqLen loop MyProp := Get_Element (Required_QoS, Index); if MyProp.name = "EventReliability" then if CORBA.Short'(From_Any (MyProp.value)) /= 0 and then CORBA.Short'(From_Any (MyProp.value)) /= 1 then MyErrCode := BAD_VALUE; MyRange := (To_Any (CORBA.Short (0)), To_Any (CORBA.Short (0))); MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); end if; elsif MyProp.name = "ConnectionReliability" then if Consumers > 0 or Suppliers > 0 then MyErrCode := UNAVAILABLE_PROPERTY; MyRange := (To_Any (CORBA.Short (0)), To_Any (CORBA.Short (0))); MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); elsif CORBA.Short'(From_Any (MyProp.value)) /= 0 and then CORBA.Short'(From_Any (MyProp.value)) /= 1 then MyErrCode := BAD_VALUE; MyRange := (To_Any (CORBA.Short (0)), To_Any (CORBA.Short (0))); MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); end if; elsif MyProp.name = "Priority" then if CORBA.Short'(From_Any (MyProp.value)) not in -32_767 .. 32_767 then MyErrCode := BAD_VALUE; MyRange := (To_Any (CORBA.Short (-32767)), To_Any (CORBA.Short (32767))); MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); end if; elsif MyProp.name = "StartTime" then MyErrCode := UNAVAILABLE_PROPERTY; MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); elsif MyProp.name = "StopTime" then MyErrCode := UNAVAILABLE_PROPERTY; MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); elsif MyProp.name = "Timeout" then MyErrCode := UNSUPPORTED_PROPERTY; MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); elsif MyProp.name = "OrderPolicy" then if CORBA.Short'(From_Any (MyProp.value)) /= 0 and then CORBA.Short'(From_Any (MyProp.value)) /= 1 and then CORBA.Short'(From_Any (MyProp.value)) /= 2 and then CORBA.Short'(From_Any (MyProp.value)) /= 3 then MyErrCode := BAD_VALUE; MyRange := (To_Any (CORBA.Short (0)), To_Any (CORBA.Short (3))); MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); end if; elsif MyProp.name = "DiscardPolicy" then if CORBA.Short'(From_Any (MyProp.value)) /= 0 and then CORBA.Short'(From_Any (MyProp.value)) /= 1 and then CORBA.Short'(From_Any (MyProp.value)) /= 2 and then CORBA.Short'(From_Any (MyProp.value)) /= 3 and then CORBA.Short'(From_Any (MyProp.value)) /= 4 then MyErrCode := BAD_VALUE; MyRange := (To_Any (CORBA.Short (0)), To_Any (CORBA.Short (4))); MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); end if; elsif MyProp.name = "MaximumBatchSize" then MyErrCode := UNSUPPORTED_PROPERTY; MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); elsif MyProp.name = "PacingInterval" then MyErrCode := UNSUPPORTED_PROPERTY; MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); elsif MyProp.name = "StartTimeSupported" then MyErrCode := UNSUPPORTED_PROPERTY; MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); elsif MyProp.name = "StopTimeSupported" then MyErrCode := UNSUPPORTED_PROPERTY; MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); elsif MyProp.name = "MaxEventsPerConsumer" then MyErrCode := UNSUPPORTED_PROPERTY; MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); else MyErrCode := BAD_PROPERTY; MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); end if; end loop; if Length (MyErrorSeq) > 0 then CosNotification.Helper.Raise_UnsupportedQoS ((CORBA.IDL_Exception_Members with qos_err => MyErrorSeq)); end if; Enter (Self_Mutex); SeqLen := Length (Self.X.QoSPropSeq); for Index in 1 .. SeqLen loop MyProp := Get_Element (Self.X.QoSPropSeq, Index); if MyProp.name = "EventReliability" then MyRange := (From_Any (MyProp.value), To_Any (CORBA.Short (0))); MyNamedRange := (MyProp.name, MyRange); Append (Available_QoS, MyNamedRange); elsif MyProp.name = "ConnectionReliability" then MyRange := (From_Any (MyProp.value), To_Any (CORBA.Short (0))); MyNamedRange := (MyProp.name, MyRange); Append (Available_QoS, MyNamedRange); elsif MyProp.name = "Priority" then MyRange := (To_Any (CORBA.Short (-32767)), To_Any (CORBA.Short (32767))); MyNamedRange := (MyProp.name, MyRange); Append (Available_QoS, MyNamedRange); elsif MyProp.name = "OrderPolicy" then MyRange := (To_Any (CORBA.Short (0)), To_Any (CORBA.Short (3))); MyNamedRange := (MyProp.name, MyRange); Append (Available_QoS, MyNamedRange); elsif MyProp.name = "DiscardPolicy" then MyRange := (To_Any (CORBA.Short (0)), To_Any (CORBA.Short (4))); MyNamedRange := (MyProp.name, MyRange); Append (Available_QoS, MyNamedRange); end if; end loop; Leave (Self_Mutex); end Validate_QoS; --------------- -- Get_Admin -- --------------- function Get_Admin (Self : access Object) return CosNotification.AdminProperties is MyProp : CosNotification.AdminProperties; begin pragma Debug (O ("get_admin in eventchannel")); Ensure_Initialization; Enter (Self_Mutex); MyProp := Self.X.AdmPropSeq; Leave (Self_Mutex); return MyProp; end Get_Admin; --------------- -- Set_Admin -- --------------- procedure Set_Admin (Self : access Object; Admin : CosNotification.AdminProperties) is Consumers : CORBA.Long; My_Ptr : EventChannel.Impl.Object_Ptr; MyProp : CosNotification.Property; MyError : CosNotification.PropertyError; MyErrCode : CosNotification.QoSError_code; MyRange : CosNotification.PropertyRange; MyErrorSeq : CosNotification.PropertyErrorSeq; SeqLen : Integer; Suppliers : CORBA.Long; begin pragma Debug (O ("set_admin in eventchannel")); Ensure_Initialization; Enter (Self_Mutex); My_Ptr := Self.X.This; Leave (Self_Mutex); Consumers := GetTotalConsumers (My_Ptr); Suppliers := GetTotalSuppliers (My_Ptr); SeqLen := Length (Admin); for Index in 1 .. SeqLen loop MyProp := Get_Element (Admin, Index); if MyProp.name = "MaxQueueLength" then if CORBA.Long'(From_Any (MyProp.value)) < 0 then MyErrCode := BAD_VALUE; MyRange := (To_Any (CORBA.Long (0)), To_Any (CORBA.Long (0))); MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); end if; elsif MyProp.name = "MaxConsumers" then if CORBA.Long'(From_Any (MyProp.value)) < 0 then MyErrCode := BAD_VALUE; MyRange := (To_Any (CORBA.Long (0)), To_Any (CORBA.Long (0))); MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); elsif CORBA.Long'(From_Any (MyProp.value)) < Consumers then MyErrCode := UNAVAILABLE_VALUE; MyRange := (To_Any (Consumers), To_Any (CORBA.Long (0))); MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); end if; elsif MyProp.name = "MaxSuppliers" then if CORBA.Long'(From_Any (MyProp.value)) < 0 then MyErrCode := BAD_VALUE; MyRange := (To_Any (CORBA.Long (0)), To_Any (CORBA.Long (0))); MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); elsif CORBA.Long'(From_Any (MyProp.value)) < Suppliers then MyErrCode := UNAVAILABLE_VALUE; MyRange := (To_Any (Suppliers), To_Any (CORBA.Long (0))); MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); end if; elsif MyProp.name = "RejectNewEvents" then if not CORBA.Boolean'(From_Any (MyProp.value)) and then CORBA.Boolean'(From_Any (MyProp.value)) then MyErrCode := BAD_TYPE; MyRange := (To_Any (CORBA.Boolean (True)), To_Any (CORBA.Boolean (False))); MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); end if; else MyErrCode := BAD_PROPERTY; MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); end if; end loop; if Length (MyErrorSeq) > 0 then CosNotification.Helper.Raise_UnsupportedAdmin ((CORBA.IDL_Exception_Members with admin_err => MyErrorSeq)); end if; Enter (Self_Mutex); for Index in 1 .. SeqLen loop MyProp := Get_Element (Admin, Index); if MyProp.name = "MaxQueueLength" then Replace_Element (Self.X.AdmPropSeq, 1, MyProp); elsif MyProp.name = "MaxConsumers" then Replace_Element (Self.X.AdmPropSeq, 2, MyProp); elsif MyProp.name = "MaxSuppliers" then Replace_Element (Self.X.AdmPropSeq, 3, MyProp); else Replace_Element (Self.X.AdmPropSeq, 4, MyProp); end if; end loop; Leave (Self_Mutex); end Set_Admin; ------------------- -- For_Consumers -- ------------------- function For_Consumers (Self : access Object) return CosEventChannelAdmin.ConsumerAdmin.Ref is pragma Warnings (Off); -- WAG:3.14 pragma Unreferenced (Self); pragma Warnings (On); -- WAG:3.14 MyConsumerAdmin : CosEventChannelAdmin.ConsumerAdmin.Ref; begin pragma Debug (O ("for_consumers in eventchannel")); Ensure_Initialization; Enter (Self_Mutex); Leave (Self_Mutex); return MyConsumerAdmin; end For_Consumers; ------------------- -- For_Suppliers -- ------------------- function For_Suppliers (Self : access Object) return CosEventChannelAdmin.SupplierAdmin.Ref is pragma Warnings (Off); -- WAG:3.14 pragma Unreferenced (Self); pragma Warnings (On); -- WAG:3.14 MySupplierAdmin : CosEventChannelAdmin.SupplierAdmin.Ref; begin pragma Debug (O ("for_suppliers in eventchannel")); Ensure_Initialization; Enter (Self_Mutex); Leave (Self_Mutex); return MySupplierAdmin; end For_Suppliers; ------------- -- Destroy -- ------------- procedure Destroy (Self : access Object) is pragma Warnings (Off); -- WAG:3.14 pragma Unreferenced (Self); pragma Warnings (On); -- WAG:3.14 begin pragma Debug (O ("destroy in eventchannel")); null; end Destroy; ------------ -- Create -- ------------ function Create (Factory : CosNotifyChannelAdmin.EventChannelFactory.Ref; Initial_QoS : CosNotification.QoSProperties; Initial_Admin : CosNotification.AdminProperties) return Object_Ptr is AdminID : CosNotifyChannelAdmin.AdminID; Channel : Object_Ptr; Consumer : CosNotifyChannelAdmin.ConsumerAdmin.Impl.Object_Ptr; ConsumerRef : CosNotifyChannelAdmin.ConsumerAdmin.Ref; My_Ref : EventChannel.Ref; MyError : CosNotification.PropertyError; MyErrCode : CosNotification.QoSError_code; MyErrorSeq : CosNotification.PropertyErrorSeq; MyRange : CosNotification.PropertyRange; MyProp : CosNotification.Property; MyPropName : CORBA.String; SeqLen : Integer; Supplier : CosNotifyChannelAdmin.SupplierAdmin.Impl.Object_Ptr; SupplierRef : CosNotifyChannelAdmin.SupplierAdmin.Ref; begin pragma Debug (O ("create eventchannel")); -- Parse the passed QoS Sequence to check for -- valid names and values SeqLen := Length (Initial_QoS); for Index in 1 .. SeqLen loop MyProp := Get_Element (Initial_QoS, Index); if MyProp.name = "EventReliability" then if CORBA.Short'(From_Any (MyProp.value)) /= 0 and then CORBA.Short'(From_Any (MyProp.value)) /= 1 then MyErrCode := BAD_VALUE; MyRange := (To_Any (CORBA.Short (0)), To_Any (CORBA.Short (0))); MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); end if; elsif MyProp.name = "ConnectionReliability" then if CORBA.Short'(From_Any (MyProp.value)) /= 0 and then CORBA.Short'(From_Any (MyProp.value)) /= 1 then MyErrCode := BAD_VALUE; MyRange := (To_Any (CORBA.Short (0)), To_Any (CORBA.Short (0))); MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); end if; elsif MyProp.name = "Priority" then if CORBA.Short'(From_Any (MyProp.value)) not in -32_767 .. 32_767 then MyErrCode := BAD_VALUE; MyRange := (To_Any (CORBA.Short (-32767)), To_Any (CORBA.Short (32767))); MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); end if; elsif MyProp.name = "StartTime" then MyErrCode := UNSUPPORTED_PROPERTY; MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); elsif MyProp.name = "StopTime" then MyErrCode := UNSUPPORTED_PROPERTY; MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); elsif MyProp.name = "Timeout" then MyErrCode := UNSUPPORTED_PROPERTY; MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); elsif MyProp.name = "OrderPolicy" then if CORBA.Short'(From_Any (MyProp.value)) /= 0 and then CORBA.Short'(From_Any (MyProp.value)) /= 1 and then CORBA.Short'(From_Any (MyProp.value)) /= 2 and then CORBA.Short'(From_Any (MyProp.value)) /= 3 then MyErrCode := BAD_VALUE; MyRange := (To_Any (CORBA.Short (0)), To_Any (CORBA.Short (3))); MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); end if; elsif MyProp.name = "DiscardPolicy" then if CORBA.Short'(From_Any (MyProp.value)) /= 0 and then CORBA.Short'(From_Any (MyProp.value)) /= 1 and then CORBA.Short'(From_Any (MyProp.value)) /= 2 and then CORBA.Short'(From_Any (MyProp.value)) /= 3 and then CORBA.Short'(From_Any (MyProp.value)) /= 4 then MyErrCode := BAD_VALUE; MyRange := (To_Any (CORBA.Short (0)), To_Any (CORBA.Short (4))); MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); end if; elsif MyProp.name = "MaximumBatchSize" then MyErrCode := UNSUPPORTED_PROPERTY; MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); elsif MyProp.name = "PacingInterval" then MyErrCode := UNSUPPORTED_PROPERTY; MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); elsif MyProp.name = "StartTimeSupported" then MyErrCode := UNSUPPORTED_PROPERTY; MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); elsif MyProp.name = "StopTimeSupported" then MyErrCode := UNSUPPORTED_PROPERTY; MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); elsif MyProp.name = "MaxEventsPerConsumer" then MyErrCode := UNSUPPORTED_PROPERTY; MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); else MyErrCode := BAD_PROPERTY; MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); end if; end loop; if Length (MyErrorSeq) > 0 then CosNotification.Helper.Raise_UnsupportedQoS ((CORBA.IDL_Exception_Members with qos_err => MyErrorSeq)); end if; -- Parse the passed Admin Sequence to check for -- valid names and values SeqLen := Length (Initial_Admin); for Index in 1 .. SeqLen loop MyProp := Get_Element (Initial_Admin, Index); if MyProp.name = "MaxQueueLength" then if CORBA.Long'(From_Any (MyProp.value)) < 0 then MyErrCode := BAD_VALUE; MyRange := (To_Any (CORBA.Long (0)), To_Any (CORBA.Long (0))); MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); end if; elsif MyProp.name = "MaxConsumers" then if CORBA.Long'(From_Any (MyProp.value)) < 0 then MyErrCode := BAD_VALUE; MyRange := (To_Any (CORBA.Long (0)), To_Any (CORBA.Long (0))); MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); end if; elsif MyProp.name = "MaxSuppliers" then if CORBA.Long'(From_Any (MyProp.value)) < 0 then MyErrCode := BAD_VALUE; MyRange := (To_Any (CORBA.Long (0)), To_Any (CORBA.Long (0))); MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); end if; elsif MyProp.name = "RejectNewEvents" then if CORBA.Boolean'(From_Any (MyProp.value)) and then CORBA.Boolean'(From_Any (MyProp.value)) then MyErrCode := BAD_TYPE; MyRange := (To_Any (CORBA.Boolean (True)), To_Any (CORBA.Boolean (False))); MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); end if; else MyErrCode := BAD_PROPERTY; MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); end if; end loop; if Length (MyErrorSeq) > 0 then CosNotification.Helper.Raise_UnsupportedAdmin ((CORBA.IDL_Exception_Members with admin_err => MyErrorSeq)); end if; Channel := new Object; Channel.X := new Event_Channel_Record; Channel.X.This := Channel; Channel.X.Factory := Factory; Initiate_Servant (Servant (Channel), My_Ref); -- Create Default QoS Properties Sequence for the channel MyPropName := To_CORBA_String ("EventReliability"); MyProp := (CosNotification.PropertyName (MyPropName), To_Any (CORBA.Short (0))); Append (Channel.X.QoSPropSeq, MyProp); MyPropName := To_CORBA_String ("ConnectionReliability"); MyProp := (CosNotification.PropertyName (MyPropName), To_Any (CORBA.Short (0))); Append (Channel.X.QoSPropSeq, MyProp); MyPropName := To_CORBA_String ("Priority"); MyProp := (CosNotification.PropertyName (MyPropName), To_Any (CORBA.Short (0))); Append (Channel.X.QoSPropSeq, MyProp); MyPropName := To_CORBA_String ("OrderPolicy"); MyProp := (CosNotification.PropertyName (MyPropName), To_Any (CORBA.Short (2))); Append (Channel.X.QoSPropSeq, MyProp); MyPropName := To_CORBA_String ("DiscardPolicy"); MyProp := (CosNotification.PropertyName (MyPropName), To_Any (CORBA.Short (2))); Append (Channel.X.QoSPropSeq, MyProp); -- Replace the values in Channel's QoSProperties Sequence -- with those of Passed AdminProperties Sequence SeqLen := Length (Initial_QoS); for Index in 1 .. SeqLen loop MyProp := Get_Element (Initial_QoS, Index); if MyProp.name = "EventReliability" then Replace_Element (Channel.X.QoSPropSeq, 1, MyProp); elsif MyProp.name = "ConnectionReliability" then Replace_Element (Channel.X.QoSPropSeq, 2, MyProp); elsif MyProp.name = "Priority" then Replace_Element (Channel.X.QoSPropSeq, 3, MyProp); elsif MyProp.name = "OrderPolicy" then Replace_Element (Channel.X.QoSPropSeq, 4, MyProp); else Replace_Element (Channel.X.QoSPropSeq, 5, MyProp); end if; end loop; -- AdminID of the default consumeradmin object created by -- eventchannel must be 0 but in Ada Sequence Indexing starts -- from 1 so every time we need to append the ID number -- into AdminIDSeq we do it before the appending the actual -- Admin Ref into its respective Sequence AdminID := CosNotifyChannelAdmin.AdminID (ConsumerAdmins.Length (Channel.X.Consumers)); Append (Channel.X.CIDSeq, AdminID); -- create a default consumeradmin and append its reference -- to ConsumerAdmins sequence Consumer := CosNotifyChannelAdmin.ConsumerAdmin.Impl.Create (My_Ref, Channel.X.QoSPropSeq, AdminID); Servant_To_Reference (Servant (Consumer), ConsumerRef); Channel.X.Consumer := ConsumerRef; ConsumerAdmins.Append (Channel.X.Consumers, Channel.X.Consumer); -- AdminID of the default supplieradmin object created by -- eventchannel must be 0 but in Ada Sequence Indexing starts -- from 1 so every time we need to append the ID number -- into AdminIDSeq we do it before the appending the actual -- Admin Ref into its respective Sequence AdminID := CosNotifyChannelAdmin.AdminID (SupplierAdmins.Length (Channel.X.Suppliers)); Append (Channel.X.SIDSeq, AdminID); -- create a default supplieradmin and append its reference -- to SupplierAdmins sequence Supplier := CosNotifyChannelAdmin.SupplierAdmin.Impl.Create (My_Ref, Channel.X.QoSPropSeq, AdminID); Servant_To_Reference (Servant (Supplier), SupplierRef); Channel.X.Supplier := SupplierRef; SupplierAdmins.Append (Channel.X.Suppliers, Channel.X.Supplier); -- Create Default Admin Properties Sequence for the channel MyPropName := To_CORBA_String ("MaxQueueLength"); MyProp := (CosNotification.PropertyName (MyPropName), To_Any (CORBA.Long (0))); Append (Channel.X.AdmPropSeq, MyProp); MyPropName := To_CORBA_String ("MaxConsumers"); MyProp := (CosNotification.PropertyName (MyPropName), To_Any (CORBA.Long (0))); Append (Channel.X.AdmPropSeq, MyProp); MyPropName := To_CORBA_String ("MaxSuppliers"); MyProp := (CosNotification.PropertyName (MyPropName), To_Any (CORBA.Long (0))); Append (Channel.X.AdmPropSeq, MyProp); MyPropName := To_CORBA_String ("RejectNewEvents"); MyProp := (CosNotification.PropertyName (MyPropName), To_Any (CORBA.Boolean (False))); Append (Channel.X.AdmPropSeq, MyProp); -- Replace the values in Channel's AdminProperties Sequence -- with those of Passed AdminProperties Sequence SeqLen := Length (Initial_Admin); for Index in 1 .. SeqLen loop MyProp := Get_Element (Initial_Admin, Index); if MyProp.name = "MaxQueueLength" then Replace_Element (Channel.X.AdmPropSeq, 1, MyProp); elsif MyProp.name = "MaxConsumers" then Replace_Element (Channel.X.AdmPropSeq, 2, MyProp); elsif MyProp.name = "MaxSuppliers" then Replace_Element (Channel.X.AdmPropSeq, 3, MyProp); else Replace_Element (Channel.X.AdmPropSeq, 4, MyProp); end if; end loop; return Channel; end Create; ----------------------- -- GetTotalConsumers -- ----------------------- function GetTotalConsumers (Self : access Object) return CORBA.Long is Res : CORBA.Long; begin pragma Debug (O ("gettotalconsumers in eventchannel")); Ensure_Initialization; Enter (Self_Mutex); declare CTotal : CORBA.Long := 0; SAdmins : constant SupplierAdmins.Element_Array := SupplierAdmins.To_Element_Array (Self.X.Suppliers); Supplier : CosNotifyChannelAdmin.SupplierAdmin.Impl.Object_Ptr; begin Leave (Self_Mutex); for J in SAdmins'Range loop Reference_To_Servant (SAdmins (J), Servant (Supplier)); CTotal := CTotal + CosNotifyChannelAdmin.SupplierAdmin.Impl. GetTotalConsumers (Supplier); end loop; Res := CTotal; end; return Res; end GetTotalConsumers; ----------------------- -- GetTotalSuppliers -- ----------------------- function GetTotalSuppliers (Self : access Object) return CORBA.Long is Res : CORBA.Long; begin pragma Debug (O ("gettotalsuppliers in eventchannel")); Ensure_Initialization; Enter (Self_Mutex); declare STotal : CORBA.Long := 0; CAdmins : constant ConsumerAdmins.Element_Array := ConsumerAdmins.To_Element_Array (Self.X.Consumers); Consumer : CosNotifyChannelAdmin.ConsumerAdmin.Impl.Object_Ptr; begin Leave (Self_Mutex); for J in CAdmins'Range loop Reference_To_Servant (CAdmins (J), Servant (Consumer)); STotal := STotal + CosNotifyChannelAdmin.ConsumerAdmin.Impl. GetTotalSuppliers (Consumer); end loop; Res := STotal; end; return Res; end GetTotalSuppliers; ---------- -- Post -- ---------- procedure Post (Self : access Object; Data : CORBA.Any) is Consumer : CosNotifyChannelAdmin.ConsumerAdmin.Impl.Object_Ptr; begin pragma Debug (O ("post new data from eventchannel to consumeradmin")); Ensure_Initialization; Enter (Self_Mutex); declare Consumers : constant ConsumerAdmins.Element_Array := ConsumerAdmins.To_Element_Array (Self.X.Consumers); begin Leave (Self_Mutex); pragma Debug (O ("post new data from eventchannel to consumeradmins")); for J in Consumers'Range loop Reference_To_Servant (Consumers (J), Servant (Consumer)); CosNotifyChannelAdmin.ConsumerAdmin.Impl.Post (Consumer, Data); end loop; end; end Post; --------------------- -- Structured_Post -- --------------------- procedure Structured_Post (Self : access Object; Notification : CosNotification.StructuredEvent) is Consumer : CosNotifyChannelAdmin.ConsumerAdmin.Impl.Object_Ptr; begin Ensure_Initialization; pragma Debug (O ("post structured event from eventchannel to consumeradmin")); Enter (Self_Mutex); declare Consumers : constant ConsumerAdmins.Element_Array := ConsumerAdmins.To_Element_Array (Self.X.Consumers); begin Leave (Self_Mutex); pragma Debug (O ("post new structured from eventchannel to consumeradmins")); for J in Consumers'Range loop Reference_To_Servant (Consumers (J), Servant (Consumer)); CosNotifyChannelAdmin.ConsumerAdmin.Impl.Structured_Post (Consumer, Notification); end loop; end; end Structured_Post; ------------------- -- Sequence_Post -- ------------------- procedure Sequence_Post (Self : access Object; Notifications : CosNotification.EventBatch) is Consumer : CosNotifyChannelAdmin.ConsumerAdmin.Impl.Object_Ptr; begin Ensure_Initialization; pragma Debug (O ("post sequence of structured event from " & "eventchannel to consumeradmin")); Enter (Self_Mutex); declare Consumers : constant ConsumerAdmins.Element_Array := ConsumerAdmins.To_Element_Array (Self.X.Consumers); begin Leave (Self_Mutex); pragma Debug (O ("post new sequence of structured from " & "eventchannel to consumeradmins")); for J in Consumers'Range loop Reference_To_Servant (Consumers (J), Servant (Consumer)); CosNotifyChannelAdmin.ConsumerAdmin.Impl.Sequence_Post (Consumer, Notifications); end loop; end; end Sequence_Post; ----------------------- -- TestConsumerLimit -- ----------------------- function TestConsumerLimit (Self : access Object) return CORBA.Boolean is MyProp : CosNotification.Property; My_Ptr : EventChannel.Impl.Object_Ptr; MaxCons : CORBA.Long; PresCons : CORBA.Long; Res : CORBA.Boolean; begin pragma Debug (O ("testconsumerlimit in eventchannel")); Ensure_Initialization; Enter (Self_Mutex); MyProp := Get_Element (Self.X.AdmPropSeq, 2); Leave (Self_Mutex); MaxCons := CORBA.Long'(From_Any (MyProp.value)); if MaxCons = 0 then Res := True; else Enter (Self_Mutex); My_Ptr := Self.X.This; Leave (Self_Mutex); PresCons := GetTotalConsumers (My_Ptr); if PresCons < MaxCons then Res := True; else Res := False; end if; end if; return Res; end TestConsumerLimit; ----------------------- -- TestSupplierLimit -- ----------------------- function TestSupplierLimit (Self : access Object) return CORBA.Boolean is MyProp : CosNotification.Property; My_Ptr : EventChannel.Impl.Object_Ptr; MaxSups : CORBA.Long; PresSups : CORBA.Long; Res : CORBA.Boolean; begin pragma Debug (O ("testsupplierlimit in eventchannel")); Ensure_Initialization; Enter (Self_Mutex); MyProp := Get_Element (Self.X.AdmPropSeq, 3); Leave (Self_Mutex); MaxSups := CORBA.Long'(From_Any (MyProp.value)); if MaxSups = 0 then Res := True; else Enter (Self_Mutex); My_Ptr := Self.X.This; Leave (Self_Mutex); PresSups := GetTotalSuppliers (My_Ptr); if PresSups < MaxSups then Res := True; else Res := False; end if; end if; return Res; end TestSupplierLimit; end CosNotifyChannelAdmin.EventChannel.Impl; polyorb-2.8~20110207.orig/cos/notification/cosnotifycomm-structuredpushsupplier-impl.ads0000644000175000017500000000664311750740337031102 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- COSNOTIFYCOMM.STRUCTUREDPUSHSUPPLIER.IMPL -- -- -- -- S p e c -- -- -- -- Copyright (C) 2003-2008, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by ACT Europe. -- -- (email: sales@act-europe.fr) -- -- -- ------------------------------------------------------------------------------ with PortableServer; with CosNotifyChannelAdmin.StructuredProxyPushConsumer; package CosNotifyComm.StructuredPushSupplier.Impl is type Object is new PortableServer.Servant_Base with private; type Object_Ptr is access all Object'Class; -- Inherited IDL operations from CosNotifyComm::NotifySubscribe procedure Subscription_Change (Self : access Object; Added : CosNotification.EventTypeSeq; Removed : CosNotification.EventTypeSeq); -- IDL operations procedure Disconnect_Structured_Push_Supplier (Self : access Object); ---------------------- -- PolyORB specific -- ---------------------- function Create return Object_Ptr; -- Call by application to create an object and activate servant procedure Connect_Structured_Proxy_Push_Consumer (Self : access Object; Proxy : CosNotifyChannelAdmin.StructuredProxyPushConsumer.Ref); -- Call by application to connect object with proxy procedure Push (Self : access Object; Notification : CosNotification.StructuredEvent); -- Call by application to push structured event private type Structured_Push_Supplier_Record; type Structured_Push_Supplier_Access is access Structured_Push_Supplier_Record; type Object is new PortableServer.Servant_Base with record X : Structured_Push_Supplier_Access; end record; end CosNotifyComm.StructuredPushSupplier.Impl; polyorb-2.8~20110207.orig/cos/notification/cosnotifychanneladmin-sequenceproxypushsupplier-impl.adb0000644000175000017500000007047611750740337033262 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- COSNOTIFYCHANNELADMIN.SEQUENCEPROXYPUSHSUPPLIER.IMPL -- -- -- -- B o d y -- -- -- -- Copyright (C) 2003-2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with CosEventChannelAdmin.Helper; with CosNotification; with CosNotification.Helper; with PolyORB.CORBA_P.Server_Tools; with PolyORB.Log; with PolyORB.Tasking.Mutexes; with CosNotifyChannelAdmin.SequenceProxyPushSupplier.Skel; pragma Warnings (Off, CosNotifyChannelAdmin.SequenceProxyPushSupplier.Skel); package body CosNotifyChannelAdmin.SequenceProxyPushSupplier.Impl is use CosNotification; use IDL_SEQUENCE_CosNotification_Property; use IDL_SEQUENCE_CosNotification_PropertyError; use IDL_SEQUENCE_CosNotification_NamedPropertyRange; use CORBA; use PolyORB.CORBA_P.Server_Tools; use PolyORB.Tasking.Mutexes; package Convert is new ConsumerAdmin_Forward.Convert (CosNotifyChannelAdmin.ConsumerAdmin.Ref); use PolyORB.Log; package L is new PolyORB.Log.Facility_Log ("sequenceproxypushsupplier"); procedure O (Message : Standard.String; Level : Log_Level := Debug) renames L.Output; function C (Level : Log_Level := Debug) return Boolean renames L.Enabled; pragma Unreferenced (C); -- For conditional pragma Debug type Sequence_Proxy_Push_Supplier_Record is record This : Object_Ptr; Admin : CosNotifyChannelAdmin.ConsumerAdmin.Ref; MyId : CosNotifyChannelAdmin.ProxyID; MyType : CosNotifyChannelAdmin.ProxyType; Peer : CosNotifyComm.SequencePushConsumer.Ref; QoSPropSeq : CosNotification.QoSProperties; end record; --------------------------- -- Ensure_Initialization -- --------------------------- procedure Ensure_Initialization; pragma Inline (Ensure_Initialization); -- Ensure that the Mutexes are initialized T_Initialized : Boolean := False; Self_Mutex : Mutex_Access; procedure Ensure_Initialization is begin if not T_Initialized then Create (Self_Mutex); T_Initialized := True; end if; end Ensure_Initialization; ------------------------------------ -- Connect_Sequence_Push_consumer -- ------------------------------------ procedure Connect_Sequence_Push_consumer (Self : access Object; Push_Consumer : CosNotifyComm.SequencePushConsumer.Ref) is begin Ensure_Initialization; pragma Debug (O ("connect_sequence_push_consumer in sequenceproxypushsupplier")); Enter (Self_Mutex); if not CosNotifyComm.SequencePushConsumer.Is_Nil (Self.X.Peer) then Leave (Self_Mutex); CosEventChannelAdmin.Helper.Raise_AlreadyConnected ((CORBA.IDL_Exception_Members with null record)); end if; Self.X.Peer := Push_Consumer; Leave (Self_Mutex); end Connect_Sequence_Push_consumer; ------------------------ -- Suspend_Connection -- ------------------------ procedure Suspend_Connection (Self : access Object) is pragma Warnings (Off); -- WAG:3.14 pragma Unreferenced (Self); pragma Warnings (On); -- WAG:3.14 begin Ensure_Initialization; pragma Debug (O ("suspend_connection in sequenceproxypushsupplier")); Enter (Self_Mutex); Leave (Self_Mutex); end Suspend_Connection; ----------------------- -- Resume_Connection -- ----------------------- procedure Resume_Connection (Self : access Object) is pragma Warnings (Off); -- WAG:3.14 pragma Unreferenced (Self); pragma Warnings (On); -- WAG:3.14 begin Ensure_Initialization; pragma Debug (O ("resume_connection in sequenceproxypushsupplier")); Enter (Self_Mutex); Leave (Self_Mutex); end Resume_Connection; ---------------- -- Get_MyType -- ---------------- function Get_MyType (Self : access Object) return CosNotifyChannelAdmin.ProxyType is MyType : CosNotifyChannelAdmin.ProxyType; begin Ensure_Initialization; pragma Debug (O ("get_mytype in sequenceproxypushsupplier")); Enter (Self_Mutex); MyType := Self.X.MyType; Leave (Self_Mutex); return MyType; end Get_MyType; ----------------- -- Get_MyAdmin -- ----------------- function Get_MyAdmin (Self : access Object) return CosNotifyChannelAdmin.ConsumerAdmin_Forward.Ref is MyAdmin : CosNotifyChannelAdmin.ConsumerAdmin_Forward.Ref; begin Ensure_Initialization; pragma Debug (O ("get_myadmin in sequenceproxypushsupplier")); Enter (Self_Mutex); MyAdmin := Convert.To_Forward (Self.X.Admin); Leave (Self_Mutex); return MyAdmin; end Get_MyAdmin; ------------------------- -- Get_Priority_Filter -- ------------------------- function Get_Priority_Filter (Self : access Object) return CosNotifyFilter.MappingFilter.Ref is pragma Warnings (Off); -- WAG:3.14 pragma Unreferenced (Self); pragma Warnings (On); -- WAG:3.14 MyFilter : CosNotifyFilter.MappingFilter.Ref; begin Ensure_Initialization; pragma Debug (O ("get_priority_filter in sequenceproxypushsupplier")); Enter (Self_Mutex); Leave (Self_Mutex); return MyFilter; end Get_Priority_Filter; ------------------------- -- Set_Priority_Filter -- ------------------------- procedure Set_Priority_Filter (Self : access Object; To : CosNotifyFilter.MappingFilter.Ref) is pragma Warnings (Off); -- WAG:3.14 pragma Unreferenced (Self, To); pragma Warnings (On); -- WAG:3.14 begin Ensure_Initialization; pragma Debug (O ("set_priority_filter in sequenceproxypushsupplier")); Enter (Self_Mutex); Leave (Self_Mutex); end Set_Priority_Filter; ------------------------- -- Get_Lifetime_Filter -- ------------------------- function Get_Lifetime_Filter (Self : access Object) return CosNotifyFilter.MappingFilter.Ref is pragma Warnings (Off); -- WAG:3.14 pragma Unreferenced (Self); pragma Warnings (On); -- WAG:3.14 MyFilter : CosNotifyFilter.MappingFilter.Ref; begin Ensure_Initialization; pragma Debug (O ("get_lifetime_filter in sequenceproxypushsupplier")); Enter (Self_Mutex); Leave (Self_Mutex); return MyFilter; end Get_Lifetime_Filter; ------------------------- -- Set_Lifetime_Filter -- ------------------------- procedure Set_Lifetime_Filter (Self : access Object; To : CosNotifyFilter.MappingFilter.Ref) is pragma Warnings (Off); -- WAG:3.14 pragma Unreferenced (Self, To); pragma Warnings (On); -- WAG:3.14 begin Ensure_Initialization; pragma Debug (O ("set_lifetime_filter in sequenceproxypushsupplier")); Enter (Self_Mutex); Leave (Self_Mutex); end Set_Lifetime_Filter; -------------------------- -- Obtain_Offered_Types -- -------------------------- function Obtain_Offered_Types (Self : access Object; Mode : CosNotifyChannelAdmin.ObtainInfoMode) return CosNotification.EventTypeSeq is pragma Warnings (Off); -- WAG:3.14 pragma Unreferenced (Self, Mode); pragma Warnings (On); -- WAG:3.14 MySeq : CosNotification.EventTypeSeq; begin Ensure_Initialization; pragma Debug (O ("obtain_offered_types in sequenceproxypushsupplier")); Enter (Self_Mutex); Leave (Self_Mutex); return MySeq; end Obtain_Offered_Types; ------------------------ -- Validate_Event_QoS -- ------------------------ procedure Validate_Event_QoS (Self : access Object; Required_QoS : CosNotification.QoSProperties; Available_QoS : out CosNotification.NamedPropertyRangeSeq) is pragma Warnings (Off); -- WAG:3.14 pragma Unreferenced (Self, Required_QoS, Available_QoS); pragma Warnings (On); -- WAG:3.14 begin Ensure_Initialization; pragma Debug (O ("validate_event_qos in sequenceproxypushsupplier")); Enter (Self_Mutex); Leave (Self_Mutex); end Validate_Event_QoS; ------------- -- Get_QoS -- ------------- function Get_QoS (Self : access Object) return CosNotification.QoSProperties is MyQoS : CosNotification.QoSProperties; begin Ensure_Initialization; pragma Debug (O ("get_qos in sequenceproxypushsupplier")); Enter (Self_Mutex); MyQoS := Self.X.QoSPropSeq; Leave (Self_Mutex); return MyQoS; end Get_QoS; ------------- -- Set_QoS -- ------------- procedure Set_QoS (Self : access Object; QoS : CosNotification.QoSProperties) is MyProp : CosNotification.Property; MyError : CosNotification.PropertyError; MyErrCode : CosNotification.QoSError_code; MyRange : CosNotification.PropertyRange; MyErrorSeq : CosNotification.PropertyErrorSeq; SeqLen : Integer; begin Ensure_Initialization; pragma Debug (O ("set_qos in sequenceproxypushsupplier")); SeqLen := Length (QoS); for Index in 1 .. SeqLen loop MyProp := Get_Element (QoS, Index); if MyProp.name = "EventReliability" then MyErrCode := UNAVAILABLE_PROPERTY; MyRange := (To_Any (CORBA.Short (0)), To_Any (CORBA.Short (0))); MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); elsif MyProp.name = "ConnectionReliability" then if CORBA.Short'(From_Any (MyProp.value)) /= 0 and then CORBA.Short'(From_Any (MyProp.value)) /= 1 then MyErrCode := BAD_VALUE; MyRange := (To_Any (CORBA.Short (0)), To_Any (CORBA.Short (0))); MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); end if; elsif MyProp.name = "Priority" then if CORBA.Short'(From_Any (MyProp.value)) not in -32_767 .. 32_767 then MyErrCode := BAD_VALUE; MyRange := (To_Any (CORBA.Short (-32767)), To_Any (CORBA.Short (32767))); MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); end if; elsif MyProp.name = "StartTime" then MyErrCode := UNAVAILABLE_PROPERTY; MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); elsif MyProp.name = "StopTime" then MyErrCode := UNAVAILABLE_PROPERTY; MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); elsif MyProp.name = "Timeout" then MyErrCode := UNSUPPORTED_PROPERTY; MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); elsif MyProp.name = "OrderPolicy" then if CORBA.Short'(From_Any (MyProp.value)) /= 0 and then CORBA.Short'(From_Any (MyProp.value)) /= 1 and then CORBA.Short'(From_Any (MyProp.value)) /= 2 and then CORBA.Short'(From_Any (MyProp.value)) /= 3 then MyErrCode := BAD_VALUE; MyRange := (To_Any (CORBA.Short (0)), To_Any (CORBA.Short (3))); MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); end if; elsif MyProp.name = "DiscardPolicy" then if CORBA.Short'(From_Any (MyProp.value)) /= 0 and then CORBA.Short'(From_Any (MyProp.value)) /= 1 and then CORBA.Short'(From_Any (MyProp.value)) /= 2 and then CORBA.Short'(From_Any (MyProp.value)) /= 3 and then CORBA.Short'(From_Any (MyProp.value)) /= 4 then MyErrCode := BAD_VALUE; MyRange := (To_Any (CORBA.Short (0)), To_Any (CORBA.Short (4))); MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); end if; elsif MyProp.name = "MaximumBatchSize" then MyErrCode := UNSUPPORTED_PROPERTY; MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); elsif MyProp.name = "PacingInterval" then MyErrCode := UNSUPPORTED_PROPERTY; MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); elsif MyProp.name = "StartTimeSupported" then MyErrCode := UNSUPPORTED_PROPERTY; MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); elsif MyProp.name = "StopTimeSupported" then MyErrCode := UNSUPPORTED_PROPERTY; MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); elsif MyProp.name = "MaxEventsPerConsumer" then MyErrCode := UNSUPPORTED_PROPERTY; MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); else MyErrCode := BAD_PROPERTY; MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); end if; end loop; if Length (MyErrorSeq) > 0 then CosNotification.Helper.Raise_UnsupportedQoS ((CORBA.IDL_Exception_Members with qos_err => MyErrorSeq)); end if; SeqLen := Length (QoS); Enter (Self_Mutex); for Index in 1 .. SeqLen loop MyProp := Get_Element (QoS, Index); if MyProp.name = "ConnectionReliability" then Replace_Element (Self.X.QoSPropSeq, 2, MyProp); elsif MyProp.name = "Priority" then Replace_Element (Self.X.QoSPropSeq, 3, MyProp); elsif MyProp.name = "OrderPolicy" then Replace_Element (Self.X.QoSPropSeq, 4, MyProp); elsif MyProp.name = "DiscardPolicy" then Replace_Element (Self.X.QoSPropSeq, 5, MyProp); end if; end loop; Leave (Self_Mutex); end Set_QoS; ------------------ -- Validate_QoS -- ------------------ procedure Validate_QoS (Self : access Object; Required_QoS : CosNotification.QoSProperties; Available_QoS : out CosNotification.NamedPropertyRangeSeq) is MyProp : CosNotification.Property; MyError : CosNotification.PropertyError; MyErrCode : CosNotification.QoSError_code; MyNamedRange : CosNotification.NamedPropertyRange; MyRange : CosNotification.PropertyRange; MyErrorSeq : CosNotification.PropertyErrorSeq; SeqLen : Integer; begin Ensure_Initialization; pragma Debug (O ("validate_qos in sequenceproxypushsupplier")); SeqLen := Length (Required_QoS); for Index in 1 .. SeqLen loop MyProp := Get_Element (Required_QoS, Index); if MyProp.name = "EventReliability" then MyErrCode := UNAVAILABLE_PROPERTY; MyRange := (To_Any (CORBA.Short (0)), To_Any (CORBA.Short (0))); MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); elsif MyProp.name = "ConnectionReliability" then if CORBA.Short'(From_Any (MyProp.value)) /= 0 and then CORBA.Short'(From_Any (MyProp.value)) /= 1 then MyErrCode := BAD_VALUE; MyRange := (To_Any (CORBA.Short (0)), To_Any (CORBA.Short (0))); MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); end if; elsif MyProp.name = "Priority" then if CORBA.Short'(From_Any (MyProp.value)) not in -32_767 .. 32_767 then MyErrCode := BAD_VALUE; MyRange := (To_Any (CORBA.Short (-32767)), To_Any (CORBA.Short (32767))); MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); end if; elsif MyProp.name = "StartTime" then MyErrCode := UNAVAILABLE_PROPERTY; MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); elsif MyProp.name = "StopTime" then MyErrCode := UNAVAILABLE_PROPERTY; MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); elsif MyProp.name = "Timeout" then MyErrCode := UNSUPPORTED_PROPERTY; MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); elsif MyProp.name = "OrderPolicy" then if CORBA.Short'(From_Any (MyProp.value)) /= 0 and then CORBA.Short'(From_Any (MyProp.value)) /= 1 and then CORBA.Short'(From_Any (MyProp.value)) /= 2 and then CORBA.Short'(From_Any (MyProp.value)) /= 3 then MyErrCode := BAD_VALUE; MyRange := (To_Any (CORBA.Short (0)), To_Any (CORBA.Short (3))); MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); end if; elsif MyProp.name = "DiscardPolicy" then if CORBA.Short'(From_Any (MyProp.value)) /= 0 and then CORBA.Short'(From_Any (MyProp.value)) /= 1 and then CORBA.Short'(From_Any (MyProp.value)) /= 2 and then CORBA.Short'(From_Any (MyProp.value)) /= 3 and then CORBA.Short'(From_Any (MyProp.value)) /= 4 then MyErrCode := BAD_VALUE; MyRange := (To_Any (CORBA.Short (0)), To_Any (CORBA.Short (4))); MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); end if; elsif MyProp.name = "MaximumBatchSize" then MyErrCode := UNSUPPORTED_PROPERTY; MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); elsif MyProp.name = "PacingInterval" then MyErrCode := UNSUPPORTED_PROPERTY; MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); elsif MyProp.name = "StartTimeSupported" then MyErrCode := UNSUPPORTED_PROPERTY; MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); elsif MyProp.name = "StopTimeSupported" then MyErrCode := UNSUPPORTED_PROPERTY; MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); elsif MyProp.name = "MaxEventsPerConsumer" then MyErrCode := UNSUPPORTED_PROPERTY; MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); else MyErrCode := BAD_PROPERTY; MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); end if; end loop; if Length (MyErrorSeq) > 0 then CosNotification.Helper.Raise_UnsupportedQoS ((CORBA.IDL_Exception_Members with qos_err => MyErrorSeq)); end if; Enter (Self_Mutex); SeqLen := Length (Self.X.QoSPropSeq); for Index in 1 .. SeqLen loop MyProp := Get_Element (Self.X.QoSPropSeq, Index); if MyProp.name = "ConnectionReliability" then MyRange := (From_Any (MyProp.value), To_Any (CORBA.Short (0))); MyNamedRange := (MyProp.name, MyRange); Append (Available_QoS, MyNamedRange); elsif MyProp.name = "Priority" then MyRange := (To_Any (CORBA.Short (-32767)), To_Any (CORBA.Short (32767))); MyNamedRange := (MyProp.name, MyRange); Append (Available_QoS, MyNamedRange); elsif MyProp.name = "OrderPolicy" then MyRange := (To_Any (CORBA.Short (0)), To_Any (CORBA.Short (3))); MyNamedRange := (MyProp.name, MyRange); Append (Available_QoS, MyNamedRange); elsif MyProp.name = "DiscardPolicy" then MyRange := (To_Any (CORBA.Short (0)), To_Any (CORBA.Short (4))); MyNamedRange := (MyProp.name, MyRange); Append (Available_QoS, MyNamedRange); end if; end loop; Leave (Self_Mutex); end Validate_QoS; ---------------- -- Add_Filter -- ---------------- function Add_Filter (Self : access Object; New_Filter : CosNotifyFilter.Filter.Ref) return CosNotifyFilter.FilterID is pragma Warnings (Off); -- WAG:3.14 pragma Unreferenced (Self, New_Filter); pragma Warnings (On); -- WAG:3.14 MyFilterID : CosNotifyFilter.FilterID; MyID : CORBA.Long; begin Ensure_Initialization; pragma Debug (O ("add_filter in sequenceproxypushsupplier")); Enter (Self_Mutex); Leave (Self_Mutex); MyID := 0; MyFilterID := CosNotifyFilter.FilterID (MyID); return MyFilterID; end Add_Filter; ------------------- -- Remove_Filter -- ------------------- procedure Remove_Filter (Self : access Object; Filter : CosNotifyFilter.FilterID) is pragma Warnings (Off); -- WAG:3.14 pragma Unreferenced (Self, Filter); pragma Warnings (On); -- WAG:3.14 begin Ensure_Initialization; pragma Debug (O ("remove_filter in sequenceproxypushsupplier")); Enter (Self_Mutex); Leave (Self_Mutex); end Remove_Filter; ---------------- -- Get_Filter -- ---------------- function Get_Filter (Self : access Object; Filter : CosNotifyFilter.FilterID) return CosNotifyFilter.Filter.Ref is pragma Warnings (Off); -- WAG:3.14 pragma Unreferenced (Self, Filter); pragma Warnings (On); -- WAG:3.14 MyFilter : CosNotifyFilter.Filter.Ref; begin Ensure_Initialization; pragma Debug (O ("get_filter in sequenceproxypushsupplier")); Enter (Self_Mutex); Leave (Self_Mutex); return MyFilter; end Get_Filter; --------------------- -- Get_All_Filters -- --------------------- function Get_All_Filters (Self : access Object) return CosNotifyFilter.FilterIDSeq is pragma Warnings (Off); -- WAG:3.14 pragma Unreferenced (Self); pragma Warnings (On); -- WAG:3.14 MyFilterSeq : CosNotifyFilter.FilterIDSeq; begin Ensure_Initialization; pragma Debug (O ("get_all_filters in sequenceproxypushsupplier")); Enter (Self_Mutex); Leave (Self_Mutex); return MyFilterSeq; end Get_All_Filters; ------------------------ -- Remove_All_Filters -- ------------------------ procedure Remove_All_Filters (Self : access Object) is pragma Warnings (Off); -- WAG:3.14 pragma Unreferenced (Self); pragma Warnings (On); -- WAG:3.14 begin Ensure_Initialization; pragma Debug (O ("remove_all_filters in sequenceproxypushsupplier")); Enter (Self_Mutex); Leave (Self_Mutex); end Remove_All_Filters; ------------------------- -- Subscription_Change -- ------------------------- procedure Subscription_Change (Self : access Object; Added : CosNotification.EventTypeSeq; Removed : CosNotification.EventTypeSeq) is pragma Warnings (Off); -- WAG:3.14 pragma Unreferenced (Self, Added, Removed); pragma Warnings (On); -- WAG:3.14 begin Ensure_Initialization; pragma Debug (O ("subscription_change in sequenceproxypushsupplier")); Enter (Self_Mutex); Leave (Self_Mutex); end Subscription_Change; ----------------------------------------- -- Disconnect_Sequence_Push_Supplier -- ----------------------------------------- procedure Disconnect_Sequence_Push_Supplier (Self : access Object) is Peer : CosNotifyComm.SequencePushConsumer.Ref; Nil_Ref : CosNotifyComm.SequencePushConsumer.Ref; begin pragma Debug (O ("disconnect sequenceproxypushsupplier")); Ensure_Initialization; Enter (Self_Mutex); Peer := Self.X.Peer; Self.X.Peer := Nil_Ref; Leave (Self_Mutex); if not CosNotifyComm.SequencePushConsumer.Is_Nil (Peer) then CosNotifyComm.SequencePushConsumer. disconnect_sequence_push_consumer (Peer); end if; end Disconnect_Sequence_Push_Supplier; ------------ -- Create -- ------------ function Create (Admin : CosNotifyChannelAdmin.ConsumerAdmin.Ref; Initial_QoS : CosNotification.QoSProperties; Ptype : CosNotifyChannelAdmin.ProxyType; Proxy_Id : CosNotifyChannelAdmin.ProxyID) return Object_Ptr is Supplier : Object_Ptr; My_Ref : SequenceProxyPushSupplier.Ref; begin pragma Debug (O ("create sequenceproxypushsupplier")); Supplier := new Object; Supplier.X := new Sequence_Proxy_Push_Supplier_Record; Supplier.X.Admin := Admin; Supplier.X.MyId := Proxy_Id; Supplier.X.MyType := Ptype; Supplier.X.This := Supplier; Supplier.X.QoSPropSeq := Initial_QoS; Initiate_Servant (PortableServer.Servant (Supplier), My_Ref); return Supplier; end Create; ------------------- -- Sequence_Post -- ------------------- procedure Sequence_Post (Self : access Object; Notifications : CosNotification.EventBatch) is MyPeer : CosNotifyComm.SequencePushConsumer.Ref; begin pragma Debug (O ("post new sequence of structured events from " & "sequenceproxypushsupplier to sequencepushconsumer")); Ensure_Initialization; Enter (Self_Mutex); MyPeer := Self.X.Peer; Leave (Self_Mutex); begin CosNotifyComm.SequencePushConsumer.push_structured_events (MyPeer, Notifications); exception when others => pragma Debug (O ("Got exception in post at sequenceproxypushsupplier")); raise; end; end Sequence_Post; end CosNotifyChannelAdmin.SequenceProxyPushSupplier.Impl; polyorb-2.8~20110207.orig/cos/notification/cosnotifycomm-notifysubscribe-impl.adb0000644000175000017500000001035111750740337027372 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- C O S N O T I F Y C O M M . N O T I F Y S U B S C R I B E . I M P L -- -- -- -- B o d y -- -- -- -- Copyright (C) 2003-2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with PolyORB.CORBA_P.Server_Tools; with PolyORB.Log; with PolyORB.Tasking.Mutexes; with CosNotifyComm.NotifySubscribe.Skel; pragma Warnings (Off, CosNotifyComm.NotifySubscribe.Skel); package body CosNotifyComm.NotifySubscribe.Impl is use PolyORB.CORBA_P.Server_Tools; use PolyORB.Tasking.Mutexes; use PolyORB.Log; package L is new PolyORB.Log.Facility_Log ("notifysubscribe"); procedure O (Message : Standard.String; Level : Log_Level := Debug) renames L.Output; function C (Level : Log_Level := Debug) return Boolean renames L.Enabled; pragma Unreferenced (C); -- For conditional pragma Debug type Notify_Subscribe_Record is record This : Object_Ptr; end record; --------------------------- -- Ensure_Initialization -- --------------------------- procedure Ensure_Initialization; pragma Inline (Ensure_Initialization); -- Ensure that the Mutexes are initialized T_Initialized : Boolean := False; Self_Mutex : Mutex_Access; procedure Ensure_Initialization is begin if not T_Initialized then Create (Self_Mutex); T_Initialized := True; end if; end Ensure_Initialization; ------------------------- -- Subscription_Change -- ------------------------- procedure Subscription_Change (Self : access Object; Added : CosNotification.EventTypeSeq; Removed : CosNotification.EventTypeSeq) is pragma Warnings (Off); -- WAG:3.14 pragma Unreferenced (Self, Added, Removed); pragma Warnings (On); -- WAG:3.14 begin pragma Debug (O ("subscription_change in notifysubscribe")); Ensure_Initialization; Enter (Self_Mutex); Leave (Self_Mutex); end Subscription_Change; ------------ -- Create -- ------------ function Create return Object_Ptr is Subscribe : Object_Ptr; My_Ref : NotifySubscribe.Ref; begin pragma Debug (O ("create notifysubscribe")); Subscribe := new Object; Subscribe.X := new Notify_Subscribe_Record; Subscribe.X.This := Subscribe; Initiate_Servant (PortableServer.Servant (Subscribe), My_Ref); return Subscribe; end Create; end CosNotifyComm.NotifySubscribe.Impl; polyorb-2.8~20110207.orig/cos/notification/cosnotifyfilter-filter-impl.ads0000644000175000017500000001015111750740337026016 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- C O S N O T I F Y F I L T E R . F I L T E R . I M P L -- -- -- -- S p e c -- -- -- -- Copyright (C) 2003-2008, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by ACT Europe. -- -- (email: sales@act-europe.fr) -- -- -- ------------------------------------------------------------------------------ -- with CORBA; with PortableServer; package CosNotifyFilter.Filter.Impl is type Object is new PortableServer.Servant_Base with private; type Object_Ptr is access all Object'Class; -- IDL operations function Get_Constraint_Grammar (Self : access Object) return CORBA.String; function Add_Constraints (Self : access Object; Constraint_List : CosNotifyFilter.ConstraintExpSeq) return CosNotifyFilter.ConstraintInfoSeq; procedure Modify_Constraints (Self : access Object; Del_List : CosNotifyFilter.ConstraintIDSeq; Modify_List : CosNotifyFilter.ConstraintInfoSeq); function Get_Constraints (Self : access Object; Id_List : CosNotifyFilter.ConstraintIDSeq) return CosNotifyFilter.ConstraintInfoSeq; function Get_All_Constraints (Self : access Object) return CosNotifyFilter.ConstraintInfoSeq; procedure Remove_All_Constraints (Self : access Object); procedure Destroy (Self : access Object); function Match (Self : access Object; Filterable_Data : CORBA.Any) return CORBA.Boolean; function Match_Structured (Self : access Object; Filterable_Data : CosNotification.StructuredEvent) return CORBA.Boolean; function Match_Typed (Self : access Object; Filterable_Data : CosNotification.PropertySeq) return CORBA.Boolean; function Attach_Callback (Self : access Object; Callback : CosNotifyComm.NotifySubscribe.Ref) return CosNotifyFilter.CallbackID; procedure Detach_Callback (Self : access Object; Callback : CosNotifyFilter.CallbackID); function Get_Callbacks (Self : access Object) return CosNotifyFilter.CallbackIDSeq; ---------------------- -- PolyORB specific -- ---------------------- function Create return Object_Ptr; private type Filter_Record; type Filter_Access is access Filter_Record; type Object is new PortableServer.Servant_Base with record X : Filter_Access; end record; end CosNotifyFilter.Filter.Impl; polyorb-2.8~20110207.orig/cos/notification/cosnotifychanneladmin-sequenceproxypushsupplier-impl.ads0000644000175000017500000001313211750740337033265 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- COSNOTIFYCHANNELADMIN.SEQUENCEPROXYPUSHSUPPLIER.IMPL -- -- -- -- S p e c -- -- -- -- Copyright (C) 2003-2008, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by ACT Europe. -- -- (email: sales@act-europe.fr) -- -- -- ------------------------------------------------------------------------------ with CosNotifyChannelAdmin.ConsumerAdmin; with CosNotifyFilter.Filter; with CosNotifyFilter.MappingFilter; with PortableServer; package CosNotifyChannelAdmin.SequenceProxyPushSupplier.Impl is type Object is new PortableServer.Servant_Base with private; type Object_Ptr is access all Object'Class; -- IDL operations procedure Connect_Sequence_Push_consumer (Self : access Object; Push_Consumer : CosNotifyComm.SequencePushConsumer.Ref); procedure Suspend_Connection (Self : access Object); procedure Resume_Connection (Self : access Object); -- IDL operations inherited from CosNotifyChannelAdmin::ProxySupplier function Get_MyType (Self : access Object) return CosNotifyChannelAdmin.ProxyType; function Get_MyAdmin (Self : access Object) return CosNotifyChannelAdmin.ConsumerAdmin_Forward.Ref; function Get_Priority_Filter (Self : access Object) return CosNotifyFilter.MappingFilter.Ref; procedure Set_Priority_Filter (Self : access Object; To : CosNotifyFilter.MappingFilter.Ref); function Get_Lifetime_Filter (Self : access Object) return CosNotifyFilter.MappingFilter.Ref; procedure Set_Lifetime_Filter (Self : access Object; To : CosNotifyFilter.MappingFilter.Ref); function Obtain_Offered_Types (Self : access Object; Mode : CosNotifyChannelAdmin.ObtainInfoMode) return CosNotification.EventTypeSeq; procedure Validate_Event_QoS (Self : access Object; Required_QoS : CosNotification.QoSProperties; Available_QoS : out CosNotification.NamedPropertyRangeSeq); function Get_QoS (Self : access Object) return CosNotification.QoSProperties; procedure Set_QoS (Self : access Object; QoS : CosNotification.QoSProperties); procedure Validate_QoS (Self : access Object; Required_QoS : CosNotification.QoSProperties; Available_QoS : out CosNotification.NamedPropertyRangeSeq); function Add_Filter (Self : access Object; New_Filter : CosNotifyFilter.Filter.Ref) return CosNotifyFilter.FilterID; procedure Remove_Filter (Self : access Object; Filter : CosNotifyFilter.FilterID); function Get_Filter (Self : access Object; Filter : CosNotifyFilter.FilterID) return CosNotifyFilter.Filter.Ref; function Get_All_Filters (Self : access Object) return CosNotifyFilter.FilterIDSeq; procedure Remove_All_Filters (Self : access Object); -- IDL operations inherited from CosNotifyComm::StructuredPushSupplier procedure Subscription_Change (Self : access Object; Added : CosNotification.EventTypeSeq; Removed : CosNotification.EventTypeSeq); procedure Disconnect_Sequence_Push_Supplier (Self : access Object); ---------------------- -- PolyORB specific -- ---------------------- function Create (Admin : CosNotifyChannelAdmin.ConsumerAdmin.Ref; Initial_QoS : CosNotification.QoSProperties; Ptype : CosNotifyChannelAdmin.ProxyType; Proxy_Id : CosNotifyChannelAdmin.ProxyID) return Object_Ptr; procedure Sequence_Post (Self : access Object; Notifications : CosNotification.EventBatch); private type Sequence_Proxy_Push_Supplier_Record; type Sequence_Proxy_Push_Supplier_Access is access Sequence_Proxy_Push_Supplier_Record; type Object is new PortableServer.Servant_Base with record X : Sequence_Proxy_Push_Supplier_Access; end record; end CosNotifyChannelAdmin.SequenceProxyPushSupplier.Impl; ././@LongLink0000000000000000000000000000014600000000000011566 Lustar rootrootpolyorb-2.8~20110207.orig/cos/notification/cosnotifychanneladmin-structuredproxypushconsumer-impl.adbpolyorb-2.8~20110207.orig/cos/notification/cosnotifychanneladmin-structuredproxypushconsumer-impl.ad0000644000175000017500000006252611750740337033501 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- COSNOTIFYCHANNELADMIN.STRUCTUREDPROXYPUSHCONSUMER.IMPL -- -- -- -- B o d y -- -- -- -- Copyright (C) 2003-2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with CosEventChannelAdmin.Helper; with CosNotification; with CosNotification.Helper; with CosNotifyChannelAdmin.SupplierAdmin.Impl; with PolyORB.CORBA_P.Server_Tools; with PolyORB.Log; with PolyORB.Tasking.Mutexes; with CosNotifyChannelAdmin.StructuredProxyPushConsumer.Skel; pragma Warnings (Off, CosNotifyChannelAdmin.StructuredProxyPushConsumer.Skel); package body CosNotifyChannelAdmin.StructuredProxyPushConsumer.Impl is use CosNotification; use IDL_SEQUENCE_CosNotification_Property; use IDL_SEQUENCE_CosNotification_PropertyError; use IDL_SEQUENCE_CosNotification_NamedPropertyRange; use CORBA; package Convert is new SupplierAdmin_Forward.Convert (CosNotifyChannelAdmin.SupplierAdmin.Ref); use PolyORB.CORBA_P.Server_Tools; use PolyORB.Tasking.Mutexes; use PolyORB.Log; package L is new PolyORB.Log.Facility_Log ("structuredproxypushconsumer"); procedure O (Message : Standard.String; Level : Log_Level := Debug) renames L.Output; function C (Level : Log_Level := Debug) return Boolean renames L.Enabled; pragma Unreferenced (C); -- For conditional pragma Debug type Structured_Proxy_Push_Consumer_Record is record This : Object_Ptr; Admin : CosNotifyChannelAdmin.SupplierAdmin.Ref; MyId : CosNotifyChannelAdmin.ProxyID; MyType : CosNotifyChannelAdmin.ProxyType; Peer : CosNotifyComm.StructuredPushSupplier.Ref; QoSPropSeq : CosNotification.QoSProperties; end record; --------------------------- -- Ensure_Initialization -- --------------------------- procedure Ensure_Initialization; pragma Inline (Ensure_Initialization); -- Ensure that the Mutexes are initialized T_Initialized : Boolean := False; Self_Mutex : Mutex_Access; procedure Ensure_Initialization is begin if not T_Initialized then Create (Self_Mutex); T_Initialized := True; end if; end Ensure_Initialization; -------------------------------------- -- Connect_Structured_Push_Supplier -- -------------------------------------- procedure Connect_Structured_Push_Supplier (Self : access Object; Push_Supplier : CosNotifyComm.StructuredPushSupplier.Ref) is begin Ensure_Initialization; pragma Debug (O ("connect_structured_push_supplier in structuredproxypushconsumer")); Enter (Self_Mutex); if not CosNotifyComm.StructuredPushSupplier.Is_Nil (Self.X.Peer) then Leave (Self_Mutex); CosEventChannelAdmin.Helper.Raise_AlreadyConnected ((CORBA.IDL_Exception_Members with null record)); end if; Self.X.Peer := Push_Supplier; Leave (Self_Mutex); end Connect_Structured_Push_Supplier; ---------------- -- Get_MyType -- ---------------- function Get_MyType (Self : access Object) return CosNotifyChannelAdmin.ProxyType is MyType : CosNotifyChannelAdmin.ProxyType; begin Ensure_Initialization; pragma Debug (O ("get_mytype in structuredproxypushconsumer")); Enter (Self_Mutex); MyType := Self.X.MyType; Leave (Self_Mutex); return MyType; end Get_MyType; ----------------- -- Get_MyAdmin -- ----------------- function Get_MyAdmin (Self : access Object) return CosNotifyChannelAdmin.SupplierAdmin_Forward.Ref is MyAdmin : CosNotifyChannelAdmin.SupplierAdmin_Forward.Ref; begin Ensure_Initialization; pragma Debug (O ("get_myadmin in structuredproxypushconsumer")); Enter (Self_Mutex); MyAdmin := Convert.To_Forward (Self.X.Admin); Leave (Self_Mutex); return MyAdmin; end Get_MyAdmin; ------------------------------- -- Obtain_Subscription_Types -- ------------------------------- function Obtain_Subscription_Types (Self : access Object; Mode : CosNotifyChannelAdmin.ObtainInfoMode) return CosNotification.EventTypeSeq is pragma Warnings (Off); -- WAG:3.14 pragma Unreferenced (Self, Mode); pragma Warnings (On); -- WAG:3.14 MySeq : CosNotification.EventTypeSeq; begin Ensure_Initialization; pragma Debug (O ("obtain_subscription_types in structuredproxypushconsumer")); Enter (Self_Mutex); Leave (Self_Mutex); return MySeq; end Obtain_Subscription_Types; ------------------------ -- Validate_Event_QoS -- ------------------------ procedure Validate_Event_QoS (Self : access Object; Required_QoS : CosNotification.QoSProperties; Available_QoS : out CosNotification.NamedPropertyRangeSeq) is pragma Warnings (Off); -- WAG:3.14 pragma Unreferenced (Self, Required_QoS, Available_QoS); pragma Warnings (On); -- WAG:3.14 begin Ensure_Initialization; pragma Debug (O ("validate_event_qos in structuredproxypushconsumer")); Enter (Self_Mutex); Leave (Self_Mutex); end Validate_Event_QoS; ------------- -- Get_QoS -- ------------- function Get_QoS (Self : access Object) return CosNotification.QoSProperties is MyQoS : CosNotification.QoSProperties; begin Ensure_Initialization; pragma Debug (O ("get_qos in structuredproxypushconsumer")); Enter (Self_Mutex); MyQoS := Self.X.QoSPropSeq; Leave (Self_Mutex); return MyQoS; end Get_QoS; ------------- -- Set_QoS -- ------------- procedure Set_QoS (Self : access Object; QoS : CosNotification.QoSProperties) is MyProp : CosNotification.Property; MyError : CosNotification.PropertyError; MyErrCode : CosNotification.QoSError_code; MyRange : CosNotification.PropertyRange; MyErrorSeq : CosNotification.PropertyErrorSeq; SeqLen : Integer; begin Ensure_Initialization; pragma Debug (O ("set_qos in structuredproxypushconsumer")); SeqLen := Length (QoS); for Index in 1 .. SeqLen loop MyProp := Get_Element (QoS, Index); if MyProp.name = "EventReliability" then MyErrCode := UNAVAILABLE_PROPERTY; MyRange := (To_Any (CORBA.Short (0)), To_Any (CORBA.Short (0))); MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); elsif MyProp.name = "ConnectionReliability" then if CORBA.Short'(From_Any (MyProp.value)) /= 0 and then CORBA.Short'(From_Any (MyProp.value)) /= 1 then MyErrCode := BAD_VALUE; MyRange := (To_Any (CORBA.Short (0)), To_Any (CORBA.Short (0))); MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); end if; elsif MyProp.name = "Priority" then if CORBA.Short'(From_Any (MyProp.value)) not in -32_767 .. 32_767 then MyErrCode := BAD_VALUE; MyRange := (To_Any (CORBA.Short (-32767)), To_Any (CORBA.Short (32767))); MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); end if; elsif MyProp.name = "StartTime" then MyErrCode := UNAVAILABLE_PROPERTY; MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); elsif MyProp.name = "StopTime" then MyErrCode := UNAVAILABLE_PROPERTY; MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); elsif MyProp.name = "Timeout" then MyErrCode := UNSUPPORTED_PROPERTY; MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); elsif MyProp.name = "OrderPolicy" then if CORBA.Short'(From_Any (MyProp.value)) /= 0 and then CORBA.Short'(From_Any (MyProp.value)) /= 1 and then CORBA.Short'(From_Any (MyProp.value)) /= 2 and then CORBA.Short'(From_Any (MyProp.value)) /= 3 then MyErrCode := BAD_VALUE; MyRange := (To_Any (CORBA.Short (0)), To_Any (CORBA.Short (3))); MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); end if; elsif MyProp.name = "DiscardPolicy" then if CORBA.Short'(From_Any (MyProp.value)) /= 0 and then CORBA.Short'(From_Any (MyProp.value)) /= 1 and then CORBA.Short'(From_Any (MyProp.value)) /= 2 and then CORBA.Short'(From_Any (MyProp.value)) /= 3 and then CORBA.Short'(From_Any (MyProp.value)) /= 4 then MyErrCode := BAD_VALUE; MyRange := (To_Any (CORBA.Short (0)), To_Any (CORBA.Short (4))); MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); end if; elsif MyProp.name = "MaximumBatchSize" then MyErrCode := UNSUPPORTED_PROPERTY; MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); elsif MyProp.name = "PacingInterval" then MyErrCode := UNSUPPORTED_PROPERTY; MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); elsif MyProp.name = "StartTimeSupported" then MyErrCode := UNSUPPORTED_PROPERTY; MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); elsif MyProp.name = "StopTimeSupported" then MyErrCode := UNSUPPORTED_PROPERTY; MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); elsif MyProp.name = "MaxEventsPerConsumer" then MyErrCode := UNSUPPORTED_PROPERTY; MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); else MyErrCode := BAD_PROPERTY; MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); end if; end loop; if Length (MyErrorSeq) > 0 then CosNotification.Helper.Raise_UnsupportedQoS ((CORBA.IDL_Exception_Members with qos_err => MyErrorSeq)); end if; SeqLen := Length (QoS); Enter (Self_Mutex); for Index in 1 .. SeqLen loop MyProp := Get_Element (QoS, Index); if MyProp.name = "ConnectionReliability" then Replace_Element (Self.X.QoSPropSeq, 2, MyProp); elsif MyProp.name = "Priority" then Replace_Element (Self.X.QoSPropSeq, 3, MyProp); elsif MyProp.name = "OrderPolicy" then Replace_Element (Self.X.QoSPropSeq, 4, MyProp); elsif MyProp.name = "DiscardPolicy" then Replace_Element (Self.X.QoSPropSeq, 5, MyProp); end if; end loop; Leave (Self_Mutex); end Set_QoS; ------------------ -- Validate_QoS -- ------------------ procedure Validate_QoS (Self : access Object; Required_QoS : CosNotification.QoSProperties; Available_QoS : out CosNotification.NamedPropertyRangeSeq) is MyProp : CosNotification.Property; MyError : CosNotification.PropertyError; MyErrCode : CosNotification.QoSError_code; MyNamedRange : CosNotification.NamedPropertyRange; MyRange : CosNotification.PropertyRange; MyErrorSeq : CosNotification.PropertyErrorSeq; SeqLen : Integer; begin Ensure_Initialization; pragma Debug (O ("validate_qos in structuredproxypushconsumer")); SeqLen := Length (Required_QoS); for Index in 1 .. SeqLen loop MyProp := Get_Element (Required_QoS, Index); if MyProp.name = "EventReliability" then MyErrCode := UNAVAILABLE_PROPERTY; MyRange := (To_Any (CORBA.Short (0)), To_Any (CORBA.Short (0))); MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); elsif MyProp.name = "ConnectionReliability" then if CORBA.Short'(From_Any (MyProp.value)) /= 0 and then CORBA.Short'(From_Any (MyProp.value)) /= 1 then MyErrCode := BAD_VALUE; MyRange := (To_Any (CORBA.Short (0)), To_Any (CORBA.Short (0))); MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); end if; elsif MyProp.name = "Priority" then if CORBA.Short'(From_Any (MyProp.value)) not in -32_767 .. 32_767 then MyErrCode := BAD_VALUE; MyRange := (To_Any (CORBA.Short (-32767)), To_Any (CORBA.Short (32767))); MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); end if; elsif MyProp.name = "StartTime" then MyErrCode := UNAVAILABLE_PROPERTY; MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); elsif MyProp.name = "StopTime" then MyErrCode := UNAVAILABLE_PROPERTY; MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); elsif MyProp.name = "Timeout" then MyErrCode := UNSUPPORTED_PROPERTY; MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); elsif MyProp.name = "OrderPolicy" then if CORBA.Short'(From_Any (MyProp.value)) /= 0 and then CORBA.Short'(From_Any (MyProp.value)) /= 1 and then CORBA.Short'(From_Any (MyProp.value)) /= 2 and then CORBA.Short'(From_Any (MyProp.value)) /= 3 then MyErrCode := BAD_VALUE; MyRange := (To_Any (CORBA.Short (0)), To_Any (CORBA.Short (3))); MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); end if; elsif MyProp.name = "DiscardPolicy" then if CORBA.Short'(From_Any (MyProp.value)) /= 0 and then CORBA.Short'(From_Any (MyProp.value)) /= 1 and then CORBA.Short'(From_Any (MyProp.value)) /= 2 and then CORBA.Short'(From_Any (MyProp.value)) /= 3 and then CORBA.Short'(From_Any (MyProp.value)) /= 4 then MyErrCode := BAD_VALUE; MyRange := (To_Any (CORBA.Short (0)), To_Any (CORBA.Short (4))); MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); end if; elsif MyProp.name = "MaximumBatchSize" then MyErrCode := UNSUPPORTED_PROPERTY; MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); elsif MyProp.name = "PacingInterval" then MyErrCode := UNSUPPORTED_PROPERTY; MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); elsif MyProp.name = "StartTimeSupported" then MyErrCode := UNSUPPORTED_PROPERTY; MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); elsif MyProp.name = "StopTimeSupported" then MyErrCode := UNSUPPORTED_PROPERTY; MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); elsif MyProp.name = "MaxEventsPerConsumer" then MyErrCode := UNSUPPORTED_PROPERTY; MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); else MyErrCode := BAD_PROPERTY; MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); end if; end loop; if Length (MyErrorSeq) > 0 then CosNotification.Helper.Raise_UnsupportedQoS ((CORBA.IDL_Exception_Members with qos_err => MyErrorSeq)); end if; Enter (Self_Mutex); SeqLen := Length (Self.X.QoSPropSeq); for Index in 1 .. SeqLen loop MyProp := Get_Element (Self.X.QoSPropSeq, Index); if MyProp.name = "ConnectionReliability" then MyRange := (From_Any (MyProp.value), To_Any (CORBA.Short (0))); MyNamedRange := (MyProp.name, MyRange); Append (Available_QoS, MyNamedRange); elsif MyProp.name = "Priority" then MyRange := (To_Any (CORBA.Short (-32767)), To_Any (CORBA.Short (32767))); MyNamedRange := (MyProp.name, MyRange); Append (Available_QoS, MyNamedRange); elsif MyProp.name = "OrderPolicy" then MyRange := (To_Any (CORBA.Short (0)), To_Any (CORBA.Short (3))); MyNamedRange := (MyProp.name, MyRange); Append (Available_QoS, MyNamedRange); elsif MyProp.name = "DiscardPolicy" then MyRange := (To_Any (CORBA.Short (0)), To_Any (CORBA.Short (4))); MyNamedRange := (MyProp.name, MyRange); Append (Available_QoS, MyNamedRange); end if; end loop; Leave (Self_Mutex); end Validate_QoS; ---------------- -- Add_Filter -- ---------------- function Add_Filter (Self : access Object; New_Filter : CosNotifyFilter.Filter.Ref) return CosNotifyFilter.FilterID is pragma Warnings (Off); -- WAG:3.14 pragma Unreferenced (Self, New_Filter); pragma Warnings (On); -- WAG:3.14 MyFilterID : CosNotifyFilter.FilterID; MyID : CORBA.Long; begin Ensure_Initialization; pragma Debug (O ("add_filter in structuredproxypushconsumer")); Enter (Self_Mutex); Leave (Self_Mutex); MyID := 0; MyFilterID := CosNotifyFilter.FilterID (MyID); return MyFilterID; end Add_Filter; ------------------- -- Remove_Filter -- ------------------- procedure Remove_Filter (Self : access Object; Filter : CosNotifyFilter.FilterID) is pragma Warnings (Off); -- WAG:3.14 pragma Unreferenced (Self, Filter); pragma Warnings (On); -- WAG:3.14 begin Ensure_Initialization; pragma Debug (O ("remove_filter in structuredproxypushconsumer")); Enter (Self_Mutex); Leave (Self_Mutex); end Remove_Filter; ---------------- -- Get_Filter -- ---------------- function Get_Filter (Self : access Object; Filter : CosNotifyFilter.FilterID) return CosNotifyFilter.Filter.Ref is pragma Warnings (Off); -- WAG:3.14 pragma Unreferenced (Self, Filter); pragma Warnings (On); -- WAG:3.14 MyFilter : CosNotifyFilter.Filter.Ref; begin Ensure_Initialization; pragma Debug (O ("get_filter in structuredproxypushconsumer")); Enter (Self_Mutex); Leave (Self_Mutex); return MyFilter; end Get_Filter; --------------------- -- Get_All_Filters -- --------------------- function Get_All_Filters (Self : access Object) return CosNotifyFilter.FilterIDSeq is pragma Warnings (Off); -- WAG:3.14 pragma Unreferenced (Self); pragma Warnings (On); -- WAG:3.14 MyFilterSeq : CosNotifyFilter.FilterIDSeq; begin Ensure_Initialization; pragma Debug (O ("get_all_filters in structuredproxypushconsumer")); Enter (Self_Mutex); Leave (Self_Mutex); return MyFilterSeq; end Get_All_Filters; ------------------------ -- Remove_All_Filters -- ------------------------ procedure Remove_All_Filters (Self : access Object) is pragma Warnings (Off); -- WAG:3.14 pragma Unreferenced (Self); pragma Warnings (On); -- WAG:3.14 begin Ensure_Initialization; pragma Debug (O ("remove_all_filters in structuredproxypushconsumer")); Enter (Self_Mutex); Leave (Self_Mutex); end Remove_All_Filters; ------------------ -- Offer_Change -- ------------------ procedure Offer_Change (Self : access Object; Added : CosNotification.EventTypeSeq; Removed : CosNotification.EventTypeSeq) is pragma Warnings (Off); -- WAG:3.14 pragma Unreferenced (Self, Added, Removed); pragma Warnings (On); -- WAG:3.14 begin Ensure_Initialization; pragma Debug (O ("offer_change in structuredproxypushconsumer")); Enter (Self_Mutex); Leave (Self_Mutex); end Offer_Change; --------------------------- -- Push_Structured_Event -- --------------------------- procedure Push_Structured_Event (Self : access Object; Notification : CosNotification.StructuredEvent) is Admin : CosNotifyChannelAdmin.SupplierAdmin.Impl.Object_Ptr; Admin_Ref : CosNotifyChannelAdmin.SupplierAdmin.Ref; begin Ensure_Initialization; pragma Debug (O ("push new structured event from structuredproxypushconsumer " & "to supplier admin")); Enter (Self_Mutex); Admin_Ref := Self.X.Admin; Leave (Self_Mutex); Reference_To_Servant (Admin_Ref, PortableServer.Servant (Admin)); CosNotifyChannelAdmin.SupplierAdmin.Impl.Structured_Post (Admin, Notification); end Push_Structured_Event; ----------------------------------------- -- Disconnect_Structured_Push_Consumer -- ----------------------------------------- procedure Disconnect_Structured_Push_Consumer (Self : access Object) is Peer : CosNotifyComm.StructuredPushSupplier.Ref; Nil_Ref : CosNotifyComm.StructuredPushSupplier.Ref; begin Ensure_Initialization; pragma Debug (O ("disconnect structuredproxypushconsumer")); Enter (Self_Mutex); Peer := Self.X.Peer; Self.X.Peer := Nil_Ref; Leave (Self_Mutex); if not CosNotifyComm.StructuredPushSupplier.Is_Nil (Peer) then CosNotifyComm.StructuredPushSupplier. disconnect_structured_push_supplier (Peer); end if; end Disconnect_Structured_Push_Consumer; ------------ -- Create -- ------------ function Create (Admin : CosNotifyChannelAdmin.SupplierAdmin.Ref; Initial_QoS : CosNotification.QoSProperties; Ptype : CosNotifyChannelAdmin.ProxyType; Proxy_Id : CosNotifyChannelAdmin.ProxyID) return Object_Ptr is Consumer : Object_Ptr; My_Ref : StructuredProxyPushConsumer.Ref; begin pragma Debug (O ("create structuredproxypushconsumer")); Consumer := new Object; Consumer.X := new Structured_Proxy_Push_Consumer_Record; Consumer.X.Admin := Admin; Consumer.X.MyId := Proxy_Id; Consumer.X.MyType := Ptype; Consumer.X.This := Consumer; Consumer.X.QoSPropSeq := Initial_QoS; Initiate_Servant (PortableServer.Servant (Consumer), My_Ref); return Consumer; end Create; end CosNotifyChannelAdmin.StructuredProxyPushConsumer.Impl; polyorb-2.8~20110207.orig/cos/notification/cosnotifychanneladmin-proxypullconsumer-impl.ads0000644000175000017500000001165411750740337031530 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- COSNOTIFYCHANNELADMIN.PROXYPULLCONSUMER.IMPL -- -- -- -- S p e c -- -- -- -- Copyright (C) 2003-2008, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by ACT Europe. -- -- (email: sales@act-europe.fr) -- -- -- ------------------------------------------------------------------------------ with CosNotifyChannelAdmin.SupplierAdmin; with CosNotifyFilter.Filter; with PortableServer; package CosNotifyChannelAdmin.ProxyPullConsumer.Impl is type Object is new PortableServer.Servant_Base with private; type Object_Ptr is access all Object'Class; -- IDL Operations procedure Connect_Any_Pull_Supplier (Self : access Object; Pull_Supplier : CosEventComm.PullSupplier.Ref); procedure Suspend_Connection (Self : access Object); procedure Resume_Connection (Self : access Object); -- IDL operations inherited from CosNotifyChannelAdmin::ProxyConsumer function Get_MyType (Self : access Object) return CosNotifyChannelAdmin.ProxyType; function Get_MyAdmin (Self : access Object) return CosNotifyChannelAdmin.SupplierAdmin_Forward.Ref; function Obtain_Subscription_Types (Self : access Object; Mode : CosNotifyChannelAdmin.ObtainInfoMode) return CosNotification.EventTypeSeq; procedure Validate_Event_QoS (Self : access Object; Required_QoS : CosNotification.QoSProperties; Available_QoS : out CosNotification.NamedPropertyRangeSeq); function Get_QoS (Self : access Object) return CosNotification.QoSProperties; procedure Set_QoS (Self : access Object; QoS : CosNotification.QoSProperties); procedure Validate_QoS (Self : access Object; Required_QoS : CosNotification.QoSProperties; Available_QoS : out CosNotification.NamedPropertyRangeSeq); function Add_Filter (Self : access Object; New_Filter : CosNotifyFilter.Filter.Ref) return CosNotifyFilter.FilterID; procedure Remove_Filter (Self : access Object; Filter : CosNotifyFilter.FilterID); function Get_Filter (Self : access Object; Filter : CosNotifyFilter.FilterID) return CosNotifyFilter.Filter.Ref; function Get_All_Filters (Self : access Object) return CosNotifyFilter.FilterIDSeq; procedure Remove_All_Filters (Self : access Object); -- Inherited IDL operations from CosNotifyComm::PullConsumer procedure Offer_Change (Self : access Object; Added : CosNotification.EventTypeSeq; Removed : CosNotification.EventTypeSeq); procedure Disconnect_Pull_Consumer (Self : access Object); ---------------------- -- PolyORB specific -- ---------------------- function Create (Admin : CosNotifyChannelAdmin.SupplierAdmin.Ref; Initial_QoS : CosNotification.QoSProperties; Ptype : CosNotifyChannelAdmin.ProxyType; Proxy_Id : CosNotifyChannelAdmin.ProxyID) return Object_Ptr; private type Proxy_Pull_Consumer_Record; type Proxy_Pull_Consumer_Access is access Proxy_Pull_Consumer_Record; type Object is new PortableServer.Servant_Base with record X : Proxy_Pull_Consumer_Access; end record; end CosNotifyChannelAdmin.ProxyPullConsumer.Impl; polyorb-2.8~20110207.orig/cos/notification/cosnotifycomm-structuredpullconsumer-impl.ads0000644000175000017500000000714211750740337031062 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- COSNOTIFYCOMM.STRUCTUREDPULLCONSUMER.IMPL -- -- -- -- S p e c -- -- -- -- Copyright (C) 2003-2008, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by ACT Europe. -- -- (email: sales@act-europe.fr) -- -- -- ------------------------------------------------------------------------------ with PortableServer; with CosNotifyChannelAdmin.StructuredProxyPullSupplier; package CosNotifyComm.StructuredPullConsumer.Impl is type Object is new PortableServer.Servant_Base with private; type Object_Ptr is access all Object'Class; -- Inherited IDL operations from CosNotifyComm::NotifyPublish procedure Offer_Change (Self : access Object; Added : CosNotification.EventTypeSeq; Removed : CosNotification.EventTypeSeq); -- IDL operations procedure Disconnect_Structured_Pull_Consumer (Self : access Object); ---------------------- -- PolyORB specific -- ---------------------- function Create return Object_Ptr; -- Call by application to create an object and activate servant procedure Connect_Structured_Proxy_Pull_Supplier (Self : access Object; Proxy : CosNotifyChannelAdmin.StructuredProxyPullSupplier.Ref); -- Call by application to connect object to proxy function Pull (Self : access Object) return CosNotification.StructuredEvent; -- Call by application to consume a structured event procedure Try_Pull (Self : access Object; Done : out CORBA.Boolean; Returns : out CosNotification.StructuredEvent); -- Call by application to try to consume a structured event private type Structured_Pull_Consumer_Record; type Structured_Pull_Consumer_Access is access Structured_Pull_Consumer_Record; type Object is new PortableServer.Servant_Base with record X : Structured_Pull_Consumer_Access; end record; end CosNotifyComm.StructuredPullConsumer.Impl; polyorb-2.8~20110207.orig/cos/notification/cosnotifycomm-pushconsumer-impl.adb0000644000175000017500000002052111750740337026713 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- C O S N O T I F Y C O M M . P U S H C O N S U M E R . I M P L -- -- -- -- B o d y -- -- -- -- Copyright (C) 2003-2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with CosEventChannelAdmin.Helper; with CosEventComm.Helper; with CosEventComm.PushConsumer.Helper; with PolyORB.CORBA_P.Server_Tools; with PolyORB.Log; with PolyORB.Tasking.Mutexes; with PolyORB.Tasking.Semaphores; with CosNotifyComm.PushConsumer.Skel; pragma Warnings (Off, CosNotifyComm.PushConsumer.Skel); package body CosNotifyComm.PushConsumer.Impl is use PolyORB.CORBA_P.Server_Tools; use PolyORB.Tasking.Mutexes; use PolyORB.Tasking.Semaphores; use PolyORB.Log; package L is new PolyORB.Log.Facility_Log ("pushconsumer"); procedure O (Message : Standard.String; Level : Log_Level := Debug) renames L.Output; function C (Level : Log_Level := Debug) return Boolean renames L.Enabled; pragma Unreferenced (C); -- For conditional pragma Debug type Push_Consumer_Record is record This : Object_Ptr; Empty : Boolean; Event : CORBA.Any; Peer : CosNotifyChannelAdmin.ProxyPushSupplier.Ref; Semaphore : Semaphore_Access; end record; --------------------------- -- Ensure_Initialization -- --------------------------- procedure Ensure_Initialization; pragma Inline (Ensure_Initialization); -- Ensure that the Mutexes are initialized T_Initialized : Boolean := False; Self_Mutex : Mutex_Access; procedure Ensure_Initialization is begin if not T_Initialized then Create (Self_Mutex); T_Initialized := True; end if; end Ensure_Initialization; ------------------ -- Offer_Change -- ------------------ procedure Offer_Change (Self : access Object; Added : CosNotification.EventTypeSeq; Removed : CosNotification.EventTypeSeq) is pragma Warnings (Off); -- WAG:3.14 pragma Unreferenced (Self, Added, Removed); pragma Warnings (On); -- WAG:3.14 begin Ensure_Initialization; pragma Debug (O ("offer_change in pushconsumer")); Enter (Self_Mutex); Leave (Self_Mutex); end Offer_Change; ---------- -- Push -- ---------- procedure Push (Self : access Object; Data : CORBA.Any) is begin Ensure_Initialization; pragma Debug (O ("push new data to push consumer")); Enter (Self_Mutex); Self.X.Empty := False; Self.X.Event := Data; Leave (Self_Mutex); V (Self.X.Semaphore); end Push; ------------------------------ -- Disconnect_Push_Consumer -- ------------------------------ procedure Disconnect_Push_Consumer (Self : access Object) is Peer : CosNotifyChannelAdmin.ProxyPushSupplier.Ref; Nil_Ref : CosNotifyChannelAdmin.ProxyPushSupplier.Ref; begin pragma Debug (O ("disconnect push consumer")); Ensure_Initialization; Enter (Self_Mutex); Peer := Self.X.Peer; Self.X.Peer := Nil_Ref; Leave (Self_Mutex); V (Self.X.Semaphore); if not CosNotifyChannelAdmin.ProxyPushSupplier.Is_Nil (Peer) then CosNotifyChannelAdmin.ProxyPushSupplier.disconnect_push_supplier (Peer); end if; end Disconnect_Push_Consumer; ------------ -- Create -- ------------ function Create return Object_Ptr is Consumer : Object_Ptr; My_Ref : PushConsumer.Ref; Peer_Ref : CosNotifyChannelAdmin.ProxyPushSupplier.Ref; begin pragma Debug (O ("create pushconsumer")); Consumer := new Object; Consumer.X := new Push_Consumer_Record; Consumer.X.This := Consumer; Consumer.X.Empty := True; Consumer.X.Peer := Peer_Ref; Create (Consumer.X.Semaphore); Initiate_Servant (PortableServer.Servant (Consumer), My_Ref); return Consumer; end Create; ------------------------------------- -- Connect_Any_Proxy_Push_Supplier -- ------------------------------------- procedure Connect_Any_Proxy_Push_Supplier (Self : access Object; Proxy : CosNotifyChannelAdmin.ProxyPushSupplier.Ref) is Cons_Ref : CosEventComm.PushConsumer.Ref; My_Ref : PushConsumer.Ref; begin Ensure_Initialization; pragma Debug (O ("connect_any_proxy_push_supplier in pushconsumer")); Enter (Self_Mutex); if not CosNotifyChannelAdmin.ProxyPushSupplier.Is_Nil (Self.X.Peer) then Leave (Self_Mutex); CosEventChannelAdmin.Helper.Raise_AlreadyConnected ((CORBA.IDL_Exception_Members with null record)); end if; Self.X.Peer := Proxy; Servant_To_Reference (PortableServer.Servant (Self.X.This), My_Ref); Leave (Self_Mutex); Cons_Ref := CosEventComm.PushConsumer.Helper.To_Ref (My_Ref); CosNotifyChannelAdmin.ProxyPushSupplier.connect_any_push_consumer (Proxy, Cons_Ref); end Connect_Any_Proxy_Push_Supplier; ---------- -- Pull -- ---------- function Pull (Self : access Object) return CORBA.Any is Event : CORBA.Any; begin Ensure_Initialization; loop pragma Debug (O ("attempt to pull new data from pushconsumer")); P (Self.X.Semaphore); Enter (Self_Mutex); if CosNotifyChannelAdmin.ProxyPushSupplier.Is_Nil (Self.X.Peer) then Leave (Self_Mutex); CosEventComm.Helper.Raise_Disconnected ((CORBA.IDL_Exception_Members with null record)); end if; if not Self.X.Empty then Self.X.Empty := True; Event := Self.X.Event; Leave (Self_Mutex); exit; end if; Leave (Self_Mutex); end loop; pragma Debug (O ("succeded to pull new data from pushconsumer")); return Event; end Pull; -------------- -- Try_Pull -- -------------- procedure Try_Pull (Self : access Object; Done : out CORBA.Boolean; Data : out CORBA.Any) is begin pragma Debug (O ("try to pull new data from push consumer")); Ensure_Initialization; Enter (Self_Mutex); if CosNotifyChannelAdmin.ProxyPushSupplier.Is_Nil (Self.X.Peer) then Leave (Self_Mutex); CosEventComm.Helper.Raise_Disconnected ((CORBA.IDL_Exception_Members with null record)); end if; Done := not Self.X.Empty; if Done then Self.X.Empty := True; Data := Self.X.Event; end if; Leave (Self_Mutex); end Try_Pull; end CosNotifyComm.PushConsumer.Impl; ././@LongLink0000000000000000000000000000014600000000000011566 Lustar rootrootpolyorb-2.8~20110207.orig/cos/notification/cosnotifychanneladmin-structuredproxypullconsumer-impl.adbpolyorb-2.8~20110207.orig/cos/notification/cosnotifychanneladmin-structuredproxypullconsumer-impl.ad0000644000175000017500000007034211750740337033471 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- COSNOTIFYCHANNELADMIN.STRUCTUREDPROXYPULLCONSUMER.IMPL -- -- -- -- B o d y -- -- -- -- Copyright (C) 2003-2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with CORBA.Impl; with CosEventChannelAdmin.Helper; with CosNotification; with CosNotification.Helper; with CosNotifyChannelAdmin.SupplierAdmin.Impl; with PolyORB.CORBA_P.Server_Tools; with PolyORB.Log; with PolyORB.Tasking.Threads; with PolyORB.Tasking.Mutexes; with PolyORB.Tasking.Condition_Variables; with CosNotifyChannelAdmin.StructuredProxyPullConsumer.Skel; pragma Warnings (Off, CosNotifyChannelAdmin.StructuredProxyPullConsumer.Skel); package body CosNotifyChannelAdmin.StructuredProxyPullConsumer.Impl is use CosNotification; use IDL_SEQUENCE_CosNotification_Property; use IDL_SEQUENCE_CosNotification_PropertyError; use IDL_SEQUENCE_CosNotification_NamedPropertyRange; use CORBA; use PortableServer; package Convert is new SupplierAdmin_Forward.Convert (CosNotifyChannelAdmin.SupplierAdmin.Ref); use PolyORB.Tasking.Condition_Variables; use PolyORB.Tasking.Mutexes; use PolyORB.Tasking.Threads; use PolyORB.CORBA_P.Server_Tools; use PolyORB.Log; package L is new PolyORB.Log.Facility_Log ("structuredproxypullconsumer"); procedure O (Message : Standard.String; Level : Log_Level := Debug) renames L.Output; function C (Level : Log_Level := Debug) return Boolean renames L.Enabled; pragma Unreferenced (C); -- For conditional pragma Debug type Structured_Proxy_Pull_Consumer_Record is record This : Object_Ptr; Admin : CosNotifyChannelAdmin.SupplierAdmin.Ref; MyId : CosNotifyChannelAdmin.ProxyID; MyType : CosNotifyChannelAdmin.ProxyType; Peer : CosNotifyComm.StructuredPullSupplier.Ref; QoSPropSeq : CosNotification.QoSProperties; Engin_Launched : Boolean := False; -- is there a thread launch for the engine end record; A_S : Object_Ptr := null; -- This variable is used to initialize the threads local variable. -- it is used to replace the 'accept' statement. Session_Mutex : Mutex_Access; Session_Taken : Condition_Access; -- Synchornisation of task initialization. Peer_Mutex : Mutex_Access; -- Protect access on a peer component T_Initialized : Boolean := False; procedure Ensure_Initialization; pragma Inline (Ensure_Initialization); -- Ensure that the Mutexes are initialized --------------------------- -- Ensure_Initialization -- --------------------------- procedure Ensure_Initialization is begin if T_Initialized then return; end if; Create (Session_Mutex); Create (Session_Taken); Create (Peer_Mutex); T_Initialized := True; end Ensure_Initialization; -------------------------------- -- Proxy_Pull_Consumer_Engine -- -------------------------------- procedure Proxy_Pull_Consumer_Engine; procedure Proxy_Pull_Consumer_Engine is This : Object_Ptr; Peer : CosNotifyComm.StructuredPullSupplier.Ref; Event : CosNotification.StructuredEvent; Obj : CORBA.Impl.Object_Ptr; begin pragma Debug (O ("Session Thread number " & Image (Current_Task) & " is starting")); -- Signal end of thread initialization. Ensure_Initialization; -- Thread initialization. -- A_S is a global variable used to pass an argument to this task This := A_S; -- This is initialized -- we can let Connect_Structured_Pull_Supplier go Enter (Session_Mutex); Signal (Session_Taken); Leave (Session_Mutex); loop -- Session thread main loop. Enter (Peer_Mutex); Peer := This.X.Peer; Leave (Peer_Mutex); exit when CosNotifyComm.StructuredPullSupplier.Is_Nil (Peer); pragma Debug (O ("pull structured event from structuredproxypullconsumer engin")); begin Event := CosNotifyComm.StructuredPullSupplier.pull_structured_event (Peer); exception when others => exit; end; pragma Debug (O ("post structured event from structuredproxypullconsumer " & "to admin")); Reference_To_Servant (This.X.Admin, Servant (Obj)); CosNotifyChannelAdmin.SupplierAdmin.Impl.Structured_Post (CosNotifyChannelAdmin.SupplierAdmin.Impl.Object_Ptr (Obj), Event); end loop; This.X.Engin_Launched := False; end Proxy_Pull_Consumer_Engine; -------------------------------------- -- Connect_Structured_Pull_Supplier -- -------------------------------------- procedure Connect_Structured_Pull_Supplier (Self : access Object; Pull_Supplier : CosNotifyComm.StructuredPullSupplier.Ref) is begin Ensure_Initialization; pragma Debug (O ("connect_structured_pull_supplier in structuredproxypullconsumer")); Enter (Session_Mutex); if not CosNotifyComm.StructuredPullSupplier.Is_Nil (Self.X.Peer) then Leave (Session_Mutex); CosEventChannelAdmin.Helper.Raise_AlreadyConnected ((CORBA.IDL_Exception_Members with null record)); end if; Self.X.Peer := Pull_Supplier; A_S := Self.X.This; -- Start engin if not Self.X.Engin_Launched then Create_Task (Proxy_Pull_Consumer_Engine'Access); Self.X.Engin_Launched := True; -- thread created end if; -- wait A_S initialization in Proxy_Pull_Consumer_Engin Wait (Session_Taken, Session_Mutex); Leave (Session_Mutex); end Connect_Structured_Pull_Supplier; ------------------------ -- Suspend_Connection -- ------------------------ procedure Suspend_Connection (Self : access Object) is pragma Warnings (Off); -- WAG:3.14 pragma Unreferenced (Self); pragma Warnings (On); -- WAG:3.14 begin Ensure_Initialization; pragma Debug (O ("suspend_connection in structuredproxypullconsumer")); Enter (Peer_Mutex); Leave (Peer_Mutex); end Suspend_Connection; ----------------------- -- Resume_Connection -- ----------------------- procedure Resume_Connection (Self : access Object) is pragma Warnings (Off); -- WAG:3.14 pragma Unreferenced (Self); pragma Warnings (On); -- WAG:3.14 begin Ensure_Initialization; pragma Debug (O ("resume_connection in structuredproxypullconsumer")); Enter (Peer_Mutex); Leave (Peer_Mutex); end Resume_Connection; ---------------- -- Get_MyType -- ---------------- function Get_MyType (Self : access Object) return CosNotifyChannelAdmin.ProxyType is MyType : CosNotifyChannelAdmin.ProxyType; begin Ensure_Initialization; pragma Debug (O ("get_mytype in structuredproxypullconsumer")); Enter (Peer_Mutex); MyType := Self.X.MyType; Leave (Peer_Mutex); return MyType; end Get_MyType; ----------------- -- Get_MyAdmin -- ----------------- function Get_MyAdmin (Self : access Object) return CosNotifyChannelAdmin.SupplierAdmin_Forward.Ref is MyAdmin : CosNotifyChannelAdmin.SupplierAdmin_Forward.Ref; begin Ensure_Initialization; pragma Debug (O ("get_myadmin in structuredproxypullconsumer")); Enter (Peer_Mutex); MyAdmin := Convert.To_Forward (Self.X.Admin); Leave (Peer_Mutex); return MyAdmin; end Get_MyAdmin; ------------------------------- -- Obtain_Subscription_Types -- ------------------------------- function Obtain_Subscription_Types (Self : access Object; Mode : CosNotifyChannelAdmin.ObtainInfoMode) return CosNotification.EventTypeSeq is pragma Warnings (Off); -- WAG:3.14 pragma Unreferenced (Self, Mode); pragma Warnings (On); -- WAG:3.14 MySeq : CosNotification.EventTypeSeq; begin Ensure_Initialization; pragma Debug (O ("obtain_subscription_types in structuredproxypullconsumer")); Enter (Peer_Mutex); Leave (Peer_Mutex); return MySeq; end Obtain_Subscription_Types; ------------------------ -- Validate_Event_QoS -- ------------------------ procedure Validate_Event_QoS (Self : access Object; Required_QoS : CosNotification.QoSProperties; Available_QoS : out CosNotification.NamedPropertyRangeSeq) is pragma Warnings (Off); -- WAG:3.14 pragma Unreferenced (Self, Required_QoS, Available_QoS); pragma Warnings (On); -- WAG:3.14 begin Ensure_Initialization; pragma Debug (O ("validate_event_qos in structuredproxypullconsumer")); Enter (Peer_Mutex); Leave (Peer_Mutex); end Validate_Event_QoS; ------------- -- Get_QoS -- ------------- function Get_QoS (Self : access Object) return CosNotification.QoSProperties is MyQoS : CosNotification.QoSProperties; begin Ensure_Initialization; pragma Debug (O ("get_qos in structuredproxypullconsumer")); Enter (Peer_Mutex); MyQoS := Self.X.QoSPropSeq; Leave (Peer_Mutex); return MyQoS; end Get_QoS; ------------- -- Set_QoS -- ------------- procedure Set_QoS (Self : access Object; QoS : CosNotification.QoSProperties) is MyProp : CosNotification.Property; MyError : CosNotification.PropertyError; MyErrCode : CosNotification.QoSError_code; MyRange : CosNotification.PropertyRange; MyErrorSeq : CosNotification.PropertyErrorSeq; SeqLen : Integer; begin Ensure_Initialization; pragma Debug (O ("set_qos in structuredproxypullconsumer")); SeqLen := Length (QoS); for Index in 1 .. SeqLen loop MyProp := Get_Element (QoS, Index); if MyProp.name = "EventReliability" then MyErrCode := UNAVAILABLE_PROPERTY; MyRange := (To_Any (CORBA.Short (0)), To_Any (CORBA.Short (0))); MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); elsif MyProp.name = "ConnectionReliability" then if CORBA.Short'(From_Any (MyProp.value)) /= 0 and then CORBA.Short'(From_Any (MyProp.value)) /= 1 then MyErrCode := BAD_VALUE; MyRange := (To_Any (CORBA.Short (0)), To_Any (CORBA.Short (0))); MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); end if; elsif MyProp.name = "Priority" then if CORBA.Short'(From_Any (MyProp.value)) not in -32_767 .. 32_767 then MyErrCode := BAD_VALUE; MyRange := (To_Any (CORBA.Short (-32767)), To_Any (CORBA.Short (32767))); MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); end if; elsif MyProp.name = "StartTime" then MyErrCode := UNAVAILABLE_PROPERTY; MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); elsif MyProp.name = "StopTime" then MyErrCode := UNAVAILABLE_PROPERTY; MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); elsif MyProp.name = "Timeout" then MyErrCode := UNSUPPORTED_PROPERTY; MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); elsif MyProp.name = "OrderPolicy" then if CORBA.Short'(From_Any (MyProp.value)) /= 0 and then CORBA.Short'(From_Any (MyProp.value)) /= 1 and then CORBA.Short'(From_Any (MyProp.value)) /= 2 and then CORBA.Short'(From_Any (MyProp.value)) /= 3 then MyErrCode := BAD_VALUE; MyRange := (To_Any (CORBA.Short (0)), To_Any (CORBA.Short (3))); MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); end if; elsif MyProp.name = "DiscardPolicy" then if CORBA.Short'(From_Any (MyProp.value)) /= 0 and then CORBA.Short'(From_Any (MyProp.value)) /= 1 and then CORBA.Short'(From_Any (MyProp.value)) /= 2 and then CORBA.Short'(From_Any (MyProp.value)) /= 3 and then CORBA.Short'(From_Any (MyProp.value)) /= 4 then MyErrCode := BAD_VALUE; MyRange := (To_Any (CORBA.Short (0)), To_Any (CORBA.Short (4))); MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); end if; elsif MyProp.name = "MaximumBatchSize" then MyErrCode := UNSUPPORTED_PROPERTY; MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); elsif MyProp.name = "PacingInterval" then MyErrCode := UNSUPPORTED_PROPERTY; MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); elsif MyProp.name = "StartTimeSupported" then MyErrCode := UNSUPPORTED_PROPERTY; MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); elsif MyProp.name = "StopTimeSupported" then MyErrCode := UNSUPPORTED_PROPERTY; MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); elsif MyProp.name = "MaxEventsPerConsumer" then MyErrCode := UNSUPPORTED_PROPERTY; MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); else MyErrCode := BAD_PROPERTY; MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); end if; end loop; if Length (MyErrorSeq) > 0 then CosNotification.Helper.Raise_UnsupportedQoS ((CORBA.IDL_Exception_Members with qos_err => MyErrorSeq)); end if; SeqLen := Length (QoS); Enter (Peer_Mutex); for Index in 1 .. SeqLen loop MyProp := Get_Element (QoS, Index); if MyProp.name = "ConnectionReliability" then Replace_Element (Self.X.QoSPropSeq, 2, MyProp); elsif MyProp.name = "Priority" then Replace_Element (Self.X.QoSPropSeq, 3, MyProp); elsif MyProp.name = "OrderPolicy" then Replace_Element (Self.X.QoSPropSeq, 4, MyProp); elsif MyProp.name = "DiscardPolicy" then Replace_Element (Self.X.QoSPropSeq, 5, MyProp); end if; end loop; Leave (Peer_Mutex); end Set_QoS; ------------------ -- Validate_QoS -- ------------------ procedure Validate_QoS (Self : access Object; Required_QoS : CosNotification.QoSProperties; Available_QoS : out CosNotification.NamedPropertyRangeSeq) is MyProp : CosNotification.Property; MyError : CosNotification.PropertyError; MyErrCode : CosNotification.QoSError_code; MyNamedRange : CosNotification.NamedPropertyRange; MyRange : CosNotification.PropertyRange; MyErrorSeq : CosNotification.PropertyErrorSeq; SeqLen : Integer; begin Ensure_Initialization; pragma Debug (O ("validate_qos in structuredproxypullconsumer")); SeqLen := Length (Required_QoS); for Index in 1 .. SeqLen loop MyProp := Get_Element (Required_QoS, Index); if MyProp.name = "EventReliability" then MyErrCode := UNAVAILABLE_PROPERTY; MyRange := (To_Any (CORBA.Short (0)), To_Any (CORBA.Short (0))); MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); elsif MyProp.name = "ConnectionReliability" then if CORBA.Short'(From_Any (MyProp.value)) /= 0 and then CORBA.Short'(From_Any (MyProp.value)) /= 1 then MyErrCode := BAD_VALUE; MyRange := (To_Any (CORBA.Short (0)), To_Any (CORBA.Short (0))); MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); end if; elsif MyProp.name = "Priority" then if CORBA.Short'(From_Any (MyProp.value)) not in -32_767 .. 32_767 then MyErrCode := BAD_VALUE; MyRange := (To_Any (CORBA.Short (-32767)), To_Any (CORBA.Short (32767))); MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); end if; elsif MyProp.name = "StartTime" then MyErrCode := UNAVAILABLE_PROPERTY; MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); elsif MyProp.name = "StopTime" then MyErrCode := UNAVAILABLE_PROPERTY; MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); elsif MyProp.name = "Timeout" then MyErrCode := UNSUPPORTED_PROPERTY; MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); elsif MyProp.name = "OrderPolicy" then if CORBA.Short'(From_Any (MyProp.value)) /= 0 and then CORBA.Short'(From_Any (MyProp.value)) /= 1 and then CORBA.Short'(From_Any (MyProp.value)) /= 2 and then CORBA.Short'(From_Any (MyProp.value)) /= 3 then MyErrCode := BAD_VALUE; MyRange := (To_Any (CORBA.Short (0)), To_Any (CORBA.Short (3))); MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); end if; elsif MyProp.name = "DiscardPolicy" then if CORBA.Short'(From_Any (MyProp.value)) /= 0 and then CORBA.Short'(From_Any (MyProp.value)) /= 1 and then CORBA.Short'(From_Any (MyProp.value)) /= 2 and then CORBA.Short'(From_Any (MyProp.value)) /= 3 and then CORBA.Short'(From_Any (MyProp.value)) /= 4 then MyErrCode := BAD_VALUE; MyRange := (To_Any (CORBA.Short (0)), To_Any (CORBA.Short (4))); MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); end if; elsif MyProp.name = "MaximumBatchSize" then MyErrCode := UNSUPPORTED_PROPERTY; MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); elsif MyProp.name = "PacingInterval" then MyErrCode := UNSUPPORTED_PROPERTY; MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); elsif MyProp.name = "StartTimeSupported" then MyErrCode := UNSUPPORTED_PROPERTY; MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); elsif MyProp.name = "StopTimeSupported" then MyErrCode := UNSUPPORTED_PROPERTY; MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); elsif MyProp.name = "MaxEventsPerConsumer" then MyErrCode := UNSUPPORTED_PROPERTY; MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); else MyErrCode := BAD_PROPERTY; MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); end if; end loop; if Length (MyErrorSeq) > 0 then CosNotification.Helper.Raise_UnsupportedQoS ((CORBA.IDL_Exception_Members with qos_err => MyErrorSeq)); end if; Enter (Peer_Mutex); SeqLen := Length (Self.X.QoSPropSeq); for Index in 1 .. SeqLen loop MyProp := Get_Element (Self.X.QoSPropSeq, Index); if MyProp.name = "ConnectionReliability" then MyRange := (From_Any (MyProp.value), To_Any (CORBA.Short (0))); MyNamedRange := (MyProp.name, MyRange); Append (Available_QoS, MyNamedRange); elsif MyProp.name = "Priority" then MyRange := (To_Any (CORBA.Short (-32767)), To_Any (CORBA.Short (32767))); MyNamedRange := (MyProp.name, MyRange); Append (Available_QoS, MyNamedRange); elsif MyProp.name = "OrderPolicy" then MyRange := (To_Any (CORBA.Short (0)), To_Any (CORBA.Short (3))); MyNamedRange := (MyProp.name, MyRange); Append (Available_QoS, MyNamedRange); elsif MyProp.name = "DiscardPolicy" then MyRange := (To_Any (CORBA.Short (0)), To_Any (CORBA.Short (4))); MyNamedRange := (MyProp.name, MyRange); Append (Available_QoS, MyNamedRange); end if; end loop; Leave (Peer_Mutex); end Validate_QoS; ---------------- -- Add_Filter -- ---------------- function Add_Filter (Self : access Object; New_Filter : CosNotifyFilter.Filter.Ref) return CosNotifyFilter.FilterID is pragma Warnings (Off); -- WAG:3.14 pragma Unreferenced (Self, New_Filter); pragma Warnings (On); -- WAG:3.14 MyFilterID : CosNotifyFilter.FilterID; MyID : CORBA.Long; begin Ensure_Initialization; pragma Debug (O ("add_filter in structuredproxypullconsumer")); Enter (Peer_Mutex); Leave (Peer_Mutex); MyID := 0; MyFilterID := CosNotifyFilter.FilterID (MyID); return MyFilterID; end Add_Filter; ------------------- -- Remove_Filter -- ------------------- procedure Remove_Filter (Self : access Object; Filter : CosNotifyFilter.FilterID) is pragma Warnings (Off); -- WAG:3.14 pragma Unreferenced (Self, Filter); pragma Warnings (On); -- WAG:3.14 begin Ensure_Initialization; pragma Debug (O ("remove_filter in structuredproxypullconsumer")); Enter (Peer_Mutex); Leave (Peer_Mutex); end Remove_Filter; ---------------- -- Get_Filter -- ---------------- function Get_Filter (Self : access Object; Filter : CosNotifyFilter.FilterID) return CosNotifyFilter.Filter.Ref is pragma Warnings (Off); -- WAG:3.14 pragma Unreferenced (Self, Filter); pragma Warnings (On); -- WAG:3.14 MyFilter : CosNotifyFilter.Filter.Ref; begin Ensure_Initialization; pragma Debug (O ("get_filter in structuredproxypullconsumer")); Enter (Peer_Mutex); Leave (Peer_Mutex); return MyFilter; end Get_Filter; --------------------- -- Get_All_Filters -- --------------------- function Get_All_Filters (Self : access Object) return CosNotifyFilter.FilterIDSeq is pragma Warnings (Off); -- WAG:3.14 pragma Unreferenced (Self); pragma Warnings (On); -- WAG:3.14 MyFilterSeq : CosNotifyFilter.FilterIDSeq; begin Ensure_Initialization; pragma Debug (O ("get_all_filters in structuredproxypullconsumer")); Enter (Peer_Mutex); Leave (Peer_Mutex); return MyFilterSeq; end Get_All_Filters; ------------------------ -- Remove_All_Filters -- ------------------------ procedure Remove_All_Filters (Self : access Object) is pragma Warnings (Off); -- WAG:3.14 pragma Unreferenced (Self); pragma Warnings (On); -- WAG:3.14 begin Ensure_Initialization; pragma Debug (O ("remove_all_filters in structuredproxypullconsumer")); Enter (Peer_Mutex); Leave (Peer_Mutex); end Remove_All_Filters; ------------------ -- Offer_Change -- ------------------ procedure Offer_Change (Self : access Object; Added : CosNotification.EventTypeSeq; Removed : CosNotification.EventTypeSeq) is pragma Warnings (Off); -- WAG:3.14 pragma Unreferenced (Self, Added, Removed); pragma Warnings (On); -- WAG:3.14 begin pragma Debug (O ("offer_change in structuredproxypullconsumer")); Ensure_Initialization; Enter (Peer_Mutex); Leave (Peer_Mutex); end Offer_Change; ----------------------------------------- -- Disconnect_Structured_Pull_Consumer -- ----------------------------------------- procedure Disconnect_Structured_Pull_Consumer (Self : access Object) is Peer : CosNotifyComm.StructuredPullSupplier.Ref; Nil_Ref : CosNotifyComm.StructuredPullSupplier.Ref; begin pragma Debug (O ("disconnect structuredproxypullconsumer")); Ensure_Initialization; Enter (Peer_Mutex); Peer := Self.X.Peer; Self.X.Peer := Nil_Ref; Leave (Peer_Mutex); if not CosNotifyComm.StructuredPullSupplier.Is_Nil (Peer) then CosNotifyComm.StructuredPullSupplier. disconnect_structured_pull_supplier (Peer); end if; end Disconnect_Structured_Pull_Consumer; ------------ -- Create -- ------------ function Create (Admin : CosNotifyChannelAdmin.SupplierAdmin.Ref; Initial_QoS : CosNotification.QoSProperties; Ptype : CosNotifyChannelAdmin.ProxyType; Proxy_Id : CosNotifyChannelAdmin.ProxyID) return Object_Ptr is Consumer : Object_Ptr; My_Ref : StructuredProxyPullConsumer.Ref; begin pragma Debug (O ("create structuredproxypullconsumer")); Consumer := new Object; Consumer.X := new Structured_Proxy_Pull_Consumer_Record; Consumer.X.Admin := Admin; Consumer.X.MyId := Proxy_Id; Consumer.X.MyType := Ptype; Consumer.X.This := Consumer; Consumer.X.QoSPropSeq := Initial_QoS; Initiate_Servant (Servant (Consumer), My_Ref); return Consumer; end Create; end CosNotifyChannelAdmin.StructuredProxyPullConsumer.Impl; polyorb-2.8~20110207.orig/cos/notification/cosnotifycomm-sequencepullsupplier-impl.adb0000644000175000017500000002252011750740337030452 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- COSNOTIFYCOMM.SEQUENCEPULLSUPPLIER.IMPL -- -- -- -- B o d y -- -- -- -- Copyright (C) 2003-2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with CosEventChannelAdmin.Helper; with CosEventComm.Helper; with PolyORB.CORBA_P.Server_Tools; with PolyORB.Log; with PolyORB.Tasking.Mutexes; with PolyORB.Tasking.Semaphores; with CosNotifyComm.SequencePullSupplier.Skel; pragma Warnings (Off, CosNotifyComm.SequencePullSupplier.Skel); package body CosNotifyComm.SequencePullSupplier.Impl is use PolyORB.CORBA_P.Server_Tools; use PolyORB.Tasking.Mutexes; use PolyORB.Tasking.Semaphores; use PolyORB.Log; package L is new PolyORB.Log.Facility_Log ("sequencepullsupplier"); procedure O (Message : Standard.String; Level : Log_Level := Debug) renames L.Output; function C (Level : Log_Level := Debug) return Boolean renames L.Enabled; pragma Unreferenced (C); -- For conditional pragma Debug type Sequence_Pull_Supplier_Record is record This : Object_Ptr; Peer : CosNotifyChannelAdmin.SequenceProxyPullConsumer.Ref; Empty : Boolean; Events : CosNotification.EventBatch; Semaphore : Semaphore_Access; end record; --------------------------- -- Ensure_Initialization -- --------------------------- procedure Ensure_Initialization; pragma Inline (Ensure_Initialization); -- Ensure that the Mutexes are initialized T_Initialized : Boolean := False; Self_Mutex : Mutex_Access; procedure Ensure_Initialization is begin if not T_Initialized then Create (Self_Mutex); T_Initialized := True; end if; end Ensure_Initialization; ------------------------------------------ -- Connect_Sequence_Proxy_Pull_Consumer -- ------------------------------------------ procedure Connect_Sequence_Proxy_Pull_Consumer (Self : access Object; Proxy : CosNotifyChannelAdmin.SequenceProxyPullConsumer.Ref) is My_Ref : SequencePullSupplier.Ref; begin Ensure_Initialization; pragma Debug (O ("connect_sequence_proxy_pull_consumer in sequencepullsupplier")); Enter (Self_Mutex); if not CosNotifyChannelAdmin.SequenceProxyPullConsumer.Is_Nil (Self.X.Peer) then Leave (Self_Mutex); CosEventChannelAdmin.Helper.Raise_AlreadyConnected ((CORBA.IDL_Exception_Members with null record)); end if; Self.X.Peer := Proxy; Servant_To_Reference (PortableServer.Servant (Self.X.This), My_Ref); Leave (Self_Mutex); CosNotifyChannelAdmin.SequenceProxyPullConsumer. connect_sequence_pull_supplier (Proxy, My_Ref); end Connect_Sequence_Proxy_Pull_Consumer; ------------------------- -- Subscription_Change -- ------------------------- procedure Subscription_Change (Self : access Object; Added : CosNotification.EventTypeSeq; Removed : CosNotification.EventTypeSeq) is pragma Warnings (Off); -- WAG:3.14 pragma Unreferenced (Self, Added, Removed); pragma Warnings (On); -- WAG:3.14 begin Ensure_Initialization; pragma Debug (O ("subscription_change in sequencepullsupplier")); Enter (Self_Mutex); Leave (Self_Mutex); end Subscription_Change; --------------------------------------- -- Disconnect_Sequence_Pull_Supplier -- --------------------------------------- procedure Disconnect_Sequence_Pull_Supplier (Self : access Object) is Peer : CosNotifyChannelAdmin.SequenceProxyPullConsumer.Ref; Nil_Ref : CosNotifyChannelAdmin.SequenceProxyPullConsumer.Ref; begin Ensure_Initialization; pragma Debug (O ("disconnect sequencepullsupplier")); Enter (Self_Mutex); Peer := Self.X.Peer; Self.X.Peer := Nil_Ref; Leave (Self_Mutex); V (Self.X.Semaphore); if not CosNotifyChannelAdmin.SequenceProxyPullConsumer.Is_Nil (Peer) then CosNotifyChannelAdmin.SequenceProxyPullConsumer. disconnect_sequence_pull_consumer (Peer); end if; end Disconnect_Sequence_Pull_Supplier; ---------------------------- -- Pull_Structured_Events -- ---------------------------- function Pull_Structured_Events (Self : access Object; Max_Number : CORBA.Long) return CosNotification.EventBatch is pragma Warnings (Off); -- WAG:3.14 pragma Unreferenced (Max_Number); pragma Warnings (On); -- WAG:3.14 Events : CosNotification.EventBatch; begin Ensure_Initialization; loop pragma Debug (O ("attempt to pull new sequence of structured events " & "from pull supplier")); P (Self.X.Semaphore); Enter (Self_Mutex); if CosNotifyChannelAdmin.SequenceProxyPullConsumer.Is_Nil (Self.X.Peer) then Leave (Self_Mutex); CosEventComm.Helper.Raise_Disconnected ((CORBA.IDL_Exception_Members with null record)); end if; if not Self.X.Empty then Events := Self.X.Events; Self.X.Empty := True; Leave (Self_Mutex); exit; end if; Leave (Self_Mutex); end loop; pragma Debug (O ("succeed to pull new sequence of structured events " & "from pull supplier")); return Events; end Pull_Structured_Events; ---------- -- Push -- ---------- procedure Push (Self : access Object; Data : CosNotification.EventBatch) is begin pragma Debug (O ("push new sequence of structured events " & "to sequencepullsupplier")); Ensure_Initialization; Enter (Self_Mutex); Self.X.Empty := False; Self.X.Events := Data; Leave (Self_Mutex); V (Self.X.Semaphore); end Push; -------------------------------- -- Try_Pull_Structured_Events -- -------------------------------- procedure Try_Pull_Structured_Events (Self : access Object; Max_Number : CORBA.Long; Has_Event : out CORBA.Boolean; Returns : out CosNotification.EventBatch) is pragma Warnings (Off); -- WAG:3.14 pragma Unreferenced (Max_Number); pragma Warnings (On); -- WAG:3.14 begin Ensure_Initialization; pragma Debug (O ("try to pull new sequence of structured events " & "from sequencepullsupplier")); Enter (Self_Mutex); if CosNotifyChannelAdmin.SequenceProxyPullConsumer.Is_Nil (Self.X.Peer) then Leave (Self_Mutex); CosEventComm.Helper.Raise_Disconnected ((CORBA.IDL_Exception_Members with null record)); end if; Has_Event := not Self.X.Empty; if Has_Event then Returns := Self.X.Events; Self.X.Empty := True; end if; Leave (Self_Mutex); end Try_Pull_Structured_Events; ------------ -- Create -- ------------ function Create return Object_Ptr is Supplier : Object_Ptr; My_Ref : SequencePullSupplier.Ref; Peer_Ref : CosNotifyChannelAdmin.SequenceProxyPullConsumer.Ref; begin pragma Debug (O ("create sequencepullsupplier")); Supplier := new Object; Supplier.X := new Sequence_Pull_Supplier_Record; Supplier.X.This := Supplier; Supplier.X.Empty := True; Supplier.X.Peer := Peer_Ref; Create (Supplier.X.Semaphore); Initiate_Servant (PortableServer.Servant (Supplier), My_Ref); return Supplier; end Create; end CosNotifyComm.SequencePullSupplier.Impl; polyorb-2.8~20110207.orig/cos/notification/cosnotifychanneladmin-proxypushsupplier-impl.ads0000644000175000017500000001271111750740337031536 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- COSNOTIFYCHANNELADMIN.PROXYPUSHSUPPLIER.IMPL -- -- -- -- S p e c -- -- -- -- Copyright (C) 2003-2008, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by ACT Europe. -- -- (email: sales@act-europe.fr) -- -- -- ------------------------------------------------------------------------------ with CosNotifyChannelAdmin.ConsumerAdmin; with CosNotifyFilter.Filter; with CosNotifyFilter.MappingFilter; with PortableServer; package CosNotifyChannelAdmin.ProxyPushSupplier.Impl is type Object is new PortableServer.Servant_Base with private; type Object_Ptr is access all Object'Class; -- IDL operations procedure Connect_Any_Push_Consumer (Self : access Object; Push_Consumer : CosEventComm.PushConsumer.Ref); procedure Suspend_Connection (Self : access Object); procedure Resume_Connection (Self : access Object); -- IDL operations inherited from CosNotifyChannelAdmin::ProxySupplier function Get_MyType (Self : access Object) return CosNotifyChannelAdmin.ProxyType; function Get_MyAdmin (Self : access Object) return CosNotifyChannelAdmin.ConsumerAdmin_Forward.Ref; function Get_Priority_Filter (Self : access Object) return CosNotifyFilter.MappingFilter.Ref; procedure Set_Priority_Filter (Self : access Object; To : CosNotifyFilter.MappingFilter.Ref); function Get_Lifetime_Filter (Self : access Object) return CosNotifyFilter.MappingFilter.Ref; procedure Set_Lifetime_Filter (Self : access Object; To : CosNotifyFilter.MappingFilter.Ref); function Obtain_Offered_Types (Self : access Object; Mode : CosNotifyChannelAdmin.ObtainInfoMode) return CosNotification.EventTypeSeq; procedure Validate_Event_QoS (Self : access Object; Required_QoS : CosNotification.QoSProperties; Available_QoS : out CosNotification.NamedPropertyRangeSeq); function Get_QoS (Self : access Object) return CosNotification.QoSProperties; procedure Set_QoS (Self : access Object; QoS : CosNotification.QoSProperties); procedure Validate_QoS (Self : access Object; Required_QoS : CosNotification.QoSProperties; Available_QoS : out CosNotification.NamedPropertyRangeSeq); function Add_Filter (Self : access Object; New_Filter : CosNotifyFilter.Filter.Ref) return CosNotifyFilter.FilterID; procedure Remove_Filter (Self : access Object; Filter : CosNotifyFilter.FilterID); function Get_Filter (Self : access Object; Filter : CosNotifyFilter.FilterID) return CosNotifyFilter.Filter.Ref; function Get_All_Filters (Self : access Object) return CosNotifyFilter.FilterIDSeq; procedure Remove_All_Filters (Self : access Object); -- IDL operations inherited from CosNotifyComm::PushSupplier procedure Subscription_Change (Self : access Object; Added : CosNotification.EventTypeSeq; Removed : CosNotification.EventTypeSeq); procedure Disconnect_Push_Supplier (Self : access Object); ---------------------- -- PolyORB specific -- ---------------------- function Create (Admin : CosNotifyChannelAdmin.ConsumerAdmin.Ref; Initial_QoS : CosNotification.QoSProperties; Ptype : CosNotifyChannelAdmin.ProxyType; Proxy_Id : CosNotifyChannelAdmin.ProxyID) return Object_Ptr; procedure Post (Self : access Object; Data : CORBA.Any); private type Proxy_Push_Supplier_Record; type Proxy_Push_Supplier_Access is access Proxy_Push_Supplier_Record; type Object is new PortableServer.Servant_Base with record X : Proxy_Push_Supplier_Access; end record; end CosNotifyChannelAdmin.ProxyPushSupplier.Impl; polyorb-2.8~20110207.orig/cos/notification/cosnotifycomm-sequencepullsupplier-impl.ads0000644000175000017500000000757111750740337030504 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- COSNOTIFYCOMM.SEQUENCEPULLSUPPLIER.IMPL -- -- -- -- S p e c -- -- -- -- Copyright (C) 2003-2008, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by ACT Europe. -- -- (email: sales@act-europe.fr) -- -- -- ------------------------------------------------------------------------------ with PortableServer; with CosNotifyChannelAdmin.SequenceProxyPullConsumer; package CosNotifyComm.SequencePullSupplier.Impl is type Object is new PortableServer.Servant_Base with private; type Object_Ptr is access all Object'Class; -- Inherited IDL operations from CosNotifyComm::NotifySubscribe procedure Subscription_Change (Self : access Object; Added : CosNotification.EventTypeSeq; Removed : CosNotification.EventTypeSeq); -- IDL operations function Pull_Structured_Events (Self : access Object; Max_Number : CORBA.Long) return CosNotification.EventBatch; -- Call by proxy to pull a sequence of structured events procedure Try_Pull_Structured_Events (Self : access Object; Max_Number : CORBA.Long; Has_Event : out CORBA.Boolean; Returns : out CosNotification.EventBatch); -- Call by proxy to try to pull a structured event procedure Disconnect_Sequence_Pull_Supplier (Self : access Object); -- Call by proxy to disconnect ---------------------- -- PolyORB specific -- ---------------------- procedure Connect_Sequence_Proxy_Pull_Consumer (Self : access Object; Proxy : CosNotifyChannelAdmin.SequenceProxyPullConsumer.Ref); -- Call by application to connect object with proxy function Create return Object_Ptr; -- Call by application to create an object and activate servant procedure Push (Self : access Object; Data : CosNotification.EventBatch); -- Call by application to produce a sequence of structured event private type Sequence_Pull_Supplier_Record; type Sequence_Pull_Supplier_Access is access Sequence_Pull_Supplier_Record; type Object is new PortableServer.Servant_Base with record X : Sequence_Pull_Supplier_Access; end record; end CosNotifyComm.SequencePullSupplier.Impl; polyorb-2.8~20110207.orig/cos/notification/cosnotifycomm-sequencepullconsumer-impl.adb0000644000175000017500000001765011750740337030452 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- COSNOTIFYCOMM.SEQUENCEPULLCONSUMER.IMPL -- -- -- -- B o d y -- -- -- -- Copyright (C) 2003-2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with CosEventChannelAdmin.Helper; with CosEventComm.Helper; with PolyORB.CORBA_P.Server_Tools; with PolyORB.Log; with PolyORB.Tasking.Mutexes; with CosNotifyComm.SequencePullConsumer.Skel; pragma Warnings (Off, CosNotifyComm.SequencePullConsumer.Skel); package body CosNotifyComm.SequencePullConsumer.Impl is use PolyORB.CORBA_P.Server_Tools; use PolyORB.Tasking.Mutexes; use PolyORB.Log; package L is new PolyORB.Log.Facility_Log ("sequencepullconsumer"); procedure O (Message : Standard.String; Level : Log_Level := Debug) renames L.Output; function C (Level : Log_Level := Debug) return Boolean renames L.Enabled; pragma Unreferenced (C); -- For conditional pragma Debug type Sequence_Pull_Consumer_Record is record This : Object_Ptr; Peer : CosNotifyChannelAdmin.SequenceProxyPullSupplier.Ref; end record; --------------------------- -- Ensure_Initialization -- --------------------------- procedure Ensure_Initialization; pragma Inline (Ensure_Initialization); -- Ensure that the Mutexes are initialized T_Initialized : Boolean := False; Self_Mutex : Mutex_Access; procedure Ensure_Initialization is begin if not T_Initialized then Create (Self_Mutex); T_Initialized := True; end if; end Ensure_Initialization; --------------------------------------- -- Disconnect_Sequence_Pull_Consumer -- --------------------------------------- procedure Disconnect_Sequence_Pull_Consumer (Self : access Object) is Peer : CosNotifyChannelAdmin.SequenceProxyPullSupplier.Ref; Nil_Ref : CosNotifyChannelAdmin.SequenceProxyPullSupplier.Ref; begin Ensure_Initialization; pragma Debug (O ("disconnect sequencepullconsumer")); Enter (Self_Mutex); Peer := Self.X.Peer; Self.X.Peer := Nil_Ref; Leave (Self_Mutex); if not CosNotifyChannelAdmin.SequenceProxyPullSupplier.Is_Nil (Peer) then CosNotifyChannelAdmin.SequenceProxyPullSupplier. disconnect_sequence_pull_supplier (Peer); end if; end Disconnect_Sequence_Pull_Consumer; ------------------ -- Offer_Change -- ------------------ procedure Offer_Change (Self : access Object; Added : CosNotification.EventTypeSeq; Removed : CosNotification.EventTypeSeq) is pragma Warnings (Off); -- WAG:3.14 pragma Unreferenced (Self, Added, Removed); pragma Warnings (On); -- WAG:3.14 begin Ensure_Initialization; pragma Debug (O ("offer_change in sequencepullconsumer")); Enter (Self_Mutex); Leave (Self_Mutex); end Offer_Change; ------------------------------------------ -- Connect_Sequence_Proxy_Pull_Supplier -- ------------------------------------------ procedure Connect_Sequence_Proxy_Pull_Supplier (Self : access Object; Proxy : CosNotifyChannelAdmin.SequenceProxyPullSupplier.Ref) is My_Ref : SequencePullConsumer.Ref; begin Ensure_Initialization; pragma Debug (O ("connect_sequence_proxy_pull_supplier in sequencepullconsumer")); Enter (Self_Mutex); if not CosNotifyChannelAdmin.SequenceProxyPullSupplier.Is_Nil (Self.X.Peer) then Leave (Self_Mutex); CosEventChannelAdmin.Helper.Raise_AlreadyConnected ((CORBA.IDL_Exception_Members with null record)); end if; Self.X.Peer := Proxy; Servant_To_Reference (PortableServer.Servant (Self.X.This), My_Ref); Leave (Self_Mutex); CosNotifyChannelAdmin.SequenceProxyPullSupplier. connect_sequence_pull_consumer (Proxy, My_Ref); end Connect_Sequence_Proxy_Pull_Supplier; ------------ -- Create -- ------------ function Create return Object_Ptr is Consumer : Object_Ptr; My_Ref : SequencePullConsumer.Ref; Peer_Ref : CosNotifyChannelAdmin.SequenceProxyPullSupplier.Ref; begin pragma Debug (O ("create sequencepullconsumer")); Consumer := new Object; Consumer.X := new Sequence_Pull_Consumer_Record; Consumer.X.This := Consumer; Consumer.X.Peer := Peer_Ref; Initiate_Servant (PortableServer.Servant (Consumer), My_Ref); return Consumer; end Create; ---------- -- Pull -- ---------- function Pull (Self : access Object; Max_Number : CORBA.Long) return CosNotification.EventBatch is Peer : CosNotifyChannelAdmin.SequenceProxyPullSupplier.Ref; begin Ensure_Initialization; pragma Debug (O ("pull sequence of structured events " & "from sequencepullconsumer")); Enter (Self_Mutex); Peer := Self.X.Peer; Leave (Self_Mutex); if CosNotifyChannelAdmin.SequenceProxyPullSupplier.Is_Nil (Peer) then CosEventComm.Helper.Raise_Disconnected ((CORBA.IDL_Exception_Members with null record)); end if; return CosNotifyChannelAdmin.SequenceProxyPullSupplier. pull_structured_events (Peer, Max_Number); end Pull; -------------- -- Try_Pull -- -------------- procedure Try_Pull (Self : access Object; Max_Number : CORBA.Long; Done : out CORBA.Boolean; Returns : out CosNotification.EventBatch) is Peer : CosNotifyChannelAdmin.SequenceProxyPullSupplier.Ref; begin pragma Debug (O ("try to pull sequence of structured events " & "from sequencepullconsumer")); Ensure_Initialization; Enter (Self_Mutex); Peer := Self.X.Peer; Leave (Self_Mutex); if CosNotifyChannelAdmin.SequenceProxyPullSupplier.Is_Nil (Peer) then CosEventComm.Helper.Raise_Disconnected ((CORBA.IDL_Exception_Members with null record)); end if; CosNotifyChannelAdmin.SequenceProxyPullSupplier. try_pull_structured_events (Peer, Max_Number, Done, Returns); end Try_Pull; end CosNotifyComm.SequencePullConsumer.Impl; polyorb-2.8~20110207.orig/cos/notification/cosnotifychanneladmin-proxyconsumer-impl.ads0000644000175000017500000001055511750740337030632 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- COSNOTIFYCHANNELADMIN.PROXYCONSUMER.IMPL -- -- -- -- S p e c -- -- -- -- Copyright (C) 2003-2008, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by ACT Europe. -- -- (email: sales@act-europe.fr) -- -- -- ------------------------------------------------------------------------------ -- with CORBA; with CosNotifyChannelAdmin.SupplierAdmin; with PortableServer; package CosNotifyChannelAdmin.ProxyConsumer.Impl is type Object is new PortableServer.Servant_Base with private; type Object_Ptr is access all Object'Class; -- IDL operations function Get_MyType (Self : access Object) return CosNotifyChannelAdmin.ProxyType; function Get_MyAdmin (Self : access Object) return CosNotifyChannelAdmin.SupplierAdmin_Forward.Ref; function Obtain_Subscription_Types (Self : access Object; Mode : CosNotifyChannelAdmin.ObtainInfoMode) return CosNotification.EventTypeSeq; procedure Validate_Event_QoS (Self : access Object; Required_QoS : CosNotification.QoSProperties; Available_QoS : out CosNotification.NamedPropertyRangeSeq); -- IDL Operations inherited from CosNotification::QoSAdmin function Get_QoS (Self : access Object) return CosNotification.QoSProperties; procedure Set_QoS (Self : access Object; QoS : CosNotification.QoSProperties); procedure Validate_QoS (Self : access Object; Required_QoS : CosNotification.QoSProperties; Available_QoS : out CosNotification.NamedPropertyRangeSeq); -- Inherited IDL operations from CosNotifyFilter::FilterAdmin function Add_Filter (Self : access Object; New_Filter : CosNotifyFilter.Filter.Ref) return CosNotifyFilter.FilterID; procedure Remove_Filter (Self : access Object; Filter : CosNotifyFilter.FilterID); function Get_Filter (Self : access Object; Filter : CosNotifyFilter.FilterID) return CosNotifyFilter.Filter.Ref; function Get_All_Filters (Self : access Object) return CosNotifyFilter.FilterIDSeq; procedure Remove_All_Filters (Self : access Object); ---------------------- -- PolyORB specific -- ---------------------- function Create (Admin : CosNotifyChannelAdmin.SupplierAdmin.Ref; Ptype : CosNotifyChannelAdmin.ProxyType; Proxy_Id : CosNotifyChannelAdmin.ProxyID) return Object_Ptr; private type Proxy_Consumer_Record; type Proxy_Consumer_Access is access Proxy_Consumer_Record; type Object is new PortableServer.Servant_Base with record X : Proxy_Consumer_Access; end record; end CosNotifyChannelAdmin.ProxyConsumer.Impl; polyorb-2.8~20110207.orig/cos/notification/cosnotifychanneladmin-proxypushsupplier-impl.adb0000644000175000017500000006734011750740337031525 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- COSNOTIFYCHANNELADMIN.PROXYPUSHSUPPLIER.IMPL -- -- -- -- B o d y -- -- -- -- Copyright (C) 2003-2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with CosEventChannelAdmin.Helper; with CosNotification; with CosNotification.Helper; with PolyORB.CORBA_P.Server_Tools; with PolyORB.Log; with PolyORB.Tasking.Mutexes; with CosNotifyChannelAdmin.ProxyPushSupplier.Skel; pragma Warnings (Off, CosNotifyChannelAdmin.ProxyPushSupplier.Skel); package body CosNotifyChannelAdmin.ProxyPushSupplier.Impl is use CosNotification; use IDL_SEQUENCE_CosNotification_Property; use IDL_SEQUENCE_CosNotification_PropertyError; use IDL_SEQUENCE_CosNotification_NamedPropertyRange; use CORBA; use PolyORB.CORBA_P.Server_Tools; use PolyORB.Tasking.Mutexes; package Convert is new ConsumerAdmin_Forward.Convert (CosNotifyChannelAdmin.ConsumerAdmin.Ref); use PolyORB.Log; package L is new PolyORB.Log.Facility_Log ("proxypushsupplier"); procedure O (Message : Standard.String; Level : Log_Level := Debug) renames L.Output; function C (Level : Log_Level := Debug) return Boolean renames L.Enabled; pragma Unreferenced (C); -- For conditional pragma Debug type Proxy_Push_Supplier_Record is record This : Object_Ptr; Admin : CosNotifyChannelAdmin.ConsumerAdmin.Ref; MyId : CosNotifyChannelAdmin.ProxyID; MyType : CosNotifyChannelAdmin.ProxyType; Peer : CosEventComm.PushConsumer.Ref; QoSPropSeq : CosNotification.QoSProperties; end record; --------------------------- -- Ensure_Initialization -- --------------------------- procedure Ensure_Initialization; pragma Inline (Ensure_Initialization); -- Ensure that the Mutexes are initialized T_Initialized : Boolean := False; Self_Mutex : Mutex_Access; procedure Ensure_Initialization is begin if not T_Initialized then Create (Self_Mutex); T_Initialized := True; end if; end Ensure_Initialization; ------------------------------- -- Connect_Any_Push_Consumer -- ------------------------------- procedure Connect_Any_Push_Consumer (Self : access Object; Push_Consumer : CosEventComm.PushConsumer.Ref) is begin pragma Debug (O ("connect_any_push_consumer in proxypushsupplier")); Ensure_Initialization; Enter (Self_Mutex); if not CosEventComm.PushConsumer.Is_Nil (Self.X.Peer) then Leave (Self_Mutex); CosEventChannelAdmin.Helper.Raise_AlreadyConnected ((CORBA.IDL_Exception_Members with null record)); end if; Self.X.Peer := Push_Consumer; Leave (Self_Mutex); end Connect_Any_Push_Consumer; ------------------------ -- Suspend_Connection -- ------------------------ procedure Suspend_Connection (Self : access Object) is pragma Warnings (Off); -- WAG:3.14 pragma Unreferenced (Self); pragma Warnings (On); -- WAG:3.14 begin pragma Debug (O ("suspend_connection in proxypushsupplier")); Ensure_Initialization; Enter (Self_Mutex); Leave (Self_Mutex); end Suspend_Connection; ----------------------- -- Resume_Connection -- ----------------------- procedure Resume_Connection (Self : access Object) is pragma Warnings (Off); -- WAG:3.14 pragma Unreferenced (Self); pragma Warnings (On); -- WAG:3.14 begin pragma Debug (O ("resume_connection in proxypushsupplier")); Ensure_Initialization; Enter (Self_Mutex); Leave (Self_Mutex); end Resume_Connection; ---------------- -- Get_MyType -- ---------------- function Get_MyType (Self : access Object) return CosNotifyChannelAdmin.ProxyType is MyType : CosNotifyChannelAdmin.ProxyType; begin pragma Debug (O ("get_mytype in proxypushsupplier")); Ensure_Initialization; Enter (Self_Mutex); MyType := Self.X.MyType; Leave (Self_Mutex); return MyType; end Get_MyType; ----------------- -- Get_MyAdmin -- ----------------- function Get_MyAdmin (Self : access Object) return CosNotifyChannelAdmin.ConsumerAdmin_Forward.Ref is MyAdmin : CosNotifyChannelAdmin.ConsumerAdmin_Forward.Ref; begin pragma Debug (O ("get_myadmin in proxypushsupplier")); Ensure_Initialization; Enter (Self_Mutex); MyAdmin := Convert.To_Forward (Self.X.Admin); Leave (Self_Mutex); return MyAdmin; end Get_MyAdmin; ------------------------- -- Get_Priority_Filter -- ------------------------- function Get_Priority_Filter (Self : access Object) return CosNotifyFilter.MappingFilter.Ref is pragma Warnings (Off); -- WAG:3.14 pragma Unreferenced (Self); pragma Warnings (On); -- WAG:3.14 MyFilter : CosNotifyFilter.MappingFilter.Ref; begin pragma Debug (O ("get_priority_filter in proxypushsupplier")); Ensure_Initialization; Enter (Self_Mutex); Leave (Self_Mutex); return MyFilter; end Get_Priority_Filter; ------------------------- -- Set_Priority_Filter -- ------------------------- procedure Set_Priority_Filter (Self : access Object; To : CosNotifyFilter.MappingFilter.Ref) is pragma Warnings (Off); -- WAG:3.14 pragma Unreferenced (Self, To); pragma Warnings (On); -- WAG:3.14 begin pragma Debug (O ("set_priority_filter in proxypushsupplier")); Ensure_Initialization; Enter (Self_Mutex); Leave (Self_Mutex); end Set_Priority_Filter; ------------------------- -- Get_Lifetime_Filter -- ------------------------- function Get_Lifetime_Filter (Self : access Object) return CosNotifyFilter.MappingFilter.Ref is pragma Warnings (Off); -- WAG:3.14 pragma Unreferenced (Self); pragma Warnings (On); -- WAG:3.14 MyFilter : CosNotifyFilter.MappingFilter.Ref; begin pragma Debug (O ("get_lifetime_filter in proxypushsupplier")); Ensure_Initialization; Enter (Self_Mutex); Leave (Self_Mutex); return MyFilter; end Get_Lifetime_Filter; ------------------------- -- Set_Lifetime_Filter -- ------------------------- procedure Set_Lifetime_Filter (Self : access Object; To : CosNotifyFilter.MappingFilter.Ref) is pragma Warnings (Off); -- WAG:3.14 pragma Unreferenced (Self, To); pragma Warnings (On); -- WAG:3.14 begin pragma Debug (O ("set_lifetime_filter in proxypushsupplier")); Ensure_Initialization; Enter (Self_Mutex); Leave (Self_Mutex); end Set_Lifetime_Filter; -------------------------- -- Obtain_Offered_Types -- -------------------------- function Obtain_Offered_Types (Self : access Object; Mode : CosNotifyChannelAdmin.ObtainInfoMode) return CosNotification.EventTypeSeq is pragma Warnings (Off); -- WAG:3.14 pragma Unreferenced (Self, Mode); pragma Warnings (On); -- WAG:3.14 MySeq : CosNotification.EventTypeSeq; begin pragma Debug (O ("obtain_offered_types in proxypushsupplier")); Ensure_Initialization; Enter (Self_Mutex); Leave (Self_Mutex); return MySeq; end Obtain_Offered_Types; ------------------------ -- Validate_Event_QoS -- ------------------------ procedure Validate_Event_QoS (Self : access Object; Required_QoS : CosNotification.QoSProperties; Available_QoS : out CosNotification.NamedPropertyRangeSeq) is pragma Warnings (Off); -- WAG:3.14 pragma Unreferenced (Self, Required_QoS, Available_QoS); pragma Warnings (On); -- WAG:3.14 begin pragma Debug (O ("validate_event_qos in proxypushsupplier")); Ensure_Initialization; Enter (Self_Mutex); Leave (Self_Mutex); end Validate_Event_QoS; ------------- -- Get_QoS -- ------------- function Get_QoS (Self : access Object) return CosNotification.QoSProperties is MyQoS : CosNotification.QoSProperties; begin pragma Debug (O ("get_qos in proxypushsupplier")); Ensure_Initialization; Enter (Self_Mutex); MyQoS := Self.X.QoSPropSeq; Leave (Self_Mutex); return MyQoS; end Get_QoS; ------------- -- Set_QoS -- ------------- procedure Set_QoS (Self : access Object; QoS : CosNotification.QoSProperties) is MyProp : CosNotification.Property; MyError : CosNotification.PropertyError; MyErrCode : CosNotification.QoSError_code; MyRange : CosNotification.PropertyRange; MyErrorSeq : CosNotification.PropertyErrorSeq; SeqLen : Integer; begin pragma Debug (O ("set_qos in proxypushsupplier")); Ensure_Initialization; SeqLen := Length (QoS); for Index in 1 .. SeqLen loop MyProp := Get_Element (QoS, Index); if MyProp.name = "EventReliability" then MyErrCode := UNAVAILABLE_PROPERTY; MyRange := (To_Any (CORBA.Short (0)), To_Any (CORBA.Short (0))); MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); elsif MyProp.name = "ConnectionReliability" then if CORBA.Short'(From_Any (MyProp.value)) /= 0 and then CORBA.Short'(From_Any (MyProp.value)) /= 1 then MyErrCode := BAD_VALUE; MyRange := (To_Any (CORBA.Short (0)), To_Any (CORBA.Short (0))); MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); end if; elsif MyProp.name = "Priority" then if CORBA.Short'(From_Any (MyProp.value)) not in -32_767 .. 32_767 then MyErrCode := BAD_VALUE; MyRange := (To_Any (CORBA.Short (-32767)), To_Any (CORBA.Short (32767))); MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); end if; elsif MyProp.name = "StartTime" then MyErrCode := UNAVAILABLE_PROPERTY; MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); elsif MyProp.name = "StopTime" then MyErrCode := UNAVAILABLE_PROPERTY; MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); elsif MyProp.name = "Timeout" then MyErrCode := UNSUPPORTED_PROPERTY; MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); elsif MyProp.name = "OrderPolicy" then if CORBA.Short'(From_Any (MyProp.value)) /= 0 and then CORBA.Short'(From_Any (MyProp.value)) /= 1 and then CORBA.Short'(From_Any (MyProp.value)) /= 2 and then CORBA.Short'(From_Any (MyProp.value)) /= 3 then MyErrCode := BAD_VALUE; MyRange := (To_Any (CORBA.Short (0)), To_Any (CORBA.Short (3))); MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); end if; elsif MyProp.name = "DiscardPolicy" then if CORBA.Short'(From_Any (MyProp.value)) /= 0 and then CORBA.Short'(From_Any (MyProp.value)) /= 1 and then CORBA.Short'(From_Any (MyProp.value)) /= 2 and then CORBA.Short'(From_Any (MyProp.value)) /= 3 and then CORBA.Short'(From_Any (MyProp.value)) /= 4 then MyErrCode := BAD_VALUE; MyRange := (To_Any (CORBA.Short (0)), To_Any (CORBA.Short (4))); MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); end if; elsif MyProp.name = "MaximumBatchSize" then MyErrCode := UNSUPPORTED_PROPERTY; MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); elsif MyProp.name = "PacingInterval" then MyErrCode := UNSUPPORTED_PROPERTY; MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); elsif MyProp.name = "StartTimeSupported" then MyErrCode := UNSUPPORTED_PROPERTY; MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); elsif MyProp.name = "StopTimeSupported" then MyErrCode := UNSUPPORTED_PROPERTY; MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); elsif MyProp.name = "MaxEventsPerConsumer" then MyErrCode := UNSUPPORTED_PROPERTY; MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); else MyErrCode := BAD_PROPERTY; MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); end if; end loop; if Length (MyErrorSeq) > 0 then CosNotification.Helper.Raise_UnsupportedQoS ((CORBA.IDL_Exception_Members with qos_err => MyErrorSeq)); end if; SeqLen := Length (QoS); Enter (Self_Mutex); for Index in 1 .. SeqLen loop MyProp := Get_Element (QoS, Index); if MyProp.name = "ConnectionReliability" then Replace_Element (Self.X.QoSPropSeq, 2, MyProp); elsif MyProp.name = "Priority" then Replace_Element (Self.X.QoSPropSeq, 3, MyProp); elsif MyProp.name = "OrderPolicy" then Replace_Element (Self.X.QoSPropSeq, 4, MyProp); elsif MyProp.name = "DiscardPolicy" then Replace_Element (Self.X.QoSPropSeq, 5, MyProp); end if; end loop; Leave (Self_Mutex); end Set_QoS; ------------------ -- Validate_QoS -- ------------------ procedure Validate_QoS (Self : access Object; Required_QoS : CosNotification.QoSProperties; Available_QoS : out CosNotification.NamedPropertyRangeSeq) is MyProp : CosNotification.Property; MyError : CosNotification.PropertyError; MyErrCode : CosNotification.QoSError_code; MyNamedRange : CosNotification.NamedPropertyRange; MyRange : CosNotification.PropertyRange; MyErrorSeq : CosNotification.PropertyErrorSeq; SeqLen : Integer; begin pragma Debug (O ("validate_qos in proxypushsupplier")); Ensure_Initialization; SeqLen := Length (Required_QoS); for Index in 1 .. SeqLen loop MyProp := Get_Element (Required_QoS, Index); if MyProp.name = "EventReliability" then MyErrCode := UNAVAILABLE_PROPERTY; MyRange := (To_Any (CORBA.Short (0)), To_Any (CORBA.Short (0))); MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); elsif MyProp.name = "ConnectionReliability" then if CORBA.Short'(From_Any (MyProp.value)) /= 0 and then CORBA.Short'(From_Any (MyProp.value)) /= 1 then MyErrCode := BAD_VALUE; MyRange := (To_Any (CORBA.Short (0)), To_Any (CORBA.Short (0))); MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); end if; elsif MyProp.name = "Priority" then if CORBA.Short'(From_Any (MyProp.value)) not in -32_767 .. 32_767 then MyErrCode := BAD_VALUE; MyRange := (To_Any (CORBA.Short (-32767)), To_Any (CORBA.Short (32767))); MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); end if; elsif MyProp.name = "StartTime" then MyErrCode := UNAVAILABLE_PROPERTY; MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); elsif MyProp.name = "StopTime" then MyErrCode := UNAVAILABLE_PROPERTY; MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); elsif MyProp.name = "Timeout" then MyErrCode := UNSUPPORTED_PROPERTY; MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); elsif MyProp.name = "OrderPolicy" then if CORBA.Short'(From_Any (MyProp.value)) /= 0 and then CORBA.Short'(From_Any (MyProp.value)) /= 1 and then CORBA.Short'(From_Any (MyProp.value)) /= 2 and then CORBA.Short'(From_Any (MyProp.value)) /= 3 then MyErrCode := BAD_VALUE; MyRange := (To_Any (CORBA.Short (0)), To_Any (CORBA.Short (3))); MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); end if; elsif MyProp.name = "DiscardPolicy" then if CORBA.Short'(From_Any (MyProp.value)) /= 0 and then CORBA.Short'(From_Any (MyProp.value)) /= 1 and then CORBA.Short'(From_Any (MyProp.value)) /= 2 and then CORBA.Short'(From_Any (MyProp.value)) /= 3 and then CORBA.Short'(From_Any (MyProp.value)) /= 4 then MyErrCode := BAD_VALUE; MyRange := (To_Any (CORBA.Short (0)), To_Any (CORBA.Short (4))); MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); end if; elsif MyProp.name = "MaximumBatchSize" then MyErrCode := UNSUPPORTED_PROPERTY; MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); elsif MyProp.name = "PacingInterval" then MyErrCode := UNSUPPORTED_PROPERTY; MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); elsif MyProp.name = "StartTimeSupported" then MyErrCode := UNSUPPORTED_PROPERTY; MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); elsif MyProp.name = "StopTimeSupported" then MyErrCode := UNSUPPORTED_PROPERTY; MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); elsif MyProp.name = "MaxEventsPerConsumer" then MyErrCode := UNSUPPORTED_PROPERTY; MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); else MyErrCode := BAD_PROPERTY; MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); end if; end loop; if Length (MyErrorSeq) > 0 then CosNotification.Helper.Raise_UnsupportedQoS ((CORBA.IDL_Exception_Members with qos_err => MyErrorSeq)); end if; Enter (Self_Mutex); SeqLen := Length (Self.X.QoSPropSeq); for Index in 1 .. SeqLen loop MyProp := Get_Element (Self.X.QoSPropSeq, Index); if MyProp.name = "ConnectionReliability" then MyRange := (From_Any (MyProp.value), To_Any (CORBA.Short (0))); MyNamedRange := (MyProp.name, MyRange); Append (Available_QoS, MyNamedRange); elsif MyProp.name = "Priority" then MyRange := (To_Any (CORBA.Short (-32767)), To_Any (CORBA.Short (32767))); MyNamedRange := (MyProp.name, MyRange); Append (Available_QoS, MyNamedRange); elsif MyProp.name = "OrderPolicy" then MyRange := (To_Any (CORBA.Short (0)), To_Any (CORBA.Short (3))); MyNamedRange := (MyProp.name, MyRange); Append (Available_QoS, MyNamedRange); elsif MyProp.name = "DiscardPolicy" then MyRange := (To_Any (CORBA.Short (0)), To_Any (CORBA.Short (4))); MyNamedRange := (MyProp.name, MyRange); Append (Available_QoS, MyNamedRange); end if; end loop; Leave (Self_Mutex); end Validate_QoS; ---------------- -- Add_Filter -- ---------------- function Add_Filter (Self : access Object; New_Filter : CosNotifyFilter.Filter.Ref) return CosNotifyFilter.FilterID is pragma Warnings (Off); -- WAG:3.14 pragma Unreferenced (Self, New_Filter); pragma Warnings (On); -- WAG:3.14 MyFilterID : CosNotifyFilter.FilterID; MyID : CORBA.Long; begin pragma Debug (O ("add_filter in proxypushsupplier")); Ensure_Initialization; Enter (Self_Mutex); Leave (Self_Mutex); MyID := 0; MyFilterID := CosNotifyFilter.FilterID (MyID); return MyFilterID; end Add_Filter; ------------------- -- Remove_Filter -- ------------------- procedure Remove_Filter (Self : access Object; Filter : CosNotifyFilter.FilterID) is pragma Warnings (Off); -- WAG:3.14 pragma Unreferenced (Self, Filter); pragma Warnings (On); -- WAG:3.14 begin pragma Debug (O ("remove_filter in proxypushsupplier")); Ensure_Initialization; Enter (Self_Mutex); Leave (Self_Mutex); end Remove_Filter; ---------------- -- Get_Filter -- ---------------- function Get_Filter (Self : access Object; Filter : CosNotifyFilter.FilterID) return CosNotifyFilter.Filter.Ref is pragma Warnings (Off); -- WAG:3.14 pragma Unreferenced (Self, Filter); pragma Warnings (On); -- WAG:3.14 MyFilter : CosNotifyFilter.Filter.Ref; begin pragma Debug (O ("get_filter in proxypushsupplier")); Ensure_Initialization; Enter (Self_Mutex); Leave (Self_Mutex); return MyFilter; end Get_Filter; --------------------- -- Get_All_Filters -- --------------------- function Get_All_Filters (Self : access Object) return CosNotifyFilter.FilterIDSeq is pragma Warnings (Off); -- WAG:3.14 pragma Unreferenced (Self); pragma Warnings (On); -- WAG:3.14 MyFilterSeq : CosNotifyFilter.FilterIDSeq; begin pragma Debug (O ("get_all_filters in proxypushsupplier")); Ensure_Initialization; Enter (Self_Mutex); Leave (Self_Mutex); return MyFilterSeq; end Get_All_Filters; ------------------------ -- Remove_All_Filters -- ------------------------ procedure Remove_All_Filters (Self : access Object) is pragma Warnings (Off); -- WAG:3.14 pragma Unreferenced (Self); pragma Warnings (On); -- WAG:3.14 begin pragma Debug (O ("remove_all_filters in proxypushsupplier")); Ensure_Initialization; Enter (Self_Mutex); Leave (Self_Mutex); end Remove_All_Filters; ------------------------- -- Subscription_Change -- ------------------------- procedure Subscription_Change (Self : access Object; Added : CosNotification.EventTypeSeq; Removed : CosNotification.EventTypeSeq) is pragma Warnings (Off); -- WAG:3.14 pragma Unreferenced (Self, Added, Removed); pragma Warnings (On); -- WAG:3.14 begin pragma Debug (O ("subscription_change in proxypushsupplier")); Ensure_Initialization; Enter (Self_Mutex); Leave (Self_Mutex); end Subscription_Change; ------------------------------ -- Disconnect_Push_Supplier -- ------------------------------ procedure Disconnect_Push_Supplier (Self : access Object) is Peer : CosEventComm.PushConsumer.Ref; Nil_Ref : CosEventComm.PushConsumer.Ref; begin pragma Debug (O ("disconnect proxypushsupplier")); Ensure_Initialization; Enter (Self_Mutex); Peer := Self.X.Peer; Self.X.Peer := Nil_Ref; Leave (Self_Mutex); if not CosEventComm.PushConsumer.Is_Nil (Peer) then CosEventComm.PushConsumer.disconnect_push_consumer (Peer); end if; end Disconnect_Push_Supplier; ------------ -- Create -- ------------ function Create (Admin : CosNotifyChannelAdmin.ConsumerAdmin.Ref; Initial_QoS : CosNotification.QoSProperties; Ptype : CosNotifyChannelAdmin.ProxyType; Proxy_Id : CosNotifyChannelAdmin.ProxyID) return Object_Ptr is Supplier : Object_Ptr; My_Ref : ProxyPushSupplier.Ref; begin pragma Debug (O ("create proxy pushsupplier")); Supplier := new Object; Supplier.X := new Proxy_Push_Supplier_Record; Supplier.X.Admin := Admin; Supplier.X.MyId := Proxy_Id; Supplier.X.MyType := Ptype; Supplier.X.This := Supplier; Supplier.X.QoSPropSeq := Initial_QoS; Initiate_Servant (PortableServer.Servant (Supplier), My_Ref); return Supplier; end Create; ---------- -- Post -- ---------- procedure Post (Self : access Object; Data : CORBA.Any) is MyPeer : CosEventComm.PushConsumer.Ref; begin pragma Debug (O ("post new data from proxy pushsupplier to push consumer")); Ensure_Initialization; Enter (Self_Mutex); MyPeer := Self.X.Peer; Leave (Self_Mutex); begin CosEventComm.PushConsumer.push (MyPeer, Data); exception when others => pragma Debug (O ("Got exception in post at proxy push supplier")); raise; end; end Post; end CosNotifyChannelAdmin.ProxyPushSupplier.Impl; ././@LongLink0000000000000000000000000000014600000000000011566 Lustar rootrootpolyorb-2.8~20110207.orig/cos/notification/cosnotifychanneladmin-structuredproxypullsupplier-impl.adbpolyorb-2.8~20110207.orig/cos/notification/cosnotifychanneladmin-structuredproxypullsupplier-impl.ad0000644000175000017500000007267311750740337033512 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- COSNOTIFYCHANNELADMIN.STRUCTUREDPROXYPULLSUPPLIER.IMPL -- -- -- -- B o d y -- -- -- -- Copyright (C) 2003-2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with CosEventChannelAdmin.Helper; with CosEventComm.Helper; with CosNotification; with CosNotification.Helper; with PolyORB.CORBA_P.Server_Tools; with PolyORB.Log; with PolyORB.Tasking.Mutexes; with PolyORB.Tasking.Semaphores; with PolyORB.Utils.Chained_Lists; with CosNotifyChannelAdmin.StructuredProxyPullSupplier.Skel; pragma Warnings (Off, CosNotifyChannelAdmin.StructuredProxyPullSupplier.Skel); package body CosNotifyChannelAdmin.StructuredProxyPullSupplier.Impl is use CosNotification; use IDL_SEQUENCE_CosNotification_Property; use IDL_SEQUENCE_CosNotification_PropertyError; use IDL_SEQUENCE_CosNotification_NamedPropertyRange; use CORBA; use PolyORB.CORBA_P.Server_Tools; use PolyORB.Tasking.Mutexes; use PolyORB.Tasking.Semaphores; package Convert is new ConsumerAdmin_Forward.Convert (CosNotifyChannelAdmin.ConsumerAdmin.Ref); use PolyORB.Log; package L is new PolyORB.Log.Facility_Log ("structuredproxypullsupplier"); procedure O (Message : Standard.String; Level : Log_Level := Debug) renames L.Output; function C (Level : Log_Level := Debug) return Boolean renames L.Enabled; pragma Unreferenced (C); -- For conditional pragma Debug package Event_Queues is new PolyORB.Utils.Chained_Lists (CosNotification.StructuredEvent); use Event_Queues; subtype Event_Queue is Event_Queues.List; type Structured_Proxy_Pull_Supplier_Record is record This : Object_Ptr; Admin : CosNotifyChannelAdmin.ConsumerAdmin.Ref; MyId : CosNotifyChannelAdmin.ProxyID; MyType : CosNotifyChannelAdmin.ProxyType; Peer : CosNotifyComm.StructuredPullConsumer.Ref; QoSPropSeq : CosNotification.QoSProperties; Queue : Event_Queue; Semaphore : Semaphore_Access; end record; --------------------------- -- Ensure_Initialization -- --------------------------- procedure Ensure_Initialization; pragma Inline (Ensure_Initialization); -- Ensure that the Mutexes are initialized T_Initialized : Boolean := False; Self_Mutex : Mutex_Access; procedure Ensure_Initialization is begin if not T_Initialized then Create (Self_Mutex); T_Initialized := True; end if; end Ensure_Initialization; -------------------------------------- -- Connect_Structured_Pull_Consumer -- -------------------------------------- procedure Connect_Structured_Pull_Consumer (Self : access Object; Pull_Consumer : CosNotifyComm.StructuredPullConsumer.Ref) is begin Ensure_Initialization; pragma Debug (O ("connect_structured_pull_consumer in structuredproxypullsupplier")); Enter (Self_Mutex); if not CosNotifyComm.StructuredPullConsumer.Is_Nil (Self.X.Peer) then Leave (Self_Mutex); CosEventChannelAdmin.Helper.Raise_AlreadyConnected ((CORBA.IDL_Exception_Members with null record)); end if; Self.X.Peer := Pull_Consumer; Leave (Self_Mutex); end Connect_Structured_Pull_Consumer; ---------------- -- Get_MyType -- ---------------- function Get_MyType (Self : access Object) return CosNotifyChannelAdmin.ProxyType is MyType : CosNotifyChannelAdmin.ProxyType; begin Ensure_Initialization; pragma Debug (O ("get_mytype in structuredproxypullsupplier")); Enter (Self_Mutex); MyType := Self.X.MyType; Leave (Self_Mutex); return MyType; end Get_MyType; ----------------- -- Get_MyAdmin -- ----------------- function Get_MyAdmin (Self : access Object) return CosNotifyChannelAdmin.ConsumerAdmin_Forward.Ref is MyAdmin : CosNotifyChannelAdmin.ConsumerAdmin_Forward.Ref; begin pragma Debug (O ("get_myadmin in structuredproxypullsupplier")); Ensure_Initialization; Enter (Self_Mutex); MyAdmin := Convert.To_Forward (Self.X.Admin); Leave (Self_Mutex); return MyAdmin; end Get_MyAdmin; ------------------------- -- Get_Priority_Filter -- ------------------------- function Get_Priority_Filter (Self : access Object) return CosNotifyFilter.MappingFilter.Ref is pragma Warnings (Off); -- WAG:3.14 pragma Unreferenced (Self); pragma Warnings (On); -- WAG:3.14 MyFilter : CosNotifyFilter.MappingFilter.Ref; begin Ensure_Initialization; pragma Debug (O ("get_priority_filter in structuredproxypullsupplier")); Enter (Self_Mutex); Leave (Self_Mutex); return MyFilter; end Get_Priority_Filter; ------------------------- -- Set_Priority_Filter -- ------------------------- procedure Set_Priority_Filter (Self : access Object; To : CosNotifyFilter.MappingFilter.Ref) is pragma Warnings (Off); -- WAG:3.14 pragma Unreferenced (Self, To); pragma Warnings (On); -- WAG:3.14 begin Ensure_Initialization; pragma Debug (O ("set_priority_filter in structuredproxypullsupplier")); Enter (Self_Mutex); Leave (Self_Mutex); end Set_Priority_Filter; ------------------------- -- Get_Lifetime_Filter -- ------------------------- function Get_Lifetime_Filter (Self : access Object) return CosNotifyFilter.MappingFilter.Ref is pragma Warnings (Off); -- WAG:3.14 pragma Unreferenced (Self); pragma Warnings (On); -- WAG:3.14 MyFilter : CosNotifyFilter.MappingFilter.Ref; begin Ensure_Initialization; pragma Debug (O ("get_lifetime_filter in structuredproxypullsupplier")); Enter (Self_Mutex); Leave (Self_Mutex); return MyFilter; end Get_Lifetime_Filter; ------------------------- -- Set_Lifetime_Filter -- ------------------------- procedure Set_Lifetime_Filter (Self : access Object; To : CosNotifyFilter.MappingFilter.Ref) is pragma Warnings (Off); -- WAG:3.14 pragma Unreferenced (Self, To); pragma Warnings (On); -- WAG:3.14 begin Ensure_Initialization; pragma Debug (O ("set_lifetime_filter in structuredproxypullsupplier")); Enter (Self_Mutex); Leave (Self_Mutex); end Set_Lifetime_Filter; -------------------------- -- Obtain_Offered_Types -- -------------------------- function Obtain_Offered_Types (Self : access Object; Mode : CosNotifyChannelAdmin.ObtainInfoMode) return CosNotification.EventTypeSeq is pragma Warnings (Off); -- WAG:3.14 pragma Unreferenced (Self, Mode); pragma Warnings (On); -- WAG:3.14 MySeq : CosNotification.EventTypeSeq; begin Ensure_Initialization; pragma Debug (O ("obtain_offered_types in structuredproxypullsupplier")); Enter (Self_Mutex); Leave (Self_Mutex); return MySeq; end Obtain_Offered_Types; ------------------------ -- Validate_Event_QoS -- ------------------------ procedure Validate_Event_QoS (Self : access Object; Required_QoS : CosNotification.QoSProperties; Available_QoS : out CosNotification.NamedPropertyRangeSeq) is pragma Warnings (Off); -- WAG:3.14 pragma Unreferenced (Self, Required_QoS, Available_QoS); pragma Warnings (On); -- WAG:3.14 begin Ensure_Initialization; pragma Debug (O ("validate_event_qos in structuredproxypullsupplier")); Enter (Self_Mutex); Leave (Self_Mutex); end Validate_Event_QoS; ------------- -- Get_QoS -- ------------- function Get_QoS (Self : access Object) return CosNotification.QoSProperties is MyQoS : CosNotification.QoSProperties; begin Ensure_Initialization; pragma Debug (O ("get_qos in structuredproxypullsupplier")); Enter (Self_Mutex); MyQoS := Self.X.QoSPropSeq; Leave (Self_Mutex); return MyQoS; end Get_QoS; ------------- -- Set_QoS -- ------------- procedure Set_QoS (Self : access Object; QoS : CosNotification.QoSProperties) is MyProp : CosNotification.Property; MyError : CosNotification.PropertyError; MyErrCode : CosNotification.QoSError_code; MyRange : CosNotification.PropertyRange; MyErrorSeq : CosNotification.PropertyErrorSeq; SeqLen : Integer; begin Ensure_Initialization; pragma Debug (O ("set_qos in structuredproxypullsupplier")); SeqLen := Length (QoS); for Index in 1 .. SeqLen loop MyProp := Get_Element (QoS, Index); if MyProp.name = "EventReliability" then MyErrCode := UNAVAILABLE_PROPERTY; MyRange := (To_Any (CORBA.Short (0)), To_Any (CORBA.Short (0))); MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); elsif MyProp.name = "ConnectionReliability" then if CORBA.Short'(From_Any (MyProp.value)) /= 0 and then CORBA.Short'(From_Any (MyProp.value)) /= 1 then MyErrCode := BAD_VALUE; MyRange := (To_Any (CORBA.Short (0)), To_Any (CORBA.Short (0))); MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); end if; elsif MyProp.name = "Priority" then if CORBA.Short'(From_Any (MyProp.value)) not in -32_767 .. 32_767 then MyErrCode := BAD_VALUE; MyRange := (To_Any (CORBA.Short (-32767)), To_Any (CORBA.Short (32767))); MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); end if; elsif MyProp.name = "StartTime" then MyErrCode := UNAVAILABLE_PROPERTY; MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); elsif MyProp.name = "StopTime" then MyErrCode := UNAVAILABLE_PROPERTY; MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); elsif MyProp.name = "Timeout" then MyErrCode := UNSUPPORTED_PROPERTY; MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); elsif MyProp.name = "OrderPolicy" then if CORBA.Short'(From_Any (MyProp.value)) /= 0 and then CORBA.Short'(From_Any (MyProp.value)) /= 1 and then CORBA.Short'(From_Any (MyProp.value)) /= 2 and then CORBA.Short'(From_Any (MyProp.value)) /= 3 then MyErrCode := BAD_VALUE; MyRange := (To_Any (CORBA.Short (0)), To_Any (CORBA.Short (3))); MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); end if; elsif MyProp.name = "DiscardPolicy" then if CORBA.Short'(From_Any (MyProp.value)) /= 0 and then CORBA.Short'(From_Any (MyProp.value)) /= 1 and then CORBA.Short'(From_Any (MyProp.value)) /= 2 and then CORBA.Short'(From_Any (MyProp.value)) /= 3 and then CORBA.Short'(From_Any (MyProp.value)) /= 4 then MyErrCode := BAD_VALUE; MyRange := (To_Any (CORBA.Short (0)), To_Any (CORBA.Short (4))); MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); end if; elsif MyProp.name = "MaximumBatchSize" then MyErrCode := UNSUPPORTED_PROPERTY; MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); elsif MyProp.name = "PacingInterval" then MyErrCode := UNSUPPORTED_PROPERTY; MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); elsif MyProp.name = "StartTimeSupported" then MyErrCode := UNSUPPORTED_PROPERTY; MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); elsif MyProp.name = "StopTimeSupported" then MyErrCode := UNSUPPORTED_PROPERTY; MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); elsif MyProp.name = "MaxEventsPerConsumer" then MyErrCode := UNSUPPORTED_PROPERTY; MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); else MyErrCode := BAD_PROPERTY; MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); end if; end loop; if Length (MyErrorSeq) > 0 then CosNotification.Helper.Raise_UnsupportedQoS ((CORBA.IDL_Exception_Members with qos_err => MyErrorSeq)); end if; SeqLen := Length (QoS); Enter (Self_Mutex); for Index in 1 .. SeqLen loop MyProp := Get_Element (QoS, Index); if MyProp.name = "ConnectionReliability" then Replace_Element (Self.X.QoSPropSeq, 2, MyProp); elsif MyProp.name = "Priority" then Replace_Element (Self.X.QoSPropSeq, 3, MyProp); elsif MyProp.name = "OrderPolicy" then Replace_Element (Self.X.QoSPropSeq, 4, MyProp); elsif MyProp.name = "DiscardPolicy" then Replace_Element (Self.X.QoSPropSeq, 5, MyProp); end if; end loop; Leave (Self_Mutex); end Set_QoS; ------------------ -- Validate_QoS -- ------------------ procedure Validate_QoS (Self : access Object; Required_QoS : CosNotification.QoSProperties; Available_QoS : out CosNotification.NamedPropertyRangeSeq) is MyProp : CosNotification.Property; MyError : CosNotification.PropertyError; MyErrCode : CosNotification.QoSError_code; MyNamedRange : CosNotification.NamedPropertyRange; MyRange : CosNotification.PropertyRange; MyErrorSeq : CosNotification.PropertyErrorSeq; SeqLen : Integer; begin Ensure_Initialization; pragma Debug (O ("validate_qos in structuredproxypullsupplier")); SeqLen := Length (Required_QoS); for Index in 1 .. SeqLen loop MyProp := Get_Element (Required_QoS, Index); if MyProp.name = "EventReliability" then MyErrCode := UNAVAILABLE_PROPERTY; MyRange := (To_Any (CORBA.Short (0)), To_Any (CORBA.Short (0))); MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); elsif MyProp.name = "ConnectionReliability" then if CORBA.Short'(From_Any (MyProp.value)) /= 0 and then CORBA.Short'(From_Any (MyProp.value)) /= 1 then MyErrCode := BAD_VALUE; MyRange := (To_Any (CORBA.Short (0)), To_Any (CORBA.Short (0))); MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); end if; elsif MyProp.name = "Priority" then if CORBA.Short'(From_Any (MyProp.value)) not in -32_767 .. 32_767 then MyErrCode := BAD_VALUE; MyRange := (To_Any (CORBA.Short (-32767)), To_Any (CORBA.Short (32767))); MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); end if; elsif MyProp.name = "StartTime" then MyErrCode := UNAVAILABLE_PROPERTY; MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); elsif MyProp.name = "StopTime" then MyErrCode := UNAVAILABLE_PROPERTY; MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); elsif MyProp.name = "Timeout" then MyErrCode := UNSUPPORTED_PROPERTY; MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); elsif MyProp.name = "OrderPolicy" then if CORBA.Short'(From_Any (MyProp.value)) /= 0 and then CORBA.Short'(From_Any (MyProp.value)) /= 1 and then CORBA.Short'(From_Any (MyProp.value)) /= 2 and then CORBA.Short'(From_Any (MyProp.value)) /= 3 then MyErrCode := BAD_VALUE; MyRange := (To_Any (CORBA.Short (0)), To_Any (CORBA.Short (3))); MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); end if; elsif MyProp.name = "DiscardPolicy" then if CORBA.Short'(From_Any (MyProp.value)) /= 0 and then CORBA.Short'(From_Any (MyProp.value)) /= 1 and then CORBA.Short'(From_Any (MyProp.value)) /= 2 and then CORBA.Short'(From_Any (MyProp.value)) /= 3 and then CORBA.Short'(From_Any (MyProp.value)) /= 4 then MyErrCode := BAD_VALUE; MyRange := (To_Any (CORBA.Short (0)), To_Any (CORBA.Short (4))); MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); end if; elsif MyProp.name = "MaximumBatchSize" then MyErrCode := UNSUPPORTED_PROPERTY; MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); elsif MyProp.name = "PacingInterval" then MyErrCode := UNSUPPORTED_PROPERTY; MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); elsif MyProp.name = "StartTimeSupported" then MyErrCode := UNSUPPORTED_PROPERTY; MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); elsif MyProp.name = "StopTimeSupported" then MyErrCode := UNSUPPORTED_PROPERTY; MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); elsif MyProp.name = "MaxEventsPerConsumer" then MyErrCode := UNSUPPORTED_PROPERTY; MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); else MyErrCode := BAD_PROPERTY; MyError := (MyErrCode, MyProp.name, MyRange); Append (MyErrorSeq, MyError); end if; end loop; if Length (MyErrorSeq) > 0 then CosNotification.Helper.Raise_UnsupportedQoS ((CORBA.IDL_Exception_Members with qos_err => MyErrorSeq)); end if; Enter (Self_Mutex); SeqLen := Length (Self.X.QoSPropSeq); for Index in 1 .. SeqLen loop MyProp := Get_Element (Self.X.QoSPropSeq, Index); if MyProp.name = "ConnectionReliability" then MyRange := (From_Any (MyProp.value), To_Any (CORBA.Short (0))); MyNamedRange := (MyProp.name, MyRange); Append (Available_QoS, MyNamedRange); elsif MyProp.name = "Priority" then MyRange := (To_Any (CORBA.Short (-32767)), To_Any (CORBA.Short (32767))); MyNamedRange := (MyProp.name, MyRange); Append (Available_QoS, MyNamedRange); elsif MyProp.name = "OrderPolicy" then MyRange := (To_Any (CORBA.Short (0)), To_Any (CORBA.Short (3))); MyNamedRange := (MyProp.name, MyRange); Append (Available_QoS, MyNamedRange); elsif MyProp.name = "DiscardPolicy" then MyRange := (To_Any (CORBA.Short (0)), To_Any (CORBA.Short (4))); MyNamedRange := (MyProp.name, MyRange); Append (Available_QoS, MyNamedRange); end if; end loop; Leave (Self_Mutex); end Validate_QoS; ---------------- -- Add_Filter -- ---------------- function Add_Filter (Self : access Object; New_Filter : CosNotifyFilter.Filter.Ref) return CosNotifyFilter.FilterID is pragma Warnings (Off); -- WAG:3.14 pragma Unreferenced (Self, New_Filter); pragma Warnings (On); -- WAG:3.14 MyFilterID : CosNotifyFilter.FilterID; MyID : CORBA.Long; begin Ensure_Initialization; pragma Debug (O ("add_filter in structuredproxypullsupplier")); Enter (Self_Mutex); Leave (Self_Mutex); MyID := 0; MyFilterID := CosNotifyFilter.FilterID (MyID); return MyFilterID; end Add_Filter; ------------------- -- Remove_Filter -- ------------------- procedure Remove_Filter (Self : access Object; Filter : CosNotifyFilter.FilterID) is pragma Warnings (Off); -- WAG:3.14 pragma Unreferenced (Self, Filter); pragma Warnings (On); -- WAG:3.14 begin Ensure_Initialization; pragma Debug (O ("remove_filter in structuredproxypullsupplier")); Enter (Self_Mutex); Leave (Self_Mutex); end Remove_Filter; ---------------- -- Get_Filter -- ---------------- function Get_Filter (Self : access Object; Filter : CosNotifyFilter.FilterID) return CosNotifyFilter.Filter.Ref is pragma Warnings (Off); -- WAG:3.14 pragma Unreferenced (Self, Filter); pragma Warnings (On); -- WAG:3.14 MyFilter : CosNotifyFilter.Filter.Ref; begin Ensure_Initialization; pragma Debug (O ("get_filter in structuredproxypullsupplier")); Enter (Self_Mutex); Leave (Self_Mutex); return MyFilter; end Get_Filter; --------------------- -- Get_All_Filters -- --------------------- function Get_All_Filters (Self : access Object) return CosNotifyFilter.FilterIDSeq is pragma Warnings (Off); -- WAG:3.14 pragma Unreferenced (Self); pragma Warnings (On); -- WAG:3.14 MyFilterSeq : CosNotifyFilter.FilterIDSeq; begin Ensure_Initialization; pragma Debug (O ("get_all_filters in structuredproxypullsupplier")); Enter (Self_Mutex); Leave (Self_Mutex); return MyFilterSeq; end Get_All_Filters; ------------------------ -- Remove_All_Filters -- ------------------------ procedure Remove_All_Filters (Self : access Object) is pragma Warnings (Off); -- WAG:3.14 pragma Unreferenced (Self); pragma Warnings (On); -- WAG:3.14 begin Ensure_Initialization; pragma Debug (O ("remove_all_filters in structuredproxypullsupplier")); Enter (Self_Mutex); Leave (Self_Mutex); end Remove_All_Filters; ------------------------- -- Subscription_Change -- ------------------------- procedure Subscription_Change (Self : access Object; Added : CosNotification.EventTypeSeq; Removed : CosNotification.EventTypeSeq) is pragma Warnings (Off); -- WAG:3.14 pragma Unreferenced (Self, Added, Removed); pragma Warnings (On); -- WAG:3.14 begin Ensure_Initialization; pragma Debug (O ("subscription_change in structuredproxypullsupplier")); Enter (Self_Mutex); Leave (Self_Mutex); end Subscription_Change; --------------------------- -- Pull_Structured_Event -- --------------------------- function Pull_Structured_Event (Self : access Object) return CosNotification.StructuredEvent is Event : CosNotification.StructuredEvent; begin Ensure_Initialization; pragma Debug (O ("attempt to pull structuredevent from structuredproxypullsupplier")); P (Self.X.Semaphore); Enter (Self_Mutex); if CosNotifyComm.StructuredPullConsumer.Is_Nil (Self.X.Peer) then Leave (Self_Mutex); CosEventComm.Helper.Raise_Disconnected ((CORBA.IDL_Exception_Members with null record)); end if; if State (Self.X.Semaphore) >= 0 then Extract_First (Self.X.Queue, Event); pragma Debug (O ("succeed to pull structuredevent from "& "structuredproxypullsupplier")); end if; Leave (Self_Mutex); return Event; end Pull_Structured_Event; ------------------------------- -- Try_Pull_Structured_Event -- ------------------------------- procedure Try_Pull_Structured_Event (Self : access Object; Has_Event : out CORBA.Boolean; Returns : out CosNotification.StructuredEvent) is begin pragma Debug (O ("try to pull structuredevent from structuredproxypullsupplier")); Ensure_Initialization; Enter (Self_Mutex); if CosNotifyComm.StructuredPullConsumer.Is_Nil (Self.X.Peer) then Leave (Self_Mutex); CosEventComm.Helper.Raise_Disconnected ((CORBA.IDL_Exception_Members with null record)); end if; Has_Event := State (Self.X.Semaphore) > 0; if Has_Event then Extract_First (Self.X.Queue, Returns); Leave (Self_Mutex); P (Self.X.Semaphore); else Leave (Self_Mutex); end if; end Try_Pull_Structured_Event; ----------------------------------------- -- Disconnect_Structured_Pull_Supplier -- ----------------------------------------- procedure Disconnect_Structured_Pull_Supplier (Self : access Object) is Peer : CosNotifyComm.StructuredPullConsumer.Ref; Nil_Ref : CosNotifyComm.StructuredPullConsumer.Ref; begin Ensure_Initialization; pragma Debug (O ("disconnect structuredproxypullsupplier")); Enter (Self_Mutex); Peer := Self.X.Peer; Self.X.Peer := Nil_Ref; Leave (Self_Mutex); V (Self.X.Semaphore); if not CosNotifyComm.StructuredPullConsumer.Is_Nil (Peer) then CosNotifyComm.StructuredPullConsumer. disconnect_structured_pull_consumer (Peer); end if; end Disconnect_Structured_Pull_Supplier; ------------ -- Create -- ------------ function Create (Admin : CosNotifyChannelAdmin.ConsumerAdmin.Ref; Initial_QoS : CosNotification.QoSProperties; Ptype : CosNotifyChannelAdmin.ProxyType; Proxy_Id : CosNotifyChannelAdmin.ProxyID) return Object_Ptr is Supplier : Object_Ptr; My_Ref : StructuredProxyPullSupplier.Ref; begin pragma Debug (O ("create structuredproxypullsupplier")); Supplier := new Object; Supplier.X := new Structured_Proxy_Pull_Supplier_Record; Supplier.X.Admin := Admin; Supplier.X.MyId := Proxy_Id; Supplier.X.MyType := Ptype; Supplier.X.This := Supplier; Supplier.X.QoSPropSeq := Initial_QoS; Create (Supplier.X.Semaphore); Initiate_Servant (PortableServer.Servant (Supplier), My_Ref); return Supplier; end Create; --------------------- -- Structured_Post -- --------------------- procedure Structured_Post (Self : access Object; Data : CosNotification.StructuredEvent) is begin pragma Debug (O ("post new structuredevent to structuredproxypullsupplier")); Ensure_Initialization; Enter (Self_Mutex); Append (Self.X.Queue, Data); Leave (Self_Mutex); V (Self.X.Semaphore); end Structured_Post; end CosNotifyChannelAdmin.StructuredProxyPullSupplier.Impl; polyorb-2.8~20110207.orig/cos/notification/cosnotifycomm-sequencepullconsumer-impl.ads0000644000175000017500000000725711750740337030475 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- COSNOTIFYCOMM.SEQUENCEPULLCONSUMER.IMPL -- -- -- -- S p e c -- -- -- -- Copyright (C) 2003-2008, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by ACT Europe. -- -- (email: sales@act-europe.fr) -- -- -- ------------------------------------------------------------------------------ with PortableServer; with CosNotifyChannelAdmin.SequenceProxyPullSupplier; package CosNotifyComm.SequencePullConsumer.Impl is type Object is new PortableServer.Servant_Base with private; type Object_Ptr is access all Object'Class; -- Inherited IDL operations from CosNotifyComm::NotifyPublish procedure Offer_Change (Self : access Object; Added : CosNotification.EventTypeSeq; Removed : CosNotification.EventTypeSeq); -- IDL operations procedure Disconnect_Sequence_Pull_Consumer (Self : access Object); ---------------------- -- PolyORB specific -- ---------------------- function Create return Object_Ptr; -- Call by application to create an object and activate servant procedure Connect_Sequence_Proxy_Pull_Supplier (Self : access Object; Proxy : CosNotifyChannelAdmin.SequenceProxyPullSupplier.Ref); -- Call by application to connect object to proxy function Pull (Self : access Object; Max_Number : CORBA.Long) return CosNotification.EventBatch; -- Call by application to consume a sequence of structured events procedure Try_Pull (Self : access Object; Max_Number : CORBA.Long; Done : out CORBA.Boolean; Returns : out CosNotification.EventBatch); -- Call by application to try to consume a sequence of structured events private type Sequence_Pull_Consumer_Record; type Sequence_Pull_Consumer_Access is access Sequence_Pull_Consumer_Record; type Object is new PortableServer.Servant_Base with record X : Sequence_Pull_Consumer_Access; end record; end CosNotifyComm.SequencePullConsumer.Impl; polyorb-2.8~20110207.orig/cos/notification/cosnotifycomm-sequencepushsupplier-impl.ads0000644000175000017500000000663111750740337030503 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- COSNOTIFYCOMM.SEQUENCEPUSHSUPPLIER.IMPL -- -- -- -- S p e c -- -- -- -- Copyright (C) 2003-2008, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by ACT Europe. -- -- (email: sales@act-europe.fr) -- -- -- ------------------------------------------------------------------------------ with PortableServer; with CosNotifyChannelAdmin.SequenceProxyPushConsumer; package CosNotifyComm.SequencePushSupplier.Impl is type Object is new PortableServer.Servant_Base with private; type Object_Ptr is access all Object'Class; -- Inherited IDL operations from CosNotifyComm::NotifySubscribe procedure Subscription_Change (Self : access Object; Added : CosNotification.EventTypeSeq; Removed : CosNotification.EventTypeSeq); -- IDL operations procedure Disconnect_Sequence_Push_Supplier (Self : access Object); ---------------------- -- PolyORB specific -- ---------------------- function Create return Object_Ptr; -- Call by application to create an object and activate servant procedure Connect_Sequence_Proxy_Push_Consumer (Self : access Object; Proxy : CosNotifyChannelAdmin.SequenceProxyPushConsumer.Ref); -- Call by application to connect object with proxy procedure Push (Self : access Object; Notifications : CosNotification.EventBatch); -- Call by application to push sequence of structured events private type Sequence_Push_Supplier_Record; type Sequence_Push_Supplier_Access is access Sequence_Push_Supplier_Record; type Object is new PortableServer.Servant_Base with record X : Sequence_Push_Supplier_Access; end record; end CosNotifyComm.SequencePushSupplier.Impl; polyorb-2.8~20110207.orig/cos/notification/cosnotifychanneladmin-proxypullsupplier-impl.ads0000644000175000017500000001303511750740337031533 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- COSNOTIFYCHANNELADMIN.PROXYPULLSUPPLIER.IMPL -- -- -- -- S p e c -- -- -- -- Copyright (C) 2003-2008, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by ACT Europe. -- -- (email: sales@act-europe.fr) -- -- -- ------------------------------------------------------------------------------ with CosNotifyChannelAdmin.ConsumerAdmin; with CosNotifyFilter.Filter; with CosNotifyFilter.MappingFilter; with PortableServer; package CosNotifyChannelAdmin.ProxyPullSupplier.Impl is type Object is new PortableServer.Servant_Base with private; type Object_Ptr is access all Object'Class; -- IDL operations procedure Connect_Any_Pull_Consumer (Self : access Object; Pull_Consumer : CosEventComm.PullConsumer.Ref); -- IDL operations inherited from CosNotifyChannelAdmin::ProxySupplier function Get_MyType (Self : access Object) return CosNotifyChannelAdmin.ProxyType; function Get_MyAdmin (Self : access Object) return CosNotifyChannelAdmin.ConsumerAdmin_Forward.Ref; function Get_Priority_Filter (Self : access Object) return CosNotifyFilter.MappingFilter.Ref; procedure Set_Priority_Filter (Self : access Object; To : CosNotifyFilter.MappingFilter.Ref); function Get_Lifetime_Filter (Self : access Object) return CosNotifyFilter.MappingFilter.Ref; procedure Set_Lifetime_Filter (Self : access Object; To : CosNotifyFilter.MappingFilter.Ref); function Obtain_Offered_Types (Self : access Object; Mode : CosNotifyChannelAdmin.ObtainInfoMode) return CosNotification.EventTypeSeq; procedure Validate_Event_QoS (Self : access Object; Required_QoS : CosNotification.QoSProperties; Available_QoS : out CosNotification.NamedPropertyRangeSeq); function Get_QoS (Self : access Object) return CosNotification.QoSProperties; procedure Set_QoS (Self : access Object; QoS : CosNotification.QoSProperties); procedure Validate_QoS (Self : access Object; Required_QoS : CosNotification.QoSProperties; Available_QoS : out CosNotification.NamedPropertyRangeSeq); function Add_Filter (Self : access Object; New_Filter : CosNotifyFilter.Filter.Ref) return CosNotifyFilter.FilterID; procedure Remove_Filter (Self : access Object; Filter : CosNotifyFilter.FilterID); function Get_Filter (Self : access Object; Filter : CosNotifyFilter.FilterID) return CosNotifyFilter.Filter.Ref; function Get_All_Filters (Self : access Object) return CosNotifyFilter.FilterIDSeq; procedure Remove_All_Filters (Self : access Object); -- IDL operations inherited from CosNotifyComm::PullSupplier procedure Subscription_Change (Self : access Object; Added : CosNotification.EventTypeSeq; Removed : CosNotification.EventTypeSeq); function Pull (Self : access Object) return CORBA.Any; procedure Try_Pull (Self : access Object; Has_Event : out CORBA.Boolean; Returns : out CORBA.Any); procedure Disconnect_Pull_Supplier (Self : access Object); ---------------------- -- PolyORB specific -- ---------------------- function Create (Admin : CosNotifyChannelAdmin.ConsumerAdmin.Ref; Initial_QoS : CosNotification.QoSProperties; Ptype : CosNotifyChannelAdmin.ProxyType; Proxy_Id : CosNotifyChannelAdmin.ProxyID) return Object_Ptr; procedure Post (Self : access Object; Data : CORBA.Any); private type Proxy_Pull_Supplier_Record; type Proxy_Pull_Supplier_Access is access Proxy_Pull_Supplier_Record; type Object is new PortableServer.Servant_Base with record X : Proxy_Pull_Supplier_Access; end record; end CosNotifyChannelAdmin.ProxyPullSupplier.Impl; polyorb-2.8~20110207.orig/cos/notification/cosnotifycomm-sequencepushconsumer-impl.adb0000644000175000017500000002166211750740337030453 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- COSNOTIFYCOMM.SEQUENCEPUSHCONSUMER.IMPL -- -- -- -- B o d y -- -- -- -- Copyright (C) 2003-2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with CosEventChannelAdmin.Helper; with CosEventComm.Helper; with PolyORB.CORBA_P.Server_Tools; with PolyORB.Log; with PolyORB.Tasking.Mutexes; with PolyORB.Tasking.Semaphores; with CosNotifyComm.SequencePushConsumer.Skel; pragma Warnings (Off, CosNotifyComm.SequencePushConsumer.Skel); package body CosNotifyComm.SequencePushConsumer.Impl is use PolyORB.CORBA_P.Server_Tools; use PolyORB.Tasking.Mutexes; use PolyORB.Tasking.Semaphores; use PolyORB.Log; package L is new PolyORB.Log.Facility_Log ("sequencepushconsumer"); procedure O (Message : Standard.String; Level : Log_Level := Debug) renames L.Output; function C (Level : Log_Level := Debug) return Boolean renames L.Enabled; pragma Unreferenced (C); -- For conditional pragma Debug type Sequence_Push_Consumer_Record is record This : Object_Ptr; Empty : Boolean; Events : CosNotification.EventBatch; Peer : CosNotifyChannelAdmin.SequenceProxyPushSupplier.Ref; Semaphore : Semaphore_Access; end record; --------------------------- -- Ensure_Initialization -- --------------------------- procedure Ensure_Initialization; pragma Inline (Ensure_Initialization); -- Ensure that the Mutexes are initialized T_Initialized : Boolean := False; Self_Mutex : Mutex_Access; procedure Ensure_Initialization is begin if not T_Initialized then Create (Self_Mutex); T_Initialized := True; end if; end Ensure_Initialization; ------------------ -- Offer_Change -- ------------------ procedure Offer_Change (Self : access Object; Added : CosNotification.EventTypeSeq; Removed : CosNotification.EventTypeSeq) is pragma Warnings (Off); -- WAG:3.14 pragma Unreferenced (Self, Added, Removed); pragma Warnings (On); -- WAG:3.14 begin Ensure_Initialization; pragma Debug (O ("offer_change in sequencepushconsumer")); Enter (Self_Mutex); Leave (Self_Mutex); end Offer_Change; ---------------------------- -- Push_Structured_Events -- ---------------------------- procedure Push_Structured_Events (Self : access Object; Notifications : CosNotification.EventBatch) is begin Ensure_Initialization; pragma Debug (O ("push sequence of structured events "& "to sequencepushconsumer")); Enter (Self_Mutex); Self.X.Empty := False; Self.X.Events := Notifications; Leave (Self_Mutex); V (Self.X.Semaphore); end Push_Structured_Events; ---------------------- ---------------- -- Disconnect_Sequence_Push_Consumer -- --------------------------------------- procedure Disconnect_Sequence_Push_Consumer (Self : access Object) is Peer : CosNotifyChannelAdmin.SequenceProxyPushSupplier.Ref; Nil_Ref : CosNotifyChannelAdmin.SequenceProxyPushSupplier.Ref; begin Ensure_Initialization; pragma Debug (O ("disconnect sequencepushconsumer")); Enter (Self_Mutex); Peer := Self.X.Peer; Self.X.Peer := Nil_Ref; Leave (Self_Mutex); V (Self.X.Semaphore); if not CosNotifyChannelAdmin.SequenceProxyPushSupplier.Is_Nil (Peer) then CosNotifyChannelAdmin.SequenceProxyPushSupplier. disconnect_sequence_push_supplier (Peer); end if; end Disconnect_Sequence_Push_Consumer; ------------ -- Create -- ------------ function Create return Object_Ptr is Consumer : Object_Ptr; My_Ref : SequencePushConsumer.Ref; Peer_Ref : CosNotifyChannelAdmin.SequenceProxyPushSupplier.Ref; begin pragma Debug (O ("create sequencepushconsumer")); Consumer := new Object; Consumer.X := new Sequence_Push_Consumer_Record; Consumer.X.This := Consumer; Consumer.X.Empty := True; Consumer.X.Peer := Peer_Ref; Create (Consumer.X.Semaphore); Initiate_Servant (PortableServer.Servant (Consumer), My_Ref); return Consumer; end Create; ------------------------------------------ -- Connect_Sequence_Proxy_Push_Supplier -- ------------------------------------------ procedure Connect_Sequence_Proxy_Push_Supplier (Self : access Object; Proxy : CosNotifyChannelAdmin.SequenceProxyPushSupplier.Ref) is My_Ref : SequencePushConsumer.Ref; begin Ensure_Initialization; pragma Debug (O ("connect_sequence_proxy_push_supplier in sequencepushconsumer")); Enter (Self_Mutex); if not CosNotifyChannelAdmin.SequenceProxyPushSupplier.Is_Nil (Self.X.Peer) then Leave (Self_Mutex); CosEventChannelAdmin.Helper.Raise_AlreadyConnected ((CORBA.IDL_Exception_Members with null record)); end if; Self.X.Peer := Proxy; Servant_To_Reference (PortableServer.Servant (Self.X.This), My_Ref); Leave (Self_Mutex); CosNotifyChannelAdmin.SequenceProxyPushSupplier. connect_sequence_push_consumer (Proxy, My_Ref); end Connect_Sequence_Proxy_Push_Supplier; ---------- -- Pull -- ---------- function Pull (Self : access Object) return CosNotification.EventBatch is Notifications : CosNotification.EventBatch; begin Ensure_Initialization; loop pragma Debug (O ("attempt to pull sequence of structured events " & "from sequencepushconsumer")); P (Self.X.Semaphore); Enter (Self_Mutex); if CosNotifyChannelAdmin.SequenceProxyPushSupplier.Is_Nil (Self.X.Peer) then Leave (Self_Mutex); CosEventComm.Helper.Raise_Disconnected ((CORBA.IDL_Exception_Members with null record)); end if; if not Self.X.Empty then Self.X.Empty := True; Notifications := Self.X.Events; Leave (Self_Mutex); exit; end if; Leave (Self_Mutex); end loop; pragma Debug (O ("succeded to pull sequence of structured events " & "from sequencepushconsumer")); return Notifications; end Pull; -------------- -- Try_Pull -- -------------- procedure Try_Pull (Self : access Object; Done : out CORBA.Boolean; Data : out CosNotification.EventBatch) is begin Ensure_Initialization; pragma Debug (O ("try to pull sequence of structured events " & "from sequencepushconsumer")); Enter (Self_Mutex); if CosNotifyChannelAdmin.SequenceProxyPushSupplier.Is_Nil (Self.X.Peer) then Leave (Self_Mutex); CosEventComm.Helper.Raise_Disconnected ((CORBA.IDL_Exception_Members with null record)); end if; Done := not Self.X.Empty; if Done then Self.X.Empty := True; Data := Self.X.Events; end if; Leave (Self_Mutex); end Try_Pull; end CosNotifyComm.SequencePushConsumer.Impl; polyorb-2.8~20110207.orig/cos/notification/cosnotifycomm-notifysubscribe-impl.ads0000644000175000017500000000537711750740337027427 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- C O S N O T I F Y C O M M . NO T I F Y S U B S C R I B E . I M P L -- -- -- -- S p e c -- -- -- -- Copyright (C) 2003 Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by ACT Europe. -- -- (email: sales@act-europe.fr) -- -- -- ------------------------------------------------------------------------------ -- with CORBA; with PortableServer; package CosNotifyComm.NotifySubscribe.Impl is type Object is new PortableServer.Servant_Base with private; type Object_Ptr is access all Object'Class; -- IDL operations procedure Subscription_Change (Self : access Object; Added : CosNotification.EventTypeSeq; Removed : CosNotification.EventTypeSeq); ---------------------- -- PolyORB specific -- ---------------------- function Create return Object_Ptr; private type Notify_Subscribe_Record; type Notify_Subscribe_Access is access Notify_Subscribe_Record; type Object is new PortableServer.Servant_Base with record X : Notify_Subscribe_Access; end record; end CosNotifyComm.NotifySubscribe.Impl; polyorb-2.8~20110207.orig/cos/naming/0000755000175000017500000000000011750740340016437 5ustar xavierxavierpolyorb-2.8~20110207.orig/cos/naming/file-impl.adb0000644000175000017500000000714111750740337020776 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- F I L E . I M P L -- -- -- -- B o d y -- -- -- -- Copyright (C) 2001-2007, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with CORBA.ORB; pragma Elaborate_All (CORBA.ORB); with PortableServer.POA.Helper; pragma Elaborate_All (PortableServer.POA); with File.Skel; pragma Warnings (Off, File.Skel); with File.Helper; package body File.Impl is type File_Ptr is access all Object'Class; Root_POA_String : constant CORBA.String := CORBA.To_CORBA_String ("RootPOA"); Root_POA : PortableServer.POA.Local_Ref; function Get_Root_POA return PortableServer.POA.Local_Ref; function Get_Root_POA return PortableServer.POA.Local_Ref is begin if PortableServer.POA.Is_Nil (Root_POA) then Root_POA := PortableServer.POA.Helper.To_Local_Ref (CORBA.ORB.Resolve_Initial_References (CORBA.ORB.ObjectId (Root_POA_String))); end if; return Root_POA; end Get_Root_POA; function New_File return File.Ref is Obj : constant File_Ptr := new Object; Oid : constant PortableServer.ObjectId := PortableServer.POA.Activate_Object (Get_Root_POA, PortableServer.Servant (Obj)); pragma Warnings (Off, Oid); -- Not referenced (created in order to -- evaluate the effects of Activate_Object). begin return File.Helper.To_Ref (PortableServer.POA.Servant_To_Reference (Get_Root_POA, PortableServer.Servant (Obj))); end New_File; function get_Image (Self : access Object) return CORBA.String is begin return Self.Image; end get_Image; procedure set_Image (Self : access Object; To : CORBA.String) is begin Self.Image := To; end set_Image; end File.Impl; polyorb-2.8~20110207.orig/cos/naming/README0000644000175000017500000000115511750740337017327 0ustar xavierxavierREADME for PolyORB Naming Service ---------------------------------- $Id: README 35694 2004-05-27 21:03:39Z hugues $ PolyORB provides an implementations of CORBA COS Naming Service : po_cos_naming : It is a stand alone excutable that runs an implementation of the CORBA COS Naming built on top of the CORBA personality. It is compliant to OMG's specifications. po_cos_naming_shell : provides a shell-like interface to navigate through a COS Naming context. This executable can either creates a Naming context, or attach itself to a remote context. ir_ab_names : XXX to be written polyorb-2.8~20110207.orig/cos/naming/cosnaming-namingcontext-impl.adb0000644000175000017500000005507611750740337024723 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- C O S N A M I N G . N A M I N G C O N T E X T . I M P L -- -- -- -- B o d y -- -- -- -- Copyright (C) 2001-2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with Ada.Unchecked_Deallocation; with PolyORB.CORBA_P.Server_Tools; with PolyORB.Exceptions; with PolyORB.Log; pragma Elaborate_All (PolyORB.Log); with PolyORB.Utils.Strings; with CosNaming.BindingIterator.Impl; with CosNaming.NamingContext.Helper; with CosNaming.NamingContext.Skel; pragma Warnings (Off, CosNaming.NamingContext.Skel); with GNAT.HTable; package body CosNaming.NamingContext.Impl is use CosNaming; use PolyORB.Log; package L is new PolyORB.Log.Facility_Log ("cosnaming.namingcontext"); procedure O (Message : String; Level : Log_Level := Debug) renames L.Output; function C (Level : Log_Level := Debug) return Boolean renames L.Enabled; pragma Unreferenced (C); -- For conditional pragma Debug package Names renames IDL_SEQUENCE_CosNaming_NameComponent; Null_Name : constant Name := Name (Names.Null_Sequence); -- Each naming context has its own internal id (Key). Bindings -- from local naming contexts are stored in the same hash table -- (BOHT). Each binding is encoded using its naming context -- internal id, its name component name and its name component -- type (Encode). subtype Hash_Header is Natural range 0 .. 30; function Hash (F : PolyORB.Utils.Strings.String_Ptr) return Hash_Header; function Equal (F1, F2 : PolyORB.Utils.Strings.String_Ptr) return Boolean; package BOHT is new GNAT.HTable.Simple_HTable (Header_Num => Hash_Header, Element => Bound_Object_Ptr, No_Element => null, Key => PolyORB.Utils.Strings.String_Ptr, Hash => Hash, Equal => Equal); function Encode (Ctx : Object_Ptr; N : NameComponent) return String; -- Encode this name component using the naming context internal -- id, the name component name and name component type. procedure Append_BO_To_NC (NC : Object_Ptr; Key : String; BN : NameComponent; BT : BindingType; Obj : CORBA.Object.Ref); -- Append a bound object to a naming context (NC). This bound -- object is composed of a binding (BN, BT) and an object Obj. -- Set a new entry in the hash table using its Key. procedure Display_NC (Text : String; NC : Object_Ptr); -- Display the list of bound objects of naming context NC with a -- output title Text. procedure Get_Ctx_And_Last_NC (Self : access Object; N : Name; Len : out Natural; Ctx : out NamingContext.Ref; NC : out NameComponent); -- Resolve N from a given naming context Self: split a name N into -- its naming context Ctx and the last name component NC. Len is -- the length of N. If Len = 1, then Ctx must be ignored. To avoid -- concurrent issues, we get a copy of the bound object lists -- (thread safe). function Look_For_BO_In_NC (NC : Object_Ptr; Key : String) return Bound_Object_Ptr; -- Look for a bound object in a naming context NC using its Key. procedure Remove_BO_From_NC (NC : Object_Ptr; BO : in out Bound_Object_Ptr); -- Remove a bound object from a naming context NC. function To_Name (NC : NameComponent) return Name; -- Basic function which returns a sequence of one name component. procedure Free is new Ada.Unchecked_Deallocation (Bound_Object, Bound_Object_Ptr); Seed : Key_Type := (others => 'A'); -------------- -- Allocate -- -------------- function Allocate return Key_Type; function Allocate return Key_Type is N : Natural := Key_Size; K : constant Key_Type := Seed; begin while N > 0 loop if Seed (N) /= 'Z' then Seed (N) := Character'Succ (Seed (N)); exit; end if; N := N - 1; end loop; if N = 0 then raise Program_Error; end if; while N < Key_Size loop N := N + 1; Seed (N) := 'A'; end loop; return K; end Allocate; --------------------- -- Append_BO_To_NC -- --------------------- procedure Append_BO_To_NC (NC : Object_Ptr; Key : String; BN : NameComponent; BT : BindingType; Obj : CORBA.Object.Ref) is BO : constant Bound_Object_Ptr := new Bound_Object; begin Display_NC ("register """ & Key & """ in naming context", NC); -- Append to the tail of the double linked list. BOHT.Set (new String'(Key), BO); BO.BN := BN; BO.BT := BT; BO.Obj := Obj; BO.NC := NC; if NC.Head = null then NC.Head := BO; NC.Tail := BO; else BO.Prev := NC.Tail; BO.Prev.Next := BO; NC.Tail := BO; end if; Display_NC ("append """ & Key & """ to naming context", NC); end Append_BO_To_NC; ---------- -- Bind -- ---------- procedure Bind (Self : access Object; N : Name; Obj : CORBA.Object.Ref) is Len : Natural; Ctx : NamingContext.Ref; Last : NameComponent; begin Get_Ctx_And_Last_NC (Self, N, Len, Ctx, Last); if Len /= 1 then NamingContext.bind (Ctx, To_Name (Last), Obj); else declare BON : constant String := Encode (Self.Self, Last); begin PTM.Enter (Self.Mutex); if Look_For_BO_In_NC (Self.Self, BON) /= null then PTM.Leave (Self.Mutex); raise AlreadyBound; end if; Append_BO_To_NC (Self.Self, BON, Last, nobject, Obj); PTM.Leave (Self.Mutex); end; end if; end Bind; ------------------ -- Bind_Context -- ------------------ procedure Bind_Context (Self : access Object; N : Name; NC : NamingContext.Ref) is Len : Natural; Ctx : NamingContext.Ref; Last : NameComponent; begin pragma Debug (O ("Bind_Context: enter")); Get_Ctx_And_Last_NC (Self, N, Len, Ctx, Last); pragma Debug (O ("Bind_Context: len is" & Len'Img)); if Len /= 1 then pragma Debug (O ("Bind_Context: binding relative name " & To_String (Last.id))); NamingContext.bind_context (Ctx, To_Name (Last), NC); else declare BON : constant String := Encode (Self.Self, Last); begin PTM.Enter (Self.Mutex); if Look_For_BO_In_NC (Self.Self, BON) /= null then PTM.Leave (Self.Mutex); raise AlreadyBound; end if; Append_BO_To_NC (Self.Self, BON, Last, ncontext, CORBA.Object.Ref (NC)); PTM.Leave (Self.Mutex); end; end if; end Bind_Context; ---------------------- -- Bind_New_Context -- ---------------------- function Bind_New_Context (Self : access Object; N : Name) return NamingContext.Ref'Class is Len : Natural; Ctx : NamingContext.Ref; Last : NameComponent; begin Get_Ctx_And_Last_NC (Self, N, Len, Ctx, Last); if Len /= 1 then return Ref (bind_new_context (Ctx, To_Name (Last))); else Ctx := NamingContext.Ref (New_Context (Self)); Bind_Context (Self, N, Ctx); return Ctx; end if; end Bind_New_Context; ------------ -- Create -- ------------ function Create return Object_Ptr is Obj : constant Object_Ptr := new Object; begin Initialize (Obj); return Obj; end Create; ---------------- -- Initialize -- ---------------- procedure Initialize (Self : Object_Ptr) is begin Self.Self := Self; Self.Key := Allocate; PTM.Create (Self.Mutex); end Initialize; ------------- -- Destroy -- ------------- procedure Destroy (Self : access Object) is begin if Self.Head /= null then raise NotEmpty; end if; end Destroy; ---------------- -- Display_NC -- ---------------- procedure Display_NC (Text : String; NC : Object_Ptr) is BO : Bound_Object_Ptr; begin O (Text, Notice); BO := NC.Head; while BO /= null loop O (String (NC.Key) & " ... " & To_Standard_String (BO.BN.id) & ASCII.HT & To_Standard_String (BO.BN.kind) & ASCII.HT & BO.BT'Img, Notice); BO := BO.Next; end loop; end Display_NC; ------------ -- Encode -- ------------ function Encode (Ctx : Object_Ptr; N : NameComponent) return String is Len : Natural; NI : constant Natural := Length (N.id); NK : constant Natural := Length (N.kind); begin Len := Key_Size + 1 + NI + 1 + NK + 1; declare BON : String (1 .. Len); begin BON (1 .. Key_Size) := String (Ctx.Key); Len := Key_Size + 1; BON (Len) := ASCII.HT; BON (Len + 1 .. Len + NI) := To_String (N.id); Len := Len + NI + 1; BON (Len) := ASCII.HT; BON (Len + 1 .. Len + NK) := To_String (N.kind); Len := Len + NK + 1; BON (Len) := ';'; return BON; end; end Encode; ----------- -- Equal -- ----------- function Equal (F1, F2 : PolyORB.Utils.Strings.String_Ptr) return Boolean is begin return F1.all = F2.all; end Equal; ------------------------- -- Get_Ctx_And_Last_NC -- ------------------------- procedure Get_Ctx_And_Last_NC (Self : access Object; N : Name; Len : out Natural; Ctx : out NamingContext.Ref; NC : out NameComponent) is use Names; begin pragma Debug (O ("Get_Ctx_And_Last_NC: enter")); PTM.Enter (Self.Mutex); declare NCA : Element_Array := To_Element_Array (Sequence (N)); Current_Obj : CORBA.Object.Ref; Current_Ctx : NamingContext.Ref; Current_Idx : Natural; begin PTM.Leave (Self.Mutex); Len := NCA'Length; if Len = 0 then raise InvalidName; end if; if Len > 1 then Current_Idx := NCA'First; pragma Debug (O ("Get_Ctx_And_Last_NC: resolve " & To_String (NCA (Current_Idx).id))); Current_Obj := Resolve (Self, To_Name (NCA (Current_Idx))); Current_Ctx := NamingContext.Helper.To_Ref (Current_Obj); Current_Idx := Current_Idx + 1; while Current_Idx < NCA'Last loop pragma Debug (O ("Get_Ctx_And_Last_NC: resolve " & To_String (NCA (Current_Idx).id))); Current_Obj := resolve (Current_Ctx, To_Name (NCA (Current_Idx))); Current_Ctx := NamingContext.Helper.To_Ref (Current_Obj); Current_Idx := Current_Idx + 1; end loop; Ctx := Current_Ctx; end if; NC := NCA (NCA'Last); exception when CORBA.Bad_Param => declare Member : NotFound_Members; begin -- Cannot cast the current name component into a -- naming context. Member.why := not_context; Member.rest_of_name := To_Sequence (NCA (Current_Idx + 1 .. NCA'Last)); PolyORB.Exceptions.User_Raise_Exception (NotFound'Identity, Member); end; end; end Get_Ctx_And_Last_NC; ---------- -- Hash -- ---------- function Hash (F : PolyORB.Utils.Strings.String_Ptr) return Hash_Header is N : Natural := 0; begin -- Add up characters of name, mod our table size for J in F'Range loop N := (N + Character'Pos (F (J))) mod (Hash_Header'Last + 1); end loop; return N; end Hash; ---------- -- List -- ---------- procedure List (Self : access Object; How_Many : CORBA.Unsigned_Long; BL : out BindingList; BI : out BindingIterator_Forward.Ref) is use BindingIterator.Impl; Len : Natural := 0; Size : Natural := Natural (How_Many); Head : Bound_Object_Ptr; Iter : BindingIterator.Impl.Object_Ptr; begin PTM.Enter (Self.Mutex); -- How many bound objects in this naming context. Head := Self.Head; while Head /= null loop Len := Len + 1; Head := Head.Next; end loop; Head := Self.Head; -- First, copy the first bound objects to fill BL. if Len < Size then Size := Len; end if; if Size > 0 then declare Table : Bindings.Element_Array (1 .. Size); begin for I in 1 .. Size loop Table (I) := (To_Name (Head.BN), Head.BT); Head := Head.Next; end loop; BL := BindingList (Bindings.To_Sequence (Table)); Len := Len - Size; end; end if; Iter := BindingIterator.Impl.Create; Iter.Index := 1; Iter.Table := new Bindings.Element_Array (1 .. Len); -- Copy the remaining bound objects into the iterator. for I in Iter.Table'Range loop Iter.Table (I) := (To_Name (Head.BN), Head.BT); Head := Head.Next; end loop; PTM.Leave (Self.Mutex); -- Activate object Iterator. PolyORB.CORBA_P.Server_Tools.Initiate_Servant (PortableServer.Servant (Iter), BI); end List; ----------------------- -- Look_For_BO_In_NC -- ----------------------- function Look_For_BO_In_NC (NC : Object_Ptr; Key : String) return Bound_Object_Ptr is begin Display_NC ("look for """ & Key & """", NC); return BOHT.Get (Key'Unrestricted_Access); end Look_For_BO_In_NC; ----------------- -- New_Context -- ----------------- function New_Context (Self : access Object) return NamingContext.Ref'Class is pragma Warnings (Off); pragma Unreferenced (Self); pragma Warnings (On); My_Ref : NamingContext.Ref; begin PolyORB.CORBA_P.Server_Tools.Initiate_Servant (PortableServer.Servant (Impl.Create), My_Ref); return My_Ref; end New_Context; ------------ -- Rebind -- ------------ procedure Rebind (Self : access Object; N : Name; Obj : CORBA.Object.Ref) is Len : Natural; Ctx : NamingContext.Ref; Last : NameComponent; begin Get_Ctx_And_Last_NC (Self, N, Len, Ctx, Last); if Len /= 1 then rebind (Ctx, To_Name (Last), Obj); else declare BON : constant String := Encode (Self.Self, Last); BO : Bound_Object_Ptr; begin PTM.Enter (Self.Mutex); BO := Look_For_BO_In_NC (Self.Self, BON); if BO = null then PTM.Leave (Self.Mutex); declare Member : NotFound_Members; begin Member.why := missing_node; Member.rest_of_name := Null_Name; PolyORB.Exceptions.User_Raise_Exception (NotFound'Identity, Member); end; end if; if BO.BT /= nobject then PTM.Leave (Self.Mutex); declare Member : NotFound_Members; begin Member.why := not_object; Member.rest_of_name := Null_Name; PolyORB.Exceptions.User_Raise_Exception (NotFound'Identity, Member); end; end if; Remove_BO_From_NC (Self.Self, BO); Append_BO_To_NC (Self.Self, BON, Last, nobject, Obj); PTM.Leave (Self.Mutex); end; end if; end Rebind; -------------------- -- Rebind_Context -- -------------------- procedure Rebind_Context (Self : access Object; N : Name; NC : NamingContext.Ref) is Len : Natural; Ctx : NamingContext.Ref; Last : NameComponent; begin Get_Ctx_And_Last_NC (Self, N, Len, Ctx, Last); if Len /= 1 then NamingContext.rebind_context (Ctx, To_Name (Last), NC); else declare BON : constant String := Encode (Self.Self, Last); BO : Bound_Object_Ptr; begin PTM.Enter (Self.Mutex); BO := Look_For_BO_In_NC (Self.Self, BON); if BO = null then PTM.Leave (Self.Mutex); declare Member : NotFound_Members; begin Member.why := missing_node; Member.rest_of_name := Null_Name; PolyORB.Exceptions.User_Raise_Exception (NotFound'Identity, Member); end; end if; if BO.BT /= ncontext then PTM.Leave (Self.Mutex); declare Member : NotFound_Members; begin Member.why := not_context; Member.rest_of_name := Null_Name; PolyORB.Exceptions.User_Raise_Exception (NotFound'Identity, Member); end; end if; Remove_BO_From_NC (Self.Self, BO); Append_BO_To_NC (Self.Self, BON, Last, ncontext, CORBA.Object.Ref (NC)); PTM.Leave (Self.Mutex); end; end if; end Rebind_Context; ----------------------- -- Remove_BO_From_NC -- ----------------------- procedure Remove_BO_From_NC (NC : Object_Ptr; BO : in out Bound_Object_Ptr) is begin if BO.Next /= null then BO.Next.Prev := BO.Prev; end if; if BO.Prev /= null then BO.Prev.Next := BO.Next; end if; if NC.Head = BO then NC.Head := BO.Next; end if; if NC.Tail = BO then NC.Tail := BO.Prev; end if; BO.Prev := null; BO.Next := null; declare BON : constant String := Encode (NC, BO.BN); begin BOHT.Set (BON'Unrestricted_Access, null); end; Free (BO); Display_NC ("remove object from naming context", NC); end Remove_BO_From_NC; ------------- -- Resolve -- ------------- function Resolve (Self : access Object; N : Name) return CORBA.Object.Ref is Len : Natural; Ctx : NamingContext.Ref; Last : NameComponent; begin Get_Ctx_And_Last_NC (Self, N, Len, Ctx, Last); if Len /= 1 then return NamingContext.resolve (Ctx, To_Name (Last)); else declare BON : constant String := Encode (Self.Self, Last); BO : Bound_Object_Ptr; Obj : CORBA.Object.Ref; begin PTM.Enter (Self.Mutex); BO := Look_For_BO_In_NC (Self.Self, BON); if BO = null then PTM.Leave (Self.Mutex); declare Member : NotFound_Members; begin Member.why := missing_node; Member.rest_of_name := Null_Name; PolyORB.Exceptions.User_Raise_Exception (NotFound'Identity, Member); end; end if; Obj := BO.Obj; PTM.Leave (Self.Mutex); return Obj; end; end if; end Resolve; ------------- -- To_Name -- ------------- function To_Name (NC : NameComponent) return Name is begin return Name (Names.To_Sequence ((1 => NC))); end To_Name; ------------ -- Unbind -- ------------ procedure Unbind (Self : access Object; N : Name) is Len : Natural; Ctx : NamingContext.Ref; Last : NameComponent; begin Get_Ctx_And_Last_NC (Self, N, Len, Ctx, Last); if Len /= 1 then unbind (Ctx, To_Name (Last)); else declare BON : constant String := Encode (Self.Self, Last); BO : Bound_Object_Ptr; begin PTM.Enter (Self.Mutex); BO := Look_For_BO_In_NC (Self.Self, BON); if BO = null then PTM.Leave (Self.Mutex); declare Member : NotFound_Members; begin Member.why := missing_node; Member.rest_of_name := Null_Name; PolyORB.Exceptions.User_Raise_Exception (NotFound'Identity, Member); end; end if; Remove_BO_From_NC (Self.Self, BO); PTM.Leave (Self.Mutex); end; end if; end Unbind; end CosNaming.NamingContext.Impl; polyorb-2.8~20110207.orig/cos/naming/cosnaming-bindingiterator-impl.adb0000644000175000017500000001000611750740337025211 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- C O S N A M I N G . B I N D I N G I T E R A T O R . I M P L -- -- -- -- B o d y -- -- -- -- Copyright (C) 2001-2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with Ada.Unchecked_Deallocation; with CosNaming.BindingIterator.Skel; pragma Warnings (Off, CosNaming.BindingIterator.Skel); package body CosNaming.BindingIterator.Impl is Null_Binding : constant Binding := (To_Sequence (0), nobject); procedure Free is new Ada.Unchecked_Deallocation (Bindings.Element_Array, Binding_Element_Array_Ptr); ------------ -- Create -- ------------ function Create return Object_Ptr is Obj : Object_Ptr; begin Obj := new Object; Obj.Self := Obj; PTM.Create (Obj.Mutex); return Obj; end Create; ------------- -- Destroy -- ------------- procedure Destroy (Self : access Object) is begin PTM.Enter (Self.Mutex); if Self.Table /= null then Free (Self.Table); end if; PTM.Leave (Self.Mutex); end Destroy; -------------- -- Next_One -- -------------- procedure Next_One (Self : access Object; B : out CosNaming.Binding; Returns : out CORBA.Boolean) is begin PTM.Enter (Self.Mutex); if Self.Index <= Self.Table'Last then B := Self.Table (Self.Index); Self.Index := Self.Index + 1; Returns := True; else B := Null_Binding; Returns := False; end if; PTM.Leave (Self.Mutex); end Next_One; ------------ -- Next_N -- ------------ procedure Next_N (Self : access Object; How_Many : CORBA.Unsigned_Long; BL : out CosNaming.BindingList; Returns : out CORBA.Boolean) is First : Natural renames Self.Index; Last : Natural; begin PTM.Enter (Self.Mutex); Last := Self.Index + Natural (How_Many) - 1; if Last <= Self.Table'Last then BL := BindingList (Bindings.To_Sequence (Self.Table (First .. Last))); Self.Index := Last + 1; Returns := True; else Returns := False; end if; PTM.Leave (Self.Mutex); end Next_N; end CosNaming.BindingIterator.Impl; polyorb-2.8~20110207.orig/cos/naming/cosnaming-bindingiterator-impl.ads0000644000175000017500000000572311750740337025244 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- C O S N A M I N G . B I N D I N G I T E R A T O R . I M P L -- -- -- -- S p e c -- -- -- -- Copyright (C) 2001-2008, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with CORBA; with PortableServer; with PolyORB.Tasking.Mutexes; package CosNaming.BindingIterator.Impl is type Object; type Object_Ptr is access all Object'Class; package Bindings renames IDL_SEQUENCE_CosNaming_Binding; package PTM renames PolyORB.Tasking.Mutexes; type Binding_Element_Array_Ptr is access Bindings.Element_Array; type Object is new PortableServer.Servant_Base with record Self : Object_Ptr; Index : Natural; Table : Binding_Element_Array_Ptr; Mutex : PTM.Mutex_Access; end record; procedure Next_One (Self : access Object; B : out CosNaming.Binding; Returns : out CORBA.Boolean); procedure Next_N (Self : access Object; How_Many : CORBA.Unsigned_Long; BL : out CosNaming.BindingList; Returns : out CORBA.Boolean); procedure Destroy (Self : access Object); function Create return Object_Ptr; end CosNaming.BindingIterator.Impl; polyorb-2.8~20110207.orig/cos/naming/cosnaming-namingcontext-impl.ads0000644000175000017500000001023311750740337024726 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- C O S N A M I N G . N A M I N G C O N T E X T . I M P L -- -- -- -- S p e c -- -- -- -- Copyright (C) 2001-2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with CORBA; with PortableServer; with PolyORB.Tasking.Mutexes; package CosNaming.NamingContext.Impl is type Object is new PortableServer.Servant_Base with private; type Object_Ptr is access all Object'Class; procedure Bind (Self : access Object; N : CosNaming.Name; Obj : CORBA.Object.Ref); procedure Rebind (Self : access Object; N : CosNaming.Name; Obj : CORBA.Object.Ref); procedure Bind_Context (Self : access Object; N : CosNaming.Name; NC : CosNaming.NamingContext.Ref); procedure Rebind_Context (Self : access Object; N : CosNaming.Name; NC : CosNaming.NamingContext.Ref); function Resolve (Self : access Object; N : CosNaming.Name) return CORBA.Object.Ref; procedure Unbind (Self : access Object; N : CosNaming.Name); function New_Context (Self : access Object) return CosNaming.NamingContext.Ref'Class; function Bind_New_Context (Self : access Object; N : CosNaming.Name) return CosNaming.NamingContext.Ref'Class; procedure Destroy (Self : access Object); procedure List (Self : access Object; How_Many : CORBA.Unsigned_Long; BL : out CosNaming.BindingList; BI : out CosNaming.BindingIterator_Forward.Ref); function Create return CosNaming.NamingContext.Impl.Object_Ptr; procedure Initialize (Self : Object_Ptr); private package PTM renames PolyORB.Tasking.Mutexes; Key_Size : constant := 4; type Key_Type is new String (1 .. Key_Size); type Bound_Object; type Bound_Object_Ptr is access Bound_Object; type Bound_Object is record BN : NameComponent; BT : BindingType; Obj : CORBA.Object.Ref; Prev : Bound_Object_Ptr; Next : Bound_Object_Ptr; NC : Object_Ptr; end record; type Object is new PortableServer.Servant_Base with record Key : Key_Type; Self : Object_Ptr; Prev : Object_Ptr; Next : Object_Ptr; Head : Bound_Object_Ptr; Tail : Bound_Object_Ptr; Mutex : PTM.Mutex_Access; end record; end CosNaming.NamingContext.Impl; polyorb-2.8~20110207.orig/cos/naming/file-impl.ads0000644000175000017500000000461511750740337021022 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- F I L E . I M P L -- -- -- -- S p e c -- -- -- -- Copyright (C) 2001-2008, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by ACT Europe. -- -- (email: sales@act-europe.fr) -- -- -- ------------------------------------------------------------------------------ with CORBA; with PortableServer; package File.Impl is type Object is new PortableServer.Servant_Base with record Image : CORBA.String; end record; function New_File return File.Ref; function get_Image (Self : access Object) return CORBA.String; procedure set_Image (Self : access Object; To : CORBA.String); end File.Impl; polyorb-2.8~20110207.orig/cos/naming/menu.ads0000644000175000017500000000455611750740337020114 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- M E N U -- -- -- -- S p e c -- -- -- -- Copyright (C) 2001-2003 Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by ACT Europe. -- -- (email: sales@act-europe.fr) -- -- -- ------------------------------------------------------------------------------ package Menu is type String_Access is access String; function "+" (S : String) return String_Access; function Argument (Index : Natural) return String_Access; function Count (Prompt : String := "> ") return Natural; procedure To_Lower (S : String_Access); procedure Set_Input (Filename : String_Access); end Menu; polyorb-2.8~20110207.orig/cos/naming/File.idl0000644000175000017500000000005711750740337020020 0ustar xavierxavierinterface File { attribute string Image; }; polyorb-2.8~20110207.orig/cos/naming/cosnaming-namingcontextext-impl.adb0000644000175000017500000001231111750740337025425 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- C O S N A M I N G . N A M I N G C O N T E X T E X T . I M P L -- -- -- -- B o d y -- -- -- -- Copyright (C) 2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with PolyORB.Utils; with CosNaming.NamingContextExt.Helper; with CosNaming.NamingContextExt.Skel; pragma Warnings (Off, CosNaming.NamingContextExt.Skel); with PolyORB.CORBA_P.Naming_Tools; package body CosNaming.NamingContextExt.Impl is use PolyORB.Utils; --------------- -- To_String -- --------------- function To_String (Self : access Object; N : CosNaming.Name) return CosNaming.NamingContextExt.StringName is pragma Unreferenced (Self); Result : CosNaming.NamingContextExt.StringName; begin for J in 1 .. Length (N) loop if Get_Element (N, J).kind = "" then if Get_Element (N, J).id = "" then Result := Result & "."; else Result := Result & StringName (Get_Element (N, J).id); end if; else Result := Result & To_CORBA_String (URI_Encode (To_Standard_String (StringName (Get_Element (N, J).id)))) & "." & StringName (Get_Element (N, J).kind); end if; if J < Length (N) then Result := Result & "/"; end if; end loop; return Result; end To_String; ------------- -- To_Name -- ------------- function To_Name (Self : access Object; Sn : CosNaming.NamingContextExt.StringName) return CosNaming.Name is pragma Unreferenced (Self); begin return PolyORB.CORBA_P.Naming_Tools.Parse_Name (To_String (Sn)); end To_Name; ------------ -- To_Url -- ------------ function To_Url (Self : access Object; Addr : CosNaming.NamingContextExt.Address; Sn : CosNaming.NamingContextExt.StringName) return CosNaming.NamingContextExt.URLString is pragma Unreferenced (Self); Result : CosNaming.NamingContextExt.URLString; begin if Addr = To_CORBA_String ("") then CosNaming.NamingContextExt.Helper.Raise_InvalidAddress (InvalidAddress_Members' (CORBA.IDL_Exception_Members with null record)); end if; Result := To_CORBA_String (URI_Encode (To_Standard_String (Addr))) & "/" & To_CORBA_String (URI_Encode (To_Standard_String (Sn))); return Result; end To_Url; ----------------- -- Resolve_Str -- ----------------- function Resolve_Str (Self : access Object; Sn : CosNaming.NamingContextExt.StringName) return CORBA.Object.Ref is Result : CORBA.Object.Ref; begin Result := CosNaming.NamingContext.Impl.Resolve (CosNaming.NamingContext.Impl.Object (Self.all)'Access, To_Name (Self, Sn)); return Result; end Resolve_Str; ------------ -- Create -- ------------ function Create return CosNaming.NamingContextExt.Impl.Object_Ptr is Obj : constant Object_Ptr := new Object; begin Initialize (Obj); return Obj; end Create; ---------------- -- Initialize -- ---------------- procedure Initialize (Self : Object_Ptr) is begin CosNaming.NamingContext.Impl.Initialize (CosNaming.NamingContext.Impl.Object_Ptr (Self)); end Initialize; end CosNaming.NamingContextExt.Impl; polyorb-2.8~20110207.orig/cos/naming/menu.adb0000644000175000017500000001243711750740337020070 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- M E N U -- -- -- -- B o d y -- -- -- -- Copyright (C) 2001-2008, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by ACT Europe. -- -- (email: sales@act-europe.fr) -- -- -- ------------------------------------------------------------------------------ with Ada.Text_IO; use Ada.Text_IO; with Ada.Unchecked_Deallocation; package body Menu is procedure Free is new Ada.Unchecked_Deallocation (String, String_Access); Args : array (1 .. 16) of String_Access; Argc : Natural; Line : String (1 .. 1024); Last : Natural; Scan : Natural; Pipe : Boolean := False; File : File_Type; function Next return String; --------- -- "+" -- --------- function "+" (S : String) return String_Access is begin return new String'(S); end "+"; -------------- -- Argument -- -------------- function Argument (Index : Natural) return String_Access is begin if Index > Argc then raise Constraint_Error; end if; return Args (Index); end Argument; ----------- -- Count -- ----------- function Count (Prompt : String := "> ") return Natural is begin Put (Prompt); begin Get_Line (Current_Input, Line, Last); exception when others => Close (File); Set_Input (Standard_Input); Pipe := False; Get_Line (Current_Input, Line, Last); end; if Pipe then Put_Line (Line (1 .. Last)); end if; Scan := 1; Argc := 0; loop declare Arg : constant String := Next; begin exit when Arg = ""; Argc := Argc + 1; if Args (Argc) /= null then Free (Args (Argc)); end if; Args (Argc) := new String'(Arg); end; end loop; return Argc; end Count; ---------- -- Next -- ---------- function Next return String is use ASCII; F, L : Natural; begin while Scan <= Last and then (Line (Scan) = ' ' or else Line (Scan) = HT) loop Scan := Scan + 1; end loop; if Scan > Last then return ""; end if; if Line (Scan) = '"' then -- " Scan := Scan + 1; F := Scan; while Scan <= Last loop if Line (Scan) = '"' then -- " L := Scan - 1; Scan := Scan + 1; return Line (F .. L); elsif Line (Scan) = NUL then return ""; end if; Scan := Scan + 1; end loop; return ""; else F := Scan; while Scan <= Last and then Line (Scan) /= ' ' and then Line (Scan) /= HT loop L := Scan; Scan := Scan + 1; end loop; return Line (F .. L); end if; end Next; --------------- -- Set_Input -- --------------- procedure Set_Input (Filename : String_Access) is begin Open (File, In_File, Filename.all); Set_Input (File); Pipe := True; exception when others => Put_Line ("no such file"); end Set_Input; -------------- -- To_Lower -- -------------- procedure To_Lower (S : String_Access) is begin for I in S'Range loop if S (I) in 'A' .. 'Z' then S (I) := Character'Val (Character'Pos (S (I)) - Character'Pos ('A') + Character'Pos ('a')); end if; end loop; end To_Lower; end Menu; polyorb-2.8~20110207.orig/cos/naming/cosnaming-namingcontextext-impl.ads0000644000175000017500000000611711750740337025455 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- C O S N A M I N G . N A M I N G C O N T E X T E X T . I M P L -- -- -- -- S p e c -- -- -- -- Copyright (C) 2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with CORBA.Object; with CosNaming.NamingContext.Impl; pragma Elaborate_All (CosNaming.NamingContext.Impl); package CosNaming.NamingContextExt.Impl is type Object is new CosNaming.NamingContext.Impl.Object with private; type Object_Ptr is access all Object'Class; function To_String (Self : access Object; N : CosNaming.Name) return CosNaming.NamingContextExt.StringName; function To_Name (Self : access Object; Sn : CosNaming.NamingContextExt.StringName) return CosNaming.Name; function To_Url (Self : access Object; Addr : CosNaming.NamingContextExt.Address; Sn : CosNaming.NamingContextExt.StringName) return CosNaming.NamingContextExt.URLString; function Resolve_Str (Self : access Object; Sn : CosNaming.NamingContextExt.StringName) return CORBA.Object.Ref; function Create return CosNaming.NamingContextExt.Impl.Object_Ptr; procedure Initialize (Self : Object_Ptr); private type Object is new CosNaming.NamingContext.Impl.Object with null record; end CosNaming.NamingContextExt.Impl; polyorb-2.8~20110207.orig/cos/time/0000755000175000017500000000000011750740340016124 5ustar xavierxavierpolyorb-2.8~20110207.orig/cos/time/costime-uto-impl.ads0000644000175000017500000000600011750740337022026 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- C O S T I M E . U T O . I M P L -- -- -- -- S p e c -- -- -- -- Copyright (C) 2001-2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with TimeBase; with PortableServer; package CosTime.UTO.Impl is type Object is new PortableServer.Servant_Base with record Time : TimeBase.TimeT := 0; Inaccuracy : TimeBase.InaccuracyT := 0; Tdf : TimeBase.TdfT := 0; end record; function get_time (Self : access Object) return TimeBase.TimeT; function get_inaccuracy (Self : access Object) return TimeBase.InaccuracyT; function get_tdf (Self : access Object) return TimeBase.TdfT; function get_utc_time (Self : access Object) return TimeBase.UtcT; function absolute_time (Self : access Object) return Ref'Class; function compare_time (Self : access Object; comparison_type : ComparisonType; uto : Ref) return TimeComparison; function time_to_interval (Self : access Object; uto : Ref) return TIO_Forward.Ref; function interval (Self : access Object) return TIO_Forward.Ref; end CosTime.UTO.Impl; polyorb-2.8~20110207.orig/cos/time/costime-timeservice-impl.ads0000644000175000017500000000550511750740337023547 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- C O S T I M E . T I M E S E R V I C E . I M P L -- -- -- -- S p e c -- -- -- -- Copyright (C) 2001-2008, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with CosTime.TIO; with TimeBase; with CosTime.UTO; with PortableServer; package CosTime.TimeService.Impl is type Object is new PortableServer.Servant_Base with null record; function universal_time (Self : access Object) return CosTime.UTO.Ref; function secure_universal_time (Self : access Object) return CosTime.UTO.Ref; function new_universal_time (Self : access Object; time : TimeBase.TimeT; inaccuracy : TimeBase.InaccuracyT; tdf : TimeBase.TdfT) return CosTime.UTO.Ref; function uto_from_utc (Self : access Object; utc : TimeBase.UtcT) return CosTime.UTO.Ref; function new_interval (Self : access Object; lower : TimeBase.TimeT; upper : TimeBase.TimeT) return CosTime.TIO.Ref; end CosTime.TimeService.Impl; polyorb-2.8~20110207.orig/cos/time/costime-timeservice-impl.adb0000644000175000017500000001124711750740337023526 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- C O S T I M E . T I M E S E R V I C E . I M P L -- -- -- -- B o d y -- -- -- -- Copyright (C) 2001-2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with PolyORB.CORBA_P.Server_Tools; with Time_Utils; with CosTime.TIO.Impl; with CosTime.UTO.Impl; with CosTime.TimeService.Skel; pragma Warnings (Off, CosTime.TimeService.Skel); package body CosTime.TimeService.Impl is use TimeBase; use Time_Utils; type UTO_Ptr is access UTO.Impl.Object; type TIO_Ptr is access TIO.Impl.Object; ------------------ -- new_interval -- ------------------ function new_interval (Self : access Object; lower : TimeBase.TimeT; upper : TimeBase.TimeT) return CosTime.TIO.Ref is pragma Unreferenced (Self); Result : constant TIO_Ptr := new TIO.Impl.Object; R : CosTime.TIO.Ref; begin Result.Interval := (lower_bound => lower, upper_bound => upper); PolyORB.CORBA_P.Server_Tools.Initiate_Servant (PortableServer.Servant (Result), R); return R; end new_interval; ------------------------ -- new_universal_time -- ------------------------ function new_universal_time (Self : access Object; time : TimeBase.TimeT; inaccuracy : TimeBase.InaccuracyT; tdf : TimeBase.TdfT) return CosTime.UTO.Ref is pragma Unreferenced (Self); Result : constant UTO_Ptr := new UTO.Impl.Object; R : CosTime.UTO.Ref; begin Result.Time := time; Result.Inaccuracy := inaccuracy; Result.Tdf := tdf; PolyORB.CORBA_P.Server_Tools.Initiate_Servant (PortableServer.Servant (Result), R); return R; end new_universal_time; --------------------------- -- secure_universal_time -- --------------------------- function secure_universal_time (Self : access Object) return CosTime.UTO.Ref is begin raise TimeUnavailable; return universal_time (Self); end secure_universal_time; -------------------- -- universal_time -- -------------------- function universal_time (Self : access Object) return CosTime.UTO.Ref is begin return new_universal_time (Self => Self, time => Current_Time, inaccuracy => Current_Inaccuracy, tdf => Current_Tdf); end universal_time; ------------------ -- uto_from_utc -- ------------------ function uto_from_utc (Self : access Object; utc : TimeBase.UtcT) return CosTime.UTO.Ref is use CORBA; begin return new_universal_time (Self => Self, time => utc.time, inaccuracy => InaccuracyT (utc.inacchi * 2 ** 32) + InaccuracyT (utc.inacclo), tdf => utc.tdf); end uto_from_utc; end CosTime.TimeService.Impl; polyorb-2.8~20110207.orig/cos/time/time_utils.ads0000644000175000017500000000530511750740337021004 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- T I M E _ U T I L S -- -- -- -- S p e c -- -- -- -- Copyright (C) 2001-2008, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with CosTime; with TimeBase; package Time_Utils is function "+" (A : TimeBase.TimeT; B : TimeBase.InaccuracyT) return TimeBase.TimeT; function "-" (A : TimeBase.TimeT; B : TimeBase.InaccuracyT) return TimeBase.TimeT; function "+" (A : TimeBase.TimeT; B : TimeBase.TdfT) return TimeBase.TimeT; function "-" (A : TimeBase.TimeT; B : TimeBase.TdfT) return TimeBase.TimeT; function Compare (A : TimeBase.TimeT; B : TimeBase.TimeT) return CosTime.TimeComparison; function Current_Time return TimeBase.TimeT; function Current_Inaccuracy return TimeBase.InaccuracyT; function Current_Tdf return TimeBase.TdfT; end Time_Utils; polyorb-2.8~20110207.orig/cos/time/costime-tio-impl.adb0000644000175000017500000001411511750740337021777 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- C O S T I M E . T I O . I M P L -- -- -- -- B o d y -- -- -- -- Copyright (C) 2001-2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with PolyORB.CORBA_P.Server_Tools; with Time_Utils; with CosTime.UTO.Impl; with CosTime.TIO.Skel; pragma Warnings (Off, CosTime.TIO.Skel); package body CosTime.TIO.Impl is use TimeBase; use Time_Utils; type TIO_Ptr is access Object; type UTO_Ptr is access UTO.Impl.Object; procedure Do_Overlap (A_Interval : IntervalT; B_Interval : IntervalT; Returns : out OverlapType; Overlaps : out IntervalT); ---------------- -- Do_Overlap -- ---------------- procedure Do_Overlap (A_Interval : IntervalT; B_Interval : IntervalT; Returns : out OverlapType; Overlaps : out IntervalT) is begin if A_Interval.upper_bound < B_Interval.lower_bound or else A_Interval.lower_bound > B_Interval.upper_bound then Returns := OTNoOverlap; Overlaps.lower_bound := TimeT'Min (A_Interval.upper_bound, B_Interval.upper_bound); Overlaps.upper_bound := TimeT'Max (A_Interval.lower_bound, B_Interval.lower_bound); elsif A_Interval.lower_bound <= B_Interval.lower_bound and then A_Interval.upper_bound >= B_Interval.upper_bound then Returns := OTContainer; Overlaps := B_Interval; elsif A_Interval.lower_bound >= B_Interval.lower_bound and then A_Interval.upper_bound <= B_Interval.upper_bound then Returns := OTContained; Overlaps := A_Interval; else Returns := OTOverlap; Overlaps.lower_bound := TimeT'Max (A_Interval.lower_bound, B_Interval.lower_bound); Overlaps.upper_bound := TimeT'Min (A_Interval.upper_bound, B_Interval.upper_bound); end if; end Do_Overlap; ----------------------- -- get_time_interval -- ----------------------- function get_time_interval (Self : access Object) return IntervalT is begin return Self.Interval; end get_time_interval; -------------- -- overlaps -- -------------- procedure overlaps (Self : access Object; interval : CosTime.TIO.Ref; overlap : out CosTime.TIO.Ref; Returns : out OverlapType) is pragma Warnings (Off); A_Interval : IntervalT renames Self.Interval; B_Interval : constant IntervalT := Get_time_interval (interval); -- XXX is it necessary ? pragma Warnings (On); Result : constant TIO_Ptr := new Object; begin Do_Overlap (A_Interval => Self.Interval, B_Interval => Get_time_interval (interval), Overlaps => Result.Interval, Returns => Returns); PolyORB.CORBA_P.Server_Tools.Initiate_Servant (PortableServer.Servant (Result), overlap); end overlaps; ----------- -- spans -- ----------- procedure spans (Self : access Object; time : CosTime.UTO.Ref; overlap : out CosTime.TIO.Ref; Returns : out OverlapType) is Tim : constant TimeT := UTO.Get_time (time); Ina : constant InaccuracyT := UTO.Get_inaccuracy (time); B_Interval : constant IntervalT := (lower_bound => Tim - Ina, upper_bound => Tim + Ina); Result : constant TIO_Ptr := new Object; begin Do_Overlap (A_Interval => Self.Interval, B_Interval => B_Interval, Overlaps => Result.Interval, Returns => Returns); PolyORB.CORBA_P.Server_Tools.Initiate_Servant (PortableServer.Servant (Result), overlap); end spans; ---------- -- time -- ---------- function time (Self : access Object) return UTO.Ref is Result : constant UTO_Ptr := new UTO.Impl.Object; R : UTO.Ref; begin Result.Time := (Self.Interval.upper_bound - Self.Interval.lower_bound) / 2; Result.Inaccuracy := InaccuracyT (Self.Interval.upper_bound - Self.Interval.lower_bound); PolyORB.CORBA_P.Server_Tools.Initiate_Servant (PortableServer.Servant (Result), R); return R; end time; end CosTime.TIO.Impl; polyorb-2.8~20110207.orig/cos/time/time_utils.adb0000644000175000017500000001003211750740337020754 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- T I M E _ U T I L S -- -- -- -- B o d y -- -- -- -- Copyright (C) 2001-2008, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with Interfaces.C; with System; package body Time_Utils is use TimeBase; Time_Offset : constant TimeT := 141_427 * 86_400 * 10_000_000; -- Time offset between 15 october 1582 and 1 january 1970. --------- -- "+" -- --------- function "+" (A : TimeBase.TimeT; B : TimeBase.InaccuracyT) return TimeBase.TimeT is begin return A + TimeBase.TimeT (B); end "+"; --------- -- "-" -- --------- function "-" (A : TimeBase.TimeT; B : TimeBase.InaccuracyT) return TimeBase.TimeT is begin return A - TimeBase.TimeT (B); end "-"; --------- -- "+" -- --------- function "+" (A : TimeBase.TimeT; B : TimeBase.TdfT) return TimeBase.TimeT is begin return A + TimeBase.TimeT (B) * 600_000_000; end "+"; --------- -- "-" -- --------- function "-" (A : TimeBase.TimeT; B : TimeBase.TdfT) return TimeBase.TimeT is begin return A + (-B); end "-"; ------------- -- Compare -- ------------- function Compare (A : TimeBase.TimeT; B : TimeBase.TimeT) return CosTime.TimeComparison is use CosTime; begin if A < B then return TCLessThan; elsif A = B then return TCEqualTo; else return TCGreaterThan; end if; end Compare; ------------------ -- Current_Time -- ------------------ function Current_Time return TimeBase.TimeT is function Unix_Time (TLOC : System.Address := System.Null_Address) return Interfaces.C.long; pragma Import (C, Unix_Time, "time"); begin return TimeBase.TimeT (Unix_Time) * 10_000_000 + Time_Offset; end Current_Time; function Current_Inaccuracy return TimeBase.InaccuracyT is begin -- Time on Unix has 1 second of precision return 10_000_000; end Current_Inaccuracy; ----------------- -- Current_Tdf -- ----------------- function Current_Tdf return TimeBase.TdfT is begin -- Return UTC return 0; end Current_Tdf; end Time_Utils; polyorb-2.8~20110207.orig/cos/time/costime-tio-impl.ads0000644000175000017500000000521111750740337022015 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- C O S T I M E . T I O . I M P L -- -- -- -- S p e c -- -- -- -- Copyright (C) 2001-2008, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with CosTime.UTO; with TimeBase; with PortableServer; package CosTime.TIO.Impl is type Object is new PortableServer.Servant_Base with record Interval : TimeBase.IntervalT; end record; function get_time_interval (Self : access Object) return TimeBase.IntervalT; procedure spans (Self : access Object; time : UTO.Ref; overlap : out Ref; Returns : out OverlapType); procedure overlaps (Self : access Object; interval : Ref; overlap : out Ref; Returns : out OverlapType); function time (Self : access Object) return UTO.Ref; end CosTime.TIO.Impl; polyorb-2.8~20110207.orig/cos/time/costime-uto-impl.adb0000644000175000017500000001401311750740337022010 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- C O S T I M E . U T O . I M P L -- -- -- -- B o d y -- -- -- -- Copyright (C) 2001-2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with Time_Utils; with PolyORB.CORBA_P.Server_Tools; with CosTime.TIO.Impl; with CosTime.UTO.Skel; pragma Warnings (Off, CosTime.UTO.Skel); package body CosTime.UTO.Impl is use TimeBase; use Time_Utils; type UTO_Ptr is access Object; type TIO_Ptr is access CosTime.TIO.Impl.Object; ------------------- -- absolute_time -- ------------------- function absolute_time (Self : access Object) return Ref'Class is Result : constant UTO_Ptr := new Object; R : Ref; begin Result.Time := Self.Time + Current_Time; Result.Inaccuracy := Self.Inaccuracy + Current_Inaccuracy; Result.Tdf := Self.Tdf + Current_Tdf; PolyORB.CORBA_P.Server_Tools.Initiate_Servant (PortableServer.Servant (Result), R); return R; end absolute_time; ------------------ -- compare_time -- ------------------ function compare_time (Self : access Object; comparison_type : ComparisonType; uto : Ref) return TimeComparison is Other_Time : constant TimeT := Get_time (uto); Other_Tdf : constant TdfT := Get_tdf (uto); begin if comparison_type = MidC then return Compare (Self.Time + Self.Tdf, Other_Time + Other_Tdf); else declare Other_Inaccuracy : constant InaccuracyT := Get_inaccuracy (uto); Comp_Low : constant TimeComparison := Compare (Self.Time - Self.Inaccuracy + Self.Tdf, Other_Time - Other_Inaccuracy + Other_Tdf); Comp_High : constant TimeComparison := Compare (Self.Time + Self.Inaccuracy + Self.Tdf, Other_Time + Other_Inaccuracy + Other_Tdf); begin if Comp_Low = Comp_High then return Comp_Low; else return TCIndeterminate; end if; end; end if; end compare_time; -------------------- -- get_inaccuracy -- -------------------- function get_inaccuracy (Self : access Object) return InaccuracyT is begin return Self.Inaccuracy; end get_inaccuracy; ------------- -- get_tdf -- ------------- function get_tdf (Self : access Object) return TdfT is begin return Self.Tdf; end get_tdf; -------------- -- get_time -- -------------- function get_time (Self : access Object) return TimeT is begin return Self.Time; end get_time; ------------------ -- get_utc_time -- ------------------ function get_utc_time (Self : access Object) return UtcT is begin return (time => Self.Time, inacclo => CORBA.Unsigned_Long (Self.Inaccuracy rem (2 ** 32)), inacchi => CORBA.Unsigned_Short (Self.Inaccuracy / (2 ** 32)), tdf => Self.Tdf); end get_utc_time; -------------- -- interval -- -------------- function interval (Self : access Object) return TIO_Forward.Ref is Result : constant TIO_Ptr := new CosTime.TIO.Impl.Object; R : TIO_Forward.Ref; begin Result.Interval.lower_bound := Self.Time - Self.Tdf; Result.Interval.upper_bound := Self.Time + Self.Tdf; PolyORB.CORBA_P.Server_Tools.Initiate_Servant (PortableServer.Servant (Result), R); return R; end interval; ---------------------- -- time_to_interval -- ---------------------- function time_to_interval (Self : access Object; uto : Ref) return TIO_Forward.Ref is Other_Time : constant TimeT := Get_time (uto); Result : constant TIO_Ptr := new CosTime.TIO.Impl.Object; R : TIO_Forward.Ref; begin Result.Interval.lower_bound := TimeT'Min (Self.Time, Other_Time); Result.Interval.upper_bound := TimeT'Max (Self.Time, Other_Time); PolyORB.CORBA_P.Server_Tools.Initiate_Servant (PortableServer.Servant (Result), R); return R; end time_to_interval; end CosTime.UTO.Impl; polyorb-2.8~20110207.orig/features-220000644000175000017500000000421511750740337016374 0ustar xavierxavier======================================================== PolyORB 2.2 NEW FEATURES LIST Current as of Jan 19, 2007 ======================================================== Copyright (c) 2007, AdaCore This file contains a complete list of new features in version 2.2 of PolyORB. See also file NEWS for various information about this release. An ISO date (YYYY-MM-DD) appears in parentheses after the description line. This date shows the implementation date of the feature. Any 2.2w wavefront subsequent to this date will contain the indicated feature, as will any subsequent releases. NF-22-FC18-024 Fixed name of PortableServer::POA reference type (2007-01-08) In the CORBA personality, the PortableServer.POAManager.Ref type has been renamed to PortableServer.POAManager.Local_Ref to be conformant with the IDL-to-Ada mapping. User code that references this type must be fixed accordingly. Accordingly, the conversion subprograms To_Ref and Unchecked_To_Ref have been accordingly renamed To_Local_Ref and Unchecked_To_Local_Ref. NF-22-FA17-009 Reduced code footprint of sequences (2006-11-28) The code footprint and compile time for instances of Sequences.Bounded and Sequences.Unbounded has been significantly thanks to a complete redesign that allowed significant code sharing across instances. Note that subprogram Element_Of has been removed. It was a non-standard renaming of the Get_Element function specified by the Ada language mapping. Get_Element should be used instead. NF-22-F804-015 New application personality: DSA (2006-08-09) A new application personality has been introduced allowing PolyORB to be used as a Partition Communication Subsystem for the Ada Distributed Systems Annex. NF-22-EB18-024 Run-time performance improvements for CORBA (2006-07-10) The neutral layer, CORBA applicative personality and IDL-to-Ada compiler have been reorganized to manage user data more efficiently, resulting in significant performance improvements for all CORBA applications. NF-22-EA31-003 Binding objects reuse (2006-05-31) Client binding objects are reused when possible, reducing the number of open channels between nodes. polyorb-2.8~20110207.orig/VERSION0000644000175000017500000000002211750740337015452 0ustar xavierxavier@polyorb_version@ polyorb-2.8~20110207.orig/Makefile.common.project.in0000644000175000017500000001315711750740337021420 0ustar xavierxavier# Common Makefile fragments for all PolyORB subsystems # $Id: Makefile.common.project.in 141119 2009-03-11 12:59:56Z hugues $ # # PolyORB's libraries # aws_lib=-I$(top_builddir)/src/aws/libpolyorb-aws.la corba_lib=$(top_builddir)/src/corba/libpolyorb-corba.la \ $(top_builddir)/src/corba/rtcorba/libpolyorb-corba-rtcorba.la moma_lib=$(top_builddir)/src/moma/libpolyorb-moma.la giop_lib=$(top_builddir)/src/giop/libpolyorb-giop.la \ $(top_builddir)/src/giop/diop/libpolyorb-giop-diop.la \ $(top_builddir)/src/giop/iiop/libpolyorb-giop-iiop.la \ $(top_builddir)/src/giop/miop/libpolyorb-giop-miop.la ifeq (${HAVE_SSL},yes) giop_lib += $(top_builddir)/src/giop/iiop/ssliop/libpolyorb-giop-iiop-ssliop.la endif soap_lib=$(top_builddir)/src/soap/libpolyorb-soap.la srp_lib=$(top_builddir)/src/srp/libpolyorb-srp.la web_common_lib=$(top_builddir)/src/web_common/libpolyorb-web_common.la # # PolyORB's libraries -- NEW (should replace above)??? # aws_lib=libpolyorb-aws.a corba_lib=libpolyorb-corba.a \ libpolyorb-corba-rtcorba.a moma_lib=libpolyorb-moma.a giop_lib=libpolyorb-giop.a \ libpolyorb-giop-diop.a \ libpolyorb-giop-iiop.a \ libpolyorb-giop-miop.a ifeq (${HAVE_SSL},yes) giop_lib += libpolyorb-giop-iiop-ssliop.a endif soap_lib=libpolyorb-soap.a srp_lib=libpolyorb-srp.a web_common_lib=libpolyorb-web_common.a # Build libpolyorb-setup last, since its project file has dependencies on # the various personality projects. POLYORB_LIBS= libpolyorb.a \ @PROTO_LIBS@ \ @APPLI_LIBS@ \ @LIBS_LIBS@ \ libpolyorb-setup.a ifeq (${HAVE_SSL},yes) POLYORB_LIBS += libpolyorb-ssl.a endif dsa_lib=libpolyorb-dsa.a event_lib=libpolyorb-corba-cos-event.a libpolyorb-corba-cos-event-impl.a notification_lib=libpolyorb-corba-cos-notification.a libpolyorb-corba-cos-notification-impl.a naming_lib=libpolyorb-corba-cos-naming.a libpolyorb-corba-cos-naming-impl.a ir_lib=libpolyorb-corba-cos-ir-impl.a time_lib=libpolyorb-corba-cos-time.a libpolyorb-corba-cos-time-impl.a SERVICE_LIBS=@SERVICE_LIBS@ APPLI_EXES=@APPLI_EXES@ SERVICE_EXES=@SERVICE_EXES@ # # PolyORB's include files # aws_inc=-I$(top_srcdir)/src/aws \ -I$(top_builddir)/src/aws \ -I$(top_srcdir)/src/aws_orig \ -I$(top_builddir)/src/aws_orig corba_inc=-I$(top_srcdir)/src/corba -I$(top_builddir)/src/corba \ -I$(top_srcdir)/src/corba/iop -I$(top_builddir)/src/corba/iop \ -I$(top_srcdir)/src/corba/messaging \ -I$(top_builddir)/src/corba/messaging \ -I$(top_srcdir)/src/corba/portableinterceptor \ -I$(top_builddir)/src/corba/portableinterceptor \ -I$(top_srcdir)/src/corba/rtcorba -I$(top_builddir)/src/corba/rtcorba moma_inc=-I$(top_srcdir)/src/moma -I$(top_builddir)/src/moma giop_inc=-I$(top_srcdir)/src/giop -I$(top_builddir)/src/giop \ -I$(top_srcdir)/src/giop/diop -I$(top_builddir)/src/giop/diop \ -I$(top_srcdir)/src/giop/iiop -I$(top_builddir)/src/giop/iiop \ -I$(top_srcdir)/src/giop/miop -I$(top_builddir)/src/giop/miop ifeq (${HAVE_SSL},yes) giop_inc+=-I$(top_srcdir)/src/giop/iiop/ssliop \ -I$(top_builddir)/src/giop/iiop/ssliop endif soap_inc=-I$(top_srcdir)/src/soap -I$(top_builddir)/src/soap srp_inc=-I$(top_srcdir)/src/srp -I$(top_builddir)/src/srp web_common_inc=-I$(top_srcdir)/src/web_common -I$(top_builddir)/src/web_common naming_inc=-I$(top_srcdir)/cos/naming -I$(top_builddir)/cos/naming \ -I$(top_builddir)/idls/cos/naming time_inc=-I$(top_srcdir)/cos/time -I$(top_builddir)/cos/time \ -I$(top_builddir)/idls/cos/time event_inc=-I$(top_srcdir)/cos/event -I$(top_builddir)/cos/event \ -I$(top_builddir)/idls/cos/event notification_inc=-I$(top_srcdir)/cos/notification \ -I$(top_builddir)/cos/notification \ -I$(top_builddir)/idls/cos/notification ir_inc=-I$(top_srcdir)/cos/ir -I$(top_builddir)/cos/ir POLYORB_INCS = \ -I$(top_srcdir)/src \ -I$(top_builddir)/src \ -I$(top_srcdir)/src/setup \ -I$(top_builddir)/src/setup \ @PROTO_INCS@ \ @APPLI_INCS@ \ @SERVICE_INCS@ \ @LIBS_INCS@ ifeq (${HAVE_SSL},yes) POLYORB_INCS+=-I$(top_srcdir)/src/ssl -I$(top_builddir)/src/ssl endif # # ALI files install # aliDATA_INSTALL = $(INSTALL) -m 444 # # Scripts and common build rules # SUFFIXES= .c .adb .ads .lo .ali .idl ADACOMPILER= $(top_builddir)/support/adacompiler LINKER= $(top_builddir)/support/linker NATIVE_LINKER= $(top_builddir)/support/native-linker MOVEIFCHANGE= $(top_builddir)/support/move-if-change IDLAC_dir= $(top_builddir)/compilers/$(IDLAC) IDLAC_bin= $(IDLAC_dir)/$(IDLAC) IDLAC_WRAPPER= $(top_builddir)/contrib/idlac_wrapper/idlac_wrapper GEN_CODESET_dir=$(top_builddir)/src/giop GEN_CODESET= $(GEN_CODESET_dir)/gen_codeset LINK= $(LINKER) -o $@ .c.lo: $(LTCOMPILE) -c $< .adb.lo: @chmod a+x $(ADACOMPILER) $(LIBTOOL) $(LIBTOOL_TAG) --mode=compile $(ADACOMPILER) -c $(ADAFLAGS) $< .ads.lo: @chmod a+x $(ADACOMPILER) $(LIBTOOL) $(LIBTOOL_TAG) --mode=compile $(ADACOMPILER) -c $(ADAFLAGS) $< .idl.ads: $(IDLAC_bin) -I$(srcdir) $(IDLAC_FLAGS) $< .idl.adb: $(IDLAC_bin) -I$(srcdir) $(IDLAC_FLAGS) $< .idl.idl-stamp: @chmod a+x $(IDLAC_WRAPPER) $(IDLAC_WRAPPER) --idlac=$(IDLAC_bin) -I$(srcdir) $(IDLAC_FLAGS) $< touch $@ ## Prevent make from building ALI files before building corresponding .o ## files in parallel build (the ALI file comes for free as a by-product ## of building the object). .o.ali: @true __default__:: all $(IDLAC): $(FORCE_IDLAC) cd $(IDLAC_dir) && $(MAKE) $(GEN_CODESET): $(FORCE_GEN_CODESET) cd $(GEN_CODESET_dir) && $(MAKE) all-gen_codeset polyorb-2.8~20110207.orig/MANIFEST0000644000175000017500000036523211750740337015554 0ustar xavierxavierCOPYING FEATURES INSTALL MANIFEST Makefile.common.project.in Makefile.in NEWS README README.DSA VERSION acinclude.m4 aclocal.m4 compilers/common_files/ChangeLog compilers/common_files/charset.adb compilers/common_files/charset.ads compilers/common_files/errors.adb compilers/common_files/errors.ads compilers/common_files/locations.adb compilers/common_files/locations.ads compilers/common_files/namet.adb compilers/common_files/namet.ads compilers/common_files/output.adb compilers/common_files/output.ads compilers/common_files/platform.ads.in compilers/common_files/types.adb compilers/common_files/types.ads compilers/common_files/utils.adb compilers/common_files/utils.ads compilers/config.adc.in compilers/gnatdist/po_gnatdist.adb compilers/gnatdist/xe.adb compilers/gnatdist/xe.ads compilers/gnatdist/xe_back-garlic.adb compilers/gnatdist/xe_back-garlic.ads compilers/gnatdist/xe_back-polyorb.adb compilers/gnatdist/xe_back-polyorb.ads compilers/gnatdist/xe_back.adb compilers/gnatdist/xe_back.ads compilers/gnatdist/xe_defs-defaults.ads.in compilers/gnatdist/xe_defs.adb compilers/gnatdist/xe_defs.ads compilers/gnatdist/xe_flags.ads compilers/gnatdist/xe_front.adb compilers/gnatdist/xe_front.ads compilers/gnatdist/xe_io.adb compilers/gnatdist/xe_io.ads compilers/gnatdist/xe_list.adb compilers/gnatdist/xe_list.ads compilers/gnatdist/xe_main.adb compilers/gnatdist/xe_main.ads compilers/gnatdist/xe_names.adb compilers/gnatdist/xe_names.ads compilers/gnatdist/xe_parse.adb compilers/gnatdist/xe_parse.ads compilers/gnatdist/xe_reg.adb compilers/gnatdist/xe_reg.ads compilers/gnatdist/xe_scan.adb compilers/gnatdist/xe_scan.ads compilers/gnatdist/xe_sem.adb compilers/gnatdist/xe_sem.ads compilers/gnatdist/xe_stdcnf.adb compilers/gnatdist/xe_stdcnf.ads compilers/gnatdist/xe_storages.adb compilers/gnatdist/xe_storages.ads compilers/gnatdist/xe_types.adb compilers/gnatdist/xe_types.ads compilers/gnatdist/xe_units.ads compilers/gnatdist/xe_usage.adb compilers/gnatdist/xe_usage.ads compilers/gnatdist/xe_utils.adb compilers/gnatdist/xe_utils.ads compilers/gnatprfh/gnatprfh.adb.in compilers/iac/ChangeLog compilers/iac/analyzer.adb compilers/iac/analyzer.ads compilers/iac/backend-be_corba_ada-aligned.adb compilers/iac/backend-be_corba_ada-aligned.ads compilers/iac/backend-be_corba_ada-buffers.adb compilers/iac/backend-be_corba_ada-buffers.ads compilers/iac/backend-be_corba_ada-cdrs.adb compilers/iac/backend-be_corba_ada-cdrs.ads compilers/iac/backend-be_corba_ada-common.adb compilers/iac/backend-be_corba_ada-common.ads compilers/iac/backend-be_corba_ada-debug.adb compilers/iac/backend-be_corba_ada-debug.ads compilers/iac/backend-be_corba_ada-expand.adb compilers/iac/backend-be_corba_ada-expand.ads compilers/iac/backend-be_corba_ada-generator.adb compilers/iac/backend-be_corba_ada-generator.ads compilers/iac/backend-be_corba_ada-helpers.adb compilers/iac/backend-be_corba_ada-helpers.ads compilers/iac/backend-be_corba_ada-helpers_internals.adb compilers/iac/backend-be_corba_ada-helpers_internals.ads compilers/iac/backend-be_corba_ada-idl_to_ada.adb compilers/iac/backend-be_corba_ada-idl_to_ada.ads compilers/iac/backend-be_corba_ada-impls.adb compilers/iac/backend-be_corba_ada-impls.ads compilers/iac/backend-be_corba_ada-ir_infos.adb compilers/iac/backend-be_corba_ada-ir_infos.ads compilers/iac/backend-be_corba_ada-nodes.idl compilers/iac/backend-be_corba_ada-nutils.adb compilers/iac/backend-be_corba_ada-nutils.ads compilers/iac/backend-be_corba_ada-runtime.adb compilers/iac/backend-be_corba_ada-runtime.ads compilers/iac/backend-be_corba_ada-skels.adb compilers/iac/backend-be_corba_ada-skels.ads compilers/iac/backend-be_corba_ada-stubs.adb compilers/iac/backend-be_corba_ada-stubs.ads compilers/iac/backend-be_corba_ada.adb compilers/iac/backend-be_corba_ada.ads compilers/iac/backend-be_idl.adb compilers/iac/backend-be_idl.ads compilers/iac/backend-be_types.adb compilers/iac/backend-be_types.ads compilers/iac/backend-config.adb compilers/iac/backend-config.ads compilers/iac/backend.adb compilers/iac/backend.ads compilers/iac/flags.ads compilers/iac/frontend-debug.adb compilers/iac/frontend-debug.ads compilers/iac/frontend-nodes.idl compilers/iac/frontend-nutils.adb compilers/iac/frontend-nutils.ads compilers/iac/frontend.ads compilers/iac/iac.adb compilers/iac/lexer.adb compilers/iac/lexer.ads compilers/iac/mknodes.adb compilers/iac/outfiles.adb compilers/iac/outfiles.ads compilers/iac/parser.adb compilers/iac/parser.ads compilers/iac/scopes.adb compilers/iac/scopes.ads compilers/iac/usage.adb compilers/iac/usage.ads compilers/iac/values.adb compilers/iac/values.ads compilers/idlac/README.Expansion compilers/idlac/TODO compilers/idlac/ada_be-debug.adb compilers/idlac/ada_be-debug.ads compilers/idlac/ada_be-expansion.adb compilers/idlac/ada_be-expansion.ads compilers/idlac/ada_be-identifiers.adb compilers/idlac/ada_be-identifiers.ads compilers/idlac/ada_be-idl2ada-helper.adb compilers/idlac/ada_be-idl2ada-helper.ads compilers/idlac/ada_be-idl2ada-impl.adb compilers/idlac/ada_be-idl2ada-impl.ads compilers/idlac/ada_be-idl2ada-ir_info.adb compilers/idlac/ada_be-idl2ada-ir_info.ads compilers/idlac/ada_be-idl2ada-skel.adb compilers/idlac/ada_be-idl2ada-skel.ads compilers/idlac/ada_be-idl2ada-value_impl.adb compilers/idlac/ada_be-idl2ada-value_impl.ads compilers/idlac/ada_be-idl2ada-value_skel.adb compilers/idlac/ada_be-idl2ada-value_skel.ads compilers/idlac/ada_be-idl2ada.adb compilers/idlac/ada_be-idl2ada.ads compilers/idlac/ada_be-mappings-corba-alm_1_2.adb compilers/idlac/ada_be-mappings-corba-alm_1_2.ads compilers/idlac/ada_be-mappings-corba.adb compilers/idlac/ada_be-mappings-corba.ads compilers/idlac/ada_be-mappings.ads compilers/idlac/ada_be-source_streams.adb compilers/idlac/ada_be-source_streams.ads compilers/idlac/ada_be-temporaries.adb compilers/idlac/ada_be-temporaries.ads compilers/idlac/ada_be.ads compilers/idlac/ada_be.opt compilers/idlac/idl_fe-debug.adb compilers/idlac/idl_fe-debug.ads compilers/idlac/idl_fe-display_tree.adb compilers/idlac/idl_fe-display_tree.ads compilers/idlac/idl_fe-files.adb compilers/idlac/idl_fe-files.ads compilers/idlac/idl_fe-lexer.adb compilers/idlac/idl_fe-lexer.ads compilers/idlac/idl_fe-parser.adb compilers/idlac/idl_fe-parser.ads compilers/idlac/idl_fe-tree-low_level.adb compilers/idlac/idl_fe-tree-low_level.ads compilers/idlac/idl_fe-tree-synthetic.adb compilers/idlac/idl_fe-tree-synthetic.ads compilers/idlac/idl_fe-tree.adb compilers/idlac/idl_fe-tree.ads compilers/idlac/idl_fe-types.adb compilers/idlac/idl_fe-types.ads compilers/idlac/idl_fe-utils.adb compilers/idlac/idl_fe-utils.ads compilers/idlac/idl_fe.ads compilers/idlac/idl_fe.opt compilers/idlac/idl_fe.types.1.ada compilers/idlac/idlac.adb compilers/idlac/idlac_errors.adb compilers/idlac/idlac_errors.ads compilers/idlac/idlac_flags.ads compilers/idlac/idlac_utils.adb compilers/idlac/idlac_utils.ads compilers/idlac/make_nodes.py compilers/idlac/nodes.txt compilers/idlac/string_sets.adb compilers/idlac/string_sets.ads compilers/idlac/testgen.adb compilers/idlac/testlexer.adb compilers/idlac/testparser.adb compilers/idlac/testsuite/adabroker.parser/testparser.exp compilers/idlac/testsuite/adabroker.parser/testparser.idl compilers/idlac/testsuite/adabroker.torture/torture.idl compilers/idlac/testsuite/lexer/testlexer.idl compilers/idlac/testsuite/lexer/testlexer_include.idl compilers/idlac/testsuite/mapping/arg.idl compilers/idlac/testsuite/mapping/union1.idl compilers/idlac/testsuite/mapping/union2.idl compilers/idlac/testsuite/omg/a01.idl compilers/idlac/testsuite/omg/a02.idl compilers/idlac/testsuite/omg/a03.idl compilers/idlac/testsuite/omg/a04.idl compilers/idlac/testsuite/omg/a05.idl compilers/idlac/testsuite/omg/a06.idl compilers/idlac/testsuite/omg/a07.idl compilers/idlac/testsuite/omg/a09.idl compilers/idlac/testsuite/omg/a10.idl compilers/idlac/testsuite/omg/a11.idl compilers/idlac/testsuite/omg/a12.idl compilers/idlac/testsuite/omg/barn.idl compilers/idlac/testsuite/omg/chicken.idl compilers/idlac/testsuite/omg/cultivation.idl compilers/idlac/testsuite/omg/drawing.idl compilers/idlac/testsuite/omg/egg.idl compilers/idlac/testsuite/parser/alldefinitions.idl compilers/idlac/testsuite/parser/allerrors.idl compilers/idlac/testsuite/parser/testparser.idl compilers/idlac/testsuite/parser/testparser_include.idl configure configure.ac contrib/README contrib/idlac_wrapper/README contrib/idlac_wrapper/idlac_wrapper.in cos/event/coseventchanneladmin-consumeradmin-impl.adb cos/event/coseventchanneladmin-consumeradmin-impl.ads cos/event/coseventchanneladmin-eventchannel-impl.adb cos/event/coseventchanneladmin-eventchannel-impl.ads cos/event/coseventchanneladmin-proxypullconsumer-impl.adb cos/event/coseventchanneladmin-proxypullconsumer-impl.ads cos/event/coseventchanneladmin-proxypullsupplier-impl.adb cos/event/coseventchanneladmin-proxypullsupplier-impl.ads cos/event/coseventchanneladmin-proxypushconsumer-impl.adb cos/event/coseventchanneladmin-proxypushconsumer-impl.ads cos/event/coseventchanneladmin-proxypushsupplier-impl.adb cos/event/coseventchanneladmin-proxypushsupplier-impl.ads cos/event/coseventchanneladmin-supplieradmin-impl.adb cos/event/coseventchanneladmin-supplieradmin-impl.ads cos/event/coseventcomm-pullconsumer-impl.adb cos/event/coseventcomm-pullconsumer-impl.ads cos/event/coseventcomm-pullsupplier-impl.adb cos/event/coseventcomm-pullsupplier-impl.ads cos/event/coseventcomm-pushconsumer-impl.adb cos/event/coseventcomm-pushconsumer-impl.ads cos/event/coseventcomm-pushsupplier-impl.adb cos/event/coseventcomm-pushsupplier-impl.ads cos/event/costypedeventchanneladmin-typedconsumeradmin-impl.adb cos/event/costypedeventchanneladmin-typedconsumeradmin-impl.ads cos/event/costypedeventchanneladmin-typedeventchannel-impl.adb cos/event/costypedeventchanneladmin-typedeventchannel-impl.ads cos/event/costypedeventchanneladmin-typedproxypullsupplier-impl.adb cos/event/costypedeventchanneladmin-typedproxypullsupplier-impl.ads cos/event/costypedeventchanneladmin-typedproxypushconsumer-impl.adb cos/event/costypedeventchanneladmin-typedproxypushconsumer-impl.ads cos/event/costypedeventchanneladmin-typedsupplieradmin-impl.adb cos/event/costypedeventchanneladmin-typedsupplieradmin-impl.ads cos/event/costypedeventcomm-typedpullsupplier-impl.adb cos/event/costypedeventcomm-typedpullsupplier-impl.ads cos/event/costypedeventcomm-typedpushconsumer-impl.adb cos/event/costypedeventcomm-typedpushconsumer-impl.ads cos/ir/corba-orb-typecode.adb cos/ir/corba-orb-typecode.ads cos/ir/corba-repository_root-abstractinterfacedef-impl.adb cos/ir/corba-repository_root-abstractinterfacedef-impl.ads cos/ir/corba-repository_root-aliasdef-impl.adb cos/ir/corba-repository_root-aliasdef-impl.ads cos/ir/corba-repository_root-arraydef-impl.adb cos/ir/corba-repository_root-arraydef-impl.ads cos/ir/corba-repository_root-attributedef-impl.adb cos/ir/corba-repository_root-attributedef-impl.ads cos/ir/corba-repository_root-constantdef-impl.adb cos/ir/corba-repository_root-constantdef-impl.ads cos/ir/corba-repository_root-contained-impl.adb cos/ir/corba-repository_root-contained-impl.ads cos/ir/corba-repository_root-container-impl.adb cos/ir/corba-repository_root-container-impl.ads cos/ir/corba-repository_root-enumdef-impl.adb cos/ir/corba-repository_root-enumdef-impl.ads cos/ir/corba-repository_root-exceptiondef-impl.adb cos/ir/corba-repository_root-exceptiondef-impl.ads cos/ir/corba-repository_root-extabstractinterfacedef-impl.adb cos/ir/corba-repository_root-extabstractinterfacedef-impl.ads cos/ir/corba-repository_root-extattributedef-impl.adb cos/ir/corba-repository_root-extattributedef-impl.ads cos/ir/corba-repository_root-extinterfacedef-impl.adb cos/ir/corba-repository_root-extinterfacedef-impl.ads cos/ir/corba-repository_root-extlocalinterfacedef-impl.adb cos/ir/corba-repository_root-extlocalinterfacedef-impl.ads cos/ir/corba-repository_root-fixeddef-impl.adb cos/ir/corba-repository_root-fixeddef-impl.ads cos/ir/corba-repository_root-idltype-impl.adb cos/ir/corba-repository_root-idltype-impl.ads cos/ir/corba-repository_root-interfaceattrextension-impl.adb cos/ir/corba-repository_root-interfaceattrextension-impl.ads cos/ir/corba-repository_root-interfacedef-impl.adb cos/ir/corba-repository_root-interfacedef-impl.ads cos/ir/corba-repository_root-irobject-impl.adb cos/ir/corba-repository_root-irobject-impl.ads cos/ir/corba-repository_root-localinterfacedef-impl.adb cos/ir/corba-repository_root-localinterfacedef-impl.ads cos/ir/corba-repository_root-moduledef-impl.adb cos/ir/corba-repository_root-moduledef-impl.ads cos/ir/corba-repository_root-nativedef-impl.adb cos/ir/corba-repository_root-nativedef-impl.ads cos/ir/corba-repository_root-operationdef-impl.adb cos/ir/corba-repository_root-operationdef-impl.ads cos/ir/corba-repository_root-primitivedef-impl.adb cos/ir/corba-repository_root-primitivedef-impl.ads cos/ir/corba-repository_root-repository-impl.adb cos/ir/corba-repository_root-repository-impl.ads cos/ir/corba-repository_root-sequencedef-impl.adb cos/ir/corba-repository_root-sequencedef-impl.ads cos/ir/corba-repository_root-stringdef-impl.adb cos/ir/corba-repository_root-stringdef-impl.ads cos/ir/corba-repository_root-structdef-impl.adb cos/ir/corba-repository_root-structdef-impl.ads cos/ir/corba-repository_root-typedefdef-impl.adb cos/ir/corba-repository_root-typedefdef-impl.ads cos/ir/corba-repository_root-uniondef-impl.adb cos/ir/corba-repository_root-uniondef-impl.ads cos/ir/corba-repository_root-valueboxdef-impl.adb cos/ir/corba-repository_root-valueboxdef-impl.ads cos/ir/corba-repository_root-valuedef-impl.adb cos/ir/corba-repository_root-valuedef-impl.ads cos/ir/corba-repository_root-valuememberdef-impl.adb cos/ir/corba-repository_root-valuememberdef-impl.ads cos/ir/corba-repository_root-wstringdef-impl.adb cos/ir/corba-repository_root-wstringdef-impl.ads cos/ir/polyorb-corba_p-ir_tools.adb cos/ir/polyorb-corba_p-ir_tools.ads cos/ir/polyorb-if_descriptors-corba_ir.adb cos/ir/polyorb-if_descriptors-corba_ir.ads cos/naming/File.idl cos/naming/cosnaming-bindingiterator-impl.adb cos/naming/cosnaming-bindingiterator-impl.ads cos/naming/cosnaming-namingcontext-impl.adb cos/naming/cosnaming-namingcontext-impl.ads cos/naming/cosnaming-namingcontextext-impl.adb cos/naming/cosnaming-namingcontextext-impl.ads cos/naming/file-impl.adb cos/naming/file-impl.ads cos/naming/menu.adb cos/naming/menu.ads cos/notification/cosnotification-adminpropertiesadmin-impl.adb cos/notification/cosnotification-adminpropertiesadmin-impl.ads cos/notification/cosnotification-qosadmin-impl.adb cos/notification/cosnotification-qosadmin-impl.ads cos/notification/cosnotifychanneladmin-consumeradmin-impl.adb cos/notification/cosnotifychanneladmin-consumeradmin-impl.ads cos/notification/cosnotifychanneladmin-eventchannel-impl.adb cos/notification/cosnotifychanneladmin-eventchannel-impl.ads cos/notification/cosnotifychanneladmin-eventchannelfactory-impl.adb cos/notification/cosnotifychanneladmin-eventchannelfactory-impl.ads cos/notification/cosnotifychanneladmin-proxyconsumer-impl.adb cos/notification/cosnotifychanneladmin-proxyconsumer-impl.ads cos/notification/cosnotifychanneladmin-proxypullconsumer-impl.adb cos/notification/cosnotifychanneladmin-proxypullconsumer-impl.ads cos/notification/cosnotifychanneladmin-proxypullsupplier-impl.adb cos/notification/cosnotifychanneladmin-proxypullsupplier-impl.ads cos/notification/cosnotifychanneladmin-proxypushconsumer-impl.adb cos/notification/cosnotifychanneladmin-proxypushconsumer-impl.ads cos/notification/cosnotifychanneladmin-proxypushsupplier-impl.adb cos/notification/cosnotifychanneladmin-proxypushsupplier-impl.ads cos/notification/cosnotifychanneladmin-proxysupplier-impl.adb cos/notification/cosnotifychanneladmin-proxysupplier-impl.ads cos/notification/cosnotifychanneladmin-sequenceproxypullconsumer-impl.adb cos/notification/cosnotifychanneladmin-sequenceproxypullconsumer-impl.ads cos/notification/cosnotifychanneladmin-sequenceproxypullsupplier-impl.adb cos/notification/cosnotifychanneladmin-sequenceproxypullsupplier-impl.ads cos/notification/cosnotifychanneladmin-sequenceproxypushconsumer-impl.adb cos/notification/cosnotifychanneladmin-sequenceproxypushconsumer-impl.ads cos/notification/cosnotifychanneladmin-sequenceproxypushsupplier-impl.adb cos/notification/cosnotifychanneladmin-sequenceproxypushsupplier-impl.ads cos/notification/cosnotifychanneladmin-structuredproxypullconsumer-impl.adb cos/notification/cosnotifychanneladmin-structuredproxypullconsumer-impl.ads cos/notification/cosnotifychanneladmin-structuredproxypullsupplier-impl.adb cos/notification/cosnotifychanneladmin-structuredproxypullsupplier-impl.ads cos/notification/cosnotifychanneladmin-structuredproxypushconsumer-impl.adb cos/notification/cosnotifychanneladmin-structuredproxypushconsumer-impl.ads cos/notification/cosnotifychanneladmin-structuredproxypushsupplier-impl.adb cos/notification/cosnotifychanneladmin-structuredproxypushsupplier-impl.ads cos/notification/cosnotifychanneladmin-supplieradmin-impl.adb cos/notification/cosnotifychanneladmin-supplieradmin-impl.ads cos/notification/cosnotifycomm-notifypublish-impl.adb cos/notification/cosnotifycomm-notifypublish-impl.ads cos/notification/cosnotifycomm-notifysubscribe-impl.adb cos/notification/cosnotifycomm-notifysubscribe-impl.ads cos/notification/cosnotifycomm-pullconsumer-impl.adb cos/notification/cosnotifycomm-pullconsumer-impl.ads cos/notification/cosnotifycomm-pullsupplier-impl.adb cos/notification/cosnotifycomm-pullsupplier-impl.ads cos/notification/cosnotifycomm-pushconsumer-impl.adb cos/notification/cosnotifycomm-pushconsumer-impl.ads cos/notification/cosnotifycomm-pushsupplier-impl.adb cos/notification/cosnotifycomm-pushsupplier-impl.ads cos/notification/cosnotifycomm-sequencepullconsumer-impl.adb cos/notification/cosnotifycomm-sequencepullconsumer-impl.ads cos/notification/cosnotifycomm-sequencepullsupplier-impl.adb cos/notification/cosnotifycomm-sequencepullsupplier-impl.ads cos/notification/cosnotifycomm-sequencepushconsumer-impl.adb cos/notification/cosnotifycomm-sequencepushconsumer-impl.ads cos/notification/cosnotifycomm-sequencepushsupplier-impl.adb cos/notification/cosnotifycomm-sequencepushsupplier-impl.ads cos/notification/cosnotifycomm-structuredpullconsumer-impl.adb cos/notification/cosnotifycomm-structuredpullconsumer-impl.ads cos/notification/cosnotifycomm-structuredpullsupplier-impl.adb cos/notification/cosnotifycomm-structuredpullsupplier-impl.ads cos/notification/cosnotifycomm-structuredpushconsumer-impl.adb cos/notification/cosnotifycomm-structuredpushconsumer-impl.ads cos/notification/cosnotifycomm-structuredpushsupplier-impl.adb cos/notification/cosnotifycomm-structuredpushsupplier-impl.ads cos/notification/cosnotifyfilter-filter-impl.adb cos/notification/cosnotifyfilter-filter-impl.ads cos/notification/cosnotifyfilter-filteradmin-impl.adb cos/notification/cosnotifyfilter-filteradmin-impl.ads cos/notification/cosnotifyfilter-filterfactory-impl.adb cos/notification/cosnotifyfilter-filterfactory-impl.ads cos/notification/cosnotifyfilter-mappingfilter-impl.adb cos/notification/cosnotifyfilter-mappingfilter-impl.ads cos/time/costime-timeservice-impl.adb cos/time/costime-timeservice-impl.ads cos/time/costime-tio-impl.adb cos/time/costime-tio-impl.ads cos/time/costime-uto-impl.adb cos/time/costime-uto-impl.ads cos/time/time_utils.adb cos/time/time_utils.ads docs/CODING_GUIDELINES docs/CONTRIBUTING docs/Makefile.am docs/Makefile.in docs/OMG_TAGS docs/PROBLEM-REPORT-FORM docs/ada.kw docs/cfg.kw docs/gfdl.texi docs/iac.1 docs/idl.kw docs/idlac.1 docs/myconfig.cfg docs/po_names.1 docs/polyorb-config.1 docs/polyorb.7 docs/polyorb_dg.texi docs/polyorb_gps.xml docs/polyorb_ug.bib docs/polyorb_ug.texi docs/polyorb_ug_ref.tex docs/polyorb_version.texi.in docs/svn.texi examples/README examples/aws/Makefile.local examples/aws/local.gpr examples/corba/README examples/corba/all_functions/Makefile.local examples/corba/all_functions/README examples/corba/all_functions/all_functions-impl.adb examples/corba/all_functions/all_functions-impl.ads examples/corba/all_functions/all_functions.idl examples/corba/all_functions/client.adb examples/corba/all_functions/dynclient.adb examples/corba/all_functions/local.gpr examples/corba/all_functions/run_tests.adb examples/corba/all_functions/server.adb examples/corba/all_types/Makefile.local examples/corba/all_types/README examples/corba/all_types/all_types-impl.adb examples/corba/all_types/all_types-impl.ads examples/corba/all_types/all_types.idl examples/corba/all_types/client.adb examples/corba/all_types/client_moma.adb examples/corba/all_types/dynclient.adb examples/corba/all_types/ir_server.adb examples/corba/all_types/local.gpr examples/corba/all_types/server.adb examples/corba/echo/Makefile.local examples/corba/echo/client.adb examples/corba/echo/delegated_server.adb examples/corba/echo/delegated_server.ads examples/corba/echo/dynclient.adb examples/corba/echo/dynserver.adb examples/corba/echo/echo-impl.adb examples/corba/echo/echo-impl.ads examples/corba/echo/echo.idl examples/corba/echo/echo_dynimpl.adb examples/corba/echo/echo_dynimpl.ads examples/corba/echo/local.gpr examples/corba/echo/server.adb examples/corba/random/Makefile.local examples/corba/random/client.adb examples/corba/random/local.gpr examples/corba/random/random-impl.adb examples/corba/random/random-impl.ads examples/corba/random/random.idl examples/corba/random/server.adb examples/corba/rtcorba/client_propagated/Makefile.local examples/corba/rtcorba/client_propagated/client.adb examples/corba/rtcorba/client_propagated/echo-impl.adb examples/corba/rtcorba/client_propagated/echo-impl.ads examples/corba/rtcorba/client_propagated/echo.idl examples/corba/rtcorba/client_propagated/local.gpr examples/corba/rtcorba/client_propagated/server.adb examples/corba/rtcorba/dhb/Makefile.local examples/corba/rtcorba/dhb/client_common.adb examples/corba/rtcorba/dhb/client_common.ads examples/corba/rtcorba/dhb/constants.ads examples/corba/rtcorba/dhb/dhb-background_worker-impl.adb examples/corba/rtcorba/dhb/dhb-background_worker-impl.ads examples/corba/rtcorba/dhb/dhb-background_worker_factory-impl.adb examples/corba/rtcorba/dhb/dhb-background_worker_factory-impl.ads examples/corba/rtcorba/dhb/dhb-worker-impl.adb examples/corba/rtcorba/dhb/dhb-worker-impl.ads examples/corba/rtcorba/dhb/dhb-worker_factory-impl.adb examples/corba/rtcorba/dhb/dhb-worker_factory-impl.ads examples/corba/rtcorba/dhb/dhb.idl examples/corba/rtcorba/dhb/dyn_dict.adb examples/corba/rtcorba/dhb/dyn_dict.ads examples/corba/rtcorba/dhb/local.gpr examples/corba/rtcorba/dhb/periodic_clients.adb examples/corba/rtcorba/dhb/periodic_clients.ads examples/corba/rtcorba/dhb/polyorb-setup-rtcorba.adb examples/corba/rtcorba/dhb/polyorb-setup-rtcorba.ads examples/corba/rtcorba/dhb/rtcorba_iiop_client.adb examples/corba/rtcorba/dhb/rtcorba_iiop_server.adb examples/corba/rtcorba/dhb/server_common.adb examples/corba/rtcorba/dhb/server_common.ads examples/corba/rtcorba/dhb/sporadic_clients.adb examples/corba/rtcorba/dhb/sporadic_clients.ads examples/corba/rtcorba/dhb/utils.adb examples/corba/rtcorba/dhb/utils.ads examples/corba/rtcorba/dhb/whetstone.adb examples/corba/rtcorba/dhb/whetstone.ads examples/corba/rtcorba/rtcosscheduling/Makefile.local examples/corba/rtcorba/rtcosscheduling/client.adb examples/corba/rtcorba/rtcosscheduling/client_scheduling.conf examples/corba/rtcorba/rtcosscheduling/echo-impl.adb examples/corba/rtcorba/rtcosscheduling/echo-impl.ads examples/corba/rtcorba/rtcosscheduling/echo.idl examples/corba/rtcorba/rtcosscheduling/local.gpr examples/corba/rtcorba/rtcosscheduling/server.adb examples/corba/rtcorba/rtcosscheduling/server_scheduling.conf examples/corba/rtcorba/server_declared/Makefile.local examples/corba/rtcorba/server_declared/client.adb examples/corba/rtcorba/server_declared/echo-impl.adb examples/corba/rtcorba/server_declared/echo-impl.ads examples/corba/rtcorba/server_declared/echo.idl examples/corba/rtcorba/server_declared/local.gpr examples/corba/rtcorba/server_declared/server.adb examples/corba/secure_echo/Makefile.local examples/corba/secure_echo/ca_openssl.conf examples/corba/secure_echo/client.adb examples/corba/secure_echo/client.ads examples/corba/secure_echo/echo-impl.adb examples/corba/secure_echo/echo-impl.ads examples/corba/secure_echo/echo.idl examples/corba/secure_echo/gssup.conf.in examples/corba/secure_echo/gssup_example.in examples/corba/secure_echo/local.gpr examples/corba/secure_echo/passwd.pwd examples/corba/secure_echo/polyorb_openssl.conf examples/corba/secure_echo/server.adb examples/corba/secure_echo/server.ads examples/corba/secure_echo/tls.conf.in examples/corba/secure_echo/tls_example.in examples/corba/secure_echo/tls_gssup.conf.in examples/corba/secure_echo/tls_gssup_example.in examples/corba/send/Makefile.local examples/corba/send/listener.adb examples/corba/send/local.gpr examples/corba/send/polyorb.conf examples/corba/send/print.idl examples/corba/send/send.adb examples/corba/send/test-controller-impl.adb examples/corba/send/test-controller-impl.ads examples/corba/send/test-printer-impl.adb examples/corba/send/test-printer-impl.ads examples/dsa/README examples/dsa/bank/README examples/dsa/bank/alarm.ads examples/dsa/bank/bank.adb examples/dsa/bank/bank.ads examples/dsa/bank/client.adb examples/dsa/bank/example examples/dsa/bank/manager.adb examples/dsa/bank/message.adb examples/dsa/bank/message.ads examples/dsa/bank/notify.ads examples/dsa/bank/server.adb examples/dsa/bank/server.ads examples/dsa/bank/simcity.cfg examples/dsa/bank/terminal.ads examples/dsa/bank/types.ads examples/dsa/connections/client.adb examples/dsa/connections/connect.cfg examples/dsa/connections/connections.ads examples/dsa/connections/hub.adb examples/dsa/connections/hub.ads examples/dsa/connections/hub_main.adb examples/dsa/connections/listeners.adb examples/dsa/connections/listeners.ads examples/dsa/connections/server.adb examples/dsa/demo/client_main.adb examples/dsa/demo/matrices.adb examples/dsa/demo/matrices.ads examples/dsa/demo/noproc.adb examples/dsa/demo/rci.adb examples/dsa/demo/rci.ads examples/dsa/demo/rt.ads examples/dsa/demo/sp.ads examples/dsa/demo/testbed.cfg examples/dsa/echo/client.adb examples/dsa/echo/echo.cfg examples/dsa/echo/server.adb examples/dsa/echo/server.ads examples/dsa/mailboxes/client.adb examples/dsa/mailboxes/hub.adb examples/dsa/mailboxes/hub.ads examples/dsa/mailboxes/hub_main.adb examples/dsa/mailboxes/mail.cfg examples/dsa/mailboxes/mailboxes-active.adb examples/dsa/mailboxes/mailboxes-active.ads examples/dsa/mailboxes/mailboxes.ads examples/dsa/mailboxes/server.adb examples/moma/Makefile.local examples/moma/README examples/moma/client.adb examples/moma/client_call_back.adb examples/moma/client_call_back_procedures.adb examples/moma/client_call_back_procedures.ads examples/moma/local.gpr examples/moma/router.adb examples/moma/server.adb examples/polyorb/Makefile.local examples/polyorb/README examples/polyorb/local.gpr examples/polyorb/polyorb-setup-test.ads examples/polyorb/polyorb-setup-test_poa.adb examples/polyorb/polyorb-setup-test_poa.ads examples/polyorb/polyorb-setup-test_soa.adb examples/polyorb/polyorb-setup-test_soa.ads examples/polyorb/polyorb-test-no_tasking.adb examples/polyorb/polyorb-test-no_tasking_poa.adb examples/polyorb/polyorb-test-thread_pool.adb examples/polyorb/polyorb-test-thread_pool_poa.adb examples/polyorb/polyorb-test.ads examples/polyorb/polyorb-test_object_poa.adb examples/polyorb/polyorb-test_object_poa.ads examples/polyorb/polyorb-test_object_soa.adb examples/polyorb/polyorb-test_object_soa.ads features-22 features-23 features-24 features-25 features-26 features-27 features-28 idls/CORBA_IDL/CORBA_Current.idl idls/CORBA_IDL/CORBA_CustomMarshal.idl idls/CORBA_IDL/CORBA_DomainManager.idl idls/CORBA_IDL/CORBA_InterfaceRepository.idl idls/CORBA_IDL/CORBA_Policy.idl idls/CORBA_IDL/CORBA_Pollable.idl idls/CORBA_IDL/CORBA_StandardExceptions.idl idls/CORBA_IDL/CORBA_Stream.idl idls/CORBA_IDL/CORBA_TypeCode.idl idls/CORBA_IDL/orb.idl idls/CORBA_PIDL/CORBA_Context.idl idls/CORBA_PIDL/CORBA_NVList.idl idls/CORBA_PIDL/CORBA_ORB.idl idls/CORBA_PIDL/CORBA_ORB_init.idl idls/CORBA_PIDL/CORBA_Object.idl idls/CORBA_PIDL/CORBA_Request.idl idls/CORBA_PIDL/CORBA_ServerRequest.idl idls/CORBA_PIDL/CORBA_ValueBase.idl idls/CORBA_PIDL/pseudo_orb.idl idls/Interop/BiDirPolicy.idl idls/Interop/CONV_FRAME.idl idls/Interop/CSI.idl idls/Interop/CSIIOP.idl idls/Interop/GIOP.idl idls/Interop/GSSUP.idl idls/Interop/IIOP.idl idls/Interop/IOP.idl idls/Interop/IOP_DCE.idl idls/Interop/SendingContext.idl idls/Misc/Dynamic.idl idls/Misc/DynamicAny.idl idls/Misc/FT.idl idls/Misc/MGM.idl idls/Misc/MIOP.idl idls/Misc/MessageRouting.idl idls/Misc/Messaging.idl idls/Misc/PortableGroup.idl idls/Misc/PortableInterceptor.idl idls/Misc/PortableServer.idl idls/RTCORBA/RTCORBA.idl idls/RTCORBA/RTCosScheduling.idl idls/RTCORBA/RTPortableServer.idl idls/cos/collection/CosCollection.idl idls/cos/concurrency/CosConcurrencyControl.idl idls/cos/event/CosEventChannelAdmin.idl idls/cos/event/CosEventComm.idl idls/cos/event/CosTypedEventChannelAdmin.idl idls/cos/event/CosTypedEventComm.idl idls/cos/externalization/CosExternalization.idl idls/cos/externalization/CosExternalizationContainment.idl idls/cos/externalization/CosExternalizationReference.idl idls/cos/externalization/CosStream.idl idls/cos/licensing/CosLicensingManager.idl idls/cos/lifecycle/CosCompoundLifeCycle.idl idls/cos/lifecycle/CosLifeCycle.idl idls/cos/lifecycle/CosLifeCycleContainment.idl idls/cos/lifecycle/CosLifeCycleReference.idl idls/cos/lifecycle/LifeCycleService.idl idls/cos/naming/CosNaming.idl idls/cos/naming/Lname-library.idl idls/cos/naming/polyorb-corba_p-naming_tools.adb idls/cos/naming/polyorb-corba_p-naming_tools.ads idls/cos/notification/CosNotification.idl idls/cos/notification/CosNotifyChannelAdmin.idl idls/cos/notification/CosNotifyComm.idl idls/cos/notification/CosNotifyFilter.idl idls/cos/notification/CosTypedNotifyChannelAdmin.idl idls/cos/notification/CosTypedNotifyComm.idl idls/cos/persistent/cospersistenceddo.idl idls/cos/persistent/cospersistenceds_cli.idl idls/cos/persistent/cospersistencepds.idl idls/cos/persistent/cospersistencepds_da.idl idls/cos/persistent/cospersistencepid.idl idls/cos/persistent/cospersistencepo.idl idls/cos/persistent/cospersistencepom.idl idls/cos/property/CosPropertyService.idl idls/cos/query/CosQuery.idl idls/cos/query/CosQueryCollection.idl idls/cos/relationship/CosContainment.idl idls/cos/relationship/CosGraphs.idl idls/cos/relationship/CosObjectIdentity.idl idls/cos/relationship/CosReference.idl idls/cos/relationship/CosRelationships.idl idls/cos/security/DCE_CIOPSecurity.idl idls/cos/security/NRService.idl idls/cos/security/SECIOP.idl idls/cos/security/SSLIOP.idl idls/cos/security/Security.idl idls/cos/security/SecurityAdmin.idl idls/cos/security/SecurityLevel1.idl idls/cos/security/SecurityLevel2.idl idls/cos/security/SecurityReplaceable.idl idls/cos/time/CosTime.idl idls/cos/time/CosTimerEvent.idl idls/cos/time/TimeBase.idl idls/cos/trader/CosTrading.idl idls/cos/trader/CosTradingDynamic.idl idls/cos/trader/CosTradingRepos.idl idls/cos/transaction/CosTSInteroperation.idl idls/cos/transaction/CosTSPortability.idl idls/cos/transaction/CosTransactions.idl polyorb-config.in projects-distrib/README projects-distrib/polyorb.gpr.in projects-distrib/polyorb/polyorb_common.gpr projects-distrib/polyorb/polyorb_cos_event.gpr projects-distrib/polyorb/polyorb_cos_ir.gpr projects-distrib/polyorb/polyorb_cos_naming.gpr projects-distrib/polyorb/polyorb_cos_notification.gpr projects-distrib/polyorb/polyorb_cos_time.gpr projects-distrib/polyorb/polyorb_idls_cos_event.gpr projects-distrib/polyorb/polyorb_idls_cos_naming.gpr projects-distrib/polyorb/polyorb_idls_cos_notification.gpr projects-distrib/polyorb/polyorb_idls_cos_time.gpr projects-distrib/polyorb/polyorb_src.gpr projects-distrib/polyorb/polyorb_src_corba.gpr projects-distrib/polyorb/polyorb_src_corba_dynamicany.gpr projects-distrib/polyorb/polyorb_src_corba_iop.gpr projects-distrib/polyorb/polyorb_src_corba_messaging.gpr projects-distrib/polyorb/polyorb_src_corba_portableinterceptor.gpr projects-distrib/polyorb/polyorb_src_corba_rtcorba.gpr projects-distrib/polyorb/polyorb_src_corba_security.gpr projects-distrib/polyorb/polyorb_src_corba_security_gssup.gpr projects-distrib/polyorb/polyorb_src_dsa.gpr projects-distrib/polyorb/polyorb_src_giop.gpr projects-distrib/polyorb/polyorb_src_giop_diop.gpr projects-distrib/polyorb/polyorb_src_giop_iiop.gpr projects-distrib/polyorb/polyorb_src_giop_iiop_security.gpr projects-distrib/polyorb/polyorb_src_giop_iiop_security_tls.gpr projects-distrib/polyorb/polyorb_src_giop_iiop_ssliop.gpr projects-distrib/polyorb/polyorb_src_giop_miop.gpr projects-distrib/polyorb/polyorb_src_moma.gpr projects-distrib/polyorb/polyorb_src_security.gpr projects-distrib/polyorb/polyorb_src_security_gssup.gpr projects-distrib/polyorb/polyorb_src_security_tls.gpr projects-distrib/polyorb/polyorb_src_security_x509.gpr projects-distrib/polyorb/polyorb_src_setup.gpr.in projects-distrib/polyorb/polyorb_src_setup_security.gpr projects-distrib/polyorb/polyorb_src_soap.gpr projects-distrib/polyorb/polyorb_src_srp.gpr projects-distrib/polyorb/polyorb_src_ssl.gpr projects-distrib/polyorb/polyorb_src_web_common.gpr projects/README projects/polyorb.gpr.in projects/polyorb_build_all.gpr projects/polyorb_common.gpr projects/polyorb_config.gpr.in projects/polyorb_cos_event.gpr projects/polyorb_cos_ir.gpr projects/polyorb_cos_naming.gpr projects/polyorb_cos_notification.gpr projects/polyorb_cos_time.gpr projects/polyorb_idls_cos_event.gpr projects/polyorb_idls_cos_naming.gpr projects/polyorb_idls_cos_notification.gpr projects/polyorb_idls_cos_time.gpr projects/polyorb_src.gpr projects/polyorb_src_corba.gpr projects/polyorb_src_corba_dynamicany.gpr projects/polyorb_src_corba_iop.gpr projects/polyorb_src_corba_messaging.gpr projects/polyorb_src_corba_portableinterceptor.gpr projects/polyorb_src_corba_rtcorba.gpr projects/polyorb_src_corba_security.gpr projects/polyorb_src_corba_security_gssup.gpr projects/polyorb_src_dsa.gpr projects/polyorb_src_giop.gpr projects/polyorb_src_giop_diop.gpr projects/polyorb_src_giop_iiop.gpr projects/polyorb_src_giop_iiop_security.gpr projects/polyorb_src_giop_iiop_security_tls.gpr projects/polyorb_src_giop_iiop_ssliop.gpr projects/polyorb_src_giop_miop.gpr projects/polyorb_src_moma.gpr projects/polyorb_src_security.gpr projects/polyorb_src_security_gssup.gpr projects/polyorb_src_security_tls.gpr projects/polyorb_src_security_x509.gpr projects/polyorb_src_setup.gpr.in projects/polyorb_src_setup_security.gpr projects/polyorb_src_soap.gpr projects/polyorb_src_srp.gpr projects/polyorb_src_ssl.gpr projects/polyorb_src_web_common.gpr projects/polyorb_test_common.gpr projects/polyorb_tools_po_catref.gpr projects/polyorb_tools_po_cos_naming.gpr projects/polyorb_tools_po_createref.gpr projects/polyorb_tools_po_dumpir.gpr projects/polyorb_tools_po_ir.gpr projects/polyorb_tools_po_names.gpr src/ROADMAP src/TODO src/config.adc.in src/config.h.in src/corba/corba-abstractbase.adb src/corba/corba-abstractbase.ads src/corba/corba-bounded_strings.adb src/corba/corba-bounded_strings.ads src/corba/corba-bounded_wide_strings.adb src/corba/corba-bounded_wide_strings.ads src/corba/corba-context.adb src/corba/corba-context.ads src/corba/corba-contextlist.adb src/corba/corba-contextlist.ads src/corba/corba-current-impl.ads src/corba/corba-current.ads src/corba/corba-domainmanager-helper.adb src/corba/corba-domainmanager-helper.ads src/corba/corba-domainmanager.adb src/corba/corba-domainmanager.ads src/corba/corba-exceptionlist.adb src/corba/corba-exceptionlist.ads src/corba/corba-fixed_point.adb src/corba/corba-fixed_point.ads src/corba/corba-forward.adb src/corba/corba-forward.ads src/corba/corba-helper.adb src/corba/corba-helper.ads src/corba/corba-idl_sequences-helper.adb src/corba/corba-idl_sequences-helper.ads src/corba/corba-idl_sequences.ads src/corba/corba-impl.adb src/corba/corba-impl.ads src/corba/corba-local.ads src/corba/corba-nvlist.adb src/corba/corba-nvlist.ads src/corba/corba-object-helper.adb src/corba/corba-object-helper.ads src/corba/corba-object-policies.adb src/corba/corba-object-policies.ads src/corba/corba-object.adb src/corba/corba-object.ads src/corba/corba-orb.adb src/corba/corba-orb.ads src/corba/corba-policy-helper.adb src/corba/corba-policy-helper.ads src/corba/corba-policy.adb src/corba/corba-policy.ads src/corba/corba-policycurrent.adb src/corba/corba-policycurrent.ads src/corba/corba-policymanager.adb src/corba/corba-policymanager.ads src/corba/corba-repository_root.ads src/corba/corba-request.adb src/corba/corba-request.ads src/corba/corba-sequences-bounded.ads src/corba/corba-sequences-unbounded.ads src/corba/corba-sequences.ads src/corba/corba-serverrequest.adb src/corba/corba-serverrequest.ads src/corba/corba.adb src/corba/corba.ads src/corba/dynamicany/dynamicany-dynany-impl.adb src/corba/dynamicany/dynamicany-dynany-impl.ads src/corba/dynamicany/dynamicany-dynanyfactory-impl.adb src/corba/dynamicany/dynamicany-dynanyfactory-impl.ads src/corba/dynamicany/dynamicany-dynarray-impl.adb src/corba/dynamicany/dynamicany-dynarray-impl.ads src/corba/dynamicany/dynamicany-dynenum-impl.adb src/corba/dynamicany/dynamicany-dynenum-impl.ads src/corba/dynamicany/dynamicany-dynfixed-impl.adb src/corba/dynamicany/dynamicany-dynfixed-impl.ads src/corba/dynamicany/dynamicany-dynsequence-impl.adb src/corba/dynamicany/dynamicany-dynsequence-impl.ads src/corba/dynamicany/dynamicany-dynstruct-impl.adb src/corba/dynamicany/dynamicany-dynstruct-impl.ads src/corba/dynamicany/dynamicany-dynunion-impl.adb src/corba/dynamicany/dynamicany-dynunion-impl.ads src/corba/dynamicany/dynamicany-dynvalue-impl.adb src/corba/dynamicany/dynamicany-dynvalue-impl.ads src/corba/dynamicany/dynamicany-dynvaluebox-impl.adb src/corba/dynamicany/dynamicany-dynvaluebox-impl.ads src/corba/dynamicany/dynamicany-dynvaluecommon-impl.adb src/corba/dynamicany/dynamicany-dynvaluecommon-impl.ads src/corba/dynamicany/polyorb-corba_p-dynamic_any.adb src/corba/dynamicany/polyorb-corba_p-dynamic_any.ads src/corba/iop/iop-codec-impl.adb src/corba/iop/iop-codec-impl.ads src/corba/iop/iop-codecfactory-impl.adb src/corba/iop/iop-codecfactory-impl.ads src/corba/iop/polyorb-corba_p-codec_utils.adb src/corba/iop/polyorb-corba_p-codec_utils.ads src/corba/polyorb-corba_p-adapteractivator.adb src/corba/polyorb-corba_p-adapteractivator.ads src/corba/polyorb-corba_p-corbaloc.adb src/corba/polyorb-corba_p-corbaloc.ads src/corba/polyorb-corba_p-domain_management.adb src/corba/polyorb-corba_p-domain_management.ads src/corba/polyorb-corba_p-exceptions.adb src/corba/polyorb-corba_p-exceptions.ads src/corba/polyorb-corba_p-initial_references.adb src/corba/polyorb-corba_p-initial_references.ads src/corba/polyorb-corba_p-interceptors_hooks.ads src/corba/polyorb-corba_p-ir_hooks.adb src/corba/polyorb-corba_p-ir_hooks.ads src/corba/polyorb-corba_p-local.adb src/corba/polyorb-corba_p-local.ads src/corba/polyorb-corba_p-names.adb src/corba/polyorb-corba_p-names.ads src/corba/polyorb-corba_p-orb_init.adb src/corba/polyorb-corba_p-orb_init.ads src/corba/polyorb-corba_p-poa_config.adb src/corba/polyorb-corba_p-poa_config.ads src/corba/polyorb-corba_p-policy.adb src/corba/polyorb-corba_p-policy.ads src/corba/polyorb-corba_p-policy_management.adb src/corba/polyorb-corba_p-policy_management.ads src/corba/polyorb-corba_p-servantactivator.adb src/corba/polyorb-corba_p-servantactivator.ads src/corba/polyorb-corba_p-servantlocator.adb src/corba/polyorb-corba_p-servantlocator.ads src/corba/polyorb-corba_p-server_tools.adb src/corba/polyorb-corba_p-server_tools.ads src/corba/polyorb-corba_p.ads src/corba/polyorb-sequences-bounded-corba_helper.adb src/corba/polyorb-sequences-bounded-corba_helper.ads src/corba/polyorb-sequences-unbounded-corba_helper.adb src/corba/polyorb-sequences-unbounded-corba_helper.ads src/corba/portableinterceptor/polyorb-corba_p-interceptors.adb src/corba/portableinterceptor/polyorb-corba_p-interceptors.ads src/corba/portableinterceptor/polyorb-corba_p-interceptors_policies.adb src/corba/portableinterceptor/polyorb-corba_p-interceptors_policies.ads src/corba/portableinterceptor/polyorb-corba_p-interceptors_slots.adb src/corba/portableinterceptor/polyorb-corba_p-interceptors_slots.ads src/corba/portableinterceptor/portableinterceptor-clientrequestinfo-impl.adb src/corba/portableinterceptor/portableinterceptor-clientrequestinfo-impl.ads src/corba/portableinterceptor/portableinterceptor-clientrequestinterceptor-impl.adb src/corba/portableinterceptor/portableinterceptor-clientrequestinterceptor-impl.ads src/corba/portableinterceptor/portableinterceptor-current-impl.adb src/corba/portableinterceptor/portableinterceptor-current-impl.ads src/corba/portableinterceptor/portableinterceptor-interceptor-impl.adb src/corba/portableinterceptor/portableinterceptor-interceptor-impl.ads src/corba/portableinterceptor/portableinterceptor-iorinfo-impl.adb src/corba/portableinterceptor/portableinterceptor-iorinfo-impl.ads src/corba/portableinterceptor/portableinterceptor-iorinterceptor-impl.adb src/corba/portableinterceptor/portableinterceptor-iorinterceptor-impl.ads src/corba/portableinterceptor/portableinterceptor-iorinterceptor_3_0-impl.adb src/corba/portableinterceptor/portableinterceptor-iorinterceptor_3_0-impl.ads src/corba/portableinterceptor/portableinterceptor-orbinitializer-impl.adb src/corba/portableinterceptor/portableinterceptor-orbinitializer-impl.ads src/corba/portableinterceptor/portableinterceptor-orbinitializer-initialize_all.adb src/corba/portableinterceptor/portableinterceptor-orbinitializer-initialize_all.ads src/corba/portableinterceptor/portableinterceptor-orbinitializer-register.adb src/corba/portableinterceptor/portableinterceptor-orbinitializer-register.ads src/corba/portableinterceptor/portableinterceptor-orbinitinfo-impl.adb src/corba/portableinterceptor/portableinterceptor-orbinitinfo-impl.ads src/corba/portableinterceptor/portableinterceptor-policyfactory-impl.adb src/corba/portableinterceptor/portableinterceptor-policyfactory-impl.ads src/corba/portableinterceptor/portableinterceptor-requestinfo-impl.adb src/corba/portableinterceptor/portableinterceptor-requestinfo-impl.ads src/corba/portableinterceptor/portableinterceptor-serverrequestinfo-impl.adb src/corba/portableinterceptor/portableinterceptor-serverrequestinfo-impl.ads src/corba/portableinterceptor/portableinterceptor-serverrequestinterceptor-impl.adb src/corba/portableinterceptor/portableinterceptor-serverrequestinterceptor-impl.ads src/corba/portableserver-adapteractivator.adb src/corba/portableserver-adapteractivator.ads src/corba/portableserver-current-helper.adb src/corba/portableserver-current-helper.ads src/corba/portableserver-current.adb src/corba/portableserver-current.ads src/corba/portableserver-helper.adb src/corba/portableserver-helper.ads src/corba/portableserver-idassignmentpolicy.adb src/corba/portableserver-idassignmentpolicy.ads src/corba/portableserver-iduniquenesspolicy.adb src/corba/portableserver-iduniquenesspolicy.ads src/corba/portableserver-implicitactivationpolicy.adb src/corba/portableserver-implicitactivationpolicy.ads src/corba/portableserver-lifespanpolicy.adb src/corba/portableserver-lifespanpolicy.ads src/corba/portableserver-poa-goa.adb src/corba/portableserver-poa-goa.ads src/corba/portableserver-poa-helper.adb src/corba/portableserver-poa-helper.ads src/corba/portableserver-poa.adb src/corba/portableserver-poa.ads src/corba/portableserver-poamanager.adb src/corba/portableserver-poamanager.ads src/corba/portableserver-requestprocessingpolicy.adb src/corba/portableserver-requestprocessingpolicy.ads src/corba/portableserver-servantactivator-impl.adb src/corba/portableserver-servantactivator-impl.ads src/corba/portableserver-servantactivator.adb src/corba/portableserver-servantactivator.ads src/corba/portableserver-servantlocator-impl.adb src/corba/portableserver-servantlocator-impl.ads src/corba/portableserver-servantlocator.adb src/corba/portableserver-servantlocator.ads src/corba/portableserver-servantmanager-impl.adb src/corba/portableserver-servantmanager-impl.ads src/corba/portableserver-servantmanager.ads src/corba/portableserver-servantretentionpolicy.adb src/corba/portableserver-servantretentionpolicy.ads src/corba/portableserver-threadpolicy.adb src/corba/portableserver-threadpolicy.ads src/corba/portableserver.adb src/corba/portableserver.ads src/corba/rtcorba/polyorb-rtcorba_p-mutex.adb src/corba/rtcorba/polyorb-rtcorba_p-mutex.ads src/corba/rtcorba/polyorb-rtcorba_p-prioritymodelpolicy.adb src/corba/rtcorba/polyorb-rtcorba_p-prioritymodelpolicy.ads src/corba/rtcorba/polyorb-rtcorba_p-setup.adb src/corba/rtcorba/polyorb-rtcorba_p-setup.ads src/corba/rtcorba/polyorb-rtcorba_p-threadpoolmanager.adb src/corba/rtcorba/polyorb-rtcorba_p-threadpoolmanager.ads src/corba/rtcorba/polyorb-rtcorba_p-to_orb_priority.adb src/corba/rtcorba/polyorb-rtcorba_p-to_orb_priority.ads src/corba/rtcorba/polyorb-rtcorba_p.ads src/corba/rtcorba/rtcorba-current-helper.adb src/corba/rtcorba/rtcorba-current-helper.ads src/corba/rtcorba/rtcorba-current.adb src/corba/rtcorba/rtcorba-current.ads src/corba/rtcorba/rtcorba-helper.adb src/corba/rtcorba/rtcorba-helper.ads src/corba/rtcorba/rtcorba-mutex-helper.adb src/corba/rtcorba/rtcorba-mutex-helper.ads src/corba/rtcorba/rtcorba-mutex.adb src/corba/rtcorba/rtcorba-mutex.ads src/corba/rtcorba/rtcorba-prioritymapping-direct.adb src/corba/rtcorba/rtcorba-prioritymapping-direct.ads src/corba/rtcorba/rtcorba-prioritymapping-linear.adb src/corba/rtcorba/rtcorba-prioritymapping-linear.ads src/corba/rtcorba/rtcorba-prioritymapping.adb src/corba/rtcorba/rtcorba-prioritymapping.ads src/corba/rtcorba/rtcorba-prioritymodelpolicy-helper.adb src/corba/rtcorba/rtcorba-prioritymodelpolicy-helper.ads src/corba/rtcorba/rtcorba-prioritymodelpolicy.adb src/corba/rtcorba/rtcorba-prioritymodelpolicy.ads src/corba/rtcorba/rtcorba-prioritytransform.adb src/corba/rtcorba/rtcorba-prioritytransform.ads src/corba/rtcorba/rtcorba-protocolproperties-helper.adb src/corba/rtcorba/rtcorba-protocolproperties-helper.ads src/corba/rtcorba/rtcorba-protocolproperties.ads src/corba/rtcorba/rtcorba-rtorb-helper.adb src/corba/rtcorba/rtcorba-rtorb-helper.ads src/corba/rtcorba/rtcorba-rtorb.adb src/corba/rtcorba/rtcorba-rtorb.ads src/corba/rtcorba/rtcorba-threadpoolpolicy-helper.adb src/corba/rtcorba/rtcorba-threadpoolpolicy-helper.ads src/corba/rtcorba/rtcorba-threadpoolpolicy.adb src/corba/rtcorba/rtcorba-threadpoolpolicy.ads src/corba/rtcorba/rtcorba.ads src/corba/rtcorba/rtcosscheduling-clientscheduler-impl.adb src/corba/rtcorba/rtcosscheduling-clientscheduler-impl.ads src/corba/rtcorba/rtcosscheduling-serverscheduler-impl.adb src/corba/rtcorba/rtcosscheduling-serverscheduler-impl.ads src/corba/rtcorba/rtportableserver-poa-helper.adb src/corba/rtcorba/rtportableserver-poa-helper.ads src/corba/rtcorba/rtportableserver-poa.adb src/corba/rtcorba/rtportableserver-poa.ads src/corba/rtcorba/rtportableserver.ads src/corba/security/polyorb-corba_p-css_state_machine.adb src/corba/security/polyorb-corba_p-css_state_machine.ads src/corba/security/polyorb-corba_p-css_state_machine_actions.adb src/corba/security/polyorb-corba_p-css_state_machine_actions.ads src/corba/security/polyorb-corba_p-security_current.adb src/corba/security/polyorb-corba_p-security_current.ads src/corba/security/polyorb-corba_p-security_policy.adb src/corba/security/polyorb-corba_p-security_policy.ads src/corba/security/polyorb-corba_p-tss_state_machine.adb src/corba/security/polyorb-corba_p-tss_state_machine.ads src/corba/security/polyorb-corba_p-tss_state_machine_actions.adb src/corba/security/polyorb-corba_p-tss_state_machine_actions.ads src/csupport.c src/dsa/polyorb-dsa_p-conversions.ads src/dsa/polyorb-dsa_p-exceptions.adb src/dsa/polyorb-dsa_p-exceptions.ads src/dsa/polyorb-dsa_p-name_server.adb src/dsa/polyorb-dsa_p-name_server.ads src/dsa/polyorb-dsa_p-partitions.adb src/dsa/polyorb-dsa_p-partitions.ads src/dsa/polyorb-dsa_p-remote_launch.adb src/dsa/polyorb-dsa_p-remote_launch.ads src/dsa/polyorb-dsa_p-storages-config.adb src/dsa/polyorb-dsa_p-storages-config.ads src/dsa/polyorb-dsa_p-storages-dfs.adb src/dsa/polyorb-dsa_p-storages-dfs.ads src/dsa/polyorb-dsa_p-storages-dsm.adb src/dsa/polyorb-dsa_p-storages-dsm.ads src/dsa/polyorb-dsa_p-storages.adb src/dsa/polyorb-dsa_p-storages.ads src/dsa/polyorb-dsa_p-streams.adb src/dsa/polyorb-dsa_p-streams.ads src/dsa/polyorb-dsa_p.ads src/dsa/polyorb-partition_elaboration.adb src/dsa/polyorb-partition_elaboration.ads src/dsa/polyorb-poa_config-racws.adb src/dsa/polyorb-poa_config-racws.ads src/dsa/polyorb-qos-term_manager_info.adb src/dsa/polyorb-qos-term_manager_info.ads src/dsa/polyorb-termination_activity.adb src/dsa/polyorb-termination_activity.ads src/dsa/polyorb-termination_manager-bootstrap.adb src/dsa/polyorb-termination_manager-bootstrap.ads src/dsa/polyorb-termination_manager.adb src/dsa/polyorb-termination_manager.ads src/dsa/s-dsaser.adb src/dsa/s-dsaser.ads src/dsa/s-dsatyp.adb src/dsa/s-dsatyp.ads src/dsa/s-parint.adb src/dsa/s-parint.ads src/dsa/s-shasto.adb src/dsa/s-shasto.ads src/giop/cs_registry1.2h src/giop/diop/polyorb-binding_data-giop-diop.adb src/giop/diop/polyorb-binding_data-giop-diop.ads src/giop/diop/polyorb-giop_p-transport_mechanisms-diop.adb src/giop/diop/polyorb-giop_p-transport_mechanisms-diop.ads src/giop/diop/polyorb-protocols-giop-diop.adb src/giop/diop/polyorb-protocols-giop-diop.ads src/giop/diop/polyorb-setup-access_points-diop.adb src/giop/diop/polyorb-setup-access_points-diop.ads src/giop/diop/polyorb-setup-diop.adb src/giop/diop/polyorb-setup-diop.ads src/giop/gen_codeset.adb src/giop/iiop/polyorb-binding_data-giop-iiop.adb src/giop/iiop/polyorb-binding_data-giop-iiop.ads src/giop/iiop/polyorb-giop_p-tagged_components-alternate_iiop_address.adb src/giop/iiop/polyorb-giop_p-tagged_components-alternate_iiop_address.ads src/giop/iiop/polyorb-giop_p-tagged_components-ssl_sec_trans.adb src/giop/iiop/polyorb-giop_p-tagged_components-ssl_sec_trans.ads src/giop/iiop/polyorb-giop_p-transport_mechanisms-iiop.adb src/giop/iiop/polyorb-giop_p-transport_mechanisms-iiop.ads src/giop/iiop/polyorb-protocols-giop-iiop.adb src/giop/iiop/polyorb-protocols-giop-iiop.ads src/giop/iiop/polyorb-setup-access_points-iiop.adb src/giop/iiop/polyorb-setup-access_points-iiop.ads src/giop/iiop/polyorb-setup-iiop.adb src/giop/iiop/polyorb-setup-iiop.ads src/giop/iiop/security/polyorb-giop_p-tagged_components-csi_sec_mech_list.adb src/giop/iiop/security/polyorb-giop_p-tagged_components-csi_sec_mech_list.ads src/giop/iiop/security/polyorb-giop_p-tagged_components-null_tag.adb src/giop/iiop/security/polyorb-giop_p-tagged_components-null_tag.ads src/giop/iiop/security/tls/polyorb-giop_p-tagged_components-tls_sec_trans.adb src/giop/iiop/security/tls/polyorb-giop_p-tagged_components-tls_sec_trans.ads src/giop/iiop/security/tls/polyorb-giop_p-transport_mechanisms-tls.adb src/giop/iiop/security/tls/polyorb-giop_p-transport_mechanisms-tls.ads src/giop/iiop/security/tls/polyorb-setup-access_points-tlsiop.adb src/giop/iiop/security/tls/polyorb-setup-access_points-tlsiop.ads src/giop/iiop/security/tls/polyorb-setup-tlsiop.adb src/giop/iiop/security/tls/polyorb-setup-tlsiop.ads src/giop/iiop/ssliop/polyorb-giop_p-transport_mechanisms-ssliop.adb src/giop/iiop/ssliop/polyorb-giop_p-transport_mechanisms-ssliop.ads src/giop/iiop/ssliop/polyorb-setup-access_points-ssliop.adb src/giop/iiop/ssliop/polyorb-setup-access_points-ssliop.ads src/giop/iiop/ssliop/polyorb-setup-ssliop.adb src/giop/iiop/ssliop/polyorb-setup-ssliop.ads src/giop/miop/polyorb-binding_data-giop-uipmc.adb src/giop/miop/polyorb-binding_data-giop-uipmc.ads src/giop/miop/polyorb-filters-miop-miop_in.adb src/giop/miop/polyorb-filters-miop-miop_in.ads src/giop/miop/polyorb-filters-miop-miop_out.adb src/giop/miop/polyorb-filters-miop-miop_out.ads src/giop/miop/polyorb-filters-miop.adb src/giop/miop/polyorb-filters-miop.ads src/giop/miop/polyorb-giop_p-transport_mechanisms-uipmc.adb src/giop/miop/polyorb-giop_p-transport_mechanisms-uipmc.ads src/giop/miop/polyorb-miop_p-groups.adb src/giop/miop/polyorb-miop_p-groups.ads src/giop/miop/polyorb-miop_p-tagged_components.adb src/giop/miop/polyorb-miop_p-tagged_components.ads src/giop/miop/polyorb-miop_p.ads src/giop/miop/polyorb-protocols-giop-uipmc.adb src/giop/miop/polyorb-protocols-giop-uipmc.ads src/giop/miop/polyorb-setup-access_points-uipmc.adb src/giop/miop/polyorb-setup-access_points-uipmc.ads src/giop/miop/polyorb-setup-uipmc.adb src/giop/miop/polyorb-setup-uipmc.ads src/giop/polyorb-binding_data-giop-inet.adb src/giop/polyorb-binding_data-giop-inet.ads src/giop/polyorb-binding_data-giop.adb src/giop/polyorb-binding_data-giop.ads src/giop/polyorb-giop_p-code_sets-converters-unicode.adb src/giop/polyorb-giop_p-code_sets-converters-unicode.ads src/giop/polyorb-giop_p-code_sets-converters.adb src/giop/polyorb-giop_p-code_sets-converters.ads src/giop/polyorb-giop_p-code_sets.adb src/giop/polyorb-giop_p-code_sets.ads src/giop/polyorb-giop_p-exceptions.adb src/giop/polyorb-giop_p-exceptions.ads src/giop/polyorb-giop_p-service_contexts.adb src/giop/polyorb-giop_p-service_contexts.ads src/giop/polyorb-giop_p-tagged_components-code_sets.adb src/giop/polyorb-giop_p-tagged_components-code_sets.ads src/giop/polyorb-giop_p-tagged_components-policies-priority_model_policy.adb src/giop/polyorb-giop_p-tagged_components-policies-priority_model_policy.ads src/giop/polyorb-giop_p-tagged_components-policies.adb src/giop/polyorb-giop_p-tagged_components-policies.ads src/giop/polyorb-giop_p-tagged_components.adb src/giop/polyorb-giop_p-tagged_components.ads src/giop/polyorb-giop_p-transport_mechanisms.adb src/giop/polyorb-giop_p-transport_mechanisms.ads src/giop/polyorb-giop_p.ads src/giop/polyorb-protocols-giop-common.adb src/giop/polyorb-protocols-giop-common.ads src/giop/polyorb-protocols-giop-giop_1_0.adb src/giop/polyorb-protocols-giop-giop_1_0.ads src/giop/polyorb-protocols-giop-giop_1_1.adb src/giop/polyorb-protocols-giop-giop_1_1.ads src/giop/polyorb-protocols-giop-giop_1_2.adb src/giop/polyorb-protocols-giop-giop_1_2.ads src/giop/polyorb-protocols-giop.adb src/giop/polyorb-protocols-giop.ads src/giop/polyorb-qos-code_sets.adb src/giop/polyorb-qos-code_sets.ads src/giop/polyorb-representations-cdr-giop_1_0.adb src/giop/polyorb-representations-cdr-giop_1_0.ads src/giop/polyorb-representations-cdr-giop_1_1.adb src/giop/polyorb-representations-cdr-giop_1_1.ads src/giop/polyorb-representations-cdr-giop_1_2.adb src/giop/polyorb-representations-cdr-giop_1_2.ads src/giop/polyorb-representations-cdr-giop_utils.adb src/giop/polyorb-representations-cdr-giop_utils.ads src/moma/moma-configuration-server.adb src/moma/moma-configuration-server.ads src/moma/moma-configuration.adb src/moma/moma-configuration.ads src/moma/moma-connection_factories.adb src/moma/moma-connection_factories.ads src/moma/moma-connections.adb src/moma/moma-connections.ads src/moma/moma-destinations.adb src/moma/moma-destinations.ads src/moma/moma-message_consumers.adb src/moma/moma-message_consumers.ads src/moma/moma-message_handlers.adb src/moma/moma-message_handlers.ads src/moma/moma-message_producers.adb src/moma/moma-message_producers.ads src/moma/moma-messages-manys.adb src/moma/moma-messages-manys.ads src/moma/moma-messages-mbytes.adb src/moma/moma-messages-mbytes.ads src/moma/moma-messages-mexecutes.adb src/moma/moma-messages-mexecutes.ads src/moma/moma-messages-mmaps.adb src/moma/moma-messages-mmaps.ads src/moma/moma-messages-mstreams.adb src/moma/moma-messages-mstreams.ads src/moma/moma-messages-mtexts.adb src/moma/moma-messages-mtexts.ads src/moma/moma-messages.adb src/moma/moma-messages.ads src/moma/moma-references.adb src/moma/moma-references.ads src/moma/moma-runtime.adb src/moma/moma-runtime.ads src/moma/moma-sessions.adb src/moma/moma-sessions.ads src/moma/moma-types.adb src/moma/moma-types.ads src/moma/moma.ads src/moma/polyorb-moma_p-exceptions.adb src/moma/polyorb-moma_p-exceptions.ads src/moma/polyorb-moma_p-provider-message_consumer.adb src/moma/polyorb-moma_p-provider-message_consumer.ads src/moma/polyorb-moma_p-provider-message_handler.adb src/moma/polyorb-moma_p-provider-message_handler.ads src/moma/polyorb-moma_p-provider-message_pool.adb src/moma/polyorb-moma_p-provider-message_pool.ads src/moma/polyorb-moma_p-provider-message_producer.adb src/moma/polyorb-moma_p-provider-message_producer.ads src/moma/polyorb-moma_p-provider-routers.adb src/moma/polyorb-moma_p-provider-routers.ads src/moma/polyorb-moma_p-provider-topic_datas.adb src/moma/polyorb-moma_p-provider-topic_datas.ads src/moma/polyorb-moma_p-provider-warehouse.adb src/moma/polyorb-moma_p-provider-warehouse.ads src/moma/polyorb-moma_p-provider.ads src/moma/polyorb-moma_p.ads src/polyorb-annotations.adb src/polyorb-annotations.ads src/polyorb-any-exceptionlist.adb src/polyorb-any-exceptionlist.ads src/polyorb-any-initialization.adb src/polyorb-any-initialization.ads src/polyorb-any-nvlist.adb src/polyorb-any-nvlist.ads src/polyorb-any-objref.adb src/polyorb-any-objref.ads src/polyorb-any.adb src/polyorb-any.ads src/polyorb-asynch_ev-sockets.adb src/polyorb-asynch_ev-sockets.ads src/polyorb-asynch_ev.adb src/polyorb-asynch_ev.ads src/polyorb-binding_data-local.adb src/polyorb-binding_data-local.ads src/polyorb-binding_data-neighbour.adb src/polyorb-binding_data-neighbour.ads src/polyorb-binding_data.adb src/polyorb-binding_data.ads src/polyorb-binding_data_qos.adb src/polyorb-binding_data_qos.ads src/polyorb-binding_object_qos.adb src/polyorb-binding_object_qos.ads src/polyorb-binding_objects-lists.ads src/polyorb-binding_objects.adb src/polyorb-binding_objects.ads src/polyorb-buffers.adb src/polyorb-buffers.ads src/polyorb-call_back.adb src/polyorb-call_back.ads src/polyorb-components.adb src/polyorb-components.ads src/polyorb-constants.ads src/polyorb-dynamic_dict.adb src/polyorb-dynamic_dict.ads src/polyorb-errors-helper.adb src/polyorb-errors-helper.ads src/polyorb-errors.adb src/polyorb-errors.ads src/polyorb-exceptions.adb src/polyorb-exceptions.ads src/polyorb-filters-fragmenter.adb src/polyorb-filters-fragmenter.ads src/polyorb-filters-iface.adb src/polyorb-filters-iface.ads src/polyorb-filters-slicers.adb src/polyorb-filters-slicers.ads src/polyorb-filters.adb src/polyorb-filters.ads src/polyorb-fixed_point.adb src/polyorb-fixed_point.ads src/polyorb-if_descriptors.ads src/polyorb-initialization.adb src/polyorb-initialization.ads src/polyorb-jobs.adb src/polyorb-jobs.ads src/polyorb-lanes.adb src/polyorb-lanes.ads src/polyorb-log-initialization.adb src/polyorb-log-initialization.ads src/polyorb-log-stderr.adb src/polyorb-log-stderr.ads src/polyorb-log.adb src/polyorb-log.ads src/polyorb-minimal_servant-tools.adb src/polyorb-minimal_servant-tools.ads src/polyorb-minimal_servant.adb src/polyorb-minimal_servant.ads src/polyorb-obj_adapter_qos.adb src/polyorb-obj_adapter_qos.ads src/polyorb-obj_adapters-group_object_adapter.adb src/polyorb-obj_adapters-group_object_adapter.ads src/polyorb-obj_adapters-simple.adb src/polyorb-obj_adapters-simple.ads src/polyorb-obj_adapters.adb src/polyorb-obj_adapters.ads src/polyorb-object_maps-system.adb src/polyorb-object_maps-system.ads src/polyorb-object_maps-user.adb src/polyorb-object_maps-user.ads src/polyorb-object_maps.adb src/polyorb-object_maps.ads src/polyorb-objects.adb src/polyorb-objects.ads src/polyorb-opaque-chunk_pools.adb src/polyorb-opaque-chunk_pools.ads src/polyorb-opaque.adb src/polyorb-opaque.ads src/polyorb-orb-iface.ads src/polyorb-orb-no_tasking.adb src/polyorb-orb-no_tasking.ads src/polyorb-orb-thread_per_request.adb src/polyorb-orb-thread_per_request.ads src/polyorb-orb-thread_per_session.adb src/polyorb-orb-thread_per_session.ads src/polyorb-orb-thread_pool.adb src/polyorb-orb-thread_pool.ads src/polyorb-orb.adb src/polyorb-orb.ads src/polyorb-orb_controller-half_sync_half_async.adb src/polyorb-orb_controller-half_sync_half_async.ads src/polyorb-orb_controller-leader_followers.adb src/polyorb-orb_controller-leader_followers.ads src/polyorb-orb_controller-no_tasking.adb src/polyorb-orb_controller-no_tasking.ads src/polyorb-orb_controller-workers.adb src/polyorb-orb_controller-workers.ads src/polyorb-orb_controller.adb src/polyorb-orb_controller.ads src/polyorb-parameters-command_line.adb src/polyorb-parameters-command_line.ads src/polyorb-parameters-environment.adb src/polyorb-parameters-environment.ads src/polyorb-parameters-file.adb src/polyorb-parameters-file.ads src/polyorb-parameters-initialization.adb src/polyorb-parameters-initialization.ads src/polyorb-parameters-static.adb src/polyorb-parameters-static.ads src/polyorb-parameters.adb src/polyorb-parameters.ads src/polyorb-platform-ssl_linker_options.ads.in src/polyorb-platform.ads.in src/polyorb-poa-basic_poa.adb src/polyorb-poa-basic_poa.ads src/polyorb-poa.adb src/polyorb-poa.ads src/polyorb-poa_config-minimum.adb src/polyorb-poa_config-minimum.ads src/polyorb-poa_config-proxies.adb src/polyorb-poa_config-proxies.ads src/polyorb-poa_config-root_poa.adb src/polyorb-poa_config-root_poa.ads src/polyorb-poa_config.adb src/polyorb-poa_config.ads src/polyorb-poa_manager-basic_manager.adb src/polyorb-poa_manager-basic_manager.ads src/polyorb-poa_manager.ads src/polyorb-poa_policies-id_assignment_policy-system.adb src/polyorb-poa_policies-id_assignment_policy-system.ads src/polyorb-poa_policies-id_assignment_policy-user.adb src/polyorb-poa_policies-id_assignment_policy-user.ads src/polyorb-poa_policies-id_assignment_policy.ads src/polyorb-poa_policies-id_uniqueness_policy-multiple.adb src/polyorb-poa_policies-id_uniqueness_policy-multiple.ads src/polyorb-poa_policies-id_uniqueness_policy-unique.adb src/polyorb-poa_policies-id_uniqueness_policy-unique.ads src/polyorb-poa_policies-id_uniqueness_policy.ads src/polyorb-poa_policies-implicit_activation_policy-activation.adb src/polyorb-poa_policies-implicit_activation_policy-activation.ads src/polyorb-poa_policies-implicit_activation_policy-no_activation.adb src/polyorb-poa_policies-implicit_activation_policy-no_activation.ads src/polyorb-poa_policies-implicit_activation_policy.ads src/polyorb-poa_policies-lifespan_policy-persistent.adb src/polyorb-poa_policies-lifespan_policy-persistent.ads src/polyorb-poa_policies-lifespan_policy-transient.adb src/polyorb-poa_policies-lifespan_policy-transient.ads src/polyorb-poa_policies-lifespan_policy.ads src/polyorb-poa_policies-request_processing_policy-active_object_map_only.adb src/polyorb-poa_policies-request_processing_policy-active_object_map_only.ads src/polyorb-poa_policies-request_processing_policy-use_default_servant.adb src/polyorb-poa_policies-request_processing_policy-use_default_servant.ads src/polyorb-poa_policies-request_processing_policy-use_servant_manager.adb src/polyorb-poa_policies-request_processing_policy-use_servant_manager.ads src/polyorb-poa_policies-request_processing_policy.ads src/polyorb-poa_policies-servant_retention_policy-non_retain.adb src/polyorb-poa_policies-servant_retention_policy-non_retain.ads src/polyorb-poa_policies-servant_retention_policy-retain.adb src/polyorb-poa_policies-servant_retention_policy-retain.ads src/polyorb-poa_policies-servant_retention_policy.ads src/polyorb-poa_policies-thread_policy-main_thread.adb src/polyorb-poa_policies-thread_policy-main_thread.ads src/polyorb-poa_policies-thread_policy-orb_ctrl.adb src/polyorb-poa_policies-thread_policy-orb_ctrl.ads src/polyorb-poa_policies-thread_policy-single_thread.adb src/polyorb-poa_policies-thread_policy-single_thread.ads src/polyorb-poa_policies-thread_policy.adb src/polyorb-poa_policies-thread_policy.ads src/polyorb-poa_policies.ads src/polyorb-poa_types.adb src/polyorb-poa_types.ads src/polyorb-protocols-echo.adb src/polyorb-protocols-echo.ads src/polyorb-protocols-iface.ads src/polyorb-protocols.adb src/polyorb-protocols.ads src/polyorb-qos-addressing_modes.ads src/polyorb-qos-exception_informations.adb src/polyorb-qos-exception_informations.ads src/polyorb-qos-priority.adb src/polyorb-qos-priority.ads src/polyorb-qos-service_contexts.adb src/polyorb-qos-service_contexts.ads src/polyorb-qos-static_buffers.adb src/polyorb-qos-static_buffers.ads src/polyorb-qos-tagged_components.adb src/polyorb-qos-tagged_components.ads src/polyorb-qos.adb src/polyorb-qos.ads src/polyorb-references-binding.adb src/polyorb-references-binding.ads src/polyorb-references-corbaloc.adb src/polyorb-references-corbaloc.ads src/polyorb-references-file.adb src/polyorb-references-file.ads src/polyorb-references-ior.adb src/polyorb-references-ior.ads src/polyorb-references-uri.adb src/polyorb-references-uri.ads src/polyorb-references.adb src/polyorb-references.ads src/polyorb-representations-cdr-common.adb src/polyorb-representations-cdr-common.ads src/polyorb-representations-cdr.adb src/polyorb-representations-cdr.ads src/polyorb-representations-test.adb src/polyorb-representations-test.ads src/polyorb-representations.adb src/polyorb-representations.ads src/polyorb-request_qos.adb src/polyorb-request_qos.ads src/polyorb-request_scheduler-servant_lane.adb src/polyorb-request_scheduler-servant_lane.ads src/polyorb-request_scheduler.adb src/polyorb-request_scheduler.ads src/polyorb-requests.adb src/polyorb-requests.ads src/polyorb-rt_poa-basic_rt_poa.adb src/polyorb-rt_poa-basic_rt_poa.ads src/polyorb-rt_poa.ads src/polyorb-rt_poa_policies-priority_model_policy.adb src/polyorb-rt_poa_policies-priority_model_policy.ads src/polyorb-rt_poa_policies-thread_pool_policy.adb src/polyorb-rt_poa_policies-thread_pool_policy.ads src/polyorb-rt_poa_policies.ads src/polyorb-sequences-bounded-helper.adb src/polyorb-sequences-bounded-helper.ads src/polyorb-sequences-bounded.adb src/polyorb-sequences-bounded.ads src/polyorb-sequences-helper.adb src/polyorb-sequences-helper.ads src/polyorb-sequences-unbounded-helper.adb src/polyorb-sequences-unbounded-helper.ads src/polyorb-sequences-unbounded-search.adb src/polyorb-sequences-unbounded-search.ads src/polyorb-sequences-unbounded.adb src/polyorb-sequences-unbounded.ads src/polyorb-sequences.adb src/polyorb-sequences.ads src/polyorb-servants-group_servants.adb src/polyorb-servants-group_servants.ads src/polyorb-servants-iface.ads src/polyorb-servants.adb src/polyorb-servants.ads src/polyorb-services-naming-helper.adb src/polyorb-services-naming-helper.ads src/polyorb-services-naming-namingcontext-client.adb src/polyorb-services-naming-namingcontext-client.ads src/polyorb-services-naming-namingcontext-helper.adb src/polyorb-services-naming-namingcontext-helper.ads src/polyorb-services-naming-namingcontext-servant.adb src/polyorb-services-naming-namingcontext-servant.ads src/polyorb-services-naming-namingcontext.adb src/polyorb-services-naming-namingcontext.ads src/polyorb-services-naming-tools.adb src/polyorb-services-naming-tools.ads src/polyorb-services-naming.ads src/polyorb-services.ads src/polyorb-setup-access_points.ads src/polyorb-setup-oa-basic_poa.adb src/polyorb-setup-oa-basic_poa.ads src/polyorb-setup-oa-basic_rt_poa.adb src/polyorb-setup-oa-basic_rt_poa.ads src/polyorb-setup-oa-simple_oa.adb src/polyorb-setup-oa-simple_oa.ads src/polyorb-setup-oa.ads src/polyorb-setup-proxies_poa.adb src/polyorb-setup-proxies_poa.ads src/polyorb-setup.ads src/polyorb-smart_pointers-controlled_entities.adb src/polyorb-smart_pointers-controlled_entities.ads src/polyorb-smart_pointers-initialization.adb src/polyorb-smart_pointers-initialization.ads src/polyorb-smart_pointers-sync_counters__intrinsic.adb src/polyorb-smart_pointers-sync_counters__mutex.adb src/polyorb-smart_pointers.adb src/polyorb-smart_pointers.ads src/polyorb-sockets.ads src/polyorb-sockets_initialization.adb src/polyorb-sockets_initialization.ads src/polyorb-std.ads src/polyorb-storage_pools.ads src/polyorb-task_info.adb src/polyorb-task_info.ads src/polyorb-tasking-abortables.adb src/polyorb-tasking-abortables.ads src/polyorb-tasking-advanced_mutexes.adb src/polyorb-tasking-advanced_mutexes.ads src/polyorb-tasking-condition_variables.adb src/polyorb-tasking-condition_variables.ads src/polyorb-tasking-idle_tasks_managers.adb src/polyorb-tasking-idle_tasks_managers.ads src/polyorb-tasking-mutexes.adb src/polyorb-tasking-mutexes.ads src/polyorb-tasking-priorities.ads src/polyorb-tasking-profiles-full_tasking-condition_variables.adb src/polyorb-tasking-profiles-full_tasking-condition_variables.ads src/polyorb-tasking-profiles-full_tasking-mutexes.adb src/polyorb-tasking-profiles-full_tasking-mutexes.ads src/polyorb-tasking-profiles-full_tasking-portable_mutexes.adb src/polyorb-tasking-profiles-full_tasking-portable_mutexes.ads src/polyorb-tasking-profiles-full_tasking-threads-annotations.adb src/polyorb-tasking-profiles-full_tasking-threads-annotations.ads src/polyorb-tasking-profiles-full_tasking-threads-dynamic_priorities.adb src/polyorb-tasking-profiles-full_tasking-threads-dynamic_priorities.ads src/polyorb-tasking-profiles-full_tasking-threads-static_priorities.adb src/polyorb-tasking-profiles-full_tasking-threads-static_priorities.ads src/polyorb-tasking-profiles-full_tasking-threads.adb src/polyorb-tasking-profiles-full_tasking-threads.ads src/polyorb-tasking-profiles-full_tasking.ads src/polyorb-tasking-profiles-full_tasking_atc-abortables.adb src/polyorb-tasking-profiles-full_tasking_atc-abortables.ads src/polyorb-tasking-profiles-full_tasking_atc.ads src/polyorb-tasking-profiles-no_tasking-condition_variables.adb src/polyorb-tasking-profiles-no_tasking-condition_variables.ads src/polyorb-tasking-profiles-no_tasking-mutexes.adb src/polyorb-tasking-profiles-no_tasking-mutexes.ads src/polyorb-tasking-profiles-no_tasking-threads-annotations.adb src/polyorb-tasking-profiles-no_tasking-threads-annotations.ads src/polyorb-tasking-profiles-no_tasking-threads.adb src/polyorb-tasking-profiles-no_tasking-threads.ads src/polyorb-tasking-profiles-no_tasking.ads src/polyorb-tasking-profiles-ravenscar-condition_variables.adb src/polyorb-tasking-profiles-ravenscar-condition_variables.ads src/polyorb-tasking-profiles-ravenscar-index_manager.adb src/polyorb-tasking-profiles-ravenscar-index_manager.ads src/polyorb-tasking-profiles-ravenscar-mutexes.adb src/polyorb-tasking-profiles-ravenscar-mutexes.ads src/polyorb-tasking-profiles-ravenscar-threads-annotations.adb src/polyorb-tasking-profiles-ravenscar-threads-annotations.ads src/polyorb-tasking-profiles-ravenscar-threads.adb src/polyorb-tasking-profiles-ravenscar-threads.ads src/polyorb-tasking-profiles-ravenscar.ads src/polyorb-tasking-profiles.ads src/polyorb-tasking-rw_locks.adb src/polyorb-tasking-rw_locks.ads src/polyorb-tasking-semaphores.adb src/polyorb-tasking-semaphores.ads src/polyorb-tasking-threads-annotations.adb src/polyorb-tasking-threads-annotations.ads src/polyorb-tasking-threads.adb src/polyorb-tasking-threads.ads src/polyorb-tasking.ads src/polyorb-transport-connected-sockets.adb src/polyorb-transport-connected-sockets.ads src/polyorb-transport-connected.adb src/polyorb-transport-connected.ads src/polyorb-transport-datagram-sockets.adb src/polyorb-transport-datagram-sockets.ads src/polyorb-transport-datagram.adb src/polyorb-transport-datagram.ads src/polyorb-transport-handlers.adb src/polyorb-transport-handlers.ads src/polyorb-transport.adb src/polyorb-transport.ads src/polyorb-types.adb src/polyorb-types.ads src/polyorb-utils-buffers.adb src/polyorb-utils-buffers.ads src/polyorb-utils-chained_lists.adb src/polyorb-utils-chained_lists.ads src/polyorb-utils-configuration_file.adb src/polyorb-utils-configuration_file.ads src/polyorb-utils-dynamic_tables.adb src/polyorb-utils-dynamic_tables.ads src/polyorb-utils-hfunctions-hyper.adb src/polyorb-utils-hfunctions-hyper.ads src/polyorb-utils-hfunctions-mul.adb src/polyorb-utils-hfunctions-mul.ads src/polyorb-utils-hfunctions.ads src/polyorb-utils-htables-perfect.adb src/polyorb-utils-htables-perfect.ads src/polyorb-utils-htables.ads src/polyorb-utils-ilists.adb src/polyorb-utils-ilists.ads src/polyorb-utils-random.adb src/polyorb-utils-random.ads src/polyorb-utils-report.adb src/polyorb-utils-report.ads src/polyorb-utils-simple_flags.adb src/polyorb-utils-simple_flags.ads src/polyorb-utils-socket_access_points.adb src/polyorb-utils-socket_access_points.ads src/polyorb-utils-sockets.adb src/polyorb-utils-sockets.ads src/polyorb-utils-strings-lists.adb src/polyorb-utils-strings-lists.ads src/polyorb-utils-strings.adb src/polyorb-utils-strings.ads src/polyorb-utils-tcp_access_points.adb src/polyorb-utils-tcp_access_points.ads src/polyorb-utils-udp_access_points.adb src/polyorb-utils-udp_access_points.ads src/polyorb-utils.adb src/polyorb-utils.ads src/polyorb.ads src/polyorb.conf src/ravenscar.adc.in src/ravenscar_compatible.adc.in src/security/gssup/polyorb-security-authentication_mechanisms-gssup_client.adb src/security/gssup/polyorb-security-authentication_mechanisms-gssup_client.ads src/security/gssup/polyorb-security-authentication_mechanisms-gssup_target.adb src/security/gssup/polyorb-security-authentication_mechanisms-gssup_target.ads src/security/gssup/polyorb-security-credentials-gssup.adb src/security/gssup/polyorb-security-credentials-gssup.ads src/security/gssup/polyorb-security-exported_names-gssup.adb src/security/gssup/polyorb-security-exported_names-gssup.ads src/security/polyorb-asn1.adb src/security/polyorb-asn1.ads src/security/polyorb-qos-clients_security.adb src/security/polyorb-qos-clients_security.ads src/security/polyorb-qos-security_contexts.adb src/security/polyorb-qos-security_contexts.ads src/security/polyorb-qos-targets_security.adb src/security/polyorb-qos-targets_security.ads src/security/polyorb-qos-transport_contexts.adb src/security/polyorb-qos-transport_contexts.ads src/security/polyorb-security-authentication_mechanisms.adb src/security/polyorb-security-authentication_mechanisms.ads src/security/polyorb-security-authority_mechanisms.adb src/security/polyorb-security-authority_mechanisms.ads src/security/polyorb-security-authorization_elements-unknown.adb src/security/polyorb-security-authorization_elements-unknown.ads src/security/polyorb-security-authorization_elements.adb src/security/polyorb-security-authorization_elements.ads src/security/polyorb-security-backward_trust_evaluators.adb src/security/polyorb-security-backward_trust_evaluators.ads src/security/polyorb-security-connections.ads src/security/polyorb-security-credentials-compound.adb src/security/polyorb-security-credentials-compound.ads src/security/polyorb-security-credentials.adb src/security/polyorb-security-credentials.ads src/security/polyorb-security-exported_names-unknown.adb src/security/polyorb-security-exported_names-unknown.ads src/security/polyorb-security-exported_names.adb src/security/polyorb-security-exported_names.ads src/security/polyorb-security-forward_trust_evaluators.ads src/security/polyorb-security-identities-anonymous.adb src/security/polyorb-security-identities-anonymous.ads src/security/polyorb-security-identities-principal_name.adb src/security/polyorb-security-identities-principal_name.ads src/security/polyorb-security-identities.adb src/security/polyorb-security-identities.ads src/security/polyorb-security-security_manager.adb src/security/polyorb-security-security_manager.ads src/security/polyorb-security-transport_mechanisms-unprotected.adb src/security/polyorb-security-transport_mechanisms-unprotected.ads src/security/polyorb-security-transport_mechanisms.ads src/security/polyorb-security-types.adb src/security/polyorb-security-types.ads src/security/polyorb-security.ads src/security/polyorb_asn1.c src/security/tls/polyorb-asynch_ev-sockets-tls.adb src/security/tls/polyorb-asynch_ev-sockets-tls.ads src/security/tls/polyorb-security-credentials-tls.adb src/security/tls/polyorb-security-credentials-tls.ads src/security/tls/polyorb-security-transport_mechanisms-tls.adb src/security/tls/polyorb-security-transport_mechanisms-tls.ads src/security/tls/polyorb-tls.adb src/security/tls/polyorb-tls.ads src/security/tls/polyorb-transport-connected-sockets-tls.adb src/security/tls/polyorb-transport-connected-sockets-tls.ads src/security/tls/polyorb-utils-tls_access_points.adb src/security/tls/polyorb-utils-tls_access_points.ads src/security/x509/polyorb-security-identities-distinguished_name.adb src/security/x509/polyorb-security-identities-distinguished_name.ads src/security/x509/polyorb-x509.adb src/security/x509/polyorb-x509.ads src/security/x509/polyorb_x509.c src/setup/polyorb-setup-base.adb.in src/setup/polyorb-setup-base.ads src/setup/polyorb-setup-client.adb src/setup/polyorb-setup-client.ads src/setup/polyorb-setup-client_base.adb.in src/setup/polyorb-setup-client_base.ads src/setup/polyorb-setup-common_base.adb src/setup/polyorb-setup-common_base.ads src/setup/polyorb-setup-default_parameters.adb src/setup/polyorb-setup-default_parameters.ads src/setup/polyorb-setup-no_tasking_client.adb src/setup/polyorb-setup-no_tasking_client.ads src/setup/polyorb-setup-no_tasking_server.adb src/setup/polyorb-setup-no_tasking_server.ads src/setup/polyorb-setup-ravenscar_tp_server.adb src/setup/polyorb-setup-ravenscar_tp_server.ads src/setup/polyorb-setup-server.adb.in src/setup/polyorb-setup-server.ads src/setup/polyorb-setup-tasking-full_tasking.adb.in src/setup/polyorb-setup-tasking-full_tasking.ads src/setup/polyorb-setup-tasking-no_tasking.adb src/setup/polyorb-setup-tasking-no_tasking.ads src/setup/polyorb-setup-tasking-ravenscar.ads src/setup/polyorb-setup-tasking.ads src/setup/polyorb-setup-thread_per_request_server.adb src/setup/polyorb-setup-thread_per_request_server.ads src/setup/polyorb-setup-thread_per_session_server.adb src/setup/polyorb-setup-thread_per_session_server.ads src/setup/polyorb-setup-thread_pool_client.adb src/setup/polyorb-setup-thread_pool_client.ads src/setup/polyorb-setup-thread_pool_server.adb src/setup/polyorb-setup-thread_pool_server.ads src/setup/security/polyorb-setup-secure_client.adb src/setup/security/polyorb-setup-secure_client.ads src/setup/security/polyorb-setup-secure_server.adb src/setup/security/polyorb-setup-secure_server.ads src/setup/security/polyorb-setup-security_base.adb src/setup/security/polyorb-setup-security_base.ads src/soap/gen_http_body src/soap/polyorb-binding_data-soap.adb src/soap/polyorb-binding_data-soap.ads src/soap/polyorb-buffer_sources.adb src/soap/polyorb-buffer_sources.ads src/soap/polyorb-filters-aws_interface.ads src/soap/polyorb-filters-http.adb src/soap/polyorb-filters-http.ads src/soap/polyorb-http_headers.ads src/soap/polyorb-http_methods.ads src/soap/polyorb-protocols-soap_pr.adb src/soap/polyorb-protocols-soap_pr.ads src/soap/polyorb-setup-access_points-soap.adb src/soap/polyorb-setup-access_points-soap.ads src/soap/polyorb-soap_p-message-payload.adb src/soap/polyorb-soap_p-message-payload.ads src/soap/polyorb-soap_p-message-reader.adb src/soap/polyorb-soap_p-message-reader.ads src/soap/polyorb-soap_p-message-response-error.adb src/soap/polyorb-soap_p-message-response-error.ads src/soap/polyorb-soap_p-message-response.adb src/soap/polyorb-soap_p-message-response.ads src/soap/polyorb-soap_p-message-xml.adb src/soap/polyorb-soap_p-message-xml.ads src/soap/polyorb-soap_p-message.adb src/soap/polyorb-soap_p-message.ads src/soap/polyorb-soap_p-parameters.adb src/soap/polyorb-soap_p-parameters.ads src/soap/polyorb-soap_p-response.adb src/soap/polyorb-soap_p-response.ads src/soap/polyorb-soap_p-types.adb src/soap/polyorb-soap_p-types.ads src/soap/polyorb-soap_p.adb src/soap/polyorb-soap_p.ads src/soap/polyorb-utils-text_buffers.adb src/soap/polyorb-utils-text_buffers.ads src/src.exclude.in src/srp/polyorb-binding_data-srp.adb src/srp/polyorb-binding_data-srp.ads src/srp/polyorb-protocols-srp.adb src/srp/polyorb-protocols-srp.ads src/srp/polyorb-representations-srp.adb src/srp/polyorb-representations-srp.ads src/srp/polyorb-setup-access_points-srp.adb src/srp/polyorb-setup-access_points-srp.ads src/srp/polyorb-utils-srp.adb src/srp/polyorb-utils-srp.ads src/ssl/polyorb-asynch_ev-sockets-ssl.adb src/ssl/polyorb-asynch_ev-sockets-ssl.ads src/ssl/polyorb-ssl.adb src/ssl/polyorb-ssl.ads src/ssl/polyorb-transport-connected-sockets-ssl.adb src/ssl/polyorb-transport-connected-sockets-ssl.ads src/ssl/polyorb-utils-ssl_access_points.adb src/ssl/polyorb-utils-ssl_access_points.ads src/ssl/polyorb_ssl.c src/web_common/polyorb-web-mime.adb src/web_common/polyorb-web-mime.ads src/web_common/polyorb-web-url-raise_url_error.adb src/web_common/polyorb-web-url-raise_url_error.ads src/web_common/polyorb-web-url.adb src/web_common/polyorb-web-url.ads src/web_common/polyorb-web-utils.adb src/web_common/polyorb-web-utils.ads src/web_common/polyorb-web.ads support/ada.m4 support/adacompiler.in support/cleanup-conf-files support/config.guess support/config.sub support/distrib.m4 support/gensedfile support/gentexifile support/gnatsrc.m4 support/idlcpp.m4 support/install-sh support/libtool-tag.m4 support/libtool.m4 support/linker.in support/ltmain.sh support/missing support/mkdep support/mkinstalldirs support/move-if-change support/reconfig support/run_cpp.ksh support/ssl.m4 support/subversion.m4 support/texinfo.tex support/utils.m4 testsuite/README testsuite/acats/CXE1001/Makefile.local testsuite/acats/CXE1001/cxe1001_a.adb testsuite/acats/CXE1001/cxe1001_b.adb testsuite/acats/CXE1001/cxe1001_p.adb testsuite/acats/CXE1001/cxe1001_q.adb testsuite/acats/CXE1001/local.gpr testsuite/acats/CXE1001/part1.adb testsuite/acats/CXE1001/part2.adb testsuite/acats/CXE2001/Makefile.local testsuite/acats/CXE2001/cxe2001_a.adb testsuite/acats/CXE2001/cxe2001_b.adb testsuite/acats/CXE2001/cxe2001_part_b.adb testsuite/acats/CXE2001/cxe2001_part_b.ads testsuite/acats/CXE2001/cxe2001_shared.adb testsuite/acats/CXE2001/cxe2001_shared.ads testsuite/acats/CXE2001/local.gpr testsuite/acats/CXE2001/part1.adb testsuite/acats/CXE2001/part2.adb testsuite/acats/CXE4001/Makefile.local testsuite/acats/CXE4001/cxe4001_a.adb testsuite/acats/CXE4001/cxe4001_b.adb testsuite/acats/CXE4001/cxe4001_decl_pure.ads testsuite/acats/CXE4001/cxe4001_partition_a.adb testsuite/acats/CXE4001/cxe4001_partition_a.ads testsuite/acats/CXE4001/cxe4001_partition_b.adb testsuite/acats/CXE4001/cxe4001_partition_b.ads testsuite/acats/CXE4001/local.gpr testsuite/acats/CXE4001/part1.adb testsuite/acats/CXE4001/part2.adb testsuite/acats/CXE4002/Makefile.local testsuite/acats/CXE4002/cxe4002_a.adb testsuite/acats/CXE4002/cxe4002_b.adb testsuite/acats/CXE4002/cxe4002_common.ads testsuite/acats/CXE4002/cxe4002_part_a1.adb testsuite/acats/CXE4002/cxe4002_part_a1.ads testsuite/acats/CXE4002/cxe4002_part_a2.adb testsuite/acats/CXE4002/cxe4002_part_a2.ads testsuite/acats/CXE4002/local.gpr testsuite/acats/CXE4002/part1.adb testsuite/acats/CXE4002/part2.adb testsuite/acats/CXE4005/Makefile.local testsuite/acats/CXE4005/cxe4005_a.adb testsuite/acats/CXE4005/cxe4005_b.adb testsuite/acats/CXE4005/cxe4005_common.adb testsuite/acats/CXE4005/cxe4005_common.ads testsuite/acats/CXE4005/cxe4005_normal.adb testsuite/acats/CXE4005/cxe4005_normal.ads testsuite/acats/CXE4005/cxe4005_part_a1.adb testsuite/acats/CXE4005/cxe4005_part_a1.ads testsuite/acats/CXE4005/cxe4005_part_a2.adb testsuite/acats/CXE4005/cxe4005_part_a2.ads testsuite/acats/CXE4005/cxe4005_part_b.adb testsuite/acats/CXE4005/cxe4005_part_b.ads testsuite/acats/CXE4005/cxe4005_remote_types.adb testsuite/acats/CXE4005/cxe4005_remote_types.ads testsuite/acats/CXE4005/local.gpr testsuite/acats/CXE4005/part1.adb testsuite/acats/CXE4005/part2.adb testsuite/acats/CXE4006/Makefile.local testsuite/acats/CXE4006/cxe4006_a.adb testsuite/acats/CXE4006/cxe4006_b.adb testsuite/acats/CXE4006/cxe4006_common.adb testsuite/acats/CXE4006/cxe4006_common.ads testsuite/acats/CXE4006/cxe4006_normal.adb testsuite/acats/CXE4006/cxe4006_normal.ads testsuite/acats/CXE4006/cxe4006_part_a1.adb testsuite/acats/CXE4006/cxe4006_part_a1.ads testsuite/acats/CXE4006/cxe4006_part_a2.adb testsuite/acats/CXE4006/cxe4006_part_a2.ads testsuite/acats/CXE4006/cxe4006_part_b.adb testsuite/acats/CXE4006/cxe4006_part_b.ads testsuite/acats/CXE4006/local.gpr testsuite/acats/CXE4006/part1.adb testsuite/acats/CXE4006/part2.adb testsuite/acats/support/impdef-annex_e.ads testsuite/acats/support/impdef.adb testsuite/acats/support/impdef.ads testsuite/acats/support/report.adb testsuite/acats/support/report.ads testsuite/corba/all_exceptions/Makefile.local testsuite/corba/all_exceptions/all_exceptions-impl.adb testsuite/corba/all_exceptions/all_exceptions-impl.ads testsuite/corba/all_exceptions/all_exceptions.idl testsuite/corba/all_exceptions/client.adb testsuite/corba/all_exceptions/local.gpr testsuite/corba/all_exceptions/server.adb testsuite/corba/benchs/test000/Makefile.local testsuite/corba/benchs/test000/client.adb testsuite/corba/benchs/test000/local.gpr testsuite/corba/benchs/test000/server.adb testsuite/corba/benchs/test000/test-activator-impl.adb testsuite/corba/benchs/test000/test-activator-impl.ads testsuite/corba/benchs/test000/test-echo-impl.adb testsuite/corba/benchs/test000/test-echo-impl.ads testsuite/corba/benchs/test000/test-factory-impl.adb testsuite/corba/benchs/test000/test-factory-impl.ads testsuite/corba/benchs/test000/test.idl testsuite/corba/benchs/test000/test_support.adb testsuite/corba/benchs/test000/test_support.ads testsuite/corba/code_sets/test000/Makefile.local testsuite/corba/code_sets/test000/client.adb testsuite/corba/code_sets/test000/local.gpr testsuite/corba/code_sets/test000/polyorb-giop_p-code_sets-converters-test.adb testsuite/corba/code_sets/test000/polyorb-giop_p-code_sets-converters-test.ads testsuite/corba/code_sets/test000/server.adb testsuite/corba/code_sets/test000/test_interface-impl.adb testsuite/corba/code_sets/test000/test_interface-impl.ads testsuite/corba/code_sets/test000/test_interface.idl testsuite/corba/cos/event/Makefile.local testsuite/corba/cos/event/README testsuite/corba/cos/event/auto_print.adb testsuite/corba/cos/event/auto_print.ads testsuite/corba/cos/event/consumer.cmd testsuite/corba/cos/event/local.gpr testsuite/corba/cos/event/supplier.cmd testsuite/corba/cos/event/test_event.adb testsuite/corba/cos/event/typedevent_multipleclient.cmd testsuite/corba/cos/event/typedevent_singleclient.cmd testsuite/corba/cos/event/typedtest_event.adb testsuite/corba/cos/event/typedtest_interface-impl.adb testsuite/corba/cos/event/typedtest_interface-impl.ads testsuite/corba/cos/event/typedtest_interface.idl testsuite/corba/cos/ir/Makefile.local testsuite/corba/cos/ir/client.adb testsuite/corba/cos/ir/local.gpr testsuite/corba/cos/ir/server.adb testsuite/corba/cos/naming/Makefile.local testsuite/corba/cos/naming/local.gpr testsuite/corba/cos/naming/test_naming_corba.adb testsuite/corba/cos/notification/Makefile.local testsuite/corba/cos/notification/README testsuite/corba/cos/notification/auto_print.adb testsuite/corba/cos/notification/auto_print.ads testsuite/corba/cos/notification/local.gpr testsuite/corba/cos/notification/test_notification.adb testsuite/corba/cos/notification/testanypull_multiple.cmd testsuite/corba/cos/notification/testanypullsupplier_multipleconsumer.cmd testsuite/corba/cos/notification/testanypush_multiple.cmd testsuite/corba/cos/notification/testanypush_single.cmd testsuite/corba/cos/notification/testsequencepull_multiple.cmd testsuite/corba/cos/notification/testsequencepull_single.cmd testsuite/corba/cos/notification/testsequencepush_multiple.cmd testsuite/corba/cos/notification/teststructpushsupplier_multipleconsumer.cmd testsuite/corba/cos/notification/teststructuredpull_multiple.cmd testsuite/corba/cos/notification/teststructuredpull_single.cmd testsuite/corba/cos/notification/teststructuredpush_multiple.cmd testsuite/corba/cos/time/Makefile.local testsuite/corba/cos/time/local.gpr testsuite/corba/cos/time/test_time.adb testsuite/corba/domainmanager/test000/Makefile.local testsuite/corba/domainmanager/test000/client.adb testsuite/corba/domainmanager/test000/corba-domainmanager-impl.adb testsuite/corba/domainmanager/test000/corba-domainmanager-impl.ads testsuite/corba/domainmanager/test000/corba-domainmanager-skel.adb testsuite/corba/domainmanager/test000/corba-domainmanager-skel.ads testsuite/corba/domainmanager/test000/local.gpr testsuite/corba/domainmanager/test000/server.adb testsuite/corba/domainmanager/test000/test-domainmanager-impl.ads testsuite/corba/domainmanager/test000/test-echo-impl.ads testsuite/corba/domainmanager/test000/test.idl testsuite/corba/harness/Makefile.local testsuite/corba/harness/client.adb testsuite/corba/harness/client_common.adb testsuite/corba/harness/client_common.ads testsuite/corba/harness/harness-impl.adb testsuite/corba/harness/harness-impl.ads testsuite/corba/harness/harness.idl testsuite/corba/harness/local.adb testsuite/corba/harness/local.gpr testsuite/corba/harness/server_common.adb testsuite/corba/harness/server_common.ads testsuite/corba/harness/server_no_tasking.adb testsuite/corba/harness/server_thread_per_request.adb testsuite/corba/harness/server_thread_per_session.adb testsuite/corba/harness/server_thread_pool.adb testsuite/corba/harness/server_thread_pool_hahs.adb testsuite/corba/harness/server_thread_pool_lf.adb testsuite/corba/interop/cpp/MICO/Makefile.MICO testsuite/corba/interop/cpp/README testsuite/corba/interop/cpp/TAO/Makefile.TAO testsuite/corba/interop/cpp/TAO/dynserver_mt_TAO.cc testsuite/corba/interop/cpp/common/all_functions_client.cc testsuite/corba/interop/cpp/common/all_types_client.cc testsuite/corba/interop/cpp/common/all_types_dynclient.cc testsuite/corba/interop/cpp/common/all_types_dynserver.cc testsuite/corba/interop/cpp/common/all_types_imp.cc testsuite/corba/interop/cpp/common/all_types_server.cc testsuite/corba/interop/cpp/common/report.cc testsuite/corba/interop/cpp/omniORB/Makefile.omniORB testsuite/corba/interop/java/Jonathan/Makefile.Jonathan testsuite/corba/interop/java/OpenORB/Makefile.OpenORB testsuite/corba/interop/java/README testsuite/corba/interop/java/common/Alltypes.java testsuite/corba/interop/java/common/Client.java testsuite/corba/interop/java/common/DynClient.java testsuite/corba/interop/java/common/DynServer.java testsuite/corba/interop/java/common/DynSkeleton.java testsuite/corba/interop/java/common/Server.java testsuite/corba/interop/java/common/all_types.idl testsuite/corba/local/Makefile.local testsuite/corba/local/local.gpr testsuite/corba/local/test000.adb testsuite/corba/location_forwarding/test000/Makefile.local testsuite/corba/location_forwarding/test000/local.gpr testsuite/corba/location_forwarding/test000/test000.adb testsuite/corba/location_forwarding/test000/test_globals.ads testsuite/corba/location_forwarding/test000/test_interface-impl.adb testsuite/corba/location_forwarding/test000/test_interface-impl.ads testsuite/corba/location_forwarding/test000/test_interface.idl testsuite/corba/location_forwarding/test000/test_servantactivator-impl.adb testsuite/corba/location_forwarding/test000/test_servantactivator-impl.ads testsuite/corba/location_forwarding/test001/Makefile.local testsuite/corba/location_forwarding/test001/local.gpr testsuite/corba/location_forwarding/test001/test001_client.adb testsuite/corba/location_forwarding/test001/test001_server.adb testsuite/corba/location_forwarding/test001/test_globals.ads testsuite/corba/location_forwarding/test001/test_interface-impl.adb testsuite/corba/location_forwarding/test001/test_interface-impl.ads testsuite/corba/location_forwarding/test001/test_interface.idl testsuite/corba/location_forwarding/test001/test_servantactivator-impl.adb testsuite/corba/location_forwarding/test001/test_servantactivator-impl.ads testsuite/corba/object/test000/Makefile.local testsuite/corba/object/test000/local.gpr testsuite/corba/object/test000/test000_client.adb testsuite/corba/object/test000/test000_server.adb testsuite/corba/object/test000/test_interface-impl.adb testsuite/corba/object/test000/test_interface-impl.ads testsuite/corba/object/test000/test_interface.idl testsuite/corba/orb_init/Makefile.local testsuite/corba/orb_init/local.gpr testsuite/corba/orb_init/test000.adb testsuite/corba/performance/Makefile.local testsuite/corba/performance/README testsuite/corba/performance/bench_utils.adb testsuite/corba/performance/bench_utils.ads testsuite/corba/performance/benchs-impl.adb testsuite/corba/performance/benchs-impl.ads testsuite/corba/performance/benchs.idl testsuite/corba/performance/client.adb testsuite/corba/performance/local.gpr testsuite/corba/performance/print_data.gnuplot testsuite/corba/performance/server_common.adb testsuite/corba/performance/server_common.ads testsuite/corba/performance/server_no_tasking.adb testsuite/corba/performance/server_thread_pool.adb testsuite/corba/portableinterceptor/test000/Makefile.local testsuite/corba/portableinterceptor/test000/local.gpr testsuite/corba/portableinterceptor/test000/test000.adb testsuite/corba/portableinterceptor/test000/test000_globals.adb testsuite/corba/portableinterceptor/test000/test000_globals.ads testsuite/corba/portableinterceptor/test000/test000_idl-clientinterceptor-impl.adb testsuite/corba/portableinterceptor/test000/test000_idl-clientinterceptor-impl.ads testsuite/corba/portableinterceptor/test000/test000_idl-orbinitializer-impl.adb testsuite/corba/portableinterceptor/test000/test000_idl-orbinitializer-impl.ads testsuite/corba/portableinterceptor/test000/test000_idl-serverinterceptor-impl.adb testsuite/corba/portableinterceptor/test000/test000_idl-serverinterceptor-impl.ads testsuite/corba/portableinterceptor/test000/test000_idl-testinterface-impl.adb testsuite/corba/portableinterceptor/test000/test000_idl-testinterface-impl.ads testsuite/corba/portableinterceptor/test000/test000_idl.idl testsuite/corba/portableinterceptor/test001/Makefile.local testsuite/corba/portableinterceptor/test001/local.gpr testsuite/corba/portableinterceptor/test001/test001.adb testsuite/corba/portableinterceptor/test001/test001_client_interceptor-impl.adb testsuite/corba/portableinterceptor/test001/test001_client_interceptor-impl.ads testsuite/corba/portableinterceptor/test001/test001_client_request_info_tests.adb testsuite/corba/portableinterceptor/test001/test001_client_request_info_tests.ads testsuite/corba/portableinterceptor/test001/test001_globals.adb testsuite/corba/portableinterceptor/test001/test001_globals.ads testsuite/corba/portableinterceptor/test001/test001_interface-impl.adb testsuite/corba/portableinterceptor/test001/test001_interface-impl.ads testsuite/corba/portableinterceptor/test001/test001_interface.idl testsuite/corba/portableinterceptor/test001/test001_orb_initializer-impl.adb testsuite/corba/portableinterceptor/test001/test001_orb_initializer-impl.ads testsuite/corba/portableinterceptor/test001/test001_request_info_tests.adb testsuite/corba/portableinterceptor/test001/test001_request_info_tests.ads testsuite/corba/portableinterceptor/test001/test001_server_interceptor-impl.adb testsuite/corba/portableinterceptor/test001/test001_server_interceptor-impl.ads testsuite/corba/portableinterceptor/test001/test001_server_request_info_tests.adb testsuite/corba/portableinterceptor/test001/test001_server_request_info_tests.ads testsuite/corba/portableinterceptor/test002/Makefile.local testsuite/corba/portableinterceptor/test002/local.gpr testsuite/corba/portableinterceptor/test002/test002.adb testsuite/corba/portableinterceptor/test002/test002_client_interceptor-impl.adb testsuite/corba/portableinterceptor/test002/test002_client_interceptor-impl.ads testsuite/corba/portableinterceptor/test002/test002_globals.ads testsuite/corba/portableinterceptor/test002/test002_interface-impl.adb testsuite/corba/portableinterceptor/test002/test002_interface-impl.ads testsuite/corba/portableinterceptor/test002/test002_interface.idl testsuite/corba/portableinterceptor/test002/test002_orb_initializer-impl.adb testsuite/corba/portableinterceptor/test002/test002_orb_initializer-impl.ads testsuite/corba/portableinterceptor/test002/test002_server_interceptor-impl.adb testsuite/corba/portableinterceptor/test002/test002_server_interceptor-impl.ads testsuite/corba/portableinterceptor/test003/Makefile.local testsuite/corba/portableinterceptor/test003/local.gpr testsuite/corba/portableinterceptor/test003/test003.adb testsuite/corba/portableinterceptor/test004/Makefile.local testsuite/corba/portableinterceptor/test004/client.adb testsuite/corba/portableinterceptor/test004/local.gpr testsuite/corba/portableinterceptor/test004/server.adb testsuite/corba/portableinterceptor/test004/test-clientinterceptor-impl.adb testsuite/corba/portableinterceptor/test004/test-clientinterceptor-impl.ads testsuite/corba/portableinterceptor/test004/test-clientorbinitializer-impl.adb testsuite/corba/portableinterceptor/test004/test-clientorbinitializer-impl.ads testsuite/corba/portableinterceptor/test004/test-demo-impl.adb testsuite/corba/portableinterceptor/test004/test-demo-impl.ads testsuite/corba/portableinterceptor/test004/test-iorinterceptor-impl.adb testsuite/corba/portableinterceptor/test004/test-iorinterceptor-impl.ads testsuite/corba/portableinterceptor/test004/test-serverorbinitializer-impl.adb testsuite/corba/portableinterceptor/test004/test-serverorbinitializer-impl.ads testsuite/corba/portableinterceptor/test004/test.idl testsuite/corba/portableserver/Makefile.local testsuite/corba/portableserver/echo-impl.adb testsuite/corba/portableserver/echo-impl.ads testsuite/corba/portableserver/echo.idl testsuite/corba/portableserver/local.gpr testsuite/corba/portableserver/test-impl.adb testsuite/corba/portableserver/test-impl.ads testsuite/corba/portableserver/test.idl testsuite/corba/portableserver/test000.adb testsuite/corba/portableserver/test000_setup.adb testsuite/corba/portableserver/test000_setup.ads testsuite/corba/portableserver/test001.adb testsuite/corba/portableserver/test002.adb testsuite/corba/portableserver/test_adapteractivator.adb testsuite/corba/portableserver/test_adapteractivator.ads testsuite/corba/portableserver/test_globals.ads testsuite/corba/portableserver/test_job.adb testsuite/corba/portableserver/test_job.ads testsuite/corba/portableserver/test_mypoa.adb testsuite/corba/portableserver/test_mypoa.ads testsuite/corba/portableserver/test_nullactivator-impl.adb testsuite/corba/portableserver/test_nullactivator-impl.ads testsuite/corba/portableserver/test_servantactivator.adb testsuite/corba/portableserver/test_servantactivator.ads testsuite/corba/portableserver/test_simpleactivator-impl.adb testsuite/corba/portableserver/test_simpleactivator-impl.ads testsuite/corba/rtcorba/rtcurrent/Makefile.local testsuite/corba/rtcorba/rtcurrent/local.gpr testsuite/corba/rtcorba/rtcurrent/rtcurrent.adb testsuite/corba/rtcorba/rtorb/Makefile.local testsuite/corba/rtcorba/rtorb/echo-impl.adb testsuite/corba/rtcorba/rtorb/echo-impl.ads testsuite/corba/rtcorba/rtorb/echo.idl testsuite/corba/rtcorba/rtorb/local.gpr testsuite/corba/rtcorba/rtorb/test000.adb testsuite/corba/rtcorba/rtpoa/Makefile.local testsuite/corba/rtcorba/rtpoa/echo-impl.adb testsuite/corba/rtcorba/rtpoa/echo-impl.ads testsuite/corba/rtcorba/rtpoa/echo.idl testsuite/corba/rtcorba/rtpoa/local.gpr testsuite/corba/rtcorba/rtpoa/test000.adb testsuite/corba/shutdown/Makefile.local testsuite/corba/shutdown/local.gpr testsuite/corba/shutdown/test000_client.adb testsuite/corba/shutdown/test001_client.adb testsuite/corba/shutdown/test_client.adb testsuite/corba/shutdown/test_interface-impl.adb testsuite/corba/shutdown/test_interface-impl.ads testsuite/corba/shutdown/test_interface.idl testsuite/core/any/Makefile.local testsuite/core/any/local.gpr testsuite/core/any/test000.adb testsuite/core/chained_lists/Makefile.local testsuite/core/chained_lists/local.gpr testsuite/core/chained_lists/test000.adb testsuite/core/dynamic_dict/Makefile.local testsuite/core/dynamic_dict/local.gpr testsuite/core/dynamic_dict/test000.adb testsuite/core/fixed_point/Makefile.local testsuite/core/fixed_point/local.gpr testsuite/core/fixed_point/test000.adb testsuite/core/initialization/Makefile.local testsuite/core/initialization/local.gpr testsuite/core/initialization/test000.adb testsuite/core/initialization/test001.adb testsuite/core/initialization/test002.adb testsuite/core/initialization/test003.adb testsuite/core/initialization/test004.adb testsuite/core/naming/Makefile.local testsuite/core/naming/local.gpr testsuite/core/naming/test000.adb testsuite/core/obj_adapters/Makefile.local testsuite/core/obj_adapters/local.gpr testsuite/core/obj_adapters/test000.adb testsuite/core/obj_adapters/test001.adb testsuite/core/obj_adapters/test_common.adb testsuite/core/obj_adapters/test_common.ads testsuite/core/obj_adapters/test_servant.adb testsuite/core/obj_adapters/test_servant.ads testsuite/core/poa/Makefile.local testsuite/core/poa/local.gpr testsuite/core/poa/test000.adb testsuite/core/poa/test_servant.adb testsuite/core/poa/test_servant.ads testsuite/core/random/Makefile.local testsuite/core/random/local.gpr testsuite/core/random/test000.adb testsuite/core/sync_policies/Makefile.local testsuite/core/sync_policies/client.adb testsuite/core/sync_policies/local.gpr testsuite/core/sync_policies/ping_object.adb testsuite/core/sync_policies/ping_object.ads testsuite/core/sync_policies/server_common.adb testsuite/core/sync_policies/server_common.ads testsuite/core/sync_policies/server_no_tasking.adb testsuite/core/tasking/Makefile.local testsuite/core/tasking/local.gpr testsuite/core/tasking/ravenscar_setup.adb testsuite/core/tasking/ravenscar_setup.ads testsuite/core/tasking/test000.adb testsuite/core/tasking/test000_common.adb testsuite/core/tasking/test000_common.ads testsuite/core/tasking/test000r.adb testsuite/core/tasking/test001.adb testsuite/core/tasking/test001_common.adb testsuite/core/tasking/test001_common.ads testsuite/core/tasking/test002.adb testsuite/core/tasking/test002_common.adb testsuite/core/tasking/test002_common.ads testsuite/core/tasking/test003.adb testsuite/core/tasking/test003_common.adb testsuite/core/tasking/test003_common.ads testsuite/core/uri_encoding/Makefile.local testsuite/core/uri_encoding/local.gpr testsuite/core/uri_encoding/test000.adb testsuite/idls/MANIFEST testsuite/idls/Makefile.ada testsuite/idls/README testsuite/idls/abstract001/tin.idl testsuite/idls/ada0009/name_clashing.idl testsuite/idls/ada0010/tin.idl testsuite/idls/ada0011/tin.idl testsuite/idls/ada0012/tin.idl testsuite/idls/ada0013/tin.idl testsuite/idls/ada0014/tin.idl testsuite/idls/ada0015/tin.idl testsuite/idls/ada0016/tin.idl testsuite/idls/ada0017/tin.idl testsuite/idls/ada0018/tin.idl testsuite/idls/ada0019/tin.idl testsuite/idls/ada0020/tin.idl testsuite/idls/ada0021/tin.idl testsuite/idls/ada0022/tin.idl testsuite/idls/aif_b01/test.out testsuite/idls/aif_b01/tin.idl testsuite/idls/aif_p01/test.out testsuite/idls/aif_p01/tin.idl testsuite/idls/anon_types001/tin.idl testsuite/idls/attr001/tin.idl testsuite/idls/autotest.sh testsuite/idls/avt_b01/test.out testsuite/idls/avt_b01/tin.idl testsuite/idls/avt_p01/test.out testsuite/idls/avt_p01/tin.idl testsuite/idls/chicken-egg/chicken.idl testsuite/idls/chicken-egg/egg.idl testsuite/idls/circular/test_array_1.idl testsuite/idls/circular/test_array_11.idl testsuite/idls/circular/test_array_2.idl testsuite/idls/circular/test_exception_1.idl testsuite/idls/circular/test_exception_2.idl testsuite/idls/circular/test_sequence_1.idl testsuite/idls/circular/test_sequence_2.idl testsuite/idls/circular/test_struct_1.idl testsuite/idls/circular/test_struct_2.idl testsuite/idls/circular/test_typedef_1.idl testsuite/idls/circular/test_typedef_2.idl testsuite/idls/cmp-words testsuite/idls/compile_files.sh testsuite/idls/corba_idl/CORBA_Context.idl testsuite/idls/corba_idl/CORBA_Current.idl testsuite/idls/corba_idl/CORBA_DomainManager.idl testsuite/idls/corba_idl/CORBA_InterfaceRepository.idl testsuite/idls/corba_idl/CORBA_NVList.idl testsuite/idls/corba_idl/CORBA_ORB.idl testsuite/idls/corba_idl/CORBA_ORB_init.idl testsuite/idls/corba_idl/CORBA_Object.idl testsuite/idls/corba_idl/CORBA_Policy.idl testsuite/idls/corba_idl/CORBA_Request.idl testsuite/idls/corba_idl/CORBA_ServerRequest.idl testsuite/idls/corba_idl/CORBA_StandardExceptions.idl testsuite/idls/corba_idl/CORBA_Stream.idl testsuite/idls/corba_idl/CORBA_TypeCode.idl testsuite/idls/corba_idl/CORBA_ValueBase.idl testsuite/idls/corba_idl/orb.idl testsuite/idls/echo/Makefile testsuite/idls/echo/client.adb testsuite/idls/echo/echo-impl.adb testsuite/idls/echo/echo-impl.ads testsuite/idls/echo/echo.idl testsuite/idls/echo/server.adb testsuite/idls/expansion01/expansion.idl testsuite/idls/expansion02/expansion.idl testsuite/idls/expansion03/expansion.idl testsuite/idls/forward01/forward.idl testsuite/idls/forward02/forward.idl testsuite/idls/forward03/forward.idl testsuite/idls/harness/Makefile testsuite/idls/harness/client.adb testsuite/idls/harness/client_common.adb testsuite/idls/harness/client_common.ads testsuite/idls/harness/harness-impl.adb testsuite/idls/harness/harness-impl.ads testsuite/idls/harness/harness.idl testsuite/idls/harness/server_common.adb testsuite/idls/harness/server_common.ads testsuite/idls/harness/server_no_tasking.adb testsuite/idls/harness/server_no_tasking2.adb testsuite/idls/harness/server_thread_per_request.adb testsuite/idls/harness/server_thread_per_session.adb testsuite/idls/harness/server_thread_pool.adb testsuite/idls/harness/server_thread_pool_hahs.adb testsuite/idls/harness/server_thread_pool_lf.adb testsuite/idls/header-sort testsuite/idls/iac-idl testsuite/idls/iac-types testsuite/idls/iac001/test.out testsuite/idls/iac001/tin.idl testsuite/idls/iac002/tin.idl testsuite/idls/iac003/test.out testsuite/idls/iac003/tin.idl testsuite/idls/iac004/test.out testsuite/idls/iac004/tin.idl testsuite/idls/iac005/t.idl testsuite/idls/iac005/test.out testsuite/idls/iac005/tin.idl testsuite/idls/iac006/test.out testsuite/idls/iac006/tin.idl testsuite/idls/iac007/tin.idl testsuite/idls/idl02030/test.out testsuite/idls/idl02030/tin.idl testsuite/idls/idl02031/test.out testsuite/idls/idl02031/tin.idl testsuite/idls/idl02034/test.out testsuite/idls/idl02034/tin.idl testsuite/idls/idl07040/test.out testsuite/idls/idl07040/tin.idl testsuite/idls/idl07051/test.out testsuite/idls/idl07051/tin.idl testsuite/idls/idl07052/test.out testsuite/idls/idl07052/tin.idl testsuite/idls/idl07053/test.out testsuite/idls/idl07053/tin.idl testsuite/idls/idl15001/test.out testsuite/idls/idl15001/tin.idl testsuite/idls/idl15011/test.out testsuite/idls/idl15011/tin.idl testsuite/idls/idl15012/test.out testsuite/idls/idl15012/tin.idl testsuite/idls/idl15021/test.out testsuite/idls/idl15021/tin.idl testsuite/idls/idl15022/test.out testsuite/idls/idl15022/tin.idl testsuite/idls/idl15023/test.out testsuite/idls/idl15023/tin.idl testsuite/idls/idl15024/test.out testsuite/idls/idl15024/tin.idl testsuite/idls/idl15025/test.out testsuite/idls/idl15025/tin.idl testsuite/idls/idl15031/test.out testsuite/idls/idl15031/tin.idl testsuite/idls/idl15032/test.out testsuite/idls/idl15032/tin.idl testsuite/idls/idl15033/test.out testsuite/idls/idl15033/tin.idl testsuite/idls/idl15034/test.out testsuite/idls/idl15034/tin.idl testsuite/idls/idlac000/tin.idl testsuite/idls/idlac001/tin.idl testsuite/idls/idlac002/tin.idl testsuite/idls/idlac003/tin.idl testsuite/idls/idlac004/tin.idl testsuite/idls/import001/int1.idl testsuite/idls/import001/int2.idl testsuite/idls/import001/int3.idl testsuite/idls/inherit001/tin.idl testsuite/idls/inherit002/tin.idl testsuite/idls/inherit003/tin.idl testsuite/idls/inherit004/tin.idl testsuite/idls/inherit005/tin.idl testsuite/idls/ir001/tin.idl testsuite/idls/list_types.sh testsuite/idls/local/local1.idl testsuite/idls/local/local2.idl testsuite/idls/local/local3.idl testsuite/idls/local/local4.idl testsuite/idls/local/local5.idl testsuite/idls/local001/tin.idl testsuite/idls/local002/tin.idl testsuite/idls/local003/tin.idl testsuite/idls/max_values/tin.idl testsuite/idls/parse_file.sh testsuite/idls/pp-idl testsuite/idls/reserved_words/tin.idl testsuite/idls/run-test.sh testsuite/idls/sequences01/test15.idl testsuite/idls/test001/test.out testsuite/idls/test001/tin.idl testsuite/idls/test002/test.out testsuite/idls/test002/tin.idl testsuite/idls/test003/test.out testsuite/idls/test003/tin.idl testsuite/idls/test004/test.out testsuite/idls/test004/tin.idl testsuite/idls/test005/test.out testsuite/idls/test005/tin.idl testsuite/idls/test006/test.out testsuite/idls/test006/tin.idl testsuite/idls/test007/test.out testsuite/idls/test007/tin.idl testsuite/idls/test008/test.out testsuite/idls/test008/tin.idl testsuite/idls/test009/test.out testsuite/idls/test009/tin.idl testsuite/idls/test010/test.out testsuite/idls/test010/tin.idl testsuite/idls/test011/test.out testsuite/idls/test011/tin.idl testsuite/idls/test012/test.out testsuite/idls/test012/tin.idl testsuite/idls/test013/test.out testsuite/idls/test013/tin.idl testsuite/idls/test014/test.out testsuite/idls/test014/tin.idl testsuite/idls/test015/test.out testsuite/idls/test015/tin.idl testsuite/idls/test016/test.out testsuite/idls/test016/tin.idl testsuite/idls/test017/test.out testsuite/idls/test017/tin.idl testsuite/idls/test018/test.out testsuite/idls/test018/tin.idl testsuite/idls/test019/test.out testsuite/idls/test019/tin.idl testsuite/idls/test020/test.out testsuite/idls/test020/tin.idl testsuite/idls/test021/test.out testsuite/idls/test021/tin.idl testsuite/idls/test022/test.out testsuite/idls/test022/tin.idl testsuite/idls/test023/test.out testsuite/idls/test023/tin.idl testsuite/idls/test024/test.out testsuite/idls/test024/tin.idl testsuite/idls/test025/test.out testsuite/idls/test025/tin.idl testsuite/idls/test026/test.out testsuite/idls/test026/tin.idl testsuite/idls/test027/test.out testsuite/idls/test027/tin.idl testsuite/idls/test028/test.out testsuite/idls/test028/tin.idl testsuite/idls/test029/test.out testsuite/idls/test029/tin.idl testsuite/idls/test030/test.out testsuite/idls/test030/tin.idl testsuite/idls/test031/test.out testsuite/idls/test031/tin.idl testsuite/idls/test032/test.out testsuite/idls/test032/tin.idl testsuite/idls/test033/test.out testsuite/idls/test033/tin.idl testsuite/idls/test034/test.out testsuite/idls/test034/tin.idl testsuite/idls/test035/test.out testsuite/idls/test035/tin.idl testsuite/idls/test036/test.out testsuite/idls/test036/tin.idl testsuite/idls/test037/test.out testsuite/idls/test037/tin.idl testsuite/idls/test038/test.out testsuite/idls/test038/tin.idl testsuite/idls/test039/test.out testsuite/idls/test039/tin.idl testsuite/idls/test040/test.out testsuite/idls/test040/tin.idl testsuite/idls/test041/test.out testsuite/idls/test041/tin.idl testsuite/idls/test042/test.out testsuite/idls/test042/tin.idl testsuite/idls/test043/test.out testsuite/idls/test043/tin.idl testsuite/idls/test044/test.out testsuite/idls/test044/tin.idl testsuite/idls/test045/test.out testsuite/idls/test045/tin.idl testsuite/idls/test046/test.out testsuite/idls/test046/tin.idl testsuite/idls/test047/test.out testsuite/idls/test047/tin.idl testsuite/idls/test048/test.out testsuite/idls/test048/tin.idl testsuite/idls/test049/test.out testsuite/idls/test049/tin.idl testsuite/idls/test050/test.out testsuite/idls/test050/tin.idl testsuite/idls/test051/test.out testsuite/idls/test051/tin.idl testsuite/idls/test052/test.out testsuite/idls/test052/tin.idl testsuite/idls/test053/test.out testsuite/idls/test053/tin.idl testsuite/idls/test054/test.out testsuite/idls/test054/tin.idl testsuite/idls/test055/test.out testsuite/idls/test055/tin.idl testsuite/idls/test_errors.sh testsuite/idls/types001/test.out testsuite/idls/types001/tin.idl testsuite/idls/types002/test.out testsuite/idls/types002/tin.idl testsuite/idls/types003/test.out testsuite/idls/types003/tin.idl testsuite/idls/types004/test.out testsuite/idls/types004/tin.idl testsuite/idls/types005/test.out testsuite/idls/types005/tin.idl testsuite/idls/types006/test.out testsuite/idls/types006/tin.idl testsuite/idls/types007/test.out testsuite/idls/types007/tin.idl testsuite/idls/types008/test.out testsuite/idls/types008/tin.idl testsuite/idls/types009/test.out testsuite/idls/types009/tin.idl testsuite/idls/types010/test.out testsuite/idls/types010/tin.idl testsuite/idls/types011/test.out testsuite/idls/types011/tin.idl testsuite/idls/types012/test.out testsuite/idls/types012/tin.idl testsuite/idls/types013/test.out testsuite/idls/types013/tin.idl testsuite/idls/types014/tan.idl testsuite/idls/types014/test.out testsuite/idls/types014/tin.idl testsuite/idls/va_f01/test.out testsuite/idls/va_f01/tin.idl testsuite/idls/va_f02/test.out testsuite/idls/va_f02/tin.idl testsuite/idls/va_t01/test.out testsuite/idls/va_t01/tin.idl testsuite/idls/va_t02/test.out testsuite/idls/va_t02/tin.idl testsuite/idls/va_t03/test.out testsuite/idls/va_t03/tin.idl testsuite/idls/va_t04/test.out testsuite/idls/va_t04/tin.idl testsuite/idls/vb_b01/test.out testsuite/idls/vb_b01/tin.idl testsuite/idls/vb_d01/test.out testsuite/idls/vb_d01/tin.idl testsuite/idls/vb_d02/test.out testsuite/idls/vb_d02/tin.idl testsuite/idls/vb_d03/test.out testsuite/idls/vb_d03/tin.idl testsuite/idls/vb_d04/test.out testsuite/idls/vb_d04/tin.idl testsuite/idls/vb_d05/test.out testsuite/idls/vb_d05/tin.idl testsuite/idls/vb_e01/test.out testsuite/idls/vb_e01/tin.idl testsuite/idls/vb_p01/test.out testsuite/idls/vb_p01/tin.idl testsuite/idls/vb_p02/test.out testsuite/idls/vb_p02/tin.idl testsuite/idls/vb_p03/test.out testsuite/idls/vb_p03/tin.idl testsuite/idls/vt_b01/test.out testsuite/idls/vt_b01/tin.idl testsuite/idls/vt_e01/test.out testsuite/idls/vt_e01/tin.idl testsuite/idls/vt_i01/test.out testsuite/idls/vt_i01/tin.idl testsuite/idls/vt_m01/test.out testsuite/idls/vt_m01/tin.idl testsuite/idls/vt_m02/test.out testsuite/idls/vt_m02/tin.idl testsuite/idls/vt_o01/test.out testsuite/idls/vt_o01/tin.idl testsuite/idls/vt_p01/test.out testsuite/idls/vt_p01/tin.idl testsuite/idls/vti_avb01/test.out testsuite/idls/vti_avb01/tin.idl testsuite/idls/vti_avb02/test.out testsuite/idls/vti_avb02/tin.idl testsuite/idls/vti_si01/test.out testsuite/idls/vti_si01/tin.idl testsuite/idls/vti_si02/test.out testsuite/idls/vti_si02/tin.idl testsuite/idls/vti_si03/test.out testsuite/idls/vti_si03/tin.idl testsuite/idls/vti_vb01/test.out testsuite/idls/vti_vb01/tin.idl testsuite/ssl-cert.conf testsuite/tests/always_fail/test.opt testsuite/tests/always_fail/test.py testsuite/tests/confs/broken_codesets.conf testsuite/tests/confs/code_sets_000_client.conf testsuite/tests/confs/code_sets_000_server.conf testsuite/tests/confs/giop.conf testsuite/tests/confs/giop_1_0.conf testsuite/tests/confs/giop_1_1.conf testsuite/tests/confs/giop_1_2.conf testsuite/tests/confs/miop.conf testsuite/tests/confs/performance.conf testsuite/tests/confs/soap.conf testsuite/tests/confs/ssliop.conf testsuite/tests/convert_scenario.py testsuite/tests/corba/all_exceptions/CORBA_ALL_EXCEPTIONS_0/test.py testsuite/tests/corba/all_exceptions/CORBA_ALL_EXCEPTIONS_1/test.py testsuite/tests/corba/all_exceptions/CORBA_ALL_EXCEPTIONS_2/test.py testsuite/tests/corba/all_exceptions/CORBA_ALL_EXCEPTIONS_3/test.py testsuite/tests/corba/benchs/CORBA_BENCHS_0/test.py testsuite/tests/corba/code_sets/CODE_SETS_0/test.py testsuite/tests/corba/code_sets/CODE_SETS_1/test.py testsuite/tests/corba/domainmanager/DOMAINMANAGER_0/test.py testsuite/tests/corba/harness/CORBA_HARNESS_0/test.py testsuite/tests/corba/harness/CORBA_HARNESS_1/test.py testsuite/tests/corba/harness/CORBA_HARNESS_2/test.py testsuite/tests/corba/harness/CORBA_HARNESS_3/test.py testsuite/tests/corba/harness/CORBA_HARNESS_5/test.py testsuite/tests/corba/harness/CORBA_HARNESS_6/test.py testsuite/tests/corba/harness/CORBA_HARNESS_7/test.py testsuite/tests/corba/interop/CORBA_INTEROP_0/test.opt testsuite/tests/corba/interop/CORBA_INTEROP_0/test.py testsuite/tests/corba/interop/CORBA_INTEROP_1/test.opt testsuite/tests/corba/interop/CORBA_INTEROP_1/test.py testsuite/tests/corba/interop/CORBA_INTEROP_2/test.opt testsuite/tests/corba/interop/CORBA_INTEROP_2/test.py testsuite/tests/corba/interop/CORBA_INTEROP_3/test.opt testsuite/tests/corba/interop/CORBA_INTEROP_3/test.py testsuite/tests/corba/interop/CORBA_INTEROP_4/test.opt testsuite/tests/corba/interop/CORBA_INTEROP_4/test.py testsuite/tests/corba/interop/CORBA_INTEROP_5/test.opt testsuite/tests/corba/interop/CORBA_INTEROP_5/test.py testsuite/tests/corba/local/LOCAL_0/test.py testsuite/tests/corba/location_forwarding/LOCATION_FORWARDING_0/test.py testsuite/tests/corba/location_forwarding/LOCATION_FORWARDING_1/test.py testsuite/tests/corba/object/OBJECT_0/test.py testsuite/tests/corba/orb_init/ORB_INIT_0/test.py testsuite/tests/corba/performance/CORBA_PERFORMANCE_0/test.opt testsuite/tests/corba/performance/CORBA_PERFORMANCE_0/test.py testsuite/tests/corba/portableinterceptor/CORBA_PORTABLEINTERCEPTOR_0/test.py testsuite/tests/corba/portableinterceptor/CORBA_PORTABLEINTERCEPTOR_1/test.opt testsuite/tests/corba/portableinterceptor/CORBA_PORTABLEINTERCEPTOR_1/test.py testsuite/tests/corba/portableinterceptor/CORBA_PORTABLEINTERCEPTOR_2/test.py testsuite/tests/corba/portableinterceptor/CORBA_PORTABLEINTERCEPTOR_3/test.py testsuite/tests/corba/portableinterceptor/CORBA_PORTABLEINTERCEPTOR_4/test.py testsuite/tests/corba/portableserver/PORTABLESERVER_0/test.py testsuite/tests/corba/portableserver/PORTABLESERVER_1/test.py testsuite/tests/corba/portableserver/PORTABLESERVER_2/test.py testsuite/tests/corba/rtcorba-rtcurrent/RTCURRENT_0/test.py testsuite/tests/corba/rtcorba-rtorb/RTORB_0/test.py testsuite/tests/corba/rtcorba-rtpoa/RTPOA_0/test.py testsuite/tests/corba/shutdown/SHUTDOWN_0/test.py testsuite/tests/corba/shutdown/SHUTDOWN_1/test.opt testsuite/tests/corba/shutdown/SHUTDOWN_1/test.py testsuite/tests/core/chained_lists/CHAINED_LIST_0/test.py testsuite/tests/core/dynamic_dict/DYNAMIC_DICT_0/test.py testsuite/tests/core/fixed_point/FIXED_0/test.py testsuite/tests/core/initialization/INIT_0/test.py testsuite/tests/core/initialization/INIT_1/test.py testsuite/tests/core/initialization/INIT_2/test.py testsuite/tests/core/initialization/INIT_3/test.py testsuite/tests/core/initialization/INIT_4/test.py testsuite/tests/core/obj_adapters/OA_0/test.py testsuite/tests/core/obj_adapters/OA_1/test.py testsuite/tests/core/poa/POA_0/test.py testsuite/tests/core/random/RANDOM_0/test.py testsuite/tests/core/sync_policies/CORE_SYNC_POLICIES_0/test.py testsuite/tests/core/tasking/TASK_0/test.py testsuite/tests/core/tasking/TASK_1/test.py testsuite/tests/core/tasking/TASK_2/test.py testsuite/tests/core/tasking/TASK_3/test.py testsuite/tests/core/uri_encoding/URI_ENCODING_0/test.py testsuite/tests/cos/ir/IR_0/test.py testsuite/tests/cos/naming/NAMING_0/test.py testsuite/tests/cos/time/TIME_0/test.py testsuite/tests/examples/corba-all_functions/ALL_FUNCTIONS_0/test.py testsuite/tests/examples/corba-all_functions/ALL_FUNCTIONS_1/test.opt testsuite/tests/examples/corba-all_functions/ALL_FUNCTIONS_1/test.py testsuite/tests/examples/corba-all_functions/ALL_FUNCTIONS_2/test.opt testsuite/tests/examples/corba-all_functions/ALL_FUNCTIONS_2/test.py testsuite/tests/examples/corba-all_functions/ALL_FUNCTIONS_3/test.opt testsuite/tests/examples/corba-all_functions/ALL_FUNCTIONS_3/test.py testsuite/tests/examples/corba-all_functions/ALL_FUNCTIONS_4/test.py testsuite/tests/examples/corba-all_functions/ALL_FUNCTIONS_5/test.py testsuite/tests/examples/corba-all_functions/ALL_FUNCTIONS_6/test.py testsuite/tests/examples/corba-all_types/ALL_TYPES_0/test.py testsuite/tests/examples/corba-all_types/ALL_TYPES_1/test.opt testsuite/tests/examples/corba-all_types/ALL_TYPES_1/test.py testsuite/tests/examples/corba-all_types/ALL_TYPES_2/test.opt testsuite/tests/examples/corba-all_types/ALL_TYPES_2/test.py testsuite/tests/examples/corba-all_types/ALL_TYPES_3/test.opt testsuite/tests/examples/corba-all_types/ALL_TYPES_3/test.py testsuite/tests/examples/corba-all_types/ALL_TYPES_4/test.opt testsuite/tests/examples/corba-all_types/ALL_TYPES_4/test.py testsuite/tests/examples/corba-all_types/ALL_TYPES_5/test.py testsuite/tests/examples/corba-all_types/ALL_TYPES_6/test.py testsuite/tests/examples/corba-all_types/ALL_TYPES_7/test.py testsuite/tests/examples/corba-echo/ECHO_0/test.py testsuite/tests/examples/corba-echo/ECHO_1/test.py testsuite/tests/examples/corba-echo/ECHO_2/test.py testsuite/tests/examples/corba-echo/ECHO_3/test.py testsuite/tests/examples/corba-echo/ECHO_4/test.py testsuite/tests/examples/corba-echo/ECHO_5/test.py testsuite/tests/examples/corba-echo/ECHO_6/test.py testsuite/tests/examples/corba-echo/ECHO_7/test.py testsuite/tests/examples/corba-random/CORBA_RANDOM_0/test.py testsuite/tests/examples/corba-random/CORBA_RANDOM_1/test.py testsuite/tests/examples/corba-rtcorba-client_propagated/RTCORBA_CLIENT_PROPAGATED_0/test.py testsuite/tests/examples/corba-rtcorba-dhb/RTCORBA_DHB_0/test.opt testsuite/tests/examples/corba-rtcorba-dhb/RTCORBA_DHB_0/test.py testsuite/tests/examples/corba-rtcorba-rtcosscheduling/RTCORBA_RTCOSSCHEDULING_0/test.opt testsuite/tests/examples/corba-rtcorba-rtcosscheduling/RTCORBA_RTCOSSCHEDULING_0/test.py testsuite/tests/examples/corba-rtcorba-server_declared/RTCORBA_SERVER_DECLARED_0/test.py testsuite/tests/examples/corba-rtcorba-server_declared/RTCORBA_SERVER_DECLARED_1/test.py testsuite/tests/examples/corba-secure_echo/CORBA_SECURE_ECHO_0/test.opt testsuite/tests/examples/corba-secure_echo/CORBA_SECURE_ECHO_0/test.py testsuite/tests/examples/corba-secure_echo/CORBA_SECURE_ECHO_1/test.opt testsuite/tests/examples/corba-secure_echo/CORBA_SECURE_ECHO_1/test.py testsuite/tests/examples/corba-secure_echo/CORBA_SECURE_ECHO_2/test.opt testsuite/tests/examples/corba-secure_echo/CORBA_SECURE_ECHO_2/test.py testsuite/tests/examples/corba-send/CORBA_MIOP_0/test.py testsuite/tests/examples/moma/MOMA_0/test.opt testsuite/tests/examples/moma/MOMA_0/test.py testsuite/tests/examples/moma/MOMA_1/test.opt testsuite/tests/examples/moma/MOMA_1/test.py testsuite/tests/examples/polyorb/POLYORB_CORE_0/test.py testsuite/tests/examples/polyorb/POLYORB_CORE_1/test.py testsuite/tests/examples/polyorb/POLYORB_CORE_2/test.py testsuite/tests/examples/polyorb/POLYORB_CORE_3/test.py testsuite/tests/run-test.py testsuite/tests/test_utils.py testsuite/testsuite.py tools/README tools/po_catref/common.adb tools/po_catref/common.ads tools/po_catref/output.adb tools/po_catref/output.ads tools/po_catref/po_catref.adb tools/po_catref/po_catref_setup.adb.in tools/po_catref/po_catref_setup.ads tools/po_catref/polyorb-binding_data-giop-diop-print.adb tools/po_catref/polyorb-binding_data-giop-diop-print.ads tools/po_catref/polyorb-binding_data-giop-iiop-print.adb tools/po_catref/polyorb-binding_data-giop-iiop-print.ads tools/po_catref/polyorb-binding_data-giop-uipmc-print.adb tools/po_catref/polyorb-binding_data-giop-uipmc-print.ads tools/po_catref/polyorb-binding_data-print.adb tools/po_catref/polyorb-binding_data-print.ads tools/po_catref/polyorb-binding_data-soap-print.adb tools/po_catref/polyorb-binding_data-soap-print.ads tools/po_catref/polyorb-binding_data-srp-print.adb tools/po_catref/polyorb-binding_data-srp-print.ads tools/po_catref/polyorb-giop_p-tagged_components-alternate_iiop_address-print.adb tools/po_catref/polyorb-giop_p-tagged_components-alternate_iiop_address-print.ads tools/po_catref/polyorb-giop_p-tagged_components-code_sets-print.adb tools/po_catref/polyorb-giop_p-tagged_components-code_sets-print.ads tools/po_catref/polyorb-giop_p-tagged_components-policies-print.adb tools/po_catref/polyorb-giop_p-tagged_components-policies-print.ads tools/po_catref/polyorb-giop_p-tagged_components-print.adb tools/po_catref/polyorb-giop_p-tagged_components-print.ads tools/po_catref/polyorb-giop_p-tagged_components-ssl_sec_trans-print.adb tools/po_catref/polyorb-giop_p-tagged_components-ssl_sec_trans-print.ads tools/po_cos_naming/ir_ab_names.adb tools/po_cos_naming/po_cos_naming.adb tools/po_cos_naming/po_cos_naming_shell.adb tools/po_createref/po_createref.adb tools/po_createref/po_createref_parse_cmd.adb tools/po_createref/po_createref_parse_cmd.ads tools/po_createref/po_createref_setup.adb.in tools/po_createref/po_createref_setup.ads tools/po_createref/polyorb-binding_data-create.adb tools/po_createref/polyorb-binding_data-create.ads tools/po_createref/polyorb-binding_data-giop-diop-create.adb tools/po_createref/polyorb-binding_data-giop-diop-create.ads tools/po_createref/polyorb-binding_data-giop-iiop-create.adb tools/po_createref/polyorb-binding_data-giop-iiop-create.ads tools/po_createref/polyorb-giop_p-tagged_components-alternate_iiop_address-create.adb tools/po_createref/polyorb-giop_p-tagged_components-alternate_iiop_address-create.ads tools/po_createref/polyorb-giop_p-tagged_components-code_sets-create.adb tools/po_createref/polyorb-giop_p-tagged_components-code_sets-create.ads tools/po_createref/polyorb-giop_p-tagged_components-create.adb tools/po_createref/polyorb-giop_p-tagged_components-create.ads tools/po_createref/polyorb-giop_p-tagged_components-policies-create.adb tools/po_createref/polyorb-giop_p-tagged_components-policies-create.ads tools/po_createref/polyorb-giop_p-tagged_components-ssl_sec_trans-create.adb tools/po_createref/polyorb-giop_p-tagged_components-ssl_sec_trans-create.ads tools/po_dumpir/po_dumpir.adb tools/po_ir/po_ir.adb tools/po_names/po_names.adb polyorb-2.8~20110207.orig/features-250000644000175000017500000000743211750740337016403 0ustar xavierxavier======================================================== PolyORB 2.5 NEW FEATURES LIST Current as of Oct 21, 2008 ======================================================== Copyright (c) 2008, AdaCore This file contains a complete list of new features in version 2.5 of PolyORB. See also file NEWS for various information about this release. An ISO date (YYYY-MM-DD) appears in parentheses after the description line. This date shows the implementation date of the feature. Any 2.5w wavefront subsequent to this date will contain the indicated feature, as will any subsequent releases. NF-25-HA21-023 Static libs installed in PolyORB-specific subdir (2008-10-21) The PolyORB libraries are now installed in $prefix/lib/polyorb/static instead of directly under $prefix/lib to avoid unwanted interactions caused by command line options generated by polyorb-config or the installed PolyORB project files. NF-25-H924-023 Operation names conflict resolution rules (2008-09-24) Additional name conflict resolution rules are now implemented for operation names that conflict with the primitive operations of Ada.Finalization. Controlled (of which CORBA.Object.Ref is a derived type) are now implemented in the PolyORB OMG IDL compiler, IAC. Operation names "Initialize", "Adjust" and "Finalize" are now prefixed with string "IDL_" in generated sources. NF-25-H704-004 Better detection of conflicting middleware setups (2008-07-09) Middleware setups that include more than one ORB tasking policy or more than one ORB controller are now detected at initialization time and cause an exception to be raised instead of silently proceeding with execution of the inconsistent partition. NF-25-H624-006 New IAC command line switch -nocpp (2008-07-09) A new command line switch "-nocpp" is supported by IAC, indicating that the input file has already been preprocessed, and should not be preprocessed again. NF-25-H616-002 IAC generates NOT NULL constraints in impl (2008-06-18) When generating implementation templates, the IDL to Ada compiler, IAC, now generates explicit NOT NULL constraints for the Self formal parameter of primitive operations. This allows the use of subprogram renaming declarations as the bodies of such primitive operations when operating in Ada 2005 mode. NF-25-H521-008 Debug_Policy is now enabled by default (2008-05-21) Configuration pragma Debug_Policy is now set to Check by default in all PolyORB builds, to allow the user to obtain debugging traces under control of the run-time configuration. Two new configure command line switches are provided (--enable-assertion-policy and --enable-debug-policy) which allow the user to override these two policies. NF-25-H424-036 Fast path CDR marshalling (2008-08-11) The CDR module now takes advantage of the fact that some common aggregate types (arrays and sequences of characters, octets and integers) have a memory representation that is identical to the CDR representation to transmit and decode them efficiently. This new feature is enabled by default but can be turned off by setting enable_fast_path to FALSE in the [cdr] section of the PolyORB configuration. NF-25-G726-017 IAC is now the default IDL compiler (2008-05-08) IAC is the new default IDL compiler provided by PolyORB. Its command line interface is compatible with the legacy idlac compiler, making it suitable as a drop-in replacement. IAC also offers a number of new features, including optional generation of minimal perfect hash tables for skeletons, generation of static marshallers for faster handling of remote calls, and the ability to pretty-print IDL files. Detailed documentation of these new features can be found in the PolyORB User's Guide. Note that the legacy idlac compiler is still provided in the PolyORB source tree. polyorb-2.8~20110207.orig/support/0000755000175000017500000000000011750740340016116 5ustar xavierxavierpolyorb-2.8~20110207.orig/support/move-if-change0000755000175000017500000000156011750740340020633 0ustar xavierxavier#!/bin/sh # Copyright (C) 1996 Free Software Foundation, Inc. # # This program is free software; you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation; either version 2 of the License, or # (at your option) any later version. # # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # You should have received a copy of the GNU General Public License # along with this program; if not, write to the Free Software # Foundation, 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. if test -r $2 then if cmp $1 $2 > /dev/null then echo $2 is unchanged rm -f $1 else mv -f $1 $2 fi else mv -f $1 $2 fi polyorb-2.8~20110207.orig/support/ssl.m40000644000175000017500000001000111750740340017151 0ustar xavierxavierAC_DEFUN([AM_WITH_OPENSSL], [AC_ARG_WITH(openssl, AC_HELP_STRING([--with-openssl@<:@=ARG@:>@], [enable SSL support, will check ARG/ssl /usr/local/ssl /usr/lib/ssl /usr/ssl /usr/pkg /usr/local /usr]), [ HAVE_SSL=no save_LIBS="$LIBS" save_CPPFLAGS="$CPPFLAGS" save_LDFLAGS="$LDFLAGS" dnl Libcrypto depends on the dynamic linking API: make sure we have dnl -ldl in LIBS when required. Most systems provide dlopen (), dnl but HP-UX uses shl_load(). LIBS="" AC_SEARCH_LIBS(dlopen, dl, [], [AC_SEARCH_LIBS(shl_load, dl)]) SSL_LIBDL="$LIBS" LIBS="$save_LIBS" dnl Libcrypto also depends on -lsocket -lnsl on Solaris: get them into dnl $LIBS if required (but that's just for the purpose of the test, dnl in real applications this will come from g-soliop.ads). AC_SEARCH_LIBS([gethostbyname], [nsl]) AC_SEARCH_LIBS([socket], [socket]) dnl If ARG is not specified, $withval is "yes", and we do not have any dnl additional user defined path to search. if test "$withval" != "yes"; then ssl_user_dir="$withval" fi # dir="-" corresponds to the default system locations for dir in $ssl_user_dir - /usr/local/ssl /usr/lib/ssl /usr/ssl /usr/pkg /usr/local /usr; do # Set candidate options for this location if test "$dir" != "-"; then SSL_INC="$dir/include" CPPFLAGS="$save_CPPFLAGS -I$SSL_INC" SSL_INC="${SSL_INC}/" LDFLAGS="$save_LDFLAGS -L$dir/lib" SSL_LDFLAGS="$LDFLAGS " else SSL_INC="" LDFLAGS="$save_LDFLAGS" SSL_LDFLAGS="" fi SSL_LDFLAGS="${SSL_LDFLAGS}-lssl -lcrypto ${SSL_LIBDL}" # Note that order is important here (-lssl must come before # -lcrypto), since some undefined symbols in libssl are provided # by libcrypto. # Check whether we see appropriate headers and libraries ssl_fail="no" AC_CHECK_HEADERS([${SSL_INC}openssl/opensslv.h ${SSL_INC}openssl/ssl.h], [], [ssl_fail="yes"]) if test "$ssl_fail" = "no"; then # If headers found, check for valid libcrypto and libssl. # unset ac_cv_XXX to prevent reuse of cached results from a previous # iteration. unset ac_cv_lib_crypto_SSLeay_version AC_CHECK_LIB(crypto, SSLeay_version, [], [ssl_fail="yes"], [$SSL_LIBDL]) unset ac_cv_lib_ssl_SSL_CTX_new AC_CHECK_LIB(ssl, SSL_CTX_new, [], [ssl_fail="yes"], [$SSL_LIBDL]) fi if test "$ssl_fail" = "no"; then if test "$dir" = "-"; then ssldir="default system directory" else ssldir="$dir" fi AC_MSG_NOTICE([OpenSSL found in $ssldir]) CPPFLAGS="$CPPFLAGS -DHAVE_SSL" # Special case for RedHat Linux 9 if test -f /usr/kerberos/include/krb5.h; then CPPFLAGS="-I/usr/kerberos/include/ ${CPPFLAGS}" fi HAVE_SSL=yes break; else CPPFLAGS="$save_CPPFLAGS" unset SSL_LDFLAGS fi done LIBS="$save_LIBS" LDFLAGS="$save_LDFLAGS" AC_MSG_CHECKING(if OpenSSL is available) AC_MSG_RESULT($HAVE_SSL) if test x$HAVE_SSL != xyes; then NO_SSL="-- " fi ], [ NO_SSL="-- " ]) # Convert the space-separated SSL_LDFLAGS into a sequence of string literals # concatenated with ASCII.NUL separators, which is what prama Linker_Options # expects. set_linker_options() { while test @S|@# -gt 0; do SSL_LINKER_OPTIONS="${SSL_LINKER_OPTIONS}\"@S|@1\"" if test @S|@# -gt 1; then SSL_LINKER_OPTIONS="${SSL_LINKER_OPTIONS} & ASCII.NUL & " fi shift done if test -z "${SSL_LINKER_OPTIONS}"; then NO_SSL_LINKER_OPTIONS="-- " fi } set_linker_options $SSL_LDFLAGS AC_SUBST(SSL_LINKER_OPTIONS) AC_SUBST(NO_SSL_LINKER_OPTIONS) AC_SUBST(HAVE_SSL) AC_SUBST(NO_SSL) ])dnl polyorb-2.8~20110207.orig/support/gentexifile0000755000175000017500000000164711750740340020357 0ustar xavierxavier#!/bin/sh if [ $# = 0 ]; then echo "Usage: $0 " exit 0 fi SOURCE=$1 case ${SOURCE} in *.idl) SEDFILE=idl.sed;; *.ad[bs]) SEDFILE=ada.sed;; *.cfg) SEDFILE=cfg.sed;; *) echo "Cannot translate file"; exit 1;; esac TARGET=${SOURCE}.texi TMPTAR=${TARGET}.tmp ${AWK:-awk} 'BEGIN{out=1}$1=="end"&&substr($0,1,1)=="e"{out=1}out==1{print}$1=="private"&&out==1{out=0; print " -- implementation removed"}' ${SOURCE} > genout echo "@smallexample" >${TMPTAR} if [ $# = 1 ]; then echo "@cartouche" >>${TMPTAR} echo "@group" >>${TMPTAR} fi echo "" >>${TMPTAR} ${SED:-sed} -f ${SEDFILE} genout >>${TMPTAR} echo "" >>${TMPTAR} if [ $# = 1 ]; then echo "@end group" >>${TMPTAR} echo "@end cartouche" >>${TMPTAR} fi echo "@end smallexample" >>${TMPTAR} cat ${TMPTAR} | tr -d '\r' > ${TARGET} rm -f ${TMPTAR} genout polyorb-2.8~20110207.orig/support/ada.m40000644000175000017500000004113211750740340017106 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- C H E C K -- -- -- -- Copyright (C) 2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ dnl Ada compiler handling dnl $Id: ada.m4 168980 2011-01-11 12:10:10Z quinot $ dnl Contributed by Samuel Tardieu dnl Usage: AM_PROG_ADA dnl Look for an Ada compiler (ADA environment variable, then gcc, then $CC) AC_DEFUN([AM_PROG_ADA], [AC_BEFORE([$0], [AM_TRY_ADA]) AC_REQUIRE([AC_PROG_CC]) AC_CHECK_PROGS(ADA, gnatgcc adagcc gcc) if test -z "$ADA"; then AC_MSG_RESULT([ Tentatively using $CC as an Ada compiler]) ADA="$CC" fi]) dnl Usage: AM_PROG_GNATCHOP dnl Look for GNATCHOP program AC_DEFUN([AM_PROG_GNATCHOP], [AC_CHECK_PROG(GNATCHOP, gnatchop, gnatchop)]) dnl Usage: AM_PROG_GNATLS dnl Look for GNATLS program AC_DEFUN([AM_PROG_GNATLS], [AC_CHECK_PROG(GNATLS, gnatls, gnatls)]) dnl Usage: AM_TRY_ADA(gnatmake, filename, content, pragmas, success, failure) dnl Compile, bind and link an Ada program and report its success or failure AC_DEFUN([AM_TRY_ADA], [mkdir conftest cat > conftest/src.ada < conftest/gnat.adc < /dev/null 2>../conftest.out]) then : Success $5 else : Failure $6 fi rm -fr conftest*]) dnl Usage: AM_TRY_ADA_CONFPRAGMA(pragma, success, failure) dnl Check whether a given configuration pragma is supported. AC_DEFUN([AM_TRY_ADA_CONFPRAGMA], [AC_REQUIRE([AM_CROSS_PROG_GNATMAKE]) AM_TRY_ADA($GNATMAKE_FOR_TARGET $ADAFLAGS_FOR_TARGET,[check.adb], [procedure Check is begin null; end Check;],[$1],[$2],[$3])]) dnl Usage: AM_TRY_ADA_COMPILER_SWITCH(switch, success, failure) dnl Check whether a given compiler command line switch is supported. AC_DEFUN([AM_TRY_ADA_COMPILER_SWITCH], [AC_REQUIRE([AM_CROSS_PROG_GNATMAKE]) AM_TRY_ADA([$GNATMAKE_FOR_TARGET $ADAFLAGS_FOR_TARGET $1],[check.adb], [procedure Check is begin null; end Check;],[],[$2],[$3])]) dnl Usage: AM_PROG_WORKING_ADA dnl Try to compile a simple Ada program to test the compiler installation dnl (especially the standard libraries such as Ada.Text_IO) AC_DEFUN([AM_PROG_WORKING_ADA], [AC_REQUIRE([AM_PROG_ADA]) AC_REQUIRE([AM_PROG_GNATCHOP]) AC_REQUIRE([AM_PROG_GNATLS]) AC_MSG_CHECKING([if the$crossflagmsg Ada compiler works]) AM_TRY_ADA([$ADA -c],[check.adb], [with Ada.Text_IO; procedure Check is begin null; end Check; ], [], [AC_MSG_RESULT(yes)], [AC_MSG_RESULT(no) AC_MSG_ERROR([Ada compiler is not working])])]) dnl Usage: AM_ADA_PREREQ(date, version) dnl Check that GNAT is at least as recent as date (YYMMDD) AC_DEFUN([AM_ADA_PREREQ], [AC_REQUIRE([AM_PROG_WORKING_ADA]) AC_CHECK_PROG(SED, sed, sed) AC_MSG_CHECKING([if the Ada compiler is recent enough]) am_gnatls_date=`$GNATLS -v | $SED -ne 's/^GNATLS .*(\(.*\)).*$/\1/p'` if test "$1" -le "$am_gnatls_date"; then AC_MSG_RESULT(yes) else AC_MSG_RESULT(no) am_gnatls_version=`$GNATLS -v | $SED -ne 's/^GNATLS \(.*\) (.*.*$/\1/p'` AC_MSG_ERROR([Please get a version of GNAT no older than [$2 ($1)] (it looks like you only have GNAT [$am_gnatls_version ($am_gnatls_date)])]) fi]) dnl Usage: AM_CROSS_PROG_ADA dnl Look for an Ada compiler for the target (same as the host one if host and dnl target are equal) AC_DEFUN([AM_CROSS_PROG_ADA], [AC_BEFORE([$0], [AM_TRY_CROSS_ADA]) AC_REQUIRE([AM_PROG_WORKING_ADA]) if test $host = $target; then ADA_FOR_TARGET=$ADA AC_SUBST(ADA_FOR_TARGET) else AC_CHECK_PROGS(ADA_FOR_TARGET, [$target_alias-$ADA $target-$ADA]) fi ]) dnl Usage: AM_CROSS_PROG_WORKING_ADA dnl Try to use Ada compiler for the target if it is different from the host AC_DEFUN([AM_CROSS_PROG_WORKING_ADA], [AC_REQUIRE([AM_CROSS_PROG_ADA]) if test $host != $target; then OLDADA=$ADA ADA=$ADA_FOR_TARGET crossflagmsg=" cross" AM_PROG_WORKING_ADA crossflagmsg="" ADA=$OLDADA fi ]) dnl Usage: AM_PROG_GNATMAKE dnl Look for an Ada make AC_DEFUN([AM_PROG_GNATMAKE], [AC_REQUIRE([AC_PROG_CC]) AC_CHECK_PROGS(GNATMAKE, gnatmake)]) dnl Usage: AM_CROSS_PROG_GNATMAKE dnl Look for gnatmake for the target (same as the host one if host and dnl target are equal). Sets GNATMAKE_FOR_TARGET and GNAT_DRIVER_FOR_TARGET. AC_DEFUN([AM_CROSS_PROG_GNATMAKE], [AC_REQUIRE([AM_PROG_WORKING_ADA]) if test $host = $target; then GNATMAKE_FOR_TARGET=$GNATMAKE AC_SUBST(GNATMAKE_FOR_TARGET) else AC_CHECK_PROGS(GNATMAKE_FOR_TARGET, [$target_alias-$GNATMAKE $target-$GNATMAKE]) fi GNAT_DRIVER_FOR_TARGET=`echo $GNATMAKE_FOR_TARGET | sed 's/make$//'` AC_SUBST(GNAT_DRIVER_FOR_TARGET) AC_MSG_CHECKING([whether $GNATMAKE_FOR_TARGET supports -aPdir]) if AC_TRY_COMMAND([gnatmake 2>&1 | grep " -aPdir" > /dev/null]) then HAVE_GNATMAKE_APDIR=yes else HAVE_GNATMAKE_APDIR=no fi AC_MSG_RESULT($HAVE_GNATMAKE_APDIR) AC_SUBST(HAVE_GNATMAKE_APDIR) ]) dnl Usage: AM_CROSS_PROG_GNATLS dnl Look for gnatls for the target (same as the host one if host and dnl target are equal) AC_DEFUN([AM_CROSS_PROG_GNATLS], [AC_REQUIRE([AM_PROG_WORKING_ADA]) if test $host = $target; then GNATLS_FOR_TARGET=$GNATLS AC_SUBST(GNATLS_FOR_TARGET) else AC_CHECK_PROGS(GNATLS_FOR_TARGET, [$target_alias-$GNATLS $target-$GNATLS]) fi ]) dnl Usage: AM_CROSS_PROG_CC dnl Look for CC for the target (same as the host one if host and dnl target are equal) AC_DEFUN([AM_CROSS_PROG_CC], [AC_REQUIRE([AC_PROG_CC]) if test $host = $target; then CC_FOR_TARGET=$CC AC_SUBST(CC_FOR_TARGET) else AC_CHECK_PROGS(CC_FOR_TARGET, [$target_alias-$CC $target-$CC]) fi ]) dnl Usage: AM_HAS_GNAT_PROJECT(project) dnl Check whether a given project file is available, and set dnl HAVE_GNAT_PROJECT_ to "yes" or "no" accordingly. AC_DEFUN([AM_HAS_GNAT_PROJECT], [AC_REQUIRE([AM_CROSS_PROG_GNATMAKE]) AC_MSG_CHECKING([whether GNAT project $1.gpr is available]) mkdir conftest cat > conftest/check.gpr < /dev/null 2>../conftest.out]) then HAVE_GNAT_PROJECT_$1=yes else HAVE_GNAT_PROJECT_$1=no fi AC_MSG_RESULT($HAVE_GNAT_PROJECT_$1) AC_SUBST(HAVE_GNAT_PROJECT_$1) rm -fr conftest]) dnl Usage: AM_HAS_GNAT_SOCKETS_COPY dnl Determine whether GNAT.Sockets has a Copy operation. AC_DEFUN([AM_HAS_GNAT_SOCKETS_COPY], [AC_REQUIRE([AM_CROSS_PROG_GNATMAKE]) AC_BEFORE([AM_HAS_GNAT_SOCKETS_COPY]) AC_BEFORE([AM_HAS_GNAT_OS_LIB_CLOSE_WITH_STATUS]) AC_BEFORE([AM_HAS_PRAGMA_PROFILE_RAVENSCAR]) AC_BEFORE([AM_HAS_PRAGMA_PROFILE_WARNINGS]) AC_MSG_CHECKING([whether you have GNAT.Sockets.Copy]) AM_TRY_ADA($GNATMAKE_FOR_TARGET $ADAFLAGS_FOR_TARGET,[check.adb], [with GNAT.Sockets; procedure Check is S1, S2 : GNAT.Sockets.Socket_Set_Type; begin GNAT.Sockets.Copy (S1, S2); end Check; ], [], [AC_MSG_RESULT(yes) MISS_GNAT_SOCKETS_COPY="-- "], [AC_MSG_RESULT(no) HAVE_GNAT_SOCKETS_COPY="-- "]) AC_SUBST(MISS_GNAT_SOCKETS_COPY)dnl AC_SUBST(HAVE_GNAT_SOCKETS_COPY)]) dnl Usage: AM_HAS_GNAT_OS_LIB_CLOSE_WITH_STATUS dnl Determine whether GNAT.OS_Lib has a Close operation with status report. AC_DEFUN([AM_HAS_GNAT_OS_LIB_CLOSE_WITH_STATUS], [AC_REQUIRE([AM_CROSS_PROG_GNATMAKE]) AC_MSG_CHECKING([whether you have GNAT.OS_Lib.Close (FD : File_Descriptor; Status : out Boolean)]) AM_TRY_ADA($GNATMAKE_FOR_TARGET $ADAFLAGS_FOR_TARGET,[check.adb], [with GNAT.OS_Lib; procedure Check is FD : GNAT.OS_Lib.File_Descriptor; Status : boolean; begin GNAT.OS_Lib.Close (FD, Status); end Check; ], [], [AC_MSG_RESULT(yes) MISS_GNAT_OS_LIB_CLOSE_WITH_STATUS="-- "], [AC_MSG_RESULT(no) HAVE_GNAT_OS_LIB_CLOSE_WITH_STATUS="-- "]) AC_SUBST(MISS_GNAT_OS_LIB_CLOSE_WITH_STATUS)dnl AC_SUBST(HAVE_GNAT_OS_LIB_CLOSE_WITH_STATUS)]) dnl Usage: AM_HAS_GNAT_PERFECT_HASH_GENERATORS dnl Determine whether GNAT.Perfect_Hash_Generators exists AC_DEFUN([AM_HAS_GNAT_PERFECT_HASH_GENERATORS], [AC_REQUIRE([AM_CROSS_PROG_GNATMAKE]) AC_MSG_CHECKING([whether you have GNAT.Perfect_Hash_Generators]) AM_TRY_ADA($GNATMAKE_FOR_TARGET $ADAFLAGS_FOR_TARGET,[check.adb], [with GNAT.Perfect_Hash_Generators; procedure Check is begin null; end Check; ], [], [AC_MSG_RESULT(yes) GNAT_PERFECT_HASH_GENERATORS="GNAT.Perfect_Hash_Generators"], [AC_MSG_RESULT(no) GNAT_PERFECT_HASH_GENERATORS="GNAT.Perfect_Hash.Generators"]) AC_SUBST(GNAT_PERFECT_HASH_GENERATORS)]) dnl Usage: AM_HAS_PRAGMA_PROFILE_RAVENSCAR dnl Test whether pragma Profile (Ravenscar) is supported (if not we use dnl pragma Ravenscar). AC_DEFUN([AM_HAS_PRAGMA_PROFILE_RAVENSCAR], [AC_REQUIRE([AM_CROSS_PROG_GNATMAKE]) AC_MSG_CHECKING([whether pragma Profile (Ravenscar) is supported]) AM_TRY_ADA_CONFPRAGMA([pragma Profile (Ravenscar);], [AC_MSG_RESULT(yes) PRAGMA_PROFILE_RAVENSCAR="pragma Profile (Ravenscar);"], [AC_MSG_RESULT(no) PRAGMA_PROFILE_RAVENSCAR="pragma Ravenscar;"]) AC_SUBST(PRAGMA_PROFILE_RAVENSCAR)]) dnl Usage: AM_HAS_PRAGMA_PROFILE_WARNINGS dnl Test whether pragma Profile_Warnings (Ravenscar) is supported. AC_DEFUN([AM_HAS_PRAGMA_PROFILE_WARNINGS], [AC_REQUIRE([AM_CROSS_PROG_GNATMAKE]) AC_MSG_CHECKING([whether pragma Profile_Warnings (Ravenscar) is supported]) AM_TRY_ADA_CONFPRAGMA([pragma Profile_Warnings (Ravenscar);], [AC_MSG_RESULT(yes) DISABLE_PROFILE_WARNINGS=""], [AC_MSG_RESULT(no) DISABLE_PROFILE_WARNINGS="-- "]) AC_SUBST(DISABLE_PROFILE_WARNINGS)]) dnl Usage: AM_HAS_PRAGMA_SUPPRESS_VALIDITY_CHECK dnl WAG:5.04 dnl Determine whether pragma Suppress (Validity_Check) can be used to dnl disable validity checks. If not, we use pragma Suppress (Range_Check) dnl instead. AC_DEFUN([AM_HAS_PRAGMA_SUPPRESS_VALIDITY_CHECK], [AC_REQUIRE([AM_CROSS_PROG_GNATMAKE]) AC_MSG_CHECKING([whether pragma Suppress (Validity_Check) is supported]) AM_TRY_ADA_CONFPRAGMA([pragma Suppress (Validity_Check);], [AC_MSG_RESULT(yes) SUPPRESS_VALIDITY_USE_VALIDITY="" SUPPRESS_VALIDITY_USE_RANGE="-- "], [AC_MSG_RESULT(no) SUPPRESS_VALIDITY_USE_VALIDITY="-- " SUPPRESS_VALIDITY_USE_RANGE=""]) AC_SUBST(SUPPRESS_VALIDITY_USE_VALIDITY) AC_SUBST(SUPPRESS_VALIDITY_USE_RANGE)]) dnl Usage: AM_HAS_STYLESW_YG dnl Test whether the style checking switch -gnatyg (apply GNAT style checks) dnl is supported. AC_DEFUN([AM_HAS_STYLESW_YG], [AC_REQUIRE([AM_CROSS_PROG_GNATMAKE]) AC_MSG_CHECKING([whether GNAT style checks are available]) AM_TRY_ADA_COMPILER_SWITCH([-gnatyg], [AC_MSG_RESULT(yes) STYLE_SWITCH="-gnatyg"], [AC_MSG_RESULT(no, falling back to -gnaty) STYLE_SWITCH="-gnaty"]) AC_SUBST(STYLE_SWITCH)]) dnl Syntax: AM_HAS_ADA_ATC dnl Determines whether the target environment supports Ada Asynchronous dnl Transfer of Control. AC_DEFUN([AM_HAS_ADA_ATC], [AC_REQUIRE([AM_CROSS_PROG_GNATMAKE]) AC_MSG_CHECKING([whether environment supports ATC]) AM_TRY_ADA($GNATMAKE_FOR_TARGET $ADAFLAGS_FOR_TARGET,[check.adb], [procedure Check is begin select delay 1.0; then abort null; end select; end Check; ], [], [AC_MSG_RESULT(yes) HAVE_ADA_ATC=true], [AC_MSG_RESULT(no) ADA_ATC="-- " HAVE_ADA_ATC=false]) AC_SUBST(ADA_ATC)]) dnl Syntax: AM_HAS_ADA_DYNAMIC_PRIORITIES dnl Determines whether the target environment supports dynamic task priotities AC_DEFUN([AM_HAS_ADA_DYNAMIC_PRIORITIES], [AC_REQUIRE([AM_CROSS_PROG_GNATMAKE]) AC_MSG_CHECKING([whether environment supports dynamic task priorities]) AM_TRY_ADA($GNATMAKE_FOR_TARGET $ADAFLAGS_FOR_TARGET,[check.adb], [with Ada.Dynamic_Priorities; procedure Check is begin null; end Check; ], [], [AC_MSG_RESULT(yes) HAVE_ADA_DYNAMIC_PRIORITIES=true], [AC_MSG_RESULT(no) HAVE_ADA_DYNAMIC_PRIORITIES=false]) AC_SUBST(ADA_DYNAMIC_PRIORITIES) AC_SUBST(HAVE_ADA_DYNAMIC_PRIORITIES)]) dnl Usage: AM_SUPPORT_RPC_ABORTION dnl For GNAT 5 or later with ZCX, we cannot support RPC abortion. In this dbl case, RPC execution may fail even when not aborted. Remove this feature dnl except when user really wants it to be enabled. When we can provide dnl this feature with SJLJ exception model and when the user really wants dnl it, then build PolyORB with SJLJ model being the default. AC_DEFUN([AM_SUPPORT_RPC_ABORTION], [AC_REQUIRE([AM_CROSS_PROG_GNATLS]) AC_REQUIRE([AM_HAS_ADA_ATC]) GNAT_RTS_FLAG=""; am_gnat_major_version=`$GNATLS_FOR_TARGET -v | $SED -ne 's/^GNATLS [[^0-9]]*\(.\).*$/\1/p'` am_system_ads=`$GNATLS_FOR_TARGET -a -s system.ads` am_gnatlib_dir=`dirname $am_system_ads` am_gnatlib_dir=`dirname $am_gnatlib_dir` am_gnat_zcx_by_default=`$SED -ne 's/ZCX_By_Default.*:= *\(.*\);$/\1/p' \ $am_system_ads` if test -z "$am_gnat_zcx_by_default"; then am_gnat_zcx_by_default=False fi if test $am_gnat_major_version -ge "5"; then if test $am_gnat_zcx_by_default = "True"; then if test $SUPPORT_RPC_ABORTION = "True"; then if test -f $am_gnatlib_dir/rts-sjlj/adainclude/system.ads; then GNAT_RTS_FLAG="--RTS=rts-sjlj" am_gnat_zcx_by_default="False" fi else SUPPORT_RPC_ABORTION="False" fi else SUPPORT_RPC_ABORTION="True" fi else SUPPORT_RPC_ABORTION="True" fi if test $am_gnat_zcx_by_default = "True"; then EXCEPTION_MODEL="zcx" else EXCEPTION_MODEL="sjlj" fi ]) dnl Usage: AM_ARG_ENABLE_POLICY(what, default) dnl Allow user to set configuration pragmas Assertion_Policy and Debug_Policy. dnl The provided default value may be overridden by earlier configure.ac dnl macros by setting xxx_POLICY_DEFAULT. define([downcase], [translit([$1], [A-Z], [a-z])]) define([upcase], [translit([$1], [a-z], [A-Z])]) AC_DEFUN([AM_ARG_ENABLE_POLICY], [ define([_argname],downcase($1)[-policy]) define([_varname],upcase($1)[_POLICY]) define([_defname],upcase($1)[_POLICY_DEFAULT]) _varname=${_defname:=$2} AC_ARG_ENABLE(_argname, AS_HELP_STRING([--enable-]_argname[=(Check|Ignore)], [Set ]$1[ policy @<:@default=$2@:>@]), [ case "`echo "${enableval}" | tr A-Z a-z`" in yes|check) _varname=Check ;; no|ignore) _varname=Ignore ;; *) AC_MSG_ERROR("Invalid $1 policy identifier: ${enableval}") ;; esac ]) AC_SUBST(_varname) undefine([_argname]) undefine([_varname]) undefine([_defname]) ]) dnl Usage: AM_HAS_ATOMIC_INCDEC32 dnl Determine whether platform/GNAT supports atomic increment/decrement dnl operations AC_DEFUN([AM_HAS_INTRINSIC_SYNC_COUNTERS], [AC_REQUIRE([AM_CROSS_PROG_GNATMAKE]) AC_MSG_CHECKING([whether platform supports atomic increment/decrement]) AM_TRY_ADA([$GNATMAKE_FOR_TARGET $ADAFLAGS_FOR_TARGET],[check.adb], [ with Interfaces; use Interfaces; procedure Check is function Sync_Add_And_Fetch (Ptr : access Interfaces.Integer_32; Value : Interfaces.Integer_32) return Interfaces.Integer_32; pragma Import (Intrinsic, Sync_Add_And_Fetch, "__sync_add_and_fetch_4"); X : aliased Interfaces.Integer_32; Y : Interfaces.Integer_32 := 0; pragma Volatile (Y); -- On some platforms (e.g. i386), GCC has limited support for -- __sync_add_and_fetch_4 for the case where the result is not used. -- Here we want to test for general availability, so make Y volatile to -- prevent the store operation from being discarded. begin Y := Sync_Add_And_Fetch (X'Access, 1); end Check; ], [], [AC_MSG_RESULT(yes) SYNC_COUNTERS_IMPL="intrinsic"], [AC_MSG_RESULT(no) SYNC_COUNTERS_IMPL="mutex"]) AC_SUBST(SYNC_COUNTERS_IMPL)]) polyorb-2.8~20110207.orig/support/idlcpp.m40000644000175000017500000000456311750740340017643 0ustar xavierxavierdnl IDL preprocessor handling dnl $Id: idlcpp.m4 150773 2009-10-14 08:42:44Z quinot $ dnl Usage: AM_GCC_XIDL dnl Test whether the GNAT IDL preprocessor command line switch is available AC_DEFUN([AM_GCC_XIDL], [AC_REQUIRE([AM_PROG_ADA]) AC_MSG_CHECKING([if GNAT provides an IDL preprocessor]) mkdir conftest echo "interface Foo {};" > conftest/input.idl ac_try="cd conftest && $ADA -E -x idl -o input.I input.idl && cat input.I > /dev/null" if AC_TRY_EVAL(ac_try); then HAVE_GCC_XIDL=yes else HAVE_GCC_XIDL=no fi AC_MSG_RESULT($HAVE_GCC_XIDL) rm -fr conftest]) dnl Usage: AM_PROG_IDLCPP dnl Find an appropriate IDL preprocessor AC_DEFUN([AM_PROG_IDLCPP], [AC_REQUIRE([AM_GCC_XIDL]) AC_MSG_CHECKING([what IDL preprocessor to use]) if test "${IDLCPP+set}" = set; then : IDLCPP set by the user elif test "$HAVE_GCC_XIDL" = yes; then # IDLCPP provided by GNAT gcc driver IDLCPP="$ADA -E -x idl" else # IDLCPP provided by C++ compiler AC_PROG_CXXCPP IDLCPP="$CXXCPP" case "$CXXCPP" in *g++*) if test "${CXXCPPFLAGS}" = ""; then IDLCPPFLAGS="-x c++ -ansi" # Options to use GNU C++ preprocessor as IDL preprocessor # -x c++ force C++ preprocessor mode (even though it cannot be # inferred from filename extension .idl) # -ansi disable GCC-specific behaviour fi ;; esac fi AC_MSG_RESULT([$IDLCPP $IDLCPPFLAGS]) AC_SUBST(IDLCPP) AC_SUBST(IDLCPPFLAGS) ]) dnl Usage: AM_IDLCPP_NEEDS_DOT dnl Check whether it is necessary to add a trailing dot for the C++ dnl preprocessor to create an output file without extension. On Windows, dnl a default extension ".exe" is appended if no trailing dot is present. AC_DEFUN([AM_IDLCPP_NEEDS_DOT], [AC_REQUIRE([AM_PROG_IDLCPP]) AC_MSG_CHECKING([if the IDL preprocessor -o option requires a dot]) mkdir conftest touch conftest/input dnl Note: We test for presence of "output.exe", not absence of "output", dnl becuse as of Cygwin 1.7, if "output.exe" is present and "output" is dnl missing, then shell tools from coreutils append the .exe extension dnl automagically, and make it appear as though "output" was present. ac_try="cd conftest && $IDLCPP $IDLCPPFLAGS -o output input && cat output.exe > /dev/null" if AC_TRY_EVAL(ac_try); then AC_MSG_RESULT(yes) AC_SUBST(IDLCPP_OUTPUT_SUFFIX, ".") else AC_MSG_RESULT(no) AC_SUBST(IDLCPP_OUTPUT_SUFFIX, "") fi rm -fr conftest]) polyorb-2.8~20110207.orig/support/gnatsrc.m40000644000175000017500000000114211750740340020017 0ustar xavierxavierdnl Find GNAT sources dnl $Id: gnatsrc.m4 35880 2004-07-28 12:04:30Z quinot $ AC_DEFUN([AC_GNAT_SOURCE], [ AC_MSG_CHECKING([for GNAT sources]) if test -f gnat/osint.ads; then GNAT_SOURCE=../gnat AC_MSG_RESULT(gnat) elif test -f ada/osint.ads; then GNAT_SOURCE=../ada AC_MSG_RESULT(ada) elif test -f $srcdir/gnat/osint.ads; then GNAT_SOURCE=[\${top_srcdir}/gnat] AC_MSG_RESULT($srcdir/gnat) elif test -f $srcdir/ada/osint.ads; then GNAT_SOURCE=[\${top_srcdir}/ada] AC_MSG_RESULT($srcdir/ada) else AC_MSG_ERROR([no sources found]) fi AC_SUBST(GNAT_SOURCE) ]) polyorb-2.8~20110207.orig/support/gensedfile0000755000175000017500000000065511750740340020157 0ustar xavierxavier#!/bin/sh if [ $# != 2 ]; then echo "Usage: $0 " exit 0 fi SOURCE=$1 TARGET=$2 /bin/rm -f ${TARGET} case ${SOURCE} in *ada*) cat <>${TARGET} /--/s/@/@@/g /--/b EOF ;; *idl*) cat <>${TARGET} s/{/\@{/g s/}/\@}/g EOF ;; esac for k in `cat ${SOURCE}`; do cat <>${TARGET} s/\([^\{\}a-zA-Z0-9_]\)${k}/\1\@b\{${k}\}/g s/^${k}/\@b\{${k}\}/g EOF done polyorb-2.8~20110207.orig/support/run_cpp.ksh0000755000175000017500000000071511750740340020301 0ustar xavierxavier#! /bin/ksh # run_cpp # $Id: run_cpp.ksh 39635 2006-12-18 11:56:48Z quinot $ # This optional wrapper can be used when no C++ preprocessor is available # to fall back on a standard UNIX C preprocessor producing output on # stdout only. while [ $# -gt 0 ]; do case "$1" in -o) shift; redir="> \"$1\""; shift ;; -I) shift; args="$args \"-I$1\""; shift ;; *) args="$args \"$1\""; shift ;; esac done eval "/lib/cpp $args $redir" polyorb-2.8~20110207.orig/support/utils.m40000644000175000017500000000121511750740340017517 0ustar xavierxavierdnl Miscellaneous shell utilities quirks handling dnl $Id: utils.m4 42195 2007-01-31 10:19:28Z quinot $ dnl Usage: AM_PROG_XARGS_I dnl Look for proper variant of xargs command line switch (old GNU dnl findutils wanted -i{}, POSIX and the rest of the world use -I{}) AC_DEFUN([AM_PROG_XARGS_I], [AC_MSG_CHECKING([if xargs supports POSIX -I option]) if AC_TRY_COMMAND(test `echo foo | xargs -I'{}' echo X'{}'X 2> /dev/null` = XfooX); then : POSIXly correct implementation AC_MSG_RESULT([yes]) XARGS_I="xargs -I{}" else : Old GNU findutils AC_MSG_RESULT([no (assuming old GNU findutils variant)]) XARGS_I="xargs -i{}" fi AC_SUBST(XARGS_I) ]) polyorb-2.8~20110207.orig/support/libtool-tag.m40000644000175000017500000000056011750740340020576 0ustar xavierxavierdnl Determine whether libtool supports --tag dnl $Id: libtool-tag.m4 35922 2004-08-04 12:37:52Z quinot $ AC_DEFUN([AC_LIBTOOL_HAS_TAG],[ AC_MSG_CHECKING([whether libtool supports --tag]) if grep "[[-]]-tag" $srcdir/support/ltmain.sh > /dev/null; then AC_MSG_RESULT([yes]) LIBTOOL_TAG=--tag=CC else AC_MSG_RESULT([no]) LIBTOOL_TAG= fi AC_SUBST(LIBTOOL_TAG) ]) polyorb-2.8~20110207.orig/support/mkinstalldirs0000644000175000017500000000121211750740340020715 0ustar xavierxavier#! /bin/sh # mkinstalldirs --- make directory hierarchy # Author: Noah Friedman # Created: 1993-05-16 # Last modified: 1994-03-25 # Public domain errstatus=0 for file in ${1+"$@"} ; do set fnord `echo ":$file" | sed -ne 's/^:\//#/;s/^://;s/\// /g;s/^#/\//;p'` shift pathcomp= for d in ${1+"$@"} ; do pathcomp="$pathcomp$d" case "$pathcomp" in -* ) pathcomp=./$pathcomp ;; esac if test ! -d "$pathcomp"; then echo "mkdir $pathcomp" 1>&2 mkdir "$pathcomp" || errstatus=$? fi pathcomp="$pathcomp/" done done exit $errstatus # mkinstalldirs ends here polyorb-2.8~20110207.orig/support/install-sh0000644000175000017500000001273611750740340020130 0ustar xavierxavier#!/bin/sh # # install - install a program, script, or datafile # This comes from X11R5 (mit/util/scripts/install.sh). # # Copyright 1991 by the Massachusetts Institute of Technology # # Permission to use, copy, modify, distribute, and sell this software and its # documentation for any purpose is hereby granted without fee, provided that # the above copyright notice appear in all copies and that both that # copyright notice and this permission notice appear in supporting # documentation, and that the name of M.I.T. not be used in advertising or # publicity pertaining to distribution of the software without specific, # written prior permission. M.I.T. makes no representations about the # suitability of this software for any purpose. It is provided "as is" # without express or implied warranty. # # Calling this script install-sh is preferred over install.sh, to prevent # `make' implicit rules from creating a file called install from it # when there is no Makefile. # # This script is compatible with the BSD install script, but was written # from scratch. It can only install one file at a time, a restriction # shared with many OS's install programs. # set DOITPROG to echo to test this script # Don't use :- since 4.3BSD and earlier shells don't like it. doit="${DOITPROG-}" # put in absolute paths if you don't have them in your path; or use env. vars. mvprog="${MVPROG-mv}" cpprog="${CPPROG-cp}" chmodprog="${CHMODPROG-chmod}" chownprog="${CHOWNPROG-chown}" chgrpprog="${CHGRPPROG-chgrp}" stripprog="${STRIPPROG-strip}" rmprog="${RMPROG-rm}" mkdirprog="${MKDIRPROG-mkdir}" transformbasename="" transform_arg="" instcmd="$mvprog" chmodcmd="$chmodprog 0755" chowncmd="" chgrpcmd="" stripcmd="" rmcmd="$rmprog -f" mvcmd="$mvprog" src="" dst="" dir_arg="" while [ x"$1" != x ]; do case $1 in -c) instcmd="$cpprog" shift continue;; -d) dir_arg=true shift continue;; -m) chmodcmd="$chmodprog $2" shift shift continue;; -o) chowncmd="$chownprog $2" shift shift continue;; -g) chgrpcmd="$chgrpprog $2" shift shift continue;; -s) stripcmd="$stripprog" shift continue;; -t=*) transformarg=`echo $1 | sed 's/-t=//'` shift continue;; -b=*) transformbasename=`echo $1 | sed 's/-b=//'` shift continue;; *) if [ x"$src" = x ] then src=$1 else # this colon is to work around a 386BSD /bin/sh bug : dst=$1 fi shift continue;; esac done if [ x"$src" = x ] then echo "install: no input file specified" exit 1 else true fi if [ x"$dir_arg" != x ]; then dst=$src src="" if [ -d $dst ]; then instcmd=: chmodcmd="" else instcmd=mkdir fi else # Waiting for this to be detected by the "$instcmd $src $dsttmp" command # might cause directories to be created, which would be especially bad # if $src (and thus $dsttmp) contains '*'. if [ -f $src -o -d $src ] then true else echo "install: $src does not exist" exit 1 fi if [ x"$dst" = x ] then echo "install: no destination specified" exit 1 else true fi # If destination is a directory, append the input filename; if your system # does not like double slashes in filenames, you may need to add some logic if [ -d $dst ] then dst="$dst"/`basename $src` else true fi fi ## this sed command emulates the dirname command dstdir=`echo $dst | sed -e 's,[^/]*$,,;s,/$,,;s,^$,.,'` # Make sure that the destination directory exists. # this part is taken from Noah Friedman's mkinstalldirs script # Skip lots of stat calls in the usual case. if [ ! -d "$dstdir" ]; then defaultIFS=' ' IFS="${IFS-${defaultIFS}}" oIFS="${IFS}" # Some sh's can't handle IFS=/ for some reason. IFS='%' set - `echo ${dstdir} | sed -e 's@/@%@g' -e 's@^%@/@'` IFS="${oIFS}" pathcomp='' while [ $# -ne 0 ] ; do pathcomp="${pathcomp}${1}" shift if [ ! -d "${pathcomp}" ] ; then $mkdirprog "${pathcomp}" else true fi pathcomp="${pathcomp}/" done fi if [ x"$dir_arg" != x ] then $doit $instcmd $dst && if [ x"$chowncmd" != x ]; then $doit $chowncmd $dst; else true ; fi && if [ x"$chgrpcmd" != x ]; then $doit $chgrpcmd $dst; else true ; fi && if [ x"$stripcmd" != x ]; then $doit $stripcmd $dst; else true ; fi && if [ x"$chmodcmd" != x ]; then $doit $chmodcmd $dst; else true ; fi else # If we're going to rename the final executable, determine the name now. if [ x"$transformarg" = x ] then dstfile=`basename $dst` else dstfile=`basename $dst $transformbasename | sed $transformarg`$transformbasename fi # don't allow the sed command to completely eliminate the filename if [ x"$dstfile" = x ] then dstfile=`basename $dst` else true fi # Make a temp file name in the proper directory. dsttmp=$dstdir/#inst.$$# # Move or copy the file name to the temp name $doit $instcmd $src $dsttmp && trap "rm -f ${dsttmp}" 0 && # and set any options; do chmod last to preserve setuid bits # If any of these fail, we abort the whole thing. If we want to # ignore errors from any of these, just make sure not to ignore # errors from the above "$doit $instcmd $src $dsttmp" command. if [ x"$chowncmd" != x ]; then $doit $chowncmd $dsttmp; else true;fi && if [ x"$chgrpcmd" != x ]; then $doit $chgrpcmd $dsttmp; else true;fi && if [ x"$stripcmd" != x ]; then $doit $stripcmd $dsttmp; else true;fi && if [ x"$chmodcmd" != x ]; then $doit $chmodcmd $dsttmp; else true;fi && # Now rename the file to the real destination. $doit $rmcmd -f $dstdir/$dstfile && $doit $mvcmd $dsttmp $dstdir/$dstfile fi && exit 0 polyorb-2.8~20110207.orig/support/missing0000644000175000017500000002403611750740340017517 0ustar xavierxavier#! /bin/sh # Common stub for a few missing GNU programs while installing. # Copyright (C) 1996, 1997, 1999, 2000, 2002 Free Software Foundation, Inc. # Originally by Fran,cois Pinard , 1996. # This program is free software; you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation; either version 2, or (at your option) # any later version. # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # You should have received a copy of the GNU General Public License # along with this program; if not, write to the Free Software # Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA # 02111-1307, USA. # As a special exception to the GNU General Public License, if you # distribute this file as part of a program that contains a # configuration script generated by Autoconf, you may include it under # the same distribution terms that you use for the rest of that program. if test $# -eq 0; then echo 1>&2 "Try \`$0 --help' for more information" exit 1 fi run=: # In the cases where this matters, `missing' is being run in the # srcdir already. if test -f configure.ac; then configure_ac=configure.ac else configure_ac=configure.in fi case "$1" in --run) # Try to run requested program, and just exit if it succeeds. run= shift "$@" && exit 0 ;; esac # If it does not exist, or fails to run (possibly an outdated version), # try to emulate it. case "$1" in -h|--h|--he|--hel|--help) echo "\ $0 [OPTION]... PROGRAM [ARGUMENT]... Handle \`PROGRAM [ARGUMENT]...' for when PROGRAM is missing, or return an error status if there is no known handling for PROGRAM. Options: -h, --help display this help and exit -v, --version output version information and exit --run try to run the given command, and emulate it if it fails Supported PROGRAM values: aclocal touch file \`aclocal.m4' autoconf touch file \`configure' autoheader touch file \`config.h.in' automake touch all \`Makefile.in' files bison create \`y.tab.[ch]', if possible, from existing .[ch] flex create \`lex.yy.c', if possible, from existing .c help2man touch the output file lex create \`lex.yy.c', if possible, from existing .c makeinfo touch the output file tar try tar, gnutar, gtar, then tar without non-portable flags yacc create \`y.tab.[ch]', if possible, from existing .[ch]" ;; -v|--v|--ve|--ver|--vers|--versi|--versio|--version) echo "missing 0.4 - GNU automake" ;; -*) echo 1>&2 "$0: Unknown \`$1' option" echo 1>&2 "Try \`$0 --help' for more information" exit 1 ;; aclocal*) if test -z "$run" && ($1 --version) > /dev/null 2>&1; then # We have it, but it failed. exit 1 fi echo 1>&2 "\ WARNING: \`$1' is missing on your system. You should only need it if you modified \`acinclude.m4' or \`${configure_ac}'. You might want to install the \`Automake' and \`Perl' packages. Grab them from any GNU archive site." touch aclocal.m4 ;; autoconf) if test -z "$run" && ($1 --version) > /dev/null 2>&1; then # We have it, but it failed. exit 1 fi echo 1>&2 "\ WARNING: \`$1' is missing on your system. You should only need it if you modified \`${configure_ac}'. You might want to install the \`Autoconf' and \`GNU m4' packages. Grab them from any GNU archive site." touch configure ;; autoheader) if test -z "$run" && ($1 --version) > /dev/null 2>&1; then # We have it, but it failed. exit 1 fi echo 1>&2 "\ WARNING: \`$1' is missing on your system. You should only need it if you modified \`acconfig.h' or \`${configure_ac}'. You might want to install the \`Autoconf' and \`GNU m4' packages. Grab them from any GNU archive site." files=`sed -n 's/^[ ]*A[CM]_CONFIG_HEADER(\([^)]*\)).*/\1/p' ${configure_ac}` test -z "$files" && files="config.h" touch_files= for f in $files; do case "$f" in *:*) touch_files="$touch_files "`echo "$f" | sed -e 's/^[^:]*://' -e 's/:.*//'`;; *) touch_files="$touch_files $f.in";; esac done touch $touch_files ;; automake*) if test -z "$run" && ($1 --version) > /dev/null 2>&1; then # We have it, but it failed. exit 1 fi echo 1>&2 "\ WARNING: \`$1' is missing on your system. You should only need it if you modified \`Makefile.am', \`acinclude.m4' or \`${configure_ac}'. You might want to install the \`Automake' and \`Perl' packages. Grab them from any GNU archive site." find . -type f -name Makefile.am -print | sed 's/\.am$/.in/' | while read f; do touch "$f"; done ;; autom4te) if test -z "$run" && ($1 --version) > /dev/null 2>&1; then # We have it, but it failed. exit 1 fi echo 1>&2 "\ WARNING: \`$1' is needed, and you do not seem to have it handy on your system. You might have modified some files without having the proper tools for further handling them. You can get \`$1Help2man' as part of \`Autoconf' from any GNU archive site." file=`echo "$*" | sed -n 's/.*--output[ =]*\([^ ]*\).*/\1/p'` test -z "$file" && file=`echo "$*" | sed -n 's/.*-o[ ]*\([^ ]*\).*/\1/p'` if test -f "$file"; then touch $file else test -z "$file" || exec >$file echo "#! /bin/sh" echo "# Created by GNU Automake missing as a replacement of" echo "# $ $@" echo "exit 0" chmod +x $file exit 1 fi ;; bison|yacc) echo 1>&2 "\ WARNING: \`$1' is missing on your system. You should only need it if you modified a \`.y' file. You may need the \`Bison' package in order for those modifications to take effect. You can get \`Bison' from any GNU archive site." rm -f y.tab.c y.tab.h if [ $# -ne 1 ]; then eval LASTARG="\${$#}" case "$LASTARG" in *.y) SRCFILE=`echo "$LASTARG" | sed 's/y$/c/'` if [ -f "$SRCFILE" ]; then cp "$SRCFILE" y.tab.c fi SRCFILE=`echo "$LASTARG" | sed 's/y$/h/'` if [ -f "$SRCFILE" ]; then cp "$SRCFILE" y.tab.h fi ;; esac fi if [ ! -f y.tab.h ]; then echo >y.tab.h fi if [ ! -f y.tab.c ]; then echo 'main() { return 0; }' >y.tab.c fi ;; lex|flex) echo 1>&2 "\ WARNING: \`$1' is missing on your system. You should only need it if you modified a \`.l' file. You may need the \`Flex' package in order for those modifications to take effect. You can get \`Flex' from any GNU archive site." rm -f lex.yy.c if [ $# -ne 1 ]; then eval LASTARG="\${$#}" case "$LASTARG" in *.l) SRCFILE=`echo "$LASTARG" | sed 's/l$/c/'` if [ -f "$SRCFILE" ]; then cp "$SRCFILE" lex.yy.c fi ;; esac fi if [ ! -f lex.yy.c ]; then echo 'main() { return 0; }' >lex.yy.c fi ;; help2man) if test -z "$run" && ($1 --version) > /dev/null 2>&1; then # We have it, but it failed. exit 1 fi echo 1>&2 "\ WARNING: \`$1' is missing on your system. You should only need it if you modified a dependency of a manual page. You may need the \`Help2man' package in order for those modifications to take effect. You can get \`Help2man' from any GNU archive site." file=`echo "$*" | sed -n 's/.*-o \([^ ]*\).*/\1/p'` if test -z "$file"; then file=`echo "$*" | sed -n 's/.*--output=\([^ ]*\).*/\1/p'` fi if [ -f "$file" ]; then touch $file else test -z "$file" || exec >$file echo ".ab help2man is required to generate this page" exit 1 fi ;; makeinfo) if test -z "$run" && (makeinfo --version) > /dev/null 2>&1; then # We have makeinfo, but it failed. exit 1 fi echo 1>&2 "\ WARNING: \`$1' is missing on your system. You should only need it if you modified a \`.texi' or \`.texinfo' file, or any other file indirectly affecting the aspect of the manual. The spurious call might also be the consequence of using a buggy \`make' (AIX, DU, IRIX). You might want to install the \`Texinfo' package or the \`GNU make' package. Grab either from any GNU archive site." file=`echo "$*" | sed -n 's/.*-o \([^ ]*\).*/\1/p'` if test -z "$file"; then file=`echo "$*" | sed 's/.* \([^ ]*\) *$/\1/'` file=`sed -n '/^@setfilename/ { s/.* \([^ ]*\) *$/\1/; p; q; }' $file` fi touch $file ;; tar) shift if test -n "$run"; then echo 1>&2 "ERROR: \`tar' requires --run" exit 1 fi # We have already tried tar in the generic part. # Look for gnutar/gtar before invocation to avoid ugly error # messages. if (gnutar --version > /dev/null 2>&1); then gnutar "$@" && exit 0 fi if (gtar --version > /dev/null 2>&1); then gtar "$@" && exit 0 fi firstarg="$1" if shift; then case "$firstarg" in *o*) firstarg=`echo "$firstarg" | sed s/o//` tar "$firstarg" "$@" && exit 0 ;; esac case "$firstarg" in *h*) firstarg=`echo "$firstarg" | sed s/h//` tar "$firstarg" "$@" && exit 0 ;; esac fi echo 1>&2 "\ WARNING: I can't seem to be able to run \`tar' with the given arguments. You may want to install GNU tar or Free paxutils, or check the command line arguments." exit 1 ;; *) echo 1>&2 "\ WARNING: \`$1' is needed, and you do not seem to have it handy on your system. You might have modified some files without having the proper tools for further handling them. Check the \`README' file, it often tells you about the needed prerequirements for installing this package. You may also peek at any GNU archive site, in case some other package would contain this missing \`$1' program." exit 1 ;; esac exit 0 polyorb-2.8~20110207.orig/support/cleanup-conf-files0000755000175000017500000000026011750740340021514 0ustar xavierxavier#! /bin/sh if [ ! -x ./config.status ]; then echo "config.status not found" 1>&2 exit 1 fi rm -f `./config.status --help 2>&1 | sed -n '/^Configuration files:/{n p q }'` polyorb-2.8~20110207.orig/support/reconfig0000755000175000017500000000541611750740340017646 0ustar xavierxavier#! /bin/sh # Make sure we do not export SHELLOPTS to child processes. Otherwise, they # would inherit the "set -e" below, and those scripts expect to continue on # "errors". We could do "export -n SHELLOPTS", but we don't want to run # configure with SHELLOPTS=igncr, as is often done in Cygwin, because some # versions of autoconf put a hard CR in configure, and igncr ignores that CR. # Better to give an error here. if (export | grep -i shellopts > /dev/null); then echo error: SHELLOPTS environment variable must not be exported echo SHELLOPTS = $SHELLOPTS exit 1 fi DISTRIBUTION_MODE=false # Find a version of awk that supports gsub NAWK=`which nawk 2> /dev/null` if [ -x "${NAWK}" ]; then : nawk found else NAWK=awk fi set -e # Stop on errors. # The -w switch is used when creating the source distribution from the contents # of the repository. Its purpose is to adapt configure.ac for files that are # present in the repository but missing from source packages, and also to tweak # some knobs that are intended to differ between the repository and the source # package. usage() { echo "$0 [-w]" echo " -w distribution mode: adjust MANIFEST and generate configure" echo " for packaged sources (not for building directly from checkout)" exit 1 } while getopts w opt do case "$opt" in w) DISTRIBUTION_MODE=true ;; *) usage ,, esac done if [ -f support/distrib.m4 ]; then echo "Using source distribution data from support/distrib.m4" fi rm -f aclocal.m4 support/libtool.m4 configure echo "Libtoolizing" # If libtoolize advises us to get a particular version of libtool.m4, # copy it locally. libtool_m4=`libtoolize --copy --force | sed -n -e '/You should add the contents of \`\([^'\'']*\)'\''.*$/s//\1/p'` if [ -n "$libtool_m4" ]; then cp $libtool_m4 support/libtool.m4 else touch support/libtool.m4 fi mv support/ltmain.sh support/ltmain.sh.orig sed -e '/xlinker)/,/;;$/s/\$wl/-Xlinker /g' < support/ltmain.sh.orig > support/ltmain.sh rm -f support/ltmain.sh.orig show_step() { echo "Running `$1 --version | head -1`" } show_step aclocal aclocal -I support show_step autoheader autoheader show_step autoconf autoconf show_step automake automake --add-missing --copy echo "Generating IDL tree accessors" (cd compilers/idlac && python make_nodes.py nodes.txt > nodes.ada \ && gnatchop -w nodes.ada && rm -f nodes.ada) echo "Doing the necessary date modifications" for f in \ configure.ac \ aclocal.m4 \ Makefile.in \ configure \ stamp-h.in \ config.h.in do find . -name $f | grep -v '^\./Makefile.in$' | while read ff # The above 'grep' is to avoid touching the Makefile.in in the root # directory, since that's now a source file, rather than being generated from # Makefile.am. do touch $ff done sleep 1 done polyorb-2.8~20110207.orig/support/linker.in0000755000175000017500000000044211750740340017735 0ustar xavierxavier#! /bin/sh # Wrapper for libtool used as linker # @configure_input@ NATIVE_ADA="@ADA@" CROSS_ADA="@ADA_FOR_TARGET@" case "`basename "$0"`" in native-*) ADA="${NATIVE_ADA}" ;; *) ADA="${CROSS_ADA}" ;; esac `dirname $0`/../libtool @LIBTOOL_TAG@ --mode=link $ADA "$@" polyorb-2.8~20110207.orig/support/mkdep0000755000175000017500000000465711750740340017160 0ustar xavierxavier#!/bin/sh # # Compute build dependencies # $Id: mkdep 37766 2006-08-10 15:04:48Z quinot $ # unset LANG LC_ALL LC_COLLATE if [ -x /usr/ucb/echo ]; then ucbecho=/usr/ucb/echo else ucbecho=echo fi srcdir=`cd ${1:-.} && /bin/pwd`; shift builddir=`cd ${1:-.} && /bin/pwd`; shift top_srcdir=`cd ${1:-.} && /bin/pwd`; shift top_builddir=`cd ${1:-.} && /bin/pwd`; shift PREFIXLIST=":" CLINE_genlist="" addprefix() { case "${PREFIXLIST}" in *:${1}:*) ;; *) PREFIXLIST="${PREFIXLIST}${1}:" ;; esac } addprefix "${srcdir}" addprefix "${builddir}" while test $# -ne 0 do case "$1" in -I*) addprefix `cd "${1#-I}" && /bin/pwd` shift ;; -*) shift ;; *) CLINE_genlist="${CLINE_genlist}:${1}" shift ;; esac done PREFIXLIST=${PREFIXLIST#:} PREFIXLIST=${PREFIXLIST%:} expand_dep() { case "${1}" in ${top_srcdir}/*) echo "${1#${top_srcdir}/}" ;; ${top_builddir}/*) echo "${1#${top_builddir}/}" ;; *) ;; esac } GPERF_genlist=":src/soap/polyorb-http_headers.adb:src/soap/polyorb-http_methods.adb" GENCS_genlist=":src/giop/polyorb-giop_p-code_sets-data.ads" genlist=${GPERF_genlist}${GENCS_genlist}${CLINE_genlist}":`sed -n -e '/^AC_OUTPUT/,/^\]/s/[ ]*//p' \ < ${top_srcdir}/configure.ac | grep '.ad[sb]$' | tr ' ' ':'`" makefile=${srcdir}/Makefile.am MKDEP="### DO NOT REMOVE THIS LINE, IT IS USED BY MAKEDEPEND ###" rm -f ${makefile}.bak cp ${makefile} ${makefile}.bak (sed -e "/$MKDEP/,\$d" < ${makefile}.bak echo $MKDEP IFS=":${IFS}" for alifile in `echo *.ali | tr ' ' '\n' | sort`; do echo "Processing ${alifile}..." > /dev/stderr withlist= while read key unit rest; do case "${key}" in D) for dir in `echo ${PREFIXLIST}`; do if [ -f ${dir}/${unit} ]; then withlist="${withlist}:`expand_dep \"${dir}/${unit}\"`" break fi done ;; *) ;; esac done < ${alifile} ${ucbecho} -n "${alifile%.ali}.lo:" withlist="${withlist#:}" echo "${withlist}" | tr ':' ' ' | sort | uniq | while read dep; do case "${genlist}:" in *:${dep}:*) qualified_dep="\$(top_builddir)/${dep}" if [ -n "${dep}" ]; then ${ucbecho} -n " ${qualified_dep#\$(top_builddir)/`expand_dep ${builddir}`/}" fi ;; *) ${ucbecho} -n " \$(top_srcdir)/${dep}" ;; esac done echo "" done ) > ${makefile} polyorb-2.8~20110207.orig/support/adacompiler.in0000644000175000017500000000511411750740340020727 0ustar xavierxavier#! /bin/sh # Wrapper for GNAT # @configure_input@ set -e NATIVE_GNATMAKE="@GNATMAKE@" CROSS_GNATMAKE="@GNATMAKE_FOR_TARGET@" SED="@SED@" GREP="@GREP@" RM="@RM@" case "`basename "$0"`" in native-*) GNATMAKE="${NATIVE_GNATMAKE}" ;; *) GNATMAKE="${CROSS_GNATMAKE}" ;; esac mline="" cline="" while [ $# -gt 1 ]; do case "$1" in *.ad[sb]) src="$1" srcdir=`dirname "$src"` if [ "x$srcdir" = "x" ] then srcdir=. fi mline="${mline}$1 " case $1 in s-*) mline="${mline}-a " ;; esac ;; -I*) include_path="$include_path:`echo $1 | ${SED} -e 's/^-I//'`" mline="$mline$1 " ;; -aI*) mline="$mline$1 " include_path="$include_path:`echo $1 | ${SED} -e 's/^-aI//'`" ;; -aO*|-gnatg|-a) mline="$mline$1 " ;; -o) # Ignore "-o path/file.o" at end of command line for now # (handled elsewhere) ;; *) cline="$cline$1 " ;; esac shift done # Last args are '-o xxx.o'; -o has been eaten up above ofile="$1" add_cfg_pragma_file() { case "${cfg_pragma_arg}" in *-gnatec=$1*) ;; *) cfg_pragma_arg="${cfg_pragma_arg} -gnatec=$1" ;; esac } _IFS="${IFS}" IFS=": " for srcdir in `echo $include_path`; do srcdir=`echo ${srcdir} | ${SED} -e 's,^./,,'` for cfg_pragma_file in ${srcdir}/*.adc; do if [ ! -f "${cfg_pragma_file}" ]; then # Case where no configuration pragmas file exists # in srcdir: cfg_pragma_file still contains the glob # pattern. continue fi if ${GREP} "INCLUDE:" ${cfg_pragma_file} > /dev/null 2>&1; then default_include=false else default_include=true fi pat="EXCLUDE: `basename $src`" if ${GREP} "${pat}" ${cfg_pragma_file} > /dev/null 2>&1; then no_specific_exclude=false else no_specific_exclude=true fi pat="INCLUDE: `basename $src`" if ${GREP} "${pat}" $cfg_pragma_file > /dev/null 2>&1 || (${default_include} && ${no_specific_exclude}) then # If unit included explicitly, or (unit not excluded explicitly, # and file applicability is not specified by explicit inclusion) add_cfg_pragma_file ${cfg_pragma_file} fi done done IFS="${_IFS}" $GNATMAKE -c -u @EXTRA_GNATMAKE_FLAGS@ $mline $newname -cargs $cfg_pragma_arg $cline # gnatmake stores ali and o files in the current directory. Move the # object file to its final destination. case "x`dirname $ofile`" in x.|x) ;; *) mv `basename $ofile` $ofile ;; esac polyorb-2.8~20110207.orig/support/subversion.m40000644000175000017500000000137211750740340020562 0ustar xavierxavierdnl Subversion infrastructure dnl $Id: subversion.m4 145301 2009-06-08 09:56:49Z quinot $ dnl Usage: AM_SUBVERSION dnl Set SVNREVISION from DISTRIB_SVNREVISION if provided by support/distrib.m4. dnl If DISTRIB_SVNREVISION is undefined, assume we are configuring from a dnl Subversion checkout, and use "svn info" to retrieve the values. AC_DEFUN([AM_SUBVERSION],[ ifdef([DISTRIB_SVNREVISION], [SVNREVISION=DISTRIB_SVNREVISION],[ AC_CHECK_PROG([SVN],[svn],[`which svn`]) if ! test -z $SVN; then SVNINFO=`cd ${srcdir} && ${SVN} info .` if test $? = 0; then last_changed_rev=`echo "$SVNINFO" | sed -n "s/^Last Changed Rev: \(.*\)\$/\1/p"` fi fi SVNREVISION=${last_changed_rev:-unknown} ]) AC_SUBST(SVNREVISION) ]) polyorb-2.8~20110207.orig/INSTALL0000644000175000017500000001023611750740337015443 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- Copyright (C) 1999-2007 Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore. -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ This file details the compilation and installation of PolyORB. For more details about build requirements, supported compilers, supported platforms and platform-specific information, please refer to the PolyORB User's Guide. Build instructions ------------------ NOTE: Developers building PolyORB from the version control repository who need to rebuild the configure and Makefile.in files should run the script support/reconfig from within the top-level source dir for this purpose. This should be done after each update from the repository. In addition to the requirements above, they will need autoconf 2.57 or newer, automake 1.6.3 or newer, and libtool 1.5.8 or newer. To install PolyORB, execute: % ./configure [some options] % make % make install This will install files in standard locations. If you want to choose another prefix than /usr/local, give configure a --prefix=whereveryouwant argument. NOTE: you MUST use GNU make (version 3.80 or later) to build PolyORB. Available options for the 'configure' script include: --with-appli-perso="...": application personalities to build Available personalities: CORBA, DSA, MOMA e.g. --with-appli-perso="corba moma" to build both the CORBA and MOMA personalities --with-proto-perso="...": personalities to build Available personalities: GIOP, SOAP, SRP e.g. --with-proto-perso="giop soap" to build both the GIOP and SOAP personalities --with-corba-services="...": CORBA COS services to build Available services: event, ir, naming, notification, time e.g. --with-corba-services="event naming" to build only COS Event and COS Naming. --with-openssl[=ARG]: build SSL support and SSL dependent features, including the IIOP/SSLIOP personality --help: list all options available By default, only the CORBA and GIOP personalities are built, no CORBA Services are built. --enable-shared: build shared libraries. --enable-debug: enable debugging information generation and supplementary runtime checks. The following environment variables can be used to override configure's guess at what compilers to use: CC: the C compiler ADA: the Ada 95 compiler (e.g. gcc, gnatgcc or adagcc) For example, if you have two versions of GNAT installed and available in your PATH, and configure picks the wrong one, you can indicate what compiler should be used with the following syntax: ADA=/path/to/good/compiler/gcc ./configure [options] polyorb-2.8~20110207.orig/NEWS0000644000175000017500000010173211750740337015113 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- Copyright (C) 1999-2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore. -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ * PolyORB 2.8 ============= This release contains the PolyORB generic middleware, and its CORBA and DSA instantiations. In addition to the 2.7 release, it includes: New features ------------ See the features-28 file. Bug fixes --------- A rare race condition might cause PolyORB partitions to perform an incorrect memory access, causing the partition to crash. (K121-014) Implementation template package specs for empty interfaces lacked a pragma Elaborate_Body to make their body legal (the body is necessary to drag the Skel into the closure). (JA27-008) * PolyORB 2.7 (branched on 2010-10-01) ====================================== This release contains the PolyORB generic middleware, and its CORBA and DSA instantiations. In addition to the 2.6 release, it includes: New features ------------ See the features-27 file. Bug fixes --------- Boolean values in composite user data might in some rare cases be incorrectly handled, causing the wrong value to be transmitted, or an application crash. (JB04-017) A range check would fail in PolyORB.CORBA_P.Naming_Tools.Locate for names less than four characters in length. (JA26-018) The iac compiler failed to check the rule that requires IDL keywords to have the correct case (for example, "any" is correct, but "ANY" is wrong). (J921-012) The iac compiler generated illegal Ada for helpers in the case of an enum type called 'Result'. (J701-270) The iac compiler did not handle modules that come in multiple parts correcly. The parts should all be considered part of the same module. (IA01-028) The global termination management circuitry would erroneously terminate the initiator partition when all partitions have deferred termination policy. (J602-015) In some cases, po_gnatdist failed to identify that a partition required re-linking after a source change. (J607-021) The global termination policy in a DSA application might fail to detect application termination if a partition with local termination had been executed and completed. (J524-001) PolyORB failed to execute a shell command specified as a partition's Host attribute. (J521-020) IAC would incorrectly generate redundant perfect hash function packages for interfaces declared in a scope nested within an imported module. (J504-010) A remote call occurring after the target partition of another previous call had been disconnected could cause a hang on the calling side. (J511-002) The -p option of iac is supposed to send the output to standard output, but it was sending part of the output (the perfect hash function) to files. (J503-020) Various minor memory leaks were fixed. (J420-020) An IDL enumeration literal "SYSTEM" would cause a name clash in generated code. (J412-032) A call with a formal parameter of a composite type could cause an erroneous memory access if the caller and callee were on the same partition. (J409-001) The "install" Makefile target would fail to copy po_gnatdist to its proper location on hosts where the system does not provide the install(1) command, and the internal support/install-sh script is used instead. (J309-020) Incoming multicast datagrams received on a MIOP access point were not correctly identified as referring to a local object on Windows. (J312-020) When referring to an enumeration literal in another package, IAC was generating just the literal, whereas an expanded name like Package_Name.Literal is needed. (J210-035) Incorrect casing was used in IAC for the generated stubs and skeletons for attribute access subprograms (_get_ and _set_). This could lead to interoperability issues with conformant 3rd party ORBs. (J126-028) Source units imported from AWS for the SOAP protocol personality have been renamed to avoid clashes in applications mixing PolyORB and AWS. (J105-013) Support for partition attribute Reconnection was missing. (IB12-005) po_gnatdist does not create files anymore outside of the private dsa/ subdirectory. (IC14-034) * PolyORB 2.6 (branched on 2009-10-07) ====================================== This release contains the PolyORB generic middleware, and its CORBA and DSA instantiations. In addition to the 2.5 release, it includes: New features ------------ See the features-26 file. Bug fixes --------- A socket leak occurring when an attempt to establish a TCP connection fails has been fixed. (J106-008) A segmentation fault could occur while unmarshalling a record with a component of a private type. (IC16-046) PROGRAM_ERROR was raised when performing a local call involving IDL union with a switch that do not have an associated member label. (IB25-010) A resource leak was fixed in the idle tasks manager. (IB19-027) A race condition has been fixed in the Half_Sync_Half_Async ORB controller that could cause a segmentation fault during ORB shutdown in some rare cases. (IB19-024) Several unrelated race conditions could cause crashes in the DSA termination process in some timing-dependent scenarios. (IB13-026) po_gnatdist would fail to build a slave partition alone. (IA29-009) IAC would fail to find the output from the C++ preprocessor when running under some recent versions of Cygwin. (IA08-013) Constrained types derived from unconstrained array types were not correctly handled in the DSA applicative personality, causing runtime exceptions when such types were passed in remote calls. (IA06-020) IAC was failing to properly detect an error in case a name that should refer to a type referred to something else. (I629-006) DSA partitions used to start processing remote calls before the local partition ID was set, potentially causing exception messages to not be tagged with the partition ID (if raised before that point). (I529-013) The Ada DSA starter would fail if the complete path of some slave partition contained white space. (I519-025) When building a DSA application, a global configuration pragmas file provided through a user project wasn't taken into account. (I513-015) Building a DSA application in a directory whose complete path include white space was not correctly handled. (I508-017) * PolyORB 2.5 (branched on 2008-11-03) ====================================== This release contains the PolyORB generic middleware, and its CORBA and DSA instantiations. In addition to the 2.4 release, it includes: New features ------------ See the features-25 file. Bug fixes --------- When building a single partition with non-local termination, po_gnatdist would systematically mark the partition as termination initiator, possibly causing a deadlock when terminating the application. (Building all partitions at the same time, which is the default, worked fine.) (HA30-008) Calling a method that has IN or INOUT arguments following an OUT argument locally on a partition (i.e. without involving any actual network communication) would cause an incorrect matching of formal and actual parameters, causing incorrect values to be passed to the servant, or a crash if parameters were of incompatible types. (HB25-017) po_gnatdist crashed when building only the main partition in an application with an Ada starter. (HB10-009) Constraint_Error could be raised when calculating the number of tasks in a thread pool; this has been corrected. (HA02-018) IAC was generating incorrect Ada code for "default:" in a union. (H930-022) Several issues have been fixed in the circuitry handling TypeCodes and Anys for bounded string types. (H904-029) IAC was failing to correctly parse arrays and strings whose length was given by a named constant. (H813-030, H813-031) The tasks management circuitry has undergone a major overhaul to make it more robust and remove some irregularities in the assignment of particular ORB jobs to application tasks. This extensive change fixes dead locks (G510-007, H813-026) and invariant violations (H813-027, H828-032) which could happen under some specific scheduling situations. CORBA.Object.Hash might under some circumstances return different values for the same object. This has been fixed. (H806-014) IAC did not generate all code in user-specified output directory when using hash optimizations, this is now corrected. (H730-014) IAC incorrectly rejected negative real literals. They are now accpted. Workaround: add a pair of parentheses around the absolute value. (H728-026) IAC and IDLAC required array sizes to be literals or constants. Arbitrary integer expressions are now allowed. Workaround: introduce a named constant. (H723-024) IAC would generate garbled error messages when referring to declarations in #include files, such as "X" conflicts with declaration at included.idl:12:03. Workaround: fix the underlying error. (H723-022) IDL real literals starting with "0." were erroneously rejected by IAC. Workaround: use an expression yielding the same value but avoiding such literals. (H721-014) IDL constants of a bounded string type were not handled correctly by the IDL to Ada compilers. Both have been fixed. (H707-023) If the tasking policy is Thread_Pool, the ORB could borrow user tasks to handle Request_Jobs, which could cause long waiting times, or even deadlock in some cases. (G510-007) IAC would generate garbled error messages when referring to declarations in #include files, such as "X" conflicts with declaration at included.idl:12:03. (H723-022). IAC and IDLAC required array sizes to be literals or constants. Arbitrary integer expressions are now allowed. (H723-024). Leading separator characters were not ignored by PolyORB.CORBA_P.Naming_Tools. Parse_Name as documented. (H513-025) * PolyORB 2.4 (branched on 2008-05-06) ====================================== This release contains the PolyORB generic middleware, and its CORBA and DSA instantiations. In addition to the 2.3 release, it includes: New features ------------ See the features-24 file. Bug fixes --------- In PolyORB/DSA, references to RACW or RAS stream attributes in user code were not handled correctly. (H407-010) There was a bug in the function that determined wether a MIOP profile is local to a partition, this has been corrected. (H303-005) A PolyORB partition configured to use MIOP 1.0 did not default to GIOP 1.2, this has been corrected. (H303-004) Two issues were fixed in the decoding of MIOP headers (H228-015). The GIOP implementation rejected messages where reserved bytes had non-zero value, causing interoperability issues with TAO (H124-010). A PolyORB partition configured to use GIOP version 1.0 only was unable to connect to a server providing an IIOP 1.2 profile. The GIOP stack now gracefully degrades the connection to GIOP 1.0. (H110-024) Host names are now kept unresolved in profiles. This allows a partition to unmarshall, process and marshall back an object reference even when the host name contained in the reference cannot be resolved to an IP address (this is useful for example on a name server which serves references provided by clients, but does not need to connect directly to the referenced objects). (H107-031) * PolyORB 2.3 (branched on 2008-01-07) ====================================== This release contains the PolyORB generic middleware, and its CORBA and DSA instantiations. In addition to the 2.2 release, it includes: New features ------------ See the features-23 file. Bug fixes --------- Receiving an out-of-range value for an enumerated type (which can occur when the sending side passes an uninitialized object with invalid representation) would cause a segmentation fault in some contexts instead of propagating an exception. (G328-007) The CDR unmarshalling routines did not support indirect typecode references. (G328-027) Parsing of PolyORB's specific command line parameters in po_cos_naming was not working. This has been corrected. (G326-002) The client side GIOP version selection mechanism was incorrect. Version 1.2 was always assumed, even when the server reference specified a different version. (G323-025) The CDR unmarshalling for TypeCode objects of kind Union was incorrect. (G326-004) IDLAC would generate incorrect code when an IDL file declared a constant called "Standard". (G322-037) IDLAC would generate incorrect code when an IDL file declared a type called "Empty". (G322-036) * PolyORB 2.2 (branched on 2007-01-10) ====================================== This release contains a CORBA-compatible instantiation of the PolyORB generic middleware. In addition to the 2.1 release, it includes: New features ------------ See the features-22 file. New applicative personality: dsa (Ada Distributed Systems Annex). The code footprint and compile time for instances of PolyORB.Sequences.Bounded and PolyORB.Sequences.Unbounded has been significantly reduced thanks to a complete redesign that allowed significant code sharing across instances. (10469) Added the possibility to define a default listen address for the DIOP protocol personality. (10377) po_cos_naming has a new flag '-file', that outputs the server IOR in a file. (10283) Client binding objects are reused when possible, reducing the number of open channels between nodes. (10072) Added new service context to GIOP to pass server-side exception information to the reply. (10051) Major run-time performance improvements for the CORBA applicative personality. Completed the support for GIOP addressing modes. (10046) Bug fixes --------- A number of issues have been fixed with the subprograms in PolyORB.Sequences.Bounded and PolyORB.Sequences.Unbounded. Their behaviour is now closely aligned on Ada.Strings.Bounded and Ada.Strings.Unbounded, as per the CORBA specification. (10469) Marshalling and unmarshalling errors for aggregates are now correctly reported (previously a marshalling error in a reply would not correctly be notified as an exception to the client). (10432) Unwanted validity checks were generated in helpers for enumeration types, causing CONSTRAINT_ERROR to be erroneously raised when using pragma Initialize_Scalars. (10396) An incorrect type name was used for the POAManager reference type. It has been fixed to be conformant with the standard Ada mapping. This may require an update of user code; see "Incompatible changes" below. (10361) PortableServer package incorrectly defined helper functions. These have been moved in the PortableServer.Helper package to ensure code generated by idlac compiles correctly; see "Incompatible changes" below. (10357) idlac generated helper functions for types with local components, resulting in code that does not compile. This has been corrected. (10354) An incorrect type name was used for the list of POAs type. It has been fixed to be conformant with the standard Ada mapping. This may require an update of user code; see "Incompatible changes" below. (10345) An incorrect type name was used for the POA reference type. It has been fixed to be conformant with the standard Ada mapping. This may require an update of user code; see "Incompatible changes" below. (10337) A permissions issue with the polyorb-config script has been fixed. (10214) A long-standing bug in the CDR library would cause an incorrect representation to be used for fixed point values (leading zeroes were incorrectly omitted), causing failures to interoperate with third-party CORBA implementations. (10178) PortableServer.POA.Reference_To_Id would raise the WrongAdapter exception if it fails. (10159) CORBA.Is_Equivalent has been fixed to correctly determine when two references designate the same remote object (same remote node and same object key). (10124) The From_Any function generated for sequences of discriminated unions would raise CONSTRAINT_ERROR on sequence elements with a discriminant value other than the default one. (10087) PortableServer.POA.Reference_To_Id would raise an exception in the case of a POA with the USE_DEFAULT_SERVANT request processing policy. (10070) Incompatible changes -------------------- The reference type for the PortableServer::POA object is a local one, PortableServer.POA.Local_Ref. The conversion subprograms To_Ref and Unchecked_To_Ref have been accordingly renamed To_Local_Ref and Unchecked_To_Local_Ref, for consistency with the standard mapping. (41599) In CORBA.Sequences, subprogram Element_Of has been removed. It was a non-standard renaming of the Get_Element function specified by the Ada language mapping. Get_Element should be used instead. (10443) In the CORBA personality, the PortableServer.POAManager.Ref type has been renamed to PortableServer.POAManager.Local_Ref to be conformant with the IDL-to-Ada mapping. This fixes a conformance defect of PolyORB with respect to the CORBA standards; user code that references this type must be fixed accordingly. (10361) In the CORBA personality, the PortableServer package incorrectly defined helper functions. These have been moved in the PortableServer.Helper package. User code that references these functions must be fixed accordingly. (10357) In the CORBA personality, the PortableServer.IDL_SEQUENCE_POA_Forward package has been renamed to PortableServer.IDL_SEQUENCE_PortableServer_POA_Forward to be conformant with the IDL-to-Ada mapping. This fixes a conformance defect of PolyORB with respect to the CORBA standards; user code that references this type must be fixed accordingly. (10345) In the CORBA personality, the PortableServer.POA.Ref type has been renamed to PortableServer.POA.Local_Ref to be conformant with the IDL-to-Ada mapping. This fixes a conformance defect of PolyORB with respect to the CORBA standards; user code that references this type must be fixed accordingly. (10337) In PolyORB.Initialization, the type Module_Info has a new component Shutdown to specify a shutdown hook. Calls to PolyORB.Initialization.Register_Module must therefore provide a value for the new component. A null value should be used for modules that do not make use of this new feature. (10315) Building idlac now requires an Ada 2005 compiler supporting Ada.Containers. * PolyORB 2.1 (branched on 2006-05-11) ====================================== This release contains a CORBA-compatible instantiation of the PolyORB generic middleware. In addition to the 2.0 release, it includes: New features ------------ Exceptions raised during modules initialization are now caught and reported. (9795) EXTRA_GNATMAKE_FLAGS are now honored throughout the PolyORB build process, not just for examples and the test suite. (9846) ORB Controllers now support multiple event source monitors. This allows one partition to simultaneously support plain TCP/IP and SSL sockets, e.g. CORBA node using both IIOP and SSLIOP. (9850) Idlac does not generate with or use clauses in package bodies anymore if the same clause already appears in the corresponding package spec. (9853) Idlac can now generate only client-side or server-side code on demand. (9899) The blocking variant of ORB.Shutdown is now implemented: when ORB shutdown with wait for request completion is requested, the ORB blocks until the ORB controller signals completion of all remaining tasks. (9912) GIOP now supports Unicode UTF-8 and UTF-16 code sets; a new configuration parameter has been added to force the inclusion of fallback GIOP code sets converters in the object reference. (9954) Documention PolyORB's framework to support new GIOP code sets has been added. (9955) An implementation object type is provided for CORBA::Current, allowing users to implement derived interfaces of CORBA::Current using the default implementation template. (9960) Support for the CosNaming::CosNamingContextExt interface. (10300) Bug fixes --------- A missing initialization dependency of helpers upon "any" has been fixed. (9811) A race condition in the client-side processing of oneway requests could cause a oneway call executed from a partition using tasks to hang. (9837) Transport errors occurring on a session that has pending requests are now correctly reported to the caller. When such an error occurs, each pending request is now marked as completed with an error condition, and its target reference is marked as unbound, allowing further calls to rebind them. (9882) The CORBA::Object::non_existent implementation was incorrect on the server side and has been fixed. (9888, 9892) For a locality-constrained interface, generation of the Is_A primitive must be under control of the Implement flag, not the Generate_Client_Code flag. (9947) Corrected several inconsistencies in PolyORB local shutdown facility that prevent the correct shutdown of the ORB. (9937, 9938) Reordered error condition testing in PortableServer.POA.Activate_Object_With_Id to prevent introducing consistencies in the CORBA's personality POA. (9942) Actually store user-defined POA policies in the POA. (9967) Incompatible changes -------------------- By default, the SOAP personality will now bind on an available port number. To force it to bind to the previous default of 8080, use the polyorb.protocols.soap.default_addr in the [soap] section of the configuration. (9793) A typo has been fixed in the name of formal parameter ORB_Identifier of procedure CORBA.ORB.Init (it was previously misspelt "ORB_Indentifier"). User code that uses a named parameter association for this parameter will need to be fixed accordingly. (9919) CORBA.Current.Ref was changed to Local_Ref to adjust to a change in the CORBA specifications (between CORBA 2.3 and CORBA 3.0). (9951) * PolyORB 2.0 (released 2006-03-07) =================================== This new major release of PolyORB comes as the conclusion of a series of extensive reviews and reorganisations of the middleware components, improving the architecture's performances and flexibility. Development has taken place in both the generic core and the various application and protocol personalities. This release contains the PolyORB generic middleware and its CORBA and MOMA instances. In addition to the 1.3 release, it includes: New features ------------ The stubs and skeletons generated by idlac now evaluate operation and argument names only once at elaboration time, for improved efficiency. (9753) The low-level mutex facility used under full tasking has been reimplemented to take advantage of internal facilities provided by the GNAT runtime library, providing a significant performance improvement. (9744) The memory footprint of simply chained lists used internally has been reduced by not storing a 'Prev' pointer in each list node for that case. (9719) The output function used by the internal traces logging system is now set to its default value (output to the standard error file descriptor) only if it is unset. This makes it easier for users to override this value. (9717) Added support for CORBA bounded strings and bounded wide strings. (9696, 9697, 9701) Support for SSLIOP, an instance of the GIOP generic protocol on top of the SSL transport layer. (9520) The Thread_Pool ORB tasking policy can now dynamically allocates new tasks to handle higher workload. It uses three different parameters to control minimum number of threads, maximum number of spare threads, maximum total number of threads. See the PolyORB's User Guide for more details. (9515) Support for 'file://' URL scheme. This allows stringified references (e.g. IOR, corbaloc) to be read from a file. (9485) Support for the Tag_Alternate_IIOP_Address GIOP tagged component. This allows a node to listen on multiple sockets when using the GIOP/IIOP protocol personality. (9473) Idlac now annotates client stubs with comments indicating in which interface each inherited operation has been declared (whether it is implicitly inherited from the primary parent or redeclared from a secondary parent). (9458, 9459, 9460) Added support for the G++ 4.1.0 preprocessor. (9438) New contrib/ directory to store contributed code. (9376) Added idlac_wrapper, a script contributed by Vadim Godunko to avoid unnecessary recompilation of idlac generated files. (9376) Incompatible changes -------------------- For a bounded sequence, the associated instance of CORBA.Sequences.Bounded is now named IDL_Sequence__ in conformance with the example par. 3.8 of the IDL-to-Ada mapping. (9690) Idlac now builds the names of accessor for attributes with the same casing as in the specification for the IDL-to-Ada mapping: the accessors names are built by prepending "Get_" and "Set_" to the the attribute name. (9636) The casing of sequences packages is now "IDL_SEQUENCE", instead of "IDL_Sequence" in conformance with section 3.8 of the IDL-to-Ada mapping. (9632) ./configure now searches '--with-corba-services' instead of '--with-services' for CORBA Services to build. (9597) polyorb-config now returns list of CORBA services using '--with-corba-services' instead of '--with-services'. (9597) The "polyorb.tasking.threads.storage_size" parameter in section [tasking] has been renamed to just "storage_size". Accordingly, the environment variable to be used to override this value is now POLYORB_TASKING_STORAGE_SIZE instead of POLYORB_TASKING_POLYORB_TASKING_THREADS_STORAGE_SIZE. (9504) The "polyorb.orb.thread_pool.threads" parameter in section [tasking] is deprecated. The Thread_Pool ORB tasking policy is now configured using a set of three parameters: min_spare_threads, max_spare_threads, and max_threads. (9504) CORBA specifications mandate that all standard minor exception codes should be or'ed with the OMGVMCID constant (CORBA3 A.5). The CORBA and GIOP personalities now handle this correctly. (9415) The implementation of the PortableServer::ObjectId has been corrected to match the IDL-to-Ada specifications, resulting in changes in the API. (9352) Fixed bugs ---------- CORBA.ORB.String_To_Object used to raise non-CORBA exceptions for some cases of malformed corbaloc URIs. This has been fixed. (9750) The helpers for union types occasionally contained lines whose length exceeded the default maximum length for GNAT (255 characters). The layout of the generated code has been adapted to avoid exceeding this implementation limit. (9710) When a GIOP reply has been received, call Expect_GIOP_Header prior to notifying the caller. Otherwise, the underlying binding object may disappear too early, causing SOCKET_ERROR to be raised due to calling select(2) on a closed socket fd. (9507) When closing a socket, remove it from the monitored set prior to closing it. Otherwise, a race condition occurs that can cause SOCKET_ERROR to be raised due to calling select(2) on a closed socket fd. (9496) Correct helper generation for typedefs. (9435) In some cases, integer constants greater than 2**31 would not be processed correctly and cause idlac to crash or generate incorrect code. (9377) Correct handling of nested (anonymous) arrays. (9412) Correct skeleton generation for functions returning references. (9411, 9424) * PolyORB 1.3 (released 2005-06-20) =================================== This release contains a CORBA-compatible instantiation of the PolyORB generic middleware. In addition to the 1.2r release, it includes: New features ------------ Base support for the DynamicAny interface. (9282) The modularity of the Neutral Core Layer has been increased, leading to better configurability of log output (8968), and parameter sources (9258). Support for CORBA Policy management, including Domain policy management. A domain policy manager can be specified using configuration variable policy_domain_manager in section [corba]. idlac now returns an exit status of 2 in the case of an illegal IDL specification. (9213) idlac now supports typeid declarations. (9212) Some inefficiencies in the buffer management subsystem have been fixed, giving a major improvement in performances when large data is passed in request parameters. Update of the implementation of the CORBA Interface Repository, PortableInterceptors API. Update of idlac to support IDL as defined by CORBA 3.0 standards. Update all CORBA IDL specification to match latest release by the OMG. Implementation of the CORBA COS Notification Service (beta stage) (9121), the RTCosScheduling service (RT-CORBA 1.1) (9016), Several additions to the User's Guide. Incompatible changes -------------------- The implementation of CORBA POA's servant managers has been corrected to match the IDL-to-Ada specifications, resulting in changes in the API. (9322) PolyORB.ORB_Controller.Basic has been renamed and is now PolyORB.ORB_Controller.Workers. (9243) idlac does not generate Interface Repository code by default anymore. The '-ir' command line switch can be used to specifically request IR code generation. The '-noir' command line switch is now a no-op and will be removed in a future release. (9211) idlac is now quiet by default. The '-v' command line switch can be used to make it verbose. The '-q' command line switch is now a no-op and will be removed in a future release. (9210) The runtime configuration parameters that control the references to well-known services (naming and interface repository) now support corbaloc URIs as a possible notation (in addition to IORs). Consequently, they have been renamed as follows: * In section [corba]: naming_ior -> name_service ir_ior -> ir_service * In section [dsa]: naming_ior -> name_service (9160) Fixed bugs ---------- Fixes for several code generation issues in idlac, the IDL-to-Ada compiler. Fixes for memory leaks in GIOP code sets negotiation. (9228) * PolyORB 1.2r (released 2004-12-17) ==================================== This release contains a CORBA-compatible instantiation of the PolyORB generic middleware. In addition to the 1.1r release, it includes: - extended support for CORBA and GIOP specifications, - support for PortableInterceptors, - support for RT-CORBA 1.1, - fixes for several bugs and memory leaks, - several additions to the User's Guide. PolyORB now includes the Message Oriented Middleware for Ada (MOMA) personality. It proposes an API comparable to Sun's Java Message Service (JMS). It supports Publish/Subscribe and Point-to-Point. PolyORB neutral core middleware now supports more concurrency policies. It implements the No Tasking, Basic, Leader/Followers and Half Sync/Half Async design patterns. Release branched on 2004-12-17. (8922) * PolyORB 1.1r (released 2004-06-07) ==================================== This release contains a CORBA-compatible instantiation of the PolyORB generic middleware. In addition to the 1.0 release, it includes: - a significant increase in performance (30%-40%), - fixes for several bugs and memory leaks, - extended support for CORBA and GIOP specifications, - the PolyORB User's Guide, - the MIOP/UIPMC protocol stack, Unreliable Multicast Inter-ORB Protocol, following the OMG standard, - the DIOP protocol stack, Datagram-based Inter-ORB Protocol, a specialization of GIOP for oneway requests. * PolyORB 1.0 (released 2003-06-16) =================================== This release contains a CORBA-compliant instantiation of the PolyORB generic middleware. It includes: - an IDL to Ada 95 compiler, - Portable Object Adapter (POA), Dynamic Skeleton Interface (DSI), Dynamic Invocation Interface (DII), and Interface Repository (IR) implementations, - COS Naming, COS Event and COS Time services implementations, - GIOP 1.0, 1.1, and 1.2 implementations. This CORBA implementation can be configured for full tasking, Ravenscar tasking or no tasking runtime, depending on the level of desired functionality for the application, and on the resource constraints for the target. This release should be considered as a stable implementation of CORBA middleware over PolyORB. Release branched on 2003-05-16. (6783) * PolyORB 0.1 (released 2001-12-04) =================================== This is the first public release of PolyORB code. This release contains the personality-neutral middleware core, the CORBA application personality (including our IDL -> Ada 95 compiler idlac), and CORBA and SOAP protocol personalities. This should be considered as test-phase software. polyorb-2.8~20110207.orig/features-280000644000175000017500000000212411750740337016377 0ustar xavierxavier============================= PolyORB 2.8 NEW FEATURES LIST ============================= Copyright (C) 2009-2010, AdaCore This file contains a complete list of new features in version 2.8 of PolyORB. See also file NEWS for various information about this release. An ISO date (YYYY-MM-DD) appears in parentheses after the description line. This date shows the implementation date of the feature. Any 2.8 wavefront subsequent to this date will contain the indicated feature, as will any subsequent releases. NF-28-JC17-036 Support for partition-wide RPC timeout setting (2010-12-23) A new runtime parameter rpc_timeout in section [dsa] specifies a global timeout (in milliseconds) to be applied to all remote subprogram calls. NF-28-JA25-023 Support for additional configuration pragmas (2010-10-26) A new configure command line switch --enable-conf-pragmas is provided, which allows the user to specify then name of an additional configuration pragmas file to be used when compiling the PolyORB runtime library, for example containing some application-mandated Restrictions pragmas. polyorb-2.8~20110207.orig/FEATURES0000644000175000017500000001216711750740337015560 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- Copyright (C) 1999-2005 Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore. -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ This files lists PolyORB's main features, as well as some known limitations. These limitations will be addressed in next releases. Configuration options --------------------- Different configuration options allow for a complete control of the middleware. - PolyORB allows for the dynamic configuration of some of its internals through a detailed configuration file (see polyorb.conf for more details). - 3 tasking runtimes: - No tasking; - Full tasking, using constructions as proposed by the Ada 95 Reference Manual; - Ravenscar, using the Ada Ravenscar restricted profile for tasking constructs. - ORB's request dispatching policies to control thread allocation: - Thread Pool; - Thread Per Session (i.e. active connection); - Thread Per Request; - Single Thread (if 'No Tasking' tasking runtime is used). - ORB Controller's policy to control concurrency patterns used to synchronize the middleware internal threads: - Workers; - Half Sync/Half Async; - Leader/Followers; - No Tasking. Configuration options are detailed in the PolyORB User's Guide. ----------- -- CORBA -- ----------- PolyORB implements a CORBA application personality, compatible with the OMG's specifications, that supports: - Static invocation models based on generated stub and skeletons, - Dynamic Invocation Interface (DII), - Dynamic Skeleton Interface (DSI), It also provides an implementation of the CORBA Portable Object Adapter (POA); CORBA DynamicAny, CORBA PortableInterceptors interfaces; and RT-CORBA 1.1 and the RTCosScheduling Service. CORBA Services -------------- PolyORB implements the following CORBA COS Services: - Event, - Interface Repository, - Naming, - Notification, - Time. Note that the current COS Naming implementation does not support corbaloc references. IDL Compiler ------------ PolyORB provides idlac, a CORBA 'IDL to Ada compiler' written entirely in Ada 95. It generates full stub and skeleton from an IDL contract. It supports all common IDL constructs; yet it does not support the following advanced constructs: value-type, abstract interfaces. ---------- -- MOMA -- ---------- PolyORB offers the Message Oriented Middleware for Ada (MOMA) personality. It proposes an API comparable to Sun's Java Message Service, and supports Publish/Subscribe and Point-to-Point. ---------- -- GIOP -- ---------- GIOP is the Generic Inter-ORB Protocol, defined as part of the CORBA specifications to support Inter-ORB communications. PolyORB follows this specification and proposes the following instances of GIOP: IIOP ---- PolyORB proposes an implementation of the IIOP 1.0, 1.1 and 1.2 protocols. Request marshaling operations are complete. IIOP-level interoperability with other ORBs have been tested with - Jonathan 3.0 - omniORB 4.0 - OpenORB 1.3.0 - VisiBroker 4.5 SSLIOP ------ PolyORB proposes an implementation of the SSLIOP protocol. It provides support for data encryption for GIOP requests. MIOP/UIPMC ---------- PolyORB proposes an implementation of the MIOP 1.0 proposed specification. It provides group communication mechanisms using IP/multicast. DIOP ---- PolyORB proposes a specialization of GIOP for oneway requests based on UDP/IP. polyorb-2.8~20110207.orig/features-260000644000175000017500000000341411750740337016400 0ustar xavierxavier============================= PolyORB 2.6 NEW FEATURES LIST ============================= Copyright (C) 2009-2010, AdaCore This file contains a complete list of new features in version 2.6 of PolyORB. See also file NEWS for various information about this release. An ISO date (YYYY-MM-DD) appears in parentheses after the description line. This date shows the implementation date of the feature. Any 2.6w wavefront subsequent to this date will contain the indicated feature, as will any subsequent releases. NF-26-IB05-009 New pre-packaged setup for threaded clients (2009-11-09) A new pre-packaged setup package PolyORB.Setup.Thread_Pool_Client is now provided for client partitions that require tasking support. NF-26-I511-037 Identify originating partition in exceptions (2009-05-12) When using the Ada DSA applicative personality, partition id information is now appended to exception messages to help identifying which partition raised the exception, and how it was propagated across partitions. NF-26-I320-027 Performance of neutral and protocol layers (2009-04-14) The performance of the neutral and protocol layers has been improved significantly by guarding some costly and seldom useful debugging traces with appropriate configuration knobs, and by rewriting the management routines for some internal data structures to avoid repeated memory allocations and deallocations. NF-26-H731-006 Improved handling of unbounded string arguments (2009-02-12) When using the Ada DSA applicative personality, remote calls involving arguments of type Ada.Strings.Unbounded.Unbounded_String now use the native PolyORB string type, providing better performance. Note that the PCS API has been updated, and this requires a corresponding compiler update. polyorb-2.8~20110207.orig/Makefile.in0000644000175000017500000036236211750740337016471 0ustar xavierxavier# Main PolyORB Makefile .PHONY: default default: all # To use this make file, say "make ". # You must be in the top-level polyorb directory. # (???We probably want a convenient way to do a build from any subdirectory.) # You still have to do: # support/reconfig # ./configure ... # first, although this make file mostly ignores the results of configure. # NOTE: You must set the ADA_PROJECT_PATH so that we can find xmlada.gpr. # See projects/polyorb_src_soap.gpr. # Interesting targets to use from the command line: # # all (the default) -- builds all of PolyORB, but not examples, # testsuite, docs # # examples -- builds the examples # # testsuite -- builds the examples and testsuite # # run_tests -- runs the testsuite (presumes polyorb built) # # all-and-test -- builds everything needed, then runs the testsuite # # polyorb_src_corba.gpr -- target to build src/corba (and similarly for all # the *.gpr files in the projects subdirectory). That is, there is a ".PHONY" # target with the same name as each project file, sans directory name. # # libpolyorb-corba.a -- ".PHONY" target to build the library # lib/libpolyorb-corba.a (and similarly for all the other libraries). # Each of these depends on the *.gpr target (e.g. lib/libpolyorb-corba.a # depends on polyorb_src_corba.gpr). # # examples/corba/all_functions/build-test -- target to build a particular # example (and similarly for other subdirectories under examples). # # testsuite/corba/all_exceptions/build-test -- target to build a particular # test (and similarly for other subdirectories under testsuite). # # docs -- target to build the document. ################################################################ # Don't rely on undefined variables being empty, nor on builtin stuff. # Note that these do not override command-line options; these options are # in addition. MAKEFLAGS := --no-builtin-rules \ --no-builtin-variables \ --warn-undefined-variables ################################################################ top_srcdir := @abs_top_srcdir@ top_builddir := @abs_top_builddir@ install_sh := @install_sh@ MOVEIFCHANGE := ${top_builddir}/support/move-if-change RM := @RM@ XARGS_I := @XARGS_I@ INSTALL := @INSTALL@ INSTALL_SCRIPT := @INSTALL_SCRIPT@ INSTALL_PROGRAM := @INSTALL_PROGRAM@ INSTALL_STRIP_PROGRAM := @INSTALL_STRIP_PROGRAM@ INSTALL_BIN := @INSTALL_BIN@ LN_S := @LN_S@ SHELL := @SHELL@ TOOL_EXE_SUFFIX := @TOOL_EXE_SUFFIX@ COMPILER_EXE_SUFFIX := @COMPILER_EXE_SUFFIX@ CC_FOR_TARGET := @CC_FOR_TARGET@ GNATCHOP := @GNATCHOP@ GNATMAKE := @GNATMAKE@ GNATMAKE_FOR_TARGET := @GNATMAKE_FOR_TARGET@ # ??? distinguish between native tools, cross tools and cross libs # Flags common to build and target # Do not use := for the following flags, so that they can be overriden on # the command line if needed. Also, need to specify PARALLEL_GNATMAKE_FLAGS # before GNATMAKE_FLAGS, otherwise this variable is simply ignored. CFLAGS = @CFLAGS@ ADAFLAGS = @ADAFLAGS@ CPPFLAGS = @CPPFLAGS@ PARALLEL_GNATMAKE_FLAGS = -j4 EXTRA_GNATMAKE_FLAGS = @EXTRA_GNATMAKE_FLAGS@ # EXTRA_GNATMAKE_FLAGS are user-provided, empty by default (typically # used to specify a non-default --RTS switch). ifneq ($(filter -%args,$(EXTRA_GNATMAKE_FLAGS)),) MARGS:=-margs endif BASE_GNATMAKE_FLAGS :=--create-missing-dirs -L${top_builddir}/lib ${ADAFLAGS} ${PARALLEL_GNATMAKE_FLAGS} ${EXTRA_GNATMAKE_FLAGS} ${MARGS} # Gnatmake flags for units built from project files # Note: if EXTRA_GNATMAKE_FLAGS contains a -%args argument, we add -margs at # the end because further builder flags may need to be passed. COMP_TOOLS_GNATMAKE_FLAGS := @STYLE_SWITCH@ -gnatwa@WARNINGS_MODE@ -gnat05 -gnatec=${top_builddir}/compilers/config.adc ${BASE_GNATMAKE_FLAGS} # Gnatmake flags for compilation tools mains, built without project files # Extra flags for target CFLAGS_FOR_TARGET := @CFLAGS_FOR_TARGET@ ADAFLAGS_FOR_TARGET := @ADAFLAGS_FOR_TARGET@ GNATMAKE_FLAGS_FOR_TARGET := -cargs ${ADAFLAGS_FOR_TARGET} HAVE_ADA_DYNAMIC_PRIORITIES := @HAVE_ADA_DYNAMIC_PRIORITIES@ HAVE_SSL := @HAVE_SSL@ include ${top_builddir}/Makefile.common.project .PHONY: all all: all-compilers perfect-hash polyorb-idl-stamps do-gnatmake IDLAC_bin := compilers/@IDLAC@/@IDLAC@ IDLAC_WRAPPER := ${top_builddir}/contrib/idlac_wrapper/idlac_wrapper # Cancel build-in implicit rule %: %.o # IDLAC_bin is rebuilt as part of the all-compilers target ${IDLAC_bin}: all-compilers # Path separator -- ":" or ";" for Unix/Windows. # Note that @PATH_SEPARATOR@ is : for cygwin, so we need to adjust that. @WINDOWS_FALSE@PATH_SEP := @PATH_SEPARATOR@ @WINDOWS_TRUE@PATH_SEP := ; ################################################################ # Personalities control APPLI_LIST := @APPLI_LIST@ ################################################################ # Rules for building programs in the 'compilers' directory COMPILER_EXES := gnatprfh/gnatprfh ifeq "${filter corba, ${APPLI_LIST}}" "corba" COMPILER_EXES += @IDLAC@/@IDLAC@ endif ifeq "${filter dsa, ${APPLI_LIST}}" "dsa" COMPILER_EXES += gnatdist/po_gnatdist endif COMPILERS := ${foreach comp,${COMPILER_EXES},${notdir ${comp}}} .PHONY: all-compilers all-compilers: ${patsubst %, build-%, ${COMPILERS}} ################ # gnatprfh tool .PHONY: build-gnatprfh build-gnatprfh: compiler_dir := gnatprfh ############################# # idlac IDL-to-Ada compiler # ############################# #???Compare with Makefile.am. .PHONY: build-testparser \ build-testlexer \ build-testgen \ build-idlac build-testgen build-idlac: \ PRJ_GNATMAKE_FLAGS := -I${top_srcdir}/compilers/common_files \ -I${top_builddir}/compilers/common_files build-testparser build-testlexer build-testgen build-idlac: \ compiler_dir := idlac ########################### # iac IDL-to-Ada compiler # ########################### .PHONY: build-mknodes build-iac build-mknodes build-iac : \ PRJ_GNATMAKE_FLAGS := -I${top_srcdir}/compilers/common_files \ -I${top_builddir}/compilers/common_files build-mknodes build-iac : \ compiler_dir := iac IAC_NODES_STAMPS= \ compilers/iac/frontend-nodes.idl-stamp \ compilers/iac/backend-be_corba_ada-nodes.idl-stamp IAC_NODES_SOURCES= \ ${IAC_NODES_STAMPS:.idl-stamp=.ads} \ ${IAC_NODES_STAMPS:.idl-stamp=.adb} ${IAC_NODES_STAMPS}: %-stamp: ${top_srcdir}/% build-mknodes cd compilers/iac && ./mknodes $< && touch ${notdir $@} ${filter %.ads,${IAC_NODES_SOURCES}}: %.ads: %.idl-stamp ${filter %.adb,${IAC_NODES_SOURCES}}: %.adb: %.idl-stamp # Additional dependency of iac upon files generated by mknodes build-iac: ${IAC_NODES_SOURCES} ################################## # gnatdist DSA partitioning tool # ################################## .PHONY: build-po_gnatdist build-po_gnatdist: \ compiler_dir := gnatdist ################################################ # Common build rule for all compile-time tools # ################################################ build-gnatprfh \ \ build-testparser \ build-testlexer \ build-testgen \ build-idlac \ \ build-mknodes \ build-iac \ \ build-po_gnatdist \ \ : build-%: mkdir -p compilers/${compiler_dir} && \ cd compilers/${compiler_dir} && \ ${GNATMAKE} -m \ $*.adb \ ${COMP_TOOLS_GNATMAKE_FLAGS} \ -I${top_srcdir}/compilers/${compiler_dir} \ ${PRJ_GNATMAKE_FLAGS} -bargs -E # Binder switch -E causes traceback information to be included in # Exception_Occurrences. # The following variables are used for invoking idlac. There is a static # pattern rule for each; see "Rules for running idlac", below. Each file # mumble.idl has a corresponding empty mumble.idl-stamp file, which is # 'touch'ed to record the time at which idlac was run. Targets that use # the output of idlac should depend on the .idl-stamp files, rather than the # actual .ads/.adb files produced by idlac. This allows the optimization # implemented in idlac_wrapper. There can be more than one .idl-stamp for the # same .idl file, in different directories, if we wish to run idlac more than # once on the same file with different options. # For each mumble.idl-stamp, we write: # xxx_idl_stamps += mumble.idl-stamp # causes the target to exist # mumble.idl-stamp: idlac_flags := ... # flags used to compile that target # xxx indicates the directories for the .idl and .idl-stamp files; # self_idl_stamps is for cases where the .idl-stamp is put in the same # directory as the .idl. idls_idl_stamps := interop_corba_idl_stamps := interop_corba_iop_idl_stamps := interop_corba_security_idl_stamps := interop_corba_security_gssup_idl_stamps := misc_corba_dynamicany_idl_stamps := misc_corba_messaging_idl_stamps := misc_corba_portableinterceptor_idl_stamps := rtcorba_corba_rtcorba_idl_stamps := self_idl_stamps := all_idl_stamps = \ ${idls_idl_stamps} \ ${interop_corba_idl_stamps} \ ${interop_corba_iop_idl_stamps} \ ${interop_corba_security_idl_stamps} \ ${interop_corba_security_gssup_idl_stamps} \ ${misc_corba_dynamicany_idl_stamps} \ ${misc_corba_messaging_idl_stamps} \ ${misc_corba_portableinterceptor_idl_stamps} \ ${rtcorba_corba_rtcorba_idl_stamps} \ ${self_idl_stamps} idlac_include_dirs := \ idls/CORBA_IDL idls/CORBA_PIDL idls/Misc idls/Interop \ idls/Misc idls/cos/event idls/cos/notification idls/cos/time idlac_include_flags := \ ${addprefix -I${top_srcdir}/,${idlac_include_dirs}} \ -I. # Command used to run idlac: idlac := ${IDLAC_WRAPPER} --idlac="${top_builddir}/${IDLAC_bin}" ${idlac_include_flags} ################################################################ # Rules for running gnatprfh in the src/soap directory .PHONY: perfect-hash perfect-hash: build-gnatprfh src/soap/polyorb-http_methods.adb src/soap/polyorb-http_headers.adb GNATPRFH = ${top_builddir}/compilers/gnatprfh/gnatprfh GEN_HTTP_BODY = ${top_srcdir}/src/soap/gen_http_body #???.exe suffix : gnatprfh.exe? src/soap/polyorb-http_methods.adb: ${GEN_HTTP_BODY} compilers/gnatprfh/gnatprfh # Note that the second gen_http_body command below overwrites perfect_hash.adb # with different content. src/soap/polyorb-http_methods.adb src/soap/polyorb-http_headers.adb: ${GEN_HTTP_BODY} compilers/gnatprfh/gnatprfh ${top_srcdir}/src/soap/polyorb-http_methods.ads ${top_srcdir}/src/soap/polyorb-http_headers.ads mkdir -p src/soap cd src/soap && ${GEN_HTTP_BODY} ${GNATPRFH} ${top_srcdir}/src/soap Method cd src/soap && ${GEN_HTTP_BODY} ${GNATPRFH} ${top_srcdir}/src/soap Header ################################################################ # src/giop, tools/po_catref. gen_codeset. GEN_CODESET = src/giop/gen_codeset build-gen_codeset: mkdir -p src/giop && cd src/giop && \ ${GNATMAKE} gen_codeset -I${top_srcdir}/src/giop ${COMP_TOOLS_GNATMAKE_FLAGS} -bargs -E src/giop/polyorb-giop_p-code_sets-data.ads-stamp: ${top_srcdir}/src/giop/cs_registry1.2h ${GEN_CODESET} cd src/giop && ./gen_codeset -c "PolyORB.GIOP_P.Code_Sets.Data" \ polyorb-giop_p-code_sets-data.ads.new \ < $< cd src/giop && ${MOVEIFCHANGE} polyorb-giop_p-code_sets-data.ads.new polyorb-giop_p-code_sets-data.ads touch src/giop/polyorb-giop_p-code_sets-data.ads-stamp tools/po_catref/polyorb-giop_p-code_sets-description_data.ads-stamp: ${top_srcdir}/src/giop/cs_registry1.2h ${GEN_CODESET} Makefile cd tools/po_catref && ${top_builddir}/${GEN_CODESET} -d "PolyORB.GIOP_P.Code_Sets.Description_Data" \ polyorb-giop_p-code_sets-description_data.ads.new \ < $< cd tools/po_catref && ${MOVEIFCHANGE} polyorb-giop_p-code_sets-description_data.ads.new polyorb-giop_p-code_sets-description_data.ads touch tools/po_catref/polyorb-giop_p-code_sets-description_data.ads-stamp ################################################################ # PolyORB IDL files server_idl_stamps := \ cos/event/CosEventChannelAdmin.idl-stamp \ cos/event/CosEventComm.idl-stamp \ cos/event/CosTypedEventChannelAdmin.idl-stamp \ cos/event/CosTypedEventComm.idl-stamp \ cos/naming/CosNaming.idl-stamp \ cos/notification/CosNotification.idl-stamp \ cos/notification/CosNotifyChannelAdmin.idl-stamp \ cos/notification/CosNotifyComm.idl-stamp \ cos/notification/CosNotifyFilter.idl-stamp \ cos/time/CosTime.idl-stamp idls_idl_stamps += ${server_idl_stamps} ${server_idl_stamps}: idlac_flags := -s client_idl_stamps := ${server_idl_stamps:cos/%=idls/cos/%} \ idls/cos/time/TimeBase.idl-stamp self_idl_stamps += ${client_idl_stamps} ${client_idl_stamps}: idlac_flags := -c self_idl_stamps += cos/naming/File.idl-stamp cos/naming/File.idl-stamp: idlac_flags := interop_corba_idl_stamps += src/corba/CONV_FRAME.idl-stamp src/corba/CONV_FRAME.idl-stamp: idlac_flags := misc_corba_dynamicany_idl_stamps += src/corba/dynamicany/DynamicAny.idl-stamp src/corba/dynamicany/DynamicAny.idl-stamp: idlac_flags := interop_corba_iop_idl_stamps += src/corba/iop/IOP.idl-stamp src/corba/iop/IOP.idl-stamp: idlac_flags := misc_corba_messaging_idl_stamps += src/corba/messaging/Messaging.idl-stamp src/corba/messaging/Messaging.idl-stamp: idlac_flags := misc_corba_portableinterceptor_idl_stamps += src/corba/portableinterceptor/PortableInterceptor.idl-stamp src/corba/portableinterceptor/PortableInterceptor.idl-stamp: idlac_flags := misc_corba_portableinterceptor_idl_stamps += src/corba/portableinterceptor/Dynamic.idl-stamp src/corba/portableinterceptor/Dynamic.idl-stamp: idlac_flags := rtcorba_corba_rtcorba_idl_stamps += src/corba/rtcorba/RTCosScheduling.idl-stamp src/corba/rtcorba/RTCosScheduling.idl-stamp: idlac_flags := interop_corba_security_idl_stamps += src/corba/security/CSI.idl-stamp src/corba/security/CSI.idl-stamp: idlac_flags := -c interop_corba_security_idl_stamps += src/corba/security/CSIIOP.idl-stamp src/corba/security/CSIIOP.idl-stamp: idlac_flags := -c interop_corba_security_gssup_idl_stamps += src/corba/security/gssup/GSSUP.idl-stamp src/corba/security/gssup/GSSUP.idl-stamp: idlac_flags := -c # This is expanded here, and therefore leaves out the examples below. polyorb_idl_stamps := ${all_idl_stamps} # All so far, that is. .PHONY: polyorb-idl-stamps polyorb-idl-stamps: build-@IDLAC@ ${polyorb_idl_stamps} cos/ir/orb.idl-stamp #???What is the following all about? Why does it "chmod" and "rm"? cos/ir/orb.idl-stamp: ${top_srcdir}/idls/CORBA_IDL/orb.idl ${top_srcdir}/idls/CORBA_IDL/CORBA_InterfaceRepository.idl ${top_srcdir}/idls/CORBA_IDL/CORBA_TypeCode.idl ${IDLAC_bin} ${IDLAC_WRAPPER} @chmod a+x ${IDLAC_WRAPPER} mkdir -p ${dir $@} cd ${dir $@} && ${idlac} $< ${RM} cos/ir/corba-repository_root.ads touch $@ ################################################################ #????idls_dirs := \ # cos/naming \ # idls/CORBA_IDL \ # idls/CORBA_PIDL \ # idls/Interop \ # idls/Misc \ # idls/RTCORBA \ # idls/cos/collection \ # idls/cos/concurrency \ # idls/cos/event \ # idls/cos/externalization \ # idls/cos/licensing \ # idls/cos/lifecycle \ # idls/cos/naming \ # idls/cos/notification \ # idls/cos/persistent \ # idls/cos/property \ # idls/cos/query \ # idls/cos/relationship \ # idls/cos/security \ # idls/cos/time \ # idls/cos/trader \ # idls/cos/transaction ################################################################ # Targets for compiling the PolyORB Ada code # ???Currently, this depends on all the .idl-stamp files; # we could make this more fine-grained. # Get list of all .gpr files, and strip off directory name. Note that most are # in ${top_srcdir}/projects, but some are generated from *.gpr.in, and are # therefore in ${top_builddir}/projects. Use ${sort} to remove duplicates # (in case srcdir and builddir are the same). ALL_PROJECT_FILES := ${sort \ ${notdir ${wildcard ${top_srcdir}/projects/*.gpr}} \ ${notdir ${wildcard ${top_builddir}/projects/*.gpr}}} # Remove the ones that shouldn't be built: IGNORED_PROJECT_FILES := polyorb_build_all.gpr polyorb_common.gpr polyorb_config.gpr PROJECT_FILES := ${filter-out ${IGNORED_PROJECT_FILES},${ALL_PROJECT_FILES}} # The ones that start with "polyorb_tools_" are for building (target) # executables. The rest are for building libraries. LIBRARY_PROJECT_FILES := ${filter-out polyorb_tools_%,${PROJECT_FILES}} EXE_PROJECT_FILES := ${filter polyorb_tools_%,${PROJECT_FILES}} # Additional C sources C_FILES= src/csupport.c .PHONY: do-gnatmake do-gnatmake: ${POLYORB_LIBS} ${SERVICE_LIBS} ${EXE_PROJECT_FILES} #??? ${APPLI_EXES} ${SERVICE_EXES} #???lib/polyorb.ali is missing the first time around. # Because we can't share library directories! .PHONY: libpolyorb-aws.a libpolyorb-aws.a: polyorb_src_aws.gpr .PHONY: libpolyorb-corba-cos-event-impl.a libpolyorb-corba-cos-event-impl.a: polyorb_cos_event.gpr .PHONY: libpolyorb-corba-cos-ir-impl.a libpolyorb-corba-cos-ir-impl.a: polyorb_cos_ir.gpr .PHONY: libpolyorb-corba-cos-naming-impl.a libpolyorb-corba-cos-naming-impl.a: polyorb_cos_naming.gpr .PHONY: libpolyorb-corba-cos-notification-impl.a libpolyorb-corba-cos-notification-impl.a: polyorb_cos_notification.gpr .PHONY: libpolyorb-corba-cos-time-impl.a libpolyorb-corba-cos-time-impl.a: polyorb_cos_time.gpr .PHONY: libpolyorb-corba-cos-event.a libpolyorb-corba-cos-event.a: polyorb_idls_cos_event.gpr .PHONY: libpolyorb-corba-cos-naming.a libpolyorb-corba-cos-naming.a: polyorb_idls_cos_naming.gpr .PHONY: libpolyorb-corba-cos-notification.a libpolyorb-corba-cos-notification.a: polyorb_idls_cos_notification.gpr .PHONY: libpolyorb-corba-cos-time.a libpolyorb-corba-cos-time.a: polyorb_idls_cos_time.gpr .PHONY: libpolyorb.a libpolyorb.a: polyorb_src.gpr .PHONY: libpolyorb-corba.a libpolyorb-corba.a: polyorb_src_corba.gpr .PHONY: libpolyorb-corba-dynamicany.a libpolyorb-corba-dynamicany.a: polyorb_src_corba_dynamicany.gpr .PHONY: libpolyorb-corba-iop.a libpolyorb-corba-iop.a: polyorb_src_corba_iop.gpr .PHONY: libpolyorb-corba-messaging.a libpolyorb-corba-messaging.a: polyorb_src_corba_messaging.gpr .PHONY: libpolyorb-corba-portableinterceptor.a libpolyorb-corba-portableinterceptor.a: polyorb_src_corba_portableinterceptor.gpr .PHONY: libpolyorb-corba-rtcorba.a libpolyorb-corba-rtcorba.a: polyorb_src_corba_rtcorba.gpr .PHONY: libpolyorb-corba-security.a libpolyorb-corba-security.a: polyorb_src_corba_security.gpr .PHONY: libpolyorb-corba-security-gssup.a libpolyorb-corba-security-gssup.a: polyorb_src_corba_security_gssup.gpr .PHONY: libpolyorb-dsa.a libpolyorb-dsa.a: polyorb_src_dsa.gpr libpolyorb-dsa.a: PRJ_GNATMAKE_FLAGS := -a # Some components of the DSA application personality are child units of # System: use -a to allow them to be compiled. .PHONY: libpolyorb-dns.a libpolyorb-dns.a: polyorb_src_dns.gpr .PHONY: libpolyorb-dns-udns.a libpolyorb-dns-udns.a: polyorb_src_dns_udns.gpr .PHONY: libpolyorb-dns-mdns.a libpolyorb-dns-mdns.a: polyorb_src_dns_mdns.gpr .PHONY: libpolyorb-giop.a libpolyorb-giop.a: polyorb_src_giop.gpr .PHONY: libpolyorb-giop-diop.a libpolyorb-giop-diop.a: polyorb_src_giop_diop.gpr .PHONY: libpolyorb-giop-iiop.a libpolyorb-giop-iiop.a: polyorb_src_giop_iiop.gpr .PHONY: libpolyorb-giop-iiop-security.a libpolyorb-giop-iiop-security.a: polyorb_src_giop_iiop_security.gpr .PHONY: libpolyorb-giop-iiop-security-tls.a libpolyorb-giop-iiop-security-tls.a: polyorb_src_giop_iiop_security_tls.gpr .PHONY: libpolyorb-giop-iiop-ssliop.a libpolyorb-giop-iiop-ssliop.a: polyorb_src_giop_iiop_ssliop.gpr .PHONY: libpolyorb-giop-miop.a libpolyorb-giop-miop.a: polyorb_src_giop_miop.gpr .PHONY: libpolyorb-moma.a libpolyorb-moma.a: polyorb_src_moma.gpr .PHONY: libpolyorb-security.a libpolyorb-security.a: polyorb_src_security.gpr .PHONY: libpolyorb-security-gssup.a libpolyorb-security-gssup.a: polyorb_src_security_gssup.gpr .PHONY: libpolyorb-security-tls.a libpolyorb-security-tls.a: polyorb_src_security_tls.gpr .PHONY: libpolyorb-security-x509.a libpolyorb-security-x509.a: polyorb_src_security_x509.gpr .PHONY: libpolyorb-setup.a libpolyorb-setup.a: polyorb_src_setup.gpr .PHONY: libpolyorb-setup-security.a libpolyorb-setup-security.a: polyorb_src_setup_security.gpr .PHONY: libpolyorb-soap.a libpolyorb-soap.a: polyorb_src_soap.gpr .PHONY: libpolyorb-srp.a libpolyorb-srp.a: polyorb_src_srp.gpr .PHONY: libpolyorb-ssl.a libpolyorb-ssl.a: polyorb_src_ssl.gpr .PHONY: libpolyorb-web_common.a libpolyorb-web_common.a: polyorb_src_web_common.gpr # Additional dependencies: polyorb_src.gpr: src/csupport.o polyorb_src_corba.gpr: polyorb_src_corba_dynamicany.gpr polyorb_src_corba_iop.gpr polyorb_src_corba_messaging.gpr polyorb_src_corba_portableinterceptor.gpr polyorb_src_corba_rtcorba.gpr ifeq (${HAVE_SSL},yes) polyorb_src_giop_iiop.gpr: polyorb_src_giop_iiop_security.gpr polyorb_src_giop_iiop_security_tls.gpr polyorb_src_setup.gpr: polyorb_src_setup_security.gpr polyorb_src_corba.gpr: polyorb_src_corba_security.gpr polyorb_src_corba_security_gssup.gpr polyorb_src.gpr: polyorb_src_security.gpr polyorb_src_security_gssup.gpr polyorb_src_security_x509.gpr polyorb_src_security_tls.gpr # Additional dependencies upon C files C_FILES += \ src/ssl/polyorb_ssl.c \ src/security/polyorb_asn1.c \ src/security/x509/polyorb_x509.c polyorb_src_ssl.gpr: src/ssl/polyorb_ssl.o polyorb_src_security.gpr: src/security/polyorb_asn1.o polyorb_src_security_x509.gpr: src/security/x509/polyorb_x509.o endif # Rule for compilation of C source files C_OBJECTS=${C_FILES:.c=.o} ${C_OBJECTS}: %.o: ${top_srcdir}/%.c ${CC_FOR_TARGET} -c -o $@ -I${top_builddir}/src ${CPPFLAGS} ${CFLAGS} ${CFLAGS_FOR_TARGET} $< ### No additions to C_FILES / C_OBJECTS beyond this point # The mkdir.flag targets are used to create the necessary directories. There is # one ALI directory for each project file (for example, ali/src_corba is the # ALI directory for projects/polyorb_src_corba.gpr). There is also a single # library directory (lib) shared by all project files. # Note: This would be unnecessary if we used the -p switch of gnatmake, # but we want this to work with older versions of gnatmake that do not # support -p (this option was introduced in GNAT 6.0). # WAG: 5.04 ALI_MKDIR_FLAGS = ${patsubst %.gpr,ali/%/mkdir.flag,${PROJECT_FILES}} C_MKDIR_FLAGS = ${patsubst %,%mkdir.flag,${dir ${C_OBJECTS}}} MKDIR_FLAGS = ${ALI_MKDIR_FLAGS} ${C_MKDIR_FLAGS} lib/mkdir.flag ${MKDIR_FLAGS}: %/mkdir.flag: mkdir -p $* touch $@ # Note that each polyorb_foo.gpr target depends on ALL .../mkdir.flag targets, # because gnatmake needs to look at the ALI directories for imported # projects. PRJ_GNATMAKE_FLAGS := # This variable is used to pass additional per-project command line switches # to gnatmake. .PHONY: ${PROJECT_FILES} ${PROJECT_FILES}: %.gpr: \ ${MKDIR_FLAGS} \ perfect-hash \ polyorb-idl-stamps \ build-gen_codeset \ src/giop/polyorb-giop_p-code_sets-data.ads-stamp \ tools/po_catref/polyorb-giop_p-code_sets-description_data.ads-stamp ADA_PROJECT_PATH="${top_builddir}/projects${PATH_SEP}${top_srcdir}/projects${PATH_SEP}$$ADA_PROJECT_PATH" \ ${GNATMAKE_FOR_TARGET} -P $@ ${BASE_GNATMAKE_FLAGS} ${PRJ_GNATMAKE_FLAGS} ${GNATMAKE_FLAGS_FOR_TARGET} -bargs -E ########################## # examples and testsuite # ########################## # We treat the examples and testsuite directories the same. # Each subdirectory that has test (or example) programs should contain # local.gpr, and may contain one or more *.idl files. We use 'find' to find # all of the *.idl. # # In addition, if there are any idl files, we need to define the flags to use # with idlac, and make the test target depend on building the idl, like this: # ${current_dir}<...>.idl-stamp: idlac_flags := <...> # ${test_target}: ${current_dir}<...>.idl-stamp # Note that ${current_dir} contains a trailing slash. # local.gpr should contain: # with "polyorb", "polyorb_test_common"; # # project local is # # Dir := external ("Test_Dir"); # Obj_Dir := PolyORB_Test_Common.Build_Dir & Dir; # for Object_Dir use Obj_Dir; # for Source_Dirs use (Obj_Dir, PolyORB_Test_Common.Source_Dir & Dir); # # package Compiler is # # for Default_Switches ("Ada") # use PolyORB_Test_Common.Compiler'Default_Switches ("Ada"); # # end Compiler; # # for Main use (<...>); # # end local; # The only variable part is the Mains. test_dirs := ${top_srcdir}/examples ${top_srcdir}/testsuite test_idls := ${shell find ${test_dirs} -name '*.idl' 2> /dev/null} test_idls := ${patsubst ${top_srcdir}/%,%,${test_idls}} test_idl_stamps := ${patsubst %.idl,%.idl-stamp,${test_idls}} self_idl_stamps += ${test_idl_stamps} # Include all the Makefile.local files. @LOCAL_MAKEFILES@ test_targets := ${sort ${test_targets}} .PHONY: ${test_targets} ${test_targets}: %/build-test: ADA_PROJECT_PATH="${top_builddir}/projects${PATH_SEP}${top_srcdir}/projects${PATH_SEP}$$ADA_PROJECT_PATH" \ ${GNATMAKE_FOR_TARGET} "-XTest_Dir=$*" -P ${top_srcdir}/$*/local.gpr ${BASE_GNATMAKE_FLAGS} ${GNATMAKE_FLAGS_FOR_TARGET} -bargs -E # Set active_tests to a subset of test_targets -- remove the ones that are for # application personalities that were not configured. Note: examples/polyorb # and testsuite/core are built unconditionally, independent of personalities. # Note that two tests are for multiple personalities: examples/bbs is built # only if we are configured for both corba and dsa, and # examples/corba/all_types is built only if we are configured for both corba # and moma. Also remove the ones that depend on ssl, if we're not configured # with ssl support. active_tests := ${test_targets} ifneq (${HAVE_SSL},yes) active_tests := ${filter-out examples/corba/secure_echo/%,${active_tests}} endif ifneq "${filter corba, ${APPLI_LIST}}" "corba" active_tests := ${filter-out examples/corba/%,${active_tests}} active_tests := ${filter-out testsuite/corba/%,${active_tests}} active_tests := ${filter-out examples/bbs/%,${active_tests}} endif ifneq "${filter dsa, ${APPLI_LIST}}" "dsa" active_tests := ${filter-out examples/dsa/%,${active_tests}} active_tests := ${filter-out testsuite/acats/%,${active_tests}} active_tests := ${filter-out examples/bbs/%,${active_tests}} endif ifneq "${filter moma, ${APPLI_LIST}}" "moma" active_tests := ${filter-out examples/moma/%,${active_tests}} active_tests := ${filter-out examples/corba/all_types/%,${active_tests}} endif ifneq "${filter aws, ${APPLI_LIST}}" "aws" active_tests := ${filter-out examples/aws/%,${active_tests}} endif ifneq "${HAVE_ADA_DYNAMIC_PRIORITIES}" "true" active_tests := ${filter-out examples/corba/rtcorba/%,${active_tests}} active_tests := ${filter-out testsuite/corba/rtcorba/%,${active_tests}} endif #???The following are disabled for now, because of minor build problems: skip_tests := examples/bbs \ examples/dsa \ testsuite/acats/CXE1001 \ testsuite/acats/CXE2001 \ testsuite/acats/CXE4001 \ testsuite/acats/CXE4002 \ testsuite/acats/CXE4005 \ testsuite/acats/CXE4006 skip_tests := ${patsubst %,%/build-test,${skip_tests}} active_tests := ${filter-out ${skip_tests},${active_tests}} active_tests := ${sort ${active_tests}} .PHONY: print_active_tests print_active_tests: @echo "All tests: ${patsubst %/build-test,%,${test_targets}}" @echo "Tests to build: ${patsubst %/build-test,%,${active_tests}}" .PHONY: testsuite testsuite: print_active_tests ${active_tests} # Create the 'examples' target as a subset of 'testsuite' -- just the ones # under the 'examples' subdirectory: active_examples := ${filter examples/%,${active_tests}} .PHONY: examples examples: ${active_examples} .PHONY: run_tests run_tests: cd testsuite && ./testsuite.py --diffs --testsuite-src-dir=${top_srcdir}/testsuite # 'all' depends on either build-iac or build-idlac; we might as well build # both, here. We run_tests via recursive make, rather than having all-and-test # depend on run_tests, so it works for parallel make (run_tests should not # run concurrently with the other stuff). .PHONY: all-and-test all-and-test: all build-iac build-idlac examples testsuite ${MAKE} run_tests ################################################################ # Rules for running idlac on .idl files # These patterns are all the same, except the directories where they expect to # find the .idl file, and the directories where they put the .idl-stamp files. # Each target that is part of xxx_idl_stamps should have set idlac_flags # as a target-specific variable. ${idls_idl_stamps}: %.idl-stamp: ${top_srcdir}/idls/%.idl mkdir -p ${dir $@} cd ${dir $@} && ${idlac} ${idlac_flags} $< touch $@ ${interop_corba_idl_stamps}: src/corba/%.idl-stamp: ${top_srcdir}/idls/Interop/%.idl mkdir -p ${dir $@} cd ${dir $@} && ${idlac} ${idlac_flags} $< touch $@ ${interop_corba_iop_idl_stamps}: src/corba/iop/%.idl-stamp: ${top_srcdir}/idls/Interop/%.idl mkdir -p ${dir $@} cd ${dir $@} && ${idlac} ${idlac_flags} $< touch $@ ${interop_corba_security_idl_stamps}: src/corba/security/%.idl-stamp: ${top_srcdir}/idls/Interop/%.idl mkdir -p ${dir $@} cd ${dir $@} && ${idlac} ${idlac_flags} $< touch $@ ${interop_corba_security_gssup_idl_stamps}: src/corba/security/gssup/%.idl-stamp: ${top_srcdir}/idls/Interop/%.idl mkdir -p ${dir $@} cd ${dir $@} && ${idlac} ${idlac_flags} $< touch $@ ${misc_corba_dynamicany_idl_stamps}: src/corba/dynamicany/%.idl-stamp: ${top_srcdir}/idls/Misc/%.idl mkdir -p ${dir $@} cd ${dir $@} && ${idlac} ${idlac_flags} $< touch $@ ${misc_corba_messaging_idl_stamps}: src/corba/messaging/%.idl-stamp: ${top_srcdir}/idls/Misc/%.idl mkdir -p ${dir $@} cd ${dir $@} && ${idlac} ${idlac_flags} $< touch $@ ${misc_corba_portableinterceptor_idl_stamps}: src/corba/portableinterceptor/%.idl-stamp: ${top_srcdir}/idls/Misc/%.idl mkdir -p ${dir $@} cd ${dir $@} && ${idlac} ${idlac_flags} $< touch $@ ${rtcorba_corba_rtcorba_idl_stamps}: src/corba/rtcorba/%.idl-stamp: ${top_srcdir}/idls/RTCORBA/%.idl mkdir -p ${dir $@} cd ${dir $@} && ${idlac} ${idlac_flags} $< touch $@ ${self_idl_stamps}: %.idl-stamp: ${top_srcdir}/%.idl mkdir -p ${dir $@} cd ${dir $@} && ${idlac} ${idlac_flags} $< touch $@ ${all_idl_stamps}: ${IDLAC_bin} ${IDLAC_WRAPPER} ################# # Documentation # ################# # We use the old make files for the documentation; recursively invoke make in # the docs directory. .PHONY: docs docs: (cd docs && ${MAKE}) ################################################################ # Installation prefix=@prefix@ .PHONY: install install: all @echo "Install prefix: ${prefix}" @echo " Sources dir: ${top_srcdir}" @echo " Build dir: ${top_builddir}" ${INSTALL} -d ${prefix}/bin ${RM} -fr "${prefix}/lib/gnat/polyorb" ${INSTALL} -d ${prefix}/lib/gnat/polyorb ${INSTALL} -d ${prefix}/lib/polyorb ${INSTALL} -d ${prefix}/lib/polyorb/static ${RM} -fr "${prefix}/include/polyorb" ${INSTALL} -d ${prefix}/include/polyorb for comp in ${COMPILER_EXES}; do \ ${INSTALL_BIN} ${top_builddir}/compilers/$${comp}${COMPILER_EXE_SUFFIX} ${prefix}/bin; \ : Special case, symlink iac as idlac for backwards compatibility; \ if [ `basename $${comp}` = iac ]; then \ (cd ${prefix}/bin && ${RM} -f idlac${TOOL_EXE_SUFFIX} && ${LN_S} iac${TOOL_EXE_SUFFIX} idlac${TOOL_EXE_SUFFIX}); \ fi; \ done ${INSTALL_BIN} ${top_builddir}/tools/po_cos_naming/po_cos_naming${TOOL_EXE_SUFFIX} ${prefix}/bin ${INSTALL_BIN} ${top_builddir}/tools/po_cos_naming/po_cos_naming_shell${TOOL_EXE_SUFFIX} ${prefix}/bin ${INSTALL_BIN} ${top_builddir}/tools/po_cos_naming/ir_ab_names${TOOL_EXE_SUFFIX} ${prefix}/bin ${INSTALL_BIN} ${top_builddir}/tools/po_ir/po_ir${TOOL_EXE_SUFFIX} ${prefix}/bin ${INSTALL_BIN} ${top_builddir}/tools/po_catref/po_catref${TOOL_EXE_SUFFIX} ${prefix}/bin ${INSTALL_BIN} ${top_builddir}/tools/po_createref/po_createref${TOOL_EXE_SUFFIX} ${prefix}/bin ${INSTALL_BIN} ${top_builddir}/tools/po_names/po_names${TOOL_EXE_SUFFIX} ${prefix}/bin ${INSTALL_BIN} ${top_builddir}/tools/po_dumpir/po_dumpir${TOOL_EXE_SUFFIX} ${prefix}/bin ${INSTALL_SCRIPT} ${top_builddir}/polyorb-config ${prefix}/bin ls ${top_builddir}/lib/*.a | ${XARGS_I} ${INSTALL} -m 444 {} ${prefix}/lib/polyorb/static ls ${top_srcdir}/projects-distrib/*.gpr | ${XARGS_I} ${INSTALL} -m 444 {} ${prefix}/lib/gnat ls ${top_builddir}/projects-distrib/*.gpr | ${XARGS_I} ${INSTALL} -m 444 {} ${prefix}/lib/gnat ls ${top_srcdir}/projects-distrib/polyorb/*.gpr | ${XARGS_I} ${INSTALL} -m 444 {} ${prefix}/lib/gnat/polyorb ls ${top_builddir}/projects-distrib/polyorb/*.gpr | ${XARGS_I} ${INSTALL} -m 444 {} ${prefix}/lib/gnat/polyorb (find \ ${top_builddir}/src \ ${top_builddir}/cos \ ${top_builddir}/idls \ ${top_srcdir}/src \ ${top_srcdir}/cos \ ${top_srcdir}/idls \ -name '*.ads' -o -name '*.adb' -o -name '*.idl') | \ ${XARGS_I} ${INSTALL} -m 444 {} ${prefix}/include/polyorb (find \ ${top_builddir}/ali \ -name '*.ali' \ -a ! -name 'polyorb-dsa_p-partitions.ali' \ -a ! -name 'polyorb-dsa_p-storages-config.ali' \ -a ! -name 'polyorb-partition_elaboration.ali') | \ ${XARGS_I} ${INSTALL} -m 444 {} ${prefix}/lib/polyorb # Install documentation only if it has been built locally, or # pre-built and packaged with sources. if [ -r docs/polyorb_ug.html ]; \ then \ (cd docs && ${MAKE} install-data-local prefix="${prefix}"); \ elif [ -r $(top_srcdir)/docs/polyorb_ug.html ]; \ then \ (cd docs && ${MAKE} install-data-local prefix="${prefix}" doc_build_dir="$(top_srcdir)/docs/"); \ fi # polyorb-dsa_p-partitions.ali is a special case above. # It is never installed, so that this unit is recompiled for each application # by gnatdist. This is necessary because two compilations must occur: # receiving stubs for the main partition, and calling stubs for others. # # Note that any change of the location where DSA application personality # files are installed (relative to ${prefix}) must be reflected in # gnatdist. # # install-data-local (as opposed to install) is used for installing the # documentation, in order to avoid trying to rebuild the documentation, since # users might not have tools like TeX. ################################################################ force:: .PHONY: clean distclean clean: ${RM} -f ${all_idl_stamps} ./cos/ir/orb.idl-stamp # ???and more ${RM} -f ${idlac_output_files} find . -name '*.ali' -o -name '*.o' | xargs ${RM} -f ${RM} -f lib/lib*.a ${RM} -f ${all_example_exes} (cd compilers && ${RM} -f ${COMPILER_EXES}) ${RM} -f ${MKDIR_FLAGS} ${RM} -f ${IAC_NODES_STAMPS} ${RM} -f ${IAC_NODES_SOURCES} ${RM} -f src/soap/polyorb-http_methods.adb src/soap/polyorb-http_headers.adb ${RM} -f cos/ir/po_ir ${RM} -f cos/naming/ir_ab_names ${RM} -f cos/naming/po_cos_naming ${RM} -f cos/naming/po_cos_naming_shell ${RM} -f src/giop/gen_codeset ${RM} -f src/giop/polyorb-giop_p-code_sets-data.ads ${RM} -f src/giop/polyorb-giop_p-code_sets-data.ads-stamp ${RM} -f src/soap/perfect_hash.adb ${RM} -f src/soap/perfect_hash.ads ${RM} -f tools/po_catref/po_catref ${RM} -f tools/po_createref/po_createref ${RM} -f tools/po_catref/polyorb-giop_p-code_sets-description_data.ads ${RM} -f tools/po_catref/polyorb-giop_p-code_sets-description_data.ads-stamp ${RM} -f tools/po_dumpir/po_dumpir ${RM} -f tools/po_names/po_names distclean: clean ${SHELL} ${top_srcdir}/support/cleanup-conf-files ${RM} -f config.* .SUFFIXES: .c .o # This tells make to delete half-baked files, as recommended by section 5.4 of # the GNU Make manual. .DELETE_ON_ERROR: idlac_output_files := \ cos/event/coseventchanneladmin-consumeradmin-skel.adb \ cos/event/coseventchanneladmin-consumeradmin-skel.ads \ cos/event/coseventchanneladmin-eventchannel-skel.adb \ cos/event/coseventchanneladmin-eventchannel-skel.ads \ cos/event/coseventchanneladmin-proxypullconsumer-skel.adb \ cos/event/coseventchanneladmin-proxypullconsumer-skel.ads \ cos/event/coseventchanneladmin-proxypullsupplier-skel.adb \ cos/event/coseventchanneladmin-proxypullsupplier-skel.ads \ cos/event/coseventchanneladmin-proxypushconsumer-skel.adb \ cos/event/coseventchanneladmin-proxypushconsumer-skel.ads \ cos/event/coseventchanneladmin-proxypushsupplier-skel.adb \ cos/event/coseventchanneladmin-proxypushsupplier-skel.ads \ cos/event/coseventchanneladmin-supplieradmin-skel.adb \ cos/event/coseventchanneladmin-supplieradmin-skel.ads \ cos/event/coseventcomm-pullconsumer-skel.adb \ cos/event/coseventcomm-pullconsumer-skel.ads \ cos/event/coseventcomm-pullsupplier-skel.adb \ cos/event/coseventcomm-pullsupplier-skel.ads \ cos/event/coseventcomm-pushconsumer-skel.adb \ cos/event/coseventcomm-pushconsumer-skel.ads \ cos/event/coseventcomm-pushsupplier-skel.adb \ cos/event/coseventcomm-pushsupplier-skel.ads \ cos/event/costypedeventchanneladmin-typedconsumeradmin-skel.adb \ cos/event/costypedeventchanneladmin-typedconsumeradmin-skel.ads \ cos/event/costypedeventchanneladmin-typedeventchannel-skel.adb \ cos/event/costypedeventchanneladmin-typedeventchannel-skel.ads \ cos/event/costypedeventchanneladmin-typedproxypullsupplier-skel.adb \ cos/event/costypedeventchanneladmin-typedproxypullsupplier-skel.ads \ cos/event/costypedeventchanneladmin-typedproxypushconsumer-skel.adb \ cos/event/costypedeventchanneladmin-typedproxypushconsumer-skel.ads \ cos/event/costypedeventchanneladmin-typedsupplieradmin-skel.adb \ cos/event/costypedeventchanneladmin-typedsupplieradmin-skel.ads \ cos/event/costypedeventcomm-typedpullsupplier-skel.adb \ cos/event/costypedeventcomm-typedpullsupplier-skel.ads \ cos/event/costypedeventcomm-typedpushconsumer-skel.adb \ cos/event/costypedeventcomm-typedpushconsumer-skel.ads \ cos/naming/cosnaming-bindingiterator-skel.adb \ cos/naming/cosnaming-bindingiterator-skel.ads \ cos/naming/cosnaming-namingcontextext-skel.adb \ cos/naming/cosnaming-namingcontextext-skel.ads \ cos/naming/cosnaming-namingcontext-skel.adb \ cos/naming/cosnaming-namingcontext-skel.ads \ cos/notification/cosnotification-adminpropertiesadmin-skel.adb \ cos/notification/cosnotification-adminpropertiesadmin-skel.ads \ cos/notification/cosnotification-qosadmin-skel.adb \ cos/notification/cosnotification-qosadmin-skel.ads \ cos/notification/cosnotifychanneladmin-consumeradmin-skel.adb \ cos/notification/cosnotifychanneladmin-consumeradmin-skel.ads \ cos/notification/cosnotifychanneladmin-eventchannelfactory-skel.adb \ cos/notification/cosnotifychanneladmin-eventchannelfactory-skel.ads \ cos/notification/cosnotifychanneladmin-eventchannel-skel.adb \ cos/notification/cosnotifychanneladmin-eventchannel-skel.ads \ cos/notification/cosnotifychanneladmin-proxyconsumer-skel.adb \ cos/notification/cosnotifychanneladmin-proxyconsumer-skel.ads \ cos/notification/cosnotifychanneladmin-proxypullconsumer-skel.adb \ cos/notification/cosnotifychanneladmin-proxypullconsumer-skel.ads \ cos/notification/cosnotifychanneladmin-proxypullsupplier-skel.adb \ cos/notification/cosnotifychanneladmin-proxypullsupplier-skel.ads \ cos/notification/cosnotifychanneladmin-proxypushconsumer-skel.adb \ cos/notification/cosnotifychanneladmin-proxypushconsumer-skel.ads \ cos/notification/cosnotifychanneladmin-proxypushsupplier-skel.adb \ cos/notification/cosnotifychanneladmin-proxypushsupplier-skel.ads \ cos/notification/cosnotifychanneladmin-proxysupplier-skel.adb \ cos/notification/cosnotifychanneladmin-proxysupplier-skel.ads \ cos/notification/cosnotifychanneladmin-sequenceproxypullconsumer-skel.adb \ cos/notification/cosnotifychanneladmin-sequenceproxypullconsumer-skel.ads \ cos/notification/cosnotifychanneladmin-sequenceproxypullsupplier-skel.adb \ cos/notification/cosnotifychanneladmin-sequenceproxypullsupplier-skel.ads \ cos/notification/cosnotifychanneladmin-sequenceproxypushconsumer-skel.adb \ cos/notification/cosnotifychanneladmin-sequenceproxypushconsumer-skel.ads \ cos/notification/cosnotifychanneladmin-sequenceproxypushsupplier-skel.adb \ cos/notification/cosnotifychanneladmin-sequenceproxypushsupplier-skel.ads \ cos/notification/cosnotifychanneladmin-structuredproxypullconsumer-skel.adb \ cos/notification/cosnotifychanneladmin-structuredproxypullconsumer-skel.ads \ cos/notification/cosnotifychanneladmin-structuredproxypullsupplier-skel.adb \ cos/notification/cosnotifychanneladmin-structuredproxypullsupplier-skel.ads \ cos/notification/cosnotifychanneladmin-structuredproxypushconsumer-skel.adb \ cos/notification/cosnotifychanneladmin-structuredproxypushconsumer-skel.ads \ cos/notification/cosnotifychanneladmin-structuredproxypushsupplier-skel.adb \ cos/notification/cosnotifychanneladmin-structuredproxypushsupplier-skel.ads \ cos/notification/cosnotifychanneladmin-supplieradmin-skel.adb \ cos/notification/cosnotifychanneladmin-supplieradmin-skel.ads \ cos/notification/cosnotifycomm-notifypublish-skel.adb \ cos/notification/cosnotifycomm-notifypublish-skel.ads \ cos/notification/cosnotifycomm-notifysubscribe-skel.adb \ cos/notification/cosnotifycomm-notifysubscribe-skel.ads \ cos/notification/cosnotifycomm-pullconsumer-skel.adb \ cos/notification/cosnotifycomm-pullconsumer-skel.ads \ cos/notification/cosnotifycomm-pullsupplier-skel.adb \ cos/notification/cosnotifycomm-pullsupplier-skel.ads \ cos/notification/cosnotifycomm-pushconsumer-skel.adb \ cos/notification/cosnotifycomm-pushconsumer-skel.ads \ cos/notification/cosnotifycomm-pushsupplier-skel.adb \ cos/notification/cosnotifycomm-pushsupplier-skel.ads \ cos/notification/cosnotifycomm-sequencepullconsumer-skel.adb \ cos/notification/cosnotifycomm-sequencepullconsumer-skel.ads \ cos/notification/cosnotifycomm-sequencepullsupplier-skel.adb \ cos/notification/cosnotifycomm-sequencepullsupplier-skel.ads \ cos/notification/cosnotifycomm-sequencepushconsumer-skel.adb \ cos/notification/cosnotifycomm-sequencepushconsumer-skel.ads \ cos/notification/cosnotifycomm-sequencepushsupplier-skel.adb \ cos/notification/cosnotifycomm-sequencepushsupplier-skel.ads \ cos/notification/cosnotifycomm-structuredpullconsumer-skel.adb \ cos/notification/cosnotifycomm-structuredpullconsumer-skel.ads \ cos/notification/cosnotifycomm-structuredpullsupplier-skel.adb \ cos/notification/cosnotifycomm-structuredpullsupplier-skel.ads \ cos/notification/cosnotifycomm-structuredpushconsumer-skel.adb \ cos/notification/cosnotifycomm-structuredpushconsumer-skel.ads \ cos/notification/cosnotifycomm-structuredpushsupplier-skel.adb \ cos/notification/cosnotifycomm-structuredpushsupplier-skel.ads \ cos/notification/cosnotifyfilter-filteradmin-skel.adb \ cos/notification/cosnotifyfilter-filteradmin-skel.ads \ cos/notification/cosnotifyfilter-filterfactory-skel.adb \ cos/notification/cosnotifyfilter-filterfactory-skel.ads \ cos/notification/cosnotifyfilter-filter-skel.adb \ cos/notification/cosnotifyfilter-filter-skel.ads \ cos/notification/cosnotifyfilter-mappingfilter-skel.adb \ cos/notification/cosnotifyfilter-mappingfilter-skel.ads \ cos/time/costime-timeservice-skel.adb \ cos/time/costime-timeservice-skel.ads \ cos/time/costime-tio-skel.adb \ cos/time/costime-tio-skel.ads \ cos/time/costime-uto-skel.adb \ cos/time/costime-uto-skel.ads \ src/corba/conv_frame.ads \ src/corba/conv_frame-helper.adb \ src/corba/conv_frame-helper.ads \ src/corba/iop/iop.ads \ src/corba/iop/iop-codec.adb \ src/corba/iop/iop-codec.ads \ src/corba/iop/iop-codecfactory.adb \ src/corba/iop/iop-codecfactory.ads \ src/corba/iop/iop-codecfactory-helper.adb \ src/corba/iop/iop-codecfactory-helper.ads \ src/corba/iop/iop-codec-helper.adb \ src/corba/iop/iop-codec-helper.ads \ src/corba/iop/iop-helper.adb \ src/corba/iop/iop-helper.ads \ src/corba/security/csi.ads \ src/corba/security/csi-helper.adb \ src/corba/security/csi-helper.ads \ src/corba/security/csiiop.ads \ src/corba/security/csiiop-helper.adb \ src/corba/security/csiiop-helper.ads \ src/corba/security/gssup/gssup.ads \ src/corba/security/gssup/gssup-helper.adb \ src/corba/security/gssup/gssup-helper.ads \ src/corba/dynamicany/dynamicany.adb \ src/corba/dynamicany/dynamicany.ads \ src/corba/dynamicany/dynamicany-dynany.adb \ src/corba/dynamicany/dynamicany-dynany.ads \ src/corba/dynamicany/dynamicany-dynanyfactory.adb \ src/corba/dynamicany/dynamicany-dynanyfactory.ads \ src/corba/dynamicany/dynamicany-dynanyfactory-helper.adb \ src/corba/dynamicany/dynamicany-dynanyfactory-helper.ads \ src/corba/dynamicany/dynamicany-dynany-helper.adb \ src/corba/dynamicany/dynamicany-dynany-helper.ads \ src/corba/dynamicany/dynamicany-dynarray.adb \ src/corba/dynamicany/dynamicany-dynarray.ads \ src/corba/dynamicany/dynamicany-dynarray-helper.adb \ src/corba/dynamicany/dynamicany-dynarray-helper.ads \ src/corba/dynamicany/dynamicany-dynenum.adb \ src/corba/dynamicany/dynamicany-dynenum.ads \ src/corba/dynamicany/dynamicany-dynenum-helper.adb \ src/corba/dynamicany/dynamicany-dynenum-helper.ads \ src/corba/dynamicany/dynamicany-dynfixed.adb \ src/corba/dynamicany/dynamicany-dynfixed.ads \ src/corba/dynamicany/dynamicany-dynfixed-helper.adb \ src/corba/dynamicany/dynamicany-dynfixed-helper.ads \ src/corba/dynamicany/dynamicany-dynsequence.adb \ src/corba/dynamicany/dynamicany-dynsequence.ads \ src/corba/dynamicany/dynamicany-dynsequence-helper.adb \ src/corba/dynamicany/dynamicany-dynsequence-helper.ads \ src/corba/dynamicany/dynamicany-dynstruct.adb \ src/corba/dynamicany/dynamicany-dynstruct.ads \ src/corba/dynamicany/dynamicany-dynstruct-helper.adb \ src/corba/dynamicany/dynamicany-dynstruct-helper.ads \ src/corba/dynamicany/dynamicany-dynunion.adb \ src/corba/dynamicany/dynamicany-dynunion.ads \ src/corba/dynamicany/dynamicany-dynunion-helper.adb \ src/corba/dynamicany/dynamicany-dynunion-helper.ads \ src/corba/dynamicany/dynamicany-dynvalue.adb \ src/corba/dynamicany/dynamicany-dynvalue.ads \ src/corba/dynamicany/dynamicany-dynvaluebox.adb \ src/corba/dynamicany/dynamicany-dynvaluebox.ads \ src/corba/dynamicany/dynamicany-dynvaluebox-helper.adb \ src/corba/dynamicany/dynamicany-dynvaluebox-helper.ads \ src/corba/dynamicany/dynamicany-dynvaluecommon.adb \ src/corba/dynamicany/dynamicany-dynvaluecommon.ads \ src/corba/dynamicany/dynamicany-dynvaluecommon-helper.adb \ src/corba/dynamicany/dynamicany-dynvaluecommon-helper.ads \ src/corba/dynamicany/dynamicany-dynvalue-helper.adb \ src/corba/dynamicany/dynamicany-dynvalue-helper.ads \ src/corba/dynamicany/dynamicany-helper.adb \ src/corba/dynamicany/dynamicany-helper.ads \ src/corba/messaging/messaging.ads \ src/corba/messaging/messaging-helper.adb \ src/corba/messaging/messaging-helper.ads \ src/corba/portableinterceptor/portableinterceptor.adb \ src/corba/portableinterceptor/portableinterceptor.ads \ src/corba/portableinterceptor/portableinterceptor-clientrequestinfo.adb \ src/corba/portableinterceptor/portableinterceptor-clientrequestinfo.ads \ src/corba/portableinterceptor/portableinterceptor-clientrequestinfo-helper.adb \ src/corba/portableinterceptor/portableinterceptor-clientrequestinfo-helper.ads \ src/corba/portableinterceptor/portableinterceptor-clientrequestinterceptor.adb \ src/corba/portableinterceptor/portableinterceptor-clientrequestinterceptor.ads \ src/corba/portableinterceptor/portableinterceptor-clientrequestinterceptor-helper.adb \ src/corba/portableinterceptor/portableinterceptor-clientrequestinterceptor-helper.ads \ src/corba/portableinterceptor/portableinterceptor-current.adb \ src/corba/portableinterceptor/portableinterceptor-current.ads \ src/corba/portableinterceptor/portableinterceptor-current-helper.adb \ src/corba/portableinterceptor/portableinterceptor-current-helper.ads \ src/corba/portableinterceptor/portableinterceptor-helper.adb \ src/corba/portableinterceptor/portableinterceptor-helper.ads \ src/corba/portableinterceptor/portableinterceptor-interceptor.adb \ src/corba/portableinterceptor/portableinterceptor-interceptor.ads \ src/corba/portableinterceptor/portableinterceptor-interceptor-helper.adb \ src/corba/portableinterceptor/portableinterceptor-interceptor-helper.ads \ src/corba/portableinterceptor/portableinterceptor-iorinfo.adb \ src/corba/portableinterceptor/portableinterceptor-iorinfo.ads \ src/corba/portableinterceptor/portableinterceptor-iorinfo-helper.adb \ src/corba/portableinterceptor/portableinterceptor-iorinfo-helper.ads \ src/corba/portableinterceptor/portableinterceptor-iorinterceptor_3_0.adb \ src/corba/portableinterceptor/portableinterceptor-iorinterceptor_3_0.ads \ src/corba/portableinterceptor/portableinterceptor-iorinterceptor_3_0-helper.adb \ src/corba/portableinterceptor/portableinterceptor-iorinterceptor_3_0-helper.ads \ src/corba/portableinterceptor/portableinterceptor-iorinterceptor.adb \ src/corba/portableinterceptor/portableinterceptor-iorinterceptor.ads \ src/corba/portableinterceptor/portableinterceptor-iorinterceptor-helper.adb \ src/corba/portableinterceptor/portableinterceptor-iorinterceptor-helper.ads \ src/corba/portableinterceptor/portableinterceptor-orbinitializer.adb \ src/corba/portableinterceptor/portableinterceptor-orbinitializer.ads \ src/corba/portableinterceptor/portableinterceptor-orbinitializer-helper.adb \ src/corba/portableinterceptor/portableinterceptor-orbinitializer-helper.ads \ src/corba/portableinterceptor/portableinterceptor-orbinitinfo.adb \ src/corba/portableinterceptor/portableinterceptor-orbinitinfo.ads \ src/corba/portableinterceptor/portableinterceptor-orbinitinfo-helper.adb \ src/corba/portableinterceptor/portableinterceptor-orbinitinfo-helper.ads \ src/corba/portableinterceptor/portableinterceptor-policyfactory.adb \ src/corba/portableinterceptor/portableinterceptor-policyfactory.ads \ src/corba/portableinterceptor/portableinterceptor-policyfactory-helper.adb \ src/corba/portableinterceptor/portableinterceptor-policyfactory-helper.ads \ src/corba/portableinterceptor/portableinterceptor-requestinfo.adb \ src/corba/portableinterceptor/portableinterceptor-requestinfo.ads \ src/corba/portableinterceptor/portableinterceptor-requestinfo-helper.adb \ src/corba/portableinterceptor/portableinterceptor-requestinfo-helper.ads \ src/corba/portableinterceptor/portableinterceptor-serverrequestinfo.adb \ src/corba/portableinterceptor/portableinterceptor-serverrequestinfo.ads \ src/corba/portableinterceptor/portableinterceptor-serverrequestinfo-helper.adb \ src/corba/portableinterceptor/portableinterceptor-serverrequestinfo-helper.ads \ src/corba/portableinterceptor/portableinterceptor-serverrequestinterceptor.adb \ src/corba/portableinterceptor/portableinterceptor-serverrequestinterceptor.ads \ src/corba/portableinterceptor/portableinterceptor-serverrequestinterceptor-helper.adb \ src/corba/portableinterceptor/portableinterceptor-serverrequestinterceptor-helper.ads \ src/corba/portableinterceptor/dynamic.ads \ src/corba/portableinterceptor/dynamic-helper.adb \ src/corba/portableinterceptor/dynamic-helper.ads \ src/corba/rtcorba/rtcosscheduling.adb \ src/corba/rtcorba/rtcosscheduling.ads \ src/corba/rtcorba/rtcosscheduling-clientscheduler.adb \ src/corba/rtcorba/rtcosscheduling-clientscheduler.ads \ src/corba/rtcorba/rtcosscheduling-clientscheduler-helper.adb \ src/corba/rtcorba/rtcosscheduling-clientscheduler-helper.ads \ src/corba/rtcorba/rtcosscheduling-helper.adb \ src/corba/rtcorba/rtcosscheduling-helper.ads \ src/corba/rtcorba/rtcosscheduling-serverscheduler.adb \ src/corba/rtcorba/rtcosscheduling-serverscheduler.ads \ src/corba/rtcorba/rtcosscheduling-serverscheduler-helper.adb \ src/corba/rtcorba/rtcosscheduling-serverscheduler-helper.ads \ idls/cos/event/coseventchanneladmin.adb \ idls/cos/event/coseventchanneladmin.ads \ idls/cos/event/coseventchanneladmin-consumeradmin.adb \ idls/cos/event/coseventchanneladmin-consumeradmin.ads \ idls/cos/event/coseventchanneladmin-consumeradmin-helper.adb \ idls/cos/event/coseventchanneladmin-consumeradmin-helper.ads \ idls/cos/event/coseventchanneladmin-eventchannel.adb \ idls/cos/event/coseventchanneladmin-eventchannel.ads \ idls/cos/event/coseventchanneladmin-eventchannel-helper.adb \ idls/cos/event/coseventchanneladmin-eventchannel-helper.ads \ idls/cos/event/coseventchanneladmin-helper.adb \ idls/cos/event/coseventchanneladmin-helper.ads \ idls/cos/event/coseventchanneladmin-proxypullconsumer.adb \ idls/cos/event/coseventchanneladmin-proxypullconsumer.ads \ idls/cos/event/coseventchanneladmin-proxypullconsumer-helper.adb \ idls/cos/event/coseventchanneladmin-proxypullconsumer-helper.ads \ idls/cos/event/coseventchanneladmin-proxypullsupplier.adb \ idls/cos/event/coseventchanneladmin-proxypullsupplier.ads \ idls/cos/event/coseventchanneladmin-proxypullsupplier-helper.adb \ idls/cos/event/coseventchanneladmin-proxypullsupplier-helper.ads \ idls/cos/event/coseventchanneladmin-proxypushconsumer.adb \ idls/cos/event/coseventchanneladmin-proxypushconsumer.ads \ idls/cos/event/coseventchanneladmin-proxypushconsumer-helper.adb \ idls/cos/event/coseventchanneladmin-proxypushconsumer-helper.ads \ idls/cos/event/coseventchanneladmin-proxypushsupplier.adb \ idls/cos/event/coseventchanneladmin-proxypushsupplier.ads \ idls/cos/event/coseventchanneladmin-proxypushsupplier-helper.adb \ idls/cos/event/coseventchanneladmin-proxypushsupplier-helper.ads \ idls/cos/event/coseventchanneladmin-supplieradmin.adb \ idls/cos/event/coseventchanneladmin-supplieradmin.ads \ idls/cos/event/coseventchanneladmin-supplieradmin-helper.adb \ idls/cos/event/coseventchanneladmin-supplieradmin-helper.ads \ idls/cos/event/coseventcomm.adb \ idls/cos/event/coseventcomm.ads \ idls/cos/event/coseventcomm-helper.adb \ idls/cos/event/coseventcomm-helper.ads \ idls/cos/event/coseventcomm-pullconsumer.adb \ idls/cos/event/coseventcomm-pullconsumer.ads \ idls/cos/event/coseventcomm-pullconsumer-helper.adb \ idls/cos/event/coseventcomm-pullconsumer-helper.ads \ idls/cos/event/coseventcomm-pullsupplier.adb \ idls/cos/event/coseventcomm-pullsupplier.ads \ idls/cos/event/coseventcomm-pullsupplier-helper.adb \ idls/cos/event/coseventcomm-pullsupplier-helper.ads \ idls/cos/event/coseventcomm-pushconsumer.adb \ idls/cos/event/coseventcomm-pushconsumer.ads \ idls/cos/event/coseventcomm-pushconsumer-helper.adb \ idls/cos/event/coseventcomm-pushconsumer-helper.ads \ idls/cos/event/coseventcomm-pushsupplier.adb \ idls/cos/event/coseventcomm-pushsupplier.ads \ idls/cos/event/coseventcomm-pushsupplier-helper.adb \ idls/cos/event/coseventcomm-pushsupplier-helper.ads \ idls/cos/event/costypedeventchanneladmin.adb \ idls/cos/event/costypedeventchanneladmin.ads \ idls/cos/event/costypedeventchanneladmin-helper.adb \ idls/cos/event/costypedeventchanneladmin-helper.ads \ idls/cos/event/costypedeventchanneladmin-typedconsumeradmin.adb \ idls/cos/event/costypedeventchanneladmin-typedconsumeradmin.ads \ idls/cos/event/costypedeventchanneladmin-typedconsumeradmin-helper.adb \ idls/cos/event/costypedeventchanneladmin-typedconsumeradmin-helper.ads \ idls/cos/event/costypedeventchanneladmin-typedeventchannel.adb \ idls/cos/event/costypedeventchanneladmin-typedeventchannel.ads \ idls/cos/event/costypedeventchanneladmin-typedeventchannel-helper.adb \ idls/cos/event/costypedeventchanneladmin-typedeventchannel-helper.ads \ idls/cos/event/costypedeventchanneladmin-typedproxypullsupplier.adb \ idls/cos/event/costypedeventchanneladmin-typedproxypullsupplier.ads \ idls/cos/event/costypedeventchanneladmin-typedproxypullsupplier-helper.adb \ idls/cos/event/costypedeventchanneladmin-typedproxypullsupplier-helper.ads \ idls/cos/event/costypedeventchanneladmin-typedproxypushconsumer.adb \ idls/cos/event/costypedeventchanneladmin-typedproxypushconsumer.ads \ idls/cos/event/costypedeventchanneladmin-typedproxypushconsumer-helper.adb \ idls/cos/event/costypedeventchanneladmin-typedproxypushconsumer-helper.ads \ idls/cos/event/costypedeventchanneladmin-typedsupplieradmin.adb \ idls/cos/event/costypedeventchanneladmin-typedsupplieradmin.ads \ idls/cos/event/costypedeventchanneladmin-typedsupplieradmin-helper.adb \ idls/cos/event/costypedeventchanneladmin-typedsupplieradmin-helper.ads \ idls/cos/event/costypedeventcomm.ads \ idls/cos/event/costypedeventcomm-typedpullsupplier.adb \ idls/cos/event/costypedeventcomm-typedpullsupplier.ads \ idls/cos/event/costypedeventcomm-typedpullsupplier-helper.adb \ idls/cos/event/costypedeventcomm-typedpullsupplier-helper.ads \ idls/cos/event/costypedeventcomm-typedpushconsumer.adb \ idls/cos/event/costypedeventcomm-typedpushconsumer.ads \ idls/cos/event/costypedeventcomm-typedpushconsumer-helper.adb \ idls/cos/event/costypedeventcomm-typedpushconsumer-helper.ads \ idls/cos/naming/cosnaming.ads \ idls/cos/naming/cosnaming-bindingiterator.adb \ idls/cos/naming/cosnaming-bindingiterator.ads \ idls/cos/naming/cosnaming-bindingiterator-helper.adb \ idls/cos/naming/cosnaming-bindingiterator-helper.ads \ idls/cos/naming/cosnaming-helper.adb \ idls/cos/naming/cosnaming-helper.ads \ idls/cos/naming/cosnaming-namingcontext.adb \ idls/cos/naming/cosnaming-namingcontext.ads \ idls/cos/naming/cosnaming-namingcontextext.adb \ idls/cos/naming/cosnaming-namingcontextext.ads \ idls/cos/naming/cosnaming-namingcontextext-helper.adb \ idls/cos/naming/cosnaming-namingcontextext-helper.ads \ idls/cos/naming/cosnaming-namingcontext-helper.adb \ idls/cos/naming/cosnaming-namingcontext-helper.ads \ idls/cos/notification/cosnotification.adb \ idls/cos/notification/cosnotification-adminpropertiesadmin.adb \ idls/cos/notification/cosnotification-adminpropertiesadmin.ads \ idls/cos/notification/cosnotification-adminpropertiesadmin-helper.adb \ idls/cos/notification/cosnotification-adminpropertiesadmin-helper.ads \ idls/cos/notification/cosnotification.ads \ idls/cos/notification/cosnotification-helper.adb \ idls/cos/notification/cosnotification-helper.ads \ idls/cos/notification/cosnotification-qosadmin.adb \ idls/cos/notification/cosnotification-qosadmin.ads \ idls/cos/notification/cosnotification-qosadmin-helper.adb \ idls/cos/notification/cosnotification-qosadmin-helper.ads \ idls/cos/notification/cosnotifychanneladmin.adb \ idls/cos/notification/cosnotifychanneladmin.ads \ idls/cos/notification/cosnotifychanneladmin-consumeradmin.adb \ idls/cos/notification/cosnotifychanneladmin-consumeradmin.ads \ idls/cos/notification/cosnotifychanneladmin-consumeradmin-helper.adb \ idls/cos/notification/cosnotifychanneladmin-consumeradmin-helper.ads \ idls/cos/notification/cosnotifychanneladmin-eventchannel.adb \ idls/cos/notification/cosnotifychanneladmin-eventchannel.ads \ idls/cos/notification/cosnotifychanneladmin-eventchannelfactory.adb \ idls/cos/notification/cosnotifychanneladmin-eventchannelfactory.ads \ idls/cos/notification/cosnotifychanneladmin-eventchannelfactory-helper.adb \ idls/cos/notification/cosnotifychanneladmin-eventchannelfactory-helper.ads \ idls/cos/notification/cosnotifychanneladmin-eventchannel-helper.adb \ idls/cos/notification/cosnotifychanneladmin-eventchannel-helper.ads \ idls/cos/notification/cosnotifychanneladmin-helper.adb \ idls/cos/notification/cosnotifychanneladmin-helper.ads \ idls/cos/notification/cosnotifychanneladmin-proxyconsumer.adb \ idls/cos/notification/cosnotifychanneladmin-proxyconsumer.ads \ idls/cos/notification/cosnotifychanneladmin-proxyconsumer-helper.adb \ idls/cos/notification/cosnotifychanneladmin-proxyconsumer-helper.ads \ idls/cos/notification/cosnotifychanneladmin-proxypullconsumer.adb \ idls/cos/notification/cosnotifychanneladmin-proxypullconsumer.ads \ idls/cos/notification/cosnotifychanneladmin-proxypullconsumer-helper.adb \ idls/cos/notification/cosnotifychanneladmin-proxypullconsumer-helper.ads \ idls/cos/notification/cosnotifychanneladmin-proxypullsupplier.adb \ idls/cos/notification/cosnotifychanneladmin-proxypullsupplier.ads \ idls/cos/notification/cosnotifychanneladmin-proxypullsupplier-helper.adb \ idls/cos/notification/cosnotifychanneladmin-proxypullsupplier-helper.ads \ idls/cos/notification/cosnotifychanneladmin-proxypushconsumer.adb \ idls/cos/notification/cosnotifychanneladmin-proxypushconsumer.ads \ idls/cos/notification/cosnotifychanneladmin-proxypushconsumer-helper.adb \ idls/cos/notification/cosnotifychanneladmin-proxypushconsumer-helper.ads \ idls/cos/notification/cosnotifychanneladmin-proxypushsupplier.adb \ idls/cos/notification/cosnotifychanneladmin-proxypushsupplier.ads \ idls/cos/notification/cosnotifychanneladmin-proxypushsupplier-helper.adb \ idls/cos/notification/cosnotifychanneladmin-proxypushsupplier-helper.ads \ idls/cos/notification/cosnotifychanneladmin-proxysupplier.adb \ idls/cos/notification/cosnotifychanneladmin-proxysupplier.ads \ idls/cos/notification/cosnotifychanneladmin-proxysupplier-helper.adb \ idls/cos/notification/cosnotifychanneladmin-proxysupplier-helper.ads \ idls/cos/notification/cosnotifychanneladmin-sequenceproxypullconsumer.adb \ idls/cos/notification/cosnotifychanneladmin-sequenceproxypullconsumer.ads \ idls/cos/notification/cosnotifychanneladmin-sequenceproxypullconsumer-helper.adb \ idls/cos/notification/cosnotifychanneladmin-sequenceproxypullconsumer-helper.ads \ idls/cos/notification/cosnotifychanneladmin-sequenceproxypullsupplier.adb \ idls/cos/notification/cosnotifychanneladmin-sequenceproxypullsupplier.ads \ idls/cos/notification/cosnotifychanneladmin-sequenceproxypullsupplier-helper.adb \ idls/cos/notification/cosnotifychanneladmin-sequenceproxypullsupplier-helper.ads \ idls/cos/notification/cosnotifychanneladmin-sequenceproxypushconsumer.adb \ idls/cos/notification/cosnotifychanneladmin-sequenceproxypushconsumer.ads \ idls/cos/notification/cosnotifychanneladmin-sequenceproxypushconsumer-helper.adb \ idls/cos/notification/cosnotifychanneladmin-sequenceproxypushconsumer-helper.ads \ idls/cos/notification/cosnotifychanneladmin-sequenceproxypushsupplier.adb \ idls/cos/notification/cosnotifychanneladmin-sequenceproxypushsupplier.ads \ idls/cos/notification/cosnotifychanneladmin-sequenceproxypushsupplier-helper.adb \ idls/cos/notification/cosnotifychanneladmin-sequenceproxypushsupplier-helper.ads \ idls/cos/notification/cosnotifychanneladmin-structuredproxypullconsumer.adb \ idls/cos/notification/cosnotifychanneladmin-structuredproxypullconsumer.ads \ idls/cos/notification/cosnotifychanneladmin-structuredproxypullconsumer-helper.adb \ idls/cos/notification/cosnotifychanneladmin-structuredproxypullconsumer-helper.ads \ idls/cos/notification/cosnotifychanneladmin-structuredproxypullsupplier.adb \ idls/cos/notification/cosnotifychanneladmin-structuredproxypullsupplier.ads \ idls/cos/notification/cosnotifychanneladmin-structuredproxypullsupplier-helper.adb \ idls/cos/notification/cosnotifychanneladmin-structuredproxypullsupplier-helper.ads \ idls/cos/notification/cosnotifychanneladmin-structuredproxypushconsumer.adb \ idls/cos/notification/cosnotifychanneladmin-structuredproxypushconsumer.ads \ idls/cos/notification/cosnotifychanneladmin-structuredproxypushconsumer-helper.adb \ idls/cos/notification/cosnotifychanneladmin-structuredproxypushconsumer-helper.ads \ idls/cos/notification/cosnotifychanneladmin-structuredproxypushsupplier.adb \ idls/cos/notification/cosnotifychanneladmin-structuredproxypushsupplier.ads \ idls/cos/notification/cosnotifychanneladmin-structuredproxypushsupplier-helper.adb \ idls/cos/notification/cosnotifychanneladmin-structuredproxypushsupplier-helper.ads \ idls/cos/notification/cosnotifychanneladmin-supplieradmin.adb \ idls/cos/notification/cosnotifychanneladmin-supplieradmin.ads \ idls/cos/notification/cosnotifychanneladmin-supplieradmin-helper.adb \ idls/cos/notification/cosnotifychanneladmin-supplieradmin-helper.ads \ idls/cos/notification/cosnotifycomm.adb \ idls/cos/notification/cosnotifycomm.ads \ idls/cos/notification/cosnotifycomm-helper.adb \ idls/cos/notification/cosnotifycomm-helper.ads \ idls/cos/notification/cosnotifycomm-notifypublish.adb \ idls/cos/notification/cosnotifycomm-notifypublish.ads \ idls/cos/notification/cosnotifycomm-notifypublish-helper.adb \ idls/cos/notification/cosnotifycomm-notifypublish-helper.ads \ idls/cos/notification/cosnotifycomm-notifysubscribe.adb \ idls/cos/notification/cosnotifycomm-notifysubscribe.ads \ idls/cos/notification/cosnotifycomm-notifysubscribe-helper.adb \ idls/cos/notification/cosnotifycomm-notifysubscribe-helper.ads \ idls/cos/notification/cosnotifycomm-pullconsumer.adb \ idls/cos/notification/cosnotifycomm-pullconsumer.ads \ idls/cos/notification/cosnotifycomm-pullconsumer-helper.adb \ idls/cos/notification/cosnotifycomm-pullconsumer-helper.ads \ idls/cos/notification/cosnotifycomm-pullsupplier.adb \ idls/cos/notification/cosnotifycomm-pullsupplier.ads \ idls/cos/notification/cosnotifycomm-pullsupplier-helper.adb \ idls/cos/notification/cosnotifycomm-pullsupplier-helper.ads \ idls/cos/notification/cosnotifycomm-pushconsumer.adb \ idls/cos/notification/cosnotifycomm-pushconsumer.ads \ idls/cos/notification/cosnotifycomm-pushconsumer-helper.adb \ idls/cos/notification/cosnotifycomm-pushconsumer-helper.ads \ idls/cos/notification/cosnotifycomm-pushsupplier.adb \ idls/cos/notification/cosnotifycomm-pushsupplier.ads \ idls/cos/notification/cosnotifycomm-pushsupplier-helper.adb \ idls/cos/notification/cosnotifycomm-pushsupplier-helper.ads \ idls/cos/notification/cosnotifycomm-sequencepullconsumer.adb \ idls/cos/notification/cosnotifycomm-sequencepullconsumer.ads \ idls/cos/notification/cosnotifycomm-sequencepullconsumer-helper.adb \ idls/cos/notification/cosnotifycomm-sequencepullconsumer-helper.ads \ idls/cos/notification/cosnotifycomm-sequencepullsupplier.adb \ idls/cos/notification/cosnotifycomm-sequencepullsupplier.ads \ idls/cos/notification/cosnotifycomm-sequencepullsupplier-helper.adb \ idls/cos/notification/cosnotifycomm-sequencepullsupplier-helper.ads \ idls/cos/notification/cosnotifycomm-sequencepushconsumer.adb \ idls/cos/notification/cosnotifycomm-sequencepushconsumer.ads \ idls/cos/notification/cosnotifycomm-sequencepushconsumer-helper.adb \ idls/cos/notification/cosnotifycomm-sequencepushconsumer-helper.ads \ idls/cos/notification/cosnotifycomm-sequencepushsupplier.adb \ idls/cos/notification/cosnotifycomm-sequencepushsupplier.ads \ idls/cos/notification/cosnotifycomm-sequencepushsupplier-helper.adb \ idls/cos/notification/cosnotifycomm-sequencepushsupplier-helper.ads \ idls/cos/notification/cosnotifycomm-structuredpullconsumer.adb \ idls/cos/notification/cosnotifycomm-structuredpullconsumer.ads \ idls/cos/notification/cosnotifycomm-structuredpullconsumer-helper.adb \ idls/cos/notification/cosnotifycomm-structuredpullconsumer-helper.ads \ idls/cos/notification/cosnotifycomm-structuredpullsupplier.adb \ idls/cos/notification/cosnotifycomm-structuredpullsupplier.ads \ idls/cos/notification/cosnotifycomm-structuredpullsupplier-helper.adb \ idls/cos/notification/cosnotifycomm-structuredpullsupplier-helper.ads \ idls/cos/notification/cosnotifycomm-structuredpushconsumer.adb \ idls/cos/notification/cosnotifycomm-structuredpushconsumer.ads \ idls/cos/notification/cosnotifycomm-structuredpushconsumer-helper.adb \ idls/cos/notification/cosnotifycomm-structuredpushconsumer-helper.ads \ idls/cos/notification/cosnotifycomm-structuredpushsupplier.adb \ idls/cos/notification/cosnotifycomm-structuredpushsupplier.ads \ idls/cos/notification/cosnotifycomm-structuredpushsupplier-helper.adb \ idls/cos/notification/cosnotifycomm-structuredpushsupplier-helper.ads \ idls/cos/notification/cosnotifyfilter.adb \ idls/cos/notification/cosnotifyfilter.ads \ idls/cos/notification/cosnotifyfilter-filter.adb \ idls/cos/notification/cosnotifyfilter-filteradmin.adb \ idls/cos/notification/cosnotifyfilter-filteradmin.ads \ idls/cos/notification/cosnotifyfilter-filteradmin-helper.adb \ idls/cos/notification/cosnotifyfilter-filteradmin-helper.ads \ idls/cos/notification/cosnotifyfilter-filter.ads \ idls/cos/notification/cosnotifyfilter-filterfactory.adb \ idls/cos/notification/cosnotifyfilter-filterfactory.ads \ idls/cos/notification/cosnotifyfilter-filterfactory-helper.adb \ idls/cos/notification/cosnotifyfilter-filterfactory-helper.ads \ idls/cos/notification/cosnotifyfilter-filter-helper.adb \ idls/cos/notification/cosnotifyfilter-filter-helper.ads \ idls/cos/notification/cosnotifyfilter-helper.adb \ idls/cos/notification/cosnotifyfilter-helper.ads \ idls/cos/notification/cosnotifyfilter-mappingfilter.adb \ idls/cos/notification/cosnotifyfilter-mappingfilter.ads \ idls/cos/notification/cosnotifyfilter-mappingfilter-helper.adb \ idls/cos/notification/cosnotifyfilter-mappingfilter-helper.ads \ idls/cos/time/costime.adb \ idls/cos/time/costime.ads \ idls/cos/time/costime-helper.adb \ idls/cos/time/costime-helper.ads \ idls/cos/time/costime-timeservice.adb \ idls/cos/time/costime-timeservice.ads \ idls/cos/time/costime-timeservice-helper.adb \ idls/cos/time/costime-timeservice-helper.ads \ idls/cos/time/costime-tio.adb \ idls/cos/time/costime-tio.ads \ idls/cos/time/costime-tio-helper.adb \ idls/cos/time/costime-tio-helper.ads \ idls/cos/time/costime-uto.adb \ idls/cos/time/costime-uto.ads \ idls/cos/time/costime-uto-helper.adb \ idls/cos/time/costime-uto-helper.ads \ idls/cos/time/timebase.ads \ idls/cos/time/timebase-helper.adb \ idls/cos/time/timebase-helper.ads \ cos/naming/file.adb \ cos/naming/file.ads \ cos/naming/file-helper.adb \ cos/naming/file-helper.ads \ cos/naming/file-skel.adb \ cos/naming/file-skel.ads \ examples/corba/all_functions/all_functions.adb \ examples/corba/all_functions/all_functions.ads \ examples/corba/all_functions/all_functions-helper.adb \ examples/corba/all_functions/all_functions-helper.ads \ examples/corba/all_functions/all_functions-skel.adb \ examples/corba/all_functions/all_functions-skel.ads \ examples/corba/random/random.adb \ examples/corba/random/random.ads \ examples/corba/random/random-helper.adb \ examples/corba/random/random-helper.ads \ examples/corba/random/random-skel.adb \ examples/corba/random/random-skel.ads \ examples/corba/send/test.ads \ examples/corba/send/test-printer.adb \ examples/corba/send/test-printer.ads \ examples/corba/send/test-printer-delegate.adb \ examples/corba/send/test-printer-delegate.ads \ examples/corba/send/test-printer-helper.adb \ examples/corba/send/test-printer-helper.ads \ examples/corba/send/test-printer-skel.adb \ examples/corba/send/test-printer-skel.ads \ examples/corba/all_types/all_types.adb \ examples/corba/all_types/all_types.ads \ examples/corba/all_types/all_types-helper.adb \ examples/corba/all_types/all_types-helper.ads \ examples/corba/all_types/all_types-ir_info.adb \ examples/corba/all_types/all_types-ir_info.ads \ examples/corba/all_types/all_types-skel.adb \ examples/corba/all_types/all_types-skel.ads \ examples/corba/rtcorba/rtcosscheduling/echo.adb \ examples/corba/rtcorba/rtcosscheduling/echo.ads \ examples/corba/rtcorba/rtcosscheduling/echo-helper.adb \ examples/corba/rtcorba/rtcosscheduling/echo-helper.ads \ examples/corba/rtcorba/rtcosscheduling/echo-skel.adb \ examples/corba/rtcorba/rtcosscheduling/echo-skel.ads \ examples/corba/rtcorba/client_propagated/echo.adb \ examples/corba/rtcorba/client_propagated/echo.ads \ examples/corba/rtcorba/client_propagated/echo-helper.adb \ examples/corba/rtcorba/client_propagated/echo-helper.ads \ examples/corba/rtcorba/client_propagated/echo-skel.adb \ examples/corba/rtcorba/client_propagated/echo-skel.ads \ examples/corba/rtcorba/server_declared/echo.adb \ examples/corba/rtcorba/server_declared/echo.ads \ examples/corba/rtcorba/server_declared/echo-helper.adb \ examples/corba/rtcorba/server_declared/echo-helper.ads \ examples/corba/rtcorba/server_declared/echo-skel.adb \ examples/corba/rtcorba/server_declared/echo-skel.ads \ examples/corba/rtcorba/dhb/dhb.ads \ examples/corba/rtcorba/dhb/dhb-background_worker.adb \ examples/corba/rtcorba/dhb/dhb-background_worker.ads \ examples/corba/rtcorba/dhb/dhb-background_worker_factory.adb \ examples/corba/rtcorba/dhb/dhb-background_worker_factory.ads \ examples/corba/rtcorba/dhb/dhb-background_worker_factory-helper.adb \ examples/corba/rtcorba/dhb/dhb-background_worker_factory-helper.ads \ examples/corba/rtcorba/dhb/dhb-background_worker_factory-skel.adb \ examples/corba/rtcorba/dhb/dhb-background_worker_factory-skel.ads \ examples/corba/rtcorba/dhb/dhb-background_worker-helper.adb \ examples/corba/rtcorba/dhb/dhb-background_worker-helper.ads \ examples/corba/rtcorba/dhb/dhb-background_worker-skel.adb \ examples/corba/rtcorba/dhb/dhb-background_worker-skel.ads \ examples/corba/rtcorba/dhb/dhb-helper.adb \ examples/corba/rtcorba/dhb/dhb-helper.ads \ examples/corba/rtcorba/dhb/dhb-worker.adb \ examples/corba/rtcorba/dhb/dhb-worker.ads \ examples/corba/rtcorba/dhb/dhb-worker_factory.adb \ examples/corba/rtcorba/dhb/dhb-worker_factory.ads \ examples/corba/rtcorba/dhb/dhb-worker_factory-helper.adb \ examples/corba/rtcorba/dhb/dhb-worker_factory-helper.ads \ examples/corba/rtcorba/dhb/dhb-worker_factory-skel.adb \ examples/corba/rtcorba/dhb/dhb-worker_factory-skel.ads \ examples/corba/rtcorba/dhb/dhb-worker-helper.adb \ examples/corba/rtcorba/dhb/dhb-worker-helper.ads \ examples/corba/rtcorba/dhb/dhb-worker-skel.adb \ examples/corba/rtcorba/dhb/dhb-worker-skel.ads \ examples/corba/echo/echo.adb \ examples/corba/echo/echo.ads \ examples/corba/echo/echo-delegate.adb \ examples/corba/echo/echo-delegate.ads \ examples/corba/echo/echo-helper.adb \ examples/corba/echo/echo-helper.ads \ examples/corba/echo/echo-skel.adb \ examples/corba/echo/echo-skel.ads \ \ src/corba/conv_frame.ads \ src/corba/conv_frame-helper.adb \ src/corba/conv_frame-helper.ads \ src/corba/dynamicany/dynamicany.adb \ src/corba/dynamicany/dynamicany.ads \ src/corba/dynamicany/dynamicany-dynany.adb \ src/corba/dynamicany/dynamicany-dynany.ads \ src/corba/dynamicany/dynamicany-dynanyfactory.adb \ src/corba/dynamicany/dynamicany-dynanyfactory.ads \ src/corba/dynamicany/dynamicany-dynanyfactory-helper.adb \ src/corba/dynamicany/dynamicany-dynanyfactory-helper.ads \ src/corba/dynamicany/dynamicany-dynany-helper.adb \ src/corba/dynamicany/dynamicany-dynany-helper.ads \ src/corba/dynamicany/dynamicany-dynarray.adb \ src/corba/dynamicany/dynamicany-dynarray.ads \ src/corba/dynamicany/dynamicany-dynarray-helper.adb \ src/corba/dynamicany/dynamicany-dynarray-helper.ads \ src/corba/dynamicany/dynamicany-dynenum.adb \ src/corba/dynamicany/dynamicany-dynenum.ads \ src/corba/dynamicany/dynamicany-dynenum-helper.adb \ src/corba/dynamicany/dynamicany-dynenum-helper.ads \ src/corba/dynamicany/dynamicany-dynfixed.adb \ src/corba/dynamicany/dynamicany-dynfixed.ads \ src/corba/dynamicany/dynamicany-dynfixed-helper.adb \ src/corba/dynamicany/dynamicany-dynfixed-helper.ads \ src/corba/dynamicany/dynamicany-dynsequence.adb \ src/corba/dynamicany/dynamicany-dynsequence.ads \ src/corba/dynamicany/dynamicany-dynsequence-helper.adb \ src/corba/dynamicany/dynamicany-dynsequence-helper.ads \ src/corba/dynamicany/dynamicany-dynstruct.adb \ src/corba/dynamicany/dynamicany-dynstruct.ads \ src/corba/dynamicany/dynamicany-dynstruct-helper.adb \ src/corba/dynamicany/dynamicany-dynstruct-helper.ads \ src/corba/dynamicany/dynamicany-dynunion.adb \ src/corba/dynamicany/dynamicany-dynunion.ads \ src/corba/dynamicany/dynamicany-dynunion-helper.adb \ src/corba/dynamicany/dynamicany-dynunion-helper.ads \ src/corba/dynamicany/dynamicany-dynvalue.adb \ src/corba/dynamicany/dynamicany-dynvalue.ads \ src/corba/dynamicany/dynamicany-dynvaluebox.adb \ src/corba/dynamicany/dynamicany-dynvaluebox.ads \ src/corba/dynamicany/dynamicany-dynvaluebox-helper.adb \ src/corba/dynamicany/dynamicany-dynvaluebox-helper.ads \ src/corba/dynamicany/dynamicany-dynvaluecommon.adb \ src/corba/dynamicany/dynamicany-dynvaluecommon.ads \ src/corba/dynamicany/dynamicany-dynvaluecommon-helper.adb \ src/corba/dynamicany/dynamicany-dynvaluecommon-helper.ads \ src/corba/dynamicany/dynamicany-dynvalue-helper.adb \ src/corba/dynamicany/dynamicany-dynvalue-helper.ads \ src/corba/dynamicany/dynamicany-helper.adb \ src/corba/dynamicany/dynamicany-helper.ads \ src/corba/iop/iop.ads \ src/corba/iop/iop-codec.adb \ src/corba/iop/iop-codec.ads \ src/corba/iop/iop-codecfactory.adb \ src/corba/iop/iop-codecfactory.ads \ src/corba/iop/iop-codecfactory-helper.adb \ src/corba/iop/iop-codecfactory-helper.ads \ src/corba/iop/iop-codec-helper.adb \ src/corba/iop/iop-codec-helper.ads \ src/corba/iop/iop-helper.adb \ src/corba/iop/iop-helper.ads \ src/corba/messaging/messaging.ads \ src/corba/messaging/messaging-helper.adb \ src/corba/messaging/messaging-helper.ads \ src/corba/portableinterceptor/portableinterceptor.adb \ src/corba/portableinterceptor/portableinterceptor.ads \ src/corba/portableinterceptor/portableinterceptor-clientrequestinfo.adb \ src/corba/portableinterceptor/portableinterceptor-clientrequestinfo.ads \ src/corba/portableinterceptor/portableinterceptor-clientrequestinfo-helper.adb \ src/corba/portableinterceptor/portableinterceptor-clientrequestinfo-helper.ads \ src/corba/portableinterceptor/portableinterceptor-clientrequestinterceptor.adb \ src/corba/portableinterceptor/portableinterceptor-clientrequestinterceptor.ads \ src/corba/portableinterceptor/portableinterceptor-clientrequestinterceptor-helper.adb \ src/corba/portableinterceptor/portableinterceptor-clientrequestinterceptor-helper.ads \ src/corba/portableinterceptor/portableinterceptor-current.adb \ src/corba/portableinterceptor/portableinterceptor-current.ads \ src/corba/portableinterceptor/portableinterceptor-current-helper.adb \ src/corba/portableinterceptor/portableinterceptor-current-helper.ads \ src/corba/portableinterceptor/portableinterceptor-helper.adb \ src/corba/portableinterceptor/portableinterceptor-helper.ads \ src/corba/portableinterceptor/portableinterceptor-interceptor.adb \ src/corba/portableinterceptor/portableinterceptor-interceptor.ads \ src/corba/portableinterceptor/portableinterceptor-interceptor-helper.adb \ src/corba/portableinterceptor/portableinterceptor-interceptor-helper.ads \ src/corba/portableinterceptor/portableinterceptor-iorinfo.adb \ src/corba/portableinterceptor/portableinterceptor-iorinfo.ads \ src/corba/portableinterceptor/portableinterceptor-iorinfo-helper.adb \ src/corba/portableinterceptor/portableinterceptor-iorinfo-helper.ads \ src/corba/portableinterceptor/portableinterceptor-iorinterceptor_3_0.adb \ src/corba/portableinterceptor/portableinterceptor-iorinterceptor_3_0.ads \ src/corba/portableinterceptor/portableinterceptor-iorinterceptor_3_0-helper.adb \ src/corba/portableinterceptor/portableinterceptor-iorinterceptor_3_0-helper.ads \ src/corba/portableinterceptor/portableinterceptor-iorinterceptor.adb \ src/corba/portableinterceptor/portableinterceptor-iorinterceptor.ads \ src/corba/portableinterceptor/portableinterceptor-iorinterceptor-helper.adb \ src/corba/portableinterceptor/portableinterceptor-iorinterceptor-helper.ads \ src/corba/portableinterceptor/portableinterceptor-orbinitializer.adb \ src/corba/portableinterceptor/portableinterceptor-orbinitializer.ads \ src/corba/portableinterceptor/portableinterceptor-orbinitializer-helper.adb \ src/corba/portableinterceptor/portableinterceptor-orbinitializer-helper.ads \ src/corba/portableinterceptor/portableinterceptor-orbinitinfo.adb \ src/corba/portableinterceptor/portableinterceptor-orbinitinfo.ads \ src/corba/portableinterceptor/portableinterceptor-orbinitinfo-helper.adb \ src/corba/portableinterceptor/portableinterceptor-orbinitinfo-helper.ads \ src/corba/portableinterceptor/portableinterceptor-policyfactory.adb \ src/corba/portableinterceptor/portableinterceptor-policyfactory.ads \ src/corba/portableinterceptor/portableinterceptor-policyfactory-helper.adb \ src/corba/portableinterceptor/portableinterceptor-policyfactory-helper.ads \ src/corba/portableinterceptor/portableinterceptor-requestinfo.adb \ src/corba/portableinterceptor/portableinterceptor-requestinfo.ads \ src/corba/portableinterceptor/portableinterceptor-requestinfo-helper.adb \ src/corba/portableinterceptor/portableinterceptor-requestinfo-helper.ads \ src/corba/portableinterceptor/portableinterceptor-serverrequestinfo.adb \ src/corba/portableinterceptor/portableinterceptor-serverrequestinfo.ads \ src/corba/portableinterceptor/portableinterceptor-serverrequestinfo-helper.adb \ src/corba/portableinterceptor/portableinterceptor-serverrequestinfo-helper.ads \ src/corba/portableinterceptor/portableinterceptor-serverrequestinterceptor.adb \ src/corba/portableinterceptor/portableinterceptor-serverrequestinterceptor.ads \ src/corba/portableinterceptor/portableinterceptor-serverrequestinterceptor-helper.adb \ src/corba/portableinterceptor/portableinterceptor-serverrequestinterceptor-helper.ads \ src/corba/portableinterceptor/dynamic.ads \ src/corba/portableinterceptor/dynamic-helper.adb \ src/corba/portableinterceptor/dynamic-helper.ads \ src/corba/rtcorba/rtcosscheduling.adb \ src/corba/rtcorba/rtcosscheduling.ads \ src/corba/rtcorba/rtcosscheduling-clientscheduler.adb \ src/corba/rtcorba/rtcosscheduling-clientscheduler.ads \ src/corba/rtcorba/rtcosscheduling-clientscheduler-helper.adb \ src/corba/rtcorba/rtcosscheduling-clientscheduler-helper.ads \ src/corba/rtcorba/rtcosscheduling-helper.adb \ src/corba/rtcorba/rtcosscheduling-helper.ads \ src/corba/rtcorba/rtcosscheduling-serverscheduler.adb \ src/corba/rtcorba/rtcosscheduling-serverscheduler.ads \ src/corba/rtcorba/rtcosscheduling-serverscheduler-helper.adb \ src/corba/rtcorba/rtcosscheduling-serverscheduler-helper.ads \ src/corba/security/csi.ads \ src/corba/security/csi-helper.adb \ src/corba/security/csi-helper.ads \ src/corba/security/csiiop.ads \ src/corba/security/csiiop-helper.adb \ src/corba/security/csiiop-helper.ads \ src/corba/security/gssup/gssup.ads \ src/corba/security/gssup/gssup-helper.adb \ src/corba/security/gssup/gssup-helper.ads \ idls/cos/naming/cosnaming.ads \ idls/cos/naming/cosnaming-bindingiterator.adb \ idls/cos/naming/cosnaming-bindingiterator.ads \ idls/cos/naming/cosnaming-bindingiterator-helper.adb \ idls/cos/naming/cosnaming-bindingiterator-helper.ads \ idls/cos/naming/cosnaming-bindingiterator-skel.adb \ idls/cos/naming/cosnaming-bindingiterator-skel.ads \ idls/cos/naming/cosnaming-helper.adb \ idls/cos/naming/cosnaming-helper.ads \ idls/cos/naming/cosnaming-namingcontext.adb \ idls/cos/naming/cosnaming-namingcontext.ads \ idls/cos/naming/cosnaming-namingcontextext.adb \ idls/cos/naming/cosnaming-namingcontextext.ads \ idls/cos/naming/cosnaming-namingcontextext-helper.adb \ idls/cos/naming/cosnaming-namingcontextext-helper.ads \ idls/cos/naming/cosnaming-namingcontextext-skel.adb \ idls/cos/naming/cosnaming-namingcontextext-skel.ads \ idls/cos/naming/cosnaming-namingcontext-helper.adb \ idls/cos/naming/cosnaming-namingcontext-helper.ads \ idls/cos/naming/cosnaming-namingcontext-skel.adb \ idls/cos/naming/cosnaming-namingcontext-skel.ads \ idls/cos/event/coseventchanneladmin.adb \ idls/cos/event/coseventchanneladmin.ads \ idls/cos/event/coseventchanneladmin-consumeradmin.adb \ idls/cos/event/coseventchanneladmin-consumeradmin.ads \ idls/cos/event/coseventchanneladmin-consumeradmin-helper.adb \ idls/cos/event/coseventchanneladmin-consumeradmin-helper.ads \ idls/cos/event/coseventchanneladmin-eventchannel.adb \ idls/cos/event/coseventchanneladmin-eventchannel.ads \ idls/cos/event/coseventchanneladmin-eventchannel-helper.adb \ idls/cos/event/coseventchanneladmin-eventchannel-helper.ads \ idls/cos/event/coseventchanneladmin-helper.adb \ idls/cos/event/coseventchanneladmin-helper.ads \ idls/cos/event/coseventchanneladmin-proxypullconsumer.adb \ idls/cos/event/coseventchanneladmin-proxypullconsumer.ads \ idls/cos/event/coseventchanneladmin-proxypullconsumer-helper.adb \ idls/cos/event/coseventchanneladmin-proxypullconsumer-helper.ads \ idls/cos/event/coseventchanneladmin-proxypullsupplier.adb \ idls/cos/event/coseventchanneladmin-proxypullsupplier.ads \ idls/cos/event/coseventchanneladmin-proxypullsupplier-helper.adb \ idls/cos/event/coseventchanneladmin-proxypullsupplier-helper.ads \ idls/cos/event/coseventchanneladmin-proxypushconsumer.adb \ idls/cos/event/coseventchanneladmin-proxypushconsumer.ads \ idls/cos/event/coseventchanneladmin-proxypushconsumer-helper.adb \ idls/cos/event/coseventchanneladmin-proxypushconsumer-helper.ads \ idls/cos/event/coseventchanneladmin-proxypushsupplier.adb \ idls/cos/event/coseventchanneladmin-proxypushsupplier.ads \ idls/cos/event/coseventchanneladmin-proxypushsupplier-helper.adb \ idls/cos/event/coseventchanneladmin-proxypushsupplier-helper.ads \ idls/cos/event/coseventchanneladmin-supplieradmin.adb \ idls/cos/event/coseventchanneladmin-supplieradmin.ads \ idls/cos/event/coseventchanneladmin-supplieradmin-helper.adb \ idls/cos/event/coseventchanneladmin-supplieradmin-helper.ads \ idls/cos/event/coseventcomm.adb \ idls/cos/event/coseventcomm.ads \ idls/cos/event/coseventcomm-helper.adb \ idls/cos/event/coseventcomm-helper.ads \ idls/cos/event/coseventcomm-pullconsumer.adb \ idls/cos/event/coseventcomm-pullconsumer.ads \ idls/cos/event/coseventcomm-pullconsumer-helper.adb \ idls/cos/event/coseventcomm-pullconsumer-helper.ads \ idls/cos/event/coseventcomm-pullsupplier.adb \ idls/cos/event/coseventcomm-pullsupplier.ads \ idls/cos/event/coseventcomm-pullsupplier-helper.adb \ idls/cos/event/coseventcomm-pullsupplier-helper.ads \ idls/cos/event/coseventcomm-pushconsumer.adb \ idls/cos/event/coseventcomm-pushconsumer.ads \ idls/cos/event/coseventcomm-pushconsumer-helper.adb \ idls/cos/event/coseventcomm-pushconsumer-helper.ads \ idls/cos/event/coseventcomm-pushsupplier.adb \ idls/cos/event/coseventcomm-pushsupplier.ads \ idls/cos/event/coseventcomm-pushsupplier-helper.adb \ idls/cos/event/coseventcomm-pushsupplier-helper.ads \ idls/cos/event/costypedeventchanneladmin.adb \ idls/cos/event/costypedeventchanneladmin.ads \ idls/cos/event/costypedeventchanneladmin-helper.adb \ idls/cos/event/costypedeventchanneladmin-helper.ads \ idls/cos/event/costypedeventchanneladmin-typedconsumeradmin.adb \ idls/cos/event/costypedeventchanneladmin-typedconsumeradmin.ads \ idls/cos/event/costypedeventchanneladmin-typedconsumeradmin-helper.adb \ idls/cos/event/costypedeventchanneladmin-typedconsumeradmin-helper.ads \ idls/cos/event/costypedeventchanneladmin-typedeventchannel.adb \ idls/cos/event/costypedeventchanneladmin-typedeventchannel.ads \ idls/cos/event/costypedeventchanneladmin-typedeventchannel-helper.adb \ idls/cos/event/costypedeventchanneladmin-typedeventchannel-helper.ads \ idls/cos/event/costypedeventchanneladmin-typedproxypullsupplier.adb \ idls/cos/event/costypedeventchanneladmin-typedproxypullsupplier.ads \ idls/cos/event/costypedeventchanneladmin-typedproxypullsupplier-helper.adb \ idls/cos/event/costypedeventchanneladmin-typedproxypullsupplier-helper.ads \ idls/cos/event/costypedeventchanneladmin-typedproxypushconsumer.adb \ idls/cos/event/costypedeventchanneladmin-typedproxypushconsumer.ads \ idls/cos/event/costypedeventchanneladmin-typedproxypushconsumer-helper.adb \ idls/cos/event/costypedeventchanneladmin-typedproxypushconsumer-helper.ads \ idls/cos/event/costypedeventchanneladmin-typedsupplieradmin.adb \ idls/cos/event/costypedeventchanneladmin-typedsupplieradmin.ads \ idls/cos/event/costypedeventchanneladmin-typedsupplieradmin-helper.adb \ idls/cos/event/costypedeventchanneladmin-typedsupplieradmin-helper.ads \ idls/cos/event/costypedeventcomm.ads \ idls/cos/event/costypedeventcomm-typedpullsupplier.adb \ idls/cos/event/costypedeventcomm-typedpullsupplier.ads \ idls/cos/event/costypedeventcomm-typedpullsupplier-helper.adb \ idls/cos/event/costypedeventcomm-typedpullsupplier-helper.ads \ idls/cos/event/costypedeventcomm-typedpushconsumer.adb \ idls/cos/event/costypedeventcomm-typedpushconsumer.ads \ idls/cos/event/costypedeventcomm-typedpushconsumer-helper.adb \ idls/cos/event/costypedeventcomm-typedpushconsumer-helper.ads \ idls/cos/notification/cosnotification.adb \ idls/cos/notification/cosnotification-adminpropertiesadmin.adb \ idls/cos/notification/cosnotification-adminpropertiesadmin.ads \ idls/cos/notification/cosnotification-adminpropertiesadmin-helper.adb \ idls/cos/notification/cosnotification-adminpropertiesadmin-helper.ads \ idls/cos/notification/cosnotification.ads \ idls/cos/notification/cosnotification-helper.adb \ idls/cos/notification/cosnotification-helper.ads \ idls/cos/notification/cosnotification-qosadmin.adb \ idls/cos/notification/cosnotification-qosadmin.ads \ idls/cos/notification/cosnotification-qosadmin-helper.adb \ idls/cos/notification/cosnotification-qosadmin-helper.ads \ idls/cos/notification/cosnotifychanneladmin.adb \ idls/cos/notification/cosnotifychanneladmin.ads \ idls/cos/notification/cosnotifychanneladmin-consumeradmin.adb \ idls/cos/notification/cosnotifychanneladmin-consumeradmin.ads \ idls/cos/notification/cosnotifychanneladmin-consumeradmin-helper.adb \ idls/cos/notification/cosnotifychanneladmin-consumeradmin-helper.ads \ idls/cos/notification/cosnotifychanneladmin-eventchannel.adb \ idls/cos/notification/cosnotifychanneladmin-eventchannel.ads \ idls/cos/notification/cosnotifychanneladmin-eventchannelfactory.adb \ idls/cos/notification/cosnotifychanneladmin-eventchannelfactory.ads \ idls/cos/notification/cosnotifychanneladmin-eventchannelfactory-helper.adb \ idls/cos/notification/cosnotifychanneladmin-eventchannelfactory-helper.ads \ idls/cos/notification/cosnotifychanneladmin-eventchannel-helper.adb \ idls/cos/notification/cosnotifychanneladmin-eventchannel-helper.ads \ idls/cos/notification/cosnotifychanneladmin-helper.adb \ idls/cos/notification/cosnotifychanneladmin-helper.ads \ idls/cos/notification/cosnotifychanneladmin-proxyconsumer.adb \ idls/cos/notification/cosnotifychanneladmin-proxyconsumer.ads \ idls/cos/notification/cosnotifychanneladmin-proxyconsumer-helper.adb \ idls/cos/notification/cosnotifychanneladmin-proxyconsumer-helper.ads \ idls/cos/notification/cosnotifychanneladmin-proxypullconsumer.adb \ idls/cos/notification/cosnotifychanneladmin-proxypullconsumer.ads \ idls/cos/notification/cosnotifychanneladmin-proxypullconsumer-helper.adb \ idls/cos/notification/cosnotifychanneladmin-proxypullconsumer-helper.ads \ idls/cos/notification/cosnotifychanneladmin-proxypullsupplier.adb \ idls/cos/notification/cosnotifychanneladmin-proxypullsupplier.ads \ idls/cos/notification/cosnotifychanneladmin-proxypullsupplier-helper.adb \ idls/cos/notification/cosnotifychanneladmin-proxypullsupplier-helper.ads \ idls/cos/notification/cosnotifychanneladmin-proxypushconsumer.adb \ idls/cos/notification/cosnotifychanneladmin-proxypushconsumer.ads \ idls/cos/notification/cosnotifychanneladmin-proxypushconsumer-helper.adb \ idls/cos/notification/cosnotifychanneladmin-proxypushconsumer-helper.ads \ idls/cos/notification/cosnotifychanneladmin-proxypushsupplier.adb \ idls/cos/notification/cosnotifychanneladmin-proxypushsupplier.ads \ idls/cos/notification/cosnotifychanneladmin-proxypushsupplier-helper.adb \ idls/cos/notification/cosnotifychanneladmin-proxypushsupplier-helper.ads \ idls/cos/notification/cosnotifychanneladmin-proxysupplier.adb \ idls/cos/notification/cosnotifychanneladmin-proxysupplier.ads \ idls/cos/notification/cosnotifychanneladmin-proxysupplier-helper.adb \ idls/cos/notification/cosnotifychanneladmin-proxysupplier-helper.ads \ idls/cos/notification/cosnotifychanneladmin-sequenceproxypullconsumer.adb \ idls/cos/notification/cosnotifychanneladmin-sequenceproxypullconsumer.ads \ idls/cos/notification/cosnotifychanneladmin-sequenceproxypullconsumer-helper.adb \ idls/cos/notification/cosnotifychanneladmin-sequenceproxypullconsumer-helper.ads \ idls/cos/notification/cosnotifychanneladmin-sequenceproxypullsupplier.adb \ idls/cos/notification/cosnotifychanneladmin-sequenceproxypullsupplier.ads \ idls/cos/notification/cosnotifychanneladmin-sequenceproxypullsupplier-helper.adb \ idls/cos/notification/cosnotifychanneladmin-sequenceproxypullsupplier-helper.ads \ idls/cos/notification/cosnotifychanneladmin-sequenceproxypushconsumer.adb \ idls/cos/notification/cosnotifychanneladmin-sequenceproxypushconsumer.ads \ idls/cos/notification/cosnotifychanneladmin-sequenceproxypushconsumer-helper.adb \ idls/cos/notification/cosnotifychanneladmin-sequenceproxypushconsumer-helper.ads \ idls/cos/notification/cosnotifychanneladmin-sequenceproxypushsupplier.adb \ idls/cos/notification/cosnotifychanneladmin-sequenceproxypushsupplier.ads \ idls/cos/notification/cosnotifychanneladmin-sequenceproxypushsupplier-helper.adb \ idls/cos/notification/cosnotifychanneladmin-sequenceproxypushsupplier-helper.ads \ idls/cos/notification/cosnotifychanneladmin-structuredproxypullconsumer.adb \ idls/cos/notification/cosnotifychanneladmin-structuredproxypullconsumer.ads \ idls/cos/notification/cosnotifychanneladmin-structuredproxypullconsumer-helper.adb \ idls/cos/notification/cosnotifychanneladmin-structuredproxypullconsumer-helper.ads \ idls/cos/notification/cosnotifychanneladmin-structuredproxypullsupplier.adb \ idls/cos/notification/cosnotifychanneladmin-structuredproxypullsupplier.ads \ idls/cos/notification/cosnotifychanneladmin-structuredproxypullsupplier-helper.adb \ idls/cos/notification/cosnotifychanneladmin-structuredproxypullsupplier-helper.ads \ idls/cos/notification/cosnotifychanneladmin-structuredproxypushconsumer.adb \ idls/cos/notification/cosnotifychanneladmin-structuredproxypushconsumer.ads \ idls/cos/notification/cosnotifychanneladmin-structuredproxypushconsumer-helper.adb \ idls/cos/notification/cosnotifychanneladmin-structuredproxypushconsumer-helper.ads \ idls/cos/notification/cosnotifychanneladmin-structuredproxypushsupplier.adb \ idls/cos/notification/cosnotifychanneladmin-structuredproxypushsupplier.ads \ idls/cos/notification/cosnotifychanneladmin-structuredproxypushsupplier-helper.adb \ idls/cos/notification/cosnotifychanneladmin-structuredproxypushsupplier-helper.ads \ idls/cos/notification/cosnotifychanneladmin-supplieradmin.adb \ idls/cos/notification/cosnotifychanneladmin-supplieradmin.ads \ idls/cos/notification/cosnotifychanneladmin-supplieradmin-helper.adb \ idls/cos/notification/cosnotifychanneladmin-supplieradmin-helper.ads \ idls/cos/notification/cosnotifycomm.adb \ idls/cos/notification/cosnotifycomm.ads \ idls/cos/notification/cosnotifycomm-helper.adb \ idls/cos/notification/cosnotifycomm-helper.ads \ idls/cos/notification/cosnotifycomm-notifypublish.adb \ idls/cos/notification/cosnotifycomm-notifypublish.ads \ idls/cos/notification/cosnotifycomm-notifypublish-helper.adb \ idls/cos/notification/cosnotifycomm-notifypublish-helper.ads \ idls/cos/notification/cosnotifycomm-notifysubscribe.adb \ idls/cos/notification/cosnotifycomm-notifysubscribe.ads \ idls/cos/notification/cosnotifycomm-notifysubscribe-helper.adb \ idls/cos/notification/cosnotifycomm-notifysubscribe-helper.ads \ idls/cos/notification/cosnotifycomm-pullconsumer.adb \ idls/cos/notification/cosnotifycomm-pullconsumer.ads \ idls/cos/notification/cosnotifycomm-pullconsumer-helper.adb \ idls/cos/notification/cosnotifycomm-pullconsumer-helper.ads \ idls/cos/notification/cosnotifycomm-pullsupplier.adb \ idls/cos/notification/cosnotifycomm-pullsupplier.ads \ idls/cos/notification/cosnotifycomm-pullsupplier-helper.adb \ idls/cos/notification/cosnotifycomm-pullsupplier-helper.ads \ idls/cos/notification/cosnotifycomm-pushconsumer.adb \ idls/cos/notification/cosnotifycomm-pushconsumer.ads \ idls/cos/notification/cosnotifycomm-pushconsumer-helper.adb \ idls/cos/notification/cosnotifycomm-pushconsumer-helper.ads \ idls/cos/notification/cosnotifycomm-pushsupplier.adb \ idls/cos/notification/cosnotifycomm-pushsupplier.ads \ idls/cos/notification/cosnotifycomm-pushsupplier-helper.adb \ idls/cos/notification/cosnotifycomm-pushsupplier-helper.ads \ idls/cos/notification/cosnotifycomm-sequencepullconsumer.adb \ idls/cos/notification/cosnotifycomm-sequencepullconsumer.ads \ idls/cos/notification/cosnotifycomm-sequencepullconsumer-helper.adb \ idls/cos/notification/cosnotifycomm-sequencepullconsumer-helper.ads \ idls/cos/notification/cosnotifycomm-sequencepullsupplier.adb \ idls/cos/notification/cosnotifycomm-sequencepullsupplier.ads \ idls/cos/notification/cosnotifycomm-sequencepullsupplier-helper.adb \ idls/cos/notification/cosnotifycomm-sequencepullsupplier-helper.ads \ idls/cos/notification/cosnotifycomm-sequencepushconsumer.adb \ idls/cos/notification/cosnotifycomm-sequencepushconsumer.ads \ idls/cos/notification/cosnotifycomm-sequencepushconsumer-helper.adb \ idls/cos/notification/cosnotifycomm-sequencepushconsumer-helper.ads \ idls/cos/notification/cosnotifycomm-sequencepushsupplier.adb \ idls/cos/notification/cosnotifycomm-sequencepushsupplier.ads \ idls/cos/notification/cosnotifycomm-sequencepushsupplier-helper.adb \ idls/cos/notification/cosnotifycomm-sequencepushsupplier-helper.ads \ idls/cos/notification/cosnotifycomm-structuredpullconsumer.adb \ idls/cos/notification/cosnotifycomm-structuredpullconsumer.ads \ idls/cos/notification/cosnotifycomm-structuredpullconsumer-helper.adb \ idls/cos/notification/cosnotifycomm-structuredpullconsumer-helper.ads \ idls/cos/notification/cosnotifycomm-structuredpullsupplier.adb \ idls/cos/notification/cosnotifycomm-structuredpullsupplier.ads \ idls/cos/notification/cosnotifycomm-structuredpullsupplier-helper.adb \ idls/cos/notification/cosnotifycomm-structuredpullsupplier-helper.ads \ idls/cos/notification/cosnotifycomm-structuredpushconsumer.adb \ idls/cos/notification/cosnotifycomm-structuredpushconsumer.ads \ idls/cos/notification/cosnotifycomm-structuredpushconsumer-helper.adb \ idls/cos/notification/cosnotifycomm-structuredpushconsumer-helper.ads \ idls/cos/notification/cosnotifycomm-structuredpushsupplier.adb \ idls/cos/notification/cosnotifycomm-structuredpushsupplier.ads \ idls/cos/notification/cosnotifycomm-structuredpushsupplier-helper.adb \ idls/cos/notification/cosnotifycomm-structuredpushsupplier-helper.ads \ idls/cos/notification/cosnotifyfilter.adb \ idls/cos/notification/cosnotifyfilter.ads \ idls/cos/notification/cosnotifyfilter-filter.adb \ idls/cos/notification/cosnotifyfilter-filteradmin.adb \ idls/cos/notification/cosnotifyfilter-filteradmin.ads \ idls/cos/notification/cosnotifyfilter-filteradmin-helper.adb \ idls/cos/notification/cosnotifyfilter-filteradmin-helper.ads \ idls/cos/notification/cosnotifyfilter-filter.ads \ idls/cos/notification/cosnotifyfilter-filterfactory.adb \ idls/cos/notification/cosnotifyfilter-filterfactory.ads \ idls/cos/notification/cosnotifyfilter-filterfactory-helper.adb \ idls/cos/notification/cosnotifyfilter-filterfactory-helper.ads \ idls/cos/notification/cosnotifyfilter-filter-helper.adb \ idls/cos/notification/cosnotifyfilter-filter-helper.ads \ idls/cos/notification/cosnotifyfilter-helper.adb \ idls/cos/notification/cosnotifyfilter-helper.ads \ idls/cos/notification/cosnotifyfilter-mappingfilter.adb \ idls/cos/notification/cosnotifyfilter-mappingfilter.ads \ idls/cos/notification/cosnotifyfilter-mappingfilter-helper.adb \ idls/cos/notification/cosnotifyfilter-mappingfilter-helper.ads \ idls/cos/time/costime.adb \ idls/cos/time/costime.ads \ idls/cos/time/costime-helper.adb \ idls/cos/time/costime-helper.ads \ idls/cos/time/costime-timeservice.adb \ idls/cos/time/costime-timeservice.ads \ idls/cos/time/costime-timeservice-helper.adb \ idls/cos/time/costime-timeservice-helper.ads \ idls/cos/time/costime-tio.adb \ idls/cos/time/costime-tio.ads \ idls/cos/time/costime-tio-helper.adb \ idls/cos/time/costime-tio-helper.ads \ idls/cos/time/costime-uto.adb \ idls/cos/time/costime-uto.ads \ idls/cos/time/costime-uto-helper.adb \ idls/cos/time/costime-uto-helper.ads \ idls/cos/time/timebase.ads \ idls/cos/time/timebase-helper.adb \ idls/cos/time/timebase-helper.ads \ cos/naming/file.adb \ cos/naming/file.ads \ cos/naming/file-helper.adb \ cos/naming/file-helper.ads \ cos/naming/file-skel.adb \ cos/naming/file-skel.ads \ cos/ir/corba-repository_root-abstractinterfacedef.adb \ cos/ir/corba-repository_root-abstractinterfacedef.ads \ cos/ir/corba-repository_root-abstractinterfacedef-helper.adb \ cos/ir/corba-repository_root-abstractinterfacedef-helper.ads \ cos/ir/corba-repository_root-abstractinterfacedef-skel.adb \ cos/ir/corba-repository_root-abstractinterfacedef-skel.ads \ cos/ir/corba-repository_root.ads \ cos/ir/corba-repository_root-aliasdef.adb \ cos/ir/corba-repository_root-aliasdef.ads \ cos/ir/corba-repository_root-aliasdef-helper.adb \ cos/ir/corba-repository_root-aliasdef-helper.ads \ cos/ir/corba-repository_root-aliasdef-skel.adb \ cos/ir/corba-repository_root-aliasdef-skel.ads \ cos/ir/corba-repository_root-arraydef.adb \ cos/ir/corba-repository_root-arraydef.ads \ cos/ir/corba-repository_root-arraydef-helper.adb \ cos/ir/corba-repository_root-arraydef-helper.ads \ cos/ir/corba-repository_root-arraydef-skel.adb \ cos/ir/corba-repository_root-arraydef-skel.ads \ cos/ir/corba-repository_root-attributedef.adb \ cos/ir/corba-repository_root-attributedef.ads \ cos/ir/corba-repository_root-attributedef-helper.adb \ cos/ir/corba-repository_root-attributedef-helper.ads \ cos/ir/corba-repository_root-attributedef-skel.adb \ cos/ir/corba-repository_root-attributedef-skel.ads \ cos/ir/corba-repository_root-constantdef.adb \ cos/ir/corba-repository_root-constantdef.ads \ cos/ir/corba-repository_root-constantdef-helper.adb \ cos/ir/corba-repository_root-constantdef-helper.ads \ cos/ir/corba-repository_root-constantdef-skel.adb \ cos/ir/corba-repository_root-constantdef-skel.ads \ cos/ir/corba-repository_root-contained.adb \ cos/ir/corba-repository_root-contained.ads \ cos/ir/corba-repository_root-contained-helper.adb \ cos/ir/corba-repository_root-contained-helper.ads \ cos/ir/corba-repository_root-contained-skel.adb \ cos/ir/corba-repository_root-contained-skel.ads \ cos/ir/corba-repository_root-container.adb \ cos/ir/corba-repository_root-container.ads \ cos/ir/corba-repository_root-container-helper.adb \ cos/ir/corba-repository_root-container-helper.ads \ cos/ir/corba-repository_root-container-skel.adb \ cos/ir/corba-repository_root-container-skel.ads \ cos/ir/corba-repository_root-enumdef.adb \ cos/ir/corba-repository_root-enumdef.ads \ cos/ir/corba-repository_root-enumdef-helper.adb \ cos/ir/corba-repository_root-enumdef-helper.ads \ cos/ir/corba-repository_root-enumdef-skel.adb \ cos/ir/corba-repository_root-enumdef-skel.ads \ cos/ir/corba-repository_root-exceptiondef.adb \ cos/ir/corba-repository_root-exceptiondef.ads \ cos/ir/corba-repository_root-exceptiondef-helper.adb \ cos/ir/corba-repository_root-exceptiondef-helper.ads \ cos/ir/corba-repository_root-exceptiondef-skel.adb \ cos/ir/corba-repository_root-exceptiondef-skel.ads \ cos/ir/corba-repository_root-extabstractinterfacedef.adb \ cos/ir/corba-repository_root-extabstractinterfacedef.ads \ cos/ir/corba-repository_root-extabstractinterfacedef-helper.adb \ cos/ir/corba-repository_root-extabstractinterfacedef-helper.ads \ cos/ir/corba-repository_root-extabstractinterfacedef-skel.adb \ cos/ir/corba-repository_root-extabstractinterfacedef-skel.ads \ cos/ir/corba-repository_root-extattributedef.adb \ cos/ir/corba-repository_root-extattributedef.ads \ cos/ir/corba-repository_root-extattributedef-helper.adb \ cos/ir/corba-repository_root-extattributedef-helper.ads \ cos/ir/corba-repository_root-extattributedef-skel.adb \ cos/ir/corba-repository_root-extattributedef-skel.ads \ cos/ir/corba-repository_root-extinterfacedef.adb \ cos/ir/corba-repository_root-extinterfacedef.ads \ cos/ir/corba-repository_root-extinterfacedef-helper.adb \ cos/ir/corba-repository_root-extinterfacedef-helper.ads \ cos/ir/corba-repository_root-extinterfacedef-skel.adb \ cos/ir/corba-repository_root-extinterfacedef-skel.ads \ cos/ir/corba-repository_root-extlocalinterfacedef.adb \ cos/ir/corba-repository_root-extlocalinterfacedef.ads \ cos/ir/corba-repository_root-extlocalinterfacedef-helper.adb \ cos/ir/corba-repository_root-extlocalinterfacedef-helper.ads \ cos/ir/corba-repository_root-extlocalinterfacedef-skel.adb \ cos/ir/corba-repository_root-extlocalinterfacedef-skel.ads \ cos/ir/corba-repository_root-fixeddef.adb \ cos/ir/corba-repository_root-fixeddef.ads \ cos/ir/corba-repository_root-fixeddef-helper.adb \ cos/ir/corba-repository_root-fixeddef-helper.ads \ cos/ir/corba-repository_root-fixeddef-skel.adb \ cos/ir/corba-repository_root-fixeddef-skel.ads \ cos/ir/corba-repository_root-helper.adb \ cos/ir/corba-repository_root-helper.ads \ cos/ir/corba-repository_root-idltype.adb \ cos/ir/corba-repository_root-idltype.ads \ cos/ir/corba-repository_root-idltype-helper.adb \ cos/ir/corba-repository_root-idltype-helper.ads \ cos/ir/corba-repository_root-idltype-skel.adb \ cos/ir/corba-repository_root-idltype-skel.ads \ cos/ir/corba-repository_root-interfaceattrextension.adb \ cos/ir/corba-repository_root-interfaceattrextension.ads \ cos/ir/corba-repository_root-interfaceattrextension-helper.adb \ cos/ir/corba-repository_root-interfaceattrextension-helper.ads \ cos/ir/corba-repository_root-interfaceattrextension-skel.adb \ cos/ir/corba-repository_root-interfaceattrextension-skel.ads \ cos/ir/corba-repository_root-interfacedef.adb \ cos/ir/corba-repository_root-interfacedef.ads \ cos/ir/corba-repository_root-interfacedef-helper.adb \ cos/ir/corba-repository_root-interfacedef-helper.ads \ cos/ir/corba-repository_root-interfacedef-skel.adb \ cos/ir/corba-repository_root-interfacedef-skel.ads \ cos/ir/corba-repository_root-irobject.adb \ cos/ir/corba-repository_root-irobject.ads \ cos/ir/corba-repository_root-irobject-helper.adb \ cos/ir/corba-repository_root-irobject-helper.ads \ cos/ir/corba-repository_root-irobject-skel.adb \ cos/ir/corba-repository_root-irobject-skel.ads \ cos/ir/corba-repository_root-localinterfacedef.adb \ cos/ir/corba-repository_root-localinterfacedef.ads \ cos/ir/corba-repository_root-localinterfacedef-helper.adb \ cos/ir/corba-repository_root-localinterfacedef-helper.ads \ cos/ir/corba-repository_root-localinterfacedef-skel.adb \ cos/ir/corba-repository_root-localinterfacedef-skel.ads \ cos/ir/corba-repository_root-moduledef.adb \ cos/ir/corba-repository_root-moduledef.ads \ cos/ir/corba-repository_root-moduledef-helper.adb \ cos/ir/corba-repository_root-moduledef-helper.ads \ cos/ir/corba-repository_root-moduledef-skel.adb \ cos/ir/corba-repository_root-moduledef-skel.ads \ cos/ir/corba-repository_root-nativedef.adb \ cos/ir/corba-repository_root-nativedef.ads \ cos/ir/corba-repository_root-nativedef-helper.adb \ cos/ir/corba-repository_root-nativedef-helper.ads \ cos/ir/corba-repository_root-nativedef-skel.adb \ cos/ir/corba-repository_root-nativedef-skel.ads \ cos/ir/corba-repository_root-operationdef.adb \ cos/ir/corba-repository_root-operationdef.ads \ cos/ir/corba-repository_root-operationdef-helper.adb \ cos/ir/corba-repository_root-operationdef-helper.ads \ cos/ir/corba-repository_root-operationdef-skel.adb \ cos/ir/corba-repository_root-operationdef-skel.ads \ cos/ir/corba-repository_root-primitivedef.adb \ cos/ir/corba-repository_root-primitivedef.ads \ cos/ir/corba-repository_root-primitivedef-helper.adb \ cos/ir/corba-repository_root-primitivedef-helper.ads \ cos/ir/corba-repository_root-primitivedef-skel.adb \ cos/ir/corba-repository_root-primitivedef-skel.ads \ cos/ir/corba-repository_root-repository.adb \ cos/ir/corba-repository_root-repository.ads \ cos/ir/corba-repository_root-repository-helper.adb \ cos/ir/corba-repository_root-repository-helper.ads \ cos/ir/corba-repository_root-repository-skel.adb \ cos/ir/corba-repository_root-repository-skel.ads \ cos/ir/corba-repository_root-sequencedef.adb \ cos/ir/corba-repository_root-sequencedef.ads \ cos/ir/corba-repository_root-sequencedef-helper.adb \ cos/ir/corba-repository_root-sequencedef-helper.ads \ cos/ir/corba-repository_root-sequencedef-skel.adb \ cos/ir/corba-repository_root-sequencedef-skel.ads \ cos/ir/corba-repository_root-stringdef.adb \ cos/ir/corba-repository_root-stringdef.ads \ cos/ir/corba-repository_root-stringdef-helper.adb \ cos/ir/corba-repository_root-stringdef-helper.ads \ cos/ir/corba-repository_root-stringdef-skel.adb \ cos/ir/corba-repository_root-stringdef-skel.ads \ cos/ir/corba-repository_root-structdef.adb \ cos/ir/corba-repository_root-structdef.ads \ cos/ir/corba-repository_root-structdef-helper.adb \ cos/ir/corba-repository_root-structdef-helper.ads \ cos/ir/corba-repository_root-structdef-skel.adb \ cos/ir/corba-repository_root-structdef-skel.ads \ cos/ir/corba-repository_root-typedefdef.adb \ cos/ir/corba-repository_root-typedefdef.ads \ cos/ir/corba-repository_root-typedefdef-helper.adb \ cos/ir/corba-repository_root-typedefdef-helper.ads \ cos/ir/corba-repository_root-typedefdef-skel.adb \ cos/ir/corba-repository_root-typedefdef-skel.ads \ cos/ir/corba-repository_root-uniondef.adb \ cos/ir/corba-repository_root-uniondef.ads \ cos/ir/corba-repository_root-uniondef-helper.adb \ cos/ir/corba-repository_root-uniondef-helper.ads \ cos/ir/corba-repository_root-uniondef-skel.adb \ cos/ir/corba-repository_root-uniondef-skel.ads \ cos/ir/corba-repository_root-valueboxdef.adb \ cos/ir/corba-repository_root-valueboxdef.ads \ cos/ir/corba-repository_root-valueboxdef-helper.adb \ cos/ir/corba-repository_root-valueboxdef-helper.ads \ cos/ir/corba-repository_root-valueboxdef-skel.adb \ cos/ir/corba-repository_root-valueboxdef-skel.ads \ cos/ir/corba-repository_root-valuedef.adb \ cos/ir/corba-repository_root-valuedef.ads \ cos/ir/corba-repository_root-valuedef-helper.adb \ cos/ir/corba-repository_root-valuedef-helper.ads \ cos/ir/corba-repository_root-valuedef-skel.adb \ cos/ir/corba-repository_root-valuedef-skel.ads \ cos/ir/corba-repository_root-valuememberdef.adb \ cos/ir/corba-repository_root-valuememberdef.ads \ cos/ir/corba-repository_root-valuememberdef-helper.adb \ cos/ir/corba-repository_root-valuememberdef-helper.ads \ cos/ir/corba-repository_root-valuememberdef-skel.adb \ cos/ir/corba-repository_root-valuememberdef-skel.ads \ cos/ir/corba-repository_root-wstringdef.adb \ cos/ir/corba-repository_root-wstringdef.ads \ cos/ir/corba-repository_root-wstringdef-helper.adb \ cos/ir/corba-repository_root-wstringdef-helper.ads \ cos/ir/corba-repository_root-wstringdef-skel.adb \ cos/ir/corba-repository_root-wstringdef-skel.ads \ cos/event/coseventchanneladmin-consumeradmin-skel.adb \ cos/event/coseventchanneladmin-consumeradmin-skel.ads \ cos/event/coseventchanneladmin-eventchannel-skel.adb \ cos/event/coseventchanneladmin-eventchannel-skel.ads \ cos/event/coseventchanneladmin-proxypullconsumer-skel.adb \ cos/event/coseventchanneladmin-proxypullconsumer-skel.ads \ cos/event/coseventchanneladmin-proxypullsupplier-skel.adb \ cos/event/coseventchanneladmin-proxypullsupplier-skel.ads \ cos/event/coseventchanneladmin-proxypushconsumer-skel.adb \ cos/event/coseventchanneladmin-proxypushconsumer-skel.ads \ cos/event/coseventchanneladmin-proxypushsupplier-skel.adb \ cos/event/coseventchanneladmin-proxypushsupplier-skel.ads \ cos/event/coseventchanneladmin-supplieradmin-skel.adb \ cos/event/coseventchanneladmin-supplieradmin-skel.ads \ cos/event/coseventcomm-pullconsumer-skel.adb \ cos/event/coseventcomm-pullconsumer-skel.ads \ cos/event/coseventcomm-pullsupplier-skel.adb \ cos/event/coseventcomm-pullsupplier-skel.ads \ cos/event/coseventcomm-pushconsumer-skel.adb \ cos/event/coseventcomm-pushconsumer-skel.ads \ cos/event/coseventcomm-pushsupplier-skel.adb \ cos/event/coseventcomm-pushsupplier-skel.ads \ cos/event/costypedeventchanneladmin-typedconsumeradmin-skel.adb \ cos/event/costypedeventchanneladmin-typedconsumeradmin-skel.ads \ cos/event/costypedeventchanneladmin-typedeventchannel-skel.adb \ cos/event/costypedeventchanneladmin-typedeventchannel-skel.ads \ cos/event/costypedeventchanneladmin-typedproxypullsupplier-skel.adb \ cos/event/costypedeventchanneladmin-typedproxypullsupplier-skel.ads \ cos/event/costypedeventchanneladmin-typedproxypushconsumer-skel.adb \ cos/event/costypedeventchanneladmin-typedproxypushconsumer-skel.ads \ cos/event/costypedeventchanneladmin-typedsupplieradmin-skel.adb \ cos/event/costypedeventchanneladmin-typedsupplieradmin-skel.ads \ cos/event/costypedeventcomm-typedpullsupplier-skel.adb \ cos/event/costypedeventcomm-typedpullsupplier-skel.ads \ cos/event/costypedeventcomm-typedpushconsumer-skel.adb \ cos/event/costypedeventcomm-typedpushconsumer-skel.ads \ cos/notification/cosnotification-adminpropertiesadmin-skel.adb \ cos/notification/cosnotification-adminpropertiesadmin-skel.ads \ cos/notification/cosnotification-qosadmin-skel.adb \ cos/notification/cosnotification-qosadmin-skel.ads \ cos/notification/cosnotifychanneladmin-consumeradmin-skel.adb \ cos/notification/cosnotifychanneladmin-consumeradmin-skel.ads \ cos/notification/cosnotifychanneladmin-eventchannelfactory-skel.adb \ cos/notification/cosnotifychanneladmin-eventchannelfactory-skel.ads \ cos/notification/cosnotifychanneladmin-eventchannel-skel.adb \ cos/notification/cosnotifychanneladmin-eventchannel-skel.ads \ cos/notification/cosnotifychanneladmin-proxyconsumer-skel.adb \ cos/notification/cosnotifychanneladmin-proxyconsumer-skel.ads \ cos/notification/cosnotifychanneladmin-proxypullconsumer-skel.adb \ cos/notification/cosnotifychanneladmin-proxypullconsumer-skel.ads \ cos/notification/cosnotifychanneladmin-proxypullsupplier-skel.adb \ cos/notification/cosnotifychanneladmin-proxypullsupplier-skel.ads \ cos/notification/cosnotifychanneladmin-proxypushconsumer-skel.adb \ cos/notification/cosnotifychanneladmin-proxypushconsumer-skel.ads \ cos/notification/cosnotifychanneladmin-proxypushsupplier-skel.adb \ cos/notification/cosnotifychanneladmin-proxypushsupplier-skel.ads \ cos/notification/cosnotifychanneladmin-proxysupplier-skel.adb \ cos/notification/cosnotifychanneladmin-proxysupplier-skel.ads \ cos/notification/cosnotifychanneladmin-sequenceproxypullconsumer-skel.adb \ cos/notification/cosnotifychanneladmin-sequenceproxypullconsumer-skel.ads \ cos/notification/cosnotifychanneladmin-sequenceproxypullsupplier-skel.adb \ cos/notification/cosnotifychanneladmin-sequenceproxypullsupplier-skel.ads \ cos/notification/cosnotifychanneladmin-sequenceproxypushconsumer-skel.adb \ cos/notification/cosnotifychanneladmin-sequenceproxypushconsumer-skel.ads \ cos/notification/cosnotifychanneladmin-sequenceproxypushsupplier-skel.adb \ cos/notification/cosnotifychanneladmin-sequenceproxypushsupplier-skel.ads \ cos/notification/cosnotifychanneladmin-structuredproxypullconsumer-skel.adb \ cos/notification/cosnotifychanneladmin-structuredproxypullconsumer-skel.ads \ cos/notification/cosnotifychanneladmin-structuredproxypullsupplier-skel.adb \ cos/notification/cosnotifychanneladmin-structuredproxypullsupplier-skel.ads \ cos/notification/cosnotifychanneladmin-structuredproxypushconsumer-skel.adb \ cos/notification/cosnotifychanneladmin-structuredproxypushconsumer-skel.ads \ cos/notification/cosnotifychanneladmin-structuredproxypushsupplier-skel.adb \ cos/notification/cosnotifychanneladmin-structuredproxypushsupplier-skel.ads \ cos/notification/cosnotifychanneladmin-supplieradmin-skel.adb \ cos/notification/cosnotifychanneladmin-supplieradmin-skel.ads \ cos/notification/cosnotifycomm-notifypublish-skel.adb \ cos/notification/cosnotifycomm-notifypublish-skel.ads \ cos/notification/cosnotifycomm-notifysubscribe-skel.adb \ cos/notification/cosnotifycomm-notifysubscribe-skel.ads \ cos/notification/cosnotifycomm-pullconsumer-skel.adb \ cos/notification/cosnotifycomm-pullconsumer-skel.ads \ cos/notification/cosnotifycomm-pullsupplier-skel.adb \ cos/notification/cosnotifycomm-pullsupplier-skel.ads \ cos/notification/cosnotifycomm-pushconsumer-skel.adb \ cos/notification/cosnotifycomm-pushconsumer-skel.ads \ cos/notification/cosnotifycomm-pushsupplier-skel.adb \ cos/notification/cosnotifycomm-pushsupplier-skel.ads \ cos/notification/cosnotifycomm-sequencepullconsumer-skel.adb \ cos/notification/cosnotifycomm-sequencepullconsumer-skel.ads \ cos/notification/cosnotifycomm-sequencepullsupplier-skel.adb \ cos/notification/cosnotifycomm-sequencepullsupplier-skel.ads \ cos/notification/cosnotifycomm-sequencepushconsumer-skel.adb \ cos/notification/cosnotifycomm-sequencepushconsumer-skel.ads \ cos/notification/cosnotifycomm-sequencepushsupplier-skel.adb \ cos/notification/cosnotifycomm-sequencepushsupplier-skel.ads \ cos/notification/cosnotifycomm-structuredpullconsumer-skel.adb \ cos/notification/cosnotifycomm-structuredpullconsumer-skel.ads \ cos/notification/cosnotifycomm-structuredpullsupplier-skel.adb \ cos/notification/cosnotifycomm-structuredpullsupplier-skel.ads \ cos/notification/cosnotifycomm-structuredpushconsumer-skel.adb \ cos/notification/cosnotifycomm-structuredpushconsumer-skel.ads \ cos/notification/cosnotifycomm-structuredpushsupplier-skel.adb \ cos/notification/cosnotifycomm-structuredpushsupplier-skel.ads \ cos/notification/cosnotifyfilter-filteradmin-skel.adb \ cos/notification/cosnotifyfilter-filteradmin-skel.ads \ cos/notification/cosnotifyfilter-filterfactory-skel.adb \ cos/notification/cosnotifyfilter-filterfactory-skel.ads \ cos/notification/cosnotifyfilter-filter-skel.adb \ cos/notification/cosnotifyfilter-filter-skel.ads \ cos/notification/cosnotifyfilter-mappingfilter-skel.adb \ cos/notification/cosnotifyfilter-mappingfilter-skel.ads \ cos/time/costime-timeservice-skel.adb \ cos/time/costime-timeservice-skel.ads \ cos/time/costime-tio-skel.adb \ cos/time/costime-tio-skel.ads \ cos/time/costime-uto-skel.adb \ cos/time/costime-uto-skel.ads ################ # Target for debugging this Makefile .PHONY: debug-makefile debug-makefile: @echo "debug-makefile" @echo top_builddir = ${top_builddir} @echo top_srcdir = ${top_srcdir} @echo MAKEFLAGS = ${MAKEFLAGS} @echo GNATMAKE_FLAGS = ${GNATMAKE_FLAGS} @echo MAKECMDGOALS = ${MAKECMDGOALS} @echo MKDIR_FLAGS = ${MKDIR_FLAGS} @echo polyorb_idl_stamps = ${polyorb_idl_stamps} @echo all_idl_stamps = ${all_idl_stamps} @echo POLYORB_LIBS = ${POLYORB_LIBS} @echo SERVICE_LIBS = ${SERVICE_LIBS} @echo ALL_PROJECT_FILES = ${ALL_PROJECT_FILES} @echo PROJECT_FILES = ${PROJECT_FILES} @echo LIBRARY_PROJECT_FILES = ${LIBRARY_PROJECT_FILES} @echo EXE_PROJECT_FILES = ${EXE_PROJECT_FILES} @echo C_FILES = ${C_FILES} @echo C_OBJECTS = ${C_OBJECTS} @echo COMPILER_EXES = ${COMPILER_EXES} @echo APPLI_EXES = ${APPLI_EXES} @echo SERVICE_EXES = ${SERVICE_EXES} @echo COMPILERS = ${COMPILERS} @echo IAC_NODES_STAMPS = ${IAC_NODES_STAMPS} @echo IAC_NODES_SOURCES = ${IAC_NODES_SOURCES} @echo active_tests = ${active_tests} @echo "debug-makefile done" ################################################################ # Reminder of arcane 'make' conventions: # In the commands of static pattern rules: # $@ -- target # $< -- first prerequisite # $^ -- all prerequisites # $* -- stem (the part that matched %) polyorb-2.8~20110207.orig/idls/0000755000175000017500000000000011750740340015335 5ustar xavierxavierpolyorb-2.8~20110207.orig/idls/CORBA_IDL/0000755000175000017500000000000011750740340016653 5ustar xavierxavierpolyorb-2.8~20110207.orig/idls/CORBA_IDL/CORBA_StandardExceptions.idl0000644000175000017500000000731011750740337024064 0ustar xavierxavier// File: CORBA_StandardExceptions.idl // CORBA 3.0, Chapter 4 const unsigned long OMGVMCID = 0x4f4d0000; #define ex_body {unsigned long minor; completion_status completed;} enum completion_status {COMPLETED_YES, COMPLETED_NO, COMPLETED_MAYBE}; enum exception_type { NO_EXCEPTION, USER_EXCEPTION, SYSTEM_EXCEPTION}; exception UNKNOWN ex_body; // the unknown exception exception BAD_PARAM ex_body; // an invalid parameter was // passed exception NO_MEMORY ex_body; // dynamic memory allocation // failure exception IMP_LIMIT ex_body; // violated implementation // limit exception COMM_FAILURE ex_body; // communication failure exception INV_OBJREF ex_body; // invalid object reference exception NO_PERMISSION ex_body; // no permission for // attempted op. exception INTERNAL ex_body; // ORB internal error exception MARSHAL ex_body; // error marshaling // param/result exception INITIALIZE ex_body; // ORB initialization failure exception NO_IMPLEMENT ex_body; // operation implementation // unavailable exception BAD_TYPECODE ex_body; // bad typecode exception BAD_OPERATION ex_body; // invalid operation exception NO_RESOURCES ex_body; // insufficient resources // for req. exception NO_RESPONSE ex_body; // response to req. not yet // available exception PERSIST_STORE ex_body; // persistent storage failure exception BAD_INV_ORDER ex_body; // routine invocations // out of order exception TRANSIENT ex_body; // transient failure - reissue // request exception FREE_MEM ex_body; // cannot free memory exception INV_IDENT ex_body; // invalid identifier syntax exception INV_FLAG ex_body; // invalid flag was specified exception INTF_REPOS ex_body; // error accessing interface // repository exception BAD_CONTEXT ex_body; // error processing context // object exception OBJ_ADAPTER ex_body; // failure detected by object // adapter exception DATA_CONVERSION ex_body; // data conversion error exception OBJECT_NOT_EXIST ex_body; // non-existent object, // delete reference exception TRANSACTION_REQUIRED ex_body; // transaction required exception TRANSACTION_ROLLEDBACK ex_body; // transaction rolled back exception INVALID_TRANSACTION ex_body; // invalid transaction exception INV_POLICY ex_body; // invalid policy exception CODESET_INCOMPATIBLE ex_body; // incompatible code set exception REBIND ex_body; // rebind needed exception TIMEOUT ex_body; // operation timed out exception TRANSACTION_UNAVAILABLE ex_body; // no transaction exception TRANSACTION_MODE ex_body; // invalid transaction mode exception BAD_QOS ex_body; // bad quality of service polyorb-2.8~20110207.orig/idls/CORBA_IDL/CORBA_TypeCode.idl0000644000175000017500000000617311750740337022004 0ustar xavierxavier// File CORBA_TypeCode.idl // CORBA 3.0 Chapter 4 #ifdef _PRE_3_0_COMPILER_ #pragma prefix "omg.org" #else typeprefix CORBA "omg.org"; #endif enum TCKind { tk_null, tk_void, tk_short, tk_long, tk_ushort, tk_ulong, tk_float, tk_double, tk_boolean, tk_char, tk_octet, tk_any, tk_TypeCode,tk_Principal, tk_objref, tk_struct, tk_union, tk_enum, tk_string, tk_sequence,tk_array, tk_alias, tk_except, tk_longlong,tk_ulonglong, tk_longdouble, tk_wchar, tk_wstring, tk_fixed, tk_value, tk_value_box, tk_native, tk_abstract_interface, tk_local_interface, tk_component, tk_home, tk_event }; typedef short ValueModifier; const ValueModifier VM_NONE = 0; const ValueModifier VM_CUSTOM = 1; const ValueModifier VM_ABSTRACT = 2; const ValueModifier VM_TRUNCATABLE = 3; interface TypeCode { exception Bounds {}; exception BadKind {}; // for all TypeCode kinds boolean equal (in TypeCode tc); boolean equivalent (in TypeCode tc); TypeCode get_compact_typecode(); TCKind kind (); // for tk_objref, tk_struct, tk_union, tk_enum, tk_alias, // tk_value, tk_value_box, tk_native, tk_abstract_interface // and tk_except RepositoryId id () raises (BadKind); // for tk_objref, tk_struct, tk_union, tk_enum, tk_alias, // tk_value, tk_value_box, tk_native, tk_abstract_interface // and tk_except Identifier name () raises (BadKind); // for tk_struct, tk_union, tk_enum, tk_value, // and tk_except unsigned long member_count () raises (BadKind); Identifier member_name (in unsigned long index) raises (BadKind, Bounds); // for tk_struct, tk_union, tk_value, and tk_except TypeCode member_type (in unsigned long index) raises (BadKind, Bounds); // for tk_union any member_label (in unsigned long index) raises (BadKind, Bounds); TypeCode discriminator_type () raises (BadKind); long default_index () raises (BadKind); // for tk_string, tk_sequence, and tk_array unsigned long length () raises (BadKind); // for tk_sequence, tk_array, tk_value_box, and tk_alias TypeCode content_type () raises (BadKind); // for tk_fixed unsigned short fixed_digits() raises (BadKind); short fixed_scale() raises (BadKind); // for tk_value Visibility member_visibility(in unsigned long index) raises(BadKind, Bounds); ValueModifier type_modifier() raises(BadKind); TypeCode concrete_base_type() raises(BadKind); }; polyorb-2.8~20110207.orig/idls/CORBA_IDL/CORBA_Current.idl0000644000175000017500000000020111750740337021674 0ustar xavierxavier// File: CORBA_Current.idl // CORBA 3.0, Chapter 4 // interface for the Current object local interface Current { }; polyorb-2.8~20110207.orig/idls/CORBA_IDL/CORBA_CustomMarshal.idl0000644000175000017500000000041311750740337023041 0ustar xavierxavier// File: CORBA_CustomMarshal.idl // CORBA 3.0, Chapter 5 // depends on CORBA_Stream.idl //PolyORB:NI: abstract valuetype CustomMarshal { //PolyORB:NI: void marshal (in DataOutputStream os); //PolyORB:NI: void unmarshal (in DataInputStream is); //PolyORB:NI: }; polyorb-2.8~20110207.orig/idls/CORBA_IDL/CORBA_DomainManager.idl0000644000175000017500000000112011750740337022755 0ustar xavierxavier// File: CORBA_DomainManager.idl // CORBA 3.0, Chapter 4 interface DomainManager { Policy get_domain_policy ( in PolicyType policy_type ); }; //PolyORB:NI: const PolicyType SecConstruction = 11; //PolyORB:NI: //PolyORB:NI: interface ConstructionPolicy: Policy { //PolyORB:NI: void make_domain_manager( //PolyORB:NI: in CORBA::InterfaceDef object_type, //PolyORB:NI: in boolean constr_policy //PolyORB:NI: ); //PolyORB:NI: }; typedef sequence DomainManagersList; polyorb-2.8~20110207.orig/idls/CORBA_IDL/CORBA_Stream.idl0000644000175000017500000003027411750740337021522 0ustar xavierxavier// File: CORBA_Stream.idl // CORBA 3.0, Chapter 5 typedef sequence AnySeq; typedef sequence BooleanSeq; typedef sequence CharSeq; typedef sequence WCharSeq; typedef sequence OctetSeq; typedef sequence ShortSeq; typedef sequence UShortSeq; typedef sequence LongSeq; typedef sequence ULongSeq; typedef sequence LongLongSeq; typedef sequence ULongLongSeq; typedef sequence FloatSeq; typedef sequence DoubleSeq; typedef sequence LongDoubleSeq; typedef sequence StringSeq; typedef sequence WStringSeq; //PolyORB:NI: exception BadFixedValue { //PolyORB:NI: unsigned long offset; //PolyORB:NI: }; //PolyORB:NI: //PolyORB:NI: abstract valuetype DataOutputStream { //PolyORB:NI: void write_any (in any value); //PolyORB:NI: void write_boolean (in boolean value); //PolyORB:NI: void write_char (in char value); //PolyORB:NI: void write_wchar (in wchar value); //PolyORB:NI: void write_octet (in octet value); //PolyORB:NI: void write_short (in short value); //PolyORB:NI: void write_ushort (in unsigned short value); //PolyORB:NI: void write_long (in long value); //PolyORB:NI: void write_ulong (in unsigned long value); //PolyORB:NI: void write_longlong (in long long value); //PolyORB:NI: void write_ulonglong (in unsigned long long value); //PolyORB:NI: void write_float (in float value); //PolyORB:NI: void write_double (in double value); //PolyORB:NI: void write_longdouble (in long double value); //PolyORB:NI: void write_string (in string value); //PolyORB:NI: void write_wstring (in wstring value); //PolyORB:NI: void write_Object (in Object value); //PolyORB:NI: void write_Abstract (in AbstractBase value); //PolyORB:NI: void write_Value (in ValueBase value); //PolyORB:NI: void write_TypeCode (in TypeCode value); //PolyORB:NI: void write_any_array (in AnySeq seq, //PolyORB:NI: in unsigned long offset, //PolyORB:NI: in unsigned long length); //PolyORB:NI: void write_boolean_array (in BooleanSeq seq, //PolyORB:NI: in unsigned long offset, //PolyORB:NI: in unsigned long length); //PolyORB:NI: void write_char_array (in CharSeq seq, //PolyORB:NI: in unsigned long offset, //PolyORB:NI: in unsigned long length); //PolyORB:NI: void write_wchar_array (in WCharSeq seq, //PolyORB:NI: in unsigned long offset, //PolyORB:NI: in unsigned long length); //PolyORB:NI: void write_octet_array (in OctetSeq seq, //PolyORB:NI: in unsigned long offset, //PolyORB:NI: in unsigned long length); //PolyORB:NI: void write_short_array (in ShortSeq seq, //PolyORB:NI: in unsigned long offset, //PolyORB:NI: in unsigned long length); //PolyORB:NI: void write_ushort_array (in UShortSeq seq, //PolyORB:NI: in unsigned long offset, //PolyORB:NI: in unsigned long length); //PolyORB:NI: void write_long_array (in LongSeq seq, //PolyORB:NI: in unsigned long offset, //PolyORB:NI: in unsigned long length); //PolyORB:NI: void write_ulong_array (in ULongSeq seq, //PolyORB:NI: in unsigned long offset, //PolyORB:NI: in unsigned long length); //PolyORB:NI: void write_ulonglong_array (in ULongLongSeq seq, //PolyORB:NI: in unsigned long offset, //PolyORB:NI: in unsigned long length); //PolyORB:NI: void write_longlong_array (in LongLongSeq seq, //PolyORB:NI: in unsigned long offset, //PolyORB:NI: in unsigned long length); //PolyORB:NI: void write_float_array (in FloatSeq seq, //PolyORB:NI: in unsigned long offset, //PolyORB:NI: in unsigned long length); //PolyORB:NI: void write_double_array (in DoubleSeq seq, //PolyORB:NI: in unsigned long offset, //PolyORB:NI: in unsigned long length); //PolyORB:NI: void write_long_double_array( //PolyORB:NI: in LongDoubleSeq seq, //PolyORB:NI: in unsigned long offset, //PolyORB:NI: in unsigned long length); //PolyORB:NI: void write_fixed ( //PolyORB:NI: in any fixed_value //PolyORB:NI: ) raises (BadFixedValue); //PolyORB:NI: void write_fixed_array ( //PolyORB:NI: in AnySeq seq, //PolyORB:NI: in unsigned long offset, //PolyORB:NI: in unsigned long length //PolyORB:NI: ) raises (BadFixedValue); //PolyORB:NI: }; //PolyORB:NI: //PolyORB:NI: abstract valuetype DataInputStream { //PolyORB:NI: any read_any(); //PolyORB:NI: boolean read_boolean(); //PolyORB:NI: char read_char(); //PolyORB:NI: wchar read_wchar(); //PolyORB:NI: octet read_octet(); //PolyORB:NI: short read_short(); //PolyORB:NI: unsigned short read_ushort(); //PolyORB:NI: long read_long(); //PolyORB:NI: unsigned long read_ulong(); //PolyORB:NI: long long read_longlong(); //PolyORB:NI: unsigned long long read_ulonglong(); //PolyORB:NI: float read_float(); //PolyORB:NI: double read_double(); //PolyORB:NI: long double read_longdouble(); //PolyORB:NI: string read_string(); //PolyORB:NI: wstring read_wstring(); //PolyORB:NI: Object read_Object(); //PolyORB:NI: AbstractBase read_Abstract(); //PolyORB:NI: ValueBase read_Value(); //PolyORB:NI: TypeCode read_TypeCode(); //PolyORB:NI: //PolyORB:NI: void read_any_array ( //PolyORB:NI: inout AnySeq seq, //PolyORB:NI: in unsigned long offset, //PolyORB:NI: in unsigned long length); //PolyORB:NI: void read_boolean_array ( //PolyORB:NI: inout BooleanSeq seq, //PolyORB:NI: in unsigned long offset, //PolyORB:NI: in unsigned long length); //PolyORB:NI: void read_char_array ( //PolyORB:NI: inout CharSeq seq, //PolyORB:NI: in unsigned long offset, //PolyORB:NI: in unsigned long length); //PolyORB:NI: void read_wchar_array ( //PolyORB:NI: inout WCharSeq seq, //PolyORB:NI: in unsigned long offset, //PolyORB:NI: in unsigned long length); //PolyORB:NI: void read_octet_array ( //PolyORB:NI: inout OctetSeq seq, //PolyORB:NI: in unsigned long offset, //PolyORB:NI: in unsigned long length); //PolyORB:NI: void read_short_array ( //PolyORB:NI: inout ShortSeq seq, //PolyORB:NI: in unsigned long offset, //PolyORB:NI: in unsigned long length); //PolyORB:NI: void read_ushort_array ( //PolyORB:NI: inout UShortSeq seq, //PolyORB:NI: in unsigned long offset, //PolyORB:NI: in unsigned long length); //PolyORB:NI: void read_long_array ( //PolyORB:NI: inout LongSeq seq, //PolyORB:NI: in unsigned long offset, //PolyORB:NI: in unsigned long length); //PolyORB:NI: void read_ulong_array ( //PolyORB:NI: inout ULongSeq seq, //PolyORB:NI: in unsigned long offset, //PolyORB:NI: in unsigned long length); //PolyORB:NI: void read_ulonglong_array ( //PolyORB:NI: inout ULongLongSeq seq, //PolyORB:NI: in unsigned long offset, //PolyORB:NI: in unsigned long length); //PolyORB:NI: void read_longlong_array ( //PolyORB:NI: inout LongLongSeq seq, //PolyORB:NI: in unsigned long offset, //PolyORB:NI: in unsigned long length); //PolyORB:NI: void read_float_array ( //PolyORB:NI: inout FloatSeq seq, //PolyORB:NI: in unsigned long offset, //PolyORB:NI: in unsigned long length); //PolyORB:NI: void read_double_array ( //PolyORB:NI: inout DoubleSeq seq, //PolyORB:NI: in unsigned long offset, //PolyORB:NI: in unsigned long length); //PolyORB:NI: void read_long_double_array( //PolyORB:NI: inout DoubleSeq seq, //PolyORB:NI: in unsigned long offset, //PolyORB:NI: in unsigned long length); //PolyORB:NI: any read_fixed ( //PolyORB:NI: in unsigned short digits, //PolyORB:NI: in short scale //PolyORB:NI: ) raises (BadFixedValue); //PolyORB:NI: void read_fixed_array ( //PolyORB:NI: inout AnySeq seq, //PolyORB:NI: in unsigned long offset, //PolyORB:NI: in unsigned long length, //PolyORB:NI: in unsigned short digits, //PolyORB:NI: in short scale //PolyORB:NI: ) raises (BadFixedValue); //PolyORB:NI: }; polyorb-2.8~20110207.orig/idls/CORBA_IDL/CORBA_InterfaceRepository.idl0000644000175000017500000007645611750740337024303 0ustar xavierxavier// File: CORBA_InterfaceRepository.idl // CORBA 3.0, Chapter 10 #ifdef _PRE_3_0_COMPILER_ #pragma prefix "omg.org" #else typeprefix CORBA "omg.org"; // ";" suppresses iac warning about missing ";". #endif typedef string ScopedName; typedef string RepositoryId; enum DefinitionKind { dk_none, dk_all, dk_Attribute, dk_Constant, dk_Exception, dk_Interface, dk_Module, dk_Operation, dk_Typedef, dk_Alias, dk_Struct, dk_Union, dk_Enum, dk_Primitive, dk_String, dk_Sequence, dk_Array, dk_Repository, dk_Wstring, dk_Fixed, dk_Value, dk_ValueBox, dk_ValueMember, dk_Native, dk_AbstractInterface, dk_LocalInterface, dk_Component, dk_Home, dk_Factory, dk_Finder, dk_Emits, dk_Publishes, dk_Consumes, dk_Provides, dk_Uses, dk_Event }; interface IRObject { // read interface readonly attribute DefinitionKind def_kind; // write interface void destroy (); }; typedef string VersionSpec; interface Contained : IRObject { // read/write interface attribute RepositoryId id; attribute Identifier name; attribute VersionSpec version; // read interface readonly attribute Container defined_in; readonly attribute ScopedName absolute_name; readonly attribute Repository containing_repository; struct Description { DefinitionKind kind; any value; }; Description describe (); // write interface void move ( in Container new_container, in Identifier new_name, in VersionSpec new_version ); }; interface ModuleDef; interface ConstantDef; interface IDLType; interface StructDef; interface UnionDef; interface EnumDef; interface AliasDef; interface ExceptionDef; interface NativeDef; interface InterfaceDef; typedef sequence InterfaceDefSeq; interface ValueDef; typedef sequence ValueDefSeq; interface ValueBoxDef; interface AbstractInterfaceDef; typedef sequence AbstractInterfaceDefSeq; interface LocalInterfaceDef; typedef sequence LocalInterfaceDefSeq; interface ExtInterfaceDef; typedef sequence ExtInterfaceDefSeq; //PolyORB:NI: interface ExtValueDef; //PolyORB:NI: typedef sequence ExtValueDefSeq; interface ExtAbstractInterfaceDef; typedef sequence ExtAbstractInterfaceDefSeq; interface ExtLocalInterfaceDef; typedef sequence ExtLocalInterfaceDefSeq; typedef sequence ContainedSeq; struct StructMember { Identifier name; TypeCode type; IDLType type_def; }; typedef sequence StructMemberSeq; struct Initializer { StructMemberSeq members; Identifier name; }; typedef sequence InitializerSeq; struct UnionMember { Identifier name; any label; TypeCode type; IDLType type_def; }; struct ExceptionDescription { Identifier name; RepositoryId id; RepositoryId defined_in; VersionSpec version; TypeCode type; }; typedef sequence ExcDescriptionSeq; struct ExtInitializer { StructMemberSeq members; ExcDescriptionSeq exceptions; Identifier name; }; typedef sequence ExtInitializerSeq; typedef sequence UnionMemberSeq; typedef sequence EnumMemberSeq; interface Container : IRObject { // read interface Contained lookup ( in ScopedName search_name); ContainedSeq contents ( in DefinitionKind limit_type, in boolean exclude_inherited ); ContainedSeq lookup_name ( in Identifier search_name, in long levels_to_search, in DefinitionKind limit_type, in boolean exclude_inherited ); struct Description { Contained contained_object; DefinitionKind kind; any value; }; typedef sequence DescriptionSeq; DescriptionSeq describe_contents ( in DefinitionKind limit_type, in boolean exclude_inherited, in long max_returned_objs ); // write interface ModuleDef create_module ( in RepositoryId id, in Identifier name, in VersionSpec version ); ConstantDef create_constant ( in RepositoryId id, in Identifier name, in VersionSpec version, in IDLType type, in any value ); StructDef create_struct ( in RepositoryId id, in Identifier name, in VersionSpec version, in StructMemberSeq members ); UnionDef create_union ( in RepositoryId id, in Identifier name, in VersionSpec version, in IDLType discriminator_type, in UnionMemberSeq members ); EnumDef create_enum ( in RepositoryId id, in Identifier name, in VersionSpec version, in EnumMemberSeq members ); AliasDef create_alias ( in RepositoryId id, in Identifier name, in VersionSpec version, in IDLType original_type ); InterfaceDef create_interface ( in RepositoryId id, in Identifier name, in VersionSpec version, in InterfaceDefSeq base_interfaces, in boolean is_abstract ); ValueDef create_value( in RepositoryId id, in Identifier name, in VersionSpec version, in boolean is_custom, in boolean is_abstract, in ValueDef base_value, in boolean is_truncatable, in ValueDefSeq abstract_base_values, in InterfaceDefSeq supported_interfaces, in InitializerSeq initializers ); ValueBoxDef create_value_box( in RepositoryId id, in Identifier name, in VersionSpec version, in IDLType original_type_def ); ExceptionDef create_exception( in RepositoryId id, in Identifier name, in VersionSpec version, in StructMemberSeq members ); NativeDef create_native( in RepositoryId id, in Identifier name, in VersionSpec version ); AbstractInterfaceDef create_abstract_interface ( in RepositoryId id, in Identifier name, in VersionSpec version, in AbstractInterfaceDefSeq base_interfaces ); LocalInterfaceDef create_local_interface ( in RepositoryId id, in Identifier name, in VersionSpec version, in InterfaceDefSeq base_interfaces ); //PolyORB:NI: ExtValueDef create_ext_value ( //PolyORB:NI: in RepositoryId id, //PolyORB:NI: in Identifier name, //PolyORB:NI: in VersionSpec version, //PolyORB:NI: in boolean is_custom, //PolyORB:NI: in boolean is_abstract, //PolyORB:NI: in ValueDef base_value, //PolyORB:NI: in boolean is_truncatable, //PolyORB:NI: in ValueDefSeq abstract_base_values, //PolyORB:NI: in InterfaceDefSeq supported_interfaces, //PolyORB:NI: in ExtInitializerSeq initializers //PolyORB:NI: ); }; interface IDLType : IRObject { readonly attribute TypeCode type; }; enum PrimitiveKind { pk_null, pk_void, pk_short, pk_long, pk_ushort, pk_ulong, pk_float, pk_double, pk_boolean, pk_char, pk_octet, pk_any, pk_TypeCode, pk_Principal, pk_string, pk_objref, pk_longlong,pk_ulonglong, pk_longdouble, pk_wchar, pk_wstring, pk_value_base }; interface Repository : Container { // read interface Contained lookup_id (in RepositoryId search_id); TypeCode get_canonical_typecode (in TypeCode tc); PrimitiveDef get_primitive (in PrimitiveKind kind); // write interface StringDef create_string (in unsigned long bound); WstringDef create_wstring (in unsigned long bound); SequenceDef create_sequence (in unsigned long bound, in IDLType element_type ); ArrayDef create_array (in unsigned long length, in IDLType element_type ); FixedDef create_fixed (in unsigned short digits, in short scale ); }; interface ModuleDef : Container, Contained { }; struct ModuleDescription { Identifier name; RepositoryId id; RepositoryId defined_in; VersionSpec version; }; interface ConstantDef : Contained { readonly attribute TypeCode type; attribute IDLType type_def; attribute any value; }; struct ConstantDescription { Identifier name; RepositoryId id; RepositoryId defined_in; VersionSpec version; TypeCode type; any value; }; interface TypedefDef : Contained, IDLType { }; struct TypeDescription { Identifier name; RepositoryId id; RepositoryId defined_in; VersionSpec version; TypeCode type; }; interface StructDef : TypedefDef, Container { attribute StructMemberSeq members; }; interface UnionDef : TypedefDef, Container { readonly attribute TypeCode discriminator_type; attribute IDLType discriminator_type_def; attribute UnionMemberSeq members; }; interface EnumDef : TypedefDef { attribute EnumMemberSeq members; }; interface AliasDef : TypedefDef { attribute IDLType original_type_def; }; interface NativeDef : TypedefDef { }; interface PrimitiveDef: IDLType { readonly attribute PrimitiveKind kind; }; interface StringDef : IDLType { attribute unsigned long bound; }; interface WstringDef : IDLType { attribute unsigned long bound; }; interface FixedDef : IDLType { attribute unsigned short digits; attribute short scale; }; interface SequenceDef : IDLType { attribute unsigned long bound; readonly attribute TypeCode element_type; attribute IDLType element_type_def; }; interface ArrayDef : IDLType { attribute unsigned long length; readonly attribute TypeCode element_type; attribute IDLType element_type_def; }; interface ExceptionDef : Contained, Container { readonly attribute TypeCode type; attribute StructMemberSeq members; }; enum AttributeMode {ATTR_NORMAL, ATTR_READONLY}; interface AttributeDef : Contained { readonly attribute TypeCode type; attribute IDLType type_def; attribute AttributeMode mode; }; struct AttributeDescription { Identifier name; RepositoryId id; RepositoryId defined_in; VersionSpec version; TypeCode type; AttributeMode mode; }; struct ExtAttributeDescription { Identifier name; RepositoryId id; RepositoryId defined_in; VersionSpec version; TypeCode type; AttributeMode mode; ExcDescriptionSeq get_exceptions; ExcDescriptionSeq put_exceptions; }; interface ExtAttributeDef : AttributeDef { // read/write interface attribute ExcDescriptionSeq get_exceptions; attribute ExcDescriptionSeq set_exceptions; // read interface ExtAttributeDescription describe_attribute (); }; enum OperationMode {OP_NORMAL, OP_ONEWAY}; enum ParameterMode {PARAM_IN, PARAM_OUT, PARAM_INOUT}; struct ParameterDescription { Identifier name; TypeCode type; IDLType type_def; ParameterMode mode; }; typedef sequence ParDescriptionSeq; typedef Identifier ContextIdentifier; typedef sequence ContextIdSeq; typedef sequence ExceptionDefSeq; interface OperationDef : Contained { readonly attribute TypeCode result; attribute IDLType result_def; attribute ParDescriptionSeq params; attribute OperationMode mode; attribute ContextIdSeq contexts; attribute ExceptionDefSeq exceptions; }; struct OperationDescription { Identifier name; RepositoryId id; RepositoryId defined_in; VersionSpec version; TypeCode result; OperationMode mode; ContextIdSeq contexts; ParDescriptionSeq parameters; ExcDescriptionSeq exceptions; }; typedef sequence RepositoryIdSeq; typedef sequence OpDescriptionSeq; typedef sequence AttrDescriptionSeq; typedef sequence ExtAttrDescriptionSeq; interface InterfaceDef : Container, Contained, IDLType { // read/write interface attribute InterfaceDefSeq base_interfaces; attribute boolean is_abstract; // read interface boolean is_a (in RepositoryId interface_id ); struct FullInterfaceDescription { Identifier name; RepositoryId id; RepositoryId defined_in; VersionSpec version; OpDescriptionSeq operations; AttrDescriptionSeq attributes; RepositoryIdSeq base_interfaces; TypeCode type; boolean is_abstract; }; FullInterfaceDescription describe_interface(); // write interface AttributeDef create_attribute ( in RepositoryId id, in Identifier name, in VersionSpec version, in IDLType type, in AttributeMode mode ); OperationDef create_operation ( in RepositoryId id, in Identifier name, in VersionSpec version, in IDLType result, in OperationMode mode, in ParDescriptionSeq params, in ExceptionDefSeq exceptions, in ContextIdSeq contexts ); }; struct InterfaceDescription { Identifier name; RepositoryId id; RepositoryId defined_in; VersionSpec version; RepositoryIdSeq base_interfaces; boolean is_abstract; }; interface InterfaceAttrExtension { // read interface struct ExtFullInterfaceDescription { Identifier name; RepositoryId id; RepositoryId defined_in; VersionSpec version; OpDescriptionSeq operations; ExtAttrDescriptionSeq attributes; RepositoryIdSeq base_interfaces; TypeCode type; }; ExtFullInterfaceDescription describe_ext_interface (); // write interface ExtAttributeDef create_ext_attribute ( in RepositoryId id, in Identifier name, in VersionSpec version, in IDLType type, in AttributeMode mode, in ExceptionDefSeq get_exceptions, in ExceptionDefSeq set_exceptions ); }; interface ExtInterfaceDef : InterfaceDef, InterfaceAttrExtension {}; typedef short Visibility; const Visibility PRIVATE_MEMBER = 0; const Visibility PUBLIC_MEMBER = 1; struct ValueMember { Identifier name; RepositoryId id; RepositoryId defined_in; VersionSpec version; TypeCode type; IDLType type_def; Visibility access; }; typedef sequence ValueMemberSeq; interface ValueMemberDef : Contained { readonly attribute TypeCode type; attribute IDLType type_def; attribute Visibility access; }; interface ValueDef : Container, Contained, IDLType { // read/write interface attribute InterfaceDefSeq supported_interfaces; attribute InitializerSeq initializers; attribute ValueDef base_value; attribute ValueDefSeq abstract_base_values; attribute boolean is_abstract; attribute boolean is_custom; attribute boolean is_truncatable; // read interface boolean is_a(in RepositoryId id); struct FullValueDescription { Identifier name; RepositoryId id; boolean is_abstract; boolean is_custom; RepositoryId defined_in; VersionSpec version; OpDescriptionSeq operations; AttrDescriptionSeq attributes; ValueMemberSeq members; InitializerSeq initializers; RepositoryIdSeq supported_interfaces; RepositoryIdSeq abstract_base_values; boolean is_truncatable; RepositoryId base_value; TypeCode type; }; FullValueDescription describe_value(); ValueMemberDef create_value_member( in RepositoryId id, in Identifier name, in VersionSpec version, in IDLType type, in Visibility access ); AttributeDef create_attribute( in RepositoryId id, in Identifier name, in VersionSpec version, in IDLType type, in AttributeMode mode ); OperationDef create_operation ( in RepositoryId id, in Identifier name, in VersionSpec version, in IDLType result, in OperationMode mode, in ParDescriptionSeq params, in ExceptionDefSeq exceptions, in ContextIdSeq contexts ); }; struct ValueDescription { Identifier name; RepositoryId id; boolean is_abstract; boolean is_custom; RepositoryId defined_in; VersionSpec version; RepositoryIdSeq supported_interfaces; RepositoryIdSeq abstract_base_values; boolean is_truncatable; RepositoryId base_value; }; //PolyORB:WAidlac: idlac/ALM for interface function which return interface // itself generates an Ada function which return Ref. // By Ada rules this function is a primitive operation // of Ref and should be overridden for each child type. // idlac doesn't generate this override function, so // code generated for ExtValueDef is wrong. //PolyORB:IL: interface ExtValueDef : ValueDef { //PolyORB:IL: // read/write interface //PolyORB:IL: attribute ExtInitializerSeq ext_initializers; //PolyORB:IL: // read interface //PolyORB:IL: struct ExtFullValueDescription { //PolyORB:IL: Identifier name; //PolyORB:IL: RepositoryId id; //PolyORB:IL: boolean is_abstract; //PolyORB:IL: boolean is_custom; //PolyORB:IL: RepositoryId defined_in; //PolyORB:IL: VersionSpec version; //PolyORB:IL: OpDescriptionSeq operations; //PolyORB:IL: ExtAttrDescriptionSeq attributes; //PolyORB:IL: ValueMemberSeq members; //PolyORB:IL: ExtInitializerSeq initializers; //PolyORB:IL: RepositoryIdSeq supported_interfaces; //PolyORB:IL: RepositoryIdSeq abstract_base_values; //PolyORB:IL: boolean is_truncatable; //PolyORB:IL: RepositoryId base_value; //PolyORB:IL: TypeCode type; //PolyORB:IL: }; //PolyORB:IL: ExtFullValueDescription describe_ext_value (); //PolyORB:IL: // write interface //PolyORB:IL: ExtAttributeDef create_ext_attribute ( //PolyORB:IL: in RepositoryId id, //PolyORB:IL: in Identifier name, //PolyORB:IL: in VersionSpec version, //PolyORB:IL: in IDLType type, //PolyORB:IL: in AttributeMode mode, //PolyORB:IL: in ExceptionDefSeq get_exceptions, //PolyORB:IL: in ExceptionDefSeq set_exceptions //PolyORB:IL: ); //PolyORB:IL: }; interface ValueBoxDef : TypedefDef { attribute IDLType original_type_def; }; interface AbstractInterfaceDef : InterfaceDef { }; interface ExtAbstractInterfaceDef : AbstractInterfaceDef, InterfaceAttrExtension { }; interface LocalInterfaceDef : InterfaceDef { }; interface ExtLocalInterfaceDef : LocalInterfaceDef, InterfaceAttrExtension { }; #ifdef _COMPONENT_REPOSITORY_ //PolyORB:NI: module ComponentIR { //PolyORB:NI: typeprefix ComponentIR "omg.org"; //PolyORB:NI: interface ComponentDef; //PolyORB:NI: interface HomeDef; //PolyORB:NI: interface EventDef : ExtValueDef {}; //PolyORB:NI: interface Container{ //PolyORB:NI: ComponentDef create_component ( //PolyORB:NI: in RepositoryId id, //PolyORB:NI: in Identifier name, //PolyORB:NI: in VersionSpec version, //PolyORB:NI: in ComponentDef base_component, //PolyORB:NI: in InterfaceDefSeq supports_interfaces //PolyORB:NI: ); //PolyORB:NI: HomeDef create_home ( //PolyORB:NI: in RepositoryId id, //PolyORB:NI: in Identifier name, //PolyORB:NI: in VersionSpec version, //PolyORB:NI: in HomeDef base_home, //PolyORB:NI: in ComponentDef managed_component, //PolyORB:NI: in InterfaceDefSeq supports_interfaces, //PolyORB:NI: in ValueDef primary_key //PolyORB:NI: ); //PolyORB:NI: EventDef create_event ( //PolyORB:NI: in RepositoryId id, //PolyORB:NI: in Identifier name, //PolyORB:NI: in VersionSpec version, //PolyORB:NI: in boolean is_custom, //PolyORB:NI: in boolean is_abstract, //PolyORB:NI: in ValueDef base_value, //PolyORB:NI: in boolean is_truncatable, //PolyORB:NI: in ValueDefSeq abstract_base_values, //PolyORB:NI: in InterfaceDefSeq supported_interfaces, //PolyORB:NI: in ExtInitializerSeq initializers //PolyORB:NI: ); //PolyORB:NI: }; //PolyORB:NI: interface ModuleDef : CORBA::ModuleDef, Container{}; //PolyORB:NI: interface Repository : CORBA::Repository, Container{}; //PolyORB:NI: interface ProvidesDef : Contained { //PolyORB:NI: attribute InterfaceDef interface_type; //PolyORB:NI: }; //PolyORB:NI: struct ProvidesDescription { //PolyORB:NI: Identifier name; //PolyORB:NI: RepositoryId id; //PolyORB:NI: RepositoryId defined_in; //PolyORB:NI: VersionSpec version; //PolyORB:NI: RepositoryId interface_type; //PolyORB:NI: }; //PolyORB:NI: interface UsesDef : Contained { //PolyORB:NI: attribute InterfaceDef interface_type; //PolyORB:NI: attribute boolean is_multiple; //PolyORB:NI: }; //PolyORB:NI: struct UsesDescription { //PolyORB:NI: Identifier name; //PolyORB:NI: RepositoryId id; //PolyORB:NI: RepositoryId defined_in; //PolyORB:NI: VersionSpec version; //PolyORB:NI: RepositoryId interface_type; //PolyORB:NI: boolean is_multiple; //PolyORB:NI: }; //PolyORB:NI: interface EventPortDef : Contained { //PolyORB:NI: // read/write interface //PolyORB:NI: attribute EventDef event; //PolyORB:NI: // read interface //PolyORB:NI: boolean is_a (in RepositoryId event_id); //PolyORB:NI: }; //PolyORB:NI: struct EventPortDescription { //PolyORB:NI: Identifier name; //PolyORB:NI: RepositoryId id; //PolyORB:NI: RepositoryId defined_in; //PolyORB:NI: VersionSpec version; //PolyORB:NI: RepositoryId event; //PolyORB:NI: }; //PolyORB:NI: interface EmitsDef : EventPortDef {}; //PolyORB:NI: interface PublishesDef : EventPortDef {}; //PolyORB:NI: interface ConsumesDef : EventPortDef {}; //PolyORB:NI: interface ComponentDef : ExtInterfaceDef { //PolyORB:NI: // read/write interface //PolyORB:NI: attribute ComponentDef base_component; //PolyORB:NI: attribute InterfaceDefSeq supported_interfaces; //PolyORB:NI: // write interface //PolyORB:NI: ProvidesDef create_provides ( //PolyORB:NI: in RepositoryId id, //PolyORB:NI: in Identifier name, //PolyORB:NI: in VersionSpec version, //PolyORB:NI: in InterfaceDef interface_type //PolyORB:NI: ); //PolyORB:NI: UsesDef create_uses ( //PolyORB:NI: in RepositoryId id, //PolyORB:NI: in Identifier name, //PolyORB:NI: in VersionSpec version, //PolyORB:NI: in InterfaceDef interface_type, //PolyORB:NI: in boolean is_multiple //PolyORB:NI: ); //PolyORB:NI: EmitsDef create_emits ( //PolyORB:NI: in RepositoryId id, //PolyORB:NI: in Identifier name, //PolyORB:NI: in VersionSpec version, //PolyORB:NI: in EventDef event //PolyORB:NI: ); //PolyORB:NI: PublishesDef create_publishes ( //PolyORB:NI: in RepositoryId id, //PolyORB:NI: in Identifier name, //PolyORB:NI: in VersionSpec version, //PolyORB:NI: in EventDef event //PolyORB:NI: ); //PolyORB:NI: ConsumesDef create_consumes ( //PolyORB:NI: in RepositoryId id, //PolyORB:NI: in Identifier name, //PolyORB:NI: in VersionSpec version, //PolyORB:NI: in EventDef event //PolyORB:NI: ); //PolyORB:NI: }; //PolyORB:NI: typedef sequence //PolyORB:NI: ProvidesDescriptionSeq; //PolyORB:NI: typedef sequence UsesDescriptionSeq; //PolyORB:NI: typedef sequence //PolyORB:NI: EventPortDescriptionSeq; //PolyORB:NI: struct ComponentDescription { //PolyORB:NI: Identifier name; //PolyORB:NI: RepositoryId id; //PolyORB:NI: RepositoryId defined_in; //PolyORB:NI: VersionSpec version; //PolyORB:NI: RepositoryId base_component; //PolyORB:NI: RepositoryIdSeq supported_interfaces; //PolyORB:NI: ProvidesDescriptionSeq provided_interfaces; //PolyORB:NI: UsesDescriptionSeq used_interfaces; //PolyORB:NI: EventPortDescriptionSeq emits_events; //PolyORB:NI: EventPortDescriptionSeq publishes_events; //PolyORB:NI: EventPortDescriptionSeq consumes_events; //PolyORB:NI: ExtAttrDescriptionSeq attributes; //PolyORB:NI: TypeCode type; //PolyORB:NI: }; //PolyORB:NI: interface FactoryDef : OperationDef {}; //PolyORB:NI: interface FinderDef : OperationDef {}; //PolyORB:NI: interface HomeDef : ExtInterfaceDef { //PolyORB:NI: // read/write interface //PolyORB:NI: attribute HomeDef base_home; //PolyORB:NI: attribute InterfaceDefSeq supported_interfaces; //PolyORB:NI: attribute ComponentDef managed_component; //PolyORB:NI: attribute ValueDef primary_key; //PolyORB:NI: // write interface //PolyORB:NI: FactoryDef create_factory ( //PolyORB:NI: in RepositoryId id, //PolyORB:NI: in Identifier name, //PolyORB:NI: in VersionSpec version, //PolyORB:NI: in ParDescriptionSeq params, //PolyORB:NI: in ExceptionDefSeq exceptions //PolyORB:NI: ); //PolyORB:NI: FinderDef create_finder ( //PolyORB:NI: in RepositoryId id, //PolyORB:NI: in Identifier name, //PolyORB:NI: in VersionSpec version, //PolyORB:NI: in ParDescriptionSeq params, //PolyORB:NI: in ExceptionDefSeq exceptions //PolyORB:NI: ); //PolyORB:NI: }; //PolyORB:NI: struct HomeDescription { //PolyORB:NI: Identifier name; //PolyORB:NI: RepositoryId id; //PolyORB:NI: RepositoryId defined_in; //PolyORB:NI: VersionSpec version; //PolyORB:NI: RepositoryId base_home; //PolyORB:NI: RepositoryId managed_component; //PolyORB:NI: ValueDescription primary_key; //PolyORB:NI: OpDescriptionSeq factories; //PolyORB:NI: OpDescriptionSeq finders; //PolyORB:NI: OpDescriptionSeq operations; //PolyORB:NI: ExtAttrDescriptionSeq attributes; //PolyORB:NI: TypeCode type; //PolyORB:NI: }; //PolyORB:NI: }; #endif // _COMPONENT_REPOSITORY_ polyorb-2.8~20110207.orig/idls/CORBA_IDL/orb.idl0000644000175000017500000001506511750740337020144 0ustar xavierxavier// File: orb.idl // From CORBA 3.0 // PolyORB Notes: // NI - Not Implemented // IL - Implementation Limitation #ifndef _ORB_IDL_ #define _ORB_IDL_ //PolyORB:WAidlac: For now, idlac supports typeprefix statement only //inside a scoped_name. This definition has been moved inside the //CORBA module. //#ifdef _PRE_3_0_COMPILER_ //#pragma prefix "omg.org" //#else //typeprefix CORBA "omg.org" //#endif //PolyORB:WAidlac:end #ifdef _PRE_3_0_COMPILER_ #ifdef _NO_LOCAL_ #define local #endif #endif // This module brings together many files defining the CORBA module // (It really ought to be called CORBA.idl, but that's history.) // This file includes only the "real" interfaces that are included // in the "orb.idl" interface supplied by every ORB and that can be // brought into an IDL compilation by "import ::CORBA" // or in pre-3.0 IDL compilers by the include directive // "#include ". module CORBA { //PolyORB:WAidlac: For now, idlac supports typeprefix statement only //inside a scoped_name. This definition has been moved inside the //CORBA module. #ifdef _PRE_3_0_COMPILER_ #pragma prefix "omg.org" #else typeprefix CORBA "omg.org"; // ";" suppresses iac warning about missing ";". #endif //PolyORB:WAidlac:end // The following forward references list *all* the interfaces and valuetypes // defined in the CORBA module. This serves two purposes: documentation // and compilability. Documentation is nice: since some of the interfaces // must be declared as forward references, it is more consistent to // declare them all. // // As far as compilability, it might be possible to avoid having to declare // many of the forward reference by rearranging the order of the interface // declarations, but there's no reason to do bother doing that. After all, // that's the reason for the design of forward references. Doing a forward // reference allows the definition order to be relatively logical.In // particular, it allows the "include"s to be done in chapter order // (almost), the only exception being the InterfaceRepository (Chapter 10). // It contains some data definitions needed by Chapter 4 interfaces. // The other reason not to try to rearrange the order is that it's hard. // Forward references, alphabetically //PolyORB:NI: interface ConstructionPolicy; // Chapter 4, CORBA_DomainManager.idl local interface Current; // Chapter 4, CORBA_Current.idl interface DomainManager; // Chapter 4, CORBA_DomainManager.idl interface Policy; // Chapter 4, CORBA_Policy.idl //PolyORB:NI: local interface PollableSet; // Chapter 7, CORBA_Pollable.idl //PolyORB:NI: abstract valuetype CustomMarshal; // Chapter 5, CORBA_valuetype.idl //PolyORB:NI: abstract valuetype DataInputStream; // Chapter 5, CORBA_Stream.idl //PolyORB:NI: abstract valuetype DataOutputStream; // Chapter 5, CORBA_Stream.idl // Forward references to Chapter 10, CORBA_InterfaceRepository.idl //PolyORB:IL: interface AbstractInterfaceDef; //PolyORB:IL: interface AliasDef; interface ArrayDef; interface AttributeDef; //PolyORB:IL: interface ConstantDef; interface Contained; interface Container; //PolyORB:IL: interface EnumDef; //PolyORB:IL: interface ExceptionDef; //PolyORB:IL: interface ExtInterfaceDef; //PolyORB:NI: interface ExtValueDef; //PolyORB:IL: interface ExtAbstractInterfaceDef; //PolyORB:IL: interface ExtLocalInterfaceDef; interface FixedDef; //PolyORB:IL: interface IDLType; //PolyORB:IL: interface InterfaceDef; interface IRObject; //PolyORB:IL: interface LocalInterfaceDef; //PolyORB:IL: interface ModuleDef; //PolyORB:IL: interface NativeDef; interface OperationDef; interface PrimitiveDef; interface Repository; interface SequenceDef; interface StringDef; //PolyORB:IL: interface StructDef; interface TypeCode; interface TypedefDef; //PolyORB:IL: interface UnionDef; //PolyORB:IL: interface ValueDef; //PolyORB:IL: interface ValueBoxDef; interface ValueMemberDef; interface WstringDef; typedef string Identifier; // Chapter 3: IDL Syntax and Semantics #include // Chapter 4: ORB Interface #include #include #include // Chapter 7: Pollable //PolyORB:NI:#include // Chapter 10: The Interface Repository #include // more Chapter 4: ORB Interface // CORBA_TypeCode.idl depends on CORBA_InterfaceRepository.idl #include // Chapter 5: Value Type Semantics //PolyORB:NI:#include #include //---------------------------------------------------------------------------- //PolyORB:AB: This code is copied from CORBA Pseudo IDL specification, //primary because it define some entities, required for CORBA Services; //and for completeness. // The "define" fakes out the compiler to let it compile the "Context" // interface and references to it even though "context" is a keyword #define Context CContext // The "define" fakes out the compiler to let it compile the "Object" // interface and references to it even though "Object" is a keyword #define Object OObject // The "define" fakes out the compiler to let it compile the "ValueBase" // valuetype and references to it even though "ValueBase" is a keyword #define ValueBase VValueBase // Forward references, alphabetically interface Context; // Chapter 7, CORBA_Context.idl interface NVList; // Chapter 7, CORBA_NVList.idl interface Object; // Chapter 4, CORBA_Object.idl interface ORB; // Chapter 4, CORBA_ORB.idl interface Request; // Chapter 7, CORBA_Request.idl interface ServerRequest; // Chapter 8, CORBA_ServerRequest.idl //PolyORB:NI: valuetype ValueBase; // Chapter 4, CORBA_ValueBase.idl typedef unsigned long Flags; // Chapter 4: ORB Interface #include #include //PolyORB:NI:// Chapter 5: Value Type Semantics //PolyORB:NI:#include // Chapter 7: Dynamic Invocation Interface #include #include #include //PolyORB:NI:// Chapter 8: Dynamic Skeleton Interface #include //PolyORB:AE: //---------------------------------------------------------------------------- }; #undef Context #undef Object #undef ValueBase #endif // _ORB_IDL_ polyorb-2.8~20110207.orig/idls/CORBA_IDL/CORBA_Policy.idl0000644000175000017500000000156011750740337021522 0ustar xavierxavier// File: CORBA_Policy.idl // CORBA 3.0, Chapter 4 typedef unsigned long PolicyType; // Basic IDL definition interface Policy { readonly attribute PolicyType policy_type; Policy copy(); void destroy(); }; typedef sequence PolicyList; typedef sequence PolicyTypeSeq; //PolyORB:WACORBA: InvalidPolicies defined in CORBA 3.0.3 specification //but not defined in OMG IDL files exception InvalidPolicies { sequence indices; }; //PolyORB:WACORBA: typedef short PolicyErrorCode; exception PolicyError {PolicyErrorCode reason;}; const PolicyErrorCode BAD_POLICY = 0; const PolicyErrorCode UNSUPPORTED_POLICY = 1; const PolicyErrorCode BAD_POLICY_TYPE = 2; const PolicyErrorCode BAD_POLICY_VALUE = 3; const PolicyErrorCode UNSUPPORTED_POLICY_VALUE = 4; polyorb-2.8~20110207.orig/idls/CORBA_IDL/CORBA_Pollable.idl0000644000175000017500000000242411750740337022015 0ustar xavierxavier// File: CORBA_Pollable.idl // CORBA 3.0, Chapter 7 // interface for the Pollable sets of invocations //PolyORB:NI: local interface PollableSet; //PolyORB:NI: //PolyORB:NI: abstract valuetype Pollable { //PolyORB:NI: boolean is_ready( //PolyORB:NI: in unsigned long timeout //PolyORB:NI: ); //PolyORB:NI: //PolyORB:NI: PollableSet create_pollable_set(); //PolyORB:NI: }; //PolyORB:NI: //PolyORB:NI: abstract valuetype DIIPollable : Pollable {}; //PolyORB:NI: //PolyORB:NI: local interface PollableSet { //PolyORB:NI: //PolyORB:NI: exception NoPossiblePollable {}; //PolyORB:NI: exception UnknownPollable {}; //PolyORB:NI: //PolyORB:NI: DIIPollable create_dii_pollable(); //PolyORB:NI: //PolyORB:NI: void add_pollable( //PolyORB:NI: in Pollable potential //PolyORB:NI: ); //PolyORB:NI: //PolyORB:NI: Pollable get_ready_pollable( //PolyORB:NI: in unsigned long timeout //PolyORB:NI: ) raises(NoPossiblePollable); //PolyORB:NI: //PolyORB:NI: void remove( //PolyORB:NI: in Pollable potential //PolyORB:NI: ) raises(UnknownPollable); //PolyORB:NI: //PolyORB:NI: unsigned short number_left(); //PolyORB:NI: }; polyorb-2.8~20110207.orig/idls/Interop/0000755000175000017500000000000011750740340016755 5ustar xavierxavierpolyorb-2.8~20110207.orig/idls/Interop/IIOP.idl0000644000175000017500000000246211750740337020221 0ustar xavierxavier// File: IIOP.idl // From CORBA 3.0: Chapter 15, General Inter-ORB Protocol #ifndef _IIOP_IDL_ #define _IIOP_IDL_ #ifdef _PRE_3_0_COMPILER_ #pragma prefix "omg.org" #include #else import ::IOP; #endif // _PRE_3_0_COMPILER_ module IIOP { // IDL extended for version 1.1 and 1.2 #ifndef _PRE_3_0_COMPILER_ typeprefix IIOP "omg.org"; #endif // _PRE_3_0_COMPILER_ struct Version { octet major; octet minor; }; struct ProfileBody_1_0 {// renamed from ProfileBody Version iiop_version; string host; unsigned short port; sequence object_key; }; struct ProfileBody_1_1 {// also used for 1.2 Version iiop_version; string host; unsigned short port; sequence object_key; // Added in 1.1 unchanged for 1.2 sequence components; }; // BiDirectional IIOP struct ListenPoint { string host; unsigned short port; }; typedef sequence ListenPointList; struct BiDirIIOPServiceContext {// BI_DIR_IIOP Service Context ListenPointList listen_points; }; }; #endif // _IIOP_IDL_ polyorb-2.8~20110207.orig/idls/Interop/GIOP.idl0000644000175000017500000001677511750740337020233 0ustar xavierxavier// File: GIOP.idl // From CORBA 3.0: Chapter 15, General Inter-ORB Protocol // To compiler this for #ifndef _GIOP_IDL_ #define _GIOP_IDL_ #ifdef _PRE_3_0_COMPILER_ #include #pragma prefix "omg.org" #else import ::IOP; #endif // _PRE_3_0_COMPILER_ module GIOP { // IDL extended for version 1.1 and 1.2 #ifndef _PRE_3_0_COMPILER_ typeprefix GIOP "omg.org"; #endif // _PRE_3_0_COMPILER_ struct Version { octet major; octet minor; }; // Note: Principal is not used in V1.2 and beyond. However, it must // be available for V1.0 and V1.1 typedef sequence Principal; #ifndef GIOP_1_1 // GIOP 1.0 enum MsgType_1_0{ // rename from MsgType Request, Reply, CancelRequest, LocateRequest, LocateReply, CloseConnection, MessageError }; #else // GIOP 1.1 enum MsgType_1_1{ Request, Reply, CancelRequest, LocateRequest, LocateReply, CloseConnection, MessageError, Fragment // GIOP 1.1 addition }; #endif // GIOP_1_1 typedef MsgType_1_1 MsgType_1_2; typedef MsgType_1_1 MsgType_1_3; // GIOP 1.0 //PolyORB:IL: struct MessageHeader_1_0 {// Renamed from MessageHeader //PolyORB:IL: char magic [4]; //PolyORB:IL: Version GIOP_version; //PolyORB:IL: boolean byte_order; //PolyORB:IL: octet message_type; //PolyORB:IL: unsigned long message_size; //PolyORB:IL: }; //PolyORB:IL: //PolyORB:IL: // GIOP 1.1 //PolyORB:IL: struct MessageHeader_1_1 { //PolyORB:IL: char magic [4]; //PolyORB:IL: Version GIOP_version; //PolyORB:IL: octet flags; // GIOP 1.1 change //PolyORB:IL: octet message_type; //PolyORB:IL: unsigned long message_size; //PolyORB:IL: }; //PolyORB:IL: //PolyORB:IL: // GIOP 1.2 //PolyORB:IL: typedef MessageHeader_1_1 MessageHeader_1_2; //PolyORB:IL: //PolyORB:IL: // GIOP 1.3 //PolyORB:IL: typedef MessageHeader_1_1 MessageHeader_1_3; // GIOP 1.0 struct RequestHeader_1_0 { IOP::ServiceContextList service_context; unsigned long request_id; boolean response_expected; sequence object_key; string operation; Principal requesting_principal; }; // GIOP 1.1 //PolyORB:IL: struct RequestHeader_1_1 { //PolyORB:IL: IOP::ServiceContextList service_context; //PolyORB:IL: unsigned long request_id; //PolyORB:IL: boolean response_expected; //PolyORB:IL: octet reserved[3]; // Added in GIOP 1.1 //PolyORB:IL: sequence object_key; //PolyORB:IL: string operation; //PolyORB:IL: Principal requesting_principal; //PolyORB:IL: }; // GIOP 1.2 typedef short AddressingDisposition; const short KeyAddr = 0; const short ProfileAddr = 1; const short ReferenceAddr = 2; struct IORAddressingInfo { unsigned long selected_profile_index; IOP::IOR ior; }; union TargetAddress switch (AddressingDisposition) { case KeyAddr: sequence object_key; case ProfileAddr: IOP::TaggedProfile profile; case ReferenceAddr: IORAddressingInfo ior; }; struct RequestHeader_1_2 { unsigned long request_id; octet response_flags; octet reserved[3]; TargetAddress target; string operation; // Principal not in GIOP 1.2 IOP::ServiceContextList service_context; // 1.2 change }; // GIOP 1.3 typedef RequestHeader_1_2 RequestHeader_1_3; #ifndef GIOP_1_2 // GIOP 1.0 and 1.1 enum ReplyStatusType_1_0 {// Renamed from ReplyStatusType NO_EXCEPTION, USER_EXCEPTION, SYSTEM_EXCEPTION, LOCATION_FORWARD }; // GIOP 1.0 struct ReplyHeader_1_0 {// Renamed from ReplyHeader IOP::ServiceContextList service_context; unsigned long request_id; ReplyStatusType_1_0 reply_status; }; // GIOP 1.1 typedef ReplyHeader_1_0 ReplyHeader_1_1; // Same Header contents for 1.0 and 1.1 #else // GIOP 1.2 enum ReplyStatusType_1_2 { NO_EXCEPTION, USER_EXCEPTION, SYSTEM_EXCEPTION, LOCATION_FORWARD, LOCATION_FORWARD_PERM, // new value for 1.2 NEEDS_ADDRESSING_MODE // new value for 1.2 }; struct ReplyHeader_1_2 { unsigned long request_id; ReplyStatusType_1_2 reply_status; IOP::ServiceContextList service_context; // 1.2 change }; // GIOP 1.3 typedef ReplyHeader_1_2 ReplyHeader_1_3; #endif // GIOP_1_2 struct SystemExceptionReplyBody { string exception_id; unsigned long minor_code_value; unsigned long completion_status; }; struct CancelRequestHeader { unsigned long request_id; }; // GIOP 1.0 struct LocateRequestHeader_1_0 {// Renamed LocationRequestHeader unsigned long request_id; sequence object_key; }; // GIOP 1.1 typedef LocateRequestHeader_1_0 LocateRequestHeader_1_1; // Same Header contents for 1.0 and 1.1 // GIOP 1.2 struct LocateRequestHeader_1_2 { unsigned long request_id; TargetAddress target; }; // GIOP 1.3 typedef LocateRequestHeader_1_2 LocateRequestHeader_1_3; #ifndef GIOP_1_2 // GIOP 1.0 and 1.1 enum LocateStatusType_1_0 {// Renamed from LocateStatusType UNKNOWN_OBJECT, OBJECT_HERE, OBJECT_FORWARD }; // GIOP 1.0 struct LocateReplyHeader_1_0 {// Renamed from LocateReplyHeader unsigned long request_id; LocateStatusType_1_0 locate_status; }; // GIOP 1.1 typedef LocateReplyHeader_1_0 LocateReplyHeader_1_1; // same Header contents for 1.0 and 1.1 #else // GIOP 1.2 enum LocateStatusType_1_2 { UNKNOWN_OBJECT, OBJECT_HERE, OBJECT_FORWARD, OBJECT_FORWARD_PERM, // new value for GIOP 1.2 LOC_SYSTEM_EXCEPTION, // new value for GIOP 1.2 LOC_NEEDS_ADDRESSING_MODE // new value for GIOP 1.2 }; struct LocateReplyHeader_1_2 { unsigned long request_id; LocateStatusType_1_2 locate_status; }; // GIOP 1.3 typedef LocateReplyHeader_1_2 LocateReplyHeader_1_3; #endif // GIOP_1_2 // GIOP 1.2 struct FragmentHeader_1_2 { unsigned long request_id; }; // GIOP 1.3 typedef FragmentHeader_1_2 FragmentHeader_1_3; }; #endif // _GIOP_IDL_ polyorb-2.8~20110207.orig/idls/Interop/IOP.idl0000644000175000017500000001451011750740337020105 0ustar xavierxavier// File: IOP.idl // From CORBA 3.0: Chapter 13, ORB Interoperability Achitecture // PolyORB:WAGCORBA This file has been updated to take into acocunt OMG // Issue 5232 (anonymous sequence types are deprecated). #ifndef _IOP_IDL_ #define _IOP_IDL_ #ifdef _PRE_3_0_COMPILER_ #pragma prefix "omg.org" #include #else import ::CORBA; #endif // _PRE_3_0_COMPILER_ module IOP { #ifndef _PRE_3_0_COMPILER_ typeprefix IOP "omg.org"; #endif // _PRE_3_0_COMPILER_ // IOR Profiles // Standard Protocol Profile tag values typedef unsigned long ProfileId; const ProfileId TAG_INTERNET_IOP = 0; const ProfileId TAG_MULTIPLE_COMPONENTS = 1; const ProfileId TAG_SCCP_IOP = 2; typedef CORBA::OctetSeq ProfileData; struct TaggedProfile { ProfileId tag; ProfileData profile_data; }; typedef sequence TaggedProfileSeq ; // The IOR // an Interoperable Object Reference is a sequence of // object-specific protocol profiles, plus a type ID. struct IOR { string type_id; TaggedProfileSeq profiles; }; // IOR Components // Standard way of representing multicomponent profiles. // This would be encapsulated in a TaggedProfile. typedef unsigned long ComponentId; typedef CORBA::OctetSeq ComponentData; struct TaggedComponent { ComponentId tag; ComponentData component_data; }; typedef sequence TaggedComponentSeq; typedef CORBA::OctetSeq ObjectKey; typedef sequence MultipleComponentProfile; const ComponentId TAG_ORB_TYPE = 0; const ComponentId TAG_CODE_SETS = 1; const ComponentId TAG_POLICIES = 2; const ComponentId TAG_ALTERNATE_IIOP_ADDRESS = 3; const ComponentId TAG_ASSOCIATION_OPTIONS = 13; const ComponentId TAG_SEC_NAME = 14; const ComponentId TAG_SPKM_1_SEC_MECH = 15; const ComponentId TAG_SPKM_2_SEC_MECH = 16; const ComponentId TAG_KerberosV5_SEC_MECH = 17; const ComponentId TAG_CSI_ECMA_Secret_SEC_MECH= 18; const ComponentId TAG_CSI_ECMA_Hybrid_SEC_MECH= 19; const ComponentId TAG_SSL_SEC_TRANS = 20; const ComponentId TAG_CSI_ECMA_Public_SEC_MECH= 21; const ComponentId TAG_GENERIC_SEC_MECH = 22; const ComponentId TAG_FIREWALL_TRANS = 23; const ComponentId TAG_SCCP_CONTACT_INFO = 24; const ComponentId TAG_JAVA_CODEBASE = 25; const ComponentId TAG_TRANSACTION_POLICY = 26; const ComponentId TAG_MESSAGE_ROUTER = 30; const ComponentId TAG_OTS_POLICY = 31; const ComponentId TAG_INV_POLICY = 32; const ComponentId TAG_CSI_SEC_MECH_LIST = 33; const ComponentId TAG_NULL_TAG = 34; const ComponentId TAG_SECIOP_SEC_TRANS = 35; const ComponentId TAG_TLS_SEC_TRANS = 36; const ComponentId TAG_ACTIVITY_POLICY = 37; const ComponentId TAG_COMPLETE_OBJECT_KEY = 5; const ComponentId TAG_ENDPOINT_ID_POSITION = 6; const ComponentId TAG_LOCATION_POLICY = 12; const ComponentId TAG_DCE_STRING_BINDING = 100; const ComponentId TAG_DCE_BINDING_NAME = 101; const ComponentId TAG_DCE_NO_PIPES = 102; const ComponentId TAG_DCE_SEC_MECH = 103; const ComponentId TAG_INET_SEC_TRANS = 123; // Service Contexts typedef CORBA::OctetSeq ContextData; typedef unsigned long ServiceId; struct ServiceContext { ServiceId context_id; ContextData context_data; }; typedef sequence ServiceContextList; const ServiceId TransactionService = 0; const ServiceId CodeSets = 1; const ServiceId ChainBypassCheck = 2; const ServiceId ChainBypassInfo = 3; const ServiceId LogicalThreadId = 4; const ServiceId BI_DIR_IIOP = 5; const ServiceId SendingContextRunTime = 6; const ServiceId INVOCATION_POLICIES = 7; const ServiceId FORWARDED_IDENTITY = 8; const ServiceId UnknownExceptionInfo = 9; const ServiceId RTCorbaPriority = 10; const ServiceId RTCorbaPriorityRange = 11; const ServiceId FT_GROUP_VERSION = 12; const ServiceId FT_REQUEST = 13; const ServiceId ExceptionDetailMessage = 14; const ServiceId SecurityAttributeService = 15; const ServiceId ActivityService = 16; // Coder Decoder from Portable Interceptor local interface Codec { exception InvalidTypeForEncoding {}; exception FormatMismatch {}; exception TypeMismatch {}; CORBA::OctetSeq encode (in any data) raises (InvalidTypeForEncoding); any decode (in CORBA::OctetSeq data) raises (FormatMismatch); CORBA::OctetSeq encode_value (in any data) raises (InvalidTypeForEncoding); any decode_value ( in CORBA::OctetSeq data, in CORBA::TypeCode tc) raises (FormatMismatch, TypeMismatch); }; // Codec Factory typedef short EncodingFormat; const EncodingFormat ENCODING_CDR_ENCAPS = 0; struct Encoding { EncodingFormat format; octet major_version; octet minor_version; }; local interface CodecFactory { exception UnknownEncoding {}; Codec create_codec (in Encoding enc) raises (UnknownEncoding); }; }; // #include #endif // _IOP_IDL_ polyorb-2.8~20110207.orig/idls/Interop/GSSUP.idl0000644000175000017500000000337211750740337020363 0ustar xavierxavier// // File: GSSUP.idl // CORBA 3.0 Chapter 24 #ifndef _GSSUP_IDL_ #define _GSSUP_IDL_ #ifdef _PRE_3_0_COMPILER_ #include #pragma prefix "omg.org" #else import ::CSI; #endif // _PRE_3_0_COMPILER_ module GSSUP { #ifndef _PRE_3_0_COMPILER_ typeprefix GSSUP "omg.org"; #endif // _PRE_3_0_COMPILER_ // The GSS Object Identifier allocated for the // username/password mechanism is defined below. // // { iso-itu-t (2) international-organization (23) omg (130) // security (1) authentication (1) gssup-mechanism (1) } const CSI::StringOID GSSUPMechOID = "oid:2.23.130.1.1.1"; // The following structure defines the inner contents of the // username password initial context token. This structure is // CDR encapsulated and appended at the end of the // username/password GSS (initial context) Token. struct InitialContextToken { CSI::UTF8String username; CSI::UTF8String password; CSI::GSS_NT_ExportedName target_name; }; typedef unsigned long ErrorCode; // GSSUP Mechanism-Specific Error Token struct ErrorToken { ErrorCode error_code; }; // The context validator has chosen not to reveal the GSSUP // specific cause of the failure. const ErrorCode GSS_UP_S_G_UNSPECIFIED = 1; // The user identified in the username field of the // GSSUP::InitialContextToken is unknown to the target. const ErrorCode GSS_UP_S_G_NOUSER = 2; // The password supplied in the GSSUP::InitialContextToken was // incorrect. const ErrorCode GSS_UP_S_G_BAD_PASSWORD = 3; // The target_name supplied in the GSSUP::InitialContextToken does // not match a target_name in a mechanism definition of the target. const ErrorCode GSS_UP_S_G_BAD_TARGET = 4; }; // GSSUP #endif polyorb-2.8~20110207.orig/idls/Interop/BiDirPolicy.idl0000644000175000017500000000204511750740337021627 0ustar xavierxavier// File: BiDirPolicy.idl // From CORBA 3.0: Chapter 15, General Inter-ORB Protocol #ifndef _BIDIR_POLICY_IDL_ #define _BIDIR_POLICY_IDL_ #ifdef _PRE_3_0_COMPILER_ #pragma prefix "omg.org" #include #else //PolyORB:NI:import ::CORBA; #endif // _PRE_3_0_COMPILER_ //PolyORB:NI:// Self contained module for Bi-directional GIOP policy //PolyORB:NI:module BiDirPolicy { //PolyORB:NI: //PolyORB:NI:#ifndef _PRE_3_0_COMPILER_ //PolyORB:NI: typeprefix BiDirPolicy "omg.org"; //PolyORB:NI:#endif // _PRE_3_0_COMPILER_ //PolyORB:NI: //PolyORB:NI: typedef unsigned short BidirectionalPolicyValue; //PolyORB:NI: //PolyORB:NI: const BidirectionalPolicyValue NORMAL = 0; //PolyORB:NI: const BidirectionalPolicyValue BOTH = 1; //PolyORB:NI: const CORBA::PolicyType BIDIRECTIONAL_POLICY_TYPE = 37; //PolyORB:NI: //PolyORB:NI: interface BidirectionalPolicy : CORBA::Policy { //PolyORB:NI: readonly attribute BidirectionalPolicyValue value; //PolyORB:NI: }; //PolyORB:NI:}; #endif // _BIDIR_POLICY_IDL_ polyorb-2.8~20110207.orig/idls/Interop/CONV_FRAME.idl0000644000175000017500000000171111750740337021134 0ustar xavierxavier// File: CONV_FRAME.idl // From CORBA 3.0: Chapter 13, Interoperability Architecture // PolyORB:WAGCORBA This file has been update to take into acocunt OMG // Issue 5232 (anonymous sequence types are deprecated). #ifndef _CONV_FRAME_IDL #define _CONV_FRAME_IDL #ifdef _PRE_3_0_COMPILER_ #pragma prefix "omg.org" #endif module CONV_FRAME { #ifndef _PRE_3_0_COMPILER_ typeprefix CONV_FRAME "omg.org"; #endif typedef unsigned long CodeSetId; typedef sequence CodeSetIdSeq; struct CodeSetComponent { CodeSetId native_code_set; CodeSetIdSeq conversion_code_sets; }; struct CodeSetComponentInfo { CodeSetComponent ForCharData; CodeSetComponent ForWcharData; }; // CodeSet Service Context information struct CodeSetContext { CodeSetId char_data; CodeSetId wchar_data; }; }; #endif // _CONV_FRAME_IDL polyorb-2.8~20110207.orig/idls/Interop/SendingContext.idl0000644000175000017500000000425011750740337022412 0ustar xavierxavier// File: SendingContext.idl // CORBA 2.5.1, Chapter 5 #ifndef _SENDING_CONTEXT_IDL_ #define _SENDING_CONTEXT_IDL_ #ifdef _PRE_3_0_COMPILER_ #include #pragma prefix "omg.org" #else //PolyORB:NI:import ::CORBA; #endif // _PRE_3_0_COMPILER_ //PolyORB:NI:module SendingContext { //PolyORB:NI: //PolyORB:NI:#ifndef _PRE_3_0_COMPILER_ //PolyORB:NI: typeprefix SendingContext "omg.org"; //PolyORB:NI:#endif // _PRE_3_0_COMPILER_ //PolyORB:NI: //PolyORB:NI: interface RunTime {}; // so that we can provide more //PolyORB:NI: // sending context run time //PolyORB:NI: // services in the future //PolyORB:NI: //PolyORB:NI: interface CodeBase: RunTime { //PolyORB:NI: typedef string URL; // blank-separated list of one or more URLs //PolyORB:NI: typedef sequence URLSeq; //PolyORB:NI: typedef sequence ValueDescSeq; //PolyORB:NI: //PolyORB:NI: // Operation to obtain the IR from the sending context //PolyORB:NI: CORBA::Repository get_ir(); //PolyORB:NI: //PolyORB:NI: // Operations to obtain a location of the implementation code //PolyORB:NI: URL implementation( in CORBA::RepositoryId x); //PolyORB:NI: URL implementationx( in CORBA::RepositoryId x); //PolyORB:NI: URLSeq implementations( in CORBA::RepositoryIdSeq x); //PolyORB:NI: //PolyORB:NI: // Operations to obtain complete meta information about a Value //PolyORB:NI: // This is just a performance optimization the IR can provide //PolyORB:NI: // the same information //PolyORB:NI: CORBA::ValueDef::FullValueDescription meta( in CORBA::RepositoryId x); //PolyORB:NI: ValueDescSeq metas(in CORBA::RepositoryIdSeq x); //PolyORB:NI: //PolyORB:NI: // To obtain a type graph for a value type //PolyORB:NI: // same comment as before the IR can provide similar //PolyORB:NI: // information //PolyORB:NI: CORBA::RepositoryIdSeq bases( in CORBA::RepositoryId x); //PolyORB:NI: }; //PolyORB:NI:}; #endif // _SENDING_CONTEXT_IDL_ polyorb-2.8~20110207.orig/idls/Interop/CSI.idl0000644000175000017500000001740111750740337020076 0ustar xavierxavier// // CSI.idl // CORBA Core 3.0 Chapter 24 #ifndef _CSI_IDL_ #define _CSI_IDL_ #ifdef _PRE_3_0_COMPILER_ #pragma prefix "omg.org" #else #endif // _PRE_3_0_COMPILER_ module CSI { #ifndef _PRE_3_0_COMPILER_ typeprefix CSI "omg.org"; #endif // _PRE_3_0_COMPILER_ // The OMG VMCID; same value as CORBA::OMGVMCID. Do not change ever. const unsigned long OMGVMCID = 0x4F4D0; // An X509CertificateChain contains an ASN.1 BER encoded SEQUENCE // [1..MAX] OF X.509 certificates encapsulated in a sequence of octets. The // subject's certificate shall come first in the list. Each following // certificate shall directly certify the one preceding it. The ASN.1 // representation of Certificate is as defined in [IETF RFC 2459]. typedef sequence X509CertificateChain; // an X.501 type name or Distinguished Name encapsulated in a sequence of // octets containing the ASN.1 encoding. typedef sequence X501DistinguishedName; // UTF-8 Encoding of String typedef sequence UTF8String; // ASN.1 Encoding of an OBJECT IDENTIFIER typedef sequence OID; typedef sequence OIDList; // A sequence of octets containing a GSStoken. Initial context tokens are // ASN.1 encoded as defined in [IETF RFC 2743] Section 3.1, // "Mechanism-Independent token Format", pp. 81-82. Initial context tokens // contain an ASN.1 tag followed by a token length, a mechanism identifier, // and a mechanism-specific token (i.e. a GSSUP::InitialContextToken). The // encoding of all other GSS tokens (e.g. error tokens and final context // tokens) is mechanism dependent. typedef sequence GSSToken; // An encoding of a GSS Mechanism-Independent Exported Name Object as // defined in [IETF RFC 2743] Section 3.2, "GSS Mechanism-Independent // Exported Name Object Format," p. 84. typedef sequence GSS_NT_ExportedName; typedef sequence GSS_NT_ExportedNameList; // The MsgType enumeration defines the complete set of service context // message types used by the CSI context management protocols, including // those message types pertaining only to the stateful application of the // protocols (to insure proper alignment of the identifiers between // stateless and stateful implementations). Specifically, the // MTMessageInContext is not sent by stateless clients (although it may // be received by stateless targets). typedef short MsgType; const MsgType MTEstablishContext = 0; const MsgType MTCompleteEstablishContext = 1; const MsgType MTContextError = 4; const MsgType MTMessageInContext = 5; // The ContextId type is used carry session identifiers. A stateless // application of the service context protocol is indicated by a session // identifier value of 0. typedef unsigned long long ContextId; // The AuthorizationElementType defines the contents and encoding of // the_element field of the AuthorizationElement. // The high order 20-bits of each AuthorizationElementType constant // shall contain the Vendor Minor Codeset ID (VMCID) of the // organization that defined the element type. The low order 12 bits // shall contain the organization-scoped element type identifier. The // high-order 20 bits of all element types defined by the OMG shall // contain the VMCID allocated to the OMG (that is, 0x4F4D0). typedef unsigned long AuthorizationElementType; // An AuthorizationElementType of X509AttributeCertChain indicates that // the_element field of the AuthorizationElement contains an ASN.1 BER // SEQUENCE composed of an (X.509) AttributeCertificate followed by a // SEQUENCE OF (X.509) Certificate. The two-part SEQUENCE is encapsulated // in an octet stream. The chain of identity certificates is provided // to certify the attribute certificate. Each certificate in the chain // shall directly certify the one preceding it. The first certificate // in the chain shall certify the attribute certificate. The ASN.1 // representation of (X.509) Certificate is as defined in [IETF RFC 2459]. // The ASN.1 representation of (X.509) AtributeCertificate is as defined // in [IETF ID PKIXAC]. const AuthorizationElementType X509AttributeCertChain = OMGVMCID | 1; typedef sequence AuthorizationElementContents; // The AuthorizationElement contains one element of an authorization token. // Each element of an authorization token is logically a PAC. struct AuthorizationElement { AuthorizationElementType the_type; AuthorizationElementContents the_element; }; // The AuthorizationToken is made up of a sequence of // AuthorizationElements typedef sequence AuthorizationToken; typedef unsigned long IdentityTokenType; // Additional standard identity token types shall only be defined by the // OMG. All IdentityTokenType constants shall be a power of 2. const IdentityTokenType ITTAbsent = 0; const IdentityTokenType ITTAnonymous = 1; const IdentityTokenType ITTPrincipalName = 2; const IdentityTokenType ITTX509CertChain = 4; const IdentityTokenType ITTDistinguishedName = 8; typedef sequence IdentityExtension; union IdentityToken switch ( IdentityTokenType ) { case ITTAbsent: boolean absent; case ITTAnonymous: boolean anonymous; case ITTPrincipalName: GSS_NT_ExportedName principal_name; case ITTX509CertChain: X509CertificateChain certificate_chain; case ITTDistinguishedName: X501DistinguishedName dn; default: IdentityExtension id; }; struct EstablishContext { ContextId client_context_id; AuthorizationToken authorization_token; IdentityToken identity_token; GSSToken client_authentication_token; }; struct CompleteEstablishContext { ContextId client_context_id; boolean context_stateful; GSSToken final_context_token; }; struct ContextError { ContextId client_context_id; long major_status; long minor_status; GSSToken error_token; }; // Not sent by stateless clients. If received by a stateless server, a // ContextError message should be returned, indicating the session does // not exist. struct MessageInContext { ContextId client_context_id; boolean discard_context; }; union SASContextBody switch ( MsgType ) { case MTEstablishContext: EstablishContext establish_msg; case MTCompleteEstablishContext: CompleteEstablishContext complete_msg; case MTContextError: ContextError error_msg; case MTMessageInContext: MessageInContext in_context_msg; }; // The following type represents the string representation of an ASN.1 // OBJECT IDENTIFIER (OID). OIDs are represented by the string "oid:" // followed by the integer base 10 representation of the OID separated // by dots. For example, the OID corresponding to the OMG is represented // as: "oid:2.23.130" typedef string StringOID; // The GSS Object Identifier for the KRB5 mechanism is: // { iso(1) member-body(2) United States(840) mit(113554) infosys(1) // gssapi(2) krb5(2) } const StringOID KRB5MechOID = "oid:1.2.840.113554.1.2.2"; // The GSS Object Identifier for name objects of the Mechanism-idependent // Exported Name Object type is: // { iso(1) org(3) dod(6) internet(1) security(5) nametypes(6) // gss-api-exported-name(4) } const StringOID GSS_NT_Export_Name_OID = "oid:1.3.6.1.5.6.4"; // The GSS Object Identifier for the scoped-username name form is: // { iso-itu-t (2) international-organization (23) omg (130) security (1) // naming (2) scoped-username(1) } const StringOID GSS_NT_Scoped_Username_OID = "oid:2.23.130.1.2.1"; }; // CSI #endif polyorb-2.8~20110207.orig/idls/Interop/CSIIOP.idl0000644000175000017500000001075211750740337020450 0ustar xavierxavier// // File: CSIIOP.idl // CORBA 3.0, Chapter 22 #ifndef _CSIIOP_IDL_ #define _CSIIOP_IDL_ #ifdef _PRE_3_0_COMPILER_ #pragma prefix "omg.org" #include #include #else import ::IOP; import ::CSI; #endif // _PRE_3_0_COMPILER_ module CSIIOP { #ifndef _PRE_3_0_COMPILER_ typeprefix CSIIOP "omg.org"; #endif // _PRE_3_0_COMPILER_ // Association options typedef unsigned short AssociationOptions; const AssociationOptions NoProtection = 1; const AssociationOptions Integrity = 2; const AssociationOptions Confidentiality = 4; const AssociationOptions DetectReplay = 8; const AssociationOptions DetectMisordering = 16; const AssociationOptions EstablishTrustInTarget = 32; const AssociationOptions EstablishTrustInClient = 64; const AssociationOptions NoDelegation = 128; const AssociationOptions SimpleDelegation = 256; const AssociationOptions CompositeDelegation = 512; const AssociationOptions IdentityAssertion = 1024; const AssociationOptions DelegationByClient = 2048; // The high order 20-bits of each ServiceConfigurationSyntax constant // shall contain the Vendor Minor Codeset ID (VMCID) of the // organization that defined the syntax. The low order 12 bits shall // contain the organization-scoped syntax identifier. The high-order 20 // bits of all syntaxes defined by the OMG shall contain the VMCID // allocated to the OMG (that is, 0x4F4D0). typedef unsigned long ServiceConfigurationSyntax; const ServiceConfigurationSyntax SCS_GeneralNames = CSI::OMGVMCID | 0; const ServiceConfigurationSyntax SCS_GSSExportedName = CSI::OMGVMCID | 1; typedef sequence ServiceSpecificName; // The name field of the ServiceConfiguration structure identifies a // privilege authority in the format identified in the syntax field. If the // syntax is SCS_GeneralNames, the name field contains an ASN.1 (BER) // SEQUENCE [1..MAX] OF GeneralName, as defined by the type GeneralNames in // [IETF RFC 2459]. If the syntax is SCS_GSSExportedName, the name field // contains a GSS exported name encoded according to the rules in // [IETF RFC 2743] Section 3.2, "Mechanism-Independent Exported Name // Object Format," p. 84. struct ServiceConfiguration { ServiceConfigurationSyntax syntax; ServiceSpecificName name; }; typedef sequence ServiceConfigurationList; // The body of the TAG_NULL_TAG component is a sequence of octets of // length 0. // type used to define AS layer functionality within a compound mechanism // definition struct AS_ContextSec { AssociationOptions target_supports; AssociationOptions target_requires; CSI::OID client_authentication_mech; CSI::GSS_NT_ExportedName target_name; }; // type used to define SAS layer functionality within a compound mechanism // definition struct SAS_ContextSec { AssociationOptions target_supports; AssociationOptions target_requires; ServiceConfigurationList privilege_authorities; CSI::OIDList supported_naming_mechanisms; CSI::IdentityTokenType supported_identity_types; }; // type used in the body of a TAG_CSI_SEC_MECH_LIST component to // describe a compound mechanism struct CompoundSecMech { AssociationOptions target_requires; IOP::TaggedComponent transport_mech; AS_ContextSec as_context_mech; SAS_ContextSec sas_context_mech; }; typedef sequence CompoundSecMechanisms; // type corresponding to the body of a TAG_CSI_SEC_MECH_LIST // component struct CompoundSecMechList { boolean stateful; CompoundSecMechanisms mechanism_list; }; struct TransportAddress { string host_name; unsigned short port; }; typedef sequence TransportAddressList; // Tagged component for configuring SECIOP as a CSIv2 transport mechanism const IOP::ComponentId TAG_SECIOP_SEC_TRANS = 35; struct SECIOP_SEC_TRANS { AssociationOptions target_supports; AssociationOptions target_requires; CSI::OID mech_oid; CSI::GSS_NT_ExportedName target_name; TransportAddressList addresses; }; // tagged component for configuring TLS/SSL as a CSIv2 transport mechanism const IOP::ComponentId TAG_TLS_SEC_TRANS = 36; struct TLS_SEC_TRANS { AssociationOptions target_supports; AssociationOptions target_requires; TransportAddressList addresses; }; }; //CSIIOP #endif // _CSIIOP_IDL_ polyorb-2.8~20110207.orig/idls/Interop/IOP_DCE.idl0000644000175000017500000000133311750740337020557 0ustar xavierxavier// File: IOP-DCE.idl // From CORBA 3.0: Chapter 13, ORB Interoperability Achitecture // if you want to copile this file then uncomment the line including // this file that reads "#include " in IOP.idl #ifndef _IOP_DCE_IDL_ #define _IOP_DCE_IDL_ //PolyORB:NI:module IOP { //PolyORB:NI: //PolyORB:NI: struct EndpointIdPositionComponent { //PolyORB:NI: unsigned short begin; //PolyORB:NI: unsigned short end; //PolyORB:NI: }; //PolyORB:NI: //PolyORB:NI: //PolyORB:NI:// IDL does not support octet constants //PolyORB:NI:#define LOCATE_NEVER 0 //PolyORB:NI:#define LOCATE_OBJECT 1 //PolyORB:NI:#define LOCATE_OPERATION 2 //PolyORB:NI:#define LOCATE_ALWAYS 3 //PolyORB:NI:}; #endif // _IOP_DCE_IDL_ polyorb-2.8~20110207.orig/idls/cos/0000755000175000017500000000000011750740340016121 5ustar xavierxavierpolyorb-2.8~20110207.orig/idls/cos/trader/0000755000175000017500000000000011750740340017402 5ustar xavierxavierpolyorb-2.8~20110207.orig/idls/cos/trader/CosTradingRepos.idl0000644000175000017500000000673311750740337023161 0ustar xavierxavier//File: CosTradingRepos.idl //Part of the Trading Object Service //OMG File: 98-10-50 #ifndef _COS_TRADING_REPOS_IDL_ #define _COS_TRADING_REPOS_IDL_ #ifdef _PRE_3_0_COMPILER_ #include #include #pragma prefix "omg.org" #else import ::CORBA; import ::CosTrading; #endif // _PRE_3_0_COMPILER_ module CosTradingRepos { #ifndef _PRE_3_0_COMPILER_ typeprefix CosTradingRepos "omg.org"; #endif // _PRE_3_0_COMPILER_ interface ServiceTypeRepository { // local types typedef sequence ServiceTypeNameSeq; enum PropertyMode { PROP_NORMAL, PROP_READONLY, PROP_MANDATORY, PROP_MANDATORY_READONLY }; struct PropStruct { CosTrading::PropertyName name; CORBA::TypeCode value_type; PropertyMode mode; }; typedef sequence PropStructSeq; typedef CosTrading::Istring Identifier; // IR::Identifier struct IncarnationNumber { unsigned long high; unsigned long low; }; struct TypeStruct { Identifier if_name; PropStructSeq props; ServiceTypeNameSeq super_types; boolean masked; IncarnationNumber incarnation; }; enum ListOption { all, since }; union SpecifiedServiceTypes switch ( ListOption ) { case since: IncarnationNumber incarnation; }; // local exceptions exception ServiceTypeExists { CosTrading::ServiceTypeName name; }; exception InterfaceTypeMismatch { CosTrading::ServiceTypeName base_service; Identifier base_if; CosTrading::ServiceTypeName derived_service; Identifier derived_if; }; exception HasSubTypes { CosTrading::ServiceTypeName the_type; CosTrading::ServiceTypeName sub_type; }; exception AlreadyMasked { CosTrading::ServiceTypeName name; }; exception NotMasked { CosTrading::ServiceTypeName name; }; exception ValueTypeRedefinition { CosTrading::ServiceTypeName type_1; PropStruct definition_1; CosTrading::ServiceTypeName type_2; PropStruct definition_2; }; exception DuplicateServiceTypeName { CosTrading::ServiceTypeName name; }; // attributes readonly attribute IncarnationNumber incarnation; // operation signatures IncarnationNumber add_type ( in CosTrading::ServiceTypeName name, in Identifier if_name, in PropStructSeq props, in ServiceTypeNameSeq super_types ) raises ( CosTrading::IllegalServiceType, ServiceTypeExists, InterfaceTypeMismatch, CosTrading::IllegalPropertyName, CosTrading::DuplicatePropertyName, ValueTypeRedefinition, CosTrading::UnknownServiceType, DuplicateServiceTypeName ); void remove_type ( in CosTrading::ServiceTypeName name ) raises ( CosTrading::IllegalServiceType, CosTrading::UnknownServiceType, HasSubTypes ); ServiceTypeNameSeq list_types ( in SpecifiedServiceTypes which_types ); TypeStruct describe_type ( in CosTrading::ServiceTypeName name ) raises ( CosTrading::IllegalServiceType, CosTrading::UnknownServiceType ); TypeStruct fully_describe_type ( in CosTrading::ServiceTypeName name ) raises ( CosTrading::IllegalServiceType, CosTrading::UnknownServiceType ); void mask_type ( in CosTrading::ServiceTypeName name ) raises ( CosTrading::IllegalServiceType, CosTrading::UnknownServiceType, AlreadyMasked ); void unmask_type ( in CosTrading::ServiceTypeName name ) raises ( CosTrading::IllegalServiceType, CosTrading::UnknownServiceType, NotMasked ); }; }; /* end module CosTradingRepos */ #endif /* ifndef _COS_TRADING_REPOS_IDL_ */ polyorb-2.8~20110207.orig/idls/cos/trader/CosTrading.idl0000644000175000017500000002566611750740337022156 0ustar xavierxavier//File: CosTrading.idl //Part of the Trading Object Service //OMG File: 98-10-48 #ifndef _COS_TRADING_IDL_ #define _COS_TRADING_IDL_ #ifdef _PRE_3_0_COMPILER_ #pragma prefix "omg.org" #endif // _PRE_3_0_COMPILER_ module CosTrading { #ifndef _PRE_3_0_COMPILER_ typeprefix CosTrading "omg.org"; #endif // _PRE_3_0_COMPILER_ // forward references to our interfaces interface Lookup; interface Register; interface Link; interface Proxy; interface Admin; interface OfferIterator; interface OfferIdIterator; // type definitions used in more than one interface typedef string Istring; typedef Object TypeRepository; typedef Istring PropertyName; typedef sequence PropertyNameSeq; typedef any PropertyValue; struct Property { PropertyName name; PropertyValue value; }; typedef sequence PropertySeq; struct Offer { Object reference; PropertySeq properties; }; typedef sequence OfferSeq; typedef string OfferId; typedef sequence OfferIdSeq; typedef Istring ServiceTypeName; // similar structure to IR::Identifier typedef Istring Constraint; enum FollowOption { local_only, if_no_local, always }; typedef Istring LinkName; typedef sequence LinkNameSeq; typedef LinkNameSeq TraderName; typedef string PolicyName; // policy names restricted to Latin1 typedef sequence PolicyNameSeq; typedef any PolicyValue; struct Policy { PolicyName name; PolicyValue value; }; typedef sequence PolicySeq; // exceptions used in more than one interface exception UnknownMaxLeft {}; exception NotImplemented {}; exception IllegalServiceType { ServiceTypeName type; }; exception UnknownServiceType { ServiceTypeName type; }; exception IllegalPropertyName { PropertyName name; }; exception DuplicatePropertyName { PropertyName name; }; exception PropertyTypeMismatch { ServiceTypeName type; Property prop; }; exception MissingMandatoryProperty { ServiceTypeName type; PropertyName name; }; exception ReadonlyDynamicProperty { ServiceTypeName type; PropertyName name; }; exception IllegalConstraint { Constraint constr; }; exception InvalidLookupRef { Lookup target; }; exception IllegalOfferId { OfferId id; }; exception UnknownOfferId { OfferId id; }; exception DuplicatePolicyName { PolicyName name; }; // the interfaces interface TraderComponents { readonly attribute Lookup lookup_if; readonly attribute Register register_if; readonly attribute Link link_if; readonly attribute Proxy proxy_if; readonly attribute Admin admin_if; }; interface SupportAttributes { readonly attribute boolean supports_modifiable_properties; readonly attribute boolean supports_dynamic_properties; readonly attribute boolean supports_proxy_offers; readonly attribute TypeRepository type_repos; }; interface ImportAttributes { readonly attribute unsigned long def_search_card; readonly attribute unsigned long max_search_card; readonly attribute unsigned long def_match_card; readonly attribute unsigned long max_match_card; readonly attribute unsigned long def_return_card; readonly attribute unsigned long max_return_card; readonly attribute unsigned long max_list; readonly attribute unsigned long def_hop_count; readonly attribute unsigned long max_hop_count; readonly attribute FollowOption def_follow_policy; readonly attribute FollowOption max_follow_policy; }; interface LinkAttributes { readonly attribute FollowOption max_link_follow_policy; }; interface Lookup:TraderComponents,SupportAttributes,ImportAttributes { typedef Istring Preference; enum HowManyProps { none, some, all }; union SpecifiedProps switch ( HowManyProps ) { case some: PropertyNameSeq prop_names; }; exception IllegalPreference { Preference pref; }; exception IllegalPolicyName { PolicyName name; }; exception PolicyTypeMismatch { Policy the_policy; }; exception InvalidPolicyValue { Policy the_policy; }; void query ( in ServiceTypeName type, in Constraint constr, in Preference pref, in PolicySeq policies, in SpecifiedProps desired_props, in unsigned long how_many, out OfferSeq offers, out OfferIterator offer_itr, out PolicyNameSeq limits_applied ) raises ( IllegalServiceType, UnknownServiceType, IllegalConstraint, IllegalPreference, IllegalPolicyName, PolicyTypeMismatch, InvalidPolicyValue, IllegalPropertyName, DuplicatePropertyName, DuplicatePolicyName ); }; interface Register : TraderComponents, SupportAttributes { struct OfferInfo { Object reference; ServiceTypeName type; PropertySeq properties; }; exception InvalidObjectRef { Object ref; }; exception UnknownPropertyName { PropertyName name; }; exception InterfaceTypeMismatch { ServiceTypeName type; Object reference; }; exception ProxyOfferId { OfferId id; }; exception MandatoryProperty { ServiceTypeName type; PropertyName name; }; exception ReadonlyProperty { ServiceTypeName type; PropertyName name; }; exception NoMatchingOffers { Constraint constr; }; exception IllegalTraderName { TraderName name; }; exception UnknownTraderName { TraderName name; }; exception RegisterNotSupported { TraderName name; }; OfferId export ( in Object reference, in ServiceTypeName type, in PropertySeq properties ) raises ( InvalidObjectRef, IllegalServiceType, UnknownServiceType, InterfaceTypeMismatch, IllegalPropertyName, // e.g. prop_name = " OctetSeq; readonly attribute OctetSeq request_id_stem; unsigned long set_def_search_card (in unsigned long value); unsigned long set_max_search_card (in unsigned long value); unsigned long set_def_match_card (in unsigned long value); unsigned long set_max_match_card (in unsigned long value); unsigned long set_def_return_card (in unsigned long value); unsigned long set_max_return_card (in unsigned long value); unsigned long set_max_list (in unsigned long value); boolean set_supports_modifiable_properties (in boolean value); boolean set_supports_dynamic_properties (in boolean value); boolean set_supports_proxy_offers (in boolean value); unsigned long set_def_hop_count (in unsigned long value); unsigned long set_max_hop_count (in unsigned long value); FollowOption set_def_follow_policy (in FollowOption policy); FollowOption set_max_follow_policy (in FollowOption policy); FollowOption set_max_link_follow_policy (in FollowOption policy); TypeRepository set_type_repos (in TypeRepository repository); OctetSeq set_request_id_stem (in OctetSeq stem); void list_offers ( in unsigned long how_many, out OfferIdSeq ids, out OfferIdIterator id_itr ) raises ( NotImplemented ); void list_proxies ( in unsigned long how_many, out OfferIdSeq ids, out OfferIdIterator id_itr ) raises ( NotImplemented ); }; interface OfferIterator { unsigned long max_left ( ) raises ( UnknownMaxLeft ); boolean next_n ( in unsigned long n, out OfferSeq offers ); void destroy (); }; interface OfferIdIterator { unsigned long max_left ( ) raises ( UnknownMaxLeft ); boolean next_n ( in unsigned long n, out OfferIdSeq ids ); void destroy (); }; }; /* end module CosTrading */ #endif /* ifndef _COS_TRADING_IDL_ */ polyorb-2.8~20110207.orig/idls/cos/trader/CosTradingDynamic.idl0000644000175000017500000000165611750740337023454 0ustar xavierxavier//File: CosTradingDynamic.idl //Part of the Trading Object Service //OMG File: 98-10-49 #ifndef _COS_TRADING_DYNAMIC_IDL_ #define _COS_TRADING_DYNAMIC_IDL_ #ifdef _PRE_3_0_COMPILER_ #include #include #pragma prefix "omg.org" #else import ::CORBA; import ::CosTrading; #endif // _PRE_3_0_COMPILER_ module CosTradingDynamic { #ifndef _PRE_3_0_COMPILER_ typeprefix CosTradingDynamic "omg.org"; #endif // _PRE_3_0_COMPILER_ exception DPEvalFailure { CosTrading::PropertyName name; CORBA::TypeCode returned_type; any extra_info; }; interface DynamicPropEval { any evalDP ( in CosTrading::PropertyName name, in CORBA::TypeCode returned_type, in any extra_info ) raises ( DPEvalFailure ); }; struct DynamicProp { DynamicPropEval eval_if; CORBA::TypeCode returned_type; any extra_info; }; }; /* end module CosTradingDynamic */ #endif /* ifndef _COS_TRADING_DYNAMIC_IDL_ */ polyorb-2.8~20110207.orig/idls/cos/event/0000755000175000017500000000000011750740340017242 5ustar xavierxavierpolyorb-2.8~20110207.orig/idls/cos/event/CosTypedEventChannelAdmin.idl0000644000175000017500000000346511750740337024750 0ustar xavierxavier//File: CosTypedEventChannelAdmin.idl //Part of the Event Service #ifndef _COS_TYPED_EVENT_CHANNEL_ADMIN_IDL_ #define _COS_TYPED_EVENT_CHANNEL_ADMIN_IDL_ #ifdef _PRE_3_0_COMPILER_ #include #include #pragma prefix "omg.org" #else import ::CosEventChannelAdmin; import ::CosTypedEventComm; #endif // _PRE_3_0_COMPILER_ module CosTypedEventChannelAdmin { #ifndef _PRE_3_0_COMPILER_ typeprefix CosTypedEventChannelAdmin "omg.org"; #endif // _PRE_3_0_COMPILER_ exception InterfaceNotSupported {}; exception NoSuchImplementation {}; typedef string Key; interface TypedProxyPushConsumer : CosEventChannelAdmin::ProxyPushConsumer, CosTypedEventComm::TypedPushConsumer { }; interface TypedProxyPullSupplier : CosEventChannelAdmin::ProxyPullSupplier, CosTypedEventComm::TypedPullSupplier { }; interface TypedSupplierAdmin : CosEventChannelAdmin::SupplierAdmin { TypedProxyPushConsumer obtain_typed_push_consumer( in Key supported_interface) raises(InterfaceNotSupported); CosEventChannelAdmin::ProxyPullConsumer obtain_typed_pull_consumer ( in Key uses_interface) raises(NoSuchImplementation); }; interface TypedConsumerAdmin : CosEventChannelAdmin::ConsumerAdmin { TypedProxyPullSupplier obtain_typed_pull_supplier( in Key supported_interface) raises (InterfaceNotSupported); CosEventChannelAdmin::ProxyPushSupplier obtain_typed_push_supplier( in Key uses_interface) raises(NoSuchImplementation); }; interface TypedEventChannel { TypedConsumerAdmin for_consumers(); TypedSupplierAdmin for_suppliers(); void destroy (); }; }; #endif /* ifndef _COS_TYPED_EVENT_CHANNEL_ADMIN_IDL_ */ polyorb-2.8~20110207.orig/idls/cos/event/CosTypedEventComm.idl0000644000175000017500000000124111750740337023310 0ustar xavierxavier//File: CosTypedEventComm.idl //Part of the Event Service #ifndef _COS_TYPED_EVENT_COMM_IDL_ #define _COS_TYPED_EVENT_COMM_IDL_ #ifdef _PRE_3_0_COMPILER_ #include #pragma prefix "omg.org" #else import ::CosEventComm; #endif // _PRE_3_0_COMPILER_ module CosTypedEventComm { #ifndef _PRE_3_0_COMPILER_ typeprefix CosTypedEventComm "omg.org"; #endif // _PRE_3_0_COMPILER_ interface TypedPushConsumer : CosEventComm::PushConsumer { Object get_typed_consumer(); }; interface TypedPullSupplier : CosEventComm::PullSupplier { Object get_typed_supplier(); }; }; #endif /* ifndef _COS_TYPED_EVENT_COMM_IDL_ */ polyorb-2.8~20110207.orig/idls/cos/event/CosEventChannelAdmin.idl0000644000175000017500000000320511750740337023732 0ustar xavierxavier//File: CosEventChannelAdmin.idl //Part of the Event Service //OMG File: 04-10-06 #ifndef _COS_EVENT_CHANNEL_ADMIN_IDL_ #define _COS_EVENT_CHANNEL_ADMIN_IDL_ #ifdef _PRE_3_0_COMPILER_ #include #pragma prefix "omg.org" #else import ::CosEventComm; #endif // _PRE_3_0_COMPILER_ module CosEventChannelAdmin { #ifndef _PRE_3_0_COMPILER_ typeprefix CosEventChannelAdmin "omg.org"; #endif // _PRE_3_0_COMPILER_ exception AlreadyConnected {}; exception TypeError {}; interface ProxyPushConsumer: CosEventComm::PushConsumer { void connect_push_supplier( in CosEventComm::PushSupplier push_supplier) raises(AlreadyConnected); }; interface ProxyPullSupplier: CosEventComm::PullSupplier { void connect_pull_consumer( in CosEventComm::PullConsumer pull_consumer) raises(AlreadyConnected); }; interface ProxyPullConsumer: CosEventComm::PullConsumer { void connect_pull_supplier( in CosEventComm::PullSupplier pull_supplier) raises(AlreadyConnected,TypeError); }; interface ProxyPushSupplier: CosEventComm::PushSupplier { void connect_push_consumer( in CosEventComm::PushConsumer push_consumer) raises(AlreadyConnected, TypeError); }; interface ConsumerAdmin { ProxyPushSupplier obtain_push_supplier(); ProxyPullSupplier obtain_pull_supplier(); }; interface SupplierAdmin { ProxyPushConsumer obtain_push_consumer(); ProxyPullConsumer obtain_pull_consumer(); }; interface EventChannel { ConsumerAdmin for_consumers(); SupplierAdmin for_suppliers(); void destroy(); }; }; #endif /* ifndef _COS_EVENT_CHANNEL_ADMIN_IDL_ */ polyorb-2.8~20110207.orig/idls/cos/event/CosEventComm.idl0000644000175000017500000000153311750740337022306 0ustar xavierxavier//File: CosEventComm.idl //Part of the Event Service //OMG File: 04-10-06 #ifndef _COS_EVENT_COMM_IDL_ #define _COS_EVENT_COMM_IDL_ #ifdef _PRE_3_0_COMPILER_ #pragma prefix "omg.org" #endif // _PRE_3_0_COMPILER_ module CosEventComm { #ifndef _PRE_3_0_COMPILER_ typeprefix CosEventComm "omg.org"; #endif // _PRE_3_0_COMPILER_ exception Disconnected{}; interface PushConsumer { void push (in any data) raises(Disconnected); void disconnect_push_consumer(); }; interface PushSupplier { void disconnect_push_supplier(); }; interface PullSupplier { any pull () raises(Disconnected); any try_pull (out boolean has_event) raises(Disconnected); void disconnect_pull_supplier(); }; interface PullConsumer { void disconnect_pull_consumer(); }; }; #endif /* ifndef _COS_EVENT_COMM_IDL_ */ polyorb-2.8~20110207.orig/idls/cos/lifecycle/0000755000175000017500000000000011750740340020060 5ustar xavierxavierpolyorb-2.8~20110207.orig/idls/cos/lifecycle/CosLifeCycle.idl0000644000175000017500000000407111750740337023066 0ustar xavierxavier//File: CosLifeCycle.idl //Part of the LifeCycle Service // Note: if your IDL compiler does not yet support the // CORBA 2.3 Feature "Escaped Identifiers" (which provides // for the addition of new keywords to IDL, compile this // module with the preprocessor definition // "NO_ESCAPED_IDENTIFIERS". With many compilers this // would be done a qualifier on the command line, // something like -DNO_ESCAPED_IDENTIFIERS //OMG File: 98-10-15 #ifndef _COS_LIFE_CYCLE_IDL_ #define _COS_LIFE_CYCLE_IDL_ #ifdef _PRE_3_0_COMPILER_ #include #pragma prefix "omg.org" #else import ::CosNaming; #endif // _PRE_3_0_COMPILER_ module CosLifeCycle{ #ifndef _PRE_3_0_COMPILER_ typeprefix CosLifeCycle "omg.org"; #endif // _PRE_3_0_COMPILER_ typedef CosNaming::Name Key; typedef Object _Factory; typedef sequence <_Factory> Factories; typedef struct NVP { CosNaming::Istring name; any value; } NameValuePair; typedef sequence Criteria; exception NoFactory { Key search_key; }; exception NotCopyable { string reason; }; exception NotMovable { string reason; }; exception NotRemovable { string reason; }; exception InvalidCriteria{ Criteria invalid_criteria; }; exception CannotMeetCriteria { Criteria unmet_criteria; }; interface FactoryFinder { Factories find_factories(in Key factory_key) raises(NoFactory); }; interface LifeCycleObject { LifeCycleObject copy(in FactoryFinder there, in Criteria the_criteria) raises(NoFactory, NotCopyable, InvalidCriteria, CannotMeetCriteria); void move(in FactoryFinder there, in Criteria the_criteria) raises(NoFactory, NotMovable, InvalidCriteria, CannotMeetCriteria); void remove() raises(NotRemovable); }; interface GenericFactory { #ifdef NO_ESCAPED_IDENTIFIERS boolean supports(in Key k); #else boolean _supports(in Key k); #endif Object create_object( in Key k, in Criteria the_criteria) raises (NoFactory, InvalidCriteria, CannotMeetCriteria); }; }; #endif /* ifndef _COS_LIFE_CYCLE_IDL_ */ polyorb-2.8~20110207.orig/idls/cos/lifecycle/LifeCycleService.idl0000644000175000017500000000343311750740337023743 0ustar xavierxavier//File: LifeCycleService.idl // An Example LifeCycleService Module // Note: This is only an example of the LifeCycle service, // and is NOT part of the LifeCycle service //OMG File: 98-10-18 #ifndef _LIFE_CYCLE_SERVICE_IDL_ #define _LIFE_CYCLE_SERVICE_IDL_ #ifdef _PRE_3_0_COMPILER_ #include #pragma prefix "omg.org" #else import ::CosLifeCycle; #endif // _PRE_3_0_COMPILER_ module LifeCycleService { #ifndef _PRE_3_0_COMPILER_ typeprefix LifeCycleService "omg.org"; #endif // _PRE_3_0_COMPILER_ typedef sequence PolicyList; typedef sequence Keys; typedef sequence PropertyList; typedef sequence NameComponents; interface LifeCycleServiceAdmin { attribute PolicyList policies; void bind_generic_factory( in CosLifeCycle::GenericFactory gf, in CosNaming::NameComponent name, in Keys key_set, in PropertyList other_properties) raises (CosNaming::NamingContext::AlreadyBound, CosNaming::NamingContext::InvalidName); void unbind_generic_factory( in CosNaming::NameComponent name) raises (CosNaming::NamingContext::NotFound, CosNaming::NamingContext::InvalidName); CosLifeCycle::GenericFactory resolve_generic_factory( in CosNaming::NameComponent name) raises (CosNaming::NamingContext::NotFound, CosNaming::NamingContext::InvalidName); NameComponents list_generic_factories(); boolean match_service (in CosLifeCycle::GenericFactory f); string get_hint(); void get_link_properties( in CosNaming::NameComponent name, out Keys key_set, out PropertyList other_properties) raises (CosNaming::NamingContext::NotFound, CosNaming::NamingContext::InvalidName); }; }; #endif /* ifndef _LIFE_CYCLE_SERVICE_IDL_ */ polyorb-2.8~20110207.orig/idls/cos/lifecycle/CosLifeCycleReference.idl0000644000175000017500000000153311750740337024705 0ustar xavierxavier//File: CosLifeCycleReference.idl //Part of the LifeCycle Service //OMG File: 98-10-17 #ifndef _COS_LIFE_CYCLE_REFERENCE_IDL_ #define _COS_LIFE_CYCLE_REFERENCE_IDL_ #ifdef _PRE_3_0_COMPILER_ #include #include #pragma prefix "omg.org" #else import ::CosReference; import ::CosCompoundLifeCycle; #endif // _PRE_3_0_COMPILER_ module CosLifeCycleReference { #ifndef _PRE_3_0_COMPILER_ typeprefix CosLifeCycleReference "omg.org"; #endif // _PRE_3_0_COMPILER_ interface Relationship : CosCompoundLifeCycle::Relationship, CosReference::Relationship {}; interface ReferencesRole : CosCompoundLifeCycle::Role, CosReference::ReferencesRole {}; interface ReferencedByRole : CosCompoundLifeCycle::Role, CosReference::ReferencedByRole {}; }; #endif /* ifndef _COS_LIFE_CYCLE_REFERENCE_IDL_ */ polyorb-2.8~20110207.orig/idls/cos/lifecycle/CosLifeCycleContainment.idl0000644000175000017500000000155311750740337025270 0ustar xavierxavier//File: CosLifeCycleContainment.idl //Part of the Lifecycle Service //OMG File: 98-10-16 #ifndef _COS_LIFE_CYCLE_CONTAINMENT_IDL_ #define _COS_LIFE_CYCLE_CONTAINMENT_IDL_ #ifdef _PRE_3_0_COMPILER_ #include #include #pragma prefix "omg.org" #else import ::CosContainment; import ::CosCompoundLifeCycle; #endif // _PRE_3_0_COMPILER_ module CosLifeCycleContainment { #ifndef _PRE_3_0_COMPILER_ typeprefix CosLifeCycleContainment "omg.org"; #endif // _PRE_3_0_COMPILER_ interface Relationship : CosCompoundLifeCycle::Relationship, CosContainment::Relationship {}; interface ContainsRole : CosCompoundLifeCycle::Role, CosContainment::ContainsRole {}; interface ContainedInRole : CosCompoundLifeCycle::Role, CosContainment::ContainedInRole {}; }; #endif /* ifndef _COS_LIFE_CYCLE_CONTAINMENT_IDL_ */ polyorb-2.8~20110207.orig/idls/cos/lifecycle/CosCompoundLifeCycle.idl0000644000175000017500000000776611750740337024611 0ustar xavierxavier//File: CosCompoundLifeCycle.idl //Part of the LifeCycle Service //OMG File: 98-10-14 #ifndef _COS_COMPOUND_LIFE_CYCLE_IDL_ #define _COS_COMPOUND_LIFE_CYCLE_IDL_ #ifdef _PRE_3_0_COMPILER_ #include #include #include #pragma prefix "omg.org" #else import ::CosLifeCycle; import ::CosRelationships; import ::CosGraphs; #endif // _PRE_3_0_COMPILER_ module CosCompoundLifeCycle { #ifndef _PRE_3_0_COMPILER_ typeprefix CosCompoundLifeCycle "omg.org"; #endif // _PRE_3_0_COMPILER_ interface OperationsFactory; interface Operations; interface Node; interface Role; interface Relationship; interface PropagationCriteriaFactory; enum Operation {copy, move, remove}; struct RelationshipHandle { CosRelationships::Relationship the_relationship; CosObjectIdentity::ObjectIdentifier constant_random_id; }; interface OperationsFactory { Operations create_compound_operations(); }; interface Operations { Node copy ( in Node starting_node, in CosLifeCycle::FactoryFinder there, in CosLifeCycle::Criteria the_criteria) raises (CosLifeCycle::NoFactory, CosLifeCycle::NotCopyable, CosLifeCycle::InvalidCriteria, CosLifeCycle::CannotMeetCriteria); void move ( in Node starting_node, in CosLifeCycle::FactoryFinder there, in CosLifeCycle::Criteria the_criteria) raises (CosLifeCycle::NoFactory, CosLifeCycle::NotMovable, CosLifeCycle::InvalidCriteria, CosLifeCycle::CannotMeetCriteria); void remove (in Node starting_node) raises (CosLifeCycle::NotRemovable); void destroy(); }; interface Node : CosGraphs::Node { exception NotLifeCycleObject {}; void copy_node ( in CosLifeCycle::FactoryFinder there, in CosLifeCycle::Criteria the_criteria, out Node new_node, out Roles roles_of_new_node) raises (CosLifeCycle::NoFactory, CosLifeCycle::NotCopyable, CosLifeCycle::InvalidCriteria, CosLifeCycle::CannotMeetCriteria); void move_node ( in CosLifeCycle::FactoryFinder there, in CosLifeCycle::Criteria the_criteria) raises (CosLifeCycle::NoFactory, CosLifeCycle::NotMovable, CosLifeCycle::InvalidCriteria, CosLifeCycle::CannotMeetCriteria); void remove_node () raises (CosLifeCycle::NotRemovable); CosLifeCycle::LifeCycleObject get_life_cycle_object() raises (NotLifeCycleObject); }; interface Role : CosGraphs::Role { Role copy_role ( in CosLifeCycle::FactoryFinder there, in CosLifeCycle::Criteria the_criteria) raises (CosLifeCycle::NoFactory, CosLifeCycle::NotCopyable, CosLifeCycle::InvalidCriteria, CosLifeCycle::CannotMeetCriteria); void move_role ( in CosLifeCycle::FactoryFinder there, in CosLifeCycle::Criteria the_criteria) raises (CosLifeCycle::NoFactory, CosLifeCycle::NotMovable, CosLifeCycle::InvalidCriteria, CosLifeCycle::CannotMeetCriteria); CosGraphs::PropagationValue life_cycle_propagation ( in Operation op, in RelationshipHandle rel, in CosRelationships::RoleName to_role_name, out boolean same_for_all); }; interface Relationship : CosRelationships::Relationship { Relationship copy_relationship ( in CosLifeCycle::FactoryFinder there, in CosLifeCycle::Criteria the_criteria, in CosGraphs::NamedRoles new_roles) raises (CosLifeCycle::NoFactory, CosLifeCycle::NotCopyable, CosLifeCycle::InvalidCriteria, CosLifeCycle::CannotMeetCriteria); void move_relationship ( in CosLifeCycle::FactoryFinder there, in CosLifeCycle::Criteria the_criteria) raises (CosLifeCycle::NoFactory, CosLifeCycle::NotMovable, CosLifeCycle::InvalidCriteria, CosLifeCycle::CannotMeetCriteria); CosGraphs::PropagationValue life_cycle_propagation ( in Operation op, in CosRelationships::RoleName from_role_name, in CosRelationships::RoleName to_role_name, out boolean same_for_all); }; interface PropagationCriteriaFactory { CosGraphs::TraversalCriteria create(in Operation op); }; }; #endif /* ifndef _COS_COMPOUND_LIFE_CYCLE_IDL_ */ polyorb-2.8~20110207.orig/idls/cos/licensing/0000755000175000017500000000000011750740340020074 5ustar xavierxavierpolyorb-2.8~20110207.orig/idls/cos/licensing/CosLicensingManager.idl0000644000175000017500000000556011750740337024455 0ustar xavierxavier//File: CosLicensingManager.idl //The only module of the Licensing Service //OMG File: 98-10-13 #ifndef _COS_LICENSING_MANAGER_IDL_ #define _COS_LICENSING_MANAGER_IDL_ #ifdef _PRE_3_0_COMPILER_ #include #include #include #pragma prefix "omg.org" #else import ::CosEventComm; import ::CosPropertyService; import ::CosEventComm; #endif // _PRE_3_0_COMPILER_ module CosLicensingManager { #ifndef _PRE_3_0_COMPILER_ typeprefix CosLicensingManager "omg.org"; #endif // _PRE_3_0_COMPILER_ exception InvalidProducer{}; exception InvalidParameter{}; exception ComponentNotRegistered{}; typedef Object ProducerSpecificNotification; enum ActionRequired { continue, terminate}; enum Answer { yes, no }; struct Action { //PolyORB:WACORBA: We rename action to the_action for avoid name conflict //PolyORB:WACORBA: ActionRequired action ; ActionRequired the_action ; Answer notification_required ; Answer wait_for_user_confirmation_after_notification ; unsigned long notification_duration; ProducerSpecificNotification producer_notification; string notification_text; }; struct ChallengeData { unsigned long challenge_index; unsigned long random_number; string digest; }; enum ChallengeProtocol { default_protocol, producer_defined }; struct Challenge { ChallengeProtocol challenge_protocol; unsigned long challenge_data_size; any challenge_data; }; typedef any LicenseHandle; interface ProducerSpecificLicenseService { readonly attribute string producer_contact_info; readonly attribute string producer_specific_license_service_info; //PolyORB:NI: CORBA::Principal is not defined //PolyORB:NI: LicenseHandle start_use ( //PolyORB:NI: in CORBA::Principal aPrincipal, //PolyORB:NI: in string component_name, //PolyORB:NI: in string component_version, //PolyORB:NI: in CosPropertyService::PropertySet license_use_context, //PolyORB:NI: in CosEventComm::PushConsumer call_back, //PolyORB:NI: inout CosLicensingManager::Challenge Challenge) //PolyORB:NI: //PolyORB:NI: raises ( InvalidParameter, ComponentNotRegistered); void check_use ( in LicenseHandle handle, in CosPropertyService::PropertySet license_use_context, out unsigned long recommended_check_interval, out Action action_to_be_taken, inout CosLicensingManager::Challenge Challenge) raises ( InvalidParameter ); void end_use ( in LicenseHandle handle, in CosPropertyService::PropertySet license_use_context, inout CosLicensingManager::Challenge Challenge) raises ( InvalidParameter ); }; interface LicenseServiceManager { ProducerSpecificLicenseService obtain_producer_specific_license_service ( in string producer_name, inout CosLicensingManager::Challenge Challenge) raises ( InvalidProducer, InvalidParameter ) ; }; }; #endif /* ifndef _COS_LICENSING_MANAGER_IDL_ */ polyorb-2.8~20110207.orig/idls/cos/security/0000755000175000017500000000000011750740340017770 5ustar xavierxavierpolyorb-2.8~20110207.orig/idls/cos/security/NRService.idl0000644000175000017500000001217111750740337022332 0ustar xavierxavier//File: NRService.idl //Part of the Security Service //OMG File: 02-03-12 #if !defined(_NR_SERVICE_IDL_) #define _NR_SERVICE_IDL_ #ifdef _PRE_3_0_COMPILER_ #include #pragma prefix "omg.org" #else import ::SecurityLevel2; #endif // _PRE_3_0_COMPILER_ module NRService { #ifndef _PRE_3_0_COMPILER_ typeprefix NRService "omg.org"; #endif // _PRE_3_0_COMPILER_ # pragma version NRService 1.5 typedef Security::MechanismType NRMech; typedef Security::ExtensibleFamily NRPolicyId; enum EvidenceType { SecProofofCreation, SecProofofReceipt, SecProofofApproval, SecProofofRetrieval, SecProofofOrigin, SecProofofDelivery, SecNoEvidence // used when request-only token desired }; enum NRVerificationResult { SecNRInvalid, SecNRValid, SecNRConditionallyValid }; // the following are used for evidence validity duration typedef unsigned long DurationInMinutes; const DurationInMinutes DurationHour = 60; const DurationInMinutes DurationDay = 1440; const DurationInMinutes DurationWeek = 10080; const DurationInMinutes DurationMonth = 43200;// 30 days; const DurationInMinutes DurationYear = 525600;//365 days; typedef long TimeOffsetInMinutes; struct NRPolicyFeatures { NRPolicyId policy_id; unsigned long policy_version; NRMech mechanism; }; typedef sequence NRPolicyFeaturesList; // features used when generating requests struct RequestFeatures { NRPolicyFeatures requested_policy; EvidenceType requested_evidence; string requested_evidence_generators; string requested_evidence_recipients; boolean include_this_token_in_evidence; }; struct EvidenceDescriptor { EvidenceType evidence_type; DurationInMinutes evidence_validity_duration; boolean must_use_trusted_time; }; typedef sequence EvidenceDescriptorList; struct AuthorityDescriptor { string authority_name; string authority_role; TimeOffsetInMinutes last_revocation_check_offset; // may be >0 or <0; add this to evid. gen. time to // get latest time at which mech. will check to see // if this authority's key has been revoked. }; typedef sequence AuthorityDescriptorList; struct MechanismDescriptor { NRMech mech_type; AuthorityDescriptorList authority_list; TimeOffsetInMinutes max_time_skew; // max permissible difference between evid. gen. time // and time of time service countersignature // ignored if trusted time not reqd. }; typedef sequence MechanismDescriptorList; //PolyORB:WACORBA: interface derived from local interface should be local // interface NRCredentials : SecurityLevel2::Credentials{ local interface NRCredentials : SecurityLevel2::Credentials{ boolean set_NR_features ( in NRPolicyFeaturesList requested_features, out NRPolicyFeaturesList actual_features ); NRPolicyFeaturesList get_NR_features (); void generate_token ( in Security::Opaque input_buffer, in EvidenceType generate_evidence_type, in boolean include_data_in_token, in boolean generate_request, in RequestFeatures request_features, in boolean input_buffer_complete, out Security::Opaque nr_token, out Security::Opaque evidence_check ); NRVerificationResult verify_evidence ( in Security::Opaque input_token_buffer, in Security::Opaque evidence_check, in boolean form_complete_evidence, in boolean token_buffer_complete, out Security::Opaque output_token, out Security::Opaque data_included_in_token, out boolean evidence_is_complete, out boolean trusted_time_used, out Security::TimeT complete_evidence_before, out Security::TimeT complete_evidence_after ); void get_token_details ( in Security::Opaque token_buffer, in boolean token_buffer_complete, out string token_generator_name, out NRPolicyFeatures policy_features, out EvidenceType evidence_type, out Security::UtcT evidence_generation_time, out Security::UtcT evidence_valid_start_time, out DurationInMinutes evidence_validity_duration, out boolean data_included_in_token, out boolean request_included_in_token, out RequestFeatures request_features ); boolean form_complete_evidence ( in Security::Opaque input_token, out Security::Opaque output_token, out boolean trusted_time_used, out Security::TimeT complete_evidence_before, out Security::TimeT complete_evidence_after ); }; interface NRPolicy : CORBA::Policy{ void get_NR_policy_info ( out Security::ExtensibleFamily NR_policy_id, out unsigned long policy_version, out Security::TimeT policy_effective_time, out Security::TimeT policy_expiry_time, out EvidenceDescriptorList supported_evidence_types, out MechanismDescriptorList supported_mechanisms ); boolean set_NR_policy_info ( in MechanismDescriptorList requested_mechanisms, out MechanismDescriptorList actual_mechanisms ); }; }; #endif /* _NR_SERVICE_IDL_ */ polyorb-2.8~20110207.orig/idls/cos/security/SecurityAdmin.idl0000644000175000017500000000705111750740337023253 0ustar xavierxavier//File: SecurityAdmin.idl //Part of the Security Service //OMG File: 02-03-12 #if !defined(_SECURITY_ADMIN_IDL_) #define _SECURITY_ADMIN_IDL_ #ifdef _PRE_3_0_COMPILER_ #include #pragma prefix "omg.org" #else import ::SecurityLevel2; #endif // _PRE_3_0_COMPILER_ module SecurityAdmin { #ifndef _PRE_3_0_COMPILER_ typeprefix SecurityAdmin "omg.org"; #endif // _PRE_3_0_COMPILER_ # pragma version SecurityAdmin 1.5 // interface AccessPolicy interface AccessPolicy : CORBA::Policy { # pragma version AccessPolicy 1.5 Security::RightsList get_effective_rights ( in Security::AttributeList attrib_list, in Security::ExtensibleFamily rights_family ); Security::RightsList get_all_effective_rights( in Security::AttributeList attrib_list ); }; // interface DomainAccessPolicy interface DomainAccessPolicy : AccessPolicy { # pragma version DomainAccessPolicy 1.5 void grant_rights( in Security::SecAttribute priv_attr, in Security::DelegationState del_state, in Security::RightsList rights ); void revoke_rights( in Security::SecAttribute priv_attr, in Security::DelegationState del_state, in Security::RightsList rights ); void replace_rights ( in Security::SecAttribute priv_attr, in Security::DelegationState del_state, in Security::RightsList rights ); Security::RightsList get_rights ( in Security::SecAttribute priv_attr, in Security::DelegationState del_state, in Security::ExtensibleFamily rights_family ); Security::RightsList get_all_rights( in Security::SecAttribute priv_attr, in Security::DelegationState del_state ); }; // interface AuditPolicy interface AuditPolicy : CORBA::Policy { # pragma version AuditPolicy 1.5 void set_audit_selectors ( in CORBA::RepositoryId object_type, in Security::AuditEventTypeList events, in Security::SelectorValueList selectors, in Security::AuditCombinator audit_combinator ); void clear_audit_selectors ( in CORBA::RepositoryId object_type, in Security::AuditEventTypeList events ); void replace_audit_selectors ( in CORBA::RepositoryId object_type, in Security::AuditEventTypeList events, in Security::SelectorValueList selectors, in Security::AuditCombinator audit_combinator ); void get_audit_selectors ( in CORBA::RepositoryId object_type, in Security::AuditEventType event_type, out Security::SelectorValueList selectors, out Security::AuditCombinator audit_combinator ); void set_audit_channel ( in Security::AuditChannelId audit_channel_id ); }; // interface SecureInvocationPolicy interface SecureInvocationPolicy : CORBA::Policy { # pragma version SecureInvocationPolicy 1.5 void set_association_options( in CORBA::RepositoryId object_type, in Security::RequiresSupports requires_supports, in Security::CommunicationDirection direction, in Security::AssociationOptions options ); Security::AssociationOptions get_association_options( in CORBA::RepositoryId object_type, in Security::RequiresSupports requires_supports, in Security::CommunicationDirection direction ); }; // interface DelegationPolicy interface DelegationPolicy : CORBA::Policy { # pragma version DelegationPolicy 1.5 void set_delegation_mode( in CORBA::RepositoryId object_type, in Security::DelegationMode mode ); Security::DelegationMode get_delegation_mode( in CORBA::RepositoryId object_type ); }; }; #endif /* _SECURITY_ADMIN_IDL_ */ polyorb-2.8~20110207.orig/idls/cos/security/SECIOP.idl0000644000175000017500000001224211750740337021453 0ustar xavierxavier//File: SECIOP.idl //Part of the Security Service //OMG File: 02-03-12 #if !defined(_SECIOP_IDL_) #define _SECIOP_IDL #ifdef _PRE_3_0_COMPILER_ #include #include #pragma prefix "omg.org" #else import ::IOP; import ::Security; #endif // _PRE_3_0_COMPILER_ module SECIOP { #ifndef _PRE_3_0_COMPILER_ typeprefix SECIOP "omg.org"; #endif // _PRE_3_0_COMPILER_ #pragma version SECIOP 1.1 const IOP::ComponentId TAG_GENERIC_SEC_MECH = 22; const IOP::ComponentId TAG_ASSOCIATION_OPTIONS = 13; const IOP::ComponentId TAG_SEC_NAME = 14; const IOP::ComponentId TAG_SECIOP_INET_SEC_TRANS = 123; struct SECIOP_INET_SEC_TRANS { unsigned short port; }; struct TargetAssociationOptions{ Security::AssociationOptions target_supports; Security::AssociationOptions target_requires; }; struct GenericMechanismInfo { sequence security_mechanism_type; sequence mech_specific_data; sequence components; }; enum MsgType { MTEstablishContext, MTCompleteEstablishContext, MTContinueEstablishContext, MTDiscardContext, MTMessageError, MTMessageInContext }; typedef unsigned long long ContextId; enum ContextIdDefn { CIDClient, CIDPeer, CIDSender }; struct EstablishContext { ContextId client_context_id; sequence initial_context_token; }; struct CompleteEstablishContext { ContextId client_context_id; boolean target_context_id_valid; ContextId target_context_id; sequence final_context_token; }; struct ContinueEstablishContext { ContextId client_context_id; sequence continuation_context_token; }; struct DiscardContext { ContextIdDefn message_context_id_defn; ContextId message_context_id; sequence discard_context_token; }; struct MessageError { ContextIdDefn message_context_id_defn; ContextId message_context_id; long major_status; long minor_status; }; enum ContextTokenType { SecTokenTypeWrap, SecTokenTypeMIC }; struct MessageInContext { ContextIdDefn message_context_id_defn; ContextId message_context_id; ContextTokenType message_context_type; sequence message_protection_token; }; typedef sequence SecurityName; typedef unsigned short CryptographicProfile; typedef sequence CryptographicProfileList; // Cryptographic profiles for SPKM const CryptographicProfile MD5_RSA = 20; const CryptographicProfile MD5_DES_CBC = 21; const CryptographicProfile DES_CBC = 22; const CryptographicProfile MD5_DES_CBC_SOURCE = 23; const CryptographicProfile DES_CBC_SOURCE = 24; // Security Mechanism SPKM_1 const IOP::ComponentId TAG_SPKM_1_SEC_MECH = 15; struct SPKM_1 { Security::AssociationOptions target_supports; Security::AssociationOptions target_requires; CryptographicProfileList crypto_profile; SecurityName security_name; }; // Security Mechanism SPKM_1 const IOP::ComponentId TAG_SPKM_2_SEC_MECH = 16; struct SPKM_2 { Security::AssociationOptions target_supports; Security::AssociationOptions target_requires; CryptographicProfileList crypto_profile; SecurityName security_name; }; // Cryptographic profiles for GSS Kerberos Protocol const CryptographicProfile DES_CBC_DES_MAC = 10; const CryptographicProfile DES_CBC_MD5 = 11; const CryptographicProfile DES_MAC = 12; const CryptographicProfile MD5 = 13; // Security Mechanism KerberosV5 const IOP::ComponentId TAG_KerberosV5_SEC_MECH = 17; struct KerberosV5 { Security::AssociationOptions target_supports; Security::AssociationOptions target_requires; CryptographicProfileList crypto_profile; SecurityName security_name; }; // Cryptographic profiles for CSI-ECMA Protocol const CryptographicProfile FullSecurity = 1; const CryptographicProfile NoDataConfidentiality = 2; const CryptographicProfile LowGradeConfidentiality = 3; const CryptographicProfile AgreedDefault = 5; // Security Mechanism CSI_ECMA_Secret const IOP::ComponentId TAG_CSI_ECMA_Secret_SEC_MECH = 18; struct CSI_ECMA_Secret { Security::AssociationOptions target_supports; Security::AssociationOptions target_requires; CryptographicProfileList crypto_profile; SecurityName security_name; }; // Security Mechanism CSI_ECMA_Hybrid const IOP::ComponentId TAG_CSI_ECMA_Hybrid_SEC_MECH = 19; struct CSI_ECMA_Hybrid { Security::AssociationOptions target_supports; Security::AssociationOptions target_requires; CryptographicProfileList crypto_profile; SecurityName security_name; }; // Security Mechanism CSI_ECMA_Public const IOP::ComponentId TAG_CSI_ECMA_Public_SEC_MECH = 21; struct CSI_ECMA_Public { Security::AssociationOptions target_supports; Security::AssociationOptions target_requires; CryptographicProfileList crypto_profile; SecurityName security_name; }; }; #endif /* _SECIOP_IDL */ polyorb-2.8~20110207.orig/idls/cos/security/Security.idl0000644000175000017500000002353211750740337022304 0ustar xavierxavier//File: Security.idl //Part of the Security Service //OMG File: 02-03-12 #if !defined(_SECURITY_IDL_) #define _SECURITY_IDL_ #ifdef _PRE_3_0_COMPILER_ #include #include #pragma prefix "omg.org" #else import ::CORBA; import ::TimeBase; #endif // _PRE_3_0_COMPILER_ module Security { #ifndef _PRE_3_0_COMPILER_ typeprefix Security "omg.org"; #endif // _PRE_3_0_COMPILER_ # pragma version Security 1.8 typedef string SecurityName; typedef sequence Opaque; // Constant declarations for Security Service Options const CORBA::ServiceOption SecurityLevel1 = 1; const CORBA::ServiceOption SecurityLevel2 = 2; const CORBA::ServiceOption NonRepudiation = 3; const CORBA::ServiceOption SecurityORBServiceReady = 4; const CORBA::ServiceOption SecurityServiceReady = 5; const CORBA::ServiceOption ReplaceORBServices = 6; const CORBA::ServiceOption ReplaceSecurityServices = 7; const CORBA::ServiceOption StandardSecureInteroperability = 8; const CORBA::ServiceOption DCESecureInteroperability = 9; // Service options for Common Secure Interoperability const CORBA::ServiceOption CommonInteroperabilityLevel0 = 10; const CORBA::ServiceOption CommonInteroperabilityLevel1 = 11; const CORBA::ServiceOption CommonInteroperabilityLevel2 = 12; // Security mech types supported for secure association const CORBA::ServiceDetailType SecurityMechanismType = 1; // privilege types supported in standard access policy const CORBA::ServiceDetailType SecurityAttribute = 2; // extensible families for standard data types struct ExtensibleFamily { unsigned short family_definer; unsigned short family; }; typedef sequence OID; typedef sequence OIDList; // security attributes typedef unsigned long SecurityAttributeType; // other attributes; family = 0 const SecurityAttributeType AuditId = 1; const SecurityAttributeType AccountingId = 2; const SecurityAttributeType NonRepudiationId = 3; // privilege attributes; family = 1 const SecurityAttributeType _Public = 1; const SecurityAttributeType AccessId = 2; const SecurityAttributeType PrimaryGroupId = 3; const SecurityAttributeType GroupId = 4; const SecurityAttributeType Role = 5; const SecurityAttributeType AttributeSet = 6; const SecurityAttributeType Clearance = 7; const SecurityAttributeType Capability = 8; struct AttributeType { ExtensibleFamily attribute_family; SecurityAttributeType attribute_type; }; typedef sequence AttributeTypeList; struct SecAttribute { AttributeType attribute_type; OID defining_authority; Opaque value; // the value of this attribute can be // decoded only with knowledge of defining_authority }; typedef sequence AttributeList; // Authentication return status enum AuthenticationStatus { SecAuthSuccess, SecAuthFailure, SecAuthContinue, SecAuthExpired }; // Association return status enum AssociationStatus { SecAssocSuccess, SecAssocFailure, SecAssocContinue }; // Authentication method typedef unsigned long AuthenticationMethod; typedef sequence AuthenticationMethodList; // Credential types enum InvocationCredentialsType { SecOwnCredentials, SecReceivedCredentials, SecTargetCredentials }; // Declarations related to Rights struct Right { ExtensibleFamily rights_family; string the_right; }; typedef sequence RightsList; enum RightsCombinator { SecAllRights , SecAnyRight }; // Delegation related enum DelegationState { SecInitiator, SecDelegate }; enum DelegationDirective { Delegate, NoDelegate }; // pick up from TimeBase typedef TimeBase::UtcT UtcT; typedef TimeBase::IntervalT IntervalT; typedef TimeBase::TimeT TimeT; // Security features available on credentials. enum SecurityFeature { SecNoDelegation, SecSimpleDelegation, SecCompositeDelegation, SecNoProtection, SecIntegrity, SecConfidentiality, SecIntegrityAndConfidentiality, SecDetectReplay, SecDetectMisordering, SecEstablishTrustInTarget, SecEstablishTrustInClient }; // Quality of protection which can be specified // for an object reference and used to protect messages enum QOP { SecQOPNoProtection, SecQOPIntegrity, SecQOPConfidentiality, SecQOPIntegrityAndConfidentiality }; // Type of SecurityContext enum SecurityContextType { SecClientSecurityContext, SecServerSecurityContext }; // Operational State of a Security Context enum SecurityContextState { SecContextInitialized, SecContextContinued, SecContextClientEstablished, SecContextEstablished, SecContextEstablishExpired, SecContextExpired, SecContextInvalid }; struct ChannelBindings { unsigned long initiator_addrtype; sequence initiator_address; unsigned long acceptor_addrtype; sequence acceptor_address; sequence application_data; }; // For use with SecurityReplaceable struct OpaqueBuffer { Opaque buffer; unsigned long startpos; unsigned long endpos; // startpos <= endpos // OpaqueBuffer is said to be empty if startpos == endpos }; // Association options which can be administered // on secure invocation policy and used to // initialize security context typedef unsigned short AssociationOptions; const AssociationOptions NoProtection = 1; const AssociationOptions Integrity = 2; const AssociationOptions Confidentiality = 4; const AssociationOptions DetectReplay = 8; const AssociationOptions DetectMisordering = 16; const AssociationOptions EstablishTrustInTarget = 32; const AssociationOptions EstablishTrustInClient = 64; const AssociationOptions NoDelegation = 128; const AssociationOptions SimpleDelegation = 256; const AssociationOptions CompositeDelegation = 512; // Flag to indicate whether association options being // administered are the "required" or "supported" set enum RequiresSupports { SecRequires, SecSupports }; // Direction of communication for which // secure invocation policy applies enum CommunicationDirection { SecDirectionBoth, SecDirectionRequest, SecDirectionReply }; // security association mechanism type typedef string MechanismType; typedef sequence MechanismTypeList; // AssociationOptions-Direction pair struct OptionsDirectionPair { AssociationOptions options; CommunicationDirection direction; }; typedef sequence OptionsDirectionPairList; // Delegation mode which can be administered enum DelegationMode { SecDelModeNoDelegation, // i.e. use own credentials SecDelModeSimpleDelegation, // delegate received credentials SecDelModeCompositeDelegation // delegate both; }; // Association options supported by a given mech type struct MechandOptions { MechanismType mechanism_type; AssociationOptions options_supported; }; typedef sequence MechandOptionsList; // Attribute of the SecurityLevel2::EstablishTrustPolicy struct EstablishTrust { boolean trust_in_client; boolean trust_in_target; }; // Audit typedef unsigned long AuditChannelId; typedef unsigned short _EventType; const _EventType AuditAll = 0; const _EventType AuditPrincipalAuth = 1; const _EventType AuditSessionAuth = 2; const _EventType AuditAuthorization = 3; const _EventType AuditInvocation = 4; const _EventType AuditSecEnvChange = 5; const _EventType AuditPolicyChange = 6; const _EventType AuditObjectCreation = 7; const _EventType AuditObjectDestruction =8; const _EventType AuditNonRepudiation = 9; enum DayOfTheWeek { Monday, Tuesday, Wednesday, Thursday, Friday, Saturday, Sunday}; enum AuditCombinator { SecAllSelectors, SecAnySelector }; struct AuditEventType { ExtensibleFamily event_family; _EventType event_type; }; typedef sequence AuditEventTypeList; typedef unsigned long SelectorType; const SelectorType InterfaceName = 1; const SelectorType ObjectRef = 2; const SelectorType Operation = 3; const SelectorType Initiator = 4; const SelectorType SuccessFailure = 5; const SelectorType Time = 6; const SelectorType DayOfWeek = 7; // values defined for audit_needed and audit_write are: // InterfaceName: CORBA::RepositoryId // ObjectRef: object reference // Operation: op_name // Initiator: Credentials // SuccessFailure: boolean // Time: utc time on audit_write; time picked up from // environment in audit_needed if required // DayOfWeek: DayOfTheWeek struct SelectorValue { SelectorType selector; any value; }; typedef sequence SelectorValueList; // Constant declaration for valid Security Policy Types // General administrative policies const CORBA::PolicyType SecClientInvocationAccess = 1; const CORBA::PolicyType SecTargetInvocationAccess = 2; const CORBA::PolicyType SecApplicationAccess = 3; const CORBA::PolicyType SecClientInvocationAudit = 4; const CORBA::PolicyType SecTargetInvocationAudit = 5; const CORBA::PolicyType SecApplicationAudit = 6; const CORBA::PolicyType SecDelegation = 7; const CORBA::PolicyType SecClientSecureInvocation = 8; const CORBA::PolicyType SecTargetSecureInvocation = 9; const CORBA::PolicyType SecNonRepudiation = 10; // Policies used to control attributes of a binding to a target const CORBA::PolicyType SecMechanismsPolicy = 12; const CORBA::PolicyType SecInvocationCredentialsPolicy = 13; const CORBA::PolicyType SecFeaturePolicy = 14; // obsolete const CORBA::PolicyType SecQOPPolicy = 15; const CORBA::PolicyType SecDelegationDirectivePolicy = 38; const CORBA::PolicyType SecEstablishTrustPolicy = 39; }; #endif /* _SECURITY_IDL_ */ polyorb-2.8~20110207.orig/idls/cos/security/SSLIOP.idl0000644000175000017500000000121211750740337021475 0ustar xavierxavier//File: SSLIOP.idl //Part of the Security Service //OMG File: 02-03-12 #if !defined(_SSLIOP_IDL) #define _SSLIOP_IDL #ifdef _PRE_3_0_COMPILER_ #include #include #pragma prefix "omg.org" #else import ::IOP; import ::Security; #endif // _PRE_3_0_COMPILER_ module SSLIOP { #ifndef _PRE_3_0_COMPILER_ typeprefix SSLIOP "omg.org"; #endif // _PRE_3_0_COMPILER_ // Security mechanism SSL const IOP::ComponentId TAG_SSL_SEC_TRANS = 20; struct SSL { Security::AssociationOptions target_supports; Security::AssociationOptions target_requires; unsigned short port; }; }; #endif /* _SSLIOP_IDL */ polyorb-2.8~20110207.orig/idls/cos/security/SecurityReplaceable.idl0000644000175000017500000001422111750740337024417 0ustar xavierxavier//File: SecurityReplaceable.idl //Part of the Security Service //OMG File: 02-03-12 #if !defined(_SECURITY_REPLACEABLE_IDL_) #define _SECURITY_REPLACEABLE_IDL_ #ifdef _PRE_3_0_COMPILER_ #include #include #pragma prefix "omg.org" #else import ::SecurityLevel2; import ::IOP; #endif // _PRE_3_0_COMPILER_ module SecurityReplaceable { #ifndef _PRE_3_0_COMPILER_ typeprefix SecurityReplaceable "omg.org"; #endif // _PRE_3_0_COMPILER_ # pragma version SecurityReplaceable 1.8 local interface SecurityContext; local interface ClientSecurityContext; local interface ServerSecurityContext; local interface Vault { # pragma version Vault 1.8 Security::AuthenticationMethodList get_supported_authen_methods( in Security::MechanismType mechanism ); readonly attribute Security::OIDList supported_mech_oids; Security::AuthenticationStatus acquire_credentials( in Security::AuthenticationMethod method, in Security::MechanismType mechanism, in Security::SecurityName security_name, in any auth_data, in Security::AttributeList privileges, out SecurityLevel2::Credentials creds, out any continuation_data, out any auth_specific_data ); Security::AuthenticationStatus continue_credentials_acquisition( in any response_data, in SecurityLevel2::Credentials creds, out any continuation_data, out any auth_specific_data ); IOP::TaggedComponentSeq create_ior_components( in SecurityLevel2::Credentials creds_list ); Security::AssociationStatus init_security_context ( in SecurityLevel2::Credentials creds, in Security::SecurityName target_security_name, in Object target, in Security::DelegationMode delegation_mode, in Security::OptionsDirectionPairList association_options, in Security::MechanismType mechanism, in Security::Opaque comp_data, //from IOR in Security::ChannelBindings chan_binding, out Security::OpaqueBuffer security_token, out ClientSecurityContext security_context ); Security::AssociationStatus accept_security_context ( in SecurityLevel2::CredentialsList creds_list, in Security::ChannelBindings chan_bindings, in Security::OpaqueBuffer in_token, out Security::OpaqueBuffer out_token, out ServerSecurityContext security_context ); Security::MechandOptionsList get_supported_mechs (); }; local interface SecurityContext { # pragma version SecurityContext 1.8 readonly attribute Security::SecurityContextType context_type; readonly attribute Security::SecurityContextState context_state; readonly attribute Security::MechanismType mechanism; readonly attribute Security::ChannelBindings chan_binding; readonly attribute SecurityLevel2::ReceivedCredentials received_credentials; Security::AssociationStatus continue_security_context ( in Security::OpaqueBuffer in_token, out Security::OpaqueBuffer out_token ); void protect_message ( in Security::OpaqueBuffer message, in Security::QOP qop, out Security::OpaqueBuffer text_buffer, out Security::OpaqueBuffer token ); boolean reclaim_message ( in Security::OpaqueBuffer text_buffer, in Security::OpaqueBuffer token, out Security::QOP qop, out Security::OpaqueBuffer message ); boolean is_valid ( out Security::UtcT expiry_time ); boolean discard_security_context ( in Security::Opaque discard_data, out Security::OpaqueBuffer out_token ); boolean process_discard_token ( in Security::OpaqueBuffer discard_token ); }; local interface ClientSecurityContext : SecurityContext { #pragma version ClientSecurityContext 1.8 readonly attribute Security::AssociationOptions association_options_used; readonly attribute Security::DelegationMode delegation_mode; readonly attribute Security::Opaque comp_data; readonly attribute SecurityLevel2::Credentials client_credentials; readonly attribute Security::AssociationOptions server_options_supported; readonly attribute Security::AssociationOptions server_options_required; readonly attribute Security::Opaque server_security_name; }; local interface ServerSecurityContext : SecurityContext { #pragma version ServerSecurityContext 1.8 readonly attribute Security::AssociationOptions association_options_used; readonly attribute Security::DelegationMode delegation_mode; readonly attribute SecurityLevel2::Credentials server_credentials; readonly attribute Security::AssociationOptions server_options_supported; readonly attribute Security::AssociationOptions server_options_required; readonly attribute Security::Opaque server_security_name; }; interface RequiredRights{ void get_required_rights( in CORBA::Identifier operation_name, in CORBA::RepositoryId interface_name, out Security::RightsList rights, out Security::RightsCombinator rights_combinator ); void set_required_rights( in CORBA::Identifier operation_name, in CORBA::RepositoryId interface_name, in Security::RightsList rights, in Security::RightsCombinator rights_combinator ); }; local interface AuditChannel { void audit_write ( in Security::AuditEventType event_type, in SecurityLevel2::CredentialsList creds_list, in Security::UtcT time, in Security::SelectorValueList descriptors, in Security::Opaque event_specific_data ); readonly attribute Security::AuditChannelId audit_channel_id; }; local interface AuditDecision { boolean audit_needed ( in Security:: AuditEventType event_type, in Security::SelectorValueList value_list ); readonly attribute AuditChannel audit_channel; }; local interface AccessDecision { boolean access_allowed ( in SecurityLevel2::CredentialsList cred_list, in CORBA::Identifier operation_name, in CORBA::Identifier target_interface_name ); }; }; #endif /* _SECURITY_REPLACEABLE_IDL_ */ polyorb-2.8~20110207.orig/idls/cos/security/SecurityLevel1.idl0000644000175000017500000000126111750740337023350 0ustar xavierxavier//File: SecurityLevel1.idl //Part of the Security Service //OMG File: 02-03-12 #if !defined(_SECURITY_LEVEL_1_IDL_) #define _SECURITY_LEVEL_1_IDL_ #ifdef _PRE_3_0_COMPILER_ #include #pragma prefix "omg.org" #else import ::Security; #endif // _PRE_3_0_COMPILER_ module SecurityLevel1 { #ifndef _PRE_3_0_COMPILER_ typeprefix SecurityLevel1 "omg.org"; #endif // _PRE_3_0_COMPILER_ # pragma version SecurityLevel1 1.8 local interface Current : CORBA::Current { # pragma version Current 1.8 // thread specific operations Security::AttributeList get_attributes ( in Security::AttributeTypeList attributes ); }; }; #endif /* _SECURITY_LEVEL_1_IDL_ */ polyorb-2.8~20110207.orig/idls/cos/security/SecurityLevel2.idl0000644000175000017500000001516411750740337023360 0ustar xavierxavier//File: SecurityLevel2.idl //Part of the Security Service //OMG File: 02-03-12 #if !defined(_SECURITY_LEVEL_2_IDL_) #define _SECURITY_LEVEL_2_IDL_ #ifdef _PRE_3_0_COMPILER_ #include #pragma prefix "omg.org" #else import ::SecurityLevel1; #endif // _PRE_3_0_COMPILER_ module SecurityLevel2 { #ifndef _PRE_3_0_COMPILER_ typeprefix SecurityLevel2 "omg.org"; #endif // _PRE_3_0_COMPILER_ # pragma version SecurityLevel2 1.8 // Forward declaration of interfaces local interface PrincipalAuthenticator; local interface Credentials; local interface Current; // Interface PrincipalAuthenticator local interface PrincipalAuthenticator { # pragma version PrincipalAuthenticator 1.8 Security::AuthenticationMethodList get_supported_authen_methods( in Security::MechanismType mechanism ); Security::AuthenticationStatus authenticate ( in Security::AuthenticationMethod method, in Security::MechanismType mechanism, in Security::SecurityName security_name, in any auth_data, in Security::AttributeList privileges, out Credentials creds, out any continuation_data, out any auth_specific_data ); Security::AuthenticationStatus continue_authentication ( in any response_data, in Credentials creds, out any continuation_data, out any auth_specific_data ); }; // Interface Credentials local interface Credentials { # pragma version Credentials 1.8 Credentials copy (); void destroy(); readonly attribute Security::InvocationCredentialsType credentials_type; readonly attribute Security::AuthenticationStatus authentication_state; readonly attribute Security::MechanismType mechanism; attribute Security::AssociationOptions accepting_options_supported; attribute Security::AssociationOptions accepting_options_required; attribute Security::AssociationOptions invocation_options_supported; attribute Security::AssociationOptions invocation_options_required; boolean get_security_feature( in Security::CommunicationDirection direction, in Security::SecurityFeature feature ); boolean set_attributes ( in Security::AttributeList requested_attributes, out Security::AttributeList actual_attributes ); Security::AttributeList get_attributes ( in Security::AttributeTypeList attributes ); boolean is_valid ( out Security::UtcT expiry_time ); boolean refresh( in any refresh_data ); }; typedef sequence CredentialsList; local interface ReceivedCredentials : Credentials { # pragma version ReceivedCredentials 1.8 readonly attribute Credentials accepting_credentials; readonly attribute Security::AssociationOptions association_options_used; readonly attribute Security::DelegationState delegation_state; readonly attribute Security::DelegationMode delegation_mode; }; local interface TargetCredentials : Credentials { # pragma version TargetCredentials 1.8 readonly attribute Credentials initiating_credentials; readonly attribute Security::AssociationOptions association_options_used; }; // RequiredRights Interface interface RequiredRights{ void get_required_rights( in Object obj, in CORBA::Identifier operation_name, in CORBA::RepositoryId interface_name, out Security::RightsList rights, out Security::RightsCombinator rights_combinator ); void set_required_rights( in CORBA::Identifier operation_name, in CORBA::RepositoryId interface_name, in Security::RightsList rights, in Security::RightsCombinator rights_combinator ); }; // interface audit channel local interface AuditChannel { # pragma version AuditChannel 1.8 void audit_write ( in Security::AuditEventType event_type, in CredentialsList creds, in Security::UtcT time, in Security::SelectorValueList descriptors, in any event_specific_data ); readonly attribute Security::AuditChannelId audit_channel_id; }; // interface for Audit Decision local interface AuditDecision { #pragma version AuditDecision 1.8 boolean audit_needed ( in Security:: AuditEventType event_type, in Security::SelectorValueList value_list ); readonly attribute AuditChannel audit_channel; }; local interface AccessDecision { #pragma version AccessDecision 1.8 boolean access_allowed ( in SecurityLevel2::CredentialsList cred_list, in Object target, in CORBA::Identifier operation_name, in CORBA::Identifier target_interface_name ); }; // Policy interfaces to control bindings local interface QOPPolicy : CORBA::Policy { #pragma version QOPPolicy 1.8 readonly attribute Security::QOP qop; }; local interface MechanismPolicy : CORBA::Policy { #pragma version MechanismPolicy 1.8 readonly attribute Security::MechanismTypeList mechanisms; }; local interface InvocationCredentialsPolicy : CORBA::Policy { #pragma version InvocationCredentialsPolicy 1.8 readonly attribute CredentialsList creds; }; local interface EstablishTrustPolicy : CORBA::Policy { #pragma version EstablishTrustPolicy 1.8 readonly attribute Security::EstablishTrust trust; }; local interface DelegationDirectivePolicy : CORBA::Policy { #pragma version DelegationDirectivePolicy 1.8 readonly attribute Security::DelegationDirective delegation_directive; }; local interface SecurityManager { #pragma version SecurityManager 1.8 // Process/Capsule/ORB Instance specific operations readonly attribute Security::MechandOptionsList supported_mechanisms; readonly attribute CredentialsList own_credentials; readonly attribute RequiredRights required_rights_object; readonly attribute PrincipalAuthenticator principal_authenticator; readonly attribute AccessDecision access_decision; readonly attribute AuditDecision audit_decision; TargetCredentials get_target_credentials ( in Object obj_ref ); void remove_own_credentials( in Credentials creds ); CORBA::Policy get_security_policy ( in CORBA::PolicyType policy_type ); }; // Interface Current derived from SecurityLevel1::Current providing // additional operations on Current at this security level. // This is implemented by the ORB local interface Current : SecurityLevel1::Current { # pragma version Current 1.8 // Thread specific readonly attribute ReceivedCredentials received_credentials; }; }; #endif /* _SECURITY_LEVEL_2_IDL_ */ polyorb-2.8~20110207.orig/idls/cos/security/DCE_CIOPSecurity.idl0000644000175000017500000000225411750740337023430 0ustar xavierxavier//File: DCE_CIOPSecurity.idl //Part of the Security Service //OMG File: 02-03-12 #if !defined(_DCE_CIOP_SECURITY_IDL) #define _DCE_CIOP_SECURITY_IDL #ifdef _PRE_3_0_COMPILER_ #include #include #pragma prefix "omg.org" #else import ::IOP; import ::Security; #endif // _PRE_3_0_COMPILER_ module DCE_CIOPSecurity { #ifndef _PRE_3_0_COMPILER_ typeprefix DCE_CIOPSecurity "omg.org"; #endif // _PRE_3_0_COMPILER_ const IOP::ComponentId TAG_DCE_SEC_MECH = 103; typedef unsigned short DCEAuthorization; const DCEAuthorization DCEAuthorizationNone = 0; const DCEAuthorization DCEAuthorizationName = 1; const DCEAuthorization DCEAuthorizationDCE = 2; // since consts of type octet are not allowed in IDL the constant // values that can be assigned to the authorization_service field // in the DCESecurityMechanismInfo is declared as unsigned shorts. // when they actually get assigned to the authorization_service field // they should be assigned as octets. struct DCESecurityMechanismInfo { octet authorization_service; sequence components; }; }; #endif /* _DCE_CIOP_SECURITY_IDL */ polyorb-2.8~20110207.orig/idls/cos/notification/0000755000175000017500000000000011750740340020607 5ustar xavierxavierpolyorb-2.8~20110207.orig/idls/cos/notification/CosNotifyFilter.idl0000644000175000017500000001071611750740337024377 0ustar xavierxavier//File: CosNotifyFilter.idl //Part of the Notification Service //OMG File: 04-10-12 #ifndef _COS_NOTIFY_FILTER_IDL_ #define _COS_NOTIFY_FILTER_IDL_ #ifdef _PRE_3_0_COMPILER_ #include #include #pragma prefix "omg.org" #else import ::CORBA; import ::CosNotifyComm; #endif // _PRE_3_0_COMPILER_ module CosNotifyFilter { #ifndef _PRE_3_0_COMPILER_ typeprefix CosNotifyFilter "omg.org"; #endif // _PRE_3_0_COMPILER_ typedef long ConstraintID; struct ConstraintExp { CosNotification::EventTypeSeq event_types; string constraint_expr; }; typedef sequence ConstraintIDSeq; typedef sequence ConstraintExpSeq; struct ConstraintInfo { ConstraintExp constraint_expression; ConstraintID constraint_id; }; typedef sequence ConstraintInfoSeq; struct MappingConstraintPair { ConstraintExp constraint_expression; any result_to_set; }; typedef sequence MappingConstraintPairSeq; struct MappingConstraintInfo { ConstraintExp constraint_expression; ConstraintID constraint_id; any value; }; typedef sequence MappingConstraintInfoSeq; typedef long CallbackID; typedef sequence CallbackIDSeq; exception UnsupportedFilterableData {}; exception InvalidGrammar {}; exception InvalidConstraint {ConstraintExp constr;}; exception DuplicateConstraintID {ConstraintID id;}; exception ConstraintNotFound {ConstraintID id;}; exception CallbackNotFound {}; exception InvalidValue {ConstraintExp constr; any value;}; interface Filter { readonly attribute string constraint_grammar; ConstraintInfoSeq add_constraints ( in ConstraintExpSeq constraint_list) raises (InvalidConstraint); void modify_constraints ( in ConstraintIDSeq del_list, in ConstraintInfoSeq modify_list) raises (InvalidConstraint, ConstraintNotFound); ConstraintInfoSeq get_constraints( in ConstraintIDSeq id_list) raises (ConstraintNotFound); ConstraintInfoSeq get_all_constraints(); void remove_all_constraints(); void destroy(); boolean match ( in any filterable_data ) raises (UnsupportedFilterableData); boolean match_structured ( in CosNotification::StructuredEvent filterable_data ) raises (UnsupportedFilterableData); boolean match_typed ( in CosNotification::PropertySeq filterable_data ) raises (UnsupportedFilterableData); CallbackID attach_callback ( in CosNotifyComm::NotifySubscribe callback); void detach_callback ( in CallbackID callback) raises ( CallbackNotFound ); CallbackIDSeq get_callbacks(); }; // Filter interface MappingFilter { readonly attribute string constraint_grammar; readonly attribute CORBA::TypeCode value_type; readonly attribute any default_value; MappingConstraintInfoSeq add_mapping_constraints ( in MappingConstraintPairSeq pair_list) raises (InvalidConstraint, InvalidValue); void modify_mapping_constraints ( in ConstraintIDSeq del_list, in MappingConstraintInfoSeq modify_list) raises (InvalidConstraint, InvalidValue, ConstraintNotFound); MappingConstraintInfoSeq get_mapping_constraints ( in ConstraintIDSeq id_list) raises (ConstraintNotFound); MappingConstraintInfoSeq get_all_mapping_constraints(); void remove_all_mapping_constraints(); void destroy(); boolean match ( in any filterable_data, out any result_to_set ) raises (UnsupportedFilterableData); boolean match_structured ( in CosNotification::StructuredEvent filterable_data, out any result_to_set) raises (UnsupportedFilterableData); boolean match_typed ( in CosNotification::PropertySeq filterable_data, out any result_to_set) raises (UnsupportedFilterableData); }; // MappingFilter interface FilterFactory { Filter create_filter ( in string constraint_grammar) raises (InvalidGrammar); MappingFilter create_mapping_filter ( in string constraint_grammar, in any default_value) raises(InvalidGrammar); }; // FilterFactory typedef long FilterID; typedef sequence FilterIDSeq; exception FilterNotFound {}; interface FilterAdmin { FilterID add_filter ( in Filter new_filter ); void remove_filter ( in FilterID filter ) raises ( FilterNotFound ); Filter get_filter ( in FilterID filter ) raises ( FilterNotFound ); FilterIDSeq get_all_filters(); void remove_all_filters(); }; // FilterAdmin }; // CosNotifyFilter #endif /* _COS_NOTIFY_FILTER_IDL_ */ polyorb-2.8~20110207.orig/idls/cos/notification/CosNotification.idl0000644000175000017500000001145511750740337024410 0ustar xavierxavier//File: CosNotification.idl //Part of the Notification Service //OMG File: 04-10-12 #ifndef _COS_NOTIFICATION_IDL_ #define _COS_NOTIFICATION_IDL_ #ifdef _PRE_3_0_COMPILER_ #pragma prefix "omg.org" #endif // _PRE_3_0_COMPILER_ module CosNotification { #ifndef _PRE_3_0_COMPILER_ typeprefix CosNotification "omg.org"; #endif // _PRE_3_0_COMPILER_ typedef string Istring; typedef Istring PropertyName; typedef any PropertyValue; struct Property { PropertyName name; PropertyValue value; }; typedef sequence PropertySeq; // The following are the same, but serve different purposes. typedef PropertySeq OptionalHeaderFields; typedef PropertySeq FilterableEventBody; typedef PropertySeq QoSProperties; typedef PropertySeq AdminProperties; struct _EventType { string domain_name; string type_name; }; typedef sequence<_EventType> EventTypeSeq; struct PropertyRange { PropertyValue low_val; PropertyValue high_val; }; struct NamedPropertyRange { PropertyName name; PropertyRange range; }; typedef sequence NamedPropertyRangeSeq; enum QoSError_code { UNSUPPORTED_PROPERTY, UNAVAILABLE_PROPERTY, UNSUPPORTED_VALUE, UNAVAILABLE_VALUE, BAD_PROPERTY, BAD_TYPE, BAD_VALUE }; struct PropertyError { QoSError_code code; PropertyName name; PropertyRange available_range; }; typedef sequence PropertyErrorSeq; exception UnsupportedQoS { PropertyErrorSeq qos_err; }; exception UnsupportedAdmin { PropertyErrorSeq admin_err; }; // Define the Structured Event structure struct FixedEventHeader { _EventType event_type; string event_name; }; struct EventHeader { FixedEventHeader fixed_header; OptionalHeaderFields variable_header; }; struct StructuredEvent { EventHeader header; FilterableEventBody filterable_data; any remainder_of_body; }; // StructuredEvent typedef sequence EventBatch; // The following constant declarations define the standard // QoS property names and the associated values each property // can take on. The name/value pairs for each standard property // are grouped, beginning with a string constant defined for the // property name, followed by the values the property can take on. const string EventReliability = "EventReliability"; const short BestEffort = 0; const short Persistent = 1; const string ConnectionReliability = "ConnectionReliability"; // Can take on the same values as EventReliability const string Priority = "Priority"; const short LowestPriority = -32767; const short HighestPriority = 32767; const short DefaultPriority = 0; const string StartTime = "StartTime"; // StartTime takes a value of type TimeBase::UtcT. const string StopTime = "StopTime"; // StopTime takes a value of type TimeBase::UtcT. const string Timeout = "Timeout"; // Timeout takes on a value of type TimeBase::TimeT const string OrderPolicy = "OrderPolicy"; const short AnyOrder = 0; const short FifoOrder = 1; const short PriorityOrder = 2; const short DeadlineOrder = 3; const string DiscardPolicy = "DiscardPolicy"; // DiscardPolicy takes on the same values as OrderPolicy, plus const short LifoOrder = 4; const string MaximumBatchSize = "MaximumBatchSize"; // MaximumBatchSize takes on a value of type long const string PacingInterval = "PacingInterval"; // PacingInterval takes on a value of type TimeBase::TimeT const string StartTimeSupported = "StartTimeSupported"; // StartTimeSupported takes on a boolean value const string StopTimeSupported = "StopTimeSupported"; // StopTimeSupported takes on a boolean value const string MaxEventsPerConsumer = "MaxEventsPerConsumer"; // MaxEventsPerConsumer takes on a value of type long interface QoSAdmin { QoSProperties get_qos(); void set_qos ( in QoSProperties qos) raises ( UnsupportedQoS ); void validate_qos ( in QoSProperties required_qos, out NamedPropertyRangeSeq available_qos ) raises ( UnsupportedQoS ); }; // QosAdmin // Admin properties are defined in similar manner as QoS // properties. The only difference is that these properties // are related to channel administration policies, as opposed // message quality of service const string MaxQueueLength = "MaxQueueLength"; // MaxQueueLength takes on a value of type long const string MaxConsumers = "MaxConsumers"; // MaxConsumers takes on a value of type long const string MaxSuppliers = "MaxSuppliers"; // MaxSuppliers takes on a value of type long const string RejectNewEvents = "RejectNewEvents"; // RejectNewEvents takes on a value of type Boolean interface AdminPropertiesAdmin { AdminProperties get_admin(); void set_admin (in AdminProperties admin) raises ( UnsupportedAdmin); }; // AdminPropertiesAdmin }; // CosNotification #endif /* _COS_NOTIFICATION_IDL_ */ polyorb-2.8~20110207.orig/idls/cos/notification/CosNotifyComm.idl0000644000175000017500000000610511750740337024042 0ustar xavierxavier//File: CosNotifyComm.idl //Part of the Notification Service //OMG File: 04-10-12 #ifndef _COS_NOTIFY_COMM_IDL_ #define _COS_NOTIFY_COMM_IDL_ #ifdef _PRE_3_0_COMPILER_ #include #include #pragma prefix "omg.org" #else import ::CosNotification; import ::CosEventComm; #endif // _PRE_3_0_COMPILER_ module CosNotifyComm { #ifndef _PRE_3_0_COMPILER_ typeprefix CosNotifyComm "omg.org"; #endif // _PRE_3_0_COMPILER_ exception InvalidEventType { CosNotification::_EventType type; }; interface NotifyPublish { void offer_change ( in CosNotification::EventTypeSeq added, in CosNotification::EventTypeSeq removed ) raises ( InvalidEventType ); }; // NotifyPublish interface NotifySubscribe { void subscription_change( in CosNotification::EventTypeSeq added, in CosNotification::EventTypeSeq removed ) raises ( InvalidEventType ); }; // NotifySubscribe interface PushConsumer : NotifyPublish, CosEventComm::PushConsumer { }; // PushConsumer interface PullConsumer : NotifyPublish, CosEventComm::PullConsumer { }; // PullConsumer interface PullSupplier : NotifySubscribe, CosEventComm::PullSupplier { }; // PullSupplier interface PushSupplier : NotifySubscribe, CosEventComm::PushSupplier { }; interface StructuredPushConsumer : NotifyPublish { void push_structured_event( in CosNotification::StructuredEvent notification) raises(CosEventComm::Disconnected); void disconnect_structured_push_consumer(); }; // StructuredPushConsumer interface StructuredPullConsumer : NotifyPublish { void disconnect_structured_pull_consumer(); }; // StructuredPullConsumer interface StructuredPullSupplier : NotifySubscribe { CosNotification::StructuredEvent pull_structured_event() raises(CosEventComm::Disconnected); CosNotification::StructuredEvent try_pull_structured_event( out boolean has_event) raises(CosEventComm::Disconnected); void disconnect_structured_pull_supplier(); }; // StructuredPullSupplier interface StructuredPushSupplier : NotifySubscribe { void disconnect_structured_push_supplier(); }; // StructuredPushSupplier interface SequencePushConsumer : NotifyPublish { void push_structured_events( in CosNotification::EventBatch notifications) raises(CosEventComm::Disconnected); void disconnect_sequence_push_consumer(); }; // SequencePushConsumer interface SequencePullConsumer : NotifyPublish { void disconnect_sequence_pull_consumer(); }; // SequencePullConsumer interface SequencePullSupplier : NotifySubscribe { CosNotification::EventBatch pull_structured_events( in long max_number ) raises(CosEventComm::Disconnected); CosNotification::EventBatch try_pull_structured_events( in long max_number, out boolean has_event) raises(CosEventComm::Disconnected); void disconnect_sequence_pull_supplier(); }; // SequencePullSupplier interface SequencePushSupplier : NotifySubscribe { void disconnect_sequence_push_supplier(); }; // SequencePushSupplier }; // CosNotifyComm #endif /* _COS_NOTIFY_COMM_IDL_ */ polyorb-2.8~20110207.orig/idls/cos/notification/CosTypedNotifyComm.idl0000644000175000017500000000153511750740337025052 0ustar xavierxavier//File: CosTypedNotifyComm.idl //Part of the Notification Service //OMG File: 04-10-12 #ifndef _COS_TYPED_NOTIFY_COMM_IDL_ #define _COS_TYPED_NOTIFY_COMM_IDL_ #ifdef _PRE_3_0_COMPILER_ #include #include #pragma prefix "omg.org" #else import ::CosNotifyChannelAdmin; import ::CosTypedEventComm; #endif // _PRE_3_0_COMPILER_ module CosTypedNotifyComm { #ifndef _PRE_3_0_COMPILER_ typeprefix CosTypedNotifyComm "omg.org"; #endif // _PRE_3_0_COMPILER_ interface TypedPushConsumer : CosTypedEventComm::TypedPushConsumer, CosNotifyComm::NotifyPublish { }; // TypedPushConsumer interface TypedPullSupplier : CosTypedEventComm::TypedPullSupplier, CosNotifyComm::NotifySubscribe { }; // TypedPullSupplier }; // CosTypedNotifyComm #endif /* _COS_TYPED_NOTIFY_COMM_IDL_ */ polyorb-2.8~20110207.orig/idls/cos/notification/CosNotifyChannelAdmin.idl0000644000175000017500000002411011750740337025464 0ustar xavierxavier//File: CosNotifyChannelAdmin.idl //Part of the Notification Service //OMG File: 04-10-12 #ifndef _COS_NOTIFY_CHANNEL_ADMIN_IDL_ #define _COS_NOTIFY_CHANNEL_ADMIN_IDL_ #ifdef _PRE_3_0_COMPILER_ #include #include #include #include #pragma prefix "omg.org" #else import ::CosNotification; import ::CosNotifyFilter; import ::CosNotifyComm; import ::CosEventChannelAdmin; #endif // _PRE_3_0_COMPILER_ module CosNotifyChannelAdmin { #ifndef _PRE_3_0_COMPILER_ typeprefix CosNotifyChannelAdmin "omg.org"; #endif // _PRE_3_0_COMPILER_ exception ConnectionAlreadyActive {}; exception ConnectionAlreadyInactive {}; exception NotConnected {}; // Forward declarations interface ConsumerAdmin; interface SupplierAdmin; interface EventChannel; interface EventChannelFactory; enum ProxyType { PUSH_ANY, PULL_ANY, PUSH_STRUCTURED, PULL_STRUCTURED, PUSH_SEQUENCE, PULL_SEQUENCE, PUSH_TYPED, PULL_TYPED }; enum ObtainInfoMode { ALL_NOW_UPDATES_OFF, ALL_NOW_UPDATES_ON, NONE_NOW_UPDATES_OFF, NONE_NOW_UPDATES_ON }; interface ProxyConsumer : CosNotification::QoSAdmin, CosNotifyFilter::FilterAdmin { readonly attribute ProxyType MyType; readonly attribute SupplierAdmin MyAdmin; CosNotification::EventTypeSeq obtain_subscription_types( in ObtainInfoMode mode ); void validate_event_qos ( in CosNotification::QoSProperties required_qos, out CosNotification::NamedPropertyRangeSeq available_qos) raises (CosNotification::UnsupportedQoS); }; // ProxyConsumer interface ProxySupplier : CosNotification::QoSAdmin, CosNotifyFilter::FilterAdmin { readonly attribute ProxyType MyType; readonly attribute ConsumerAdmin MyAdmin; attribute CosNotifyFilter::MappingFilter priority_filter; attribute CosNotifyFilter::MappingFilter lifetime_filter; CosNotification::EventTypeSeq obtain_offered_types( in ObtainInfoMode mode ); void validate_event_qos ( in CosNotification::QoSProperties required_qos, out CosNotification::NamedPropertyRangeSeq available_qos) raises (CosNotification::UnsupportedQoS); }; // ProxySupplier interface ProxyPushConsumer : ProxyConsumer, CosNotifyComm::PushConsumer { void connect_any_push_supplier ( in CosEventComm::PushSupplier push_supplier) raises(CosEventChannelAdmin::AlreadyConnected); }; // ProxyPushConsumer interface StructuredProxyPushConsumer : ProxyConsumer, CosNotifyComm::StructuredPushConsumer { void connect_structured_push_supplier ( in CosNotifyComm::StructuredPushSupplier push_supplier) raises(CosEventChannelAdmin::AlreadyConnected); }; // StructuredProxyPushConsumer interface SequenceProxyPushConsumer : ProxyConsumer, CosNotifyComm::SequencePushConsumer { void connect_sequence_push_supplier ( in CosNotifyComm::SequencePushSupplier push_supplier) raises(CosEventChannelAdmin::AlreadyConnected); }; // SequenceProxyPushConsumer interface ProxyPullSupplier : ProxySupplier, CosNotifyComm::PullSupplier { void connect_any_pull_consumer ( in CosEventComm::PullConsumer pull_consumer) raises(CosEventChannelAdmin::AlreadyConnected); }; // ProxyPullSupplier interface StructuredProxyPullSupplier : ProxySupplier, CosNotifyComm::StructuredPullSupplier { void connect_structured_pull_consumer ( in CosNotifyComm::StructuredPullConsumer pull_consumer) raises(CosEventChannelAdmin::AlreadyConnected); }; // StructuredProxyPullSupplier interface SequenceProxyPullSupplier : ProxySupplier, CosNotifyComm::SequencePullSupplier { void connect_sequence_pull_consumer ( in CosNotifyComm::SequencePullConsumer pull_consumer) raises(CosEventChannelAdmin::AlreadyConnected); }; // SequenceProxyPullSupplier interface ProxyPullConsumer : ProxyConsumer, CosNotifyComm::PullConsumer { void connect_any_pull_supplier ( in CosEventComm::PullSupplier pull_supplier) raises(CosEventChannelAdmin::AlreadyConnected, CosEventChannelAdmin::TypeError ); void suspend_connection() raises(ConnectionAlreadyInactive, NotConnected); void resume_connection() raises(ConnectionAlreadyActive, NotConnected); }; // ProxyPullConsumer interface StructuredProxyPullConsumer : ProxyConsumer, CosNotifyComm::StructuredPullConsumer { void connect_structured_pull_supplier ( in CosNotifyComm::StructuredPullSupplier pull_supplier) raises(CosEventChannelAdmin::AlreadyConnected, CosEventChannelAdmin::TypeError ); void suspend_connection() raises(ConnectionAlreadyInactive, NotConnected); void resume_connection() raises(ConnectionAlreadyActive, NotConnected); }; // StructuredProxyPullConsumer interface SequenceProxyPullConsumer : ProxyConsumer, CosNotifyComm::SequencePullConsumer { void connect_sequence_pull_supplier ( in CosNotifyComm::SequencePullSupplier pull_supplier) raises(CosEventChannelAdmin::AlreadyConnected, CosEventChannelAdmin::TypeError ); void suspend_connection() raises(ConnectionAlreadyInactive, NotConnected); void resume_connection() raises(ConnectionAlreadyActive, NotConnected); }; // SequenceProxyPullConsumer interface ProxyPushSupplier : ProxySupplier, CosNotifyComm::PushSupplier { void connect_any_push_consumer ( in CosEventComm::PushConsumer push_consumer) raises(CosEventChannelAdmin::AlreadyConnected, CosEventChannelAdmin::TypeError ); void suspend_connection() raises(ConnectionAlreadyInactive, NotConnected); void resume_connection() raises(ConnectionAlreadyActive, NotConnected); }; // ProxyPushSupplier interface StructuredProxyPushSupplier : ProxySupplier, CosNotifyComm::StructuredPushSupplier { void connect_structured_push_consumer ( in CosNotifyComm::StructuredPushConsumer push_consumer) raises(CosEventChannelAdmin::AlreadyConnected, CosEventChannelAdmin::TypeError ); void suspend_connection() raises(ConnectionAlreadyInactive, NotConnected); void resume_connection() raises(ConnectionAlreadyActive, NotConnected); }; // StructuredProxyPushSupplier interface SequenceProxyPushSupplier : ProxySupplier, CosNotifyComm::SequencePushSupplier { void connect_sequence_push_consumer ( in CosNotifyComm::SequencePushConsumer push_consumer) raises(CosEventChannelAdmin::AlreadyConnected, CosEventChannelAdmin::TypeError ); void suspend_connection() raises(ConnectionAlreadyInactive, NotConnected); void resume_connection() raises(ConnectionAlreadyActive, NotConnected); }; // SequenceProxyPushSupplier typedef long ProxyID; typedef sequence ProxyIDSeq; enum ClientType { ANY_EVENT, STRUCTURED_EVENT, SEQUENCE_EVENT }; enum InterFilterGroupOperator { AND_OP, OR_OP }; typedef long AdminID; typedef sequence AdminIDSeq; exception AdminNotFound {}; exception ProxyNotFound {}; struct AdminLimit { CosNotification::PropertyName name; CosNotification::PropertyValue value; }; exception AdminLimitExceeded { AdminLimit admin_property_err; }; interface ConsumerAdmin : CosNotification::QoSAdmin, CosNotifyComm::NotifySubscribe, CosNotifyFilter::FilterAdmin, CosEventChannelAdmin::ConsumerAdmin { readonly attribute AdminID MyID; readonly attribute EventChannel MyChannel; readonly attribute InterFilterGroupOperator MyOperator; attribute CosNotifyFilter::MappingFilter priority_filter; attribute CosNotifyFilter::MappingFilter lifetime_filter; readonly attribute ProxyIDSeq pull_suppliers; readonly attribute ProxyIDSeq push_suppliers; ProxySupplier get_proxy_supplier ( in ProxyID proxy_id ) raises ( ProxyNotFound ); ProxySupplier obtain_notification_pull_supplier ( in ClientType ctype, out ProxyID proxy_id) raises ( AdminLimitExceeded ); ProxySupplier obtain_notification_push_supplier ( in ClientType ctype, out ProxyID proxy_id) raises ( AdminLimitExceeded ); void destroy(); }; // ConsumerAdmin interface SupplierAdmin : CosNotification::QoSAdmin, CosNotifyComm::NotifyPublish, CosNotifyFilter::FilterAdmin, CosEventChannelAdmin::SupplierAdmin { readonly attribute AdminID MyID; readonly attribute EventChannel MyChannel; readonly attribute InterFilterGroupOperator MyOperator; readonly attribute ProxyIDSeq pull_consumers; readonly attribute ProxyIDSeq push_consumers; ProxyConsumer get_proxy_consumer ( in ProxyID proxy_id ) raises ( ProxyNotFound ); ProxyConsumer obtain_notification_pull_consumer ( in ClientType ctype, out ProxyID proxy_id) raises ( AdminLimitExceeded ); ProxyConsumer obtain_notification_push_consumer ( in ClientType ctype, out ProxyID proxy_id) raises ( AdminLimitExceeded ); void destroy(); }; // SupplierAdmin interface EventChannel : CosNotification::QoSAdmin, CosNotification::AdminPropertiesAdmin, CosEventChannelAdmin::EventChannel { readonly attribute EventChannelFactory MyFactory; readonly attribute ConsumerAdmin default_consumer_admin; readonly attribute SupplierAdmin default_supplier_admin; readonly attribute CosNotifyFilter::FilterFactory default_filter_factory; ConsumerAdmin new_for_consumers( in InterFilterGroupOperator op, out AdminID id ); SupplierAdmin new_for_suppliers( in InterFilterGroupOperator op, out AdminID id ); ConsumerAdmin get_consumeradmin ( in AdminID id ) raises (AdminNotFound); SupplierAdmin get_supplieradmin ( in AdminID id ) raises (AdminNotFound); AdminIDSeq get_all_consumeradmins(); AdminIDSeq get_all_supplieradmins(); }; // EventChannel typedef long ChannelID; typedef sequence ChannelIDSeq; exception ChannelNotFound {}; interface EventChannelFactory { EventChannel create_channel ( in CosNotification::QoSProperties initial_qos, in CosNotification::AdminProperties initial_admin, out ChannelID id) raises(CosNotification::UnsupportedQoS, CosNotification::UnsupportedAdmin ); ChannelIDSeq get_all_channels(); EventChannel get_event_channel ( in ChannelID id ) raises (ChannelNotFound); }; // EventChannelFactory }; // CosNotifyChannelAdmin #endif /* _COS_NOTIFY_CHANNEL_ADMIN_IDL_ */ polyorb-2.8~20110207.orig/idls/cos/notification/CosTypedNotifyChannelAdmin.idl0000644000175000017500000001277411750740337026507 0ustar xavierxavier//File: CosTypedNotifyChannelAdmin.idl //Part of the Notification Service //OMG File: 04-10-12 #ifndef _COS_TYPED_NOTIFY_CHANNEL_ADMIN_IDL_ #define _COS_TYPED_NOTIFY_CHANNEL_ADMIN_IDL_ #ifdef _PRE_3_0_COMPILER_ #include #include #include #pragma prefix "omg.org" #else import ::CosNotifyChannelAdmin; import ::CosTypedNotifyComm; import ::CosTypedEventChannelAdmin; #endif // _PRE_3_0_COMPILER_ module CosTypedNotifyChannelAdmin { #ifndef _PRE_3_0_COMPILER_ typeprefix CosTypedNotifyChannelAdmin "omg.org"; #endif // _PRE_3_0_COMPILER_ // Forward declaration interface TypedEventChannelFactory; typedef string Key; interface TypedProxyPushConsumer : CosNotifyChannelAdmin::ProxyConsumer, CosTypedNotifyComm::TypedPushConsumer { void connect_typed_push_supplier ( in CosEventComm::PushSupplier push_supplier ) raises ( CosEventChannelAdmin::AlreadyConnected ); }; // TypedProxyPushConsumer interface TypedProxyPullSupplier : CosNotifyChannelAdmin::ProxySupplier, CosTypedNotifyComm::TypedPullSupplier { void connect_typed_pull_consumer ( in CosEventComm::PullConsumer pull_consumer ) raises ( CosEventChannelAdmin::AlreadyConnected ); }; // TypedProxyPullSupplier interface TypedProxyPullConsumer : CosNotifyChannelAdmin::ProxyConsumer, CosNotifyComm::PullConsumer { void connect_typed_pull_supplier ( in CosTypedEventComm::TypedPullSupplier pull_supplier) raises ( CosEventChannelAdmin::AlreadyConnected, CosEventChannelAdmin::TypeError ); void suspend_connection() raises (CosNotifyChannelAdmin::ConnectionAlreadyInactive, CosNotifyChannelAdmin::NotConnected); void resume_connection() raises (CosNotifyChannelAdmin::ConnectionAlreadyActive, CosNotifyChannelAdmin::NotConnected); }; // TypedProxyPullConsumer interface TypedProxyPushSupplier : CosNotifyChannelAdmin::ProxySupplier, CosNotifyComm::PushSupplier { void connect_typed_push_consumer ( in CosTypedEventComm::TypedPushConsumer push_consumer) raises ( CosEventChannelAdmin::AlreadyConnected, CosEventChannelAdmin::TypeError ); void suspend_connection() raises (CosNotifyChannelAdmin::ConnectionAlreadyInactive, CosNotifyChannelAdmin::NotConnected); void resume_connection() raises (CosNotifyChannelAdmin::ConnectionAlreadyActive, CosNotifyChannelAdmin::NotConnected); }; // TypedProxyPushSupplier interface TypedConsumerAdmin : CosNotifyChannelAdmin::ConsumerAdmin, CosTypedEventChannelAdmin::TypedConsumerAdmin { TypedProxyPullSupplier obtain_typed_notification_pull_supplier( in Key supported_interface, out CosNotifyChannelAdmin::ProxyID proxy_id ) raises( CosTypedEventChannelAdmin::InterfaceNotSupported, CosNotifyChannelAdmin::AdminLimitExceeded ); TypedProxyPushSupplier obtain_typed_notification_push_supplier( in Key uses_interface, out CosNotifyChannelAdmin::ProxyID proxy_id ) raises( CosTypedEventChannelAdmin::NoSuchImplementation, CosNotifyChannelAdmin::AdminLimitExceeded ); }; // TypedConsumerAdmin interface TypedSupplierAdmin : CosNotifyChannelAdmin::SupplierAdmin, CosTypedEventChannelAdmin::TypedSupplierAdmin { TypedProxyPushConsumer obtain_typed_notification_push_consumer( in Key supported_interface, out CosNotifyChannelAdmin::ProxyID proxy_id ) raises( CosTypedEventChannelAdmin::InterfaceNotSupported, CosNotifyChannelAdmin::AdminLimitExceeded ); TypedProxyPullConsumer obtain_typed_notification_pull_consumer( in Key uses_interface, out CosNotifyChannelAdmin::ProxyID proxy_id ) raises( CosTypedEventChannelAdmin::NoSuchImplementation, CosNotifyChannelAdmin::AdminLimitExceeded ); }; // TypedSupplierAdmin interface TypedEventChannel : CosNotification::QoSAdmin, CosNotification::AdminPropertiesAdmin, CosTypedEventChannelAdmin::TypedEventChannel { readonly attribute TypedEventChannelFactory MyFactory; readonly attribute TypedConsumerAdmin default_consumer_admin; readonly attribute TypedSupplierAdmin default_supplier_admin; readonly attribute CosNotifyFilter::FilterFactory default_filter_factory; TypedConsumerAdmin new_for_typed_notification_consumers( in CosNotifyChannelAdmin::InterFilterGroupOperator op, out CosNotifyChannelAdmin::AdminID id ); TypedSupplierAdmin new_for_typed_notification_suppliers( in CosNotifyChannelAdmin::InterFilterGroupOperator op, out CosNotifyChannelAdmin::AdminID id ); TypedConsumerAdmin get_consumeradmin ( in CosNotifyChannelAdmin::AdminID id ) raises ( CosNotifyChannelAdmin::AdminNotFound ); TypedSupplierAdmin get_supplieradmin ( in CosNotifyChannelAdmin::AdminID id ) raises ( CosNotifyChannelAdmin::AdminNotFound ); CosNotifyChannelAdmin::AdminIDSeq get_all_consumeradmins(); CosNotifyChannelAdmin::AdminIDSeq get_all_supplieradmins(); }; // TypedEventChannel interface TypedEventChannelFactory { TypedEventChannel create_typed_channel ( in CosNotification::QoSProperties initial_QoS, in CosNotification::AdminProperties initial_admin, out CosNotifyChannelAdmin::ChannelID id) raises( CosNotification::UnsupportedQoS, CosNotification::UnsupportedAdmin ); CosNotifyChannelAdmin::ChannelIDSeq get_all_typed_channels(); TypedEventChannel get_typed_event_channel ( in CosNotifyChannelAdmin::ChannelID id ) raises ( CosNotifyChannelAdmin::ChannelNotFound ); }; // TypedEventChannelFactory }; // CosTypedNotifyChannelAdmin #endif /* _COS_TYPED_NOTIFY_CHANNEL_ADMIN_IDL_ */ polyorb-2.8~20110207.orig/idls/cos/concurrency/0000755000175000017500000000000011750740340020453 5ustar xavierxavierpolyorb-2.8~20110207.orig/idls/cos/concurrency/CosConcurrencyControl.idl0000644000175000017500000000406111750740337025454 0ustar xavierxavier//File: ConcurrencyControl.idl //The only module of the Concurrency Control Service //OMG File: 98-10-04 #ifndef _COS_CONCURRENCY_CONTROL_IDL_ #define _COS_CONCURRENCY_CONTROL_IDL_ #ifdef _PRE_3_0_COMPILER_ #include #pragma prefix "omg.org" #else import ::CosTransactions; #endif // _PRE_3_0_COMPILER_ module CosConcurrencyControl { #ifndef _PRE_3_0_COMPILER_ typeprefix CosConcurrencyControl "omg.org"; #endif // _PRE_3_0_COMPILER_ enum lock_mode { read, write, upgrade, intention_read, intention_write }; exception LockNotHeld{}; interface LockCoordinator { void drop_locks(); }; interface LockSet { void lock(in lock_mode mode); boolean try_lock(in lock_mode mode); void unlock(in lock_mode mode) raises(LockNotHeld); void change_mode(in lock_mode held_mode, in lock_mode new_mode) raises(LockNotHeld); LockCoordinator get_coordinator( in CosTransactions::Coordinator which); }; interface TransactionalLockSet { void lock(in CosTransactions::Coordinator current, in lock_mode mode); boolean try_lock(in CosTransactions::Coordinator current, in lock_mode mode); void unlock(in CosTransactions::Coordinator current, in lock_mode mode) raises(LockNotHeld); void change_mode(in CosTransactions::Coordinator current, in lock_mode held_mode, in lock_mode new_mode) raises(LockNotHeld); LockCoordinator get_coordinator( in CosTransactions::Coordinator which); }; interface LockSetFactory { LockSet create(); LockSet create_related(in LockSet which); TransactionalLockSet create_transactional(); TransactionalLockSet create_transactional_related( in TransactionalLockSet which); }; }; #endif /* ifndef _COS_CONCURRENCY_CONTROL_IDL_ */ polyorb-2.8~20110207.orig/idls/cos/transaction/0000755000175000017500000000000011750740340020446 5ustar xavierxavierpolyorb-2.8~20110207.orig/idls/cos/transaction/CosTSInteroperation.idl0000644000175000017500000000137011750740337025065 0ustar xavierxavier//File: CosTSInteroperation.idl //Part of the Transaction Service #ifndef _COS_TS_INTEROPERATION_IDL_ #define _COS_TS_INTEROPERATION_IDL_ #ifdef _PRE_3_0_COMPILER_ #include #include #include #pragma prefix "omg.org" #else import ::CORBA; import ::IOP; import ::CosTransactions; #endif // _PRE_3_0_COMPILER_ module CosTSInteroperation { #ifndef _PRE_3_0_COMPILER_ typeprefix CosTSInteroperation "omg.org"; #endif // _PRE_3_0_COMPILER_ const IOP::ComponentId TAG_TRANSACTION_POLICY=26; struct TransactionPolicyComponent { CosTransactions::TransactionPolicyValue tpv; }; const IOP::ComponentId TAG_OTS_POLICY= 31; const IOP::ComponentId TAG_INV_POLICY= 32; }; #endif // _COS_TS_INTEROPERATION_IDL_ polyorb-2.8~20110207.orig/idls/cos/transaction/CosTSPortability.idl0000644000175000017500000000215111750740337024363 0ustar xavierxavier//File: CosTSPortability.idl //Part of the Transaction Service #ifndef _COS_TS_PORTABILITY_IDL_ #define _COS_TS_PORTABILITY_IDL_ //Note Even though this module is marked PIDL, it compiles with // an IDL compiler. #ifdef _PRE_3_0_COMPILER_ #include #pragma prefix "omg.org" #else import ::CosTransactions; #endif // _PRE_3_0_COMPILER_ module CosTSPortability { // PIDL #ifndef _PRE_3_0_COMPILER_ typeprefix CosTSPortability "omg.org"; #endif // _PRE_3_0_COMPILER_ typedef long ReqId; //PolyORB:NI: CORBA::Environment not yet implemented //PolyORB:NI: interface Sender { //PolyORB:NI: void sending_request(in ReqId id, //PolyORB:NI: out CosTransactions::PropagationContext ctx); //PolyORB:NI: void received_reply(in ReqId id, //PolyORB:NI: in CosTransactions::PropagationContext ctx, //PolyORB:NI: in CORBA::Environment env); //PolyORB:NI: }; interface Receiver { void received_request(in ReqId id, in CosTransactions::PropagationContext ctx); void sending_reply(in ReqId id, out CosTransactions::PropagationContext ctx); }; }; #endif /* ifndef _COS_TS_PORTABILITY_IDL_ */ polyorb-2.8~20110207.orig/idls/cos/transaction/CosTransactions.idl0000644000175000017500000001546111750740337024272 0ustar xavierxavier//File: CosTransactions.idl //Part of the Transaction Service #ifndef _COS_TRANSACTIONS_IDL_ #define _COS_TRANSACTIONS_IDL_ #ifdef _PRE_3_0_COMPILER_ #include #pragma prefix "omg.org" #else import ::CORBA; #endif // _PRE_3_0_COMPILER_ module CosTransactions { #ifndef _PRE_3_0_COMPILER_ typeprefix CosTransactions "omg.org"; #endif // _PRE_3_0_COMPILER_ // DATATYPES enum Status { StatusActive, StatusMarkedRollback, StatusPrepared, StatusCommitted, StatusRolledBack, StatusUnknown, StatusNoTransaction, StatusPreparing, StatusCommitting, StatusRollingBack }; enum Vote { VoteCommit, VoteRollback, VoteReadOnly }; typedef unsigned short TransactionPolicyValue; // TransactionPolicyValue definitions are deprecated and replaced // // with new InvocationPolicy and OTSPolicy definitions. They are // // retained for backward compatibility. // const TransactionPolicyValue Allows_shared = 0; const TransactionPolicyValue Allows_none = 1; const TransactionPolicyValue Requires_shared = 2; const TransactionPolicyValue Allows_unshared = 3; const TransactionPolicyValue Allows_either = 4; const TransactionPolicyValue Requires_unshared = 5; const TransactionPolicyValue Requires_either = 6; // Forward references for interfaces defined later in module local interface Current; interface TransactionFactory; interface Control; interface Terminator; interface Coordinator; interface RecoveryCoordinator; interface Resource; interface Synchronization; interface SubtransactionAwareResource; // TransactionalObject has been deprecated. interface TransactionalObject; // Structure definitions struct otid_t { long formatID; /*format identifier. 0 is OSI TP */ long bqual_length; sequence tid; }; struct TransIdentity { Coordinator coord; Terminator term; otid_t otid; }; struct PropagationContext { unsigned long timeout; TransIdentity current; sequence parents; any implementation_specific_data; }; // Heuristic exceptions exception HeuristicRollback {}; exception HeuristicCommit {}; exception HeuristicMixed {}; exception HeuristicHazard {}; // Other transaction-specific exceptions exception SubtransactionsUnavailable {}; exception NotSubtransaction {}; exception Inactive {}; exception NotPrepared {}; exception NoTransaction {}; exception InvalidControl {}; exception Unavailable {}; exception SynchronizationUnavailable {}; // Current transaction local interface Current : CORBA::Current { void begin() raises(SubtransactionsUnavailable); void commit(in boolean report_heuristics) raises( NoTransaction, HeuristicMixed, HeuristicHazard ); void rollback() raises(NoTransaction); void rollback_only() raises(NoTransaction); Status get_status(); string get_transaction_name(); void set_timeout(in unsigned long seconds); unsigned long get_timeout (); Control get_control(); Control suspend(); void resume(in Control which) raises(InvalidControl); }; interface TransactionFactory { Control create(in unsigned long time_out); Control recreate(in PropagationContext ctx); }; interface Control { Terminator get_terminator() raises(Unavailable); Coordinator get_coordinator() raises(Unavailable); }; interface Terminator { void commit(in boolean report_heuristics) raises( HeuristicMixed, HeuristicHazard ); void rollback(); }; interface Coordinator { Status get_status(); Status get_parent_status(); Status get_top_level_status(); boolean is_same_transaction(in Coordinator tc); boolean is_related_transaction(in Coordinator tc); boolean is_ancestor_transaction(in Coordinator tc); boolean is_descendant_transaction(in Coordinator tc); boolean is_top_level_transaction(); unsigned long hash_transaction(); unsigned long hash_top_level_tran(); RecoveryCoordinator register_resource(in Resource r) raises(Inactive); void register_synchronization (in Synchronization sync) raises(Inactive, SynchronizationUnavailable); void register_subtran_aware(in SubtransactionAwareResource r) raises(Inactive, NotSubtransaction); void rollback_only() raises(Inactive); string get_transaction_name(); Control create_subtransaction() raises(SubtransactionsUnavailable, Inactive); PropagationContext get_txcontext () raises(Unavailable); }; interface RecoveryCoordinator { Status replay_completion(in Resource r) raises(NotPrepared); }; interface Resource { Vote prepare() raises( HeuristicMixed, HeuristicHazard ); void rollback() raises( HeuristicCommit, HeuristicMixed, HeuristicHazard ); void commit() raises( NotPrepared, HeuristicRollback, HeuristicMixed, HeuristicHazard ); void commit_one_phase() raises( HeuristicHazard ); void forget(); }; // TransactionalObject has been deprecated // and replaced by the OTSPolicy component // Synchronization will use the OTSPolicy of ADAPTS // Inheritance from TransactionalObject is for backward compatability/ //PolyORB:WACORBA: TransactionalObject moved before first use of it // TransactionalObject has been deprecated. interface TransactionalObject { }; //PolyORB:WACORBA: interface Synchronization : TransactionalObject { void before_completion(); void after_completion(in Status s); }; interface SubtransactionAwareResource : Resource { void commit_subtransaction(in Coordinator parent); void rollback_subtransaction(); }; //PolyORB:WACORBA:// TransactionalObject has been deprecated. //PolyORB:WACORBA:interface TransactionalObject { //PolyORB:WACORBA:}; // TransactionPolicyType is deprecated and replaced // by InvocationPolicyType and OTSPolicyType // It is retained for backward compatibility. //PolyORB:WACORBA: This is duplicate declaration of TransactionPolicyValue //PolyORB:WACORBA:typedef unsigned short TransactionPolicyValue; const CORBA::PolicyType TransactionPolicyType = 46; interface TransactionPolicy : CORBA::Policy { readonly attribute TransactionPolicyValue tpv; }; typedef unsigned short InvocationPolicyValue; const InvocationPolicyValue EITHER = 0; const InvocationPolicyValue SHARED = 1; const InvocationPolicyValue UNSHARED =2; typedef unsigned short OTSPolicyValue; const OTSPolicyValue REQUIRES = 1; const OTSPolicyValue FORBIDS =2; const OTSPolicyValue ADAPTS =3; typedef unsigned short NonTxTargetPolicyValue; const NonTxTargetPolicyValue PREVENT = 0; const NonTxTargetPolicyValue PERMIT = 1; const CORBA::PolicyType INVOCATION_POLICY_TYPE = 55; interface InvocationPolicy : CORBA::Policy { readonly attribute InvocationPolicyValue ipv; }; const CORBA::PolicyType OTS_POLICY_TYPE = 56; interface OTSPolicy : CORBA::Policy { readonly attribute OTSPolicyValue tpv; }; // Deprecated const CORBA::PolicyType NON_TX_TARGET_POLICY_TYPE = 57; // Deprecated interface NonTxTargetPolicy : CORBA::Policy { readonly attribute NonTxTargetPolicyValue tpv; }; }; // End of CosTransactions Module #endif /* ifndef _COS_TRANSACTIONS_IDL_ */ polyorb-2.8~20110207.orig/idls/cos/relationship/0000755000175000017500000000000011750740340020622 5ustar xavierxavierpolyorb-2.8~20110207.orig/idls/cos/relationship/CosReference.idl0000644000175000017500000000112411750740337023663 0ustar xavierxavier//File: CosReference.idl //Part of the Relationship Service //OMG File: 98-10-34 #ifndef _COS_REFERENCE_IDL_ #define _COS_REFERENCE_IDL_ #ifdef _PRE_3_0_COMPILER_ #include #pragma prefix "omg.org" #else import ::CosGraphs; #endif // _PRE_3_0_COMPILER_ module CosReference { #ifndef _PRE_3_0_COMPILER_ typeprefix CosReference "omg.org"; #endif // _PRE_3_0_COMPILER_ interface Relationship : CosRelationships::Relationship {}; interface ReferencesRole : CosGraphs::Role {}; interface ReferencedByRole : CosGraphs::Role {}; }; #endif /* ifndef _COS_REFERENCE_IDL_ */ polyorb-2.8~20110207.orig/idls/cos/relationship/CosRelationships.idl0000644000175000017500000000740011750740337024614 0ustar xavierxavier//File: CosRelationships.idl //Part of the Relationship Service //OMG File: 98-10-35 #ifndef _COS_RELATIONSHIPS_IDL_ #define _COS_RELATIONSHIPS_IDL_ #ifdef _PRE_3_0_COMPILER_ #include #include #pragma prefix "omg.org" #else import ::CORBA; import ::CosObjectIdentity; #endif // _PRE_3_0_COMPILER_ module CosRelationships { #ifndef _PRE_3_0_COMPILER_ typeprefix CosRelationships "omg.org"; #endif // _PRE_3_0_COMPILER_ interface RoleFactory; interface RelationshipFactory; interface Relationship; interface Role; interface RelationshipIterator; typedef Object RelatedObject; typedef sequence Roles; typedef string RoleName; typedef sequence RoleNames; struct NamedRole {RoleName name; Role aRole;}; typedef sequence NamedRoles; struct RelationshipHandle { Relationship the_relationship; CosObjectIdentity::ObjectIdentifier constant_random_id; }; typedef sequence RelationshipHandles; interface RelationshipFactory { struct NamedRoleType { RoleName name; CORBA::InterfaceDef named_role_type; }; typedef sequence NamedRoleTypes; readonly attribute CORBA::InterfaceDef relationship_type; readonly attribute unsigned short degree; readonly attribute NamedRoleTypes named_role_types; exception RoleTypeError {NamedRoles culprits;}; exception MaxCardinalityExceeded { NamedRoles culprits;}; exception DegreeError {unsigned short required_degree;}; exception DuplicateRoleName {NamedRoles culprits;}; exception UnknownRoleName {NamedRoles culprits;}; Relationship create (in NamedRoles named_roles) raises (RoleTypeError, MaxCardinalityExceeded, DegreeError, UnknownRoleName); }; interface Relationship : CosObjectIdentity::IdentifiableObject { exception CannotUnlink { Roles offending_roles; }; readonly attribute NamedRoles named_roles; void destroy () raises(CannotUnlink); }; interface Role { exception UnknownRoleName {}; exception UnknownRelationship {}; exception RelationshipTypeError {}; exception CannotDestroyRelationship { RelationshipHandles offenders; }; exception ParticipatingInRelationship { RelationshipHandles the_relationships; }; readonly attribute RelatedObject related_object; RelatedObject get_other_related_object ( in RelationshipHandle rel, in RoleName target_name) raises (UnknownRoleName, UnknownRelationship); Role get_other_role (in RelationshipHandle rel, in RoleName target_name) raises (UnknownRoleName, UnknownRelationship); void get_relationships ( in unsigned long how_many, out RelationshipHandles rels, out RelationshipIterator iterator); void destroy_relationships() raises(CannotDestroyRelationship); void destroy() raises(ParticipatingInRelationship); boolean check_minimum_cardinality (); void link (in RelationshipHandle rel, in NamedRoles named_roles) raises( RelationshipFactory::MaxCardinalityExceeded, RelationshipTypeError); void unlink (in RelationshipHandle rel) raises (UnknownRelationship); }; interface RoleFactory { exception NilRelatedObject {}; exception RelatedObjectTypeError {}; readonly attribute CORBA::InterfaceDef role_type; readonly attribute unsigned long max_cardinality; readonly attribute unsigned long min_cardinality; typedef sequence InterfaceDefs; readonly attribute InterfaceDefs related_object_types; Role create_role (in RelatedObject related_object) raises (NilRelatedObject, RelatedObjectTypeError); }; interface RelationshipIterator { boolean next_one (out RelationshipHandle rel); boolean next_n (in unsigned long how_many, out RelationshipHandles rels); void destroy (); }; }; #endif /* ifndef _COS_RELATIONSHIPS_IDL_ */ polyorb-2.8~20110207.orig/idls/cos/relationship/CosObjectIdentity.idl0000644000175000017500000000115711750740337024713 0ustar xavierxavier//File: CosObjectIdentity.idl //Part of the Relationship Service //OMG File: 98-10-33 #ifndef _COS_OBJECT_IDENTITY_IDL_ #define _COS_OBJECT_IDENTITY_IDL_ #ifdef _PRE_3_0_COMPILER_ #pragma prefix "omg.org" #endif // _PRE_3_0_COMPILER_ module CosObjectIdentity { #ifndef _PRE_3_0_COMPILER_ typeprefix CosObjectIdentity "omg.org"; #endif // _PRE_3_0_COMPILER_ typedef unsigned long ObjectIdentifier; interface IdentifiableObject { readonly attribute ObjectIdentifier constant_random_id; boolean is_identical ( in IdentifiableObject other_object); }; }; #endif /* ifndef _COS_OBJECT_IDENTITY_IDL_ */ polyorb-2.8~20110207.orig/idls/cos/relationship/CosContainment.idl0000644000175000017500000000113711750740337024250 0ustar xavierxavier//File: CosContainment.idl //Part of the Externalization Service //OMG File: 98-10-31 #ifndef _COS_CONTAINMENT_IDL_ #define _COS_CONTAINMENT_IDL_ #ifdef _PRE_3_0_COMPILER_ #include #pragma prefix "omg.org" #else import ::CosGraphs; #endif // _PRE_3_0_COMPILER_ module CosContainment { #ifndef _PRE_3_0_COMPILER_ typeprefix CosContainment "omg.org"; #endif // _PRE_3_0_COMPILER_ interface Relationship : CosRelationships::Relationship {}; interface ContainsRole : CosGraphs::Role {}; interface ContainedInRole : CosGraphs::Role {}; }; #endif /* ifndef _COS_CONTAINMENT_IDL_ */ polyorb-2.8~20110207.orig/idls/cos/relationship/CosGraphs.idl0000644000175000017500000000664711750740337023230 0ustar xavierxavier//File: CosGraphs.idl //Part of the Relationship Service //OMG File: 98-10-32 #ifndef _COS_GRAPHS_IDL_ #define _COS_GRAPHS_IDL_ #ifdef _PRE_3_0_COMPILER_ #include #include #include #pragma prefix "omg.org" #else import ::CORBA; import ::CosRelationships; import ::CosObjectIdentity; #endif // _PRE_3_0_COMPILER_ module CosGraphs { #ifndef _PRE_3_0_COMPILER_ typeprefix CosGraphs "omg.org"; #endif // _PRE_3_0_COMPILER_ interface TraversalFactory; interface Traversal; interface TraversalCriteria; interface Node; interface NodeFactory; interface Role; interface EdgeIterator; struct NodeHandle { Node the_node; CosObjectIdentity::ObjectIdentifier constant_random_id; }; typedef sequence NodeHandles; struct NamedRole { Role the_role; CosRelationships::RoleName the_name; }; typedef sequence NamedRoles; struct EndPoint { NodeHandle the_node; NamedRole the_role; }; typedef sequence EndPoints; struct Edge { EndPoint from; CosRelationships::RelationshipHandle the_relationship; EndPoints relatives; }; typedef sequence Edges; enum PropagationValue {deep, shallow, none, inhibit}; enum Mode {depthFirst, breadthFirst, bestFirst}; interface TraversalFactory { Traversal create_traversal_on ( in NodeHandle root_node, in TraversalCriteria the_criteria, in Mode how); }; interface Traversal { typedef unsigned long TraversalScopedId; struct ScopedEndPoint { EndPoint point; TraversalScopedId id; }; typedef sequence ScopedEndPoints; struct ScopedRelationship { CosRelationships::RelationshipHandle scoped_relationship; TraversalScopedId id; }; struct ScopedEdge { ScopedEndPoint from; ScopedRelationship the_relationship; ScopedEndPoints relatives; }; typedef sequence ScopedEdges; boolean next_one (out ScopedEdge the_edge); boolean next_n (in short how_many, out ScopedEdges the_edges); void destroy (); }; interface TraversalCriteria { struct WeightedEdge { Edge the_edge; unsigned long weight; sequence next_nodes; }; typedef sequence WeightedEdges; void visit_node(in NodeHandle a_node, in Mode search_mode); boolean next_one (out WeightedEdge the_edge); boolean next_n (in short how_many, out WeightedEdges the_edges); void destroy(); }; interface Node: CosObjectIdentity::IdentifiableObject { typedef sequence Roles; exception NoSuchRole {}; exception DuplicateRoleType {}; readonly attribute CosRelationships::RelatedObject related_object; readonly attribute Roles roles_of_node; Roles roles_of_type ( in CORBA::InterfaceDef role_type); void add_role (in Role a_role) raises (DuplicateRoleType); void remove_role (in CORBA::InterfaceDef of_type) raises (NoSuchRole); }; interface NodeFactory { Node create_node (in Object related_object); }; interface Role : CosRelationships::Role { void get_edges ( in long how_many, out Edges the_edges, out EdgeIterator the_rest); }; interface EdgeIterator { boolean next_one (out Edge the_edge); boolean next_n ( in unsigned long how_many, out Edges the_edges); void destroy (); }; }; #endif /* ifndef _COS_GRAPHS_IDL_ */ polyorb-2.8~20110207.orig/idls/cos/persistent/0000755000175000017500000000000011750740340020321 5ustar xavierxavierpolyorb-2.8~20110207.orig/idls/cos/persistent/cospersistencepom.idl0000644000175000017500000000126011750740337024565 0ustar xavierxavier//File: CosPersistencePOM.idl //Part of the Persistence Service #ifndef _COS_PERSISTENCE_POM_IDL_ #define _COS_PERSISTENCE_POM_IDL_ #include #pragma prefix "omg.org" module CosPersistencePOM { interface POM { CosPersistencePDS::PDS connect ( in Object obj, in CosPersistencePID::PID p); void disconnect ( in Object obj, in CosPersistencePID::PID p); void store ( in Object obj, in CosPersistencePID::PID p); void restore ( in Object obj, in CosPersistencePID::PID p); void delete ( in Object obj, in CosPersistencePID::PID p); }; }; #endif /* ifndef _COS_PERSISTENCE_POM_IDL_ */ polyorb-2.8~20110207.orig/idls/cos/persistent/cospersistencepds.idl0000644000175000017500000000124611750740337024564 0ustar xavierxavier//File: CosPersistencePDS.idl //Part of the Persistence Service #ifndef _COS_PERSISTENCE_PDS_IDL_ #define _COS_PERSISTENCE_PDS_IDL_ #pragma prefix "omg.org" #include #pragma prefix "omg.org" module CosPersistencePDS { interface PDS { PDS connect (in Object obj, in CosPersistencePID::PID p); void disconnect (in Object obj, in CosPersistencePID::PID p); void store (in Object obj, in CosPersistencePID::PID p); void restore (in Object obj, in CosPersistencePID::PID p); void delete (in Object obj, in CosPersistencePID::PID p); }; }; #endif /* ifndef _COS_PERSISTENCE_PDS_IDL_ */ polyorb-2.8~20110207.orig/idls/cos/persistent/cospersistenceddo.idl0000644000175000017500000000167611750740337024553 0ustar xavierxavier//File: CosPersistenceDDO.idl //Part of the Persistence Service #ifndef _COS_PERSISTENCE_DDO_IDL_ #define _COS_PERSISTENCE_DDO_IDL_ #include #pragma prefix "omg.org" module CosPersistenceDDO { interface DDO { attribute string object_type; attribute CosPersistencePID::PID p; short add_data(); short add_data_property (in short data_id); short get_data_count(); short get_data_property_count (in short data_id); void get_data_property (in short data_id, in short property_id, out string property_name, out any property_value); void set_data_property (in short data_id, in short property_id, in string property_name, in any property_value); void get_data (in short data_id, out string data_name, out any data_value); void set_data (in short data_id, in string data_name, in any data_value); }; }; #endif /* ifndef _COS_PERSISTENCE_DDO_IDL_ */ polyorb-2.8~20110207.orig/idls/cos/persistent/cospersistencepid.idl0000644000175000017500000000051711750740337024552 0ustar xavierxavier//File: CosPersistencePID.idl //Part of the Persistence Service #ifndef _COS_PERSISTENCE_PID_IDL_ #define _COS_PERSISTENCE_PID_IDL_ #pragma prefix "omg.org" module CosPersistencePID { interface PID { attribute string datastore_type; string get_PIDString(); }; }; #endif /* ifndef _COS_PERSISTENCE_PID_IDL_ */ polyorb-2.8~20110207.orig/idls/cos/persistent/cospersistencepds_da.idl0000644000175000017500000000173111750740337025227 0ustar xavierxavier//File: CosPersistencePDS_DA.idl //Part of the Persistence Service #ifndef _COS_PERSISTENCE_PDS_DA_IDL_ #define _COS_PERSISTENCE_PDS_DA_IDL_ #include #pragma prefix "omg.org" module CosPersistencePDS_DA { typedef string DAObjectID; interface PID_DA : CosPersistencePID::PID { attribute DAObjectID oid; }; interface DAObject { boolean dado_same(in DAObject d); DAObjectID dado_oid(); PID_DA dado_pid(); void dado_remove(); void dado_free(); }; interface DAObjectFactory { DAObject create(); }; interface DAObjectFactoryFinder { DAObjectFactory find_factory(in string key); }; interface PDS_DA : CosPersistencePDS::PDS { DAObject get_data(); void set_data(in DAObject new_data); DAObject lookup(in DAObjectID id); PID_DA get_pid(); PID_DA get_object_pid(in DAObject dao); DAObjectFactoryFinder data_factories(); }; }; #endif /* ifndef _COS_PERSISTENCE_PDS_DA_IDL_ */ polyorb-2.8~20110207.orig/idls/cos/persistent/cospersistencepo.idl0000644000175000017500000000123411750740337024411 0ustar xavierxavier//File: CosPersistencePO.idl //Part of the Persistence Service #ifndef _COS_PERSISTENCE_PO_IDL_ #define _COS_PERSISTENCE_PO_IDL_ #include #pragma prefix "omg.org" module CosPersistencePO { interface PO { attribute CosPersistencePID::PID p; CosPersistencePDS::PDS connect ( in CosPersistencePID::PID p); void disconnect (in CosPersistencePID::PID p); void store (in CosPersistencePID::PID p); void restore (in CosPersistencePID::PID p); void delete (in CosPersistencePID::PID p); }; interface SD { void pre_store(); void post_restore(); }; }; #endif /* ifndef _COS_PERSISTENCE_PO_IDL_ */ polyorb-2.8~20110207.orig/idls/cos/persistent/cospersistenceds_cli.idl0000644000175000017500000000426411750740337025236 0ustar xavierxavier//File: CosPersistenceDS_CLI.idl //Part of the Persistence Service #ifndef _COS_PERSISTENCE_DS_CLI_IDL_ #define _COS_PERSISTENCE_DS_CLI_IDL_ #include #pragma prefix "omg.org" module CosPersistenceDS_CLI { interface UserEnvironment { void set_option (in long option,in any value); void get_option (in long option,out any value); void release(); }; interface Connection { void set_option (in long option,in any value); void get_option (in long option,out any value); }; interface ConnectionFactory { Connection create_object ( in UserEnvironment user_envir); }; interface Cursor { void set_position (in long position,in any value); CosPersistenceDDO::DDO fetch_object(); }; interface CursorFactory { Cursor create_object ( in Connection a_connection); }; interface PID_CLI : CosPersistencePID::PID { attribute string datastore_id; attribute string id; }; interface Datastore_CLI { void connect (in Connection a_connection, in string datastore_id, in string user_name, in string authentication); void disconnect (in Connection a_connection); Connection get_connection ( in string datastore_id, in string user_name); void add_object (in Connection a_connection, in CosPersistenceDDO::DDO data_obj); void delete_object ( in Connection a_connection, in CosPersistenceDDO::DDO data_obj); void update_object ( in Connection a_connection, in CosPersistenceDDO::DDO data_obj); void retrieve_object( in Connection a_connection, in CosPersistenceDDO::DDO data_obj); Cursor select_object( in Connection a_connection, in string key); void transact (in UserEnvironment user_envir, in short completion_type); void assign_PID (in PID_CLI p); void assign_PID_relative ( in PID_CLI source_pid, in PID_CLI target_pid); boolean is_identical_PID ( in PID_CLI pid_1, in PID_CLI pid_2); string get_object_type (in PID_CLI p); void register_mapping_schema (in string schema_file); Cursor execute (in Connection a_connection, in string command); }; }; #endif /* ifndef _COS_PERSISTENCE_DS_CLI_IDL_ */ polyorb-2.8~20110207.orig/idls/cos/query/0000755000175000017500000000000011750740340017266 5ustar xavierxavierpolyorb-2.8~20110207.orig/idls/cos/query/CosQuery.idl0000644000175000017500000000340311750740337021540 0ustar xavierxavier//File: CosQuery.idl //Part of the Query Service //OMG File: 98-10-29 #ifndef _COS_QUERY_IDL_ #define _COS_QUERY_IDL_ #ifdef _PRE_3_0_COMPILER_ #include #include #pragma prefix "omg.org" #else import ::CORBA; import ::CosQueryCollection; #endif // _PRE_3_0_COMPILER_ module CosQuery { #ifndef _PRE_3_0_COMPILER_ typeprefix CosQuery "omg.org"; #endif // _PRE_3_0_COMPILER_ exception QueryInvalid {string why;}; exception QueryProcessingError {string why;}; exception QueryTypeInvalid {}; enum QueryStatus {complete, incomplete}; typedef CosQueryCollection::ParameterList ParameterList; typedef CORBA::InterfaceDef QLType; interface Query; interface QueryLanguageType {}; interface SQLQuery : QueryLanguageType {}; interface SQL_92Query : SQLQuery {}; interface OQL : QueryLanguageType {}; interface OQLBasic : OQL {}; interface OQL_93 : OQL {}; interface OQL_93Basic : OQL_93, OQLBasic {}; interface QueryEvaluator { typedef sequence QLTypes; readonly attribute QLTypes ql_types; readonly attribute QLType default_ql_type; any evaluate (in string query, in QLType ql_type, in ParameterList params) raises(QueryTypeInvalid, QueryInvalid, QueryProcessingError); }; interface QueryableCollection : QueryEvaluator, CosQueryCollection::Collection {}; interface QueryManager : QueryEvaluator { Query create (in string query, in QLType ql_type, in ParameterList params) raises(QueryTypeInvalid, QueryInvalid); }; interface Query { readonly attribute QueryManager query_mgr; void prepare (in ParameterList params) raises(QueryProcessingError); void execute (in ParameterList params) raises(QueryProcessingError); QueryStatus get_status (); any get_result (); }; }; #endif /* ifndef _COS_QUERY_IDL_ */ polyorb-2.8~20110207.orig/idls/cos/query/CosQueryCollection.idl0000644000175000017500000000647611750740337023571 0ustar xavierxavier//File: CosQueryCollection.idl //Part of the Query Service // Note: if your IDL compiler does not yet support the // CORBA 2.3 Feature "Escaped Identifiers" (which provides // for the addition of new keywords to IDL, compile this // module with the preprocessor definition // "NO_ESCAPED_IDENTIFIERS". With many compilers this // would be done a qualifier on the command line, // something like -DNO_ESCAPED_IDENTIFIERS //OMG File: 98-10-30 #ifndef _COS_QUERY_COLLECTION_IDL_ #define _COS_QUERY_COLLECTION_IDL_ #ifdef _PRE_3_0_COMPILER_ #pragma prefix "omg.org" #endif // _PRE_3_0_COMPILER_ module CosQueryCollection { #ifndef _PRE_3_0_COMPILER_ typeprefix CosQueryCollection "omg.org"; #endif // _PRE_3_0_COMPILER_ exception ElementInvalid {}; exception IteratorInvalid {}; exception PositionInvalid {}; #ifdef NO_ESCAPED_IDENTIFIERS enum ValueType {TypeBoolean, TypeChar, TypeOctet, TypeShort, TypeUShort, TypeLong, TypeULong, TypeFloat, TypeDouble, TypeString, TypeObject, TypeAny, TypeSmallInt, TypeInteger, TypeReal, TypeDoublePrecision, TypeCharacter, TypeDecimal, TypeNumeric}; #else enum _ValueType {TypeBoolean, TypeChar, TypeOctet, TypeShort, TypeUShort, TypeLong, TypeULong, TypeFloat, TypeDouble, TypeString, TypeObject, TypeAny, TypeSmallInt, TypeInteger, TypeReal, TypeDoublePrecision, TypeCharacter, TypeDecimal, TypeNumeric}; #endif struct Decimal { long precision; long scale; sequence value; }; #ifdef NO_ESCAPED_IDENTIFIERS union Value switch(ValueType) { #else union _Value switch(_ValueType) { #endif case TypeBoolean : boolean b; case TypeChar : char c; case TypeOctet : octet o; case TypeShort : short s; case TypeUShort : unsigned short us; case TypeLong : long l; case TypeULong : unsigned long ul; case TypeFloat : float f; case TypeDouble : double d; case TypeString : string str; case TypeObject : Object obj; case TypeAny : any a; case TypeSmallInt : short si; case TypeInteger : long i; case TypeReal : float r; case TypeDoublePrecision : double dp; case TypeCharacter : string ch; case TypeDecimal : Decimal dec; case TypeNumeric : Decimal n; }; typedef boolean Null; union FieldValue switch(Null) { case FALSE : Value v; }; typedef sequence Record; typedef string Istring; struct NVPair {Istring name; any value;}; typedef sequence ParameterList; interface Collection; interface Iterator; interface CollectionFactory { Collection create (in ParameterList params); }; interface Collection { readonly attribute long cardinality; void add_element (in any element) raises(ElementInvalid); void add_all_elements (in Collection elements) raises(ElementInvalid); void insert_element_at (in any element, in Iterator where) raises(IteratorInvalid, ElementInvalid); void replace_element_at (in any element, in Iterator where) raises(IteratorInvalid, PositionInvalid, ElementInvalid); void remove_element_at (in Iterator where) raises(IteratorInvalid, PositionInvalid); void remove_all_elements (); any retrieve_element_at (in Iterator where) raises(IteratorInvalid, PositionInvalid); Iterator create_iterator (); }; interface Iterator { any next () raises(IteratorInvalid, PositionInvalid); void reset (); boolean more (); }; }; #endif /* ifndef _COS_QUERY_COLLECTION_IDL_ */ polyorb-2.8~20110207.orig/idls/cos/externalization/0000755000175000017500000000000011750740340021341 5ustar xavierxavierpolyorb-2.8~20110207.orig/idls/cos/externalization/CosStream.idl0000644000175000017500000000756711750740337023760 0ustar xavierxavier//File: CosStream.idl //Part of the Externalization Service // Modified from version 1.0 to include the previous CosCompoundExternalization module //OMG File: 98-10-12 #ifndef _COS_STREAM_IDL_ #define _COS_STREAM_IDL_ #ifdef _PRE_3_0_COMPILER_ #include #include #include #pragma prefix "omg.org" #else import ::CosLifeCycle; import ::CosObjectIdentity; import ::CosGraphs; #endif // _PRE_3_0_COMPILER_ module CosStream { #ifndef _PRE_3_0_COMPILER_ typeprefix CosStream "omg.org"; #endif // _PRE_3_0_COMPILER_ exception ObjectCreationError{}; exception StreamDataFormatError{}; interface StreamIO; interface Node; interface Role; interface Relationship; interface Streamable: CosObjectIdentity::IdentifiableObject { readonly attribute CosLifeCycle::Key external_form_id; void externalize_to_stream( in StreamIO targetStreamIO); void internalize_from_stream( in StreamIO sourceStreamIO, in CosLifeCycle::FactoryFinder there) raises( CosLifeCycle::NoFactory, ObjectCreationError, StreamDataFormatError ); }; interface StreamableFactory { Streamable create_uninitialized(); }; interface StreamIO { void write_string(in string aString); void write_char(in char aChar); void write_octet(in octet anOctet); void write_unsigned_long( in unsigned long anUnsignedLong); void write_unsigned_short( in unsigned short anUnsignedShort); void write_long(in long aLong); void write_short(in short aShort); void write_float(in float aFloat); void write_double(in double aDouble); void write_boolean(in boolean aBoolean); void write_object(in Streamable aStreamable); void write_graph(in Node aNode); string read_string() raises(StreamDataFormatError); char read_char() raises(StreamDataFormatError ); octet read_octet() raises(StreamDataFormatError ); unsigned long read_unsigned_long() raises(StreamDataFormatError ); unsigned short read_unsigned_short() raises( StreamDataFormatError ); long read_long() raises(StreamDataFormatError ); short read_short() raises(StreamDataFormatError ); float read_float() raises(StreamDataFormatError ); double read_double() raises(StreamDataFormatError ); boolean read_boolean() raises(StreamDataFormatError ); Streamable read_object( in CosLifeCycle::FactoryFinder there, in Streamable aStreamable) raises(StreamDataFormatError ); void read_graph( in Node starting_node, in CosLifeCycle::FactoryFinder there) raises(StreamDataFormatError ); }; // the following are required for compound externalization struct RelationshipHandle { CosRelationships::Relationship theRelationship; CosObjectIdentity::ObjectIdentifier constantRandomId; }; interface Node : CosGraphs::Node, CosStream::Streamable{ void externalize_node (in CosStream::StreamIO sio); void internalize_node (in CosStream::StreamIO sio, in CosLifeCycle::FactoryFinder there, out Roles rolesOfNode) raises ( CosLifeCycle::NoFactory); }; interface Role : CosGraphs::Role { void externalize_role (in CosStream::StreamIO sio); void internalize_role (in CosStream::StreamIO sio); CosGraphs::PropagationValue externalize_propagation ( in RelationshipHandle rel, in CosRelationships::RoleName toRoleName, out boolean sameForAll); }; interface Relationship : CosRelationships::Relationship { void externalize_relationship ( in CosStream::StreamIO sio); void internalize_relationship( in CosStream::StreamIO sio, in CosGraphs::NamedRoles newRoles); CosGraphs::PropagationValue externalize_propagation ( in CosRelationships::RoleName fromRoleName, in CosRelationships::RoleName toRoleName, out boolean sameForAll); }; interface PropagationCriteriaFactory { CosGraphs::TraversalCriteria create_for_externalize( ); }; }; #endif /* ifndef _COS_STREAM_IDL_ */ polyorb-2.8~20110207.orig/idls/cos/externalization/CosExternalizationContainment.idl0000644000175000017500000000166711750740337030100 0ustar xavierxavier//File: CosExternalizationContainment.idl //Part of the Externalization Service // modified from version 1.0 to use CosStream module // instead of CosCompoundExternalization //OMG File: 98-10-10 #ifndef _COS_EXTERNALIZATION_CONTAINMENT_IDL_ #define _COS_EXTERNALIZATION_CONTAINMENT_IDL_ #ifdef _PRE_3_0_COMPILER_ #include #include #pragma prefix "omg.org" #else import ::CosContainment; import ::CosStream; #endif // _PRE_3_0_COMPILER_ module CosExternalizationContainment { #ifndef _PRE_3_0_COMPILER_ typeprefix CosExternalizationContainment "omg.org"; #endif // _PRE_3_0_COMPILER_ interface Relationship : CosStream::Relationship, CosContainment::Relationship {}; interface ContainsRole : CosStream::Role, CosContainment::ContainsRole {}; interface ContainedInRole : CosStream::Role, CosContainment::ContainedInRole {}; }; #endif /* ifndef _COS_EXTERNALIZATION_CONTAINMENT_IDL_*/ polyorb-2.8~20110207.orig/idls/cos/externalization/CosExternalization.idl0000644000175000017500000000215011750740337025664 0ustar xavierxavier//File: CosExternalization.idl //Part of the Externalization Service //OMG File: 98-10-09 #ifndef _COS_EXTERNALIZATION_IDL_ #define _COS_EXTERNALIZATION_IDL_ #ifdef _PRE_3_0_COMPILER_ #include #include #pragma prefix "omg.org" #else import ::CosLifeCycle; import ::CosStream; #endif // _PRE_3_0_COMPILER_ module CosExternalization { #ifndef _PRE_3_0_COMPILER_ typeprefix CosExternalization "omg.org"; #endif // _PRE_3_0_COMPILER_ exception InvalidFileNameError{}; exception ContextAlreadyRegistered{}; interface Stream: CosLifeCycle::LifeCycleObject{ void externalize( in CosStream::Streamable theObject); CosStream::Streamable internalize( in CosLifeCycle::FactoryFinder there) raises( CosLifeCycle::NoFactory, CosStream::StreamDataFormatError ); void begin_context() raises( ContextAlreadyRegistered); void end_context(); void flush(); }; interface StreamFactory { Stream create(); }; interface FileStreamFactory { Stream create( in string theFileName) raises( InvalidFileNameError ); }; }; #endif /* ifndef _COS_EXTERNALIZATION_IDL_ */ polyorb-2.8~20110207.orig/idls/cos/externalization/CosExternalizationReference.idl0000644000175000017500000000164711750740337027515 0ustar xavierxavier//File: CosExternalizationReference.idl //Part of the Externalization Service // modified from version 1.0 to use CosStream module // instead of CosCompoundExternalization //OMG File: 98-10-11 #ifndef _COS_EXTERNALIZATION_REFERENCE_IDL_ #define _COS_EXTERNALIZATION_REFERENCE_IDL_ #ifdef _PRE_3_0_COMPILER_ #include #include #pragma prefix "omg.org" #else import ::CosReference; import ::CosStream; #endif // _PRE_3_0_COMPILER_ module CosExternalizationReference { #ifndef _PRE_3_0_COMPILER_ typeprefix CosExternalizationReference "omg.org"; #endif // _PRE_3_0_COMPILER_ interface Relationship : CosStream::Relationship, CosReference::Relationship {}; interface ReferencesRole : CosStream::Role, CosReference::ReferencesRole {}; interface ReferencedByRole : CosStream::Role, CosReference::ReferencedByRole {}; }; #endif /* ifndef _COS_EXTERNALIZATION_REFERENCE_IDL_ */ polyorb-2.8~20110207.orig/idls/cos/collection/0000755000175000017500000000000011750740340020254 5ustar xavierxavierpolyorb-2.8~20110207.orig/idls/cos/collection/CosCollection.idl0000644000175000017500000007477611750740337023541 0ustar xavierxavier//File: CosCollection.idl //This is the single module for the Collection Service //OMG File: 98-10-03 #ifndef _COS_COLLECTION_IDL_ #define _COS_COLLECTION_IDL_ #ifdef _PRE_3_0_COMPILER_ #include #pragma prefix "omg.org" #else import ::CORBA; #endif // _PRE_3_0_COMPILER_ module CosCollection { #ifndef _PRE_3_0_COMPILER_ typeprefix CosCollection "omg.org"; #endif // _PRE_3_0_COMPILER_ interface Collection; // T y p e d e f i n i t i o n s typedef sequence AnySequence; typedef string Istring; struct NVPair { Istring name; any value; }; typedef sequence ParameterList; // E x c e p t i o n s exception EmptyCollection{}; exception PositionInvalid{}; enum IteratorInvalidReason {is_invalid, is_not_for_collection, is_const}; exception IteratorInvalid {IteratorInvalidReason why;}; exception IteratorInBetween{}; enum ElementInvalidReason { element_type_invalid, positioning_property_invalid, element_exists}; exception ElementInvalid {ElementInvalidReason why;}; exception KeyInvalid {}; exception ParameterInvalid {unsigned long which; Istring why;}; // O p e r a t i o n s interface Operations { // e l e m e n t t y p e s p e c i f i c // i n f o r m a t i o n readonly attribute CORBA::TypeCode element_type; boolean check_element_type (in any element); boolean equal (in any element1, in any element2); long compare (in any element1, in any element2); unsigned long hash (in any element, in unsigned long value); // k e y r e t r i e v a l any key (in any element); // k e y t y p e s p e c i f i c // i n f o r m a t i o n readonly attribute CORBA::TypeCode key_type; boolean check_key_type (in any key); boolean key_equal (in any key1, in any key2); long key_compare (in any key1, in any key2); unsigned long key_hash (in any thisKey, in unsigned long value); // d e s t r o y i n g void destroy(); }; interface Command { boolean do_on (in any element); }; interface Comparator { long compare (in any element1, in any element2); }; // Iterators // I t e r a t o r interface Iterator { // m o v i n g i t e r a t o r s boolean set_to_first_element (); boolean set_to_next_element() raises (IteratorInvalid); boolean set_to_next_nth_element (in unsigned long n) raises (IteratorInvalid); // r e t r i e v i n g e l e m e n t s boolean retrieve_element (out any element) raises (IteratorInvalid, IteratorInBetween); boolean retrieve_element_set_to_next ( out any element, out boolean more) raises (IteratorInvalid, IteratorInBetween); boolean retrieve_next_n_elements ( in unsigned long n, out AnySequence result, out boolean more) raises (IteratorInvalid, IteratorInBetween); boolean not_equal_retrieve_element_set_to_next ( in Iterator test, out any element) raises (IteratorInvalid, IteratorInBetween); // r e m o v i n g e l e m e n t s void remove_element() raises (IteratorInvalid, IteratorInBetween); boolean remove_element_set_to_next() raises (IteratorInvalid, IteratorInBetween); boolean remove_next_n_elements ( in unsigned long n, out unsigned long actual_number) raises (IteratorInvalid, IteratorInBetween); boolean not_equal_remove_element_set_to_next (in Iterator test) raises (IteratorInvalid, IteratorInBetween); // r e p l a c i n g e l e m e n t s void replace_element (in any element) raises (IteratorInvalid, IteratorInBetween, ElementInvalid); boolean replace_element_set_to_next (in any element) raises(IteratorInvalid, IteratorInBetween, ElementInvalid); boolean replace_next_n_elements ( in AnySequence elements, out unsigned long actual_number) raises (IteratorInvalid, IteratorInBetween, ElementInvalid); boolean not_equal_replace_element_set_to_next ( in Iterator test, in any element) raises(IteratorInvalid, IteratorInBetween, ElementInvalid); // a d d i n g e l e m e n t s boolean add_element_set_iterator (in any element)raises (ElementInvalid); boolean add_n_elements_set_iterator ( in AnySequence elements, out unsigned long actual_number) raises (ElementInvalid); // s e t t i n g i t e r a t o r s t a t e void invalidate (); // t e s t i n g i t e r a t o r s boolean is_valid (); boolean is_in_between (); boolean is_for(in Collection collector); boolean is_const (); boolean is_equal (in Iterator test) raises (IteratorInvalid); // c l o n i n g , a s s i g n i n g , // d e s t r o y i n g i t e r a t o r s Iterator clone (); void assign (in Iterator from_where) raises (IteratorInvalid); void destroy (); }; // O r d e r e d I t e r a t o r interface OrderedIterator: Iterator { // m o v i n g i t e r a t o r s boolean set_to_last_element (); boolean set_to_previous_element() raises (IteratorInvalid); boolean set_to_nth_previous_element(in unsigned long n) raises (IteratorInvalid); void set_to_position (in unsigned long position) raises (PositionInvalid); // c o m p u t i n g i t e r a t o r p o s i t i o n unsigned long position () raises (IteratorInvalid); // r e t r i e v i n g e l e m e n t s boolean retrieve_element_set_to_previous( out any element, out boolean more) raises (IteratorInvalid, IteratorInBetween); boolean retrieve_previous_n_elements ( in unsigned long n, out AnySequence result, out boolean more) raises (IteratorInvalid, IteratorInBetween); boolean not_equal_retrieve_element_set_to_previous ( in Iterator test, out any element) raises (IteratorInvalid, IteratorInBetween); // r e m o v i n g e l e m e n t s boolean remove_element_set_to_previous() raises (IteratorInvalid, IteratorInBetween); boolean remove_previous_n_elements ( in unsigned long n, out unsigned long actual_number) raises (IteratorInvalid, IteratorInBetween); boolean not_equal_remove_element_set_to_previous( in Iterator test) raises (IteratorInvalid, IteratorInBetween); // r e p l a c i n g e l e m e n t s boolean replace_element_set_to_previous(in any element) raises (IteratorInvalid, IteratorInBetween, ElementInvalid); boolean replace_previous_n_elements( in AnySequence elements, out unsigned long actual_number) raises (IteratorInvalid, IteratorInBetween, ElementInvalid); boolean not_equal_replace_element_set_to_previous ( in Iterator test, in any element) raises (IteratorInvalid, IteratorInBetween, ElementInvalid); // t e s t i n g i t e r a t o r s boolean is_first (); boolean is_last (); boolean is_for_same (in Iterator test); boolean is_reverse (); }; // S e q u e n t i a l I t e r a t o r interface SequentialIterator : OrderedIterator { // adding elements boolean add_element_as_next_set_iterator (in any element) raises(IteratorInvalid, ElementInvalid); void add_n_elements_as_next_set_iterator( in AnySequence elements) raises(IteratorInvalid, ElementInvalid); boolean add_element_as_previous_set_iterator(in any element) raises(IteratorInvalid, ElementInvalid); void add_n_elements_as_previous_set_iterator( in AnySequence elements) raises(IteratorInvalid, ElementInvalid); }; // K e y I t e r a t o r interface KeyIterator : Iterator { // m o v i n g t h e i t e r a t o r s boolean set_to_element_with_key (in any key) raises(KeyInvalid); boolean set_to_next_element_with_key (in any key) raises(IteratorInvalid, KeyInvalid); boolean set_to_next_element_with_different_key() raises (IteratorInBetween, IteratorInvalid); // r e t r i e v i n g t h e k e y s boolean retrieve_key (out any key) raises (IteratorInBetween, IteratorInvalid); boolean retrieve_next_n_keys (out AnySequence keys) raises (IteratorInBetween, IteratorInvalid); }; // E q u a l i t y I t e r a t o r interface EqualityIterator : Iterator { // m o v i n g t h e i t e r a t o r s boolean set_to_element_with_value(in any element) raises(ElementInvalid); boolean set_to_next_element_with_value(in any element) raises (IteratorInvalid, ElementInvalid); boolean set_to_next_element_with_different_value() raises (IteratorInBetween, IteratorInvalid); }; // E q u a l i t y K e y I t e r a t o r interface EqualityKeyIterator : EqualityIterator, KeyIterator {}; // S o r t e d I t e r a t o r interface SortedIterator : OrderedIterator {}; // e n u m e r a t i o n t y p e f o r s p e c i f y i n g r a n g e s enum LowerBoundStyle {equal_lo, greater, greater_or_equal}; enum UpperBoundStyle {equal_up, less, less_or_equal}; // K e y S o r t e d I t e r a t o r interface KeySortedIterator : KeyIterator, SortedIterator { // m o v i n g t h e i t e r a t o r s boolean set_to_first_element_with_key ( in any key, in LowerBoundStyle style) raises(KeyInvalid); boolean set_to_last_element_with_key ( in any key, in UpperBoundStyle style) raises (KeyInvalid); boolean set_to_previous_element_with_key (in any key) raises(IteratorInvalid, KeyInvalid); boolean set_to_previous_element_with_different_key() raises (IteratorInBetween, IteratorInvalid); // r e t r i e v i n g k e y s boolean retrieve_previous_n_keys(out AnySequence keys) raises (IteratorInBetween, IteratorInvalid); }; // E q u a l i t y S o r t e d I t e r a t o r interface EqualitySortedIterator : EqualityIterator, SortedIterator { // m o v i n g t h e i t e r a t o r boolean set_to_first_element_with_value ( in any element, in LowerBoundStyle style) raises (ElementInvalid); boolean set_to_last_element_with_value ( in any element, in UpperBoundStyle style) raises (ElementInvalid); boolean set_to_previous_element_with_value (in any elementally) raises (IteratorInvalid, ElementInvalid); boolean set_to_previous_element_with_different_value() raises (IteratorInBetween, IteratorInvalid); }; // E q u a l i t y K e y S o r t e d I t e r a t o r interface EqualityKeySortedIterator : EqualitySortedIterator, KeySortedIterator {}; // E q u a l i t y S e q u e n t i a l I t e r a t o r interface EqualitySequentialIterator : EqualityIterator, SequentialIterator { // l o c a t i n g e l e m e n t s boolean set_to_first_element_with_value (in any element) raises (ElementInvalid); boolean set_to_last_element_with_value (in any element) raises (ElementInvalid); boolean set_to_previous_element_with_value (in any element) raises (ElementInvalid); }; interface Collection { // e l e m e n t t y p e i n f o r m a t i o n readonly attribute CORBA::TypeCode element_type; // a d d i n g e l e m e n t s boolean add_element (in any element) raises (ElementInvalid); boolean add_element_set_iterator ( in any element, in Iterator where) raises (IteratorInvalid, ElementInvalid); void add_all_from (in Collection collector) raises (ElementInvalid); // r e m o v i n g e l e m e n t s void remove_element_at (in Iterator where) raises (IteratorInvalid, IteratorInBetween); unsigned long remove_all (); // r e p l a c i n g e l e m e n t s void replace_element_at ( in Iterator where, in any element) raises(IteratorInvalid, IteratorInBetween, ElementInvalid); // r e t r i e v i n g e l e m e n t s boolean retrieve_element_at ( in Iterator where, out any element) raises (IteratorInvalid, IteratorInBetween); // i t e r a t i n g o v e r t h e c o l l e c t i o n boolean all_elements_do (in Command what) ; // i n q u i r i n g c o l l e c t i o n // i n f o r m a t i o n unsigned long number_of_elements (); boolean is_empty (); // d e s t r o y i n g c o l l e c t i o n void destroy(); // c r e a t i n g i t e r a t o r s Iterator create_iterator (in boolean read_only); }; // O r d e r e d C o l l e c t i o n interface OrderedCollection: Collection { // r e m o v i n g e l e m e n t s void remove_element_at_position (in unsigned long position) raises (PositionInvalid); void remove_first_element () raises (EmptyCollection); void remove_last_element () raises (EmptyCollection); // r e t r i e v i n g e l e m e n t s boolean retrieve_element_at_position ( in unsigned long position, out any element) raises (PositionInvalid); boolean retrieve_first_element (out any element) raises (EmptyCollection); boolean retrieve_last_element (out any element) raises (EmptyCollection); // c r e a t i n g i t e r a t o r s OrderedIterator create_ordered_iterator( in boolean read_only, in boolean reverse_iteration); }; // S e q u e n t i a l C o l l e c t i o n interface SequentialCollection: OrderedCollection { // a d d i n g e l e m e n t s void add_element_as_first (in any element) raises (ElementInvalid); void add_element_as_first_set_iterator ( in any element, in Iterator where) raises (ElementInvalid, IteratorInvalid); void add_element_as_last (in any element) raises (ElementInvalid); void add_element_as_last_set_iterator ( in any element, in Iterator where) raises (ElementInvalid, IteratorInvalid); void add_element_as_next ( in any element, in Iterator where) raises (ElementInvalid, IteratorInvalid); void add_element_as_previous ( in any element, in Iterator where) raises (ElementInvalid,IteratorInvalid); void add_element_at_position ( in unsigned long position, in any element) raises(PositionInvalid, ElementInvalid); void add_element_at_position_set_iterator ( in unsigned long position, in any element, in Iterator where) raises (PositionInvalid, ElementInvalid, IteratorInvalid); // r e p l a c i n g e l e m e n t s void replace_element_at_position ( in unsigned long position, in any element) raises (PositionInvalid, ElementInvalid); void replace_first_element (in any element) raises (ElementInvalid, EmptyCollection); void replace_last_element (in any element) raises (ElementInvalid, EmptyCollection); // r e o r d e r i n g e l e m e n t s void sort (in Comparator comparison); void reverse(); }; // S o r t e C o l l e c t i o n interface SortedCollection: OrderedCollection{}; // E q u a l i t y C o l l e c t i o n interface EqualityCollection: Collection { // t e s t i n g e l e m e n t c o n t a i n m e n t boolean contains_element (in any element) raises(ElementInvalid); boolean contains_all_from (in Collection collector) raises(ElementInvalid); // a d d i n g e l e m e n t s boolean locate_or_add_element (in any element) raises (ElementInvalid); boolean locate_or_add_element_set_iterator ( in any element, in Iterator where) raises (ElementInvalid, IteratorInvalid); // l o c a t i n g e l e m e n t s boolean locate_element ( in any element, in Iterator where) raises (ElementInvalid, IteratorInvalid); boolean locate_next_element ( in any element, in Iterator where) raises (ElementInvalid, IteratorInvalid); boolean locate_next_different_element (in Iterator where) raises (IteratorInvalid, IteratorInBetween); // r e m o v i n g e l e m e n t s boolean remove_element (in any element) raises (ElementInvalid); unsigned long remove_all_occurrences (in any element) raises (ElementInvalid); // i n q u i r i n g c o l l e c t i o n // i n f o r m a t i o n unsigned long number_of_different_elements (); unsigned long number_of_occurrences (in any element) raises(ElementInvalid); }; // K e y C o l l e c t i o n interface KeyCollection: Collection { // K e y t y p e i n f o r m a t i o n readonly attribute CORBA::TypeCode key_type; // t e s t i n g c o n t a i n m e n t boolean contains_element_with_key (in any key) raises(KeyInvalid); boolean contains_all_keys_from (in KeyCollection collector) raises(KeyInvalid); // a d d i n g e l e m e n t s boolean locate_or_add_element_with_key (in any element) raises(ElementInvalid); boolean locate_or_add_element_with_key_set_iterator ( in any element, in Iterator where) raises (ElementInvalid, IteratorInvalid); // a d d i n g o r r e p l a c i n g e l e m e n t s boolean add_or_replace_element_with_key (in any element) raises(ElementInvalid); boolean add_or_replace_element_with_key_set_iterator ( in any element, in Iterator where) raises (ElementInvalid, IteratorInvalid); // r e m o v i n g e l e m e n t s boolean remove_element_with_key(in any key) raises(KeyInvalid); unsigned long remove_all_elements_with_key (in any key) raises(KeyInvalid); // r e p l a c i n g e l e m e n t s boolean replace_element_with_key (in any element) raises(ElementInvalid); boolean replace_element_with_key_set_iterator ( in any element, in Iterator where) raises (ElementInvalid, IteratorInvalid); // r e t r i e v i n g e l e m e n t s boolean retrieve_element_with_key ( in any key, out any element) raises (KeyInvalid); // c o m p u t i n g t h e k e y s void key (in any element, out any key) raises (ElementInvalid); void keys (in AnySequence elements, out AnySequence keys) raises (ElementInvalid); // l o c a t i n g e l e m e n t s boolean locate_element_with_key ( in any key, in Iterator where) raises (KeyInvalid, IteratorInvalid); boolean locate_next_element_with_key ( in any key, in Iterator where) raises (KeyInvalid, IteratorInvalid); boolean locate_next_element_with_different_key ( in Iterator where) raises (IteratorInBetween, IteratorInvalid); // i n q u i r i n g c o l l e c t i o n // i n f o r m a t i o n unsigned long number_of_different_keys (); unsigned long number_of_elements_with_key (in any key) raises(KeyInvalid); }; // E q u a l i t y K e y C o l l e c t i o n interface EqualityKeyCollection : EqualityCollection, KeyCollection{}; // K e y S o r t e d C o l l e c t i o n interface KeySortedCollection : KeyCollection, SortedCollection { // l o c a t i n g e l e m e n t s boolean locate_first_element_with_key ( in any key, in Iterator where) raises (KeyInvalid, IteratorInvalid); boolean locate_last_element_with_key( in any key, in Iterator where) raises (KeyInvalid, IteratorInvalid); boolean locate_previous_element_with_key ( in any key, in Iterator where) raises (KeyInvalid, IteratorInvalid); boolean locate_previous_element_with_different_key( in Iterator where) raises (IteratorInBetween, IteratorInvalid); }; // E q u a l i t y S o r t e d C o l l e c t i o n interface EqualitySortedCollection : EqualityCollection, SortedCollection { // l o c a t i n g e l e m e n t s boolean locate_first_element ( in any element, in Iterator where) raises (ElementInvalid, IteratorInvalid); boolean locate_last_element ( in any element, in Iterator where) raises (ElementInvalid, IteratorInvalid); boolean locate_previous_element ( in any element, in Iterator where) raises (ElementInvalid, IteratorInvalid); boolean locate_previous_different_element (in Iterator where) raises (IteratorInvalid); }; // E q u a l i t y K e y S o r t e d C o l l e c t i o n interface EqualityKeySortedCollection : EqualityCollection, KeyCollection, SortedCollection {}; // E q u a l i t y S e q u e n t i a l C o l l e c t i o n interface EqualitySequentialCollection : EqualityCollection, SequentialCollection { // l o c a t i n g e l e m e n t s boolean locate_first_element_with_value ( in any element, in Iterator where) raises (ElementInvalid, IteratorInvalid); boolean locate_last_element_with_value ( in any element, in Iterator where) raises (ElementInvalid, IteratorInvalid); boolean locate_previous_element_with_value ( in any element, in Iterator where) raises (ElementInvalid, IteratorInvalid); }; // THE CONCRETE COLLECTION INTERFACES // K e y S e t interface KeySet: KeyCollection {}; // K e y B a g interface KeyBag: KeyCollection {}; // M a p interface Map : EqualityKeyCollection { // s e t t h e o r e t i c a l o p e r a t i o n s void difference_with (in Map collector) raises (ElementInvalid); void add_difference ( in Map collector1, in Map collector2) raises (ElementInvalid); void intersection_with (in Map collector) raises (ElementInvalid); void add_intersection ( in Map collector1, in Map collector2) raises (ElementInvalid); void union_with (in Map collector) raises (ElementInvalid); void add_union ( in Map collector1, in Map collector2) raises (ElementInvalid); // t e s t i n g e q u a l i t y boolean equal (in Map collector) raises (ElementInvalid); boolean not_equal (in Map collector) raises(ElementInvalid); }; // R e l a t i o n interface Relation : EqualityKeyCollection { // e q u a l , n o t _ e q u a l , a n d t h e // s e t - t h e o r e t i c a l o p e r a t i o n s a s // d e f i n e d f o r M a p }; // S e t interface Set : EqualityCollection { // e q u a l , n o t _ e q u a l , a n d t h e s e t // t h e o r e t i c a l o p e r a t i o n s a s // d e f i n e d f o r M a p }; // B a g interface Bag : EqualityCollection { // e q u a l , n o t _ e q u a l , a n d t h e s e t // t h e o r e t i c a l o p e r a t i o n s a s d e f i n e d // d e f i n e d f o r M a p }; // K e y S o r t e d S e t interface KeySortedSet : KeySortedCollection { long compare ( in KeySortedSet collector, in Comparator comparison); }; // K e y S o r t e d B a g interface KeySortedBag : KeySortedCollection { long compare ( in KeySortedBag collector, in Comparator comparison); }; // S o r t e d M a p interface SortedMap : EqualityKeySortedCollection { // e q u a l , n o t _ e q u a l , a n d t h e s e t // t h e o r e t i c a l o p e r a t i o n s long compare ( in SortedMap collector, in Comparator comparison); }; // S o r t e d R e l a t i o n interface SortedRelation : EqualityKeySortedCollection { // e q u a l , n o t _ e q u a l , a n d t h e s e t // t h e o r e t i c a l o p e r a t i o n s long compare ( in SortedRelation collector, in Comparator comparison); }; // S o r t e d S e t interface SortedSet : EqualitySortedCollection { // e q u a l , n o t _ e q u a l , a n d t h e s e t // t h e o r e t i c a l o p e r a t i o n s long compare ( in SortedSet collector, in Comparator comparison); }; // S o r t e d B a g interface SortedBag: EqualitySortedCollection { // e q u a l , n o t _ e q u a l , a n d t h e s e t // t h e o r e t i c a l o p e r a t i o n s long compare ( in SortedBag collector, in Comparator comparison); }; // S e q u e n c e interface CSequence : SequentialCollection { // C o m p a r i s o n long compare ( in CSequence collector, in Comparator comparison); }; // E q u a l i t y S e q u e n c e interface EqualitySequence : EqualitySequentialCollection { // t e s t o n e q u a l i t y boolean equal (in EqualitySequence collector); boolean not_equal (in EqualitySequence collector); // c o m p a r i s o n long compare ( in EqualitySequence collector, in Comparator comparison); }; // H e a p interface Heap : Collection {}; // R e s t r i c t e d A c c e s s C o l l e c t i o n s interface RestrictedAccessCollection { // g e t t i n g i n f o r m a t i o n o n // c o l l e c t i o n s t a t e boolean unfilled (); unsigned long size (); // r e m o v i n g e l e m e n t s void purge (); }; // Q u e u e interface Queue : RestrictedAccessCollection { // a d d i n g e l e m e n t s void enqueue (in any element) raises (ElementInvalid); // r e m o v i n g e l e m e n t s void dequeue () raises (EmptyCollection); boolean element_dequeue (out any element) raises (EmptyCollection); }; // D e q u e interface Deque : RestrictedAccessCollection { // a d d i n g e l e m e n t s void enqueue_as_first (in any element) raises (ElementInvalid); void enqueue_as_last (in any element) raises(ElementInvalid); // r e m o v i n g e l e m e n t s void dequeue_first () raises (EmptyCollection); boolean element_dequeue_first (out any element) raises (EmptyCollection); void dequeue_last () raises (EmptyCollection); boolean element_dequeue_last (out any element) raises (EmptyCollection); }; // S t a c k interface Stack: RestrictedAccessCollection { // a d d i n g e l e m e n t s void push (in any element) raises (ElementInvalid); // r e m o v i n g a n d r e t r i e v i n g // e l e m e n t s void pop () raises (EmptyCollection); boolean element_pop (out any element) raises (EmptyCollection); boolean top (out any element) raises (EmptyCollection); }; // P r i o r i t y Q u e u e interface PriorityQueue: RestrictedAccessCollection { // a d d i n g e l e m e n t s void enqueue (in any element) raises (ElementInvalid); // r e m o v i n g e l e m e n t s void dequeue () raises (EmptyCollection); boolean element_dequeue (out any element) raises (EmptyCollection); }; // COLLECTION FACTORIES // C o l l e c t i o n F a c t o r y interface CollectionFactory { Collection generic_create (in ParameterList parameters) raises (ParameterInvalid); }; // C o l l e c t i o n F a c t o r i e s interface CollectionFactories : CollectionFactory { boolean add_factory ( in Istring collection_interface, in Istring impl_category, in Istring impl_interface, in CollectionFactory _factory); boolean remove_factory ( in Istring collection_interface, in Istring impl_category, in Istring impl_interface); Collection create (in ParameterList parameters) raises (ParameterInvalid); }; // R A C o l l e c t i o n F a ct o r y interface RACollectionFactory { RestrictedAccessCollection generic_create ( in ParameterList parameters) raises (ParameterInvalid); }; // R A C o l l e c t i o n F a c t o r i e s interface RACollectionFactories : RACollectionFactory { boolean add_factory ( in Istring collection_interface, in Istring impl_category, in Istring impl_interface, in RACollectionFactory _factory); boolean remove_factory ( in Istring collection_interface, in Istring impl_category, in Istring impl_interface); Collection create ( in ParameterList parameters) raises (ParameterInvalid); }; // K e y S e t F a c t o r y interface KeySetFactory : CollectionFactory { KeySet create ( in Operations ops, in unsigned long expected_size); }; // K e y B a g F a c t o r y interface KeyBagFactory : CollectionFactory { KeyBag create ( in Operations ops, in unsigned long expected_size); }; // M a p F a c t o r y interface MapFactory : CollectionFactory { Map create (in Operations ops, in unsigned long expected_size); }; // R e l a t i o n F a c t o r y interface RelationFactory : CollectionFactory { Relation create ( in Operations ops, in unsigned long expected_size); }; // S e t F a c t o r y interface SetFactory : CollectionFactory { Set create (in Operations ops, in unsigned long expected_size); }; // B a g F a c t o r y interface BagFactory { Bag create (in Operations ops, in unsigned long expected_size); }; // K e y S o r t e d S e t F a c t o r y interface KeySortedSetFactory { KeySortedSet create (in Operations ops, in unsigned long expected_size); }; // K e y S o r t e d B a g F a c t o r y interface KeySortedBagFactory : CollectionFactory { KeySortedBag create (in Operations ops, in unsigned long expected_size); }; // S o r t e d M a p F a c t o r y interface SortedMapFactory : CollectionFactory { SortedMap create (in Operations ops, in unsigned long expected_size); }; // S o r t e d R e l a t i o n F a c t o r y interface SortedRelationFactory : CollectionFactory { SortedRelation create ( in Operations ops, in unsigned long expected_size); }; // S o r t e d S e t F a c t o r y interface SortedSetFactory : CollectionFactory { SortedSet create ( in Operations ops, in unsigned long expected_size); }; // S o r t e d B a g F a c t o r y interface SortedBagFactory { SortedBag create ( in Operations ops, in unsigned long expected_size); }; // S e q u e n c e F a c t o r y interface SequenceFactory : CollectionFactory { CSequence create ( in Operations ops, in unsigned long expected_size); }; // E q u a l i t y S e q u e n c e F a c t o r y interface EqualitySequenceFactory : CollectionFactory { EqualitySequence create (in Operations ops, in unsigned long expected_size); }; // H e a p F a c t o r y interface HeapFactory : CollectionFactory { Heap create (in Operations ops, in unsigned long expected_size); }; // Q u e u e F a c t o r y interface QueueFactory : RACollectionFactory { Queue create ( in Operations ops, in unsigned long expected_size); }; // S t a c k F a c t o r y interface StackFactory : RACollectionFactory { Stack create ( in Operations ops, in unsigned long expected_size); }; // D e q u e F a c t o r y interface DequeFactory : RACollectionFactory { Deque create ( in Operations ops, in unsigned long expected_size); }; // P r i o r i t y Q u e u e F a c t o r y interface PriorityQueueFactory : RACollectionFactory { PriorityQueue create ( in Operations ops, in unsigned long expected_size); }; }; #endif /* ifndef _COS_COLLECTION_IDL_ */ polyorb-2.8~20110207.orig/idls/cos/naming/0000755000175000017500000000000011750740340017372 5ustar xavierxavierpolyorb-2.8~20110207.orig/idls/cos/naming/CosNaming.idl0000644000175000017500000000631611750740337021756 0ustar xavierxavier//File: CosNaming.idl //The only module of the Naming Service //OMG File: 04-10-07 #ifndef _COS_NAMING_IDL_ #define _COS_NAMING_IDL_ #ifdef _PRE_3_0_COMPILER_ #pragma prefix "omg.org" #endif // _PRE_3_0_COMPILER_ module CosNaming { #ifndef _PRE_3_0_COMPILER_ typeprefix CosNaming "omg.org"; #endif // _PRE_3_0_COMPILER_ typedef string Istring; struct NameComponent { Istring id; Istring kind; }; typedef sequence Name; enum BindingType { nobject, ncontext }; struct Binding { Name binding_name; BindingType binding_type; }; // Note: In struct Binding, binding_name is incorrectly defined // as a Name instead of a NameComponent. This definition is // unchanged for compatibility reasons. typedef sequence BindingList; interface BindingIterator; interface NamingContext { enum NotFoundReason { missing_node, not_context, not_object }; exception NotFound { NotFoundReason why; Name rest_of_name; }; exception CannotProceed { NamingContext cxt; Name rest_of_name; }; exception InvalidName{}; exception AlreadyBound {}; exception NotEmpty{}; void bind(in Name n, in Object obj) raises( NotFound, CannotProceed, InvalidName, AlreadyBound ); void rebind(in Name n, in Object obj) raises(NotFound, CannotProceed, InvalidName); void bind_context(in Name n, in NamingContext nc) raises(NotFound, CannotProceed, InvalidName, AlreadyBound); void rebind_context(in Name n, in NamingContext nc) raises(NotFound, CannotProceed, InvalidName); Object resolve (in Name n) raises(NotFound, CannotProceed, InvalidName); void unbind(in Name n) raises(NotFound, CannotProceed, InvalidName); NamingContext new_context(); NamingContext bind_new_context(in Name n) raises( NotFound, AlreadyBound, CannotProceed, InvalidName ); void destroy() raises(NotEmpty); void list( in unsigned long how_many, out BindingList bl, out BindingIterator bi ); }; interface BindingIterator { boolean next_one(out Binding b); boolean next_n(in unsigned long how_many, out BindingList bl); void destroy(); }; interface NamingContextExt: NamingContext { typedef string StringName; typedef string Address; typedef string URLString; StringName to_string(in Name n) raises(InvalidName); Name to_name(in StringName sn) raises(InvalidName); exception InvalidAddress {}; URLString to_url(in Address addr, in StringName sn) raises(InvalidAddress, InvalidName); Object resolve_str(in StringName sn) raises( NotFound, CannotProceed, InvalidName //PolyORB:WA: the OMG's IDL states "InvalidaName," // which is not syntanxically correct ); }; }; #endif /* ifndef _COS_NAMING_IDL_ */ polyorb-2.8~20110207.orig/idls/cos/naming/polyorb-corba_p-naming_tools.ads0000644000175000017500000001062511750740337025655 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . C O R B A _ P . N A M I N G _ T O O L S -- -- -- -- S p e c -- -- -- -- Copyright (C) 2001-2008, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- Wrappers for the COS Naming service to facilitate retrievel of object -- references by IOR or by name. with Ada.Finalization; with CORBA.Object; with CosNaming.NamingContext; package PolyORB.CORBA_P.Naming_Tools is function Locate (Name : CosNaming.Name) return CORBA.Object.Ref; function Locate (Context : CosNaming.NamingContext.Ref; Name : CosNaming.Name) return CORBA.Object.Ref; -- Locate an object given its name, given as an array of name components. function Locate (IOR_Or_Name : String; Sep : Character := '/') return CORBA.Object.Ref; function Locate (Context : CosNaming.NamingContext.Ref; IOR_Or_Name : String; Sep : Character := '/') return CORBA.Object.Ref; -- Locate an object by IOR or name. If the string does not start with -- "IOR:", the name will be parsed before it is looked up, using -- Parse_Name below. procedure Register (Name : String; Ref : CORBA.Object.Ref; Rebind : Boolean := False; Sep : Character := '/'); -- Register an object by its name by binding or rebinding. -- The name will be parsed by Parse_Name below; any necessary contexts -- will be created on the name server. -- If Rebind is True, then a rebind will be performed if the name -- is already bound. procedure Unregister (Name : String); -- Unregister an object by its name by unbinding it type Server_Guard is limited private; procedure Register (Guard : in out Server_Guard; Name : String; Ref : CORBA.Object.Ref; Rebind : Boolean := False; Sep : Character := '/'); -- A Server_Guard object is an object which is able to register a server -- reference in a naming service (see Register above), and destroy this -- name using Unregister when the object disappears (the program terminates -- or the Server_Guard object lifetime has expired). function Parse_Name (Name : String; Sep : Character := '/') return CosNaming.Name; -- Split a sequence of name component specifications separated with Sep -- characters into a name component array. Any leading Sep is ignored. private type Server_Guard is new Ada.Finalization.Limited_Controlled with record Name : CORBA.String := CORBA.To_CORBA_String (""); end record; procedure Finalize (Guard : in out Server_Guard); end PolyORB.CORBA_P.Naming_Tools; polyorb-2.8~20110207.orig/idls/cos/naming/polyorb-corba_p-naming_tools.adb0000644000175000017500000002227711750740337025642 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B . C O R B A _ P . N A M I N G _ T O O L S -- -- -- -- B o d y -- -- -- -- Copyright (C) 2001-2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with CORBA.ORB; with CosNaming.NamingContext.Helper; with PolyORB.Utils; package body PolyORB.CORBA_P.Naming_Tools is use CosNaming; use CosNaming.NamingContext; use CosNaming.NamingContext.Helper; use PolyORB.Utils; subtype NameComponent_Array is CosNaming.IDL_SEQUENCE_CosNaming_NameComponent.Element_Array; function Retrieve_Context (Name : CosNaming.Name) return Ref; -- Return a CosNaming.NamingContext.Ref that designates the NamingContext -- registered as Name. -------------- -- Finalize -- -------------- procedure Finalize (Guard : in out Server_Guard) is Name : constant String := CORBA.To_Standard_String (Guard.Name); begin if Name /= "" then Unregister (Name); end if; end Finalize; ------------ -- Locate -- ------------ function Locate (Name : CosNaming.Name) return CORBA.Object.Ref is RNS : constant NamingContext.Ref := To_Ref (CORBA.ORB.Resolve_Initial_References (CORBA.ORB.To_CORBA_String ("NamingService"))); begin return resolve (RNS, Name); end Locate; ------------ -- Locate -- ------------ function Locate (Context : CosNaming.NamingContext.Ref; Name : CosNaming.Name) return CORBA.Object.Ref is begin return resolve (Context, Name); end Locate; ------------ -- Locate -- ------------ function Locate (IOR_Or_Name : String; Sep : Character := '/') return CORBA.Object.Ref is begin if Has_Prefix (IOR_Or_Name, Prefix => "IOR:") then declare Obj : CORBA.Object.Ref; begin CORBA.ORB.String_To_Object (CORBA.To_CORBA_String (IOR_Or_Name), Obj); return Obj; end; end if; return Locate (Parse_Name (IOR_Or_Name, Sep)); end Locate; ------------ -- Locate -- ------------ function Locate (Context : CosNaming.NamingContext.Ref; IOR_Or_Name : String; Sep : Character := '/') return CORBA.Object.Ref is begin if Has_Prefix (IOR_Or_Name, Prefix => "IOR:") then declare Obj : CORBA.Object.Ref; begin CORBA.ORB.String_To_Object (CORBA.To_CORBA_String (IOR_Or_Name), Obj); return Obj; end; end if; return Locate (Context, Parse_Name (IOR_Or_Name, Sep)); end Locate; ---------------------- -- Retrieve_Context -- ---------------------- function Retrieve_Context (Name : CosNaming.Name) return Ref is Cur : NamingContext.Ref := To_Ref (CORBA.ORB.Resolve_Initial_References (CORBA.ORB.To_CORBA_String ("NamingService"))); Ref : NamingContext.Ref; N : CosNaming.Name; NCA : constant NameComponent_Array := CosNaming.To_Element_Array (Name); begin for I in NCA'Range loop N := CosNaming.To_Sequence ((1 => NCA (I))); begin Ref := To_Ref (resolve (Cur, N)); exception when NotFound => Ref := NamingContext.Ref (bind_new_context (Cur, N)); end; Cur := Ref; end loop; return Cur; end Retrieve_Context; -------------- -- Register -- -------------- procedure Register (Name : String; Ref : CORBA.Object.Ref; Rebind : Boolean := False; Sep : Character := '/') is Context : NamingContext.Ref; NCA : constant NameComponent_Array := CosNaming.To_Element_Array (Parse_Name (Name, Sep)); N : constant CosNaming.Name := CosNaming.To_Sequence ((1 => NCA (NCA'Last))); begin if NCA'Length = 1 then Context := To_Ref (CORBA.ORB.Resolve_Initial_References (CORBA.ORB.To_CORBA_String ("NamingService"))); else Context := Retrieve_Context (CosNaming.To_Sequence (NCA (NCA'First .. NCA'Last - 1))); end if; bind (Context, N, Ref); exception when NamingContext.AlreadyBound => if Rebind then NamingContext.rebind (Context, N, Ref); else raise; end if; end Register; -------------- -- Register -- -------------- procedure Register (Guard : in out Server_Guard; Name : String; Ref : CORBA.Object.Ref; Rebind : Boolean := False; Sep : Character := '/') is begin Register (Name, Ref, Rebind, Sep); Guard.Name := CORBA.To_CORBA_String (Name); end Register; ---------------- -- Parse_Name -- ---------------- function Parse_Name (Name : String; Sep : Character := '/') return CosNaming.Name is Result : CosNaming.Name; Unescaped : String (Name'Range); First : Integer := Unescaped'First; Last : Integer; Last_Unescaped_Period : Integer := Unescaped'First - 1; Seen_Backslash : Boolean := False; End_Of_NC : Boolean := False; begin -- First ignore any leading separators while First <= Name'Last and then Name (First) = Sep loop First := First + 1; end loop; Last := First - 1; for J in First .. Name'Last loop if not Seen_Backslash and then Name (J) = '\' then Seen_Backslash := True; else -- Seen_Backslash and seeing an escaped character -- *or* seeing a non-escaped non-backslash character. if not Seen_Backslash and then Name (J) = Sep then -- Seeing a non-escaped Sep End_Of_NC := True; else -- Seeing a non-escaped non-backslash, non-Sep character, -- or seeing an escaped character. Last := Last + 1; Unescaped (Last) := Name (J); End_Of_NC := J = Name'Last; end if; if not Seen_Backslash and then Name (J) = '.' then Last_Unescaped_Period := Last; end if; if End_Of_NC then if Last_Unescaped_Period < First then Last_Unescaped_Period := Last + 1; end if; Append (Result, NameComponent' (id => To_CORBA_String (Unescaped (First .. Last_Unescaped_Period - 1)), kind => To_CORBA_String (Unescaped (Last_Unescaped_Period + 1 .. Last)))); Last_Unescaped_Period := Last; First := Last + 1; end if; Seen_Backslash := Name (J) = '\' and then not Seen_Backslash; end if; end loop; return Result; end Parse_Name; ---------------- -- Unregister -- ---------------- procedure Unregister (Name : String) is RNS : constant NamingContext.Ref := To_Ref (CORBA.ORB.Resolve_Initial_References (CORBA.ORB.To_CORBA_String ("NamingService"))); N : CosNaming.Name; NC : NameComponent; begin NC.kind := To_CORBA_String (""); NC.id := To_CORBA_String (Name); Append (N, NC); unbind (RNS, N); end Unregister; end PolyORB.CORBA_P.Naming_Tools; polyorb-2.8~20110207.orig/idls/cos/naming/Lname-library.idl0000644000175000017500000000373311750740337022576 0ustar xavierxavier//File: Lname-library.idl //Listed with the Naming Service, but not part of it. // // The Lname-Library interfaces are defined in PIDL, not IDL. // They are included here to provide a complete listing of what // is in the Naming Service and to test the syntax. It actually // compiles as IDL. // This libary is optional and NOT a part of CosNaming. It should // not be included in the CosNaming.idl file. // The Naming Service suggests that a vendor may wish to provide // a language specific libary corresponding to this PIDL. This file // might then serve as the basis of what the language libary // looks like. // The interfaces defined here are NOT intended to be CORBA objects. // It should be noted that there is no module name associated // because this file is not intended to be "#include"d in any // other .idl file. For that reason, there are also no guards. #include interface LNameComponent { // PIDL exception NotSet{}; string get_id() raises(NotSet); void set_id(in string i); string get_kind() raises(NotSet); void set_kind(in string k); void destroy(); }; interface LName { // PIDL exception NoComponent{}; exception OverFlow{}; exception InvalidName{}; LName insert_component( in unsigned long i, in LNameComponent n) raises( NoComponent, OverFlow); LNameComponent get_component(in unsigned long i) raises(NoComponent); LNameComponent delete_component(in unsigned long i) raises(NoComponent); unsigned long num_components(); boolean equal(in LName ln); boolean less_than(in LName ln); CosNaming::Name to_idl_form() raises(InvalidName); void from_idl_form(in CosNaming::Name n); void destroy(); }; //Note: end of option LName PIDL polyorb-2.8~20110207.orig/idls/cos/property/0000755000175000017500000000000011750740340020005 5ustar xavierxavierpolyorb-2.8~20110207.orig/idls/cos/property/CosPropertyService.idl0000644000175000017500000001477711750740337024337 0ustar xavierxavier//File: CosPropertyService.idl //The only module of the Property Service //OMG File: 98-10-28 #ifndef _COS_PROPERTY_SERVICE_IDL_ #define _COS_PROPERTY_SERVICE_IDL_ #ifdef _PRE_3_0_COMPILER_ #include #pragma prefix "omg.org" #else import ::CORBA; #endif // _PRE_3_0_COMPILER_ module CosPropertyService { #ifndef _PRE_3_0_COMPILER_ typeprefix CosPropertyService "omg.org"; #endif // _PRE_3_0_COMPILER_ /*****************************************************/ /* Data Types */ /*****************************************************/ typedef string PropertyName; struct Property { PropertyName property_name; any property_value; }; enum PropertyModeType { normal, read_only, fixed_normal, fixed_readonly, undefined }; struct PropertyDef { PropertyName property_name; any property_value; PropertyModeType property_mode; }; struct PropertyMode { PropertyName property_name; PropertyModeType property_mode; }; typedef sequence PropertyNames; typedef sequence Properties; typedef sequence PropertyDefs; typedef sequence PropertyModes; typedef sequence PropertyTypes; interface PropertyNamesIterator; interface PropertiesIterator; interface PropertySetFactory; interface PropertySetDef; interface PropertySet; /*****************************************************/ /* Exceptions */ /*****************************************************/ exception ConstraintNotSupported{}; exception InvalidPropertyName {}; exception ConflictingProperty {}; exception PropertyNotFound {}; exception UnsupportedTypeCode {}; exception UnsupportedProperty {}; exception UnsupportedMode {}; exception FixedProperty {}; exception ReadOnlyProperty {}; enum ExceptionReason { invalid_property_name, conflicting_property, property_not_found, unsupported_type_code, unsupported_property, unsupported_mode, fixed_property, read_only_property }; struct PropertyException { ExceptionReason reason; PropertyName failing_property_name; }; typedef sequence PropertyExceptions; exception MultipleExceptions { PropertyExceptions exceptions; }; /*****************************************************/ /* Interface Definitions */ /*****************************************************/ interface PropertySetFactory { PropertySet create_propertyset(); PropertySet create_constrained_propertyset( in PropertyTypes allowed_property_types, in Properties allowed_properties) raises(ConstraintNotSupported); PropertySet create_initial_propertyset( in Properties initial_properties) raises(MultipleExceptions); }; /*---------------------------------------------------*/ interface PropertySetDefFactory { PropertySetDef create_propertysetdef(); PropertySetDef create_constrained_propertysetdef( in PropertyTypes allowed_property_types, in PropertyDefs allowed_property_defs) raises(ConstraintNotSupported); PropertySetDef create_initial_propertysetdef( in PropertyDefs initial_property_defs) raises(MultipleExceptions); }; /*---------------------------------------------------*/ interface PropertySet { /* Support for defining and modifying properties */ void define_property( in PropertyName property_name, in any property_value) raises( InvalidPropertyName, ConflictingProperty, UnsupportedTypeCode, UnsupportedProperty, ReadOnlyProperty); void define_properties( in Properties nproperties) raises(MultipleExceptions); /* Support for Getting Properties and their Names */ unsigned long get_number_of_properties(); void get_all_property_names( in unsigned long how_many, out PropertyNames property_names, out PropertyNamesIterator rest); any get_property_value( in PropertyName property_name) raises( PropertyNotFound, InvalidPropertyName); boolean get_properties( in PropertyNames property_names, out Properties nproperties); void get_all_properties( in unsigned long how_many, out Properties nproperties, out PropertiesIterator rest); /* Support for Deleting Properties */ void delete_property( in PropertyName property_name) raises( PropertyNotFound, InvalidPropertyName, FixedProperty); void delete_properties( in PropertyNames property_names) raises(MultipleExceptions); boolean delete_all_properties(); /* Support for Existence Check */ boolean is_property_defined( in PropertyName property_name) raises(InvalidPropertyName); }; /*---------------------------------------------------*/ interface PropertySetDef:PropertySet { /* Support for retrieval of PropertySet constraints*/ void get_allowed_property_types( out PropertyTypes property_types); void get_allowed_properties( out PropertyDefs property_defs); /* Support for defining and modifying properties */ void define_property_with_mode( in PropertyName property_name, in any property_value, in PropertyModeType property_mode) raises( InvalidPropertyName, ConflictingProperty, UnsupportedTypeCode, UnsupportedProperty, UnsupportedMode, ReadOnlyProperty); void define_properties_with_modes( in PropertyDefs property_defs) raises(MultipleExceptions); /* Support for Getting and Setting Property Modes */ PropertyModeType get_property_mode( in PropertyName property_name) raises( PropertyNotFound, InvalidPropertyName); boolean get_property_modes( in PropertyNames property_names, out PropertyModes property_modes); void set_property_mode( in PropertyName property_name, in PropertyModeType property_mode) raises( InvalidPropertyName, PropertyNotFound, UnsupportedMode); void set_property_modes( in PropertyModes property_modes) raises(MultipleExceptions); }; /*---------------------------------------------------*/ interface PropertyNamesIterator { void reset(); boolean next_one( out PropertyName property_name); boolean next_n ( in unsigned long how_many, out PropertyNames property_names); void destroy(); }; /*---------------------------------------------------*/ interface PropertiesIterator { void reset(); boolean next_one( out Property aproperty); boolean next_n( in unsigned long how_many, out Properties nproperties); void destroy(); }; }; #endif /* ifndef _COS_PROPERTY_SERVICE_IDL_ */ polyorb-2.8~20110207.orig/idls/cos/time/0000755000175000017500000000000011750740340017057 5ustar xavierxavierpolyorb-2.8~20110207.orig/idls/cos/time/CosTime.idl0000644000175000017500000000326511750740337021130 0ustar xavierxavier//File: CosTime.idl //Part of the Time Service //OMG File: 02-03-08 #ifndef _COS_TIME_IDL_ #define _COS_TIME_IDL_ #ifdef _PRE_3_0_COMPILER_ #include #pragma prefix "omg.org" #else import ::TimeBase; #endif // _PRE_3_0_COMPILER_ module CosTime { #ifndef _PRE_3_0_COMPILER_ typeprefix CosTime "omg.org"; #endif // _PRE_3_0_COMPILER_ enum TimeComparison { TCEqualTo, TCLessThan, TCGreaterThan, TCIndeterminate }; enum ComparisonType{ IntervalC, MidC }; enum OverlapType { OTContainer, OTContained, OTOverlap, OTNoOverlap }; exception TimeUnavailable {}; interface TIO; // forward declaration interface UTO { readonly attribute TimeBase::TimeT time; readonly attribute TimeBase::InaccuracyT inaccuracy; readonly attribute TimeBase::TdfT tdf; readonly attribute TimeBase::UtcT utc_time; UTO absolute_time(); TimeComparison compare_time( in ComparisonType comparison_type, in CosTime::UTO uto ); TIO time_to_interval( in CosTime::UTO uto); TIO interval(); }; interface TIO { readonly attribute TimeBase::IntervalT time_interval; OverlapType spans ( in UTO time, out TIO overlap); OverlapType overlaps ( in TIO interval, out TIO overlap); UTO time (); }; interface TimeService { UTO universal_time() raises(TimeUnavailable); UTO secure_universal_time() raises(TimeUnavailable); UTO new_universal_time( in TimeBase::TimeT time, in TimeBase::InaccuracyT inaccuracy, in TimeBase::TdfT tdf); UTO uto_from_utc( in TimeBase::UtcT utc); TIO new_interval( in TimeBase::TimeT lower, in TimeBase::TimeT upper); }; }; #endif /* ifndef _COS_TIME_IDL_ */ polyorb-2.8~20110207.orig/idls/cos/time/TimeBase.idl0000644000175000017500000000210411750740337021245 0ustar xavierxavier//File: TimeBase.idl //Part of the Time Service // Note: if your IDL compiler does not yet support the // "long long" data type, compile this module with the // preprocessor definition "NOLONGLONG". With many // compilers this would be done with a qualifier on // the command line, something like -DNOLONGLONG //OMG File: 98-10-47 #ifndef _TIME_BASE_IDL_ #define _TIME_BASE_IDL_ #ifdef _PRE_3_0_COMPILER_ #pragma prefix "omg.org" #endif // _PRE_3_0_COMPILER_ module TimeBase { #ifndef _PRE_3_0_COMPILER_ typeprefix TimeBase "omg.org"; #endif // _PRE_3_0_COMPILER_ #ifdef NOLONGLONG struct ulonglong{ unsigned long low; unsigned long high; }; typedef ulonglong TimeT; #else typedef unsigned long long TimeT; #endif typedef TimeT InaccuracyT; typedef short TdfT; struct UtcT { TimeT time; // 8 octets unsigned long inacclo; // 4 octets unsigned short inacchi; // 2 octets TdfT tdf; // 2 octets // total 16 octets. }; struct IntervalT { TimeT lower_bound; TimeT upper_bound; }; }; #endif /* ifndef _TIME_BASE_IDL_ */ polyorb-2.8~20110207.orig/idls/cos/time/CosTimerEvent.idl0000644000175000017500000000235211750740337022310 0ustar xavierxavier//File: CosTimerEvent.idl //Part of the Time Service //OMG File: 98-10-46 #ifndef _COS_TIMER_EVENT_IDL_ #define _COS_TIMER_EVENT_IDL_ #ifdef _PRE_3_0_COMPILER_ #include #include #pragma prefix "omg.org" #else import ::CosTime; import ::CosEventComm; #endif // _PRE_3_0_COMPILER_ module CosTimerEvent { #ifndef _PRE_3_0_COMPILER_ typeprefix CosTimerEvent "omg.org"; #endif // _PRE_3_0_COMPILER_ enum TimeType { TTAbsolute, TTRelative, TTPeriodic }; enum EventStatus { ESTimeSet, ESTimeCleared, ESTriggered, ESFailedTrigger }; struct TimerEventT { TimeBase::UtcT utc; any event_data; }; interface TimerEventHandler { readonly attribute EventStatus status; boolean time_set( out CosTime::UTO uto); void SetTimer( in TimeType time_type, in CosTime::UTO trigger_time); boolean cancel_timer(); void set_data( in any event_data); }; interface TimerEventService { TimerEventHandler register( in CosEventComm::PushConsumer event_interface, in any data); void unregister( in TimerEventHandler timer_event_handler); CosTime::UTO event_time( in TimerEventT timer_event); }; }; #endif /* ifndef _COS_TIMER_EVENT_IDL_ */ polyorb-2.8~20110207.orig/idls/Misc/0000755000175000017500000000000011750740340016230 5ustar xavierxavierpolyorb-2.8~20110207.orig/idls/Misc/Dynamic.idl0000644000175000017500000000120511750740337020312 0ustar xavierxavier// File: Dynamic.idl // CORBA 3.0, Chapter 21 #ifndef _DYNAMIC_IDL_ #define _DYNAMIC_IDL_ #ifdef _PRE_3_0_COMPILER_ #pragma prefix "omg.org" #include #else import ::CORBA; #endif // _PRE_3_0_COMPILER_ module Dynamic { #ifndef _PRE_3_0_COMPILER_ typeprefix Dynamic "omg.org"; #endif // _PRE_3_0_COMPILER_ struct Parameter { any argument; CORBA::ParameterMode mode; }; typedef sequence ParameterList; typedef CORBA::StringSeq ContextList; typedef sequence ExceptionList; typedef CORBA::StringSeq RequestContext; }; // module Dynamic #endif // _DYNAMIC_IDL_ polyorb-2.8~20110207.orig/idls/Misc/PortableInterceptor.idl0000644000175000017500000001717611750740337022733 0ustar xavierxavier// File: PortableInterceptor.idl // CORBA 3.0, Chapter 21 #ifndef _PORTABLE_INTERCEPTOR_IDL_ #define _PORTABLE_INTERCEPTOR_IDL_ #ifdef _PRE_3_0_COMPILER_ #pragma prefix "omg.org" #include #include #include #include #else import ::CORBA; import ::IOP; import ::Messaging; import ::Dynamic; #endif // _PRE_3_0_COMPILER_ module PortableInterceptor { #ifndef _PRE_3_0_COMPILER_ typeprefix PortableInterceptor "omg.org"; #endif // _PRE_3_0_COMPILER_ local interface Interceptor { readonly attribute string name; }; exception ForwardRequest { Object forward; }; typedef short ReplyStatus; // Valid reply_status values: const ReplyStatus SUCCESSFUL = 0; const ReplyStatus SYSTEM_EXCEPTION = 1; const ReplyStatus USER_EXCEPTION = 2; const ReplyStatus LOCATION_FORWARD = 3; const ReplyStatus TRANSPORT_RETRY = 4; const ReplyStatus UNKNOWN = 5; typedef unsigned long SlotId; exception InvalidSlot {}; local interface Current : CORBA::Current { any get_slot (in SlotId id) raises (InvalidSlot); void set_slot (in SlotId id, in any data) raises (InvalidSlot); }; local interface RequestInfo { readonly attribute unsigned long request_id; readonly attribute string operation; readonly attribute Dynamic::ParameterList arguments; readonly attribute Dynamic::ExceptionList exceptions; readonly attribute Dynamic::ContextList contexts; readonly attribute Dynamic::RequestContext operation_context; readonly attribute any result; readonly attribute boolean response_expected; readonly attribute Messaging::SyncScope sync_scope; readonly attribute ReplyStatus reply_status; readonly attribute Object forward_reference; any get_slot (in SlotId id) raises (InvalidSlot); IOP::ServiceContext get_request_service_context ( in IOP::ServiceId id); IOP::ServiceContext get_reply_service_context ( in IOP::ServiceId id); }; local interface ClientRequestInfo : RequestInfo { readonly attribute Object target; readonly attribute Object effective_target; readonly attribute IOP::TaggedProfile effective_profile; readonly attribute any received_exception; readonly attribute CORBA::RepositoryId received_exception_id; IOP::TaggedComponent get_effective_component ( in IOP::ComponentId id); IOP::TaggedComponentSeq get_effective_components ( in IOP::ComponentId id); CORBA::Policy get_request_policy (in CORBA::PolicyType type); void add_request_service_context ( in IOP::ServiceContext service_context, in boolean replace); }; typedef string ServerId ; typedef string ORBId ; typedef CORBA::StringSeq AdapterName ; typedef CORBA::OctetSeq ObjectId ; local interface ServerRequestInfo : RequestInfo { readonly attribute any sending_exception; readonly attribute ServerId server_id; readonly attribute ORBId orb_id; readonly attribute AdapterName adapter_name; readonly attribute ObjectId object_id; readonly attribute CORBA::OctetSeq adapter_id; readonly attribute CORBA::RepositoryId target_most_derived_interface; CORBA::Policy get_server_policy (in CORBA::PolicyType type); void set_slot (in SlotId id, in any data) raises (InvalidSlot); boolean target_is_a (in CORBA::RepositoryId id); void add_reply_service_context ( in IOP::ServiceContext service_context, in boolean replace); }; local interface ClientRequestInterceptor : Interceptor { void send_request (in ClientRequestInfo ri) raises (ForwardRequest); void send_poll (in ClientRequestInfo ri); void receive_reply (in ClientRequestInfo ri); void receive_exception (in ClientRequestInfo ri) raises (ForwardRequest); void receive_other (in ClientRequestInfo ri) raises (ForwardRequest); }; local interface ServerRequestInterceptor : Interceptor { void receive_request_service_contexts (in ServerRequestInfo ri) raises (ForwardRequest); void receive_request (in ServerRequestInfo ri) raises (ForwardRequest); void send_reply (in ServerRequestInfo ri); void send_exception (in ServerRequestInfo ri) raises (ForwardRequest); void send_other (in ServerRequestInfo ri) raises (ForwardRequest); }; //PolyORB:NI: abstract valuetype ObjectReferenceFactory { //PolyORB:NI: Object make_object( in string repository_id, //PolyORB:NI: in ObjectId id ) ; //PolyORB:NI: }; //PolyORB:NI: //PolyORB:NI: abstract valuetype ObjectReferenceTemplate : //PolyORB:NI: ObjectReferenceFactory { //PolyORB:NI: readonly attribute ServerId server_id ; //PolyORB:NI: readonly attribute ORBId orb_id ; //PolyORB:NI: readonly attribute AdapterName adapter_name ; //PolyORB:NI: } ; //PolyORB:NI: //PolyORB:NI: typedef sequence ObjectReferenceTemplateSeq; typedef string AdapterManagerId; typedef short AdapterState ; const AdapterState HOLDING = 0 ; const AdapterState ACTIVE = 1 ; const AdapterState DISCARDING = 2 ; const AdapterState INACTIVE = 3 ; const AdapterState NON_EXISTENT = 4 ; local interface IORInfo { CORBA::Policy get_effective_policy (in CORBA::PolicyType type); void add_ior_component ( in IOP::TaggedComponent a_component); void add_ior_component_to_profile ( in IOP::TaggedComponent a_component, in IOP::ProfileId profile_id); }; local interface IORInterceptor : Interceptor { void establish_components (in IORInfo info); }; local interface IORInterceptor_3_0 : IORInterceptor { void components_established( in IORInfo info ); void adapter_manager_state_changed( in AdapterManagerId id, in AdapterState state ); //PolyORB:NI: void adapter_state_changed( //PolyORB:NI: in ObjectReferenceTemplateSeq templates, //PolyORB:NI: in AdapterState state); }; local interface PolicyFactory { CORBA::Policy create_policy ( in CORBA::PolicyType type, in any value) raises (CORBA::PolicyError); }; local interface ORBInitInfo { typedef string ObjectId; exception DuplicateName { string name; }; exception InvalidName {}; readonly attribute CORBA::StringSeq arguments; readonly attribute string orb_id; readonly attribute IOP::CodecFactory codec_factory; void register_initial_reference (in ObjectId id, in Object obj) raises (InvalidName); Object resolve_initial_references( in ObjectId id) raises (InvalidName); void add_client_request_interceptor ( in ClientRequestInterceptor interceptor) raises (DuplicateName); void add_server_request_interceptor ( in ServerRequestInterceptor interceptor) raises (DuplicateName); void add_ior_interceptor (in IORInterceptor interceptor) raises (DuplicateName); SlotId allocate_slot_id (); void register_policy_factory ( in CORBA::PolicyType type, in PolicyFactory policy_factory); }; local interface ORBInitializer { void pre_init (in ORBInitInfo info); void post_init (in ORBInitInfo info); }; }; // module PortableInterceptor #endif // _PORTABLE_INTERCEPTOR_IDL_ polyorb-2.8~20110207.orig/idls/Misc/MIOP.idl0000644000175000017500000000162211750740337017475 0ustar xavierxavier#ifndef _MIOP_IDL_ #define _MIOP_IDL_ #ifndef _PRE_3_0_COMPILER_ #pragma prefix "omg.org" #include #include #else import ::IOP; import ::GIOP; #endif //_PRE_3_0_COMPILER_ module MIOP { #ifndef _PRE_3_0_COMPILER_ typeprefix MIOP "omg.org"; #endif // _PRE_3_0_COMPILER_ typedef sequence UniqueId; struct PacketHeader_1_0 { char magic[4]; octet hdr_version; octet flags; unsigned short packet_length; unsigned long packet_number; unsigned long number_of_packets; UniqueId Id ; }; typedef GIOP::Version Version; typedef string Address; struct UIPMC_ProfileBody { Version miop_version; Address the_address; short the_port; sequence components; }; }; #endif polyorb-2.8~20110207.orig/idls/Misc/FT.idl0000644000175000017500000002400611750740337017243 0ustar xavierxavier// // File: FT.idl // CORBA 3.0 Chapter 23 #ifndef _FT_IDL_ #define _FT_IDL_ #ifdef _PRE_3_0_COMPILER_ #pragma prefix "omg.org" #include #include #include #include #include #include #include #else import ::TimeBase; import ::CosNaming; import ::CosEventComm; import ::CosNotification; import ::CosNotifyComm; import ::IOP; //PolyORB:IL:import ::GIOP; import ::CORBA; #endif // _PRE_3_0_COMPILER_ module FT { #ifndef _PRE_3_0_COMPILER_ typeprefix FT "omg.org"; #endif // _PRE_3_0_COMPILER_ // Specification for Interoperable Object Group References typedef string FTDomainId; typedef unsigned long long ObjectGroupId; typedef unsigned long ObjectGroupRefVersion; //PolyORB:IL: struct TagFTGroupTaggedComponent { // tag = TAG_FT_GROUP; //PolyORB:IL: GIOP::Version version; //PolyORB:IL: FTDomainId ft_domain_id; //PolyORB:IL: ObjectGroupId object_group_id; //PolyORB:IL: ObjectGroupRefVersion object_group_ref_version; //PolyORB:IL: }; struct TagFTPrimaryTaggedComponent { // tag = TAG_FT_PRIMARY; boolean primary; }; // Specification for Most Recent Object Group Reference struct FTGroupVersionServiceContext { //context_id = FT_GROUP_VERSION; ObjectGroupRefVersion object_group_ref_version; }; // Specification for Transparent Reinvocation const CORBA::PolicyType REQUEST_DURATION_POLICY = 47; struct FTRequestServiceContext { // context_id = FT_REQUEST; string client_id; long retention_id; TimeBase::TimeT expiration_time; }; //PolyORB:NI: interface RequestDurationPolicy : CORBA::Policy { //PolyORB:NI: readonly attribute TimeBase::TimeT request_duration_value; //PolyORB:NI: }; // Specification for Transport Heartbeats const CORBA::PolicyType HEARTBEAT_POLICY = 48; const CORBA::PolicyType HEARTBEAT_ENABLED_POLICY = 49; struct TagFTHeartbeatEnabledTaggedComponent { // tag = TAG_FT_HEARTBEAT_ENABLED; boolean heartbeat_enabled; }; struct HeartbeatPolicyValue { boolean heartbeat; TimeBase::TimeT heartbeat_interval; TimeBase::TimeT heartbeat_timeout; }; //PolyORB:NI: interface HeartbeatPolicy : CORBA::Policy { //PolyORB:NI: readonly attribute HeartbeatPolicyValue heartbeat_policy_value; //PolyORB:NI: }; //PolyORB:NI: interface HeartbeatEnabledPolicy : CORBA::Policy { //PolyORB:NI: readonly attribute boolean heartbeat_enabled_policy_value; //PolyORB:NI: }; // Specification of Common Types and Exceptions for ReplicationManager interface GenericFactory; interface FaultNotifier; typedef CORBA::RepositoryId _TypeId; typedef Object ObjectGroup; typedef CosNaming::Name Name; typedef any Value; struct Property { Name nam; Value val; }; typedef sequence Properties; typedef Name Location; typedef sequence Locations; typedef Properties Criteria; struct FactoryInfo { GenericFactory the_factory; Location the_location; Criteria the_criteria; }; typedef sequence FactoryInfos; typedef unsigned short ReplicationStyleValue; const ReplicationStyleValue STATELESS = 0; const ReplicationStyleValue COLD_PASSIVE = 1; const ReplicationStyleValue WARM_PASSIVE = 2; const ReplicationStyleValue ACTIVE = 3; const ReplicationStyleValue ACTIVE_WITH_VOTING = 4; typedef unsigned short MembershipStyleValue; const MembershipStyleValue MEMB_APP_CTRL = 0; const MembershipStyleValue MEMB_INF_CTRL = 1; typedef unsigned short ConsistencyStyleValue; const ConsistencyStyleValue CONS_APP_CTRL = 0; const ConsistencyStyleValue CONS_INF_CTRL = 1; typedef unsigned short FaultMonitoringStyleValue; const FaultMonitoringStyleValue PULL = 0; const FaultMonitoringStyleValue PUSH = 1; const FaultMonitoringStyleValue NOT_MONITORED = 2; typedef unsigned short FaultMonitoringGranularityValue; const FaultMonitoringGranularityValue MEMB = 0; const FaultMonitoringGranularityValue LOC = 1; const FaultMonitoringGranularityValue LOC_AND_TYPE = 2; typedef FactoryInfos FactoriesValue; typedef unsigned short InitialNumberReplicasValue; typedef unsigned short MinimumNumberReplicasValue; struct FaultMonitoringIntervalAndTimeoutValue { TimeBase::TimeT monitoring_interval; TimeBase::TimeT timeout; }; typedef TimeBase::TimeT CheckpointIntervalValue; exception InterfaceNotFound {}; exception ObjectGroupNotFound {}; exception MemberNotFound {}; exception ObjectNotFound {}; exception MemberAlreadyPresent {}; exception BadReplicationStyle {}; exception ObjectNotCreated {}; exception ObjectNotAdded {}; exception PrimaryNotSet {}; exception UnsupportedProperty { Name nam; Value val; }; exception InvalidProperty { Name nam; Value val; }; exception NoFactory { Location the_location; _TypeId type_id; }; exception InvalidCriteria { Criteria invalid_criteria; }; exception CannotMeetCriteria { Criteria unmet_criteria; }; // Specification of PropertyManager Interface // which ReplicationManager Inherits interface PropertyManager { void set_default_properties(in Properties props) raises (InvalidProperty, UnsupportedProperty); Properties get_default_properties(); void remove_default_properties(in Properties props) raises (InvalidProperty, UnsupportedProperty); void set_type_properties( in _TypeId type_id, in Properties overrides) raises (InvalidProperty, UnsupportedProperty); Properties get_type_properties(in _TypeId type_id); void remove_type_properties( in _TypeId type_id, in Properties props) raises (InvalidProperty, UnsupportedProperty); void set_properties_dynamically( in ObjectGroup object_group, in Properties overrides) raises(ObjectGroupNotFound, InvalidProperty, UnsupportedProperty); Properties get_properties(in ObjectGroup object_group) raises(ObjectGroupNotFound); }; // Specification of ObjectGroupManager Interface // which ReplicationManager Inherits interface ObjectGroupManager { ObjectGroup create_member( in ObjectGroup object_group, in Location the_location, in _TypeId type_id, in Criteria the_criteria) raises(ObjectGroupNotFound, MemberAlreadyPresent, NoFactory, ObjectNotCreated, InvalidCriteria, CannotMeetCriteria); ObjectGroup add_member( in ObjectGroup object_group, in Location the_location, in Object member) raises(ObjectGroupNotFound, MemberAlreadyPresent, ObjectNotAdded); ObjectGroup remove_member( in ObjectGroup object_group, in Location the_location) raises(ObjectGroupNotFound, MemberNotFound); ObjectGroup set_primary_member( in ObjectGroup object_group, in Location the_location) raises(ObjectGroupNotFound, MemberNotFound, PrimaryNotSet, BadReplicationStyle); Locations locations_of_members( in ObjectGroup object_group) raises(ObjectGroupNotFound); ObjectGroupId get_object_group_id( in ObjectGroup object_group) raises(ObjectGroupNotFound); ObjectGroup get_object_group_ref( in ObjectGroup object_group) raises(ObjectGroupNotFound); Object get_member_ref( in ObjectGroup object_group, in Location loc) raises(ObjectGroupNotFound, MemberNotFound); }; // Specification of GenericFactory Interface // which ReplicationManager Inherits and Application Objects Implement interface GenericFactory { typedef any FactoryCreationId; Object create_object(in _TypeId type_id, in Criteria the_criteria, out FactoryCreationId factory_creation_id) raises (NoFactory, ObjectNotCreated, InvalidCriteria, InvalidProperty, CannotMeetCriteria); void delete_object( in FactoryCreationId factory_creation_id) raises (ObjectNotFound); }; // Specification of ReplicationManager Interface interface ReplicationManager : PropertyManager, ObjectGroupManager, GenericFactory { void register_fault_notifier( in FaultNotifier fault_notifier); FaultNotifier get_fault_notifier() raises (InterfaceNotFound); }; // Specifications for Fault Management // Specification of PullMonitorable Interface // which Application Objects Inherit interface PullMonitorable { boolean is_alive(); }; // Specification of FaultNotifier Interface interface FaultNotifier { typedef unsigned long long ConsumerId; void push_structured_fault( in CosNotification::StructuredEvent event); void push_sequence_fault( in CosNotification::EventBatch events); ConsumerId connect_structured_fault_consumer( in CosNotifyComm::StructuredPushConsumer push_consumer); ConsumerId connect_sequence_fault_consumer( in CosNotifyComm::SequencePushConsumer push_consumer); void disconnect_consumer( in ConsumerId connection) raises(CosEventComm::Disconnected); void replace_constraint( in ConsumerId connection, in CosNotification::EventTypeSeq event_types, in string constr_expr); }; // Specifications for Logging and Recovery typedef sequence State; exception NoStateAvailable {}; exception InvalidState {}; exception NoUpdateAvailable {}; exception InvalidUpdate {}; // Specification of Checkpointable Interface // which Updateable and Application Objects Inherit interface Checkpointable { State get_state() raises(NoStateAvailable); void set_state(in State s) raises(InvalidState); }; // Specification of Updateable Interface // which Application Objects Inherit interface Updateable : Checkpointable { State get_update() raises(NoUpdateAvailable); void set_update(in State s) raises(InvalidUpdate); }; }; #endif // for #ifndef _FT_IDL_ polyorb-2.8~20110207.orig/idls/Misc/PortableGroup.idl0000644000175000017500000001751011750740337021521 0ustar xavierxavier#ifndef _PortableGroup_IDL_ #define _PortableGroup_IDL_ #ifdef _PRE_3_0_COMPILER_ //PolyORB:WACORBA: was #ifndef in original spec #pragma prefix "omg.org" #include // CORBA 3.0, Chapter 11 //PolyORB::NI:#include // 98-10-19.idl //PolyORB::NI:#include // from 98-03-01.idl //PolyORB::NI:#include "GIOP.idl"// from 98-03-01.idl #include #else //PolyORB::NI:import ::IOP; //PolyORB::NI:import ::GIOP; import ::CORBA; //PolyORB::IL:import ::PortableServer::POA; import ::PortableServer; import ::CosNaming; //PolyORB:WACORBA: was missing #endif //_PRE_3_0_COMPILER_ module PortableGroup { #ifndef _PRE_3_0_COMPILER_ typeprefix PortableGroup "omg.org"; #endif // _PRE_3_0_COMPILER_ // Specification for Interoperable Object Group References //PolyORB::NI: typedef GIOP::Version Version; //PolyORB::NI: typedef string GroupDomainId; //PolyORB::NI: typedef unsigned long long ObjectGroupId; //PolyORB::NI: typedef unsigned long ObjectGroupRefVersion; //PolyORB::NI: struct TagGroupTaggedComponent { // tag = TAG_GROUP; //PolyORB::NI: GIOP::Version group_version; //PolyORB::NI: GroupDomainId group_domain_id; //PolyORB::NI: ObjectGroupId object_group_id; //PolyORB::NI: ObjectGroupRefVersion object_group_ref_version; //PolyORB::NI: }; //PolyORB::NI: typedef sequence GroupIIOPProfile; // tag = TAG_GROUP_IIOP // Specification of Common Types and Exceptions // for GroupManagement //PolyORB::NI: interface GenericFactory; //PolyORB::NI: typedef CORBA::RepositoryId _TypeId; //PolyORB::NI: typedef Object ObjectGroup; //PolyORB::NI: typedef CosNaming::Name Name; //PolyORB::NI: typedef any Value; //PolyORB::NI: struct Property { //PolyORB::NI: Name nam; //PolyORB::NI: Value val; //PolyORB::NI: }; //PolyORB::NI: typedef sequence Properties; //PolyORB::NI: typedef Name Location; //PolyORB::NI: typedef sequence Locations; //PolyORB::NI: typedef Properties Criteria; //PolyORB::NI: struct FactoryInfo { //PolyORB::NI: GenericFactory the_factory; //PolyORB::NI: Location the_location; //PolyORB::NI: Criteria the_criteria; //PolyORB::NI: }; //PolyORB::NI: typedef sequence FactoryInfos; //PolyORB::NI: typedef long MembershipStyleValue; //PolyORB::NI: const MembershipStyleValue MEMB_APP_CTRL = 0; //PolyORB::NI: const MembershipStyleValue MEMB_INF_CTRL = 1; //PolyORB::NI: typedef unsigned short InitialNumberReplicasValue; //PolyORB::NI: typedef unsigned short MinimumNumberReplicasValue; //PolyORB::NI: exception InterfaceNotFound {}; //PolyORB::NI: exception ObjectGroupNotFound {}; //PolyORB::NI: exception MemberNotFound {}; //PolyORB::NI: exception ObjectNotFound {}; //PolyORB::NI: exception MemberAlreadyPresent {}; //PolyORB::NI: exception BadReplicationStyle {}; //PolyORB::NI: exception ObjectNotCreated {}; //PolyORB::NI: exception ObjectNotAdded {}; //PolyORB::NI: exception UnsupportedProperty { //PolyORB::NI: Name nam; //PolyORB::NI: }; //PolyORB::NI: exception InvalidProperty { //PolyORB::NI: Name nam; //PolyORB::NI: Value val; //PolyORB::NI: }; //PolyORB::NI: exception NoFactory { //PolyORB::NI: Location the_location; //PolyORB::NI: _TypeId type_id; //PolyORB::NI: }; //PolyORB::NI: exception InvalidCriteria { //PolyORB::NI: Criteria invalid_criteria; //PolyORB::NI: }; //PolyORB::NI: exception CannotMeetCriteria { //PolyORB::NI: Criteria unmet_criteria; //PolyORB::NI: }; // Specification of PropertyManager Interface //PolyORB::NI: interface PropertyManager { //PolyORB::NI: void set_default_properties //PolyORB::NI: (in Properties props) //PolyORB::NI: raises (InvalidProperty, UnsupportedProperty); //PolyORB::NI: Properties get_default_properties(); //PolyORB::NI: void remove_default_properties //PolyORB::NI: (in Properties props) //PolyORB::NI: raises (InvalidProperty, UnsupportedProperty); //PolyORB::NI: void set_type_properties //PolyORB::NI: (in _TypeId type_id, in Properties overrides) //PolyORB::NI: raises (InvalidProperty, UnsupportedProperty); //PolyORB::NI: Properties get_type_properties(in _TypeId type_id); //PolyORB::NI: void remove_type_properties //PolyORB::NI: (in _TypeId type_id, in Properties props) //PolyORB::NI: raises (InvalidProperty, UnsupportedProperty); //PolyORB::NI: void set_properties_dynamically //PolyORB::NI: (in ObjectGroup object_group, in Properties overrides) //PolyORB::NI: raises //PolyORB::NI: (ObjectGroupNotFound, //PolyORB::NI: InvalidProperty, //PolyORB::NI: UnsupportedProperty); //PolyORB::NI: Properties get_properties //PolyORB::NI: (in ObjectGroup object_group) //PolyORB::NI: raises(ObjectGroupNotFound); //PolyORB::NI: }; // endPropertyManager // Specification of ObjectGroupManager Interface //PolyORB::NI: interface ObjectGroupManager { //PolyORB::NI: ObjectGroup create_member //PolyORB::NI: (in ObjectGroup object_group, //PolyORB::NI: in Location the_location, //PolyORB::NI: in _TypeId type_id, //PolyORB::NI: in Criteria the_criteria) //PolyORB::NI: raises //PolyORB::NI: (ObjectGroupNotFound, //PolyORB::NI: MemberAlreadyPresent, //PolyORB::NI: NoFactory, //PolyORB::NI: ObjectNotCreated, //PolyORB::NI: InvalidCriteria, //PolyORB::NI: CannotMeetCriteria); //PolyORB::NI: ObjectGroup add_member //PolyORB::NI: (in ObjectGroup object_group, //PolyORB::NI: in Location the_location, //PolyORB::NI: in Object member) //PolyORB::NI: raises //PolyORB::NI: (ObjectGroupNotFound, //PolyORB::NI: CORBA::INV_OBJREF, //PolyORB::NI: MemberAlreadyPresent, //PolyORB::NI: ObjectNotAdded); //PolyORB::NI: ObjectGroup remove_member //PolyORB::NI: (in ObjectGroup object_group, //PolyORB::NI: in Location the_location) //PolyORB::NI: raises //PolyORB::NI: (ObjectGroupNotFound, MemberNotFound); //PolyORB::NI: Locations locations_of_members //PolyORB::NI: (in ObjectGroup object_group) raises(ObjectGroupNotFound); //PolyORB::NI: ObjectGroupId get_object_group_id //PolyORB::NI: (in ObjectGroup object_group) raises(ObjectGroupNotFound); //PolyORB::NI: ObjectGroup get_object_group_ref //PolyORB::NI: (in ObjectGroup object_group) raises(ObjectGroupNotFound); //PolyORB::NI: Object get_member_ref //PolyORB::NI: (in ObjectGroup object_group, //PolyORB::NI: in Location loc) //PolyORB::NI: raises(ObjectGroupNotFound, MemberNotFound); //PolyORB::NI: }; // end ObjectGroupManager // Specification of GenericFactory Interface //PolyORB::NI: interface GenericFactory { //PolyORB::NI: typedef any FactoryCreationId; //PolyORB::NI: Object create_object //PolyORB::NI: (in _TypeId type_id, //PolyORB::NI: in Criteria the_criteria, //PolyORB::NI: out FactoryCreationId factory_creation_id) //PolyORB::NI: raises //PolyORB::NI: (NoFactory, //PolyORB::NI: ObjectNotCreated, //PolyORB::NI: InvalidCriteria, //PolyORB::NI: InvalidProperty, //PolyORB::NI: CannotMeetCriteria); //PolyORB::NI: void delete_object //PolyORB::NI: (in FactoryCreationId factory_creation_id) //PolyORB::NI: raises (ObjectNotFound); //PolyORB::NI: }; // end GenericFactory exception NotAGroupObject {}; typedef sequence IDs; local interface GOA : PortableServer::POA { PortableServer::ObjectId create_id_for_reference(in Object the_ref) raises (NotAGroupObject); IDs reference_to_ids (in Object the_ref) raises (NotAGroupObject); void associate_reference_with_id (in Object ref, in PortableServer::ObjectId oid) raises(NotAGroupObject); void disassociate_reference_with_id (in Object ref, in PortableServer::ObjectId oid) raises(NotAGroupObject); }; // end interface GOA }; // end PortableGroup #endif // for #ifndef _PortableGroup_IDL_ polyorb-2.8~20110207.orig/idls/Misc/DynamicAny.idl0000644000175000017500000003153611750740337020774 0ustar xavierxavier// File: DynamicAny.idl // CORBA 3.0, Chapter 9 #ifndef _DYNAMIC_ANY_IDL_ #define _DYNAMIC_ANY_IDL_ #ifdef _PRE_3_0_COMPILER_ #pragma prefix "omg.org" #include #else import ::CORBA; #endif // _PRE_3_0_COMPILER_ module DynamicAny { #ifndef _PRE_3_0_COMPILER_ typeprefix DynamicAny "omg.org"; #endif // _PRE_3_0_COMPILER_ local interface DynAny { exception InvalidValue {}; exception TypeMismatch {}; CORBA::TypeCode type(); void assign( in DynAny dyn_any) raises(TypeMismatch); void from_any( in any value) raises(TypeMismatch, InvalidValue); any to_any(); boolean equal( in DynAny dyn_any); void destroy(); DynAny copy(); void insert_boolean(in boolean value) raises(TypeMismatch, InvalidValue); void insert_octet( in octet value) raises(TypeMismatch, InvalidValue); void insert_char( in char value) raises(TypeMismatch, InvalidValue); void insert_short( in short value) raises(TypeMismatch, InvalidValue); void insert_ushort( in unsigned short value) raises(TypeMismatch, InvalidValue); void insert_long( in long value) raises(TypeMismatch, InvalidValue); void insert_ulong( in unsigned long value) raises(TypeMismatch, InvalidValue); void insert_float( in float value) raises(TypeMismatch, InvalidValue); void insert_double( in double value) raises(TypeMismatch, InvalidValue); void insert_string( in string value) raises(TypeMismatch, InvalidValue); //PolyORB:NI: void insert_reference(in Object value) //PolyORB:NI: raises(TypeMismatch, InvalidValue); void insert_typecode(in CORBA::TypeCode value) raises(TypeMismatch, InvalidValue); void insert_longlong(in long long value) raises(TypeMismatch, InvalidValue); void insert_ulonglong(in unsigned long long value) raises(TypeMismatch, InvalidValue); void insert_longdouble(in long double value) raises(TypeMismatch, InvalidValue); void insert_wchar( in wchar value) raises(TypeMismatch, InvalidValue); void insert_wstring(in wstring value) raises(TypeMismatch, InvalidValue); void insert_any( in any value) raises(TypeMismatch, InvalidValue); void insert_dyn_any(in DynAny value) raises(TypeMismatch, InvalidValue); //PolyORB:NI: void insert_val( in ValueBase value) //PolyORB:NI: raises(TypeMismatch, InvalidValue); boolean get_boolean() raises(TypeMismatch, InvalidValue); octet get_octet() raises(TypeMismatch, InvalidValue); char get_char() raises(TypeMismatch, InvalidValue); short get_short() raises(TypeMismatch, InvalidValue); unsigned short get_ushort() raises(TypeMismatch, InvalidValue); long get_long() raises(TypeMismatch, InvalidValue); unsigned long get_ulong() raises(TypeMismatch, InvalidValue); float get_float() raises(TypeMismatch, InvalidValue); double get_double() raises(TypeMismatch, InvalidValue); string get_string() raises(TypeMismatch, InvalidValue); //PolyORB:NI: Object get_reference() //PolyORB:NI: raises(TypeMismatch, InvalidValue); CORBA::TypeCode get_typecode() raises(TypeMismatch, InvalidValue); long long get_longlong() raises(TypeMismatch, InvalidValue); unsigned long long get_ulonglong() raises(TypeMismatch, InvalidValue); long double get_longdouble() raises(TypeMismatch, InvalidValue); wchar get_wchar() raises(TypeMismatch, InvalidValue); wstring get_wstring() raises(TypeMismatch, InvalidValue); any get_any() raises(TypeMismatch, InvalidValue); DynAny get_dyn_any() raises(TypeMismatch, InvalidValue); //PolyORB:NI: ValueBase get_val() //PolyORB:NI: raises(TypeMismatch, InvalidValue); boolean seek(in long index); void rewind(); boolean next(); unsigned long component_count(); DynAny current_component() raises(TypeMismatch); //PolyORB:NI: void insert_abstract(in CORBA::AbstractBase value) //PolyORB:NI: raises(TypeMismatch, InvalidValue); //PolyORB:NI: CORBA::AbstractBase get_abstract() //PolyORB:NI: raises(TypeMismatch, InvalidValue); //PolyORB:NI: //PolyORB:NI: void insert_boolean_seq(in CORBA::BooleanSeq value) //PolyORB:NI: raises(TypeMismatch, InvalidValue); //PolyORB:NI: void insert_octet_seq(in CORBA::OctetSeq value) //PolyORB:NI: raises(TypeMismatch, InvalidValue); //PolyORB:NI: void insert_char_seq(in CORBA::CharSeq value) //PolyORB:NI: raises(TypeMismatch, InvalidValue); //PolyORB:NI: void insert_short_seq(in CORBA::ShortSeq value) //PolyORB:NI: raises(TypeMismatch, InvalidValue); //PolyORB:NI: void insert_ushort_seq(in CORBA::UShortSeq value) //PolyORB:NI: raises(TypeMismatch, InvalidValue); //PolyORB:NI: void insert_long_seq(in CORBA::LongSeq value) //PolyORB:NI: raises(TypeMismatch, InvalidValue); //PolyORB:NI: void insert_ulong_seq(in CORBA::ULongSeq value) //PolyORB:NI: raises(TypeMismatch, InvalidValue); //PolyORB:NI: void insert_float_seq(in CORBA::FloatSeq value) //PolyORB:NI: raises(TypeMismatch, InvalidValue); //PolyORB:NI: void insert_double_seq(in CORBA::DoubleSeq value) //PolyORB:NI: raises(TypeMismatch, InvalidValue); //PolyORB:NI: void insert_longlong_seq(in CORBA::LongLongSeq value) //PolyORB:NI: raises(TypeMismatch, InvalidValue); //PolyORB:NI: void insert_ulonglong_seq(in CORBA::ULongLongSeq value) //PolyORB:NI: raises(TypeMismatch, InvalidValue); //PolyORB:NI: void insert_longdouble_seq(in CORBA::LongDoubleSeq value) //PolyORB:NI: raises(TypeMismatch, InvalidValue); //PolyORB:NI: void insert_wchar_seq(in CORBA::WCharSeq value) //PolyORB:NI: raises(TypeMismatch, InvalidValue); //PolyORB:NI: CORBA::BooleanSeq get_boolean_seq() //PolyORB:NI: raises(TypeMismatch, InvalidValue); //PolyORB:NI: CORBA::OctetSeq get_octet_seq() //PolyORB:NI: raises(TypeMismatch, InvalidValue); //PolyORB:NI: CORBA::CharSeq get_char_seq() //PolyORB:NI: raises(TypeMismatch, InvalidValue); //PolyORB:NI: CORBA::ShortSeq get_short_seq() //PolyORB:NI: raises(TypeMismatch, InvalidValue); //PolyORB:NI: CORBA::UShortSeq get_ushort_seq() //PolyORB:NI: raises(TypeMismatch, InvalidValue); //PolyORB:NI: CORBA::LongSeq get_long_seq() //PolyORB:NI: raises(TypeMismatch, InvalidValue); //PolyORB:NI: CORBA::ULongSeq get_ulong_seq() //PolyORB:NI: raises(TypeMismatch, InvalidValue); //PolyORB:NI: CORBA::FloatSeq get_float_seq() //PolyORB:NI: raises(TypeMismatch, InvalidValue); //PolyORB:NI: CORBA::DoubleSeq get_double_seq() //PolyORB:NI: raises(TypeMismatch, InvalidValue); //PolyORB:NI: CORBA::LongLongSeq get_longlong_seq() //PolyORB:NI: raises(TypeMismatch, InvalidValue); //PolyORB:NI: CORBA::ULongLongSeq get_ulonglong_seq() //PolyORB:NI: raises(TypeMismatch, InvalidValue); //PolyORB:NI: CORBA::LongDoubleSeq get_longdouble_seq() //PolyORB:NI: raises(TypeMismatch, InvalidValue); //PolyORB:NI: CORBA::WCharSeq get_wchar_seq() //PolyORB:NI: raises(TypeMismatch, InvalidValue); }; local interface DynFixed : DynAny { string get_value(); boolean set_value(in string val) raises(TypeMismatch, InvalidValue); }; local interface DynEnum : DynAny { string get_as_string(); void set_as_string(in string value) raises(InvalidValue); unsigned long get_as_ulong(); void set_as_ulong( in unsigned long value) raises(InvalidValue); }; typedef string FieldName; struct NameValuePair { FieldName id; any value; }; typedef sequence NameValuePairSeq; struct NameDynAnyPair { FieldName id; DynAny value; }; typedef sequence NameDynAnyPairSeq; local interface DynStruct : DynAny { FieldName current_member_name() raises(TypeMismatch, InvalidValue); CORBA::TCKind current_member_kind() raises(TypeMismatch, InvalidValue); NameValuePairSeq get_members(); void set_members(in NameValuePairSeq value) raises(TypeMismatch, InvalidValue); NameDynAnyPairSeq get_members_as_dyn_any(); void set_members_as_dyn_any(in NameDynAnyPairSeq value) raises(TypeMismatch, InvalidValue); }; local interface DynUnion : DynAny { DynAny get_discriminator(); void set_discriminator(in DynAny d) raises(TypeMismatch); void set_to_default_member() raises(TypeMismatch); void set_to_no_active_member() raises(TypeMismatch); boolean has_no_active_member(); CORBA::TCKind discriminator_kind(); DynAny member() raises(InvalidValue); FieldName member_name() raises(InvalidValue); CORBA::TCKind member_kind() raises(InvalidValue); }; typedef sequence AnySeq; typedef sequence DynAnySeq; local interface DynSequence : DynAny { unsigned long get_length(); void set_length(in unsigned long len) raises(InvalidValue); AnySeq get_elements(); void set_elements(in AnySeq value) raises(TypeMismatch, InvalidValue); DynAnySeq get_elements_as_dyn_any(); void set_elements_as_dyn_any(in DynAnySeq value) raises(TypeMismatch, InvalidValue); }; local interface DynArray : DynAny { AnySeq get_elements(); void set_elements(in AnySeq value) raises(TypeMismatch, InvalidValue); DynAnySeq get_elements_as_dyn_any(); void set_elements_as_dyn_any(in DynAnySeq value) raises(TypeMismatch, InvalidValue); }; local interface DynValueCommon : DynAny { boolean is_null(); void set_to_null(); void set_to_value(); }; local interface DynValue : DynValueCommon { FieldName current_member_name() raises(TypeMismatch, InvalidValue); CORBA::TCKind current_member_kind() raises(TypeMismatch, InvalidValue); NameValuePairSeq get_members() raises(InvalidValue); void set_members(in NameValuePairSeq value) raises(TypeMismatch, InvalidValue); NameDynAnyPairSeq get_members_as_dyn_any() raises(InvalidValue); void set_members_as_dyn_any(in NameDynAnyPairSeq value) raises(TypeMismatch, InvalidValue); }; local interface DynValueBox : DynValueCommon { any get_boxed_value() raises(InvalidValue); void set_boxed_value(in any boxed) raises(TypeMismatch, InvalidValue); DynAny get_boxed_value_as_dyn_any() raises(InvalidValue); void set_boxed_value_as_dyn_any(in DynAny boxed) raises(TypeMismatch); }; exception MustTruncate { }; local interface DynAnyFactory { exception InconsistentTypeCode {}; DynAny create_dyn_any(in any value) raises(InconsistentTypeCode); //PolyORB:NI: DynAny create_dyn_any_from_type_code(in CORBA::TypeCode type) //PolyORB:NI: raises(InconsistentTypeCode); DynAny create_dyn_any_without_truncation(in any value) raises(InconsistentTypeCode, MustTruncate); //PolyORB:NI: DynAnySeq create_multiple_dyn_anys( //PolyORB:NI: in AnySeq values, //PolyORB:NI: in boolean allow_truncate) //PolyORB:NI: raises(InconsistentTypeCode, MustTruncate); //PolyORB:NI: AnySeq create_multiple_anys(in DynAnySeq values); }; }; // module DynamicAny #endif // _DYNAMIC_ANY_IDL_ polyorb-2.8~20110207.orig/idls/Misc/PortableServer.idl0000644000175000017500000002535511750740337021701 0ustar xavierxavier// File: PortableServer.idl // CORBA 3.0, Chapter 11 #ifndef _PORTABLE_SERVER_IDL_ #define _PORTABLE_SERVER_IDL_ #ifdef _PRE_3_0_COMPILER_ #pragma prefix "omg.org" #include #else import ::CORBA; #endif // _PRE_3_0_COMPILER_ // Most IDL compilers don't accept the "native" keyword in application IDL // files. In order to compile an IDL (really PIDL) file that has it, the // following trick can be used: change what the compiler sees. Instead // of letting the compiler see the keyword "native", use a preprocessor // definition that results in valid IDL, even if it doesn't yield // useful stubs and skeletons. Of course, PIDL never results in // the standard stubs so that's not a problem. // // Set the variable _MASK_NATIVE_ in the IDL compiler to enable it to // parse this file. #ifdef _MASK_NATIVE_ #define native typedef long #endif // _MASK_NATIVE_ module PortableServer { #ifndef _PRE_3_0_COMPILER_ typeprefix PortableServer "omg.org"; #endif // _PRE_3_0_COMPILER_ local interface POA; // forward declaration typedef sequence POAList; native Servant; typedef CORBA::OctetSeq ObjectId; exception ForwardRequest { Object forward_reference; }; // Policy interfaces const CORBA::PolicyType THREAD_POLICY_ID = 16; const CORBA::PolicyType LIFESPAN_POLICY_ID = 17; const CORBA::PolicyType ID_UNIQUENESS_POLICY_ID = 18; const CORBA::PolicyType ID_ASSIGNMENT_POLICY_ID = 19; const CORBA::PolicyType IMPLICIT_ACTIVATION_POLICY_ID = 20; const CORBA::PolicyType SERVANT_RETENTION_POLICY_ID = 21; const CORBA::PolicyType REQUEST_PROCESSING_POLICY_ID = 22; enum ThreadPolicyValue { ORB_CTRL_MODEL, SINGLE_THREAD_MODEL, MAIN_THREAD_MODEL }; local interface ThreadPolicy : CORBA::Policy { readonly attribute ThreadPolicyValue value; }; enum LifespanPolicyValue { TRANSIENT, PERSISTENT }; local interface LifespanPolicy : CORBA::Policy { readonly attribute LifespanPolicyValue value; }; enum IdUniquenessPolicyValue { UNIQUE_ID, MULTIPLE_ID }; local interface IdUniquenessPolicy : CORBA::Policy { readonly attribute IdUniquenessPolicyValue value; }; enum IdAssignmentPolicyValue { USER_ID, SYSTEM_ID }; local interface IdAssignmentPolicy : CORBA::Policy { readonly attribute IdAssignmentPolicyValue value; }; enum ImplicitActivationPolicyValue { IMPLICIT_ACTIVATION, NO_IMPLICIT_ACTIVATION }; local interface ImplicitActivationPolicy : CORBA::Policy { readonly attribute ImplicitActivationPolicyValue value; }; enum ServantRetentionPolicyValue { RETAIN, NON_RETAIN }; local interface ServantRetentionPolicy : CORBA::Policy { readonly attribute ServantRetentionPolicyValue value; }; enum RequestProcessingPolicyValue { USE_ACTIVE_OBJECT_MAP_ONLY, USE_DEFAULT_SERVANT, USE_SERVANT_MANAGER }; local interface RequestProcessingPolicy : CORBA::Policy { readonly attribute RequestProcessingPolicyValue value; }; // POAManager interface local interface POAManager { exception AdapterInactive{}; enum State {HOLDING, ACTIVE, DISCARDING, INACTIVE}; void activate() raises(AdapterInactive); void hold_requests( in boolean wait_for_completion) raises(AdapterInactive); void discard_requests( in boolean wait_for_completion) raises(AdapterInactive); void deactivate( in boolean etherealize_objects, in boolean wait_for_completion) raises(AdapterInactive); State get_state(); //PolyORB:NI: string get_id(); }; //PolyORB:NI: // PoaManagerFactory //PolyORB:NI: local interface POAManagerFactory { //PolyORB:NI: typedef sequence POAManagerSeq; //PolyORB:NI: exception ManagerAlreadyExists {}; //PolyORB:NI: POAManager create_POAManager( //PolyORB:NI: in string id, //PolyORB:NI: in CORBA::PolicyList policies //PolyORB:NI: ) raises(ManagerAlreadyExists, CORBA::PolicyError); //PolyORB:NI: POAManagerSeq list(); //PolyORB:NI: POAManager find( in string id); //PolyORB:NI: }; // AdapterActivator interface local interface AdapterActivator { boolean unknown_adapter(in POA parent, in string name); }; // ServantManager interface local interface ServantManager{ }; local interface ServantActivator : ServantManager { Servant incarnate ( in ObjectId oid, in POA adapter) raises (ForwardRequest); void etherealize ( in ObjectId oid, in POA adapter, in Servant serv, in boolean cleanup_in_progress, in boolean remaining_activations); }; local interface ServantLocator : ServantManager { native Cookie; //PolyORB:IL: Servant preinvoke( in ObjectId oid, //PolyORB:IL: in POA adapter, //PolyORB:IL: in CORBA::Identifier //PolyORB:IL: operation, //PolyORB:IL: out Cookie the_cookie) //PolyORB:IL: raises (ForwardRequest); //PolyORB:IL: void postinvoke( in ObjectId oid, //PolyORB:IL: in POA adapter, //PolyORB:IL: in CORBA::Identifier //PolyORB:IL: operation, //PolyORB:IL: in Cookie the_cookie, //PolyORB:IL: in Servant the_servant ); }; local interface POA { exception AdapterAlreadyExists {}; exception AdapterNonExistent {}; exception InvalidPolicy {unsigned short index;}; exception NoServant {}; exception ObjectAlreadyActive {}; exception ObjectNotActive {}; exception ServantAlreadyActive {}; exception ServantNotActive {}; exception WrongAdapter {}; exception WrongPolicy {}; // POA creation and destruction POA create_POA( in string adapter_name, in POAManager a_POAManager, in CORBA::PolicyList policies) raises (AdapterAlreadyExists, InvalidPolicy); POA find_POA( in string adapter_name, in boolean activate_it) raises (AdapterNonExistent); void destroy( in boolean etherealize_objects, in boolean wait_for_completion); // Factories for Policy objects ThreadPolicy create_thread_policy(in ThreadPolicyValue value); LifespanPolicy create_lifespan_policy(in LifespanPolicyValue value); IdUniquenessPolicy create_id_uniqueness_policy( in IdUniquenessPolicyValue value); IdAssignmentPolicy create_id_assignment_policy( in IdAssignmentPolicyValue value); ImplicitActivationPolicy create_implicit_activation_policy( in ImplicitActivationPolicyValue value); ServantRetentionPolicy create_servant_retention_policy( in ServantRetentionPolicyValue value); RequestProcessingPolicy create_request_processing_policy( in RequestProcessingPolicyValue value); // POA attributes readonly attribute string the_name; readonly attribute POA the_parent; readonly attribute POAList the_children; readonly attribute POAManager the_POAManager; attribute AdapterActivator the_activator; // Servant Manager registration: ServantManager get_servant_manager() raises (WrongPolicy); void set_servant_manager(in ServantManager imgr) raises (WrongPolicy); // operations for the USE_DEFAULT_SERVANT policy Servant get_servant() raises (NoServant, WrongPolicy); void set_servant( in Servant p_servant) raises (WrongPolicy); // object activation and deactivation ObjectId activate_object(in Servant p_servant) raises (ServantAlreadyActive, WrongPolicy); void activate_object_with_id(in ObjectId id, in Servant p_servant) raises (ServantAlreadyActive, ObjectAlreadyActive, WrongPolicy); void deactivate_object( in ObjectId oid) raises (ObjectNotActive, WrongPolicy); // reference creation operations Object create_reference ( in CORBA::RepositoryId intf) raises (WrongPolicy); Object create_reference_with_id ( in ObjectId oid, in CORBA::RepositoryId intf); // Identity mapping operations: ObjectId servant_to_id( in Servant p_servant) raises (ServantNotActive, WrongPolicy); Object servant_to_reference(in Servant p_servant) raises (ServantNotActive, WrongPolicy); Servant reference_to_servant(in Object reference) raises(ObjectNotActive, WrongAdapter, WrongPolicy); ObjectId reference_to_id( in Object reference) raises (WrongAdapter, WrongPolicy); Servant id_to_servant( in ObjectId oid) raises (ObjectNotActive, WrongPolicy); Object id_to_reference( in ObjectId oid) raises (ObjectNotActive, WrongPolicy); //PolyORB:NI: readonly attribute CORBA::OctetSeq id; //PolyORB:NI: readonly attribute POAManagerFactory the_POAManagerFactory; }; // Current interface local interface Current : CORBA::Current { exception NoContext { }; POA get_POA() raises (NoContext); ObjectId get_object_id() raises (NoContext); Object get_reference() raises (NoContext); Servant get_servant() raises (NoContext); }; }; #endif // _PORTABLE_SERVER_IDL_ polyorb-2.8~20110207.orig/idls/Misc/MessageRouting.idl0000644000175000017500000001431711750740337021672 0ustar xavierxavier// File: MessageRouting.idl // CORBA 3.0, Chapter 22 #ifndef _MESSAGE_ROUTING_IDL_ #define _MESSAGE_ROUTING_IDL_ #ifdef _PRE_3_0_COMPILER_ #pragma prefix "omg.org" #include #include #include #include #else //PolyORB:NI:import ::CORBA; //PolyORB:NI:import ::GIOP; //PolyORB:NI:import ::IOP; //PolyORB:NI:import ::Messaging; #endif // _PRE_3_0_COMPILER_ //PolyORB:NI:module MessageRouting{ //PolyORB:NI: //PolyORB:NI:#ifndef _PRE_3_0_COMPILER_ //PolyORB:NI: typeprefix MessageRouting "omg.org"; //PolyORB:NI:#endif // _PRE_3_0_COMPILER_ //PolyORB:NI: //PolyORB:NI: // Basic routing Interoperability //PolyORB:NI: //PolyORB:NI: interface Router; //PolyORB:NI: interface RouterAdmin; //PolyORB:NI: //PolyORB:NI: typedef sequence RouterList; //PolyORB:NI: //PolyORB:NI: struct MessageBody { //PolyORB:NI: sequence body; //PolyORB:NI: boolean byte_order; //PolyORB:NI: }; //PolyORB:NI: //PolyORB:NI: struct RequestMessage { //PolyORB:NI: GIOP::Version giop_version; //PolyORB:NI: IOP::ServiceContextList service_contexts; //PolyORB:NI: octet response_flags; //PolyORB:NI: octet reserved[3]; //PolyORB:NI: sequence object_key; //PolyORB:NI: string operation; //PolyORB:NI: MessageBody body; //PolyORB:NI: }; //PolyORB:NI: //PolyORB:NI: enum ReplyDisposition { TYPED, UNTYPED }; //PolyORB:NI: //PolyORB:NI: struct ReplyDestination { //PolyORB:NI: ReplyDisposition handler_type; //PolyORB:NI: Messaging::ReplyHandler handler; //PolyORB:NI: sequence typed_excep_holder_repids; //PolyORB:NI: }; //PolyORB:NI: //PolyORB:NI: struct RequestInfo { //PolyORB:NI: RouterList visited; //PolyORB:NI: RouterList to_visit; //PolyORB:NI: Object target; //PolyORB:NI: unsigned short profile_index; //PolyORB:NI: ReplyDestination reply_destination; //PolyORB:NI: Messaging::PolicyValueSeq selected_qos; //PolyORB:NI: RequestMessage payload; //PolyORB:NI: }; //PolyORB:NI: //PolyORB:NI: typedef sequence RequestInfoSeq; //PolyORB:NI: //PolyORB:NI: interface Router { //PolyORB:NI: void send_request(in RequestInfo req); //PolyORB:NI: void send_multiple_requests(in RequestInfoSeq reqSeq); //PolyORB:NI: //PolyORB:NI: readonly attribute RouterAdmin admin; //PolyORB:NI: }; //PolyORB:NI: //PolyORB:NI: // Polling-related interfaces //PolyORB:NI: //PolyORB:NI: interface UntypedReplyHandler : Messaging::ReplyHandler { //PolyORB:NI: void reply( //PolyORB:NI: in string operation_name, //PolyORB:NI: in GIOP::ReplyStatusType reply_type, //PolyORB:NI: in MessageBody reply_body); //PolyORB:NI: }; //PolyORB:NI: //PolyORB:NI: exception ReplyNotAvailable { }; //PolyORB:NI: //PolyORB:NI: interface PersistentRequest { //PolyORB:NI: readonly attribute boolean reply_available; //PolyORB:NI: GIOP::ReplyStatusType get_reply( //PolyORB:NI: in boolean blocking, //PolyORB:NI: in unsigned long timeout, //PolyORB:NI: out MessageBody reply_body) //PolyORB:NI: raises (ReplyNotAvailable); //PolyORB:NI: attribute Messaging::ReplyHandler associated_handler; //PolyORB:NI: }; //PolyORB:NI: //PolyORB:NI: interface PersistentRequestRouter { //PolyORB:NI: PersistentRequest create_persistent_request( //PolyORB:NI: in unsigned short profile_index, //PolyORB:NI: in RouterList to_visit, //PolyORB:NI: in Object target, //PolyORB:NI: in CORBA::PolicyList current_qos, //PolyORB:NI: in RequestMessage payload); //PolyORB:NI: }; //PolyORB:NI: //PolyORB:NI: // Router Administration //PolyORB:NI: //PolyORB:NI: typedef short RegistrationState; //PolyORB:NI: const RegistrationState NOT_REGISTERED = 0; //PolyORB:NI: const RegistrationState ACTIVE = 1; //PolyORB:NI: const RegistrationState SUSPENDED = 2; //PolyORB:NI: //PolyORB:NI: exception InvalidState{ //PolyORB:NI: RegistrationState registration_state; //PolyORB:NI: }; //PolyORB:NI: //PolyORB:NI: valuetype RetryPolicy supports CORBA::Policy { }; //PolyORB:NI: //PolyORB:NI: const CORBA::PolicyType IMMEDIATE_SUSPEND_POLICY_TYPE = 36; //PolyORB:NI: //PolyORB:NI: valuetype ImmediateSuspend : RetryPolicy { }; //PolyORB:NI: //PolyORB:NI: const CORBA::PolicyType UNLIMITED_PING_POLICY_TYPE = 37; //PolyORB:NI: //PolyORB:NI: valuetype UnlimitedPing : RetryPolicy { //PolyORB:NI: public short max_backoffs; //PolyORB:NI: public float backoff_factor; //PolyORB:NI: public unsigned long base_interval_seconds; //PolyORB:NI: }; //PolyORB:NI: //PolyORB:NI: const CORBA::PolicyType LIMITED_PING_POLICY_TYPE = 38; //PolyORB:NI: //PolyORB:NI: valuetype LimitedPing : UnlimitedPing { //PolyORB:NI: public unsigned long interval_limit; //PolyORB:NI: }; //PolyORB:NI: //PolyORB:NI: const CORBA::PolicyType DECAY_POLICY_TYPE = 39; //PolyORB:NI: //PolyORB:NI: valuetype DecayPolicy supports CORBA::Policy { //PolyORB:NI: public unsigned long decay_seconds; //PolyORB:NI: }; //PolyORB:NI: //PolyORB:NI: const CORBA::PolicyType RESUME_POLICY_TYPE = 40; //PolyORB:NI: //PolyORB:NI: valuetype ResumePolicy supports CORBA::Policy { //PolyORB:NI: public unsigned long resume_seconds; //PolyORB:NI: }; //PolyORB:NI: //PolyORB:NI: interface RouterAdmin { //PolyORB:NI: void register_destination( //PolyORB:NI: in Object dest, //PolyORB:NI: in boolean is_router, //PolyORB:NI: in RetryPolicy retry, //PolyORB:NI: in DecayPolicy decay); //PolyORB:NI: void suspend_destination( //PolyORB:NI: in Object dest, //PolyORB:NI: in ResumePolicy resumption) //PolyORB:NI: raises (InvalidState); //PolyORB:NI: void resume_destination( //PolyORB:NI: in Object dest) //PolyORB:NI: raises (InvalidState); //PolyORB:NI: void unregister_destination( //PolyORB:NI: in Object dest) //PolyORB:NI: raises (InvalidState); //PolyORB:NI: }; //PolyORB:NI: //PolyORB:NI:}; // module MessageRouting #endif // _MESSAGE_ROUTING_IDL_ polyorb-2.8~20110207.orig/idls/Misc/Messaging.idl0000644000175000017500000001504611750740337020653 0ustar xavierxavier// File: Messaging.idl // CORBA 3.0, Chapter 22 #ifndef _MESSAGING_IDL_ #define _MESSAGING_IDL_ #ifdef _PRE_3_0_COMPILER_ #pragma prefix "omg.org" #include #include #include #include #else import ::CORBA; //PolyORB:NI:import ::Dynamic; //PolyORB:NI:import ::IOP; //PolyORB:NI:import ::TimeBase; #endif // _PRE_3_0_COMPILER_ // App developers should never have to use this IDL file. The ORB vendor // should supply an implementation language version of this file, and // that should be used by app developers if necessary. // Most IDL compilers don't accept the "native" keyword in application IDL // files. In order to compile an IDL (really PIDL) file that has it, the // following trick can be used: change what the compiler sees. Instead // of letting the compiler see the keyword "native", use a preprocessor // definition that results in valid IDL, even if it doesn't yield // useful stubs and skeletons. Of course, PIDL never results in // the standard stubs so that's not a problem. // // Set the variable _MASK_NATIVE_ in the IDL compiler to enable it to // parse this file. #ifdef _MASK_NATIVE_ #define native typedef long #endif // _MASK_NATIVE_ module Messaging { #ifndef _PRE_3_0_COMPILER_ typeprefix Messaging "omg.org"; #endif // _PRE_3_0_COMPILER_ typedef short RebindMode; const RebindMode TRANSPARENT = 0; const RebindMode NO_REBIND = 1; const RebindMode NO_RECONNECT = 2; typedef short SyncScope; const SyncScope SYNC_NONE = 0; const SyncScope SYNC_WITH_TRANSPORT = 1; const SyncScope SYNC_WITH_SERVER = 2; const SyncScope SYNC_WITH_TARGET = 3; typedef short RoutingType; const RoutingType ROUTE_NONE = 0; const RoutingType ROUTE_FORWARD = 1; const RoutingType ROUTE_STORE_AND_FORWARD =2; typedef short Priority; typedef unsigned short Ordering; const Ordering ORDER_ANY = 0x01; const Ordering ORDER_TEMPORAL = 0x02; const Ordering ORDER_PRIORITY = 0x04; const Ordering ORDER_DEADLINE = 0x08; // Rebind Policy (default = TRANSPARENT) const CORBA::PolicyType REBIND_POLICY_TYPE = 23; //PolyORB:NI: local interface RebindPolicy : CORBA::Policy { //PolyORB:NI: readonly attribute RebindMode rebind_mode; //PolyORB:NI: }; // Synchronization Policy (default = SYNC_WITH_TRANSPORT) const CORBA::PolicyType SYNC_SCOPE_POLICY_TYPE = 24; //PolyORB:NI: local interface SyncScopePolicy : CORBA::Policy { //PolyORB:NI: readonly attribute SyncScope synchronization; //PolyORB:NI: }; // Priority Policies const CORBA::PolicyType REQUEST_PRIORITY_POLICY_TYPE = 25; struct PriorityRange { Priority min; Priority max; }; //PolyORB:NI: local interface RequestPriorityPolicy : CORBA::Policy { //PolyORB:NI: readonly attribute PriorityRange priority_range; //PolyORB:NI: }; const CORBA::PolicyType REPLY_PRIORITY_POLICY_TYPE = 26; //PolyORB:NI: interface ReplyPriorityPolicy : CORBA::Policy { //PolyORB:NI: readonly attribute PriorityRange priority_range; //PolyORB:NI: }; // Timeout Policies const CORBA::PolicyType REQUEST_START_TIME_POLICY_TYPE = 27; //PolyORB:NI: local interface RequestStartTimePolicy : CORBA::Policy { //PolyORB:NI: readonly attribute TimeBase::UtcT start_time; //PolyORB:NI: }; const CORBA::PolicyType REQUEST_END_TIME_POLICY_TYPE = 28; //PolyORB:NI: local interface RequestEndTimePolicy : CORBA::Policy { //PolyORB:NI: readonly attribute TimeBase::UtcT end_time; //PolyORB:NI: }; const CORBA::PolicyType REPLY_START_TIME_POLICY_TYPE = 29; //PolyORB:NI: local interface ReplyStartTimePolicy : CORBA::Policy { //PolyORB:NI: readonly attribute TimeBase::UtcT start_time; //PolyORB:NI: }; const CORBA::PolicyType REPLY_END_TIME_POLICY_TYPE = 30; //PolyORB:NI: local interface ReplyEndTimePolicy : CORBA::Policy { //PolyORB:NI: readonly attribute TimeBase::UtcT end_time; //PolyORB:NI: }; const CORBA::PolicyType RELATIVE_REQ_TIMEOUT_POLICY_TYPE = 31; //PolyORB:NI: local interface RelativeRequestTimeoutPolicy : CORBA::Policy { //PolyORB:NI: readonly attribute TimeBase::TimeT relative_expiry; //PolyORB:NI: }; const CORBA::PolicyType RELATIVE_RT_TIMEOUT_POLICY_TYPE = 32; //PolyORB:NI: local interface RelativeRoundtripTimeoutPolicy : CORBA::Policy { //PolyORB:NI: readonly attribute TimeBase::TimeT relative_expiry; //PolyORB:NI: }; const CORBA::PolicyType ROUTING_POLICY_TYPE = 33; struct RoutingTypeRange { RoutingType min; RoutingType max; }; //PolyORB:NI: local interface RoutingPolicy : CORBA::Policy { //PolyORB:NI: readonly attribute RoutingTypeRange routing_range; //PolyORB:NI: }; const CORBA::PolicyType MAX_HOPS_POLICY_TYPE = 34; //PolyORB:NI: local interface MaxHopsPolicy : CORBA::Policy { //PolyORB:NI: readonly attribute unsigned short max_hops; //PolyORB:NI: }; // Router Delivery-ordering Policy (default = ORDER_TEMPORAL) const CORBA::PolicyType QUEUE_ORDER_POLICY_TYPE = 35; //PolyORB:NI: local interface QueueOrderPolicy : CORBA::Policy { //PolyORB:NI: readonly attribute Ordering allowed_orders; //PolyORB:NI: }; // Profile components through which policy values are expressed in IORs struct PolicyValue { CORBA::PolicyType ptype; sequence pvalue; }; typedef sequence PolicyValueSeq; //PolyORB:NI: native UserExceptionBase; //PolyORB:NI: valuetype ExceptionHolder { //PolyORB:NI: void raise_exception() raises (UserExceptionBase); //PolyORB:NI: void raise_exception_with_list( //PolyORB:NI: in Dynamic::ExceptionList exc_list) //PolyORB:NI: raises (UserExceptionBase); //PolyORB:NI: private boolean is_system_exception; //PolyORB:NI: private boolean byte_order; //PolyORB:NI: private sequence marshaled_exception; //PolyORB:NI: }; //PolyORB:NI: //PolyORB:NI: // For handling Routing //PolyORB:NI: interface ReplyHandler { }; //PolyORB:NI: //PolyORB:NI: // Generic Poller Valuetype //PolyORB:NI: //PolyORB:NI: valuetype Poller : CORBA::Pollable { //PolyORB:NI: readonly attribute Object operation_target; //PolyORB:NI: readonly attribute string operation_name; //PolyORB:NI: attribute ReplyHandler associated_handler; //PolyORB:NI: readonly attribute boolean is_from_poller; //PolyORB:NI: private Object target; //PolyORB:NI: private string op_name; //PolyORB:NI: }; }; // module Messaging #endif // _MESSAGING_IDL_ polyorb-2.8~20110207.orig/idls/Misc/MGM.idl0000644000175000017500000000123111750740337017345 0ustar xavierxavier#ifndef _MGM_IDL_ #define _MGM_IDL_ #ifndef _PRE_3_0_COMPILER_ #pragma prefix "omg.org" #include "PortableGroup.idl" #else import ::PortableGroup; #endif //_PRE_3_0_COMPILER_ module MGM { #ifndef _PRE_3_0_COMPILER_ typeprefix MIOP "omg.org"; #endif // _PRE_3_0_COMPILER_ // Property values typedef long GroupCreationMode const GroupCreationMode CREATE_ADDRESS_DEFERED = 0; const GroupCreationMode CREATE_ADDRESS_GENERATED = 1; const GroupCreationMode CREATE_ADDRESS_SUPPLIED = 2; interface ObjectGroupFactory : PortableGroup::GenericFactory, PortableGroup::PropertyManager, PortableGroup::ObjectGroupManager {} }; #endif // __MGM__idl polyorb-2.8~20110207.orig/idls/CORBA_PIDL/0000755000175000017500000000000011750740340016773 5ustar xavierxavierpolyorb-2.8~20110207.orig/idls/CORBA_PIDL/CORBA_Context.idl0000644000175000017500000000206611750740337022031 0ustar xavierxavier// File: CORBA_Context.idl // From CORBA 3.0, Chapter 4 //PolyORB:NI: Context is not actually implemented. Context API is provided //by CORBA personality, but not implemented, any call will raise NO_IMPLEMENT. interface Context { // PIDL void set_one_value ( in Identifier prop_name, // property name to add in string value // property value to add ); void set_values ( in NVList values // property values to be changed ); void get_values ( in Identifier start_scope, // search scope in Flags op_flags, // operation flags in Identifier prop_name, // name of property(s) to retrieve out NVList values // requested property(s) ); void delete_values ( in Identifier prop_name // name of property(s) to delete ); void create_child ( in Identifier ctx_name, // name of context object out Context child_ctx // newly created context object ); void delete ( in Flags del_flags // flags controlling deletion ); }; polyorb-2.8~20110207.orig/idls/CORBA_PIDL/CORBA_NVList.idl0000644000175000017500000000133211750740337021557 0ustar xavierxavier// File: CORBA_NVList.idl // CORBA 3.0, Chapter 7 interface NVList { // PIDL //PolyORB:NI: void add_item ( //PolyORB:NI: in Identifier item_name, // name of item //PolyORB:NI: in TypeCode item_type, // item datatype //PolyORB:NI: in OpaqueValue value, // item value //PolyORB:NI: in long value_len, // length of item value //PolyORB:NI: in Flags item_flags // item flags //PolyORB:NI: ); void free ( ); void free_memory ( ); void get_count ( out long count // number of entries in the list ); }; polyorb-2.8~20110207.orig/idls/CORBA_PIDL/CORBA_ServerRequest.idl0000644000175000017500000000054011750740337023217 0ustar xavierxavier// File: ServerRequest.idl // CORBA 3.0, Chapter 8 interface ServerRequest { // PIDL readonly attribute Identifier operation; void arguments (inout NVList nv); Context ctx(); void set_result (in any val); void set_exception(in any val); }; polyorb-2.8~20110207.orig/idls/CORBA_PIDL/CORBA_ORB_init.idl0000644000175000017500000000071111750740337022045 0ustar xavierxavier// File: CORBA_ORB_init.idl // CORBA 3.0, Chapter 4 // Note: This PIDL does not compile. Don't even try. // It defines an operation not in an interface, which is illegal. // As a result, this file is not "included" anywhere. // It is included for completeness' sake. // PIDL module CORBA { typedef string ORBid; typedef sequence arg_list; ORB ORB_init (inout arg_list argv, in ORBid orb_identifier); }; polyorb-2.8~20110207.orig/idls/CORBA_PIDL/CORBA_ValueBase.idl0000644000175000017500000000024711750740337022253 0ustar xavierxavier// File: CORBA_ValueBase.idl // CORBA 3.0, Chapter 5 //PolyORB:NI: valuetype ValueBase{ //PIDL //PolyORB:NI: ValueDef get_value_def(); //PolyORB:NI: }; polyorb-2.8~20110207.orig/idls/CORBA_PIDL/CORBA_ORB.idl0000644000175000017500000002002311750740337021020 0ustar xavierxavier// File CORBA_ORB.idl // CORBA 3.0, Chapter 4 //PolyORB:NI: typedef sequence RequestSeq; native AbstractBase; typedef unsigned short ServiceType; typedef unsigned long ServiceOption; typedef unsigned long ServiceDetailType; const ServiceType Security = 1; struct ServiceDetail { ServiceDetailType service_detail_type; sequence service_detail; }; struct ServiceInformation { sequence service_options; sequence service_details; }; //PolyORB:NI: native ValueFactory; typedef string ORBid; interface ORB { // PIDL typedef string ObjectId; typedef sequence ObjectIdList; exception InvalidName {}; //PolyORB:NI: ORBid id(); string object_to_string ( in Object obj ); Object string_to_object ( in string str ); // Dynamic Invocation related operations void create_list ( in long count, out NVList new_list ); //PolyORB:NI: void create_operation_list ( //PolyORB:NI: in OperationDef oper, //PolyORB:NI: out NVList new_list //PolyORB:NI: ); void get_default_context ( out Context ctx ); //PolyORB:NI: void send_multiple_requests_oneway( //PolyORB:NI: in RequestSeq req //PolyORB:NI: ); //PolyORB:NI: //PolyORB:NI: void send_multiple_requests_deferred( //PolyORB:NI: in RequestSeq req //PolyORB:NI: ); //PolyORB:NI: //PolyORB:NI: boolean poll_next_response(); //PolyORB:NI: //PolyORB:NI: void get_next_response( //PolyORB:NI: out Request req //PolyORB:NI: ) raises (WrongTransaction); // Service information operations boolean get_service_information ( in ServiceType service_type, out ServiceInformation service_information ); ObjectIdList list_initial_services (); // Initial reference operation Object resolve_initial_references ( in ObjectId identifier ) raises (InvalidName); // Type code creation operations //PolyORB:NI: TypeCode create_struct_tc ( //PolyORB:NI: in RepositoryId id, //PolyORB:NI: in Identifier name, //PolyORB:NI: in StructMemberSeq members //PolyORB:NI: ); //PolyORB:NI: //PolyORB:NI: TypeCode create_union_tc ( //PolyORB:NI: in RepositoryId id, //PolyORB:NI: in Identifier name, //PolyORB:NI: in TypeCode discriminator_type, //PolyORB:NI: in UnionMemberSeq members //PolyORB:NI: ); //PolyORB:NI: //PolyORB:NI: TypeCode create_enum_tc ( //PolyORB:NI: in RepositoryId id, //PolyORB:NI: in Identifier name, //PolyORB:NI: in EnumMemberSeq members //PolyORB:NI: ); TypeCode create_alias_tc ( in RepositoryId id, in Identifier name, in TypeCode original_type ); //PolyORB:NI: TypeCode create_exception_tc ( //PolyORB:NI: in RepositoryId id, //PolyORB:NI: in Identifier name, //PolyORB:NI: in StructMemberSeq members //PolyORB:NI: ); TypeCode create_interface_tc ( in RepositoryId id, in Identifier name ); TypeCode create_string_tc ( in unsigned long bound ); TypeCode create_wstring_tc ( in unsigned long bound ); TypeCode create_fixed_tc ( in unsigned short digits, in short scale ); TypeCode create_sequence_tc ( in unsigned long bound, in TypeCode element_type ); TypeCode create_recursive_sequence_tc( // deprecated in unsigned long bound, in unsigned long offset ); TypeCode create_array_tc ( in unsigned long length, in TypeCode element_type ); //PolyORB:NI: TypeCode create_value_tc ( //PolyORB:NI: in RepositoryId id, //PolyORB:NI: in Identifier name, //PolyORB:NI: in ValueModifier type_modifier, //PolyORB:NI: in TypeCode concrete_base, //PolyORB:NI: in ValueMemberSeq members //PolyORB:NI: ); //PolyORB:NI: //PolyORB:NI: TypeCode create_value_box_tc ( //PolyORB:NI: in RepositoryId id, //PolyORB:NI: in Identifier name, //PolyORB:NI: in TypeCode boxed_type //PolyORB:NI: ); TypeCode create_native_tc ( in RepositoryId id, in Identifier name ); //PolyORB:NI: TypeCode create_recursive_tc( //PolyORB:NI: in RepositoryId id //PolyORB:NI: ); //PolyORB:NI: //PolyORB:NI: TypeCode create_abstract_interface_tc( //PolyORB:NI: in RepositoryId id, //PolyORB:NI: in Identifier name //PolyORB:NI: ); //PolyORB:NI: //PolyORB:NI: TypeCode create_local_interface_tc( //PolyORB:NI: in RepositoryId id, //PolyORB:NI: in Identifier name //PolyORB:NI: ); //PolyORB:NI: //PolyORB:NI: TypeCode create_component_tc ( //PolyORB:NI: in RepositoryId id, //PolyORB:NI: in Identifier name //PolyORB:NI: ); //PolyORB:NI: //PolyORB:NI: TypeCode create_home_tc ( //PolyORB:NI: in RepositoryId id, //PolyORB:NI: in Identifier name //PolyORB:NI: ); //PolyORB:NI: //PolyORB:NI: TypeCode create_event_tc ( //PolyORB:NI: in RepositoryId id, //PolyORB:NI: in Identifier name, //PolyORB:NI: in ValueModifier type_modifier, //PolyORB:NI: in TypeCode concrete_base, //PolyORB:NI: in ValueMemberSeq members //PolyORB:NI: ); // Thread related operations boolean work_pending( ); void perform_work(); void run(); void shutdown( in boolean wait_for_completion ); //PolyORB:NI: void destroy(); // Policy related operations Policy create_policy( in PolicyType type, in any val ) raises (PolicyError); //PolyORB:NI: // Dynamic Any related operations deprecated and removed //PolyORB:NI: // from primary list of ORB operations //PolyORB:NI: //PolyORB:NI: // Value factory operations //PolyORB:NI: //PolyORB:NI: ValueFactory register_value_factory( //PolyORB:NI: in RepositoryId id, //PolyORB:NI: in ValueFactory _factory //PolyORB:NI: ); //PolyORB:NI: //PolyORB:NI: void unregister_value_factory( //PolyORB:NI: in RepositoryId id); //PolyORB:NI: //PolyORB:NI: ValueFactory lookup_value_factory( //PolyORB:NI: in RepositoryId id); // Portable Interceptor related operations void register_initial_reference( in ObjectId id, in Object obj ) raises (InvalidName); }; polyorb-2.8~20110207.orig/idls/CORBA_PIDL/CORBA_Object.idl0000644000175000017500000000347711750740337021622 0ustar xavierxavier// File: CORBA_Object.idl // CORBA 3.0, Chapter 4 //PIDL struct NamedValue { Identifier name; // argument name any argument; // argument long len; // length/count of argument value Flags arg_modes; // argument mode flags }; enum SetOverrideType {SET_OVERRIDE, ADD_OVERRIDE}; interface Object { // PIDL InterfaceDef get_interface (); boolean is_nil(); Object duplicate (); void release (); boolean is_a ( in string logical_type_id ); boolean non_existent(); boolean is_equivalent ( in Object other_object ); unsigned long hash( in unsigned long maximum ); void create_request ( in Context ctx, in Identifier operation, in NVList arg_list, inout NamedValue result, out Request request, in Flags req_flag ); Policy get_policy ( in PolicyType policy_type ); DomainManagersList get_domain_managers (); Object set_policy_overrides( in PolicyList policies, in SetOverrideType set_add ) raises(InvalidPolicies); Policy get_client_policy( in PolicyType type ); PolicyList get_policy_overrides( in PolicyTypeSeq types ); //PolyORB:IL: boolean validate_connection( //PolyORB:IL: out PolicyList inconsistent_policies //PolyORB:IL: ); //PolyORB:NI: Object get_component (); }; polyorb-2.8~20110207.orig/idls/CORBA_PIDL/pseudo_orb.idl0000644000175000017500000001176011750740337021641 0ustar xavierxavier// File: pseudo_orb.idl // From CORBA 3.0 #ifndef _PSEUDO_ORB_IDL_ #define _PSEUDO_ORB_IDL_ #include // This module brings together all the pseudo IDL in the definition // of the CORBA module. (May heaven have mercy on us.) // Why? Just to see if it can be done. Well, maybe a little more. // The PIDL interfaces are included in this file for the purpose // of testing the syntax (for all the good that does) and for // completeness. Including them serves as documentation of // the intent of the CORBA specification. // This file should never be copied (or #included) into a real IDL // file for a couple reasons. First, the only reason this compiles // is a couple tricks played, as you will see below. The tricks // are necessary because there are PIDL definition of entities // whose names conflict with IDL keywords (Object, ValueBase, and // Context); the tricks essentially negate any pseudo-benefit that // might accrue from pseudo-compiling the PIDL. Finally, PIDL does // not define a full CORBA object. These pseudo-objects are // implemented as purely local entities; the ORB provides the // implementation. An invocation on a pseudo-object goes directly // to a language entity; specifically, it doesn't go through the // full remote invocation process (avoiding infinite regress). As // a result, the generated stubs wouldn't get to the right code // even if used by a client program and the skeletons aren't of // use to anybody. // For the definitions that an application needs corresponding to, // the PIDL in this file, an ORB provides a special stub (header // file, whatever) corresponding to the custom mapping of the // PIDL for that language. It's as if the ORB vendor compiled // this PIDL using a PIDL compiler. // Most IDL compilers don't accept the "native" keyword in application IDL // files. In order to compile an IDL (really PIDL) file that has it, the // following trick can be used: change what the compiler sees. Instead // of letting the compiler see the keyword "native", use a preprocessor // definition that results in valid IDL, even if it doesn't yield // useful stubs and skeletons. Of course, PIDL never results in // the standard stubs so that's not a problem. // // Set the variable _MASK_NATIVE_ in the IDL compiler to enable it to // parse this file. #ifdef _MASK_NATIVE_ #define native typedef long #endif // _MASK_NATIVE_ module CORBA { // The following forward references list *all* the PIDL interfaces and // valuetypes in the CORBA module. This serves two purposes: documentation // and compilability. Documentation is nice: since some of the interfaces // must be declared as forward references, it is more consistent to // declare them all. // // As far as compilability, it might be possible to avoid having to declare // many of the forward reference by rearranging the order of the interface // declarations, but there's no reason to do bother doing that since // that's the reason forward references were invented. Doing a forward // reference allows the definition order to be relatively logical.In // particular, it allows the "include"s to be done in chapter order // (almost), the only exception being the InterfaceRepository (Chapter 10). // It contains some data definitions needed by Chapter 4 interfaces. // The other reason not to try to rearrange the order is that it's hard. // The "define" fakes out the compiler to let it compile the "Context" // interface and references to it even though "context" is a keyword #define Context CContext // The "define" fakes out the compiler to let it compile the "Object" // interface and references to it even though "Object" is a keyword #define Object OObject // The "define" fakes out the compiler to let it compile the "ValueBase" // valuetype and references to it even though "ValueBase" is a keyword #define ValueBase VValueBase // Forward references, alphabetically interface Context; // Chapter 7, CORBA_Context.idl interface NVList; // Chapter 7, CORBA_NVList.idl interface Object; // Chapter 4, CORBA_Object.idl interface ORB; // Chapter 4, CORBA_ORB.idl interface Request; // Chapter 7, CORBA_Request.idl interface ServerRequest; // Chapter 8, CORBA_ServerRequest.idl valuetype ValueBase; // Chapter 4, CORBA_ValueBase.idl typedef unsigned long Flags; // Chapter 4: ORB Interface #include #include // Chapter 5: Value Type Semantics #include // Chapter 7: Dynamic Invocation Interface #include #include #include // Chapter 8: Dynamic Skeleton Interface #include }; #endif // _PSEUDO_ORB_IDL_ polyorb-2.8~20110207.orig/idls/CORBA_PIDL/CORBA_Request.idl0000644000175000017500000000224111750740337022030 0ustar xavierxavier// File: CORBA_Request.idl // CORBA 3.0, Chapter 7 //PolyORB:NI: native OpaqueValue; interface Request { // PIDL //PolyORB:NI: void add_arg ( //PolyORB:NI: in Identifier name, // argument name //PolyORB:NI: in TypeCode arg_type, // argument datatype //PolyORB:NI: in OpaqueValue value, // argument value to be added //PolyORB:NI: in long len, // length/count of argument value //PolyORB:NI: in Flags arg_flags // argument flags //PolyORB:NI: ); void invoke ( in Flags invoke_flags // invocation flags ); void delete (); //PolyORB:NI: void send ( //PolyORB:NI: in Flags invoke_flags // invocation flags //PolyORB:NI: ); //PolyORB:NI: //PolyORB:NI: void get_response () raises (WrongTransaction); //PolyORB:NI: //PolyORB:NI: boolean poll_response(); //PolyORB:NI: //PolyORB:NI: Object sendp(); //PolyORB:NI: //PolyORB:NI: void prepare(in Object p); //PolyORB:NI: //PolyORB:NI: void sendc(in Object handler); }; polyorb-2.8~20110207.orig/polyorb-config.in0000644000175000017500000001725611750740337017704 0ustar xavierxavier#!/bin/sh # This script provides tool chain command line switches used to build # applications that use PolyORB. # @configure_input@ # Determine installation prefix case "$0" in */*) # Already has a directory indication exec_name="$0" ;; *) # Just base filename, retrieve from PATH exec_name=`which $0` ;; esac exec_rel_dir=`dirname "${exec_name}"` exec_abs_dir=`cd ${exec_rel_dir} && pwd` exec_prefix=`dirname "${exec_abs_dir}"` # Translate Cygwin-style path to Windows equivalent case "$OS" in Windows_NT) exec_prefix=`cygpath -w $exec_prefix` esac if [ -f "${exec_prefix}"/include/polyorb/polyorb.ads ]; then prefix="${exec_prefix}" else # Fall back to configure-time prefix prefix="@prefix@" fi have_gnatmake_aPdir=@HAVE_GNATMAKE_APDIR@ default_appli="@APPLI_LIST@" default_proto="@PROTO_LIST@" default_services="@SERVICE_LIST@" require_xmlada=false appli="${default_appli}" proto="${default_proto}" services="${default_services}" # is_in NEEDLE HAY1 HAY2 ... # True if NEEDLE is equal to any of the HAY* is_in () { needle=$1 shift while [ "$#" != 0 ]; do if [ "$needle" = "$1" ]; then return 0 fi shift done return 1 } # set_components MSG VAR VALUE,VALUE,VALUE # Set VAR to the listed set of VALUEs, with commas replaced with spaces, # checking that all VALUEs are present in default_VAR. # MSG is the user-friendly name of the component being set. set_components () { failed=false values=`echo $3 | tr , ' '` for value in $values; do if eval "is_in '$value' \$default_$2"; then : OK else echo "$1 $value not available." 1>&2 failed=true fi done if $failed; then exit 1; fi eval "$2='$values'" } usage() { cat <&2 Usage: polyorb-config [OPTIONS] Options: No option: Output all the flags (compiler and linker) required to compile your program. [--prefix[=DIR]] Output the directory in which PolyORB architecture-independent files are installed, or set this directory to DIR. [--exec-prefix[=DIR]] Output the directory in which PolyORB architecture-dependent files are installed, or set this directory to DIR. [--version|-v] Output the version of PolyORB. [--config] Output PolyORB's configuration parameters. [--libs] Output the linker flags to use for PolyORB. [--cflags] Output the compiler flags to use for PolyORB. [--idls] Output flags to set up path to CORBA's IDL for idlac. [--with-appli-perso=P,P,P] Restrict output to only those flags relevant to the listed applicative personalities. [--with-proto-perso=P,P,P] Restrict output to only those flags relevant to the listed protocol personalities. [--with-corba-services=S,S,S] Restrict output to only those flags relevant to the listed services. [--help] Output this message EOF } while test $# -gt 0; do case "$1" in -*=*) optarg=`echo "$1" | sed 's/[-_a-zA-Z0-9]*=//'` ;; *) optarg= ;; esac case $1 in --help|-h) usage 1>&2 exit 1 ;; --prefix=*) prefix=$optarg; if test "x$exec_prefix_set" = x ; then exec_prefix=$prefix fi ;; --prefix) echo_prefix=true ;; --exec-prefix=*) exec_prefix=$optarg ;; --exec-prefix) echo_exec_prefix=true ;; --version|-v) echo "PolyORB @POLYORB_VERSION@" 1>&2 exit 0 ;; --config) cat <&2 Personalities built : * Application personalities : @APPLI_LIST@ * Protocol personalities : @PROTO_LIST@ * Services : @SERVICE_LIST@ * SSL support : @HAVE_SSL@ EOF exit 0 ;; --libs) echo_libs=true ;; --idls) echo_idls=true ;; --cflags) echo_cflags=true ;; --with-appli-perso=*) set_components "Applicative personality" appli "$optarg" ;; --with-proto-perso=*) set_components "Protocol personality" proto "$optarg" ;; --with-corba-services=*) set_components "Service" services "$optarg" ;; *) usage 1>&2 exit 1 ;; esac shift done exec_prefix="@exec_prefix@" includedir="@includedir@" libdir="@libdir@" polyorb_dir="${includedir}/polyorb" polyorb_lib="@LDFLAGS@ -L${libdir}/polyorb/static -lpolyorb" corba_idl_dir="-I${includedir}/polyorb" for P in $appli; do polyorb_lib="$polyorb_lib -lpolyorb-${P}" if [ "x$P" = "xcorba" ] then polyorb_lib="$polyorb_lib -lpolyorb-corba-dynamicany -lpolyorb-corba-iop -lpolyorb-corba-messaging -lpolyorb-corba-portableinterceptor -lpolyorb-corba-rtcorba" for S in $services; do # In general we have two libraries for each service: cos-${S} for client # stubs and helpers, and cos-${S}-impl for implementation. A user # application does not need the impl library in general, and it is # therefore not included in the default set of libraries we output. # The interface repository is an exception to this rule, because in this # case we build a single library with client stubs and implementation. if [ "${S}" = "ir" ]; then polyorb_lib="$polyorb_lib -lpolyorb-corba-cos-${S}-impl" else polyorb_lib="$polyorb_lib -lpolyorb-corba-cos-${S}" fi done if [ "x@HAVE_SSL@" = "xyes" ]; then polyorb_lib="$polyorb_lib -lpolyorb-corba-security -lpolyorb-corba-security-gssup" fi fi if [ "x$P" = "xaws" ] then polyorb_lib="$polyorb_lib -lpolyorb-web_common" require_xmlada=true fi done for P in $proto; do polyorb_lib="$polyorb_lib -lpolyorb-${P}" case "$P" in giop) polyorb_lib="$polyorb_lib -lpolyorb-giop-diop -lpolyorb-giop-iiop -lpolyorb-giop-miop" if [ "x@HAVE_SSL@" = "xyes" ] then polyorb_lib="$polyorb_lib -lpolyorb-giop-iiop-ssliop" polyorb_lib="$polyorb_lib -lpolyorb-giop-iiop-security -lpolyorb-giop-iiop-security-tls" fi ;; soap) polyorb_lib="$polyorb_lib -lpolyorb-web_common" require_xmlada=true ;; dns) polyorb_lib="$polyorb_lib -lpolyorb-dns-udns -lpolyorb-dns-mdns" ;; esac done if [ "x@HAVE_SSL@" = "xyes" ] then polyorb_lib="$polyorb_lib -lpolyorb-ssl" polyorb_lib="$polyorb_lib -lpolyorb-security -lpolyorb-security-gssup -lpolyorb-security-x509 -lpolyorb-security-tls -lpolyorb-setup-security" fi polyorb_lib="$polyorb_lib -lpolyorb-setup" # Dependencies on XML/Ada are appended at the end of the command line, # so that they are passed to the linker after any other object, right # before the dependency on libgnat. This is necessary so that in the case # of dynamic XML/Ada libraries, an implicit dependency on the dynamic libgnat # does not take precedence over symbols that are overridden by PolyORB # (specifically, System.Partition_Interface.*). if $require_xmlada; then xmlada_dir="`xmlada-config --cflags`" xmlada_lib="`xmlada-config --libs`" xmlada_mflags="`xmlada-config`" fi if test x$have_gnatmake_aPdir = xyes; then apdir="-aP${prefix}/lib/gnat" fi if test ! x"$echo_prefix" = x"true" -a ! x"$echo_exec_prefix" = x"true" -a ! x"$echo_cflags" = x"true" -a ! x"$echo_libs" = x"true" -a ! x"$echo_idls" = x"true"; then echo ${apdir} -aI${polyorb_dir} -aO${libdir}/polyorb ${xmlada_mflags} -largs ${polyorb_lib} ${xmlada_lib} fi if test x"$echo_prefix" = x"true" ; then echo $prefix fi if test x"$echo_exec_prefix" = x"true" ; then echo $exec_prefix fi if test x"$echo_cflags" = x"true"; then echo -I${polyorb_dir} ${xmlada_dir} fi if test x"$echo_libs" = x"true"; then echo ${polyorb_lib} ${xmlada_lib} fi if test x"$echo_idls" = x"true"; then echo $corba_idl_dir fi polyorb-2.8~20110207.orig/projects/0000755000175000017500000000000011750740340016233 5ustar xavierxavierpolyorb-2.8~20110207.orig/projects/polyorb_src_dns_mdns.gpr0000644000175000017500000000520311750740337023175 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B _ S R C _ D N S _ M D N S -- -- -- -- P r o j -- -- -- -- Copyright (C) 2007-2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with "polyorb_common", "polyorb_src", "polyorb_src_dns"; project PolyORB_src_dns_mdns is Dir := "src/dns/mdns"; Obj_Dir := PolyORB_Common.Build_Dir & Dir; for Object_Dir use Obj_Dir; for Source_Dirs use (Obj_Dir, PolyORB_Common.Source_Dir & Dir); for Library_Name use "polyorb-dns-mdns"; for Library_Dir use PolyORB_Common.Build_Dir & "lib"; for Library_ALI_Dir use PolyORB_Common.Build_Dir & "ali/src_dns_mdns"; for Library_Kind use "static"; package Compiler is for Default_Switches ("Ada") use PolyORB_Src.Compiler'Default_Switches ("Ada"); end Compiler; end PolyORB_src_dns_mdns; polyorb-2.8~20110207.orig/projects/polyorb_src_corba_messaging.gpr0000644000175000017500000000541111750740337024514 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B _ S R C _ C O R B A _ M E S S A G I N G -- -- -- -- P r o j -- -- -- -- Copyright (C) 2007-2009, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with "polyorb_common", "polyorb_src", "polyorb_src_corba"; project PolyORB_src_corba_messaging is Dir := "src/corba/messaging"; Obj_Dir := PolyORB_Common.Build_Dir & Dir; for Object_Dir use Obj_Dir; for Source_Dirs use (Obj_Dir); -- for Source_Dirs use (Obj_Dir, PolyORB_Common.Source_Dir & Dir); -- Only generated sources, no sources from repository for Library_Name use "polyorb-corba-messaging"; for Library_Dir use PolyORB_Common.Build_Dir & "lib"; for Library_ALI_Dir use PolyORB_Common.Build_Dir & "ali/src_corba_messaging"; for Library_Kind use "static"; package Compiler is for Default_Switches ("Ada") use PolyORB_Src.Compiler'Default_Switches ("Ada"); end Compiler; end PolyORB_src_corba_messaging; polyorb-2.8~20110207.orig/projects/polyorb_src_giop_miop.gpr0000644000175000017500000000521111750740337023351 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B _ S R C _ G I O P _ M I O P -- -- -- -- P r o j -- -- -- -- Copyright (C) 2007-2009, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with "polyorb_common", "polyorb_src", "polyorb_src_giop"; project PolyORB_src_giop_miop is Dir := "src/giop/miop"; Obj_Dir := PolyORB_Common.Build_Dir & Dir; for Object_Dir use Obj_Dir; for Source_Dirs use (Obj_Dir, PolyORB_Common.Source_Dir & Dir); for Library_Name use "polyorb-giop-miop"; for Library_Dir use PolyORB_Common.Build_Dir & "lib"; for Library_ALI_Dir use PolyORB_Common.Build_Dir & "ali/src_giop_miop"; for Library_Kind use "static"; package Compiler is for Default_Switches ("Ada") use PolyORB_Src.Compiler'Default_Switches ("Ada"); end Compiler; end PolyORB_src_giop_miop; polyorb-2.8~20110207.orig/projects/polyorb_cos_ir.gpr0000644000175000017500000000517111750740337022003 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B _ C O S _ I R -- -- -- -- P r o j -- -- -- -- Copyright (C) 2007-2009, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with "polyorb_common", "polyorb_src", "polyorb_src_corba"; project PolyORB_cos_ir is Dir := "cos/ir"; Obj_Dir := PolyORB_Common.Build_Dir & Dir; for Object_Dir use Obj_Dir; for Source_Dirs use (Obj_Dir, PolyORB_Common.Source_Dir & Dir); for Library_Name use "polyorb-corba-cos-ir-impl"; for Library_Dir use PolyORB_Common.Build_Dir & "lib"; for Library_ALI_Dir use PolyORB_Common.Build_Dir & "ali/cos_ir"; for Library_Kind use "static"; package Compiler is for Default_Switches ("Ada") use PolyORB_Common.Compiler'Default_Switches ("Ada"); end Compiler; end PolyORB_cos_ir; polyorb-2.8~20110207.orig/projects/polyorb_idls_cos_naming.gpr0000644000175000017500000000527711750740337023664 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B _ I D L S _ C O S _ N A M I N G -- -- -- -- P r o j -- -- -- -- Copyright (C) 2007-2009, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with "polyorb_common", "polyorb_src"; limited with "polyorb_src_corba", "polyorb_cos_naming"; project PolyORB_idls_cos_naming is Dir := "idls/cos/naming"; Obj_Dir := PolyORB_Common.Build_Dir & Dir; for Object_Dir use Obj_Dir; for Source_Dirs use (Obj_Dir, PolyORB_Common.Source_Dir & Dir); for Library_Name use "polyorb-corba-cos-naming"; for Library_Dir use PolyORB_Common.Build_Dir & "lib"; for Library_ALI_Dir use PolyORB_Common.Build_Dir & "ali/idls_cos_naming"; for Library_Kind use "static"; package Compiler is for Default_Switches ("Ada") use PolyORB_Common.Compiler'Default_Switches ("Ada"); end Compiler; end PolyORB_idls_cos_naming; polyorb-2.8~20110207.orig/projects/polyorb_src_corba_iop.gpr0000644000175000017500000000521211750740337023325 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B _ S R C _ C O R B A _ I O P -- -- -- -- P r o j -- -- -- -- Copyright (C) 2007-2009, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with "polyorb_common", "polyorb_src", "polyorb_src_corba"; project PolyORB_src_corba_iop is Dir := "src/corba/iop"; Obj_Dir := PolyORB_Common.Build_Dir & Dir; for Object_Dir use Obj_Dir; for Source_Dirs use (Obj_Dir, PolyORB_Common.Source_Dir & Dir); for Library_Name use "polyorb-corba-iop"; for Library_Dir use PolyORB_Common.Build_Dir & "lib"; for Library_ALI_Dir use PolyORB_Common.Build_Dir & "ali/src_corba_iop"; for Library_Kind use "static"; package Compiler is for Default_Switches ("Ada") use PolyORB_Src.Compiler'Default_Switches ("Ada"); end Compiler; end PolyORB_src_corba_iop; polyorb-2.8~20110207.orig/projects/README0000644000175000017500000000167211750740337017127 0ustar xavierxavierThe project files in this directory are for building PolyORB. See ../projects-distrib for building clients of PolyORB. common.gpr -- imported by all the others; contains commonly used variables config.gpr -- generated from config.gpr.in by configure, and imported by common.gpr. build_all.gpr -- imports all the others; can be used to recompile everything, using the -U switch of gnatmake. (??Currently not used.) One for each of the following directories: src and its subdirectories (including src_setup.gpr, which is generated from src_setup.gpr.in). subdirectories of cos subdirectories of idls that correspond to subdirectories of cos The naming convention is the path name, relative to the root of the polyorb hierarchy, with directory separators "/" replaced with underscore "_"; for example, src_giop_diop.gpr is the project file for src/giop/diop. Each of these builds a library. tools_*.gpr -- these are for building programs. polyorb-2.8~20110207.orig/projects/polyorb_src_corba_portableinterceptor.gpr0000644000175000017500000000565111750740337026634 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- POLYORB_SRC_CORBA_PORTABLEINTERCEPTOR -- -- -- -- P r o j -- -- -- -- Copyright (C) 2007-2009, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with "polyorb_common", "polyorb_src", "polyorb_src_corba", "polyorb_src_corba_iop", "polyorb_src_corba_messaging", "polyorb_cos_ir"; -- Depends on IR for portableinterceptor/dynamic -- ??? that should be idls_cos_ir, no need for visibility on IR implementation project PolyORB_src_corba_portableinterceptor is Dir := "src/corba/portableinterceptor"; Obj_Dir := PolyORB_Common.Build_Dir & Dir; for Object_Dir use Obj_Dir; for Source_Dirs use (Obj_Dir, PolyORB_Common.Source_Dir & Dir); for Library_Name use "polyorb-corba-portableinterceptor"; for Library_Dir use PolyORB_Common.Build_Dir & "lib"; for Library_ALI_Dir use PolyORB_Common.Build_Dir & "ali/src_corba_portableinterceptor"; for Library_Kind use "static"; package Compiler is for Default_Switches ("Ada") use PolyORB_Src.Compiler'Default_Switches ("Ada"); end Compiler; end PolyORB_src_corba_portableinterceptor; polyorb-2.8~20110207.orig/projects/polyorb_tools_po_createref.gpr0000644000175000017500000000475711750740337024414 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B _ T O O L S _ P O _ C R E A T E R E F -- -- -- -- P r o j -- -- -- -- Copyright (C) 2007-2009, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with "polyorb_common", "polyorb_src", "polyorb_src_setup"; project PolyORB_tools_po_createref is Dir := "tools/po_createref"; Obj_Dir := PolyORB_Common.Build_Dir & Dir; for Object_Dir use Obj_Dir; for Source_Dirs use (Obj_Dir, PolyORB_Common.Source_Dir & Dir); package Compiler is for Default_Switches ("Ada") use PolyORB_Common.Compiler'Default_Switches ("Ada"); end Compiler; for Main use ("po_createref.adb"); end PolyORB_tools_po_createref; polyorb-2.8~20110207.orig/projects/polyorb_src_setup.gpr.in0000644000175000017500000000577111750740337023147 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B _ S R C _ S E T U P -- -- -- -- P r o j -- -- -- -- Copyright (C) 2007-2009, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- Pre-canned middleware setups -- The units provided by this project provide convenient short-hands to -- drag in an appropriate middleware configuration. They contain only -- WITH clauses for the PolyORB components. Within the PolyORB build -- system, only tools projects (not library projects) are allowed to import -- this one. with "polyorb_common", "polyorb_src"; @NO_SSL@with "polyorb_src_ssl"; @WITH_PROTO_PRJS@ @WITH_APPLI_PRJS@ project PolyORB_src_setup is Dir := "src/setup"; Obj_Dir := PolyORB_Common.Build_Dir & Dir; for Object_Dir use Obj_Dir; for Source_Dirs use (Obj_Dir, PolyORB_Common.Source_Dir & Dir); for Library_Name use "polyorb-setup"; for Library_Dir use PolyORB_Common.Build_Dir & "lib"; for Library_ALI_Dir use PolyORB_Common.Build_Dir & "ali/src_setup"; for Library_Kind use "static"; package Compiler is for Default_Switches ("Ada") use PolyORB_Src.Compiler'Default_Switches ("Ada"); end Compiler; end PolyORB_src_setup; polyorb-2.8~20110207.orig/projects/polyorb_src_corba_security.gpr0000644000175000017500000000532411750740337024411 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B _ S R C _ C O R B A _ S E C U R I T Y -- -- -- -- P r o j -- -- -- -- Copyright (C) 2007-2009, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with "polyorb_common", "polyorb_src", "polyorb_src_corba", "polyorb_src_corba_iop", "polyorb_src_security"; project PolyORB_src_corba_security is Dir := "src/corba/security"; Obj_Dir := PolyORB_Common.Build_Dir & Dir; for Object_Dir use Obj_Dir; for Source_Dirs use (Obj_Dir, PolyORB_Common.Source_Dir & Dir); for Library_Name use "polyorb-corba-security"; for Library_Dir use PolyORB_Common.Build_Dir & "lib"; for Library_ALI_Dir use PolyORB_Common.Build_Dir & "ali/src_corba_security"; for Library_Kind use "static"; package Compiler is for Default_Switches ("Ada") use PolyORB_Src.Compiler'Default_Switches ("Ada"); end Compiler; end PolyORB_src_corba_security; polyorb-2.8~20110207.orig/projects/polyorb_src_corba.gpr0000644000175000017500000000514111750740337022457 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B _ S R C _ C O R B A -- -- -- -- P r o j -- -- -- -- Copyright (C) 2007-2009, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with "polyorb_common", "polyorb_src"; project PolyORB_src_corba is Dir := "src/corba"; Obj_Dir := PolyORB_Common.Build_Dir & Dir; for Object_Dir use Obj_Dir; for Source_Dirs use (Obj_Dir, PolyORB_Common.Source_Dir & Dir); for Library_Name use "polyorb-corba"; for Library_Dir use PolyORB_Common.Build_Dir & "lib"; for Library_ALI_Dir use PolyORB_Common.Build_Dir & "ali/src_corba"; for Library_Kind use "static"; package Compiler is for Default_Switches ("Ada") use PolyORB_Src.Compiler'Default_Switches ("Ada"); end Compiler; end PolyORB_src_corba; polyorb-2.8~20110207.orig/projects/polyorb_src_dns.gpr0000644000175000017500000000512711750740337022161 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B _ S R C _ D N S -- -- -- -- P r o j -- -- -- -- Copyright (C) 2007-2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with "polyorb_common", "polyorb_src"; project PolyORB_src_dns is Dir := "src/dns"; Obj_Dir := PolyORB_Common.Build_Dir & Dir; for Object_Dir use Obj_Dir; for Source_Dirs use (Obj_Dir, PolyORB_Common.Source_Dir & Dir); for Library_Name use "polyorb-dns"; for Library_Dir use PolyORB_Common.Build_Dir & "lib"; for Library_ALI_Dir use PolyORB_Common.Build_Dir & "ali/src_dns"; for Library_Kind use "static"; package Compiler is for Default_Switches ("Ada") use PolyORB_Src.Compiler'Default_Switches ("Ada"); end Compiler; end PolyORB_src_dns; polyorb-2.8~20110207.orig/projects/polyorb_tools_po_catref.gpr0000644000175000017500000000474311750740337023713 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B _ T O O L S _ P O _ C A T R E F -- -- -- -- P r o j -- -- -- -- Copyright (C) 2007-2009, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with "polyorb_common", "polyorb_src", "polyorb_src_setup"; project PolyORB_tools_po_catref is Dir := "tools/po_catref"; Obj_Dir := PolyORB_Common.Build_Dir & Dir; for Object_Dir use Obj_Dir; for Source_Dirs use (Obj_Dir, PolyORB_Common.Source_Dir & Dir); package Compiler is for Default_Switches ("Ada") use PolyORB_Common.Compiler'Default_Switches ("Ada"); end Compiler; for Main use ("po_catref.adb"); end PolyORB_tools_po_catref; polyorb-2.8~20110207.orig/projects/polyorb_tools_po_ir.gpr0000644000175000017500000000503611750740337023055 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B _ T O O L S _ P O _ I R -- -- -- -- P r o j -- -- -- -- Copyright (C) 2007-2009, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with "polyorb_common", "polyorb_src", "polyorb_src_setup", "polyorb_src_giop_diop"; with "polyorb_src_corba"; with "polyorb_cos_ir"; project PolyORB_tools_po_ir is Dir := "tools/po_ir"; Obj_Dir := PolyORB_Common.Build_Dir & Dir; for Object_Dir use Obj_Dir; for Source_Dirs use (Obj_Dir, PolyORB_Common.Source_Dir & Dir); package Compiler is for Default_Switches ("Ada") use PolyORB_Common.Compiler'Default_Switches ("Ada"); end Compiler; for Main use ("po_ir.adb"); end PolyORB_tools_po_ir; polyorb-2.8~20110207.orig/projects/polyorb_src_giop.gpr0000644000175000017500000000513411750740337022331 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B _ S R C _ G I O P -- -- -- -- P r o j -- -- -- -- Copyright (C) 2007-2009, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with "polyorb_common", "polyorb_src"; project PolyORB_src_giop is Dir := "src/giop"; Obj_Dir := PolyORB_Common.Build_Dir & Dir; for Object_Dir use Obj_Dir; for Source_Dirs use (Obj_Dir, PolyORB_Common.Source_Dir & Dir); for Library_Name use "polyorb-giop"; for Library_Dir use PolyORB_Common.Build_Dir & "lib"; for Library_ALI_Dir use PolyORB_Common.Build_Dir & "ali/src_giop"; for Library_Kind use "static"; package Compiler is for Default_Switches ("Ada") use PolyORB_Src.Compiler'Default_Switches ("Ada"); end Compiler; end PolyORB_src_giop; polyorb-2.8~20110207.orig/projects/polyorb_src.gpr0000644000175000017500000000523111750740337021311 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B _ S R C -- -- -- -- P r o j -- -- -- -- Copyright (C) 2007-2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with "polyorb_common"; project PolyORB_src is for Languages use ("Ada", "C"); Dir := "src"; Obj_Dir := PolyORB_Common.Build_Dir & Dir; for Object_Dir use Obj_Dir; for Source_Dirs use (Obj_Dir, PolyORB_Common.Source_Dir & Dir); for Excluded_Source_List_File use Obj_Dir & "/src.exclude"; for Library_Name use "polyorb"; for Library_Dir use PolyORB_Common.Build_Dir & "lib"; for Library_ALI_Dir use PolyORB_Common.Build_Dir & "ali/src"; for Library_Kind use "static"; package Compiler is for Default_Switches ("Ada") use PolyORB_Common.Compiler'Default_Switches ("Ada"); end Compiler; end PolyORB_src; polyorb-2.8~20110207.orig/projects/polyorb_src_security_gssup.gpr0000644000175000017500000000524611750740337024467 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B _ S R C _ S E C U R I T Y _ G S S U P -- -- -- -- P r o j -- -- -- -- Copyright (C) 2007-2009, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with "polyorb_common", "polyorb_src", "polyorb_src_security"; project PolyORB_src_security_gssup is Dir := "src/security/gssup"; Obj_Dir := PolyORB_Common.Build_Dir & Dir; for Object_Dir use Obj_Dir; for Source_Dirs use (Obj_Dir, PolyORB_Common.Source_Dir & Dir); for Library_Name use "polyorb-security-gssup"; for Library_Dir use PolyORB_Common.Build_Dir & "lib"; for Library_ALI_Dir use PolyORB_Common.Build_Dir & "ali/src_security_gssup"; for Library_Kind use "static"; package Compiler is for Default_Switches ("Ada") use PolyORB_Src.Compiler'Default_Switches ("Ada"); end Compiler; end PolyORB_src_security_gssup; polyorb-2.8~20110207.orig/projects/polyorb_src_corba_rtcorba.gpr0000644000175000017500000000526711750740337024204 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B _ S R C _ C O R B A _ R T C O R B A -- -- -- -- P r o j -- -- -- -- Copyright (C) 2007-2009, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with "polyorb_common", "polyorb_src", "polyorb_src_corba", "polyorb_src_corba_iop"; project PolyORB_src_corba_rtcorba is Dir := "src/corba/rtcorba"; Obj_Dir := PolyORB_Common.Build_Dir & Dir; for Object_Dir use Obj_Dir; for Source_Dirs use (Obj_Dir, PolyORB_Common.Source_Dir & Dir); for Library_Name use "polyorb-corba-rtcorba"; for Library_Dir use PolyORB_Common.Build_Dir & "lib"; for Library_ALI_Dir use PolyORB_Common.Build_Dir & "ali/src_corba_rtcorba"; for Library_Kind use "static"; package Compiler is for Default_Switches ("Ada") use PolyORB_Src.Compiler'Default_Switches ("Ada"); end Compiler; end PolyORB_src_corba_rtcorba; polyorb-2.8~20110207.orig/projects/polyorb_src_giop_diop.gpr0000644000175000017500000000521111750740337023340 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B _ S R C _ G I O P _ D I O P -- -- -- -- P r o j -- -- -- -- Copyright (C) 2007-2009, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with "polyorb_common", "polyorb_src", "polyorb_src_giop"; project PolyORB_src_giop_diop is Dir := "src/giop/diop"; Obj_Dir := PolyORB_Common.Build_Dir & Dir; for Object_Dir use Obj_Dir; for Source_Dirs use (Obj_Dir, PolyORB_Common.Source_Dir & Dir); for Library_Name use "polyorb-giop-diop"; for Library_Dir use PolyORB_Common.Build_Dir & "lib"; for Library_ALI_Dir use PolyORB_Common.Build_Dir & "ali/src_giop_diop"; for Library_Kind use "static"; package Compiler is for Default_Switches ("Ada") use PolyORB_Src.Compiler'Default_Switches ("Ada"); end Compiler; end PolyORB_src_giop_diop; polyorb-2.8~20110207.orig/projects/polyorb_src_corba_dynamicany.gpr0000644000175000017500000000525511750740337024701 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B _ S R C _ C O R B A _ D Y N A M I C A N Y -- -- -- -- P r o j -- -- -- -- Copyright (C) 2007-2009, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with "polyorb_common", "polyorb_src", "polyorb_src_corba"; project PolyORB_src_corba_dynamicany is Dir := "src/corba/dynamicany"; Obj_Dir := PolyORB_Common.Build_Dir & Dir; for Object_Dir use Obj_Dir; for Source_Dirs use (Obj_Dir, PolyORB_Common.Source_Dir & Dir); for Library_Name use "polyorb-corba-dynamicany"; for Library_Dir use PolyORB_Common.Build_Dir & "lib"; for Library_ALI_Dir use PolyORB_Common.Build_Dir & "ali/src_corba_dynamicany"; for Library_Kind use "static"; package Compiler is for Default_Switches ("Ada") use PolyORB_Src.Compiler'Default_Switches ("Ada"); end Compiler; end PolyORB_src_corba_dynamicany; polyorb-2.8~20110207.orig/projects/polyorb_cos_naming.gpr0000644000175000017500000000525011750740337022640 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B _ C O S _ N A M I N G -- -- -- -- P r o j -- -- -- -- Copyright (C) 2007-2009, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with "polyorb_common", "polyorb_src", "polyorb_src_corba", "polyorb_idls_cos_naming"; project PolyORB_cos_naming is Dir := "cos/naming"; Obj_Dir := PolyORB_Common.Build_Dir & Dir; for Object_Dir use Obj_Dir; for Source_Dirs use (Obj_Dir, PolyORB_Common.Source_Dir & Dir); for Library_Name use "polyorb-corba-cos-naming-impl"; for Library_Dir use PolyORB_Common.Build_Dir & "lib"; for Library_ALI_Dir use PolyORB_Common.Build_Dir & "ali/cos_naming"; for Library_Kind use "static"; package Compiler is for Default_Switches ("Ada") use PolyORB_Common.Compiler'Default_Switches ("Ada"); end Compiler; end PolyORB_cos_naming; polyorb-2.8~20110207.orig/projects/polyorb_cos_event.gpr0000644000175000017500000000524211750740337022511 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B _ C O S _ E V E N T -- -- -- -- P r o j -- -- -- -- Copyright (C) 2007-2009, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with "polyorb_common", "polyorb_src", "polyorb_src_corba", "polyorb_idls_cos_event"; project PolyORB_cos_event is Dir := "cos/event"; Obj_Dir := PolyORB_Common.Build_Dir & Dir; for Object_Dir use Obj_Dir; for Source_Dirs use (Obj_Dir, PolyORB_Common.Source_Dir & Dir); for Library_Name use "polyorb-corba-cos-event-impl"; for Library_Dir use PolyORB_Common.Build_Dir & "lib"; for Library_ALI_Dir use PolyORB_Common.Build_Dir & "ali/cos_event"; for Library_Kind use "static"; package Compiler is for Default_Switches ("Ada") use PolyORB_Common.Compiler'Default_Switches ("Ada"); end Compiler; end PolyORB_cos_event; polyorb-2.8~20110207.orig/projects/polyorb_src_srp.gpr0000644000175000017500000000512711750740337022201 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B _ S R C _ S R P -- -- -- -- P r o j -- -- -- -- Copyright (C) 2007-2009, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with "polyorb_common", "polyorb_src"; project PolyORB_src_srp is Dir := "src/srp"; Obj_Dir := PolyORB_Common.Build_Dir & Dir; for Object_Dir use Obj_Dir; for Source_Dirs use (Obj_Dir, PolyORB_Common.Source_Dir & Dir); for Library_Name use "polyorb-srp"; for Library_Dir use PolyORB_Common.Build_Dir & "lib"; for Library_ALI_Dir use PolyORB_Common.Build_Dir & "ali/src_srp"; for Library_Kind use "static"; package Compiler is for Default_Switches ("Ada") use PolyORB_Src.Compiler'Default_Switches ("Ada"); end Compiler; end PolyORB_src_srp; polyorb-2.8~20110207.orig/projects/polyorb_cos_notification.gpr0000644000175000017500000000531511750740337024057 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B _ C O S _ N O T I F I C A T I O N -- -- -- -- P r o j -- -- -- -- Copyright (C) 2007-2009, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with "polyorb_common", "polyorb_src", "polyorb_src_corba", "polyorb_idls_cos_notification"; project PolyORB_cos_notification is Dir := "cos/notification"; Obj_Dir := PolyORB_Common.Build_Dir & Dir; for Object_Dir use Obj_Dir; for Source_Dirs use (Obj_Dir, PolyORB_Common.Source_Dir & Dir); for Library_Name use "polyorb-corba-cos-notification-impl"; for Library_Dir use PolyORB_Common.Build_Dir & "lib"; for Library_ALI_Dir use PolyORB_Common.Build_Dir & "ali/cos_notification"; for Library_Kind use "static"; package Compiler is for Default_Switches ("Ada") use PolyORB_Common.Compiler'Default_Switches ("Ada"); end Compiler; end PolyORB_cos_notification; polyorb-2.8~20110207.orig/projects/polyorb_src_security_tls.gpr0000644000175000017500000000527111750740337024126 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B _ S R C _ S E C U R I T Y _ T L S -- -- -- -- P r o j -- -- -- -- Copyright (C) 2007-2009, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with "polyorb_common", "polyorb_src", "polyorb_src_security", "polyorb_src_security_x509"; project PolyORB_src_security_tls is Dir := "src/security/tls"; Obj_Dir := PolyORB_Common.Build_Dir & Dir; for Object_Dir use Obj_Dir; for Source_Dirs use (Obj_Dir, PolyORB_Common.Source_Dir & Dir); for Library_Name use "polyorb-security-tls"; for Library_Dir use PolyORB_Common.Build_Dir & "lib"; for Library_ALI_Dir use PolyORB_Common.Build_Dir & "ali/src_security_tls"; for Library_Kind use "static"; package Compiler is for Default_Switches ("Ada") use PolyORB_Src.Compiler'Default_Switches ("Ada"); end Compiler; end PolyORB_src_security_tls; polyorb-2.8~20110207.orig/projects/polyorb_src_dns_udns.gpr0000644000175000017500000000520311750740337023205 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B _ S R C _ D N S _ U D N S -- -- -- -- P r o j -- -- -- -- Copyright (C) 2007-2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with "polyorb_common", "polyorb_src", "polyorb_src_dns"; project PolyORB_src_dns_udns is Dir := "src/dns/udns"; Obj_Dir := PolyORB_Common.Build_Dir & Dir; for Object_Dir use Obj_Dir; for Source_Dirs use (Obj_Dir, PolyORB_Common.Source_Dir & Dir); for Library_Name use "polyorb-dns-udns"; for Library_Dir use PolyORB_Common.Build_Dir & "lib"; for Library_ALI_Dir use PolyORB_Common.Build_Dir & "ali/src_dns_udns"; for Library_Kind use "static"; package Compiler is for Default_Switches ("Ada") use PolyORB_Src.Compiler'Default_Switches ("Ada"); end Compiler; end PolyORB_src_dns_udns; polyorb-2.8~20110207.orig/projects/polyorb.gpr.in0000644000175000017500000000426111750740337021051 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B -- -- -- -- P r o j -- -- -- -- Copyright (C) 2007-2009, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with "polyorb_common", "polyorb_src_setup"; @NO_SSL@with "polyorb_src_setup_security"; @WITH_SERVICE_PRJS@ project PolyORB is for Source_Files use (); end PolyORB; polyorb-2.8~20110207.orig/projects/polyorb_src_ssl.gpr0000644000175000017500000000517311750740337022177 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B _ S R C _ S S L -- -- -- -- P r o j -- -- -- -- Copyright (C) 2007-2009, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with "polyorb_common", "polyorb_src"; project PolyORB_src_ssl is for Languages use ("Ada", "C"); Dir := "src/ssl"; Obj_Dir := PolyORB_Common.Build_Dir & Dir; for Object_Dir use Obj_Dir; for Source_Dirs use (Obj_Dir, PolyORB_Common.Source_Dir & Dir); for Library_Name use "polyorb-ssl"; for Library_Dir use PolyORB_Common.Build_Dir & "lib"; for Library_ALI_Dir use PolyORB_Common.Build_Dir & "ali/src_ssl"; for Library_Kind use "static"; package Compiler is for Default_Switches ("Ada") use PolyORB_Src.Compiler'Default_Switches ("Ada"); end Compiler; end PolyORB_src_ssl; polyorb-2.8~20110207.orig/projects/polyorb_src_moma.gpr0000644000175000017500000000513411750740337022324 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B _ S R C _ M O M A -- -- -- -- P r o j -- -- -- -- Copyright (C) 2007-2009, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with "polyorb_common", "polyorb_src"; project PolyORB_src_moma is Dir := "src/moma"; Obj_Dir := PolyORB_Common.Build_Dir & Dir; for Object_Dir use Obj_Dir; for Source_Dirs use (Obj_Dir, PolyORB_Common.Source_Dir & Dir); for Library_Name use "polyorb-moma"; for Library_Dir use PolyORB_Common.Build_Dir & "lib"; for Library_ALI_Dir use PolyORB_Common.Build_Dir & "ali/src_moma"; for Library_Kind use "static"; package Compiler is for Default_Switches ("Ada") use PolyORB_Src.Compiler'Default_Switches ("Ada"); end Compiler; end PolyORB_src_moma; polyorb-2.8~20110207.orig/projects/polyorb_common.gpr0000644000175000017500000001000511750740337022005 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B _ C O M M O N -- -- -- -- P r o j -- -- -- -- Copyright (C) 2007-2009, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with "polyorb_config"; project PolyORB_Common is -- This project is imported by all the polyorb project files. type Build_Type is ("PRODUCTION", "DEBUG"); Build : Build_Type := external ("Build", "PRODUCTION"); Warnings_Mode := external ("Warnings_Mode", "e"); -- Possible values: -- e: treat warnings as errors, default -- n: normal warnings processing -- s: suppress all warnings for Source_Files use (); Build_Dir := PolyORB_Config.Top_Build_Dir; -- Used to set source, object, and ALI dirs of importing projects Source_Dir := PolyORB_Config.Top_Source_Dir; -- Used to set source dir of importing projects Cfg_Pragmas_Switch := "-gnatec=" & Build_Dir & "src/config.adc"; package Compiler is Base_Ada_Compiler_Switches := ("-gnat05", -- Ada 2005 mode "-gnati1", -- Full ISO 8859-1 character set allowed in -- source code (for generated CORBA stubs) "-gnatf", -- Full compiler error messages Cfg_Pragmas_Switch, -- Configuration pragmas from configure PolyORB_Config.Style_Switch, -- Enable style checks "-gnatwal" & Warnings_Mode); -- Enable all warnings, also enable elaboration -- warnings, and treat all warnings as errors -- if Warnings_As_Errors is set to "e". case Build is when "PRODUCTION" => for Default_Switches ("Ada") use Base_Ada_Compiler_Switches & ("-gnatp", -- Suppress all checks "-gnatn"); -- Enable inlining when "DEBUG" => for Default_Switches ("Ada") use Base_Ada_Compiler_Switches & ("-gnato", -- Overflow checks "-gnata", -- Enable assertions "-fstack-check"); -- Stack overflow checking end case; end Compiler; end PolyORB_Common; polyorb-2.8~20110207.orig/projects/polyorb_src_setup_security.gpr0000644000175000017500000000566011750740337024466 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B _ S R C _ S E T U P _ S E C U R I T Y -- -- -- -- P r o j -- -- -- -- Copyright (C) 2007-2009, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- Pre-canned setups for security subsystem -- See src_setup for purpose and usage rules with "polyorb_common", "polyorb_src", "polyorb_src_corba", "polyorb_src_giop", "polyorb_src_security", "polyorb_src_security_gssup", "polyorb_src_corba_security", "polyorb_src_giop_iiop_security", "polyorb_src_giop_iiop_security_tls"; project PolyORB_src_setup_security is Dir := "src/setup/security"; Obj_Dir := PolyORB_Common.Build_Dir & Dir; for Object_Dir use Obj_Dir; for Source_Dirs use (Obj_Dir, PolyORB_Common.Source_Dir & Dir); for Library_Name use "polyorb-setup-security"; for Library_Dir use PolyORB_Common.Build_Dir & "lib"; for Library_ALI_Dir use PolyORB_Common.Build_Dir & "ali/src_setup_security"; for Library_Kind use "static"; package Compiler is for Default_Switches ("Ada") use PolyORB_Src.Compiler'Default_Switches ("Ada"); end Compiler; end PolyORB_src_setup_security; polyorb-2.8~20110207.orig/projects/polyorb_src_web_common.gpr0000644000175000017500000000517211750740337023522 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B _ S R C _ W E B _ C O M M O N -- -- -- -- P r o j -- -- -- -- Copyright (C) 2007-2009, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with "polyorb_common", "polyorb_src"; project PolyORB_src_web_common is Dir := "src/web_common"; Obj_Dir := PolyORB_Common.Build_Dir & Dir; for Object_Dir use Obj_Dir; for Source_Dirs use (Obj_Dir, PolyORB_Common.Source_Dir & Dir); for Library_Name use "polyorb-web_common"; for Library_Dir use PolyORB_Common.Build_Dir & "lib"; for Library_ALI_Dir use PolyORB_Common.Build_Dir & "ali/src_web_common"; for Library_Kind use "static"; package Compiler is for Default_Switches ("Ada") use PolyORB_Src.Compiler'Default_Switches ("Ada"); end Compiler; end PolyORB_src_web_common; polyorb-2.8~20110207.orig/projects/polyorb_build_all.gpr0000644000175000017500000000662311750740337022457 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B _ B U I L D _ A L L -- -- -- -- P r o j -- -- -- -- Copyright (C) 2007-2009, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with "polyorb_common", "polyorb_cos_event", "polyorb_cos_ir", "polyorb_cos_naming", "polyorb_cos_notification", "polyorb_cos_time", "polyorb_idls_cos_event", "polyorb_idls_cos_naming", "polyorb_idls_cos_notification", "polyorb_idls_cos_time", "polyorb_src", "polyorb_src_corba", "polyorb_src_corba_dynamicany", "polyorb_src_corba_iop", "polyorb_src_corba_messaging", "polyorb_src_corba_portableinterceptor", "polyorb_src_corba_rtcorba", "polyorb_src_corba_security", "polyorb_src_corba_security_gssup", "polyorb_src_dsa", "polyorb_src_giop", "polyorb_src_giop_diop", "polyorb_src_giop_iiop", "polyorb_src_giop_iiop_security", "polyorb_src_giop_iiop_security_tls", "polyorb_src_giop_iiop_ssliop", "polyorb_src_giop_miop", "polyorb_src_moma", "polyorb_src_security", "polyorb_src_security_gssup", "polyorb_src_security_tls", "polyorb_src_security_x509", "polyorb_src_setup", "polyorb_src_setup_security", "polyorb_src_soap", "polyorb_src_srp", "polyorb_src_ssl", "polyorb_src_web_common" ; -- "polyorb_tools_po_catref", -- "tools_po_cos_naming.gpr", -- "polyorb_tools_po_dumpir", - "tools_po_ir.gpr", -- "polyorb_tools_po_names"; project PolyORB_Build_All is for Source_Files use (); end PolyORB_Build_All; polyorb-2.8~20110207.orig/projects/polyorb_src_giop_iiop_security.gpr0000644000175000017500000000534711750740337025306 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B _ S R C _ G I O P _ I I O P _ S E C U R I T Y -- -- -- -- P r o j -- -- -- -- Copyright (C) 2007-2009, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with "polyorb_common", "polyorb_src", "polyorb_src_giop", "polyorb_src_giop_iiop", "polyorb_src_security"; project PolyORB_src_giop_iiop_security is Dir := "src/giop/iiop/security"; Obj_Dir := PolyORB_Common.Build_Dir & Dir; for Object_Dir use Obj_Dir; for Source_Dirs use (Obj_Dir, PolyORB_Common.Source_Dir & Dir); for Library_Name use "polyorb-giop-iiop-security"; for Library_Dir use PolyORB_Common.Build_Dir & "lib"; for Library_ALI_Dir use PolyORB_Common.Build_Dir & "ali/src_giop_iiop_security"; for Library_Kind use "static"; package Compiler is for Default_Switches ("Ada") use PolyORB_Src.Compiler'Default_Switches ("Ada"); end Compiler; end PolyORB_src_giop_iiop_security; polyorb-2.8~20110207.orig/projects/polyorb_idls_cos_notification.gpr0000644000175000017500000000531711750740337025074 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B _ I D L S _ C O S _ N O T I F I C A T I O N -- -- -- -- P r o j -- -- -- -- Copyright (C) 2007-2009, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with "polyorb_common", "polyorb_src", "polyorb_src_corba", "polyorb_cos_event"; project PolyORB_idls_cos_notification is Dir := "idls/cos/notification"; Obj_Dir := PolyORB_Common.Build_Dir & Dir; for Object_Dir use Obj_Dir; for Source_Dirs use (Obj_Dir, PolyORB_Common.Source_Dir & Dir); for Library_Name use "polyorb-corba-cos-notification"; for Library_Dir use PolyORB_Common.Build_Dir & "lib"; for Library_ALI_Dir use PolyORB_Common.Build_Dir & "ali/idls_cos_notification"; for Library_Kind use "static"; package Compiler is for Default_Switches ("Ada") use PolyORB_Common.Compiler'Default_Switches ("Ada"); end Compiler; end PolyORB_idls_cos_notification; polyorb-2.8~20110207.orig/projects/polyorb_tools_po_names.gpr0000644000175000017500000000473711750740337023555 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B _ T O O L S _ P O _ N A M E S -- -- -- -- P r o j -- -- -- -- Copyright (C) 2007-2009, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with "polyorb_common", "polyorb_src", "polyorb_src_setup"; project PolyORB_tools_po_names is Dir := "tools/po_names"; Obj_Dir := PolyORB_Common.Build_Dir & Dir; for Object_Dir use Obj_Dir; for Source_Dirs use (Obj_Dir, PolyORB_Common.Source_Dir & Dir); package Compiler is for Default_Switches ("Ada") use PolyORB_Common.Compiler'Default_Switches ("Ada"); end Compiler; for Main use ("po_names.adb"); end PolyORB_tools_po_names; polyorb-2.8~20110207.orig/projects/polyorb_test_common.gpr0000644000175000017500000000467411750740337023063 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B _ T E S T _ C O M M O N -- -- -- -- P r o j -- -- -- -- Copyright (C) 2007-2009, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with "polyorb_common"; project PolyORB_Test_Common is -- This project is imported by all the local.gpr projects under examples and -- testsuite. for Source_Files use (); Build_Dir := PolyORB_Common.Build_Dir; Source_Dir := PolyORB_Common.Source_Dir; package Compiler is for Default_Switches ("Ada") use PolyORB_Common.Compiler'Default_Switches ("Ada"); end Compiler; end PolyORB_Test_Common; polyorb-2.8~20110207.orig/projects/polyorb_idls_cos_event.gpr0000644000175000017500000000522711750740337023527 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B _ I D L S _ C O S _ E V E N T -- -- -- -- P r o j -- -- -- -- Copyright (C) 2007-2009, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with "polyorb_common", "polyorb_src", "polyorb_src_corba"; project PolyORB_idls_cos_event is Dir := "idls/cos/event"; Obj_Dir := PolyORB_Common.Build_Dir & Dir; for Object_Dir use Obj_Dir; for Source_Dirs use (Obj_Dir, PolyORB_Common.Source_Dir & Dir); for Library_Name use "polyorb-corba-cos-event"; for Library_Dir use PolyORB_Common.Build_Dir & "lib"; for Library_ALI_Dir use PolyORB_Common.Build_Dir & "ali/idls_cos_event"; for Library_Kind use "static"; package Compiler is for Default_Switches ("Ada") use PolyORB_Common.Compiler'Default_Switches ("Ada"); end Compiler; end PolyORB_idls_cos_event; polyorb-2.8~20110207.orig/projects/polyorb_src_security_x509.gpr0000644000175000017500000000530511750740337024027 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B _ S R C _ S E C U R I T Y _ X 5 0 9 -- -- -- -- P r o j -- -- -- -- Copyright (C) 2007-2009, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with "polyorb_common", "polyorb_src", "polyorb_src_security"; project PolyORB_src_security_x509 is for Languages use ("Ada", "C"); Dir := "src/security/x509"; Obj_Dir := PolyORB_Common.Build_Dir & Dir; for Object_Dir use Obj_Dir; for Source_Dirs use (Obj_Dir, PolyORB_Common.Source_Dir & Dir); for Library_Name use "polyorb-security-x509"; for Library_Dir use PolyORB_Common.Build_Dir & "lib"; for Library_ALI_Dir use PolyORB_Common.Build_Dir & "ali/src_security_x509"; for Library_Kind use "static"; package Compiler is for Default_Switches ("Ada") use PolyORB_Src.Compiler'Default_Switches ("Ada"); end Compiler; end PolyORB_src_security_x509; polyorb-2.8~20110207.orig/projects/polyorb_src_security.gpr0000644000175000017500000000522411750740337023242 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B _ S R C _ S E C U R I T Y -- -- -- -- P r o j -- -- -- -- Copyright (C) 2007-2009, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with "polyorb_common", "polyorb_src"; project PolyORB_src_security is for Languages use ("Ada", "C"); Dir := "src/security"; Obj_Dir := PolyORB_Common.Build_Dir & Dir; for Object_Dir use Obj_Dir; for Source_Dirs use (Obj_Dir, PolyORB_Common.Source_Dir & Dir); for Library_Name use "polyorb-security"; for Library_Dir use PolyORB_Common.Build_Dir & "lib"; for Library_ALI_Dir use PolyORB_Common.Build_Dir & "ali/src_security"; for Library_Kind use "static"; package Compiler is for Default_Switches ("Ada") use PolyORB_Src.Compiler'Default_Switches ("Ada"); end Compiler; end PolyORB_src_security; polyorb-2.8~20110207.orig/projects/polyorb_src_giop_iiop_ssliop.gpr0000644000175000017500000000533011750740337024740 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B _ S R C _ G I O P _ I I O P _ S S L I O P -- -- -- -- P r o j -- -- -- -- Copyright (C) 2007-2009, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with "polyorb_common", "polyorb_src", "polyorb_src_giop", "polyorb_src_giop_iiop", "polyorb_src_ssl"; project PolyORB_src_giop_iiop_ssliop is Dir := "src/giop/iiop/ssliop"; Obj_Dir := PolyORB_Common.Build_Dir & Dir; for Object_Dir use Obj_Dir; for Source_Dirs use (Obj_Dir, PolyORB_Common.Source_Dir & Dir); for Library_Name use "polyorb-giop-iiop-ssliop"; for Library_Dir use PolyORB_Common.Build_Dir & "lib"; for Library_ALI_Dir use PolyORB_Common.Build_Dir & "ali/src_giop_iiop_ssliop"; for Library_Kind use "static"; package Compiler is for Default_Switches ("Ada") use PolyORB_Src.Compiler'Default_Switches ("Ada"); end Compiler; end PolyORB_src_giop_iiop_ssliop; polyorb-2.8~20110207.orig/projects/polyorb_src_corba_security_gssup.gpr0000644000175000017500000000553011750740337025631 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B _ S R C _ C O R B A _ S E C U R I T Y _ G S S U P -- -- -- -- P r o j -- -- -- -- Copyright (C) 2007-2009, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with "polyorb_common", "polyorb_src", "polyorb_src_corba", "polyorb_src_corba_security", "polyorb_src_security"; project PolyORB_src_corba_security_gssup is Dir := "src/corba/security/gssup"; Obj_Dir := PolyORB_Common.Build_Dir & Dir; for Object_Dir use Obj_Dir; for Source_Dirs use (Obj_Dir); -- for Source_Dirs use (Obj_Dir, PolyORB_Common.Source_Dir & Dir); -- Only generated sources, no sources from repository for Library_Name use "polyorb-corba-security-gssup"; for Library_Dir use PolyORB_Common.Build_Dir & "lib"; for Library_ALI_Dir use PolyORB_Common.Build_Dir & "ali/src_corba_security_gssup"; for Library_Kind use "static"; package Compiler is for Default_Switches ("Ada") use PolyORB_Src.Compiler'Default_Switches ("Ada"); end Compiler; end PolyORB_src_corba_security_gssup; polyorb-2.8~20110207.orig/projects/polyorb_src_soap.gpr0000644000175000017500000000534311750740337022337 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B _ S R C _ S O A P -- -- -- -- P r o j -- -- -- -- Copyright (C) 2007-2009, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with "polyorb_common", "polyorb_src", "polyorb_src_web_common", "xmlada"; -- Note that the ADA_PROJECT_PATH environment variable must be set so we can -- find xmlada.gpr. project PolyORB_src_soap is Dir := "src/soap"; Obj_Dir := PolyORB_Common.Build_Dir & Dir; for Object_Dir use Obj_Dir; for Source_Dirs use (Obj_Dir, PolyORB_Common.Source_Dir & Dir); for Library_Name use "polyorb-soap"; for Library_Dir use PolyORB_Common.Build_Dir & "lib"; for Library_ALI_Dir use PolyORB_Common.Build_Dir & "ali/src_soap"; for Library_Kind use "static"; package Compiler is for Default_Switches ("Ada") use PolyORB_Src.Compiler'Default_Switches ("Ada"); end Compiler; end PolyORB_src_soap; polyorb-2.8~20110207.orig/projects/polyorb_config.gpr.in0000644000175000017500000000440511750740337022376 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B _ C O N F I G -- -- -- -- P r o j -- -- -- -- Copyright (C) 2007-2009, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- Defaults set by configure -- @configure_input@ project PolyORB_Config is Top_Source_Dir := "@abs_top_srcdir@/"; Top_Build_Dir := "@abs_top_builddir@/"; for Source_Files use (); Style_Switch := "@STYLE_SWITCH@"; end PolyORB_Config; polyorb-2.8~20110207.orig/projects/polyorb_tools_po_dumpir.gpr0000644000175000017500000000501711750740337023742 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B _ T O O L S _ P O _ D U M P I R -- -- -- -- P r o j -- -- -- -- Copyright (C) 2007-2009, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with "polyorb_common", "polyorb_src", "polyorb_src_corba", "polyorb_cos_ir"; with "polyorb_src_setup"; project PolyORB_tools_po_dumpir is Dir := "tools/po_dumpir"; Obj_Dir := PolyORB_Common.Build_Dir & Dir; for Object_Dir use Obj_Dir; for Source_Dirs use (Obj_Dir, PolyORB_Common.Source_Dir & Dir); package Compiler is for Default_Switches ("Ada") use PolyORB_Common.Compiler'Default_Switches ("Ada"); end Compiler; for Main use ("po_dumpir.adb"); end PolyORB_tools_po_dumpir; polyorb-2.8~20110207.orig/projects/polyorb_src_giop_iiop_security_tls.gpr0000644000175000017500000000552611750740337026167 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B _ S R C _ G I O P _ I I O P _ S E C U R I T Y _ T L S -- -- -- -- P r o j -- -- -- -- Copyright (C) 2007-2009, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with "polyorb_common", "polyorb_src", "polyorb_src_giop", "polyorb_src_giop_iiop", "polyorb_src_giop_iiop_security", "polyorb_src_security", "polyorb_src_security_tls", "polyorb_src_security_x509"; project PolyORB_src_giop_iiop_security_tls is Dir := "src/giop/iiop/security/tls"; Obj_Dir := PolyORB_Common.Build_Dir & Dir; for Object_Dir use Obj_Dir; for Source_Dirs use (Obj_Dir, PolyORB_Common.Source_Dir & Dir); for Library_Name use "polyorb-giop-iiop-security-tls"; for Library_Dir use PolyORB_Common.Build_Dir & "lib"; for Library_ALI_Dir use PolyORB_Common.Build_Dir & "ali/src_giop_iiop_security_tls"; for Library_Kind use "static"; package Compiler is for Default_Switches ("Ada") use PolyORB_Src.Compiler'Default_Switches ("Ada"); end Compiler; end PolyORB_src_giop_iiop_security_tls; polyorb-2.8~20110207.orig/projects/polyorb_tools_po_cos_naming.gpr0000644000175000017500000000517611750740337024565 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B _ T O O L S _ P O _ C O S _ N A M I N G -- -- -- -- P r o j -- -- -- -- Copyright (C) 2007-2009, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with "polyorb_common", "polyorb_src", "polyorb_src_corba", "polyorb_idls_cos_naming", "polyorb_cos_naming", "polyorb_cos_ir"; with "polyorb_src_setup"; project PolyORB_tools_po_cos_naming is Dir := "tools/po_cos_naming"; Obj_Dir := PolyORB_Common.Build_Dir & Dir; for Object_Dir use Obj_Dir; for Source_Dirs use (Obj_Dir, PolyORB_Common.Source_Dir & Dir); package Compiler is for Default_Switches ("Ada") use PolyORB_Common.Compiler'Default_Switches ("Ada"); end Compiler; for Main use ("po_cos_naming.adb", "po_cos_naming_shell.adb", "ir_ab_names.adb"); end PolyORB_tools_po_cos_naming; polyorb-2.8~20110207.orig/projects/polyorb_idls_cos_time.gpr0000644000175000017500000000522211750740337023337 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B _ I D L S _ C O S _ T I M E -- -- -- -- P r o j -- -- -- -- Copyright (C) 2007-2009, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with "polyorb_common", "polyorb_src", "polyorb_src_corba"; project PolyORB_idls_cos_time is Dir := "idls/cos/time"; Obj_Dir := PolyORB_Common.Build_Dir & Dir; for Object_Dir use Obj_Dir; for Source_Dirs use (Obj_Dir, PolyORB_Common.Source_Dir & Dir); for Library_Name use "polyorb-corba-cos-time"; for Library_Dir use PolyORB_Common.Build_Dir & "lib"; for Library_ALI_Dir use PolyORB_Common.Build_Dir & "ali/idls_cos_time"; for Library_Kind use "static"; package Compiler is for Default_Switches ("Ada") use PolyORB_Common.Compiler'Default_Switches ("Ada"); end Compiler; end PolyORB_idls_cos_time; polyorb-2.8~20110207.orig/projects/polyorb_src_aws.gpr0000644000175000017500000000540211750740337022163 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B _ S R C _ A W S -- -- -- -- P r o j -- -- -- -- Copyright (C) 2009, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with "polyorb_common", "polyorb_src", "polyorb_src_web_common", "xmlada"; -- Note that the ADA_PROJECT_PATH environment variable must be set so we can -- find xmlada.gpr. project PolyORB_src_aws is Dir := "src/aws"; Obj_Dir := PolyORB_Common.Build_Dir & Dir; for Object_Dir use Obj_Dir; for Source_Dirs use (Obj_Dir, PolyORB_Common.Source_Dir & Dir, Common.Source_Dir & "src/aws_orig"); for Library_Name use "polyorb-aws"; for Library_Dir use PolyORB_Common.Build_Dir & "lib"; for Library_ALI_Dir use PolyORB_Common.Build_Dir & "ali/src_aws"; for Library_Kind use "static"; package Compiler is for Default_Switches ("Ada") use PolyORB_Src.Compiler'Default_Switches ("Ada"); end Compiler; end PolyORB_src_aws; polyorb-2.8~20110207.orig/projects/polyorb_cos_time.gpr0000644000175000017500000000523411750740337022327 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B _ C O S _ T I M E -- -- -- -- P r o j -- -- -- -- Copyright (C) 2007-2009, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with "polyorb_common", "polyorb_src", "polyorb_src_corba", "polyorb_idls_cos_time"; project PolyORB_cos_time is Dir := "cos/time"; Obj_Dir := PolyORB_Common.Build_Dir & Dir; for Object_Dir use Obj_Dir; for Source_Dirs use (Obj_Dir, PolyORB_Common.Source_Dir & Dir); for Library_Name use "polyorb-corba-cos-time-impl"; for Library_Dir use PolyORB_Common.Build_Dir & "lib"; for Library_ALI_Dir use PolyORB_Common.Build_Dir & "ali/cos_time"; for Library_Kind use "static"; package Compiler is for Default_Switches ("Ada") use PolyORB_Common.Compiler'Default_Switches ("Ada"); end Compiler; end PolyORB_cos_time; polyorb-2.8~20110207.orig/projects/polyorb_src_giop_iiop.gpr0000644000175000017500000000521111750740337023345 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B _ S R C _ G I O P _ I I O P -- -- -- -- P r o j -- -- -- -- Copyright (C) 2007-2009, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with "polyorb_common", "polyorb_src", "polyorb_src_giop"; project PolyORB_src_giop_iiop is Dir := "src/giop/iiop"; Obj_Dir := PolyORB_Common.Build_Dir & Dir; for Object_Dir use Obj_Dir; for Source_Dirs use (Obj_Dir, PolyORB_Common.Source_Dir & Dir); for Library_Name use "polyorb-giop-iiop"; for Library_Dir use PolyORB_Common.Build_Dir & "lib"; for Library_ALI_Dir use PolyORB_Common.Build_Dir & "ali/src_giop_iiop"; for Library_Kind use "static"; package Compiler is for Default_Switches ("Ada") use PolyORB_Src.Compiler'Default_Switches ("Ada"); end Compiler; end PolyORB_src_giop_iiop; polyorb-2.8~20110207.orig/projects/polyorb_src_dsa.gpr0000644000175000017500000000612511750740337022143 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B _ S R C _ D S A -- -- -- -- P r o j -- -- -- -- Copyright (C) 2007-2009, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with "polyorb_common", "polyorb_src"; project PolyORB_src_dsa is Dir := "src/dsa"; Obj_Dir := PolyORB_Common.Build_Dir & Dir; for Object_Dir use Obj_Dir; for Source_Dirs use (Obj_Dir, PolyORB_Common.Source_Dir & Dir); for Library_Name use "polyorb-dsa"; for Library_Dir use PolyORB_Common.Build_Dir & "lib"; for Library_ALI_Dir use PolyORB_Common.Build_Dir & "ali/src_dsa"; for Library_Kind use "static"; package Compiler is for Default_Switches ("Ada") use PolyORB_Src.Compiler'Default_Switches ("Ada"); Ada_RTL_Switches := Compiler'Default_Switches ("Ada") & ("-gnatw" & PolyORB_Common.Warnings_Mode); -- Gnatmake compiles children of System with -gnatg (otherwise it is -- illegal to recompile such children). -gnatg sets the warnings mode -- to -gnatwe, so we need to reset it explicitly afterwards. for Switches ("s-parint.adb") use Ada_RTL_Switches; for Switches ("s-dsaser.adb") use Ada_RTL_Switches; for Switches ("s-dsatyp.adb") use Ada_RTL_Switches; end Compiler; end PolyORB_src_dsa; polyorb-2.8~20110207.orig/utils/0000755000175000017500000000000011750740340015542 5ustar xavierxavierpolyorb-2.8~20110207.orig/utils/make_distrib0000644000175000017500000000623211750740340020125 0ustar xavierxavier#!/bin/sh # # $Id: //droopi/main/utils/make_distrib#27 $ # # This script builds a compressed archive suitable for distribution. # # Usage: make_distrib [-Dn] [-svn] [-b branch] dir # # -D : build and package documentation # -n : assume a checkout has already been done in dir # -svn : use Subversion to extract files # -b branch : use that CM branch # dir : the distribution will unpack in directory

and will be # named .tar.gz # subversion=false nocheckout=false prepare_distrib_options= ################################################### # Usage information ################################################### usage() { echo "Usage: $0 [-Dks] [-svn] [-bBRANCH] -[ncs] tag dir" exit 1 } set -e ################################################### # Parse commande line ################################################### while getopts Dns:b: opt; do case "$opt" in D) prepare_distrib_options="${prepare_distrib_options} -D" ;; s) case "s$OPTARG" in svn) subversion=true ;; esac ;; n) nocheckout=true;; b) branch="$OPTARG" ;; *) usage ;; esac done shift `expr $OPTIND - 1` if [ $# != 1 ]; then usage fi dir=$1 ################################################### # Prepare temporary directory ################################################### prev=`pwd` tmp=${TMPDIR-/var/tmp}/make_distrib.$$ mkdir -p ${tmp}/${dir} trap "cd /; rm -fr ${tmp}" 0 ################################################### # Checkout from repository, if required ################################################### # Subversion if $subversion; then # Tag is always ignored if [ "${branch}" != "" ]; then case ${branch} in */global/*) view_root=${branch}/polyorb ;; *) view_root=${branch} ;; esac else view_root=/trunk/polyorb fi cd ${tmp}/${dir} tmp=`/bin/pwd` set +e svn checkout svn+ssh://svn.eu.adacore.com/Dev${view_root} . rc=$? set -e if [ $rc != 0 ]; then exit $rc fi # Get last change for this tree prepare_distrib_options="${prepare_distrib_options} -c "`svn log --limit 1 | sed -n '2s/^r\([0-9]*\) .*$/\1/p'` cd .. # Do no checkout elif $nocheckout; then # Edits will be done in place directly in this case # Note that this assumes that the specified directory contains a # clean checkout of the repository. : Nothing to do else echo "Specify either -svn or -n" exit 1 fi ${dir}/utils/prepare_distrib $prepare_distrib_options $dir ################################################### # Packaging ################################################### echo Packaging local_filelist=${tmp}/filelist rm -f ${local_filelist} for f in `cat ${dir}/MANIFEST`; do if [ ! -f ${dir}/${f} ]; then echo "FATAL: ${dir}/${f} is not a regular file." exit 1 fi echo ${dir}/${f} >> ${local_filelist} done # Check for GNU tar tar --version 2> /dev/null | grep "GNU tar" > /dev/null && \ GTAR_OPTS=--portability # Create package tar ${GTAR_OPTS} -cf ${dir}.tar -T ${local_filelist} gzip --best ${dir}.tar ls -l ${dir}.tar.gz if [ "`pwd`" != "${prev}" ]; then mv ${dir}.tar.gz ${prev} cd ${prev} fi rm -fr ${tmp} polyorb-2.8~20110207.orig/utils/update_headers.adb0000644000175000017500000003765611750740340021210 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- U P D A T E _ H E A D E R S -- -- -- -- B o d y -- -- -- -- Copyright (C) 2006-2009, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with Ada.Calendar; use Ada.Calendar; with Ada.Characters.Handling; use Ada.Characters.Handling; with Ada.Command_Line; with Ada.Directories; use Ada.Directories; with Ada.Exceptions; with Ada.Strings.Unbounded; use Ada.Strings.Unbounded; with Ada.Text_IO; use Ada.Text_IO; with GNAT.Regpat; use GNAT.Regpat; procedure Update_Headers is pragma Style_Checks ("mM100"); -- Allow long lines below subtype Line_Type is String (1 .. 256); type Kind_Type is (None, Unit_Spec, Unit_Body, Unit_Project); Header_Template : constant String := "------------------------------------------------------------------------------" & ASCII.LF & "-- --" & ASCII.LF & "-- POLYORB COMPONENTS --" & ASCII.LF & "-- --" & ASCII.LF & "@UNIT_NAME@" & "-- --" & ASCII.LF & "@COPYRIGHT@" & "-- --" & ASCII.LF & "@SECONDARY_HEADER@" & "-- PolyORB is free software; you can redistribute it and/or modify it --" & ASCII.LF & "-- under terms of the GNU General Public License as published by the Free --" & ASCII.LF & "-- Software Foundation; either version 2, or (at your option) any later --" & ASCII.LF & "-- version. PolyORB is distributed in the hope that it will be useful, --" & ASCII.LF & "-- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- --" & ASCII.LF & "-- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public --" & ASCII.LF & "-- License for more details. You should have received a copy of the GNU --" & ASCII.LF & "-- General Public License distributed with PolyORB; see file COPYING. If --" & ASCII.LF & "-- not, write to the Free Software Foundation, 51 Franklin Street, Fifth --" & ASCII.LF & "-- Floor, Boston, MA 02111-1301, USA. --" & ASCII.LF & "-- --" & ASCII.LF & "-- --" & ASCII.LF & "-- PolyORB is maintained by AdaCore --" & ASCII.LF & "-- (email: sales@adacore.com) --" & ASCII.LF & "-- --" & ASCII.LF & "------------------------------------------------------------------------------" & ASCII.LF; OMG_Header_Template : constant String := "-- This specification is derived from the CORBA Specification, and adapted --" & ASCII.LF & "-- for use with PolyORB. The copyright notice above, and the license --" & ASCII.LF & "-- provisions that follow apply solely to the contents neither explicitly --" & ASCII.LF & "-- nor implicitly specified by the CORBA Specification defined by the OMG. --" & ASCII.LF & "-- --" & ASCII.LF; ------------------------- -- Utility subprograms -- ------------------------- function Center_Ada (S : String) return String; -- Return S centered with comment delimiters of appropriate width function Copyright_Line (First_Year, Last_Year : Year_Number) return String; -- Return copyright notice for the specified year range function Doublespace (S : String) return String; -- Return S with double spacing inserted if short enough to fit the header -- comment box; otherwise return S unchanged. function Has_Prefix (Prefix : String; S : String) return Boolean; -- True iff S starts with Prefix function Image (Year : Year_Number) return String; -- Return the string image of Year (with no leading space) procedure Update_Header (Filename : String); -- Output the contents of Filename with updated header ---------------- -- Center_Ada -- ---------------- function Center_Ada (S : String) return String is Line : String (1 .. 78) := (others => ' '); Width : constant := Line'Length; Pos : constant Positive := (Line'Length - (S'Length - 1)) / 2; begin Line (1 .. 2) := "--"; Line (Line'Last - 1 .. Line'Last) := "--"; Line (Pos .. Pos + S'Length - 1) := S; return Line; end Center_Ada; -------------------- -- Copyright_Line -- -------------------- function Copyright_Line (First_Year, Last_Year : Year_Number) return String is Range_Image : constant String := Image (First_Year) & "-" & Image (Last_Year); Last : Positive := Range_Image'Last; begin if First_Year = Last_Year then Last := Range_Image'First + 3; end if; return "Copyright (C) " & Range_Image (Range_Image'First .. Last) & ", Free Software Foundation, Inc."; end Copyright_Line; ----------------- -- Doublespace -- ----------------- function Doublespace (S : String) return String is begin if S'Length > 35 then return S; else declare Res : String (2 * S'First .. 2 * S'Last) := (others => ' '); begin for J in S'Range loop Res (2 * J) := S (J); end loop; return Res; end; end if; end Doublespace; ---------------- -- Has_Prefix -- ---------------- function Has_Prefix (Prefix : String; S : String) return Boolean is begin return S'Length >= Prefix'Length and then S (S'First .. S'First + Prefix'Length - 1) = Prefix; end Has_Prefix; ----------- -- Image -- ----------- function Image (Year : Year_Number) return String is Res : constant String := Year'Img; begin return Res (Res'First + 1 .. Res'Last); end Image; ------------------- -- Update_Header -- ------------------- procedure Update_Header (Filename : String) is Ofilename : constant String := Filename & ".UHN"; ---------------------- -- Global variables -- ---------------------- UName : Unbounded_String; UKind : Kind_Type; Last_Copyright_Year : Year_Number := Year (Clock); First_Copyright_Year : Year_Number := Last_Copyright_Year; Require_OMG_Header : Boolean; type Substs is (Unit_Name, Copyright, Secondary_Header); procedure Output_Header (Outf : File_Type); -- Output header templates with appropriate substitutions procedure Output_Header (Outf : File_Type) is Pattern : Unbounded_String; function "+" (S : String) return Unbounded_String is begin return To_Unbounded_String (Center_Ada (S) & ASCII.LF); end "+"; Subst_Strings : array (Substs) of Unbounded_String := (Unit_Name => +Doublespace (To_Upper (To_String (UName))), Copyright => +Copyright_Line (First_Copyright_Year, Last_Copyright_Year), Secondary_Header => To_Unbounded_String ("")); Kind_Strings : constant array (Unit_Spec .. Unit_Project) of String (1 .. 4) := (Unit_Spec => "Spec", Unit_Body => "Body", Unit_Project => "Proj"); begin if UKind in Kind_Strings'Range then Append (Subst_Strings (Unit_Name), +""); Append (Subst_Strings (Unit_Name), +Doublespace (Kind_Strings (Ukind))); end if; if Require_OMG_Header then Subst_Strings (Secondary_Header) := To_Unbounded_String (OMG_Header_Template); end if; Pattern := To_Unbounded_String ("@("); for J in Substs loop Append (Pattern, J'Img); if J /= Substs'Last then Append (Pattern, '|'); end if; end loop; Append (Pattern, ")@"); declare Matcher : constant Pattern_Matcher := Compile (To_String (Pattern), Single_Line); Matches : Match_Array (0 .. Paren_Count (Matcher)); Start : Positive := Header_Template'First; begin while Start <= Header_Template'Last loop Match (Matcher, Header_Template (Start .. Header_Template'Last), Matches); if Matches (0) = No_Match then Put (Outf, Header_Template (Start .. Header_Template'Last)); exit; end if; declare Loc_Token : Match_Location renames Matches (1); begin Put (Outf, Header_Template (Start .. Loc_Token.First - 2)); Put (Outf, To_String (Subst_Strings (Substs'Value (Header_Template (Loc_Token.First .. Loc_Token.Last))))); Start := Loc_Token.Last + 2; end; end loop; end; end Output_Header; Line : Line_Type; Last : Natural; Copyright_Matcher : constant Pattern_Matcher := Compile ("Copyright \([cC]\) ([0-9]+)"); Copyright_Matches : Match_Array (0 .. Paren_Count (Copyright_Matcher)); Unit_Name_Matcher : constant Pattern_Matcher := Compile ("^(private\s+|separate \(([\w.]+)\)\s+)?" & "(procedure|function|project|package" & "(\s+body)?)\s+([\w.]+)\b"); Unit_Name_Matches : Match_Array (0 .. Paren_Count (Unit_Name_Matcher)); F : File_Type; Outf : File_Type; In_Header : Boolean := True; Buf : Unbounded_String; Basename : constant String := Base_Name (Filename); begin Open (F, In_File, Filename); Create (Outf, Out_File, Ofilename, Form => "Text_Translation=No"); begin -- Check for file kind suffix, but omit possible trailing ".in" -- for the case of autoconf template files. Last := Filename'Last; if Last - 2 >= Filename'First and then Filename (Last - 2 .. Last) = ".in" then Last := Last - 3; end if; if Last - 2 >= Filename'First then declare Extension : String renames Filename (Last - 2 .. Last); begin if Extension = "ads" then UKind := Unit_Spec; elsif Extension = "adb" then UKind := Unit_Body; elsif Extension = "gpr" then UKind := Unit_Project; else UKind := None; end if; end; end if; Require_OMG_Header := UKind = Unit_Spec and then (False or else Has_Prefix ("conv_frame", Basename) or else Has_Prefix ("corba", Basename) or else Has_Prefix ("portableinterceptor", Basename) or else Has_Prefix ("portableserver", Basename) or else Has_Prefix ("rtcorba", Basename) or else Has_Prefix ("rtcosscheduling", Basename) or else Has_Prefix ("rtportableserver", Basename)); loop Get_Line (F, Line, Last); if Last = Line'Last then raise Constraint_Error with "line too long"; end if; if Last < 2 or else Line (1 .. 2) /= "--" then In_Header := False; end if; if In_Header then Match (Copyright_Matcher, Line (1 .. Last), Copyright_Matches); if Copyright_Matches (0) /= No_Match then First_Copyright_Year := Year_Number'Value (Line (Copyright_Matches (1).First .. Copyright_Matches (1).Last)); end if; else Append (Buf, Line (1 .. Last)); Append (Buf, ASCII.LF); Match (Unit_Name_Matcher, Line (1 .. Last), Unit_Name_Matches); if Unit_Name_Matches (0) /= No_Match then if Unit_Name_Matches (1).First in Line'Range and then Line (Unit_Name_Matches (1).First) = 's' then -- Case of a separate body UName := To_Unbounded_String (Line (Unit_Name_Matches (2).First .. Unit_Name_Matches (2).Last)); Append (Uname, '.'); end if; Append (UName, Line (Unit_Name_Matches (5).First .. Unit_Name_Matches (5).Last)); exit; end if; end if; end loop; Output_Header (Outf); if Slice (Buf, 1, 1) /= (1 => ASCII.LF) then New_Line (Outf); end if; Put (Outf, To_String (Buf)); while not End_Of_File (F) loop Get_Line (F, Line, Last); if Last = Line'Last then raise Constraint_Error with "line too long"; end if; Put_Line (Outf, Line (1 .. Last)); end loop; Close (F); Close (Outf); Delete_File (Filename); Rename (Ofilename, Filename); exception when E : others => Put_Line (Standard_Error, "Update of " & Filename & " failed:"); Put_Line (Ada.Exceptions.Exception_Information (E)); Delete_File (Ofilename); end; end Update_Header; -- Start of processing for Update_Headers begin for J in 1 .. Ada.Command_Line.Argument_Count loop Update_Header (Ada.Command_Line.Argument (J)); end loop; end Update_Headers; polyorb-2.8~20110207.orig/utils/cobuild0000644000175000017500000001516111750740340017112 0ustar xavierxavier#! /bin/sh # cobuild: Build something from a checked-out wavefront. # $Id: cobuild 43098 2007-03-13 12:28:25Z hugues $ ################################################### # Usage information ################################################### usage () { echo "Usage: $0 -m EMAIL_ADDRESS -i SOURCE_DIR -o OUTPUT_DIR -p PROJECT -r [cvs | p4 | svn | none] [ -c CHANGELIST ]" echo " A notification e-mail will be sent to EMAIL_ADDRESS" echo " Source code is in SOURCE_DIR" echo " A symlink tree is made in OUTPUT_DIR/src" echo " Build is done in OUTPUT_DIR/build" echo " Install is done in OUTPUT_DIR/install" echo "" echo " PROJECT is the name of the project to be built" echo "" echo " Revision control options:" echo " cvs checkout PROJECT from CVS repository" echo " svn checkout PROJECT from Subversion repository" echo " p4 checkout PROJECT from Perforce repository" echo " none use source directory as is, do not attempt to checkout" echo "" echo " CHANGELIST indicates Perforce change number to use" exit 1 } ################################################### # Set defaults ################################################### MAILTO=root CM_REPOSITORY=none ################################################### # Parse commande line ################################################### while getopts c:i:o:m:p:r: opt do case $opt in c) CHANGELIST="$OPTARG" ;; i) SOURCE_DIR=$OPTARG ;; o) OUTPUT_DIR=$OPTARG ;; m) MAILTO=$OPTARG ;; p) PROJECT=$OPTARG ;; r) CM_REPOSITORY=$OPTARG ;; *) usage ;; esac done if [ "x$OUTPUT_DIR" = "x" ] then usage fi if [ "x$SOURCE_DIR" = "x" ] then usage fi case "$CM_REPOSITORY" in p4|cvs|svn|none) ;; *) usage ;; esac ################################################### # Setup environment ################################################### if [ "x$CM_REPOSITORY" = "xp4" ] then P4CONFIG=.p4 export P4CONFIG fi case ":$PATH:" in *:/usr/local/bin:*) ;; *) PATH=/usr/local/bin:$PATH ;; esac TMPDIR=/var/tmp GNUMAKE=gmake LANG=C export MAILTO OUTPUT_DIR SOURCE_DIR TMPDIR GNUMAKE \ PATH LANG set -e umask 022 PIDFILE=$OUTPUT_DIR/build.pid CHGFILE=$OUTPUT_DIR/build.change LOGFILE=$OUTPUT_DIR/build.log ################################################### # Prepare build ################################################### # Take mutex. lockfile $PIDFILE.lock trap 'rm -f $PIDFILE.lock' 0 # Determine change level to be built. cd $SOURCE_DIR case "$CM_REPOSITORY" in p4) if [ "$CHANGELIST" = "" ]; then CHANGELIST=`p4 changes -m 1 ... | awk '{print \$2}'` fi CM_TAG="$CHANGELIST" ;; svn) if [ "$CHANGELIST" = "" ]; then CHANGELIST=`svn log --limit 1 | sed -n '2s/^r\([0-9]*\) .*$/\1/p'` fi CM_TAG="$CHANGELIST" ;; cvs) if [ "$CHANGELIST" = "" ]; then CM_TAG="HEAD" else CM_TAG="ch_$CHANGELIST" fi ;; none) CM_TAG="current" ;; esac export CHANGELIST CM_TAG # Kill any previous build, unless we know for a fact # that the build in porgress is building this change # or a more recent one. if [ -f $PIDFILE ] then OLDPID=`cat $PIDFILE` if [ "x$OLDPID" != x ] && ps -p $OLDPID > /dev/null then # Build in progress. if [ "$CHANGELIST" != "" && -f "$CHGFILE" ]; then if [ "`cat $CHGFILE`" -ge "$CHANGELIST" ] then # Already building this changelist or a more recent one. exit 0 fi fi # Interrupt current build kill $OLDPID > /dev/null 2>&1 || true fi fi # Here comes the hot builder. exec > $LOGFILE 2>&1 # Prepare execution. echo "---------- Starting build of ${PROJECT} at `date`" echo "---------- Syncing from repository $CM_REPOSITORY at $CM_TAG" ################################################### # Update files ################################################### case "$CM_REPOSITORY" in p4) p4 sync @$CM_TAG ;; cvs) cvs update -d -C -r$CM_TAG ;; svn) svn update -r$CM_TAG ;; *) echo "Using currently directory as is" ;; esac ################################################### # Launch build process ################################################### rungroup /bin/sh -c '( set -e sleep 10 echo "---------- Preparing source tree" cd $OUTPUT_DIR rm -fr src mkdir src mkdir build > /dev/null 2>&1 || true mkdir install > /dev/null 2>&1 || true cd src while read file do dir=`dirname "$file"` mkdir -p "$dir" if [ -f "$SOURCE_DIR/$file" ] then ln -s "$SOURCE_DIR/$file" "$file" fi done < $SOURCE_DIR/MANIFEST if [ ! -e testsuite ] then ln -s "$SOURCE_DIR/testsuite" . fi support/reconfig -w # At this point every file named in MANIFEST must exist while read file do if [ ! -f "$file" ] then echo "FATAL: MANIFEST file $file not found." exit 1 fi done < MANIFEST cd ../build echo "---------- Building" if [ -x $OUTPUT_DIR/src/configure ] then $OUTPUT_DIR/src/configure --disable-shared --enable-debug \ --with-proto-perso="giop soap srp" --with-appli-perso="corba moma" \ --with-corba-services="naming ir event notification time" --with-openssl --prefix=$OUTPUT_DIR/install fi && ${GNUMAKE} && ${GNUMAKE} install && cd examples && ${GNUMAKE} && cd ../docs && ${GNUMAKE} && ${GNUMAKE} install # && cd ../testsuite && ${GNUMAKE} # XXX configure is not processing testsuite diectory! RC=$? exit $RC )' & # The build is now running in background. Save PID and changelist #, # and release mutex. THISPID=$! echo $THISPID > $PIDFILE if [ "$CHANGELIST" != "" ]; then echo $CHANGELIST > $CHGFILE fi ################################################### # Analyze build output ################################################### trap '' 0 rm -f $PIDFILE.lock set +e wait $THISPID RC=$? set -e if [ $RC = 0 ] then echo "---------- Build completed successfully: `date`" STATUS="completed" MSG="Build completed successfully.\\nSee details at $OUTPUT_DIR/build.log" SUCCESS=true elif [ $RC -ge 128 ] then echo "---------- Build aborted by a signal: `date`" STATUS="aborted" MSG="The build process was interrupted by a signal." SUCCESS=true else echo "---------- BUILD FAILED: `date`" SUCCESS=false fi if $SUCCESS then echo -e "$MSG" | Mail -s "${PROJECT} build $CM_REPOSITORY $CM_TAG $STATUS" $MAILTO else cat $OUTPUT_DIR/build.log | Mail -s "${PROJECT} BUILD $CM_REPOSITORY $CM_TAG FAILED" $MAILTO fi lockfile $PIDFILE.lock THATPID=`cat $PIDFILE` if [ "$THATPID" = "$THISPID" ] then rm -f $PIDFILE fi rm -f $PIDFILE.lock polyorb-2.8~20110207.orig/utils/chk_distrib.py0000644000175000017500000000631311750740340020404 0ustar xavierxavier#! /usr/bin/env python # import string, sys, re, os, glob, stat # All dirs: check MANIFEST vs. files def get_subdirs (dir): res = [dir] vars = {} for l in open (dir + "/Makefile.am", "r").readlines (): m = re.match ("^([A-Za-z_]*)\s*=\s*(.*)$", l) if m: if len (m.group (2)) > 0: vars[m.group (1)] = m.group (2) if m.group (1) != 'corba_dir' \ and m.group (1) != 'dsa_dir' \ and m.group (1) != 'giop_dir' \ and m.group (1) != 'moma_dir' \ and m.group (1) != 'soap_dir' \ and m.group (1) != 'srp_dir' \ and m.group (1) != 'SUBDIRS': continue dirs = map (lambda s, d=dir: d + "/" + s, string.split (m.group (2), ' ')) for d in dirs: if re.match (dir + "/\.?$", d): continue if re.match (dir + "/\@", d): continue d = re.sub("\\$\\(([^)]*)\\)", lambda mm, v=vars: v[mm.group (1)], d) sub = get_subdirs (d) for dd in sub: if not (dd in res): res = res + [dd] return res def read_MANIFEST (dir): MANIFEST = [] for l in open ("MANIFEST", "r").readlines (): l = l[:-1] if re.match (dir + "/[^/]*$", l): MANIFEST.append (l) if l[-3:] == ".in": MANIFEST.append (l[:-3]) return MANIFEST def read_files (dir): l = [] for f in glob.glob (dir + "/*"): if not re.search ("(\.(lo|o|ali|la)|~)$", f): mode = os.stat(f)[stat.ST_MODE] if stat.S_ISREG(mode): l.append(f) return l # Additional checks for src/: # allsrc alis_seen = [] def read_one_ali (alidir, file): try: f = open (alidir + "/" + file, "r") except: return [] units = [] for l in f.readlines (): if l[0] == 'U': units.append ("src/" + re.match ("^U\s*\S*\s*(\S*\.ad[bs])", l).group (1)) elif l[0] == 'W': m = re.match ("^W\s\S*\s*\S*\s*(\S*\.ali)", l) if m: ali = m.group (1) try: i = alis_seen.index (ali) except: alis_seen.append (ali) units = units + read_one_ali (alidir, ali) return units def read_allsrc (alidir): return read_one_ali (alidir, "allsrc.ali") def compare_lists (l1, l2, reverse): ll1 = eval (l1)[:] ll2 = eval (l2)[:] not_in_ll1 = [] for f in ll2: try: ll1.remove (f) except: not_in_ll1.append (f) if len (ll1) > 0: print ("These are in " + l1 + " but not in " + l2 + ":") print (" " + string.join (ll1, "\n ")) print "" if reverse and len (not_in_ll1) > 0: print ("These are in " + l2 + " but not in " + l1 + ":") print (" " + string.join (not_in_ll1, "\n ")) print "" if len (sys.argv) > 1: allsrc = read_allsrc (sys.argv[1]) compare_lists ("files", "allsrc", 0) subdirs = get_subdirs ("src") for d in subdirs: print "Checking " + d + "/...\n" MANIFEST = read_MANIFEST (d) files = read_files (d) compare_lists ("files", "MANIFEST", 1) subdirs = get_subdirs ("examples") + get_subdirs ("cos") + get_subdirs ("idls") for d in subdirs: print "Checking " + d + "/...\n" MANIFEST = read_MANIFEST (d) files = read_files (d) compare_lists ("files", "MANIFEST", 1) polyorb-2.8~20110207.orig/utils/rsync-polyorb-cvs0000755000175000017500000000135311750740340021105 0ustar xavierxavier#! /bin/sh # $Id: rsync-polyorb-cvs 37363 2006-02-27 14:32:19Z quinot $ # Copy the read-only CVS repository for PolyORB from the master # site to libre.act-europe.fr (this is a mirror of the real Perforce # depot, for users' convenience). umask 022 case "`id -u -n`" in gnatmail) ;; *) echo "This script must be run by gnatmail." exit 1 ;; esac DIR=/anoncvs/polyorb/ rsync "$@" --delete \ --exclude "#*" \ --exclude "/WWW" \ --exclude "/design" \ --exclude "/doc/memoires" \ --exclude "/doc/internal" \ --exclude "/docs/memoires" \ --exclude "/docs/internal" \ --exclude "/utils" \ -a www.polyorb.eu.org::polyorb-cvs/ $DIR && find $DIR -type d | xargs chgrp cvs && find $DIR -type d | xargs chmod g+w polyorb-2.8~20110207.orig/utils/sort_MANIFEST0000755000175000017500000000035611750740340017751 0ustar xavierxavier#! /bin/sh # Sort MANIFEST in (C locale) ascending order # $Id: sort_MANIFEST 37328 2006-02-02 11:59:43Z quinot $ unset LANG LC_ALL LC_COLLATE set -e tmpf=MANIFEST.$$ trap 'rm -f $tmpf' 0 cp MANIFEST $tmpf sort < $tmpf | uniq > MANIFEST polyorb-2.8~20110207.orig/utils/make_snapshot0000755000175000017500000000116611750740340020330 0ustar xavierxavier#! /bin/sh # $Id: make_snapshot 41653 2007-01-09 17:32:29Z quinot $ # # Build a snapshot of PolyORB from Perforce repository files. # # make_snapshot [-scp] # -scp : update snapshots directory on PolyORB's Web site. # scp=false case $1 in -scp) scp=true; shift;; *) ;; esac name=polyorb-src TMPDIR=$HOME utils/make_distrib -svn $name change=`tar tzf $name.tar.gz $name/CHANGE"*" | sed 's/.*CHANGE_//'` tar=polyorb-snap-$change.tar.gz mv $name.tar.gz $tar name=polyorb-snap-$change.tar.gz if $scp; then tar=$name.tar.gz scp $tar libre.act-europe.fr:/paris.a/httpd/html-libre/polyorb/snapshots/ \ && rm -f $tar fi polyorb-2.8~20110207.orig/utils/rungroup.c0000644000175000017500000000254711750740340017577 0ustar xavierxavier/* rungroup -- Run a command, kill whole process group if a signal /* is received. /********************************************************************/ /* $Id: //depot/adabroker/main/broca/utils/rungroup.c#1 $ */ #include #include #include #include #include int sig = 0; int status; void hnd (int s) { sig = s; } void hndcld (int s) { int st; while (waitpid (-1, &st, WNOHANG) > 0) { if (!sig && WIFEXITED (st)) status = st; sig = SIGCHLD; } } int main (int argc, char **argv, char **envp) { int child; if (setpgid (0, 0)) { perror ("setpgid"); exit (1); } ++argv; if ((child = fork ()) < 0) { perror ("fork"); exit (1); } if (!child) { execve (*argv, argv, envp); } signal (SIGTERM, hnd); signal (SIGINT, hnd); signal (SIGCHLD, hndcld); while (!(sig == SIGTERM || sig == SIGINT)) { pause (); if (sig == SIGCHLD) { printf ("Child terminated with status %u.\n", WEXITSTATUS (status)); exit (WEXITSTATUS (status)); } } printf ("Build aborted on signal %u.\n", sig); signal (SIGTERM, SIG_IGN); signal (SIGINT, SIG_IGN); signal (SIGCHLD, SIG_IGN); if (killpg (0, SIGTERM)) perror ("killpg-TERM"); sleep (2); while (waitpid (-1, NULL, WNOHANG) > 0); killpg (0, SIGKILL); exit (128 + sig); } polyorb-2.8~20110207.orig/utils/make_distrib_docs0000755000175000017500000000220111750740340021130 0ustar xavierxavier#!/bin/sh # # $Id$ # # This script builds a compressed archive suitable for the distribution # of PolyORB documentation # # Usage: make_distrib_docs dir # # dir : the distribution will unpack in directory and will be # named .tar.gz # ################################################### # Usage information ################################################### if [ $# = 0 ]; then echo "Usage: $0 dir"; exit 0; fi; dir="$1" ########################################## # Building the documentation ########################################## echo Building the documentation cd doc make release cd .. ########################################## # Preparing files ########################################## echo Preparing files mkdir -p ${dir} for f in `cat doc/MANIFEST`; do if [ ! -f doc/${f} ]; then echo "FATAL: ${dir}/${f} is not a regular file." exit 1 fi mkdir -p $dir/`dirname $f` cp doc/$f ${dir}/`dirname $f`/ done ################################################### # Packaging ################################################### echo Packaging tar zcvf ${dir}.tar.gz ${dir} rm -rf ${dir} polyorb-2.8~20110207.orig/utils/prepare_distrib0000755000175000017500000000667611750740340020665 0ustar xavierxavier#!/bin/sh # # $Id: prepare_distrib 167707 2010-12-01 12:24:05Z quinot $ # # This script performs all the necessary steps to transform a checked # out copy of PolyORB into a source tree suitable for packaging. # # The file MANIFEST contains the list of files to be included in this # archive, one file per line. # change= with_doc=false ################################################### # Usage information ################################################### usage() { echo "Usage: $0 [-c CHANGE] [-R release] [-V version] [-D] dir" echo " -c optional CM change identifier" echo " -R override release identifier" echo " -V optional additional version identifier" echo " -D build documentation" exit 1 } set -e ################################################### # Parse commande line ################################################### while getopts c:R:V:D opt; do case "$opt" in c) change="$OPTARG" ;; D) with_doc=true ;; R) override_release="$OPTARG" ;; V) additional_version="$OPTARG" ;; *) usage ;; esac done shift `expr $OPTIND - 1` if [ $# != 1 ]; then usage fi dir=$1 cd $dir rm -f MANIFEST.distrib if [ ! -z "$change" ]; then taginfo="CHANGE_${change}" if [ ! -f "${taginfo}" ]; then LANG=C date "+Packaged from repository rev. ${change} on %c" > ${taginfo} fi echo ${taginfo} >> MANIFEST.distrib fi ################################################### # Update version in all files ################################################### # sed_in_place FILE ARG... # Apply "sed ARG..." transformation to FILE sed_in_place() { oldfile=$1; shift newfile=$oldfile.new.$$ sed "$@" < $oldfile > $newfile mv -f $newfile $oldfile } # # Generate configure script # # Generate distrib.m4 to pass additional information related to packaged # sources to autoconf. ( # Switch default warnings mode to "n" (default is "e" when building from # a checkout). echo "define([DEFAULT_WARNINGS_MODE], [n])" # Strip binaries when installing in non-debug mode echo "define([STRIP_PRODUCTION_BINARIES], [true])" # Release name override and additional version information from command line if [ -n "$override_release" ]; then echo "define([OVERRIDE_RELEASE],[$override_release])" fi if [ -n "$additional_version" ]; then echo "define([ADDITIONAL_VERSION],[$additional_version])" fi # Subversion revision information (optional) if [ -n "$change" ]; then echo "define([DISTRIB_SVNREVISION],[${change}])" fi # Use MANIFEST to filter output files echo "define([OUTPUT_FILTER],[MANIFEST])" # Define longest file name (configure will check its presence) longest_file_name=`awk 'BEGIN{max=""}{if (length($0) > length(max)) {max=$0}}END{print max}' < MANIFEST` echo "define([LONGEST_FILE_NAME],[$longest_file_name])" ) > support/distrib.m4 echo support/distrib.m4 >> MANIFEST.distrib echo Generating auto-generated files sh support/reconfig -w polyorb_version=`./configure --version | sed -n 's/^PolyORB configure //p'` echo "Setting version: ${polyorb_version}" for f in README VERSION; do sed_in_place $f "s/@polyorb_version@/${polyorb_version}/g" done ################################################### # Build documentation (optional) ################################################### if $with_doc; then ./configure cd docs make cd .. sed 's#^#docs/#' < docs/MANIFEST >> MANIFEST.distrib fi echo 'Updating MANIFEST' cat MANIFEST.distrib >> MANIFEST utils/sort_MANIFEST echo "Adapting modes" chmod -R og=u-w . polyorb-2.8~20110207.orig/features-240000644000175000017500000000522011750740337016373 0ustar xavierxavier======================================================== PolyORB 2.4 NEW FEATURES LIST Current as of Jun 09, 2008 ======================================================== Copyright (c) 2008, AdaCore This file contains a complete list of new features in version 2.4 of PolyORB. See also file NEWS for various information about this release. An ISO date (YYYY-MM-DD) appears in parentheses after the description line. This date shows the implementation date of the feature. Any 2.4w wavefront subsequent to this date will contain the indicated feature, as will any subsequent releases. NF-24-H311-027 No default MIOP access point address (2008-03-17) The MIOP (Unreliable Multicast Inter-ORB Protocol) access point does not listen on a default group address anymore. Run-time configuration parameters polyorb.miop.multicast_addr and polyorb.miop.multicast_port in section [miop] must now be set explicitly to enable the MIOP access point. NF-24-H226-012 Gnatdist displays executed commands (2008-02-25) When not in quiet mode, gnatdist now prints all commands it executes on standard error, just as gnatmake. NF-24-H214-018 po_gnatdist does not depend on polyorb-config (2008-02-21) The PolyORB/DSA partitioning tool, po_gnatdist, does not depend on the external shell script polyorb-config to locate the PolyORB runtime library anymore. This allows po_gnatdist to be usable on platforms that do not provide a Bourne shell, such as MinGW. NF-24-H110-025 Environment variables passing to slave partitions (2008-02-25) A list of environment variables can now be associated with partitions in gnatdist configuration files. When starting a distributed application using a generated launcher (shell or Ada), these variables are then passed from the main partition's environment to the slave partitions. NF-24-H109-006 Conditional form of pragma Debug (2008-01-28) PolyORB sources now use the conditional (two-argument) form of pragma Debug, so that the debug message strings are constructed only if traces are enabled for the particular module. This significantly reduces the run-time performance cost of enabling pragma Debug. Users can thus decide to leave it enabled even in production systems, for more convenient debugging. As a result of making this the default, the supporting script support/enable-conditional-debug has been removed from the PolyORB distribution. NF-24-H107-031 Hosts with multiple IP addresses (2008-01-11) When an object reference contains a host name corresponding to multiple IP addresses, connection attempts try successive addresses in turn if the connection fails, instead of bailing out after the first attempt. polyorb-2.8~20110207.orig/acinclude.m40000644000175000017500000000241211750740337016600 0ustar xavierxavierdnl Various base M4 macros dnl $Id: acinclude.m4 127146 2008-07-28 11:01:13Z quinot $ dnl Allow various parameters to be overridden by distrib.m4, a file dnl generated when preparing a source distribution package. m4_sinclude([support/distrib.m4]) dnl Usage: pkg_version(release) dnl Expands to the complete version string built from: dnl - the indicated product release; dnl - ADDITIONAL_VERSION dnl ADDITIONAL_VERSION may be defined in distrib.m4. define([pkg_version],[$1[]ifdef([ADDITIONAL_VERSION],ADDITIONAL_VERSION)]) dnl Usage: FILTER_OUTPUT_FILES(list, files) dnl If LIST is the name of a file containing a list of filenames dnl return those members of list FILES whose corresponding templates (XXX.in) dnl are mentioned in LIST. Otherwise return FILES unchanged. dnl AC_DEFUN([FILTER_OUTPUT_FILES], dnl [ifdef($1, dnl [m4_foreach_w(mfile, m4_normalize(defn($1)), [define([$M$]mfile,1)]) dnl m4_foreach_w(file, m4_normalize($2), [ifdef([$M$]file[.in],[file ])])], dnl $2)]) AC_DEFUN([FILTER_OUTPUT_FILES],[esyscmd( [if test -f $1; then mkdir conftest sed -n 's/\.in$//p' < $1 | sort | uniq > conftest/list echo "$2" | tr -d ' \t' | grep -v '^$' | sort | uniq > conftest/files comm -12 conftest/list conftest/files rm -fr conftest else echo "$2" fi])]) polyorb-2.8~20110207.orig/projects-distrib/0000755000175000017500000000000011750740340017671 5ustar xavierxavierpolyorb-2.8~20110207.orig/projects-distrib/README0000755000175000017500000000115111750740337020560 0ustar xavierxavierThe project files in this directory are for building clients of PolyORB. See ../projects for building PolyORB itself. Clients should import polyorb.gpr, which imports others as necessary. These project files end up being installed in the /lib/gnat/polyorb directory, except for polyorb.gpr itself, which is installed in /lib/gnat. For each project file in ../projects that builds a library, there is a project file in this directory with the same name, which has the necessary commands to allow gnatmake to find the corresponding installed .a file. In addition, we have common.gpr and polyorb.gpr. polyorb-2.8~20110207.orig/projects-distrib/polyorb/0000755000175000017500000000000011750740340021357 5ustar xavierxavierpolyorb-2.8~20110207.orig/projects-distrib/polyorb/polyorb_src_dns_mdns.gpr0000644000175000017500000000447211750740337026330 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B _ S R C _ D N S _ M D N S -- -- -- -- P r o j -- -- -- -- Copyright (C) 2007-2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with "polyorb_common", "polyorb_src", "polyorb_src_dns"; project PolyORB_src_dns_mdns is for Source_Files use (); for Library_Name use "polyorb-dns-mdns"; for Library_Dir use "../../polyorb/static"; for Library_Kind use "static"; for Externally_Built use "true"; end PolyORB_src_dns_mdns; polyorb-2.8~20110207.orig/projects-distrib/polyorb/polyorb_src_corba_messaging.gpr0000644000175000017500000000452111750740337027641 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B _ S R C _ C O R B A _ M E S S A G I N G -- -- -- -- P r o j -- -- -- -- Copyright (C) 2007-2009, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with "polyorb_common", "polyorb_src", "polyorb_src_corba"; project PolyORB_src_corba_messaging is for Source_Files use (); for Library_Name use "polyorb-corba-messaging"; for Library_Dir use "../../polyorb/static"; for Library_Kind use "static"; for Externally_Built use "true"; end PolyORB_src_corba_messaging; polyorb-2.8~20110207.orig/projects-distrib/polyorb/polyorb_src_giop_miop.gpr0000644000175000017500000000447611750740337026511 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B _ S R C _ G I O P _ M I O P -- -- -- -- P r o j -- -- -- -- Copyright (C) 2007-2009, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with "polyorb_common", "polyorb_src", "polyorb_src_giop"; project PolyORB_src_giop_miop is for Source_Files use (); for Library_Name use "polyorb-giop-miop"; for Library_Dir use "../../polyorb/static"; for Library_Kind use "static"; for Externally_Built use "true"; end PolyORB_src_giop_miop; polyorb-2.8~20110207.orig/projects-distrib/polyorb/polyorb_cos_ir.gpr0000644000175000017500000000450611750740337025130 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B _ C O S _ I R -- -- -- -- P r o j -- -- -- -- Copyright (C) 2007-2009, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with "polyorb_common", "polyorb_src"; limited with "polyorb_src_corba"; project PolyORB_cos_ir is for Source_Files use (); for Library_Name use "polyorb-corba-cos-ir-impl"; for Library_Dir use "../../polyorb/static"; for Library_Kind use "static"; for Externally_Built use "true"; end PolyORB_cos_ir; polyorb-2.8~20110207.orig/projects-distrib/polyorb/polyorb_idls_cos_naming.gpr0000644000175000017500000000455511750740337027006 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B _ I D L S _ C O S _ N A M I N G -- -- -- -- P r o j -- -- -- -- Copyright (C) 2007-2009, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with "polyorb_common", "polyorb_src"; limited with "polyorb_src_corba", "polyorb_cos_naming"; project PolyORB_idls_cos_naming is for Source_Files use (); for Library_Name use "polyorb-corba-cos-naming"; for Library_Dir use "../../polyorb/static"; for Library_Kind use "static"; for Externally_Built use "true"; end PolyORB_idls_cos_naming; polyorb-2.8~20110207.orig/projects-distrib/polyorb/polyorb_src_corba_iop.gpr0000644000175000017500000000447711750740337026465 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B _ S R C _ C O R B A _ I O P -- -- -- -- P r o j -- -- -- -- Copyright (C) 2007-2009, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with "polyorb_common", "polyorb_src", "polyorb_src_corba"; project PolyORB_src_corba_iop is for Source_Files use (); for Library_Name use "polyorb-corba-iop"; for Library_Dir use "../../polyorb/static"; for Library_Kind use "static"; for Externally_Built use "true"; end PolyORB_src_corba_iop; polyorb-2.8~20110207.orig/projects-distrib/polyorb/polyorb_src_corba_portableinterceptor.gpr0000644000175000017500000000507611750740337031761 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- POLYORB_SRC_CORBA_PORTABLEINTERCEPTOR -- -- -- -- P r o j -- -- -- -- Copyright (C) 2007-2009, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with "polyorb_common", "polyorb_src", "polyorb_src_corba", "polyorb_src_corba_iop", "polyorb_src_corba_messaging", "polyorb_cos_ir"; -- Depends on IR for portableinterceptor/dynamic -- ??? that should be idls_cos_ir, no need for visibility on IR implementation project PolyORB_src_corba_portableinterceptor is for Source_Files use (); for Library_Name use "polyorb-corba-portableinterceptor"; for Library_Dir use "../../polyorb/static"; for Library_Kind use "static"; for Externally_Built use "true"; end PolyORB_src_corba_portableinterceptor; polyorb-2.8~20110207.orig/projects-distrib/polyorb/polyorb_src_setup.gpr.in0000644000175000017500000000512611750740337026265 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B _ S R C _ S E T U P -- -- -- -- P r o j -- -- -- -- Copyright (C) 2007-2009, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- Pre-canned middleware setups -- The units provided by this project provide convenient short-hands to -- drag in an appropriate middleware configuration. They contain only -- WITH clauses for the PolyORB components. with "polyorb_common", "polyorb_src"; @NO_SSL@with "polyorb_src_ssl"; @WITH_PROTO_PRJS@ @WITH_APPLI_PRJS@ @WITH_SERVICE_PRJS@ project PolyORB_src_setup is for Source_Files use (); for Library_Name use "polyorb-setup"; for Library_Dir use "../../polyorb/static"; for Library_Kind use "static"; for Externally_Built use "true"; end PolyORB_src_setup; polyorb-2.8~20110207.orig/projects-distrib/polyorb/polyorb_src_corba_security.gpr0000644000175000017500000000457711750740337027546 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B _ S R C _ C O R B A _ S E C U R I T Y -- -- -- -- P r o j -- -- -- -- Copyright (C) 2007-2009, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with "polyorb_common", "polyorb_src", "polyorb_src_corba", "polyorb_src_corba_iop", "polyorb_src_security"; project PolyORB_src_corba_security is for Source_Files use (); for Library_Name use "polyorb-corba-security"; for Library_Dir use "../../polyorb/static"; for Library_Kind use "static"; for Externally_Built use "true"; end PolyORB_src_corba_security; polyorb-2.8~20110207.orig/projects-distrib/polyorb/polyorb_src_corba.gpr0000644000175000017500000000443611750740337025611 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B _ S R C _ C O R B A -- -- -- -- P r o j -- -- -- -- Copyright (C) 2007-2009, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with "polyorb_common", "polyorb_src"; project PolyORB_src_corba is for Source_Files use (); for Library_Name use "polyorb-corba"; for Library_Dir use "../../polyorb/static"; for Library_Kind use "static"; for Externally_Built use "true"; end PolyORB_src_corba; polyorb-2.8~20110207.orig/projects-distrib/polyorb/polyorb_src_dns.gpr0000644000175000017500000000443011750740337025301 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B _ S R C _ D N S -- -- -- -- P r o j -- -- -- -- Copyright (C) 2007-2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with "polyorb_common", "polyorb_src"; project PolyORB_src_dns is for Source_Files use (); for Library_Name use "polyorb-dns"; for Library_Dir use "../../polyorb/static"; for Library_Kind use "static"; for Externally_Built use "true"; end PolyORB_src_dns; polyorb-2.8~20110207.orig/projects-distrib/polyorb/polyorb_src_giop.gpr0000644000175000017500000000443311750740337025456 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B _ S R C _ G I O P -- -- -- -- P r o j -- -- -- -- Copyright (C) 2007-2009, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with "polyorb_common", "polyorb_src"; project PolyORB_src_giop is for Source_Files use (); for Library_Name use "polyorb-giop"; for Library_Dir use "../../polyorb/static"; for Library_Kind use "static"; for Externally_Built use "true"; end PolyORB_src_giop; polyorb-2.8~20110207.orig/projects-distrib/polyorb/polyorb_src.gpr0000644000175000017500000000437511750740337024445 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B _ S R C -- -- -- -- P r o j -- -- -- -- Copyright (C) 2007-2009, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with "polyorb_common"; project PolyORB_src is for Source_Files use (); for Library_Name use "polyorb"; for Library_Dir use "../../polyorb/static"; for Library_Kind use "static"; for Externally_Built use "true"; end PolyORB_src; polyorb-2.8~20110207.orig/projects-distrib/polyorb/polyorb_src_security_gssup.gpr0000644000175000017500000000452111750740337027606 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B _ S R C _ S E C U R I T Y _ G S S U P -- -- -- -- P r o j -- -- -- -- Copyright (C) 2007-2009, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with "polyorb_common", "polyorb_src", "polyorb_src_security"; project PolyORB_src_security_gssup is for Source_Files use (); for Library_Name use "polyorb-security-gssup"; for Library_Dir use "../../polyorb/static"; for Library_Kind use "static"; for Externally_Built use "true"; end PolyORB_src_security_gssup; polyorb-2.8~20110207.orig/projects-distrib/polyorb/polyorb_src_corba_rtcorba.gpr0000644000175000017500000000454411750740337027325 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B _ S R C _ C O R B A _ R T C O R B A -- -- -- -- P r o j -- -- -- -- Copyright (C) 2007-2009, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with "polyorb_common", "polyorb_src", "polyorb_src_corba", "polyorb_src_corba_iop"; project PolyORB_src_corba_rtcorba is for Source_Files use (); for Library_Name use "polyorb-corba-rtcorba"; for Library_Dir use "../../polyorb/static"; for Library_Kind use "static"; for Externally_Built use "true"; end PolyORB_src_corba_rtcorba; polyorb-2.8~20110207.orig/projects-distrib/polyorb/polyorb_src_giop_diop.gpr0000644000175000017500000000447611750740337026500 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B _ S R C _ G I O P _ D I O P -- -- -- -- P r o j -- -- -- -- Copyright (C) 2007-2009, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with "polyorb_common", "polyorb_src", "polyorb_src_giop"; project PolyORB_src_giop_diop is for Source_Files use (); for Library_Name use "polyorb-giop-diop"; for Library_Dir use "../../polyorb/static"; for Library_Kind use "static"; for Externally_Built use "true"; end PolyORB_src_giop_diop; polyorb-2.8~20110207.orig/projects-distrib/polyorb/polyorb_src_corba_dynamicany.gpr0000644000175000017500000000452411750740337030023 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B _ S R C _ C O R B A _ D Y N A M I C A N Y -- -- -- -- P r o j -- -- -- -- Copyright (C) 2007-2009, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with "polyorb_common", "polyorb_src", "polyorb_src_corba"; project PolyORB_src_corba_dynamicany is for Source_Files use (); for Library_Name use "polyorb-corba-dynamicany"; for Library_Dir use "../../polyorb/static"; for Library_Kind use "static"; for Externally_Built use "true"; end PolyORB_src_corba_dynamicany; polyorb-2.8~20110207.orig/projects-distrib/polyorb/polyorb_cos_naming.gpr0000644000175000017500000000455511750740337025773 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B _ C O S _ N A M I N G -- -- -- -- P r o j -- -- -- -- Copyright (C) 2007-2009, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with "polyorb_common", "polyorb_src"; limited with "polyorb_src_corba", "polyorb_idls_cos_naming"; project PolyORB_cos_naming is for Source_Files use (); for Library_Name use "polyorb-corba-cos-naming-impl"; for Library_Dir use "../../polyorb/static"; for Library_Kind use "static"; for Externally_Built use "true"; end PolyORB_cos_naming; polyorb-2.8~20110207.orig/projects-distrib/polyorb/polyorb_cos_event.gpr0000644000175000017500000000455111750740337025637 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B _ C O S _ E V E N T -- -- -- -- P r o j -- -- -- -- Copyright (C) 2007-2009, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with "polyorb_common", "polyorb_src", "polyorb_idls_cos_event"; limited with "polyorb_src_corba"; project PolyORB_cos_event is for Source_Files use (); for Library_Name use "polyorb-corba-cos-event-impl"; for Library_Dir use "../../polyorb/static"; for Library_Kind use "static"; for Externally_Built use "true"; end PolyORB_cos_event; polyorb-2.8~20110207.orig/projects-distrib/polyorb/polyorb_src_srp.gpr0000644000175000017500000000443011750740337025321 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B _ S R C _ S R P -- -- -- -- P r o j -- -- -- -- Copyright (C) 2007-2009, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with "polyorb_common", "polyorb_src"; project PolyORB_src_srp is for Source_Files use (); for Library_Name use "polyorb-srp"; for Library_Dir use "../../polyorb/static"; for Library_Kind use "static"; for Externally_Built use "true"; end PolyORB_src_srp; polyorb-2.8~20110207.orig/projects-distrib/polyorb/polyorb_cos_notification.gpr0000644000175000017500000000460511750740337027204 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B _ C O S _ N O T I F I C A T I O N -- -- -- -- P r o j -- -- -- -- Copyright (C) 2007-2009, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with "polyorb_common", "polyorb_src", "polyorb_idls_cos_notification"; limited with "polyorb_src_corba"; project PolyORB_cos_notification is for Source_Files use (); for Library_Name use "polyorb-corba-cos-notification-impl"; for Library_Dir use "../../polyorb/static"; for Library_Kind use "static"; for Externally_Built use "true"; end PolyORB_cos_notification; polyorb-2.8~20110207.orig/projects-distrib/polyorb/polyorb_src_security_tls.gpr0000644000175000017500000000455011750740337027251 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B _ S R C _ S E C U R I T Y _ T L S -- -- -- -- P r o j -- -- -- -- Copyright (C) 2007-2009, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with "polyorb_common", "polyorb_src", "polyorb_src_security", "polyorb_src_security_x509"; project PolyORB_src_security_tls is for Source_Files use (); for Library_Name use "polyorb-security-tls"; for Library_Dir use "../../polyorb/static"; for Library_Kind use "static"; for Externally_Built use "true"; end PolyORB_src_security_tls; polyorb-2.8~20110207.orig/projects-distrib/polyorb/polyorb_src_dns_udns.gpr0000644000175000017500000000447211750740337026340 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B _ S R C _ D N S _ U D N S -- -- -- -- P r o j -- -- -- -- Copyright (C) 2007-2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with "polyorb_common", "polyorb_src", "polyorb_src_dns"; project PolyORB_src_dns_udns is for Source_Files use (); for Library_Name use "polyorb-dns-udns"; for Library_Dir use "../../polyorb/static"; for Library_Kind use "static"; for Externally_Built use "true"; end PolyORB_src_dns_udns; polyorb-2.8~20110207.orig/projects-distrib/polyorb/polyorb_src_ssl.gpr0000644000175000017500000000443011750740337025316 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B _ S R C _ S S L -- -- -- -- P r o j -- -- -- -- Copyright (C) 2007-2009, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with "polyorb_common", "polyorb_src"; project PolyORB_src_ssl is for Source_Files use (); for Library_Name use "polyorb-ssl"; for Library_Dir use "../../polyorb/static"; for Library_Kind use "static"; for Externally_Built use "true"; end PolyORB_src_ssl; polyorb-2.8~20110207.orig/projects-distrib/polyorb/polyorb_src_moma.gpr0000644000175000017500000000443311750740337025451 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B _ S R C _ M O M A -- -- -- -- P r o j -- -- -- -- Copyright (C) 2007-2009, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with "polyorb_common", "polyorb_src"; project PolyORB_src_moma is for Source_Files use (); for Library_Name use "polyorb-moma"; for Library_Dir use "../../polyorb/static"; for Library_Kind use "static"; for Externally_Built use "true"; end PolyORB_src_moma; polyorb-2.8~20110207.orig/projects-distrib/polyorb/polyorb_common.gpr0000644000175000017500000000422611750740337025141 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B _ C O M M O N -- -- -- -- P r o j -- -- -- -- Copyright (C) 2007-2009, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ project PolyORB_Common is -- This project is imported by all the polyorb project files. for Source_Files use (); end PolyORB_Common; polyorb-2.8~20110207.orig/projects-distrib/polyorb/polyorb_src_setup_security.gpr0000644000175000017500000000513311750740337027605 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B _ S R C _ S E T U P _ S E C U R I T Y -- -- -- -- P r o j -- -- -- -- Copyright (C) 2007-2009, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- Pre-canned setups for security subsystem -- See src_setup for purpose and usage rules with "polyorb_common", "polyorb_src", "polyorb_src_corba", "polyorb_src_giop", "polyorb_src_security", "polyorb_src_security_gssup", "polyorb_src_corba_security", "polyorb_src_giop_iiop_security", "polyorb_src_giop_iiop_security_tls"; project PolyORB_src_setup_security is for Source_Files use (); for Library_Name use "polyorb-setup-security"; for Library_Dir use "../../polyorb/static"; for Library_Kind use "static"; for Externally_Built use "true"; end PolyORB_src_setup_security; polyorb-2.8~20110207.orig/projects-distrib/polyorb/polyorb_src_web_common.gpr0000644000175000017500000000445511750740337026651 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B _ S R C _ W E B _ C O M M O N -- -- -- -- P r o j -- -- -- -- Copyright (C) 2007-2009, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with "polyorb_common", "polyorb_src"; project PolyORB_src_web_common is for Source_Files use (); for Library_Name use "polyorb-web_common"; for Library_Dir use "../../polyorb/static"; for Library_Kind use "static"; for Externally_Built use "true"; end PolyORB_src_web_common; polyorb-2.8~20110207.orig/projects-distrib/polyorb/polyorb_src_giop_iiop_security.gpr0000644000175000017500000000461211750740337030424 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B _ S R C _ G I O P _ I I O P _ S E C U R I T Y -- -- -- -- P r o j -- -- -- -- Copyright (C) 2007-2009, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with "polyorb_common", "polyorb_src", "polyorb_src_giop", "polyorb_src_giop_iiop", "polyorb_src_security"; project PolyORB_src_giop_iiop_security is for Source_Files use (); for Library_Name use "polyorb-giop-iiop-security"; for Library_Dir use "../../polyorb/static"; for Library_Kind use "static"; for Externally_Built use "true"; end PolyORB_src_giop_iiop_security; polyorb-2.8~20110207.orig/projects-distrib/polyorb/polyorb_idls_cos_notification.gpr0000644000175000017500000000457611750740337030226 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B _ I D L S _ C O S _ N O T I F I C A T I O N -- -- -- -- P r o j -- -- -- -- Copyright (C) 2007-2009, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with "polyorb_common", "polyorb_src", "polyorb_cos_event"; limited with "polyorb_src_corba"; project PolyORB_idls_cos_notification is for Source_Files use (); for Library_Name use "polyorb-corba-cos-notification"; for Library_Dir use "../../polyorb/static"; for Library_Kind use "static"; for Externally_Built use "true"; end PolyORB_idls_cos_notification; polyorb-2.8~20110207.orig/projects-distrib/polyorb/polyorb_idls_cos_event.gpr0000644000175000017500000000452411750740337026652 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B _ I D L S _ C O S _ E V E N T -- -- -- -- P r o j -- -- -- -- Copyright (C) 2007-2009, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with "polyorb_common", "polyorb_src"; limited with "polyorb_src_corba"; project PolyORB_idls_cos_event is for Source_Files use (); for Library_Name use "polyorb-corba-cos-event"; for Library_Dir use "../../polyorb/static"; for Library_Kind use "static"; for Externally_Built use "true"; end PolyORB_idls_cos_event; polyorb-2.8~20110207.orig/projects-distrib/polyorb/polyorb_src_security_x509.gpr0000644000175000017500000000451611750740337027156 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B _ S R C _ S E C U R I T Y _ X 5 0 9 -- -- -- -- P r o j -- -- -- -- Copyright (C) 2007-2009, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with "polyorb_common", "polyorb_src", "polyorb_src_security"; project PolyORB_src_security_x509 is for Source_Files use (); for Library_Name use "polyorb-security-x509"; for Library_Dir use "../../polyorb/static"; for Library_Kind use "static"; for Externally_Built use "true"; end PolyORB_src_security_x509; polyorb-2.8~20110207.orig/projects-distrib/polyorb/polyorb_src_security.gpr0000644000175000017500000000444711750740337026374 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B _ S R C _ S E C U R I T Y -- -- -- -- P r o j -- -- -- -- Copyright (C) 2007-2009, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with "polyorb_common", "polyorb_src"; project PolyORB_src_security is for Source_Files use (); for Library_Name use "polyorb-security"; for Library_Dir use "../../polyorb/static"; for Library_Kind use "static"; for Externally_Built use "true"; end PolyORB_src_security; polyorb-2.8~20110207.orig/projects-distrib/polyorb/polyorb_src_giop_iiop_ssliop.gpr0000644000175000017500000000457711750740337030100 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B _ S R C _ G I O P _ I I O P _ S S L I O P -- -- -- -- P r o j -- -- -- -- Copyright (C) 2007-2009, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with "polyorb_common", "polyorb_src", "polyorb_src_giop", "polyorb_src_giop_iiop", "polyorb_src_ssl"; project PolyORB_src_giop_iiop_ssliop is for Source_Files use (); for Library_Name use "polyorb-giop-iiop-ssliop"; for Library_Dir use "../../polyorb/static"; for Library_Kind use "static"; for Externally_Built use "true"; end PolyORB_src_giop_iiop_ssliop; polyorb-2.8~20110207.orig/projects-distrib/polyorb/polyorb_src_corba_security_gssup.gpr0000644000175000017500000000462611750740337030762 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B _ S R C _ C O R B A _ S E C U R I T Y _ G S S U P -- -- -- -- P r o j -- -- -- -- Copyright (C) 2007-2009, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with "polyorb_common", "polyorb_src", "polyorb_src_corba", "polyorb_src_corba_security", "polyorb_src_security"; project PolyORB_src_corba_security_gssup is for Source_Files use (); for Library_Name use "polyorb-corba-security-gssup"; for Library_Dir use "../../polyorb/static"; for Library_Kind use "static"; for Externally_Built use "true"; end PolyORB_src_corba_security_gssup; polyorb-2.8~20110207.orig/projects-distrib/polyorb/polyorb_src_soap.gpr0000644000175000017500000000464211750740337025464 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B _ S R C _ S O A P -- -- -- -- P r o j -- -- -- -- Copyright (C) 2007-2009, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with "polyorb_common", "polyorb_src", "polyorb_src_web_common", "xmlada"; -- Note that the ADA_PROJECT_PATH environment variable must be set so we can -- find xmlada.gpr. project PolyORB_src_soap is for Source_Files use (); for Library_Name use "polyorb-soap"; for Library_Dir use "../../polyorb/static"; for Library_Kind use "static"; for Externally_Built use "true"; end PolyORB_src_soap; polyorb-2.8~20110207.orig/projects-distrib/polyorb/polyorb_src_giop_iiop_security_tls.gpr0000644000175000017500000000476111750740337031313 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B _ S R C _ G I O P _ I I O P _ S E C U R I T Y _ T L S -- -- -- -- P r o j -- -- -- -- Copyright (C) 2007-2009, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with "polyorb_common", "polyorb_src", "polyorb_src_giop", "polyorb_src_giop_iiop", "polyorb_src_giop_iiop_security", "polyorb_src_security", "polyorb_src_security_tls", "polyorb_src_security_x509"; project PolyORB_src_giop_iiop_security_tls is for Source_Files use (); for Library_Name use "polyorb-giop-iiop-security-tls"; for Library_Dir use "../../polyorb/static"; for Library_Kind use "static"; for Externally_Built use "true"; end PolyORB_src_giop_iiop_security_tls; polyorb-2.8~20110207.orig/projects-distrib/polyorb/polyorb_idls_cos_time.gpr0000644000175000017500000000452111750740337026464 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B _ I D L S _ C O S _ T I M E -- -- -- -- P r o j -- -- -- -- Copyright (C) 2007-2009, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with "polyorb_common", "polyorb_src"; limited with "polyorb_src_corba"; project PolyORB_idls_cos_time is for Source_Files use (); for Library_Name use "polyorb-corba-cos-time"; for Library_Dir use "../../polyorb/static"; for Library_Kind use "static"; for Externally_Built use "true"; end PolyORB_idls_cos_time; polyorb-2.8~20110207.orig/projects-distrib/polyorb/polyorb_cos_time.gpr0000644000175000017500000000454511750740337025457 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B _ C O S _ T I M E -- -- -- -- P r o j -- -- -- -- Copyright (C) 2007-2009, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with "polyorb_common", "polyorb_src", "polyorb_idls_cos_time"; limited with "polyorb_src_corba"; project PolyORB_cos_time is for Source_Files use (); for Library_Name use "polyorb-corba-cos-time-impl"; for Library_Dir use "../../polyorb/static"; for Library_Kind use "static"; for Externally_Built use "true"; end PolyORB_cos_time; polyorb-2.8~20110207.orig/projects-distrib/polyorb/polyorb_src_giop_iiop.gpr0000644000175000017500000000447611750740337026505 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B _ S R C _ G I O P _ I I O P -- -- -- -- P r o j -- -- -- -- Copyright (C) 2007-2009, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with "polyorb_common", "polyorb_src", "polyorb_src_giop"; project PolyORB_src_giop_iiop is for Source_Files use (); for Library_Name use "polyorb-giop-iiop"; for Library_Dir use "../../polyorb/static"; for Library_Kind use "static"; for Externally_Built use "true"; end PolyORB_src_giop_iiop; polyorb-2.8~20110207.orig/projects-distrib/polyorb/polyorb_src_dsa.gpr0000644000175000017500000000443011750740337025264 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B _ S R C _ D S A -- -- -- -- P r o j -- -- -- -- Copyright (C) 2007-2009, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with "polyorb_common", "polyorb_src"; project PolyORB_src_dsa is for Source_Files use (); for Library_Name use "polyorb-dsa"; for Library_Dir use "../../polyorb/static"; for Library_Kind use "static"; for Externally_Built use "true"; end PolyORB_src_dsa; polyorb-2.8~20110207.orig/projects-distrib/polyorb.gpr.in0000755000175000017500000000513511750740337022513 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O L Y O R B -- -- -- -- P r o j -- -- -- -- Copyright (C) 2007-2009, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- This is the main project file for clients of PolyORB. A client project -- file should say: -- with "polyorb"; -- and the ADA_PROJECT_PATH environment variable should be set to point to the -- directory containing this file. If SOAP is included, ADA_PROJECT_PATH must -- also be set so we can find xmlada.gpr. with "polyorb/polyorb_common", "polyorb/polyorb_src_setup"; @NO_SSL@with "polyorb/polyorb_src_setup_security"; project PolyORB is for Source_Dirs use ("../../include/polyorb"); for Object_Dir use "../../lib/polyorb"; for Externally_Built use "true"; end PolyORB; polyorb-2.8~20110207.orig/COPYING0000644000175000017500000004312711750740337015452 0ustar xavierxavier GNU GENERAL PUBLIC LICENSE Version 2, June 1991 Copyright (C) 1989, 1991 Free Software Foundation, Inc. 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA Everyone is permitted to copy and distribute verbatim copies of this license document, but changing it is not allowed. Preamble The licenses for most software are designed to take away your freedom to share and change it. By contrast, the GNU General Public License is intended to guarantee your freedom to share and change free software--to make sure the software is free for all its users. This General Public License applies to most of the Free Software Foundation's software and to any other program whose authors commit to using it. (Some other Free Software Foundation software is covered by the GNU Library General Public License instead.) You can apply it to your programs, too. When we speak of free software, we are referring to freedom, not price. Our General Public Licenses are designed to make sure that you have the freedom to distribute copies of free software (and charge for this service if you wish), that you receive source code or can get it if you want it, that you can change the software or use pieces of it in new free programs; and that you know you can do these things. To protect your rights, we need to make restrictions that forbid anyone to deny you these rights or to ask you to surrender the rights. These restrictions translate to certain responsibilities for you if you distribute copies of the software, or if you modify it. For example, if you distribute copies of such a program, whether gratis or for a fee, you must give the recipients all the rights that you have. You must make sure that they, too, receive or can get the source code. And you must show them these terms so they know their rights. We protect your rights with two steps: (1) copyright the software, and (2) offer you this license which gives you legal permission to copy, distribute and/or modify the software. Also, for each author's protection and ours, we want to make certain that everyone understands that there is no warranty for this free software. If the software is modified by someone else and passed on, we want its recipients to know that what they have is not the original, so that any problems introduced by others will not reflect on the original authors' reputations. Finally, any free program is threatened constantly by software patents. We wish to avoid the danger that redistributors of a free program will individually obtain patent licenses, in effect making the program proprietary. To prevent this, we have made it clear that any patent must be licensed for everyone's free use or not licensed at all. The precise terms and conditions for copying, distribution and modification follow. GNU GENERAL PUBLIC LICENSE TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION 0. This License applies to any program or other work which contains a notice placed by the copyright holder saying it may be distributed under the terms of this General Public License. The "Program", below, refers to any such program or work, and a "work based on the Program" means either the Program or any derivative work under copyright law: that is to say, a work containing the Program or a portion of it, either verbatim or with modifications and/or translated into another language. (Hereinafter, translation is included without limitation in the term "modification".) Each licensee is addressed as "you". Activities other than copying, distribution and modification are not covered by this License; they are outside its scope. The act of running the Program is not restricted, and the output from the Program is covered only if its contents constitute a work based on the Program (independent of having been made by running the Program). Whether that is true depends on what the Program does. 1. You may copy and distribute verbatim copies of the Program's source code as you receive it, in any medium, provided that you conspicuously and appropriately publish on each copy an appropriate copyright notice and disclaimer of warranty; keep intact all the notices that refer to this License and to the absence of any warranty; and give any other recipients of the Program a copy of this License along with the Program. You may charge a fee for the physical act of transferring a copy, and you may at your option offer warranty protection in exchange for a fee. 2. You may modify your copy or copies of the Program or any portion of it, thus forming a work based on the Program, and copy and distribute such modifications or work under the terms of Section 1 above, provided that you also meet all of these conditions: a) You must cause the modified files to carry prominent notices stating that you changed the files and the date of any change. b) You must cause any work that you distribute or publish, that in whole or in part contains or is derived from the Program or any part thereof, to be licensed as a whole at no charge to all third parties under the terms of this License. c) If the modified program normally reads commands interactively when run, you must cause it, when started running for such interactive use in the most ordinary way, to print or display an announcement including an appropriate copyright notice and a notice that there is no warranty (or else, saying that you provide a warranty) and that users may redistribute the program under these conditions, and telling the user how to view a copy of this License. (Exception: if the Program itself is interactive but does not normally print such an announcement, your work based on the Program is not required to print an announcement.) These requirements apply to the modified work as a whole. If identifiable sections of that work are not derived from the Program, and can be reasonably considered independent and separate works in themselves, then this License, and its terms, do not apply to those sections when you distribute them as separate works. But when you distribute the same sections as part of a whole which is a work based on the Program, the distribution of the whole must be on the terms of this License, whose permissions for other licensees extend to the entire whole, and thus to each and every part regardless of who wrote it. Thus, it is not the intent of this section to claim rights or contest your rights to work written entirely by you; rather, the intent is to exercise the right to control the distribution of derivative or collective works based on the Program. In addition, mere aggregation of another work not based on the Program with the Program (or with a work based on the Program) on a volume of a storage or distribution medium does not bring the other work under the scope of this License. 3. You may copy and distribute the Program (or a work based on it, under Section 2) in object code or executable form under the terms of Sections 1 and 2 above provided that you also do one of the following: a) Accompany it with the complete corresponding machine-readable source code, which must be distributed under the terms of Sections 1 and 2 above on a medium customarily used for software interchange; or, b) Accompany it with a written offer, valid for at least three years, to give any third party, for a charge no more than your cost of physically performing source distribution, a complete machine-readable copy of the corresponding source code, to be distributed under the terms of Sections 1 and 2 above on a medium customarily used for software interchange; or, c) Accompany it with the information you received as to the offer to distribute corresponding source code. (This alternative is allowed only for noncommercial distribution and only if you received the program in object code or executable form with such an offer, in accord with Subsection b above.) The source code for a work means the preferred form of the work for making modifications to it. For an executable work, complete source code means all the source code for all modules it contains, plus any associated interface definition files, plus the scripts used to control compilation and installation of the executable. However, as a special exception, the source code distributed need not include anything that is normally distributed (in either source or binary form) with the major components (compiler, kernel, and so on) of the operating system on which the executable runs, unless that component itself accompanies the executable. If distribution of executable or object code is made by offering access to copy from a designated place, then offering equivalent access to copy the source code from the same place counts as distribution of the source code, even though third parties are not compelled to copy the source along with the object code. 4. You may not copy, modify, sublicense, or distribute the Program except as expressly provided under this License. Any attempt otherwise to copy, modify, sublicense or distribute the Program is void, and will automatically terminate your rights under this License. However, parties who have received copies, or rights, from you under this License will not have their licenses terminated so long as such parties remain in full compliance. 5. You are not required to accept this License, since you have not signed it. However, nothing else grants you permission to modify or distribute the Program or its derivative works. These actions are prohibited by law if you do not accept this License. Therefore, by modifying or distributing the Program (or any work based on the Program), you indicate your acceptance of this License to do so, and all its terms and conditions for copying, distributing or modifying the Program or works based on it. 6. Each time you redistribute the Program (or any work based on the Program), the recipient automatically receives a license from the original licensor to copy, distribute or modify the Program subject to these terms and conditions. You may not impose any further restrictions on the recipients' exercise of the rights granted herein. You are not responsible for enforcing compliance by third parties to this License. 7. If, as a consequence of a court judgment or allegation of patent infringement or for any other reason (not limited to patent issues), conditions are imposed on you (whether by court order, agreement or otherwise) that contradict the conditions of this License, they do not excuse you from the conditions of this License. If you cannot distribute so as to satisfy simultaneously your obligations under this License and any other pertinent obligations, then as a consequence you may not distribute the Program at all. For example, if a patent license would not permit royalty-free redistribution of the Program by all those who receive copies directly or indirectly through you, then the only way you could satisfy both it and this License would be to refrain entirely from distribution of the Program. If any portion of this section is held invalid or unenforceable under any particular circumstance, the balance of the section is intended to apply and the section as a whole is intended to apply in other circumstances. It is not the purpose of this section to induce you to infringe any patents or other property right claims or to contest validity of any such claims; this section has the sole purpose of protecting the integrity of the free software distribution system, which is implemented by public license practices. Many people have made generous contributions to the wide range of software distributed through that system in reliance on consistent application of that system; it is up to the author/donor to decide if he or she is willing to distribute software through any other system and a licensee cannot impose that choice. This section is intended to make thoroughly clear what is believed to be a consequence of the rest of this License. 8. If the distribution and/or use of the Program is restricted in certain countries either by patents or by copyrighted interfaces, the original copyright holder who places the Program under this License may add an explicit geographical distribution limitation excluding those countries, so that distribution is permitted only in or among countries not thus excluded. In such case, this License incorporates the limitation as if written in the body of this License. 9. The Free Software Foundation may publish revised and/or new versions of the General Public License from time to time. Such new versions will be similar in spirit to the present version, but may differ in detail to address new problems or concerns. Each version is given a distinguishing version number. If the Program specifies a version number of this License which applies to it and "any later version", you have the option of following the terms and conditions either of that version or of any later version published by the Free Software Foundation. If the Program does not specify a version number of this License, you may choose any version ever published by the Free Software Foundation. 10. If you wish to incorporate parts of the Program into other free programs whose distribution conditions are different, write to the author to ask for permission. For software which is copyrighted by the Free Software Foundation, write to the Free Software Foundation; we sometimes make exceptions for this. Our decision will be guided by the two goals of preserving the free status of all derivatives of our free software and of promoting the sharing and reuse of software generally. NO WARRANTY 11. BECAUSE THE PROGRAM IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY FOR THE PROGRAM, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE PROGRAM IS WITH YOU. SHOULD THE PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING, REPAIR OR CORRECTION. 12. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR REDISTRIBUTE THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER PROGRAMS), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGES. END OF TERMS AND CONDITIONS How to Apply These Terms to Your New Programs If you develop a new program, and you want it to be of the greatest possible use to the public, the best way to achieve this is to make it free software which everyone can redistribute and change under these terms. To do so, attach the following notices to the program. It is safest to attach them to the start of each source file to most effectively convey the exclusion of warranty; and each file should have at least the "copyright" line and a pointer to where the full notice is found. Copyright (C) 19yy This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program; if not, write to the Free Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA Also add information on how to contact you by electronic and paper mail. If the program is interactive, make it output a short notice like this when it starts in an interactive mode: Gnomovision version 69, Copyright (C) 19yy name of author Gnomovision comes with ABSOLUTELY NO WARRANTY; for details type `show w'. This is free software, and you are welcome to redistribute it under certain conditions; type `show c' for details. The hypothetical commands `show w' and `show c' should show the appropriate parts of the General Public License. Of course, the commands you use may be called something other than `show w' and `show c'; they could even be mouse-clicks or menu items--whatever suits your program. You should also get your employer (if you work as a programmer) or your school, if any, to sign a "copyright disclaimer" for the program, if necessary. Here is a sample; alter the names: Yoyodyne, Inc., hereby disclaims all copyright interest in the program `Gnomovision' (which makes passes at compilers) written by James Hacker. , 1 April 1989 Ty Coon, President of Vice This General Public License does not permit incorporating your program into proprietary programs. If your program is a subroutine library, you may consider it more useful to permit linking proprietary applications with the library. If this is what you want to do, use the GNU Library General Public License instead of this License. polyorb-2.8~20110207.orig/compilers/0000755000175000017500000000000011750740340016377 5ustar xavierxavierpolyorb-2.8~20110207.orig/compilers/idlac/0000755000175000017500000000000011750740340017453 5ustar xavierxavierpolyorb-2.8~20110207.orig/compilers/idlac/idl_fe-debug.adb0000644000175000017500000000655711750740337022454 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- I D L _ F E . D E B U G -- -- -- -- B o d y -- -- -- -- Copyright (C) 2001-2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with Ada.Text_IO; use Ada.Text_IO; package body Idl_Fe.Debug is Filename : constant String := "idl_fe.opt"; type String_Ptr is access String; Flag_Table : array (1 .. 32) of String_Ptr; Last_Flag : Natural := 0; --------------- -- Is_Active -- --------------- function Is_Active (Flag : String) return Natural is begin for I in 1 .. Last_Flag loop if Flag_Table (I).all = Flag then return I; end if; end loop; return 0; end Is_Active; ------------ -- Output -- ------------ procedure Output (Message : String) is begin if Flag /= 0 then Put_Line (Current_Error, Flag_Table (Flag).all & ": " & Message); end if; end Output; File : File_Type; Line : String (1 .. 256); Last : Natural; begin begin Open (File, In_File, Filename); while not End_Of_File (File) loop Get_Line (File, Line, Last); if Last /= 0 then if Line (1) /= '#' then if Is_Active (Line (1 .. Last)) = 0 then Last_Flag := Last_Flag + 1; Flag_Table (Last_Flag) := new String'(Line (1 .. Last)); end if; end if; end if; end loop; Close (File); exception when others => null; end; end Idl_Fe.Debug; polyorb-2.8~20110207.orig/compilers/idlac/ada_be-idl2ada-impl.ads0000644000175000017500000000473111750740337023607 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- A D A _ B E . I D L 2 A D A . I M P L -- -- -- -- S p e c -- -- -- -- Copyright (C) 2001-2002 Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by ACT Europe. -- -- (email: sales@act-europe.fr) -- -- -- ------------------------------------------------------------------------------ private package Ada_Be.Idl2Ada.Impl is Suffix : constant String := ".Impl"; procedure Gen_Node_Spec (CU : in out Compilation_Unit; Node : Node_Id; Is_Delegate : Boolean := False); procedure Gen_Node_Body (CU : in out Compilation_Unit; Node : Node_Id); -- Generate an implementation template. If Is_Delegate is True, the -- generated spec is a delegate's generic formal parameter. end Ada_Be.Idl2Ada.Impl; polyorb-2.8~20110207.orig/compilers/idlac/idl_fe-tree-synthetic.ads0000644000175000017500000001530011750740337024340 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- I D L _ F E . T R E E . S Y N T H E T I C -- -- -- -- S p e c -- -- -- -- Copyright (C) 2001-2008, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- Synthetised attributes of the IDL tree nodes. package Idl_Fe.Tree.Synthetic is --------------------------------------- -- Synthetic attributes of IDL nodes -- --------------------------------------- function S_Type (Node : Node_Id) return Node_Id; -- If Node is a Scoped_Name whose Value declares a type, then S_Type -- returns that type, else S_Type is No_Node. function Default_Repository_Id (Node : Node_Id) return String; -- The string of "/"-separated identifiers that makes up the default -- repository id for Node. -- Must be called only by the parser, before the tree is expanded. function Is_Interface_Type (Node : Node_Id; Or_ValueType : Boolean := False) return Boolean; -- True iff Node is a that denotes an object reference type -- If Or_ValueType is True, also return true for valuetype reference types. function Is_Gen_Scope (Node : Node_Id) return Boolean; -- True iff Node is a generable Scope (ie K_Repository, K_Ben_Idl_File, -- K_Module, K_Interface or K_ValueType). function Name (Node : Node_Id) return String; -- The name of a K_Named node function Original_Operation_Type (Node : Node_Id) return Node_Id; -- The type that was initially declared for an operation. -- The type of a non-void operation that has inout or out arguments is -- changed to void by the expander; this returns the original, non-void -- type. function Original_Parent_Scope (Node : Node_Id) return Node_Id; -- The scope wherein a K_Named node was initially declared. This property -- never changes once it is set by the parser. -- -- If Node is a Forward_Interface or Forward_ValueType that has a -- corresponding actual declaration, then the Name and -- Original_Parent_Scope returned are those of the actual declaration. function Parent_Scope (Node : Node_Id) return Node_Id; -- The scope wherein a K_Named node was declared. This property may be set -- explicitly by the expander using Set_Parent_Scope. Otherwise, it is -- equal to the Original_Parent_Scope of the node. procedure Set_Parent_Scope (Node : Node_Id; To : Node_Id); -- Explicitly change the parent scope of Node to To. -- Intended for use only by the expander. function Idl_Repository_Id (Node : Node_Id) return String; -- Return a Repository ID in OMG IDL format for K_Named Node -- (as defined in "10.6 RepositoryIds"). function Version (Node : Node_Id) return String; -- Return the version part of Node's repository id. function All_Ancestors (Node : Node_Id; Exclude : Node_List := Nil_List) return Node_List; -- Return the list of all ancestors (direct or indirect) of K_Interface -- Node. -- If Exclude is not Nil_List, all nodes in Exclude are ignored during the -- exploration. It is up to the caller to Free the returned Node_List -- after use. function Primary_Parent (Node : Node_Id) return Node_Id; -- Return the first non abstract parent interface for an interface node, -- and the first non abstract parent valuetype for a valuetype node. -- Returns No_Node if such a parent does not exist function Supports_Non_Abstract_Interface (Node : Node_Id) return Boolean; -- For a valuetype, returns true if it supports at least one -- non-abstract interface function Has_Interface_Component (Node : Node_Id; I_Node : Node_Id) return Boolean; -- For a node that is a type, True if the type is I_Node, a typedef -- thereof, or a composite type that has one such component. function Has_Local_Component (Node : Node_Id) return Boolean; -- For a node that is a type, True if the type is a local interface, a -- forward declaration of a local interface, or a composite or constructed -- type that has one such component, or that has a component for which -- Has_Local_Component is True. function Integer_Value (Node : Node_Id) return Idl_Integer; function Character_Value (Node : Node_Id) return Character; function Float_Value (Node : Node_Id) return Idl_Float; function String_Value (Node : Node_Id) return String; function WString_Value (Node : Node_Id) return Wide_String; function Boolean_Value (Node : Node_Id) return Boolean; function Enum_Value (Node : Node_Id) return Node_Id; -- Return the value of a constant expression node as an -- {integer,char,string,boolean,enumerator}. procedure Set_String_Value (Node : Node_Id; Val : String); -- Set the value of a string node function Root_Type (Typ : Node_Id) return Node_Id; -- Return the ultimate type derivation ancestor of Typ (unwinding all -- typedefs and type references). end Idl_Fe.Tree.Synthetic; polyorb-2.8~20110207.orig/compilers/idlac/ada_be-source_streams.adb0000644000175000017500000005364611750740337024376 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- A D A _ B E . S O U R C E _ S T R E A M S -- -- -- -- B o d y -- -- -- -- Copyright (C) 2001-2008, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with Ada.Characters.Handling; use Ada.Characters.Handling; with Ada.Characters.Latin_1; use Ada.Characters.Latin_1; with GNAT.OS_Lib; with GNAT.Directory_Operations; with Ada_Be.Debug; pragma Elaborate_All (Ada_Be.Debug); with Output; with Platform; with Utils; package body Ada_Be.Source_Streams is Flag : constant Natural := Ada_Be.Debug.Is_Active ("ada_be.source_streams"); procedure O is new Ada_Be.Debug.Output (Flag); -- User-defined diversion identifiers are allocated on a system-wide basis. Diversions_Allocation : array (Diversion) of Boolean := (Predefined_Diversions'Range => True, others => False); -- Semantic dependencies type Dependency_Node is record Library_Unit : String_Ptr; Use_It : Boolean; Elab_Control : Elab_Control_Pragma := None; No_Warnings : Boolean; Next : Dependency; end record; Output_Directory : Unbounded_String; ----------------------- -- Local subprograms -- ----------------------- function Is_Empty (Unit : Compilation_Unit) return Boolean; -- True if, and only if, all of Unit's diversions are empty function Is_Ancestor (U1 : String; U2 : String) return Boolean; -- True if library unit U1 is an ancestor of U2. function Find_Dep (Unit : String; Context_Clauses : Dependency) return Dependency; -- Retrieve the node for Unit in the given context clauses list (null if -- not found). ----------------- -- Is_Ancestor -- ----------------- function Is_Ancestor (U1 : String; U2 : String) return Boolean is LU1 : constant String := To_Lower (U1) & "."; LU2 : constant String := To_Lower (U2); begin return True and then LU1'Length <= LU2'Length and then LU1 = LU2 (LU2'First .. LU2'First + LU1'Length - 1); end Is_Ancestor; -------------- -- Add_With -- -------------- procedure Add_With (Unit : in out Compilation_Unit; Dep : String; Use_It : Boolean := False; Elab_Control : Elab_Control_Pragma := None; No_Warnings : Boolean := False) is Dep_Node : Dependency; LU_Name : constant String := Unit.Library_Unit_Name.all; begin if False or else Dep = "Standard" or else Dep = LU_Name or else Unit.Comment_Out_Mode then -- No need to with oneself. If Dep is an ancestor of Unit, register -- it (even though no 'with' clause will be emitted) for the sake of -- elaboration control. If in comment out mode, ignore dependency as -- well. return; end if; pragma Debug (O ("Adding depend of " & LU_Name & " (" & Unit_Kind'Image (Unit.Kind) & ")" & " upon " & Dep)); if True and then Unit.Kind = Unit_Spec and then Is_Ancestor (LU_Name, Dep) then -- All hope abandon he who trieth to make a package spec depend upon -- its child. pragma Debug (O ("The declaration of " & LU_Name & " cannot depend on " & Dep)); raise Program_Error; end if; Dep_Node := Find_Dep (Dep, Unit.Context_Clause); if Dep_Node = null then Unit.Context_Clause := new Dependency_Node' (Library_Unit => new String'(Dep), Use_It => Use_It, Elab_Control => Elab_Control, No_Warnings => No_Warnings, Next => Unit.Context_Clause); else Dep_Node.Use_It := Dep_Node.Use_It or else Use_It; Dep_Node.No_Warnings := Dep_Node.No_Warnings and then No_Warnings; if Elab_Control = Elaborate_All or else Dep_Node.Elab_Control = Elaborate_All then Dep_Node.Elab_Control := Elaborate_All; elsif Elab_Control = Elaborate or else Dep_Node.Elab_Control = Elaborate then Dep_Node.Elab_Control := Elaborate; else Dep_Node.Elab_Control := None; end if; end if; end Add_With; ------------------------ -- Add_Elaborate_Body -- ------------------------ procedure Add_Elaborate_Body (U_Spec : in out Compilation_Unit; U_Body : Compilation_Unit) is begin pragma Assert (U_Spec.Kind = Unit_Spec); if not Is_Empty (U_Body) then U_Spec.Diversions (Visible_Declarations).Empty := False; U_Spec.Elaborate_Body := True; end if; end Add_Elaborate_Body; ------------------------------ -- Suppress_Warning_Message -- ------------------------------ procedure Suppress_Warning_Message (Unit : in out Compilation_Unit) is begin Unit.No_Warning := True; end Suppress_Warning_Message; ---------- -- Name -- ---------- function Name (CU : Compilation_Unit) return String is begin return CU.Library_Unit_Name.all; end Name; ----------------------------- -- Allocate_User_Diversion -- ----------------------------- function Allocate_User_Diversion return Diversion is begin for I in User_Diversions'Range loop if not Diversions_Allocation (I) then Diversions_Allocation (I) := True; return I; end if; end loop; -- Too many diversions open raise Program_Error; end Allocate_User_Diversion; ----------------------- -- Current_Diversion -- ----------------------- function Current_Diversion (CU : Compilation_Unit) return Diversion is begin return CU.Current_Diversion; end Current_Diversion; ------------ -- Divert -- ------------ procedure Divert (CU : in out Compilation_Unit; Whence : Diversion) is begin if not (Diversions_Allocation (Whence) and then (False or else Whence in User_Diversions'Range or else Whence = Visible_Declarations or else (Whence = Private_Declarations and then CU.Kind = Unit_Spec) or else (Whence = Elaboration and then CU.Kind = Unit_Body) or else (Whence = Generic_Formals and then CU.Kind = Unit_Spec))) then raise Program_Error; end if; CU.Current_Diversion := Whence; end Divert; -------------- -- Undivert -- -------------- procedure Undivert (CU : in out Compilation_Unit; D : Diversion) is Div : Diversion_Data renames CU.Diversions (D); Empty_Diversion : Diversion_Data; pragma Warnings (Off, Empty_Diversion); -- Use default initialization begin if not Diversions_Allocation (D) then raise Program_Error; end if; if Length (Div.Library_Item) > 0 then if not CU.Diversions (CU.Current_Diversion).At_BOL then New_Line (CU); end if; -- Now we are actually at BOL Put (CU, To_String (Div.Library_Item)); CU.Diversions (CU.Current_Diversion).At_BOL := Div.At_BOL; end if; if not Div.Empty then -- Undivert might be performed in template mode, so we need to -- carry manually the non-Empty status from D to Current_Diversion. CU.Diversions (CU.Current_Diversion).Empty := False; end if; -- Reset diversion D to empty state CU.Diversions (D) := Empty_Diversion; end Undivert; -------------------------- -- New_Compilation_Unit -- -------------------------- procedure New_Compilation_Unit (CU : out Compilation_Unit; Kind : Unit_Kind; Name : String; Corresponding_Spec : Compilation_Unit_Access := null) is Res : Compilation_Unit (Kind); pragma Warnings (Off, Res); -- Used to provide defaults for all components, and an appropriate -- discriminant. begin CU := Res; CU.Library_Unit_Name := new String'(Name); for D in Predefined_Diversions loop CU.Diversions (D).Indent_Level := 1; end loop; if Kind = Unit_Spec then pragma Assert (Corresponding_Spec = null); null; else pragma Assert (Corresponding_Spec /= null); CU.Corresponding_Spec := Corresponding_Spec; end if; end New_Compilation_Unit; -------------- -- Generate -- -------------- procedure Generate (Unit : Compilation_Unit; Is_Generic_Instantiation : Boolean := False; To_Stdout : Boolean := False) is function Ada_File_Name (Full_Name : String; Part : Unit_Kind := Unit_Spec) return String; -- Name of the source file for Unit ------------------- -- Ada_File_Name -- ------------------- function Ada_File_Name (Full_Name : String; Part : Unit_Kind := Unit_Spec) return String is Extension : constant array (Unit_Kind) of Character := (Unit_Spec => 's', Unit_Body => 'b'); Result : String := Full_Name & ".ad?"; begin for I in Result'First .. Result'Last - 4 loop if Result (I) = '.' then Result (I) := '-'; else Result (I) := To_Lower (Result (I)); end if; end loop; Result (Result'Last) := Extension (Part); return Result; end Ada_File_Name; use Output; procedure Emit_Standard_Header (User_Edited : Boolean := False); -- Generate boilerplate header. If User_Edited is False, include a -- warning that the file is generated automatically and should not -- be modified by hand. procedure Emit_Source_Code; -- Generate the source text -------------------------- -- Emit_Standard_Header -- -------------------------- procedure Emit_Standard_Header (User_Edited : Boolean := False) is begin Write_Line ("-------------------------------------------------"); Write_Line ("-- This file has been generated automatically"); Write_Line ("-- by IDLAC version " & Platform.Version & "."); if not User_Edited then Write_Line ("--"); Write_Line ("-- Do NOT hand-modify this file, as your"); Write_Line ("-- changes will be lost when you re-run the"); Write_Line ("-- IDL to Ada compiler."); end if; Write_Line ("-------------------------------------------------"); -- Disable style checks (N), and set maximum line length to the -- largest allowed value (M32766). Write_Line ("pragma Style_Checks (""NM32766"");"); Write_Eol; end Emit_Standard_Header; ---------------------- -- Emit_Source_Code -- ---------------------- procedure Emit_Source_Code is Dep_Node : Dependency := Unit.Context_Clause; begin while Dep_Node /= null loop declare Spec_Dep_Node : Dependency := null; begin if Unit.Kind = Unit_Body then Spec_Dep_Node := Find_Dep (Dep_Node.Library_Unit.all, Unit.Corresponding_Spec.Context_Clause); end if; if Dep_Node.Elab_Control /= None or else (Spec_Dep_Node = null and then not Is_Ancestor (Dep_Node.Library_Unit.all, Unit.Library_Unit_Name.all)) then Write_Line ("with " & Dep_Node.Library_Unit.all & ";"); if Dep_Node.Use_It and then (Spec_Dep_Node = null or else not Spec_Dep_Node.Use_It) then Write_Line (" use " & Dep_Node.Library_Unit.all & ";"); end if; case Dep_Node.Elab_Control is when Elaborate_All => Write_Line ("pragma Elaborate_All (" & Dep_Node.Library_Unit.all & ");"); when Elaborate => Write_Line ("pragma Elaborate (" & Dep_Node.Library_Unit.all & ");"); when None => null; end case; if Dep_Node.No_Warnings then Write_Line ("pragma Warnings (Off, " & Dep_Node.Library_Unit.all & ");"); end if; end if; end; Dep_Node := Dep_Node.Next; end loop; if Unit.Context_Clause /= null then Write_Eol; end if; if not Unit.Diversions (Generic_Formals).Empty then Write_Line ("generic"); Write_Str (To_String (Unit.Diversions (Generic_Formals).Library_Item)); Write_Eol; end if; Write_Str ("package "); if Unit.Kind = Unit_Body then Write_Str ("body "); end if; Write_Line (Unit.Library_Unit_Name.all & " is"); if Unit.Kind = Unit_Spec and then Unit.Elaborate_Body then Write_Eol; Write_Line (" pragma Elaborate_Body;"); end if; if not Unit.Diversions (Visible_Declarations).Empty then Write_Str (To_String (Unit.Diversions (Visible_Declarations).Library_Item)); end if; if not Unit.Diversions (Private_Declarations).Empty then Write_Eol; Write_Line ("private"); Write_Str (To_String (Unit.Diversions (Private_Declarations).Library_Item)); end if; if not Unit.Diversions (Elaboration).Empty then Write_Eol; Write_Line ("begin"); Write_Str (To_String (Unit.Diversions (Elaboration).Library_Item)); end if; if not Is_Generic_Instantiation then Write_Eol; Write_Line ("end " & Unit.Library_Unit_Name.all & ";"); end if; end Emit_Source_Code; use GNAT.OS_Lib; File_Name : Unbounded_String; -- Name of output file File : File_Descriptor; -- Output file descriptor Success : Boolean; -- Status returned upon closing File -- Start of processing for Generate begin if Is_Empty (Unit) then return; end if; if To_Stdout then File := Standout; else File_Name := Output_Directory & Ada_File_Name (Unit.Library_Unit_Name.all, Unit.Kind); File := Create_File (To_String (File_Name), Fmode => Binary); if File = Invalid_FD then raise Program_Error with "cannot create output file " & To_String (File_Name); end if; end if; Set_Output (File); Emit_Standard_Header (Unit.No_Warning); Emit_Source_Code; if not To_Stdout then Close (File, Status => Success); if not Success then raise Program_Error with "failed to close " & To_String (File_Name); end if; end if; end Generate; --------- -- Put -- --------- procedure Put (Unit : in out Compilation_Unit; Text : String) is Indent_String : constant String (1 .. Indent_Size * Unit.Diversions (Unit.Current_Diversion).Indent_Level) := (others => ' '); LF_Pos : Integer; Non_Space_Seen : Boolean := False; At_BOL : Boolean renames Unit.Diversions (Unit.Current_Diversion).At_BOL; begin if not Unit.Template_Mode then Unit.Diversions (Unit.Current_Diversion).Empty := False; end if; -- If in comment-out mode, output comment marker at beginning of line if Unit.Diversions (Unit.Current_Diversion).At_BOL then if Unit.Comment_Out_Mode then Append (Unit.Diversions (Unit.Current_Diversion).Library_Item, "-- "); end if; end if; -- Determine whether the provided text contains a linefeed, and if so, -- wheter there is any non-space character before the linefeed. LF_Pos := Text'First; while LF_Pos <= Text'Last and then Text (LF_Pos) /= ASCII.LF loop if Text (LF_Pos) /= ' ' then Non_Space_Seen := True; end if; LF_Pos := LF_Pos + 1; end loop; -- Do not output indentation if we know we are generating an empty line if At_BOL and then (Non_Space_Seen or else LF_Pos > Text'Last) then Append (Unit.Diversions (Unit.Current_Diversion).Library_Item, Indent_String); end if; Append (Unit.Diversions (Unit.Current_Diversion).Library_Item, Text (Text'First .. LF_Pos - 1)); At_BOL := False; -- LF seen? if LF_Pos <= Text'Last then New_Line (Unit); end if; -- More? if LF_Pos + 1 <= Text'Last then Put (Unit, Text (LF_Pos + 1 .. Text'Last)); end if; end Put; -------------- -- Put_Line -- -------------- procedure Put_Line (Unit : in out Compilation_Unit; Line : String) is begin Put (Unit, Line & ASCII.LF); end Put_Line; -------------- -- New_Line -- -------------- procedure New_Line (Unit : in out Compilation_Unit) is begin Append (Unit.Diversions (Unit.Current_Diversion).Library_Item, LF); Unit.Diversions (Unit.Current_Diversion).At_BOL := True; end New_Line; ---------------- -- Inc_Indent -- ---------------- procedure Inc_Indent (Unit : in out Compilation_Unit) is begin Unit.Diversions (Unit.Current_Diversion).Indent_Level := Unit.Diversions (Unit.Current_Diversion).Indent_Level + 1; end Inc_Indent; ---------------- -- Dec_Indent -- ---------------- procedure Dec_Indent (Unit : in out Compilation_Unit) is begin Unit.Diversions (Unit.Current_Diversion).Indent_Level := Unit.Diversions (Unit.Current_Diversion).Indent_Level - 1; end Dec_Indent; ----------------------------- -- Current_Diversion_Empty -- ----------------------------- function Current_Diversion_Empty (CU : Compilation_Unit) return Boolean is begin return CU.Diversions (CU.Current_Diversion).Empty; end Current_Diversion_Empty; -------------- -- Is_Empty -- -------------- function Is_Empty (Unit : Compilation_Unit) return Boolean is begin for I in Unit.Diversions'Range loop if not Unit.Diversions (I).Empty then return False; end if; end loop; return True; end Is_Empty; -------------------------- -- Set_Output_Directory -- -------------------------- function Set_Output_Directory (Dir : String) return Boolean is begin if not GNAT.OS_Lib.Is_Directory (Dir) then return False; end if; Output_Directory := To_Unbounded_String (Dir); if not Utils.Is_Dir_Separator (Dir (Dir'Last)) then Append (Output_Directory, GNAT.Directory_Operations.Dir_Separator); end if; return True; end Set_Output_Directory; -------------------------- -- Set_Comment_Out_Mode -- -------------------------- procedure Set_Comment_Out_Mode (Unit : in out Compilation_Unit; Mode : Boolean) is begin Unit.Comment_Out_Mode := Mode; end Set_Comment_Out_Mode; ----------------------- -- Set_Template_Mode -- ----------------------- procedure Set_Template_Mode (Unit : in out Compilation_Unit; Mode : Boolean) is begin Unit.Template_Mode := Mode; end Set_Template_Mode; -------------- -- Find_Dep -- -------------- function Find_Dep (Unit : String; Context_Clauses : Dependency) return Dependency is D : Dependency := Context_Clauses; begin while D /= null and then D.Library_Unit.all /= Unit loop D := D.Next; end loop; return D; end Find_Dep; end Ada_Be.Source_Streams; polyorb-2.8~20110207.orig/compilers/idlac/ada_be-idl2ada-ir_info.ads0000644000175000017500000000504311750740337024270 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- A D A _ B E . I D L 2 A D A . I R _ I N F O -- -- -- -- S p e c -- -- -- -- Copyright (C) 2002-2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ private package Ada_Be.Idl2Ada.IR_Info is Suffix : constant String := ".IR_Info"; procedure Gen_Spec_Prelude (CU : in out Compilation_Unit); procedure Gen_Body_Prelude (CU : in out Compilation_Unit); procedure Gen_Body_Postlude (CU : in out Compilation_Unit); procedure Gen_Node_Spec (CU : in out Compilation_Unit; Node : Node_Id); procedure Gen_Node_Body (CU : in out Compilation_Unit; Node : Node_Id); -- Generate an Interface Repository information package end Ada_Be.Idl2Ada.IR_Info; polyorb-2.8~20110207.orig/compilers/idlac/string_sets.ads0000644000175000017500000000676711750740337022536 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- S T R I N G _ S E T S -- -- -- -- S p e c -- -- -- -- Copyright (C) 2006-2007, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- Simple sets of Strings. Note that storage is never reclaimed; objects of -- type Set are typically global. with GNAT.Dynamic_HTables; package String_Sets is type Set is limited private; function Contains (Container : Set; Element : String) return Boolean; -- Determine whether Element is in Container procedure Insert (Container : in out Set; Element : String); -- Insert Element into Container private -- WAG:5.03a1 : Ideally, this would be implemented in terms of -- Ada.Containers.Indefinite_Hashed_Sets, but we wish to avoid -- dependence on Ada 2005 features, so this can be compiled with -- older compilers. -- The implementation is a hash table mapping strings to True; False means -- "not present". This implementation is probably not as efficient as the -- Indefinite_Hashed_Sets would be. type Header_Num is range 0 .. 2**14 - 1; -- arbitrary number; seems big enough type String_Ptr is access constant String; -- We have to use a pointer, because Simple_HTable requires a definite -- subtype. function Hash (F : String_Ptr) return Header_Num; function Equal (F1, F2 : String_Ptr) return Boolean; package Tables is new GNAT.Dynamic_HTables.Simple_HTable (Header_Num => Header_Num, Element => Boolean, No_Element => False, Key => String_Ptr, Hash => Hash, Equal => Equal); type Set is limited record Set : Tables.Instance; end record; end String_Sets; polyorb-2.8~20110207.orig/compilers/idlac/idl_fe-display_tree.ads0000644000175000017500000000565311750740337024067 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- I D L _ F E . D I S P L A Y _ T R E E -- -- -- -- S p e c -- -- -- -- Copyright (C) 2001 Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by ACT Europe. -- -- (email: sales@act-europe.fr) -- -- -- ------------------------------------------------------------------------------ with Idl_Fe.Types; use Idl_Fe.Types; package Idl_Fe.Display_Tree is Offset : constant Natural := 2; procedure Disp_Tree (Tree : Node_Id); -- display a node list procedure Disp_List (List : Node_List; Indent : Natural; Full : Boolean); private -- display the indentation procedure Disp_Indent (Indent : Natural; S : String := ""); -- displays a binary operator procedure Disp_Binary (N : Node_Id; Indent : Natural; Full : Boolean; Op : String); -- displays a unary operator procedure Disp_Unary (N : Node_Id; Indent : Natural; Full : Boolean; Op : String); -- displays a constant value and its type procedure Disp_Const_Value (Expr : Constant_Value_Ptr; Indent : Natural); end Idl_Fe.Display_Tree; polyorb-2.8~20110207.orig/compilers/idlac/idlac_utils.adb0000644000175000017500000001165411750740337022434 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- U T I L S -- -- -- -- B o d y -- -- -- -- Copyright (C) 2001-2008, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- Utilities for the IDLAC compiler. with System.Address_Image; package body Idlac_Utils is --------- -- Img -- --------- function Img (N : Character) return String is begin return (1 => N); end Img; --------- -- Img -- --------- function Img (N : Idl_Integer) return String is S : constant String := Idl_Integer'Image (N); begin if S (S'First) = ' ' then return S (S'First + 1 .. S'Last); else return S; end if; end Img; --------- -- Img -- --------- function Long_Integer_Img (N : Long_Integer) return String is begin return Img (Idl_Integer (N)); end Long_Integer_Img; --------- -- Img -- --------- function Img (N : Integer) return String is begin return Img (Idl_Integer (N)); end Img; --------- -- Img -- --------- function Img (N : Idl_Float) return String is begin return Idl_Float'Image (N); end Img; --------- -- Img -- --------- function Img (N : Node_Id) return String is begin if N = No_Node then return "No_Node"; else return Img (Natural (N)); end if; end Img; --------- -- Img -- --------- function Img (N : Node_Kind) return String is begin return Node_Kind'Image (N); end Img; --------- -- Img -- --------- function Img (B : Boolean) return String is begin if B then return "True"; else return "False"; end if; end Img; --------- -- Img -- --------- function Img (A : System.Address) return String renames System.Address_Image; --------- -- Img -- --------- function Img (A : Constant_Value_Ptr) return String is begin case A.all.Kind is when C_Octet | C_Short | C_Long | C_LongLong | C_UShort | C_ULong | C_ULongLong | C_General_Integer => return Img (A.all.Integer_Value); when C_Char => -- FIXME : not a correct image return ""; when C_WChar => -- FIXME : not a correct image return ""; when C_Boolean => -- FIXME : not a correct image return ""; when C_Float | C_Double | C_LongDouble | C_General_Float => -- FIXME : not a correct image return ""; when C_String => -- FIXME : not a correct image return ""; when C_WString => -- FIXME : not a correct image return ""; when C_Fixed | C_General_Fixed => -- FIXME : not a correct image return ""; when C_Enum => -- FIXME : not a correct image return ""; when C_No_Kind => return ""; end case; end Img; end Idlac_Utils; polyorb-2.8~20110207.orig/compilers/idlac/idl_fe-parser.ads0000644000175000017500000012765611750740337022707 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- I D L _ F E . P A R S E R -- -- -- -- S p e c -- -- -- -- Copyright (C) 2001-2007, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with Idl_Fe.Lexer; use Idl_Fe.Lexer; with Idl_Fe.Types; use Idl_Fe.Types; with Idlac_Errors; with Ada.Unchecked_Deallocation; package Idl_Fe.Parser is -------------------- -- Initialization -- -------------------- procedure Initialize (Filename : String); procedure Finalize; --------------------------------------------------------------------------- -- Parsing of an IDL specification (root nonterminal of the IDL grammar) -- --------------------------------------------------------------------------- function Parse_Specification return Node_Id; -- Parse IDL specification according to CORBA V3.0, 3.4 private -------------------------------------- -- Management of the token stream -- -------------------------------------- -- This function returns the current token function Get_Token return Idl_Token; -- This procedure gets the next token from the lexer and put it -- into the token_buffer. It also gets its location and -- eventually its string representation and put them in the -- corresponding buffers procedure Get_Token_From_Lexer; -- This procedure consumes a token. If the token was already -- in the buffer, it just increases the index. Else, it gets -- the next token from the lexer. procedure Next_Token; -- Returns the previous token in the token stream. function View_Previous_Token return Idl_Token; -- Returns the previous token in the token stream. function View_Previous_Previous_Token return Idl_Token; -- Returns the next token in the token stream without consuming -- it. If necessary get it from the lexer and put it in the buffer function View_Next_Token return Idl_Token; -- Returns the next token in the token stream without consuming -- it. If necessary get it from the lexer and put it in the buffer function View_Next_Next_Token return Idl_Token; -- Returns the location of the current_token function Get_Token_Location return Idlac_Errors.Location; -- Returns the location of the previous token function Get_Previous_Token_Location return Idlac_Errors.Location; -- Returns the location of the previous token function Get_Previous_Previous_Token_Location return Idlac_Errors.Location; -- Returns the location of the current_token function Get_Next_Token_Location return Idlac_Errors.Location; -- The next three methods unreference a pointer without any -- verification. that's because the verification is useless -- in this case if this package is correctly written. -- Since these methods are not exported... -- Returns the location of the current_token function Get_Token_String return String; -- Returns the string of the previous token function Get_Previous_Token_String return String; -- Returns the string of the previous token function Get_Previous_Previous_Token_String return String; -- Returns the string of the current_token function Get_Next_Token_String return String; -- Divides T_Greater_Greater in two T_Greater -- usefull for the parsing of sequences procedure Divide_T_Greater_Greater; --------------------------------- -- Management of expressions -- --------------------------------- -- a generic interval of values type Interval_Type is record Min, Max : Constant_Value_Ptr; end record; -- a generic set of values, implemented as a list of intervals type Set; type Set_Ptr is access Set; type Set is record Interval : Interval_Type; Next : Set_Ptr; end record; -- to deallocate a set_ptr procedure Free is new Ada.Unchecked_Deallocation (Set, Set_Ptr); -- -- try to add a value to the set of already used values. -- -- if this value was already there, it return false, else true -- function Add_Used_Value -- (C : Node_Id) -- return Boolean; -- -- Frees all the set of already used values -- procedure Release_All_Used_Values; -------------------------- -- Parsing of the idl -- -------------------------- -- -- CORBA V3.0, 3.4 -- -- Rule 1 : -- ::= * + procedure Parse_Specification (Repository : Node_Id; Called_From_Import : Boolean); -- Rule 2 -- ::= ";" -- | ";" -- | ";" -- | ";" -- | ";" -- | ";" -- | ";" -- | ";" -- | ";" -- not implemented -- | ";" -- not implemented -- | ";" -- not implemented procedure Parse_Definition (Result : out Node_Id; Success : out Boolean); -- Rule 3 -- ::= "module" "{" + "}" procedure Parse_Module (Result : out Node_Id; Success : out Boolean; Reopen : out Boolean); -- Rule 4 -- ::= | -- -- Rule 5 -- ::= "{" "}" -- -- Rule 6 -- ::= ["abstract" | "local"] "interface" -- -- Rule 7 -- ::= ["abstract" | "local"] "interface" -- [ ] -- -- These rules are equivalent to -- -- Rule Inter1 -- ::= ["abstract" | "local"] "interface" -- -- -- Rule Inter2 -- ::= -- | -- -- Rule Inter3 -- ::= -- -- Rule Inter4 -- ::= [] "{" -- "}" -- this last will be used in Parse_Interface_Dcl_End procedure Parse_Interface (Result : out Node_Id; Success : out Boolean); -- Rule 8 -- ::= * procedure Parse_Interface_Body (List : in out Node_List; Success : out Boolean); -- Rule 9 -- ::= ";" -- | ";" -- | ";" -- | ";" -- | ";" -- | ";" -- not implemented -- | ";" -- not implemented procedure Parse_Export (Result : out Node_Id; Success : out Boolean); -- ::= [] "{" -- "}" -- -- Rule 10 -- ::= ":" -- { "," }* procedure Parse_Interface_Dcl_End (Result : in out Node_Id; Success : out Boolean); -- Rule 11 -- ::= procedure Parse_Interface_Name (Result : out Node_Id; Success : out Boolean); -- Rule 12 -- ::= -- | "::" -- | "::" procedure Parse_Scoped_Name (Result : out Node_Id; Success : out Boolean); -- Rule 13 -- ::= ( -- | -- | -- | ) ";" -- Rule 14 -- ::= [ "abstract" ] "valuetype" -- Rule 15 -- ::= "valuetype" -- Rule 16 -- ::= "abstract" "valuetype" -- [ ] "{" * "}" -- Rule 17 -- ::= "{" * "}" -- Rule 18 -- ::= ["custom" ] "valuetype" -- [ ] -- These Rules (13 to 18) are equivalent to the following : -- Rule Value1 -- ::= ( "custom" -- | "abstract" -- | ) ";" -- Rule Value2 -- ::= "valuetype" -- Rule Value3 -- ::= "valuetype" ( -- | ) -- Rule Value4 -- ::= "valuetype" ( -- | -- | ) -- Rule Value5 -- ::= [ ] -- "{" < value_element>* "}" -- Rule Value6 -- ::= [ ] -- "{" * "}" -- Rule Value7 -- ::= -- Rule Value8 -- ::= -- Rule Value1 -- ::= ( "custom" -- | "abstract" -- | ) ";" procedure Parse_Value (Result : out Node_Id; Success : out Boolean); -- Rule Value2 -- ::= "valuetype" procedure Parse_Custom_Value (Result : out Node_Id; Success : out Boolean); -- Rule Value3 -- ::= "valuetype" ( -- | ) procedure Parse_Abstract_Value (Result : out Node_Id; Success : out Boolean); -- Rule Value4 -- ::= "valuetype" ( -- | -- | ) procedure Parse_Direct_Value (Result : out Node_Id; Success : out Boolean); -- Since rule 5 and 6 are very close, there is only one method -- Rule Value5 -- ::= [ ] -- "{" < value_element>* "}" -- Rule Value6 -- ::= [ ] -- "{" * "}" procedure Parse_End_Value_Dcl (Result : out Node_Id; Success : out Boolean; Custom : Boolean; Abst : Boolean); -- Rule Value7 -- ::= procedure Parse_End_Value_Forward_Dcl (Result : out Node_Id; Success : out Boolean; Abst : Boolean); -- Rule Value8 -- ::= procedure Parse_End_Value_Box_Dcl (Result : out Node_Id; Success : out Boolean); -- Rule 19 -- ::= [ ":" [ "truncatable" ] -- { "," }* ] -- [ "supports" -- { "," }* ] procedure Parse_Value_Inheritance_Spec (Result : Node_Id; Success : out Boolean); -- Rule 20 -- ::= procedure Parse_Value_Name (Result : out Node_Id; Success : out Boolean); -- Rule 21 -- ::= | | procedure Parse_Value_Element (Result : out Node_Id; Success : out Boolean); -- Rule 22 -- ::= ( "public" | "private" ) -- ";" procedure Parse_State_Member (Result : out Node_Id; Success : out Boolean); -- Rule 23 -- ::= "factory" "(" -- [ ] ")" ";" procedure Parse_Init_Dcl (Result : out Node_Id; Success : out Boolean); -- Rule 24 -- ::= { "," } procedure Parse_Init_Param_Decls (Result : out Node_List; Success : out Boolean); -- Rule 25 -- ::= -- -- Rule 26 -- ::= "in" procedure Parse_Init_Param_Decl (Result : out Node_Id; Success : out Boolean); -- Rule 27 -- ::= "const" "=" procedure Parse_Const_Dcl (Result : out Node_Id; Success : out Boolean); -- Rule 28 -- ::= -- | -- | -- | -- | -- | -- | -- | -- | -- | procedure Parse_Const_Type (Result : out Node_Id; Success : out Boolean); -- Rule 29 -- ::= procedure Parse_Const_Exp (Result : out Node_Id; Constant_Type : Node_Id; Success : out Boolean); -- Rule 30 -- ::= -- | "|" -- actually, the implemented gramar is slightly different : -- ::= { "|" }* procedure Parse_Or_Expr (Result : out Node_Id; Success : out Boolean; Expr_Type : Constant_Value_Ptr); -- Rule 31 -- ::= -- | "^" -- actually, the implemented gramar is slightly different : -- ::= { "^" }* procedure Parse_Xor_Expr (Result : out Node_Id; Success : out Boolean; Expr_Type : Constant_Value_Ptr); -- Rule 32 -- ::= -- | "&" -- actually, the implemented gramar is slightly different : -- ::= { "&" }* procedure Parse_And_Expr (Result : out Node_Id; Success : out Boolean; Expr_Type : Constant_Value_Ptr); -- Rule 33 -- ::= -- | ">>" -- | "<<" -- actually, the implemented gramar is slightly different : -- ::= { { ">>" | "<<" } }* procedure Parse_Shift_Expr (Result : out Node_Id; Success : out Boolean; Expr_Type : Constant_Value_Ptr); -- Rule 34 -- ::= -- | "+" -- | "-" -- actually, the implemented gramar is slightly different : -- ::= { { "+" | "-" } }* procedure Parse_Add_Expr (Result : out Node_Id; Success : out Boolean; Expr_Type : Constant_Value_Ptr); -- Rule 35 -- ::= -- | "*" -- | "/" -- | "%" -- actually, the implemented gramar is slightly different : -- ::= { { "*" | "/" | "%" } }* procedure Parse_Mult_Expr (Result : out Node_Id; Success : out Boolean; Expr_Type : Constant_Value_Ptr); -- Rule 36 -- ::= -- | -- Rule 37 -- ::= "+" | "-" | "~" procedure Parse_Unary_Expr (Result : out Node_Id; Success : out Boolean; Expr_Type : Constant_Value_Ptr); -- Rule 38 -- ::= -- | -- | "(" ")" procedure Parse_Primary_Expr (Result : out Node_Id; Success : out Boolean; Expr_Type : Constant_Value_Ptr); -- Rule 39 -- ::= -- | -- | -- | -- | -- | -- | -- | procedure Parse_Literal (Result : out Node_Id; Success : out Boolean; Expr_Type : Constant_Value_Ptr); -- Rule 40 -- ::= "TRUE" -- | "FALSE" procedure Parse_Boolean_Literal (Result : out Node_Id; Success : out Boolean; Expr_Type : Constant_Value_Ptr); -- Rule 41 -- ::= procedure Parse_Positive_Int_Const (Result : out Node_Id; Success : out Boolean); -- Rule 42 -- ::= "typedef" -- | -- | -- | -- | "native" -- | -- not implemented procedure Parse_Type_Dcl (Result : out Node_Id; Success : out Boolean); -- Rule 43 -- ::= procedure Parse_Type_Declarator (Result : out Node_Id; Success : out Boolean); -- Rule 44 -- ::= -- | procedure Parse_Type_Spec (Result : out Node_Id; Success : out Boolean); -- Rule 45 -- ::= -- | -- | procedure Parse_Simple_Type_Spec (Result : out Node_Id; Success : out Boolean); -- Rule 46 -- ::= -- | -- | -- | -- | -- | -- | -- | -- | -- not implemented procedure Parse_Base_Type_Spec (Result : out Node_Id; Success : out Boolean); -- Rule 47 -- ::= -- | -- | -- | procedure Parse_Template_Type_Spec (Result : out Node_Id; Success : out Boolean); -- Rule 48 -- ::= -- | -- | procedure Parse_Constr_Type_Spec (Result : out Node_Id; Success : out Boolean); -- Rule 49 -- ::= { "," }* procedure Parse_Declarators (Result : out Node_List; Parent : Node_Id; Success : out Boolean); -- Rule 50 -- ::= -- | procedure Parse_Declarator (Result : out Node_Id; Parent : Node_Id; Success : out Boolean); -- Rule 51 -- ::= procedure Parse_Simple_Declarator (Result : out Node_Id; Parent : Node_Id; Success : out Boolean); -- Rule 52 -- ::= procedure Parse_Complex_Declarator (Result : out Node_Id; Parent : Node_Id; Success : out Boolean); -- Rule 53 -- ::= "float" -- | "double" -- | "long" "double" procedure Parse_Floating_Pt_Type (Result : out Node_Id; Success : out Boolean); -- Rule 54 -- ::= -- | procedure Parse_Integer_Type (Result : out Node_Id; Success : out Boolean); -- Rule 55 -- ::= -- | -- | procedure Parse_Signed_Int (Result : out Node_Id; Success : out Boolean); -- Rule 56 -- ::= "short" procedure Parse_Signed_Short_Int (Result : out Node_Id; Success : out Boolean); -- Rule 57 -- := "long" procedure Parse_Signed_Long_Int (Result : out Node_Id; Success : out Boolean); -- Rule 58 -- ::= "long" "long" procedure Parse_Signed_Longlong_Int (Result : out Node_Id; Success : out Boolean); -- Rule 59 -- ::= -- | -- | procedure Parse_Unsigned_Int (Result : out Node_Id; Success : out Boolean); -- Rule 60 -- ::= "unsigned" "short" procedure Parse_Unsigned_Short_Int (Result : out Node_Id; Success : out Boolean); -- Rule 61 -- ::= "unsigned" "long" procedure Parse_Unsigned_Long_Int (Result : out Node_Id; Success : out Boolean); -- Rule 62 -- ::= "unsigned" "long" "long" procedure Parse_Unsigned_Longlong_Int (Result : out Node_Id; Success : out Boolean); -- Rule 63 -- ::= "char" procedure Parse_Char_Type (Result : out Node_Id; Success : out Boolean); -- Rule 64 -- ::= "wchar" procedure Parse_Wide_Char_Type (Result : out Node_Id; Success : out Boolean); -- Rule 65 -- ::= "boolean" procedure Parse_Boolean_Type (Result : out Node_Id; Success : out Boolean); -- Rule 66 -- ::= "octet" procedure Parse_Octet_Type (Result : out Node_Id; Success : out Boolean); -- Rule 67 -- ::= "any" procedure Parse_Any_Type (Result : out Node_Id; Success : out Boolean); -- Rule 68 -- ::= "Object" procedure Parse_Object_Type (Result : out Node_Id; Success : out Boolean); -- Rule 69 -- ::= "struct" "{" "}" procedure Parse_Struct_Type (Result : out Node_Id; Success : out Boolean); -- Rule 70 -- ::= + procedure Parse_Member_List (Result : out Node_List; Success : out Boolean); -- Rule 71 -- ::= ";" procedure Parse_Member (Result : out Node_Id; Success : out Boolean); -- Rule 72 -- ::= "union" -- "switch" "(" ")" -- "{" "}" procedure Parse_Union_Type (Result : out Node_Id; Success : out Boolean); -- Rule 73 -- ::= -- | -- | -- | -- | procedure Parse_Switch_Type_Spec (Result : out Node_Id; Success : out Boolean); -- Rule 74 -- ::= + procedure Parse_Switch_Body (Result : out Node_List; Switch_Type : Node_Id; Default_Index : out Long_Integer; Success : out Boolean); -- Rule 75 -- ::= + ";" procedure Parse_Case (Result : out Node_Id; Switch_Type : Node_Id; Success : out Boolean); -- Rule 76 -- ::= "case" ":" -- | "default ":" procedure Parse_Case_Label (Result : out Node_Id; Switch_Type : Node_Id; Success : out Boolean); -- Rule 77 -- ::= procedure Parse_Element_Spec (Element_Type : out Node_Id; Element_Decl : out Node_Id; Parent : Node_Id; Success : out Boolean); -- Rule 78 -- ::= "enum" "{" -- { "," }* "}" procedure Parse_Enum_Type (Result : out Node_Id; Success : out Boolean); -- Rule 79 -- ::= procedure Parse_Enumerator (Result : out Node_Id; Success : out Boolean); -- Rule 80 -- ::= "sequence" "<" -- "," ">" -- | "sequence" "<" ">" procedure Parse_Sequence_Type (Result : out Node_Id; Success : out Boolean); -- Rule 81 -- ::= "string" "<" ">" -- | "string" procedure Parse_String_Type (Result : out Node_Id; Success : out Boolean); -- Rule 82 -- ::= "wstring" "<" ">" -- | "wstring" procedure Parse_Wide_String_Type (Result : out Node_Id; Success : out Boolean); -- Rule 83 -- ::= + procedure Parse_Array_Declarator (Result : out Node_Id; Parent : Node_Id; Success : out Boolean); -- Rule 84 -- ::= "[" "]" procedure Parse_Fixed_Array_Size (Result : out Node_Id; Success : out Boolean); -- Rule 85: -- ::= -- | -- -- Actually implement below rule: -- ::= "readonly" "attribute" -- -- | "readonly" "attribute" -- { "," }* -- | "attribute" -- -- | "attribute" -- { "," }* procedure Parse_Attr_Dcl (Result : out Node_Id; Success : out Boolean); -- Rule 86 -- ::= "exception" "{" * "}" procedure Parse_Except_Dcl (Result : out Node_Id; Success : out Boolean); -- Rule 87 -- ::= [ ] -- [ ] -- [ ] procedure Parse_Op_Dcl (Result : out Node_Id; Success : out Boolean); -- Rule 88 -- ::= "oneway" -- no parsing method needed here -- Rule 89 -- ::= -- | "void" procedure Parse_Op_Type_Spec (Result : out Node_Id; Success : out Boolean); -- Rule 90 -- ::= "(" { "," }* ")" -- | "(" ")" procedure Parse_Parameter_Dcls (Result : out Node_List; Success : out Boolean); -- Rule 91 -- ::= procedure Parse_Param_Dcl (Result : out Node_Id; Success : out Boolean); -- Rule 92 -- ::= "in" -- | "out" -- | "inout" procedure Parse_Param_Attribute (Result : out Param_Mode; Success : out Boolean); -- Rule 93 -- ::= "raises" "(" { "," -- " }* ")" -- actually, the implemented gramar is slightly different : -- ::= "raises" procedure Parse_Raises_Expr (Result : out Node_List; Success : out Boolean); -- Rule 94 -- ::= "context" "(" { "," -- }* ")" procedure Parse_Context_Expr (Result : out Node_List; Success : out Boolean); -- Rule 95 -- ::= -- | -- | -- | procedure Parse_Param_Type_Spec (Result : out Node_Id; Success : out Boolean); -- Rule 96 -- ::= "fixed" "<" "," -- ">" procedure Parse_Fixed_Pt_Type (Result : out Node_Id; Success : out Boolean); -- Rule 97 -- ::= "fixed" -- XXX Why no comments for this rule? -- Rule 98 -- ::= "ValueBase" procedure Parse_Value_Base_Type (Result : out Node_Id; Success : out Boolean); -- Rule 99 -- := "struct" -- | "union" -- Not implemented -- Rule 100 -- ::= "import" ";" procedure Parse_Import (Repository : Node_Id; Success : out Boolean); -- Rule 101 -- ::= | -- Not implemented -- Rule 102 -- ::= "typeid" procedure Parse_Type_Id_Dcl (Success : out Boolean); -- Rule 103 -- ::= "typeprefix" procedure Parse_Type_Prefix_Dcl (Success : out Boolean); -- Rule 104 -- ::= "readonly" "attribute" -- -- Implemented as part of rule 85. -- Rule 105 -- ::= -- | -- { "," }* -- Implemented as part of rule 85. -- Rule 106 -- ::= "attribute" -- Implemented as part of rule 85. -- Rule 107 -- ::= -- | { "," }* -- Implemented as part of rule 85. -- Rule 108 -- ::= [ ] -- | -- Actually implement below rule: -- ::= "getraises" -- [ "setraises" ] -- | "setraises" procedure Parse_Attr_Raises_Expr (Result_Get : out Node_List; Result_Set : out Node_List; Success : out Boolean); -- Rule 109 -- ::= "getraises" -- Implemented as part of rule 108 -- Rule 110 -- ::= "setraises" -- Implemented as part of rule 108 -- Rule 111 -- ::= "(" { "," }* ")" procedure Parse_Exception_List (Result : out Node_List; Success : out Boolean; Statement : String); -- Rules 112 .. 138 corresponded to CORBA components specification what -- can't currently supported. ------------------------------ -- Inheritance management -- ------------------------------ -- verifying that an interface can be imported : -- Int in a scoped name denoting the interface to be imported -- Scope is an interface where the other will be imported -- This function verifies that there is no operation or -- attributes in the new imported interface that clashes -- with the already imported ones. function Interface_Is_Importable (Int : Node_Id; Scope : Node_Id) return Boolean; -------------------------- -- Parsing of pragmas -- -------------------------- -- parsing pragmas procedure Parse_Pragma (Result : out Node_Id; Success : out Boolean); --------------------------- -- Parsing of literals -- --------------------------- -- gives the digit value correponding to an hexadecimal -- character function Hexa_Char_To_Digit (C : Character) return Integer; -- parse the character C at the beginning of the string S -- Offset is the number of character used in the string S -- For example, if S = "\12etc...", Result = LF and Offset = 3 procedure Get_Char_Literal (S : String; Result : out Idl_Character; Offset : out Integer); -- parse the wide character C at the beginning of the string S -- Offset is the number of character used in the string S -- For example, if S = "\u1a2etc...", Result = <1a2> and -- Offset = 4 procedure Get_Wide_Char_Literal (S : String; Result : out Idl_Wide_Character; Offset : out Integer); -- parsing an integer literal function Get_Integer_Literal return Idl_Integer; -- parse the repository_ids version procedure Parse_Version (Result : out Version_Type; Success : out Boolean); -- parsing of an integer procedure Parse_Integer_Literal (Result : out Node_Id; Success : out Boolean; Expr_Type : Constant_Value_Ptr); -- parsing of a string procedure Parse_String_Literal (Result : out Node_Id; Success : out Boolean; Expr_Type : Constant_Value_Ptr); -- parsing of a wide string procedure Parse_Wide_String_Literal (Result : out Node_Id; Success : out Boolean; Expr_Type : Constant_Value_Ptr); -- parsing of a char procedure Parse_Char_Literal (Result : out Node_Id; Success : out Boolean; Expr_Type : Constant_Value_Ptr); -- parsing of a wide char procedure Parse_Wide_Char_Literal (Result : out Node_Id; Success : out Boolean; Expr_Type : Constant_Value_Ptr); -- parsing of float function Get_Float_Literal return Idl_Float; -- parsing of a float procedure Parse_Floating_Pt_Literal (Result : out Node_Id; Success : out Boolean; Expr_Type : Constant_Value_Ptr); -- parsing of a fixed point number procedure Parse_Fixed_Pt_Literal (Result : out Node_Id; Success : out Boolean; Expr_Type : Constant_Value_Ptr); -- Checks the range of an expression value in case of -- integer or float type. If the range is not respected, -- raises an error and put the type to C_General_Int or -- C_General_Float -- Full indicates whether signed and unsigned types should be -- distinguished or not procedure Check_Value_Range (Node : Node_Id; Full : Boolean); -- checks that the value contained by value is compatible with -- the type of value_type. -- If the value and type are not compatible, raises an error procedure Check_Expr_Value (Value : Constant_Value_Ptr; Value_Type : Constant_Value_Ptr); -- CORBA V2.3 - 3.12.4 -- -- "Each String_literal is an arbitrary long sequence of -- alphabetic, digit, period ("."), underscore ("_") and -- asterisk ("*") characters. The first character of the string -- must be an alphabetic character. An asterisk may only be -- used at the last character of the string. " -- -- This procedure raises an error if S does not respect these -- constraints. procedure Check_Context_String (S : String); --------------------------------- -- evaluation of expressions -- --------------------------------- -- or operator between two Idl_Integer function "or" (X, Y : Idl_Integer) return Idl_Integer; -- xor operator between two Idl_Integer function "xor" (X, Y : Idl_Integer) return Idl_Integer; -- and operator between two Idl_Integer function "and" (X, Y : Idl_Integer) return Idl_Integer; -- << operator between an Idl_Integer and a natural function Shift_Left (X : Idl_Integer; Y : Natural) return Idl_Integer; -- >> operator between an Idl_Integer and a natural function Shift_Right (X : Idl_Integer; Y : Natural) return Idl_Integer; -- computes the maximum of two idl_integer function Max (X, Y : Idl_Integer) return Idl_Integer; -- addition of two fixed integer : -- R is the result -- Left and right are the operands procedure Fixed_Add (Res, Left, Right : Constant_Value_Ptr); -- subtraction of two fixed integer : -- R is the result -- Left and right are the operands procedure Fixed_Sub (Res, Left, Right : Constant_Value_Ptr); -- multiplication of two fixed integer : -- R is the result -- Left and right are the operands procedure Fixed_Mul (Res, Left, Right : Constant_Value_Ptr); -- division of two fixed integer : -- R is the result -- Left and right are the operands procedure Fixed_Div (Res, Left, Right : Constant_Value_Ptr); -- identity for a fixed integer : -- R is the result -- operand is the operand procedure Fixed_Id (Res, Operand : Constant_Value_Ptr); -- negation of a fixed integer : -- R is the result -- operand is the operand procedure Fixed_Neg (Res, Operand : Constant_Value_Ptr); -- bitwise negation of a fixed integer function "not" (X : Idl_Integer) return Idl_Integer; -------------------- -- Error recovery -- -------------------- -- These procedures are called when the parser encounters an error, and -- attempt to skip to a suitable recovery point. -- Goes to the beginning of the next definition. procedure Go_To_Next_Definition; -- Goes to the end of the export definition. procedure Go_To_End_Of_Export; -- Goes to the next Cbracket opening. procedure Go_To_Next_Left_Cbracket; -- Goes to the next Cbracket closing; procedure Go_To_Next_Right_Cbracket; -- Goes to the next export (see rule 9) procedure Go_To_Next_Export; -- Goes to the next value_element (see rule 21) procedure Go_To_Next_Value_Element; -- Goes to the end of a state member declaration (see rule 22) procedure Go_To_End_Of_State_Member; -- Goes to the next right parenthesis. procedure Go_To_Next_Right_Paren; -- Goes to the next member (see rule 71) procedure Go_To_Next_Member; -- Goes to the end of a case clause in an union (see rule 74) procedure Go_To_End_Of_Case; -- Goes to the end of a case label in an union (see rule 75) procedure Go_To_End_Of_Case_Label; -- Goes to the end of a scoped name (see rule 12) procedure Go_To_End_Of_Scoped_Name; -- Goes to the next T_End_Pragma token and consumes it procedure Go_To_End_Of_Pragma; -- Goes to the end of an enumeration procedure Go_To_End_Of_Enumeration; -- Goes to the next ';' and consumes it procedure Go_To_Next_Semi_Colon; -- Goes to the next '>' and consumes it procedure Go_To_Next_Greater; end Idl_Fe.Parser; polyorb-2.8~20110207.orig/compilers/idlac/idlac_flags.ads0000644000175000017500000000512111750740337022401 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- I D L A C _ F L A G S -- -- -- -- S p e c -- -- -- -- Copyright (C) 2001-2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ package Idlac_Flags is pragma Preelaborate; type Encoding is (ISO_Latin_1, UTF_8); Generate_Server_Code : Boolean := False; Generate_Client_Code : Boolean := False; Generate_Impl_Template : Boolean := False; Keep_Temporary_Files : Boolean := False; Preprocess_Only : Boolean := False; To_Stdout : Boolean := False; Verbose : Boolean := False; Generate_Delegate : Boolean := False; Generate_IR : Boolean := False; Character_Encoding : Encoding := ISO_Latin_1; end Idlac_Flags; polyorb-2.8~20110207.orig/compilers/idlac/ir_code_gen0000644000175000017500000000065711750740337021651 0ustar xavierxavierDesign notes for the Interface Repository Infor code generator -------------------------------------------------------------- $Id$ For each scope we generate a new package: Foo.IR_Info that contains a function returning an IRObject reference for each entity in the scope (caching previous results if available). This is generated as a separate package so that applications that do not need the IR need not depend on it at all. polyorb-2.8~20110207.orig/compilers/idlac/ada_be-idl2ada-impl.adb0000644000175000017500000001056511750740337023570 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- A D A _ B E . I D L 2 A D A . I M P L -- -- -- -- B o d y -- -- -- -- Copyright (C) 2001-2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with Idl_Fe.Tree; use Idl_Fe.Tree; with Ada_Be.Identifiers; use Ada_Be.Identifiers; package body Ada_Be.Idl2Ada.Impl is procedure Gen_Node_Spec (CU : in out Compilation_Unit; Node : Node_Id; Is_Delegate : Boolean := False) is begin case Kind (Node) is ---------------- -- Operations -- ---------------- when K_Operation => if Is_Delegate then Gen_Operation_Profile (CU, Node, "access Wrapped", Is_Delegate => True); PL (CU, ";"); elsif not Is_Implicit_Inherited (Node) then Gen_Operation_Profile (CU, Node, "not null access Object"); PL (CU, ";"); end if; when others => null; end case; end Gen_Node_Spec; procedure Gen_Node_Body (CU : in out Compilation_Unit; Node : Node_Id) is begin case Kind (Node) is ---------------- -- Operations -- ---------------- when K_Operation => -- Implicitly inherited operation are not overridden by default if Is_Implicit_Inherited (Node) then return; end if; declare Is_Function : constant Boolean := Kind (Operation_Type (Node)) /= K_Void; begin NL (CU); Gen_Operation_Profile (CU, Node, "not null access Object"); if Is_Function then NL (CU); PL (CU, "is"); II (CU); PL (CU, "Result : " & Ada_Type_Name (Operation_Type (Node)) & ";"); DI (CU); else PL (CU, " is"); end if; PL (CU, "begin"); II (CU); NL (CU); PL (CU, "-- Insert implementation of " & Ada_Name (Node)); NL (CU); if Is_Function then PL (CU, "return Result;"); else PL (CU, "null;"); end if; DI (CU); PL (CU, "end " & Ada_Operation_Name (Node) & ";"); end; when others => null; end case; end Gen_Node_Body; end Ada_Be.Idl2Ada.Impl; polyorb-2.8~20110207.orig/compilers/idlac/ada_be.ads0000644000175000017500000000406511750740337021352 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- A D A _ B E -- -- -- -- S p e c -- -- -- -- Copyright (C) 2001 Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by ACT Europe. -- -- (email: sales@act-europe.fr) -- -- -- ------------------------------------------------------------------------------ package Ada_Be is pragma Pure; end Ada_Be; polyorb-2.8~20110207.orig/compilers/idlac/idl_fe-types.ads0000644000175000017500000005645611750740337022556 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- I D L _ F E . T Y P E S -- -- -- -- S p e c -- -- -- -- Copyright (C) 2001-2008, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- Base types for the IDL front-end (standard version). with Ada.Unchecked_Deallocation; with Interfaces; with Idlac_Errors; package Idl_Fe.Types is ----------------------------- -- Simple type definitions -- ----------------------------- type Node_Id is new Integer; No_Node : constant Node_Id := 0; function No (N : Node_Id) return Boolean; -- True when N is No_Node function Present (N : Node_Id) return Boolean; -- True when N is not No_Node -- used for the identifiers type String_Cacc is access constant String; -- Identifiers are numbered, in order to make comparaison -- easier and static. Each number is unique. type Uniq_Id is new Natural; Nil_Uniq_Id : constant Uniq_Id := 0; type Param_Mode is (Mode_In, Mode_Inout, Mode_Out); -- To manipulate the location of a node subtype Location is Idlac_Errors.Location; procedure Set_Location (N : Node_Id; Loc : Location); function Get_Location (N : Node_Id) return Location; -- Version types for repository_ids type Version_Type is record Major : Interfaces.Unsigned_16; Minor : Interfaces.Unsigned_16; end record; function Image (V : Version_Type) return String; ---------------------------------- -- Management of const values -- ---------------------------------- -- all the possible kind of constants -- These types are used in the evaluation of constants to check -- that each subexpression of an expression does not exceed the -- precision of the final expression. In this context, there's -- no use to distinguish signed and unsigned integers (see CORBA -- V2.3 - 3.9.2), so C_Short for example could be a short or an -- unsigned short. -- In case a subexpression exceeds its supposed precision, the -- types C_general_... can be used to avoid further precision -- checking. type Const_Kind is (C_Short, C_Long, C_LongLong, C_UShort, C_ULong, C_ULongLong, C_Char, C_WChar, C_Boolean, C_Float, C_Double, C_LongDouble, C_Fixed, C_String, C_WString, C_Octet, C_Enum, C_No_Kind, C_General_Integer, C_General_Float, C_General_Fixed); -- Idl types. -- No distinction between intergers or floats here, the same -- type will be used for a short and a long long or for a float -- and a long double. However, the value will be checked and -- correspond to the type of the constant subtype Idl_Integer is Long_Long_Integer; type Idl_String is access String; type Idl_Wide_String is access Wide_String; subtype Idl_Character is Character; subtype Idl_Wide_Character is Wide_Character; subtype Idl_Float is Long_Long_Float; subtype Idl_Boolean is Boolean; -- To deallocate Idl strings procedure Free_Idl_String is new Ada.Unchecked_Deallocation (String, Idl_String); procedure Free_Idl_Wide_String is new Ada.Unchecked_Deallocation (Wide_String, Idl_Wide_String); -- These are the limits for each Idl type. -- This time, the different integer types are distinguished Idl_Octet_Min : constant Idl_Integer := 0; Idl_Octet_Max : constant Idl_Integer := (2 ** 8) - 1; Idl_Short_Min : constant Idl_Integer := (-2 ** 15); Idl_Short_Max : constant Idl_Integer := (2 ** 15) - 1; Idl_Long_Min : constant Idl_Integer := (-2 ** 31); Idl_Long_Max : constant Idl_Integer := (2 ** 31) - 1; Idl_LongLong_Min : constant Idl_Integer := (-2 ** 63); Idl_LongLong_Max : constant Idl_Integer := (2 ** 63) - 1; Idl_UShort_Min : constant Idl_Integer := 0; Idl_UShort_Max : constant Idl_Integer := (2 ** 16) - 1; Idl_ULong_Min : constant Idl_Integer := 0; Idl_ULong_Max : constant Idl_Integer := (2 ** 32) - 1; Idl_ULongLong_Min : constant Idl_Integer := 0; Idl_ULongLong_Max : constant Idl_Integer := Idl_ULong_Max ; -- (2 ** 64) - 1; ??? Idl_Float_Min : constant Idl_Float := Long_Long_Float (Float'First); Idl_Float_Max : constant Idl_Float := Long_Long_Float (Float'Last); Idl_Double_Min : constant Idl_Float := Long_Long_Float (Long_Float'First); Idl_Double_Max : constant Idl_Float := Long_Long_Float (Long_Float'Last); Idl_Long_Double_Min : constant Idl_Float := Long_Long_Float'First; Idl_Long_Double_Max : constant Idl_Float := Long_Long_Float'Last; Idl_Enum_Max : constant Long_Long_Integer := (2 ** 32) - 1; -- definition of a constant, depending on its kind -- This type is also used to specify a constant type type Constant_Value (Kind : Const_Kind) is record case Kind is when C_Octet | C_Short | C_Long | C_LongLong | C_UShort | C_ULong | C_ULongLong | C_General_Integer => Integer_Value : Idl_Integer; when C_Char => Char_Value : Idl_Character; when C_WChar => WChar_Value : Idl_Wide_Character; when C_Boolean => Boolean_Value : Idl_Boolean; when C_Float | C_Double | C_LongDouble | C_General_Float => Float_Value : Idl_Float; when C_String => String_Length : Idl_Integer; String_Value : Idl_String; when C_WString => WString_Length : Idl_Integer; WString_Value : Idl_Wide_String; when C_Fixed | C_General_Fixed => Fixed_Value : Idl_Integer; Digits_Nb : Idl_Integer; Scale : Idl_Integer; when C_Enum => Enum_Name : Node_Id; Enum_Value : Node_Id; when C_No_Kind => null; end case; end record; type Constant_Value_Ptr is access Constant_Value; -- to duplicate a constant_value_ptr function Duplicate (C : Constant_Value_Ptr) return Constant_Value_Ptr; -- to deallocate a constant_value_ptr procedure Free (C : in out Constant_Value_Ptr); --------------------------------- -- A useful list of root nodes -- --------------------------------- type Node_List is private; -- A list of nodes. type Node_Iterator is private; -- An iterator on a node list. -- the empty list Nil_List : constant Node_List; function Head (NL : Node_List) return Node_Id; -- Return the first node in NL. function Is_Empty (NL : Node_List) return Boolean; -- True iff NL is empty. function Length (NL : Node_List) return Natural; -- The length of a list. -- Simple way to iterate over a node_list. -- NODE_ITERATOR is a type representing an iterator, which must -- be initialiazed by INIT. -- End of list is detected by IS_END. -- Until the end of list is reached, the node can be extracted -- with GET_NODE and the iterator can be incremented with NEXT. -- Therefore, usual way to use an iterator is: -- declare -- it: node_iterator; -- node: node_id; -- begin -- init (it, rep.contents); -- while not is_end (it) loop -- get_next_node (it, node); -- ... -- end loop; -- end; procedure Init (It : out Node_Iterator; List : Node_List); function Get_Node (It : Node_Iterator) return Node_Id; -- Get the current node corresponding to It, leaving It at its current -- position in the list. procedure Next (It : in out Node_Iterator); -- Advance It to the next position in the list procedure Get_Next_Node (It : in out Node_Iterator; Node : out Node_Id); -- Get the current node corresponding to It, and avande It to the next -- position in the list. function Is_End (It : Node_Iterator) return Boolean; -- Indicates when It has been advanced to the next position after the -- last node. procedure Append_Node (List : in out Node_List; Node : Node_Id); -- Append a node at the end of a list function Append_Node (List : Node_List; Node : Node_Id) return Node_List; -- Appends a node at the end of a list, and return the list. procedure Remove_Node (List : in out Node_List; Node : Node_Id); function Remove_Node (List : Node_List; Node : Node_Id) return Node_List; -- Remove the first occurrence of Node from List procedure Insert_Before (List : in out Node_List; Node : Node_Id; Before : Node_Id); -- Insert Node into List immediately before the first occurrence of Before procedure Insert_After (List : Node_List; Node : Node_Id; After : Node_Id); -- Insert Node into List immediately after the first occurrence of After function Is_In_List (List : Node_List; Node : Node_Id) return Boolean; -- Test whether node is in list function Is_In_Pointed_List (List : Node_List; Node : Node_Id) return Boolean; -- Look whether the entity denoted by scoped name Node is also denoted -- by an element of List (which must be scoped names as well). procedure Free (List : in out Node_List); -- Deallocate List function Simplify_Node_List (In_List : Node_List) return Node_List; -- Function that take a node list and remove all the redundant items -- returns the resulting node list -- useful for the inheritance treatement procedure Merge_List (Into : in out Node_List; From : Node_List); -- Appends all nodes of list From to list Into, unless they are already -- there. ---------------------------------------- -- Type of an identifier definition -- ---------------------------------------- -- An identifier definition contains the following : -- - the name of the identifier -- - the uniq_id of the identifier -- - the node in which it was defined -- - the previous definition of the same identifier (if overloaded) -- - a pointer on the parent scope of the node type Identifier_Definition; type Identifier_Definition_Acc is access Identifier_Definition; type Identifier_Definition is record Name : String_Cacc := null; Id : Uniq_Id; Node : Node_Id; Previous_Definition : Identifier_Definition_Acc; Parent_Scope : Node_Id; end record; -- Definition of a list of identifier_definition type Identifier_Definition_List is private; -- Return the named node corresponding to the identifier -- definition. -- Raises fatal_error if Cell is a null pointer function Get_Node (Definition : Identifier_Definition_Acc) return Node_Id; ---------------------- -- scope handling -- ---------------------- -- Scopes are stacked and create an identifier space. -- In a scope, an identifier has at most one meaning. function Get_Root_Scope return Node_Id; function Get_Current_Scope return Node_Id; -- Get the root (the oldest) and current (the newest) scope. function Get_Current_Gen_Scope return Node_Id; -- Return the current repository, idl file, module, -- interface or valuetype. function Get_Previous_Scope return Node_Id; -- Get the scope of the current scope procedure Push_Scope (Scope : Node_Id); -- Create a new scope, defined by a Scope node, add it in -- the current scope, and activate it. procedure Pop_Scope; -- Unstack the current scope. -- In order to ensure that each forward definition of a value -- or an interface is implemented in the same scope, here are -- some methods to take forward declarations and implementations -- into account procedure Add_Int_Val_Forward (Node : Node_Id); -- To add a forward declaration in the list procedure Add_Int_Val_Definition (Node : Node_Id); -- To take an implementation into account and remove the -- corresponding forward declaration from the list. -------------------------- -- Identifiers handling -- -------------------------- function Is_Redefinable (Name : String; Loc : Idlac_Errors.Location; Scope : Node_Id := No_Node) return Boolean; -- Check if the name is redefinable in Scope or in the current scope -- (default). If result is false, means that Find_Identifier_Definition -- has a NOT NULL result! -- Loc is the location of the attempted redefinition. function Find_Identifier_Definition (Name : String; Loc : Idlac_Errors.Location) return Identifier_Definition_Acc; -- Find the definition associated with the usage occurence of -- identifier Name located at Loc. -- If this identifier is not defined, returns a null pointer. function Find_Identifier_Node (Name : String; Loc : Idlac_Errors.Location) return Node_Id; -- Find the node associated with the usage occurence of -- identifier Name located at Loc. -- If this identifier is not defined, returns a null pointer. procedure Redefine_Identifier (A_Definition : Identifier_Definition_Acc; Node : Node_Id); -- Change the definition (associed node) of CELL. -- only used in the case of a forward interface definition function Add_Identifier (Node : Node_Id; Name : String; Scope : Node_Id := No_Node; Is_Inheritable : Boolean := True) return Boolean; -- Creates an identifier definition for the current identifier -- and add it to scope Scope or the current scope if Scope is No_Node. -- Node is the node where the identifier is defined. If Is_Inheritable -- is False, then this identifier will not be considered when resolving -- names in scopes that inherit from this one. -- Returns true if successful, False if the identifier was -- already in this scope. function Find_Identifier_In_Storage (Scope : Node_Id; Name : String; Inheritable_Only : Boolean := False) return Identifier_Definition_Acc; -- Find the identifier definition in Scope. If Inheritable_Only, -- do not consider identifiers that were marked as not eligible -- for inheritance. -- If this identifier is not defined, returns a null pointer. function Find_Imported_Identifier_Definition (Name : String) return Identifier_Definition_Acc; -- Find the identifier definition in the imported table. -- If this identifier is not defined, returns a null pointer. procedure Add_Definition_To_Imported (Definition : Identifier_Definition_Acc; Scope : Node_Id); -- Add the imported definition to the given scope imported table. procedure Find_Identifier_In_Inheritance (Name : String; Scope : Node_Id; List : in out Node_List); -- Find the identifier in the scope's parents (in each one recursively) -- add the different definitions to the node list -- it is useful for looking in the inherited interfaces or value types ----------------------- -- Identifiers table -- ----------------------- -- Each identifier is assigned a unique id number. This number is -- its location in the table of all the identifiers definitions: -- the Id_Table. -- In order to easily find a given identifier in the Id_Table, -- a hash table is used to store the mapping of identifier names -- to unique identifiers: the Hash_Table. -- The Hash_Table retains the position in the Id_Table of the first -- identifier defined for each possible hash value. All the -- identifiers having the same hash value are then linked: each one -- has a pointer on the next defined: Next. -- dimension of the hashtable type Hash_Value_Type is mod 2**32; -- dimension of the hashtable Hash_Mod : constant Hash_Value_Type := 2053; -- The hash table of the location of the identifiers in the -- id_table type Hash_Table_Type is array (0 .. Hash_Mod - 1) of Uniq_Id; Hash_Table : Hash_Table_Type := (others => Nil_Uniq_Id); -- An entry in the ID table, containing: -- - the Identifier_Definition; -- - a flag indicating whether this entry can be incorporated -- into another (interface or valuetype) scope by inheritance -- (meant for use only during expansion); -- - a pointer to the entry correponding to the next definition -- of an identifier with the same hash value. type Hash_Entry is record Definition : Identifier_Definition_Acc := null; Is_Inheritable : Boolean := True; Next : Uniq_Id; end record; ---------------------------------- -- The Gnat_Table adapted type -- ---------------------------------- -- This section provides an implementation of dynamically resizable one -- dimensional array type.The idea is to mimic the normal Ada semantics for -- arrays as closely as possible with the one additional capability of -- dynamically modifying the value of the Last attribute. -- we are defining the type of the table type Table_Type is array (Uniq_Id range <>) of Hash_Entry; subtype Big_Table_Type is Table_Type (Nil_Uniq_Id + 1 .. Uniq_Id'Last); -- The table is actually represented as a pointer to allow reallocation type Table_Ptr is access all Big_Table_Type; -- the table type that will be instantiated type Table is record -- the table Table : Table_Ptr := null; -- Subscript of the maximum entry in the currently allocated table Max : Integer := Integer (Nil_Uniq_Id); -- Number of entries in currently allocated table. The value of zero -- ensures that we initially allocate the table. Length : Integer := 0; -- Current value of Last. Last_Val : Integer := Integer (Nil_Uniq_Id); end record; -- the location of the first element of the table (it is constant) First : constant Uniq_Id := Nil_Uniq_Id + 1; -- Table expansion is permitted only if this switch is set to False. A -- client may set Locked to True, in which case any attempt to expand -- the table will cause an assertion failure. Note that while a table -- is locked, its address in memory remains fixed and unchanging. Locked : Boolean := False; -- This procedure allocates a new table of size Initial (freeing any -- previously allocated larger table). It is not necessary to call -- Init when a table is first instantiated (since reallocate works -- with a null table). However, it is harmless to do so, and -- Init is convenient in reestablishing a table for new use. procedure Init (T : in out Table); -- Returns the current value of the last used entry in the table, which -- can then be used as a subscript for Table. Note that the only way to -- modify Last is to call the Set_Last procedure. Last must always be -- used to determine the logically last entry. function Last (T : Table) return Uniq_Id; -- Storage is allocated in chunks according to the values given in the -- Initial and Increment parameters. A call to Release releases all -- storage that is allocated, but is not logically part of the current -- array value. Current array values are not affected by this call. procedure Release (T : in out Table); -- This procedure sets Last to the indicated value. If necessary the -- table is reallocated to accomodate the new value (i.e. on return -- the allocated table has an upper bound of at least Last). If Set_Last -- reduces the size of the table, then logically entries are removed -- from the table. If Set_Last increases the size of the table, then -- new entries are logically added to the table. procedure Set_Last (T : in out Table; New_Val : Uniq_Id); -- Adds 1 to Last (same as Set_Last (Last + 1). procedure Increment_Last (T : in out Table); -- Subtracts 1 from Last (same as Set_Last (Last - 1). procedure Decrement_Last (T : in out Table); -- Adds Num to T.Last_val, and returns the old value of T.Last_Val + 1. procedure Allocate (T : in out Table; Num : Integer := 1; Result : out Uniq_Id); ------------------------------------------------- -- the structure used for storing identifiers -- ------------------------------------------------- type Storage is record Hash_Table : Hash_Table_Type := (others => Nil_Uniq_Id); Content_Table : Table; end record; ----------------------------------- -- dealing with Repository_Ids -- ----------------------------------- procedure Set_Default_Repository_Id (Node : Node_Id); -- Set Node's default repository id. procedure Set_Initial_Current_Prefix (Node : Node_Id); -- Set the current prefix for scope Node -- from its parent's. private ---------------------------------------- -- Type of an identifier definition -- ---------------------------------------- -- classical definition of a list for the identifier_definition_list type Identifier_Definition_Cell; type Identifier_Definition_List is access Identifier_Definition_Cell; type Identifier_Definition_Cell is record Definition : Identifier_Definition_Acc; Next : Identifier_Definition_List; end record; -- The hashing function. Takes an identifier and return its hash -- value function Hash (Str : String) return Hash_Value_Type; --------------- -- Node list -- --------------- type Node_List_Cell; type Node_List is access Node_List_Cell; type Node_List_Cell is record Car : Node_Id; Cdr : Node_List; end record; Nil_List : constant Node_List := null; type Node_Iterator is new Node_List; end Idl_Fe.Types; polyorb-2.8~20110207.orig/compilers/idlac/testgen.adb0000644000175000017500000000511111750740337021600 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- T E S T G E N -- -- -- -- B o d y -- -- -- -- Copyright (C) 2001-2005 Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with GNAT.Command_Line; with Idl_Fe.Types; with Idl_Fe.Parser; with Ada_Be.Expansion; with Ada_Be.Idl2Ada; with Ada_Be.Mappings.CORBA; procedure Testgen is The_CORBA_Mapping : Ada_Be.Mappings.CORBA.CORBA_Mapping_Type; Rep : Idl_Fe.Types.Node_Id; begin Idl_Fe.Parser.Initialize (GNAT.Command_Line.Get_Argument); Rep := Idl_Fe.Parser.Parse_Specification; Ada_Be.Expansion.Expand_Repository (Rep); Ada_Be.Idl2Ada.Generate (Use_Mapping => The_CORBA_Mapping, Node => Rep, Implement => True); Idl_Fe.Parser.Finalize; end Testgen; polyorb-2.8~20110207.orig/compilers/idlac/idlac_utils.ads0000644000175000017500000000647211750740337022457 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- U T I L S -- -- -- -- S p e c -- -- -- -- Copyright (C) 2001-2008, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- Utilities for the IDLAC compiler. with Idl_Fe.Types; use Idl_Fe.Types; with Idl_Fe.Tree; use Idl_Fe.Tree; with System; package Idlac_Utils is function Img (N : Character) return String; function Img (N : Integer) return String; function Img (N : Idl_Integer) return String; -- Return the image of an integer without the leading space function Long_Integer_Img (N : Long_Integer) return String; -- Same as above. This function cannot be named Img because this would -- conflict with the one for Idl_Integer in environments where 64-bit -- integers are not supported (eg on Apex). In such environments, -- Idl_Integer is a subtype of Long_Integer. function Img (N : Idl_Float) return String; -- Return the image of a Long_Long_Float function Img (N : Node_Id) return String; -- Return the image of a Node_Id function Img (N : Node_Kind) return String; -- Return the image of a Node_Kind function Img (B : Boolean) return String; -- Return "True" or "False", cased that way function Img (A : System.Address) return String; -- Return the image of an Address pragma Inline (Img); -- All versions of Img are covered by this pragma function Img (A : Constant_Value_Ptr) return String; -- Return the image of a constant end Idlac_Utils; polyorb-2.8~20110207.orig/compilers/idlac/ada_be-expansion.adb0000644000175000017500000022303111750740337023327 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- A D A _ B E . E X P A N S I O N -- -- -- -- B o d y -- -- -- -- Copyright (C) 2001-2008, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with Idl_Fe.Tree; use Idl_Fe.Tree; with Idl_Fe.Tree.Synthetic; use Idl_Fe.Tree.Synthetic; with Idl_Fe.Tree.Low_Level; use Idl_Fe.Tree.Low_Level; with Idl_Fe.Utils; use Idl_Fe.Utils; with Ada_Be.Identifiers; use Ada_Be.Identifiers; with Ada_Be.Debug; pragma Elaborate_All (Ada_Be.Debug); with Idlac_Errors; use Idlac_Errors; with Idlac_Utils; use Idlac_Utils; with Ada.Characters.Handling; with GNAT.HTable; package body Ada_Be.Expansion is ----------- -- Debug -- ----------- Flag : constant Natural := Ada_Be.Debug.Is_Active ("ada_be.expansion"); procedure O is new Ada_Be.Debug.Output (Flag); ------------------ -- Shared state -- ------------------ In_Sequence_Type : Boolean := False; -- Set in Expand_Sequence during expansion of the sequence type ------------------------------------ -- Internal expansion subprograms -- ------------------------------------ procedure Expand_Node (Node : Node_Id); -- Expand node according to its type (using the type-specific routines -- below). -- Specific expansion subprograms procedure Expand_Module (Node : Node_Id); procedure Expand_Ben_Idl_File (Node : Node_Id); -- Expand all subnodes procedure Expand_Interface (Node : Node_Id); -- First expand all subnodes, then copy inherited methods and attributes -- from ancestors procedure Expand_ValueType (Node : Node_Id); -- First expand all subnodes, then copy inherited methods and attributes -- from ancestors and supported interfaces procedure Expand_Boxed_ValueType (Node : Node_Id); -- Expand the type of a boxed value (sequence for example) procedure Expand_Attribute (Node : Node_Id); -- Expand an attribute into the corresponding _get_ and _set_ operations procedure Expand_State_Member (Node : Node_Id); -- Expand a State_Member : -- 1. Split it if there are several declarators; -- 2. Creates the corresponding _get_ and _set_ operations. procedure Expand_Attribute_Or_State_Member (Node : Node_Id; The_Type : Node_Id; Declarators : Node_List; Is_Readable : Boolean; Is_Writable : Boolean); -- Code factorization for the two subprograms above procedure Expand_Operation (Node : Node_Id); -- Expand each formal parameter, then replace -- the operation if it has a non-void return -- type and out formal parameters with a void -- operation having a supplementary "Returns" -- out formal parameter. procedure Expand_Param (Node : Node_Id); -- Expand Param_Type. procedure Expand_Exception (Node : Node_Id); -- Expand an exception into a _Members struct. procedure Expand_Type_Declarator (Node : Node_Id); -- Expand the denoted type. procedure Expand_Struct (Node : Node_Id); procedure Expand_Member (Node : Node_Id); -- Expand struct members: for each member, -- isolate array declarators, then expand M_Type. procedure Expand_Constant (Node : Node_Id); -- Expand the constant's type. procedure Expand_Union (Node : Node_Id); procedure Expand_Case (Node : Node_Id); -- Expand union: for each case, isolate array declarators, -- then expand Case_Type. procedure Expand_Enum (Node : Node_Id); -- Expand enum (used to handle renaming of Ada keywords) procedure Expand_Sequence (Node : Node_Id); -- Replace a Sequence node with a reference to -- a Sequence_Instance node. The Sequence Instance -- node is also inserted as a declaration in the current -- scope. procedure Expand_String (Node : Node_Id); -- Replace a bounded string or bounded wide string node -- with a reference to a Bounded_String_Instance node. procedure Expand_Fixed (Node : Node_Id); -- Expand a fixed-point node. procedure Expand_Constructed_Type (Node : Node_Id; Replacement_Node : out Node_Id); -- Expand a constructed type (enum, struct, or union) -- occurring in a type_spec. -- If the node is expanded, the type_spec must set to -- with Replacement_Node, which is a valid node id, else -- Replacement_Node is No_Node. procedure Expand_Array_Declarators (Node : Node_Id); -- Expand all the array declarators in a member. procedure Expand_Array_Declarator (Node : Node_Id); -- Expand on array declarator into a simple declarator -- whose parent member or case has a reference to -- an array typedef as type. -- Precondition: The declarator must be the only one -- in the parent member or case declarator list. -- (This precondition is guaranteed by Expand_Array_Declarators). procedure Expand_Scoped_Name (Node : Node_Id); -- If Node is a reference to an interface or valuetype -- within the current scope for which a forward declaration -- exists, then reference the forward declaration instead -- of the interface or valuetype itself. ---------------------- -- Utility routines -- ---------------------- subtype Location is Idlac_Errors.Location; Current_Position_In_List : Node_Id := No_Node; procedure Expand_Node_List (List : Node_List; Set_Current_Position : Boolean); -- Expand a whole list of nodes -- The global variable Current_Position_In_List is set -- before each node is expanded. function Sequence_Type_Name (Node : Node_Id) return String; -- The name corresponding to type Node as used -- to construct the name of an instance of -- CORBA.Sequences.Bounded or CORBA.Sequences.Unbounded. procedure Insert_Before_Current (Node : Node_Id); -- Insert node in Current_Gen_Scope immediately before -- Current_Position_In_List. function Has_Out_Formals (Node : Node_Id) return Boolean; -- True if Node (K_Operation) has "out" or "in out" formal parameters function Is_Ada_Keyword (Name : String) return Boolean; -- Check whether Name is an Ada 95 keyword procedure Recursive_Copy_Operations (Into : in out Node_List; Parent : Node_Id; From : Node_Id; Implicit_Inherited : Boolean; Directly_Supported : Boolean; Oldest_Supporting_ValueType : Node_Id; Parents_Seen : in out Node_List); -- Recursively copy all operations from K_Interface or K_ValueType node -- From and all its ancestors into Into. Ancestors are appended to the -- Parents_Seen list as they are explored, and will not be explored twice. -- The Parent_Scope for the copies is set to Parent, and the -- Is_Implicit_Inherited attribute is set to Implicit_Inherited. -- Directly_Supported and Oldest_Supporting_ValueType are valuetype -- attributes. See nodes.txt for their meaning. function Is_CORBA_PolicyList (Node : Node_Id) return Boolean; -- Return True iff Node denotes CORBA::PolicyList function Is_CORBA_IR_Entity (Node : Node_Id) return Boolean; -- Return True iff Node denotes one entity from CORBA Interface Repository. function Is_CORBA_Sequence (Node : Node_Id) return Boolean; -- Return True iff Node is a sequence type declared in the CORBA module, -- in which case its mapped type is reparented under the -- CORBA.IDL_SEQUENCES package. -- Predefined CORBA entities requiring specific processing CORBA_TypeCode_Node : Node_Id := No_Node; -- Declaration of CORBA::TypeCode -- CORBA::TypeCode interface don't have instantiated forward declaration -- package, thus we always must use full declaration node, independed -- of existence of forward declaration in used orb.idl or TypeCode.idl -- file. ----------------------- -- Subprogram bodies -- ----------------------- ----------------- -- Expand_Node -- ----------------- procedure Expand_Node (Node : Node_Id) is NK : constant Node_Kind := Kind (Node); begin if Expanded (Node) then return; end if; pragma Debug (O ("Expanding node : " & Node_Kind'Image (NK))); -- Set node expanded early to catch infinite loops as well Set_Expanded (Node, True); if Is_Named (Node) then if Is_Ada_Keyword (Name (Node)) then -- Rename nodes whose name collide with Ada -- reserved words. pragma Debug (O ("Renaming node" & Node_Id'Image (Node) & " with kind " & Node_Kind'Image (Kind (Node)) & " to IDL_" & Name (Node))); Add_Identifier_With_Renaming (Node, "IDL_" & Name (Node), Is_Inheritable => False); end if; -- Allocate a name for the node's repository ID if Kind (Node) /= K_Repository and then Kind (Node) /= K_Ben_Idl_File then declare RID_Name_Node : constant Node_Id := Make_Named (Loc (Node)); begin Set_Repository_Id_Identifier (Node, RID_Name_Node); if Is_Gen_Scope (Node) then Push_Scope (Node); Add_Identifier_With_Renaming (RID_Name_Node, "Repository_Id", Is_Inheritable => False); Pop_Scope; else Add_Identifier_With_Renaming (RID_Name_Node, Name (Node) & "_Repository_Id", Is_Inheritable => False); end if; pragma Debug (O ("Allocated RID name:" & Name (RID_Name_Node))); end; end if; end if; case (Kind (Node)) is when K_Repository => Expand_Repository (Node); when K_Module => Expand_Module (Node); when K_Interface => Expand_Interface (Node); when K_Attribute => Expand_Attribute (Node); when K_Operation => Expand_Operation (Node); when K_Exception => Expand_Exception (Node); when K_Ben_Idl_File => Expand_Ben_Idl_File (Node); when K_ValueType => Expand_ValueType (Node); when K_State_Member => Expand_State_Member (Node); when K_Type_Declarator => Expand_Type_Declarator (Node); when K_Const_Dcl => Expand_Constant (Node); when K_Struct => Expand_Struct (Node); when K_Member => Expand_Member (Node); when K_Union => Expand_Union (Node); when K_Case => Expand_Case (Node); when K_Fixed => Expand_Fixed (Node); when K_Sequence => Expand_Sequence (Node); when K_Enum => Expand_Enum (Node); when K_Param => Expand_Param (Node); when K_String | K_Wide_String => Expand_String (Node); when K_Boxed_ValueType => Expand_Boxed_ValueType (Node); when K_Scoped_Name => Expand_Scoped_Name (Node); when others => null; end case; end Expand_Node; ------------------------------------------- -- and now one procedure per node type -- ------------------------------------------- ------------------------ -- Expand_Repository -- ------------------------ Unknown_Filename : constant Idlac_Errors.String_Ptr := new String'(".idl"); procedure Expand_Repository (Node : Node_Id) is Iterator : Node_Iterator; type Header_Num is range 0 .. 1024; function Hash is new GNAT.HTable.Hash (Header_Num); function Hash (A : Idlac_Errors.String_Ptr) return Header_Num; function Hash (A : Idlac_Errors.String_Ptr) return Header_Num is begin return Hash (A.all); end Hash; function Equals (A, B : Idlac_Errors.String_Ptr) return Boolean; function Equals (A, B : Idlac_Errors.String_Ptr) return Boolean is begin return A.all = B.all; end Equals; package Idlnodes is new GNAT.HTable.Simple_HTable (Header_Num, Node_Id, No_Node, Idlac_Errors.String_Ptr, Hash, Equals); Repository_Contents : constant Node_List := Contents (Node); New_Repository_Contents : Node_List := Nil_List; Is_Unknown_File : Boolean; begin Push_Scope (Node); Init (Iterator, Repository_Contents); while not Is_End (Iterator) loop declare Current : Node_Id; Loc : Idlac_Errors.Location; Filename : Idlac_Errors.String_Ptr; Idl_File_Node : Node_Id; Success : Boolean; Has_Named_Subnodes : Boolean := False; Named_Subnodes : Node_Iterator; begin Get_Next_Node (Iterator, Current); Loc := Get_Location (Current); Filename := Loc.Filename; if Filename = null then Is_Unknown_File := True; Filename := Unknown_Filename; else Is_Unknown_File := False; end if; pragma Debug (O ("node " & Node_Kind'Image (Kind (Current)) & " in file " & Filename.all)); Idl_File_Node := Idlnodes.Get (Filename); -- if this is the first node of this file if Idl_File_Node = No_Node then -- create a new node Ben_Idl_File Idl_File_Node := Make_Ben_Idl_File (Loc); Set_Is_Unknown (Idl_File_Node, Is_Unknown_File); -- set its name -- is it correct when conflict ? if Get_Current_Scope /= Node then Pop_Scope; Push_Scope (Node); end if; declare Base_Name : constant String := Filename.all (Filename'First .. Filename'Last - 4); -- Omit ".idl" begin Success := Add_Identifier (Idl_File_Node, Base_Name & "_IDL_File"); end; pragma Assert (Success); -- add the new node to the hashtable. Idlnodes.Set (Filename, Idl_File_Node); -- add the new node to the repository. Append_Node (New_Repository_Contents, Idl_File_Node); end if; pragma Assert (Idl_File_Node /= No_Node); if Get_Current_Scope /= Idl_File_Node then -- Entering a new file. Pop_Scope; Push_Scope (Idl_File_Node); end if; Append_Node_To_Contents (Idl_File_Node, Current); if Is_Named (Current) then -- Reparent current node. if Definition (Current) /= null then Success := Add_Identifier (Current, Name (Current)); pragma Assert (Success); end if; if Is_Enum (Current) then Has_Named_Subnodes := True; Init (Named_Subnodes, Enumerators (Current)); -- Reparent all enumerators of current node. end if; -- Enable code generation for Idl_File only if its -- content is not imported to another file if Kind (Current) /= K_Forward_Interface and then Kind (Current) /= K_Forward_ValueType and then Imported (Current) then Set_Generate_Code (Idl_File_Node, False); end if; elsif Is_Type_Declarator (Current) then Has_Named_Subnodes := True; Init (Named_Subnodes, Declarators (Current)); -- Reparent all declarators of current node. end if; -- If the current node has named subnodes, reparent -- them now. if Has_Named_Subnodes then declare Dcl_Node : Node_Id; begin while not Is_End (Named_Subnodes) loop Get_Next_Node (Named_Subnodes, Dcl_Node); Success := Add_Identifier (Dcl_Node, Name (Dcl_Node)); pragma Assert (Success); end loop; end; end if; end; end loop; Set_Contents (Node, New_Repository_Contents); Pop_Scope; Expand_Node_List (Contents (Node), True); end Expand_Repository; ------------------- -- Expand_Module -- ------------------- procedure Expand_Module (Node : Node_Id) is procedure Relocate (Parent : Node_Id; Node : Node_Id); -- Reparent Node and its named subnodes to the new Parent procedure Relocate (Parent : Node_Id; Node : Node_Id) is Has_Named_Subnodes : Boolean; Named_Subnodes : Node_Iterator; Success : Boolean; begin Push_Scope (Parent); Append_Node_To_Contents (Parent, Node); if Is_Named (Node) then -- Rattach current node if Definition (Node) /= null then Success := Add_Identifier (Node, Name (Node)); pragma Assert (Success); end if; if Is_Enum (Node) then Has_Named_Subnodes := True; Init (Named_Subnodes, Enumerators (Node)); -- Attach all enumerators of the current node end if; elsif Is_Type_Declarator (Node) then Has_Named_Subnodes := True; Init (Named_Subnodes, Declarators (Node)); -- Attach all declarators of the current node end if; -- If the current node has named subnodes, rattach -- them now. if Has_Named_Subnodes then declare Dcl_Node : Node_Id; begin while not Is_End (Named_Subnodes) loop Get_Next_Node (Named_Subnodes, Dcl_Node); Success := Add_Identifier (Dcl_Node, Name (Dcl_Node)); pragma Assert (Success); end loop; end; end if; Pop_Scope; end Relocate; CORBA_IR_Root_Node : Node_Id; CORBA_Sequences_Node : Node_Id; CORBA_Policy_Node : Node_Id; Success : Boolean; begin pragma Assert (Kind (Node) = K_Module); Push_Scope (Node); if Name (Node) = "CORBA" then -- Allocate CORBA.Repository_Root node for rattachment all entities -- of the Interface Repository to it CORBA_IR_Root_Node := Make_Module (No_Location); Set_Default_Repository_Id (CORBA_IR_Root_Node); Set_Initial_Current_Prefix (CORBA_IR_Root_Node); Success := Add_Identifier (CORBA_IR_Root_Node, "Repository_Root"); pragma Assert (Success); Append_Node_To_Contents (Node, CORBA_IR_Root_Node); -- Allocate CORBA.IDL_SEQUENCES node for rattach all sequences to it CORBA_Sequences_Node := Make_Module (No_Location); Set_Default_Repository_Id (CORBA_Sequences_Node); Set_Initial_Current_Prefix (CORBA_Sequences_Node); Success := Add_Identifier (CORBA_Sequences_Node, "IDL_SEQUENCES"); pragma Assert (Success); Append_Node_To_Contents (Node, CORBA_Sequences_Node); declare CORBA_Contents : constant Node_List := Contents (Node); New_CORBA_Contents : Node_List; Iterator : Node_Iterator; Current : Node_Id; begin Init (Iterator, CORBA_Contents); while not Is_End (Iterator) loop Get_Next_Node (Iterator, Current); -- Detect and store Nodes for the CORBA entities that -- require special processing if Kind (Current) = K_Interface and then Ada_Name (Current) = "TypeCode" then CORBA_TypeCode_Node := Current; end if; if Kind (Current) = K_Interface and then Ada_Name (Current) = "Policy" then CORBA_Policy_Node := Current; end if; -- Relocate CORBA Interface Repository entities if Is_CORBA_IR_Entity (Current) then Relocate (CORBA_IR_Root_Node, Current); elsif Is_CORBA_Sequence (Current) then Relocate (CORBA_Sequences_Node, Current); elsif Is_CORBA_PolicyList (Current) then Relocate (CORBA_Policy_Node, Current); else Append_Node (New_CORBA_Contents, Current); end if; end loop; Set_Contents (Node, New_CORBA_Contents); end; end if; Expand_Node_List (Contents (Node), True); Pop_Scope; end Expand_Module; -------------------------- -- Expand_Ben_Idl_File -- -------------------------- procedure Expand_Ben_Idl_File (Node : Node_Id) is begin pragma Assert (Kind (Node) = K_Ben_Idl_File); Push_Scope (Node); Expand_Node_List (Contents (Node), True); Pop_Scope; end Expand_Ben_Idl_File; --------------------------------- -- Recursive_Copy_Operations -- --------------------------------- procedure Recursive_Copy_Operations (Into : in out Node_List; Parent : Node_Id; From : Node_Id; Implicit_Inherited : Boolean; Directly_Supported : Boolean; Oldest_Supporting_ValueType : Node_Id; Parents_Seen : in out Node_List) is Ops_It : Node_Iterator; O_Node : Node_Id; New_O_Node : Node_Id; Inh_It : Node_Iterator; I_Node : Node_Id; begin pragma Assert (False or else Kind (From) = K_Interface or else Kind (From) = K_ValueType); if Is_In_List (Parents_Seen, From) then return; end if; Init (Ops_It, Contents (From)); while not Is_End (Ops_It) loop Get_Next_Node (Ops_It, O_Node); if Kind (O_Node) = K_Operation and then From = Original_Parent_Scope (O_Node) then New_O_Node := Copy_Node (O_Node); Set_Parent_Scope (New_O_Node, Parent); Set_Is_Implicit_Inherited (New_O_Node, Implicit_Inherited); if not Implicit_Inherited then Set_Has_Non_Implicit_Inherited_Operations (Parent, True); end if; Set_Is_Directly_Supported (New_O_Node, Directly_Supported); if Oldest_Supporting_ValueType /= No_Node then Set_Oldest_Supporting_ValueType (New_O_Node, Oldest_Supporting_ValueType); end if; Append_Node (Into, New_O_Node); end if; end loop; Append_Node (Parents_Seen, From); Init (Inh_It, Parents (From)); while not Is_End (Inh_It) loop Get_Next_Node (Inh_It, I_Node); Recursive_Copy_Operations (Into, Parent, Value (I_Node), Implicit_Inherited, Directly_Supported, Oldest_Supporting_ValueType, Parents_Seen); end loop; end Recursive_Copy_Operations; ---------------------- -- Expand_Interface -- ---------------------- procedure Expand_Interface (Node : Node_Id) is Export_List : Node_List; It : Node_Iterator; I_Node : Node_Id; Parents_Seen : Node_List := Nil_List; Primary_Parent : constant Node_Id := Idl_Fe.Tree.Synthetic.Primary_Parent (Node); begin pragma Assert (Kind (Node) = K_Interface); Push_Scope (Node); Export_List := Contents (Node); Expand_Node_List (Export_List, True); -- First expand the interface's exports -- (eg, attributes are expanded into operations.) Export_List := Contents (Node); -- Expand_Node_List may have inserted new nodes -- in Contents. -- copy the operations of the primary parent if Primary_Parent /= No_Node then Recursive_Copy_Operations (Into => Export_List, Parent => Node, From => Value (Primary_Parent), Implicit_Inherited => True, Directly_Supported => False, Oldest_Supporting_ValueType => No_Node, Parents_Seen => Parents_Seen); end if; Init (It, Parents (Node)); while not Is_End (It) loop Get_Next_Node (It, I_Node); Recursive_Copy_Operations (Into => Export_List, Parent => Node, From => Value (I_Node), Implicit_Inherited => False, Directly_Supported => False, Oldest_Supporting_ValueType => No_Node, Parents_Seen => Parents_Seen); end loop; Set_Contents (Node, Export_List); Pop_Scope; end Expand_Interface; ---------------------- -- Expand_ValueType -- ---------------------- procedure Expand_ValueType (Node : Node_Id) is Export_List : Node_List; It : Node_Iterator; I_Node : Node_Id; Parents_Seen : Node_List := Nil_List; Interfaces_Seen : Node_List := Nil_List; Primary_Parent : constant Node_Id := Idl_Fe.Tree.Synthetic.Primary_Parent (Node); begin pragma Assert (Kind (Node) = K_ValueType); Push_Scope (Node); Export_List := Contents (Node); Expand_Node_List (Export_List, True); -- First expand the valuetype's exports -- (eg, attributes are expanded into operations.) Export_List := Contents (Node); -- Expand_Node_List may have inserted new nodes -- in Contents. -- Copy the operations of the primary parent if Primary_Parent /= No_Node then Recursive_Copy_Operations (Into => Export_List, Parent => Node, From => Value (Primary_Parent), Implicit_Inherited => True, Directly_Supported => False, Oldest_Supporting_ValueType => No_Node, Parents_Seen => Parents_Seen); end if; -- Copy the operations of the secondary parents Init (It, Parents (Node)); while not Is_End (It) loop Get_Next_Node (It, I_Node); Recursive_Copy_Operations (Into => Export_List, Parent => Node, From => Value (I_Node), Implicit_Inherited => False, Directly_Supported => False, Oldest_Supporting_ValueType => No_Node, Parents_Seen => Parents_Seen); end loop; -- Copy the operations of the supported interfaces Init (It, Supports (Node)); while not Is_End (It) loop Get_Next_Node (It, I_Node); Recursive_Copy_Operations (Into => Export_List, Parent => Node, From => Value (I_Node), Implicit_Inherited => False, Directly_Supported => True, Oldest_Supporting_ValueType => Node, Parents_Seen => Interfaces_Seen); end loop; Set_Contents (Node, Export_List); Pop_Scope; end Expand_ValueType; ---------------------- -- Expand_Attribute -- ---------------------- procedure Expand_Attribute (Node : Node_Id) is begin pragma Assert (Kind (Node) = K_Attribute); Expand_Node (A_Type (Node)); Expand_Attribute_Or_State_Member (Node, A_Type (Node), Declarators (Node), Is_Readable => True, Is_Writable => not Is_Readonly (Node)); end Expand_Attribute; ------------------------- -- Expand_State_Member -- ------------------------- procedure Expand_State_Member (Node : Node_Id) is Declarators : Node_List; It : Node_Iterator; Current_Decl : Node_Id; Parent_List : Node_List; begin pragma Assert (Kind (Node) = K_State_Member); Declarators := State_Declarators (Node); -- expand the type Expand_Node (State_Type (Node)); Init (It, Declarators); pragma Assert (not Is_End (It)); Get_Next_Node (It, Current_Decl); Parent_List := Contents (Parent_Scope (Current_Decl)); while not Is_End (It) loop pragma Debug (O ("Expand_State_Member:")); declare New_State_Member : constant Node_Id := Make_State_Member (Get_Location (Current_Decl)); Decls : Node_List := Nil_List; begin Get_Next_Node (It, Current_Decl); Append_Node (Decls, Current_Decl); -- create node State_Member Set_Original_Node (New_State_Member, Node); Set_State_Type (New_State_Member, State_Type (Node)); Set_Is_Public (New_State_Member, Is_Public (Node)); Set_State_Declarators (New_State_Member, Decls); Insert_After (List => Parent_List, Node => New_State_Member, After => Node); Remove_Node (Declarators, Current_Decl); Expand_Attribute_Or_State_Member (Node => New_State_Member, The_Type => State_Type (New_State_Member), Declarators => State_Declarators (New_State_Member), Is_Readable => Is_Public (New_State_Member), Is_Writable => Is_Public (New_State_Member)); end; end loop; -- and now expand the first declarator Expand_Attribute_Or_State_Member (Node => Node, The_Type => State_Type (Node), Declarators => State_Declarators (Node), Is_Readable => Is_Public (Node), Is_Writable => Is_Public (Node)); end Expand_State_Member; ---------------------------------------- -- Expand_Attribute_Or_State_Member -- ---------------------------------------- procedure Expand_Attribute_Or_State_Member (Node : Node_Id; The_Type : Node_Id; Declarators : Node_List; Is_Readable : Boolean; Is_Writable : Boolean) is Exports_List : Node_List := Nil_List; -- The exports list of the interface -- containing these attributes, wherein we insert -- _get_Attribute and _set_Attribute operations. Loc : Location; Position : Node_Id := Node; Iterator : Node_Iterator; Current_Declarator : Node_Id; begin pragma Assert (Kind (Node) = K_Attribute or else Kind (Node) = K_State_Member); Init (Iterator, Declarators); while not Is_End (Iterator) loop Get_Next_Node (Iterator, Current_Declarator); if Exports_List = Nil_List then Exports_List := Contents (Parent_Scope (Current_Declarator)); pragma Assert (Exports_List /= Nil_List); end if; pragma Debug (O ("Expanding attribute or state member " & "declarator with name : " & Ada_Name (Current_Declarator))); Loc := Get_Location (Current_Declarator); if Is_Readable then -- create the get_method declare Get_Method : constant Node_Id := Make_Operation (Loc); Success : Boolean; begin pragma Debug (O ("Creating _get_ method")); Success := Add_Identifier (Get_Method, "_get_" & Ada_Name (Current_Declarator)); pragma Assert (Success); Push_Scope (Get_Method); Set_Is_Oneway (Get_Method, False); Set_Operation_Type (Get_Method, The_Type); -- parameters Set_Parameters (Get_Method, Nil_List); if Kind (Node) = K_Attribute then if Is_Readonly (Node) then Set_Raises (Get_Method, Raises (Node)); else Set_Raises (Get_Method, Get_Raises (Node)); end if; else Set_Raises (Get_Method, Nil_List); end if; Set_Contexts (Get_Method, Nil_List); Set_Original_Node (Get_Method, Node); if Kind (Node) = K_State_Member then Set_Oldest_Supporting_ValueType (Get_Method, Parent_Scope (Current_Declarator)); end if; Insert_After (List => Exports_List, Node => Get_Method, After => Position); Position := Get_Method; Pop_Scope; end; end if; -- create the Set method if Is_Writable then declare Set_Method : constant Node_Id := Make_Operation (Loc); Void_Node : constant Node_Id := Make_Void (Loc); Success : Boolean; begin pragma Debug (O ("Creating _set_ method")); Success := Add_Identifier (Set_Method, "_set_" & Ada_Name (Current_Declarator)); pragma Assert (Success); Push_Scope (Set_Method); Set_Is_Oneway (Set_Method, False); Set_Operation_Type (Set_Method, Void_Node); -- parameters declare Param : constant Node_Id := Make_Param (Loc); Decl : constant Node_Id := Make_Declarator (Loc); Params : Node_List := Nil_List; begin -- new value parameter Set_Mode (Param, Mode_In); Set_Param_Type (Param, The_Type); Success := Add_Identifier (Decl, "To"); pragma Assert (Success); Set_Array_Bounds (Decl, Nil_List); Set_Parent (Decl, Param); Set_Declarator (Param, Decl); Append_Node (Params, Param); Set_Parameters (Set_Method, Params); end; if Kind (Node) = K_Attribute then Set_Raises (Set_Method, Set_Raises (Node)); else Set_Raises (Set_Method, Nil_List); end if; Set_Contexts (Set_Method, Nil_List); Set_Original_Node (Set_Method, Node); if Kind (Node) = K_State_Member then Set_Oldest_Supporting_ValueType (Set_Method, Parent_Scope (Current_Declarator)); end if; -- add the node to the node list Insert_After (List => Exports_List, Node => Set_Method, After => Position); Position := Set_Method; Pop_Scope; end; end if; Expand_Node (Current_Declarator); end loop; end Expand_Attribute_Or_State_Member; procedure Expand_Operation (Node : Node_Id) is Loc : constant Location := Get_Location (Node); begin Expand_Node_List (Parameters (Node), False); Expand_Node (Operation_Type (Node)); -- First expand all formals and return type. if Kind (Operation_Type (Node)) /= K_Void and then Has_Out_Formals (Node) then declare Operation_Type_Node : Node_Id := Operation_Type (Node); Void_Node : Node_Id := Make_Void (Loc); Param_Node : constant Node_Id := Make_Param (Loc); Decl_Node : constant Node_Id := Make_Declarator (Loc); Success : Boolean; begin -- Create an identifier in the operation's scope Push_Scope (Node); Success := Add_Identifier (Decl_Node, "Returns"); pragma Assert (Success); Pop_Scope; -- Make the operation void. The actual operation type can be -- retrieved from the Void_Node's Original_Node attribute. Replace_Node (Operation_Type_Node, Void_Node); -- Create a new parameter node Set_Mode (Param_Node, Mode_Out); Set_Param_Type (Param_Node, Operation_Type_Node); Set_Declarator (Param_Node, Decl_Node); Set_Is_Returns (Param_Node, True); Set_Parent (Decl_Node, Param_Node); -- Insert it in the operation parameter list Set_Parameters (Node, Append_Node (Parameters (Node), Param_Node)); end; end if; -- If this operation is defined in a valuetype, set its -- "Oldest_Supporting_ValueType" attribute if Kind (Parent_Scope (Node)) = K_ValueType then Set_Oldest_Supporting_ValueType (Node, Parent_Scope (Node)); end if; -- If this operation is not implicitly inherited, note it in the -- enclosing interface. if Kind (Parent_Scope (Node)) = K_Interface and then not Is_Implicit_Inherited (Node) then Set_Has_Non_Implicit_Inherited_Operations (Parent_Scope (Node), True); end if; end Expand_Operation; procedure Expand_Param (Node : Node_Id) is begin Expand_Node (Param_Type (Node)); Expand_Node (Declarator (Node)); end Expand_Param; procedure Expand_Exception (Node : Node_Id) is Loc : constant Location := Get_Location (Node); begin pragma Assert (Kind (Node) = K_Exception); declare Members_Struct : constant Node_Id := Make_Struct (Loc); Enclosing_Scope : constant Node_Id := Parent_Scope (Node); Enclosing_List : Node_List := Contents (Enclosing_Scope); Success : Boolean; begin pragma Debug (O ("Expand_Exception: " & Ada_Name (Node))); Success := Add_Identifier (Members_Struct, Ada_Name (Node) & "_Members"); pragma Assert (Success); Set_Default_Repository_Id (Members_Struct); Set_Initial_Current_Prefix (Members_Struct); Set_Members (Members_Struct, Members (Node)); Set_Is_Exception_Members (Members_Struct, True); Set_Members_Type (Node, Members_Struct); -- Members_Struct must be expanded as though it was -- encountered during the traversal of the Enclosing_List, -- for the necessary ancillary types (arrays, sequences...) -- to be declared correctly before it. We thus need to -- insert it at the proper position, and then temporarily -- fake Current_Position_In_List. Insert_Before (List => Enclosing_List, Node => Members_Struct, Before => Node); Set_Contents (Enclosing_Scope, Enclosing_List); pragma Assert (Current_Position_In_List = Node); -- If this were not the case we would need to save -- Current_Position_In_List in a temporary variable -- so we can restore it after expanding Member_Struct. Current_Position_In_List := Members_Struct; Expand_Node (Members_Struct); Current_Position_In_List := Node; end; end Expand_Exception; ---------------------------- -- Expand_Type_Declarator -- ---------------------------- procedure Expand_Type_Declarator (Node : Node_Id) is R_Node : Node_Id; begin Expand_Constructed_Type (T_Type (Node), R_Node); if R_Node /= No_Node then Set_T_Type (Node, R_Node); end if; Expand_Node (T_Type (Node)); Expand_Node_List (Declarators (Node), False); end Expand_Type_Declarator; procedure Expand_Struct (Node : Node_Id) is begin Push_Scope (Node); Expand_Node_List (Members (Node), False); Pop_Scope; end Expand_Struct; procedure Expand_Member (Node : Node_Id) is R_Node : Node_Id; begin Expand_Constructed_Type (M_Type (Node), R_Node); if R_Node /= No_Node then Set_M_Type (Node, R_Node); end if; Expand_Node (M_Type (Node)); Expand_Array_Declarators (Node); Expand_Node_List (Decl (Node), False); end Expand_Member; procedure Expand_Constant (Node : Node_Id) is begin Expand_Node (Constant_Type (Node)); end Expand_Constant; procedure Expand_Union (Node : Node_Id) is R_Node : Node_Id; begin Push_Scope (Node); Expand_Constructed_Type (Switch_Type (Node), R_Node); if R_Node /= No_Node then Set_Switch_Type (Node, R_Node); end if; Expand_Node_List (Cases (Node), False); Pop_Scope; end Expand_Union; procedure Expand_Case (Node : Node_Id) is R_Node : Node_Id; begin Expand_Constructed_Type (Case_Type (Node), R_Node); if R_Node /= No_Node then Set_Case_Type (Node, R_Node); end if; Expand_Node (Case_Type (Node)); Expand_Array_Declarator (Case_Decl (Node)); Expand_Node (Case_Decl (Node)); end Expand_Case; procedure Expand_Enum (Node : Node_Id) is begin Expand_Node_List (Enumerators (Node), False); end Expand_Enum; ----------------------- -- Expand_Sequence -- ----------------------- procedure Expand_Sequence (Node : Node_Id) is Loc : constant Location := Get_Location (Node); Sequence_Node : Node_Id := Node; Seq_Ref_Node : Node_Id := Make_Scoped_Name (Loc); Seq_Inst_Node : constant Node_Id := Make_Sequence_Instance (Loc); Prev_In_Sequence_Type : constant Boolean := In_Sequence_Type; begin In_Sequence_Type := True; Expand_Node (Sequence_Type (Node)); In_Sequence_Type := Prev_In_Sequence_Type; Add_Identifier_With_Renaming (Seq_Inst_Node, "IDL_" & Sequence_Type_Name (Node), Get_Current_Gen_Scope); -- FIXME: If the identifier is not available -- in the current gen scope, that may mean that the -- correct sequence type has already been created. -- If it is the case, maybe we should reuse it. Insert_Before_Current (Seq_Inst_Node); Set_Value (Seq_Ref_Node, Seq_Inst_Node); Replace_Node (Sequence_Node, Seq_Ref_Node); Set_Sequence (Seq_Inst_Node, Sequence_Node); end Expand_Sequence; Prefix : constant array (Boolean) of String_Cacc := (False => new String'("Bounded_String"), True => new String'("Bounded_Wide_String")); procedure Expand_String (Node : Node_Id) is Loc : constant Location := Get_Location (Node); begin if Bound (Node) = No_Node then -- This string is not bounded. return; end if; declare Is_Wide_String : constant Boolean := Kind (Node) = K_Wide_String; String_Node : Node_Id := Node; String_Inst_Node : constant Node_Id := Make_String_Instance (Loc); String_Ref_Node : Node_Id := Make_Scoped_Name (Loc); begin Add_Identifier_With_Renaming (String_Inst_Node, Prefix (Is_Wide_String).all & "_" & Img (Integer_Value (Bound (Node)))); Set_Is_Wide (String_Inst_Node, Is_Wide_String); Set_Bound (String_Inst_Node, Bound (Node)); Insert_Before_Current (String_Inst_Node); Set_Value (String_Ref_Node, String_Inst_Node); Replace_Node (String_Node, String_Ref_Node); end; end Expand_String; procedure Expand_Fixed (Node : Node_Id) is Loc : constant Location := Get_Location (Node); Fixed_Node : Node_Id := Node; Fixed_Ref_Node : Node_Id := Make_Scoped_Name (Loc); Identifier : constant String := "Fixed_" & Img (Integer_Value (Digits_Nb (Node))) & "_" & Img (Integer_Value (Scale (Node))); Definition : constant Identifier_Definition_Acc := Find_Identifier_Definition (Identifier, Loc); Success : Boolean; begin pragma Assert (Kind (Node) = K_Fixed); Replace_Node (Fixed_Node, Fixed_Ref_Node); -- If the identifier already exists in the current scope, -- and resolves to denote a K_Fixed typedef, then it -- is guaranteed that it is a node created by expansion, -- and we can reuse it. if Definition = null then declare Typedef_Node : constant Node_Id := Make_Type_Declarator (Loc); Declarator_Node : constant Node_Id := Make_Declarator (Loc); begin Success := Add_Identifier (Declarator_Node, Identifier, Get_Current_Gen_Scope); pragma Assert (Success); Set_Original_Node (Declarator_Node, Fixed_Node); Set_Value (Fixed_Ref_Node, Declarator_Node); Insert_Before_Current (Typedef_Node); Set_T_Type (Typedef_Node, Fixed_Node); Set_Declarators (Typedef_Node, Append_Node (Nil_List, Declarator_Node)); Set_Parent (Declarator_Node, Typedef_Node); end; else Set_Value (Fixed_Ref_Node, Definition.Node); end if; end Expand_Fixed; ------------------------------ -- Expand_Boxed_ValueType -- ------------------------------ procedure Expand_Boxed_ValueType (Node : Node_Id) is begin Expand_Node (Boxed_Type (Node)); end Expand_Boxed_ValueType; ------------------------------- -- Expand_Constructed_Type -- ------------------------------- procedure Expand_Constructed_Type (Node : Node_Id; Replacement_Node : out Node_Id) is Loc : constant Location := Get_Location (Node); NK : constant Node_Kind := Kind (Node); begin Replacement_Node := No_Node; if not (False or else NK = K_Enum or else NK = K_Union or else NK = K_Struct) then return; end if; Expand_Node (Node); pragma Debug (O ("Expand_Constructed_Type: enter")); declare Current_Gen_Scope : constant Node_Id := Get_Current_Gen_Scope; Constr_Type_Ref_Node : constant Node_Id := Make_Scoped_Name (Loc); begin Insert_Before_Current (Node); -- Pull up the constructed type node into a declaration -- by itself. if Parent_Scope (Node) /= Current_Gen_Scope then Add_Identifier_With_Renaming (Node, Name (Node), Current_Gen_Scope); if Kind (Node) = K_Enum then -- Also reparent all enumerators declare It : Node_Iterator; E_Node : Node_Id; begin Init (It, Enumerators (Node)); while not Is_End (It) loop Get_Next_Node (It, E_Node); Add_Identifier_With_Renaming (E_Node, Name (E_Node), Current_Gen_Scope); end loop; end; end if; end if; Set_Value (Constr_Type_Ref_Node, Node); Replacement_Node := Constr_Type_Ref_Node; end; end Expand_Constructed_Type; procedure Expand_Array_Declarators (Node : Node_Id) is It : Node_Iterator; D_Node : Node_Id; Position : Node_Id := Node; First : Boolean := True; begin pragma Assert (Kind (Node) = K_Member); pragma Debug (O ("Expand_Array_Declarators : enter")); Init (It, Decl (Node)); while not Is_End (It) loop Get_Next_Node (It, D_Node); if Kind (D_Node) /= K_Declarator then Error ("Unexpected " & Node_Kind'Image (Kind (D_Node)), Fatal, Get_Location (D_Node)); end if; if not Is_Empty (Array_Bounds (D_Node)) then if not (First and then Is_End (It)) then declare New_Node : constant Node_Id := Copy_Node (Node); begin Set_Decl (Node, Remove_Node (Decl (Node), D_Node)); Set_Decl (New_Node, Append_Node (Nil_List, D_Node)); Set_Parent (D_Node, New_Node); Insert_After (Members (Parent_Scope (D_Node)), New_Node, After => Position); Expand_Array_Declarator (D_Node); Expand_Node_List (Decl (New_Node), False); -- The new member would not be processed by -- Expand_Struct, because the iterator in that -- procedure is already pointing to the next one. -- Also note that Expand_Member should not be -- called on New_Node, because the M_Type -- has already been expanded; only the declarators -- of New_Node have not been expanded yet. Position := New_Node; end; else Expand_Array_Declarator (D_Node); end if; end if; First := False; end loop; pragma Debug (O ("Expand_Array_Declarators : leave")); end Expand_Array_Declarators; procedure Expand_Array_Declarator (Node : Node_Id) is Loc : constant Location := Get_Location (Node); begin if Is_Empty (Array_Bounds (Node)) then return; end if; declare Parent_Node : constant Node_Id := Parent (Node); Array_Node : constant Node_Id := Make_Declarator (Loc); Array_Type_Node : constant Node_Id := Make_Type_Declarator (Loc); Array_Ref_Node : constant Node_Id := Make_Scoped_Name (Loc); Element_Type_Node : Node_Id; Success : Boolean; begin pragma Debug (O ("Expand_Array_Declarator: enter")); case Kind (Parent_Node) is when K_Member => Element_Type_Node := M_Type (Parent_Node); when K_Case => Element_Type_Node := Case_Type (Parent_Node); when others => pragma Assert (False); null; end case; Set_Original_Node (Array_Node, Node); Set_Original_Node (Array_Ref_Node, Element_Type_Node); Set_Original_Node (Array_Type_Node, Element_Type_Node); Set_Value (Array_Ref_Node, Array_Node); case Kind (Parent_Node) is when K_Member => Set_M_Type (Parent_Node, Array_Ref_Node); when K_Case => Set_Case_Type (Parent_Node, Array_Ref_Node); when others => pragma Assert (False); null; end case; Set_T_Type (Array_Type_Node, Element_Type_Node); Set_Declarators (Array_Type_Node, Append_Node (Nil_List, Array_Node)); Set_Parent (Array_Node, Array_Type_Node); pragma Debug (O ("Expand_Array_Declarator : " & "about to call add_identifier")); Success := Add_Identifier (Array_Node, Name (Node) & "_Array", Get_Current_Gen_Scope); pragma Assert (Success); pragma Debug (O ("Expand_Array_Declarator : " & "add_identifier successfully called")); Insert_Before_Current (Array_Type_Node); Set_Array_Bounds (Array_Node, Array_Bounds (Node)); Set_Array_Bounds (Node, Nil_List); end; end Expand_Array_Declarator; ----------------------- -- Expand_Scope_Name -- ----------------------- procedure Expand_Scoped_Name (Node : Node_Id) is V : constant Node_Id := Value (Node); V_Scope : Node_Id; This_Gen_Scope : constant Node_Id := Get_Current_Gen_Scope; Forward_Declaration : Node_Id; function Create_Forward_Declaration (Node : Node_Id) return Node_Id; -- Create forward decalaration node for specified declaration -------------------------------- -- Create_Forward_Declaration -- -------------------------------- function Create_Forward_Declaration (Node : Node_Id) return Node_Id is Result : Node_Id; begin pragma Assert (Kind (Node) = K_Interface); Result := Make_Forward_Interface (No_Location); Set_Abst (Result, Abst (Node)); Set_Local (Result, Local (Node)); Set_Forward (Result, Node); Set_Repository_Id (Result, Repository_Id (Node)); Set_Forward (Node, Result); return Result; end Create_Forward_Declaration; begin -- Special processing of CORBA::TypeCode: we always refer to -- the full interface declaration if V = CORBA_TypeCode_Node then return; elsif Kind (V) = K_Forward_Interface and then Forward (V) = CORBA_TypeCode_Node then Set_Value (Node, Forward (V)); return; elsif Kind (V) /= K_Interface and then Kind (V) /= K_ValueType then return; end if; -- Check whether the value of this scoped name is within a child -- scope of the current scope. V_Scope := Parent_Scope (V); loop exit when V_Scope = No_Node or else V_Scope = This_Gen_Scope; V_Scope := Parent_Scope (V_Scope); end loop; if (Kind (This_Gen_Scope) = K_Interface and then Has_Interface_Component (V, This_Gen_Scope) and then In_Sequence_Type) or else V_Scope = This_Gen_Scope then -- If the value of this scoped name is within a child scope of -- the current scope, a forward declaration is necessary. Also, -- if the value of this scoped name denotes the current interface, -- or has a component whose type is the current interface, a -- forward declaration is necessary if it is used as the item type -- for a sequence, because the instantiation of the sequences -- generic would otherwise cause freezing. Forward_Declaration := Forward (V); if Forward_Declaration = No_Node then -- If there is no explicit forward declaration, create one to -- avoid a circular dependency between Ada units, and insert -- it immediately before the complete interface declaration. Forward_Declaration := Create_Forward_Declaration (V); declare Enclosing_Scope : constant Node_Id := Parent_Scope (V); Enclosing_List : Node_List := Contents (Enclosing_Scope); begin Insert_Before (List => Enclosing_List, Node => Forward_Declaration, Before => V); Set_Contents (Enclosing_Scope, Enclosing_List); end; end if; -- Now we are assured that a forward declaration exists: fix up -- the scoped name to denote the forward instead of the complete -- declaration. Set_Value (Node, Forward_Declaration); end if; end Expand_Scoped_Name; ----------------------- -- Private utilities -- ----------------------- -------------------- -- Is_Ada_Keyword -- -------------------- function Is_Ada_Keyword (Name : String) return Boolean is Lower : constant String := Ada.Characters.Handling.To_Lower (Name); begin return Lower = "abort" or else Lower = "abs" or else Lower = "abstract" or else Lower = "accept" or else Lower = "access" or else Lower = "aliased" or else Lower = "all" or else Lower = "and" or else Lower = "array" or else Lower = "at" or else Lower = "begin" or else Lower = "body" or else Lower = "case" or else Lower = "constant" or else Lower = "declare" or else Lower = "delay" or else Lower = "delta" or else Lower = "digits" or else Lower = "do" or else Lower = "else" or else Lower = "elsif" or else Lower = "end" or else Lower = "entry" or else Lower = "exception" or else Lower = "exit" or else Lower = "for" or else Lower = "function" or else Lower = "generic" or else Lower = "goto" or else Lower = "if" or else Lower = "in" or else Lower = "is" or else Lower = "limited" or else Lower = "loop" or else Lower = "mod" or else Lower = "new" or else Lower = "not" or else Lower = "null" or else Lower = "of" or else Lower = "or" or else Lower = "others" or else Lower = "out" or else Lower = "package" or else Lower = "pragma" or else Lower = "private" or else Lower = "procedure" or else Lower = "protected" or else Lower = "raise" or else Lower = "range" or else Lower = "record" or else Lower = "rem" or else Lower = "renames" or else Lower = "requeue" or else Lower = "return" or else Lower = "reverse" or else Lower = "select" or else Lower = "separate" or else Lower = "subtype" or else Lower = "tagged" or else Lower = "task" or else Lower = "terminate" or else Lower = "then" or else Lower = "type" or else Lower = "until" or else Lower = "use" or else Lower = "when" or else Lower = "while" or else Lower = "with" or else Lower = "xor"; end Is_Ada_Keyword; ---------------------- -- Expand_Node_List -- ---------------------- procedure Expand_Node_List (List : Node_List; Set_Current_Position : Boolean) is It : Node_Iterator; Node : Node_Id; begin Init (It, List); while not Is_End (It) loop Node := Get_Node (It); if Set_Current_Position then Current_Position_In_List := Node; pragma Debug (O ("Current_Position_In_List = " & Img (Integer (Node)))); end if; Expand_Node (Node); -- Go to the next position only after Node has been expanded, -- as this expansion may have inserted new nodes in List. Next (It); end loop; if Set_Current_Position then Current_Position_In_List := No_Node; end if; end Expand_Node_List; ------------------------ -- Sequence_Type_Name -- ------------------------- function Sequence_Type_Name (Node : Node_Id) return String is NK : constant Node_Kind := Kind (Node); begin case NK is when K_Sequence => if Bound (Node) = No_Node then return "SEQUENCE_" & Sequence_Type_Name (Sequence_Type (Node)); else return "SEQUENCE_" & Img (Integer_Value (Bound (Node))) & "_" & Sequence_Type_Name (Sequence_Type (Node)); end if; when K_Scoped_Name => declare P : constant String := "CORBA_Repository_Root"; N : String := Ada_Full_Name (Value (Node)); begin for I in N'Range loop if N (I) = '.' then N (I) := '_'; end if; end loop; if N'Length > P'Length and then N (N'First .. N'First + P'Length - 1) = P then return "CORBA" & N (N'First + P'Length .. N'Last); else return N; end if; end; when K_Short => return "short"; when K_Long => return "long"; when K_Long_Long => return "long_long"; when K_Unsigned_Short => return "unsigned_short"; when K_Unsigned_Long => return "unsigned_long"; when K_Unsigned_Long_Long => return "unsigned_long_long"; when K_Char => return "char"; when K_Wide_Char => return "wide_char"; when K_Boolean => return "boolean"; when K_Float => return "float"; when K_Double => return "double"; when K_Long_Double => return "long_double"; when K_String => return "string"; when K_Wide_String => return "wide_string"; when K_Octet => return "octet"; when K_Any => return "any"; when others => -- Improper use: node N is not mapped to an Ada type. Error ("A " & Node_Kind'Image (NK) & " cannot be used in a sequence.", Fatal, Get_Location (Node)); -- Keep the compiler happy raise Program_Error; end case; end Sequence_Type_Name; --------------------------- -- Insert_Before_Current -- --------------------------- procedure Insert_Before_Current (Node : Node_Id) is Current_Gen_Scope : constant Node_Id := Get_Current_Gen_Scope; Current_Scope_Contents : Node_List; begin pragma Assert (Is_Gen_Scope (Current_Gen_Scope)); Current_Scope_Contents := Contents (Current_Gen_Scope); Insert_Before (Current_Scope_Contents, Node, Before => Current_Position_In_List); Set_Contents (Current_Gen_Scope, Current_Scope_Contents); end Insert_Before_Current; function Has_Out_Formals (Node : Node_Id) return Boolean is It : Node_Iterator; N : Node_Id; begin Init (It, Parameters (Node)); while not Is_End (It) loop Get_Next_Node (It, N); if Mode (N) = Mode_Out or else Mode (N) = Mode_Inout then return True; end if; end loop; return False; end Has_Out_Formals; ------------------------ -- Is_CORBA_IR_Entity -- ------------------------ type String_Access is access all String; -- CORBA 3.0 Interface Repository entities CORBA_IR_Names : constant array (Positive range <>) of String_Access := (new String'("CORBA.AbstractInterfaceDef"), -- interface new String'("CORBA.AbstractInterfaceDefSeq"), -- typedef/sequence new String'("CORBA.AliasDef"), -- interface new String'("CORBA.ArrayDef"), -- interface new String'("CORBA.AttrDescriptionSeq"), -- typedef/sequence new String'("CORBA.AttributeDef"), -- interface new String'("CORBA.AttributeDescription"), -- struct new String'("CORBA.AttributeMode"), -- enum new String'("CORBA.ComponentIR"), -- module new String'("CORBA.ConstantDef"), -- interface new String'("CORBA.ConstantDescription"), -- struct new String'("CORBA.Contained"), -- interface new String'("CORBA.ContainedSeq"), -- typedef/sequence new String'("CORBA.Container"), -- interface new String'("CORBA.ContextIdentifier"), -- typedef new String'("CORBA.ContextIdSeq"), -- typedef/sequence new String'("CORBA.DefinitionKind"), -- enum new String'("CORBA.EnumDef"), -- interface new String'("CORBA.EnumMemberSeq"), -- typedef/sequence new String'("CORBA.ExcDescriptionSeq"), -- typedef/sequence new String'("CORBA.ExceptionDef"), -- interface new String'("CORBA.ExceptionDefSeq"), -- typedef/sequence new String'("CORBA.ExceptionDescription"), -- struct new String'("CORBA.ExtAttrDescriptionSeq"), -- typedef/sequence new String'("CORBA.ExtAttributeDef"), -- interface new String'("CORBA.ExtAttributeDescription"), -- struct new String'("CORBA.ExtAbstractInterfaceDef"), -- interface new String'("CORBA.ExtAbstractInterfaceDefSeq"), -- typedef/sequence new String'("CORBA.ExtInterfaceDef"), -- interface new String'("CORBA.ExtInterfaceDefSeq"), -- typedef/sequence new String'("CORBA.ExtInitializer"), -- struct new String'("CORBA.ExtInitializerSeq"), -- typedef/sequence new String'("CORBA.ExtLocalInterfaceDef"), -- interface new String'("CORBA.ExtLocalInterfaceDefSeq"), -- typedef/sequence new String'("CORBA.ExtValueDef"), -- interface new String'("CORBA.ExtValueDefSeq"), -- typedef/sequence new String'("CORBA.FixedDef"), -- interface new String'("CORBA.IDLType"), -- interface new String'("CORBA.InterfaceAttrExtension"), -- interface new String'("CORBA.InterfaceDef"), -- interface new String'("CORBA.InterfaceDefSeq"), -- typedef/sequence new String'("CORBA.InterfaceDescription"), -- struct new String'("CORBA.Initializer"), -- struct new String'("CORBA.InitializerSeq"), -- typedef/sequence new String'("CORBA.IRObject"), -- interface new String'("CORBA.LocalInterfaceDef"), -- interface new String'("CORBA.LocalInterfaceDefSeq"), -- typedef/sequence new String'("CORBA.ModuleDef"), -- interface new String'("CORBA.ModuleDescription"), -- struct new String'("CORBA.NativeDef"), -- interface new String'("CORBA.OpDescriptionSeq"), -- typedef/sequence new String'("CORBA.OperationDef"), -- interface new String'("CORBA.OperationDescription"), -- struct new String'("CORBA.OperationMode"), -- enum new String'("CORBA.ParameterDescription"), -- struct new String'("CORBA.ParameterMode"), -- enum new String'("CORBA.ParDescriptionSeq"), -- typedef/sequence new String'("CORBA.PrimitiveDef"), -- interface new String'("CORBA.PrimitiveKind"), -- enum new String'("CORBA.Repository"), -- interface -- new String'("CORBA.RepositoryId"); -- typedef new String'("CORBA.RepositoryIdSeq"), -- typedef/sequence -- new String'("CORBA.ScopedName"); -- typedef new String'("CORBA.SequenceDef"), -- interface new String'("CORBA.StringDef"), -- interface new String'("CORBA.StructDef"), -- interface new String'("CORBA.StructMember"), -- struct new String'("CORBA.StructMemberSeq"), -- typedef/sequence new String'("CORBA.TypedefDef"), -- interface new String'("CORBA.TypeDescription"), -- struct new String'("CORBA.UnionDef"), -- interface new String'("CORBA.UnionMember"), -- struct new String'("CORBA.UnionMemberSeq"), -- typedef/sequence new String'("CORBA.ValueBoxDef"), -- interface new String'("CORBA.ValueDef"), -- interface new String'("CORBA.ValueDefSeq"), -- typedef/sequence new String'("CORBA.ValueDescription"), -- struct new String'("CORBA.ValueMember"), -- struct new String'("CORBA.ValueMemberSeq"), -- typedef/sequence new String'("CORBA.ValueMemberDef"), -- interface new String'("CORBA.VersionSpec"), -- typedef -- new String'("CORBA.Visibility"), -- typedef new String'("CORBA.WstringDef")); -- interface function Is_CORBA_IR_Entity (Node : Node_Id) return Boolean is NK : constant Node_Kind := Kind (Node); N : Node_Id := Node; begin if NK /= K_Interface and then NK /= K_Forward_Interface and then NK /= K_Declarator and then NK /= K_Type_Declarator and then NK /= K_Enum and then NK /= K_Struct then return False; end if; if NK = K_Type_Declarator then declare List : constant Node_List := Declarators (Node); Iter : Node_Iterator; begin Init (Iter, List); Get_Next_Node (Iter, N); end; elsif Kind (Node) = K_Forward_Interface then N := Forward (Node); end if; declare Name : constant String := Ada_Full_Name (N); begin for J in CORBA_IR_Names'Range loop if CORBA_IR_Names (J).all = Name then return True; end if; end loop; end; return False; end Is_CORBA_IR_Entity; ------------------------- -- Is_CORBA_PolicyList -- ------------------------- -- CORBA::PolicyList relocated to CORBA.Policy package CORBA_PolicyList_Names : constant array (Positive range <>) of String_Access := (1 => new String'("CORBA.PolicyList")); function Is_CORBA_PolicyList (Node : Node_Id) return Boolean is N : Node_Id; begin if Kind (Node) /= K_Type_Declarator then return False; end if; declare List : constant Node_List := Declarators (Node); Iter : Node_Iterator; begin Init (Iter, List); Get_Next_Node (Iter, N); end; declare Name : constant String := Ada_Full_Name (N); begin for J in CORBA_PolicyList_Names'Range loop if CORBA_PolicyList_Names (J).all = Name then return True; end if; end loop; end; return False; end Is_CORBA_PolicyList; ----------------------- -- Is_CORBA_Sequence -- ----------------------- -- CORBA 3.0 sequences relocated to CORBA.IDL_SEQUENCES package CORBA_Sequences_Names : constant array (Positive range <>) of String_Access := (new String'("CORBA.AnySeq"), new String'("CORBA.BooleanSeq"), new String'("CORBA.CharSeq"), new String'("CORBA.WCharSeq"), new String'("CORBA.OctetSeq"), new String'("CORBA.ShortSeq"), new String'("CORBA.UShortSeq"), new String'("CORBA.LongSeq"), new String'("CORBA.ULongSeq"), new String'("CORBA.LongLongSeq"), new String'("CORBA.ULongLongSeq"), new String'("CORBA.FloatSeq"), new String'("CORBA.DoubleSeq"), new String'("CORBA.LongDoubleSeq"), new String'("CORBA.StringSeq"), new String'("CORBA.WStringSeq")); function Is_CORBA_Sequence (Node : Node_Id) return Boolean is N : Node_Id; begin if Kind (Node) /= K_Type_Declarator then return False; end if; declare List : constant Node_List := Declarators (Node); Iter : Node_Iterator; begin Init (Iter, List); Get_Next_Node (Iter, N); end; declare Name : constant String := Ada_Full_Name (N); begin for J in CORBA_Sequences_Names'Range loop if CORBA_Sequences_Names (J).all = Name then return True; end if; end loop; end; return False; end Is_CORBA_Sequence; end Ada_Be.Expansion; polyorb-2.8~20110207.orig/compilers/idlac/ada_be-idl2ada-skel.ads0000644000175000017500000000540511750740337023603 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- A D A _ B E . I D L 2 A D A . S K E L -- -- -- -- S p e c -- -- -- -- Copyright (C) 2001-2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ private package Ada_Be.Idl2Ada.Skel is -- This package contains the code common to the skeleton and the -- delegate packages. function Suffix (Is_Delegate : Boolean) return String; procedure Gen_Node_Spec (CU : in out Compilation_Unit; Node : Node_Id; Is_Delegate : Boolean); procedure Gen_Node_Body (CU : in out Compilation_Unit; Node : Node_Id; Is_Delegate : Boolean); procedure Gen_Body_Common_End (CU : in out Compilation_Unit; Node : Node_Id; Is_Delegate : Boolean); -- generates code for skel_body that is common -- for interfaces and valuetypes supporting interfaces -- at the end of the package. end Ada_Be.Idl2Ada.Skel; polyorb-2.8~20110207.orig/compilers/idlac/ada_be-idl2ada-skel.adb0000644000175000017500000007062011750740337023563 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- A D A _ B E . I D L 2 A D A . S K E L -- -- -- -- B o d y -- -- -- -- Copyright (C) 2001-2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with Idl_Fe.Tree; use Idl_Fe.Tree; with Idl_Fe.Tree.Synthetic; use Idl_Fe.Tree.Synthetic; with Ada_Be.Identifiers; use Ada_Be.Identifiers; with Ada_Be.Idl2Ada.Impl; with Ada_Be.Idl2Ada.Helper; with Ada_Be.Idl2Ada.Value_Skel; with Ada_Be.Temporaries; use Ada_Be.Temporaries; with Ada_Be.Debug; pragma Elaborate_All (Ada_Be.Debug); package body Ada_Be.Idl2Ada.Skel is Flag : constant Natural := Ada_Be.Debug.Is_Active ("ada_be.idl2ada.skel"); procedure O is new Ada_Be.Debug.Output (Flag); pragma Warnings (Off); pragma Unreferenced (O); pragma Warnings (On); procedure Gen_Is_A (CU : in out Compilation_Unit; Node : Node_Id; Is_Delegate : Boolean); -- Generate server-side support for the Is_A operation procedure Gen_Non_Existent (CU : in out Compilation_Unit; Node : Node_Id); -- Generate server-side support for the Non_Existent operation procedure Gen_Get_Interface (CU : in out Compilation_Unit; Node : Node_Id); -- Generate server-side support for the Get_Interface operation procedure Gen_Get_Domain_Managers (CU : in out Compilation_Unit; Node : Node_Id); -- Generate server-side support for the Get_Domain_Managers operation procedure Gen_Body_Common_Start (CU : in out Compilation_Unit; Node : Node_Id; Is_Delegate : Boolean); -- generates code for skel_body that is common -- for interfaces and valuetypes supporting interfaces -- at the beginning of the package. procedure Gen_Invoke (CU : in out Compilation_Unit; Node : Node_Id); -- Generate a static dispatcher fragment for operation Node. Decls_Div : Diversion; ------------------- -- Gen_Node_Body -- ------------------- procedure Gen_Node_Body (CU : in out Compilation_Unit; Node : Node_Id; Is_Delegate : Boolean) is NK : constant Node_Kind := Kind (Node); begin case NK is when K_ValueType => pragma Assert (not Is_Delegate); if Supports (Node) /= Nil_List then Gen_Body_Common_Start (CU, Node, Is_Delegate); -- Predefined operations Gen_Is_A (CU, Node, Is_Delegate); Gen_Non_Existent (CU, Node); declare It : Node_Iterator; P_Node : Node_Id; begin Init (It, Supports (Node)); while not Is_End (It) loop Get_Next_Node (It, P_Node); Add_With (CU, Ada_Full_Name (P_Node) & Skel.Suffix (Is_Delegate), No_Warnings => True); end loop; end; end if; when K_Interface => -- No skel or impl packages are generated for abstract interfaces if not Abst (Node) then Add_With (CU, "PolyORB.CORBA_P.Exceptions"); Add_With (CU, "PortableServer", Use_It => False, Elab_Control => Elaborate_All); Gen_Body_Common_Start (CU, Node, Is_Delegate); -- Predefined operations Gen_Is_A (CU, Node, Is_Delegate); Gen_Non_Existent (CU, Node); Gen_Get_Interface (CU, Node); Gen_Get_Domain_Managers (CU, Node); end if; when K_Operation => Gen_Invoke (CU, Node); when others => null; end case; end Gen_Node_Body; -------------- -- Gen_Is_A -- -------------- procedure Gen_Is_A (CU : in out Compilation_Unit; Node : Node_Id; Is_Delegate : Boolean) is NK : constant Node_Kind := Kind (Node); begin pragma Assert ((NK = K_Interface) or else (NK = K_ValueType)); PL (CU, "if Operation = ""_is_a"" then"); II (CU); PL (CU, "declare"); II (CU); PL (CU, "Type_Id : CORBA.String;"); Divert (CU, Decls_Div); NL (CU); PL (CU, "Is_A" & T_Arg_Name & "Type_Id :" & " constant CORBA.Identifier"); PL (CU, ":= CORBA.To_CORBA_String (""Type_Id"");"); Divert (CU, Operation_Body); PL (CU, T_Arg_Any & "Type_Id : constant CORBA.Any := CORBA.To_Any (Type_Id);"); PL (CU, ""); PL (CU, T_Result & " : CORBA.Boolean;"); DI (CU); PL (CU, "begin"); II (CU); PL (CU, "CORBA.NVList.Add_Item"); PL (CU, "(" & T_Arg_List & ","); PL (CU, "Is_A" & T_Arg_Name & "Type_Id,"); PL (CU, T_Arg_Any & "Type_Id,"); PL (CU, "CORBA.ARG_IN);"); NL (CU); PL (CU, "CORBA.ServerRequest.Arguments (Request, " & T_Arg_List & ");"); NL (CU); PL (CU, "begin"); II (CU); PL (CU, "-- Convert arguments from their Any"); NL (CU); PL (CU, "Type_Id :="); PL (CU, " CORBA.From_Any (" & T_Arg_Any & "Type_Id);"); NL (CU); PL (CU, "-- Call implementation"); NL (CU); Put (CU, T_Result & " := "); if NK = K_Interface then Put (CU, Ada_Full_Name (Node)); else pragma Assert (not Is_Delegate); Add_With (CU, Ada_Full_Name (Node) & Ada_Be.Idl2Ada.Value_Skel.Suffix); Put (CU, Ada_Full_Name (Node) & Ada_Be.Idl2Ada.Value_Skel.Suffix); end if; PL (CU, ".Is_A"); PL (CU, " (CORBA.To_Standard_String (Type_Id));"); DI (CU); PL (CU, "end;"); NL (CU); PL (CU, "-- Set Result"); NL (CU); PL (CU, "CORBA.ServerRequest.Set_Result"); PL (CU, "(Request,"); PL (CU, "CORBA.To_Any (" & T_Result & "));"); DI (CU); PL (CU, "end;"); DI (CU); end Gen_Is_A; ---------------------- -- Gen_Non_Existent -- ---------------------- procedure Gen_Non_Existent (CU : in out Compilation_Unit; Node : Node_Id) is NK : constant Node_Kind := Kind (Node); begin pragma Assert ((NK = K_Interface) or else (NK = K_ValueType)); Add_With (CU, "CORBA.Object.Helper"); Add_With (CU, "PolyORB.CORBA_P.IR_Hooks"); -- The correct operation name is _non_existent; however, for -- compatibility with legacy implementations of the GIOP 1.0 and 1.2 -- standards, the alternative name _not_existent is also supported. NL (CU); PL (CU, "elsif Operation = ""_non_existent"""); PL (CU, " or else Operation = ""_not_existent"""); PL (CU, "then"); II (CU); NL (CU); PL (CU, "CORBA.ServerRequest.Arguments (Request, " & T_Arg_List & ");"); NL (CU); PL (CU, "CORBA.ServerRequest.Set_Result"); PL (CU, " (Request,"); PL (CU, " CORBA.To_Any (CORBA.Boolean'(False)));"); DI (CU); end Gen_Non_Existent; ----------------------- -- Gen_Get_Interface -- ----------------------- procedure Gen_Get_Interface (CU : in out Compilation_Unit; Node : Node_Id) is NK : constant Node_Kind := Kind (Node); begin pragma Assert ((NK = K_Interface) or else (NK = K_ValueType)); Add_With (CU, "CORBA.Object.Helper"); Add_With (CU, "PolyORB.CORBA_P.IR_Hooks"); NL (CU); PL (CU, "elsif Operation = ""_interface"" then"); II (CU); NL (CU); PL (CU, "CORBA.ServerRequest.Arguments (Request, " & T_Arg_List & ");"); NL (CU); PL (CU, "CORBA.ServerRequest.Set_Result"); PL (CU, " (Request,"); PL (CU, " CORBA.Object.Helper.To_Any"); PL (CU, " (CORBA.Object.Ref"); PL (CU, " (PolyORB.CORBA_P.IR_Hooks.Get_Interface_Definition"); PL (CU, " (CORBA.To_CORBA_String (Repository_Id)))));"); DI (CU); end Gen_Get_Interface; ----------------------------- -- Gen_Get_Domain_Managers -- ----------------------------- procedure Gen_Get_Domain_Managers (CU : in out Compilation_Unit; Node : Node_Id) is NK : constant Node_Kind := Kind (Node); begin pragma Assert ((NK = K_Interface) or else (NK = K_ValueType)); Add_With (CU, "PolyORB.CORBA_P.Domain_Management"); NL (CU); PL (CU, "elsif Operation = ""_domain_managers"" then"); II (CU); NL (CU); PL (CU, "CORBA.ServerRequest.Arguments (Request, " & T_Arg_List & ");"); NL (CU); PL (CU, "CORBA.ServerRequest.Set_Result"); PL (CU, " (Request,"); PL (CU, " PolyORB.CORBA_P.Domain_Management.Get_Domain_Managers"); PL (CU, " (Self));"); DI (CU); end Gen_Get_Domain_Managers; ---------------------------- -- Gen_Body_Common_Start -- ---------------------------- procedure Gen_Body_Common_Start (CU : in out Compilation_Unit; Node : Node_Id; Is_Delegate : Boolean) is NK : constant Node_Kind := Kind (Node); begin pragma Assert ((NK = K_Interface) or else (NK = K_ValueType)); Add_With (CU, "PortableServer"); Add_With (CU, "CORBA", Elab_Control => Elaborate_All); -- CORBA.To_CORBA_String is used in skel elab NL (CU); PL (CU, "-- Skeleton subprograms"); NL (CU); PL (CU, "function Servant_Is_A"); PL (CU, " (Obj : PortableServer.Servant)"); PL (CU, " return Boolean;"); NL (CU); PL (CU, "function Servant_Is_A"); PL (CU, " (Obj : PortableServer.Servant)"); PL (CU, " return Boolean is"); PL (CU, "begin"); II (CU); Put (CU, "return Obj.all in "); if Is_Delegate then Put (CU, "Object'Class"); elsif NK = K_Interface then Add_With (CU, Ada_Full_Name (Node) & Impl.Suffix); Put (CU, Ada_Full_Name (Node) & Impl.Suffix & ".Object'Class"); else Add_With (CU, Ada_Full_Name (Node) & Ada_Be.Idl2Ada.Helper.Suffix); Put (CU, Ada_Full_Name (Node) & Ada_Be.Idl2Ada.Helper.Suffix & ".Servant'Class"); end if; PL (CU, ";"); DI (CU); PL (CU, "end Servant_Is_A;"); Decls_Div := Current_Diversion (CU); Divert (CU, Operation_Body); NL (CU); Add_With (CU, "CORBA.ServerRequest"); Add_With (CU, "PolyORB.Std"); PL (CU, "procedure Invoke"); PL (CU, " (Self : PortableServer.Servant;"); II (CU); PL (CU, "Request : CORBA.ServerRequest.Object_Ptr)"); DI (CU); PL (CU, "is"); II (CU); PL (CU, "Operation : constant PolyORB.Std.String"); PL (CU, " := CORBA.To_Standard_String"); PL (CU, " (CORBA.ServerRequest.Operation"); PL (CU, " (Request.all));"); Add_With (CU, "CORBA.NVList"); PL (CU, T_Arg_List & " : CORBA.NVList.Ref;"); DI (CU); PL (CU, "begin"); II (CU); Add_With (CU, "CORBA.ORB"); PL (CU, "CORBA.ORB.Create_List (0, " & T_Arg_List & ");"); end Gen_Body_Common_Start; ------------------------- -- Gen_Body_Common_End -- ------------------------- procedure Gen_Body_Common_End (CU : in out Compilation_Unit; Node : Node_Id; Is_Delegate : Boolean) is NK : constant Node_Kind := Kind (Node); It : Node_Iterator; P_Node : Node_Id; begin pragma Assert ((NK = K_Interface) or else (NK = K_ValueType)); NL (CU); PL (CU, "else"); II (CU); PL (CU, "CORBA.Raise_Bad_Operation (CORBA.Default_Sys_Member);"); DI (CU); PL (CU, "end if;"); DI (CU); PL (CU, "exception"); II (CU); PL (CU, "when E : others =>"); II (CU); PL (CU, "CORBA.ServerRequest.Set_Exception"); PL (CU, " (Request,"); II (CU); PL (CU, "PolyORB.CORBA_P.Exceptions.System_Exception_To_Any (E));"); DI (CU); Add_With (CU, "PolyORB.QoS.Exception_Informations"); PL (CU, "PolyORB.QoS.Exception_Informations.Set_Exception_Information"); PL (CU, " (Request.all, E);"); DI (CU); DI (CU); PL (CU, "end Invoke;"); Divert (CU, Decls_Div); Undivert (CU, Operation_Body); if not Is_Delegate then Init (It, Parents (Node)); while not Is_End (It) loop Get_Next_Node (It, P_Node); Add_With (CU, Ada_Full_Name (P_Node) & Skel.Suffix (Is_Delegate => False), No_Warnings => True); end loop; end if; Divert (CU, Deferred_Initialization); PL (CU, "PortableServer.Internals.Register_Skeleton"); Put (CU, " ("); Put (CU, Ada_Full_Name (Node)); PL (CU, "." & Repository_Id_Name (Node) &","); if not Is_Delegate then PL (CU, " Servant_Is_A'Access,"); PL (CU, " Is_A'Access,"); PL (CU, " Invoke'Access);"); else PL (CU, " Servant_Is_A'Unrestricted_Access,"); PL (CU, " Is_A'Access,"); PL (CU, " Invoke'Unrestricted_Access);"); end if; end Gen_Body_Common_End; ------------ -- Suffix -- ------------ function Suffix (Is_Delegate : Boolean) return String is begin if Is_Delegate then return ".Delegate"; else return ".Skel"; end if; end Suffix; ---------------- -- Gen_Invoke -- ---------------- procedure Gen_Invoke (CU : in out Compilation_Unit; Node : Node_Id) is begin case Kind (Node) is ---------------- -- Operations -- ---------------- when K_Operation => declare O_Type : constant Node_Id := Operation_Type (Node); Org_O_Type : constant Node_Id := Original_Operation_Type (Node); O_Name : constant String := Ada_Operation_Name (Node); Response_Expected : constant Boolean := not Is_Oneway (Node); Is_Function : constant Boolean := Kind (O_Type) /= K_Void; Is_Class_Wide : constant Boolean := Is_Function and then Kind (O_Type) = K_Scoped_Name and then S_Type (O_Type) = Original_Parent_Scope (Node); -- For an operation that returns a reference to its own -- interface type, the return type is classwide, so we need to -- convert it to the corresponding root type in the assignment -- to Result. Raise_Something : constant Boolean := not (Raises (Node) = Nil_List); Has_Out_Args : Boolean; -- True when there are arguments of mode out or in out Max_Len : Integer := T_Result_Name'Length; Arg_Seen : Boolean; begin declare It : Node_Iterator; P_Node : Node_Id; begin Init (It, Parameters (Node)); while not Is_End (It) loop Get_Next_Node (It, P_Node); if not Is_Returns (P_Node) then declare L : constant Integer := Ada_Name (Declarator (P_Node))'Length; begin if Max_Len < (L + T_Arg_Any'Length) then Max_Len := L + T_Arg_Any'Length; end if; end; end if; end loop; end; NL (CU); PL (CU, "elsif Operation = """ & Idl_Operation_Id (Node) & """ then"); II (CU); Arg_Seen := False; declare It : Node_Iterator; P_Node : Node_Id; begin Init (It, Parameters (Node)); while not Is_End (It) loop if not Arg_Seen then Add_With (CU, "PolyORB.Any"); NL (CU); PL (CU, "declare"); II (CU); end if; Get_Next_Node (It, P_Node); if not Is_Returns (P_Node) then declare Arg_Name : constant String := Ada_Name (Declarator (P_Node)); P_Typ : constant Node_Id := Param_Type (P_Node); begin PL (CU, Justify (T_Argument & Arg_Name, Max_Len) & " : " & Ada_Type_Name (Param_Type (P_Node)) & ";"); -- Kill warning about uninitialized variable (it is -- accessed only through the wrapper below). PL (CU, "pragma Warnings (Off, " & T_Argument & Arg_Name & ");"); PL (CU, Justify (T_Arg_CC & Arg_Name, Max_Len) & " : aliased PolyORB.Any.Content'Class" & " :="); II (CU); Helper.Gen_Wrap_Call (CU, P_Typ, T_Argument & Arg_Name); DI (CU); PL (CU, ";"); Divert (CU, Decls_Div); if not Arg_Seen then NL (CU); Arg_Seen := True; end if; PL (CU, Justify (O_Name & T_Arg_Name & Arg_Name, Max_Len) & " : constant CORBA.Identifier :="); PL (CU, " CORBA.To_CORBA_String (""" & Arg_Name & """);"); Divert (CU, Operation_Body); Add_With (CU, TC_Unit (P_Typ)); PL (CU, Justify (T_Arg_Any & Arg_Name, Max_Len) & " : constant CORBA.Any := " & "CORBA.Internals.Get_Wrapper_Any (" & Ada_Full_TC_Name (P_Typ) & ", " & T_Arg_CC & Arg_Name & "'Unchecked_Access);"); NL (CU); end; end if; end loop; end; if Kind (Org_O_Type) /= K_Void then if not Arg_Seen then Add_With (CU, "PolyORB.Any"); NL (CU); PL (CU, "declare"); II (CU); Arg_Seen := True; end if; Add_With_Entity (CU, Org_O_Type); PL (CU, Justify (T_Result, Max_Len) & " : " & Ada_Type_Name (Org_O_Type) & ";"); -- Kill warning about unreferenced variable (it is accessed -- only through the wrapper below). PL (CU, "pragma Warnings (Off, " & T_Result & ");"); PL (CU, Justify (T_Arg_CC & T_Result, Max_Len) & " : aliased PolyORB.Any.Content'Class" & " :="); II (CU); Helper.Gen_Wrap_Call (CU, Org_O_Type, T_Result); DI (CU); PL (CU, ";"); Add_With (CU, TC_Unit (Org_O_Type)); PL (CU, Justify (T_Arg_Any & T_Result, Max_Len) & " : constant CORBA.Any :=" & " CORBA.Internals.Get_Wrapper_Any (" & Ada_Full_TC_Name (Org_O_Type) & ", " & T_Arg_CC & T_Result & "'Unchecked_Access);"); end if; if Arg_Seen then DI (CU); end if; PL (CU, "begin"); II (CU); declare It : Node_Iterator; P_Node : Node_Id; begin Init (It, Parameters (Node)); while not Is_End (It) loop Get_Next_Node (It, P_Node); if not Is_Returns (P_Node) then declare Arg_Name : constant String := Ada_Name (Declarator (P_Node)); begin PL (CU, "CORBA.NVList.Add_Item"); PL (CU, " (" & T_Arg_List & ","); II (CU); PL (CU, O_Name & T_Arg_Name & Arg_Name & ","); PL (CU, T_Arg_Any & Arg_Name & ","); case Mode (P_Node) is when Mode_In => PL (CU, "CORBA.ARG_IN);"); when Mode_Inout => PL (CU, "CORBA.ARG_INOUT);"); Has_Out_Args := True; when Mode_Out => PL (CU, "CORBA.ARG_OUT);"); Has_Out_Args := True; end case; DI (CU); end; end if; end loop; end; NL (CU); PL (CU, "CORBA.ServerRequest.Arguments (Request, " & T_Arg_List & ");"); NL (CU); PL (CU, "begin"); II (CU); if Is_Function then Put (CU, T_Result & " := "); if Is_Class_Wide then Put (CU, Ada_Type_Name (O_Type) & " ("); end if; end if; declare Impl_Name : constant String := Ada_Full_Name (Parent_Scope (Node)) & ".Impl"; begin PL (CU, Impl_Name & "." & Ada_Operation_Name (Node)); Put (CU, " (" & Impl_Name & ".Object'Class (Self.all)'Access"); end; II (CU); declare It : Node_Iterator; P_Node : Node_Id; begin Init (It, Parameters (Node)); while not Is_End (It) loop Get_Next_Node (It, P_Node); PL (CU, ","); if Is_Returns (P_Node) then Put (CU, T_Result); else Put (CU, T_Argument & Ada_Name (Declarator (P_Node))); end if; end loop; end; Put (CU, ")"); if Is_Class_Wide then Put (CU, ")"); end if; PL (CU, ";"); DI (CU); if Raise_Something then DI (CU); PL (CU, "exception"); II (CU); declare It : Node_Iterator; R_Node : Node_Id; E_Node : Node_Id; begin Init (It, Raises (Node)); while not Is_End (It) loop Get_Next_Node (It, R_Node); E_Node := Value (R_Node); Add_With_Entity (CU, E_Node); declare Prefix : constant String := Helper_Unit (E_Node); begin Add_With (CU, Prefix); PL (CU, "when E : " & Ada_Full_Name (E_Node) & " =>"); II (CU); PL (CU, "declare"); II (CU); PL (CU, "Members : " & Ada_Full_Name (E_Node) & "_Members;"); DI (CU); PL (CU, "begin"); II (CU); PL (CU, Parent_Scope_Name (E_Node) & ".Get_Members (E, Members);"); PL (CU, "CORBA.ServerRequest.Set_Exception"); PL (CU, " (Request,"); II (CU); PL (CU, Prefix & ".To_Any (Members));"); DI (CU); PL (CU, "return;"); DI (CU); PL (CU, "end;"); DI (CU); end; end loop; end; end if; DI (CU); PL (CU, "end;"); if Response_Expected then if Kind (Original_Operation_Type (Node)) /= K_Void then PL (CU, "CORBA.ServerRequest.Set_Result"); PL (CU, " (Request, " & T_Arg_Any & T_Result & ");"); end if; -- The Any's for out or inout arguments must remain valid -- after the skel is exited, for the marshalling of the -- answer: copy them now. if Has_Out_Args then PL (CU, "CORBA.NVList.Internals.Clone_Out_Args (" & T_Arg_List & ");"); end if; end if; PL (CU, "return;"); DI (CU); PL (CU, "end;"); DI (CU); end; when others => null; end case; end Gen_Invoke; ------------------- -- Gen_Node_Spec -- ------------------- procedure Gen_Node_Spec (CU : in out Compilation_Unit; Node : Node_Id; Is_Delegate : Boolean) is pragma Unreferenced (CU, Node, Is_Delegate); begin null; end Gen_Node_Spec; end Ada_Be.Idl2Ada.Skel; polyorb-2.8~20110207.orig/compilers/idlac/testsuite/0000755000175000017500000000000011750740340021504 5ustar xavierxavierpolyorb-2.8~20110207.orig/compilers/idlac/testsuite/private/0000755000175000017500000000000011750740340023156 5ustar xavierxavierpolyorb-2.8~20110207.orig/compilers/idlac/testsuite/private/server_operations.idl0000644000175000017500000030426611750740337027442 0ustar xavierxavier// Test-case submitted by Philippe Lerch, 2000-05-03. // $Id: //depot/adabroker/main/idlac/testsuite/private/server_operations.idl#1 $ //------------------------------------------------------------------------------ // // File : server_operations.idl // // Project : EZF // // ELCA Matrix SA // Avenue de la Harpe 22-24 // CH-1000 Lausanne 13 // Tel (41 21) 613 22 41 // Fax (41 21) 613 22 40 // // Description: // // This file contains the interface definitions to access EasyFile server // with a CORBA client over a CORBA EasyNet bridge. // // History: // // 02-JUL-1998 HBU Creation // 13-JUL-1998 HBU Modifications suggested by BRY and minor corrections // in the connection interface. // 16-JUL-1998 HBU Removed the interfaces EZFObj and ServiceConnection; // Locks are handFiled at the level of connection // 19-AUG-1998 HBU Minor modifications suggested by MWE. // 6-OCT-1998 RRO integration of BridgeMgr.idl into this file. // 26-OCT-1998 RRO LockItem & WaitToLockItem are void procedures // 1-NOV-1999 JPN From Problem to InternalException and specific Exception. // 21-DEC-1999 JPN Adding NonuniqueIndex Exception in CreateEDoc,Doc,Folder. //------------------------------------------------------------------------------ //------------------------------------------------------------------------------ module easyfile { module server_operations //------------------------------------------------------------------------------ { // Consts : //---------- //---------------------------------------------------------------------------- const string ident = "@(#) EZF Skelettons/Stubs 1.8" ; //---------------------------------------------------------------------------- // General Types : //---------------- typedef sequence RawDataT ; typedef sequence StringListT ; typedef sequence BooleanListT ; // Object ID's : //-------------- // // Reference: package EZF_Ids enum ItemKindT { NoneIK, EDocIK, DocIK, FolderIK, SearcherIK, UserIK, GroupIK } ; struct ObjectIdT { long lowerPart ; long higherPart ; long DBPartitionPart ; } ; typedef sequence ObjectIdListT ; // Permission : //------------- // // Reference: package EZF_Protection, type Protection struct PermissionT { boolean read ; boolean write ; boolean delete ; boolean control ; } ; struct ProtectionT { PermissionT owner ; PermissionT group ; PermissionT world ; } ; // Values : //--------- // // Reference: package EZF_Data_Types typedef sequence TextT ; // depend of the use of client..... typedef long TimeStampT ; // in seconds since 1.1.1970 (timestamp) enum ValueKindT { NoneV, IntegerV, SmallIntegerV, RealV, LongRealV, TimeStampV, TextV, IdentifierV } ; union ValueT switch ( ValueKindT ) { case NoneV: char notUsed ; case IntegerV: long intValue ; case SmallIntegerV: short smallIntValue ; case RealV: float realValue ; case LongRealV: double longRealValue ; case TimeStampV: TimeStampT timeStampValue ; case TextV: TextT textValue ; case IdentifierV: ObjectIdT identifierValue ; } ; // Descriptor : //------------- // // Reference: package EZF_Descriptors struct GroupDescriptorT { long groupId ; // this is the group Id long fatherId ; // father group id long depth ; // depth in the group tree } ; typedef sequence GroupT ; typedef sequence PositionT ; struct ValueAndPositionT { PositionT position ; ValueT value ; } ; typedef sequence ValuesAndPositionsT ; struct FieldWithValuesT { string fieldName ; long groupId ; ValuesAndPositionsT values ; } ; typedef sequence FieldValueListT ; struct DescriptorT { GroupT groups ; FieldValueListT fieldsAndValues ; } ; // Criterion : //------------ // // Reference: package EZF_Search_Criteria // Remark: Represented as a sequence of tokens in the "prefix" notation. enum UnaryOperatorT { NotOp, UnaryPlusOp, UnaryMinusOp, AbsOp, FloorOp, CeilingOp, TruncateOp, SignOP, UpperCaseOp, LowerCaseOp, IsNullOp, IsNotNullOp } ; enum BinaryOperatorT { AndOp, OrOp, EqualOp, NotEqualOp, LikeOp, NotLikeOp, LessThanOp, LessThanOrEqualOp, GreaterThanOp, GreaterThanOrEqualOp, PlusOp, MinusOp, TimesOp, DivideOp, ModuloOp, PowerOp } ; enum TokenKindT { UnaryOpTok, BinaryOpTok, FieldNameTok, ValueTok } ; union TokenT switch ( TokenKindT ) { case UnaryOpTok: UnaryOperatorT unaryOperator ; case BinaryOpTok: BinaryOperatorT binaryOperator ; case FieldNameTok: string fieldName ; case ValueTok: ValueT value ; } ; typedef sequence CriterionT ; // Structered Parameter : //----------------------- // // Reference: package EZF_Structured_Paramters enum ParameterKindT { NoneP, IntegerP, SmallIntegerP, RealP, LongRealP, TimeStampP, StringP, IdentifierP, RawDataP , CriterionP, DescriptorP } ; union ParameterValueT switch ( ParameterKindT ) { case NoneP: char notUsed ; case IntegerP: long intValue ; case SmallIntegerP: short smallIntValue ; case RealP: float realValue ; case LongRealP: double longRealValue ; case TimeStampP: TimeStampT timeStampValue ; case StringP: string textValue ; case IdentifierP: ObjectIdT identifierValue ; case RawDataP: RawDataT data ; case CriterionP: CriterionT criterion ; case DescriptorP: DescriptorT descriptor ; } ; typedef sequence ParameterT ; // Types used for services : //-------------------------- // // Reference: package EZF_Services, EZF_Server_Operations enum CompletionStatusT { NoneCS, OkCS, ErrorCS } ; enum ServiceKindT { NoneSrv, PrintSrv, FaxSrv, OtherSrv } ; struct ServiceInfoT { ServiceKindT kind ; string name ; } ; typedef sequence ServiceInfoListT ; struct JobResultHeaderT { ServiceKindT kind ; string name ; long jobNumber ; string userName ; TimeStampT submitted ; TimeStampT done ; } ; typedef sequence JobResultHeaderListT ; struct LoginInfoT{ boolean PasswordExpiringSoon; } ; struct ItemImageVarT { ObjectIdT eDocId ; long tag ; RawDataT image ; } ; enum JobItemKindT { NoneJIK, DescriptorJIK, ImageJIK, SuppliedImageJIK } ; union ItemVarT switch ( JobItemKindT ) { case NoneJIK: char notUsed ; case DescriptorJIK: DescriptorT descriptor ; case ImageJIK: ItemImageVarT imageId ; case SuppliedImageJIK: RawDataT image ; } ; struct ItemT { long number ; ParameterT parameter ; ItemVarT variablePart ; } ; typedef sequence ItemListT ; struct JobT { long number ; ParameterT parameter ; long lastItemServed ; } ; enum HeaderOrItemT { JobHeader, JobItem } ; union JobHeaderOrItemT switch (HeaderOrItemT) { case JobHeader: JobT job ; case JobItem: ItemT item ; } ; struct ItemResultT { CompletionStatusT status ; ParameterT contents ; } ; typedef sequence ItemResultListT ; struct JobResultT { CompletionStatusT status ; ParameterT contents ; ItemResultListT itemResults ; } ; // Notifications : //---------------- // // Reference: package EZF_Notifier_Types enum NotificationKindT { ItemDescriptorChangedNK, ItemContentsChangedNK, ItemContainerChangedNK, ItemPermissionChangedNK, ItemDeletedNK, MessageNK, StructuredMessageNK, CloseImmediatelyNK, CloseASAPNK, ShutdownNK, ShutdownCancelledNK, ServiceJobDoneNK, NewServiceAvailableNK, ServiceDeadNK, UserArrivedNK, UserGoneNK } ; struct NotifItemVarPartT { string fromUser ; ObjectIdT itemId ; } ; struct NotifShutdownVarPartT { string fromUser ; string message ; long secondsToLive ; } ; struct NotifMsgVarPartT { string fromUser ; string message ; } ; struct NotifStructMsgVarPartT { string fromUser ; ParameterT message ; } ; struct NotifJobDoneVarPartT { string serviceName ; long jobNumber ; CompletionStatusT jobStatus ; long lastItemDone ; } ; struct NotifServiceVarPartT { string serviceName ; ServiceKindT serviceKind ; } ; union NotificationT switch ( NotificationKindT ) { case ItemDescriptorChangedNK: NotifItemVarPartT descChangedInfo ; case ItemContentsChangedNK: NotifItemVarPartT contentsChangedInfo ; case ItemContainerChangedNK: NotifItemVarPartT containerChangedInfo ; case ItemPermissionChangedNK: NotifItemVarPartT permChangeditemInfo ; case ItemDeletedNK: NotifItemVarPartT deletedItemInfo ; case MessageNK: NotifMsgVarPartT message ; case CloseImmediatelyNK: NotifMsgVarPartT closeImmMsg ; case CloseASAPNK: NotifMsgVarPartT closeASAPMsg ; case ShutdownCancelledNK: NotifMsgVarPartT shutdownCancelledMsg ; case StructuredMessageNK: NotifStructMsgVarPartT structuredMsg ; case ShutdownNK: NotifShutdownVarPartT shutdownInfo ; case ServiceJobDoneNK: NotifJobDoneVarPartT jobInfo ; case NewServiceAvailableNK: NotifServiceVarPartT newServiceInfo ; case ServiceDeadNK: NotifServiceVarPartT deadServiceInfo ; case UserArrivedNK: string arrivedUserName ; case UserGoneNK: string goneUserName ; } ; // Groupmembers : //--------------- enum GroupMemberKindT { userGM, groupGM } ; struct GroupMemberT { GroupMemberKindT kind ; string name ; } ; typedef sequence GroupMemberListT ; // Exceptions : //------------- // specific exeption : exception InternalException { string errorMessage; // As returned from the EZF server } ; exception WrongVersion{}; exception DuplicateUserName{}; exception NonexistentUser{}; exception WrongPassword{}; exception PasswordExpired{}; exception PasswordNotAllowed{}; exception NonuniqueIndex{}; exception DuplicateGroupName{}; exception NonexistentGroup{}; exception CircularGroupInclusion{}; exception ItemAlreadyLocked{}; //---------------------------------------------------------------------------- const long NoTransaction = 0 ; // Transaction id, when trans. not required. //---------------------------------------------------------------------------- // Bridge Manager: //------------------------------------------------------------------------------ // Type declarations: //------------------- enum TagT {connectTag, opTag, serviceTag, exceptionTag, transactionTag, anyTag}; // category of the event enum ValueTagT {IntegerValue, StringValue, BinDataValue}; // keep the same order of enum elements as in ValueTagT (Manager.hpp)! // With this assumption, casting is possible and correct! (as it is // implemented). union ValueTMgr switch (ValueTagT) { case IntegerValue: long i; case StringValue: string str; case BinDataValue: sequence bin; }; struct NameValuePairT { string name; ValueTMgr value; }; typedef sequence NameValuePairListT; // argument list struct FilterT { // AND relation TagT type; TimeStampT since; string sender; }; struct EventT { TagT type; // kind of event string whichEvent; // detailed description, e.g. operation performed, // transaction id, exception description TimeStampT timeStamp; // timestamp string sender; // username of the related connection }; typedef sequence EventListT ; // Exception declarations: //------------------------ exception MgrInternalException { string errorMessage; string reason; }; // Interfaces: //------------ // Forward declaration interface EventListIterator ; interface Manager //-------------------------------------------------------------------------- // Purpose: Manager is used to manage the EasyNet bridge: // shutdown bridge, tracing and listing of the events occured. // Several Managers can be connected to the bridge. //-------------------------------------------------------------------------- { void Logout() raises (MgrInternalException); //------------------------------------------------------------------------ // Effect : Closes the connection to the bridge and distroys all related // Iterators. If already closed, no action is performed. // Error : the bridge is shuting down //------------------------------------------------------------------------ void Shutdown(in long delay) raises (MgrInternalException); //------------------------------------------------------------------------ // Effect : Shuts down the EasyNet bridge after a delay given in seconds. // Delay<=0 implies immediate shutdown. // Error : Exception MgrInternalException containing the errorcode returned by // the bridge is raised. //------------------------------------------------------------------------ StringListT GetOpenConnections() raises (MgrInternalException); //------------------------------------------------------------------------ // Effect : Lists all usernames of open connections to the EZF-Server. // Error : Exception MgrInternalException containing the errorcode returned by // the bridge is raised. //------------------------------------------------------------------------ void SetTraceOn() raises (MgrInternalException); //------------------------------------------------------------------------ // Effect : Turns tracing on. The traced events can be retrieved with // method GetEvents. // Error : Exception MgrInternalException containing the errorcode returned by // the bridge is raised. //------------------------------------------------------------------------ void SetTraceOff() raises (MgrInternalException); //------------------------------------------------------------------------ // Effect : Turns tracing off. // Error : Exception MgrInternalException containing the errorcode returned by // the bridge is raised. //------------------------------------------------------------------------ void ClearTrace() raises (MgrInternalException); //------------------------------------------------------------------------ // Effect : Erases all traced events. // Error : Exception MgrInternalException containing the errorcode returned by // the bridge is raised. //------------------------------------------------------------------------ StringListT GetAvailableInfos() raises (MgrInternalException); //------------------------------------------------------------------------ // Effect : returns a list of available infos to be passed to GetInfo. // Error : Exception MgrInternalException containing the errorcode returned by // the bridge is raised. //------------------------------------------------------------------------ StringListT GetAvailableCmds() raises (MgrInternalException); //------------------------------------------------------------------------ // Effect : returns a list of available commands to be passed to Execute. // Error : Exception MgrInternalException containing the errorcode returned by // the bridge is raised. //------------------------------------------------------------------------ void GetInfo(in string what, out NameValuePairListT infos) raises (MgrInternalException); //------------------------------------------------------------------------ // Effect : Returns requested information. If what is set to // - availableInfos, infos contains a list of requestable // information. // - availableCmds, infos contains a list of executable // commands which can be executed with Execute method. // Error : Exception MgrInternalException containing the errorcode returned by // the bridge is raised. //------------------------------------------------------------------------ long Execute(in string command, in NameValuePairListT args) raises(MgrInternalException); //------------------------------------------------------------------------ // Effect : Executes a command with the given arguments. // Error : Exception MgrInternalException containing the errorcode returned by // the bridge is raised. //------------------------------------------------------------------------ void GetEvents( in FilterT filter , in long howMany , out EventListT events , out EventListIterator iter) raises (MgrInternalException) ; //------------------------------------------------------------------------ // Effect : Returns a list of up to howMany traced events. The // EventListIterator is only used if there are more than // howMany in the list. // Set TraceOn before calling GetEvents. Otherwise the list // events may be empty. // Error : Exception MgrInternalException containing the errorcode returned by // the bridge is raised. //------------------------------------------------------------------------ }; // end interface Manager //-------------------------------------------------------------------------- interface EventListIterator //-------------------------------------------------------------------------- // Iterator to read an EventListT. //-------------------------------------------------------------------------- { void Rewind(); //------------------------------------------------------------------------ // Effect : Sets the Iterator to the beginning of the file. // Error : - //------------------------------------------------------------------------ long Next(inout EventT event); //------------------------------------------------------------------------ // Effect : Returns next Event of the list fulfilling the filter's // criteria or NULL if the end is reached. Set TraceOn before // calling Iterator. Otherwise there are no events. // Error : end of file //------------------------------------------------------------------------ void NextN(out EventListT events, in long howMany); //------------------------------------------------------------------------ // Effect : Returns next 'howMany' Events of the list fulfilling the // filter's criteria or NULL if the end is reached. Set TraceOn // before calling Iterator. Otherwise there are no events. // howMany returns the number of read Events. // Error : - //------------------------------------------------------------------------ void Destroy(); //------------------------------------------------------------------------ // Effect : Destroys the Iterator. The reference to the iterator must // not be used any more. // Error : - //------------------------------------------------------------------------ }; // end interface EventListIterator //-------------------------------------------------------------------------- // Forward declarations : //----------------------- interface EDoc ; interface Doc ; interface Folder ; interface Searcher ; interface User ; interface Group ; interface Connection ; interface Notifier ; // Interfaces : //------------- //---------------------------------------------------------------------------- interface ConnectionFactory //---------------------------------------------------------------------------- // Purpose: The ConnectionFactory is used to create connections // between a CORBA client and the EZF server (CreateConnection) // or between a CORBA EZF service and the EZF server // (CreateServiceConnection). //---------------------------------------------------------------------------- { //-------------------------------------------------------------------------- Connection CreateConnection( in string version , in string userName , in string password , in string groupName , in string securityInfo , in ProtectionT defaultProtection , in boolean isReadonly , in Notifier notifHandler , out LoginInfoT logininformation ) raises (InternalException,WrongVersion,NonexistentUser,WrongPassword,PasswordExpired) ; //-------------------------------------------------------------------------- // Effect : Opens a new connection between the bridge and the EZF server // for ordinary clients. // If "notifHandler" is nil, then all notifications for // "userName" will be discarded. // logininformation contains information about non fatal events // during the login. (As PasswordExpiringSoon...) // Error : Exception InternalException containing the errorcode returned by the // EZF server is raised. (When fatal Error Occured). //-------------------------------------------------------------------------- //------------------------------------------------------------------------- Connection ConnectService( in string version , in ServiceKindT kind , in string name , in string password , in string securityInfo , in Notifier notifHandler , out LoginInfoT logininformation ) raises (InternalException) ; //-------------------------------------------------------------------------- // Effect : Opens a new connection between the bridge and the EZF server // for services. // If "notifHandler" is nil, then all notifications for // the service "name" will be discarded. // logininformation contains information about non fatal events // during the login. (As PasswordExpiringSoon...) // Error : Exception InternalException containing the errorcode returned by the // EZF server is raised. (When fatal Error Occured). //-------------------------------------------------------------------------- //-------------------------------------------------------------------------- Manager ConnectBridge(in string groupname, in string username, in string passWord) raises(MgrInternalException); //------------------------------------------------------------------------ // Effect : IF (groupname is Supergroup) and (username is superuser) // and password_correct THEN grant access to bridge and open // connection for administration. // Error : Exception MgrInternalException containing the errorcode returned by // the bridge is raised (EZFServerDown or notAuhorised). //------------------------------------------------------------------------ } ; // end interface ConnectionFactory //---------------------------------------------------------------------------- //---------------------------------------------------------------------------- interface Connection //---------------------------------------------------------------------------- // Purpose: A Connection alows a CORBA client to invoke the complete // functionality of the EZF Server. //---------------------------------------------------------------------------- { // Type definitions : //------------------- enum ConnectionTypeT { clientConnection, serviceConnection } ; enum OperationKindT { readOp, modifyOp } ; // Used for the locks enum TraceLevelT { Debug, Trace, Information, Warning, Error, Fatal } ; // Attributes : //------------- readonly attribute ConnectionTypeT connectionType ; // Methods : //---------- // Server management : //-------------------- //-------------------------------------------------------------------------- void ShutdownEZFServer( in string securityInfo , in long delay , in string message ) raises (InternalException) ; //-------------------------------------------------------------------------- // Effect : // Error : Exception InternalException containing the errorcode returned by the // EZF server is raised. //-------------------------------------------------------------------------- //-------------------------------------------------------------------------- void ReloadSecurity ( in string securityInfo ) raises (InternalException) ; //-------------------------------------------------------------------------- // Effect : // Error : Exception InternalException containing the errorcode returned by the // EZF server is raised. //-------------------------------------------------------------------------- //-------------------------------------------------------------------------- void ReloadDBPartition ( in string securityInfo ) raises (InternalException) ; //-------------------------------------------------------------------------- // Effect : // Error : Exception InternalException containing the errorcode returned by the // EZF server is raised. //-------------------------------------------------------------------------- //-------------------------------------------------------------------------- void ReloadAll ( in string securityInfo ) raises (InternalException) ; //-------------------------------------------------------------------------- // Effect : // Error : Exception InternalException containing the errorcode returned by the // EZF server is raised. //-------------------------------------------------------------------------- //-------------------------------------------------------------------------- void RestartAAM ( in string securityInfo ) raises (InternalException) ; //-------------------------------------------------------------------------- // Effect : // Error : Exception InternalException containing the errorcode returned by the // EZF server is raised. //-------------------------------------------------------------------------- //-------------------------------------------------------------------------- void SetTraceLevel ( in string securityInfo , in TraceLevelT level ) raises (InternalException) ; //-------------------------------------------------------------------------- // Effect : // Error : Exception InternalException containing the errorcode returned by the // EZF server is raised. //-------------------------------------------------------------------------- // Transactions : //--------------- //-------------------------------------------------------------------------- long StartTransactionOnPartition( in string securityInfo , in long DBPartitionPart ) raises (InternalException) ; //-------------------------------------------------------------------------- // Effect : Starts a new transaction and returns its id. // Error : Exception InternalException containing the errorcode returned by the // EZF server is raised. //-------------------------------------------------------------------------- //-------------------------------------------------------------------------- long StartTransactionWithDescrAndCrit( in string securityInfo , in DescriptorT descriptor , in CriterionT criterion ) raises (InternalException) ; //-------------------------------------------------------------------------- // Effect : Starts a new transaction and returns its id. // Error : Exception InternalException containing the errorcode returned by the // EZF server is raised. //-------------------------------------------------------------------------- //-------------------------------------------------------------------------- void CommitTransaction( in long transactionId , in string securityInfo ) raises (InternalException) ; //-------------------------------------------------------------------------- // Requires : valid transactionId ( different from NoTransaction). // Effect : Commits the transaction "transactionId". //-------------------------------------------------------------------------- //-------------------------------------------------------------------------- void RollbackTransaction( in long transactionId , in string securityInfo ) raises (InternalException) ; //-------------------------------------------------------------------------- // Requires : valid transactionId ( different from NoTransaction). // Effect : Rolls the transaction "transactionId" back. //-------------------------------------------------------------------------- // EDocs: //------- //-------------------------------------------------------------------------- EDoc GetEDoc( in ObjectIdT eDocId ) raises (InternalException) ; //-------------------------------------------------------------------------- // Effect : Retruns an objectreference on the EDoc "eDocId". // Error : Exception InternalException containing the errorcode returned by the // EZF server is raised. //-------------------------------------------------------------------------- //-------------------------------------------------------------------------- EDoc CreateEDoc( in long transactionId , in string securityInfo , in DescriptorT descriptor ) raises (InternalException,NonuniqueIndex) ; //-------------------------------------------------------------------------- // Requires : Must be transacted ( "transactionId" different from // NoTransaction). // Effect : Creates a new EDoc on the EZF server. // Error : Exception InternalException containing the errorcode returned by the // EZF server is raised. // NonuniqueIndex is raised in the case the UniqueIndex rule is violated. //-------------------------------------------------------------------------- // Docs: //------ //-------------------------------------------------------------------------- Doc GetDoc( in ObjectIdT docId ) raises (InternalException) ; //-------------------------------------------------------------------------- // Effect : Retruns an objectreference on the Doc "docId". // Error : Exception InternalException containing the errorcode returned by the // EZF server is raised. //-------------------------------------------------------------------------- //-------------------------------------------------------------------------- Doc CreateDoc( in long transactionId , in string securityInfo , in DescriptorT descriptor ) raises (InternalException,NonuniqueIndex) ; //-------------------------------------------------------------------------- // Requires : Must be transacted ( "transactionId" different from // NoTransaction). // Effect : Creates a new Doc on the EZF server. // Error : Exception InternalException containing the errorcode returned by the // EZF server is raised. // NonuniqueIndex is raised in the case the UniqueIndex rule is violated. //-------------------------------------------------------------------------- // Folders: //--------- //-------------------------------------------------------------------------- Folder GetFolder( in ObjectIdT folderId ) raises (InternalException) ; //-------------------------------------------------------------------------- // Effect : Returns an objectreference on the Folder "folderId". // Error : Exception InternalException containing the errorcode returned by the // EZF server is raised. //-------------------------------------------------------------------------- //-------------------------------------------------------------------------- Folder CreateFolder( in long transactionId , in string securityInfo , in DescriptorT descriptor ) raises (InternalException,NonuniqueIndex) ; //-------------------------------------------------------------------------- // Requires : Must be transacted ( "transactionId" different from // NoTransaction). // Effect : Creates a new Folder on the EZF server. // Error : Exception InternalException containing the errorcode returned by the // EZF server is raised. // NonuniqueIndex is raised in the case the UniqueIndex rule is violated. //-------------------------------------------------------------------------- // Searchers: //----------- //-------------------------------------------------------------------------- Searcher GetSearcher( in ObjectIdT searcherId ) raises (InternalException) ; //-------------------------------------------------------------------------- // Effect : Returns an objectreference on the Searcher "searcherId". // Error : Exception InternalException containing the errorcode returned by the // EZF server is raised. //-------------------------------------------------------------------------- //-------------------------------------------------------------------------- Searcher CreateSearcher( in long transactionId , in string securityInfo , in ItemKindT kind , in CriterionT criterion ) raises (InternalException) ; //-------------------------------------------------------------------------- // Requires : Must be transacted ( "transactionId" different from // NoTransaction). // Effect : Creates a new Searcher on the EZF Server. // Error : Exception InternalException containing the errorcode returned by the // EZF server is raised. //-------------------------------------------------------------------------- //-------------------------------------------------------------------------- void SearchItems( in long transactionId , in string securityInfo , in ItemKindT kind , in CriterionT criterion , out ObjectIdListT imtemIds ) raises (InternalException) ; //-------------------------------------------------------------------------- // Effect : Searches the items "kind" (EDoc, Doc or Folder) corresponding // to "criterion" and returns the id's of the found items. // Error : Exception InternalException containing the errorcode returned by the // EZF server is raised. //-------------------------------------------------------------------------- //-------------------------------------------------------------------------- void SearchItemsWithDescriptor( in long transactionId , in string securityInfo , in ItemKindT kind , in CriterionT criterion , inout DescriptorT descriptor) raises (InternalException) ; //-------------------------------------------------------------------------- // Effect : Searches the items "kind" (EDoc, Doc or Folder) corresponding // to "criterion" and returns the descriptor containing the // found values. // Error : Exception InternalException containing the errorcode returned by the // EZF server is raised. //-------------------------------------------------------------------------- // Users: //------- //-------------------------------------------------------------------------- User GetUser( in string userName ) raises (InternalException) ; //-------------------------------------------------------------------------- // Effect : Returns an objectreference on the User "userName". // Error : Exception InternalException containing the errorcode returned by the // EZF server is raised. //-------------------------------------------------------------------------- //-------------------------------------------------------------------------- User CreateUser( in string securityInfo , in string userName , in string password , in string defaultGroup , in DescriptorT descriptor ) raises (InternalException,DuplicateUserName,PasswordNotAllowed,NonexistentGroup) ; //-------------------------------------------------------------------------- // Effect : Creates a new User on the EZF Server. // Error : Exception InternalException containing the errorcode returned by the // EZF server is raised. //-------------------------------------------------------------------------- //-------------------------------------------------------------------------- void ListAllUsers( in string securityInfo , out StringListT userNames ) raises (InternalException) ; //-------------------------------------------------------------------------- // Effect : Returns the list of all EZF users. // Error : Exception InternalException containing the errorcode returned by the // EZF server is raised. //-------------------------------------------------------------------------- // Groups: //-------- //-------------------------------------------------------------------------- Group GetGroup( in string groupName ) raises (InternalException) ; //-------------------------------------------------------------------------- // Effect : Returns an objectreference on the group "groupName". // Error : Exception InternalException containing the errorcode returned by the // EZF server is raised. //-------------------------------------------------------------------------- //-------------------------------------------------------------------------- Group CreateGroup( in string securityInfo , in string groupName , in DescriptorT descriptor ) raises (InternalException,DuplicateGroupName) ; //-------------------------------------------------------------------------- // Effect : Creates a new Group on the EZF Server. // Error : Exception InternalException containing the errorcode returned by the // EZF server is raised. //-------------------------------------------------------------------------- //-------------------------------------------------------------------------- void ListAllGroups( in string securityInfo , out StringListT groupNames ) raises (InternalException) ; //-------------------------------------------------------------------------- // Effect : Returns the list of all EZF groups. // Error : Exception InternalException containing the errorcode returned by the // EZF server is raised. //-------------------------------------------------------------------------- // Locking : //---------- //-------------------------------------------------------------------------- void LockItem( in long transactionId , in string securityInfo , in ObjectIdT itemId , in OperationKindT operationKind ) raises (InternalException,ItemAlreadyLocked) ; //-------------------------------------------------------------------------- // Effect : Locks *this for read or write purpose. // Retval : Returns TRUE, if *this could be locked, FALSE otherwise. // Error : Exception InternalException containing the errorcode returned by the // EZF server is raised. //-------------------------------------------------------------------------- //-------------------------------------------------------------------------- void WaitToLockItem( in long transactionId , in string securityInfo , in ObjectIdT itemId , in OperationKindT operationKind , in long timeout ) raises (InternalException) ; //-------------------------------------------------------------------------- // Effect : Waits until the lock for "operationKind" could be obtained // or that "timeout" seconds ellapsed (0 means infinite). // Retval : Returns TRUE, if *this could be locked, FALSE if timeout // reached. // Error : Exception InternalException containing the errorcode returned by the // EZF server is raised. //-------------------------------------------------------------------------- //-------------------------------------------------------------------------- void UnlockItem( in long transactionId , in string securityInfo , in ObjectIdT itemId , in OperationKindT operationKind ) raises (InternalException) ; //-------------------------------------------------------------------------- // Effect : Unlocks *this. // Error : Exception InternalException containing the errorcode returned by the // EZF server is raised. //-------------------------------------------------------------------------- // External Tables : //------------------ //-------------------------------------------------------------------------- void ModifyExternalTables( in long transactionId , in string securityInfo , in DescriptorT removeDescriptor , in DescriptorT addDescriptor ) raises (InternalException) ; //-------------------------------------------------------------------------- // Requires : Must be transacted ( "transactionId" different from // NoTransaction). // Effect : Modifies values in an external table. // Error : Exception InternalException containing the errorcode returned by the // EZF server is raised. //-------------------------------------------------------------------------- //-------------------------------------------------------------------------- void SearchExternalTables( in long transactionId , in string securityInfo , in CriterionT criterion , inout DescriptorT descriptor ) raises (InternalException) ; //-------------------------------------------------------------------------- // Effect : Searches values from an external table. // Error : Exception InternalException containing the errorcode returned by the // EZF server is raised. //-------------------------------------------------------------------------- // Connection : //------------- //-------------------------------------------------------------------------- void Close( in string securityInfo ) ; //-------------------------------------------------------------------------- // Effect : Closes the connection between a CORBA client and the EZF // server (ordinary client or service client). // All objects created during this connection, and the connection // itself are released (all objectreferences returned to the // client become invalid). //-------------------------------------------------------------------------- //-------------------------------------------------------------------------- void ListConnectedUsers( in string securityInfo , out StringListT userNames ) raises (InternalException) ; //-------------------------------------------------------------------------- // Effect : Returns the list of the connected EZF users. // Error : Exception InternalException containing the errorcode returned by the // EZF server is raised. //-------------------------------------------------------------------------- // Services : //----------- //-------------------------------------------------------------------------- JobHeaderOrItemT GetNextItemToServe( in string securityInfo ) raises (InternalException) ; //-------------------------------------------------------------------------- // Effect : Returns the next item or job waiting in the queue to the // service. // Error : Exception InternalException containing the errorcode returned by the // EZF server is raised. //-------------------------------------------------------------------------- //-------------------------------------------------------------------------- void ReturnServiceResult( in string securityInfo , in long jobNumber , in long itemNumber , in CompletionStatusT status , in ParameterT result ) raises (InternalException) ; //-------------------------------------------------------------------------- // Requires : if "itemNumber" == 0 then "status" and "result" refers to // the job "jobNumber" (job finished) otherwise to the item // "itemNumber". // Effect : Used by a service to return its status. // Error : Exception InternalException containing the errorcode returned by the // EZF server is raised. //-------------------------------------------------------------------------- //-------------------------------------------------------------------------- void GetAvailableServices( in string securityInfo , out ServiceInfoListT serviceInfos ) raises (InternalException) ; //-------------------------------------------------------------------------- // Effect : Returns the list of available services. // Error : Exception InternalException containing the errorcode returned by the // EZF server is raised. //-------------------------------------------------------------------------- //-------------------------------------------------------------------------- long ForwardServiceItems( in string securityInfo , in string serviceName , in ParameterT jobParams , in ItemListT items ) raises (InternalException) ; //-------------------------------------------------------------------------- // Effect : Submits a new job for the service "serviceName". // Retval : jobNumber. // Error : Exception InternalException containing the errorcode returned by the // EZF server is raised. //-------------------------------------------------------------------------- //-------------------------------------------------------------------------- void ListServiceResults( in string securityInfo , in string userName , out JobResultHeaderListT availableResults ) raises (InternalException) ; //-------------------------------------------------------------------------- // Effect : Returns the available service results for "userName". // Error : Exception InternalException containing the errorcode returned by the // EZF server is raised. //-------------------------------------------------------------------------- //-------------------------------------------------------------------------- void GetServiceResult( in string securityInfo , in string serviceName , in long jobNumber , out JobResultT jobResult) raises (InternalException) ; //-------------------------------------------------------------------------- // Effect : Returns the result of the job "jobNumber" handled by the // service "serviceName". // Error : Exception InternalException containing the errorcode returned by the // EZF server is raised. //-------------------------------------------------------------------------- //-------------------------------------------------------------------------- void DestroyServiceResult( in string securityInfo , in string serviceName , in long jobNumber ) raises (InternalException) ; //-------------------------------------------------------------------------- // Effect : Destroys the result of the job "serviceJobNumber" of the // service "serviceName". // Error : Exception InternalException containing the errorcode returned by the // EZF server is raised. //-------------------------------------------------------------------------- //-------------------------------------------------------------------------- void StopService( in string securityInfo , in string serviceName ) raises (InternalException) ; //-------------------------------------------------------------------------- // Effect : Asks the service "serviceName" to stop. // Error : Exception InternalException containing the errorcode returned by the // EZF server is raised. //-------------------------------------------------------------------------- // Notifications : //---------------- //-------------------------------------------------------------------------- void SendMessage( in string securityInfo , in string userName , in string message ) raises (InternalException) ; //-------------------------------------------------------------------------- // Effect : Sends the message "message" to the user "userName". // Error : Exception InternalException containing the errorcode returned by the // EZF server is raised. //-------------------------------------------------------------------------- //-------------------------------------------------------------------------- void SendStructuredMessage( in string securityInfo , in string userName , in ParameterT message ) raises (InternalException) ; //-------------------------------------------------------------------------- // Effect : Sends the structured message "message" to the user "userName". // Error : Exception InternalException containing the errorcode returned by the // EZF server is raised. //-------------------------------------------------------------------------- //-------------------------------------------------------------------------- void SendCloseImmediately( in string securityInfo , in string userName , in string message ) raises (InternalException) ; //-------------------------------------------------------------------------- // Effect : Sends the message "message" to the user "userName". "userName" // has to close the connection immediately after receiving this // message. // Error : Exception InternalException containing the errorcode returned by the // EZF server is raised. //-------------------------------------------------------------------------- //-------------------------------------------------------------------------- void SendCloseASAP( in string securityInfo , in string userName , in string message ) raises (InternalException) ; //-------------------------------------------------------------------------- // Effect : Sends the message "message" to the user "userName". "userName" // has to close the connection shortly after receiving this // message. // Error : Exception InternalException containing the errorcode returned by the // EZF server is raised. //-------------------------------------------------------------------------- } ; // end interface Connection //---------------------------------------------------------------------------- //---------------------------------------------------------------------------- interface EDoc //---------------------------------------------------------------------------- // Purpose: This interface provides all necessary methods to manipulate // EDoc's on the EZF server. //---------------------------------------------------------------------------- { // Type definitions : //------------------- typedef long DocumentTagT ; typedef sequence DocumentTagListT ; // Attributes : //------------- readonly attribute ObjectIdT objectId ; // Methods : //---------- //-------------------------------------------------------------------------- void Release() ; //-------------------------------------------------------------------------- // Effect : Frees all resources occupied by *this. After a successful // invocation this CORBA Objectreference shouldn't be used // anymore. // Error : - //-------------------------------------------------------------------------- //-------------------------------------------------------------------------- void Delete( in long transactionId , in string securityInfo ) raises (InternalException) ; //-------------------------------------------------------------------------- // Requires : Must be transacted ( "transactionId" different from // NoTransaction). // Effect : Deletes *this EDoc on the EZF server. After a successful // invocation this CORBA Objectreference shouldn't be used // anymore. // Error : Exception InternalException containing the errorcode returned by the // EZF server is raised. //-------------------------------------------------------------------------- //-------------------------------------------------------------------------- void PutDescriptor( in long transactionId , in string securityInfo , in DescriptorT removeDescriptor , in DescriptorT addDescriptor ) raises (InternalException) ; //-------------------------------------------------------------------------- // Requires : Must be transacted ( "transactionId" different from // NoTransaction). // Effect : Stores the descriptor part for *this on the EZF server. // Error : Exception InternalException containing the errorcode returned by the // EZF server is raised. //-------------------------------------------------------------------------- //-------------------------------------------------------------------------- void GetDescriptor( in long transactionId , in string securityInfo , inout DescriptorT descriptor) raises (InternalException) ; //-------------------------------------------------------------------------- // Effect : Searches the descriptor part for *this on the EZF server. // Error : Exception InternalException containing the errorcode returned by the // EZF server is raised. //-------------------------------------------------------------------------- //-------------------------------------------------------------------------- void PutContents( in long transactionId , in string securityInfo , in DocumentTagT tag , in RawDataT data) raises (InternalException) ; //-------------------------------------------------------------------------- // Requires : Must be transacted ( "transactionId" different from // NoTransaction). // Effect : Stores the contents part of *this on the EZF server. // Error : Exception InternalException containing the errorcode returned by the // EZF server is raised. //-------------------------------------------------------------------------- //-------------------------------------------------------------------------- void GetContents( in long transactionId , in string securityInfo , in DocumentTagT tag , out RawDataT data ) raises (InternalException) ; //-------------------------------------------------------------------------- // Effect : Searches the contents part of an EDoc. // Error : Exception InternalException containing the errorcode returned by the // EZF server is raised. //-------------------------------------------------------------------------- //-------------------------------------------------------------------------- void GetContentsTags( in long transactionId , in string securityInfo , out DocumentTagListT contentTags ) raises (InternalException) ; //-------------------------------------------------------------------------- // Effect : Returns the list with the content tags of *this. // Error : Exception InternalException containing the errorcode returned by the // EZF server is raised. //-------------------------------------------------------------------------- //-------------------------------------------------------------------------- void DeleteContents( in long transactionId , in string securityInfo , in DocumentTagT tag ) raises (InternalException) ; //-------------------------------------------------------------------------- // Requires : Must be transacted ( "transactionId" different from // NoTransaction). // Effect : Deletes the contents part of *this on the EZF server. // Error : Exception InternalException containing the errorcode returned by the // EZF server is raised. //-------------------------------------------------------------------------- //-------------------------------------------------------------------------- void MoveContents( in long transactionId , in string securityInfo , in DocumentTagT tag , in ObjectIdT toEDocId , in DocumentTagT toTag ) raises (InternalException) ; //-------------------------------------------------------------------------- // Requires : Must be transacted ( "transactionId" different from // NoTransaction). // Effect : Moves the contents part of *this to an other EDoc "toEDocId". // Error : Exception InternalException containing the errorcode returned by the // EZF server is raised. //-------------------------------------------------------------------------- //-------------------------------------------------------------------------- ObjectIdT GetContainer( in long transactionId , in string securityInfo ) raises (InternalException) ; //-------------------------------------------------------------------------- // Effect : Searches the container Doc of *this. // Error : Exception InternalException containing the errorcode returned by the // EZF server is raised. //-------------------------------------------------------------------------- } ; // end interface EDoc //---------------------------------------------------------------------------- //---------------------------------------------------------------------------- interface Doc //---------------------------------------------------------------------------- // Purpose: This interface provides all necessary methods to manipulate // Doc's on the EZF server. //---------------------------------------------------------------------------- { // Type definitions : //------------------- typedef long EDocPositionT ; // Position of an EDoc in a Doc struct EDocIdAndPositionT { // represents the id and the position of an EDoc ObjectIdT objectId ; EDocPositionT position ; } ; typedef sequence EDocIdAndPositionListT ; // Attributes : //------------- readonly attribute ObjectIdT objectId ; // Methods : //---------- //-------------------------------------------------------------------------- void Release() ; //-------------------------------------------------------------------------- // Effect : Frees all resources occupied by *this. After a successful // invocation this CORBA Objectreference shouldn't be used // anymore. // Error : - //-------------------------------------------------------------------------- //-------------------------------------------------------------------------- void Delete( in long transactionId , in string securityInfo ) raises (InternalException) ; //-------------------------------------------------------------------------- // Requires : Must be transacted ( "transactionId" different from // NoTransaction). // Effect : Deletes *this Doc on the EZF server. After a successful // invocation this CORBA Objectreference shouldn't be used // anymore. // Error : Exception InternalException containing the errorcode returned by the // EZF server is raised. //-------------------------------------------------------------------------- //-------------------------------------------------------------------------- void PutDescriptor( in long transactionId , in string securityInfo , in DescriptorT removeDescriptor , in DescriptorT addDescriptor ) raises (InternalException) ; //-------------------------------------------------------------------------- // Requires : Must be transacted ( "transactionId" different from // NoTransaction). // Effect : Stores the descriptor part for *this on the EZF server. // Error : Exception InternalException containing the errorcode returned by the // EZF server is raised. //-------------------------------------------------------------------------- //-------------------------------------------------------------------------- void GetDescriptor( in long transactionId , in string securityInfo , inout DescriptorT descriptor ) raises (InternalException) ; //-------------------------------------------------------------------------- // Effect : Searches the descriptor part for *this on the EZF server. // Error : Exception InternalException containing the errorcode returned by the // EZF server is raised. //-------------------------------------------------------------------------- //-------------------------------------------------------------------------- void InsertEDoc( in long transactionId , in string securityInfo , in ObjectIdT whichEDoc , in EDocPositionT position ) raises (InternalException) ; //-------------------------------------------------------------------------- // Requires : Must be transacted ( "transactionId" different from // NoTransaction). // Effect : Inserts an EDoc at "position" into *this. // Error : Exception InternalException containing the errorcode returned by the // EZF server is raised. //-------------------------------------------------------------------------- //-------------------------------------------------------------------------- void RemoveEDoc( in long transactionId , in string securityInfo , in ObjectIdT whichEDoc ) raises (InternalException) ; //-------------------------------------------------------------------------- // Requires : Must be transacted ( "transactionId" different from // NoTransaction). // Effect : Removes the EDoc "whichEDoc" from *this. // Error : Exception InternalException containing the errorcode returned by the // EZF server is raised. //-------------------------------------------------------------------------- //-------------------------------------------------------------------------- void MoveEDoc( in long transactionId , in string securityInfo , in ObjectIdT whichEDoc , in ObjectIdT targetDoc, in EDocPositionT targetPosition ) raises (InternalException) ; //-------------------------------------------------------------------------- // Requires : Must be transacted ( "transactionId" different from // NoTransaction). // Effect : Removes the EDoc "whichEDoc" from *this and adds it at // "targetPosition" to the Doc "targetDoc". // Error : Exception InternalException containing the errorcode returned by the // EZF server is raised. //-------------------------------------------------------------------------- //-------------------------------------------------------------------------- long GetNumberOfEDocs( in long transactionId , in string securityInfo ) raises (InternalException) ; //-------------------------------------------------------------------------- // Effect : Returns the number of EDocs of *this. // Error : Exception InternalException containing the errorcode returned by the // EZF server is raised. //-------------------------------------------------------------------------- //-------------------------------------------------------------------------- void GetEDocs( in long transactionId , in string securityInfo , in boolean loadThem , out EDocIdAndPositionListT theEDocs ) raises (InternalException) ; //-------------------------------------------------------------------------- // Effect : Returns the list with all EDocs of *this. // Error : Exception InternalException containing the errorcode returned by the // EZF server is raised. //-------------------------------------------------------------------------- //-------------------------------------------------------------------------- void GetEDocsWithDescriptor( in long transactionId , in string securityInfo , in boolean loadThem , inout DescriptorT descriptor ) raises (InternalException) ; //-------------------------------------------------------------------------- // Effect : Searches the EDocs and their descriptor in *this. // Error : Exception InternalException containing the errorcode returned by the // EZF server is raised. //-------------------------------------------------------------------------- //-------------------------------------------------------------------------- void GetContainers( in long transactionId , in string securityInfo , out ObjectIdListT folderIdList ) raises (InternalException) ; //-------------------------------------------------------------------------- // Effect : Returns the list of folders containing *this. // Error : Exception InternalException containing the errorcode returned by the // EZF server is raised. //-------------------------------------------------------------------------- //-------------------------------------------------------------------------- void GetContainersWithDescriptor( in long transactionId , in string securityInfo , inout DescriptorT descriptor ) raises (InternalException) ; //-------------------------------------------------------------------------- // Effect : Returns the descriptor values of folders containing *this. // Error : Exception InternalException containing the errorcode returned by the // EZF server is raised. //-------------------------------------------------------------------------- } ; // end interface Doc //---------------------------------------------------------------------------- //---------------------------------------------------------------------------- interface Folder { // Attributes : //------------- readonly attribute ObjectIdT objectId ; // Methods : //---------- //-------------------------------------------------------------------------- void Release() ; //-------------------------------------------------------------------------- // Effect : Frees all resources occupied by *this. After a successful // invocation this CORBA Objectreference shouldn't be used // anymore. //-------------------------------------------------------------------------- //-------------------------------------------------------------------------- void Delete( in long transactionId , in string securityInfo ) raises (InternalException) ; //-------------------------------------------------------------------------- // Requires : Must be transacted ( "transactionId" different from // NoTransaction). // Effect : Deletes *this EDoc on the EZF server. After a successful // invocation this CORBA Objectreference shouldn't be used // anymore. // Error : Exception InternalException containing the errorcode returned by the // EZF server is raised. //-------------------------------------------------------------------------- //-------------------------------------------------------------------------- void PutDescriptor( in long transactionId , in string securityInfo , in DescriptorT removeDescriptor , in DescriptorT addDescriptor ) raises (InternalException) ; //-------------------------------------------------------------------------- // Requires : Must be transacted ( "transactionId" different from // NoTransaction). // Effect : Stores the descriptor part for *this on the EZF server. // Error : Exception InternalException containing the errorcode returned by the // EZF server is raised. //-------------------------------------------------------------------------- //-------------------------------------------------------------------------- void GetDescriptor( in long transactionId , in string securityInfo , inout DescriptorT descriptor ) raises (InternalException) ; //-------------------------------------------------------------------------- // Effect : Searches the descriptor part for *this on the EZF server. // Error : Exception InternalException containing the errorcode returned by the // EZF server is raised. //-------------------------------------------------------------------------- //-------------------------------------------------------------------------- void InsertItem( in long transactionId , in string securityInfo , in ObjectIdT item ) raises (InternalException) ; //-------------------------------------------------------------------------- // Requires : Must be transacted ( "transactionId" different from // NoTransaction). // Effect : Inserts a Doc or a Folder ("item") into *this. // Error : Exception InternalException containing the errorcode returned by the // EZF server is raised. //-------------------------------------------------------------------------- //-------------------------------------------------------------------------- void RemoveItem( in long transactionId , in string securityInfo , in ObjectIdT whichItem ) raises (InternalException) ; //-------------------------------------------------------------------------- // Requires : Must be transacted ( "transactionId" different from // NoTransaction). // Effect : Removes the item "whichItem" (Doc or Folder) from *this. // Error : Exception InternalException containing the errorcode returned by the // EZF server is raised. //-------------------------------------------------------------------------- //-------------------------------------------------------------------------- short GetNumberOfItems( in long transactionId , in string securityInfo ) raises (InternalException) ; //-------------------------------------------------------------------------- // Effect : Returns the number of items (Folders and Docs) of *this. // Error : Exception InternalException containing the errorcode returned by the // EZF server is raised. //-------------------------------------------------------------------------- //-------------------------------------------------------------------------- void GetItems( in long transactionId , in string securityInfo , out ObjectIdListT theItems ) raises (InternalException) ; //-------------------------------------------------------------------------- // Effect : Returns the list with all items (Docs and Folders) of *this. // Error : Exception InternalException containing the errorcode returned by the // EZF server is raised. //-------------------------------------------------------------------------- //-------------------------------------------------------------------------- void GetItemsWithDescriptor( in long transactionId , in string securityInfo , in ItemKindT itemKind , inout DescriptorT descriptor ) raises (InternalException) ; //-------------------------------------------------------------------------- // Effect : Searches the items and their descriptor in *this. // Error : Exception InternalException containing the errorcode returned by the // EZF server is raised. //-------------------------------------------------------------------------- //-------------------------------------------------------------------------- void GetContainers( in long transactionId , in string securityInfo , out ObjectIdListT folderIdList ) raises (InternalException) ; //-------------------------------------------------------------------------- // Effect : Returns the list of folders containing *this. // Error : Exception InternalException containing the errorcode returned by the // EZF server is raised. //-------------------------------------------------------------------------- //-------------------------------------------------------------------------- void GetContainersWithDescriptor( in long transactionId , in string securityInfo , inout DescriptorT descriptor ) raises (InternalException) ; //-------------------------------------------------------------------------- // Effect : Returns the descriptor values of folders containing *this. // Error : Exception InternalException containing the errorcode returned by the // EZF server is raised. //-------------------------------------------------------------------------- } ; // end interface Folder //---------------------------------------------------------------------------- //---------------------------------------------------------------------------- interface Searcher //---------------------------------------------------------------------------- // Purpose: This interface provides all necessary methods to manipulate // searcher's on the EZF server. //---------------------------------------------------------------------------- { // Attributes : //------------- readonly attribute ObjectIdT objectId ; // Methods : //---------- //-------------------------------------------------------------------------- void Release() ; //-------------------------------------------------------------------------- // Effect : Frees all resources occupied by *this. After a successful // invocation this CORBA Objectreference shouldn't be used // anymore. // Error : - //-------------------------------------------------------------------------- //-------------------------------------------------------------------------- void Delete( in long transactionId , in string securityInfo ) raises (InternalException) ; //-------------------------------------------------------------------------- // Requires : Must be transacted ( "transactionId" different from // NoTransaction). // Effect : Deletes *this Searcher on the EZF server. After a successful // invocation this CORBA Objectreference shouldn't be used // anymore. // Error : Exception InternalException containing the errorcode returned by the // EZF server is raised. //-------------------------------------------------------------------------- //-------------------------------------------------------------------------- void PutSearchCriterion( in long transactionId , in string securityInfo , in ItemKindT kind , in CriterionT newCriterion ) raises (InternalException) ; //-------------------------------------------------------------------------- // Requires : Must be transacted ( "transactionId" different from // NoTransaction). // Effect : Changes the criterion of *this to "newCriterion". // Error : Exception InternalException containing the errorcode returned by the // EZF server is raised. //-------------------------------------------------------------------------- //-------------------------------------------------------------------------- void GetSearchCriterion( in long transactionId , in string securityInfo , out ItemKindT kind , out CriterionT criterion ) raises (InternalException) ; //-------------------------------------------------------------------------- // Effect : Returns the criterion of *this. // Error : Exception InternalException containing the errorcode returned by the // EZF server is raised. //-------------------------------------------------------------------------- //-------------------------------------------------------------------------- void GetItems( in long transactionId , in string securityInfo , out ObjectIdListT objectList ) raises (InternalException) ; //-------------------------------------------------------------------------- // Effect : Searches the items corresponding to this->criterion. // Error : Exception InternalException containing the errorcode returned by the // EZF server is raised. //-------------------------------------------------------------------------- //-------------------------------------------------------------------------- void GetItemsWithDescriptor( in long transactionId , in string securityInfo , inout DescriptorT descriptor ) raises (InternalException) ; //-------------------------------------------------------------------------- // Effect : Searches the items corresponding to this->criterion. // Error : Exception InternalException containing the errorcode returned by the // EZF server is raised. //-------------------------------------------------------------------------- } ; // end interface Searcher //---------------------------------------------------------------------------- //---------------------------------------------------------------------------- interface User //---------------------------------------------------------------------------- // Purpose: This interface provides all necessary methods to manipulate // EZF users. //---------------------------------------------------------------------------- { // Attributes : //------------- readonly attribute string name ; // Methods : //---------- //-------------------------------------------------------------------------- void Release() ; //-------------------------------------------------------------------------- // Effect : Frees all resources occupied by *this. After a successful // invocation this CORBA Objectreference shouldn't be used // anymore. // Error : - //-------------------------------------------------------------------------- //-------------------------------------------------------------------------- void Delete( in string securityInfo ) raises (InternalException) ; //-------------------------------------------------------------------------- // Effect : Deletes *this user on the EZF server. After a successful // invocation this CORBA Objectreference shouldn't be used // anymore. // Error : Exception InternalException containing the errorcode returned by the // EZF server is raised. //-------------------------------------------------------------------------- //-------------------------------------------------------------------------- void Rename( in string securityInfo , in string newName ) raises (InternalException,DuplicateUserName) ; //-------------------------------------------------------------------------- // Effect : Changes the name of *this to "newName". // Error : Exception InternalException containing the errorcode returned by the // EZF server is raised. //-------------------------------------------------------------------------- //-------------------------------------------------------------------------- void ChangePassword( in string securityInfo , in string oldPassword , in string newPassword ) raises (InternalException,PasswordNotAllowed) ; //-------------------------------------------------------------------------- // Effect : Changes the password of *this to "newPassword". // Error : Exception InternalException containing the errorcode returned by the // EZF server is raised. //-------------------------------------------------------------------------- //-------------------------------------------------------------------------- void SetDefaultGroup( in string securityInfo , in string groupName ) raises (InternalException) ; //-------------------------------------------------------------------------- // Effect : Sets the default group of *this to "groupName". // Error : Exception InternalException containing the errorcode returned by the // EZF server is raised. //-------------------------------------------------------------------------- //-------------------------------------------------------------------------- void GetDefaultGroup( in string securityInfo , out string groupName ) raises (InternalException) ; //-------------------------------------------------------------------------- // Effect : Returns in "groupName" the default group of *this. // Error : Exception InternalException containing the errorcode returned by the // EZF server is raised. //-------------------------------------------------------------------------- //-------------------------------------------------------------------------- void PutDescriptor( in string securityInfo , in DescriptorT removeDescriptor , in DescriptorT addDescriptor ) raises (InternalException) ; //-------------------------------------------------------------------------- // Effect : Stores the descriptor part for *this on the EZF server. // Error : Exception InternalException containing the errorcode returned by the // EZF server is raised. //-------------------------------------------------------------------------- //-------------------------------------------------------------------------- void GetDescriptor( in string securityInfo , inout DescriptorT fieldsToSearch ) raises (InternalException) ; //-------------------------------------------------------------------------- // Effect : Searches the descriptor part for *this on the EZF server. // Error : Exception InternalException containing the errorcode returned by the // EZF server is raised. //-------------------------------------------------------------------------- //-------------------------------------------------------------------------- boolean IsSuperuser( in string securityInfo ) raises (InternalException) ; //-------------------------------------------------------------------------- // Effect : Returns TRUE, if *this is a superuser, FALSE otherwise. // Error : Exception InternalException containing the errorcode returned by the // EZF server is raised. //-------------------------------------------------------------------------- //-------------------------------------------------------------------------- void GetContainers( in string securityInfo , out StringListT groupNames ) raises (InternalException) ; //-------------------------------------------------------------------------- // Effect : Returns the list with all groups having *this as member. // Error : Exception InternalException containing the errorcode returned by the // EZF server is raised. //-------------------------------------------------------------------------- } ; // end interface User //---------------------------------------------------------------------------- //---------------------------------------------------------------------------- interface Group //---------------------------------------------------------------------------- // Purpose: This interface provides all necessary methods to manipulate // EZF groups. //---------------------------------------------------------------------------- { // Attributes : //------------- readonly attribute string name ; // Methods : //---------- //-------------------------------------------------------------------------- void Release() ; //-------------------------------------------------------------------------- // Effect : Frees all resources used by *this. After a successful // invocation this CORBA Objectreference shouldn't be used // anymore. //-------------------------------------------------------------------------- //-------------------------------------------------------------------------- void Delete( in string securityInfo ) raises (InternalException) ; //-------------------------------------------------------------------------- // Effect : Deletes *this group on the EZF server. After a successful // invocation this CORBA Objectreference shouldn't be used // anymore. // Error : Exception InternalException containing the errorcode returned by the // EZF server is raised. //-------------------------------------------------------------------------- //-------------------------------------------------------------------------- void Rename( in string securityInfo , in string newName ) raises (InternalException,DuplicateGroupName) ; //-------------------------------------------------------------------------- // Effect : Changes the name of *this to "newName". // Error : Exception InternalException containing the errorcode returned by the // EZF server is raised. //-------------------------------------------------------------------------- //-------------------------------------------------------------------------- void PutDescriptor( in string securityInfo , in DescriptorT removeDescriptor , in DescriptorT addDescriptor ) raises (InternalException) ; //-------------------------------------------------------------------------- // Effect : Stores the descriptor part for *this on the EZF server. // Error : Exception InternalException containing the errorcode returned by the // EZF server is raised. //-------------------------------------------------------------------------- //-------------------------------------------------------------------------- void GetDescriptor( in string securityInfo , inout DescriptorT descriptor) raises (InternalException) ; //-------------------------------------------------------------------------- // Effect : Searches the descriptor part for *this on the EZF server. // Error : Exception InternalException containing the errorcode returned by the // EZF server is raised. //-------------------------------------------------------------------------- //-------------------------------------------------------------------------- void InsertUser( in string securityInfo , in string userName ) raises (InternalException) ; //-------------------------------------------------------------------------- // Effect : Inserts the user "userName" to *this. // Error : Exception InternalException containing the errorcode returned by the // EZF server is raised. //-------------------------------------------------------------------------- //-------------------------------------------------------------------------- void InsertGroup( in string securityInfo , in string groupName ) raises (InternalException,CircularGroupInclusion) ; //-------------------------------------------------------------------------- // Effect : Inserts the group "groupName" to *this. // Error : Exception InternalException containing the errorcode returned by the // EZF server is raised. //-------------------------------------------------------------------------- //-------------------------------------------------------------------------- void RemoveUser( in string securityInfo , in string userName ) raises (InternalException) ; //-------------------------------------------------------------------------- // Effect : Removes the user "userName" from *this. // Error : Exception InternalException containing the errorcode returned by the // EZF server is raised. //-------------------------------------------------------------------------- //-------------------------------------------------------------------------- void RemoveGroup( in string securityInfo , in string groupName ) raises (InternalException) ; //-------------------------------------------------------------------------- // Effect : Removes the group "groupName" from *this. // Error : Exception InternalException containing the errorcode returned by the // EZF server is raised. //-------------------------------------------------------------------------- //-------------------------------------------------------------------------- void GetMembers( in string securityInfo , out GroupMemberListT members ) raises (InternalException) ; //-------------------------------------------------------------------------- // Effect : Returns the list with the user and group members of *this. // Error : Exception InternalException containing the errorcode returned by the // EZF server is raised. //-------------------------------------------------------------------------- //-------------------------------------------------------------------------- void GetContainers( in string securityInfo , out StringListT groupNames ) raises (InternalException) ; //-------------------------------------------------------------------------- // Effect : Returns the list with all groups having *this as member. // Error : Exception InternalException containing the errorcode returned by the // EZF server is raised. //-------------------------------------------------------------------------- //-------------------------------------------------------------------------- boolean IsSupergroup( in string securityInfo ) raises (InternalException) ; //-------------------------------------------------------------------------- // Effect : Returns TRUE, if *this is a supergroup, FALSE otherwise. // Error : Exception InternalException containing the errorcode returned by the // EZF server is raised. //-------------------------------------------------------------------------- } ; // end interface Group //---------------------------------------------------------------------------- //---------------------------------------------------------------------------- interface Notifier //---------------------------------------------------------------------------- // Purpose: This ineterface is used by an CORBA EZF service to communicate // with the EZF server. //---------------------------------------------------------------------------- { //-------------------------------------------------------------------------- oneway void Notify( in NotificationT message ) ; //-------------------------------------------------------------------------- // Effect : Sends the notification "message". //-------------------------------------------------------------------------- } ; // end interface Notifier //---------------------------------------------------------------------------- } ; // end module server_operations; }; // end module easyfile; //------------------------------------------------------------------------------ //------------------------------------------------------------------------------ // end file server_operations.idl //------------------------------------------------------------------------------ polyorb-2.8~20110207.orig/compilers/idlac/testsuite/import/0000755000175000017500000000000011750740340023016 5ustar xavierxavierpolyorb-2.8~20110207.orig/compilers/idlac/testsuite/import/T2.idl0000644000175000017500000000002211750740337023775 0ustar xavierxavier interface T2 {}; polyorb-2.8~20110207.orig/compilers/idlac/testsuite/import/T1.idl0000644000175000017500000000005511750740337024002 0ustar xavierxavier import ::T2; import ::T3; interface T1 {}; polyorb-2.8~20110207.orig/compilers/idlac/testsuite/import/test004.idl0000644000175000017500000000011211750740337024713 0ustar xavierxavier import ::test0041; import ::test0042; interface Test004 : Test0042 { }; polyorb-2.8~20110207.orig/compilers/idlac/testsuite/import/T3.idl0000644000175000017500000000004011750740337023776 0ustar xavierxavier import ::T2; interface T3 {}; polyorb-2.8~20110207.orig/compilers/idlac/testsuite/import/test0042.idl0000644000175000017500000000003011750740337024774 0ustar xavierxavier interface Test0042 {}; polyorb-2.8~20110207.orig/compilers/idlac/testsuite/parser/0000755000175000017500000000000011750740340023000 5ustar xavierxavierpolyorb-2.8~20110207.orig/compilers/idlac/testsuite/parser/testparser.idl0000644000175000017500000002346711750740337025710 0ustar xavierxavier/******************************************************** This file is meant to try every error message that the idl front-end can generate. These errors are tested rule by rule. *********************************************************/ /************************/ /* First, try each rule */ /************************/ /*** Test of rule 1 ***/ // An empty specification may be tested since it is not permitted /*** Test of rule 2 ***/ Error abstract Error module mymodule {} /*** Test of rule 3 ***/ module module toto module toto {}; module toto {}; /*** Test of rule 4 through 7 ***/ /* Test of rule Interface1 & 2 &3 */ interface interface tata; interface tata; interface tata interface tata{}; interface tutu{}; interface tata; interface titi{} abstract interface to; interface to{}; abstract interface tu{}; interface tirli : to, to {}; /* test of rule 11 */ interface int1 : toto {}; /* test of rule 12 */ interface i : { const long a = 5;}; typedef does_not_exist a1; const long not_a_scope = 5; typedef not_a_scope::l a2; interface ii { const long a = 5;}; typedef ii:: ; typedef ii::does_not_exist a3; typedef ii::a::b a4; struct structA { structA s; }; /*** Test of rule 13 through 26 ***/ /* Test of rule Value2 */ custom custom valuetype /* Test of rule Value3 */ abstract abstract valuetype abstract valuetype toto /* Test of rule Value4 */ valuetype valuetype toto /* Test of rule Value5 & Value6 */ valuetype toto {}; //valuetype titi supports toto /* Test of rule Value7 */ valuetype toto; valuetype forward_value; valuetype forward_value; /* Test of rule Value8 */ valuetype forward_value long; valuetype toto long; valuetype rightboxedvalue long; //valuetype FooSeq sequence ; /* Test of rule 19 */ /* test errors */ abstract valuetype value1 {}; abstract valuetype value2 : truncatable value1 {}; custom valuetype value3 : truncatable value1 {}; valuetype value4 {}; abstract valuetype value5 : value4 {}; valuetype value6 : truncatable value1 {}; valuetype value7; valuetype value8 : value7 {}; valuetype value9 long; valuetype value10 : value9 {}; interface valueinterface1 {}; valuetype value11 : valueinterface1 {}; valuetype value12 : {}; valuetype value13 : value1, value1 {}; valuetype value14 : value4, value4 {}; valuetype value15 : value4, value7 {}; valuetype value16 : value4, value9 {}; valuetype value17 : value4, valueinterface1 {}; valuetype value18 : value4, {}; interface valueinterface2; valuetype value19 supports valueinterface2 {}; valuetype value20 supports value4 {}; valuetype value21 supports {}; interface valueinterface3 {}; valuetype value22 supports valueinterface1, valueinterface3 {}; valuetype value23 supports valueinterface1, valueinterface2 {}; valuetype value24 supports valueinterface1, value4 {}; valuetype value25 supports valueinterface1, {}; valuetype value26 : value1, value1 Error {}; abstract interface valueinterface4 {}; valuetype value27 : value1, value1 supports valueinterface4, valueinterface4 {}; /* Test of rule 20 */ valuetype value27 : toto {}; /* Test of rule 21 */ valuetype value45 { Error }; /* Test of rule 22 */ valuetype value45 { private long[5] }; /* Test of rule 23 */ valuetype value46 { factory factory factory1 (); factory factory1 (); factory factory2 factory factory3 (; factory factory4 () }; /* Test of rule 25 */ valuetype value47 { factory factory1 (out long l); factory factory2 (long l); factory factory3 (Error); factory factory4 (out long l, out l ll); }; /* Test of rule 27 */ const boolean; const boolean const1 = TRUE; const boolean const1 = TRUE; const boolean const2 TRUE; const boolean const3; /* Test of rule 28 */ typedef any any1; const any1 const4 = TRUE; const error; const toto a = 6; /* Test of rule 29 */ const short const5 = 65000; const unsigned short const6 = -17; const long const7 = 4000000000; const unsigned long const8 = -17; /* Test of rule 30 */ const short const9 = 3 | 4; /* Test of rule 31 */ const short const10 = 3 ^ 4; /* Test of rule 32 */ const short const11 = 3 & 4; /* Test of rule 33 */ const short const12 = 3 << 4; const short const13 = 3 >> 4; /* Test of rule 34 */ const short const14 = 3 + 4; const short const15 = 3 - 4; /* Test of rule 35 */ const short const16 = 3 * 4; const short const17 = 3 / 4; const short const18 = 3 % 4; /* Test of rule 36-37 */ const short const19 = -3; const short const20 = +3; const short const21 = ~3; /* Test of rule 38 */ const wchar const22 = L'X'; const wstring const23 = L"Wide string"; const fixed const24 = 4.05d; const short const25 = ( 3 ; const short const26 = const; const short const26 = toto; /* Test of rule 39 */ // nothing to be tested /* Test of rule 40 */ // nothing to be tested /* Test of rule 44 */ valuetype value48 { private Error; }; /* Test of Rule 45 */ typedef sequence <>; interface not_a_type { void echo (); }; typedef not_a_type type1; /* Test of rule 50 */ union union1 switch (boolean) { case TRUE : long ; default : short short1; }; /* Test of rule 51 */ valuetype value49 { factory factory1 (in long); factory factory1 (in long l, in short l); }; /* Test of rule 59 */ unsigned Error; /* Test of rule 69 */ struct { long i;}; struct struct1 { long i; }; struct struct1 { long i; }; struct struct3 { long struct1; }; struct struct3 {; struct struct4 { long struct4; }; /* Test of rule 70 */ struct struct5 {}; /* Test of rule 71 */ struct struct6 { long i }; /* Test of rule 72 */ union; union union1 switch (boolean) { case true : long i; }; union union1 switch (boolean) { case true : long i; }; union union2; union union3 switch; union union4 switch (boolean {}; union union5 switch (boolean); union union6 switch (boolean) { case true : long i; ; /* Test of rule 73 */ union union7 switch (error) { case true : long i; }; typedef string string1; union union8 switch (string1) { case true : long i; }; /* Test of rule 74 */ union union9 switch (boolean) { }; union union10 switch (boolean) { default : long i; default : short j; }; /* Test of rule 75 */ union union11 switch (boolean) { error }; union union12 switch (boolean) { case true : long i }; /* Test of rule 76 */ union union13 switch (boolean) { case true : long i; case true : long j; }; union union14 switch (boolean) { case true long k; }; /* Test of rule 78 */ enum; enum enum1 { male, female }; enum enum1 { male, female }; enum enum2; enum enum3 {}; enum enum4 { male, female ; /* Test of rule 79 */ enum enum5 { , id }; enum enum6 { male , female }; /* Test of rule 80 */ typedef sequence sequence1; typedef sequence > sequence4; typedef sequence > sequence5; /* Test of rule 81 */ typedef string <10 string1; /* Test of rule 82 */ typedef wstring <10 wstring1; /* Test of rule 83 */ typedef boolean array1[2]; typedef boolean array1[2]; /* Test of rule 84 */ typedef boolean array2[3; /* Test of rule 85 */ interface toitoi{ attribute; readonly error; readonly attribute error; readonly attribute long; readonly attribute blurp; readonly attribute long titi; readonly attribute long titi; readonly attribute long tutu, trotro; readonly attribute long tutu,; attribute string abab, obob; }; /* Test of rule 86 */ exception; exception etoto1; exception etoto3}; exception etoto4{}; exception etoto4{}; exception etoto5{lbl}; exception etoto6{long }; exception etoto7{long truc}; exception etoto8{long truc;}; exception etoto8{long etoto8;}; /* Test of rule 87 */ boolean; oneway boolean; boolean op1 (); boolean op1 (); /* Test of rule 89 */ oneway error; /* Test of rule 90 */ boolean op2; boolean op3 (; /* Test of rule 91 */ boolean op4 (boolean); boolean op5 (error); /* Test of rule 92 */ boolean op6 (boolean b); /* Test of rule 93 */ boolean op7 () raises; boolean op8 () raises (); boolean op9 raises (; const long const27 = 5; boolean op10 raises (const27); /* Test of rule 94 */ boolean op11 () context; boolean op12 () context (); boolean op13 context (; /* Test of rule 95 */ boolean op14 (inout error); boolean op14 (inout toto); /* Test of rule 96 */ typedef fixed fixed1; typedef fixed <6> fixed2; typedef fixed <6,7 fixed3; /* Test of check_context_string */ boolean op15 () context ("0error"); boolean op16 () context ("eréror"); boolean op17 () context ("err*or"); boolean op18 () context ("erroré"); /* Test of eval_or_expr */ const integer c1 = TRUE | 2; const integer c2 = 2 | true; const integer c3 = 3 | -5; const integer c4 = 10000000 | -5; /*******************************/ /* Now, try each miscellaneous */ /* point of the Idl langage */ /*******************************/ // non defined forwarded interface and valuetype module moduleA { valuetype valuetype1; interface interface1; }; // recursive structures module moduleB { typedef short typeA; interface interfaceA { typedef short typeC; typedef moduleB::interfaceA::typeC typeD; }; }; // multiple inheritance management // in case of interfaces interface i1 { typedef long type1; const long const1 = 5; exception e {}; }; interface i2 { typedef short type1; const long const1 = 7; exception e {}; }; interface i3 : i1, i2 { typedef type1 type2; const long const2 = const1; void echo () raises (e); }; interface i4 { attribute long l; void echo (); }; interface i5 : i4 { attribute long l; void echo (long arg); }; interface i6 { attribute long l; void echo (); }; interface i7 : i4, i6 {}; // multiple inheritance management // in case of valuetypes valuetype v1 { typedef long type1; const long const1 = 5; exception e {}; }; abstract valuetype v2 { typedef short type1; const long const1 = 7; exception e {}; }; valuetype v3 : v1, v2 { typedef type1 type2; const long const2 = const1; void echo () raises (e); }; valuetype v4 { attribute long l; void echo (); }; valuetype v5 : v4 { attribute long l; void echo (long arg); }; polyorb-2.8~20110207.orig/compilers/idlac/testsuite/parser/allerrors.idl0000644000175000017500000010732011750740337025510 0ustar xavierxavier/******************************************************** This file is meant to try every error message that the idl front-end can generate. These errors are tested rule by rule. *********************************************************/ /************************/ /* First, try each rule */ /************************/ /*** Test of rule 1 ***/ // An empty specification may be tested since it is not permitted /*** Test of rule 2 ***/ // not a definition Error // just to resume the parsing on a right definition interface resume1 {}; // ';' forgotten interface interface1 {} // just to resume the parsing on a right definition interface resume2 {}; /*** Test of rule 3 ***/ // identifier forgotten module // just to resume the parsing on a right definition interface resume3 {}; // '{' forgotten module module2 // just to resume the parsing on a right definition interface resume4 {}; // an empty module (not allowed) module module3 {}; // '}' forgotten module module4 {;}; // just to resume the parsing on a right definition interface resume5 {}; /*** Test of rule 4 ***/ // nothing to test here /*** Test of rule 5 ***/ // '{' forgotten interface interface2 ERROR // just to resume the parsing on a right definition interface resume6 {}; // '}' forgotten interface interface3 {;}; // just to resume the parsing on a right definition interface resume7 {}; /*** Test of rule 6 ***/ // "interface" forgotten abstract ERROR // just to resume the parsing on a right definition interface resume8 {}; // identifier forgotten interface; // just to resume the parsing on a right definition interface resume9 {}; // identifier forgotten abstract interface; // just to resume the parsing on a right definition interface resume10 {}; /*** Test of rule 7 ***/ // "interface" forgotten abstract ERROR // just to resume the parsing on a right definition interface resume11 {}; // identifier forgotten interface; // just to resume the parsing on a right definition interface resume12 {}; // identifier forgotten abstract interface; // just to resume the parsing on a right definition interface resume13 {}; /*** Test of rule 8 ***/ // not an export interface interface4 { ERROR }; /*** Test of rule 9 ***/ // ';' forgotten at the end of an export interface interface5 { const long const1 = 5 }; /*** test of rule 10 ***/ // forgotten interface name interface interface6 : {}; // just to resume the parsing on a right definition interface resume14 {}; // forgotten interface name too interface interface7 {}; interface interface8 : interface7, {}; // just to resume the parsing on a right definition interface resume15 {}; /*** test of rule 11 ***/ // an interface name should denote an interface const long const1 = 5; interface interface9 : const1 {}; /*** test of rule 12 ***/ // identifier forgotten interface interface10 : ::; // just to resume the parsing on a right definition interface resume16 {}; // identifier forgotten too interface interface11 {}; interface interface12 : interface11::; // just to resume the parsing on a right definition interface resume17 {}; /*** Test of rule 13 ***/ // nothing to test here /*** Test of rule 14 ***/ // "valuetype" forgotten abstract ERROR // just to resume the parsing on a right definition interface resume18 {}; // identifier forgotten valuetype; // just to resume the parsing on a right definition interface resume19 {}; // identifier forgotten abstract valuetype; // just to resume the parsing on a right definition interface resume20 {}; /*** Test of rule 15 ***/ // identifier forgotten valuetype; // just to resume the parsing on a right definition interface resume21 {}; /*** Test of rule 16 ***/ // "valuetype" forgotten abstract ERROR // just to resume the parsing on a right definition interface resume23 {}; // identifier forgotten abstract valuetype; // just to resume the parsing on a right definition interface resume24 {}; // inheritance or '{' forgotten abstract valuetype valuetype2 ERROR // just to resume the parsing on a right definition interface resume25 {}; // '}' forgotten abstract valuetype valuetype3 { ERROR }; // just to resume the parsing on a right definition interface resume26 {}; /*** Test of rule 17 ***/ // '{' forgotten custom valuetype valuetype4 ERROR // just to resume the parsing on a right definition interface resume27 {}; // '}' forgotten custom valuetype valuetype5 { ERROR }; // just to resume the parsing on a right definition interface resume28 {}; /*** Test of rule 18 ***/ // valuetype forgotten custom ERROR // just to resume the parsing on a right definition interface resume29 {}; // identifier forgotten valuetype // just to resume the parsing on a right definition interface resume30 {}; // identifier forgotten custom valuetype // just to resume the parsing on a right definition interface resume31 {}; // inheritance or '{' forgotten valuetype valuetype6 ERROR // just to resume the parsing on a right definition interface resume32 {}; // inheritance or '{' forgotten custom valuetype valuetype7 ERROR // just to resume the parsing on a right definition interface resume33 {}; /*** Test of rule 19 ***/ // value_name forgotten valuetype valuetype8 : {}; // just to resume the parsing on a right definition interface resume34 {}; // ',', "supports" or '{' expected interface interface13 {}; valuetype valuetype9 supports interface13 ERROR // just to resume the parsing on a right definition interface resume35 {}; // value_name forgotten valuetype valuetype10 {}; valuetype valuetype11 : valuetype10, {}; // just to resume the parsing on a right definition interface resume36 {}; // interface_name forgotten valuetype valuetype12 supports {}; // just to resume the parsing on a right definition interface resume37 {}; // interface_name forgotten interface interface15 {}; valuetype valuetype14 supports interface15, {}; // just to resume the parsing on a right definition interface resume39 {}; /*** Test of rule 20 ***/ // a value_name should denote a valuetype const long const2 = 5; valuetype valuetype15 : const2 {}; /*** Test of rule 21 ***/ // bad value element valuetype valuetype16 { ; }; /*** Test of rule 22 ***/ // "public" or "private" forgotten valuetype valuetype17 { long member1; }; // type_spec forgotten valuetype valuetype18 { public ; }; // declarators forgotten valuetype valuetype19 { public long; }; // ';' forgotten valuetype valuetype20 { public long a,b[2] }; /*** Test of rule 23 ***/ // identifier forgotten valuetype value21 { factory }; // '(' forgotten valuetype value22 { factory factory1 }; // ')' forgotten valuetype value23 { factory factory1 ( }; // ';' forgotten valuetype value24 { factory factory1 () }; /*** Test of rule 24 ***/ // bad init_param_decls valuetype value25 { factory factory1 (;); }; /*** Test of rule 25 ***/ // Bad init_param_decl valuetype value26 { factory factory1 (;); }; // init_param_attribute forgotten valuetype value27 { factory factory1 (long argument1); }; // param_type_spec forgotten valuetype value28 { factory factory1 (in); }; // simple declarator forgotten valuetype value29 { factory factory1 (in long); }; /*** Test of rule 26 ***/ // Bad init param attribute valuetype value30 { factory factory1 (;); }; valuetype value31 { factory factory1 (out long argument1); }; valuetype value32 { factory factory1 (inout long argument1); }; /*** Test of rule 27 ***/ // const_type forgotten const; // just to resume the parsing on a right definition interface resume40 {}; // identifier forgotten const boolean; // just to resume the parsing on a right definition interface resume41 {}; // '=' forgotten const boolean const3; // just to resume the parsing on a right definition interface resume42 {}; // const_exp forgotten const boolean const4 =; // just to resume the parsing on a right definition interface resume43 {}; /*** Test of rule 28 ***/ // bad const_type const Error; // just to resume the parsing on a right definition interface resume44 {}; /*** Test of rule 29 ***/ // nothing to test here /*** Test of rule 30 ***/ // xor_expr forgotten const short const9 = 3 |; // just to resume the parsing on a right definition interface resume45 {}; /*** Test of rule 31 ***/ // and_expr forgotten const short const10 = 3 ^; // just to resume the parsing on a right definition interface resume46 {}; /*** Test of rule 32 ***/ // shift_expr forgotten const short const11 = 3 &; // just to resume the parsing on a right definition interface resume47 {}; /*** Test of rule 33 ***/ // add_expr forgotten const short const12 = 3 >>; // just to resume the parsing on a right definition interface resume48 {}; // add_expr forgotten const short const13 = 3 <<; // just to resume the parsing on a right definition interface resume49 {}; /*** Test of rule 34 ***/ // mult_expr forgotten const short const14 = 3 +; // just to resume the parsing on a right definition interface resume50 {}; // mult_expr forgotten const short const15 = 3 -; // just to resume the parsing on a right definition interface resume51 {}; /*** Test of rule 35 ***/ // unary_expr forgotten const short const16 = 3 *; // just to resume the parsing on a right definition interface resume52 {}; // unary_expr forgotten const short const17 = 3 /; // just to resume the parsing on a right definition interface resume53 {}; // unary_expr forgotten const short const18 = 3 %; // just to resume the parsing on a right definition interface resume54 {}; /*** Test of rule 36 ***/ // primary_expr forgotten const short const19 = -; // just to resume the parsing on a right definition interface resume55 {}; // primary_expr forgotten const short const20 = +; // just to resume the parsing on a right definition interface resume56 {}; // primary_expr forgotten const short const21 = ~; // just to resume the parsing on a right definition interface resume57 {}; /*** Test of rule 36 ***/ // nothing to test here /*** Test of rule 38 ***/ // bad primary_expr const short const22 = ERROR; // just to resume the parsing on a right definition interface resume58 {}; // const_exp forgotten const short const23 = ( ); // ')' forgotten const short const24 = ( 3 ; // just to resume the parsing on a right definition interface resume59 {}; /*** Test of rule 39 ***/ // nothing to be tested /*** Test of rule 40 ***/ // nothing to be tested /*** Test of rule 41 ***/ // non positive integer typedef sequence typedef1; /*** Test of rule 42 ***/ // type_declarator forgotten typedef ; // just to resume the parsing on a right definition interface resume60 {}; // simple_declarator forgotten native ; // just to resume the parsing on a right definition interface resume61 {}; /*** Test of rule 43 ***/ // declarators forgotten typedef long; // just to resume the parsing on a right definition interface resume62 {}; /*** Test of rule 44 ***/ // nothing to test here /*** Test of rule 45 ***/ // nothing to test here /*** Test of rule 46 ***/ // nothing to test here /*** Test of rule 47 ***/ // nothing to test here /*** Test of rule 48 ***/ // nothing to test here /*** Test of rule 49 ***/ // declarator forgotten typedef long typedef2, ; // just to resume the parsing on a right definition interface resume63 {}; /*** Test of rule 50 ***/ // nothing to test here /*** Test of rule 51 ***/ // nothing to test here /*** Test of rule 52 ***/ // nothing to test here /*** Test of rule 53 ***/ // "double" forgotten const long const25 = 2.3; /*** Test of rule 54 ***/ // nothing to test here /*** Test of rule 55 ***/ // nothing to test here /*** Test of rule 56 ***/ // nothing to test here /*** Test of rule 57 ***/ // nothing to test here /*** Test of rule 58 ***/ // "long" forgotten const long const26 = 56000000000; /*** Test of rule 59 ***/ // nothing to test here /*** Test of rule 60 ***/ // "short" forgotten const unsigned const27 = 5; /*** Test of rule 61 ***/ // "long" forgotten const unsigned const28 = 5; /*** Test of rule 62 ***/ // "long" forgotten const unsigned const29 = 5; // "long" forgotten const unsigned long const30 = 56000000000; /*** Test of rule 63 ***/ // nothing to test here /*** Test of rule 64 ***/ // nothing to test here /*** Test of rule 65 ***/ // nothing to test here /*** Test of rule 66 ***/ // nothing to test here /*** Test of rule 67 ***/ // nothing to test here /*** Test of rule 68 ***/ // nothing to test here /*** Test of rule 69 ***/ // identifier forgotten struct; // just to resume the parsing on a right definition interface resume64 {}; // '{' forgotten struct struct1; // just to resume the parsing on a right definition interface resume65 {}; // '}' forgotten struct struct3 { long member1; ; }; // just to resume the parsing on a right definition interface resume66 {}; /*** Test of rule 70 ***/ // empty member list struct struct4 {}; /*** Test of rule 71 ***/ // bad member struct struct5 {;}; // declarators forgotten struct struct6 { long }; // ';' forgotten struct struct7 { long member1 }; /*** Test of rule 72 ***/ // identifier forgotten union; // just to resume the parsing on a right definition interface resume67 {}; // "switch" forgotten union union2; // just to resume the parsing on a right definition interface resume68 {}; // '(' forgotten union union3 switch; // just to resume the parsing on a right definition interface resume69 {}; // switch_type_spec forgotten union union4 switch () { default : short element1; }; // ')' forgotten union union5 switch (boolean ; // just to resume the parsing on a right definition interface resume70 {}; // '{' forgotten union union6 switch (boolean); // just to resume the parsing on a right definition interface resume71 {}; // switch body forgotten union union7 switch (boolean) {}; // '}' forgotten union union8 switch (boolean) { case TRUE : long element1; ; }; // just to resume the parsing on a right definition interface resume72 {}; /*** Test of rule 73 ***/ // bad switch_type_spec union union9 switch (error) { case TRUE : long element1; }; // bad switch_type_spec union union10 switch (string) { case TRUE : long element1; }; /*** Test of rule 74 ***/ // bad switch body union union11 switch (boolean) { ERROR }; /*** Test of rule 75 ***/ // element_spec forgotten union union12 switch (boolean) { case TRUE : }; // just to resume the parsing on a right definition interface resume73 {}; // ';' forgotten union union13 switch (boolean) { case TRUE : long element1 }; // just to resume the parsing on a right definition interface resume74 {}; /*** Test of rule 76 ***/ // const_exp forgotten union union14 switch (boolean) { case : long element1; }; // just to resume the parsing on a right definition interface resume75 {}; // ':' forgotten union union15 switch (boolean) { case TRUE long k; }; // just to resume the parsing on a right definition interface resume76 {}; // ':' forgotten union union16 switch (boolean) { default long k; }; // just to resume the parsing on a right definition interface resume77 {}; /*** Test of rule 77 ***/ // declarator forgotten union union17 switch (boolean) { default : long ; }; // just to resume the parsing on a right definition interface resume78 {}; /*** Test of rule 78 ***/ // identifier forgotten enum; // just to resume the parsing on a right definition interface resume79 {}; // '{' forgotten enum enum1; // just to resume the parsing on a right definition interface resume80 {}; // enumerator forgotten enum enum2 {}; // enumerator forgotten enum enum3 { e1, }; // '}' forgotten enum enum4 { e2, e3; }; // just to resume the parsing on a right definition interface resume81 {}; /*** Test of rule 79 ***/ // nothing to test here /*** Test of rule 80 ***/ // '<' forgotten typedef sequence typedef3; // just to resume the parsing on a right definition interface resume82 {}; // simple_type_spec forgotten typedef sequence <> typedef4; // just to resume the parsing on a right definition interface resume83 {}; // positive_int_const forgotten typedef sequence typedef5; // just to resume the parsing on a right definition interface resume84 {}; // '>' forgotten typedef sequence typedef7; /*** Test of rule 81 ***/ // positive_int_const forgotten typedef string <> typedef8; // just to resume the parsing on a right definition interface resume85 {}; // '>' forgotten typedef string <10 typedef9; // just to resume the parsing on a right definition interface resume86 {}; /*** Test of rule 82 ***/ // positive_int_const forgotten typedef wstring <> typedef10; // just to resume the parsing on a right definition interface resume87 {}; // '>' forgotten typedef wstring <10 typedef11; // just to resume the parsing on a right definition interface resume88 {}; /*** Test of rule 83 ***/ // nothing to test here /*** Test of rule 84 ***/ // positive_int_const forgotten typedef boolean typedef12[; // just to resume the parsing on a right definition interface resume89 {}; // ']' forgotten typedef boolean typedef13[7; // just to resume the parsing on a right definition interface resume90 {}; /*** Test of rule 85 ***/ // "attribute" forgotten interface interface16 { readonly; }; // param_type_spec forgotten interface interface17 { attribute; }; // simple declarator forgotten interface interface18 { attribute long; }; // simple declarator forgotten interface interface19 { attribute long attribute1, ; }; // bad param type interface interface20 { attribute fixed <3,2> attribute1; }; /*** Test of rule 86 ***/ // identifier expected exception; // just to resume the parsing on a right definition interface resume91 {}; // '{' expected exception exception1; // just to resume the parsing on a right definition interface resume92 {}; // '}' expected exception exception2 {; }; // just to resume the parsing on a right definition interface resume93 {}; // bad member exception exception3 { const ; }; /*** Test of rule 87 ***/ // op_type_spec forgotten interface interface21 { oneway; }; // identifier forgotten interface interface22 { void; }; // parameter_dcls forgotten interface interface23 { void operation1; }; // bad op_type_spec interface interface24 { fixed<3,2> operation1(); }; /*** Test of rule 88 ***/ // nothing to test here /*** Test of rule 89 ***/ // bad op_type_spec interface interface25 { oneway ERROR operation1(); }; /*** Test of rule 90 ***/ // param_dcl forgotten interface interface26 { void operation1(in long arg1,); }; // ')' forgotten interface interface27 { void operation1(in long arg1; }; /*** Test of rule 91 ***/ // param_type_spec forgotten interface interface28 { void operation1(in); }; // simple_declarator forgotten interface interface29 { void operation1(in long); }; /*** Test of rule 92 ***/ // bad param_attribute interface interface30 { void operation1(long arg1); }; /*** Test of rule 93 ***/ // '(' forgotten interface interface31 { void operation1() raises; }; // scoped_name forgotten interface interface32 { void operation1() raises(); }; // scoped_name forgotten exception exception4 {}; interface interface33 { void operation1() raises (exception4,); }; // ')' forgotten exception exception5 {}; interface interface34 { void operation1() raises (exception5; }; // bad scoped name const long const31 = 5; interface interface35 { void operation1() raises (const31); }; /*** Test of rule 94 ***/ // '(' forgotten interface interface36 { void operation1() context; }; // string_literal forgotten interface interface37 { void operation1() context(); }; // string_literal forgotten interface interface38 { void operation1() context("context1",); }; // ')' forgotten interface interface39 { void operation1() context ("context1"; }; // bad string_literal interface interface40 { void operation1() context ("_context1"); }; // bad string_literal interface interface41 { void operation1() context (".context1"); }; // bad string_literal interface interface42 { void operation1() context ("0context1"); }; // bad string_literal interface interface43 { void operation1() context ("con%text1"); }; // bad string_literal interface interface44 { void operation1() context ("con*text1"); }; /*** Test of rule 95 ***/ // bad param_type_spec interface interface45 { void operation1(in fixed<2,3> arg1); }; // bad param_type_spec interface interface46 { void operation1(in ERROR arg1); }; /*** Test of rule 96 ***/ // '<' forgotten typedef fixed typedef14; // just to resume the parsing on a right definition interface resume94 {}; // positive_int_const forgotten typedef fixed<> typedef15; // just to resume the parsing on a right definition interface resume95 {}; // ',' forgotten typedef fixed<3> typedef16; // just to resume the parsing on a right definition interface resume96 {}; // positive_int_const forgotten typedef fixed<3,> typedef17; // just to resume the parsing on a right definition interface resume97 {}; // '>' forgotten typedef fixed<3,2 typedef18; // just to resume the parsing on a right definition interface resume98 {}; /*******************************/ /* Now, try each miscellaneous */ /* point of the Idl langage */ /*******************************/ /*** duplicated identifiers ***/ // duplicated module module module0 { const long l = 5; }; module module0 { const long l = 5; }; interface interface0 {}; interface interface0 {}; valuetype valuetype0 {}; valuetype valuetype0 {}; const boolean const0 = TRUE; const boolean const0 = TRUE; typedef long type0; typedef long type0; typedef long type01[2]; typedef long type01[3]; struct struct0 {long memberA; }; struct struct0 {long memberA; }; union union0 switch (boolean) { case TRUE : long elementA; }; union union0 switch (boolean) { case TRUE : long elementA; }; union unionA switch (boolean) { case TRUE : long elementA; case FALSE : long elementA; }; enum enum0 { e0 }; enum enum0 { e01 }; enum enum01 { e02, e02 }; interface interface01 { attribute long attribute1; attribute long attribute1; }; exception exception0 {}; exception exception0 {}; interface interface02 { void operation1 (); long operation1 (long arg1); }; interface interface03 { void operation1 (in long arg1, in short arg1); }; interface interface04 { exception exception1 {}; void operation1 () raises (exception1, exception1); }; /*** forwarded interfaces ***/ // problem of abstraction at the instantiation abstract interface interfaceB; interface interfaceB {}; interface interfaceC; abstract interface interfaceC {}; // double forward interface interfaceD; interface interfaceD; interface interfaceD {}; // non defined forwarded interface module moduleB { interface interfaceA; }; /*** single inheritance management for interfaces ***/ //an abstract interface cannot inherit from a stateful one interface interfaceE {}; abstract interface interfaceF : interfaceE {}; /*** multiple inheritance management in case of interfaces ***/ // twice inherited from the same interface interface interfaceG {}; interface interfaceH : interfaceG, interfaceG {}; // two inherited interfaces clash interface interfaceI { attribute long attributeA; }; interface interfaceJ { attribute long attributeA; }; interface interfaceK : interfaceI, interfaceJ {}; // ambiguous references due to multiple inheritance interface interfaceL { typedef long typeA; const long constA = 5; exception exceptionA {}; }; interface interfaceM { typedef short typeA; const long constA = 7; exception exceptionA {}; }; interface interfaceN : interfaceL, interfaceM { typedef typeA typeB; const long constB = constA; void operationA () raises (exceptionA); }; // redefinition of attributes or operation interface interfaceO { attribute long attributeA; void operationA (); }; interface interfaceP : interfaceO { attribute long attributeA; void operationA (long argument); }; /*** scoped names ***/ // non existing simple scoped name typedef non_existing_scoped_name typeA; // all the identifier except the last one should denote scopes const long constA = 5; typedef constA::l typeB; // non existing complicated scope name interface interfaceQ { const long constA = 5;}; typedef interfaceQ::constB typeC; /*** recursive declaration ***/ // recursivity not allowed in a struct struct structA { structA s; }; // recursivity not allowed in an union union unionB switch (boolean) { case TRUE : unionB unionC; }; /*** forwarded values ***/ // double forward valuetype valuetypeB; valuetype valuetypeB; valuetype valuetypeB {}; // problem of abstraction at the instantiation abstract valuetype valuetypeC; valuetype valuetypeC {}; valuetype valuetypeD; abstract valuetype valuetypeD {}; // non defined forwarded value module moduleC { valuetype valuetypeA; }; // forward of a boxed valuetype valuetype valuetypeE; valuetype valuetypeE long; /*** single inheritance management for values ***/ // no truncatable for an abstract value abstract valuetype valuetypeF {}; abstract valuetype valuetypeG : truncatable valuetypeF {}; // no truncatable for an custom value abstract valuetype valuetypeH {}; custom valuetype valuetypeI : truncatable valuetypeH {}; // an abstract value cannot inherit from a stateful one valuetype valuetypeJ {}; abstract valuetype valuetypeK : valuetypeJ {}; // no truncatable for an abstract value inheritance abstract valuetype valuetypeL {}; valuetype valuetypeM : truncatable valuetypeL {}; // no inheritance of a forward value without instantiation valuetype valuetypeN; valuetype valuetypeO : valuetypeN {}; valuetype valuetypeN {}; // no inheritance from a boxed value valuetype valuetypeP long; valuetype valuetypeQ : valuetypeP {}; // no inheritance from an interface interface interfaceR {}; valuetype valuetypeR : interfaceR {}; /*** multiple inheritance management for values ***/ // no double inheritance of a single value valuetype valuetypeS {}; valuetype valuetypeT : valuetypeS, valuetypeS {}; // no inheritance from more than one stateful value valuetype valuetypeU {}; valuetype valuetypeV {}; valuetype valuetypeW : valuetypeU, valuetypeV {}; // no inheritance from a stateful value after the first inherited value abstract valuetype valuetypeX {}; valuetype valuetypeY {}; valuetype valuetypeZ : valuetypeX, valuetypeY {}; // no inheritance of a forward value without instantiation valuetype valuetypeAA {}; abstract valuetype valuetypeAB; valuetype valuetypeAC : valuetypeAA, valuetypeAB {}; abstract valuetype valuetypeAB {}; // no inheritance from a boxed value valuetype valuetypeAD {}; valuetype valuetypeAE long; valuetype valuetypeAF : valuetypeAD, valuetypeAE {}; // no inheritance from an interface valuetype valuetypeAG interface interfaceS {}; valuetype valuetypeAH : valuetypeAG, interfaceS {}; /*** single support management for values ***/ // no support of a forward interface without instantiation interface interfaceT; valuetype valuetypeAI supports interfaceT {}; interface interfaceT {}; // no support of values valuetype valuetypeAJ {}; valuetype valuetypeAK supports valuetypeAJ {}; /*** multiple support management for values ***/ // no double support of a single interface abstract interface interfaceU {}; valuetype valuetypeAL supports interfaceU, interfaceU {}; // a stateful value may not support multiple stateful interfaces interface interfaceV {}; interface interfaceW {}; valuetype valuetypeAM supports interfaceV, interfaceW {}; // no support of a forward interface without instantiation interface interfaceX {}; interface interfaceY; abstract valuetype valuetypeAN supports interfaceX, interfaceY {}; interface interfaceY {}; // no support of values interface interfaceZ {}; valuetype valuetypeAO {}; valuetype valuetypeAP supports interfaceZ, valuetypeAO {}; /*** scopes and multiple inheritance in values ***/ // identifier already defined valuetype valuetypeAQ { typedef long type1; typedef long type1; }; valuetype valuetypeAR { const long constant1 = 5; const long constant1 = 5; }; valuetype valuetypeAS { exception exception1 {}; exception exception1 {}; }; valuetype valuetypeAT { attribute long attribute1; attribute long attribute1; }; valuetype valuetypeAU { void operation1 (); void operation1 (); }; valuetype valuetypeAV { public long member1; public long member1; }; valuetype valuetypeAW { factory factory1 (); factory factory1 (); }; /*** constant management : use of operators ***/ // not legal constant type interface interfaceAA {}; const interfaceAA constB = 5; // misuse of the | operator const char constC = 'C' | 'H'; // misuse of the ^ operator const char constD = 'C' ^ 'H'; // misuse of the & operator const char constE = 'C' & 'H'; // negative value in a shift const short constF = 160 >> -5; // value > 63 in a shift const short constG = 1 >> 65; // misuse of the >> operator const char constH = 'C' >> 'H'; // misuse of the << operator const char constI = 'C' << 'H'; // misuse of the binary + operator const char constJ = 'C' + 'H'; // misuse of the binary - operator const char constK = 'C' - 'H'; // division by 0 const short constL = 45 / 0; // division by 0 const float constM = 45. / 0.; // division by 0 const fixed<2,0> constN = 45d / 0d; // modulo by 0 const short constO = 45 % 0; // misuse of the operator * const char constP = 'C' * 'H'; // misuse of the operator / const char constQ = 'C' / 'H'; // misuse of the operator % const float constR = 1.23 % 1.23; // misuse of the unary operator - const char constS = - 'H'; // misuse of the unary operator + const char constT = + 'H'; // misuse of the operator ~ const float constU = ~ 1.23; /*** constant management : value types and scoped names ***/ // not a regular type interface interfaceAB {}; const short constV = interfaceAB; // incompatible types const short constW = 4; const char constX = constW; // incompatible types const short constY = 4; const unsigned long constZ = constY; // incompatible types const fixed <3,1> constAA = 4.4d; const fixed <3,2> constAB = constAA; // incompatible types enum enumC {eG, eH, eI}; enum enumD {eJ, eK, eL}; const enumC constAC = eL; // incompatible types enum enumE {eM, eN, eO}; const enumE constAD = eO; enum enumF {eP, eQ, eR}; const enumF constAE = constAD; /*** constant management : value types and literals ***/ // integer literal but no integer type const float constAF = 5; // string literal but no string type const float constAG = "string"; // string literal and wide string type const wstring constAH = "string"; // wide string literal but no wide string type const float constAI = L"string"; // wide string literal and string type const string constAJ = L"string"; // too long string literal const string<4> constAK = "string"; // too long wide string literal const wstring<4> constAL = L"wstring"; // char literal but no char type const float constAM = 'c'; // char literal and wide char type const wchar constAN = 'c'; // wide char literal but no wide char type const float constAO = L'c'; // wide char literal and char type const char constAP = L'c'; // floating point literal but no floating point type const long constAQ = 5.2; // fixed point literal but no fixed point type const float constAR = 5.4d; // precision in fixed point literals const fixed<3,2> constAS = .434d; // precision in fixed point literals const fixed<3,1> constAT = 234.7d; // boolean literal but no boolean type const float constAU = TRUE; /*** constant management : direct value ranges ***/ // octet range const octet constAV = -2; // octet range const octet constAW = 280; // short range const short constAX = -33000; // short range const short constAY = 33000; // long range const long constAZ = -3000000000; // long range const long constBA = 3000000000; // longlong range //const long long constBB = -10000000000000000000; // longlong range //const long long constBC = 10000000000000000000; // unsigned short range const unsigned short constBD = -3; // unsigned short range const unsigned short constBE = 70000; // unsigned long range const unsigned long constBF = -3; // unsigned long range const unsigned long constBG = 5000000000; // unsigned longlong range const unsigned long long constBH = -1; // unsigned longlong range //const unsigned long long constBI = 18000000000000000000; // float range const float constBJ = -4e38; // float range const float constBK = 4e38; // double range const double constBL = -2E308; // double range const double constBM = 2e308; // long double range const long double constBN = -1.2E4932; // long double range const long double constBO = 1.2E4932; // fixed point range const fixed <32,4> constBP = 12344.254d; // fixed point range const fixed <4,5> constBQ = .01254d; /*** constant management : indirect value ranges ***/ // octet range const octet constBR = 5 - 8; // octet range const octet constBS = 230 + 50; // octet range const octet constBT = 23 * 23; // short range const short constBU = -30000 - 3000; // short range const short constBV = 30000 + 3000; // short range const short constBW = 30000 * 2; // long range const long constBX = -2000000000 - 1000000000; // long range const long constBY = 2000000000 + 1000000000; // long range const long constBZ = 2000000000 * 2; // longlong range //const long long constCA = -5000000000000000000 - 5000000000000000000; // longlong range //const long long constCB = 5000000000000000000 + 5000000000000000000; // unsigned short range //const long long constCC = 5000000000000000000 *2; // unsigned short range const unsigned short constCD = 5 - 8; // unsigned short range const unsigned short constCE = 40000 + 30000; // unsigned short range const unsigned short constCF = 40000 * 2; // unsigned long range const unsigned long constCG = 5 - 8; // unsigned long range const unsigned long constCH = 3000000000 + 2000000000; // unsigned long range const unsigned long constCI = 3000000000 * 2; // unsigned longlong range const unsigned long long constCJ = 5 - 8; // unsigned longlong range //const unsigned long long constCK = 9000000000000000000 + 9000000000000000000; // unsigned longlong range //const unsigned long long constCL = 9000000000000000000 * 2; // float range const float constCM = -2e38 - 2e38; // float range const float constCN = 2e38 + 2e38; // float range const float constCO = 2e38 * 2; // double range const double constCP = -1E308 - 1E308; // double range const double constCQ = 1E308 + 1E308; // long double range const double constCR = 1E308 * 2.; // long double range const long double constCS = -0.6E4932 - 0.6E4932; // long double range const long double constCT = 0.6E4932 + 0.6E4932; // long double range const long double constCU = 0.6E4932 * 2.; // fixed point range const fixed <3,0> constCV = 605d + 605d; // fixed point range const fixed <3,0> constCW = -605d - 605d; // fixed point range const fixed <3,0> constCX = 605d * 2d; /*** type declarations and scoped names ***/ // invalid type const long constCY = 5; typedef constCY typeD; // invalid type module moduleD { const long constA = 5; }; typedef moduleD typeE; /*** switch type and scoped names ***/ // bad switch type typedef string typeF; union unionC switch (typeF) { case TRUE : long elementA; }; // identifier clash union unionD switch (enum enumG {eS, eT, eU}) { case eS : long eT; }; /*** switch types : case label management ***/ // duplicated label union unionE switch (short) { case 1 : long elementA; case 1 : long elementB; }; // duplicated label union unionF switch (short) { case 1 : case 3 : case 5 : long elementA; case 2 : case 3 : case 4 : long elementB; }; // useless label union unionG switch (short) { case 1 : default : long elementA; }; // double default clause union unionH switch (short) { default : long elementA; default : long elementB; }; /*** sequence and scoped names ***/ // bad sequence type enum enumH { eV, eW, eX }; typedef sequence typeG; /*** operation parameters types and scoped names ***/ // bad parameter type typedef fixed<3,2> typeH; interface interfaceAC { void operation1(in typeH arg1); }; /* // multiple inheritance management // in case of valuetypes -- To be completed valuetype v1 { typedef long type1; const long const1 = 5; exception e {}; }; abstract valuetype v2 { typedef short type1; const long const1 = 7; exception e {}; }; valuetype v3 : v1, v2 { typedef type1 type2; const long const2 = const1; void echo () raises (e); }; valuetype v4 { attribute long l; void echo (); }; valuetype v5 : v4 { attribute long l; void echo (long arg); }; */polyorb-2.8~20110207.orig/compilers/idlac/testsuite/parser/toplevel.idl0000644000175000017500000000204111750740337025327 0ustar xavierxavier// Test all declarations allowed at file level, except modules, // interfaces, valuetypes, forward interfaces and valuetypes. typedef Object otherObject; enum Color { Red, Green, Blue }; exception my_exception {long info;}; union myUnion switch (long) { case 1: long Counter; case 2: boolean Flag; case 3: Color Hue; default: long Unknown; }; union myUnionEnumSwitch switch (Color) { case Red: long foo; case Green: short bar; case Blue: string baz; }; typedef long simple_array[5]; typedef long matrix[3][3]; typedef long bigmatrix[30][15]; struct simple_struct { long a; string s; }; struct array_struct { long a[10]; unsigned short b; }; struct composite_struct { fixed<12,3> fixedMember; sequence > seqseqMember; long double matrixMember[3][4]; }; struct nested_struct { simple_struct ns; }; typedef sequence U_sequence; typedef sequence B_sequence; typedef fixed<18,2> Money; polyorb-2.8~20110207.orig/compilers/idlac/testsuite/parser/testparser_include.idl0000644000175000017500000000004011750740337027371 0ustar xavierxavierconst long included_const = 10; polyorb-2.8~20110207.orig/compilers/idlac/testsuite/parser/alldefinitions.idl0000644000175000017500000003237411750740337026515 0ustar xavierxavier/******************************************************** This file is meant to try every definition of the idl langage in order to test the idl parser *********************************************************/ /************************/ /* First, try each rule */ /************************/ // Rule 0 : preprocessor #include "testparser_include.idl" #line 500 #line 14 #pragma toto // Rule 1 const short const1 = 412; // Rule 2 typedef long long1; const short const2 = 2; exception exception1 {}; interface interface1 {}; module module3 {const short const1 = 3;}; valuetype valuetype1 {}; // Rule 3 module module4 {const short const1 = 3;}; module module5 {const short const1 = 3; const short const2 = 3;}; // Rule 4 interface interface2; interface interface2 {}; // Rule 5 interface interface3 {long echo_long (in long l);}; // Rule 6 interface interface4; abstract interface interface5; interface interface4 {}; abstract interface interface5 {}; // Rule 7 interface interface6 {}; abstract interface interface7 {}; interface interface8 : interface6 {}; abstract interface interface9 : interface7 {}; // Rule 8 interface interface10 {}; interface interface11 {long echo_long (in long l);}; // Rule 9 interface interface12 { typedef long long1; const short const2 = 2; exception exception1 {}; attribute long attr1; long echo_long (in long l); }; // Rule 10 interface interface13 : interface6 {}; interface interface14 : interface6, interface12 {}; interface interface15 : interface6, interface12, interface13 {}; // Rule 11 module module6 { interface inter {}; }; interface interface16 : ::module6::inter {}; // Rule 12 module module7 { typedef long type1; }; typedef long type1; typedef type1 type2; typedef type2 type3; typedef module7::type1 type4; typedef ::module7::type1 type5; // Rule 13 valuetype value1{}; abstract valuetype value2{}; valuetype value3 long; valuetype value4; valuetype value4{}; // Rule 14 valuetype value5; valuetype value5{}; abstract valuetype value6; abstract valuetype value6{}; // Rule 15 valuetype value7 long; // Rule 16 abstract valuetype value8 {}; abstract valuetype value9 {const short a = 2;}; abstract valuetype value10 {const short a = 2;const short b = 2;}; abstract valuetype value11 : value6 {}; abstract valuetype value12 : value6 {const short a = 2;}; abstract valuetype value13 : value6 {const short a = 2;const short b = 2;}; // Rule 17 valuetype value14 {}; valuetype value15 {const short a = 2;}; valuetype value16 {const short a = 2;const short b = 2;}; // Rule 18 valuetype value17 {}; custom valuetype value18 {}; valuetype value19 : value17 {}; custom valuetype value20 : value19 {}; // Rule 19 valuetype value21 : value17 {}; valuetype value22 : value17, value8 {}; valuetype value23 : value17, value8, value9 {}; valuetype value24 : truncatable value17 {}; valuetype value25 : truncatable value17, value8 {}; valuetype value26 : truncatable value17, value8, value9 {}; valuetype value27 supports interface6 {}; valuetype value28 supports interface6, interface5 {}; valuetype value29 supports interface6, interface5, interface7 {}; valuetype value30 : value17 supports interface6 {}; valuetype value31 : value17 supports interface6, interface5 {}; valuetype value32 : value17 supports interface6, interface5, interface7 {}; valuetype value33 : truncatable value17 supports interface6 {}; valuetype value34 : truncatable value17 supports interface6, interface5 {}; valuetype value35 : truncatable value17 supports interface6, interface5, interface7 {}; // Rule 20 module module8 { valuetype value {}; }; valuetype value36 : ::module8::value {}; // Rule 21 valuetype value37 { const short a = 2; public long l; factory f(); }; // Rule 22 valuetype value38 { public long l; private short s; }; // Rule 23 valuetype value39 { factory f(); factory g(in short s); }; // Rule 24 valuetype value40 { factory f(in short s); factory g(in short s, in long l); }; // Rule 25 valuetype value41 { factory f(in short s); }; // Rule 26 valuetype value42 { factory f(in short s); }; // Rule 27 const short const3 = 3; // Rule 28 const short const4 = 3; const char const5 = 'd'; const wchar const6 = L'd'; const boolean const7 = TRUE; const float const8 = 3.14; const string const9 = "string"; const wstring const10 = L"wstring"; const fixed<5,3> const11 = 3.141d; typedef long type6; const type6 const12 = 5; typedef type6 type7; const type7 const13 = 5; const octet const14 = 2; // Rule 29 const short const15 = 5; // Rule 30 const short const16 = 3 | 28; const short const17 = 3 | 28 | 12; // Rule 31 const short const18 = 3 ^ 28; const short const19 = 3 ^ 28 ^ 12; // Rule 32 const short const20 = 3 & 28; const short const21 = 3 & 28 & 12; // Rule 33 const long const22 = 345 << 8; const long const23 = 345 << 2 << 6; const short const24 = 345 >> 8; const short const25 = 345 >> 2 >> 6; // Rule 34 const short const26 = 345 + 8; const short const27 = 345 + 2 + 6; const short const28 = 345 - 8; const short const29 = 345 - 2 - 6; const short const30 = 345 - 2 + 6; const short const31 = 345 + 2 - 6; // Rule 35 const short const32 = 345 * 8; const short const33 = 345 * 2 * 4; const short const34 = 345 / 8; const short const35 = 345 / 2 / 4; const short const36 = 345 % 8; const short const37 = 347 % 4 % 2; const short const38 = 345 * 4 / 2; const short const39 = 345 / 4 * 2; const short const40 = 345 * 4 % 5; const short const41 = 345 % 4 * 5; const short const42 = 345 / 4 % 5; const short const43 = 345 % 4 / 5; // Rule 36 const short const44 = - 17; // Rule 37 const short const45 = - 17; const short const46 = + 17; const short const47 = ~ 17; // Rule 38 module module9 { const short c = 2; }; const short const48 = ::module9::c; const short const49 = module9::c; const short const50 = 18; const short const51 = ( 1 | 3 ^ 200 >> 3 & 7 << 2 + -7 - -11 * 13 / 15 % ~17); // Rule 39 const short const52 = 12; const short const53 = 014; const short const54 = 0xC; const string const55 = "a string"; const wstring const56 = L"a wide string"; const char const57 = 'r'; const char const58 = '\n'; const char const59 = '\60'; const char const60 = '\xab'; const wchar const61 = L'r'; const wchar const62 = L'\n'; const wchar const63 = L'\12'; const wchar const64 = L'\xab'; const wchar const65 = L'\uabc'; const fixed<5,3> const66 = 12d; const fixed<3,1> const67 = 3.4d; const float const68 = 1.45; const float const69 = 5e3; const float const70 = 3E4; const boolean const71 = TRUE; // Rule 40 const boolean const72 = TRUE; const boolean const73 = FALSE; // Rule 41 const fixed<4,2> const74 = 12d; // Rule 42 typedef long type8; struct struct1 { long l; }; union union1 switch (boolean) { default : long l; }; enum enum1 { e1, e2 }; native native1; // Rule 43 typedef long type9; // Rule 44 typedef long type10; typedef enum enum2 { e3, e4 } type11; // Rule 45 typedef long type12; typedef string type13; module module10 { typedef long type; }; typedef type10 type14; typedef module10::type type15; typedef ::module10::type type16; // Rule 46 typedef float type17; typedef long type18; typedef char type19; typedef wchar type20; typedef boolean type21; typedef octet type22; typedef any type23; typedef Object type24; typedef ValueBase type25; // Rule 47 typedef sequence type26; typedef string type27; typedef wstring type28; typedef fixed<4,4> type29; // Rule 48 typedef struct struct2 { long l; } type30; typedef union union2 switch (boolean) { default : long l; } type31; typedef enum enum3 { e5, e6 } type32; // Rule 49 typedef long type33; typedef long type34, type35; typedef long type36, type37, type38; // Rule 50 typedef long type39; typedef long type40[5]; // Rule 51 typedef long type41; // Rule 52 typedef long type42[5]; // Rule 53 typedef float type43; typedef double type44; typedef long double type45; // Rule 54 typedef short type46; typedef unsigned short type47; // Rule 55 typedef short type48; typedef long type49; typedef long long type50; // Rule 56 typedef short type51; // Rule 57 typedef long type52; // Rule 58 typedef long long type53; // Rule 59 typedef unsigned short type54; typedef unsigned long type55; typedef unsigned long long type56; // Rule 60 typedef unsigned short type57; // Rule 61 typedef unsigned long type58; // Rule 62 typedef unsigned long long type59; // Rule 63 typedef char type60; // Rule 64 typedef wchar type61; // Rule 65 typedef boolean type62; // Rule 66 typedef octet type63; // Rule 67 typedef any type64; // Rule 68 typedef Object type65; // Rule 69 typedef struct struct3 { char c; } type66; // Rule 70 struct struct4 { char c; }; struct struct5 { char c; string s; }; // Rule 71 struct struct6 { char c; }; // Rule 72 union union3 switch (boolean) { case TRUE : short s; default : long l; }; // Rule 73 union union4 switch (short) { case 0 : short s; default : long l; }; union union5 switch (char) { case 'c' : short s; default : long l; }; union union6 switch (boolean) { case TRUE : short s; default : long l; }; union union7 switch (enum enum4 {e7, e8}) { case e7 : short s; default : long l; }; module module11 { typedef boolean type; }; union union8 switch (module11::type) { case TRUE : short s; default : long l; }; // Rule 74 union union9 switch (short) { case 0 : short s; }; union union10 switch (short) { case 0 : short r; case 1 : short s; }; union union11 switch (short) { case 0 : short r; case 1 : short s; case 2 : short t; }; union union12 switch (short) { default : short s; }; union union13 switch (short) { case 0 : short r; default : short s; }; union union14 switch (short) { case 0 : short r; case 1 : short s; default : short t; }; union union15 switch (short) { default : short r; case 1 : short s; }; // Rule 75 union union16 switch (short) { case 0 : short s; }; union union17 switch (short) { case 0 : case 1 : short s; }; union union18 switch (short) { case 0 : case 1 : case 2 : short s; }; // Rule 76 union union19 switch (boolean) { case TRUE : short s; default : long l; }; // Rule 77 union union20 switch (boolean) { case TRUE : short s; }; // Rule 78 enum enum5 { e9 }; enum enum6 { e10, e11 }; enum enum7 { e12, e13, e14 }; // Rule 79 enum enum8 { e15 }; // Rule 80 typedef sequence type67; typedef sequence type68; // Rule 81 typedef string<5> type69; typedef string type70; // Rule 82 typedef wstring<5> type71; typedef wstring type72; // Rule 83 typedef short type73[1]; typedef short type74[1][2]; typedef short type75[1][2][3]; // Rule 84 typedef short type76[17]; // Rule 85 interface interface17 { attribute short attribute1; readonly attribute long attribute2; attribute short attribute3, attribute4; readonly attribute boolean attribute5, attribute6; attribute short attribute7, attribute8, attribute9; readonly attribute float attribute10, attribute11, attribute12; }; // Rule 86 exception exception2 {}; exception exception3 { short s; }; exception exception4 { short s; long l; }; // Rule 87 interface interface18 { exception e{}; long op1 (); oneway long op2 (); long op3 () raises (e); oneway long op4 () raises (e); long op5 () context ("context"); oneway long op6 () context ("context"); long op7 () raises (e) context ("context"); oneway long op8 () raises (e) context ("context"); }; // Rule 88 interface interface19 { oneway long op1 (); }; // Rule 89 interface interface20 { long op1 (); void op2 (); }; // Rule 90 interface interface21 { long op1 (); long op2 (in short p1); long op3 (in short p1,out short p2); long op4 (in short p1,out short p2,inout short p3); }; // Rule 91 interface interface22 { long op1 (in short p1); }; // Rule 92 interface interface23 { long op1 (in short p1,out short p2,inout short p3); }; // Rule 93 interface interface24 { exception e1 {}; exception e2 {}; exception e3 {}; long op1 () raises (e1); long op2 () raises (e1,e2); long op3 () raises (e1,e2,e3); }; // Rule 94 interface interface25 { long op1 () context ("c1"); long op2 () context ("c1","c2"); long op3 () context ("c1","c2","c3"); }; // Rule 95 module module12 { typedef long type; }; interface interface26 { long op1 (in short p1); long op2 (in string p1); long op3 (in wstring p1); long op4 (in ::module12::type p1); }; // Rule 96 const fixed<4,1> const75 = 12d; // Rule 97 const fixed<4,1> const76 = 12d; // Rule 98 typedef ValueBase type77; /*******************************/ /* Now, try each miscellaneous */ /* point of the Idl langage */ /*******************************/ // scoped names module moduleA { typedef short typeA; interface interfaceA { typedef long typeA; typedef moduleA::typeA typeB; typedef moduleA::interfaceA::typeA typeC; }; }; // sequences of sequences typedef sequence sequenceA; typedef sequence > sequenceB; typedef sequence> sequenceC; typedef sequence> sequenceD; typedef sequence>1>> sequenceE; typedef sequence>1>,5>>1> sequenceF; typedef sequence>> sequenceG; // reopening of modules module moduleB { const long constA = 0; }; typedef short typeA; module moduleB { typedef typeA typeB; const long constB = constA; }; // native type as parameter of a function interface interfaceA { native nativeA; void methodA (in nativeA argA); };polyorb-2.8~20110207.orig/compilers/idlac/testsuite/local/0000755000175000017500000000000011750740340022576 5ustar xavierxavierpolyorb-2.8~20110207.orig/compilers/idlac/testsuite/local/local7.idl0000644000175000017500000000014211750740337024454 0ustar xavierxaviermodule Local7 { local interface X; typedef sequence XSeq; local interface X {}; }; polyorb-2.8~20110207.orig/compilers/idlac/testsuite/local/local4.idl0000644000175000017500000000010611750740337024451 0ustar xavierxavier interface A {}; local interface B {}; local interface C : A, B {}; polyorb-2.8~20110207.orig/compilers/idlac/testsuite/local/local8.idl0000644000175000017500000000013011750740337024452 0ustar xavierxavierlocal interface Local8 { boolean is_x (out boolean result); boolean is_y (); }; polyorb-2.8~20110207.orig/compilers/idlac/testsuite/local/local6.idl0000644000175000017500000000010511750740337024452 0ustar xavierxavierlocal interface A; local interface A {}; local interface B : A {}; polyorb-2.8~20110207.orig/compilers/idlac/testsuite/local/local1.idl0000644000175000017500000000002711750740337024450 0ustar xavierxavier local interface A {}; polyorb-2.8~20110207.orig/compilers/idlac/testsuite/local/local2.idl0000644000175000017500000000005411750740337024451 0ustar xavierxavier interface A {}; local interface B : A {}; polyorb-2.8~20110207.orig/compilers/idlac/testsuite/local/local3.idl0000644000175000017500000000006211750740337024451 0ustar xavierxavier local interface A {}; local interface B : A {}; polyorb-2.8~20110207.orig/compilers/idlac/testsuite/local/local5.idl0000644000175000017500000000007011750740337024452 0ustar xavierxavier local interface A {}; // illegal interface B : A {}; polyorb-2.8~20110207.orig/compilers/idlac/testsuite/regression/0000755000175000017500000000000011750740340023664 5ustar xavierxavierpolyorb-2.8~20110207.orig/compilers/idlac/testsuite/regression/RT-43/0000755000175000017500000000000011750740340024435 5ustar xavierxavierpolyorb-2.8~20110207.orig/compilers/idlac/testsuite/regression/RT-43/CfmuTypes.idl0000644000175000017500000000167611750740337027066 0ustar xavierxavier//------------------------------------------------------------ // // CfmuTypes.idl // // IDL include file for global CFMU types // // Eurocontrol // //------------------------------------------------------------ #ifndef CFMU_TYPES_IDL #define CFMU_TYPES_IDL //------------------------------------------------------------ // Global definitions out of any interface. // Following IDL guidelines, we define as few as possible typedef with string. // Therefore, we define once CfmuStrings which will be used everywhere a list of strings objects is needed. typedef sequence CfmuStrings; // this exception occurs when something is wrong in parameters exception CfmuInvalid { string m_cause; }; // this exception occurs when something prevent a server from doing // its job. For example, database is missing. exception CfmuUnavailableService { string m_cause; }; // A general sequence of objects // typedef sequence CfmuObjectList; #endif polyorb-2.8~20110207.orig/compilers/idlac/testsuite/regression/RT-43/RplIgnoredErrorsManager.idl0000644000175000017500000002374111750740337031701 0ustar xavierxavier #include "CfmuTypes.idl" interface RplIgnoredErrorsManager { /** * This is the general Rpl exception raised when it is not possible to provide a required service. */ enum RplExceptionType { StatusError, NotExisting, UnavailableService, ParameterInconsistencyError, RplFatalError, ParameterSyntaxtError, NotIgnorableError, AlreadyInCatalog }; exception RplException { RplExceptionType m_type; string m_cause; }; enum ErtSynIdent { No_Vfr, No_Key_Field_Changes, Efpm_Error, Invalid_Field, Invalid_Point_In_Field, Invalid_Off_Block_Time_In_Field, Text_Too_Long, Text_Too_Short, Unknown_Flight_Rules, Invalid_Level_In_Field, Invalid_Time_In_Field, Invalid_Date_In_Field, Invalid_Speed_In_Field, Invalid_Lattitude_In_Field, Invalid_Longitude_In_Field, Invalid_Bearing_In_Field, Invalid_Distance_In_Field, Invalid_List, Invalid_Designator, Invalid_Separator, Unexpected_Separator, Expected_End_Of_Message, Unknown_Or_Unexpected_Field, Syn_Missing_Field, Too_Many_Alternate_Aerodromes, Expected_Ats_Unit_Name, Unexpected_Time, Incomplete_Input_String, Multiple_Flight_Info_Records, Unknown_Rpl_Record_Type, No_Activation_Day, Unknown_Entry_Type, Susp_Text_Too_Long, Susp_Invalid_Field, Item_Already_Exists, Invalid_Title_Field, Missing_Adexp_Eto, Missing_Adexp_End, Missing_Adexp_Pt_Id, Missing_Adexp_Rte_Pts, Missing_Adexp_Addr, Number_Expected, Ats_Unit_Expected, Ref_Data_Expected, Unknown_Aircrft_Type, Wake_Turb_Expected, C_Equip_Expected, Ssr_Equip_Expected, Fslash_Expected, Unexpected_Mode_Code, Unknown_Aircraft_Id, Missing_Right_Bracket, Flight_Type_Expected, Flight_Rules_Expected, Flight_Type_Rules_Expected, Change_Rules_Expected, Truncated_Route_Expected, Date_Expected, Time_Expected, Invalid_Terminator, Invalid_Source, Invalid_Day_Of_Operation, Remark_Record_Cannot_Be_Parsed, Invalid_Characters_In_Field, No_Matching_Longitude, Multiple_Matching_Longitude, Meridian_Not_Allowed, Too_Many_Addresses, Incorrect_Parenthesis_Pairing, Eqpt_Field_Not_Allowed, Multiple_Matching_Latitude, Parallel_Not_Allowed, Invalid_Sr_Sequence_Number }; enum ErtAssocIdent { No_Association, Single_Association, // ARG1 status Multiple_Association, // ARG1 count, ARG2 status Single_Overlap_Association, // ARG1 status Multiple_Overlap_Association, // ARG1 count, ARG2 status Invalid_Keys_In_Association, Duplicate_Standard_Route, Duplicate_Standard_Route_Id }; enum ErtProfIdent { Unknown_Item, // Must provide name of item Obsolete_Error_1, // Flight_Level_Not_Available, // Must provide route, from+to pt and level. General_Rs_Violation, // Mandatory routes missing, provide ADEP-ADES, UNIT, ROUTE(S) Obsolete_Error_2, // Not_Accessible, // Must provide name of route and pts (segment) Bad_Eet_At_Oceanic_Boundary, Prof_Abort_Due_To_Software, Prof_Abort_Due_To_Environment, // Provide previous and current processed items. Ttl_Eet_Difference, // Provide the calculated TTL_EET and the percentage of difference allowed Ats_Availability_Error, Cdr1_Availability_Error, Specific_Rs_Violation, // Non-permitted route crossed, provide ADEP-ADES, UNIT, ROUTE, USAGE/ROLE Violate_833_Requirements, Cdr2_Availability_Error, Cdr3_Availability_Error, Na_Availability_Error, Gap_Availability_Error, Cannot_Change_Of_Level, Unequiped_Enters_833_Sector, Use_Of_Uhf_Not_Permited, Closed_Rs_Violation }; enum ErtRouteIdent{ No_Cruise_Level, No_Level_At_Point, // Arg1 is the point name. Bad_Cruise_Level, Bad_Level_At_Point, // Arg1 is the point name. No_Cruise_Speed, No_Speed_At_Point, // Arg1 is the point name. Bad_Cruise_Speed, Bad_Speed_At_Point, // Arg1 is the point name. Data_Inconsistency_At_Point, // Arg1 is the point name. Sequence_Not_In_Route, Multiple_Route, // Arg1,2 are the junction points Bad_Identifier, // Arg1 is the identifier. Truncated_Route, Bad_Time_At_Point, // Arg1 is the point name. No_Identifier, No_Ifr_Part, Point_Not_On_Route, // Arg1 is route, Arg2 is point. Unresolved_Homonym, Route_Abort_Due_To_Software, Route_Abort_Due_To_Environment, Cannot_Be_Sequential, // Arg1, Arg2 Entry_Exit_Missing, // Arg1 is the item. Dct_Misplaced, // Arg1,2 are two route items. Nothing_After_Arrival, // Arg1 is the arrival proc. Nothing_Before_Departure, // Arg1 is the departure proc. Geo_Ref_Point_Ending_Route, // Arg1 is the routeid Multiple_Junctions, // Must provide from route and to route No_Junction, // Must provide the names of the routes Not_Last_Point_Of_Sid, // Must provide Point & name of SID Not_First_Point_Of_Star, // Must provide Point & name of STAR Direct_Route_Too_Long, // Provide From & To parameters. No_Star_Between, // Must provide the name of the item + ADES No_Sid_Between, // Must provide ADEP and name of the item Not_Accessible, // Must provide name of route and pts (segment) Not_Applicable_To_Ifpz, Cannot_Correct_Points_Pair, // Must provide two point ids and a sequence of route ids Multiple_Change_For_One_Point, // Must provide one point and the type of change Ambiguous_Entry_Exit_Point_On, // Must provide the name of the route Inconsistent_With_Flight_Rules, Ambiguous_Entry_Exit_Route, // Must provide the name of the route Route_Between_Same_Points, // Must provide the name of the route and point Multiple_Points, Point_Not_In_Rte_Pts, No_More_Valid_Nat, Nat_Not_Connected, Is_Not_Oee, Oee_Missing, Lfpt_Missing, Sid_Limit_Exceeded, Entry_Exit_Missing_Before, // Arg1 is the item. Entry_Exit_Missing_After, Cannot_Find_Entry_Exit, Cannot_Expand, Point_Of_Route_Expected_After, Point_Of_Route_Expected_Before, Y_Flt_Rule_With_No_Vfr, Star_Limit_Exceeded, Rts_To_Repl_Dct_All_Unavail }; enum ErtEfpmIdent { Invalid_Value, Ambiguous_Value, Invalid_Format, Efpm_Missing_Field, Field_Is_Not_Required, Date_Inconsistency_With_Field, // Field name as ARG1 Date_Time_Inconsistency_With_Field, // Field name as ARG1 Aerodrome_Zzzz_And_No_Name_In_Field, // Field name as ARG1 Aerodrome_Not_Zzzz_But_Name_Supplied_In_Field, // Field name as ARG1 C_Eqpt_Z_And_No_Name_In_Com_Or_Nav, Arc_Typ_And_Typ_Z_Present, Arc_Typ_Zzzz, Replace_Zzzz_With_Icao_Id, Multiple_Fpd_Match, Efpm_Match, Afil_Point_Not_On_Route, Afil_With_No_Matching_Fpd, No_Matching_Fpd, Match_Error, Insufficient_Data_To_Create_Fpd, Change_Modifies_The_Field, // Field name as ARG1 Route_Data_Missing, Route_Data_Not_Expected, Adep_Is_Afil, No_Env_For_Reference_Time, // Field name as ARG1 Partially_Matching_Fpd, Partially_Matching_Efpm, Matching_Fpd_Is_Unprocessed, Invalid_Fpd_Id, Efpm_From_Fpd, Rfpd_Inconsistent_With_Environment_Change, Efpm_Filed_Before_Fpd, Delay_Changes_Route, Manual_Addressing, Fpd_Closed, Wk_Trc_Does_Not_Match_Arc_Typ, Flight_Plan_Already_Received, // Originator address as ARG1 Flight_Plan_Already_Generated, Cannot_Update_Fpd, Eobdt_Out_Of_Range, Adta_After_Reception_Time, Adtd_After_Reception_Time, Zero_Ifpl_For_Rpl, Overlaps_2_Airac_Cycles, Could_Be_Wrong, Filing_Time_After_Eobdt, Protected_Efpm_Requested_By_Rqp, Match_With_Fpd, Afp_Route_Alter_Fpd, Possible_DOF, STATE_AND_RVSM_WITH_STS_NONRVSM, STATE_AND_NONRVSM_WITH_STS_NONRVSM, VFR_Not_Allowed_In_RVSM_AS, Formation_Flights_Forbidden_In_Rvsm_As, State_Formation_Flights_Rvsm_Incompatable }; /** * Type of errors (used for example to filter errors) */ enum RplErrorType {ErtIgnored, ErtEfpm, ErtAssoc, ErtProf, ErtRoute, ErtSyn}; union RplErrorIdentifier switch (RplErrorType) { case ErtEfpm : ErtEfpmIdent m_ErtEfpmIdent; case ErtAssoc : ErtAssocIdent m_ErtAssocIdent; case ErtProf : ErtProfIdent m_ErtProfIdent; case ErtRoute : ErtRouteIdent m_ErtRouteIdent; case ErtSyn : ErtSynIdent m_ErtSynIdent; case ErtIgnored : string m_notApplicable; }; /** * Structre that defines the error from which we derive the string m_displayableError */ struct RplErrorDescription { RplErrorType m_type; // Type of this error CfmuStrings m_listOfArguments; RplErrorIdentifier m_errorIdentifier; }; struct RplIgnoredError { string m_errorMessage; short m_creationTime; }; typedef sequence RplErrorsFromCatalog; /** * Load the catalog of Ignored Errors * * * @return the list of ignored errors. * @raises RplException of type RplUnavailableService. */ RplErrorsFromCatalog loadIgnoredErrors() raises (RplException); /** * Delete the error from the catalog and update the DB. * @parm i_RplErrorsFromCatalog is the the error (string representation + creation time) * to delete from the catalog. * @raises RplException of type RplFatalError ,RplUnavailableService, RplStatusError. */ void deleteIgnoredError ( in RplErrorsFromCatalog i_RplErrorCatalog ) raises (RplException); /** * Add the error to the catalog and update the DB. * pre-condition: *
    *
  • The error should be ignore-able *
* * @parm i_RplErrorDescription is the the error to add to the catalog * @raises RplException of type RplFatalError ,RplUnavailableService, RplStatusError, NotIgnorableError, AlreadyInCatalog. */ void addIgnoredError ( in RplErrorDescription i_RplErrorDescription ) raises (RplException); }; polyorb-2.8~20110207.orig/compilers/idlac/testsuite/regression/RT-34/0000755000175000017500000000000011750740340024435 5ustar xavierxavierpolyorb-2.8~20110207.orig/compilers/idlac/testsuite/regression/RT-34/introduced_identifier.idl0000644000175000017500000000024111750740337031474 0ustar xavierxaviermodule M { module Inner1 { typedef string S1; }; module Inner2 { typedef Inner1::S1 S2; typedef string Inner1; typedef string S1; }; }; polyorb-2.8~20110207.orig/compilers/idlac/testsuite/regression/RT-58/0000755000175000017500000000000011750740340024443 5ustar xavierxavierpolyorb-2.8~20110207.orig/compilers/idlac/testsuite/regression/RT-58/xx.idl0000644000175000017500000000016711750740337025606 0ustar xavierxavierinterface xx { enum Color {Red, Blue, Green}; // An interface that does not contain any user-defined operation. }; polyorb-2.8~20110207.orig/compilers/idlac/testsuite/regression/RT-55/0000755000175000017500000000000011750740340024440 5ustar xavierxavierpolyorb-2.8~20110207.orig/compilers/idlac/testsuite/regression/RT-55/xx.idl0000644000175000017500000000037311750740337025602 0ustar xavierxavierinterface xx { exception An_Exception { string m_reason; }; typedef sequence shortSeq; typedef short shortArray[10]; void foo1 (out shortSeq val) raises (An_Exception); void foo2 (out shortArray val) raises (An_Exception); }; polyorb-2.8~20110207.orig/compilers/idlac/testsuite/regression/RT-33/0000755000175000017500000000000011750740340024434 5ustar xavierxavierpolyorb-2.8~20110207.orig/compilers/idlac/testsuite/regression/RT-33/multiple_inh.idl0000644000175000017500000000023411750740337027624 0ustar xavierxaviermodule MyModule { interface IfA { void opA (); }; interface IfB { void opB (); }; interface IfC : IfA, IfB { void opC (); }; }; polyorb-2.8~20110207.orig/compilers/idlac/testsuite/adabroker.parser/0000755000175000017500000000000011750740340024731 5ustar xavierxavierpolyorb-2.8~20110207.orig/compilers/idlac/testsuite/adabroker.parser/testparser.idl0000644000175000017500000002211711750740337027630 0ustar xavierxavier/******************************************************** This file is meant to try every error message that the idl front-end can generate. These errors are tested rule by rule. *********************************************************/ /************************/ /* First, try each rule */ /************************/ /*** Test of rule 1 ***/ // An empty specification may be tested since it is not permitted /*** Test of rule 2 ***/ Error abstract Error module mymodule {} /*** Test of rule 3 ***/ module module toto module toto {}; module toto {}; /*** Test of rule 4 through 7 ***/ /* Test of rule Interface1 & 2 &3 */ interface interface tata; interface tata; interface tata interface tata{}; interface tutu{}; interface tata; interface titi{} abstract interface to; interface to{}; abstract interface tu{}; /*** Test of rule 13 through 26 ***/ /* Test of rule Value2 */ custom custom valuetype /* Test of rule Value3 */ abstract abstract valuetype abstract valuetype toto /* Test of rule Value4 */ valuetype valuetype toto /* Test of rule Value5 & Value6 */ valuetype toto {}; //valuetype titi supports toto /* Test of rule Value7 */ valuetype toto; valuetype forward_value; valuetype forward_value; /* Test of rule Value8 */ valuetype forward_value long; valuetype toto long; valuetype rightboxedvalue long; //valuetype FooSeq sequence ; /* Test of rule 19 */ /* test errors */ abstract valuetype value1 {}; abstract valuetype value2 : truncatable value1 {}; custom valuetype value3 : truncatable value1 {}; valuetype value4 {}; abstract valuetype value5 : value4 {}; valuetype value6 : truncatable value1 {}; valuetype value7; valuetype value8 : value7 {}; valuetype value9 long; valuetype value10 : value9 {}; interface valueinterface1 {}; valuetype value11 : valueinterface1 {}; valuetype value12 : {}; valuetype value13 : value1, value1 {}; valuetype value14 : value4, value4 {}; valuetype value15 : value4, value7 {}; valuetype value16 : value4, value9 {}; valuetype value17 : value4, valueinterface1 {}; valuetype value18 : value4, {}; interface valueinterface2; valuetype value19 supports valueinterface2 {}; valuetype value20 supports value4 {}; valuetype value21 supports {}; interface valueinterface3 {}; valuetype value22 supports valueinterface1, valueinterface3 {}; valuetype value23 supports valueinterface1, valueinterface2 {}; valuetype value24 supports valueinterface1, value4 {}; valuetype value25 supports valueinterface1, {}; valuetype value26 : value1, value1 Error {}; /* test ok */ valuetype value30 : value4 {}; abstract valuetype value31 {}; valuetype value32 : value4, value1 {}; //valuetype value33 : value4, value1, value 31 {}; valuetype value34 : truncatable value4 {}; valuetype value35 : truncatable value4, value1 {}; valuetype value36 : truncatable value4, value1, value31 {}; abstract valuetype value37 : value1 {}; abstract valuetype value38 : value1, value31 {}; abstract interface valueinterface4 {}; abstract interface valueinterface5 {}; valuetype value39 supports valueinterface1 {}; valuetype value40 supports valueinterface1, valueinterface4 {}; valuetype value41 supports valueinterface1, valueinterface4, valueinterface5 {}; abstract valuetype value42 supports valueinterface1, valueinterface3 {}; abstract valuetype value43 supports valueinterface1, valueinterface3, valueinterface4 {}; abstract valuetype value44 supports valueinterface1, valueinterface3, valueinterface4, valueinterface5 {}; /* Test of rule 21 */ valuetype value45 { Error }; /* Test of rule 22 */ valuetype value45 { private long[5] }; /* Test of rule 23 */ valuetype value46 { factory factory factory1 (); factory factory1 (); factory factory2 factory factory3 (; factory factory4 () }; /* Test of rule 25 */ valuetype value47 { factory factory1 (out long l); factory factory2 (long l); factory factory3 (Error); factory factory4 (out long l, out l ll); }; /* Test of rule 27 */ const boolean; const boolean const1 = TRUE; const boolean const1 = TRUE; const boolean const2 TRUE; const boolean const3; /* Test of rule 28 */ typedef any any1; const any1 const4 = TRUE; const error; /* Test of rule 29 */ const short const5 = 65000; const unsigned short const6 = -17; const long const7 = 4000000000; const unsigned long const8 = -17; /* Test of rule 30 */ const short const9 = 3 | 4; /* Test of rule 31 */ const short const10 = 3 ^ 4; /* Test of rule 32 */ const short const11 = 3 & 4; /* Test of rule 33 */ const short const12 = 3 << 4; const short const13 = 3 >> 4; /* Test of rule 34 */ const short const14 = 3 + 4; const short const15 = 3 - 4; /* Test of rule 35 */ const short const16 = 3 * 4; const short const17 = 3 / 4; const short const18 = 3 % 4; /* Test of rule 36-37 */ const short const19 = -3; const short const20 = +3; const short const21 = ~3; /* Test of rule 38 */ const wchar const22 = L'X'; const wstring const23 = L"Wide string"; const fixed const24 = 4.05d; const short const25 = ( 3 ; const short const26 = const; /* Test of rule 39 */ // nothing to be tested /* Test of rule 40 */ // nothing to be tested /* Test of rule 44 */ valuetype value48 { private Error; }; /* Test of Rule 45 */ typedef sequence ; /* Test of rule 50 */ union union1 switch (boolean) { case TRUE : long ; default : short short1; }; /* Test of rule 51 */ valuetype value49 { factory factory1 (in long); factory factory1 (in long l, in short l); }; /* Test of rule 59 */ unsigned Error; /* Test of rule 69 */ struct { long i;}; struct struct1 { long i; }; struct struct1 { long i; }; struct struct3 { long struct1; }; struct struct3 {; struct struct4 { long struct4; }; /* Test of rule 70 */ struct struct5 {}; /* Test of rule 71 */ struct struct6 { long i }; /* Test of rule 72 */ union; union union1 switch (boolean) { case true : long i; }; union union1 switch (boolean) { case true : long i; }; union union2; union union3 switch; union union4 switch (boolean {}; union union5 switch (boolean); union union6 switch (boolean) { case true : long i; ; /* Test of rule 73 */ union union7 switch (error) { case true : long i; }; typedef string string1; union union8 switch (string1) { case true : long i; }; /* Test of rule 74 */ union union9 switch (boolean) { }; union union10 switch (boolean) { default : long i; default : short j; }; /* Test of rule 75 */ union union11 switch (boolean) { error }; union union12 switch (boolean) { case true : long i }; /* Test of rule 76 */ union union13 switch (boolean) { case true : long i; case true : long j; }; union union14 switch (boolean) { case true long k; }; /* Test of rule 78 */ enum; enum enum1 { male, female }; enum enum1 { male, female }; enum enum2; enum enum3 {}; enum enum4 { male, female ; /* Test of rule 79 */ enum enum5 { , id }; enum enum6 { male , female }; /* Test of rule 80 */ typedef sequence sequence1; typedef sequence > sequence4; typedef sequence > sequence5; /* Test of rule 81 */ typedef string <10 string1; /* Test of rule 82 */ typedef wstring <10 wstring1; /* Test of rule 83 */ typedef boolean array1[2]; typedef boolean array1[2]; /* Test of rule 84 */ typedef boolean array2[3; /* Test of rule 85 */ interface toitoi{ attribute; readonly error; readonly attribute error; readonly attribute long; readonly attribute blurp; readonly attribute long titi; readonly attribute long titi; readonly attribute long tutu, trotro; readonly attribute long tutu,; attribute string abab, obob; }; /* Test of rule 86 */ exception; exception etoto1; exception etoto3}; exception etoto4{}; exception etoto4{}; exception etoto5{lbl}; exception etoto6{long }; exception etoto7{long truc}; exception etoto8{long truc;}; exception etoto8{long etoto8;}; /* Test of rule 87 */ boolean; oneway boolean; boolean op1 (); boolean op1 (); /* Test of rule 89 */ oneway error; /* Test of rule 90 */ boolean op2; boolean op3 (; /* Test of rule 91 */ boolean op4 (boolean); boolean op5 (error); /* Test of rule 92 */ boolean op6 (boolean b); /* Test of rule 93 */ boolean op7 () raises; boolean op8 () raises (); boolean op9 raises (; /* Test of rule 94 */ boolean op10 () context; boolean op11 () context (); boolean op12 context (; /* Test of rule 95 */ boolean op13 (inout error); /* Test of rule 96 */ typedef fixed fixed1; typedef fixed <6> fixed2; typedef fixed <6,7 fixed3; /* Test of check_context_string */ boolean op14 () context ("0error"); boolean op15 () context ("eréror"); boolean op16 () context ("err*or"); boolean op17 () context ("erroré"); /* Test of eval_or_expr */ const integer c1 = TRUE | 2; const integer c2 = 2 | true; const integer c3 = 3 | -5; const integer c4 = 10000000 | -5; /*******************************/ /* Now, try each miscellaneous */ /* point of the Idl langage */ /*******************************/ // non defined forwarded interface and valuetype module moduleA { valuetype valuetype1; interface interface1; }; // recursive structures module moduleB { typedef short typeA; interface interfaceA { typedef moduleB::interfaceA typeD; }; }; // recursive structs struct structA { structA s; }; polyorb-2.8~20110207.orig/compilers/idlac/testsuite/adabroker.parser/testparser.exp0000644000175000017500000000031311750740337027646 0ustar xavierxaviercatch "exec ../idlac $srcdir/adabroker.parser/testparser.idl 2> testparser.log; diff testparser.log testparser.out > /dev/null" rc if { $rc == "" } { pass "Parser test"; } else { fail "Parser test"; } polyorb-2.8~20110207.orig/compilers/idlac/testsuite/adabroker.torture/0000755000175000017500000000000011750740340025141 5ustar xavierxavierpolyorb-2.8~20110207.orig/compilers/idlac/testsuite/adabroker.torture/torture.idl0000644000175000017500000001112011750740337027340 0ustar xavierxavier// AdaBroker torture test. // This IDL file tests a lot of parser, expander and // code generator features. // $Id: //depot/adabroker/main/idlac/testsuite/adabroker.torture/torture.idl#9 $ #define HAVE_BOUNDED_STRINGS exception rootScopeException {}; module MyModule { struct MyStruct { unsigned long MyInt; boolean member3[4][8]; long a, b[2], c, d, e[4]; }; enum Color { Red, Green, Blue, Grey }; typedef sequence longSpectrum; typedef sequence > bidimSpectrum; typedef sequence> bidimSparseArray; typedef Color Hue, Tint, Paint; typedef Color spectrum[7]; typedef Color foo; // Constants const string aConstantString = "$Id: //depot/adabroker/main/idlac/testsuite/adabroker.torture/torture.idl#9 $" ; const long aConstantLong = 0; const long aComputedLong = 1 + 2 * 4 - 5; const double Pi = 3.14159265358; const long double oneSeventh = 1.0 / 7.0; const Color blood = Red; const boolean lies = FALSE; // Enum E2 must be moved out of the switch type // spec by expansion. union U switch (enum E2 { XX2, XY2 }) { case XX2: long hair; case XY2: long beard; }; // Check that scoped-names that denote enumerators // are parsed correctly. union Example switch (Color) { case Red: case Green: long Counter; case Blue: boolean Flags[4][8]; default: long Unknown; }; typedef struct Complex { double Re; double Im; } complexNumber; #ifdef HAVE_BOUNDED_STRINGS typedef string<2> saltString; typedef unsigned long uid_t; typedef unsigned long gid_t; struct passwd { string<8> pw_name; /* user name */ string<13> pw_passwd; /* user password */ uid_t pw_uid; /* user id */ gid_t pw_gid; /* group id */ wstring pw_gecos; /* real name */ string pw_dir; /* home directory */ string pw_shell; /* shell program */ }; #endif union U3 switch (boolean) { case TRUE: long foo; case FALSE: string bar; }; interface MyInterface; typedef sequence longSeq; struct forwardUsageOccurence1 { MyInterface aForwardRef; }; interface MyInterface { typedef sequence list; string echoString (in string arg) raises (rootScopeException); Color echoColor (in Color arg); MyInterface echoRef (in MyInterface arg); longSeq echoLongSeq (in longSeq arg); }; #pragma ID MyInterface "IDL:toto/titi/tata/tutu:1.0" #if 0 struct forwardUsageOccurence2 { // This should still refer to the /forward/ declaration. MyInterface anotherForwardRef; }; #endif exception MyException { unsigned long Einfo; }; interface IfB : MyInterface { long echoLong (in long Arg); void bindWith (in MyInterface otherInterface); void testException (in long Arg) raises (MyModule::MyException); readonly attribute unsigned long inBytes, outBytes; attribute Color currentColorSetting; }; interface smallIf { void smallOp (in long arg); }; #pragma prefix "adabroker.net" interface IfC : smallIf, IfB { void foo (); }; interface IfD : IfC, MyInterface { void bar (); }; typedef Complex Complex2; typedef complexNumber complexNumber2; #if 0 typedef MyInterface MyReference; // Must resolve to a /forward/ reference. typedef MyReference anObjectReference; typedef MyReference referencePack[5]; typedef MyInterface bunchOfObjects[2][4]; #endif interface Chicken; interface Egg; interface Egg { Chicken hatch (); }; interface Chicken { Egg lay (); }; // A test-case from the adabroker mailing list. module Ss_Reu_Time_Utilities { typedef long Time_Stamp_Type; typedef long Relative_Time_Stamp_Type; enum Time_Format_Type { H_Hour, On_Call, Absolute }; union Uniform_Time_Type switch ( Time_Format_Type ) { case H_Hour: case On_Call: Relative_Time_Stamp_Type Relative_Time_Stamp; case Absolute: Time_Stamp_Type Time_Stamp; }; }; typedef struct coords { double x; double y; } point; union U2 switch (long) { case 0: wstring name; case 1: Complex c; }; abstract interface Person { void greet (in string hello); }; abstract interface Employee { long summon (in string order); }; valuetype EmployeeRecord supports Person, Employee { private string Name; private string Email; private string SSN; factory init (in string name, in string SSN); double salary (in long age); }; }; typedef MyModule::complexNumber2 rootCplx; typedef ::MyModule::Complex rootCplx1; typedef MyModule::MyInterface rootRef; typedef long rootLong; polyorb-2.8~20110207.orig/compilers/idlac/testsuite/circular/0000755000175000017500000000000011750740340023310 5ustar xavierxavierpolyorb-2.8~20110207.orig/compilers/idlac/testsuite/circular/test_typedef_2.idl0000644000175000017500000000012611750740337026727 0ustar xavierxavier module Test_Typedef_2 { interface X; interface X {}; typedef X Y; }; polyorb-2.8~20110207.orig/compilers/idlac/testsuite/circular/test_struct_1.idl0000644000175000017500000000012611750740337026612 0ustar xavierxavier module Test_Struct_1 { interface X { }; struct Y { X a; }; }; polyorb-2.8~20110207.orig/compilers/idlac/testsuite/circular/test_exception_1.idl0000644000175000017500000000013311750740337027262 0ustar xavierxavier module Test_Exception_1 { interface X {}; exception Y { X a; }; }; polyorb-2.8~20110207.orig/compilers/idlac/testsuite/circular/test_sequence_2.idl0000644000175000017500000000014111750740337027074 0ustar xavierxavier module Test_Sequence_2 { interface X; interface X { }; typedef sequence Y; }; polyorb-2.8~20110207.orig/compilers/idlac/testsuite/circular/test_exception_2.idl0000644000175000017500000000015511750740337027267 0ustar xavierxavier module Test_Exception_2 { interface X; interface X {}; exception Y { X a; }; }; polyorb-2.8~20110207.orig/compilers/idlac/testsuite/circular/test_struct_2.idl0000644000175000017500000000012611750740337026613 0ustar xavierxavier module Test_Struct_2 { interface X { }; struct Y { X a; }; }; polyorb-2.8~20110207.orig/compilers/idlac/testsuite/circular/test_array_2.idl0000644000175000017500000000012711750740337026406 0ustar xavierxavier module Test_Array_2 { interface X; interface X {}; typedef X y[4]; }; polyorb-2.8~20110207.orig/compilers/idlac/testsuite/circular/test_typedef_1.idl0000644000175000017500000000010411750740337026722 0ustar xavierxavier module Test_Typedef_1 { interface X {}; typedef X Y; }; polyorb-2.8~20110207.orig/compilers/idlac/testsuite/circular/test_sequence_1.idl0000644000175000017500000000011711750740337027076 0ustar xavierxavier module Test_Sequence_1 { interface X { }; typedef sequence Y; }; polyorb-2.8~20110207.orig/compilers/idlac/testsuite/circular/test_array_1.idl0000644000175000017500000000010511750740337026401 0ustar xavierxavier module Test_Array_1 { interface X {}; typedef X y[4]; }; polyorb-2.8~20110207.orig/compilers/idlac/testsuite/omg/0000755000175000017500000000000011750740340022266 5ustar xavierxavierpolyorb-2.8~20110207.orig/compilers/idlac/testsuite/omg/a11.idl0000644000175000017500000000003711750740337023350 0ustar xavierxavier exception null_exception{}; polyorb-2.8~20110207.orig/compilers/idlac/testsuite/omg/a01.idl0000644000175000017500000000027511750740337023353 0ustar xavierxavier interface Asset { void op1(); void op2(); }; interface Vehicle { void op3(); void op4(); }; interface Tank : Vehicle, Asset { }; polyorb-2.8~20110207.orig/compilers/idlac/testsuite/omg/a06.idl0000644000175000017500000000005611750740337023355 0ustar xavierxavier typedef sequence> Ragged8; polyorb-2.8~20110207.orig/compilers/idlac/testsuite/omg/barn.idl0000644000175000017500000000046211750740337023712 0ustar xavierxaviertypedef long measure; interface Feed { attribute measure weight; }; interface Animal { enum State {SLEEPING, AWAKE}; boolean eat(inout Feed bag); // returns true if animal is full attribute State alertness; }; interface Horse : Animal{ void trot(in short distance); }; polyorb-2.8~20110207.orig/compilers/idlac/testsuite/omg/chicken.idl0000644000175000017500000000017311750740337024373 0ustar xavierxavier#ifndef CHICKEN #define CHICKEN interface Chicken; #include "egg.idl" interface Chicken { Egg lay(); }; #endif polyorb-2.8~20110207.orig/compilers/idlac/testsuite/omg/a12.idl0000644000175000017500000000120311750740337023345 0ustar xavierxavier #define ex_body {unsigned long minor; completion_status completed;} enum completion_status {COMPLETED_YES, COMPLETED_NO, COMPLETED_MAYBE}; enum exception_type {NO_EXCEPTION, USER_EXCEPTION, SYSTEM_EXCEPTION}; exception UNKNOWN ex_body; exception access_error { long file_access_code; string access_error_description; }; exception a_simple_exception{}; interface stack { typedef long element; exception overflow{long upper_bound;}; exception underflow{}; void push (in element the_element) raises (overflow); void pop (out element the_element) raises (underflow); }; polyorb-2.8~20110207.orig/compilers/idlac/testsuite/omg/egg.idl0000644000175000017500000000016511750740337023532 0ustar xavierxavier#ifndef EGG #define EGG interface Egg; #include "chicken.idl" interface Egg { Chicken hatch(); }; #endif polyorb-2.8~20110207.orig/compilers/idlac/testsuite/omg/cultivation.idl0000644000175000017500000000024311750740337025326 0ustar xavierxavier #include "barn.idl" interface Plow { long row(); void attach(in short blade); void harness(in Horse power); }; #pragma Subsystem("Farm"); polyorb-2.8~20110207.orig/compilers/idlac/testsuite/omg/a04.idl0000644000175000017500000000012011750740337023343 0ustar xavierxavier struct Example { long member1, member2; boolean member3[4][8]; }; polyorb-2.8~20110207.orig/compilers/idlac/testsuite/omg/a05.idl0000644000175000017500000000021011750740337023344 0ustar xavierxavier union Example switch (long) { case 1: case 3: long Counter; case 2: boolean Flags [4] [8]; default: long Unknown; }; polyorb-2.8~20110207.orig/compilers/idlac/testsuite/omg/a02.idl0000644000175000017500000000004011750740337023342 0ustar xavierxavier typedef boolean Result_Flag; polyorb-2.8~20110207.orig/compilers/idlac/testsuite/omg/a07.idl0000644000175000017500000000007011750740337023352 0ustar xavierxavier typedef string Name; typedef string<512> Title; polyorb-2.8~20110207.orig/compilers/idlac/testsuite/omg/a09.idl0000644000175000017500000000031211750740337023353 0ustar xavierxavier const double Pi = 3.1415926535; const short Line_Buffer_Length = 80; const long Page_Buffer_Length = (Line_Buffer_Length * 60) + 2; const long Legal_Page_Buffer_Length = (80 * 80) + 2; polyorb-2.8~20110207.orig/compilers/idlac/testsuite/omg/drawing.idl0000644000175000017500000000020411750740337024415 0ustar xavierxavier module Fresco { interface DrawingKit { typedef sequence Data8; typedef sequence Data32; }; }; polyorb-2.8~20110207.orig/compilers/idlac/testsuite/omg/a03.idl0000644000175000017500000000004211750740337023345 0ustar xavierxavier enum Color {Red, Green, Blue}; polyorb-2.8~20110207.orig/compilers/idlac/testsuite/omg/a10.idl0000644000175000017500000000016411750740337023350 0ustar xavierxavier typedef string Name, Street_Address[2]; typedef Name Employee_Name; typedef enum Color {Red, Green, Blue} RGB; polyorb-2.8~20110207.orig/compilers/idlac/testsuite/mapping/0000755000175000017500000000000011750740340023137 5ustar xavierxavierpolyorb-2.8~20110207.orig/compilers/idlac/testsuite/mapping/union2.idl0000644000175000017500000000025311750740337025051 0ustar xavierxavier // Unusual place for default case. union Example switch (long) { case 1: case 3: long Counter; default: long Unknown; case 2: boolean Flags [4] [8]; }; polyorb-2.8~20110207.orig/compilers/idlac/testsuite/mapping/union1.idl0000644000175000017500000000020011750740337025040 0ustar xavierxavier // no default case. union Example switch (long) { case 1: case 3: long Counter; case 2: boolean Flags [4] [8]; }; polyorb-2.8~20110207.orig/compilers/idlac/testsuite/mapping/arg.idl0000644000175000017500000000007211750740337024407 0ustar xavierxavierinterface all_types { Object echo12(in Object arg); }; polyorb-2.8~20110207.orig/compilers/idlac/testsuite/prefix/0000755000175000017500000000000011750740340023001 5ustar xavierxavierpolyorb-2.8~20110207.orig/compilers/idlac/testsuite/prefix/test003.idl0000644000175000017500000000012611750740337024702 0ustar xavierxavier module Test003 { typeprefix Test003 "aaa.ru"; local interface T2 { }; }; polyorb-2.8~20110207.orig/compilers/idlac/testsuite/lexer/0000755000175000017500000000000011750740340022623 5ustar xavierxavierpolyorb-2.8~20110207.orig/compilers/idlac/testsuite/lexer/testlexer_include.idl0000644000175000017500000000002211750740337027037 0ustar xavierxavier"#include OK" '\8'polyorb-2.8~20110207.orig/compilers/idlac/testsuite/lexer/testlexer.idl0000644000175000017500000000636511750740337025354 0ustar xavierxavier/**************************/ /*** preprocessor tests ***/ /**************************/ const char '\8'; #if 1 "#if OK"; #endif #if 0 #error #else "#else OK"; #endif #if 0 #error #elseif 1 "#elif OK" #endif #define string1 "#define OK" string1 #ifdef string1 "#ifdef OK" #endif #define string2 NE SERA PAS COMPILE #undef string2 #ifdef string2 #error #else "#undef OK" #endif #ifndef string2 "#ifndef OK" #endif #include "testlexer_include.idl" #pragma toto #line 500 '\8' #line 50 # define toto # undef toto /* bad ones */ // commented since the C preprocessor crashes // # error // # ( error ) /*********************/ /*** comment tests ***/ /*********************/ // conneries /* encore *** des *** /// conneries /// /* hello * / coucou */ /***********************/ /*** identifier test ***/ /***********************/ echo_string _string _Strong /* bad ones */ __string _String /*********************/ /*** keywords test ***/ /*********************/ abstract any attribute boolean case char const context custom default double enum exception factory FALSE fixed float in inout interface long module native Object octet oneway out private public raises readonly sequence short string struct supports switch TRUE truncatable typedef unsigned union ValueBase valuetype void wchar wstring /* bad ones */ Boolean false object true valuebase /*********************/ /*** literal tests ***/ /*********************/ /* integers */ 0 12 014 0xC /* characters */ 'r' '\n' '\'' '\\' '\1' '\12' '\123' '\xa' '\xab' '\ua' '\uab' '\uabc' '\uabcd' /* bad characters */ '' '\8' '\k' '\1234' '\xzfrt' '\xabc' '\ux' '\uabcde' /* fatal characters if preprocessor enable */ //''' //'\' /* fatal character */ //'z /* wide characters */ L'r' L'\n' L'\'' L'\\' L'\1' L'\12' L'\123' L'\xa' L'\xab' L'\ua' L'\uab' L'\uabc' L'\uabcd' /* bad wide characters */ L'' L'\8' L'\k' L'\1234' L'\xzfrt' L'\xabc' L'\ux' L'\uabcde' /* fatal wide characters if preprocessor enable */ //L''' //L'\' /* fatal wide character */ //L'z /* floats */ 1.45 0.2 .3 3. 5e3 3E4 .3e4 0. 0e0 /* strings */ "a string" "a more"" complicated"" one" "two" "strings" "very """ """complicated""" "with a \\ inside" "with a \""" inside" "with an octal char : \123" "with an octal char : \12345" "with an octal char : \03" "with an hexa char : \xab" "with an hexa char : \xabcd" "with a unicode char : \uabcd" "with a unicode char : \uabcdef" /* bad strings */ " a multiline string" "with a null octal char : \0" "with a bad hexa char : \xk" "with a bad unicode char : \uk" "with a bad escape char : \g" /* fatal string */ //"sans fin ... /* wide strings */ L"a string" L"a more"" complicated"" one" L"two" "strings" L"very """ """complicated""" L"with a \\ inside" L"with a \""" inside" L"with an " "espace between both parts" L"with an octal char : \123" L"with an octal char : \12345" L"with an octal char : \03" L"with an hexa char : \xab" L"with an hexa char : \xabcd" L"with a unicode char : \uabcd" L"with a unicode char : \uabcdef" /* bad wide strings */ L" a multiline string" L"with a null octal char : \0" L"with a bad hexa char : \xk" L"with a bad unicode char : \uk" L"with a bad escape char : \g" /* fatal wide string */ //L"sans fin ... /* fixed point */ 2d 5D 3.4d .5d 0d polyorb-2.8~20110207.orig/compilers/idlac/testsuite/raises/0000755000175000017500000000000011750740340022772 5ustar xavierxavierpolyorb-2.8~20110207.orig/compilers/idlac/testsuite/raises/attr-raises-4.idl0000644000175000017500000000033011750740337026065 0ustar xavierxavierinterface Attr_Raises_4 { exception Exc_1 {}; exception Exc_2 {}; attribute long a getraises (Exc_1); attribute long b setraises (Exc_2); attribute long c getraises (Exc_1) setraises (Exc_2); }; polyorb-2.8~20110207.orig/compilers/idlac/testsuite/raises/attr-raises-3.idl0000644000175000017500000000050011750740337026063 0ustar xavierxavierinterface Attr_Raises_3 { exception Exc {}; // All attribute declarations are incorrect. readonly attribute long a setraises (Exc); readonly attribute long b getraises (Exc); readonly attribute long c getraises (Exc) setraises (Exc); readonly attribute long d setraises (Exc) getraises (Exc); }; polyorb-2.8~20110207.orig/compilers/idlac/testsuite/raises/attr-raises-1.idl0000644000175000017500000000013711750740337026067 0ustar xavierxavierinterface Attr_Raises_1 { exception Exc {}; readonly attribute long a raises (Exc); }; polyorb-2.8~20110207.orig/compilers/idlac/testsuite/raises/attr-raises-2.idl0000644000175000017500000000021311750740337026063 0ustar xavierxavierinterface Attr_Raises_2 { exception Exc {}; attribute long a raises (Exc); // Incorrect: setraises/getraises must be used. }; polyorb-2.8~20110207.orig/compilers/idlac/testsuite/raises/attr-raises-5.idl0000644000175000017500000000023011750740337026065 0ustar xavierxavierinterface Attr_Raises_5 { exception Exc {}; // Incorrect order of getraises/setraises. attribute long d setraises (Exc) getraises (Exc); }; polyorb-2.8~20110207.orig/compilers/idlac/make_nodes.py0000644000175000017500000001545711750740337022154 0ustar xavierxavier#! /usr/bin/env python # import string, sys, re class Node: nodes = {} children = {} def __init__ (self, name, parent = None): self.name = name if parent: self.parent = parent elif name == "Root": self.parent = None else: self.parent = "Root" self.fields = [] if self.parent: if Node.children.has_key (self.parent): Node.children[self.parent].append (self.name) else: Node.children[self.parent] = [self.name] Node.nodes [name] = self def add_field (self, name, type, init): self.fields.append ((name, type, init)) def get_words (l): return string.split (l [0:-1]) def get_fields (n): if n.parent: return get_fields (Node.nodes [n.parent]) + n.fields else: return n.fields def append (kind, name, type): if fields.has_key (name): if typess [name] != type: sys.stderr.write ("Conflicting types for field %s\n" % name) sys.exit (1) fields [name].append (kind) else: fields [name] = [kind] typess [name] = type fields = {} typess = {} current = None started = 0 input = open (sys.argv [1], "r").readlines() for i in input: if re.match ("^\s*--", i): continue words = get_words (i) if not words: continue if not started: if words == ['START']: started = 1 continue continue if words == ['END']: break if len (words) >= 3 and words [1] == ':': if len (words) == 5 and words [3] == ':=': current.add_field (words [0], words [2], words [4]) else: current.add_field (words [0], words [2], None) elif len (words) > 0: if len (words) == 3 and words [1] == '<--': current = Node (words [0], words [2]) else: current = Node (words [0]) else: sys.stderr.write ("Unknown line: %s\n" % i) sys.exit (1) nodes = Node.nodes.keys() nodes.sort () types = [] spec = [] body = [] for n in nodes: if n == "Root": continue i = Node.nodes [n] types.append ("K_%s" % n) spec.append (" --") spec.append (" -- %s" % n) spec.append (" --") for (name, type, init) in get_fields (i): append (n, name, type) spec.append (" -- %-25s : %s" % (name, type)) spec.append (" --") spec.append ("") spec.append (" function Make_%s (Loc : Location) return Node_Id;" % n) spec.append (" function Is_%s (N : Node_Id) return Boolean;" % n) spec.append ("") body.append (" function Make_%s (Loc : Location) return Node_Id is" % n) body.append (" Node : constant Node_Access := new Node_Type;") body.append (" Index : constant Node_Id := Nodes_Table.Allocate;") body.append (" begin") body.append (" Node.Loc := Loc;") body.append (" Node.Kind := K_%s;" % n) for (name, type, init) in get_fields (i): if init: body.append (" Node.%s := %s;" % (name, init)) body.append (" Nodes_Table.Table (Index) := Node;") body.append (" return Index;") body.append (" end Make_%s;" % n) body.append ("") body.append (" function Is_%s (N : Node_Id) return Boolean is" % n) body.append (" begin") body.append (" return Kind (N) = K_%s" % n) if Node.children.has_key (n): for c in Node.children[n]: body.append (" or else Is_%s (N)" % (c)) body.append (" or else False;") body.append (" end Is_%s;" % n) body.append ("") f = fields.keys () f.sort () for name in f: type = typess [name] kinds = fields [name] spec.append (" function %s" % (name,)); spec.append (" (N : Node_Id) return %s;" % (type,)) spec.append (" procedure Set_%s" % (name,)) spec.append (" (N : Node_Id; V : %s);" % (type,)) body.append (" function %s" % (name,)) body.append (" (N : Node_Id) return %s" % (type,)) body.append (" is") body.append (" Node : constant Node_Access := Nodes_Table.Table (N);") body.append (" begin") for k in range (len (kinds)): if k == 0: if len (kinds) == 1: assrt = [" pragma Assert (Node.Kind = K_%s);" % kinds [k]] else: assrt = [" pragma Assert (Node.Kind = K_%s" % kinds [k]] else: if k == len (kinds) - 1: expr = ");" else: expr = "" assrt.append (" or else Node.Kind = K_%s%s" % (kinds [k], expr)) body = body + assrt body.append (" return Node.%s;" % name) body.append (" end %s;" % name) body.append ("") body.append (" procedure Set_%s" % (name,)) body.append (" (N : Node_Id; V : %s)" % (type,)) body.append (" is") body.append (" Node : constant Node_Access := Nodes_Table.Table (N);") body.append (" begin") body = body + assrt body.append (" Node.%s := V;" % name) body.append (" end Set_%s;" % name) body.append ("") if type == "Node_List": spec.append (" procedure Append_Node_To_%s" % (name)) spec.append (" (N : Node_Id; V : Node_Id);") body.append (" procedure Append_Node_To_%s" % (name)) body.append (" (N : Node_Id; V : Node_Id)") body.append (" is") body.append (" begin") body.append (" Set_%s" % (name)) body.append (" (N, Append_Node (%s (N), V));" % (name)) body.append (" end Append_Node_To_%s;" % (name)) body.append ("") spec.append ("") # with Nodes; use Nodes; print """with GNAT.Table; with Idl_Fe.Types; use Idl_Fe.Types; package Idl_Fe.Tree is type Node_Kind is""" for n in range (len (types)): if n == 0: s = '(' else: s = ' ' if n == len (types) - 1: e = ');' else: e = ',' print " %s%s%s" % (s, types [n], e) print for i in spec: print i print "private" print print " type Node_Type is record" for i in f: if typess [i] == "Node_Id": print " %-25s : %-25s%s;" % (i, typess [i], ":= No_Node") elif typess [i] == "Node_List": print " %-25s : %-25s%s;" % (i, typess [i], ":= Nil_List") else: print " %-25s : %s%s;" % (i, typess [i], "") print " end record;" print """ type Node_Access is access Node_Type; package Nodes_Table is new GNAT.Table (Table_Component_Type => Node_Access, Table_Index_Type => Node_Id, Table_Low_Bound => 1, Table_Initial => 1024, Table_Increment => 100); end Idl_Fe.Tree;""" print "package body Idl_Fe.Tree is" print print " use Nodes_Table;" print for i in body: print i print "end Idl_Fe.Tree;" polyorb-2.8~20110207.orig/compilers/idlac/ada_be-source_streams.ads0000644000175000017500000002516411750740337024411 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- A D A _ B E . S O U R C E _ S T R E A M S -- -- -- -- S p e c -- -- -- -- Copyright (C) 2001-2007, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with Ada.Strings.Unbounded; use Ada.Strings.Unbounded; package Ada_Be.Source_Streams is Indent_Size : constant := 3; type Unit_Kind is (Unit_Spec, Unit_Body); -- The kind of a compilation unit type Compilation_Unit (Kind : Unit_Kind := Unit_Spec) is limited private; type Compilation_Unit_Access is access all Compilation_Unit; -- A complete compilation unit type Library_Unit is array (Unit_Kind) of Compilation_Unit; -- A matching package declaration and package body Max_Diversions : constant := 32; type Diversion is private; -- A compilation unit can have several diversions, -- each of which is a linear stream of source code -- lines. There can be at most Max_Diversions of these -- in one compilation unit. -- Predefined diversions: Visible_Declarations : constant Diversion; Private_Declarations : constant Diversion; Generic_Formals : constant Diversion; Elaboration : constant Diversion; -- The Visible_Declarations and Private_Declarations -- diversions correspond to the visible and private -- parts of the compilation unit's declarative region. -- The Elaboration diversion corresponds to the elaboration -- statements in a package body. type Elab_Control_Pragma is (None, -- Add no elaboration control pragma Elaborate, -- Add a pragma Elaborate Elaborate_All); -- Add a pragma Elaborate_All -- Possible elaboration control pragmas that can be added -- for a dependency. --------------------------------------------------- -- The following subprograms operate globally on -- -- a compilation unit. -- --------------------------------------------------- function Name (CU : Compilation_Unit) return String; -- Return the name of CU. function Allocate_User_Diversion return Diversion; -- Creates a system-wide user-defined diversion identifier -- and returns it. function Current_Diversion (CU : Compilation_Unit) return Diversion; -- Return the current diversion of CU. procedure Divert (CU : in out Compilation_Unit; Whence : Diversion); -- Set CU's current diversion to Whence. -- If CU is a Unit_Spec, it is not allowed to set the current -- diversion to Elaboration. -- If CU is a Unit_Body, it is not allowed to set the current -- diversion to Private_Declarations or Generic_Formals. procedure Undivert (CU : in out Compilation_Unit; D : Diversion); -- Insert the contents of diversion D into CU at the current -- position. D is emptied and unused after Undivert returns. function Current_Diversion_Empty (CU : Compilation_Unit) return Boolean; -- True iff CU's current diversion is empty procedure Add_With (Unit : in out Compilation_Unit; Dep : String; Use_It : Boolean := False; Elab_Control : Elab_Control_Pragma := None; No_Warnings : Boolean := False); -- Add Dep to the semantic dependecies of Unit, if it is not already -- present. If Use_It is true, a "use" clause will be added for that unit. -- Additionnally, an elaboration control pragma may be inserted according -- to Elab_Control. If No_Warnings is True, also emit a -- pragma Warnings (Off, Withed_Unit) (useful e.g. when no entities -- from the withed unit are referenced.) -- If Add_With is called several times for the same unit: -- - the unit is use'd if at least one call was made with Use_It set to -- True; -- - the elab control is set to Elaborate_All if any call was made with -- Elab_Control = Elaborate_All, -- - else the elab control is set to Elaborate if any call was made with -- Elab_Control = Elaborate, -- - else the elab control is set to None. procedure Add_Elaborate_Body (U_Spec : in out Compilation_Unit; U_Body : Compilation_Unit); -- Add a pragma Elaborate_Body to U_Spec if U_Body is not empty procedure Suppress_Warning_Message (Unit : in out Compilation_Unit); -- Remove warning such as "Do not modify this file". Used for -- implementations. procedure New_Compilation_Unit (CU : out Compilation_Unit; Kind : Unit_Kind; Name : String; Corresponding_Spec : Compilation_Unit_Access := null); -- Prepare to generate a new compilation unit. If Kind is Unit_Spec, -- Corresponding_Spec is ignored and shall be null. If Kind is Unit_Body, -- it shall be an access to the corresponding spec. procedure Set_Template_Mode (Unit : in out Compilation_Unit; Mode : Boolean); -- Set Unit's template mode. When a unit is in template mode, code -- insertion is not taken into account to determine whether the unit -- is 'empty' for the purpose of procedure Generate. procedure Set_Comment_Out_Mode (Unit : in out Compilation_Unit; Mode : Boolean); -- Set Unit's comment out mode. While a unit is in comment out mode, -- any generated code is output as comments, and any Add_With call is -- ignored. function Set_Output_Directory (Dir : String) return Boolean; -- Set output directory to Dir. False is returned upon failure -- (case of a non-existing directory). procedure Generate (Unit : Compilation_Unit; Is_Generic_Instantiation : Boolean := False; To_Stdout : Boolean := False); -- Produce the source code for Unit. -- If Is_Generic_Instantiation, then Unit's Kind must -- be Unit_Spec, and Unit must be a library-level -- instantiation of a generic package. -- If To_Stdout, the code is emitted to standard output. -- Empty units are omitted altogether. ---------------------------------------------------------------- -- The following subprograms operate on the current diversion -- ---------------------------------------------------------------- procedure Put (Unit : in out Compilation_Unit; Text : String); -- Append a text fragment to a compilation unit. procedure Put_Line (Unit : in out Compilation_Unit; Line : String); -- Append a whole line to a compilation unit. procedure New_Line (Unit : in out Compilation_Unit); -- Append a blank line to a compilation unit, or -- terminate an unfinished line. procedure Inc_Indent (Unit : in out Compilation_Unit); procedure Dec_Indent (Unit : in out Compilation_Unit); -- Increment or decrement the indentation level -- for the compilation unit. private type String_Ptr is access String; type Dependency_Node; type Dependency is access Dependency_Node; type Diversion is new Integer range 0 .. Max_Diversions - 1; Visible_Declarations : constant Diversion := 0; Private_Declarations : constant Diversion := 1; Generic_Formals : constant Diversion := 2; Elaboration : constant Diversion := 3; subtype Predefined_Diversions is Diversion range Visible_Declarations .. Elaboration; subtype User_Diversions is Diversion range Predefined_Diversions'Last + 1 .. Diversion'Last; type Diversion_Data is record Empty : Boolean := True; -- True iff some text has been Insert'ed in this diversion outside of -- template mode. Library_Item : Unbounded_String; Indent_Level : Natural := 0; At_BOL : Boolean := True; -- True if a line has just been ended, and the -- indentation space for the new line has not -- been written yet. end record; type Diversion_Set is array (Diversion) of aliased Diversion_Data; type Compilation_Unit (Kind : Unit_Kind := Unit_Spec) is record Library_Unit_Name : String_Ptr; No_Warning : Boolean := False; -- If True, warnings are suppressed on the unit Comment_Out_Mode : Boolean := False; -- If True, all code inserted in the current diversion is commented out Template_Mode : Boolean := False; -- If True, code insertion in the current diversion does not cause -- it to become non-empty. Context_Clause : Dependency := null; -- List of with clauses to be generated for this compilation unit Current_Diversion : Diversion := Visible_Declarations; Diversions : Diversion_Set; case Kind is when Unit_Spec => Elaborate_Body : Boolean := False; -- If True, a pragma Elaborate_Body is generated when Unit_Body => Corresponding_Spec : Compilation_Unit_Access; end case; end record; end Ada_Be.Source_Streams; polyorb-2.8~20110207.orig/compilers/idlac/idl_fe-display_tree.adb0000644000175000017500000006027511750740337024047 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- I D L _ F E . D I S P L A Y _ T R E E -- -- -- -- B o d y -- -- -- -- Copyright (C) 2001-2008, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by ACT Europe. -- -- (email: sales@act-europe.fr) -- -- -- ------------------------------------------------------------------------------ with Ada.Wide_Text_IO; with Ada.Text_IO; use Ada.Text_IO; with Ada.Characters.Latin_1; with Idlac_Utils; use Idlac_Utils; with Idl_Fe.Tree.Synthetic; use Idl_Fe.Tree, Idl_Fe.Tree.Synthetic; package body Idl_Fe.Display_Tree is Blanks : constant String (1 .. 80) := (others => ' '); procedure Disp_Tree (N : Node_Id; Indent : Natural; Full : Boolean); procedure Disp_Indent (Indent : Natural; S : String := "") is N : Natural; begin N := Indent; while N > 0 loop if N < Blanks'Length then Put (Blanks (1 .. N)); N := 0; else Put (Blanks); N := N - Blanks'Length; end if; end loop; if S'Length > 0 then Put_Line (S); end if; end Disp_Indent; procedure Disp_List (List : Node_List; Indent : Natural; Full : Boolean) is It : Node_Iterator; N : Node_Id; begin Init (It, List); while not Is_End (It) loop Get_Next_Node (It, N); if N /= No_Node then Disp_Tree (N, Indent, Full); else Disp_Indent (Indent, "*null*"); end if; end loop; end Disp_List; procedure Disp_Binary (N : Node_Id; Indent : Natural; Full : Boolean; Op : String) is begin Put_Line ("binary operator : " & Op); Disp_Const_Value (Expr_Value (N), Indent); Disp_Indent (Indent, "left:"); Disp_Tree (Left (N), Indent, Full); Disp_Indent (Indent, "right:"); Disp_Tree (Right (N), Indent, Full); end Disp_Binary; procedure Disp_Unary (N : Node_Id; Indent : Natural; Full : Boolean; Op : String) is begin Put_Line ("unary operator : " & Op); Disp_Const_Value (Expr_Value (N), Indent); Disp_Indent (Indent, "operand:"); Disp_Tree (Operand (N), Indent, Full); end Disp_Unary; procedure Disp_Const_Value (Expr : Constant_Value_Ptr; Indent : Natural) is begin Disp_Indent (Indent); Put ("value : "); if Expr /= null then case Expr.Kind is when C_Octet => Put_Line ("octet " & Idl_Integer'Image (Expr.Integer_Value)); when C_Short => Put_Line ("short " & Idl_Integer'Image (Expr.Integer_Value)); when C_Long => Put_Line ("long " & Idl_Integer'Image (Expr.Integer_Value)); when C_LongLong => Put_Line ("long long " & Idl_Integer'Image (Expr.Integer_Value)); when C_UShort => Put_Line ("unsigned short " & Idl_Integer'Image (Expr.Integer_Value)); when C_ULong => Put_Line ("unsigned long " & Idl_Integer'Image (Expr.Integer_Value)); when C_ULongLong => Put_Line ("unsigned long long " & Idl_Integer'Image (Expr.Integer_Value)); when C_General_Integer => Put_Line ("general integer " & Idl_Integer'Image (Expr.Integer_Value)); when C_String => Put_Line ("string " & Ada.Characters.Latin_1.Quotation & Expr.String_Value.all & Ada.Characters.Latin_1.Quotation); when C_WString => Put ("wide string literal: " & Ada.Characters.Latin_1.Quotation); Ada.Wide_Text_IO.Put (Expr.WString_Value.all); Put_Line ("" & Ada.Characters.Latin_1.Quotation); when C_Char => Put_Line ("character " & Idl_Character'Image (Expr.Char_Value)); when C_WChar => Put_Line ("wide character " & Idl_Wide_Character'Image (Expr.WChar_Value)); when C_Fixed => Put_Line ("fixed point " & "<" & Idl_Integer'Image (Expr.Digits_Nb) & "," & Idl_Integer'Image (Expr.Scale) & "> " & Idl_Integer'Image (Expr.Fixed_Value)); when C_General_Fixed => Put_Line ("general fixed point " & "<" & Idl_Integer'Image (Expr.Digits_Nb) & "," & Idl_Integer'Image (Expr.Scale) & "> " & Idl_Integer'Image (Expr.Fixed_Value)); when C_Float => Put_Line ("float " & Idl_Float'Image (Expr.Float_Value)); when C_Double => Put_Line ("double " & Idl_Float'Image (Expr.Float_Value)); when C_LongDouble => Put_Line ("long double " & Idl_Float'Image (Expr.Float_Value)); when C_General_Float => Put_Line ("general float " & Idl_Float'Image (Expr.Float_Value)); when C_Boolean => Put_Line ("boolean " & Idl_Boolean'Image (Expr.Boolean_Value)); when C_Enum => Put_Line ("enum " & Name (Expr.Enum_Name) & ": " & Name (Expr.Enum_Value)); when C_No_Kind => Put_Line ("no_kind"); end case; else Put_Line ("no correct value."); end if; end Disp_Const_Value; -- Disp tree procedure procedure Disp_Tree (N : Node_Id; Indent : Natural; Full : Boolean) is N_Indent : constant Natural := Indent + Offset; begin Disp_Indent (Indent); if N = No_Node then Put_Line ("node not properly defined"); return; end if; Put ("[" & Img (N)); if Is_Named (N) then Put ("/" & Img (Parent_Scope (N))); end if; Put ("] "); case Kind (N) is when K_Scoped_Name => Put ("scoped name: -> " & Img (Value (N)) & " " & Name (Value (N))); if S_Type (N) /= No_Node then Put_Line (" (type: " & Img (S_Type (N)) & " " & Node_Kind'Image (Kind (S_Type (N))) & ")"); else Put_Line (""); end if; when K_Repository => Put_Line ("repository"); Disp_List (Contents (N), N_Indent, Full); when K_Module => Put_Line ("module " & Name (N)); Disp_Indent (N_Indent, "content:"); Disp_List (Contents (N), N_Indent + Offset, Full); when K_Interface => if Abst (N) then Put ("abstract "); end if; Put_Line ("interface " & Name (N)); if Repository_Id (N) /= No_Node then Disp_Indent (Indent + 2); Put_Line ("repository id: """ & String_Value (Repository_Id (N)) & """"); end if; if Full then if Parents (N) /= Nil_List then Disp_Indent (N_Indent); Put_Line ("parents:"); Disp_List (Parents (N), N_Indent + Offset, False); end if; end if; Disp_List (Contents (N), N_Indent, Full); when K_Forward_Interface => if Abst (N) then Put ("abstract "); end if; if Forward (N) /= No_Node then Put_Line ("forward interface " & Name (Forward (N)) ); else Put_Line ("forward interface (never declared!!) " & Name (N)); end if; when K_ValueType => if Abst (N) then Put ("abstract "); end if; if Custom (N) then Put ("custom "); end if; Put_Line ("valuetype " & Name (N)); if Full then if Parents (N) /= Nil_List then Disp_Indent (N_Indent); if Truncatable (N) then Put_Line ("parents (truncatable):"); else Put_Line ("parents:"); end if; Disp_List (Parents (N), N_Indent + Offset, False); end if; if Supports (N) /= Nil_List then Disp_Indent (N_Indent); Put_Line ("supports:"); Disp_List (Supports (N), N_Indent + Offset, False); end if; end if; Disp_List (Contents (N), N_Indent, Full); when K_Forward_ValueType => if Abst (N) then Put ("abstract "); end if; if Forward (N) /= No_Node then Put_Line ("forward valuetype " & Name (Forward (N)) ); else Put_Line ("forward valuetype (never declared!!) " & Name (N)); end if; when K_Boxed_ValueType => Put_Line ("boxed valuetype " & Name (N)); Disp_Tree (Boxed_Type (N), N_Indent + Offset, Full); when K_State_Member => if Is_Public (N) then Put ("public"); else Put ("private"); end if; Put_Line (" statemember"); Disp_Indent (N_Indent, "type:"); Disp_Tree (State_Type (N), N_Indent + Offset, Full); Disp_Indent (N_Indent, "declarators:"); Disp_List (State_Declarators (N), N_Indent + Offset, Full); when K_Initializer => Put_Line ("initializer " & Name (N)); if Param_Decls (N) /= Nil_List then Disp_Indent (N_Indent, "parameters:"); Disp_List (Param_Decls (N), N_Indent + Offset, Full); end if; when K_Operation => begin Put ("operation "); if Is_Oneway (N) then Put ("oneway "); end if; Put (Name (N)); if Is_Implicit_Inherited (N) then Put (" (implicit inherited)"); end if; New_Line; Disp_Indent (N_Indent, "type:"); Disp_Tree (Operation_Type (N), N_Indent + Offset, Full); if Parameters (N) /= Nil_List then Disp_Indent (N_Indent, "parameters:"); Disp_List (Parameters (N), N_Indent + Offset, Full); end if; if Raises (N) /= Nil_List then Disp_Indent (N_Indent, "raises:"); Disp_List (Raises (N), N_Indent + Offset, Full); end if; if Contexts (N) /= Nil_List then Disp_Indent (N_Indent, "contexts:"); Disp_List (Contexts (N), N_Indent + Offset, Full); end if; end; when K_Attribute => Put ("attribute "); if Is_Readonly (N) then Put ("readonly "); end if; Put_Line (""); Disp_Indent (N_Indent, "type:"); Disp_Tree (A_Type (N), N_Indent + Offset, Full); Disp_Indent (N_Indent, "declarators:"); Disp_List (Declarators (N), N_Indent + Offset, Full); when K_Void => Put_Line ("void"); when K_Float => Put_Line ("float"); when K_Double => Put_Line ("double"); when K_Long_Double => Put_Line ("long double"); when K_Short => Put_Line ("short"); when K_Long => Put_Line ("long"); when K_Long_Long => Put_Line ("long long"); when K_Unsigned_Long => Put_Line ("unsigned long"); when K_Unsigned_Short => Put_Line ("unsigned short"); when K_Unsigned_Long_Long => Put_Line ("unsigned long long"); when K_Char => Put_Line ("char"); when K_Wide_Char => Put_Line ("wide_char"); when K_Boolean => Put_Line ("boolean"); when K_Object => Put_Line ("object"); when K_Octet => Put_Line ("octet"); when K_Any => Put_Line ("any"); when K_String => Put ("string "); if Bound (N) = No_Node then Put_Line ("(unbounded)"); else Put_Line ("bounds:"); Disp_Tree (Bound (N), N_Indent, Full); end if; when K_Wide_String => Put ("wide string "); if Bound (N) = No_Node then Put_Line ("(unbounded)"); else Put_Line ("bounds:"); Disp_Tree (Bound (N), N_Indent, Full); end if; when K_Param => Put ("param "); case Mode (N) is when Mode_In => Put_Line ("in"); when Mode_Out => Put_Line ("out"); when Mode_Inout => Put_Line ("inout"); end case; Disp_Indent (N_Indent, "name:"); Disp_Tree (Declarator (N), N_Indent + Offset, False); if Param_Type (N) /= No_Node then case (Kind (Param_Type (N))) is when K_Interface | K_ValueType => Disp_Indent (N_Indent, "type: " & Name (Param_Type (N))); when others => Disp_Indent (N_Indent, "type: "); Disp_Tree (Param_Type (N), N_Indent, Full); end case; else Disp_Indent (N_Indent, "type: no valid type"); end if; when K_Exception => Put ("exception "); Put_Line (Name (N)); if Repository_Id (N) /= No_Node then Disp_Indent (Indent + 2); Put_Line ("repository id: """ & String_Value (Repository_Id (N)) & """"); end if; if Full then Disp_Indent (N_Indent, "members:"); Disp_List (Members (N), N_Indent + Offset, Full); end if; when K_Member => Put_Line ("member"); Disp_Indent (N_Indent, "declarator:"); Disp_List (Decl (N), N_Indent + Offset, Full); Disp_Indent (N_Indent, "type:"); Disp_Tree (M_Type (N), N_Indent + Offset, Full); when K_Declarator => Put_Line ("declarator " & Name (N)); if Array_Bounds (N) /= Nil_List then Disp_Indent (N_Indent, "bounds:"); Disp_List (Array_Bounds (N), N_Indent + Offset, True); end if; when K_Union => Put_Line ("union " & Name (N)); if Full then Disp_Indent (N_Indent, "switch type:"); Disp_Tree (Switch_Type (N), N_Indent + Offset, True); Disp_Indent (N_Indent, "cases:"); Disp_List (Cases (N), N_Indent + Offset, True); end if; when K_Case => Put_Line ("case"); Disp_Indent (N_Indent, "labels (*null* means default):"); Disp_List (Labels (N), N_Indent + Offset, Full); Disp_Indent (N_Indent, "type:"); Disp_Tree (Case_Type (N), N_Indent + Offset, Full); Disp_Indent (N_Indent, "declarator:"); Disp_Tree (Case_Decl (N), N_Indent + Offset, Full); when K_Or_Expr => Disp_Binary (N, N_Indent + Offset, Full, "or"); when K_Xor_Expr => Disp_Binary (N, N_Indent + Offset, Full, "xor"); when K_And_Expr => Disp_Binary (N, N_Indent + Offset, Full, "and"); when K_Shl_Expr => Disp_Binary (N, N_Indent + Offset, Full, "shl"); when K_Shr_Expr => Disp_Binary (N, N_Indent + Offset, Full, "shr"); when K_Add_Expr => Disp_Binary (N, N_Indent + Offset, Full, "add"); when K_Sub_Expr => Disp_Binary (N, N_Indent + Offset, Full, "sub"); when K_Mul_Expr => Disp_Binary (N, N_Indent + Offset, Full, "mul"); when K_Div_Expr => Disp_Binary (N, N_Indent + Offset, Full, "div"); when K_Mod_Expr => Disp_Binary (N, N_Indent + Offset, Full, "mod"); when K_Not_Expr => Disp_Unary (N, N_Indent + Offset, Full, "not"); when K_Neg_Expr => Disp_Unary (N, N_Indent + Offset, Full, "neg"); when K_Id_Expr => Disp_Unary (N, N_Indent + Offset, Full, "id"); when K_Primary_Expr => Put_Line ("primary expression"); Disp_Const_Value (Expr_Value (N), N_Indent + Offset); Disp_Tree (Operand (N), N_Indent, Full); when K_Lit_Integer => Put_Line ("integer literal: "); Disp_Const_Value (Expr_Value (N), N_Indent + Offset); when K_Lit_String => Put_Line ("string literal: "); Disp_Const_Value (Expr_Value (N), N_Indent + Offset); when K_Lit_Wide_String => Put_Line ("wide string literal: "); Disp_Const_Value (Expr_Value (N), N_Indent + Offset); when K_Lit_Character => Put_Line ("character literal: "); Disp_Const_Value (Expr_Value (N), N_Indent + Offset); when K_Lit_Wide_Character => Put_Line ("wide character literal: "); Disp_Const_Value (Expr_Value (N), N_Indent + Offset); when K_Lit_Fixed_Point => Put_Line ("fixed point literal: "); Disp_Const_Value (Expr_Value (N), N_Indent + Offset); when K_Lit_Floating_Point => Put_Line ("floating point literal: "); Disp_Const_Value (Expr_Value (N), N_Indent + Offset); when K_Lit_Boolean => Put_Line ("boolean literal: "); Disp_Const_Value (Expr_Value (N), N_Indent + Offset); when K_Lit_Enum => Put_Line ("enum literal: "); Disp_Const_Value (Expr_Value (N), N_Indent + Offset); when K_Struct => Put ("struct " & Name (N)); if Is_Exception_Members (N) then Put_Line (" (exception members)"); else New_Line; end if; if Full then Disp_Indent (N_Indent, "members:"); Disp_List (Members (N), N_Indent + Offset, True); end if; when K_Enum => Put_Line ("enum " & Name (N)); if Full then Disp_Indent (N_Indent, "enumerators:"); Disp_List (Enumerators (N), N_Indent + Offset, True); end if; when K_ValueBase => Put_Line ("ValueBase"); when K_Enumerator => Put_Line ("enumerator: " & Name (N)); when K_Type_Declarator => Put_Line ("type declarator:"); Disp_Indent (N_Indent, "type:"); Disp_Tree (T_Type (N), N_Indent + Offset, Full); Disp_Indent (N_Indent, "declarators:"); Disp_List (Declarators (N), N_Indent + Offset, Full); when K_Sequence => Put_Line ("sequence"); Disp_Indent (N_Indent, "type:"); Disp_Tree (Sequence_Type (N), N_Indent + Offset, Full); if Bound (N) /= No_Node then Disp_Indent (N_Indent, "bound:"); Disp_Tree (Bound (N), N_Indent + Offset, Full); end if; when K_Const_Dcl => Put_Line ("const " & Name (N)); Disp_Indent (N_Indent, "type:"); Disp_Tree (Constant_Type (N), N_Indent + Offset, Full); Disp_Indent (N_Indent, "expr:"); Disp_Tree (Expression (N), N_Indent + Offset, Full); when K_Fixed => Put_Line ("fixed"); Disp_Tree (Digits_Nb (N), N_Indent, Full); Disp_Tree (Scale (N), N_Indent, Full); when K_Native => Put_Line ("native:"); Disp_Tree (Declarator (N), N_Indent + Offset, Full); ------------------------------------------------------- -- The following nodes are generated by the expander -- -- and have no equivalent in standard IDL syntax. -- ------------------------------------------------------- when K_Ben_Idl_File => Put_Line ("ben_idl_file " & Name (N)); Disp_List (Contents (N), N_Indent, Full); when K_Sequence_Instance => Put_Line ("sequence_instance " & Name (N)); Disp_Tree (Sequence (N), N_Indent, Full); when K_String_Instance => Put ("string_instance " & Name (N)); if Is_Wide (N) then Put_Line (" (wide)"); else New_Line; end if; Disp_Tree (Bound (N), N_Indent, Full); when others => Put_Line ("not implemented yet"); end case; end Disp_Tree; procedure Disp_Tree (Tree : Node_Id) is begin Disp_Tree (Tree, 0, True); end Disp_Tree; end Idl_Fe.Display_Tree; polyorb-2.8~20110207.orig/compilers/idlac/ada_be-idl2ada-value_skel.ads0000644000175000017500000000447111750740337025001 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- A D A _ B E . I D L 2 A D A . V A L U E _ S K E L -- -- -- -- S p e c -- -- -- -- Copyright (C) 2001 Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by ACT Europe. -- -- (email: sales@act-europe.fr) -- -- -- ------------------------------------------------------------------------------ private package Ada_Be.Idl2Ada.Value_Skel is Suffix : constant String := ".Value_Skel"; procedure Gen_Node_Spec (CU : in out Compilation_Unit; Node : Node_Id); procedure Gen_Node_Body (CU : in out Compilation_Unit; Node : Node_Id); end Ada_Be.Idl2Ada.Value_Skel; polyorb-2.8~20110207.orig/compilers/idlac/ada_be-idl2ada.adb0000644000175000017500000032677111750740337022642 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- A D A _ B E . I D L 2 A D A -- -- -- -- B o d y -- -- -- -- Copyright (C) 2001-2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- This unit contains both generation routines that are -- of general use to the whole Ada 95 back-end, and specialised -- routines for the generation of calling stubs. -- XXX The latter should be moved away to a Ada_Be.Idl2Ada.Stubs -- child unit one day. with Ada.Characters.Conversions; with Ada.Strings.Unbounded; with Ada.Unchecked_Deallocation; with Idl_Fe.Tree; use Idl_Fe.Tree; with Idl_Fe.Tree.Synthetic; use Idl_Fe.Tree.Synthetic; with Idlac_Flags; use Idlac_Flags; with Ada_Be.Identifiers; use Ada_Be.Identifiers; with Ada_Be.Temporaries; use Ada_Be.Temporaries; with Ada_Be.Debug; pragma Elaborate_All (Ada_Be.Debug); with Ada_Be.Idl2Ada.Impl; with Ada_Be.Idl2Ada.Value_Impl; with Ada_Be.Idl2Ada.Helper; with Ada_Be.Idl2Ada.Value_Skel; with Ada_Be.Idl2Ada.Skel; with Ada_Be.Idl2Ada.IR_Info; with Ada_Be.Mappings; use Ada_Be.Mappings; with Ada_Be.Mappings.CORBA; use Ada_Be.Mappings.CORBA; with Idlac_Errors; use Idlac_Errors; with Idlac_Utils; use Idlac_Utils; with Ada.Strings.Fixed; use Ada.Strings.Fixed; package body Ada_Be.Idl2Ada is Flag : constant Natural := Ada_Be.Debug.Is_Active ("ada_be.idl2ada"); procedure O is new Ada_Be.Debug.Output (Flag); --------------------------------------------- -- The current state of the code generator -- --------------------------------------------- type Library_Unit_Data is array (Unit_Kind) of aliased Compilation_Unit; procedure New_Library_Unit (Name : String; LU : out Library_Unit_Data); -- Create a spec and associated body for the named unit type Scope_State is limited record Stubs, Skel, Helper, IR_Info, Impl, Value_Skel, Delegate : Library_Unit_Data; end record; type Scope_State_Access is access Scope_State; procedure Free is new Ada.Unchecked_Deallocation (Scope_State, Scope_State_Access); ------------------------------------------------- -- General purpose code generation subprograms -- ------------------------------------------------- procedure Gen_Scope (Node : Node_Id; Implement : Boolean; Intf_Repo : Boolean; To_Stdout : Boolean; Current_Scope : Scope_State_Access); -- Generate all the files for scope Node. -- The implementation templates for interfaces is -- generated only if Implement is true. procedure Gen_Value_Scope (Node : Node_Id; Implement : Boolean; Intf_Repo : Boolean; To_Stdout : Boolean; In_Scope : Scope_State_Access); procedure Gen_Interface_Module_Scope (Node : Node_Id; Implement : Boolean; Intf_Repo : Boolean; To_Stdout : Boolean; In_Scope : Scope_State_Access); procedure Gen_ValueType_Stubs_Body (CU : in out Compilation_Unit; Node : Node_Id); procedure Gen_Module_Init_Prelude (CU : in out Compilation_Unit; With_Dependency : String := ""); procedure Gen_Module_Init_Postlude (CU : in out Compilation_Unit); ---------------------------------------- -- Specialised generation subprograms -- ---------------------------------------- function Access_Type_Name (Node : Node_Id) return String; -- Generates a name for an access to objet type. -- The rule used is to take the ada_type_name, replacing '.' with '_', and -- appending "_Access". Should be in expansion, but it would require too -- much work to do it now. procedure Gen_Repository_Id (Node : Node_Id; CU : in out Compilation_Unit); -- Generate the RepositoryId for an entity. procedure Gen_Is_A (Node : Node_Id; Stubs_Spec : in out Compilation_Unit; Stubs_Body : in out Compilation_Unit); -- Generate code for Repository_Id and Is_A -- object reference operation. procedure Gen_Local_Impl_Is_A (Node : Node_Id; Impl_Spec : in out Compilation_Unit; Impl_Body : in out Compilation_Unit); -- Generate code for Is_A local object implementation operation. procedure Gen_Local_Is_A_Type_Checks (Node : Node_Id; CU : in out Compilation_Unit); -- Generate a return statement with a list of Logical_Type_Id checks. procedure Gen_Client_Stub_Type_Declaration (CU : in out Compilation_Unit; Node : Node_Id); -- Generate the declaration of a client stub type -- for an interface or valuetype (in the standard -- IDL -> Ada mapping, this is the Ref type.) procedure Gen_Object_Servant_Declaration (CU : in out Compilation_Unit; Node : Node_Id; Full_View : Boolean); -- Generate a template declaration for an object -- implementation type. If Full_View is False, -- the produced declaration is a private extension -- declaration, else it is an extension declaration -- with an empty extension. procedure Gen_Node_Stubs_Body_Dyn (CU : in out Compilation_Unit; Node : Node_Id); procedure Gen_Convert_Forward_Declaration (CU : in out Compilation_Unit; Node : Node_Id); -- Generate package Convert if necessary for -- valuetypes and interfaces. ---------------------------------------------- -- End of internal subprograms declarations -- ---------------------------------------------- ---------------------- -- Conditional_Call -- ---------------------- function Conditional_Call (Func : String; Only_When : Boolean; Expr : String) return String is begin if Only_When then return Func & " (" & Expr & ")"; else return Expr; end if; end Conditional_Call; -------------- -- Generate -- -------------- procedure Generate (Use_Mapping : Ada_Be.Mappings.Mapping_Type'Class; Node : Node_Id; Implement : Boolean := False; Intf_Repo : Boolean := False; To_Stdout : Boolean := False) is S_Node : Node_Id; It : Node_Iterator; begin pragma Assert (Is_Repository (Node)); Mapping := new Mappings.CORBA.CORBA_Mapping_Type'Class' (CORBA_Mapping_Type'Class (Use_Mapping)); Init (It, Contents (Node)); while not Is_End (It) loop Get_Next_Node (It, S_Node); if Generate_Code (S_Node) then Gen_Scope (S_Node, Implement, Intf_Repo, To_Stdout, Current_Scope => null); end if; end loop; end Generate; --------------- -- Gen_Scope -- --------------- procedure Gen_Scope (Node : Node_Id; Implement : Boolean; Intf_Repo : Boolean; To_Stdout : Boolean; Current_Scope : Scope_State_Access) is In_Scope : Scope_State_Access := null; begin if Code_Generation_Suppressed (Mapping, Node) then declare It : Node_Iterator; S_Node : Node_Id; begin Init (It, Contents (Node)); while not Is_End (It) loop Get_Next_Node (It, S_Node); if Is_Gen_Scope (S_Node) and then Generate_Scope_In_Child_Package (Mapping, S_Node) then Gen_Scope (S_Node, Implement, Intf_Repo, To_Stdout, Current_Scope); end if; end loop; return; end; end if; if not Generate_Scope_In_Child_Package (Mapping, Node) then In_Scope := Current_Scope; end if; case Kind (Node) is when K_ValueType => Gen_Value_Scope (Node, Implement, Intf_Repo, To_Stdout, In_Scope); when K_Ben_Idl_File | K_Module | K_Interface => Gen_Interface_Module_Scope (Node, Implement, Intf_Repo, To_Stdout, In_Scope); when others => raise Program_Error; -- Should never happen end case; end Gen_Scope; procedure Initialize_Scope_State (Stubs_Name : String; Skel_Name : String; Helper_Name : String; IR_Info_Name : String; Impl_Name : String; Value_Skel_Name : String; Delegate_Name : String; St : out Scope_State); procedure Initialize_Scope_State (Stubs_Name : String; Skel_Name : String; Helper_Name : String; IR_Info_Name : String; Impl_Name : String; Value_Skel_Name : String; Delegate_Name : String; St : out Scope_State) is pragma Warnings (Off, St); -- Never assigned a (global) value, but all components are assigned begin New_Library_Unit (Stubs_Name, St.Stubs); New_Library_Unit (Skel_Name, St.Skel); New_Library_Unit (Helper_Name, St.Helper); New_Library_Unit (Skel_Name, St.Skel); New_Library_Unit (IR_Info_Name, St.IR_Info); New_Library_Unit (Impl_Name, St.Impl); New_Library_Unit (Value_Skel_Name, St.Value_Skel); New_Library_Unit (Delegate_Name, St.Delegate); end Initialize_Scope_State; --------------------- -- Gen_Value_Scope -- --------------------- procedure Gen_Value_Scope (Node : Node_Id; Implement : Boolean; Intf_Repo : Boolean; To_Stdout : Boolean; In_Scope : Scope_State_Access) is Stubs_Name : constant String := Client_Stubs_Unit_Name (Mapping, Node); Skel_Name : constant String := Server_Skel_Unit_Name (Mapping, Node); Impl_Name : constant String := Stubs_Name & Value_Impl.Suffix; Helper_Name : constant String := Stubs_Name & Helper.Suffix; IR_Info_Name : constant String := Stubs_Name & IR_Info.Suffix; Value_Skel_Name : constant String := Stubs_Name & Value_Skel.Suffix; S : Scope_State_Access; begin if In_Scope = null then S := new Scope_State; Initialize_Scope_State (Stubs_Name, Skel_Name, Helper_Name, IR_Info_Name, Impl_Name, Value_Skel_Name => Value_Skel_Name, Delegate_Name => "", St => S.all); else S := In_Scope; end if; if In_Scope = null then Gen_Module_Init_Prelude (S.Helper (Unit_Body), With_Dependency => "any"); Gen_Module_Init_Prelude (S.Skel (Unit_Body)); Gen_Module_Init_Prelude (S.Stubs (Unit_Body)); if Intf_Repo then IR_Info.Gen_Spec_Prelude (S.IR_Info (Unit_Spec)); IR_Info.Gen_Body_Prelude (S.IR_Info (Unit_Body)); end if; end if; -- ValueType reference type Gen_Client_Stub_Type_Declaration (S.Stubs (Unit_Spec), Node); Gen_Repository_Id (Node, S.Stubs (Unit_Spec)); if not Abst (Node) then NL (S.Stubs (Unit_Spec)); PL (S.Stubs (Unit_Spec), "Null_Value : constant Value_Ref;"); Divert (S.Stubs (Unit_Spec), Private_Declarations); PL (S.Stubs (Unit_Spec), "Null_Value : constant Value_ref"); II (S.Stubs (Unit_Spec)); Add_With (S.Stubs (Unit_Spec), "CORBA.AbstractBase"); PL (S.Stubs (Unit_Spec), " := (CORBA.AbstractBase.Nil_Ref with null record);"); DI (S.Stubs (Unit_Spec)); Divert (S.Stubs (Unit_Spec), Visible_Declarations); end if; if not Abst (Node) then -- Value_Impl type Value_Impl.Gen_Node_Spec (S.Impl (Unit_Spec), Node); Value_Impl.Gen_Node_Body (S.Impl (Unit_Body), Node); Suppress_Warning_Message (S.Impl (Unit_Body)); -- value_skel package Value_Skel.Gen_Node_Spec (S.Value_Skel (Unit_Spec), Node); Value_Skel.Gen_Node_Body (S.Value_Skel (Unit_Body), Node); end if; Helper.Gen_Node_Spec (S.Helper (Unit_Spec), Node); Helper.Gen_Node_Body (S.Helper (Unit_Body), Node); if Intf_Repo then IR_Info.Gen_Node_Spec (S.IR_Info (Unit_Spec), Node); IR_Info.Gen_Node_Body (S.IR_Info (Unit_Body), Node); end if; -- Skel package Skel.Gen_Node_Spec (S.Skel (Unit_Spec), Node, Is_Delegate => False); Skel.Gen_Node_Body (S.Skel (Unit_Body), Node, Is_Delegate => False); -- generate code for node content declare It : Node_Iterator; Export_Node : Node_Id; begin Init (It, Contents (Node)); while not Is_End (It) loop Get_Next_Node (It, Export_Node); pragma Debug (O ("valuetype content node: " & Node_Kind'Image (Kind (Export_Node)))); if Is_Gen_Scope (Export_Node) then Gen_Scope (Export_Node, Implement, Intf_Repo, To_Stdout, Current_Scope => S); else Gen_Node_Stubs_Spec (S.Stubs (Unit_Spec), Export_Node); Gen_ValueType_Stubs_Body (S.Stubs (Unit_Body), Export_Node); -- Value_Skel packages Value_Skel.Gen_Node_Spec (S.Value_Skel (Unit_Spec), Export_Node); if not Abst (Node) then Value_Skel.Gen_Node_Body (S.Value_Skel (Unit_Body), Export_Node); Value_Impl.Gen_Node_Spec (S.Impl (Unit_Spec), Export_Node); Value_Impl.Gen_Node_Body (S.Impl (Unit_Body), Export_Node); -- Skel package if Kind (Export_Node) = K_Operation and then Is_Directly_Supported (Export_Node) then Skel.Gen_Node_Body (S.Skel (Unit_Body), Export_Node, Is_Delegate => False); end if; end if; Helper.Gen_Node_Spec (S.Helper (Unit_Spec), Export_Node); Helper.Gen_Node_Body (S.Helper (Unit_Body), Export_Node); end if; -- Methods inherited from parents other that -- the first one are added to the interface or -- valuetype's exports list by the expander. end loop; end; Gen_Convert_Forward_Declaration (S.Stubs (Unit_Spec), Node); if In_Scope /= null then return; end if; Gen_Module_Init_Postlude (S.Helper (Unit_Body)); Gen_Module_Init_Postlude (S.Skel (Unit_Body)); Gen_Module_Init_Postlude (S.Stubs (Unit_Body)); Add_Elaborate_Body (S.Skel (Unit_Spec), S.Skel (Unit_Body)); if Intf_Repo then IR_Info.Gen_Body_Postlude (S.IR_Info (Unit_Body)); end if; if not Is_Empty (Supports (Node)) then Skel.Gen_Body_Common_End (S.Skel (Unit_Body), Node, Is_Delegate => False); end if; if Implement then Generate (S.Impl (Unit_Spec), False, To_Stdout); Generate (S.Impl (Unit_Body), False, To_Stdout); else Generate (S.Stubs (Unit_Spec), False, To_Stdout); Generate (S.Stubs (Unit_Body), False, To_Stdout); Generate (S.Helper (Unit_Spec), False, To_Stdout); Generate (S.Helper (Unit_Body), False, To_Stdout); if Intf_Repo then Generate (S.IR_Info (Unit_Spec), False, To_Stdout); Generate (S.IR_Info (Unit_Body), False, To_Stdout); end if; Generate (S.Value_Skel (Unit_Spec), False, To_Stdout); Generate (S.Value_Skel (Unit_Body), False, To_Stdout); Generate (S.Skel (Unit_Spec), False, To_Stdout); Generate (S.Skel (Unit_Body), False, To_Stdout); end if; if In_Scope = null then Free (S); end if; end Gen_Value_Scope; ------------------------------ -- Gen_ValueType_Stubs_Body -- ------------------------------ procedure Gen_ValueType_Stubs_Body (CU : in out Compilation_Unit; Node : Node_Id) is begin case Kind (Node) is when K_Operation => declare Op_Name : constant String := Ada_Operation_Name (Node); Is_Function : constant Boolean := Kind (Operation_Type (Node)) /= K_Void; Original_VT_Name : constant String := Ada_Full_Name (Oldest_Supporting_ValueType (Node)); Self_Expr : constant String := Self_For_Operation (Mapping, Node); begin if not Is_Implicit_Inherited (Node) then Add_With (CU, Parent_Scope_Name (Node) & Value_Skel.Suffix); Add_With (CU, "CORBA.Impl"); Gen_Operation_Profile (CU, Node, Ada_Type_Defining_Name (Mapping, Parent_Scope (Node))); PL (CU, " is"); II (CU); Add_With (CU, Original_VT_Name & Value_Skel.Suffix); PL (CU, Ada_Be.Temporaries.T_Value_Operation & " : " & Original_VT_Name & Value_Skel.Suffix & "." & Ada_Operation_Name (Node) & "_Type;"); PL (CU, Ada_Be.Temporaries.T_Impl_Object_Ptr & " : constant CORBA.Impl.Object_Ptr"); PL (CU, " := CORBA.Impl.Object_Ptr (Object_Of"); II (CU); PL (CU, "(" & Self_Expr & "));"); DI (CU); DI (CU); PL (CU, "begin"); II (CU); PL (CU, "-- Sanity check"); PL (CU, "if Is_Nil (" & Self_Expr & ") then"); II (CU); Add_With (CU, "CORBA"); PL (CU, "CORBA.Raise_Inv_Objref (Default_Sys_Member);"); DI (CU); PL (CU, "end if;"); NL (CU); PL (CU, "-- Find the operation"); PL (CU, Ada_Be.Temporaries.T_Value_Operation & " := " & Original_VT_Name & Value_Skel.Suffix & "." & Op_Name & "_Store.Get_Operation (" & Ada_Be.Temporaries.T_Impl_Object_Ptr & ".all'Tag);"); NL (CU); PL (CU, "-- Call it operation"); if Is_Function then PL (CU, "return"); II (CU); end if; PL (CU, Ada_Be.Temporaries.T_Value_Operation); Put (CU, " (" & Ada_Be.Temporaries.T_Impl_Object_Ptr); II (CU); -- The remaining formals declare It : Node_Iterator; Param_Node : Node_Id; begin Init (It, Parameters (Node)); while not Is_End (It) loop Get_Next_Node (It, Param_Node); PL (CU, ","); Put (CU, Ada_Name (Declarator (Param_Node))); end loop; end; PL (CU, ");"); DI (CU); if Is_Function then DI (CU); end if; DI (CU); NL (CU); PL (CU, "end " & Op_Name & ";"); end if; end; when K_Initializer => Gen_Initializer_Profile (CU, "Value_Ref'Class", Node); PL (CU, " is"); II (CU); PL (CU, "Result : Value_Ref;"); DI (CU); PL (CU, "begin"); II (CU); Add_With (CU, Parent_Scope_Name (Node) & Value_Impl.Suffix); PL (CU, "Set"); PL (CU, " (Result,"); PL (CU, " CORBA.Impl.Object_Ptr"); Put (CU, " (" & Parent_Scope_Name (Node) & Value_Impl.Suffix & "." & Ada_Name (Node)); -- The formal parameters declare It : Node_Iterator; Param_Node : Node_Id; Is_First : Boolean := True; begin Init (It, Param_Decls (Node)); while not Is_End (It) loop Get_Next_Node (It, Param_Node); if Is_First then NL (CU); Put (CU, " ("); Is_First := False; else PL (CU, ","); Put (CU, " "); end if; Put (CU, Ada_Name (Declarator (Param_Node))); end loop; if not Is_First then Put (CU, ")"); end if; PL (CU, "));"); end; PL (CU, "return Result;"); DI (CU); PL (CU, "end " & Ada_Name (Node) & ";"); when others => null; end case; end Gen_ValueType_Stubs_Body; -------------------------------- -- Gen_Interface_Module_Scope -- -------------------------------- procedure Gen_Interface_Module_Scope (Node : Node_Id; Implement : Boolean; Intf_Repo : Boolean; To_Stdout : Boolean; In_Scope : Scope_State_Access) is Stubs_Name : constant String := Client_Stubs_Unit_Name (Mapping, Node); Skel_Name : constant String := Server_Skel_Unit_Name (Mapping, Node); Skel_Required : constant Boolean := not ((Kind (Node) = K_Interface and then Local (Node)) or else Kind (Node) = K_Ben_Idl_File); Impl_Name : constant String := Stubs_Name & Impl.Suffix; Helper_Name : constant String := Stubs_Name & Helper.Suffix; Delegate_Name : constant String := Stubs_Name & Skel.Suffix (Is_Delegate => True); IR_Info_Name : constant String := Stubs_Name & IR_Info.Suffix; S : Scope_State_Access; begin if In_Scope = null then S := new Scope_State; Initialize_Scope_State (Stubs_Name, Skel_Name, Helper_Name, IR_Info_Name, Impl_Name, Value_Skel_Name => "", Delegate_Name => Delegate_Name, St => S.all); else S := In_Scope; end if; if In_Scope = null then -- Really starting a new gen scope Gen_Module_Init_Prelude (S.Helper (Unit_Body), With_Dependency => "any"); if Skel_Required then Gen_Module_Init_Prelude (S.Skel (Unit_Body)); Gen_Module_Init_Prelude (S.Stubs (Unit_Body)); end if; if Intf_Repo then IR_Info.Gen_Spec_Prelude (S.IR_Info (Unit_Spec)); IR_Info.Gen_Body_Prelude (S.IR_Info (Unit_Body)); end if; end if; case Kind (Node) is when K_ValueType => raise Program_Error; -- Handled by Gen_Value_Scope when K_Ben_Idl_File | K_Module => declare It : Node_Iterator; Decl_Node : Node_Id; begin Init (It, Contents (Node)); while not Is_End (It) loop Get_Next_Node (It, Decl_Node); if Is_Gen_Scope (Decl_Node) then if Generate_Client_Code then -- Ensure current unit has a non-empty spec, if the -- mapping prescribes that it has a child package. if Kind (Node) /= K_Repository and then Kind (Node) /= K_Ben_Idl_File then NL (S.Stubs (Unit_Spec)); Put (S.Stubs (Unit_Spec), "-- "); case Kind (Decl_Node) is when K_Module => Put (S.Stubs (Unit_Spec), "Module "); when K_Interface => Put (S.Stubs (Unit_Spec), "Interface "); when K_ValueType => Put (S.Stubs (Unit_Spec), "ValueType "); when others => -- Never happens raise Program_Error; end case; PL (S.Stubs (Unit_Spec), Name (Decl_Node)); end if; end if; Gen_Scope (Decl_Node, Implement, Intf_Repo, To_Stdout, Current_Scope => S); else if Generate_Client_Code then if Kind (Decl_Node) = K_Forward_Interface then Helper.Gen_Forward_Interface_Spec (S.Helper (Unit_Spec), Decl_Node); Helper.Gen_Forward_Interface_Body (S.Helper (Unit_Body), Decl_Node); end if; Gen_Node_Stubs_Spec (S.Stubs (Unit_Spec), Decl_Node); Gen_Node_Stubs_Body_Dyn (S.Stubs (Unit_Body), Decl_Node); -- Exception declarations cause generation of -- Get_Members procedure. Helper.Gen_Node_Spec (S.Helper (Unit_Spec), Decl_Node); Helper.Gen_Node_Body (S.Helper (Unit_Body), Decl_Node); if Intf_Repo then IR_Info.Gen_Node_Spec (S.IR_Info (Unit_Spec), Decl_Node); IR_Info.Gen_Node_Body (S.IR_Info (Unit_Body), Decl_Node); end if; end if; end if; end loop; if Kind (Node) = K_Module and then Generate_Client_Code then Gen_Repository_Id (Node, S.Stubs (Unit_Spec)); if Intf_Repo then IR_Info.Gen_Node_Spec (S.IR_Info (Unit_Spec), Node); IR_Info.Gen_Node_Body (S.IR_Info (Unit_Body), Node); end if; end if; end; when K_Interface => -- Object reference type if Generate_Client_Code then Gen_Client_Stub_Type_Declaration (S.Stubs (Unit_Spec), Node); Helper.Gen_Node_Spec (S.Helper (Unit_Spec), Node); Helper.Gen_Node_Body (S.Helper (Unit_Body), Node); end if; if not Abst (Node) then if not Local (Node) and then Generate_Server_Code then Skel.Gen_Node_Spec (S.Skel (Unit_Spec), Node, Is_Delegate => False); Skel.Gen_Node_Body (S.Skel (Unit_Body), Node, Is_Delegate => False); end if; -- Delegate package if Generate_Delegate then NL (S.Delegate (Unit_Body)); PL (S.Delegate (Unit_Body), "function Create (From : access Wrapped) " & "return Object_Ptr"); PL (S.Delegate (Unit_Body), "is"); PL (S.Delegate (Unit_Body), " Result : constant Object_Ptr := new Object;"); PL (S.Delegate (Unit_Body), "begin"); PL (S.Delegate (Unit_Body), " Result.Real := From.all'Unchecked_Access;"); PL (S.Delegate (Unit_Body), " return Result;"); PL (S.Delegate (Unit_Body), "end Create;"); Skel.Gen_Node_Spec (S.Delegate (Unit_Spec), Node, Is_Delegate => True); Skel.Gen_Node_Body (S.Delegate (Unit_Body), Node, Is_Delegate => True); Add_With (S.Delegate (Unit_Spec), "PortableServer"); NL (S.Delegate (Unit_Spec)); PL (S.Delegate (Unit_Spec), "type Object (<>) is"); PL (S.Delegate (Unit_Spec), " new PortableServer.Servant_Base with private;"); PL (S.Delegate (Unit_Spec), "type Object_Ptr is access all Object'Class;"); NL (S.Delegate (Unit_Spec)); PL (S.Delegate (Unit_Spec), "function Create (From : access Wrapped) " & "return Object_Ptr;"); Divert (S.Delegate (Unit_Spec), Private_Declarations); NL (S.Delegate (Unit_Spec)); PL (S.Delegate (Unit_Spec), "type Wrapped_Access is access all Wrapped;"); NL (S.Delegate (Unit_Spec)); PL (S.Delegate (Unit_Spec), "type Object is " & "new PortableServer.Servant_Base with record"); PL (S.Delegate (Unit_Spec), " Real : Wrapped_Access;"); PL (S.Delegate (Unit_Spec), "end record;"); Divert (S.Delegate (Unit_Spec), Generic_Formals); PL (S.Delegate (Unit_Spec), "type Wrapped is limited private;"); Divert (S.Delegate (Unit_Spec), Visible_Declarations); end if; if Implement then Divert (S.Impl (Unit_Spec), Private_Declarations); Gen_Object_Servant_Declaration (S.Impl (Unit_Spec), Node, Full_View => True); Divert (S.Impl (Unit_Spec), Visible_Declarations); Gen_Object_Servant_Declaration (S.Impl (Unit_Spec), Node, Full_View => False); -- The template object implementation type. Suppress_Warning_Message (S.Impl (Unit_Spec)); Suppress_Warning_Message (S.Impl (Unit_Body)); if not Local (Node) then Add_With (S.Impl (Unit_Body), Skel_Name, Use_It => False, Elab_Control => Elaborate, No_Warnings => True); end if; end if; end if; if Generate_Client_Code then Gen_Node_Stubs_Body_Dyn (S.Stubs (Unit_Body), Node); end if; declare It : Node_Iterator; Export_Node : Node_Id; begin Init (It, Contents (Node)); while not Is_End (It) loop Get_Next_Node (It, Export_Node); if Is_Gen_Scope (Export_Node) then Gen_Scope (Export_Node, Implement, Intf_Repo, To_Stdout, Current_Scope => S); else if Generate_Client_Code then Gen_Node_Stubs_Spec (S.Stubs (Unit_Spec), Export_Node); Gen_Node_Stubs_Body_Dyn (S.Stubs (Unit_Body), Export_Node); end if; -- No code produced per-node in skeleton spec if not Abst (Node) then if not Local (Node) and then Generate_Server_Code then Skel.Gen_Node_Body (S.Skel (Unit_Body), Export_Node, Is_Delegate => False); end if; if Generate_Delegate then Divert (S.Delegate (Unit_Spec), Generic_Formals); Impl.Gen_Node_Spec (S.Delegate (Unit_Spec), Export_Node, Is_Delegate => True); Divert (S.Delegate (Unit_Spec), Visible_Declarations); Skel.Gen_Node_Body (S.Delegate (Unit_Body), Export_Node, Is_Delegate => True); end if; if Implement then Impl.Gen_Node_Spec (S.Impl (Unit_Spec), Export_Node); Impl.Gen_Node_Body (S.Impl (Unit_Body), Export_Node); end if; end if; if Generate_Client_Code then Helper.Gen_Node_Spec (S.Helper (Unit_Spec), Export_Node); Helper.Gen_Node_Body (S.Helper (Unit_Body), Export_Node); end if; if Intf_Repo then IR_Info.Gen_Node_Spec (S.IR_Info (Unit_Spec), Export_Node); IR_Info.Gen_Node_Body (S.IR_Info (Unit_Body), Export_Node); end if; end if; -- Methods inherited from parents other that the first one -- are added to the interface's exports list by the -- expander. end loop; end; if Implement and then Local (Node) then Gen_Local_Impl_Is_A (Node, S.Impl (Unit_Spec), S.Impl (Unit_Body)); end if; if Generate_Client_Code then Gen_Repository_Id (Node, S.Stubs (Unit_Spec)); if not Local (Node) then Gen_Is_A (Node, S.Stubs (Unit_Spec), S.Stubs (Unit_Body)); Gen_Local_Is_A (S.Stubs (Unit_Body), Node); end if; end if; if Intf_Repo then IR_Info.Gen_Node_Spec (S.IR_Info (Unit_Spec), Node); IR_Info.Gen_Node_Body (S.IR_Info (Unit_Body), Node); end if; if Generate_Client_Code then Gen_Convert_Forward_Declaration (S.Stubs (Unit_Spec), Node); end if; if not Abst (Node) then if not Local (Node) and then Generate_Server_Code then Skel.Gen_Body_Common_End (S.Skel (Unit_Body), Node, Is_Delegate => False); end if; if Generate_Delegate then Skel.Gen_Body_Common_End (S.Delegate (Unit_Body), Node, Is_Delegate => True); end if; end if; when others => -- This never happens pragma Assert (False); null; end case; if In_Scope /= null then return; end if; Gen_Module_Init_Postlude (S.Helper (Unit_Body)); -- Local objects do not have a skeleton if Skel_Required then Gen_Module_Init_Postlude (S.Stubs (Unit_Body)); Gen_Module_Init_Postlude (S.Skel (Unit_Body)); Add_Elaborate_Body (S.Skel (Unit_Spec), S.Skel (Unit_Body)); end if; if Intf_Repo then IR_Info.Gen_Body_Postlude (S.IR_Info (Unit_Body)); end if; if Kind (Node) = K_Ben_Idl_File and then Is_Unknown (Node) then -- Do not attempt to generate a 'file' scope if there was no actual -- IDL file (case of a tree that is synthetised from a DSA service -- specification, for example). return; end if; declare Is_Abstract_Node : Boolean := False; -- No skel and impl packages are generated for abstract interfaces begin if Kind (Node) = K_Interface then Is_Abstract_Node := Abst (Node); end if; if Implement then if not Is_Abstract_Node then Generate (S.Impl (Unit_Spec), False, To_Stdout); Generate (S.Impl (Unit_Body), False, To_Stdout); end if; else Generate (S.Stubs (Unit_Spec), False, To_Stdout); Generate (S.Stubs (Unit_Body), False, To_Stdout); Generate (S.Helper (Unit_Spec), False, To_Stdout); Generate (S.Helper (Unit_Body), False, To_Stdout); if Intf_Repo then Generate (S.IR_Info (Unit_Spec), False, To_Stdout); Generate (S.IR_Info (Unit_Body), False, To_Stdout); end if; if not Is_Abstract_Node then Generate (S.Skel (Unit_Spec), False, To_Stdout); Generate (S.Skel (Unit_Body), False, To_Stdout); if Generate_Delegate then Generate (S.Delegate (Unit_Spec), False, To_Stdout); Generate (S.Delegate (Unit_Body), False, To_Stdout); end if; end if; end if; end; Free (S); end Gen_Interface_Module_Scope; ------------------------- -- Gen_Repository_Id -- ------------------------- procedure Gen_Repository_Id (Node : Node_Id; CU : in out Compilation_Unit) is begin Add_With (CU, "PolyORB.Std"); NL (CU); PL (CU, Repository_Id_Name (Node) & " : constant PolyORB.Std.String"); PL (CU, " := """ & Idl_Repository_Id (Node) & """;"); end Gen_Repository_Id; -------------- -- Gen_Is_A -- -------------- procedure Gen_Is_A (Node : Node_Id; Stubs_Spec : in out Compilation_Unit; Stubs_Body : in out Compilation_Unit) is NK : constant Node_Kind := Kind (Node); begin pragma Assert (NK = K_Interface); -- Declaration Add_With (Stubs_Spec, "CORBA", Use_It => False, Elab_Control => Elaborate_All); NL (Stubs_Spec); PL (Stubs_Spec, "function Is_A"); PL (Stubs_Spec, " (Self : " & Ada_Type_Defining_Name (Mapping, Node) & ";"); PL (Stubs_Spec, " Logical_Type_Id : PolyORB.Std.String)"); PL (Stubs_Spec, " return CORBA.Boolean;"); Divert (Stubs_Spec, Private_Declarations); NL (Stubs_Spec); PL (Stubs_Spec, "function Is_A"); PL (Stubs_Spec, " (Logical_Type_Id : PolyORB.Std.String)"); PL (Stubs_Spec, " return CORBA.Boolean;"); Divert (Stubs_Spec, Visible_Declarations); -- Implementation NL (Stubs_Body); PL (Stubs_Body, "-- The visible Is_A object reference"); PL (Stubs_Body, "-- operation (a dispatching operation"); PL (Stubs_Body, "-- of all object reference types)."); NL (Stubs_Body); PL (Stubs_Body, "function Is_A"); PL (Stubs_Body, " (Self : " & Ada_Type_Defining_Name (Mapping, Node) & ";"); PL (Stubs_Body, " Logical_Type_Id : PolyORB.Std.String)"); PL (Stubs_Body, " return CORBA.Boolean"); PL (Stubs_Body, "is"); PL (Stubs_Body, "begin"); II (Stubs_Body); PL (Stubs_Body, "return False"); II (Stubs_Body); PL (Stubs_Body, "-- Locally check class membership for this interface"); DI (Stubs_Body); NL (Stubs_Body); PL (Stubs_Body, " or else Is_A (Logical_Type_Id)"); Add_With (Stubs_Body, "CORBA.Object"); II (Stubs_Body); PL (Stubs_Body, "-- Fall back to a remote membership check (may involve"); PL (Stubs_Body, "-- an actual request invocation on Self)."); NL (Stubs_Body); PL (Stubs_Body, " or else CORBA.Object.Is_A"); PL (Stubs_Body, " (CORBA.Object.Ref (Self), Logical_Type_Id);"); DI (Stubs_Body); NL (Stubs_Body); DI (Stubs_Body); PL (Stubs_Body, "end Is_A;"); end Gen_Is_A; -------------------------------- -- Gen_Local_Is_A_Type_Checks -- -------------------------------- procedure Gen_Local_Is_A_Type_Checks (Node : Node_Id; CU : in out Compilation_Unit) is begin -- An instance of a type verifies Is_A for that type... Add_With (CU, "CORBA"); PL (CU, "return CORBA.Is_Equivalent"); PL (CU, " (Logical_Type_Id,"); II (CU); PL (CU, Ada_Full_Name (Node) & "." & Repository_Id_Name (Node) & ")"); DI (CU); PL (CU, " or else CORBA.Is_Equivalent"); PL (CU, " (Logical_Type_Id,"); -- ... and for CORBA::Object (if it is an interface) or -- CORBA::ValueBase (if it is a valuetype), either -- of which is at the root of the instance type's inheritance -- hierarchy if Kind (Node) = K_Interface then PL (CU, " ""IDL:omg.org/CORBA/Object:1.0"")"); else PL (CU, " ""IDL:omg.org/CORBA/ValueBase:1.0"")"); end if; -- ... and for all of its ancestor types. declare Parents : Node_List := All_Ancestors (Node); It : Node_Iterator; P_Node : Node_Id; begin Init (It, Parents); while not Is_End (It) loop Get_Next_Node (It, P_Node); Add_With (CU, Ada_Full_Name (P_Node)); PL (CU, " or else CORBA.Is_Equivalent"); PL (CU, " (Logical_Type_Id,"); II (CU); PL (CU, Ada_Full_Name (P_Node) & "." & Repository_Id_Name (P_Node) & ")"); DI (CU); end loop; Free (Parents); end; PL (CU, " or else False;"); NL (CU); end Gen_Local_Is_A_Type_Checks; ------------------------- -- Gen_Local_Impl_Is_A -- ------------------------- procedure Gen_Local_Impl_Is_A (Node : Node_Id; Impl_Spec : in out Compilation_Unit; Impl_Body : in out Compilation_Unit) is NK : constant Node_Kind := Kind (Node); begin pragma Assert (NK = K_Interface); -- Declaration Divert (Impl_Spec, Visible_Declarations); NL (Impl_Spec); PL (Impl_Spec, "function Is_A"); PL (Impl_Spec, " (Self : access Object;"); PL (Impl_Spec, " Logical_Type_Id : PolyORB.Std.String) " & "return Boolean;"); -- Implementation NL (Impl_Body); PL (Impl_Body, "function Is_A"); PL (Impl_Body, " (Self : access Object;"); PL (Impl_Body, " Logical_Type_Id : PolyORB.Std.String) " & "return Boolean"); PL (Impl_Body, "is"); PL (Impl_Body, "begin"); II (Impl_Body); Gen_Local_Is_A_Type_Checks (Node, Impl_Body); DI (Impl_Body); PL (Impl_Body, "end Is_A;"); end Gen_Local_Impl_Is_A; ---------------------- -- Gen_Local_Is_A -- ---------------------- procedure Gen_Local_Is_A (CU : in out Compilation_Unit; Node : Node_Id) is NK : constant Node_Kind := Kind (Node); begin pragma Assert (NK = K_Interface or else NK = K_ValueType); -- Declaration NL (CU); PL (CU, "-- The internal Is_A implementation for"); PL (CU, "-- this interface."); NL (CU); PL (CU, "function Is_A"); PL (CU, " (Logical_Type_Id : PolyORB.Std.String)"); PL (CU, " return CORBA.Boolean"); PL (CU, "is"); PL (CU, "begin"); II (CU); Gen_Local_Is_A_Type_Checks (Node, CU); DI (CU); PL (CU, "end Is_A;"); end Gen_Local_Is_A; -------------------------------------- -- Gen_Client_Stub_Type_Declaration -- -------------------------------------- procedure Gen_Client_Stub_Type_Declaration (CU : in out Compilation_Unit; Node : Node_Id) is Primary_Parent : constant Node_Id := Idl_Fe.Tree.Synthetic.Primary_Parent (Node); Unit, Typ : ASU.Unbounded_String; begin pragma Assert (False or else Kind (Node) = K_Interface or else Kind (Node) = K_ValueType); NL (CU); Put (CU, "type " & Ada_Type_Defining_Name (Mapping, Node) & " is new "); if Primary_Parent = No_Node then case (Kind (Node)) is when K_Interface => if Abst (Node) then Add_With (CU, "CORBA.Object"); Put (CU, "CORBA.Object.Ref"); -- FIXME -- Add_With (CU, "CORBA.AbstractBase"); -- Put (CU, "CORBA.AbstractBase.Ref"); -- See CORBA Spec v2.3, chapter 6 on abstract interface -- semantics, it explains why abstract interfaces should -- inherit directly from CORBA.AbstractBase.Ref and not from -- CORBA.Object.Ref However, I leave it like that because it -- requires a lot of code rewriting, all the current support -- for abstract interfaces is wrong (mainly because abstract -- interfaces can refer to valutypes). else Add_With (CU, "CORBA.Object"); Put (CU, "CORBA.Object.Ref"); end if; when K_ValueType => Add_With (CU, "CORBA.Value"); Put (CU, "CORBA.Value.Base"); when others => raise Program_Error; -- Never happens end case; else Map_Type_Name (Mapping, Primary_Parent, Unit, Typ); Add_With (CU, -Unit); Put (CU, -Typ); end if; PL (CU, " with null record;"); -- The type is not produced as a private extension declaration, because -- we may need to use it as a generic actual parameter to instantiate -- CORBA.Forward. end Gen_Client_Stub_Type_Declaration; --------------------------------------- -- Gen_Convert_Forward_Declaration -- --------------------------------------- procedure Gen_Convert_Forward_Declaration (CU : in out Compilation_Unit; Node : Node_Id) is Forward_Node : Node_Id; begin pragma Assert ((Kind (Node) = K_Interface) or else (Kind (Node) = K_ValueType)); Forward_Node := Forward (Node); if Forward_Node /= No_Node then -- This interface has a forward declaration NL (CU); PL (CU, "package Convert_Forward is"); Add_With (CU, Ada_Full_Name (Parent_Scope (Forward_Node))); Put (CU, " new " & Ada_Full_Name (Forward_Node) & ".Convert (" & Ada_Type_Defining_Name (Mapping, Node) & ");"); end if; end Gen_Convert_Forward_Declaration; ------------------------------------ -- Gen_Object_Servant_Declaration -- ------------------------------------ procedure Gen_Object_Servant_Declaration (CU : in out Compilation_Unit; Node : Node_Id; Full_View : Boolean) is Primary_Parent : constant Node_Id := Idl_Fe.Tree.Synthetic.Primary_Parent (Node); begin -- No skel package is generated for abstract interfaces pragma Assert (Kind (Node) = K_Interface); pragma Assert (not Abst (Node)); NL (CU); PL (CU, "type Object is"); if Primary_Parent = No_Node then if Local (Node) then Add_With (CU, "CORBA.Local"); Put (CU, " new CORBA.Local.Object"); else Add_With (CU, "PortableServer"); Put (CU, " new PortableServer.Servant_Base"); end if; else declare It : Node_Iterator; P_Node : Node_Id; begin Put (CU, " new " & Ada_Full_Name (Primary_Parent) & Impl.Suffix & ".Object"); Init (It, Parents (Node)); while not Is_End (It) loop Get_Next_Node (It, P_Node); if not Abst (Value (P_Node)) then Add_With (CU, Ada_Full_Name (P_Node) & Impl.Suffix, Use_It => False, Elab_Control => Elaborate_All); -- Make it so that the skeleton unit for an interface is -- elaborated after those of all its parents. end if; end loop; end; end if; if Full_View then PL (CU, " with record"); II (CU); PL (CU, "-- Insert components for implementation object state"); PL (CU, "null;"); DI (CU); PL (CU, "end record;"); else PL (CU, " with private;"); NL (CU); PL (CU, "type Object_Ptr is access all Object'Class;"); end if; end Gen_Object_Servant_Declaration; procedure Gen_When_Clause (CU : in out Compilation_Unit; Node : Node_Id; Default_Case_Seen : in out Boolean) is It : Node_Iterator; Label_Node : Node_Id; First_Label : Boolean := True; Multiple_Labels : constant Boolean := Length (Labels (Node)) > 1; begin pragma Assert (Kind (Node) = K_Case); Init (It, Labels (Node)); while not Is_End (It) loop Get_Next_Node (It, Label_Node); if First_Label then Put (CU, "when "); end if; if Multiple_Labels then pragma Assert (Label_Node /= No_Node); -- The null label is the "default" one, and must have its own case if not First_Label then PL (CU, " |"); else NL (CU); end if; Put (CU, " "); end if; if Label_Node /= No_Node then Gen_Node_Stubs_Spec (CU, Label_Node); else Put (CU, "others"); Default_Case_Seen := True; end if; First_Label := False; end loop; PL (CU, " =>"); end Gen_When_Clause; procedure Gen_When_Others_Clause (CU : in out Compilation_Unit) is begin -- All cases might already have been covered by explicit when clauses, -- in which case the compiler notes that this "when others" clause is -- redundant: disable warnings here. NL (CU); PL (CU, "pragma Warnings (Off);"); PL (CU, "when others =>"); II (CU); PL (CU, "null;"); DI (CU); PL (CU, "pragma Warnings (On);"); end Gen_When_Others_Clause; ------------------------- -- Gen_Node_Stubs_Spec -- ------------------------- procedure Gen_Node_Stubs_Spec (CU : in out Compilation_Unit; Node : Node_Id) is begin case Kind (Node) is -- Scopes when K_Repository | K_Module => null; when K_Interface => null; when K_Forward_Interface => Add_With (CU, "CORBA.Forward", Elab_Control => Elaborate_All); NL (CU); PL (CU, "package " & Ada_Name (Node) & " is new CORBA.Forward;"); ----------------- -- Value types -- ----------------- when K_ValueType => null; when K_Forward_ValueType => Add_With (CU, "CORBA.Value.Forward"); NL (CU); PL (CU, "package " & Ada_Name (Node) & " is new CORBA.Value.Forward;"); when K_Boxed_ValueType => Add_With (CU, "CORBA.Value.Box"); NL (CU); PL (CU, "type " & Access_Type_Name (Boxed_Type (Node)) & " is"); PL (CU, " access all " & Ada_Type_Name (Boxed_Type (Node)) & ";"); NL (CU); PL (CU, "package " & Ada_Name (Node) & "_Value_Box is new CORBA.Value.Box"); PL (CU, " (" & Ada_Type_Name (Boxed_Type (Node)) & ","); PL (CU, " " & Access_Type_Name (Boxed_Type (Node)) & ");"); NL (CU); PL (CU, "subtype " & Ada_Name (Node) & " is " & Ada_Name (Node) & "_Value_Box.Box_Ref;"); -- XXX Using a derived type would require overriding primtives -- of CORBA.Value.Box, which was deemed "impractical". But are we -- allowed to use a subtype instead? when K_State_Member => null; ---------------- -- Operations -- ---------------- when K_Initializer => Gen_Initializer_Profile (CU, "Value_Ref'Class", Node); PL (CU, ";"); when K_Operation => declare Implicit : constant Boolean := Is_Implicit_Inherited (Node); Original_If : constant Node_Id := Original_Parent_Scope (Node); begin -- Generate operation declaration (commented out if it is -- implicitly inherited from parent type). Set_Comment_Out_Mode (CU, Implicit); Gen_Operation_Profile (CU, Node, Ada_Type_Defining_Name (Mapping, Parent_Scope (Node))); PL (CU, ";"); Set_Comment_Out_Mode (CU, False); if not Implicit and then Original_Node (Node) = No_Node then -- A real operation (coming from the IDL source) Gen_Repository_Id (Node, CU); end if; if Original_If /= Parent_Scope (Node) then Put (CU, "-- "); if Implicit then Put (CU, "Implicitly i"); else Put (CU, "I"); end if; PL (CU, "nherited from " & Ada_Full_Name (Original_If)); end if; end; when K_Attribute => declare It : Node_Iterator; Attr_Decl_Node : Node_Id; begin Init (It, Declarators (Node)); while not Is_End (It) loop Get_Next_Node (It, Attr_Decl_Node); Gen_Repository_Id (Attr_Decl_Node, CU); end loop; end; when K_Exception => Add_With (CU, "Ada.Exceptions"); Add_With (CU, "CORBA", Elab_Control => Elaborate_All); -- Exception declaration NL (CU); PL (CU, Ada_Name (Node) & " : exception;"); -- Repository id Gen_Repository_Id (Node, CU); -- Members accessor NL (CU); PL (CU, "procedure Get_Members"); PL (CU, " (From : Ada.Exceptions.Exception_Occurrence;"); PL (CU, " To : out " & Ada_Name (Members_Type (Node)) & ");"); when K_Member => declare It : Node_Iterator; Decl_Node : Node_Id; begin Init (It, Decl (Node)); while not Is_End (It) loop Get_Next_Node (It, Decl_Node); Gen_Node_Stubs_Spec (CU, Decl_Node); Put (CU, " : "); Gen_Node_Stubs_Spec (CU, M_Type (Node)); PL (CU, ";"); end loop; end; when K_Enum => -- Type declaration NL (CU); PL (CU, "type " & Ada_Name (Node) & " is"); declare First_Enumerator : Boolean := True; It : Node_Iterator; E_Node : Node_Id; begin Init (It, Enumerators (Node)); while not Is_End (It) loop if First_Enumerator then First_Enumerator := False; Put (CU, " ("); II (CU); end if; Get_Next_Node (It, E_Node); Gen_Node_Stubs_Spec (CU, E_Node); if Is_End (It) then PL (CU, ");"); DI (CU); else PL (CU, ","); end if; end loop; end; Gen_Repository_Id (Node, CU); when K_Type_Declarator => declare Is_Ref : constant Boolean := Is_Interface_Type (T_Type (Node)) or else Kind (T_Type (Node)) = K_Object; Is_Fixed : constant Boolean := Kind (T_Type (Node)) = K_Fixed; begin declare It : Node_Iterator; Decl_Node : Node_Id; begin Init (It, Declarators (Node)); while not Is_End (It) loop Get_Next_Node (It, Decl_Node); declare Bounds_It : Node_Iterator; Bound_Node : Node_Id; First_Bound : Boolean := True; Is_Array : constant Boolean := not Is_Empty (Array_Bounds (Decl_Node)); begin NL (CU); if Is_Ref and then not Is_Array then -- A typedef where the denotes an -- interface type, and which is not an array -- declaration. Put (CU, "subtype "); else Put (CU, "type "); end if; Gen_Node_Stubs_Spec (CU, Decl_Node); PL (CU, " is"); if Is_Array then Init (Bounds_It, Array_Bounds (Decl_Node)); while not Is_End (Bounds_It) loop Get_Next_Node (Bounds_It, Bound_Node); if First_Bound then Put (CU, " array ("); First_Bound := False; else Put (CU, ", "); end if; Put (CU, "0 .. "); Gen_Constant_Value (CU, Expr => Bound_Node, Typ => No_Node); Put (CU, " - 1"); end loop; PL (CU, ") of"); II (CU); else Put (CU, " "); if not (Is_Ref or else Is_Fixed) then Put (CU, "new "); end if; end if; Gen_Node_Stubs_Spec (CU, T_Type (Node)); PL (CU, ";"); if Is_Array then DI (CU); end if; end; if Original_Node (Decl_Node) = No_Node then Gen_Repository_Id (Decl_Node, CU); end if; end loop; end; end; when K_Union => NL (CU); PL (CU, "type " & Ada_Name (Node)); Put (CU, " (Switch : "); Gen_Node_Stubs_Spec (CU, Switch_Type (Node)); NL (CU); II (CU); Put (CU, " := "); Gen_Node_Stubs_Spec (CU, Switch_Type (Node)); PL (CU, "'First)"); DI (CU); PL (CU, "is record"); II (CU); PL (CU, "case Switch is"); II (CU); declare It : Node_Iterator; Case_Node : Node_Id; Has_Default : Boolean := False; begin Init (It, Cases (Node)); while not Is_End (It) loop Get_Next_Node (It, Case_Node); Gen_When_Clause (CU, Case_Node, Has_Default); II (CU); Gen_Node_Stubs_Spec (CU, Case_Decl (Case_Node)); Put (CU, " : "); Gen_Node_Stubs_Spec (CU, Case_Type (Case_Node)); PL (CU, ";"); DI (CU); end loop; if not Has_Default then Gen_When_Others_Clause (CU); end if; end; DI (CU); PL (CU, "end case;"); DI (CU); PL (CU, "end record;"); Gen_Repository_Id (Node, CU); when K_String_Instance => NL (CU); PL (CU, "package " & Name (Node) & " is"); if Is_Wide (Node) then Add_With (CU, "CORBA.Bounded_Wide_Strings", Use_It => False, Elab_Control => Elaborate_All); Put (CU, " new CORBA.Bounded_Wide_Strings"); else Add_With (CU, "CORBA.Bounded_Strings", Use_It => False, Elab_Control => Elaborate_All); Put (CU, " new CORBA.Bounded_Strings"); end if; PL (CU, " (" & Img (Integer_Value (Bound (Node))) & ");"); when K_Sequence_Instance => NL (CU); PL (CU, "package " & Name (Node) & " is"); declare S_Node : constant Node_Id := Sequence (Node); B_Node : constant Node_Id := Bound (S_Node); Unit, Typ : ASU.Unbounded_String; begin Map_Type_Name (Mapping, Sequence_Type (S_Node), Unit, Typ); Add_With (CU, -Unit); if B_Node /= No_Node then Add_With (CU, "CORBA.Sequences.Bounded", Use_It => False, Elab_Control => Elaborate_All); PL (CU, " new CORBA.Sequences.Bounded"); PL (CU, " (" & (-Typ) & ", " & Img (Integer_Value (B_Node)) & ");"); else Add_With (CU, "CORBA.Sequences.Unbounded", Use_It => False, Elab_Control => Elaborate_All); PL (CU, " new CORBA.Sequences.Unbounded"); PL (CU, " (" & (-Typ) & ");"); end if; end; when K_Struct => NL (CU); Put (CU, "type " & Ada_Name (Node) & " is"); if Is_Exception_Members (Node) then NL (CU); PL (CU, " new CORBA.IDL_Exception_Members with"); else Put (CU, " "); end if; if Is_Empty (Members (Node)) then PL (CU, "null record;"); else PL (CU, "record"); II (CU); declare It : Node_Iterator; Member_Node : Node_Id; begin Init (It, Members (Node)); while not Is_End (It) loop Get_Next_Node (It, Member_Node); Gen_Node_Stubs_Spec (CU, Member_Node); end loop; end; DI (CU); PL (CU, "end record;"); end if; if not Is_Exception_Members (Node) then Gen_Repository_Id (Node, CU); end if; when K_Const_Dcl => NL (CU); Put (CU, Name (Node) & " : constant "); Gen_Node_Stubs_Spec (CU, Constant_Type (Node)); NL (CU); Put (CU, " := "); Gen_Constant_Value (CU, Expr => Expression (Node), Typ => Constant_Type (Node)); PL (CU, ";"); when K_ValueBase => -- FIXME: Check that this is correct. null; when K_Native => NL (CU); PL (CU, "-- Type " & Name (Declarator (Node)) & " is implementation defined;"); when K_Void => -- FIXME: Probably cannot happen. null; when K_Fixed => Put (CU, "delta 10.0 ** (-"); Gen_Node_Stubs_Spec (CU, Scale (Node)); Put (CU, ") digits "); Gen_Node_Stubs_Spec (CU, Digits_Nb (Node)); when others => Gen_Node_Default (CU, Node); end case; end Gen_Node_Stubs_Spec; ------------- -- Justify -- ------------- function Justify (S : String; Max : Integer) return String is WS : String (1 .. 50); begin if S'Length >= Max or else Max > WS'Length then return S; end if; Move (S, WS, Pad => ' '); return Head (WS, Max); end Justify; ---------------------------- -- Gen_Forward_Conversion -- ---------------------------- procedure Gen_Forward_Conversion (CU : in out Compilation_Unit; T_Node : Node_Id; Direction : String; What : String) is NT : Node_Id := T_Node; begin -- XXX the following loop is dubious. -- Most likely, it runs exactly once every time. while Kind (NT) = K_Scoped_Name loop NT := Value (NT); end loop; if Kind (NT) = K_Forward_Interface or else Kind (NT) = K_Forward_ValueType then declare Prefix : constant String := Ada_Full_Name (Forward (NT)); begin Add_With (CU, Prefix); PL (CU, Prefix & ".Convert_Forward." & Direction); Put (CU, " (" & What & ")"); end; else Put (CU, What); end if; end Gen_Forward_Conversion; ----------------------------- -- Gen_Node_Stubs_Body_Dyn -- ----------------------------- procedure Gen_Node_Stubs_Body_Dyn (CU : in out Compilation_Unit; Node : Node_Id) is begin case Kind (Node) is -- Scopes when K_Repository | K_Module => null; when K_Interface => -- Declare constant used by stubs for the name of the Result -- NamedValue if not Local (Node) and then Has_Non_Implicit_Inherited_Operations (Node) then NL (CU); Add_With (CU, "PolyORB.Types"); PL (CU, T_Result_Name & " : constant PolyORB.Types.Identifier"); PL (CU, " := PolyORB.Types.To_PolyORB_String (""Result"");"); end if; when K_Forward_Interface => null; ----------------- -- Value types -- ----------------- when K_ValueType => null; when K_Forward_ValueType => null; when K_Boxed_ValueType => null; when K_State_Member => null; when K_Initializer => null; ---------------- -- Operations -- ---------------- when K_Operation => if Is_Implicit_Inherited (Node) then return; end if; declare O_Name : constant String := Ada_Operation_Name (Node); O_Type : constant Node_Id := Operation_Type (Node); Org_O_Type : constant Node_Id := Original_Operation_Type (Node); Is_Function : constant Boolean := Kind (O_Type) /= K_Void; Decls_Div : constant Diversion := Current_Diversion (CU); Self_Expr : constant String := Self_For_Operation (Mapping, Node); procedure Gen_Object_Self_Nil_Check; -- Generate object reference nil check ------------------------------- -- Gen_Object_Self_Nil_Check -- ------------------------------- procedure Gen_Object_Self_Nil_Check is begin NL (CU); PL (CU, "if Is_Nil (" & Self_Expr & ") then"); II (CU); PL (CU, "CORBA.Raise_Inv_Objref (Default_Sys_Member);"); DI (CU); PL (CU, "end if;"); NL (CU); end Gen_Object_Self_Nil_Check; begin Add_With (CU, "CORBA", Use_It => True, Elab_Control => Elaborate_All); Divert (CU, Operation_Body); Gen_Operation_Profile (CU, Node, Ada_Type_Defining_Name (Mapping, Parent_Scope (Node))); NL (CU); PL (CU, "is"); II (CU); if Local (Parent_Scope (Node)) then -- Case of a local interface declare Impl_U_Name : constant String := Client_Stubs_Unit_Name (Mapping, Parent_Scope (Node)) & Impl.Suffix; begin Add_With (CU, Impl_U_Name); DI (CU); PL (CU, "begin"); II (CU); Gen_Object_Self_Nil_Check; if Is_Function then Put (CU, "return "); end if; PL (CU, Impl_U_Name & '.' & O_Name); -- XXX replace .Object_Ptr by ??? Put (CU, " (" & Impl_U_Name & ".Object_Ptr (Entity_Of (" & Self_For_Operation (Mapping, Node) & "))"); declare It : Node_Iterator; P_Node : Node_Id; begin Init (It, Parameters (Node)); while not Is_End (It) loop Get_Next_Node (It, P_Node); if not Is_Returns (P_Node) then PL (CU, ","); II (CU); Put (CU, Ada_Name (Declarator (P_Node))); DI (CU); end if; end loop; end; if not Is_Function and then Kind (Org_O_Type) /= K_Void then PL (CU, ","); II (CU); Put (CU, "Returns"); DI (CU); end if; PL (CU, ");"); end; else -- Case of an unconstrained interface declare Response_Expected : constant Boolean := not Is_Oneway (Node); Raise_Something : constant Boolean := not Is_Empty (Raises (Node)); begin Add_With (CU, "PolyORB.CORBA_P.Exceptions"); Add_With (CU, "PolyORB.CORBA_P.Interceptors_Hooks"); Add_With (CU, "PolyORB.Any.NVList"); Add_With (CU, "PolyORB.Requests"); -- Prepare return Any if Kind (Org_O_Type) /= K_Void then Put (CU, T_Result & " : " & Ada_Type_Name (Org_O_Type)); if Is_Function then PL (CU, ";"); -- Kill warning about unreferenced variable (it is -- accessed only through the wrapper below). PL (CU, "pragma Warnings (Off, " & T_Result & ");"); else PL (CU, " renames Returns;"); -- Kill warning on out arg that is never explicitly -- assigned. PL (CU, "pragma Warnings (Off, Returns);"); end if; PL (CU, T_Arg_CC & T_Result & " : aliased PolyORB.Any.Content'Class" & " :="); II (CU); Helper.Gen_Wrap_Call (CU, Org_O_Type, T_Result); DI (CU); PL (CU, ";"); end if; -- Prepare argument Anys declare It : Node_Iterator; P_Node : Node_Id; begin Init (It, Parameters (Node)); while not Is_End (It) loop Get_Next_Node (It, P_Node); if not Is_Returns (P_Node) then declare Arg_Name : constant String := Ada_Name (Declarator (P_Node)); P_Typ : constant Node_Id := Param_Type (P_Node); Helper_Name : constant String := Helper_Unit (P_Typ); begin Add_With (CU, Helper_Name); Divert (CU, Decls_Div); NL (CU); PL (CU, O_Name & T_Arg_Name & Arg_Name & " : constant PolyORB.Types.Identifier"); PL (CU, " := PolyORB.Types.To_PolyORB_String (""" & Arg_Name & """);"); Divert (CU, Operation_Body); PL (CU, T_Arg_CC & Arg_Name & " : aliased PolyORB.Any.Content'Class" & " :="); II (CU); Helper.Gen_Wrap_Call (CU, P_Typ, Arg_Name); DI (CU); PL (CU, ";"); Add_With (CU, TC_Unit (P_Typ)); PL (CU, T_Arg_Any & Arg_Name & " : constant CORBA.Any :=" & " CORBA.Internals.Get_Wrapper_Any (" & Ada_Full_TC_Name (P_Typ) & ", " & T_Arg_CC & Arg_Name & "'Unchecked_Access);"); -- Kill warning on out arg that is never -- explicitly assigned. if Mode (P_Node) /= Mode_In then PL (CU, "pragma Warnings (Off, " & Arg_Name & ");"); end if; end; end if; end loop; end; NL (CU); Add_With (CU, "CORBA.Object"); PL (CU, T_Request & " : PolyORB.Requests.Request_Access;"); PL (CU, T_Arg_List & " : PolyORB.Any.NVList.Ref;"); PL (CU, T_Result & "_NV : PolyORB.Any.NamedValue;"); DI (CU); PL (CU, "begin"); II (CU); Gen_Object_Self_Nil_Check; PL (CU, "-- Create argument list"); NL (CU); PL (CU, "PolyORB.Any.NVList.Create"); PL (CU, " (" & T_Arg_List & ");"); declare It : Node_Iterator; P_Node : Node_Id; begin Init (It, Parameters (Node)); while not Is_End (It) loop Get_Next_Node (It, P_Node); if not Is_Returns (P_Node) then declare Arg_Name : constant String := Ada_Name (Declarator (P_Node)); begin PL (CU, "PolyORB.Any.NVList.Add_Item"); PL (CU, " (" & T_Arg_List & ","); II (CU); PL (CU, O_Name & T_Arg_Name & Arg_Name & ","); Put (CU, Conditional_Call (Func => "PolyORB.Any.Copy_Any", Only_When => not Response_Expected, Expr => "PolyORB.Any.Any (" & T_Arg_Any & Arg_Name & ")")); PL (CU, ","); end; case Mode (P_Node) is when Mode_In => PL (CU, "PolyORB.Any.ARG_IN);"); when Mode_Inout => PL (CU, "PolyORB.Any.ARG_INOUT);"); when Mode_Out => PL (CU, "PolyORB.Any.ARG_OUT);"); end case; DI (CU); end if; end loop; end; declare It : Node_Iterator; R_Node : Node_Id; E_Node : Node_Id; First : Boolean := True; begin Init (It, Raises (Node)); while not Is_End (It) loop Get_Next_Node (It, R_Node); E_Node := Value (R_Node); if First then Divert (CU, Decls_Div); NL (CU); Add_With (CU, "CORBA.ExceptionList"); PL (CU, O_Name & T_Excp_List & " : CORBA.ExceptionList.Ref;"); Divert (CU, Deferred_Initialization); NL (CU); PL (CU, "-- Exceptions list for " & O_Name); NL (CU); PL (CU, "CORBA.ExceptionList.Create_List (" & O_Name & T_Excp_List & ");"); First := False; end if; Helper.Add_Helper_Dependency (CU, TC_Unit (E_Node)); PL (CU, "CORBA.ExceptionList.Add"); PL (CU, " (" & O_Name & T_Excp_List & ","); II (CU); PL (CU, Ada_Full_TC_Name (E_Node) & ");"); DI (CU); end loop; end; Divert (CU, Operation_Body); NL (CU); PL (CU, "-- Set result type (maybe void)"); NL (CU); PL (CU, T_Result & "_NV :="); PL (CU, " (Name => " & T_Result_Name & ","); PL (CU, " Argument =>"); Add_With (CU, TC_Unit (Org_O_Type)); II (CU); PL (CU, "CORBA.Internals.Get_Empty_Any (" & Ada_Full_TC_Name (Org_O_Type) & "),"); PL (CU, "Arg_Modes => 0);"); DI (CU); if Kind (Org_O_Type) /= K_Void then PL (CU, "PolyORB.Any.Set_Value (" & "PolyORB.Any.Get_Container (" & T_Result & "_NV.Argument).all, " & T_Arg_CC & T_Result & "'Unrestricted_Access);"); end if; NL (CU); PL (CU, "PolyORB.Requests.Create_Request"); PL (CU, " (Target => CORBA.Object.Internals." & "To_PolyORB_Ref"); II (CU); PL (CU, " (CORBA.Object.Ref (" & Self_For_Operation (Mapping, Node) & ")),"); PL (CU, "Operation => """ & Idl_Operation_Id (Node) & ""","); PL (CU, "Arg_List => " & T_Arg_List & ","); PL (CU, "Result => " & T_Result & "_NV,"); if Raise_Something then PL (CU, "Exc_List => CORBA.ExceptionList.Internals." & "To_PolyORB_Ref (" & O_Name & T_Excp_List & "),"); end if; if Response_Expected then PL (CU, "Req => " & T_Request & ");"); else PL (CU, "Req => " & T_Request & ","); PL (CU, "Req_Flags => " & "PolyORB.Requests.Sync_With_Transport);"); end if; DI (CU); NL (CU); PL (CU, "PolyORB.CORBA_P.Interceptors_Hooks.Client_Invoke"); PL (CU, " (" & T_Request & ", PolyORB.Requests.Flags (0));"); PL (CU, "PolyORB.CORBA_P.Exceptions." & "Request_Raise_Occurrence (" & T_Request & ".all);"); PL (CU, "PolyORB.Requests.Destroy_Request (" & T_Request & ");"); if Response_Expected then NL (CU); PL (CU, "-- Request has been synchronously invoked"); NL (CU); if Kind (Org_O_Type) /= K_Void and then Is_Function then PL (CU, "return " & T_Result & ";"); end if; end if; end; end if; DI (CU); PL (CU, "end " & O_Name & ";"); Divert (CU, Decls_Div); Undivert (CU, Operation_Body); end; when K_Exception => Add_With (CU, "PolyORB.Exceptions"); NL (CU); PL (CU, "procedure Get_Members"); PL (CU, " (From : Ada.Exceptions.Exception_Occurrence;"); PL (CU, " To : out " & Ada_Name (Members_Type (Node)) & ") is"); PL (CU, "begin"); II (CU); PL (CU, "PolyORB.Exceptions.User_Get_Members (From, To);"); DI (CU); PL (CU, "end Get_Members;"); when others => null; end case; end Gen_Node_Stubs_Body_Dyn; ----------------------------- -- Gen_Initializer_Profile -- ----------------------------- procedure Gen_Initializer_Profile (CU : in out Compilation_Unit; Return_Type : String; Node : Node_Id) is begin pragma Assert (Kind (Node) = K_Initializer); NL (CU); Put (CU, "function "); PL (CU, Ada_Name (Node)); -- Parameters declare It : Node_Iterator; P_Node : Node_Id; begin Init (It, Param_Decls (Node)); if not Is_End (It) then -- First parameter Put (CU, " ("); Get_Next_Node (It, P_Node); Gen_Operation_Profile (CU, P_Node, ""); II (CU); -- Next parameters while not Is_End (It) loop Get_Next_Node (It, P_Node); PL (CU, ";"); Gen_Operation_Profile (CU, P_Node, ""); end loop; Put (CU, ")"); DI (CU); end if; NL (CU); II (CU); Put (CU, "return " & Return_Type); DI (CU); end; end Gen_Initializer_Profile; --------------------------- -- Gen_Operation_Profile -- --------------------------- procedure Gen_Operation_Profile (CU : in out Compilation_Unit; Node : Node_Id; Object_Type : String; With_Name : Boolean := True; Is_Delegate : Boolean := False) is First : Boolean := True; begin case Kind (Node) is when K_Operation => -- Subprogram name NL (CU); if Is_Delegate then Put (CU, "with "); end if; if Kind (Operation_Type (Node)) = K_Void then Put (CU, "procedure "); else Put (CU, "function "); end if; -- In Value_Skel, we need the profile of the subprogram without -- the name, to create an access to subprogram type if With_Name then Put (CU, Ada_Operation_Name (Node)); end if; -- Formals if not Is_Explicit_Self (Node) then Put (CU, ASCII.LF & " (Self : " & Object_Type); II (CU); First := False; end if; declare It : Node_Iterator; P_Node : Node_Id; begin Init (It, Parameters (Node)); while not Is_End (It) loop Get_Next_Node (It, P_Node); if First then Put (CU, ASCII.LF & " ("); II (CU); First := False; else PL (CU, ";"); end if; Gen_Operation_Profile (CU, P_Node, Object_Type); end loop; if not First then -- Non-empty profile Put (CU, ")"); DI (CU); end if; end; -- Return type declare O_Type : constant Node_Id := Operation_Type (Node); Unit, Typ : ASU.Unbounded_String; begin if Kind (O_Type) /= K_Void then NL (CU); Map_Type_Name (Mapping, O_Type, Unit, Typ); Add_With (CU, -Unit); Put (CU, " return " & (-Typ)); if Kind (O_Type) = K_Scoped_Name and then S_Type (O_Type) = Parent_Scope (Node) then -- An operation of an interface is a primitive operation -- of the tagged type that maps this interface. If it has -- other formal parameters that are object references of -- the same interface type, then these formals must not -- be controlling (Ada RTF issue #2459). Put (CU, "'Class"); end if; end if; end; if Is_Delegate then Put (CU, " is <>"); end if; when K_Param => Gen_Operation_Profile (CU, Declarator (Node), Object_Type); case Mode (Node) is when Mode_In => Put (CU, " : "); when Mode_Out => Put (CU, " : out "); when Mode_Inout => Put (CU, " : in out "); end case; declare T_Node : constant Node_Id := Param_Type (Node); Unit, Typ : ASU.Unbounded_String; begin Map_Type_Name (Mapping, T_Node, Unit, Typ); Add_With (CU, -Unit); Put (CU, -Typ); if Kind (T_Node) = K_Scoped_Name and then S_Type (T_Node) = Parent_Scope (Parent_Scope (Declarator (Node))) then -- An operation of an interface is primitive operation of -- the tagged type that maps this interface. If it has other -- formal parameters that are object references of the same -- interface type, then these formals must not be -- controlling. (Ada RTF issue #2459) (see above). -- FIXME: code duplication. Put (CU, "'Class"); end if; end; when others => Gen_Node_Default (CU, Node); end case; end Gen_Operation_Profile; procedure Gen_Node_Default (CU : in out Compilation_Unit; Node : Node_Id) is Unit, Typ : Ada.Strings.Unbounded.Unbounded_String; NK : constant Node_Kind := Kind (Node); begin case NK is when K_Scoped_Name => declare Denoted_Entity : constant Node_Id := Value (Node); begin case Kind (Denoted_Entity) is when K_Enumerator => Put (CU, Ada_Full_Name (Node)); when others => Map_Type_Name (Mapping, Node, Unit, Typ); Add_With (CU, -Unit); Put (CU, -Typ); end case; end; when K_Declarator => Put (CU, Ada_Name (Node)); -- A simple or complex (array) declarator. -- Base types when K_Float | K_Double | K_Long_Double | K_Short | K_Long | K_Long_Long | K_Unsigned_Short | K_Unsigned_Long | K_Unsigned_Long_Long | K_Char | K_Wide_Char | K_Boolean | K_String | K_Wide_String | K_Octet | K_Object | K_Any => Map_Type_Name (Mapping, Node, Unit, Typ); Add_With (CU, -Unit); Put (CU, -Typ); when K_Enumerator => Put (CU, Ada_Name (Node)); when K_Attribute => null; -- Attributes are expanded into operations. when K_Or_Expr => -- Binary operators. null; when K_Xor_Expr => null; -- when K_And => -- when K_Sub => -- when K_Add => -- when K_Shr => -- when K_Shl => -- when K_Mul => -- when K_Div => -- when K_Mod => -- when K_Id => -- Unary operators. -- when K_Neg => -- when K_Not => when K_Lit_String => Put (CU, String_Value (Node)); when K_Lit_Character => Put (CU, Img (Character_Value (Node))); when K_Lit_Integer => Put (CU, Img (Integer_Value (Node))); when K_Lit_Boolean => Put (CU, Img (Boolean_Value (Node))); when K_Lit_Enum => Put (CU, Ada_Full_Name (Enum_Value (Node))); when K_Primary_Expr => Gen_Node_Default (CU, Operand (Node)); when others => Error ("ada_be-idl2ada.Gen_Node_Default: " & "Don't know what to do with a " & Node_Kind'Image (NK) & " node.", Fatal, Get_Location (Node)); end case; end Gen_Node_Default; -------------------- -- Ada_Type_Name -- -------------------- function Ada_Type_Name (Node : Node_Id) return String is Unit, Typ : ASU.Unbounded_String; begin Map_Type_Name (Mapping, Node, Unit, Typ); return -Typ; end Ada_Type_Name; ---------------------- -- Ada_Full_TC_Name -- ---------------------- function Ada_Full_TC_Name (Node : Node_Id) return String is begin return TC_Unit (Node) & "." & Ada_TC_Name (Node); end Ada_Full_TC_Name; ----------------- -- Helper_Unit -- ----------------- function Helper_Unit (Node : Node_Id) return String is NK : constant Node_Kind := Kind (Node); begin case NK is when K_Declarator => declare P_T_Type : constant Node_Id := T_Type (Parent (Node)); Is_Array : constant Boolean := not Is_Empty (Array_Bounds (Node)); Is_Ref : constant Boolean := not Is_Array and then (Is_Interface_Type (P_T_Type) or else Kind (P_T_Type) = K_Object); begin if Is_Ref then -- This node is mapped to a subtype of the original -- reference type: use that type's From_Any and To_Any. return Helper_Unit (P_T_Type); else return Helper_Unit (Parent_Scope (Node)); end if; end; when K_Forward_Interface | K_Forward_ValueType => return Helper_Unit (Parent_Scope (Node)); -- Different from Ada_Helper_Name (Node). when K_Scoped_Name => return Helper_Unit (Value (Node)); -- Potentially different from Ada_Helper_Name (Node). when others => return Ada_Helper_Unit_Name (Mapping, Node); end case; end Helper_Unit; ------------- -- TC_Unit -- ------------- function TC_Unit (Node : Node_Id) return String is begin return Ada_Helper_Unit_Name (Mapping, Node); end TC_Unit; ---------------------- -- Access_Type_Name -- ---------------------- function Access_Type_Name (Node : Node_Id) return String is Name : String := Ada_Type_Name (Node); begin for I in Name'Range loop if Name (I) = '.' then Name (I) := '_'; end if; end loop; return Name & "_Access"; end Access_Type_Name; --------------------- -- Add_With_Entity -- --------------------- procedure Add_With_Entity (CU : in out Compilation_Unit; Node : Node_Id) is begin Add_With (CU, Library_Unit_Name (Mapping, Node)); end Add_With_Entity; --------------------------------------------------------- -- Ada_Operation_Name and Idl_Operation_Id differ -- -- for operations that are created by the expander and -- -- represent attributes: -- -- given an attribute Foo of an interface, the "get" -- -- and "set" operations will be generated with -- -- Ada_Operation_Names "Get_Foo" and "Set_Foo", and -- -- Idl_Operation_Ids "_get_Foo" and "_set_Foo". -- --------------------------------------------------------- function Ada_Operation_Name (Node : Node_Id) return String is begin pragma Assert (Kind (Node) = K_Operation); return Ada_Name (Node); end Ada_Operation_Name; function Idl_Operation_Id (Node : Node_Id) return String is begin pragma Assert (Kind (Node) = K_Operation); return Name (Node); end Idl_Operation_Id; ------------------------ -- Repository_Id_Name -- ------------------------ function Repository_Id_Name (Node : Node_Id) return String is begin return Ada_Name (Repository_Id_Identifier (Node)); end Repository_Id_Name; ------------------------ -- Gen_Constant_Value -- ------------------------ procedure Gen_Constant_Value (CU : in out Compilation_Unit; Expr : Node_Id; Typ : Node_Id) is Value : constant Constant_Value_Ptr := Expr_Value (Expr); To_CORBA_Prefix : aliased String := "To_CORBA"; To_Bounded_Prefix : aliased String := "To_Bounded"; String_Cvt_Prefix : constant array (Boolean) of access String := (False => To_CORBA_Prefix'Access, True => To_Bounded_Prefix'Access); begin case Value.Kind is when C_Short | C_Long | C_LongLong | C_UShort | C_ULong | C_ULongLong | C_Octet | C_General_Integer => declare Int_Val : constant Idl_Integer := Integer_Value (Expr); begin -- If the value is negative, we use an expanded name for the -- "-" operator, because it might not be directly visible. For -- example, CORBA."-" (1234). If Typ is not provided, assume -- that the "-" operator is directly visible (case of the -- index type of an IDL array, which is Standard.Integer). if Present (Typ) and then Int_Val < 0 then Put (CU, Library_Unit_Name (Mapping, Typ) & ".""-"" ("); Put (CU, Img (-Int_Val)); Put (CU, ")"); else Put (CU, Img (Int_Val)); end if; end; when C_Char => Put (CU, "'" & Value.Char_Value & "'"); when C_WChar => Put (CU, Ada.Characters.Conversions.To_String ("'" & Value.WChar_Value & "'")); when C_Boolean => Put (CU, Img (Boolean_Value (Expr))); when C_Float | C_Double | C_LongDouble | C_General_Float => Put (CU, Img (Float_Value (Expr))); when C_Fixed | C_General_Fixed => declare Value_Digits : constant String := Img (Value.Fixed_Value); Zeroes : constant String (1 .. Integer (Value.Scale) - Value_Digits'Length + 1) := (others => '0'); All_Digits : constant String := Zeroes & Value_Digits; begin if Value.Scale = 0 then Put (CU, Value_Digits); else Put (CU, All_Digits (All_Digits'First .. All_Digits'Last - Integer (Value.Scale)) & "." & All_Digits (All_Digits'Last - Integer (Value.Scale) + 1 .. All_Digits'Last)); end if; end; when C_String => declare Bounded : constant Boolean := Present (Bound (Root_Type (Typ))); begin Put (CU, Library_Unit_Name (Mapping, Typ) & "." & String_Cvt_Prefix (Bounded).all & "_String (""" & String_Value (Expr) & """)"); end; when C_WString => declare Bounded : constant Boolean := Present (Bound (Root_Type (Typ))); begin Put (CU, Library_Unit_Name (Mapping, Typ) & "." & String_Cvt_Prefix (Bounded).all & "_Wide_String (""" & Ada.Characters.Conversions.To_String (WString_Value (Expr)) & """)"); end; when C_Enum => Put (CU, Ada_Full_Name (Enum_Value (Expr))); when C_No_Kind => Error ("Constant without a kind.", Fatal, Get_Location (Expr)); end case; end Gen_Constant_Value; ----------------- -- Ada_TC_Name -- ----------------- function Ada_TC_Name (Node : Node_Id) return String is NK : constant Node_Kind := Kind (Node); Prefix : constant String := "TC_"; begin case NK is when K_Forward_Interface | K_Forward_ValueType => return Ada_TC_Name (Forward (Node)); when K_Interface | K_ValueType | K_Sequence_Instance | K_String_Instance | K_Enum | K_Union | K_Struct | K_Exception | K_Declarator => return Prefix & Ada_Name (Node); when K_Scoped_Name => return Ada_TC_Name (Value (Node)); when K_Short => return Prefix & "Short"; when K_Long => return Prefix & "Long"; when K_Long_Long => return Prefix & "Long_Long"; when K_Unsigned_Short => return Prefix & "Unsigned_Short"; when K_Unsigned_Long => return Prefix & "Unsigned_Long"; when K_Unsigned_Long_Long => return Prefix & "Unsigned_Long_Long"; when K_Char => return Prefix & "Char"; when K_Wide_Char => return Prefix & "Wchar"; when K_Boolean => return Prefix & "Boolean"; when K_Float => return Prefix & "Float"; when K_Double => return Prefix & "Double"; when K_Long_Double => return Prefix & "Long_Double"; when K_String => return Prefix & "String"; when K_Wide_String => return Prefix & "Wide_String"; when K_Octet => return Prefix & "Octet"; when K_Object => return Prefix & "Object"; when K_Any => return Prefix & "Any"; when K_Void => return Prefix & "Void"; when others => -- Improper use: node N is not mapped to an Ada type Error ("No TypeCode for " & Node_Kind'Image (NK) & " nodes.", Fatal, Get_Location (Node)); -- Keep the compiler happy raise Program_Error; end case; end Ada_TC_Name; ----------------------------- -- Gen_Module_Init_Prelude -- ----------------------------- procedure Gen_Module_Init_Prelude (CU : in out Compilation_Unit; With_Dependency : String := "") is begin Set_Template_Mode (CU, True); Divert (CU, Deferred_Initialization); NL (CU); PL (CU, "procedure Deferred_Initialization is"); PL (CU, "begin"); II (CU); Divert (CU, Initialization_Dependencies); II (CU); II (CU); II (CU); if With_Dependency'Length /= 0 then PL (CU, "+""" & With_Dependency & """"); else PL (CU, "PolyORB.Initialization.String_Lists.Empty"); end if; Divert (CU, Visible_Declarations); Set_Template_Mode (CU, False); end Gen_Module_Init_Prelude; ------------------------------ -- Gen_Module_Init_Postlude -- ------------------------------ procedure Gen_Module_Init_Postlude (CU : in out Compilation_Unit) is begin Set_Template_Mode (CU, True); Divert (CU, Deferred_Initialization); DI (CU); NL (CU); PL (CU, "end Deferred_Initialization;"); Set_Template_Mode (CU, False); if Current_Diversion_Empty (CU) then return; end if; Divert (CU, Visible_Declarations); Undivert (CU, Deferred_Initialization); Divert (CU, Visible_Declarations); Add_With (CU, "PolyORB.Initialization", Elab_Control => Elaborate_All); Add_With (CU, "PolyORB.Utils.Strings"); Divert (CU, Elaboration); PL (CU, "declare"); II (CU); PL (CU, "use PolyORB.Initialization;"); PL (CU, "use PolyORB.Initialization.String_Lists;"); PL (CU, "use PolyORB.Utils.Strings;"); DI (CU); PL (CU, "begin"); II (CU); PL (CU, "Register_Module"); PL (CU, " (Module_Info'"); II (CU); PL (CU, "(Name => +""" & Name (CU) & ""","); PL (CU, " Conflicts => PolyORB.Initialization.String_Lists.Empty,"); PL (CU, " Depends =>"); Undivert (CU, Initialization_Dependencies); PL (CU, " ,"); PL (CU, " Provides => PolyORB.Initialization.String_Lists.Empty,"); PL (CU, " Implicit => False,"); PL (CU, " Init => Deferred_Initialization'Access,"); PL (CU, " Shutdown => null));"); DI (CU); DI (CU); PL (CU, "end;"); end Gen_Module_Init_Postlude; ---------------------- -- New_Library_Unit -- ---------------------- procedure New_Library_Unit (Name : String; LU : out Library_Unit_Data) is begin New_Compilation_Unit (LU (Unit_Spec), Unit_Spec, Name); New_Compilation_Unit (LU (Unit_Body), Unit_Body, Name, LU (Unit_Spec)'Unchecked_Access); end New_Library_Unit; end Ada_Be.Idl2Ada; polyorb-2.8~20110207.orig/compilers/idlac/idl_fe-types.adb0000644000175000017500000014355011750740337022525 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- I D L _ F E . T Y P E S -- -- -- -- B o d y -- -- -- -- Copyright (C) 2001-2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with Ada.Text_IO; with System; with GNAT.Case_Util; with Idl_Fe.Lexer; with Idl_Fe.Tree; use Idl_Fe.Tree; with Idl_Fe.Tree.Synthetic; use Idl_Fe.Tree.Synthetic; with Idl_Fe.Debug; pragma Elaborate_All (Idl_Fe.Debug); with Idlac_Utils; use Idlac_Utils; package body Idl_Fe.Types is ----------- -- Debug -- ----------- Flag : constant Natural := Idl_Fe.Debug.Is_Active ("idl_fe.types"); procedure O is new Idl_Fe.Debug.Output (Flag); Flag2 : constant Natural := Idl_Fe.Debug.Is_Active ("idl_fe.types_method_trace"); procedure O2 is new Idl_Fe.Debug.Output (Flag2); -------------------------- -- Internal subprograms -- -------------------------- procedure Unchecked_Deallocation is new Ada.Unchecked_Deallocation (Node_List_Cell, Node_List); procedure Add_Definition_To_Storage (Scope : Node_Id; Definition : Identifier_Definition_Acc; Is_Inheritable : Boolean); -- Add the definition to Scope storage table. procedure Add_Identifier_Definition (Scope : Node_Id; Definition : Identifier_Definition_Acc; Is_Inheritable : Boolean); -- Add an identifier definition to a scope. function Find_Inherited_Identifier_Definition (Name : String; Loc : Idlac_Errors.Location) return Identifier_Definition_Acc; -- Find the identifier definition in inherited interfaces. -- If this identifier is not defined, returns a null pointer. -------------------------------------- -- Root of the tree parsed from IDL -- -------------------------------------- ------------------ -- Set_Location -- ------------------ procedure Set_Location (N : Node_Id; Loc : Idlac_Errors.Location) is Loc2 : Idlac_Errors.Location; use Idlac_Errors; begin Loc2.Col := Loc.Col; Loc2.Line := Loc.Line; pragma Assert (Loc.Filename /= null); Loc2.Filename := new String'(Loc.Filename.all); if Loc.Dirname = null then Loc2.Dirname := null; else Loc2.Dirname := new String'(Loc.Dirname.all); end if; Set_Loc (N, Loc2); end Set_Location; ------------------ -- Get_Location -- ------------------ function Get_Location (N : Node_Id) return Idlac_Errors.Location is begin return Loc (N); end Get_Location; ----------- -- Image -- ----------- function Image (V : Version_Type) return String is Major_Image : constant String := Interfaces.Unsigned_16'Image (V.Major); Minor_Image : constant String := Interfaces.Unsigned_16'Image (V.Minor); begin return Major_Image (Major_Image'First + 1 .. Major_Image'Last) & "." & Minor_Image (Major_Image'First + 1 .. Minor_Image'Last); end Image; -------- -- No -- -------- function No (N : Node_Id) return Boolean is begin return N = No_Node; end No; ------------- -- Present -- ------------- function Present (N : Node_Id) return Boolean is begin return N /= No_Node; end Present; -------------------------------- -- Management of const values -- -------------------------------- --------------- -- Duplicate -- --------------- function Duplicate (C : Constant_Value_Ptr) return Constant_Value_Ptr is Result : constant Constant_Value_Ptr := new Constant_Value (Kind => C.Kind); begin case C.Kind is when C_Octet | C_Short | C_Long | C_LongLong | C_UShort | C_ULong | C_ULongLong | C_General_Integer => Result.Integer_Value := C.Integer_Value; when C_Char => Result.Char_Value := C.Char_Value; when C_WChar => Result.WChar_Value := C.WChar_Value; when C_Boolean => Result.Boolean_Value := C.Boolean_Value; when C_Float | C_Double | C_LongDouble | C_General_Float => Result.Float_Value := C.Float_Value; when C_String => Result.String_Value := C.String_Value; when C_WString => Result.WString_Value := C.WString_Value; when C_Fixed | C_General_Fixed => Result.Fixed_Value := C.Fixed_Value; Result.Digits_Nb := C.Digits_Nb; Result.Scale := C.Scale; when C_Enum => Result.Enum_Value := C.Enum_Value; Result.Enum_Name := C.Enum_Name; when C_No_Kind => null; end case; return Result; end Duplicate; ---------- -- Free -- ---------- procedure Free (C : in out Constant_Value_Ptr) is procedure Real_Free is new Ada.Unchecked_Deallocation (Constant_Value, Constant_Value_Ptr); begin case C.Kind is when C_String => Free_Idl_String (C.String_Value); when C_WString => Free_Idl_Wide_String (C.WString_Value); when others => null; end case; Real_Free (C); end Free; -------------------- -- Lists of nodes -- -------------------- ---------- -- Head -- ---------- function Head (NL : Node_List) return Node_Id is begin pragma Assert (NL /= Nil_List); return NL.Car; end Head; -------------- -- Is_Empty -- -------------- function Is_Empty (NL : Node_List) return Boolean is begin return NL = Nil_List; end Is_Empty; ------------ -- Length -- ------------ function Length (NL : Node_List) return Natural is Current : Node_List := NL; Count : Natural := 0; begin while not Is_Empty (Current) loop Count := Count + 1; Current := Current.Cdr; end loop; return Count; end Length; ---------- -- Init -- ---------- procedure Init (It : out Node_Iterator; List : Node_List) is begin It := Node_Iterator (List); end Init; ------------------- -- Get_Next_Node -- ------------------- procedure Get_Next_Node (It : in out Node_Iterator; Node : out Node_Id) is begin pragma Debug (O ("Getting head of list at " & Img (It.all'Address))); Node := Get_Node (It); Next (It); end Get_Next_Node; -------------- -- Get_Node -- -------------- function Get_Node (It : Node_Iterator) return Node_Id is begin return It.Car; end Get_Node; ------------ -- Is_End -- ------------ function Is_End (It : Node_Iterator) return Boolean is begin return Is_Empty (Node_List (It)); end Is_End; ----------------- -- Append_Node -- ----------------- procedure Append_Node (List : in out Node_List; Node : Node_Id) is begin List := Append_Node (List, Node); end Append_Node; ----------------- -- Append_Node -- ----------------- function Append_Node (List : Node_List; Node : Node_Id) return Node_List is Cell, Last : Node_List; begin Cell := new Node_List_Cell'(Car => Node, Cdr => null); if List = null then return Cell; else Last := List; while Last.Cdr /= null loop Last := Last.Cdr; end loop; Last.Cdr := Cell; return List; end if; end Append_Node; ------------------- -- Insert_Before -- ------------------- procedure Insert_Before (List : in out Node_List; Node : Node_Id; Before : Node_Id) is Cell : Node_List; begin pragma Assert (List /= Nil_List); if List.Car = Before then Cell := new Node_List_Cell'(Car => Node, Cdr => List); List := Cell; else Insert_Before (List.Cdr, Node, Before); end if; end Insert_Before; ------------------ -- Insert_After -- ------------------ procedure Insert_After (List : Node_List; Node : Node_Id; After : Node_Id) is Cell : Node_List; begin pragma Assert (List /= Nil_List); if List.Car = After then Cell := new Node_List_Cell'(Car => Node, Cdr => List.Cdr); List.Cdr := Cell; else Insert_After (List.Cdr, Node, After); end if; end Insert_After; ---------------- -- Is_In_List -- ---------------- function Is_In_List (List : Node_List; Node : Node_Id) return Boolean is begin pragma Debug (O2 ("Is_In_List : enter")); if List = Nil_List then pragma Debug (O2 ("Is_In_List : enter")); pragma Debug (O ("Is_In_List : nil_list")); return False; end if; if List.Car = Node then pragma Debug (O2 ("Is_In_List : enter")); pragma Debug (O ("Is_In_List : found")); return True; else pragma Debug (O2 ("Is_In_List : enter")); pragma Debug (O ("Is_In_List : searching further")); return Is_In_List (List.Cdr, Node); end if; end Is_In_List; ------------------------ -- Is_In_Pointed_List -- ------------------------ function Is_In_Pointed_List (List : Node_List; Node : Node_Id) return Boolean is begin if List = Nil_List then return False; end if; pragma Assert (Kind (List.Car) = K_Scoped_Name); if Value (List.Car) = Value (Node) then return True; else return Is_In_Pointed_List (List.Cdr, Node); end if; end Is_In_Pointed_List; ---------- -- Next -- ---------- procedure Next (It : in out Node_Iterator) is begin It := Node_Iterator (It.Cdr); end Next; ----------------- -- Remove_Node -- ----------------- function Remove_Node (List : Node_List; Node : Node_Id) return Node_List is begin if List /= Nil_List then if List.Car = Node then declare Old_List : Node_List := List; Old_Cdr : constant Node_List := List.Cdr; begin pragma Debug (O ("Deallocating list cell at " & Img (Old_List.all'Address))); Unchecked_Deallocation (Old_List); return Old_Cdr; end; else List.Cdr := Remove_Node (List.Cdr, Node); end if; end if; return List; end Remove_Node; ----------------- -- Remove_Node -- ----------------- procedure Remove_Node (List : in out Node_List; Node : Node_Id) is begin List := Remove_Node (List, Node); end Remove_Node; ---------- -- Free -- ---------- procedure Free (List : in out Node_List) is Old_List : Node_List; begin while List /= null loop Old_List := List; List := List.Cdr; Unchecked_Deallocation (Old_List); end loop; end Free; -------------------------- -- Simplify node list -- -------------------------- function Simplify_Node_List (In_List : Node_List) return Node_List is Result_List : Node_List := null; It : Node_Iterator; Node : Node_Id; begin Init (It, In_List); while not Is_End (It) loop Get_Next_Node (It, Node); if not Is_In_List (Result_List, Node) then Append_Node (Result_List, Node); end if; end loop; return Result_List; end Simplify_Node_List; procedure Merge_List (Into : in out Node_List; From : Node_List) is It : Node_Iterator; N : Node_Id; begin Init (It, From); while not Is_End (It) loop Get_Next_Node (It, N); if not Is_In_List (Into, N) then Append_Node (Into, N); end if; end loop; end Merge_List; ----------------------------- -- Identifier definition -- ----------------------------- ---------------- -- Get_Node -- ---------------- function Get_Node (Definition : Identifier_Definition_Acc) return Node_Id is begin if Definition /= null then return Definition.Node; else raise Idlac_Errors.Fatal_Error; end if; end Get_Node; --------------------------------- -- Add_Identifier_Definition -- --------------------------------- procedure Add_Identifier_Definition (Scope : Node_Id; Definition : Identifier_Definition_Acc; Is_Inheritable : Boolean) is List : Identifier_Definition_List; begin pragma Debug (O2 ("Add_Identifier_Definition : enter")); pragma Assert (Scope /= No_Node); List := new Identifier_Definition_Cell' (Definition => Definition, Next => Identifier_List (Scope)); Set_Identifier_List (Scope, List); Add_Definition_To_Storage (Scope, Definition, Is_Inheritable); pragma Debug (O2 ("Add_Identifier_Definition : end")); end Add_Identifier_Definition; -------------------- -- Scope handling -- -------------------- -- A stack of active scopes type Scope_Stack; type Scope_Stack_Acc is access Scope_Stack; type Scope_Stack is record Parent : Scope_Stack_Acc; Scope : Node_Id; end record; procedure Unchecked_Deallocation is new Ada.Unchecked_Deallocation (Object => Scope_Stack, Name => Scope_Stack_Acc); Current_Scope : Scope_Stack_Acc := null; -- Top of the scope stack Root_Scope : Scope_Stack_Acc := null; -- Bottom of the scope stack ----------------------------------------------- -- The Gnat_Table type implemented functions -- ----------------------------------------------- Initial : constant Positive := 37; -- Initial table size Min : constant Integer := Integer (Nil_Uniq_Id + 1); -- Subscript of the minimum entry in the currently allocated table type size_t is new Integer; procedure Reallocate (T : in out Table); -- Reallocate the existing table according to the current value stored -- in Max. Works correctly to do an initial allocation if the table -- is currently null. procedure Allocate (T : in out Table; Num : Integer := 1; Result : out Uniq_Id) is Old_Last : constant Integer := T.Last_Val; begin T.Last_Val := T.Last_Val + Num; if T.Last_Val > T.Max then Reallocate (T); end if; Result := Uniq_Id (Old_Last + 1); end Allocate; procedure Decrement_Last (T : in out Table) is begin T.Last_Val := T.Last_Val - 1; end Decrement_Last; procedure Increment_Last (T : in out Table) is begin T.Last_Val := T.Last_Val + 1; if T.Last_Val > T.Max then Reallocate (T); end if; end Increment_Last; procedure Init (T : in out Table) is Old_Length : constant Integer := T.Length; begin T.Last_Val := Min - 1; T.Max := Min + Initial - 1; T.Length := T.Max - Min + 1; -- If table is same size as before (happens when table is never -- expanded which is a common case), then simply reuse it. Note -- that this also means that an explicit Init call right after -- the implicit one in the package body is harmless. if Old_Length = T.Length then return; -- Otherwise we can use Reallocate to get a table of the right size. -- Note that Reallocate works fine to allocate a table of the right -- initial size when it is first allocated. else Reallocate (T); end if; end Init; function Last (T : Table) return Uniq_Id is begin return Uniq_Id (T.Last_Val); end Last; procedure Reallocate (T : in out Table) is function realloc (memblock : Table_Ptr; size : size_t) return Table_Ptr; pragma Import (C, realloc); function malloc (size : size_t) return Table_Ptr; pragma Import (C, malloc); New_Size : size_t; begin if T.Max < T.Last_Val then if T.Length = 0 and then T.Max = Min - 1 then T.Max := Min + Initial - 1; T.Length := T.Max - Min + 1; else pragma Assert (not Locked); while T.Max < T.Last_Val loop T.Length := T.Length * 2; T.Max := Min + T.Length - 1; end loop; end if; end if; New_Size := size_t ((T.Max - Min + 1) * (Table_Type'Component_Size / System.Storage_Unit)); if T.Table = null then T.Table := malloc (New_Size); elsif New_Size > 0 then T.Table := realloc (memblock => T.Table, size => New_Size); end if; if T.Length /= 0 and then T.Table = null then raise Storage_Error; end if; end Reallocate; procedure Release (T : in out Table) is begin T.Length := T.Last_Val - Min + 1; T.Max := T.Last_Val; Reallocate (T); end Release; procedure Set_Last (T : in out Table; New_Val : Uniq_Id) is begin if Integer (New_Val) < T.Last_Val then T.Last_Val := Integer (New_Val); else T.Last_Val := Integer (New_Val); if T.Last_Val > T.Max then Reallocate (T); end if; end if; end Set_Last; -------------------------------- -- Identifiers handling types -- -------------------------------- Id_Table : Table; ----------- -- Hash -- ----------- function Hash (Str : String) return Hash_Value_Type is Res : Hash_Value_Type := 0; begin for I in Str'Range loop Res := ((Res and 16#0fffffff#) * 16) xor Character'Pos (GNAT.Case_Util.To_Lower (Str (I))); end loop; return Res; end Hash; ------------------------- -- Add_Int_Val_Forward -- ------------------------- procedure Add_Int_Val_Forward (Node : Node_Id) is UF : Node_List := Unimplemented_Forwards (Get_Root_Scope); begin Append_Node (UF, Node); Set_Unimplemented_Forwards (Get_Root_Scope, UF); end Add_Int_Val_Forward; ---------------------------- -- Add_Int_Val_Definition -- ---------------------------- procedure Add_Int_Val_Definition (Node : Node_Id) is UF : Node_List := Unimplemented_Forwards (Get_Root_Scope); begin Remove_Node (UF, Node); Set_Unimplemented_Forwards (Get_Root_Scope, UF); end Add_Int_Val_Definition; -------------------- -- Get_Root_Scope -- -------------------- function Get_Root_Scope return Node_Id is begin return Root_Scope.Scope; end Get_Root_Scope; ----------------------- -- Get_Current_Scope -- ----------------------- function Get_Current_Scope return Node_Id is begin return Current_Scope.Scope; end Get_Current_Scope; --------------------------- -- Get_Current_Gen_Scope -- --------------------------- function Get_Current_Gen_Scope return Node_Id is Scope : Scope_Stack_Acc := Current_Scope; begin while Scope /= null and then not Is_Gen_Scope (Scope.Scope) loop Scope := Scope.Parent; end loop; if Scope /= null then return Scope.Scope; else return No_Node; end if; end Get_Current_Gen_Scope; ------------------------- -- Get_Previous_Scope -- ------------------------- function Get_Previous_Scope return Node_Id is begin return Current_Scope.Parent.Scope; end Get_Previous_Scope; -------------------------- -- Identifiers handling -- -------------------------- function Identifier_Index (Identifier : String; Hash_Table : Hash_Table_Type; Table : Idl_Fe.Types.Table) return Uniq_Id; -- Return the Uniq_id of Identifier if it is defined in -- Table, or else return Nil_Uniq_Id. function Imported_Identifier_Index (Identifier : String) return Uniq_Id; -- Check if the uniq_id from an identifier is already defined -- in the imported table. -- return it or Nil_Unqiq_Id procedure Create_Identifier_Index (Identifier : String; Hash_Table : in out Hash_Table_Type; Table : in out Idl_Fe.Types.Table; Index : out Uniq_Id); -- Create the uniq_id entry for an identifier if it doesn't exist -- return it function Create_Identifier_In_Storage (Identifier : String; Scope : Node_Id) return Uniq_Id; -- Create the uniq_id entry for an identifier in the storage table -- at the end of the scope parsing -- return it function Create_Identifier_In_Imported (Identifier : String; Scope : Node_Id) return Uniq_Id; -- Create the uniq_id entry for an identifier in the imported table of -- the given scope -- return it ------------------ -- Push_Scope -- ------------------ procedure Push_Scope (Scope : Node_Id) is Stack : Scope_Stack_Acc; Index : Uniq_Id; procedure Reenter_Definition_List (Definition_List : Identifier_Definition_List); -- Enter all identifiers in Definition_List into the -- global Id_Table and Hash_Table, in reverse order. procedure Reenter_Definition_List (Definition_List : Identifier_Definition_List) is begin -- Definitions must be re-added in the order they -- were first created, i. e. starting at the tail -- of Definition_List. if Definition_List = null then return; end if; pragma Debug (O2 ("Reenter_Definition_List: enter")); Reenter_Definition_List (Definition_List.Next); -- Find a place for this identifier in the table... Create_Identifier_Index (Definition_List.Definition.Name.all, Hash_Table, Id_Table, Index); -- Set its fields previous_definition and id that were -- not used in the scope table... Definition_List.Definition.Previous_Definition := Id_Table.Table (Index).Definition; Definition_List.Definition.Id := Index; -- And finally add the identifier to the scope Id_Table.Table (Index).Definition := Definition_List.Definition; pragma Debug (O2 ("Reenter_Definition_List: leave")); end Reenter_Definition_List; begin pragma Debug (O2 ("Push_Scope : enter")); pragma Assert (Is_Scope (Scope)); Stack := new Scope_Stack; Stack.Parent := Current_Scope; Stack.Scope := Scope; if Current_Scope = null then pragma Debug (O ("Push_Scope : current_scope is null.")); pragma Debug (O ("Push_Scope : root scope is defined at " & Idlac_Errors.Location_To_String (Get_Location (Scope)))); Root_Scope := Stack; end if; Current_Scope := Stack; pragma Debug (O ("Push_Scope : putting the old definition " & "in the id_table.")); -- Add all definition of the new scope into the hash table, -- in case there are some. Used when a scoped is reopened. Reenter_Definition_List (Identifier_List (Scope)); pragma Debug (O2 ("Push_Scope : end")); end Push_Scope; ----------------- -- Pop_Scope -- ----------------- procedure Pop_Scope is Old_Scope : Scope_Stack_Acc; Definition_List : Identifier_Definition_List; Old_Definition : Identifier_Definition_Acc; Forward_Defs : Node_Iterator; Forward_Def : Node_Id; Hash_Index : Hash_Value_Type; Index : Uniq_Id; begin pragma Debug (O2 ("Pop_Scope : enter")); -- Remove all definition of scope from the hash table, and -- replace them by the previous one. -- Add these definition to the identifier_table of the Current_Scope Definition_List := Identifier_List (Current_Scope.Scope); while Definition_List /= null loop pragma Debug (O ("Pop_Scope: beginning of loop ")); Old_Definition := Definition_List.Definition; -- Remove the identifier from the Id_Table if Definition_List.Definition.Id not in Id_Table.Table'Range then Ada.Text_IO.Put_Line ("@@0 Argh."); end if; Id_Table.Table (Definition_List.Definition.Id).Definition := Definition_List.Definition.Previous_Definition; pragma Debug (O ("Pop_Scope: test the presence of" & " the previous definition")); if Definition_List.Definition.Previous_Definition = null then pragma Debug (O ("Pop_Scope: removing " & Definition_List.Definition.Name.all)); Hash_Index := Hash (Definition_List.Definition.Name.all) mod Hash_Mod; if Id_Table.Table (Hash_Table (Hash_Index)).Definition = null then Hash_Table (Hash_Index) := Nil_Uniq_Id; else Index := Hash_Table (Hash_Index); while Id_Table.Table (Id_Table.Table (Index).Next).Definition /= null loop Index := Id_Table.Table (Index).Next; end loop; Id_Table.Table (Index).Next := Nil_Uniq_Id; end if; end if; -- once the definition is no more in the id table but -- only in the table of the scope, the previous_definition -- field has no more interest, as well as the Id field Old_Definition.Previous_Definition := null; Old_Definition.Id := Nil_Uniq_Id; Definition_List := Definition_List.Next; pragma Debug (O ("Pop_Scope: end of loop ")); end loop; pragma Debug (O ("Pop_Scope: all is removed ")); Old_Scope := Current_Scope; Current_Scope := Old_Scope.Parent; -- Test if all forward definitions were implemented if Kind (Old_Scope.Scope) = K_Repository then pragma Debug (O ("Pop_Scope: forward definitions still there ")); Init (Forward_Defs, Unimplemented_Forwards (Get_Root_Scope)); while not Is_End (Forward_Defs) loop Get_Next_Node (Forward_Defs, Forward_Def); Idlac_Errors.Error ("The forward declaration " & Idlac_Errors.Location_To_String (Get_Location (Forward_Def)) & " is not implemented.", Idlac_Errors.Error, Get_Location (Old_Scope.Scope)); end loop; end if; -- Free the forward definition list if Kind (Old_Scope.Scope) = K_Repository then declare UF : Node_List := Unimplemented_Forwards (Get_Root_Scope); begin Set_Unimplemented_Forwards (Get_Root_Scope, Nil_List); Free (UF); end; end if; Unchecked_Deallocation (Old_Scope); pragma Debug (O2 ("Pop_Scope : end")); end Pop_Scope; -------------------- -- Is_Redefinable -- -------------------- function Is_Redefinable (Name : String; Loc : Idlac_Errors.Location; Scope : Node_Id := No_Node) return Boolean is A_Definition : Identifier_Definition_Acc; Scop : Node_Id; begin pragma Debug (O2 ("Is_Redefinable (""" & Name & """): enter")); if Scope = No_Node then Scop := Current_Scope.Scope; else Scop := Scope; end if; pragma Assert (Is_Scope (Scop)); -- Check if the identifier is already imported if Imported_Identifier_Index (Name) /= Nil_Uniq_Id then pragma Debug (O ("Is_Redefinable: already imported")); pragma Debug (O2 ("Is_Redefinable: end")); return False; end if; A_Definition := Find_Identifier_Definition (Name, Loc); if A_Definition /= null then pragma Debug (O ("Is_Redefinable: " & "Definition found is " & Node_Kind'Image (Kind (A_Definition.Node)))); -- Ensure that the identifier is not being redefined -- in the same scope. if A_Definition.Parent_Scope = Scop then pragma Debug (O2 ("Is_Redefinable: end")); return False; end if; -- An attribute or operation may not be redefined if Kind (A_Definition.Node) = K_Operation or else (Kind (A_Definition.Node) = K_Declarator and then Kind (Parent (A_Definition.Node)) = K_Attribute) then if Kind (Scop) = K_Interface or else Kind (Scop) = K_ValueType then pragma Debug (O ("Is_Redefinable: " & "An operation or attribute cannot be redefined.")); pragma Debug (O2 ("Is_Redefinable : end")); return False; end if; end if; -- Ckecks if identifier found is the scope name: -- it is not allowed except for operations if Kind (Scop) /= K_Operation and then A_Definition = Definition (Scop) then pragma Debug (O2 ("Is_Redefinable: end")); return False; end if; end if; pragma Debug (O2 ("Is_Redefinable : end")); return True; end Is_Redefinable; ---------------------- -- Identifier_Index -- ---------------------- function Identifier_Index (Identifier : String; Hash_Table : Hash_Table_Type; Table : Idl_Fe.Types.Table) return Uniq_Id is use Idl_Fe.Lexer; Index : Uniq_Id := Hash_Table (Hash (Identifier) mod Hash_Mod); begin pragma Debug (O2 ("Identifier_Index : enter")); pragma Debug (O ("Identifier_Index : the identifier is " & Identifier)); while Index /= Nil_Uniq_Id and then Table.Table (Index).Definition.Name /= null and then Idl_Identifier_Equal (Table.Table (Index).Definition.Name.all, Identifier) = Differ loop pragma Debug (O ("Identifier_Index : identifier is " & Identifier & ", in the table, we have " & Table.Table (Index).Definition.Name.all)); Index := Table.Table (Index).Next; end loop; pragma Debug (O2 ("Identifier_Index : end")); return Index; end Identifier_Index; function Imported_Identifier_Index (Identifier : String) return Uniq_Id is use Idl_Fe.Lexer; Scope : Node_Id; begin pragma Debug (O2 ("Imported_Identifier_Index : enter")); if not Is_Imports (Current_Scope.Scope) then pragma Debug (O2 ("Imported_Identifier_Index : end")); return Nil_Uniq_Id; end if; Scope := Current_Scope.Scope; pragma Debug (O ("Imported_Identifier_Index : scope type is " & Node_Kind'Image (Kind (Scope)) & ".")); pragma Debug (O2 ("Imported_Identifier_Index : end")); return Identifier_Index (Identifier, Imported_Table (Scope).Hash_Table, Imported_Table (Scope).Content_Table); end Imported_Identifier_Index; ----------------------------- -- Create_Identifier_Index -- ----------------------------- procedure Create_Identifier_Index (Identifier : String; Hash_Table : in out Hash_Table_Type; Table : in out Idl_Fe.Types.Table; Index : out Uniq_Id) is use Idl_Fe.Lexer; Hash_Value : constant Hash_Value_Type := Hash (Identifier) mod Hash_Mod; Result : Uniq_Id := Hash_Table (Hash_Value); Previous : Uniq_Id := Nil_Uniq_Id; begin pragma Debug (O2 ("Create_Identifier_Index : enter, id = " & Identifier & ", hash = " & Img (Integer (Hash_Value)))); if Result = Nil_Uniq_Id then -- No identifier in this slot yet. Increment_Last (Table); Result := Uniq_Id (Table.Last_Val); Hash_Table (Hash_Value) := Result; else -- This slot already has identifiers. while True and then Result /= Nil_Uniq_Id and then Table.Table (Result).Definition.Name /= null and then Idl_Identifier_Equal (Table.Table (Result).Definition.Name.all, Identifier) = Differ loop Previous := Result; Result := Table.Table (Result).Next; end loop; if Result /= Nil_Uniq_Id then -- This identifier is already in the table. Index := Result; pragma Debug (O2 ("Create_Identifier_Index : end (already in table)")); return; end if; pragma Assert (Previous /= Nil_Uniq_Id); Increment_Last (Table); Result := Uniq_Id (Table.Last_Val); Table.Table (Previous).Next := Result; end if; -- Add an entry for Index, using default values Index := Result; Table.Table (Result) := (Definition => null, Is_Inheritable => True, Next => Nil_Uniq_Id); pragma Debug (O2 ("Create_Identifier_Index : end")); return; end Create_Identifier_Index; -------------------------------- -- Find_Identifier_Definition -- -------------------------------- function Find_Identifier_Definition (Name : String; Loc : Idlac_Errors.Location) return Identifier_Definition_Acc is Index : Uniq_Id; Imported_Definition, Inherited_Definition : Identifier_Definition_Acc; Definition : Identifier_Definition_Acc := null; begin pragma Debug (O2 ("Find_Identifier_Definition (""" & Name & """): enter")); Index := Identifier_Index (Name, Hash_Table, Id_Table); pragma Debug (O ("Find_Identifier_Definition: " & "check_identifier_index done")); if Index /= Nil_Uniq_Id then pragma Debug (O ("Find_Identifier_Definition: " & "there is a definition in the id table")); Definition := Id_Table.Table (Index).Definition; -- Is the definition in the current scope? if Definition.Parent_Scope = Current_Scope.Scope then pragma Debug (O2 ("Find_Identifier_Definition: end")); return Definition; end if; end if; -- Is the definition imported? Imported_Definition := Find_Imported_Identifier_Definition (Name); if Imported_Definition /= null then pragma Debug (O2 ("Find_Identifier_Definition: end")); return Imported_Definition; end if; -- Is the definition inherited? Inherited_Definition := Find_Inherited_Identifier_Definition (Name, Loc); if Inherited_Definition /= null then pragma Debug (O ("Find_Identifier_Definition: " & "Inherited definition is of type " & Node_Kind'Image (Kind (Inherited_Definition.Node)))); pragma Debug (O2 ("Find_Identifier_Definition: end")); return Inherited_Definition; end if; -- The definition is in a upper scope pragma Debug (O2 ("Find_Identifier_Definition: end")); return Definition; end Find_Identifier_Definition; -------------------------- -- Find_Identifier_Node -- -------------------------- function Find_Identifier_Node (Name : String; Loc : Idlac_Errors.Location) return Node_Id is Definition : Identifier_Definition_Acc; begin Definition := Find_Identifier_Definition (Name, Loc); if Definition = null then return No_Node; else return Definition.Node; end if; end Find_Identifier_Node; ------------------------- -- Redefine_Identifier -- ------------------------- procedure Redefine_Identifier (A_Definition : Identifier_Definition_Acc; Node : Node_Id) is begin pragma Debug (O2 ("Redefine_Identifier : begin")); if A_Definition.Node = No_Node or else Definition (Node) /= null then raise Idlac_Errors.Internal_Error; end if; Set_Definition (A_Definition.Node, null); -- free???????? A_Definition.Node := Node; Set_Definition (Node, A_Definition); pragma Debug (O2 ("Redefine_Identifier : end")); end Redefine_Identifier; -------------------- -- Add_Identifier -- -------------------- function Add_Identifier (Node : Node_Id; Name : String; Scope : Node_Id := No_Node; Is_Inheritable : Boolean := True) return Boolean is Definition : Identifier_Definition_Acc; Index : Uniq_Id; Scop : Node_Id; Loc : constant Idlac_Errors.Location := Get_Location (Node); begin if Scope = No_Node then Scop := Current_Scope.Scope; else Scop := Scope; end if; pragma Assert (Is_Scope (Scop)); pragma Debug (O2 ("Add_Identifier (""" & Name & """): enter")); -- Check whether the identifier is redefinable if not Is_Redefinable (Name, Loc, Scop) then pragma Debug (O ("Add_Identifier: identifier not redefinable")); pragma Debug (O2 ("Add_Identifier: end")); return False; end if; pragma Debug (O ("Add_Identifier: creating a definition")); Create_Identifier_Index (Name, Hash_Table, Id_Table, Index); Definition := new Identifier_Definition; Definition.Name := new String'(Name); Definition.Id := Index; Definition.Node := Node; Definition.Previous_Definition := Id_Table.Table (Index).Definition; Definition.Parent_Scope := Scop; Id_Table.Table (Index).Definition := Definition; pragma Debug (O ("Add_Identifier: " & "adding definition to the current scope")); Add_Identifier_Definition (Scop, Definition, Is_Inheritable); pragma Debug (O ("Add_Identifier: pointing node to definition")); Set_Definition (Node, Definition); pragma Debug (O2 ("Add_Identifier: end")); return True; end Add_Identifier; -------------------------------- -- Find_Identifier_In_Storage -- -------------------------------- function Find_Identifier_In_Storage (Scope : Node_Id; Name : String; Inheritable_Only : Boolean := False) return Identifier_Definition_Acc is function Stored_Identifier_Index (Scope : Node_Id; Identifier : String) return Uniq_Id; -- Check if the uniq_id from an identifier is already defined -- in the scope and return it or Nil_Uniq_Id function Stored_Identifier_Index (Scope : Node_Id; Identifier : String) return Uniq_Id is use Idl_Fe.Lexer; begin pragma Debug (O2 ("Stored_Identifier_Index : enter & end")); return Identifier_Index (Identifier, Identifier_Table (Scope).Hash_Table, Identifier_Table (Scope).Content_Table); end Stored_Identifier_Index; Index : Uniq_Id; begin pragma Debug (O2 ("Find_Identifier_In_Storage : enter")); Index := Stored_Identifier_Index (Scope, Name); if Index /= Nil_Uniq_Id and then (Identifier_Table (Scope).Content_Table.Table (Index).Is_Inheritable or else not Inheritable_Only) then pragma Debug (O2 ("Find_Identifier_In_Storage : end")); return Identifier_Table (Scope). Content_Table.Table (Index).Definition; else pragma Debug (O2 ("Find_Identifier_In_Storage : end")); return null; end if; end Find_Identifier_In_Storage; ----------------------------------- -- Create_Indentifier_In_Storage -- ----------------------------------- function Create_Identifier_In_Storage (Identifier : String; Scope : Node_Id) return Uniq_Id is use Idl_Fe.Lexer; IT : Storage := Identifier_Table (Scope); Index : Uniq_Id; begin Create_Identifier_Index (Identifier, IT.Hash_Table, IT.Content_Table, Index); Set_Identifier_Table (Scope, IT); return Index; end Create_Identifier_In_Storage; ------------------------------- -- Add_Definition_To_Storage -- ------------------------------- procedure Add_Definition_To_Storage (Scope : Node_Id; Definition : Identifier_Definition_Acc; Is_Inheritable : Boolean) is Index : Uniq_Id; begin pragma Debug (O2 ("Add_Definition_To_Storage : enter")); pragma Assert (Scope /= No_Node); pragma Debug (O ("Name = " & Definition.Name.all)); Index := Create_Identifier_In_Storage (Definition.Name.all, Scope); -- There should be no redefinitions. pragma Assert (Identifier_Table (Scope).Content_Table. Table (Index).Definition = null); Identifier_Table (Scope).Content_Table. Table (Index).Definition := Definition; Identifier_Table (Scope).Content_Table. Table (Index).Is_Inheritable := Is_Inheritable; pragma Debug (O2 ("Add_Definition_To_Storage : end")); end Add_Definition_To_Storage; ----------------------------------------- -- Find_Imported_Identifier_Definition -- ----------------------------------------- function Find_Imported_Identifier_Definition (Name : String) return Identifier_Definition_Acc is Index : Uniq_Id; Scope : Node_Id; begin pragma Debug (O2 ("Find_Imported_Identifier_Definition : enter")); Scope := Current_Scope.Scope; Index := Imported_Identifier_Index (Name); if Index /= Nil_Uniq_Id then pragma Debug (O2 ("Find_Imported_Identifier_Definition : end")); return Imported_Table (Scope).Content_Table.Table (Index).Definition; else pragma Debug (O2 ("Find_Imported_Identifier_Definition : end")); return null; end if; end Find_Imported_Identifier_Definition; ------------------------------------ -- Create_Indentifier_In_Imported -- ------------------------------------ function Create_Identifier_In_Imported (Identifier : String; Scope : Node_Id) return Uniq_Id is use Idl_Fe.Lexer; Index : Uniq_Id; IT : Storage := Imported_Table (Scope); begin Create_Identifier_Index (Identifier, IT.Hash_Table, IT.Content_Table, Index); Set_Imported_Table (Scope, IT); return Index; end Create_Identifier_In_Imported; -------------------------------- -- Add_Definition_To_Imported -- -------------------------------- procedure Add_Definition_To_Imported (Definition : Identifier_Definition_Acc; Scope : Node_Id) is Index : Uniq_Id; Definition_Test : Identifier_Definition_Acc; begin -- check if we are in value type or interfaces (we should be); if not Is_Imports (Scope) then return; end if; pragma Assert (Kind (Scope) = K_Interface or else Kind (Scope) = K_ValueType); Index := Create_Identifier_In_Imported (Definition.Name.all, Scope); Definition_Test := Imported_Table (Scope).Content_Table.Table (Index).Definition; if Definition_Test /= null then if Definition_Test /= Definition then raise Idlac_Errors.Internal_Error; end if; end if; Imported_Table (Scope).Content_Table. Table (Index).Definition := Definition; end Add_Definition_To_Imported; ------------------------------------ -- Find_Identifier_In_Inheritance -- ------------------------------------ procedure Find_Identifier_In_Inheritance (Name : String; Scope : Node_Id; List : in out Node_List) is It : Node_Iterator; Node : Node_Id; Definition : Identifier_Definition_Acc; Parent : Node_List; begin pragma Debug (O2 ("Find_Identifier_In_Inheritance (""" & Name & """: enter")); Parent := Parents (Scope); Init (It, Parent); -- Iterate over all parents of the scope while not Is_End (It) loop Get_Next_Node (It, Node); pragma Assert (Kind (Node) = K_Scoped_Name); pragma Debug (O ("Find_Identifier_In_Inheritance: " & Node_Kind'Image (Kind (Node)))); Definition := Find_Identifier_In_Storage (Value (Node), Name, Inheritable_Only => True); if Definition /= null then Append_Node (List, Definition.Node); else Find_Identifier_In_Inheritance (Name, Value (Node), List); end if; end loop; pragma Debug (O2 ("Find_Identifier_In_Inheritance: end")); return; end Find_Identifier_In_Inheritance; ------------------------------------------ -- Find_Inherited_Identifier_Definition -- ------------------------------------------ function Find_Inherited_Identifier_Definition (Name : String; Loc : Idlac_Errors.Location) return Identifier_Definition_Acc is Temp_List : Node_List := Nil_List; Result_List : Node_List := Nil_List; Result : Identifier_Definition_Acc; begin pragma Debug (O2 ("Find_Inherited_Identifier_Definition (""" & Name & """): enter")); -- There are no imports in modules if Kind (Current_Scope.Scope) /= K_Interface and then Kind (Current_Scope.Scope) /= K_ValueType then pragma Debug (O2 ("Find_Inherited_Identifier_Definition: end")); return null; end if; Find_Identifier_In_Inheritance (Name, Current_Scope.Scope, Temp_List); Result_List := Simplify_Node_List (Temp_List); case Length (Result_List) is when 0 => pragma Debug (O ("Find_Inherited_Identifier_Definition: " & "Nothing found in inheritance")); pragma Debug (O2 ("Find_Inherited_Identifier_Definition: end")); Result := null; when 1 => pragma Debug (O ("Find_Inherited_Identifier_Definition: " & "One definition found in inheritance")); Result := Definition (Head (Result_List)); when others => -- There are multiple definitions pragma Debug (O ("Find_Inherited_Identifier_Definition: " & "Multiple definitions found in inheritance")); Idlac_Errors.Error ("Multiple definitions found" & " in inheritance: ambiguous " & "reference", Idlac_Errors.Error, Loc); Result := Definition (Head (Result_List)); end case; Free (Temp_List); Free (Result_List); return Result; end Find_Inherited_Identifier_Definition; ---------------------------------- -- Processing of Repository_Ids -- ---------------------------------- ------------------------------- -- Set_Default_Repository_Id -- ------------------------------- procedure Set_Default_Repository_Id (Node : Node_Id) is Prefix_Node : constant Node_Id := Current_Prefix (Get_Current_Scope); Name_Node : constant Node_Id := Make_Lit_String (Get_Location (Node)); begin pragma Debug (O2 ("Set_Default_Repository_Id : enter")); pragma Assert (not Is_Explicit_Repository_Id (Node)); if Prefix_Node /= No_Node and then String_Value (Prefix_Node) /= "" then Set_String_Value (Name_Node, "IDL:" & String_Value (Prefix_Node) & "/" & Default_Repository_Id (Node) & ":1.0"); else Set_String_Value (Name_Node, "IDL:" & Default_Repository_Id (Node) & ":1.0"); end if; Set_Repository_Id (Node, Name_Node); pragma Debug (O2 ("Set_Default_Repository_Id : end")); end Set_Default_Repository_Id; -------------------------------- -- Set_Initial_Current_Prefix -- -------------------------------- procedure Set_Initial_Current_Prefix (Node : Node_Id) is begin pragma Assert (Is_Scope (Node)); Set_Current_Prefix (Node, Current_Prefix (Get_Current_Scope)); end Set_Initial_Current_Prefix; end Idl_Fe.Types; polyorb-2.8~20110207.orig/compilers/idlac/TODO0000644000175000017500000000407611750740337020160 0ustar xavierxavierThese are some points to be implemented or improved in idlac : - the token T_ERROR is not taken into account in the parser. It creates parser errors while the error in only in the lexer. - the parsing of sequences is not completly done. Some tricky cases are not taken into account. The problem is the following code : const long r = 5; interface Bug { typedef sequence > r >> s; } the first ">>" is not well understood since it is difficult to know whether it is the name of the type (r could be overloaded) or the second operand of the >> operation. Some code is to be added in parse_sequence_type in idl_fe-parser.adb. - all_errors.idl is not complete. - the types Idl_Integer and Idl_Float should have an unlimited precision. It is not the case and moreover, there is no check on the length of the entry in the functions get_integer, get_float and get_fixed of idl_fe-parser.idl - in the value definitions, some special cases are not correctly handled : - you should not be able to overload an operation or an attribute - the support of interfaces is badly managed : clashes between attributes or operations are not detected - you should not be able to overload a factory or a member - I'm not sure that the ranges of the types float, double and long double are right. To be checked using paragraph 3.10.1.2 of the specification. - some useless cases in switch statement are potentially not detected (for example case 1, default : ...) - there is no verification that all the cases of a switch are distincts. There was some code written to handle a list of all values already used in a given switch statement. But this was never used. You can find this code after the lines : --------------------------------- -- Management of expressions -- --------------------------------- in idl_fe-parser.adb and idl_fe-parser.ads. - some FIXMES were left in the code (5 at this moment). They explain the problem - the function Img for constant_value_ptr in utils.adb does only work for integers - merge torture and all_definitions examples. polyorb-2.8~20110207.orig/compilers/idlac/ada_be-idl2ada-value_impl.ads0000644000175000017500000000453311750740337025003 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- A D A _ B E . I D L 2 A D A . V A L U E _ I M P L -- -- -- -- S p e c -- -- -- -- Copyright (C) 2001 Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by ACT Europe. -- -- (email: sales@act-europe.fr) -- -- -- ------------------------------------------------------------------------------ private package Ada_Be.Idl2Ada.Value_Impl is Suffix : constant String := ".Value_Impl"; procedure Gen_Node_Spec (CU : in out Compilation_Unit; Node : Node_Id); procedure Gen_Node_Body (CU : in out Compilation_Unit; Node : Node_Id); -- Generate an helper package end Ada_Be.Idl2Ada.Value_Impl; polyorb-2.8~20110207.orig/compilers/idlac/ada_be-mappings-corba.ads0000644000175000017500000001025711750740337024252 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- A D A _ B E . M A P P I N G S . C O R B A -- -- -- -- S p e c -- -- -- -- Copyright (C) 2001-2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- The CORBA personality IDL mapping. package Ada_Be.Mappings.CORBA is type CORBA_Mapping_Type is new Mapping_Type with private; function Library_Unit_Name (Self : access CORBA_Mapping_Type; Node : Idl_Fe.Types.Node_Id) return String; function Client_Stubs_Unit_Name (Self : access CORBA_Mapping_Type; Node : Idl_Fe.Types.Node_Id) return String; function Server_Skel_Unit_Name (Self : access CORBA_Mapping_Type; Node : Idl_Fe.Types.Node_Id) return String; function Self_For_Operation (Self : access CORBA_Mapping_Type; Node : Idl_Fe.Types.Node_Id) return String; procedure Map_Type_Name (Self : access CORBA_Mapping_Type; Node : Idl_Fe.Types.Node_Id; Unit : out ASU.Unbounded_String; Typ : out ASU.Unbounded_String); function Calling_Stubs_Type (Self : access CORBA_Mapping_Type; Node : Idl_Fe.Types.Node_Id) return String; function Generate_Scope_In_Child_Package (Self : access CORBA_Mapping_Type; Node : Idl_Fe.Types.Node_Id) return Boolean; The_CORBA_Mapping : constant CORBA_Mapping_Type; ---------------------------- -- CORBA specific section -- ---------------------------- function Ada_Helper_Unit_Name (Mapping : access CORBA_Mapping_Type; Node : Idl_Fe.Types.Node_Id) return String; -- The name of the helper package where the TypeCode for Node is defined function Ada_Type_Defining_Name (Mapping : access CORBA_Mapping_Type; Node : Idl_Fe.Types.Node_Id) return String; -- The defining name of the Ada type that maps Node -- (a K_Interface or K_ValueType). -- This is not the fully qualified name. function Code_Generation_Suppressed (Mapping : access CORBA_Mapping_Type; Node : Idl_Fe.Types.Node_Id) return Boolean; -- Return True iff code generation for Node should be suppressed -- because of non-standard or Ada Language Mapping specific rules. private type CORBA_Mapping_Type is new Mapping_Type with null record; The_CORBA_Mapping : constant CORBA_Mapping_Type := (Mapping_Type with null record); end Ada_Be.Mappings.CORBA; polyorb-2.8~20110207.orig/compilers/idlac/ada_be-identifiers.ads0000644000175000017500000000473311750740337023657 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- A D A _ B E . I D E N T I F I E R S -- -- -- -- S p e c -- -- -- -- Copyright (C) 2001 Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by ACT Europe. -- -- (email: sales@act-europe.fr) -- -- -- ------------------------------------------------------------------------------ with Idl_Fe.Types; use Idl_Fe.Types; package Ada_Be.Identifiers is function Ada_Name (Node : Node_Id) return String; -- The Ada name (unqualified) of K_Named node. function Ada_Full_Name (Node : Node_Id) return String; -- The Ada full name of K_Named Node. function Parent_Scope_Name (Node : Node_Id) return String; -- The Ada full name of the scope where K_Named -- Node is defined. end Ada_Be.Identifiers; polyorb-2.8~20110207.orig/compilers/idlac/ada_be-debug.adb0000644000175000017500000000655711750740337022425 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- A D A _ B E . D E B U G -- -- -- -- B o d y -- -- -- -- Copyright (C) 2001-2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with Ada.Text_IO; use Ada.Text_IO; package body Ada_Be.Debug is Filename : constant String := "ada_be.opt"; type String_Ptr is access String; Flag_Table : array (1 .. 32) of String_Ptr; Last_Flag : Natural := 0; --------------- -- Is_Active -- --------------- function Is_Active (Flag : String) return Natural is begin for I in 1 .. Last_Flag loop if Flag_Table (I).all = Flag then return I; end if; end loop; return 0; end Is_Active; ------------ -- Output -- ------------ procedure Output (Message : String) is begin if Flag /= 0 then Put_Line (Current_Error, Flag_Table (Flag).all & ": " & Message); end if; end Output; File : File_Type; Line : String (1 .. 256); Last : Natural; begin begin Open (File, In_File, Filename); while not End_Of_File (File) loop Get_Line (File, Line, Last); if Last /= 0 then if Line (1) /= '#' then if Is_Active (Line (1 .. Last)) = 0 then Last_Flag := Last_Flag + 1; Flag_Table (Last_Flag) := new String'(Line (1 .. Last)); end if; end if; end if; end loop; Close (File); exception when others => null; end; end Ada_Be.Debug; polyorb-2.8~20110207.orig/compilers/idlac/ada_be-idl2ada-ir_info.adb0000644000175000017500000013765311750740337024264 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- A D A _ B E . I D L 2 A D A . I R _ I N F O -- -- -- -- B o d y -- -- -- -- Copyright (C) 2002-2007, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with Idl_Fe.Tree; use Idl_Fe.Tree; with Idl_Fe.Tree.Synthetic; use Idl_Fe.Tree.Synthetic; with Ada_Be.Identifiers; use Ada_Be.Identifiers; with Ada_Be.Mappings.CORBA; use Ada_Be.Mappings.CORBA; with Ada_Be.Debug; pragma Elaborate_All (Ada_Be.Debug); with Idlac_Errors; use Idlac_Errors; with Ada_Be.Source_Streams; pragma Elaborate_All (Ada_Be.Source_Streams); package body Ada_Be.Idl2Ada.IR_Info is Flag : constant Natural := Ada_Be.Debug.Is_Active ("ada_be.idl2ada.ir_info"); procedure O is new Ada_Be.Debug.Output (Flag); pragma Warnings (Off); pragma Unreferenced (O); pragma Warnings (On); Registration : constant Source_Streams.Diversion := Source_Streams.Allocate_User_Diversion; CRR : constant String := "CORBA.Repository_Root"; procedure Gen_IR_Function_Prologue (CU : in out Compilation_Unit; Node : Node_Id; For_Body : Boolean); function Ada_IR_Name (Node : Node_Id) return String; -- The defining name for the IR object corresponding to Node. function Ada_IR_Info_Name (Node : Node_Id) return String; -- The name of the package that contains the IR object for Node. function Ada_Full_IR_Name (Node : Node_Id) return String; -- The fully qualified name for the IR object corresponding -- to Node. ---------------------------------------- -- Specialised generation subprograms -- ---------------------------------------- procedure Gen_Standard_Create_Parameters (CU : in out Compilation_Unit; Node : Node_Id); -- Generate the actual parameters that are common to -- all create_* operations: id, name, and version. procedure Gen_Parent_Container_Dcl (CU : in out Compilation_Unit; Node : Node_Id); -- Generate the declaration of a Container_Ref corresponding -- to the container corresponding to Node's parent scope. procedure Gen_IDLType (CU : in out Compilation_Unit; T_Node : Node_Id; D_Node : Node_Id); -- Generate an IDLType object reference corresponding -- to the entity declared by declarator D_Node with the type -- denoted by T_Node (note, for arrays T_Node is the element -- type.) If D_Node is No_Node, no array bounds are assumed. procedure Gen_Parent_Container_Lookup (CU : in out Compilation_Unit; Node : Node_Id); -- Generate the code to look up Node's name in the container -- object that describes its parent scope. procedure Gen_Interface_Body (CU : in out Compilation_Unit; Node : Node_Id); -- Generate the body of the helper package for an interface declaration procedure Gen_Operation_Body (CU : in out Compilation_Unit; Node : Node_Id); -- Generate the body of the helper package for an operation declaration procedure Gen_Attribute_Body (CU : in out Compilation_Unit; Node : Node_Id); -- Generate the body of the helper package for an attribute declaration procedure Gen_Module_Body (CU : in out Compilation_Unit; Node : Node_Id); -- Generate the body of the helper package for a module declaration procedure Gen_ValueType_Spec (CU : in out Compilation_Unit; Node : Node_Id); -- Generate the spec of the helper package for a valuetype declaration procedure Gen_ValueType_Body (CU : in out Compilation_Unit; Node : Node_Id); -- Generate the body of the helper package for a valuetype declaration procedure Gen_Enum_Spec (CU : in out Compilation_Unit; Node : Node_Id); -- Generate the spec of the helper package for an enum declaration procedure Gen_Enum_Body (CU : in out Compilation_Unit; Node : Node_Id); -- Generate the body of the helper package for an enum declaration procedure Gen_Struct_Exception_Spec (CU : in out Compilation_Unit; Node : Node_Id); -- Generate the spec of the helper package for a struct or an -- exception declaration procedure Gen_Struct_Exception_Body (CU : in out Compilation_Unit; Node : Node_Id); -- Generate the body of the helper package for a struct or an -- exception declaration procedure Gen_Union_Spec (CU : in out Compilation_Unit; Node : Node_Id); -- Generate the spec of the helper package for an union declaration procedure Gen_Union_Body (CU : in out Compilation_Unit; Node : Node_Id); -- Generate the body of the helper package for an union declaration procedure Gen_Type_Declarator_Body (CU : in out Compilation_Unit; Node : Node_Id); -- Generate the body of the helper package for an array declaration -- procedure Gen_Sequence_Spec -- (CU : in out Compilation_Unit; -- Node : Node_Id); -- -- Generate the spec of the helper package for a sequence declaration -- procedure Gen_Sequence_Body -- (CU : in out Compilation_Unit; -- Node : Node_Id); -- -- Generate the body of the helper package for a sequence declaration procedure Gen_Array_IR (CU : in out Compilation_Unit; Element_Type_Node : Node_Id; Decl_Node : Node_Id); -- Generate code to create an ArrayDef IRObject -- (only used in the type_declarator part of gen_node_body). procedure Gen_Fixed_IR (CU : in out Compilation_Unit; Node : Node_Id); -- Generate code to create a FixedDef IRObject -- (only used in the type_declarator part of gen_node_body). procedure Gen_Sequence_IR (CU : in out Compilation_Unit; Node : Node_Id); -- Generate code to create a SequenceDef IRObject -- (only used in the type_declarator part of gen_node_body). ---------------------------------------------- -- End of internal subprograms declarations -- ---------------------------------------------- function Ada_IR_Name (Node : Node_Id) return String is Prefix : constant String := "IR_"; NK : constant Node_Kind := Kind (Node); function Get_Primitive (S : String) return String; -- Return a call to Get_Primitive for the named -- PrimitiveDef kind. function Get_Primitive (S : String) return String is begin return "Get_Primitive" & ASCII.LF & " (Get_IR_Root, CORBA.Repository_Root." & S & ")"; end Get_Primitive; begin case NK is when K_Declarator => if Original_Node (Node) /= No_Node and then Kind (Original_Node (Node)) /= K_Fixed then return Ada_IR_Name (Original_Node (Node)); end if; return Prefix & Ada_Name (Node); when K_Module | K_Interface | K_Forward_Interface | K_ValueType | K_Forward_ValueType | K_Enum | K_Union | K_Struct | K_Exception | K_Operation => return Prefix & Ada_Name (Node); when K_Scoped_Name => return Ada_IR_Name (Value (Node)); when K_Void => return Get_Primitive ("pk_void"); when K_Short => return Get_Primitive ("pk_short"); when K_Long => return Get_Primitive ("pk_long"); when K_Long_Long => return Get_Primitive ("pk_longlong"); when K_Unsigned_Short => return Get_Primitive ("pk_ushort"); when K_Unsigned_Long => return Get_Primitive ("pk_ulong"); when K_Unsigned_Long_Long => return Get_Primitive ("pk_ulonglong"); when K_Char => return Get_Primitive ("pk_char"); when K_Wide_Char => return Get_Primitive ("pk_wchar"); when K_Boolean => return Get_Primitive ("pk_boolean"); when K_Float => return Get_Primitive ("pk_float"); when K_Double => return Get_Primitive ("pk_double"); when K_Long_Double => return Get_Primitive ("pk_longdouble"); when K_String => return Get_Primitive ("pk_string"); when K_String_Instance => return Get_Primitive ("pk_string"); -- XXX dubious when K_Wide_String => return Get_Primitive ("pk_wstring"); when K_Octet => return Get_Primitive ("pk_octet"); when K_Object => return Get_Primitive ("pk_objref"); when K_Any => return Get_Primitive ("pk_any"); when others => -- Improper use: node N is not -- mapped to an Ada type. Error ("No IR object for " & Node_Kind'Image (NK) & " nodes.", Fatal, Get_Location (Node)); -- Keep the compiler happy. raise Program_Error; end case; end Ada_IR_Name; function Ada_IR_Info_Name (Node : Node_Id) return String is NK : constant Node_Kind := Kind (Node); begin case NK is when K_Module | K_Interface => return Ada_Full_Name (Node) & Suffix; when K_Forward_Interface => return Parent_Scope_Name (Node) & Suffix; when -- K_Sequence_Instance | K_ValueType | K_Forward_ValueType | K_Enum | K_Union | K_Struct | K_Declarator | K_Exception => return Parent_Scope_Name (Node) & Suffix; when K_Scoped_Name => return Ada_IR_Info_Name (Value (Node)); when K_Void | K_Short | K_Long | K_Long_Long | K_Unsigned_Short | K_Unsigned_Long | K_Unsigned_Long_Long | K_Char | K_Wide_Char | K_Boolean | K_Float | K_Double | K_Long_Double | K_String | K_Wide_String | K_Octet | K_Object | K_Any => return CRR & ".Repository"; when K_String_Instance => return CRR & ".Repository"; -- XXX dubious when others => -- Improper use: node N does not have a correspoding -- IR object. Error ("No IR info for " & Node_Kind'Image (NK) & " nodes.", Fatal, Get_Location (Node)); -- Keep the compiler happy. raise Program_Error; end case; end Ada_IR_Info_Name; function Ada_Full_IR_Name (Node : Node_Id) return String is begin return Ada_IR_Info_Name (Node) & "." & Ada_IR_Name (Node); end Ada_Full_IR_Name; -------------------- -- Gen_Scope_Spec -- -------------------- procedure Gen_Node_Spec (CU : in out Compilation_Unit; Node : Node_Id) is begin case Kind (Node) is when K_Attribute => declare It : Node_Iterator; Decl_Node : Node_Id; begin Init (It, Declarators (Node)); while not Is_End (It) loop Get_Next_Node (It, Decl_Node); Gen_IR_Function_Prologue (CU, Decl_Node, For_Body => False); end loop; end; when K_Operation => if Original_Node (Node) /= No_Node then return; end if; Gen_IR_Function_Prologue (CU, Node, For_Body => False); when K_Interface | K_Module => Gen_IR_Function_Prologue (CU, Node, For_Body => False); when K_Enum => Gen_Enum_Spec (CU, Node); when K_Type_Declarator => if Original_Node (Node) /= No_Node then return; end if; if Kind (T_Type (Node)) /= K_Fixed then declare It : Node_Iterator; Decl_Node : Node_Id; begin Init (It, Declarators (Node)); while not Is_End (It) loop Get_Next_Node (It, Decl_Node); Gen_IR_Function_Prologue (CU, Decl_Node, For_Body => False); end loop; end; end if; when K_Struct => if not Is_Exception_Members (Node) then Gen_Struct_Exception_Spec (CU, Node); end if; when K_String_Instance => null; when K_Union => Gen_Union_Spec (CU, Node); -- when K_Sequence_Instance => -- Gen_Sequence_Spec (CU, Node); when K_ValueType => Gen_ValueType_Spec (CU, Node); when K_Exception => Gen_Struct_Exception_Spec (CU, Node); when others => null; end case; end Gen_Node_Spec; -------------------- -- Gen_Scope_Body -- -------------------- procedure Gen_Node_Body (CU : in out Compilation_Unit; Node : Node_Id) is begin case Kind (Node) is when K_Interface => Gen_Interface_Body (CU, Node); when K_Attribute => declare It : Node_Iterator; Decl_Node : Node_Id; begin Init (It, Declarators (Node)); while not Is_End (It) loop Get_Next_Node (It, Decl_Node); Gen_Attribute_Body (CU, Decl_Node); end loop; end; when K_Operation => if Original_Node (Node) /= No_Node then return; end if; Gen_Operation_Body (CU, Node); when K_Module => Gen_Module_Body (CU, Node); when K_Enum => Gen_Enum_Body (CU, Node); when K_Type_Declarator => if Original_Node (Node) /= No_Node then return; end if; if Kind (T_Type (Node)) /= K_Fixed then declare It : Node_Iterator; Decl_Node : Node_Id; begin Init (It, Declarators (Node)); while not Is_End (It) loop Get_Next_Node (It, Decl_Node); Gen_Type_Declarator_Body (CU, Decl_Node); end loop; end; end if; when K_Struct => if not Is_Exception_Members (Node) then Gen_Struct_Exception_Body (CU, Node); end if; when K_String_Instance => null; when K_Union => Gen_Union_Body (CU, Node); -- when K_Sequence_Instance => -- Gen_Sequence_Body (CU, Node); when K_ValueType => Gen_ValueType_Body (CU, Node); when K_Exception => Gen_Struct_Exception_Body (CU, Node); when others => null; end case; end Gen_Node_Body; ------------------------ -- Gen_Interface_Spec -- ------------------------ -- procedure Gen_Interface_Spec -- (CU : in out Compilation_Unit; -- Node : Node_Id) is -- begin -- Gen_IR_Function_Prologue (CU, Node, For_Body => False); -- end Gen_Interface_Spec; ------------------------ -- Gen_ValueType_Spec -- ------------------------ procedure Gen_ValueType_Spec (CU : in out Compilation_Unit; Node : Node_Id) is pragma Warnings (Off); pragma Unreferenced (CU, Node); pragma Warnings (On); begin null; end Gen_ValueType_Spec; ------------------------ -- Gen_ValueType_Body -- ------------------------ procedure Gen_ValueType_Body (CU : in out Compilation_Unit; Node : Node_Id) is pragma Warnings (Off); pragma Unreferenced (CU, Node); pragma Warnings (On); begin null; end Gen_ValueType_Body; ------------------------------ -- Gen_IR_Function_Prologue -- ------------------------------ procedure Gen_IR_Function_Prologue (CU : in out Compilation_Unit; Node : Node_Id; For_Body : Boolean) is Name : constant String := Ada_IR_Name (Node); begin NL (CU); if not For_Body then Add_With (CU, CRR & ".IRObject"); else PL (CU, "Cached_" & Name & " :"); PL (CU, " CORBA.Repository_Root.IRObject.Ref;"); NL (CU); end if; PL (CU, "function " & Name); Put (CU, " return CORBA.Repository_Root.IRObject.Ref"); if not For_Body then PL (CU, ";"); else NL (CU); PL (CU, "is"); II (CU); Gen_Parent_Container_Dcl (CU, Node); DI (CU); PL (CU, "begin"); II (CU); PL (CU, "if not CORBA.Repository_Root.IRObject.Is_Nil"); PL (CU, " (Cached_" & Name & ")"); PL (CU, "then"); II (CU); PL (CU, "return Cached_" & Name & ";"); DI (CU); PL (CU, "end if;"); NL (CU); Add_With (CU, "CORBA.Object"); Divert (CU, Registration); PL (CU, "declare"); II (CU); PL (CU, "Dummy : constant CORBA.Object.Ref'Class := " & Name & ";"); PL (CU, "pragma Unreferenced (Dummy);"); DI (CU); PL (CU, "begin"); II (CU); PL (CU, "null;"); DI (CU); PL (CU, "end;"); Divert (CU, Visible_Declarations); end if; end Gen_IR_Function_Prologue; ------------------------------------ -- Gen_Standard_Create_Parameters -- ------------------------------------ procedure Gen_Standard_Create_Parameters (CU : in out Compilation_Unit; Node : Node_Id) is begin begin PL (CU, "id => CORBA.To_CORBA_String"); PL (CU, " (" & Repository_Id_Name (Node) & "),"); exception when Constraint_Error => Error ("Repository Id failed for " & Name (Node), Fatal, Get_Location (Node)); end; PL (CU, "name => CORBA.To_CORBA_String"); PL (CU, " (""" & Name (Node) & """),"); PL (CU, "version => CORBA.Repository_Root.To_CORBA_String"); PL (CU, " (""" & Version (Node) & """),"); end Gen_Standard_Create_Parameters; ------------------------------ -- Gen_Parent_Container_Dcl -- ------------------------------ procedure Gen_Parent_Container_Dcl (CU : in out Compilation_Unit; Node : Node_Id) is PS_Node : constant Node_Id := Parent_Scope (Node); NK : constant Node_Kind := Kind (Node); PSNK : constant Node_Kind := Kind (PS_Node); begin Add_With (CU, CRR & ".Container.Helper"); Add_With (CU, CRR & ".IRObject.Helper"); PL (CU, "Container_Ref : " & "constant CORBA.Repository_Root.Container.Ref"); if NK = K_Sequence_Instance or else not (False or else PSNK = K_Interface or else PSNK = K_ValueType or else PSNK = K_Module) then PL (CU, " := " & CRR & ".Container.Helper.To_Ref (Get_IR_Root);"); else -- The PS_Node corresponds to a container in -- the IR sense. Add_With (CU, Ada_IR_Info_Name (PS_Node)); PL (CU, " := CORBA.Repository_Root.Container.Helper.To_Ref"); PL (CU, " (" & Ada_Full_IR_Name (PS_Node) & ");"); end if; end Gen_Parent_Container_Dcl; --------------------------------- -- Gen_Parent_Container_Lookup -- --------------------------------- procedure Gen_Parent_Container_Lookup (CU : in out Compilation_Unit; Node : Node_Id) is Cached_Name : constant String := "Cached_" & Ada_IR_Name (Node); begin PL (CU, Cached_Name & " :="); PL (CU, " CORBA.Repository_Root.IRObject.Helper.To_Ref"); PL (CU, " (CORBA.Repository_Root.Container.Lookup"); II (CU); PL (CU, "(Container_Ref,"); PL (CU, " CORBA.To_CORBA_String (""" & Name (Node) & """)));"); DI (CU); PL (CU, "if not CORBA.Repository_Root.IRObject.Is_Nil"); PL (CU, " (" & Cached_Name & ")"); PL (CU, "then"); II (CU); PL (CU, "return " & Cached_Name & ";"); DI (CU); PL (CU, "end if;"); end Gen_Parent_Container_Lookup; ------------------------ -- Gen_Interface_Body -- ------------------------ procedure Gen_Interface_Body (CU : in out Compilation_Unit; Node : Node_Id) is It : Node_Iterator; IRN : constant String := Ada_IR_Name (Node); begin Add_With (CU, CRR & ".InterfaceDef.Helper"); Gen_IR_Function_Prologue (CU, Node, For_Body => True); Gen_Parent_Container_Lookup (CU, Node); NL (CU); PL (CU, "declare"); II (CU); PL (CU, "Base_Ifs : InterfaceDefSeq;"); DI (CU); PL (CU, "begin"); II (CU); Init (It, Parents (Node)); while not Is_End (It) loop declare A_Node : Node_Id; begin Get_Next_Node (It, A_Node); Add_With (CU, Ada_IR_Info_Name (A_Node)); PL (CU, "CORBA.Repository_Root.Append"); PL (CU, " (Base_Ifs,"); II (CU); PL (CU, "InterfaceDef.Helper.To_Ref"); PL (CU, " (" & Ada_Full_IR_Name (A_Node) & ");"); DI (CU); end; end loop; PL (CU, "Cached_" & IRN); Add_With (CU, CRR & ".IRObject.Helper"); PL (CU, " := " & CRR & ".IRObject.Helper.To_Ref"); PL (CU, " (CORBA.Repository_Root." & "Container.Create_Interface"); PL (CU, " (Container_Ref,"); II (CU); PL (CU, "CORBA.To_CORBA_String"); PL (CU, " (" & Repository_Id_Name (Node) & "),"); PL (CU, "CORBA.To_CORBA_String"); PL (CU, " (""" & Name (Node) & """),"); PL (CU, "To_CORBA_String (""" & Version (Node) & """),"); PL (CU, "Base_Ifs,"); PL (CU, Boolean'Image (Abst (Node)) & "));"); DI (CU); NL (CU); PL (CU, "return Cached_" & IRN & ";"); DI (CU); PL (CU, "end;"); DI (CU); PL (CU, "end " & IRN & ";"); end Gen_Interface_Body; ------------------------ -- Gen_Operation_Body -- ------------------------ procedure Gen_Operation_Body (CU : in out Compilation_Unit; Node : Node_Id) is It : Node_Iterator; IRN : constant String := Ada_IR_Name (Node); OT_Node : constant Node_Id := Operation_Type (Node); begin Gen_IR_Function_Prologue (CU, Node, For_Body => True); Gen_Parent_Container_Lookup (CU, Node); NL (CU); PL (CU, "declare"); II (CU); PL (CU, "Params : ParDescriptionSeq;"); PL (CU, "Exceptions : ExceptionDefSeq;"); PL (CU, "Contexts : ContextIdSeq;"); DI (CU); PL (CU, "begin"); II (CU); Init (It, Parameters (Node)); while not Is_End (It) loop declare P_Node, T_Node : Node_Id; begin Get_Next_Node (It, P_Node); T_Node := Param_Type (P_Node); PL (CU, "CORBA.Repository_Root.Append"); PL (CU, " (Params,"); II (CU); PL (CU, "ParameterDescription'"); PL (CU, "(name => CORBA.To_CORBA_String (""" & Name (Declarator (P_Node)) & """),"); Add_With (CU, Ada_Helper_Unit_Name (Mapping, T_Node)); Add_With (CU, Ada_IR_Info_Name (T_Node)); PL (CU, " IDL_type =>"); II (CU); PL (CU, Ada_Full_TC_Name (T_Node) & ","); DI (CU); Add_With (CU, CRR & ".IDLType"); PL (CU, " type_def => " & "IDLType.Convert_Forward.To_Forward"); II (CU); Put (CU, "("); Gen_IDLType (CU, T_Node => T_Node, D_Node => Node); PL (CU, "),"); DI (CU); Put (CU, " mode => "); case Mode (P_Node) is when Mode_In => Put (CU, "PARAM_IN"); when Mode_Inout => Put (CU, "PARAM_INOUT"); when Mode_Out => Put (CU, "PARAM_OUT"); end case; PL (CU, "));"); DI (CU); end; end loop; -- XXX TODO! -- Init (It, Exceptions (Node)); -- while not Is_End (It) loop -- Next (It); -- end loop; Add_With (CU, CRR & ".InterfaceDef.Helper"); Add_With (CU, CRR & ".IRObject.Helper"); PL (CU, "Cached_" & IRN); PL (CU, " := " & CRR & ".IRObject.Helper.To_Ref"); PL (CU, " (" & CRR & ".InterfaceDef.Create_Operation"); PL (CU, " (" & CRR & ".InterfaceDef.Helper.To_Ref"); II (CU); PL (CU, "(Container_Ref),"); Gen_Standard_Create_Parameters (CU, Node); Add_With (CU, Ada_IR_Info_Name (OT_Node)); Add_With (CU, CRR & ".IDLType.Helper"); PL (CU, "result => IDLType.Helper.To_Ref"); PL (CU, " (" & Ada_Full_IR_Name (OT_Node) & "),"); Put (CU, "mode => "); if Is_Oneway (Node) then Put (CU, "OP_ONEWAY"); else Put (CU, "OP_NORMAL"); end if; PL (CU, ","); PL (CU, "params => Params,"); PL (CU, "exceptions => Exceptions,"); PL (CU, "contexts => Contexts));"); DI (CU); DI (CU); PL (CU, "end;"); PL (CU, "return Cached_" & IRN & ";"); DI (CU); PL (CU, "end " & IRN & ";"); end Gen_Operation_Body; ------------------------ -- Gen_Attribute_Body -- ------------------------ procedure Gen_Attribute_Body (CU : in out Compilation_Unit; Node : Node_Id) is IRN : constant String := Ada_IR_Name (Node); A_Node : constant Node_Id := Parent (Node); AT_Node : constant Node_Id := A_Type (A_Node); begin Gen_IR_Function_Prologue (CU, Node, For_Body => True); Gen_Parent_Container_Lookup (CU, Node); Add_With (CU, CRR & ".InterfaceDef.Helper"); Add_With (CU, CRR & ".IRObject.Helper"); PL (CU, "Cached_" & IRN); PL (CU, " := " & CRR & ".IRObject.Helper.To_Ref"); PL (CU, " (" & CRR & ".InterfaceDef.Create_Attribute"); PL (CU, " (" & CRR & ".InterfaceDef.Helper.To_Ref"); II (CU); PL (CU, "(Container_Ref),"); Gen_Standard_Create_Parameters (CU, Node); PL (CU, "IDL_type =>"); Gen_IDLType (CU, AT_Node, No_Node); PL (CU, ","); Put (CU, "mode => "); if Is_Readonly (A_Node) then Put (CU, "ATTR_READONLY"); else Put (CU, "ATTR_NORMAL"); end if; PL (CU, "));"); DI (CU); PL (CU, "return Cached_" & IRN & ";"); DI (CU); PL (CU, "end " & IRN & ";"); end Gen_Attribute_Body; ------------------------ -- Gen_Module_Body -- ------------------------ procedure Gen_Module_Body (CU : in out Compilation_Unit; Node : Node_Id) is IRN : constant String := Ada_IR_Name (Node); begin Gen_IR_Function_Prologue (CU, Node, For_Body => True); Gen_Parent_Container_Lookup (CU, Node); PL (CU, "Cached_" & IRN); Add_With (CU, CRR & ".IRObject.Helper"); PL (CU, " := " & CRR & ".IRObject.Helper.To_Ref"); PL (CU, " (" & CRR & ".Container.Create_Module"); PL (CU, " (Container_Ref,"); II (CU); PL (CU, "CORBA.To_CORBA_String"); PL (CU, " (" & Repository_Id_Name (Node) & "),"); PL (CU, "CORBA.To_CORBA_String"); PL (CU, " (""" & Name (Node) & """),"); PL (CU, "CORBA.Repository_Root.To_CORBA_String"); PL (CU, " (""" & Version (Node) & """)));"); DI (CU); NL (CU); PL (CU, "return Cached_" & IRN & ";"); DI (CU); PL (CU, "end " & IRN & ";"); end Gen_Module_Body; ------------------- -- Gen_Enum_Spec -- ------------------- procedure Gen_Enum_Spec (CU : in out Compilation_Unit; Node : Node_Id) is begin Gen_IR_Function_Prologue (CU, Node, For_Body => False); end Gen_Enum_Spec; ------------------- -- Gen_Enum_body -- ------------------- procedure Gen_Enum_Body (CU : in out Compilation_Unit; Node : Node_Id) is It : Node_Iterator; IRN : constant String := Ada_IR_Name (Node); begin Gen_IR_Function_Prologue (CU, Node, For_Body => True); Gen_Parent_Container_Lookup (CU, Node); NL (CU); PL (CU, "declare"); II (CU); PL (CU, "Members : EnumMemberSeq;"); DI (CU); PL (CU, "begin"); II (CU); Init (It, Enumerators (Node)); while not Is_End (It) loop declare E_Node : Node_Id; begin Get_Next_Node (It, E_Node); PL (CU, "CORBA.Repository_Root.Append"); PL (CU, " (Members,"); II (CU); PL (CU, "CORBA.To_CORBA_String (""" & Name (E_Node) & """));"); DI (CU); end; end loop; PL (CU, "Cached_" & IRN); Add_With (CU, CRR & ".IRObject.Helper"); PL (CU, " := " & CRR & ".IRObject.Helper.To_Ref"); PL (CU, " (CORBA.Repository_Root.Container.Create_Enum"); PL (CU, " (Container_Ref,"); II (CU); PL (CU, "CORBA.To_CORBA_String"); PL (CU, " (" & Repository_Id_Name (Node) & "),"); PL (CU, "CORBA.To_CORBA_String"); PL (CU, " (""" & Name (Node) & """),"); PL (CU, "CORBA.Repository_Root.To_CORBA_String"); PL (CU, " (""" & Version (Node) & """),"); PL (CU, "Members));"); DI (CU); DI (CU); PL (CU, "end;"); NL (CU); PL (CU, "return Cached_" & IRN & ";"); DI (CU); PL (CU, "end " & IRN & ";"); end Gen_Enum_Body; ------------------------------- -- Gen_Struct_Exception_Spec -- ------------------------------- procedure Gen_Struct_Exception_Spec (CU : in out Compilation_Unit; Node : Node_Id) is begin Gen_IR_Function_Prologue (CU, Node, For_Body => False); end Gen_Struct_Exception_Spec; ------------------------------- -- Gen_Struct_Exception_Body -- ------------------------------- procedure Gen_Struct_Exception_Body (CU : in out Compilation_Unit; Node : Node_Id) is It, It2 : Node_Iterator; IRN : constant String := Ada_IR_Name (Node); begin Gen_IR_Function_Prologue (CU, Node, For_Body => True); Gen_Parent_Container_Lookup (CU, Node); NL (CU); PL (CU, "declare"); II (CU); PL (CU, "Members : StructMemberSeq;"); DI (CU); PL (CU, "begin"); II (CU); Init (It, Members (Node)); while not Is_End (It) loop declare M_Node, T_Node : Node_Id; begin Get_Next_Node (It, M_Node); T_Node := M_Type (M_Node); Add_With (CU, Ada_Helper_Unit_Name (Mapping, T_Node)); Init (It2, Decl (M_Node)); while not Is_End (It2) loop declare D_Node : Node_Id; begin Get_Next_Node (It2, D_Node); PL (CU, "CORBA.Repository_Root.Append"); PL (CU, " (Members,"); II (CU); PL (CU, "StructMember'"); PL (CU, "(name => CORBA.To_CORBA_String (""" & Name (D_Node) & """),"); PL (CU, " IDL_type =>"); II (CU); PL (CU, Ada_Full_TC_Name (T_Node) & ","); DI (CU); Add_With (CU, CRR & ".IDLType"); PL (CU, " type_def => " & "IDLType.Convert_Forward.To_Forward"); II (CU); Put (CU, "("); Gen_IDLType (CU, T_Node => T_Node, D_Node => D_Node); PL (CU, ")));"); DI (CU); DI (CU); end; end loop; end; end loop; Add_With (CU, CRR & ".IRObject.Helper"); PL (CU, "Cached_" & IRN); PL (CU, " := " & CRR & ".IRObject.Helper.To_Ref"); if Is_Struct (Node) then PL (CU, " (" & CRR & ".Container.Create_Struct"); else PL (CU, " (" & CRR & ".Container.Create_Exception"); end if; II (CU); PL (CU, "(Container_Ref,"); Gen_Standard_Create_Parameters (CU, Node); PL (CU, "members => Members));"); DI (CU); DI (CU); PL (CU, "end;"); PL (CU, "return Cached_" & IRN & ";"); DI (CU); PL (CU, "end " & IRN & ";"); end Gen_Struct_Exception_Body; -------------------- -- Gen_Union_Spec -- -------------------- procedure Gen_Union_Spec (CU : in out Compilation_Unit; Node : Node_Id) is begin Gen_IR_Function_Prologue (CU, Node, For_Body => False); end Gen_Union_Spec; -------------------- -- Gen_Union_Body -- -------------------- procedure Gen_Union_Body (CU : in out Compilation_Unit; Node : Node_Id) is IRN : constant String := Ada_IR_Name (Node); It, It2 : Node_Iterator; Case_Index : Long_Integer := -1; ST_Node : constant Node_Id := Switch_Type (Node); ST_Helper : constant String := Ada_Helper_Unit_Name (Mapping, ST_Node); begin Gen_IR_Function_Prologue (CU, Node, For_Body => True); Gen_Parent_Container_Lookup (CU, Node); NL (CU); PL (CU, "declare"); II (CU); PL (CU, "Members : UnionMemberSeq;"); DI (CU); PL (CU, "begin"); II (CU); Add_With (CU, ST_Helper); Add_With (CU, CRR & ".IDLType"); Add_With (CU, CRR & ".IDLType.Helper"); Init (It, Cases (Node)); while not Is_End (It) loop declare M_Node, T_Node : Node_Id; begin Case_Index := Case_Index + 1; Get_Next_Node (It, M_Node); T_Node := Case_Type (M_Node); Init (It2, Labels (M_Node)); while not Is_End (It2) loop declare L_Node : Node_Id; begin Get_Next_Node (It2, L_Node); PL (CU, "CORBA.Repository_Root.Append"); PL (CU, " (Members,"); II (CU); PL (CU, "UnionMember'"); PL (CU, "(name => CORBA.To_CORBA_String (""" & Name (Case_Decl (M_Node)) & """),"); Put (CU, " label => "); if Case_Index = Default_Index (Node) then PL (CU, "CORBA.To_Any (CORBA.Octet'(0)),"); else PL (CU, ST_Helper & ".To_Any"); II (CU); Put (CU, "("); Gen_Node_Stubs_Spec (CU, ST_Node); Put (CU, "'("); Gen_Constant_Value (CU, Expr => L_Node, Typ => ST_Node); PL (CU, ")),"); DI (CU); end if; PL (CU, " IDL_type =>"); II (CU); PL (CU, Ada_Full_TC_Name (T_Node) & ","); DI (CU); PL (CU, " type_def =>"); II (CU); PL (CU, "IDLType.Convert_Forward.To_Forward"); PL (CU, " (IDLType.Helper.To_Ref"); II (CU); Put (CU, "("); II (CU); Gen_IDLType (CU, T_Node, Case_Decl (M_Node)); PL (CU, "))));"); DI (CU); DI (CU); DI (CU); DI (CU); end; end loop; end; end loop; Add_With (CU, CRR & ".IRObject.Helper"); PL (CU, "Cached_" & IRN); PL (CU, " := " & CRR & ".IRObject.Helper.To_Ref"); PL (CU, " (" & CRR & ".Container.Create_Union"); II (CU); PL (CU, "(Container_Ref,"); Gen_Standard_Create_Parameters (CU, Node); Add_With (CU, CRR & ".IDLType"); Add_With (CU, CRR & ".IDLType.Helper"); PL (CU, "discriminator_type => " & "IDLType.Convert_Forward.To_Forward"); PL (CU, " (IDLType.Helper.To_Ref"); II (CU); PL (CU, "(" & Ada_Full_IR_Name (ST_Node) & ")),"); DI (CU); PL (CU, "members => Members));"); DI (CU); DI (CU); PL (CU, "end;"); PL (CU, "return Cached_" & IRN & ";"); DI (CU); PL (CU, "end " & IRN & ";"); end Gen_Union_Body; ----------------- -- Gen_IDLType -- ----------------- procedure Gen_IDLType (CU : in out Compilation_Unit; T_Node : Node_Id; D_Node : Node_Id) is function Get_Original (Node : Node_Id) return Node_Id; function Get_Original (Node : Node_Id) return Node_Id is O_Node : Node_Id; begin if Node /= No_Node then O_Node := Original_Node (Node); end if; if O_Node /= No_Node then return O_Node; end if; return Node; end Get_Original; OT_Node : constant Node_Id := Get_Original (T_Node); OD_Node : Node_Id; Is_Array : Boolean; begin if T_Node /= OT_Node and then Kind (T_Node) = K_Scoped_Name then OD_Node := Value (T_Node); else OD_Node := D_Node; end if; Is_Array := OD_Node /= No_Node and then Kind (OD_Node) = K_Declarator and then Length (Array_Bounds (OD_Node)) > 0; -- OD_Node may also be a K_Sequence_Instance. if Is_Array then Gen_Array_IR (CU, Element_Type_Node => OT_Node, Decl_Node => OD_Node); else case Kind (OT_Node) is when K_Fixed => Gen_Fixed_IR (CU, OT_Node); when K_Sequence => Gen_Sequence_IR (CU, OT_Node); when others => Add_With (CU, Ada_IR_Info_Name (T_Node)); PL (CU, "IDLType.Helper.To_Ref"); Put (CU, "(" & Ada_Full_IR_Name (T_Node) & ")"); end case; end if; end Gen_IDLType; ------------------------------ -- Gen_Type_Declarator_Body -- ------------------------------ procedure Gen_Type_Declarator_Body (CU : in out Compilation_Unit; Node : Node_Id) is T_Node : constant Node_Id := T_Type (Parent (Node)); IRN : constant String := Ada_IR_Name (Node); begin Add_With (CU, CRR & ".IRObject.Helper"); Gen_IR_Function_Prologue (CU, Node, For_Body => True); Gen_Parent_Container_Lookup (CU, Node); NL (CU); PL (CU, "Cached_" & IRN); PL (CU, " := " & CRR & ".IRObject.Helper.To_Ref"); PL (CU, " (" & CRR & ".Container.Create_Alias"); II (CU); PL (CU, "(Container_Ref,"); Gen_Standard_Create_Parameters (CU, Node); Add_With (CU, CRR & ".IDLType"); Add_With (CU, CRR & ".IDLType.Helper"); PL (CU, "original_type => " & "IDLType.Convert_Forward.To_Forward"); Put (CU, " ("); II (CU); Gen_IDLType (CU, T_Node => T_Node, D_Node => Node); PL (CU, ")));"); DI (CU); DI (CU); PL (CU, "return Cached_" & IRN & ";"); DI (CU); PL (CU, "end " & IRN & ";"); end Gen_Type_Declarator_Body; -- ----------------------- -- -- Gen_Sequence_Spec -- -- ----------------------- -- procedure Gen_Sequence_Spec -- (CU : in out Compilation_Unit; -- Node : Node_Id) is -- begin -- Gen_IR_Function_Prologue (CU, Node, For_Body => False); -- end Gen_Sequence_Spec; -- ----------------------- -- -- Gen_Sequence_Body -- -- ----------------------- -- procedure Gen_Sequence_Body -- (CU : in out Compilation_Unit; -- Node : Node_Id) -- is -- S_Node : constant Node_Id := Sequence (Node); -- ET_Node : constant Node_Id := Sequence_Type (S_Node); -- B_Node : constant Node_Id := Bound (S_Node); -- IRN : constant String := Ada_IR_Name (Node); -- begin -- Add_With (CU, CRR & ".IRObject.Helper"); -- Add_With (CU, CRR & ".Repository"); -- Add_With (CU, CRR & ".Repository.Helper"); -- Gen_IR_Function_Prologue (CU, Node, For_Body => True); -- Gen_Parent_Container_Lookup (CU, Node); -- NL (CU); -- PL (CU, "Cached_" & IRN); -- PL (CU, " := " & CRR & ".IRObject.Helper.To_Ref"); -- PL (CU, " (" & CRR & ".Repository.Create_Sequence"); -- II (CU); -- PL (CU, "(" & CRR & ".Repository.Helper.To_Ref (Container_Ref),"); -- Put (CU, " bound => "); -- if B_Node = No_Node then -- Put (CU, "0"); -- else -- Gen_Constant_Value (CU, B_Node); -- end if; -- PL (CU, ","); -- Add_With (CU, Ada_IR_Info_Name (ET_Node)); -- Add_With (CU, CRR & ".IDLType"); -- Add_With (CU, CRR & ".IDLType.Helper"); -- PL (CU, "element_type => IDLType.Helper.To_Ref"); -- PL (CU, " (" & Ada_Full_IR_Name (ET_Node) & ")));"); -- DI (CU); -- PL (CU, "return Cached_" & IRN & ";"); -- DI (CU); -- PL (CU, "end " & IRN & ";"); -- end Gen_Sequence_Body; ------------------ -- Gen_Array_IR -- ------------------ procedure Gen_Array_IR (CU : in out Compilation_Unit; Element_Type_Node : Node_Id; Decl_Node : Node_Id) is procedure Rec_Gen_Array_IR (CU : in out Compilation_Unit; It : in out Node_Iterator; Element_Type_Node : Node_Id; Decl_Node : Node_Id); procedure Rec_Gen_Array_IR (CU : in out Compilation_Unit; It : in out Node_Iterator; Element_Type_Node : Node_Id; Decl_Node : Node_Id) is Bound_Node : Node_Id; begin Get_Next_Node (It, Bound_Node); PL (CU, CRR & ".IDLType.Helper.To_Ref"); PL (CU, " (Repository.Create_Array"); II (CU); PL (CU, "(Get_IR_Root,"); II (CU); Put (CU, " Length => "); Gen_Constant_Value (CU, Expr => Bound_Node, Typ => No_Node); PL (CU, ","); Put (CU, " element_type => "); if not Is_End (It) then Rec_Gen_Array_IR (CU, It, Element_Type_Node, Decl_Node); else Add_With (CU, Ada_IR_Info_Name (Element_Type_Node)); PL (CU, "IDLType.Helper.To_Ref"); II (CU); Put (CU, "(" & Ada_Full_IR_Name (Element_Type_Node) & ")"); DI (CU); end if; DI (CU); DI (CU); PL (CU, "))"); end Rec_Gen_Array_IR; Bounds_It : Node_Iterator; begin Init (Bounds_It, Array_Bounds (Decl_Node)); Add_With (CU, CRR & ".IDLType.Helper"); Rec_Gen_Array_IR (CU, Bounds_It, Element_Type_Node, Decl_Node); end Gen_Array_IR; ------------------ -- Gen_Fixed_IR -- ------------------ procedure Gen_Fixed_IR (CU : in out Compilation_Unit; Node : Node_Id) is begin PL (CU, CRR & ".IDLType.Helper.To_Ref"); PL (CU, " (Repository.Create_Fixed"); II (CU); PL (CU, "(Get_IR_Root,"); II (CU); Put (CU, " IDL_digits => "); Gen_Constant_Value (CU, Expr => Digits_Nb (Node), Typ => No_Node); PL (CU, ","); Put (CU, " scale => "); Gen_Constant_Value (CU, Expr => Scale (Node), Typ => No_Node); Put (CU, "))"); DI (CU); DI (CU); end Gen_Fixed_IR; --------------------- -- Gen_Sequence_IR -- --------------------- procedure Gen_Sequence_IR (CU : in out Compilation_Unit; Node : Node_Id) is ET_Node : constant Node_Id := Sequence_Type (Node); B_Node : constant Node_Id := Bound (Node); begin Add_With (CU, CRR & ".IDLType.Helper"); Add_With (CU, CRR & ".Repository"); PL (CU, CRR & ".IDLType.Helper.To_Ref"); PL (CU, " (" & CRR & ".Repository.Create_Sequence"); II (CU); PL (CU, "(Get_IR_Root,"); Put (CU, " bound => "); if B_Node = No_Node then Put (CU, "0"); else Gen_Constant_Value (CU, Expr => B_Node, Typ => No_Node); end if; PL (CU, ","); Put (CU, "element_type => "); Gen_IDLType (CU, T_Node => ET_Node, D_Node => No_Node); Put (CU, "))"); DI (CU); end Gen_Sequence_IR; ---------------------- -- Gen_Spec_Prelude -- ---------------------- procedure Gen_Spec_Prelude (CU : in out Compilation_Unit) is begin Set_Template_Mode (CU, True); NL (CU); PL (CU, "procedure Register_IR_Info;"); Set_Template_Mode (CU, False); end Gen_Spec_Prelude; ---------------------- -- Gen_Body_Prelude -- ---------------------- procedure Gen_Body_Prelude (CU : in out Compilation_Unit) is begin Set_Template_Mode (CU, True); Add_With (CU, CRR, Use_It => True); Add_With (CU, "PolyORB.CORBA_P.IR_Tools", Use_It => True); NL (CU); Divert (CU, Registration); NL (CU); PL (CU, "procedure Register_IR_Info is"); PL (CU, "begin"); II (CU); PL (CU, "null;"); Divert (CU, Visible_Declarations); Set_Template_Mode (CU, False); end Gen_Body_Prelude; ----------------------- -- Gen_Body_Postlude -- ----------------------- procedure Gen_Body_Postlude (CU : in out Compilation_Unit) is begin Set_Template_Mode (CU, True); Divert (CU, Registration); DI (CU); PL (CU, "end Register_IR_Info;"); Divert (CU, Visible_Declarations); Undivert (CU, Registration); Set_Template_Mode (CU, False); end Gen_Body_Postlude; end Ada_Be.Idl2Ada.IR_Info; polyorb-2.8~20110207.orig/compilers/idlac/idl_fe-tree-synthetic.adb0000644000175000017500000004474111750740337024332 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- I D L _ F E . T R E E . S Y N T H E T I C -- -- -- -- B o d y -- -- -- -- Copyright (C) 2001-2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with Ada.Text_IO; with Idl_Fe.Tree; use Idl_Fe.Tree; with Idl_Fe.Display_Tree; with Idl_Fe.Debug; pragma Elaborate_All (Idl_Fe.Debug); with Idlac_Errors; use Idlac_Errors; package body Idl_Fe.Tree.Synthetic is ----------- -- Debug -- ----------- Flag : constant Natural := Idl_Fe.Debug.Is_Active ("idl_fe.tree.synthetic"); procedure O is new Idl_Fe.Debug.Output (Flag); ------------------- -- All_Ancestors -- ------------------- function All_Ancestors (Node : Node_Id; Exclude : Node_List := Nil_List) return Node_List is It : Node_Iterator; I_Node : Node_Id; -- A scoped name in the inheritance spec. P_Node : Node_Id; -- The corresponding actual parent node. Result : Node_List := Nil_List; begin Init (It, Parents (Node)); while not Is_End (It) loop Get_Next_Node (It, I_Node); P_Node := Value (I_Node); if not (False or else Is_In_List (Exclude, P_Node) or else Is_In_List (Result, P_Node)) then Append_Node (Result, P_Node); Merge_List (Into => Result, From => All_Ancestors (P_Node)); end if; end loop; return Result; end All_Ancestors; ------------------- -- Boolean_Value -- ------------------- function Boolean_Value (Node : Node_Id) return Boolean is begin return Expr_Value (Node).Boolean_Value; end Boolean_Value; --------------------- -- Character_Value -- --------------------- function Character_Value (Node : Node_Id) return Character is begin return Character (Expr_Value (Node).Char_Value); end Character_Value; --------------------------- -- Default_Repository_Id -- --------------------------- function Default_Repository_Id (Node : Node_Id) return String is P_Node : constant Node_Id := Parent_Scope (Node); begin if P_Node /= No_Node then if Kind (P_Node) = K_Repository then return Name (Node); else return Default_Repository_Id (Parent_Scope (Node)) & "/" & Name (Node); end if; else return Name (Node); end if; end Default_Repository_Id; ---------------- -- Enum_Value -- ---------------- function Enum_Value (Node : Node_Id) return Node_Id is begin return Expr_Value (Node).Enum_Value; end Enum_Value; ----------------- -- Float_Value -- ----------------- function Float_Value (Node : Node_Id) return Idl_Float is begin return Expr_Value (Node).Float_Value; end Float_Value; ----------------------------- -- Has_Interface_Component -- ----------------------------- function Has_Interface_Component (Node : Node_Id; I_Node : Node_Id) return Boolean is begin pragma Assert (Kind (I_Node) = K_Interface); case Kind (Node) is when K_Void | K_Float | K_Double | K_Long_Double | K_Short | K_Long | K_Long_Long | K_Unsigned_Short | K_Unsigned_Long | K_Unsigned_Long_Long | K_Char | K_Wide_Char | K_Boolean | K_Octet | K_Any | K_Object | K_Enum | K_ValueType | K_Forward_ValueType | K_Boxed_ValueType | K_String | K_Wide_String | K_Fixed | K_Forward_Interface | K_Sequence_Instance | K_Sequence => return False; when K_Interface => return Node = I_Node; when K_Struct | K_Exception => declare Iter : Node_Iterator; Member : Node_Id; begin Init (Iter, Members (Node)); while not Is_End (Iter) loop Get_Next_Node (Iter, Member); if Has_Interface_Component (M_Type (Member), I_Node) then return True; end if; end loop; return False; end; when K_Union => declare Iter : Node_Iterator; Case_Node : Node_Id; begin Init (Iter, Cases (Node)); while not Is_End (Iter) loop Get_Next_Node (Iter, Case_Node); if Has_Interface_Component (Case_Type (Case_Node), I_Node) then return True; end if; end loop; return False; end; when K_Scoped_Name => return Has_Interface_Component (Value (Node), I_Node); when K_Declarator => return Has_Interface_Component (Parent (Node), I_Node); when K_Type_Declarator => return Has_Interface_Component (T_Type (Node), I_Node); when others => Ada.Text_IO.Put_Line (Node_Kind'Image (Kind (Node))); Display_Tree.Disp_Tree (Node); raise Program_Error; return False; end case; end Has_Interface_Component; ------------------------- -- Has_Local_Component -- ------------------------- function Has_Local_Component (Node : Node_Id) return Boolean is begin case Kind (Node) is when K_Void | K_Float | K_Double | K_Long_Double | K_Short | K_Long | K_Long_Long | K_Unsigned_Short | K_Unsigned_Long | K_Unsigned_Long_Long | K_Char | K_Wide_Char | K_Boolean | K_Octet | K_Any | K_Object | K_Enum | K_ValueType | K_Forward_ValueType | K_Boxed_ValueType | K_String | K_String_Instance | K_Wide_String | K_Fixed => return False; when K_Interface | K_Forward_Interface => return Local (Node); when K_Struct | K_Exception => declare Iter : Node_Iterator; Member : Node_Id; begin Init (Iter, Members (Node)); while not Is_End (Iter) loop Get_Next_Node (Iter, Member); if Has_Local_Component (M_Type (Member)) then return True; end if; end loop; return False; end; when K_Union => declare Iter : Node_Iterator; Case_Node : Node_Id; begin Init (Iter, Cases (Node)); while not Is_End (Iter) loop Get_Next_Node (Iter, Case_Node); if Has_Local_Component (Case_Type (Case_Node)) then return True; end if; end loop; return False; end; when K_Scoped_Name => return Has_Local_Component (Value (Node)); when K_Declarator => return Has_Local_Component (Parent (Node)); when K_Type_Declarator => return Has_Local_Component (T_Type (Node)); when K_Sequence_Instance => return Has_Local_Component (Sequence (Node)); when K_Sequence => return Has_Local_Component (Sequence_Type (Node)); when others => Ada.Text_IO.Put_Line (Node_Kind'Image (Kind (Node))); Display_Tree.Disp_Tree (Node); raise Program_Error; return False; end case; end Has_Local_Component; ----------------------- -- Idl_Repository_Id -- ----------------------- function Idl_Repository_Id (Node : Node_Id) return String is Repository_Id_Node : constant Node_Id := Repository_Id (Node); begin -- XXX pragma Assert (Repository_Id_Node /= No_Node); -- Not verified with current version of CIAO. if Repository_Id_Node = No_Node then return ""; end if; return String_Value (Repository_Id_Node); end Idl_Repository_Id; ------------------- -- Integer_Value -- ------------------- function Integer_Value (Node : Node_Id) return Idl_Integer is begin return Expr_Value (Node).Integer_Value; end Integer_Value; ------------------ -- Is_Gen_Scope -- ------------------ function Is_Gen_Scope (Node : Node_Id) return Boolean is K : constant Node_Kind := Kind (Node); begin return (False or else K = K_Repository or else K = K_Ben_Idl_File or else K = K_Module or else K = K_Interface or else K = K_ValueType); end Is_Gen_Scope; ----------------------- -- Is_Interface_Type -- ----------------------- function Is_Interface_Type (Node : Node_Id; Or_ValueType : Boolean := False) return Boolean is begin pragma Debug (O ("Is_Interface_Type: enter, dealing with a " & Node_Kind'Image (Kind (Node)))); case Kind (Node) is when K_Interface | K_Forward_Interface => return True; when K_ValueType | K_Forward_ValueType => return Or_ValueType; when K_Scoped_Name => return Is_Interface_Type (S_Type (Node)); when K_Declarator => declare P_Node : constant Node_Id := Parent (Node); begin pragma Assert (Is_Type_Declarator (P_Node)); return Is_Empty (Array_Bounds (Node)) and then Is_Interface_Type (T_Type (P_Node)); end; when others => return False; end case; end Is_Interface_Type; ---------- -- Name -- ---------- function Name (Node : Node_Id) return String is begin if Definition (Node) /= null then return Definition (Node).Name.all; elsif True and then (Kind (Node) = K_Forward_Interface or else Kind (Node) = K_Forward_ValueType) and then Forward (Node) /= No_Node then return Name (Forward (Node)); else return "##null##"; end if; end Name; ----------------------------- -- Original_Operation_Type -- ----------------------------- function Original_Operation_Type (Node : Node_Id) return Node_Id is OT_Node : constant Node_Id := Operation_Type (Node); Original_OT_Node : constant Node_Id := Original_Node (OT_Node); begin if Original_OT_Node /= No_Node then return Original_OT_Node; else return OT_Node; end if; end Original_Operation_Type; --------------------------- -- Original_Parent_Scope -- --------------------------- function Original_Parent_Scope (Node : Node_Id) return Node_Id is begin if Definition (Node) /= null then return Definition (Node).Parent_Scope; elsif (Kind (Node) = K_Forward_Interface or else Kind (Node) = K_Forward_ValueType) and then Forward (Node) /= No_Node then return Original_Parent_Scope (Forward (Node)); else return No_Node; end if; end Original_Parent_Scope; ------------------ -- Parent_Scope -- ------------------ function Parent_Scope (Node : Node_Id) return Node_Id is Override : constant Node_Id := Parent_Scope_Override (Node); begin if Override /= No_Node then return Override; else return Original_Parent_Scope (Node); end if; end Parent_Scope; -------------------- -- Primary_Parent -- -------------------- function Primary_Parent (Node : Node_Id) return Node_Id is It : Node_Iterator; Candidate : Node_Id; begin pragma Assert ((Kind (Node) = K_Interface) or else (Kind (Node) = K_ValueType)); Init (It, Parents (Node)); while not Is_End (It) loop Get_Next_Node (It, Candidate); if not Abst (Value (Candidate)) then return Candidate; end if; end loop; return No_Node; end Primary_Parent; --------------- -- Root_Type -- --------------- function Root_Type (Typ : Node_Id) return Node_Id is Root_Typ : Node_Id; begin Root_Typ := Typ; -- Unwind typedefs and scoped names loop case Kind (Root_Typ) is when K_Scoped_Name => Root_Typ := Value (Root_Typ); when K_Declarator => if Length (Array_Bounds (Root_Typ)) > 0 or else Kind (T_Type (Parent (Root_Typ))) = K_Fixed then exit; end if; Root_Typ := T_Type (Parent (Root_Typ)); when others => exit; end case; end loop; return Root_Typ; end Root_Type; ------------ -- S_Type -- ------------ function S_Type (Node : Node_Id) return Node_Id is Typ : Node_Id := Value (Node); begin if Kind (Typ) = K_Declarator then -- For a typedef, go back to the original type if Kind (Parent (Typ)) = K_Type_Declarator then pragma Debug (O ("S_Type: the name is defined in a typedef")); if not Is_Empty (Array_Bounds (Typ)) then return Typ; end if; Typ := T_Type (Parent (Typ)); if Kind (Typ) = K_Scoped_Name then return S_Type (Typ); else return Typ; end if; elsif Kind (Parent (Typ)) = K_Native then return Parent (Typ); end if; elsif Kind (Typ) = K_Struct or else Kind (Typ) = K_Union or else Kind (Typ) = K_Enum or else Kind (Typ) = K_Interface or else Kind (Typ) = K_ValueType or else Kind (Typ) = K_Forward_Interface or else Kind (Typ) = K_Boxed_ValueType or else Kind (Typ) = K_Forward_ValueType or else Kind (Typ) = K_Sequence_Instance or else Kind (Typ) = K_String_Instance then return Typ; end if; Error ("Scoped name does not denote a type", Fatal, Get_Location (Node)); -- Not reached return No_Node; end S_Type; ---------------------- -- Set_Parent_Scope -- ---------------------- procedure Set_Parent_Scope (Node : Node_Id; To : Node_Id) is begin Set_Parent_Scope_Override (Node, To); end Set_Parent_Scope; ---------------------- -- Set_String_Value -- ---------------------- procedure Set_String_Value (Node : Node_Id; Val : String) is begin Set_Expr_Value (Node, new Constant_Value (Kind => C_String)); Expr_Value (Node).String_Value := new String'(Val); end Set_String_Value; ------------------ -- String_Value -- ------------------ function String_Value (Node : Node_Id) return String is begin return Expr_Value (Node).String_Value.all; end String_Value; ------------------------------------- -- Supports_Non_Abstract_Interface -- ------------------------------------- function Supports_Non_Abstract_Interface (Node : Node_Id) return Boolean is It : Node_Iterator; Current : Node_Id; begin pragma Assert (Kind (Node) = K_ValueType); Init (It, Supports (Node)); while not Is_End (It) loop Get_Next_Node (It, Current); -- we get a K_Scoped_Name that we must transform into K_Interface if not Abst (Value (Current)) then return True; end if; end loop; return False; end Supports_Non_Abstract_Interface; ------------- -- Version -- ------------- function Version (Node : Node_Id) return String is Id : constant String := Idl_Repository_Id (Node); Colon : Integer := Id'Last; begin while Colon >= Id'First and then Id (Colon) /= ':' loop Colon := Colon - 1; end loop; if Colon < Id'First then Error ("Cannot determine version, rid=«" & Id & "»", Fatal, Get_Location (Node)); end if; return Id (Colon + 1 .. Id'Last); end Version; ------------------- -- WString_Value -- ------------------- function WString_Value (Node : Node_Id) return Wide_String is begin return Expr_Value (Node).WString_Value.all; end WString_Value; end Idl_Fe.Tree.Synthetic; polyorb-2.8~20110207.orig/compilers/idlac/idl_fe-files.adb0000644000175000017500000002201311750740337022451 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- I D L _ F E . F I L E S -- -- -- -- B o d y -- -- -- -- Copyright (C) 2004-2008, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with Ada.Command_Line; with Ada.Strings.Fixed; with Ada.Strings.Maps; with GNAT.Command_Line; with GNAT.Directory_Operations; with GNAT.OS_Lib; with GNAT.Table; with Idlac_Errors; with Platform; with Utils; package body Idl_Fe.Files is use GNAT.Directory_Operations; use GNAT.OS_Lib; IDL_File_Suffix : constant String := ".idl"; package Search_Path is new GNAT.Table (Table_Component_Type => String_Access, Table_Index_Type => Natural, Table_Low_Bound => Natural'First + 1, Table_Initial => 10, Table_Increment => 100); -- Search paths are stored in table with directory separator at -- the end. --------------------- -- Add_Search_Path -- --------------------- procedure Add_Search_Path (Path : String; Success : out Boolean) is begin if Is_Directory (Path) then if Utils.Is_Dir_Separator (Path (Path'Last)) then Search_Path.Append (new String'(Path)); else Search_Path.Append (new String'(Path & Dir_Separator)); end if; Success := True; else Success := False; end if; end Add_Search_Path; --------------------- -- Locate_IDL_File -- --------------------- function Locate_IDL_File (File_Name : String) return String is use Ada.Strings; use Ada.Strings.Fixed; use Ada.Strings.Maps; Separator : Natural; begin -- If file doesn't have IDL file extension then add it. if File_Extension (File_Name) /= IDL_File_Suffix then return Locate_IDL_File (File_Name & IDL_File_Suffix); end if; -- If File_Name has directory prefix then check file existence -- and return File_Name as result. Separator := Index (File_Name, To_Set (Dir_Separator & "/"), Inside, Backward); if Separator /= 0 then -- Directory prefix present: check file existence if Is_Regular_File (File_Name) then return File_Name; else return ""; end if; end if; -- Check in the current working directory if Is_Regular_File (File_Name) then return File_Name; end if; for J in Search_Path.First .. Search_Path.Last loop declare Full_Path : constant String := Search_Path.Table (J).all & File_Name; begin if Is_Regular_File (Full_Path) then return Full_Path; end if; end; end loop; return ""; end Locate_IDL_File; ------------------------------ -- Locate_IDL_Specification -- ------------------------------ function Locate_IDL_Specification (Scoped_Name : String) return String is begin if Scoped_Name = "CORBA" then -- CORBA specification actually stored in orb.idl file -- for historical reasons. return Locate_IDL_File ("orb.idl"); else return Locate_IDL_File (Scoped_Name & IDL_File_Suffix); end if; end Locate_IDL_Specification; --------------------- -- Preprocess_File -- --------------------- function Preprocess_File (File_Name : String) return String is use Ada.Command_Line; use GNAT.Command_Line; CPP_Arg_List : constant Argument_List_Access := Argument_String_To_List (Platform.IDL_Preprocessor); Tmp_File_Name_NUL : Temp_File_Name; -- Name of the temporary file to which preprocessor output -- is sent (NUL-terminated). Tmp_File_Name : String_Access; Args : Argument_List (1 .. 128); Arg_Count : Natural := Args'First - 1; -- Arguments to be passed to the preprocessor procedure Add_Argument (Arg : String); -- Increment Arg_Count and set Args (Arg_Count) to Arg ------------------ -- Add_Argument -- ------------------ procedure Add_Argument (Arg : String) is begin Arg_Count := Arg_Count + 1; Args (Arg_Count) := new String'(Arg); end Add_Argument; begin -- Create temporary file. declare Fd : File_Descriptor; begin Create_Temp_File (Fd, Tmp_File_Name_NUL); if Fd = Invalid_FD then Idlac_Errors.Error (Base_Name (Command_Name) & ": cannot create temporary file name", Idlac_Errors.Fatal, Idlac_Errors.No_Location); return ""; end if; -- We don't need the file descriptor Close (Fd); Tmp_File_Name := new String'( Tmp_File_Name_NUL (Tmp_File_Name_NUL'First .. Tmp_File_Name_NUL'Last - 1) & Platform.IDL_Preprocessor_Suffix); end; -- Add platform specific C++ preprocessor arguments as well as C++ -- preprocessor command name. for J in CPP_Arg_List'First + 1 .. CPP_Arg_List'Last loop Add_Argument (CPP_Arg_List (J).all); end loop; -- Pass user options to the preprocessor. Goto_Section ("cppargs"); while Getopt ("*") /= ASCII.NUL loop Add_Argument (Full_Switch); end loop; -- Add all search paths. Remove directory separator, because gcc does -- not work on Windows when we call it with things like: -- -I /some/directory\ for J in Search_Path.First .. Search_Path.Last loop Add_Argument ("-I"); declare Dir : String renames Search_Path.Table (J).all; pragma Assert (Dir (Dir'Last) = Dir_Separator); begin Add_Argument (Dir (Dir'First .. Dir'Last - 1)); end; end loop; -- Always add the current directory at the end of the include list Add_Argument ("-I"); Add_Argument ("."); -- Add output and source file names. Add_Argument ("-o"); Add_Argument (Tmp_File_Name.all); Add_Argument (File_Name); declare Preprocessor_Full_Pathname : constant String_Access := Locate_Exec_On_Path (CPP_Arg_List (CPP_Arg_List'First).all); Spawn_Result : Boolean; begin if Preprocessor_Full_Pathname = null then Idlac_Errors.Error ("Cannot find preprocessor " & "'" & CPP_Arg_List (CPP_Arg_List'First).all & "'", Idlac_Errors.Fatal, Idlac_Errors.No_Location); Free (Tmp_File_Name); return ""; end if; Spawn (Preprocessor_Full_Pathname.all, Args (Args'First .. Arg_Count), Spawn_Result); if not Spawn_Result then Idlac_Errors.Error (Base_Name (Command_Name) & ": preprocessor failed", Idlac_Errors.Fatal, Idlac_Errors.No_Location); Free (Tmp_File_Name); return ""; end if; end; declare Result : constant String := Tmp_File_Name.all; begin Free (Tmp_File_Name); return Result; end; end Preprocess_File; end Idl_Fe.Files; polyorb-2.8~20110207.orig/compilers/idlac/testlexer.adb0000644000175000017500000000613511750740337022155 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- T E S T L E X E R -- -- -- -- B o d y -- -- -- -- Copyright (C) 2001-2007, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by ACT Europe. -- -- (email: sales@act-europe.fr) -- -- -- ------------------------------------------------------------------------------ with Ada.Text_IO; with GNAT.Command_Line; with Idl_Fe.Lexer; use Idl_Fe.Lexer; with Idlac_Errors; procedure Testlexer is use Idl_Fe.Lexer.Lexer_State; Token : Idl_Fe.Lexer.Idl_Token; begin Idl_Fe.Lexer.Initialize (GNAT.Command_Line.Get_Argument); loop Token := Get_Next_Token; Ada.Text_IO.Put (Idl_Token'Image (Token)); case Token is when T_Lit_Decimal_Integer | T_Lit_Octal_Integer | T_Lit_Hexa_Integer | T_Lit_Char | T_Lit_Wide_Char | T_Lit_Simple_Floating_Point | T_Lit_Exponent_Floating_Point | T_Lit_Pure_Exponent_Floating_Point | T_Lit_String | T_Lit_Wide_String | T_Lit_Simple_Fixed_Point | T_Lit_Floating_Fixed_Point | T_Identifier | T_Pragma => Ada.Text_IO.Put (" : " & Get_Lexer_String & "."); when others => null; end case; Ada.Text_IO.Put_Line (""); exit when Token = T_Eof; end loop; exception when Idlac_Errors.Fatal_Error => null; end Testlexer; polyorb-2.8~20110207.orig/compilers/idlac/idl_fe-utils.ads0000644000175000017500000000517211750740337022537 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- I D L _ F E . U T I L S -- -- -- -- S p e c -- -- -- -- Copyright (C) 2001 Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by ACT Europe. -- -- (email: sales@act-europe.fr) -- -- -- ------------------------------------------------------------------------------ with Idl_Fe.Types; use Idl_Fe.Types; package Idl_Fe.Utils is -- Miscellaneous utilities for IDL tree manipulation procedure Add_Identifier_With_Renaming (Node : Node_Id; Identifier : String; Scope : Node_Id := No_Node; Is_Inheritable : Boolean := True); -- Assign Identifier to Node in Scope (or current scope if No_Node), -- possibly appending a numeric prefix if a conflict -- would otherwise be introduced. If Is_Inheritable is False, then -- this identifier will not be considered as conflicting when this scope -- is inherited by another. end Idl_Fe.Utils; polyorb-2.8~20110207.orig/compilers/idlac/idl_fe.opt0000644000175000017500000000014211750740337021424 0ustar xavierxavier#idl_fe.lexer #idl_fe.parser_method_trace #idl_fe.parser #idl_fe.types #idl_fe.types_method_trace polyorb-2.8~20110207.orig/compilers/idlac/idl_fe.ads0000644000175000017500000000476211750740337021405 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- I D L _ F E -- -- -- -- S p e c -- -- -- -- Copyright (C) 2001 Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by ACT Europe. -- -- (email: sales@act-europe.fr) -- -- -- ------------------------------------------------------------------------------ package Idl_Fe is -- This package is the root package of all the adabroker -- front-end -- Its children are : -- - idl_fe.lexer which implements the idl lexer -- - idl_fe.parser which implements the idl parser -- - idl_fe.types which define some usefull types, including -- the nodes of the tree generated by the parser. -- - idl_fe.display_tree which defines methods to display -- the output of the parser pragma Pure; end Idl_Fe; polyorb-2.8~20110207.orig/compilers/idlac/idl_fe-files.ads0000644000175000017500000000611711750740337022501 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- I D L _ F E . F I L E S -- -- -- -- S p e c -- -- -- -- Copyright (C) 2004-2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- This package contains different utilities for file manipulation: -- - seaching included/imported files with substituting IDL file extensions; -- - preprocessing files; -- Most of this functionality moved from idlac driver and idl_fe-lexer. package Idl_Fe.Files is procedure Add_Search_Path (Path : String; Success : out Boolean); -- Add IDL files search path. If path don't exists or not a direcotry -- then Success is False. function Locate_IDL_File (File_Name : String) return String; -- Search file in search paths and return file path. Return empty -- string if file not found. Append IDL file suffix if it absent. function Locate_IDL_Specification (Scoped_Name : String) return String; -- Convert Scoped_Name to file name and search file in search paths. -- Return file path if found and empty string else. function Preprocess_File (File_Name : String) return String; -- Call the C++ preprocessor for processing defined file. Return -- file name of temporary file or empty string if something failed. end Idl_Fe.Files; polyorb-2.8~20110207.orig/compilers/idlac/string_sets.adb0000644000175000017500000000555511750740337022507 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- S T R I N G _ S E T S -- -- -- -- B o d y -- -- -- -- Copyright (C) 2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with GNAT.HTable; package body String_Sets is function Hash_String is new GNAT.HTable.Hash (Header_Num); function Hash (F : String_Ptr) return Header_Num is begin return Hash_String (F.all); end Hash; function Equal (F1, F2 : String_Ptr) return Boolean is begin return F1.all = F2.all; end Equal; function Contains (Container : Set; Element : String) return Boolean is Element_Copy : aliased constant String := Element; begin return Tables.Get (Container.Set, Element_Copy'Unchecked_Access); end Contains; procedure Insert (Container : in out Set; Element : String) is begin -- Avoid heap allocation if the string is already in the set if not Contains (Container, Element) then Tables.Set (Container.Set, new String'(Element), True); end if; end Insert; end String_Sets; polyorb-2.8~20110207.orig/compilers/idlac/ada_be-idl2ada-value_skel.adb0000644000175000017500000001740111750740337024755 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- A D A _ B E . I D L 2 A D A . V A L U E _ S K E L -- -- -- -- B o d y -- -- -- -- Copyright (C) 2001-2007, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with Idl_Fe.Tree; use Idl_Fe.Tree; with Idl_Fe.Tree.Synthetic; use Idl_Fe.Tree.Synthetic; with Ada_Be.Identifiers; use Ada_Be.Identifiers; with Ada_Be.Debug; pragma Elaborate_All (Ada_Be.Debug); package body Ada_Be.Idl2Ada.Value_Skel is Flag : constant Natural := Ada_Be.Debug.Is_Active ("ada_be.idl2ada.value_skel"); procedure O is new Ada_Be.Debug.Output (Flag); ------------------- -- Gen_Node_Spec -- ------------------- procedure Gen_Node_Spec (CU : in out Compilation_Unit; Node : Node_Id) is begin case Kind (Node) is when K_ValueType => NL (CU); PL (CU, "function Is_A"); Add_With (CU, "CORBA"); Add_With (CU, "PolyORB.Std"); PL (CU, " (Logical_Type_Id : PolyORB.Std.String) " & "return CORBA.Boolean;"); NL (CU); when K_Operation => -- Write the store only if the operation is not inherited from -- another valuetype. if Oldest_Supporting_ValueType (Node) = Parent_Scope (Node) then declare Opname : constant String := Ada_Operation_Name (Node); begin Add_With (CU, "CORBA.Impl"); Add_With (CU, "PolyORB.CORBA_P.Value.Operation_Store"); NL (CU); Put (CU, "type " & Opname & "_Type is access "); Gen_Operation_Profile (CU, Node, "CORBA.Impl.Object_Ptr", With_Name => False); PL (CU, ";"); NL (CU); PL (CU, "package " & Opname & "_Store is new PolyORB.CORBA_P.Value.Operation_Store"); II (CU); PL (CU, "(" & Opname & "_Type);"); DI (CU); NL (CU); end; end if; when others => null; end case; end Gen_Node_Spec; ------------------- -- Gen_Node_Body -- ------------------- procedure Gen_Node_Body (CU : in out Compilation_Unit; Node : Node_Id) is begin pragma Debug (O ("Gen_Node_Body : enter")); pragma Debug (O ("Gen_Node_Body (" & Node_Kind'Image (Kind (Node)) & ")")); case Kind (Node) is when K_ValueType => Ada_Be.Idl2Ada.Gen_Local_Is_A (CU, Node); Divert (CU, Elaboration); Add_With (CU, "PolyORB.CORBA_P.Value.Value_Skel"); PL (CU, "PolyORB.CORBA_P.Value.Value_Skel." & "Is_A_Store.Register_Operation"); PL (CU, " (" & Ada_Full_Name (Node) & ".Value_Impl.Object'Tag,"); PL (CU, " " & Ada_Full_Name (Node) & ".Value_Skel.Is_A'Access);"); NL (CU); Divert (CU, Visible_Declarations); when K_Operation => declare Opname : constant String := Ada_Operation_Name (Node); V_Impl_Name : constant String := Parent_Scope_Name (Node) & ".Value_Impl"; begin Add_With (CU, V_Impl_Name); Gen_Operation_Profile (CU, Node, "CORBA.Impl.Object_Ptr"); PL (CU, " is"); PL (CU, "begin"); II (CU); if Kind (Operation_Type (Node)) /= K_Void then Put (CU, "return "); end if; PL (CU, V_Impl_Name & "." & Opname); Put (CU, " (" & V_Impl_Name & ".Object_Ptr (Self)"); II (CU); -- Other formal parameters declare It : Node_Iterator; P_Node : Node_Id; begin Init (It, Parameters (Node)); while not Is_End (It) loop Get_Next_Node (It, P_Node); PL (CU, ","); Gen_Node_Default (CU, Declarator (P_Node)); end loop; end; PL (CU, ");"); DI (CU); DI (CU); PL (CU, "end " & Opname & ";"); NL (CU); -- Register this operation in the proper Operation_Store Divert (CU, Elaboration); declare Original_VT_Name : constant String := Ada_Full_Name (Oldest_Supporting_ValueType (Node)); begin Put (CU, Original_VT_Name); Add_With (CU, Original_VT_Name & ".Value_Skel"); PL (CU, ".Value_Skel." & Opname & "_Store.Register_Operation"); PL (CU, " (" & V_Impl_Name & ".Object'Tag,"); PL (CU, " " & Parent_Scope_Name (Node) & ".Value_Skel." & Opname & "'Access);"); NL (CU); end; Divert (CU, Visible_Declarations); end; when others => null; end case; end Gen_Node_Body; end Ada_Be.Idl2Ada.Value_Skel; polyorb-2.8~20110207.orig/compilers/idlac/idl_fe-debug.ads0000644000175000017500000000527211750740337022466 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- I D L _ F E . D E B U G -- -- -- -- S p e c -- -- -- -- Copyright (C) 2001-2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- This is a debugging package for IDL-Ada Compiler. -- -- with Idl_Fe.Debug; -- pragma Elaborate(Idl_Fe.Debug); -- -- Flag : constant Natural := Idl_Fe.Debug.Is_Active ("specific_name"); -- procedure O is new Idl_Fe.Debug.Output (Flag); -- -- and then : -- -- pragma Debug (O ("debugging info")); -- -- The output will be done if "idl_fe.opt" file contains -- a line with "specific_name" package Idl_Fe.Debug is pragma Elaborate_Body; function Is_Active (Flag : String) return Natural; -- Returns 0 when not active generic Flag : Natural; procedure Output (Message : String); -- Prints Message on standard output when Flag is not 0 end Idl_Fe.Debug; polyorb-2.8~20110207.orig/compilers/idlac/ada_be-expansion.ads0000644000175000017500000000422211750740337023347 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- A D A _ B E . E X P A N S I O N -- -- -- -- S p e c -- -- -- -- Copyright (C) 2001-2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with Idl_Fe.Types; use Idl_Fe.Types; package Ada_Be.Expansion is procedure Expand_Repository (Node : Node_Id); end Ada_Be.Expansion; polyorb-2.8~20110207.orig/compilers/idlac/idlac_errors.ads0000644000175000017500000001001011750740337022612 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- I D L A C _ E R R O R S -- -- -- -- S p e c -- -- -- -- Copyright (C) 2001-2008, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ package Idlac_Errors is ----------------------- -- Types definitions -- ----------------------- type String_Ptr is access String; -- Source file locations type Location is record Filename : String_Ptr; Dirname : String_Ptr; Line : Natural; Col : Natural; end record; No_Location : constant Location := (Filename => null, Dirname => null, Line => 0, Col => 0); Internal_Error : exception; -- Internal use: raised when the parser detects that it is in an -- inconsistent state. Fatal_Error : exception; -- Exception raised when input cannot be processed -- Error levels type Error_Kind is (Fatal, Error, Warning); -- Fatal causes the immediate stop of the parsing, Error displays an -- error message, try to resume the parsing but does not generate any -- code. Warning only informs the user of a mistake but generates -- code normally. ----------------------- -- Location handling -- ----------------------- function Location_To_String (Loc : Location; Short : Boolean := False) return String; -- Return a string with the following format if Short is False: -- file : name_of_file, line : line_nb, column : column_nb -- or, if Short is True, -- name_of_file:line_nb:column_nb procedure Set_Path (Loc : in out Location; Filename : String); -- Set Loc.Dirname and Loc.Filename to the appropriate parts of Filename. -------------------- -- Error handling -- -------------------- procedure Error (Message : String; Level : Error_Kind; Loc : Location); -- Produce an error message. Fatal_Error is raised if Level is Fatal function Is_Error return Boolean; -- True if an error occurred function Is_Warning return Boolean; -- True if a warning was emitted function Error_Number return Natural; -- Returns the number of errors function Warning_Number return Natural; -- Returns the number of warnings end Idlac_Errors; polyorb-2.8~20110207.orig/compilers/idlac/idlac.adb0000644000175000017500000002267411750740337021220 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- I D L A C -- -- -- -- B o d y -- -- -- -- Copyright (C) 2001-2008, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with Ada.Text_IO; use Ada.Text_IO; with Ada.Command_Line; use Ada.Command_Line; with GNAT.Command_Line; use GNAT.Command_Line; with GNAT.OS_Lib; use GNAT.OS_Lib; with Idlac_Flags; use Idlac_Flags; with Idl_Fe.Files; with Idl_Fe.Types; with Idl_Fe.Parser; with Idlac_Errors; with Ada_Be.Expansion; with Ada_Be.Idl2Ada; with Ada_Be.Mappings.CORBA; with Ada_Be.Source_Streams; with Platform; procedure Idlac is procedure Usage; -- Display a general help message describing the -- idlac command line, and exit to the operating -- system with a failure indication. procedure Usage is begin Put_Line (Current_Error, "IDLAC from PolyORB " & Platform.Version); Put_Line (Current_Error, "Usage: " & Command_Name & " [-Edikpqv] [-[no]ir] [-gnatW8] [-o DIR]" & " idl_file [-cppargs ...]"); Put_Line (Current_Error, " -E Preprocess only."); Put_Line (Current_Error, " -d Generate delegation package."); Put_Line (Current_Error, " -i Generate implementation template."); Put_Line (Current_Error, " -s Generate server side code."); Put_Line (Current_Error, " -c Generate client side code."); Put_Line (Current_Error, " -k Keep temporary files."); Put_Line (Current_Error, " -p Produce source on standard output."); Put_Line (Current_Error, " -q Be quiet (default)."); Put_Line (Current_Error, " -v Be verbose."); Put_Line (Current_Error, " -ir Generate code for " & "interface repository."); Put_Line (Current_Error, " -noir Don't generate code for " & "interface repository (default)."); Put_Line (Current_Error, " -gnatW8"); Put_Line (Current_Error, " Use UTF8 character encoding."); Put_Line (Current_Error, " -o DIR Specify output directory."); Put_Line (Current_Error, " -cppargs ARGS"); Put_Line (Current_Error, " Pass ARGS to the C++ preprocessor."); Put_Line (Current_Error, " -I dir is a shortcut for -cppargs -I dir."); OS_Exit (1); end Usage; File_Name : Idl_Fe.Types.String_Cacc; Rep : Idl_Fe.Types.Node_Id; begin begin Initialize_Option_Scan ('-', False, "cppargs"); loop case Getopt ("E I: c d i k p q s v ir noir o: gnatW8") is when ASCII.NUL => exit; when 'E' => Preprocess_Only := True; when 'd' => Generate_Delegate := True; when 'i' => if Full_Switch = "i" then Generate_Impl_Template := True; elsif Full_Switch = "ir" then Generate_IR := True; end if; when 'c' => Generate_Client_Code := True; when 's' => Generate_Server_Code := True; when 'k' => Keep_Temporary_Files := True; when 'p' => To_Stdout := True; when 'q' => -- For backward compatibility we just ignore this switch Verbose := False; when 'v' => Verbose := True; when 'g' => Character_Encoding := UTF_8; when 'n' => if Full_Switch = "noir" then -- For backward compatibility we just ignore this switch Generate_IR := False; end if; when 'o' => if not Ada_Be.Source_Streams.Set_Output_Directory (Parameter) then raise Invalid_Parameter; end if; when 'I' => declare Success : Boolean; begin Idl_Fe.Files.Add_Search_Path (Parameter, Success); if not Success then raise Program_Error with Parameter & ": directory not found"; end if; end; when others => raise Program_Error; end case; end loop; -- Force generation of client and server side code if at least one -- from client, server or implementation template not selected. if not Generate_Client_Code and then not Generate_Server_Code and then not Generate_Impl_Template then Generate_Client_Code := True; Generate_Server_Code := True; end if; File_Name := new String'(Get_Argument); if File_Name.all'Length = 0 then Put_Line (Current_Error, "No file name specified."); Usage; end if; -- The "cppargs" section is processed in -- Idl_Fe.Lexer.Initialize. exception when Invalid_Switch => Put_Line (Current_Error, "Invalid Switch " & Full_Switch); Usage; when Invalid_Parameter => Put_Line (Current_Error, "No parameter for " & Full_Switch); Usage; end; -- If file does not exist, issue an error message unless it works after -- adding an "idl" extension. declare File_Loc : constant String := Idl_Fe.Files.Locate_IDL_File (File_Name.all); begin if File_Loc'Length = 0 then Put_Line (Current_Error, "No such file: " & File_Name.all); Usage; end if; File_Name := new String'(File_Loc); end; if Preprocess_Only then -- If we only want to preprocess, let's preprocess, print the content -- of the file and exit. declare Idl_File : File_Type; Line : String (1 .. 1024); Last : Natural; begin Open (Idl_File, In_File, Idl_Fe.Files.Preprocess_File (File_Name.all)); Set_Input (Idl_File); while not End_Of_File loop Get_Line (Line, Last); Put_Line (Line (1 .. Last)); end loop; Delete (Idl_File); end; else -- Setup parser Idl_Fe.Parser.Initialize (File_Name.all); -- Parse input Rep := Idl_Fe.Parser.Parse_Specification; if Idlac_Errors.Is_Error then Put (Current_Error, Natural'Image (Idlac_Errors.Error_Number) & " error(s)"); if Idlac_Errors.Is_Warning then Put (Current_Error, " and " & Natural'Image (Idlac_Errors.Warning_Number) & " warning(s)"); end if; Put_Line (Current_Error, " during parsing."); else if Verbose then if Idlac_Errors.Is_Warning then Put_Line (Current_Error, Natural'Image (Idlac_Errors.Warning_Number) & " warning(s) during parsing."); else Put_Line (Current_Error, "Successfully parsed."); end if; end if; -- Expand tree. This should not cause any errors! Ada_Be.Expansion.Expand_Repository (Rep); pragma Assert (not Idlac_Errors.Is_Error); -- Generate code Ada_Be.Idl2Ada.Generate (Use_Mapping => Ada_Be.Mappings.CORBA.The_CORBA_Mapping, Node => Rep, Implement => Generate_Impl_Template, Intf_Repo => Generate_IR, To_Stdout => To_Stdout); end if; Idl_Fe.Parser.Finalize; if Idlac_Errors.Is_Error then OS_Exit (2); end if; end if; end Idlac; polyorb-2.8~20110207.orig/compilers/idlac/ada_be-debug.ads0000644000175000017500000000530111750740337022430 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- A D A _ B E . D E B U G -- -- -- -- S p e c -- -- -- -- Copyright (C) 2001-2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- This is a debugging package for AdaBroker. -- -- with Adabroker.Debug; -- pragma Elaborate(Adabroker.Debug); -- -- Flag : constant Natural := Adabroker.Debug.Is_Active ("specific_name"); -- procedure O is new AdaBroker.Debug.Output (Flag); -- -- and then : -- -- pragma Debug (O ("debugging info")); -- -- The output will be done if "adabroker.deb" file contains -- a line with "specific_name" package Ada_Be.Debug is pragma Elaborate_Body; function Is_Active (Flag : String) return Natural; -- Return 0 when not active generic Flag : Natural; procedure Output (Message : String); -- Prints Message on standard output when Flag is not 0 end Ada_Be.Debug; polyorb-2.8~20110207.orig/compilers/idlac/ada_be-mappings-corba-alm_1_2.ads0000644000175000017500000000553111750740337025461 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- A D A _ B E . M A P P I N G S . C O R B A . A L M _ 1 _ 2 -- -- -- -- S p e c -- -- -- -- Copyright (C) 2005-2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- This unit controls the mapping of specific CORBA IDL constructs -- into Ada units as defined by the Ada Language Mapping version 1.2. package Ada_Be.Mappings.CORBA.ALM_1_2 is function Is_Well_Known_Node (Node : Idl_Fe.Types.Node_Id) return Boolean; -- Return True iff Node denotes one CORBA IDL construct with -- specific mapping rules. function Fetch_Unit_Name (Node : Idl_Fe.Types.Node_Id) return String; -- Return fully qualified compilation base unit name for Node function Fetch_Helper_Unit_Name (Node : Idl_Fe.Types.Node_Id) return String; -- Return fully qualified compilation helper unit name for Node function Fetch_Calling_Stubs_Type_Name (Node : Idl_Fe.Types.Node_Id) return String; -- Return calling stubs type name corresponding to Node end Ada_Be.Mappings.CORBA.ALM_1_2; polyorb-2.8~20110207.orig/compilers/idlac/ada_be-idl2ada.ads0000644000175000017500000002112611750740337022645 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- A D A _ B E . I D L 2 A D A -- -- -- -- S p e c -- -- -- -- Copyright (C) 2001-2008, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with Idl_Fe.Types; use Idl_Fe.Types; with Ada_Be.Source_Streams; use Ada_Be.Source_Streams; pragma Elaborate_All (Ada_Be.Source_Streams); with Ada_Be.Mappings.CORBA; package Ada_Be.Idl2Ada is procedure Generate (Use_Mapping : Ada_Be.Mappings.Mapping_Type'Class; Node : Node_Id; Implement : Boolean := False; Intf_Repo : Boolean := False; To_Stdout : Boolean := False); -- Generate the Ada mapping of the IDL tree -- rooted at Node. -- If Implement is true, produce only a template -- for the Impl package of each interface, to -- be completed by the user. -- If Intf_Repo is true, also produce CORBA -- Interface Repository packages. -- If To_Stdout is true, all produced source code -- is emitted on standard output (e. g. for use -- with GNATCHOP). private function Ada_Type_Name (Node : Node_Id) return String; -- The name of the Ada type that maps Node. -- This is the fully qualified name. function Ada_Operation_Name (Node : Node_Id) return String; -- The name of the Ada subprogram that maps -- K_Operation Node. function Repository_Id_Name (Node : Node_Id) return String; -- The name of the Ada constant that contains -- the repository ID of K_Named Node. function Ada_TC_Name (Node : Node_Id) return String; -- The name of the typecode corresponding to an Ada type function Ada_Full_TC_Name (Node : Node_Id) return String; -- The full name of the typecode corresponding to an Ada type -------------------------------------- -- Top-level generation subprograms -- -------------------------------------- procedure Gen_Node_Stubs_Spec (CU : in out Compilation_Unit; Node : Node_Id); -- procedure Gen_Node_Stubs_Body -- (CU : in out Compilation_Unit; -- Node : Node_Id); -- Generate the stubs code for a node. ------------------------- -- Utility subprograms -- ------------------------- function Idl_Operation_Id (Node : Node_Id) return String; -- The GIOP operation identifier (to use in -- a GIOP Request message) corresponding -- to K_Operation Node. procedure Add_With_Entity (CU : in out Compilation_Unit; Node : Node_Id); -- Add a semantic dependency of CU on the -- package that contains the mapping of -- the entity defined by Node. function Helper_Unit (Node : Node_Id) return String; -- The name of the Helper unit containing helper subprograms for Node -- (including From_Any and To_Any). function TC_Unit (Node : Node_Id) return String; -- The name of the Helper unit containing the TypeCode for Node function Conditional_Call (Func : String; Only_When : Boolean; Expr : String) return String; -- Return Func (Expr) if Only_When is true, Expr otherwise procedure Gen_When_Clause (CU : in out Compilation_Unit; Node : Node_Id; Default_Case_Seen : in out Boolean); -- Generate "when" clause for union K_Case Node. -- If this K_Case has a "default:" label, then -- Default_Case_Seen is set to True, else its -- value is left unchanged. procedure Gen_When_Others_Clause (CU : in out Compilation_Unit); -- Generate a "when others => null;" clause. procedure Gen_Operation_Profile (CU : in out Compilation_Unit; Node : Node_Id; Object_Type : String; With_Name : Boolean := True; Is_Delegate : Boolean := False); -- Generate the profile for an K_Operation node, -- with the Self formal parameter mode and type taken -- from the Object_Type string. -- If With_name is false, then the profile is generated, without -- the subprogram name, to create an access to subprogram type. -- If Delegate is True, "with" is added in front of the declaration -- and "is <>" at the end. procedure Gen_Initializer_Profile (CU : in out Compilation_Unit; Return_Type : String; Node : Node_Id); -- Generate the profile for an K_Initializer node, -- with the specified Return_Type procedure Gen_Local_Is_A (CU : in out Compilation_Unit; Node : Node_Id); -- Generate a function that checks locally whether a -- given repository ID denotes an ancestor type of -- Node. procedure Gen_Constant_Value (CU : in out Compilation_Unit; Expr : Node_Id; Typ : Node_Id); -- Generate the representation of a constant expression. Expr is the -- expression node, and Typ is the IDL type of the expression. Typ may be -- No_Node for integer constants, in which case the context must expect -- a Standard.Integer value. procedure Gen_Node_Default (CU : in out Compilation_Unit; Node : Node_Id); -- Generate the text for a node whose mapping is -- common to all generated files. procedure Gen_Forward_Conversion (CU : in out Compilation_Unit; T_Node : Node_Id; Direction : String; What : String); pragma Unreferenced (Gen_Forward_Conversion); -- Generate a call to a forward <-> actual reference conversion, -- if necessary. ------------------- -- Text handling -- ------------------- function Justify (S : String; Max : Integer) return String; --------------------- -- User diversions -- --------------------- Deferred_Initialization : constant Source_Streams.Diversion := Source_Streams.Allocate_User_Diversion; -- Body of initialization subprogram Initialization_Dependencies : constant Source_Streams.Diversion := Source_Streams.Allocate_User_Diversion; -- List of initialization dependencies Operation_Body : constant Source_Streams.Diversion := Source_Streams.Allocate_User_Diversion; -- Body of operation stub ------------------------------------------ -- The current language mapping variant -- ------------------------------------------ type CORBA_Mapping_Access is access Ada_Be.Mappings.CORBA.CORBA_Mapping_Type'Class; Mapping : CORBA_Mapping_Access; --------------- -- Shortcuts -- --------------- procedure NL (CU : in out Compilation_Unit) renames New_Line; procedure PL (CU : in out Compilation_Unit; Line : String) renames Put_Line; procedure II (CU : in out Compilation_Unit) renames Inc_Indent; procedure DI (CU : in out Compilation_Unit) renames Dec_Indent; end Ada_Be.Idl2Ada; polyorb-2.8~20110207.orig/compilers/idlac/idl_fe-utils.adb0000644000175000017500000000514511750740337022516 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- I D L _ F E . U T I L S -- -- -- -- B o d y -- -- -- -- Copyright (C) 2001-2008, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by ACT Europe. -- -- (email: sales@act-europe.fr) -- -- -- ------------------------------------------------------------------------------ with Idlac_Utils; use Idlac_Utils; package body Idl_Fe.Utils is procedure Add_Identifier_With_Renaming (Node : Node_Id; Identifier : String; Scope : Node_Id := No_Node; Is_Inheritable : Boolean := True) is Suffix : Integer := 1; begin if not Add_Identifier (Node, Identifier, Scope, Is_Inheritable) then while not Add_Identifier (Node, Identifier & "_" & Img (Suffix), Scope, Is_Inheritable) loop Suffix := Suffix + 1; end loop; end if; end Add_Identifier_With_Renaming; end Idl_Fe.Utils; polyorb-2.8~20110207.orig/compilers/idlac/testparser.adb0000644000175000017500000001051711750740337022331 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- T E S T P A R S E R -- -- -- -- B o d y -- -- -- -- Copyright (C) 2001-2008, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with Ada.Exceptions; use Ada.Exceptions; with Ada.Text_IO; use Ada.Text_IO; with GNAT.Command_Line; use GNAT.Command_Line; with Idl_Fe.Types; with Idl_Fe.Parser; with Idl_Fe.Display_Tree; with Ada_Be.Expansion; with Idlac_Errors; procedure Testparser is Rep : Idl_Fe.Types.Node_Id; Display_Tree : Boolean := True; Expand : Boolean := False; Exception_Raised : Exception_Occurrence_Access := null; begin Put_Line (Current_Error, "Testparser : initializing parser"); loop case Getopt ("q e") is when ASCII.NUL => exit; when 'q' => -- Quiet. Display_Tree := False; when 'e' => Expand := True; when others => raise Program_Error; -- cannot occur! end case; end loop; Idl_Fe.Parser.Initialize (Get_Argument); Put_Line (Current_Error, "Testparser : Parsing"); Rep := Idl_Fe.Parser.Parse_Specification; if Expand then Put_Line (Current_Error, "Testparser : Expanding "); begin Ada_Be.Expansion.Expand_Repository (Rep); exception when E : others => Exception_Raised := Save_Occurrence (E); end; end if; if Display_Tree then Put_Line (Current_Error, "Testparser : Displaying "); Idl_Fe.Display_Tree.Disp_Tree (Rep); end if; Put_Line (Current_Error, "Testparser : Finished "); if Idlac_Errors.Is_Error then Put (Current_Error, "There were " & Natural'Image (Idlac_Errors.Error_Number) & " error(s)"); if Idlac_Errors.Is_Warning then Put_Line (Current_Error, " and " & Natural'Image (Idlac_Errors.Warning_Number) & " warning(s) during parsing."); end if; else if Idlac_Errors.Is_Warning then Put_Line (Current_Error, "there was " & Natural'Image (Idlac_Errors.Warning_Number) & " warning(s) during parsing."); else Put_Line (Current_Error, "successfully parsed"); end if; end if; if Exception_Raised /= null then Put_Line (Current_Error, "Exception raised during expansion:"); Put_Line (Current_Error, Ada.Exceptions.Exception_Information (Exception_Raised.all)); end if; Idl_Fe.Parser.Finalize; end Testparser; polyorb-2.8~20110207.orig/compilers/idlac/idl_fe-lexer.adb0000644000175000017500000014000311750740337022466 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- I D L _ F E . L E X E R -- -- -- -- B o d y -- -- -- -- Copyright (C) 2001-2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with Ada.Text_IO; with Ada.Characters.Latin_1; use Ada.Characters.Latin_1; with Ada.Characters.Handling; with GNAT.Case_Util; with GNAT.OS_Lib; with GNAT.Table; with Idlac_Flags; with Idl_Fe.Debug; pragma Elaborate_All (Idl_Fe.Debug); with Idl_Fe.Files; with Idl_Fe.Types; use Idl_Fe.Types; package body Idl_Fe.Lexer is ----------- -- Debug -- ----------- Flag : constant Natural := Idl_Fe.Debug.Is_Active ("idl_fe.lexer"); procedure O is new Idl_Fe.Debug.Output (Flag); subtype Line_Type is String (1 .. 2047); -- Used for define identical line buffers in global variable and -- state table. subtype Idl_Token_Keyword is Idl_Token range T_Abstract .. T_Wstring; All_Idl_Keywords : constant array (Idl_Token_Keyword) of String_Cacc := (T_Abstract => new String'("abstract"), T_Any => new String'("any"), T_Attribute => new String'("attribute"), T_Boolean => new String'("boolean"), T_Case => new String'("case"), T_Char => new String'("char"), T_Component => new String'("component"), T_Const => new String'("const"), T_Consumes => new String'("consumes"), T_Context => new String'("context"), T_Custom => new String'("custom"), T_Default => new String'("default"), T_Double => new String'("double"), T_Emits => new String'("emits"), T_Enum => new String'("enum"), T_EventType => new String'("eventtype"), T_Exception => new String'("exception"), T_Factory => new String'("factory"), T_False => new String'("FALSE"), T_Finder => new String'("finder"), T_Fixed => new String'("fixed"), T_Float => new String'("float"), T_GetRaises => new String'("getraises"), T_Home => new String'("home"), T_Import => new String'("import"), T_In => new String'("in"), T_Inout => new String'("inout"), T_Interface => new String'("interface"), T_Local => new String'("local"), T_Long => new String'("long"), T_Module => new String'("module"), T_Multiple => new String'("multiple"), T_Native => new String'("native"), T_Object => new String'("Object"), T_Octet => new String'("octet"), T_Oneway => new String'("oneway"), T_Out => new String'("out"), T_PrimaryKey => new String'("primarykey"), T_Private => new String'("private"), T_Provides => new String'("provides"), T_Public => new String'("public"), T_Publishes => new String'("publishes"), T_Raises => new String'("raises"), T_Readonly => new String'("readonly"), T_Sequence => new String'("sequence"), T_SetRaises => new String'("setraises"), T_Short => new String'("short"), T_String => new String'("string"), T_Struct => new String'("struct"), T_Supports => new String'("supports"), T_Switch => new String'("switch"), T_True => new String'("TRUE"), T_Truncatable => new String'("truncatable"), T_Typedef => new String'("typedef"), T_TypeId => new String'("typeid"), T_TypePrefix => new String'("typeprefix"), T_Unsigned => new String'("unsigned"), T_Union => new String'("union"), T_Uses => new String'("uses"), T_ValueBase => new String'("ValueBase"), T_ValueType => new String'("valuetype"), T_Void => new String'("void"), T_Wchar => new String'("wchar"), T_Wstring => new String'("wstring")); Idl_File_Name : GNAT.OS_Lib.String_Access; -- Name of file in which preprocessor output is saved, and which is now -- processed by lexer Idl_File : Ada.Text_IO.File_Type; -- Currently processed file --------------------------------- -- A state for pragma scanning -- --------------------------------- Pragma_State : Boolean := False; -- True when the lexer is scanning a pragma line --------------------------------- -- Low-level string processing -- --------------------------------- Current_Location : Idlac_Errors.Location; -- The current location in the parsed file Current_Token_Location : Idlac_Errors.Location; -- The current_token location Current_Line_Len : Natural; -- The length of the current line Line : Line_Type; -- The current line in the parsed file Offset : Natural; -- The current offset on the line (the offset is due to tabs) Mark_Pos : Natural; End_Mark_Pos : Natural; -- The current position of the marks in the line. The marks -- are used to memorize the begining and the end of an -- identifier for example. ----------------- -- State stack -- ----------------- -- ??? More comments needed type State_Item is record Idl_File_Name : GNAT.OS_Lib.String_Access; Current_Location : Idlac_Errors.Location; Current_Token_Location : Idlac_Errors.Location; Current_Line_Len : Natural; Line : Line_Type; Offset : Natural; TIO_Line : Ada.Text_IO.Positive_Count; TIO_Col : Ada.Text_IO.Positive_Count; end record; package State_Stack is new GNAT.Table (Table_Component_Type => State_Item, Table_Index_Type => Natural, Table_Low_Bound => 1, Table_Initial => 10, Table_Increment => 100); Initialized : Boolean := False; -- Flag to detect nested calls to Initialize. If True then lexer -- is already initialized, else its initialization for new file -- current state should be saved in state stack. procedure Push_State; -- Store lexer state in stack procedure Pop_State; -- Restore lexer state from stack ---------------- -- Push_State -- ---------------- procedure Push_State is begin State_Stack.Append ((Idl_File_Name => Idl_File_Name, Current_Location => Current_Location, Current_Token_Location => Current_Token_Location, Current_Line_Len => Current_Line_Len, Line => Line, Offset => Offset, TIO_Line => Ada.Text_IO.Line (Idl_File), TIO_Col => Ada.Text_IO.Col (Idl_File))); Ada.Text_IO.Close (Idl_File); end Push_State; --------------- -- Pop_State -- --------------- procedure Pop_State is S : constant State_Item := State_Stack.Table (State_Stack.Last); begin State_Stack.Set_Last (State_Stack.Last - 1); Idl_File_Name := S.Idl_File_Name; Current_Location := S.Current_Location; Current_Token_Location := S.Current_Token_Location; Current_Line_Len := S.Current_Line_Len; Line := S.Line; Offset := S.Offset; Ada.Text_IO.Open (Idl_File, Ada.Text_IO.In_File, Idl_File_Name.all); Ada.Text_IO.Set_Input (Idl_File); Ada.Text_IO.Set_Line (Idl_File, S.TIO_Line); Ada.Text_IO.Set_Col (Idl_File, S.TIO_Col); end Pop_State; ------------------------ -- Set_Token_Location -- ------------------------ procedure Set_Token_Location is begin Current_Token_Location.Filename := Current_Location.Filename; Current_Token_Location.Dirname := Current_Location.Dirname; Current_Token_Location.Line := Current_Location.Line; Current_Token_Location.Col := Current_Location.Col + Offset - Line'First; end Set_Token_Location; ----------------------- -- Get_Real_Location -- ----------------------- function Get_Real_Location return Idlac_Errors.Location is begin pragma Debug (O ("Get_Real_Location: Line = " & Natural'Image (Current_Location.Line) & ", Col = " & Natural'Image (Current_Location.Col + Offset - Line'First) & ", Filename = " & Current_Location.Filename.all)); return (Filename => Current_Location.Filename, Dirname => Current_Location.Dirname, Line => Current_Location.Line, Col => Current_Location.Col + Offset - Line'First); end Get_Real_Location; --------------- -- Read_Line -- --------------- procedure Read_Line is begin -- Get next line and append LF Ada.Text_IO.Get_Line (Line, Current_Line_Len); Current_Line_Len := Current_Line_Len + 1; Line (Current_Line_Len) := LF; Current_Location.Line := Current_Location.Line + 1; Current_Location.Col := Line'First; Offset := 0; Mark_Pos := Current_Location.Col; End_Mark_Pos := Current_Location.Col; end Read_Line; --------------- -- Skip_Char -- --------------- procedure Skip_Char is begin Current_Location.Col := Current_Location.Col + 1; if Current_Location.Col > Current_Line_Len then Read_Line; end if; end Skip_Char; --------------- -- Skip_Line -- --------------- procedure Skip_Line is begin Read_Line; Current_Location.Col := Current_Location.Col - 1; end Skip_Line; --------------- -- Next_Char -- --------------- function Next_Char return Character is begin Skip_Char; return Line (Current_Location.Col); end Next_Char; -------------------- -- View_Next_Char -- -------------------- function View_Next_Char return Character is begin if Current_Location.Col = Current_Line_Len then return LF; else return Line (Current_Location.Col + 1); end if; end View_Next_Char; ------------------------- -- View_Next_Next_Char -- ------------------------- function View_Next_Next_Char return Character is begin if Current_Location.Col > Current_Line_Len - 2 then return LF; else return Line (Current_Location.Col + 2); end if; end View_Next_Next_Char; ---------------------- -- Get_Current_Char -- ---------------------- function Get_Current_Char return Character is begin return Line (Current_Location.Col); end Get_Current_Char; -------------------- -- Refresh_Offset -- -------------------- procedure Refresh_Offset is begin Offset := ((Current_Location.Col + Offset + 7) / 8) * 8 - Current_Location.Col; end Refresh_Offset; ----------------- -- Skip_Spaces -- ----------------- procedure Skip_Spaces is begin loop case View_Next_Char is when Space | CR | VT | FF | HT => Skip_Char; when others => return; end case; end loop; end Skip_Spaces; ------------------ -- Skip_Comment -- ------------------ procedure Skip_Comment is begin pragma Debug (O ("Skip_Comment: enter")); loop while Next_Char /= '*' loop null; end loop; pragma Debug (O ("Skip_Comment: '*' found")); while Next_Char = '*' loop null; end loop; pragma Debug (O ("Skip_Comment: no more '*'s")); exit when Get_Current_Char = '/'; end loop; pragma Debug (O ("Skip_Comment: end")); end Skip_Comment; -------------- -- Set_Mark -- -------------- procedure Set_Mark is begin Mark_Pos := Current_Location.Col; End_Mark_Pos := Mark_Pos; end Set_Mark; --------------------------- -- Set_Mark_On_Next_Char -- --------------------------- procedure Set_Mark_On_Next_Char is begin Mark_Pos := Current_Location.Col + 1; End_Mark_Pos := Mark_Pos; end Set_Mark_On_Next_Char; ------------------ -- Set_End_Mark -- ------------------ procedure Set_End_Mark is begin End_Mark_Pos := Current_Location.Col; end Set_End_Mark; ----------------------------------- -- Set_End_Mark_On_Previous_Char -- ----------------------------------- procedure Set_End_Mark_On_Previous_Char is begin End_Mark_Pos := Current_Location.Col - 1; end Set_End_Mark_On_Previous_Char; --------------------- -- Get_Marked_Text -- --------------------- function Get_Marked_Text return String is begin return Line (Mark_Pos .. End_Mark_Pos); end Get_Marked_Text; ----------------------- -- Go_To_End_Of_Char -- ----------------------- procedure Go_To_End_Of_Char is begin while View_Next_Char /= ''' and then View_Next_Char /= LF loop Skip_Char; end loop; end Go_To_End_Of_Char; ------------------------- -- Go_To_End_Of_String -- ------------------------- procedure Go_To_End_Of_String is begin while View_Next_Char /= Quotation loop Skip_Char; end loop; Skip_Char; end Go_To_End_Of_String; ------------------------------- -- Low-level char processing -- ------------------------------- ----------------------------- -- Is_Alphabetic_Character -- ----------------------------- function Is_Alphabetic_Character (C : Standard.Character) return Boolean is begin case C is when 'A' .. 'Z' | LC_A .. LC_Z | UC_A_Grave .. UC_I_Diaeresis | LC_A_Grave .. LC_I_Diaeresis | UC_N_Tilde .. UC_O_Diaeresis | LC_N_Tilde .. LC_O_Diaeresis | UC_O_Oblique_Stroke .. UC_U_Diaeresis | LC_O_Oblique_Stroke .. LC_U_Diaeresis | LC_German_Sharp_S | LC_Y_Diaeresis => return True; when others => return False; end case; end Is_Alphabetic_Character; ------------------------ -- Is_Digit_Character -- ------------------------ function Is_Digit_Character (C : Standard.Character) return Boolean is begin return C in '0' .. '9'; end Is_Digit_Character; ------------------------------ -- Is_Octal_Digit_Character -- ------------------------------ function Is_Octal_Digit_Character (C : Standard.Character) return Boolean is begin return C in '0' .. '7'; end Is_Octal_Digit_Character; ----------------------------- -- Is_Hexa_Digit_Character -- ----------------------------- function Is_Hexa_Digit_Character (C : Standard.Character) return Boolean is begin case C is when '0' .. '9' | 'A' .. 'F' | LC_A .. LC_F => return True; when others => return False; end case; end Is_Hexa_Digit_Character; ----------------------------- -- Is_Identifier_Character -- ----------------------------- function Is_Identifier_Character (C : Standard.Character) return Boolean is begin case C is when 'A' .. 'Z' | LC_A .. LC_Z | UC_A_Grave .. UC_I_Diaeresis | LC_A_Grave .. LC_I_Diaeresis | UC_N_Tilde .. UC_O_Diaeresis | LC_N_Tilde .. LC_O_Diaeresis | UC_O_Oblique_Stroke .. UC_U_Diaeresis | LC_O_Oblique_Stroke .. LC_U_Diaeresis | LC_German_Sharp_S | LC_Y_Diaeresis | Low_Line | '0' .. '9' | ''' => return True; when others => return False; end case; end Is_Identifier_Character; --------------------------- -- IDL string processing -- --------------------------- -------------------------- -- Idl_Identifier_Equal -- -------------------------- function Idl_Identifier_Equal (Left, Right : String) return Ident_Equality is use GNAT.Case_Util; begin if Left'Length /= Right'Length then return Differ; end if; for I in Left'Range loop if To_Lower (Left (I)) /= To_Lower (Right (Right'First + I - Left'First)) then return Differ; end if; end loop; if Left /= Right then return Case_Differ; else return Equal; end if; end Idl_Identifier_Equal; -------------------- -- Is_Idl_Keyword -- -------------------- procedure Is_Idl_Keyword (S : String; Is_Escaped : Boolean; Is_A_Keyword : out Idl_Keyword_State; Tok : out Idl_Token) is Result : Ident_Equality; begin for I in All_Idl_Keywords'Range loop Result := Idl_Identifier_Equal (S, All_Idl_Keywords (I).all); case Result is when Differ => null; when Case_Differ => if Is_Escaped then Is_A_Keyword := Is_Identifier; Tok := T_Error; return; else Is_A_Keyword := Bad_Case; Tok := I; return; end if; when Equal => if Is_Escaped then Is_A_Keyword := Is_Identifier; Tok := T_Error; return; else Is_A_Keyword := Is_Keyword; Tok := I; return; end if; end case; end loop; Is_A_Keyword := Is_Identifier; Tok := T_Error; end Is_Idl_Keyword; -------------------------------------- -- Scanners for chars, identifiers, -- -- numerics, string literals, and -- -- preprocessor directives. -- -------------------------------------- --------------- -- Scan_Char -- --------------- function Scan_Char (Wide : Boolean) return Idl_Token is Result : Idl_Token; begin Set_Mark_On_Next_Char; if Next_Char = '\' then case View_Next_Char is when 'n' | 't' | 'v' | 'b' | 'r' | 'f' | 'a' | '\' | '?' | Quotation => Skip_Char; Result := T_Lit_Char; when ''' => if View_Next_Next_Char /= ''' then Idlac_Errors.Error ("Invalid character: '\', " & "it should probably be '\\'", Idlac_Errors.Error, Get_Real_Location); Result := T_Error; else Skip_Char; Result := T_Lit_Char; end if; when '0' .. '7' => Skip_Char; if Is_Octal_Digit_Character (View_Next_Char) then Skip_Char; end if; if Is_Octal_Digit_Character (View_Next_Char) then Skip_Char; end if; if Is_Octal_Digit_Character (View_Next_Char) then Go_To_End_Of_Char; Set_End_Mark; Idlac_Errors.Error ("Too much octal digits in " & "character " & Get_Marked_Text & ", maximum is 3 in a char " & "definition", Idlac_Errors.Error, Get_Real_Location); Result := T_Error; else Result := T_Lit_Char; end if; when 'x' => Skip_Char; if Is_Hexa_Digit_Character (Next_Char) then if Is_Hexa_Digit_Character (View_Next_Char) then Skip_Char; end if; if Is_Hexa_Digit_Character (View_Next_Char) then Go_To_End_Of_Char; Set_End_Mark; Idlac_Errors.Error ("Too much hexadecimal digits " & "in character " & Get_Marked_Text & ", maximum is 2 in a char " & "definition", Idlac_Errors.Error, Get_Real_Location); Result := T_Error; else Result := T_Lit_Char; end if; else Go_To_End_Of_Char; Set_End_Mark; Idlac_Errors.Error ("Invalid hexadecimal character " & "code: " & Get_Marked_Text, Idlac_Errors.Error, Get_Real_Location); Result := T_Error; end if; when 'u' => Skip_Char; if Is_Hexa_Digit_Character (Next_Char) then if Is_Hexa_Digit_Character (View_Next_Char) then Skip_Char; end if; if Is_Hexa_Digit_Character (View_Next_Char) then Skip_Char; end if; if Is_Hexa_Digit_Character (View_Next_Char) then Skip_Char; end if; if Is_Hexa_Digit_Character (View_Next_Char) then Go_To_End_Of_Char; Set_End_Mark; if Wide then Idlac_Errors.Error ("Too much hexadecimal " & "digits in character " & Get_Marked_Text & ", maximum is 4 in a " & "unicode char definition", Idlac_Errors.Error, Get_Real_Location); end if; Result := T_Error; else Result := T_Lit_Char; end if; else Go_To_End_Of_Char; Set_End_Mark; if Wide then Idlac_Errors.Error ("Invalid unicode character " & "code: " & Get_Marked_Text, Idlac_Errors.Error, Get_Real_Location); end if; Result := T_Error; end if; if not Wide then Idlac_Errors.Error ("Unicode character is not " & "allowed in a non wide " & "character.", Idlac_Errors.Error, Get_Real_Location); Result := T_Error; end if; when '8' | '9' | 'A' .. 'F' | LC_C .. LC_E => Go_To_End_Of_Char; Set_End_Mark; Idlac_Errors.Error ("Invalid octal character code: " & Get_Marked_Text & ". For hexadecimal codes, " & "use \xhh", Idlac_Errors.Error, Get_Real_Location); Result := T_Error; when others => Go_To_End_Of_Char; Set_End_Mark; Idlac_Errors.Error ("Invalid definition of character: " & Get_Marked_Text, Idlac_Errors.Error, Get_Real_Location); Result := T_Error; end case; elsif Get_Current_Char = ''' then if View_Next_Char = ''' then Idlac_Errors.Error ("Invalid character: ''', " & "it should probably be '\''", Idlac_Errors.Error, Get_Real_Location); Result := T_Error; else Idlac_Errors.Error ("Invalid character: ''", Idlac_Errors.Error, Get_Real_Location); return T_Error; end if; else Result := T_Lit_Char; end if; Set_End_Mark; if Next_Char /= ''' then Go_To_End_Of_Char; Idlac_Errors.Error ("Invalid character: '" & Get_Marked_Text & "'", Idlac_Errors.Error, Get_Real_Location); Result := T_Error; end if; return Result; end Scan_Char; ----------------- -- Scan_String -- ----------------- function Scan_String (Wide : Boolean) return Idl_Token is Several_Lines : Boolean := False; begin Set_Mark_On_Next_Char; loop case Next_Char is when Quotation => if View_Next_Char = Quotation then Skip_Char; else Set_End_Mark_On_Previous_Char; return T_Lit_String; end if; when '\' => case View_Next_Char is when LC_N | LC_T | LC_V | LC_B | LC_R | LC_F | LC_A | '\' | '?' | ''' | Quotation => Skip_Char; when '0' => if Is_Octal_Digit_Character (View_Next_Next_Char) then Skip_Char; else Go_To_End_Of_String; Idlac_Errors.Error ("A string literal may not contain" & " the character '\0'", Idlac_Errors.Error, Get_Real_Location); return T_Error; end if; when '1' .. '7' => Skip_Char; when LC_X => if Is_Hexa_Digit_Character (View_Next_Next_Char) then Skip_Char; else Go_To_End_Of_String; Idlac_Errors.Error ("bad hexadecimal character in string", Idlac_Errors.Error, Get_Real_Location); return T_Error; end if; when LC_U => if Is_Hexa_Digit_Character (View_Next_Next_Char) then Skip_Char; else Go_To_End_Of_String; if Wide then Idlac_Errors.Error ("bad unicode character in string", Idlac_Errors.Error, Get_Real_Location); else Idlac_Errors.Error ("bad unicode character in string. " & "Anyway, it is not allowed in a non " & "wide string.", Idlac_Errors.Error, Get_Real_Location); end if; return T_Error; end if; if not Wide then Idlac_Errors.Error ("Unicode characters are not allowed " & "in a non wide string.", Idlac_Errors.Error, Get_Real_Location); end if; when others => Go_To_End_Of_String; Idlac_Errors.Error ("bad escape sequence in string", Idlac_Errors.Error, Get_Real_Location); return T_Error; end case; when LF => if Several_Lines = False then Idlac_Errors.Error ("A String may not go over several lines", Idlac_Errors.Error, Get_Real_Location); Several_Lines := True; end if; when others => null; end case; end loop; exception when Ada.Text_IO.End_Error => Idlac_Errors.Error ("unexpected end of file in the middle " & "of a string, you probably forgot the " & Quotation & " at the end of a string", Idlac_Errors.Fatal, Get_Real_Location); -- Not reached raise Idlac_Errors.Fatal_Error; end Scan_String; --------------------- -- Scan_Identifier -- --------------------- function Scan_Identifier (Is_Escaped : Boolean) return Idl_Token is Is_A_Keyword : Idl_Keyword_State; Tok : Idl_Token; begin Set_Mark; if not Is_Escaped and then Get_Current_Char = 'L' and then View_Next_Char = ''' then Skip_Char; Set_End_Mark; case Scan_Char (True) is when T_Lit_Char => return T_Lit_Wide_Char; when T_Error => return T_Error; when others => raise Idlac_Errors.Internal_Error; end case; elsif not Is_Escaped and then Get_Current_Char = 'L' and then View_Next_Char = Quotation then Skip_Char; Set_End_Mark; case Scan_String (True) is when T_Lit_String => return T_Lit_Wide_String; when T_Error => return T_Error; when others => raise Idlac_Errors.Internal_Error; end case; else while Is_Identifier_Character (View_Next_Char) loop Skip_Char; end loop; Set_End_Mark; Is_Idl_Keyword (Get_Marked_Text, Is_Escaped, Is_A_Keyword, Tok); case Is_A_Keyword is when Is_Keyword => return Tok; when Is_Identifier => return T_Identifier; when Bad_Case => Idlac_Errors.Error ("Bad identifier or bad case for IDL keyword.", Idlac_Errors.Error, Get_Real_Location); return Tok; end case; end if; end Scan_Identifier; ------------------ -- Scan_Numeric -- ------------------ function Scan_Numeric return Idl_Token is begin Set_Mark; if Get_Current_Char = '0' and then View_Next_Char /= '.' then if View_Next_Char = 'x' or else View_Next_Char = 'X' then Skip_Char; while Is_Hexa_Digit_Character (View_Next_Char) loop Skip_Char; end loop; Set_End_Mark; return T_Lit_Hexa_Integer; elsif Is_Octal_Digit_Character (View_Next_Char) then while Is_Octal_Digit_Character (View_Next_Char) loop Skip_Char; end loop; Set_End_Mark; return T_Lit_Octal_Integer; elsif View_Next_Char = 'D' or else View_Next_Char = 'd' or else View_Next_Char = 'E' or else View_Next_Char = 'e' then null; else -- This is only a digit return T_Lit_Decimal_Integer; end if; end if; if Get_Current_Char /= '.' then while Is_Digit_Character (View_Next_Char) loop Skip_Char; end loop; end if; if Get_Current_Char /= '.' and then View_Next_Char = '.' then Skip_Char; end if; if Get_Current_Char = '.' then while Is_Digit_Character (View_Next_Char) loop Skip_Char; end loop; if View_Next_Char = 'D' or else View_Next_Char = 'd' then Skip_Char; Set_End_Mark; return T_Lit_Floating_Fixed_Point; elsif View_Next_Char = 'E' or else View_Next_Char = 'e' then Skip_Char; if View_Next_Char = '+' or else View_Next_Char = '-' then Skip_Char; end if; while Is_Digit_Character (View_Next_Char) loop Skip_Char; end loop; Set_End_Mark; return T_Lit_Exponent_Floating_Point; else Set_End_Mark; return T_Lit_Simple_Floating_Point; end if; elsif View_Next_Char = 'E' or else View_Next_Char = 'e' then Skip_Char; if View_Next_Char = '+' or else View_Next_Char = '-' then Skip_Char; end if; while Is_Digit_Character (View_Next_Char) loop Skip_Char; end loop; Set_End_Mark; return T_Lit_Pure_Exponent_Floating_Point; elsif View_Next_Char = 'D' or else View_Next_Char = 'd' then Skip_Char; Set_End_Mark; return T_Lit_Simple_Fixed_Point; else Set_End_Mark; return T_Lit_Decimal_Integer; end if; end Scan_Numeric; --------------------- -- Scan_Underscore -- --------------------- function Scan_Underscore return Idl_Token is begin if Is_Alphabetic_Character (View_Next_Char) then Skip_Char; return Scan_Identifier (True); else Idlac_Errors.Error ("Invalid character '_' in identifier", Idlac_Errors.Error, Get_Real_Location); return T_Error; end if; end Scan_Underscore; ----------------------- -- Scan_Preprocessor -- ----------------------- function Scan_Preprocessor return Boolean is use Ada.Characters.Handling; begin Skip_Spaces; case View_Next_Char is when 'A' .. 'Z' | LC_A .. LC_Z | UC_A_Grave .. UC_I_Diaeresis | LC_A_Grave .. LC_I_Diaeresis | UC_N_Tilde .. UC_O_Diaeresis | LC_N_Tilde .. LC_O_Diaeresis | UC_O_Oblique_Stroke .. UC_U_Diaeresis | LC_O_Oblique_Stroke .. LC_U_Diaeresis | LC_German_Sharp_S | LC_Y_Diaeresis => -- This is a preprocessor directive Skip_Char; Set_Mark; while Is_Identifier_Character (View_Next_Char) loop Skip_Char; end loop; Set_End_Mark; if To_Lower (Get_Marked_Text) = "if" or else To_Lower (Get_Marked_Text) = "elif" or else To_Lower (Get_Marked_Text) = "else" or else To_Lower (Get_Marked_Text) = "endif" or else To_Lower (Get_Marked_Text) = "define" or else To_Lower (Get_Marked_Text) = "undef" or else To_Lower (Get_Marked_Text) = "ifdef" or else To_Lower (Get_Marked_Text) = "ifndef" or else To_Lower (Get_Marked_Text) = "include" or else To_Lower (Get_Marked_Text) = "error" then Idlac_Errors.Error ("cannot handle preprocessor directive in " & "lexer, please run cpp first.", Idlac_Errors.Error, Get_Real_Location); Skip_Line; elsif To_Lower (Get_Marked_Text) = "pragma" then Pragma_State := True; return True; else Idlac_Errors.Error ("Unknown preprocessor directive: " & Get_Marked_Text & ".", Idlac_Errors.Error, Get_Real_Location); Skip_Line; end if; when '0' .. '9' => -- Line number and maybe file name must be updated declare New_Line_Number : Natural; Last : Positive; package Natural_IO is new Ada.Text_IO.Integer_IO (Natural); begin Natural_IO.Get (Line (Current_Location.Col .. Line'Last), New_Line_Number, Last); Current_Location.Col := Last; -- GCC-4.1's C preprocessor output "built-in" section with -- line number 0, so we need to check and workaround this -- situation if New_Line_Number /= 0 then Current_Location.Line := New_Line_Number - 1; else Current_Location.Line := 0; end if; Skip_Spaces; case View_Next_Char is when Quotation => -- A filename is present Skip_Char; Set_Mark_On_Next_Char; Go_To_End_Of_String; Set_End_Mark_On_Previous_Char; declare use GNAT.OS_Lib; Text : constant String := Get_Marked_Text; begin if Text (Text'First) = '<' and then Text (Text'Last) = '>' then -- This is an internal # line generated by the -- GCC 3 preprocessor. goto Ignore_Location; end if; -- Verify that the name ends with ".idl" if Text'Length < 4 or else Text (Text'Last - 3 .. Text'Last) /= ".idl" then Idlac_Errors.Error ("An IDL file name must have a " & Ada.Characters.Latin_1.Quotation & ".idl" & Ada.Characters.Latin_1.Quotation & " extension.", Idlac_Errors.Error, Get_Real_Location); end if; Idlac_Errors.Set_Path (Current_Location, Text); end; <> Skip_Spaces; while View_Next_Char /= LF loop -- A flag is present case Next_Char is when '1' | '2' | '3' | '4' => -- Expected, ignore null; when others => -- Unexpected preprocessor output, bail out raise Idlac_Errors.Internal_Error; end case; Skip_Spaces; end loop; when LF => -- End of preprocessor directive null; when others => -- Unexpected preprocessor output, bail out raise Idlac_Errors.Internal_Error; end case; end; when LF => -- End of line return False; when others => pragma Debug (O ("Scan_Preprocessor: bad preprocessor line")); Idlac_Errors.Error ("bad preprocessor line", Idlac_Errors.Error, Get_Real_Location); Skip_Line; end case; return False; end Scan_Preprocessor; ---------------- -- Initialize -- ---------------- procedure Initialize (Filename : String) is use GNAT.OS_Lib; begin if Initialized then Push_State; else Initialized := True; end if; if Filename'Length = 0 then Idlac_Errors.Error ("Missing IDL file as argument", Idlac_Errors.Fatal, Get_Real_Location); return; end if; Current_Location.Line := 0; Current_Location.Col := 0; Current_Line_Len := 0; Idlac_Errors.Set_Path (Current_Location, Filename); Idl_File_Name := new String'(Files.Preprocess_File (Filename)); Ada.Text_IO.Open (Idl_File, Ada.Text_IO.In_File, Idl_File_Name.all); Ada.Text_IO.Set_Input (Idl_File); pragma Debug (O ("Initialize: end")); end Initialize; -------------- -- Finalize -- -------------- procedure Finalize is begin if Idlac_Flags.Keep_Temporary_Files then Ada.Text_IO.Close (Idl_File); else Ada.Text_IO.Delete (Idl_File); end if; if State_Stack.Last /= 0 then Pop_State; else Initialized := False; end if; end Finalize; -------------------- -- Get_Next_Token -- -------------------- function Get_Next_Token return Idl_Token is begin loop case Next_Char is when Space | CR | VT | FF => null; when LF => if Pragma_State then Pragma_State := False; return T_End_Pragma; else null; end if; when HT => Refresh_Offset; when ';' => Set_Token_Location; return T_Semi_Colon; when '{' => Set_Token_Location; return T_Left_Cbracket; when '}' => Set_Token_Location; return T_Right_Cbracket; when ':' => Set_Token_Location; if View_Next_Char = ':' then Skip_Char; return T_Colon_Colon; else return T_Colon; end if; when ',' => Set_Token_Location; return T_Comma; when '(' => Set_Token_Location; return T_Left_Paren; when ')' => Set_Token_Location; return T_Right_Paren; when '=' => Set_Token_Location; return T_Equal; when '|' => Set_Token_Location; return T_Bar; when '^' => Set_Token_Location; return T_Circumflex; when '&' => Set_Token_Location; return T_Ampersand; when '<' => Set_Token_Location; if View_Next_Char = '<' then Skip_Char; return T_Less_Less; else return T_Less; end if; when '>' => Set_Token_Location; if View_Next_Char = '>' then Skip_Char; return T_Greater_Greater; else return T_Greater; end if; when '+' => Set_Token_Location; return T_Plus; when '-' => Set_Token_Location; return T_Minus; when '*' => Set_Token_Location; return T_Star; when '/' => if View_Next_Char = '/' then -- Line comment Skip_Line; elsif View_Next_Char = '*' then -- Start of a multi-line comment Skip_Char; Skip_Comment; else Set_Token_Location; return T_Slash; end if; when '%' => Set_Token_Location; return T_Percent; when '~' => Set_Token_Location; return T_Tilde; when '[' => Set_Token_Location; return T_Left_Sbracket; when ']' => Set_Token_Location; return T_Right_Sbracket; when '0' .. '9' => Set_Token_Location; return Scan_Numeric; when '.' => Set_Token_Location; return Scan_Numeric; when 'A' .. 'Z' | LC_A .. LC_Z | UC_A_Grave .. UC_I_Diaeresis | LC_A_Grave .. LC_I_Diaeresis | UC_N_Tilde .. UC_O_Diaeresis | LC_N_Tilde .. LC_O_Diaeresis | UC_O_Oblique_Stroke .. UC_U_Diaeresis | LC_O_Oblique_Stroke .. LC_U_Diaeresis | LC_German_Sharp_S | LC_Y_Diaeresis => Set_Token_Location; return Scan_Identifier (False); when '_' => Set_Token_Location; return Scan_Underscore; when ''' => Set_Token_Location; return Scan_Char (False); when Quotation => Set_Token_Location; return Scan_String (False); when Number_Sign => Set_Token_Location; if Scan_Preprocessor then return T_Pragma; end if; when others => if Get_Current_Char >= ' ' then Idlac_Errors.Error ("Invalid character '" & Get_Current_Char & "'", Idlac_Errors.Error, Get_Real_Location); else Idlac_Errors.Error ("Invalid character, ASCII code " & Natural'Image (Character'Pos (Get_Current_Char)), Idlac_Errors.Error, Get_Real_Location); end if; return T_Error; end case; end loop; exception when Ada.Text_IO.End_Error => return T_Eof; end Get_Next_Token; package body Lexer_State is ------------------------ -- Get_Lexer_Location -- ------------------------ function Get_Lexer_Location return Idlac_Errors.Location is begin pragma Debug (O ("Get_Lexer_Location: filename is " & Current_Token_Location.Filename.all)); return Current_Token_Location; end Get_Lexer_Location; ---------------------- -- Get_Lexer_String -- ---------------------- function Get_Lexer_String return String renames Get_Marked_Text; end Lexer_State; end Idl_Fe.Lexer; polyorb-2.8~20110207.orig/compilers/idlac/idl_fe-tree-low_level.ads0000644000175000017500000000507311750740337024324 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- I D L _ F E . T R E E . L O W _ L E V E L -- -- -- -- S p e c -- -- -- -- Copyright (C) 2001-2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ package Idl_Fe.Tree.Low_Level is ---------------------------------------------------- -- Low-level manipulations on the tree structure. -- ---------------------------------------------------- procedure Replace_Node (Old_Node : in out Node_Id; New_Node : in out Node_Id); -- Replaces Old_Node with New_Node in the hashtable. -- Sets the Origianal_Node attribute of New_Node to -- Old_Node. function Copy_Node (Old_Node : Node_Id) return Node_Id; -- Create a (shallow) copy of Node. end Idl_Fe.Tree.Low_Level; polyorb-2.8~20110207.orig/compilers/idlac/idl_fe.types.1.ada0000644000175000017500000005565511750740337022674 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- I D L _ F E . T Y P E S -- -- -- -- Copyright (C) 2001-2007, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- $Id$ -- Base types for the IDL front-end (Apex version). with Ada.Unchecked_Deallocation; with Interfaces; with Idlac_Errors; package Idl_Fe.Types is ------------------------------- -- simple type definitions -- ------------------------------- Min_Id : constant := -16#07FF_FFFF#; Max_Id : constant := 16#07FF_FFFF#; type Node_Id is new Integer range Min_Id .. Max_Id; No_Node : constant Node_Id := 0; -- used for the identifiers type String_Cacc is access constant String; -- Identifiers are numbered, in order to make comparaison -- easier and static. Each number is unique. type Uniq_Id is new Natural range 0 .. Max_Id; Nil_Uniq_Id : constant Uniq_Id := 0; type Param_Mode is (Mode_In, Mode_Inout, Mode_Out); -- To manipulate the location of a node subtype Location is Idlac_Errors.Location; procedure Set_Location (N : Node_Id; Loc : Location); function Get_Location (N : Node_Id) return Location; -- Version types for repository_ids type Version_Type is record Major : Interfaces.Unsigned_16; Minor : Interfaces.Unsigned_16; end record; ---------------------------------- -- Management of const values -- ---------------------------------- -- all the possible kind of constants -- These types are used in the evaluation of constants to check -- that each subexpression of an expression does not exceed the -- precision of the final expression. In this context, there's -- no use to distinguish signed and unsigned integers (see CORBA -- V2.3 - 3.9.2), so C_Short for example could be a short or an -- unsigned short. -- In case a subexpression exceeds its supposed precision, the -- types C_general_... can be used to avoid further precision -- checking. type Const_Kind is (C_Short, C_Long, C_LongLong, C_UShort, C_ULong, C_ULongLong, C_Char, C_WChar, C_Boolean, C_Float, C_Double, C_LongDouble, C_Fixed, C_String, C_WString, C_Octet, C_Enum, C_No_Kind, C_General_Integer, C_General_Float, C_General_Fixed); -- Idl types. -- No distinction between intergers or floats here, the same -- type will be used for a short and a long long or for a float -- and a long double. However, the value will be checked and -- correspond to the type of the constant subtype Idl_Integer is Long_Integer; type Idl_String is access String; type Idl_Wide_String is access Wide_String; subtype Idl_Character is Character; subtype Idl_Wide_Character is Wide_Character; subtype Idl_Float is Long_Float; subtype Idl_Boolean is Boolean; -- To deallocate Idl strings procedure Free_Idl_String is new Ada.Unchecked_Deallocation (String, Idl_String); procedure Free_Idl_Wide_String is new Ada.Unchecked_Deallocation (Wide_String, Idl_Wide_String); -- These are the limits for each Idl type. -- This time, the different integer types are distinguished Idl_Octet_Min : constant Idl_Integer := 0; Idl_Octet_Max : constant Idl_Integer := (2 ** 8) - 1; Idl_Short_Min : constant Idl_Integer := (-2 ** 15); Idl_Short_Max : constant Idl_Integer := (2 ** 15) - 1; Idl_Long_Min : constant Idl_Integer := (-2 ** 31); Idl_Long_Max : constant Idl_Integer := (2 ** 31) - 1; Idl_Longlong_Min : constant Idl_Integer := (-2 ** 31); Idl_Longlong_Max : constant Idl_Integer := (2 ** 31) - 1; Idl_UShort_Min : constant Idl_Integer := 0; Idl_UShort_Max : constant Idl_Integer := (2 ** 16) - 1; Idl_ULong_Min : constant Idl_Integer := 0; Idl_ULong_Max : constant Idl_Integer := Idl_Integer'Last; Idl_ULongLong_Min : constant Idl_Integer := 0; Idl_ULongLong_Max : constant Idl_Integer := Idl_ULong_Max ; -- (2 ** 64) - 1; Idl_Float_Min : constant Idl_Float := Idl_Float (Float'First); Idl_Float_Max : constant Idl_Float := Idl_Float (Float'Last); Idl_Double_Min : constant Idl_Float := Idl_Float (Long_Float'First); Idl_Double_Max : constant Idl_Float := Idl_Float (Long_Float'Last); Idl_Long_Double_Min : constant Idl_Float := Idl_Float'First; Idl_Long_Double_Max : constant Idl_Float := Idl_Float'Last; Idl_Enum_Max : constant Idl_Integer := Idl_Longlong_Max; -- definition of a constant, depending on its kind -- This type is also used to specify a constant type type Constant_Value (Kind : Const_Kind) is record case Kind is when C_Octet | C_Short | C_Long | C_LongLong | C_UShort | C_ULong | C_ULongLong | C_General_Integer => Integer_Value : Idl_Integer; when C_Char => Char_Value : Idl_Character; when C_WChar => WChar_Value : Idl_Wide_Character; when C_Boolean => Boolean_Value : Idl_Boolean; when C_Float | C_Double | C_LongDouble | C_General_Float => Float_Value : Idl_Float; when C_String => String_Length : Idl_Integer; String_Value : Idl_String; when C_WString => WString_Length : Idl_Integer; WString_Value : Idl_Wide_String; when C_Fixed | C_General_Fixed => Fixed_Value : Idl_Integer; Digits_Nb : Idl_Integer; Scale : Idl_Integer; when C_Enum => Enum_Name : Node_Id; Enum_Value : Node_Id; when C_No_Kind => null; end case; end record; type Constant_Value_Ptr is access Constant_Value; -- to duplicate a constant_value_ptr function Duplicate (C : Constant_Value_Ptr) return Constant_Value_Ptr; -- to deallocate a constant_value_ptr procedure Free (C : in out Constant_Value_Ptr); --------------------------------- -- A useful list of root nodes -- --------------------------------- type Node_List is private; -- A list of nodes. type Node_Iterator is private; -- An iterator on a node list. -- the empty list Nil_List : constant Node_List; function Head (NL : Node_List) return Node_Id; -- Return the first node in NL. function Is_Empty (NL : Node_List) return Boolean; -- True iff NL is empty. function Length (NL : Node_List) return Natural; -- The length of a list. -- Simple way to iterate over a node_list. -- NODE_ITERATOR is a type representing an iterator, which must -- be initialiazed by INIT. -- End of list is detected by IS_END. -- Until the end of list is reached, the node can be extracted -- with GET_NODE and the iterator can be incremented with NEXT. -- Therefore, usual way to use an iterator is: -- declare -- it: node_iterator; -- node: node_id; -- begin -- init (it, rep.contents); -- while not is_end (it) loop -- get_next_node (it, node); -- ... -- end loop; -- end; procedure Init (It : out Node_Iterator; List : Node_List); procedure Get_Next_Node (It : in out Node_Iterator; Node : out Node_Id); function Is_End (It : Node_Iterator) return Boolean; -- Appends a node at the end of a list. procedure Append_Node (List : in out Node_List; Node : Node_Id); -- Appends a node at the end of a list. function Append_Node (List : Node_List; Node : Node_Id) return Node_List; procedure Remove_Node (List : in out Node_List; Node : Node_Id); function Remove_Node (List : Node_List; Node : Node_Id) return Node_List; -- Remove the first occurrence of Node from List -- Insert Node into List immediately before the first -- occurrence of Before. procedure Insert_Before (List : in out Node_List; Node : Node_Id; Before : Node_Id); -- Insert Node into List immediately after the first -- occurrence of After. procedure Insert_After (List : Node_List; Node : Node_Id; After : Node_Id); -- Look whether node is in list or not function Is_In_List (List : Node_List; Node : Node_Id) return Boolean; -- Look whether node is in the list or not -- node is supposed to be a scoped name and the list must be -- a list of scoped names. What is compared here is not the nodes -- themselves but the node they are pointing to function Is_In_Pointed_List (List : Node_List; Node : Node_Id) return Boolean; -- Frees all the list procedure Free (List : in out Node_List); -- computes the length of the list function Get_Length (List : Node_List) return Integer; -- Function that take a node list and remove all the redondant items -- returns the resulting node list -- useful for the inheritance treatement function Simplify_Node_List (In_List : Node_List) return Node_List; procedure Merge_List (Into : in out Node_List; From : Node_List); -- Appends all nodes of list From to list Into, unless they are -- in it already. ---------------------------------------- -- Type of an identifier definition -- ---------------------------------------- -- An identifier definition contains the following : -- - the name of the identifier -- - the uniq_id of the identifier -- - the node in which it was defined -- - the previous definition of the same identifier (if overloaded) -- - a pointer on the parent scope of the node type Identifier_Definition; type Identifier_Definition_Acc is access Identifier_Definition; type Identifier_Definition is record Name : String_Cacc := null; Id : Uniq_Id; Node : Node_Id; Previous_Definition : Identifier_Definition_Acc; Parent_Scope : Node_Id; end record; -- Definition of a list of identifier_definition type Identifier_Definition_List is private; -- Return the named node corresponding to the identifier -- definition. -- Raises fatal_error if Cell is a null pointer function Get_Node (Definition : Identifier_Definition_Acc) return Node_Id; ---------------------- -- scope handling -- ---------------------- -- Scopes are stacked and create an identifier space. -- In a scope, an identifier has at most one meaning. function Get_Root_Scope return Node_Id; function Get_Current_Scope return Node_Id; -- Get the root (the oldest) and current (the newest) scope. function Get_Current_Gen_Scope return Node_Id; -- Return the current repository, idl file, module, -- interface or valuetype. function Get_Previous_Scope return Node_Id; -- Get the scope of the current scope procedure Push_Scope (Scope : Node_Id); -- Create a new scope, defined by a Scope node, add it in -- the current scope, and activate it. procedure Pop_Scope; -- Unstack the current scope. -- In order to ensure that each forward definition of a value -- or an interface is implemented in the same scope, here are -- some methods to take forward declarations and implementations -- into account procedure Add_Int_Val_Forward (Node : Node_Id); -- To add a forward declaration in the list procedure Add_Int_Val_Definition (Node : Node_Id); -- To take an implementation into account and remove the -- corresponding forward declaration from the list. -------------------------- -- Identifiers handling -- -------------------------- function Is_Redefinable (Name : String; Loc : Idlac_Errors.Location; Scope : Node_Id := No_Node) return Boolean; -- Check if the name is redefinable in Scope or in the current scope -- (default). If result is false, means that Find_Identifier_Definition -- has a NOT NULL result! -- Loc is the location of the attempted redefinition. function Find_Identifier_Definition (Name : String; Loc : Idlac_Errors.Location) return Identifier_Definition_Acc; -- Find the definition associated with the usage occurence of -- identifier Name located at Loc. -- If this identifier is not defined, returns a null pointer. function Find_Identifier_Node (Name : String; Loc : Idlac_Errors.Location) return Node_Id; -- Find the node associated with the usage occurence of -- identifier Name located at Loc. -- If this identifier is not defined, returns a null pointer. procedure Redefine_Identifier (A_Definition : Identifier_Definition_Acc; Node : Node_Id); -- Change the definition (associed node) of CELL. -- only used in the case of a forward interface definition function Add_Identifier (Node : Node_Id; Name : String; Scope : Node_Id := No_Node; Is_Inheritable : Boolean := True) return Boolean; -- Creates an identifier definition for the current identifier -- and add it to scope Scope or the current scope if Scope is No_Node. -- Node is the node where the identifier is defined. If Is_Inheritable -- is False, then this identifier will not be considered when resolving -- names in scopes that inherit from this one. -- Returns true if successful, False if the identifier was -- already in this scope. function Find_Identifier_In_Storage (Scope : Node_Id; Name : String; Inheritable_Only : Boolean := False) return Identifier_Definition_Acc; -- Find the identifier definition in Scope. If Inheritable_Only, -- do not consider identifiers that were marked as not eligible -- for inheritance. -- If this identifier is not defined, returns a null pointer. function Find_Imported_Identifier_Definition (Name : String) return Identifier_Definition_Acc; -- Find the identifier definition in the imported table. -- If this identifier is not defined, returns a null pointer. procedure Add_Definition_To_Imported (Definition : Identifier_Definition_Acc; Scope : Node_Id); -- Add the imported definition to the given scope imported table. procedure Find_Identifier_In_Inheritance (Name : String; Scope : Node_Id; List : in out Node_List); -- Find the identifier in the scope's parents (in each one recursively) -- add the different definitions to the node list -- it is useful for looking in the inherited interfaces or value types ----------------------- -- Identifiers table -- ----------------------- -- Each identifier is assigned a unique id number. This number is -- its location in the table of all the identifiers definitions: -- the Id_Table. -- In order to easily find a given identifier in the Id_Table, -- a hash table is used to store the mapping of identifier names -- to unique identifiers: the Hash_Table. -- The Hash_Table retains the position in the Id_Table of the first -- identifier defined for each possible hash value. All the -- identifiers having the same hash value are then linked: each one -- has a pointer on the next defined: Next. -- dimension of the hashtable type Hash_Value_Type is mod 2**32; -- dimension of the hashtable Hash_Mod : constant Hash_Value_Type := 2053; -- The hash table of the location of the identifiers in the -- id_table type Hash_Table_Type is array (0 .. Hash_Mod - 1) of Uniq_Id; Hash_Table : Hash_Table_Type := (others => Nil_Uniq_Id); -- An entry in the ID table, containing: -- - the Identifier_Definition; -- - a flag indicating whether this entry can be incorporated -- into another (interface or valuetype) scope by inheritance -- (meant for use only during expansion); -- - a pointer to the entry correponding to the next definition -- of an identifier with the same hash value. type Hash_Entry is record Definition : Identifier_Definition_Acc := null; Is_Inheritable : Boolean := True; Next : Uniq_Id := Nil_Uniq_Id; end record; ---------------------------------- -- The Gnat_Table adapted type -- ---------------------------------- -- This section provides an implementation of dynamically resizable one -- dimensional array type.The idea is to mimic the normal Ada semantics for -- arrays as closely as possible with the one additional capability of -- dynamically modifying the value of the Last attribute. -- we are defining the type of the table type Table_Type is array (Uniq_Id range <>) of Hash_Entry; subtype Big_Table_Type is Table_Type (Nil_Uniq_Id + 1 .. Uniq_Id'Last); -- The table is actually represented as a pointer to allow reallocation type Table_Ptr is access all Big_Table_Type; -- the table type that will be instantiated type Table is record -- the table Table : Table_Ptr := null; -- Subscript of the maximum entry in the currently allocated table Max : Integer := Integer (Nil_Uniq_Id); -- Number of entries in currently allocated table. The value of zero -- ensures that we initially allocate the table. Length : Integer := 0; -- Current value of Last. Last_Val : Integer := Integer (Nil_Uniq_Id); end record; -- the location of the first element of the table (it is constant) First : constant Uniq_Id := Nil_Uniq_Id + 1; -- Table expansion is permitted only if this switch is set to False. A -- client may set Locked to True, in which case any attempt to expand -- the table will cause an assertion failure. Note that while a table -- is locked, its address in memory remains fixed and unchanging. Locked : Boolean := False; -- This procedure allocates a new table of size Initial (freeing any -- previously allocated larger table). It is not necessary to call -- Init when a table is first instantiated (since reallocate works -- with a null table). However, it is harmless to do so, and -- Init is convenient in reestablishing a table for new use. procedure Init (T : in out Table); -- Returns the current value of the last used entry in the table, which -- can then be used as a subscript for Table. Note that the only way to -- modify Last is to call the Set_Last procedure. Last must always be -- used to determine the logically last entry. function Last (T : Table) return Uniq_Id; -- Storage is allocated in chunks according to the values given in the -- Initial and Increment parameters. A call to Release releases all -- storage that is allocated, but is not logically part of the current -- array value. Current array values are not affected by this call. procedure Release (T : in out Table); -- This procedure sets Last to the indicated value. If necessary the -- table is reallocated to accomodate the new value (i.e. on return -- the allocated table has an upper bound of at least Last). If Set_Last -- reduces the size of the table, then logically entries are removed -- from the table. If Set_Last increases the size of the table, then -- new entries are logically added to the table. procedure Set_Last (T : in out Table; New_Val : Uniq_Id); -- Adds 1 to Last (same as Set_Last (Last + 1). procedure Increment_Last (T : in out Table); -- Subtracts 1 from Last (same as Set_Last (Last - 1). procedure Decrement_Last (T : in out Table); -- Adds Num to T.Last_val, and returns the old value of T.Last_Val + 1. procedure Allocate (T : in out Table; Num : Integer := 1; Result : out Uniq_Id); ------------------------------------------------- -- the structure used for storing identifiers -- ------------------------------------------------- type Storage is record Hash_Table : Hash_Table_Type := (others => Nil_Uniq_Id); Content_Table : Table; end record; ----------------------------------- -- dealing with Repository_Ids -- ----------------------------------- procedure Set_Default_Repository_Id (Node : Node_Id); -- Set Node's default repository id. procedure Set_Initial_Current_Prefix (Node : Node_Id); -- Set the current prefix for scope Node -- from its parent's. private ---------------------------------------- -- Type of an identifier definition -- ---------------------------------------- -- classical definition of a list for the identifier_definition_list type Identifier_Definition_Cell; type Identifier_Definition_List is access Identifier_Definition_Cell; type Identifier_Definition_Cell is record Definition : Identifier_Definition_Acc; Next : Identifier_Definition_List; end record; -- The hashing function. Takes an identifier and return its hash -- value function Hash (Str : String) return Hash_Value_Type; --------------- -- Node list -- --------------- type Node_List_Cell; type Node_List is access Node_List_Cell; type Node_List_Cell is record Car : Node_Id := No_Node; Cdr : Node_List := null; end record; Nil_List : constant Node_List := null; type Node_Iterator is new Node_List; end Idl_Fe.Types; polyorb-2.8~20110207.orig/compilers/idlac/ada_be-temporaries.ads0000644000175000017500000000576211750740337023707 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- A D A _ B E . T E M P O R A R I E S -- -- -- -- S p e c -- -- -- -- Copyright (C) 2001-2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ package Ada_Be.Temporaries is pragma Preelaborate; function T_Handler return String; function T_Returns return String; function T_Send_Request_Result return String; function T_Self_Ref return String; function T_Exception_Repo_Id return String; function T_Members return String; function T_Impl_Object_Ptr return String; function T_Value_Operation return String; function T_Request return String; function T_Ctx return String; function T_Argument return String; function T_Arg_Any return String; function T_Arg_CC return String; function T_Arg_List return String; function T_Arg_Name return String; function T_Content return String; function T_Excp_List return String; function T_Helpers return String; function T_Indices return String; function T_Lengths return String; function T_Ptr return String; function T_Result return String; function T_Result_Name return String; function T_J return String; end Ada_Be.Temporaries; polyorb-2.8~20110207.orig/compilers/idlac/idlac_errors.adb0000644000175000017500000002310711750740337022604 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- I D L A C _ E R R O R S -- -- -- -- B o d y -- -- -- -- Copyright (C) 2001-2008, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with Ada.Strings.Fixed; use Ada.Strings, Ada.Strings.Fixed; with Ada.Strings.Maps; with Ada.Text_IO; use Ada.Text_IO; with GNAT.Directory_Operations; with Idlac_Flags; use Idlac_Flags; with Idlac_Utils; use Idlac_Utils; with Utils; package body Idlac_Errors is ------------------------- -- Location handling -- ------------------------- procedure Display_Error (Message : String; Level : Error_Kind; Loc : Location); -- Display an error procedure Pinpoint_Error (Message : String; Loc : Location); -- Print a full description of the error message with pointers -- on the error location. function Full_Name (Loc : Location) return String; -- Return the full file name (i.e., a usable one), or "" if -- unknown. function Resolve_Tabs (S : String) return String; -- Return a string where tabs have been properly expanded -------------------------- -- Location_To_String -- -------------------------- function Location_To_String (Loc : Location; Short : Boolean := False) return String is Path : constant String := Full_Name (Loc); Line : constant String := Img (Loc.Line); Column : constant String := Img (Loc.Col); begin if Short then return Path & ':' & Line & ':' & Column; else return "line " & Line & ", column " & Column & " of file " & Path; end if; end Location_To_String; ---------------- -- Set_Path -- ---------------- procedure Set_Path (Loc : in out Location; Filename : String) is use Ada.Strings.Maps; Separator : constant Natural := Index (Filename, To_Set (GNAT.Directory_Operations.Dir_Separator & '/'), Inside, Backward); begin if Separator /= 0 then Loc.Dirname := new String'(Filename (Filename'First .. Separator - 1)); Loc.Filename := new String'(Filename (Separator + 1 .. Filename'Last)); else Loc.Dirname := null; Loc.Filename := new String'(Filename); end if; end Set_Path; ---------------------- -- Error handling -- ---------------------- -- counters for errors and warnings Error_Count : Natural := 0; Warning_Count : Natural := 0; --------------------- -- Display_Error -- --------------------- procedure Display_Error (Message : String; Level : Error_Kind; Loc : Location) is begin case Level is when Fatal => Pinpoint_Error ("Fatal: " & Message, Loc); when Error => Pinpoint_Error ("Error: " & Message, Loc); when Warning => Pinpoint_Error ("Warning: " & Message, Loc); end case; end Display_Error; ----------- -- Error -- ----------- procedure Error (Message : String; Level : Error_Kind; Loc : Location) is begin case Level is when Fatal => null; when Error => Error_Count := Error_Count + 1; when Warning => Warning_Count := Warning_Count + 1; end case; Display_Error (Message, Level, Loc); if Level = Fatal then raise Fatal_Error; end if; end Error; ---------------- -- Is_Error -- ---------------- function Is_Error return Boolean is begin return Error_Count > 0; end Is_Error; ------------------ -- Is_Warning -- ------------------ function Is_Warning return Boolean is begin return Warning_Count > 0; end Is_Warning; -------------------- -- Error_Number -- -------------------- function Error_Number return Natural is begin return Error_Count; end Error_Number; ---------------------- -- Warning_Number -- ---------------------- function Warning_Number return Natural is begin return Warning_Count; end Warning_Number; --------------- -- Full_Name -- --------------- function Full_Name (Loc : Location) return String is begin if Loc.Filename = null then return ""; elsif Loc.Dirname = null then return Loc.Filename.all; elsif Utils.Is_Dir_Separator (Loc.Dirname (Loc.Dirname'Last)) then return Loc.Dirname.all & Loc.Filename.all; else return Loc.Dirname.all & GNAT.Directory_Operations.Dir_Separator & Loc.Filename.all; end if; end Full_Name; -------------------- -- PinPoint_Error -- -------------------- procedure Pinpoint_Error (Message : String; Loc : Location) is procedure Format (Message : String); -- Format an error message so that it fits (hopefully) on a 80 -- characters screen. ------------ -- Format -- ------------ procedure Format (Message : String) is Sep : Natural; begin if Message = "" then return; elsif Message (Message'First) = ' ' then Format (Message (Message'First + 1 .. Message'Last)); return; end if; Put (Current_Error, " >>> "); if Message'Length <= 75 then Put_Line (Current_Error, Message); else Sep := Index (Message (Message'First .. Message'First + 74), " ", Backward); if Sep = 0 then Put_Line (Current_Error, Message (Message'First .. Message'First + 74)); Format (Message (Message'First + 75 .. Message'Last)); else Put_Line (Current_Error, Message (Message'First .. Sep - 1)); Format (Message (Sep + 1 .. Message'Last)); end if; end if; end Format; begin if Verbose and then Loc.Line > 0 and then Loc.Col > 0 then Put_Line (Current_Error, "In file " & Full_Name (Loc)); New_Line (Current_Error); declare File_Name : constant String := Full_Name (Loc); File : File_Type; Line : String (1 .. 1024); Last : Natural; LN : constant String := Img (Loc.Line); LNN : constant Positive := LN'Length; begin Open (File, In_File, File_Name); for I in 1 .. Loc.Line loop Get_Line (File, Line, Last); end loop; Put_Line (Current_Error, LN & " " & Resolve_Tabs (Line (1 .. Last))); for I in 1 .. LNN + 3 + Loc.Col loop Put (Current_Error, " "); end loop; Put_Line (Current_Error, "^"); Format (Message); Close (File); exception when Name_Error => Put_Line (Current_Error, Message); end; New_Line (Current_Error); else Put_Line (Current_Error, Location_To_String (Loc, Short => True) & ' ' & Message); end if; end Pinpoint_Error; ------------------ -- Resolve_Tabs -- ------------------ function Resolve_Tabs (S : String) return String is R : String (1 .. S'Length * 8); L : Natural := 0; begin for I in S'Range loop if S (I) = ASCII.HT then for J in 1 .. 8 - (L mod 8) loop L := L + 1; R (L) := ' '; end loop; else L := L + 1; R (L) := S (I); end if; end loop; return R (1 .. L); end Resolve_Tabs; end Idlac_Errors; polyorb-2.8~20110207.orig/compilers/idlac/ada_be-idl2ada-helper.adb0000644000175000017500000037553511750740337024121 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- A D A _ B E . I D L 2 A D A . H E L P E R -- -- -- -- B o d y -- -- -- -- Copyright (C) 2001-2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with Ada.Strings.Unbounded; with Idl_Fe.Tree; use Idl_Fe.Tree; with Idl_Fe.Tree.Synthetic; use Idl_Fe.Tree.Synthetic; with Ada_Be.Identifiers; use Ada_Be.Identifiers; with Ada_Be.Mappings.CORBA; use Ada_Be.Mappings.CORBA; with Ada_Be.Temporaries; use Ada_Be.Temporaries; with Ada_Be.Debug; pragma Elaborate_All (Ada_Be.Debug); with Idlac_Errors; use Idlac_Errors; with Platform; use Platform; with String_Sets; use String_Sets; with Idlac_Utils; use Idlac_Utils; package body Ada_Be.Idl2Ada.Helper is Flag : constant Natural := Ada_Be.Debug.Is_Active ("ada_be.idl2ada.helper"); procedure O is new Ada_Be.Debug.Output (Flag); pragma Warnings (Off); pragma Unreferenced (O); pragma Warnings (On); ---------------------- -- Utility routines -- ---------------------- procedure Gen_From_Any_Profile (CU : in out Compilation_Unit; Type_Node : Node_Id; From_Container : Boolean); -- Generate the profile for the From_Any operation of a type. -- If From_Container is true, formal parameter is an Any_Container'Class, -- else it is an Any. procedure Gen_To_Any_Profile (CU : in out Compilation_Unit; Type_Node : Node_Id); -- Generate the profile for the To_Any operation of a type procedure Gen_Raise_From_Any_Profile (CU : in out Compilation_Unit; Node : Node_Id); -- Generate the Raise__From_Any procedure for an -- exception. The name of the procedure is -- Raise_From_Any_Name (Node). procedure Gen_Raise_Profile (CU : in out Compilation_Unit; Node : Node_Id); -- Generate the Raise_ procedure for an exception. -------------------------------- -- Aggregate content wrappers -- -------------------------------- procedure Gen_Aggregate_Content_Wrapper_Spec (CU : in out Compilation_Unit; Node : Node_Id); -- For an aggregate type, generate an Aggregate_Content derived type with -- the declaration of the appropriate primitive operations. procedure Gen_Aggregate_Content_Wrapper_Body (CU : in out Compilation_Unit; Node : Node_Id); -- Generate the bodies of the Aggregate_Content primitive operations for -- Node. procedure Gen_Get_Aggregate_Element_Profile (CU : in out Compilation_Unit; Node : Node_Id); -- Generate the profile of the Get_Aggregate_Element primitive operation procedure Gen_Set_Aggregate_Element_Profile (CU : in out Compilation_Unit; Node : Node_Id); -- Generate the profile of the Set_Aggregate_Element primitive operation procedure Gen_Get_Aggregate_Count_Profile (CU : in out Compilation_Unit; Node : Node_Id); -- Generate the profile of the Get_Aggregate_Count primitive operation procedure Gen_Set_Aggregate_Count_Profile (CU : in out Compilation_Unit; Node : Node_Id); -- Generate the profile of the Set_Aggregate_Count primitive operation procedure Gen_Clone_Profile (CU : in out Compilation_Unit; Node : Node_Id); -- Generate the profile of the Clone primitive operation procedure Gen_Finalize_Value_Profile (CU : in out Compilation_Unit; Node : Node_Id); -- Generate the profile of the Finalize_Value primitive operation procedure Gen_Wrap_Profile (CU : in out Compilation_Unit; Node : Node_Id); -- Generate the profile of the Wrap function ----------------------------------------------------------- -- Specialised generation subprograms for each node kind -- ----------------------------------------------------------- procedure Gen_Interface_Spec (CU : in out Compilation_Unit; Node : Node_Id); -- Generate the spec of the helper package for an interface declaration procedure Gen_Interface_Body (CU : in out Compilation_Unit; Node : Node_Id); -- Generate the body of the helper package for an interface declaration procedure Gen_ValueType_Spec (CU : in out Compilation_Unit; Node : Node_Id); -- Generate the spec of the helper package for a valuetype declaration procedure Gen_ValueType_Body (CU : in out Compilation_Unit; Node : Node_Id); -- Generate the body of the helper package for a valuetype declaration procedure Gen_Enum_Spec (CU : in out Compilation_Unit; Node : Node_Id); -- Generate the spec of the helper package for an enum declaration procedure Gen_Enum_Body (CU : in out Compilation_Unit; Node : Node_Id); -- Generate the body of the helper package for an enum declaration procedure Gen_Struct_Exception_Spec (CU : in out Compilation_Unit; Node : Node_Id); -- Generate the spec of the helper package for a struct or an -- exception declaration procedure Gen_Struct_Exception_Body (CU : in out Compilation_Unit; Node : Node_Id); -- Generate the body of the helper package for a struct or an -- exception declaration procedure Gen_String_Instance_Spec (CU : in out Compilation_Unit; Node : Node_Id); -- Generate the spec of the helper package for a string instance procedure Gen_String_Instance_Body (CU : in out Compilation_Unit; Node : Node_Id); -- Generate the body of the helper package for a string instance procedure Gen_Union_Spec (CU : in out Compilation_Unit; Node : Node_Id); -- Generate the spec of the helper package for an union declaration procedure Gen_Union_Body (CU : in out Compilation_Unit; Node : Node_Id); -- Generate the body of the helper package for an union declaration procedure Gen_Type_Declarator_Spec (CU : in out Compilation_Unit; Node : Node_Id); -- Generate the spec of the helper package for an array declaration procedure Gen_Type_Declarator_Body (CU : in out Compilation_Unit; Node : Node_Id); -- Generate the body of the helper package for an array declaration procedure Gen_Sequence_Spec (CU : in out Compilation_Unit; Node : Node_Id); -- Generate the spec of the helper package for a sequence declaration procedure Gen_Sequence_Body (CU : in out Compilation_Unit; Node : Node_Id); -- Generate the body of the helper package for a sequence declaration procedure Gen_Fixed_Spec (CU : in out Compilation_Unit; Decl_Node : Node_Id); -- Generate the spec of the helper package for a fixed type declaration procedure Gen_Fixed_Body (CU : in out Compilation_Unit; Decl_Node : Node_Id); -- Generate the body of the helper package for a fixed type declaration procedure Gen_Array_TC (CU : in out Compilation_Unit; Element_Type_Node : Node_Id; Decl_Node : Node_Id); -- generate lines to fill in an array typecode -- only used in the type_declarator part of gen_node_body function Raise_From_Any_Name (Node : Node_Id) return String; -- Return the name of a procedure that raises that exception -- from an occurrence stored in an Any. function Raise_Name (Node : Node_Id) return String; -- Return the name of a procedure that raises that exception -- with specified members values. function Type_Modifier (Node : Node_Id) return String; -- Return the type modifier associed with the ValueType Node function Visibility (Node : Node_Id) return String; -- Return the visibility of a state member function Loop_Parameter (Dim : Natural) return String; -- Return a unique name for the Dim'th loop parameter -- for iteration over an array. ---------------------------------------------- -- End of internal subprograms declarations -- ---------------------------------------------- Helper_Deps : String_Sets.Set; -- Cache of already recorded helper dependencies --------------------------- -- Add_Helper_Dependency -- --------------------------- procedure Add_Helper_Dependency (CU : in out Compilation_Unit; Helper_Name : String) is Previous_Diversion : constant Diversion := Current_Diversion (CU); Dep_Key : constant String := Name (CU) & '/' & Helper_Name; begin if Contains (Helper_Deps, Dep_Key) then -- This dependency is already set return; end if; Insert (Helper_Deps, Dep_Key); Add_With (CU, Helper_Name); Divert (CU, Initialization_Dependencies); if Helper_Name = "CORBA.Object.Helper" then PL (CU, "& ""corba.object"""); elsif Helper_Name = "CORBA.Helper" then PL (CU, "& ""corba.helper"""); elsif Helper_Name /= "CORBA" and then Helper_Name /= Name (CU) then PL (CU, "& """ & Helper_Name & """"); end if; Divert (CU, Previous_Diversion); end Add_Helper_Dependency; ---------------------------------------- -- Gen_Aggregate_Content_Wrapper_Spec -- ---------------------------------------- procedure Gen_Aggregate_Content_Wrapper_Spec (CU : in out Compilation_Unit; Node : Node_Id) is begin Gen_Wrap_Profile (CU, Node); PL (CU, ";"); end Gen_Aggregate_Content_Wrapper_Spec; ---------------------------------------- -- Gen_Aggregate_Content_Wrapper_Body -- ---------------------------------------- procedure Gen_Aggregate_Content_Wrapper_Body (CU : in out Compilation_Unit; Node : Node_Id) is Members_Count : Integer; -- Members count for this aggregate kind if known at compile time; -- -1 if dynamic. Dim : Integer; -- Dimensionality, for the array case NK : constant Node_Kind := Kind (Node); Index : Natural; It : Node_Iterator; M_Node : Node_Id; begin -- Content_ and declarations for its overriding subprograms Add_With (CU, "PolyORB.Types"); NL (CU); if NK = K_Declarator then Dim := Length (Array_Bounds (Node)); if Dim > 1 then PL (CU, "type " & T_Indices & Ada_Name (Node) & " is array (1 .." & Integer'Image (Dim - 1) & ") of Integer;"); end if; end if; PL (CU, "type " & T_Ptr & Ada_Name (Node) & " is access all " & Ada_Type_Name (Node) & ";"); PL (CU, "type " & T_Content & Ada_Name (Node) & " is"); PL (CU, " new PolyORB.Any.Aggregate_Content with"); PL (CU, "record"); II (CU); PL (CU, "V : " & T_Ptr & Ada_Name (Node) & ";"); case NK is when K_Declarator => if Dim > 1 then PL (CU, "Dimen : Positive;"); PL (CU, "Indices : " & T_Indices & Ada_Name (Node) & ";"); end if; when K_Enum => PL (CU, "Repr_Cache : aliased PolyORB.Types.Unsigned_Long;"); when K_Union => PL (CU, "Switch_Cache : aliased " & Ada_Type_Name (Switch_Type (Node)) & ";"); when others => null; end case; DI (CU); PL (CU, "end record;"); NL (CU); Gen_Get_Aggregate_Element_Profile (CU, Node); PL (CU, ";"); case NK is when K_Enum | K_Union => Gen_Set_Aggregate_Element_Profile (CU, Node); PL (CU, ";"); when others => null; end case; -- XXX Ada 2005: These should be declared 'overriding' Gen_Get_Aggregate_Count_Profile (CU, Node); PL (CU, ";"); Gen_Set_Aggregate_Count_Profile (CU, Node); PL (CU, ";"); Gen_Clone_Profile (CU, Node); PL (CU, ";"); Gen_Finalize_Value_Profile (CU, Node); PL (CU, ";"); -- Pre-compute members count, if appropriate case NK is when K_Enum => Members_Count := 1; when K_Union => Members_Count := 2; when K_Struct => Members_Count := -1; -- Will be updated below while generating Get_Aggregate_Element. -- We can't just use Length (Members (Node)) because some members -- may have several declarators. when K_Declarator => Members_Count := -1; when others => Error ("No Member_Count for " & NK'Img & " nodes.", Fatal, Get_Location (Node)); -- Keep the compiler happy raise Program_Error; end case; -- Array lengths list if NK = K_Declarator then declare Bound_Node : Node_Id; Bounds_It : Node_Iterator; Index : Positive; begin NL (CU); Put (CU, T_Lengths & Ada_Name (Node) & " : constant array (1 .." & Dim'Img & ") of PolyORB.Types.Unsigned_Long := ("); Index := 1; Init (Bounds_It, Array_Bounds (Node)); while not Is_End (Bounds_It) loop Get_Next_Node (Bounds_It, Bound_Node); if Index > 1 then Put (CU, ", "); end if; Put (CU, Img (Index) & " => "); Gen_Constant_Value (CU, Expr => Bound_Node, Typ => No_Node); Index := Index + 1; end loop; PL (CU, ");"); end; end if; -- Get_Aggregate_Element NL (CU); Gen_Get_Aggregate_Element_Profile (CU, Node); NL (CU); PL (CU, "is"); II (CU); PL (CU, "use type PolyORB.Types.Unsigned_Long;"); PL (CU, "use type PolyORB.Any.Mechanism;"); -- ACC.V might be uninitialized and have an invalid representation -- (case of Get_Aggregate_Element being called from within an -- unmarshall routine), in which case we know that we will -- overwrite it without using the invalid value; we must -- disable validity checks here so that we do not fail a runtime -- check on the bogus value. PL (CU, "pragma Suppress (" & Validity_Check_Name & ");"); -- The TypeCode formal is of no use here (we always statically know -- the type of each aggregate element). PL (CU, "pragma Unreferenced (TC);"); if NK = K_Enum then -- An enum always has exactly one element, so we can ignore the -- provided index. PL (CU, "pragma Unreferenced (Index);"); end if; DI (CU); PL (CU, "begin"); II (CU); case NK is when K_Enum => PL (CU, "ACC.Repr_Cache := " & Ada_Type_Name (Node) & "'Pos (ACC.V.all);"); PL (CU, "Mech.all := PolyORB.Any.By_Value;"); PL (CU, "return PolyORB.Any.Wrap " & "(ACC.Repr_Cache'Unrestricted_Access);"); when K_Struct => PL (CU, "Mech.all := PolyORB.Any.By_Reference;"); PL (CU, "case Index is"); II (CU); Index := 0; Init (It, Members (Node)); while not Is_End (It) loop Get_Next_Node (It, M_Node); declare M_Typ : constant Node_Id := M_Type (M_Node); It2 : Node_Iterator; M_Decl : Node_Id; begin Init (It2, Decl (M_Node)); while not Is_End (It2) loop Get_Next_Node (It2, M_Decl); PL (CU, "when" & Index'Img & " =>"); II (CU); Put (CU, "return "); Gen_Wrap_Call (CU, M_Typ, "ACC.V." & Ada_Name (M_Decl)); PL (CU, ";"); DI (CU); Index := Index + 1; end loop; end; end loop; PL (CU, "when others =>"); II (CU); PL (CU, "raise Constraint_Error;"); DI (CU); DI (CU); PL (CU, "end case;"); Members_Count := Index; when K_Declarator => PL (CU, "Mech.all := PolyORB.Any.By_Reference;"); if Dim > 1 then PL (CU, "if ACC.Dimen < " & Img (Dim) & " then"); II (CU); PL (CU, "declare"); II (CU); PL (CU, "R_ACC : " & T_Content & Ada_Name (Node) & " := ACC.all;"); DI (CU); PL (CU, "begin"); II (CU); PL (CU, "R_ACC.Indices (R_ACC.Dimen) := Integer (Index);"); PL (CU, "R_ACC.Dimen := R_ACC.Dimen + 1;"); PL (CU, "return R_ACC;"); DI (CU); PL (CU, "end;"); DI (CU); PL (CU, "else"); II (CU); end if; declare use Ada.Strings.Unbounded; Elt_Reference : Unbounded_String; begin Put (CU, "return "); Elt_Reference := To_Unbounded_String ("ACC.V ("); for J in 1 .. Dim - 1 loop Append (Elt_Reference, "ACC.Indices (" & Img (J) & "), "); end loop; Append (Elt_Reference, "Integer (Index))"); Gen_Wrap_Call (CU, T_Type (Parent (Node)), To_String (Elt_Reference)); PL (CU, ";"); end; if Dim > 1 then DI (CU); PL (CU, "end if;"); end if; when K_Union => -- Discriminant case PL (CU, "if Index = 0 then"); II (CU); -- Discriminant must be managed by value, because changing the -- discriminant value requires a complete record aggregate -- assignment. We provide a distinct component as we do not want -- the current discriminant to be altered in place. PL (CU, "Mech.all := PolyORB.Any.By_Value;"); PL (CU, "ACC.Switch_Cache := ACC.V.Switch;"); Put (CU, "return "); Gen_Wrap_Call (CU, Switch_Type (Node), "ACC.Switch_Cache"); PL (CU, ";"); DI (CU); PL (CU, "else"); II (CU); -- Union member case PL (CU, "pragma Assert (Index = 1);"); PL (CU, "Mech.all := PolyORB.Any.By_Reference;"); PL (CU, "case ACC.V.Switch is"); -- XXX This block is duplicated from Gen_Union_Body and should -- be factored. declare It : Node_Iterator; Case_Node : Node_Id; J : Long_Integer := 0; Has_Default : Boolean := False; begin Init (It, Cases (Node)); while not Is_End (It) loop Get_Next_Node (It, Case_Node); II (CU); declare It2 : Node_Iterator; Label_Node : Node_Id; First_Label : Boolean := True; begin if Default_Index (Node) = J then Put (CU, "when others"); Has_Default := True; else Init (It2, Labels (Case_Node)); while not Is_End (It2) loop Get_Next_Node (It2, Label_Node); if First_Label then Put (CU, "when "); First_Label := False; else Put (CU, " | "); end if; Gen_Constant_Value (CU, Expr => Label_Node, Typ => Switch_Type (Node)); end loop; end if; PL (CU, " =>"); II (CU); Put (CU, "return "); Gen_Wrap_Call (CU, Case_Type (Case_Node), "ACC.V." & Ada_Name (Case_Decl (Case_Node))); PL (CU, ";"); J := J + 1; DI (CU); DI (CU); end; end loop; if not Has_Default then Gen_When_Others_Clause (CU); end if; end; PL (CU, "end case;"); DI (CU); PL (CU, "end if;"); when others => null; end case; DI (CU); PL (CU, "end Get_Aggregate_Element;"); -- Set_Aggregate_Element if NK = K_Enum or else NK = K_Union then NL (CU); Gen_Set_Aggregate_Element_Profile (CU, Node); NL (CU); PL (CU, "is"); II (CU); PL (CU, "pragma Unreferenced (TC);"); PL (CU, "use type PolyORB.Types.Unsigned_Long;"); PL (CU, "pragma Assert (Index = 0);"); if NK = K_Enum then DI (CU); PL (CU, "begin"); II (CU); PL (CU, "ACC.V.all := " & Ada_Type_Name (Node) & "'Val (" & "PolyORB.Types.Unsigned_Long'" & "(PolyORB.Any.From_Any (From_C)));"); else declare ST_Node : constant Node_Id := Switch_Type (Node); S_Helper_Name : constant String := Helper_Unit (ST_Node); begin PL (CU, "New_Switch : constant " & Ada_Type_Name (ST_Node) & " := " & S_Helper_Name & ".From_Any (From_C);"); end; PL (CU, "New_Union : " & Ada_Type_Name (Node) & " (Switch => New_Switch);"); PL (CU, "pragma Warnings (Off, New_Union);"); PL (CU, "-- Use default initialization"); NL (CU); PL (CU, "pragma Suppress (Discriminant_Check);"); DI (CU); PL (CU, "begin"); II (CU); PL (CU, "ACC.V.all := New_Union;"); end if; DI (CU); PL (CU, "end Set_Aggregate_Element;"); end if; -- Get_Aggregate_Count NL (CU); Gen_Get_Aggregate_Count_Profile (CU, Node); NL (CU); PL (CU, "is"); II (CU); if Members_Count > 0 or else (NK = K_Declarator and then Dim = 1) then PL (CU, "pragma Unreferenced (ACC);"); end if; DI (CU); PL (CU, "begin"); II (CU); if Members_Count >= 0 then PL (CU, "return" & Members_Count'Img & ";"); elsif NK = K_Declarator then Put (CU, "return " & T_Lengths & Ada_Name (Node) & " ("); if Dim > 1 then Put (CU, "ACC.Dimen"); else Put (CU, "1"); end if; PL (CU, ");"); else pragma Assert (Kind (Node) = K_Sequence); PL (CU, "return PolyORB.Types.Unsigned_Long"); PL (CU, " (" & Ada_Name (Node) & ".Length (ACC.V.all));"); end if; DI (CU); PL (CU, "end Get_Aggregate_Count;"); -- Set_Aggregate_Count NL (CU); Gen_Set_Aggregate_Count_Profile (CU, Node); NL (CU); PL (CU, "is"); II (CU); PL (CU, "use type PolyORB.Types.Unsigned_Long;"); if Members_Count > 0 or else (NK = K_Declarator and then Dim = 1) then PL (CU, "pragma Unreferenced (ACC);"); end if; DI (CU); PL (CU, "begin"); II (CU); if Members_Count >= 0 then PL (CU, "if Count /=" & Members_Count'Img & " then"); II (CU); PL (CU, "raise Program_Error;"); DI (CU); PL (CU, "end if;"); else pragma Assert (NK = K_Declarator); Put (CU, "if Count /= " & T_Lengths & Ada_Name (Node) & " ("); if Dim > 1 then Put (CU, "ACC.Dimen"); else Put (CU, "1"); end if; PL (CU, ") then"); II (CU); PL (CU, "raise Program_Error;"); DI (CU); PL (CU, "end if;"); end if; DI (CU); PL (CU, "end Set_Aggregate_Count;"); -- Clone NL (CU); Gen_Clone_Profile (CU, Node); NL (CU); PL (CU, "is"); II (CU); PL (CU, "use type PolyORB.Any.Content_Ptr;"); PL (CU, "Target : PolyORB.Any.Content_Ptr;"); if NK = K_Union then PL (CU, "pragma Suppress (Discriminant_Check);"); end if; DI (CU); declare Target_Obj : constant String := T_Content & Ada_Name (Node) & " (Target.all)"; procedure Assign_Component (Comp_Name : String); -- Generate assignment of named component of ACC to same component -- of Target. procedure Assign_Component (Comp_Name : String) is begin PL (CU, Target_Obj & "." & Comp_Name & ":= ACC." & Comp_Name & ";"); end Assign_Component; begin PL (CU, "begin"); II (CU); PL (CU, "if Into /= null then"); II (CU); PL (CU, "if Into.all not in " & T_Content & Ada_Name (Node) & " then"); II (CU); PL (CU, "return null;"); DI (CU); PL (CU, "end if;"); PL (CU, "Target := Into;"); PL (CU, Target_Obj & ".V.all := ACC.V.all;"); DI (CU); PL (CU, "else"); II (CU); PL (CU, "Target := new " & T_Content & Ada_Name (Node) & ";"); -- Ensure the allocation here is at least as large as the actual -- value (can't use the default discriminant, as the allocator -- allocates constrained object, which might be too small). PL (CU, T_Content & Ada_Name (Node) & " (Target.all).V := " & "new " & Ada_Type_Name (Node) & "'(ACC.V.all);"); DI (CU); PL (CU, "end if;"); case NK is when K_Declarator => if Dim > 1 then Assign_Component ("Dimen"); Assign_Component ("Indices"); end if; when K_Enum => Assign_Component ("Repr_Cache"); when K_Union => Assign_Component ("Switch_Cache"); when others => null; end case; end; PL (CU, "return Target;"); DI (CU); PL (CU, "end Clone;"); -- Finalize_Value NL (CU); Gen_Finalize_Value_Profile (CU, Node); NL (CU); PL (CU, "is"); II (CU); Add_With (CU, "Ada.Unchecked_Deallocation"); PL (CU, "procedure Free is new Ada.Unchecked_Deallocation"); PL (CU, " (" & Ada_Type_Name (Node) & ", " & T_Ptr & Ada_Name (Node) & ");"); DI (CU); PL (CU, "begin"); II (CU); PL (CU, "Free (ACC.V);"); DI (CU); PL (CU, "end Finalize_Value;"); -- Wrap NL (CU); Gen_Wrap_Profile (CU, Node); PL (CU, " is"); PL (CU, "begin"); II (CU); Put (CU, "return " & T_Content & Ada_Name (Node) & "'(PolyORB.Any.Aggregate_Content with V => " & T_Ptr & Ada_Name (Node) & " (X)"); case NK is when K_Declarator => if Dim > 1 then PL (CU, ","); PL (CU, " Dimen => 1,"); Put (CU, " Indices => (others => 0)"); end if; when K_Enum => PL (CU, ","); Put (CU, " Repr_Cache => 0"); when K_Union => PL (CU, ","); Put (CU, " Switch_Cache => X.Switch"); when others => null; end case; PL (CU, ");"); DI (CU); PL (CU, "end Wrap;"); end Gen_Aggregate_Content_Wrapper_Body; --------------------------------------- -- Gen_Get_Aggregate_Element_Profile -- --------------------------------------- procedure Gen_Get_Aggregate_Element_Profile (CU : in out Compilation_Unit; Node : Node_Id) is begin PL (CU, "function Get_Aggregate_Element"); PL (CU, " (ACC : not null access " & T_Content & Ada_Name (Node) & ";"); PL (CU, " TC : PolyORB.Any.TypeCode.Object_Ptr;"); PL (CU, " Index : PolyORB.Types.Unsigned_Long;"); Put (CU, " Mech : not null access PolyORB.Any.Mechanism)" & " return PolyORB.Any.Content'Class"); end Gen_Get_Aggregate_Element_Profile; ------------------------------------- -- Gen_Get_Aggregate_Count_Profile -- ------------------------------------- procedure Gen_Get_Aggregate_Count_Profile (CU : in out Compilation_Unit; Node : Node_Id) is begin Add_With (CU, "PolyORB.Types"); PL (CU, "function Get_Aggregate_Count"); Put (CU, " (ACC : " & T_Content & Ada_Name (Node) & ") return PolyORB.Types.Unsigned_Long"); end Gen_Get_Aggregate_Count_Profile; ------------------------------------- -- Gen_Set_Aggregate_Count_Profile -- ------------------------------------- procedure Gen_Set_Aggregate_Count_Profile (CU : in out Compilation_Unit; Node : Node_Id) is begin PL (CU, "procedure Set_Aggregate_Count"); PL (CU, " (ACC : in out " & T_Content & Ada_Name (Node) & ";"); Put (CU, " Count : PolyORB.Types.Unsigned_Long)"); end Gen_Set_Aggregate_Count_Profile; --------------------------------------- -- Gen_Set_Aggregate_Element_Profile -- --------------------------------------- procedure Gen_Set_Aggregate_Element_Profile (CU : in out Compilation_Unit; Node : Node_Id) is begin PL (CU, "procedure Set_Aggregate_Element"); PL (CU, " (ACC : in out " & T_Content & Ada_Name (Node) & ";"); PL (CU, " TC : PolyORB.Any.TypeCode.Object_Ptr;"); PL (CU, " Index : PolyORB.Types.Unsigned_Long;"); Put (CU, " From_C : in out PolyORB.Any.Any_Container'Class)"); end Gen_Set_Aggregate_Element_Profile; ----------------------- -- Gen_Clone_Profile -- ----------------------- procedure Gen_Clone_Profile (CU : in out Compilation_Unit; Node : Node_Id) is begin PL (CU, "function Clone"); PL (CU, " (ACC : " & T_Content & Ada_Name (Node) & ";"); Put (CU, " Into : PolyORB.Any.Content_Ptr := null) " & "return PolyORB.Any.Content_Ptr"); end Gen_Clone_Profile; -------------------------------- -- Gen_Finalize_Value_Profile -- -------------------------------- procedure Gen_Finalize_Value_Profile (CU : in out Compilation_Unit; Node : Node_Id) is begin PL (CU, "procedure Finalize_Value"); Put (CU, " (ACC : in out " & T_Content & Ada_Name (Node) & ")"); end Gen_Finalize_Value_Profile; ------------------- -- Gen_Node_Spec -- ------------------- procedure Gen_Node_Spec (CU : in out Compilation_Unit; Node : Node_Id) is begin case Kind (Node) is when K_Interface => Gen_Interface_Spec (CU, Node); when K_Enum => Gen_Aggregate_Content_Wrapper_Spec (CU, Node); Gen_Enum_Spec (CU, Node); when K_Type_Declarator => declare It : Node_Iterator; Decl_Node : Node_Id; begin Init (It, Declarators (Node)); if Kind (T_Type (Node)) = K_Fixed then Get_Next_Node (It, Decl_Node); pragma Assert (Is_End (It)); Gen_Fixed_Spec (CU, Decl_Node); else while not Is_End (It) loop Get_Next_Node (It, Decl_Node); Gen_Type_Declarator_Spec (CU, Decl_Node); end loop; end if; end; when K_Struct => if not Is_Exception_Members (Node) then Gen_Aggregate_Content_Wrapper_Spec (CU, Node); Gen_Struct_Exception_Spec (CU, Node); end if; when K_String_Instance => Gen_String_Instance_Spec (CU, Node); when K_Union => Gen_Aggregate_Content_Wrapper_Spec (CU, Node); Gen_Union_Spec (CU, Node); when K_Sequence_Instance => Gen_Sequence_Spec (CU, Node); when K_ValueType => Gen_Aggregate_Content_Wrapper_Spec (CU, Node); Gen_ValueType_Spec (CU, Node); when K_Exception => Gen_Struct_Exception_Spec (CU, Node); Gen_Raise_Profile (CU, Node); PL (CU, ";"); PL (CU, "pragma No_Return (" & Raise_Name (Node) & ");"); when others => null; end case; end Gen_Node_Spec; ------------------- -- Gen_Node_Body -- ------------------- procedure Gen_Node_Body (CU : in out Compilation_Unit; Node : Node_Id) is begin case Kind (Node) is when K_Interface => Gen_Interface_Body (CU, Node); when K_Enum => Gen_Aggregate_Content_Wrapper_Body (CU, Node); Gen_Enum_Body (CU, Node); when K_Type_Declarator => declare It : Node_Iterator; Decl_Node : Node_Id; begin Init (It, Declarators (Node)); if Kind (T_Type (Node)) = K_Fixed then Get_Next_Node (It, Decl_Node); pragma Assert (Is_End (It)); Gen_Fixed_Body (CU, Decl_Node); else while not Is_End (It) loop Get_Next_Node (It, Decl_Node); Gen_Type_Declarator_Body (CU, Decl_Node); end loop; end if; end; when K_Struct => if not Is_Exception_Members (Node) then Gen_Aggregate_Content_Wrapper_Body (CU, Node); Gen_Struct_Exception_Body (CU, Node); end if; when K_String_Instance => Gen_String_Instance_Body (CU, Node); when K_Union => Gen_Aggregate_Content_Wrapper_Body (CU, Node); Gen_Union_Body (CU, Node); when K_Sequence_Instance => Gen_Sequence_Body (CU, Node); when K_ValueType => Gen_Aggregate_Content_Wrapper_Body (CU, Node); Gen_ValueType_Body (CU, Node); when K_Exception => Gen_Struct_Exception_Body (CU, Node); if not Has_Local_Component (Node) then Gen_Raise_From_Any_Profile (CU, Node); PL (CU, ";"); PL (CU, "pragma No_Return (" & Raise_From_Any_Name (Node) & ");"); Gen_Raise_From_Any_Profile (CU, Node); PL (CU, ""); PL (CU, "is"); II (CU); PL (CU, "Members : constant " & Ada_Name (Members_Type (Node)) & " := From_Any (CORBA.Any (Item));"); DI (CU); PL (CU, "begin"); II (CU); Add_With (CU, "PolyORB.Exceptions"); PL (CU, "PolyORB.Exceptions.User_Raise_Exception"); PL (CU, " (" & Ada_Name (Node) & "'Identity,"); II (CU); PL (CU, "Members,"); PL (CU, "Message);"); DI (CU); DI (CU); PL (CU, "end " & Raise_From_Any_Name (Node) & ";"); -- Register raiser -- This has to be done in deferred initialization, after the -- TypeCode has been constructed. Divert (CU, Deferred_Initialization); PL (CU, "PolyORB.Exceptions.Register_Exception"); PL (CU, " (CORBA.TypeCode.Internals.To_PolyORB_Object (" & Ada_TC_Name (Node) & "),"); II (CU); PL (CU, Raise_From_Any_Name (Node) & "'Access);"); DI (CU); Divert (CU, Initialization_Dependencies); PL (CU, "& ""exceptions"""); Divert (CU, Visible_Declarations); end if; Gen_Raise_Profile (CU, Node); PL (CU, ""); PL (CU, "is"); PL (CU, "begin"); II (CU); Add_With (CU, "PolyORB.Exceptions"); PL (CU, "PolyORB.Exceptions.User_Raise_Exception"); PL (CU, " (" & Ada_Name (Node) & "'Identity,"); II (CU); PL (CU, "Members);"); DI (CU); DI (CU); PL (CU, "end " & Raise_Name (Node) & ";"); when others => null; end case; end Gen_Node_Body; -------------------------- -- Gen_From_Any_Profile -- -------------------------- procedure Gen_From_Any_Profile (CU : in out Compilation_Unit; Type_Node : Node_Id; From_Container : Boolean) is begin if From_Container then Add_With (CU, "PolyORB.Any"); Put (CU, "function From_Any (C : PolyORB.Any.Any_Container'Class) " & "return " & Ada_Type_Name (Type_Node)); else Put (CU, "function From_Any (Item : CORBA.Any) " & "return " & Ada_Type_Name (Type_Node)); end if; end Gen_From_Any_Profile; ------------------------ -- Gen_To_Any_Profile -- ------------------------ procedure Gen_To_Any_Profile (CU : in out Compilation_Unit; Type_Node : Node_Id) is begin PL (CU, "function To_Any"); Put (CU, " (Item : " & Ada_Type_Name (Type_Node) & ") return CORBA.Any"); end Gen_To_Any_Profile; -------------------------------- -- Gen_Raise_From_Any_Profile -- -------------------------------- procedure Gen_Raise_From_Any_Profile (CU : in out Compilation_Unit; Node : Node_Id) is begin Add_With (CU, "PolyORB.Any"); Add_With (CU, "PolyORB.Std"); PL (CU, ""); PL (CU, "procedure " & Raise_From_Any_Name (Node)); PL (CU, " (Item : PolyORB.Any.Any;"); Put (CU, " Message : PolyORB.Std.String)"); end Gen_Raise_From_Any_Profile; ----------------------- -- Gen_Raise_Profile -- ----------------------- procedure Gen_Raise_Profile (CU : in out Compilation_Unit; Node : Node_Id) is begin PL (CU, ""); PL (CU, "procedure " & Raise_Name (Node)); Put (CU, " (Members : " & Ada_Name (Members_Type (Node)) & ")"); end Gen_Raise_Profile; ------------------------ -- Gen_Interface_Spec -- ------------------------ procedure Gen_Interface_Spec (CU : in out Compilation_Unit; Node : Node_Id) is begin -- Unchecked_To_ declare Short_Type_Name : constant String := Ada_Type_Defining_Name (Mapping, Node); Type_Name : constant String := Ada_Type_Name (Node); begin Add_With (CU, "CORBA.Object"); NL (CU); PL (CU, "function Unchecked_To_" & Short_Type_Name); PL (CU, " (The_Ref : CORBA.Object.Ref'Class)" & " return " & Type_Name & ";"); NL (CU); PL (CU, "function To_" & Short_Type_Name); PL (CU, " (The_Ref : CORBA.Object.Ref'Class)" & " return " & Type_Name & ";"); end; -- TypeCode NL (CU); Add_With (CU, "CORBA", Elab_Control => Elaborate_All); PL (CU, Ada_TC_Name (Node) & " : CORBA.TypeCode.Object;"); if not Local (Node) then -- From_Any NL (CU); Gen_From_Any_Profile (CU, Node, From_Container => False); PL (CU, ";"); -- To_Any NL (CU); Gen_To_Any_Profile (CU, Node); PL (CU, ";"); end if; end Gen_Interface_Spec; -------------------------------- -- Gen_Forward_Interface_Spec -- -------------------------------- procedure Gen_Forward_Interface_Spec (CU : in out Compilation_Unit; Node : Node_Id) is begin -- Unchecked_To_ declare Short_Type_Name : constant String := Ada_Type_Defining_Name (Mapping, Node); Type_Name : constant String := Ada_Type_Name (Node); begin Add_With (CU, "CORBA.Object"); NL (CU); PL (CU, "function Unchecked_To_" & Short_Type_Name); PL (CU, " (The_Ref : CORBA.Object.Ref'Class)" & " return " & Type_Name & ";"); NL (CU); PL (CU, "function To_" & Short_Type_Name); PL (CU, " (The_Ref : CORBA.Object.Ref'Class)" & " return " & Type_Name & ";"); end; -- TypeCode NL (CU); Add_With (CU, "CORBA", Elab_Control => Elaborate_All); PL (CU, Ada_TC_Name (Node) & " : CORBA.TypeCode.Object;"); if not Local (Node) then -- From_Any NL (CU); Gen_From_Any_Profile (CU, Node, From_Container => False); PL (CU, ";"); -- To_Any NL (CU); Gen_To_Any_Profile (CU, Node); PL (CU, ";"); end if; end Gen_Forward_Interface_Spec; ------------------------ -- Gen_ValueType_Spec -- ------------------------ procedure Gen_ValueType_Spec (CU : in out Compilation_Unit; Node : Node_Id) is Type_Name : constant String := Ada_Type_Defining_Name (Mapping, Node); Type_Full_Name : constant String := Ada_Type_Name (Node); V_Impl_Name : constant String := Ada_Name (Node) & ".Value_Impl.Object'Class"; begin pragma Assert (Kind (Node) = K_ValueType); Add_With (CU, "CORBA.Value"); NL (CU); PL (CU, "function To_" & Type_Name); PL (CU, " (The_Ref : CORBA.Value.Base'Class)"); PL (CU, " return " & Type_Full_Name & ";"); -- Generate code for supported non-abstract interfaces, if any if Supports_Non_Abstract_Interface (Node) then Add_With (CU, Ada_Full_Name (Node) & ".Value_Impl"); NL (CU); PL (CU, "type Servant"); II (CU); PL (CU, "(Value : access " & V_Impl_Name & ")"); Add_With (CU, "PortableServer"); PL (CU, "is new PortableServer.Servant_Base with null record;"); DI (CU); PL (CU, "type Servant_Ref is access all Servant'Class;"); NL (CU); PL (CU, "function To_Servant"); PL (CU, " (Self : access " & V_Impl_Name & ")"); PL (CU, " return Servant_Ref;"); end if; -- TypeCode NL (CU); Add_With (CU, "CORBA"); PL (CU, Ada_TC_Name (Node) & " : CORBA.TypeCode.Object;"); -- From_Any NL (CU); Gen_From_Any_Profile (CU, Node, From_Container => False); PL (CU, ";"); -- To_Any NL (CU); Gen_To_Any_Profile (CU, Node); PL (CU, ";"); Add_With (CU, "PolyORB.CORBA_P.Value.Helper"); NL (CU); PL (CU, "use PolyORB.CORBA_P.Value.Helper;"); NL (CU); PL (CU, "-- Prototypes for internal conversion procedures"); PL (CU, "procedure From_Any"); II (CU); PL (CU, "(Item : CORBA.Any;"); PL (CU, " Result_Ref : in out " & Type_Full_Name & ";"); PL (CU, " Unmarshalled_List : in out AnyRef_Seq.Sequence);"); DI (CU); NL (CU); PL (CU, "procedure To_Any"); II (CU); PL (CU, "(Item : " & Type_Full_Name & ";"); PL (CU, " Result : in out CORBA.Any;"); PL (CU, " Marshalled_List : in out RefAny_Seq.Sequence);"); DI (CU); NL (CU); end Gen_ValueType_Spec; ------------------------ -- Gen_ValueType_Body -- ------------------------ procedure Gen_ValueType_Body (CU : in out Compilation_Unit; Node : Node_Id) is Type_Name : constant String := Ada_Type_Defining_Name (Mapping, Node); Type_Full_Name : constant String := Ada_Type_Name (Node); V_Impl_Name : constant String := Ada_Name (Node) & ".Value_Impl.Object'Class"; begin pragma Assert (Kind (Node) = K_ValueType); Add_With (CU, "CORBA.Value"); Add_With (CU, "PolyORB.Log"); Add_With (CU, "Ada.Strings.Unbounded"); PL (CU, "use PolyORB.Log;"); PL (CU, "use PolyORB.Any;"); PL (CU, "use PolyORB.Std;"); PL (CU, "use PolyORB.CORBA_P.Value.Helper;"); PL (CU, "use CORBA.Value;"); NL (CU); PL (CU, "-- Logging for this package."); PL (CU, "package L is new PolyORB.Log.Facility_Log (""" & Name (CU) & """);"); PL (CU, "procedure O (Message : PolyORB.Std.String; Level :" & " Log_Level := Debug)"); PL (CU, " renames L.Output;"); NL (CU); PL (CU, "-- Pointer type for Value_Refs."); PL (CU, "type Value_Ptr is access Value_Ref;"); NL (CU); NL (CU); PL (CU, "function To_" & Type_Name); PL (CU, " (The_Ref : CORBA.Value.Base'Class)"); PL (CU, " return " & Type_Full_Name & " is"); II (CU); PL (CU, "Result : " & Type_Full_Name & ";"); DI (CU); PL (CU, "begin"); II (CU); PL (CU, "if CORBA.Value.Is_Nil (The_Ref)"); PL (CU, " or else CORBA.Value.Is_A (The_Ref, " & Repository_Id_Name (Node) & ") then"); II (CU); PL (CU, "Set (Result, CORBA.Value.Object_Of (The_Ref));"); PL (CU, "return Result;"); DI (CU); PL (CU, "else"); II (CU); PL (CU, "CORBA.Raise_Bad_Param (CORBA.Default_Sys_Member);"); DI (CU); PL (CU, "end if;"); DI (CU); PL (CU, "end To_" & Type_Name & ";"); -- Generate code for supported non-abstract interfaces, if any if Supports_Non_Abstract_Interface (Node) then NL (CU); PL (CU, "function To_Servant"); PL (CU, " (Self : access " & V_Impl_Name & ")"); PL (CU, " return Servant_Ref is"); PL (CU, "begin"); II (CU); PL (CU, "return new Servant (Self);"); DI (CU); PL (CU, "end To_Servant;"); end if; NL (CU); PL (CU, "-- Wrappers for the recursive procedures"); NL (CU); Add_With (CU, "PolyORB.CORBA_P.Value.Helper"); Gen_From_Any_Profile (CU, Node, From_Container => False); PL (CU, " is"); II (CU); PL (CU, "Result_Ref : " & Type_Full_Name & ";"); PL (CU, "New_Sequence : AnyRef_Seq.Sequence := " & "AnyRef_Seq.Null_Sequence;"); DI (CU); PL (CU, "begin"); II (CU); PL (CU, "From_Any (Item, Result_Ref, New_Sequence);"); PL (CU, "return Result_Ref;"); DI (CU); PL (CU, "end From_Any;"); NL (CU); Gen_To_Any_Profile (CU, Node); PL (CU, " is"); II (CU); PL (CU, "Result_Any : CORBA.Any;"); PL (CU, "New_Sequence : RefAny_Seq.Sequence :=" & " RefAny_Seq.Null_Sequence;"); DI (CU); PL (CU, "begin"); II (CU); PL (CU, "To_Any (Item, Result_Any, New_Sequence);"); PL (CU, "return Result_Any;"); DI (CU); PL (CU, "end To_Any;"); NL (CU); Add_With (CU, Ada_Full_Name (Node) & ".Value_Impl"); Add_With (CU, "CORBA.Impl"); PL (CU, "-- Actual From_Any conversion procedure."); PL (CU, "procedure From_Any"); PL (CU, " (Item : CORBA.Any;"); PL (CU, " Result_Ref : in out " & Type_Full_Name & ";"); PL (CU, " Unmarshalled_List : in out AnyRef_Seq.Sequence)"); PL (CU, "is"); II (CU); PL (CU, "-- Get the ID, and then check the association list."); PL (CU, "ID_Tag : constant CORBA.Any :="); PL (CU, " CORBA.Internals.Get_Aggregate_Element"); PL (CU, " (Item, CORBA.TC_String, " & "CORBA.Unsigned_Long (0));"); PL (CU, "Temp_String : constant CORBA.String :="); PL (CU, " CORBA.From_Any (ID_Tag);"); PL (CU, "My_ID : Any_ID;"); PL (CU, "Index : Natural;"); DI (CU); PL (CU, "begin"); II (CU); PL (CU, "My_ID := Ada.Strings.Unbounded.To_String"); PL (CU, " (Ada.Strings.Unbounded.Unbounded_String (Temp_String));"); PL (CU, "pragma Debug (O (""From_Any: "" & My_ID));"); NL (CU); PL (CU, "Index := PolyORB.CORBA_P.Value.Helper.Find_Ref.Index"); PL (CU, " (Unmarshalled_List, My_ID);"); NL (CU); PL (CU, "if Index = 0 then"); II (CU); PL (CU, "declare"); II (CU); PL (CU, "List_Item : AnyRef_Element;"); PL (CU, "Result : " & Ada_Full_Name (Node) & ".Value_Impl.Object_Ptr :="); PL (CU, " new " & Ada_Full_Name (Node) & ".Value_Impl.Object;"); PL (CU, "Temp_Any : CORBA.Any;"); PL (CU, "Temp_Ref : Value_Ptr :="); PL (CU, " new " & Type_Full_Name & ";"); DI (CU); PL (CU, "begin"); II (CU); PL (CU, "-- Save the Any <-> Ref association."); PL (CU, "List_Item.Ref := Ref_Ptr (Temp_Ref);"); PL (CU, "List_Item.Any := My_ID;"); PL (CU, "AnyRef_Seq.Append (Unmarshalled_List, List_Item);"); NL (CU); -- Type dependent section declare It : Node_Iterator; Member_Node : Node_Id; Position : Natural := 1; begin Init (It, Contents (Node)); while not Is_End (It) loop Get_Next_Node (It, Member_Node); if Is_State_Member (Member_Node) then declare Type_Node : constant Node_Id := State_Type (Member_Node); Helper_Name : constant String := Helper_Unit (Type_Node); TCU_Name : constant String := TC_Unit (Type_Node); It2 : Node_Iterator; Decl_Node : Node_Id; begin Init (It2, State_Declarators (Member_Node)); while not Is_End (It2) loop Get_Next_Node (It2, Decl_Node); PL (CU, "-- Common code"); PL (CU, "Temp_Any := CORBA.Internals.Get_Aggregate_Element"); Add_Helper_Dependency (CU, TCU_Name); Add_With (CU, Helper_Name); PL (CU, " (Item, " & Ada_Full_TC_Name (Type_Node) & ", CORBA.Unsigned_Long (" & Natural'Image (Position) & "));"); PL (CU, "pragma Debug (O (""member" & Natural'Image (Position) & " = "" & CORBA.Image (Temp_Any)));"); declare Decl_Name : constant String := Ada_Name (Decl_Node); begin if (Kind (Type_Node) = K_Scoped_Name) and then ((Kind (Value (Type_Node)) = K_ValueType or else (Kind (Value (Type_Node)) = K_Forward_ValueType))) then PL (CU, "-- ValueType specific"); NL (CU); PL (CU, "declare"); PL (CU, " New_Ref : " & Ada_Type_Name (State_Type (Member_Node)) & ";"); PL (CU, "begin"); II (CU); PL (CU, Helper_Name & ".From_Any (Temp_Any, New_Ref," & " Unmarshalled_List);"); PL (CU, "Result." & Decl_Name & " := New_Ref;"); DI (CU); PL (CU, "end;"); else PL (CU, "-- Regular member."); PL (CU, "Result." & Decl_Name & " := " & Helper_Name & ".From_Any (Temp_Any);"); end if; end; Position := Position + 1; NL (CU); end loop; end; end if; end loop; end; PL (CU, "-- Return a pointer on the newly created object."); PL (CU, "Set (Result_Ref, CORBA.Impl.Object_Ptr (Result));"); DI (CU); PL (CU, "end;"); DI (CU); PL (CU, "else"); II (CU); PL (CU, "declare"); II (CU); PL (CU, "List_Item : AnyRef_Element :="); PL (CU, " AnyRef_Seq.Get_Element (Unmarshalled_List, Index);"); DI (CU); PL (CU, "begin"); II (CU); PL (CU, "pragma Debug (O (""pointer to "" & My_ID));"); PL (CU, "Set (Result_Ref, " & "CORBA.AbstractBase.Entity_Of (List_Item.Ref.all));"); DI (CU); PL (CU, "end;"); DI (CU); PL (CU, "end if;"); DI (CU); PL (CU, "end From_Any;"); -- To_Any NL (CU); PL (CU, "-- Actual To_Any conversion procedure."); PL (CU, "procedure To_Any"); II (CU); PL (CU, "(Item : " & Type_Full_Name & ";"); PL (CU, " Result : in out CORBA.Any;"); PL (CU, " Marshalled_List : in out RefAny_Seq.Sequence)"); DI (CU); PL (CU, " is"); II (CU); PL (CU, "My_ID : constant Any_ID := Get_ID (Result);"); PL (CU, "Index : constant Natural :="); PL (CU, " Find_Any.Index (Marshalled_List," & " CORBA.AbstractBase.Ref (Item));"); DI (CU); PL (CU, "begin"); II (CU); PL (CU, "if Index = 0 then"); II (CU); PL (CU, "declare"); II (CU); PL (CU, "Temp_Result : PolyORB.Any.Any;"); PL (CU, "Object_U : " & Ada_Full_Name (Node) & ".Value_Impl.Object_Ptr;"); PL (CU, "List_Item : RefAny_Element;"); DI (CU); PL (CU, "begin"); II (CU); PL (CU, "Temp_Result := CORBA.Internals.Get_Empty_Any_Aggregate (" & Ada_TC_Name (Node) & ");"); PL (CU, "Object_U := " & Ada_Full_Name (Node) & ".Value_Impl.Object_Ptr"); PL (CU, " (Object_Of (Item));"); NL (CU); PL (CU, "-- We save the association Item <-> Temp_Result."); PL (CU, "List_Item.Ref := CORBA.AbstractBase.Ref (Item);"); PL (CU, "List_Item.Any := My_ID;"); PL (CU, "RefAny_Seq.Append (Marshalled_List, List_Item);"); NL (CU); PL (CU, "-- Put the ID first into the aggregate."); PL (CU, "CORBA.Internals.Add_Aggregate_Element"); PL (CU, " (Temp_Result, CORBA.To_Any"); PL (CU, " (CORBA.To_CORBA_String (My_ID)));"); PL (CU, "pragma Debug (O (""To_Any: ID="" & My_ID));"); NL (CU); declare It : Node_Iterator; Member_Node : Node_Id; begin Init (It, Contents (Node)); while not Is_End (It) loop Get_Next_Node (It, Member_Node); if Is_State_Member (Member_Node) then declare Type_Node : constant Node_Id := State_Type (Member_Node); Helper_Name : constant String := Helper_Unit (Type_Node); It2 : Node_Iterator; Decl_Node : Node_Id; begin Init (It2, State_Declarators (Member_Node)); while not Is_End (It2) loop Get_Next_Node (It2, Decl_Node); declare Decl_Name : constant String := Ada_Name (Decl_Node); begin if (Kind (Type_Node) = K_Scoped_Name) and then ((Kind (Value (Type_Node)) = K_ValueType or else (Kind (Value (Type_Node)) = K_Forward_ValueType))) then PL (CU, "-- ValueType member."); PL (CU, "declare"); PL (CU, " Temp_Any : CORBA.Any;"); PL (CU, "begin"); II (CU); PL (CU, "Temp_Any := " & "CORBA.Internals.Get_Empty_Any_Aggregate" & " (" & Ada_Full_TC_Name (State_Type (Member_Node)) & ");"); PL (CU, Helper_Name & ".To_Any (Object_U." & Decl_Name & ", Temp_Any, Marshalled_List);"); PL (CU, "pragma Debug (O (""To_Any: member=""" & " & CORBA.Image (Temp_Any)));"); PL (CU, "CORBA.Internals.Add_Aggregate_Element " & "(Temp_Result,"); PL (CU, " Temp_Any);"); DI (CU); PL (CU, "end;"); else PL (CU, "-- Regular member."); PL (CU, "CORBA.Internals.Add_Aggregate_Element"); PL (CU, " (Temp_Result, " & Helper_Name & ".To_Any (Object_U." & Decl_Name & "));"); PL (CU, " pragma Debug (O (""To_Any: member1=""" & " & CORBA.Image (CORBA.To_Any (Object_U." & Decl_Name & "))));"); end if; end; end loop; end; end if; end loop; end; PL (CU, "Result := Temp_Result;"); DI (CU); PL (CU, "end;"); DI (CU); PL (CU, "else"); II (CU); PL (CU, "declare"); PL (CU, " List_Item : RefAny_Element :="); PL (CU, " RefAny_Seq.Element_Of (Marshalled_List, Index);"); PL (CU, " Result_ID : Any_ID := List_Item.Any;"); PL (CU, "begin"); II (CU); PL (CU, "CORBA.Internals.Add_Aggregate_Element"); PL (CU, " (Result, CORBA.To_Any"); PL (CU, " (CORBA.To_CORBA_String (Result_ID)));"); PL (CU, "pragma Debug (O (""To_Any: pointer="" & Result_ID));"); DI (CU); PL (CU, "end;"); DI (CU); PL (CU, "end if;"); DI (CU); PL (CU, "end To_Any;"); -- Fill in the typecode TC_ Divert (CU, Deferred_Initialization); NL (CU); PL (CU, "declare"); II (CU); PL (CU, "Name : constant CORBA.String :="); PL (CU, " CORBA.To_CORBA_String (""" & Ada_Name (Node) & """);"); PL (CU, "Id : constant CORBA.String :="); PL (CU, " CORBA.To_CORBA_String (""" & Idl_Repository_Id (Node) & """);"); -- Declare the names and types of the members of the value declare It : Node_Iterator; State_Member_Node_Id : Node_Id; begin Init (It, Contents (Node)); while not Is_End (It) loop Get_Next_Node (It, State_Member_Node_Id); if Is_State_Member (State_Member_Node_Id) then declare It2 : Node_Iterator; Content_Node_Id : Node_Id; begin Init (It2, State_Declarators (State_Member_Node_Id)); while not Is_End (It2) loop Get_Next_Node (It2, Content_Node_Id); PL (CU, "Name_" & Ada_Name (Content_Node_Id) & " : constant CORBA.String := " & "CORBA.To_CORBA_String (""" & Ada_Name (Content_Node_Id) & """);"); end loop; end; end if; end loop; end; DI (CU); PL (CU, "begin"); II (CU); Add_With (CU, "PolyORB.Any"); PL (CU, Ada_TC_Name (Node) & " :="); PL (CU, " CORBA.TypeCode.Internals.To_CORBA_Object" & " (PolyORB.Any.TypeCode.TC_Value);"); -- Put the name and repository Id for the value PL (CU, "CORBA.Internals.Add_Parameter"); PL (CU, " (" & Ada_TC_Name (Node) & ", CORBA.To_Any (Name));"); PL (CU, "CORBA.Internals.Add_Parameter"); PL (CU, " (" & Ada_TC_Name (Node) & ", CORBA.To_Any (Id));"); -- Add the type modifier tag PL (CU, "CORBA.Internals.Add_Parameter"); PL (CU, " (" & Ada_TC_Name (Node) & ", CORBA.To_Any (CORBA.Short (" & Type_Modifier (Node) & ")));"); -- Add the concrete base type -- XXX For the moment, a null TC is passed PL (CU, "CORBA.Internals.Add_Parameter"); PL (CU, " (" & Ada_TC_Name (Node) & ", CORBA.To_Any (CORBA.TC_Null));"); -- Add visibility, type and name for each member declare It : Node_Iterator; State_Member_Node_Id : Node_Id; begin Init (It, Contents (Node)); while not Is_End (It) loop Get_Next_Node (It, State_Member_Node_Id); if Is_State_Member (State_Member_Node_Id) then declare It2 : Node_Iterator; Content_Node_Id : Node_Id; begin Init (It2, State_Declarators (State_Member_Node_Id)); while not Is_End (It2) loop Get_Next_Node (It2, Content_Node_Id); PL (CU, "CORBA.Internals.Add_Parameter"); II (CU); PL (CU, "(" & Ada_TC_Name (Node) & ", CORBA.To_Any ( CORBA.Short (" & Visibility (State_Member_Node_Id) & ")));"); DI (CU); PL (CU, "CORBA.Internals.Add_Parameter"); II (CU); PL (CU, "(" & Ada_TC_Name (Node) & ", CORBA.To_Any (" & Ada_Full_TC_Name (State_Type (State_Member_Node_Id)) & "));"); DI (CU); PL (CU, "CORBA.Internals.Add_Parameter"); II (CU); PL (CU, "(" & Ada_TC_Name (Node) & ", CORBA.To_Any (" & "Name_" & Ada_Name (Content_Node_Id) & "));"); DI (CU); end loop; end; end if; end loop; end; PL (CU, "CORBA.TypeCode.Internals.Disable_Reference_Counting (" & Ada_TC_Name (Node) & ");"); DI (CU); PL (CU, "end;"); Divert (CU, Visible_Declarations); end Gen_ValueType_Body; ------------------------ -- Gen_Interface_Body -- ------------------------ procedure Gen_Interface_Body (CU : in out Compilation_Unit; Node : Node_Id) is begin -- Unchecked_To_ declare Type_Defining_Name : constant String := Ada_Type_Defining_Name (Mapping, Node); Type_Name : constant String := Ada_Type_Name (Node); begin NL (CU); PL (CU, "function Unchecked_To_" & Type_Defining_Name); PL (CU, " (The_Ref : CORBA.Object.Ref'Class)"); PL (CU, " return " & Type_Name); PL (CU, "is"); II (CU); PL (CU, "Result : " & Type_Name & ";"); DI (CU); PL (CU, "begin"); II (CU); PL (CU, "Set (Result,"); PL (CU, " CORBA.Object.Object_Of (The_Ref));"); PL (CU, "return Result;"); DI (CU); PL (CU, "end Unchecked_To_" & Type_Defining_Name & ";"); -- To_ -- The standard mandates type checking during narrowing -- (4.6.2 Narrowing Object References). -- -- Doing the check properly implies either -- 1. querying the interface repository (not implemented yet); -- or 2. calling Is_A (Repository_Id) on an object reference whose -- type maps the actual (i. e. most derived) interface of -- The_Ref (which is impossible if that type is not -- known on the partition where To_Ref is called); -- or 3. a remote invocation of an Is_A method of the designated -- object. -- -- The most general and correct solution to this problem is 3. When -- a remote call is not desired, the user should use -- Unchecked_To_Ref, whose purpose is precisely that. -- -- This solution is implemented as a dispatching call to Is_A on -- the source object reference. The remote Is_A operation will be -- invoked if necessary. NL (CU); PL (CU, "function To_" & Type_Defining_Name); PL (CU, " (The_Ref : CORBA.Object.Ref'Class)"); PL (CU, " return " & Type_Name); PL (CU, "is"); PL (CU, "begin"); II (CU); PL (CU, "if CORBA.Object.Is_Nil (The_Ref)"); PL (CU, " or else CORBA.Object.Is_A (The_Ref, " & Repository_Id_Name (Node) & ") then"); II (CU); PL (CU, "return Unchecked_To_" & Type_Defining_Name & " (The_Ref);"); DI (CU); PL (CU, "end if;"); PL (CU, "CORBA.Raise_Bad_Param (CORBA.Default_Sys_Member);"); DI (CU); PL (CU, "end To_" & Type_Defining_Name & ";"); end; if not Local (Node) then -- From_Any Add_With (CU, "CORBA.Object.Helper"); NL (CU); Gen_From_Any_Profile (CU, Node, From_Container => False); PL (CU, " is"); PL (CU, "begin"); II (CU); PL (CU, "return To_" & Ada_Type_Defining_Name (Mapping, Node) & " (CORBA.Object.Helper." & "From_Any (Item));"); DI (CU); PL (CU, "end From_Any;"); -- To_Any Add_With (CU, "CORBA.Object.Helper"); NL (CU); Gen_To_Any_Profile (CU, Node); PL (CU, " is"); II (CU); PL (CU, "A : CORBA.Any := CORBA.Object.Helper.To_Any"); PL (CU, " (CORBA.Object.Ref (Item));"); DI (CU); PL (CU, "begin"); II (CU); PL (CU, "CORBA.Internals.Set_Type (A, " & Ada_TC_Name (Node) & ");"); PL (CU, "return A;"); DI (CU); PL (CU, "end To_Any;"); end if; -- Fill in the typecode TC_ Divert (CU, Deferred_Initialization); NL (CU); PL (CU, "declare"); II (CU); PL (CU, "Name : constant CORBA.String := CORBA.To_CORBA_String (""" & Ada_Name (Node) & """);"); PL (CU, "Id : constant CORBA.String := CORBA.To_CORBA_String (""" & Idl_Repository_Id (Node) & """);"); DI (CU); PL (CU, "begin"); II (CU); Add_With (CU, "PolyORB.Any"); PL (CU, Ada_TC_Name (Node) & " :="); PL (CU, " CORBA.TypeCode.Internals.To_CORBA_Object" & " (PolyORB.Any.TypeCode.TC_Object);"); PL (CU, "CORBA.Internals.Add_Parameter (" & Ada_TC_Name (Node) & ", CORBA.To_Any (Name));"); PL (CU, "CORBA.Internals.Add_Parameter (" & Ada_TC_Name (Node) & ", CORBA.To_Any (Id));"); PL (CU, "CORBA.TypeCode.Internals.Disable_Reference_Counting (" & Ada_TC_Name (Node) & ");"); DI (CU); PL (CU, "end;"); Divert (CU, Visible_Declarations); end Gen_Interface_Body; -------------------------------- -- Gen_Forward_Interface_Body -- -------------------------------- procedure Gen_Forward_Interface_Body (CU : in out Compilation_Unit; Node : Node_Id) is begin -- Unchecked_To_ declare Short_Type_Name : constant String := Ada_Type_Defining_Name (Mapping, Node); Type_Name : constant String := Ada_Type_Name (Node); begin NL (CU); PL (CU, "function Unchecked_To_" & Short_Type_Name); PL (CU, " (The_Ref : CORBA.Object.Ref'Class)"); PL (CU, " return " & Type_Name); PL (CU, "is"); II (CU); PL (CU, "Result : " & Type_Name & ";"); DI (CU); PL (CU, "begin"); II (CU); PL (CU, Ada_Name (Node) & ".Set (Result,"); PL (CU, " CORBA.Object.Object_Of (The_Ref));"); PL (CU, "return Result;"); DI (CU); PL (CU, "end Unchecked_To_" & Short_Type_Name & ";"); -- To_ -- see the corresponding comment in gen_interface_body -- if you want more information. NL (CU); PL (CU, "function To_" & Short_Type_Name); PL (CU, " (The_Ref : CORBA.Object.Ref'Class)"); PL (CU, " return " & Type_Name); PL (CU, "is"); PL (CU, "begin"); II (CU); PL (CU, "if CORBA.Object.Is_Nil (The_Ref)"); PL (CU, " or else CORBA.Object.Is_A (The_Ref, """ & Idl_Repository_Id (Forward (Node)) & """) then"); II (CU); PL (CU, "return Unchecked_To_" & Short_Type_Name & " (The_Ref);"); DI (CU); PL (CU, "end if;"); PL (CU, "CORBA.Raise_Bad_Param (CORBA.Default_Sys_Member);"); DI (CU); PL (CU, "end To_" & Short_Type_Name & ";"); end; if not Local (Node) then -- From_Any Add_With (CU, "CORBA.Object.Helper"); NL (CU); Gen_From_Any_Profile (CU, Node, From_Container => False); PL (CU, " is"); PL (CU, "begin"); II (CU); PL (CU, "return To_" & Ada_Type_Defining_Name (Mapping, Node) & " (CORBA.Object.Helper." & "From_Any (Item));"); DI (CU); PL (CU, "end From_Any;"); -- To_Any Add_With (CU, "CORBA.Object.Helper"); NL (CU); Gen_To_Any_Profile (CU, Node); PL (CU, " is"); PL (CU, "begin"); II (CU); PL (CU, "return CORBA.Object.Helper.To_Any " & "(CORBA.Object.Ref (Item));"); DI (CU); PL (CU, "end To_Any;"); end if; -- Fill in the typecode TC_ Divert (CU, Deferred_Initialization); NL (CU); PL (CU, "declare"); II (CU); PL (CU, "Name : constant CORBA.String := CORBA.To_CORBA_String (""" & Ada_Name (Forward (Node)) & """);"); PL (CU, "Id : constant CORBA.String := CORBA.To_CORBA_String (""" & Idl_Repository_Id (Node) & """);"); DI (CU); PL (CU, "begin"); II (CU); Add_With (CU, "PolyORB.Any"); PL (CU, Ada_TC_Name (Node) & " :="); PL (CU, " CORBA.TypeCode.Internals.To_CORBA_Object" & " (PolyORB.Any.TypeCode.TC_Object);"); PL (CU, "CORBA.Internals.Add_Parameter (" & Ada_TC_Name (Node) & ", CORBA.To_Any (Name));"); PL (CU, "CORBA.Internals.Add_Parameter (" & Ada_TC_Name (Node) & ", CORBA.To_Any (Id));"); PL (CU, "CORBA.TypeCode.Internals.Disable_Reference_Counting (" & Ada_TC_Name (Node) & ");"); DI (CU); PL (CU, "end;"); Divert (CU, Visible_Declarations); end Gen_Forward_Interface_Body; ------------------- -- Gen_Enum_Spec -- ------------------- procedure Gen_Enum_Spec (CU : in out Compilation_Unit; Node : Node_Id) is begin -- TypeCode NL (CU); Add_With (CU, "CORBA"); PL (CU, Ada_TC_Name (Node) & " : CORBA.TypeCode.Object;"); -- From_Any NL (CU); Gen_From_Any_Profile (CU, Node, From_Container => True); PL (CU, ";"); NL (CU); Gen_From_Any_Profile (CU, Node, From_Container => False); PL (CU, ";"); -- To_Any NL (CU); Gen_To_Any_Profile (CU, Node); PL (CU, ";"); end Gen_Enum_Spec; ------------------- -- Gen_Enum_Body -- ------------------- procedure Gen_Enum_Body (CU : in out Compilation_Unit; Node : Node_Id) is begin -- From_Any NL (CU); Gen_From_Any_Profile (CU, Node, From_Container => True); PL (CU, " is"); PL (CU, "begin"); II (CU); PL (CU, "return " & Ada_Full_Name (Node) & "'Val (PolyORB.Types.Unsigned_Long'(" & "PolyORB.Any.Get_Aggregate_Element (C, 0)));"); DI (CU); PL (CU, "end From_Any;"); NL (CU); Gen_From_Any_Profile (CU, Node, From_Container => False); PL (CU, " is"); PL (CU, "begin"); II (CU); PL (CU, "return From_Any (CORBA.Get_Container (Item).all);"); DI (CU); PL (CU, "end From_Any;"); -- To_Any NL (CU); Gen_To_Any_Profile (CU, Node); PL (CU, " is"); II (CU); PL (CU, "Result : CORBA.Any :="); II (CU); PL (CU, "CORBA.Internals.Get_Empty_Any_Aggregate (" & Ada_TC_Name (Node) & ");"); DI (CU); DI (CU); PL (CU, "begin"); II (CU); PL (CU, "CORBA.Internals.Add_Aggregate_Element"); II (CU); PL (CU, "(Result,"); PL (CU, " CORBA.To_Any (CORBA.Unsigned_Long (" & Ada_Name (Node) & "'Pos (Item))));"); DI (CU); PL (CU, "return Result;"); DI (CU); PL (CU, "end To_Any;"); -- Fill in typecode TC_ Divert (CU, Deferred_Initialization); PL (CU, "declare"); II (CU); PL (CU, "Name : constant CORBA.String := CORBA.To_CORBA_String (""" & Ada_Name (Node) & """);"); PL (CU, "Id : constant CORBA.String := CORBA.To_CORBA_String (""" & Idl_Repository_Id (Node) & """);"); declare It : Node_Iterator; E_Node : Node_Id; begin Init (It, Enumerators (Node)); while not Is_End (It) loop Get_Next_Node (It, E_Node); PL (CU, Ada_Name (E_Node) & "_Name : constant CORBA.String := CORBA.To_CORBA_String (""" & Ada_Name (E_Node) & """);"); end loop; end; DI (CU); PL (CU, "begin"); II (CU); Add_With (CU, "PolyORB.Any"); PL (CU, Ada_TC_Name (Node) & " :="); PL (CU, " CORBA.TypeCode.Internals.To_CORBA_Object" & " (PolyORB.Any.TypeCode.TC_Enum);"); PL (CU, "CORBA.Internals.Add_Parameter (" & Ada_TC_Name (Node) & ", CORBA.To_Any (Name));"); PL (CU, "CORBA.Internals.Add_Parameter (" & Ada_TC_Name (Node) & ", CORBA.To_Any (Id));"); declare It : Node_Iterator; E_Node : Node_Id; begin Init (It, Enumerators (Node)); while not Is_End (It) loop Get_Next_Node (It, E_Node); PL (CU, "CORBA.Internals.Add_Parameter (" & Ada_TC_Name (Node) & ", CORBA.To_Any (" & Ada_Name (E_Node) & "_Name));"); end loop; end; PL (CU, "CORBA.TypeCode.Internals.Disable_Reference_Counting (" & Ada_TC_Name (Node) & ");"); DI (CU); PL (CU, "end;"); Divert (CU, Visible_Declarations); end Gen_Enum_Body; ------------------------------- -- Gen_Struct_Exception_Spec -- ------------------------------- procedure Gen_Struct_Exception_Spec (CU : in out Compilation_Unit; Node : Node_Id) is Struct_Node : Node_Id; begin -- Typecode generation Add_With (CU, "CORBA", Elab_Control => Elaborate_All); NL (CU); PL (CU, Ada_TC_Name (Node) & " : CORBA.TypeCode.Object;"); if Kind (Node) = K_Struct then Struct_Node := Node; else Struct_Node := Members_Type (Node); end if; if not Has_Local_Component (Node) then -- From_Any NL (CU); Gen_From_Any_Profile (CU, Struct_Node, From_Container => False); PL (CU, ";"); -- To_Any NL (CU); Gen_To_Any_Profile (CU, Struct_Node); PL (CU, ";"); end if; end Gen_Struct_Exception_Spec; ------------------------------- -- Gen_Struct_Exception_Body -- ------------------------------- procedure Gen_Struct_Exception_Body (CU : in out Compilation_Unit; Node : Node_Id) is Struct_Node : Node_Id; Is_Empty : Boolean; begin if Kind (Node) = K_Struct then Struct_Node := Node; else Struct_Node := Members_Type (Node); end if; Is_Empty := Length (Members (Node)) = 0; if not Has_Local_Component (Node) then -- From_Any NL (CU); Gen_From_Any_Profile (CU, Struct_Node, From_Container => False); PL (CU, " is"); II (CU); if not Is_Empty then PL (CU, "Index : CORBA.Any;"); declare It : Node_Iterator; Member_Node : Node_Id; begin Init (It, Members (Struct_Node)); while not Is_End (It) loop Get_Next_Node (It, Member_Node); declare It2 : Node_Iterator; Decl_Node : Node_Id; begin Init (It2, Decl (Member_Node)); while not Is_End (It2) loop Get_Next_Node (It2, Decl_Node); PL (CU, "Result_" & Ada_Name (Decl_Node) & " : " & Ada_Type_Name (M_Type (Member_Node)) & ";"); end loop; end; end loop; end; else PL (CU, "Result : " & Ada_Name (Struct_Node) & ";"); PL (CU, "pragma Warnings (Off);"); PL (CU, "pragma Unreferenced (Item);"); PL (CU, "pragma Warnings (On);"); end if; DI (CU); PL (CU, "begin"); II (CU); if Is_Empty then PL (CU, "return Result;"); else declare It : Node_Iterator; Member_Node : Node_Id; J : Integer := 0; begin Init (It, Members (Struct_Node)); while not Is_End (It) loop Get_Next_Node (It, Member_Node); declare It2 : Node_Iterator; Decl_Node : Node_Id; Type_Node : constant Node_Id := M_Type (Member_Node); Helper_Name : constant String := Helper_Unit (Type_Node); TCU_Name : constant String := TC_Unit (Type_Node); begin Add_Helper_Dependency (CU, TCU_Name); Add_With (CU, Helper_Name); Init (It2, Decl (Member_Node)); while not Is_End (It2) loop Get_Next_Node (It2, Decl_Node); PL (CU, "Index := " & "CORBA.Internals.Get_Aggregate_Element (Item,"); Add_With (CU, Ada_Helper_Unit_Name (Mapping, M_Type (Member_Node))); PL (CU, " " & Ada_Full_TC_Name (Type_Node) & ","); PL (CU, " " & "CORBA.Unsigned_Long (" & Integer'Image (J) &"));"); Add_With (CU, Helper_Name); PL (CU, "Result_" & Ada_Name (Decl_Node) & " := " & Helper_Name & ".From_Any (Index);"); J := J + 1; end loop; end; end loop; end; PL (CU, "return"); II (CU); declare First_Member : Boolean := True; Begin_Of_Line : String (1 .. 1) := "("; End_Of_Line : String (1 .. 2) := ", "; It : Node_Iterator; Member_Node : Node_Id; begin Init (It, Members (Struct_Node)); while not Is_End (It) loop Get_Next_Node (It, Member_Node); declare It2 : Node_Iterator; Decl_Node : Node_Id; begin Init (It2, Decl (Member_Node)); while not Is_End (It2) loop Get_Next_Node (It2, Decl_Node); if Is_End (It) and then Is_End (It2) then End_Of_Line := ");"; end if; PL (CU, Begin_Of_Line & Ada_Name (Decl_Node) & " => Result_" & Ada_Name (Decl_Node) & End_Of_Line); if First_Member then First_Member := False; Begin_Of_Line := " "; end if; end loop; end; end loop; end; DI (CU); end if; DI (CU); PL (CU, "end From_Any;"); -- To_Any NL (CU); Gen_To_Any_Profile (CU, Struct_Node); PL (CU, " is"); II (CU); Put (CU, "Result : "); if Is_Empty then Put (CU, "constant "); end if; PL (CU, "CORBA.Any :="); II (CU); PL (CU, "CORBA.Internals.Get_Empty_Any_Aggregate (" & Ada_TC_Name (Node) & ");"); DI (CU); if Is_Empty then PL (CU, "pragma Warnings (Off);"); PL (CU, "pragma Unreferenced (Item);"); PL (CU, "pragma Warnings (On);"); end if; DI (CU); PL (CU, "begin"); II (CU); declare It : Node_Iterator; Member_Node : Node_Id; begin Init (It, Members (Struct_Node)); while not Is_End (It) loop Get_Next_Node (It, Member_Node); declare Type_Node : constant Node_Id := M_Type (Member_Node); Helper_Name : constant String := Helper_Unit (Type_Node); It2 : Node_Iterator; Decl_Node : Node_Id; begin Init (It2, Decl (Member_Node)); while not Is_End (It2) loop Get_Next_Node (It2, Decl_Node); PL (CU, "CORBA.Internals.Add_Aggregate_Element"); II (CU); PL (CU, "(Result, " & Helper_Name & ".To_Any (Item." & Ada_Name (Decl_Node) & "));"); DI (CU); end loop; end; end loop; end; PL (CU, "return Result;"); DI (CU); PL (CU, "end To_Any;"); end if; -- Fill in typecode TC_ Divert (CU, Deferred_Initialization); NL (CU); PL (CU, "declare"); II (CU); PL (CU, "Name : constant CORBA.String := CORBA.To_CORBA_String (""" & Ada_Name (Node) & """);"); PL (CU, "Id : constant CORBA.String := CORBA.To_CORBA_String (""" & Idl_Repository_Id (Node) & """);"); declare It : Node_Iterator; Member_Node : Node_Id; begin Init (It, Members (Struct_Node)); while not Is_End (It) loop Get_Next_Node (It, Member_Node); declare It2 : Node_Iterator; Decl_Node : Node_Id; begin Init (It2, Decl (Member_Node)); while not Is_End (It2) loop Get_Next_Node (It2, Decl_Node); PL (CU, "Arg_Name_" & Ada_Name (Decl_Node) & " : constant CORBA.String := CORBA.To_CORBA_String (""" & Ada_Name (Decl_Node) & """);"); end loop; end; end loop; end; DI (CU); PL (CU, "begin"); II (CU); Add_With (CU, "PolyORB.Any"); PL (CU, Ada_TC_Name (Node) & " :="); Put (CU, " CORBA.TypeCode.Internals.To_CORBA_Object" & " (PolyORB.Any.TypeCode."); if Kind (Node) = K_Struct then Put (CU, "TC_Struct"); else Put (CU, "TC_Except"); end if; PL (CU, ");"); PL (CU, "CORBA.Internals.Add_Parameter (" & Ada_TC_Name (Node) & ", CORBA.To_Any (Name));"); PL (CU, "CORBA.Internals.Add_Parameter (" & Ada_TC_Name (Node) & ", CORBA.To_Any (Id));"); declare It : Node_Iterator; Member_Node : Node_Id; begin Init (It, Members (Struct_Node)); while not Is_End (It) loop Get_Next_Node (It, Member_Node); Add_With (CU, Ada_Helper_Unit_Name (Mapping, M_Type (Member_Node))); declare It2 : Node_Iterator; Decl_Node : Node_Id; begin Init (It2, Decl (Member_Node)); while not Is_End (It2) loop Get_Next_Node (It2, Decl_Node); PL (CU, "CORBA.Internals.Add_Parameter (" & Ada_TC_Name (Node) & ", CORBA.To_Any (" & Ada_Full_TC_Name (M_Type (Member_Node)) & "));"); PL (CU, "CORBA.Internals.Add_Parameter (" & Ada_TC_Name (Node) & ", CORBA.To_Any (Arg_Name_" & Ada_Name (Decl_Node) & "));"); end loop; end; end loop; end; PL (CU, "CORBA.TypeCode.Internals.Disable_Reference_Counting (" & Ada_TC_Name (Node) & ");"); DI (CU); PL (CU, "end;"); Divert (CU, Visible_Declarations); end Gen_Struct_Exception_Body; ------------------------------ -- Gen_String_Instance_Spec -- ------------------------------ procedure Gen_String_Instance_Spec (CU : in out Compilation_Unit; Node : Node_Id) is begin -- Typecode generation Add_With (CU, "CORBA"); NL (CU); PL (CU, Ada_TC_Name (Node) & " : CORBA.TypeCode.Object;"); -- From_Any NL (CU); Gen_From_Any_Profile (CU, Node, From_Container => False); PL (CU, ";"); -- To_Any NL (CU); Gen_To_Any_Profile (CU, Node); PL (CU, ";"); -- Wrap NL (CU); Gen_Wrap_Profile (CU, Node); PL (CU, ";"); end Gen_String_Instance_Spec; ------------------------------ -- Gen_String_Instance_Body -- ------------------------------ procedure Gen_String_Instance_Body (CU : in out Compilation_Unit; Node : Node_Id) is begin -- From_Any NL (CU); Gen_From_Any_Profile (CU, Node, From_Container => False); NL (CU); PL (CU, " renames " & Ada_Name (Node) & ".From_Any;"); -- To_Any NL (CU); Gen_To_Any_Profile (CU, Node); NL (CU); PL (CU, " renames " & Ada_Name (Node) & ".To_Any;"); -- Wrap NL (CU); Gen_Wrap_Profile (CU, Node); NL (CU); PL (CU, " renames " & Ada_Name (Node) & ".Wrap;"); -- Fill in the typecode TC_ Divert (CU, Deferred_Initialization); NL (CU); PL (CU, "begin"); II (CU); Put (CU, Ada_TC_Name (Node) & " := "); Add_With (CU, "CORBA", Elab_Control => Elaborate_All); if Is_Wide (Node) then PL (CU, "CORBA.TypeCode.Internals.Build_Wstring_TC (" & Img (Expr_Value (Bound (Node))) & ");"); else PL (CU, "CORBA.TypeCode.Internals.Build_String_TC (" & Img (Expr_Value (Bound (Node))) & ");"); end if; PL (CU, "CORBA.TypeCode.Internals.Disable_Reference_Counting (" & Ada_TC_Name (Node) & ");"); DI (CU); PL (CU, "end;"); Divert (CU, Visible_Declarations); end Gen_String_Instance_Body; -------------------- -- Gen_Union_Spec -- -------------------- procedure Gen_Union_Spec (CU : in out Compilation_Unit; Node : Node_Id) is begin -- TypeCode generation Add_With (CU, "CORBA", Elab_Control => Elaborate_All); NL (CU); PL (CU, Ada_TC_Name (Node) & " : CORBA.TypeCode.Object;"); if not Has_Local_Component (Node) then -- From_Any NL (CU); Gen_From_Any_Profile (CU, Node, From_Container => False); PL (CU, ";"); -- To_Any NL (CU); Gen_To_Any_Profile (CU, Node); PL (CU, ";"); end if; end Gen_Union_Spec; -------------------- -- Gen_Union_Body -- -------------------- procedure Gen_Union_Body (CU : in out Compilation_Unit; Node : Node_Id) is ST_Node : constant Node_Id := Switch_Type (Node); Switch_Helper_Name : constant String := Helper_Unit (ST_Node); Switch_TCU_Name : constant String := TC_Unit (ST_Node); begin Add_Helper_Dependency (CU, Switch_TCU_Name); Add_Helper_Dependency (CU, Switch_Helper_Name); if not Has_Local_Component (Node) then -- From_Any NL (CU); Gen_From_Any_Profile (CU, Node, From_Container => False); PL (CU, " is"); II (CU); PL (CU, "Label_Any : constant CORBA.Any :="); II (CU); PL (CU, "CORBA.Internals.Get_Aggregate_Element (Item,"); PL (CU, " " & Ada_Full_TC_Name (ST_Node) & ","); PL (CU, " CORBA.Unsigned_Long (0));"); DI (CU); PL (CU, "Label : constant " & Ada_Type_Name (ST_Node) & " := " & Switch_Helper_Name & ".From_Any (Label_Any);"); PL (CU, "Result : " & Ada_Type_Name (Node) & " (Label);"); PL (CU, "Index : CORBA.Any;"); DI (CU); PL (CU, "begin"); II (CU); PL (CU, "case Label is"); II (CU); declare It : Node_Iterator; Case_Node : Node_Id; J : Long_Integer := 0; Has_Default : Boolean := False; begin Init (It, Cases (Node)); while not Is_End (It) loop Get_Next_Node (It, Case_Node); declare CT_Node : constant Node_Id := Case_Type (Case_Node); Helper_Name : constant String := Helper_Unit (CT_Node); TCU_Name : constant String := TC_Unit (CT_Node); It2 : Node_Iterator; Label_Node : Node_Id; First_Label : Boolean := True; begin Add_Helper_Dependency (CU, TCU_Name); Add_With (CU, Helper_Name); if Default_Index (Node) = J then Has_Default := True; Put (CU, "when others"); else Init (It2, Labels (Case_Node)); while not Is_End (It2) loop Get_Next_Node (It2, Label_Node); if First_Label then Put (CU, "when "); First_Label := False; else Put (CU, " | "); end if; Gen_Constant_Value (CU, Expr => Label_Node, Typ => ST_Node); end loop; end if; PL (CU, " =>"); II (CU); PL (CU, "Index := CORBA.Internals.Get_Aggregate_Element"); II (CU); PL (CU, "(Item,"); PL (CU, " " & Ada_Full_TC_Name (CT_Node) & ","); PL (CU, " CORBA.Unsigned_Long (1));"); J := J + 1; DI (CU); PL (CU, "Result." & Ada_Name (Case_Decl (Case_Node)) & " := " & Helper_Name & ".From_Any (Index);"); DI (CU); end; end loop; if not Has_Default then Gen_When_Others_Clause (CU); end if; end; DI (CU); PL (CU, "end case;"); PL (CU, "return Result;"); DI (CU); PL (CU, "end From_Any;"); -- To_Any NL (CU); Gen_To_Any_Profile (CU, Node); PL (CU, " is"); II (CU); PL (CU, "Result : CORBA.Any :="); II (CU); PL (CU, "CORBA.Internals.Get_Empty_Any_Aggregate (" & Ada_TC_Name (Node) & ");"); DI (CU); DI (CU); PL (CU, "begin"); II (CU); PL (CU, "CORBA.Internals.Add_Aggregate_Element"); II (CU); PL (CU, "(Result, " & Switch_Helper_Name & ".To_Any (Item.Switch));"); DI (CU); PL (CU, "case Item.Switch is"); II (CU); declare It : Node_Iterator; Case_Node : Node_Id; J : Long_Integer := 0; Has_Default : Boolean := False; begin Init (It, Cases (Node)); while not Is_End (It) loop Get_Next_Node (It, Case_Node); declare CT_Node : constant Node_Id := Case_Type (Case_Node); Helper_Name : constant String := Helper_Unit (CT_Node); It2 : Node_Iterator; Label_Node : Node_Id; First_Label : Boolean := True; begin if Default_Index (Node) = J then Put (CU, "when others"); Has_Default := True; else Init (It2, Labels (Case_Node)); while not Is_End (It2) loop Get_Next_Node (It2, Label_Node); if First_Label then Put (CU, "when "); First_Label := False; else Put (CU, " | "); end if; Gen_Constant_Value (CU, Expr => Label_Node, Typ => ST_Node); end loop; end if; PL (CU, " =>"); II (CU); PL (CU, "CORBA.Internals.Add_Aggregate_Element"); II (CU); PL (CU, "(Result, " & Helper_Name & ".To_Any (Item." & Ada_Name (Case_Decl (Case_Node)) & "));"); J := J + 1; DI (CU); DI (CU); end; end loop; if not Has_Default then Gen_When_Others_Clause (CU); end if; end; DI (CU); PL (CU, "end case;"); PL (CU, "return Result;"); DI (CU); PL (CU, "end To_Any;"); end if; -- Fill in typecode TC_ Divert (CU, Deferred_Initialization); NL (CU); PL (CU, "declare"); II (CU); PL (CU, "Name : constant CORBA.String := CORBA.To_CORBA_String (""" & Ada_Name (Node) & """);"); PL (CU, "Id : constant CORBA.String := CORBA.To_CORBA_String (""" & Idl_Repository_Id (Node) & """);"); declare It : Node_Iterator; Case_Node : Node_Id; begin Init (It, Cases (Node)); while not Is_End (It) loop Get_Next_Node (It, Case_Node); PL (CU, "Arg_Name_" & Ada_Name (Case_Decl (Case_Node)) & " : constant CORBA.String := CORBA.To_CORBA_String (""" & Ada_Name (Case_Decl (Case_Node)) & """);"); end loop; end; DI (CU); PL (CU, "begin"); II (CU); Add_With (CU, "PolyORB.Any"); PL (CU, Ada_TC_Name (Node) & " :="); PL (CU, " CORBA.TypeCode.Internals.To_CORBA_Object" & " (PolyORB.Any.TypeCode.TC_Union);"); PL (CU, "CORBA.Internals.Add_Parameter" & ASCII.LF & " (" & Ada_TC_Name (Node) & "," & ASCII.LF & " CORBA.To_Any (Name));"); PL (CU, "CORBA.Internals.Add_Parameter" & ASCII.LF & " (" & Ada_TC_Name (Node) & "," & ASCII.LF & " CORBA.To_Any (Id));"); PL (CU, "CORBA.Internals.Add_Parameter" & ASCII.LF & " (" & Ada_TC_Name (Node) & "," & ASCII.LF & " CORBA.To_Any (" & Ada_Full_TC_Name (ST_Node) & "));"); Put (CU, "CORBA.Internals.Add_Parameter" & ASCII.LF & " (" & Ada_TC_Name (Node) & "," & ASCII.LF & " CORBA.To_Any ("); declare Default : Long_Integer := Default_Index (Node); Negative : constant Boolean := Default < 0; begin if Negative then -- CORBA."-" (unary) may not be directly visible Put (CU, "CORBA.""-"" ("); Default := -Default; end if; Put (CU, "CORBA.Long'(" & Long_Integer_Img (Default) & ")"); if Negative then Put (CU, ")"); end if; end; PL (CU, "));"); declare It : Node_Iterator; Case_Node : Node_Id; I : Long_Integer := 0; begin Init (It, Cases (Node)); while not Is_End (It) loop Get_Next_Node (It, Case_Node); declare It2 : Node_Iterator; Label_Node : Node_Id; begin if Default_Index (Node) = I then PL (CU, "CORBA.Internals.Add_Parameter" & ASCII.LF & " (" & Ada_TC_Name (Node) & "," & ASCII.LF & " " & Switch_Helper_Name & ".To_Any (" & Ada_Type_Name (ST_Node) & "'First));"); Add_Helper_Dependency (CU, Ada_Helper_Unit_Name (Mapping, Case_Type (Case_Node))); PL (CU, "CORBA.Internals.Add_Parameter" & ASCII.LF & " (" & Ada_TC_Name (Node) & "," & ASCII.LF & " CORBA.To_Any (" & Ada_Full_TC_Name (Case_Type (Case_Node)) & "));"); PL (CU, "CORBA.Internals.Add_Parameter" & ASCII.LF & " (" & Ada_TC_Name (Node) & "," & ASCII.LF & " CORBA.To_Any (Arg_Name_" & Ada_Name (Case_Decl (Case_Node)) & "));"); else Init (It2, Labels (Case_Node)); while not Is_End (It2) loop Get_Next_Node (It2, Label_Node); Put (CU, "CORBA.Internals.Add_Parameter" & ASCII.LF & " (" & Ada_TC_Name (Node) & "," & ASCII.LF & " " & Switch_Helper_Name & ".To_Any (" & Ada_Type_Name (ST_Node) & "'("); Gen_Constant_Value (CU, Expr => Label_Node, Typ => ST_Node); PL (CU, ")));"); Add_Helper_Dependency (CU, Ada_Helper_Unit_Name (Mapping, Case_Type (Case_Node))); PL (CU, "CORBA.Internals.Add_Parameter" & ASCII.LF & " (" & Ada_TC_Name (Node) & "," & ASCII.LF & " CORBA.To_Any (" & Ada_Full_TC_Name (Case_Type (Case_Node)) & "));"); PL (CU, "CORBA.Internals.Add_Parameter" & ASCII.LF & " (" & Ada_TC_Name (Node) & "," & ASCII.LF & " CORBA.To_Any (Arg_Name_" & Ada_Name (Case_Decl (Case_Node)) & "));"); end loop; end if; I := I + 1; end; end loop; end; PL (CU, "CORBA.TypeCode.Internals.Disable_Reference_Counting (" & Ada_TC_Name (Node) & ");"); DI (CU); PL (CU, "end;"); Divert (CU, Visible_Declarations); end Gen_Union_Body; ------------------------------ -- Gen_Type_Declarator_Spec -- ------------------------------ procedure Gen_Type_Declarator_Spec (CU : in out Compilation_Unit; Node : Node_Id) is Is_Array : constant Boolean := Length (Array_Bounds (Node)) > 0; begin -- TypeCode NL (CU); Add_With (CU, "CORBA", Elab_Control => Elaborate_All); PL (CU, Ada_TC_Name (Node) & " : CORBA.TypeCode.Object;"); if Is_Array then for J in 1 .. Length (Array_Bounds (Node)) - 1 loop PL (CU, Ada_TC_Name (Node) & "_TC_Dimension_" & Img (J) & " : CORBA.TypeCode.Object;"); end loop; Gen_Aggregate_Content_Wrapper_Spec (CU, Node); end if; if not Is_Interface_Type (Node) and then not Has_Local_Component (Node) then -- From_Any NL (CU); Gen_From_Any_Profile (CU, Node, From_Container => False); PL (CU, ";"); -- Generate From_Any operating on PolyORB.Any.Any_Container'Class -- for elementary scalar types and enum types, as these can be used -- as switch type for unions. if not Is_Array then case Kind (Root_Type (Node)) is when K_Short | K_Long | K_Long_Long | K_Unsigned_Short | K_Unsigned_Long | K_Unsigned_Long_Long | K_Char | K_Wide_Char | K_Boolean | K_Octet | K_Enum => NL (CU); Gen_From_Any_Profile (CU, Node, From_Container => True); PL (CU, ";"); when others => null; end case; end if; -- To_Any NL (CU); Gen_To_Any_Profile (CU, Node); PL (CU, ";"); end if; end Gen_Type_Declarator_Spec; ------------------------------ -- Gen_Type_Declarator_Body -- ------------------------------ procedure Gen_Type_Declarator_Body (CU : in out Compilation_Unit; Node : Node_Id) is Is_Array : constant Boolean := Length (Array_Bounds (Node)) > 0; Type_Node : constant Node_Id := T_Type (Parent (Node)); Helper_Name : constant String := Helper_Unit (Type_Node); TCU_Name : constant String := TC_Unit (Type_Node); begin -- Fill in typecode TC_ Divert (CU, Deferred_Initialization); NL (CU); PL (CU, "declare"); II (CU); if not Is_Array then PL (CU, "Name : constant CORBA.String := CORBA.To_CORBA_String (""" & Ada_Name (Node) & """);"); PL (CU, "Id : constant CORBA.String := CORBA.To_CORBA_String (""" & Idl_Repository_Id (Node) & """);"); end if; DI (CU); PL (CU, "begin"); II (CU); Put (CU, Ada_TC_Name (Node) & " :="); if not Is_Array then Add_Helper_Dependency (CU, TCU_Name); PL (CU, " CORBA.TypeCode.Internals.Build_Alias_TC"); PL (CU, " (Name => Name, Id => Id, Parent => " & Ada_Full_TC_Name (Type_Node) & ");"); else Add_With (CU, "PolyORB.Any"); NL (CU); Put (CU, " CORBA.TypeCode.Internals.To_CORBA_Object ("); PL (CU, "PolyORB.Any.TypeCode.TC_Array);"); for J in 1 .. Length (Array_Bounds (Node)) - 1 loop PL (CU, Ada_TC_Name (Node) & "_TC_Dimension_" & Img (J) & " := " & "CORBA.TypeCode.Internals.To_CORBA_Object" & " (PolyORB.Any.TypeCode.TC_Array);"); end loop; Gen_Array_TC (CU, Type_Node, Node); end if; PL (CU, "CORBA.TypeCode.Internals.Disable_Reference_Counting (" & Ada_TC_Name (Node) & ");"); DI (CU); PL (CU, "end;"); Divert (CU, Visible_Declarations); if Is_Interface_Type (Type_Node) and then not Is_Array then return; end if; if not Has_Local_Component (Node) then if Is_Array then Gen_Aggregate_Content_Wrapper_Body (CU, Node); end if; -- From_Any NL (CU); Gen_From_Any_Profile (CU, Node, From_Container => False); NL (CU); PL (CU, "is"); II (CU); Add_Helper_Dependency (CU, Helper_Name); if Is_Array then PL (CU, "Result : " & Ada_Type_Name (Node) & ";"); PL (CU, "Aux : array (Natural range 0 .. " & Img (Length (Array_Bounds (Node)) - 1) & ") of CORBA.Any;"); DI (CU); NL (CU); PL (CU, "begin"); II (CU); declare Bounds_It : Node_Iterator; Bound_Node : Node_Id; Dim : Natural := 0; begin Init (Bounds_It, Array_Bounds (Node)); while not Is_End (Bounds_It) loop Get_Next_Node (Bounds_It, Bound_Node); if Dim = 0 then PL (CU, "Aux (0) := Item;"); else PL (CU, "Aux (" & Img (Dim) & ") :="); PL (CU, " CORBA.Internals.Get_Aggregate_Element"); PL (CU, " (Aux (" & Img (Dim - 1) & "),"); PL (CU, " " & Ada_TC_Name (Node) & "_TC_Dimension_" & Img (Dim) & ","); PL (CU, " CORBA.Unsigned_Long (" & Loop_Parameter (Dim - 1) & "));"); end if; NL (CU); Put (CU, "for " & Loop_Parameter (Dim) & " in 0 .. "); Gen_Constant_Value (CU, Expr => Bound_Node, Typ => No_Node); PL (CU, " - 1 loop"); II (CU); Dim := Dim + 1; end loop; Put (CU, "Result "); for J in 0 .. Dim - 1 loop if J = 0 then Put (CU, "("); else Put (CU, ", "); end if; Put (CU, Loop_Parameter (J)); if J = Dim - 1 then Put (CU, ")"); end if; end loop; PL (CU, " :="); PL (CU, " " & Helper_Name & ".From_Any"); PL (CU, " (CORBA.Internals.Get_Aggregate_Element"); PL (CU, " (Aux (" & Img (Dim - 1) & "),"); PL (CU, " " & Ada_Full_TC_Name (Type_Node) & ","); PL (CU, " CORBA.Unsigned_Long (" & Loop_Parameter (Dim - 1) & ")));"); for J in 1 .. Dim loop DI (CU); PL (CU, "end loop;"); end loop; end; NL (CU); PL (CU, "return Result;"); else DI (CU); PL (CU, "begin"); II (CU); PL (CU, "return " & Ada_Type_Name (Node) & " (" & Ada_Type_Name (Type_Node) & "'(" & Helper_Name & ".From_Any (Item)));"); end if; DI (CU); PL (CU, "end From_Any;"); -- See Gen_Type_Declarator_Spec for details about the second -- version of From_Any. if not Is_Array then case Kind (Root_Type (Node)) is when K_Short | K_Long | K_Long_Long | K_Unsigned_Short | K_Unsigned_Long | K_Unsigned_Long_Long | K_Char | K_Wide_Char | K_Boolean | K_Octet | K_Enum => NL (CU); Gen_From_Any_Profile (CU, Node, From_Container => True); PL (CU, " is"); PL (CU, "begin"); II (CU); PL (CU, "return " & Ada_Type_Name (Node) & " (" & Ada_Type_Name (Type_Node) & "'(" & Helper_Name & ".From_Any (C)));"); DI (CU); PL (CU, "end From_Any;"); when others => null; end case; end if; -- To_Any NL (CU); Gen_To_Any_Profile (CU, Node); NL (CU); PL (CU, "is"); II (CU); if Is_Array then PL (CU, "Result : array (Natural range 0 .. " & Img (Length (Array_Bounds (Node)) - 1) & ") of CORBA.Any;"); DI (CU); NL (CU); PL (CU, "begin"); II (CU); declare Bounds_It : Node_Iterator; Bound_Node : Node_Id; Dim : Natural := 0; begin Init (Bounds_It, Array_Bounds (Node)); while not Is_End (Bounds_It) loop Get_Next_Node (Bounds_It, Bound_Node); PL (CU, "Result (" & Img (Dim) & ") :="); PL (CU, " CORBA.Internals.Get_Empty_Any_Aggregate"); if Dim = 0 then PL (CU, " (" & Ada_TC_Name (Node) & ");"); else PL (CU, " (" & Ada_TC_Name (Node) & "_TC_Dimension_" & Img (Dim) & ");"); end if; NL (CU); Put (CU, "for " & Loop_Parameter (Dim) & " in 0 .. "); Gen_Constant_Value (CU, Expr => Bound_Node, Typ => No_Node); PL (CU, " - 1 loop"); II (CU); Dim := Dim + 1; end loop; PL (CU, "CORBA.Internals.Add_Aggregate_Element"); PL (CU, " (Result (" & Img (Dim - 1) & "),"); II (CU); Put (CU, Helper_Name & ".To_Any (Item (" & Loop_Parameter (0)); for J in 1 .. Dim - 1 loop Put (CU, ", " & Loop_Parameter (J)); end loop; PL (CU, ")));"); DI (CU); for J in reverse 1 .. Dim loop if J /= Dim then PL (CU, "CORBA.Internals.Add_Aggregate_Element (Result (" & Img (J - 1) & "), Result (" & Img (J) & "));"); end if; DI (CU); PL (CU, "end loop;"); NL (CU); end loop; end; PL (CU, "return Result (0);"); else PL (CU, "Result : CORBA.Any := " & Helper_Name & ".To_Any (" & Ada_Type_Name (Type_Node) & " (Item));"); DI (CU); PL (CU, "begin"); II (CU); PL (CU, "CORBA.Internals.Set_Type (Result, " & Ada_TC_Name (Node) & ");"); PL (CU, "return Result;"); end if; DI (CU); PL (CU, "end To_Any;"); end if; end Gen_Type_Declarator_Body; ----------------------- -- Gen_Sequence_Spec -- ----------------------- procedure Gen_Sequence_Spec (CU : in out Compilation_Unit; Node : Node_Id) is begin -- TypeCode NL (CU); Add_With (CU, "CORBA"); PL (CU, Ada_TC_Name (Node) & " : CORBA.TypeCode.Object;"); if not Has_Local_Component (Node) then -- From_Any NL (CU); Gen_From_Any_Profile (CU, Node, From_Container => False); PL (CU, ";"); -- To_Any NL (CU); Gen_To_Any_Profile (CU, Node); PL (CU, ";"); -- Wrap NL (CU); Gen_Wrap_Profile (CU, Node); PL (CU, ";"); end if; end Gen_Sequence_Spec; ----------------------- -- Gen_Sequence_Body -- ----------------------- procedure Gen_Sequence_Body (CU : in out Compilation_Unit; Node : Node_Id) is Seq_Helper_Name : constant String := Ada_Name (Node) & "_Helper"; Seq_TC_Name : constant String := Ada_TC_Name (Node); Elt_Type : constant Node_Id := Sequence_Type (Sequence (Node)); Elt_Helper_Name : constant String := Helper_Unit (Elt_Type); Elt_TCU_Name : constant String := TC_Unit (Elt_Type); Elt_TC_Name : constant String := Ada_Full_TC_Name (Elt_Type); Elt_Wrap_Name : constant String := Ada_Name (Node) & "_Element_Wrap"; B_Node : constant Node_Id := Bound (Sequence (Node)); B_Value : Idl_Integer := 0; begin if not Has_Local_Component (Node) then if B_Node = No_Node then Add_With (CU, "PolyORB.Sequences.Unbounded.CORBA_Helper", Elab_Control => Elaborate_All); else Add_With (CU, "PolyORB.Sequences.Bounded.CORBA_Helper", Elab_Control => Elaborate_All); B_Value := Integer_Value (B_Node); end if; Add_Helper_Dependency (CU, Elt_Helper_Name); -- For element To_Any/From_Any -- Generate Element_Wrap NL (CU); PL (CU, "function " & Elt_Wrap_Name & " (X : access " & Ada_Type_Name (Elt_Type) & ") return PolyORB.Any.Content'Class is"); PL (CU, "begin"); II (CU); Put (CU, "return "); Gen_Wrap_Call (CU, Elt_Type, "X.all"); PL (CU, ";"); DI (CU); PL (CU, "end " & Elt_Wrap_Name & ";"); -- Instantiate generic sequence helper NL (CU); PL (CU, "package " & Seq_Helper_Name & " is new " & Ada_Name (Node) & ".CORBA_Helper"); Put (CU, " ("); II (CU); PL (CU, "Element_To_Any => " & Elt_Helper_Name & ".To_Any,"); PL (CU, "Element_From_Any => " & Elt_Helper_Name & ".From_Any,"); PL (CU, "Element_Wrap => " & Elt_Wrap_Name & ");"); DI (CU); -- Generate renamings-as-body from instance NL (CU); Gen_From_Any_Profile (CU, Node, From_Container => False); NL (CU); PL (CU, " renames " & Seq_Helper_Name & ".From_Any;"); NL (CU); Gen_To_Any_Profile (CU, Node); NL (CU); PL (CU, " renames " & Seq_Helper_Name & ".To_Any;"); NL (CU); Gen_Wrap_Profile (CU, Node); NL (CU); PL (CU, " renames " & Seq_Helper_Name & ".Wrap;"); end if; Divert (CU, Deferred_Initialization); Add_Helper_Dependency (CU, Elt_TCU_Name); -- For element TypeCode NL (CU); PL (CU, Ada_TC_Name (Node) & " := "); PL (CU, " CORBA.TypeCode.Internals.Build_Sequence_TC"); PL (CU, " (" & Elt_TC_Name & ", " & Img (B_Value) & ");"); PL (CU, "CORBA.TypeCode.Internals.Disable_Reference_Counting (" & Ada_TC_Name (Node) & ");"); if not Has_Local_Component (Node) then Put (CU, Seq_Helper_Name & ".Initialize" & ASCII.LF & " ("); II (CU); PL (CU, "Element_TC => " & Elt_TC_Name & ","); PL (CU, "Sequence_TC => " & Seq_TC_Name & ");"); DI (CU); Divert (CU, Visible_Declarations); end if; end Gen_Sequence_Body; -------------------- -- Gen_Fixed_Spec -- -------------------- procedure Gen_Fixed_Spec (CU : in out Compilation_Unit; Decl_Node : Node_Id) is begin -- TypeCode NL (CU); Add_With (CU, "CORBA", Elab_Control => Elaborate_All); PL (CU, Ada_TC_Name (Decl_Node) & " : CORBA.TypeCode.Object;"); -- From_Any NL (CU); Gen_From_Any_Profile (CU, Decl_Node, From_Container => False); PL (CU, ";"); -- To_Any NL (CU); Gen_To_Any_Profile (CU, Decl_Node); PL (CU, ";"); -- Wrap NL (CU); Gen_Wrap_Profile (CU, Decl_Node); PL (CU, ";"); end Gen_Fixed_Spec; -------------------- -- Gen_Fixed_Body -- -------------------- procedure Gen_Fixed_Body (CU : in out Compilation_Unit; Decl_Node : Node_Id) is Fixed_Node : constant Node_Id := T_Type (Parent (Decl_Node)); Type_Name : constant String := Ada_Name (Decl_Node); Helpers_Inst_Name : constant String := T_Helpers & Type_Name; begin NL (CU); PL (CU, "package " & Helpers_Inst_Name & " is"); Add_With (CU, "CORBA.Fixed_Point", Elab_Control => Elaborate_All); PL (CU, " new CORBA.Fixed_Point (" & Ada_Full_Name (Decl_Node) & ");"); -- From_Any NL (CU); Gen_From_Any_Profile (CU, Decl_Node, From_Container => False); NL (CU); PL (CU, " renames " & Helpers_Inst_Name & ".From_Any;"); -- To_Any NL (CU); Gen_To_Any_Profile (CU, Decl_Node); NL (CU); PL (CU, " renames " & Helpers_Inst_Name & ".To_Any;"); -- Wrap NL (CU); Gen_Wrap_Profile (CU, Decl_Node); NL (CU); PL (CU, " renames " & Helpers_Inst_Name & ".Wrap;"); -- Fill in typecode TC_ Divert (CU, Deferred_Initialization); NL (CU); Add_With (CU, "PolyORB.Any"); PL (CU, Ada_TC_Name (Decl_Node) & " :="); PL (CU, " CORBA.TypeCode.Internals.To_CORBA_Object" & " (PolyORB.Any.TypeCode.TC_Fixed);"); Put (CU, "CORBA.Internals.Add_Parameter (" & Ada_TC_Name (Decl_Node) & ", CORBA.To_Any (CORBA.Unsigned_Short ("); Gen_Constant_Value (CU, Expr => Digits_Nb (Fixed_Node), Typ => No_Node); PL (CU, ")));"); Put (CU, "CORBA.Internals.Add_Parameter (" & Ada_TC_Name (Decl_Node) & ", CORBA.To_Any (CORBA.Short ("); Gen_Constant_Value (CU, Expr => Scale (Fixed_Node), Typ => No_Node); PL (CU, ")));"); PL (CU, "CORBA.TypeCode.Internals.Disable_Reference_Counting (" & Ada_TC_Name (Decl_Node) & ");"); Divert (CU, Visible_Declarations); end Gen_Fixed_Body; ------------------ -- Gen_Array_TC -- ------------------ procedure Gen_Array_TC (CU : in out Compilation_Unit; Element_Type_Node : Node_Id; Decl_Node : Node_Id) is procedure Rec_Gen_Array_TC (CU : in out Compilation_Unit; It : in out Node_Iterator; First_Bound : Boolean; Index : Integer; Element_Type_Node : Node_Id; Decl_Node : Node_Id); -- Recursively generate the typecode for the component subtype of an -- array, then generate the typecode for the array itself. This is node -- by advancing the bounds iterator one step, to unwind one dimension, -- until no bounds remain, at which point we reference the typecode for -- the ultimate element type. ---------------------- -- Rec_Gen_Array_TC -- ---------------------- procedure Rec_Gen_Array_TC (CU : in out Compilation_Unit; It : in out Node_Iterator; First_Bound : Boolean; Index : Integer; Element_Type_Node : Node_Id; Decl_Node : Node_Id) is Bound_Node : Node_Id; Last_Bound : Boolean := False; begin Get_Next_Node (It, Bound_Node); if not Is_End (It) then Rec_Gen_Array_TC (CU, It, False, Index + 1, Element_Type_Node, Decl_Node); else Last_Bound := True; end if; Put (CU, "CORBA.Internals.Add_Parameter ("); if First_Bound then Put (CU, Ada_TC_Name (Decl_Node)); else Put (CU, Ada_TC_Name (Decl_Node) & "_TC_Dimension_" & Img (Index)); end if; Put (CU, ", CORBA.To_Any (CORBA.Unsigned_Long ("); Gen_Constant_Value (CU, Expr => Bound_Node, Typ => No_Node); PL (CU, ")));"); Put (CU, "CORBA.Internals.Add_Parameter ("); if First_Bound then Put (CU, Ada_TC_Name (Decl_Node)); else Put (CU, Ada_TC_Name (Decl_Node) & "_TC_Dimension_" & Img (Index)); end if; if Last_Bound then Put (CU, ", " & "CORBA.To_Any (" & Ada_Full_TC_Name (Element_Type_Node)); else Put (CU, ", CORBA.To_Any (" & Ada_TC_Name (Decl_Node) & "_TC_Dimension_" & Img (Index + 1)); end if; PL (CU, "));"); end Rec_Gen_Array_TC; Bounds_It : Node_Iterator; begin Init (Bounds_It, Array_Bounds (Decl_Node)); Rec_Gen_Array_TC (CU, Bounds_It, True, 0, Element_Type_Node, Decl_Node); end Gen_Array_TC; ------------------- -- Gen_Wrap_Call -- ------------------- procedure Gen_Wrap_Call (CU : in out Compilation_Unit; Typ : Node_Id; Expr : String) is Root_Typ : Node_Id := Root_Type (Typ); begin if Is_Interface_Type (Root_Typ) and then Ada_Type_Name (Root_Typ) /= "CORBA.TypeCode.Object" then Root_Typ := Idl_Fe.Tree.Make_Object (Loc (Root_Typ)); end if; declare Helper_Name : constant String := Helper_Unit (Root_Typ); Convert : constant Boolean := (Ada_Type_Name (Root_Typ) /= Ada_Type_Name (Typ)); begin Add_With (CU, Helper_Name); -- Perform view conversion to root type, then take -- 'Unrestricted_Access. Put (CU, Helper_Name & ".Wrap (" & Conditional_Call (Func => Ada_Type_Name (Root_Typ), Only_When => Convert, Expr => Expr) & "'Unrestricted_Access)"); end; end Gen_Wrap_Call; ---------------------- -- Gen_Wrap_Profile -- ---------------------- procedure Gen_Wrap_Profile (CU : in out Compilation_Unit; Node : Node_Id) is begin Add_With (CU, "PolyORB.Any"); Put (CU, "function Wrap (X : access " & Ada_Type_Name (Node) & ") return PolyORB.Any.Content'Class"); end Gen_Wrap_Profile; -------------------- -- Loop_Parameter -- -------------------- function Loop_Parameter (Dim : Natural) return String is begin return T_J & Img (Dim); end Loop_Parameter; ------------------------- -- Raise_From_Any_Name -- ------------------------- function Raise_From_Any_Name (Node : Node_Id) return String is begin pragma Assert (Kind (Node) = K_Exception); return "Raise_" & Ada_Name (Node) & "_From_Any"; end Raise_From_Any_Name; ---------------- -- Raise_Name -- ---------------- function Raise_Name (Node : Node_Id) return String is begin pragma Assert (Kind (Node) = K_Exception); return "Raise_" & Ada_Name (Node); end Raise_Name; ------------------- -- Type_Modifier -- ------------------- function Type_Modifier (Node : Node_Id) return String is begin pragma Assert (Kind (Node) = K_ValueType); if Boolean'Pos (Abst (Node)) + Boolean'Pos (Custom (Node)) + Boolean'Pos (Truncatable (Node)) > 1 then -- A Value Type cannot be at the same time -- abstract, custom or trucatable raise Program_Error; end if; if Abst (Node) then return "CORBA.VTM_ABSTRACT"; end if; if Custom (Node) then return "CORBA.VTM_CUSTOM"; end if; if Truncatable (Node) then return "CORBA.VTM_TRUNCATABLE"; end if; return "CORBA.VTM_NONE"; end Type_Modifier; ---------------- -- Visibility -- ---------------- function Visibility (Node : Node_Id) return String is begin pragma Assert (Kind (Node) = K_State_Member); if Is_Public (Node) then return "CORBA.PUBLIC_MEMBER"; else return "CORBA.PRIVATE_MEMBER"; end if; end Visibility; end Ada_Be.Idl2Ada.Helper; polyorb-2.8~20110207.orig/compilers/idlac/ada_be-idl2ada-helper.ads0000644000175000017500000000641511750740337024126 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- A D A _ B E . I D L 2 A D A . H E L P E R -- -- -- -- S p e c -- -- -- -- Copyright (C) 2001-2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ private package Ada_Be.Idl2Ada.Helper is Suffix : constant String := ".Helper"; procedure Gen_Node_Spec (CU : in out Compilation_Unit; Node : Node_Id); procedure Gen_Node_Body (CU : in out Compilation_Unit; Node : Node_Id); -- Generate an helper package procedure Add_Helper_Dependency (CU : in out Compilation_Unit; Helper_Name : String); -- Add a semantic dependency and an initialization dependency in CU -- upon Helper_Name. procedure Gen_Forward_Interface_Spec (CU : in out Compilation_Unit; Node : Node_Id); -- Generate the spec of the helper package for a forward interface -- declaration called directly by ada_be.idl2ada.gen_scope procedure Gen_Forward_Interface_Body (CU : in out Compilation_Unit; Node : Node_Id); -- Generate the body of the helper package for a forward interface -- declaration called directly by ada_be.idl2ada.gen_scope procedure Gen_Wrap_Call (CU : in out Compilation_Unit; Typ : Node_Id; Expr : String); -- Generate a call appropriate to wrap expression Expr (denoting some -- object to be pointed to) in a content wrapper for the given type. end Ada_Be.Idl2Ada.Helper; polyorb-2.8~20110207.orig/compilers/idlac/idl_fe-tree-low_level.adb0000644000175000017500000000561711750740337024307 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- I D L _ F E . T R E E . L O W _ L E V E L -- -- -- -- B o d y -- -- -- -- Copyright (C) 2001-2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ package body Idl_Fe.Tree.Low_Level is procedure Replace_Node (Old_Node : in out Node_Id; New_Node : in out Node_Id) is Temp_Node : constant Node_Access := Nodes_Table.Table (Old_Node); Temp_Id : constant Node_Id := Old_Node; begin Nodes_Table.Table (Old_Node) := Nodes_Table.Table (New_Node); Nodes_Table.Table (New_Node) := Temp_Node; Old_Node := New_Node; New_Node := Temp_Id; Set_Original_Node (New_Node, Old_Node); end Replace_Node; function Copy_Node (Old_Node : Node_Id) return Node_Id is Node : constant Node_Access := new Node_Type; Index : constant Node_Id := Nodes_Table.Allocate; begin Node.all := Nodes_Table.Table (Old_Node).all; Nodes_Table.Table (Index) := Node; Set_Original_Node (Index, Old_Node); return Index; end Copy_Node; end Idl_Fe.Tree.Low_Level; polyorb-2.8~20110207.orig/compilers/idlac/README.Expansion0000644000175000017500000000461211750740337022307 0ustar xavierxavierThe following expansion occurs on the IDL tree ---------------------------------------------- - a simple typedef: typedef fixed<8,2> Megabucks[3]; -> {fixed(8,2,Fixed_8_2)} {fixed(DIGITS,SCALE,NAME)} is a new node kind for fixed type declarations. It is mapped to "type NAME is delta 10 ** -SCALE digits DIGITS;" typedef fixed<8,2>{Fixed_8_2} Megabucks[3]; // The N_Fixed_Type node has a new attribute which is // a pointer to the expanded {fixed} node. typedef sequence> SeqSeqFoo; -> N1:{seq(Name=IDL_SEQUENCE_foo,Bound=0,Element_Type=foo)} N2:{seq(Name=IDL_SEQUENCE_SEQUENCE_foo,Bound=0,Element_Type=N1)} typedef N2 SeqSeqFoo; {seq} is a new node kind for generic CORBA.Sequences.* instantiations. It is a named node, and holds a reference to the original sequence node as its Original_Node field. The {seq} node replaces the original sequence node wherever it is used, *and* is inserted in the scope where it is used, before the declaration that uses it. - For complex_declarators in struct members - -> eg typedef enum Color {Red, Green, Blue} RGB -> enum Color {Red, Green, Blue}; typedef enum Color RGB; - In a union, the default label shall be the only element in its label_list: own case: union U switch (long) { case 1: long foo; case 2: long bar; case 3: default: long baz; } -> union U switch(long) { case 1: long foo; case 2: long bar; default: long baz; // Covers the 3 case as well anyway. } - A usage occurence of an interface name within its parent scope must resolve to denote a forward declaration of this interface: module M { interface I { ... }; typedef I J; } -> module M { interface I; interface I { ... }; typedef I J; } (where the N_Scoped_Name "I" in the typedef shall have a Value that designates the newly-inserted N_Forward_Interface node.). - Exception members: exception E { members... }; -> struct E_Members { members... }; exception E{members_type: ...} { members... }; (where Members_Type is a new Node_Id attribute of node K_Exception that designates the expanded struct _Members). - Repository IDs for all interfaces: interface I { exports ... }; -> interface I{RepositoryID="IDL:/.../I:1.0"} { exports ... }; (where {RepositoryID} is a new attribute of N_Interface). - Bounded string types -> typedefs. polyorb-2.8~20110207.orig/compilers/idlac/ada_be-mappings-corba-alm_1_2.adb0000644000175000017500000001005411750740337025434 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- A D A _ B E . M A P P I N G S . C O R B A . A L M _ 1 _ 2 -- -- -- -- B o d y -- -- -- -- Copyright (C) 2005-2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with Ada_Be.Identifiers; use Ada_Be.Identifiers; with Idl_Fe.Tree; use Idl_Fe.Tree; with Idl_Fe.Types; use Idl_Fe.Types; package body Ada_Be.Mappings.CORBA.ALM_1_2 is function Is_CORBA_TypeCode (Node : Idl_Fe.Types.Node_Id) return Boolean; -- Return True iff Node denote CORBA.TypeCode interface declaration ----------------------------------- -- Fetch_Calling_Stubs_Type_Name -- ----------------------------------- function Fetch_Calling_Stubs_Type_Name (Node : Node_Id) return String is begin pragma Assert (Is_Well_Known_Node (Node)); if Is_CORBA_TypeCode (Node) then return "TypeCode.Object"; else raise Program_Error; end if; end Fetch_Calling_Stubs_Type_Name; ---------------------------- -- Fetch_Helper_Unit_Name -- ---------------------------- function Fetch_Helper_Unit_Name (Node : Node_Id) return String is begin pragma Assert (Is_Well_Known_Node (Node)); if Is_CORBA_TypeCode (Node) then return "CORBA"; else raise Program_Error; end if; end Fetch_Helper_Unit_Name; --------------------- -- Fetch_Unit_Name -- --------------------- function Fetch_Unit_Name (Node : Node_Id) return String is begin pragma Assert (Is_Well_Known_Node (Node)); if Is_CORBA_TypeCode (Node) then return "CORBA"; else raise Program_Error; end if; end Fetch_Unit_Name; ----------------------- -- Is_CORBA_TypeCode -- ----------------------- function Is_CORBA_TypeCode (Node : Node_Id) return Boolean is begin return Kind (Node) = K_Interface and then Ada_Full_Name (Node) = "CORBA.TypeCode"; end Is_CORBA_TypeCode; ------------------------ -- Is_Well_Known_Node -- ------------------------ function Is_Well_Known_Node (Node : Node_Id) return Boolean is begin if Is_CORBA_TypeCode (Node) then return True; else return False; end if; end Is_Well_Known_Node; end Ada_Be.Mappings.CORBA.ALM_1_2; polyorb-2.8~20110207.orig/compilers/idlac/ada_be-mappings-corba.adb0000644000175000017500000003344711750740337024237 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- A D A _ B E . M A P P I N G S . C O R B A -- -- -- -- B o d y -- -- -- -- Copyright (C) 2001-2007, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- The CORBA personality IDL mapping. with Idlac_Errors; use Idlac_Errors; with Idl_Fe.Tree; use Idl_Fe.Tree; with Idl_Fe.Tree.Synthetic; use Idl_Fe.Tree.Synthetic; with Ada_Be.Identifiers; use Ada_Be.Identifiers; with Ada_Be.Mappings.CORBA.ALM_1_2; use Ada_Be.Mappings.CORBA.ALM_1_2; package body Ada_Be.Mappings.CORBA is use Idl_Fe.Types; Skel_Suffix : constant String := ".Skel"; Helper_Suffix : constant String := ".Helper"; -------------------------- -- Ada_Helper_Unit_Name -- -------------------------- function Ada_Helper_Unit_Name (Mapping : access CORBA_Mapping_Type; Node : Node_Id) return String is NK : constant Node_Kind := Kind (Node); begin case NK is when K_Module | K_Interface | K_ValueType | K_Ben_Idl_File => if Is_Well_Known_Node (Node) then return Fetch_Helper_Unit_Name (Node); else return Client_Stubs_Unit_Name (Mapping, Node) & Helper_Suffix; end if; when K_Forward_Interface | K_Forward_ValueType => return Ada_Helper_Unit_Name (Mapping, Forward (Node)); when K_Sequence_Instance | K_String_Instance | K_Declarator | K_Enum | K_Union | K_Struct | K_Exception => null; when K_Scoped_Name => return Ada_Helper_Unit_Name (Mapping, Value (Node)); when K_Short | K_Long | K_Long_Long | K_Unsigned_Short | K_Unsigned_Long | K_Unsigned_Long_Long | K_Char | K_Wide_Char | K_Boolean | K_Float | K_Double | K_Long_Double | K_String | K_Wide_String | K_Octet | K_Any | K_Void => return "CORBA"; when K_Object => return "CORBA.Object.Helper"; when others => -- Improper use: node N is not -- mapped to an Ada type. Error ("No helpers for " & Node_Kind'Image (NK) & " nodes.", Fatal, Get_Location (Node)); -- Keep the compiler happy. raise Program_Error; end case; return Client_Stubs_Unit_Name (Mapping, Parent_Scope (Node)) & Helper_Suffix; end Ada_Helper_Unit_Name; ---------------------------- -- Ada_Type_Defining_Name -- ---------------------------- function Ada_Type_Defining_Name (Mapping : access CORBA_Mapping_Type; Node : Node_Id) return String is NK : constant Node_Kind := Kind (Node); begin case NK is when K_Interface | K_Forward_Interface => return Calling_Stubs_Type (Mapping, Node); when K_ValueType | K_Forward_ValueType => if Abst (Node) then return "Abstract_Value_Ref"; else return "Value_Ref"; end if; when others => -- Improper use: node N is not an -- Interface or ValueType. Error ("Improper call of Ada_Type_Defining_Name with a " & Node_Kind'Image (NK), Fatal, Get_Location (Node)); -- Keep the compiler happy. raise Program_Error; end case; end Ada_Type_Defining_Name; ----------------------- -- Library_Unit_Name -- ----------------------- function Library_Unit_Name (Self : access CORBA_Mapping_Type; Node : Node_Id) return String is NK : constant Node_Kind := Kind (Node); begin if Is_Well_Known_Node (Node) then return Fetch_Unit_Name (Node); end if; case NK is when K_Interface | K_Module | K_ValueType | K_Ben_Idl_File => return Ada_Full_Name (Node); when K_Enum | K_Union | K_Struct | K_Declarator | K_Forward_Interface | K_Forward_ValueType | K_Boxed_ValueType | K_Exception | K_Sequence_Instance | K_String_Instance => return Library_Unit_Name (Self, Parent_Scope (Node)); when K_Scoped_Name => return Library_Unit_Name (Self, Value (Node)); when K_Short | K_Long | K_Long_Long | K_Unsigned_Short | K_Unsigned_Long | K_Unsigned_Long_Long | K_Char | K_Wide_Char | K_Boolean | K_Float | K_Double | K_Long_Double | K_String | K_Wide_String | K_Octet | K_Any => return "CORBA"; when K_Object => return "CORBA.Object"; when others => Error ("A " & Node_Kind'Image (NK) & " is not a mapped entity.", Fatal, Get_Location (Node)); end case; return ""; end Library_Unit_Name; function Client_Stubs_Unit_Name (Self : access CORBA_Mapping_Type; Node : Idl_Fe.Types.Node_Id) return String is begin return Library_Unit_Name (Self, Node); end Client_Stubs_Unit_Name; function Server_Skel_Unit_Name (Self : access CORBA_Mapping_Type; Node : Idl_Fe.Types.Node_Id) return String is begin return Client_Stubs_Unit_Name (Self, Node) & Skel_Suffix; end Server_Skel_Unit_Name; function Self_For_Operation (Self : access CORBA_Mapping_Type; Node : Idl_Fe.Types.Node_Id) return String is pragma Warnings (Off); pragma Unreferenced (Self, Node); pragma Warnings (On); begin return "Self"; -- In CORBA stubs, the target objet is always passed -- as a formal parameter named Self. end Self_For_Operation; -------------------------------- -- Code_Generation_Suppressed -- -------------------------------- function Code_Generation_Suppressed (Mapping : access CORBA_Mapping_Type; Node : Node_Id) return Boolean is pragma Unreferenced (Mapping); function Has_Period_Delimited_Prefix (Name : String; Prefix : String) return Boolean; -- Return True iff Name has Prefix, matching only complete -- period-separated elements. --------------------------------- -- Has_Period_Delimited_Prefix -- --------------------------------- function Has_Period_Delimited_Prefix (Name : String; Prefix : String) return Boolean is Length : constant Natural := Prefix'Length; begin return Name'Length >= Length and then Name (Name'First .. Name'First + Length - 1) = Prefix and then (Name'Length = Length or else Name (Name'First + Length) = '.'); end Has_Period_Delimited_Prefix; begin pragma Assert (Kind (Node) = K_Ben_Idl_File or else Kind (Node) = K_Module or else Kind (Node) = K_Interface); declare Name : constant String := Ada_Full_Name (Node); begin -- By default all CORBA modules are predefined, except -- for CORBA.Repository_Root. return Has_Period_Delimited_Prefix (Name, "CORBA") and then not Has_Period_Delimited_Prefix (Name, "CORBA.Repository_Root"); end; end Code_Generation_Suppressed; ------------------- -- Map_Type_Name -- ------------------- procedure Map_Type_Name (Self : access CORBA_Mapping_Type; Node : Node_Id; Unit : out ASU.Unbounded_String; Typ : out ASU.Unbounded_String) is use Ada.Strings.Unbounded; NK : constant Node_Kind := Kind (Node); begin Unit := +Library_Unit_Name (Self, Node); case NK is when K_Interface | K_ValueType => Typ := Unit & "." & Ada_Type_Defining_Name (Self, Node); when K_Forward_Interface | K_Forward_ValueType => Typ := Unit & "." & Ada_Name (Node) & "." & Ada_Type_Defining_Name (Self, Node); when K_Sequence_Instance => Typ := +(Ada_Full_Name (Node) & ".Sequence"); when K_String_Instance => if Is_Wide (Node) then Typ := +(Ada_Full_Name (Node) & ".Bounded_Wide_String"); else Typ := +(Ada_Full_Name (Node) & ".Bounded_String"); end if; when K_Enum | K_Union | K_Struct | K_Exception | K_Boxed_ValueType | K_Declarator => Typ := +Ada_Full_Name (Node); when K_Scoped_Name => Map_Type_Name (Self, Value (Node), Unit, Typ); when K_Short => Typ := +"CORBA.Short"; when K_Long => Typ := +"CORBA.Long"; when K_Long_Long => Typ := +"CORBA.Long_Long"; when K_Unsigned_Short => Typ := +"CORBA.Unsigned_Short"; when K_Unsigned_Long => Typ := +"CORBA.Unsigned_Long"; when K_Unsigned_Long_Long => Typ := +"CORBA.Unsigned_Long_Long"; when K_Char => Typ := +"CORBA.Char"; when K_Wide_Char => Typ := +"CORBA.Wchar"; when K_Boolean => Typ := +"CORBA.Boolean"; when K_Float => Typ := +"CORBA.Float"; when K_Double => Typ := +"CORBA.Double"; when K_Long_Double => Typ := +"CORBA.Long_Double"; when K_String => Typ := +"CORBA.String"; when K_Wide_String => Typ := +"CORBA.Wide_String"; when K_Octet => Typ := +"CORBA.Octet"; when K_Object => Typ := +"CORBA.Object.Ref"; when K_Any => Typ := +"CORBA.Any"; when others => -- Improper use: node N is not mapped to an Ada type Error ("This Ada_Type_Name : A " & Node_Kind'Image (NK) & " does not denote a type.", Fatal, Get_Location (Node)); -- Keep the compiler happy raise Program_Error; end case; end Map_Type_Name; function Calling_Stubs_Type (Self : access CORBA_Mapping_Type; Node : Idl_Fe.Types.Node_Id) return String is pragma Warnings (Off); pragma Unreferenced (Self); pragma Warnings (On); begin if Abst (Node) then return "Abstract_Ref"; elsif Kind (Node) = K_Interface and then Local (Node) then return "Local_Ref"; elsif Is_Well_Known_Node (Node) then return Fetch_Calling_Stubs_Type_Name (Node); else return "Ref"; end if; end Calling_Stubs_Type; function Generate_Scope_In_Child_Package (Self : access CORBA_Mapping_Type; Node : Idl_Fe.Types.Node_Id) return Boolean is pragma Warnings (Off); pragma Unreferenced (Self); pragma Warnings (On); begin pragma Assert (Is_Gen_Scope (Node)); -- For CORBA, all Gen_Scopes are generated in child packages return True; end Generate_Scope_In_Child_Package; end Ada_Be.Mappings.CORBA; polyorb-2.8~20110207.orig/compilers/idlac/ada_be-mappings.ads0000644000175000017500000001117211750740337023163 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- A D A _ B E . M A P P I N G S -- -- -- -- S p e c -- -- -- -- Copyright (C) 2001-2002 Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by ACT Europe. -- -- (email: sales@act-europe.fr) -- -- -- ------------------------------------------------------------------------------ -- The abstract interface for all personality mappings of distributed -- object service descriptions (i.e. IDL trees). with Ada.Strings.Unbounded; with Idl_Fe.Types; package Ada_Be.Mappings is package ASU renames Ada.Strings.Unbounded; function "+" (S : String) return ASU.Unbounded_String renames ASU.To_Unbounded_String; function "-" (US : ASU.Unbounded_String) return String renames ASU.To_String; type Mapping_Type is abstract tagged private; -- The root type for all personality mappings. Each -- mapping must provide a concrete derivation of Mapping_Type -- that implements the following operations. function Library_Unit_Name (Self : access Mapping_Type; Node : Idl_Fe.Types.Node_Id) return String is abstract; -- Return the name of the library unit that contains the -- entity mapping Node. function Client_Stubs_Unit_Name (Self : access Mapping_Type; Node : Idl_Fe.Types.Node_Id) return String is abstract; -- Return the name of the library unit that contains the -- client stubs for interface or valuetype Node. function Server_Skel_Unit_Name (Self : access Mapping_Type; Node : Idl_Fe.Types.Node_Id) return String is abstract; -- Return the name of the library unit that contains the -- server skeleton for interface or valuetype Node. function Self_For_Operation (Self : access Mapping_Type; Node : Idl_Fe.Types.Node_Id) return String is abstract; -- Return an expression that resolves to denote the target -- object reference in a calling stub unit. procedure Map_Type_Name (Self : access Mapping_Type; Node : Idl_Fe.Types.Node_Id; Unit : out ASU.Unbounded_String; Typ : out ASU.Unbounded_String) is abstract; -- Given a Node that denotes a type, provide a library -- unit name (Unit) and a complete entity name (Typ) that -- resolves to denote a type declaration within Unit -- which declares the type that maps Node. function Calling_Stubs_Type (Self : access Mapping_Type; Node : Idl_Fe.Types.Node_Id) return String is abstract; -- Return the defining name for the calling stubs type -- corresponding to Node. function Generate_Scope_In_Child_Package (Self : access Mapping_Type; Node : Idl_Fe.Types.Node_Id) return Boolean is abstract; -- Given a Gen_Scope Node, return True if, and only if, -- the code generation for Node needs to occur in a new -- child unit. private type Mapping_Type is abstract tagged null record; end Ada_Be.Mappings; polyorb-2.8~20110207.orig/compilers/idlac/idl_fe-lexer.ads0000644000175000017500000004100511750740337022511 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- I D L _ F E . L E X E R -- -- -- -- S p e c -- -- -- -- Copyright (C) 2001-2007, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with Idlac_Errors; package Idl_Fe.Lexer is pragma Elaborate_Body; ----------------------------- -- IDL keywords and tokens -- ----------------------------- -- All the idl_keywords -- -- IDL Syntax and semantics, CORBA V3.0 § 3.2.4 -- -- All the idl tokens. type Idl_Token is ( T_Error, -- Position 0. T_Abstract, -- Keywords, synchronised with keywords T_Any, T_Attribute, T_Boolean, T_Case, T_Char, T_Component, T_Const, T_Consumes, T_Context, T_Custom, T_Default, T_Double, T_Emits, T_Enum, T_EventType, T_Exception, T_Factory, T_False, T_Finder, T_Fixed, T_Float, T_GetRaises, T_Home, T_Import, T_In, T_Inout, T_Interface, T_Local, T_Long, T_Module, T_Multiple, T_Native, T_Object, T_Octet, T_Oneway, T_Out, T_PrimaryKey, T_Private, T_Provides, T_Public, T_Publishes, T_Raises, T_Readonly, T_Sequence, T_SetRaises, T_Short, T_String, T_Struct, T_Supports, T_Switch, T_True, T_Truncatable, T_Typedef, T_TypeId, T_TypePrefix, T_Unsigned, T_Union, T_Uses, T_ValueBase, T_ValueType, T_Void, T_Wchar, T_Wstring, T_Semi_Colon, -- ; -- graphical character tokens T_Left_Cbracket, -- { T_Right_Cbracket, -- } T_Colon, -- : T_Comma, -- , T_Colon_Colon, -- :: T_Left_Paren, -- ( T_Right_Paren, -- ) T_Equal, -- = T_Bar, -- | T_Circumflex, -- ^ T_Ampersand, -- & T_Greater_Greater, -- >> T_Less_Less, -- << T_Plus, -- + T_Minus, -- - T_Star, -- * T_Slash, -- / T_Percent, -- % T_Tilde, -- ~ T_Less, -- < T_Greater, -- > T_Left_Sbracket, -- [ T_Right_Sbracket, -- ] T_Lit_Decimal_Integer, -- Literals T_Lit_Octal_Integer, T_Lit_Hexa_Integer, T_Lit_Char, T_Lit_Wide_Char, T_Lit_Simple_Floating_Point, T_Lit_Exponent_Floating_Point, T_Lit_Pure_Exponent_Floating_Point, T_Lit_String, T_Lit_Wide_String, T_Lit_Simple_Fixed_Point, T_Lit_Floating_Fixed_Point, T_Identifier, -- Identifier T_Eof, -- Misc T_End_Pragma, T_Pragma, T_Line ); ------------------------------------------------------------ -- Main lexer entry points: Initialize and Get_Next_Token -- ------------------------------------------------------------ procedure Initialize (Filename : String); -- Initialize the lexer by opening the file to process and by -- preprocessing it if necessary. If the lexer is already -- initialized then save it state and reinitialize for processing -- of new file. procedure Finalize; -- Finalize the lexer, close currently opened file, and restore -- previous state (return to processing previous file). function Get_Next_Token return Idl_Token; -- Analyse forward and return the next token. -- Returns T_Error if the entry is invalid. ------------------------------------------ -- Current state of the lexer. -- -- These subprograms must not be called -- -- outside the parser. -- ------------------------------------------ package Lexer_State is function Get_Lexer_Location return Idlac_Errors.Location; -- Return the location of the current token. function Get_Lexer_String return String; -- If the current token is an identifier, a literal -- or a pragma, return its string value end Lexer_State; --------------------------- -- IDL string processing -- --------------------------- type Ident_Equality is (Differ, Case_Differ, Equal); function Idl_Identifier_Equal (Left, Right : String) return Ident_Equality; -- Compare two IDL identifiers. The result is either DIFFER, if they -- are different identifiers, or CASE_DIFFER if it is the same identifier -- but with a different case on some letters, or at last EQUAL if it is -- the same word. -- -- CORBA V2.3, 3.2.3 -- When comparing two identifiers to see if they collide : -- - Upper- and lower-case letters are treated as the same letter. (...) -- - all characters are significant private ----------------------------------- -- Low-level string processing -- ----------------------------------- procedure Set_Token_Location; -- Set the line and column number of the current token function Get_Real_Location return Idlac_Errors.Location; -- Return the real location in the parsed file, with corrections -- for tabs taken into account. procedure Read_Line; -- Read in the next input line procedure Skip_Char; -- Skip over the current character procedure Skip_Line; -- Skip over the current line function Next_Char return Character; -- Read and consume one character function View_Next_Char return Character; -- Look ahead the next char without consuming it. -- Warning: if it is the end of a line, returns -- LF and not the first char of the next line function View_Next_Next_Char return Character; -- Look ahead the next next char without consuming it. -- Warning: if it is the end of a line, returns -- LF and not the first or second char of the next line function Get_Current_Char return Character; -- Return the current character procedure Refresh_Offset; -- Compute the new offset of the column when a tab is seen procedure Skip_Spaces; -- Skip over whitespace procedure Skip_Comment; -- Skip over a /* ... */ comment procedure Set_Mark; -- Set the mark in the text. -- If the line changes, the mark is repositioned at the beginning -- of the new line procedure Set_Mark_On_Next_Char; -- Set the mark on the char following the current one. procedure Set_End_Mark; -- Set the end mark in the text. -- If the line changes, the mark is replaced at the beginning -- of the new line procedure Set_End_Mark_On_Previous_Char; -- Sets the end mark on the char before the current one. function Get_Marked_Text return String; -- Return the text from the mark to the current position procedure Go_To_End_Of_Char; -- Skip over the characters until the next ' or the end of the line procedure Go_To_End_Of_String; -- skip over the characters until the next " or the end of the file ------------------------------- -- Low-level char processing -- ------------------------------- function Is_Alphabetic_Character (C : Standard.Character) return Boolean; -- True if C is an IDL alphabetic character function Is_Digit_Character (C : Standard.Character) return Boolean; -- True if C is a decimal digit function Is_Octal_Digit_Character (C : Standard.Character) return Boolean; -- True if C is an octal digit function Is_Hexa_Digit_Character (C : Standard.Character) return Boolean; -- True if C is an hexadecimal digit function Is_Identifier_Character (C : Standard.Character) return Boolean; -- True if C is an IDL identifier character, i.e. either an -- alphabetic character, a digit, or an underscore. --------------------------- -- IDL string processing -- --------------------------- type Idl_Keyword_State is (Is_Keyword, Is_Identifier, Bad_Case); -- The three kinds of identifiers: keywords, true -- identifiers or miscased keywords. procedure Is_Idl_Keyword (S : String; Is_Escaped : Boolean; Is_A_Keyword : out Idl_Keyword_State; Tok : out Idl_Token); -- Check whether S is an IDL keyword. -- Is_Escaped indicates whether the identifier was preceeded -- by an underscore. -- -- IDL Syntax and semantics, CORBA V2.3 § 3.2.4 -- -- keywords must be written exactly as in the above list. Identifiers -- that collide with keywords (...) are illegal. -------------------------------------- -- Scanners for chars, identifiers, -- -- numerics, string literals and -- -- preprocessor directives. -- -------------------------------------- function Scan_Char (Wide : Boolean) return Idl_Token; -- Called when the current character is a '. -- This procedure sets Current_Token and returns. -- The get_marked_text function returns then the -- character -- -- IDL Syntax and semantics, CORBA V2.3 § 3.2.5 -- -- Char Literals : (3.2.5.2) -- A character literal is one or more characters enclosed in single -- quotes, as in 'x'. -- Nongraphic characters must be represented using escape sequences as -- defined in Table 3-9. (escape sequences are \n, \t, \v, \b, \r, \f, -- \a, \\, \?, \', \", \ooo, \xhh and \uhhhh) -- -- The escape \ooo consists of the backslash followed by one, two or -- three octal digits that are taken to specify the value of the desired -- character. The escape \xhh consists of the backslash followed by x -- followed by one or two hexadecimal digits that are taken to specify -- the value of the desired character. -- -- The escape \uhhhh consist of a backslash followed by the character -- 'u', followed by one, two, three or four hexadecimal digits. -- -- Wide is used to say if the scanner should scan a wide -- character or not. If not and the character looks like -- '/u...' then an error is raised and the function returns -- T_Error function Scan_String (Wide : Boolean) return Idl_Token; -- Called when the current character is a ". -- This procedure sets Current_Token and returns. -- The get_marked_text function returns then the -- string literal -- -- IDL Syntax and semantics, CORBA V2.3 § 3.2.5 -- -- String Literals : (3.2.5.1) -- A string literal is a sequence of characters (...) surrounded -- by double quotes, as in "...". -- -- Adjacent string literals are concatenated. -- (...) -- Within a string, the double quote character " must be preceded -- by a \. -- A string literal may not contain the character '\0'. -- -- Wide is used to say if the scanner should scan a wide -- string or not. If not and a character looks like -- '/u...' then an error is raised function Scan_Identifier (Is_Escaped : Boolean) return Idl_Token; -- Called when the current character is a letter. -- This procedure sets TOKEN and returns. -- The get_marked_text function returns then the -- name of the identifier -- The is_escaped parameter says if this identifier was -- preceeded by an underscore or not -- -- IDL Syntax and semantics, CORBA V2.3, 3.2.5 -- -- Wide Chars : 3.5.2.2 -- Wide characters litterals have an L prefix, for example : -- const wchar C1 = L'X'; -- -- Wide Strings : 3.5.2.4 -- Wide string literals have an L prefix, for example : -- const wstring S1 = L"Hello"; -- -- Identifiers : 3.2.3 -- An identifier is an arbritrarily long sequence of ASCII -- alphabetic, digit and underscore characters. The first -- character must be an ASCII alphabetic character. All -- characters are significant. -- -- Keywords : 3.2.4 -- keywords must be written exactly as in the above list. Identifiers -- that collide with keywords (...) are illegal. For example, -- "boolean" is a valid keyword, "Boolean" and "BOOLEAN" are -- illegal identifiers. function Scan_Numeric return Idl_Token; -- Called when the current character is a digit. -- This procedure sets Current_Token and returns. -- The get_marked_text function returns then the -- numeric literal -- -- IDL Syntax and semantics, CORBA V2.3 § 3.2.5 -- -- Integers Literals : (3.2.5.1) -- An integer literal consisting of a sequence of digits is taken to be -- decimal (base ten), unless it begins with 0 (digit zero). A sequence -- of digits starting with 0 is taken to be an octal integer (base eight). -- The digits 8 and 9 are not octal digits. A sequence of digits preceded -- by 0x or 0X is taken to be a hexadecimal integer (base sixteen). The -- hexadecimal digits include a or A through f or F with decimal values -- ten to through fifteen, repectively. For example, the number twelve can -- be written 12, 014 or 0XC -- -- Floating-point literals : (3.2.5.3) -- A floating-point literal consists of an integer part, a decimal point, -- a fraction part, an e or E, and an optionnaly signed integer exponent. -- The integer and fraction parts both consists of a sequence of decimal -- (base ten) digits. Either the integer part or the fraction part (but not -- both may be missing; either the decimal point or the letter e (or E) and -- the exponent (but not both) may be missing. -- -- Fixed-point literals : (3.2.5.5) -- A fixed-point decimal literal consists of an integer part, a decimal -- point, a fraction part and a d or D. The integer and fraction part both -- consist of a sequence of decimal (base ten) digits. Either the integer -- part or the fraction part (but not both) may be missing; the decimal -- point (but not the letter d (or D)) may be missing function Scan_Underscore return Idl_Token; -- Called when the current character is a _. -- This procedure sets Current_Token and returns. -- The get_marked_text function returns then the -- identifier -- -- IDL Syntax and semantics, CORBA V2.3 § 3.2.3.1 -- -- "users may lexically "escape" identifiers by prepending an -- underscore (_) to an identifier. function Scan_Preprocessor return Boolean; -- Called when the current character is a #. -- Deals with the preprocessor directives. -- Actually, most of these are processed by gcc in a former -- step; this function only deals with #PRAGMA and -- #LINE directives. -- it returns true if it produced a token, false else -- -- IDL Syntax and semantics, CORBA V2.3 § 3.3 end Idl_Fe.Lexer; polyorb-2.8~20110207.orig/compilers/idlac/ada_be.opt0000644000175000017500000000007511750740337021402 0ustar xavierxavier#ada_be.expansion #ada_be.source_streams #ada_be.identifiers polyorb-2.8~20110207.orig/compilers/idlac/ada_be-temporaries.adb0000644000175000017500000001601011750740337023652 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- A D A _ B E . T E M P O R A R I E S -- -- -- -- B o d y -- -- -- -- Copyright (C) 2004-2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with Idlac_Flags; package body Ada_Be.Temporaries is use Idlac_Flags; function Suffix return String; -- Return the suffix value for the current encoding setting. type String_Access is access String; -- To avoid collisions between identifiers generated by idlac and -- identifiers resulting from the mapping of IDL user identifiers, -- one non-ASCII character is appended to the former -- (now LATIN CAPITAL LETTER U WITH DIAERESIS), since such characters -- are not permitted in IDL identifiers. -- This table encodes the representation of that character in different -- character sets. Suffix_Table : constant array (Encoding) of String_Access := (ISO_Latin_1 => new String'(1 => Character'Val (16#DC#)), UTF_8 => new String'(1 => Character'Val (16#C3#), 2 => Character'Val (16#9C#))); ------------ -- Suffix -- ------------ function Suffix return String is begin return Suffix_Table (Character_Encoding).all; end Suffix; ---------------- -- T_Argument -- ---------------- function T_Argument return String is begin return "Argument_" & Suffix & '_'; end T_Argument; --------------- -- T_Arg_Any -- --------------- function T_Arg_Any return String is begin return "Arg_Any_" & Suffix & '_'; end T_Arg_Any; -------------- -- T_Arg_CC -- -------------- function T_Arg_CC return String is begin return "Arg_CC_" & Suffix & '_'; end T_Arg_CC; ---------------- -- T_Arg_List -- ---------------- function T_Arg_List return String is begin return "Arg_List_" & Suffix; end T_Arg_List; ---------------- -- T_Arg_Name -- ---------------- function T_Arg_Name return String is begin return "_Arg_Name_" & Suffix & '_'; end T_Arg_Name; --------------- -- T_Content -- --------------- function T_Content return String is begin return "Content_" & Suffix & '_'; end T_Content; ------------------------- -- T_Exception_Repo_Id -- ------------------------- function T_Exception_Repo_Id return String is begin return "Exception_Repo_Id_" & Suffix; end T_Exception_Repo_Id; ----------------- -- T_Excp_List -- ----------------- function T_Excp_List return String is begin return "_Excp_List_" & Suffix; end T_Excp_List; ----------- -- T_Ctx -- ----------- function T_Ctx return String is begin return "Ctx_" & Suffix; end T_Ctx; --------------- -- T_Handler -- --------------- function T_Handler return String is begin return "Handler_" & Suffix; end T_Handler; ----------------------- -- T_Impl_Object_Ptr -- ----------------------- function T_Impl_Object_Ptr return String is begin return "Object_" & Suffix; end T_Impl_Object_Ptr; --------------- -- T_Indices -- --------------- function T_Indices return String is begin return "Indices_" & Suffix & "_"; end T_Indices; --------- -- T_J -- --------- function T_J return String is begin return "J_" & Suffix; end T_J; --------------- -- T_Helpers -- --------------- function T_Helpers return String is begin return "Helpers_" & Suffix & '_'; end T_Helpers; --------------- -- T_Lengths -- --------------- function T_Lengths return String is begin return "Lengths_" & Suffix & '_'; end T_Lengths; --------------- -- T_Members -- --------------- function T_Members return String is begin return "Members_" & Suffix; end T_Members; ----------- -- T_Ptr -- ----------- function T_Ptr return String is begin return "Ptr_" & Suffix & "_"; end T_Ptr; --------------- -- T_Request -- --------------- function T_Request return String is begin return "Request_" & Suffix; end T_Request; -------------- -- T_Result -- -------------- function T_Result return String is begin return "Result_" & Suffix; end T_Result; ------------------- -- T_Result_Name -- ------------------- function T_Result_Name return String is begin return "Result_Name_" & Suffix; end T_Result_Name; --------------- -- T_Returns -- --------------- function T_Returns return String is begin return "Return_" & Suffix; end T_Returns; ---------------- -- T_Self_Ref -- ---------------- function T_Self_Ref return String is begin return "Self_Ref_" & Suffix; end T_Self_Ref; --------------------------- -- T_Send_Request_Result -- --------------------------- function T_Send_Request_Result return String is begin return "Send_Request_Result_" & Suffix; end T_Send_Request_Result; ----------------------- -- T_Value_Operation -- ----------------------- function T_Value_Operation return String is begin return "Op_" & Suffix; end T_Value_Operation; end Ada_Be.Temporaries; polyorb-2.8~20110207.orig/compilers/idlac/ada_be-identifiers.adb0000644000175000017500000001216111750740337023630 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- A D A _ B E . I D E N T I F I E R S -- -- -- -- B o d y -- -- -- -- Copyright (C) 2001-2008, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with Idlac_Utils; use Idlac_Utils; with Idl_Fe.Tree; use Idl_Fe.Tree; with Idl_Fe.Tree.Synthetic; use Idl_Fe.Tree.Synthetic; with Ada_Be.Debug; pragma Elaborate_All (Ada_Be.Debug); package body Ada_Be.Identifiers is Flag : constant Natural := Ada_Be.Debug.Is_Active ("ada_be.identifiers"); procedure O is new Ada_Be.Debug.Output (Flag); ------------------- -- Ada_Full_Name -- ------------------- function Ada_Full_Name (Node : Node_Id) return String is begin pragma Debug (O ("Ada_Full_Name: enter (Node = " & Img (Node) & ", Kind = " & Img (Kind (Node)) & ")")); case Kind (Node) is when K_Scoped_Name => return Ada_Full_Name (Value (Node)); when K_Ben_Idl_File => return Ada_Name (Node); when K_Repository => raise Program_Error; when others => declare P_Node : constant Node_Id := Parent_Scope (Node); Node_Name : constant String := Ada_Name (Node); begin pragma Assert (Kind (P_Node) /= K_Repository); if Kind (P_Node) = K_Ben_Idl_File and then Is_Gen_Scope (Node) then return Node_Name; else return Ada_Full_Name (P_Node) & "." & Node_Name; end if; end; end case; end Ada_Full_Name; -------------- -- Ada_Name -- -------------- function Ada_Name (Node : Node_Id) return String is NK : constant Node_Kind := Kind (Node); Result : String := Name (Node) & "U"; -- Reserve an additional character for the case of a terminal underscore First : Integer := Result'First; Last : Integer := Result'Last - 1; begin while First <= Last and then Result (First) = '_' loop First := First + 1; end loop; if NK = K_Operation and then Original_Node (Node) /= No_Node and then Kind (Original_Node (Node)) = K_Attribute then if Result (First) = 'g' then Result (First) := 'G'; elsif Result (First) = 's' then Result (First) := 'S'; else raise Program_Error; end if; end if; for J in First .. Last loop if Result (J) = '_' and then J < Last and then Result (J + 1) = '_' then Result (J + 1) := 'U'; end if; end loop; if Result (Last) = '_' then Last := Last + 1; end if; if False or else NK = K_Forward_Interface or else NK = K_Forward_ValueType then return Result (First .. Last) & "_Forward"; else return Result (First .. Last); end if; end Ada_Name; function Parent_Scope_Name (Node : Node_Id) return String is begin pragma Debug (O ("Parent_Scope_Name : enter & end")); pragma Debug (O ("Parent_Scope_Name : node kind is " & Node_Kind'Image (Kind (Node)))); return Ada_Full_Name (Parent_Scope (Node)); end Parent_Scope_Name; end Ada_Be.Identifiers; polyorb-2.8~20110207.orig/compilers/idlac/nodes.txt0000644000175000017500000001670611750740337021344 0ustar xavierxavier-- -*- ada -*- -- -- This file contains declaration such as: -- -- Type [ <-- ParentType ] -- Field : FieldType [ := Initialization ] -- -- There is a special node kind called Root, which is not a real node, -- and will serve as a virtual parent for everything. It has to contain -- a Kind node of type Node_Kind, which will be used for qualification -- purpose. Also, an Original_Node field of type Node_Id must be retained -- if one wants to use the Node_Access.Manip package. -- -- Accessors will have the name Field and Set_Field. -- -- $Id$ -- START Root Kind : Node_Kind Original_Node : Node_Id Loc : Location Expanded : Boolean := False Named Definition : Identifier_Definition_Acc Repository_Id : Node_Id Is_Explicit_Repository_Id : Boolean := False -- The repository ID for this entity was explicitly set -- using #pragma ID. Is_Explicit_Version_Id : Boolean := False -- The version of the Repository ID was explicitly set -- using #pragma version Parent_Scope_Override : Node_Id -- Expansion attribute: override that -- value of Definition.Parent_Scope for this -- copy of the node (used for inherited operation -- and attribute nodes). Repository_Id_Identifier : Node_Id -- Expansion attribute: A Named node that holds the name -- of the Ada constant that contains the node's repository ID. Scope <-- Named Identifier_List : Identifier_Definition_List Identifier_Table : Storage Current_Prefix : Node_Id -- The current Repository Id prefix for the scope. -- This attribute is used only during parse. Forward <-- Scope Unimplemented_Forwards : Node_List Imports <-- Scope Imported_Table : Storage Imported : Boolean Repository <-- Forward Contents : Node_List Module <-- Forward Contents : Node_List Imported : Boolean Interface <-- Imports Parents : Node_List -- The ancestors of this interface Contents : Node_List -- The declarations of this interface Forward : Node_Id -- Forward declaration (if any) of this interface Abst : Boolean -- Abstract interface Local : Boolean -- Locality-constrained interface Has_Non_Implicit_Inherited_Operations : Boolean := False -- Set when this interface has operations for which stub bodies are -- actually generated. Forward_Interface <-- Named Forward : Node_Id -- Actual interface corresponding to this forward declaration (set during -- semantic analysis of the complete declaration). -- The Name and Parent_Scope of the forward declaration must then be -- retrieved from the full declaration's Definition Abst : Boolean -- Abstract interface Local : Boolean -- Locality-constrained interface ValueType <-- Imports Parents : Node_List Contents : Node_List Supports : Node_List Forward : Node_Id Abst : Boolean Custom : Boolean Truncatable : Boolean Forward_ValueType <-- Named Forward : Node_Id Abst : Boolean Boxed_ValueType <-- Named Boxed_Type : Node_Id Declarator <-- Named Array_Bounds : Node_List Parent : Node_Id State_Member State_Type : Node_Id State_Declarators : Node_List Is_Public : Boolean Initializer <-- Scope Param_Decls : Node_List Scoped_Name Value : Node_Id -- The Named node that this scoped name resolves to. Operation <-- Scope Is_Oneway : Boolean Operation_Type : Node_Id Parameters : Node_List Raises : Node_List Contexts : Node_List Is_Explicit_Self : Boolean := False -- Determines whether the argument that determines the target object for -- this operation is listed explicitly in Parameters. Normally False for -- the standard IDL -> Ada mapping. Intended for implementation of -- distributed objects in DSA personality. Is_Implicit_Inherited : Boolean := False -- Expansion attribute: this operation is inherited from -- the first parent (and therefore its calling stubs need -- not be redeclared). Is_Directly_Supported : Boolean := False -- Expansion attribute: this operation is copied -- from one of this valuetype's supported interfaces Oldest_Supporting_ValueType : Node_Id := No_Node -- Expansion attribute: when an operation is copied down -- to a valuetype from a supported interface, then this attribute -- is set to this valuetype; it keeps its value when copied down -- to derived valuetypes. Attribute Is_Readonly : Boolean A_Type : Node_Id Declarators : Node_List Raises : Node_List Get_Raises : Node_List Set_Raises : Node_List Void Float Double Long_Double Short Long Long_Long Unsigned_Short Unsigned_Long Unsigned_Long_Long Char Wide_Char Boolean Octet Any Object Param Mode : Param_Mode Param_Type : Node_Id Declarator : Node_Id Is_Returns : Boolean := False -- Expansion attribute: is this a mode out -- formal that represents the return value -- of a function with out or inout formals? Exception <-- Scope Members : Node_List Imported : Boolean Members_Type : Node_Id := No_Node -- Expansion attribute: The expanded struct -- _Members. Member M_Type : Node_Id Decl : Node_List Native Declarator : Node_Id Union <-- Scope Switch_Type : Node_Id Default_Index : Long_Integer := -1 Cases : Node_List Imported : Boolean Case Labels : Node_List Case_Type : Node_Id Case_Decl : Node_Id Struct <-- Scope Members : Node_List Imported : Boolean Is_Exception_Members : Boolean := False -- Expansion attribute: is this struct -- generated by the expander to hold the -- members of an exception? Enum <-- Named Enumerators : Node_List Imported : Boolean Enumerator <-- Named Type_Declarator T_Type : Node_Id Declarators : Node_List Imported : Boolean Expr Expr_Value : Constant_Value_Ptr Binary_Expr <-- Expr Left : Node_Id Right : Node_Id Unary_Expr <-- Expr Operand : Node_Id Primary_Expr <-- Expr Operand : Node_Id Or_Expr <-- Binary_Expr Xor_Expr <-- Binary_Expr And_Expr <-- Binary_Expr Shl_Expr <-- Binary_Expr Shr_Expr <-- Binary_Expr Add_Expr <-- Binary_Expr Sub_Expr <-- Binary_Expr Mul_Expr <-- Binary_Expr Div_Expr <-- Binary_Expr Mod_Expr <-- Binary_Expr Neg_Expr <-- Unary_Expr Id_Expr <-- Unary_Expr Not_Expr <-- Unary_Expr Literal <-- Expr Lit_Integer <-- Literal Lit_String <-- Literal Lit_Wide_String <-- Literal Lit_Character <-- Literal Lit_Wide_Character <-- Literal Lit_Fixed_Point <-- Literal Lit_Floating_Point <-- Literal Lit_Boolean <-- Literal Lit_Enum <-- Literal Const_Dcl <-- Named Constant_Type : Node_Id Expression : Node_Id Sequence Sequence_Type : Node_Id Bound : Node_Id String Bound : Node_Id Wide_String Bound : Node_Id Fixed Digits_Nb : Node_Id Scale : Node_Id ValueBase Pragma ------------------------------ -- Expansion-specific nodes -- ------------------------------ Ben_Idl_File <-- Scope Contents : Node_List Is_Unknown : Boolean := False -- Expansion attribute: set to True if this node does -- not actually correspond to a real file (in which case -- it is expected that it only contains other scopes). Generate_Code : Boolean := True -- Expansion attribute: set to True if for this node -- code should be generated. By default code generation -- is always enabled, but for CORBA 3 style "imported" -- file we disable code generation. Sequence_Instance <-- Named Sequence : Node_Id -- The Sequence node for which this instance was created String_Instance <-- Named -- An instance of CORBA.Bounded_Strings or CORBA.Bounded_Wide_Strings Bound : Node_Id Is_Wide : Boolean END polyorb-2.8~20110207.orig/compilers/idlac/idl_fe-parser.adb0000644000175000017500000121445511750740337022661 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- I D L _ F E . P A R S E R -- -- -- -- B o d y -- -- -- -- Copyright (C) 2001-2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with Ada.Characters.Latin_1; with Ada.Strings.Unbounded; with GNAT.Case_Util; with GNAT.Table; with Idlac_Utils; use Idlac_Utils; with Idl_Fe.Files; with Idl_Fe.Tree.Synthetic; use Idl_Fe.Tree, Idl_Fe.Tree.Synthetic; with Idl_Fe.Debug; pragma Elaborate_All (Idl_Fe.Debug); with Interfaces; package body Idl_Fe.Parser is use Idl_Fe.Lexer.Lexer_State; -- Only the parser may access the current state -- of the lexer. ----------- -- Debug -- ----------- Flag : constant Natural := Idl_Fe.Debug.Is_Active ("idl_fe.parser"); procedure O is new Idl_Fe.Debug.Output (Flag); Flag2 : constant Natural := Idl_Fe.Debug.Is_Active ("idl_fe.parser_method_trace"); procedure O2 is new Idl_Fe.Debug.Output (Flag2); ------------------------------------ -- Management of the token stream -- ------------------------------------ -- This is a little buffer to put tokens if we have -- to look a bit further than the current_token. -- A second buffer is used to keep the location of each token, -- and a third one for their string value (usefull in case of -- an identifier or a literal) -- buffer length Buffer_Length : constant Natural := 6; -- a type for indexes on the buffer type Buffer_Index is mod Buffer_Length; -- definition of a pointer on a string and the associated -- deallocation type String_Ptr is access String; procedure Free_String_Ptr is new Ada.Unchecked_Deallocation (Object => String, Name => String_Ptr); -- types for buffers type Token_Buffer_Type is array (Buffer_Index) of Idl_Token; type Location_Buffer_Type is array (Buffer_Index) of Idlac_Errors.Location; type String_Buffer_Type is array (Buffer_Index) of String_Ptr; -- the buffers themself Token_Buffer : Token_Buffer_Type := (others => T_Error); Location_Buffer : Location_Buffer_Type := (others => Idlac_Errors.No_Location); String_Buffer : String_Buffer_Type := (others => null); -- index of the current token in the buffer Current_Index : Buffer_Index := 0; -- index of the newest token in the buffer (could be different -- from the current token if we looked a bit further in the past) Newest_Index : Buffer_Index := 0; Initialized : Boolean := False; -- Flag for detecting parser reinitialization and store current parser -- state if it already initialized ------------------------ -- Parser State Stack -- ------------------------ -- ??? More comments needed type State_Item is record Token_Buffer : Token_Buffer_Type; Location_Buffer : Location_Buffer_Type; String_Buffer : String_Buffer_Type; Current_Index : Buffer_Index; Newest_Index : Buffer_Index; end record; package State_Stack is new GNAT.Table (Table_Component_Type => State_Item, Table_Index_Type => Natural, Table_Low_Bound => 1, Table_Initial => 10, Table_Increment => 100); procedure Push_State; procedure Pop_State; --------------------------- -- Processed files table -- --------------------------- package Processed_File is new GNAT.Table (Table_Component_Type => String_Ptr, Table_Index_Type => Natural, Table_Low_Bound => 1, Table_Initial => 10, Table_Increment => 100); function Is_Processed (File_Name : String) return Boolean; ------------------ -- Is_Processed -- ------------------ function Is_Processed (File_Name : String) return Boolean is begin for J in Processed_File.First .. Processed_File.Last loop if Processed_File.Table (J).all = File_Name then return True; end if; end loop; return False; end Is_Processed; ---------------- -- Push_State -- ---------------- procedure Push_State is begin State_Stack.Append (State_Item'(Token_Buffer, Location_Buffer, String_Buffer, Current_Index, Newest_Index)); end Push_State; --------------- -- Pop_State -- --------------- procedure Pop_State is S : constant State_Item := State_Stack.Table (State_Stack.Last); begin State_Stack.Set_Last (State_Stack.Last - 1); Token_Buffer := S.Token_Buffer; Location_Buffer := S.Location_Buffer; String_Buffer := S.String_Buffer; Current_Index := S.Current_Index; Newest_Index := S.Newest_Index; end Pop_State; --------------- -- Get_Token -- --------------- function Get_Token return Idl_Token is begin pragma Debug (O ("Get_Token : token is " & Idl_Token'Image (Token_Buffer (Current_Index)))); return Token_Buffer (Current_Index); end Get_Token; -------------------------- -- Get_Token_From_Lexer -- -------------------------- procedure Get_Token_From_Lexer is begin pragma Debug (O ("Get_Token_From_Lexer: enter")); Newest_Index := Newest_Index + 1; Token_Buffer (Newest_Index) := Idl_Fe.Lexer.Get_Next_Token; pragma Debug (O ("Get_Token_From_Lexer : location file is " & Get_Lexer_Location.Filename.all)); Location_Buffer (Newest_Index) := Get_Lexer_Location; if String_Buffer (Newest_Index) /= null then Free_String_Ptr (String_Buffer (Newest_Index)); end if; case Token_Buffer (Newest_Index) is when T_Lit_Decimal_Integer | T_Lit_Octal_Integer | T_Lit_Hexa_Integer | T_Lit_Char | T_Lit_Wide_Char | T_Lit_Simple_Floating_Point | T_Lit_Exponent_Floating_Point | T_Lit_Pure_Exponent_Floating_Point | T_Lit_String | T_Lit_Wide_String | T_Lit_Simple_Fixed_Point | T_Lit_Floating_Fixed_Point | T_Identifier | T_Pragma => String_Buffer (Newest_Index) := new String'(Get_Lexer_String); when others => String_Buffer (Newest_Index) := null; end case; pragma Debug (O ("Get_Token_From_Lexer: end")); end Get_Token_From_Lexer; ---------------- -- Next_Token -- ---------------- procedure Next_Token is begin if Current_Index = Newest_Index then Get_Token_From_Lexer; end if; Current_Index := Current_Index + 1; end Next_Token; ------------------------- -- View_Previous_Token -- ------------------------- function View_Previous_Token return Idl_Token is begin return Token_Buffer (Current_Index - 1); end View_Previous_Token; ---------------------------------- -- View_Previous_Previous_Token -- ---------------------------------- function View_Previous_Previous_Token return Idl_Token is begin return Token_Buffer (Current_Index - 2); end View_Previous_Previous_Token; --------------------- -- View_Next_Token -- --------------------- function View_Next_Token return Idl_Token is begin if Current_Index = Newest_Index then Get_Token_From_Lexer; end if; return Token_Buffer (Current_Index + 1); end View_Next_Token; -------------------------- -- View_Next_Next_Token -- -------------------------- function View_Next_Next_Token return Idl_Token is begin if Current_Index = Newest_Index then Get_Token_From_Lexer; end if; if Current_Index = Newest_Index - 1 then Get_Token_From_Lexer; end if; return Token_Buffer (Current_Index + 2); end View_Next_Next_Token; ------------------------ -- Get_Token_Location -- ------------------------ function Get_Token_Location return Idlac_Errors.Location is begin pragma Debug (O ("Get_Token_Location : enter & end")); return Location_Buffer (Current_Index); end Get_Token_Location; --------------------------------- -- Get_Previous_Token_Location -- --------------------------------- function Get_Previous_Token_Location return Idlac_Errors.Location is begin pragma Debug (O ("Get_Previous_Token_Location : enter," & " Current_Index - 1 = " & Buffer_Index'Image (Current_Index - 1))); return Location_Buffer (Current_Index - 1); end Get_Previous_Token_Location; --------------------------------- -- Get_Previous_Token_Location -- --------------------------------- function Get_Previous_Previous_Token_Location return Idlac_Errors.Location is begin return Location_Buffer (Current_Index - 2); end Get_Previous_Previous_Token_Location; ----------------------------- -- Get_Next_Token_Location -- ----------------------------- function Get_Next_Token_Location return Idlac_Errors.Location is begin return Location_Buffer (Current_Index + 1); end Get_Next_Token_Location; ---------------------- -- Get_Token_String -- ---------------------- function Get_Token_String return String is begin return String_Buffer (Current_Index).all; end Get_Token_String; ------------------------------- -- Get_Previous_Token_String -- ------------------------------- function Get_Previous_Token_String return String is begin return String_Buffer (Current_Index - 1).all; end Get_Previous_Token_String; ---------------------------------------- -- Get_Previous_Previous_Token_String -- ---------------------------------------- function Get_Previous_Previous_Token_String return String is begin return String_Buffer (Current_Index - 2).all; end Get_Previous_Previous_Token_String; --------------------------- -- Get_Next_Token_String -- --------------------------- function Get_Next_Token_String return String is begin return String_Buffer (Current_Index + 1).all; end Get_Next_Token_String; ------------------------------ -- Divide_T_Greater_Greater -- ------------------------------ procedure Divide_T_Greater_Greater is Loc : Idlac_Errors.Location := Get_Token_Location; begin if Get_Token /= T_Greater_Greater then return; end if; Token_Buffer (Current_Index) := T_Greater; if Newest_Index /= Current_Index then declare I : Buffer_Index := Newest_Index; begin if String_Buffer (Newest_Index + 1) /= null then Free_String_Ptr (String_Buffer (Newest_Index + 1)); end if; while I /= Current_Index loop Token_Buffer (I + 1) := Token_Buffer (I); Location_Buffer (I + 1) := Location_Buffer (I); String_Buffer (I + 1) := String_Buffer (I); I := I - 1; pragma Debug (O ("Divide T_Greater_Greater : Token I+1 is " & Idl_Token'Image (Token_Buffer (I + 1)))); pragma Debug (O ("I = " & Buffer_Index'Image (I))); end loop; end; end if; Newest_Index := Newest_Index + 1; Loc.Col := Loc.Col + 1; Token_Buffer (Current_Index + 1) := T_Greater; Location_Buffer (Current_Index + 1) := Loc; String_Buffer (Current_Index + 1) := null; end Divide_T_Greater_Greater; ---------------- -- Initialize -- ---------------- procedure Initialize (Filename : String) is begin Idl_Fe.Lexer.Initialize (Filename); if not Initialized then Initialized := True; else Push_State; end if; Token_Buffer := (others => T_Error); Location_Buffer := (others => Idlac_Errors.No_Location); String_Buffer := (others => null); Current_Index := 0; Newest_Index := 0; Next_Token; Processed_File.Append (new String'(Filename)); end Initialize; -------------- -- Finalize -- -------------- procedure Finalize is begin if State_Stack.Last /= 0 then Pop_State; else Initialized := False; end if; Idl_Fe.Lexer.Finalize; end Finalize; ------------------------------- -- Management of expressions -- ------------------------------- -- -- the actual list of already used values -- Used_Values : Set_Ptr := null; -- ---------------------- -- -- Add_Used_Value -- -- ---------------------- -- function Add_Used_Value (C : Node_Id) return Boolean is -- Old_Used : Set_Ptr := null; -- Used : Set_Ptr := Used_Values; -- begin -- while Used /= null and then Used.Interval.Max < Value (C) loop -- Old_Used := Used; -- Used := Used.Next; -- end loop; -- if Used = null then -- if Old_Used = null then -- Used_Values := new Set; -- Used_Values.Next := null; -- Used_Values.Interval := (Min => Value (C), Max => Value (C)); -- else -- if Used.Interval.Max = Value (C) - 1 then -- if Used.Next /= null -- and then Value (C) = Used.Next.Interval.Min - 1 then -- -- merge the intervals -- declare -- Old_Used : Set_Ptr := Used.Next; -- begin -- Used.Interval.Max := Used.Next.Interval.Max; -- Used.Next := Used.Next.Next; -- Free (Old_Used); -- end; -- else -- -- only change the upper bound of the interval -- Used.Interval.Max := Value (C); -- end if; -- else -- Old_Used.Next := new Set; -- Old_Used.Next.all.Next := null; -- Old_Used.Next.all.Interval := -- (Min => Value (C), Max => Value (C)); -- end if; -- end if; -- else -- if Used.Interval.Min > Value (C) then -- if Value (C) = Used.Interval.Min - 1 then -- if Old_Used /= null -- and then Old_Used.Interval.Max = Value (C) - 1 then -- -- merge the intervals -- Old_Used.Interval.Max := Used.Interval.Max; -- Old_Used.Next := Used.Next; -- Free (Used); -- else -- -- only change the lower bound of the interval -- Used.Interval.Min := Value (C); -- end if; -- else -- Old_Used.Next := new Set; -- Old_Used.Next.all.Next := Used; -- Old_Used.Next.all.Interval -- := (Min => Value (C), Max => Value (C)); -- end if; -- else -- return False; -- end if; -- end if; -- return True; -- end Add_Used_Value; -- -------------------------- -- -- Release_All_Values -- -- -------------------------- -- procedure Release_All_Used_Values is -- Old_Used_Values : Set_Ptr; -- begin -- pragma Debug (O ("Release_All_Used_Values: enter")); -- while Used_Values /= null loop -- Old_Used_Values := Used_Values; -- Used_Values := Used_Values.Next; -- Free (Old_Used_Values); -- end loop; -- end Release_All_Used_Values; -------------------------- -- Parsing of the idl -- -------------------------- ------------------------- -- Parse_Specification -- ------------------------- procedure Parse_Specification (Repository : Node_Id; Called_From_Import : Boolean) is Definition : Node_Id; Definition_Result : Boolean; Def_Nb : Natural := 0; begin loop exit when Get_Token /= T_Import; Parse_Import (Repository, Definition_Result); if not Definition_Result then while Get_Token /= T_Semi_Colon loop Next_Token; end loop; Next_Token; end if; end loop; while Get_Token /= T_Eof loop if Get_Token = T_Right_Cbracket then Idlac_Errors.Error ("Invalid '}', nothing to be closed.", Idlac_Errors.Error, Get_Token_Location); Next_Token; if Get_Token = T_Semi_Colon then Next_Token; end if; end if; Parse_Definition (Definition, Definition_Result); if not Definition_Result then -- we can be here for two reasons : -- either the definition parsing crashed and we'd like to go -- to the next one -- either the definition was right but it was an already -- existing module that was reopened. In this case, -- go_to_next_definition won't have any effect since we are -- on a definition Go_To_Next_Definition; elsif Definition /= No_Node then Def_Nb := Def_Nb + 1; -- Avoid to setup Imported flag on forward declaration nodes. if Kind (Definition) /= K_Forward_Interface and then Kind (Definition) /= K_Forward_ValueType then Set_Imported (Definition, Called_From_Import); end if; Append_Node_To_Contents (Repository, Definition); end if; end loop; if Def_Nb = 0 then Idlac_Errors.Error ("Definition expected : a specification may not be empty.", Idlac_Errors.Error, Get_Token_Location); end if; end Parse_Specification; ------------------------- -- Parse_Specification -- ------------------------- function Parse_Specification return Node_Id is Result : Node_Id; begin pragma Debug (O2 ("Parse_Specification: enter")); -- first call next_token in order to initialize the location Result := Make_Repository (Get_Token_Location); -- The repository is the root scope. Push_Scope (Result); Parse_Specification (Result, False); Pop_Scope; pragma Debug (O2 ("Parse_Specification: end")); return Result; end Parse_Specification; ---------------------- -- Parse_Definition -- ---------------------- procedure Parse_Definition (Result : out Node_Id; Success : out Boolean) is begin pragma Debug (O2 ("Parse_Definition: enter")); case Get_Token is when T_Typedef | T_Struct | T_Union | T_Enum | T_Native => Parse_Type_Dcl (Result, Success); if not Success then pragma Debug (O2 ("Parse_Definition: end")); return; end if; when T_Const => Parse_Const_Dcl (Result, Success); if not Success then pragma Debug (O2 ("Parse_Definition: end")); return; end if; when T_Exception => Parse_Except_Dcl (Result, Success); if not Success then pragma Debug (O2 ("Parse_Definition: end")); return; end if; when T_Abstract => case View_Next_Token is when T_Interface => Parse_Interface (Result, Success); if not Success then pragma Debug (O2 ("Parse_Definition: end")); return; end if; when T_ValueType => Parse_Value (Result, Success); if not Success then pragma Debug (O2 ("Parse_Definition: end")); return; end if; when others => declare Loc : Idlac_Errors.Location; begin Loc := Get_Token_Location; Loc.Col := Loc.Col + 9; Idlac_Errors.Error (Ada.Characters.Latin_1.Quotation & "interface" & Ada.Characters.Latin_1.Quotation & " or " & Ada.Characters.Latin_1.Quotation & "valuetype" & Ada.Characters.Latin_1.Quotation & " expected after the abstract keyword.", Idlac_Errors.Error, Get_Token_Location); Success := False; Result := No_Node; -- consumes T_Abstract Next_Token; pragma Debug (O2 ("Parse_Definition: end")); return; end; end case; when T_Local => case View_Next_Token is when T_Interface => Parse_Interface (Result, Success); if not Success then pragma Debug (O2 ("Parse_Definition: end")); return; end if; when others => declare Loc : Idlac_Errors.Location; begin Loc := Get_Token_Location; Loc.Col := Loc.Col + 6; Idlac_Errors.Error (Ada.Characters.Latin_1.Quotation & "interface" & Ada.Characters.Latin_1.Quotation & " expected after the local keyword.", Idlac_Errors.Error, Get_Token_Location); Success := False; Result := No_Node; -- consumes T_Local Next_Token; pragma Debug (O2 ("Parse_Definition: end")); return; end; end case; when T_Interface => Parse_Interface (Result, Success); if not Success then pragma Debug (O2 ("Parse_Definition: end")); return; end if; when T_Module => declare Reopen : Boolean; begin Parse_Module (Result, Success, Reopen); if not Success then pragma Debug (O2 ("Parse_Definition: end")); return; end if; -- if the module was reopened then we don't want its node to -- be added again to the definition list of the current scope. -- Thus, we put success to false, indicating that no node was -- generated if Reopen then Success := False; end if; end; when T_ValueType | T_Custom => Parse_Value (Result, Success); if not Success then pragma Debug (O2 ("Parse_Definition: end")); return; end if; when T_Pragma => Parse_Pragma (Result, Success); if not Success then -- here the pragma is ignored and no node created -- so we parse the next definition (if it exists) pragma Debug (O ("Parse_Definition : parse definition " & "after pragma, current token is " & Idl_Token'Image (Get_Token))); Parse_Definition (Result, Success); end if; pragma Debug (O2 ("Parse_Definition: end")); return; when T_TypeId => Parse_Type_Id_Dcl (Success); Result := No_Node; Success := False; return; when T_TypePrefix => Parse_Type_Prefix_Dcl (Success); Result := No_Node; Success := False; return; when T_Eof | T_Right_Cbracket => Result := No_Node; Success := False; pragma Debug (O2 ("Parse_Definition: end")); return; when others => Idlac_Errors.Error ("definition expected.", Idlac_Errors.Error, Get_Token_Location); Result := No_Node; Success := False; pragma Debug (O2 ("Parse_Definition: end")); return; end case; if Get_Token /= T_Semi_Colon then Idlac_Errors.Error ("';' expected at the end of a definition.", Idlac_Errors.Error, Get_Token_Location); Success := False; else Next_Token; end if; pragma Debug (O2 ("Parse_Definition: end")); return; end Parse_Definition; ------------------ -- Parse_Module -- ------------------ procedure Parse_Module (Result : out Node_Id; Success : out Boolean; Reopen : out Boolean) is begin pragma Debug (O2 ("Parse_Module: enter")); Reopen := False; -- Is there an identifier? Next_Token; case Get_Token is when T_Identifier => case View_Next_Token is when T_Left_Cbracket => declare -- true if we have to create a module Build_Module : Boolean := True; begin -- See if the identifier is not already used if not Is_Redefinable (Get_Token_String, Get_Lexer_Location) then -- There is a name collision with the module name declare Def : Identifier_Definition_Acc; begin Def := Find_Identifier_Definition (Get_Token_String, Get_Lexer_Location); if Kind (Def.Node) = K_Module and then Def.Parent_Scope = Get_Current_Scope then -- If the previous definition was a module in -- the same scope, then reopen it... pragma Debug (O ("Parse_Module: reopening a " & "module")); Reopen := True; Result := Def.Node; Build_Module := False; else -- ... else raise an error declare Loc : Idlac_Errors.Location; begin Loc := Types.Get_Location (Find_Identifier_Node (Get_Token_String, Get_Lexer_Location)); Idlac_Errors.Error ("This module name is already defined in" & " this scope : " & Idlac_Errors.Location_To_String (Loc), Idlac_Errors.Error, Get_Token_Location); end; end if; end; end if; if Build_Module then -- Creation of the node Result := Make_Module (Get_Previous_Token_Location); declare Ok : constant Boolean := Add_Identifier (Result, Get_Token_String); pragma Warnings (Off); pragma Unreferenced (Ok); pragma Warnings (On); -- here, the addentifier is really added only if -- we're not in the case where the module name -- was already defined begin Set_Default_Repository_Id (Result); Set_Initial_Current_Prefix (Result); end; end if; end; -- consume the T_Left_Cbracket token Next_Token; -- parse the module body Next_Token; declare Definition : Node_Id; Definition_Result : Boolean; begin pragma Debug (O ("Parse_Module: parse body")); Push_Scope (Result); pragma Debug (O ("Parse_Module: after push_scope, " & "current scope is : " & Name (Get_Current_Scope))); if Get_Token = T_Right_Cbracket then Idlac_Errors.Error ("definition expected : a module may not be empty.", Idlac_Errors.Error, Get_Token_Location); end if; while Get_Token /= T_Right_Cbracket and then Get_Token /= T_Eof loop -- try to parse a definition Parse_Definition (Definition, Definition_Result); if Definition_Result then Append_Node_To_Contents (Result, Definition); else -- failed Go_To_Next_Definition; end if; end loop; Pop_Scope; pragma Debug (O ("Parse_Module: after pop_scope, " & "current scope is : " & Name (Get_Current_Scope))); -- consume the T_Right_Cbracket token Next_Token; end; -- end of the module body parsing Success := True; when others => declare Loc : Idlac_Errors.Location; begin Loc := Get_Token_Location; Loc.Col := Loc.Col + Get_Token_String'Length + 1; Idlac_Errors.Error ("'{' expected. ", Idlac_Errors.Error, Loc); end; Result := No_Node; Success := False; end case; when others => declare Loc : Idlac_Errors.Location; begin Loc := Get_Previous_Token_Location; Loc.Col := Loc.Col + 7; Idlac_Errors.Error ("Identifier expected in module.", Idlac_Errors.Error, Loc); end; Result := No_Node; Success := False; end case; return; pragma Debug (O2 ("Parse_Module: end")); end Parse_Module; --------------------- -- Parse_Interface -- --------------------- procedure Parse_Interface (Result : out Node_Id; Success : out Boolean) is Res : Node_Id; Prev_Decl : Node_Id; Definition : Identifier_Definition_Acc; begin pragma Debug (O2 ("Parse_Interface: enter")); Res := Make_Interface (Get_Token_Location); -- is the interface abstracted if Get_Token = T_Abstract then Set_Abst (Res, True); Set_Local (Res, False); -- the T_Interface token should "interface" -- (it is already checked) Next_Token; elsif Get_Token = T_Local then Set_Abst (Res, False); Set_Local (Res, True); -- the T_Interface token should "interface" -- (it is already checked) Next_Token; else Set_Abst (Res, False); Set_Local (Res, False); end if; Set_Location (Res, Get_Token_Location); Set_Initial_Current_Prefix (Res); Next_Token; -- Expect an identifier if Get_Token = T_Identifier then Definition := Find_Identifier_Definition (Get_Token_String, Get_Lexer_Location); -- Retrieve previous definition if not Is_Redefinable (Get_Token_String, Get_Lexer_Location) then -- Is previous definition a forward declaration? if Definition.Parent_Scope = Get_Current_Scope and then Kind (Definition.Node) = K_Forward_Interface then -- Check consistency of the 'abstract' property if Abst (Definition.Node) /= Abst (Res) then declare Loc : Idlac_Errors.Location; begin Loc := Types.Get_Location (Definition.Node); Idlac_Errors.Error ("Forward declaration " & Idlac_Errors.Location_To_String (Loc) & " has not the same abstract type", Idlac_Errors.Error, Get_Previous_Token_Location); end; end if; -- XXX Does we also check consistency of 'local' property? Prev_Decl := Get_Node (Definition); if View_Next_Token /= T_Semi_Colon then Set_Forward (Prev_Decl, Res); Set_Forward (Res, Prev_Decl); Redefine_Identifier (Definition, Res); -- The forward declaration is now implemented. Add_Int_Val_Definition (Prev_Decl); Set_Repository_Id (Res, Repository_Id (Prev_Decl)); end if; else declare Loc : Idlac_Errors.Location; begin Loc := Types.Get_Location (Find_Identifier_Node (Get_Token_String, Get_Lexer_Location)); Idlac_Errors.Error ("This interface name is already declared in" & " this scope : " & Idlac_Errors.Location_To_String (Loc), Idlac_Errors.Error, Get_Token_Location); Success := False; Result := No_Node; Prev_Decl := No_Node; return; end; end if; else pragma Debug (O ("Parse_Interface : identifier not defined")); Prev_Decl := No_Node; Set_Forward (Res, No_Node); if not Add_Identifier (Res, Get_Token_String) then raise Idlac_Errors.Internal_Error; end if; Set_Default_Repository_Id (Res); Definition := Find_Identifier_Definition (Get_Token_String, Get_Lexer_Location); end if; else declare Loc : Idlac_Errors.Location; begin Loc := Get_Previous_Token_Location; Loc.Col := Loc.Col + 10; Idlac_Errors.Error (" identifier expected after 'interface'", Idlac_Errors.Error, Loc); Success := False; Result := No_Node; return; end; end if; pragma Debug (O ("Parse_Interface : identifier parsed")); Next_Token; if Get_Token = T_Semi_Colon then -- Forward declaration Set_Kind (Res, K_Forward_Interface); Success := True; Result := Res; if Prev_Decl /= No_Node then declare Loc : Idlac_Errors.Location; begin Loc := Types.Get_Location (Prev_Decl); Idlac_Errors.Error ("interface already forward declared in" & " this scope: " & Idlac_Errors.Location_To_String (Loc), Idlac_Errors.Warning, Get_Token_Location); -- This is only a warning: the OMG IDL grammar -- allows multiple forward declarations of an -- interface. end; else -- Add a forward declaration Add_Int_Val_Forward (Res); end if; else -- Full interface declaration, parse remainder Parse_Interface_Dcl_End (Res, Success); if not Success then Result := No_Node; else Result := Res; end if; end if; pragma Debug (O2 ("Parse_Interface: end")); end Parse_Interface; ------------------ -- Parse_Export -- ------------------ procedure Parse_Export (Result : out Node_Id; Success : out Boolean) is begin case Get_Token is when T_Readonly | T_Attribute => declare Result_Attr : Node_Id; begin Parse_Attr_Dcl (Result_Attr, Success); Result := Result_Attr; end; when T_Oneway | T_Void | T_Colon_Colon | T_Identifier | T_Short | T_Long | T_Float | T_Double | T_Unsigned | T_Char | T_Wchar | T_Boolean | T_Octet | T_Any | T_Object | T_String | T_Wstring | T_ValueBase => declare Result_Operation : Node_Id; begin Parse_Op_Dcl (Result_Operation, Success); Result := Result_Operation; end; when T_Exception => declare Result_Except : Node_Id; begin Parse_Except_Dcl (Result_Except, Success); Result := Result_Except; end; when T_Const => declare Result_Const : Node_Id; begin Parse_Const_Dcl (Result_Const, Success); Result := Result_Const; end; when T_Union | T_Struct | T_Enum | T_Native | T_Typedef => Parse_Type_Dcl (Result, Success); when T_Pragma => Parse_Pragma (Result, Success); if not Success then -- here the pragma is ignored and no node created -- so we parse the next export (if it exists) Parse_Export (Result, Success); end if; pragma Debug (O2 ("Parse_Export: end")); return; when T_Right_Cbracket => -- here we just parsed a pragma but it was the last export of the -- interface or value. Thus, we return without creating a node but -- without an error message Success := False; Result := No_Node; return; when others => Idlac_Errors.Error ("declaration of a type, a constant, an exception, " & "an attribute or an operation expected", Idlac_Errors.Error, Get_Token_Location); Success := False; Result := No_Node; return; end case; if not Success then return; end if; if Get_Token /= T_Semi_Colon then Idlac_Errors.Error ("';' expected", Idlac_Errors.Error, Get_Token_Location); Go_To_End_Of_Export; else Next_Token; end if; end Parse_Export; ----------------------------- -- Parse_Interface_Dcl_End -- ----------------------------- procedure Parse_Interface_Dcl_End (Result : in out Node_Id; Success : out Boolean) is Body_Success : Boolean; begin pragma Debug (O2 ("Parse_Interface_Dcl_End: enter")); -- interface header. if Get_Token = T_Colon then -- inheritance_spec loop Next_Token; declare Scoped_Success : Boolean; Name : Node_Id; begin Parse_Interface_Name (Name, Scoped_Success); if not Scoped_Success then Go_To_Next_Left_Cbracket; exit; end if; if Name /= No_Node and then Kind (Value (Name)) = K_Interface then -- verify it was not already inherited pragma Debug (O ("Parse_Interface_Dcl_End : verify " & "duplicated inheritance")); if Is_In_Pointed_List (Parents (Result), Name) then pragma Debug (O ("Parse_Interface_Dcl_End : duplicated " & "inheritance")); Idlac_Errors.Error ("An interface may not " & "directly inherit more " & "than once from another one.", Idlac_Errors.Error, Get_Token_Location); else pragma Debug (O ("Parse_Interface_Dcl_End : non " & "duplicated inheritance")); -- verify the abstraction of the inherited interface if Abst (Result) and then not Abst (Value (Name)) then Idlac_Errors.Error ("An abstract interface may not inherit from " & "a statefull one.", Idlac_Errors.Error, Get_Token_Location); end if; -- verify XXX if not Local (Result) and then Local (Value (Name)) then Idlac_Errors.Error ("An unconstrained interface may not inherit from " & "a local interface.", Idlac_Errors.Error, Get_Token_Location); end if; -- verify that the imported interface does not -- define an attribute or an operation already -- defined in a previouly imported one. if Interface_Is_Importable (Name, Result) then Append_Node_To_Parents (Result, Name); else -- one of the attribute or operation of the -- new interface to be imported was already -- defined in the previously imported ones Idlac_Errors.Error ("The attribute or operation definitions "& " in this interface clashes with the definitions " & "of the previouly imported ones.", Idlac_Errors.Error, Get_Token_Location); end if; end if; end if; end; exit when Get_Token /= T_Comma; end loop; end if; if Get_Token = T_Left_Cbracket then Next_Token; else declare Loc : Idlac_Errors.Location; begin Loc := Get_Previous_Token_Location; Loc.Col := Loc.Col + Get_Previous_Token_String'Length + 1; Idlac_Errors.Error ("'{' expected", Idlac_Errors.Error, Loc); Success := False; return; end; end if; -- Create a scope for the interface. Push_Scope (Result); declare List : Node_List; begin List := Contents (Result); Parse_Interface_Body (List, Body_Success); Set_Contents (Result, List); end; Pop_Scope; if not Body_Success then Result := No_Node; Success := False; return; else -- consume the right bracket at the end of the interface body -- verification of the presence of this bracket was done -- in Parse_Interface_Body Next_Token; end if; Success := True; return; pragma Debug (O2 ("Parse_Interface_Dcl_End: end")); end Parse_Interface_Dcl_End; -------------------------- -- Parse_Interface_Body -- -------------------------- procedure Parse_Interface_Body (List : in out Node_List; Success : out Boolean) is Export_Success : Boolean; Result : Node_Id; begin Success := True; loop exit when Get_Token = T_Right_Cbracket or else Get_Token = T_Eof; Parse_Export (Result, Export_Success); if not Export_Success then pragma Debug (O ("Parse_Interface_Body : Export_Success = false")); Go_To_Next_Export; else pragma Debug (O ("Parse_Interface_Body : Export_Success = True")); Append_Node (List, Result); end if; end loop; end Parse_Interface_Body; -------------------------- -- Parse_Interface_Name -- -------------------------- procedure Parse_Interface_Name (Result : out Node_Id; Success : out Boolean) is begin Parse_Scoped_Name (Result, Success); -- the scoped name should denote an interface if Success and then Result /= No_Node then if Kind (Value (Result)) /= K_Interface then if Kind (Value (Result)) = K_Forward_Interface then Idlac_Errors.Error ("the inherited scoped name should denote a statefull " & "interface, not a forwarded one.", Idlac_Errors.Error, Get_Previous_Token_Location); else Idlac_Errors.Error ("the inherited scoped name should denote an interface", Idlac_Errors.Error, Get_Previous_Token_Location); end if; end if; end if; end Parse_Interface_Name; ----------------------- -- Parse_Scoped_Name -- ----------------------- procedure Parse_Scoped_Name (Result : out Node_Id; Success : out Boolean) is Res : Node_Id; Scope : Node_Id; A_Name : Node_Id := No_Node; begin pragma Debug (O2 ("Parse_Scoped_Name: enter")); Result := No_Node; Success := False; -- creation of a scoped_name node Res := Make_Scoped_Name (Get_Token_Location); -- if it begins with :: then the scope of reference is -- the root scope if Get_Token = T_Colon_Colon then Scope := Get_Root_Scope; pragma Debug (O ("Parse_Scoped_Name: root scope is defined at " & Idlac_Errors.Location_To_String (Get_Location (Scope)))); else -- token should be an identifier if Get_Token /= T_Identifier then Idlac_Errors.Error (" identifier or '::' expected at the " & "beginning of a scoped name", Idlac_Errors.Error, Get_Token_Location); Success := False; Result := No_Node; pragma Debug (O2 ("Parse_Scoped_Name: end")); return; end if; -- gets the name of the scope of reference for this scoped_name -- if the current scope is one of the following : -- struct, union, operation, exception -- then we have to look at the parent scope level -- (see COBA v2.3 3.15.3 : Special Scoping Rules for Type Names) -- if it is a union, you have to take care of a potential -- enum type definition inside the switch statement. In this -- precise case, one of the label of the enum can be used inside -- the union. case Kind (Get_Current_Scope) is when K_Struct | K_Exception | K_Operation => declare The_Scope : constant Node_Id := Get_Current_Scope; begin Pop_Scope; A_Name := Find_Identifier_Node (Get_Token_String, Get_Lexer_Location); Push_Scope (The_Scope); end; when K_Union => declare The_Scope : constant Node_Id := Get_Current_Scope; begin pragma Debug (O ("Parse_Scoped_Name : dealing with " & "a union scope")); -- first try to find the name in the potential -- enum declaration of the switch statement -- for this purpose, we look in the current_scope -- and check if the result is in the switch or not -- if not, we just skip because of 3.15.3 (see above) A_Name := Find_Identifier_Node (Get_Token_String, Get_Lexer_Location); if A_Name /= No_Node and then Switch_Type (Get_Current_Scope) /= No_Node and then Kind (Switch_Type (Get_Current_Scope)) = K_Enum and then Is_In_List (Enumerators (Switch_Type (Get_Current_Scope)), A_Name) then pragma Debug (O ("Parse_Scoped_Name : found something " & "in the current scope. That was " & "interesting")); null; else pragma Debug (O ("Parse_Scoped_Name : found something " & "in the current scope but " & "not interesting")); A_Name := No_Node; end if; if A_Name = No_Node then pragma Debug (O ("Parse_Scoped_Name : looking in " & "the parent scope")); -- else look at the parent scope Pop_Scope; A_Name := Find_Identifier_Node (Get_Token_String, Get_Lexer_Location); -- this reopens the union scope. Push_Scope (The_Scope); end if; end; when others => A_Name := Find_Identifier_Node (Get_Token_String, Get_Lexer_Location); end case; -- If it does not correspond to a previously defined scope if A_Name = No_Node then pragma Debug (O ("Parse_Scoped_Name : name is null")); Idlac_Errors.Error ("Bad identifier in scoped name : " & "identifier `" & Get_Token_String & "' does not exist", Idlac_Errors.Error, Get_Token_Location); Go_To_End_Of_Scoped_Name; Success := True; pragma Debug (O2 ("Parse_Scoped_Name: end")); return; end if; -- If we are not in its definition scope, -- we should perhaps import this identifier: -- -- first we should look at the current scope. -- If it is a Struct, Union, Operation or Exception -- we should import the identifier into the parent scope -- of the current scope if necessary; -- else we should import it into the current scope. -- -- If it is a module, an interface, a valuetype -- or the repository, the add function won't do -- anything. -- XXX Thomas 2000-08-25: I don't understand the above -- 3 lines /at all/. declare CSK : constant Node_Kind := Kind (Get_Current_Scope); begin if CSK = K_Repository or else CSK = K_Module or else CSK = K_Interface or else CSK = K_ValueType then pragma Debug (O ("Parse_Scope_Name: Current_Scope is a Gen_Scope.")); if Get_Current_Scope /= Definition (A_Name).Parent_Scope or else Name (Get_Current_Scope) /= Get_Token_String then pragma Debug (O ("Parse_Scoped_Name: importing """ & Get_Token_String & """ into Current_Scope")); Add_Definition_To_Imported (Definition (A_Name), Get_Current_Scope); end if; else pragma Debug (O ("Parse_Scoped_Name: Current_Scope is not a Gen_Scope.")); if Get_Previous_Scope /= Definition (A_Name).Parent_Scope or else Name (Get_Previous_Scope) /= Get_Token_String then pragma Debug (O ("Parse_Scoped_Name: importing """ & Get_Token_String & """ into Previous_Scope")); Add_Definition_To_Imported (Definition (A_Name), Get_Previous_Scope); end if; end if; end; -- here we deal with the case of an identifier -- with '::' after it : it must denote a scope if View_Next_Token = T_Colon_Colon then -- Is the identifier a scope? if not Is_Scope (A_Name) then Idlac_Errors.Error ("Bad identifier in scoped name : " & "identifier `" & Name (A_Name) & "' does not denote a scope", Idlac_Errors.Error, Get_Token_Location); Go_To_End_Of_Scoped_Name; Success := True; pragma Debug (O2 ("Parse_Scoped_Name: end")); return; else Scope := A_Name; end if; -- to eat the identifier representing the current scope Next_Token; end if; end if; pragma Debug (O ("Parse_Scoped_Name : beginning of loop")); -- Loop through the scopes to get the right definition declare Def : Identifier_Definition_Acc; begin while Get_Token = T_Colon_Colon loop -- consumes the '::' Next_Token; -- we should have an identifier here if Get_Token /= T_Identifier then Idlac_Errors.Error (" identifier expected in the scoped name", Idlac_Errors.Error, Get_Token_Location); Success := False; Result := No_Node; pragma Debug (O2 ("Parse_Scoped_Name: end")); return; end if; -- Find the identifier in the reference scope Def := Find_Identifier_In_Storage (Scope, Get_Token_String); -- if it does not exist if Def = null then Idlac_Errors.Error ("Bad identifier `" & Get_Token_String & "' in scoped name : this identifier does not exist " & "in the given scope", Idlac_Errors.Error, Get_Token_Location); Go_To_End_Of_Scoped_Name; Success := True; pragma Debug (O2 ("Parse_Scoped_Name: end")); return; end if; A_Name := Def.Node; -- if it is not the end of the scoped name, the -- current identifier should denote a node if View_Next_Token = T_Colon_Colon then if not Is_Scope (A_Name) then Idlac_Errors.Error ("Bad identifier `" & Name (A_Name) & "' in scoped name : this identifier does not denote " & "a scope", Idlac_Errors.Error, Get_Token_Location); Go_To_End_Of_Scoped_Name; Success := True; pragma Debug (O2 ("Parse_Scoped_Name: end")); return; else Scope := A_Name; end if; -- consumes the identifier Next_Token; end if; end loop; pragma Debug (O ("Parse_Scoped_Name : end of loop")); Set_Value (Res, A_Name); -- Here we try to avoid recursivity in structs and unions if (Kind (Get_Current_Scope) = K_Struct or else Kind (Get_Current_Scope) = K_Union) and then Get_Current_Scope = A_Name then -- recursivity is allowed through sequences or Pragma if View_Previous_Previous_Token /= T_Sequence and then View_Previous_Previous_Token /= T_Pragma then Idlac_Errors.Error ("Recursive definitions not allowed", Idlac_Errors.Error, Get_Token_Location); Success := False; Result := No_Node; pragma Debug (O2 ("Parse_Scoped_Name: end")); return; end if; end if; end; -- consumes the last identifier Next_Token; Success := True; Result := Res; pragma Debug (O ("Parse_Scoped_Name : " & "end if simple identifier")); pragma Debug (O2 ("Parse_Scoped_Name: end")); return; end Parse_Scoped_Name; ----------------- -- Parse_Value -- ----------------- procedure Parse_Value (Result : out Node_Id; Success : out Boolean) is begin pragma Debug (O2 ("Parse_Value: enter")); case Get_Token is when T_Custom => Next_Token; declare Res : Node_Id; begin Parse_Custom_Value (Res, Success); Result := Res; end; when T_Abstract => Next_Token; Parse_Abstract_Value (Result, Success); when T_ValueType => Parse_Direct_Value (Result, Success); when others => raise Idlac_Errors.Internal_Error; end case; pragma Debug (O2 ("Parse_Value: end")); return; end Parse_Value; ------------------------ -- Parse_Custom_Value -- ------------------------ procedure Parse_Custom_Value (Result : out Node_Id; Success : out Boolean) is begin pragma Debug (O2 ("Parse_Custom_Value: enter")); if Get_Token /= T_ValueType then declare Loc : Idlac_Errors.Location; begin Loc := Get_Previous_Token_Location; Loc.Col := Loc.Col + 7; Idlac_Errors.Error (Ada.Characters.Latin_1.Quotation & "valuetype" & Ada.Characters.Latin_1.Quotation & " expected after custom keyword.", Idlac_Errors.Error, Loc); end; Result := No_Node; Success := False; else Next_Token; if Get_Token /= T_Identifier then declare Loc : Idlac_Errors.Location; begin Loc := Get_Previous_Token_Location; Loc.Col := Loc.Col + 10; Idlac_Errors.Error ("identifier expected.", Idlac_Errors.Error, Loc); end; Result := No_Node; Success := False; else Parse_End_Value_Dcl (Result, Success, True, False); end if; end if; pragma Debug (O2 ("Parse_Custom_Value: enter")); return; end Parse_Custom_Value; ---------------------------- -- Parse_Abstract_Value -- ---------------------------- procedure Parse_Abstract_Value (Result : out Node_Id; Success : out Boolean) is begin pragma Debug (O2 ("Parse_Abstract_Value: enter")); if Get_Token /= T_ValueType then declare Loc : Idlac_Errors.Location; begin Loc := Get_Previous_Token_Location; Loc.Col := Loc.Col + 9; Idlac_Errors.Error (Ada.Characters.Latin_1.Quotation & "valuetype" & Ada.Characters.Latin_1.Quotation & "expected after abstract keyword.", Idlac_Errors.Error, Loc); end; Result := No_Node; Success := False; else Next_Token; pragma Debug (O ("Parse_Abstract_Value : check for identifier")); if Get_Token /= T_Identifier then declare Loc : Idlac_Errors.Location; begin Loc := Get_Previous_Token_Location; Loc.Col := Loc.Col + 10; Idlac_Errors.Error ("identifier expected.", Idlac_Errors.Error, Loc); end; Result := No_Node; Success := False; else case View_Next_Token is when T_Colon | T_Supports | T_Left_Cbracket => declare Res : Node_Id; begin Parse_End_Value_Dcl (Res, Success, False, True); Result := Res; end; when T_Semi_Colon => declare Res : Node_Id; begin Parse_End_Value_Forward_Dcl (Res, Success, True); Result := Res; end; when others => declare Loc : Idlac_Errors.Location; begin Loc := Get_Token_Location; Loc.Col := Loc.Col + Get_Token_String'Length; Idlac_Errors.Error ("Bad value definition. " & "Inheritance specification, '{'" & " or ';' expected.", Idlac_Errors.Error, Loc); end; Result := No_Node; Success := False; end case; end if; end if; pragma Debug (O2 ("Parse_Abstract_Value: end")); return; end Parse_Abstract_Value; ------------------------ -- Parse_Direct_Value -- ------------------------ procedure Parse_Direct_Value (Result : out Node_Id; Success : out Boolean) is begin pragma Debug (O2 ("Parse_Direct_Value: enter")); Next_Token; if Get_Token /= T_Identifier then declare Loc : Idlac_Errors.Location; begin Loc := Get_Previous_Token_Location; Loc.Col := Loc.Col + 10; Idlac_Errors.Error ("identifier expected.", Idlac_Errors.Error, Loc); end; Result := No_Node; Success := False; else case View_Next_Token is when T_Float | T_Double | T_Long | T_Short | T_Unsigned | T_Char | T_Wchar | T_Boolean | T_Octet | T_Any | T_Object | T_ValueBase | T_Sequence | T_String | T_Wstring | T_Fixed | T_Identifier | T_Colon_Colon | T_Struct | T_Union | T_Enum => declare Res : Node_Id; begin Parse_End_Value_Box_Dcl (Res, Success); Result := Res; end; when T_Semi_Colon => declare Res : Node_Id; begin Parse_End_Value_Forward_Dcl (Res, Success, False); Result := Res; end; when T_Colon | T_Supports | T_Left_Cbracket => declare Res : Node_Id; begin Parse_End_Value_Dcl (Res, Success, False, False); Result := Res; end; when others => declare Loc : Idlac_Errors.Location; begin Loc := Get_Token_Location; Loc.Col := Loc.Col + Get_Token_String'Length; Idlac_Errors.Error ("Bad value definition. " & "Type, inheritance specification, " & "'{' or ';' expected.", Idlac_Errors.Error, Loc); end; Result := No_Node; Success := False; end case; end if; pragma Debug (O2 ("Parse_Direct_Value: end")); return; end Parse_Direct_Value; --------------------------- -- Parse_End_Value_Dcl -- --------------------------- procedure Parse_End_Value_Dcl (Result : out Node_Id; Success : out Boolean; Custom : Boolean; Abst : Boolean) is Definition : Identifier_Definition_Acc; begin pragma Debug (O2 ("Parse_End_Value_Dcl: enter")); Result := Make_ValueType (Get_Previous_Token_Location); Set_Abst (Result, Abst); Set_Custom (Result, Custom); if Abst or else Custom then Set_Location (Result, Get_Previous_Previous_Token_Location); else Set_Location (Result, Get_Previous_Token_Location); end if; Set_Initial_Current_Prefix (Result); -- Try to find a previous definition Definition := Find_Identifier_Definition (Get_Token_String, Get_Lexer_Location); -- Is there a previous definition and in the same scope? if not Is_Redefinable (Get_Token_String, Get_Lexer_Location) then -- Is it a forward declaration? if Definition.Parent_Scope = Get_Current_Scope and then Kind (Definition.Node) = K_Forward_ValueType then declare Fd_Decl : Node_Id; begin Fd_Decl := Get_Node (Definition); Add_Int_Val_Definition (Fd_Decl); Set_Forward (Fd_Decl, Result); Set_Forward (Result, Fd_Decl); Set_Repository_Id (Result, Repository_Id (Fd_Decl)); Redefine_Identifier (Definition, Result); end; else Idlac_Errors.Error ("The identifier used for this valuetype is already " & "defined in the same scope : " & Idlac_Errors.Location_To_String (Get_Location (Definition.Node)), Idlac_Errors.Error, Get_Token_Location); Set_Forward (Result, No_Node); end if; else -- No previous definition Set_Forward (Result, No_Node); if not Add_Identifier (Result, Get_Token_String) then raise Idlac_Errors.Internal_Error; end if; Set_Default_Repository_Id (Result); end if; Next_Token; if Get_Token = T_Colon or else Get_Token = T_Supports then -- An inheritance specification is present declare Inherit_Success : Boolean; begin Parse_Value_Inheritance_Spec (Result, Inherit_Success); if not Inherit_Success then Go_To_Next_Left_Cbracket; if Get_Token = T_Eof then Success := False; return; end if; end if; end; end if; if Get_Token /= T_Left_Cbracket then declare Loc : Idlac_Errors.Location; begin Loc := Get_Token_Location; -- At this point, this is only possible after an -- inheritance specification. -- The previous token is therefore an identifier. Loc.Col := Loc.Col + Get_Previous_Token_String'Length; Idlac_Errors.Error ("Bad value definition: '{' expected.", Idlac_Errors.Error, Loc); end; Success := False; return; end if; Next_Token; Push_Scope (Result); while Get_Token /= T_Right_Cbracket loop declare Element_Success : Boolean; Element : Node_Id; begin if Abst then -- rule Value5 Parse_Export (Element, Element_Success); else -- rule Value6 Parse_Value_Element (Element, Element_Success); end if; if not Element_Success then Go_To_Next_Value_Element; if Get_Token = T_Eof then Success := False; return; end if; else Append_Node_To_Contents (Result, Element); end if; end; end loop; Pop_Scope; -- Consume the right Cbracket Next_Token; Success := True; pragma Debug (O2 ("Parse_End_Value_Dcl: end")); return; end Parse_End_Value_Dcl; ----------------------------------- -- Parse_End_Value_Forward_Dcl -- ----------------------------------- procedure Parse_End_Value_Forward_Dcl (Result : out Node_Id; Success : out Boolean; Abst : Boolean) is Definition : Identifier_Definition_Acc; begin Result := Make_Forward_ValueType (Get_Previous_Token_Location); Set_Abst (Result, Abst); if Abst then Set_Location (Result, Get_Previous_Previous_Token_Location); else Set_Location (Result, Get_Previous_Token_Location); end if; -- try to find a previous definition Definition := Find_Identifier_Definition (Get_Token_String, Get_Lexer_Location); -- Is there a previous definition and in the same scope ? if not Is_Redefinable (Get_Token_String, Get_Lexer_Location) then -- is it a forward if Definition.Parent_Scope = Get_Current_Scope and then Kind (Definition.Node) = K_Forward_ValueType then -- nothing to do : this new forward declaration is useless Idlac_Errors.Error ("This valuetype was already declared forward : " & Idlac_Errors.Location_To_String (Get_Location (Definition.Node)), Idlac_Errors.Warning, Get_Token_Location); else Idlac_Errors.Error ("The identifier used for this valuetype is already " & "defined in the same scope : " & Idlac_Errors.Location_To_String (Get_Location (Definition.Node)), Idlac_Errors.Error, Get_Token_Location); end if; else -- no previous forward if not Add_Identifier (Result, Get_Token_String) then raise Idlac_Errors.Internal_Error; end if; Set_Default_Repository_Id (Result); Add_Int_Val_Forward (Result); end if; -- consumes the identifier Next_Token; Success := True; return; end Parse_End_Value_Forward_Dcl; ------------------------------- -- Parse_End_Value_Box_Dcl -- ------------------------------- procedure Parse_End_Value_Box_Dcl (Result : out Node_Id; Success : out Boolean) is Definition : Identifier_Definition_Acc; begin Result := Make_Boxed_ValueType (Get_Previous_Token_Location); -- try to find a previous definition Definition := Find_Identifier_Definition (Get_Token_String, Get_Lexer_Location); -- Is there a previous definition and in the same scope ? if not Is_Redefinable (Get_Token_String, Get_Lexer_Location) then -- is it a forward if Definition.Parent_Scope = Get_Current_Scope and then Kind (Definition.Node) = K_Forward_ValueType then -- nothing to do : this new forward declaration is useless Idlac_Errors.Error ("This valuetype was forward declared : " & Idlac_Errors.Location_To_String (Get_Location (Definition.Node)) & ". It can not be a boxed one.", Idlac_Errors.Error, Get_Previous_Token_Location); -- To avoid a second error, due to the non declaration -- of the forward value Add_Int_Val_Definition (Definition.Node); else Idlac_Errors.Error ("The identifier used for this valuetype is already " & "defined in the same scope : " & Idlac_Errors.Location_To_String (Get_Location (Definition.Node)), Idlac_Errors.Error, Get_Token_Location); end if; Next_Token; declare Node : Node_Id; begin Node := Boxed_Type (Result); Parse_Type_Spec (Node, Success); Set_Boxed_Type (Result, Node); end; else -- no previous forward declare Name : String_Ptr; begin -- the purpose here is to avoid the use of the value -- name in the definition of its type. For example, the -- following declaration is illegal : -- valuetype FooSeq sequence Name := new String'(Get_Token_String); Next_Token; declare Node : Node_Id; begin Node := Boxed_Type (Result); Parse_Type_Spec (Node, Success); Set_Boxed_Type (Result, Node); end; if not Add_Identifier (Result, Name.all) then raise Idlac_Errors.Internal_Error; end if; Set_Default_Repository_Id (Result); Free_String_Ptr (Name); end; end if; return; end Parse_End_Value_Box_Dcl; ---------------------------------- -- Parse_Value_Inheritance_Spec -- ---------------------------------- procedure Parse_Value_Inheritance_Spec (Result : Node_Id; Success : out Boolean) is begin pragma Debug (O2 ("Parse_Value_Inheritance_Spec: enter")); Success := True; if Get_Token = T_Colon then Next_Token; if Get_Token = T_Truncatable then if Abst (Result) then Idlac_Errors.Error ("The truncatable modifier may not " & "be used in an abstract value.", Idlac_Errors.Error, Get_Token_Location); elsif Custom (Result) then Idlac_Errors.Error ("The truncatable modifier may not " & "be used in a custom value.", Idlac_Errors.Error, Get_Token_Location); else Set_Truncatable (Result, True); end if; Next_Token; end if; pragma Debug (O ("Parse_Value_Inheritance_Spec : truncable treated")); -- parse value inheritance declare Name : Node_Id; Name_Success : Boolean; begin Parse_Value_Name (Name, Name_Success); if Name_Success and then Name /= No_Node then case Kind (Value (Name)) is when K_ValueType => if Abst (Result) then if not Abst (Value (Name)) then Idlac_Errors.Error ("An abstract value may not inherit from a " & "stateful one.", Idlac_Errors.Error, Get_Token_Location); end if; else if Abst (Value (Name)) and then Truncatable (Result) then Idlac_Errors.Error ("The truncatable modifier may not be used " & "for an abstract value inheritance.", Idlac_Errors.Error, Get_Token_Location); end if; end if; Append_Node_To_Parents (Result, Name); when K_Forward_ValueType => Idlac_Errors.Error ("A value may not inherit from a forward declared" & " value whose definition has not yet been seen.", Idlac_Errors.Error, Get_Token_Location); when K_Boxed_ValueType => Idlac_Errors.Error ("A value may not inherit from a boxed value.", Idlac_Errors.Error, Get_Token_Location); when K_Interface | K_Forward_Interface => Idlac_Errors.Error ("A value may not inherit from an interface. "& "It can only support it.", Idlac_Errors.Error, Get_Token_Location); when others => declare Loc : Idlac_Errors.Location; begin Loc := Get_Previous_Token_Location; Loc.Col := Loc.Col + 2; Idlac_Errors.Error ("Value name expected.", Idlac_Errors.Error, Loc); end; end case; else Go_To_Next_Left_Cbracket; Success := False; return; end if; end; pragma Debug (O ("Parse_Value_Inheritance_Spec : " & "first parent parsed")); while Get_Token = T_Comma loop Next_Token; declare Name : Node_Id; Name_Success : Boolean; begin Parse_Value_Name (Name, Name_Success); if Name_Success and then Name /= No_Node then case Kind (Value (Name)) is when K_ValueType => pragma Debug (O ("Parse_Value_Inheritance_Spec : " & "parent is a valuetype")); if Is_In_Pointed_List (Parents (Result), Name) then -- already inherited Idlac_Errors.Error ("A value may not directly inherit more than " & "once from another one.", Idlac_Errors.Error, Get_Token_Location); else if not Abst (Value (Name)) then Idlac_Errors.Error ("A stateful value may only derive from a " & "single stateful value and this one must " & "be the first element in the inheritance.", Idlac_Errors.Error, Get_Token_Location); end if; Append_Node_To_Parents (Result, Name); end if; when K_Forward_ValueType => Idlac_Errors.Error ("A value may not inherit from a forward declared" & " value whose definition has not yet been seen.", Idlac_Errors.Error, Get_Token_Location); when K_Boxed_ValueType => Idlac_Errors.Error ("A value may not inherit from a boxed value.", Idlac_Errors.Error, Get_Token_Location); when K_Interface | K_Forward_Interface => Idlac_Errors.Error ("A value may not inherit from an interface. "& "It can only support it.", Idlac_Errors.Error, Get_Token_Location); when others => declare Loc : Idlac_Errors.Location; begin Loc := Get_Previous_Token_Location; Loc.Col := Loc.Col + 2; Idlac_Errors.Error ("Value name expected.", Idlac_Errors.Error, Loc); end; end case; else Go_To_Next_Left_Cbracket; Success := False; return; end if; end; end loop; end if; pragma Debug (O ("Parse_Value_Inheritance_Spec : " & "beginning parsing of supports declarations")); -- Since we entered this method after reading T_colon -- or T_Supports, we should have T_Supports now. case Get_Token is when T_Supports => Next_Token; declare Non_Abstract_Interface : Boolean := False; begin -- parse interface inheritance declare Name : Node_Id; Name_Success : Boolean; begin Parse_Interface_Name (Name, Name_Success); if Name_Success then case Kind (Value (Name)) is when K_Interface => if not Abst (Value (Name)) then Non_Abstract_Interface := True; end if; Append_Node_To_Supports (Result, Name); when K_Forward_Interface => Idlac_Errors.Error ("A value may not support a forward declared" & " interface whose declaration has not yet " & "been seen.", Idlac_Errors.Error, Get_Token_Location); when K_Boxed_ValueType | K_ValueType | K_Forward_ValueType => Idlac_Errors.Error ("A value may not support another value. " & " However, it can inherit from it.", Idlac_Errors.Error, Get_Token_Location); when others => declare Loc : Idlac_Errors.Location; begin Loc := Get_Previous_Token_Location; Loc.Col := Loc.Col + 9; Idlac_Errors.Error ("Value name expected.", Idlac_Errors.Error, Loc); end; end case; else Go_To_Next_Left_Cbracket; Success := False; return; end if; end; while Get_Token = T_Comma loop Next_Token; declare Name : Node_Id; Name_Success : Boolean; begin Parse_Interface_Name (Name, Name_Success); if Name_Success then case Kind (Value (Name)) is when K_Interface => if Is_In_Pointed_List (Supports (Result), Name) then -- already inherited Idlac_Errors.Error ("A value may not directly support " & "a given interface more than once.", Idlac_Errors.Error, Get_Token_Location); else if not Abst (Result) and then not Abst (Value (Name)) then if Non_Abstract_Interface then Idlac_Errors.Error ("A stateful value may support " & "only " & "one non abstract interface. This " & "is the second one.", Idlac_Errors.Error, Get_Token_Location); else Non_Abstract_Interface := True; end if; end if; Append_Node_To_Supports (Result, Name); end if; when K_Forward_Interface => Idlac_Errors.Error ("A value may not support a forward declared" & " interface whose declaration has not yet " & "been seen.", Idlac_Errors.Error, Get_Token_Location); when K_Boxed_ValueType | K_ValueType | K_Forward_ValueType => Idlac_Errors.Error ("A value may not support another value. " & " However, it can inherit from it.", Idlac_Errors.Error, Get_Token_Location); when others => declare Loc : Idlac_Errors.Location; begin Loc := Get_Previous_Token_Location; Loc.Col := Loc.Col + 9; Idlac_Errors.Error ("Value name expected.", Idlac_Errors.Error, Loc); end; end case; else Go_To_Next_Left_Cbracket; Success := False; return; end if; end; end loop; end; when T_Left_Cbracket => Success := True; when others => declare Loc : Idlac_Errors.Location; begin Loc := Get_Previous_Token_Location; Loc.Col := Loc.Col + Get_Previous_Token_String'Length; Idlac_Errors.Error ("',', " & Ada.Characters.Latin_1.Quotation & "supports" & Ada.Characters.Latin_1.Quotation & " or '{' expected.", Idlac_Errors.Error, Loc); Success := False; end; end case; pragma Debug (O2 ("Parse_Value_Inheritance_Spec: end")); end Parse_Value_Inheritance_Spec; ------------------------ -- Parse_Value_Name -- ------------------------ procedure Parse_Value_Name (Result : out Node_Id; Success : out Boolean) is begin Parse_Scoped_Name (Result, Success); -- the checking of the type is done inside the method -- parse_value_inheritance_spec, which is the only user of -- this procedure end Parse_Value_Name; --------------------------- -- Parse_Value_Element -- --------------------------- procedure Parse_Value_Element (Result : out Node_Id; Success : out Boolean) is begin case Get_Token is when T_Typedef | T_Struct | T_Union | T_Enum | T_Native | T_Const | T_Exception | T_Readonly | T_Attribute | T_Oneway | T_Void | T_Float | T_Double | T_Long | T_Short | T_Unsigned | T_Char | T_Wchar | T_Boolean | T_Octet | T_Any | T_Object | T_ValueBase | T_String | T_Wstring | T_Identifier | T_Colon_Colon => Parse_Export (Result, Success); when T_Public | T_Private => Parse_State_Member (Result, Success); when T_Factory => Parse_Init_Dcl (Result, Success); when T_Pragma => Parse_Pragma (Result, Success); if not Success then -- here the pragma is ignored and no node created -- so we parse the next export (if it exists) Parse_Value_Element (Result, Success); end if; return; when T_Right_Cbracket => -- here we just parsed a pragma but it was the last element of the -- value. Thus, we return without creating a node but -- without an error message Success := False; Result := No_Node; return; when others => Idlac_Errors.Error ("value_element expected.", Idlac_Errors.Error, Get_Token_Location); Result := No_Node; Success := False; return; end case; end Parse_Value_Element; -------------------------- -- Parse_State_Member -- -------------------------- procedure Parse_State_Member (Result : out Node_Id; Success : out Boolean) is begin Result := Make_State_Member (Get_Token_Location); case Get_Token is when T_Public => Set_Is_Public (Result, True); when T_Private => Set_Is_Public (Result, False); when others => raise Idlac_Errors.Internal_Error; end case; Next_Token; declare Node : Node_Id; begin Node := State_Type (Result); Parse_Type_Spec (Node, Success); Set_State_Type (Result, Node); end; if not Success then Go_To_End_Of_State_Member; return; end if; declare Node : Node_List; begin Node := State_Declarators (Result); Parse_Declarators (Node, Result, Success); Set_State_Declarators (Result, Node); end; if not Success then Go_To_End_Of_State_Member; return; end if; if Get_Token /= T_Semi_Colon then Idlac_Errors.Error ("missing ';' at the end of the state " & "declaration.", Idlac_Errors.Error, Get_Token_Location); Success := False; else Next_Token; end if; return; end Parse_State_Member; ---------------------- -- Parse_Init_Dcl -- ---------------------- procedure Parse_Init_Dcl (Result : out Node_Id; Success : out Boolean) is begin if View_Next_Token /= T_Identifier then declare Loc : Idlac_Errors.Location; begin Loc := Get_Token_Location; Loc.Col := Loc.Col + 8; Idlac_Errors.Error ("Identifier expected after keyword " & Ada.Characters.Latin_1.Quotation & "factory" & Ada.Characters.Latin_1.Quotation & ".", Idlac_Errors.Error, Loc); end; Success := False; return; end if; Result := Make_Initializer (Get_Token_Location); -- consume T_Factory Next_Token; -- Is there a previous definition if not Is_Redefinable (Get_Token_String, Get_Lexer_Location) then declare Definition : constant Identifier_Definition_Acc := Find_Identifier_Definition (Get_Token_String, Get_Lexer_Location); begin Idlac_Errors.Error ("The identifier used for this initializer is already " & "defined in the same scope : " & Idlac_Errors.Location_To_String (Get_Location (Definition.Node)), Idlac_Errors.Error, Get_Token_Location); end; else -- no previous definition if not Add_Identifier (Result, Get_Token_String) then raise Idlac_Errors.Internal_Error; end if; Set_Default_Repository_Id (Result); end if; Next_Token; if Get_Token /= T_Left_Paren then declare Loc : Idlac_Errors.Location; begin Loc := Get_Previous_Token_Location; Loc.Col := Loc.Col + Get_Previous_Token_String'Length; Idlac_Errors.Error ("missing '(' in initializer declaration.", Idlac_Errors.Error, Loc); end; Success := False; return; end if; Next_Token; if Get_Token /= T_Right_Paren then -- there is some parameters declare Decls_Success : Boolean; begin Push_Scope (Result); declare Node : Node_List; begin Node := Param_Decls (Result); Parse_Init_Param_Decls (Node, Decls_Success); Set_Param_Decls (Result, Node); end; Pop_Scope; if not Decls_Success then Go_To_Next_Right_Paren; if Get_Token = T_Eof then Success := False; return; end if; else if Get_Token /= T_Right_Paren then Idlac_Errors.Error ("missing ')' at the end of " & "initializer declaration.", Idlac_Errors.Error, Get_Token_Location); Success := False; return; end if; end if; end; end if; -- consumes the T_Right_Parenthesis Next_Token; if Get_Token /= T_Semi_Colon then Idlac_Errors.Error ("missing ';' at the end of initializer " & "declaration.", Idlac_Errors.Error, Get_Token_Location); Success := False; return; end if; Next_Token; Success := True; return; end Parse_Init_Dcl; ------------------------ -- Parse_Init_Decls -- ------------------------ procedure Parse_Init_Param_Decls (Result : out Node_List; Success : out Boolean) is begin Result := Nil_List; declare Decl : Node_Id; Decl_Success : Boolean; begin Parse_Init_Param_Decl (Decl, Decl_Success); if Decl_Success then Append_Node (Result, Decl); else Success := False; return; end if; end; while Get_Token = T_Comma loop Next_Token; declare Decl : Node_Id; Decl_Success : Boolean; begin Parse_Init_Param_Decl (Decl, Decl_Success); if Decl_Success then Append_Node (Result, Decl); else Success := False; return; end if; end; end loop; Success := True; return; end Parse_Init_Param_Decls; ----------------------- -- Parse_Init_Decl -- ----------------------- procedure Parse_Init_Param_Decl (Result : out Node_Id; Success : out Boolean) is begin case Get_Token is when T_In => Next_Token; when T_Out | T_Inout => Idlac_Errors.Error ("an initializer parameter can only be " & "in mode " & Ada.Characters.Latin_1.Quotation & "in" & Ada.Characters.Latin_1.Quotation & ".", Idlac_Errors.Error, Get_Token_Location); Next_Token; when T_Float | T_Double | T_Long | T_Short | T_Unsigned | T_Char | T_Wchar | T_Boolean | T_Octet | T_Any | T_Object | T_ValueBase | T_String | T_Wstring | T_Identifier | T_Colon_Colon => Idlac_Errors.Error ("an initializer parameter should begin " & "with keyword " & Ada.Characters.Latin_1.Quotation & "in" & Ada.Characters.Latin_1.Quotation & ".", Idlac_Errors.Error, Get_Token_Location); when others => Idlac_Errors.Error ("bad initializer parameter declaration.", Idlac_Errors.Error, Get_Token_Location); Success := False; Result := No_Node; return; end case; Result := Make_Param (Get_Previous_Token_Location); Set_Mode (Result, Mode_In); declare Type_Node : Node_Id; begin Type_Node := Param_Type (Result); Parse_Param_Type_Spec (Type_Node, Success); Set_Param_Type (Result, Type_Node); if not Success then return; end if; declare Node : Node_Id; begin Node := Declarator (Result); Parse_Simple_Declarator (Node, Result, Success); Set_Declarator (Result, Node); end; end; return; end Parse_Init_Param_Decl; ----------------------- -- Parse_Const_Dcl -- ----------------------- procedure Parse_Const_Dcl (Result : out Node_Id; Success : out Boolean) is begin pragma Debug (O2 ("Parse_Const_Dcl: enter")); Next_Token; Result := Make_Const_Dcl (Get_Previous_Token_Location); declare Node : Node_Id; begin Parse_Const_Type (Node, Success); Set_Constant_Type (Result, Node); end; if not Success then return; end if; if Get_Token /= T_Identifier then Idlac_Errors.Error ("Identifier expected in constant declaration.", Idlac_Errors.Error, Get_Token_Location); Success := False; return; else -- Is there a previous definition? if not Is_Redefinable (Get_Token_String, Get_Lexer_Location) then declare Definition : constant Identifier_Definition_Acc := Find_Identifier_Definition (Get_Token_String, Get_Lexer_Location); begin Idlac_Errors.Error ("This identifier is already defined in this scope : " & Idlac_Errors.Location_To_String (Get_Location (Definition.Node)), Idlac_Errors.Error, Get_Token_Location); end; else -- no previous definition if not Add_Identifier (Result, Get_Token_String) then raise Idlac_Errors.Internal_Error; end if; Set_Default_Repository_Id (Result); end if; end if; Next_Token; if Get_Token /= T_Equal then declare Loc : Idlac_Errors.Location; begin Loc := Get_Previous_Token_Location; Loc.Col := Loc.Col + Get_Previous_Token_String'Length; Idlac_Errors.Error ("'=' expected in const declaration.", Idlac_Errors.Error, Loc); end; case Get_Token is when T_Minus | T_Plus | T_Tilde | T_Colon_Colon | T_Identifier | T_Lit_Decimal_Integer | T_Lit_Octal_Integer | T_Lit_Hexa_Integer | T_Lit_Char | T_Lit_Wide_Char | T_Lit_Simple_Floating_Point | T_Lit_Exponent_Floating_Point | T_Lit_Pure_Exponent_Floating_Point | T_Lit_String | T_Lit_Wide_String | T_Lit_Simple_Fixed_Point | T_Lit_Floating_Fixed_Point | T_Left_Paren => null; when others => Success := False; return; end case; else Next_Token; end if; declare Node : Node_Id; begin Node := Expression (Result); Parse_Const_Exp (Node, Constant_Type (Result), Success); Set_Expression (Result, Node); end; return; pragma Debug (O2 ("Parse_Const_Dcl: end")); end Parse_Const_Dcl; ------------------------ -- Parse_Const_Type -- ------------------------ procedure Parse_Const_Type (Result : out Node_Id; Success : out Boolean) is begin pragma Debug (O2 ("Parse_Const_Type: enter")); case Get_Token is when T_Long => if View_Next_Token = T_Double then Parse_Floating_Pt_Type (Result, Success); else Parse_Integer_Type (Result, Success); end if; when T_Short | T_Unsigned => Parse_Integer_Type (Result, Success); when T_Char => Parse_Char_Type (Result, Success); when T_Wchar => Parse_Wide_Char_Type (Result, Success); when T_Boolean => Parse_Boolean_Type (Result, Success); when T_Float | T_Double => Parse_Floating_Pt_Type (Result, Success); when T_String => Parse_String_Type (Result, Success); when T_Wstring => Parse_Wide_String_Type (Result, Success); when T_Fixed => Parse_Fixed_Pt_Type (Result, Success); when T_Colon_Colon | T_Identifier => Parse_Scoped_Name (Result, Success); -- The in the production -- must be a previously defined integer, char, wide_char, -- boolean, floating_pt, string, wide_string, octet -- or enum type. if not Success then Result := No_Node; pragma Debug (O2 ("Parse_Const_Type: end")); return; end if; if Result /= No_Node then declare Invalid_Type : Boolean := False; begin if S_Type (Result) /= No_Node then pragma Debug (O ("Parse_Const_Type : scoped name " & "found. Its type is " & Img (Kind (S_Type (Result))))); case Kind (S_Type (Result)) is when K_Short | K_Long | K_Long_Long | K_Unsigned_Short | K_Unsigned_Long | K_Unsigned_Long_Long | K_Char | K_Wide_Char | K_Boolean | K_Float | K_Double | K_Long_Double | K_String | K_Wide_String | K_Octet | K_Enum => null; when others => Invalid_Type := True; end case; else Invalid_Type := True; end if; if Invalid_Type then Idlac_Errors.Error ("Invalid type in constant. The " & "scoped name should refer to " & "an integer, char, wide_char, " & "boolean, floating_pt, string, " & "wide_string, octet or enum type.", Idlac_Errors.Error, Get_Token_Location); Success := False; end if; end; end if; when T_Octet => Parse_Octet_Type (Result, Success); when others => Idlac_Errors.Error ("constant type expected.", Idlac_Errors.Error, Get_Token_Location); Success := False; Result := No_Node; end case; pragma Debug (O2 ("Parse_Const_Type: end")); return; end Parse_Const_Type; ----------------------- -- Parse_Const_Exp -- ----------------------- procedure Parse_Const_Exp (Result : out Node_Id; Constant_Type : Node_Id; Success : out Boolean) is C_Type : Constant_Value_Ptr; begin pragma Debug (O2 ("Parse_Const_Exp: enter")); if Constant_Type /= No_Node then case Kind (Constant_Type) is when K_Short => C_Type := new Constant_Value (Kind => C_Short); when K_Unsigned_Short => C_Type := new Constant_Value (Kind => C_UShort); when K_Long => C_Type := new Constant_Value (Kind => C_Long); when K_Unsigned_Long => C_Type := new Constant_Value (Kind => C_ULong); when K_Long_Long => C_Type := new Constant_Value (Kind => C_LongLong); when K_Unsigned_Long_Long => C_Type := new Constant_Value (Kind => C_ULongLong); when K_Char => C_Type := new Constant_Value (Kind => C_Char); when K_Wide_Char => C_Type := new Constant_Value (Kind => C_WChar); when K_Boolean => C_Type := new Constant_Value (Kind => C_Boolean); when K_Float => C_Type := new Constant_Value (Kind => C_Float); when K_Double => C_Type := new Constant_Value (Kind => C_Double); when K_Long_Double => C_Type := new Constant_Value (Kind => C_LongDouble); when K_Fixed => -- FIXME : verify the values of digits_nb and scale C_Type := new Constant_Value (Kind => C_Fixed); C_Type.Digits_Nb := Expr_Value (Digits_Nb (Constant_Type)).Integer_Value; C_Type.Scale := Expr_Value (Scale (Constant_Type)).Integer_Value; when K_String => C_Type := new Constant_Value (Kind => C_String); if Bound (Constant_Type) = No_Node then C_Type.String_Length := -1; else C_Type.String_Length := Expr_Value (Bound (Constant_Type)).Integer_Value; end if; when K_Wide_String => C_Type := new Constant_Value (Kind => C_WString); if Bound (Constant_Type) = No_Node then C_Type.WString_Length := -1; else C_Type.WString_Length := Expr_Value (Bound (Constant_Type)).Integer_Value; end if; when K_Octet => C_Type := new Constant_Value (Kind => C_Octet); when K_Enum => C_Type := new Constant_Value (Kind => C_Enum); C_Type.Enum_Name := Constant_Type; when K_Scoped_Name => case Kind (S_Type (Constant_Type)) is when K_Short => C_Type := new Constant_Value (Kind => C_Short); when K_Unsigned_Short => C_Type := new Constant_Value (Kind => C_UShort); when K_Long => C_Type := new Constant_Value (Kind => C_Long); when K_Unsigned_Long => C_Type := new Constant_Value (Kind => C_ULong); when K_Long_Long => C_Type := new Constant_Value (Kind => C_LongLong); when K_Unsigned_Long_Long => C_Type := new Constant_Value (Kind => C_ULongLong); when K_Char => C_Type := new Constant_Value (Kind => C_Char); when K_Wide_Char => C_Type := new Constant_Value (Kind => C_WChar); when K_Boolean => C_Type := new Constant_Value (Kind => C_Boolean); when K_Float => C_Type := new Constant_Value (Kind => C_Float); when K_Double => C_Type := new Constant_Value (Kind => C_Double); when K_Long_Double => C_Type := new Constant_Value (Kind => C_LongDouble); when K_Fixed => -- FIXME : verify the values of digits_nb and scale C_Type := new Constant_Value (Kind => C_Fixed); C_Type.Digits_Nb := Expr_Value (Digits_Nb (S_Type (Constant_Type))) .Integer_Value; C_Type.Scale := Expr_Value (Scale (S_Type (Constant_Type))) .Integer_Value; when K_String => C_Type := new Constant_Value (Kind => C_String); if Bound (S_Type (Constant_Type)) = No_Node then C_Type.String_Length := -1; else C_Type.String_Length := Expr_Value (Bound (S_Type (Constant_Type))) .Integer_Value; end if; when K_Wide_String => C_Type := new Constant_Value (Kind => C_WString); if Bound (S_Type (Constant_Type)) = No_Node then C_Type.WString_Length := -1; else C_Type.WString_Length := Expr_Value (Bound (S_Type (Constant_Type))) .Integer_Value; end if; when K_Octet => C_Type := new Constant_Value (Kind => C_Octet); when K_Enum => C_Type := new Constant_Value (Kind => C_Enum); C_Type.Enum_Name := S_Type (Constant_Type); when others => raise Idlac_Errors.Internal_Error; end case; when others => raise Idlac_Errors.Internal_Error; end case; else C_Type := new Constant_Value (Kind => C_No_Kind); end if; Parse_Or_Expr (Result, Success, C_Type); if Result /= No_Node then Check_Value_Range (Result, True); end if; Free (C_Type); pragma Debug (O2 ("Parse_Const_Exp: end")); end Parse_Const_Exp; --------------------- -- Parse_Or_Expr -- --------------------- procedure Parse_Or_Expr (Result : out Node_Id; Success : out Boolean; Expr_Type : Constant_Value_Ptr) is begin pragma Debug (O2 ("Parse_Or_Expr: enter")); Parse_Xor_Expr (Result, Success, Expr_Type); if not Success then return; end if; while Get_Token = T_Bar loop declare Res : Node_Id; Res_Right : Node_Id; Loc : Idlac_Errors.Location; begin pragma Debug (O ("Parse_Or_Expr : '|' detected")); Loc := Get_Token_Location; Next_Token; pragma Debug (O ("Parse_Or_Expr : making the or node")); Res := Make_Or_Expr (Loc); pragma Debug (O ("Parse_Or_Expr : setting the first term")); Set_Left (Res, Result); pragma Debug (O ("Parse_Or_Expr : parsing of the second term")); Parse_Xor_Expr (Res_Right, Success, Expr_Type); if not Success or else Res_Right = No_Node then Set_Right (Res, No_Node); Set_Expr_Value (Res, new Constant_Value (Kind => C_No_Kind)); Result := Res; return; end if; Set_Right (Res, Res_Right); if Left (Res) = No_Node then Set_Expr_Value (Res, new Constant_Value (Kind => C_No_Kind)); Result := Res; return; end if; -- test if the types are ok for the or operation if Expr_Type.Kind = C_Octet or else Expr_Type.Kind = C_Short or else Expr_Type.Kind = C_Long or else Expr_Type.Kind = C_LongLong or else Expr_Type.Kind = C_UShort or else Expr_Type.Kind = C_ULong or else Expr_Type.Kind = C_ULongLong or else Expr_Type.Kind = C_General_Integer then -- test if both sons have a type if Expr_Value (Left (Res)).Kind /= C_No_Kind and then Expr_Value (Right (Res)).Kind /= C_No_Kind then if Expr_Value (Right (Res)).Kind /= C_General_Integer and then Expr_Value (Left (Res)).Kind /= C_General_Integer then Set_Expr_Value (Res, Duplicate (Expr_Type)); else Set_Expr_Value (Res, new Constant_Value (Kind => C_General_Integer)); end if; Expr_Value (Res).Integer_Value := Expr_Value (Left (Res)).Integer_Value or Expr_Value (Right (Res)).Integer_Value; Check_Value_Range (Res, False); else Set_Expr_Value (Res, new Constant_Value (Kind => C_No_Kind)); end if; else Idlac_Errors.Error ("The | operation is not defined " & "on this type.", Idlac_Errors.Error, Loc); Set_Expr_Value (Res, new Constant_Value (Kind => C_No_Kind)); end if; Result := Res; end; end loop; pragma Debug (O2 ("Parse_Or_Expr: end")); return; end Parse_Or_Expr; --------------------- -- Parse_Xor_Exp -- --------------------- procedure Parse_Xor_Expr (Result : out Node_Id; Success : out Boolean; Expr_Type : Constant_Value_Ptr) is begin pragma Debug (O2 ("Parse_Xor_Expr: enter")); Parse_And_Expr (Result, Success, Expr_Type); if not Success then return; end if; while Get_Token = T_Circumflex loop declare Res : Node_Id; Res_Right : Node_Id; Loc : Idlac_Errors.Location; begin Loc := Get_Token_Location; Next_Token; Res := Make_Xor_Expr (Loc); Set_Left (Res, Result); Parse_And_Expr (Res_Right, Success, Expr_Type); if not Success or else Res_Right = No_Node then Set_Right (Res, No_Node); Set_Expr_Value (Res, new Constant_Value (Kind => C_No_Kind)); Result := Res; return; end if; Set_Right (Res, Res_Right); if Left (Res) = No_Node then Set_Expr_Value (Res, new Constant_Value (Kind => C_No_Kind)); Result := Res; return; end if; -- test if the types are ok for the or operation if Expr_Type.Kind = C_Octet or else Expr_Type.Kind = C_Short or else Expr_Type.Kind = C_Long or else Expr_Type.Kind = C_LongLong or else Expr_Type.Kind = C_UShort or else Expr_Type.Kind = C_ULong or else Expr_Type.Kind = C_ULongLong or else Expr_Type.Kind = C_General_Integer then -- test if both sons have a type if Expr_Value (Left (Res)).Kind /= C_No_Kind and then Expr_Value (Right (Res)).Kind /= C_No_Kind then if Expr_Value (Right (Res)).Kind /= C_General_Integer and then Expr_Value (Left (Res)).Kind /= C_General_Integer then Set_Expr_Value (Res, Duplicate (Expr_Type)); else Set_Expr_Value (Res, new Constant_Value (Kind => C_General_Integer)); end if; Expr_Value (Res).Integer_Value := Expr_Value (Left (Res)).Integer_Value xor Expr_Value (Right (Res)).Integer_Value; Check_Value_Range (Res, False); else Set_Expr_Value (Res, new Constant_Value (Kind => C_No_Kind)); end if; else Idlac_Errors.Error ("The ^ operation is not defined " & "on this type.", Idlac_Errors.Error, Loc); Set_Expr_Value (Res, new Constant_Value (Kind => C_No_Kind)); end if; Result := Res; end; end loop; pragma Debug (O2 ("Parse_Xor_Expr: end")); return; end Parse_Xor_Expr; --------------------- -- Parse_And_Exp -- --------------------- procedure Parse_And_Expr (Result : out Node_Id; Success : out Boolean; Expr_Type : Constant_Value_Ptr) is begin pragma Debug (O2 ("Parse_And_Expr: enter")); Parse_Shift_Expr (Result, Success, Expr_Type); if not Success then return; end if; while Get_Token = T_Ampersand loop declare Res : Node_Id; Res_Right : Node_Id; Loc : Idlac_Errors.Location; begin Loc := Get_Token_Location; Next_Token; Res := Make_And_Expr (Loc); Set_Left (Res, Result); Parse_Shift_Expr (Res_Right, Success, Expr_Type); if not Success or else Res_Right = No_Node then Set_Right (Res, No_Node); Set_Expr_Value (Res, new Constant_Value (Kind => C_No_Kind)); Result := Res; return; end if; Set_Right (Res, Res_Right); if Left (Res) = No_Node then Set_Expr_Value (Res, new Constant_Value (Kind => C_No_Kind)); Result := Res; return; end if; -- test if the types are ok for the or operation if Expr_Type.Kind = C_Octet or else Expr_Type.Kind = C_Short or else Expr_Type.Kind = C_Long or else Expr_Type.Kind = C_LongLong or else Expr_Type.Kind = C_UShort or else Expr_Type.Kind = C_ULong or else Expr_Type.Kind = C_ULongLong or else Expr_Type.Kind = C_General_Integer then -- test if both sons have a type if Expr_Value (Left (Res)).Kind /= C_No_Kind and then Expr_Value (Right (Res)).Kind /= C_No_Kind then if Expr_Value (Right (Res)).Kind /= C_General_Integer and then Expr_Value (Left (Res)).Kind /= C_General_Integer then Set_Expr_Value (Res, Duplicate (Expr_Type)); else Set_Expr_Value (Res, new Constant_Value (Kind => C_General_Integer)); end if; Expr_Value (Res).Integer_Value := Expr_Value (Left (Res)).Integer_Value and Expr_Value (Right (Res)).Integer_Value; Check_Value_Range (Res, False); else Set_Expr_Value (Res, new Constant_Value (Kind => C_No_Kind)); end if; else Idlac_Errors.Error ("The & operation is not defined " & "on this type.", Idlac_Errors.Error, Loc); Set_Expr_Value (Res, new Constant_Value (Kind => C_No_Kind)); end if; Result := Res; end; end loop; pragma Debug (O2 ("Parse_And_Expr: end")); return; end Parse_And_Expr; ----------------------- -- Parse_Shift_Exp -- ----------------------- procedure Parse_Shift_Expr (Result : out Node_Id; Success : out Boolean; Expr_Type : Constant_Value_Ptr) is begin pragma Debug (O2 ("Parse_Shift_Expr: enter")); Parse_Add_Expr (Result, Success, Expr_Type); if not Success then return; end if; While_Loop : while Get_Token = T_Greater_Greater or else Get_Token = T_Less_Less loop declare Res : Node_Id; Res_Right : Node_Id; Loc : Idlac_Errors.Location; Shl : Boolean; begin -- if we have a t_greater_greater and no expression -- after it, it is likely to be a double sequence -- end, so we exit from the loop if Get_Token = T_Greater_Greater then case View_Next_Token is when T_Left_Paren | T_Plus | T_Minus | T_Tilde | T_Lit_Decimal_Integer | T_Lit_Octal_Integer | T_Lit_Hexa_Integer => null; when T_Identifier => -- FIXME : not always exit exit While_Loop; when T_Greater | T_Greater_Greater | T_Comma => exit While_Loop; when others => null; end case; end if; Loc := Get_Token_Location; Next_Token; if View_Previous_Token = T_Greater_Greater then Shl := False; Res := Make_Shr_Expr (Loc); else Shl := True; Res := Make_Shl_Expr (Loc); end if; Set_Left (Res, Result); Parse_Add_Expr (Res_Right, Success, Expr_Type); if not Success or else Res_Right = No_Node then Set_Right (Res, No_Node); Set_Expr_Value (Res, new Constant_Value (Kind => C_No_Kind)); Result := Res; return; end if; Set_Right (Res, Res_Right); if Left (Res) = No_Node then Set_Expr_Value (Res, new Constant_Value (Kind => C_No_Kind)); Result := Res; return; end if; -- test if the types are ok for the or operation if Expr_Type.Kind = C_Octet or else Expr_Type.Kind = C_Short or else Expr_Type.Kind = C_Long or else Expr_Type.Kind = C_LongLong or else Expr_Type.Kind = C_UShort or else Expr_Type.Kind = C_ULong or else Expr_Type.Kind = C_ULongLong or else Expr_Type.Kind = C_General_Integer then -- test if both sons have a type if Expr_Value (Left (Res)).Kind /= C_No_Kind and then Expr_Value (Right (Res)).Kind /= C_No_Kind then if Expr_Value (Right (Res)).Kind /= C_General_Integer and then Expr_Value (Left (Res)).Kind /= C_General_Integer then Set_Expr_Value (Res, Duplicate (Expr_Type)); else Set_Expr_Value (Res, new Constant_Value (Kind => C_General_Integer)); end if; -- check the value of the right operand if Expr_Value (Right (Res)).Integer_Value < 0 or else Expr_Value (Right (Res)).Integer_Value > 63 then if Expr_Value (Right (Res)).Integer_Value < 0 then Idlac_Errors.Error ("The right operand must be " & "positive. The shift operation " & "will be ignored.", Idlac_Errors.Error, Loc); Expr_Value (Res).Integer_Value := Expr_Value (Left (Res)).Integer_Value; else Idlac_Errors.Error ("The right operand must be " & "less than 64. The result will " & "be put to 0.", Idlac_Errors.Error, Loc); Expr_Value (Res).Integer_Value := 0; end if; else if Shl then Expr_Value (Res).Integer_Value := Shift_Left (Expr_Value (Left (Res)).Integer_Value, Natural (Expr_Value (Right (Res)).Integer_Value)); else Expr_Value (Res).Integer_Value := Shift_Right (Expr_Value (Left (Res)).Integer_Value, Natural (Expr_Value (Right (Res)).Integer_Value)); end if; end if; Check_Value_Range (Res, False); else Set_Expr_Value (Res, new Constant_Value (Kind => C_No_Kind)); end if; else Idlac_Errors.Error ("The << and >> operations are not " & "defined on this type.", Idlac_Errors.Error, Loc); Set_Expr_Value (Res, new Constant_Value (Kind => C_No_Kind)); end if; Result := Res; end; end loop While_Loop; pragma Debug (O2 ("Parse_Shift_Expr: end")); return; end Parse_Shift_Expr; --------------------- -- Parse_Add_Exp -- --------------------- procedure Parse_Add_Expr (Result : out Node_Id; Success : out Boolean; Expr_Type : Constant_Value_Ptr) is begin pragma Debug (O2 ("Parse_Add_Expr: enter")); Parse_Mult_Expr (Result, Success, Expr_Type); if not Success then return; end if; while Get_Token = T_Plus or else Get_Token = T_Minus loop declare Res : Node_Id; Res_Right : Node_Id; Loc : Idlac_Errors.Location; Plus : Boolean; begin Loc := Get_Token_Location; Next_Token; if View_Previous_Token = T_Plus then Plus := True; Res := Make_Add_Expr (Loc); else Plus := False; Res := Make_Sub_Expr (Loc); end if; Set_Left (Res, Result); Parse_Mult_Expr (Res_Right, Success, Expr_Type); if not Success or else Res_Right = No_Node then Set_Right (Res, No_Node); Set_Expr_Value (Res, new Constant_Value (Kind => C_No_Kind)); Result := Res; return; end if; Set_Right (Res, Res_Right); if Left (Res) = No_Node then Set_Expr_Value (Res, new Constant_Value (Kind => C_No_Kind)); Result := Res; return; end if; -- test if the types are ok for the or operation if Expr_Type.Kind = C_Octet or else Expr_Type.Kind = C_Short or else Expr_Type.Kind = C_Long or else Expr_Type.Kind = C_LongLong or else Expr_Type.Kind = C_UShort or else Expr_Type.Kind = C_ULong or else Expr_Type.Kind = C_ULongLong or else Expr_Type.Kind = C_General_Integer or else Expr_Type.Kind = C_Float or else Expr_Type.Kind = C_Double or else Expr_Type.Kind = C_LongDouble or else Expr_Type.Kind = C_General_Float or else Expr_Type.Kind = C_Fixed or else Expr_Type.Kind = C_General_Fixed then -- test if both sons have a type if Expr_Value (Left (Res)).Kind /= C_No_Kind and then Expr_Value (Right (Res)).Kind /= C_No_Kind then if Expr_Type.Kind = C_Octet or else Expr_Type.Kind = C_Short or else Expr_Type.Kind = C_Long or else Expr_Type.Kind = C_LongLong or else Expr_Type.Kind = C_UShort or else Expr_Type.Kind = C_ULong or else Expr_Type.Kind = C_ULongLong or else Expr_Type.Kind = C_General_Integer then if Expr_Value (Right (Res)).Kind /= C_General_Integer and then Expr_Value (Left (Res)).Kind /= C_General_Integer then Set_Expr_Value (Res, Duplicate (Expr_Type)); else Set_Expr_Value (Res, new Constant_Value (Kind => C_General_Integer)); end if; if Plus then Expr_Value (Res).Integer_Value := Expr_Value (Left (Res)).Integer_Value + Expr_Value (Right (Res)).Integer_Value; else Expr_Value (Res).Integer_Value := Expr_Value (Left (Res)).Integer_Value - Expr_Value (Right (Res)).Integer_Value; end if; elsif Expr_Type.Kind = C_Float or else Expr_Type.Kind = C_Double or else Expr_Type.Kind = C_LongDouble or else Expr_Type.Kind = C_General_Float then if Expr_Value (Right (Res)).Kind /= C_General_Float and then Expr_Value (Left (Res)).Kind /= C_General_Float then Set_Expr_Value (Res, Duplicate (Expr_Type)); else Set_Expr_Value (Res, new Constant_Value (Kind => C_General_Float)); end if; if Plus then Expr_Value (Res).Float_Value := Expr_Value (Left (Res)).Float_Value + Expr_Value (Right (Res)).Float_Value; else Expr_Value (Res).Float_Value := Expr_Value (Left (Res)).Float_Value - Expr_Value (Right (Res)).Float_Value; end if; else if Expr_Value (Right (Res)).Kind /= C_General_Fixed and then Expr_Value (Left (Res)).Kind /= C_General_Fixed then Set_Expr_Value (Res, Duplicate (Expr_Type)); else Set_Expr_Value (Res, new Constant_Value (Kind => C_General_Fixed)); Expr_Value (Res).Digits_Nb := Expr_Type.Digits_Nb; Expr_Value (Res).Scale := Expr_Type.Scale; end if; declare Res_Expr : constant Constant_Value_Ptr := Expr_Value (Res); begin if Plus then Fixed_Add (Res_Expr, Expr_Value (Left (Res)), Expr_Value (Right (Res))); else Fixed_Sub (Res_Expr, Expr_Value (Left (Res)), Expr_Value (Right (Res))); end if; Set_Expr_Value (Res, Res_Expr); end; end if; Check_Value_Range (Res, False); if Expr_Value (Res).Kind = C_Fixed and then Expr_Type.Kind = C_Fixed then -- checks precision of the fixed value after -- the possible simplifications in -- check_value_range if Expr_Value (Res).Digits_Nb - Expr_Value (Res).Scale > Expr_Type.Digits_Nb - Expr_Type.Scale or else Expr_Value (Res).Scale > Expr_Type.Scale then Idlac_Errors.Error ("The specified type for this fixed point " & "constant is not enough precise for its value. " & "A more precise type will be used.", Idlac_Errors.Error, Get_Token_Location); declare Value : Constant_Value_Ptr := Expr_Value (Res); begin Set_Expr_Value (Res, new Constant_Value (Kind => C_General_Fixed)); Expr_Value (Res).Fixed_Value := Value.Fixed_Value; Expr_Value (Res).Digits_Nb := Value.Digits_Nb; Expr_Value (Res).Scale := Value.Scale; Free (Value); end; end if; end if; else Set_Expr_Value (Res, new Constant_Value (Kind => C_No_Kind)); end if; else Idlac_Errors.Error ("The + and - operations are not defined " & "on this type.", Idlac_Errors.Error, Loc); Set_Expr_Value (Res, new Constant_Value (Kind => C_No_Kind)); end if; Result := Res; end; end loop; pragma Debug (O2 ("Parse_Add_Expr: end")); return; end Parse_Add_Expr; ---------------------- -- Parse_Mult_Exp -- ---------------------- procedure Parse_Mult_Expr (Result : out Node_Id; Success : out Boolean; Expr_Type : Constant_Value_Ptr) is begin pragma Debug (O2 ("Parse_Mult_Expr: enter")); Parse_Unary_Expr (Result, Success, Expr_Type); if not Success then return; end if; while Get_Token = T_Star or else Get_Token = T_Slash or else Get_Token = T_Percent loop declare Res : Node_Id; Res_Right : Node_Id; Loc : Idlac_Errors.Location; type Operator_Type is (Mul, Div, Modulo); Op : Operator_Type; begin Loc := Get_Token_Location; Next_Token; if View_Previous_Token = T_Star then Op := Mul; Res := Make_Mul_Expr (Loc); elsif View_Previous_Token = T_Slash then Op := Div; Res := Make_Div_Expr (Loc); else Op := Modulo; Res := Make_Mod_Expr (Loc); end if; Set_Left (Res, Result); Parse_Unary_Expr (Res_Right, Success, Expr_Type); if not Success or else Res_Right = No_Node then Set_Right (Res, No_Node); Set_Expr_Value (Res, new Constant_Value (Kind => C_No_Kind)); Result := Res; return; end if; Set_Right (Res, Res_Right); if Left (Res) = No_Node then Set_Expr_Value (Res, new Constant_Value (Kind => C_No_Kind)); Result := Res; return; end if; -- test if the types are ok for the or operation if Expr_Type.Kind = C_Octet or else Expr_Type.Kind = C_Short or else Expr_Type.Kind = C_Long or else Expr_Type.Kind = C_LongLong or else Expr_Type.Kind = C_UShort or else Expr_Type.Kind = C_ULong or else Expr_Type.Kind = C_ULongLong or else Expr_Type.Kind = C_General_Integer or else ((Expr_Type.Kind = C_Float or else Expr_Type.Kind = C_Double or else Expr_Type.Kind = C_LongDouble or else Expr_Type.Kind = C_General_Float or else Expr_Type.Kind = C_Fixed or else Expr_Type.Kind = C_General_Fixed) and then Op /= Modulo) then -- test if both sons have a type if Expr_Value (Left (Res)).Kind /= C_No_Kind and then Expr_Value (Right (Res)).Kind /= C_No_Kind then if Expr_Type.Kind = C_Octet or else Expr_Type.Kind = C_Short or else Expr_Type.Kind = C_Long or else Expr_Type.Kind = C_LongLong or else Expr_Type.Kind = C_UShort or else Expr_Type.Kind = C_ULong or else Expr_Type.Kind = C_ULongLong or else Expr_Type.Kind = C_General_Integer then if Expr_Value (Right (Res)).Kind /= C_General_Integer and then Expr_Value (Left (Res)).Kind /= C_General_Integer then Set_Expr_Value (Res, Duplicate (Expr_Type)); else Set_Expr_Value (Res, new Constant_Value (Kind => C_General_Integer)); end if; if Op = Mul then Expr_Value (Res).Integer_Value := Expr_Value (Left (Res)).Integer_Value * Expr_Value (Right (Res)).Integer_Value; elsif Op = Div then if Expr_Value (Right (Res)).Integer_Value = 0 then Idlac_Errors.Error ("The second operand of the division is 0. " & "The operation will be ignored.", Idlac_Errors.Error, Loc); Expr_Value (Res).Integer_Value := Expr_Value (Left (Res)).Integer_Value; else Expr_Value (Res).Integer_Value := Expr_Value (Left (Res)).Integer_Value / Expr_Value (Right (Res)).Integer_Value; end if; else if Expr_Value (Right (Res)).Integer_Value = 0 then Idlac_Errors.Error ("The second operand of the modulo is 0. " & "The modulo operation will be ignored.", Idlac_Errors.Error, Loc); Expr_Value (Res).Integer_Value := Expr_Value (Left (Res)).Integer_Value; else Expr_Value (Res).Integer_Value := Expr_Value (Left (Res)).Integer_Value mod Expr_Value (Right (Res)).Integer_Value; end if; end if; elsif Expr_Type.Kind = C_Float or else Expr_Type.Kind = C_Double or else Expr_Type.Kind = C_LongDouble or else Expr_Type.Kind = C_General_Float then if Expr_Value (Right (Res)).Kind /= C_General_Float and then Expr_Value (Left (Res)).Kind /= C_General_Float then Set_Expr_Value (Res, Duplicate (Expr_Type)); else Set_Expr_Value (Res, new Constant_Value (Kind => C_General_Float)); end if; if Op = Mul then Expr_Value (Res).Float_Value := Expr_Value (Left (Res)).Float_Value * Expr_Value (Right (Res)).Float_Value; else if Expr_Value (Right (Res)).Float_Value = 0.0 then Idlac_Errors.Error ("The second operand of the division is 0. " & "The operation will be ignored.", Idlac_Errors.Error, Loc); Expr_Value (Res).Float_Value := Expr_Value (Left (Res)).Float_Value; else Expr_Value (Res).Float_Value := Expr_Value (Left (Res)).Float_Value / Expr_Value (Right (Res)).Float_Value; end if; end if; else if Expr_Value (Right (Res)).Kind /= C_General_Fixed and then Expr_Value (Left (Res)).Kind /= C_General_Fixed then Set_Expr_Value (Res, Duplicate (Expr_Type)); else Set_Expr_Value (Res, new Constant_Value (Kind => C_General_Fixed)); Expr_Value (Res).Digits_Nb := Expr_Type.Digits_Nb; Expr_Value (Res).Scale := Expr_Type.Scale; end if; declare Res_Expr : constant Constant_Value_Ptr := Expr_Value (Res); begin if Op = Mul then Fixed_Mul (Res_Expr, Expr_Value (Left (Res)), Expr_Value (Right (Res))); else if Expr_Value (Right (Res)).Fixed_Value = 0 then Idlac_Errors.Error ("The second operand of the division is 0. " & "The operation will be ignored.", Idlac_Errors.Error, Loc); Expr_Value (Res).Fixed_Value := Expr_Value (Left (Res)).Fixed_Value; else Fixed_Div (Res_Expr, Expr_Value (Left (Res)), Expr_Value (Right (Res))); end if; end if; end; end if; Check_Value_Range (Res, False); if Expr_Value (Res).Kind = C_Fixed and then Expr_Type.Kind = C_Fixed then -- checks precision of the fixed value after -- the possible simplifications in -- check_value_range if Expr_Value (Res).Digits_Nb - Expr_Value (Res).Scale > Expr_Type.Digits_Nb - Expr_Type.Scale or else Expr_Value (Res).Scale > Expr_Type.Scale then Idlac_Errors.Error ("The specified type for this fixed point " & "constant is not enough precise for its value. " & "A more precise type will be used.", Idlac_Errors.Error, Get_Token_Location); declare Value : Constant_Value_Ptr := Expr_Value (Res); begin Set_Expr_Value (Res, new Constant_Value (Kind => C_General_Fixed)); Expr_Value (Res).Fixed_Value := Value.Fixed_Value; Expr_Value (Res).Digits_Nb := Value.Digits_Nb; Expr_Value (Res).Scale := Value.Scale; Free (Value); end; end if; end if; else Set_Expr_Value (Res, new Constant_Value (Kind => C_No_Kind)); end if; else if Op = Modulo then Idlac_Errors.Error ("The % operation is not defined " & "on this type.", Idlac_Errors.Error, Loc); else Idlac_Errors.Error ("The * and / operations are not " & "defined on this type.", Idlac_Errors.Error, Loc); end if; Set_Expr_Value (Res, new Constant_Value (Kind => C_No_Kind)); end if; Result := Res; end; end loop; pragma Debug (O2 ("Parse_Mult_Expr: end")); return; end Parse_Mult_Expr; ----------------------- -- Parse_Unary_Exp -- ----------------------- procedure Parse_Unary_Expr (Result : out Node_Id; Success : out Boolean; Expr_Type : Constant_Value_Ptr) is type Operator_Type is (Plus, Minus, Tilde); Op : Operator_Type; Loc : Idlac_Errors.Location; begin pragma Debug (O2 ("Parse_Unary_Expr: enter")); case Get_Token is when T_Plus | T_Minus | T_Tilde => Loc := Get_Token_Location; if Get_Token = T_Plus then Op := Plus; Result := Make_Id_Expr (Get_Token_Location); elsif Get_Token = T_Minus then Op := Minus; Result := Make_Neg_Expr (Get_Token_Location); else Op := Tilde; Result := Make_Not_Expr (Get_Token_Location); end if; Next_Token; declare Operand : Node_Id; begin Parse_Primary_Expr (Operand, Success, Expr_Type); if not Success or else Operand = No_Node then Set_Operand (Result, No_Node); Set_Expr_Value (Result, new Constant_Value (Kind => C_No_Kind)); pragma Debug (O2 ("Parse_Unary_Expr: end")); return; end if; Set_Operand (Result, Operand); end; -- test if the types are ok for the or operation if Expr_Type.Kind = C_Octet or else Expr_Type.Kind = C_Short or else Expr_Type.Kind = C_Long or else Expr_Type.Kind = C_LongLong or else Expr_Type.Kind = C_UShort or else Expr_Type.Kind = C_ULong or else Expr_Type.Kind = C_ULongLong or else Expr_Type.Kind = C_General_Integer or else ((Expr_Type.Kind = C_Float or else Expr_Type.Kind = C_Double or else Expr_Type.Kind = C_LongDouble or else Expr_Type.Kind = C_General_Float or else Expr_Type.Kind = C_Fixed or else Expr_Type.Kind = C_General_Fixed) and then Op /= Tilde) then -- Test whether the operand has a type if Expr_Value (Operand (Result)).Kind /= C_No_Kind then if Expr_Type.Kind = C_Octet or else Expr_Type.Kind = C_Short or else Expr_Type.Kind = C_Long or else Expr_Type.Kind = C_LongLong or else Expr_Type.Kind = C_UShort or else Expr_Type.Kind = C_ULong or else Expr_Type.Kind = C_ULongLong or else Expr_Type.Kind = C_General_Integer then if Expr_Value (Operand (Result)).Kind /= C_General_Integer then Set_Expr_Value (Result, Duplicate (Expr_Type)); else Set_Expr_Value (Result, new Constant_Value (Kind => C_General_Integer)); end if; if Op = Plus then Expr_Value (Result).Integer_Value := Expr_Value (Operand (Result)).Integer_Value; elsif Op = Minus then Expr_Value (Result).Integer_Value := -Expr_Value (Operand (Result)).Integer_Value; else Expr_Value (Result).Integer_Value := not Expr_Value (Operand (Result)).Integer_Value; end if; elsif Expr_Type.Kind = C_Float or else Expr_Type.Kind = C_Double or else Expr_Type.Kind = C_LongDouble or else Expr_Type.Kind = C_General_Float then if Expr_Value (Operand (Result)).Kind /= C_General_Float then Set_Expr_Value (Result, Duplicate (Expr_Type)); else Set_Expr_Value (Result, new Constant_Value (Kind => C_General_Float)); end if; if Op = Plus then Expr_Value (Result).Float_Value := Expr_Value (Operand (Result)).Float_Value; else Expr_Value (Result).Float_Value := -Expr_Value (Operand (Result)).Float_Value; end if; else if Expr_Value (Operand (Result)).Kind /= C_General_Fixed then Set_Expr_Value (Result, Duplicate (Expr_Type)); else Set_Expr_Value (Result, new Constant_Value (Kind => C_General_Fixed)); Expr_Value (Result).Digits_Nb := Expr_Type.Digits_Nb; Expr_Value (Result).Scale := Expr_Type.Scale; end if; declare Res_Expr : constant Constant_Value_Ptr := Expr_Value (Result); begin if Op = Plus then Fixed_Id (Res_Expr, Expr_Value (Operand (Result))); else Fixed_Neg (Res_Expr, Expr_Value (Operand (Result))); end if; Set_Expr_Value (Result, Res_Expr); end; end if; else Set_Expr_Value (Result, new Constant_Value (Kind => C_No_Kind)); end if; else if Op = Tilde then Idlac_Errors.Error ("The ~ operation is not defined " & "on this type.", Idlac_Errors.Error, Loc); else Idlac_Errors.Error ("The unary + and - operations are " & "not defined on this type.", Idlac_Errors.Error, Loc); end if; Set_Expr_Value (Result, new Constant_Value (Kind => C_No_Kind)); end if; Check_Value_Range (Result, False); when others => Parse_Primary_Expr (Result, Success, Expr_Type); end case; pragma Debug (O2 ("Parse_Unary_Expr: end")); return; end Parse_Unary_Expr; ------------------------- -- Parse_Primary_Exp -- ------------------------- procedure Parse_Primary_Expr (Result : out Node_Id; Success : out Boolean; Expr_Type : Constant_Value_Ptr) is begin pragma Debug (O2 ("Parse_Primary_Expr: enter")); case Get_Token is when T_Colon_Colon | T_Identifier => declare Local_Res : Node_Id; begin Parse_Scoped_Name (Local_Res, Success); if Success then -- this scoped name must denote a previously -- defined constant or enum value if Local_Res /= No_Node then -- If it is a constant, check its type and -- duplicate its value if Kind (Value (Local_Res)) = K_Const_Dcl then Check_Expr_Value (Expr_Value (Expression (Value (Local_Res))), Expr_Type); Result := Expression (Value (Local_Res)); elsif Kind (Value (Local_Res)) = K_Enumerator then -- If it is an enum value, check the specified type Result := Make_Lit_Enum (Get_Token_Location); if Expr_Type.Kind = C_Enum then -- checks that the value is of the right type pragma Debug (O ("Parse_Primary_Expr : Kind " & "(Expr_Type.Enum_Name) is " & Node_Kind'Image (Kind (Expr_Type.Enum_Name)))); if not Is_In_List (Enumerators (Expr_Type.Enum_Name), Value (Local_Res)) then Idlac_Errors.Error ("The specified type for this constant " & "does not match with its value.", Idlac_Errors.Error, Get_Token_Location); Set_Expr_Value (Result, new Constant_Value (Kind => C_No_Kind)); else Set_Expr_Value (Result, new Constant_Value (Kind => C_Enum)); Expr_Value (Result).Enum_Name := Expr_Type.Enum_Name; Expr_Value (Result).Enum_Value := Value (Local_Res); end if; else Set_Expr_Value (Result, new Constant_Value (Kind => C_No_Kind)); Idlac_Errors.Error ("The specified type for this constant " & "does not match with its value.", Idlac_Errors.Error, Get_Token_Location); end if; else -- If no constant and no enum value, error Idlac_Errors.Error ("This scoped name must denote a constant value", Idlac_Errors.Error, Get_Token_Location); Result := No_Node; end if; else Result := No_Node; end if; else Result := No_Node; end if; end; when T_Lit_Decimal_Integer | T_Lit_Octal_Integer | T_Lit_Hexa_Integer | T_Lit_String | T_Lit_Wide_String | T_Lit_Char | T_Lit_Wide_Char | T_Lit_Simple_Floating_Point | T_Lit_Exponent_Floating_Point | T_Lit_Pure_Exponent_Floating_Point | T_Lit_Simple_Fixed_Point | T_Lit_Floating_Fixed_Point | T_True | T_False => Parse_Literal (Result, Success, Expr_Type); when T_Left_Paren => Next_Token; Parse_Or_Expr (Result, Success, Expr_Type); if not Success then pragma Debug (O2 ("Parse_Primary_Expr: end")); return; end if; if Get_Token /= T_Right_Paren then Idlac_Errors.Error ("')' expected at the end of ." & "a constant expression.", Idlac_Errors.Error, Get_Token_Location); Success := False; pragma Debug (O2 ("Parse_Primary_Expr: end")); return; end if; Next_Token; when others => Idlac_Errors.Error ("primary expression expected.", Idlac_Errors.Error, Get_Token_Location); Result := No_Node; Success := False; pragma Debug (O2 ("Parse_Primary_Expr: end")); return; end case; pragma Debug (O2 ("Parse_Primary_Expr: end")); return; end Parse_Primary_Expr; --------------------- -- Parse_Literal -- --------------------- procedure Parse_Literal (Result : out Node_Id; Success : out Boolean; Expr_Type : Constant_Value_Ptr) is begin pragma Debug (O2 ("Parse_Literal: enter")); case Get_Token is when T_Lit_Decimal_Integer | T_Lit_Octal_Integer | T_Lit_Hexa_Integer => pragma Debug (O ("Parse_Literal : literal is an integer")); declare Res : Node_Id; begin Parse_Integer_Literal (Res, Success, Expr_Type); Result := Res; end; when T_Lit_String => pragma Debug (O ("Parse_Literal : literal is a string")); declare Res : Node_Id; begin Parse_String_Literal (Res, Success, Expr_Type); Result := Res; end; when T_Lit_Wide_String => pragma Debug (O ("Parse_Literal : literal is a wide string")); declare Res : Node_Id; begin Parse_Wide_String_Literal (Res, Success, Expr_Type); Result := Res; end; when T_Lit_Char => declare Res : Node_Id; begin Parse_Char_Literal (Res, Success, Expr_Type); Result := Res; end; when T_Lit_Wide_Char => declare Res : Node_Id; begin Parse_Wide_Char_Literal (Res, Success, Expr_Type); Result := Res; end; when T_Lit_Simple_Floating_Point | T_Lit_Exponent_Floating_Point | T_Lit_Pure_Exponent_Floating_Point => declare Res : Node_Id; begin Parse_Floating_Pt_Literal (Res, Success, Expr_Type); Result := Res; end; when T_Lit_Simple_Fixed_Point | T_Lit_Floating_Fixed_Point => declare Res : Node_Id; begin Parse_Fixed_Pt_Literal (Res, Success, Expr_Type); Result := Res; end; when T_True | T_False => declare Res : Node_Id; begin Parse_Boolean_Literal (Res, Success, Expr_Type); Result := Res; end; when others => raise Idlac_Errors.Internal_Error; end case; pragma Debug (O2 ("Parse_Literal: end")); end Parse_Literal; ----------------------------- -- Parse_Boolean_Literal -- ----------------------------- procedure Parse_Boolean_Literal (Result : out Node_Id; Success : out Boolean; Expr_Type : Constant_Value_Ptr) is begin Result := Make_Lit_Boolean (Get_Token_Location); if Expr_Type.Kind = C_Boolean then if Get_Token = T_True then Set_Expr_Value (Result, new Constant_Value (Kind => C_Boolean)); Expr_Value (Result).Boolean_Value := True; else Set_Expr_Value (Result, new Constant_Value (Kind => C_Boolean)); Expr_Value (Result).Boolean_Value := False; end if; else Set_Expr_Value (Result, new Constant_Value (Kind => C_No_Kind)); Idlac_Errors.Error ("The specified type for this constant " & "does not match with its value.", Idlac_Errors.Error, Get_Token_Location); end if; Next_Token; Success := True; return; end Parse_Boolean_Literal; ------------------------------ -- Parse_Positive_Int_Const -- ------------------------------ procedure Parse_Positive_Int_Const (Result : out Node_Id; Success : out Boolean) is C_Type : Constant_Value_Ptr := new Constant_Value (Kind => C_General_Integer); begin -- We cannot call Parse_Const_Exp directly, since we do -- not have a node specifying the type of the constant, -- so we call Parse_Or_Expr, and then check the result -- against the unsigned type bounds. Parse_Or_Expr (Result, Success, C_Type); if Success and then Expr_Value (Result).Integer_Value not in Idl_ULongLong_Min .. Idl_ULongLong_Max then Idlac_Errors.Error ("The specified type for this integer constant " & "does not allow this value", Idlac_Errors.Error, Get_Token_Location); end if; Free (C_Type); end Parse_Positive_Int_Const; -------------------- -- Parse_Type_Dcl -- -------------------- procedure Parse_Type_Dcl (Result : out Node_Id; Success : out Boolean) is begin pragma Debug (O2 ("Parse_Type_Dcl: enter")); Result := No_Node; Success := False; case Get_Token is when T_Typedef => Next_Token; declare Res : Node_Id; begin Parse_Type_Declarator (Res, Success); Result := Res; end; when T_Struct => declare Res : Node_Id; begin Parse_Struct_Type (Res, Success); Result := Res; end; when T_Union => declare Res : Node_Id; begin Parse_Union_Type (Res, Success); Result := Res; end; when T_Enum => declare Res : Node_Id; begin Parse_Enum_Type (Res, Success); Result := Res; end; when T_Native => declare Res : Node_Id; begin Res := Make_Native (Get_Token_Location); Next_Token; declare Node : Node_Id; begin Node := Declarator (Res); Parse_Simple_Declarator (Node, Res, Success); Set_Declarator (Res, Node); end; if not Success then Result := No_Node; return; end if; Result := Res; end; when others => raise Idlac_Errors.Internal_Error; end case; pragma Debug (O2 ("Parse_Type_Dcl: end")); return; end Parse_Type_Dcl; --------------------------- -- Parse_Type_Declarator -- --------------------------- procedure Parse_Type_Declarator (Result : out Node_Id; Success : out Boolean) is begin pragma Debug (O2 ("Parse_Type_declarator: enter")); Result := Make_Type_Declarator (Get_Token_Location); declare Node : Node_Id; begin Node := T_Type (Result); Parse_Type_Spec (Node, Success); Set_T_Type (Result, Node); end; if not Success then pragma Debug (O ("Parse_Type_Declarator: type_spec return false")); pragma Debug (O2 ("Parse_Type_declarator: end")); return; end if; declare Node : Node_List; begin Node := Declarators (Result); Parse_Declarators (Node, Result, Success); Set_Declarators (Result, Node); end; pragma Debug (O2 ("Parse_Type_declarator: end")); return; end Parse_Type_Declarator; --------------------- -- Parse_Type_Spec -- --------------------- procedure Parse_Type_Spec (Result : out Node_Id; Success : out Boolean) is begin pragma Debug (O2 ("Parse_Type_Spec: enter")); case Get_Token is when T_Float | T_Double | T_Long | T_Short | T_Unsigned | T_Char | T_Wchar | T_Boolean | T_Octet | T_Any | T_Object | T_ValueBase | T_Sequence | T_String | T_Wstring | T_Fixed | T_Colon_Colon | T_Identifier => Parse_Simple_Type_Spec (Result, Success); when T_Enum | T_Struct | T_Union => Parse_Constr_Type_Spec (Result, Success); when others => Idlac_Errors.Error ("type specification expected.", Idlac_Errors.Error, Get_Token_Location); Success := False; Result := No_Node; end case; pragma Debug (O2 ("Parse_Type_Spec: end")); return; end Parse_Type_Spec; ---------------------------- -- Parse_Simple_Type_Spec -- ---------------------------- procedure Parse_Simple_Type_Spec (Result : out Node_Id; Success : out Boolean) is begin pragma Debug (O2 ("Parse_Simple_Type_Spec: enter")); pragma Debug (O ("Parse_Simple_Type_Spec: token is " & Idl_Token'Image (Get_Token))); case Get_Token is when T_Float | T_Double | T_Long | T_Short | T_Unsigned | T_Char | T_Wchar | T_Boolean | T_Octet | T_Any | T_Object | T_ValueBase => Parse_Base_Type_Spec (Result, Success); when T_Sequence | T_String | T_Wstring | T_Fixed => Parse_Template_Type_Spec (Result, Success); when T_Colon_Colon | T_Identifier => Parse_Scoped_Name (Result, Success); if not Success then Result := No_Node; end if; if Result /= No_Node then declare Not_A_Type : Boolean := False; begin -- Check that the scoped name denotes a type pragma Debug (O ("Parse_Simple_Type_Spec: " & "kind of result is " & Img (Kind (Result)))); if S_Type (Result) /= No_Node then pragma Debug (O ("Parse_Simple_Type_Spec: " & "scoped name without an S_Type")); case Kind (S_Type (Result)) is when K_Float | K_Double | K_Long_Double | K_Long | K_Long_Long | K_Short | K_Unsigned_Long | K_Unsigned_Long_Long | K_Unsigned_Short | K_Char | K_Wide_Char | K_Boolean | K_Octet | K_Any | K_Object | K_ValueBase | K_Sequence | K_String | K_Wide_String | K_Fixed | K_Enum | K_Struct | K_Union | K_Declarator | K_Interface | K_Forward_Interface | K_ValueType | K_Boxed_ValueType | K_Forward_ValueType => null; when others => Not_A_Type := True; end case; else Not_A_Type := True; end if; if Not_A_Type then Idlac_Errors.Error ("This scoped name does not denote an " & "acceptable type for a Simple_Type_Spec.", Idlac_Errors.Error, Get_Token_Location); end if; end; end if; when T_Enum | T_Struct | T_Union => Idlac_Errors.Error ("simple type specification " & "expected. No constructed " & "type allowed here.", Idlac_Errors.Error, Get_Token_Location); Parse_Constr_Type_Spec (Result, Success); when others => Idlac_Errors.Error ("simple type specification expected.", Idlac_Errors.Error, Get_Token_Location); Result := No_Node; Success := False; end case; pragma Debug (O2 ("Parse_Simple_Type_Spec: end")); return; end Parse_Simple_Type_Spec; -------------------------- -- Parse_Base_Type_Spec -- -------------------------- procedure Parse_Base_Type_Spec (Result : out Node_Id; Success : out Boolean) is begin pragma Debug (O2 ("Parse_Base_Type_Spec: enter")); case Get_Token is when T_Float | T_Double => Parse_Floating_Pt_Type (Result, Success); when T_Long => if View_Next_Token = T_Double then Parse_Floating_Pt_Type (Result, Success); else Parse_Integer_Type (Result, Success); end if; when T_Short | T_Unsigned => Parse_Integer_Type (Result, Success); when T_Char => declare Res : Node_Id; begin Parse_Char_Type (Res, Success); Result := Res; end; when T_Wchar => declare Res : Node_Id; begin Parse_Wide_Char_Type (Res, Success); Result := Res; end; when T_Boolean => declare Res : Node_Id; begin Parse_Boolean_Type (Res, Success); Result := Res; end; when T_Octet => declare Res : Node_Id; begin Parse_Octet_Type (Res, Success); Result := Res; end; when T_Any => declare Res : Node_Id; begin Parse_Any_Type (Res, Success); Result := Res; end; when T_Object => declare Res : Node_Id; begin Parse_Object_Type (Res, Success); Result := Res; end; when T_ValueBase => declare Res : Node_Id; begin Parse_Value_Base_Type (Res, Success); Result := Res; end; when others => raise Idlac_Errors.Internal_Error; end case; pragma Debug (O2 ("Parse_Base_Type_Spec: end")); return; end Parse_Base_Type_Spec; ------------------------------ -- Parse_Template_Type_Spec -- ------------------------------ procedure Parse_Template_Type_Spec (Result : out Node_Id; Success : out Boolean) is begin case Get_Token is when T_Sequence => declare Res : Node_Id; begin Parse_Sequence_Type (Res, Success); Result := Res; end; when T_String => declare Res : Node_Id; begin Parse_String_Type (Res, Success); Result := Res; end; when T_Wstring => declare Res : Node_Id; begin Parse_Wide_String_Type (Res, Success); Result := Res; end; when T_Fixed => declare Res : Node_Id; begin Parse_Fixed_Pt_Type (Res, Success); Result := Res; end; when others => raise Idlac_Errors.Internal_Error; end case; end Parse_Template_Type_Spec; ---------------------------- -- Parse_Constr_Type_Spec -- ---------------------------- procedure Parse_Constr_Type_Spec (Result : out Node_Id; Success : out Boolean) is begin case Get_Token is when T_Struct => declare Res : Node_Id; begin Parse_Struct_Type (Res, Success); Result := Res; end; when T_Union => declare Res : Node_Id; begin Parse_Union_Type (Res, Success); Result := Res; end; when T_Enum => declare Res : Node_Id; begin Parse_Enum_Type (Res, Success); Result := Res; end; when others => raise Idlac_Errors.Internal_Error; end case; end Parse_Constr_Type_Spec; ----------------------- -- Parse_Declarators -- ----------------------- procedure Parse_Declarators (Result : out Node_List; Parent : Node_Id; Success : out Boolean) is begin Result := Nil_List; declare Res : Node_Id; begin Parse_Declarator (Res, Parent, Success); if not Success then pragma Debug (O ("Parse_Declarators : first success = false")); return; else Append_Node (Result, Res); end if; end; while Get_Token = T_Comma loop Next_Token; declare Res : Node_Id; begin Parse_Declarator (Res, Parent, Success); if not Success then return; else Append_Node (Result, Res); end if; end; end loop; return; end Parse_Declarators; ------------------------ -- Parse_Declarator -- ------------------------ procedure Parse_Declarator (Result : out Node_Id; Parent : Node_Id; Success : out Boolean) is begin pragma Debug (O2 ("parse_declarator: enter")); if Get_Token /= T_Identifier then Idlac_Errors.Error ("Identifier expected in declarator.", Idlac_Errors.Error, Get_Token_Location); Success := False; Result := No_Node; return; else if View_Next_Token = T_Left_Sbracket then pragma Debug (O ("Parse_Declarator : Array")); Parse_Complex_Declarator (Result, Parent, Success); else pragma Debug (O ("Parse_Declarator : Simple")); Parse_Simple_Declarator (Result, Parent, Success); end if; end if; pragma Debug (O2 ("parse_declarator: end")); return; end Parse_Declarator; ------------------------------- -- Parse_Simple_Declarator -- ------------------------------- procedure Parse_Simple_Declarator (Result : out Node_Id; Parent : Node_Id; Success : out Boolean) is begin if Get_Token /= T_Identifier then Idlac_Errors.Error ("Identifier expected in simple declarator.", Idlac_Errors.Error, Get_Token_Location); Success := False; return; else pragma Debug (O ("Parse_Simple_Declarator : the scope is " & Img (Kind (Get_Current_Scope)))); -- Is there a previous definition if not Is_Redefinable (Get_Token_String, Get_Lexer_Location) then declare Definition : constant Identifier_Definition_Acc := Find_Identifier_Definition (Get_Token_String, Get_Lexer_Location); begin Idlac_Errors.Error ("This identifier is already defined in this scope : " & Idlac_Errors.Location_To_String (Get_Location (Definition.Node)), Idlac_Errors.Error, Get_Token_Location); end; end if; Result := Make_Declarator (Get_Token_Location); -- no previous definition if Add_Identifier (Result, Get_Token_String) then Set_Default_Repository_Id (Result); end if; Set_Array_Bounds (Result, Nil_List); Set_Parent (Result, Parent); end if; Success := True; Next_Token; return; end Parse_Simple_Declarator; -------------------------------- -- Parse_Complex_Declarator -- -------------------------------- procedure Parse_Complex_Declarator (Result : out Node_Id; Parent : Node_Id; Success : out Boolean) renames Parse_Array_Declarator; ------------------------------ -- Parse_Floating_Pt_Type -- ------------------------------ procedure Parse_Floating_Pt_Type (Result : out Node_Id; Success : out Boolean) is begin case Get_Token is when T_Float => Next_Token; Result := Make_Float (Get_Token_Location); when T_Double => Next_Token; Result := Make_Double (Get_Token_Location); when T_Long => Next_Token; Next_Token; Result := Make_Long_Double (Get_Token_Location); when others => raise Idlac_Errors.Internal_Error; end case; Success := True; return; end Parse_Floating_Pt_Type; -------------------------- -- Parse_Integer_Type -- -------------------------- procedure Parse_Integer_Type (Result : out Node_Id; Success : out Boolean) is begin case Get_Token is when T_Long | T_Short => Parse_Signed_Int (Result, Success); when T_Unsigned => Parse_Unsigned_Int (Result, Success); when others => raise Idlac_Errors.Internal_Error; end case; end Parse_Integer_Type; ------------------------ -- Parse_Signed_Int -- ------------------------ procedure Parse_Signed_Int (Result : out Node_Id; Success : out Boolean) is begin case Get_Token is when T_Long => if View_Next_Token = T_Long then Parse_Signed_Longlong_Int (Result, Success); else Parse_Signed_Long_Int (Result, Success); end if; when T_Short => Parse_Signed_Short_Int (Result, Success); when others => raise Idlac_Errors.Internal_Error; end case; end Parse_Signed_Int; ------------------------------ -- Parse_Signed_Short_Int -- ------------------------------ procedure Parse_Signed_Short_Int (Result : out Node_Id; Success : out Boolean) is begin Next_Token; Result := Make_Short (Get_Token_Location); Success := True; end Parse_Signed_Short_Int; ----------------------------- -- Parse_Signed_Long_Int -- ----------------------------- procedure Parse_Signed_Long_Int (Result : out Node_Id; Success : out Boolean) is begin Next_Token; Result := Make_Long (Get_Token_Location); Success := True; end Parse_Signed_Long_Int; --------------------------------- -- Parse_Signed_Longlong_Int -- --------------------------------- procedure Parse_Signed_Longlong_Int (Result : out Node_Id; Success : out Boolean) is begin Next_Token; Next_Token; Result := Make_Long_Long (Get_Token_Location); Success := True; end Parse_Signed_Longlong_Int; -------------------------- -- Parse_Unsigned_Int -- -------------------------- procedure Parse_Unsigned_Int (Result : out Node_Id; Success : out Boolean) is begin case View_Next_Token is when T_Long => if View_Next_Next_Token = T_Long then Parse_Unsigned_Longlong_Int (Result, Success); else Parse_Unsigned_Long_Int (Result, Success); end if; when T_Short => Parse_Unsigned_Short_Int (Result, Success); when others => declare Loc : Idlac_Errors.Location; begin Loc := Get_Previous_Token_Location; Loc.Col := Loc.Col + 9; Idlac_Errors.Error (Ada.Characters.Latin_1.Quotation & "short" & Ada.Characters.Latin_1.Quotation & " or " & Ada.Characters.Latin_1.Quotation & "long" & Ada.Characters.Latin_1.Quotation & " expected after unsigned.", Idlac_Errors.Error, Loc); Success := False; Result := No_Node; return; end; end case; end Parse_Unsigned_Int; -------------------------------- -- Parse_Unsigned_Short_Int -- -------------------------------- procedure Parse_Unsigned_Short_Int (Result : out Node_Id; Success : out Boolean) is begin Next_Token; Next_Token; Result := Make_Unsigned_Short (Get_Token_Location); Success := True; end Parse_Unsigned_Short_Int; ------------------------------- -- Parse_Unsigned_Long_Int -- ------------------------------- procedure Parse_Unsigned_Long_Int (Result : out Node_Id; Success : out Boolean) is begin Next_Token; Next_Token; Result := Make_Unsigned_Long (Get_Token_Location); Success := True; end Parse_Unsigned_Long_Int; ----------------------------------- -- Parse_Unsigned_Longlong_Int -- ----------------------------------- procedure Parse_Unsigned_Longlong_Int (Result : out Node_Id; Success : out Boolean) is begin Next_Token; Next_Token; Next_Token; Result := Make_Unsigned_Long_Long (Get_Token_Location); Success := True; end Parse_Unsigned_Longlong_Int; ----------------------- -- Parse_Char_Type -- ----------------------- procedure Parse_Char_Type (Result : out Node_Id; Success : out Boolean) is begin Next_Token; Result := Make_Char (Get_Token_Location); Success := True; end Parse_Char_Type; ---------------------------- -- Parse_Wide_Char_Type -- ---------------------------- procedure Parse_Wide_Char_Type (Result : out Node_Id; Success : out Boolean) is begin Next_Token; Result := Make_Wide_Char (Get_Token_Location); Success := True; end Parse_Wide_Char_Type; -------------------------- -- Parse_Boolean_Type -- -------------------------- procedure Parse_Boolean_Type (Result : out Node_Id; Success : out Boolean) is begin Next_Token; Result := Make_Boolean (Get_Token_Location); Success := True; end Parse_Boolean_Type; ------------------------ -- Parse_Octet_Type -- ------------------------ procedure Parse_Octet_Type (Result : out Node_Id; Success : out Boolean) is begin Next_Token; Result := Make_Octet (Get_Token_Location); Success := True; end Parse_Octet_Type; ---------------------- -- Parse_Any_Type -- ---------------------- procedure Parse_Any_Type (Result : out Node_Id; Success : out Boolean) is begin Next_Token; Result := Make_Any (Get_Token_Location); Success := True; end Parse_Any_Type; ------------------------- -- Parse_Object_Type -- ------------------------- procedure Parse_Object_Type (Result : out Node_Id; Success : out Boolean) is begin Result := Make_Object (Get_Token_Location); Success := True; Next_Token; return; end Parse_Object_Type; ------------------------- -- Parse_Struct_Type -- ------------------------- procedure Parse_Struct_Type (Result : out Node_Id; Success : out Boolean) is begin pragma Debug (O2 ("Parse_Struct_Type: enter")); Next_Token; if Get_Token /= T_Identifier then declare Loc : Idlac_Errors.Location; begin Loc := Get_Previous_Token_Location; Loc.Col := Loc.Col + 7; Idlac_Errors.Error ("identifier expected in struct declaration.", Idlac_Errors.Error, Loc); Result := No_Node; Success := False; return; end; end if; -- Is there a previous definition if not Is_Redefinable (Get_Token_String, Get_Lexer_Location) then declare Definition : constant Identifier_Definition_Acc := Find_Identifier_Definition (Get_Token_String, Get_Lexer_Location); begin Idlac_Errors.Error ("This identifier is already defined in this scope : " & Idlac_Errors.Location_To_String (Get_Location (Definition.Node)), Idlac_Errors.Error, Get_Token_Location); end; end if; Result := Make_Struct (Get_Token_Location); Set_Is_Exception_Members (Result, False); if Add_Identifier (Result, Get_Token_String) then Set_Default_Repository_Id (Result); Set_Initial_Current_Prefix (Result); end if; Next_Token; if Get_Token /= T_Left_Cbracket then declare Loc : Idlac_Errors.Location; begin Loc := Get_Previous_Token_Location; Loc.Col := Loc.Col + Get_Previous_Token_String'Length; Idlac_Errors.Error ("'{' expected in struct definition.", Idlac_Errors.Error, Loc); Success := False; return; end; end if; Next_Token; Push_Scope (Result); declare Node : Node_List; begin Node := Members (Result); Parse_Member_List (Node, Success); Set_Members (Result, Node); end; Pop_Scope; if not Success then return; end if; if Get_Token /= T_Right_Cbracket then Idlac_Errors.Error ("'}' expected at the end of struct definition.", Idlac_Errors.Error, Get_Token_Location); Success := False; return; end if; Next_Token; pragma Debug (O2 ("Parse_Struct_Type: end")); return; end Parse_Struct_Type; ------------------------- -- Parse_Member_List -- ------------------------- procedure Parse_Member_List (Result : out Node_List; Success : out Boolean) is Empty : Boolean := True; begin pragma Debug (O2 ("Parse_Member_List: enter")); Result := Nil_List; loop declare Member : Node_Id; Member_Success : Boolean; begin Parse_Member (Member, Member_Success); if not Member_Success then Go_To_Next_Member; else if Kind (Member) /= K_Pragma then Empty := False; end if; Append_Node (Result, Member); end if; end; exit when Get_Token = T_Right_Cbracket or else Get_Token = T_Eof; end loop; if Empty then Idlac_Errors.Error ("member expected : a struct may not be empty.", Idlac_Errors.Error, Get_Token_Location); end if; Success := True; pragma Debug (O2 ("Parse_Member_List: end")); return; end Parse_Member_List; -------------------- -- Parse_Member -- -------------------- procedure Parse_Member (Result : out Node_Id; Success : out Boolean) is Type_Spec : Node_Id; Loc : Idlac_Errors.Location; begin pragma Debug (O2 ("Parse_Member: enter")); if Get_Token = T_Pragma then Parse_Pragma (Result, Success); if not Success then -- here the pragma is ignored and no node created -- so we parse the next member (if it exists) Parse_Member (Result, Success); end if; return; end if; if Get_Token = T_Right_Cbracket then -- here, two situation possible : -- either we just parsed a pragma but it was the last member of the -- struct or the struct is empty. -- In both case, we return without creating a node Success := False; Result := No_Node; return; end if; Loc := Get_Token_Location; Parse_Type_Spec (Type_Spec, Success); if not Success then return; end if; Result := Make_Member (Loc); Set_M_Type (Result, Type_Spec); declare Node : Node_List; begin Node := Decl (Result); Parse_Declarators (Node, Result, Success); Set_Decl (Result, Node); end; if not Success then return; end if; if Get_Token /= T_Semi_Colon then Idlac_Errors.Error ("';' expected at the end of member declaration.", Idlac_Errors.Error, Get_Token_Location); Success := False; return; end if; -- to eat the semi-colon Next_Token; pragma Debug (O2 ("Parse_Member: end")); return; end Parse_Member; ------------------------ -- Parse_Union_Type -- ------------------------ procedure Parse_Union_Type (Result : out Node_Id; Success : out Boolean) is begin pragma Debug (O2 ("Parse_Union_Type: enter")); Next_Token; if Get_Token /= T_Identifier then declare Loc : Idlac_Errors.Location; begin Loc := Get_Previous_Token_Location; Loc.Col := Loc.Col + 6; Idlac_Errors.Error ("identifier expected in union definition.", Idlac_Errors.Error, Loc); Result := No_Node; Success := False; return; end; end if; -- Is there a previous definition if not Is_Redefinable (Get_Token_String, Get_Lexer_Location) then declare Definition : constant Identifier_Definition_Acc := Find_Identifier_Definition (Get_Token_String, Get_Lexer_Location); begin Idlac_Errors.Error ("This identifier is already defined in this scope : " & Idlac_Errors.Location_To_String (Get_Location (Definition.Node)), Idlac_Errors.Error, Get_Token_Location); end; end if; Result := Make_Union (Get_Token_Location); if not Add_Identifier (Result, Get_Token_String) then -- the error was raised before Success := False; else Set_Default_Repository_Id (Result); Set_Initial_Current_Prefix (Result); end if; Next_Token; if Get_Token /= T_Switch then declare Loc : Idlac_Errors.Location; begin Loc := Get_Previous_Token_Location; Loc.Col := Loc.Col + Get_Previous_Token_String'Length; Idlac_Errors.Error ("switch expected in union definition.", Idlac_Errors.Error, Loc); Result := No_Node; Success := False; return; end; end if; Next_Token; if Get_Token /= T_Left_Paren then declare Loc : Idlac_Errors.Location; begin Loc := Get_Previous_Token_Location; Loc.Col := Loc.Col + 2; Idlac_Errors.Error ("'(' expected after " & Ada.Characters.Latin_1.Quotation & "switch" & Ada.Characters.Latin_1.Quotation & ".", Idlac_Errors.Error, Loc); Result := No_Node; Success := False; return; end; end if; Next_Token; Push_Scope (Result); declare Node : Node_Id; begin Parse_Switch_Type_Spec (Node, Success); Set_Switch_Type (Result, Node); end; if not Success then Pop_Scope; return; end if; if Get_Token /= T_Right_Paren then Idlac_Errors.Error ("')' expected at the end of switch " & "specification.", Idlac_Errors.Error, Get_Token_Location); Success := False; Pop_Scope; return; end if; Next_Token; if Get_Token /= T_Left_Cbracket then declare Loc : Idlac_Errors.Location; begin Loc := Get_Previous_Token_Location; Loc.Col := Loc.Col + 2; Idlac_Errors.Error ("'{' expected at the beginning of union.", Idlac_Errors.Error, Loc); Result := No_Node; Success := False; Pop_Scope; return; end; end if; Next_Token; declare Node : Node_List; Default_Index : Long_Integer; begin Node := Cases (Result); Parse_Switch_Body (Node, Switch_Type (Result), Default_Index, Success); Set_Cases (Result, Node); Set_Default_Index (Result, Default_Index); end; Pop_Scope; if not Success then return; end if; if Get_Token /= T_Right_Cbracket then Idlac_Errors.Error ("'}' expected at the end of union.", Idlac_Errors.Error, Get_Token_Location); Result := No_Node; Success := False; return; end if; Next_Token; return; pragma Debug (O2 ("Parse_Union_Type: end")); end Parse_Union_Type; ------------------------------ -- Parse_Switch_Type_Spec -- ------------------------------ procedure Parse_Switch_Type_Spec (Result : out Node_Id; Success : out Boolean) is begin pragma Debug (O2 ("Parse_Switch_Type_Spec: enter")); case Get_Token is when T_Long | T_Short | T_Unsigned => Parse_Integer_Type (Result, Success); when T_Char => Parse_Char_Type (Result, Success); when T_Boolean => Parse_Boolean_Type (Result, Success); when T_Enum => Parse_Enum_Type (Result, Success); when T_Colon_Colon | T_Identifier => Parse_Scoped_Name (Result, Success); -- The in the production -- must be a previously defined integer, char, boolean -- or enum type. if not Success then Result := No_Node; end if; if Result /= No_Node then declare Invalid_Type : Boolean := False; begin if S_Type (Result) /= No_Node then case Kind (S_Type (Result)) is when K_Short | K_Long | K_Long_Long | K_Unsigned_Short | K_Unsigned_Long | K_Unsigned_Long_Long | K_Char | K_Wide_Char | K_Boolean | K_Enum => null; when others => Invalid_Type := True; end case; else Invalid_Type := True; end if; if Invalid_Type then Idlac_Errors.Error ("Invalid type in switch. The " & "scoped name should refer to " & "an integer, char, boolean or " & " enum type.", Idlac_Errors.Error, Get_Token_Location); end if; end; end if; when others => Idlac_Errors.Error ("switch type expected.", Idlac_Errors.Error, Get_Token_Location); Success := False; Result := No_Node; end case; pragma Debug (O2 ("Parse_Switch_Type_Spec: end")); return; end Parse_Switch_Type_Spec; ------------------------- -- Parse_Switch_Body -- ------------------------- procedure Parse_Switch_Body (Result : out Node_List; Switch_Type : Node_Id; Default_Index : out Long_Integer; Success : out Boolean) is Empty : Boolean := True; I : Long_Integer := -1; begin pragma Debug (O2 ("Parse_Switch_Body: enter")); Result := Nil_List; Default_Index := -1; loop declare Case_Clause : Node_Id; Case_Success : Boolean; Loc : Idlac_Errors.Location; begin pragma Debug (O ("Parse_Switch_Body : new case clause")); Loc := Get_Token_Location; Parse_Case (Case_Clause, Switch_Type, Case_Success); if not Case_Success then Go_To_End_Of_Case; else I := I + 1; Append_Node (Result, Case_Clause); if Kind (Case_Clause) /= K_Pragma then Empty := False; if Default_Index /= -1 then if Is_In_List (Labels (Case_Clause), No_Node) then Idlac_Errors.Error ("default clause already appeared.", Idlac_Errors.Error, Loc); end if; else if Is_In_List (Labels (Case_Clause), No_Node) then Default_Index := I; end if; end if; end if; end if; end; exit when Get_Token = T_Right_Cbracket or else Get_Token = T_Eof; end loop; if Empty then Idlac_Errors.Error ("case clause expected : " & "a union may not be empty.", Idlac_Errors.Error, Get_Token_Location); end if; -- Release_All_Used_Values; Success := True; return; pragma Debug (O2 ("Parse_Switch_Body: end")); end Parse_Switch_Body; ------------------ -- Parse_Case -- ------------------ procedure Parse_Case (Result : out Node_Id; Switch_Type : Node_Id; Success : out Boolean) is Default_Label : Boolean := False; Loc : Idlac_Errors.Location; begin pragma Debug (O2 ("Parse_Case: enter")); Loc := Get_Token_Location; case Get_Token is when T_Case | T_Default => null; when T_Pragma => Parse_Pragma (Result, Success); if not Success then -- here the pragma is ignored and no node created -- so we parse the next case (if it exists) Parse_Case (Result, Switch_Type, Success); end if; pragma Debug (O2 ("Parse_Case: end")); return; when T_Right_Cbracket => -- here we just parsed a pragma but it was the last case of the -- union. Thus, we return without creating a node but -- without an error message Result := No_Node; Success := False; pragma Debug (O2 ("Parse_Case: end")); return; when others => Idlac_Errors.Error ("invalid case label : " & Ada.Characters.Latin_1.Quotation & "case" & Ada.Characters.Latin_1.Quotation & " or " & Ada.Characters.Latin_1.Quotation & "default" & Ada.Characters.Latin_1.Quotation & " expected.", Idlac_Errors.Error, Get_Token_Location); Result := No_Node; Success := False; return; end case; pragma Debug (O ("Parse_case : first token ok")); Result := Make_Case (Get_Token_Location); Set_Labels (Result, Nil_List); while Get_Token = T_Case or else Get_Token = T_Default loop declare Case_Label : Node_Id; Case_Success : Boolean; begin Parse_Case_Label (Case_Label, Switch_Type, Case_Success); if not Case_Success then Go_To_End_Of_Case_Label; else Append_Node_To_Labels (Result, Case_Label); if Case_Label = No_Node then Default_Label := True; end if; end if; end; end loop; if Default_Label and then Length (Labels (Result)) > 1 then Idlac_Errors.Error ("Some labels are use less since you " & "one of them is the default clause", Idlac_Errors.Warning, Loc); end if; pragma Debug (O ("Parse_case : all label parsed")); declare Node1 : Node_Id; Node2 : Node_Id; begin Node1 := Case_Type (Result); Node2 := Case_Decl (Result); Parse_Element_Spec (Node1, Node2, Result, Success); Set_Case_Type (Result, Node1); Set_Case_Decl (Result, Node2); end; if not Success then return; end if; if Get_Token /= T_Semi_Colon then Idlac_Errors.Error ("';' expected at the end of case clause.", Idlac_Errors.Error, Get_Token_Location); else Next_Token; end if; pragma Debug (O2 ("Parse_Case: end")); return; end Parse_Case; ------------------------ -- Parse_Case_Label -- ------------------------ procedure Parse_Case_Label (Result : out Node_Id; Switch_Type : Node_Id; Success : out Boolean) is begin pragma Debug (O2 ("Parse_case_label: enter")); case Get_Token is when T_Case => declare -- Loc : Idlac_Errors.Location; begin Next_Token; -- Loc := Get_Token_Location; Parse_Const_Exp (Result, Switch_Type, Success); if not Success then return; end if; -- Verifying that a clause does not appear twice -- if not Add_Used_Value (Result) then -- Idlac_Errors.Error -- ("This value was already taken into " & -- "account in this switch statement.", -- Idlac_Errors.Warning, -- Loc); -- end if; end; when T_Default => Next_Token; Result := No_Node; Success := True; when others => raise Idlac_Errors.Internal_Error; end case; if Get_Token /= T_Colon then Idlac_Errors.Error ("':' expected at the end of case label.", Idlac_Errors.Error, Get_Token_Location); else Next_Token; end if; return; pragma Debug (O2 ("Parse_case_label: end")); end Parse_Case_Label; -------------------------- -- Parse_Element_Spec -- -------------------------- procedure Parse_Element_Spec (Element_Type : out Node_Id; Element_Decl : out Node_Id; Parent : Node_Id; Success : out Boolean) is begin pragma Debug (O2 ("Parse_Element_Spec: enter")); Parse_Type_Spec (Element_Type, Success); if not Success then return; end if; Parse_Declarator (Element_Decl, Parent, Success); pragma Debug (O2 ("Parse_Element_Spec: end")); return; end Parse_Element_Spec; --------------------- -- Parse_Enum_Type -- --------------------- procedure Parse_Enum_Type (Result : out Node_Id; Success : out Boolean) is begin Next_Token; if Get_Token /= T_Identifier then declare Loc : Idlac_Errors.Location; begin Loc := Get_Previous_Token_Location; Loc.Col := Loc.Col + 5; Idlac_Errors.Error ("Identifier expected in enumeration " & "definition.", Idlac_Errors.Error, Loc); Result := No_Node; Success := False; return; end; end if; Result := Make_Enum (Get_Token_Location); Set_Enumerators (Result, Nil_List); -- Is there a previous definition? if not Is_Redefinable (Get_Token_String, Get_Lexer_Location) then declare Definition : constant Identifier_Definition_Acc := Find_Identifier_Definition (Get_Token_String, Get_Lexer_Location); begin Idlac_Errors.Error ("This identifier is already defined in this scope : " & Idlac_Errors.Location_To_String (Get_Location (Definition.Node)), Idlac_Errors.Error, Get_Token_Location); end; return; end if; if not Add_Identifier (Result, Get_Token_String) then raise Idlac_Errors.Internal_Error; end if; Set_Default_Repository_Id (Result); Next_Token; if Get_Token /= T_Left_Cbracket then declare Loc : Idlac_Errors.Location; begin Loc := Get_Previous_Token_Location; Loc.Col := Loc.Col + Get_Previous_Token_String'Length; Idlac_Errors.Error ("'{' expected in enumeration definition.", Idlac_Errors.Error, Loc); Result := No_Node; Success := False; return; end; end if; Next_Token; if Get_Token = T_Right_Cbracket then Idlac_Errors.Error ("identifier expected : " & "an enumeration may not be empty.", Idlac_Errors.Error, Get_Token_Location); Next_Token; return; end if; declare Count : Idl_Integer := 1; begin loop declare Enum : Node_Id; begin if Get_Token = T_Pragma then Parse_Pragma (Enum, Success); if Success then Append_Node_To_Enumerators (Result, Enum); end if; else Parse_Enumerator (Enum, Success); if not Success then Go_To_End_Of_Enumeration; return; end if; Count := Count + 1; if Count = Idl_Enum_Max then Idlac_Errors.Error ("two much possible values in this " & "enumeration : maximum is 2^32.", Idlac_Errors.Error, Get_Token_Location); end if; Append_Node_To_Enumerators (Result, Enum); if Get_Token = T_Comma then Next_Token; elsif Get_Token /= T_Pragma then exit; end if; end if; end; end loop; end; if Get_Token /= T_Right_Cbracket then Idlac_Errors.Error ("'}' expected at the end of enumeration " & "definition.", Idlac_Errors.Error, Get_Token_Location); Go_To_Next_Right_Cbracket; if Get_Token = T_Right_Cbracket then Next_Token; end if; if Get_Token = T_Semi_Colon then Next_Token; end if; Success := False; return; end if; Next_Token; return; end Parse_Enum_Type; ------------------------ -- Parse_Enumerator -- ------------------------ procedure Parse_Enumerator (Result : out Node_Id; Success : out Boolean) is begin if Get_Token /= T_Identifier then Idlac_Errors.Error ("identifier expected in enumerator.", Idlac_Errors.Error, Get_Token_Location); Success := False; return; else Result := Make_Enumerator (Get_Token_Location); -- Is there a previous definition if not Is_Redefinable (Get_Token_String, Get_Lexer_Location) then declare Definition : constant Identifier_Definition_Acc := Find_Identifier_Definition (Get_Token_String, Get_Lexer_Location); begin Idlac_Errors.Error ("This identifier is already defined in this scope : " & Idlac_Errors.Location_To_String (Get_Location (Definition.Node)), Idlac_Errors.Error, Get_Token_Location); end; else -- no previous definition if not Add_Identifier (Result, Get_Token_String) then raise Idlac_Errors.Internal_Error; end if; Set_Default_Repository_Id (Result); end if; end if; Success := True; -- eat the identifier Next_Token; return; end Parse_Enumerator; --------------------------- -- Parse_Sequence_Type -- --------------------------- procedure Parse_Sequence_Type (Result : out Node_Id; Success : out Boolean) is begin pragma Debug (O2 ("Parse_Sequence_Type: enter")); Next_Token; if Get_Token /= T_Less then Idlac_Errors.Error ("'<' expected in sequence definition.", Idlac_Errors.Error, Get_Token_Location); Success := False; return; end if; Result := Make_Sequence (Get_Previous_Token_Location); pragma Debug (O ("Parse_Sequence_Type : previous location :" & " filename = " & Get_Previous_Token_Location.Filename.all)); Next_Token; declare Node : Node_Id; begin Node := Sequence_Type (Result); Parse_Simple_Type_Spec (Node, Success); Set_Sequence_Type (Result, Node); end; if not Success then return; end if; pragma Debug (O ("Parse_Sequence_Type : Token is" & Idl_Token'Image (Get_Token))); -- should divide the greater_greater token! if Get_Token = T_Greater_Greater then Idlac_Errors.Error ("'>>' could be considered as a constant operation." & "You should better insert a space between the two '>'.", Idlac_Errors.Warning, Get_Token_Location); Divide_T_Greater_Greater; end if; if Get_Token /= T_Comma and then Get_Token /= T_Greater then Idlac_Errors.Error ("',' or '>' expected in sequence definition.", Idlac_Errors.Error, Get_Token_Location); Success := False; return; end if; if Get_Token = T_Comma then Next_Token; declare Node : Node_Id; begin Node := Bound (Result); Parse_Positive_Int_Const (Node, Success); Set_Bound (Result, Node); end; if not Success then return; end if; else Set_Bound (Result, No_Node); end if; -- should divide the greater_greater token! if Get_Token = T_Greater_Greater then Idlac_Errors.Error ("'>>' could be considered as a constant operation." & "You should better insert a space between the two '>'.", Idlac_Errors.Warning, Get_Token_Location); Divide_T_Greater_Greater; end if; case Get_Token is when T_Greater => Next_Token; when others => Idlac_Errors.Error ("'>' expected at the end of " & "sequence definition.", Idlac_Errors.Error, Get_Token_Location); Success := False; return; end case; pragma Debug (O2 ("Parse_Sequence_Type: end")); return; end Parse_Sequence_Type; ------------------------- -- Parse_String_Type -- ------------------------- procedure Parse_String_Type (Result : out Node_Id; Success : out Boolean) is begin Next_Token; Result := Make_String (Get_Previous_Token_Location); if Get_Token = T_Less then declare Node : Node_Id; begin Next_Token; Node := Bound (Result); Parse_Positive_Int_Const (Node, Success); Set_Bound (Result, Node); end; if not Success then return; end if; if Get_Token /= T_Greater then Idlac_Errors.Error ("'>' expected in string definition.", Idlac_Errors.Error, Get_Token_Location); Success := False; return; end if; Next_Token; else Set_Bound (Result, No_Node); end if; Success := True; return; end Parse_String_Type; ------------------------------ -- Parse_Wide_String_Type -- ------------------------------ procedure Parse_Wide_String_Type (Result : out Node_Id; Success : out Boolean) is begin Next_Token; Result := Make_Wide_String (Get_Previous_Token_Location); if Get_Token = T_Less then declare Node : Node_Id; begin Next_Token; Node := Bound (Result); Parse_Positive_Int_Const (Node, Success); Set_Bound (Result, Node); end; if not Success then return; end if; if Get_Token /= T_Greater then Idlac_Errors.Error ("'>' expected in wide string definition.", Idlac_Errors.Error, Get_Token_Location); Success := False; return; end if; Next_Token; else Set_Bound (Result, No_Node); end if; Success := True; return; end Parse_Wide_String_Type; ------------------------------ -- Parse_Array_Declarator -- ------------------------------ procedure Parse_Array_Declarator (Result : out Node_Id; Parent : Node_Id; Success : out Boolean) is begin pragma Debug (O2 ("Parse_Array_Declarator: enter")); Result := Make_Declarator (Get_Token_Location); Set_Parent (Result, Parent); -- Is there a previous definition if not Is_Redefinable (Get_Token_String, Get_Lexer_Location) then declare Definition : constant Identifier_Definition_Acc := Find_Identifier_Definition (Get_Token_String, Get_Lexer_Location); begin Idlac_Errors.Error ("This identifier is already defined in this scope : " & Idlac_Errors.Location_To_String (Get_Location (Definition.Node)), Idlac_Errors.Error, Get_Token_Location); end; end if; -- if any previous definition, just ignore the identifier -- but keep parsing parsing (no syntax error) if Add_Identifier (Result, Get_Token_String) then Set_Default_Repository_Id (Result); Set_Array_Bounds (Result, Nil_List); end if; -- consumes the identifier Next_Token; while Get_Token = T_Left_Sbracket loop declare Expr : Node_Id; begin Parse_Fixed_Array_Size (Expr, Success); if not Success then pragma Debug (O ("Parse_Array_Declarator : " & "Parse_Fixed_Array_Size returned false")); pragma Debug (O2 ("Parse_Array_Declarator: end")); return; end if; Append_Node_To_Array_Bounds (Result, Expr); end; end loop; pragma Debug (O2 ("Parse_Array_Declarator: end")); return; end Parse_Array_Declarator; ------------------------------ -- Parse_Fixed_Array_Size -- ------------------------------ procedure Parse_Fixed_Array_Size (Result : out Node_Id; Success : out Boolean) is begin pragma Debug (O2 ("Parse_Fixed_Array_Size: enter")); Next_Token; Parse_Positive_Int_Const (Result, Success); if not Success then pragma Debug (O ("Parse_fixed_array_size : "& "Parse_positive_int_const returned false")); return; end if; if Get_Token /= T_Right_Sbracket then declare Loc : Idlac_Errors.Location; begin Loc := Get_Previous_Token_Location; Loc.Col := Loc.Col + Get_Previous_Token_String'Length; Idlac_Errors.Error ("']' expected in array definition.", Idlac_Errors.Error, Loc); end; Success := False; return; end if; Next_Token; pragma Debug (O2 ("Parse_Fixed_Array_Size: end")); return; end Parse_Fixed_Array_Size; --------------------- -- Parse_Attr_Dcl -- --------------------- procedure Parse_Attr_Dcl (Result : out Node_Id; Success : out Boolean) is El : Node_Id; begin El := Make_Attribute (Get_Token_Location); Set_Raises (El, Nil_List); Set_Get_Raises (El, Nil_List); Set_Set_Raises (El, Nil_List); if Get_Token = T_Readonly then Set_Is_Readonly (El, True); Next_Token; else Set_Is_Readonly (El, False); end if; if Get_Token /= T_Attribute then Idlac_Errors.Error ("'attribute' expected", Idlac_Errors.Error, Get_Token_Location); Result := No_Node; Success := False; return; end if; Next_Token; pragma Debug (O ("Parse_Attr_Dcl :" & Idl_Token'Image (Get_Token))); declare Node : Node_Id; begin Node := A_Type (El); Parse_Param_Type_Spec (Node, Success); Set_A_Type (El, Node); end; if not Success then Result := No_Node; return; end if; if Get_Token /= T_Identifier then Idlac_Errors.Error ("identifier expected", Idlac_Errors.Error, Get_Token_Location); Result := No_Node; Success := False; return; end if; declare Res : Node_Id; begin Parse_Declarator (Res, El, Success); if not Success then Result := No_Node; Success := False; return; else Append_Node_To_Declarators (El, Res); end if; end; if Get_Token = T_Comma then while Get_Token = T_Comma loop Next_Token; declare Res : Node_Id; begin Parse_Declarator (Res, El, Success); if not Success then Result := No_Node; Success := False; return; else Append_Node_To_Declarators (El, Res); end if; end; end loop; elsif Get_Token = T_Raises then if not Is_Readonly (El) then Idlac_Errors.Error ("raises statement may be used only with readonly attributes", Idlac_Errors.Error, Get_Token_Location); Result := No_Node; Success := False; return; end if; declare Node : Node_List; begin Node := Raises (El); Parse_Raises_Expr (Node, Success); Set_Raises (El, Node); end; if not Success then return; end if; elsif Get_Token = T_SetRaises or else Get_Token = T_GetRaises then if Is_Readonly (El) then Idlac_Errors.Error ("getraises/setraises are acceptable only for " & "non readonly attributes", Idlac_Errors.Error, Get_Token_Location); Result := No_Node; Success := False; return; end if; declare Node_Get : Node_List; Node_Set : Node_List; begin Node_Get := Get_Raises (El); Node_Set := Set_Raises (El); Parse_Attr_Raises_Expr (Node_Get, Node_Set, Success); Set_Get_Raises (El, Node_Get); Set_Set_Raises (El, Node_Set); end; if not Success then return; end if; end if; Result := El; end Parse_Attr_Dcl; ------------------------ -- Parse_Except_Dcl -- ------------------------ procedure Parse_Except_Dcl (Result : out Node_Id; Success : out Boolean) is begin pragma Debug (O2 ("Parse_Except_Dcl: enter")); pragma Debug (O ("Parse_Except_Dcl : first token " & Idl_Token'Image (Get_Token))); if Get_Token /= T_Exception then Idlac_Errors.Error ("'exception' expected", Idlac_Errors.Error, Get_Token_Location); Success := False; Result := No_Node; return; end if; Result := Make_Exception (Get_Token_Location); -- memory leak Next_Token; if Get_Token /= T_Identifier then Idlac_Errors.Error ("identifier expected", Idlac_Errors.Error, Get_Token_Location); Success := False; return; end if; pragma Debug (O ("Parse_Except_Dcl : token before add : " & Idl_Token'Image (Get_Token))); if not Add_Identifier (Result, Get_Token_String) then declare Definition : constant Identifier_Definition_Acc := Find_Identifier_Definition (Get_Token_String, Get_Lexer_Location); begin Idlac_Errors.Error ("This identifier is already defined in this scope : " & Idlac_Errors.Location_To_String (Get_Location (Definition.Node)), Idlac_Errors.Error, Get_Token_Location); Success := False; return; end; end if; Set_Default_Repository_Id (Result); Set_Initial_Current_Prefix (Result); pragma Debug (O ("Parse_Except_Dcl : token after add : " & Idl_Token'Image (Get_Token))); Next_Token; if Get_Token /= T_Left_Cbracket then Idlac_Errors.Error ("'{' expected", Idlac_Errors.Error, Get_Token_Location); Success := False; return; else Next_Token; end if; Push_Scope (Result); while Get_Token /= T_Right_Cbracket loop declare Mem : Node_Id; Mem_Success : Boolean; begin Parse_Member (Mem, Mem_Success); if not Mem_Success then Go_To_Next_Member; if Get_Token = T_Eof then Success := False; return; end if; else Append_Node_To_Members (Result, Mem); end if; end; end loop; Pop_Scope; -- to eat the right bracket Next_Token; Success := True; return; pragma Debug (O2 ("Parse_Except_Dcl: end")); end Parse_Except_Dcl; ------------------ -- Parse_Op_Dcl -- ------------------ procedure Parse_Op_Dcl (Result : out Node_Id; Success : out Boolean) is begin Result := Make_Operation (Get_Token_Location); Set_Initial_Current_Prefix (Result); if Get_Token = T_Oneway then Set_Is_Oneway (Result, True); Next_Token; else Set_Is_Oneway (Result, False); end if; declare Node : Node_Id; begin Node := Operation_Type (Result); Parse_Op_Type_Spec (Node, Success); Set_Operation_Type (Result, Node); if Is_Oneway (Result) and then not Is_Void (Operation_Type (Result)) then Idlac_Errors.Error ("Oneway operation must have void type", Idlac_Errors.Error, Get_Previous_Token_Location); Success := False; end if; end; if not Success then return; end if; if Get_Token /= T_Identifier then Idlac_Errors.Error ("Identifier expected in operation declaration.", Idlac_Errors.Error, Get_Token_Location); Success := False; return; else -- Is there a previous definition if not Is_Redefinable (Get_Token_String, Get_Lexer_Location) then declare Definition : constant Identifier_Definition_Acc := Find_Identifier_Definition (Get_Token_String, Get_Lexer_Location); begin Idlac_Errors.Error ("This identifier is already defined in this scope: " & Idlac_Errors.Location_To_String (Get_Location (Definition.Node)), Idlac_Errors.Error, Get_Token_Location); pragma Debug (O ("Parse_Op_Dcl: bad identifier")); Result := No_Node; Success := False; return; end; else -- no previous definition if not Add_Identifier (Result, Get_Token_String) then raise Idlac_Errors.Internal_Error; end if; Set_Default_Repository_Id (Result); end if; end if; Next_Token; Push_Scope (Result); declare Node : Node_List; begin Node := Parameters (Result); Parse_Parameter_Dcls (Node, Success); Set_Parameters (Result, Node); end; Pop_Scope; if not Success then return; end if; if Get_Token = T_Raises then declare Raises_Location : constant Idlac_Errors.Location := Get_Token_Location; Node : Node_List; begin Node := Raises (Result); Parse_Raises_Expr (Node, Success); Set_Raises (Result, Node); if Is_Oneway (Result) then Idlac_Errors.Error ("Oneway operation may not have raises expression", Idlac_Errors.Error, Raises_Location); Set_Raises (Result, Nil_List); return; end if; end; if not Success then return; end if; else Set_Raises (Result, Nil_List); end if; if Get_Token = T_Context then declare Node : Node_List; begin Node := Contexts (Result); Parse_Context_Expr (Node, Success); Set_Contexts (Result, Node); end; else Set_Contexts (Result, Nil_List); end if; return; end Parse_Op_Dcl; -------------------------- -- Parse_Op_Type_Spec -- -------------------------- procedure Parse_Op_Type_Spec (Result : out Node_Id; Success : out Boolean) is begin case Get_Token is when T_Void => Result := Make_Void (Get_Token_Location); Next_Token; Success := True; return; when T_Float | T_Double | T_Long | T_Short | T_Unsigned | T_Char | T_Wchar | T_Boolean | T_Octet | T_Any | T_Object | T_ValueBase | T_String | T_Wstring | T_Colon_Colon | T_Identifier => Parse_Param_Type_Spec (Result, Success); return; when others => Idlac_Errors.Error ("void or type specification expected.", Idlac_Errors.Error, Get_Token_Location); Success := False; Result := No_Node; return; end case; end Parse_Op_Type_Spec; -------------------------- -- Parse_Parameter_Dcls -- -------------------------- procedure Parse_Parameter_Dcls (Result : out Node_List; Success : out Boolean) is begin Result := Nil_List; if Get_Token /= T_Left_Paren then declare Loc : Idlac_Errors.Location; begin Loc := Get_Previous_Token_Location; Loc.Col := Loc.Col + Get_Previous_Token_String'Length; Idlac_Errors.Error ("'(' expected in operation definition.", Idlac_Errors.Error, Loc); end; Success := False; return; end if; Next_Token; if Get_Token /= T_Right_Paren then declare Param : Node_Id; begin Parse_Param_Dcl (Param, Success); if not Success then return; end if; Append_Node (Result, Param); end; end if; while Get_Token = T_Comma loop Next_Token; declare Param : Node_Id; begin Parse_Param_Dcl (Param, Success); if not Success then Go_To_Next_Right_Paren; else Append_Node (Result, Param); end if; end; end loop; if Get_Token /= T_Right_Paren then Idlac_Errors.Error ("')' expected at the end of the " & "parameters definition.", Idlac_Errors.Error, Get_Token_Location); Success := False; return; end if; Next_Token; Success := True; return; end Parse_Parameter_Dcls; --------------------- -- Parse_Param_Dcl -- --------------------- procedure Parse_Param_Dcl (Result : out Node_Id; Success : out Boolean) is Attr_Success : Boolean; begin pragma Debug (O2 ("Parse_Param_Dcl: enter")); Result := Make_Param (Get_Token_Location); declare Node : Param_Mode; begin Node := Mode (Result); Parse_Param_Attribute (Node, Attr_Success); Set_Mode (Result, Node); end; if not Attr_Success then case Get_Token is when T_Float | T_Double | T_Long | T_Short | T_Unsigned | T_Char | T_Wchar | T_Boolean | T_Octet | T_Any | T_Object | T_ValueBase | T_String | T_Colon_Colon | T_Identifier => null; when others => Success := False; return; end case; end if; declare Node : Node_Id; begin Node := Param_Type (Result); Parse_Param_Type_Spec (Node, Success); Set_Param_Type (Result, Node); end; if not Success then return; end if; declare Node : Node_Id; begin Node := Declarator (Result); Parse_Simple_Declarator (Node, Result, Success); Set_Declarator (Result, Node); end; pragma Debug (O2 ("Parse_Param_Dcl: end")); return; end Parse_Param_Dcl; ----------------------------- -- Parse_Param_Attribute -- ----------------------------- procedure Parse_Param_Attribute (Result : out Param_Mode; Success : out Boolean) is begin case Get_Token is when T_In => Result := Mode_In; when T_Out => Result := Mode_Out; when T_Inout => Result := Mode_Inout; when others => Idlac_Errors.Error ("mode expected (in, out or inout).", Idlac_Errors.Error, Get_Token_Location); Result := Mode_In; Success := False; return; end case; if Is_Oneway (Get_Current_Scope) and then Result /= Mode_In then Idlac_Errors.Error ("Oneway operation may not have output parameters", Idlac_Errors.Error, Get_Token_Location); Success := False; return; end if; Next_Token; Success := True; return; end Parse_Param_Attribute; ------------------------- -- Parse_Raises_Expr -- ------------------------- procedure Parse_Raises_Expr (Result : out Node_List; Success : out Boolean) is begin Next_Token; Parse_Exception_List (Result, Success, "raises"); end Parse_Raises_Expr; -------------------------- -- Parse_Context_Expr -- -------------------------- procedure Parse_Context_Expr (Result : out Node_List; Success : out Boolean) is begin Result := Nil_List; Next_Token; if Get_Token /= T_Left_Paren then declare Loc : Idlac_Errors.Location; begin Loc := Get_Previous_Token_Location; Loc.Col := Loc.Col + 7; Idlac_Errors.Error ("'(' expected in context statement.", Idlac_Errors.Error, Loc); end; Success := False; return; end if; Next_Token; if Get_Token = T_Right_Paren then declare Loc : Idlac_Errors.Location; begin Loc := Get_Previous_Token_Location; Loc.Col := Loc.Col + 1; Idlac_Errors.Error ("string literal expected : a context " & "statement may not be empty.", Idlac_Errors.Error, Loc); end; Next_Token; Success := True; return; end if; declare Name : Node_Id; String_Type : Constant_Value_Ptr := new Constant_Value (Kind => C_String); begin String_Type.String_Length := -1; Parse_String_Literal (Name, Success, String_Type); Free (String_Type); if not Success then return; end if; Check_Context_String (Expr_Value (Name).String_Value.all); Append_Node (Result, Name); end; while Get_Token = T_Comma loop Next_Token; declare Name : Node_Id; String_Type : Constant_Value_Ptr := new Constant_Value (Kind => C_String); begin String_Type.String_Length := -1; Parse_String_Literal (Name, Success, String_Type); Free (String_Type); if not Success then Go_To_Next_Semi_Colon; return; end if; Check_Context_String (Expr_Value (Name).String_Value.all); Append_Node (Result, Name); end; end loop; if Get_Token /= T_Right_Paren then Idlac_Errors.Error ("')' expected at the end of the " & "context statement.", Idlac_Errors.Error, Get_Token_Location); Success := False; return; end if; Next_Token; return; end Parse_Context_Expr; --------------------------- -- Parse_Param_Type_Spec -- --------------------------- procedure Parse_Param_Type_Spec (Result : out Node_Id; Success : out Boolean) is begin case Get_Token is when T_Float | T_Double | T_Long | T_Short | T_Unsigned | T_Char | T_Wchar | T_Boolean | T_Octet | T_Any | T_Object | T_ValueBase => Parse_Base_Type_Spec (Result, Success); when T_String => declare Res : Node_Id; begin Parse_String_Type (Res, Success); Result := Res; end; when T_Wstring => declare Res : Node_Id; begin Parse_Wide_String_Type (Res, Success); Result := Res; end; when T_Colon_Colon | T_Identifier => Parse_Scoped_Name (Result, Success); if Result /= No_Node then declare Not_A_Type : Boolean := False; begin -- Check that the scoped name denotes a type pragma Debug (O ("Parse_Simple_Type_Spec : " & "kind of result is " & Img (Kind (Result)))); if S_Type (Result) /= No_Node then pragma Debug (O ("Parse_Simple_Type_Spec : " & "scoped name without an S_Type")); case Kind (S_Type (Result)) is when K_Float | K_Double | K_Long_Double | K_Long | K_Long_Long | K_Short | K_Unsigned_Long | K_Unsigned_Long_Long | K_Unsigned_Short | K_Char | K_Wide_Char | K_Boolean | K_Octet | K_Fixed | K_Any | K_Object | K_ValueBase | K_String | K_Wide_String | K_Enum | K_Struct | K_Union | K_Declarator | K_Sequence | K_Interface | K_Forward_Interface | K_ValueType | K_Boxed_ValueType | K_Forward_ValueType | K_Native => null; when others => Not_A_Type := True; end case; else pragma Debug (O ("Parse_Simple_Type_Spec : " & "scoped name with an S_Type")); Not_A_Type := True; end if; if Not_A_Type then pragma Debug (O ("Parse_Simple_Type_Spec : " & "not_a_type error")); Idlac_Errors.Error ("A Scoped_Named with a S_Type of " & Img (Kind (S_Type (Result))) & " is not acceptable as a Param_Type.", Idlac_Errors.Error, Get_Token_Location); end if; end; end if; when others => Idlac_Errors.Error ("param type specifier expected.", Idlac_Errors.Error, Get_Token_Location); Success := False; end case; return; end Parse_Param_Type_Spec; --------------------------- -- Parse_Fixed_Pt_Type -- --------------------------- procedure Parse_Fixed_Pt_Type (Result : out Node_Id; Success : out Boolean) is begin Next_Token; Result := Make_Fixed (Get_Previous_Token_Location); if Get_Token /= T_Less then Idlac_Errors.Error ("'<' expected in fixed point type definition.", Idlac_Errors.Error, Get_Token_Location); Success := False; return; end if; Next_Token; declare Node : Node_Id; begin Node := Digits_Nb (Result); Parse_Positive_Int_Const (Node, Success); Set_Digits_Nb (Result, Node); end; if not Success then Result := No_Node; Go_To_Next_Greater; return; end if; if Expr_Value (Digits_Nb (Result)).Integer_Value < 0 or else Expr_Value (Digits_Nb (Result)).Integer_Value > 31 then Idlac_Errors.Error ("invalid number of digits in fixed point " & "type definition : it should be in range " & "0 .. 31.", Idlac_Errors.Error, Get_Token_Location); end if; if Get_Token /= T_Comma then Idlac_Errors.Error ("',' expected in fixed point type definition.", Idlac_Errors.Error, Get_Token_Location); Success := False; return; end if; Next_Token; declare Node : Node_Id; begin Node := Scale (Result); Parse_Positive_Int_Const (Node, Success); Set_Scale (Result, Node); end; if not Success then Go_To_Next_Greater; Result := No_Node; return; end if; if Expr_Value (Digits_Nb (Result)).Integer_Value < Expr_Value (Scale (Result)).Integer_Value then Idlac_Errors.Error ("invalid scale in fixed point " & "type definition : it should be less " & "than or equal to the number of digits.", Idlac_Errors.Error, Get_Token_Location); end if; if Get_Token /= T_Greater then Idlac_Errors.Error ("'>' expected in fixed point type definition.", Idlac_Errors.Error, Get_Token_Location); Success := False; return; end if; Next_Token; return; end Parse_Fixed_Pt_Type; ----------------------------- -- Parse_Value_Base_Type -- ----------------------------- procedure Parse_Value_Base_Type (Result : out Node_Id; Success : out Boolean) is begin Result := No_Node; Success := False; end Parse_Value_Base_Type; ------------------ -- Parse_Import -- ------------------ procedure Parse_Import (Repository : Node_Id; Success : out Boolean) is begin -- Skip 'import' keyword Next_Token; if Get_Token /= T_Colon_Colon then Idlac_Errors.Error ("Only identifier relative global scope now allowed " & "(IDLAC limitation)", Idlac_Errors.Error, Get_Token_Location); Success := False; return; end if; Next_Token; if Get_Token /= T_Identifier then Idlac_Errors.Error ("Identifier required in ", Idlac_Errors.Error, Get_Token_Location); Success := False; return; end if; declare File_Name : constant String := Get_Token_String; File_Loc : constant String := Files.Locate_IDL_Specification (File_Name); begin if File_Loc'Length = 0 then Idlac_Errors.Error ("Can't find IDL specification " & File_Name, Idlac_Errors.Error, Get_Token_Location); Success := False; return; end if; -- Process file if it not present in list of processed files. if not Is_Processed (File_Loc) then Idl_Fe.Parser.Initialize (File_Loc); Parse_Specification (Repository, True); Idl_Fe.Parser.Finalize; end if; end; Next_Token; if Get_Token /= T_Semi_Colon then Idlac_Errors.Error ("Import statement must end with semicolon", Idlac_Errors.Error, Get_Token_Location); Success := False; end if; Next_Token; Success := True; end Parse_Import; ----------------------- -- Parse_Type_Id_Dcl -- ----------------------- procedure Parse_Type_Id_Dcl (Success : out Boolean) is Scoped_Name_Node : Node_Id; String_Literal_Node : Node_Id; String_Constant_Type : Constant_Value_Ptr; begin Next_Token; Parse_Scoped_Name (Scoped_Name_Node, Success); if not Success then return; end if; declare NK : constant Node_Kind := Kind (Value (Scoped_Name_Node)); begin if NK /= K_Module and then NK /= K_Interface and then NK /= K_Forward_Interface and then NK /= K_ValueType and then NK /= K_Forward_ValueType and then NK /= K_Boxed_ValueType -- XXX This list must be extended to follow CORBA 3.0 3.15.1 then Idlac_Errors.Error ("Inappropriate scope kind", Idlac_Errors.Error, Get_Token_Location); Success := False; return; end if; end; String_Constant_Type := new Constant_Value (Kind => C_String); String_Constant_Type.String_Length := -1; Parse_String_Literal (String_Literal_Node, Success, String_Constant_Type); Free (String_Constant_Type); if not Success then Idlac_Errors.Error ("Repository ID expected", Idlac_Errors.Error, Get_Token_Location); return; end if; Set_Current_Prefix (Value (Scoped_Name_Node), String_Literal_Node); -- Overwrite repository id of named scope if it don't have explicitly -- defined repository id if Is_Explicit_Repository_Id (Value (Scoped_Name_Node)) then Idlac_Errors.Error ("Entity already has an explicit repository ID.", Idlac_Errors.Error, Get_Token_Location); else Set_Is_Explicit_Repository_Id (Value (Scoped_Name_Node), True); Set_Default_Repository_Id (Value (Scoped_Name_Node)); end if; Success := False; end Parse_Type_Id_Dcl; --------------------------- -- Parse_Type_Prefix_Dcl -- --------------------------- procedure Parse_Type_Prefix_Dcl (Success : out Boolean) is Scoped_Name_Node : Node_Id; String_Literal_Node : Node_Id; String_Constant_Type : Constant_Value_Ptr; begin Next_Token; Parse_Scoped_Name (Scoped_Name_Node, Success); if not Success then return; end if; declare NK : constant Node_Kind := Kind (Value (Scoped_Name_Node)); begin if True and then NK /= K_Module and then NK /= K_Interface and then NK /= K_Forward_Interface and then NK /= K_ValueType and then NK /= K_Forward_ValueType and then NK /= K_Boxed_ValueType then Idlac_Errors.Error ("Inappropriate scope kind", Idlac_Errors.Error, Get_Token_Location); Success := False; return; end if; end; String_Constant_Type := new Constant_Value (Kind => C_String); String_Constant_Type.String_Length := -1; Parse_String_Literal (String_Literal_Node, Success, String_Constant_Type); Free (String_Constant_Type); if not Success then Idlac_Errors.Error ("Repository ID prefix expected", Idlac_Errors.Error, Get_Token_Location); return; end if; Set_Current_Prefix (Value (Scoped_Name_Node), String_Literal_Node); -- Overwrite repository id of named scope if it don't have explicitly -- defined repository id if not Is_Explicit_Repository_Id (Value (Scoped_Name_Node)) then Set_Default_Repository_Id (Value (Scoped_Name_Node)); end if; Success := False; end Parse_Type_Prefix_Dcl; -------------------------- -- Parse_Exception_List -- -------------------------- procedure Parse_Exception_List (Result : out Node_List; Success : out Boolean; Statement : String) is begin Result := Nil_List; if Get_Token /= T_Left_Paren then declare Loc : Idlac_Errors.Location; begin Loc := Get_Previous_Token_Location; Loc.Col := Loc.Col + 7; Idlac_Errors.Error ("'(' expected in " & Statement & " statement.", Idlac_Errors.Error, Loc); end; Success := False; return; end if; Next_Token; if Get_Token = T_Right_Paren then declare Loc : Idlac_Errors.Location; begin Loc := Get_Previous_Token_Location; Loc.Col := Loc.Col + 1; Idlac_Errors.Error ("scoped_name expected : a " & Statement & " statement " & "may not be empty.", Idlac_Errors.Error, Loc); end; Next_Token; Success := True; return; end if; declare Name : Node_Id; begin Parse_Scoped_Name (Name, Success); if not Success then return; end if; if Name /= No_Node then if Kind (Value (Name)) /= K_Exception then Idlac_Errors.Error ("This scoped name is supposed " & "to denote an exception.", Idlac_Errors.Error, Get_Token_Location); end if; end if; Append_Node (Result, Name); end; while Get_Token = T_Comma loop Next_Token; declare Name : Node_Id; begin Parse_Scoped_Name (Name, Success); if not Success then Go_To_Next_Semi_Colon; return; end if; if Name /= No_Node then if Kind (Value (Name)) /= K_Exception then Idlac_Errors.Error ("This scoped name is supposed " & "to denote an exception.", Idlac_Errors.Error, Get_Token_Location); elsif Is_In_Pointed_List (Result, Name) then Idlac_Errors.Error ("An operation may not raise twice " & "a given exception.", Idlac_Errors.Error, Get_Token_Location); else Append_Node (Result, Name); end if; end if; end; end loop; if Get_Token /= T_Right_Paren then Idlac_Errors.Error ("')' expected at the end of the " & Statement & " statement.", Idlac_Errors.Error, Get_Token_Location); Success := False; return; end if; Next_Token; end Parse_Exception_List; ------------------------------ -- Inheritance management -- ------------------------------ ------------------------------- -- Interface_Is_Importable -- ------------------------------- function Interface_Is_Importable (Int : Node_Id; Scope : Node_Id) return Boolean is It, It2 : Node_Iterator; Node, Node2 : Node_Id; Result : Boolean := True; List : Node_List := Nil_List; Result_List : Node_List := Nil_List; procedure Call_Find_Identifier_In_Inheritance (Node : Node_Id); procedure Call_Find_Identifier_In_Inheritance (Node : Node_Id) is It3 : Node_Iterator; First_Node : Node_Id; begin -- find the given node in previous inheritance Find_Identifier_In_Inheritance (Name (Node), Scope, List); -- remove duplicated nodes Result_List := Simplify_Node_List (List); Free (List); -- if the list has more than one element, -- one of the two definition comes from an inherited -- interface that is not Scope, so the definitions clash. -- If there is only one element, we must test its scope. -- If there are none, there is no problem. case Length (Result_List) is when 0 => pragma Debug (O ("Interface_Is_Importable : list is nil_list")); null; when 1 => Init (It3, Result_List); Get_Next_Node (It3, First_Node); pragma Debug (O ("Interface_Is_Importable : list length is 1")); pragma Debug (O ("Interface_Is_Importable : parent scope is " & Name (Definition (First_Node).Parent_Scope))); pragma Debug (O ("Interface_Is_Importable : scope is " & Name (Value (Int)))); if Definition (First_Node).Parent_Scope /= Value (Int) then Result := False; end if; when others => pragma Debug (O ("Interface_Is_Importable : list length > 1")); Result := False; end case; end Call_Find_Identifier_In_Inheritance; begin pragma Debug (O2 ("Interface_Is_Importable: enter")); pragma Assert (Int /= No_Node); pragma Assert (Kind (Int) = K_Scoped_Name); pragma Assert (Kind (Value (Int)) = K_Interface); pragma Assert (Kind (Scope) = K_Interface); -- loop over each definition in the interface Init (It, Contents (Value (Int))); while (not Is_End (It)) and then Result loop pragma Debug (O ("Interface_Is_Importable : beginning of loop")); Get_Next_Node (It, Node); -- if the current definition is an operation if Kind (Node) = K_Operation then Call_Find_Identifier_In_Inheritance (Node); end if; -- if it is an attribute, loop over its declarators if Kind (Node) = K_Attribute then Init (It2, Declarators (Node)); while (not Is_End (It2)) and then Result loop Get_Next_Node (It2, Node2); Call_Find_Identifier_In_Inheritance (Node2); end loop; end if; end loop; pragma Debug (O2 ("Interface_Is_Importable: end")); return Result; end Interface_Is_Importable; ---------------------------- -- Parse_Attr_Raises_Expr -- ---------------------------- procedure Parse_Attr_Raises_Expr (Result_Get : out Node_List; Result_Set : out Node_List; Success : out Boolean) is begin Result_Get := Nil_List; Result_Set := Nil_List; if Get_Token = T_GetRaises then Next_Token; Parse_Exception_List (Result_Get, Success, "getraises"); end if; if not Success then return; end if; if Get_Token = T_SetRaises then Next_Token; Parse_Exception_List (Result_Set, Success, "setraises"); if not Success then return; end if; if Get_Token = T_GetRaises then Idlac_Errors.Error ("getraises statement must preceed setraises statement", Idlac_Errors.Error, Get_Token_Location); Success := False; end if; end if; end Parse_Attr_Raises_Expr; -------------------------- -- Parsing of pragmas -- -------------------------- -------------------- -- Parse_Pragma -- -------------------- procedure Parse_Pragma (Result : out Node_Id; Success : out Boolean) is begin pragma Debug (O2 ("Parse_Pragma: enter")); Result := No_Node; Success := False; Next_Token; if Get_Token /= T_Identifier then Idlac_Errors.Error ("pragma identifier expected", Idlac_Errors.Error, Get_Token_Location); Go_To_End_Of_Pragma; return; end if; declare Pragma_Id : constant String := Get_Token_String; begin if Pragma_Id = "ID" then ----------------------------------------- -- #pragma ID -- -- -- -- Explicitly give a RepositoryID to a -- -- named entity. -- ----------------------------------------- declare Name_Node : Node_Id; String_Lit_Node : Node_Id; Res_Success : Boolean; String_Constant_Type : Constant_Value_Ptr := new Constant_Value (Kind => C_String); begin String_Constant_Type.String_Length := -1; Next_Token; Parse_Scoped_Name (Name_Node, Res_Success); if not Res_Success then Go_To_End_Of_Pragma; return; end if; Parse_String_Literal (String_Lit_Node, Res_Success, String_Constant_Type); Free (String_Constant_Type); if not Res_Success then Idlac_Errors.Error ("Repository ID expected.", Idlac_Errors.Error, Get_Token_Location); Go_To_End_Of_Pragma; return; end if; if Name_Node /= No_Node then if Is_Explicit_Repository_Id (Value (Name_Node)) then Idlac_Errors.Error ("Entity already has an explicit repository ID.", Idlac_Errors.Error, Get_Token_Location); Go_To_End_Of_Pragma; return; end if; Set_Is_Explicit_Repository_Id (Value (Name_Node), True); Set_Repository_Id (Value (Name_Node), String_Lit_Node); end if; -- pragma ID does not generate any node: -- return with Success = False. end; elsif Pragma_Id = "prefix" then --------------------------------------- -- #pragma prefix -- -- -- -- Set the current Repository Id for -- -- the current scope. -- --------------------------------------- declare String_Lit_Node : Node_Id; Res_Success : Boolean; Val : constant Constant_Value_Ptr := new Constant_Value (Kind => C_String); begin Val.String_Length := -1; Next_Token; Parse_String_Literal (String_Lit_Node, Res_Success, Val); if not Res_Success then Idlac_Errors.Error ("Repository ID prefix expected.", Idlac_Errors.Error, Get_Token_Location); Go_To_End_Of_Pragma; return; end if; Set_Current_Prefix (Get_Current_Scope, String_Lit_Node); -- pragma prefix does not generate any node: -- return with Success = False. end; elsif Pragma_Id = "version" then ---------------------------------------------- -- #pragma version -- -- -- -- Set the current version of the -- -- Repository Id for a given name -- ---------------------------------------------- declare Name_Node : Node_Id; Rep_Id : Node_Id; Res_Success : Boolean; Version : Version_Type; begin Next_Token; Parse_Scoped_Name (Name_Node, Res_Success); if not Res_Success then Go_To_End_Of_Pragma; return; end if; Parse_Version (Version, Res_Success); if not (Res_Success) then Go_To_End_Of_Pragma; return; end if; if Name_Node /= No_Node then if Is_Explicit_Version_Id (Value (Name_Node)) or else Is_Explicit_Repository_Id (Value (Name_Node)) then Idlac_Errors.Error ("Entity already has an explicit version ID.", Idlac_Errors.Error, Get_Token_Location); Go_To_End_Of_Pragma; return; end if; Set_Is_Explicit_Version_Id (Value (Name_Node), True); Rep_Id := Repository_Id (Value (Name_Node)); -- replace the former version, (should be 1.0) declare use Ada.Strings.Unbounded; New_Rep : Unbounded_String := To_Unbounded_String (String_Value (Rep_Id)); Smajor : constant String := Interfaces.Unsigned_16'Image (Version.Major); Sminor : constant String := Interfaces.Unsigned_16'Image (Version.Minor); begin Replace_Slice (New_Rep, Index (To_Unbounded_String (String_Value (Rep_Id)), ":1.0") + 1, String_Value (Rep_Id)'Length, Smajor ((Smajor'First + 1) .. Smajor'Last) & "." & Sminor ((Sminor'First + 1) .. Sminor'Last)); Set_String_Value (Rep_Id, To_String (New_Rep)); end; end if; -- pragma version does not generate any node: -- return with Success = False. end; else Idlac_Errors.Error ("Unknown pragma: " & Pragma_Id & ", will be ignored.", Idlac_Errors.Warning, Get_Token_Location); Go_To_End_Of_Pragma; return; end if; if Get_Token /= T_End_Pragma then Idlac_Errors.Error ("unexpected end of pragma line : the end will be ignored.", Idlac_Errors.Error, Get_Token_Location); Go_To_End_Of_Pragma; return; end if; -- consumes the end_of_pragma token Next_Token; return; end; pragma Debug (O2 ("Parse_Pragma: leave")); end Parse_Pragma; --------------------------- -- Parsing of literals -- --------------------------- -------------------------- -- Hexa_Char_To_Digit -- -------------------------- function Hexa_Char_To_Digit (C : Character) return Integer is use Ada.Characters.Latin_1; Result : Integer; begin Result := Character'Pos (C); if Result >= Character'Pos ('0') and then Result <= Character'Pos ('9') then Result := Result - Character'Pos ('0'); elsif Result >= Character'Pos (LC_A) and then Result <= Character'Pos (LC_F) then Result := Result + 10 - Character'Pos ('a'); else Result := Result + 10 - Character'Pos ('A'); end if; return Result; end Hexa_Char_To_Digit; ------------------------ -- Get_Char_Literal -- ------------------------ procedure Get_Char_Literal (S : String; Result : out Idl_Character; Offset : out Integer) is use Ada.Characters.Latin_1; begin if S (S'First) = '\' then Offset := 2; case S (S'First + 1) is when LC_N => Result := LF; when LC_T => Result := HT; when LC_V => Result := VT; when LC_B => Result := BS; when LC_R => Result := CR; when LC_F => Result := FF; when LC_A => Result := BEL; when '\' => Result := '\'; when '?' => Result := '?'; when ''' => Result := '''; when Quotation => Result := Quotation; when '0' .. '7' => declare Pos : Integer; begin Pos := Character'Pos (S (S'First + 1)) - Character'Pos ('0'); for G in 2 .. 3 loop if G < S'Length then case S (S'First + G) is when '0' .. '7' => Pos := 8 * Pos + Character'Pos (S (S'First + G)) - Character'Pos ('0'); Offset := G + 1; when others => exit; end case; end if; end loop; Result := Character'Val (Pos); end; when LC_X => declare Pos : Integer; begin Pos := Hexa_Char_To_Digit (S (S'First + 2)); Offset := 3; pragma Debug (O ("Get_Char_Literal : Pos = " & Integer'Image (Pos))); if S'Length > 3 then case S (S'First + 3) is when '0' .. '9' | 'A' .. 'F' | LC_A .. LC_F => Pos := (16 * Pos) + Hexa_Char_To_Digit (S (S'First + 3)); Offset := 4; when others => null; end case; end if; pragma Debug (O ("Get_Char_Literal : Pos = " & Integer'Image (Pos))); Result := Character'Val (Pos); end; when others => raise Idlac_Errors.Internal_Error; end case; else Result := S (S'First); Offset := 1; end if; end Get_Char_Literal; ----------------------------- -- Get_Wide_Char_Literal -- ----------------------------- procedure Get_Wide_Char_Literal (S : String; Result : out Idl_Wide_Character; Offset : out Integer) is use Ada.Characters.Latin_1; begin if S (S'First) = '\' then Offset := 2; case S (S'First + 1) is when LC_N => Result := Wide_Character'Val (Character'Pos (ASCII.LF)); when LC_T => Result := Wide_Character'Val (Character'Pos (ASCII.HT)); when LC_V => Result := Wide_Character'Val (Character'Pos (ASCII.VT)); when LC_B => Result := Wide_Character'Val (Character'Pos (ASCII.BS)); when LC_R => Result := Wide_Character'Val (Character'Pos (CR)); when LC_F => Result := Wide_Character'Val (Character'Pos (FF)); when LC_A => Result := Wide_Character'Val (Character'Pos (BEL)); when '\' => Result := '\'; when '?' => Result := '?'; when ''' => Result := '''; when Quotation => Result := Wide_Character'Val (Character'Pos (Quotation)); when '0' .. '7' => declare Pos : Integer; begin Pos := Character'Pos (S (S'First + 1)) - Character'Pos ('0'); for G in 2 .. 3 loop if G < S'Length then case S (S'First + G) is when '0' .. '7' => Pos := 8 * Pos + Character'Pos (S (S'First + G)) - Character'Pos ('0'); Offset := G + 1; when others => exit; end case; end if; end loop; Result := Wide_Character'Val (Pos); end; when LC_X => declare Pos : Integer; begin Pos := Hexa_Char_To_Digit (S (S'First + 2)); Offset := 3; pragma Debug (O ("Get_Char_Literal : Pos = " & Integer'Image (Pos))); if S'Length > 3 then case S (S'First + 3) is when '0' .. '9' | 'A' .. 'F' | LC_A .. LC_F => Pos := (16 * Pos) + Hexa_Char_To_Digit (S (S'First + 3)); Offset := 4; when others => null; end case; end if; pragma Debug (O ("Get_Char_Literal : Pos = " & Integer'Image (Pos))); Result := Wide_Character'Val (Pos); end; when LC_U => declare Pos : Integer; begin Pos := Hexa_Char_To_Digit (S (S'First + 2)); Offset := 3; for G in 3 .. 5 loop if G < S'Length then case S (S'First + G) is when '0' .. '9' | 'A' .. 'F' | LC_A .. LC_F => Pos := 16 * Pos + Hexa_Char_To_Digit (S (S'First + G)); Offset := G + 1; when others => exit; end case; end if; end loop; Result := Wide_Character'Val (Pos); end; when others => raise Idlac_Errors.Internal_Error; end case; else Result := Wide_Character'Val (Character'Pos (S (S'First))); Offset := 1; end if; end Get_Wide_Char_Literal; --------------------------- -- Get_Integer_Literal -- --------------------------- function Get_Integer_Literal return Idl_Integer is S : constant String := Get_Token_String; Result : Idl_Integer := 0; I : Natural := 0; begin pragma Debug (O2 ("Get_Integer_Literal: enter")); case Get_Token is when T_Lit_Decimal_Integer => while I < S'Length loop Result := Result * 10 + (Character'Pos (S (S'First + I)) - Character'Pos ('0')); I := I + 1; end loop; when T_Lit_Octal_Integer => I := 1; while I < S'Length loop Result := Result * 8 + (Character'Pos (S (S'First + I)) - Character'Pos ('0')); I := I + 1; end loop; when T_Lit_Hexa_Integer => I := 2; while I < S'Length loop Result := Result * 16 + Idl_Integer (Hexa_Char_To_Digit (S (S'First + I))); I := I + 1; end loop; when others => return Result; end case; pragma Debug (O2 ("Get_Integer_Literal: end")); return Result; end Get_Integer_Literal; --------------------- -- Parse_Version -- --------------------- procedure Parse_Version (Result : out Version_Type; Success : out Boolean) is begin if Get_Token /= T_Lit_Simple_Floating_Point then Idlac_Errors.Error ("Invalid version number.", Idlac_Errors.Error, Get_Token_Location); Success := False; Result.Minor := 0; Result.Major := 1; return; end if; declare S : constant String := Get_Token_String; Minor : Interfaces.Unsigned_16 := 0; Major : Interfaces.Unsigned_16 := 0; I : Natural := 0; use Interfaces; begin while S (S'First + I) /= '.' loop Major := Major * 10 + (Character'Pos (S (S'First + I)) - Character'Pos ('0')); I := I + 1; end loop; I := I + 1; while I < S'Length loop Minor := Minor * 10 + (Character'Pos (S (S'First + I)) - Character'Pos ('0')); I := I + 1; end loop; Result.Minor := Minor; Result.Major := Major; Success := True; Next_Token; end; end Parse_Version; ----------------------------- -- Parse_Integer_Literal -- ----------------------------- procedure Parse_Integer_Literal (Result : out Node_Id; Success : out Boolean; Expr_Type : Constant_Value_Ptr) is begin pragma Debug (O2 ("Parse_Integer_Literal: enter")); Result := Make_Lit_Integer (Get_Token_Location); case Expr_Type.Kind is when C_Octet | C_Short | C_Long | C_LongLong | C_UShort | C_ULong | C_ULongLong | C_General_Integer => Set_Expr_Value (Result, new Constant_Value (Kind => Expr_Type.Kind)); Expr_Value (Result).Integer_Value := Get_Integer_Literal; Check_Value_Range (Result, False); when others => Set_Expr_Value (Result, new Constant_Value (Kind => C_No_Kind)); Idlac_Errors.Error ("The specified type for this constant " & "does not match with its value.", Idlac_Errors.Error, Get_Token_Location); end case; Next_Token; Success := True; pragma Debug (O2 ("Parse_Integer_Literal: end")); return; end Parse_Integer_Literal; ---------------------------- -- Parse_String_Literal -- ---------------------------- procedure Parse_String_Literal (Result : out Node_Id; Success : out Boolean; Expr_Type : Constant_Value_Ptr) is function Get_String_Literal return Idl_String; function Get_String_Literal return Idl_String is S : constant String := Get_Token_String; Result : String (1 .. S'Length); L : Natural := 0; I : Natural := 0; Offset : Integer; C : Character; use Ada.Characters.Latin_1; begin while I < S'Length loop if S (S'First + I) = Quotation then I := I + 2; else L := L + 1; Get_Char_Literal (S (S'First + I .. S'Last), C, Offset); Result (L) := C; I := I + Offset; end if; end loop; if Expr_Type.String_Length >= 0 then if L > Integer (Expr_Type.String_Length) then Idlac_Errors.Error ("This value does not match with the specified type : " & "the string is too long.", Idlac_Errors.Error, Get_Token_Location); end if; end if; return new String'(Result (1 .. L)); end Get_String_Literal; begin pragma Debug (O2 ("Parse_String_Literal: enter")); if Get_Token /= T_Lit_String then Idlac_Errors.Error ("String literal expected here.", Idlac_Errors.Error, Get_Token_Location); Result := No_Node; Success := False; pragma Debug (O2 ("Parse_String_Literal: end")); return; end if; Result := Make_Lit_String (Get_Token_Location); if Expr_Type.Kind = C_String then Set_Expr_Value (Result, new Constant_Value (Kind => C_String)); Expr_Value (Result).String_Value := Get_String_Literal; else Set_Expr_Value (Result, new Constant_Value (Kind => C_No_Kind)); Idlac_Errors.Error ("The specified type for this constant " & "does not match with its value.", Idlac_Errors.Error, Get_Token_Location); end if; Next_Token; Success := True; pragma Debug (O2 ("Parse_String_Literal: end")); return; end Parse_String_Literal; --------------------------------- -- Parse_Wide_String_Literal -- --------------------------------- procedure Parse_Wide_String_Literal (Result : out Node_Id; Success : out Boolean; Expr_Type : Constant_Value_Ptr) is function Get_WString_Literal return Idl_Wide_String; function Get_WString_Literal return Idl_Wide_String is S : constant String := Get_Token_String; Result : Wide_String (1 .. S'Length); L : Natural := 0; I : Natural := 0; Offset : Integer; C : Wide_Character; use Ada.Characters.Latin_1; begin while I < S'Length loop if S (S'First + I) = Quotation then I := I + 2; else L := L + 1; Get_Wide_Char_Literal (S (S'First + I .. S'Last), C, Offset); Result (L) := C; I := I + Offset; end if; end loop; if Expr_Type.WString_Length >= 0 then if L > Integer (Expr_Type.WString_Length) then Idlac_Errors.Error ("This value does not match with the specified type : " & "the string is too long.", Idlac_Errors.Error, Get_Token_Location); end if; end if; return new Wide_String'(Result (1 .. L)); end Get_WString_Literal; begin if Get_Token /= T_Lit_Wide_String then Idlac_Errors.Error ("Wide string literal expected here.", Idlac_Errors.Error, Get_Token_Location); Result := No_Node; Success := False; return; end if; Result := Make_Lit_Wide_String (Get_Token_Location); if Expr_Type.Kind = C_WString then Set_Expr_Value (Result, new Constant_Value (Kind => C_WString)); Expr_Value (Result).WString_Value := Get_WString_Literal; else Set_Expr_Value (Result, new Constant_Value (Kind => C_No_Kind)); Idlac_Errors.Error ("The specified type for this constant " & "does not match with its value.", Idlac_Errors.Error, Get_Token_Location); end if; Next_Token; Success := True; return; end Parse_Wide_String_Literal; -------------------------- -- Parse_Char_Literal -- -------------------------- procedure Parse_Char_Literal (Result : out Node_Id; Success : out Boolean; Expr_Type : Constant_Value_Ptr) is begin Result := Make_Lit_Character (Get_Token_Location); if Expr_Type.Kind = C_Char then declare Useless : Integer; C : Character; begin Set_Expr_Value (Result, new Constant_Value (Kind => C_Char)); Get_Char_Literal (Get_Token_String, C, Useless); Expr_Value (Result).Char_Value := C; end; else Set_Expr_Value (Result, new Constant_Value (Kind => C_No_Kind)); Idlac_Errors.Error ("The specified type for this constant " & "does not match with its value.", Idlac_Errors.Error, Get_Token_Location); end if; Next_Token; Success := True; return; end Parse_Char_Literal; ------------------------------- -- Parse_Wide_Char_Literal -- ------------------------------- procedure Parse_Wide_Char_Literal (Result : out Node_Id; Success : out Boolean; Expr_Type : Constant_Value_Ptr) is begin Result := Make_Lit_Wide_Character (Get_Token_Location); if Expr_Type.Kind = C_WChar then declare Useless : Integer; C : Wide_Character; begin Set_Expr_Value (Result, new Constant_Value (Kind => C_WChar)); Get_Wide_Char_Literal (Get_Token_String, C, Useless); Expr_Value (Result).WChar_Value := C; end; else Set_Expr_Value (Result, new Constant_Value (Kind => C_No_Kind)); Idlac_Errors.Error ("The specified type for this constant " & "does not match with its value.", Idlac_Errors.Error, Get_Token_Location); end if; Next_Token; Success := True; return; end Parse_Wide_Char_Literal; ---------------------------- -- Get_Floating_Literal -- ---------------------------- function Get_Float_Literal return Idl_Float is S : constant String := Get_Token_String; Result : Idl_Float := 0.0; I : Natural := 0; begin while S (S'First + I) /= '.' and then S (S'First + I) /= 'e' and then S (S'First + I) /= 'E' loop Result := Result * 10.0 + Idl_Float (Character'Pos (S (S'First + I)) - Character'Pos ('0')); I := I + 1; end loop; if Get_Token = T_Lit_Simple_Floating_Point or else Get_Token = T_Lit_Exponent_Floating_Point then I := I + 1; declare Offset : Idl_Float := 0.1; begin while I < S'Length and then (S (S'First + I) /= 'e' and then S (S'First + I) /= 'E') loop Result := Result + Offset * Idl_Float (Character'Pos (S (S'First + I)) - Character'Pos ('0')); I := I + 1; Offset := Offset / 10.0; end loop; end; end if; if Get_Token = T_Lit_Exponent_Floating_Point or else Get_Token = T_Lit_Pure_Exponent_Floating_Point then declare Exponent : Integer := 0; begin I := I + 1; while I < S'Length loop Exponent := Exponent * 10 + (Character'Pos (S (S'First + I)) - Character'Pos ('0')); I := I + 1; end loop; Result := Result * (10.0 ** Exponent); end; end if; return Result; end Get_Float_Literal; --------------------------------- -- Parse_Floating_Pt_Literal -- --------------------------------- procedure Parse_Floating_Pt_Literal (Result : out Node_Id; Success : out Boolean; Expr_Type : Constant_Value_Ptr) is begin Result := Make_Lit_Floating_Point (Get_Token_Location); case Expr_Type.Kind is when C_Float | C_Double | C_LongDouble | C_General_Float => Set_Expr_Value (Result, new Constant_Value (Kind => Expr_Type.Kind)); Expr_Value (Result).Float_Value := Get_Float_Literal; Check_Value_Range (Result, False); when others => Set_Expr_Value (Result, new Constant_Value (Kind => C_No_Kind)); Idlac_Errors.Error ("The specified type for this constant " & "does not match with its value.", Idlac_Errors.Error, Get_Token_Location); end case; Next_Token; Success := True; return; end Parse_Floating_Pt_Literal; ------------------------------ -- Parse_Fixed_Pt_Literal -- ------------------------------ procedure Parse_Fixed_Pt_Literal (Result : out Node_Id; Success : out Boolean; Expr_Type : Constant_Value_Ptr) is procedure Get_Fixed_Literal; procedure Get_Fixed_Literal is S : constant String := Get_Token_String; Res : Idl_Integer := 0; I : Natural := 0; L1, L2 : Natural := 0; Last_Zeros_Nb : Natural := 0; begin -- first remove leading zeros while S (S'First + I) = '0' loop I := I + 1; end loop; -- parse the integer part while S (S'First + I) /= '.' and then S (S'First + I) /= 'd' and then S (S'First + I) /= 'D' loop Res := Res * 10 + Idl_Integer (Character'Pos (S (S'First + I)) - Character'Pos ('0')); if S (S'First + I) = '0' then Last_Zeros_Nb := Last_Zeros_Nb + 1; else Last_Zeros_Nb := 0; end if; I := I + 1; L1 := L1 + 1; end loop; -- parse fractionnal part if Get_Token = T_Lit_Floating_Fixed_Point then I := I + 1; while S (S'First + I) /= 'd' and then S (S'First + I) /= 'D' loop Res := Res * 10 + Idl_Integer (Character'Pos (S (S'First + I)) - Character'Pos ('0')); if S (S'First + I) = '0' then Last_Zeros_Nb := Last_Zeros_Nb + 1; else Last_Zeros_Nb := 0; end if; I := I + 1; L2 := L2 + 1; end loop; end if; Res := Res / 10 ** Last_Zeros_Nb; -- check type precision if (L1 /= 0 and then Idl_Integer (L1) > Expr_Type.Digits_Nb - Expr_Type.Scale) or else (Idl_Integer (L2 - Last_Zeros_Nb) > Expr_Type.Scale) then Idlac_Errors.Error ("The specified type for this constant " & "is not enough precise for this value. " & "A more precise type will be used.", Idlac_Errors.Error, Get_Token_Location); Set_Expr_Value (Result, new Constant_Value (Kind => C_General_Fixed)); else Set_Expr_Value (Result, new Constant_Value (Kind => C_Fixed)); end if; -- stores results Expr_Value (Result).Fixed_Value := Res; Expr_Value (Result).Digits_Nb := Idl_Integer (L1 + L2 - Last_Zeros_Nb); Expr_Value (Result).Scale := Idl_Integer (L2 - Last_Zeros_Nb); end Get_Fixed_Literal; begin Result := Make_Lit_Fixed_Point (Get_Token_Location); if Expr_Type.Kind = C_Fixed then Get_Fixed_Literal; else Set_Expr_Value (Result, new Constant_Value (Kind => C_No_Kind)); Idlac_Errors.Error ("The specified type for this constant " & "does not match with its value.", Idlac_Errors.Error, Get_Token_Location); end if; Next_Token; Success := True; return; end Parse_Fixed_Pt_Literal; ----------------------- -- Check_Value_Range -- ----------------------- procedure Check_Value_Range (Node : Node_Id; Full : Boolean) is N : Constant_Value_Ptr renames Expr_Value (Node); procedure Integer_Precision_Exceeded; procedure Float_Precision_Exceeded; procedure Fixed_Precision_Exceeded; procedure Integer_Precision_Exceeded is Old_Value : Constant_Value_Ptr := Expr_Value (Node); begin pragma Debug (O2 ("Integer_Precision_Exceeded: enter")); Idlac_Errors.Error ("The specified type for this integer constant " & "does not allow this value", Idlac_Errors.Error, Get_Token_Location); Set_Expr_Value (Node, new Constant_Value (Kind => C_General_Integer)); Expr_Value (Node).Integer_Value := Old_Value.Integer_Value; Free (Old_Value); pragma Debug (O2 ("Integer_Precision_Exceeded: end")); end Integer_Precision_Exceeded; procedure Float_Precision_Exceeded is Old_Value : Constant_Value_Ptr := Expr_Value (Node); begin pragma Debug (O2 ("Float_Precision_Exceeded: enter")); Idlac_Errors.Error ("The specified type for this floating point constant " & "does not allow this value", Idlac_Errors.Error, Get_Token_Location); Set_Expr_Value (Node, new Constant_Value (Kind => C_General_Float)); Expr_Value (Node).Float_Value := Old_Value.Float_Value; Free (Old_Value); pragma Debug (O2 ("Float_Precision_Exceeded: end")); end Float_Precision_Exceeded; procedure Fixed_Precision_Exceeded is Old_Value : Constant_Value_Ptr := Expr_Value (Node); begin pragma Debug (O2 ("Fixed_Precision_Exceeded: enter")); Idlac_Errors.Error ("invalid number of digits in fixed point " & "type definition : it should be in range " & "0 .. 31.", Idlac_Errors.Error, Get_Token_Location); Set_Expr_Value (Node, new Constant_Value (Kind => C_General_Fixed)); Expr_Value (Node).Fixed_Value := Old_Value.Fixed_Value; Expr_Value (Node).Digits_Nb := Old_Value.Digits_Nb; Expr_Value (Node).Scale := Old_Value.Scale; Free (Old_Value); pragma Debug (O2 ("Float_Precision_Exceeded: end")); end Fixed_Precision_Exceeded; begin pragma Debug (O2 ("Check_Value_Range: enter")); pragma Debug (O ("Check_Value_Range : Kind (Node) is " & Node_Kind'Image (Kind (Node)) & ", Full = " & Boolean'Image (Full))); pragma Debug (O ("Check_Value_Range : N.kind is " & Const_Kind'Image (N.Kind))); pragma Assert (Kind (Node) = K_Add_Expr or else Kind (Node) = K_And_Expr or else Kind (Node) = K_Binary_Expr or else Kind (Node) = K_Div_Expr or else Kind (Node) = K_Expr or else Kind (Node) = K_Id_Expr or else Kind (Node) = K_Lit_Boolean or else Kind (Node) = K_Lit_Character or else Kind (Node) = K_Lit_Enum or else Kind (Node) = K_Lit_Fixed_Point or else Kind (Node) = K_Lit_Floating_Point or else Kind (Node) = K_Lit_Integer or else Kind (Node) = K_Lit_String or else Kind (Node) = K_Lit_Wide_Character or else Kind (Node) = K_Lit_Wide_String or else Kind (Node) = K_Literal or else Kind (Node) = K_Mod_Expr or else Kind (Node) = K_Mul_Expr or else Kind (Node) = K_Neg_Expr or else Kind (Node) = K_Not_Expr or else Kind (Node) = K_Or_Expr or else Kind (Node) = K_Shl_Expr or else Kind (Node) = K_Shr_Expr or else Kind (Node) = K_Sub_Expr or else Kind (Node) = K_Unary_Expr or else Kind (Node) = K_Xor_Expr); case N.Kind is when C_Octet => if N.Integer_Value < Idl_Octet_Min or else N.Integer_Value > Idl_Octet_Max then Integer_Precision_Exceeded; end if; when C_Short => if Full then if N.Integer_Value < Idl_Short_Min or else N.Integer_Value > Idl_Short_Max then Integer_Precision_Exceeded; end if; else if N.Integer_Value < Idl_Short_Min or else N.Integer_Value > Idl_UShort_Max then Integer_Precision_Exceeded; end if; end if; when C_Long => if Full then if N.Integer_Value < Idl_Long_Min or else N.Integer_Value > Idl_Long_Max then Integer_Precision_Exceeded; end if; else if N.Integer_Value < Idl_Long_Min or else N.Integer_Value > Idl_ULong_Max then Integer_Precision_Exceeded; end if; end if; when C_LongLong => if Full then pragma Warnings (Off); -- Condition is always false. if N.Integer_Value < Idl_LongLong_Min or else N.Integer_Value > Idl_LongLong_Max then Integer_Precision_Exceeded; end if; pragma Warnings (On); else pragma Warnings (Off); -- Condition is always false. if N.Integer_Value < Idl_LongLong_Min or else N.Integer_Value > Idl_ULongLong_Max then Integer_Precision_Exceeded; end if; pragma Warnings (On); end if; when C_UShort => if Full then if N.Integer_Value < Idl_UShort_Min or else N.Integer_Value > Idl_UShort_Max then Integer_Precision_Exceeded; end if; else if N.Integer_Value < Idl_Short_Min or else N.Integer_Value > Idl_UShort_Max then Integer_Precision_Exceeded; end if; end if; when C_ULong => if Full then if N.Integer_Value < Idl_ULong_Min or else N.Integer_Value > Idl_ULong_Max then Integer_Precision_Exceeded; end if; else if N.Integer_Value < Idl_Long_Min or else N.Integer_Value > Idl_ULong_Max then Integer_Precision_Exceeded; end if; end if; when C_ULongLong => if Full then if N.Integer_Value < Idl_ULongLong_Min or else N.Integer_Value > Idl_ULongLong_Max then Integer_Precision_Exceeded; end if; else pragma Warnings (Off); -- Condition is always false. if N.Integer_Value < Idl_LongLong_Min or else N.Integer_Value > Idl_ULongLong_Max then Integer_Precision_Exceeded; end if; pragma Warnings (On); end if; when C_Float => if N.Float_Value < Idl_Float_Min or else N.Float_Value > Idl_Float_Max then Float_Precision_Exceeded; end if; when C_Double => if N.Float_Value < Idl_Double_Min or else N.Float_Value > Idl_Double_Max then Float_Precision_Exceeded; end if; when C_LongDouble => if N.Float_Value < Idl_Long_Double_Min or else N.Float_Value > Idl_Long_Double_Max then Float_Precision_Exceeded; end if; when C_Fixed | C_General_Fixed => -- simplification of a fixed point literal if N.Fixed_Value /= 0 then -- first remove the trailing zeros while N.Fixed_Value mod 10 = 0 loop N.Fixed_Value := N.Fixed_Value / 10; N.Digits_Nb := N.Digits_Nb - 1; N.Scale := N.Scale + 1; end loop; -- then remove the leading zeros while N.Fixed_Value / 10 ** Natural (N.Digits_Nb - 1) = 0 loop N.Digits_Nb := N.Digits_Nb - 1; end loop; else N.Digits_Nb := 0; N.Scale := 0; end if; -- Checks the number of digits if N.Digits_Nb > 31 then Fixed_Precision_Exceeded; end if; when others => null; end case; pragma Debug (O2 ("Check_Value_Range: end")); end Check_Value_Range; ------------------------ -- Check_Expr_Value -- ------------------------ procedure Check_Expr_Value (Value : Constant_Value_Ptr; Value_Type : Constant_Value_Ptr) is Types_Ok : Boolean := True; begin pragma Debug (O2 ("Check_Expr_Value: enter")); case Value.Kind is when C_General_Integer => pragma Debug (O ("Check_Expr_Value : " & "dealing with a General_Integer")); case Value_Type.Kind is when C_Octet | C_Short | C_Long | C_LongLong | C_UShort | C_ULong | C_ULongLong => null; when others => Types_Ok := False; end case; when C_General_Float => pragma Debug (O ("Check_Expr_Value : " & "dealing with a General_Float")); case Value_Type.Kind is when C_Float | C_Double | C_LongDouble => null; when others => Types_Ok := False; end case; when C_General_Fixed => pragma Debug (O ("Check_Expr_Value : " & "dealing with a General_Fixed")); if Value_Type.Kind /= C_Fixed then Types_Ok := False; end if; when others => pragma Debug (O ("Check_Expr_Value : " & "dealing with something else")); case Value_Type.Kind is when C_General_Integer => case Value.Kind is when C_Octet | C_Short | C_Long | C_LongLong | C_UShort | C_ULong | C_ULongLong => null; when others => Types_Ok := False; end case; when C_General_Float => case Value.Kind is when C_Float | C_Double | C_LongDouble => null; when others => Types_Ok := False; end case; when C_General_Fixed => if Value.Kind /= C_Fixed then Types_Ok := False; end if; when others => if Value.Kind /= Value_Type.Kind then Types_Ok := False; end if; end case; end case; if Types_Ok then case Value.Kind is when C_Fixed => if Value.Digits_Nb - Value.Scale > Value_Type.Digits_Nb - Value_Type.Scale or else Value.Scale > Value_Type.Scale then Idlac_Errors.Error ("The specified type for this fixed point " & "constant is not enough precise for its value. " & "A more precise type will be used.", Idlac_Errors.Error, Get_Token_Location); end if; when C_Enum => if Value.Enum_Name /= Value_Type.Enum_Name then Idlac_Errors.Error ("The specified type for this enum constant " & "does not match with its value.", Idlac_Errors.Error, Get_Token_Location); end if; when others => null; end case; else Idlac_Errors.Error ("The specified type for this constant " & "does not match with its value.", Idlac_Errors.Error, Get_Token_Location); end if; null; pragma Debug (O2 ("Check_Expr_Value: end")); end Check_Expr_Value; ---------------------------- -- Check_Context_String -- ---------------------------- procedure Check_Context_String (S : String) is use GNAT.Case_Util; use Ada.Characters.Latin_1; begin if S'Length = 0 then return; end if; if To_Lower (S (S'First)) not in LC_A .. LC_Z then Idlac_Errors.Error ("invalid string for context " & "declaration : the first character " & "must be an alphabetic one.", Idlac_Errors.Error, Get_Token_Location); return; end if; for I in S'First + 1 .. S'Last - 1 loop if To_Lower (S (I)) not in LC_A .. LC_Z and then S (I) not in '0' .. '9' and then S (I) /= '.' and then S (I) /= '_' then Idlac_Errors.Error ("invalid string for context " & "declaration : it may only content " & "alphabetic, digit, period, underscore " & "characters plus an asterisk at the end.", Idlac_Errors.Error, Get_Token_Location); return; end if; end loop; if To_Lower (S (S'Last)) not in LC_A .. LC_Z and then S (S'Last) not in '0' .. '9' and then S (S'Last) /= '.' and then S (S'Last) /= '_' and then S (S'Last) /= '*' then Idlac_Errors.Error ("invalid string for context " & "declaration : the last character may only " & "be an alphabetic, digit, period, " & "underscore or asterisk character.", Idlac_Errors.Error, Get_Token_Location); return; end if; end Check_Context_String; ------------------------------- -- Evaluation of expressions -- ------------------------------- -------- -- Or -- -------- function "or" (X, Y : Idl_Integer) return Idl_Integer is I : Idl_Integer := 0; Res : Idl_Integer := 0; Exp : Idl_Integer := 1; XX : Idl_Integer := abs X; YY : Idl_Integer := abs Y; begin while XX > 0 or else YY > 0 loop if (XX mod 2 = 1) or else (YY mod 2 = 1) then Res := Res + Exp; end if; I := I + 1; Exp := Exp * 2; XX := XX / 2; YY := YY / 2; end loop; if X < 0 or else Y < 0 then return -Res; else return Res; end if; end "or"; --------- -- Xor -- --------- function "xor" (X, Y : Idl_Integer) return Idl_Integer is I : Idl_Integer := 0; Res : Idl_Integer := 0; Exp : Idl_Integer := 1; XX : Idl_Integer := abs X; YY : Idl_Integer := abs Y; begin while XX > 0 or else YY > 0 loop if XX mod 2 + YY mod 2 = 1 then Res := Res + Exp; end if; I := I + 1; Exp := Exp * 2; XX := XX / 2; YY := YY / 2; end loop; if (X < 0 and then Y < 0) or else (X > 0 and then Y > 0) then return Res; else return -Res; end if; end "xor"; --------- -- And -- --------- function "and" (X, Y : Idl_Integer) return Idl_Integer is I : Idl_Integer := 0; Res : Idl_Integer := 0; Exp : Idl_Integer := 1; XX : Idl_Integer := abs X; YY : Idl_Integer := abs Y; begin while XX > 0 or else YY > 0 loop if (XX mod 2 = 1) and then (YY mod 2 = 1) then Res := Res + Exp; end if; I := I + 1; Exp := Exp * 2; XX := XX / 2; YY := YY / 2; end loop; if X < 0 and then Y < 0 then return -Res; else return Res; end if; end "and"; ---------------- -- Shift_Left -- ---------------- function Shift_Left (X : Idl_Integer; Y : Natural) return Idl_Integer is begin return X * 2 ** Y; end Shift_Left; ----------------- -- Shift_Right -- ----------------- function Shift_Right (X : Idl_Integer; Y : Natural) return Idl_Integer is begin return X / 2 ** Y; end Shift_Right; --------- -- Max -- --------- function Max (X, Y : Idl_Integer) return Idl_Integer is begin if X > Y then return X; else return Y; end if; end Max; --------------- -- Fixed_Add -- --------------- procedure Fixed_Add (Res, Left, Right : Constant_Value_Ptr) is begin pragma Assert (Res.Kind = C_Fixed); pragma Assert (Left.Kind = C_Fixed); pragma Assert (Right.Kind = C_Fixed); Res.Digits_Nb := 1 + Max (Left.Digits_Nb - Left.Scale, Right.Digits_Nb - Right.Scale) + Max (Left.Scale, Right.Scale); Res.Scale := Max (Left.Scale, Right.Scale); Res.Fixed_Value := Left.Fixed_Value * 10 ** Natural (Res.Scale - Left.Scale) + Right.Fixed_Value * 10 ** Natural (Res.Scale - Right.Scale); end Fixed_Add; --------------- -- Fixed_Sub -- --------------- procedure Fixed_Sub (Res, Left, Right : Constant_Value_Ptr) is begin pragma Assert (Res.Kind = C_Fixed); pragma Assert (Left.Kind = C_Fixed); pragma Assert (Right.Kind = C_Fixed); Res.Digits_Nb := Max (Left.Digits_Nb - Left.Scale, Right.Digits_Nb - Right.Scale) + Max (Left.Scale, Right.Scale) + 1; Res.Scale := Max (Left.Scale, Right.Scale); Res.Fixed_Value := Left.Fixed_Value * 10 ** Natural (Res.Scale - Left.Scale) - Right.Fixed_Value * 10 ** Natural (Res.Scale - Right.Scale); end Fixed_Sub; --------------- -- Fixed_Mul -- --------------- procedure Fixed_Mul (Res, Left, Right : Constant_Value_Ptr) is begin pragma Assert (Res.Kind = C_Fixed); pragma Assert (Left.Kind = C_Fixed); pragma Assert (Right.Kind = C_Fixed); Res.Digits_Nb := Left.Digits_Nb + Right.Digits_Nb; Res.Scale := Left.Scale + Right.Scale; Res.Fixed_Value := Left.Fixed_Value * Right.Fixed_Value; end Fixed_Mul; --------------- -- Fixed_Div -- --------------- procedure Fixed_Div (Res, Left, Right : Constant_Value_Ptr) is Dn, S, Fv : Idl_Integer := 0; Remainder : Idl_Integer; begin pragma Assert (Res.Kind = C_Fixed); pragma Assert (Left.Kind = C_Fixed); pragma Assert (Right.Kind = C_Fixed); Fv := Left.Fixed_Value / Right.Fixed_Value; Remainder := Left.Fixed_Value mod Right.Fixed_Value; declare Ffvv : Idl_Integer := Fv; begin while Ffvv /= 0 loop Dn := Dn + 1; Ffvv := Ffvv / 10; end loop; end; S := Left.Scale - Right.Scale; while Remainder /= 0 and then Dn < 31 loop Fv := Fv * 10 + (Remainder * 10) / Right.Fixed_Value; Dn := Dn + 1; S := S + 1; Remainder := (Remainder * 10) mod Right.Fixed_Value; end loop; Res.Fixed_Value := Fv; Res.Digits_Nb := Dn; Res.Scale := S; end Fixed_Div; -------------- -- Fixed_Id -- -------------- procedure Fixed_Id (Res, Operand : Constant_Value_Ptr) is begin pragma Assert (Res.Kind = C_Fixed); pragma Assert (Operand.Kind = C_Fixed); Res.Digits_Nb := Operand.Digits_Nb; Res.Scale := Operand.Scale; Res.Fixed_Value := Operand.Fixed_Value; end Fixed_Id; --------------- -- Fixed_Neg -- --------------- procedure Fixed_Neg (Res, Operand : Constant_Value_Ptr) is begin pragma Assert (Res.Kind = C_Fixed); pragma Assert (Operand.Kind = C_Fixed); Res.Digits_Nb := Operand.Digits_Nb; Res.Scale := Operand.Scale; Res.Fixed_Value := -Operand.Fixed_Value; end Fixed_Neg; --------- -- not -- --------- function "not" (X : Idl_Integer) return Idl_Integer is I : Idl_Integer := 0; Res : Idl_Integer := 0; Exp : Idl_Integer := 1; XX : Idl_Integer := abs X; begin while XX > 0 loop if XX mod 2 = 0 then Res := Res + Exp; end if; I := I + 1; Exp := Exp * 2; XX := XX / 2; end loop; if X < 0 then return Res; else return -Res; end if; end "not"; -------------------- -- Error recovery -- -------------------- --------------------------- -- Go_To_Next_Definition -- --------------------------- -- Try to reach the beginning of the next definition. -- Called when the parser encounters an error during the -- parsing of a definition in order to try to continue the -- parsing after the bad definition. procedure Go_To_Next_Definition is Num : Natural := 0; begin pragma Debug (O2 ("Go_To_Next_Definition: enter")); while Get_Token /= T_Eof loop if Num = 0 then case Get_Token is when T_Module | T_Interface | T_Exception | T_Union | T_Struct | T_Enum | T_Typedef | T_Custom | T_Abstract | T_Local | T_ValueType | T_Const | T_Right_Cbracket => pragma Debug (O2 ("Go_To_Next_Definition: end")); return; when others => null; end case; end if; if Get_Token = T_Left_Cbracket then Num := Num + 1; end if; if Get_Token = T_Right_Cbracket and then Num > 0 then Num := Num - 1; end if; Next_Token; end loop; pragma Debug (O2 ("Go_To_Next_Definition: end")); end Go_To_Next_Definition; ------------------------- -- Go_To_End_Of_Export -- ------------------------- -- Try to reach the end of en export. -- Called when the parser encounters an error during the -- parsing of an export in order to try to continue the -- parsing after the bad export. procedure Go_To_End_Of_Export is Num : Natural := 0; begin pragma Debug (O2 ("Go_To_Next_Definition: enter")); while Get_Token /= T_Eof loop if Num = 0 then case Get_Token is when T_Readonly | T_Attribute | T_Oneway | T_Void | T_String | T_Wstring | T_Float | T_Double | T_Long | T_Short | T_Unsigned | T_Char | T_Wchar | T_Boolean | T_Octet | T_Any | T_Object | T_ValueBase | T_Colon_Colon | T_Identifier | T_Exception | T_Union | T_Struct | T_Enum | T_Typedef | T_Custom | T_Abstract | T_Const | T_Right_Cbracket => return; when others => null; end case; end if; if Get_Token = T_Left_Cbracket then Num := Num + 1; end if; if Get_Token = T_Right_Cbracket and then Num > 0 then Num := Num - 1; end if; Next_Token; end loop; pragma Debug (O2 ("Go_To_Next_Definition: end")); end Go_To_End_Of_Export; ------------------------------ -- Go_To_Next_Left_Cbracket -- ------------------------------ procedure Go_To_Next_Left_Cbracket is begin pragma Debug (O2 ("Go_To_Next_Left_CBracket: enter")); while Get_Token /= T_Eof and then Get_Token /= T_Left_Cbracket loop Next_Token; end loop; pragma Debug (O2 ("Go_To_Next_Left_CBracket: end")); end Go_To_Next_Left_Cbracket; ------------------------------- -- Go_To_Next_Right_Cbracket -- ------------------------------- procedure Go_To_Next_Right_Cbracket is begin pragma Debug (O2 ("Go_To_Next_Right_CBracket: enter")); while Get_Token /= T_Eof and then Get_Token /= T_Right_Cbracket loop Next_Token; end loop; pragma Debug (O2 ("Go_To_Next_Right_CBracket: end")); end Go_To_Next_Right_Cbracket; ----------------------- -- Go_To_Next_Export -- ----------------------- procedure Go_To_Next_Export is Num : Natural := 0; begin pragma Debug (O2 ("Go_To_Next_Export: enter")); While_Loop : while Get_Token /= T_Eof loop if Num = 0 then case Get_Token is when T_Eof | T_Semi_Colon | T_Right_Cbracket => exit While_Loop; when others => null; end case; end if; if Get_Token = T_Left_Cbracket then Num := Num + 1; end if; if Get_Token = T_Right_Cbracket and then Num > 0 then Num := Num - 1; end if; Next_Token; end loop While_Loop; if Get_Token = T_Semi_Colon then Next_Token; end if; pragma Debug (O2 ("Go_To_Next_Export: end")); end Go_To_Next_Export; ------------------------------ -- Go_To_Next_Value_Element -- ------------------------------ procedure Go_To_Next_Value_Element is Num : Natural := 0; begin pragma Debug (O2 ("Go_To_Next_Value_Element: enter")); While_Loop : while Get_Token /= T_Eof loop if Num = 0 then case Get_Token is when T_Eof | T_Semi_Colon | T_Right_Cbracket => exit While_Loop; when others => null; end case; end if; if Get_Token = T_Left_Cbracket then Num := Num + 1; end if; if Get_Token = T_Right_Cbracket and then Num > 0 then Num := Num - 1; end if; Next_Token; end loop While_Loop; if Get_Token = T_Semi_Colon then Next_Token; end if; pragma Debug (O2 ("Go_To_Next_Value_Element: end")); end Go_To_Next_Value_Element; ------------------------------- -- Go_To_End_Of_State_Member -- ------------------------------- procedure Go_To_End_Of_State_Member is begin pragma Debug (O2 ("Go_To_End_Of_State_Member: enter")); while Get_Token /= T_Eof and then Get_Token /= T_Semi_Colon loop Next_Token; end loop; if Get_Token /= T_Eof then Next_Token; else null; end if; pragma Debug (O2 ("Go_To_End_Of_State_Member: end")); end Go_To_End_Of_State_Member; ---------------------------- -- Go_To_Next_Right_Paren -- ---------------------------- procedure Go_To_Next_Right_Paren is begin pragma Debug (O2 ("Go_To_Next_Right_Paren: enter")); while Get_Token /= T_Eof and then Get_Token /= T_Right_Paren loop Next_Token; end loop; pragma Debug (O2 ("Go_To_Next_Right_Paren: end")); end Go_To_Next_Right_Paren; ----------------------- -- Go_To_Next_Member -- ----------------------- procedure Go_To_Next_Member is begin pragma Debug (O2 ("Go_To_Next_Right_Paren: enter")); while Get_Token /= T_Eof and then Get_Token /= T_Semi_Colon and then Get_Token /= T_Right_Cbracket loop Next_Token; end loop; if Get_Token /= T_Eof and then Get_Token /= T_Right_Cbracket then Next_Token; else null; end if; pragma Debug (O2 ("Go_To_Next_Right_Paren: end")); end Go_To_Next_Member; ----------------------- -- Go_To_End_Of_Case -- ----------------------- procedure Go_To_End_Of_Case is Num : Natural := 0; begin -- Go to the next clause (T_Case or T_Default) or to -- the next right cbracket (if this was the last clause). While_Loop : while Get_Token /= T_Eof loop if Num = 0 then case Get_Token is when T_Eof | T_Case | T_Right_Cbracket => exit While_Loop; when others => null; end case; end if; if Get_Token = T_Left_Cbracket then Num := Num + 1; end if; if Get_Token = T_Right_Cbracket and then Num > 0 then Num := Num - 1; end if; Next_Token; end loop While_Loop; end Go_To_End_Of_Case; ----------------------------- -- Go_To_End_Of_Case_Label -- ----------------------------- procedure Go_To_End_Of_Case_Label is begin -- Go to the next colon and consume it while Get_Token /= T_Colon loop Next_Token; end loop; Next_Token; end Go_To_End_Of_Case_Label; ------------------------------ -- Go_To_End_Of_Scoped_Name -- ------------------------------ procedure Go_To_End_Of_Scoped_Name is begin -- Skip the current token (an identifier) Next_Token; -- While there are '::' tokens, skip them, -- and skip the following identifier. while Get_Token = T_Colon_Colon loop Next_Token; if Get_Token = T_Identifier then Next_Token; end if; end loop; end Go_To_End_Of_Scoped_Name; ------------------------- -- Go_To_End_Of_Pragma -- ------------------------- procedure Go_To_End_Of_Pragma is begin while Get_Token /= T_End_Pragma loop Next_Token; end loop; Next_Token; end Go_To_End_Of_Pragma; ------------------------------ -- Go_To_End_Of_Enumeration -- ------------------------------ procedure Go_To_End_Of_Enumeration is begin Go_To_Next_Right_Cbracket; if Get_Token /= T_Eof then Next_Token; if Get_Token = T_Semi_Colon then Next_Token; end if; end if; end Go_To_End_Of_Enumeration; --------------------------- -- Go_To_Next_Semi_Colon -- --------------------------- procedure Go_To_Next_Semi_Colon is begin while Get_Token /= T_Semi_Colon loop Next_Token; end loop; Next_Token; end Go_To_Next_Semi_Colon; ------------------------ -- Go_To_Next_Greater -- ------------------------ procedure Go_To_Next_Greater is begin while Get_Token /= T_Greater loop Next_Token; end loop; Next_Token; end Go_To_Next_Greater; end Idl_Fe.Parser; polyorb-2.8~20110207.orig/compilers/idlac/ada_be-idl2ada-value_impl.adb0000644000175000017500000002032211750740337024754 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- A D A _ B E . I D L 2 A D A . V A L U E _ I M P L -- -- -- -- B o d y -- -- -- -- Copyright (C) 2001-2002 Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- -- -- PolyORB is maintained by ACT Europe. -- -- (email: sales@act-europe.fr) -- -- -- ------------------------------------------------------------------------------ with Idl_Fe.Tree; use Idl_Fe.Tree; with Idl_Fe.Tree.Synthetic; use Idl_Fe.Tree.Synthetic; with Ada_Be.Identifiers; use Ada_Be.Identifiers; with Ada_Be.Debug; pragma Elaborate_All (Ada_Be.Debug); with Ada_Be.Idl2Ada.Impl; with Ada_Be.Idl2Ada.Skel; package body Ada_Be.Idl2Ada.Value_Impl is Flag : constant Natural := Ada_Be.Debug.Is_Active ("ada_be.idl2ada.value_impl"); procedure O is new Ada_Be.Debug.Output (Flag); ---------------------------------------------- -- End of internal subprograms declarations -- ---------------------------------------------- --------------------- -- Gen_Scope_Spec -- --------------------- procedure Gen_Node_Spec (CU : in out Compilation_Unit; Node : Node_Id) is begin case Kind (Node) is when K_ValueType => NL (CU); Put (CU, "type Object is new "); -- check parent declare Primary_Parent : constant Node_Id := Idl_Fe.Tree.Synthetic.Primary_Parent (Node); begin if Primary_Parent = No_Node then Add_With (CU, "CORBA.Value"); Put (CU, "CORBA.Value.Impl_Base"); else Add_With (CU, Ada_Full_Name (Primary_Parent) & ".Value_Impl"); Put (CU, Ada_Full_Name (Primary_Parent) & ".Value_Impl.Object"); end if; end; -- write members declare First : Boolean := True; It : Node_Iterator; Member_Node : Node_Id; begin Init (It, Contents (Node)); while not Is_End (It) loop Get_Next_Node (It, Member_Node); if Kind (Member_Node) = K_State_Member then declare Decl_Iterator : Node_Iterator; Decl_Node : Node_Id; begin if First then PL (CU, " with record"); II (CU); First := False; end if; Init (Decl_Iterator, State_Declarators (Member_Node)); while not Is_End (Decl_Iterator) loop Get_Next_Node (Decl_Iterator, Decl_Node); if Kind (Decl_Node) = K_Declarator then Gen_Node_Stubs_Spec (CU, Decl_Node); Put (CU, " : "); Gen_Node_Stubs_Spec (CU, State_Type (Member_Node)); PL (CU, ";"); end if; end loop; end; end if; end loop; if First then PL (CU, " with null record;"); else DI (CU); PL (CU, "end record;"); end if; NL (CU); end; PL (CU, "type Object_Ptr is access all Object'Class;"); when K_Initializer => Gen_Initializer_Profile (CU, "Object_Ptr", Node); PL (CU, ";"); when K_Operation => Ada_Be.Idl2Ada.Impl.Gen_Node_Spec (CU, Node); when K_State_Member => null; when others => null; end case; end Gen_Node_Spec; --------------------- -- Gen_Scope_Body -- --------------------- procedure Gen_Node_Body (CU : in out Compilation_Unit; Node : Node_Id) is begin case Kind (Node) is when K_ValueType => if Supports (Node) /= Nil_List then Add_With (CU, Ada_Full_Name (Node) & Ada_Be.Idl2Ada.Skel.Suffix (Is_Delegate => False)); end if; when K_Operation => -- for public state members, the operation body is -- fully generated. if Original_Node (Node) = No_Node or else Kind (Original_Node (Node)) /= K_State_Member then Ada_Be.Idl2Ada.Impl.Gen_Node_Body (CU, Node); else pragma Debug (O ("Generating .value_impl for state member")); declare Is_Get : constant Boolean := Kind (Operation_Type (Node)) /= K_Void; begin NL (CU); Gen_Operation_Profile (CU, Node, "access Object"); PL (CU, " is"); PL (CU, "begin"); II (CU); if Is_Get then Put (CU, "return Self.all."); Put (CU, Ada_Name (Head (State_Declarators (Original_Node (Node))))); PL (CU, ";"); else Put (CU, "Self.all."); Put (CU, Ada_Name (Head (State_Declarators (Original_Node (Node))))); PL (CU, " := To;"); end if; DI (CU); PL (CU, "end " & Ada_Operation_Name (Node) & ";"); end; end if; when K_Initializer => Gen_Initializer_Profile (CU, "Object_Ptr", Node); PL (CU, " is"); II (CU); PL (CU, "Result : Object_Ptr := new Object;"); DI (CU); PL (CU, "begin"); II (CU); NL (CU); PL (CU, "-- Insert implementation of " & Ada_Name (Node)); NL (CU); PL (CU, "return Result;"); DI (CU); PL (CU, "end " & Ada_Name (Node) & ";"); when others => null; end case; end Gen_Node_Body; end Ada_Be.Idl2Ada.Value_Impl; polyorb-2.8~20110207.orig/compilers/ciao/0000755000175000017500000000000011750740340017312 5ustar xavierxavierpolyorb-2.8~20110207.orig/compilers/ciao/ciao-asis_queries.adb0000644000175000017500000011147511750740337023406 0ustar xavierxavier---------------------------------------- -- -- -- ---- --- -- ---- -- -- - - - - - - -- -- - - ---- - - -- -- ---- --- - - ---- -- -- -- ---------------------------------------- -- CORBA -- -- Interface for -- -- Ada'95 distributed systems annex -- -- Objects -- ---------------------------------------- -- Copyright (c) 1999-2002 -- -- École nationale supérieure des -- -- télécommunications -- ---------------------------------------- -- Various ASIS queries for CIAO. with Ada.Characters.Handling; with Ada.Unchecked_Deallocation; with Asis.Compilation_Units; use Asis.Compilation_Units; with Asis.Declarations; use Asis.Declarations; with Asis.Definitions; use Asis.Definitions; with Asis.Elements; use Asis.Elements; with Asis.Expressions; use Asis.Expressions; with Asis.Statements; use Asis.Statements; with Asis.Text; use Asis.Text; package body CIAO.ASIS_Queries is use Asis; function Is_Ancestor (Ancestor_Compilation_Unit : Asis.Compilation_Unit; Compilation_Unit : Asis.Compilation_Unit) return Boolean is Parent : constant Asis.Compilation_Unit := Corresponding_Parent_Declaration (Compilation_Unit); begin if Is_Identical (Ancestor_Compilation_Unit, Compilation_Unit) then return True; elsif Is_Nil (Parent) then -- Compilation_Unit is predefined package Standard. return False; else return Is_Ancestor (Ancestor_Compilation_Unit, Parent); end if; end Is_Ancestor; function Corresponding_Entity_Name_Definition (Reference : Asis.Expression) return Asis.Defining_Name is Identifier : Asis.Expression; begin case Expression_Kind (Reference) is when An_Identifier => Identifier := Reference; when A_Selected_Component => Identifier := Selector (Reference); when An_Attribute_Reference => return Corresponding_Entity_Name_Definition (Prefix (Reference)); when others => raise ASIS_Inappropriate_Element; end case; return Corresponding_Name_Definition (Identifier); end Corresponding_Entity_Name_Definition; function Corresponding_Entity_Name_Declaration (Reference : Asis.Expression) return Asis.Declaration is Result : Asis.Element; begin Result := Corresponding_Entity_Name_Definition (Reference); if not Is_Nil (Result) then Result := Enclosing_Element (Result); end if; return Result; end Corresponding_Entity_Name_Declaration; function Discrete_Subtype_Name (Definition : Asis.Definition) return Asis.Program_Text is begin case Discrete_Range_Kind (Definition) is when Not_A_Discrete_Range => raise ASIS_Failed; when A_Discrete_Subtype_Indication => return Ada_Full_Name (Corresponding_Entity_Name_Declaration (Asis.Definitions.Subtype_Mark (Definition))); when A_Discrete_Range_Attribute_Reference => return Ada_Full_Name (Corresponding_Entity_Name_Declaration (Prefix (Definition))); when A_Discrete_Simple_Expression_Range => return Ada_Full_Name (Corresponding_Expression_Type (Asis.Definitions.Lower_Bound (Definition))); end case; end Discrete_Subtype_Name; function First_Subtype_Of_Denoted_Subtype (Subtype_Mark : Asis.Expression) return Asis.Declaration; -- This function recursively unwinds subtyping to return a -- type_declaration that defines the first subtype of the -- subtype denoted by the given Subtype_Mark. function First_Subtype_Of_Denoted_Subtype (Subtype_Mark : Asis.Expression) return Asis.Declaration is begin return Corresponding_First_Subtype (Corresponding_Entity_Name_Declaration (Subtype_Mark)); end First_Subtype_Of_Denoted_Subtype; function Is_Type_Conformant (Declaration_1, Declaration_2 : Asis.Declaration) return Boolean is DK_1 : constant Asis.Declaration_Kinds := Declaration_Kind (Declaration_1); DK_2 : constant Asis.Declaration_Kinds := Declaration_Kind (Declaration_2); begin if (DK_1 /= DK_2) or else not (DK_1 = A_Procedure_Declaration or else DK_1 = A_Function_Declaration) then return False; end if; -- XXX Warning! Toto'Class == Toto'Class ?? if DK_1 = A_Function_Declaration and then not Is_Identical (First_Subtype_Of_Denoted_Subtype (Result_Profile (Declaration_1)), First_Subtype_Of_Denoted_Subtype (Result_Profile (Declaration_2))) then return False; end if; declare Params_1 : constant Parameter_Specification_List := Parameter_Profile (Declaration_1); Params_2 : constant Parameter_Specification_List := Parameter_Profile (Declaration_2); begin for I in Params_1'Range loop if not Is_Identical (First_Subtype_Of_Denoted_Subtype (Declaration_Subtype_Mark (Params_1 (I))), First_Subtype_Of_Denoted_Subtype (Declaration_Subtype_Mark (Params_2 (I)))) then return False; end if; end loop; end; return True; end Is_Type_Conformant; function Is_Inheritance_Homograph (Ancestor_Subprogram, Ancestor, Child_Subprogram, Child : Asis.Declaration) return Boolean; -- Determine whether subprogram declaration Child_Subprogram -- is homograph to the implicit declaration of the primitive -- operation for type Child corresponding to the primitive -- operation Ancestor_Subprogram of its ancestor type Ancestor. -- (8.3(8 et seq) rules for overriding of primitive operations). function Is_Inheritance_Homograph (Ancestor_Subprogram, Ancestor, Child_Subprogram, Child : Asis.Declaration) return Boolean is DK_1 : constant Asis.Declaration_Kinds := Declaration_Kind (Ancestor_Subprogram); DK_2 : constant Asis.Declaration_Kinds := Declaration_Kind (Child_Subprogram); function Is_Same_Type (Ancestor_Decl, Child_Decl : Asis.Declaration) return Boolean; -- Check whether Ancestor_Decl and Child_Decl are -- identical for the determination of inheritance -- homography between a primitive operation of type -- Ancestor and a primitive operation of type Child -- which is derived from Ancestor. (3.4(18 et seq) rules -- for type replacement in the implicit declaration of -- inherited subprograms). function Is_Same_Type (Ancestor_Decl, Child_Decl : Asis.Declaration) return Boolean is begin return Is_Identical (Ancestor_Decl, Child_Decl) or else (Is_Identical (Ancestor_Decl, Ancestor) and then Is_Identical (Child_Decl, Child)); end Is_Same_Type; begin if (DK_1 /= DK_2) or else not (DK_1 = A_Procedure_Declaration or else DK_1 = A_Function_Declaration) then return False; end if; -- XXX Warning! Toto'Class == Toto'Class ?? if DK_1 = A_Function_Declaration and then not Is_Same_Type (First_Subtype_Of_Denoted_Subtype (Result_Profile (Ancestor_Subprogram)), First_Subtype_Of_Denoted_Subtype (Result_Profile (Child_Subprogram))) then return False; end if; declare Params_1 : constant Parameter_Specification_List := Parameter_Profile (Ancestor_Subprogram); Params_2 : constant Parameter_Specification_List := Parameter_Profile (Child_Subprogram); begin if Params_1'Length /= Params_2'Length then return False; end if; for I in Params_1'Range loop if not Is_Same_Type (First_Subtype_Of_Denoted_Subtype (Declaration_Subtype_Mark (Params_1 (I))), First_Subtype_Of_Denoted_Subtype (Declaration_Subtype_Mark (Params_2 (I + Params_2'First - Params_1'First)))) then return False; end if; end loop; end; return True; end Is_Inheritance_Homograph; function Is_Tagged_Type (Declaration : Asis.Declaration) return Boolean is begin case Declaration_Kind (Declaration) is when A_Subtype_Declaration => return Is_Tagged_Type (Corresponding_First_Subtype (Declaration)); when An_Ordinary_Type_Declaration | A_Private_Type_Declaration | A_Private_Extension_Declaration => declare Def : constant Asis.Definition := Type_Declaration_View (Declaration); begin case Definition_Kind (Def) is when A_Tagged_Private_Type_Definition | A_Private_Extension_Definition => return True; when A_Type_Definition => case Type_Kind (Def) is when A_Tagged_Record_Type_Definition | A_Derived_Record_Extension_Definition => return True; when A_Derived_Type_Definition => return False; when others => return False; end case; when others => return False; end case; end; when others => -- An unexpected Declaration_Kind return False; end case; end Is_Tagged_Type; function Has_Limited_Component (Components : Asis.Record_Component_List) return Boolean; -- Determine whether any of the components declared by -- Components has a limited type or has the 'limited' keyword. function Has_Limited_Component (Components : Asis.Record_Component_List) return Boolean is begin for I in Components'Range loop case Element_Kind (Components (I)) is when A_Pragma | A_Clause => return False; when A_Declaration => declare View : constant Asis.Definition := Object_Declaration_View (Components (I)); begin if Is_Limited_Type (Corresponding_Entity_Name_Declaration (Asis.Definitions.Subtype_Mark (Component_Subtype_Indication (View)))) then return True; end if; end; when A_Definition => case Definition_Kind (Components (I)) is when A_Variant_Part => declare Variants : constant Asis.Variant_List := Asis.Definitions.Variants (Components (I)); begin for I in Variants'Range loop if Has_Limited_Component (Record_Components (Variants (I))) then return True; end if; end loop; end; when A_Null_Component => null; when others => raise ASIS_Failed; end case; when others => -- Cannot happen! raise ASIS_Failed; end case; end loop; return False; end Has_Limited_Component; function Is_Limited_Type (Declaration : Asis.Declaration) return Boolean is begin case Declaration_Kind (Declaration) is when A_Task_Type_Declaration | A_Protected_Type_Declaration => return True; when A_Subtype_Declaration => return Is_Limited_Type (Corresponding_First_Subtype (Declaration)); when An_Ordinary_Type_Declaration | A_Private_Type_Declaration | A_Private_Extension_Declaration => declare Def : constant Asis.Definition := Type_Declaration_View (Declaration); TK : constant Trait_Kinds := Trait_Kind (Def); begin if False or else TK = A_Limited_Trait or else TK = A_Limited_Private_Trait or else TK = An_Abstract_Limited_Trait or else TK = An_Abstract_Limited_Private_Trait then return True; end if; case Definition_Kind (Def) is when A_Type_Definition => case Type_Kind (Def) is when A_Derived_Type_Definition | A_Derived_Record_Extension_Definition => return Is_Limited_Type (Corresponding_Root_Type (Def)); when An_Unconstrained_Array_Definition | A_Constrained_Array_Definition => return (Trait_Kind (Array_Component_Definition (Def)) = A_Limited_Trait) or else Is_Limited_Type (Corresponding_Entity_Name_Declaration (Asis.Definitions.Subtype_Mark (Component_Subtype_Indication (Array_Component_Definition (Def))))); when A_Record_Type_Definition | A_Tagged_Record_Type_Definition => declare Record_Def : constant Asis.Definition := Definitions.Record_Definition (Def); begin if Definition_Kind (Record_Def) = A_Null_Record_Definition then return False; else return Has_Limited_Component (Record_Components (Definitions.Record_Definition (Def))); end if; end; when others => return False; end case; when A_Private_Extension_Definition => return Is_Limited_Type (Corresponding_Entity_Name_Declaration (Asis.Definitions.Subtype_Mark (Ancestor_Subtype_Indication (Def)))); when others => return False; end case; end; when others => -- An unexpected Declaration_Kind return False; end case; end Is_Limited_Type; function Recursive_Is_Overriding_Inherited_Subprogram (Subprogram_Declaration : Asis.Declaration; Derived_Type_Declaration : Asis.Declaration; Leaf_Type_Declaration : Asis.Declaration) return Boolean; -- Determine whether Subprogram_Declaration is overriding an -- implicit subprogram inherited from an ancestor of the type -- declared by the Derived_Type_Declaration as a result -- of the derivation Leaf_Type_Declaration. function Recursive_Is_Overriding_Inherited_Subprogram (Subprogram_Declaration : Asis.Declaration; Derived_Type_Declaration : Asis.Declaration; Leaf_Type_Declaration : Asis.Declaration) return Boolean is type Declaration_List_Access is access Declaration_List; procedure Free is new Ada.Unchecked_Deallocation (Declaration_List, Declaration_List_Access); -- True iff the defining names in Names_1 -- and Names_2 are the same in the sense of 8.3(2). function Same_Defining_Names (Names_1, Names_2 : Asis.Defining_Name_List) return Boolean; function Same_Defining_Names (Names_1, Names_2 : Asis.Defining_Name_List) return Boolean is use Ada.Characters.Handling; begin if Names_1'Length /= Names_2'Length then return False; end if; for I in Names_1'Range loop declare Name_1 : constant Asis.Program_Text := Isolated_Element_Image (Names_1 (I)); Name_2 : constant Asis.Program_Text := Isolated_Element_Image (Names_2 (Names_2'First + I - Names_1'First)); begin for J in Name_1'Range loop declare Char_1 : Wide_Character := Name_1 (J); Char_2 : Wide_Character := Name_2 (J + Name_2'First - Name_1'First); begin if (Is_Character (Char_1) and then To_Lower (To_Character (Char_1)) /= To_Lower (To_Character (Char_2))) or else Char_1 /= Char_2 then return False; end if; end; end loop; end; end loop; return True; end Same_Defining_Names; Subprogram_DK : constant Asis.Declaration_Kinds := Declaration_Kind (Subprogram_Declaration); Type_DK : constant Asis.Declaration_Kinds := Declaration_Kind (Derived_Type_Declaration); Type_Definition : constant Asis.Definition := Type_Declaration_View (Derived_Type_Declaration); Incomplete_Parent_Type_Declaration : Asis.Declaration; Parent_Type_Declaration : Asis.Declaration; Parent_Type_Scope : Asis.Element; Scope_Items : Declaration_List_Access := null; Result : Boolean := False; begin -- Recursive_Is_Overriding_Inherited_Subprogram -- Find the immediate parent type. case Type_DK is when A_Private_Type_Declaration => -- A private type declaration that is not a private -- extension declaration has no inherited subprograms. return False; when A_Full_Type_Declaration => if Type_Kind (Type_Definition) /= A_Derived_Type_Definition then -- A full type declaration that is not a derivation -- has no inherited subprograms. return False; end if; Parent_Type_Declaration := Corresponding_Entity_Name_Declaration (Asis.Definitions.Subtype_Mark (Parent_Subtype_Indication (Type_Definition))); when A_Private_Extension_Declaration => Parent_Type_Declaration := Corresponding_Entity_Name_Declaration (Asis.Definitions.Subtype_Mark (Ancestor_Subtype_Indication (Type_Definition))); when others => -- An unexpected Declaration_Kind return False; end case; Incomplete_Parent_Type_Declaration := Corresponding_Type_Declaration (Parent_Type_Declaration); -- Find the region containing the parent declaration. Parent_Type_Scope := Enclosing_Element (Parent_Type_Declaration); case Element_Kind (Parent_Type_Scope) is when A_Declaration => case Declaration_Kind (Parent_Type_Scope) is when A_Generic_Package_Declaration | A_Package_Declaration => Scope_Items := new Declaration_List' (Visible_Part_Declarative_Items (Parent_Type_Scope) & Private_Part_Declarative_Items (Parent_Type_Scope)); when A_Function_Body_Declaration | A_Procedure_Body_Declaration | A_Package_Body_Declaration | A_Task_Body_Declaration | An_Entry_Body_Declaration => Scope_Items := new Declaration_List' (Body_Declarative_Items (Parent_Type_Scope)); when others => raise ASIS_Failed; end case; when A_Statement => if Statement_Kind (Parent_Type_Scope) /= A_Block_Statement then raise ASIS_Failed; end if; Scope_Items := new Declaration_List' (Block_Declarative_Items (Parent_Type_Scope)); when others => raise ASIS_Failed; end case; Parent_Scope : for I in Scope_Items.all'Range loop declare Item : constant Asis.Declaration := Scope_Items.all (I); Item_DK : constant Asis.Declaration_Kinds := Declaration_Kind (Item); Type_Decl : Asis.Declaration; Is_Primitive : Boolean := False; begin exit Parent_Scope when Is_Identical (Item, Derived_Type_Declaration); -- Primitives declared after the derivation are not inherited. if False or else Item_DK = A_Procedure_Declaration or else Item_DK = A_Function_Declaration then if Item_DK = A_Function_Declaration then Type_Decl := First_Subtype_Of_Denoted_Subtype (Result_Profile (Item)); if Is_Identical (Type_Decl, Parent_Type_Declaration) or else Is_Identical (Type_Decl, Incomplete_Parent_Type_Declaration) then Is_Primitive := True; end if; end if; declare Params : constant Parameter_Specification_List := Parameter_Profile (Item); begin Profile : for I in Params'Range loop exit Profile when Is_Primitive; Type_Decl := First_Subtype_Of_Denoted_Subtype (Declaration_Subtype_Mark (Params (I))); if Is_Identical (Type_Decl, Parent_Type_Declaration) or else Is_Identical (Type_Decl, Incomplete_Parent_Type_Declaration) then Is_Primitive := True; end if; end loop Profile; end; -- At this point Is_Primitive = True if Item is the declaration -- of a primitive operation of the parent type. if True and then Is_Primitive and then Subprogram_DK = Item_DK and then Same_Defining_Names (Names (Subprogram_Declaration), Names (Item)) and then Is_Inheritance_Homograph (Ancestor_Subprogram => Item, Ancestor => Parent_Type_Declaration, Child_Subprogram => Subprogram_Declaration, Child => Leaf_Type_Declaration) then -- This primitive operation is homograph to -- Subprogram_Declaration. Result := True; exit Parent_Scope; end if; end if; end; end loop Parent_Scope; Free (Scope_Items); if Result then return True; else return Recursive_Is_Overriding_Inherited_Subprogram (Subprogram_Declaration, Parent_Type_Declaration, Leaf_Type_Declaration); end if; exception when others => Free (Scope_Items); raise; end Recursive_Is_Overriding_Inherited_Subprogram; function Is_Overriding_Inherited_Subprogram (Subprogram_Declaration : Asis.Declaration; Derived_Type_Declaration : Asis.Declaration) return Boolean is begin return Recursive_Is_Overriding_Inherited_Subprogram (Subprogram_Declaration, Derived_Type_Declaration, Derived_Type_Declaration); end Is_Overriding_Inherited_Subprogram; function Is_Controlling_Formal_Or_Result (Subprogram_Declaration : Asis.Declaration; Subtype_Mark : Asis.Expression) return Boolean; -- Determine whether a formal parameter or result of a -- subprogram declaration is a controlling formal parameter, -- resp. controlling result. function Is_Controlling_Formal_Or_Result (Subprogram_Declaration : Asis.Declaration; Subtype_Mark : Asis.Expression) return Boolean is Type_Declaration : constant Asis.Declaration := Corresponding_Entity_Name_Declaration (Subtype_Mark); Type_Enclosing_Element : Asis.Element; begin if not Is_Tagged_Type (Type_Declaration) then return False; end if; Type_Enclosing_Element := Enclosing_Element (Type_Declaration); if not Is_Identical (Type_Enclosing_Element, Enclosing_Element (Subprogram_Declaration)) then return False; end if; if Element_Kind (Type_Enclosing_Element) = A_Declaration then declare DK : constant Asis.Declaration_Kinds := Declaration_Kind (Type_Enclosing_Element); begin if DK = A_Package_Declaration or else DK = A_Generic_Package_Declaration then -- A package_specification return True; end if; end; end if; return Is_Overriding_Inherited_Subprogram (Subprogram_Declaration, Type_Declaration); end Is_Controlling_Formal_Or_Result; function Is_Controlling_Formal (Parameter_Specification : Asis.Parameter_Specification) return Boolean is begin return Is_Controlling_Formal_Or_Result (Enclosing_Element (Parameter_Specification), Declaration_Subtype_Mark (Parameter_Specification)); end Is_Controlling_Formal; function Is_Controlling_Result (Result_Profile : Asis.Expression) return Boolean is begin return Is_Controlling_Formal_Or_Result (Enclosing_Element (Result_Profile), Result_Profile); end Is_Controlling_Result; function Controlling_Formal_Parameters (Declaration : Asis.Declaration) return Asis.Parameter_Specification_List is Params : constant Asis.Parameter_Specification_List := Parameter_Profile (Declaration); Controlling_Params : Asis.Parameter_Specification_List (Params'Range); Controlling_Count : Natural range 0 .. Controlling_Params'Length := 0; begin for I in Params'Range loop if Is_Controlling_Formal (Params (I)) then Controlling_Params (Controlling_Params'First + Controlling_Count) := Params (I); Controlling_Count := Controlling_Count + 1; end if; end loop; if Controlling_Count = 0 then return Nil_Element_List; else return Controlling_Params (Controlling_Params'First .. Controlling_Params'First + Controlling_Count - 1); end if; end Controlling_Formal_Parameters; function Enclosing_Basic_Declaration (Element : Asis.Element) return Asis.Declaration is begin case Element_Kind (Element) is when Not_An_Element | A_Statement | A_Path | An_Exception_Handler => raise ASIS_Inappropriate_Element; when A_Pragma | A_Clause | A_Defining_Name | A_Definition | An_Expression | An_Association => return Enclosing_Basic_Declaration (Enclosing_Element (Element)); when A_Declaration => case Declaration_Kind (Element) is when An_Ordinary_Type_Declaration | A_Task_Type_Declaration | A_Protected_Type_Declaration | An_Incomplete_Type_Declaration | A_Private_Type_Declaration | A_Private_Extension_Declaration | -- type_declaration A_Subtype_Declaration | -- subtype_declaration A_Variable_Declaration | A_Constant_Declaration | A_Deferred_Constant_Declaration | A_Single_Task_Declaration | A_Single_Protected_Declaration | -- object_declaration An_Integer_Number_Declaration | A_Real_Number_Declaration | -- number_declaration A_Procedure_Declaration | A_Function_Declaration | -- subprogram_declaration -- abstract_subprogram_declaration A_Package_Declaration | -- package_declaration An_Object_Renaming_Declaration | An_Exception_Renaming_Declaration | A_Package_Renaming_Declaration | A_Procedure_Renaming_Declaration | A_Function_Renaming_Declaration | A_Generic_Package_Renaming_Declaration | A_Generic_Procedure_Renaming_Declaration | A_Generic_Function_Renaming_Declaration | -- renaming_declaration An_Exception_Declaration | -- exception_declaration A_Generic_Procedure_Declaration | A_Generic_Function_Declaration | A_Generic_Package_Declaration | -- generic_declaration A_Package_Instantiation | A_Procedure_Instantiation | A_Function_Instantiation => -- generic_instanciation return Element; when An_Enumeration_Literal_Specification | A_Discriminant_Specification | A_Component_Declaration | A_Parameter_Specification | An_Entry_Declaration | An_Entry_Index_Specification | A_Formal_Object_Declaration | A_Formal_Type_Declaration | A_Formal_Procedure_Declaration | A_Formal_Function_Declaration | A_Formal_Package_Declaration | A_Formal_Package_Declaration_With_Box => return Enclosing_Basic_Declaration (Enclosing_Element (Element)); when others => raise ASIS_Inappropriate_Element; end case; end case; end Enclosing_Basic_Declaration; function Isolated_Element_Image (Element : Asis.Element) return Program_Text is Padded_Image : constant Program_Text := Asis.Text.Element_Image (Element); begin return Padded_Image (Element_Span (Element).First_Column .. Padded_Image'Last); end Isolated_Element_Image; function Ada_Full_Name (Declaration : Asis.Declaration) return Asis.Program_Text is Origin : constant Compilation_Unit := Enclosing_Compilation_Unit (Declaration); begin if Is_Nil (Corresponding_Parent_Declaration (Origin)) then declare Declaration_Names : constant Asis.Defining_Name_List := Names (Declaration); begin if Declaration_Names'Length > 0 then return "Standard." & Defining_Name_Image (Declaration_Names (Declaration_Names'First)); else -- The implicit declaration of a root or universal -- numeric type. pragma Assert (Declaration_Kind (Declaration) = An_Ordinary_Type_Declaration); declare Definition : constant Asis.Definition := Type_Declaration_View (Declaration); begin pragma Assert (Type_Kind (Definition) = A_Root_Type_Definition); -- XXX This should be checked, but ASIS for -- GNAT up to 3.13w 19991007 makes this -- assertion fail (Not_A_Root_Type_Definition, -- see below). -- XXX check reinstated 20011211 TQ case Root_Type_Kind (Definition) is when Not_A_Root_Type_Definition => raise ASIS_Failed; -- XXX exception reinstated 20011211 TQ -- XXX The only scalar type that has an implicit -- declaration is universal_integer. -- return "Standard.Integer"; when A_Root_Integer_Definition => -- Integer'Base return "Standard.Integer'Base"; when A_Root_Real_Definition => -- Float'Base return "Standard.Float'Base"; when A_Universal_Integer_Definition => -- Integer'Class return "Standard.Integer"; when A_Universal_Real_Definition => -- Float'Class return "Standard.Float"; when A_Universal_Fixed_Definition => -- Fixed'Class return "Standard.Universal_FixedXXX"; end case; end; end if; end; end if; if Is_Identical (Declaration, Unit_Declaration (Origin)) then return Unit_Full_Name (Origin); end if; declare Enclosing_Declaration : constant Asis.Declaration := Enclosing_Element (Declaration); Denoted_Definition : constant Asis.Definition := Declaration_Name (Declaration); begin pragma Assert (Element_Kind (Enclosing_Declaration) = A_Declaration); return Ada_Full_Name (Enclosing_Declaration) & "." & Defining_Name_Image (Denoted_Definition); end; end Ada_Full_Name; function Declaration_Name (Declaration : Asis.Declaration) return Asis.Defining_Name is Defining_Names : constant Asis.Defining_Name_List := Names (Declaration); begin pragma Assert (Defining_Names'Length = 1); return Defining_Names (Defining_Names'First); end Declaration_Name; function Is_Asynchronous (Element : Asis.Declaration) return Boolean is Pragmas : constant Asis.Pragma_Element_List := Corresponding_Pragmas (Element); begin if Element_Kind (Element) /= A_Declaration then return False; end if; for I in Pragmas'Range loop if Pragma_Kind (Pragmas (I)) = An_Asynchronous_Pragma then return True; end if; end loop; return False; end Is_Asynchronous; function Unit_Category (LU : in Compilation_Unit) return Unit_Categories is D : constant Declaration := Unit_Declaration (LU); K : constant Declaration_Kinds := Declaration_Kind (D); begin if K /= A_Package_Declaration then raise ASIS_Inappropriate_Element; end if; declare Unit_Pragmas : constant Pragma_Element_List := Pragmas (D); begin for I in Unit_Pragmas'Range loop case Pragma_Kind (Unit_Pragmas (I)) is when A_Pure_Pragma => return Pure; when A_Remote_Types_Pragma => return Remote_Types; when A_Remote_Call_Interface_Pragma => return Remote_Call_Interface; when others => null; end case; end loop; return Other; end; end Unit_Category; end CIAO.ASIS_Queries; polyorb-2.8~20110207.orig/compilers/ciao/ciao-generator-orb_deps_g.ads0000644000175000017500000000245111750740337025013 0ustar xavierxavier---------------------------------------- -- -- -- ---- --- -- ---- -- -- - - - - - - -- -- - - ---- - - -- -- ---- --- - - ---- -- -- -- ---------------------------------------- -- CORBA -- -- Interface for -- -- Ada'95 distributed systems annex -- -- Objects -- ---------------------------------------- -- Copyright (c) 1999 -- -- École nationale supérieure des -- -- télécommunications -- ---------------------------------------- -- Generic template for ORB-specific matter. with CIAO.Types; generic ObjectId_Sequences_Package : in Wide_String; -- The name of the instanciation of CORBA.Sequences (Octet) -- used for PortableServer.ObjectId. ObjectId_Sequences_Dependency : in Wide_String; -- The name of the library unit that encloses -- that instanciation. with function Sequences_Package (N : CIAO.Types.Node_Id) return Wide_String is <>; -- The name of the instanciation of CORBA.Sequences (Octet) -- used for N_Sequence_Type node N. package CIAO.Generator.ORB_Deps_G is end CIAO.Generator.ORB_Deps_G; polyorb-2.8~20110207.orig/compilers/ciao/ciao-generator-proxy.adb0000644000175000017500000025720211750740337024056 0ustar xavierxavier---------------------------------------- -- -- -- ---- --- -- ---- -- -- - - - - - - -- -- - - ---- - - -- -- ---- --- - - ---- -- -- -- ---------------------------------------- -- CORBA -- -- Interface for -- -- Ada'95 distributed systems annex -- -- Objects -- ---------------------------------------- -- Copyright (c) 1999 -- -- École nationale supérieure des -- -- télécommunications -- ---------------------------------------- -- The proxy package generator. -- Produces a CORBA servant implementation from an -- annotated IDL tree obtained as output of the translator. with Ada.Characters.Handling; use Ada.Characters.Handling; with Ada.Unchecked_Deallocation; with Ada.Strings.Wide_Unbounded; use Ada.Strings.Wide_Unbounded; with Ada.Wide_Text_Io; use Ada.Wide_Text_Io; with Asis; use Asis; with Asis.Compilation_Units; use Asis.Compilation_Units; with Asis.Declarations; use Asis.Declarations; with Asis.Definitions; use Asis.Definitions; with Asis.Elements; use Asis.Elements; with CIAO.Asis_Queries; use CIAO.Asis_Queries; with CIAO.IDL_Tree; use CIAO.IDL_Tree; with CIAO.IDL_Syntax; use CIAO.IDL_Syntax; with CIAO.Namet; use CIAO.Namet; with CIAO.Nlists; use CIAO.Nlists; with CIAO.Options; use CIAO.Options; with CIAO.Translator.Maps; use CIAO.Translator.Maps; with CIAO.Translator.State; use CIAO.Translator.State; with CIAO.Types; use CIAO.Types; with CIAO.Ada_Source_Streams; use CIAO.Ada_Source_Streams; package body CIAO.Generator.Proxy is use ORB_Deps; --------------------------------- -- A stack of IDL module names -- --------------------------------- type Stack_Node; type Stack is access all Stack_Node; type Stack_Node is record Name : Wide_String_Ptr; Next : Stack; end record; procedure Free is new Ada.Unchecked_Deallocation (Stack_Node, Stack); Module_Names : Stack := null; procedure Push (Name : Wide_String) is begin Module_Names := new Stack_Node'(Name => new Wide_String'(Name), Next => Module_Names); end Push; procedure Pop is Old_Top : Stack := Module_Names; begin Module_Names := Old_Top.Next; Free (Old_Top.Name); Free (Old_Top); end; function Depth return Natural is Count : Natural := 0; Module : Stack := Module_Names; begin while Module /= null loop Count := Count + 1; Module := Module.Next; end loop; return Count; end Depth; function Map_Identifier (Id : Wide_String) return Wide_String is Ret : Wide_String := Id; First : Integer := Id'First; Prev_Underscore : Boolean := False; begin while First < Ret'Last and then Ret (First) = '_' loop First := First + 1; end loop; for I in First .. Ret'Last loop if Ret (I) = '_' then if Prev_Underscore then Ret (I) := 'U'; end if; end if; Prev_Underscore := (Ret (I) = '_'); end loop; return Ret (First .. Ret'Last); end Map_Identifier; function Module_Name (Module : Stack) return Wide_String is begin if Module = null then return "EMPTY_STACK"; end if; if Module.Next /= null then return Module_Name (Module.Next) & "." & Map_Identifier (Module.Name.all); else return Map_Identifier (Module.Name.all); end if; end Module_Name; function Current_Ada_Name return Wide_String is begin return Module_Name (Module_Names); end Current_Ada_Name; ------------------------------- -- The source code generator -- ------------------------------- -- Wrapper routines for new Source_Streams package type Library_Unit is record Name : Wide_String_Ptr; Unit_Spec : CIAO.Ada_Source_Streams.Compilation_Unit; Unit_Body : CIAO.Ada_Source_Streams.Compilation_Unit; end record; procedure Append (Unit : in out CIAO.Ada_Source_Streams.Compilation_Unit; Line : Wide_String); -- Append Line to Unit. function New_Package (Name : Wide_String) return Library_Unit; -- Create a Library_Unit. procedure Add_Wide_With (Unit : in out CIAO.Ada_Source_Streams.Compilation_Unit; Dep : Wide_String; Use_It : Boolean := False; Elab_Control : Elab_Control_Pragma := None); -- Add Dep to the semantic dependecies of Unit, -- if it is not already present. If Use_It is true, -- a "use" clause will be added for that unit. -- Additionnally, an elaboration control pragma may -- be inserted according to Elab_Control. procedure Generate (LU : Library_Unit); -- Generate the spec and body for LU. procedure Append (Unit : in out CIAO.Ada_Source_Streams.Compilation_Unit; Line : Wide_String) is begin CIAO.Ada_Source_Streams.Put_Line (Unit, To_String (Line)); end Append; function New_Package (Name : Wide_String) return Library_Unit is begin return Library_Unit' (Name => new Wide_String'(Name), Unit_Spec => New_Package (To_String (Name), Unit_Spec), Unit_Body => New_Package (To_String (Name), Unit_Body)); end New_Package; procedure Add_Wide_With (Unit : in out CIAO.Ada_Source_Streams.Compilation_Unit; Dep : Wide_String; Use_It : Boolean := False; Elab_Control : Elab_Control_Pragma := None) is begin Add_With (Unit, To_String (Dep), Use_It, Elab_Control); end Add_Wide_With; -- Short-cuts for code generation subprograms procedure PL (Unit : in out CIAO.Ada_Source_Streams.Compilation_Unit; Line : Wide_String) renames Append; procedure NL (Unit : in out CIAO.Ada_Source_Streams.Compilation_Unit) renames New_Line; procedure II (Unit : in out CIAO.Ada_Source_Streams.Compilation_Unit) renames Inc_Indent; procedure DI (Unit : in out CIAO.Ada_Source_Streams.Compilation_Unit) renames Dec_Indent; procedure Generate (LU : Library_Unit) is begin Generate (LU.Unit_Spec); Generate (LU.Unit_Body); end Generate; procedure Generate (Tree : in Node_Id) is ------------------------------------------------------- -- Global variables of Generate -- -- These variables are used to pass around the -- -- reprensetations produced by recursive invocations -- -- of Generate_Node. -- ------------------------------------------------------- RACWs_Package : Library_Unit; -- Package where RACWs for distributed objects of the current modules -- are declared. Convert_Package : Library_Unit; -- Package where conversion functions for the user-defined types -- of the current module are declared. Impl_Package : Library_Unit; -- The Impl package for the current interface. DSA_Package : Wide_String_Ptr; -- The DSA module within which the distributed -- object corresponding to the current interface -- notionally resides. ---------------------- -- Utility routines -- ---------------------- procedure With_Type (N : Node_Id; L : in out CIAO.Ada_Source_Streams.Compilation_Unit); -- A dependency is added to L on the package where -- the type denoted by N is defined. procedure With_Convert_For_Type (N : Node_Id; L : in out CIAO.Ada_Source_Streams.Compilation_Unit); -- A dependency is added to L on the Convert package -- for the module that defines the type denoted by node N -- (an , or ). procedure Generate_Node (N : Node_Id; Buffer : in out Unbounded_Wide_String); -- Do the generation for node N into Buffer (if this node -- produces intermediate text), or into the current packages. ----------------------------------------------- -- Some node kinds require heavy processing; -- -- we handle these in separated subprograms. -- ----------------------------------------------- -- procedure Produce_Type_Converters (IDL_Declaration : Node_Id; Ada_Declaration : Asis.Declaration); -- Produce the To_Ada and To_CORBA functions -- for the type declared by Ada_Declaration, -- which is translated to IDL_Declaration. -- procedure Produce_Interface (IDL_Declaration : Node_Id); -- Produce the complete translation of an . --------------------------------- -- Bodies of local subprograms -- --------------------------------- procedure With_Type (N : Node_Id; L : in out CIAO.Ada_Source_Streams.Compilation_Unit) is Type_Name_Buffer : Unbounded_Wide_String; begin pragma Assert (False or else Node_Kind (N) = N_Op_Type_Spec or else Node_Kind (N) = N_Param_Type_Spec or else Node_Kind (N) = N_Simple_Type_Spec); Generate_Node (N, Type_Name_Buffer); declare Type_Name : constant Wide_String := To_Wide_String (Type_Name_Buffer); Dot : Integer := Type_Name'Last; begin while Dot >= Type_Name'First loop exit when Type_Name (Dot) = '.'; Dot := Dot - 1; end loop; if Dot > Type_Name'First then if Type_Name (Type_Name'First .. Dot - 1) = "CORBA" then -- A base type. Add_Wide_With (L, "CORBA", Elab_Control => Elaborate); else -- A scoped name that denotes a user-defined -- type. Add_Wide_With (L, Type_Name (Type_Name'First .. Dot - 1)); end if; end if; end; end With_Type; procedure With_Convert_For_Type (N : Node_Id; L : in out CIAO.Ada_Source_Streams.Compilation_Unit) is Type_Name_Buffer : Unbounded_Wide_String; begin pragma Assert (False or else Node_Kind (N) = N_Op_Type_Spec or else Node_Kind (N) = N_Param_Type_Spec or else Node_Kind (N) = N_Simple_Type_Spec); Generate_Node (N, Type_Name_Buffer); declare -- XXX -- This is wrong -- Map_Identifier works on a -- single name component, and won't suppress leading -- underscores at start of components of a qualified -- name. But for now, it will make do. Type_Name : constant Wide_String := Map_Identifier (To_Wide_String (Type_Name_Buffer)); Dot : Integer := Type_Name'Last; begin while Dot >= Type_Name'First loop exit when Type_Name (Dot) = '.'; Dot := Dot - 1; end loop; if Dot > Type_Name'First then if Type_Name (Type_Name'First .. Dot - 1) = "CORBA" then -- A base type. Add_Wide_With (L, "CIAO_Runtime.Convert", Use_It => True); else -- A scoped name that denotes a user-defined -- type. Add_Wide_With (L, Type_Name (Type_Name'First .. Dot - 1) & ".Convert", Use_It => True); end if; end if; end; end With_Convert_For_Type; procedure Produce_Type_Converters (IDL_Declaration : Node_Id; Ada_Declaration : Asis.Declaration) is Ada_Type_Name : constant Wide_String := Ada_Full_Name (Ada_Declaration); -- The type as declared in the DSA package. CORBA_Type_Name : constant Wide_String := "DSA_" & Ada_Type_Name; -- The type as mapped by the IDL to Ada translator. procedure Produce_Specification (Conversion_Ada_Type_Name : Wide_String) is begin NL (Convert_Package.Unit_Spec); Append (Convert_Package.Unit_Spec, "function To_CORBA (Ada_Val : " & Conversion_Ada_Type_Name & ") return " & CORBA_Type_Name & ";"); Append (Convert_Package.Unit_Spec, "function To_Ada (CORBA_Val : " & CORBA_Type_Name & ") return " & Conversion_Ada_Type_Name & ";"); end Produce_Specification; procedure Produce_Body_Opaque (Conversion_Ada_Type_Name : Wide_String) is -- The translation of this declaration is a -- within the current module, which defines a sequence -- type. According to the CORBA specification, this sequence -- type is mapped to an implementation-dependant instanciation -- of CORBA.Sequences within the package that maps the -- current module. Sequences_Instance : constant Wide_String := Current_Ada_Name & "." & Sequences_Package (Template_Type_Spec (Specific_Type_Spec (Type_Spec (Type_Declarator (CIAO.Translator.State.Get_Translation (Ada_Declaration)))))); To_Sequence : constant Wide_String := Sequences_Instance & ".To_Sequence"; To_Element_Array : constant Wide_String := Sequences_Instance & ".To_Element_Array"; begin -------------- -- To_CORBA -- -------------- Add_Wide_With (Convert_Package.Unit_Body, "CIAO_Runtime.Encap_Streams", Use_It => True); NL (Convert_Package.Unit_Body); Append (Convert_Package.Unit_Body, "function To_CORBA (Ada_Val : " & Conversion_Ada_Type_Name & ") return " & CORBA_Type_Name & " is"); II (Convert_Package.Unit_Body); Append (Convert_Package.Unit_Body, "St : aliased Stream;"); DI (Convert_Package.Unit_Body); Append (Convert_Package.Unit_Body, "begin"); II (Convert_Package.Unit_Body); Append (Convert_Package.Unit_Body, Conversion_Ada_Type_Name & "'Output (St'Access, Ada_Val);"); Append (Convert_Package.Unit_Body, "return " & CORBA_Type_Name); Append (Convert_Package.Unit_Body, " (" & To_Sequence); Append (Convert_Package.Unit_Body, " (" & Sequences_Instance & ".Element_Array (Get_Seq (St))));"); DI (Convert_Package.Unit_Body); Append (Convert_Package.Unit_Body, "end To_CORBA;"); ------------ -- To_Ada -- ------------ NL (Convert_Package.Unit_Body); Append (Convert_Package.Unit_Body, "function To_Ada (CORBA_Val : " & CORBA_Type_Name & ") return " & Conversion_Ada_Type_Name & " is"); II (Convert_Package.Unit_Body); Append (Convert_Package.Unit_Body, "St : aliased Stream;"); DI (Convert_Package.Unit_Body); Append (Convert_Package.Unit_Body, "begin"); II (Convert_Package.Unit_Body); Append (Convert_Package.Unit_Body, "Set_Seq (St, Octet_Array"); Append (Convert_Package.Unit_Body, " (" & To_Element_Array); Append (Convert_Package.Unit_Body, " (" & Sequences_Instance & ".Sequence (CORBA_Val))));"); Append (Convert_Package.Unit_Body, "return " & Conversion_Ada_Type_Name & "'Input (St'Access);"); DI (Convert_Package.Unit_Body); Append (Convert_Package.Unit_Body, "end To_Ada;"); end Produce_Body_Opaque; procedure Produce_Body_Nickname (Conversion_Ada_Type_Name : Wide_String; Ada_Parent_Type_Name : Wide_String; CORBA_Parent_Type_Name : Wide_String; Unchecked_Conversion : Boolean := False) is begin -------------- -- To_CORBA -- -------------- NL (Convert_Package.Unit_Body); Append (Convert_Package.Unit_Body, "function To_CORBA (Ada_Val : " & Conversion_Ada_Type_Name & ") return " & CORBA_Type_Name); Append (Convert_Package.Unit_Body, "is"); if Unchecked_Conversion then Add_Wide_With (Convert_Package.Unit_Body, "Ada.Unchecked_Conversion"); II (Convert_Package.Unit_Body); Append (Convert_Package.Unit_Body, "function Unchecked_Conversion is new Ada.Unchecked_Conversion"); Append (Convert_Package.Unit_Body, " (" & Conversion_Ada_Type_Name & ", " & Ada_Parent_Type_Name & ");"); DI (Convert_Package.Unit_Body); end if; Append (Convert_Package.Unit_Body, "begin"); II (Convert_Package.Unit_Body); Append (Convert_Package.Unit_Body, "return " & CORBA_Type_Name); Append (Convert_Package.Unit_Body, " (" & CORBA_Parent_Type_Name & "'"); if Unchecked_Conversion then Append (Convert_Package.Unit_Body, " (To_CORBA (Unchecked_Conversion (Ada_Val))));"); else Append (Convert_Package.Unit_Body, " (To_CORBA (" & Ada_Parent_Type_Name & " (Ada_Val))));"); end if; DI (Convert_Package.Unit_Body); Append (Convert_Package.Unit_Body, "end To_CORBA;"); ------------ -- To_Ada -- ------------ NL (Convert_Package.Unit_Body); Append (Convert_Package.Unit_Body, "function To_Ada (CORBA_Val : " & CORBA_Type_Name & ") return " & Conversion_Ada_Type_Name & " is"); if Unchecked_Conversion then Add_Wide_With (Convert_Package.Unit_Body, "Ada.Unchecked_Conversion"); II (Convert_Package.Unit_Body); Append (Convert_Package.Unit_Body, "function Unchecked_Conversion is new Ada.Unchecked_Conversion"); Append (Convert_Package.Unit_Body, " (" & Ada_Parent_Type_Name & ", " & Conversion_Ada_Type_Name & ");"); DI (Convert_Package.Unit_Body); end if; Append (Convert_Package.Unit_Body, "begin"); II (Convert_Package.Unit_Body); if Unchecked_Conversion then Append (Convert_Package.Unit_Body, "return Unchecked_Conversion"); else Append (Convert_Package.Unit_Body, "return " & Conversion_Ada_Type_Name); end if; Append (Convert_Package.Unit_Body, " (" & Ada_Parent_Type_Name & "'"); Append (Convert_Package.Unit_Body, " (To_Ada (" & CORBA_Parent_Type_Name & " (CORBA_Val))));"); DI (Convert_Package.Unit_Body); Append (Convert_Package.Unit_Body, "end To_Ada;"); end Produce_Body_Nickname; procedure Produce_Body_Enum (Conversion_Ada_Type_Name : Wide_String) is Literals : constant Asis.Declaration_List := Enumeration_Literal_Declarations (Type_Declaration_View (Ada_Declaration)); begin -------------- -- To_CORBA -- -------------- NL (Convert_Package.Unit_Body); Append (Convert_Package.Unit_Body, "function To_CORBA (Ada_Val : " & Conversion_Ada_Type_Name & ") return " & CORBA_Type_Name & " is"); II (Convert_Package.Unit_Body); Append (Convert_Package.Unit_Body, "Map : constant array (" & Conversion_Ada_Type_Name & ") of " & CORBA_Type_Name); Append (Convert_Package.Unit_Body, " := ("); for I in Literals'Range loop declare Buffer : Unbounded_Wide_String; Defining_Literal : constant Asis.Defining_Name := Declaration_Name (Literals (I)); Literal_Image : constant Asis.Program_Text := Isolated_Element_Image (Defining_Literal); begin Buffer := To_Unbounded_Wide_String (Literal_Image & " => "); case Defining_Name_Kind (Defining_Literal) is when A_Defining_Enumeration_Literal => Append (Buffer, Literal_Image); when A_Defining_Character_Literal => Append (Buffer, Character_Literal_Identifier (Literal_Image)); when others => -- XXX ERROR should not happen. pragma Assert (False); null; end case; if I /= Literals'Last then Append (Buffer, ","); end if; Append (Convert_Package.Unit_Body, " " & To_Wide_String (Buffer)); end; end loop; Append (Convert_Package.Unit_Body, " );"); DI (Convert_Package.Unit_Body); Append (Convert_Package.Unit_Body, "begin"); II (Convert_Package.Unit_Body); Append (Convert_Package.Unit_Body, "return Map (Ada_Val);"); DI (Convert_Package.Unit_Body); Append (Convert_Package.Unit_Body, "end To_CORBA;"); ------------ -- To_Ada -- ------------ NL (Convert_Package.Unit_Body); Append (Convert_Package.Unit_Body, "function To_Ada (CORBA_Val : " & CORBA_Type_Name & ") return " & Conversion_Ada_Type_Name & " is"); II (Convert_Package.Unit_Body); Append (Convert_Package.Unit_Body, "Map : constant array (" & CORBA_Type_Name & ") of " & Conversion_Ada_Type_Name); Append (Convert_Package.Unit_Body, " := ("); for I in Literals'Range loop declare Buffer : Unbounded_Wide_String; Defining_Literal : constant Asis.Defining_Name := Declaration_Name (Literals (I)); Literal_Image : constant Asis.Program_Text := Isolated_Element_Image (Defining_Literal); begin case Defining_Name_Kind (Defining_Literal) is when A_Defining_Enumeration_Literal => Buffer := To_Unbounded_Wide_String (Literal_Image); when A_Defining_Character_Literal => Buffer := To_Unbounded_Wide_String (Character_Literal_Identifier (Literal_Image)); when others => raise Program_Error; -- XXX ERROR should not happen. end case; Append (Buffer, " => " & Literal_Image); if I /= Literals'Last then Append (Buffer, ","); end if; Append (Convert_Package.Unit_Body, " " & To_Wide_String (Buffer)); end; end loop; Append (Convert_Package.Unit_Body, " );"); DI (Convert_Package.Unit_Body); Append (Convert_Package.Unit_Body, "begin"); II (Convert_Package.Unit_Body); Append (Convert_Package.Unit_Body, "return Map (CORBA_Val);"); DI (Convert_Package.Unit_Body); Append (Convert_Package.Unit_Body, "end To_Ada;"); end Produce_Body_Enum; procedure Produce_Body_Array (Conversion_Ada_Type_Name : Wide_String) is Array_Type_Definition : constant Asis.Definition := Type_Declaration_View (Ada_Declaration); Dimensions : Natural; Index_Subtype_Name : Unbounded_Wide_String; Sequences_Instance : constant Wide_String := Current_Ada_Name & "." & Sequences_Package (Template_Type_Spec (Specific_Type_Spec (Type_Spec (Last (Members (Structure (Specific_Type_Spec (Type_Spec (Type_Declarator (CIAO.Translator.State.Get_Translation (Ada_Declaration))))))))))); -- The translation of this declaration is a within -- the current module, which defines a struct type with two -- members: a low bound, or array of low bounds, and a sequence -- of elements. -- According to the CORBA specification, this sequence mapped -- to an implementation-dependant instanciation of CORBA.Sequences -- within the package that maps the current module. -- These nested calls are obscene. To_Sequence : constant Wide_String := Sequences_Instance & ".To_Sequence"; To_Element_Array : constant Wide_String := Sequences_Instance & ".To_Element_Array"; begin if Type_Kind (Array_Type_Definition) = An_Unconstrained_Array_Definition then declare Indices : constant Asis.Expression_List := Index_Subtype_Definitions (Array_Type_Definition); begin Index_Subtype_Name := To_Unbounded_Wide_String (Ada_Full_Name (Corresponding_Entity_Name_Declaration (Indices (Indices'First)))); Dimensions := Indices'Length; end; else declare Indices : constant Asis.Expression_List := Discrete_Subtype_Definitions (Array_Type_Definition); begin Index_Subtype_Name := To_Unbounded_Wide_String (Discrete_Subtype_Name (Indices (Indices'First))); Dimensions := Indices'Length; end; end if; pragma Assert (Dimensions = 1); -- XXX FOR NOW due to a bug in the Sun IDL front-end -- XXX (no support for nested sequences), -- XXX multi-dimensional arrays are *not* supported. -- XXX The hereunder code must be rewritten if/when -- XXX multidimensional arrays are supported. -------------- -- To_CORBA -- -------------- NL (Convert_Package.Unit_Body); Append (Convert_Package.Unit_Body, "function To_CORBA (Ada_Val : " & Conversion_Ada_Type_Name & ") return " & CORBA_Type_Name & " is"); II (Convert_Package.Unit_Body); Append (Convert_Package.Unit_Body, "CORBA_Elements : " & Sequences_Instance & ".Element_Array (0 .. Ada_Val'Length - 1);"); DI (Convert_Package.Unit_Body); Append (Convert_Package.Unit_Body, "begin"); II (Convert_Package.Unit_Body); Append (Convert_Package.Unit_Body, "for I in Ada_Val'Range loop"); II (Convert_Package.Unit_Body); Append (Convert_Package.Unit_Body, "CORBA_Elements (" & To_Wide_String (Index_Subtype_Name) & "'Pos (I) - " & To_Wide_String (Index_Subtype_Name) & "'Pos (Ada_Val'First)) :="); Append (Convert_PAckage.Unit_Body, " To_CORBA (Ada_Val (I));"); DI (Convert_Package.Unit_Body); Append (Convert_Package.Unit_Body, "end loop;"); NL (Convert_Package.Unit_Body); Append (Convert_Package.Unit_Body, "return " & CORBA_Type_Name & "'(Low_Bound => " & To_Wide_String (Index_Subtype_Name) & "'Pos (Ada_Val'First),"); Append (Convert_Package.Unit_Body, " Array_Values => " & Sequences_Instance & ".To_Sequence (CORBA_Elements));"); DI (Convert_Package.Unit_Body); Append (Convert_Package.Unit_Body, "end To_CORBA;"); ------------ -- To_Ada -- ------------ NL (Convert_Package.Unit_Body); Append (Convert_Package.Unit_Body, "function To_Ada (CORBA_Val : " & CORBA_Type_Name & ") return " & Conversion_Ada_Type_Name & " is"); II (Convert_Package.Unit_Body); Append (Convert_Package.Unit_Body, "CORBA_Elements : constant " & Sequences_Instance & ".Element_Array :="); Append (Convert_Package.Unit_Body, " " & Sequences_Instance & ".To_Element_Array (CORBA_Val.Array_Values);"); if Type_Kind (Array_Type_Definition) = A_Constrained_Array_Definition then Append (Convert_Package.Unit_Body, "Ada_Elements : " & Conversion_Ada_Type_Name & ";"); else Append (Convert_Package.Unit_Body, "Ada_Elements : " & Conversion_Ada_Type_Name & "("); Append (Convert_Package.Unit_Body, " " & To_Wide_String (Index_Subtype_Name) & "'Val (" & "CORBA_Val.Low_Bound + " & Sequences_Instance & ".Length (CORBA_Val.Array_Values)));"); end if; DI (Convert_Package.Unit_Body); Append (Convert_Package.Unit_Body, "begin"); II (Convert_Package.Unit_Body); II (Convert_Package.Unit_Body); Append (Convert_Package.Unit_Body, "for I in CORBA_Elements'Range loop"); II (Convert_Package.Unit_Body); Append (Convert_Package.Unit_Body, "Ada_Elements (" & To_Wide_String (Index_Subtype_Name) & "'Val (" & To_Wide_String (Index_Subtype_Name) & "'Pos (Ada_Elements'First) + I)) :="); Append (Convert_PAckage.Unit_Body, " To_Ada (CORBA_Elements (I));"); DI (Convert_Package.Unit_Body); Append (Convert_Package.Unit_Body, "end loop;"); NL (Convert_Package.Unit_Body); Append (Convert_Package.Unit_Body, "return Ada_Elements;"); DI (Convert_Package.Unit_Body); Append (Convert_Package.Unit_Body, "end To_Ada;"); end Produce_Body_Array; begin -- Produce_Type_Converters case Declaration_Kind (Ada_Declaration) is when An_Ordinary_Type_Declaration | A_Subtype_Declaration => declare Ada_Definition : constant Asis.Definition := Type_Declaration_View (Ada_Declaration); DK : constant Asis.Definition_Kinds := Definition_Kind (Ada_Definition); begin if DK = A_Subtype_Indication then -- A subtype declaration declare CORBA_Ancestor_Type : constant Node_Id := Type_Spec (Type_Declarator (Get_Translation (Ada_Declaration))); CORBA_Ancestor_Type_Name : Unbounded_Wide_String; begin Generate_Node (CORBA_Ancestor_Type, CORBA_Ancestor_Type_Name); Produce_Specification (Ada_Type_Name); Produce_Body_Nickname (Ada_Type_Name, Ada_Full_Name (Corresponding_Entity_Name_Declaration (Asis.Definitions.Subtype_Mark (Ada_Definition))), To_Wide_String (CORBA_Ancestor_Type_Name)); end; else pragma Assert (DK = A_Type_Definition); case Type_Kind (Ada_Definition) is when A_Derived_Type_Definition => -- A derivation of a non-tagged type. declare CORBA_Ancestor_Type : constant Node_Id := Type_Spec (Type_Declarator (Get_Translation (Ada_Declaration))); CORBA_Ancestor_Type_Name : Unbounded_Wide_String; begin Generate_Node (CORBA_Ancestor_Type, CORBA_Ancestor_Type_Name); Produce_Specification (Ada_Type_Name); Produce_Body_Nickname (Ada_Type_Name, Ada_Full_Name (Corresponding_Entity_Name_Declaration (Asis.Definitions.Subtype_Mark (Parent_Subtype_Indication (Ada_Definition)))), To_Wide_String (CORBA_Ancestor_Type_Name)); end; when An_Enumeration_Type_Definition => Produce_Specification (Ada_Type_Name); Produce_Body_Enum (Ada_Type_Name); when A_Signed_Integer_Type_Definition | A_Modular_Type_Definition | A_Floating_Point_Definition | An_Ordinary_Fixed_Point_Definition | A_Decimal_Fixed_Point_Definition => -- A new numeric type. -- XXX TODO Put_Line ("XXX numeric conversion not implemented."); when An_Unconstrained_Array_Definition | A_Constrained_Array_Definition => Produce_Specification (Ada_Type_Name); Produce_Body_Array (Ada_Type_Name); when A_Record_Type_Definition => -- XXX TODO Put_Line ("XXX record conversion not implemented."); when A_Tagged_Record_Type_Definition => Produce_Specification (Ada_Type_Name & "'Class"); Produce_Body_Opaque (Ada_Type_Name & "'Class"); when A_Derived_Record_Extension_Definition => -- XXX See below (private extension definition). null; when An_Access_Type_Definition => -- A RACW. declare DSA_Object_Subtype : constant Asis.Expression := Asis.Definitions.Subtype_Mark (Asis.Definitions.Access_To_Object_Definition (Ada_Definition)); DSA_Object_Name : constant Wide_String := Ada_Full_Name (Corresponding_Entity_Name_Declaration (DSA_Object_Subtype)); begin Add_Wide_With (Convert_Package.Unit_Spec, Unit_Full_Name (Enclosing_Compilation_Unit (Ada_Definition))); -- The Convert package spec needs the declaration of the -- newly-defined RACW type. Add_Wide_With (Convert_Package.Unit_Body, "RACW_DSA_" & Unit_Full_Name (Enclosing_Compilation_Unit (Corresponding_Entity_Name_Definition (DSA_Object_Subtype)))); -- The Convert package body needs the declaration of the -- parent Ada type, which is the canonical CIAO RACW -- for the distributed object. -- The declaration for the CORBA parent type -- is already visible, because the parent unit of -- the convert package contains the declaration of -- the new CORBA type as a subtype of the parent CORBA -- type (the forward object reference for the interface). -- XXX Thomas 2000-04-07 Thomas test... With_Convert_For_Type (Specific_Type_Spec (Type_Spec (Type_Declarator (IDL_Declaration))), Convert_Package.Unit_Body); -- The Convert package body requires the declaration -- of the conversion subprograms for the parent types. Produce_Specification (Ada_Type_Name); Produce_Body_Nickname (Ada_Type_Name, "RACW_DSA_" & DSA_Object_Name, "DSA_" & DSA_Object_Name & ".Ref", Unchecked_Conversion => True); end; when others => -- Cannot happen. raise Program_Error; end case; end if; end; when A_Task_Type_Declaration | A_Protected_Type_Declaration | A_Private_Type_Declaration => -- A non-(limited tagged) private type, -- or a task or protected type -- (translated as an encapsulation). if Declaration_Kind (Ada_Declaration) = A_Private_Type_Declaration and then Is_Tagged_Type (Ada_Declaration) then Produce_Specification (Ada_Type_Name & "'Class"); Produce_Body_Opaque (Ada_Type_Name & "'Class"); else Produce_Specification (Ada_Type_Name); Produce_Body_Opaque (Ada_Type_Name); end if; when A_Private_Extension_Declaration => -- A derivation of a non-limited tagged -- type. No conversion function is generated -- because those of the classwide root -- type are used. -- (See also above: A_Record_Extension_Definition.) -- XXX visibility?? Translator should set a semantic flag -- in the IDL tree on this node to state that -- With_Convert_For_Type should with the convert package -- for the /ancestor/ type (of which we have a scoped_name). -- => TODO in CIAO.Translator and in -- With_Convert_For_Type !! XXX null; when others => -- Cannot happen. raise Program_Error; end case; end Produce_Type_Converters; procedure Produce_Interface (IDL_Declaration : Node_Id) is Dummy : Unbounded_Wide_String; Distributed_Object_Declaration : constant Asis.Element := Origin (IDL_Declaration); Export : Node_Id := First (Interface_Body (IDL_Declaration)); Interface : Node_Id := First (Interfaces (IDL_Declaration)); Current_Name : constant Wide_String := Current_Ada_Name; begin Free (DSA_Package); DSA_Package := new Wide_String' (Current_Name (Current_Name'First + 4 .. Current_Name'Last)); -- Strip "DSA_" prefix. if not Is_Nil (Distributed_Object_Declaration) then -- This is a potentially distributed object type -- declared in a Pure or Remote_Types package. declare Object_Names : constant Asis.Defining_Name_List := Names (Distributed_Object_Declaration); Object_Name : constant Asis.Program_Text := Isolated_Element_Image (Object_Names (Object_Names'First)); Ref_Package : constant Wide_String := Current_Ada_Name; -- DSA_. Helper_Package : constant Wide_String := Current_Ada_Name & ".Helper"; -- DSA_..Helper RACW_Type : constant Wide_String := "RACW_" & Ref_Package; procedure Produce_Reference_Converters (Forward : Boolean) is To_Ref : constant Wide_String := Ref_Package & ".Helper.To_Ref"; Real_Ref_Type : constant Wide_String := Ref_Package & ".Ref"; Forward_Ref_Type : constant Wide_String := Ref_Package & "_Forward.Ref"; Ref_Type : Wide_String_Ptr; begin if Forward then Ref_Type := new Wide_String'(Forward_Ref_Type); else Ref_Type := new Wide_String'(Real_Ref_Type); end if; -- Specification NL (Convert_Package.Unit_Spec); if Forward then -- With the library package that contains the -- forward reference declaration. -- This is dependant on the CORBA implementation. -- The following is correct for Broca, where the -- instance of CORBA.Forward is a subpackage of -- the package that maps the enclosing scope. -- (In CIAO, the enclosing scope is always -- a or .) declare Dot : Integer := Ref_Package'Last; begin while (Ref_Package (Dot) /= '.') loop Dot := Dot - 1; pragma Assert (Dot > Ref_Package'First); end loop; Add_Wide_With (Convert_Package.Unit_Spec, Ref_Package (Ref_Package'First .. Dot - 1)); end; else Add_Wide_With (Convert_Package.Unit_Spec, Ref_Package); end if; Append (Convert_Package.Unit_Spec, "function To_CORBA (RACW : " & RACW_Type & ") return " & Ref_Type.all & ";"); Append (Convert_Package.Unit_Spec, "function To_Ada (Ref : " & Ref_Type.all & ") return " & RACW_Type & ";"); -- Body Add_With (Convert_Package.Unit_Body, To_String (Helper_Package)); NL (Convert_Package.Unit_Body); Append (Convert_Package.Unit_Body, "function To_CORBA (RACW : " & RACW_Type & ") return " & Ref_Type.all & " is"); II (Convert_Package.Unit_Body); Append (Convert_Package.Unit_Body, "use CORBA;"); Append (Convert_Package.Unit_Body, "use " & ObjectId_Sequences_Package & ";"); NL (Convert_Package.Unit_Body); Append (Convert_Package.Unit_Body, "St : aliased Stream;"); DI (Convert_Package.Unit_Body); Append (Convert_Package.Unit_Body, "begin"); II (Convert_Package.Unit_Body); Append (Convert_Package.Unit_Body, RACW_Type & "'Output (St'Access, RACW);"); if Forward then Append (Convert_Package.Unit_Body, "return " & Ref_Package & ".Convert_Forward.To_Forward"); Append (Convert_Package.Unit_Body, " (" & To_Ref); Append (Convert_Package.Unit_Body, " (Create_Reference_With_Id (" & Ref_Package & ".Impl.POA,"); Append (Convert_Package.Unit_Body, " PortableServer.ObjectId (To_Sequence " & "(Element_Array (Get_Seq (St)))),"); Append (Convert_Package.Unit_Body, " CORBA.To_CORBA_String (" & Ref_Package & ".Repository_Id))));"); else Append (Convert_Package.Unit_Body, "return " & To_Ref); Append (Convert_Package.Unit_Body, " (Create_Reference_With_Id (" & Ref_Package & ".Impl.POA,"); Append (Convert_Package.Unit_Body, " PortableServer.ObjectId (To_Sequence " & "(Element_Array (Get_Seq (St)))),"); Append (Convert_Package.Unit_Body, " CORBA.To_CORBA_String (" & Ref_Package & ".Repository_Id)));"); end if; DI (Convert_Package.Unit_Body); Append (Convert_Package.Unit_Body, "end To_CORBA;"); NL (Convert_Package.Unit_Body); Append (Convert_Package.Unit_Body, "function To_Ada (Ref : " & Ref_Type.all & ") return " & RACW_Type & " is"); II (Convert_Package.Unit_Body); Append (Convert_Package.Unit_Body, "Object_Id : constant PortableServer.ObjectId :="); if Forward then Append (Convert_Package.Unit_Body, " PortableServer.POA.Reference_To_Id (" & Ref_Package & ".Impl.POA, " & Ref_Package & ".Convert_Forward.From_Forward (Ref));"); else Append (Convert_Package.Unit_Body, " PortableServer.POA.Reference_To_Id (" & Ref_Package & ".Impl.POA, Ref);"); end if; DI (Convert_Package.Unit_Body); Append (Convert_Package.Unit_Body, "begin"); II (Convert_Package.Unit_Body); Append (Convert_Package.Unit_Body, "return ObjectId_To_RACW (Object_Id);"); DI (Convert_Package.Unit_Body); Append (Convert_Package.Unit_Body, "end To_Ada;"); end Produce_Reference_Converters; begin -- Declare a RACW for this interface, for our internal use Append (RACWs_Package.Unit_Spec, "type " & Object_Name & " is access all " & Ref_Package (Ref_Package'First + 4 .. Ref_Package'Last) & "'Class;"); -- Strip DSA_ prefix. NL (RACWs_Package.Unit_Spec); -- Declare conversion functions between RACW and CORBA -- reference. Add_Wide_With (Convert_Package.Unit_Spec, RACWs_Package.Name.all); Add_Wide_With (Convert_Package.Unit_Spec, "PortableServer", Elab_Control => Elaborate); -- For PortableServer.ObjectId. Add_Wide_With (Convert_Package.Unit_Body, "PortableServer.POA", Use_It => True, Elab_Control => Elaborate); -- For Create_Reference_With_Id. Add_Wide_With (Convert_Package.Unit_Body, Ref_Package & ".Impl"); Add_Wide_With (Convert_Package.Unit_Body, "CIAO_Runtime.Encap_Streams", Use_It => True); Add_Wide_With (Convert_Package.Unit_Body, ObjectId_Sequences_Dependency); ------------------------------------- -- The ObjectId to RACW converter. -- ------------------------------------- NL (Convert_Package.Unit_Spec); Append (Convert_Package.Unit_Spec, "function ObjectId_To_RACW (Object_Id : PortableServer.ObjectId)"); Append (Convert_Package.Unit_Spec, " return " & RACW_Type & ";"); NL (Convert_Package.Unit_Body); Append (Convert_Package.Unit_Body, "function ObjectId_To_RACW (Object_Id : PortableServer.ObjectId)"); Append (Convert_Package.Unit_Body, " return " & RACW_Type & " is"); II (Convert_Package.Unit_Body); Append (Convert_Package.Unit_Body, "use " & ObjectId_Sequences_Package & ";"); NL (Convert_Package.Unit_Body); Append (Convert_Package.Unit_Body, "St : aliased Stream;"); DI (Convert_Package.Unit_Body); Append (Convert_Package.Unit_Body, "begin"); II (Convert_Package.Unit_Body); Append (Convert_Package.Unit_Body, "Set_Seq (St, Octet_Array"); Append (Convert_Package.Unit_Body, " (To_Element_Array (" & ObjectId_Sequences_Package & ".Sequence (Object_Id))));"); Append (Convert_Package.Unit_Body, "return " & RACW_Type & "'Input (St'Access);"); DI (Convert_Package.Unit_Body); Append (Convert_Package.Unit_Body, "end ObjectId_To_RACW;"); ---------------------------------------- -- The reference <-> RACW converters. -- ---------------------------------------- Produce_Reference_Converters (Forward => False); Produce_Reference_Converters (Forward => True); end; end if; -- Generate implementation of the interface declare Ada_Name : constant Wide_String := Current_Ada_Name; Inh_Spec : constant List_Id := Inheritance_Spec (Interface_Header (IDL_Declaration)); ImS : CIAO.Ada_Source_Streams.Compilation_Unit renames Impl_Package.Unit_Spec; ImB : CIAO.Ada_Source_Streams.Compilation_Unit renames Impl_Package.Unit_Body; begin Impl_Package := New_Package (Ada_Name & ".Impl"); Add_Wide_With (ImS, "PortableServer.POA", Elab_Control => Elaborate); Add_Wide_With (ImB, Ada_Name & ".Skel", Use_It => False, Elab_Control => Elaborate); Add_Wide_With (ImB, "CIAO_Runtime.Convert", Use_It => True); if not Is_Remote_Subprograms (IDL_Declaration) then Add_Wide_With (ImB, Convert_Package.Name.all, Use_It => True); -- We are producing the interface that represents a distributed -- object: the corresponding conversion subprograms reside -- in the current conversion package. end if; if Is_Empty_List (Inh_Spec) then -- This interface has no ancestors Add_Wide_With (ImS, "PortableServer"); PL (ImS, "type Object is new PortableServer.Servant_Base with null record;"); else declare Ancestor : constant Node_Id := First (Inh_Spec); Ancestor_Name : Unbounded_Wide_String; begin Generate_Node (Ancestor, Ancestor_Name); Add_Wide_With (ImS, To_Wide_String (Ancestor_Name) & ".Impl"); PL (ImS, "type Object is new " & To_Wide_String (Ancestor_Name) & ".Impl.Object" & " with null record;"); end; end if; NL (ImS); PL (ImS, "type Object_Ptr is access all Object;"); while Present (Export) loop Generate_Node (Export, Dummy); Export := Next (Export); end loop; while Present (Interface) loop Generate_Node (Interface, Dummy); Export := Next (Interface); end loop; Add_Wide_With (ImB, "PortableServer"); Add_Wide_With (ImS, "PortableServer.POA"); Add_Wide_With (ImS, "PortableServer.POAManager"); NL (ImB); PL (ImB, "My_Server : constant Object_Ptr := new Object;"); if not Is_Nil (Distributed_Object_Declaration) then NL (ImS); PL (ImS, "POA : PortableServer.POA.Ref;"); -- That POA is used by the Convert package for this interface, -- so it must be exposed by the Impl. Add_Wide_With (ImB, "CORBA"); Add_Wide_With (ImB, "PortableServer.POAManager"); Add_Wide_With (ImB, "Ada.Text_IO", Use_It => True); -- For display of the IOR (To_Standard_String, Put_Line). NL (ImB); PL (ImB, "procedure Initialize_Proxy (Root_POA : PortableServer.POA.Ref)"); PL (ImB, "is"); II (ImB); PL (ImB, "use PortableServer;"); NL (ImB); PL (ImB, "Nil_POAManager : PortableServer.POAManager.Ref;"); NL (ImB); DI (ImB); PL (ImB, "begin"); II (ImB); NL (ImB); PL (ImB, "-- Create the POA"); NL (ImB); PL (ImB, "POA := PortableServer.POA.Ref (PortableServer.POA.Create_POA"); PL (ImB, " (Root_POA,"); II (ImB); PL (ImB, "CORBA.To_CORBA_String (""" & Ada_Name & "_Proxy""),"); PL (ImB, "A_POAManager => Nil_POAManager,"); PL (ImB, "Tp => ORB_CTRL_MODEL,"); PL (ImB, "Lp => TRANSIENT,"); PL (ImB, "Up => MULTIPLE_ID,"); PL (ImB, "Ip => USER_ID,"); PL (ImB, "Ap => NO_IMPLICIT_ACTIVATION,"); PL (ImB, "Sp => NON_RETAIN,"); PL (ImB, "Rp => USE_DEFAULT_SERVANT));"); DI (ImB); NL (ImB); PL (ImB, "-- Set the default servant"); NL (ImB); PL (ImB, "PortableServer.POA.Set_Servant (POA, PortableServer.Servant (My_Server));"); NL (ImB); PL (ImB, "-- Activate the POAManager"); NL (ImB); PL (ImB, "PortableServer.POAManager.Activate"); PL (ImB, " (PortableServer.POA.Get_The_POAManager (POA));"); DI (ImB); PL (ImB, "end Initialize_Proxy;"); NL (ImB); else Add_Wide_With (ImB, "CORBA"); Add_Wide_With (ImB, "Ada.Text_IO", Use_It => True); -- For display of the IOR (To_Standard_String, Put_Line). Add_Wide_With (ImB, "Broca.Naming_Tools"); -- To register the RCI reference with the CORBA Naming Service. NL (ImS); PL (ImS, "procedure Initialize_Proxy (Root_POA : PortableServer.POA.Ref);"); NL (ImS); NL (ImB); PL (ImB, "procedure Initialize_Proxy (Root_POA : PortableServer.POA.Ref) is"); II (ImB); PL (ImB, "My_Server_Oid : PortableServer.ObjectId;"); PL (ImB, "My_Server_Ref : CORBA.Object.Ref;"); PL (ImB, "IOR : CORBA.String;"); DI (ImB); PL (ImB, "begin"); II (ImB); PL (ImB, "My_Server_Oid := PortableServer.POA.Activate_Object"); PL (ImB, " (Root_Poa, PortableServer.Servant (My_Server));"); PL (ImB, "My_Server_Ref := PortableServer.POA.Servant_To_Reference"); PL (ImB, " (Root_Poa, PortableServer.Servant (My_Server));"); NL (ImB); PL (ImB, "Broca.Naming_Tools.Register (""CIAO.subcontext/" & Ada_Name & ".Remote Call Interface"", My_Server_Ref, Rebind => True);"); -- XXX hard-coded constants: CIAO.subcontext, Remote Call Interface PL (ImB, "IOR := CORBA.Object.Object_To_String (My_Server_Ref);"); PL (ImB, "Put_Line (""'"" & CORBA.To_Standard_String (IOR) & ""'"");"); DI (ImB); PL (ImB, "end Initialize_Proxy;"); end if; Divert (ImB, Elaboration); Add_Wide_With (ImB, "CORBA.ORB", Elab_Control => Elaborate); PL (ImB, "Initialize_Proxy"); PL (ImB, " (Root_POA => PortableServer.POA.To_Ref"); PL (ImB, " (CORBA.ORB.Resolve_Initial_References"); PL (ImB, " (CORBA.ORB.To_CORBA_String (""RootPOA""))));"); Generate (Impl_Package); end; end Produce_Interface; procedure Generate_Node (N : Node_Id; Buffer : in out Unbounded_Wide_String) is begin case Node_Kind (N) is ----------------------------------------------------------- -- Nodes that generate an Ada representation into Buffer -- ----------------------------------------------------------- -- Scoped names when N_Scoped_Name => if Present (Prefix (N)) then if Node_Kind (Prefix (N)) = N_Scoped_Name then Generate_Node (Prefix (N), Buffer); Append (Buffer, "."); end if; end if; declare Name_Element : Wide_String := Get_Name (N); Prev_Underscore : Boolean := False; begin -- XXX This code should be factored with that of Current_Ada_Name. for I in Name_Element'Range loop if Prev_Underscore and then Name_Element (I) = '_' then Name_Element (I) := 'U'; Prev_Underscore := False; end if; Prev_Underscore := (Name_Element (I) = '_'); end loop; Append (Buffer, Name_Element); end; -- Keywords when N_Keyword_Default | N_Keyword_Void => Append (Buffer, Nkind'Wide_Image (Node_Kind (N))); when N_Keyword_In => Append (Buffer, "in"); when N_Keyword_Out => Append (Buffer, "out"); when N_Keyword_Inout => Append (Buffer, "in out"); -- Base types when N_Base_Type_Char => Append (Buffer, "CORBA.Char"); when N_Base_Type_Boolean => Append (Buffer, "CORBA.Boolean"); when N_Base_Type_Long => Append (Buffer, "CORBA.Long"); when N_Base_Type_Double => Append (Buffer, "CORBA.Double"); when N_Base_Type_Unsigned_Long => Append (Buffer, "CORBA.Unsigned_Long"); when N_Base_Type_Long_Long => Append (Buffer, "CORBA.Long_Long"); when N_Base_Type_Long_Double => Append (Buffer, "CORBA.Long_Double"); when N_Base_Type_Unsigned_Long_Long => Append (Buffer, "CORBA.Unsigned_Long_Long"); when N_Base_Type_String => Append (Buffer, "CORBA.String"); when N_Base_Type_Octet => Append (Buffer, "CORBA.Octet"); --------------------- -- Other terminals -- --------------------- -- Actually generated in N_Scoped_Name. -- when N_Absolute => -- -- XXX Put (File, "::"); when N_Preprocessor_Include => -- XXX NOT USED! if Unit_Used (N) then -- XXX Put (File, "#include """); -- XXX Put_Name (N); -- XXX | Put_Line (File, """"); null; end if; ------------------------------------------------------------- -- Nodes that produce code into the various proxy packages -- ------------------------------------------------------------- when N_Specification => declare Def : Node_Id := First (CIAO.IDL_Syntax.Definitions (N)); Int : Node_Id := First (Interfaces (N)); begin while Present (Def) loop Generate_Node (Def, Buffer); Def := Next (Def); end loop; while Present (Int) loop Generate_Node (Int, Buffer); Int := Next (Int); end loop; end; when N_Module => declare Def : Node_Id := First (CIAO.IDL_Syntax.Definitions (N)); Interface : Node_Id := First (Interfaces (N)); My_Name : constant Wide_String := Get_Name (N); begin Push (My_Name); if Depth = 1 then -- This is a "root" , i. e. one which is declared -- directly within a , and which embodies -- the translation of a library unit. -- The RACWs_Package contains the declaration of one canonical -- RACW for each interface declared in the module that corresponds -- to an actual DSA distributed object type. RACWs_Package := New_Package ("RACW_" & Current_Ada_Name); Add_Wide_With (RACWs_Package.Unit_Spec, My_Name (My_Name'First + 4 .. My_Name'Last)); -- Strip DSA_ prefix. -- The RACWs package depends on the declaration of the -- actual DSA objet types. NL (RACWs_Package.Unit_Spec); PL (RACWs_Package.Unit_Spec, "pragma Remote_Types;"); Set_Empty (RACWs_Package.Unit_Spec); -- The Convert_Package contains converter subprograms for the various -- types declared in the module. Convert_Package := New_Package (Current_Ada_Name & ".Convert"); else NL (RACWs_Package.Unit_Spec); Append (RACWs_Package.Unit_Spec, "package " & My_Name & " is"); II (RACWs_Package.Unit_Spec); end if; while Present (Def) loop Generate_Node (Def, Buffer); Def := Next (Def); end loop; while Present (Interface) loop Generate_Node (Interface, Buffer); Interface := Next (Interface); end loop; if Depth = 1 then NL (RACWs_Package.Unit_Spec); NL (RACWs_Package.Unit_Body); Generate (RACWs_Package); NL (Convert_Package.Unit_Spec); NL (Convert_Package.Unit_Body); Generate (Convert_Package); else DI (RACWs_Package.Unit_Spec); Append (RACWs_Package.Unit_Spec, "end " & My_Name & ";"); end if; Pop; end; when N_Interface => Generate_Node (Specific_Interface (N), Buffer); when N_Interface_Dcl => declare My_Name : constant Wide_String := Get_Name (Interface_Header (N)); Initial_Depth : Integer; begin Push (My_Name); Initial_Depth := Depth; if Is_Remote_Subprograms (N) then if Depth = 1 then -- This is a "root" , i. e. one which is declared -- directly within a , and which embodies -- the translation of a (RCI) library unit. -- The RACWs_Package contains the declaration of one canonical -- RACW for each interface declared in the module that corresponds -- to an actual DSA distributed object type. RACWs_Package := New_Package ("RACW_" & Current_Ada_Name); Add_Wide_With (RACWs_Package.Unit_Spec, My_Name (My_Name'First + 4 .. My_Name'Last)); -- Strip DSA_ prefix. -- The RACWs package depends on the declaration of the -- actual DSA objet types. Append (RACWs_Package.Unit_Spec, "pragma Remote_Types;"); Set_Empty (RACWs_Package.Unit_Spec); -- The Convert_Package contains converter subprograms for the various -- types declared in the module. Convert_Package := New_Package (Current_Ada_Name & ".Convert"); else NL (RACWs_Package.Unit_Spec); Append (RACWs_Package.Unit_Spec, "package " & My_Name & " is"); II (RACWs_Package.Unit_Spec); end if; end if; Produce_Interface (N); if Is_Remote_Subprograms (N) then pragma Assert (Depth = Initial_Depth); if Initial_Depth = 1 then NL (RACWs_Package.Unit_Spec); NL (RACWs_Package.Unit_Body); Generate (RACWs_Package); NL (Convert_Package.Unit_Spec); NL (Convert_Package.Unit_Body); Generate (Convert_Package); else DI (RACWs_Package.Unit_Spec); Append (RACWs_Package.Unit_Spec, "end " & My_Name & ";"); NL (RACWs_Package.Unit_Spec); end if; end if; end; Pop; when N_Forward_Dcl => -- Nothing to do. null; when N_Interface_Header => null; when N_Type_Dcl => Produce_Type_Converters (N, Origin (N)); -- Generate conversion functions for the -- newly defined type. when N_Type_Declarator | N_Member => -- XXX Do nothing for now raise Program_Error; when N_Declarator => -- Generate_Node (Specific_Declarator (N), Buffer); -- XXX Do nothing for now null; when N_Simple_Declarator | N_Enumerator => -- XXX Put_Name (N); null; when N_Simple_Type_Spec => -- XXX Check that! -- XXX Untyped traversal! Node1 is either or . Generate_Node (Node1 (N), Buffer); when N_Type_Spec => Generate_Node (Specific_Type_Spec (N), Buffer); when N_Constr_Type_Spec => Generate_Node (Structure (N), Buffer); when N_Struct_Type => declare Member : Node_Id := First (Members (N)); begin -- XXX TODO pragma Assert (False); while Present (Member) loop Generate_Node (Member, Buffer); Member := Next (Member); end loop; Indent_Level := Indent_Level - 1; end; when N_Union_Type => -- XXX TODO pragma Assert (False); null; when N_Case_Element => -- XXX TODO raise Program_Error; when N_Element_Spec => -- XXX TODO raise Program_Error; when N_Enum_Type => declare Enumerator : Node_Id := First (Enumerators (N)); begin -- XXX TODO pragma Assert (False); -- XXX Put_Name (N); -- XXX | Put_Line (File, " {"); Indent_Level := Indent_Level + 1; while Present (Enumerator) loop -- XXX | Put_Indent; Generate_Node (Enumerator, Buffer); Enumerator := Next (Enumerator); if Present (Enumerator) then -- XXX Put (File, ","); null; end if; -- XXX | NL (File); end loop; Indent_Level := Indent_Level - 1; -- XXX | Put_Indent; -- XXX Put (File, "}"); end; when N_Sequence_Type => -- XXX Put (File, "sequence<"); Generate_Node (Specific_Type_Spec (N), Buffer); -- XXX Put (File, ">"); when N_Array_Declarator => declare Array_Size : Node_Id := First (Fixed_Array_Sizes (N)); begin -- XXX Put_Name (N); while Present (Array_Size) loop -- XXX Put (File, "["); -- XXX Put (File, Unbiased_Uint'Image (Size_Value (Array_Size))); -- XXX Put (File, "]"); Array_Size := Next (Array_Size); end loop; end; when N_Op_Dcl => declare Ada_Declaration : constant Asis.Declaration := Origin (N); type Parameter_Profile_Ptr is access Asis.Parameter_Specification_List; procedure Free is new Ada.Unchecked_Deallocation (Asis.Parameter_Specification_List, Parameter_Profile_Ptr); Profile_Buffer : Unbounded_Wide_String; Parameter_Profile : Parameter_Profile_Ptr := null; Result_Profile : Asis.Element := Nil_Element; Param_Dcl : Node_Id := First (Param_Dcls (N)); Op_Name : constant Wide_String := Get_Name (N); Is_Function : constant Boolean := Node_Kind (Operation_Value_Type (Op_Type_Spec (N))) /= N_Keyword_Void; begin -- NOT IMPLEMENTED. if Is_Function then Profile_Buffer := To_Unbounded_Wide_String ("function "); else Profile_Buffer := To_Unbounded_Wide_String ("procedure "); end if; Append (Profile_Buffer, Op_Name & " (Self : access Object"); while Present (Param_Dcl) loop Generate_Node (Param_Dcl, Profile_Buffer); With_Type (Param_Type_Spec (Param_Dcl), Impl_Package.Unit_Spec); With_Convert_For_Type (Param_Type_Spec (Param_Dcl), Impl_Package.Unit_Body); Param_Dcl := Next (Param_Dcl); end loop; Append (Profile_Buffer, ")"); if Is_Function then Append (Profile_Buffer, " return "); Generate_Node (Op_Type_Spec (N), Profile_Buffer); With_Convert_For_Type (Op_Type_Spec (N), Impl_Package.Unit_Body); end if; NL (Impl_Package.Unit_Spec); PL (Impl_Package.Unit_Spec, To_Wide_String (Profile_Buffer) & ";"); NL (Impl_Package.Unit_Body); PL (Impl_Package.Unit_Body, To_Wide_String (Profile_Buffer) & " is"); PL (Impl_Package.Unit_Body, "begin"); II (Impl_Package.Unit_Body); PL (Impl_Package.Unit_Body, "declare"); II (Impl_Package.Unit_Body); case Declaration_Kind (Ada_Declaration) is when A_Procedure_Declaration => Add_Wide_With (Impl_Package.Unit_Body, Unit_Full_Name (Enclosing_Compilation_Unit (Ada_Declaration))); Parameter_Profile := new Asis.Parameter_Specification_List' (Asis.Declarations.Parameter_Profile (Ada_Declaration)); when A_Function_Declaration => Add_Wide_With (Impl_Package.Unit_Body, Unit_Full_Name (Enclosing_Compilation_Unit (Ada_Declaration))); Parameter_Profile := new Asis.Parameter_Specification_List' (Asis.Declarations.Parameter_Profile (Ada_Declaration)); Result_Profile := Asis.Declarations.Result_Profile (Ada_Declaration); when An_Ordinary_Type_Declaration => -- A remote access to subprogram declaration. case Access_Type_Kind (Type_Declaration_View (Ada_Declaration)) is when An_Access_To_Procedure | An_Access_To_Protected_Procedure => Parameter_Profile := new Parameter_Specification_List' (Access_To_Subprogram_Parameter_Profile (Type_Declaration_View (Ada_Declaration))); when An_Access_To_Function | An_Access_To_Protected_Function => Parameter_Profile := new Parameter_Specification_List' (Access_To_Subprogram_Parameter_Profile (Type_Declaration_View (Ada_Declaration))); Result_Profile := Access_To_Function_Result_Profile (Type_Declaration_View (Ada_Declaration)); when others => -- XXX Error cannot happen raise Program_Error; end case; when A_Constant_Declaration | A_Deferred_Constant_Declaration | An_Integer_Number_Declaration | A_Real_Number_Declaration => -- A constant declaration. Result_Profile := Asis.Definitions.Subtype_Mark (Object_Declaration_View (Ada_Declaration)); -- XXX A constant of a record or array type ??? when others => -- XXX Error cannot happen raise Program_Error; end case; if Parameter_Profile /= null then declare P : Parameter_Specification_List renames Parameter_Profile.all; Implicit_Self_Parameter : Asis.Element := Nil_Element; Subprogram_Name : constant Asis.Defining_Name_List := Names (Ada_Declaration); First_Parameter : Boolean := True; begin if Declaration_Kind (Ada_Declaration) in A_Procedure_Declaration .. A_Function_Declaration and then not (Is_Remote_Subprograms (Parent (N))) then -- This interface corresponds to a real -- distributed object type: every operation -- has an implicit Self parameter. declare Controlling_Formals : constant Asis.Parameter_Specification_List := Controlling_Formal_Parameters (Ada_Declaration); begin Implicit_Self_Parameter := Controlling_Formals (Controlling_Formals'First); end; end if; -- The invocation syntagm for the subprogram is constructed -- in Buffer. Buffer := To_Unbounded_Wide_String (Ada_Full_Name (Ada_Declaration)); for I in P'Range loop declare N : constant Asis.Defining_Name_List := Names (P (I)); Parameter_Name : constant Asis.Program_Text := Isolated_Element_Image (N (N'First)); begin if First_Parameter then First_Parameter := False; Append (Buffer, " ("); else Append (Buffer, ", "); end if; -- Append (Buffer, Parameter_Name & " => Ada_" & Parameter_Name); -- Named parameter associations cause -- problems with DSA in GNAT 3.12p and -- earlier (GNAT bug 7112-004). Append (Buffer, "Ada_" & Parameter_Name); if Is_Identical (Implicit_Self_Parameter, P (I)) then -- The actual for the implicit Self parameter is -- of a derived type of its first subtype. Add_Wide_With (Impl_Package.Unit_Body, "RACW_DSA_" & Unit_Full_Name (Enclosing_Compilation_Unit (Corresponding_Entity_Name_Definition (Declaration_Subtype_Mark (P (I)))))); if Trait_Kind (P (I)) /= An_Access_Definition_Trait then -- This parameter is not an access parameter. Append (Buffer, ".all"); end if; PL (Impl_Package.Unit_Body, "Self_ObjectId : constant PortableServer.ObjectId"); PL (Impl_Package.Unit_Body, " := PortableServer.POA.Servant_To_Id (POA, PortableServer.Servant (Self));"); PL (Impl_Package.Unit_Body, "Ada_" & Parameter_Name & " : constant RACW_DSA_" & Ada_Full_Name (Corresponding_Entity_Name_Declaration (Declaration_Subtype_Mark (P (I)))) & " := ObjectId_To_RACW (Self_ObjectId);"); elsif Is_Controlling_Formal (P (I)) then -- ...the same goes for other (explicit) controlling -- formal parameters. Add_Wide_With (Impl_Package.Unit_Body, "RACW_DSA_" & Unit_Full_Name (Enclosing_Compilation_Unit (Corresponding_Entity_Name_Definition (Declaration_Subtype_Mark (P (I)))))); Append (Impl_Package.Unit_Body, "Ada_" & Parameter_Name & " : constant RACW_" & Ada_Full_Name (Corresponding_Entity_Name_Declaration (Declaration_Subtype_Mark (P (I)))) & " := To_Ada (" & Parameter_Name & ");"); else declare Ada_Type_Name : constant Asis.Program_Text := Ada_Full_Name (Corresponding_Entity_Name_Declaration (Declaration_Subtype_Mark (P (I)))); begin Append (Impl_Package.Unit_Body, "Ada_" & Parameter_Name & " : constant " & Ada_Type_Name & " := " & Ada_Type_Name & " (To_Ada (" & Parameter_Name & "));"); end; end if; end; end loop; if not First_Parameter then Append (Buffer, ")"); end if; Append (Buffer, ";"); end; end if; DI (Impl_Package.Unit_Body); Append (Impl_Package.Unit_Body, "begin"); II (Impl_Package.Unit_Body); if Is_Function then PL (Impl_Package.Unit_Body, "declare"); II (Impl_Package.Unit_Body); declare Invocation : constant Unbounded_Wide_String := Buffer; begin PL (Impl_Package.Unit_Body, "Result : constant " & Ada_Full_Name (Corresponding_Entity_Name_Declaration (Result_Profile))); PL (Impl_Package.Unit_Body, " := " & To_Wide_String (Invocation)); end; DI (Impl_Package.Unit_Body); PL (Impl_Package.Unit_Body, "begin"); II (Impl_Package.Unit_Body); PL (Impl_Package.Unit_Body, "declare"); II (Impl_Package.Unit_Body); Buffer := To_Unbounded_Wide_String ("CORBA_Result : constant "); Generate_Node (Op_Type_Spec (N), Buffer); Append (Buffer, " := To_CORBA (Result);"); PL (Impl_Package.Unit_Body, To_Wide_String (Buffer)); DI (Impl_Package.Unit_Body); PL (Impl_Package.Unit_Body, "begin"); II (Impl_Package.Unit_Body); PL (Impl_Package.Unit_Body, "return CORBA_Result;"); DI (Impl_Package.Unit_Body); PL (Impl_Package.Unit_Body, "end;"); DI (Impl_Package.Unit_Body); PL (Impl_Package.Unit_Body, "exception"); II (Impl_Package.Unit_Body); -- XXX TODO exceptions for conversion of result PL (Impl_Package.Unit_Body, "when others => raise;"); DI (Impl_Package.Unit_Body); PL (Impl_Package.Unit_Body, "end;"); else -- TODO invoke procedure PL (Impl_Package.Unit_Body, To_Wide_String (Buffer)); end if; DI (Impl_Package.Unit_Body); PL (Impl_Package.Unit_Body, "exception"); II (Impl_Package.Unit_Body); -- XXX TODO exceptions for execution of the request PL (Impl_Package.Unit_Body, "when others => raise;"); DI (Impl_Package.Unit_Body); PL (Impl_Package.Unit_Body, "end;"); DI (Impl_Package.Unit_Body); PL (Impl_Package.Unit_Body, "exception"); II (Impl_Package.Unit_Body); -- XXX TODO exceptions for conversion of parameters PL (Impl_Package.Unit_Body, "when others => raise;"); DI (Impl_Package.Unit_Body); PL (Impl_Package.Unit_Body, "end " & Op_Name & ";"); -- Generate_Node (Raises_Expr (N)); -- NOT IMPLEMENTED. end; when N_Op_Type_Spec => Generate_Node (Operation_Value_Type (N), Buffer); when N_Param_Type_Spec => -- XXX ugly abstraction violation! Untyped traversal. Generate_Node (Node1 (N), Buffer); when N_Param_Dcl => declare Param_Name : constant Wide_String := Get_Name (N); begin Append (Buffer, "; " & Param_Name & " : "); Generate_Node (Parameter_Attribute (N), Buffer); Append (Buffer, " "); Generate_Node (Param_Type_Spec (N), Buffer); end; when N_Param_Attribute => -- XXX ugly abstraction violation! Untyped traversal. Generate_Node (Node1 (N), Buffer); when N_Raises_Expr => -- XXX TODO raise Program_Error; when others => -- Impossible, should not happen! -- (N_Empty, N_Error, N_Unused_At_Start). -- /XXXXXX raise Program_Error; pragma Assert (False); null; end case; end Generate_Node; Dummy : Unbounded_Wide_String; begin Generate_Node (Tree, Dummy); end Generate; end CIAO.Generator.Proxy; polyorb-2.8~20110207.orig/compilers/ciao/ciao-asis_queries.ads0000644000175000017500000002762311750740337023430 0ustar xavierxavier---------------------------------------- -- -- -- ---- --- -- ---- -- -- - - - - - - -- -- - - ---- - - -- -- ---- --- - - ---- -- -- -- ---------------------------------------- -- CORBA -- -- Interface for -- -- Ada'95 distributed systems annex -- -- Objects -- ---------------------------------------- -- Copyright (c) 1999-2002 -- -- École nationale supérieure des -- -- télécommunications -- ---------------------------------------- -- Various ASIS queries for CIAO. with Asis; with Asis.Exceptions; package CIAO.ASIS_Queries is ASIS_Inappropriate_Element : exception renames Asis.Exceptions.ASIS_Inappropriate_Element; ASIS_Failed : exception renames Asis.Exceptions.ASIS_Failed; function Is_Ancestor (Ancestor_Compilation_Unit : Asis.Compilation_Unit; Compilation_Unit : Asis.Compilation_Unit) return Boolean; ---------------------------------------------------------------------------- -- Ancestor_Compilation_Unit - Specifies a putative ancestor. -- Compilation_Unit - Specifies the compilation unit to query. -- -- Returns True if, and only if, Ancestor_Compilation_Unit is -- an ancestor of Compilation_Unit. -- -- All Unit_Kinds are expected. function Corresponding_Entity_Name_Definition (Reference : Asis.Expression) return Asis.Defining_Name; ---------------------------------------------------------------------------- -- Reference - Specifies an expression to query -- -- Returns the defining_identifier, defining_character_literal, -- defining_operator_symbol, or defining_program_unit_name from the -- declaration of the referenced entity. -- -- In case of renaming, the function returns the new name for the entity. -- -- Appropriate Expression_Kinds: -- An_Identifier -- A_Selected_Component -- An_Attribute_Reference -- -- Returns Element_Kinds: -- Not_An_Element -- A_Defining_Name -- function Corresponding_Entity_Name_Declaration (Reference : Asis.Expression) return Asis.Declaration; ---------------------------------------------------------------------------- -- Reference - Specifies the expression to query -- -- Returns the declaration that declared the entity named by the given -- reference. The result is exactly the same as: -- -- Result := Corresponding_Entity_Name_Definition (Subtype_Mark); -- if not Is_Nil (Result) then -- Result := Enclosing_Element (Result); -- end if; -- return Result; -- -- Appropriate Element_Kinds: -- An_Expression -- -- Appropriate Expression_Kinds: -- An_Identifier -- A_Selected_Component -- An_Attribute_Reference -- -- Returns Element_Kinds: -- A_Declaration -- A_Nil_Element -- function Is_Type_Conformant (Declaration_1, Declaration_2 : Asis.Declaration) return Boolean; ---------------------------------------------------------------------------- -- Declaration_1, Declaration_2 - Specify the declarations to query. -- -- Returns True if, and only if, the two declarations are -- type conformant subprogram declarations. -- -- Returns False for any unexpected Declaration. -- -- Expected Declaration_Kinds: -- A_Procedure_Declaration -- A_Function_Declaration function Is_Tagged_Type (Declaration : Asis.Declaration) return Boolean; ---------------------------------------------------------------------------- -- Declaration - Specifies the declaration to query. -- -- Returns True if, and only if, the Declaration declares -- a subtype of a tagged type. -- -- Returns False for any unexpected Declaration. -- -- Expected Declaration_Kinds: -- A_Subtype_Declaration -- An_Ordinary_Type_Declaration -- A_Private_Type_Declaration -- A_Private_Extension_Declaration function Is_Limited_Type (Declaration : Asis.Declaration) return Boolean; ---------------------------------------------------------------------------- -- Declaration - Specifies the declaration to query. -- -- Returns True if, and only if, the Declaration declares -- a subtype of a limited type. -- -- Returns False for any unexpected Declaration. -- -- Expected Declaration_Kinds: -- A_Task_Type_Declaration -- A_Protected_Type_Declaration -- A_Subtype_Declaration -- An_Ordinary_Type_Declaration -- A_Private_Type_Declaration -- A_Private_Extension_Declaration function Discrete_Subtype_Name (Definition : Asis.Definition) return Asis.Program_Text; ---------------------------------------------------------------------------- -- Definition - Specifies the definition to query. -- -- Returns the name of the named subtype underlying -- the (anonymous) discrete subtype denoted by a -- Discrete_Subtype_Definition. -- -- Appropriate Definition_Kinds: -- A_Discrete_Subtype_Definition function Is_Overriding_Inherited_Subprogram (Subprogram_Declaration : Asis.Declaration; Derived_Type_Declaration : Asis.Declaration) return Boolean; ---------------------------------------------------------------------------- -- Subprogram_Declaration - Specifies the subprogram declaration to query -- Derived_Type_Declaration - Specifies the derived type declaration -- to query -- -- Returns True if the Subprogram_Declaration overrides a subprogram -- that was implicitly inherited from the parent type in the -- Derived_Type_Declaration. -- -- Returns False for any unexpected Declaration. -- -- Expected Declaration_Kinds: -- A_Procedure_Declaration -- A_Function_Declaration function Is_Controlling_Result (Result_Profile : Asis.Expression) return Boolean; ---------------------------------------------------------------------------- -- Result_Profile - Specifies the Result_Profile to query. -- -- Returns True if, and only if, Result_Profile is the result -- profile of a function declaration and it is a controlling result. -- -- Returns False for any unexpected Expression. -- -- Expected Expression_Kinds: -- An_Identifier -- A_Selected_Component -- An_Attribute_Reference function Is_Controlling_Formal (Parameter_Specification : Asis.Parameter_Specification) return Boolean; ---------------------------------------------------------------------------- -- Parameter_Specification - Specifies the Parameter_Specification -- to query. -- -- Returns True if, and only if, the Parameter_Specification -- defines a controlling formal parameter of its subprogram declaration. function Controlling_Formal_Parameters (Declaration : Asis.Declaration) return Asis.Parameter_Specification_List; ---------------------------------------------------------------------------- -- Declaration - Specifies the subprogram or entry declaration to query -- -- Returns a list of parameter specifications in the formal part of the -- subprogram or entry declaration that are controlling formal parameters, -- in their order of appearance. -- -- Returns a Nil_Element_List if the subprogram or entry has no -- controlling formal parameters. -- -- Appropriate Declaration_Kinds: -- A_Procedure_Declaration -- A_Function_Declaration -- A_Procedure_Body_Declaration -- A_Function_Body_Declaration -- A_Procedure_Renaming_Declaration -- A_Function_Renaming_Declaration -- An_Entry_Declaration -- An_Entry_Body_Declaration -- A_Procedure_Body_Stub -- A_Function_Body_Stub -- A_Generic_Function_Declaration -- A_Generic_Procedure_Declaration -- A_Formal_Function_Declaration -- A_Formal_Procedure_Declaration -- -- Returns Declaration_Kinds: -- A_Parameter_Specification function Enclosing_Basic_Declaration (Element : Asis.Element) return Asis.Declaration; ---------------------------------------------------------------------------- -- Element - Specifies the element to query -- -- Returns the basic_declaration Element that immediately encloses the -- given element. If Element is a basic_declaration, return Element. -- -- Appropriate Element_Kinds: -- A_Pragma -- A_Defining_Name -- A_Definition -- An_Expression -- An_Association -- A_Declaration -- -- Appropriate *_Kinds... XXX -- function Isolated_Element_Image (Element : Asis.Element) return Asis.Program_Text; ---------------------------------------------------------------------------- -- Element - Specifies the element to query -- -- Returns a program text image of the element. The image of an element -- can span more than one line, in which case the program text returned by -- the function Delimiter_Image separates the individual lines. The bounds -- on the returned program text value are 1..N, N is as large as necessary. -- -- Returns a null string if not Is_Text_Available(Element). -- -- The image will not be space-padded. -- -- NOTE: The image of a large element can exceed the range of Program_Text. -- In this case, the exception ASIS_Failed is raised with a Status of -- Capacity_Error. Use the Lines function to operate on the image of large -- elements. -- function Ada_Full_Name (Declaration : Asis.Declaration) return Asis.Program_Text; ---------------------------------------------------------------------------- -- Element - Specifies the element to query -- -- Returns a program text image of the fully qualified name of the entity -- (unambiguously) declared by the Declaration (which shall be a -- declaration with a unique name, such as a subprogram, type, -- subtype or formal parameter declaration. -- -- The image will not be space-padded. -- -- Appropriate Element_Kinds: -- A_Declaration -- function Declaration_Name (Declaration : Asis.Declaration) return Asis.Defining_Name; ---------------------------------------------------------------------------- -- Element - Specifies the element to query -- -- Returns the single defining name of a declaration that has only one -- (such as a subprogram, type or formal parameter declaration). -- -- Appropriate Element_Kinds: -- A_Declaration -- function Is_Asynchronous (Element : Asis.Declaration) return Boolean; ---------------------------------------------------------------------------- -- Element - Specifies the declaration to query. -- Compilation_Unit - Specifies the compilation unit to query. -- -- Returns True if, and only if, Element is a declaration to -- which a pragma Asynchronous applies (Declaration may be -- a remote procedure declaration, a RAS declaration or a RACW -- declaration). -- -- Appropriate Element_Kinds: -- A_Declaration -- type Unit_Categories is (Pure, Remote_Types, Remote_Call_Interface, Other); -- A type used to denote the category of a library unit -- as defined by the Distributed Systems Annex. function Unit_Category (LU : in ASIS.Compilation_Unit) return Unit_Categories; -- Returns the category (Pure, RT, RCI or Other) -- of a library unit. end CIAO.ASIS_Queries; polyorb-2.8~20110207.orig/compilers/ciao/ciao-generator-proxy.ads0000644000175000017500000000240511750740337024070 0ustar xavierxavier---------------------------------------- -- -- -- ---- --- -- ---- -- -- - - - - - - -- -- - - ---- - - -- -- ---- --- - - ---- -- -- -- ---------------------------------------- -- CORBA -- -- Interface for -- -- Ada'95 distributed systems annex -- -- Objects -- ---------------------------------------- -- Copyright (c) 1999 -- -- École nationale supérieure des -- -- télécommunications -- ---------------------------------------- -- The proxy package generator. -- Produces a CORBA servant implementation from an -- annotated IDL tree obtained as output of the translator. with CIAO.Generator.ORB_Deps_G; with CIAO.Types; use CIAO.Types; generic with package ORB_Deps is new CIAO.Generator.ORB_Deps_G (<>); package CIAO.Generator.Proxy is procedure Generate (Tree : in Node_Id); -- Generate a CORBA servant implementation for -- the remotely callable entitites (remote procedures, -- remote accesses to subprogram and remote -- accesses to class-wide type). end CIAO.Generator.Proxy; polyorb-2.8~20110207.orig/compilers/ciao/README0000644000175000017500000000554311750740337020207 0ustar xavierxavier---------------------------------------- -- -- -- ---- --- -- ---- -- -- - - - - - - -- -- - - ---- - - -- -- ---- --- - - ---- -- -- -- ---------------------------------------- -- CORBA -- -- Interface for -- -- Ada'95 distributed systems annex -- -- Objects -- ---------------------------------------- -- Copyright (C) 1999 -- -- École nationale supérieure des -- -- télécommunications -- ---------------------------------------- -- Parts Copyright (C) -- -- Free Software Fundation, Inc. -- ---------------------------------------- Created by Thomas Quinot . $Id: README 33963 2002-11-06 22:38:19Z quinot $ The purpose of the CIAO project is to provide an automated means of providing a CORBA interface for CORBA clients to perform requests on existing Ada'95 Distributed Systems Annex packages. CIAO comprises: - a translator that generates an OMG IDL description of the visible part of a Remote_Types or Remote_Call_Interface Ada'95 package; - a code generator which produces an agent that listens to CORBA requests for the CORBA objects corresponding to the DSA package, and services them by performing the corresponding DSA calls. The translator accepts as entry all legal Ada'95 library units that have the Pure, Remote_Types or Remote_Call_Interface category, with some restrictions listed in the documentation. Usage ----- 1. Run ciao once for the specification of each RCI or RT package in your application: $ ciao -tkf rci1.ads $ ciao -tkf rci2.ads $ ciao -tkf rt1.ads $ ciao -tkf rt2.ads This produces IDL declarations and proxy implementation for each package. 2. Run idlac, AdaBroker's IDL to Ada compiler, for each of the generated IDL contracts: $ idlac rci1.idl $ idlac rci2.idl $ idlac rt1.idl $ idlac rt2.idl 3. Add the proxy partition in your GNATDIST configuration file: ProxyP : Partition := (DSA_RCI1.Impl, DSA_RCI2.Impl); -- List all RCI impls here. procedure Proxy_Main; -- proxy_main.adb is part of the CIAO distribution for ProxyP'Main use Proxy_Main; for ProxyP'Termination use Local_Termination; 4. Run gnatdist. You need to have a configured AdaBroker source tree in $AB_SRC. $ gnatdist `adabroker-config --cflags` \ -I$AB_SRC/cos/naming -I$AB_SRC/idls/cos/naming \ -largs `adabroker-config --libs` The generated proxy partition acts as a CORBA server. It will register each RCI package with the CORBA Naming Service. CORBA clients can then query the naming service to obtain references to RCI packages, and invoke services provided by these packages to obtain references to DSA distributed objects. polyorb-2.8~20110207.orig/compilers/ciao/proxy_main.adb0000644000175000017500000000267211750740337022164 0ustar xavierxavier---------------------------------------- -- -- -- ---- --- -- ---- -- -- - - - - - - -- -- - - ---- - - -- -- ---- --- - - ---- -- -- -- ---------------------------------------- -- CORBA -- -- Interface for -- -- Ada'95 distributed systems annex -- -- Objects -- ---------------------------------------- -- Copyright (c) 1999 -- -- École nationale supérieure des -- -- télécommunications -- ---------------------------------------- -- Main procedure for the proxy partition. -- Portable Object Adapter with CORBA; use CORBA; with CORBA.Object; with CORBA.ORB; use CORBA.ORB; with PortableServer; with PortableServer.POA; with PortableServer.POAManager; -- Debug with Ada.Text_IO; use Ada.Text_IO; procedure Proxy_Main is Root_POA : constant PortableServer.POA.Ref := PortableServer.POA.To_Ref (Resolve_Initial_References (To_CORBA_String ("RootPOA"))); POA_Manager : constant PortableServer.POAManager.Ref := PortableServer.POA.Get_the_POAManager (Root_POA); begin Put_Line ("Starting proxy."); PortableServer.POAManager.Activate (POA_Manager); CORBA.ORB.Run; exception when others => Put_Line ("Proxy caught exception, exiting."); end Proxy_Main; polyorb-2.8~20110207.orig/compilers/ciao/ciao-translator-state.ads0000644000175000017500000000623411750740337024236 0ustar xavierxavier---------------------------------------- -- -- -- ---- --- -- ---- -- -- - - - - - - -- -- - - ---- - - -- -- ---- --- - - ---- -- -- -- ---------------------------------------- -- CORBA -- -- Interface for -- -- Ada'95 distributed systems annex -- -- Objects -- ---------------------------------------- -- Copyright (c) 1999-2002 -- -- École nationale supérieure des -- -- télécommunications -- ---------------------------------------- -- The internal state of the translator. with Asis; with CIAO.ASIS_Queries; package CIAO.Translator.State is use CIAO.ASIS_Queries; --------------------------------------------------- -- Translator_State -- -- Actual for the State_Information parameter in -- -- Iterator.Traverse_Element. -- --------------------------------------------------- type Translator_State is record Unit_Category : Unit_Categories := Other; -- The category (Pure, Remote_Types or Remote_Call_Interface) -- of the library unit being translated. Repository : Node_Id := No_Node; -- The topmost IDL node (a container for all others). Current_Node : Node_Id := No_Node; -- The IDL node which is being constructed. end record; procedure Initialize_Translator_State (Category : in Unit_Categories; Unit : in Asis.Compilation_Unit; Repository : in Node_Id; State : out Translator_State); -- Set the inital values of a Translator_State record. procedure Set_Translation (Element : Asis.Element; Translation : Node_Id); pragma Inline (Set_Translation); -- Record the IDL translation of an Element. procedure Set_Previous_Current_Node (Element : Asis.Element; Previous_Current_Node : Node_Id); pragma Inline (Set_Previous_Current_Node); -- Record the IDL node that was Current_Node when -- Element started being processed. This must be called -- before returning from a Pre_Translate_Element operation -- in an ASIS recursive iterator when State.Current_Node has -- been changed and the children of that node are processed -- using the implicit recursive traversal. In that case, -- the Post_Translate_Element operation must restore -- State.Current_Node to its recorded previous value when -- the element and all its children have been processed. function Get_Translation (Element : Asis.Element) return Node_Id; pragma Inline (Get_Translation); function Get_Previous_Current_Node (Element : Asis.Element) return Node_Id; pragma Inline (Get_Previous_Current_Node); function Get_Origin (Node : Node_Id) return Asis.Element; pragma Inline (Get_Origin); -- Return the original ASIS element at the origin of Node. -- If no such information was recorded (by a previous call -- to Set_Translation), return Nil_Element. end CIAO.Translator.State; polyorb-2.8~20110207.orig/compilers/ciao/ciao-ada_source_streams.adb0000644000175000017500000003016711750740337024553 0ustar xavierxavier---------------------------------------- -- -- -- ---- --- -- ---- -- -- - - - - - - -- -- - - ---- - - -- -- ---- --- - - ---- -- -- -- ---------------------------------------- -- CORBA -- -- Interface for -- -- Ada'95 distributed systems annex -- -- Objects -- ---------------------------------------- -- Copyright (c) 1999 -- -- Icole nationale supirieure des -- -- tilicommunications -- ---------------------------------------- -- An abstraction for the production of the text of -- an Ada 95 compilation unit. with Ada.Characters.Handling; use Ada.Characters.Handling; with Ada.Characters.Latin_1; use Ada.Characters.Latin_1; with Ada.Unchecked_Deallocation; with Ada.Text_IO; package body CIAO.Ada_Source_Streams is -- Semantic dependencies type Dependency_Node is record Library_Unit : String_Ptr; Use_It : Boolean := False; Elab_Control : Elab_Control_Pragma := None; Next : Dependency; end record; function Is_Ancestor (U1 : String; U2 : String) return Boolean; -- True if library unit U1 is an ancestor of U2. function Is_Ancestor (U1 : String; U2 : String) return Boolean is use Ada.Characters.Handling; LU1 : constant String := To_Lower (U1) & "."; LU2 : constant String := To_Lower (U2); begin return True and then LU1'Length <= LU2'Length and then LU1 = LU2 (LU2'First .. LU2'First + LU1'Length - 1); end Is_Ancestor; procedure Add_With (Unit : in out Compilation_Unit; Dep : String; Use_It : Boolean := False; Elab_Control : Elab_Control_Pragma := None) is Dep_Node : Dependency := Unit.Context_Clause; LU_Name : constant String := Unit.Library_Unit_Name.all; begin if False or else Dep = LU_Name or else Is_Ancestor (Dep, LU_Name) then -- No need to with oneself or one's ancestor. return; end if; if True and then Unit.Kind = Unit_Spec and then Is_Ancestor (LU_Name, Dep) then -- All hope abandon he who trieth to make a unit -- spec depend upon its child. raise Program_Error; end if; while Dep_Node /= null and then Dep_Node.Library_Unit.all /= Dep loop Dep_Node := Dep_Node.Next; end loop; if Dep_Node = null then Dep_Node := new Dependency_Node' (Library_Unit => new String'(Dep), Use_It => Use_It, Elab_Control => Elab_Control, Next => Unit.Context_Clause); Unit.Context_Clause := Dep_Node; else Dep_Node.Use_It := Dep_Node.Use_It or else Use_It; if Elab_Control = Elaborate_All or else Dep_Node.Elab_Control = Elaborate_All then Dep_Node.Elab_Control := Elaborate_All; elsif Elab_Control = Elaborate or else Dep_Node.Elab_Control = Elaborate then Dep_Node.Elab_Control := Elaborate; else Dep_Node.Elab_Control := None; end if; end if; end Add_With; procedure Add_Elaborate_Body (Unit : in out Compilation_Unit) is begin pragma Assert (Unit.Kind = Unit_Spec); Unit.Diversions (Visible_Declarations).Empty := False; Unit.Elaborate_Body := True; end Add_Elaborate_Body; procedure Suppress_Warning_Message (Unit : in out Compilation_Unit) is begin Unit.No_Warning := True; end Suppress_Warning_Message; -- Source streams (global) procedure Divert (CU : in out Compilation_Unit; Whence : Diversion) is begin if not (False or else Whence = Visible_Declarations or else (Whence = Private_Declarations and then CU.Kind = Unit_Spec) or else (Whence = Elaboration and then CU.Kind = Unit_Body) or else (Whence = Generic_Formals and then CU.Kind = Unit_Spec)) then raise Program_Error; end if; CU.Current_Diversion := Whence; end Divert; function New_Package (Name : String; Kind : Unit_Kind) return Compilation_Unit is The_Package : Compilation_Unit; begin The_Package.Library_Unit_Name := new String'(Name); The_Package.Kind := Kind; return The_Package; end New_Package; procedure Generate (Unit : in Compilation_Unit; Is_Generic_Instanciation : Boolean := False; To_Stdout : Boolean := False) is -- Helper subprograms for Generate function Ada_File_Name (Full_Name : String; Part : Unit_Kind := Unit_Spec) return String; -- The name of the file that contains Unit. function Is_Empty return Boolean; -- True if, and only if, any of Unit's diversions -- is not empty. function Ada_File_Name (Full_Name : String; Part : Unit_Kind := Unit_Spec) return String is Extension : constant array (Unit_Kind) of Character := (Unit_Spec => 's', Unit_Body => 'b'); Result : String := Full_Name & ".ad?"; begin for I in Result'First .. Result'Last - 4 loop if Result (I) = '.' then Result (I) := '-'; else Result (I) := To_Lower (Result (I)); end if; end loop; Result (Result'Last) := Extension (Part); return Result; end Ada_File_Name; function Is_Empty return Boolean is begin for I in Unit.Diversions'Range loop if not Unit.Diversions (I).Empty then return False; end if; end loop; return True; end Is_Empty; use Ada.Text_IO; procedure Emit_Standard_Header (File : in File_Type; User_Edited : in Boolean := False); procedure Emit_Source_Code (File : in File_Type); procedure Emit_Standard_Header (File : in File_Type; User_Edited : in Boolean := False) is begin Put_Line (File, "-------------------------------------------------------"); Put_Line (File, "-- This file has been generated automatically by CIAO."); if not User_Edited then Put_Line (File, "--"); Put_Line (File, "-- Do NOT hand-modify this file, as your"); Put_Line (File, "-- changes will be lost when you re-run the"); Put_Line (File, "-- IDL to Ada compiler."); end if; Put_Line (File, "-------------------------------------------------------"); New_Line (File); end Emit_Standard_Header; procedure Emit_Source_Code (File : in File_Type) is Dep_Node : Dependency := Unit.Context_Clause; begin while Dep_Node /= null loop Put (File, "with " & Dep_Node.Library_Unit.all & ";"); if Dep_Node.Use_It then Put_Line (File, " use " & Dep_Node.Library_Unit.all & ";"); else New_Line (File); end if; case Dep_Node.Elab_Control is when Elaborate_All => Put_Line (File, "pragma Elaborate_All (" & Dep_Node.Library_Unit.all & ");"); when Elaborate => Put_Line (File, "pragma Elaborate (" & Dep_Node.Library_Unit.all & ");"); when None => null; end case; Dep_Node := Dep_Node.Next; end loop; if Unit.Context_Clause /= null then New_Line (File); end if; if not Unit.Diversions (Generic_Formals).Empty then Put_Line (File, "generic"); Put (File, To_String (Unit.Diversions (Generic_Formals).Library_Item)); New_Line (File); end if; Put (File, "package "); if Unit.Kind = Unit_Body then Put (File, "body "); end if; Put_Line (File, Unit.Library_Unit_Name.all & " is"); if Unit.Elaborate_Body then New_Line (File); Put_Line (File, " pragma Elaborate_Body;"); end if; if not Unit.Diversions (Visible_Declarations).Empty then Put (File, To_String (Unit.Diversions (Visible_Declarations).Library_Item)); end if; if not Unit.Diversions (Private_Declarations).Empty then New_Line (File); Put_Line (File, "private"); Put (File, To_String (Unit.Diversions (Private_Declarations).Library_Item)); end if; if not Unit.Diversions (Elaboration).Empty then New_Line (File); Put_Line (File, "begin"); Put (File, To_String (Unit.Diversions (Elaboration).Library_Item)); end if; if not Is_Generic_Instanciation then New_Line (File); Put_Line (File, "end " & Unit.Library_Unit_Name.all & ";"); end if; end Emit_Source_Code; begin if Is_Empty then return; end if; if To_Stdout then Emit_Standard_Header (Current_Output, Unit.No_Warning); Emit_Source_Code (Current_Output); else declare File_Name : String := Ada_File_Name (Unit.Library_Unit_Name.all, Unit.Kind); File : File_Type; begin Create (File, Out_File, File_Name); Emit_Standard_Header (File, Unit.No_Warning); Emit_Source_Code (File); Close (File); end; end if; end Generate; -- Source code streams (diversion specific) procedure Set_Empty (Unit : in out Compilation_Unit) is begin Unit.Diversions (Unit.Current_Diversion).Empty := True; end Set_Empty; procedure Put (Unit : in out Compilation_Unit; Text : String) is Indent_String : constant String (1 .. Indent_Size * Unit.Diversions (Unit.Current_Diversion).Indent_Level) := (others => ' '); begin Unit.Diversions (Unit.Current_Diversion).Empty := False; if Unit.Diversions (Unit.Current_Diversion).At_BOL then Append (Unit.Diversions (Unit.Current_Diversion).Library_Item, Indent_String); Unit.Diversions (Unit.Current_Diversion).At_BOL := False; end if; Append (Unit.Diversions (Unit.Current_Diversion).Library_Item, Text); end Put; procedure Put_Line (Unit : in out Compilation_Unit; Line : String) is begin Put (Unit, Line); New_Line (Unit); end Put_Line; procedure New_Line (Unit : in out Compilation_Unit) is begin Append (Unit.Diversions (Unit.Current_Diversion).Library_Item, LF); Unit.Diversions (Unit.Current_Diversion).At_BOL := True; end New_Line; procedure Inc_Indent (Unit : in out Compilation_Unit) is begin Unit.Diversions (Unit.Current_Diversion).Indent_Level := Unit.Diversions (Unit.Current_Diversion).Indent_Level + 1; end Inc_Indent; procedure Dec_Indent (Unit : in out Compilation_Unit) is begin Unit.Diversions (Unit.Current_Diversion).Indent_Level := Unit.Diversions (Unit.Current_Diversion).Indent_Level - 1; end Dec_Indent; -- Finalization procedure Free is new Ada.Unchecked_Deallocation (String, String_Ptr); procedure Free is new Ada.Unchecked_Deallocation (Dependency_Node, Dependency); procedure Finalize (Object : in out Dependency_Node); procedure Finalize (Object : in out Dependency_Node) is begin if Object.Next /= null then Finalize (Object.Next.all); Free (Object.Next); end if; Free (Object.Library_Unit); end Finalize; procedure Finalize (Object : in out Compilation_Unit) is begin if Object.Context_Clause /= null then Finalize (Object.Context_Clause.all); Free (Object.Context_Clause); end if; end Finalize; end CIAO.Ada_Source_Streams; polyorb-2.8~20110207.orig/compilers/ciao/ciao-translator-maps.adb0000644000175000017500000005407611750740337024044 0ustar xavierxavier---------------------------------------- -- -- -- ---- --- -- ---- -- -- - - - - - - -- -- - - ---- - - -- -- ---- --- - - ---- -- -- -- ---------------------------------------- -- CORBA -- -- Interface for -- -- Ada'95 distributed systems annex -- -- Objects -- ---------------------------------------- -- Copyright (c) 1999 -- -- École nationale supérieure des -- -- télécommunications -- ---------------------------------------- -- Various mapping functions for CIAO.Translator. with Ada.Characters.Latin_1; use Ada.Characters.Latin_1; with Ada.Characters.Handling; use Ada.Characters.Handling; with Asis.Compilation_Units; use Asis.Compilation_Units; with Asis.Elements; use Asis.Elements; with Asis.Text; with Idl_Fe.Tree; use Idl_Fe.Tree; package body CIAO.Translator.Maps is -- function Internal_IDL_Module_Name -- (Library_Unit_Name : String) -- return String; -- function IDL_Module_Name (Library_Unit : Compilation_Unit) -- return String is -- Full_Name : constant String := -- To_String -- (Asis.Compilation_Units.Unit_Full_Name (Library_Unit)); -- begin -- return Internal_IDL_Module_Name (Full_Name); -- end IDL_Module_Name; -- function Internal_IDL_Module_Name -- (Library_Unit_Name : String) -- return String -- is -- Total_Dot_Count : Natural := 0; -- begin -- for I in Library_Unit_Name'Range loop -- if Library_Unit_Name (I) = '.' then -- Total_Dot_Count := Total_Dot_Count + 1; -- end if; -- end loop; -- declare -- IDL_Name : String (1 .. Library_Unit_Name'Length + Total_Dot_Count); -- Dot_Count : Natural := 0; -- begin -- for I in Library_Unit_Name'Range loop -- declare -- II : constant Integer := I - Library_Unit_Name'First; -- begin -- if Library_Unit_Name (I) /= '.' then -- IDL_Name -- (IDL_Name'First + Dot_Count + II) -- := Library_Unit_Name (I); -- else -- IDL_Name -- (IDL_Name'First + Dot_Count + II .. -- IDL_Name'First + Dot_Count + II + 1) -- := "__"; -- Dot_Count := Dot_Count + 1; -- end if; -- end; -- end loop; -- return "DSA_" & IDL_Name; -- end; -- end Internal_IDL_Module_Name; function Map_Loc (Element : Asis.Element) return Errors.Location is use Asis.Compilation_Units; use Asis.Text; ESpan : constant Span := Element_Span (Element); begin return Errors.Location' (Filename => new String' (To_String (Text_Name (Enclosing_Compilation_Unit (Element)))), Dirname => null, Line => ESpan.First_Line, Col => ESpan.First_Column); end Map_Loc; function Operator_Symbol_Identifier (Op : Asis.Defining_Name) return String is begin pragma Assert (Defining_Name_Kind (Op) = A_Defining_Operator_Symbol); case Operator_Kind (Op) is when An_And_Operator => return "Op_And"; when An_Or_Operator => return "Op_Or"; when An_Xor_Operator => return "Op_Xor"; when An_Equal_Operator => return "Op_Equal"; when A_Not_Equal_Operator => return "Op_Not_Equal"; when A_Less_Than_Operator => return "Op_Less_Than"; when A_Less_Than_Or_Equal_Operator => return "Op_Less_Than_Or_Equal"; when A_Greater_Than_Operator => return "Op_Greater_Than"; when A_Greater_Than_Or_Equal_Operator => return "Op_Greater_Than_Or_Equal"; when A_Plus_Operator => return "Op_Plus"; when A_Minus_Operator => return "Op_Minus"; when A_Concatenate_Operator => return "Op_Concatenate"; when A_Unary_Plus_Operator => return "Op_Unary_Plus"; when A_Unary_Minus_Operator => return "Op_Unary_Minus"; when A_Multiply_Operator => return "Op_Multiply"; when A_Divide_Operator => return "Op_Divide"; when A_Mod_Operator => return "Op_Mod"; when A_Rem_Operator => return "Op_Rem"; when An_Exponentiate_Operator => return "Op_Exponentiate"; when An_Abs_Operator => return "Op_Abs"; when A_Not_Operator => return "Op_Not"; when others => -- XXX Error raise Program_Error; return ""; end case; end Operator_Symbol_Identifier; function Character_Literal_Identifier (Ch : Program_Text) return String is Wide_Ch : Wide_Character; begin pragma Assert (True and then Ch'Length = 3 and then Ch (Ch'First) = ''' and then Ch (Ch'Last) = '''); Wide_Ch := Ch (Ch'First + 1); case To_Character (Wide_Ch) is when NUL => return "Ch_NUL"; when SOH => return "Ch_SOH"; when STX => return "Ch_STX"; when ETX => return "Ch_ETX"; when EOT => return "Ch_EOT"; when ENQ => return "Ch_ENQ"; when ACK => return "Ch_ACK"; when BEL => return "Ch_BEL"; when BS => return "Ch_BS"; when HT => return "Ch_HT"; when LF => return "Ch_LF"; when VT => return "Ch_VT"; when FF => return "Ch_FF"; when CR => return "Ch_CR"; when SO => return "Ch_SO"; when SI => return "Ch_SI"; when DLE => return "Ch_DLE"; when DC1 => return "Ch_DC1"; when DC2 => return "Ch_DC2"; when DC3 => return "Ch_DC3"; when DC4 => return "Ch_DC4"; when NAK => return "Ch_NAK"; when SYN => return "Ch_SYN"; when ETB => return "Ch_ETB"; when CAN => return "Ch_CAN"; when EM => return "Ch_EM"; when SUB => return "Ch_SUB"; when ESC => return "Ch_ESC"; when FS => return "Ch_FS"; when GS => return "Ch_GS"; when RS => return "Ch_RS"; when US => return "Ch_US"; -------------------------------- -- ISO 646 Graphic Characters -- -------------------------------- when Space => return "Ch_Space"; when Exclamation => return "Ch_Exclamation"; when Quotation => return "Ch_Quotation"; when Number_Sign => return "Ch_Number_Sign"; when Dollar_Sign => return "Ch_Dollar_Sign"; when Percent_Sign => return "Ch_Percent_Sign"; when Ampersand => return "Ch_Ampersand"; when Apostrophe => return "Ch_Apostrophe"; when Left_Parenthesis => return "Ch_Left_Parenthesis"; when Right_Parenthesis => return "Ch_Right_Parenthesis"; when Asterisk => return "Ch_Asterisk"; when Plus_Sign => return "Ch_Plus_Sign"; when Comma => return "Ch_Comma"; when Hyphen => return "Ch_Hyphen"; when Full_Stop => return "Ch_Full_Stop"; when Solidus => return "Ch_Solidus"; -- Decimal digits '0' though '9' are at positions 48 through 57 when '0' => return "Ch_0"; when '1' => return "Ch_1"; when '2' => return "Ch_2"; when '3' => return "Ch_3"; when '4' => return "Ch_4"; when '5' => return "Ch_5"; when '6' => return "Ch_6"; when '7' => return "Ch_7"; when '8' => return "Ch_8"; when '9' => return "Ch_9"; when Colon => return "Ch_Colon"; when Semicolon => return "Ch_Semicolon"; when Less_Than_Sign => return "Ch_Less_Than_Sign"; when Equals_Sign => return "Ch_Equals_Sign"; when Greater_Than_Sign => return "Ch_Greater_Than_Sign"; when Question => return "Ch_Question"; when Commercial_At => return "Ch_Commercial_At"; -- Letters 'A' through 'Z' are at positions 65 through 90 when 'A' => return "Ch_UC_A"; when 'B' => return "Ch_UC_B"; when 'C' => return "Ch_UC_C"; when 'D' => return "Ch_UC_D"; when 'E' => return "Ch_UC_E"; when 'F' => return "Ch_UC_F"; when 'G' => return "Ch_UC_G"; when 'H' => return "Ch_UC_H"; when 'I' => return "Ch_UC_I"; when 'J' => return "Ch_UC_J"; when 'K' => return "Ch_UC_K"; when 'L' => return "Ch_UC_L"; when 'M' => return "Ch_UC_M"; when 'N' => return "Ch_UC_N"; when 'O' => return "Ch_UC_O"; when 'P' => return "Ch_UC_P"; when 'Q' => return "Ch_UC_Q"; when 'R' => return "Ch_UC_R"; when 'S' => return "Ch_UC_S"; when 'T' => return "Ch_UC_T"; when 'U' => return "Ch_UC_U"; when 'V' => return "Ch_UC_V"; when 'W' => return "Ch_UC_W"; when 'X' => return "Ch_UC_X"; when 'Y' => return "Ch_UC_Y"; when 'Z' => return "Ch_UC_Z"; when Left_Square_Bracket => return "Ch_Left_Square_Bracket"; when Reverse_Solidus => return "Ch_Reverse_Solidus"; when Right_Square_Bracket => return "Ch_Right_Square_Bracket"; when Circumflex => return "Ch_Circumflex"; when Low_Line => return "Ch_Low_Line"; when Grave => return "Ch_Grave"; when LC_A => return "Ch_LC_A"; when LC_B => return "Ch_LC_B"; when LC_C => return "Ch_LC_C"; when LC_D => return "Ch_LC_D"; when LC_E => return "Ch_LC_E"; when LC_F => return "Ch_LC_F"; when LC_G => return "Ch_LC_G"; when LC_H => return "Ch_LC_H"; when LC_I => return "Ch_LC_I"; when LC_J => return "Ch_LC_J"; when LC_K => return "Ch_LC_K"; when LC_L => return "Ch_LC_L"; when LC_M => return "Ch_LC_M"; when LC_N => return "Ch_LC_N"; when LC_O => return "Ch_LC_O"; when LC_P => return "Ch_LC_P"; when LC_Q => return "Ch_LC_Q"; when LC_R => return "Ch_LC_R"; when LC_S => return "Ch_LC_S"; when LC_T => return "Ch_LC_T"; when LC_U => return "Ch_LC_U"; when LC_V => return "Ch_LC_V"; when LC_W => return "Ch_LC_W"; when LC_X => return "Ch_LC_X"; when LC_Y => return "Ch_LC_Y"; when LC_Z => return "Ch_LC_Z"; when Left_Curly_Bracket => return "Ch_Left_Curly_Bracket"; when Vertical_Line => return "Ch_Vertical_Line"; when Right_Curly_Bracket => return "Ch_Right_Curly_Bracket"; when Tilde => return "Ch_Tilde"; when DEL => return "Ch_DEL"; --------------------------------- -- ISO 6429 Control Characters -- --------------------------------- when Reserved_128 => return "Ch_Reserved_128"; when Reserved_129 => return "Ch_Reserved_129"; when BPH => return "Ch_BPH"; when NBH => return "Ch_NBH"; when Reserved_132 => return "Ch_Reserved_132"; when NEL => return "Ch_NEL"; when SSA => return "Ch_SSA"; when ESA => return "Ch_ESA"; when HTS => return "Ch_HTS"; when HTJ => return "Ch_HTJ"; when VTS => return "Ch_VTS"; when PLD => return "Ch_PLD"; when PLU => return "Ch_PLU"; when RI => return "Ch_RI"; when SS2 => return "Ch_SS2"; when SS3 => return "Ch_SS3"; when DCS => return "Ch_DCS"; when PU1 => return "Ch_PU1"; when PU2 => return "Ch_PU2"; when STS => return "Ch_STS"; when CCH => return "Ch_CCH"; when MW => return "Ch_MW"; when SPA => return "Ch_SPA"; when EPA => return "Ch_EPA"; when SOS => return "Ch_SOS"; when Reserved_153 => return "Ch_Reserved_153"; when SCI => return "Ch_SCI"; when CSI => return "Ch_CSI"; when ST => return "Ch_ST"; when OSC => return "Ch_OSC"; when PM => return "Ch_PM"; when APC => return "Ch_APC"; ------------------------------ -- Other Graphic Characters -- ------------------------------ -- Character positions 160 (16#A0#) .. 175 (16#AF#) when No_Break_Space => return "Ch_No_Break_Space"; when Inverted_Exclamation => return "Ch_Inverted_Exclamation"; when Cent_Sign => return "Ch_Cent_Sign"; when Pound_Sign => return "Ch_Pound_Sign"; when Currency_Sign => return "Ch_Currency_Sign"; when Yen_Sign => return "Ch_Yen_Sign"; when Broken_Bar => return "Ch_Broken_Bar"; when Section_Sign => return "Ch_Section_Sign"; when Diaeresis => return "Ch_Diaeresis"; when Copyright_Sign => return "Ch_Copyright_Sign"; when Feminine_Ordinal_Indicator => return "Ch_Feminine_Ordinal_Indicator"; when Left_Angle_Quotation => return "Ch_Left_Angle_Quotation"; when Not_Sign => return "Ch_Not_Sign"; when Soft_Hyphen => return "Ch_Soft_Hyphen"; when Registered_Trade_Mark_Sign => return "Ch_Registered_Trade_Mark_Sign"; when Macron => return "Ch_Macron"; -- Character positions 176 (16#B0#) .. 191 (16#BF#) when Degree_Sign => return "Ch_Degree_Sign"; when Plus_Minus_Sign => return "Ch_Plus_Minus_Sign"; when Superscript_Two => return "Ch_Superscript_Two"; when Superscript_Three => return "Ch_Superscript_Three"; when Acute => return "Ch_Acute"; when Micro_Sign => return "Ch_Micro_Sign"; when Pilcrow_Sign => return "Ch_Pilcrow_Sign"; when Middle_Dot => return "Ch_Middle_Dot"; when Cedilla => return "Ch_Cedilla"; when Superscript_One => return "Ch_Superscript_One"; when Masculine_Ordinal_Indicator => return "Ch_Masculine_Ordinal_Indicator"; when Right_Angle_Quotation => return "Ch_Right_Angle_Quotation"; when Fraction_One_Quarter => return "Ch_Fraction_One_Quarter"; when Fraction_One_Half => return "Ch_Fraction_One_Half"; when Fraction_Three_Quarters => return "Ch_Fraction_Three_Quarters"; when Inverted_Question => return "Ch_Inverted_Question"; -- Character positions 192 (16#C0#) .. 207 (16#CF#) when UC_A_Grave => return "Ch_UC_A_Grave"; when UC_A_Acute => return "Ch_UC_A_Acute"; when UC_A_Circumflex => return "Ch_UC_A_Circumflex"; when UC_A_Tilde => return "Ch_UC_A_Tilde"; when UC_A_Diaeresis => return "Ch_UC_A_Diaeresis"; when UC_A_Ring => return "Ch_UC_A_Ring"; when UC_AE_Diphthong => return "Ch_UC_AE_Diphthong"; when UC_C_Cedilla => return "Ch_UC_C_Cedilla"; when UC_E_Grave => return "Ch_UC_E_Grave"; when UC_E_Acute => return "Ch_UC_E_Acute"; when UC_E_Circumflex => return "Ch_UC_E_Circumflex"; when UC_E_Diaeresis => return "Ch_UC_E_Diaeresis"; when UC_I_Grave => return "Ch_UC_I_Grave"; when UC_I_Acute => return "Ch_UC_I_Acute"; when UC_I_Circumflex => return "Ch_UC_I_Circumflex"; when UC_I_Diaeresis => return "Ch_UC_I_Diaeresis"; -- Character positions 208 (16#D0#) .. 223 (16#DF#) when UC_Icelandic_Eth => return "Ch_UC_Icelandic_Eth"; when UC_N_Tilde => return "Ch_UC_N_Tilde"; when UC_O_Grave => return "Ch_UC_O_Grave"; when UC_O_Acute => return "Ch_UC_O_Acute"; when UC_O_Circumflex => return "Ch_UC_O_Circumflex"; when UC_O_Tilde => return "Ch_UC_O_Tilde"; when UC_O_Diaeresis => return "Ch_UC_O_Diaeresis"; when Multiplication_Sign => return "Ch_Multiplication_Sign"; when UC_O_Oblique_Stroke => return "Ch_UC_O_Oblique_Stroke"; when UC_U_Grave => return "Ch_UC_U_Grave"; when UC_U_Acute => return "Ch_UC_U_Acute"; when UC_U_Circumflex => return "Ch_UC_U_Circumflex"; when UC_U_Diaeresis => return "Ch_UC_U_Diaeresis"; when UC_Y_Acute => return "Ch_UC_Y_Acute"; when UC_Icelandic_Thorn => return "Ch_UC_Icelandic_Thorn"; when LC_German_Sharp_S => return "Ch_LC_German_Sharp_S"; -- Character positions 224 (16#E0#) .. 239 (16#EF#) when LC_A_Grave => return "Ch_LC_A_Grave"; when LC_A_Acute => return "Ch_LC_A_Acute"; when LC_A_Circumflex => return "Ch_LC_A_Circumflex"; when LC_A_Tilde => return "Ch_LC_A_Tilde"; when LC_A_Diaeresis => return "Ch_LC_A_Diaeresis"; when LC_A_Ring => return "Ch_LC_A_Ring"; when LC_AE_Diphthong => return "Ch_LC_AE_Diphthong"; when LC_C_Cedilla => return "Ch_LC_C_Cedilla"; when LC_E_Grave => return "Ch_LC_E_Grave"; when LC_E_Acute => return "Ch_LC_E_Acute"; when LC_E_Circumflex => return "Ch_LC_E_Circumflex"; when LC_E_Diaeresis => return "Ch_LC_E_Diaeresis"; when LC_I_Grave => return "Ch_LC_I_Grave"; when LC_I_Acute => return "Ch_LC_I_Acute"; when LC_I_Circumflex => return "Ch_LC_I_Circumflex"; when LC_I_Diaeresis => return "Ch_LC_I_Diaeresis"; -- Character positions 240 (16#F0#) .. 255 (16#FF) when LC_Icelandic_Eth => return "Ch_LC_Icelandic_Eth"; when LC_N_Tilde => return "Ch_LC_N_Tilde"; when LC_O_Grave => return "Ch_LC_O_Grave"; when LC_O_Acute => return "Ch_LC_O_Acute"; when LC_O_Circumflex => return "Ch_LC_O_Circumflex"; when LC_O_Tilde => return "Ch_LC_O_Tilde"; when LC_O_Diaeresis => return "Ch_LC_O_Diaeresis"; when Division_Sign => return "Ch_Division_Sign"; when LC_O_Oblique_Stroke => return "Ch_LC_O_Oblique_Stroke"; when LC_U_Grave => return "Ch_LC_U_Grave"; when LC_U_Acute => return "Ch_LC_U_Acute"; when LC_U_Circumflex => return "Ch_LC_U_Circumflex"; when LC_U_Diaeresis => return "Ch_LC_U_Diaeresis"; when LC_Y_Acute => return "Ch_LC_Y_Acute"; when LC_Icelandic_Thorn => return "Ch_LC_Icelandic_Thorn"; when LC_Y_Diaeresis => return "Ch_LC_Y_Diaeresis"; end case; end Character_Literal_Identifier; function Base_Type (T : Root_Type) return Node_Id is use Errors; begin case T is when Root_Integer => return Make_Long (No_Location); when Root_Modular => return Make_Unsigned_Long (No_Location); when Root_Real => return Make_Double (No_Location); -- Change these to long long, unsigned long long and long double -- if the CORBA software supports it. when Root_Boolean => return Make_Boolean (No_Location); when Root_Char => return Make_Char (No_Location); when Root_String => return Make_String (No_Location); end case; end Base_Type; end CIAO.Translator.Maps; polyorb-2.8~20110207.orig/compilers/ciao/ciao-generator-broca.adb0000644000175000017500000002153411750740337023760 0ustar xavierxavier---------------------------------------- -- -- -- ---- --- -- ---- -- -- - - - - - - -- -- - - ---- - - -- -- ---- --- - - ---- -- -- -- ---------------------------------------- -- CORBA -- -- Interface for -- -- Ada'95 distributed systems annex -- -- Objects -- ---------------------------------------- -- Copyright (c) 1999 -- -- École nationale supérieure des -- -- télécommunications -- ---------------------------------------- -- ORB-specific matter, Broca version. with Ada.Strings.Wide_Unbounded; use Ada.Strings.Wide_Unbounded; with CIAO.Nlists; use CIAO.Nlists; with CIAO.IDL_Syntax; use CIAO.IDL_Syntax; with CIAO.IDL_Tree; use CIAO.IDL_Tree; with CIAO.Types; use CIAO.Types; package body CIAO.Generator.Broca is function Broca_Sequences_Package (N : Node_Id) return Wide_String is ----------------------- -- Local subprograms -- ----------------------- function Sequence_Base_Package (N : Node_Id) return Wide_String; -- Return the base name for the sequence type denoted -- by N_Type_Dcl node N. function Count_Sequences (Root : Node_Id; Up_To : Node_Id) return Integer; -- From Root, count recursively the sequence () nodes -- up to, but not including, including Up_To. Root shall be a -- or node. -------------------------------- -- Local subprograms (bodies) -- -------------------------------- function Sequence_Base_Package (N : Node_Id) return Wide_String is Buffer : Unbounded_Wide_String := To_Unbounded_Wide_String ("IDL_"); Current_Node : Node_Id := N; begin while Node_Kind (Current_Node) = N_Sequence_Type loop Append (Buffer, "SEQUENCE_"); Current_Node := Specific_Type_Spec (Current_Node); if Node_Kind (Template_Type_Spec (Current_Node)) = N_Sequence_Type then Current_Node := Template_Type_Spec (Current_Node); end if; end loop; -- Current_Node is now the innermost -- of the . Current_Node := Node1 (Current_Node); -- XXX UGLY abstraction violation. case Node_Kind (Current_Node) is when N_Scoped_Name => Append (Buffer, Get_Name (Current_Node)); -- XXX The following cases should be tested! when N_Base_Type_Boolean => Append (Buffer, "Boolean"); when N_Base_Type_Long => Append (Buffer, "Long"); when N_Base_Type_Double => Append (Buffer, "Double"); when N_Base_Type_Unsigned_Long => Append (Buffer, "Unsigned_Long_Long"); when N_Base_Type_Long_Long => Append (Buffer, "Long_Long"); when N_Base_Type_Long_Double => Append (Buffer, "Long_Double"); when N_Base_Type_Unsigned_Long_Long => Append (Buffer, "Unsigned_Long_Long"); when N_Base_Type_String => Append (Buffer, "String"); when N_Base_Type_Octet => Append (Buffer, "Octet"); when others => -- XXX ERROR should not happen raise Program_Error; end case; return To_Wide_String (Buffer); end Sequence_Base_Package; function Count_Sequences (Root : Node_Id; Up_To : Node_Id) return Integer is Dummy : Boolean; Count : Integer := 0; procedure Count_Sequences (Root : Node_Id; Up_To : Node_Id; Count : in out Integer; Stop_Here : out Boolean) is N : Node_Id; begin Stop_Here := False; case Node_Kind (Root) is when N_Module | N_Specification => N := First (Definitions (Root)); Module: while Present (N) loop if True and then Node_Kind (N) = N_Type_Dcl and then Node_Kind (Specific_Type_Spec (Type_Spec (Type_Declarator (N)))) = N_Simple_Type_Spec then declare TTS_Node : constant Node_Id := Template_Type_Spec (Specific_Type_Spec (Type_Spec (Type_Declarator (N)))); begin if TTS_Node = Up_To then Stop_Here := True; return; elsif Node_Kind (TTS_Node) = N_Sequence_Type then Count := Count + 1; end if; end; elsif True and then Node_Kind (N) = N_Type_Dcl and then Node_Kind (Specific_Type_Spec (Type_Spec (Type_Declarator (N)))) = N_Constr_Type_Spec and then Node_Kind (Structure (Specific_Type_Spec (Type_Spec (Type_Declarator (N))))) in N_Compound_Type then Count_Sequences (Structure (Specific_Type_Spec (Type_Spec (Type_Declarator (N)))), Up_To, Count, Stop_Here); exit Module when Stop_Here; -- elsif Type_Dcl and Array_Dcl then Count... elsif Node_Kind (N) = N_Module then Count_Sequences (N, Up_To, Count, Stop_Here); exit Module when Stop_Here; end if; N := Next (N); end loop Module; when N_Struct_Type => N := First (Members (Root)); while Present (N) loop if Node_Kind (Specific_Type_Spec (Type_Spec (N))) = N_Simple_Type_Spec then declare TTS_Node : constant Node_Id := Template_Type_Spec (Specific_Type_Spec (Type_Spec (N))); begin if TTS_Node = Up_To then Stop_Here := True; return; elsif Node_Kind (TTS_Node) = N_Sequence_Type then Count := Count + 1; end if; end; end if; N := Next (N); end loop; when others => -- XXX ERROR should not happen raise Program_Error; end case; end Count_Sequences; begin Count_Sequences (Root, Up_To, Count, Dummy); return Count; end Count_Sequences; Scope : Node_Id := N; begin ----------------------------- -- Broca_Sequences_Package -- ----------------------------- pragma Assert (Node_Kind (N) = N_Sequence_Type); while Node_Kind (Scope) /= N_Specification loop Scope := Parent (Scope); pragma Assert (Node_Kind (Scope) /= N_Empty); end loop; declare Base_Name : constant Wide_String := Sequence_Base_Package (N); Pos : Integer := Count_Sequences (Scope, N); begin if Pos = 0 then return Base_Name; else declare Pos_Image : Wide_String := Natural'Wide_Image (Pos); begin return Base_Name & "_" & Pos_Image (Pos_Image'First + 1 .. Pos_Image'Last); end; end if; end; end Broca_Sequences_Package; end CIAO.Generator.Broca; polyorb-2.8~20110207.orig/compilers/ciao/ciao_runtime-encap_streams.ads0000644000175000017500000000317011750740337025312 0ustar xavierxavier---------------------------------------- -- -- -- ---- --- -- ---- -- -- - - - - - - -- -- - - ---- - - -- -- ---- --- - - ---- -- -- -- ---------------------------------------- -- CORBA -- -- Interface for -- -- Ada'95 distributed systems annex -- -- Objects -- ---------------------------------------- -- Copyright (c) 1999 -- -- École nationale supérieure des -- -- télécommunications -- ---------------------------------------- -- A DSA stream based on a CORBA Encapsulation -- (sequence). with Ada.Streams; use Ada.Streams; with CORBA.Sequences.Unbounded; package CIAO_Runtime.Encap_Streams is package IDL_SEQUENCE_Octet is new CORBA.Sequences.Unbounded (CORBA.Octet); subtype Sequence is IDL_SEQUENCE_Octet.Sequence; subtype Octet_Array is IDL_SEQUENCE_Octet.Element_Array; type Stream is new Ada.Streams.Root_Stream_Type with private; procedure Set_Seq (St : in out Stream; Ar : Octet_Array); function Get_Seq (St : Stream) return Octet_Array; private type Stream is new Ada.Streams.Root_Stream_Type with record Seq : Sequence; Pos : Natural := 0; end record; procedure Read (St : in out Stream; Item : out Stream_Element_Array; Last : out Stream_Element_Offset); procedure Write (St : in out Stream; Item : in Stream_Element_Array); end CIAO_Runtime.Encap_Streams; polyorb-2.8~20110207.orig/compilers/ciao/ada_be-mappings-dsa.adb0000644000175000017500000002434411750740337023553 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- ADABROKER COMPONENTS -- -- -- -- A D A _ B E . M A P P I N G S . D S A -- -- -- -- B o d y -- -- -- -- Copyright (C) 1999-2002 ENST Paris University, France. -- -- -- -- AdaBroker is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. AdaBroker is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with AdaBroker; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- AdaBroker is maintained by ENST Paris University. -- -- (email: broker@inf.enst.fr) -- -- -- ------------------------------------------------------------------------------ -- The DSA personality IDL mapping. with Ada.Characters.Handling; -- use Ada.Characters.Handling; with Asis.Compilation_Units; use Asis.Compilation_Units; with Asis.Elements; use Asis.Elements; with Asis.Declarations; with Errors; use Errors; with Idl_Fe.Tree; use Idl_Fe.Tree; with Idl_Fe.Tree.Synthetic; use Idl_Fe.Tree.Synthetic; with Ada_Be.Identifiers; use Ada_Be.Identifiers; with Ada_Be.Idl2Ada; use Ada_Be.Idl2Ada; with CIAO.ASIS_Queries; with CIAO.Translator.State; use CIAO.Translator.State; package body Ada_Be.Mappings.DSA is use Idl_Fe.Types; function Library_Unit_Name (Self : access DSA_Mapping_Type; Node : Node_Id) return String is NK : constant Node_Kind := Kind (Node); begin case NK is when K_Interface | K_Module | K_ValueType | K_Ben_Idl_File => declare E : constant Asis.Element := Get_Origin (Node); begin if not Is_Nil (E) then return Ada.Characters.Handling.To_String (Unit_Full_Name (Enclosing_Compilation_Unit (E))); else return "Standard"; end if; end; when K_Enum | K_Union | K_Struct | K_Declarator | K_Forward_Interface | K_Forward_ValueType | K_Boxed_ValueType | K_Exception | K_Sequence_Instance | K_String_Instance => return Library_Unit_Name (Self, Parent_Scope (Node)); when K_Scoped_Name => return Library_Unit_Name (Self, Value (Node)); when K_Short | K_Long | K_Long_Long | K_Unsigned_Short | K_Unsigned_Long | K_Unsigned_Long_Long | K_Char | K_Wide_Char | K_Boolean | K_Float | K_Double | K_Long_Double | K_String | K_Wide_String => return "Standard"; when K_Octet => return "Ada.Streams"; when K_Any => return "PolyORB.Any"; when K_Object => return "DSA.Object"; when others => Error ("A " & NK'Img & " is not a mapped entity.", Fatal, Get_Location (Node)); end case; return ""; end Library_Unit_Name; function Client_Stubs_Unit_Name (Self : access DSA_Mapping_Type; Node : Idl_Fe.Types.Node_Id) return String is begin return Library_Unit_Name (Self, Node) & "_Stubs"; end Client_Stubs_Unit_Name; ------------------- -- Map_Type_Name -- ------------------- procedure Map_Type_Name (Self : access DSA_Mapping_Type; Node : Node_Id; Unit : out ASU.Unbounded_String; Typ : out ASU.Unbounded_String) is NK : constant Node_Kind := Kind (Node); begin Unit := +Library_Unit_Name (Self, Node); case NK is when K_Interface | K_Forward_Interface | K_ValueType | K_Forward_ValueType => Typ := +(Library_Unit_Name (Self, Node) & "." & Ada_Type_Defining_Name (Node)); when K_Sequence_Instance => Typ := +(Ada_Full_Name (Node) & ".Sequence"); when K_String_Instance => Typ := +(Ada_Full_Name (Node) & ".Bounded_String"); when K_Enum | K_Union | K_Struct | K_Exception | K_Boxed_ValueType | K_Declarator => Typ := +Ada_Full_Name (Node); when K_Scoped_Name => Map_Type_Name (Self, Value (Node), Unit, Typ); when K_Short => Typ := +"Integer"; -- XXX What if a subtype thereof was meant? when K_Long => Typ := +"Integer"; -- XXX ditto when K_Long_Long => Typ := +"Integer"; -- XXX ditto when K_Unsigned_Short => Typ := +"Natural"; -- XXX ditto when K_Unsigned_Long => Typ := +"Natural"; -- XXX ditto when K_Unsigned_Long_Long => Typ := +"Natural"; -- XXX ditto when K_Char => Typ := +"Character"; when K_Wide_Char => Typ := +"Wide_Character"; when K_Boolean => Typ := +"Boolean"; when K_Float => Typ := +"Float"; when K_Double => Typ := +"Float"; when K_Long_Double => Typ := +"Float"; when K_String => Typ := +"String"; when K_Wide_String => Typ := +"Wide_String"; when K_Octet => Typ := +"Ada.Streams.Stream_Element"; when K_Object => Typ := +"DSA.Object.Ref"; when K_Any => Typ := +"PolyORB.Any.Any"; when others => -- Improper use: node N is not -- mapped to an Ada type. Error ("This Ada_Type_Name : A " & NK'Img & " does not denote a type.", Fatal, Get_Location (Node)); -- Keep the compiler happy. raise Program_Error; end case; end Map_Type_Name; ------------------------ -- Self_For_Operation -- ------------------------ function Self_For_Operation (Self : access DSA_Mapping_Type; Node : Idl_Fe.Types.Node_Id) return String is use CIAO.ASIS_Queries; E : constant Asis.Element := Get_Origin (Node); PS_Node : constant Node_Id := Parent_Scope (Node); begin if Unit_Category (Enclosing_Compilation_Unit (E)) = Remote_Call_Interface then -- This is an RPC operation from an RCI package: -- the Self object is determined internally by -- the calling stubs. return Client_Stubs_Unit_Name (Self, PS_Node) & ".Get_Target_Ref"; else declare Controlling_Formals : constant Asis.Parameter_Specification_List := Controlling_Formal_Parameters (E); CFN : constant Asis.Defining_Name_List := Asis.Declarations.Names (Controlling_Formals (Controlling_Formals'First)); begin return Ada.Characters.Handling.To_String (Asis.Declarations.Defining_Name_Image (CFN (CFN'First))); end; end if; end Self_For_Operation; --------------------------- -- Server_Skel_Unit_Name -- --------------------------- function Server_Skel_Unit_Name (Self : access DSA_Mapping_Type; Node : Idl_Fe.Types.Node_Id) return String is begin return Ada_Name (Node) & "_RPC_Receiver"; end Server_Skel_Unit_Name; ------------------------------------- -- Generate_Scope_In_Child_Package -- ------------------------------------- function Generate_Scope_In_Child_Package (Self : access DSA_Mapping_Type; Node : Idl_Fe.Types.Node_Id) return Boolean is use CIAO.ASIS_Queries; E : constant Asis.Element := Get_Origin (Node); NK : constant Node_Kind := Kind (Node); begin pragma Assert (Is_Gen_Scope (Node)); case NK is when K_Module => return Is_Equal (E, Unit_Declaration (Enclosing_Compilation_Unit (E))); -- True only if E is a library unit declaration. when K_Interface => return Unit_Category (Enclosing_Compilation_Unit (E)) = Remote_Call_Interface; when others => return False; end case; -- Not reached. end Generate_Scope_In_Child_Package; ------------------------ -- Calling_Stubs_Type -- ------------------------ function Calling_Stubs_Type (Self : access DSA_Mapping_Type; Node : Idl_Fe.Types.Node_Id) return String is begin return Name (Node) & "_Calling_Stubs"; end Calling_Stubs_Type; end Ada_Be.Mappings.DSA; polyorb-2.8~20110207.orig/compilers/ciao/ciao_runtime-convert.adb0000644000175000017500000000605511750740337024132 0ustar xavierxavier---------------------------------------- -- -- -- ---- --- -- ---- -- -- - - - - - - -- -- - - ---- - - -- -- ---- --- - - ---- -- -- -- ---------------------------------------- -- CORBA -- -- Interface for -- -- Ada'95 distributed systems annex -- -- Objects -- ---------------------------------------- -- Copyright (c) 1999 -- -- École nationale supérieure des -- -- télécommunications -- ---------------------------------------- -- The CIAO run-time library. package body CIAO_Runtime.Convert is function To_Ada (Val : CORBA.Boolean) return Boolean is begin return Val; end To_Ada; function To_Ada (Val : CORBA.Short) return Integer is begin return Integer (Val); end To_Ada; function To_Ada (Val : CORBA.Long) return Integer is begin return Integer (Val); end To_Ada; function To_Ada (Val : CORBA.Unsigned_Short) return Integer is begin return Integer (Val); end To_Ada; function To_Ada (Val : CORBA.Unsigned_Long) return Integer is begin return Integer (Val); end To_Ada; function To_Ada (Val : CORBA.Float) return Float is begin return Float (Val); end To_Ada; function To_Ada (Val : CORBA.Double) return Float is begin return Float (Val); end To_Ada; function To_Ada (Val : CORBA.Char) return Character is begin return Character (Val); end To_Ada; function To_Ada (Val : CORBA.String) return String is begin return CORBA.To_Standard_String (Val); end To_Ada; function To_CORBA (Val : Boolean) return CORBA.Boolean is begin return Val; end To_CORBA; function To_CORBA (Val : Integer) return CORBA.Short is begin return CORBA.Short (Val); end To_CORBA; function To_CORBA (Val : Integer) return CORBA.Long is begin return CORBA.Long (Val); end To_CORBA; function To_CORBA (Val : Integer) return CORBA.Unsigned_Short is begin return CORBA.Unsigned_Short (Val); end To_CORBA; function To_CORBA (Val : Integer) return CORBA.Unsigned_Long is begin return CORBA.Unsigned_Long (Val); end To_CORBA; function To_CORBA (Val : Float) return CORBA.Float is begin return CORBA.Float (Val); end To_CORBA; function To_CORBA (Val : Float) return CORBA.Double is begin return CORBA.Double (Val); end To_CORBA; function To_CORBA (Val : Character) return CORBA.Char is begin return Val; end To_CORBA; function To_CORBA (Val : String) return CORBA.String is begin return CORBA.To_CORBA_String (Val); end To_CORBA; end CIAO_Runtime.Convert; polyorb-2.8~20110207.orig/compilers/ciao/ciao-filenames.adb0000644000175000017500000000331711750740337022650 0ustar xavierxavier---------------------------------------- -- -- -- ---- --- -- ---- -- -- - - - - - - -- -- - - ---- - - -- -- ---- --- - - ---- -- -- -- ---------------------------------------- -- CORBA -- -- Interface for -- -- Ada'95 distributed systems annex -- -- Objects -- ---------------------------------------- -- Copyright (c) 1999 -- -- École nationale supérieure des -- -- télécommunications -- ---------------------------------------- -- Mapping of file names with Ada.Characters.Handling; use Ada.Characters.Handling; package body CIAO.Filenames is function IDL_File_Name (Ada_File_Name : String) return String is Result : String (Ada_File_Name'Range) := Ada_File_Name; begin Result (Result'Last - 2 .. Result'Last) := "idl"; return Result; end IDL_File_Name; function Ada_File_Name (Full_Name : Asis.Program_Text; Part : Unit_Part := Unit_Declaration) return String is Extension : constant array (Unit_Part) of Character := (Unit_Declaration => 's', Unit_Body => 'b'); Result : String := To_String (Full_Name) & ".ad?"; begin for I in Result'First .. Result'Last - 4 loop if Result (I) = '.' then Result (I) := '-'; else Result (I) := To_Lower (Result (I)); end if; end loop; Result (Result'Last) := Extension (Part); return Result; end Ada_File_Name; end CIAO.Filenames; polyorb-2.8~20110207.orig/compilers/ciao/TODO0000644000175000017500000000066311750740337020015 0ustar xavierxavierTODO file for CIAO ================== $Id: //depot/ciao/main/TODO#1 $ All over CIAO, names are stored in nodes for usage occurrence of entities. This should not happen anymore; when the name of the entity denoted by a node is required, the (IDL) declaration of the node should be looked up, and only /that/ node should have a name. It is guaranteed that Translate has been previously called for any unit a given unit depends upon. polyorb-2.8~20110207.orig/compilers/ciao/ciao-translator-state.adb0000644000175000017500000001521311750740337024212 0ustar xavierxavier---------------------------------------- -- -- -- ---- --- -- ---- -- -- - - - - - - -- -- - - ---- - - -- -- ---- --- - - ---- -- -- -- ---------------------------------------- -- CORBA -- -- Interface for -- -- Ada'95 distributed systems annex -- -- Objects -- ---------------------------------------- -- Copyright (c) 1999 -- -- École nationale supérieure des -- -- télécommunications -- ---------------------------------------- -- The internal state of the translator. with Asis.Elements; use Asis.Elements; with GNAT.HTable; with Idl_Fe.Types; use Idl_Fe.Types; package body CIAO.Translator.State is procedure Initialize_Translator_State (Category : in Unit_Categories; Unit : in Asis.Compilation_Unit; Repository : in Node_Id; State : out Translator_State) is begin State.Repository := Repository; State.Unit_Category := Category; State.Current_Node := Repository; end Initialize_Translator_State; ----------------------------------------------------------- -- Map_Info -- -- All the information recorded about the mapping -- -- of an Ada element. -- -- -- -- For an element that is part of the current library -- -- unit, the translation is defined by the Mapping -- -- Specification Document. -- -- Additionally, for each withed unit, a translation -- -- for the unit declaration is registered. It designates -- -- the corresponding N_Preprocessor_Include node. -- ----------------------------------------------------------- type Map_Info is record Translation : Node_Id := No_Node; Previous_Current_Node : Node_Id := No_Node; end record; -- All information we want to keep about the mapping -- of an Ada Element is stored as a Map_Info record. Nil_Map_Info : constant Map_Info := (Translation => No_Node, Previous_Current_Node => No_Node); ------------------------------------- -- Elementary hash table accessors -- ------------------------------------- procedure Set_Map_Info (Element : Asis.Element; Info : Map_Info); pragma Inline (Set_Map_Info); -- Set the Map_Info for the Element. function Get_Map_Info (Element : Asis.Element) return Map_Info; pragma Inline (Get_Map_Info); -- Retrieve the mapping information for an Element. -- If no information was set, Nil_Map_Info is returned. procedure Set_Origin (Node : Node_Id; Element : Asis.Element); pragma Inline (Set_Origin); -- Record the original ASIS element at the origin of Node. -------------------------------- -- High-level state accessors -- -------------------------------- procedure Set_Translation (Element : Asis.Element; Translation : Node_Id) is Info : Map_Info := Get_Map_Info (Element); begin Info.Translation := Translation; Set_Map_Info (Element, Info); Set_Origin (Translation, Element); end Set_Translation; procedure Set_Previous_Current_Node (Element : Asis.Element; Previous_Current_Node : Node_Id) is Info : Map_Info := Get_Map_Info (Element); begin Info.Previous_Current_Node := Previous_Current_Node; Set_Map_Info (Element, Info); end Set_Previous_Current_Node; function Get_Translation (Element : Asis.Element) return Node_Id is begin return Get_Map_Info (Element).Translation; end Get_Translation; function Get_Previous_Current_Node (Element : Asis.Element) return Node_Id is begin return Get_Map_Info (Element).Previous_Current_Node; end Get_Previous_Current_Node; ------------------------------------------------------------------- -- Implementation of the hash functions and hash table accessors -- ------------------------------------------------------------------- type Map_HTable_Header_Num is range 1 .. 256; function Hash_Element (E : Asis.Element) return Map_HTable_Header_Num; -- Hash function for an ASIS Element. function Hash_Element (E : Asis.Element) return Map_HTable_Header_Num is begin return Map_HTable_Header_Num (Integer (Map_HTable_Header_Num'First) + Asis.Elements.Hash (E) mod Asis.ASIS_Integer (Map_HTable_Header_Num'Last - Map_HTable_Header_Num'First + 1)); end Hash_Element; package Map_HTable is new GNAT.HTable.Simple_HTable (Header_Num => Map_HTable_Header_Num, Element => Map_Info, No_Element => Nil_Map_Info, Key => Asis.Element, Hash => Hash_Element, Equal => Asis.Elements.Is_Identical); -- A table that records a reference of the corresponding -- IDL node for any given Ada element (represented by an -- Ids.Id value). The Map_HTable is notionally part of the -- translator's state. procedure Set_Map_Info (Element : Asis.Element; Info : Map_Info) is begin Map_HTable.Set (Element, Info); end Set_Map_Info; function Get_Map_Info (Element : Asis.Element) return Map_Info is begin return Map_HTable.Get (Element); end Get_Map_Info; function Hash_Node_Id (N : Node_Id) return Map_HTable_Header_Num; -- Hash function for a node id. function Hash_Node_Id (N : Node_Id) return Map_HTable_Header_Num is begin return Map_HTable_Header_Num (Integer (Map_HTable_Header_Num'First) + Integer (N) mod Asis.ASIS_Integer (Map_HTable_Header_Num'Last - Map_HTable_Header_Num'First + 1)); end Hash_Node_Id; package Origin_HTable is new GNAT.HTable.Simple_HTable (Header_Num => Map_HTable_Header_Num, Element => Asis.Element, No_Element => Asis.Nil_Element, Key => Node_Id, Hash => Hash_Node_Id, Equal => "="); -- A table that records the original ASIS element corresponding -- to an IDL node. The Origin_HTable is notionally part of the -- translator's state. procedure Set_Origin (Node : Node_Id; Element : Asis.Element) is begin Origin_HTable.Set (Node, Element); end Set_Origin; function Get_Origin (Node : Node_Id) return Asis.Element is begin return Origin_HTable.Get (Node); end Get_Origin; end CIAO.Translator.State; polyorb-2.8~20110207.orig/compilers/ciao/ciao-generator.ads0000644000175000017500000000155711750740337022720 0ustar xavierxavier---------------------------------------- -- -- -- ---- --- -- ---- -- -- - - - - - - -- -- - - ---- - - -- -- ---- --- - - ---- -- -- -- ---------------------------------------- -- CORBA -- -- Interface for -- -- Ada'95 distributed systems annex -- -- Objects -- ---------------------------------------- -- Copyright (c) 1999 -- -- École nationale supérieure des -- -- télécommunications -- ---------------------------------------- -- Common declarations for the interface description (IDL) -- generator and the CORBA implementation body generator. package CIAO.Generator is pragma Pure; end CIAO.Generator; polyorb-2.8~20110207.orig/compilers/ciao/ciao-translator.ads0000644000175000017500000000276411750740337023124 0ustar xavierxavier---------------------------------------- -- -- -- ---- --- -- ---- -- -- - - - - - - -- -- - - ---- - - -- -- ---- --- - - ---- -- -- -- ---------------------------------------- -- CORBA -- -- Interface for -- -- Ada'95 distributed systems annex -- -- Objects -- ---------------------------------------- -- Copyright (c) 1999-2002 -- -- École nationale supérieure des -- -- télécommunications -- ---------------------------------------- -- This unit generates a decorated IDL tree by traversing -- the ASIS tree of a DSA package specification. with Asis; with Idl_Fe.Types; use Idl_Fe.Types; package CIAO.Translator is Translation_Error : exception; -- An error occured, and the library unit could -- not be translated. Not_Implemented : exception; -- A construct was encountered whose translation is not implemented -- in this version of the CIAO translator. ----------------------------------------------- -- Translate -- -- Produce the IDL tree corresponding to the -- -- translation of the libray unit. -- ----------------------------------------------- procedure Translate (LU : in Asis.Compilation_Unit; Repository : in out Node_Id); end CIAO.Translator; polyorb-2.8~20110207.orig/compilers/ciao/ada_be-mappings-dsa.ads0000644000175000017500000000636711750740337023601 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- ADABROKER COMPONENTS -- -- -- -- A D A _ B E . M A P P I N G S . D S A -- -- -- -- S p e c -- -- -- -- Copyright (C) 1999-2002 ENST Paris University, France. -- -- -- -- AdaBroker is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. AdaBroker is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with AdaBroker; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- AdaBroker is maintained by ENST Paris University. -- -- (email: broker@inf.enst.fr) -- -- -- ------------------------------------------------------------------------------ -- The DSA personality IDL mapping. package Ada_Be.Mappings.DSA is pragma Elaborate_Body; type DSA_Mapping_Type is new Mapping_Type with private; function Library_Unit_Name (Self : access DSA_Mapping_Type; Node : Idl_Fe.Types.Node_Id) return String; function Client_Stubs_Unit_Name (Self : access DSA_Mapping_Type; Node : Idl_Fe.Types.Node_Id) return String; function Server_Skel_Unit_Name (Self : access DSA_Mapping_Type; Node : Idl_Fe.Types.Node_Id) return String; function Self_For_Operation (Self : access DSA_Mapping_Type; Node : Idl_Fe.Types.Node_Id) return String; procedure Map_Type_Name (Self : access DSA_Mapping_Type; Node : Idl_Fe.Types.Node_Id; Unit : out ASU.Unbounded_String; Typ : out ASU.Unbounded_String); function Calling_Stubs_Type (Self : access DSA_Mapping_Type; Node : Idl_Fe.Types.Node_Id) return String; function Generate_Scope_In_Child_Package (Self : access DSA_Mapping_Type; Node : Idl_Fe.Types.Node_Id) return Boolean; The_DSA_Mapping : constant DSA_Mapping_Type; private type DSA_Mapping_Type is new Mapping_Type with null record; The_DSA_Mapping : constant DSA_Mapping_Type := (Mapping_Type with null record); end Ada_Be.Mappings.DSA; polyorb-2.8~20110207.orig/compilers/ciao/allruntime.adb0000644000175000017500000000156611750740337022154 0ustar xavierxavier---------------------------------------- -- -- -- ---- --- -- ---- -- -- - - - - - - -- -- - - ---- - - -- -- ---- --- - - ---- -- -- -- ---------------------------------------- -- CORBA -- -- Interface for -- -- Ada'95 distributed systems annex -- -- Objects -- ---------------------------------------- -- Copyright (c) 1999 -- -- École nationale supérieure des -- -- télécommunications -- ---------------------------------------- -- Dummy top-level procedure for building -- the CIAO runtime library. with CIAO_Runtime.Encap_Streams; with CIAO_Runtime.Convert; procedure AllRuntime is begin null; end AllRuntime; polyorb-2.8~20110207.orig/compilers/ciao/ciao-generator-idl.adb0000644000175000017500000003343611750740337023446 0ustar xavierxavier---------------------------------------- -- -- -- ---- --- -- ---- -- -- - - - - - - -- -- - - ---- - - -- -- ---- --- - - ---- -- -- -- ---------------------------------------- -- CORBA -- -- Interface for -- -- Ada'95 distributed systems annex -- -- Objects -- ---------------------------------------- -- Copyright (c) 1999 -- -- École nationale supérieure des -- -- télécommunications -- ---------------------------------------- -- The interface description (IDL) generator. with CIAO.IDL_Tree; use CIAO.IDL_Tree; with CIAO.IDL_Syntax; use CIAO.IDL_Syntax; with CIAO.Namet; use CIAO.Namet; with CIAO.Nlists; use CIAO.Nlists; with CIAO.Options; use CIAO.Options; with CIAO.Types; use CIAO.Types; package body CIAO.Generator.IDL is use Ada.Text_Io; procedure Generate (Tree : in Node_Id; File : in Ada.Text_Io.File_Type) is Indent_Level : Natural := 0; procedure Put_Indent; -- Generate the whitespace corresponding to the current -- indentation level. procedure Put_Name (N : Name_Id); -- Generate the textual representation for a Name. procedure Generate_Node (N : Node_Id); -- Generate the text representation for IDL node N. -- File and Indent_String are considered global -- variables in this procedure. procedure Put_Indent is Indent_String : constant String (1 .. Indent * Indent_Level) := (others => ' '); begin Put (File, Indent_String); end Put_Indent; procedure Put_Name (N : Name_Id) is begin Get_Name_String (N); Put (File, Name_Buffer (1 .. Name_Len)); end Put_Name; procedure Generate_Node (N : Node_Id) is begin case Node_Kind (N) is ------------- -- Keyword -- ------------- when N_Keyword_Default => Put (File, "default"); when N_Keyword_Void => Put (File, "void"); when N_Keyword_In => Put (File, "in"); when N_Keyword_Out => Put (File, "out"); when N_Keyword_Inout => Put (File, "inout"); --------------- -- Base type -- --------------- when N_Base_Type_Char => Put (File, "char"); when N_Base_Type_Boolean => Put (File, "boolean"); when N_Base_Type_Long => Put (File, "long"); when N_Base_Type_Double => Put (File, "double"); when N_Base_Type_Unsigned_Long => Put (File, "unsigned long"); when N_Base_Type_Long_Long => Put (File, "long long"); when N_Base_Type_Long_Double => Put (File, "long double"); when N_Base_Type_Unsigned_Long_Long => Put (File, "unsigned long long"); when N_Base_Type_String => Put (File, "string"); when N_Base_Type_Octet => Put (File, "octet"); --------------------- -- Other terminals -- --------------------- -- Actually generated in N_Scoped_Name. -- when N_Absolute => -- Put (File, "::"); when N_Preprocessor_Include => if Unit_Used (N) then Put (File, "#include """); Put_Name (Name (N)); Put_Line (File, """"); end if; ------------------- -- Non-terminals -- ------------------- when N_Specification => declare Dir : Node_Id := First (Directives (N)); Def : Node_Id := First (Definitions (N)); Int : Node_Id := First (Interfaces (N)); begin while Present (Dir) loop Generate_Node (Dir); Dir := Next (Dir); end loop; New_Line (File); while Present (Def) loop Generate_Node (Def); Put_Line (File, ";"); Def := Next (Def); end loop; while Present (Int) loop Generate_Node (Int); Put_Line (File, ";"); Int := Next (Int); end loop; end; when N_Module => declare Def : Node_Id := First (Definitions (N)); Interface : Node_Id := First (Interfaces (N)); begin Put_Indent; Put (File, "module "); Put_Name (Name (N)); Put (File, " {"); Indent_Level := Indent_Level + 1; while Present (Def) loop New_Line (File); Generate_Node (Def); Put_Line (File, ";"); Def := Next (Def); end loop; while Present (Interface) loop New_Line (File); Generate_Node (Interface); Put_Line (File, ";"); Interface := Next (Interface); end loop; Indent_Level := Indent_Level - 1; Put_Indent; Put (File, "}"); end; when N_Interface => Generate_Node (Specific_Interface (N)); when N_Interface_Dcl => declare Export : Node_Id := First (Interface_Body (N)); Int : Node_Id := First (Interfaces (N)); begin Generate_Node (Interface_Header (N)); Put_Line (File, " {"); Indent_Level := Indent_Level + 1; while Present (Export) loop Put_Indent; Generate_Node (Export); Put_Line (File, ";"); Export := Next (Export); end loop; while Present (Int) loop Generate_Node (Int); Int := Next (Int); end loop; Indent_Level := Indent_Level - 1; Put_Indent; Put (File, "}"); end; when N_Forward_Dcl => Put_Indent; Put (File, "interface "); Put_Name (Name (N)); when N_Interface_Header => declare Inh : Node_Id := First (Inheritance_Spec (N)); First_Inheritance_Spec : Boolean := True; begin Put_Indent; Put (File, "interface "); Put_Name (Name (N)); while Present (Inh) loop if First_Inheritance_Spec then Put (File, " : "); First_Inheritance_Spec := False; else Put (File, ", "); end if; Generate_Node (Inh); Inh := Next (Inh); end loop; end; when N_Scoped_Name => if Present (Prefix (N)) then if Node_Kind (Prefix (N)) = N_Scoped_Name then Generate_Node (Prefix (N)); end if; Put (File, "::"); end if; Put_Name (Name (N)); when N_Type_Dcl => Put_Indent; Put (File, "typedef "); Generate_Node (Type_Declarator (N)); when N_Type_Declarator | N_Member => -- Indentation and ";" around N_Member are -- actually generated in enclosing node. Generate_Node (Type_Spec (N)); Put (File, " "); declare Decl : Node_Id := First (Declarators (N)); First_Declarator : Boolean := True; begin while Present (Decl) loop if First_Declarator then First_Declarator := False; else Put (File, ", "); end if; Generate_Node (Decl); Decl := Next (Decl); end loop; end; when N_Declarator => Generate_Node (Specific_Declarator (N)); when N_Simple_Declarator | N_Enumerator => Put_Name (Name (N)); when N_Simple_Type_Spec => -- XXX Check that! -- XXX Untyped traversal! Node1 is either or . Generate_Node (Node1 (N)); when N_Type_Spec => Generate_Node (Specific_Type_Spec (N)); when N_Constr_Type_Spec => Generate_Node (Structure (N)); when N_Struct_Type => declare Member : Node_Id := First (Members (N)); begin Put (File, "struct "); Put_Name (Name (N)); Put_Line (File, " {"); Indent_Level := Indent_Level + 1; while Present (Member) loop Put_Indent; Generate_Node (Member); Put_Line (File, ";"); Member := Next (Member); end loop; Indent_Level := Indent_Level - 1; Put_Indent; Put (File, "}"); end; when N_Union_Type => -- XXX TODO raise Program_Error; when N_Case_Element => -- XXX TODO raise Program_Error; when N_Element_Spec => -- XXX TODO raise Program_Error; when N_Enum_Type => declare Enumerator : Node_Id := First (Enumerators (N)); begin Put (File, "enum "); Put_Name (Name (N)); Put_Line (File, " {"); Indent_Level := Indent_Level + 1; while Present (Enumerator) loop Put_Indent; Generate_Node (Enumerator); Enumerator := Next (Enumerator); if Present (Enumerator) then Put (File, ","); end if; New_Line (File); end loop; Indent_Level := Indent_Level - 1; Put_Indent; Put (File, "}"); end; when N_Sequence_Type => Put (File, "sequence<"); Generate_Node (Specific_Type_Spec (N)); Put (File, " >"); when N_Array_Declarator => declare Array_Size : Node_Id := First (Fixed_Array_Sizes (N)); begin Put_Name (Name (N)); while Present (Array_Size) loop Put (File, "["); Put (File, Unbiased_Uint'Image (Size_Value (Array_Size))); Put (File, "]"); Array_Size := Next (Array_Size); end loop; end; when N_Op_Dcl => declare Param_Dcl : Node_Id := First (Param_Dcls (N)); First_Parameter : Boolean := True; begin -- NOT IMPLEMENTED. Generate_Node (Op_Type_Spec (N)); Put (File, " "); Put_Name (Name (N)); Put (File, " ("); while Present (Param_Dcl) loop if First_Parameter then First_Parameter := False; else Put (File, ", "); end if; Generate_Node (Param_Dcl); Param_Dcl := Next (Param_Dcl); end loop; Put (File, ")"); -- XXX TODO -- Generate_Node (Raises_Expr (N)); -- NOT IMPLEMENTED. end; when N_Op_Type_Spec => Generate_Node (Operation_Value_Type (N)); when N_Param_Type_Spec => -- XXX ugly abstraction violation! Generate_Node (Node1 (N)); when N_Param_Dcl => Generate_Node (Parameter_Attribute (N)); Put (File, " "); Generate_Node (Param_Type_Spec (N)); Put (File, " "); Put_Name (Name (N)); when N_Param_Attribute => -- XXX ugly abstraction violation! Untyped traversal. Generate_Node (Node1 (N)); when N_Raises_Expr => -- XXX TODO raise Program_Error; when N_Empty => -- XXX DEBUG ONLY Put (File, "XXX N_Empty XXX"); when others => -- Impossible, should not happen! -- (N_Empty, N_Error, N_Unused_At_Start). raise Program_Error; end case; end Generate_Node; begin Generate_Node (Tree); end Generate; end CIAO.Generator.IDL; polyorb-2.8~20110207.orig/compilers/ciao/ciao.ads0000644000175000017500000000166411750740337020733 0ustar xavierxavier---------------------------------------- -- -- -- ---- --- -- ---- -- -- - - - - - - -- -- - - ---- - - -- -- ---- --- - - ---- -- -- -- ---------------------------------------- -- CORBA -- -- Interface for -- -- Ada'95 distributed systems annex -- -- Objects -- ---------------------------------------- -- Copyright (c) 1999 -- -- École nationale supérieure des -- -- télécommunications -- ---------------------------------------- -- The top of the CIAO project package CIAO is pragma Pure (CIAO); Version : constant Wide_String := "0.0"; Copyright : constant Wide_String := "Copyright (c) 1999" & " École nationale supérieure des télécommunications"; end CIAO; polyorb-2.8~20110207.orig/compilers/ciao/ciao-translator.adb0000644000175000017500000024457511750740337023113 0ustar xavierxavier---------------------------------------- -- -- -- ---- --- -- ---- -- -- - - - - - - -- -- - - ---- - - -- -- ---- --- - - ---- -- -- -- ---------------------------------------- -- CORBA -- -- Interface for -- -- Ada'95 distributed systems annex -- -- Objects -- ---------------------------------------- -- Copyright (c) 1999-2002 -- -- École nationale supérieure des -- -- télécommunications -- ---------------------------------------- -- This unit generates a decorated IDL tree -- by traversing the ASIS tree of a DSA package -- specification. with Ada.Exceptions; with Ada.Wide_Text_IO; use Ada.Wide_Text_IO; with Ada.Characters.Handling; use Ada.Characters.Handling; with Asis.Clauses; with Asis.Compilation_Units; with Asis.Declarations; with Asis.Definitions; with Asis.Elements; with Asis.Expressions; with Asis.Extensions; with Asis.Iterator; with Asis.Text; with CIAO.ASIS_Queries; use CIAO.ASIS_Queries; with Idl_Fe.Types; use Idl_Fe.Types; with Idl_Fe.Tree; use Idl_Fe.Tree; with Idl_Fe.Tree.Synthetic; with Idl_Fe.Utils; use Idl_Fe.Utils; with Errors; use Errors; with CIAO.Translator.Maps; use CIAO.Translator.Maps; with CIAO.Translator.State; use CIAO.Translator.State; package body CIAO.Translator is use Asis; use Asis.Definitions; use Asis.Elements; use Asis.Expressions; use Asis.Declarations; use CIAO; --------------------------------------------------- -- Raise_Translation_Error -- -- Print an error message and abort translation. -- --------------------------------------------------- procedure Raise_Translation_Error (Element : Asis.Element; Message : String); pragma No_Return (Raise_Translation_Error); procedure Raise_Translation_Error (Element : Asis.Element; Message : String) is use Asis.Text; E_Span : constant Span := Element_Span (Element); Line_Number_Wide_Image : Wide_String := Line_Number'Wide_Image (E_Span.First_Line); E_Lines : Line_List := Lines (Element => Element, First_Line => E_Span.First_Line, Last_Line => E_Span.First_Line); begin New_Line; New_Line; Put (Line_Number_Wide_Image); -- (2 .. Line_Number_Wide_Image'Last)); Put (". "); Put (Line_Image (E_Lines (E_Lines'First))); New_Line; for I in 1 .. E_Span.First_Column + Line_Number_Wide_Image'Length + 1 loop Put (' '); end loop; Put ('|'); New_Line; Put (">>> "); Ada.Exceptions.Raise_Exception (Translation_Error'Identity, Message); end Raise_Translation_Error; -------------------------------------- -- {Pre,Post}_Translate_Element -- -- The pre- and post-operations for -- -- Asis.Iterator.Traverse_Element. -- -------------------------------------- procedure Pre_Translate_Element (Element : in Asis.Element; Control : in out Traverse_Control; State : in out Translator_State); procedure Post_Translate_Element (Element : in Asis.Element; Control : in out Traverse_Control; State : in out Translator_State); ------------------------------------------- -- Translate_Tree -- -- Translate an Ada syntax tree into the -- -- corresponding IDL tree. -- ------------------------------------------- procedure Translate_Tree is new Iterator.Traverse_Element (State_Information => Translator_State, Pre_Operation => Pre_Translate_Element, Post_Operation => Post_Translate_Element); ------------------------------------------------------------------ -- Process_* -- -- Helper subprograms for Pre_Translate_Element that -- -- handle specific Element_Kinds. -- -- These subprograms act strictly like Pre_Translate_Elements: -- -- the caller should return immediately to the Traverse_Element -- -- instance after calling any of them. -- ------------------------------------------------------------------ procedure Process_Declaration (Element : in Asis.Element; Control : in out Traverse_Control; State : in out Translator_State); procedure Process_Definition (Element : in Asis.Element; Control : in out Traverse_Control; State : in out Translator_State); procedure Process_Expression (Element : in Asis.Element; Control : in out Traverse_Control; State : in out Translator_State); procedure Process_Type_Definition (Element : in Asis.Element; Control : in out Traverse_Control; State : in out Translator_State); ---------------------------------------------------------- -- Translate_* -- -- These procedures are called by Pre_Translate_Element -- -- to take care of particular Element_Kinds. -- ---------------------------------------------------------- function Map_Defining_Name (Name : in Asis.Defining_Name) return String; -- Return the IDL representation of Name. function Translate_Subtype_Mark (Exp : in Asis.Expression) return Node_Id; -- Return the node id corresponding to the definition of -- the type denoted by subtype_mark Exp. procedure Translate_List (List : in Asis.Element_List; State : in out Translator_State); procedure Translate_Formal_Parameter (Specification : in Asis.Definition; State : in out Translator_State); function New_Opaque_Type return Node_Id; -- Return a new node corresponding to the type to be -- assigned to opaque entities. function New_Integer_Literal (Value : Integer) return Node_Id; -- Return a new node corresponding to an integer literal -- with the given Value. function New_Opaque_Type return Node_Id is begin return Make_Native (No_Location); end New_Opaque_Type; function New_Integer_Literal (Value : Integer) return Node_Id is Result : constant Node_Id := Make_Lit_Integer (No_Location); begin Set_Expr_Value (Result, new Constant_Value (Kind => C_General_Integer)); Expr_Value (Result).Integer_Value := Long_Long_Integer (Value); return Result; end New_Integer_Literal; --------------------------------------------------------------- -- Pre_Translate_Element -- -- Translate an element into IDL. -- -- Used as pre-operation for Iterator.Traverse_Element. -- --------------------------------------------------------------- procedure Pre_Translate_Element (Element : in Asis.Element; Control : in out Traverse_Control; State : in out Translator_State) is begin case Element_Kind (Element) is when Not_An_Element | A_Statement | A_Path | An_Exception_Handler => Raise_Translation_Error (Element, "Unexpected element."); when A_Defining_Name => null; -- Defining names are translated explicitly when -- processing the enclosing declaration. The children -- of that declaration may then be traversed recursively, -- so we need to just ignore the defining_name here. when A_Declaration => Process_Declaration (Element, Control, State); when A_Definition => Process_Definition (Element, Control, State); when An_Expression => Process_Expression (Element, Control, State); when An_Association => -- In a DSA unit declaration, An_Association can occur -- in a discriminant_constraint in a member or subtype -- definition. Such a constraint is not translated, -- therefore this point should never be reached (but -- the generated helper code might later consult -- explicitly the constraints of a declaration to ensure -- validity of an object when converting it from an external -- representation (Any or marshalled data stream) to its -- native representation Raise_Translation_Error (Element, "Unexpected element (An_Association)."); when A_Pragma | A_Clause => Control := Abandon_Children; end case; exception when Ex : others => Put_Line ("Unexpected exception in Pre_Translate_Element:"); Put_Line (To_Wide_String (Ada.Exceptions.Exception_Information (Ex))); raise; end Pre_Translate_Element; procedure Process_Declaration (Element : in Asis.Element; Control : in out Traverse_Control; State : in out Translator_State) is use Asis.Definitions; Node : Node_Id := No_Node; DK : constant Declaration_Kinds := Declaration_Kind (Element); Defining_Names : constant Defining_Name_List := Declarations.Names (Element); Defining_Name : Asis.Defining_Name renames Defining_Names (Defining_Names'First); Old_Current_Node : constant Node_Id := State.Current_Node; ----------------------- -- Local subprograms -- ----------------------- procedure Process_Distributed_Object_Declaration (Element : in Asis.Element; Control : in out Traverse_Control; State : in out Translator_State); -- Process the declaration of a potentially -- distributed object (the declaration of any -- tagged limited private type). procedure Translate_Operation_Declaration (State : in out Translator_State; Name : String; Asynchronous : Boolean; Parameter_Profile : Asis.Parameter_Specification_List; Result_Profile : Asis.Element := Nil_Element; Op_Node : out Node_Id); -- Core processing for the declaration of a method of a -- remote entity, i. e. either a subprogram_declaration, -- or a full_type_declaration that declares a RAS. -- -- State - The translator state. -- Name - The name of the operation. -- Asynchronous - Determines whether a pragma Asynchronous -- applies to invocations of this operations. -- Parameter_Profile - The calling profile of the operation. -- Result_Profile - The return profile (for a funtion), -- Nil_Element (for a procedure). -- -- Pre-condition: State.Current_Node is the . -- Post-condition: The node is returned. It has already -- been added to the contents of State.Current_Node. procedure Process_Distributed_Object_Declaration (Element : in Asis.Element; Control : in out Traverse_Control; State : in out Translator_State) is -- Forward_Node : Node_Id; Success : Boolean; begin -- Forward_Node := New_Forward_Interface; -- Set_Parent (Forward_Node, State.Current_Node); -- Add_Definition (State.Current_Node, Forward_Node); -- Node := New_Interface; -- Set_Parent (Node, State.Current_Node); -- Add_Interface (State.Current_Node, Node); -- Forward_Node := Make_Forward_Interface (No_Location); -- XXX for now do not define the forward interface. Node := Make_Interface (No_Location); Set_Abst (Node, False); -- Set_Forward (Node, Forward_Node); -- Set_Forward (Forward_Node, Node); -- Set_Definition (Node, Idl_Fe.Tree.Definition (Forward_Node)); Success := Add_Identifier (Node, Map_Defining_Name (Defining_Name)); pragma Assert (Success); Append_Node_To_Contents (State.Current_Node, Node); if DK = A_Private_Extension_Declaration then -- This is an extension of a distributed object declaration: -- either a private_extension_declaration or an -- ordinary_type_declaration which is a derived_type_declaration -- for a distributed object type, without an extension part. declare Ancestor_Definition : constant Asis.Defining_Name := Corresponding_Entity_Name_Definition (Asis.Definitions.Subtype_Mark (Ancestor_Subtype_Indication (Type_Declaration_View (Element)))); begin Append_Node_To_Parents (Node, Get_Translation (Ancestor_Definition)); end; else -- This is a root distributed object declaration. null; end if; Set_Translation (Element, Node); -- The translation information for a tagged type -- definition is the corresponding Interface node. Control := Abandon_Children; -- Children were processed explicitly. end Process_Distributed_Object_Declaration; procedure Translate_Operation_Declaration (State : in out Translator_State; Name : String; Asynchronous : Boolean; Parameter_Profile : Asis.Parameter_Specification_List; Result_Profile : Asis.Element := Nil_Element; Op_Node : out Node_Id) is Result : Node_Id; -- The Value_Type_Node : Node_Id; -- or "void", for use in . Success : Boolean; Old_Current_Node : constant Node_Id := State.Current_Node; begin Result := Make_Operation (No_Location); if Asynchronous then Set_Is_Oneway (Result, True); else Set_Is_Oneway (Result, False); end if; Append_Node_To_Contents (State.Current_Node, Result); Success := Add_Identifier (Result, Name); pragma Assert (Success); if Is_Nil (Result_Profile) then Value_Type_Node := Make_Void (No_Location); else Value_Type_Node := Translate_Subtype_Mark (Result_Profile); end if; Set_Operation_Type (Result, Value_Type_Node); State.Current_Node := Result; Push_Scope (State.Current_Node); Translate_List (Parameter_Profile, State); -- XXX CAVEAT! In DSA, GNAT reorders the parameter -- list to have all unconstrained parameters first -- (see Exp_Dist.Build_Ordered_Parameter_List). Pop_Scope; State.Current_Node := Old_Current_Node; Op_Node := Result; end Translate_Operation_Declaration; begin -- Process_Declaration case DK is when An_Ordinary_Type_Declaration | -- 3.2.1(3) A_Subtype_Declaration | -- 3.2.2(2) A_Task_Type_Declaration | -- 9.1(2) A_Protected_Type_Declaration => -- 9.4(2) declare Type_Definition : constant Asis.Definition := Declarations.Type_Declaration_View (Element); Success : Boolean; begin pragma Assert (Defining_Names'Length = 1); -- Only one defining_name in a full_type_declaration, -- subtype_declaration, task_type_declaration or -- protected_type_declaration. if True and then Type_Kind (Type_Definition) = An_Access_Type_Definition and then Access_Type_Kind (Type_Definition) in Access_To_Subprogram_Definition then -- This is the definition of a Remote Access to -- Subprogram type. Node := Make_Interface (No_Location); Set_Abst (Node, False); Append_Node_To_Contents (State.Current_Node, Node); Success := Add_Identifier (Node, Map_Defining_Name (Defining_Names (Defining_Names'First))); pragma Assert (Success); State.Current_Node := Node; Push_Scope (State.Current_Node); declare Op_Node : Node_Id; begin case Access_Type_Kind (Type_Definition) is when An_Access_To_Procedure | An_Access_To_Protected_Procedure => Translate_Operation_Declaration (State, "Call", Is_Asynchronous (Element), Access_To_Subprogram_Parameter_Profile (Type_Definition), Result_Profile => Nil_Element, Op_Node => Op_Node); when An_Access_To_Function | An_Access_To_Protected_Function => Translate_Operation_Declaration (State, "Call", Is_Asynchronous (Element), Access_To_Subprogram_Parameter_Profile (Type_Definition), Result_Profile => Access_To_Function_Result_Profile (Type_Definition), Op_Node => Op_Node); when others => -- This cannot happen because we checked that -- Access_Kind in Access_To_Subprogram_Definition raise ASIS_Failed; end case; Set_Translation (Element, Op_Node); -- The translation of a RAS declaration is -- an . end; Pop_Scope; else -- This is the definition of a normal type or -- of a subtype. Node := No_Node; case Type_Kind (Type_Definition) is when An_Enumeration_Type_Definition => Node := Make_Enum (No_Location); Success := Add_Identifier (Node, Map_Defining_Name (Defining_Name)); when A_Record_Type_Definition => if not Is_Limited_Type (Element) or else Is_Tagged_Type (Element) then Node := Make_Struct (No_Location); Success := Add_Identifier (Node, Map_Defining_Name (Defining_Name)); end if; when A_Constrained_Array_Definition | An_Unconstrained_Array_Definition => if not Is_Limited_Type (Element) then Node := Make_Struct (No_Location); Success := Add_Identifier (Node, Map_Defining_Name (Defining_Name)); end if; when others => null; end case; if Node /= No_Node then -- An enumeration, record or array definition. pragma Assert (Success); Append_Node_To_Contents (State.Current_Node, Node); Set_Translation (Element, Node); Set_Previous_Current_Node (Element, State.Current_Node); State.Current_Node := Node; -- Process children recursively. return; else -- Any other type definition. Node := Make_Type_Declarator (No_Location); Append_Node_To_Contents (State.Current_Node, Node); declare Declarator_Node : constant Node_Id := Make_Declarator (No_Location); begin Set_Parent (Declarator_Node, Node); Append_Node_To_Declarators (Node, Declarator_Node); Set_Translation (Element, Declarator_Node); -- The translation of a type declaration is -- a in a . if False -- For now, we cannot determine the bounds of a -- static constrained array. and then Definition_Kind (Type_Definition) = A_Type_Definition and then Type_Kind (Type_Definition) = A_Constrained_Array_Definition then -- Node := New_Node (N_Array_Declarator); -- Set_Parent (Node, Declarator_Node); -- Set_Specific_Declarator (Declarator_Node, Node); -- State.Current_Node := Node; -- Translate_Defining_Name (Defining_Name, State); -- Here we should process the array dimensions raise Program_Error; else Success := Add_Identifier (Declarator_Node, Map_Defining_Name (Defining_Name)); pragma Assert (Success); end if; end; if DK = A_Subtype_Declaration then Set_T_Type (Node, Translate_Subtype_Mark (Asis.Definitions.Subtype_Mark (Type_Definition))); -- In A_Subtype_Declaration, the Type_Definition -- is A_Subtype_Indication. elsif Is_Limited_Type (Element) or else Is_Tagged_Type (Element) then -- Limited types and (non-private, hence -- non-distributed-objects) tagged types -- are mapped to an opaque type. Set_T_Type (Node, New_Opaque_Type); else Set_Previous_Current_Node (Element, State.Current_Node); State.Current_Node := Node; -- Process children recursively return; end if; end if; end if; State.Current_Node := Old_Current_Node; Control := Abandon_Children; -- Children were processed explicitly. end; when An_Incomplete_Type_Declaration => -- 3.2.1(2), 3.10(2) -- An incomplete_type_declaration is translated -- when completed. The only place where the name -- could be used before completion in the context -- of CIAO is as part of an access_definition in -- the profile of a subprogram_declaration. -- Since the mapping of the subprogram_declaration -- is produced after all other definitions in the , -- this is not an issue => we do nothing. Control := Abandon_Children; -- No child processing required. when A_Private_Type_Declaration => -- 3.2.1(2), 7.3(2) declare TK : Trait_Kinds := Trait_Kind (Element); Type_Definition : constant Asis.Definition := Declarations.Type_Declaration_View (Element); begin pragma Assert (Defining_Names'Length = 1); -- Only one defining_name in a private_type_declaration. if (TK = An_Abstract_Limited_Private_Trait or else TK = A_Limited_Private_Trait) and then Definition_Kind (Type_Definition) = A_Tagged_Private_Type_Definition then -- This is the declaration of a potentially -- distributed object. Process_Distributed_Object_Declaration (Element, Control, State); else -- For A_Private_Type_Declaration that is not -- a tagged limited private (possibly abstract) -- type declaration, the type is mapped to an -- opaque sequence of octets. declare Type_Dcl_Node : Node_Id; Declarator_Node : Node_Id; Success : Boolean; begin Type_Dcl_Node := Make_Type_Declarator (No_Location); Append_Node_To_Contents (Type_Dcl_Node, State.Current_Node); Declarator_Node := Make_Declarator (No_Location); Set_Parent (Declarator_Node, Type_Dcl_Node); Append_Node_To_Declarators (Type_Dcl_Node, Declarator_Node); Set_Translation (Element, Declarator_Node); Success := Add_Identifier (Declarator_Node, Map_Defining_Name (Defining_Name)); pragma Assert (Success); Set_T_Type (Type_Dcl_Node, New_Opaque_Type); State.Current_Node := Old_Current_Node; end; Control := Abandon_Children; -- Children were processed explicitly. end if; end; when A_Private_Extension_Declaration => -- 3.2.1(2), 7.3(3) pragma Assert (Defining_Names'Length = 1); -- Only one defining_name in a private_extension_declaration. if Is_Limited_Type (Element) then -- A private_extension_declaration declares -- a tagged private type. If it is limited as well, -- then it is an extension of a potentially -- distributed object. Process_Distributed_Object_Declaration (Element, Control, State); end if; -- For A_Private_Extension_Declaration that is not -- a tagged limited private (possibly abstract) -- type declaration, the implicit processing is done, -- resulting in an opaque type mapping. -- XXX NOT CHECKED! when A_Variable_Declaration | -- 3.3.1(2) A_Single_Task_Declaration | -- 3.3.1(2), 9.1(3) A_Single_Protected_Declaration => -- 3.3.1(2), 9.4(2) Raise_Translation_Error (Element, "Unexpected variable declaration" & " (according to unit categorization)."); when A_Constant_Declaration | -- 3.3.1(4) A_Deferred_Constant_Declaration | -- 3.3.1(6), 7.4(2) An_Integer_Number_Declaration | -- 3.3.2(2) A_Real_Number_Declaration => -- 3.5.6(2) raise Not_Implemented; when An_Enumeration_Literal_Specification => -- 3.5.1(3) pragma Assert (Kind (State.Current_Node) = K_Enum); declare Enumerator_Node : constant Node_Id := Make_Enumerator (No_Location); Success : Boolean; begin pragma Assert (Defining_Names'Length = 1); -- Only one defining_name in an -- enumeration_literal_specification. Append_Node_To_Enumerators (State.Current_Node, Enumerator_Node); Success := Add_Identifier (Enumerator_Node, Map_Defining_Name (Defining_Name)); pragma Assert (Success); Set_Translation (Element, Enumerator_Node); Control := Abandon_Children; -- Children were processed explicitly. end; when A_Discriminant_Specification | -- 3.7(5) A_Component_Declaration => -- 3.8(6) pragma Assert (Kind (State.Current_Node) = K_Struct); declare Component_Subtype_Mark : Asis.Expression; Declarator_Node : Node_Id; Success : Boolean; begin if DK = A_Discriminant_Specification then Component_Subtype_Mark := Declaration_Subtype_Mark (Element); else Component_Subtype_Mark := Asis.Definitions.Subtype_Mark (Component_Subtype_Indication (Object_Declaration_View (Element))); end if; Node := Make_Member (No_Location); Append_Node_To_Members (State.Current_Node, Node); for I in Defining_Names'Range loop Declarator_Node := Make_Declarator (No_Location); Set_Parent (Declarator_Node, Node); Append_Node_To_Decl (Node, Declarator_Node); Success := Add_Identifier (Declarator_Node, Map_Defining_Name (Defining_Name)); pragma Assert (Success); end loop; Set_M_Type (Node, Translate_Subtype_Mark (Component_Subtype_Mark)); State.Current_Node := Old_Current_Node; Control := Abandon_Children; -- Child elements were processed explicitly. end; when A_Procedure_Declaration | -- 6.1(4) A_Function_Declaration => -- 6.1(4) declare Is_Function : constant Boolean := (DK = A_Function_Declaration); Profile : constant Parameter_Specification_List := Parameter_Profile (Element); Interface_Dcl_Node : Node_Id := No_Node; Old_Current_Node : constant Node_Id := State.Current_Node; Op_Node : Node_Id; Need_To_Pop_Scope : Boolean; begin pragma Assert (Defining_Names'Length = 1); -- Only one defining_name in a subprogram declaration. if State.Unit_Category = Remote_Call_Interface then -- This is a remote subprogram of an RCI unit: -- the current scope is the that maps -- that unit. Interface_Dcl_Node := State.Current_Node; else declare Controlling_Formals : constant Parameter_Specification_List := Controlling_Formal_Parameters (Element); Tagged_Type_Declaration : Declaration := Nil_Element; begin -- First determine if this is a primitive operation -- of a tagged type. if Is_Function then declare Subtype_Mark : constant Asis.Expression := Result_Profile (Element); Subtype_Declaration : constant Asis.Declaration := Corresponding_Entity_Name_Declaration (Subtype_Mark); begin if Is_Controlling_Result (Subtype_Mark) then Tagged_Type_Declaration := Corresponding_First_Subtype (Subtype_Declaration); end if; end; end if; if Is_Nil (Tagged_Type_Declaration) and then Controlling_Formals'Length > 0 then Tagged_Type_Declaration := Corresponding_First_Subtype (Corresponding_Entity_Name_Declaration (Declaration_Subtype_Mark (Controlling_Formals (Controlling_Formals'First)))); -- Note: language rules guarantee that the -- choice of one controlling formal parameter -- does not affect the determination of the -- tagged type for which this operation is a -- primitive operation, because a dispatching -- operation is a primitive operation of exactly -- one tagged type. end if; if True and then not Is_Nil (Tagged_Type_Declaration) and then not Is_Overriding_Inherited_Subprogram (Element, Tagged_Type_Declaration) then -- This is a new dispatching operation of a tagged -- type (it does not override an inherited operation). -- Obtain the corresponding node. -- XXX For now, we do not check whether this operation -- overloads another with a different signature. In -- that case, a non-conformant IDL tree is produced -- (it contains overloaded operation declarations). Interface_Dcl_Node := Get_Translation (Tagged_Type_Declaration); end if; end; end if; if Kind (Interface_Dcl_Node) = K_Interface then State.Current_Node := Interface_Dcl_Node; if Get_Current_Scope /= State.Current_Node then Push_Scope (State.Current_Node); Need_To_Pop_Scope := True; else Need_To_Pop_Scope := False; end if; if Is_Function then Translate_Operation_Declaration (State, Map_Defining_Name (Defining_Name), False, Profile, Result_Profile => Result_Profile (Element), Op_Node => Op_Node); else Translate_Operation_Declaration (State, Map_Defining_Name (Defining_Name), False, Profile, Result_Profile => Nil_Element, Op_Node => Op_Node); end if; -- if State.Unit_Category /= Remote_Call_Interface then Set_Is_Explicit_Self (Op_Node, True); -- end if; Set_Translation (Element, Op_Node); -- The translation of a subprogram declaration is -- an . if Need_To_Pop_Scope then Pop_Scope; end if; else -- An operation declaration within something -- that is not an INTERFACE??? Raise_Translation_Error (Element, "Operation outside of an interface."); end if; State.Current_Node := Old_Current_Node; Control := Abandon_Children; -- Children were processed explicitly. end; when A_Parameter_Specification => -- 6.1(15) declare use CIAO.Translator.State; Defining_Names : constant Defining_Name_List := Declarations.Names (Element); Subtype_Mark : constant Asis.Expression := Declarations.Declaration_Subtype_Mark (Element); Declarator_Node : Node_Id; Mode : Param_Mode; Old_Current_Node : constant Node_Id := State.Current_Node; Success : Boolean; begin for I in Defining_Names'Range loop Node := Make_Param (No_Location); Append_Node_To_Parameters (State.Current_Node, Node); Declarator_Node := Make_Declarator (No_Location); Set_Declarator (Node, Declarator_Node); Set_Parent (Declarator_Node, Node); Success := Add_Identifier (Declarator_Node, Map_Defining_Name (Defining_Names (I))); pragma Assert (Success); Set_Param_Type (Node, Translate_Subtype_Mark (Subtype_Mark)); State.Current_Node := Old_Current_Node; if State.Unit_Category /= Remote_Call_Interface and then Is_Controlling_Formal (Element) then Mode := Mode_In; -- A controlling formal of a distributed object -- primitive is always passed as a remote object -- reference that is passed by value, with mode IN. else case Mode_Kind (Element) is when Not_A_Mode => -- An unexpected element Raise_Translation_Error (Element, "Unexpected element (Not_A_Mode)."); when A_Default_In_Mode | -- P : T An_In_Mode => -- P : IN T Mode := Mode_In; when An_Out_Mode => -- P : OUT T Mode := Mode_Out; when An_In_Out_Mode => -- P : IN OUT T Mode := Mode_Inout; end case; -- XXX warning: for out or inout parameters -- with a dynamic constrained status, DSA -- needs an extra formal to transmit that -- status. end if; Set_Mode (Node, Mode); end loop; end; Control := Abandon_Children; -- Children were processed explicitly. when A_Package_Declaration => -- 7.1(2) declare Visible_Part : constant Declarative_Item_List := Declarations.Visible_Part_Declarative_Items (Declaration => Element, Include_Pragmas => True); Success : Boolean; begin if State.Unit_Category = Remote_Call_Interface then -- The translation of a Remote Call Interface -- is an Node := Make_Interface (No_Location); Set_Abst (Node, False); Append_Node_To_Contents (State.Current_Node, Node); Success := Add_Identifier (Node, Map_Defining_Name (Defining_Name)); pragma Assert (Success); Set_Translation (Element, Node); Push_Scope (Node); -- Set_Is_Remote_Subprograms (Node, True); -- XXX CANNOT BE REPRESENTED in idlac tree! -- but will we need this in code gen phase? State.Current_Node := Node; else -- The translation of a non-RCI package -- declaration is a Node := Make_Module (No_Location); Success := Add_Identifier (Node, Map_Defining_Name (Defining_Name)); pragma Assert (Success); Append_Node_To_Contents (State.Current_Node, Node); Push_Scope (Node); State.Current_Node := Node; Set_Translation (Element, Node); end if; Translate_List (Visible_Part, State); Pop_Scope; State.Current_Node := Old_Current_Node; Control := Abandon_Children; -- Children were processed explicitly. end; when A_Procedure_Body_Declaration | -- 6.3(2) A_Function_Body_Declaration | -- 6.3(2) A_Task_Body_Declaration | -- 9.1(6) A_Protected_Body_Declaration | -- 9.4(7) A_Package_Body_Declaration | -- 7.2(2) A_Procedure_Body_Stub | -- 10.1.3(3) A_Function_Body_Stub | -- 10.1.3(3) A_Package_Body_Stub | -- 10.1.3(4) A_Task_Body_Stub | -- 10.1.3(5) A_Protected_Body_Stub | -- 10.1.3(6) An_Entry_Body_Declaration => -- 9.5.2(5) Raise_Translation_Error (Element, "Unexpected body declaration."); when An_Exception_Declaration | -- 11.1(2) -- User-defined exceptions need not be -- mapped, as all Ada exceptions are propagated -- as ::CIAO::Ada_Exception. A_Generic_Procedure_Declaration | -- 12.1(2) A_Generic_Function_Declaration | -- 12.1(2) A_Generic_Package_Declaration => -- 12.1(2) -- Generic declarations define no exported services, -- and are therefore not mapped. Control := Abandon_Children; when A_Package_Instantiation | -- 12.3(2) A_Procedure_Instantiation | -- 12.3(2) A_Function_Instantiation | -- 12.3(2) An_Object_Renaming_Declaration | -- 8.5.1(2) An_Exception_Renaming_Declaration | -- 8.5.2(2) A_Package_Renaming_Declaration | -- 8.5.3(2) A_Procedure_Renaming_Declaration | -- 8.5.4(2) A_Function_Renaming_Declaration | -- 8.5.4(2) A_Generic_Package_Renaming_Declaration | -- 8.5.5(2) A_Generic_Procedure_Renaming_Declaration | -- 8.5.5(2) A_Generic_Function_Renaming_Declaration => -- 8.5.5(2) -- These constructs are not supported due to -- restrictions placed by the translation specification. Raise_Translation_Error (Element, "Construct not supported by translation schema."); when Not_A_Declaration | -- Unexpected element A_Loop_Parameter_Specification | -- 5.5(4) An_Entry_Declaration | -- 9.5.2(2) An_Entry_Index_Specification | -- 9.5.2(2) A_Choice_Parameter_Specification | -- 11.2(4) A_Formal_Object_Declaration | -- 12.4(2) A_Formal_Type_Declaration | -- 12.5(2) A_Formal_Procedure_Declaration | -- 12.6(2) A_Formal_Function_Declaration | -- 12.6(2) A_Formal_Package_Declaration | -- 12.7(2) A_Formal_Package_Declaration_With_Box => -- 12.7(3) Raise_Translation_Error (Element, "Unexpected element (A_Declaration)."); end case; end Process_Declaration; procedure Process_Definition (Element : in Asis.Element; Control : in out Traverse_Control; State : in out Translator_State) is begin case Definition_Kind (Element) is when Not_A_Definition => -- An unexpected element Raise_Translation_Error (Element, "Unexpected element (A_Definition)."); when A_Type_Definition => -- 3.2.1(4) Process_Type_Definition (Element, Control, State); when A_Subtype_Indication => -- 3.2.2(3) -- Process child nodes: -- translate subtype_mark, ignore constraint. null; when A_Constraint => -- 3.2.2(5) -- Constraints cannot be represented in OMG IDL -- and are therefore ignored. Control := Abandon_Children; when A_Discrete_Subtype_Definition => -- 3.6(6) -- XXX Does this ever happen? raise Program_Error; when A_Discrete_Range => -- 3.6.1(3) case Kind (State.Current_Node) is when K_Union => -- A discrete_range as a discrete_choice for a variant null; -- XXX TODO: generate one Label for each value -- of the anonymous subtype declared by the discrete_range, -- and append each of these labels to -- Labels (State.Current_Node). when others => null; end case; when An_Unknown_Discriminant_Part => -- 3.7(3) -- XXX Does this ever happen? raise Program_Error; when A_Known_Discriminant_Part => -- 3.7(2) -- Process child nodes recursively. null; when A_Component_Definition | -- 3.6(7) A_Record_Definition | -- 3.8(3) -- Process child nodes. A_Null_Record_Definition | -- 3.8(3) A_Null_Component => -- 3.8(4) -- Nothing to do, no child elements. null; when A_Variant_Part => -- 3.8.1(2) declare Member_Node : constant Node_Id := Make_Member (No_Location); Decl_Node : constant Node_Id := Make_Declarator (No_Location); Union_Node : constant Node_Id := Make_Union (No_Location); Success : Boolean; begin Append_Node_To_Members (State.Current_Node, Member_Node); Append_Node_To_Decl (Member_Node, Decl_Node); Add_Identifier_With_Renaming (Decl_Node, "variant"); Success := Add_Identifier (Union_Node, Idl_Fe.Tree.Synthetic.Name (Decl_Node) & "_union"); pragma Assert (Success); Set_M_Type (Member_Node, Union_Node); Set_Switch_Type (Union_Node, Translate_Subtype_Mark (Declaration_Subtype_Mark (Corresponding_Entity_Name_Declaration (Discriminant_Direct_Name (Element))))); Set_Translation (Element, Union_Node); Set_Previous_Current_Node (Element, State.Current_Node); State.Current_Node := Union_Node; -- Process children recursively. end; when A_Variant => -- 3.8.1(3) -- Enclosing node is the union corresponding to the -- Variant_Part. declare Union_Node : constant Node_Id := State.Current_Node; Case_Node : Node_Id; Decl_Node : Node_Id; Struct_Node : Node_Id; Variant_Components : constant Asis.Record_Component_List := Record_Components (Element); Variant_Component : Asis.Record_Component renames Variant_Components (Variant_Components'First); Success : Boolean; begin Case_Node := Make_Case (No_Location); Decl_Node := Make_Declarator (No_Location); Append_Node_To_Cases (State.Current_Node, Case_Node); State.Current_Node := Case_Node; Translate_List (Variant_Choices (Element), State); State.Current_Node := Union_Node; if Is_In_List (Labels (Case_Node), No_Node) then -- The default label is denoted by an empty node. Set_Default_Index (State.Current_Node, Long_Integer (Length (Cases (Union_Node))) - 1); end if; Set_Case_Decl (Case_Node, Decl_Node); if Variant_Components'Length = 1 and then Element_Kind (Variant_Component) = A_Declaration -- Only one component, and not a null_component. then declare Component_Defining_Names : constant Asis.Defining_Name_List := Declarations.Names (Variant_Component); Component_Defining_Name : Asis.Defining_Name := Component_Defining_Names (Component_Defining_Names'First); begin Success := Add_Identifier (Decl_Node, Map_Defining_Name (Component_Defining_Name)); pragma Assert (Success); Set_Case_Type (Case_Node, Translate_Subtype_Mark (Asis.Definitions.Subtype_Mark (Component_Subtype_Indication (Object_Declaration_View (Variant_Component))))); end; else Struct_Node := Make_Struct (No_Location); Add_Identifier_With_Renaming (Decl_Node, "variant_components"); Success := Add_Identifier (Struct_Node, Idl_Fe.Tree.Synthetic.Name (Decl_Node) & "_struct"); pragma Assert (Success); Set_Case_Type (Case_Node, Struct_Node); State.Current_Node := Struct_Node; Translate_List (Variant_Components, State); end if; State.Current_Node := Union_Node; -- Restore value. Control := Abandon_Children; -- They have been processed explicitly. end; when An_Others_Choice => -- 3.8.1(5) -- => 4.3.1(5) => 4.3.3(5) => 11.2(5) if Kind (State.Current_Node) = K_Case then Append_Node_To_Labels (State.Current_Node, No_Node); -- The default label is denoted by an empty node. end if; when A_Private_Type_Definition | -- 7.3(2) A_Tagged_Private_Type_Definition | -- 7.3(2) A_Private_Extension_Definition => -- 7.3(3) -- Should probably never happen. Raise_Translation_Error (Element, "Unexpected element (a private type definition)."); when A_Task_Definition | -- 9.1(4) A_Protected_Definition => -- 9.4(4) -- A task type or protected type. -- declare -- Type_Spec_Node : Node_Id; -- begin -- Type_Spec_Node := Insert_New_Opaque_Type -- (State.Current_Node); Control := Abandon_Children; -- -- Children not processed (the mapping is opaque). -- end; raise Not_Implemented; when A_Formal_Type_Definition => -- 12.5(3) -- XXX Does this ever happen? -- We are not supposed to support generics?!?! raise Program_Error; end case; end Process_Definition; function Base_Type_For_Standard_Definition (Element : Asis.Type_Definition) return Node_Id; -- Return a node that denotes the standard IDL -- type corresponding to predefined type Element (which is -- expected to be a type definition within Standard). function Base_Type_For_Standard_Definition (Element : Asis.Type_Definition) return Node_Id is begin if Definition_Kind (Element) = A_Subtype_Indication then -- Unwind all levels of subtyping. return Base_Type_For_Standard_Definition (Type_Declaration_View (Corresponding_Entity_Name_Declaration (Asis.Definitions.Subtype_Mark (Element)))); else case Type_Kind (Element) is when A_Signed_Integer_Type_Definition => return Base_Type (Root_Integer); when A_Modular_Type_Definition => return Base_Type (Root_Modular); when A_Floating_Point_Definition | An_Ordinary_Fixed_Point_Definition | A_Decimal_Fixed_Point_Definition => return Base_Type (Root_Real); when An_Enumeration_Type_Definition => -- This is "Boolean". return Base_Type (Root_Boolean); when An_Unconstrained_Array_Definition => -- This is "String". return Base_Type (Root_String); when others => null; end case; end if; Raise_Translation_Error (Element, "Unexpected standard type definition."); end Base_Type_For_Standard_Definition; procedure Process_Expression (Element : in Asis.Element; Control : in out Traverse_Control; State : in out Translator_State) is use Asis.Extensions; -- In this subprogram we use ASIS-for-GNAT extensions -- to determine the value of static expressions. EK : constant Asis.Expression_Kinds := Expression_Kind (Element); EI : constant String := To_String (Static_Expression_Value_Image (Element)); EI_Valid : constant Boolean := True and then Is_True_Expression (Element) and then Is_Static (Element) and then EI'Length /= 0; begin case Kind (State.Current_Node) is when K_Union => pragma Assert (EK = An_Identifier); -- A Discriminant_Direct_Name. -- XXX record that the discriminant for this union -- is actually that member of the enclosing struct. return; when K_Case => null; -- see below. when others => Raise_Translation_Error (Element, "Unexpected expression."); end case; case EK is when Not_An_Expression => -- An unexpected element Raise_Translation_Error (Element, "Unexpected element (Not_An_Expression)."); -- when -- An_Identifier | -- 4.1 -- A_Selected_Component => -- 4.1.3 -- -- The expression shall be translated as -- -- a . State.Current_Node shall -- -- accept a subnode. -- declare -- use Asis.Compilation_Units; -- Name_Definition : constant Asis.Element -- := Corresponding_Entity_Name_Definition (Element); -- Origin : constant Compilation_Unit := -- Enclosing_Compilation_Unit (Name_Definition); -- -- The library unit where the name is declared. -- Node : Node_Id; -- begin -- if Is_Nil (Corresponding_Parent_Declaration (Origin)) then -- -- Element is a subtype_mark that denotes a type -- -- declared in predefined package Standard. -- Node := Base_Type_For_Standard_Definition -- (Type_Declaration_View -- (Enclosing_Element -- (Name_Definition))); -- Set_Base_Type_Spec (State.Current_Node, Node); -- Set_Parent (Node, State.Current_Node); -- else -- declare -- Include_Node : constant Node_Id -- := Get_Translation (Unit_Declaration (Origin)); -- begin -- if Include_Node /= Empty -- and then Node_Kind (Include_Node) -- = N_Preprocessor_Include -- then -- Set_Unit_Used (Include_Node, True); -- end if; -- Node := Relative_Scoped_Name -- (Denoted_Definition => Name_Definition, -- Referer => Element); -- Set_Scoped_Name (State.Current_Node, Node); -- Set_Parent (Node, State.Current_Node); -- end; -- end if; -- Control := Abandon_Children; -- -- Children were processed explicitly. -- end; -- when An_Attribute_Reference => -- 4.1.4 -- case Attribute_Kind (Element) is -- when -- A_Base_Attribute | -- A_Class_Attribute => -- Translate_Subtype_Mark (Prefix (Element), State); -- Control := Abandon_Children; -- -- Children were processed explicitly. -- when others => -- Raise_Translation_Error -- (Element, "Unexpected element" -- & " (An_Attribute_Reference)."); -- end case; when An_Integer_Literal => Append_Node_To_Labels (State.Current_Node, New_Integer_Literal (Integer'Value (EI))); -- when -- An_Integer_Literal | -- 2.4 -- A_Character_Literal | -- 4.1 -- An_Enumeration_Literal | -- 4.1 -- A_Null_Literal => -- 4.4 -- Raise_Translation_Error -- (Element, "Unexpected element (a literal)."); when A_Real_Literal | -- 2.4.1 A_String_Literal => -- 2.6 Raise_Translation_Error (Element, "Unexpected element (a non-scalar literal)."); -- when -- An_Operator_Symbol | -- 4.1 -- A_Function_Call => -- 4.1 -- Raise_Translation_Error -- (Element, "Unexpected element (a function or operator)."); -- when -- An_Explicit_Dereference | -- 4.1 -- An_Indexed_Component | -- 4.1.1 -- A_Slice => -- 4.1.2 -- Raise_Translation_Error -- (Element, "Unexpected element" -- & " (an indexed reference or explicit dereference)."); -- when -- A_Record_Aggregate | -- 4.3 -- An_Extension_Aggregate | -- 4.3 -- A_Positional_Array_Aggregate | -- 4.3 -- A_Named_Array_Aggregate => -- 4.3 -- Raise_Translation_Error -- (Element, "Unexpected element (an aggregate)."); -- when -- An_And_Then_Short_Circuit | -- 4.4 -- An_Or_Else_Short_Circuit | -- 4.4 -- An_In_Range_Membership_Test | -- 4.4 -- A_Not_In_Range_Membership_Test | -- 4.4 -- An_In_Type_Membership_Test | -- 4.4 -- A_Not_In_Type_Membership_Test | -- 4.4 -- A_Parenthesized_Expression | -- 4.4 -- A_Type_Conversion | -- 4.6 -- A_Qualified_Expression => -- 4.7 -- Raise_Translation_Error -- (Element, "Unexpected element (An_Expression)."); when An_Allocation_From_Subtype | -- 4.8 An_Allocation_From_Qualified_Expression => -- 4.8 Raise_Translation_Error (Element, "Unexpected element (an allocator)."); when others => if EI_Valid then if Has_Enumeration_Type (Element) then declare Lit_Enum_Node : Node_Id := No_Node; Enum_Type : constant Asis.Definition := Type_Declaration_View (Corresponding_First_Subtype (Corresponding_Expression_Type (Element))); Literals : constant Asis.Declaration_List := Enumeration_Literal_Declarations (Enum_Type); begin Scan_Enumerators : for I in Literals'Range loop declare Literal_Names : constant Asis.Defining_Name_List := Names (Literals (I)); Literal_Name : Asis.Defining_Name renames Literal_Names (Literal_Names'First); Pos_Image : constant String := To_String (Position_Number_Image (Literal_Name)); begin pragma Assert (Literal_Names'Length = 1); if Pos_Image = EI then Lit_Enum_Node := Make_Lit_Enum (No_Location); Set_Expr_Value (Lit_Enum_Node, new Constant_Value (Kind => C_Enum)); Expr_Value (Lit_Enum_Node).Enum_Value := Get_Translation (Literals (I)); pragma Assert (Is_Named (Expr_Value (Lit_Enum_Node).Enum_Value)); Append_Node_To_Labels (State.Current_Node, Lit_Enum_Node); exit Scan_Enumerators; end if; end; end loop Scan_Enumerators; if Lit_Enum_Node = No_Node then Raise_Translation_Error (Element, "Could not resolve enumerator name: " & EI); end if; end; elsif Has_Integer_Type (Element) then Append_Node_To_Labels (State.Current_Node, New_Integer_Literal (Integer'Value (EI))); end if; else Raise_Translation_Error (Element, "Cannot resolve expression value."); end if; end case; end Process_Expression; procedure Process_Type_Definition (Element : in Asis.Element; Control : in out Traverse_Control; State : in out Translator_State) is Old_Current_Node : constant Node_Id := State.Current_Node; TK : constant Asis.Type_Kinds := Type_Kind (Element); begin -- Translate the Element into a , and set the -- of State.Current_Node to that. case TK is when Not_A_Type_Definition => -- An unexpected element Raise_Translation_Error (Element, "Unexpected element (Not_A_Type_Definition)."); when A_Root_Type_Definition => -- 3.5.4(14) => 3.5.6(3) Raise_Translation_Error (Element, "Unexpected implicit element" & " (A_Root_Type_Definition)."); when A_Derived_Type_Definition => -- 3.4(2) Set_T_Type (State.Current_Node, Translate_Subtype_Mark (Asis.Definitions.Subtype_Mark (Asis.Definitions.Parent_Subtype_Indication (Element)))); Control := Abandon_Children; -- Children were processed explicitly. when An_Enumeration_Type_Definition => -- 3.5.1(2) null; -- Process all children recursively. when A_Signed_Integer_Type_Definition | -- 3.5.4(3) A_Modular_Type_Definition | -- 3.5.4(4) A_Floating_Point_Definition | -- 3.5.7(2) An_Ordinary_Fixed_Point_Definition | -- 3.5.9(3) A_Decimal_Fixed_Point_Definition => -- 3.5.9(6) Set_T_Type (State.Current_Node, Base_Type_For_Standard_Definition (Element)); Control := Abandon_Children; -- Children were processed explicitly. when An_Unconstrained_Array_Definition | -- 3.6(2) A_Constrained_Array_Definition => -- 3.6(2) declare Component_Subtype_Mark : constant Asis.Expression := Asis.Definitions.Subtype_Mark (Component_Subtype_Indication (Array_Component_Definition (Element))); begin if Is_Limited_Type (Corresponding_Entity_Name_Declaration (Component_Subtype_Mark)) then -- Current_Node is a typedef Set_T_Type (State.Current_Node, New_Opaque_Type); else -- Current_Node is a struct that will hold -- a member array containing array bounds, -- and a member sequence containing array values. declare Dimensions : Natural; Struct_Type_Node : constant Node_Id := State.Current_Node; Member_Node : Node_Id; Declarator_Node : Node_Id; Parent_Node : Node_Id; Success : Boolean; begin if TK = An_Unconstrained_Array_Definition then Dimensions := Index_Subtype_Definitions (Element)'Length; else Dimensions := Discrete_Subtype_Definitions (Element)'Length; end if; -- State.Current_Node is the -- associated with this type. ---------------------------------------------------------- -- : unsigned long long Low_Bound; -- -- OR unsigned long long Low_Bounds[DIMENSIONS]; -- ---------------------------------------------------------- Member_Node := Make_Member (No_Location); Append_Node_To_Members (Struct_Type_Node, Member_Node); Set_M_Type (Member_Node, Base_Type (Root_Integer)); Declarator_Node := Make_Declarator (No_Location); Set_Parent (Declarator_Node, Member_Node); Append_Node_To_Decl (Member_Node, Declarator_Node); if Dimensions = 1 then Success := Add_Identifier (Declarator_Node, "Low_Bound"); pragma Assert (Success); else declare Size_Node : Node_Id; begin Success := Add_Identifier (Declarator_Node, "Low_Bounds"); pragma Assert (Success); Size_Node := New_Integer_Literal (Dimensions); Append_Node_To_Array_Bounds (Declarator_Node, Size_Node); end; end if; -------------------------------------------------- -- : sequence<...> Array_Values; -- -- -- -- For now, we cannot determine the bounds of a -- -- static constrained array, so we always map -- -- all arrays to sequences. -- -------------------------------------------------- Member_Node := Make_Member (No_Location); Append_Node_To_Members (Struct_Type_Node, Member_Node); Set_M_Type (Member_Node, Base_Type (Root_Integer)); Declarator_Node := Make_Declarator (No_Location); Set_Parent (Declarator_Node, Member_Node); Append_Node_To_Decl (Member_Node, Declarator_Node); Success := Add_Identifier (Declarator_Node, "Array_Values"); pragma Assert (Success); Parent_Node := Member_Node; for I in 1 .. Dimensions loop declare Sequence_Node : Node_Id; begin Sequence_Node := Make_Sequence (No_Location); if Parent_Node = Member_Node then Set_M_Type (Parent_Node, Sequence_Node); else Set_Sequence_Type (Parent_Node, Sequence_Node); end if; Parent_Node := Sequence_Node; end; end loop; -- Parent_Node is innermost sequence. Set_Sequence_Type (Parent_Node, Translate_Subtype_Mark (Component_Subtype_Mark)); State.Current_Node := Old_Current_Node; end; end if; Control := Abandon_Children; -- Children were processed explicitly. end; when A_Record_Type_Definition => -- 3.8(2) null; -- Process all children recursively. when A_Tagged_Record_Type_Definition | -- 3.8(2) A_Derived_Record_Extension_Definition => -- 3.4(2) -- Processed directly in Process_Declaration. raise Program_Error; -- Set_T_Type (State.Current_Node, New_Opaque_Type); -- Control := Abandon_Children; -- -- Children were processed explicitly when An_Access_Type_Definition => -- 3.10(2) -- This is the definition of a Remote Access to Class-Wide -- type (RAS were processed in Process_Declaration directly; -- other access-to-object types would not be allowed in the -- visible part of a declared pure, RT or RCI package). -- Note: if Is_Asynchronous is True for this RACW type, -- then method calls should be asynchronous when they -- are made that way. DSA stub objects must be parameterised -- to contain a flag that indicates whether method calls -- should be asynchronous or not, and this flag should be -- set when creating a value of a RACW type (i.e. in the -- corresponding From_Any helper). declare Designated_Subtype : constant Asis.Expression := Asis.Definitions.Subtype_Mark (Asis.Definitions.Access_To_Object_Definition (Element)); begin pragma Assert (True and then Expression_Kind (Designated_Subtype) = An_Attribute_Reference and then Attribute_Kind (Designated_Subtype) = A_Class_Attribute); Set_T_Type (State.Current_Node, Translate_Subtype_Mark (Prefix (Designated_Subtype))); Control := Abandon_Children; -- Child elements were processed explicitly. end; end case; end Process_Type_Definition; function Map_Defining_Name (Name : in Asis.Defining_Name) return String is begin case Defining_Name_Kind (Name) is when Not_A_Defining_Name => Raise_Translation_Error (Name, "Unexpected element (Not_A_Defining_Name)."); when A_Defining_Identifier | A_Defining_Enumeration_Literal | A_Defining_Expanded_Name => return To_String (Declarations.Defining_Name_Image (Name)); when A_Defining_Character_Literal => return Maps.Character_Literal_Identifier (Declarations.Defining_Name_Image (Name)); when A_Defining_Operator_Symbol => return Maps.Operator_Symbol_Identifier (Name); end case; end Map_Defining_Name; function Translate_Subtype_Mark (Exp : in Asis.Expression) return Node_Id is EK : constant Expression_Kinds := Expression_Kind (Exp); begin case EK is when An_Identifier | -- 4.1 A_Selected_Component => -- 4.1.3 declare use Asis.Compilation_Units; Name_Definition : constant Asis.Element := Corresponding_Entity_Name_Definition (Exp); Origin : constant Compilation_Unit := Enclosing_Compilation_Unit (Name_Definition); -- The library unit where the name is declared. begin if Is_Nil (Corresponding_Parent_Declaration (Origin)) then -- Exp is a subtype_mark that denotes a type -- declared in predefined package Standard. return Base_Type_For_Standard_Definition (Type_Declaration_View (Enclosing_Element (Name_Definition))); else -- Exp is a name that resolves to denote a -- user-defined type. declare N : constant Node_Id := Get_Translation (Corresponding_Entity_Name_Declaration (Exp)); Name : constant Node_Id := Make_Scoped_Name (No_Location); begin if N = No_Node then Raise_Translation_Error (Exp, "Translation of element is unknown."); end if; if not Is_Named (N) then Raise_Translation_Error (Exp, "Translation of element is not named (it is a " & Node_Kind'Image (Kind (N)) & ")."); end if; Set_Value (Name, N); return Name; end; end if; end; when An_Attribute_Reference => -- 4.1.4 case Attribute_Kind (Exp) is when A_Base_Attribute | A_Class_Attribute => return Translate_Subtype_Mark (Prefix (Exp)); when others => Raise_Translation_Error (Exp, "Unexpected element (An_Attribute_Reference)."); end case; when others => null; end case; Raise_Translation_Error (Exp, "Unexpected element (not a subtype mark)."); end Translate_Subtype_Mark; -- procedure Translate_Discriminant_Part -- (Element : in Asis.Declaration; -- State : in out Translator_State) is -- Control : Traverse_Control := Continue; -- Current_Pass : constant Translation_Pass -- := State.Pass; -- begin -- Translate_Tree (Discriminant_Part (Element), Control, State); -- end Translate_Discriminant_Part; -- procedure Translate_Type_Definition -- (Def : in Asis.Definition; -- State : in out Translator_State) is -- Control : Traverse_Control := Continue; -- Current_Pass : constant Translation_Pass -- := State.Pass; -- begin -- State.Pass := CIAO.Translator.State.Type_Definition; -- Translate_Tree (Def, Control, State); -- State.Pass := Current_Pass; -- end Translate_Type_Definition; procedure Translate_List (List : in Asis.Element_List; State : in out Translator_State) is Control : Traverse_Control := Continue; begin for I in List'Range loop Translate_Tree (List (I), Control, State); exit when Control = Abandon_Siblings; end loop; end Translate_List; procedure Translate_Formal_Parameter (Specification : in Asis.Definition; State : in out Translator_State) is Control : Traverse_Control := Continue; begin Translate_Tree (Specification, Control, State); end Translate_Formal_Parameter; ----------------------------------------------------------- -- Post_Translate_Element -- -- Restore Current_Node after a node has been -- -- entirely constructed. -- -- Used as post-operation for Iterator.Traverse_Element. -- ----------------------------------------------------------- procedure Post_Translate_Element (Element : in Asis.Element; Control : in out Traverse_Control; State : in out Translator_State) is Previous_Current_Node : constant Node_Id := Get_Previous_Current_Node (Element); begin if Previous_Current_Node /= No_Node then State.Current_Node := Previous_Current_Node; end if; end Post_Translate_Element; procedure Translate_Context_Clause (Library_Unit : Asis.Compilation_Unit; State : in out Translator_State); -- Translate the context clause of a library unit -- into a set of subtree inclusions. procedure Translate_Context_Clause (Library_Unit : Asis.Compilation_Unit; State : in out Translator_State) is Context_Clause_Items : constant Context_Clause_List := Context_Clause_Elements (Library_Unit); Defining_Names : constant Asis.Name_List := Names (Unit_Declaration (Library_Unit)); Name : constant Asis.Name := Defining_Names (Defining_Names'First); begin -- Include_Node := New_Include_Directive; -- Set_Parent (Include_Node, State.Current_Node); -- Add_Directive (State.Current_Node, Include_Node); -- Set_Name (Include_Node, New_Name ("ciao.idl")); -- Set_Unit_Used (Include_Node, True); for I in Context_Clause_Items'Range loop declare Clause : constant Context_Clause := Context_Clause_Items (I); begin case Clause_Kind (Clause) is when A_With_Clause => declare Units : constant Name_List := Asis.Clauses.Clause_Names (Clause); begin for J in Units'Range loop declare Unit_Declaration : constant Asis.Declaration := Corresponding_Entity_Name_Declaration (Units (J)); begin Translate (Enclosing_Compilation_Unit (Unit_Declaration), State.Repository); end; end loop; end; when others => null; end case; end; end loop; -- If this is a child unit of a library unit, then its -- visible part has visibility on the visible part of -- its parent. if Defining_Name_Kind (Name) = A_Defining_Expanded_Name then declare Unit_Declaration : constant Asis.Declaration := Corresponding_Entity_Name_Declaration (Defining_Prefix (Name)); begin Translate (Enclosing_Compilation_Unit (Unit_Declaration), State.Repository); end; end if; end Translate_Context_Clause; procedure Translate (LU : in Compilation_Unit; Repository : in out Node_Id) is Category : constant Unit_Categories := Unit_Category (LU); Need_To_Pop_Scope : Boolean; begin if Repository = No_Node then Repository := Make_Repository (No_Location); Push_Scope (Repository); Need_To_Pop_Scope := True; else pragma Assert (Is_Repository (Repository)); Need_To_Pop_Scope := False; end if; if Category = Other then Raise_Translation_Error (Nil_Element, "The unit is not a Pure, Remote Types or " & "Remote Call Interface package specification."); end if; declare D : constant Declaration := Unit_Declaration (LU); C : Traverse_Control := Continue; S : Translator_State; begin if Get_Translation (D) = No_Node then -- Unit not already translated. Initialize_Translator_State (Category => Category, Unit => LU, Repository => Repository, State => S); Translate_Context_Clause (LU, S); Translate_Tree (D, C, S); end if; end; if Need_To_Pop_Scope then Pop_Scope; end if; end Translate; end CIAO.Translator; polyorb-2.8~20110207.orig/compilers/ciao/ciao-generator-broca.ads0000644000175000017500000000256311750740337024002 0ustar xavierxavier---------------------------------------- -- -- -- ---- --- -- ---- -- -- - - - - - - -- -- - - ---- - - -- -- ---- --- - - ---- -- -- -- ---------------------------------------- -- CORBA -- -- Interface for -- -- Ada'95 distributed systems annex -- -- Objects -- ---------------------------------------- -- Copyright (c) 1999 -- -- École nationale supérieure des -- -- télécommunications -- ---------------------------------------- -- ORB-specific matter, Broca version. with CIAO.Generator.ORB_Deps_G; with CIAO.Types; package CIAO.Generator.Broca is Broca_ObjectId_Sequences_Package : constant Wide_String := "Broca.Sequences.Octet_Sequences"; Broca_ObjectId_Sequences_Dependency : constant Wide_String := "Broca.Sequences"; function Broca_Sequences_Package (N : CIAO.Types.Node_Id) return Wide_String; package ORB_Deps is new CIAO.Generator.ORB_Deps_G (ObjectId_Sequences_Package => Broca_ObjectId_Sequences_Package, ObjectId_Sequences_Dependency => Broca_ObjectId_Sequences_Dependency, Sequences_Package => Broca_Sequences_Package); end CIAO.Generator.Broca; polyorb-2.8~20110207.orig/compilers/ciao/ciao-generator-idl.ads0000644000175000017500000000231711750740337023461 0ustar xavierxavier---------------------------------------- -- -- -- ---- --- -- ---- -- -- - - - - - - -- -- - - ---- - - -- -- ---- --- - - ---- -- -- -- ---------------------------------------- -- CORBA -- -- Interface for -- -- Ada'95 distributed systems annex -- -- Objects -- ---------------------------------------- -- Copyright (c) 1999 -- -- École nationale supérieure des -- -- télécommunications -- ---------------------------------------- -- The interface description (IDL) generator. -- Produces an IDL specification from an IDL -- tree obtained as output of the translator. with Ada.Text_Io; with CIAO.Types; use CIAO.Types; package CIAO.Generator.IDL is procedure Generate (Tree : in Node_Id; File : in Ada.Text_Io.File_Type); -- Generate an OMG IDL interface description for -- the remotely callable entitites (remote procedures, -- remote accesses to subprogram and remote -- accesses to class-wide type). end CIAO.Generator.IDL; polyorb-2.8~20110207.orig/compilers/ciao/ciao-types.ads0000644000175000017500000002332711750740337022075 0ustar xavierxavier-- The package Types is a part of the GNAT compiler. -- Copyright (C) 1992-1998 Free Software Foundation, Inc. -- This modified version is a part of the CIAO project. -- Copyright (C) 1999 École nationale supérieure des télécommunications. ------------------------------------------------------------------------------ -- -- -- GNAT COMPILER COMPONENTS -- -- -- -- T Y P E S -- -- -- -- S p e c -- -- -- -- Copyright (C) 1992-1998 Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- -- for more details. You should have received a copy of the GNU General -- -- Public License distributed with GNAT; see file COPYING. If not, write -- -- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- -- MA 02111-1307, USA. -- -- -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). -- -- -- ------------------------------------------------------------------------------ with Unchecked_Deallocation; package CIAO.Types is pragma Preelaborate (CIAO.Types); -- This package contains host independent type definitions which are used -- in more than one unit in the compiler. They are gathered here for easy -- reference, though in some cases the full description is found in the -- relevant module which implements the definition. The main reason that -- they are not in their "natural" specs is that this would cause a lot of -- inter-spec dependencies, and in particular some awkward circular -- dependencies would have to be dealt with. -- WARNING: There is a C version of this package. Any changes to this -- source file must be properly reflected in the C header file a-types.h -- Note: the declarations in this package reflect an expectation that the -- host machine has an efficient integer base type with a range at least -- 32 bits 2s-complement. If there are any machines for which this is not -- a correct assumption, a significant number of changes will be required! ------------------------------- -- General Use Integer Types -- ------------------------------- type Int is range -2 ** 31 .. +2 ** 31 - 1; -- Signed 32-bit integer subtype Nat is Int range 0 .. Int'Last; -- Non-negative Int values subtype Pos is Int range 1 .. Int'Last; -- Positive Int values type Word is mod 2 ** 32; -- Unsigned 32-bit integer type Short is range -32768 .. +32767; for Short'Size use 16; -- 16-bit signed integer type Byte is mod 2 ** 8; for Byte'Size use 8; -- 8-bit unsigned integer type size_t is mod 2 ** Standard'Address_Size; -- Memory size value, for use in calls to C routines -------------------------------------- -- 8-Bit Character and String Types -- -------------------------------------- -- We use Standard.Character and Standard.String freely, since we are -- compiling ourselves, and we properly implement the required 8-bit -- character code as required in Ada 95. This section defines a few -- general use constants and subtypes. EOF : constant Character := ASCII.SUB; -- The character SUB (16#1A#) is used in DOS and other systems derived -- from DOS (OS/2, NT etc) to signal the end of a text file. Internally -- all source files are ended by an EOF character, even on Unix systems. -- An EOF character acts as the end of file only as the last character -- of a source buffer, in any other position, it is treated as a blank -- if it appears between tokens, and as an illegal character otherwise. -- This makes life easier dealing with files that originated from DOS, -- including concatenated files with interspersed EOF characters. subtype Graphic_Character is Character range ' ' .. '~'; -- Graphic characters, as defined in ARM subtype Line_Terminator is Character range ASCII.LF .. ASCII.CR; -- Line terminator characters (LF, VT, FF, CR) subtype Upper_Half_Character is Character range Character'Val (16#80#) .. Character'Val (16#FF#); -- Characters with the upper bit set type Character_Ptr is access all Character; type String_Ptr is access all String; type Wide_String_Ptr is access all Wide_String; -- Standard character and string pointers procedure Free is new Unchecked_Deallocation (String, String_Ptr); procedure Free is new Unchecked_Deallocation (Wide_String, Wide_String_Ptr); -- Procedure for freeing dynamically allocated String values -- subtype Word_Hex_String is String (1 .. 8); -- -- Type used to represent Word value as 8 hex digits, with upper case -- -- letters for the alphabetic cases. -- function Get_Hex_String (W : Word) return Word_Hex_String; -- -- Convert word value to 8-character hex string ----------------------------------------- -- Types Used for Text Buffer Handling -- ----------------------------------------- -- We can't use type String for text buffers, since we must use the -- standard 32-bit integer as an index value, since we count on all -- index values being the same size. type Text_Ptr is new Int; -- Type used for subscripts in text buffer type Text_Buffer is array (Text_Ptr range <>) of Character; -- Text buffer used to hold source file or library information file type Text_Buffer_Ptr is access all Text_Buffer; -- Text buffers for input files are allocated dynamically and this type -- is used to reference these text buffers. procedure Free is new Unchecked_Deallocation (Text_Buffer, Text_Buffer_Ptr); -- Procedure for freeing dynamically allocated text buffers ------------------------------------------ -- Types Used for Source Input Handling -- ------------------------------------------ type Logical_Line_Number is range 0 .. Int'Last; for Logical_Line_Number'Size use 32; -- Line number type, used for storing logical line numbers (i.e. line -- numbers that include the line offset from pragma Source_Reference) -- Logical line number zero is reserved for the line containing the -- Source_Reference pragma at the start of the file. No_Line_Number : constant Logical_Line_Number := 0; -- Special value used to indicate no line number type Column_Number is range 0 .. 32767; for Column_Number'Size use 16; -- Column number (assume that 2**15 is large enough, see declaration -- of Hostparm.Max_Line_Length) No_Column_Number : constant Column_Number := 0; -- Special value used to indicate no column number subtype Source_Buffer is Text_Buffer; -- Type used to store text of a source file . The buffer for the main -- source (the source specified on the command line) has a lower bound -- starting at zero. Subsequent subsidiary sources have lower bounds -- which are one greater than the previous upper bound. subtype Big_Source_Buffer is Text_Buffer (0 .. Text_Ptr'Last); -- This is a virtual type used as the designated type of the access -- type Source_Buffer_Ptr, see Osint.Read_Source_File for details. type Source_Buffer_Ptr is access all Big_Source_Buffer; -- Pointer to source buffer. We use virtual origin addressing for -- source buffers, with thin pointers. The pointer points to a virtual -- instance of type Big_Source_Buffer, where the actual type is in fact -- of type Source_Buffer. The address is adjusted so that the virtual -- origin addressing works correctly. See Osint.Read_Source_Buffer for -- further details. subtype Source_Ptr is Text_Ptr; -- Type used to represent a source location, which is a subscript of a -- character in the source buffer. As noted above, diffferent source -- buffers have different ranges, so it is possible to tell from a -- Source_Ptr value which source it refers to. Note that negative numbers -- are allowed to accomodate the following special values. No_Location : constant Source_Ptr := -1; -- Value used to indicate no source position set in a node Standard_Location : constant Source_Ptr := -2; -- Used for all nodes in the representation of package Standard other -- than nodes representing the contents of Standard.ASCII. Note that -- testing for <= Standard_Location tests for both Standard_Location -- and for Standard_ASCII_Location. Standard_ASCII_Location : constant Source_Ptr := -3; -- Used for all nodes in the presentation of package Standard.ASCII First_Source_Ptr : constant Source_Ptr := 0; -- Starting source pointer index value for first source program end CIAO.Types; polyorb-2.8~20110207.orig/compilers/ciao/ciao-hostparm.ads0000644000175000017500000001132311750740337022557 0ustar xavierxavier-- The package Hostparm is a part of the GNAT compiler. -- Copyright (C) 1992-1998 Free Software Foundation, Inc. -- This modified version is a part of the CIAO project. -- Copyright (C) 1999 École nationale supérieure des télécommunications. ------------------------------------------------------------------------------ -- -- -- GNAT COMPILER COMPONENTS -- -- -- -- H O S T P A R M -- -- -- -- S p e c -- -- -- -- Copyright (C) 1992-1998 Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- -- for more details. You should have received a copy of the GNU General -- -- Public License distributed with GNAT; see file COPYING. If not, write -- -- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- -- MA 02111-1307, USA. -- -- -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). -- -- -- ------------------------------------------------------------------------------ -- This package defines some system dependent parameters for GNAT. These -- are parameters that are relevant to the host machine on which the -- compiler is running, and thus this package is part of the compiler. package CIAO.Hostparm is pragma Pure (Hostparm); OpenVMS : constant Boolean := False; -- Set true for compilers for OpenVMS systems. This is really a target -- flag, which should be sorted out some time??? For now we have no cross -- compilers with OpenVMS as the target so there is no confusion. Long_Integer_Size : constant := 0; -- This is the length of the long integer type in bits. A value of -- zero means that the length is to be taken from the C type long. -- Otherwise a non-zero length overrides the C length. This is used -- for the Alpha VMS port, where Long_Integer is 64 bits, even though -- the C long type remains at 32 bits. This is really a target flag, -- which should be sorted out some time??? For now we have no cross -- compilers with OpenVMS as the target, so there is no confusion Normalized_CWD : constant String := "./"; -- Normalized string to access current directory Max_Line_Length : constant := 255; -- Maximum source line length. This can be set to any value up to -- 2**15 - 1, a limit imposed by the assumption that column numbers -- can be stored in 16 bits (see Types.Column_Number). A value of -- 200 is the minimum value required (RM 2.2(15)), but we use 255 -- for most GNAT targets since this is DEC Ada compatible. Max_Name_Length : constant := 1024; -- Maximum length of unit name (including all dots, and " (spec)") and -- of file names in the library, must be at least Max_Line_Length, but -- can be larger. Max_Instantiations : constant := 4000; -- Maximum number of instantiations permitted (to stop runaway cases -- of nested instantiations). These situations probably only occur in -- specially concocted test cases. Tag_Errors : constant Boolean := False; -- If set to true, then brief form error messages will be prefaced by -- the string "error:" Exclude_Missing_Objects : constant Boolean := True; -- If set to true, gnatbind will exclude from consideration all -- non-existent .o files. Zero_Cost_Exceptions : constant Boolean := False; -- This switch is set to True if zero cost exceptions are implemented -- on the current target. See unit Ada.Exceptions for full details. end CIAO.Hostparm; polyorb-2.8~20110207.orig/compilers/ciao/ciao_runtime-encap_streams.adb0000644000175000017500000000455611750740337025302 0ustar xavierxavier---------------------------------------- -- -- -- ---- --- -- ---- -- -- - - - - - - -- -- - - ---- - - -- -- ---- --- - - ---- -- -- -- ---------------------------------------- -- CORBA -- -- Interface for -- -- Ada'95 distributed systems annex -- -- Objects -- ---------------------------------------- -- Copyright (c) 1999 -- -- École nationale supérieure des -- -- télécommunications -- ---------------------------------------- -- A DSA stream based on a CORBA Encapsulation -- (sequence). package body CIAO_Runtime.Encap_Streams is use IDL_SEQUENCE_Octet; procedure Set_Seq (St : in out Stream; Ar : Octet_Array) is begin St.Seq := IDL_Sequence_Octet.To_Sequence (Ar); St.Pos := 1; end Set_Seq; function Get_Seq (St : Stream) return Octet_Array is begin return To_Element_Array (St.Seq); end Get_Seq; procedure Read (St : in out Stream; Item : out Stream_Element_Array; Last : out Stream_Element_Offset) is Read_Length : Integer; begin if Item'Length > Length (St.Seq) - St.Pos + 1 then Read_Length := Length (St.Seq) - St.Pos; else Read_Length := Item'Length; end if; if Read_Length <= 0 then Last := Item'First - 1; return; end if; declare Data : Octet_Array := Slice (St.Seq, St.Pos, St.Pos + Read_Length - 1); begin for I in Data'Range loop Item (Stream_Element_Offset (I - Data'First) + Item'First) := Stream_Element (Data (I)); end loop; end; Last := Item'First + Stream_Element_Offset (Read_Length - 1); St.Pos := St.Pos + Read_Length; end Read; procedure Write (St : in out Stream; Item : in Stream_Element_Array) is begin declare Data : Octet_Array (Integer (Item'First) .. Integer (Item'Last)); begin for I in Item'Range loop Data (Integer (I)) := CORBA.Octet (Item (I)); end loop; Append (St.Seq, Data); St.Pos := St.Pos + Item'Size; end; end Write; end CIAO_Runtime.Encap_Streams; polyorb-2.8~20110207.orig/compilers/ciao/ciao-alloc.ads0000644000175000017500000001467611750740337022032 0ustar xavierxavier-- The package Alloc is a part of the GNAT compiler. -- Copyright (C) 1992-1998 Free Software Foundation, Inc. -- This modified version is a part of the CIAO project. -- Copyright (C) 1999 École nationale supérieure des télécommunications. ------------------------------------------------------------------------------ -- -- -- GNAT COMPILER COMPONENTS -- -- -- -- A L L O C -- -- -- -- S p e c -- -- -- -- Copyright (C) 1992-1998 Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- -- for more details. You should have received a copy of the GNU General -- -- Public License distributed with GNAT; see file COPYING. If not, write -- -- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- -- MA 02111-1307, USA. -- -- -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). -- -- -- ------------------------------------------------------------------------------ -- This package contains definitions for initial sizes and growth increments -- for the various dynamic arrays used for principle compiler data strcutures. -- The indicated initial size is allocated for the start of each file, and -- the increment factor is a percentage used to increase the table size when -- it needs expanding (e.g. a value of 100 = 100% increase = double) -- Note: the initial values here are multiplied by Table_Factor, as set -- by the -gnatTnn switch. This variable is defined in Opt, as is the -- default value for the table factor. package CIAO.Alloc is -- The comment shows the unit in which the table is defined All_Interp_Initial : constant := 1_000; -- Sem_Type All_Interp_Increment : constant := 100; Elists_Initial : constant := 200; -- Elists Elists_Increment : constant := 100; Elmts_Initial : constant := 1_200; -- Elists Elmts_Increment : constant := 100; Entity_Suppress_Initial : constant := 100; -- Sem Entity_Suppress_Increment : constant := 200; Feature_List_Initial : constant := 5; -- Features Feature_List_Increment : constant := 300; Inlined_Initial : constant := 100; -- Inline Inlined_Increment : constant := 100; Inlined_Bodies_Initial : constant := 50; -- Inline Inlined_Bodies_Increment : constant := 200; Interp_Map_Initial : constant := 200; -- Sem_Type Interp_Map_Increment : constant := 100; Lines_Initial : constant := 500; -- Sinput Lines_Increment : constant := 150; Linker_Option_Lines_Initial : constant := 5; -- Lib Linker_Option_Lines_Increment : constant := 200; Lists_Initial : constant := 4_000; -- Nlists Lists_Increment : constant := 200; Load_Stack_Initial : constant := 10; -- Lib Load_Stack_Increment : constant := 100; Name_Chars_Initial : constant := 50_000; -- Namet Name_Chars_Increment : constant := 100; Names_Initial : constant := 6_000; -- Namet Names_Increment : constant := 100; Nodes_Initial : constant := 50_000; -- Atree Nodes_Increment : constant := 100; Orig_Nodes_Initial : constant := 50_000; -- Atree Orig_Nodes_Increment : constant := 100; Pending_Instantiations_Initial : constant := 10; -- Inline Pending_Instantiations_Increment : constant := 100; Scope_Stack_Initial : constant := 10; -- Sem Scope_Stack_Increment : constant := 200; SFN_Table_Initial : constant := 10; -- Fname SFN_Table_Increment : constant := 200; Source_File_Initial : constant := 10; -- Sinput Source_File_Increment : constant := 200; String_Chars_Initial : constant := 2_500; -- Stringt String_Chars_Increment : constant := 150; Strings_Initial : constant := 5_00; -- Stringt Strings_Increment : constant := 150; Successors_Initial : constant := 2_00; -- Inline Successors_Increment : constant := 100; Udigits_Initial : constant := 10_000; -- Uintp Udigits_Increment : constant := 100; Uints_Initial : constant := 5_000; -- Uintp Uints_Increment : constant := 100; Units_Initial : constant := 30; -- Lib Units_Increment : constant := 100; Ureals_Initial : constant := 200; -- Urealp Ureals_Increment : constant := 100; With_List_Initial : constant := 10; -- Features With_List_Increment : constant := 300; Xrefs_Initial : constant := 5_000; -- Cross-refs Xrefs_Increment : constant := 300; end CIAO.Alloc; polyorb-2.8~20110207.orig/compilers/ciao/ciao-filenames.ads0000644000175000017500000000236711750740337022675 0ustar xavierxavier---------------------------------------- -- -- -- ---- --- -- ---- -- -- - - - - - - -- -- - - ---- - - -- -- ---- --- - - ---- -- -- -- ---------------------------------------- -- CORBA -- -- Interface for -- -- Ada'95 distributed systems annex -- -- Objects -- ---------------------------------------- -- Copyright (c) 1999 -- -- École nationale supérieure des -- -- télécommunications -- ---------------------------------------- -- Mapping of file names with Asis; package CIAO.Filenames is -- The name of the IDL file that contains the mapping of the -- given Ada file. function IDL_File_Name (Ada_File_Name : String) return String; -- The name of the source file that contains the declaration -- or body of the library unit whose full name is given. type Unit_Part is (Unit_Declaration, Unit_Body); function Ada_File_Name (Full_Name : Asis.Program_Text; Part : Unit_Part := Unit_Declaration) return String; end CIAO.Filenames; polyorb-2.8~20110207.orig/compilers/ciao/ciao-ada_source_streams.ads0000644000175000017500000001325011750740337024566 0ustar xavierxavier---------------------------------------- -- -- -- ---- --- -- ---- -- -- - - - - - - -- -- - - ---- - - -- -- ---- --- - - ---- -- -- -- ---------------------------------------- -- CORBA -- -- Interface for -- -- Ada'95 distributed systems annex -- -- Objects -- ---------------------------------------- -- Copyright (c) 1999 -- -- Icole nationale supirieure des -- -- tilicommunications -- ---------------------------------------- -- An abstraction for the production of the text of -- an Ada 95 compilation unit. with Ada.Finalization; with Ada.Strings.Unbounded; use Ada.Strings.Unbounded; package CIAO.Ada_Source_Streams is Indent_Size : constant := 3; type Compilation_Unit is private; -- A complete compilation unit. type Unit_Kind is (Unit_Spec, Unit_Body); -- The kind of a compilation unit. type Diversion is (Visible_Declarations, Private_Declarations, Generic_Formals, Elaboration); -- A compilation unit can have several diversions, -- each of which is a linear stream of source code -- lines. -- The Visible_Declarations and Private_Declarations -- diversions correspond to the visible and private -- parts of the compilation unit's declarative region. -- The Elaboration diversion corresponds to the elaboration -- statements in a package body. type Elab_Control_Pragma is (None, -- Add no elaboration control pragma Elaborate, -- Add a pragma Elaborate Elaborate_All); -- Add a pragma Elaborate_All -- Possible elaboration control pragmas that can be added -- for a dependency. --------------------------------------------------- -- The following subprograms operate globally on -- -- a compilation unit. -- --------------------------------------------------- procedure Divert (CU : in out Compilation_Unit; Whence : Diversion); -- Set CU's current diversion to Whence. -- If CU is a Unit_Spec, it is not allowed to set the current -- diversion to Elaboration. -- If CU is a Unit_Body, it is not allowed to set the current -- diversion to Private_Declarations or Generic_Formals. procedure Add_With (Unit : in out Compilation_Unit; Dep : String; Use_It : Boolean := False; Elab_Control : Elab_Control_Pragma := None); -- Add Dep to the semantic dependecies of Unit, -- if it is not already present. If Use_It is true, -- a "use" clause will be added for that unit. -- Additionnally, an elaboration control pragma may -- be inserted according to Elab_Control. procedure Add_Elaborate_Body (Unit : in out Compilation_Unit); -- Add a pragma Elaborate_Body to the spec denoted by Unit. procedure Suppress_Warning_Message (Unit : in out Compilation_Unit); -- Remove warning such as "Do not modify this file". Used for -- implementations. function New_Package (Name : String; Kind : Unit_Kind) return Compilation_Unit; -- Prepare to generate a new compilation unit. procedure Generate (Unit : Compilation_Unit; Is_Generic_Instanciation : Boolean := False; To_Stdout : Boolean := False); -- Produce the source code for Unit. -- If Is_Generic_Instanciation, then Unit's Kind must -- be Unit_Spec, and Unit must be a library-level -- instanciation of a generic package. -- If To_Stdout, the code is emitted to standard output. ---------------------------------------------------------------- -- The following subprograms operate on the current diversion -- ---------------------------------------------------------------- procedure Set_Empty (Unit : in out Compilation_Unit); -- Set the Empty flag on the compilation unit. pragma Inline (Set_Empty); procedure Put (Unit : in out Compilation_Unit; Text : String); -- Append a text fragment to a compilation unit. procedure Put_Line (Unit : in out Compilation_Unit; Line : String); -- Append a whole line to a compilation unit. procedure New_Line (Unit : in out Compilation_Unit); -- Append a blank line to a compilation unit, or -- terminate an unfinished line. procedure Inc_Indent (Unit : in out Compilation_Unit); procedure Dec_Indent (Unit : in out Compilation_Unit); -- Increment or decrement the indentation level -- for the compilation unit. private type String_Ptr is access String; type Dependency_Node; type Dependency is access Dependency_Node; type Diversion_Data is record Library_Item : Unbounded_String; Empty : Boolean := True; Indent_Level : Positive := 1; At_BOL : Boolean := True; -- True if a line has just been ended, and the -- indentation space for the new line has not -- been written yet. end record; type Diversion_Set is array (Diversion) of aliased Diversion_Data; type Compilation_Unit is new Ada.Finalization.Controlled with record Library_Unit_Name : String_Ptr; Kind : Unit_Kind; Elaborate_Body : Boolean := False; No_Warning : Boolean := False; Context_Clause : Dependency := null; Current_Diversion : Diversion := Visible_Declarations; Diversions : Diversion_Set; end record; procedure Finalize (Object : in out Compilation_Unit); end CIAO.Ada_Source_Streams; polyorb-2.8~20110207.orig/compilers/ciao/ciao-options.ads0000644000175000017500000001043411750740337022417 0ustar xavierxavier---------------------------------------- -- -- -- ---- --- -- ---- -- -- - - - - - - -- -- - - ---- - - -- -- ---- --- - - ---- -- -- -- ---------------------------------------- -- CORBA -- -- Interface for -- -- Ada'95 distributed systems annex -- -- Objects -- ---------------------------------------- -- Copyright (c) 1999 -- -- École nationale supérieure des -- -- télécommunications -- ---------------------------------------- -- This package defines variables for storing CIAO options and parameters, -- as well as some internal parameters used by CIAO. with GNAT.OS_Lib; with CIAO.Types; use CIAO.Types; package CIAO.Options is Initialized : Boolean := False; -- set to True by Initialize, if initialization is successful ------------- -- Options -- ------------- Indent : constant Natural := 3; -- Indentation in the outputted source, is not set from command line. -- The default values are used as initialization expressions Verbose_Mode : Boolean := False; -- If this flag is set ON, gnatstub generates the message about itself, -- including ASIS/GNAT version with which it is built Quiet_Mode : Boolean := False; -- If this flag is set ON, gnatstub does not generate a confirmation -- in case when the samle body has successfully been created Overwrite_IDL : Boolean := False; -- Indicates whether an existing IDL source file should be overwritten. Overwrite_Tree : Boolean := False; -- Indicates whether an existing tree file should be overwritten. Reuse_Tree : Boolean := False; -- Indicates whether an existing tree should be reused Delete_Tree : Boolean := False; -- When CIAO creates a tree file itself, indicates whether that -- file should be removed after use. Expand : Boolean := True; -- Indicates whether IDL tree expansion must be performed. Disp_Tree : Boolean := False; -- Indicates whether a textual IDL tree debug dump must be -- performed. Generate : Boolean := True; -- Indicates whether stub code generation must be performed. Indent_Level : Positive := 3; Min_Indent_Level : constant Positive := 1; Max_Indent_Level : constant Positive := 9; -- identation level ------------------------------ -- File and Directory names -- ------------------------------ File_Name : String_Ptr; -- The name of file that contains processed unit. This is the only one -- obligatory parameter. Only one unit name may be given. The name -- should be the name of the sourve file, it has to follow the GNAT -- file name conventions (in particular, it has to have .ads suffix). -- the file name may or may not contain the path information. Short_File_Name : String_Ptr; -- File name without directory information Tree_Name : String_Ptr; -- we need it in more, then one routine, so we define it here IDL_Name : String_Ptr; Marshall_Spec_Name : String_Ptr; Marshall_Body_Name : String_Ptr; Impl_Spec_Name : String_Ptr; Impl_Body_Name : String_Ptr; Destination_Dir : String_Ptr; -- directory to put the sampler body in Arg_List : GNAT.OS_Lib.Argument_List_Access; -- -I options from the Gnatstub command line transformed into the -- form appropriate for calling gcc to create the tree file I_Options : String_Ptr := new String'(""); I_Options_Tmp : String_Ptr := new String'(""); -- these two variables are needed to accomulate the '-I' options -- during the command line processing ---------------------- -- Status variables -- ---------------------- Tree_Exists : Boolean := False; -- if the tree file has been created or has been found as existing -- during the initialization Dir_Count : Natural := 0; -- the number of '-I' options in command line File_Name_Len : Natural; File_Name_First : Natural; File_Name_Last : Natural; Short_File_Name_Len : Natural; Short_File_Name_First : Natural; Short_File_Name_Last : Natural; -- To simplify dealing with the spec file name end CIAO.Options; polyorb-2.8~20110207.orig/compilers/ciao/ciao-translator-maps.ads0000644000175000017500000000532211750740337024053 0ustar xavierxavier---------------------------------------- -- -- -- ---- --- -- ---- -- -- - - - - - - -- -- - - ---- - - -- -- ---- --- - - ---- -- -- -- ---------------------------------------- -- CORBA -- -- Interface for -- -- Ada'95 distributed systems annex -- -- Objects -- ---------------------------------------- -- Copyright (c) 1999 -- -- École nationale supérieure des -- -- télécommunications -- ---------------------------------------- -- Various mapping functions for CIAO.Translator. with Asis; use Asis; with Errors; with Idl_Fe.Types; use Idl_Fe.Types; package CIAO.Translator.Maps is -- ------------------------------------------- -- -- IDL_Module_Name -- -- -- The name of the IDL module that maps -- -- -- the given library unit. -- -- ------------------------------------------- -- function IDL_Module_Name (Library_Unit : Compilation_Unit) -- return String; -------------------------------------------------------- -- Map_Loc -- -- Map a source code location from ASIS location info -- -- to Errors.Location. -- -------------------------------------------------------- function Map_Loc (Element : Asis.Element) return Errors.Location; ---------------------------------------------- -- Operator_Symbol_Identifier -- -- Return an from the image of -- -- a defining operator symbol. -- ---------------------------------------------- function Operator_Symbol_Identifier (Op : Asis.Defining_Name) return String; ---------------------------------------------- -- Character_Literal_Identifier -- -- Return an from the image of -- -- a defining character literal. -- ---------------------------------------------- function Character_Literal_Identifier (Ch : Program_Text) return String; --------------------------------------------------- -- Base_Type -- -- Return the base type kind that represents the -- -- given class of Ada types. -- --------------------------------------------------- type Root_Type is (Root_Integer, Root_Modular, Root_Real, Root_Boolean, Root_Char, Root_String); function Base_Type (T : Root_Type) return Node_Id; pragma Inline (Base_Type); end CIAO.Translator.Maps; polyorb-2.8~20110207.orig/compilers/ciao/ciao_runtime-convert.ads0000644000175000017500000000424011750740337024145 0ustar xavierxavier---------------------------------------- -- -- -- ---- --- -- ---- -- -- - - - - - - -- -- - - ---- - - -- -- ---- --- - - ---- -- -- -- ---------------------------------------- -- CORBA -- -- Interface for -- -- Ada'95 distributed systems annex -- -- Objects -- ---------------------------------------- -- Copyright (c) 1999 -- -- École nationale supérieure des -- -- télécommunications -- ---------------------------------------- -- The CIAO run-time library. with CORBA; package CIAO_Runtime.Convert is function To_Ada (Val : CORBA.Boolean) return Boolean; function To_Ada (Val : CORBA.Short) return Integer; function To_Ada (Val : CORBA.Long) return Integer; function To_Ada (Val : CORBA.Unsigned_Short) return Integer; function To_Ada (Val : CORBA.Unsigned_Long) return Integer; function To_Ada (Val : CORBA.Float) return Float; function To_Ada (Val : CORBA.Double) return Float; function To_Ada (Val : CORBA.Char) return Character; -- function To_Ada (Val : CORBA.Octet) return ; function To_Ada (Val : CORBA.String) return String; pragma Inline (To_Ada); function To_CORBA (Val : Boolean) return CORBA.Boolean; function To_CORBA (Val : Integer) return CORBA.Short; function To_CORBA (Val : Integer) return CORBA.Long; function To_CORBA (Val : Integer) return CORBA.Unsigned_Short; function To_CORBA (Val : Integer) return CORBA.Unsigned_Long; function To_CORBA (Val : Float) return CORBA.Float; function To_CORBA (Val : Float) return CORBA.Double; function To_CORBA (Val : Character) return CORBA.Char; function To_CORBA (Val : String) return CORBA.String; pragma Inline (To_CORBA); end CIAO_Runtime.Convert; polyorb-2.8~20110207.orig/compilers/ciao/ciao-driver.adb0000644000175000017500000004633511750740337022207 0ustar xavierxavier---------------------------------------- -- -- -- ---- --- -- ---- -- -- - - - - - - -- -- - - ---- - - -- -- ---- --- - - ---- -- -- -- ---------------------------------------- -- CORBA -- -- Interface for -- -- Ada'95 distributed systems annex -- -- Objects -- ---------------------------------------- -- Copyright (c) 1999 -- -- École nationale supérieure des -- -- télécommunications -- ---------------------------------------- -- Main subprogram for the CIAO generation tool. -- Some code is taken from display-source, gnatstub and gnatelim. with Ada.Command_Line; use Ada.Command_Line; with Ada.Exceptions; use Ada.Exceptions; with Ada.Characters.Handling; use Ada.Characters.Handling; with Ada.Text_IO; with Ada.Unchecked_Deallocation; with Ada.Wide_Text_IO; use Ada.Wide_Text_IO; with Asis; with Asis.Exceptions; with Asis.Errors; with Asis.Implementation; with Asis.Ada_Environments; with Asis.Compilation_Units; with GNAT.Command_Line; use GNAT.Command_Line; with GNAT.OS_Lib; use GNAT.OS_Lib; with CIAO.Filenames; use CIAO.Filenames; with CIAO.Options; use CIAO.Options; with CIAO.Translator; use CIAO.Translator; with CIAO.Types; use CIAO.Types; with Idl_Fe.Types; use Idl_Fe.Types; with Idl_Fe.Display_Tree; with Ada_Be.Expansion; with Ada_Be.Idl2Ada; with Ada_Be.Mappings.DSA; procedure CIAO.Driver is -- package Proxy_Generator is new CIAO.Generator.Proxy -- (CIAO.Generator.Broca.ORB_Deps); Parameter_Error : exception; IDL_File : Ada.Text_IO.File_Type; Tree_File : Ada.Text_IO.File_Type; -- Spec_File : Ada.Text_IO.File_Type; Form : String := ""; CIAO_Context : Asis.Context; ------------------------- -- Local subprograms -- ------------------------- procedure Clean; -- Does the ASIS finalization steps (Close->Dissociate->Finalize) -- and possibly delete the tree file. Called on all exits, -- erroneous or not. procedure Put_CIAO_Version; -- Displays the version information for CIAO and -- the underlying ASIS implementation. procedure Brief_Help; -- Displays a help message describing the command line -- options. procedure Initialize; -- Scan command line arguments and set up the -- context for the translation. procedure Make_Unit_Name (CU_Name : in out String); -- Change a GNAT source file name to an Ada -- compilation unit name by replacing all '-'s to '.'s. procedure Check_Parameters; -- Checks that command-line options and files existing in the file -- system fit each other. If the check fails, generates the diagnostic -- message and raises Parameter_Error procedure Free is new Ada.Unchecked_Deallocation (String, String_Ptr); ------------- -- Clean -- ------------- procedure Clean is begin if Asis.Ada_Environments.Is_Open (CIAO_Context) then Asis.Ada_Environments.Close (CIAO_Context); end if; Asis.Ada_Environments.Dissociate (CIAO_Context); Asis.Implementation.Finalize; if Delete_Tree and then Tree_Exists then Ada.Text_IO.Open (Tree_File, Ada.Text_IO.In_File, Tree_Name.all, Form); Ada.Text_IO.Delete (Tree_File); end if; -- CIAO.IDL_Tree.Finalize; -- CIAO.Namet.Finalize; -- CIAO.Nlists.Finalize; end Clean; ---------------------- -- Put_CIAO_Version -- ---------------------- procedure Put_CIAO_Version is begin Put_Line ("CIAO version " & CIAO.Version); Put_Line (CIAO.Copyright); New_Line; Put_Line (Asis.Implementation.ASIS_Version & " by " & Asis.Implementation.ASIS_Implementor & ":"); Put_Line (Asis.Implementation.ASIS_Implementor_Version); end Put_CIAO_Version; ---------------- -- Brief_Help -- ---------------- procedure Brief_Help is begin Put_Line ("Usage: ciao [opts] filename [directory]"); New_Line; Put_Line (" filename source file"); Put (" directory directory to place a sample body"); Put_Line (" (default is the current directory)"); New_Line; Put_Line ("CIAO options:"); New_Line; Put_Line (" -d display constructed IDL tree"); Put_Line (" -e display expanded IDL tree"); Put_Line (" -f replace existing generated IDL file"); Put_Line (" -t overwrite the existing tree file"); Put_Line (" -r reuse existing tree file"); Put_Line (" -k do not delete tree file"); Put_Line (" (-r also implies -k)"); Put_Line (" -Idir source search dir, has the same meaning as for " & "gcc and gnatmake"); Put_Line (" -I- do not look for the sources in the default " & "directory"); Put_Line (" -in (n in 1 .. 9) number of spaces used for identation " & "in a generated file"); Put_Line (" -q quiet mode - do not confirm creating a body"); Put_Line (" -v verbose mode - output the version information"); end Brief_Help; ---------------- -- Initialize -- ---------------- procedure Initialize is use GNAT.Command_Line; Switch_Parameter : Natural; function Get_Switch_Parameter (Val : String) return Natural; -- computes a natural parameter for switch from its string -- representation. Raises Parameter_Error if Val can not be considered -- as a string image of a natural number. This function supposes that -- Val is not an empty string. function Get_Switch_Parameter (Val : String) return Natural is Result : Natural := 0; begin for I in Val'Range loop if Val (I) not in '0' .. '9' then Ada.Text_IO.Put_Line ("CIAO: wrong switch integer parameter " & Val); raise Parameter_Error; else Result := Result * 10 + Character'Pos (Val (I)) - Character'Pos ('0'); end if; end loop; return Result; end Get_Switch_Parameter; begin if Argument_Count = 0 then Brief_Help; -- Initialized remains False here! else -- First scan command line parameters Command_Line : loop case Getopt ("d e f I: i: k l: q r t v") is when ASCII.NUL => exit Command_Line; when 'd' => Disp_Tree := True; Expand := False; Generate := False; when 'e' => Disp_Tree := True; Expand := True; Generate := False; when 'f' => Overwrite_IDL := True; when 'I' => Free (I_Options_Tmp); I_Options_Tmp := new String'(I_Options.all & " " & Parameter); Free (I_Options); I_Options := new String'(I_Options_Tmp.all); Dir_Count := Dir_Count + 1; when 'i' => Switch_Parameter := Get_Switch_Parameter (Parameter); if Switch_Parameter < Min_Indent_Level then Ada.Text_IO.Put ("CIAO: identation level is too small ("); Ada.Text_IO.Put (Parameter); Ada.Text_IO.Put_Line (")"); raise Parameter_Error; elsif Switch_Parameter > Max_Indent_Level then Ada.Text_IO.Put ("CIAO: identation level is too large ("); Ada.Text_IO.Put (Parameter); Ada.Text_IO.Put_Line (")"); raise Parameter_Error; else Indent_Level := Switch_Parameter; end if; when 'k' => Delete_Tree := False; when 'q' => Quiet_Mode := True; when 'r' => Reuse_Tree := True; when 't' => Overwrite_Tree := True; when 'v' => Verbose_Mode := True; when others => Ada.Text_IO.Put_Line ("CIAO: unknown option " & Parameter); raise Parameter_Error; end case; end loop Command_Line; declare S : constant String := Get_Argument (Do_Expansion => True); begin if S'Length > 0 then File_Name := new String'(S); end if; end; -- then, checking, that parameters are valid and that they -- corresponds to the situation in the file system Check_Parameters; -- Open output files Ada.Text_IO.Create (IDL_File, Ada.Text_IO.Out_File, IDL_Name.all, Form); Initialized := True; end if; exception when Parameter_Error => Initialized := False; -- nothing else to do! when others => Initialized := False; raise; end Initialize; -------------------- -- Make_Unit_Name -- -------------------- procedure Make_Unit_Name (CU_Name : in out String) is begin for I in CU_Name'Range loop if CU_Name (I) = '-' then CU_Name (I) := '.'; end if; end loop; end Make_Unit_Name; ---------------------- -- Check_Parameters -- ---------------------- procedure Check_Parameters is Ind : Integer; I_Len : Natural; Next_Dir_Start : Natural := 2; Next_Dir_End : Natural := 2; -- "2 is because of the leading ' ' " begin -- First, check if the source file is set if File_Name = null then Brief_Help; raise Parameter_Error; end if; -- Then, checking if the argument file follows the GNAT file name -- conventions: File_Name_Len := File_Name'Length; File_Name_First := File_Name'First; File_Name_Last := File_Name'Last; if not (File_Name_Len >= 5 and then File_Name (File_Name_Last - 3 .. File_Name_Last) = ".ads") then Ada.Text_IO.Put_Line ("CIAO: " & File_Name.all & " is not a name of a spec file"); raise Parameter_Error; end if; -- checking if the file to process really exists: if not Is_Regular_File (File_Name.all) then Ada.Text_IO.Put_Line ("CIAO: cannot find " & File_Name.all); raise Parameter_Error; end if; -- if destination is set, check if the destination directory exists: if Destination_Dir /= null then if not Is_Directory (Destination_Dir.all) then Ada.Text_IO.Put_Line ("CIAO: " & Destination_Dir.all & " does not exist"); raise Parameter_Error; end if; end if; -- and now, we have to compute some names before continuing checking: Ind := File_Name_First; File_Name_Scan : for I in reverse File_Name_First .. File_Name_Last loop if File_Name (I) = Directory_Separator then Ind := I + 1; exit File_Name_Scan; end if; end loop File_Name_Scan; Short_File_Name := new String'(File_Name (Ind .. File_Name_Last)); Short_File_Name_Len := Short_File_Name'Length; Short_File_Name_First := Short_File_Name'First; Short_File_Name_Last := Short_File_Name'Last; if Destination_Dir = null then IDL_Name := new String'(IDL_File_Name (Short_File_Name.all)); else IDL_Name := new String' (Destination_Dir.all & Directory_Separator & IDL_File_Name (Short_File_Name.all)); end if; if Generate then Expand := True; end if; if Generate and then Is_Regular_File (IDL_Name.all) then if Overwrite_IDL then Ada.Text_IO.Open (IDL_File, Ada.Text_IO.Out_File, IDL_Name.all, Form); Ada.Text_IO.Delete (IDL_File); else Ada.Text_IO.Put_Line ("CIAO: the body for " & File_Name.all & " already exists"); Ada.Text_IO.Put_Line (" use -f to overwrite it"); raise Parameter_Error; end if; end if; -- now, checking the situation with the tree file: Tree_Name := new String'(Short_File_Name.all); Tree_Name (Tree_Name'Last) := 't'; if Is_Regular_File (Tree_Name.all) then Tree_Exists := True; if not (Reuse_Tree or else Overwrite_Tree) then Ada.Text_IO.Put_Line ("CIAO: " & Tree_Name.all & " already exists"); Ada.Text_IO.Put_Line (" use -r or -t to reuse or to overwrite it"); raise Parameter_Error; end if; else if Reuse_Tree then Ada.Text_IO.Put_Line ("CIAO: cannot find " & Tree_Name.all & " (-r is set)"); raise Parameter_Error; end if; end if; if Reuse_Tree then Delete_Tree := False; Overwrite_Tree := False; end if; -- now, converting '-I' options from a string into argument list if Dir_Count = 0 then Arg_List := new Argument_List (1 .. 0); else Arg_List := new Argument_List (1 .. Dir_Count); I_Len := I_Options'Length; for I in 1 .. Dir_Count loop while (Next_Dir_End <= I_Len and then I_Options (Next_Dir_End) /= ' ') loop Next_Dir_End := Next_Dir_End + 1; end loop; Next_Dir_End := Next_Dir_End - 1; Arg_List (I) := new String' (I_Options (Next_Dir_Start .. Next_Dir_End)); Next_Dir_Start := Next_Dir_End + 2; Next_Dir_End := Next_Dir_Start; end loop; end if; -- Cleaning up - freeing what we will not need any more Free (Destination_Dir); Free (I_Options); Free (I_Options_Tmp); end Check_Parameters; --------------------- -- Local variables -- --------------------- Library_Unit : Asis.Compilation_Unit; IDL_Tree : Idl_Fe.Types.Node_Id := No_Node; begin -- CIAO.Driver's body. -- CIAO initializations -- CIAO.Namet.Initialize; -- CIAO.Nlists.Initialize; -- CIAO.IDL_Tree.Initialize; Initialize; if not Initialized then -- Cannot do much... return; end if; -- ASIS Initialization Asis.Implementation.Initialize; declare Param : String_Ptr; begin if Overwrite_Tree then Param := new String'("-CA -FS"); elsif Reuse_Tree then Param := new String'("-C1 " & Tree_Name.all); else Param := new String'("-CA -FM"); end if; Asis.Ada_Environments.Associate (The_Context => CIAO_Context, Name => "CIAO_Context", Parameters => To_Wide_String (Param.all)); Free (Param); end; Asis.Ada_Environments.Open (CIAO_Context); declare Library_Unit_Name_Len : Positive := Short_File_Name_Len - 4; -- "- 4" stands for ".ads" Library_Unit_Name : String (1 .. Library_Unit_Name_Len) := Short_File_Name.all (Short_File_Name_First .. Short_File_Name_Last - 4); begin -- Open requested library unit. Make_Unit_Name (Library_Unit_Name); Library_Unit := Asis.Compilation_Units.Library_Unit_Declaration (To_Wide_String (Library_Unit_Name), CIAO_Context); end; if Asis.Compilation_Units.Is_Nil (Library_Unit) then -- this may be the case if the file name was krunched. -- This is the case for the GNAT RTL components. -- In this case we have to iterate through the context declare C_Units : Asis.Compilation_Unit_List := Asis.Compilation_Units.Compilation_Units (CIAO_Context); begin -- to be 100% honest, we should go through C_Units list and -- to compare the result of Asis.Compilation_Units.Text_Name -- applied to a unit with File_Name. But here we use the -- fact that in every tree a unit for which the tree is -- created is always processed first when ASIS opens a -- Context, and in gnatstub we have C1 context. So -- the needed unit is the second in the list (just after Standard) -- In CIAO we have C1 context only if Reuse_Tree. -- XXX for the other cases we should implement the -- behaviour described above. if Reuse_Tree and then C_Units'Length > 1 then Library_Unit := C_Units (2); end if; end; end if; Translate (Library_Unit, IDL_Tree); -- Translate service specification to IDL syntax tree. -- IDL.Generate (IDL_Tree, IDL_File); -- -- Produce IDL_Source_File. -- Proxy_Generator.Generate (IDL_Tree); -- -- Generate proxy packages. if Expand then Ada_Be.Expansion.Expand_Repository (IDL_Tree); pragma Assert (not Standard.Errors.Is_Error); end if; if Disp_Tree then Idl_Fe.Display_Tree.Disp_Tree (IDL_Tree); end if; if Generate then Ada_Be.Idl2Ada.Generate (Use_Mapping => Ada_Be.Mappings.DSA.The_DSA_Mapping, Node => IDL_Tree, Implement => False, To_Stdout => True); end if; Clean; exception when Ex : Asis.Exceptions.ASIS_Inappropriate_Context | Asis.Exceptions.ASIS_Inappropriate_Container | Asis.Exceptions.ASIS_Inappropriate_Compilation_Unit | Asis.Exceptions.ASIS_Inappropriate_Element | Asis.Exceptions.ASIS_Inappropriate_Line | Asis.Exceptions.ASIS_Inappropriate_Line_Number | Asis.Exceptions.ASIS_Failed => Set_Output (Standard_Error); New_Line; Put ("Unexpected bug in "); Put_CIAO_Version; New_Line; Put (To_Wide_String (Exception_Name (Ex))); Put_Line (" raised"); Put ("CIAO: ASIS Diagnosis is " & Asis.Implementation.Diagnosis); New_Line; Put ("CIAO: Status Value is "); Put_Line (Asis.Errors.Error_Kinds'Wide_Image (Asis.Implementation.Status)); New_Line; Put_Line ("Please report to ciao-report@adabroker.eu.org."); -- Exit cleanly. Set_Output (Standard_Output); Set_Exit_Status (Failure); Clean; when CIAO.Translator.Translation_Error => Clean; when Ex : others => Set_Output (Standard_Error); New_Line; Put ("Unexpected exception in "); Put_CIAO_Version; New_Line; Put (To_Wide_String (Exception_Name (Ex))); Put (" was raised: "); if Exception_Information (Ex)'Length = 0 then Put_Line ("(no exception message)"); else Put_Line (To_Wide_String (Exception_Information (Ex))); end if; -- Exit cleanly. Set_Output (Standard_Output); Set_Exit_Status (Failure); Clean; end CIAO.Driver; polyorb-2.8~20110207.orig/compilers/ciao/ciao_runtime.ads0000644000175000017500000000144211750740337022470 0ustar xavierxavier---------------------------------------- -- -- -- ---- --- -- ---- -- -- - - - - - - -- -- - - ---- - - -- -- ---- --- - - ---- -- -- -- ---------------------------------------- -- CORBA -- -- Interface for -- -- Ada'95 distributed systems annex -- -- Objects -- ---------------------------------------- -- Copyright (c) 1999 -- -- École nationale supérieure des -- -- télécommunications -- ---------------------------------------- -- The CIAO run-time library. package CIAO_Runtime is pragma Pure (CIAO_Runtime); end CIAO_Runtime; polyorb-2.8~20110207.orig/compilers/gnatdist/0000755000175000017500000000000011750740340020214 5ustar xavierxavierpolyorb-2.8~20110207.orig/compilers/gnatdist/xe_usage.adb0000644000175000017500000001060311750740337022472 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- X E _ U S A G E -- -- -- -- B o d y -- -- -- -- Copyright (C) 1995-2009, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with XE_IO; use XE_IO; with XE_Defs.Defaults; with XE_Flags; use XE_Flags; procedure XE_Usage is begin if Verbose_Mode then Write_Str ("GNATDIST "); Write_Str (XE_Defs.Defaults.Version); Write_Eol; Write_Str ("Copyright 1996-2008, Free Software Foundation, Inc."); Write_Eol; Write_Eol; end if; Write_Str ("Usage: "); Write_Program_Name; Write_Str (" [options] name[.cfg] {[partition]}"); Write_Str (" {[-cargs opts] [-bargs opts] [-largs opts]}"); Write_Eol; Write_Eol; Write_Str (" name is a configuration file name from which you can"); Write_Str (" omit the .cfg suffix"); Write_Eol; Write_Eol; Write_Str ("gnatdist switches:"); Write_Eol; Write_Str (" -a Consider all files, even readonly ali files"); Write_Eol; Write_Str (" -f Force recompilations"); Write_Eol; Write_Str (" -k Keep going after compilation errors"); Write_Eol; Write_Str (" -q Be quiet, do not display partitioning operations"); Write_Eol; Write_Str (" -v Motivate all executed commands"); Write_Eol; Write_Str (" -t Keep all temporary files"); Write_Eol; Write_Str (" --PCS=... " & "Select PCS variant (default: " & XE_Defs.Defaults.Default_PCS_Name & ")"); Write_Eol; Write_Eol; Write_Str ("Other switches are passed directly to gnatmake"); Write_Eol; Write_Eol; Write_Str ("Source & Library search path switches:"); Write_Eol; Write_Str (" -aLdir Skip missing library sources if ali in dir"); Write_Eol; Write_Str (" -aOdir Specify library/object files search path"); Write_Eol; Write_Str (" -aIdir Specify source files search path"); Write_Eol; Write_Str (" -Idir Like -aIdir -aOdir"); Write_Eol; Write_Str (" -I- Don't look for sources & library files"); Write_Str (" in the default directory"); Write_Eol; Write_Str (" -Ldir Look for program libraries also in dir"); Write_Eol; Write_Eol; Write_Str ("To pass an arbitrary switch to the Compiler, "); Write_Str ("Binder or Linker:"); Write_Eol; Write_Str (" -cargs opts opts are passed to the compiler"); Write_Eol; Write_Str (" -bargs opts opts are passed to the binder"); Write_Eol; Write_Str (" -largs opts opts are passed to the linker"); Write_Eol; end XE_Usage; polyorb-2.8~20110207.orig/compilers/gnatdist/xe_utils.adb0000644000175000017500000010150411750740337022527 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- X E _ U T I L S -- -- -- -- B o d y -- -- -- -- Copyright (C) 1995-2009, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with Ada.Characters.Handling; use Ada.Characters.Handling; with Ada.Command_Line; use Ada.Command_Line; with GNAT.Directory_Operations; use GNAT.Directory_Operations; with XE_Defs; use XE_Defs; with XE_Flags; use XE_Flags; with XE_IO; use XE_IO; with XE_Names; use XE_Names; package body XE_Utils is type Name_Array is array (Natural range <>) of Name_Id; type Name_Array_Ptr is access Name_Array; Main_Sources : Name_Array_Ptr; Current_Main_Source : Natural := 1; Last_Main_Source : Natural := 0; type Make_Program_Type is (None, Compiler, Binder, Linker); Program_Args : Make_Program_Type := None; -- Used to indicate if we are scanning gnatmake, gcc, gnatbind, or -- gnatbind options within the gnatmake command line. procedure Ensure_Make_Args; -- Reset Program_Args to None, adding "-margs" to make switches if needed Project_File_Name_Expected : Boolean := False; -- Used to keep state between invocations of Scan_Dist_Arg. True when -- previous argument was "-P". function Dup (Fd : File_Descriptor) return File_Descriptor; pragma Import (C, Dup); procedure Dup2 (Old_Fd, New_Fd : File_Descriptor); pragma Import (C, Dup2); GNAT_Driver : String_Access; GPRBuild : String_Access; List_Command : constant String_Access := new String'("list"); Build_Command : constant String_Access := new String'("make"); Compile_Command : constant String_Access := new String'("compile"); function Locate (Exec_Name : String; Show_Error : Boolean := True) return String_Access; -- look for Exec_Name on the path. If Exec_Name is found then the full -- pathname for Exec_Name is returned. If Exec_Name is not found and -- Show_Error is set to False then null is returned. If Exec_Name is not -- found and Show_Error is set to True then Fatal_Error is raised. procedure Add_Make_Switch (Argv : String_Access); procedure Add_Make_Switch (Argv : String); procedure Add_List_Switch (Argv : String); procedure Add_Main_Source (Source : String); procedure Add_Source_Directory (Argv : String); procedure Fail (S1 : String; S2 : String := No_Str; S3 : String := No_Str); type Sigint_Handler is access procedure; pragma Convention (C, Sigint_Handler); procedure Install_Int_Handler (Handler : Sigint_Handler); pragma Import (C, Install_Int_Handler, "__gnat_install_int_handler"); -- Called by Gnatmake to install the SIGINT handler below procedure Sigint_Intercepted; pragma Convention (C, Sigint_Intercepted); -- Called when the program is interrupted by Ctrl-C to delete the -- temporary mapping files and configuration pragmas files. procedure Check_User_Provided_S_RPC (Dir : String); -- Check whether the given directory contains a user-provided version of -- s-rpc.adb, and if so set the global flag User_Provided_S_RPC to True. --------- -- "&" -- --------- function "&" (L : File_Name_Type; R : File_Name_Type) return File_Name_Type is begin Name_Len := 0; if Present (L) then Get_Name_String_And_Append (L); end if; if Present (R) then Get_Name_String_And_Append (R); end if; return Name_Find; end "&"; --------- -- "&" -- --------- function "&" (L : File_Name_Type; R : String) return File_Name_Type is begin Name_Len := 0; if Present (L) then Get_Name_String_And_Append (L); end if; Add_Str_To_Name_Buffer (R); return Name_Find; end "&"; --------------------- -- Add_List_Switch -- --------------------- procedure Add_List_Switch (Argv : String) is begin List_Switches.Append (new String'(Argv)); end Add_List_Switch; --------------------- -- Add_Main_Source -- --------------------- procedure Add_Main_Source (Source : String) is begin if Main_Sources = null then Main_Sources := new Name_Array (1 .. Argument_Count); end if; Name_Len := 0; Add_Str_To_Name_Buffer (Source); Last_Main_Source := Last_Main_Source + 1; Main_Sources (Last_Main_Source) := Name_Find; end Add_Main_Source; --------------------- -- Add_Make_Switch -- --------------------- procedure Add_Make_Switch (Argv : String_Access) is begin Make_Switches.Append (Argv); end Add_Make_Switch; --------------------- -- Add_Make_Switch -- --------------------- procedure Add_Make_Switch (Argv : String) is begin Make_Switches.Append (new String'(Argv)); end Add_Make_Switch; -------------------------- -- Add_Source_Directory -- -------------------------- procedure Add_Source_Directory (Argv : String) is begin Check_User_Provided_S_RPC (Argv); Source_Directories.Append (new String'(Argv)); end Add_Source_Directory; ----------- -- Build -- ----------- procedure Build (Library : File_Name_Type; Arguments : Argument_List; Fatal : Boolean := True; Progress : Boolean := False) is Length : constant Positive := Arguments'Length + 5 + Make_Switches.Last - Make_Switches.First; Flags : Argument_List (1 .. Length); N_Flags : Natural := 0; Library_Name_Flag : Natural; Success : Boolean; Has_Prj : Boolean := False; Index : Natural; Builder : String_Access; begin if Use_GPRBuild then Builder := GPRBuild; else Builder := GNAT_Driver; -- gnat make N_Flags := N_Flags + 1; Flags (N_Flags) := Build_Command; end if; if Quiet_Mode then -- Pass -q to gnatmake N_Flags := N_Flags + 1; Flags (N_Flags) := Quiet_Flag; elsif Verbose_Mode then -- Pass -v to gnatmake N_Flags := N_Flags + 1; Flags (N_Flags) := Verbose_Flag; end if; if Progress then -- Pass -d to gnatmake N_Flags := N_Flags + 1; Flags (N_Flags) := Progress_Flag; end if; -- Library file name (free'd at exit of Compile, must record position -- in Flags array). N_Flags := N_Flags + 1; Get_Name_String (Library); Flags (N_Flags) := new String'(Name_Buffer (1 .. Name_Len)); Library_Name_Flag := N_Flags; for I in Arguments'Range loop N_Flags := N_Flags + 1; Flags (N_Flags) := Arguments (I); -- Detect any project file if Arguments (I).all = Project_File_Flag.all then Has_Prj := True; end if; end loop; Index := Make_Switches.First; while Index <= Make_Switches.Last loop -- If there is a project file among the arguments then any -- project file from the Make switches is ignored. if Has_Prj and then Make_Switches.Table (Index).all = Project_File_Flag.all then Index := Index + 1; else N_Flags := N_Flags + 1; Flags (N_Flags) := Make_Switches.Table (Index); end if; Index := Index + 1; end loop; -- Call gnat make Execute (Builder, Flags (1 .. N_Flags), Success); -- Free library file name argument Free (Flags (Library_Name_Flag)); if not Success and then Fatal then raise Compilation_Error; end if; end Build; ---------------- -- Capitalize -- ---------------- function Capitalize (N : Name_Id) return Name_Id is begin Get_Name_String (N); Capitalize (Name_Buffer (1 .. Name_Len)); return Name_Find; end Capitalize; ---------------- -- Capitalize -- ---------------- function Capitalize (S : String) return String is R : String := S; begin Capitalize (R); return R; end Capitalize; ---------------- -- Capitalize -- ---------------- procedure Capitalize (S : in out String) is Capitalized : Boolean := True; begin for J in S'Range loop if S (J) in 'a' .. 'z' then if Capitalized then S (J) := To_Upper (S (J)); end if; Capitalized := False; elsif S (J) in 'A' .. 'Z' then if not Capitalized then S (J) := To_Lower (S (J)); end if; Capitalized := False; elsif S (J) = '_' or else S (J) = '.' then Capitalized := True; end if; end loop; end Capitalize; ------------------------------- -- Check_User_Provided_S_RPC -- ------------------------------- procedure Check_User_Provided_S_RPC (Dir : String) is begin -- Special kludge: if the user provides his own version of s-rpc, the -- PCS should not provide it. if Is_Readable_File (Dir & Dir_Separator & "s-rpc.adb") then XE_Flags.User_Provided_S_RPC := True; end if; end Check_User_Provided_S_RPC; ------------- -- Compile -- ------------- procedure Compile (Source : File_Name_Type; Arguments : Argument_List; Fatal : Boolean := True) is Length : constant Natural := Arguments'Length + 5 + Make_Switches.Last - Make_Switches.First; Flags : Argument_List (1 .. Length); N_Flags : Natural := 0; Success : Boolean; Has_Prj : Boolean := False; Index : Natural; begin -- gnat compile N_Flags := N_Flags + 1; Flags (N_Flags) := Compile_Command; -- Source file name (free'd at exit of Compile, must be at constant -- position in Flags array). N_Flags := N_Flags + 1; Get_Name_String (Source); Flags (N_Flags) := new String'(Normalize_Pathname (Name_Buffer (1 .. Name_Len))); -- Check whether we have a predefined unit Name_Len := 0; Add_Str_To_Name_Buffer (Strip_Directory (Flags (N_Flags).all)); if Name_Len > 2 and then Name_Buffer (2) = '-' and then (Name_Buffer (1) = 'a' or else Name_Buffer (1) = 'g' or else Name_Buffer (1) = 's') then N_Flags := N_Flags + 1; Flags (N_Flags) := Readonly_Flag; end if; if Quiet_Mode then -- Pass -q to gnatmake N_Flags := N_Flags + 1; Flags (N_Flags) := Quiet_Flag; elsif Verbose_Mode then -- Pass -v to gnatmake N_Flags := N_Flags + 1; Flags (N_Flags) := Verbose_Flag; end if; for I in Arguments'Range loop N_Flags := N_Flags + 1; Flags (N_Flags) := Arguments (I); -- Detect any project file if Arguments (I).all = Project_File_Flag.all then Has_Prj := True; end if; end loop; Index := Make_Switches.First; while Index <= Make_Switches.Last loop -- If there is a project file among the arguments then any -- project file from the Make switches is ignored. if Has_Prj and then Make_Switches.Table (Index).all = Project_File_Flag.all then Index := Index + 1; else N_Flags := N_Flags + 1; Flags (N_Flags) := Make_Switches.Table (Index); end if; Index := Index + 1; end loop; Execute (GNAT_Driver, Flags (1 .. N_Flags), Success); -- Free source file name argument Free (Flags (2)); if not Success and then Fatal then raise Compilation_Error; end if; end Compile; ---------------------- -- Ensure_Make_Args -- ---------------------- procedure Ensure_Make_Args is begin if Program_Args /= None then Add_Make_Switch (Make_Args_Flag); Program_Args := None; end if; end Ensure_Make_Args; ------------- -- Execute -- ------------- procedure Execute (Command : String_Access; Arguments : Argument_List; Success : out Boolean) is begin if not Quiet_Mode then Set_Standard_Error; Write_Str (Command.all); for J in Arguments'Range loop if Arguments (J) /= null then Write_Str (" "); Write_Str (Arguments (J).all); end if; end loop; Write_Eol; Set_Standard_Output; end if; Spawn (Command.all, Arguments, Success); end Execute; ------------------ -- Exit_Program -- ------------------ procedure Exit_Program (Code : Exit_Code_Type) is Status : Integer := 0; begin Remove_All_Temp_Files; if Code /= E_Success then Status := 1; end if; OS_Exit (Status); end Exit_Program; ---------- -- Fail -- ---------- procedure Fail (S1 : String; S2 : String := No_Str; S3 : String := No_Str) is begin Write_Program_Name; Write_Str (": "); Write_Str (S1); Write_Str (S2); Write_Str (S3); Write_Eol; raise Usage_Error; end Fail; -------- -- Id -- -------- function Id (S : String) return Name_Id is begin if S'Length = 0 then return No_Name; end if; Name_Buffer (1 .. S'Length) := S; Name_Len := S'Length; return Name_Find; end Id; ---------------- -- Initialize -- ---------------- procedure Initialize is begin XE_Names.Initialize; Set_Space_Increment (3); Cfg_Suffix_Id := Id (Cfg_Suffix); Obj_Suffix_Id := Id (Obj_Suffix); Exe_Suffix_Id := Id (Exe_Suffix); ALI_Suffix_Id := Id (ALI_Suffix); ADB_Suffix_Id := Id (ADB_Suffix); ADS_Suffix_Id := Id (ADS_Suffix); Part_Dir_Name := Dir (Id (Root), Id ("partitions")); Stub_Dir_Name := Dir (Id (Root), Id ("stubs")); Stub_Dir := new String'(Name_Buffer (1 .. Name_Len)); PWD_Id := Dir (Id ("`pwd`"), No_File_Name); I_Current_Dir := new String'("-I."); E_Current_Dir := new String'("-I-"); PCS_Project := Id ("pcs_project"); Set_Corresponding_Project_File_Name (PCS_Project_File); Part_Main_Src_Name := Id ("partition" & ADB_Suffix); Part_Main_ALI_Name := To_Afile (Part_Main_Src_Name); Part_Main_Obj_Name := To_Ofile (Part_Main_Src_Name); Part_Prj_File_Name := Id ("partition.gpr"); Overridden_PCS_Units := Id ("pcs_excluded.lst"); Name_Len := 2; Name_Buffer (1 .. 2) := "-A"; Get_Name_String_And_Append (Stub_Dir_Name); A_Stub_Dir := new String'(Name_Buffer (1 .. Name_Len)); for J in 1 .. Argument_Count loop Scan_Dist_Arg (Argument (J), Implicit => False); end loop; if Project_File_Name_Expected then Fail ("project file name missing after -P"); end if; if Check_Readonly_Files and then Project_File_Name = null then -- If the user asks for recompilation of files with read-only ALIs -- (in practice recompilation of the GNAT runtime), and no project -- has been provided, then assume that additional files to be -- recompiled won't be covered by the generated project, and pass -- extra flag to gnatmake to allow compiling them anyway. Ensure_Make_Args; Add_Make_Switch (External_Units_Flag); end if; XE_Defs.Initialize; Install_Int_Handler (Sigint_Intercepted'Access); Create_Dir (Stub_Dir_Name); Create_Dir (Part_Dir_Name); GNAT_Driver := Locate ("gnat"); -- Note: we initialize variable GPRBuild in Scan_Dist_Arg rather than -- unconditionally in Initialize so that the absence of gprbuild does -- not cause initialization to fail in the normal case where -dB is not -- used. Check_User_Provided_S_RPC ("."); end Initialize; ---------- -- List -- ---------- procedure List (Sources : File_Name_List; Arguments : Argument_List; Output : out File_Name_Type; Fatal : Boolean := True) is Length : constant Natural := Sources'Length + 4 + Arguments'Length + List_Switches.Last - List_Switches.First; Flags : Argument_List (1 .. Length); N_Flags : Natural := 0; File : GNAT.OS_Lib.File_Descriptor; Success : Boolean; Result : File_Name_Type := No_File_Name; Has_Prj : Boolean := False; Index : Natural; Predef : Boolean := False; Saved_Standout : File_Descriptor; begin -- gnat list N_Flags := N_Flags + 1; Flags (N_Flags) := List_Command; -- Source file names (free'd at exit of List, must be at constant -- position in Flags array). for J in Sources'Range loop N_Flags := N_Flags + 1; Get_Name_String (Sources (J)); Flags (N_Flags) := new String'(Name_Buffer (1 .. Name_Len)); Predef := Predef or else Is_Predefined_File (Sources (J)); end loop; if Predef then N_Flags := N_Flags + 1; Flags (N_Flags) := Readonly_Flag; end if; -- -q (because gnatmake is verbose instead of gcc) N_Flags := N_Flags + 1; Flags (N_Flags) := Quiet_Flag; for I in Arguments'Range loop N_Flags := N_Flags + 1; Flags (N_Flags) := Arguments (I); -- Detect any project file if Arguments (I).all = Project_File_Flag.all then Has_Prj := True; end if; end loop; Index := List_Switches.First; while Index <= List_Switches.Last loop -- If there is a project file among the arguments then any -- project file from the List switches is ignored. if Has_Prj and then List_Switches.Table (Index).all = Project_File_Flag.all then Index := Index + 1; else N_Flags := N_Flags + 1; Flags (N_Flags) := List_Switches.Table (Index); end if; Index := Index + 1; end loop; Register_Temp_File (File, Result); Saved_Standout := Dup (Standout); Dup2 (File, Standout); Execute (GNAT_Driver, Flags (1 .. N_Flags), Success); Dup2 (Saved_Standout, Standout); Close (Saved_Standout); if not Success then if Fatal then raise Program_Error; end if; Remove_Temp_File (Result); end if; -- Free source filename arguments N_Flags := 1; for J in Sources'Range loop N_Flags := N_Flags + 1; Free (Flags (N_Flags)); end loop; Output := Result; end List; ------------ -- Locate -- ------------ function Locate (Exec_Name : String; Show_Error : Boolean := True) return String_Access is Loc : String_Access; begin Name_Len := Exec_Name'Length; Name_Buffer (1 .. Name_Len) := Exec_Name; declare Exe : constant String := Name_Buffer (1 .. Name_Len); begin Loc := GNAT.OS_Lib.Locate_Exec_On_Path (Exe); if Loc = null and then Show_Error then raise Fatal_Error with Exe & " is not in your path"; end if; end; return Loc; end Locate; ----------------------- -- More_Source_Files -- ----------------------- function More_Source_Files return Boolean is begin return Current_Main_Source <= Last_Main_Source; end More_Source_Files; ---------- -- Name -- ---------- function Name (N : Name_Id) return Name_Id is begin Get_Name_String (N); if Name_Len > 1 and then Name_Buffer (Name_Len - 1) = '%' then Name_Len := Name_Len - 2; return Name_Find; end if; return N; end Name; ---------------------- -- Next_Main_Source -- ---------------------- function Next_Main_Source return Name_Id is Source : Name_Id := No_Name; begin if Current_Main_Source <= Last_Main_Source then Source := Main_Sources (Current_Main_Source); Current_Main_Source := Current_Main_Source + 1; end if; return Source; end Next_Main_Source; -------- -- No -- -------- function No (N : Name_Id) return Boolean is begin return N = No_Name; end No; --------------------- -- Number_Of_Files -- --------------------- function Number_Of_Files return Natural is begin return Last_Main_Source; end Number_Of_Files; ------------- -- Present -- ------------- function Present (N : Name_Id) return Boolean is begin return N /= No_Name; end Present; ----------- -- Quote -- ----------- function Quote (N : Name_Id) return Name_Id is begin Name_Len := 0; Add_Char_To_Name_Buffer ('"'); -- " if Present (N) then Get_Name_String_And_Append (N); end if; Add_Char_To_Name_Buffer ('"'); -- " return Name_Find; end Quote; ------------------- -- Scan_Dist_Arg -- ------------------- procedure Scan_Dist_Arg (Argv : String; Implicit : Boolean := True) is begin if Argv'Length = 0 then return; end if; if Argv = "-cargs" then Program_Args := Compiler; Add_Make_Switch (Comp_Args_Flag); return; elsif Argv = "-bargs" then Program_Args := Binder; Add_Make_Switch (Bind_Args_Flag); return; elsif Argv = "-largs" then Program_Args := Linker; Add_Make_Switch (Link_Args_Flag); return; elsif Argv = "-margs" then Program_Args := None; Add_Make_Switch (Make_Args_Flag); return; end if; case Program_Args is when Compiler | Binder | Linker => Add_Make_Switch (Argv); return; when others => null; end case; if Project_File_Name_Expected then Project_File_Name := new String'(Normalize_Pathname (Argv)); Project_File_Name_Expected := False; elsif Argv (Argv'First) = '-' then if Argv'Length = 1 then Fail ("switch character cannot be followed by a blank"); -- Processing for -I- elsif Argv = "-I-" then Add_List_Switch (Argv); Add_Make_Switch (Argv); -- Forbid -?- or -??- where ? is any character elsif Argv'Length in 3 .. 4 and then Argv (Argv'Last) = '-' then Fail ("Trailing ""-"" at the end of ", Argv, " forbidden."); -- Processing for -Adir, -Idir and -Ldir elsif Argv (Argv'First + 1) = 'A' or else Argv (Argv'First + 1) = 'I' or else Argv (Argv'First + 1) = 'L' then Add_List_Switch (Argv); Add_Make_Switch (Argv); if Argv (Argv'First + 1) = 'I' and then not Implicit then Add_Source_Directory (Argv (Argv'First + 2 .. Argv'Last)); end if; -- Processing for -aIdir, -aLdir, -aOdir, -aPdir elsif Argv'Length >= 3 and then Argv (Argv'First + 1) = 'a' and then (Argv (Argv'First + 2) = 'I' or else Argv (Argv'First + 2) = 'L' or else Argv (Argv'First + 2) = 'O' or else Argv (Argv'First + 2) = 'P') then Add_List_Switch (Argv); Add_Make_Switch (Argv); if Argv (Argv'First + 2) = 'I' and then not Implicit then Add_Source_Directory (Argv (Argv'First + 3 .. Argv'Last)); end if; elsif Argv (Argv'First + 1) = 'P' then if Project_File_Name_Expected or else Project_File_Name /= null then Fail ("cannot have several project files specified"); end if; if Argv'Length > 2 then Project_File_Name := new String'(Normalize_Pathname (Argv (Argv'First + 2 .. Argv'Last))); Add_List_Switch (Project_File_Flag.all); Add_List_Switch (Project_File_Name.all); Add_Make_Switch (Project_File_Flag.all); Add_Make_Switch (Project_File_Name.all); else Project_File_Name_Expected := True; Add_List_Switch (Project_File_Flag.all); Add_Make_Switch (Project_File_Flag.all); end if; elsif Argv (Argv'First + 1) = 'X' then Add_List_Switch (Argv); Add_Make_Switch (Argv); -- Debugging switches elsif Argv (Argv'First + 1) = 'd' then -- -d: debugging traces if Argv'Length = 2 then Display_Compilation_Progress := True; else case Argv (Argv'First + 2) is -- -dd: debug mode when 'd' => Debug_Mode := True; -- -df: output base names only in error messages (to ensure -- constant output for testsuites). when 'f' => Add_Make_Switch ("-df"); -- -dP: Force using project files to reference the PolyORB -- PCS even on non-Windows platforms. when 'P' => Use_PolyORB_Project := True; -- -dB: Use gprbuild (implies -dP) -- (for experimentation, not expected to work yet???) when 'B' => GPRBuild := Locate ("gprbuild"); Use_GPRBuild := True; Use_PolyORB_Project := True; when others => -- Pass other debugging flags to the builder untouched Add_Make_Switch (Argv); end case; end if; -- Processing for one character switches elsif Argv'Length = 2 then case Argv (Argv'First + 1) is when 'a' => Check_Readonly_Files := True; Add_List_Switch (Argv); Add_Make_Switch (Argv); when 'k' => Keep_Going := True; Add_Make_Switch (Argv); when 't' => Keep_Tmp_Files := True; Add_Make_Switch ("-dn"); when 'q' => Quiet_Mode := True; -- Switch is passed to gnatmake later on when 'v' => Verbose_Mode := True; -- Switch is passed to gnatmake later on when others => -- Pass unrecognized switches to gnatmake Add_Make_Switch (Argv); end case; -- Processing for --PCS= elsif Argv'Length > 6 and then Argv (Argv'First + 1 .. Argv'First + 5) = "-PCS=" then Set_PCS_Name (Argv (Argv'First + 6 .. Argv'Last)); -- Processing for --RTS= elsif Argv'Length > 6 and then Argv (Argv'First + 1 .. Argv'First + 5) = "-RTS=" then Add_Make_Switch (Argv); Add_List_Switch (Argv); else Add_Make_Switch (Argv); end if; else Add_Main_Source (Argv); end if; end Scan_Dist_Arg; -------------------- -- Scan_Dist_Args -- -------------------- procedure Scan_Dist_Args (Args : String) is Argv : Argument_List_Access := Argument_String_To_List (Args); begin -- We have already processed the user command line: we might be in the -- -cargs or -largs section. If so, switch back to -margs now. Ensure_Make_Args; for J in Argv'Range loop if Argv (J)'Length > 0 then Scan_Dist_Arg (Argv (J).all); end if; end loop; Free (Argv); end Scan_Dist_Args; ----------------------------------------- -- Set_Corresponding_Project_File_Name -- ----------------------------------------- procedure Set_Corresponding_Project_File_Name (N : out File_Name_Type) is begin Add_Str_To_Name_Buffer (".gpr"); N := Name_Find; end Set_Corresponding_Project_File_Name; -------------------- -- Show_Dist_Args -- -------------------- procedure Show_Dist_Args is begin for J in Make_Switches.First .. Make_Switches.Last loop Message ("make = " & Make_Switches.Table (J).all); end loop; for J in List_Switches.First .. List_Switches.Last loop Message ("list = " & List_Switches.Table (J).all); end loop; end Show_Dist_Args; ------------------------ -- Sigint_Intercepted -- ------------------------ procedure Sigint_Intercepted is begin Exit_Program (E_Fatal); end Sigint_Intercepted; -------------- -- To_Lower -- -------------- procedure To_Lower (S : in out String) is begin for J in S'Range loop S (J) := To_Lower (S (J)); end loop; end To_Lower; -------------- -- To_Lower -- -------------- procedure To_Lower (N : in out Name_Id) is begin Get_Name_String (N); To_Lower (Name_Buffer (1 .. Name_Len)); N := Name_Find; end To_Lower; -------------- -- To_Lower -- -------------- function To_Lower (N : Name_Id) return Name_Id is begin Get_Name_String (N); To_Lower (Name_Buffer (1 .. Name_Len)); return Name_Find; end To_Lower; --------------------------- -- Set_Application_Names -- --------------------------- procedure Set_Application_Names (Configuration_Name : Name_Id) is begin Get_Name_String (Configuration_Name); To_Lower (Name_Buffer (1 .. Name_Len)); Add_Str_To_Name_Buffer ("_monolithic_app"); Monolithic_App_Unit_Name := Name_Find; Add_Str_To_Name_Buffer (ADB_Suffix); Monolithic_Src_Base_Name := Name_Find; Monolithic_Src_Name := Dir (Id (Root), Monolithic_Src_Base_Name); Monolithic_ALI_Name := To_Afile (Monolithic_Src_Name); Monolithic_Obj_Name := To_Ofile (Monolithic_Src_Name); Monolithic_Obj_Dir := Dir (Id (Root), Id ("obj")); Create_Dir (Monolithic_Obj_Dir); Get_Name_String (Configuration_Name); To_Lower (Name_Buffer (1 .. Name_Len)); Add_Str_To_Name_Buffer ("_dist_app"); Dist_App_Project := Name_Find; Set_Corresponding_Project_File_Name (Dist_App_Project_File); end Set_Application_Names; ------------------------ -- Write_Missing_File -- ------------------------ procedure Write_Missing_File (Fname : File_Name_Type) is begin Message ("file", Fname, "does not exist"); end Write_Missing_File; ---------------------------- -- Write_Warnings_Pragmas -- ---------------------------- procedure Write_Warnings_Pragmas is begin -- Turn off warnings Write_Line ("pragma Warnings (Off);"); -- Turn off style checks and set maximum line length to the largest -- supported value. Write_Line ("pragma Style_Checks (""NM32766"");"); end Write_Warnings_Pragmas; end XE_Utils; polyorb-2.8~20110207.orig/compilers/gnatdist/po_gnatdist.adb0000644000175000017500000000412211750740337023204 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P O _ G N A T D I S T -- -- -- -- B o d y -- -- -- -- Copyright (C) 2007-2008, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with XE_Main; procedure PO_Gnatdist is begin XE_Main; end PO_Gnatdist; polyorb-2.8~20110207.orig/compilers/gnatdist/xe_sem.ads0000644000175000017500000000422411750740337022175 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- X E _ S E M -- -- -- -- S p e c -- -- -- -- Copyright (C) 1995-2009, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- This package provides the routines to analyze the consistency of -- configuration. package XE_Sem is procedure Analyze; end XE_Sem; polyorb-2.8~20110207.orig/compilers/gnatdist/xe_sem.adb0000644000175000017500000012062511750740337022160 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- X E _ S E M -- -- -- -- B o d y -- -- -- -- Copyright (C) 1995-2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with GNAT.Table; with XE; use XE; with XE_Back; use XE_Back; with XE_Front; use XE_Front; with XE_Flags; use XE_Flags; with XE_IO; use XE_IO; with XE_List; use XE_List; with XE_Names; use XE_Names; with XE_Types; use XE_Types; with XE_Units; use XE_Units; with XE_Utils; use XE_Utils; with XE_Storages; use XE_Storages; package body XE_Sem is package Files is new GNAT.Table (Table_Component_Type => File_Name_Type, Table_Index_Type => Natural, Table_Low_Bound => 1, Table_Initial => 20, Table_Increment => 100); procedure Apply_Default_Channel_Attributes (Channel : Channel_Id); -- When a channel attribute has not been assigned, apply the -- default channel attribute. procedure Apply_Default_Partition_Attributes (Partition : Partition_Id); -- When a partition attribute has not been assigned, apply the default -- value for the attribute. procedure Assign_Unit_Tasking (ALI : ALI_Id); -- Assign PCS tasking for a RCI unit. procedure Assign_Partition_Termination (Partition : Partition_Id); -- Assign termination policy based on tasking policy. procedure Update_Partition_Tasking (ALI : ALI_Id; Partition : Partition_Id); -- Update partition tasking with ALI tasking as well as all its -- withed and collocated units. procedure Detect_Configured_Channel_Duplication (Channel : Channel_Id; Success : in out Boolean); -- Detect when two channels are defined designating the same -- partition pair. This may be incorrect as the configuration of -- the two channels may be inconsistent. procedure Detect_Empty_Partition (Partition : Partition_Id; Success : in out Boolean); -- Detect empty partition since they cannot register to the -- distributed system. procedure Detect_Incorrect_Main_Subprogram (Partition : Partition_Id; Success : in out Boolean); -- Check that the configured unit used as main subprogram is really a main -- subprogram from the Ada point of view. procedure Detect_Malformed_Location (Location : Location_Id; Success : in out Boolean); -- Check that the major location is not missing procedure Detect_Multiply_Assigned_Conf_Unit (Conf_Unit : Conf_Unit_Id; Success : in out Boolean); -- RCI and SP units cannot be multiply assigned. They have to be -- unique in the global distributed system. No replication yet. procedure Detect_Non_Ada_Conf_Unit (Conf_Unit : Conf_Unit_Id; Success : in out Boolean); -- Detect that configured units do really designate Ada units. procedure Detect_Non_Collocated_Categorized_Child_Unit (Conf_Unit : Conf_Unit_Id; Success : in out Boolean); -- When two RCI or SP units are child and parent, they have to be -- collocated as they have visibility on their private parts. procedure Detect_Non_Configured_Categorized_Unit (ALI : ALI_Id; Success : in out Boolean); -- A RCI or SP unit has to be configured on one partition. This -- rule is applied only when we produce the global distributed -- system. If a unit is not configured then we already know that -- it is erroneous. procedure Find_Stubs_And_Stamps_From_Closure (Partition : Partition_Id); -- Explore the partition transitive closure to compute the list of -- units for which we need only their stubs (RCI and SP that are -- not configured on this partition). We need this list to check -- the version consistency between stubs and skels. In the same -- time, compute the most recent file time stamp to see whether we -- need to update the partition executable file. procedure Analyze_Required_Storage_Supports (Partition : Partition_Id; Success : in out Boolean); -- For the given partition, build the required storages table by -- analyzing shared passive packages configured on this partition -- and stub packages configured on other partitions. -- Also ensure that storage location specific constraints aren't -- violated (see nested procedure Detect_Storage_Constraint_Violation). procedure Assign_ORB_Tasking_Policy (Partition : Partition_Id); -- Assign ORB tasking policy to default if hasn't been assigned by -- user. Write warning messages if selected policy is incompatible -- with partition tasking or Task_Pool attribute. ------------- -- Analyze -- ------------- procedure Analyze is A : ALI_Id; CU : Conf_Unit_Id; OK : Boolean := True; P : Partition_Id; begin XE_List.Initialize; -- Add units configured on the partition type to each -- partition (for instance, main subprogram). CU := Partitions.Table (Default_Partition_Id).First_Unit; while CU /= No_Conf_Unit_Id loop for J in Partitions.First + 1 .. Partitions.Last loop Add_Conf_Unit (Conf_Units.Table (CU).Name, J); end loop; CU := Conf_Units.Table (CU).Next_Unit; end loop; -- PCS may require to configure one of its RCI units on the main -- partition. if PCS_Conf_Unit /= No_Name then Add_Conf_Unit (PCS_Conf_Unit, Main_Partition); -- Also register this unit explicitly because we want its stubs to -- be built even if the main partition is not built and there are no -- explicit calls to it in user code. Register_Unit_To_Load (PCS_Conf_Unit); end if; Main_Subprogram := Partitions.Table (Main_Partition).Main_Subprogram; if Partitions.Table (Main_Partition).To_Build then Register_Unit_To_Load (Main_Subprogram); end if; -- Load the closure of all configured RCIs for U in Conf_Units.First .. Conf_Units.Last loop if To_Build (U) then Register_Unit_To_Load (Conf_Units.Table (U).Name); end if; end loop; Load_All_Registered_Units; ---------------------------- -- Use of Name Table Info -- ---------------------------- -- All unit names and file names are entered into the Names table. -- The Info and Byte fields of these entries are used as follows: -- -- Unit name Info field has Unit_Id -- Conf. unit name Info field has ALI_Id -- Byte field has Partition_Id (*) -- ALI file name Info field has ALI_Id -- Source file name Info field has Unit_Id -- -- (*) A (normal, RT) unit may be assigned to several partitions. -- We want to detect whether these configured units are real Ada units. -- Set the configured unit name to No_ALI_Id. When we load an ALI file, -- its unit name is set to its ALI Id. If a configured unit name has no -- ALI Id, it is not an Ada unit. -- The byte field of configured unit names is used to detect multiple -- assignment of a unit. for J in Conf_Units.First .. Conf_Units.Last loop Set_ALI_Id (Conf_Units.Table (J).Name, No_ALI_Id); Set_Partition_Id (Conf_Units.Table (J).Name, No_Partition_Id); end loop; -- Set name table info of conf. unit name (%s or %b removed) to ALI Id. for J in ALIs.First .. ALIs.Last loop Set_ALI_Id (ALIs.Table (J).Uname, J); end loop; if not Quiet_Mode then Message ("checking configuration consistency"); end if; if Debug_Mode then Message ("detect non Ada configured units"); Message ("detect (RCI/SP) multiply assigned configured units"); end if; for J in Conf_Units.First .. Conf_Units.Last loop if Partitions.Table (Conf_Units.Table (J).Partition).To_Build then Detect_Non_Ada_Conf_Unit (J, OK); Detect_Multiply_Assigned_Conf_Unit (J, OK); end if; end loop; if Partitions.Table (Default_Partition_Id).To_Build then if Debug_Mode then Message ("detect non configured (RCI/SP) categorized units"); end if; for J in ALIs.First .. ALIs.Last loop Detect_Non_Configured_Categorized_Unit (J, OK); end loop; end if; if Debug_Mode then Message ("detect non collocated (RCI/SP) child and parents"); end if; for J in Conf_Units.First .. Conf_Units.Last loop if To_Build (J) then Detect_Non_Collocated_Categorized_Child_Unit (J, OK); end if; end loop; if Debug_Mode then Message ("detect empty partitions"); Message ("detect incorrect main subprograms"); end if; for J in Partitions.First + 1 .. Partitions.Last loop if Partitions.Table (J).To_Build then Detect_Empty_Partition (J, OK); Detect_Incorrect_Main_Subprogram (J, OK); end if; end loop; if Debug_Mode then Message ("detect channel duplications"); end if; for J in Channels.First + 1 .. Channels.Last loop Detect_Configured_Channel_Duplication (J, OK); end loop; if Debug_Mode then Message ("detect malformed locations"); end if; for J in Locations.First .. Locations.Last loop Detect_Malformed_Location (J, OK); end loop; if not OK then raise Partitioning_Error; end if; for J in Partitions.First + 1 .. Partitions.Last loop -- Apply default values for unspecified attributes. Note that this -- must be done even for partitions that are not built, since their -- attributes might be referenced by other partitions, e.g. when -- generating an Ada starter procedure (which needs the partition's -- executable file name). Apply_Default_Partition_Attributes (J); end loop; for J in Channels.First + 1 .. Channels.Last loop Apply_Default_Channel_Attributes (J); end loop; if not Quiet_Mode then Show_Configuration; end if; if Debug_Mode then Message ("look for units dragging tasking"); end if; -- This step checks whether we need tasking on a partition. -- Check whether a unit comes with tasking. Possibly because of -- its dependencies. Note that we do not look any further a -- dependency designating a RCI unit since it may not be -- collocated with the initial unit. Check also whether this -- unit is RCI and or has RACW as such a unit requires tasking -- from the PCS. Check whether the partition is candidate for a -- local termination. for J in ALIs.First .. ALIs.Last loop Set_Partition_Id (ALIs.Table (J).Uname, No_Partition_Id); Assign_Unit_Tasking (J); end loop; for J in Conf_Units.First .. Conf_Units.Last loop A := Conf_Units.Table (J).My_ALI; P := Conf_Units.Table (J).Partition; Set_Partition_Id (Conf_Units.Table (J).Name, P); if To_Build (J) then Update_Partition_Tasking (A, P); end if; end loop; Partitions.Table (Main_Partition).Tasking := PCS_Tasking; if Debug_Mode then Message ("find partition stub-only units"); Message ("update partition most recent stamp"); end if; for J in Partitions.First + 1 .. Partitions.Last loop if Partitions.Table (J).To_Build then Find_Stubs_And_Stamps_From_Closure (J); end if; end loop; if Debug_Mode then Message ("find needed storage supports"); end if; -- As the analysis of needed storage supports should update partition -- tasking, it must be performed before the termination analysis. for J in Partitions.First + 1 .. Partitions.Last loop if Partitions.Table (J).To_Build then Analyze_Required_Storage_Supports (J, OK); end if; end loop; if not OK then raise Partitioning_Error; end if; if Debug_Mode then Message ("configure partition termination"); end if; for J in Partitions.First + 1 .. Partitions.Last loop if Partitions.Table (J).To_Build then Assign_Partition_Termination (J); Assign_ORB_Tasking_Policy (J); end if; end loop; end Analyze; --------------------------------------- -- Analyze_Required_Storage_Supports -- --------------------------------------- procedure Analyze_Required_Storage_Supports (Partition : Partition_Id; Success : in out Boolean) is procedure Detect_Storage_Constraint_Violation (SLID : Location_Id); -- Needs comment??? Current : Partition_Type renames Partitions.Table (Partition); ----------------------------------------- -- Detect_Storage_Constraint_Violation -- ----------------------------------------- procedure Detect_Storage_Constraint_Violation (SLID : Location_Id) is Location : Location_Type renames Locations.Table (SLID); Storage_Properties : constant Storage_Support_Type := Storage_Supports.Get (Location.Major); begin -- Some storage supports cannot be used on passive partitions if Current.Passive = BTrue and then not Storage_Properties.Allow_Passive then Message ("passive partition", Quote (Current.Name), "cannot use", Quote (Location.Major), "storage support"); Success := False; return; end if; -- Some storage supports cannot be used on partition with local -- termination. if Current.Termination = Local_Termination and then not Storage_Properties.Allow_Local_Term then Message ("partition", Quote (Current.Name), "cannot locally terminate while using", Quote (Location.Major), "storage support"); Success := False; return; end if; -- Some storage supports need a PCS tasking profile if Storage_Properties.Need_Tasking and then Current.Tasking /= PCS_Tasking then Current.Tasking := PCS_Tasking; Message ("PCS tasking forced for", Quote (Current.Name), "to use", Quote (Location.Major), "storage support"); end if; end Detect_Storage_Constraint_Violation; Uname : Name_Id; Unit : Unit_Id; Conf_Unit : Conf_Unit_Id; Part : Partition_Id; Location : Location_Id; -- Start of processing for Analyze_Required_Storage_Supports begin -- Look up storage supports needed for shared passive stub -- packages configured on other partitions. for S in Current.First_Stub .. Current.Last_Stub loop Uname := Stubs.Table (S); Unit := ALIs.Table (Get_ALI_Id (Uname)).Last_Unit; if Units.Table (Unit).Shared_Passive then Part := Get_Partition_Id (Uname); Location := Partitions.Table (Part).Storage_Loc; if Location = No_Location_Id then Location := Default_Data_Location; end if; Detect_Storage_Constraint_Violation (Location); Add_Required_Storage (Current.First_Required_Storage, Current.Last_Required_Storage, Location, Unit, Owner => False); end if; end loop; -- Look up storage support needed for shared passive packages configured -- on this partition. Conf_Unit := Current.First_Unit; while Conf_Unit /= No_Conf_Unit_Id loop Unit := Conf_Units.Table (Conf_Unit).My_Unit; if Units.Table (Unit).Shared_Passive then Location := Current.Storage_Loc; if Location = No_Location_Id then Location := Default_Data_Location; end if; Detect_Storage_Constraint_Violation (Location); Add_Required_Storage (Current.First_Required_Storage, Current.Last_Required_Storage, Location, Unit, Owner => True); end if; Conf_Unit := Conf_Units.Table (Conf_Unit).Next_Unit; end loop; end Analyze_Required_Storage_Supports; -------------------------------------- -- Apply_Default_Channel_Attributes -- -------------------------------------- procedure Apply_Default_Channel_Attributes (Channel : Channel_Id) is Current : Channel_Type renames Channels.Table (Channel); Default : Channel_Type renames Channels.Table (Default_Channel_Id); begin if No (Current.Filter) then Current.Filter := Default.Filter; end if; end Apply_Default_Channel_Attributes; ---------------------------------------- -- Apply_Default_Partition_Attributes -- ---------------------------------------- procedure Apply_Default_Partition_Attributes (Partition : Partition_Id) is Current : Partition_Type renames Partitions.Table (Partition); Default : Partition_Type renames Partitions.Table (Default_Partition_Id); begin Current.Partition_Dir := Dir (Configuration, Current.Name); Current.Partition_Dir := Dir (Part_Dir_Name, Current.Partition_Dir); if No (Current.Command_Line) then Current.Command_Line := Default.Command_Line; end if; if No (Current.Executable_Dir) then Current.Executable_Dir := Default.Executable_Dir; end if; Current.Executable_File := Current.Name & Exe_Suffix_Id; if Present (Current.Executable_Dir) then Current.Executable_File := Dir (Current.Executable_Dir, Current.Executable_File); end if; if No (Current.Filter) then Current.Filter := Default.Filter; end if; if No (Current.Main_Subprogram) then Current.Main_Subprogram := Default.Main_Subprogram; end if; if Current.Host = No_Host_Id then Current.Host := Default.Host; end if; if Current.Light_PCS = BMaybe then Current.Light_PCS := Default.Light_PCS; end if; if Current.Light_PCS = BFalse then Current.Tasking := PCS_Tasking; end if; if Current.Passive = BMaybe then Current.Passive := Default.Passive; end if; if Current.Priority = No_Priority then Current.Priority := Default.Priority; end if; if Current.First_Network_Loc = No_Location_Id then Current.First_Network_Loc := Default.First_Network_Loc; Current.Last_Network_Loc := Default.Last_Network_Loc; end if; if Current.First_Env_Var = No_Env_Var_Id then Current.First_Env_Var := Default.First_Env_Var; else Env_Vars.Table (Current.Last_Env_Var).Next_Env_Var := Default.First_Env_Var; end if; if Default.Last_Env_Var /= No_Env_Var_Id then Current.Last_Env_Var := Default.Last_Env_Var; end if; if Current.Reconnection = No_Reconnection then Current.Reconnection := Default.Reconnection; end if; if Current.Storage_Loc = No_Location_Id then Current.Storage_Loc := Default.Storage_Loc; end if; if Current.First_Required_Storage = No_Required_Storage_Id then Current.First_Required_Storage := Default.First_Required_Storage; Current.Last_Required_Storage := Default.Last_Required_Storage; end if; if Current.Task_Pool = No_Task_Pool then Current.Task_Pool := Default.Task_Pool; end if; if Current.Termination = No_Termination then Current.Termination := Default.Termination; end if; if Current.ORB_Tasking_Policy = No_ORB_Tasking_Policy then Current.ORB_Tasking_Policy := Default.ORB_Tasking_Policy; end if; end Apply_Default_Partition_Attributes; ------------------------------- -- Assign_ORB_Tasking_Policy -- ------------------------------- procedure Assign_ORB_Tasking_Policy (Partition : Partition_Id) is Current : Partition_Type renames Partitions.Table (Partition); begin if Current.Tasking = PCS_Tasking then -- If ORB tasking policy isn't assigned yet, use default if Current.ORB_Tasking_Policy = No_ORB_Tasking_Policy then Current.ORB_Tasking_Policy := Default_ORB_Tasking_Policy; end if; if Debug_Mode then Message ("partition", Current.Name, "has ORB tasking policy ", ORB_Tasking_Policy_Img (Current.ORB_Tasking_Policy)); end if; else -- Write a warning message if ORB tasking policy is assigned -- when partition has no ORB tasking. if Current.ORB_Tasking_Policy /= No_ORB_Tasking_Policy then Message ("Attribute ORB_Tasking_Policy has no effect when" & "partition has no ORB tasking"); end if; end if; -- Write a warning message if Task_Pool attribute is set -- when another than Thread_Pool ORB tasking poliy is -- selected. if Current.ORB_Tasking_Policy /= Thread_Pool and then Current.Task_Pool /= No_Task_Pool then Message ("Attribute Task_Pool has no effect when ", ORB_Tasking_Policy_Img (Current.ORB_Tasking_Policy), "ORB tasking policy is set"); end if; end Assign_ORB_Tasking_Policy; ---------------------------------- -- Assign_Partition_Termination -- ---------------------------------- procedure Assign_Partition_Termination (Partition : Partition_Id) is Current : Partition_Type renames Partitions.Table (Partition); begin if Debug_Mode then Message ("partition", Current.Name, "has tasking ", Tasking_Img (Current.Tasking)); end if; if Current.Termination = No_Termination then if Current.Tasking /= PCS_Tasking then Current.Termination := Local_Termination; if Debug_Mode then Message ("local termination forced for", Current.Name); end if; else Current.Termination := Global_Termination; end if; end if; end Assign_Partition_Termination; ------------------------- -- Assign_Unit_Tasking -- ------------------------- procedure Assign_Unit_Tasking (ALI : ALI_Id) is T : Tasking_Type := Get_Tasking (ALI); begin for J in ALIs.Table (ALI).First_Unit .. ALIs.Table (ALI).Last_Unit loop -- No need to investigate further when the unit is a RCI unit or has -- RACW objects. if Units.Table (J).RCI or else Units.Table (J).Has_RACW then T := PCS_Tasking; exit; end if; end loop; if T = Unknown_Tasking then T := No_Tasking; end if; Set_Tasking (ALI, T); if Debug_Mode then Message ("unit", ALIs.Table (ALI).Uname, "has tasking ", Tasking_Img (Get_Tasking (ALI))); end if; end Assign_Unit_Tasking; ------------------------------------------- -- Detect_Configured_Channel_Duplication -- ------------------------------------------- procedure Detect_Configured_Channel_Duplication (Channel : Channel_Id; Success : in out Boolean) is N : Name_Id := Channels.Table (Channel).Name; LP : Partition_Id renames Channels.Table (Channel).Lower.My_Partition; UP : Partition_Id renames Channels.Table (Channel).Upper.My_Partition; C : Channel_Id; begin if UP = LP then Message ("channel", Quote (N), "is an illegal pair of partitions"); Success := False; end if; Get_Name_String (Partitions.Table (UP).Name); Add_Char_To_Name_Buffer ('#'); Get_Name_String_And_Append (Partitions.Table (UP).Name); N := Name_Find; C := Get_Channel_Id (N); if C /= No_Channel_Id then Message ("channels", Quote (N), "and", Quote (Channels.Table (C).Name), "designate the same pair"); Success := False; end if; Set_Channel_Id (N, Channel); end Detect_Configured_Channel_Duplication; ---------------------------- -- Detect_Empty_Partition -- ---------------------------- procedure Detect_Empty_Partition (Partition : Partition_Id; Success : in out Boolean) is N : constant Name_Id := Partitions.Table (Partition).Name; begin -- We cannot have an empty partition if Partitions.Table (Partition).First_Unit = No_Conf_Unit_Id then Message ("partition", Quote (N), "is empty"); Success := False; end if; end Detect_Empty_Partition; -------------------------------------- -- Detect_Incorrect_Main_Subprogram -- -------------------------------------- procedure Detect_Incorrect_Main_Subprogram (Partition : Partition_Id; Success : in out Boolean) is N : constant Unit_Name_Type := Partitions.Table (Partition).Main_Subprogram; A : ALI_Id; begin if No (N) then return; end if; A := Get_ALI_Id (N); if A = No_ALI_Id or else ALIs.Table (A).Main_Program = None then Message ("", Quote (N), "is not a main program"); Success := False; end if; end Detect_Incorrect_Main_Subprogram; ------------------------------- -- Detect_Malformed_Location -- ------------------------------- procedure Detect_Malformed_Location (Location : Location_Id; Success : in out Boolean) is begin Get_Name_String (Locations.Table (Location).Major); if Name_Len = 0 then Add_Str_To_Name_Buffer ("://"); if Present (Locations.Table (Location).Minor) then Get_Name_String_And_Append (Locations.Table (Location).Minor); end if; Message ("missing location name in", Quote (Name_Find)); Success := False; end if; end Detect_Malformed_Location; ---------------------------------------- -- Detect_Multiply_Assigned_Conf_Unit -- ---------------------------------------- procedure Detect_Multiply_Assigned_Conf_Unit (Conf_Unit : Conf_Unit_Id; Success : in out Boolean) is N : constant Name_Id := Conf_Units.Table (Conf_Unit).Name; A : constant ALI_Id := Get_ALI_Id (N); U : Unit_Id; begin if A = No_ALI_Id then return; end if; -- The last unit is always the spec when there is a spec. U := ALIs.Table (A).Last_Unit; Conf_Units.Table (Conf_Unit).My_Unit := U; Conf_Units.Table (Conf_Unit).My_ALI := A; if Units.Table (U).Is_Generic then Message ("generic unit", Quote (N), "cannot be assigned to a partition"); Success := False; elsif Units.Table (U).RCI or else Units.Table (U).Shared_Passive then -- If null, we have not yet assigned this rci or sp unit -- name to a partition. if Get_Partition_Id (N) /= No_Partition_Id then if Units.Table (U).RCI then Message ("RCI Ada unit", Quote (N), "has been assigned twice"); else Message ("SP Ada unit", Quote (N), "has been assigned twice"); end if; Success := False; end if; -- Assign unit to partition in order not to assign it twice -- as this unit is a RCI or a SP package. Set_Partition_Id (N, Conf_Units.Table (Conf_Unit).Partition); end if; end Detect_Multiply_Assigned_Conf_Unit; ------------------------------ -- Detect_Non_Ada_Conf_Unit -- ------------------------------ procedure Detect_Non_Ada_Conf_Unit (Conf_Unit : Conf_Unit_Id; Success : in out Boolean) is N : constant Unit_Name_Type := Conf_Units.Table (Conf_Unit).Name; A : constant ALI_Id := Get_ALI_Id (N); begin -- If no ALI Id is associated with the unit name of the configured unit, -- then it is not an Ada unit. if A = No_ALI_Id then Message ("configured unit", Quote (N), "is not an Ada unit"); Success := False; end if; end Detect_Non_Ada_Conf_Unit; -------------------------------------------------- -- Detect_Non_Collocated_Categorized_Child_Unit -- -------------------------------------------------- procedure Detect_Non_Collocated_Categorized_Child_Unit (Conf_Unit : Conf_Unit_Id; Success : in out Boolean) is P : constant Partition_Id := Conf_Units.Table (Conf_Unit).Partition; U : Unit_Id := Conf_Units.Table (Conf_Unit).My_Unit; X : constant Unit_Name_Type := Conf_Units.Table (Conf_Unit).Name; N : Unit_Name_Type := X; A : ALI_Id; begin if not Units.Table (U).RCI and then not Units.Table (U).Shared_Passive then return; end if; Get_Name_String (N); -- Find a parent while Name_Len > 0 and then Name_Buffer (Name_Len) /= '.' loop Name_Len := Name_Len - 1; end loop; -- There is a parent if Name_Len > 1 then Name_Len := Name_Len - 1; N := Name_Find; A := Get_ALI_Id (N); -- When this is an issue this has already been reported if A = No_ALI_Id then return; end if; -- It is a RCI or SP package U := ALIs.Table (A).Last_Unit; if Units.Table (U).RCI or else Units.Table (U).Shared_Passive then -- There are not on the same partition if Get_Partition_Id (N) /= P then Message ("", Quote (N), "and", Quote (X), "are not on the same partition"); Success := False; end if; end if; end if; end Detect_Non_Collocated_Categorized_Child_Unit; -------------------------------------------- -- Detect_Non_Configured_Categorized_Unit -- -------------------------------------------- procedure Detect_Non_Configured_Categorized_Unit (ALI : ALI_Id; Success : in out Boolean) is U : constant Unit_Id := ALIs.Table (ALI).Last_Unit; N : constant Unit_Name_Type := ALIs.Table (ALI).Uname; begin if (Units.Table (U).RCI or else Units.Table (U).Shared_Passive) and then not Units.Table (U).Is_Generic and then Get_Partition_Id (N) = No_Partition_Id then if Units.Table (U).RCI then Message ("RCI Ada unit", Quote (N), "has not been assigned to a partition"); else Message ("Shared passive Ada unit", Quote (N), "has not been assigned to a partition"); end if; Success := False; end if; end Detect_Non_Configured_Categorized_Unit; ---------------------------------------- -- Find_Stubs_And_Stamps_From_Closure -- ---------------------------------------- procedure Find_Stubs_And_Stamps_From_Closure (Partition : Partition_Id) is CU : Conf_Unit_Id; U : Unit_Id; A : ALI_Id; F : File_Name_Type; L : Stub_Id; begin Partitions.Table (Partition).First_Stub := Stubs.Last + 1; Partitions.Table (Partition).Last_Stub := Stubs.Last; -- Reset Stamp_Checked flag for J in ALIs.First .. ALIs.Last loop ALIs.Table (J).Stamp_Checked := False; end loop; -- Append all the dependencies on units which are assigned to -- this partition. CU := Partitions.Table (Partition).First_Unit; while CU /= No_Conf_Unit_Id loop A := Conf_Units.Table (CU).My_ALI; -- Mark unit as already checked now ALIs.Table (A).Stamp_Checked := True; F := Dir (Monolithic_Obj_Dir, ALIs.Table (A).Afile); -- Update most recent stamp of this partition Update_Most_Recent_Stamp (Partition, F); for J in ALIs.Table (A).First_Unit .. ALIs.Table (A).Last_Unit loop for K in Units.Table (J).First_With .. Units.Table (J).Last_With loop if Present (Withs.Table (K).Afile) then Files.Append (Withs.Table (K).Afile); end if; end loop; end loop; CU := Conf_Units.Table (CU).Next_Unit; end loop; -- Explore the withed units. Any Shared Passive or RCI unit that is -- seen from this point on is a stub unit (unlike conf units checked -- in the above loop). <> while Files.First <= Files.Last loop F := Files.Table (Files.Last); Files.Decrement_Last; A := Get_ALI_Id (F); -- Some units may not have ALI files like generic units if A = No_ALI_Id then if Debug_Mode then Write_Str ("no ALI info found for "); Write_Name (F); Write_Eol; end if; goto Next_With; end if; if ALIs.Table (A).Stamp_Checked then if Debug_Mode then Message ("stamps already checked for", ALIs.Table (A).Uname); end if; goto Next_With; end if; -- Mark unit as checked ALIs.Table (A).Stamp_Checked := True; F := Dir (Monolithic_Obj_Dir, F); if Debug_Mode then Message ("check stamp", F); end if; -- Update most recent stamp of this partition Update_Most_Recent_Stamp (Partition, F); -- Check for stub U := ALIs.Table (A).Last_Unit; if not Units.Table (U).Is_Generic and then (Units.Table (U).RCI or else Units.Table (U).Shared_Passive) then -- If RCI or SP unit is encountered now, mark it as a stub and do -- not explore its dependencies any further. Stubs.Increment_Last; L := Stubs.Last; Stubs.Table (L) := ALIs.Table (A).Uname; if Partitions.Table (Partition).Last_Stub = No_Stub_Id then Partitions.Table (Partition).First_Stub := L; end if; Partitions.Table (Partition).Last_Stub := L; if Verbose_Mode then Message ("append stub", ALIs.Table (A).Uname); end if; else -- Mark this unit as explored and append its dependencies if Debug_Mode then Message ("append dependencies of", ALIs.Table (A).Uname); end if; for J in ALIs.Table (A).First_Unit .. ALIs.Table (A).Last_Unit loop for K in Units.Table (J).First_With .. Units.Table (J).Last_With loop if Present (Withs.Table (K).Afile) then A := Get_ALI_Id (Withs.Table (K).Afile); if A /= No_ALI_Id and then not ALIs.Table (A).Stamp_Checked then Files.Append (Withs.Table (K).Afile); end if; end if; end loop; end loop; end if; end loop; end Find_Stubs_And_Stamps_From_Closure; ------------------------------ -- Update_Partition_Tasking -- ------------------------------ procedure Update_Partition_Tasking (ALI : ALI_Id; Partition : Partition_Id) is A : ALI_Id; F : File_Name_Type; N : Unit_Name_Type; U : Unit_Id; T : Tasking_Type renames Partitions.Table (Partition).Tasking; begin if Debug_Mode then Message ("update partition", Partitions.Table (Partition).Name, "tasking", Tasking_Img (T)); end if; Files.Append (ALIs.Table (ALI).Afile); while Files.First <= Files.Last loop F := Files.Table (Files.Last); Files.Decrement_Last; A := Get_ALI_Id (F); if Debug_Mode then Message ("pop unit", ALIs.Table (A).Uname); end if; -- Update partition tasking to unit tasking if T = PCS_Tasking then null; elsif T = User_Tasking then if ALIs.Table (A).Tasking = PCS_Tasking then if Debug_Mode then Message ("update tasking from", Tasking_Img (T), "to", Tasking_Img (ALIs.Table (A).Tasking)); end if; T := ALIs.Table (A).Tasking; end if; else if T /= ALIs.Table (A).Tasking then if Debug_Mode then Message ("update tasking from ", Tasking_Img (T), " to ", Tasking_Img (ALIs.Table (A).Tasking)); end if; T := ALIs.Table (A).Tasking; end if; end if; -- When needed, push into the collocated units stack the withed units for J in ALIs.Table (A).First_Unit .. ALIs.Table (A).Last_Unit loop for K in Units.Table (J).First_With .. Units.Table (J).Last_With loop F := Withs.Table (K).Afile; if Present (F) then A := Get_ALI_Id (F); -- Discard predefined units since they do not bring -- tasking with them. if Is_Predefined_File (F) then null; elsif A /= No_ALI_Id then U := ALIs.Table (A).Last_Unit; N := ALIs.Table (A).Uname; -- Discard unit that has already been assigned -- to this partition. if Get_Partition_Id (N) = Partition then null; -- Discard this unit as it may not be collocated elsif Units.Table (U).RCI or else Units.Table (U).Shared_Passive then null; -- Continue investigation later on else if Debug_Mode then Message ("push unit", N, "in partition", Partitions.Table (Partition).Name); end if; Set_Partition_Id (N, Partition); Files.Append (F); end if; end if; end if; end loop; end loop; end loop; end Update_Partition_Tasking; end XE_Sem; polyorb-2.8~20110207.orig/compilers/gnatdist/xe_reg.adb0000644000175000017500000000740011750740337022144 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- X E _ R E G -- -- -- -- B o d y -- -- -- -- Copyright (C) 1995-2008, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with GNAT.Registry; use GNAT.Registry; package body XE_Reg is function Get_GNAT_Version return String; -- Returns the GNAT version number -------------------- -- Get_GARLIC_Dir -- -------------------- function Get_GARLIC_Dir return String_Access is ACT_Key : HKEY; Result : String_Access; begin -- First check the GCC_ROOT environent variable Result := Getenv ("GCC_ROOT"); if Result.all /= "" then declare GCC_ROOT : constant String := Result.all; begin Free (Result); if GCC_ROOT (GCC_ROOT'Last) = '\' or else GCC_ROOT (GCC_ROOT'Last) = '/' then return new String'(GCC_ROOT & "lib\garlic"); else return new String'(GCC_ROOT & "\lib\garlic"); end if; end; end if; -- GCC_ROOT was not defined, look in the registry. -- Open "HKEY_LOCAL_MACHINE\SOFTWARE\Free Software Foundation\ -- GNAT\" key. ACT_Key := Open_Key (HKEY_LOCAL_MACHINE, "SOFTWARE\Ada Core Technologies\GNAT\" & Get_GNAT_Version); -- Get ROOT value Result := new String'(Query_Value (ACT_Key, "ROOT") & "\lib\garlic"); Close_Key (ACT_Key); return Result; exception when Registry_Error => return null; end Get_GARLIC_Dir; ---------------------- -- Get_GNAT_Version -- ---------------------- function Get_GNAT_Version return String is GSVS : constant String := "5.03w"; begin for K in GSVS'Range loop if GSVS (K) = ' ' then return GSVS (GSVS'First .. K - 1); end if; end loop; return ""; end Get_GNAT_Version; end XE_Reg; polyorb-2.8~20110207.orig/compilers/gnatdist/xe_defs-defaults.ads.in0000644000175000017500000000557511750740337024556 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- X E _ D E F S . D E F A U L T S -- -- -- -- S p e c -- -- -- -- Copyright (C) 2006-2007, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- Defaults set by configure pragma Style_Checks ("M2048"); -- Configure substitutions may yield long lines -- @configure_input@ package XE_Defs.Defaults is Default_RSH_Command : constant String := "@RSH_CMD@"; Default_RSH_Options : constant String := "@RSH_OPT@"; Default_PCS_Name : constant String := "@PCSNAME@"; Default_Storage_Data : constant String := "@DEFSTORAGEDATA@"; Default_Storage_Name : constant String := "@DEFSTORAGENAME@"; Default_Protocol_Data : constant String := "@DEFPROTOCOLDATA@"; Default_Protocol_Name : constant String := "@DEFPROTOCOLNAME@"; Default_Dist_Flags : constant String := "@GNAT_RTS_FLAG@"; Default_Prefix : constant String := "@prefix@"; Version : constant String := "@GNATDIST_VERSION@"; Windows_On_Host : constant Boolean := @WINDOWS_ON_HOST@; end XE_Defs.Defaults; polyorb-2.8~20110207.orig/compilers/gnatdist/xe_front.adb0000644000175000017500000016226711750740337022534 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- X E _ F R O N T -- -- -- -- B o d y -- -- -- -- Copyright (C) 1995-2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with XE_Back; use XE_Back; with XE_Defs; use XE_Defs; with XE_Flags; use XE_Flags; with XE_IO; use XE_IO; with XE_Names; use XE_Names; with XE_Utils; use XE_Utils; with XE_Storages; use XE_Storages; package body XE_Front is Min_Field_Width : constant := 11; procedure Add_Channel_Partition (P : Partition_Id; C : Channel_Id); -- Assign a partition to a channel. Sort the partition pair. procedure Build_New_Channel (V : Variable_Id); -- Retrieve the two partitions and attributes previously parsed in -- order to build the channel. procedure Build_New_Host (Subprogram : Subprogram_Id; Host_Entry : out Host_Id); procedure Build_New_Partition (V : Variable_Id); -- Retrieve ada units and attributes previously parsed in order to -- build the partition. procedure Build_New_Variable (Variable : Variable_Id); -- Dispatching procedure to create entities of different types. function Comes_From_Source (N : Node_Id) return Boolean; -- True when N's source location denotes a point in the user's config file -- (False for internally generated nodes). procedure Set_Channel_Attribute (Attribute : Attribute_Id; Channel : Channel_Id); procedure Set_Partition_Attribute (Attribute : Attribute_Id; Partition : Partition_Id); procedure Set_Pragma_Statement (Subprogram : Subprogram_Id); procedure Set_Type_Attribute (Pre_Type : Type_Id); procedure Show_Partition (P : Partition_Id); -- Output the different attributes of a partition. procedure Write_Field (Indent : Natural; Field : String; Width : Natural := Min_Field_Width); -- Output field with at least Width characters and indent it. --------------------------- -- Add_Channel_Partition -- --------------------------- procedure Add_Channel_Partition (P : Partition_Id; C : Channel_Id) is procedure Update_Channel_Partition (Channel_Partition : in out Channel_Partition_Type; Partition : Partition_Id; Channel : Channel_Id); -- Link Channel into the list of partition Channels. The head of -- this list is First_Channel (Partitions) and the tail is -- Last_Channel. Next elements are Next_Channel (Channels). procedure Update_Channel_Partition (Channel_Partition : in out Channel_Partition_Type; Partition : Partition_Id; Channel : Channel_Id) is CID : Channel_Id; begin Channel_Partition.My_Partition := Partition; Channel_Partition.Next_Channel := No_Channel_Id; CID := Partitions.Table (Partition).Last_Channel; if CID = No_Channel_Id then Partitions.Table (Partition).First_Channel := Channel; Partitions.Table (Partition).Last_Channel := Channel; else if Channels.Table (CID).Lower.My_Partition = Partition then Channels.Table (CID).Lower.Next_Channel := Channel; else Channels.Table (CID).Upper.Next_Channel := Channel; end if; Partitions.Table (Partition).Last_Channel := Channel; end if; end Update_Channel_Partition; begin if Debug_Mode then Message ("add partition", Partitions.Table (P).Name, "to channel", Channels.Table (C).Name); end if; if Channels.Table (C).Lower = Null_Channel_Partition then Update_Channel_Partition (Channels.Table (C).Lower, P, C); elsif P > Channels.Table (C).Lower.My_Partition then Update_Channel_Partition (Channels.Table (C).Upper, P, C); else Channels.Table (C).Upper := Channels.Table (C).Lower; Update_Channel_Partition (Channels.Table (C).Lower, P, C); end if; end Add_Channel_Partition; ------------------- -- Add_Conf_Unit -- ------------------- procedure Add_Conf_Unit (U : Unit_Name_Type; P : Partition_Id) is begin if Get_Partition_Id (U) = P then return; end if; -- Mark this configured unit as already partitioned Set_Partition_Id (U, P); -- The same unit can be multiply declared especially if -- this unit is a normal package Conf_Units.Increment_Last; Conf_Units.Table (Conf_Units.Last) := Null_Conf_Unit; Conf_Units.Table (Conf_Units.Last).Partition := P; Conf_Units.Table (Conf_Units.Last).Name := U; -- Update partition single linked list of configured units if Partitions.Table (P).First_Unit = No_Conf_Unit_Id then Partitions.Table (P).First_Unit := Conf_Units.Last; else Conf_Units.Table (Partitions.Table (P).Last_Unit).Next_Unit := Conf_Units.Last; end if; Partitions.Table (P).Last_Unit := Conf_Units.Last; end Add_Conf_Unit; ------------------------------ -- Add_Environment_Variable -- ------------------------------ procedure Add_Environment_Variable (First : in out Env_Var_Id; Last : in out Env_Var_Id; Name : Name_Id) is L : Env_Var_Id; begin -- Add a new element in the location table and fill it with the -- given name (major). Env_Vars.Increment_Last; L := Env_Vars.Last; Env_Vars.Table (L).Name := Name; Env_Vars.Table (L).Next_Env_Var := No_Env_Var_Id; -- Link this new location to the end of the partition env vars -- list. if First = No_Env_Var_Id then First := L; else Env_Vars.Table (Last).Next_Env_Var := L; end if; Last := L; end Add_Environment_Variable; ------------------ -- Add_Location -- ------------------ procedure Add_Location (First : in out Location_Id; Last : in out Location_Id; Major : Name_Id; Minor : Name_Id) is L : Location_Id; begin -- Add a new element in the location table and fill it with the -- protocol name (major) and the protocol data (minor). Locations.Increment_Last; L := Locations.Last; Locations.Table (L).Major := Major; Locations.Table (L).Minor := Minor; Locations.Table (L).Next_Location := No_Location_Id; -- Link this new location to the end of the partition location -- list. if First = No_Location_Id then First := L; else Locations.Table (Last).Next_Location := L; end if; Last := L; end Add_Location; -------------------------- -- Add_Required_Storage -- -------------------------- procedure Add_Required_Storage (First : in out Required_Storage_Id; Last : in out Required_Storage_Id; Location : Location_Id; Unit : Unit_Id; Owner : Boolean) is W : Required_Storage_Id; begin -- Add a new element in the required storage table Required_Storages.Increment_Last; W := Required_Storages.Last; Required_Storages.Table (W).Location := Location; Required_Storages.Table (W).Unit := Unit; Required_Storages.Table (W).Is_Owner := Owner; Required_Storages.Table (W).Next_Storage := No_Required_Storage_Id; -- Link this new required storage to the end of the partition required -- storage list. if First = No_Required_Storage_Id then First := W; else Required_Storages.Table (Last).Next_Storage := W; end if; Last := W; end Add_Required_Storage; ----------------------- -- Build_New_Channel -- ----------------------- procedure Build_New_Channel (V : Variable_Id) is Channel_Name : Name_Id; Partition_Name : Name_Id; Partition_Node : Variable_Id; Component_Node : Component_Id; Partition : Partition_Id; Channel : Channel_Id; begin Channel_Name := Get_Variable_Name (V); -- Create a new entry in Channels.Table Create_Channel (Channel_Name, Node_Id (V), Channel); -- Scan Channel_Name partition pair and Channel_Name attributes First_Variable_Component (V, Component_Node); while Component_Node /= Null_Component loop -- This is a partition (upper or lower) if Get_Attribute_Kind (Component_Node) = Attribute_Unknown then if Is_Component_Initialized (Component_Node) then -- Append this partition to the pair Partition_Node := Get_Component_Value (Component_Node); Partition_Name := Get_Variable_Name (Partition_Node); Partition := Get_Partition_Id (Partition_Name); if Partition = No_Partition_Id then Write_SLOC (Node_Id (Partition_Node)); Write_Str ("no such partition "); Write_Name (Partition_Name); Write_Eol; raise Parsing_Error; end if; Add_Channel_Partition (Partition, Channel); end if; else Set_Channel_Attribute (Attribute_Id (Component_Node), Channel); end if; Next_Variable_Component (Component_Node); end loop; end Build_New_Channel; -------------------- -- Build_New_Host -- -------------------- procedure Build_New_Host (Subprogram : Subprogram_Id; Host_Entry : out Host_Id) is Host : Host_Id; Name : Name_Id; Node : Node_Id; begin Node := Node_Id (Subprogram); Name := Get_Node_Name (Node); Host := Get_Host_Id (Name); if Host = No_Host_Id then Create_Host (Name, Node, Host); Hosts.Table (Host).Static := False; Hosts.Table (Host).Import := Ada_Import; Hosts.Table (Host).External := Name; end if; Host_Entry := Host; end Build_New_Host; ------------------------- -- Build_New_Partition -- ------------------------- procedure Build_New_Partition (V : Variable_Id) is Partition_Name : Name_Id; Ada_Unit_Name : Name_Id; Ada_Unit_Node : Variable_Id; Component_Node : Component_Id; Partition : Partition_Id; begin Partition_Name := Get_Variable_Name (V); -- Create a new entry into Partitions.Table Create_Partition (Partition_Name, Node_Id (V), Partition); -- Scan Partition_Name ada unit list and Partition_Name attributes First_Variable_Component (V, Component_Node); while Component_Node /= Null_Component loop if Get_Attribute_Kind (Component_Node) = Attribute_Unknown then -- Append this unit to the partition list Ada_Unit_Node := Get_Component_Value (Component_Node); Ada_Unit_Name := Get_Variable_Name (Ada_Unit_Node); Add_Conf_Unit (Ada_Unit_Name, Partition); else -- This information is a partition attribute Set_Partition_Attribute (Attribute_Id (Component_Node), Partition); end if; Next_Variable_Component (Component_Node); end loop; end Build_New_Partition; ------------------------ -- Build_New_Variable -- ------------------------ procedure Build_New_Variable (Variable : Variable_Id) is Var_Type : Type_Id; Pre_Type : Predefined_Type; begin Var_Type := Get_Variable_Type (Variable); Pre_Type := Get_Type_Kind (Var_Type); case Pre_Type is when Pre_Type_Partition => Build_New_Partition (Variable); when Pre_Type_Channel => Build_New_Channel (Variable); when others => null; end case; end Build_New_Variable; ----------------------- -- Comes_From_Source -- ----------------------- function Comes_From_Source (N : Node_Id) return Boolean is X, Y : Int; begin Get_Node_SLOC (N, X, Y); return X /= 0; end Comes_From_Source; -------------------- -- Create_Channel -- -------------------- procedure Create_Channel (Name : Channel_Name_Type; Node : Node_Id; CID : out Channel_Id) is Channel : Channel_Id; begin if Debug_Mode then Message ("create channel", Name); end if; Channels.Increment_Last; Channel := Channels.Last; Set_Channel_Id (Name, Channel); Channels.Table (Channel).Name := Name; Channels.Table (Channel).Node := Node; Channels.Table (Channel).Lower := Null_Channel_Partition; Channels.Table (Channel).Upper := Null_Channel_Partition; Channels.Table (Channel).Filter := No_Filter_Name; CID := Channel; end Create_Channel; ----------------- -- Create_Host -- ----------------- procedure Create_Host (Name : Host_Name_Type; Node : Node_Id; HID : out Host_Id) is Host : Host_Id; begin if Debug_Mode then Message ("create host", Name); end if; Hosts.Increment_Last; Host := Hosts.Last; Hosts.Table (Host).Name := Name; Hosts.Table (Host).Node := Node; Hosts.Table (Host).Static := True; Hosts.Table (Host).Import := None_Import; Hosts.Table (Host).External := No_Name; Hosts.Table (Host).Most_Recent := No_File_Name; Set_Host_Id (Name, Host); HID := Host; end Create_Host; ---------------------- -- Create_Partition -- ---------------------- procedure Create_Partition (Name : Partition_Name_Type; Node : Node_Id; PID : out Partition_Id) is Partition : Partition_Id; begin if Debug_Mode then Message ("create partition", Name); end if; Partitions.Increment_Last; Partition := Partitions.Last; Set_Partition_Id (Name, Partition); Partitions.Table (Partition) := Null_Partition; Partitions.Table (Partition).Name := Name; Partitions.Table (Partition).Node := Node; PID := Partition; end Create_Partition; -------------- -- Frontend -- -------------- procedure Frontend is Node : Node_Id; HID : Host_Id; begin First_Configuration_Declaration (Configuration_Node, Node); while Node /= Null_Node loop if Is_Variable (Node) then Build_New_Variable (Variable_Id (Node)); elsif Is_Configuration (Node) and then Comes_From_Source (Node) then pragma Assert (Configuration = No_Name); Configuration := Get_Node_Name (Node); Set_Application_Names (Configuration); elsif Is_Type (Node) then Set_Type_Attribute (Type_Id (Node)); elsif Is_Statement (Node) then Set_Pragma_Statement (Get_Subprogram_Call (Statement_Id (Node))); end if; Next_Configuration_Declaration (Node); end loop; for P in Partitions.First .. Partitions.Last loop HID := Partitions.Table (P).Host; if HID /= No_Host_Id and then not Hosts.Table (HID).Static and then Hosts.Table (HID).Import = Ada_Import then Add_Conf_Unit (Hosts.Table (HID).External, P); end if; end loop; if Main_Partition = No_Partition_Id then Write_SLOC (Node_Id (Configuration_Node)); Write_Str ("non-dist. app. main subprogram has not been declared"); Write_Eol; raise Parsing_Error; end if; end Frontend; ---------------- -- Get_ALI_Id -- ---------------- function Get_ALI_Id (N : Name_Id) return ALI_Id is Info : Int; begin Info := Get_Name_Table_Info (Name (N)); case Info is when Int (ALI_Id'First) .. Int (ALI_Id'Last) => null; when others => raise Program_Error; end case; return ALI_Id (Info); end Get_ALI_Id; -------------------- -- Get_Channel_Id -- -------------------- function Get_Channel_Id (N : Name_Id) return Channel_Id is Info : Int; begin Info := Get_Name_Table_Info (Name (N)); case Info is when Int (Channel_Id'First) .. Int (Channel_Id'Last) => null; when 0 => Info := Int (No_Channel_Id); when others => raise Program_Error; end case; return Channel_Id (Info); end Get_Channel_Id; ---------------------- -- Get_Conf_Unit_Id -- ---------------------- function Get_Conf_Unit_Id (N : Name_Id) return Conf_Unit_Id is Info : Int; begin Info := Get_Name_Table_Info (Name (N)); if Info in Int (Conf_Unit_Id'First) .. Int (Conf_Unit_Id'Last) then return Conf_Unit_Id (Info); end if; return No_Conf_Unit_Id; end Get_Conf_Unit_Id; ----------------- -- Get_Host_Id -- ----------------- function Get_Host_Id (N : Name_Id) return Host_Id is Info : Int; begin Info := Get_Name_Table_Info (N); if Info in Int (Host_Id'First) .. Int (Host_Id'Last) then return Host_Id (Info); end if; return No_Host_Id; end Get_Host_Id; ---------------------- -- Get_Partition_Id -- ---------------------- function Get_Partition_Id (N : Name_Id) return Partition_Id is PID : Int; Info : Byte; begin Info := Get_Name_Table_Byte (Name (N)); PID := Int (Info) + Int (Partition_Id'First); if PID in Int (Partition_Id'First) .. Int (Partition_Id'Last) then return Partition_Id (PID); end if; return No_Partition_Id; end Get_Partition_Id; --------------------- -- Get_Rsh_Command -- --------------------- function Get_Rsh_Command return XE_Types.Name_Id is begin if No (Default_Rsh_Command) then return Id (XE_Defs.Get_Rsh_Command); end if; return Default_Rsh_Command; end Get_Rsh_Command; --------------------- -- Get_Rsh_Options -- --------------------- function Get_Rsh_Options return XE_Types.Name_Id is begin if No (Default_Rsh_Options) then return Id (XE_Defs.Get_Rsh_Options); end if; return Default_Rsh_Options; end Get_Rsh_Options; ----------------- -- Get_Tasking -- ----------------- function Get_Tasking (A : ALI_Id) return Tasking_Type is begin return ALIs.Table (A).Tasking; end Get_Tasking; ----------------- -- Get_Unit_Id -- ----------------- function Get_Unit_Id (N : Name_Id) return Unit_Id is Info : Int; begin Info := Get_Name_Table_Info (N); case Info is when Int (Unit_Id'First) .. Int (Unit_Id'Last) => null; when 0 => Info := Int (No_Unit_Id); when others => raise Program_Error; end case; return Unit_Id (Info); end Get_Unit_Id; ---------------- -- Initialize -- ---------------- procedure Initialize is P : Partition_Id; C : Channel_Id; N : Partition_Name_Type; F : Location_Id := No_Location_Id; L : Location_Id := No_Location_Id; begin -- Create default location Add_Location (F, L, Id (Get_Def_Storage_Name), Id (Get_Def_Storage_Data)); Default_Data_Location := F; -- Create default partition N := Get_Node_Name (Node_Id (Partition_Type_Node)); Create_Partition (N, Null_Node, P); Default_Partition_Id := P; -- Create default channel Channels.Increment_Last; C := Channels.Last; Default_Channel_Id := C; -- Set properties of default channel Channels.Table (C).Name := Get_Node_Name (Node_Id (Channel_Type_Node)); Channels.Table (C).Filter := No_Filter_Name; end Initialize; ---------------- -- Set_ALI_Id -- ---------------- procedure Set_ALI_Id (N : Name_Id; A : ALI_Id) is begin Set_Name_Table_Info (Name (N), Int (A)); end Set_ALI_Id; --------------------------- -- Set_Channel_Attribute -- --------------------------- procedure Set_Channel_Attribute (Attribute : Attribute_Id; Channel : Channel_Id) is Attr_Item : Variable_Id; Attr_Kind : Attribute_Type; begin -- Apply attribute to a channel. Attr_Kind := Get_Attribute_Kind (Component_Id (Attribute)); Attr_Item := Get_Component_Value (Component_Id (Attribute)); -- No attribute was really assigned. if Attr_Item = Null_Variable then return; end if; case Attr_Kind is when Attribute_CFilter => -- Only string literals are allowed here. if Get_Variable_Type (Attr_Item) /= String_Type_Node then Write_SLOC (Node_Id (Attribute)); Write_Name (Channels.Table (Channel).Name); Write_Str ("'s filter attribute must be "); Write_Str ("a string literal"); Write_Eol; raise Parsing_Error; end if; -- Does it apply to all channels ? Therefore, check -- that this has not already been done. if Channel = No_Channel_Id and then Channels.Table (Default_Channel_Id).Filter = No_Filter_Name then Channels.Table (Default_Channel_Id).Filter := Get_Variable_Name (Attr_Item); To_Lower (Channels.Table (Default_Channel_Id).Filter); -- Apply to one channel. Check that it has not already -- been done. elsif Channel /= No_Channel_Id and then Channels.Table (Channel).Filter = No_Filter_Name then Channels.Table (Channel).Filter := Get_Variable_Name (Attr_Item); To_Lower (Channels.Table (Channel).Filter); -- This operation has already been done ! else Write_SLOC (Node_Id (Attr_Item)); if Channel = No_Channel_Id then Write_Str ("predefined type Channel"); else Write_Name (Channels.Table (Channel).Name); end if; Write_Str ("'s filter attribute has been assigned twice"); Write_Eol; raise Parsing_Error; end if; when others => raise Fatal_Error; end case; end Set_Channel_Attribute; -------------------- -- Set_Channel_Id -- -------------------- procedure Set_Channel_Id (N : Name_Id; C : Channel_Id) is begin Set_Name_Table_Info (N, Int (C)); end Set_Channel_Id; ---------------------- -- Set_Conf_Unit_Id -- ---------------------- procedure Set_Conf_Unit_Id (N : Name_Id; U : Conf_Unit_Id) is begin Set_Name_Table_Info (Name (N), Int (U)); end Set_Conf_Unit_Id; ----------------- -- Set_Host_Id -- ----------------- procedure Set_Host_Id (N : Name_Id; H : Host_Id) is begin Set_Name_Table_Info (N, Int (H)); end Set_Host_Id; ----------------------------- -- Set_Partition_Attribute -- ----------------------------- procedure Set_Partition_Attribute (Attribute : Attribute_Id; Partition : Partition_Id) is Attr_Item : Variable_Id; Attr_Kind : Attribute_Type; Attr_Type : Type_Id; Comp_Node : Component_Id; Ada_Unit : Name_Id; Current : Partition_Type renames Partitions.Table (Partition); Host : Host_Id; Name : Name_Id; Data : Name_Id; procedure Write_Attr_Init_Error (Attr_Name : String); procedure Write_Attr_Kind_Error (Attr_Name : String; Attr_Kind : String); --------------------------- -- Write_Attr_Init_Error -- --------------------------- procedure Write_Attr_Init_Error (Attr_Name : String) is begin Write_SLOC (Node_Id (Attribute)); Write_Name (Partitions.Table (Partition).Name); Write_Str ("'s "); Write_Str (Attr_Name); Write_Str (" attribute has been assigned twice"); Write_Eol; raise Parsing_Error; end Write_Attr_Init_Error; --------------------------- -- Write_Attr_Kind_Error -- --------------------------- procedure Write_Attr_Kind_Error (Attr_Name : String; Attr_Kind : String) is begin Write_SLOC (Node_Id (Attribute)); Write_Name (Partitions.Table (Partition).Name); Write_Str ("'s "); Write_Str (Attr_Name); Write_Str (" attribute must be "); Write_Str (Attr_Kind); Write_Eol; raise Parsing_Error; end Write_Attr_Kind_Error; begin -- If this attribute applies to partition type itself, it may not -- have a value. No big deal, we use defaults. -- Apply attribute to a partition. Attr_Kind := Get_Attribute_Kind (Component_Id (Attribute)); Attr_Item := Get_Component_Value (Component_Id (Attribute)); -- No attribute was really assigned. if Attr_Item = Null_Variable then return; end if; case Attr_Kind is when Attribute_PFilter => -- Only string literals are allowed here. if Get_Variable_Type (Attr_Item) /= String_Type_Node then Write_Attr_Kind_Error ("filter", "a string literal"); end if; -- Does it apply to all partitions ? Therefore, check -- that this has not already been done. if Partition = Default_Partition_Id and then Current.Filter = No_Filter_Name then Current.Filter := Get_Variable_Name (Attr_Item); To_Lower (Current.Filter); -- Apply to one partition. Check that it has not already -- been done. elsif Partition /= Default_Partition_Id then Write_SLOC (Node_Id (Attribute)); Write_Str ("a partition filter attribute applies only to "); Write_Eol; Write_SLOC (Node_Id (Attribute)); Write_Str ("predefined type Partition"); Write_Eol; raise Parsing_Error; -- This operation has already been done ! else Write_Attr_Init_Error ("filter"); end if; when Attribute_Directory => -- Only strings are allowed here. if Get_Variable_Type (Attr_Item) /= String_Type_Node then Write_Attr_Kind_Error ("directory", "a string litteral"); end if; -- Check that it has not already been assigned. if Current.Executable_Dir = No_Directory_Name then Current.Executable_Dir := Get_Variable_Name (Attr_Item); else Write_Attr_Init_Error ("directory"); end if; when Attribute_Host => Attr_Type := Get_Variable_Type (Attr_Item); case Get_Type_Kind (Attr_Type) is when Pre_Type_String => Hosts.Increment_Last; Host := Hosts.Last; Hosts.Table (Host).Name := Get_Variable_Name (Attr_Item); Hosts.Table (Host).Static := True; when Pre_Type_Ada_Unit => Attr_Item := Get_Variable_Value (Attr_Item); Build_New_Host (Subprogram_Id (Attr_Item), Host); when others => Write_Attr_Kind_Error ("host", "of string type"); end case; -- Check that it has not already been assigned. if Current.Host = No_Host_Id then Current.Host := Host; else Write_Attr_Init_Error ("host"); end if; when Attribute_Main => -- Check that it has not already been assigned. if Current.Main_Subprogram = No_Main_Subprogram then Current.Main_Subprogram := Get_Variable_Name (Attr_Item); -- We are not sure at this point that this unit -- has been configured on partition. Ada_Unit := Get_Variable_Name (Attr_Item); Add_Conf_Unit (Ada_Unit, Partition); else Write_Attr_Init_Error ("main"); end if; when Attribute_Command_Line => -- Only strings are allowed. if Get_Variable_Type (Attr_Item) /= String_Type_Node then Write_Attr_Kind_Error ("command_line", "a string litteral"); end if; -- Check that this has not already been assigned. if Current.Command_Line = No_Command_Line then Current.Command_Line := Get_Variable_Name (Attr_Item); else Write_Attr_Init_Error ("command_line"); end if; when Attribute_Termination => if Get_Variable_Type (Attr_Item) /= Integer_Type_Node then Write_Attr_Kind_Error ("termination", "of termination type"); end if; -- Check that it has not already been assigned. if Current.Termination = No_Termination then Current.Termination := Termination_Type (Get_Scalar_Value (Attr_Item)); else Write_Attr_Init_Error ("termination"); end if; when Attribute_Passive => if Get_Variable_Type (Attr_Item) /= Boolean_Type_Node then Write_Attr_Kind_Error ("passive", "of boolean type"); end if; -- Check that it has not already been assigned. if Current.Passive = BMaybe then Current.Passive := Boolean_Type (Get_Scalar_Value (Attr_Item)); else Write_Attr_Init_Error ("passive"); end if; when Attribute_Allow_Light_PCS => if Get_Variable_Type (Attr_Item) /= Boolean_Type_Node then Write_Attr_Kind_Error ("allow_light_pcs", "of boolean type"); end if; -- Check that it has not already been assigned. if Current.Light_PCS = BMaybe then Current.Light_PCS := Boolean_Type (Get_Scalar_Value (Attr_Item)); else Write_Attr_Init_Error ("allow_light_pcs"); end if; when Attribute_Reconnection => if Get_Variable_Type (Attr_Item) /= Integer_Type_Node then Write_Attr_Kind_Error ("reconnection", "of reconnection type"); end if; -- Check that it has not already been assigned. if Current.Reconnection = No_Reconnection then Current.Reconnection := Convert (Get_Scalar_Value (Attr_Item)); else Write_Attr_Init_Error ("reconnection"); end if; when Attribute_Leader => -- Internal attribute. Don't check anything. if Partition /= No_Partition_Id then if Main_Partition /= No_Partition_Id then Write_SLOC (Node_Id (Attribute)); Write_Str ("multiple definitions of "); Write_Str ("application main subprogram not allowed"); Write_Eol; raise Parsing_Error; end if; Main_Partition := Partition; end if; when Attribute_Task_Pool => First_Variable_Component (Attr_Item, Comp_Node); for B in Current.Task_Pool'Range loop begin Get_Name_String (Get_Variable_Name (Get_Component_Value (Comp_Node))); Current.Task_Pool (B) := Int'Value (Name_Buffer (1 .. Name_Len)); exception when others => Write_SLOC (Node_Id (Attribute)); Write_Str ("incorrect integer value"); Write_Eol; raise Parsing_Error; end; Next_Variable_Component (Comp_Node); end loop; when Attribute_Storage => if Current.Storage_Loc = No_Location_Id then First_Variable_Component (Attr_Item, Comp_Node); Name := Get_Variable_Name (Get_Component_Value (Comp_Node)); Next_Variable_Component (Comp_Node); Data := Get_Variable_Name (Get_Component_Value (Comp_Node)); -- Check validity of choosen storage support if Storage_Supports.Get (Name) = Unknown_Storage_Support then Write_Attr_Kind_Error ("storage", "an available storage support"); end if; declare LID : Location_Id; begin Locations.Increment_Last; LID := Locations.Last; Locations.Table (LID).Major := Name; Locations.Table (LID).Minor := Data; Locations.Table (LID).Next_Location := No_Location_Id; Current.Storage_Loc := LID; end; else Write_Attr_Init_Error ("storage"); end if; when Attribute_Protocol => if Current.First_Network_Loc = No_Location_Id then Attr_Type := Get_Variable_Type (Attr_Item); case Get_Type_Kind (Attr_Type) is when Pre_Type_Location => First_Variable_Component (Attr_Item, Comp_Node); Name := Get_Variable_Name (Get_Component_Value (Comp_Node)); Next_Variable_Component (Comp_Node); Data := Get_Variable_Name (Get_Component_Value (Comp_Node)); Add_Location (Current.First_Network_Loc, Current.Last_Network_Loc, Name, Data); when Pre_Type_Locations => First_Variable_Component (Attr_Item, Comp_Node); while Comp_Node /= Null_Component loop declare C : Component_Id; V : Variable_Id; begin V := Get_Component_Value (Comp_Node); First_Variable_Component (V, C); Name := Get_Variable_Name (Get_Component_Value (C)); Next_Variable_Component (C); Data := Get_Variable_Name (Get_Component_Value (C)); Add_Location (Current.First_Network_Loc, Current.Last_Network_Loc, Name, Data); end; Next_Variable_Component (Comp_Node); end loop; when others => raise Parsing_Error; end case; else Write_Attr_Init_Error ("location"); end if; when Attribute_Priority => if Get_Variable_Type (Attr_Item) /= Integer_Type_Node then Write_Attr_Kind_Error ("priority", "of priority type"); end if; -- Check that it has not already been assigned. if Current.Priority = No_Priority then begin Get_Name_String (Get_Variable_Name (Attr_Item)); Current.Priority := Priority_Type'Value (Name_Buffer (1 .. Name_Len)); exception when others => Write_SLOC (Node_Id (Attribute)); Write_Str ("incorrect integer value"); Write_Eol; raise Parsing_Error; end; else Write_Attr_Init_Error ("priority"); end if; when Attribute_Environment_Variables => First_Variable_Component (Attr_Item, Comp_Node); while Comp_Node /= Null_Component loop Add_Environment_Variable (Current.First_Env_Var, Current.Last_Env_Var, Get_Variable_Name (Get_Component_Value (Comp_Node))); Next_Variable_Component (Comp_Node); end loop; when Attribute_ORB_Tasking_Policy => if Get_Variable_Type (Attr_Item) /= Integer_Type_Node then Write_Attr_Kind_Error ("ORB tasking policy", "of ORB tasking policy type"); end if; -- Check that it has not already been assigned. if Current.ORB_Tasking_Policy = No_ORB_Tasking_Policy then Current.ORB_Tasking_Policy := ORB_Tasking_Policy_Type (Get_Scalar_Value (Attr_Item)); else Write_Attr_Init_Error ("ORB_Tasking_Policy"); end if; when Attribute_CFilter | Attribute_Unknown => raise Fatal_Error; end case; end Set_Partition_Attribute; ---------------------- -- Set_Partition_Id -- ---------------------- procedure Set_Partition_Id (N : Name_Id; P : Partition_Id) is Info : constant Int := Int (P) - Int (Partition_Id'First); begin Set_Name_Table_Byte (N, Byte (Info)); end Set_Partition_Id; -------------------------- -- Set_Pragma_Statement -- -------------------------- procedure Set_Pragma_Statement (Subprogram : Subprogram_Id) is Pragma_Kind : Pragma_Type; Parameter : Parameter_Id; Method : Import_Method_Type; Value : Variable_Id; Host : Host_Id; Name : Name_Id; Data : Name_Id; Param_Type : Type_Id; Param_Kind : Predefined_Type; begin -- Apply pragma statement. Pragma_Kind := Get_Pragma_Kind (Subprogram); First_Subprogram_Parameter (Subprogram, Parameter); case Pragma_Kind is when Pragma_Import => Value := Get_Parameter_Value (Parameter); Method := Convert (Get_Scalar_Value (Value)); Next_Subprogram_Parameter (Parameter); Value := Get_Parameter_Value (Parameter); Value := Get_Variable_Value (Value); -- We are not sure that this function has been already -- declared as an host function. Build_New_Host (Subprogram_Id (Value), Host); -- Apply Import pragma ... Hosts.Table (Host).Import := Method; Next_Subprogram_Parameter (Parameter); Value := Get_Parameter_Value (Parameter); Hosts.Table (Host).External := Get_Variable_Name (Value); when Pragma_Remote_Shell => Value := Get_Parameter_Value (Parameter); Default_Rsh_Command := Get_Variable_Name (Value); Next_Subprogram_Parameter (Parameter); Value := Get_Parameter_Value (Parameter); Default_Rsh_Options := Get_Variable_Name (Value); when Pragma_Starter => Value := Get_Parameter_Value (Parameter); Default_Starter := Convert (Get_Scalar_Value (Value)); when Pragma_Boot_Location => if Default_First_Boot_Location /= No_Location_Id then Write_SLOC (Node_Id (Subprogram)); Write_Str ("multiple boot location definition not allowed"); Write_Eol; raise Parsing_Error; end if; Param_Type := Get_Parameter_Type (Parameter); Param_Kind := Get_Type_Kind (Param_Type); case Param_Kind is when Pre_Type_String => Value := Get_Parameter_Value (Parameter); Name := Get_Variable_Name (Value); Next_Subprogram_Parameter (Parameter); Value := Get_Parameter_Value (Parameter); Data := Get_Variable_Name (Value); Add_Location (Default_First_Boot_Location, Default_Last_Boot_Location, Name, Data); when Pre_Type_Location => declare V : Variable_Id; C : Component_Id; begin V := Get_Parameter_Value (Parameter); First_Variable_Component (V, C); Name := Get_Variable_Name (Get_Component_Value (C)); Next_Variable_Component (C); Data := Get_Variable_Name (Get_Component_Value (C)); Add_Location (Default_First_Boot_Location, Default_Last_Boot_Location, Name, Data); end; when Pre_Type_Locations => declare V1 : Variable_Id; C1 : Component_Id; begin V1 := Get_Parameter_Value (Parameter); First_Variable_Component (V1, C1); while C1 /= Null_Component loop declare V2 : Variable_Id; C2 : Component_Id; begin V2 := Get_Component_Value (C1); First_Variable_Component (V2, C2); Name := Get_Variable_Name (Get_Component_Value (C2)); Next_Variable_Component (C2); Data := Get_Variable_Name (Get_Component_Value (C2)); Add_Location (Default_First_Boot_Location, Default_Last_Boot_Location, Name, Data); end; Next_Variable_Component (C1); end loop; end; when others => raise Program_Error; end case; when Pragma_Version => Value := Get_Parameter_Value (Parameter); Default_Version_Check := (Get_Scalar_Value (Value) = Int (BTrue)); when Pragma_Reg_Filter => Value := Get_Parameter_Value (Parameter); Default_Registration_Filter := Get_Variable_Name (Value); when Pragma_Priority => Value := Get_Parameter_Value (Parameter); Default_Priority_Policy := Convert (Get_Scalar_Value (Value)); when Pragma_Name_Server => Value := Get_Parameter_Value (Parameter); Default_Name_Server := Convert (Get_Scalar_Value (Value)); when Pragma_Unknown => raise Program_Error; end case; end Set_Pragma_Statement; ----------------- -- Set_Tasking -- ----------------- procedure Set_Tasking (A : ALI_Id; T : Tasking_Type) is begin ALIs.Table (A).Tasking := T; end Set_Tasking; ------------------------ -- Set_Type_Attribute -- ------------------------ procedure Set_Type_Attribute (Pre_Type : Type_Id) is Component_Node : Component_Id; Pre_Type_Id : Predefined_Type; begin if Is_Type_Composite (Pre_Type) then Pre_Type_Id := Get_Type_Kind (Pre_Type); First_Type_Component (Pre_Type, Component_Node); while Component_Node /= Null_Component loop if Get_Attribute_Kind (Component_Node) /= Attribute_Unknown and then Is_Component_Initialized (Component_Node) then case Pre_Type_Id is when Pre_Type_Partition => Set_Partition_Attribute (Attribute_Id (Component_Node), Default_Partition_Id); when Pre_Type_Channel => Set_Channel_Attribute (Attribute_Id (Component_Node), Default_Channel_Id); when others => null; end case; end if; Next_Type_Component (Component_Node); end loop; end if; end Set_Type_Attribute; ----------------- -- Set_Unit_Id -- ----------------- procedure Set_Unit_Id (N : Name_Id; U : Unit_Id) is begin Set_Name_Table_Info (N, Int (U)); end Set_Unit_Id; ------------------------ -- Show_Configuration -- ------------------------ procedure Show_Configuration is begin Write_Line (" ------------------------------"); Write_Line (" ---- Configuration report ----"); Write_Line (" ------------------------------"); Write_Eol; Write_Line ("Configuration :"); Write_Field (1, "Name"); Write_Name (Configuration); Write_Eol; Write_Field (1, "Main"); Write_Name (Main_Subprogram); Write_Eol; Write_Field (1, "Starter"); case Default_Starter is when Ada_Import => Write_Str ("Ada code"); when Shell_Import => Write_Str ("shell script"); when None_Import => Write_Str ("none"); end case; Write_Eol; if Default_Name_Server /= No_Name_Server then Write_Field (1, "Name_Server"); Write_Name (Name_Server_Img (Default_Name_Server)); Write_Eol; end if; if Default_First_Boot_Location /= No_Location_Id then Write_Field (1, "Protocols"); declare LID : Location_Id := Default_First_Boot_Location; One : constant Boolean := (Locations.Table (LID).Next_Location = No_Location_Id); begin if One then Write_Name (Locations.Table (LID).Major); Write_Str ("://"); Write_Name (Locations.Table (LID).Minor); else while LID /= No_Location_Id loop Write_Eol; Write_Str (" - "); Write_Name (Locations.Table (LID).Major); Write_Str ("://"); Write_Name (Locations.Table (LID).Minor); LID := Locations.Table (LID).Next_Location; end loop; end if; Write_Eol; end; end if; for P in Partitions.First + 1 .. Partitions.Last loop Write_Eol; Show_Partition (P); end loop; Write_Line (" -------------------------------"); if Channels.First + 1 <= Channels.Last then Write_Eol; declare P : Partition_Id; F : Name_Id; begin for C in Channels.First + 1 .. Channels.Last loop Write_Str ("Channel "); Write_Name (Channels.Table (C).Name); Write_Eol; Write_Field (1, "Partition 1"); P := Channels.Table (C).Lower.My_Partition; Write_Name (Partitions.Table (P).Name); Write_Eol; Write_Field (1, "Partition 2"); P := Channels.Table (C).Upper.My_Partition; Write_Name (Partitions.Table (P).Name); Write_Eol; F := Channels.Table (C).Filter; if F /= No_Filter_Name then Write_Field (1, "Filter"); Write_Name (F); Write_Eol; end if; Write_Eol; end loop; end; Write_Line (" -------------------------------"); end if; end Show_Configuration; -------------------- -- Show_Partition -- -------------------- procedure Show_Partition (P : Partition_Id) is H : Host_Id; U : Conf_Unit_Id; I : Unit_Id; V : Env_Var_Id; Current : Partition_Type renames Partitions.Table (P); begin Write_Str ("Partition "); Write_Name (Current.Name); Write_Eol; if Present (Current.Main_Subprogram) then Write_Field (1, "Main"); Write_Name (Current.Main_Subprogram); Write_Eol; end if; H := Partitions.Table (P).Host; if H = No_Host_Id then H := Partitions.Table (Default_Partition_Id).Host; end if; if H /= No_Host_Id then Write_Field (1, "Host"); if Hosts.Table (H).Static then Write_Name (Hosts.Table (H).Name); else Write_Str ("function call :: "); Write_Name (Hosts.Table (H).External); case Hosts.Table (H).Import is when None_Import => null; when Ada_Import => Write_Str (" (ada)"); when Shell_Import => Write_Str (" (shell)"); end case; end if; Write_Eol; end if; if Present (Current.Executable_Dir) then Write_Field (1, "Directory"); Write_Name (Current.Executable_Dir); Write_Eol; end if; if Present (Current.Command_Line) then Write_Field (1, "Command"); Write_Name (Current.Command_Line); Write_Eol; end if; if Current.ORB_Tasking_Policy /= No_ORB_Tasking_Policy then Write_Field (1, "ORB tasking"); case Current.ORB_Tasking_Policy is when Thread_Pool => Write_Str ("thread pool"); when Thread_Per_Session => Write_Str ("thread per session"); when Thread_Per_Request => Write_Str ("thread per request"); when No_ORB_Tasking_Policy => null; end case; Write_Eol; end if; if Current.Task_Pool /= No_Task_Pool then Write_Field (1, "Task Pool"); for J in Current.Task_Pool'Range loop Write_Int (Current.Task_Pool (J)); Write_Str (" "); end loop; Write_Eol; end if; if Current.Priority /= No_Priority then Write_Field (1, "Priority"); Write_Int (Int (Current.Priority)); Write_Eol; end if; if Current.Termination /= No_Termination then Write_Field (1, "Termination"); case Current.Termination is when Local_Termination => Write_Str ("local"); when Global_Termination => Write_Str ("global"); when Deferred_Termination => Write_Str ("deferred"); when No_Termination => null; end case; Write_Eol; end if; if Current.First_Network_Loc /= No_Location_Id then Write_Field (1, "Protocols"); Write_Eol; declare L : Location_Id := Current.First_Network_Loc; begin while L /= No_Location_Id loop Write_Str (" - "); Write_Name (Locations.Table (L).Major); if Present (Locations.Table (L).Minor) then Write_Str ("://"); Write_Name (Locations.Table (L).Minor); end if; Write_Eol; L := Locations.Table (L).Next_Location; end loop; end; end if; if Current.Storage_Loc /= No_Location_Id then Write_Field (1, "Storages"); Write_Eol; declare L : Location_Id := Current.Storage_Loc; begin while L /= No_Location_Id loop Write_Str (" - "); Write_Name (Locations.Table (L).Major); if Present (Locations.Table (L).Minor) then Write_Str ("://"); Write_Name (Locations.Table (L).Minor); end if; Write_Eol; L := Locations.Table (L).Next_Location; end loop; end; end if; if Current.Light_PCS = BFalse then Write_Field (1, "Light PCS"); Write_Str ("false"); Write_Eol; end if; if Partitions.Table (P).First_Unit /= No_Conf_Unit_Id then Write_Field (1, "Units"); Write_Eol; U := Partitions.Table (P).First_Unit; while U /= No_Conf_Unit_Id loop Write_Str (" - "); Write_Name (Conf_Units.Table (U).Name); Write_Str (" ("); -- Indicate unit categorization I := Conf_Units.Table (U).My_Unit; if I = No_Unit_Id then -- Case where the unit has not been compiled succesfully Write_Str ("unavailable"); elsif Units.Table (I).RCI then Write_Str ("rci"); elsif Units.Table (I).Remote_Types then Write_Str ("rt"); elsif Units.Table (I).Shared_Passive then Write_Str ("sp"); else Write_Str ("normal"); end if; -- Indicate if unit is configured automatically by the PCS if Conf_Units.Table (U).Name = PCS_Conf_Unit then Write_Str (", from PCS"); end if; Write_Line (")"); U := Conf_Units.Table (U).Next_Unit; end loop; end if; if Partitions.Table (P).First_Env_Var /= No_Env_Var_Id then Write_Field (1, "Environment variables"); Write_Eol; V := Partitions.Table (P).First_Env_Var; while V /= No_Env_Var_Id loop Write_Str (" - """); Write_Name (Env_Vars.Table (V).Name); Write_Line (""""); V := Env_Vars.Table (V).Next_Env_Var; end loop; end if; end Show_Partition; -------------- -- To_Build -- -------------- function To_Build (U : Conf_Unit_Id) return Boolean is begin return Partitions.Table (Conf_Units.Table (U).Partition).To_Build; end To_Build; ------------------------------ -- Update_Most_Recent_Stamp -- ------------------------------ procedure Update_Most_Recent_Stamp (P : Partition_Id; F : File_Name_Type) is Most_Recent : File_Name_Type; begin if Debug_Mode then Message (" update stamp for", Partitions.Table (P).Name, "from", F); end if; Most_Recent := Partitions.Table (P).Most_Recent; if No (Most_Recent) then Partitions.Table (P).Most_Recent := F; if Debug_Mode then Write_Program_Name; Write_Str (": "); Write_Name (Partitions.Table (P).Name); Write_Str ("'s most recent stamp comes from "); Write_Name (F); Write_Eol; end if; elsif File_Time_Stamp (F) > File_Time_Stamp (Most_Recent) then Partitions.Table (P).Most_Recent := F; if Debug_Mode then Write_Program_Name; Write_Str (": "); Write_Name (Partitions.Table (P).Name); Write_Str (" most recent file updated to "); Write_Name (F); Write_Eol; Write_Stamp_Comparison (F, Most_Recent); Write_Eol; end if; end if; end Update_Most_Recent_Stamp; ----------------- -- Write_Field -- ----------------- procedure Write_Field (Indent : Natural; Field : String; Width : Natural := Min_Field_Width) is W : Natural := Width; begin for I in 1 .. Indent loop Write_Str (" "); end loop; if Field'Length > W then W := Field'Length; end if; declare L : String (1 .. W) := (others => ' '); begin L (1 .. Field'Length) := Field; Write_Str (L); end; Write_Str (" : "); end Write_Field; end XE_Front; polyorb-2.8~20110207.orig/compilers/gnatdist/xe_storages.adb0000644000175000017500000000601511750740337023217 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- X E _ S T O R A G E S -- -- -- -- B o d y -- -- -- -- Copyright (C) 2008, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with XE_Utils; use XE_Utils; with XE_Names; use XE_Names; package body XE_Storages is ----------- -- Equal -- ----------- function Equal (N1, N2 : Name_Id) return Boolean is begin return N1 = N2; end Equal; ---------- -- Hash -- ---------- function Hash (N : Name_Id) return Hash_Header is Name : constant String := Get_Name_String (N); H : Natural := 0; begin for J in Name'Range loop H := (H + Character'Pos (Name (J))) mod (Hash_Header'Last + 1); end loop; return H; end Hash; ---------------------- -- Register_Storage -- ---------------------- procedure Register_Storage (Storage_Name : String; Allow_Passive : Boolean; Allow_Local_Term : Boolean; Need_Tasking : Boolean) is begin Storage_Supports.Set (Id (Storage_Name), Storage_Support_Type' (Allow_Passive, Allow_Local_Term, Need_Tasking)); end Register_Storage; end XE_Storages; polyorb-2.8~20110207.orig/compilers/gnatdist/xe_back-garlic.ads0000644000175000017500000000412111750740337023544 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- X E _ B A C K . G A R L I C -- -- -- -- S p e c -- -- -- -- Copyright (C) 1995-2008, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ package XE_Back.GARLIC is pragma Elaborate_Body; end XE_Back.GARLIC; polyorb-2.8~20110207.orig/compilers/gnatdist/xe_back.ads0000644000175000017500000001714511750740337022317 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- X E _ B A C K -- -- -- -- S p e c -- -- -- -- Copyright (C) 1995-2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- This package and its children define all the routines to generate stubs -- (object files), skeleton files (object files), PCS units (source and -- object files) and eventually executable files. with XE_Types; use XE_Types; with XE_Units; use XE_Units; package XE_Back is type Backend is abstract tagged limited private; type Backend_Access is access all Backend'Class; procedure Set_PCS_Dist_Flags (Self : access Backend) is abstract; -- Set PCS-specific default command line flags procedure Initialize (Self : access Backend) is abstract; -- Initialize the backend procedure Run_Backend (Self : access Backend) is abstract; -- Generate stubs, skels, PCS units and executables. procedure Register_Storages (Self : access Backend) is abstract; -- Register available storage supports function Find_Backend (PCS_Name : String) return Backend_Access; -- Return an instance of the backend appropriate for the specified PCS function Get_Detach_Flag (Self : access Backend) return Name_Id is abstract; -- Returns the flag for detaching a partition from command line PCS_Conf_Unit : Name_Id := No_Name; -- Define a PCS unit that gnatdist has to automatically configure -- on the main partition. private type Backend is abstract tagged limited null record; function "and" (N : Name_Id; S : String) return Name_Id; function "and" (L, R : Name_Id) return Name_Id; procedure Register_Backend (PCS_Name : String; The_Backend : Backend_Access); procedure Generate_Partition_Project_File (D : Directory_Name_Type; P : Partition_Id := No_Partition_Id); -- Generate a project file extending the user's project to build -- one partition. procedure Generate_All_Stubs_And_Skels; -- Generates needed stubs and skels for all the partitions procedure Generate_Skel (A : ALI_Id; P : Partition_Id); -- Create skel for a RCI or SP unit and store them in the -- directory of the partition on which the unit is assigned. procedure Generate_Stub (A : ALI_Id); -- Create stub and skel for a RCI or SP unit. procedure Generate_Stamp_File (P : Partition_Id); -- Create a stamp file in which the executable file stamp and the -- configuration file stamp are stored. procedure Generate_Starter_File (Backend : Backend_Access); -- Create the starter file to launch the other partitions from -- main partition subprogram. This can be a shell script or an Ada -- program. function Get_Env_Vars (P : Partition_Id; Q : Character := ' '; Names_Only : Boolean) return String; -- Return a series of environment variables assignment for partition P -- (if Names_Only is False, in which case values are encosed with Q), or a -- space separated list of environment variable names only (if Names_Only -- is True). procedure Generate_Application_Project_Files; -- Generate a project file for the appplication code, extending the one -- provided by the user (if any), and including a dependency upon the PCS -- project. This is PCS independent. procedure Initialize; -- Initialize PCS-independent backend information procedure Prepare_Directories; -- Create partition and executable directories, and clean old object files function Rebuild_Partition (P : Partition_Id) return Boolean; -- Check various file stamps to decide whether the partition -- executable should be regenerated. Load the partition stamp file -- which contains the configuration file stamp, executable file -- stamp and the most recent object file stamp. If one of these -- stamps is not the same, rebuild the partition. Note that for -- instance we ensure that a partition executable coming from -- another configuration is detected as inconsistent. procedure Write_Call (SP : Unit_Name_Type; N1 : Name_Id := No_Name; S1 : String := No_Str; N2 : Name_Id := No_Name; S2 : String := No_Str; N3 : Name_Id := No_Name; S3 : String := No_Str; I1_Present : Boolean := False; I1 : Int := -1); -- Insert a procedure call. The first non-null parameter is supposed to be -- the procedure name. The next parameters are parameters for this -- procedure call. function Location_List_Image (Location : Location_Id) return Name_Id; -- Explore linked list of locations to build its image procedure Write_Image (I : out Name_Id; H : Host_Id; P : Partition_Id); -- Write in I the text to get the partition hostname. This can be -- a shell script. procedure Write_With_Clause (W : Name_Id; U : Boolean := False; E : Boolean := False); -- Add a with clause W, a use clause when U is true and an Elaborate_All -- pragma when E is true. function Prefix (Check_For : String) return String; -- Return the PCS installation prefix as dynamically determined by the -- location of the gnatdist executable, or fall back to the default -- (configure-time) prefix. The validity of a candidate prefix is -- checked by testing whether file Check_For exists under that prefix. -- The returned string always ends with a directory separator. procedure Apply_Casing_Rules (S : in out String); procedure Register_Casing_Rule (S : String); -- ??? documentation needed! function Partition_Dir_Flag (P : Partition_Id) return String; -- Return a gnatmake command line flag setting external variable -- PARTITION_DIR for partition P. Build_Stamp_File : File_Name_Type; Partition_Main_File : File_Name_Type; Partition_Main_Name : Unit_Name_Type; end XE_Back; polyorb-2.8~20110207.orig/compilers/gnatdist/xe_usage.ads0000644000175000017500000000403311750740337022513 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- X E _ U S A G E -- -- -- -- S p e c -- -- -- -- Copyright (C) 1995-2008, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ procedure XE_Usage; polyorb-2.8~20110207.orig/compilers/gnatdist/xe_defs.ads0000644000175000017500000000476411750740337022343 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- X E _ D E F S -- -- -- -- S p e c -- -- -- -- Copyright (C) 1995-2008, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ package XE_Defs is -- This package provides the definition of various GLADE parameters procedure Initialize; function Get_Rsh_Command return String; function Get_Rsh_Options return String; function Get_Def_Storage_Data return String; function Get_Def_Storage_Name return String; function Get_Def_Protocol_Data return String; function Get_Def_Protocol_Name return String; function Get_PCS_Name return String; procedure Set_PCS_Name (S : String); end XE_Defs; polyorb-2.8~20110207.orig/compilers/gnatdist/xe.adb0000644000175000017500000013063711750740337021320 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- X E -- -- -- -- B o d y -- -- -- -- Copyright (C) 1995-2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with GNAT.Table; with XE_Names; use XE_Names; with XE_Flags; use XE_Flags; with XE_IO; use XE_IO; with XE_Utils; use XE_Utils; package body XE is type Node_Kind is (K_Configuration, K_List, K_Type, K_Subprogram, K_Statement, K_Component, K_Variable); type Node_Type is record Kind : Node_Kind; Loc_X : Int := 0; Loc_Y : Int := 0; Name : Name_Id; Node_1 : Node_Id; Node_2 : Node_Id; Node_3 : Node_Id; Flag_1 : Boolean; Value : Int; end record; -- list -- node_1 : list head -- node_2 : list tail -- node_3 : component type -- flag_1 : unused -- value : length -- subprogram -- node_1 : next declaration -- node_2 : appl. main procedure -- node_3 : parameter list -- flag_1 : is a procedure -- value : pragma_type -- type -- node_1 : next declaration -- node_2 : array component type -- node_3 : component list -- flag_1 : unused -- value : predefined_type -- variable -- node_1 : next declaration -- node_2 : variable type -- node_3 : component list | subprogram (1) -- flag_1 : initialized -- value : when list: number of components; when scalar: value -- component -- node_1 : next component -- node_2 : component type -- node_3 : component value -- flag_1 : initialized -- value : attribute_type -- statement -- node_1 : next declaration -- node_2 : subprogram call -- node_3 : unused -- flag_1 : unused -- value : unused -- configuration -- node_1 : declaration head (in another way, next declaration) -- node_2 : declaration tail -- node_3 : previous configuration -- flag_1 : unused -- value : unused -- -- (1) Ada units are in our context enumeration literal, but in the -- context of Ada, there are also subprograms. When the variable type -- is Pre_Type_Ada_Unit, then the value of this variable is a -- subprogram. N_Anonymous_Variable : Int := 0; -- Count the number of created anonymous variables. package Nodes is new GNAT.Table (Table_Component_Type => Node_Type, Table_Index_Type => Node_Id, Table_Low_Bound => First_Node, Table_Initial => 200, Table_Increment => 100); procedure Create_Node (Node : out Node_Id; Name : Name_Id; Kind : Node_Kind); function Is_List (Node : Node_Id) return Boolean; function Is_Of_Kind (Node : Node_Id; Kind : Node_Kind) return Boolean; ----------------------------------- -- Add_Configuration_Declaration -- ----------------------------------- procedure Add_Configuration_Declaration (Configuration_Node : Configuration_Id; Declaration_Node : Node_Id) is CN : constant Node_Id := Node_Id (Configuration_Node); DN : constant Node_Id := Declaration_Node; begin pragma Assert (Is_Configuration (CN)); if Is_Configuration (DN) then -- If Conf has already a configuration in its scope, then -- insert the new configuration in between. Then, link the -- last declaration of the new configuration with Conf. if Nodes.Table (CN).Node_3 /= Null_Node then Add_Configuration_Declaration (Configuration_Id (DN), Nodes.Table (CN).Node_3); Nodes.Table (DN).Node_3 := CN; else Nodes.Table (CN).Node_3 := DN; -- If the new configuration has declarations in it, then -- link the last declaration with Conf. if Nodes.Table (DN).Node_2 /= Null_Node then Nodes.Table (Nodes.Table (DN).Node_2).Node_1 := CN; else Nodes.Table (DN).Node_1 := CN; end if; end if; elsif Nodes.Table (CN).Node_2 /= Null_Node then -- In this case, Conf contains declarations. The last -- declaration of Conf may point to another -- configuration. When we add a declaration at the end of -- this configuration, we have to save the link to the other -- configuration in the new declaration node. Nodes.Table (DN).Node_1 := Nodes.Table (Nodes.Table (CN).Node_2).Node_1; Nodes.Table (Nodes.Table (CN).Node_2).Node_1 := DN; Nodes.Table (CN).Node_2 := DN; else -- Conf is empty. Nodes.Table (DN).Node_1 := Nodes.Table (CN).Node_1; Nodes.Table (CN).Node_2 := DN; Nodes.Table (CN).Node_1 := DN; end if; -- When we add a configuration to another configuration we want the -- the following structure. This is done to ensure that we explore -- all the declarations by following node_1 of each node. To start -- from the beginning of the declarations of a configuration, we -- first jump to the previous configurations by following node_3 -- of each configuration node. -- -- conf-root node node -- +--------+ +--------+ +--------+ -- | node 1 |------->| node 1 |-------->| node 1 | -- +--------+ +--------+ +--------+ -- | node 2 |- | node 2 | | node 2 | -- +--------+ \ +--------+ +--------+ -- | node 3 | \ | node 3 | --->| node 3 | -- +--------+ \ +--------+ / +--------+ -- | ^ ------------------ -- | | -- | \ -- | ------------------------------- -- | \ -- v | -- conf-decl node node -- +--------+ +--------+ +--------+ -- | node 1 |------->| node 1 |-------->| node 1 | -- +--------+ +--------+ +--------+ -- | node 2 |- | node 2 | | node 2 | -- +--------+ \ +--------+ +--------+ -- | node 3 | \ | node 3 | --->| node 3 | -- +--------+ \ +--------+ / +--------+ -- ----------------- end Add_Configuration_Declaration; ------------------------------ -- Add_Subprogram_Parameter -- ------------------------------ procedure Add_Subprogram_Parameter (Subprogram_Node : Subprogram_Id; Parameter_Node : Parameter_Id) is Node : constant Node_Id := Node_Id (Subprogram_Node); List : Node_Id; Value : constant Node_Id := Node_Id (Parameter_Node); begin pragma Assert (Is_Subprogram (Node)); -- Get the list of the actual or formal parameters. List := Nodes.Table (Node).Node_3; pragma Assert (Is_List (List)); if Nodes.Table (List).Node_1 = Null_Node then Nodes.Table (List).Node_1 := Value; Nodes.Table (List).Node_2 := Value; else Nodes.Table (Nodes.Table (List).Node_2).Node_1 := Value; Nodes.Table (List).Node_2 := Value; end if; end Add_Subprogram_Parameter; ------------------------ -- Add_Type_Component -- ------------------------ procedure Add_Type_Component (Type_Node : Type_Id; Component_Node : Component_Id) is TN : constant Node_Id := Node_Id (Type_Node); CL : Node_Id; CN : constant Node_Id := Node_Id (Component_Node); begin pragma Assert (Is_Type (TN)); CL := Nodes.Table (TN).Node_3; pragma Assert (Is_List (CL)); if Nodes.Table (CL).Node_1 = Null_Node then Nodes.Table (CL).Node_1 := CN; Nodes.Table (CL).Node_2 := CN; else Nodes.Table (Nodes.Table (CL).Node_2).Node_1 := CN; Nodes.Table (CL).Node_2 := CN; end if; end Add_Type_Component; ---------------------------- -- Add_Variable_Component -- ---------------------------- procedure Add_Variable_Component (Variable_Node : Variable_Id; Component_Node : Component_Id) is Node : constant Node_Id := Node_Id (Variable_Node); List : Node_Id; Value : constant Node_Id := Node_Id (Component_Node); begin pragma Assert (Is_Variable (Node)); List := Nodes.Table (Node).Node_3; pragma Assert (Is_List (List)); if Nodes.Table (List).Node_1 = Null_Node then Nodes.Table (List).Node_1 := Value; Nodes.Table (List).Node_2 := Value; else Nodes.Table (Nodes.Table (List).Node_2).Node_1 := Value; Nodes.Table (List).Node_2 := Value; end if; end Add_Variable_Component; ------------------------------ -- Component_Is_Initialized -- ------------------------------ procedure Component_Is_Initialized (Component_Node : Component_Id; Is_Initialized : Boolean) is Node : constant Node_Id := Node_Id (Component_Node); begin pragma Assert (Is_Component (Node)); Nodes.Table (Node).Flag_1 := Is_Initialized; end Component_Is_Initialized; ------------- -- Convert -- ------------- function Convert (Item : Attribute_Type) return Int is begin return Int (Item); end Convert; ------------- -- Convert -- ------------- function Convert (Item : Int) return Attribute_Type is begin pragma Assert (Item in Int (Attribute_Type'First) .. Int (Attribute_Type'Last)); return Attribute_Type (Item); end Convert; ------------- -- Convert -- ------------- function Convert (Item : Import_Method_Type) return Int is begin return Int (Item); end Convert; ------------- -- Convert -- ------------- function Convert (Item : Int) return Import_Method_Type is begin pragma Assert (Item in Int (Import_Method_Type'First) .. Int (Import_Method_Type'Last)); return Import_Method_Type (Item); end Convert; ------------- -- Convert -- ------------- function Convert (Item : Pragma_Type) return Int is begin return Int (Item); end Convert; ------------- -- Convert -- ------------- function Convert (Item : Int) return Pragma_Type is begin pragma Assert (Item in Int (Pragma_Type'First) .. Int (Pragma_Type'Last)); return Pragma_Type (Item); end Convert; ------------- -- Convert -- ------------- function Convert (Item : Predefined_Type) return Int is begin return Int (Item); end Convert; ------------- -- Convert -- ------------- function Convert (Item : Int) return Predefined_Type is begin pragma Assert (Item in Int (Predefined_Type'First) .. Int (Predefined_Type'Last)); return Predefined_Type (Item); end Convert; ------------- -- Convert -- ------------- function Convert (Item : Reconnection_Type) return Int is begin return Int (Item); end Convert; ------------- -- Convert -- ------------- function Convert (Item : Int) return Reconnection_Type is begin pragma Assert (Item in Int (Reconnection_Type'First) .. Int (Reconnection_Type'Last)); return Reconnection_Type (Item); end Convert; ------------- -- Convert -- ------------- function Convert (Item : Termination_Type) return Int is begin return Int (Item); end Convert; ------------- -- Convert -- ------------- function Convert (Item : Int) return Termination_Type is begin pragma Assert (Item in Int (Termination_Type'First) .. Int (Termination_Type'Last)); return Termination_Type (Item); end Convert; ------------- -- Convert -- ------------- function Convert (Item : Priority_Policy_Type) return Int is begin return Int (Item); end Convert; ------------- -- Convert -- ------------- function Convert (Item : Int) return Priority_Policy_Type is begin pragma Assert (Item in Int (Priority_Policy_Type'First) .. Int (Priority_Policy_Type'Last)); return Priority_Policy_Type (Item); end Convert; ------------- -- Convert -- ------------- function Convert (Item : ORB_Tasking_Policy_Type) return Int is begin return Int (Item); end Convert; ------------- -- Convert -- ------------- function Convert (Item : Int) return ORB_Tasking_Policy_Type is begin pragma Assert (Item in Int (ORB_Tasking_Policy_Type'First) .. Int (ORB_Tasking_Policy_Type'Last)); return ORB_Tasking_Policy_Type (Item); end Convert; ------------- -- Convert -- ------------- function Convert (Item : Name_Server_Type) return Int is begin return Int (Item); end Convert; ------------- -- Convert -- ------------- function Convert (Item : Int) return Name_Server_Type is begin pragma Assert (Item in Int (Name_Server_Type'First) .. Int (Name_Server_Type'Last)); return Name_Server_Type (Item); end Convert; ---------------------- -- Create_Component -- ---------------------- procedure Create_Component (Component_Node : out Component_Id; Component_Name : Name_Id) is begin Create_Node (Node_Id (Component_Node), Component_Name, K_Component); end Create_Component; -------------------------- -- Create_Configuration -- -------------------------- procedure Create_Configuration (Configuration_Node : out Configuration_Id; Configuration_Name : Name_Id) is begin Create_Node (Node_Id (Configuration_Node), Configuration_Name, K_Configuration); end Create_Configuration; ----------------- -- Create_Node -- ----------------- procedure Create_Node (Node : out Node_Id; Name : Name_Id; Kind : Node_Kind) is begin Nodes.Increment_Last; Nodes.Table (Nodes.Last).Kind := Kind; Nodes.Table (Nodes.Last).Name := Name; Nodes.Table (Nodes.Last).Node_1 := Null_Node; Nodes.Table (Nodes.Last).Node_2 := Null_Node; Nodes.Table (Nodes.Last).Node_3 := Null_Node; Nodes.Table (Nodes.Last).Flag_1 := False; Nodes.Table (Nodes.Last).Value := 0; Node := Nodes.Last; end Create_Node; ---------------------- -- Create_Parameter -- ---------------------- procedure Create_Parameter (Parameter_Node : out Parameter_Id; Parameter_Name : Name_Id) is begin Create_Node (Node_Id (Parameter_Node), Parameter_Name, K_Variable); end Create_Parameter; ---------------------- -- Create_Statement -- ---------------------- procedure Create_Statement (Statement_Node : out Statement_Id; Statement_Name : Name_Id) is begin Create_Node (Node_Id (Statement_Node), Statement_Name, K_Statement); end Create_Statement; ----------------------- -- Create_Subprogram -- ----------------------- procedure Create_Subprogram (Subprogram_Node : out Subprogram_Id; Subprogram_Name : Name_Id) is Node : Node_Id; List : Node_Id; begin Create_Node (Node, Subprogram_Name, K_Subprogram); Create_Node (List, No_Name, K_List); Nodes.Table (Node).Node_3 := List; Subprogram_Node := Subprogram_Id (Node); end Create_Subprogram; ----------------- -- Create_Type -- ----------------- procedure Create_Type (Type_Node : out Type_Id; Type_Name : Name_Id) is Node : Node_Id; begin Create_Node (Node, Type_Name, K_Type); Type_Node := Type_Id (Node); end Create_Type; --------------------- -- Create_Variable -- --------------------- procedure Create_Variable (Variable_Node : out Variable_Id; Variable_Name : Name_Id) is begin Create_Node (Node_Id (Variable_Node), Variable_Name, K_Variable); end Create_Variable; ------------------------------------- -- First_Configuration_Declaration -- ------------------------------------- procedure First_Configuration_Declaration (Configuration_Node : Configuration_Id; Declaration_Node : out Node_Id) is Conf : constant Node_Id := Node_Id (Configuration_Node); begin pragma Assert (Is_Configuration (Conf)); -- Check that there is no configuration in front of the current -- configuration. If this is the case, then start from the -- previous configuration. if Nodes.Table (Conf).Node_3 /= Null_Node then First_Configuration_Declaration (Configuration_Id (Nodes.Table (Conf).Node_3), Declaration_Node); else Declaration_Node := Conf; end if; end First_Configuration_Declaration; -------------------------------- -- First_Subprogram_Parameter -- -------------------------------- procedure First_Subprogram_Parameter (Subprogram_Node : Subprogram_Id; Parameter_Node : out Parameter_Id) is Node : constant Node_Id := Node_Id (Subprogram_Node); List : Node_Id; begin pragma Assert (Is_Subprogram (Node) or else Is_Statement (Node)); List := Nodes.Table (Node).Node_3; pragma Assert (Is_List (List)); Parameter_Node := Parameter_Id (Nodes.Table (List).Node_1); end First_Subprogram_Parameter; -------------------------- -- First_Type_Component -- -------------------------- procedure First_Type_Component (Type_Node : Type_Id; Component_Node : out Component_Id) is TN : constant Node_Id := Node_Id (Type_Node); CL : Node_Id; begin Component_Node := Null_Component; if Is_Type (TN) then CL := Nodes.Table (TN).Node_3; if CL /= Null_Node and then Is_List (CL) then Component_Node := Component_Id (Nodes.Table (CL).Node_1); end if; end if; end First_Type_Component; ------------------------------ -- First_Variable_Component -- ------------------------------ procedure First_Variable_Component (Variable_Node : Variable_Id; Component_Node : out Component_Id) is VN : constant Node_Id := Node_Id (Variable_Node); CL : Node_Id; begin Component_Node := Null_Component; if Is_Variable (VN) then CL := Nodes.Table (VN).Node_3; if CL /= Null_Node and then Is_List (CL) then Component_Node := Component_Id (Nodes.Table (CL).Node_1); end if; end if; end First_Variable_Component; ------------------------------ -- Get_Array_Component_Type -- ------------------------------ function Get_Array_Component_Type (Type_Node : Type_Id) return Type_Id is TN : constant Node_Id := Node_Id (Type_Node); begin pragma Assert (Is_Type_Composite (Type_Node)); if Get_Array_Length (Type_Node) = 0 then return Null_Type; else return Type_Id (Nodes.Table (TN).Node_2); end if; end Get_Array_Component_Type; ---------------------- -- Get_Array_Length -- ---------------------- function Get_Array_Length (Type_Node : Type_Id) return Int is TN : constant Node_Id := Node_Id (Type_Node); CL : Node_Id; begin pragma Assert (Is_Type_Composite (Type_Node)); CL := Nodes.Table (TN).Node_3; return Nodes.Table (CL).Value; end Get_Array_Length; ---------------------- -- Get_Array_Length -- ---------------------- function Get_Array_Length (Variable_Node : Variable_Id) return Int is VN : constant Node_Id := Node_Id (Variable_Node); VT : constant Type_Id := Get_Variable_Type (Variable_Node); begin pragma Assert (Is_Variable (VN)); pragma Assert (Get_Array_Length (VT) /= 0); return Nodes.Table (VN).Value; end Get_Array_Length; ------------------------ -- Get_Attribute_Kind -- ------------------------ function Get_Attribute_Kind (Component_Node : Component_Id) return Attribute_Type is Node : constant Node_Id := Node_Id (Component_Node); begin pragma Assert (Is_Component (Node)); return Convert (Nodes.Table (Node).Value); end Get_Attribute_Kind; ------------------------ -- Get_Component_Name -- ------------------------ function Get_Component_Name (Component : Component_Id) return Name_Id is begin return Nodes.Table (Node_Id (Component)).Name; end Get_Component_Name; ------------------------ -- Get_Component_Type -- ------------------------ function Get_Component_Type (Component_Node : Component_Id) return Type_Id is Node : constant Node_Id := Node_Id (Component_Node); begin pragma Assert (Is_Component (Node)); return Type_Id (Nodes.Table (Node).Node_2); end Get_Component_Type; ------------------------ -- Get_Component_Value -- ------------------------ function Get_Component_Value (Component_Node : Component_Id) return Variable_Id is Node : Node_Id := Node_Id (Component_Node); begin pragma Assert (Is_Component_Initialized (Component_Node)); Node := Nodes.Table (Node).Node_3; pragma Assert (Is_Variable (Node)); return Variable_Id (Node); end Get_Component_Value; ------------------- -- Get_Node_Name -- ------------------- function Get_Node_Name (Node : Node_Id) return Name_Id is begin return Nodes.Table (Node).Name; end Get_Node_Name; ------------------- -- Get_Node_SLOC -- ------------------- procedure Get_Node_SLOC (Node : Node_Id; Loc_X : out Int; Loc_Y : out Int) is begin Loc_X := Nodes.Table (Node).Loc_X; Loc_Y := Nodes.Table (Node).Loc_Y; end Get_Node_SLOC; ------------------------ -- Get_Parameter_Type -- ------------------------ function Get_Parameter_Type (Parameter_Node : Parameter_Id) return Type_Id is begin return Get_Variable_Type (Variable_Id (Parameter_Node)); end Get_Parameter_Type; ------------------------- -- Get_Parameter_Value -- ------------------------- function Get_Parameter_Value (Parameter_Node : Parameter_Id) return Variable_Id is Node : Node_Id := Node_Id (Parameter_Node); begin pragma Assert (Is_Parameter_Initialized (Parameter_Node)); Node := Nodes.Table (Node).Node_3; pragma Assert (Is_Variable (Node)); return Variable_Id (Node); end Get_Parameter_Value; --------------------- -- Get_Pragma_Kind -- --------------------- function Get_Pragma_Kind (Subprogram_Node : Subprogram_Id) return Pragma_Type is Node : constant Node_Id := Node_Id (Subprogram_Node); begin pragma Assert (Is_Subprogram (Node)); return Convert (Nodes.Table (Node).Value); end Get_Pragma_Kind; ---------------------- -- Get_Scalar_Value -- ---------------------- function Get_Scalar_Value (Variable_Node : Variable_Id) return Int is Node : constant Node_Id := Node_Id (Variable_Node); VT : Type_Id; begin pragma Assert (Is_Variable_Initialized (Variable_Node)); VT := Get_Variable_Type (Variable_Node); pragma Assert (not Is_Type_Composite (VT)); return Nodes.Table (Node).Value; end Get_Scalar_Value; ------------------------- -- Get_Subprogram_Call -- ------------------------- function Get_Subprogram_Call (Statement_Node : Statement_Id) return Subprogram_Id is Node : constant Node_Id := Node_Id (Statement_Node); begin pragma Assert (Is_Statement (Node)); return Subprogram_Id (Nodes.Table (Node).Node_2); end Get_Subprogram_Call; --------------- -- Get_Token -- --------------- function Get_Token (N : Name_Id) return Token_Type is Info : Int; begin Info := Get_Name_Table_Info (N); if Info in Int (Token_Type'First) .. Int (Token_Type'Last) then return Token_Type (Info); else return Tok_Unknown; end if; end Get_Token; ------------------- -- Get_Type_Kind -- ------------------- function Get_Type_Kind (Type_Node : Type_Id) return Predefined_Type is Node : constant Node_Id := Node_Id (Type_Node); begin pragma Assert (Is_Type (Node)); return Convert (Nodes.Table (Node).Value); end Get_Type_Kind; ----------------------- -- Get_Variable_Name -- ----------------------- function Get_Variable_Name (Variable : Variable_Id) return Name_Id is begin return Nodes.Table (Node_Id (Variable)).Name; end Get_Variable_Name; ----------------------- -- Get_Variable_Type -- ----------------------- function Get_Variable_Type (Variable_Node : Variable_Id) return Type_Id is Node : constant Node_Id := Node_Id (Variable_Node); begin pragma Assert (Is_Variable (Node)); return Type_Id (Nodes.Table (Node).Node_2); end Get_Variable_Type; ------------------------ -- Get_Variable_Value -- ------------------------ function Get_Variable_Value (Variable_Node : Variable_Id) return Variable_Id is Node : Node_Id := Node_Id (Variable_Node); begin pragma Assert (Is_Variable_Initialized (Variable_Node)); Node := Nodes.Table (Node).Node_3; pragma Assert (Is_Variable (Node) or else Is_Subprogram (Node)); return Variable_Id (Node); end Get_Variable_Value; ---------------- -- Initialize -- ---------------- procedure Initialize is begin Priority_Policy_Img := (No_Priority_Policy => Id ("Undefined Priority Policy"), Server_Declared => Id ("Server_Declared"), Client_Propagated => Id ("Client_Propagated")); Termination_Img := (No_Termination => Id ("Undefined Termination"), Local_Termination => Id ("Local_Termination"), Global_Termination => Id ("Global_Termination"), Deferred_Termination => Id ("Deferred_Termination")); Reconnection_Img := (No_Reconnection => Id ("Undefined Reconnection"), Reject_On_Restart => Id ("Reject_On_Restart"), Block_Until_Restart => Id ("Block_Until_Restart"), Fail_Until_Restart => Id ("Fail_Until_Restart")); Boolean_Img := (BMaybe => Id ("Undefined Boolean"), BFalse => Id ("False"), BTrue => Id ("True")); ORB_Tasking_Policy_Img := (No_ORB_Tasking_Policy => Id ("Undefined ORB Tasking Policy"), Thread_Pool => Id ("Thread_Pool"), Thread_Per_Session => Id ("Thread_Per_Session"), Thread_Per_Request => Id ("Thread_Per_Request")); Tasking_Img := (Unknown_Tasking => Id ("Undefined Tasking"), PCS_Tasking => Id ("PCS_Tasking"), User_Tasking => Id ("User_Tasking"), No_Tasking => Id ("No_Tasking")); Name_Server_Img := (No_Name_Server => Id ("Undefined name server kind"), Embedded => Id ("Embedded"), Standalone => Id ("Standalone"), Multicast => Id ("Multicast")); end Initialize; ------------------ -- Is_Component -- ------------------ function Is_Component (Node : Node_Id) return Boolean is begin return Is_Of_Kind (Node, K_Component); end Is_Component; ------------------------------ -- Is_Component_Initialized -- ------------------------------ function Is_Component_Initialized (Component_Node : Component_Id) return Boolean is Node : constant Node_Id := Node_Id (Component_Node); begin pragma Assert (Is_Component (Node)); return Nodes.Table (Node).Flag_1; end Is_Component_Initialized; ---------------------- -- Is_Configuration -- ---------------------- function Is_Configuration (Node : Node_Id) return Boolean is begin return Is_Of_Kind (Node, K_Configuration); end Is_Configuration; ------------- -- Is_List -- ------------- function Is_List (Node : Node_Id) return Boolean is begin return Is_Of_Kind (Node, K_List); end Is_List; ---------------- -- Is_Of_Kind -- ---------------- function Is_Of_Kind (Node : Node_Id; Kind : Node_Kind) return Boolean is begin pragma Assert (Node /= Null_Node); return Nodes.Table (Node).Kind = Kind; end Is_Of_Kind; ------------------------------ -- Is_Parameter_Initialized -- ------------------------------ function Is_Parameter_Initialized (Parameter_Node : Parameter_Id) return Boolean is Node : constant Node_Id := Node_Id (Parameter_Node); begin pragma Assert (Is_Variable (Node)); return Nodes.Table (Node).Flag_1; end Is_Parameter_Initialized; ------------------ -- Is_Statement -- ------------------ function Is_Statement (Node : Node_Id) return Boolean is begin return Is_Of_Kind (Node, K_Statement); end Is_Statement; ------------------- -- Is_Subprogram -- ------------------- function Is_Subprogram (Node : Node_Id) return Boolean is begin return Is_Of_Kind (Node, K_Subprogram); end Is_Subprogram; ------------------------------- -- Is_Subprogram_A_Procedure -- ------------------------------- function Is_Subprogram_A_Procedure (Subprogram_Node : Subprogram_Id) return Boolean is Node : constant Node_Id := Node_Id (Subprogram_Node); begin pragma Assert (Is_Subprogram (Node)); return Nodes.Table (Node).Flag_1; end Is_Subprogram_A_Procedure; ------------- -- Is_Type -- ------------- function Is_Type (Node : Node_Id) return Boolean is begin return Is_Of_Kind (Node, K_Type); end Is_Type; ----------------------- -- Is_Type_Composite -- ----------------------- function Is_Type_Composite (Type_Node : Type_Id) return Boolean is TN : constant Node_Id := Node_Id (Type_Node); begin pragma Assert (Is_Type (TN)); return Nodes.Table (TN).Node_3 /= Null_Node; end Is_Type_Composite; ----------------- -- Is_Variable -- ----------------- function Is_Variable (Node : Node_Id) return Boolean is begin pragma Assert (Node /= Null_Node); return Is_Of_Kind (Node, K_Variable); end Is_Variable; ----------------------------- -- Is_Variable_Initialized -- ----------------------------- function Is_Variable_Initialized (Variable_Node : Variable_Id) return Boolean is Node : constant Node_Id := Node_Id (Variable_Node); begin pragma Assert (Is_Variable (Node)); return Nodes.Table (Node).Flag_1; end Is_Variable_Initialized; ------------------ -- Jump_Context -- ------------------ procedure Jump_Context (Context : Context_Type) is begin if Debug_Mode then Write_Str ("delete ["); Write_Int (Int (Context.Last_Node + 1)); Write_Str (" .. "); Write_Int (Int (Nodes.Last)); Write_Str ("]"); Write_Eol; end if; -- Cut the link to the next declarations because there are no -- longer meaningfull. Except when the declaration list was -- empty (the last declaration is the configuration node itself). -- In this case, reset configuration head to null. if Context.Last_Decl /= Null_Node then Nodes.Table (Context.Last_Decl).Node_1 := Null_Node; else Nodes.Table (Context.Conf_Node).Node_1 := Null_Node; end if; -- Update the configuration tail. Nodes.Table (Context.Conf_Node).Node_2 := Context.Last_Decl; -- Remove the nodes created in the previous context. loop exit when Nodes.Last <= Context.Last_Node; Nodes.Decrement_Last; end loop; N_Anonymous_Variable := Context.Anonymous; end Jump_Context; ------------------------ -- New_Component_Name -- ------------------------ function New_Component_Name (Variable_Node : Variable_Id) return Name_Id is begin Name_Len := 0; Add_Str_To_Name_Buffer ("C ["); Add_Nat_To_Name_Buffer (Nat (Get_Array_Length (Variable_Node))); Add_Str_To_Name_Buffer ("]"); return Name_Find; end New_Component_Name; ----------------------- -- New_Variable_Name -- ----------------------- function New_Variable_Name return Name_Id is begin Name_Len := 0; Add_Str_To_Name_Buffer ("V_"); Add_Nat_To_Name_Buffer (Nat (N_Anonymous_Variable)); N_Anonymous_Variable := N_Anonymous_Variable + 1; return Name_Find; end New_Variable_Name; ------------------------------------ -- Next_Configuration_Declaration -- ------------------------------------ procedure Next_Configuration_Declaration (Declaration_Node : in out Node_Id) is begin Declaration_Node := Nodes.Table (Declaration_Node).Node_1; end Next_Configuration_Declaration; ------------------------------- -- Next_Subprogram_Parameter -- ------------------------------- procedure Next_Subprogram_Parameter (Parameter_Node : in out Parameter_Id) is Node : constant Node_Id := Node_Id (Parameter_Node); begin pragma Assert (Is_Variable (Node)); Parameter_Node := Parameter_Id (Nodes.Table (Node).Node_1); end Next_Subprogram_Parameter; ------------------------- -- Next_Type_Component -- ------------------------- procedure Next_Type_Component (Component_Node : in out Component_Id) is Node : constant Node_Id := Node_Id (Component_Node); begin Component_Node := Component_Id (Nodes.Table (Node).Node_1); end Next_Type_Component; ----------------------------- -- Next_Variable_Component -- ----------------------------- procedure Next_Variable_Component (Component_Node : in out Component_Id) is Node : constant Node_Id := Node_Id (Component_Node); begin Component_Node := Component_Id (Nodes.Table (Node).Node_1); end Next_Variable_Component; ------------------------------ -- Parameter_Is_Initialized -- ------------------------------ procedure Parameter_Is_Initialized (Parameter_Node : Parameter_Id; Is_Initialized : Boolean) is Node : constant Node_Id := Node_Id (Parameter_Node); begin pragma Assert (Is_Variable (Node)); Nodes.Table (Node).Flag_1 := Is_Initialized; end Parameter_Is_Initialized; ------------------ -- Save_Context -- ------------------ procedure Save_Context (Configuration : Configuration_Id; Context : out Context_Type) is begin Context.Last_Node := Nodes.Last; Context.Last_Decl := Nodes.Table (Node_Id (Configuration)).Node_2; Context.Conf_Node := Node_Id (Configuration); Context.Anonymous := N_Anonymous_Variable; end Save_Context; ------------------------------ -- Set_Array_Component_Type -- ------------------------------ procedure Set_Array_Component_Type (Type_Node : Type_Id; Comp_Type : Type_Id) is Node : constant Node_Id := Node_Id (Type_Node); begin pragma Assert (Is_Type (Node)); Nodes.Table (Node).Node_2 := Node_Id (Comp_Type); end Set_Array_Component_Type; ---------------------- -- Set_Array_Length -- ---------------------- procedure Set_Array_Length (Type_Node : Type_Id; Array_Length : Int) is TN : constant Node_Id := Node_Id (Type_Node); CL : Node_Id; begin pragma Assert (Is_Type_Composite (Type_Node)); CL := Nodes.Table (TN).Node_3; Nodes.Table (CL).Value := Array_Length; end Set_Array_Length; ---------------------- -- Set_Array_Length -- ---------------------- procedure Set_Array_Length (Variable_Node : Variable_Id; Array_Length : Int) is VN : constant Node_Id := Node_Id (Variable_Node); VT : Type_Id; begin pragma Assert (Is_Variable (VN)); VT := Get_Variable_Type (Variable_Node); pragma Assert (Is_Type_Composite (VT)); pragma Assert (Get_Array_Length (VT) /= 0); Nodes.Table (VN).Value := Array_Length; end Set_Array_Length; ------------------------ -- Set_Attribute_Kind -- ------------------------ procedure Set_Attribute_Kind (Component_Node : Component_Id; Attribute_Kind : Attribute_Type) is Node : constant Node_Id := Node_Id (Component_Node); begin pragma Assert (Is_Component (Node)); Nodes.Table (Node).Value := Convert (Attribute_Kind); end Set_Attribute_Kind; ------------------------ -- Set_Component_Type -- ------------------------ procedure Set_Component_Type (Component_Node : Component_Id; Type_Node : Type_Id) is Node : constant Node_Id := Node_Id (Component_Node); Ntype : constant Node_Id := Node_Id (Type_Node); begin pragma Assert (Is_Component (Node)); pragma Assert (Is_Type (Ntype)); Nodes.Table (Node).Node_2 := Ntype; end Set_Component_Type; ------------------------- -- Set_Component_Value -- ------------------------- procedure Set_Component_Value (Component_Node : Component_Id; Value_Node : Variable_Id) is Node : constant Node_Id := Node_Id (Component_Node); begin pragma Assert (Is_Component (Node)); Nodes.Table (Node).Flag_1 := True; Nodes.Table (Node).Node_3 := Node_Id (Value_Node); end Set_Component_Value; ------------------- -- Set_Node_SLOC -- ------------------- procedure Set_Node_SLOC (Node : Node_Id; Loc_X : Int; Loc_Y : Int) is begin Nodes.Table (Node).Loc_X := Loc_X; Nodes.Table (Node).Loc_Y := Loc_Y; end Set_Node_SLOC; ------------------------ -- Set_Parameter_Type -- ------------------------ procedure Set_Parameter_Type (Parameter_Node : Parameter_Id; Parameter_Type : Type_Id) is begin Set_Variable_Type (Variable_Id (Parameter_Node), Parameter_Type); end Set_Parameter_Type; --------------------- -- Set_Pragma_Kind -- --------------------- procedure Set_Pragma_Kind (Subprogram_Node : Subprogram_Id; Pragma_Kind : Pragma_Type) is Node : constant Node_Id := Node_Id (Subprogram_Node); begin pragma Assert (Is_Subprogram (Node)); Nodes.Table (Node).Value := Convert (Pragma_Kind); end Set_Pragma_Kind; ---------------------- -- Set_Scalar_Value -- ----------------------- procedure Set_Scalar_Value (Variable_Node : Variable_Id; Scalar_Value : Int) is Node : constant Node_Id := Node_Id (Variable_Node); begin pragma Assert (Is_Variable (Node)); Nodes.Table (Node).Flag_1 := True; Nodes.Table (Node).Value := Scalar_Value; end Set_Scalar_Value; ------------------------ -- Set_Subprogram_Call -- ------------------------ procedure Set_Subprogram_Call (Statement_Node : Statement_Id; Subprogram_Node : Subprogram_Id) is Statement : constant Node_Id := Node_Id (Statement_Node); Subprogram : constant Node_Id := Node_Id (Subprogram_Node); begin pragma Assert (Is_Statement (Statement) and then Is_Subprogram (Subprogram)); Nodes.Table (Statement).Node_2 := Subprogram; end Set_Subprogram_Call; --------------- -- Set_Token -- --------------- procedure Set_Token (N : String; T : Token_Type) is Name : Name_Id; begin Name_Len := N'Length; Name_Buffer (1 .. Name_Len) := N; Name := Name_Find; Set_Name_Table_Info (Name, Int (T)); Reserved (T) := True; end Set_Token; ------------------- -- Set_Type_Kind -- ------------------- procedure Set_Type_Kind (Type_Node : Type_Id; Type_Kind : Predefined_Type) is Node : constant Node_Id := Node_Id (Type_Node); begin pragma Assert (Is_Type (Node)); Nodes.Table (Node).Value := Convert (Type_Kind); end Set_Type_Kind; ----------------------- -- Set_Variable_Type -- ----------------------- procedure Set_Variable_Type (Variable_Node : Variable_Id; Variable_Type : Type_Id) is VN : constant Node_Id := Node_Id (Variable_Node); L : Node_Id; begin pragma Assert (Is_Variable (VN)); Nodes.Table (VN).Node_2 := Node_Id (Variable_Type); if Is_Type_Composite (Variable_Type) then Create_Node (L, No_Name, K_List); Nodes.Table (VN).Node_3 := L; end if; end Set_Variable_Type; ------------------------ -- Set_Variable_Value -- ------------------------ procedure Set_Variable_Value (Variable_Node : Variable_Id; Value_Node : Variable_Id) is Node : constant Node_Id := Node_Id (Variable_Node); begin pragma Assert (Is_Variable (Node)); Nodes.Table (Node).Flag_1 := True; Nodes.Table (Node).Node_3 := Node_Id (Value_Node); end Set_Variable_Value; ------------------------------- -- Subprogram_Is_A_Procedure -- ------------------------------- procedure Subprogram_Is_A_Procedure (Subprogram_Node : Subprogram_Id; Procedure_Node : Boolean) is Node : constant Node_Id := Node_Id (Subprogram_Node); begin pragma Assert (Is_Subprogram (Node)); Nodes.Table (Node).Flag_1 := Procedure_Node; end Subprogram_Is_A_Procedure; ----------------------- -- Type_Is_Composite -- ----------------------- procedure Type_Is_Composite (Type_Node : Type_Id; Composite : Boolean) is TN : constant Node_Id := Node_Id (Type_Node); L : Node_Id; begin pragma Assert (Is_Type (TN)); if Composite then Create_Node (L, No_Name, K_List); Nodes.Table (TN).Node_3 := L; else Nodes.Table (TN).Node_3 := Null_Node; end if; end Type_Is_Composite; ----------------------------- -- Variable_Is_Initialized -- ----------------------------- procedure Variable_Is_Initialized (Variable_Node : Variable_Id; Is_Initialized : Boolean) is Node : constant Node_Id := Node_Id (Variable_Node); begin pragma Assert (Is_Variable (Node)); Nodes.Table (Node).Flag_1 := Is_Initialized; end Variable_Is_Initialized; ---------------- -- Write_SLOC -- ---------------- procedure Write_SLOC (Node : Node_Id) is X, Y : Int; begin Get_Node_SLOC (Node, X, Y); Write_Name (Configuration_File_Name); Write_Str (":"); Write_Int (X); Write_Str (":"); Write_Int (Y); Write_Str (": "); end Write_SLOC; end XE; polyorb-2.8~20110207.orig/compilers/gnatdist/xe_units.ads0000644000175000017500000005424411750740337022562 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- X E _ U N I T S -- -- -- -- S p e c -- -- -- -- Copyright (C) 1995-2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- This package provides all the types and tables required to -- represent the configuration of the distributed system like -- Ada units, configured units, partitions, channels, locations, ... with GNAT.Table; with XE; use XE; with XE_Types; use XE_Types; package XE_Units is ---------------- -- Name Types -- ---------------- No_Unit_Name : constant Unit_Name_Type := Unit_Name_Type (No_Name); subtype Partition_Name_Type is Unit_Name_Type; No_Partition_Name : constant Partition_Name_Type := No_Unit_Name; subtype Channel_Name_Type is Name_Id; No_Channel_Name : constant Channel_Name_Type := Channel_Name_Type (No_Name); subtype Filter_Name_Type is Name_Id; No_Filter_Name : constant Filter_Name_Type := Filter_Name_Type (No_Name); subtype Host_Name_Type is Name_Id; No_Host_Name : constant Host_Name_Type := Host_Name_Type (No_Name); subtype Main_Subprogram_Type is Unit_Name_Type; No_Main_Subprogram : constant Main_Subprogram_Type := No_Unit_Name; subtype Command_Line_Type is Name_Id; No_Command_Line : constant Command_Line_Type := Command_Line_Type (No_Name); subtype Directory_Name_Type is File_Name_Type; No_Directory_Name : constant Directory_Name_Type := No_File_Name; ------------------- -- Tasking Types -- ------------------- type Task_Pool_Type is array (1 .. 3) of Int; No_Task_Pool : constant Task_Pool_Type := (-1, -1, -1); type Priority_Type is new Int; No_Priority : constant Priority_Type := -1; -------------- -- Id Types -- -------------- -- The various entries are stored in tables with distinct subscript -- ranges. The following type definitions indicate the ranges used -- for the subscripts (Id values) for the various tables. type ALI_Id is range 0 .. 999_999; -- Id values used for ALIs table entries No_ALI_Id : constant ALI_Id := ALI_Id'First; First_ALI_Id : constant ALI_Id := No_ALI_Id + 1; type Unit_Id is range 1_000_000 .. 1_999_999; -- Id values used for Unit table entries No_Unit_Id : constant Unit_Id := Unit_Id'First; First_Unit_Id : constant Unit_Id := No_Unit_Id + 1; type With_Id is range 2_000_000 .. 2_999_999; -- Id values used for Withs table entries No_With_Id : constant With_Id := With_Id'First; First_With_Id : constant With_Id := No_With_Id + 1; type Sdep_Id is range 4_000_000 .. 4_999_999; -- Id values used for Sdep table entries No_Sdep_Id : constant Sdep_Id := Sdep_Id'First; First_Sdep_Id : constant Sdep_Id := No_Sdep_Id + 1; type Partition_Id is range 7_000_000 .. 7_000_255; No_Partition_Id : constant Partition_Id := Partition_Id'First; First_Partition_Id : constant Partition_Id := No_Partition_Id + 1; type Conf_Unit_Id is range 7_100_000 .. 7_199_999; No_Conf_Unit_Id : constant Conf_Unit_Id := Conf_Unit_Id'First; First_Conf_Unit_Id : constant Conf_Unit_Id := No_Conf_Unit_Id + 1; type Channel_Id is range 7_200_000 .. 7_299_999; No_Channel_Id : constant Channel_Id := Channel_Id'First; First_Channel_Id : constant Channel_Id := No_Channel_Id + 1; type Host_Id is range 7_300_000 .. 7_399_999; No_Host_Id : constant Host_Id := Host_Id'First; First_Host_Id : constant Host_Id := No_Host_Id + 1; type Location_Id is range 7_400_000 .. 7_499_999; No_Location_Id : constant Location_Id := Location_Id'First; First_Location_Id : constant Location_Id := No_Location_Id + 1; type Stub_Id is range 7_500_000 .. 7_599_999; No_Stub_Id : constant Stub_Id := Stub_Id'First; First_Stub_Id : constant Stub_Id := No_Stub_Id + 1; type Env_Var_Id is range 7_500_000 .. 7_599_999; No_Env_Var_Id : constant Env_Var_Id := Env_Var_Id'First; First_Env_Var_Id : constant Env_Var_Id := No_Env_Var_Id + 1; type Required_Storage_Id is range 7_600_000 .. 7_699_999; No_Required_Storage_Id : constant Required_Storage_Id := Required_Storage_Id'First; First_Required_Storage_Id : constant Required_Storage_Id := No_Required_Storage_Id + 1; -------------------- -- ALI File Table -- -------------------- -- Each ALI file read generates an entry in the ALIs table type Main_Program_Type is (None, Proc, Func); -- Indicator of whether unit can be used as main program type ALIs_Record is record Ofile : File_Name_Type; -- Name of object file Afile : File_Name_Type; -- Name of ALI file Sfile : File_Name_Type; -- Name of source file that generates this ALI file (which is equal -- to the name of the source file in the first unit table entry for -- this ALI file, since the body if present is always first). Uname : Unit_Name_Type; -- Name of Unit First_Unit : Unit_Id; -- Id of first Unit table entry for this file Last_Unit : Unit_Id; -- Id of last Unit table entry for this file First_Sdep : Sdep_Id; -- Id of first Sdep table entry for this file Last_Sdep : Sdep_Id; -- Id of last Sdep table entry for this file Main_Program : Main_Program_Type; -- Indicator of whether first unit can be used as main program. Tasking : Tasking_Type; -- Indicator of whether the unit (or the collocated units it -- depends on) drags in tasking. -- Notation: -- Unknown_Tasking : tasking has not been established -- PCS_Tasking : tasking is required because of PCS code -- User_Tasking : tasking is required because of user code -- No_Tasking : tasking is not required for this unit -- Note that PCS_Tasking is a stronger property than User_Tasking -- as this also has an impact on the termination policy. Stamp_Checked : Boolean; -- Set true when ALI file time stamp has been checked (reset -- for each partition). end record; Default_ALI : constant ALIs_Record := ( Ofile => No_File_Name, Afile => No_File_Name, Sfile => No_File_Name, Uname => No_Unit_Name, First_Unit => No_Unit_Id, Last_Unit => No_Unit_Id, First_Sdep => First_Sdep_Id, Last_Sdep => No_Sdep_Id, Main_Program => None, Tasking => Unknown_Tasking, Stamp_Checked => False); package ALIs is new GNAT.Table ( Table_Component_Type => ALIs_Record, Table_Index_Type => ALI_Id, Table_Low_Bound => First_ALI_Id, Table_Initial => 500, Table_Increment => 200); ---------------- -- Unit Table -- ---------------- -- Each unit within an ALI file generates an entry in the unit table type Unit_Type is (Is_Spec, Is_Body, Is_Spec_Only, Is_Body_Only); -- Indicates type of entry, if both body and spec appear in the ALI file, -- then the first unit is marked Is_Body, and the second is marked Is_Spec. -- If only a spec appears, then it is marked as Is_Spec_Only, and if only -- a body appears, then it is marked Is_Body_Only). type Unit_Record is record My_ALI : ALI_Id; -- Corresponding ALI entry Uname : Unit_Name_Type; -- Name of Unit Sfile : File_Name_Type; -- Name of source file First_With : With_Id; -- Id of first withs table entry for this file Last_With : With_Id; -- Id of last withs table entry for this file Has_RACW : Boolean; -- Indicates presence of RA parameter for a package that declares -- at least one Remote Access to Class_Wide (RACW) object. Remote_Types : Boolean; -- Indicates a Remote_Types package. Shared_Passive : Boolean; -- Indicates a Shared_Passive package. RCI : Boolean; -- Indicates a Remote_Call_Interface package. Preelaborated : Boolean; -- Indicates a preelaborated package. Pure : Boolean; -- Indicates a pure package. Predefined : Boolean; -- Indicates if unit is language predefined (or a child of such a unit) Internal : Boolean; -- Indicates if unit is an internal unit (or a child of such a unit) Utype : Unit_Type; -- Type of entry Is_Generic : Boolean; -- True for generic unit (i.e. a generic declaration, or a generic -- body). False for a non-generic unit. Unit_Kind : Character; -- Indicates the nature of the unit. 'p' for Packages and 's' for -- subprograms. end record; package Units is new GNAT.Table ( Table_Component_Type => Unit_Record, Table_Index_Type => Unit_Id, Table_Low_Bound => First_Unit_Id, Table_Initial => 100, Table_Increment => 200); Default_Unit : constant Unit_Record := ( My_ALI => No_ALI_Id, Uname => No_Unit_Name, Sfile => No_File_Name, First_With => First_With_Id, Last_With => No_With_Id, Has_RACW => False, Remote_Types => False, Shared_Passive => False, RCI => False, Preelaborated => False, Pure => False, Predefined => False, Internal => False, Utype => Is_Spec_Only, Is_Generic => False, Unit_Kind => 'p'); ---------------- -- With Table -- ---------------- -- Each with within an ALI file generates an entry in the Withs table type With_Record is record Uname : Unit_Name_Type; -- Name of Unit Sfile : File_Name_Type; -- Name of source file, set to No_File in generic case Afile : File_Name_Type; -- Name of ALI file, set to No_File in generic case end record; package Withs is new GNAT.Table ( Table_Component_Type => With_Record, Table_Index_Type => With_Id, Table_Low_Bound => First_With_Id, Table_Initial => 100, Table_Increment => 200); Default_With : constant With_Record := ( Uname => No_Unit_Name, Afile => No_File_Name, Sfile => No_File_Name); ------------------------------------ -- Sdep (Source Dependency) Table -- ------------------------------------ -- Each source dependency (D line) in an ALI file generates an -- entry in the Sdep table. type Sdep_Record is record Sfile : File_Name_Type; -- Name of source file end record; package Sdep is new GNAT.Table ( Table_Component_Type => Sdep_Record, Table_Index_Type => Sdep_Id, Table_Low_Bound => First_Sdep_Id, Table_Initial => 5000, Table_Increment => 200); --------------------- -- Partition Table -- --------------------- type Partition_Type is record Name : Partition_Name_Type; -- Name of partition First_Unit : Conf_Unit_Id; -- Id of first unit table entry for this partition Last_Unit : Conf_Unit_Id; -- Id of last unit table entry for this partition Main_Subprogram : Unit_Name_Type; -- Main subprogram for this partition First_Stub : Stub_Id; -- Id of first stub unit table entry for this partition Last_Stub : Stub_Id; -- Id of last stub unit table entry for this partition First_Channel : Channel_Id; -- Id of first channel table entry for this partition Last_Channel : Channel_Id; -- Id of last channel table entry for this partition First_Env_Var : Env_Var_Id; -- Id of first environment variables entry for this partition Last_Env_Var : Env_Var_Id; -- Id of last environment variables entry for this partition Passive : Boolean_Type; -- Indicate whether this partition is passive Tasking : Tasking_Type; -- Indicate why this partition requires tasking. -- Notation: -- Unknown_Tasking : tasking has not been established -- PCS_Tasking : tasking is required because of PCS code -- User_Tasking : tasking is required because of user code -- No_Tasking : tasking is not required for this unit ORB_Tasking_Policy : ORB_Tasking_Policy_Type; -- ORB tasking policy to activate on this partition. -- Has no effect in Garlic PCS. Task_Pool : Task_Pool_Type; -- Configuration of the task pool Priority : Priority_Type; -- Priority to which remote calls are executed when priority -- policy is server declared. Light_PCS : Boolean_Type; -- True when the partition may be configured with a light PCS Termination : Termination_Type; -- Termination policy to activate on this partition Reconnection : Reconnection_Type; -- Reconnection policy to execute on this partition when -- another partition crashes. Host : Host_Id; -- Host on which this partition has to be launched Command_Line : Command_Line_Type; -- Command line to pass when we launch the partition First_Network_Loc : Location_Id; -- Id of first network location table entry for this partition Last_Network_Loc : Location_Id; -- Id of last network location table entry for this partition Storage_Loc : Location_Id; -- Id of storage location table entry for this partition First_Required_Storage : Required_Storage_Id; -- Id of first location needed by this partition for shared storage Last_Required_Storage : Required_Storage_Id; -- Id of last location needed by this partition for shared storage Filter : Filter_Name_Type; -- Name of filter to apply during filter registration Partition_Dir : File_Name_Type; -- Internal directory in which we build the partition Executable_Dir : Directory_Name_Type; -- Directory to store the executable file Executable_File : File_Name_Type; -- Fully qualified executable file name To_Build : Boolean; -- True when we want to build this partition Node : Node_Id; -- Frontend node Most_Recent : File_Name_Type; -- Most recent source file of this partition end record; package Partitions is new GNAT.Table (Table_Component_Type => Partition_Type, Table_Index_Type => Partition_Id, Table_Low_Bound => First_Partition_Id, Table_Initial => 20, Table_Increment => 10); Null_Partition : constant Partition_Type := (Name => No_Partition_Name, First_Unit => No_Conf_Unit_Id, Last_Unit => No_Conf_Unit_Id, Main_Subprogram => No_Unit_Name, First_Stub => First_Stub_Id, Last_Stub => No_Stub_Id, First_Channel => No_Channel_Id, Last_Channel => No_Channel_Id, First_Env_Var => No_Env_Var_Id, Last_Env_Var => No_Env_Var_Id, Passive => BMaybe, Tasking => Unknown_Tasking, ORB_Tasking_Policy => No_ORB_Tasking_Policy, Task_Pool => No_Task_Pool, Priority => No_Priority, Light_PCS => BMaybe, Termination => No_Termination, Reconnection => No_Reconnection, Command_Line => No_Command_Line, Host => No_Host_Id, First_Network_Loc => No_Location_Id, Last_Network_Loc => No_Location_Id, Storage_Loc => No_Location_Id, First_Required_Storage => No_Required_Storage_Id, Last_Required_Storage => No_Required_Storage_Id, Filter => No_Filter_Name, Partition_Dir => No_Directory_Name, Executable_Dir => No_Directory_Name, Executable_File => No_File_Name, To_Build => True, Node => Null_Node, Most_Recent => No_File_Name); --------------------------- -- Configured Unit Table -- --------------------------- -- Configured units are different from units. Such units come from the -- configuration language and might not correspond to Ada units in case of -- an illegal configuration file. type Conf_Unit_Type is record Name : Unit_Name_Type; -- Name of unit Node : Node_Id; -- Frontend node My_ALI : ALI_Id; -- Corresponding ALI id My_Unit : Unit_Id; -- Corresponding unit id Partition : Partition_Id; -- Partition on which this unit is assigned Next_Unit : Conf_Unit_Id; -- Next unit assigned on the unit partition Most_Recent : File_Name_Type; -- Most recent file for this unit end record; package Conf_Units is new GNAT.Table (Table_Component_Type => Conf_Unit_Type, Table_Index_Type => Conf_Unit_Id, Table_Low_Bound => First_Conf_Unit_Id, Table_Initial => 200, Table_Increment => 100); Null_Conf_Unit : constant Conf_Unit_Type := (Name => No_Unit_Name, Node => Null_Node, My_ALI => No_ALI_Id, My_Unit => No_Unit_Id, Partition => No_Partition_Id, Next_Unit => No_Conf_Unit_Id, Most_Recent => No_File_Name); ------------------- -- Channel Types -- ------------------- type Channel_Partition_Type is record My_Partition : Partition_Id; Next_Channel : Channel_Id; end record; Null_Channel_Partition : Channel_Partition_Type := (No_Partition_Id, No_Channel_Id); type Channel_Type is record Name : Channel_Name_Type; Node : Node_Id; Lower : Channel_Partition_Type; Upper : Channel_Partition_Type; Filter : Filter_Name_Type; end record; package Channels is new GNAT.Table (Table_Component_Type => Channel_Type, Table_Index_Type => Channel_Id, Table_Low_Bound => First_Channel_Id, Table_Initial => 20, Table_Increment => 10); ---------------- -- Host Table -- ---------------- type Host_Type is record Name : Host_Name_Type; Node : Node_Id; Static : Boolean := True; Import : Import_Method_Type := None_Import; External : Host_Name_Type := No_Host_Name; Most_Recent : File_Name_Type := No_File_Name; end record; package Hosts is new GNAT.Table (Table_Component_Type => Host_Type, Table_Index_Type => Host_Id, Table_Low_Bound => First_Host_Id, Table_Initial => 20, Table_Increment => 10); -------------------- -- Location Table -- -------------------- type Location_Type is record Major : Name_Id; Minor : Name_Id; Next_Location : Location_Id; end record; package Locations is new GNAT.Table (Table_Component_Type => Location_Type, Table_Index_Type => Location_Id, Table_Low_Bound => First_Location_Id, Table_Initial => 20, Table_Increment => 10); ---------------- -- Stub Table -- ---------------- package Stubs is new GNAT.Table (Table_Component_Type => Unit_Name_Type, Table_Index_Type => Stub_Id, Table_Low_Bound => First_Stub_Id, Table_Initial => 20, Table_Increment => 10); ------------------- -- Env var Table -- ------------------- type Env_Var_Type is record Name : Name_Id; Next_Env_Var : Env_Var_Id; end record; package Env_Vars is new GNAT.Table (Table_Component_Type => Env_Var_Type, Table_Index_Type => Env_Var_Id, Table_Low_Bound => First_Env_Var_Id, Table_Initial => 20, Table_Increment => 10); ---------------------------- -- Required Storage Table -- ---------------------------- type Required_Storage_Type is record Location : Location_Id; Is_Owner : Boolean; Unit : Unit_Id; Next_Storage : Required_Storage_Id; end record; package Required_Storages is new GNAT.Table (Table_Component_Type => Required_Storage_Type, Table_Index_Type => Required_Storage_Id, Table_Low_Bound => First_Required_Storage_Id, Table_Initial => 20, Table_Increment => 10); end XE_Units; polyorb-2.8~20110207.orig/compilers/gnatdist/xe_io.adb0000644000175000017500000006160111750740337022001 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- X E _ I O -- -- -- -- B o d y -- -- -- -- Copyright (C) 1995-2008, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with Ada.Command_Line; with GNAT.Directory_Operations; use GNAT.Directory_Operations; with XE_Names; use XE_Names; with XE_Flags; use XE_Flags; with XE_Utils; use XE_Utils; package body XE_IO is Program_Name : Name_Id := No_Name; Current_FD : File_Descriptor := Standout; -- File descriptor for current output ------------------------------ -- Local Directory Routines -- ------------------------------ function Is_Directory_Separator (C : Character) return Boolean; function Format_Pathname (Path : File_Name_Type; Style : Path_Style) return File_Name_Type; -- See GNAT.Directory_Operations.Format_Pathname ---------------- -- Temp Files -- ---------------- type Temp_File_Entry is record Fname : File_Name_Type; File : File_Descriptor; end record; Null_Temp_File_Entry : constant Temp_File_Entry := (No_File_Name, Invalid_FD); Temp_Files : array (1 .. 16) of Temp_File_Entry := (others => Null_Temp_File_Entry); ------------------------- -- Line Buffer Control -- ------------------------- -- Note: the following buffer and column position are maintained by -- the subprograms defined in this package, and are not normally -- directly modified or accessed by a client. However, a client is -- permitted to modify these values, using the knowledge that only -- Write_Eol actually generates any output. Buffer_Max : constant := 8192; Buffer : String (1 .. Buffer_Max + 1); -- Buffer used to build output line. We do line buffering because it -- is needed for the support of the debug-generated-code option (-gnatD). -- Historically it was first added because on VMS, line buffering is -- needed with certain file formats. So in any case line buffering must -- be retained for this purpose, even if other reasons disappear. Note -- any attempt to write more output to a line than can fit in the buffer -- will be silently ignored. Next_Column : Pos range 1 .. Buffer'Length + 1 := 1; -- Column about to be written. procedure Flush_Buffer; -- Flush buffer if non-empty and reset column counter --------------------------- -- Predefined File Names -- --------------------------- subtype Str8 is String (1 .. 8); Predefined_Names : constant array (1 .. 12) of Str8 := ("ada ", -- Ada "calendar", -- Calendar "gnat ", -- GNAT "interfac", -- Interfaces "system ", -- System "machcode", -- Machine_Code "unchconv", -- Unchecked_Conversion "unchdeal", -- Unchecked_Deallocation "directio", -- Direct_IO "ioexcept", -- IO_Exceptions "sequenio", -- Sequential_IO "text_io "); -- Text_IO ---------------- -- Time Stamp -- ---------------- function Image (T : OS_Time) return Time_Stamp_Type; --------------- -- Copy_File -- --------------- procedure Copy_File (Source, Target : File_Name_Type) is S, T : String_Access; OK : Boolean; begin Get_Name_String (Source); S := new String'(Name_Buffer (1 .. Name_Len)); Get_Name_String (Target); T := new String'(Name_Buffer (1 .. Name_Len)); Copy_File (S.all, T.all, OK, Mode => Overwrite); if not OK then Message ("cannot copy file " & S.all & " to " & T.all); raise Fatal_Error; end if; Free (S); Free (T); end Copy_File; ---------------- -- Create_Dir -- ---------------- procedure Create_Dir (Dname : Directory_Name_Type) is begin if Dname = No_Directory_Name then return; end if; Get_Name_String (Dname); if Is_Directory (Name_Buffer (1 .. Name_Len)) then return; end if; for J in 2 .. Name_Len loop if Is_Directory_Separator (Name_Buffer (J)) and then not Is_Directory (Name_Buffer (1 .. J - 1)) then Make_Dir (Name_Buffer (1 .. J - 1)); end if; end loop; Make_Dir (Name_Buffer (1 .. Name_Len)); exception when others => Message ("cannot create directory", Dname); raise; end Create_Dir; ----------------- -- Create_File -- ----------------- procedure Create_File (File : out File_Descriptor; Fname : File_Name_Type; Exec : Boolean := False) is begin if Debug_Mode then Message ("creating file", Fname); end if; Get_Name_String (Fname); Name_Buffer (Name_Len + 1) := ASCII.NUL; File := Create_File (Name_Buffer'Address, Binary); if File = Invalid_FD then Message ("cannot create file", Fname); raise Fatal_Error; end if; if Exec then Set_Executable (Name_Buffer (1 .. Name_Len)); end if; end Create_File; --------------------------- -- Decrement_Indentation -- --------------------------- procedure Decrement_Indentation is begin N_Space := N_Space - Space_Increment; end Decrement_Indentation; ----------------- -- Delete_File -- ----------------- procedure Delete_File (Fname : File_Name_Type) is Success : Boolean; begin if Debug_Mode then Message ("deleting", Fname); end if; Get_Name_String (Fname); if Is_Regular_File (Name_Buffer (1 .. Name_Len)) then Delete_File (Name_Buffer (1 .. Name_Len), Success); if not Success then Message ("cannot delete file", Fname); raise Fatal_Error; end if; end if; end Delete_File; --------- -- Dir -- --------- function Dir (D1 : File_Name_Type; D2 : File_Name_Type) return File_Name_Type is begin pragma Assert (D1 /= No_File_Name); if D2 = No_File_Name then return Format_Pathname (D1, UNIX); end if; Get_Name_String (D1); if not Is_Directory_Separator (Name_Buffer (Name_Len)) then Add_Char_To_Name_Buffer ('/'); end if; Get_Name_String_And_Append (D2); return Format_Pathname (Name_Find, UNIX); end Dir; --------- -- Dir -- --------- function Dir (D1 : String_Access; D2 : File_Name_Type) return File_Name_Type is begin pragma Assert (D1 /= null); Name_Len := 0; Add_Str_To_Name_Buffer (D1.all); if D2 = No_File_Name then return Format_Pathname (Name_Find, UNIX); end if; Add_Char_To_Name_Buffer ('/'); Get_Name_String_And_Append (D2); return Format_Pathname (Name_Find, UNIX); end Dir; --------------------- -- File_Time_Stamp -- --------------------- function File_Time_Stamp (Fname : File_Name_Type) return Time_Stamp_Type is begin Get_Name_String (Fname); return Image (File_Time_Stamp (Name_Buffer (1 .. Name_Len))); end File_Time_Stamp; ------------------ -- Flush_Buffer -- ------------------ procedure Flush_Buffer is Len : constant Natural := Natural (Next_Column - 1); begin if Len /= 0 then if Len /= Write (Current_FD, Buffer'Address, Len) then -- If there are errors with standard error, just quit if Current_FD = Standerr then OS_Exit (2); -- Otherwise, set the output to standard error before -- reporting a failure and quitting. else Current_FD := Standerr; Next_Column := 1; Write_Line ("fatal error: disk full"); OS_Exit (2); end if; end if; -- Buffer is now empty Next_Column := 1; end if; end Flush_Buffer; --------------------- -- Format_Pathname -- --------------------- function Format_Pathname (Path : File_Name_Type; Style : Path_Style) return File_Name_Type is begin Get_Name_String (Path); Set_Str_To_Name_Buffer (Format_Pathname (Name_Buffer (1 .. Name_Len), Style)); return Name_Find; end Format_Pathname; ----------- -- Image -- ----------- function Image (T : OS_Time) return Time_Stamp_Type is Img : Time_Stamp_Type; Year : Natural; Month : Natural; Day : Natural; Hour : Natural; Minutes : Natural; Seconds : Natural; Zero_Pos : constant := Character'Pos ('0'); begin GM_Split (T, Natural (Year), Natural (Month), Natural (Day), Natural (Hour), Natural (Minutes), Natural (Seconds)); Img (01) := Character'Val (Zero_Pos + Year / 1000); Img (02) := Character'Val (Zero_Pos + (Year / 100) mod 10); Img (03) := Character'Val (Zero_Pos + (Year / 10) mod 10); Img (04) := Character'Val (Zero_Pos + Year mod 10); Img (05) := Character'Val (Zero_Pos + Month / 10); Img (06) := Character'Val (Zero_Pos + Month mod 10); Img (07) := Character'Val (Zero_Pos + Day / 10); Img (08) := Character'Val (Zero_Pos + Day mod 10); Img (09) := Character'Val (Zero_Pos + Hour / 10); Img (10) := Character'Val (Zero_Pos + Hour mod 10); Img (11) := Character'Val (Zero_Pos + Minutes / 10); Img (12) := Character'Val (Zero_Pos + Minutes mod 10); Img (13) := Character'Val (Zero_Pos + Seconds / 10); Img (14) := Character'Val (Zero_Pos + Seconds mod 10); return Img; end Image; --------------------------- -- Increment_Indentation -- --------------------------- procedure Increment_Indentation is begin N_Space := N_Space + Space_Increment; end Increment_Indentation; ------------------ -- Is_Directory -- ------------------ function Is_Directory (Fname : File_Name_Type) return Boolean is begin Get_Name_String (Fname); return Is_Directory (Name_Buffer (1 .. Name_Len)); end Is_Directory; ---------------------------- -- Is_Directory_Separator -- ---------------------------- function Is_Directory_Separator (C : Character) return Boolean is begin return C = Directory_Separator or else C = '/'; end Is_Directory_Separator; ------------------------ -- Is_Predefined_File -- ------------------------ function Is_Predefined_File (Fname : File_Name_Type) return Boolean is begin Get_Name_String (Strip_Suffix (Strip_Directory (Fname))); -- Definitely false if longer than 12 characters (8.3) if Name_Len > 8 then return False; -- Definitely predefined if prefix is a- i- or s- followed by letter elsif Name_Len >= 3 and then Name_Buffer (2) = '-' and then (Name_Buffer (1) = 'a' or else Name_Buffer (1) = 'g' or else Name_Buffer (1) = 'i' or else Name_Buffer (1) = 's') and then (Name_Buffer (3) in 'a' .. 'z' or else Name_Buffer (3) in 'A' .. 'Z') then return True; end if; -- Otherwise check against special list, first padding to 8 characters while Name_Len < 8 loop Name_Len := Name_Len + 1; Name_Buffer (Name_Len) := ' '; end loop; for J in Predefined_Names'Range loop if Name_Buffer (1 .. 8) = Predefined_Names (J) then return True; end if; end loop; return False; end Is_Predefined_File; --------------------- -- Is_Regular_File -- --------------------- function Is_Regular_File (Fname : File_Name_Type) return Boolean is begin Get_Name_String (Fname); return GNAT.OS_Lib.Is_Regular_File (Name_Buffer (1 .. Name_Len)); end Is_Regular_File; ------------- -- Message -- ------------- procedure Message (S1 : String := No_Str; S2 : Name_Id := No_Name; S3 : String := No_Str; S4 : Name_Id := No_Name; S5 : String := No_Str) is begin Write_Program_Name; Write_Str (":"); if S1 /= "" then Write_Char (' '); Write_Str (S1); end if; if Present (S2) then Write_Char (' '); Write_Name (S2); end if; if S3 /= "" then Write_Char (' '); Write_Str (S3); end if; if Present (S4) then Write_Char (' '); Write_Name (S4); end if; if S5 /= "" then Write_Char (' '); Write_Str (S5); end if; Write_Eol; end Message; ------------------- -- Normalize_CWD -- ------------------- function Normalize_CWD (F : File_Name_Type) return File_Name_Type is begin Get_Name_String (F); if Name_Buffer (1) = '.' and then Is_Directory_Separator (Name_Buffer (2)) then return Strip_Directory (F); end if; return F; end Normalize_CWD; --------------- -- Read_File -- --------------- procedure Read_File (Fname : File_Name_Type; First : out Text_Ptr; Last : out Text_Ptr; Buffer : out Text_Buffer_Ptr) is File : File_Descriptor; Length : Text_Ptr; Result : Text_Ptr; Ptr : Text_Ptr := 1; begin -- Pre-set First and Last to junk values to prevent a warning in case -- of early return (in error cases). First := 0; Last := 0; Get_Name_String (Fname); Name_Buffer (Name_Len + 1) := ASCII.NUL; File := Open_Read (Name_Buffer'Address, Binary); if File = Invalid_FD then Buffer := null; return; end if; Length := Text_Ptr (File_Length (File)); Buffer := new Text_Buffer (1 .. Length + 1); First := 1; Last := Length + 1; -- Force the last character to be EOF Buffer (Length + 1) := EOF; loop Result := Text_Ptr (Read (File, Buffer (Ptr)'Address, Integer (Length))); exit when Result = Length; if Result <= 0 then Free (Buffer); return; end if; Ptr := Ptr + Result; Length := Length - Result; end loop; Close (File); end Read_File; ------------------------ -- Register_Temp_File -- ------------------------ procedure Register_Temp_File (Fname : File_Name_Type) is begin for J in Temp_Files'Range loop if Temp_Files (J).Fname = No_File_Name then Temp_Files (J) := (Fname, Invalid_FD); return; end if; end loop; raise Fatal_Error; end Register_Temp_File; procedure Register_Temp_File (File : out File_Descriptor; Fname : in out File_Name_Type) is Buffer : Temp_File_Name; begin if Fname = No_File_Name then Create_Temp_File (File, Buffer); Set_Str_To_Name_Buffer (Buffer); pragma Assert (Name_Buffer (Name_Len) = ASCII.NUL); Name_Len := Name_Len - 1; Fname := Name_Find; else Get_Name_String (Fname); File := Create_File (Name_Buffer (1 .. Name_Len), Text); end if; for J in Temp_Files'Range loop if No (Temp_Files (J).Fname) then Temp_Files (J) := (Fname, File); return; end if; end loop; raise Fatal_Error; end Register_Temp_File; --------------------------- -- Remove_All_Temp_Files -- --------------------------- procedure Remove_All_Temp_Files is Success : Boolean; begin for J in Temp_Files'Range loop if Present (Temp_Files (J).Fname) then Close (Temp_Files (J).File, Success); if not Keep_Tmp_Files then Delete_File (Temp_Files (J).Fname); end if; Temp_Files (J) := Null_Temp_File_Entry; end if; end loop; end Remove_All_Temp_Files; ---------------------- -- Remove_Temp_File -- ---------------------- procedure Remove_Temp_File (Fname : File_Name_Type) is Success : Boolean; begin for J in Temp_Files'Range loop if Temp_Files (J).Fname = Fname then Close (Temp_Files (J).File, Success); if not Keep_Tmp_Files then Delete_File (Fname); end if; Temp_Files (J) := Null_Temp_File_Entry; exit; end if; end loop; end Remove_Temp_File; ----------------- -- Rename_File -- ----------------- procedure Rename_File (Source, Target : File_Name_Type) is S, T : String_Access; OK : Boolean; begin Get_Name_String (Source); S := new String'(Name_Buffer (1 .. Name_Len)); Get_Name_String (Target); T := new String'(Name_Buffer (1 .. Name_Len)); Rename_File (S.all, T.all, OK); if not OK then Message ("cannot rename file " & S.all & " to " & T.all); raise Fatal_Error; end if; Free (S); Free (T); end Rename_File; ---------------- -- Set_Output -- ---------------- procedure Set_Output (New_Output : File_Descriptor) is begin Flush_Buffer; Next_Column := 1; Current_FD := New_Output; end Set_Output; ------------------------- -- Set_Space_Increment -- ------------------------- procedure Set_Space_Increment (Value : Natural) is begin Space_Increment := Value; end Set_Space_Increment; ------------------------ -- Set_Standard_Error -- ------------------------ procedure Set_Standard_Error is begin Flush_Buffer; Next_Column := 1; Current_FD := Standerr; end Set_Standard_Error; ------------------------- -- Set_Standard_Output -- ------------------------- procedure Set_Standard_Output is begin Flush_Buffer; Next_Column := 1; Current_FD := Standout; end Set_Standard_Output; --------------------- -- Strip_Directory -- --------------------- function Strip_Directory (Fname : String) return String is begin return Base_Name (Fname); end Strip_Directory; --------------------- -- Strip_Directory -- --------------------- function Strip_Directory (Fname : File_Name_Type) return File_Name_Type is begin return Id (Strip_Directory (Get_Name_String (Fname))); end Strip_Directory; ----------------------- -- Strip_Exec_Suffix -- ----------------------- function Strip_Exec_Suffix (Fname : File_Name_Type) return File_Name_Type is Exe : constant String := Get_Executable_Suffix.all; Len : constant Natural := Exe'Length; begin Get_Name_String (Fname); if Len > 0 and then Name_Len > Len and then Name_Buffer (Name_Len - Len + 1 .. Name_Len) = Exe then Name_Len := Name_Len - Len; end if; return Name_Find; end Strip_Exec_Suffix; ------------------ -- Strip_Suffix -- ------------------ function Strip_Suffix (Fname : File_Name_Type) return File_Name_Type is begin Get_Name_String (Fname); for J in reverse 2 .. Name_Len loop -- If we found the last '.', return part of Name that precedes it if Name_Buffer (J) = '.' then Name_Len := J - 1; return Name_Find; end if; end loop; return Fname; end Strip_Suffix; ---------------------- -- To_Absolute_File -- ---------------------- function To_Absolute_File (Fname : File_Name_Type) return File_Name_Type is begin Get_Name_String (Fname); if Is_Absolute_Path (Name_Buffer (1 .. Name_Len)) then return Fname; end if; Set_Str_To_Name_Buffer (Get_Current_Dir); if Name_Buffer (Name_Len) /= Directory_Separator then Add_Char_To_Name_Buffer (Directory_Separator); end if; Get_Name_String_And_Append (Fname); return Name_Find; end To_Absolute_File; -------------- -- To_Afile -- -------------- function To_Afile (Fname : File_Name_Type) return File_Name_Type is begin -- The ALI file is not necessarily in the directory of the -- source file. return Strip_Suffix (Strip_Directory (Fname)) & ALI_Suffix_Id; end To_Afile; -------------- -- To_Ofile -- -------------- function To_Ofile (Fname : File_Name_Type) return File_Name_Type is begin return Strip_Suffix (Fname) & Obj_Suffix_Id; end To_Ofile; ---------------- -- Write_Char -- ---------------- procedure Write_Char (C : Character) is begin if Next_Column < Buffer'Length then Buffer (Natural (Next_Column)) := C; Next_Column := Next_Column + 1; end if; end Write_Char; --------------- -- Write_Eol -- --------------- procedure Write_Eol (N : Natural := 1) is begin for I in 1 .. N loop Buffer (Natural (Next_Column)) := ASCII.LF; Next_Column := Next_Column + 1; Flush_Buffer; end loop; end Write_Eol; ----------------------- -- Write_Indentation -- ----------------------- procedure Write_Indentation (Offset : Integer := 0) is begin for I in 1 .. N_Space + Offset loop Write_Char (' '); end loop; end Write_Indentation; --------------- -- Write_Int -- --------------- procedure Write_Int (Val : Int) is begin if Val < 0 then Write_Char ('-'); Write_Int (-Val); else if Val > 9 then Write_Int (Val / 10); end if; Write_Char (Character'Val ((Val mod 10) + Character'Pos ('0'))); end if; end Write_Int; ---------------- -- Write_Line -- ---------------- procedure Write_Line (S : String) is begin Write_Str (S); Write_Eol; end Write_Line; ------------------------ -- Write_Program_Name -- ------------------------ procedure Write_Program_Name is use Ada.Command_Line; begin if No (Program_Name) then Program_Name := Strip_Exec_Suffix (Id (Base_Name (Command_Name))); end if; Write_Name (Program_Name); end Write_Program_Name; ----------------- -- Write_Space -- ----------------- procedure Write_Space is begin Write_Char (' '); end Write_Space; ---------------------------- -- Write_Stamp_Comparison -- ---------------------------- procedure Write_Stamp_Comparison (Newer, Older : File_Name_Type) is begin Write_Program_Name; Write_Str (": "); Write_Name (Newer); if Debug_Mode then Write_Str (" ("); Write_Str (String (File_Time_Stamp (Newer))); Write_Str (")"); end if; Write_Eol; Write_Program_Name; Write_Str (": is more recent than"); Write_Eol; Write_Program_Name; Write_Str (": "); Write_Name (Older); if Debug_Mode then Write_Str (" ("); Write_Str (String (File_Time_Stamp (Older))); Write_Str (")"); end if; Write_Eol; end Write_Stamp_Comparison; --------------- -- Write_Str -- --------------- procedure Write_Str (S : String) is begin for J in S'Range loop Write_Char (S (J)); end loop; end Write_Str; end XE_IO; polyorb-2.8~20110207.orig/compilers/gnatdist/xe_main.adb0000644000175000017500000001605511750740337022321 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- X E _ M A I N -- -- -- -- B o d y -- -- -- -- Copyright (C) 1995-2009, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with Ada.Characters.Handling; use Ada.Characters.Handling; with Ada.Exceptions; use Ada.Exceptions; with XE; use XE; with XE_Back; use XE_Back; with XE_Back.GARLIC; use XE_Back.GARLIC; with XE_Back.PolyORB; use XE_Back.PolyORB; with XE_Defs; use XE_Defs; with XE_Flags; use XE_Flags; with XE_Front; use XE_Front; with XE_IO; use XE_IO; with XE_Names; use XE_Names; with XE_Parse; use XE_Parse; with XE_Types; use XE_Types; with XE_Sem; use XE_Sem; with XE_Scan; use XE_Scan; with XE_Stdcnf; use XE_Stdcnf; with XE_Utils; use XE_Utils; with XE_Units; use XE_Units; with XE_Usage; procedure XE_Main is Partition : Partition_Id; Backend : XE_Back.Backend_Access; Raised_Usage_Error : Boolean := False; -- If command line processing raises Usage_Error, we want to defer -- propagation until after calling Show_Dist_Args if in debug mode. function NS (N : Name_Id) return String renames XE_Names.Get_Name_String; begin XE_Names.Initialize; begin XE_Utils.Initialize; Backend := XE_Back.Find_Backend (Get_PCS_Name); Set_PCS_Dist_Flags (Backend); exception when Usage_Error => Raised_Usage_Error := True; end; if Debug_Mode then XE_Utils.Show_Dist_Args; end if; if Raised_Usage_Error then raise Usage_Error; end if; if XE_Utils.Number_Of_Files = 0 then XE_Usage; Exit_Program (E_Success); end if; XE.Initialize; XE_Scan.Initialize; XE_Parse.Initialize; XE_Stdcnf.Initialize; XE_Front.Initialize; XE_Back.Register_Storages (Backend); -- Look for the configuration file that is Next_Main_Source or -- Next_Main_Source + ".cfg" if the former does not exist. Configuration_File_Name := Next_Main_Source; if not Is_Regular_File (Configuration_File_Name) then -- Not found: try to add ".cfg" Get_Name_String (Configuration_File_Name); Add_Str_To_Name_Buffer (Cfg_Suffix); Configuration_File_Name := Name_Find; if not Is_Regular_File (Configuration_File_Name) then raise Fatal_Error with "file " & NS (Quote (Configuration_File_Name)) & " not found"; end if; end if; -- Parse the configuration file and fill the different tables Parse; Frontend; -- Configuration name and configuration file name do not match (case -- insensitively, to mimic the way project files work) Get_Name_String (Strip_Directory (Configuration_File_Name)); Name_Len := Name_Len - Cfg_Suffix'Length; if To_Lower (Get_Name_String (Configuration)) /= To_Lower (Get_Name_String (Name_Find)) then raise Fatal_Error with "configuration file name should be " & NS (Quote (Configuration & Cfg_Suffix_Id)); end if; -- Look for a partition list on the command line. Only those partitions are -- built. If no partition list is given, then generate all of them. if More_Source_Files then for J in Partitions.First + 1 .. Partitions.Last loop Partitions.Table (J).To_Build := False; end loop; -- As a result of the parsing, the name table info of a -- partition name contains its partition id. If there is no -- partition id attached to this name, then it is not a -- declared partition. while More_Source_Files loop Partition := Get_Partition_Id (Next_Main_Source); if Partition = No_Partition_Id then raise Fatal_Error with "unknown partition " & NS (Quote (Next_Main_Source)); end if; Partitions.Table (Partition).To_Build := True; end loop; -- Check whether we build the whole configuration for J in Partitions.First + 1 .. Partitions.Last loop if not Partitions.Table (J).To_Build then Partitions.Table (Default_Partition_Id).To_Build := False; exit; end if; end loop; end if; -- Check consistency once we know which partitions to build. Some parts of -- configuration may be missing because we partially build the distributed -- system. XE_Back.Initialize (Backend); Analyze; XE_Back.Run_Backend (Backend); -- Everything went fine Exit_Program (E_Success); exception when Scanning_Error => Message ("*** scanning failed"); Exit_Program (E_Fatal); when Parsing_Error => Message ("*** parsing failed"); Exit_Program (E_Fatal); when Partitioning_Error => Message ("*** partitioning failed"); Exit_Program (E_Fatal); when Usage_Error => Message ("*** wrong argument(s)"); Exit_Program (E_Fatal); when Not_Yet_Implemented => Message ("*** unimplemented feature"); Exit_Program (E_Fatal); when E : Fatal_Error => Message (Ada.Exceptions.Exception_Message (E)); Message ("*** can't continue"); Exit_Program (E_Fatal); when Compilation_Error => Exit_Program (E_Fatal); when others => Remove_All_Temp_Files; raise; end XE_Main; polyorb-2.8~20110207.orig/compilers/gnatdist/xe_names.ads0000644000175000017500000002416611750740337022523 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- X E _ N A M E S -- -- -- -- S p e c -- -- -- -- Copyright (C) 1995-2008, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- This package contains routines to handle a name table. Close to Namet. with GNAT.Table; with XE_Types; use XE_Types; package XE_Names is -- This package contains routines for handling the names table. The table -- is used to store character strings for identifiers and operator symbols, -- as well as other string values such as unit names and file names. -- The names are hashed so that a given name appears only once in the table, -- except that names entered with Name_Enter as opposed to Name_Find are -- omitted from the hash table. -- The first 26 entries in the names table (with Name_Id values in the range -- First_Name_Id .. First_Name_Id + 25) represent names which are the one -- character lower case letters in the range a-z, and these names are created -- and initialized by the Initialize procedure. -- Two values, one of type Int and one of type Byte, are stored with each -- names table entry and subprograms are provided for setting and retrieving -- these associated values. The usage of these values is up to the client. Name_Buffer : String (1 .. 16*1024); -- This buffer is used to set the name to be stored in the table for the -- Name_Find call, and to retrieve the name for the Get_Name_String call. -- The plus 1 in the length allows for cases of adding ASCII.NUL. The -- 16K here is intended to be an infinite value that ensures that we -- never overflow the buffer (names this long are too absurd to worry!) Name_Len : Natural; -- Length of name stored in Name_Buffer. Used as an input parameter for -- Name_Find, and as an output value by Get_Name_String, or Write_Name. ----------------- -- Subprograms -- ----------------- procedure Get_Name_String (Id : Name_Id); -- Get_Name_String is used to retrieve the string associated with an entry -- in the names table. The resulting string is stored in Name_Buffer -- and Name_Len is set. It is an error to call Get_Name_String with one -- of the special name Id values (No_Name or Error_Name). function Get_Name_String (Id : Name_Id) return String; -- This functional form returns the result as a string without affecting -- the contents of either Name_Buffer or Name_Len. procedure Get_Name_String_And_Append (Id : Name_Id); -- Like Get_Name_String but the resulting characters are appended to -- the current contents of the entry stored in Name_Buffer, and Name_Len -- is incremented to include the added characters. function Get_Name_Table_Byte (Id : Name_Id) return Byte; pragma Inline (Get_Name_Table_Byte); -- Fetches the Byte value associated with the given name function Get_Name_Table_Info (Id : Name_Id) return Int; pragma Inline (Get_Name_Table_Info); -- Fetches the Int value associated with the given name procedure Initialize; -- Initializes the names table, including initializing the first 26 -- entries in the table (for the 1-character lower case names a-z) -- Note that Initialize must not be called if Tree_Read is used. function Name_Find return Name_Id; -- Name_Find is called with a string stored in Name_Buffer whose length -- is in Name_Len (i.e. the characters of the name are in subscript -- positions 1 to Name_Len in Name_Buffer). It searches the names -- table to see if the string has already been stored. If so the Id of -- the existing entry is returned. Otherwise a new entry is created with -- its Name_Table_Info field set to zero. The contents of Name_Buffer -- and Name_Len are not modified by this call. function Name_Enter return Name_Id; -- Name_Enter has the same calling interface as Name_Find. The difference -- is that it does not search the table for an existing match, and also -- subsequent Name_Find calls using the same name will not locate the -- entry created by this call. Thus multiple calls to Name_Enter with the -- same name will create multiple entries in the name table with different -- Name_Id values. This is useful in the case of created names, which are -- never expected to be looked up. Note: Name_Enter should never be used -- for one character names, since these are efficiently located without -- hashing by Name_Find in any case. procedure Add_Char_To_Name_Buffer (C : Character); pragma Inline (Add_Char_To_Name_Buffer); -- Add given character to the end of the string currently stored in the -- Name_Buffer, incrementing Name_Len. procedure Set_Char_To_Name_Buffer (C : Character); pragma Inline (Set_Char_To_Name_Buffer); -- Equivalent to Name_Len := 0; followed by Add_Char_To_Name_Buffer (C); procedure Add_Nat_To_Name_Buffer (V : Nat); -- Add decimal representation of given value to the end of the string -- currently stored in Name_Buffer, incrementing Name_Len as required. procedure Set_Nat_To_Name_Buffer (V : Nat); pragma Inline (Set_Nat_To_Name_Buffer); -- Equivalent to Name_Len := 0; followed by Add_Nat_To_Name_Buffer (V); procedure Add_Str_To_Name_Buffer (S : String); -- Add characters of string S to the end of the string currently stored -- in the Name_Buffer, incrementing Name_Len by the length of the string. procedure Set_Str_To_Name_Buffer (S : String); pragma Inline (Set_Str_To_Name_Buffer); -- Equivalent to Name_Len := 0; followed by Add_Str_To_Name_Buffer (S); procedure Set_Name_Table_Info (Id : Name_Id; Val : Int); pragma Inline (Set_Name_Table_Info); -- Sets the Int value associated with the given name procedure Set_Name_Table_Byte (Id : Name_Id; Val : Byte); pragma Inline (Set_Name_Table_Byte); -- Sets the Byte value associated with the given name procedure Write_Name (Id : Name_Id); -- Write_Name writes the characters of the specified name using the -- standard output procedures in package Output. No end of line is -- written, just the characters of the name. On return Name_Buffer and -- Name_Len are set as for a call to Get_Name_String. The name is written -- in encoded form (i.e. including Uhh, Whhh, Qx, _op as they appear in -- the name table). If Id is Error_Name, or No_Name, no text is output. procedure wn (Id : Name_Id); pragma Export (Ada, wn); -- Like Write_Name, but includes new line at end. Intended for use -- from the debugger only. --------------------------- -- Table Data Structures -- --------------------------- -- The following declarations define the data structures used to store -- names. The definitions are in the private part of the package spec, -- rather than the body, since they are referenced directly by gigi. private -- This table stores the actual string names. Although logically there -- is no need for a terminating character (since the length is stored -- in the name entry table), we still store a NUL character at the end -- of every name (for convenience in interfacing to the C world). package Name_Chars is new GNAT.Table ( Table_Component_Type => Character, Table_Index_Type => Int, Table_Low_Bound => 0, Table_Initial => 50_000, Table_Increment => 100); type Name_Entry is record Name_Chars_Index : Int; -- Starting location of characters in the Name_Chars table minus -- one (i.e. pointer to character just before first character). The -- reason for the bias of one is that indexes in Name_Buffer are -- one's origin, so this avoids unnecessary adds and subtracts of 1. Name_Len : Short; -- Length of this name in characters Byte_Info : Byte; -- Byte value associated with this name Hash_Link : Name_Id; -- Link to next entry in names table for same hash code Int_Info : Int; -- Int Value associated with this name end record; -- This is the table that is referenced by Name_Id entries. -- It contains one entry for each unique name in the table. package Name_Entries is new GNAT.Table ( Table_Component_Type => Name_Entry, Table_Index_Type => Name_Id, Table_Low_Bound => First_Name_Id, Table_Initial => 6_000, Table_Increment => 100); end XE_Names; polyorb-2.8~20110207.orig/compilers/gnatdist/xe_types.adb0000644000175000017500000000476011750740337022541 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- X E _ T Y P E S -- -- -- -- B o d y -- -- -- -- Copyright (C) 1995-2008, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ package body XE_Types is ----------- -- Dummy -- ----------- procedure Dummy (E : Node_Id) is begin if Present (E) then null; end if; end Dummy; -------- -- No -- -------- function No (E : Node_Id) return Boolean is begin return E = No_Node; end No; ------------- -- Present -- ------------- function Present (E : Node_Id) return Boolean is begin return E /= No_Node; end Present; end XE_Types; polyorb-2.8~20110207.orig/compilers/gnatdist/xe_back-garlic.adb0000644000175000017500000013453611750740337023541 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- X E _ B A C K . G A R L I C -- -- -- -- B o d y -- -- -- -- Copyright (C) 1995-2009, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with GNAT.Directory_Operations; use GNAT.Directory_Operations; with GNAT.OS_Lib; use GNAT.OS_Lib; with XE; use XE; with XE_Defs; use XE_Defs; with XE_Flags; use XE_Flags; with XE_Front; use XE_Front; with XE_IO; use XE_IO; with XE_Names; use XE_Names; with XE_Utils; use XE_Utils; with XE_Storages; use XE_Storages; with XE_Back; pragma Elaborate_All (XE_Back); package body XE_Back.GARLIC is type GARLIC_Backend is new Backend with null record; procedure Set_PCS_Dist_Flags (Self : access GARLIC_Backend); procedure Initialize (Self : access GARLIC_Backend); procedure Register_Storages (Self : access GARLIC_Backend); procedure Run_Backend (Self : access GARLIC_Backend); function Get_Detach_Flag (Self : access GARLIC_Backend) return Name_Id; Elaboration_File : File_Name_Type; Protocol_Config_File : File_Name_Type; Storage_Config_File : File_Name_Type; type RU_Id is (RU_System, RU_System_Garlic, RU_System_Garlic_Elaboration, RU_System_Garlic_Filters, RU_System_Garlic_Heart, RU_System_Garlic_Name_Table, RU_System_Garlic_No_Tasking, RU_System_Garlic_Options, RU_System_Garlic_Priorities, RU_System_Garlic_Protocols, RU_System_Garlic_Protocols_Config, RU_System_Garlic_Remote, RU_System_Garlic_Startup, RU_System_Garlic_Storages, RU_System_Garlic_Storages_Config, RU_System_Garlic_Tasking, RU_System_Garlic_Types, RU_System_Partition_Interface, RU_System_RPC, RU_System_RPC_Server); RU : array (RU_Id) of Unit_Name_Type; type RE_Id is (RE_Register_Partition_To_Launch, RE_Set_RPC_Handler_Priority, RE_Set_RPC_Handler_Priority_Policy, RE_Set_Rsh_Command, RE_Set_Rsh_Options, RE_Set_Slave, RE_Set_Termination, RE_Set_Reconnection, RE_Set_Boot_Location, RE_Set_Self_Location, RE_Set_Data_Location, RE_Set_Nolaunch, RE_Set_Task_Pool_Bounds, RE_Set_Light_PCS, RE_Set_Pure_Client, RE_Initialize_0, RE_Initialize_1, RE_Initialize_2, RE_Set_Partition_Name, RE_Set_Registration_Filter, RE_Set_Default_Filter, RE_Set_Channel_Filter, RE_Register_Passive_Partition, RE_Register_Passive_Package, RE_Register_Passive_Package_On_Passive_Partition, RE_Elaborate_Passive_Partition, RE_Check, RE_Run, RE_Partition_ID, RE_Register); RE : array (RE_Id) of Unit_Name_Type; RE_Unit_Table : constant array (RE_Id) of RU_Id := (RE_Register_Partition_To_Launch => RU_System_Garlic_Remote, RE_Set_RPC_Handler_Priority => RU_System_Garlic_Priorities, RE_Set_RPC_Handler_Priority_Policy => RU_System_Garlic_Priorities, RE_Set_Rsh_Command => RU_System_Garlic_Options, RE_Set_Rsh_Options => RU_System_Garlic_Options, RE_Set_Slave => RU_System_Garlic_Options, RE_Set_Termination => RU_System_Garlic_Options, RE_Set_Reconnection => RU_System_Garlic_Options, RE_Set_Boot_Location => RU_System_Garlic_Options, RE_Set_Self_Location => RU_System_Garlic_Options, RE_Set_Data_Location => RU_System_Garlic_Options, RE_Set_Nolaunch => RU_System_Garlic_Options, RE_Set_Task_Pool_Bounds => RU_System_Garlic_Options, RE_Set_Light_PCS => RU_System_Garlic_Options, RE_Set_Pure_Client => RU_System_Garlic_Options, RE_Initialize_0 => RU_System_Garlic_No_Tasking, RE_Initialize_1 => RU_System_Garlic_Tasking, RE_Initialize_2 => RU_System_Garlic_Name_Table, RE_Set_Partition_Name => RU_System_Garlic_Options, RE_Set_Registration_Filter => RU_System_Garlic_Filters, RE_Set_Default_Filter => RU_System_Garlic_Filters, RE_Set_Channel_Filter => RU_System_Garlic_Filters, RE_Register_Passive_Partition => RU_System_Partition_Interface, RE_Register_Passive_Package => RU_System_Partition_Interface, RE_Register_Passive_Package_On_Passive_Partition => RU_System_Partition_Interface, RE_Elaborate_Passive_Partition => RU_System_Partition_Interface, RE_Check => RU_System_Partition_Interface, RE_Run => RU_System_Partition_Interface, RE_Partition_ID => RU_System_RPC, RE_Register => RU_System_Garlic_Protocols); procedure Add_Protocol (First : in out Location_Id; Last : in out Location_Id; Name : Name_Id); -- Add a protocol of name Name to the chained list which starts at -- First and ends at Last. procedure Generate_Elaboration_File (P : Partition_Id); -- Create the elaboration unit for the given partition. This unit -- overloads the default PCS settings. procedure Generate_Executable_File (P : Partition_Id); -- Compile main partition file and elaboration file. -- Bind and link partition to create executable. procedure Generate_PCS_Project_Files; procedure Generate_Partition_Main_File (P : Partition_Id); -- Create a procedure which "withes" all the RCI or SP receivers -- of the partition and insert the main procedure if needed. procedure Generate_Overridden_PCS_Units_File (P : Partition_Id; F : out File_Descriptor); -- Generate the initial list of PCS files that are overridden by the -- partition. Further per-partition generation subprograms may append to -- that list by writing further lines using the returned file descriptor. procedure Generate_Protocol_Config_File (P : Partition_Id; F : File_Descriptor); -- Create protocol configuration file that includes the protocols required -- for this partition. -- If the unit is generated, write its name to F to note that the -- corresponding PCS source is overridden. procedure Generate_Storage_Config_File (P : Partition_Id; F : File_Descriptor); -- Create storage configuration file that includes the storages required -- for this partition. -- If the unit is generated, write its name to F to note that the -- corresponding PCS source is overridden. function Name (U : Unit_Id) return Name_Id; -- Take a unit id and return its name removing unit suffix. DSA_Inc_Rel_Dir : constant String := "lib" & Directory_Separator & "garlic"; -- GARLIC include directory, relative to the installation prefix GARLIC_Prefix : constant String := XE_Back.Prefix (Check_For => DSA_Inc_Rel_Dir & Dir_Separator & "s-garlic.ads"); DSA_Inc_Dir : constant String := GARLIC_Prefix & DSA_Inc_Rel_Dir; ------------------ -- Add_Protocol -- ------------------ procedure Add_Protocol (First : in out Location_Id; Last : in out Location_Id; Name : Name_Id) is LID : Location_Id; begin if First /= No_Location_Id then LID := First; while LID /= No_Location_Id loop if Locations.Table (LID).Major = Name then return; end if; LID := Locations.Table (LID).Next_Location; end loop; end if; Add_Location (First, Last, Name, No_Name); end Add_Protocol; ------------------------------- -- Generate_Elaboration_File -- ------------------------------- procedure Generate_Elaboration_File (P : Partition_Id) is procedure Register_Launched_Partition (P : Partition_Id); --------------------------------- -- Register_Launched_Partition -- --------------------------------- procedure Register_Launched_Partition (P : Partition_Id) is Current : Partition_Type renames Partitions.Table (P); Use_Rem_Host : Boolean; Remote_Host : Name_Id; Executable : File_Name_Type := Current.Executable_File; begin Write_Image (Remote_Host, Current.Host, P); Use_Rem_Host := Present (Remote_Host); if not Use_Rem_Host then Remote_Host := Quote (Current.Name); end if; Executable := Strip_Exec_Suffix (Executable); Write_Call (RE (RE_Register_Partition_To_Launch), N1 => Capitalize (Id (Boolean'Image (Use_Rem_Host))), S1 => Get_Name_String (Remote_Host), N2 => Quote (Id (Get_Env_Vars (P, Names_Only => False))), N3 => Quote (To_Absolute_File (Executable) & Current.Command_Line)); end Register_Launched_Partition; Filename : File_Name_Type; File : File_Descriptor; Current : Partition_Type renames Partitions.Table (P); Channel : Channel_Id; Filter : Filter_Name_Type; Peer : Partition_Id; begin Filename := Elaboration_File & ADB_Suffix_Id; Filename := Dir (Current.Partition_Dir, Filename); Create_File (File, Filename); Set_Output (File); Write_Warnings_Pragmas; Write_With_Clause (RU (RU_System_Garlic_Filters), True); Write_With_Clause (RU (RU_System_Garlic_Heart), True); Write_With_Clause (RU (RU_System_Garlic_Name_Table), True); Write_With_Clause (RU (RU_System_Garlic_Options), True); Write_With_Clause (RU (RU_System_Garlic_Priorities), True); Write_With_Clause (RU (RU_System_Garlic_Remote), True); Write_With_Clause (RU (RU_System_Garlic_Types), True); if Current.Tasking = No_Tasking then Write_With_Clause (RU (RU_System_Garlic_No_Tasking), False, True); else Write_With_Clause (RU (RU_System_Garlic_Tasking), False, True); end if; -- Add filtering package if needed Filter := Default_Registration_Filter; if Present (Filter) then Write_With_Clause (RU (RU_System_Garlic_Filters) and Capitalize (Filter)); end if; if Present (Current.Filter) then Write_With_Clause (RU (RU_System_Garlic_Filters) and Capitalize (Current.Filter)); end if; if Current.First_Channel /= No_Channel_Id then Channel := Current.First_Channel; while Channel /= No_Channel_Id loop Filter := Channels.Table (Channel).Filter; if Present (Filter) then Write_With_Clause (RU (RU_System_Garlic_Filters) and Capitalize (Filter)); end if; if Channels.Table (Channel).Lower.My_Partition = P then Channel := Channels.Table (Channel).Lower.Next_Channel; else Channel := Channels.Table (Channel).Upper.Next_Channel; end if; end loop; end if; Write_Str ("package body "); Write_Name (RU (RU_System_Garlic_Elaboration)); Write_Line (" is"); Increment_Indentation; Write_Indentation; Write_Line ("procedure Initialize is"); Write_Indentation; Write_Line ("begin"); Increment_Indentation; if Current.Priority /= No_Priority then Write_Call (RE (RE_Set_RPC_Handler_Priority), No_Name, I1_Present => True, I1 => Int (Current.Priority)); end if; if Default_Priority_Policy /= No_Priority_Policy then Write_Call (RE (RE_Set_RPC_Handler_Priority_Policy), Priority_Policy_Img (Default_Priority_Policy)); end if; Write_Call (RE (RE_Set_Rsh_Command), Quote (Get_Rsh_Command)); Write_Call (RE (RE_Set_Rsh_Options), Quote (Get_Rsh_Options)); -- If the partition holds the main unit, then it cannot be slave. -- Otherwise, it is. if P /= Main_Partition then Write_Call (RE (RE_Set_Slave), Id ("True")); else Write_Call (RE (RE_Set_Slave), Id ("False")); end if; -- How should the partition terminate. Note that -- Global_Termination is the default. No need to force the -- default. if Current.Termination /= No_Termination then Write_Call (RE (RE_Set_Termination), Termination_Img (Current.Termination)); end if; -- When this partition is restarted, how should we handle -- reconnections? if Current.Reconnection /= No_Reconnection then Write_Call (RE (RE_Set_Reconnection), Reconnection_Img (Current.Reconnection)); end if; -- If a protocol has been specified, then use it (with its data -- if present). if Default_First_Boot_Location /= No_Location_Id then Write_Call (RE (RE_Set_Boot_Location), Location_List_Image (Default_First_Boot_Location)); end if; -- Compute the self location string (eventually composed of -- several locations separated by commas). if Current.First_Network_Loc /= No_Location_Id then Write_Call (RE (RE_Set_Self_Location), Location_List_Image (Current.First_Network_Loc)); end if; -- Compute the data location string (eventually composed of -- several locations separated by commas). if Current.Storage_Loc /= No_Location_Id then Write_Call (RE (RE_Set_Data_Location), Location_List_Image (Current.Storage_Loc)); end if; -- If we have no Ada starter (None or Shell), then it is equivalent -- to having --nolaunch on the command line. if Default_Starter /= Ada_Import then Write_Call (RE (RE_Set_Nolaunch), No_Name, "True"); end if; -- Do we want to control the number of anonymous tasks if Current.Task_Pool /= No_Task_Pool then Name_Len := 0; Add_Str_To_Name_Buffer (Int'Image (Current.Task_Pool (1))); Add_Char_To_Name_Buffer (','); Add_Str_To_Name_Buffer (Int'Image (Current.Task_Pool (2))); Add_Char_To_Name_Buffer (','); Add_Str_To_Name_Buffer (Int'Image (Current.Task_Pool (3))); Write_Call (RE (RE_Set_Task_Pool_Bounds), Id (Name_Buffer (2 .. Name_Len))); end if; -- Set tasking policy and with appropriate package if Current.Tasking = No_Tasking then Write_Call (RE (RE_Initialize_0)); Write_Call (RE (RE_Set_Light_PCS), Id ("True")); elsif Current.Tasking = User_Tasking then Write_Call (RE (RE_Initialize_1)); Write_Call (RE (RE_Set_Pure_Client), Id ("True")); else -- Get_Tasking (P) = 'P' Write_Call (RE (RE_Initialize_1)); end if; -- Elaborate Name_Table Write_Call (RE (RE_Initialize_2)); Write_Call (RE (RE_Set_Partition_Name), Quote (Current.Name)); -- Set registration filter, default filter and partition filters Filter := Default_Registration_Filter; if Present (Filter) then Write_Call (RE (RE_Set_Registration_Filter), Quote (Filter)); end if; Filter := Partitions.Table (Default_Partition_Id).Filter; if Present (Filter) then Write_Call (RE (RE_Set_Default_Filter), Quote (Filter)); end if; Channel := Current.First_Channel; while Channel /= No_Channel_Id loop Filter := Channels.Table (Channel).Filter; if Channels.Table (Channel).Lower.My_Partition = P then Peer := Channels.Table (Channel).Upper.My_Partition; Channel := Channels.Table (Channel).Lower.Next_Channel; else Peer := Channels.Table (Channel).Lower.My_Partition; Channel := Channels.Table (Channel).Upper.Next_Channel; end if; if Present (Filter) then Write_Call (RE (RE_Set_Channel_Filter), Quote (Partitions.Table (Peer).Name), No_Str, Quote (Filter)); end if; end loop; -- Initialize filters Filter := Default_Registration_Filter; if Present (Filter) then Write_Call (RU (RU_System_Garlic_Filters) and Capitalize (Filter) and "Initialize"); end if; if Present (Current.Filter) then Write_Call (RU (RU_System_Garlic_Filters) and Capitalize (Current.Filter) and "Initialize"); end if; Channel := Current.First_Channel; while Channel /= No_Channel_Id loop Filter := Channels.Table (Channel).Filter; if Present (Filter) then Write_Call (RU (RU_System_Garlic_Filters) and Capitalize (Filter) and "Initialize"); end if; if Channels.Table (Channel).Lower.My_Partition = P then Channel := Channels.Table (Channel).Lower.Next_Channel; else Channel := Channels.Table (Channel).Upper.Next_Channel; end if; end loop; if P = Main_Partition then if Default_Starter = Ada_Import then for J in Partitions.First + 1 .. Partitions.Last loop if J /= Main_Partition and then Partitions.Table (J).Passive /= BTrue then Register_Launched_Partition (J); end if; end loop; end if; end if; Decrement_Indentation; Write_Indentation; Write_Line ("end Initialize;"); Decrement_Indentation; Write_Str ("end "); Write_Name (RU (RU_System_Garlic_Elaboration)); Write_Line (";"); Close (File); Set_Standard_Output; end Generate_Elaboration_File; ------------------------------ -- Generate_Executable_File -- ------------------------------ procedure Generate_Executable_File (P : Partition_Id) is Current : Partition_Type renames Partitions.Table (P); Executable : File_Name_Type renames Current.Executable_File; Partition_Dir : Directory_Name_Type renames Current.Partition_Dir; I_Part_Dir : String_Access; Comp_Args : String_List (1 .. 7); Make_Args : String_List (1 .. 11); Sfile : File_Name_Type; Prj_Fname : File_Name_Type; begin Set_Str_To_Name_Buffer ("-I"); Get_Name_String_And_Append (Partition_Dir); I_Part_Dir := new String'(Name_Buffer (1 .. Name_Len)); -- Give the priority to partition and stub directory against -- current directory. Comp_Args (1) := E_Current_Dir; Comp_Args (2) := I_Part_Dir; Comp_Args (3) := A_Stub_Dir; Comp_Args (4) := I_Current_Dir; Comp_Args (5) := Project_File_Flag; Prj_Fname := Dir (Partition_Dir, Part_Prj_File_Name); Comp_Args (6) := new String'(Get_Name_String (Prj_Fname)); Comp_Args (7) := new String'(Partition_Dir_Flag (P)); -- Compile Garlic elaboration file Sfile := Elaboration_File & ADB_Suffix_Id; Sfile := Dir (Partition_Dir, Sfile); Compile (Sfile, Comp_Args); -- Compile protocol configuration file if any Sfile := Protocol_Config_File & ADB_Suffix_Id; if Is_Regular_File (Dir (Partition_Dir, Sfile)) then Sfile := Dir (Partition_Dir, Sfile); Compile (Sfile, Comp_Args); end if; -- Compile storage support configuration file if any Sfile := Storage_Config_File & ADB_Suffix_Id; if Is_Regular_File (Dir (Partition_Dir, Sfile)) then Sfile := Dir (Partition_Dir, Sfile); Compile (Sfile, Comp_Args); end if; -- We already checked the consistency of all the partition -- units. In case of an inconsistency of exception mode, we may -- have to rebuild some parts of garlic (units configured just -- for this partition). Note that some parts of Garlic may have -- been already recompiled when the monolithic application was -- initially built. Some bodies may be missing as they are -- assigned to partitions we do not want to build. So compile -- silently and do not exit on errors (keep going). Sfile := Partition_Main_File & ADB_Suffix_Id; Build (Sfile, Comp_Args, Fatal => False); -- Now we just want to bind and link as the ALI files are now -- consistent. Make_Args (1) := E_Current_Dir; Make_Args (2) := I_Part_Dir; Make_Args (3) := A_Stub_Dir; Make_Args (4) := I_Current_Dir; Make_Args (5) := Bind_Only_Flag; Make_Args (6) := Link_Only_Flag; Make_Args (7) := Project_File_Flag; Prj_Fname := Dir (Partition_Dir, Part_Prj_File_Name); Make_Args (8) := new String'(Get_Name_String (Prj_Fname)); Make_Args (9) := Comp_Args (7); Make_Args (10) := Output_Flag; Make_Args (11) := new String'(Get_Name_String (Strip_Directory (Executable))); Build (Sfile, Make_Args, Fatal => True); Free (Comp_Args (6)); Free (Comp_Args (7)); Free (Make_Args (2)); Free (Make_Args (8)); Free (Make_Args (11)); end Generate_Executable_File; ---------------------------------- -- Generate_Partition_Main_File -- ---------------------------------- procedure Generate_Partition_Main_File (P : Partition_Id) is Filename : File_Name_Type; File : File_Descriptor; Current : Partition_Type renames Partitions.Table (P); Conf_Unit : Conf_Unit_Id; Unit : Unit_Id; Variable : constant Name_Id := Id ("Partition"); Location : Location_Id; function Import_Stub_From (Partition : Partition_Id) return Boolean; -- Return True when we include stubs assigned to Partition ---------------------- -- Import_Stub_From -- ---------------------- function Import_Stub_From (Partition : Partition_Id) return Boolean is begin for J in Current.First_Stub .. Current.Last_Stub loop if Get_Partition_Id (Stubs.Table (J)) = Partition then return True; end if; end loop; return False; end Import_Stub_From; begin Filename := Partition_Main_File & ADB_Suffix_Id; Filename := Dir (Current.Partition_Dir, Filename); Create_File (File, Filename); Set_Output (File); Write_Warnings_Pragmas; Write_With_Clause (RU (RU_System_Partition_Interface), True); Write_With_Clause (RU (RU_System_RPC)); if Current.Tasking /= No_Tasking then Write_With_Clause (RU (RU_System_RPC_Server)); end if; Write_With_Clause (RU (RU_System_Garlic_Startup), False, True); -- Assign RCI or SP skels on the partition Conf_Unit := Current.First_Unit; while Conf_Unit /= No_Conf_Unit_Id loop Write_With_Clause (Conf_Units.Table (Conf_Unit).Name); Conf_Unit := Conf_Units.Table (Conf_Unit).Next_Unit; end loop; -- Assign the RCI or SP stubs to compare version with skels for J in Current.First_Stub .. Current.Last_Stub loop Write_With_Clause (Stubs.Table (J)); end loop; -- Add termination package and locking mechanisms if needed Write_Str ("procedure "); Write_Name (Partition_Main_Name); Write_Line (" is"); Increment_Indentation; Write_Indentation; Write_Name (Variable); Write_Line (" : "); Write_Name (RE (RE_Partition_ID)); Write_Line (";"); Decrement_Indentation; Write_Line ("begin"); Increment_Indentation; -- Register passive partitions and their shared passive -- packages as they are not going to do this registration by -- themselves. for J in Partitions.First + 1 .. Partitions.Last loop if Partitions.Table (J).Passive = BTrue and then Import_Stub_From (J) then Location := Partitions.Table (J).Storage_Loc; if Location = No_Location_Id then Location := Default_Data_Location; end if; Write_Call (RE (RE_Register_Passive_Partition), Variable, No_Str, Quote (Partitions.Table (J).Name), Get_Name_String (Location_List_Image (Location))); Conf_Unit := Partitions.Table (J).First_Unit; while Conf_Unit /= No_Conf_Unit_Id loop Write_Call (RE (RE_Register_Passive_Package_On_Passive_Partition), Variable, No_Str, Quote (Conf_Units.Table (Conf_Unit).Name), No_Str, Conf_Units.Table (Conf_Unit).Name & "'Version"); Conf_Unit := Conf_Units.Table (Conf_Unit).Next_Unit; end loop; Conf_Unit := Partitions.Table (J).First_Unit; if Conf_Unit /= No_Conf_Unit_Id then Write_Call (RE (RE_Elaborate_Passive_Partition), Variable); end if; end if; end loop; -- Register shared passive packages since they have no -- elaboration code. Conf_Unit := Current.First_Unit; while Conf_Unit /= No_Conf_Unit_Id loop Unit := Conf_Units.Table (Conf_Unit).My_Unit; if Units.Table (Unit).Shared_Passive then Write_Call (RE (RE_Register_Passive_Package), Quote (Conf_Units.Table (Conf_Unit).Name), Get_Name_String (Name (Unit)) & "'Version"); end if; Conf_Unit := Conf_Units.Table (Conf_Unit).Next_Unit; end loop; -- Check version consistency of RCI and SP stubs if Default_Version_Check then for J in Current.First_Stub .. Current.Last_Stub loop Unit := ALIs.Table (Get_ALI_Id (Stubs.Table (J))).Last_Unit; Write_Call (RE (RE_Check), Quote (Stubs.Table (J)), No_Str, Stubs.Table (J) & "'Version", Boolean'Image (Units.Table (Unit).RCI)); end loop; end if; -- Invoke main subprogram through Run routine if Present (Current.Main_Subprogram) then Get_Name_String (Current.Main_Subprogram); Add_Str_To_Name_Buffer ("'Access"); Write_Call (RE (RE_Run), Name_Find); else Write_Call (RE (RE_Run)); end if; Decrement_Indentation; Write_Str ("end "); Write_Name (Partition_Main_Name); Write_Line (";"); Close (File); Set_Standard_Output; end Generate_Partition_Main_File; ---------------------------------------- -- Generate_Overridden_PCS_Units_File -- ---------------------------------------- procedure Generate_Overridden_PCS_Units_File (P : Partition_Id; F : out File_Descriptor) is Partition_Dir : Directory_Name_Type; Filename : File_Name_Type; begin if P = No_Partition_Id then Partition_Dir := Stub_Dir_Name; else Partition_Dir := Partitions.Table (P).Partition_Dir; end if; Filename := Dir (Partition_Dir, Overridden_PCS_Units); Create_File (F, Filename); Set_Output (F); -- Always overridden Write_Line ("s-garela.adb"); if User_Provided_S_RPC then -- User has provided an alternative version of s-rpc: remove the -- one from GARLIC from the project. Write_Line ("s-rpc.adb"); end if; Set_Standard_Output; end Generate_Overridden_PCS_Units_File; -------------------------------- -- Generate_PCS_Project_Files -- -------------------------------- procedure Generate_PCS_Project_Files is Prj_Fname : File_Name_Type; File : File_Descriptor; begin -- Use GARLIC sources, but remove files that need to be overridden -- per-partition. Prj_Fname := Dir (Id (Root), PCS_Project_File); Create_File (File, Prj_Fname); Set_Output (File); Write_Str ("project "); Write_Name (PCS_Project); Write_Line (" is"); Write_Line (" for Externally_Built use ""true"";"); Write_Line (" for Source_Dirs use (""" & DSA_Inc_Dir & """);"); Write_Str (" Partition_Dir := external (""PARTITION_DIR"", """); Write_Name (Stub_Dir_Name); Write_Line (""");"); Write_Str (" for Excluded_Source_List_File use" & " Partition_Dir & """ & Dir_Separator); Write_Name (Overridden_PCS_Units); Write_Line (""";"); Write_Str ("end "); Write_Name (PCS_Project); Write_Line (";"); Close (File); Set_Standard_Output; -- Generate default exclusion list for RCI calling stubs Generate_Overridden_PCS_Units_File (No_Partition_Id, File); Close (File); end Generate_PCS_Project_Files; ----------------------------------- -- Generate_Protocol_Config_File -- ----------------------------------- procedure Generate_Protocol_Config_File (P : Partition_Id; F : File_Descriptor) is Filename : File_Name_Type; File : File_Descriptor; Current : Partition_Type renames Partitions.Table (P); Major : Name_Id; Location : Location_Id; First_Loc : Location_Id := No_Location_Id; Last_Loc : Location_Id := No_Location_Id; Light_PCS : Boolean; begin Filename := Dir (Current.Partition_Dir, Protocol_Config_File); Location := Current.First_Network_Loc; Light_PCS := Current.Tasking = No_Tasking and then Current.Light_PCS /= BFalse; -- Having no protocol configured on this partition is not -- enough for using the default protocol configuration. The -- default protocol configuration is customized for a tasking -- profile. Therefore, in case of light PCS, we have to produce -- a specific protocol configuration. if Location = No_Location_Id and then not Light_PCS then Delete_File (Filename & ADB_Suffix_Id); Delete_File (Filename & ALI_Suffix_Id); Delete_File (Filename & Obj_Suffix_Id); return; end if; Filename := Filename & ADB_Suffix_Id; -- Record that this PCS source file is overridden Set_Output (F); Write_Name (Protocol_Config_File); Write_Name (ADB_Suffix_Id); Write_Eol; Create_File (File, Filename); Set_Output (File); Write_Warnings_Pragmas; -- Required location protocols while Location /= No_Location_Id loop Add_Protocol (First_Loc, Last_Loc, Locations.Table (Location).Major); Location := Locations.Table (Location).Next_Location; end loop; if First_Loc = No_Location_Id then Location := Default_First_Boot_Location; while Location /= No_Location_Id loop Add_Protocol (First_Loc, Last_Loc, Locations.Table (Location).Major); Location := Locations.Table (Location).Next_Location; end loop; end if; if First_Loc = No_Location_Id then Add_Protocol (First_Loc, Last_Loc, Id (Get_Def_Protocol_Name)); end if; Location := First_Loc; while Location /= No_Location_Id loop Major := Capitalize (Locations.Table (Location).Major); Major := RU (RU_System_Garlic_Protocols) and Major; Write_With_Clause (Major, False, True); if Current.Tasking /= No_Tasking then Major := Major and "Server"; Write_With_Clause (Major, False, True); end if; Location := Locations.Table (Location).Next_Location; end loop; Write_Str ("package body "); Write_Name (RU (RU_System_Garlic_Protocols_Config)); Write_Line (" is"); Increment_Indentation; Write_Indentation; Write_Line ("procedure Initialize is"); Write_Indentation; Write_Line ("begin"); -- Register protocols used in partition locations Increment_Indentation; Location := First_Loc; while Location /= No_Location_Id loop Major := Capitalize (Locations.Table (Location).Major); Major := RU (RU_System_Garlic_Protocols) and Major; Write_Call (RE (RE_Register), Major and "Create"); Location := Locations.Table (Location).Next_Location; end loop; Decrement_Indentation; Write_Indentation; Write_Line ("end Initialize;"); Decrement_Indentation; Write_Eol; Write_Str ("end "); Write_Name (RU (RU_System_Garlic_Protocols_Config)); Write_Line (";"); Close (File); Set_Standard_Output; end Generate_Protocol_Config_File; ---------------------------------- -- Generate_Storage_Config_File -- ---------------------------------- procedure Generate_Storage_Config_File (P : Partition_Id; F : File_Descriptor) is Filename : File_Name_Type; File : File_Descriptor := Invalid_FD; Current : Partition_Type renames Partitions.Table (P); Partition : Partition_Id; Location : Location_Id; Uname : Unit_Name_Type; Major : Name_Id; Use_Default : Boolean := False; Conf_Unit : Conf_Unit_Id; Unit : Unit_Id; procedure Setup_Output; -- Open output file and record it as an overridden PCS unit, if not -- already done. ------------------ -- Setup_Output -- ------------------ procedure Setup_Output is begin if File = Invalid_FD then -- Record that this PCS source file is overridden Set_Output (F); Write_Name (Storage_Config_File); Write_Name (ADB_Suffix_Id); Write_Eol; Create_File (File, Filename); Set_Output (File); Write_Warnings_Pragmas; end if; end Setup_Output; begin Filename := Dir (Current.Partition_Dir, Storage_Config_File); Filename := Filename & ADB_Suffix_Id; Delete_File (To_Afile (Filename)); Delete_File (To_Ofile (Filename)); Delete_File (Filename); -- Import the storage supports needed for shared passive stub -- packages configured on other partitions. for S in Current.First_Stub .. Current.Last_Stub loop Uname := Stubs.Table (S); Unit := ALIs.Table (Get_ALI_Id (Uname)).Last_Unit; if Units.Table (Unit).Shared_Passive then Setup_Output; Partition := Get_Partition_Id (Uname); Location := Partitions.Table (Partition).Storage_Loc; if Location /= No_Location_Id then Major := Capitalize (Locations.Table (Location).Major); Major := RU (RU_System_Garlic_Storages) and Major; Write_With_Clause (Major, False, True); else Use_Default := True; end if; end if; end loop; -- Import storage supports needed for shared passive packages -- configured on this partition. Conf_Unit := Current.First_Unit; while Conf_Unit /= No_Conf_Unit_Id loop Unit := Conf_Units.Table (Conf_Unit).My_Unit; if Units.Table (Unit).Shared_Passive then Setup_Output; Location := Current.Storage_Loc; if Location /= No_Location_Id then Major := Capitalize (Locations.Table (Location).Major); Major := RU (RU_System_Garlic_Storages) and Major; Write_With_Clause (Major, False, True); else Use_Default := True; end if; end if; Conf_Unit := Conf_Units.Table (Conf_Unit).Next_Unit; end loop; -- Import default storage supports when a partition did not -- come with its own. if Use_Default then Location := Default_Data_Location; Major := Capitalize (Locations.Table (Location).Major); Major := RU (RU_System_Garlic_Storages) and Major; Write_With_Clause (Major, False, True); end if; if File = Invalid_FD then return; end if; -- Initialize storage supports Write_Str ("package body "); Write_Name (RU (RU_System_Garlic_Storages_Config)); Write_Line (" is"); Increment_Indentation; Write_Indentation; Write_Line ("procedure Initialize is"); Write_Indentation; Write_Line ("begin"); -- Follow the same approach as for package importation Increment_Indentation; for S in Current.First_Stub .. Current.Last_Stub loop Uname := Stubs.Table (S); Unit := ALIs.Table (Get_ALI_Id (Uname)).Last_Unit; if Units.Table (Unit).Shared_Passive then Partition := Get_Partition_Id (Uname); Location := Partitions.Table (Partition).Storage_Loc; if Location /= No_Location_Id then Major := Locations.Table (Location).Major; Write_Call (RU (RU_System_Garlic_Storages) and Capitalize (Major) and "Initialize"); end if; end if; end loop; Conf_Unit := Current.First_Unit; while Conf_Unit /= No_Conf_Unit_Id loop Unit := Conf_Units.Table (Conf_Unit).My_Unit; if Units.Table (Unit).Shared_Passive then Location := Current.Storage_Loc; if Location /= No_Location_Id then Major := Locations.Table (Location).Major; Write_Call (RU (RU_System_Garlic_Storages) and Capitalize (Major) and "Initialize"); end if; end if; Conf_Unit := Conf_Units.Table (Conf_Unit).Next_Unit; end loop; if Use_Default then Major := Locations.Table (Default_Data_Location).Major; Write_Call (RU (RU_System_Garlic_Storages) and Capitalize (Major) and "Initialize"); end if; Decrement_Indentation; Write_Indentation; Write_Line ("end Initialize;"); Decrement_Indentation; Write_Eol; Write_Str ("end "); Write_Name (RU (RU_System_Garlic_Storages_Config)); Write_Line (";"); Close (File); Set_Standard_Output; end Generate_Storage_Config_File; --------------------- -- Get_Detach_Flag -- --------------------- function Get_Detach_Flag (Self : access GARLIC_Backend) return Name_Id is pragma Unreferenced (Self); begin return Id ("--detach"); end Get_Detach_Flag; ---------------- -- Initialize -- ---------------- procedure Initialize (Self : access GARLIC_Backend) is pragma Unreferenced (Self); Position : Integer; Length : Natural; begin XE_Back.Initialize; Elaboration_File := Id ("s-garela"); Protocol_Config_File := Id ("s-gaprco"); Storage_Config_File := Id ("s-gastco"); Register_Casing_Rule ("PCS"); Register_Casing_Rule ("RPC"); for U in RU_Id'First .. RU_Id'Last loop Set_Str_To_Name_Buffer (RU_Id'Image (U)); Set_Str_To_Name_Buffer (Name_Buffer (4 .. Name_Len)); Apply_Casing_Rules (Name_Buffer (1 .. Name_Len)); Position := 0; RU (U) := Name_Find; Length := Name_Len; Set_Name_Table_Info (RU (U), RU_Id'Pos (U) + 1); while Name_Len > 0 loop if Name_Buffer (Name_Len) = '_' then Name_Len := Name_Len - 1; Position := Integer (Get_Name_Table_Info (Name_Find)); exit when Position > 0; else Name_Len := Name_Len - 1; end if; end loop; -- When there is a parent, remove parent unit name from -- unit name to get real identifier. if Position > 0 then Set_Str_To_Name_Buffer (Name_Buffer (Name_Len + 2 .. Length)); RU (U) := RU (RU_Id'Val (Position - 1)) and Name_Find; else Set_Str_To_Name_Buffer (Name_Buffer (1 .. Length)); RU (U) := Name_Find; end if; if Debug_Mode then Message (U'Img & " = " & Get_Name_String (RU (U))); end if; end loop; for E in RE_Id loop Set_Str_To_Name_Buffer (RE_Id'Image (E)); Set_Str_To_Name_Buffer (Name_Buffer (4 .. Name_Len)); Apply_Casing_Rules (Name_Buffer (1 .. Name_Len)); while Name_Buffer (Name_Len) in '0' .. '9' or else Name_Buffer (Name_Len) = '_' loop Name_Len := Name_Len - 1; end loop; RE (E) := RU (RE_Unit_Table (E)) and Name_Find; if Debug_Mode then Message (E'Img & " = " & Get_Name_String (RE (E))); end if; end loop; Generate_PCS_Project_Files; Generate_Application_Project_Files; end Initialize; ---------- -- Name -- ---------- function Name (U : Unit_Id) return Name_Id is begin return Name (Units.Table (U).Uname); end Name; ----------------------- -- Register_Storages -- ----------------------- procedure Register_Storages (Self : access GARLIC_Backend) is pragma Unreferenced (Self); begin Register_Storage (Storage_Name => "dfs", Allow_Passive => True, Allow_Local_Term => True, Need_Tasking => False); -- Registrer "dfs" storage support Register_Storage (Storage_Name => "dsm", Allow_Passive => False, Allow_Local_Term => False, Need_Tasking => True); -- Registrer "dsm" storage support end Register_Storages; ----------------- -- Run_Backend -- ----------------- procedure Run_Backend (Self : access GARLIC_Backend) is type Pass_Type is (Prepare, Build); -- We iterate twice over all partitions: a Prepare pass where source -- code and configuration files are produced, and then a Build pass -- after stubs have been compiled. procedure Iterate_Over_All_Partitions (Pass : Pass_Type); -- Execute required processing for the given pass for all partitions -- that need to be built. procedure Iterate_Over_All_Partitions (Pass : Pass_Type) is Current : Partition_Type; Overridden_PCS_Units : File_Descriptor; begin for J in Partitions.First + 1 .. Partitions.Last loop if Partitions.Table (J).To_Build then Current := Partitions.Table (J); if Current.To_Build and then Current.Passive /= BTrue then if Rebuild_Partition (J) then case Pass is when Prepare => Generate_Partition_Main_File (J); -- Prepare overridden PCS units. This is required -- for building the receiver stubs, since they -- use the partition project file. Generate_Overridden_PCS_Units_File (J, Overridden_PCS_Units); Generate_Elaboration_File (J); Generate_Protocol_Config_File (J, Overridden_PCS_Units); Generate_Storage_Config_File (J, Overridden_PCS_Units); Close (Overridden_PCS_Units); when Build => if not Quiet_Mode then Message ("building partition", Current.Name); end if; Generate_Executable_File (J); Generate_Stamp_File (J); end case; end if; elsif Verbose_Mode and then Pass = Prepare then Message ("no need to expand", Current.Name); end if; end if; end loop; end Iterate_Over_All_Partitions; begin Prepare_Directories; Iterate_Over_All_Partitions (Pass => Prepare); Generate_All_Stubs_And_Skels; Iterate_Over_All_Partitions (Pass => Build); Generate_Starter_File (Backend_Access (Self)); end Run_Backend; ------------------------ -- Set_PCS_Dist_Flags -- ------------------------ procedure Set_PCS_Dist_Flags (Self : access GARLIC_Backend) is pragma Unreferenced (Self); begin if not Is_Directory (DSA_Inc_Dir) then raise Fatal_Error with "GARLIC library not found"; end if; Scan_Dist_Arg ("-aI" & DSA_Inc_Dir); Scan_Dist_Arg ("-aO" & DSA_Inc_Dir); Scan_Dist_Arg ("-largs"); Scan_Dist_Arg ("-L" & DSA_Inc_Dir); Scan_Dist_Arg ("-lgarlic"); end Set_PCS_Dist_Flags; begin Register_Backend ("garlic", new GARLIC_Backend); end XE_Back.GARLIC; polyorb-2.8~20110207.orig/compilers/gnatdist/xe_stdcnf.adb0000644000175000017500000006002411750740337022651 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- X E _ S T D C N F -- -- -- -- B o d y -- -- -- -- Copyright (C) 1995-2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with XE_Types; use XE_Types; with XE; use XE; with XE_Parse; use XE_Parse; with XE_Scan; use XE_Scan; with XE_Utils; use XE_Utils; package body XE_Stdcnf is -- This procedure contains the standard configuration which is loaded -- before the user configuration. ---------------- -- Initialize -- ---------------- procedure Initialize is Variable_Node : Variable_Id; begin -- As a naming convention, we use the reserved keyword "private" -- for the standard configuration name. Create_Configuration (Configuration_Node, Id ("private")); -- type Boolean_Type is (False, True, Infinite); Declare_Type (Type_Name => Id ("boolean"), Type_Kind => Pre_Type_Boolean, Composite => False, Comp_Type => Null_Type, Array_Len => 0, Type_Sloc => Null_Location, Type_Node => Boolean_Type_Node); Declare_Variable (Id ("true"), Boolean_Type_Node, Null_Location, Variable_Node); -- To easily retrieve the enumeration literal. Set_Scalar_Value (Variable_Node, Int (BTrue)); Declare_Variable (Id ("false"), Boolean_Type_Node, Null_Location, Variable_Node); -- To easily retrieve the enumeration literal. Set_Scalar_Value (Variable_Node, Int (BFalse)); Declare_Variable (Id ("unknown boolean"), Boolean_Type_Node, Null_Location, Variable_Node); -- To easily retrieve the enumeration literal. Set_Scalar_Value (Variable_Node, Int (BMaybe)); -- type string (standard) Declare_Type (Type_Name => Id ("string"), Type_Kind => Pre_Type_String, Composite => False, Comp_Type => Null_Type, Array_Len => 0, Type_Sloc => Null_Location, Type_Node => String_Type_Node); -- type integer (standard) Declare_Type (Type_Name => Id ("integer"), Type_Kind => Pre_Type_Integer, Composite => False, Comp_Type => Null_Type, Array_Len => 0, Type_Sloc => Null_Location, Type_Node => Integer_Type_Node); -- Type Termination. To easily retrieve the enumeration literal -- and their image. for T in Termination_Img'Range loop Declare_Variable (To_Lower (Termination_Img (T)), Integer_Type_Node, Null_Location, Variable_Node); Set_Scalar_Value (Variable_Node, Int (T)); end loop; -- type Reconnection. To easily retrieve the enumeration literal -- and their image. for R in Reconnection_Img'Range loop Declare_Variable (To_Lower (Reconnection_Img (R)), Integer_Type_Node, Null_Location, Variable_Node); Set_Scalar_Value (Variable_Node, Int (R)); end loop; -- type priority_policy. To easily retrieve the enumeration -- literal and their image. for R in Priority_Policy_Img'Range loop Declare_Variable (To_Lower (Priority_Policy_Img (R)), Integer_Type_Node, Null_Location, Variable_Node); Set_Scalar_Value (Variable_Node, Int (R)); end loop; -- type ORB_tasking_policy. To easily retrieve the enumeration -- literal and their image. for R in ORB_Tasking_Policy_Img'Range loop Declare_Variable (To_Lower (ORB_Tasking_Policy_Img (R)), Integer_Type_Node, Null_Location, Variable_Node); Set_Scalar_Value (Variable_Node, Int (R)); end loop; -- type type__host_function (standard) -- function F (...: String) return String; Declare_Type (Type_Name => Type_Prefix & "host function", Type_Kind => Pre_Type_Function, Composite => True, Comp_Type => Null_Type, Array_Len => 0, Type_Sloc => Null_Location, Type_Node => Host_Function_Type_Node); Declare_Type_Component (Type_Node => Host_Function_Type_Node, Component_Name => Id ("partition_name"), Comp_Type_Node => String_Type_Node, Component_Sloc => Null_Location); Declare_Type_Component (Type_Node => Host_Function_Type_Node, Component_Name => Id ("return parameter"), Comp_Type_Node => String_Type_Node, Component_Sloc => Null_Location); -- type type__main_procedure (standard) -- procedure P Declare_Type (Type_Name => Type_Prefix & "main procedure", Type_Kind => Pre_Type_Procedure, Composite => False, Comp_Type => Null_Type, Array_Len => 0, Type_Sloc => Null_Location, Type_Node => Main_Procedure_Type_Node); -- type type__ada_unit (standard) Declare_Type (Type_Name => Type_Prefix & "ada unit", Type_Kind => Pre_Type_Ada_Unit, Composite => False, Comp_Type => Null_Type, Array_Len => 0, Type_Sloc => Null_Location, Type_Node => Ada_Unit_Type_Node); -- type Partition (standard) Declare_Type (Type_Name => Id ("partition"), Type_Kind => Pre_Type_Partition, Composite => True, Comp_Type => Ada_Unit_Type_Node, Array_Len => Infinite, Type_Sloc => Null_Location, Type_Node => Partition_Type_Node); -- type type__task_pool (standard) Declare_Type (Type_Name => Type_Prefix & "task pool", Type_Kind => Pre_Type_Task_Pool, Composite => True, Comp_Type => Null_Type, Array_Len => 0, Type_Sloc => Null_Location, Type_Node => Task_Pool_Type_Node); Declare_Type_Component (Type_Node => Task_Pool_Type_Node, Component_Name => Id ("low_mark"), Comp_Type_Node => Integer_Type_Node, Component_Sloc => Null_Location); Declare_Type_Component (Type_Node => Task_Pool_Type_Node, Component_Name => Id ("high_mark"), Comp_Type_Node => Integer_Type_Node, Component_Sloc => Null_Location); Declare_Type_Component (Type_Node => Task_Pool_Type_Node, Component_Name => Id ("max_mark"), Comp_Type_Node => Integer_Type_Node, Component_Sloc => Null_Location); -- type type__location (standard) Declare_Type (Type_Name => Type_Prefix & "location", Type_Kind => Pre_Type_Location, Composite => True, Comp_Type => Null_Type, Array_Len => 0, Type_Sloc => Null_Location, Type_Node => Location_Type_Node); Declare_Type_Component (Type_Node => Location_Type_Node, Component_Name => Id ("support_name"), Comp_Type_Node => String_Type_Node, Component_Sloc => Null_Location); Declare_Type_Component (Type_Node => Location_Type_Node, Component_Name => Id ("support_data"), Comp_Type_Node => String_Type_Node, Component_Sloc => Null_Location); -- type type__location_list (standard) Declare_Type (Type_Name => Type_Prefix & "location list", Type_Kind => Pre_Type_Locations, Composite => True, Comp_Type => Location_Type_Node, Array_Len => Infinite, Type_Sloc => Null_Location, Type_Node => Locations_Type_Node); -- type type__string_list (standard) Declare_Type (Type_Name => Type_Prefix & "string list", Type_Kind => Pre_Type_Strings, Composite => True, Comp_Type => String_Type_Node, Array_Len => Infinite, Type_Sloc => Null_Location, Type_Node => String_List_Type_Node); -- Define attributes for partition Declare_Type_Attribute (Type_Node => Partition_Type_Node, Attribute_Name => Id ("main"), Attr_Type_Node => Main_Procedure_Type_Node, Attribute_Kind => Attribute_Main, Attribute_Sloc => Null_Location); Declare_Type_Attribute (Type_Node => Partition_Type_Node, Attribute_Name => Id ("host"), Attr_Type_Node => String_Type_Node, Attribute_Kind => Attribute_Host, Attribute_Sloc => Null_Location); Declare_Type_Attribute (Type_Node => Partition_Type_Node, Attribute_Name => Id ("storage_dir"), Attr_Type_Node => String_Type_Node, Attribute_Kind => Attribute_Directory, Attribute_Sloc => Null_Location); Declare_Type_Attribute (Type_Node => Partition_Type_Node, Attribute_Name => Id ("directory"), Attr_Type_Node => String_Type_Node, Attribute_Kind => Attribute_Directory, Attribute_Sloc => Null_Location); Declare_Type_Attribute (Type_Node => Partition_Type_Node, Attribute_Name => Id ("environment_variables"), Attr_Type_Node => String_List_Type_Node, Attribute_Kind => Attribute_Environment_Variables, Attribute_Sloc => Null_Location); Declare_Type_Attribute (Type_Node => Partition_Type_Node, Attribute_Name => Id ("reconnection"), Attr_Type_Node => Integer_Type_Node, Attribute_Kind => Attribute_Reconnection, Attribute_Sloc => Null_Location); Declare_Type_Attribute (Type_Node => Partition_Type_Node, Attribute_Name => Id ("command_line"), Attr_Type_Node => String_Type_Node, Attribute_Kind => Attribute_Command_Line, Attribute_Sloc => Null_Location); Declare_Type_Attribute (Type_Node => Partition_Type_Node, Attribute_Name => Id ("termination"), Attr_Type_Node => Integer_Type_Node, Attribute_Kind => Attribute_Termination, Attribute_Sloc => Null_Location); Declare_Type_Attribute (Type_Node => Partition_Type_Node, Attribute_Name => Id ("priority"), Attr_Type_Node => Integer_Type_Node, Attribute_Kind => Attribute_Priority, Attribute_Sloc => Null_Location); Declare_Type_Attribute (Type_Node => Partition_Type_Node, Attribute_Name => Id ("filter"), Attr_Type_Node => String_Type_Node, Attribute_Kind => Attribute_PFilter, Attribute_Sloc => Null_Location); Declare_Type_Attribute (Type_Node => Partition_Type_Node, Attribute_Name => Id ("task_pool"), Attr_Type_Node => Task_Pool_Type_Node, Attribute_Kind => Attribute_Task_Pool, Attribute_Sloc => Null_Location); Declare_Type_Attribute (Type_Node => Partition_Type_Node, Attribute_Name => Id ("self_location"), Attr_Type_Node => Locations_Type_Node, Attribute_Kind => Attribute_Protocol, Attribute_Sloc => Null_Location); Declare_Type_Attribute (Type_Node => Partition_Type_Node, Attribute_Name => Id ("self_location"), Attr_Type_Node => Location_Type_Node, Attribute_Kind => Attribute_Protocol, Attribute_Sloc => Null_Location); Declare_Type_Attribute (Type_Node => Partition_Type_Node, Attribute_Name => Id ("data_location"), Attr_Type_Node => Location_Type_Node, Attribute_Kind => Attribute_Storage, Attribute_Sloc => Null_Location); Declare_Type_Attribute (Type_Node => Partition_Type_Node, Attribute_Name => Id ("is boot partition"), Attr_Type_Node => Boolean_Type_Node, Attribute_Kind => Attribute_Leader, Attribute_Sloc => Null_Location); Declare_Type_Attribute (Type_Node => Partition_Type_Node, Attribute_Name => Id ("passive"), Attr_Type_Node => Boolean_Type_Node, Attribute_Kind => Attribute_Passive, Attribute_Sloc => Null_Location); Declare_Type_Attribute (Type_Node => Partition_Type_Node, Attribute_Name => Id ("allow_light_pcs"), Attr_Type_Node => Boolean_Type_Node, Attribute_Kind => Attribute_Allow_Light_PCS, Attribute_Sloc => Null_Location); Declare_Type_Attribute (Type_Node => Partition_Type_Node, Attribute_Name => Id ("orb_tasking_policy"), Attr_Type_Node => Integer_Type_Node, Attribute_Kind => Attribute_ORB_Tasking_Policy, Attribute_Sloc => Null_Location); -- type Channel (standard) Declare_Type (Type_Name => Id ("channel"), Type_Kind => Pre_Type_Channel, Composite => True, Comp_Type => Null_Type, Array_Len => 0, Type_Sloc => Null_Location, Type_Node => Channel_Type_Node); Declare_Type_Component (Type_Node => Channel_Type_Node, Component_Name => Id ("partition_1"), Comp_Type_Node => Partition_Type_Node, Component_Sloc => Null_Location); Declare_Type_Component (Type_Node => Channel_Type_Node, Component_Name => Id ("partition_2"), Comp_Type_Node => Partition_Type_Node, Component_Sloc => Null_Location); Declare_Type_Attribute (Type_Node => Channel_Type_Node, Attribute_Name => Id ("filter"), Attr_Type_Node => String_Type_Node, Attribute_Kind => Attribute_CFilter, Attribute_Sloc => Null_Location); -- type Convention_Type is (Ada, Shell, None); (standard) Declare_Type (Type_Name => Type_Prefix & "convention", Type_Kind => Pre_Type_Convention, Composite => False, Comp_Type => Null_Type, Array_Len => 0, Type_Sloc => Null_Location, Type_Node => Convention_Type_Node); Declare_Variable (Id ("ada"), Convention_Type_Node, Null_Location, Variable_Node); -- To easily retrieve the enumeration literal. Set_Scalar_Value (Variable_Node, Convert (Ada_Import)); Declare_Variable (Id ("shell"), Convention_Type_Node, Null_Location, Variable_Node); -- To easily retrieve the enumeration literal. Set_Scalar_Value (Variable_Node, Convert (Shell_Import)); Declare_Variable (Id ("none"), Convention_Type_Node, Null_Location, Variable_Node); -- To easily retrieve the enumeration literal. Set_Scalar_Value (Variable_Node, Convert (None_Import)); -- pragma starter ... or -- procedure pragma__starter -- (convention : type__convention); Declare_Subprogram (Pragma_Prefix & "starter", Pragma_Starter, True, Null_Location, Pragma_Starter_Node); Declare_Subprogram_Parameter (Id ("convention"), Convention_Type_Node, Pragma_Starter_Node, Null_Location); -- type Name_Server is (Embedded, Standalone, Multicast); Declare_Type (Type_Name => Type_Prefix & "name_server", Type_Kind => Pre_Type_Name_Server, Composite => False, Comp_Type => Null_Type, Array_Len => 0, Type_Sloc => Null_Location, Type_Node => Name_Server_Type_Node); for R in Name_Server_Img'Range loop Declare_Variable (To_Lower (Name_Server_Img (R)), Name_Server_Type_Node, Null_Location, Variable_Node); Set_Scalar_Value (Variable_Node, Convert (R)); end loop; -- pragma name_server ... or -- procedure pragma__name_server -- (ns : type__name_server); Declare_Subprogram (Pragma_Prefix & "name_server", Pragma_Name_Server, True, Null_Location, Pragma_Name_Server_Node); Declare_Subprogram_Parameter (Id ("name_server_kind"), Name_Server_Type_Node, Pragma_Name_Server_Node, Null_Location); -- pragma priority ... or -- procedure pragma__priority -- (propagate : type__priority_policy); Declare_Subprogram (Pragma_Prefix & "priority", Pragma_Priority, True, Null_Location, Pragma_Priority_Node); Declare_Subprogram_Parameter (Id ("policy"), Integer_Type_Node, Pragma_Priority_Node, Null_Location); -- pragma Import ... or -- procedure pragma__import -- (convention : type__convention; -- entity : type__procedure; -- external_name : type__string); Declare_Subprogram (Pragma_Prefix & "import", Pragma_Import, True, Null_Location, Pragma_Import_Node); Declare_Subprogram_Parameter (Id ("convention"), Convention_Type_Node, Pragma_Import_Node, Null_Location); Declare_Subprogram_Parameter (Id ("entity"), Ada_Unit_Type_Node, Pragma_Import_Node, Null_Location); Declare_Subprogram_Parameter (Id ("external_name"), String_Type_Node, Pragma_Import_Node, Null_Location); -- pragma boot_server ... or -- procedure pragma__boot_server -- (protocol_name : type__string; -- protocol_data : type__string); Declare_Subprogram (Pragma_Prefix & "boot_server", Pragma_Boot_Location, True, Null_Location, Pragma_Boot_Location_Node); Declare_Subprogram_Parameter (Id ("protocol_name"), String_Type_Node, Pragma_Boot_Location_Node, Null_Location); Declare_Subprogram_Parameter (Id ("protocol_data"), String_Type_Node, Pragma_Boot_Location_Node, Null_Location); -- pragma boot_server ... or -- procedure pragma__boot_server -- (location : type__location); Declare_Subprogram (Pragma_Prefix & "boot_server", Pragma_Boot_Location, True, Null_Location, Pragma_Boot_Location_Node); Declare_Subprogram_Parameter (Id ("location"), Location_Type_Node, Pragma_Boot_Location_Node, Null_Location); -- pragma boot_server ... or -- procedure pragma__boot_server -- (locations : type__location__list); Declare_Subprogram (Pragma_Prefix & "boot_server", Pragma_Boot_Location, True, Null_Location, Pragma_Boot_Location_Node); Declare_Subprogram_Parameter (Id ("locations"), Locations_Type_Node, Pragma_Boot_Location_Node, Null_Location); -- pragma boot_location ... or -- procedure pragma__boot_location -- (protocol_name : type__string; -- protocol_data : type__string); Declare_Subprogram (Pragma_Prefix & "boot_location", Pragma_Boot_Location, True, Null_Location, Pragma_Boot_Location_Node); Declare_Subprogram_Parameter (Id ("protocol_name"), String_Type_Node, Pragma_Boot_Location_Node, Null_Location); Declare_Subprogram_Parameter (Id ("protocol_data"), String_Type_Node, Pragma_Boot_Location_Node, Null_Location); -- pragma boot_location ... or -- procedure pragma__boot_server -- (location : type__location); Declare_Subprogram (Pragma_Prefix & "boot_location", Pragma_Boot_Location, True, Null_Location, Pragma_Boot_Location_Node); Declare_Subprogram_Parameter (Id ("location"), Location_Type_Node, Pragma_Boot_Location_Node, Null_Location); -- pragma boot_location ... or -- procedure pragma__boot_server -- (locations : type__location__list); Declare_Subprogram (Pragma_Prefix & "boot_location", Pragma_Boot_Location, True, Null_Location, Pragma_Boot_Location_Node); Declare_Subprogram_Parameter (Id ("locations"), Locations_Type_Node, Pragma_Boot_Location_Node, Null_Location); -- pragma version ... or -- procedure pragma__version -- (check : boolean__type); Declare_Subprogram (Pragma_Prefix & "version", Pragma_Version, True, Null_Location, Pragma_Version_Node); Declare_Subprogram_Parameter (Id ("check"), Boolean_Type_Node, Pragma_Version_Node, Null_Location); -- pragma registration_filter ... or -- procedure registration_filter -- (filter : type__string); Declare_Subprogram (Pragma_Prefix & "registration_filter", Pragma_Reg_Filter, True, Null_Location, Pragma_Reg_Filter_Node); Declare_Subprogram_Parameter (Id ("filter"), String_Type_Node, Pragma_Reg_Filter_Node, Null_Location); -- pragma remote_shell ... or -- procedure pragma__remote_shell -- (command : type__string; -- options : type__string); Declare_Subprogram (Pragma_Prefix & "remote_shell", Pragma_Remote_Shell, True, Null_Location, Pragma_Remote_Shell_Node); Declare_Subprogram_Parameter (Id ("command"), String_Type_Node, Pragma_Remote_Shell_Node, Null_Location); Declare_Subprogram_Parameter (Id ("options"), String_Type_Node, Pragma_Remote_Shell_Node, Null_Location); end Initialize; end XE_Stdcnf; polyorb-2.8~20110207.orig/compilers/gnatdist/xe_back.adb0000644000175000017500000011573011750740337022275 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- X E _ B A C K -- -- -- -- B o d y -- -- -- -- Copyright (C) 1995-2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with Ada.Command_Line; use Ada.Command_Line; with GNAT.HTable; with GNAT.Directory_Operations; use GNAT.Directory_Operations; with GNAT.OS_Lib; use GNAT.OS_Lib; with XE; use XE; with XE_Defs.Defaults; with XE_Flags; use XE_Flags; with XE_Front; use XE_Front; with XE_IO; use XE_IO; with XE_Names; use XE_Names; with XE_Utils; use XE_Utils; package body XE_Back is ------------------------- -- Backend Registering -- ------------------------- type String_Ptr is access all String; type Header_Num is range 1 .. 7; function Hash (S : String_Ptr) return Header_Num; function Eq (S1, S2 : String_Ptr) return Boolean; -- Test equality of designated strings package All_Backends is new GNAT.HTable.Simple_HTable (Header_Num => Header_Num, Element => Backend_Access, No_Element => null, Key => String_Ptr, Hash => Hash, Equal => Eq); ------------------ -- Casing Rules -- ------------------ type Casing_Rule is record Size : Natural; From : String_Access; Into : String_Access; end record; Rules : array (1 .. 64) of Casing_Rule; Rules_Last : Natural := 0; function Get_Absolute_Command return String; -- Get the absolute path of the command being executed ----------- -- "and" -- ----------- function "and" (N : Name_Id; S : String) return Name_Id is begin Get_Name_String (N); Add_Char_To_Name_Buffer ('.'); Add_Str_To_Name_Buffer (S); return Name_Find; end "and"; ----------- -- "and" -- ----------- function "and" (L, R : Name_Id) return Name_Id is begin return L and Get_Name_String (R); end "and"; ------------------------ -- Apply_Casing_Rules -- ------------------------ procedure Apply_Casing_Rules (S : in out String) is New_Word : Boolean := True; Length : Natural := S'Length; C : String := S; begin Capitalize (S); To_Lower (C); for I in S'Range loop if New_Word then New_Word := False; for J in 1 .. Rules_Last loop if Rules (J).Size <= Length and then C (I .. I + Rules (J).Size - 1) = Rules (J).From.all then S (I .. I + Rules (J).Size - 1) := Rules (J).Into.all; end if; end loop; end if; if S (I) = '_' then New_Word := True; end if; Length := Length - 1; end loop; end Apply_Casing_Rules; -------- -- Eq -- -------- function Eq (S1, S2 : String_Ptr) return Boolean is begin if S1 = null or else S2 = null then return S1 = S2; end if; return S1.all = S2.all; end Eq; ------------------ -- Find_Backend -- ------------------ function Find_Backend (PCS_Name : String) return Backend_Access is S : aliased String := PCS_Name; Backend : Backend_Access; begin Backend := All_Backends.Get (S'Unchecked_Access); if Backend = null then Write_Line ("'" & PCS_Name & "' is not a valid PCS."); raise Usage_Error; end if; return Backend; end Find_Backend; ---------------------------------- -- Generate_All_Stubs_And_Skels -- ---------------------------------- procedure Generate_All_Stubs_And_Skels is PID : Partition_Id; Unit : Unit_Id; Uname : Unit_Name_Type; begin for J in ALIs.First .. ALIs.Last loop Unit := ALIs.Table (J).Last_Unit; -- Create stub files. Create skel files as well when we have to build -- the partition on which this unit is mapped. if not Units.Table (Unit).Is_Generic and then (Units.Table (Unit).RCI or else Units.Table (Unit).Shared_Passive) then Uname := Name (Units.Table (Unit).Uname); PID := Get_Partition_Id (Uname); if PID /= No_Partition_Id and then Partitions.Table (PID).To_Build and then Partitions.Table (PID).Passive /= BTrue then if Debug_Mode then Message ("create caller and receiver stubs for", Uname); end if; Generate_Stub (J); Generate_Skel (J, PID); else if Debug_Mode then Message ("create caller stubs for", Uname); end if; Generate_Stub (J); end if; end if; if Display_Compilation_Progress then Write_Str ("completed "); Write_Int (Int (J)); Write_Str (" out of "); Write_Int (Int (ALIs.Last)); Write_Str (" ("); Write_Int (Int ((J * 100) / (ALIs.Last - ALIs.First + 1))); Write_Str ("%)..."); Write_Eol; end if; end loop; end Generate_All_Stubs_And_Skels; ---------------------------------------- -- Generate_Application_Project_Files -- ---------------------------------------- procedure Generate_Application_Project_Files is Prj_Fname : File_Name_Type; Prj_File : File_Descriptor; begin -- Create application-wide project, extending user project file if -- provided. Prj_Fname := Dir (Id (Root), Dist_App_Project_File); Create_File (Prj_File, Prj_Fname); Set_Output (Prj_File); -- Dependency on PCS Write_Str ("with """); Write_Name (PCS_Project); Write_Line (""";"); -- Dependency on user project, if any Write_Str ("project "); Write_Name (Dist_App_Project); if Project_File_Name /= null then Write_Str (" extends all """ & Project_File_Name.all & """"); end if; Write_Line (" is"); Write_Line (" for Object_Dir use ""obj"";"); -- If no user project file is provided, add any source directory -- specified on the command line as source directories, in addition to -- the main application directory. The generated main subprogram -- (monolithic_app.adb) and all RCI units must be sources of the -- project (so that they can be individually recompiled). Write_Str (" for Source_Dirs use (""."""); if Project_File_Name = null then Write_Line (","); Write_Line (" "".."""); for J in Source_Directories.First .. Source_Directories.Last loop declare Normalized_Dir : constant String := Normalize_Pathname (Source_Directories.Table (J).all); begin if Is_Directory (Normalized_Dir) then Write_Line (","); Write_Str (" """ & Normalized_Dir & """"); end if; end; end loop; end if; Write_Line (");"); -- If a user project file is provided, explicitly specify additional -- source file partition.adb (in addition to all other sources, which -- are sources of this project by virtue of "extends all"). if Project_File_Name /= null then Write_Str (" for Source_Files use ("""); Write_Name (Monolithic_Src_Base_Name); Write_Line (""");"); end if; Write_Str ("end "); Write_Name (Dist_App_Project); Write_Line (";"); Close (Prj_File); Set_Standard_Output; Free (Project_File_Name); -- Distributed app project file extends user provided project, and -- includes the PCS as well. Project_File_Name := new String'( Normalize_Pathname (Get_Name_String (Prj_Fname))); end Generate_Application_Project_Files; ------------------------------------- -- Generate_Partition_Project_File -- ------------------------------------- procedure Generate_Partition_Project_File (D : Directory_Name_Type; P : Partition_Id := No_Partition_Id) is Prj_Fname : File_Name_Type; Prj_File : File_Descriptor; begin Prj_Fname := Dir (D, Part_Prj_File_Name); Create_File (Prj_File, Prj_Fname); Set_Output (Prj_File); -- Note that the main subprogram for each partition is always called -- partition.adb; the executable name is set using gnatmake command line -- switch "-o". We do not set it through the project to ensure that -- any settings inherited from the user's Builder package (in particular -- global configuration pragmas) are preserved. Write_Str ("project Partition extends all """); Write_Str (Project_File_Name.all); Write_Line (""" is"); Write_Line (" for Object_Dir use ""."";"); if P /= No_Partition_Id then Write_Str (" for Exec_Dir use """); Name_Len := 0; if Present (Partitions.Table (P).Executable_Dir) then Get_Name_String (Partitions.Table (P).Executable_Dir); end if; declare Exec_Dir : constant String := Name_Buffer (1 .. Name_Len); begin if Exec_Dir'Length = 0 or else not Is_Absolute_Path (Exec_Dir) then -- Reach up to main dir from dsa/partitions// Write_Str ("../../../../"); end if; Write_Str (Exec_Dir); end; Write_Line (""";"); else Write_Line (" -- Pseudo-partition project for RCI calling stubs"); end if; Write_Line ("end Partition;"); Close (Prj_File); Set_Standard_Output; end Generate_Partition_Project_File; ------------------- -- Generate_Skel -- ------------------- procedure Generate_Skel (A : ALI_Id; P : Partition_Id) is Full_Unit_File : File_Name_Type; Full_ALI_File : File_Name_Type; Skel_Object : File_Name_Type; Skel_ALI : File_Name_Type; Arguments : Argument_List (1 .. 4); Part_Prj_Fname : File_Name_Type; Directory : Directory_Name_Type renames Partitions.Table (P).Partition_Dir; begin Full_Unit_File := Units.Table (ALIs.Table (A).First_Unit).Sfile; Full_ALI_File := Dir (Monolithic_Obj_Dir, ALIs.Table (A).Afile); if not Is_Regular_File (Full_ALI_File) then -- No ALI in monolithic application: this must be the PCS_Conf_Unit. -- In this case the Full_ALI_File is deemed to be older than any -- existing stubs file, and so the stubs will be considered to be -- always up-to-date if present. pragma Assert (PCS_Conf_Unit /= No_Name and then ALIs.Table (A).Uname = PCS_Conf_Unit); null; end if; -- Determination of skel ALI file name Skel_ALI := Dir (Directory, Strip_Directory (Full_ALI_File)); Skel_Object := To_Ofile (Skel_ALI); -- Do we need to generate the skel files if not Is_Regular_File (Skel_Object) then if Verbose_Mode then Write_Missing_File (Skel_Object); end if; elsif not Is_Regular_File (Skel_ALI) then if Verbose_Mode then Write_Missing_File (Skel_ALI); end if; elsif File_Time_Stamp (Full_ALI_File) > File_Time_Stamp (Skel_ALI) then if Verbose_Mode then Write_Stamp_Comparison (Full_ALI_File, Skel_ALI); end if; else if not Quiet_Mode then Message (" ", ALIs.Table (A).Uname, "receiver stubs is up to date"); end if; return; end if; -- Here if stubs need to be rebuilt if not Quiet_Mode then Message ("building", ALIs.Table (A).Uname, "receiver stubs from", Normalize_CWD (Full_Unit_File)); end if; Arguments (1) := Skel_Flag; if Project_File_Name = null then Arguments (2) := Object_Dir_Flag; Arguments (3) := new String'(Get_Name_String (Directory)); else Arguments (2) := Project_File_Flag; Part_Prj_Fname := Dir (Directory, Part_Prj_File_Name); Get_Name_String (Part_Prj_Fname); Arguments (3) := new String'(Name_Buffer (1 .. Name_Len)); end if; Arguments (4) := new String'(Partition_Dir_Flag (P)); Compile (Full_Unit_File, Arguments, Fatal => False); Free (Arguments (3)); Free (Arguments (4)); end Generate_Skel; ------------------------- -- Generate_Stamp_File -- ------------------------- procedure Generate_Stamp_File (P : Partition_Id) is File : File_Descriptor; Current : Partition_Type renames Partitions.Table (P); begin Create_File (File, Dir (Current.Partition_Dir, Build_Stamp_File)); Set_Output (File); Write_Line (String (File_Time_Stamp (Configuration_File_Name))); Write_Line (String (File_Time_Stamp (Current.Executable_File))); Write_Line (String (File_Time_Stamp (Current.Most_Recent))); Close (File); Set_Standard_Output; end Generate_Stamp_File; --------------------------- -- Generate_Starter_File -- --------------------------- procedure Generate_Starter_File (Backend : Backend_Access) is procedure Generate_Boot_Server_Evaluation (P : Partition_Id); procedure Generate_Host_Name_Evaluation (P : Partition_Id); procedure Generate_Executable_Invocation (P : Partition_Id); ------------------------------------- -- Generate_Boot_Server_Evaluation -- ------------------------------------- procedure Generate_Boot_Server_Evaluation (P : Partition_Id) is L : Location_Id := Partitions.Table (P).First_Network_Loc; begin if L = No_Location_Id then L := Default_First_Boot_Location; end if; if L = No_Location_Id then Write_Str ("BOOT_LOCATION=tcp://`hostname`:"); Write_Str ("`echo 000$$ | sed 's,^.*\(...\),5\1,'`"); Write_Eol; else Write_Str ("BOOT_LOCATION='"); loop Write_Name (Locations.Table (L).Major); Write_Str ("://"); Write_Name (Locations.Table (L).Minor); L := Locations.Table (L).Next_Location; exit when L = No_Location_Id; Write_Char (' '); end loop; Write_Str ("'"); Write_Eol; end if; end Generate_Boot_Server_Evaluation; ------------------------------------ -- Generate_Executable_Invocation -- ------------------------------------ procedure Generate_Executable_Invocation (P : Partition_Id) is Ext_Quote : constant Character := '"'; -- " Int_Quote : Character := '''; -- ' Current : Partition_Type renames Partitions.Table (P); begin -- For the main partition, the command should be -- "" --boot_location "" -- For other partitions, it should be -- " '' --detach ... -- ... --boot_location '' &" ... -- ... < /dev/null > /dev/null 2>&1 if P = Main_Partition then Int_Quote := '"'; -- " end if; if P /= Main_Partition then Write_Name (Get_Rsh_Command); Write_Str (" ${"); Write_Name (Current.Name); Write_Str ("_HOST} "); Write_Name (Get_Rsh_Options); Write_Char (' '); Write_Char (Ext_Quote); Write_Str (Get_Env_Vars (P, Q => Int_Quote, Names_Only => False)); end if; -- Executable file name must be quoted because it may contain -- spaces, or (on Windows) backslashes that must not be interpreted -- by the shell. Write_Char (Int_Quote); Write_Name (To_Absolute_File (Current.Executable_File)); Write_Char (Int_Quote); -- Boot_Location not currently supported with PolyORB, instead pass -- name service reference directly. -- Write_Str (" --boot_location "); -- Write_Char (Int_Quote); -- Write_Str ("${BOOT_LOCATION}"); -- Write_Char (Int_Quote); Write_Str (" --polyorb-dsa-name_service="); Write_Char (Int_Quote); Write_Str ("${POLYORB_DSA_NAME_SERVICE}"); Write_Char (Int_Quote); Write_Name (Current.Command_Line); if P /= Main_Partition then Write_Str (" "); Write_Name (Get_Detach_Flag (Backend)); Write_Str (" &"); Write_Char (Ext_Quote); Write_Str (" < /dev/null > /dev/null 2>&1"); end if; Write_Eol; end Generate_Executable_Invocation; ----------------------------------- -- Generate_Host_Name_Evaluation -- ----------------------------------- procedure Generate_Host_Name_Evaluation (P : Partition_Id) is H : Name_Id; begin Write_Image (H, Partitions.Table (P).Host, P); if No (H) then Write_Str ("echo '"); Write_Name (Partitions.Table (P).Name); Write_Str (" host: '"); Write_Eol; Write_Str ("read "); Write_Name (Partitions.Table (P).Name); Write_Str ("_HOST"); Write_Eol; else Write_Name (Partitions.Table (P).Name); Write_Str ("_HOST="); Write_Name (H); Write_Eol; end if; end Generate_Host_Name_Evaluation; File : File_Descriptor; Exec_File : File_Name_Type; Success : Boolean; -- Start of processing for Generate_Starter_File begin -- Do not build start unless also building all partitions if not Partitions.Table (Default_Partition_Id).To_Build then return; end if; if Default_Starter /= None_Import and then not Quiet_Mode then Message ("generating starter", Main_Subprogram); end if; case Default_Starter is when Shell_Import => Delete_File (Main_Subprogram); Create_File (File, Main_Subprogram, True); Set_Output (File); Write_Line ("#! /bin/sh"); for J in Partitions.First + 1 .. Partitions.Last loop if J /= Main_Partition then Generate_Host_Name_Evaluation (J); end if; end loop; Generate_Boot_Server_Evaluation (Main_Partition); for J in Partitions.First + 1 .. Partitions.Last loop if J /= Main_Partition then Generate_Executable_Invocation (J); end if; end loop; Generate_Executable_Invocation (Main_Partition); Close (File); Set_Standard_Output; when Ada_Import => Exec_File := Partitions.Table (Main_Partition).Executable_File; Copy_File (Get_Name_String (Exec_File), Get_Name_String (Main_Subprogram & Exe_Suffix_Id), Success, Overwrite, Full); when None_Import => null; end case; end Generate_Starter_File; ------------------- -- Generate_Stub -- ------------------- procedure Generate_Stub (A : ALI_Id) is Full_Unit_File : File_Name_Type; Full_ALI_File : File_Name_Type; Full_ALI_Base : File_Name_Type; Stub_Object : File_Name_Type; Stub_ALI_Base : File_Name_Type; Stub_ALI : File_Name_Type; Unit : Unit_Id := ALIs.Table (A).Last_Unit; Arguments : Argument_List (1 .. 3); Part_Prj_Fname : File_Name_Type := No_File_Name; begin if Units.Table (Unit).Shared_Passive then Unit := ALIs.Table (A).First_Unit; end if; Full_Unit_File := Units.Table (Unit).Sfile; Full_ALI_File := Dir (Monolithic_Obj_Dir, ALIs.Table (A).Afile); Full_ALI_Base := ALIs.Table (A).Afile; if not Is_Regular_File (Full_ALI_File) then -- No ALI in monolithic application: this must be the PCS_Conf_Unit. -- In this case the Full_ALI_File is deemed to be older than any -- existing stubs file, and so the stubs will be considered to be -- always up-to-date if present. pragma Assert (PCS_Conf_Unit /= No_Name and then ALIs.Table (A).Uname = PCS_Conf_Unit); null; end if; -- Determination of stub ALI file name -- Note that the base name the compiler will use for the stubs ALI -- and object files (which cannot be overridden) may be different from -- thos of the full application (because under some non-standard -- naming convention, the base name of the spec might be different -- from the base name of the body, which is also the base name of the -- monolithic ALI). In that case, the output files are renamed after -- compilation. Stub_ALI_Base := To_Afile (Strip_Directory (Full_Unit_File)); Stub_ALI := Dir (Stub_Dir_Name, Stub_ALI_Base); Stub_Object := To_Ofile (Stub_ALI); -- Do we need to regenerate the caller stub and its ali? if not Is_Regular_File (Stub_Object) then if Verbose_Mode then Write_Missing_File (Stub_Object); end if; elsif not Is_Regular_File (Stub_ALI) then if Verbose_Mode then Write_Missing_File (Stub_ALI); end if; elsif File_Time_Stamp (Full_ALI_File) > File_Time_Stamp (Stub_ALI) then if Verbose_Mode then Write_Stamp_Comparison (Full_ALI_File, Stub_ALI); end if; else if not Quiet_Mode then Message (" ", ALIs.Table (A).Uname, "caller stubs is up to date"); end if; return; end if; -- Here if stubs need to be rebuilt if not Quiet_Mode then Message ("building", ALIs.Table (A).Uname, "caller stubs from", Normalize_CWD (Full_Unit_File)); end if; Arguments (1) := Stub_Flag; if Project_File_Name = null then Arguments (2) := Object_Dir_Flag; Arguments (3) := Stub_Dir; else Arguments (2) := Project_File_Flag; Part_Prj_Fname := Dir (Stub_Dir, Part_Prj_File_Name); Get_Name_String (Part_Prj_Fname); Arguments (3) := new String'(Name_Buffer (1 .. Name_Len)); end if; Compile (Full_Unit_File, Arguments, Fatal => False); -- Now rename output files if required (see comments above) if Full_ALI_Base /= Stub_ALI_Base then declare Final_ALI : constant File_Name_Type := Dir (Stub_Dir_Name, Full_ALI_Base); Final_Object : constant File_Name_Type := To_Ofile (Final_ALI); procedure Do_Rename (Src, Target : File_Name_Type); -- Call Rename_File (Src, Target), also outputting a message -- if in debug mode. procedure Do_Rename (Src, Target : File_Name_Type) is begin if Debug_Mode then Message ("renaming", Src, "to", Target); end if; Delete_File (Target); Rename_File (Src, Target); end Do_Rename; begin Do_Rename (Stub_ALI, Final_ALI); Do_Rename (Stub_Object, Final_Object); end; end if; if Present (Part_Prj_Fname) then Free (Arguments (3)); end if; end Generate_Stub; -------------------------- -- Get_Absolute_Command -- -------------------------- function Get_Absolute_Command return String is Cmd : constant String := Command_Name; begin for J in Cmd'Range loop if Cmd (J) = Dir_Separator then return Normalize_Pathname (Cmd); end if; end loop; -- Case of command name containing no directory separator declare Abs_Command_Access : String_Access := Locate_Exec_On_Path (Cmd); Abs_Command : constant String := Abs_Command_Access.all; begin Free (Abs_Command_Access); return Abs_Command; end; end Get_Absolute_Command; ------------------ -- Get_Env_Vars -- ------------------ function Get_Env_Vars (P : Partition_Id; Q : Character := ' '; Names_Only : Boolean) return String is V : Env_Var_Id; begin -- Export environment vars for remote partitions Name_Len := 0; V := Partitions.Table (P).First_Env_Var; while V /= No_Env_Var_Id loop if V = Partitions.Table (P).First_Env_Var then Add_Str_To_Name_Buffer ("env "); end if; Get_Name_String_And_Append (Env_Vars.Table (V).Name); if not Names_Only then Add_Char_To_Name_Buffer ('='); Add_Char_To_Name_Buffer (Q); Add_Str_To_Name_Buffer ("${"); Get_Name_String_And_Append (Env_Vars.Table (V).Name); Add_Char_To_Name_Buffer ('}'); Add_Char_To_Name_Buffer (Q); end if; Add_Str_To_Name_Buffer (" "); V := Env_Vars.Table (V).Next_Env_Var; end loop; return Name_Buffer (1 .. Name_Len); end Get_Env_Vars; ---------- -- Hash -- ---------- function Hash (S : String_Ptr) return Header_Num is function Hash is new GNAT.HTable.Hash (Header_Num); begin if S = null then return Header_Num'First; end if; return Hash (S.all); end Hash; ---------------- -- Initialize -- ---------------- procedure Initialize is begin Build_Stamp_File := Id ("glade.sta"); Partition_Main_File := Id ("partition"); Partition_Main_Name := Id ("Partition"); end Initialize; ------------------------- -- Location_List_Image -- ------------------------- function Location_List_Image (Location : Location_Id) return Name_Id is L : Location_Id := Location; begin Name_Len := 0; loop Get_Name_String_And_Append (Locations.Table (L).Major); if Present (Locations.Table (L).Minor) then Add_Str_To_Name_Buffer ("://"); Get_Name_String_And_Append (Locations.Table (L).Minor); end if; L := Locations.Table (L).Next_Location; exit when L = No_Location_Id; Add_Char_To_Name_Buffer (' '); end loop; return Quote (Name_Find); end Location_List_Image; ------------------------ -- Partition_Dir_Flag -- ------------------------ function Partition_Dir_Flag (P : Partition_Id) return String is begin Set_Str_To_Name_Buffer ("-XPARTITION_DIR="); Get_Name_String_And_Append (Partitions.Table (P).Partition_Dir); return Name_Buffer (1 .. Name_Len); end Partition_Dir_Flag; -- Local declarations for Prefix Exec_Abs_Name : constant String := Get_Absolute_Command; Exec_Abs_Dir : constant String := Dir_Name (Exec_Abs_Name); -- Strip trailing separator and remove last component ("bin") Exec_Prefix : constant String := Dir_Name (Exec_Abs_Dir (Exec_Abs_Dir'First .. Exec_Abs_Dir'Last - 1)); ------------ -- Prefix -- ------------ function Prefix (Check_For : String) return String is begin if Is_Readable_File (Exec_Prefix & Check_For) then return Exec_Prefix; else return XE_Defs.Defaults.Default_Prefix & Dir_Separator; end if; end Prefix; ------------------------- -- Prepare_Directories -- ------------------------- procedure Prepare_Directories is Afile : File_Name_Type; Unit : Unit_Id; Uname : Unit_Name_Type; Current : Partition_Type; begin if Project_File_Name /= null then Generate_Partition_Project_File (Stub_Dir_Name); end if; for J in Partitions.First + 1 .. Partitions.Last loop Current := Partitions.Table (J); if Current.To_Build and then Current.Passive /= BTrue then -- Create directories in which resp skels, main partition -- unit, elaboration unit and executables are stored Create_Dir (Current.Partition_Dir); if Present (Current.Executable_Dir) then Get_Name_String (Current.Executable_Dir); Set_Str_To_Name_Buffer (Normalize_Pathname (Name_Buffer (1 .. Name_Len))); Current.Executable_Dir := Name_Find; Create_Dir (Current.Executable_Dir); end if; if Project_File_Name /= null then Generate_Partition_Project_File (Current.Partition_Dir, J); end if; for K in ALIs.First .. ALIs.Last loop Afile := ALIs.Table (K).Afile; Unit := ALIs.Table (K).Last_Unit; Uname := Units.Table (Unit).Uname; -- Remove possible copies of unit object if (not Units.Table (Unit).RCI and then not Units.Table (Unit).Shared_Passive) or else Get_Partition_Id (Uname) /= J then Afile := Strip_Directory (Afile); Afile := Dir (Current.Partition_Dir, Afile); Delete_File (Afile); Delete_File (To_Ofile (Afile)); end if; end loop; end if; end loop; end Prepare_Directories; ----------------------- -- Rebuild_Partition -- ----------------------- function Rebuild_Partition (P : Partition_Id) return Boolean is Current : Partition_Type renames Partitions.Table (P); Executable : File_Name_Type renames Current.Executable_File; Most_Recent : File_Name_Type renames Current.Most_Recent; Stamp_File : File_Name_Type; First : Text_Ptr; Last : Text_Ptr; Buffer : Text_Buffer_Ptr; function Read_Time_Stamp return Time_Stamp_Type; --------------------- -- Read_Time_Stamp -- --------------------- function Read_Time_Stamp return Time_Stamp_Type is S : Time_Stamp_Type; begin for I in S'Range loop if Buffer (First) not in '0' .. '9' then return Dummy_Time_Stamp; end if; S (I) := Buffer (First); First := First + 1; end loop; while Buffer (First) = ASCII.LF or else Buffer (First) = ASCII.CR loop First := First + 1; end loop; return S; end Read_Time_Stamp; Old_Stamp : Time_Stamp_Type; New_Stamp : Time_Stamp_Type; begin -- Check that executable exists and is up to date if not Is_Regular_File (Executable) then return True; end if; if File_Time_Stamp (Most_Recent) > File_Time_Stamp (Executable) then return True; end if; -- Check that stamp file exists Stamp_File := Dir (Partitions.Table (P).Partition_Dir, Build_Stamp_File); if not Is_Regular_File (Stamp_File) then return True; end if; -- Check stamps from stamp file corresponds to the current ones. Read_File (Stamp_File, First, Last, Buffer); -- Check Configuration File Stamp Old_Stamp := Read_Time_Stamp; New_Stamp := File_Time_Stamp (Configuration_File_Name); if Old_Stamp /= New_Stamp then return True; end if; -- Check Executable File Stamp Old_Stamp := Read_Time_Stamp; New_Stamp := File_Time_Stamp (Executable); if Old_Stamp /= New_Stamp then return True; end if; -- Check Most Recent Object File Stamp Old_Stamp := Read_Time_Stamp; New_Stamp := File_Time_Stamp (Most_Recent); if Old_Stamp /= New_Stamp then return True; end if; return False; end Rebuild_Partition; ---------------------- -- Register_Backend -- ---------------------- procedure Register_Backend (PCS_Name : String; The_Backend : Backend_Access) is begin All_Backends.Set (new String'(PCS_Name), The_Backend); end Register_Backend; -------------------------- -- Register_Casing_Rule -- -------------------------- procedure Register_Casing_Rule (S : String) is begin Rules_Last := Rules_Last + 1; Rules (Rules_Last).Size := S'Length; Rules (Rules_Last).Into := new String'(S); Rules (Rules_Last).From := new String'(S); To_Lower (Rules (Rules_Last).From.all); end Register_Casing_Rule; ---------------- -- Write_Call -- ---------------- procedure Write_Call (SP : Unit_Name_Type; N1 : Name_Id := No_Name; S1 : String := No_Str; N2 : Name_Id := No_Name; S2 : String := No_Str; N3 : Name_Id := No_Name; S3 : String := No_Str; I1_Present : Boolean := False; I1 : Int := -1) is Max_String_Length : constant := 64; N_Params : Integer := 0; procedure Write_Parameter (P : String); procedure Write_Separator; --------------------- -- Write_Parameter -- --------------------- procedure Write_Parameter (P : String) is F : Natural := P'First; L : Natural := P'Last; begin if P (F) /= '"' then -- " Write_Str (P); return; end if; F := F + 1; for J in 1 .. (P'Length - 2) / Max_String_Length loop L := F + Max_String_Length - 1; Write_Char ('"'); -- " Write_Str (P (F .. L)); Write_Line (""" &"); Write_Indentation; F := L + 1; end loop; Write_Char ('"'); -- " Write_Str (P (F .. P'Last)); end Write_Parameter; --------------------- -- Write_Separator -- --------------------- procedure Write_Separator is begin N_Params := N_Params + 1; if N_Params = 1 then Write_Eol; Increment_Indentation; Write_Indentation (-1); Write_Str ("("); else Write_Str (","); Write_Eol; Write_Indentation; end if; end Write_Separator; begin Write_Indentation; Write_Name (SP); if Present (N1) then Write_Separator; Write_Parameter (Get_Name_String (N1)); end if; if S1 /= No_Str then Write_Separator; Write_Parameter (S1); end if; if Present (N2) then Write_Separator; Write_Parameter (Get_Name_String (N2)); end if; if S2 /= No_Str then Write_Separator; Write_Parameter (S2); end if; if Present (N3) then Write_Separator; Write_Parameter (Get_Name_String (N3)); end if; if S3 /= No_Str then Write_Separator; Write_Parameter (S3); end if; if I1_Present then Write_Separator; Write_Int (I1); end if; if N_Params /= 0 then Write_Str (")"); Decrement_Indentation; end if; Write_Str (";"); Write_Eol; end Write_Call; ----------------- -- Write_Image -- ----------------- procedure Write_Image (I : out Name_Id; H : Host_Id; P : Partition_Id) is begin if H /= No_Host_Id then if not Hosts.Table (H).Static then if Hosts.Table (H).Import = Shell_Import then Name_Len := 0; Add_Str_To_Name_Buffer ("""`"); Get_Name_String_And_Append (Hosts.Table (H).External); Add_Char_To_Name_Buffer (' '); Get_Name_String_And_Append (Partitions.Table (P).Name); Add_Str_To_Name_Buffer ("`"""); I := Name_Find; elsif Hosts.Table (H).Import = Ada_Import then Get_Name_String (Hosts.Table (H).External); Add_Char_To_Name_Buffer ('('); Get_Name_String_And_Append (Partitions.Table (P).Name); Add_Char_To_Name_Buffer (')'); I := Name_Find; else raise Parsing_Error; end if; else Name_Len := 0; Add_Char_To_Name_Buffer ('"'); -- " Get_Name_String_And_Append (Hosts.Table (H).Name); Add_Char_To_Name_Buffer ('"'); -- " I := Name_Find; end if; else I := No_Name; end if; end Write_Image; ------------------------ -- Write_With_Clause -- ------------------------ procedure Write_With_Clause (W : Name_Id; U : Boolean := False; E : Boolean := False) is begin Name_Len := 0; Add_Str_To_Name_Buffer ("with "); Get_Name_String_And_Append (W); Add_Char_To_Name_Buffer (';'); Write_Str (Name_Buffer (1 .. Name_Len)); Write_Eol; if U then Name_Buffer (1 .. 4) := "use "; Write_Str (Name_Buffer (1 .. Name_Len)); Write_Eol; end if; if E then Write_Call (Id ("pragma Elaborate_All"), W); end if; end Write_With_Clause; end XE_Back; polyorb-2.8~20110207.orig/compilers/gnatdist/xe_names.adb0000644000175000017500000004457611750740337022511 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- X E _ N A M E S -- -- -- -- B o d y -- -- -- -- Copyright (C) 1995-2009, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with XE_IO; use XE_IO; package body XE_Names is Hash_Num : constant Int := 2**12; -- Number of headers in the hash table. Current hash algorithm is closely -- tailored to this choice, so it can only be changed if a corresponding -- change is made to the hash alogorithm. Hash_Max : constant Int := Hash_Num - 1; -- Indexes in the hash header table run from 0 to Hash_Num - 1 subtype Hash_Index_Type is Int range 0 .. Hash_Max; -- Range of hash index values Hash_Table : array (Hash_Index_Type) of Name_Id; -- The hash table is used to locate existing entries in the names table. -- The entries point to the first names table entry whose hash value -- matches the hash code. Then subsequent names table entries with the -- same hash code value are linked through the Hash_Link fields. ----------------------- -- Local Subprograms -- ----------------------- function Hash return Hash_Index_Type; pragma Inline (Hash); -- Compute hash code for name stored in Name_Buffer (length in Name_Len) ----------------------------- -- Add_Char_To_Name_Buffer -- ----------------------------- procedure Add_Char_To_Name_Buffer (C : Character) is begin if Name_Len < Name_Buffer'Last then Name_Len := Name_Len + 1; Name_Buffer (Name_Len) := C; end if; end Add_Char_To_Name_Buffer; ---------------------------- -- Add_Nat_To_Name_Buffer -- ---------------------------- procedure Add_Nat_To_Name_Buffer (V : Nat) is begin if V >= 10 then Add_Nat_To_Name_Buffer (V / 10); end if; Add_Char_To_Name_Buffer (Character'Val (Character'Pos ('0') + V rem 10)); end Add_Nat_To_Name_Buffer; ---------------------------- -- Add_Str_To_Name_Buffer -- ---------------------------- procedure Add_Str_To_Name_Buffer (S : String) is begin for J in S'Range loop Add_Char_To_Name_Buffer (S (J)); end loop; end Add_Str_To_Name_Buffer; --------------------- -- Get_Name_String -- --------------------- procedure Get_Name_String (Id : Name_Id) is S : Int; begin pragma Assert (Id in Name_Entries.First .. Name_Entries.Last); S := Name_Entries.Table (Id).Name_Chars_Index; Name_Len := Natural (Name_Entries.Table (Id).Name_Len); for J in 1 .. Name_Len loop Name_Buffer (J) := Name_Chars.Table (S + Int (J)); end loop; end Get_Name_String; function Get_Name_String (Id : Name_Id) return String is S : Int; begin pragma Assert (Id in Name_Entries.First .. Name_Entries.Last); S := Name_Entries.Table (Id).Name_Chars_Index; declare R : String (1 .. Natural (Name_Entries.Table (Id).Name_Len)); begin for J in R'Range loop R (J) := Name_Chars.Table (S + Int (J)); end loop; return R; end; end Get_Name_String; -------------------------------- -- Get_Name_String_And_Append -- -------------------------------- procedure Get_Name_String_And_Append (Id : Name_Id) is S : Int; begin pragma Assert (Id in Name_Entries.First .. Name_Entries.Last); S := Name_Entries.Table (Id).Name_Chars_Index; for J in 1 .. Natural (Name_Entries.Table (Id).Name_Len) loop Name_Len := Name_Len + 1; Name_Buffer (Name_Len) := Name_Chars.Table (S + Int (J)); end loop; end Get_Name_String_And_Append; ------------------------- -- Get_Name_Table_Byte -- ------------------------- function Get_Name_Table_Byte (Id : Name_Id) return Byte is begin pragma Assert (Id in Name_Entries.First .. Name_Entries.Last); return Name_Entries.Table (Id).Byte_Info; end Get_Name_Table_Byte; ------------------------- -- Get_Name_Table_Info -- ------------------------- function Get_Name_Table_Info (Id : Name_Id) return Int is begin pragma Assert (Id in Name_Entries.First .. Name_Entries.Last); return Name_Entries.Table (Id).Int_Info; end Get_Name_Table_Info; ---------- -- Hash -- ---------- function Hash return Hash_Index_Type is begin -- For the cases of 1-12 characters, all characters participate in the -- hash. The positioning is randomized, with the bias that characters -- later on participate fully (i.e. are added towards the right side). case Name_Len is when 0 => return 0; when 1 => return Character'Pos (Name_Buffer (1)); when 2 => return (( Character'Pos (Name_Buffer (1))) * 64 + Character'Pos (Name_Buffer (2))) mod Hash_Num; when 3 => return ((( Character'Pos (Name_Buffer (1))) * 16 + Character'Pos (Name_Buffer (3))) * 16 + Character'Pos (Name_Buffer (2))) mod Hash_Num; when 4 => return (((( Character'Pos (Name_Buffer (1))) * 8 + Character'Pos (Name_Buffer (2))) * 8 + Character'Pos (Name_Buffer (3))) * 8 + Character'Pos (Name_Buffer (4))) mod Hash_Num; when 5 => return ((((( Character'Pos (Name_Buffer (4))) * 8 + Character'Pos (Name_Buffer (1))) * 4 + Character'Pos (Name_Buffer (3))) * 4 + Character'Pos (Name_Buffer (5))) * 8 + Character'Pos (Name_Buffer (2))) mod Hash_Num; when 6 => return (((((( Character'Pos (Name_Buffer (5))) * 4 + Character'Pos (Name_Buffer (1))) * 4 + Character'Pos (Name_Buffer (4))) * 4 + Character'Pos (Name_Buffer (2))) * 4 + Character'Pos (Name_Buffer (6))) * 4 + Character'Pos (Name_Buffer (3))) mod Hash_Num; when 7 => return ((((((( Character'Pos (Name_Buffer (4))) * 4 + Character'Pos (Name_Buffer (3))) * 4 + Character'Pos (Name_Buffer (1))) * 4 + Character'Pos (Name_Buffer (2))) * 2 + Character'Pos (Name_Buffer (5))) * 2 + Character'Pos (Name_Buffer (7))) * 2 + Character'Pos (Name_Buffer (6))) mod Hash_Num; when 8 => return (((((((( Character'Pos (Name_Buffer (2))) * 4 + Character'Pos (Name_Buffer (1))) * 4 + Character'Pos (Name_Buffer (3))) * 2 + Character'Pos (Name_Buffer (5))) * 2 + Character'Pos (Name_Buffer (7))) * 2 + Character'Pos (Name_Buffer (6))) * 2 + Character'Pos (Name_Buffer (4))) * 2 + Character'Pos (Name_Buffer (8))) mod Hash_Num; when 9 => return ((((((((( Character'Pos (Name_Buffer (2))) * 4 + Character'Pos (Name_Buffer (1))) * 4 + Character'Pos (Name_Buffer (3))) * 4 + Character'Pos (Name_Buffer (4))) * 2 + Character'Pos (Name_Buffer (8))) * 2 + Character'Pos (Name_Buffer (7))) * 2 + Character'Pos (Name_Buffer (5))) * 2 + Character'Pos (Name_Buffer (6))) * 2 + Character'Pos (Name_Buffer (9))) mod Hash_Num; when 10 => return (((((((((( Character'Pos (Name_Buffer (01))) * 2 + Character'Pos (Name_Buffer (02))) * 2 + Character'Pos (Name_Buffer (08))) * 2 + Character'Pos (Name_Buffer (03))) * 2 + Character'Pos (Name_Buffer (04))) * 2 + Character'Pos (Name_Buffer (09))) * 2 + Character'Pos (Name_Buffer (06))) * 2 + Character'Pos (Name_Buffer (05))) * 2 + Character'Pos (Name_Buffer (07))) * 2 + Character'Pos (Name_Buffer (10))) mod Hash_Num; when 11 => return ((((((((((( Character'Pos (Name_Buffer (05))) * 2 + Character'Pos (Name_Buffer (01))) * 2 + Character'Pos (Name_Buffer (06))) * 2 + Character'Pos (Name_Buffer (09))) * 2 + Character'Pos (Name_Buffer (07))) * 2 + Character'Pos (Name_Buffer (03))) * 2 + Character'Pos (Name_Buffer (08))) * 2 + Character'Pos (Name_Buffer (02))) * 2 + Character'Pos (Name_Buffer (10))) * 2 + Character'Pos (Name_Buffer (04))) * 2 + Character'Pos (Name_Buffer (11))) mod Hash_Num; when 12 => return (((((((((((( Character'Pos (Name_Buffer (03))) * 2 + Character'Pos (Name_Buffer (02))) * 2 + Character'Pos (Name_Buffer (05))) * 2 + Character'Pos (Name_Buffer (01))) * 2 + Character'Pos (Name_Buffer (06))) * 2 + Character'Pos (Name_Buffer (04))) * 2 + Character'Pos (Name_Buffer (08))) * 2 + Character'Pos (Name_Buffer (11))) * 2 + Character'Pos (Name_Buffer (07))) * 2 + Character'Pos (Name_Buffer (09))) * 2 + Character'Pos (Name_Buffer (10))) * 2 + Character'Pos (Name_Buffer (12))) mod Hash_Num; -- Names longer than 12 characters are handled by taking the first -- 6 odd numbered characters and the last 6 even numbered characters. when others => declare Even_Name_Len : constant Integer := (Name_Len) / 2 * 2; begin return (((((((((((( Character'Pos (Name_Buffer (01))) * 2 + Character'Pos (Name_Buffer (Even_Name_Len - 10))) * 2 + Character'Pos (Name_Buffer (03))) * 2 + Character'Pos (Name_Buffer (Even_Name_Len - 08))) * 2 + Character'Pos (Name_Buffer (05))) * 2 + Character'Pos (Name_Buffer (Even_Name_Len - 06))) * 2 + Character'Pos (Name_Buffer (07))) * 2 + Character'Pos (Name_Buffer (Even_Name_Len - 04))) * 2 + Character'Pos (Name_Buffer (09))) * 2 + Character'Pos (Name_Buffer (Even_Name_Len - 02))) * 2 + Character'Pos (Name_Buffer (11))) * 2 + Character'Pos (Name_Buffer (Even_Name_Len))) mod Hash_Num; end; end case; end Hash; ---------------- -- Initialize -- ---------------- procedure Initialize is begin Name_Chars.Init; Name_Entries.Init; -- Initialize entries for one character names for C in Character loop Name_Entries.Increment_Last; Name_Entries.Table (Name_Entries.Last).Name_Chars_Index := Name_Chars.Last; Name_Entries.Table (Name_Entries.Last).Name_Len := 1; Name_Entries.Table (Name_Entries.Last).Hash_Link := No_Name; Name_Entries.Table (Name_Entries.Last).Int_Info := 0; Name_Entries.Table (Name_Entries.Last).Byte_Info := 0; Name_Chars.Increment_Last; Name_Chars.Table (Name_Chars.Last) := C; Name_Chars.Increment_Last; Name_Chars.Table (Name_Chars.Last) := ASCII.NUL; end loop; -- Clear hash table for J in Hash_Index_Type loop Hash_Table (J) := No_Name; end loop; end Initialize; ---------------- -- Name_Enter -- ---------------- function Name_Enter return Name_Id is begin Name_Entries.Increment_Last; Name_Entries.Table (Name_Entries.Last).Name_Chars_Index := Name_Chars.Last; Name_Entries.Table (Name_Entries.Last).Name_Len := Short (Name_Len); Name_Entries.Table (Name_Entries.Last).Hash_Link := No_Name; Name_Entries.Table (Name_Entries.Last).Int_Info := 0; Name_Entries.Table (Name_Entries.Last).Byte_Info := 0; -- Set corresponding string entry in the Name_Chars table for J in 1 .. Name_Len loop Name_Chars.Increment_Last; Name_Chars.Table (Name_Chars.Last) := Name_Buffer (J); end loop; Name_Chars.Increment_Last; Name_Chars.Table (Name_Chars.Last) := ASCII.NUL; return Name_Entries.Last; end Name_Enter; --------------- -- Name_Find -- --------------- function Name_Find return Name_Id is New_Id : Name_Id; -- Id of entry in hash search, and value to be returned S : Int; -- Pointer into string table Hash_Index : Hash_Index_Type; -- Computed hash index begin -- Quick handling for one character names if Name_Len = 1 then return Name_Id (First_Name_Id + Character'Pos (Name_Buffer (1))); -- Otherwise search hash table for existing matching entry else Hash_Index := XE_Names.Hash; New_Id := Hash_Table (Hash_Index); if New_Id = No_Name then Hash_Table (Hash_Index) := Name_Entries.Last + 1; else Search : loop if Name_Len /= Integer (Name_Entries.Table (New_Id).Name_Len) then goto No_Match; end if; S := Name_Entries.Table (New_Id).Name_Chars_Index; for I in 1 .. Name_Len loop if Name_Chars.Table (S + Int (I)) /= Name_Buffer (I) then goto No_Match; end if; end loop; return New_Id; -- Current entry in hash chain does not match <> if Name_Entries.Table (New_Id).Hash_Link /= No_Name then New_Id := Name_Entries.Table (New_Id).Hash_Link; else Name_Entries.Table (New_Id).Hash_Link := Name_Entries.Last + 1; exit Search; end if; end loop Search; end if; -- We fall through here only if a matching entry was not found in the -- hash table. We now create a new entry in the names table. The hash -- link pointing to the new entry (Name_Entries.Last+1) has been set. Name_Entries.Increment_Last; Name_Entries.Table (Name_Entries.Last).Name_Chars_Index := Name_Chars.Last; Name_Entries.Table (Name_Entries.Last).Name_Len := Short (Name_Len); Name_Entries.Table (Name_Entries.Last).Hash_Link := No_Name; Name_Entries.Table (Name_Entries.Last).Int_Info := 0; Name_Entries.Table (Name_Entries.Last).Byte_Info := 0; -- Set corresponding string entry in the Name_Chars table for I in 1 .. Name_Len loop Name_Chars.Increment_Last; Name_Chars.Table (Name_Chars.Last) := Name_Buffer (I); end loop; Name_Chars.Increment_Last; Name_Chars.Table (Name_Chars.Last) := ASCII.NUL; return Name_Entries.Last; end if; end Name_Find; ----------------------------- -- Set_Char_To_Name_Buffer -- ----------------------------- procedure Set_Char_To_Name_Buffer (C : Character) is begin Name_Len := 0; Add_Char_To_Name_Buffer (C); end Set_Char_To_Name_Buffer; ------------------------- -- Set_Name_Table_Byte -- ------------------------- procedure Set_Name_Table_Byte (Id : Name_Id; Val : Byte) is begin pragma Assert (Id in Name_Entries.First .. Name_Entries.Last); Name_Entries.Table (Id).Byte_Info := Val; end Set_Name_Table_Byte; ------------------------- -- Set_Name_Table_Info -- ------------------------- procedure Set_Name_Table_Info (Id : Name_Id; Val : Int) is begin pragma Assert (Id in Name_Entries.First .. Name_Entries.Last); Name_Entries.Table (Id).Int_Info := Val; end Set_Name_Table_Info; ---------------------------- -- Set_Nat_To_Name_Buffer -- ---------------------------- procedure Set_Nat_To_Name_Buffer (V : Nat) is begin Name_Len := 0; Add_Nat_To_Name_Buffer (V); end Set_Nat_To_Name_Buffer; ---------------------------- -- Set_Str_To_Name_Buffer -- ---------------------------- procedure Set_Str_To_Name_Buffer (S : String) is begin Name_Len := 0; Add_Str_To_Name_Buffer (S); end Set_Str_To_Name_Buffer; -------- -- wn -- -------- procedure wn (Id : Name_Id) is begin Write_Str (Get_Name_String (Id)); Write_Eol; end wn; ---------------- -- Write_Name -- ---------------- procedure Write_Name (Id : Name_Id) is begin if Id >= First_Name_Id then Get_Name_String (Id); Write_Str (Name_Buffer (1 .. Name_Len)); end if; end Write_Name; end XE_Names; polyorb-2.8~20110207.orig/compilers/gnatdist/xe_stdcnf.ads0000644000175000017500000000445611750740337022701 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- X E _ S T D C N F -- -- -- -- S p e c -- -- -- -- Copyright (C) 1995-2008, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- This package contains predefined entities needed to described a -- configuration like types, pragmas, attributes. package XE_Stdcnf is procedure Initialize; -- This procedure contains the standard configuration which is loaded -- before the user configuration. end XE_Stdcnf; polyorb-2.8~20110207.orig/compilers/gnatdist/xe_scan.ads0000644000175000017500000000605311750740337022337 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- X E _ S C A N -- -- -- -- S p e c -- -- -- -- Copyright (C) 1995-2009, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- This package provides routines to scan the configuration file. with XE; use XE; with XE_Types; use XE_Types; package XE_Scan is Token_Name : XE_Types.Name_Id; Token : Token_Type; type Location_Type is record Line : XE_Types.Int; First : XE_Types.Text_Ptr; Last : XE_Types.Text_Ptr; end record; Null_Location : constant Location_Type := (0, 0, 0); function Get_Token_Location return Location_Type; procedure Initialize; -- Load all kind of keywords procedure Load_File (File : XE_Types.File_Name_Type); -- Load this file in a memory buffer procedure Location_To_XY (Where : Location_Type; Loc_X : out XE_Types.Int; Loc_Y : out XE_Types.Int); procedure Next_Token; -- Find next token and update internal variables procedure Set_Token_Location (Where : Location_Type); procedure Write_Location (Where : Location_Type); -- Display line and column where the error occured procedure Write_Token (T : Token_Type); end XE_Scan; polyorb-2.8~20110207.orig/compilers/gnatdist/xe_parse.ads0000644000175000017500000003231211750740337022522 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- X E _ P A R S E -- -- -- -- S p e c -- -- -- -- Copyright (C) 1995-2008, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- This package contains routines to parse the configuration file. with XE; use XE; with XE_Scan; use XE_Scan; with XE_Types; use XE_Types; package XE_Parse is type Convention_Type is (Named, Positional); Attribute_Prefix : Name_Id; Type_Prefix : Name_Id; Pragma_Prefix : Name_Id; procedure Check_Not_Declared (Declaration_Name : Name_Id; Declaration_Sloc : XE_Scan.Location_Type); -- Check that such a declaration has not already been done procedure Declare_Literal (Literal_Name : Name_Id; Literal_Type : Type_Id; Literal_Sloc : XE_Scan.Location_Type; Literal_Node : out Variable_Id); procedure Declare_Procedure_Call (Subprogram_Node : Subprogram_Id; Subprogram_Sloc : XE_Scan.Location_Type); -- Declare a call to a procedure. A statement node is created and -- contains an entire copy of the subprogram node. procedure Declare_Subprogram (Subprogram_Name : Name_Id; Pragma_Kind : Pragma_Type; Is_A_Procedure : Boolean; Subprogram_Sloc : XE_Scan.Location_Type; Subprogram_Node : out Subprogram_Id); -- Declare a subprogram into the configuration context. This subprogram -- is possibly a function. At this point, the subprogram has no -- parameter. procedure Declare_Subprogram_Parameter (Parameter_Name : Name_Id; Para_Type_Node : Type_Id; Subprogram_Node : Subprogram_Id; Parameter_Sloc : XE_Scan.Location_Type; Parameter_Node : out Parameter_Id); -- Declare a parameter for a subprogram. The last parameter corresponds -- to a returned value when the subprogram is a function. procedure Declare_Subprogram_Parameter (Parameter_Name : Name_Id; Para_Type_Node : Type_Id; Subprogram_Node : Subprogram_Id; Parameter_Sloc : XE_Scan.Location_Type); -- Same as above, but does not return the Parameter_Node. procedure Declare_Type (Type_Name : Name_Id; Type_Kind : Predefined_Type; Composite : Boolean; Array_Len : Int; Comp_Type : Type_Id; Type_Sloc : XE_Scan.Location_Type; Type_Node : out Type_Id); -- Declare a new type into the configuration context. If type is -- not a composite, then it is a scalar type or a string type. If -- Array_Len is zero, it is a record type. Comp_Type is the type -- of an array component type. procedure Declare_Type_Attribute (Type_Node : Type_Id; Attribute_Name : Name_Id; Attr_Type_Node : Type_Id; Attribute_Kind : Attribute_Type; Attribute_Sloc : XE_Scan.Location_Type; Attribute_Node : out Attribute_Id); -- Declare an attribute for a given type. This procedure creates a -- component of type Attr_Type_Node and includes it in the type -- component list. procedure Declare_Type_Attribute (Type_Node : Type_Id; Attribute_Name : Name_Id; Attr_Type_Node : Type_Id; Attribute_Kind : Attribute_Type; Attribute_Sloc : XE_Scan.Location_Type); -- Same as above, but does not return the Attribute_Node. procedure Declare_Type_Component (Type_Node : Type_Id; Component_Name : Name_Id; Comp_Type_Node : Type_Id; Component_Sloc : XE_Scan.Location_Type; Component_Node : out Component_Id); -- Declare a component for a given type. This procedure creates a -- component of type Comp_Type_Node and includes it in the type -- component list. procedure Declare_Type_Component (Type_Node : Type_Id; Component_Name : Name_Id; Comp_Type_Node : Type_Id; Component_Sloc : XE_Scan.Location_Type); -- Same as above, but does not return the Component_Node. procedure Declare_Variable (Variable_Name : Name_Id; Variable_Type : Type_Id; Variable_Sloc : XE_Scan.Location_Type; Variable_Node : out Variable_Id); -- Declare a new variable into the configuration context. This variable -- of name Variable_Name is of type Variable_Type. Allocate the -- component nodes if needed (not attributes). procedure Declare_Variable_Component (Variable_Node : Variable_Id; Component_Name : Name_Id; Component_Type : Type_Id; Attribute_Kind : Attribute_Type; Component_Sloc : XE_Scan.Location_Type; Component_Node : out Component_Id); -- Add a component for a given variable. This component is -- possibly an attribute. The component type is Component_Type. procedure Duplicate_Variable (Source, Target : Variable_Id); -- Duplicate all the content except attributes procedure Exit_On_Error; -- Print configuration if verbose_mode and then raise Parsing_Error procedure Initialize; -- Elaboration code procedure Match_Actual_With_Formal (Subprogram_Node : Subprogram_Id); -- Parse a subprogram call and associate actual parameters to formal -- parameters. procedure P_Aggregate_Assignment (Variable_Node : Variable_Id); -- Parse an aggregate assignement procedure P_Configuration_Body; procedure P_Configuration_Declaration; procedure P_Configuration_End; procedure P_Full_Ada_Identifier; procedure P_Function_Declaration; procedure P_Pragma; procedure P_Procedure_Declaration; procedure P_Representation_Clause; procedure P_Variable_List_Declaration (Previous_Name : Name_Id; Previous_Sloc : XE_Scan.Location_Type); -- Parse a list of identifiers procedure Parse; -- Main procedure procedure Print; -- Print node tree for debugging purpose. The global variable -- Configuration_Node is used as tree root. procedure Print_Component (Node : Component_Id; Many : Int); procedure Print_Parameter (Node : Parameter_Id; Many : Int); procedure Print_Statement (Node : Statement_Id; Many : Int); procedure Print_Subprogram (Node : Subprogram_Id; Many : Int); procedure Print_Type (Node : Type_Id; Many : Int); procedure Print_Variable (Node : Variable_Id; Many : Int); procedure Search_Actual_Parameter (Actual_Name : Name_Id; Actual_Type : Type_Id; Actual_Node : out Variable_Id); -- Similar to Search_Variable but check name *and* type procedure Search_Component (Component_Name : Name_Id; Type_Node : Type_Id; Component_Node : out Component_Id); -- Search for the first occurrence of a component Component_Name in a -- type Type_Node. If unsuccessful, returns Null_Component. procedure Search_Component (Component_Name : Name_Id; Variable_Node : Variable_Id; Component_Node : out Component_Id); -- Search for the first occurrence of a component Component_Name in a -- variable Variable_Node. If unsuccessful, returns Null_Component. procedure Search_Declaration (Declaration_Name : Name_Id; Declaration_Node : out Node_Id); -- Search for the first occurrence of a declaration -- Declaration_Name. If unsuccessful, returns Null_Node. procedure Search_Function_Returned_Parameter (Function_Node : Subprogram_Id; Parameter_Node : out Parameter_Id); -- Search for the last parameter of this subprogram. This is by -- convention the returned parameter. procedure Search_Matching_Parameter (Subprogram_Node : Subprogram_Id; Convention : Convention_Type; Formal_Name : in out Name_Id; Formal_Type : out Type_Id; Parameter_Node : in out Parameter_Id); -- Search for a formal parameter that has no actual associated -- parameter. This choice should follow Convention requirements. If -- Convention is Named, then returns Parameter_Node of name -- Formal_Name. If is Positional, returns the next unmatched parameter -- and returns also its name in Formal_Name. procedure Search_Next_Component (Component_Name : Name_Id; Component_Node : in out Component_Id); -- Search for the next occurrence of a component Component_Name in -- a list of components starting from Component_Node. If -- unsuccessful, returns Null_Component. procedure Search_Next_Declaration (Declaration_Name : Name_Id; Declaration_Node : in out Node_Id); -- Search the next occurence of a declaration Declaration_Name in -- the configuration starting from Declaratio_Node. If unsuccessful, -- returns Null_Node. procedure Search_Next_Pragma (Pragma_Name : Name_Id; Pragma_Node : in out Subprogram_Id); -- Search for the next occurrence of a pragma Pragma_Name in a -- configuration starting from Subprogram_Node. If unsuccessful, -- returns Null_Subprogram. procedure Search_Next_Subprogram (Subprogram_Name : Name_Id; Subprogram_Node : in out Subprogram_Id); -- Search for the next occurrence of a subprogram Subprogram_Name -- in a configuration starting from Subprogram_Node. If -- unsuccessful, returns Null_Subprogram. procedure Search_Pragma (Pragma_Name : Name_Id; Pragma_Kind : out Pragma_Type; Pragma_Node : out Subprogram_Id); -- Search for the first occurrence of a pragma Pragma_Name. If -- unsuccessful, returns Null_Pragma. If successful, Pragma_Kind is set -- to its corresponding litteral. Otherwise, it is set to -- Pragma_Unknown. procedure Search_Subprogram (Subprogram_Name : Name_Id; Subprogram_Node : out Subprogram_Id); -- Search for the first occurrence of a subprogram Subprogram_Name. If -- unsuccessful, returns Null_Subprogram. procedure Search_Type (Type_Name : Name_Id; Type_Kind : out Predefined_Type; Type_Node : out Type_Id); -- Search for the first occurrence of a type Type_Name. If -- unsuccessful, returns Null_Type. If successful, Type_Kind is set to -- its corresponding litteral. Otherwise, it is set to -- Pre_Type_Unknown. procedure Search_Uninitialized_Component (Variable_Node : Variable_Id; Component_Type : Type_Id; Component_Node : out Component_Id); -- Search for the first occurrence of an uninitialized component in a -- variable Variable_Node. Attributes are discarded. If unsuccessful, -- returns Null_Component. procedure Search_Variable (Variable_Name : Name_Id; Variable_Node : out Variable_Id); -- Search for the first occurrence of a variable Variable_Name. If -- unsuccessful, returns Null_Variable. procedure Set_Node_Location (Node : Node_Id; Location : XE_Scan.Location_Type); -- Set SLOC node to Location procedure T_Apostrophe; procedure T_Arrow; procedure T_Colon; procedure T_Colon_Equal; procedure T_Comma; procedure T_Configuration; procedure T_Dot; procedure T_End; procedure T_EOF; procedure T_For; procedure T_Function; procedure T_Identifier; procedure T_In; procedure T_Is; procedure T_Left_Paren; procedure T_Pragma; procedure T_Procedure; procedure T_Return; procedure T_Right_Paren; procedure T_Semicolon; procedure T_String_Literal; procedure T_Use; procedure Take_Token (T : Token_Type); procedure Take_Token (L : Token_List_Type); end XE_Parse; polyorb-2.8~20110207.orig/compilers/gnatdist/xe_back-polyorb.ads0000644000175000017500000000412311750740337023773 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- X E _ B A C K . P O L Y O R B -- -- -- -- S p e c -- -- -- -- Copyright (C) 1995-2008, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ package XE_Back.PolyORB is pragma Elaborate_Body; end XE_Back.PolyORB; polyorb-2.8~20110207.orig/compilers/gnatdist/xe_io.ads0000644000175000017500000002066211750740337022024 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- X E _ I O -- -- -- -- S p e c -- -- -- -- Copyright (C) 1995-2008, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- This package contains all the routines needed to handle input and -- output operations. with GNAT.OS_Lib; use GNAT.OS_Lib; with XE_Types; use XE_Types; with XE_Units; use XE_Units; package XE_IO is --------------------------------- -- File and Directory Handling -- --------------------------------- procedure Copy_File (Source, Target : File_Name_Type); -- Copy source file into target file (preserves file stamps) procedure Rename_File (Source, Target : File_Name_Type); -- Rename source file into target file procedure Create_File (File : out File_Descriptor; Fname : File_Name_Type; Exec : Boolean := False); -- Create file Fname and make it executable when required procedure Delete_File (Fname : File_Name_Type); -- Delete Fname, fail silently if the file does not exists but -- raise Fatal Error if it file exists and cannot be deleted. procedure Create_Dir (Dname : Directory_Name_Type); -- Create a directory Dname. This function creates all the -- subdirectories (separated by a Directory_Separator) one by one -- and then creates the final directory. function Is_Directory (Fname : File_Name_Type) return Boolean; function Is_Regular_File (Fname : File_Name_Type) return Boolean; function To_Absolute_File (Fname : File_Name_Type) return File_Name_Type; -- When the directory corresponding to Fname is already an -- absolute directory, return Fname. Otherwise, prefix Fname by -- the current directory. function Dir (D1 : Directory_Name_Type; D2 : Directory_Name_Type) return Directory_Name_Type; function Dir (D1 : String_Access; D2 : Directory_Name_Type) return Directory_Name_Type; -- Concatenate several names and insert a directory separator -- between them. function Strip_Directory (Fname : String) return String; function Strip_Directory (Fname : File_Name_Type) return File_Name_Type; -- Strips the prefix directory name (if any) from Name. Returns the -- stripped name. Name cannot end with a directory separator. function Strip_Suffix (Fname : File_Name_Type) return File_Name_Type; -- Strips the suffix (the last '.' and whatever comes after it) from Name. -- Returns the stripped name. function Strip_Exec_Suffix (Fname : File_Name_Type) return File_Name_Type; -- When suffix is an executable suffix, strip it function Normalize_CWD (F : File_Name_Type) return File_Name_Type; -- Remove any leading CWD (./) function To_Afile (Fname : File_Name_Type) return File_Name_Type; function To_Ofile (Fname : File_Name_Type) return File_Name_Type; -- Strip suffix and add resp. ALI suffix or object suffix function Is_Predefined_File (Fname : File_Name_Type) return Boolean; -- Return True when Fname belongs to Ada, GNAT, Interfaces or -- System hierarchy. function File_Time_Stamp (Fname : File_Name_Type) return Time_Stamp_Type; -- Return image of file Fname time stamp. ------------------------------ -- Temporary Files Handling -- ------------------------------ procedure Register_Temp_File (File : out File_Descriptor; Fname : in out File_Name_Type); -- When Fname is null, create a new temporary file. Otherwise, consider -- Fname as a temporary file to be removed when Remove_All_Temporary_Files -- is invoked. procedure Register_Temp_File (Fname : File_Name_Type); -- Insert Fname in the list of temporary files procedure Remove_Temp_File (Fname : File_Name_Type); -- Remove Fname file and remove it from the temporary files list procedure Remove_All_Temp_Files; -- Remove all the files registered as temporary files ---------------------- -- Message Handling -- ---------------------- procedure Message (S1 : String := No_Str; S2 : Name_Id := No_Name; S3 : String := No_Str; S4 : Name_Id := No_Name; S5 : String := No_Str); -- Display a message to the standard output. The message is the -- concatenation of S1 to S5. Parameters with default values are not -- displayed. procedure Write_Stamp_Comparison (Newer, Older : File_Name_Type); procedure Write_Program_Name; --------------------- -- Output Handling -- --------------------- procedure Set_Output (New_Output : GNAT.OS_Lib.File_Descriptor); -- Sets subsequent output to appear on the given file procedure Set_Standard_Error; -- Sets subsequent output to appear on the standard error file -- (whatever that might mean for the host operating system, if -- anything). procedure Set_Standard_Output; -- Sets subsequent output to appear on the standard output file -- (whatever that might mean for the host operating system, if -- anything). Output to standard output is the default mode before -- any call to either of the Set procedures. procedure Write_Char (C : Character); -- Write one character to the standard output file. Note that the -- character should not be LF or CR (use Write_Eol for end of line) procedure Write_Eol (N : Natural := 1); -- Write an end of line (whatever is required by the system in use, -- e.g. CR/LF for DOS, or LF for Unix) to the standard output file. -- This routine also empties the line buffer, actually writing it -- to the file. Note that Write_Eol is the only routine that causes -- any actual output to be written. procedure Write_Int (Val : Int); -- Write an integer value with no leading blanks or zeroes. Negative -- values are preceded by a minus sign). procedure Write_Str (S : String); -- Write a string of characters to the standard output file. Note that -- end of line is handled separately using WRITE_EOL, so the string -- should not contain either of the characters LF or CR, but it may -- contain horizontal tab characters. procedure Write_Line (S : String); -- Equivalent to Write_Str (S) followed by Write_Eol; Space_Increment : Natural := 2; N_Space : Natural := 0; procedure Decrement_Indentation; procedure Increment_Indentation; procedure Set_Space_Increment (Value : Natural); procedure Write_Indentation (Offset : Integer := 0); procedure Write_Space; -------------------- -- Input Handling -- -------------------- procedure Read_File (Fname : File_Name_Type; First : out Text_Ptr; Last : out Text_Ptr; Buffer : out Text_Buffer_Ptr); end XE_IO; polyorb-2.8~20110207.orig/compilers/gnatdist/xe_types.ads0000644000175000017500000002360311750740337022557 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- X E _ T Y P E S -- -- -- -- S p e c -- -- -- -- Copyright (C) 1995-2008, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- This package provides all the basic types used in gnatdist. with Ada.Unchecked_Deallocation; package XE_Types is pragma Preelaborate (XE_Types); -- This package contains host independent type definitions which are used -- in more than one unit in the compiler. They are gathered here for easy -- reference, though in some cases the full description is found in the -- relevant module which implements the definition. The main reason that -- they are not in their "natural" specs is that this would cause a lot of -- inter-spec dependencies, and in particular some awkward circular -- dependencies would have to be dealt with. ------------------------------- -- General Use Integer XE_Types -- ------------------------------- type Int is range -2 ** 31 .. +2 ** 31 - 1; for Int'Size use 32; -- Signed 32-bit integer type Short is range -32768 .. +32767; for Short'Size use 16; -- 16-bit signed integer subtype Nat is Int range 0 .. Int'Last; -- Non-negative Int values subtype Pos is Int range 1 .. Int'Last; -- Positive Int values type Word is mod 2 ** 32; -- Unsigned 32-bit integer type Byte is mod 2 ** 8; for Byte'Size use 8; -- 8-bit unsigned integer type size_t is mod 2 ** Standard'Address_Size; -- Memory size value, for use in calls to C routines -------------------------------------- -- 8-Bit Character and String XE_Types -- -------------------------------------- -- We use Standard.Character and Standard.String freely, since we are -- compiling ourselves, and we properly implement the required 8-bit -- character code as required in Ada 95. This section defines a few -- general use constants and subtypes. EOF : constant Character := ASCII.SUB; -- The character SUB (16#1A#) is used in DOS and other systems derived -- from DOS (OS/2, NT etc) to signal the end of a text file. Internally -- all source files are ended by an EOF character, even on Unix systems. -- An EOF character acts as the end of file only as the last character -- of a source buffer, in any other position, it is treated as a blank -- if it appears between tokens, and as an illegal character otherwise. -- This makes life easier dealing with files that originated from DOS, -- including concatenated files with interspersed EOF characters. subtype Graphic_Character is Character range ' ' .. '~'; -- Graphic characters, as defined in ARM subtype Line_Terminator is Character range ASCII.LF .. ASCII.CR; -- Line terminator characters (LF, VT, FF, CR) subtype Upper_Half_Character is Character range Character'Val (16#80#) .. Character'Val (16#FF#); -- Characters with the upper bit set type Character_Ptr is access all Character; type String_Ptr is access all String; -- Standard character and string pointers procedure Free is new Ada.Unchecked_Deallocation (String, String_Ptr); -- Procedure for freeing dynamically allocated String values ----------------------------------------- -- Types Used for Text Buffer Handling -- ----------------------------------------- -- We can't use type String for text buffers, since we must use the -- standard 32-bit integer as an index value, since we count on all -- index values being the same size. type Text_Ptr is new Int; -- Type used for subscripts in text buffer type Text_Buffer is array (Text_Ptr range <>) of Character; -- Text buffer used to hold source file or library information file type Text_Buffer_Ptr is access all Text_Buffer; -- Text buffers for input files are allocated dynamically and this type -- is used to reference these text buffers. procedure Free is new Ada.Unchecked_Deallocation (Text_Buffer, Text_Buffer_Ptr); -- Procedure for freeing dynamically allocated text buffers -------------------------------- -- Types for XE_Names Package -- -------------------------------- -- Name_Id values are used to identify entries in the names table. Except -- for the special values No_Name, and Error_Name, they are subscript -- values for the Names table defined in package XE_Names. -- Note that with only a few exceptions, which are clearly documented, the -- type Name_Id should be regarded as a private type. In particular it is -- never appropriate to perform arithmetic operations using this type. Names_Low_Bound : constant := 300_000_000; -- Low bound for name Id values Names_High_Bound : constant := 399_999_999; -- Maximum number of names that can be allocated is 100 million, which is -- in practice infinite and there is no need to check the range. type Name_Id is range Names_Low_Bound .. Names_High_Bound; for Name_Id'Size use 32; -- Type used to identify entries in the names table No_Str : constant String := ""; No_Name : constant Name_Id := Names_Low_Bound; -- The special Name_Id value No_Name is used in the parser to indicate -- a situation where no name is present (e.g. on a loop or block). First_Name_Id : constant Name_Id := Names_Low_Bound + 2; -- Subscript of first entry in names table subtype File_Name_Type is Name_Id; -- File names are stored in the names table and this synonym is used to -- indicate that a Name_Id value is being used to hold a simple file -- name (which does not include any directory information). No_File_Name : constant File_Name_Type := File_Name_Type (No_Name); -- Constant used to indicate no file found subtype Unit_Name_Type is Name_Id; -- Unit names are stored in the names table and this synonym is used to -- indicate that a Name_Id value is being used to hold a unit name. ----------------------------------- -- Representation of Time Stamps -- ----------------------------------- -- All compiled units are marked with a time stamp which is derived from -- the source file (we assume that the host system has the concept of a -- file time stamp which is modified when a file is modified). These -- time stamps are used to ensure consistency of the set of units that -- constitutes a library. Time stamps are 12 character strings with -- with the following format: -- YYYYMMDDHHMMSS -- YYYY year -- MM month (2 digits 01-12) -- DD day (2 digits 01-31) -- HH hour (2 digits 00-23) -- MM minutes (2 digits 00-59) -- SS seconds (2 digits 00-59) -- In the case of Unix systems (and other systems which keep the time in -- GMT), the time stamp is the GMT time of the file, not the local time. -- This solves problems in using libraries across networks with clients -- spread across multiple time-zones. Time_Stamp_Length : constant := 14; -- Length of time stamp value subtype Time_Stamp_Index is Natural range 1 .. Time_Stamp_Length; type Time_Stamp_Type is new String (Time_Stamp_Index); -- Type used to represent time stamp Empty_Time_Stamp : constant Time_Stamp_Type := (others => ' '); -- Type used to represent an empty or missing time stamp. Looks less -- than any real time stamp if two time stamps are compared. Note that -- although this is not a private type, clients should not rely on the -- exact way in which this string is represented, and instead should -- use the subprograms below. Dummy_Time_Stamp : constant Time_Stamp_Type := (others => '0'); -- This is used for dummy time stamp values used in the D lines for -- non-existant files, and is intended to be an impossible value. type Node_Id is new Int; No_Node : constant Node_Id := 0; function Present (E : Node_Id) return Boolean; -- Return true when E is not No_Node function No (E : Node_Id) return Boolean; -- Return true when E is No_Node procedure Dummy (E : Node_Id); type List_Id is new Node_Id; No_List : constant List_Id := 0; end XE_Types; polyorb-2.8~20110207.orig/compilers/gnatdist/xe_front.ads0000644000175000017500000001474511750740337022552 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- X E _ F R O N T -- -- -- -- S p e c -- -- -- -- Copyright (C) 1995-2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- This package contains all the data structures needed to represent -- the configuration of the distributed system. As a result of the -- frontend, these structures will provide info required to produce -- stubs, skels and other packages. with XE; use XE; with XE_Types; use XE_Types; with XE_Units; use XE_Units; package XE_Front is -------------- -- Defaults -- -------------- Default_Partition_Id : Partition_Id; Default_Channel_Id : Channel_Id; -- Default channel and partition. The properties of these objects serve as -- templates for all other channels and partitions. Default_Registration_Filter : Filter_Name_Type := No_Filter_Name; Default_First_Boot_Location : Location_Id := No_Location_Id; Default_Last_Boot_Location : Location_Id := No_Location_Id; Default_Data_Location : Location_Id := No_Location_Id; Default_Starter : Import_Method_Type := Ada_Import; Default_Name_Server : Name_Server_Type := No_Name_Server; Default_Version_Check : Boolean := True; Default_Rsh_Command : Name_Id := No_Name; Default_Rsh_Options : Name_Id := No_Name; Default_Priority_Policy : Priority_Policy_Type := No_Priority_Policy; Default_ORB_Tasking_Policy : ORB_Tasking_Policy_Type := Thread_Pool; Configuration : Unit_Name_Type := No_Unit_Name; -- Name of the configuration Main_Partition : Partition_Id := No_Partition_Id; -- Partition where the main procedure has been assigned Main_Subprogram : Unit_Name_Type := No_Unit_Name; -- Several variables related to the main procedure procedure Frontend; procedure Add_Conf_Unit (U : Unit_Name_Type; P : Partition_Id); -- Assign a unit to a partition. This unit is declared in the -- configuration file (it is not yet mapped to an ada unit). procedure Add_Location (First : in out Location_Id; Last : in out Location_Id; Major : Name_Id; Minor : Name_Id); -- Read major and minor from variable and add this pair to -- partition location list. procedure Add_Required_Storage (First : in out Required_Storage_Id; Last : in out Required_Storage_Id; Location : Location_Id; Unit : Unit_Id; Owner : Boolean); -- Add a node in the required storages chained list of a partition procedure Add_Environment_Variable (First : in out Env_Var_Id; Last : in out Env_Var_Id; Name : Name_Id); -- Add new environment variable to partition's list procedure Create_Channel (Name : Channel_Name_Type; Node : Node_Id; CID : out Channel_Id); -- Create a new channel and store its CID in its name key. procedure Create_Host (Name : Host_Name_Type; Node : Node_Id; HID : out Host_Id); -- Create a new host and store its HID in its name key. procedure Create_Partition (Name : Partition_Name_Type; Node : Node_Id; PID : out Partition_Id); -- Create a new partition and store its PID in its name key. function Get_ALI_Id (N : Name_Id) return ALI_Id; function Get_Channel_Id (N : Name_Id) return Channel_Id; function Get_Conf_Unit_Id (N : Name_Id) return Conf_Unit_Id; function Get_Host_Id (N : Name_Id) return Host_Id; function Get_Partition_Id (N : Name_Id) return Partition_Id; function Get_Unit_Id (N : Name_Id) return Unit_Id; procedure Set_ALI_Id (N : Name_Id; A : ALI_Id); procedure Set_Channel_Id (N : Name_Id; C : Channel_Id); procedure Set_Conf_Unit_Id (N : Name_Id; U : Conf_Unit_Id); procedure Set_Host_Id (N : Name_Id; H : Host_Id); procedure Set_Partition_Id (N : Name_Id; P : Partition_Id); procedure Set_Unit_Id (N : Name_Id; U : Unit_Id); function Get_Tasking (A : ALI_Id) return Tasking_Type; procedure Set_Tasking (A : ALI_Id; T : Tasking_Type); function Get_Rsh_Command return Name_Id; function Get_Rsh_Options return Name_Id; procedure Initialize; -- Initialize the first item of each table to use them as default. procedure Update_Most_Recent_Stamp (P : Partition_Id; F : File_Name_Type); -- The more recent stamp of files needed to build a partition is -- updated. procedure Show_Configuration; -- Report the current configuration function To_Build (U : Conf_Unit_Id) return Boolean; -- Is this unit mapped on a partition to build end XE_Front; polyorb-2.8~20110207.orig/compilers/gnatdist/xe_storages.ads0000644000175000017500000000731411750740337023243 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- X E _ S T O R A G E S -- -- -- -- S p e c -- -- -- -- Copyright (C) 2008, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with GNAT.HTable; with XE_Types; use XE_Types; -- This package contains properties of differents storages support -- for shared memory. package XE_Storages is -- Define contraints of shared storage supports -- -- * Allow_Passive : Indicate if the storage support can be -- used on passive partitions -- * Allow_Local_Term : Indicate if the storage support can be -- used on passive partitions -- * Need_tasking : Indicate if the storage support need -- a full tasking profile type Storage_Support_Type is record Allow_Passive : Boolean; Allow_Local_Term : Boolean; Need_Tasking : Boolean; end record; Unknown_Storage_Support : Storage_Support_Type; -- Variable returned when no storage found in table subtype Hash_Header is Natural range 0 .. 10; function Hash (N : Name_Id) return Hash_Header; function Equal (N1, N2 : Name_Id) return Boolean; -- Hash and equality functions for hash table package Storage_Supports is new GNAT.HTable.Simple_HTable (Header_Num => Hash_Header, Element => Storage_Support_Type, No_Element => Unknown_Storage_Support, Key => Name_Id, Hash => Hash, Equal => Equal); -- Storage support implementation repostory table procedure Register_Storage (Storage_Name : String; Allow_Passive : Boolean; Allow_Local_Term : Boolean; Need_Tasking : Boolean); -- Register an available storgae support. Storage name must -- be a valid subpackge name of the storage package. -- (ex. "dsm" => PolyORB.DSA_P.Storages.DSM) end XE_Storages; polyorb-2.8~20110207.orig/compilers/gnatdist/xe_list.adb0000644000175000017500000010454011750740337022345 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- X E _ L I S T -- -- -- -- B o d y -- -- -- -- Copyright (C) 1995-2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with GNAT.Directory_Operations; use GNAT.Directory_Operations; with GNAT.OS_Lib; use GNAT.OS_Lib; with GNAT.Table; with XE; with XE_Front; use XE_Front; with XE_Flags; use XE_Flags; with XE_IO; use XE_IO; with XE_Names; use XE_Names; with XE_Units; use XE_Units; with XE_Utils; use XE_Utils; package body XE_List is Monolithic_Src_File : File_Descriptor; ----------------------- -- Source File Stack -- ----------------------- type Sources_Entry is record Sfile : File_Name_Type; Afile : File_Name_Type; end record; package Sources is new GNAT.Table (Table_Component_Type => Sources_Entry, Table_Index_Type => Natural, Table_Low_Bound => 1, Table_Initial => 20, Table_Increment => 100); ------------ -- Parser -- ------------ package Parser is subtype Token_Type is Natural range 0 .. 27; T_No_ALI : constant Token_Type := 00; T_ALI : constant Token_Type := 01; T_Unit : constant Token_Type := 02; T_With : constant Token_Type := 03; T_Source : constant Token_Type := 04; T_Afile : constant Token_Type := 05; T_Ofile : constant Token_Type := 06; T_Sfile : constant Token_Type := 07; T_Name : constant Token_Type := 08; T_Main : constant Token_Type := 09; T_Kind : constant Token_Type := 10; T_Flags : constant Token_Type := 11; T_Preelaborated : constant Token_Type := 12; T_Pure : constant Token_Type := 13; T_Has_RACW : constant Token_Type := 14; T_Remote_Types : constant Token_Type := 15; T_Shared_Passive : constant Token_Type := 16; T_RCI : constant Token_Type := 17; T_Predefined : constant Token_Type := 18; T_Internal : constant Token_Type := 19; T_Is_Generic : constant Token_Type := 20; T_Procedure : constant Token_Type := 21; T_Function : constant Token_Type := 22; T_Package : constant Token_Type := 23; T_Subprogram : constant Token_Type := 24; T_Spec : constant Token_Type := 25; T_Body : constant Token_Type := 26; No_Such_Token : constant Token_Type := 27; subtype Valid_Token_Type is Token_Type range Token_Type'First .. Token_Type'Last - 1; Image : constant array (Valid_Token_Type) of String_Access := (T_No_ALI => new String'("No_ALI"), T_ALI => new String'("ALI"), T_Unit => new String'("Unit"), T_With => new String'("With"), T_Source => new String'("Source"), T_Afile => new String'("Afile"), T_Ofile => new String'("Ofile"), T_Sfile => new String'("Sfile"), T_Name => new String'("Name"), T_Main => new String'("Main"), T_Kind => new String'("Kind"), T_Flags => new String'("Flags"), T_Preelaborated => new String'("Preelaborated"), T_Pure => new String'("Pure"), T_Has_RACW => new String'("Has_RACW"), T_Remote_Types => new String'("Remote_Types"), T_Shared_Passive => new String'("Shared_Passive"), T_RCI => new String'("RCI"), T_Predefined => new String'("Predefined"), T_Internal => new String'("Internal"), T_Is_Generic => new String'("Is_Generic"), T_Procedure => new String'("procedure"), T_Function => new String'("function"), T_Package => new String'("package"), T_Subprogram => new String'("subprogram"), T_Spec => new String'("spec"), T_Body => new String'("body")); procedure Open (Fname : String); -- Open Fname in order to parse it. Initialize the parser by -- loading file in a buffer. procedure Get_Line; -- Read one line from current buffer and evaluate fields function Field (N : Integer) return String; -- Return Nth field. N has to be in the range of 0 and Number_Of_Fields. -- When N is zero, return the full line. When N < 0, the contents of -- the line starting at the beginning of the |N|th field and until end -- of line is returned. function Number_Of_Fields return Natural; -- Return number of fields in the current line function End_Of_File return Boolean; -- Return True when there is nothing else to read function Token (N : Positive) return Token_Type; -- Return the token corresponding to field N. When there is no -- such corresponding token return No_Such_Token. Note that N -- cannot be zero. procedure Close; -- Close current file and free buffer end Parser; procedure Dump_ALI (My_ALI : ALI_Id); -- Dump content of ALI record procedure Load_ALIs (Output : File_Name_Type); -- Read from Output all the ALI files available ------------ -- Parser -- ------------ package body Parser is use ASCII; type Field_Record is record First, Last : Natural; end record; Chars : String (1 .. 256); N_Chars : Natural; Fields : array (1 .. 32) of Field_Record; N_Fields : Natural := 0; Buffer : Text_Buffer_Ptr; First : Text_Ptr; Index : Text_Ptr; Last : Text_Ptr; -- These values are automatically generated for the set of -- tokens from Token_Type. Do not modify them. P : constant array (0 .. 2) of Natural := (01, 02, 04); T1 : constant array (0 .. 2) of Byte := (54, 27, 20); T2 : constant array (0 .. 2) of Byte := (45, 24, 26); G : constant array (0 .. 54) of Byte := (03, 00, 00, 00, 13, 11, 00, 00, 00, 00, 13, 00, 03, 00, 13, 00, 00, 00, 06, 01, 00, 00, 11, 00, 04, 13, 08, 26, 00, 00, 24, 00, 22, 00, 00, 02, 00, 00, 00, 00, 00, 05, 25, 03, 00, 26, 26, 14, 10, 00, 06, 08, 12, 00, 00); function Hash (S : String) return Natural; ----------- -- Close -- ----------- procedure Close is begin Free (Buffer); Index := First; Last := First; N_Fields := 0; end Close; ----------------- -- End_Of_File -- ----------------- function End_Of_File return Boolean is begin return Last = Index; end End_Of_File; ----------- -- Field -- ----------- function Field (N : Integer) return String is Last : Natural; begin if N = 0 then return Chars (1 .. N_Chars); end if; if N > N_Fields then return ""; end if; if N < 0 then Last := N_Chars; else Last := Fields (N).Last; end if; return Chars (Fields (abs N).First .. Last); end Field; -------------- -- Get_Line -- -------------- procedure Get_Line is C : Character; begin if Last <= Index then raise Fatal_Error; end if; N_Fields := 0; Fields := (others => (0, 0)); N_Chars := 0; while Index < Last loop C := Buffer (Index); Index := Index + 1; case C is when LF | FF | CR | VT => if N_Fields > 0 and then Fields (N_Fields).Last = 0 then Fields (N_Fields).Last := N_Chars; end if; return; when ' ' | HT => if N_Fields > 0 and then Fields (N_Fields).Last = 0 then Fields (N_Fields).Last := N_Chars; end if; N_Chars := N_Chars + 1; Chars (N_Chars) := C; when others => N_Chars := N_Chars + 1; Chars (N_Chars) := C; if N_Fields = 0 or else Fields (N_Fields).Last /= 0 then N_Fields := N_Fields + 1; Fields (N_Fields).First := N_Chars; end if; end case; end loop; if N_Fields > 0 and then Fields (N_Fields).Last = 0 then Fields (N_Fields).Last := N_Chars; end if; end Get_Line; ---------- -- Hash -- ---------- function Hash (S : String) return Natural is F : constant Natural := S'First - 1; L : constant Natural := S'Length; F1, F2 : Natural := 0; J : Natural; begin for K in P'Range loop exit when L < P (K); J := Character'Pos (S (P (K) + F)); F1 := (F1 + Natural (T1 (K)) * J) mod 55; F2 := (F2 + Natural (T2 (K)) * J) mod 55; end loop; return (Natural (G (F1)) + Natural (G (F2))) mod 27; end Hash; ---------------------- -- Number_Of_Fields -- ---------------------- function Number_Of_Fields return Natural is begin if Buffer = null then raise Fatal_Error; end if; return N_Fields; end Number_Of_Fields; ---------- -- Open -- ---------- procedure Open (Fname : String) is begin Name_Len := 0; Add_Str_To_Name_Buffer (Fname); Read_File (Name_Find, First, Last, Buffer); if Buffer = null then raise Fatal_Error; end if; Index := First; end Open; ----------- -- Token -- ----------- function Token (N : Positive) return Token_Type is F : constant String := Field (N); T : constant Natural := Hash (F); begin if T in Valid_Token_Type and then F = Image (T).all then return T; end if; return No_Such_Token; end Token; end Parser; -------------- -- Dump_ALI -- -------------- procedure Dump_ALI (My_ALI : ALI_Id) is use Parser; A : constant ALIs_Record := ALIs.Table (My_ALI); U : Unit_Record; N : Natural := 0; procedure Write_Token (T : Token_Type); ----------------- -- Write_Token -- ----------------- procedure Write_Token (T : Token_Type) is Img : String_Access renames Image (T); begin case T is when T_No_ALI .. T_Flags => for J in 1 .. N loop Write_Str (" "); end loop; Write_Str (Img.all); for J in Img'Length .. 12 loop Write_Char (' '); end loop; Write_Str ("=>"); if T in T_Source .. T_Name then Write_Char (' '); end if; when T_Preelaborated .. T_Body => Write_Char (' '); Write_Str (Img.all); when others => Write_Str (Img.all); end case; end Write_Token; begin Write_Token (T_ALI); Write_Str (" ("); Write_Int (Int (My_ALI)); Write_Str (")"); Write_Eol; N := N + 1; Write_Token (T_Name); Write_Name (A.Uname); Write_Str (" ("); Write_Int (Get_Name_Table_Info (A.Uname)); Write_Str (")"); Write_Eol; if Present (A.Afile) then Write_Token (T_Afile); Write_Name (A.Afile); Write_Str (" ("); Write_Int (Get_Name_Table_Info (A.Afile)); Write_Str (")"); Write_Eol; end if; if Present (A.Ofile) then Write_Token (T_Ofile); Write_Name (A.Ofile); Write_Eol; end if; if Present (A.Sfile) then Write_Token (T_Sfile); Write_Name (A.Sfile); Write_Str (" ("); Write_Int (Get_Name_Table_Info (A.Sfile)); Write_Str (")"); Write_Eol; end if; for J in A.First_Unit .. A.Last_Unit loop U := Units.Table (J); Write_Token (T_Unit); Write_Str (" ("); Write_Int (Int (J)); Write_Str (")"); Write_Eol; N := N + 1; Write_Token (T_Name); Write_Name (U.Uname); Write_Str (" ("); Write_Int (Get_Name_Table_Info (U.Uname)); Write_Str (")"); Write_Eol; if Present (U.Sfile) then Write_Token (T_Sfile); Write_Name (U.Sfile); Write_Str (" ("); Write_Int (Get_Name_Table_Info (U.Sfile)); Write_Str (")"); Write_Eol; end if; Write_Token (T_Flags); if U.Has_RACW then Write_Token (T_Has_RACW); end if; if U.Remote_Types then Write_Token (T_Remote_Types); end if; if U.Shared_Passive then Write_Token (T_Shared_Passive); end if; if U.RCI then Write_Token (T_RCI); end if; if U.Preelaborated then Write_Token (T_Preelaborated); end if; if U.Pure then Write_Token (T_Pure); end if; if U.Predefined then Write_Token (T_Predefined); end if; if U.Internal then Write_Token (T_Internal); end if; if U.Is_Generic then Write_Token (T_Is_Generic); end if; Write_Eol; for K in U.First_With .. U.Last_With loop Write_Token (T_With); Write_Eol; N := N + 1; if Present (Withs.Table (K).Afile) then Write_Token (T_Afile); Write_Name (Withs.Table (K).Afile); Write_Str (" ("); Write_Int (Get_Name_Table_Info (Withs.Table (K).Afile)); Write_Str (")"); Write_Eol; end if; if Present (Withs.Table (K).Sfile) then Write_Token (T_Sfile); Write_Name (Withs.Table (K).Sfile); Write_Str (" ("); Write_Int (Get_Name_Table_Info (Withs.Table (K).Sfile)); Write_Str (")"); Write_Eol; end if; N := N - 1; end loop; N := N - 1; end loop; for J in A.First_Sdep .. A.Last_Sdep loop Write_Token (T_Source); Write_Name (Sdep.Table (J).Sfile); Write_Eol; end loop; Write_Eol; end Dump_ALI; ---------------- -- Initialize -- ---------------- procedure Initialize is begin -- Create main body for monolithic application as a temporary file Register_Temp_File (Monolithic_Src_File, Monolithic_Src_Name); Set_Output (Monolithic_Src_File); Write_Warnings_Pragmas; -- Record the associated object and ALI files as temporary files to -- be cleaned up eventually. Register_Temp_File (Monolithic_ALI_Name); Register_Temp_File (Monolithic_Obj_Name); end Initialize; --------------- -- Load_ALIs -- --------------- procedure Load_ALIs (Output : File_Name_Type) is use Parser; My_ALI : ALI_Id := No_ALI_Id; My_Unit : Unit_Id := No_Unit_Id; My_With : With_Id := No_With_Id; My_Sdep : Sdep_Id := No_Sdep_Id; Afile : File_Name_Type; function File_Name (N : Natural) return File_Name_Type; -- Get the line contents starting with the Nth field and up to end of -- line, and return it as a file name type. --------------- -- File_Name -- --------------- function File_Name (N : Natural) return File_Name_Type is begin -- File names may contain whitespace, so consider not just the Nth -- field but also everything up to end of line. return Id (Format_Pathname (Parser.Field (-N), UNIX)); end File_Name; begin Parser.Open (Get_Name_String (Output)); while not Parser.End_Of_File loop Parser.Get_Line; case Parser.Token (1) is when T_No_ALI => My_ALI := No_ALI_Id; My_Unit := No_Unit_Id; My_With := No_With_Id; My_Sdep := No_Sdep_Id; when T_ALI => -- Allocate ALI and initialize ALI entry ALIs.Increment_Last; My_ALI := ALIs.Last; ALIs.Table (My_ALI) := Default_ALI; My_Sdep := No_Sdep_Id; My_Unit := No_Unit_Id; My_With := No_With_Id; when T_Unit => -- Allocate Unit and initialize Unit entry Units.Increment_Last; My_Unit := Units.Last; Units.Table (My_Unit) := Default_Unit; Units.Table (My_Unit).My_ALI := My_ALI; My_With := No_With_Id; -- Add it to ALI unit list if ALIs.Table (My_ALI).Last_Unit = No_Unit_Id then ALIs.Table (My_ALI).First_Unit := My_Unit; end if; ALIs.Table (My_ALI).Last_Unit := My_Unit; when T_With => -- Allocate With and initialize With entry Withs.Increment_Last; My_With := Withs.Last; Withs.Table (My_With) := Default_With; -- Add it to unit with list if Units.Table (My_Unit).Last_With = No_With_Id then Units.Table (My_Unit).First_With := My_With; end if; Units.Table (My_Unit).Last_With := My_With; when T_Source => Sdep.Increment_Last; My_Sdep := Sdep.Last; Sdep.Table (My_Sdep).Sfile := File_Name (3); -- Add it to ALI sdep list if ALIs.Table (My_ALI).Last_Sdep = No_Sdep_Id then ALIs.Table (My_ALI).First_Sdep := My_Sdep; end if; ALIs.Table (My_ALI).Last_Sdep := My_Sdep; -- Detect use of tasking Get_Name_String (Strip_Directory (Sdep.Table (My_Sdep).Sfile)); if Name_Len > 8 and then Name_Buffer (1 .. 8) = "s-taskin" then ALIs.Table (My_ALI).Tasking := XE.User_Tasking; end if; when T_Afile => -- If My_With is not null, then this attribute belongs -- to a With entry. if My_With /= No_With_Id then Withs.Table (My_With).Afile := File_Name (3); else Afile := File_Name (3); Set_ALI_Id (Afile, My_ALI); if My_ALI /= No_ALI_Id then ALIs.Table (My_ALI).Afile := Afile; end if; end if; when T_Ofile => ALIs.Table (My_ALI).Ofile := File_Name (3); when T_Sfile => -- If My_With is not null, then this attribute belongs -- to a Withs entry. if My_With /= No_With_Id then Withs.Table (My_With).Sfile := File_Name (3); -- If My_Unit is not null, then this attribute belongs -- to a Units entry. elsif My_Unit /= No_Unit_Id then Units.Table (My_Unit).Sfile := File_Name (3); Set_Unit_Id (Units.Table (My_Unit).Sfile, My_Unit); elsif My_ALI /= No_ALI_Id then ALIs.Table (My_ALI).Sfile := File_Name (3); else -- Unexpected Sfile token raise Program_Error; end if; when T_Name => -- If My_With is not null, then this attribute belongs -- to a With entry. if My_With /= No_With_Id then Withs.Table (My_With).Uname := File_Name (3); else Units.Table (My_Unit).Uname := File_Name (3); -- When Uname is unknown in ALI, update it and -- associate unit name with ALI id. Note that the -- unit name is not yet encoded. if No (ALIs.Table (My_ALI).Uname) then ALIs.Table (My_ALI).Uname := Units.Table (My_Unit).Uname; Set_ALI_Id (ALIs.Table (My_ALI).Uname, My_ALI); end if; end if; when T_Main => if Parser.Token (3) = T_Procedure then ALIs.Table (My_ALI).Main_Program := Proc; else ALIs.Table (My_ALI).Main_Program := Func; end if; when T_Kind => -- If My_With is not null, then this attribute belongs -- to a With entry. if My_With /= No_With_Id then Get_Name_String (Withs.Table (My_With).Uname); Add_Char_To_Name_Buffer ('%'); if Parser.Token (3) = T_Spec then Add_Char_To_Name_Buffer ('s'); else Add_Char_To_Name_Buffer ('b'); end if; Withs.Table (My_With).Uname := Name_Find; else -- Is it a subprogram or a package if Parser.Token (3) = T_Subprogram then Units.Table (My_Unit).Unit_Kind := 's'; else Units.Table (My_Unit).Unit_Kind := 'p'; end if; -- Prepare to set unit name info Get_Name_String (Units.Table (My_Unit).Uname); Add_Char_To_Name_Buffer ('%'); -- Is it a spec or a body if Parser.Token (4) = T_Spec then Add_Char_To_Name_Buffer ('s'); if ALIs.Table (My_ALI).First_Unit = My_Unit then Units.Table (My_Unit).Utype := Is_Spec_Only; else Units.Table (ALIs.Table (My_ALI).First_Unit).Utype := Is_Body; Units.Table (My_Unit).Utype := Is_Spec; end if; else Add_Char_To_Name_Buffer ('b'); Units.Table (My_Unit).Utype := Is_Body_Only; end if; -- Set unit name info Units.Table (My_Unit).Uname := Name_Find; Set_Unit_Id (Units.Table (My_Unit).Uname, My_Unit); end if; when T_Flags => for F in 3 .. Parser.Number_Of_Fields loop case Parser.Token (F) is when T_Has_RACW => Units.Table (My_Unit).Has_RACW := True; when T_Remote_Types => Units.Table (My_Unit).Remote_Types := True; when T_Shared_Passive => Units.Table (My_Unit).Shared_Passive := True; when T_RCI => Units.Table (My_Unit).RCI := True; when T_Predefined => Units.Table (My_Unit).Predefined := True; when T_Internal => Units.Table (My_Unit).Internal := True; when T_Is_Generic => Units.Table (My_Unit).Is_Generic := True; when T_Preelaborated => Units.Table (My_Unit).Preelaborated := True; when others => null; end case; end loop; when others => null; end case; end loop; Parser.Close; Remove_Temp_File (Output); end Load_ALIs; ------------------------------- -- Load_All_Registered_Units -- ------------------------------- procedure Load_All_Registered_Units is Comp_Flags : constant Argument_List := (Semantic_Only_Flag, Object_Dir_Flag, new String'(Get_Name_String (Monolithic_Obj_Dir))); List_Args : constant Argument_List := (GLADE_List_Flag, Project_File_Flag, Project_File_Name); Make_Args : constant Argument_List := (Compile_Only_Flag, Project_File_Flag, Project_File_Name); List_Args_Length, Make_Args_Length : Natural; Sfile : File_Name_Type; Afile : File_Name_Type; ALI : ALI_Id; Partition : Partition_Id; Output : File_Name_Type; begin -- Only use the project flags if a project has been set if Project_File_Name /= null then List_Args_Length := 3; Make_Args_Length := 3; else List_Args_Length := 1; Make_Args_Length := 1; end if; declare Make_Flags : Argument_List renames Make_Args (1 .. Make_Args_Length); List_Flags : Argument_List renames List_Args (1 .. List_Args_Length); begin -- Finish up main library procedure with a dummy body Write_Str ("procedure "); Write_Name (Monolithic_App_Unit_Name); Write_Line (" is"); Write_Line ("begin"); Write_Line (" null;"); Write_Str ("end "); Write_Name (Monolithic_App_Unit_Name); Write_Line (";"); Close (Monolithic_Src_File); Set_Standard_Output; -- Build the monolithic application with a fake main subprogram -- Monolithic_App. Note that we must pass the bare file name (without -- directory information) to gnat make, Monolithic_Src_Base_Name, -- not Monolithic_Src_Name. Sfile := Monolithic_Src_Base_Name; Build (Sfile, Make_Flags, not Keep_Going, Display_Compilation_Progress); -- Load the info from its ALI file List ((1 => Monolithic_ALI_Name), List_Flags, Output); Load_ALIs (Output); ALI := Get_ALI_Id (Monolithic_ALI_Name); -- Do not delete the source file for the fake main subprogram, -- it is needed by List later on. Remove_Temp_File (Part_Main_ALI_Name); Remove_Temp_File (Part_Main_Obj_Name); -- The compilation of monolithic_app.adb failed. There is no way to -- rescue this situation. if ALI = No_ALI_Id then raise Compilation_Error; end if; -- Load in the sources stack all the withed units or in other -- words the configured units. for J in ALIs.Table (ALI).First_Unit .. ALIs.Table (ALI).Last_Unit loop for K in Units.Table (J).First_With .. Units.Table (J).Last_With loop Sfile := Withs.Table (K).Sfile; if Present (Sfile) then Set_Name_Table_Byte (Sfile, 1); Sources.Append (Sources_Entry' (Sfile => Sfile, Afile => Withs.Table (K).Afile)); end if; end loop; end loop; while Sources.First <= Sources.Last loop declare Last : Natural := Sources.Last + 1 - Sources.First; Afiles : File_Name_List (1 .. Last); Sfiles : File_Name_List (1 .. Last); begin -- Load in Args the sources whose corresponding ALI file is not -- yet available. Last := 0; for J in Sources.First .. Sources.Last loop Sfile := Sources.Table (J).Sfile; Afile := Sources.Table (J).Afile; -- We never tried to download this ALI file. Its info -- is not a valid ALI id (not even No_ALI_Id). if Get_Name_Table_Info (Afile) = 0 then Last := Last + 1; Afiles (Last) := Afile; Sfiles (Last) := Sfile; end if; end loop; Sources.Init; List (Afiles (1 .. Last), List_Flags, Output); Load_ALIs (Output); for J in 1 .. Last loop Sfile := Sfiles (J); Afile := Afiles (J); ALI := Get_ALI_Id (Afile); -- The ALI file does not exist. It may come from a missing -- body file although the spec file is available (the main -- subprogram is compiled with the -k (keep going) flag). -- Therefore compile the spec file with the -gnatc -- (semantics only) flag in order to obtain an ALI file -- anyway. Then check, this operation was successul, i.e. -- that the unit is an RCI. The missing body file is not an -- issue as long as the unit is not assigned to a partition -- to build. if ALI = No_ALI_Id then Compile (Sfile, Comp_Flags, Fatal => False); List ((1 => Afile), List_Flags, Output); Load_ALIs (Output); -- If the ALI file is still missing, then we have a -- real problem. ALI := Get_ALI_Id (Afile); if ALI = No_ALI_Id then Get_Name_String (Sfile); raise Fatal_Error with "failed to load ALI for " & Name_Buffer (1 .. Name_Len); end if; -- Check that the unit was really assigned to a partition -- we are not going to build. Partition := Get_Partition_Id (ALIs.Table (ALI).Uname); if not Units.Table (ALIs.Table (ALI).Last_Unit).RCI or else Partition = No_Partition_Id or else Partitions.Table (Partition).To_Build then Get_Name_String (ALIs.Table (ALI).Uname); raise Fatal_Error with "invalid partition for " & Name_Buffer (1 .. Name_Len); end if; end if; if Debug_Mode then Dump_ALI (ALI); end if; -- Check that the withed units are present. for J in ALIs.Table (ALI).First_Unit .. ALIs.Table (ALI).Last_Unit loop for K in Units.Table (J).First_With .. Units.Table (J).Last_With loop Sfile := Withs.Table (K).Sfile; -- We can ignore the sources that have already -- been loaded and the predefined ones (they are -- not defined as configured units at this stage -- and they cannot be categorized). if Present (Sfile) and then not Is_Predefined_File (Sfile) and then Get_Name_Table_Byte (Sfile) = 0 then Set_Name_Table_Byte (Sfile, 1); Sources.Append (Sources_Entry' (Sfile => Sfile, Afile => Withs.Table (K).Afile)); end if; end loop; end loop; end loop; end; end loop; end; end Load_All_Registered_Units; --------------------------- -- Register_Unit_To_Load -- --------------------------- procedure Register_Unit_To_Load (Uname : Unit_Name_Type) is begin Write_Str ("with "); Write_Name (Uname); Write_Line (";"); end Register_Unit_To_Load; end XE_List; polyorb-2.8~20110207.orig/compilers/gnatdist/xe.ads0000644000175000017500000006771211750740337021344 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- X E -- -- -- -- S p e c -- -- -- -- Copyright (C) 1995-2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- This package contains the routines used by the parser to handle -- tokens and nodes corresponding to the configuration file. with XE_Types; use XE_Types; package XE is -- Several names are reserved keywords. For each of these names, a key -- is associated in the hash table. This allows to retrieve the nature -- of the name and especially its type. The key (an integer) is in one -- of the following ranges and therefore, the name corresponds to the -- image of an element in the enumeration type. -------------- -- Keywords -- -------------- type Token_Type is new Int range 100 .. 126; Tok_Unknown : constant Token_Type := 100; -- (0) Identifier Tok_String_Literal : constant Token_Type := 101; -- (1) string literal Tok_Numeric_Literal : constant Token_Type := 102; -- (2) numeric literal Tok_Identifier : constant Token_Type := 103; -- (3) identifer Tok_Dot : constant Token_Type := 104; -- (4) . Tok_Apostrophe : constant Token_Type := 105; -- (5) ' Tok_Left_Paren : constant Token_Type := 106; -- (6) ( Tok_Right_Paren : constant Token_Type := 107; -- (7) ) Tok_Comma : constant Token_Type := 108; -- (8) , Tok_Colon_Equal : constant Token_Type := 109; -- (9) := Tok_Colon : constant Token_Type := 110; -- (10) : Tok_Configuration : constant Token_Type := 111; -- (11) CONFIGURATION Tok_Pragma : constant Token_Type := 112; -- (12) PRAGMA Tok_Procedure : constant Token_Type := 113; -- (13) PROCEDURE Tok_Is : constant Token_Type := 114; -- (14) IS Tok_In : constant Token_Type := 115; -- (15) IN Tok_For : constant Token_Type := 116; -- (16) FOR Tok_Use : constant Token_Type := 117; -- (17) USE Tok_Function : constant Token_Type := 118; -- (18) FUNCTION Tok_End : constant Token_Type := 119; -- (19) END Tok_Begin : constant Token_Type := 120; -- (20) BEGIN Tok_Null : constant Token_Type := 121; -- (21) NULL Tok_Semicolon : constant Token_Type := 122; -- (22) ; Tok_Arrow : constant Token_Type := 123; -- (23) => Tok_Return : constant Token_Type := 124; -- (24) return Tok_EOF : constant Token_Type := 125; -- (25) end of file Tok_Reserved : constant Token_Type := 126; -- (26) Ada keywords type Token_List_Type is array (Positive range <>) of Token_Type; Reserved : array (Token_Type) of Boolean := (others => False); -------------------- -- Attribute Type -- -------------------- type Attribute_Type is new Int range 200 .. 217; Attribute_Unknown : constant Attribute_Type := 200; Attribute_Host : constant Attribute_Type := 201; Attribute_Directory : constant Attribute_Type := 202; Attribute_Main : constant Attribute_Type := 203; Attribute_Command_Line : constant Attribute_Type := 204; Attribute_Termination : constant Attribute_Type := 205; Attribute_Leader : constant Attribute_Type := 206; Attribute_PFilter : constant Attribute_Type := 207; Attribute_CFilter : constant Attribute_Type := 208; Attribute_Task_Pool : constant Attribute_Type := 209; Attribute_Reconnection : constant Attribute_Type := 210; Attribute_Protocol : constant Attribute_Type := 211; Attribute_Storage : constant Attribute_Type := 212; Attribute_Passive : constant Attribute_Type := 213; Attribute_Priority : constant Attribute_Type := 214; Attribute_Allow_Light_PCS : constant Attribute_Type := 215; Attribute_Environment_Variables : constant Attribute_Type := 216; Attribute_ORB_Tasking_Policy : constant Attribute_Type := 217; ----------------- -- Pragma Type -- ----------------- type Pragma_Type is new Int range 300 .. 308; Pragma_Unknown : constant Pragma_Type := 300; Pragma_Boot_Location : constant Pragma_Type := 301; Pragma_Import : constant Pragma_Type := 302; Pragma_Name_Server : constant Pragma_Type := 303; Pragma_Priority : constant Pragma_Type := 304; Pragma_Reg_Filter : constant Pragma_Type := 305; Pragma_Remote_Shell : constant Pragma_Type := 306; Pragma_Starter : constant Pragma_Type := 307; Pragma_Version : constant Pragma_Type := 308; ------------------------ -- Import Method Type -- ------------------------ type Import_Method_Type is new Int range 341 .. 343; Ada_Import : constant Import_Method_Type := 341; Shell_Import : constant Import_Method_Type := 342; None_Import : constant Import_Method_Type := 343; --------------------- -- Predefined Type -- --------------------- type Predefined_Type is new Int range 401 .. 415; Pre_Type_Partition : constant Predefined_Type := 401; Pre_Type_Channel : constant Predefined_Type := 402; Pre_Type_Boolean : constant Predefined_Type := 403; Pre_Type_Integer : constant Predefined_Type := 404; Pre_Type_String : constant Predefined_Type := 405; Pre_Type_Strings : constant Predefined_Type := 406; Pre_Type_Entity : constant Predefined_Type := 407; Pre_Type_Convention : constant Predefined_Type := 408; Pre_Type_Ada_Unit : constant Predefined_Type := 409; Pre_Type_Function : constant Predefined_Type := 410; Pre_Type_Procedure : constant Predefined_Type := 411; Pre_Type_Task_Pool : constant Predefined_Type := 412; Pre_Type_Location : constant Predefined_Type := 413; Pre_Type_Locations : constant Predefined_Type := 414; Pre_Type_Name_Server : constant Predefined_Type := 415; ---------------------- -- Termination Type -- ---------------------- type Termination_Type is new Int range 500 .. 503; No_Termination : constant Termination_Type := 500; Local_Termination : constant Termination_Type := 501; Global_Termination : constant Termination_Type := 502; Deferred_Termination : constant Termination_Type := 503; Termination_Img : array (Termination_Type) of Name_Id; ------------------ -- Boolean Type -- ------------------ type Boolean_Type is new Int range 600 .. 602; BMaybe : constant Boolean_Type := 600; BFalse : constant Boolean_Type := 601; BTrue : constant Boolean_Type := 602; Boolean_Img : array (Boolean_Type) of Name_Id; ----------------------- -- Reconnection Type -- ----------------------- type Reconnection_Type is new Int range 700 .. 703; No_Reconnection : constant Reconnection_Type := 700; Reject_On_Restart : constant Reconnection_Type := 701; Block_Until_Restart : constant Reconnection_Type := 702; Fail_Until_Restart : constant Reconnection_Type := 703; Reconnection_Img : array (Reconnection_Type) of Name_Id; -------------------------- -- Priority Policy Type -- -------------------------- type Priority_Policy_Type is new Int range 800 .. 802; No_Priority_Policy : constant Priority_Policy_Type := 800; Server_Declared : constant Priority_Policy_Type := 801; Client_Propagated : constant Priority_Policy_Type := 802; Priority_Policy_Img : array (Priority_Policy_Type) of Name_Id; ----------------------------- -- ORB Tasking Policy Type -- ----------------------------- type ORB_Tasking_Policy_Type is new Int range 900 .. 903; No_ORB_Tasking_Policy : constant ORB_Tasking_Policy_Type := 900; Thread_Pool : constant ORB_Tasking_Policy_Type := 901; Thread_Per_Session : constant ORB_Tasking_Policy_Type := 902; Thread_Per_Request : constant ORB_Tasking_Policy_Type := 903; ORB_Tasking_Policy_Img : array (ORB_Tasking_Policy_Type) of Name_Id; ----------------------------- -- ORB Tasking Policy Type -- ----------------------------- type Name_Server_Type is new Int range 950 .. 953; No_Name_Server : constant Name_Server_Type := 950; Embedded : constant Name_Server_Type := 951; Standalone : constant Name_Server_Type := 952; Multicast : constant Name_Server_Type := 953; Name_Server_Img : array (Name_Server_Type) of Name_Id; ------------------ -- Tasking Type -- ------------------ type Tasking_Type is new Int range 1000 .. 1003; Unknown_Tasking : constant Tasking_Type := 1000; PCS_Tasking : constant Tasking_Type := 1001; User_Tasking : constant Tasking_Type := 1002; No_Tasking : constant Tasking_Type := 1003; Tasking_Img : array (Tasking_Type) of Name_Id; ------------- -- Node Id -- ------------- type Type_Id is new Node_Id; type Variable_Id is new Node_Id; type Component_Id is new Node_Id; type Parameter_Id is new Node_Id; type Attribute_Id is new Node_Id; type Statement_Id is new Node_Id; type Subprogram_Id is new Node_Id; type Configuration_Id is new Node_Id; Null_Node : constant Node_Id := Node_Id'First; First_Node : constant Node_Id := Null_Node + 1; NN : constant Node_Id := Null_Node; Null_Type : constant Type_Id := Type_Id (NN); Null_Variable : constant Variable_Id := Variable_Id (NN); Null_Parameter : constant Parameter_Id := Parameter_Id (NN); Null_Component : constant Component_Id := Component_Id (NN); Null_Subprogram : constant Subprogram_Id := Subprogram_Id (NN); Null_Configuration : constant Configuration_Id := Configuration_Id (NN); -------------------- -- Standard nodes -- -------------------- Configuration_Node : Configuration_Id; Configuration_File_Name : File_Name_Type := No_File_Name; Partition_Type_Node : Type_Id; Channel_Type_Node : Type_Id; Boolean_Type_Node : Type_Id; Integer_Type_Node : Type_Id; String_Type_Node : Type_Id; String_List_Type_Node : Type_Id; Convention_Type_Node : Type_Id; Ada_Unit_Type_Node : Type_Id; Subprogram_Type_Node : Type_Id; Main_Procedure_Type_Node : Type_Id; Host_Function_Type_Node : Type_Id; Task_Pool_Type_Node : Type_Id; Location_Type_Node : Type_Id; Locations_Type_Node : Type_Id; Priority_Policy_Type_Node : Type_Id; Name_Server_Type_Node : Type_Id; Pragma_Starter_Node : Subprogram_Id; Pragma_Import_Node : Subprogram_Id; Pragma_Boot_Location_Node : Subprogram_Id; Pragma_Version_Node : Subprogram_Id; Pragma_Reg_Filter_Node : Subprogram_Id; Pragma_Priority_Node : Subprogram_Id; Pragma_Remote_Shell_Node : Subprogram_Id; Pragma_Name_Server_Node : Subprogram_Id; Infinite : constant Int := Int'Last; -- Size of an unconstrained array --------------------------- -- Internal System Names -- --------------------------- Function_Name_Id : Name_Id; Procedure_Name_Id : Name_Id; Return_Name_Id : Name_Id; type Context_Type is record Last_Decl : Node_Id; Last_Node : Node_Id; Conf_Node : Node_Id; Anonymous : Int; end record; ---------------------- -- Node Subprograms -- ---------------------- procedure Add_Configuration_Declaration (Configuration_Node : Configuration_Id; Declaration_Node : Node_Id); -- Add a configuration node to the list of configuration. Cannot -- be inlined. procedure Add_Subprogram_Parameter (Subprogram_Node : Subprogram_Id; Parameter_Node : Parameter_Id); pragma Inline (Add_Subprogram_Parameter); -- Add a parameter node to the subprogram parameter list. procedure Add_Type_Component (Type_Node : Type_Id; Component_Node : Component_Id); pragma Inline (Add_Type_Component); -- Add a component to the type component list. procedure Add_Variable_Component (Variable_Node : Variable_Id; Component_Node : Component_Id); pragma Inline (Add_Variable_Component); -- Add a component to the variable component list. procedure Component_Is_Initialized (Component_Node : Component_Id; Is_Initialized : Boolean); pragma Inline (Component_Is_Initialized); -- Indicate whether a component is initialized or not. procedure Create_Component (Component_Node : out Component_Id; Component_Name : Name_Id); pragma Inline (Create_Component); procedure Create_Configuration (Configuration_Node : out Configuration_Id; Configuration_Name : Name_Id); pragma Inline (Create_Configuration); procedure Create_Parameter (Parameter_Node : out Parameter_Id; Parameter_Name : Name_Id); pragma Inline (Create_Parameter); procedure Create_Statement (Statement_Node : out Statement_Id; Statement_Name : Name_Id); pragma Inline (Create_Statement); procedure Create_Subprogram (Subprogram_Node : out Subprogram_Id; Subprogram_Name : Name_Id); pragma Inline (Create_Subprogram); procedure Create_Type (Type_Node : out Type_Id; Type_Name : Name_Id); pragma Inline (Create_Type); procedure Create_Variable (Variable_Node : out Variable_Id; Variable_Name : Name_Id); pragma Inline (Create_Variable); procedure First_Configuration_Declaration (Configuration_Node : Configuration_Id; Declaration_Node : out Node_Id); -- Set to the first declaration in the configuration list. Cannot -- be inlined. procedure First_Subprogram_Parameter (Subprogram_Node : Subprogram_Id; Parameter_Node : out Parameter_Id); pragma Inline (First_Subprogram_Parameter); -- Set to the first parameter in the subprogram parameter list. procedure First_Type_Component (Type_Node : Type_Id; Component_Node : out Component_Id); pragma Inline (First_Type_Component); -- Set to the first type component in the type component list. procedure First_Variable_Component (Variable_Node : Variable_Id; Component_Node : out Component_Id); pragma Inline (First_Variable_Component); -- Set to the first component of the variable component list. The -- variable component list can be different from the type -- component list when the type is an unconstrained array. In this -- case, each array element is considered as a component. function Get_Array_Component_Type (Type_Node : Type_Id) return Type_Id; pragma Inline (Get_Array_Component_Type); -- When the type is a component array type, this function returns the -- type of a component. function Get_Attribute_Kind (Component_Node : Component_Id) return Attribute_Type; pragma Inline (Get_Attribute_Kind); -- A type or a variable is a set of components and of attributes. This -- function returns the attribute type, Attribute_Unknown when it is -- not an attribute. function Get_Array_Length (Variable_Node : Variable_Id) return Int; pragma Inline (Get_Array_Length); -- When the type of Variable_Node is an unconstrained array, this -- function returns the current length of the array. Otherwise, it -- returns the length of the array type. function Get_Array_Length (Type_Node : Type_Id) return Int; pragma Inline (Get_Array_Length); -- When the type is a record type, return 0. For a constrained -- array type, this function returns the length of the array -- type. Infinite for an unconstrained array type. function Get_Component_Name (Component : Component_Id) return Name_Id; pragma Inline (Get_Component_Name); function Get_Component_Type (Component_Node : Component_Id) return Type_Id; pragma Inline (Get_Component_Type); function Get_Component_Value (Component_Node : Component_Id) return Variable_Id; pragma Inline (Get_Component_Value); -- The component has to be initialized. This function returns the -- variable set as component value. function Get_Node_Name (Node : Node_Id) return Name_Id; pragma Inline (Get_Node_Name); procedure Get_Node_SLOC (Node : Node_Id; Loc_X : out Int; Loc_Y : out Int); pragma Inline (Get_Node_SLOC); function Get_Parameter_Type (Parameter_Node : Parameter_Id) return Type_Id; pragma Inline (Get_Parameter_Type); function Get_Parameter_Value (Parameter_Node : Parameter_Id) return Variable_Id; pragma Inline (Get_Parameter_Value); -- This parameter has to be initialized. This function returns the -- variable set as parameter value. function Get_Pragma_Kind (Subprogram_Node : Subprogram_Id) return Pragma_Type; pragma Inline (Get_Pragma_Kind); -- Subprograms are used to implement pragmas and to represent some -- ada units (function and procedures). This function returns -- Pragma_Unknown when this subprogram does not implement a -- pragma. function Get_Scalar_Value (Variable_Node : Variable_Id) return Int; -- Return a scalar rather than a variable as a value. function Get_Subprogram_Call (Statement_Node : Statement_Id) return Subprogram_Id; -- This statement is a procedure call. This returns a copy of the -- subprogram call with the initialized parameters in it. function Get_Token (N : Name_Id) return Token_Type; -- Use name key to get back the token type. function Get_Type_Kind (Type_Node : Type_Id) return Predefined_Type; pragma Inline (Get_Type_Kind); -- This function returns the predefined_type id of Type_Node. function Get_Variable_Name (Variable : Variable_Id) return Name_Id; pragma Inline (Get_Variable_Name); function Get_Variable_Type (Variable_Node : Variable_Id) return Type_Id; pragma Inline (Get_Variable_Type); function Get_Variable_Value (Variable_Node : Variable_Id) return Variable_Id; pragma Inline (Get_Variable_Value); -- Return a variable rather than a scalar as a value. procedure Initialize; function Is_Component (Node : Node_Id) return Boolean; pragma Inline (Is_Component); function Is_Component_Initialized (Component_Node : Component_Id) return Boolean; pragma Inline (Is_Component_Initialized); -- Has this component a value. function Is_Configuration (Node : Node_Id) return Boolean; pragma Inline (Is_Configuration); function Is_Parameter_Initialized (Parameter_Node : Parameter_Id) return Boolean; -- Has this parameter a value. Parameter are marked to find which -- parameter is missing in a subprogram call. function Is_Statement (Node : Node_Id) return Boolean; pragma Inline (Is_Statement); function Is_Subprogram (Node : Node_Id) return Boolean; pragma Inline (Is_Subprogram); function Is_Subprogram_A_Procedure (Subprogram_Node : Subprogram_Id) return Boolean; pragma Inline (Is_Subprogram_A_Procedure); function Is_Type (Node : Node_Id) return Boolean; pragma Inline (Is_Type); function Is_Type_Composite (Type_Node : Type_Id) return Boolean; pragma Inline (Is_Type_Composite); function Is_Variable (Node : Node_Id) return Boolean; pragma Inline (Is_Variable); function Is_Variable_Initialized (Variable_Node : Variable_Id) return Boolean; pragma Inline (Is_Variable_Initialized); procedure Jump_Context (Context : Context_Type); pragma Inline (Jump_Context); -- Preserve the context of the parsing process to restore it in -- case of failure to try another solution. function New_Variable_Name return Name_Id; pragma Inline (New_Variable_Name); -- Return an anonymous name variable which does not conflict with -- user names. This name is composed of a constant prefix and an -- index. function New_Component_Name (Variable_Node : Variable_Id) return Name_Id; pragma Inline (New_Component_Name); -- Returns an anonymous name which does not conflict with user -- name. This name is composed of a constant prefix and the index -- of the component in the variable. procedure Next_Configuration_Declaration (Declaration_Node : in out Node_Id); pragma Inline (Next_Configuration_Declaration); -- There are two configurations : the user one and the standard -- one. When the next declaration is a configuration node, go into -- this configuration and return the next declaration node. procedure Next_Subprogram_Parameter (Parameter_Node : in out Parameter_Id); pragma Inline (Next_Subprogram_Parameter); -- Set to the next parameter in the subprogram parameter list. procedure Next_Type_Component (Component_Node : in out Component_Id); pragma Inline (Next_Type_Component); -- Set to the next component of type component list. procedure Next_Variable_Component (Component_Node : in out Component_Id); pragma Inline (Next_Variable_Component); -- Set to the next component in the variable component list. procedure Parameter_Is_Initialized (Parameter_Node : Parameter_Id; Is_Initialized : Boolean); pragma Inline (Parameter_Is_Initialized); -- Parameter are marked to find what parameter is missing in a -- subprogram call. procedure Save_Context (Configuration : Configuration_Id; Context : out Context_Type); pragma Inline (Save_Context); -- Save the context of the parsing process to restore it in case -- of failure to try another solution. procedure Set_Array_Component_Type (Type_Node : Type_Id; Comp_Type : Type_Id); pragma Inline (Set_Array_Component_Type); -- This type becomes an component list type. Each element is of type -- comp_type. procedure Set_Attribute_Kind (Component_Node : Component_Id; Attribute_Kind : Attribute_Type); pragma Inline (Set_Attribute_Kind); -- See Get_Attribute_Kind. procedure Set_Array_Length (Type_Node : Type_Id; Array_Length : Int); pragma Inline (Set_Array_Length); -- See Get_Array_Length. procedure Set_Array_Length (Variable_Node : Variable_Id; Array_Length : Int); pragma Inline (Set_Array_Length); -- See Get_Array_Length. procedure Set_Component_Type (Component_Node : Component_Id; Type_Node : Type_Id); pragma Inline (Set_Component_Type); -- See Get_Component_Type. procedure Set_Component_Value (Component_Node : Component_Id; Value_Node : Variable_Id); pragma Inline (Set_Component_Value); -- See Get_Component_Value. procedure Set_Node_SLOC (Node : Node_Id; Loc_X : Int; Loc_Y : Int); pragma Inline (Set_Node_SLOC); procedure Set_Parameter_Type (Parameter_Node : Parameter_Id; Parameter_Type : Type_Id); pragma Inline (Set_Parameter_Type); -- See Get_Parameter_Type. procedure Set_Pragma_Kind (Subprogram_Node : Subprogram_Id; Pragma_Kind : Pragma_Type); pragma Inline (Set_Pragma_Kind); -- See Get_Pragam_Kind. procedure Set_Scalar_Value (Variable_Node : Variable_Id; Scalar_Value : Int); pragma Inline (Set_Scalar_Value); -- See Get_Scalar_Value. procedure Set_Subprogram_Call (Statement_Node : Statement_Id; Subprogram_Node : Subprogram_Id); pragma Inline (Set_Subprogram_Call); -- Initiliaze this statement with a copy of the subprogram tree. This -- tree contains the parameters with their associated values. procedure Set_Token (N : String; T : Token_Type); procedure Set_Type_Kind (Type_Node : Type_Id; Type_Kind : Predefined_Type); pragma Inline (Set_Type_Kind); -- See Get_Type_Kind. procedure Set_Variable_Type (Variable_Node : Variable_Id; Variable_Type : Type_Id); pragma Inline (Set_Variable_Type); -- See Get_Variable_Type. procedure Set_Variable_Value (Variable_Node : Variable_Id; Value_Node : Variable_Id); pragma Inline (Set_Variable_Value); -- See Get_Variable_Value. procedure Subprogram_Is_A_Procedure (Subprogram_Node : Subprogram_Id; Procedure_Node : Boolean); pragma Inline (Subprogram_Is_A_Procedure); -- See Is_Suprogram_A_Procedure procedure Type_Is_Composite (Type_Node : Type_Id; Composite : Boolean); procedure Variable_Is_Initialized (Variable_Node : Variable_Id; Is_Initialized : Boolean); pragma Inline (Variable_Is_Initialized); -- See Is_Variable_Initialized procedure Write_SLOC (Node : Node_Id); pragma Inline (Write_SLOC); -------------------------- -- Conversion Functions -- -------------------------- function Convert (Item : Attribute_Type) return Int; pragma Inline (Convert); function Convert (Item : Int) return Attribute_Type; pragma Inline (Convert); function Convert (Item : Pragma_Type) return Int; pragma Inline (Convert); function Convert (Item : Int) return Pragma_Type; pragma Inline (Convert); function Convert (Item : Import_Method_Type) return Int; pragma Inline (Convert); function Convert (Item : Int) return Import_Method_Type; pragma Inline (Convert); function Convert (Item : Predefined_Type) return Int; pragma Inline (Convert); function Convert (Item : Int) return Predefined_Type; pragma Inline (Convert); function Convert (Item : Reconnection_Type) return Int; pragma Inline (Convert); function Convert (Item : Int) return Reconnection_Type; pragma Inline (Convert); function Convert (Item : Termination_Type) return Int; pragma Inline (Convert); function Convert (Item : Int) return Termination_Type; pragma Inline (Convert); function Convert (Item : Priority_Policy_Type) return Int; pragma Inline (Convert); function Convert (Item : Int) return Priority_Policy_Type; pragma Inline (Convert); function Convert (Item : ORB_Tasking_Policy_Type) return Int; pragma Inline (Convert); function Convert (Item : Int) return ORB_Tasking_Policy_Type; pragma Inline (Convert); function Convert (Item : Name_Server_Type) return Int; pragma Inline (Convert); function Convert (Item : Int) return Name_Server_Type; pragma Inline (Convert); end XE; polyorb-2.8~20110207.orig/compilers/gnatdist/xe_defs.adb0000644000175000017500000000646611750740337022323 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- X E _ D E F S -- -- -- -- B o d y -- -- -- -- Copyright (C) 1995-2008, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with GNAT.OS_Lib; use GNAT.OS_Lib; with XE_Utils; use XE_Utils; with XE_Defs.Defaults; package body XE_Defs is PCS_Name : String_Access := new String'(Defaults.Default_PCS_Name); function Get_Def_Protocol_Data return String is begin return Defaults.Default_Protocol_Data; end Get_Def_Protocol_Data; function Get_Def_Protocol_Name return String is begin return Defaults.Default_Protocol_Name; end Get_Def_Protocol_Name; function Get_Def_Storage_Data return String is begin return Defaults.Default_Storage_Data; end Get_Def_Storage_Data; function Get_Def_Storage_Name return String is begin return Defaults.Default_Storage_Name; end Get_Def_Storage_Name; function Get_PCS_Name return String is begin return PCS_Name.all; end Get_PCS_Name; function Get_Rsh_Command return String is begin return Defaults.Default_RSH_Command; end Get_Rsh_Command; function Get_Rsh_Options return String is begin return Defaults.Default_RSH_Options; end Get_Rsh_Options; procedure Initialize is begin Scan_Dist_Args (Defaults.Default_Dist_Flags); end Initialize; procedure Set_PCS_Name (S : String) is begin Free (PCS_Name); PCS_Name := new String'(S); end Set_PCS_Name; end XE_Defs; polyorb-2.8~20110207.orig/compilers/gnatdist/xe_flags.ads0000644000175000017500000001237311750740337022511 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- X E _ F L A G S -- -- -- -- S p e c -- -- -- -- Copyright (C) 1995-2009, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- This package contains the flags available for GNATDIST as well as -- those used by GNATDIST and passed to GNATMAKE and GNATLS. with GNAT.Table; with GNAT.OS_Lib; use GNAT.OS_Lib; with XE_Defs.Defaults; package XE_Flags is Quiet_Mode : Boolean := False; Verbose_Mode : Boolean := False; Debug_Mode : Boolean := False; Check_Readonly_Files : Boolean := False; Keep_Going : Boolean := False; Keep_Tmp_Files : Boolean := False; -- Do not remove temporary files User_Provided_S_RPC : Boolean := False; -- User provided his own version of s-rpc.adb, overriding the one from the -- PCS. Use_PolyORB_Project : Boolean := XE_Defs.Defaults.Windows_On_Host; -- True when the installed project file must be used to reference the -- PolyORB PCS (otherwise the external script polyorb-config is used, -- exception on Windows where the MinGW environment does not support -- spawning arbitrary shell scripts). Use_GPRBuild : Boolean := False; -- Use GPRBuild instead of gnatmake Display_Compilation_Progress : Boolean := False; Readonly_Flag : constant String_Access := new String'("-a"); Bind_Only_Flag : constant String_Access := new String'("-b"); Compile_Only_Flag : constant String_Access := new String'("-c"); Object_Dir_Flag : constant String_Access := new String'("-D"); Progress_Flag : constant String_Access := new String'("-d"); Keep_Going_Flag : constant String_Access := new String'("-k"); Link_Only_Flag : constant String_Access := new String'("-l"); Output_Flag : constant String_Access := new String'("-o"); Project_File_Flag : constant String_Access := new String'("-P"); Quiet_Flag : constant String_Access := new String'("-q"); Verbose_Flag : constant String_Access := new String'("-v"); GLADE_List_Flag : constant String_Access := new String'("-V"); External_Units_Flag : constant String_Access := new String'("-x"); Semantic_Only_Flag : constant String_Access := new String'("-gnatc"); Skel_Flag : constant String_Access := new String'("-gnatzr"); Stub_Flag : constant String_Access := new String'("-gnatzc"); Comp_Args_Flag : constant String_Access := new String'("-cargs"); Bind_Args_Flag : constant String_Access := new String'("-bargs"); Link_Args_Flag : constant String_Access := new String'("-largs"); Make_Args_Flag : constant String_Access := new String'("-margs"); Project_File_Name : String_Access; package Make_Switches is new GNAT.Table ( Table_Component_Type => String_Access, Table_Index_Type => Integer, Table_Low_Bound => 1, Table_Initial => 20, Table_Increment => 100); package List_Switches is new GNAT.Table ( Table_Component_Type => String_Access, Table_Index_Type => Integer, Table_Low_Bound => 1, Table_Initial => 20, Table_Increment => 100); package Source_Directories is new GNAT.Table ( Table_Component_Type => String_Access, Table_Index_Type => Integer, Table_Low_Bound => 1, Table_Initial => 20, Table_Increment => 100); end XE_Flags; polyorb-2.8~20110207.orig/compilers/gnatdist/xe_main.ads0000644000175000017500000000410611750740337022334 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- X E _ M A I N -- -- -- -- S p e c -- -- -- -- Copyright (C) 1995-2008, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- This is the main procedure of GNATDIST procedure XE_Main; polyorb-2.8~20110207.orig/compilers/gnatdist/xe_reg.ads0000644000175000017500000000467111750740337022174 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- X E _ R E G -- -- -- -- S p e c -- -- -- -- Copyright (C) 1995-2008, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with GNAT.OS_Lib; use GNAT.OS_Lib; package XE_Reg is function Get_GARLIC_Dir return String_Access; -- look in the registry for the GNAT/GARLIC installation directory. -- The key to be read is -- "HKEY_LOCAL_MACHINE\SOFTWARE\Free Software Foundation\GNAT\" -- If the key value can't be retrieved (key does not exist, error opening -- it, can't fetch value...) Get_GARLIC_Dir return null. end XE_Reg; polyorb-2.8~20110207.orig/compilers/gnatdist/xe_utils.ads0000644000175000017500000002120011750740337022542 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- X E _ U T I L S -- -- -- -- S p e c -- -- -- -- Copyright (C) 1995-2009, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- This package provides several global variables, routines and -- exceptions of general use. with GNAT.OS_Lib; use GNAT.OS_Lib; pragma Elaborate_All (GNAT.OS_Lib); with XE_Types; use XE_Types; package XE_Utils is ---------------------- -- Global Variables -- ---------------------- Root : constant String := "dsa"; Cfg_Suffix : constant String := ".cfg"; Obj_Suffix : constant String := Get_Object_Suffix.all; Exe_Suffix : constant String := Get_Executable_Suffix.all; ALI_Suffix : constant String := ".ali"; ADB_Suffix : constant String := ".adb"; ADS_Suffix : constant String := ".ads"; Cfg_Suffix_Id : File_Name_Type; Obj_Suffix_Id : File_Name_Type; Exe_Suffix_Id : File_Name_Type; ALI_Suffix_Id : File_Name_Type; ADB_Suffix_Id : File_Name_Type; ADS_Suffix_Id : File_Name_Type; Stub_Dir_Name : File_Name_Type; Part_Dir_Name : File_Name_Type; PWD_Id : File_Name_Type; Stub_Dir : String_Access; A_Stub_Dir : String_Access; E_Current_Dir : String_Access; I_Current_Dir : String_Access; -- Monolithic application main subprogram (set by Set_Application_Names) Monolithic_App_Unit_Name : File_Name_Type; Monolithic_Src_Base_Name : File_Name_Type; Monolithic_Src_Name : File_Name_Type; Monolithic_ALI_Name : File_Name_Type; Monolithic_Obj_Name : File_Name_Type; Monolithic_Obj_Dir : File_Name_Type; -- Object dir for the monolithic application -- Project file for the complete application (set by Set_Application_Names) Dist_App_Project : Name_Id; Dist_App_Project_File : File_Name_Type; PCS_Project : Name_Id; PCS_Project_File : File_Name_Type; -- Project file for the PCS Part_Main_Src_Name : File_Name_Type; Part_Main_ALI_Name : File_Name_Type; Part_Main_Obj_Name : File_Name_Type; -- Partition main subprogram Part_Prj_File_Name : File_Name_Type; -- Partition project file Overridden_PCS_Units : File_Name_Type; -- Per-partition list of PCS units that are overridden by the partition No_Args : constant Argument_List (1 .. 0) := (others => null); procedure Initialize; -- Perform global initialization of this unit ------------------------------ -- String and Name Handling -- ------------------------------ function Id (S : String) return Name_Id; -- Add S into name table and return id. function Quote (N : Name_Id) return Name_Id; -- Make a string containing N and return it as a Name_Id. function "&" (L : Name_Id; R : Name_Id) return Name_Id; function "&" (L : Name_Id; R : String) return Name_Id; function No (N : Name_Id) return Boolean; function Present (N : Name_Id) return Boolean; procedure Capitalize (S : in out String); function Capitalize (N : Name_Id) return Name_Id; function Capitalize (S : String) return String; -- Capitalize string or name id procedure To_Lower (S : in out String); procedure To_Lower (N : in out Name_Id); function To_Lower (N : Name_Id) return Name_Id; function Name (N : Name_Id) return Name_Id; -- Remove any encoded info from unit name (%s or %b) procedure Set_Corresponding_Project_File_Name (N : out File_Name_Type); -- Assuming the Name_Buffer contains a project name, set N to the name of -- the corrsponding project file. Assumes that the project name is already -- all lowercase. ------------------------------------ -- Command Line Argument Handling -- ------------------------------------ procedure Scan_Dist_Arg (Argv : String; Implicit : Boolean := True); -- Process one command line argument. -- Implicit is set True for additional flags generated internally by -- gnatdist. procedure Scan_Dist_Args (Args : String); -- Split Args into a list of arguments according to usual shell splitting -- semantics, and process each argument using Scan_Dist_Arg as implicit -- arguments. function More_Source_Files return Boolean; function Next_Main_Source return Name_Id; function Number_Of_Files return Natural; procedure Show_Dist_Args; -- Output processed command line switches (for debugging purposes) procedure Set_Application_Names (Configuration_Name : Name_Id); -- Set the name of the monolithic application main subprogram and of the -- distributed application project based on the configuration name. -- Called once the configuration has been parsed. -------------------- -- Error Handling -- -------------------- Fatal_Error : exception; -- Operating system error Scanning_Error : exception; -- Error during scanning Parsing_Error : exception; -- Error during parsing Matching_Error : exception; -- Error on overloading Partitioning_Error : exception; -- Error during partitionning Compilation_Error : exception; -- Error during compilation Usage_Error : exception; -- Command line error Not_Yet_Implemented : exception; -- Note: Compilation_Error may be raised only when a previous build command -- has already emitted an error message. Gnatdist itself will silently -- exist (with an error status) in that case, and won't produce any -- further error message. type Exit_Code_Type is (E_Success, -- No warnings or errors E_Fatal); -- Fatal (serious) error procedure Exit_Program (Code : Exit_Code_Type); -- Clean up temporary files and exit with appropriate return code procedure Write_Missing_File (Fname : File_Name_Type); -- Output an informational message to indicate that Fname is missing procedure Write_Warnings_Pragmas; -- Generate pragmas to turn off warnings and style checks ----------------------- -- Command Handling -- ----------------------- type File_Name_List is array (Natural range <>) of File_Name_Type; procedure Execute (Command : String_Access; Arguments : Argument_List; Success : out Boolean); procedure Build (Library : File_Name_Type; Arguments : Argument_List; Fatal : Boolean := True; Progress : Boolean := False); -- Execute gnat make and add gnatdist link flags procedure Compile (Source : File_Name_Type; Arguments : Argument_List; Fatal : Boolean := True); -- Execute gnat compile and add gnatdist gcc flags procedure List (Sources : File_Name_List; Arguments : Argument_List; Output : out File_Name_Type; Fatal : Boolean := True); -- List source info into Output and raise Fatal Error if not -- successful. The user has to close Output afterwards. end XE_Utils; polyorb-2.8~20110207.orig/compilers/gnatdist/xe_list.ads0000644000175000017500000000643411750740337022371 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- X E _ L I S T -- -- -- -- S p e c -- -- -- -- Copyright (C) 1995-2008, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- This package contains all the routines to parse the GNATLS outputs -- and to load the ALI files. with XE_Types; use XE_Types; package XE_List is procedure Register_Unit_To_Load (Uname : Unit_Name_Type); procedure Load_All_Registered_Units; -- All unit names and file names are entered into the Names -- table. The Info and Byte fields of these entries are used as -- follows: -- -- Unit name Info field has Unit_Id -- Byte fiels has Partition_Id (*) -- Conf. unit name Info field has ALI_Id -- Byte fiels has Partition_Id (*) -- ALI file name Info field has ALI_Id -- Source file name Info field has ALI_Id -- -- (*) A (normal, RT) unit may be assigned to several partitions. -- We want to detect whether these configured units are real -- ada units. Set the configured unit name to No_ALI_Id. When -- we load an ali file, its unit name is set to its ali id. If -- a configured unit name has no ali id, it is not an Ada unit. -- Assign byte field of configured unit name to No_Partition_Id -- in order to detect units that are multiply assigned. procedure Initialize; end XE_List; polyorb-2.8~20110207.orig/compilers/gnatdist/xe_scan.adb0000644000175000017500000003620011750740337022313 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- X E _ S C A N -- -- -- -- B o d y -- -- -- -- Copyright (C) 1995-2009, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with XE_IO; use XE_IO; with XE_Names; use XE_Names; with XE_Utils; use XE_Utils; package body XE_Scan is Location : Location_Type; Buffer : Text_Buffer_Ptr; Scan_Ptr : Text_Ptr; procedure New_Line; -- Update SLOC ------------------------ -- Get_Token_Location -- ------------------------ function Get_Token_Location return Location_Type is begin return Location; end Get_Token_Location; ---------------- -- Initialize -- ---------------- procedure Initialize is begin Set_Token ("configuration", Tok_Configuration); Set_Token ("pragma", Tok_Pragma); Set_Token ("procedure", Tok_Procedure); Set_Token ("is", Tok_Is); Set_Token ("in", Tok_In); Set_Token ("for", Tok_For); Set_Token ("use", Tok_Use); Set_Token ("function", Tok_Function); Set_Token ("end", Tok_End); Set_Token ("begin", Tok_Begin); Set_Token ("null", Tok_Null); Set_Token ("return", Tok_Return); Set_Token ("mod", Tok_Reserved); Set_Token ("rem", Tok_Reserved); Set_Token ("new", Tok_Reserved); Set_Token ("abs", Tok_Reserved); Set_Token ("others", Tok_Reserved); Set_Token ("delta", Tok_Reserved); Set_Token ("digits", Tok_Reserved); Set_Token ("range", Tok_Reserved); Set_Token ("and", Tok_Reserved); Set_Token ("or", Tok_Reserved); Set_Token ("not", Tok_Reserved); Set_Token ("abstract", Tok_Reserved); Set_Token ("access", Tok_Reserved); Set_Token ("aliased", Tok_Reserved); Set_Token ("all", Tok_Reserved); Set_Token ("array", Tok_Reserved); Set_Token ("body", Tok_Reserved); Set_Token ("constant", Tok_Reserved); Set_Token ("do", Tok_Reserved); Set_Token ("limited", Tok_Reserved); Set_Token ("of", Tok_Reserved); Set_Token ("out", Tok_Reserved); Set_Token ("record", Tok_Reserved); Set_Token ("renames", Tok_Reserved); Set_Token ("reverse", Tok_Reserved); Set_Token ("tagged", Tok_Reserved); Set_Token ("then", Tok_Reserved); Set_Token ("reverse", Tok_Reserved); Set_Token ("abort", Tok_Reserved); Set_Token ("accept", Tok_Reserved); Set_Token ("case", Tok_Reserved); Set_Token ("delay", Tok_Reserved); Set_Token ("else", Tok_Reserved); Set_Token ("elsif", Tok_Reserved); Set_Token ("exception", Tok_Reserved); Set_Token ("exit", Tok_Reserved); Set_Token ("goto", Tok_Reserved); Set_Token ("if", Tok_Reserved); Set_Token ("raise", Tok_Reserved); Set_Token ("requeue", Tok_Reserved); Set_Token ("select", Tok_Reserved); Set_Token ("terminate", Tok_Reserved); Set_Token ("until", Tok_Reserved); Set_Token ("when", Tok_Reserved); Set_Token ("declare", Tok_Reserved); Set_Token ("loop", Tok_Reserved); Set_Token ("while", Tok_Reserved); Set_Token ("entry", Tok_Reserved); Set_Token ("protected", Tok_Reserved); Set_Token ("task", Tok_Reserved); Set_Token ("type", Tok_Reserved); Set_Token ("subtype", Tok_Reserved); Set_Token ("generic", Tok_Reserved); Set_Token ("package", Tok_Reserved); Set_Token ("private", Tok_Reserved); Set_Token ("with", Tok_Reserved); Set_Token ("separate", Tok_Reserved); end Initialize; --------------- -- Load_File -- --------------- procedure Load_File (File : File_Name_Type) is First, Last : Text_Ptr; begin Read_File (File, First, Last, Buffer); if Buffer = null then raise Fatal_Error with "cannot open file " & Get_Name_String (File); end if; Scan_Ptr := First; Location.Line := 1; Location.First := Scan_Ptr; Location.Last := Scan_Ptr; end Load_File; -------------------- -- Location_To_XY -- -------------------- procedure Location_To_XY (Where : Location_Type; Loc_X : out Int; Loc_Y : out Int) is begin Loc_X := Where.Line; Loc_Y := Int (Where.Last - Where.First) + 1; end Location_To_XY; -------------- -- New_Line -- -------------- procedure New_Line is begin Scan_Ptr := Scan_Ptr + 1; Location.Line := Location.Line + 1; Location.First := Scan_Ptr; Location.Last := Scan_Ptr; end New_Line; ---------------- -- Next_Token -- ---------------- procedure Next_Token is use ASCII; Char : Character; Found : Boolean := False; begin while not Found loop -- Skip blank and tab characters while Buffer (Scan_Ptr) = ' ' or else Buffer (Scan_Ptr) = HT loop Scan_Ptr := Scan_Ptr + 1; end loop; -- First non-blank character Location.Last := Scan_Ptr; Found := True; case Buffer (Scan_Ptr) is when LF | FF | CR | VT => New_Line; Found := False; when '-' => if Buffer (Scan_Ptr + 1) = '-' then -- Comment Scan_Ptr := Scan_Ptr + 2; loop if Buffer (Scan_Ptr) = LF or else Buffer (Scan_Ptr) = FF or else Buffer (Scan_Ptr) = CR or else Buffer (Scan_Ptr) = VT then New_Line; exit; elsif Buffer (Scan_Ptr) = EOF then Token := Tok_EOF; Scan_Ptr := Scan_Ptr + 1; exit; end if; Scan_Ptr := Scan_Ptr + 1; end loop; if Token = Tok_EOF then Found := True; else Found := False; end if; else Token := Tok_Unknown; end if; when '"' => -- " Token := Tok_String_Literal; Name_Len := 0; Scan_Ptr := Scan_Ptr + 1; loop if Buffer (Scan_Ptr) = '"' then -- " -- end of string literal Scan_Ptr := Scan_Ptr + 1; exit when Buffer (Scan_Ptr) /= '"'; -- " elsif Buffer (Scan_Ptr) = EOF then Token := Tok_Unknown; exit; end if; Name_Len := Name_Len + 1; Name_Buffer (Name_Len) := Buffer (Scan_Ptr); Scan_Ptr := Scan_Ptr + 1; end loop; if Token = Tok_String_Literal then Token_Name := Name_Find; end if; when 'A' .. 'Z' | 'a' .. 'z' => -- Identifier Name_Len := 0; loop Char := Buffer (Scan_Ptr); case Char is when 'A' .. 'Z' | 'a' .. 'z' | '0' .. '9' | '_' => null; when others => exit; end case; Name_Len := Name_Len + 1; Name_Buffer (Name_Len) := Char; Scan_Ptr := Scan_Ptr + 1; end loop; if Name_Len = 0 then Token := Tok_Unknown; else To_Lower (Name_Buffer (1 .. Name_Len)); Token := Tok_Identifier; Token_Name := Name_Find; end if; when ':' => Scan_Ptr := Scan_Ptr + 1; if Buffer (Scan_Ptr) = '=' then Scan_Ptr := Scan_Ptr + 1; Token := Tok_Colon_Equal; else Token := Tok_Colon; end if; when '.' => Scan_Ptr := Scan_Ptr + 1; Token := Tok_Dot; when '(' => Scan_Ptr := Scan_Ptr + 1; Token := Tok_Left_Paren; when ')' => Scan_Ptr := Scan_Ptr + 1; Token := Tok_Right_Paren; when ',' => Scan_Ptr := Scan_Ptr + 1; Token := Tok_Comma; when ';' => Scan_Ptr := Scan_Ptr + 1; Token := Tok_Semicolon; when ''' => Scan_Ptr := Scan_Ptr + 1; Token := Tok_Apostrophe; when EOF => Token := Tok_EOF; when '=' => if Buffer (Scan_Ptr + 1) = '>' then Scan_Ptr := Scan_Ptr + 2; Token := Tok_Arrow; else Token := Tok_Unknown; end if; when '0' .. '9' => Name_Len := 0; Char := Buffer (Scan_Ptr); while Char in '0' .. '9' loop Name_Len := Name_Len + 1; Name_Buffer (Name_Len) := Char; Scan_Ptr := Scan_Ptr + 1; Char := Buffer (Scan_Ptr); end loop; Token := Tok_Numeric_Literal; Token_Name := Name_Find; when others => Token := Tok_Unknown; end case; end loop; if Token = Tok_Identifier then declare T : Token_Type; begin T := Get_Token (Token_Name); if T = Tok_Reserved then Write_Location (Location); Write_Str ("reserved word """); Write_Name (Token_Name); Write_Str (""" cannot be used as identifier"); Write_Eol; raise Scanning_Error; elsif T /= Tok_Unknown then Token := T; end if; end; elsif Token = Tok_Unknown then Write_Location (Location); Write_Str ("character '"); Write_Char (Buffer (Scan_Ptr)); Write_Str ("' not allowed ("); Write_Int (Character'Pos (Buffer (Scan_Ptr))); Write_Str (")"); Write_Eol; raise Scanning_Error; end if; end Next_Token; ------------------------ -- Set_Token_Location -- ------------------------ procedure Set_Token_Location (Where : Location_Type) is begin Location := Where; Scan_Ptr := Where.Last; end Set_Token_Location; -------------------- -- Write_Location -- -------------------- procedure Write_Location (Where : Location_Type) is use ASCII; begin Write_Name (Configuration_File_Name); Write_Str (":"); Write_Int (Where.Line); Write_Str (":"); Write_Int (Int (Where.Last - Where.First) + 1); Write_Str (": "); end Write_Location; ----------------- -- Write_Token -- ----------------- procedure Write_Token (T : Token_Type) is begin case T is when Tok_String_Literal => Write_Str ("string literal"); when Tok_Numeric_Literal => Write_Str ("numeric literal"); when Tok_Identifier => Write_Str ("identifier"); when Tok_Dot => Write_Str ("""."""); when Tok_Apostrophe => Write_Str ("""'"""); when Tok_Left_Paren => Write_Str ("""("""); when Tok_Right_Paren => Write_Str (""")"""); when Tok_Comma => Write_Str (""","""); when Tok_Colon_Equal => Write_Str (""":="""); when Tok_Colon => Write_Str (""":"""); when Tok_Configuration => Write_Str ("""configuration"""); when Tok_Pragma => Write_Str ("""pragma"""); when Tok_Procedure => Write_Str ("""procedure"""); when Tok_Is => Write_Str ("""is"""); when Tok_In => Write_Str ("""in"""); when Tok_For => Write_Str ("""for"""); when Tok_Use => Write_Str ("""use"""); when Tok_Null => Write_Str ("""null"""); when Tok_Function => Write_Str ("""function"""); when Tok_End => Write_Str ("""end"""); when Tok_Begin => Write_Str ("""begin"""); when Tok_Arrow => Write_Str ("""=>"""); when Tok_EOF => Write_Str ("end of file"); when Tok_Semicolon => Write_Str (""";"""); when Tok_Return => Write_Str ("""return"""); when Tok_Unknown => Write_Str (""); when Tok_Reserved => raise Scanning_Error; end case; end Write_Token; end XE_Scan; polyorb-2.8~20110207.orig/compilers/gnatdist/xe_back-polyorb.adb0000644000175000017500000013125611750740337023762 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- X E _ B A C K . P O L Y O R B -- -- -- -- B o d y -- -- -- -- Copyright (C) 1995-2011, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with Ada.Characters.Handling; with GNAT.Directory_Operations; use GNAT.Directory_Operations; with GNAT.Expect; use GNAT.Expect; with GNAT.OS_Lib; use GNAT.OS_Lib; with XE; use XE; with XE_Front; use XE_Front; with XE_Flags; use XE_Flags; with XE_IO; use XE_IO; with XE_Names; use XE_Names; with XE_Utils; use XE_Utils; with XE_Storages; use XE_Storages; with XE_Back; pragma Elaborate_All (XE_Back); package body XE_Back.PolyORB is type PolyORB_Backend is new Backend with null record; procedure Set_PCS_Dist_Flags (Self : access PolyORB_Backend); procedure Initialize (Self : access PolyORB_Backend); procedure Register_Storages (Self : access PolyORB_Backend); procedure Run_Backend (Self : access PolyORB_Backend); function Get_Detach_Flag (Self : access PolyORB_Backend) return Name_Id; Elaboration_File : File_Name_Type; -- Partition elaboration unit Storage_Config_File : File_Name_Type; -- Shared storage configuration unit type RU_Id is (RU_PolyORB, RU_PolyORB_Binding_Data, RU_PolyORB_Binding_Data_GIOP, RU_PolyORB_Binding_Data_GIOP_IIOP, RU_PolyORB_Binding_Data_DNS, RU_PolyORB_Binding_Data_DNS_MDNS, RU_PolyORB_Protocols, RU_PolyORB_Protocols_DNS, RU_PolyORB_Initialization, RU_PolyORB_ORB_Controller, RU_PolyORB_ORB_Controller_Workers, RU_PolyORB_ORB, RU_PolyORB_ORB_No_Tasking, RU_PolyORB_DSA_P, RU_PolyORB_DSA_P_Name_Server, RU_PolyORB_DSA_P_Name_Service, RU_PolyORB_DSA_P_Name_Service_mDNS, RU_PolyORB_DSA_P_Remote_Launch, RU_PolyORB_DSA_P_Storages, RU_PolyORB_DSA_P_Storages_Config, RU_PolyORB_Parameters, RU_PolyORB_Partition_Elaboration, RU_PolyORB_Setup, RU_PolyORB_Setup_Access_Points, RU_PolyORB_Setup_Access_Points_IIOP, RU_PolyORB_Setup_Access_Points_MDNS, RU_PolyORB_Setup_Base, RU_PolyORB_Setup_IIOP, RU_PolyORB_Setup_OA, RU_PolyORB_Setup_OA_Basic_POA, RU_PolyORB_Setup_Tasking, RU_PolyORB_Setup_Tasking_Full_Tasking, RU_PolyORB_Setup_Tasking_No_Tasking, RU_PolyORB_Tasking, RU_PolyORB_Tasking_Threads, RU_PolyORB_Utils, RU_PolyORB_Utils_Strings, RU_PolyORB_Utils_Strings_Lists, RU_System, RU_System_DSA_Services, RU_System_Partition_Interface, RU_System_RPC, RU_System_RPC_Server, RU_Tasking); RU : array (RU_Id) of Unit_Name_Type; type RE_Id is (RE_Check, RE_Launch_Partition, RE_Run, RE_Run_In_Task, RE_Shutdown_World, RE_The_ORB, RE_Set_Default_Servant, RE_Get_MDNS_Servant); RE : array (RE_Id) of Unit_Name_Type; RE_Unit_Table : constant array (RE_Id) of RU_Id := (RE_Check => RU_System_Partition_Interface, RE_Launch_Partition => RU_PolyORB_DSA_P_Remote_Launch, RE_Run => RU_PolyORB_ORB, RE_Run_In_Task => RU_PolyORB_Tasking_Threads, RE_Shutdown_World => RU_PolyORB_Initialization, RE_The_ORB => RU_PolyORB_Setup, RE_Set_Default_Servant => RU_PolyORB_Protocols_DNS, RE_Get_MDNS_Servant => RU_PolyORB_DSA_P_Name_Service_mDNS); --------------------- -- Parameter types -- --------------------- type PS_Id is (PS_Tasking, PS_DSA); PS : array (PS_Id) of Unit_Name_Type; type PE_Id is (PE_Start_Threads, PE_Max_Spare_Threads, PE_Max_Threads, PE_Min_Spare_Threads, PE_Rsh_Command, PE_Rsh_Options, PE_Boot_Location, PE_Self_Location, PE_Tasking_Available, PE_Termination_Initiator, PE_Termination_Policy, PE_Partition_Name, PE_Name_Context); PE : array (PE_Id) of Unit_Name_Type; PE_Section_Table : constant array (PE_Id) of PS_Id := (PE_Rsh_Command => PS_DSA, PE_Rsh_Options => PS_DSA, PE_Boot_Location => PS_DSA, PE_Self_Location => PS_DSA, PE_Tasking_Available => PS_DSA, PE_Termination_Initiator => PS_DSA, PE_Termination_Policy => PS_DSA, PE_Partition_Name => PS_DSA, PE_Name_Context => PS_DSA, PE_Start_Threads => PS_Tasking, PE_Max_Spare_Threads => PS_Tasking, PE_Max_Threads => PS_Tasking, PE_Min_Spare_Threads => PS_Tasking); ----------------------------- -- Parameter table entries -- ----------------------------- type Parameter_Entry is record Section : Name_Id; Key : Name_Id; Value : Name_Id; end record; Table : array (0 .. 31) of Parameter_Entry; Last : Integer := -1; --------------------------- -- Generation Procedures -- --------------------------- procedure Generate_Ada_Starter_Code; -- Generates Ada calls for starting the remote partitions procedure Generate_Elaboration_File (P : Partition_Id); -- Create the elaboration unit for the given partition. This unit -- overloads the default PCS settings. procedure Generate_Executable_File (P : Partition_Id); -- Compile main partition file, storages configuration file and -- elaboration file. Bind and link partition to create executable. procedure Generate_Parameters_Source (P : Partition_Id); -- Create fragment of elaboration file that declares and registers a -- runtime parameters source for the given partition. Must be called last -- thing in Generate_Elaboration_File (creates elaboration statements for -- the package). procedure Generate_Partition_Main_File (P : Partition_Id); -- Create a procedure which "withes" all the RCI or SP receivers -- of the partition and insert the main procedure if needed. procedure Generate_Storage_Config_File (P : Partition_Id); -- Create storage configuration file that includes the storages -- required in the configuration file for this partition. procedure Generate_PCS_Project_Files; -- Generate project files to access the PCS function Strip (S : String; To_Lower : Boolean := False) return Unit_Name_Type; -- Return the prefix and a possible suffix from S. If To_Lower is set, -- convert to lowercase, else apply general casing rules. procedure Set_Conf (Var : PE_Id; Val : Name_Id; Quote : Boolean := True); -- Add a new entry in the configuration table procedure Set_Conf (Section : Name_Id; Key : Name_Id; Val : Name_Id; Quote : Boolean); -- Add a new entry in the configuration table procedure Reset_Conf; -- Clear the configuration table -- Installation information DSA_Inc_Rel_Dir : constant String := "include" & Dir_Separator & "polyorb"; -- PolyORB include directory, relative to the installation prefix PolyORB_Prefix : constant String := XE_Back.Prefix (Check_For => DSA_Inc_Rel_Dir & Dir_Separator & "polyorb.ads"); ------------------------------- -- Generate_Ada_Starter_Code -- ------------------------------- procedure Generate_Ada_Starter_Code is Remote_Host : Name_Id; begin for J in Partitions.First + 1 .. Partitions.Last loop if J /= Main_Partition and then Partitions.Table (J).Passive /= BTrue then declare Partition : Partition_Type renames Partitions.Table (J); Full_Cmd : constant String := Get_Name_String (Quote (To_Absolute_File (Partition.Executable_File) & Partition.Command_Line)); Env : constant String := Get_Env_Vars (J, Names_Only => True); begin Write_Image (Remote_Host, Partition.Host, J); if not Present (Remote_Host) then Remote_Host := Id ("""localhost"""); end if; Write_Call (RU (RE_Unit_Table (RE_Launch_Partition)) and RE (RE_Launch_Partition), Remote_Host, Full_Cmd, Quote (Id (Env))); end; end if; end loop; end Generate_Ada_Starter_Code; ------------------------------- -- Generate_Elaboration_File -- ------------------------------- procedure Generate_Elaboration_File (P : Partition_Id) is Filename : File_Name_Type; File : File_Descriptor; Current : Partition_Type renames Partitions.Table (P); begin Filename := Elaboration_File & ADB_Suffix_Id; Filename := Dir (Current.Partition_Dir, Filename); Create_File (File, Filename); Set_Output (File); Write_Warnings_Pragmas; Write_Line ("pragma Ada_2005;"); -- First drag platform the specific base setup Write_With_Clause (RU (RU_PolyORB_Setup_Base), False, True); -- Remote_Launch is only needed when using the Ada Starter, -- we avoid "withing" it otherwise since it drags sockets. if P = Main_Partition then if Default_Starter = Ada_Import then Write_With_Clause (RU (RU_PolyORB_DSA_P_Remote_Launch)); end if; if Default_Name_Server = Embedded then Write_With_Clause (RU (RU_PolyORB_DSA_P_Name_Server)); end if; end if; Write_With_Clause (RU (RU_PolyORB_Setup_IIOP), False, True); if Current.Tasking = No_Tasking then Write_With_Clause (RU (RU_PolyORB_Setup_Tasking_No_Tasking)); Write_With_Clause (RU (RU_PolyORB_ORB_No_Tasking)); Write_With_Clause (RU (RU_PolyORB_Binding_Data_GIOP_IIOP)); if Default_Name_Server = Multicast then Write_With_Clause (RU (RU_PolyORB_Binding_Data_DNS_MDNS)); end if; else Write_With_Clause (RU (RU_PolyORB_Setup_Tasking_Full_Tasking)); if Current.Tasking = User_Tasking then Write_With_Clause (RU (RU_PolyORB_ORB) and ORB_Tasking_Policy_Img (Thread_Pool)); Write_With_Clause (RU (RU_PolyORB_Binding_Data_GIOP_IIOP)); if Default_Name_Server = Multicast then Write_With_Clause (RU (RU_PolyORB_Binding_Data_DNS_MDNS)); end if; else Write_With_Clause (RU (RU_PolyORB_ORB) and ORB_Tasking_Policy_Img (Current.ORB_Tasking_Policy)); Write_With_Clause (RU (RU_PolyORB_Setup_Access_Points_IIOP)); if Default_Name_Server = Multicast then Write_With_Clause (RU (RU_PolyORB_Setup_Access_Points_MDNS)); end if; end if; end if; -- Dependencies related to the partition specific parameters source Write_With_Clause (RU (RU_PolyORB_Parameters), U => True); Write_With_Clause (RU (RU_PolyORB_Initialization), True, True); Write_With_Clause (RU (RU_PolyORB_Utils), True); Write_With_Clause (RU (RU_PolyORB_Utils_Strings), True); Write_With_Clause (RU (RU_PolyORB_Utils_Strings_Lists), True); Write_With_Clause (RU (RU_PolyORB_Utils_Strings_Lists), True); Write_With_Clause (RU (RU_PolyORB_Tasking_Threads), True); Write_Str ("package body "); Write_Name (RU (RU_PolyORB_Partition_Elaboration)); Write_Line (" is"); Increment_Indentation; Write_Indentation; -- Launch remote partitions if needed Write_Line ("procedure Full_Launch is"); Write_Indentation; Write_Line ("begin"); Increment_Indentation; if P = Main_Partition and then Default_Starter = Ada_Import then Generate_Ada_Starter_Code; end if; -- Write a null statement, so that partitions which have -- an empty Full_Launch can still compile. Write_Indentation; Write_Line ("null;"); Decrement_Indentation; Write_Indentation; Write_Line ("end Full_Launch;"); -- Run additional tasks if needed. -- Only Thread_Per_Request and Thread_Per_Session policies -- need an additional ORB task, as there is no task dedicated -- to process incoming requests. if Current.Tasking = PCS_Tasking and then Current.ORB_Tasking_Policy /= Thread_Pool then -- Generate a wrapper procedure that allow to give a -- parameterless procedure access to Run_In_task call. Write_Indentation; Write_Line ("procedure Run_In_Task_Wrapper is"); Write_Indentation; Write_Line ("begin"); Increment_Indentation; Write_Call (RU (RE_Unit_Table (RE_Run)) and RE (RE_Run), RU (RE_Unit_Table (RE_The_ORB)) and RE (RE_The_ORB), S1 => "May_Exit => False"); Decrement_Indentation; Write_Indentation; Write_Line ("end Run_In_Task_Wrapper;"); end if; Write_Indentation; Write_Line ("procedure Run_Additional_Tasks is"); if Current.Tasking = PCS_Tasking and then Current.ORB_Tasking_Policy /= Thread_Pool then Increment_Indentation; Write_Indentation; Write_Line ("Thread_Acc : Thread_Access;"); Decrement_Indentation; Write_Indentation; Write_Line ("begin"); Increment_Indentation; Write_Indentation; Write_Str ("Thread_Acc := "); Write_Call (RU (RE_Unit_Table (RE_Run_In_Task)) and RE (RE_Run_In_Task), S1 => "TF => Get_Thread_Factory", S2 => "P => Run_In_Task_Wrapper'Access"); else -- Write a null statement, so that partitions which have -- an empty Run_Additional_Tasks can still compile. Write_Indentation; Write_Line ("begin"); Increment_Indentation; Write_Indentation; Write_Line ("null;"); end if; Decrement_Indentation; Write_Indentation; Write_Line ("end Run_Additional_Tasks;"); Generate_Parameters_Source (P); Decrement_Indentation; Write_Str ("end "); Write_Name (RU (RU_PolyORB_Partition_Elaboration)); Write_Line (";"); Close (File); Set_Standard_Output; end Generate_Elaboration_File; ------------------------------ -- Generate_Executable_File -- ------------------------------ procedure Generate_Executable_File (P : Partition_Id) is Current : Partition_Type renames Partitions.Table (P); Executable : File_Name_Type renames Current.Executable_File; Partition_Dir : Directory_Name_Type renames Current.Partition_Dir; I_Part_Dir : String_Access; Comp_Args : String_List (1 .. 9); Make_Args : String_List (1 .. 10); Last : Positive; Sfile : File_Name_Type; Prj_Fname : File_Name_Type; Length : Natural; begin Set_Str_To_Name_Buffer ("-I"); Get_Name_String_And_Append (Partition_Dir); I_Part_Dir := new String'(Name_Buffer (1 .. Name_Len)); -- Give the priority to partition and stub directory against -- current directory. Comp_Args (1) := E_Current_Dir; Comp_Args (2) := I_Part_Dir; Comp_Args (3) := A_Stub_Dir; Comp_Args (4) := I_Current_Dir; -- If there is no project file, then save ali and object files -- in partition directory. if Project_File_Name = null then Comp_Args (5) := Object_Dir_Flag; Comp_Args (6) := new String'(Get_Name_String (Partition_Dir)); else Comp_Args (5) := Project_File_Flag; Prj_Fname := Dir (Partition_Dir, Part_Prj_File_Name); Comp_Args (6) := new String'(Get_Name_String (Prj_Fname)); end if; Length := 6; -- We already checked the consistency of all the partition -- units. In case of an inconsistency of exception mode, we may -- have to rebuild some parts of polyorb (units configured just -- for this partition). Note that some parts of PolyORB may have -- been already recompiled when the monolithic application was -- initially build. Some bodies may be missing as they are -- assigned to partitions we do not want to build. So compile -- silently and do not exit on errors (keep going). if Project_File_Name = null then Comp_Args (7) := Compile_Only_Flag; Comp_Args (8) := Keep_Going_Flag; Comp_Args (9) := Readonly_Flag; Length := 9; end if; -- Compile elaboration file Sfile := Dir (Partition_Dir, Elaboration_File & ADB_Suffix_Id); Compile (Sfile, Comp_Args (1 .. Length)); -- Compile storage support configuration file Sfile := Dir (Partition_Dir, Storage_Config_File & ADB_Suffix_Id); Compile (Sfile, Comp_Args (1 .. Length)); -- Compile main file Sfile := Dir (Partition_Dir, Partition_Main_File & ADB_Suffix_Id); Compile (Sfile, Comp_Args (1 .. Length)); Free (Comp_Args (6)); -- Now we just want to bind and link as the ALI files are now consistent Make_Args (1) := E_Current_Dir; Make_Args (2) := I_Part_Dir; Make_Args (3) := A_Stub_Dir; Make_Args (4) := I_Current_Dir; Make_Args (5) := Bind_Only_Flag; Make_Args (6) := Link_Only_Flag; Make_Args (7) := Output_Flag; Make_Args (8) := new String'(Get_Name_String (Strip_Directory (Executable))); if Project_File_Name = null then Last := 8; else Make_Args (9) := Project_File_Flag; Prj_Fname := Dir (Partition_Dir, Part_Prj_File_Name); Make_Args (10) := new String'(Get_Name_String (Prj_Fname)); Last := 10; end if; Build (Sfile, Make_Args (1 .. Last), Fatal => True); Free (Make_Args (2)); Free (Make_Args (8)); if Make_Args (10) /= null then Free (Make_Args (10)); end if; end Generate_Executable_File; -------------------------------- -- Generate_Parameters_Source -- -------------------------------- procedure Generate_Parameters_Source (P : Partition_Id) is Current : Partition_Type renames Partitions.Table (P); Section : constant Name_Id := PS (PS_DSA); T : constant Name_Id := Id ("true"); type Attribute_Type is (Local, Reconnection); function Attribute_Name (U : Conf_Unit_Id; A : Attribute_Type) return Name_Id; -- Return U'A function Attribute_Name (U : Conf_Unit_Id; A : Attribute_Type) return Name_Id is begin Get_Name_String (Conf_Units.Table (U).Name); Add_Char_To_Name_Buffer ('''); Add_Str_To_Name_Buffer (Ada.Characters.Handling.To_Lower (A'Img)); return Name_Find; end Attribute_Name; -- Start of processing for Generate_Parameters_Source begin -- Set partition name Set_Conf (PE_Partition_Name, Current.Name); -- Set tasking mode Set_Str_To_Name_Buffer (Boolean'Image (Current.Tasking /= No_Tasking)); Set_Conf (PE_Tasking_Available, Name_Find); -- Add the termination policy to the configuration table, if no -- termination policy is set, the default is Global_Termination. if Current.Termination /= No_Termination then Set_Conf (PE_Termination_Policy, Termination_Img (Current.Termination)); end if; -- Set boot location if Default_First_Boot_Location /= No_Location_Id then Set_Conf (PE_Boot_Location, Location_List_Image (Default_First_Boot_Location), Quote => False); end if; -- Set self location if Current.First_Network_Loc /= No_Location_Id then Set_Conf (PE_Self_Location, Location_List_Image (Current.First_Network_Loc), Quote => False); end if; -- Set task pool parameters if Current.Task_Pool /= No_Task_Pool then Set_Nat_To_Name_Buffer (Current.Task_Pool (1)); declare N : constant Name_Id := Name_Find; -- Min_Spare_Threads, also used for Start_Threads begin Set_Conf (PE_Start_Threads, N); Set_Conf (PE_Min_Spare_Threads, N); end; Set_Nat_To_Name_Buffer (Current.Task_Pool (2)); Set_Conf (PE_Max_Spare_Threads, Name_Find); Set_Nat_To_Name_Buffer (Current.Task_Pool (3)); Set_Conf (PE_Max_Threads, Name_Find); end if; -- Set the rsh parameters Set_Conf (PE_Rsh_Command, Get_Rsh_Command); Set_Conf (PE_Rsh_Options, Get_Rsh_Options); -- For each RCI assigned on this partition add a parameter -- 'local set to True. declare U : Conf_Unit_Id; Key : Name_Id; begin U := Current.First_Unit; while U /= No_Conf_Unit_Id loop if Units.Table (Conf_Units.Table (U).My_Unit).RCI then Key := Attribute_Name (U, Local); Set_Conf (Section, Key, T, Quote => True); end if; U := Conf_Units.Table (U).Next_Unit; end loop; end; -- Set reconnection policies for all RCIs (note: we also set this for -- local RCIs so that we can abort partition elaboration when a stale -- reference is present in the name server and the partition's policy -- is Reject_On_Restart. for Rem_P in Partitions.First .. Partitions.Last loop declare Remote : Partition_Type renames Partitions.Table (Rem_P); U : Conf_Unit_Id; Key : Name_Id; begin if Remote.Reconnection /= No_Reconnection then U := Remote.First_Unit; while U /= No_Conf_Unit_Id loop if Units.Table (Conf_Units.Table (U).My_Unit).RCI then Key := Attribute_Name (U, Reconnection); Set_Conf (Section, Key, Reconnection_Img (Remote.Reconnection), Quote => True); end if; U := Conf_Units.Table (U).Next_Unit; end loop; end if; end; end loop; -- Set the corect Name_Context, depending on the Name_Server if Default_Name_Server = Multicast then Set_Conf (PE_Name_Context, XE_Utils.Id ("MDNS")); else Set_Conf (PE_Name_Context, XE_Utils.Id ("COS")); end if; -- The configuration is done, start generating the code Write_Indentation; Write_Line ("procedure Configure"); Increment_Indentation; Write_Indentation (-1); Write_Line ("(Set_Conf : access procedure (Section, Key, Value : String))"); Decrement_Indentation; Write_Indentation; Write_Line ("is"); Write_Indentation; Write_Line ("begin"); Increment_Indentation; for P in Table'First .. Last loop Write_Indentation; Write_Line ("Set_Conf"); Increment_Indentation; Write_Indentation (-1); Write_Str ("(Section => """); Write_Name (Table (P).Section); Write_Line (""","); Write_Indentation; Write_Str ("Key => """); Write_Name (Table (P).Key); Write_Line (""","); Write_Indentation; Write_Str ("Value => "); Write_Name (Table (P).Value); Write_Line (");"); Decrement_Indentation; end loop; Decrement_Indentation; Write_Indentation; Write_Line ("end Configure;"); end Generate_Parameters_Source; ---------------------------------- -- Generate_Storage_Config_File -- ---------------------------------- procedure Generate_Storage_Config_File (P : Partition_Id) is Filename : File_Name_Type; File : File_Descriptor := Invalid_FD; Current : Partition_Type renames Partitions.Table (P); Major : Name_Id; Required_Storage : Required_Storage_Id; Location : Location_Id; begin Filename := Storage_Config_File & ADB_Suffix_Id; Filename := Dir (Current.Partition_Dir, Filename); Create_File (File, Filename); Set_Output (File); Write_Warnings_Pragmas; -- Import the storage supports used by this partition Required_Storage := Partitions.Table (P).First_Required_Storage; while Required_Storage /= No_Required_Storage_Id loop Location := Required_Storages.Table (Required_Storage).Location; Major := Capitalize (Locations.Table (Location).Major); Major := RU (RU_PolyORB_DSA_P_Storages) and Major; Write_With_Clause (Major, False, True); Required_Storage := Required_Storages.Table (Required_Storage).Next_Storage; end loop; -- Initialize storage supports Write_Str ("package body "); Write_Name (RU (RU_PolyORB_DSA_P_Storages_Config)); Write_Line (" is"); Increment_Indentation; Write_Indentation; Write_Line ("procedure Initialize_Storages is"); Write_Indentation; Write_Line ("begin"); Increment_Indentation; -- Follow the same approach as for package importation Required_Storage := Partitions.Table (P).First_Required_Storage; while Required_Storage /= No_Required_Storage_Id loop Location := Required_Storages.Table (Required_Storage).Location; Major := Capitalize (Locations.Table (Location).Major); Write_Call (RU (RU_PolyORB_DSA_P_Storages) and Capitalize (Major) and "Register_Passive_Package", Quote (Name (Units.Table (Required_Storages.Table (Required_Storage).Unit).Uname)), Boolean'Image (Required_Storages.Table (Required_Storage).Is_Owner), Quote (Locations.Table (Location).Minor)); Required_Storage := Required_Storages.Table (Required_Storage).Next_Storage; end loop; -- Write a null statement, so that partitions which have -- an empty Initialize_Storages can still compile. Write_Indentation; Write_Line ("null;"); Decrement_Indentation; Write_Indentation; Write_Line ("end Initialize_Storages;"); Decrement_Indentation; Write_Eol; Write_Str ("end "); Write_Name (RU (RU_PolyORB_DSA_P_Storages_Config)); Write_Line (";"); Close (File); Set_Standard_Output; end Generate_Storage_Config_File; ---------------------------------- -- Generate_Partition_Main_File -- ---------------------------------- procedure Generate_Partition_Main_File (P : Partition_Id) is Filename : File_Name_Type; File : File_Descriptor; Current : Partition_Type renames Partitions.Table (P); Conf_Unit : Conf_Unit_Id; Unit : Unit_Id; begin Filename := Partition_Main_File & ADB_Suffix_Id; Filename := Dir (Current.Partition_Dir, Filename); Create_File (File, Filename); Set_Output (File); Write_Warnings_Pragmas; Write_With_Clause (RU (RU_PolyORB_ORB)); Write_With_Clause (RU (RU_PolyORB_Initialization)); Write_With_Clause (RU (RU_PolyORB_Setup)); Write_With_Clause (RU (RU_System_Partition_Interface)); Write_With_Clause (RU (RU_System_DSA_Services)); if Default_Name_Server = Multicast then Write_With_Clause (RU (RU_PolyORB_DSA_P_Name_Service_mDNS)); Write_With_Clause (RU (RU_PolyORB_Protocols_DNS)); end if; -- Assign RCI or SP skels on the partition Conf_Unit := Current.First_Unit; while Conf_Unit /= No_Conf_Unit_Id loop Write_With_Clause (Conf_Units.Table (Conf_Unit).Name); Conf_Unit := Conf_Units.Table (Conf_Unit).Next_Unit; end loop; -- Assign the RCI or SP stubs to compare version with skels for J in Current.First_Stub .. Current.Last_Stub loop Write_With_Clause (Stubs.Table (J)); end loop; Write_Str ("procedure "); Write_Name (Partition_Main_Name); Write_Line (" is"); Write_Line ("begin"); Increment_Indentation; -- If Name_Server is Multicast, set the default mDNS servant if Default_Name_Server = Multicast then Write_Call (RU (RE_Unit_Table (RE_Set_Default_Servant)) and RE (RE_Set_Default_Servant), RU (RE_Unit_Table (RE_Get_MDNS_Servant)) and RE (RE_Get_MDNS_Servant)); end if; -- Check version consistency of RCI stubs if Default_Version_Check then for J in Current.First_Stub .. Current.Last_Stub loop Unit := ALIs.Table (Get_ALI_Id (Stubs.Table (J))).Last_Unit; Write_Call (RU (RE_Unit_Table (RE_Check)) and RE (RE_Check), Quote (Stubs.Table (J)), No_Str, Stubs.Table (J) & "'Version", Units.Table (Unit).RCI'Img); end loop; end if; -- Invoke main subprogram when there is one if Present (Current.Main_Subprogram) then Write_Call (Current.Main_Subprogram); -- ??? We launch ORB.Run although this is only required for a -- non-tasking server. Note that this can be considered as -- incorrect since the env task becomes indirectly part of the -- task pool. else Write_Call (RU (RE_Unit_Table (RE_Run)) and RE (RE_Run), RU (RE_Unit_Table (RE_The_ORB)) and RE (RE_The_ORB), S1 => "May_Exit => False"); end if; Decrement_Indentation; Write_Str ("end "); Write_Name (Partition_Main_Name); Write_Line (";"); Close (File); Set_Standard_Output; end Generate_Partition_Main_File; -------------------------------- -- Generate_PCS_Project_Files -- -------------------------------- procedure Generate_PCS_Project_Files is Prj_Fname : File_Name_Type; Prj_File : File_Descriptor; DSA_Inc_Dir : constant String := PolyORB_Prefix & DSA_Inc_Rel_Dir; Secondary_PCS_Project : Name_Id; Secondary_PCS_Project_File : File_Name_Type; begin -- In the two project files below, we use ".." as the object directory, -- relative to the project directory, so that all objects are stored in -- the user's build directory. -- Create intermediate PCS project, extending the main PolyORB project, -- but removing source files that need to be rebuilt as client or server -- stubs, and those that are overridden by each partition. Get_Name_String (PCS_Project); Add_Char_To_Name_Buffer ('1'); Secondary_PCS_Project := Name_Find; Set_Corresponding_Project_File_Name (Secondary_PCS_Project_File); Prj_Fname := Dir (Id (Root), Secondary_PCS_Project_File); Create_File (Prj_File, Prj_Fname); Set_Output (Prj_File); Write_Str ("project "); Write_Name (Secondary_PCS_Project); Write_Str (" extends all ""polyorb"""); Write_Line (" is"); Write_Line (" for Externally_Built use ""true"";"); Write_Line (" for Source_Dirs use (""" & DSA_Inc_Dir & """);"); -- The files to be removed are the only source files for the extending -- project (all other sources are made visible as inherited), so we -- need to first list those files as sources, then as removed. for J in 1 .. 2 loop if J = 1 then Write_Line (" for Source_Files use"); else Write_Line (" for Locally_Removed_Files use"); end if; -- Overridden Write_Line (" (""polyorb-partition_elaboration.adb"","); Write_Line (" ""polyorb-dsa_p-storages-config.adb"","); -- Rebuilt as stubs Write_Line (" ""polyorb-dsa_p-partitions.ads"","); Write_Line (" ""polyorb-dsa_p-partitions.adb"");"); end loop; Write_Str ("end "); Write_Name (Secondary_PCS_Project); Write_Line (";"); Close (Prj_File); Set_Standard_Output; -- Create project for PCS units that need to be rebuilt per-partition Prj_Fname := Dir (Id (Root), PCS_Project_File); Create_File (Prj_File, Prj_Fname); Set_Output (Prj_File); Write_Str ("with """); Write_Name (Secondary_PCS_Project); Write_Line (""";"); Write_Str ("project "); Write_Name (PCS_Project); Write_Line (" is"); Write_Line (" for Object_Dir use ""obj"";"); Write_Line (" for Source_Dirs use (""" & DSA_Inc_Dir & """);"); Write_Line (" for Source_Files use"); Write_Line (" (""polyorb-dsa_p-partitions.ads"","); Write_Line (" ""polyorb-dsa_p-partitions.adb"");"); Write_Str ("end "); Write_Name (PCS_Project); Write_Line (";"); Close (Prj_File); Set_Standard_Output; end Generate_PCS_Project_Files; --------------------- -- Get_Detach_Flag -- --------------------- function Get_Detach_Flag (Self : access PolyORB_Backend) return Name_Id is pragma Unreferenced (Self); begin return Id ("--polyorb-dsa-detach"); end Get_Detach_Flag; ---------------- -- Initialize -- ---------------- procedure Initialize (Self : access PolyORB_Backend) is pragma Unreferenced (Self); Pos : Integer; Len : Natural; begin XE_Back.Initialize; -- RCI unit PolyORB.DSA_P.Partition must be automatically configured on -- the main partition. PCS_Conf_Unit := Id ("polyorb.dsa_p.partitions"); Elaboration_File := Id ("polyorb-partition_elaboration"); Storage_Config_File := Id ("polyorb-dsa_p-storages-config"); Register_Casing_Rule ("ORB"); for U in RU_Id'First .. RU_Id'Last loop RU (U) := Strip (RU_Id'Image (U)); -- Allow to get the litteral value back from the name id. As -- the default value of info is zero, and as the first pos -- of an enumeration type is also zero, increment the pos. Set_Name_Table_Info (RU (U), RU_Id'Pos (U) + 1); -- Look for parent units Pos := 0; Get_Name_String (RU (U)); Len := Name_Len; while Name_Len > 0 loop if Name_Buffer (Name_Len) = '_' then Name_Len := Name_Len - 1; Pos := Integer (Get_Name_Table_Info (Name_Find)); exit when Pos > 0; else Name_Len := Name_Len - 1; end if; end loop; -- When there is a parent, remove its name from unit name to get -- real identifier. if Pos > 0 then Set_Str_To_Name_Buffer (Name_Buffer (Name_Len + 2 .. Len)); RU (U) := RU (RU_Id'Val (Pos - 1)) and Name_Find; else Set_Str_To_Name_Buffer (Name_Buffer (1 .. Len)); RU (U) := Name_Find; end if; if Debug_Mode then Message (U'Img & " = " & Get_Name_String (RU (U))); end if; end loop; for E in RE_Id loop RE (E) := Strip (RE_Id'Image (E)); end loop; for S in PS_Id loop PS (S) := Strip (PS_Id'Image (S), To_Lower => True); end loop; for E in PE_Id loop PE (E) := Strip (PE_Id'Image (E), To_Lower => True); end loop; Generate_PCS_Project_Files; Generate_Application_Project_Files; end Initialize; ---------------- -- Reset_Conf -- ---------------- procedure Reset_Conf is begin Last := -1; end Reset_Conf; ----------------------- -- Register_Storages -- ----------------------- procedure Register_Storages (Self : access PolyORB_Backend) is pragma Unreferenced (Self); begin Register_Storage (Storage_Name => "dsm", Allow_Passive => False, Allow_Local_Term => False, Need_Tasking => True); -- Registrer "dsm" storage support Register_Storage (Storage_Name => "dfs", Allow_Passive => True, Allow_Local_Term => True, Need_Tasking => False); -- Registrer "dfs" storage support end Register_Storages; ----------------- -- Run_Backend -- ----------------- procedure Run_Backend (Self : access PolyORB_Backend) is Current : Partition_Type; Is_Initiator_Set : Boolean := False; Enable_Global_Termination : Boolean := False; begin Prepare_Directories; Generate_All_Stubs_And_Skels; -- Scan all partitions to check global application properties for J in Partitions.First + 1 .. Partitions.Last loop Current := Partitions.Table (J); -- Termination policy has been set for all built partitions pragma Assert (Current.Termination /= No_Termination or else not Current.To_Build); -- Enable a termination initiator only if at least one node has -- global termination. if Current.Termination = Global_Termination then Enable_Global_Termination := True; end if; end loop; -- For each partition, generate the elaboration, main, executable -- and stamp files. for J in Partitions.First + 1 .. Partitions.Last loop Current := Partitions.Table (J); -- Reset the configuration table to forget all options set for -- previous partitions. Reset_Conf; -- Set termination initiator option on first partition with non local -- termination. Note that this must be done outside of the To_Build -- test. Otherwise, when building two partitions in separate gnatdist -- runs, both may end up being set up as initiators. Note that if -- no partition has global termination, then no initiator is defined. if not Is_Initiator_Set and then Current.Tasking /= No_Tasking and then Current.Termination /= Local_Termination and then Enable_Global_Termination then Set_Str_To_Name_Buffer ("true"); Set_Conf (PE_Termination_Initiator, Name_Find); Is_Initiator_Set := True; end if; if Partitions.Table (J).To_Build then if Current.To_Build and then Current.Passive /= BTrue then if Rebuild_Partition (J) then if not Quiet_Mode then Message ("building partition", Current.Name); end if; Generate_Storage_Config_File (J); Generate_Elaboration_File (J); Generate_Partition_Main_File (J); Generate_Executable_File (J); Generate_Stamp_File (J); end if; elsif Verbose_Mode then Message ("no need to expand", Current.Name); end if; end if; if Display_Compilation_Progress then Write_Str ("completed "); Write_Int (Int (J) - Int (Partition_Id'First) - 1); Write_Str (" out of "); Write_Int (Int (Partitions.Last) - Int (Partition_Id'First) - 1); Write_Str (" ("); Write_Int (((Int (J) - Int (Partition_Id'First) - 1) * 100) / Int (Partitions.Last - Partitions.First)); Write_Str ("%)..."); Write_Eol; end if; end loop; Generate_Starter_File (Backend_Access (Self)); end Run_Backend; -------------- -- Set_Conf -- -------------- procedure Set_Conf (Var : PE_Id; Val : Name_Id; Quote : Boolean := True) is begin Set_Conf (Section => PS (PE_Section_Table (Var)), Key => PE (Var), Val => Val, Quote => Quote); end Set_Conf; -------------- -- Set_Conf -- -------------- procedure Set_Conf (Section : Name_Id; Key : Name_Id; Val : Name_Id; Quote : Boolean) is Value : Name_Id; begin if Quote then Value := XE_Utils.Quote (Val); else Value := Val; end if; Last := Last + 1; Table (Last) := (Section => Section, Key => Key, Value => Value); end Set_Conf; ------------------------ -- Set_PCS_Dist_Flags -- ------------------------ procedure Set_PCS_Dist_Flags (Self : access PolyORB_Backend) is pragma Unreferenced (Self); begin -- WAG:61 -- We would normally get linker switches for the PolyORB runtime library -- through project files. This is the only supported option in MinGW -- context, where we cannot use the polyorb-config shell script. -- In the UNIX case, we still use polyorb-config, so that we get not -- only the project file path but also the legacy -L/-l command line -- switches, which allow correct operation even with older compilers. -- Note that in the UNIX case we rely on polyorb-config to set both -- -aP and -aI, to avoid setting -aP here to a value that might be -- inconsistent with the -aI path set by polyorb-config. if XE_Flags.Use_PolyORB_Project then Scan_Dist_Arg ("-margs"); Scan_Dist_Arg ("-aP" & PolyORB_Prefix & "lib" & Dir_Separator & "gnat"); else begin declare Status : aliased Integer; PolyORB_Config_Command : constant String := PolyORB_Prefix & "bin" & Dir_Separator & "polyorb-config"; PolyORB_Config_Output : constant String := Get_Command_Output (PolyORB_Config_Command, (1 .. 0 => null), "", Status'Access); begin Scan_Dist_Args (PolyORB_Config_Output); end; exception when others => raise Fatal_Error with "PolyORB installation is invalid " & "(polyorb-config failure)"; end; end if; end Set_PCS_Dist_Flags; ----------- -- Strip -- ----------- function Strip (S : String; To_Lower : Boolean := False) return Unit_Name_Type is begin Set_Str_To_Name_Buffer (S); Set_Str_To_Name_Buffer (Name_Buffer (4 .. Name_Len)); if To_Lower then for J in 1 .. Name_Len loop Name_Buffer (J) := Ada.Characters.Handling.To_Lower (Name_Buffer (J)); end loop; else Apply_Casing_Rules (Name_Buffer (1 .. Name_Len)); end if; while Name_Buffer (Name_Len) in '0' .. '9' or else Name_Buffer (Name_Len) = '_' loop Name_Len := Name_Len - 1; end loop; return Name_Find; end Strip; begin Register_Backend ("polyorb", new PolyORB_Backend); end XE_Back.PolyORB; polyorb-2.8~20110207.orig/compilers/gnatdist/xe_parse.adb0000644000175000017500000021215411750740337022505 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- X E _ P A R S E -- -- -- -- B o d y -- -- -- -- Copyright (C) 1995-2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with XE_Names; use XE_Names; with XE_Flags; use XE_Flags; with XE_IO; use XE_IO; with XE_Utils; use XE_Utils; package body XE_Parse is Indent : constant String := " "; -- Set Fatal_Error to False to allow overloading. In this case, if a -- a literal does not match the expected type, no error message is printed, -- an exception is raised and handled in order to try another matching. Fatal_Error : Boolean := True; procedure Print_Node (Node : Node_Id); -- Print only this node. procedure Write_Conflict_Error (SLOC : Location_Type; Name : Name_Id); procedure Write_Declaration_Error (SLOC : Location_Type; Name : Name_Id); procedure Write_Error_Message (SLOC : Location_Type; Mesg1 : String := ""; Name1 : Name_Id := No_Name; Mesg2 : String := ""; Name2 : Name_Id := No_Name); procedure Write_Indent (Many : Int := 1; Mesg : String := ""); procedure Write_Type_Error (SLOC : Location_Type; Name : Name_Id); ------------------------ -- Check_Not_Declared -- ------------------------ procedure Check_Not_Declared (Declaration_Name : Name_Id; Declaration_Sloc : Location_Type) is Node : Node_Id; begin Search_Declaration (Declaration_Name, Node); if Node /= Null_Node then if Debug_Mode then Print_Node (Node); end if; Write_Conflict_Error (Declaration_Sloc, Declaration_Name); end if; end Check_Not_Declared; --------------------- -- Declare_Literal -- --------------------- procedure Declare_Literal (Literal_Name : Name_Id; Literal_Type : Type_Id; Literal_Sloc : Location_Type; Literal_Node : out Variable_Id) is L : Variable_Id; begin -- A literal is a variable which is not linked into the -- configuration declaration list. Create_Variable (L, Literal_Name); Set_Variable_Type (L, Literal_Type); Set_Node_Location (Node_Id (L), Literal_Sloc); Literal_Node := L; end Declare_Literal; ---------------------------- -- Declare_Procedure_Call -- ---------------------------- procedure Declare_Procedure_Call (Subprogram_Node : Subprogram_Id; Subprogram_Sloc : Location_Type) is New_Statement : Statement_Id; Old_Subprogram : Subprogram_Id; New_Subprogram : Subprogram_Id; Old_Parameter : Parameter_Id; New_Parameter : Parameter_Id; begin Old_Subprogram := Subprogram_Node; -- Parser naming convention: Procedure_Name_Id indicates a -- procedure call. Create_Statement (New_Statement, Procedure_Name_Id); Set_Node_Location (Node_Id (New_Statement), Subprogram_Sloc); -- Make a copy of subprogram node. Create_Subprogram (New_Subprogram, Get_Node_Name (Node_Id (Old_Subprogram))); Subprogram_Is_A_Procedure (New_Subprogram, Is_Subprogram_A_Procedure (Old_Subprogram)); Set_Pragma_Kind (New_Subprogram, Get_Pragma_Kind (Old_Subprogram)); Set_Node_Location (Node_Id (New_Subprogram), Subprogram_Sloc); -- Make a copy of parameters. First_Subprogram_Parameter (Old_Subprogram, Old_Parameter); while Old_Parameter /= Null_Parameter loop Declare_Subprogram_Parameter (Get_Node_Name (Node_Id (Old_Parameter)), Get_Parameter_Type (Old_Parameter), New_Subprogram, Null_Location, New_Parameter); -- Assign the (actual) parameters of subprogram execution -- to the value of the formal parameters computed during -- the parameter matching phase. Set_Variable_Value (Variable_Id (New_Parameter), Get_Variable_Value (Variable_Id (Old_Parameter))); Parameter_Is_Initialized (New_Parameter, True); Next_Subprogram_Parameter (Old_Parameter); end loop; Set_Subprogram_Call (New_Statement, New_Subprogram); Add_Configuration_Declaration (Configuration_Node, Node_Id (New_Statement)); end Declare_Procedure_Call; ------------------------ -- Declare_Subprogram -- ------------------------ procedure Declare_Subprogram (Subprogram_Name : Name_Id; Pragma_Kind : Pragma_Type; Is_A_Procedure : Boolean; Subprogram_Sloc : Location_Type; Subprogram_Node : out Subprogram_Id) is Node : Subprogram_Id; Unit : Variable_Id; begin -- A pragma is handled like a subprogram execution. When parameter -- Pragma_Kind is different from Pragma_Unkown, we have a pragma -- declaration. if Pragma_Kind = Pragma_Unknown then -- An ada unit node should be defined and its value holds the -- subprogram node. This way, function or procedure are handled -- as normal ada units. Search_Variable (Subprogram_Name, Unit); if Unit = Null_Variable then Declare_Variable (Subprogram_Name, Ada_Unit_Type_Node, Subprogram_Sloc, Unit); elsif Is_Variable_Initialized (Unit) then -- In this case, the ada unit is already declared, but already -- holds a function or procedure node. Write_Conflict_Error (Subprogram_Sloc, Subprogram_Name); end if; end if; Create_Subprogram (Node, Subprogram_Name); Set_Node_Location (Node_Id (Node), Subprogram_Sloc); Subprogram_Is_A_Procedure (Node, Is_A_Procedure); Set_Pragma_Kind (Node, Pragma_Kind); Subprogram_Node := Node; if Pragma_Kind = Pragma_Unknown then -- If it is an ada unit (variable) then it is already linked -- into the configuration declaration list. Set_Variable_Value (Unit, Variable_Id (Node)); else Add_Configuration_Declaration (Configuration_Node, Node_Id (Node)); end if; end Declare_Subprogram; ---------------------------------- -- Declare_Subprogram_Parameter -- ---------------------------------- procedure Declare_Subprogram_Parameter (Parameter_Name : Name_Id; Para_Type_Node : Type_Id; Subprogram_Node : Subprogram_Id; Parameter_Sloc : Location_Type; Parameter_Node : out Parameter_Id) is Node : Parameter_Id; begin Create_Parameter (Node, Parameter_Name); Set_Parameter_Type (Node, Para_Type_Node); Add_Subprogram_Parameter (Subprogram_Node, Node); Set_Node_Location (Node_Id (Node), Parameter_Sloc); Parameter_Node := Node; end Declare_Subprogram_Parameter; ---------------------------------- -- Declare_Subprogram_Parameter -- ---------------------------------- procedure Declare_Subprogram_Parameter (Parameter_Name : Name_Id; Para_Type_Node : Type_Id; Subprogram_Node : Subprogram_Id; Parameter_Sloc : XE_Scan.Location_Type) is Ignore : Parameter_Id; pragma Unreferenced (Ignore); begin Declare_Subprogram_Parameter (Parameter_Name, Para_Type_Node, Subprogram_Node, Parameter_Sloc, Parameter_Node => Ignore); end Declare_Subprogram_Parameter; ------------------ -- Declare_Type -- ------------------ procedure Declare_Type (Type_Name : Name_Id; Type_Kind : Predefined_Type; Composite : Boolean; Array_Len : Int; Comp_Type : Type_Id; Type_Sloc : Location_Type; Type_Node : out Type_Id) is T : Type_Id; begin pragma Assert (not Composite or else Array_Len = 0 or else Comp_Type /= Null_Type); Check_Not_Declared (Type_Name, Get_Token_Location); Create_Type (T, Type_Name); Type_Is_Composite (T, Composite); if Composite then Set_Array_Length (T, Array_Len); if Array_Len /= 0 then Set_Array_Component_Type (T, Comp_Type); end if; end if; Set_Type_Kind (T, Type_Kind); Set_Node_Location (Node_Id (T), Type_Sloc); Type_Node := T; Add_Configuration_Declaration (Configuration_Node, Node_Id (T)); end Declare_Type; ---------------------------- -- Declare_Type_Attribute -- ---------------------------- procedure Declare_Type_Attribute (Type_Node : Type_Id; Attribute_Name : Name_Id; Attr_Type_Node : Type_Id; Attribute_Kind : Attribute_Type; Attribute_Sloc : Location_Type; Attribute_Node : out Attribute_Id) is A : Attribute_Id; begin Declare_Type_Component (Type_Node, Attribute_Prefix & Attribute_Name, Attr_Type_Node, Attribute_Sloc, Component_Id (A)); Set_Attribute_Kind (Component_Id (A), Attribute_Kind); Attribute_Node := A; end Declare_Type_Attribute; ---------------------------- -- Declare_Type_Attribute -- ---------------------------- procedure Declare_Type_Attribute (Type_Node : Type_Id; Attribute_Name : Name_Id; Attr_Type_Node : Type_Id; Attribute_Kind : Attribute_Type; Attribute_Sloc : Location_Type) is Ignore : Attribute_Id; pragma Unreferenced (Ignore); begin Declare_Type_Attribute (Type_Node, Attribute_Name, Attr_Type_Node, Attribute_Kind, Attribute_Sloc, Attribute_Node => Ignore); end Declare_Type_Attribute; ---------------------------- -- Declare_Type_Component -- ---------------------------- procedure Declare_Type_Component (Type_Node : Type_Id; Component_Name : Name_Id; Comp_Type_Node : Type_Id; Component_Sloc : Location_Type; Component_Node : out Component_Id) is C : Component_Id; begin Create_Component (C, Component_Name); Set_Component_Type (C, Comp_Type_Node); Set_Attribute_Kind (C, Attribute_Unknown); Component_Is_Initialized (C, False); Add_Type_Component (Type_Node, C); Set_Node_Location (Node_Id (C), Component_Sloc); Component_Node := C; end Declare_Type_Component; ---------------------------- -- Declare_Type_Component -- ---------------------------- procedure Declare_Type_Component (Type_Node : Type_Id; Component_Name : Name_Id; Comp_Type_Node : Type_Id; Component_Sloc : Location_Type) is Ignore : Component_Id; pragma Unreferenced (Ignore); begin Declare_Type_Component (Type_Node, Component_Name, Comp_Type_Node, Component_Sloc, Component_Node => Ignore); end Declare_Type_Component; ---------------------- -- Declare_Variable -- ---------------------- procedure Declare_Variable (Variable_Name : Name_Id; Variable_Type : Type_Id; Variable_Sloc : Location_Type; Variable_Node : out Variable_Id) is TV : Variable_Id; SC : Component_Id; TC : Component_Id; begin Check_Not_Declared (Variable_Name, Variable_Sloc); Create_Variable (TV, Variable_Name); Set_Variable_Type (TV, Variable_Type); -- This type is a record, allocate the record (but not -- attributes). if Is_Type_Composite (Variable_Type) and then Get_Array_Length (Variable_Type) = 0 then First_Type_Component (Variable_Type, SC); while SC /= Null_Component loop if Get_Attribute_Kind (SC) = Attribute_Unknown then Declare_Variable_Component (TV, Get_Node_Name (Node_Id (SC)), Get_Component_Type (SC), Attribute_Unknown, Null_Location, TC); end if; Next_Type_Component (SC); end loop; end if; Set_Node_Location (Node_Id (TV), Variable_Sloc); Variable_Node := TV; Add_Configuration_Declaration (Configuration_Node, Node_Id (TV)); end Declare_Variable; -------------------------------- -- Declare_Variable_Component -- -------------------------------- procedure Declare_Variable_Component (Variable_Node : Variable_Id; Component_Name : Name_Id; Component_Type : Type_Id; Attribute_Kind : Attribute_Type; Component_Sloc : Location_Type; Component_Node : out Component_Id) is VC : Component_Id; VT : Type_Id; begin Create_Component (VC, Component_Name); Set_Component_Type (VC, Component_Type); Set_Attribute_Kind (VC, Attribute_Kind); Component_Is_Initialized (VC, False); Add_Variable_Component (Variable_Node, VC); Set_Node_Location (Node_Id (VC), Component_Sloc); -- If we add a new component to an array, then increment the -- number of components. VT := Get_Variable_Type (Variable_Node); if Attribute_Kind = Attribute_Unknown and then Get_Array_Length (VT) /= 0 then Set_Array_Length (Variable_Node, Get_Array_Length (Variable_Node) + 1); end if; Component_Node := VC; end Declare_Variable_Component; ------------------------ -- Duplicate_Variable -- ------------------------ procedure Duplicate_Variable (Source, Target : Variable_Id) is SC : Component_Id; VT : Type_Id; TC : Component_Id; begin VT := Get_Variable_Type (Source); pragma Assert (Get_Variable_Type (Target) = VT); -- For a non-composite type, just set the variable value if -- needed. if not Is_Type_Composite (VT) then if Is_Variable_Initialized (Source) then Set_Variable_Value (Target, Get_Variable_Value (Source)); end if; else -- If it is an array, then copy the number of components for -- the target. if Get_Array_Length (VT) /= 0 then Set_Array_Length (Target, Get_Array_Length (Source)); end if; -- Allocate and initialize only non_attribute components; First_Variable_Component (Source, SC); while SC /= Null_Component loop if Get_Attribute_Kind (SC) = Attribute_Unknown then Declare_Variable_Component (Target, Get_Node_Name (Node_Id (SC)), Get_Component_Type (SC), Attribute_Unknown, Null_Location, TC); if Is_Component_Initialized (SC) then Set_Component_Value (TC, Get_Component_Value (SC)); end if; end if; Next_Variable_Component (SC); end loop; end if; end Duplicate_Variable; ------------------- -- Exit_On_Error -- ------------------- procedure Exit_On_Error is begin if Fatal_Error then Print; raise Parsing_Error; else raise Matching_Error; end if; end Exit_On_Error; ---------------- -- Initialize -- ---------------- procedure Initialize is begin Attribute_Prefix := Id ("attribute "); Pragma_Prefix := Id ("pragma "); Type_Prefix := Id ("type "); Function_Name_Id := Id ("function"); Procedure_Name_Id := Id ("procedure"); Return_Name_Id := Id ("return"); end Initialize; ------------------------------ -- Match_Actual_With_Formal -- ------------------------------ procedure Match_Actual_With_Formal (Subprogram_Node : Subprogram_Id) is Convention : Convention_Type; Actual_Name : Name_Id; Formal_Name : Name_Id; Actual_Node : Variable_Id; Formal_Node : Parameter_Id; Formal_Type : Type_Id; N_Parameter : Int; Location : Location_Type; begin -- Look for the matching (marked) parameters. When a formal -- parameter has an associated actual parameter, mark the -- formal parameter and set the formal parameter value to -- the actual parameter. N_Parameter := 0; First_Subprogram_Parameter (Subprogram_Node, Formal_Node); while Formal_Node /= Null_Parameter loop Parameter_Is_Initialized (Formal_Node, False); N_Parameter := N_Parameter + 1; Next_Subprogram_Parameter (Formal_Node); end loop; -- At the beginning, convention is unknown. if N_Parameter <= 0 then return; end if; -- Look forward to find the convention. Take_Token ((Tok_Identifier, Tok_String_Literal, Tok_Left_Paren)); Location := Get_Token_Location; Convention := Positional; if Token = Tok_Identifier then Next_Token; if Token = Tok_Arrow then Convention := Named; end if; end if; Set_Token_Location (Location); -- Do the real matching once the convention is known. Formal_Name := No_Name; loop Location := Get_Token_Location; if Convention = Named then T_Identifier; Formal_Name := Token_Name; T_Arrow; end if; -- If convention = named, check that such a formal parameter -- belongs to the subprogram parameter list. -- If convention = positional, retrieve the first unmarked -- (unmatched) parameter (name and node). Search_Matching_Parameter (Subprogram_Node, Convention, Formal_Name, Formal_Type, Formal_Node); if Formal_Node = Null_Parameter then Write_Error_Message (Location, "formal parameter mismatch"); end if; Take_Token ((Tok_Identifier, Tok_String_Literal, Tok_Left_Paren)); Location := Get_Token_Location; Actual_Name := Token_Name; if Token = Tok_String_Literal then if Formal_Type /= String_Type_Node then Write_Error_Message (Location, "actual parameter mismatch"); end if; -- Create a declaration that contains the literal. Declare_Literal (Actual_Name, String_Type_Node, Location, Actual_Node); elsif Token = Tok_Identifier then -- Does this actual parameter really exist ? Search_Actual_Parameter (Actual_Name, Formal_Type, Actual_Node); if Actual_Node = Null_Variable then Write_Error_Message (Location, "actual parameter mismatch"); end if; else -- This is a literal aggregate. Declare_Variable (New_Variable_Name, Formal_Type, Location, Actual_Node); -- Reset the location to read the first left parenthesis. Set_Token_Location (Location); P_Aggregate_Assignment (Actual_Node); end if; -- Mark the matching parameter and set its value to actual -- parameter value. Set_Variable_Value (Variable_Id (Formal_Node), Actual_Node); N_Parameter := N_Parameter - 1; exit when N_Parameter = 0; Next_Token; if Token /= Tok_Comma then Write_Error_Message (Get_Token_Location, "missing parameters"); end if; end loop; end Match_Actual_With_Formal; ----------------------------- -- P_Aggregate_Assignment -- ----------------------------- procedure P_Aggregate_Assignment (Variable_Node : Variable_Id) is Expression_Name : Name_Id; Expression_Node : Variable_Id; Expression_Sloc : Location_Type; Variable_Type : Type_Id; Component_Node : Component_Id; Component_Type : Type_Id; Array_Length : Int; begin -- Only aggregates are allowed at this point. Variable_Type := Get_Variable_Type (Variable_Node); if not Is_Type_Composite (Variable_Type) then Write_Error_Message (Get_Token_Location, "only aggregate are allowed"); return; end if; Array_Length := Get_Array_Length (Variable_Type); T_Left_Paren; if Array_Length /= 0 then Component_Type := Get_Array_Component_Type (Variable_Type); end if; loop if Array_Length = 0 then Search_Uninitialized_Component (Variable_Node, Null_Type, Component_Node); if Component_Node = Null_Component then Write_Error_Message (Get_Token_Location, "too many components for record aggregate"); end if; Component_Type := Get_Component_Type (Component_Node); end if; if Is_Type_Composite (Component_Type) then Take_Token ((Tok_Identifier, Tok_Left_Paren, Tok_Right_Paren, Tok_String_Literal, Tok_Numeric_Literal)); else Take_Token ((Tok_Identifier, Tok_Right_Paren, Tok_String_Literal, Tok_Numeric_Literal)); end if; exit when Token = Tok_Right_Paren; Expression_Sloc := Get_Token_Location; if Token = Tok_Identifier then -- Ada unit names are allowed. P_Full_Ada_Identifier; Expression_Name := Token_Name; Search_Variable (Expression_Name, Expression_Node); if Expression_Node = Null_Variable then Declare_Variable (Expression_Name, Component_Type, Expression_Sloc, Expression_Node); end if; -- Tok_String_Literal. elsif Token = Tok_String_Literal then Declare_Literal (Token_Name, String_Type_Node, Expression_Sloc, Expression_Node); -- Tok_Numeric_Literal. elsif Token = Tok_Numeric_Literal then Declare_Literal (Token_Name, Integer_Type_Node, Expression_Sloc, Expression_Node); else Declare_Variable (New_Variable_Name, Component_Type, Expression_Sloc, Expression_Node); -- Reset the location to read the first left parenthesis. Set_Token_Location (Expression_Sloc); P_Aggregate_Assignment (Expression_Node); end if; -- Do this variable have the appropriate type. if Get_Variable_Type (Expression_Node) /= Component_Type then Write_Error_Message (Get_Token_Location, "incorrect element type in aggregate"); end if; -- ??? -- Variable_Is_Initialized (Expression_Node, True); if Array_Length /= 0 then -- We declare a component with an anonymous name. Declare_Variable_Component (Variable_Node, New_Component_Name (Variable_Node), Component_Type, Attribute_Unknown, Expression_Sloc, Component_Node); end if; Set_Component_Value (Component_Node, Expression_Node); Take_Token ((Tok_Comma, Tok_Right_Paren)); exit when Token = Tok_Right_Paren; end loop; Variable_Is_Initialized (Variable_Node, True); end P_Aggregate_Assignment; -------------------------- -- P_Configuration_Body -- -------------------------- procedure P_Configuration_Body is Name : Name_Id; begin if not Quiet_Mode then Write_Location (Get_Token_Location); Write_Str ("a configuration body is an obsolete feature"); Write_Eol; Write_Location (Get_Token_Location); Write_Str ("this code should be moved in the declarative part"); Write_Eol; end if; loop Take_Token ((Tok_Identifier, Tok_Null, Tok_End)); if Token = Tok_Identifier then -- This is an assignment. Includes a list of ada units -- into a partition. declare Variable_Node : Variable_Id; begin Name := Token_Name; Search_Variable (Name, Variable_Node); if Variable_Node = Null_Variable then Write_Declaration_Error (Get_Token_Location, Name); end if; T_Colon_Equal; -- Read the ada units aggregate. P_Aggregate_Assignment (Variable_Node); T_Semicolon; end; elsif Token = Tok_End then P_Configuration_End; exit; end if; end loop; end P_Configuration_Body; --------------------------------- -- P_Configuration_Declaration -- --------------------------------- procedure P_Configuration_Declaration is Conf_Name : Name_Id; Conf_Sloc : Location_Type; Conf_Node : Configuration_Id; begin -- Use "private" configuration to start. T_Configuration; T_Identifier; Conf_Name := Token_Name; Conf_Sloc := Get_Token_Location; Check_Not_Declared (Conf_Name, Conf_Sloc); -- We have the real configuration node. Let's use this one. Create_Configuration (Conf_Node, Conf_Name); Set_Node_Location (Node_Id (Conf_Node), Conf_Sloc); -- Append the "private" configuration to the new one. Add_Configuration_Declaration (Conf_Node, Node_Id (Configuration_Node)); -- Now, the new configuration is the root configuration. Configuration_Node := Conf_Node; T_Is; end P_Configuration_Declaration; ------------------------- -- P_Configuration_End -- ------------------------- procedure P_Configuration_End is begin Take_Token ((Tok_Identifier, Tok_Semicolon)); -- Check that the configuration name is matching the current -- configuration name. if Token = Tok_Identifier then if Get_Node_Name (Node_Id (Configuration_Node)) /= Token_Name then Write_Error_Message (Get_Token_Location, "name mismatch"); end if; T_Semicolon; end if; end P_Configuration_End; --------------------------- -- P_Full_Ada_Identifier -- --------------------------- procedure P_Full_Ada_Identifier is Identifier : Name_Id := Token_Name; Location : Location_Type; begin loop Next_Token; Location := Get_Token_Location; -- If token is '.' then continue ... if Token = Tok_Dot then T_Identifier; Get_Name_String (Identifier); Add_Char_To_Name_Buffer ('.'); Get_Name_String_And_Append (Token_Name); Identifier := Name_Find; -- If not, then this is the identifier end. else Set_Token_Location (Location); Token_Name := Identifier; Token := Tok_Identifier; exit; end if; end loop; end P_Full_Ada_Identifier; ---------------------------- -- P_Function_Declaration -- ---------------------------- procedure P_Function_Declaration is Function_Name : Name_Id; Function_Sloc : Location_Type; Function_Node : Subprogram_Id; Parameter_Name : Name_Id; Parameter_Sloc : Location_Type; Para_Type_Name : Name_Id; Para_Type_Sloc : Location_Type; Para_Type_Node : Type_Id; Para_Type_Kind : Predefined_Type; begin -- The following is the only allowed signature : -- function ( : String) return String; -- where and are to be defined. -- Token FUNCTION has already been parsed. T_Identifier; Function_Name := Token_Name; Function_Sloc := Get_Token_Location; Declare_Subprogram (Function_Name, Pragma_Unknown, False, Function_Sloc, Function_Node); T_Left_Paren; -- Get parameter . T_Identifier; Parameter_Name := Token_Name; Parameter_Sloc := Get_Token_Location; T_Colon; -- Get parameter type. T_Identifier; Para_Type_Name := Token_Name; Para_Type_Sloc := Get_Token_Location; Search_Type (Para_Type_Name, Para_Type_Kind, Para_Type_Node); -- String is the only expected type. if Para_Type_Node /= String_Type_Node then Write_Error_Message (Para_Type_Sloc, """", Para_Type_Name, """ is not the expected type"); end if; -- Declare as a formal parameter. Declare_Subprogram_Parameter (Parameter_Name, Para_Type_Node, Function_Node, Parameter_Sloc); T_Right_Paren; T_Return; -- Get returned parameter type. T_Identifier; Para_Type_Name := Token_Name; Para_Type_Sloc := Get_Token_Location; Search_Type (Para_Type_Name, Para_Type_Kind, Para_Type_Node); -- String is the only type allowed at this level. if Para_Type_Node /= String_Type_Node then Write_Type_Error (Para_Type_Sloc, Para_Type_Name); end if; -- Declare returned parameter type. As a naming convention -- we use keyword Return_Name_Id as the anonymous parameter. Declare_Subprogram_Parameter (Return_Name_Id, Para_Type_Node, Function_Node, Para_Type_Sloc); T_Semicolon; end P_Function_Declaration; -------------- -- P_Pragma -- -------------- procedure P_Pragma is Pragma_Kind : Pragma_Type; Pragma_Node : Subprogram_Id; Pragma_Name : Name_Id; Pragma_Sloc : Location_Type; Invoke_Sloc : Location_Type; Context : Context_Type; begin -- Token PRAGMA has already been parsed. T_Identifier; -- Known pragmas are prefixed by Pragma_Prefix. Pragma_Name := Token_Name; Pragma_Sloc := Get_Token_Location; -- Is this pragma a known pragma. Search_Pragma (Pragma_Prefix & Pragma_Name, Pragma_Kind, Pragma_Node); if Pragma_Node = Null_Subprogram then Write_Error_Message (Get_Token_Location, "unrecognized pragma """, Pragma_Name, """"); end if; declare Next_Node : Subprogram_Id := Pragma_Node; begin Search_Next_Pragma (Pragma_Prefix & Pragma_Name, Next_Node); Fatal_Error := (Next_Node = Null_Subprogram); end; -- Save the context. Try to find a matching pragma (some -- pragmas are overloaded). If the attempt fails, then reset -- the context and try another pragma. If this pragma is not -- overloaded, then a failure is a fatal error and errors have -- to be printed. loop begin Save_Context (Configuration_Node, Context); T_Left_Paren; Invoke_Sloc := Get_Token_Location; -- Parse a pragma as a procedure call. Match_Actual_With_Formal (Pragma_Node); -- There is a match. Any error is now fatal. Fatal_Error := True; Next_Token; if Token /= Tok_Right_Paren then Write_Error_Message (Get_Token_Location, "too many parameters"); end if; exit; exception when Matching_Error => -- Reset context and location Jump_Context (Context); Set_Token_Location (Invoke_Sloc); -- Find another overloaded pragma. Search_Next_Pragma (Pragma_Prefix & Pragma_Name, Pragma_Node); if Pragma_Node = Null_Subprogram then Fatal_Error := True; Write_Error_Message (Invoke_Sloc, "invalid """, Pragma_Name, """ parameter list"); end if; end; end loop; Fatal_Error := True; -- When successful, declare the procedure call node. Declare_Procedure_Call (Pragma_Node, Pragma_Sloc); T_Semicolon; end P_Pragma; ----------------------------- -- P_Procedure_Declaration -- ----------------------------- procedure P_Procedure_Declaration is Ada_Unit_Node : Variable_Id; Constant_True : Variable_Id; Partition_Name : Name_Id; Partition_Node : Variable_Id; Partition_Sloc : Location_Type; Procedure_Sloc : Location_Type; Procedure_Name : Name_Id; Procedure_Node : Subprogram_Id; Component_Node : Component_Id; begin -- Token PROCEDURE has already been parsed. T_Identifier; Procedure_Sloc := Get_Token_Location; P_Full_Ada_Identifier; Procedure_Name := Token_Name; Search_Variable (Procedure_Name, Ada_Unit_Node); Take_Token ((Tok_Is, Tok_Semicolon)); -- This procedure has to be declared when this statement is -- a declaration or when it has not been already declared. if Token = Tok_Semicolon or else Ada_Unit_Node = Null_Variable then Declare_Subprogram (Procedure_Name, Pragma_Unknown, True, Procedure_Sloc, Procedure_Node); end if; if Token = Tok_Is then T_In; -- This should be an already declared variable. T_Identifier; Partition_Name := Token_Name; Partition_Sloc := Get_Token_Location; Search_Variable (Partition_Name, Partition_Node); -- This variable has to be already declared. Its type has to be -- of the predefined type Partition_Type_Node. if Partition_Node = Null_Variable or else Get_Variable_Type (Partition_Node) /= Partition_Type_Node then Write_Conflict_Error (Partition_Sloc, Partition_Name); end if; Search_Variable (Procedure_Name, Ada_Unit_Node); if Ada_Unit_Node = Null_Variable then Declare_Variable (Procedure_Name, Ada_Unit_Type_Node, Procedure_Sloc, Ada_Unit_Node); end if; Declare_Variable_Component (Variable_Node => Partition_Node, Component_Name => Attribute_Prefix & "main", Component_Type => Ada_Unit_Type_Node, Attribute_Kind => Attribute_Main, Component_Sloc => Procedure_Sloc, Component_Node => Component_Node); Set_Component_Value (Component_Node, Ada_Unit_Node); Search_Variable (Id ("true"), Constant_True); Declare_Variable_Component (Variable_Node => Partition_Node, Component_Name => Attribute_Prefix & "is boot partition", Component_Type => Boolean_Type_Node, Attribute_Kind => Attribute_Leader, Component_Sloc => Procedure_Sloc, Component_Node => Component_Node); Set_Component_Value (Component_Node, Constant_True); T_Semicolon; end if; end P_Procedure_Declaration; ----------------------------- -- P_Representation_Clause -- ----------------------------- procedure P_Representation_Clause is Direct_Name : Name_Id; Direct_Node : Node_Id; Direct_Type : Type_Id; Attr_Name : Name_Id; Attr_Sloc : Location_Type; Attr_Type : Type_Id; Attr_Node : Component_Id; Expr_Name : Name_Id; Expr_Node : Variable_Id; Expr_Type : Type_Id; Expr_Sloc : Location_Type; Is_A_Type : Boolean; Context : Context_Type; begin -- Token FOR has already been parsed. T_Identifier; Direct_Name := Token_Name; Search_Declaration (Direct_Name, Direct_Node); -- This identifier has to be already declared. if Direct_Node /= Null_Node then -- If legal, retrieve variable Direct_Node type. if Is_Variable (Direct_Node) then Direct_Type := Get_Variable_Type (Variable_Id (Direct_Node)); Is_A_Type := False; elsif Is_Type (Direct_Node) then Direct_Type := Type_Id (Direct_Node); Is_A_Type := True; -- Only variables and types are subject to representation clause. else Write_Error_Message (Get_Token_Location, "attribute cannot be given to ", Direct_Name); end if; else Write_Declaration_Error (Get_Token_Location, Direct_Name); end if; T_Apostrophe; -- Get the attribute name. T_Identifier; Attr_Name := Token_Name; Attr_Sloc := Get_Token_Location; -- Attributes are always prefixed by Attribute_Prefix. Search_Component (Attribute_Prefix & Attr_Name, Direct_Type, Attr_Node); -- Check that this attribute is a legal attribute for the given type if Attr_Node = Null_Component then Write_Error_Message (Attr_Sloc, "unrecognized attribute """, Attr_Name, """"); end if; -- Attributes may be overloaded. If it is the case, then we -- will have to perform several attempts. In this case, an -- error is not a fatal error. declare Next_Node : Component_Id := Attr_Node; begin Search_Next_Component (Attribute_Prefix & Attr_Name, Next_Node); Fatal_Error := (Next_Node = Null_Component); end; T_Use; -- Save the context. Try to find a matching attribute (some -- attributes are overloaded). If the attempt fails, then reset -- the context and try another attribute. If this attribute is -- not overloaded, then a failure is a fatal error and errors -- have to be printed. loop begin Save_Context (Configuration_Node, Context); Take_Token ((Tok_Identifier, Tok_String_Literal, Tok_Numeric_Literal, Tok_Left_Paren)); Expr_Name := Token_Name; Expr_Sloc := Get_Token_Location; Attr_Type := Get_Component_Type (Attr_Node); -- If string literal, declare an anonymous variable. if Token = Tok_String_Literal then Declare_Literal (Expr_Name, String_Type_Node, Expr_Sloc, Variable_Id (Expr_Node)); -- If aggregate literal, declare an anonymous variable. elsif Token = Tok_Left_Paren then if not Is_Type_Composite (Attr_Type) then Write_Type_Error (Expr_Sloc, Expr_Name); end if; Declare_Variable (New_Variable_Name, Attr_Type, Expr_Sloc, Variable_Id (Expr_Node)); -- Reset the location to read the first left parenthesis. Set_Token_Location (Expr_Sloc); P_Aggregate_Assignment (Expr_Node); -- If aggregate literal, declare an anonymous variable. elsif Token = Tok_Numeric_Literal then Declare_Literal (Expr_Name, Integer_Type_Node, Expr_Sloc, Variable_Id (Expr_Node)); -- Otherwise, retrieve the declaration. else Search_Variable (Expr_Name, Expr_Node); if Expr_Node = Null_Variable then Write_Declaration_Error (Expr_Sloc, Expr_Name); end if; end if; -- Check that the expression has the correct type Expr_Type := Get_Variable_Type (Expr_Node); -- Special case for functions and procedures if Expr_Type = Ada_Unit_Type_Node and then Is_Variable_Initialized (Expr_Node) then declare S : Subprogram_Id; P : Parameter_Id; begin S := Subprogram_Id (Get_Variable_Value (Expr_Node)); if Is_Subprogram_A_Procedure (S) then -- ??? Very ugly kludge Expr_Type := Main_Procedure_Type_Node; else Search_Function_Returned_Parameter (S, P); Expr_Type := Get_Parameter_Type (P); end if; end; end if; -- Is this the expected type ? if Expr_Type /= Attr_Type then Write_Type_Error (Get_Token_Location, Get_Node_Name (Node_Id (Expr_Type))); end if; if Is_A_Type then -- When the attribute applies to a type, the attribute -- component does already exist. Set_Component_Value (Attr_Node, Expr_Node); else -- When the attribute applies to a variable, the -- attribute has to be created. Declare_Variable_Component (Variable_Id (Direct_Node), Attribute_Prefix & Attr_Name, Attr_Type, Get_Attribute_Kind (Attr_Node), Attr_Sloc, Attr_Node); Set_Component_Value (Attr_Node, Expr_Node); end if; exit; exception when Matching_Error => -- Reset context and location Jump_Context (Context); Set_Token_Location (Expr_Sloc); -- Find another overloaded attribute. Search_Next_Component (Attribute_Prefix & Attr_Name, Attr_Node); if Attr_Node = Null_Component then Fatal_Error := True; Write_Error_Message (Expr_Sloc, "expression type does not match """, Attr_Name, """ attribute type"); end if; end; end loop; Fatal_Error := True; T_Semicolon; end P_Representation_Clause; --------------------------------- -- P_Variable_List_Declaration -- --------------------------------- procedure P_Variable_List_Declaration (Previous_Name : Name_Id; Previous_Sloc : Location_Type) is Previous_Node : Variable_Id; Variable_Name : Name_Id; Variable_Node : Variable_Id; Variable_Sloc : Location_Type; Var_Type_Name : Name_Id; Var_Type_Node : Type_Id; Var_Type_Kind : Predefined_Type; Var_Type_Sloc : Location_Type; begin Take_Token ((Tok_Comma, Tok_Colon)); -- Is it a list of identifiers ? if Token = Tok_Comma then T_Identifier; Variable_Name := Token_Name; Variable_Sloc := Get_Token_Location; -- Declare a temporary variable of any type -- ??? Should not use partition_type Declare_Variable (Previous_Name, Partition_Type_Node, Previous_Sloc, Previous_Node); -- Call recursively P_Variable_List_Declaration until the -- end of list. Variable_Node is a node for the next -- declared variable. P_Variable_List_Declaration (Variable_Name, Variable_Sloc); -- Variables can now be fully described. Search_Variable (Variable_Name, Variable_Node); Set_Variable_Type (Previous_Node, Get_Variable_Type (Variable_Node)); -- If previous variable has been initialized, initialize -- this newly declared variable with the same value. Duplicate_Variable (Variable_Node, Previous_Node); else -- The following identifier is a type. T_Identifier; Var_Type_Name := Token_Name; Var_Type_Sloc := Get_Token_Location; -- Has this type been declared ? Search_Type (Var_Type_Name, Var_Type_Kind, Var_Type_Node); if Var_Type_Node = Null_Type then Write_Type_Error (Var_Type_Sloc, Var_Type_Name); end if; -- Declare this new variable of type Var_Type_Node. Declare_Variable (Previous_Name, Var_Type_Node, Previous_Sloc, Previous_Node); Take_Token ((Tok_Semicolon, Tok_Colon_Equal)); -- Is there an initialization ? if Token = Tok_Colon_Equal then P_Aggregate_Assignment (Previous_Node); T_Semicolon; end if; end if; end P_Variable_List_Declaration; ----------- -- Parse -- ----------- procedure Parse is begin Load_File (Configuration_File_Name); P_Configuration_Declaration; loop Take_Token ((Tok_Identifier, Tok_Procedure, Tok_Function, Tok_For, Tok_Pragma, Tok_Begin, Tok_End)); case Token is when Tok_Function => P_Function_Declaration; when Tok_Procedure => P_Procedure_Declaration; when Tok_For => P_Representation_Clause; when Tok_Pragma => P_Pragma; when Tok_Identifier => P_Variable_List_Declaration (Token_Name, Get_Token_Location); when Tok_Begin => P_Configuration_Body; exit; when Tok_End => P_Configuration_End; exit; when others => null; end case; end loop; T_EOF; Print; end Parse; ----------- -- Print -- ----------- procedure Print is Node : Node_Id; begin if not Debug_Mode then return; end if; Write_Eol; Write_Str ("configuration"); Write_Eol; Write_Str ("============="); Write_Eol; Write_Eol; First_Configuration_Declaration (Configuration_Node, Node); while Node /= Null_Node loop Print_Node (Node); Next_Configuration_Declaration (Node); end loop; Write_Eol; Write_Str ("============="); Write_Eol; end Print; --------------------- -- Print_Component -- --------------------- procedure Print_Component (Node : Component_Id; Many : Int) is T : Type_Id; N : Variable_Id; begin T := Get_Component_Type (Node); Write_Indent (Many, ""); Write_Name (Get_Component_Name (Node)); Write_Str (" : "); Write_Name (Get_Node_Name (Node_Id (T))); if Is_Component_Initialized (Node) then N := Get_Component_Value (Node); Write_Str (" := "); Write_Name (Get_Variable_Name (N)); end if; Write_Eol; end Print_Component; ---------------- -- Print_Node -- ---------------- procedure Print_Node (Node : Node_Id) is X, Y : Int; C : Character; begin if Is_Variable (Node) then C := 'V'; Write_Str ("variable <"); elsif Is_Type (Node) then C := 'T'; Write_Str ("type <"); elsif Is_Subprogram (Node) then C := 'S'; Write_Str ("subprogram <"); elsif Is_Statement (Node) then C := 'I'; Write_Str ("invoke <"); elsif Is_Configuration (Node) then C := 'C'; Write_Str ("configuration <"); end if; Write_Name (Get_Node_Name (Node)); Write_Str ("> ("); Write_Int (Int (Node)); Write_Str (" at "); Get_Node_SLOC (Node, X, Y); Write_Int (X); Write_Str (":"); Write_Int (Y); Write_Str (")"); Write_Eol; case C is when 'V' => Print_Variable (Variable_Id (Node), 1); when 'T' => Print_Type (Type_Id (Node), 1); when 'S' => Print_Subprogram (Subprogram_Id (Node), 1); when 'I' => Print_Statement (Statement_Id (Node), 1); when others => null; end case; Write_Eol; end Print_Node; --------------------- -- Print_Parameter -- --------------------- procedure Print_Parameter (Node : Parameter_Id; Many : Int) is T : Type_Id; V : Variable_Id; begin T := Get_Parameter_Type (Node); Write_Indent (Many, ""); Write_Name (Get_Variable_Name (Variable_Id (Node))); Write_Str (" : "); Write_Name (Get_Node_Name (Node_Id (T))); if Is_Variable_Initialized (Variable_Id (Node)) then V := Get_Parameter_Value (Node); Write_Str (" := "); Write_Name (Get_Variable_Name (V)); end if; Write_Eol; end Print_Parameter; --------------------- -- Print_Statement -- --------------------- procedure Print_Statement (Node : Statement_Id; Many : Int) is S : Subprogram_Id; begin S := Get_Subprogram_Call (Node); Write_Indent (Many, ""); Write_Name (Get_Node_Name (Node_Id (S))); Write_Eol; Print_Subprogram (S, Many); end Print_Statement; ---------------------- -- Print_Subprogram -- ---------------------- procedure Print_Subprogram (Node : Subprogram_Id; Many : Int) is P : Parameter_Id; begin First_Subprogram_Parameter (Node, P); while P /= Null_Parameter loop Print_Parameter (P, Many + 1); Next_Subprogram_Parameter (P); end loop; end Print_Subprogram; ---------------- -- Print_Type -- ---------------- procedure Print_Type (Node : Type_Id; Many : Int) is C : Component_Id; S : Int; T : Type_Id; begin if not Is_Type_Composite (Node) then return; end if; S := Get_Array_Length (Node); if S /= 0 then Write_Indent (Many, "array ("); if S = Infinite then Write_Str ("<>"); else Write_Str ("0 .. "); Write_Int (S - 1); end if; T := Get_Array_Component_Type (Node); Write_Str (") of "); Write_Name (Get_Node_Name (Node_Id (T))); Write_Eol; else First_Type_Component (Node, C); while C /= Null_Component loop if Get_Attribute_Kind (C) = Attribute_Unknown then Print_Component (C, Many + 1); end if; Next_Type_Component (C); end loop; end if; First_Type_Component (Node, C); while C /= Null_Component loop if Get_Attribute_Kind (C) /= Attribute_Unknown then Print_Component (C, Many + 1); end if; Next_Type_Component (C); end loop; end Print_Type; -------------------- -- Print_Variable -- -------------------- procedure Print_Variable (Node : Variable_Id; Many : Int) is T : Type_Id; S : Int; C : Component_Id; begin T := Get_Variable_Type (Node); Write_Indent (Many, " : "); Write_Name (Get_Node_Name (Node_Id (T))); if not Is_Type_Composite (T) then if Is_Variable_Initialized (Node) then Write_Str (" := "); if T = String_Type_Node then Write_Name (Get_Variable_Name (Node)); else Write_Int (Get_Scalar_Value (Node)); end if; end if; Write_Eol; else S := Get_Array_Length (T); if S > 0 then Write_Str (" (0 .. "); Write_Int (Get_Array_Length (Node) - 1); Write_Str (") of "); T := Get_Array_Component_Type (T); Write_Name (Get_Node_Name (Node_Id (T))); end if; Write_Eol; First_Variable_Component (Node, C); while C /= Null_Component loop if Get_Attribute_Kind (C) = Attribute_Unknown then Print_Component (C, Many + 1); end if; Next_Type_Component (C); end loop; First_Variable_Component (Node, C); while C /= Null_Component loop if Get_Attribute_Kind (C) /= Attribute_Unknown then Print_Component (C, Many + 1); end if; Next_Type_Component (C); end loop; end if; end Print_Variable; ----------------------------- -- Search_Actual_Parameter -- ----------------------------- procedure Search_Actual_Parameter (Actual_Name : Name_Id; Actual_Type : Type_Id; Actual_Node : out Variable_Id) is Actual : Node_Id; begin -- Scan the configuration to find variable Actual_Name. First_Configuration_Declaration (Configuration_Node, Actual); while Actual /= Null_Node loop if Is_Variable (Actual) and then Get_Node_Name (Actual) = Actual_Name and then Get_Variable_Type (Variable_Id (Actual)) = Actual_Type then Actual_Node := Variable_Id (Actual); return; end if; Next_Configuration_Declaration (Actual); end loop; Write_Declaration_Error (Get_Token_Location, Actual_Name); end Search_Actual_Parameter; ---------------------- -- Search_Component -- ---------------------- procedure Search_Component (Component_Name : Name_Id; Type_Node : Type_Id; Component_Node : out Component_Id) is C : Component_Id; begin First_Type_Component (Type_Node, C); while C /= Null_Component loop exit when Get_Node_Name (Node_Id (C)) = Component_Name; Next_Type_Component (C); end loop; Component_Node := C; end Search_Component; ---------------------- -- Search_Component -- ---------------------- procedure Search_Component (Component_Name : Name_Id; Variable_Node : Variable_Id; Component_Node : out Component_Id) is C : Component_Id; begin First_Variable_Component (Variable_Node, C); while C /= Null_Component loop exit when Get_Node_Name (Node_Id (C)) = Component_Name; Next_Variable_Component (C); end loop; Component_Node := C; end Search_Component; ------------------------ -- Search_Declaration -- ------------------------ procedure Search_Declaration (Declaration_Name : Name_Id; Declaration_Node : out Node_Id) is Node : Node_Id; Name : Name_Id; begin First_Configuration_Declaration (Configuration_Node, Node); while Node /= Null_Node loop Name := Get_Node_Name (Node); exit when Name = Declaration_Name; Next_Configuration_Declaration (Node); end loop; Declaration_Node := Node; end Search_Declaration; ---------------------------------------- -- Search_Function_Returned_Parameter -- ---------------------------------------- procedure Search_Function_Returned_Parameter (Function_Node : Subprogram_Id; Parameter_Node : out Parameter_Id) is Prev, Next : Parameter_Id; begin pragma Assert (not Is_Subprogram_A_Procedure (Function_Node)); -- As it is a function, get the last parameter. Prev := Null_Parameter; First_Subprogram_Parameter (Function_Node, Next); while Next /= Null_Parameter loop Prev := Next; Next_Subprogram_Parameter (Next); end loop; Parameter_Node := Prev; end Search_Function_Returned_Parameter; ------------------------------- -- Search_Matching_Parameter -- ------------------------------- procedure Search_Matching_Parameter (Subprogram_Node : Subprogram_Id; Convention : Convention_Type; Formal_Name : in out Name_Id; Formal_Type : out Type_Id; Parameter_Node : in out Parameter_Id) is begin First_Subprogram_Parameter (Subprogram_Node, Parameter_Node); while Parameter_Node /= Null_Parameter loop Formal_Type := Get_Parameter_Type (Parameter_Node); case Convention is -- If Positional, find the first uninitialized parameter. when Positional => if not Is_Parameter_Initialized (Parameter_Node) then Formal_Name := Get_Node_Name (Node_Id (Parameter_Node)); return; end if; -- If Named, use Formal_Name to return format parameter node. when Named => if Get_Node_Name (Node_Id (Parameter_Node)) = Formal_Name then return; end if; end case; Next_Subprogram_Parameter (Parameter_Node); end loop; Write_Error_Message (Get_Token_Location, "no matching parameter"); end Search_Matching_Parameter; --------------------------- -- Search_Next_Component -- --------------------------- procedure Search_Next_Component (Component_Name : Name_Id; Component_Node : in out Component_Id) is begin Next_Type_Component (Component_Node); while Component_Node /= Null_Component and then Get_Node_Name (Node_Id (Component_Node)) /= Component_Name loop Next_Type_Component (Component_Node); end loop; end Search_Next_Component; ----------------------------- -- Search_Next_Declaration -- ----------------------------- procedure Search_Next_Declaration (Declaration_Name : Name_Id; Declaration_Node : in out Node_Id) is Node : Node_Id; Name : Name_Id; begin Node := Declaration_Node; Next_Configuration_Declaration (Node); while Node /= Null_Node loop Name := Get_Node_Name (Node); exit when Name = Declaration_Name; Next_Configuration_Declaration (Node); end loop; Declaration_Node := Node; end Search_Next_Declaration; ------------------------ -- Search_Next_Pragma -- ------------------------ procedure Search_Next_Pragma (Pragma_Name : Name_Id; Pragma_Node : in out Subprogram_Id) is begin Search_Next_Subprogram (Pragma_Name, Pragma_Node); end Search_Next_Pragma; ---------------------------- -- Search_Next_Subprogram -- ---------------------------- procedure Search_Next_Subprogram (Subprogram_Name : Name_Id; Subprogram_Node : in out Subprogram_Id) is Node : Node_Id := Node_Id (Subprogram_Node); begin Search_Next_Declaration (Subprogram_Name, Node); while Node /= Null_Node and then not Is_Subprogram (Node) loop Search_Next_Declaration (Subprogram_Name, Node); end loop; Subprogram_Node := Subprogram_Id (Node); end Search_Next_Subprogram; ------------------- -- Search_Pragma -- ------------------- procedure Search_Pragma (Pragma_Name : Name_Id; Pragma_Kind : out Pragma_Type; Pragma_Node : out Subprogram_Id) is Node : Subprogram_Id; begin Search_Subprogram (Pragma_Name, Node); if Node /= Null_Subprogram then Pragma_Kind := Get_Pragma_Kind (Node); end if; Pragma_Node := Node; end Search_Pragma; ----------------------- -- Search_Subprogram -- ----------------------- procedure Search_Subprogram (Subprogram_Name : Name_Id; Subprogram_Node : out Subprogram_Id) is Node : Node_Id; begin Search_Declaration (Subprogram_Name, Node); if Node /= Null_Node and then not Is_Subprogram (Node) then Node := Null_Node; end if; Subprogram_Node := Subprogram_Id (Node); end Search_Subprogram; ----------------- -- Search_Type -- ----------------- procedure Search_Type (Type_Name : Name_Id; Type_Kind : out Predefined_Type; Type_Node : out Type_Id) is Node : Node_Id; begin Search_Declaration (Type_Name, Node); if Node /= Null_Node and then not Is_Type (Node) then Node := Null_Node; end if; Type_Node := Type_Id (Node); if Node /= Null_Node then Type_Kind := Get_Type_Kind (Type_Id (Node)); end if; end Search_Type; ------------------------------------ -- Search_Uninitialized_Component -- ------------------------------------ procedure Search_Uninitialized_Component (Variable_Node : Variable_Id; Component_Type : Type_Id; Component_Node : out Component_Id) is C : Component_Id; T : Type_Id; begin -- If Component_Type is Null_Type, find the first uninitialized -- component, otherwise, try to match also the type. First_Variable_Component (Variable_Node, C); while C /= Null_Component loop T := Get_Component_Type (C); exit when (Component_Type = T or else Component_Type = Null_Type) and then not Is_Component_Initialized (C); Next_Variable_Component (C); end loop; Component_Node := C; end Search_Uninitialized_Component; --------------------- -- Search_Variable -- --------------------- procedure Search_Variable (Variable_Name : Name_Id; Variable_Node : out Variable_Id) is Node : Node_Id; begin Search_Declaration (Variable_Name, Node); if Node /= Null_Node and then not Is_Variable (Node) then Node := Null_Node; end if; Variable_Node := Variable_Id (Node); end Search_Variable; ----------------------- -- Set_Node_Location -- ----------------------- procedure Set_Node_Location (Node : Node_Id; Location : Location_Type) is X, Y : Int; begin Location_To_XY (Location, X, Y); Set_Node_SLOC (Node, X, Y); end Set_Node_Location; ------------------ -- T_Apostrophe -- ------------------ procedure T_Apostrophe is begin Take_Token (Tok_Apostrophe); end T_Apostrophe; ------------- -- T_Arrow -- ------------- procedure T_Arrow is begin Take_Token (Tok_Arrow); end T_Arrow; ------------- -- T_Colon -- ------------- procedure T_Colon is begin Take_Token (Tok_Colon); end T_Colon; ------------------- -- T_Colon_Equal -- ------------------- procedure T_Colon_Equal is begin Take_Token (Tok_Colon_Equal); end T_Colon_Equal; ------------- -- T_Comma -- ------------- procedure T_Comma is begin Take_Token (Tok_Comma); end T_Comma; --------------------- -- T_Configuration -- --------------------- procedure T_Configuration is begin Take_Token (Tok_Configuration); end T_Configuration; ----------- -- T_Dot -- ----------- procedure T_Dot is begin Take_Token (Tok_Dot); end T_Dot; ----------- -- T_End -- ----------- procedure T_End is begin Take_Token (Tok_End); end T_End; ----------- -- T_EOF -- ----------- procedure T_EOF is begin Take_Token (Tok_EOF); end T_EOF; ----------- -- T_For -- ----------- procedure T_For is begin Take_Token (Tok_For); end T_For; ---------------- -- T_Function -- ---------------- procedure T_Function is begin Take_Token (Tok_Function); end T_Function; ------------------ -- T_Identifier -- ------------------ procedure T_Identifier is begin Take_Token (Tok_Identifier); end T_Identifier; ---------- -- T_In -- ---------- procedure T_In is begin Take_Token (Tok_In); end T_In; ---------- -- T_Is -- ---------- procedure T_Is is begin Take_Token (Tok_Is); end T_Is; ------------------ -- T_Left_Paren -- ------------------ procedure T_Left_Paren is begin Take_Token (Tok_Left_Paren); end T_Left_Paren; -------------- -- T_Pragma -- -------------- procedure T_Pragma is begin Take_Token (Tok_Pragma); end T_Pragma; ----------------- -- T_Procedure -- ----------------- procedure T_Procedure is begin Take_Token (Tok_Procedure); end T_Procedure; -------------- -- T_Return -- -------------- procedure T_Return is begin Take_Token (Tok_Return); end T_Return; ------------------- -- T_Right_Paren -- ------------------- procedure T_Right_Paren is begin Take_Token (Tok_Right_Paren); end T_Right_Paren; ----------------- -- T_Semicolon -- ----------------- procedure T_Semicolon is begin Take_Token (Tok_Semicolon); end T_Semicolon; ---------------------- -- T_String_Literal -- ---------------------- procedure T_String_Literal is begin Take_Token (Tok_String_Literal); end T_String_Literal; ----------- -- T_Use -- ----------- procedure T_Use is begin Take_Token (Tok_Use); end T_Use; ---------------- -- Take_Token -- ---------------- procedure Take_Token (T : Token_Type) is begin Next_Token; if T /= Token then if Fatal_Error then Write_Location (Get_Token_Location); Write_Token (T); Write_Str (" was expected"); Write_Eol; end if; Exit_On_Error; end if; end Take_Token; ---------------- -- Take_Token -- ---------------- procedure Take_Token (L : Token_List_Type) is begin Next_Token; for Index in L'Range loop if L (Index) = Token then return; end if; end loop; if Fatal_Error then Write_Location (Get_Token_Location); Write_Token (L (L'First)); for Index in L'First + 1 .. L'Last loop Write_Str (" or "); Write_Token (L (Index)); end loop; Write_Str (" was expected"); Write_Eol; end if; Exit_On_Error; end Take_Token; -------------------------- -- Write_Conflict_Error -- -------------------------- procedure Write_Conflict_Error (SLOC : Location_Type; Name : Name_Id) is begin Write_Error_Message (SLOC, """", Name, """ conflicts with a previous declaration"); end Write_Conflict_Error; ----------------------------- -- Write_Declaration_Error -- ----------------------------- procedure Write_Declaration_Error (SLOC : Location_Type; Name : Name_Id) is begin Write_Error_Message (SLOC, """", Name, """ is undefined"); end Write_Declaration_Error; ------------------------- -- Write_Error_Message -- ------------------------- procedure Write_Error_Message (SLOC : Location_Type; Mesg1 : String := ""; Name1 : Name_Id := No_Name; Mesg2 : String := ""; Name2 : Name_Id := No_Name) is begin if Fatal_Error or else Debug_Mode then Write_Location (SLOC); if Mesg1 /= "" then Write_Str (Mesg1); end if; if Present (Name1) then Write_Name (Name1); end if; if Mesg2 /= "" then Write_Str (Mesg2); end if; if Present (Name2) then Write_Name (Name2); end if; Write_Eol; end if; Exit_On_Error; end Write_Error_Message; ------------------ -- Write_Indent -- ------------------ procedure Write_Indent (Many : Int := 1; Mesg : String := "") is begin for I in 1 .. Many loop Write_Str (Indent); end loop; Write_Str (Mesg); end Write_Indent; ---------------------- -- Write_Type_Error -- ---------------------- procedure Write_Type_Error (SLOC : Location_Type; Name : Name_Id) is begin Write_Error_Message (SLOC, """", Name, """ is not the expected type"); end Write_Type_Error; end XE_Parse; polyorb-2.8~20110207.orig/compilers/gnatprfh/0000755000175000017500000000000011750740340020210 5ustar xavierxavierpolyorb-2.8~20110207.orig/compilers/gnatprfh/gnatprfh.adb.in0000644000175000017500000001406311750740337023110 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- G N A T P R F H -- -- -- -- B o d y -- -- -- -- Copyright (C) 2007, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- Main driver for static perfect hash table generator pragma Style_Checks ("M2048"); -- Configure substitutions may yield long lines -- @configure_input@ with Ada.Command_Line; use Ada.Command_Line; with Ada.Text_IO; use Ada.Text_IO; with @GNAT_PERFECT_HASH_GENERATORS@; use @GNAT_PERFECT_HASH_GENERATORS@; procedure GNATPrfh is type String_Access is access String; File : File_Type; Buffer : String (1 .. 256); Last : Natural; Filename : String_Access; K_To_V : Float; K, V : Natural := 0; Pkg_Name : String_Access; Position : String_Access; Optim : Optimization := Memory_Space; Seed : constant Natural := 4321; procedure Parse_Command_Line; Flag : Character := '-'; procedure Check (B : Boolean); ----------- -- Check -- ----------- procedure Check (B : Boolean) is begin if not B then Put_Line (Standard_Error, "cannot parse command line"); raise Program_Error; end if; end Check; ------------------------ -- Parse_Command_Line -- ------------------------ procedure Parse_Command_Line is Argc : constant Natural := Argument_Count; begin for I in 1 .. Argc loop declare Arg : constant String := Argument (I); Len : constant Natural := Arg'Length; begin if Arg (1) = Flag then if Len = 1 then Check ((Filename = null)); Filename := new String'(""); else case Arg (2) is when '-' => Check ((Len = 2)); Flag := ASCII.NUL; when 'v' => Check ((Len = 2)); Verbose := True; when 's' => Check ((Position = null)); Position := new String'(Arg (3 .. Len)); when 'p' => Check ((Pkg_Name = null)); Pkg_Name := new String'(Arg (3 .. Len)); when 'm' => Optim := Memory_Space; when 'c' => Optim := CPU_Time; when others => null; end case; end if; else Check ((Filename = null)); Filename := new String'(Arg); end if; end; end loop; if Pkg_Name = null then Pkg_Name := new String'(Default_Pkg_Name); end if; if Position = null then Position := new String'(Default_Position); end if; end Parse_Command_Line; begin Parse_Command_Line; if Filename = null then Put_Line (Standard_Error, "Usage: gnatprfh opts name"); New_Line (Standard_Error); Put_Line (Standard_Error, " name is a filename of words"); New_Line (Standard_Error); Put_Line (Standard_Error, "gnatprfh switches:"); Put_Line (Standard_Error, " - Standard input"); Put_Line (Standard_Error, " -v Verbose mode"); Put_Line (Standard_Error, " -sRANGE Char selection"); Put_Line (Standard_Error, " -pNAME Package name"); Put_Line (Standard_Error, " -c CPU time optimization"); Put_Line (Standard_Error, " -m Memory space optimization"); return; end if; if Filename'Length /= 0 then Open (File, In_File, Filename.all); Set_Input (File); end if; while not End_Of_File (Current_Input) loop Get_Line (Buffer, Last); Insert (Buffer (1 .. Last)); K := K + 1; end loop; V := 2 * K + 1; loop K_To_V := Float (V) / Float (K); Initialize (Seed, K_To_V, Optim); begin Compute (Position.all); exit; exception when Too_Many_Tries => if Optim = CPU_Time then raise; end if; V := V + 1; end; end loop; Produce (Pkg_Name.all); Finalize; end GNATPrfh; polyorb-2.8~20110207.orig/compilers/common_files/0000755000175000017500000000000011750740340021051 5ustar xavierxavierpolyorb-2.8~20110207.orig/compilers/common_files/output.adb0000644000175000017500000001775411750740337023105 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- O U T P U T -- -- -- -- B o d y -- -- -- -- Copyright (C) 1992-2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ pragma License (GPL); with GNAT.OS_Lib; use GNAT.OS_Lib; package body Output is Current_FD : File_Descriptor := Standout; -- File descriptor for current output ------------------------- -- Line Buffer Control -- ------------------------- -- Note: the following buffer and column position are maintained by -- the subprograms defined in this package, and are not normally -- directly modified or accessed by a client. However, a client is -- permitted to modify these values, using the knowledge that only -- Write_Eol actually generates any output. Buffer_Max : constant := 8192; Buffer : String (1 .. Buffer_Max + 1); -- Buffer used to build output line. We do line buffering because it -- is needed for the support of the debug-generated-code option (-gnatD). -- Historically it was first added because on VMS, line buffering is -- needed with certain file formats. So in any case line buffering must -- be retained for this purpose, even if other reasons disappear. Note -- any attempt to write more output to a line than can fit in the buffer -- will be silently ignored. Next_Col : Positive range 1 .. Buffer'Length + 1 := 1; -- Column about to be written. ----------------------- -- Local_Subprograms -- ----------------------- procedure Flush_Buffer; -- Flush buffer if non-empty and reset column counter ------------ -- Column -- ------------ function Column return Pos is begin return Pos (Next_Col); end Column; ----------------------------- -- Copy_To_Standard_Output -- ----------------------------- procedure Copy_To_Standard_Output (Input : GNAT.OS_Lib.File_Descriptor) is Length : constant := 1024; Buffer : aliased String (1 .. Length); Result : Integer; begin loop Result := Read (Input, Buffer'Address, Length); exit when Result <= 0; Result := Write (Standout, Buffer'Address, Result); -- Deliberately ignore Result on output; it's not clear what we could -- do about any failure. end loop; Close (Input); end Copy_To_Standard_Output; --------------------------- -- Decrement_Indentation -- --------------------------- procedure Decrement_Indentation is begin N_Space := N_Space - Space_Increment; end Decrement_Indentation; ------------------ -- Flush_Buffer -- ------------------ procedure Flush_Buffer is Len : constant Natural := Natural (Next_Col - 1); begin if Len /= 0 then if Len /= Write (Current_FD, Buffer'Address, Len) then -- If there are errors with standard error, just quit if Current_FD = Standerr then OS_Exit (2); -- Otherwise, set the output to standard error before -- reporting a failure and quitting. else Current_FD := Standerr; Next_Col := 1; Write_Line ("fatal error: disk full"); OS_Exit (2); end if; end if; -- Buffer is now empty Next_Col := 1; end if; end Flush_Buffer; --------------------------- -- Increment_Indentation -- --------------------------- procedure Increment_Indentation is begin N_Space := N_Space + Space_Increment; end Increment_Indentation; ---------------- -- Set_Output -- ---------------- procedure Set_Output (New_Output : File_Descriptor) is begin Flush_Buffer; Next_Col := 1; Current_FD := New_Output; end Set_Output; ------------------------- -- Set_Space_Increment -- ------------------------- procedure Set_Space_Increment (Value : Natural) is begin Space_Increment := Value; end Set_Space_Increment; ------------------------ -- Set_Standard_Error -- ------------------------ procedure Set_Standard_Error is begin Flush_Buffer; Next_Col := 1; Current_FD := Standerr; end Set_Standard_Error; ------------------------- -- Set_Standard_Output -- ------------------------- procedure Set_Standard_Output is begin Flush_Buffer; Next_Col := 1; Current_FD := Standout; end Set_Standard_Output; ---------------- -- Write_Char -- ---------------- procedure Write_Char (C : Character) is begin if Next_Col = Buffer'Length then Write_Eol; end if; if C = ASCII.LF then Write_Eol; else Buffer (Next_Col) := C; Next_Col := Next_Col + 1; end if; end Write_Char; --------------- -- Write_Eol -- --------------- procedure Write_Eol (N : Natural := 1) is begin for I in 1 .. N loop Buffer (Natural (Next_Col)) := ASCII.LF; Next_Col := Next_Col + 1; Flush_Buffer; end loop; end Write_Eol; ----------------------- -- Write_Indentation -- ----------------------- procedure Write_Indentation (Offset : Integer := 0) is begin for I in 1 .. N_Space + Offset loop Write_Char (' '); end loop; end Write_Indentation; --------------- -- Write_Int -- --------------- procedure Write_Int (Val : Int) is begin if Val < 0 then Write_Char ('-'); Write_Int (-Val); else if Val > 9 then Write_Int (Val / 10); end if; Write_Char (Character'Val ((Val mod 10) + Character'Pos ('0'))); end if; end Write_Int; ---------------- -- Write_Line -- ---------------- procedure Write_Line (S : String) is begin Write_Str (S); Write_Eol; end Write_Line; ----------------- -- Write_Space -- ----------------- procedure Write_Space is begin Write_Char (' '); end Write_Space; --------------- -- Write_Str -- --------------- procedure Write_Str (S : String) is begin for J in S'Range loop Write_Char (S (J)); end loop; end Write_Str; end Output; polyorb-2.8~20110207.orig/compilers/common_files/namet.ads0000644000175000017500000002451411750740337022662 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- N A M E T -- -- -- -- S p e c -- -- -- -- Copyright (C) 2004-2008, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with GNAT.Table; with Types; use Types; package Namet is -- This package contains routines for handling the names table. The table -- is used to store character strings for identifiers and operator symbols, -- as well as other string values such as unit names and file names. -- The names are hashed so that a given name appears only once in the table, -- except that names entered with Name_Enter as opposed to Name_Find are -- omitted from the hash table. -- The first 26 entries in the names table (with Name_Id values in the range -- First_Name_Id .. First_Name_Id + 25) represent names which are the one -- character lower case letters in the range a-z, and these names are created -- and initialized by the Initialize procedure. -- Two values, one of type Int and one of type Byte, are stored with each -- names table entry and subprograms are provided for setting and retrieving -- these associated values. The usage of these values is up to the client. Name_Buffer : String (1 .. 16*1024); -- This buffer is used to set the name to be stored in the table for the -- Name_Find call, and to retrieve the name for the Get_Name_String call. -- The 16K here is intended to be an infinite value that ensures that we -- never overflow the buffer (names this long are too absurd to worry!) Name_Len : Natural; -- Length of name stored in Name_Buffer. Used as an input parameter for -- Name_Find, and as an output value by Get_Name_String, or Write_Name. ----------------- -- Subprograms -- ----------------- procedure Get_Name_String (Id : Name_Id); -- Get_Name_String is used to retrieve the string associated with an entry -- in the names table. The resulting string is stored in Name_Buffer -- and Name_Len is set. It is an error to call Get_Name_String with one -- of the special name Id values (No_Name or Error_Name). function Get_Name_String (Id : Name_Id) return String; -- This functional form returns the result as a string without affecting -- the contents of either Name_Buffer or Name_Len. procedure Get_Name_String_And_Append (Id : Name_Id); -- Like Get_Name_String but the resulting characters are appended to -- the current contents of the entry stored in Name_Buffer, and Name_Len -- is incremented to include the added characters. function Get_Name_Table_Byte (Id : Name_Id) return Byte; pragma Inline (Get_Name_Table_Byte); -- Fetches the Byte value associated with the given name function Get_Name_Table_Info (Id : Name_Id) return Int; pragma Inline (Get_Name_Table_Info); -- Fetches the Int value associated with the given name procedure Initialize; -- Initializes the names table, including initializing the first 26 -- entries in the table (for the 1-character lower case names a-z) -- Note that Initialize must not be called if Tree_Read is used. function Name_Find return Name_Id; -- Name_Find is called with a string stored in Name_Buffer whose length -- is in Name_Len (i.e. the characters of the name are in subscript -- positions 1 to Name_Len in Name_Buffer). It searches the names -- table to see if the string has already been stored. If so the Id of -- the existing entry is returned. Otherwise a new entry is created with -- its Name_Table_Info field set to zero. The contents of Name_Buffer -- and Name_Len are not modified by this call. function Name_Enter return Name_Id; -- Name_Enter has the same calling interface as Name_Find. The difference -- is that it does not search the table for an existing match, and also -- subsequent Name_Find calls using the same name will not locate the -- entry created by this call. Thus multiple calls to Name_Enter with the -- same name will create multiple entries in the name table with different -- Name_Id values. This is useful in the case of created names, which are -- never expected to be looked up. Note: Name_Enter should never be used -- for one character names, since these are efficiently located without -- hashing by Name_Find in any case. procedure Add_Char_To_Name_Buffer (C : Character); pragma Inline (Add_Char_To_Name_Buffer); -- Add given character to the end of the string currently stored in the -- Name_Buffer, incrementing Name_Len. procedure Set_Char_To_Name_Buffer (C : Character); pragma Inline (Set_Char_To_Name_Buffer); -- Equivalent to Name_Len := 0; followed by Add_Char_To_Name_Buffer (C); procedure Add_Nat_To_Name_Buffer (V : Nat); -- Add decimal representation of given value to the end of the string -- currently stored in Name_Buffer, incrementing Name_Len as required. procedure Set_Nat_To_Name_Buffer (V : Nat); pragma Inline (Set_Nat_To_Name_Buffer); -- Equivalent to Name_Len := 0; followed by Add_Nat_To_Name_Buffer (V); procedure Add_Dnat_To_Name_Buffer (V : Dnat); -- Add decimal representation of given value to the end of the string -- currently stored in Name_Buffer, incrementing Name_Len as required. procedure Set_Dnat_To_Name_Buffer (V : Dnat); pragma Inline (Set_Dnat_To_Name_Buffer); -- Equivalent to Name_Len := 0; followed by Add_Nat_To_Name_Buffer (V); procedure Add_Str_To_Name_Buffer (S : String); -- Add characters of string S to the end of the string currently stored -- in the Name_Buffer, incrementing Name_Len by the length of the string. procedure Set_Str_To_Name_Buffer (S : String); pragma Inline (Set_Str_To_Name_Buffer); -- Equivalent to Name_Len := 0; followed by Add_Str_To_Name_Buffer (S); procedure Set_Name_Table_Info (Id : Name_Id; Val : Int); pragma Inline (Set_Name_Table_Info); -- Sets the Int value associated with the given name procedure Set_Name_Table_Byte (Id : Name_Id; Val : Byte); pragma Inline (Set_Name_Table_Byte); -- Sets the Byte value associated with the given name procedure Write_Name (Id : Name_Id); -- Write_Name writes the characters of the specified name using the -- standard output procedures in package Output. No end of line is -- written, just the characters of the name. On return Name_Buffer and -- Name_Len are set as for a call to Get_Name_String. The name is written -- in encoded form (i.e. including Uhh, Whhh, Qx, _op as they appear in -- the name table). If Id is Error_Name, or No_Name, no text is output. procedure wn (Id : Name_Id); -- pragma Export (Ada, wn); -- Like Write_Name, but includes new line at end. Intended for use -- from the debugger only. --------------------------- -- Table Data Structures -- --------------------------- -- The following declarations define the data structures used to store -- names. The definitions are in the private part of the package spec, -- rather than the body, since they are referenced directly by gigi. private -- This table stores the actual string names. Although logically there -- is no need for a terminating character (since the length is stored -- in the name entry table), we still store a NUL character at the end -- of every name (for convenience in interfacing to the C world). package Name_Chars is new GNAT.Table ( Table_Component_Type => Character, Table_Index_Type => Int, Table_Low_Bound => 0, Table_Initial => 50_000, Table_Increment => 100); type Name_Entry is record Name_Chars_Index : Int; -- Starting location of characters in the Name_Chars table minus -- one (i.e. pointer to character just before first character). The -- reason for the bias of one is that indexes in Name_Buffer are -- one's origin, so this avoids unnecessary adds and subtracts of 1. Name_Len : Short; -- Length of this name in characters Byte_Info : Byte; -- Byte value associated with this name Hash_Link : Name_Id; -- Link to next entry in names table for same hash code Int_Info : Int; -- Int Value associated with this name end record; -- This is the table that is referenced by Name_Id entries. -- It contains one entry for each unique name in the table. package Name_Entries is new GNAT.Table ( Table_Component_Type => Name_Entry, Table_Index_Type => Name_Id, Table_Low_Bound => First_Name_Id, Table_Initial => 6_000, Table_Increment => 100); end Namet; polyorb-2.8~20110207.orig/compilers/common_files/errors.adb0000644000175000017500000001523311750740337023047 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- E R R O R S -- -- -- -- B o d y -- -- -- -- Copyright (C) 2004-2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with Output; use Output; with Namet; use Namet; with Utils; use Utils; package body Errors is procedure Initialize; -- [Re]Initialize global variables to decrease the likelihood of silently -- using old values. ------------------- -- Display_Error -- ------------------- procedure Display_Error (Template : Message_Template) is procedure Check_Space; -- Ensure the last character of the name buffer is a space ----------------- -- Check_Space -- ----------------- procedure Check_Space is begin if Name_Len > 0 and then Name_Buffer (Name_Len) /= ' ' then Add_Char_To_Name_Buffer (' '); end if; end Check_Space; -- N, L, and I are the indices mentioned in the spec N : Natural range 1 .. 3 := 1; -- Index into Error_Name L : Natural range 1 .. 3 := 1; -- Index into Error_Loc I : Natural range 1 .. 3 := 1; -- Index into Error_Int Special : Boolean := False; -- True when the current character is a special insertion character type Message_Kind is (K_Error, K_Warning, K_Continuation); Kind : Message_Kind; begin if Error_Loc (L) = No_Location then Set_Str_To_Name_Buffer (Utils.Simple_Command_Name); else Set_Str_To_Name_Buffer (Image (Error_Loc (L))); end if; L := L + 1; Add_Str_To_Name_Buffer (": "); Kind := K_Error; for J in Template'Range loop case Template (J) is when '\' => Kind := K_Continuation; exit; when '?' => Kind := K_Warning; exit; when others => null; end case; end loop; case Kind is when K_Error => N_Errors := N_Errors + 1; when K_Warning => N_Warnings := N_Warnings + 1; Add_Str_To_Name_Buffer ("warning: "); when K_Continuation => null; end case; for J in Template'Range loop -- Process special insertion characters case Template (J) is when '%' => Check_Space; Get_Name_String_And_Append (Error_Name (N)); N := N + 1; Special := True; when '#' => Check_Space; Add_Char_To_Name_Buffer ('"'); Get_Name_String_And_Append (Error_Name (N)); Add_Char_To_Name_Buffer ('"'); N := N + 1; Special := True; when '!' => case L is when 1 => Add_Str_To_Name_Buffer (Image (Error_Loc (1))); when 2 => Check_Space; if Error_Loc (1).File = Error_Loc (2).File then Add_Str_To_Name_Buffer ("at line "); Add_Nat_To_Name_Buffer (Error_Loc (2).Line); else Add_Str_To_Name_Buffer ("at "); Add_Str_To_Name_Buffer (Image (Error_Loc (2))); end if; when 3 => raise Program_Error; end case; L := L + 1; Special := True; when '$' => Add_Nat_To_Name_Buffer (Error_Int (I)); I := I + 1; Special := True; when '?' | '\' => -- Already dealt with null; when others => -- Add space after insertion if not provided by S if Special then if Template (J) /= ' ' then Add_Char_To_Name_Buffer (' '); end if; Special := False; end if; Add_Char_To_Name_Buffer (Template (J)); end case; end loop; Set_Standard_Error; Write_Line (Name_Buffer (1 .. Name_Len)); Set_Standard_Output; -- Reset all insertion data to ensure it is not erroneously propagated -- from one error to another. Initialize; end Display_Error; ------------------- -- Display_Error -- ------------------- procedure Display_Error (Template : Message_Template; S : String) is begin Set_Str_To_Name_Buffer (S); Error_Name (1) := Name_Find; Display_Error (Template); end Display_Error; ---------------- -- Initialize -- ---------------- procedure Initialize is begin Error_Loc := (others => No_Location); Error_Name := (others => No_Name); Error_Int := (others => Int'Last); end Initialize; begin Initialize; end Errors; polyorb-2.8~20110207.orig/compilers/common_files/errors.ads0000644000175000017500000001125311750740337023066 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- E R R O R S -- -- -- -- S p e c -- -- -- -- Copyright (C) 2004-2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with Locations; use Locations; with Types; use Types; package Errors is pragma Elaborate_Body; -- Because the body initializes the global variables below, so the compiler -- otherwise warns that they could be accessed by elaboration code in other -- packages. Not_Yet_Implemented : exception; -- Raised when code is not ready yet Internal_Error : exception; -- Raised when idlac reaches an internal inconsistent state Fatal_Error : exception; -- Raised when idlac has detected an external inconsistent state; that is, -- a user error like source-file-not-found. Whenever you raise Fatal_Error, -- you should print an error message first. type Message_Template is new String; -- Type of message templates used by Display_Error. We don't use type -- String, because we want to avoid using input data (tainted data) as part -- of the template. For example, if File_Name is a String that came from -- the command line, then: -- -- Display_Error ("file not found: %", File_Name); -- Correct -- Display_Error ("file not found: " & File_Name); -- WRONG! -- -- The second example will get a compilation error. If we allowed that, -- then we would crash if File_Name = "%". procedure Display_Error (Template : Message_Template); procedure DE (Template : Message_Template) renames Display_Error; -- Display a warning or error message based on the Template. The following -- special characters may appear in the Template: -- -- % (Percent): insert Error_Name (N) -- # (Hash): insert Error_Name (N) within quotes -- ! (Exclamantion): insert Error_Loc (L) -- $ (Dollar): insert Error_Int (I) -- ? (Question): make message a warning -- \ (Backslash): make message a continuation (does not count toward -- errors or warnings counter) -- Where N, L and I are indices incremented after each insertion character -- (note that Error_Loc (1) is always inserted ahead of the message, and -- L starts at 2 as far as explicit '!' insertions are concerned). procedure Display_Error (Template : Message_Template; S : String); procedure DE (Template : Message_Template; S : String) renames Display_Error; -- Same as previous Display_Error, except first put S into Error_Name (1). -- Template must contain a % special character, which will be replaced by -- S. Error_Name : array (1 .. 2) of Name_Id; Error_Loc : array (1 .. 2) of Location; Error_Int : array (1 .. 2) of Int; -- Count of errors and warnings displayed so far N_Errors : Int := 0; N_Warnings : Int := 0; end Errors; polyorb-2.8~20110207.orig/compilers/common_files/types.adb0000644000175000017500000000475211750740337022703 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- T Y P E S -- -- -- -- B o d y -- -- -- -- Copyright (C) 2004-2007, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ package body Types is ----------- -- Dummy -- ----------- procedure Dummy (E : Node_Id) is begin if Present (E) then null; end if; end Dummy; -------- -- No -- -------- function No (E : Node_Id) return Boolean is begin return E = No_Node; end No; ------------- -- Present -- ------------- function Present (E : Node_Id) return Boolean is begin return E /= No_Node; end Present; end Types; polyorb-2.8~20110207.orig/compilers/common_files/charset.ads0000644000175000017500000000472511750740337023211 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- C H A R S E T -- -- -- -- S p e c -- -- -- -- Copyright (C) 2004-2007, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ package Charset is function Is_Alphabetic_Character (C : Character) return Boolean; -- Alphabetic characters of ISO Latin-1 function Is_Identifier_Character (C : Character) return Boolean; -- Alphabetic character or digit or underscore character procedure To_Lower (S : in out String); function To_Lower (S : String) return String; function To_Lower (C : Character) return Character; -- Translate into lower case form end Charset; polyorb-2.8~20110207.orig/compilers/common_files/platform.ads.in0000644000175000017500000000540311750740337024003 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P L A T F O R M -- -- -- -- S p e c -- -- -- -- Copyright (C) 2001-2008, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- Defaults set by configure pragma Style_Checks ("M2048"); -- Configure substitutions may yield long lines -- @configure_input@ package Platform is pragma Pure; Version : constant String := "@POLYORB_VERSION@"; Prefix : constant String := "@prefix@"; IDL_Preprocessor : constant String := "@IDLCPP@ @IDLCPPFLAGS@"; IDL_Preprocessor_Suffix : constant String := "@IDLCPP_OUTPUT_SUFFIX@"; Windows_On_Host : constant Boolean := @WINDOWS_ON_HOST@; Validity_Check_Name : constant String := @SUPPRESS_VALIDITY_USE_VALIDITY@"Validity_Check"; @SUPPRESS_VALIDITY_USE_RANGE@"Range_Check"; -- WAG:5.04 -- GNAT versions prior to 6.0.1 only support suppressing validity checks -- by also disabling range checks. end Platform; polyorb-2.8~20110207.orig/compilers/common_files/utils.ads0000644000175000017500000000623111750740337022712 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- U T I L S -- -- -- -- S p e c -- -- -- -- Copyright (C) 2004-2008, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with Types; use Types; package Utils is function Image (N : Int) return String; -- Return the image of N without the annoying leading blank procedure Capitalize (S : in out String); -- Change in S any leading character or any successor of an -- underscore into its corresponding uppercase character. function Quoted (S : String; D : Character := '"') return String; -- " function Quoted (S : String; D : Character := '"') return Name_Id; -- " function Quoted (N : Name_Id; D : Character := '"') return String; -- " function Quoted (N : Name_Id; D : Character := '"') return Name_Id; -- " -- Embrace string S or name N with character D function To_Lower (N : Name_Id) return Name_Id; function Is_Dir_Separator (C : Character) return Boolean; -- Returns True if C is a directory separator. Always True for '/', since -- this is acceptable on Windows even though the "standard" one is '\'. function Simple_Command_Name return String; -- Returns the simple name of the command. Same as -- Ada.Command_Line.Command_Name, except this strips off the directory and -- extension, if any. end Utils; polyorb-2.8~20110207.orig/compilers/common_files/charset.adb0000644000175000017500000002100611750740337023157 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- C H A R S E T -- -- -- -- B o d y -- -- -- -- Copyright (C) 2004-2007, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with Ada.Characters.Latin_1; use Ada.Characters.Latin_1; package body Charset is type Translate_Table is array (Character) of Character; -- Type used to describe translate tables Fold_Lower : constant Translate_Table := ( 'A' => LC_A, 'B' => LC_B, 'C' => LC_C, 'D' => LC_D, 'E' => LC_E, 'F' => LC_F, 'G' => LC_G, 'H' => LC_H, 'I' => LC_I, 'J' => LC_J, 'K' => LC_K, 'L' => LC_L, 'M' => LC_M, 'N' => LC_N, 'O' => LC_O, 'P' => LC_P, 'Q' => LC_Q, 'R' => LC_R, 'S' => LC_S, 'T' => LC_T, 'U' => LC_U, 'V' => LC_V, 'W' => LC_W, 'X' => LC_X, 'Y' => LC_Y, 'Z' => LC_Z, LC_A => LC_A, LC_B => LC_B, LC_C => LC_C, LC_D => LC_D, LC_E => LC_E, LC_F => LC_F, LC_G => LC_G, LC_H => LC_H, LC_I => LC_I, LC_J => LC_J, LC_K => LC_K, LC_L => LC_L, LC_M => LC_M, LC_N => LC_N, LC_O => LC_O, LC_P => LC_P, LC_Q => LC_Q, LC_R => LC_R, LC_S => LC_S, LC_T => LC_T, LC_U => LC_U, LC_V => LC_V, LC_W => LC_W, LC_X => LC_X, LC_Y => LC_Y, LC_Z => LC_Z, UC_A_Grave => LC_A_Grave, UC_A_Acute => LC_A_Acute, UC_A_Circumflex => LC_A_Circumflex, UC_A_Tilde => LC_A_Tilde, UC_A_Diaeresis => LC_A_Diaeresis, UC_A_Ring => LC_A_Ring, UC_AE_Diphthong => LC_AE_Diphthong, UC_C_Cedilla => LC_C_Cedilla, UC_E_Grave => LC_E_Grave, UC_E_Acute => LC_E_Acute, UC_E_Circumflex => LC_E_Circumflex, UC_E_Diaeresis => LC_E_Diaeresis, UC_I_Grave => LC_I_Grave, UC_I_Acute => LC_I_Acute, UC_I_Circumflex => LC_I_Circumflex, UC_I_Diaeresis => LC_I_Diaeresis, UC_Icelandic_Eth => LC_Icelandic_Eth, UC_N_Tilde => LC_N_Tilde, UC_O_Grave => LC_O_Grave, UC_O_Acute => LC_O_Acute, UC_O_Circumflex => LC_O_Circumflex, UC_O_Tilde => LC_O_Tilde, UC_O_Diaeresis => LC_O_Diaeresis, UC_O_Oblique_Stroke => LC_O_Oblique_Stroke, UC_U_Grave => LC_U_Grave, UC_U_Acute => LC_U_Acute, UC_U_Circumflex => LC_U_Circumflex, UC_U_Diaeresis => LC_U_Diaeresis, UC_Y_Acute => LC_Y_Acute, UC_Icelandic_Thorn => LC_Icelandic_Thorn, LC_German_Sharp_S => LC_German_Sharp_S, LC_A_Grave => LC_A_Grave, LC_A_Acute => LC_A_Acute, LC_A_Circumflex => LC_A_Circumflex, LC_A_Tilde => LC_A_Tilde, LC_A_Diaeresis => LC_A_Diaeresis, LC_A_Ring => LC_A_Ring, LC_AE_Diphthong => LC_AE_Diphthong, LC_C_Cedilla => LC_C_Cedilla, LC_E_Grave => LC_E_Grave, LC_E_Acute => LC_E_Acute, LC_E_Circumflex => LC_E_Circumflex, LC_E_Diaeresis => LC_E_Diaeresis, LC_I_Grave => LC_I_Grave, LC_I_Acute => LC_I_Acute, LC_I_Circumflex => LC_I_Circumflex, LC_I_Diaeresis => LC_I_Diaeresis, LC_Icelandic_Eth => LC_Icelandic_Eth, LC_N_Tilde => LC_N_Tilde, LC_O_Grave => LC_O_Grave, LC_O_Acute => LC_O_Acute, LC_O_Circumflex => LC_O_Circumflex, LC_O_Tilde => LC_O_Tilde, LC_O_Diaeresis => LC_O_Diaeresis, LC_O_Oblique_Stroke => LC_O_Oblique_Stroke, LC_U_Grave => LC_U_Grave, LC_U_Acute => LC_U_Acute, LC_U_Circumflex => LC_U_Circumflex, LC_U_Diaeresis => LC_U_Diaeresis, LC_Y_Acute => LC_Y_Acute, LC_Icelandic_Thorn => LC_Icelandic_Thorn, LC_Y_Diaeresis => LC_Y_Diaeresis, others => ' '); ----------------------------- -- Is_Alphabetic_Character -- ----------------------------- function Is_Alphabetic_Character (C : Character) return Boolean is begin return Fold_Lower (C) /= ' '; end Is_Alphabetic_Character; ----------------------------- -- Is_Identifier_Character -- ----------------------------- function Is_Identifier_Character (C : Character) return Boolean is begin return C = '_' or else C in '0' .. '9' or else Fold_Lower (C) /= ' '; end Is_Identifier_Character; -------------- -- To_Lower -- -------------- procedure To_Lower (S : in out String) is begin for I in S'Range loop if Fold_Lower (S (I)) /= ' ' then S (I) := Fold_Lower (S (I)); end if; end loop; end To_Lower; -------------- -- To_Lower -- -------------- function To_Lower (C : Character) return Character is begin if Fold_Lower (C) /= ' ' then return Fold_Lower (C); else return C; end if; end To_Lower; -------------- -- To_Lower -- -------------- function To_Lower (S : String) return String is LS : String := S; begin To_Lower (LS); return LS; end To_Lower; end Charset; polyorb-2.8~20110207.orig/compilers/common_files/ChangeLog0000644000175000017500000000221211750740337022626 0ustar xavierxavier2004-08-13 Laurent Pautet * output.adb, output.ads: Remove unused routines. 2004-08-04 Laurent Pautet * utils.adb, utils.ads: Slightly modify Capitalize to change any leading character or successor of an underscore into its corresponding uppercase character (do not modify anything else). 2004-07-02 Ngoc Minh Vo * output.ads, output.adb: added Set_Output (File_Descriptor) 2004-06-29 Laurent Pautet * output.adb, output.ads: Add a parameter to Write_Eol in order to indicate the number of lines to write. Add a parameter Offset to Write_Indentation in order to insert or remove space when executing this routine. 2004-06-12 Laurent Pautet * output.ads, output.adb: Move Write_Indentation, Write_Space, Increment_Indentation and Decrement_Indentation from BE_IDL to Output. * errors.ads: Add exception Not_Yet_Implemented. 2004-06-10 Laurent Pautet * locations.adb, locations.ads: Add a location comparison function in order to know which location occurs first in the source file. polyorb-2.8~20110207.orig/compilers/common_files/namet.adb0000644000175000017500000004665611750740337022654 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- N A M E T -- -- -- -- B o d y -- -- -- -- Copyright (C) 2004-2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with Output; use Output; package body Namet is Already_Initialized : Boolean := False; Hash_Num : constant Int := 2**12; -- Number of headers in the hash table. Current hash algorithm is closely -- tailored to this choice, so it can only be changed if a corresponding -- change is made to the hash alogorithm. Hash_Max : constant Int := Hash_Num - 1; -- Indexes in the hash header table run from 0 to Hash_Num - 1 subtype Hash_Index_Type is Int range 0 .. Hash_Max; -- Range of hash index values Hash_Table : array (Hash_Index_Type) of Name_Id; -- The hash table is used to locate existing entries in the names table. -- The entries point to the first names table entry whose hash value -- matches the hash code. Then subsequent names table entries with the -- same hash code value are linked through the Hash_Link fields. ----------------------- -- Local Subprograms -- ----------------------- function Hash return Hash_Index_Type; pragma Inline (Hash); -- Compute hash code for name stored in Name_Buffer (length in Name_Len) ----------------------------- -- Add_Char_To_Name_Buffer -- ----------------------------- procedure Add_Char_To_Name_Buffer (C : Character) is begin if Name_Len < Name_Buffer'Last then Name_Len := Name_Len + 1; Name_Buffer (Name_Len) := C; end if; end Add_Char_To_Name_Buffer; ----------------------------- -- Add_Dnat_To_Name_Buffer -- ----------------------------- procedure Add_Dnat_To_Name_Buffer (V : Dnat) is begin if V >= 10 then Add_Dnat_To_Name_Buffer (V / 10); end if; Add_Char_To_Name_Buffer (Character'Val (Character'Pos ('0') + V rem 10)); end Add_Dnat_To_Name_Buffer; ---------------------------- -- Add_Nat_To_Name_Buffer -- ---------------------------- procedure Add_Nat_To_Name_Buffer (V : Nat) is begin if V >= 10 then Add_Nat_To_Name_Buffer (V / 10); end if; Add_Char_To_Name_Buffer (Character'Val (Character'Pos ('0') + V rem 10)); end Add_Nat_To_Name_Buffer; ---------------------------- -- Add_Str_To_Name_Buffer -- ---------------------------- procedure Add_Str_To_Name_Buffer (S : String) is begin for J in S'Range loop Add_Char_To_Name_Buffer (S (J)); end loop; end Add_Str_To_Name_Buffer; --------------------- -- Get_Name_String -- --------------------- procedure Get_Name_String (Id : Name_Id) is S : Int; begin pragma Assert (Id in Name_Entries.First .. Name_Entries.Last); S := Name_Entries.Table (Id).Name_Chars_Index; Name_Len := Natural (Name_Entries.Table (Id).Name_Len); for J in 1 .. Name_Len loop Name_Buffer (J) := Name_Chars.Table (S + Int (J)); end loop; end Get_Name_String; function Get_Name_String (Id : Name_Id) return String is S : Int; begin pragma Assert (Id in Name_Entries.First .. Name_Entries.Last); S := Name_Entries.Table (Id).Name_Chars_Index; declare R : String (1 .. Natural (Name_Entries.Table (Id).Name_Len)); begin for J in R'Range loop R (J) := Name_Chars.Table (S + Int (J)); end loop; return R; end; end Get_Name_String; -------------------------------- -- Get_Name_String_And_Append -- -------------------------------- procedure Get_Name_String_And_Append (Id : Name_Id) is S : Int; begin pragma Assert (Id in Name_Entries.First .. Name_Entries.Last); S := Name_Entries.Table (Id).Name_Chars_Index; for J in 1 .. Natural (Name_Entries.Table (Id).Name_Len) loop Name_Len := Name_Len + 1; Name_Buffer (Name_Len) := Name_Chars.Table (S + Int (J)); end loop; end Get_Name_String_And_Append; ------------------------- -- Get_Name_Table_Byte -- ------------------------- function Get_Name_Table_Byte (Id : Name_Id) return Byte is begin pragma Assert (Id in Name_Entries.First .. Name_Entries.Last); return Name_Entries.Table (Id).Byte_Info; end Get_Name_Table_Byte; ------------------------- -- Get_Name_Table_Info -- ------------------------- function Get_Name_Table_Info (Id : Name_Id) return Int is begin pragma Assert (Id in Name_Entries.First .. Name_Entries.Last); return Name_Entries.Table (Id).Int_Info; end Get_Name_Table_Info; ---------- -- Hash -- ---------- function Hash return Hash_Index_Type is subtype Int_1_12 is Positive range 1 .. 12; -- Used to avoid when others on case jump below Even_Name_Len : Integer; -- Last even numbered position (used for >12 case) begin -- Special test for 12 (rather than counting on a when others for the -- case statement below) avoids some Ada compilers converting the case -- statement into successive jumps. -- The case of a name longer than 12 characters is handled by taking -- the first 6 odd numbered characters and the last 6 even numbered -- characters if Name_Len > 12 then Even_Name_Len := (Name_Len) / 2 * 2; return (((((((((((( Character'Pos (Name_Buffer (01))) * 2 + Character'Pos (Name_Buffer (Even_Name_Len - 10))) * 2 + Character'Pos (Name_Buffer (03))) * 2 + Character'Pos (Name_Buffer (Even_Name_Len - 08))) * 2 + Character'Pos (Name_Buffer (05))) * 2 + Character'Pos (Name_Buffer (Even_Name_Len - 06))) * 2 + Character'Pos (Name_Buffer (07))) * 2 + Character'Pos (Name_Buffer (Even_Name_Len - 04))) * 2 + Character'Pos (Name_Buffer (09))) * 2 + Character'Pos (Name_Buffer (Even_Name_Len - 02))) * 2 + Character'Pos (Name_Buffer (11))) * 2 + Character'Pos (Name_Buffer (Even_Name_Len))) mod Hash_Num; end if; -- For the cases of 1-12 characters, all characters participate in the -- hash. The positioning is randomized, with the bias that characters -- later on participate fully (i.e. are added towards the right side). case Int_1_12'(Name_Len) is when 1 => return Character'Pos (Name_Buffer (1)); when 2 => return (( Character'Pos (Name_Buffer (1))) * 64 + Character'Pos (Name_Buffer (2))) mod Hash_Num; when 3 => return ((( Character'Pos (Name_Buffer (1))) * 16 + Character'Pos (Name_Buffer (3))) * 16 + Character'Pos (Name_Buffer (2))) mod Hash_Num; when 4 => return (((( Character'Pos (Name_Buffer (1))) * 8 + Character'Pos (Name_Buffer (2))) * 8 + Character'Pos (Name_Buffer (3))) * 8 + Character'Pos (Name_Buffer (4))) mod Hash_Num; when 5 => return ((((( Character'Pos (Name_Buffer (4))) * 8 + Character'Pos (Name_Buffer (1))) * 4 + Character'Pos (Name_Buffer (3))) * 4 + Character'Pos (Name_Buffer (5))) * 8 + Character'Pos (Name_Buffer (2))) mod Hash_Num; when 6 => return (((((( Character'Pos (Name_Buffer (5))) * 4 + Character'Pos (Name_Buffer (1))) * 4 + Character'Pos (Name_Buffer (4))) * 4 + Character'Pos (Name_Buffer (2))) * 4 + Character'Pos (Name_Buffer (6))) * 4 + Character'Pos (Name_Buffer (3))) mod Hash_Num; when 7 => return ((((((( Character'Pos (Name_Buffer (4))) * 4 + Character'Pos (Name_Buffer (3))) * 4 + Character'Pos (Name_Buffer (1))) * 4 + Character'Pos (Name_Buffer (2))) * 2 + Character'Pos (Name_Buffer (5))) * 2 + Character'Pos (Name_Buffer (7))) * 2 + Character'Pos (Name_Buffer (6))) mod Hash_Num; when 8 => return (((((((( Character'Pos (Name_Buffer (2))) * 4 + Character'Pos (Name_Buffer (1))) * 4 + Character'Pos (Name_Buffer (3))) * 2 + Character'Pos (Name_Buffer (5))) * 2 + Character'Pos (Name_Buffer (7))) * 2 + Character'Pos (Name_Buffer (6))) * 2 + Character'Pos (Name_Buffer (4))) * 2 + Character'Pos (Name_Buffer (8))) mod Hash_Num; when 9 => return ((((((((( Character'Pos (Name_Buffer (2))) * 4 + Character'Pos (Name_Buffer (1))) * 4 + Character'Pos (Name_Buffer (3))) * 4 + Character'Pos (Name_Buffer (4))) * 2 + Character'Pos (Name_Buffer (8))) * 2 + Character'Pos (Name_Buffer (7))) * 2 + Character'Pos (Name_Buffer (5))) * 2 + Character'Pos (Name_Buffer (6))) * 2 + Character'Pos (Name_Buffer (9))) mod Hash_Num; when 10 => return (((((((((( Character'Pos (Name_Buffer (01))) * 2 + Character'Pos (Name_Buffer (02))) * 2 + Character'Pos (Name_Buffer (08))) * 2 + Character'Pos (Name_Buffer (03))) * 2 + Character'Pos (Name_Buffer (04))) * 2 + Character'Pos (Name_Buffer (09))) * 2 + Character'Pos (Name_Buffer (06))) * 2 + Character'Pos (Name_Buffer (05))) * 2 + Character'Pos (Name_Buffer (07))) * 2 + Character'Pos (Name_Buffer (10))) mod Hash_Num; when 11 => return ((((((((((( Character'Pos (Name_Buffer (05))) * 2 + Character'Pos (Name_Buffer (01))) * 2 + Character'Pos (Name_Buffer (06))) * 2 + Character'Pos (Name_Buffer (09))) * 2 + Character'Pos (Name_Buffer (07))) * 2 + Character'Pos (Name_Buffer (03))) * 2 + Character'Pos (Name_Buffer (08))) * 2 + Character'Pos (Name_Buffer (02))) * 2 + Character'Pos (Name_Buffer (10))) * 2 + Character'Pos (Name_Buffer (04))) * 2 + Character'Pos (Name_Buffer (11))) mod Hash_Num; when 12 => return (((((((((((( Character'Pos (Name_Buffer (03))) * 2 + Character'Pos (Name_Buffer (02))) * 2 + Character'Pos (Name_Buffer (05))) * 2 + Character'Pos (Name_Buffer (01))) * 2 + Character'Pos (Name_Buffer (06))) * 2 + Character'Pos (Name_Buffer (04))) * 2 + Character'Pos (Name_Buffer (08))) * 2 + Character'Pos (Name_Buffer (11))) * 2 + Character'Pos (Name_Buffer (07))) * 2 + Character'Pos (Name_Buffer (09))) * 2 + Character'Pos (Name_Buffer (10))) * 2 + Character'Pos (Name_Buffer (12))) mod Hash_Num; end case; end Hash; ---------------- -- Initialize -- ---------------- procedure Initialize is begin if not Already_Initialized then Name_Chars.Init; Name_Entries.Init; -- Initialize entries for one character names for C in Character loop Name_Entries.Increment_Last; Name_Entries.Table (Name_Entries.Last).Name_Chars_Index := Name_Chars.Last; Name_Entries.Table (Name_Entries.Last).Name_Len := 1; Name_Entries.Table (Name_Entries.Last).Hash_Link := No_Name; Name_Entries.Table (Name_Entries.Last).Int_Info := 0; Name_Entries.Table (Name_Entries.Last).Byte_Info := 0; Name_Chars.Increment_Last; Name_Chars.Table (Name_Chars.Last) := C; Name_Chars.Increment_Last; Name_Chars.Table (Name_Chars.Last) := ASCII.NUL; end loop; -- Clear hash table for J in Hash_Index_Type loop Hash_Table (J) := No_Name; end loop; Already_Initialized := True; end if; end Initialize; ---------------- -- Name_Enter -- ---------------- function Name_Enter return Name_Id is begin Name_Entries.Increment_Last; Name_Entries.Table (Name_Entries.Last).Name_Chars_Index := Name_Chars.Last; Name_Entries.Table (Name_Entries.Last).Name_Len := Short (Name_Len); Name_Entries.Table (Name_Entries.Last).Hash_Link := No_Name; Name_Entries.Table (Name_Entries.Last).Int_Info := 0; Name_Entries.Table (Name_Entries.Last).Byte_Info := 0; -- Set corresponding string entry in the Name_Chars table for J in 1 .. Name_Len loop Name_Chars.Increment_Last; Name_Chars.Table (Name_Chars.Last) := Name_Buffer (J); end loop; Name_Chars.Increment_Last; Name_Chars.Table (Name_Chars.Last) := ASCII.NUL; return Name_Entries.Last; end Name_Enter; --------------- -- Name_Find -- --------------- function Name_Find return Name_Id is New_Id : Name_Id; -- Id of entry in hash search, and value to be returned S : Int; -- Pointer into string table Hash_Index : Hash_Index_Type; -- Computed hash index begin -- Quick handling for one character names if Name_Len = 1 then return Name_Id (First_Name_Id + Character'Pos (Name_Buffer (1))); -- Otherwise search hash table for existing matching entry else Hash_Index := Namet.Hash; New_Id := Hash_Table (Hash_Index); if New_Id = No_Name then Hash_Table (Hash_Index) := Name_Entries.Last + 1; else Search : loop if Name_Len /= Integer (Name_Entries.Table (New_Id).Name_Len) then goto No_Match; end if; S := Name_Entries.Table (New_Id).Name_Chars_Index; for I in 1 .. Name_Len loop if Name_Chars.Table (S + Int (I)) /= Name_Buffer (I) then goto No_Match; end if; end loop; return New_Id; -- Current entry in hash chain does not match <> if Name_Entries.Table (New_Id).Hash_Link /= No_Name then New_Id := Name_Entries.Table (New_Id).Hash_Link; else Name_Entries.Table (New_Id).Hash_Link := Name_Entries.Last + 1; exit Search; end if; end loop Search; end if; -- We fall through here only if a matching entry was not found in the -- hash table. We now create a new entry in the names table. The hash -- link pointing to the new entry (Name_Entries.Last+1) has been set. Name_Entries.Increment_Last; Name_Entries.Table (Name_Entries.Last).Name_Chars_Index := Name_Chars.Last; Name_Entries.Table (Name_Entries.Last).Name_Len := Short (Name_Len); Name_Entries.Table (Name_Entries.Last).Hash_Link := No_Name; Name_Entries.Table (Name_Entries.Last).Int_Info := 0; Name_Entries.Table (Name_Entries.Last).Byte_Info := 0; -- Set corresponding string entry in the Name_Chars table for I in 1 .. Name_Len loop Name_Chars.Increment_Last; Name_Chars.Table (Name_Chars.Last) := Name_Buffer (I); end loop; Name_Chars.Increment_Last; Name_Chars.Table (Name_Chars.Last) := ASCII.NUL; return Name_Entries.Last; end if; end Name_Find; ----------------------------- -- Set_Char_To_Name_Buffer -- ----------------------------- procedure Set_Char_To_Name_Buffer (C : Character) is begin Name_Len := 0; Add_Char_To_Name_Buffer (C); end Set_Char_To_Name_Buffer; ----------------------------- -- Set_Dnat_To_Name_Buffer -- ----------------------------- procedure Set_Dnat_To_Name_Buffer (V : Dnat) is begin Name_Len := 0; Add_Dnat_To_Name_Buffer (V); end Set_Dnat_To_Name_Buffer; ------------------------- -- Set_Name_Table_Byte -- ------------------------- procedure Set_Name_Table_Byte (Id : Name_Id; Val : Byte) is begin pragma Assert (Id in Name_Entries.First .. Name_Entries.Last); Name_Entries.Table (Id).Byte_Info := Val; end Set_Name_Table_Byte; ------------------------- -- Set_Name_Table_Info -- ------------------------- procedure Set_Name_Table_Info (Id : Name_Id; Val : Int) is begin pragma Assert (Id in Name_Entries.First .. Name_Entries.Last); Name_Entries.Table (Id).Int_Info := Val; end Set_Name_Table_Info; ---------------------------- -- Set_Nat_To_Name_Buffer -- ---------------------------- procedure Set_Nat_To_Name_Buffer (V : Nat) is begin Name_Len := 0; Add_Nat_To_Name_Buffer (V); end Set_Nat_To_Name_Buffer; ---------------------------- -- Set_Str_To_Name_Buffer -- ---------------------------- procedure Set_Str_To_Name_Buffer (S : String) is begin Name_Len := 0; Add_Str_To_Name_Buffer (S); end Set_Str_To_Name_Buffer; -------- -- wn -- -------- procedure wn (Id : Name_Id) is begin Write_Name (Id); Write_Eol; end wn; ---------------- -- Write_Name -- ---------------- procedure Write_Name (Id : Name_Id) is begin if Id >= First_Name_Id then Get_Name_String (Id); Write_Str (Name_Buffer (1 .. Name_Len)); end if; end Write_Name; end Namet; polyorb-2.8~20110207.orig/compilers/common_files/output.ads0000644000175000017500000001127211750740337023113 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- O U T P U T -- -- -- -- S p e c -- -- -- -- Copyright (C) 1992-2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- This package contains low level output routines used by the compiler -- for writing error messages and informational output. It is also used -- by the debug source file output routines (see Sprintf.Print_Eol). with GNAT.OS_Lib; with Types; use Types; package Output is pragma Elaborate_Body (Output); ----------------- -- Subprograms -- ----------------- procedure Copy_To_Standard_Output (Input : GNAT.OS_Lib.File_Descriptor); -- Read the entire Input, and copy the data to standard output. Finally, -- close the Input. procedure Set_Output (New_Output : GNAT.OS_Lib.File_Descriptor); -- Sets subsequent output to appear on the given file procedure Set_Standard_Error; -- Sets subsequent output to appear on the standard error file -- (whatever that might mean for the host operating system, if -- anything). procedure Set_Standard_Output; -- Sets subsequent output to appear on the standard output file -- (whatever that might mean for the host operating system, if -- anything). Output to standard output is the default mode before -- any call to either of the Set procedures. procedure Write_Char (C : Character); -- Write one character to the standard output file. Note that the -- character should not be LF or CR (use Write_Eol for end of line) procedure Write_Eol (N : Natural := 1); -- Write an end of line (whatever is required by the system in use, -- e.g. CR/LF for DOS, or LF for Unix) to the standard output file. -- This routine also empties the line buffer, actually writing it -- to the file. Note that Write_Eol is the only routine that causes -- any actual output to be written. procedure Write_Int (Val : Int); -- Write an integer value with no leading blanks or zeroes. Negative -- values are preceded by a minus sign). procedure Write_Str (S : String); -- Write a string of characters to the standard output file. Note that -- end of line is handled separately using WRITE_EOL, so the string -- should not contain either of the characters LF or CR, but it may -- contain horizontal tab characters. procedure Write_Line (S : String); -- Equivalent to Write_Str (S) followed by Write_Eol; function Column return Pos; pragma Inline (Column); -- Returns the number of the column about to be written (e.g. a value -- of 1 means the current line is empty). Space_Increment : Natural := 2; N_Space : Natural := 0; procedure Decrement_Indentation; procedure Increment_Indentation; procedure Set_Space_Increment (Value : Natural); procedure Write_Indentation (Offset : Integer := 0); procedure Write_Space; end Output; polyorb-2.8~20110207.orig/compilers/common_files/utils.adb0000644000175000017500000001170311750740337022671 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- U T I L S -- -- -- -- B o d y -- -- -- -- Copyright (C) 2004-2008, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with Ada.Command_Line; with Ada.Directories; with Charset; use Charset; with GNAT.Directory_Operations; use GNAT; with Namet; use Namet; with Platform; package body Utils is Up_To_Low : constant := Character'Pos ('A') - Character'Pos ('a'); ---------------- -- Capitalize -- ---------------- procedure Capitalize (S : in out String) is Up : Boolean := True; begin for I in S'Range loop if Up then Up := False; if S (I) in 'a' .. 'z' then S (I) := Character'Val (Character'Pos (S (I)) + Up_To_Low); end if; end if; if S (I) = '_' then Up := True; end if; end loop; end Capitalize; ----------- -- Image -- ----------- function Image (N : Int) return String is S : constant String := Int'Image (N); begin case S (S'First) is when ' ' => return S (S'First + 1 .. S'Last); when '-' => return S; when others => raise Program_Error; end case; end Image; ---------------------- -- Is_Dir_Separator -- ---------------------- function Is_Dir_Separator (C : Character) return Boolean is begin return C = Directory_Operations.Dir_Separator or else C = '/'; end Is_Dir_Separator; ------------ -- Quoted -- ------------ function Quoted (S : String; D : Character := '"') return String is -- " begin return (1 => D) & S & (1 => D); end Quoted; ------------ -- Quoted -- ------------ function Quoted (S : String; D : Character := '"') return Name_Id is -- " begin Set_Char_To_Name_Buffer (D); Add_Str_To_Name_Buffer (S); Add_Char_To_Name_Buffer (D); return Name_Find; end Quoted; ------------ -- Quoted -- ------------ function Quoted (N : Name_Id; D : Character := '"') return String is -- " begin return Quoted (Get_Name_String (N), D); end Quoted; ------------ -- Quoted -- ------------ function Quoted (N : Name_Id; D : Character := '"') return Name_Id is -- " begin return Quoted (Get_Name_String (N), D); end Quoted; ------------------------- -- Simple_Command_Name -- ------------------------- function Simple_Command_Name return String is use Ada, Ada.Directories; Name : constant String := Simple_Name (Command_Line.Command_Name); Exe : constant String := "exe"; begin if Platform.Windows_On_Host then if To_Lower (Extension (Name)) = Exe then return Base_Name (Name); end if; end if; return Name; end Simple_Command_Name; -------------- -- To_Lower -- -------------- function To_Lower (N : Name_Id) return Name_Id is begin if N = No_Name then return No_Name; end if; Get_Name_String (N); To_Lower (Name_Buffer (1 .. Name_Len)); return Name_Find; end To_Lower; end Utils; polyorb-2.8~20110207.orig/compilers/common_files/locations.ads0000644000175000017500000000525011750740337023545 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- L O C A T I O N S -- -- -- -- S p e c -- -- -- -- Copyright (C) 2004-2008, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with Types; use Types; package Locations is type Location is record File : Name_Id; Dir : Name_Id; Line : Nat; First : Text_Ptr; Last : Text_Ptr; Scan : Text_Ptr; end record; No_Location : constant Location := (No_Name, No_Name, 0, 0, 0, 0); function Image (Loc : Location) return String; procedure Set_New_Location (Loc : in out Location; Name : Name_Id; Line : Int); function "<" (Op1, Op2 : Location) return Boolean; -- If Op1 and Op2 are in the same file, returns True if and only if Op1 is -- before Op2. Returns False if Op1 and Op2 are not in the same file. end Locations; polyorb-2.8~20110207.orig/compilers/common_files/locations.adb0000644000175000017500000000746211750740337023533 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- L O C A T I O N S -- -- -- -- B o d y -- -- -- -- Copyright (C) 2004-2008, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with Namet; use Namet; with Utils; use Utils; package body Locations is --------- -- "<" -- --------- function "<" (Op1, Op2 : Location) return Boolean is begin return Op1.File = Op2.File and then Op1.Dir = Op2.Dir and then Op1.Scan < Op2.Scan; end "<"; ----------- -- Image -- ----------- function Image (Loc : Location) return String is begin if Loc.File = No_Name then return No_Str; end if; declare Column : constant Nat := Nat (Loc.Last - Loc.First + 1); function Column_Image return String; -- Return the image of Column, with a leading blank if necessary to -- make it at least 2 characters. function Column_Image return String is Im : constant String := Image (Column); begin if Column < 10 then return "0" & Im; else return Im; end if; end Column_Image; begin return Get_Name_String (Loc.File) & ":" & Image (Loc.Line) & ":" & Column_Image; end; end Image; ---------------------- -- Set_New_Location -- ---------------------- procedure Set_New_Location (Loc : in out Location; Name : Name_Id; Line : Int) is Len : Integer; begin Loc.Line := Line; Get_Name_String (Name); Len := Name_Len; for I in reverse 1 .. Name_Len loop if Is_Dir_Separator (Name_Buffer (I)) then Name_Len := I - 1; Loc.Dir := Name_Find; Set_Str_To_Name_Buffer (Name_Buffer (I + 1 .. Len)); Loc.File := Name_Find; return; end if; end loop; Loc.Dir := No_Name; Loc.File := Name; end Set_New_Location; end Locations; polyorb-2.8~20110207.orig/compilers/common_files/types.ads0000644000175000017500000002646611750740337022732 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- T Y P E S -- -- -- -- S p e c -- -- -- -- Copyright (C) 2004-2007, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with Unchecked_Deallocation; package Types is pragma Preelaborate (Types); -- This package contains host independent type definitions which are used -- in more than one unit in the compiler. They are gathered here for easy -- reference, though in some cases the full description is found in the -- relevant module which implements the definition. The main reason that -- they are not in their "natural" specs is that this would cause a lot of -- inter-spec dependencies, and in particular some awkward circular -- dependencies would have to be dealt with. ------------------------------- -- General Use Integer Types -- ------------------------------- type Int is range -2 ** 31 .. +2 ** 31 - 1; -- Signed 32-bit integer type Dint is range -2 ** 63 .. +2 ** 63 - 1; -- Double length (64-bit) integer subtype Nat is Int range 0 .. Int'Last; -- Non-negative Int values subtype Dnat is Dint range 0 .. Dint'Last; subtype Pos is Int range 1 .. Int'Last; -- Positive Int values type Word is mod 2 ** 32; -- Unsigned 32-bit integer type Byte is mod 2 ** 8; for Byte'Size use 8; -- 8-bit unsigned integer type size_t is mod 2 ** Standard'Address_Size; -- Memory size value, for use in calls to C routines -------------------------------------- -- 8-Bit Character and String Types -- -------------------------------------- -- We use Standard.Character and Standard.String freely, since we are -- compiling ourselves, and we properly implement the required 8-bit -- character code as required in Ada 95. This section defines a few -- general use constants and subtypes. EOF : constant Character := ASCII.SUB; -- The character SUB (16#1A#) is used in DOS and other systems derived -- from DOS (OS/2, NT etc) to signal the end of a text file. Internally -- all source files are ended by an EOF character, even on Unix systems. -- An EOF character acts as the end of file only as the last character -- of a source buffer, in any other position, it is treated as a blank -- if it appears between tokens, and as an illegal character otherwise. -- This makes life easier dealing with files that originated from DOS, -- including concatenated files with interspersed EOF characters. subtype Graphic_Character is Character range ' ' .. '~'; -- Graphic characters, as defined in ARM subtype Line_Terminator is Character range ASCII.LF .. ASCII.CR; -- Line terminator characters (LF, VT, FF, CR) subtype Upper_Half_Character is Character range Character'Val (16#80#) .. Character'Val (16#FF#); -- Characters with the upper bit set type Character_Ptr is access all Character; type String_Ptr is access all String; -- Standard character and string pointers procedure Free is new Unchecked_Deallocation (String, String_Ptr); -- Procedure for freeing dynamically allocated String values ----------------------------------------- -- Types Used for Text Buffer Handling -- ----------------------------------------- -- We can't use type String for text buffers, since we must use the -- standard 32-bit integer as an index value, since we count on all -- index values being the same size. type Text_Ptr is new Int; -- Type used for subscripts in text buffer type Text_Buffer is array (Text_Ptr range <>) of Character; -- Text buffer used to hold source file or library information file type Text_Buffer_Ptr is access all Text_Buffer; -- Text buffers for input files are allocated dynamically and this type -- is used to reference these text buffers. procedure Free is new Unchecked_Deallocation (Text_Buffer, Text_Buffer_Ptr); -- Procedure for freeing dynamically allocated text buffers ------------------------------------------ -- Types Used for Source Input Handling -- ------------------------------------------ type Logical_Line_Number is range 0 .. Int'Last; for Logical_Line_Number'Size use 32; -- Line number type, used for storing logical line numbers (i.e. line -- numbers that include effects of any Source_Reference pragmas in the -- source file). The value zero indicates a line containing a source -- reference pragma. No_Line_Number : constant Logical_Line_Number := 0; -- Special value used to indicate no line number type Physical_Line_Number is range 1 .. Int'Last; for Physical_Line_Number'Size use 32; -- Line number type, used for storing physical line numbers (i.e. -- line numbers in the physical file being compiled, unaffected by -- the presence of source reference pragmas. type Column_Number is range 0 .. 32767; for Column_Number'Size use 16; -- Column number (assume that 2**15 is large enough, see declaration -- of Hostparm.Max_Line_Length) No_Column_Number : constant Column_Number := 0; -- Special value used to indicate no column number ----------------------------- -- Types for Namet Package -- ----------------------------- -- Name_Id values are used to identify entries in the names table. Except -- for the special values No_Name, and Error_Name, they are subscript -- values for the Names table defined in package Namet. -- Note that with only a few exceptions, which are clearly documented, the -- type Name_Id should be regarded as a private type. In particular it is -- never appropriate to perform arithmetic operations using this type. Names_Low_Bound : constant := 300_000_000; -- Low bound for name Id values Names_High_Bound : constant := 399_999_999; -- Maximum number of names that can be allocated is 100 million, which is -- in practice infinite and there is no need to check the range. type Name_Id is range Names_Low_Bound .. Names_High_Bound; for Name_Id'Size use 32; -- Type used to identify entries in the names table No_Str : constant String := ""; No_Name : constant Name_Id := Names_Low_Bound; -- The special Name_Id value No_Name is used in the parser to indicate -- a situation where no name is present (e.g. on a loop or block). First_Name_Id : constant Name_Id := Names_Low_Bound + 2; -- Subscript of first entry in names table type Node_Id is new Int; No_Node : constant Node_Id := 0; function Present (E : Node_Id) return Boolean; -- Return true when E is not No_Node function No (E : Node_Id) return Boolean; -- Return true when E is No_Node procedure Dummy (E : Node_Id); type List_Id is new Node_Id; No_List : constant List_Id := 0; type Operator_Id is new Byte; type Value_Id is new Int; Mode_In : constant := 0; Mode_Inout : constant := 1; Mode_Out : constant := 2; type Mode_Id is new Byte range Mode_In .. Mode_Out; Pragma_Id : constant := 0; Pragma_Prefix : constant := 1; Pragma_Version : constant := 2; Pragma_Unrecognized : constant := 3; type Pragma_Type is new Byte range Pragma_Id .. Pragma_Unrecognized; type Base_Type is new Node_Id; type Short_Short is range -2 ** 7 .. 2 ** 7 - 1; for Short_Short'Size use 8; type Short is range -2 ** 15 .. 2 ** 15 - 1; for Short'Size use 16; type Long is range -2 ** 31 .. 2 ** 31 - 1; for Long'Size use 32; type Long_Long is range -2 ** 63 .. 2 ** 63 - 1; for Long_Long'Size use 64; type Octet is mod 2 ** 8; for Octet'Size use 8; type Unsigned_Short_Short is mod 2 ** 8; for Unsigned_Short_Short'Size use 8; type Unsigned_Short is mod 2 ** 16; for Unsigned_Short'Size use 16; type Unsigned_Long is mod 2 ** 32; for Unsigned_Long'Size use 32; type Unsigned_Long_Long is mod 2 ** 64; for Unsigned_Long_Long'Size use 64; -- Floating point types. We assume that we are on an IEEE machine, and -- that the types Short_Float and Long_Float in Standard refer to the -- 32-bit short and 64-bit long IEEE forms. Furthermore, if there is -- an extended float, we assume that it is available as Long_Long_Float. -- Note: it is harmless, and explicitly permitted, to include additional -- types in interfaces, so it is not wrong to have IEEE_Extended_Float -- defined even if the extended format is not available. type Float is new Short_Float; type Double is new Long_Float; type Long_Double is new Long_Long_Float; FSS : constant := Short_Short'First; LSS : constant := Short_Short'Last; FS : constant := Short'First; LS : constant := Short'Last; FL : constant := Long'First; LL : constant := Long'Last; FLL : constant := Long_Long'First; LLL : constant := Long_Long'Last; FO : constant := Octet'First; LO : constant := Octet'Last; FUSS : constant := Unsigned_Short_Short'First; LUSS : constant := Unsigned_Short_Short'Last; FUS : constant := Unsigned_Short'First; LUS : constant := Unsigned_Short'Last; FUL : constant := Unsigned_Long'First; LUL : constant := Unsigned_Long'Last; FULL : constant := Unsigned_Long_Long'First; LULL : constant := Unsigned_Long_Long'Last; function Shift_Left (Value : Unsigned_Long_Long; Amount : Natural) return Unsigned_Long_Long; function Shift_Right (Value : Unsigned_Long_Long; Amount : Natural) return Unsigned_Long_Long; pragma Import (Intrinsic, Shift_Left); pragma Import (Intrinsic, Shift_Right); end Types; polyorb-2.8~20110207.orig/compilers/config.adc.in0000644000175000017500000000027311750740337020732 0ustar xavierxavier-- Set policies pragma Assertion_Policy (@ASSERTION_POLICY@); pragma Debug_Policy (@DEBUG_POLICY@); -- Set Initialize_Scalars for debug builds @DEBUG_ONLY@pragma Initialize_Scalars; polyorb-2.8~20110207.orig/compilers/iac/0000755000175000017500000000000011750740340017133 5ustar xavierxavierpolyorb-2.8~20110207.orig/compilers/iac/backend.adb0000644000175000017500000001255311750740337021206 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- B A C K E N D -- -- -- -- B o d y -- -- -- -- Copyright (C) 2005-2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with GNAT.OS_Lib; use GNAT.OS_Lib; with Errors; use Errors; with Output; use Output; package body Backend is type Backend_Record is record Language : String_Access; Comments : String_Access; Generate : Generate_Procedure; Usage : Usage_Procedure; end record; type Table_Index is range 1 .. 8; subtype Table_Count is Table_Index'Base range 0 .. Table_Index'Last; Table : array (Table_Index) of Backend_Record; First : constant Table_Index := Table'First; Last : Table_Count := 0; Current : Table_Count := 0; -- Initialized to proper value in Backend.Config ---------------------- -- Current_Language -- ---------------------- function Current_Language return String is pragma Assert (Current in Table_Index); begin return Table (Current).Language.all; end Current_Language; -------------- -- Generate -- -------------- procedure Generate (IDL_Spec : Node_Id) is begin if Current /= 0 then Table (Current).Generate (IDL_Spec); end if; end Generate; ----------------------- -- Is_Valid_Language -- ----------------------- function Is_Valid_Language (L : String) return Boolean is begin for N in First .. Last loop if Table (N).Language.all = L then return True; end if; end loop; return False; end Is_Valid_Language; -------------- -- Register -- -------------- procedure Register_Language (Generate : Generate_Procedure; Usage : Usage_Procedure; Language : String; Comments : String) is begin if Last = Table'Last then DE ("too many target languages"); end if; for I in First .. Last loop if Table (I).Language.all = Language then DE ("already declared target language"); raise Internal_Error; end if; end loop; Last := Last + 1; Table (Last).Generate := Generate; Table (Last).Usage := Usage; Table (Last).Language := new String'(Language); Table (Last).Comments := new String'(Comments); end Register_Language; -------------------------- -- Set_Current_Language -- -------------------------- procedure Set_Current_Language (Language : String) is begin Current := 0; for I in First .. Last loop if Table (I).Language.all = Language then Current := I; exit; end if; end loop; if Current = 0 then DE ("unknown target language"); raise Fatal_Error; end if; end Set_Current_Language; --------------------- -- Write_Languages -- --------------------- procedure Write_Languages (L, C : Natural) is S : String (1 .. 64); begin for I in reverse First .. Last loop S := (others => ' '); declare Language : constant String := Table (I).Language.all; Comments : constant String := Table (I).Comments.all; Usage : constant Usage_Procedure := Table (I).Usage; begin S (L .. L + Language'Length - 1) := Language; S (C .. C + Comments'Length - 1) := Comments; Write_Line (S (1 .. C + Comments'Length - 1)); Usage (C); Write_Eol; end; end loop; end Write_Languages; end Backend; polyorb-2.8~20110207.orig/compilers/iac/outfiles.ads0000644000175000017500000000500511750740337021464 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- O U T F I L E S -- -- -- -- S p e c -- -- -- -- Copyright (C) 2007, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- Management of output files with GNAT.OS_Lib; use GNAT.OS_Lib; with Types; use Types; package Outfiles is function Set_Output (File_Name : Name_Id) return File_Descriptor; -- Adjust the output depending on the command line options (output -- to files or to stdout), and return a file descriptor for subsequent -- call to Release_Output. procedure Release_Output (Fd : File_Descriptor); -- Releases the output by closing the opened file descriptor, if required end Outfiles; polyorb-2.8~20110207.orig/compilers/iac/backend-be_corba_ada-idl_to_ada.ads0000644000175000017500000006070611750740337025646 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- B A C K E N D . B E _ C O R B A _ A D A . I D L _ T O _ A D A -- -- -- -- S p e c -- -- -- -- Copyright (C) 2005-2009, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with Frontend.Nodes; with Backend.BE_CORBA_Ada.Runtime; use Backend.BE_CORBA_Ada.Runtime; package Backend.BE_CORBA_Ada.IDL_To_Ada is package FEN renames Frontend.Nodes; function Base_Type_TC (K : FEN.Node_Kind) return Node_Id; -- Return the CORBA TypeCode corresponding to the IDL base type K type Binding is (B_Impl, B_Stub, B_TC, B_From_Any_Container, B_From_Any, B_To_Any, B_Raise_Excp, B_Initialize, B_To_Ref, B_U_To_Ref, B_Type_Def, B_Forward, B_Unmarshaller, B_Marshaller, B_Buffer_Size, B_Instantiation, B_Pointer_Type, B_Aggr_Container, B_Clone, B_Finalize_Value, B_Get_Aggregate_Count, B_Set_Aggregate_Count, B_Get_Aggregate_Element, B_Set_Aggregate_Element, B_Unchecked_Get_V, B_Wrap, B_Element_Wrap, B_Args_Out, B_Args_In, B_Access_Args_Out, B_IR_Function, B_Register_IR_Info); procedure Bind_FE_To_BE (F : Node_Id; B : Node_Id; W : Binding); -- To make easier the creation of the Ada tree, to minimize the -- number of nodes in this tree and finally to retrieve some Ada -- tree nodes created previously, we need to link the IDL tree and -- the Ada tree. The links are performed using the Bind_FE_To_BE -- subprogram. Bind_FE_To_BE creates a link between the IDL node F -- and the Ada node B according to the binding B_XXXX. The result -- of the execution : Bind_FE_To_BE (F, B, B_XXXX) is : B = -- XXXX_Node (BE_Node (F)) and F = FE_Node (B) function Is_Base_Type (N : Node_Id) return Boolean; -- Return True iff N is an IDL base type function Is_Object_Type (E : Node_Id) return Boolean; -- Returns True when the E is an interface type, when E denotes -- the CORBA::Object type or when it is a redefinition for one of -- the two first cases. function Is_N_Parent_Of_M (N : Node_Id; M : Node_Id) return Boolean; -- Return True iff the IDL node M is declared within (directly or -- not) the scope of N. function Map_Defining_Identifier (Entity : Node_Id) return Node_Id; -- Map an Ada defining identifier from the IDL node 'Entity' function Map_Expanded_Name (Entity : Node_Id) return Node_Id; -- Map an Ada expanded name from the IDL node 'Entity'. Handle the -- case of IDL base types for which we must return a CORBA type -- designator function Map_Fully_Qualified_Identifier (Entity : Node_Id) return Node_Id; -- Map a fully qualified Identifier (with the proper parent unit -- name) from 'Entity'. function Map_Get_Members_Spec (Member_Type : Node_Id) return Node_Id; -- Create the spec of the Get_Member procedure of an exception function Map_IDL_Unit (Entity : Node_Id) return Node_Id; -- Create an IDL unit from the Interface, Module or Specification -- 'Entity' and initialize the packages of the Unit according to -- its kind. function Map_Impl_Type_Ancestor (Entity : Node_Id) return Node_Id; -- Map an Implementation parent type according to the properties -- of the interface 'Entity'. function Map_Members_Definition (Members : List_Id) return List_Id; -- Map a Component_List from an exception member list function Map_Narrowing_Designator (E : Node_Id; Unchecked : Boolean) return Node_Id; -- Map a designator for the narrowing function corresponding to -- the interface type 'E'. function Map_Range_Constraints (Array_Sizes : List_Id) return List_Id; -- Create an Ada range constraint list from the IDL list Array_Sizes function Map_Ref_Type (Entity : Node_Id) return Node_Id; -- Map an reference type according to the properties of the -- interface 'Entity'. function Map_Ref_Type_Ancestor (Entity : Node_Id; Withed : Boolean := True) return Node_Id; -- Map an reference parent type according to the properties of the -- interface 'Entity'. If Withed is True, add the proper 'with' -- clause to the current package function Map_Raise_From_Any_Name (Entity : Node_Id) return Name_Id; -- Map the name of the Raise__From_Any function Map_Repository_Id_Declaration (Entity : Node_Id) return Node_Id; -- Map the Repository Id constant String declaration for the IDL -- entity 'Entity' function Map_Repository_Id_Name (Entity : Node_Id) return Name_Id; -- Maps the name of the repository id variable declared in the -- stub for node E. function Map_Type_Version (Entity : Node_Id) return Name_Id; -- Returns the type version of the respository id of entity E function Map_Fixed_Type_Name (F : Node_Id) return Name_Id; -- Map a fixed type name from the IDL node F according to the -- mapping specifications and handle name clashing by adding a -- unique suffix at the end of the name. If the -- Map_Fixed_Type_Helper_Name function is called twice on the same -- node F, it returns the same Name_Id. function Map_Fixed_Type_Helper_Name (F : Node_Id) return Name_Id; -- Map the 'Helper' instantiated package name name from the IDL -- node F. function Map_Sequence_Pkg_Name (S : Node_Id) return Name_Id; -- Map a Sequence package name from the Sequence Type S. Has the -- same name clashing handling properties as Map_Fixed_Type_Name. function Map_Sequence_Pkg_Helper_Name (S : Node_Id) return Name_Id; -- Maps Sequence package Helper name from the mapped name if the -- Sequence Type S. function Map_String_Pkg_Name (S : Node_Id) return Name_Id; -- Maps a Bounded String package name from the String Type S. Has -- the same name clashing handling properties as -- Map_Fixed_Type_Name. function Map_Variant_List (Alternatives : List_Id; Literal_Parent : Node_Id) return List_Id; -- Map a variant record part from an IDL union alternative list procedure Map_Choice_List (Labels : List_Id; Literal_Parent : Node_Id; Choices : out List_Id; Has_Default : in out Boolean); -- Converts an IDL case label list into an Ada choice list. Set -- Has_Default to True if 'default:' is in the IDL label list. ------------------- -- Stub Routines -- ------------------- function Map_Argument_Identifier_Name (P : Name_Id; O : Name_Id) return Name_Id; -- Maps the `PolyORB.Types.Identifier' variable name from the -- parameter name `P' and the operation name `O'. function Map_Argument_Name (P : Name_Id) return Name_Id; -- Maps an internal use variable name from the parameter name `P'. function Map_Argument_Content_Name (P : Name_Id) return Name_Id; -- Maps the `PolyORB.Any.Content'Class' variable name from the -- parameter name `P'. function Map_Argument_Any_Name (P : Name_Id) return Name_Id; -- Maps the `CORBA.Any' variable name from the parameter name `P' function Map_Result_Subprogram_Name (O : Name_Id) return Name_Id; -- Maps the name of the subprogram that set the Result_NV_Ü name -- value. function Map_Result_Identifier_Name (O : Name_Id) return Name_Id; -- Maps the `PolyORB.Types.Identifier' variable name from the -- operation name `O'. function Map_Operation_Name_Literal (O : Node_Id) return Name_Id; -- Maps the string literal that represents the operation name. If -- the operation is an attribute accessor, a '_' is appended at -- the beginning of the string literal. ------------------------- -- Shadow Any routines -- ------------------------- function Map_Container_Name (E : Node_Id) return Name_Id; -- Maps a name for the aggregate container corresponding to the -- IDL type 'E' function Map_Indices_Name (D : Node_Id) return Name_Id; -- Maps and identifier for an array type declaration (used in the -- Shadow Any's) corresponding to the complex declarator D function Map_Lengths_Name (D : Node_Id) return Name_Id; -- Maps a name for the constant that conatains the length of an -- array function Map_Pointer_Type_Name (E : Node_Id) return Name_Id; -- Maps a Pointer type name corresponding to the IDL type E function Map_IR_Name (E : Node_Id) return Name_Id; -- Maps the name of the IR_<...> subprogram generated in the -- IR_Info package. function Map_Cached_IR_Name (E : Node_Id) return Name_Id; -- Maps the name of the Cached_IR_<...> global variable generated -- in the IR_Info package. procedure Cast_When_Necessary (Ada_Node : in out Node_Id; IDL_Immediate_Type : Node_Id; IDL_Original_Type : Node_Id; Wrap : Boolean := False); -- Cast the Ada node to: -- a) The Ada type corresponding to IDL_Original_Type if -- IDL_Immediate_Type is a scoped name and its reference is a -- simple declarator and if IDL_Original_Type is not an Object -- type. -- b) CORBA.Object.Ref if IDL_Original_Type is an Object type and -- then if IDL_Immediate_Type is a scoped name. -- If the Wrap flag is set, the casting is done to the -- corresponding `.Sequence' type for sequence types. ---------------------------------------- -- CORBA Predefined Entities Routines -- ---------------------------------------- -- The subprograms below handle the CORBA modules and the CORBA::XXXX -- scoped names. If the 'Implem' parameter is 'True', the returned value is -- the implementation type instead of the reference type function Get_Predefined_CORBA_Entity (E : Node_Id; Implem : Boolean := False; Wrap : Boolean := False) return RE_Id; -- Return the runtime entity corresponding to the CORBA Predefined -- Entity 'E'. If E is an interface declaration node, the Implem -- indicate whether the user wants the reference type or the -- implementation type. RE_Null is returned if 'E' is not a CORBA -- Predefined Entity. If the Wrap flag is set, the returned type -- is a type for which a Wrap function has been generated. This -- flag has an effect only if he predefined entity is a CORBA -- predefined sequence type. function Map_Predefined_CORBA_Entity (E : Node_Id; Implem : Boolean := False; Wrap : Boolean := False; Withed : Boolean := True) return Node_Id; -- Use Get_Predefined_CORBA_Entity to return a designator for the -- runtime entity. No_Node is returned if 'E' is not a CORBA -- Predefined Entity. If the Withed flag is set, add a with clause -- to the current package if necessary. function Map_Predefined_CORBA_Type (E : Node_Id; Wrap : Boolean := False; Withed : Boolean := True) return Node_Id; -- Use Get_Predefined_CORBA_Entity to return a designator for the -- CORBA type associated to the runtime entity E. No_Node is -- returned if 'E' is not a CORBA Predefined Entity. If the Withed -- flag is set, add a with clause to the current package if -- necessary. function Map_Predefined_CORBA_Initialize (E : Node_Id) return Node_Id; -- Return a designator to the Initialize function corresponding to -- the CORBA Predefined Entity 'E' and No_Node if 'E' is not a -- CORBA Predefined Entity. function Map_Predefined_CORBA_IR_Function (E : Node_Id) return Node_Id; -- Return a designator to the IR_ function corresponding to -- the CORBA Predefined Entity 'E' and No_Node if 'E' is not a -- CORBA Predefined Entity. function Map_Predefined_CORBA_TC (E : Node_Id; Withed : Boolean := True) return Node_Id; -- Return a designator to the TypeCode variable corresponding to -- the CORBA Predefined Entity 'E' and No_Node if 'E' is not a -- CORBA Predefined Entity. If the Withed flag is set, add a with -- clause to the current package if necessary. function Map_Predefined_CORBA_From_Any (E : Node_Id; Withed : Boolean := True) return Node_Id; -- Return a designator to the From_Any function corresponding to -- the CORBA Predefined Entity 'E' and No_Node if 'E' is not a -- CORBA Predefined Entity. If the Withed flag is set, add a with -- clause to the current package if necessary. function Map_Predefined_CORBA_To_Any (E : Node_Id; Withed : Boolean := True) return Node_Id; -- Return a designator to the To_Any function corresponding to the -- CORBA Predefined Entity 'E' and No_Node if 'E' is not a CORBA -- Predefined Entity. If the Withed flag is set, add a with clause -- to the current package if necessary. function Map_Predefined_CORBA_To_Ref (E : Node_Id; Withed : Boolean := True) return Node_Id; -- Return a designator to the To_Ref function corresponding to the -- CORBA Predefined Interface 'E' and No_Node if 'E' is not a CORBA -- Predefined Entity. If the Withed flag is set, add a with clause -- to the current package if necessary. function Map_Predefined_CORBA_Marshaller (E : Node_Id; Withed : Boolean := True) return Node_Id; -- Return a designator to the SII marshaller procedure -- corresponding to the CORBA Predefined IDL operation 'E' and -- No_Node if 'E' is not a CORBA Predefined Entity. If the Withed -- flag is set, add a with clause to the current package if -- necessary. function Map_Predefined_CORBA_Unmarshaller (E : Node_Id; Withed : Boolean := True) return Node_Id; -- Return a designator to the SII unmarshaller procedure -- corresponding to the CORBA Predefined IDL operation 'E' and -- No_Node if 'E' is not a CORBA Predefined Entity. If the Withed -- flag is set, add a with clause to the current package if -- necessary. function Map_Predefined_CORBA_Wrap (E : Node_Id; Withed : Boolean := True) return Node_Id; -- Return a designator to the Wrap function corresponding to the -- CORBA Predefined Entity 'E' and No_Node if 'E' is not a CORBA -- Predefined Entity. If the Withed flag is set, add a with clause -- to the current package if necessary. function Map_Wrap_Element_Identifier (E : Node_Id) return Node_Id; -- Maps a defining identifier fothe wrap element function -- corresponding to the sequence type E. -------------------------- -- Inheritance Routines -- -------------------------- -- This section concerns interface inheritance. According to the -- Ada mapping specification, some entities from the parent -- interfaces must be generated "manually" (details are given -- below) The "manual" code generation occurs in the stubs, the -- helpers, the skeletons and the implementations. The subprograms -- that do this generation are not exactly the same, but are very -- similar. So the fact of generate as many subprograms as -- packages is a kind of code replication. -- The two types below designate the Visit_XXX and the Visit -- functions which are different depending on which package are we -- generating (stub, skel, helper or impl). type Visit_Procedure_One_Param_Ptr is access procedure (E : Node_Id); type Visit_Procedure_Two_Params_Ptr is access procedure (E : Node_Id; Binding : Boolean := True); -- The two procedures below generate mapping for several entities -- declared in the parent interfaces. The generation is done -- recursively. During the first recursion level, the operations -- and attributes are generated only for the second until the last -- parent. During the other recursion levels, we generate the -- operations and attributes for all parents. procedure Map_Inherited_Entities_Specs (Current_Interface : Node_Id; First_Recusrion_Level : Boolean := True; Visit_Operation_Subp : Visit_Procedure_Two_Params_Ptr; Stub : Boolean := False; Helper : Boolean := False; Skel : Boolean := False; Impl : Boolean := False); procedure Map_Inherited_Entities_Bodies (Current_Interface : Node_Id; First_Recusrion_Level : Boolean := True; Visit_Operation_Subp : Visit_Procedure_One_Param_Ptr; Stub : Boolean := False; Helper : Boolean := False; Skel : Boolean := False; Impl : Boolean := False); -- Extract from the Ada mapping specifications : -- "The definitions of types, constants, and exceptions in the -- parent package are renamed or sub-typed so that they are also -- 'inherited' in accordance with the IDL semantics." procedure Map_Additional_Entities_Specs (Parent_Interface : Node_Id; Child_Interface : Node_Id; Stub : Boolean := False; Helper : Boolean := False); procedure Map_Additional_Entities_Bodies (Parent_Interface : Node_Id; Child_Interface : Node_Id; Stub : Boolean := False; Helper : Boolean := False); ----------------------------- -- Static Request Handling -- ----------------------------- -- The subprograms below are related to the use of the SII when -- handling a request. To avoid conflicts the names of the -- entities generated have the operation name as prefix function Map_Args_Type_Identifier (E : Node_Id) return Node_Id; -- Create an Identifier for the Args record type of an operation function Map_Args_Identifier (E : Node_Id) return Node_Id; -- Create an Identifier for the Args record identifier of an -- operation function Map_Unmarshaller_Identifier (E : Node_Id) return Node_Id; -- Create an Identifier for the Unmarshaller procedure of an -- operation function Map_Marshaller_Identifier (E : Node_Id) return Node_Id; -- Create an Identifier for the Marshaller procedure of an -- operation function Map_Set_Args_Identifier (E : Node_Id) return Node_Id; -- Create an Identifier for the Set_Arg procedure of an operation function Map_Buffer_Size_Identifier (E : Node_Id) return Node_Id; -- Create an Identifier for the Buffer Size Identifier of an -- operation ------------------------------------------------- -- Routines to resolve links between the trees -- ------------------------------------------------- function Get_TC_Node (T : Node_Id; Resolve_Forward : Boolean := True) return Node_Id; -- Return the TypeCode Variable corresponding to the IDL node -- T. It handles base types and user defined types. If the -- Resolve_Forward is set and T is a forward declaration node then -- return the TypeCode of the forwarded entity. function Get_From_Any_Container_Node (T : Node_Id) return Node_Id; -- Return the additional From_Any function designator -- corresponding to the enumeration type T. It handles base types -- and user defined types. function Get_From_Any_Node (T : Node_Id; Withed : Boolean := True) return Node_Id; -- Return the From_Any function designator corresponding to the -- IDL node T. It handles base types and user defined types. If -- the Withed flag is False then the appropriate 'with' clause is -- not added. function Get_To_Any_Node (T : Node_Id; Withed : Boolean := True) return Node_Id; -- Return the To_Any function designator corresponding to the IDL -- node T. It handles base types and user defined types. If the -- Withed flag is False then the appropriate 'with' clause is not -- added. function Get_To_Ref_Node (T : Node_Id; Withed : Boolean := True) return Node_Id; -- Return the To_Ref function designator corresponding to the IDL -- interface T. If the Withed flag is False then the appropriate -- 'with' clause is not added. function Get_Marshaller_Node (O : Node_Id; Withed : Boolean := True) return Node_Id; -- Return the ..._Marshaller procedure designator corresponding to -- the IDL operation O. If the Withed flag is False then the -- appropriate 'with' clause is not added. function Get_Unmarshaller_Node (O : Node_Id; Withed : Boolean := True) return Node_Id; -- Return the ..._Unmarshaller procedure designator corresponding to -- the IDL operation O. If the Withed flag is False then the -- appropriate 'with' clause is not added. function Get_Initialize_Node (T : Node_Id; Resolve_Forward : Boolean := True) return Node_Id; -- Return the Initialize function designator corresponding to the -- IDL node T. It handles base types and user defined types. If -- the Resolve_Forward is set and T is a forward declaration node -- then return the TypeCode of the forwarded entity. function Get_Wrap_Node (T : Node_Id; Withed : Boolean := True) return Node_Id; -- Return the To_Any function designator corresponding to the IDL -- node T. It handles base types and user defined types. If the -- Withed flag is False then the appropriate 'with' clause is not -- added. function Get_Type_Definition_Node (T : Node_Id; Wrap : Boolean := False) return Node_Id; -- Return the Ada type mapped from the IDL entity T. If the Wrap -- flag is set, returs the Ada type for which a Wrap function has -- been generated (this is relevant only for sequence types). function Get_IR_Function_Node (T : Node_Id; Withed : Boolean := True) return Node_Id; -- Return the IR_ function or the corresponding predefined -- primitive corresponding to the IDL node T. It handles base -- types and user defined types. If the Withed flag is False then -- the appropriate 'with' clause is not added. type Dependent_Entity is (D_Stub, D_Helper, D_Skel); procedure Add_Dependency (Dep : Node_Id; Dependency_List : List_Id; Dependency_Kind : Dependent_Entity; Optional : Boolean := False); -- When a package is initialized by the PolyORB Initialization -- Manager, some packages this package depends on must be -- initialized before it. This procedure add the given dependency -- to the given dependency list. If 'Optional' is True, then the -- added dependency is suffixed by '?'. end Backend.BE_CORBA_Ada.IDL_To_Ada; polyorb-2.8~20110207.orig/compilers/iac/backend-be_corba_ada-ir_infos.adb0000644000175000017500000016553311750740337025362 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- B A C K E N D . B E _ C O R B A _ A D A . I R _ I N F O S -- -- -- -- B o d y -- -- -- -- Copyright (C) 2007-2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with Values; use Values; with Locations; use Locations; with Frontend.Nutils; with Frontend.Nodes; use Frontend.Nodes; with Backend.BE_CORBA_Ada.IDL_To_Ada; use Backend.BE_CORBA_Ada.IDL_To_Ada; with Backend.BE_CORBA_Ada.Nodes; use Backend.BE_CORBA_Ada.Nodes; with Backend.BE_CORBA_Ada.Nutils; use Backend.BE_CORBA_Ada.Nutils; with Backend.BE_CORBA_Ada.Runtime; use Backend.BE_CORBA_Ada.Runtime; package body Backend.BE_CORBA_Ada.IR_Infos is package FEN renames Frontend.Nodes; package BEN renames Backend.BE_CORBA_Ada.Nodes; package FEU renames Frontend.Nutils; ------------------ -- Package_Spec -- ------------------ package body Package_Spec is procedure Visit_Attribute_Declaration (E : Node_Id); procedure Visit_Enumeration_Type (E : Node_Id); procedure Visit_Exception_Declaration (E : Node_Id); procedure Visit_Interface_Declaration (E : Node_Id); procedure Visit_Module (E : Node_Id); procedure Visit_Operation_Declaration (E : Node_Id); procedure Visit_Specification (E : Node_Id); procedure Visit_Structure_Type (E : Node_Id); procedure Visit_Type_Declaration (E : Node_Id); procedure Visit_Union_Type (E : Node_Id); function IR_Function_Spec (E : Node_Id) return Node_Id; -- Create the subprogram specification of the IR_ -- function relative to the IDL entity E. function Register_IR_Info_Spec (E : Node_Id) return Node_Id; -- Create the 'Register_IR_Info' subprogram specification that -- must be generated in the IR_Info package. ---------------------- -- IR_Function_Spec -- ---------------------- function IR_Function_Spec (E : Node_Id) return Node_Id is N : Node_Id; begin N := Make_Subprogram_Specification (Defining_Identifier => Make_Defining_Identifier (Map_IR_Name (E)), Parameter_Profile => No_List, Return_Type => RE (RE_Ref_12)); return N; end IR_Function_Spec; --------------------------- -- Register_IR_Info_Spec -- --------------------------- function Register_IR_Info_Spec (E : Node_Id) return Node_Id is pragma Unreferenced (E); N : Node_Id; begin N := Make_Subprogram_Specification (Defining_Identifier => RE (RE_Register_IR_Info), Parameter_Profile => No_List, Return_Type => No_Node); return N; end Register_IR_Info_Spec; ----------- -- Visit -- ----------- procedure Visit (E : Node_Id) is begin case FEN.Kind (E) is when K_Specification => Visit_Specification (E); when K_Enumeration_Type => Visit_Enumeration_Type (E); when K_Exception_Declaration => Visit_Exception_Declaration (E); when K_Interface_Declaration => Visit_Interface_Declaration (E); when K_Operation_Declaration => Visit_Operation_Declaration (E); when K_Structure_Type => Visit_Structure_Type (E); when K_Union_Type => Visit_Union_Type (E); when K_Attribute_Declaration => Visit_Attribute_Declaration (E); when K_Type_Declaration => Visit_Type_Declaration (E); when K_Module => Visit_Module (E); when others => null; end case; end Visit; --------------------------------- -- Visit_Attribute_Declaration -- --------------------------------- procedure Visit_Attribute_Declaration (E : Node_Id) is A : Node_Id; N : Node_Id; begin A := First_Entity (Declarators (E)); while Present (A) loop N := IR_Function_Spec (A); Bind_FE_To_BE (FEN.Identifier (A), N, B_IR_Function); Append_To (Visible_Part (Current_Package), N); A := Next_Entity (A); end loop; end Visit_Attribute_Declaration; ---------------------------- -- Visit_Enumeration_Type -- ---------------------------- procedure Visit_Enumeration_Type (E : Node_Id) is N : Node_Id; begin N := IR_Function_Spec (E); Bind_FE_To_BE (FEN.Identifier (E), N, B_IR_Function); Append_To (Visible_Part (Current_Package), N); end Visit_Enumeration_Type; --------------------------------- -- Visit_Exception_Declaration -- --------------------------------- procedure Visit_Exception_Declaration (E : Node_Id) is N : Node_Id; begin N := IR_Function_Spec (E); Bind_FE_To_BE (FEN.Identifier (E), N, B_IR_Function); Append_To (Visible_Part (Current_Package), N); end Visit_Exception_Declaration; --------------------------------- -- Visit_Interface_Declaration -- --------------------------------- procedure Visit_Interface_Declaration (E : Node_Id) is N : Node_Id; begin N := BEN.Parent (Type_Def_Node (BE_Node (Identifier (E)))); Push_Entity (BEN.IDL_Unit (Package_Declaration (N))); Set_IR_Info_Spec; N := Register_IR_Info_Spec (E); Bind_FE_To_BE (FEN.Identifier (E), N, B_Register_IR_Info); Append_To (Visible_Part (Current_Package), N); N := First_Entity (Interface_Body (E)); while Present (N) loop Visit (N); N := Next_Entity (N); end loop; N := IR_Function_Spec (E); Bind_FE_To_BE (FEN.Identifier (E), N, B_IR_Function); Append_To (Visible_Part (Current_Package), N); Pop_Entity; end Visit_Interface_Declaration; ------------------ -- Visit_Module -- ------------------ procedure Visit_Module (E : Node_Id) is D : Node_Id; N : Node_Id; begin if not Map_Particular_CORBA_Parts (E, PK_IR_Info_Spec) then D := Stub_Node (BE_Node (Identifier (E))); Push_Entity (D); Set_IR_Info_Spec; N := Register_IR_Info_Spec (E); Bind_FE_To_BE (FEN.Identifier (E), N, B_Register_IR_Info); Append_To (Visible_Part (Current_Package), N); D := First_Entity (Definitions (E)); while Present (D) loop Visit (D); D := Next_Entity (D); end loop; N := IR_Function_Spec (E); Bind_FE_To_BE (FEN.Identifier (E), N, B_IR_Function); Append_To (Visible_Part (Current_Package), N); Pop_Entity; end if; end Visit_Module; --------------------------------- -- Visit_Operation_Declaration -- --------------------------------- procedure Visit_Operation_Declaration (E : Node_Id) is N : Node_Id; begin -- We do not generate IR informations for operations that -- are expanded from IDL attributes if FEN.Loc (Identifier (E)) = No_Location then return; end if; N := IR_Function_Spec (E); Bind_FE_To_BE (FEN.Identifier (E), N, B_IR_Function); Append_To (Visible_Part (Current_Package), N); end Visit_Operation_Declaration; ------------------------- -- Visit_Specification -- ------------------------- procedure Visit_Specification (E : Node_Id) is Definition : Node_Id; begin Push_Entity (Stub_Node (BE_Node (Identifier (E)))); Definition := First_Entity (Definitions (E)); while Present (Definition) loop Visit (Definition); Definition := Next_Entity (Definition); end loop; Pop_Entity; end Visit_Specification; -------------------------- -- Visit_Structure_Type -- -------------------------- procedure Visit_Structure_Type (E : Node_Id) is N : Node_Id; begin N := IR_Function_Spec (E); Bind_FE_To_BE (FEN.Identifier (E), N, B_IR_Function); Append_To (Visible_Part (Current_Package), N); end Visit_Structure_Type; ---------------------------- -- Visit_Type_Declaration -- ---------------------------- procedure Visit_Type_Declaration (E : Node_Id) is D : Node_Id; N : Node_Id; begin D := First_Entity (Declarators (E)); while Present (D) loop N := IR_Function_Spec (D); Bind_FE_To_BE (FEN.Identifier (D), N, B_IR_Function); Append_To (Visible_Part (Current_Package), N); D := Next_Entity (D); end loop; end Visit_Type_Declaration; ---------------------- -- Visit_Union_Type -- ---------------------- procedure Visit_Union_Type (E : Node_Id) is N : Node_Id; begin N := IR_Function_Spec (E); Bind_FE_To_BE (FEN.Identifier (E), N, B_IR_Function); Append_To (Visible_Part (Current_Package), N); end Visit_Union_Type; end Package_Spec; ------------------ -- Package_Body -- ------------------ package body Package_Body is procedure Visit_Attribute_Declaration (E : Node_Id); procedure Visit_Enumeration_Type (E : Node_Id); procedure Visit_Exception_Declaration (E : Node_Id); procedure Visit_Interface_Declaration (E : Node_Id); procedure Visit_Module (E : Node_Id); procedure Visit_Operation_Declaration (E : Node_Id); procedure Visit_Specification (E : Node_Id); procedure Visit_Structure_Type (E : Node_Id); procedure Visit_Type_Declaration (E : Node_Id); procedure Visit_Union_Type (E : Node_Id); function IR_Function_Body (E : Node_Id; For_Attr : Boolean := False) return Node_Id; -- Create the subprogram body of the IR_ function -- relative to the IDL entity E. If For_Attr is True and If E -- is a simple declarator, then assume a is a declarator of an -- attribute declaration. function Register_IR_Info_Body (E : Node_Id) return Node_Id; -- Create the 'Register_IR_Info' subprogram body that must be -- generated in the IR_Info package. ---------------------- -- IR_Function_Body -- ---------------------- function IR_Function_Body (E : Node_Id; For_Attr : Boolean := False) return Node_Id is Spec : constant Node_Id := Ir_Function_Node (BE_Node (Identifier (E))); Declarations : constant List_Id := New_List; Statements : constant List_Id := New_List; N : Node_Id; procedure Interface_Body; procedure Attribute_Body; procedure Declarator_Body; procedure Operation_Declaration_Body; procedure Module_Body; procedure Enumeration_Type_Body; procedure Structure_Exception_Body; procedure Union_Type_Body; procedure Parent_Container_Declaration; -- Declaration of a Container_Ref corresponding to the -- container corresponding to E's parent scope. procedure Parent_Container_Lookup; -- Statement to look up E's name in the container object -- that describes its parent scope. function Standard_Create_Parameters return List_Id; -- Create a list of the actual parameters that are common to -- all create_* operations: id, name, and version. function IDL_Type (Type_Spec : Node_Id; Declarator : Node_Id) return Node_Id; -- Creates an IDLType object reference corresponding to the -- entity declared by declarator Declarator with the type -- denoted by Type_Spec (note, for arrays Type_Spec is the -- element type.) If Declarator is No_Node, no array bounds -- are assumed. function Array_IR (Elt_Type_Spec : Node_Id; Declarator : Node_Id) return Node_Id; -- Create an ArrayDef IRObject function Fixed_IR (Type_Spec : Node_Id) return Node_Id; -- Create a FixedDef IRObject function Sequence_IR (Type_Spec : Node_Id) return Node_Id; -- Create a SequenceDef IRObject -------------------- -- Interface_Body -- -------------------- procedure Interface_Body is Inner_Dcl : constant List_Id := New_List; Inner_St : constant List_Id := New_List; Profile : constant List_Id := New_List; N : Node_Id; P : Node_Id; begin Parent_Container_Lookup; N := Make_Object_Declaration (Defining_Identifier => Make_Defining_Identifier (PN (P_Base_Ifs)), Object_Definition => RE (RE_InterfaceDefSeq)); Append_To (Inner_Dcl, N); P := First_Entity (Interface_Spec (E)); while Present (P) loop N := Make_Subprogram_Call (RE (RE_To_Ref_14), New_List (Get_IR_Function_Node (P))); N := Make_Subprogram_Call (RE (RE_To_Forward_2), New_List (N)); N := Make_Subprogram_Call (RE (RE_Append), New_List (Make_Identifier (PN (P_Base_Ifs)), N)); Append_To (Inner_St, N); P := Next_Entity (P); end loop; N := Make_Identifier (PN (P_Container_Ref)); Append_To (Profile, N); N := Make_Subprogram_Call (RE (RE_To_CORBA_String), New_List (Make_Identifier (Map_Repository_Id_Name (E)))); Append_To (Profile, N); N := Make_Subprogram_Call (RE (RE_To_CORBA_String), New_List (Make_Literal (New_String_Value (IDL_Name (Identifier (E)), False)))); Append_To (Profile, N); N := Make_Subprogram_Call (RE (RE_To_CORBA_String_2), New_List (Make_Literal (New_String_Value (Map_Type_Version (E), False)))); Append_To (Profile, N); N := Make_Identifier (PN (P_Base_Ifs)); Append_To (Profile, N); N := Make_Literal (New_Boolean_Value (False)); Append_To (Profile, N); N := Make_Subprogram_Call (RE (RE_Create_Interface), Profile); N := Make_Subprogram_Call (RE (RE_To_Ref_12), New_List (N)); N := Make_Assignment_Statement (Make_Identifier (Map_Cached_IR_Name (E)), N); Append_To (Inner_St, N); N := Make_Return_Statement (Make_Identifier (Map_Cached_IR_Name (E))); Append_To (Inner_St, N); N := Make_Block_Statement (Declarative_Part => Inner_Dcl, Statements => Inner_St); Append_To (Statements, N); end Interface_Body; --------------------- -- Declarator_Body -- --------------------- procedure Declarator_Body is D : constant Node_Id := Declaration (E); Create_Parameters : constant List_Id := Standard_Create_Parameters; Profile : constant List_Id := New_List; N : Node_Id; begin Parent_Container_Lookup; N := Make_Identifier (PN (P_Container_Ref)); Append_To (Profile, N); Append_To (Profile, First_Node (Create_Parameters)); N := Make_Parameter_Association (Make_Identifier (PN (P_Original_Type)), Make_Subprogram_Call (RE (RE_To_Forward), New_List (IDL_Type (Type_Spec (D), E)))); Append_To (Profile, N); N := Make_Subprogram_Call (RE (RE_Create_Alias), Profile); N := Make_Subprogram_Call (RE (RE_To_Ref_12), New_List (N)); N := Make_Assignment_Statement (Make_Identifier (Map_Cached_IR_Name (E)), N); Append_To (Statements, N); N := Make_Return_Statement (Make_Identifier (Map_Cached_IR_Name (E))); Append_To (Statements, N); end Declarator_Body; -------------------- -- Attribute_Body -- -------------------- procedure Attribute_Body is A : constant Node_Id := Declaration (E); Create_Parameters : constant List_Id := Standard_Create_Parameters; Profile : constant List_Id := New_List; N : Node_Id; begin Parent_Container_Lookup; N := Make_Subprogram_Call (RE (RE_To_Ref_14), New_List (Make_Identifier (PN (P_Container_Ref)))); Append_To (Profile, N); Append_To (Profile, First_Node (Create_Parameters)); N := Make_Parameter_Association (Make_Identifier (PN (P_IDL_Type)), IDL_Type (Type_Spec (A), No_Node)); Append_To (Profile, N); if Is_Readonly (A) then N := RE (RE_ATTR_READONLY); else N := RE (RE_ATTR_NORMAL); end if; N := Make_Parameter_Association (Make_Identifier (PN (P_Mode)), N); Append_To (Profile, N); N := Make_Subprogram_Call (RE (RE_Create_Attribute), Profile); N := Make_Subprogram_Call (RE (RE_To_Ref_12), New_List (N)); N := Make_Assignment_Statement (Make_Identifier (Map_Cached_IR_Name (E)), N); Append_To (Statements, N); N := Make_Return_Statement (Make_Identifier (Map_Cached_IR_Name (E))); Append_To (Statements, N); end Attribute_Body; -------------------------------- -- Operation_Declaration_Body -- -------------------------------- procedure Operation_Declaration_Body is Inner_Dcl : constant List_Id := New_List; Inner_St : constant List_Id := New_List; Create_Parameters : constant List_Id := Standard_Create_Parameters; Profile : constant List_Id := New_List; Aggr : List_Id; N : Node_Id; P : Node_Id; M : Node_Id; begin Parent_Container_Lookup; N := Make_Object_Declaration (Defining_Identifier => Make_Defining_Identifier (PN (P_Params)), Object_Definition => RE (RE_ParDescriptionSeq)); Append_To (Inner_Dcl, N); if not FEU.Is_Empty (Parameters (E)) then P := First_Entity (Parameters (E)); while Present (P) loop Aggr := New_List; N := Make_Element_Association (Make_Identifier (CN (C_Name)), Make_Subprogram_Call (RE (RE_To_CORBA_String), New_List (Make_Literal (New_String_Value (To_Ada_Name (FEN.IDL_Name (Identifier (Declarator (P)))), False))))); Append_To (Aggr, N); N := Make_Element_Association (Make_Identifier (CN (C_IDL_Type)), Get_TC_Node (Type_Spec (P))); Append_To (Aggr, N); N := Make_Element_Association (Make_Identifier (CN (C_Type_Def)), Make_Subprogram_Call (RE (RE_To_Forward), New_List (IDL_Type (Type_Spec (P), E)))); Append_To (Aggr, N); case FEN.Parameter_Mode (P) is when Mode_In => M := RE (RE_PARAM_IN); when Mode_Inout => M := RE (RE_PARAM_INOUT); when Mode_Out => M := RE (RE_PARAM_OUT); end case; N := Make_Element_Association (Make_Identifier (CN (C_Mode)), M); Append_To (Aggr, N); N := Make_Qualified_Expression (RE (RE_ParameterDescription), Make_Record_Aggregate (Aggr)); N := Make_Subprogram_Call (RE (RE_Append), New_List (Make_Identifier (PN (P_Params)), N)); Append_To (Inner_St, N); P := Next_Entity (P); end loop; end if; N := Make_Object_Declaration (Defining_Identifier => Make_Defining_Identifier (PN (P_Exceptions)), Object_Definition => RE (RE_ExceptionDefSeq)); Append_To (Inner_Dcl, N); -- XXX TODO -- if FEU.Is_Empty (Exceptions (E)) then -- X := First_Entity (Exceptions (E)); -- while Present (X) loop -- X := Next_Entity (X); -- end loop; -- end if; N := Make_Object_Declaration (Defining_Identifier => Make_Defining_Identifier (PN (P_Contexts)), Object_Definition => RE (RE_ContextIdSeq)); Append_To (Inner_Dcl, N); -- XXX TODO -- if FEU.Is_Empty (Contexts (E)) then -- C := First_Entity (Exceptions (E)); -- while Present (C) loop -- C := Next_Entity (C); -- end loop; -- end if; N := Make_Subprogram_Call (RE (RE_To_Ref_14), New_List (Make_Identifier (PN (P_Container_Ref)))); Append_To (Profile, N); Append_To (Profile, First_Node (Create_Parameters)); N := Make_Parameter_Association (Make_Identifier (PN (P_Result)), Make_Subprogram_Call (RE (RE_To_Ref_15), New_List (Get_IR_Function_Node (Type_Spec (E))))); Append_To (Profile, N); if Is_Oneway (E) then M := RE (RE_OP_ONEWAY); else M := RE (RE_OP_NORMAL); end if; N := Make_Parameter_Association (Make_Identifier (PN (P_Mode)), M); Append_To (Profile, N); N := Make_Parameter_Association (Make_Identifier (PN (P_Params)), Make_Identifier (PN (P_Params))); Append_To (Profile, N); N := Make_Parameter_Association (Make_Identifier (PN (P_Exceptions)), Make_Identifier (PN (P_Exceptions))); Append_To (Profile, N); N := Make_Parameter_Association (Make_Identifier (PN (P_Contexts)), Make_Identifier (PN (P_Contexts))); Append_To (Profile, N); N := Make_Subprogram_Call (RE (RE_Create_Operation), Profile); N := Make_Subprogram_Call (RE (RE_To_Ref_12), New_List (N)); N := Make_Assignment_Statement (Make_Identifier (Map_Cached_IR_Name (E)), N); Append_To (Inner_St, N); N := Make_Return_Statement (Make_Identifier (Map_Cached_IR_Name (E))); Append_To (Inner_St, N); N := Make_Block_Statement (Declarative_Part => Inner_Dcl, Statements => Inner_St); Append_To (Statements, N); end Operation_Declaration_Body; ----------------- -- Module_Body -- ----------------- procedure Module_Body is Profile : constant List_Id := New_List; N : Node_Id; begin Parent_Container_Lookup; N := Make_Identifier (PN (P_Container_Ref)); Append_To (Profile, N); N := Make_Subprogram_Call (RE (RE_To_CORBA_String), New_List (Make_Identifier (Map_Repository_Id_Name (E)))); Append_To (Profile, N); N := Make_Subprogram_Call (RE (RE_To_CORBA_String), New_List (Make_Literal (New_String_Value (IDL_Name (Identifier (E)), False)))); Append_To (Profile, N); N := Make_Subprogram_Call (RE (RE_To_CORBA_String_2), New_List (Make_Literal (New_String_Value (Map_Type_Version (E), False)))); Append_To (Profile, N); N := Make_Subprogram_Call (RE (RE_Create_Module), Profile); N := Make_Subprogram_Call (RE (RE_To_Ref_12), New_List (N)); N := Make_Assignment_Statement (Make_Identifier (Map_Cached_IR_Name (E)), N); Append_To (Statements, N); N := Make_Return_Statement (Make_Identifier (Map_Cached_IR_Name (E))); Append_To (Statements, N); end Module_Body; --------------------------- -- Enumeration_Type_Body -- --------------------------- procedure Enumeration_Type_Body is Inner_Dcl : constant List_Id := New_List; Inner_St : constant List_Id := New_List; Profile : constant List_Id := New_List; N : Node_Id; Enumerator : Node_Id; begin Parent_Container_Lookup; N := Make_Object_Declaration (Defining_Identifier => Make_Defining_Identifier (PN (P_Members)), Object_Definition => RE (RE_EnumMemberSeq)); Append_To (Inner_Dcl, N); Enumerator := First_Entity (Enumerators (E)); while Present (Enumerator) loop N := Make_Subprogram_Call (RE (RE_Append), New_List (Make_Identifier (PN (P_Members)), Make_Subprogram_Call (RE (RE_To_CORBA_String), New_List (Make_Literal (New_String_Value (To_Ada_Name (IDL_Name (Identifier (Enumerator))), False)))))); Append_To (Inner_St, N); Enumerator := Next_Entity (Enumerator); end loop; N := Make_Identifier (PN (P_Container_Ref)); Append_To (Profile, N); N := Make_Subprogram_Call (RE (RE_To_CORBA_String), New_List (Make_Identifier (Map_Repository_Id_Name (E)))); Append_To (Profile, N); N := Make_Subprogram_Call (RE (RE_To_CORBA_String), New_List (Make_Literal (New_String_Value (IDL_Name (Identifier (E)), False)))); Append_To (Profile, N); N := Make_Subprogram_Call (RE (RE_To_CORBA_String_2), New_List (Make_Literal (New_String_Value (Map_Type_Version (E), False)))); Append_To (Profile, N); N := Make_Identifier (PN (P_Members)); Append_To (Profile, N); N := Make_Subprogram_Call (RE (RE_Create_Enum), Profile); N := Make_Subprogram_Call (RE (RE_To_Ref_12), New_List (N)); N := Make_Assignment_Statement (Make_Identifier (Map_Cached_IR_Name (E)), N); Append_To (Inner_St, N); N := Make_Return_Statement (Make_Identifier (Map_Cached_IR_Name (E))); Append_To (Inner_St, N); N := Make_Block_Statement (Declarative_Part => Inner_Dcl, Statements => Inner_St); Append_To (Statements, N); end Enumeration_Type_Body; ------------------------------ -- Structure_Exception_Body -- ------------------------------ procedure Structure_Exception_Body is Inner_Dcl : constant List_Id := New_List; Inner_St : constant List_Id := New_List; Create_Parameters : constant List_Id := Standard_Create_Parameters; Profile : constant List_Id := New_List; Aggr : List_Id; N : Node_Id; Member : Node_Id; Declarator : Node_Id; C : Node_Id; begin Parent_Container_Lookup; N := Make_Object_Declaration (Defining_Identifier => Make_Defining_Identifier (PN (P_Members)), Object_Definition => RE (RE_StructMemberSeq)); Append_To (Inner_Dcl, N); Member := First_Entity (Members (E)); while Present (Member) loop Declarator := First_Entity (Declarators (Member)); while Present (Declarator) loop Aggr := New_List; N := Make_Element_Association (Make_Identifier (CN (C_Name)), Make_Subprogram_Call (RE (RE_To_CORBA_String), New_List (Make_Literal (New_String_Value (To_Ada_Name (FEN.IDL_Name (Identifier (Declarator))), False))))); Append_To (Aggr, N); N := Make_Element_Association (Make_Identifier (CN (C_IDL_Type)), Get_TC_Node (Type_Spec (Member))); Append_To (Aggr, N); N := Make_Element_Association (Make_Identifier (CN (C_Type_Def)), Make_Subprogram_Call (RE (RE_To_Forward), New_List (IDL_Type (Type_Spec (Member), Declarator)))); Append_To (Aggr, N); N := Make_Qualified_Expression (RE (RE_StructMember), Make_Record_Aggregate (Aggr)); N := Make_Subprogram_Call (RE (RE_Append), New_List (Make_Identifier (PN (P_Members)), N)); Append_To (Inner_St, N); Declarator := Next_Entity (Declarator); end loop; Member := Next_Entity (Member); end loop; N := Make_Identifier (PN (P_Container_Ref)); Append_To (Profile, N); Append_To (Profile, First_Node (Create_Parameters)); N := Make_Parameter_Association (Make_Identifier (PN (P_Members)), Make_Identifier (PN (P_Members))); Append_To (Profile, N); if FEN.Kind (E) = K_Structure_Type then C := RE (RE_Create_Struct); else C := RE (RE_Create_Exception); end if; N := Make_Subprogram_Call (C, Profile); N := Make_Subprogram_Call (RE (RE_To_Ref_12), New_List (N)); N := Make_Assignment_Statement (Make_Identifier (Map_Cached_IR_Name (E)), N); Append_To (Inner_St, N); N := Make_Return_Statement (Make_Identifier (Map_Cached_IR_Name (E))); Append_To (Inner_St, N); N := Make_Block_Statement (Declarative_Part => Inner_Dcl, Statements => Inner_St); Append_To (Statements, N); end Structure_Exception_Body; --------------------- -- Union_Type_Body -- --------------------- procedure Union_Type_Body is Inner_Dcl : constant List_Id := New_List; Inner_St : constant List_Id := New_List; Create_Parameters : constant List_Id := Standard_Create_Parameters; Profile : constant List_Id := New_List; Orig_Type : constant Node_Id := FEU.Get_Original_Type_Specifier (Switch_Type_Spec (E)); Switch_Type : Node_Id; Literal_Parent : Node_Id := No_Node; Aggr : List_Id; N : Node_Id; Alternative : Node_Id; Label : Node_Id; begin if Is_Base_Type (Switch_Type_Spec (E)) then Switch_Type := RE (Convert (FEN.Kind (Switch_Type_Spec (E)))); elsif FEN.Kind (Orig_Type) = K_Enumeration_Type then Switch_Type := Map_Expanded_Name (Switch_Type_Spec (E)); Literal_Parent := Map_Expanded_Name (Scope_Entity (Identifier (Orig_Type))); else Switch_Type := Map_Expanded_Name (Switch_Type_Spec (E)); end if; Parent_Container_Lookup; N := Make_Object_Declaration (Defining_Identifier => Make_Defining_Identifier (PN (P_Members)), Object_Definition => RE (RE_UnionMemberSeq)); Append_To (Inner_Dcl, N); Alternative := First_Entity (Switch_Type_Body (E)); while Present (Alternative) loop Label := First_Entity (Labels (Alternative)); while Present (Label) loop Aggr := New_List; N := Make_Element_Association (Make_Identifier (CN (C_Name)), Make_Subprogram_Call (RE (RE_To_CORBA_String), New_List (Make_Literal (New_String_Value (To_Ada_Name (FEN.IDL_Name (Identifier (Declarator (Element (Alternative))))), False))))); Append_To (Aggr, N); if FEU.Expr_Value (Label) = No_Value then N := Make_Subprogram_Call (RE (RE_To_Any_0), New_List (Make_Qualified_Expression (RE (RE_Octet), Make_Literal (Int0_Val)))); else N := Make_Subprogram_Call (Get_To_Any_Node (Switch_Type_Spec (E)), New_List (Make_Qualified_Expression (Switch_Type, Make_Literal_With_Parent (FEU.Expr_Value (Label), Parent => Literal_Parent)))); end if; N := Make_Parameter_Association (Make_Identifier (PN (P_Label)), N); Append_To (Aggr, N); N := Make_Element_Association (Make_Identifier (CN (C_IDL_Type)), Get_TC_Node (Type_Spec (Element (Alternative)))); Append_To (Aggr, N); N := Make_Element_Association (Make_Identifier (CN (C_Type_Def)), Make_Subprogram_Call (RE (RE_To_Forward), New_List (IDL_Type (Type_Spec (Element (Alternative)), Declarator (Element (Alternative)))))); Append_To (Aggr, N); N := Make_Qualified_Expression (RE (RE_UnionMember), Make_Record_Aggregate (Aggr)); N := Make_Subprogram_Call (RE (RE_Append), New_List (Make_Identifier (PN (P_Members)), N)); Append_To (Inner_St, N); Label := Next_Entity (Label); end loop; Alternative := Next_Entity (Alternative); end loop; N := Make_Identifier (PN (P_Container_Ref)); Append_To (Profile, N); Append_To (Profile, First_Node (Create_Parameters)); N := Make_Parameter_Association (Make_Identifier (PN (P_Discriminator_Type)), Make_Subprogram_Call (RE (RE_To_Forward), New_List (Make_Subprogram_Call (RE (RE_To_Ref_15), New_List (Get_IR_Function_Node (Switch_Type_Spec (E))))))); Append_To (Profile, N); N := Make_Parameter_Association (Make_Identifier (PN (P_Members)), Make_Identifier (PN (P_Members))); Append_To (Profile, N); N := Make_Subprogram_Call (RE (RE_Create_Union), Profile); N := Make_Subprogram_Call (RE (RE_To_Ref_12), New_List (N)); N := Make_Assignment_Statement (Make_Identifier (Map_Cached_IR_Name (E)), N); Append_To (Inner_St, N); N := Make_Return_Statement (Make_Identifier (Map_Cached_IR_Name (E))); Append_To (Inner_St, N); N := Make_Block_Statement (Declarative_Part => Inner_Dcl, Statements => Inner_St); Append_To (Statements, N); end Union_Type_Body; ---------------------------------- -- Parent_Container_Declaration -- ---------------------------------- procedure Parent_Container_Declaration is Parent_Scope : constant Node_Id := Scope_Entity (FEN.Identifier (E)); Parent_Scope_Kind : constant FEN.Node_Kind := FEN.Kind (Parent_Scope); N : Node_Id; Expression : Node_Id; begin if Parent_Scope_Kind /= K_Interface_Declaration and then Parent_Scope_Kind /= K_Value_Declaration and then Parent_Scope_Kind /= K_Module then Expression := Make_Subprogram_Call (RE (RE_To_Ref_13), New_List (RE (RE_Get_IR_Root))); else -- Parent_Scope corresponds to a container in the IR -- sense. Expression := Make_Subprogram_Call (RE (RE_To_Ref_13), New_List (Get_IR_Function_Node (Parent_Scope))); end if; N := Make_Object_Declaration (Defining_Identifier => Make_Defining_Identifier (PN (P_Container_Ref)), Constant_Present => True, Object_Definition => RE (RE_Ref_13), Expression => Expression); Append_To (Declarations, N); end Parent_Container_Declaration; ----------------------------- -- Parent_Container_Lookup -- ----------------------------- procedure Parent_Container_Lookup is N : Node_Id; begin N := Make_Subprogram_Call (RE (RE_To_CORBA_String), New_List (Make_Literal (New_String_Value (IDL_Name (Identifier (E)), False)))); N := Make_Subprogram_Call (RE (RE_Lookup), New_List (Make_Identifier (PN (P_Container_Ref)), N)); N := Make_Subprogram_Call (RE (RE_To_Ref_12), New_List (N)); N := Make_Assignment_Statement (Make_Identifier (Map_Cached_IR_Name (E)), N); Append_To (Statements, N); N := Make_If_Statement (Condition => Make_Expression (Make_Subprogram_Call (RE (RE_Is_Nil_12), New_List (Make_Identifier (Map_Cached_IR_Name (E)))), Op_Not), Then_Statements => New_List (Make_Return_Statement (Make_Identifier (Map_Cached_IR_Name (E))))); Append_To (Statements, N); end Parent_Container_Lookup; -------------------------------- -- Standard_Create_Parameters -- -------------------------------- function Standard_Create_Parameters return List_Id is Result : constant List_Id := New_List; begin N := Make_Subprogram_Call (RE (RE_To_CORBA_String), New_List (Make_Literal (New_String_Value (Map_Repository_Id_Name (E), False)))); N := Make_Parameter_Association (Make_Identifier (PN (P_Id)), N); Append_To (Result, N); N := Make_Subprogram_Call (RE (RE_To_CORBA_String), New_List (Make_Literal (New_String_Value (IDL_Name (Identifier (E)), False)))); N := Make_Parameter_Association (Make_Identifier (PN (P_Name)), N); Append_To (Result, N); N := Make_Subprogram_Call (RE (RE_To_CORBA_String_2), New_List (Make_Literal (New_String_Value (Map_Type_Version (E), False)))); N := Make_Parameter_Association (Make_Identifier (PN (P_Version)), N); Append_To (Result, N); return Result; end Standard_Create_Parameters; -------------- -- IDL_Type -- -------------- function IDL_Type (Type_Spec : Node_Id; Declarator : Node_Id) return Node_Id is Original_Type_Spec : constant Node_Id := FEU.Get_Original_Type_Specifier (Type_Spec); Is_Array : constant Boolean := Present (Declarator) and then FEN.Kind (Declarator) = K_Complex_Declarator; begin if Is_Array then return Array_IR (Original_Type_Spec, FEU.Get_Original_Type_Declarator (Declarator)); else case FEN.Kind (Original_Type_Spec) is when K_Fixed_Point_Type => return Fixed_IR (Original_Type_Spec); when K_Sequence_Type => return Sequence_IR (Original_Type_Spec); when others => return Make_Subprogram_Call (RE (RE_To_Ref_15), New_List (Get_IR_Function_Node (FEU.Get_Original_Type_Declarator (Type_Spec)))); end case; end if; end IDL_Type; -------------- -- Array_IR -- -------------- function Array_IR (Elt_Type_Spec : Node_Id; Declarator : Node_Id) return Node_Id is function Rec_Array_IR (Dim : Node_Id) return Node_Id; ------------------ -- Rec_Array_IR -- ------------------ function Rec_Array_IR (Dim : Node_Id) return Node_Id is N : Node_Id; Profile : constant List_Id := New_List; V : Value_Type; begin N := Make_Subprogram_Call (RE (RE_Get_IR_Root), No_List); Append_To (Profile, N); V := FEU.Expr_Value (Dim); N := Make_Parameter_Association (Make_Identifier (PN (P_Length)), Make_Literal (New_Value (V))); Append_To (Profile, N); if Present (Next_Entity (Dim)) then N := Rec_Array_IR (Next_Entity (Dim)); else N := Make_Subprogram_Call (RE (RE_To_Ref_15), New_List (Get_IR_Function_Node (Elt_Type_Spec))); end if; N := Make_Parameter_Association (Make_Identifier (PN (P_Element_Type)), N); Append_To (Profile, N); N := Make_Subprogram_Call (RE (RE_Create_Array), Profile); N := Make_Subprogram_Call (RE (RE_To_Ref_15), New_List (N)); return N; end Rec_Array_IR; L : constant List_Id := Array_Sizes (Declarator); begin return Rec_Array_IR (First_Entity (L)); end Array_IR; -------------- -- Fixed_IR -- -------------- function Fixed_IR (Type_Spec : Node_Id) return Node_Id is N : Node_Id; Profile : constant List_Id := New_List; begin N := Make_Subprogram_Call (RE (RE_Get_IR_Root), No_List); Append_To (Profile, N); N := Make_Parameter_Association (Make_Identifier (PN (P_IDL_Digits)), Make_Literal (New_Integer_Value (Unsigned_Long_Long (FEN.N_Total (Type_Spec)), 1, 10))); Append_To (Profile, N); N := Make_Parameter_Association (Make_Identifier (PN (P_Scale)), Make_Literal (New_Integer_Value (Unsigned_Long_Long (FEN.N_Scale (Type_Spec)), 1, 10))); Append_To (Profile, N); N := Make_Subprogram_Call (RE (RE_Create_Fixed), Profile); N := Make_Subprogram_Call (RE (RE_To_Ref_15), New_List (N)); return N; end Fixed_IR; ----------------- -- Sequence_IR -- ----------------- function Sequence_IR (Type_Spec : Node_Id) return Node_Id is N : Node_Id; Profile : constant List_Id := New_List; Bounded : constant Boolean := Present (Max_Size (Type_Spec)); Elt_Type : constant Node_Id := FEN.Type_Spec (Type_Spec); V : Value_Id; begin N := Make_Subprogram_Call (RE (RE_Get_IR_Root), No_List); Append_To (Profile, N); if Bounded then V := FEU.Expr_Value (Max_Size (Type_Spec)); else V := Int0_Val; end if; N := Make_Parameter_Association (Make_Identifier (PN (P_Bound)), Make_Literal (V)); Append_To (Profile, N); N := Make_Parameter_Association (Make_Identifier (PN (P_Element_Type)), IDL_Type (FEU.Get_Original_Type_Specifier (Elt_Type), No_Node)); Append_To (Profile, N); N := Make_Subprogram_Call (RE (RE_Create_Sequence), Profile); N := Make_Subprogram_Call (RE (RE_To_Ref_15), New_List (N)); return N; end Sequence_IR; begin -- Declare the Cached_IR_ global variable N := Make_Object_Declaration (Defining_Identifier => Make_Defining_Identifier (Map_Cached_IR_Name (E)), Object_Definition => RE (RE_Ref_12)); Append_To (BEN.Statements (Current_Package), N); -- Common declarations and statements Parent_Container_Declaration; N := Make_If_Statement (Condition => Make_Expression (Make_Subprogram_Call (RE (RE_Is_Nil_12), New_List (Make_Identifier (Map_Cached_IR_Name (E)))), Op_Not), Then_Statements => New_List (Make_Return_Statement (Make_Identifier (Map_Cached_IR_Name (E))))); Append_To (Statements, N); case FEN.Kind (E) is when K_Interface_Declaration => Interface_Body; when K_Simple_Declarator => if For_Attr then Attribute_Body; else Declarator_Body; end if; when K_Complex_Declarator => Declarator_Body; when K_Operation_Declaration => Operation_Declaration_Body; when K_Module => Module_Body; when K_Enumeration_Type => Enumeration_Type_Body; when K_Structure_Type => Structure_Exception_Body; when K_Union_Type => Union_Type_Body; when K_Exception_Declaration => Structure_Exception_Body; when others => raise Program_Error; end case; -- Add the corresponding block statement to the body of -- Register_IR_Info. declare Register_IR_Info_St : constant List_Id := Get_GList (Package_Declaration (Current_Package), GL_Register_IR_Info); Dcl : constant List_Id := New_List; begin N := Make_Object_Declaration (Defining_Identifier => Make_Defining_Identifier (PN (P_Dummy)), Constant_Present => True, Object_Definition => Make_Attribute_Reference (RE (RE_Ref_2), A_Class), Expression => Get_IR_Function_Node (E)); Append_To (Dcl, N); N := Make_Pragma (Pragma_Unreferenced, New_List (Make_Identifier (PN (P_Dummy)))); Append_To (Dcl, N); N := Make_Block_Statement (Declarative_Part => Dcl, Statements => New_List (Make_Null_Statement)); Append_To (Register_IR_Info_St, N); end; N := Make_Subprogram_Body (Spec, Declarations, Statements); return N; end IR_Function_Body; --------------------------- -- Register_IR_Info_Body -- --------------------------- function Register_IR_Info_Body (E : Node_Id) return Node_Id is Spec : constant Node_Id := Register_Ir_Info_Node (BE_Node (Identifier (E))); Statements : constant List_Id := Get_GList (Package_Declaration (Current_Package), GL_Register_IR_Info); begin return Make_Subprogram_Body (Spec, No_List, Statements); end Register_IR_Info_Body; ----------- -- Visit -- ----------- procedure Visit (E : Node_Id) is begin case FEN.Kind (E) is when K_Specification => Visit_Specification (E); when K_Enumeration_Type => Visit_Enumeration_Type (E); when K_Exception_Declaration => Visit_Exception_Declaration (E); when K_Interface_Declaration => Visit_Interface_Declaration (E); when K_Operation_Declaration => Visit_Operation_Declaration (E); when K_Structure_Type => Visit_Structure_Type (E); when K_Union_Type => Visit_Union_Type (E); when K_Attribute_Declaration => Visit_Attribute_Declaration (E); when K_Type_Declaration => Visit_Type_Declaration (E); when K_Module => Visit_Module (E); when others => null; end case; end Visit; --------------------------------- -- Visit_Attribute_Declaration -- --------------------------------- procedure Visit_Attribute_Declaration (E : Node_Id) is N : Node_Id; A : Node_Id; begin A := First_Entity (Declarators (E)); while Present (A) loop N := IR_Function_Body (A, For_Attr => True); Append_To (Statements (Current_Package), N); A := Next_Entity (A); end loop; end Visit_Attribute_Declaration; ---------------------------- -- Visit_Enumeration_Type -- ---------------------------- procedure Visit_Enumeration_Type (E : Node_Id) is N : Node_Id; begin N := IR_Function_Body (E); Append_To (Statements (Current_Package), N); end Visit_Enumeration_Type; --------------------------------- -- Visit_Exception_Declaration -- --------------------------------- procedure Visit_Exception_Declaration (E : Node_Id) is N : Node_Id; begin N := IR_Function_Body (E); Append_To (Statements (Current_Package), N); end Visit_Exception_Declaration; --------------------------------- -- Visit_Interface_Declaration -- --------------------------------- procedure Visit_Interface_Declaration (E : Node_Id) is N : Node_Id; begin N := BEN.Parent (Type_Def_Node (BE_Node (Identifier (E)))); Push_Entity (BEN.IDL_Unit (Package_Declaration (N))); Set_IR_Info_Body; -- Statements of the Register_IR_Info body Initialize_GList (Package_Declaration (Current_Package), GL_Register_IR_Info); N := First_Entity (Interface_Body (E)); while Present (N) loop Visit (N); N := Next_Entity (N); end loop; N := IR_Function_Body (E); Append_To (Statements (Current_Package), N); N := Register_IR_Info_Body (E); Append_To (Statements (Current_Package), N); Pop_Entity; end Visit_Interface_Declaration; ------------------ -- Visit_Module -- ------------------ procedure Visit_Module (E : Node_Id) is D : Node_Id; N : Node_Id; begin if not Map_Particular_CORBA_Parts (E, PK_IR_Info_Body) then D := Stub_Node (BE_Node (Identifier (E))); Push_Entity (D); Set_IR_Info_Body; -- Statements of the Register_IR_Info body Initialize_GList (Package_Declaration (Current_Package), GL_Register_IR_Info); D := First_Entity (Definitions (E)); while Present (D) loop Visit (D); D := Next_Entity (D); end loop; N := IR_Function_Body (E); Append_To (Statements (Current_Package), N); N := Register_IR_Info_Body (E); Append_To (Statements (Current_Package), N); Pop_Entity; end if; end Visit_Module; --------------------------------- -- Visit_Operation_Declaration -- --------------------------------- procedure Visit_Operation_Declaration (E : Node_Id) is N : Node_Id; begin -- We do not generate IR informations for operations that -- are expanded from IDL attributes if FEN.Loc (Identifier (E)) = No_Location then return; end if; N := IR_Function_Body (E); Append_To (Statements (Current_Package), N); end Visit_Operation_Declaration; ------------------------- -- Visit_Specification -- ------------------------- procedure Visit_Specification (E : Node_Id) is Definition : Node_Id; begin Push_Entity (Stub_Node (BE_Node (Identifier (E)))); Definition := First_Entity (Definitions (E)); while Present (Definition) loop Visit (Definition); Definition := Next_Entity (Definition); end loop; Pop_Entity; end Visit_Specification; -------------------------- -- Visit_Structure_Type -- -------------------------- procedure Visit_Structure_Type (E : Node_Id) is N : Node_Id; begin N := IR_Function_Body (E); Append_To (Statements (Current_Package), N); end Visit_Structure_Type; ---------------------------- -- Visit_Type_Declaration -- ---------------------------- procedure Visit_Type_Declaration (E : Node_Id) is D : Node_Id; N : Node_Id; begin D := First_Entity (Declarators (E)); while Present (D) loop N := IR_Function_Body (D); Append_To (Statements (Current_Package), N); D := Next_Entity (D); end loop; end Visit_Type_Declaration; ---------------------- -- Visit_Union_Type -- ---------------------- procedure Visit_Union_Type (E : Node_Id) is N : Node_Id; begin N := IR_Function_Body (E); Append_To (Statements (Current_Package), N); end Visit_Union_Type; end Package_Body; end Backend.BE_CORBA_Ada.IR_Infos; polyorb-2.8~20110207.orig/compilers/iac/.gdbinit0000644000175000017500000000010111750740337020552 0ustar xavierxavierb exception b display_error define wi call w_node_id (1, $$) end polyorb-2.8~20110207.orig/compilers/iac/backend-be_corba_ada-buffers.ads0000644000175000017500000000526011750740337025215 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- B A C K E N D . B E _ C O R B A _ A D A . B U F F E R S -- -- -- -- S p e c -- -- -- -- Copyright (C) 2005-2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- This package contains routines related to the use of the SII with -- buffer pre-allocation in the distributed application. For each -- operation (or attribute accessor), a subprogram that compute the -- buffer size is generated -- The routines in this package avoid the allocation of marshalling -- buffers by part to decrease the number of system calls (allocate) -- in goal to enhance distributed application performances package Backend.BE_CORBA_Ada.Buffers is package Package_Spec is procedure Visit (E : Node_Id); end Package_Spec; package Package_Body is procedure Visit (E : Node_Id); end Package_Body; end Backend.BE_CORBA_Ada.Buffers; polyorb-2.8~20110207.orig/compilers/iac/backend-config.adb0000644000175000017500000000545711750740337022456 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- B A C K E N D . C O N F I G -- -- -- -- B o d y -- -- -- -- Copyright (C) 2005-2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with Backend.BE_CORBA_Ada; with Backend.BE_IDL; with Backend.BE_Types; package body Backend.Config is ---------------- -- Initialize -- ---------------- procedure Initialize is begin Register_Language (BE_IDL.Generate'Access, BE_IDL.Usage'Access, "idl", "Dump parsed IDL file"); Register_Language (BE_CORBA_Ada.Generate'Access, BE_CORBA_Ada.Usage'Access, "ada", "(default) Generate Ada source code"); Register_Language (BE_Types.Generate'Access, BE_Types.Usage'Access, "types", "Generate a list of all types present in the IDL file"); -- Now set the current language to the default Set_Current_Language ("ada"); end Initialize; end Backend.Config; polyorb-2.8~20110207.orig/compilers/iac/backend-config.ads0000644000175000017500000000412011750740337022461 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- B A C K E N D . C O N F I G -- -- -- -- S p e c -- -- -- -- Copyright (C) 2004-2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ package Backend.Config is procedure Initialize; end Backend.Config; polyorb-2.8~20110207.orig/compilers/iac/frontend-nutils.ads0000644000175000017500000001703311750740337022771 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- F R O N T E N D . N U T I L S -- -- -- -- S p e c -- -- -- -- Copyright (C) 2005-2009, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with Lexer; use Lexer; with Locations; use Locations; with Types; use Types; with Values; with Frontend.Nodes; use Frontend.Nodes; package Frontend.Nutils is procedure Check_Identifier (Ref, Def : Node_Id); -- Return true when L and R have the same IDL names function First_Homonym (N : Node_Id) return Node_Id; procedure Set_First_Homonym (N : Node_Id; V : Node_Id); procedure Append_To (L : List_Id; E : Node_Id); -- Append node E to list L. procedure Insert_After_Node (E : Node_Id; N : Node_Id); -- Insert node E after node N procedure Insert_Before_Node (E : Node_Id; N : Node_Id; L : List_Id; Success : out Boolean); procedure Insert_Before_Node (E : Node_Id; N : Node_Id; L : List_Id); -- Insert node E before node N in list L. The form with Success returns -- True in Success if N was inserted, and False if E is not in list L. The -- other one requires that E is in L. procedure Remove_Node_From_List (E : Node_Id; L : List_Id); -- Remove node N to list L. -- This function returns a fully qualified name of an Identifier. function Fully_Qualified_Name (E : Node_Id; Separator : String := "::") return Name_Id; function Length (L : List_Id) return Natural; function Is_Empty (L : List_Id) return Boolean; pragma Inline (Is_Empty); -- Return true when L is empty function Is_A_Forward_Of (X, Y : Node_Id) return Boolean; function Is_A_Scope (E : Node_Id) return Boolean; function Is_Type (E : Node_Id) return Boolean; function Is_Noninterface_Type (E : Node_Id) return Boolean; function Is_Attribute_Or_Operation (E : Node_Id) return Boolean; function Is_Interface_Redefinable_Node (E : Node_Id) return Boolean; function Is_A_Non_Module (E : Node_Id) return Boolean; function Is_A_Local_Type (E : Node_Id) return Boolean; function Is_Multidimensional_Array (D : Node_Id) return Boolean; function Is_Parent (Parent : Node_Id; Child : Node_Id; First : Boolean := False) return Boolean; -- This function returns True if the "Parent" node is a parent -- interface of the "Child" node. If First is true, the test is -- performed only at the first position in the interface spec of -- the child node. function Is_Redefined (Entity : Node_Id; In_Interface : Node_Id) return Boolean; -- This function returns True if there is already an entity having -- the same name as "Entity" in "In_Interface". It returns False -- otherwise. function Get_Original_Type_Declarator (E : Node_Id) return Node_Id; -- This function returns the Original type declarator -- corresponding to the IDL node E. The original type declarator -- is a complex declarator, or a simple declarator for which the -- type specifier is *not* a scoped name. function Get_Original_Type_Declaration (E : Node_Id) return Node_Id; -- This function returns the type declaration node corresponding -- to the original type declarator of E. function Get_Original_Type_Specifier (E : Node_Id) return Node_Id; -- If the original type declarator of E is a simple declarator, -- this function return its type specifier. Otherwise it returns -- the original type declarator of E. function Has_Local_Component (E : Node_Id) return Boolean; -- Return True if the node E is a local interface, is defined -- basing on a local interface op else if it contains local -- interface as subcomponent (structure/.exception member or union -- element). function New_Node (Kind : Node_Kind; Loc : Location) return Node_Id; function New_List (Loc : Location) return List_Id; function New_Copy (N : Node_Id) return Node_Id; procedure Bind_Identifier_To_Entity (N : Node_Id; E : Node_Id); procedure Bind_Declarator_To_Entity (D : Node_Id; E : Node_Id); procedure Bind_Declarators_To_Entity (D : List_Id; E : Node_Id); function Operator (E : Node_Id) return Operator_Type; procedure Set_Operator (E : Node_Id; O : Operator_Type); function Parameter_Mode (T : Token_Type) return Mode_Id; function Parameter_Mode (M : Mode_Id) return Token_Type; function Get_Pragma_Type (T : Token_Type) return Pragma_Type; function Get_Pragma_Type (P : Pragma_Type) return Token_Type; function Make_Scoped_Name (Loc : Location; Identifier : Node_Id; Parent : Node_Id; Reference : Node_Id) return Node_Id; -- Return a scoped name function Make_Identifier (Loc : Location; IDL_Name : Name_Id; Node : Node_Id; Scope_Entity : Node_Id) return Node_Id; -- return identifier function Make_Constant_Declaration (Loc : Location; Type_Spec : Node_Id; Identifier : Node_Id; Expression : Node_Id) return Node_Id; -- Return constant declaration function Expr_Value (N : Node_Id) return Value_Id; -- Returns the value of an expression, constant, or label node. This is -- just Frontend.Nodes.Value, except in the case of a K_Scoped_Name, in -- which case we have to get the Reference first. Possible alternative -- design: attach the Value attribute to scoped name nodes as well, and -- copy it over from the constant during analysis. We choose not to do that -- because scoped names can refer to other things as well -- things that -- have no "value". function Expr_Value (N : Node_Id) return Values.Value_Type; -- Same as previous Expr_Value, except fetches the Values.Value of the -- Valid_Id. end Frontend.Nutils; polyorb-2.8~20110207.orig/compilers/iac/backend.ads0000644000175000017500000000614211750740337021224 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- B A C K E N D -- -- -- -- S p e c -- -- -- -- Copyright (C) 2005-2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with Types; use Types; package Backend is procedure Set_Current_Language (Language : String); -- Set the current language. function Current_Language return String; -- Return language previously set. Must not be called until after -- Backend.Config.Initialize. type Generate_Procedure is access procedure (IDL_Spec : Node_Id); procedure Generate (IDL_Spec : Node_Id); -- Generate code for the current language. type Usage_Procedure is access procedure (Indent : Natural); procedure Register_Language (Generate : Generate_Procedure; Usage : Usage_Procedure; Language : String; Comments : String); -- Register a new language with its code generation procedure, its -- name and a comment associated to it (for usage output). function Is_Valid_Language (L : String) return Boolean; -- Return True when there is a backend corresponding to L procedure Write_Languages (L, C : Natural); -- For each language backend available write at column L the name -- and at column C the comments associated to a language. end Backend; polyorb-2.8~20110207.orig/compilers/iac/backend-be_corba_ada-common.adb0000644000175000017500000012305711750740337025035 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- B A C K E N D . B E _ C O R B A _ A D A . C O M M O N -- -- -- -- B o d y -- -- -- -- Copyright (C) 2006-2009, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with Namet; use Namet; with Values; with Frontend.Nodes; use Frontend.Nodes; with Frontend.Nutils; with Backend.BE_CORBA_Ada.Nutils; use Backend.BE_CORBA_Ada.Nutils; with Backend.BE_CORBA_Ada.Nodes; use Backend.BE_CORBA_Ada.Nodes; with Backend.BE_CORBA_Ada.IDL_To_Ada; use Backend.BE_CORBA_Ada.IDL_To_Ada; with Backend.BE_CORBA_Ada.Runtime; use Backend.BE_CORBA_Ada.Runtime; package body Backend.BE_CORBA_Ada.Common is package FEN renames Frontend.Nodes; package FEU renames Frontend.Nutils; ------------------------------------- -- Cast_Variable_From_PolyORB_Type -- ------------------------------------- function Cast_Variable_From_PolyORB_Type (Var_Name : Name_Id; Var_Type : Node_Id) return Node_Id is N : Node_Id; Orig_Type : Node_Id; Direct_Type_Node : Node_Id; begin N := Make_Identifier (Var_Name); Orig_Type := FEU.Get_Original_Type_Specifier (Var_Type); if FEN.Kind (Var_Type) = K_Simple_Declarator or else FEN.Kind (Var_Type) = K_Complex_Declarator then Direct_Type_Node := Type_Spec (Declaration (Var_Type)); else Direct_Type_Node := Var_Type; end if; case FEN.Kind (Orig_Type) is when K_String => begin N := Make_Subprogram_Call (RE (RE_To_Standard_String_1), New_List (N)); if FEN.Kind (Direct_Type_Node) /= K_String then declare Ada_Type : constant Node_Id := Map_Expanded_Name (Direct_Type_Node); TCS : constant Node_Id := Make_Selected_Component (Copy_Node (Prefix (Ada_Type)), Make_Identifier (SN (S_To_CORBA_String))); -- To_CORBA_String primitive inherited from the -- CORBA.String type. begin N := Make_Subprogram_Call (TCS, New_List (N)); -- We use qualified expression to avoid conflicts with -- types derived from String in the spec of package CORBA -- (RepositoryId, ScopedName...) N := Make_Qualified_Expression (Ada_Type, N); end; else N := Make_Subprogram_Call (RE (RE_To_CORBA_String), New_List (N)); N := Make_Qualified_Expression (RE (RE_String_0), N); end if; end; when K_String_Type => declare Str_Package_Node : Node_Id; Str_Convert_Subp : Node_Id; begin -- Getting the instantiated package node Str_Package_Node := Defining_Identifier (Instantiation_Node (BE_Node (Orig_Type))); -- Getting the conversion subprogram Str_Convert_Subp := Make_Selected_Component (Str_Package_Node, Make_Identifier (SN (S_To_Bounded_String))); N := Make_Subprogram_Call (RE (RE_To_Standard_String_1), New_List (N)); N := Make_Subprogram_Call (Str_Convert_Subp, New_List (N)); N := Make_Subprogram_Call (Map_Expanded_Name (Direct_Type_Node), New_List (N)); end; when K_Wide_String => begin N := Make_Subprogram_Call (RE (RE_To_Standard_Wide_String_1), New_List (N)); if FEN.Kind (Direct_Type_Node) /= K_Wide_String then declare Ada_Type : constant Node_Id := Map_Expanded_Name (Direct_Type_Node); TCWS : constant Node_Id := Make_Selected_Component (Copy_Node (Prefix (Ada_Type)), Make_Identifier (SN (S_To_CORBA_Wide_String))); -- To_CORBA_Wide_String primitive inherited from the -- CORBA.Wide_String type. begin N := Make_Subprogram_Call (TCWS, New_List (N)); N := Make_Qualified_Expression (Ada_Type, N); end; else N := Make_Subprogram_Call (RE (RE_To_CORBA_Wide_String), New_List (N)); N := Make_Qualified_Expression (RE (RE_Wide_String), N); end if; end; when K_Wide_String_Type => declare Str_Package_Node : Node_Id; Str_Convert_Subp : Node_Id; begin -- Getting the instantiated package node Str_Package_Node := Defining_Identifier (Instantiation_Node (BE_Node (Orig_Type))); -- Getting the conversion subprogram Str_Convert_Subp := Make_Selected_Component (Str_Package_Node, Make_Identifier (SN (S_To_Bounded_Wide_String))); N := Make_Subprogram_Call (RE (RE_To_Standard_Wide_String_1), New_List (N)); N := Make_Subprogram_Call (Str_Convert_Subp, New_List (N)); N := Make_Subprogram_Call (Map_Expanded_Name (Direct_Type_Node), New_List (N)); end; when K_Long | K_Long_Long | K_Unsigned_Long | K_Unsigned_Long_Long | K_Float | K_Double | K_Long_Double | K_Char | K_Wide_Char | K_Octet | K_Sequence_Type | K_Short | K_Unsigned_Short | K_Boolean | K_Fixed_Point_Type | K_Any => declare CORBA_Type : constant Node_Id := Map_Expanded_Name (Direct_Type_Node); begin N := Make_Subprogram_Call (CORBA_Type, New_List (N)); end; -- For Objects and interfaces, there is no need to cast -- to the original type because the type definition is -- done by means of 'subtype' and not 'type ... is new -- ...' when K_Object => begin N := Make_Subprogram_Call (RE (RE_To_CORBA_Ref), New_List (N)); end; when K_Interface_Declaration | K_Forward_Interface_Declaration => -- Check whether we are dealing with a TypeCode if Get_Predefined_CORBA_Entity (Orig_Type) = RE_Object then N := Make_Subprogram_Call (RE (RE_To_CORBA_Object), New_List (N)); else declare To_Ref_Node : constant Node_Id := Get_To_Ref_Node (Direct_Type_Node); begin N := Make_Subprogram_Call (RE (RE_To_CORBA_Ref), New_List (N)); N := Make_Subprogram_Call (To_Ref_Node, New_List (N)); end; end if; when K_Enumeration_Type => declare CORBA_Type : constant Node_Id := Map_Expanded_Name (Direct_Type_Node); M : Node_Id; begin -- Even if the type is not directly an enumeration and -- is defined basing on an enumeration, we still have -- access to the 'Val attribute. So there is no need -- to cast the variable to the original enumeration -- type. M := Make_Attribute_Reference (CORBA_Type, A_Val); N := Make_Subprogram_Call (M, New_List (N)); end; when others => null; end case; return N; end Cast_Variable_From_PolyORB_Type; ----------------------------------- -- Cast_Variable_To_PolyORB_Type -- ----------------------------------- function Cast_Variable_To_PolyORB_Type (Var_Node : Node_Id; Var_Type : Node_Id) return Node_Id is N : Node_Id; Orig_Type : Node_Id; begin N := Var_Node; Orig_Type := FEU.Get_Original_Type_Specifier (Var_Type); case FEN.Kind (Orig_Type) is when K_Long => begin N := Make_Type_Conversion (RE (RE_Long_1), N); end; when K_Long_Long => begin N := Make_Type_Conversion (RE (RE_Long_Long_1), N); end; when K_Unsigned_Long => begin N := Make_Type_Conversion (RE (RE_Unsigned_Long_1), N); end; when K_Unsigned_Long_Long => begin N := Make_Type_Conversion (RE (RE_Unsigned_Long_Long_1), N); end; when K_Short => begin N := Make_Type_Conversion (RE (RE_Short_1), N); end; when K_Unsigned_Short => begin N := Make_Type_Conversion (RE (RE_Unsigned_Short_1), N); end; when K_Float => begin N := Make_Type_Conversion (RE (RE_Float_1), N); end; when K_Double => begin N := Make_Type_Conversion (RE (RE_Double_1), N); end; when K_Long_Double => begin N := Make_Type_Conversion (RE (RE_Long_Double_1), N); end; when K_Char => begin N := Make_Type_Conversion (RE (RE_Char_1), N); end; when K_Wide_Char => begin N := Make_Type_Conversion (RE (RE_Wchar_1), N); end; when K_Octet => begin N := Make_Type_Conversion (RE (RE_Octet_1), N); end; when K_Boolean => begin N := Make_Type_Conversion (RE (RE_Boolean_1), N); end; when K_Fixed_Point_Type => declare FP_Type_Node : Node_Id; begin -- Getting the fixed point type FP_Type_Node := Expand_Designator (Type_Def_Node (BE_Node (Orig_Type))); N := Make_Type_Conversion (FP_Type_Node, N); end; when K_Object => begin N := Make_Subprogram_Call (RE (RE_To_PolyORB_Ref), New_List (N)); end; when K_Interface_Declaration | K_Forward_Interface_Declaration => -- Check whether we are dealing with a TypeCode if Get_Predefined_CORBA_Entity (Orig_Type) = RE_Object then N := Make_Subprogram_Call (RE (RE_Object_Of_1), New_List (Make_Subprogram_Call (RE (RE_To_PolyORB_Object), New_List (N)))); else N := Make_Type_Conversion (RE (RE_Ref_2), N); N := Make_Subprogram_Call (RE (RE_To_PolyORB_Ref), New_List (N)); end if; when K_Enumeration_Type => declare Ada_Enum_Type : constant Node_Id := Expand_Designator (Type_Def_Node (BE_Node (Identifier (Orig_Type)))); M : Node_Id; begin if FEN.Kind (Var_Type) = K_Scoped_Name and then FEN.Kind (Reference (Var_Type)) /= K_Enumeration_Type then N := Make_Type_Conversion (Ada_Enum_Type, N); end if; -- Even if the type is not directly an enumeration and -- is defined basing on an enumeration, we still have -- access to the 'Pos' attribute. So there is no need -- to cast the variable to the original enumeration -- type. M := Make_Attribute_Reference (Ada_Enum_Type, A_Pos); M := Make_Subprogram_Call (M, New_List (N)); N := Make_Type_Conversion (RE (RE_Unsigned_Long_1), M); end; when K_String => begin if FEN.Kind (Var_Type) /= K_String then N := Make_Type_Conversion (RE (RE_String_0), N); end if; N := Make_Subprogram_Call (RE (RE_To_Standard_String), New_List (N)); N := Make_Subprogram_Call (RE (RE_To_PolyORB_String), New_List (N)); end; when K_String_Type => declare Str_Package_Node : Node_Id; Str_Type : Node_Id; Str_Convert_Subp : Node_Id; begin -- Getting the instantiated package node Str_Package_Node := Defining_Identifier (Instantiation_Node (BE_Node (Orig_Type))); -- Getting the conversion subprogram Str_Type := Make_Selected_Component (Str_Package_Node, Make_Identifier (TN (T_Bounded_String))); Str_Convert_Subp := Make_Selected_Component (Str_Package_Node, Make_Identifier (SN (S_To_String))); N := Make_Type_Conversion (Str_Type, N); N := Make_Subprogram_Call (Str_Convert_Subp, New_List (N)); N := Make_Subprogram_Call (RE (RE_To_PolyORB_String), New_List (N)); end; when K_Wide_String => begin if FEN.Kind (Var_Type) /= K_Wide_String then N := Make_Type_Conversion (RE (RE_Wide_String), N); end if; N := Make_Subprogram_Call (RE (RE_To_Standard_Wide_String), New_List (N)); N := Make_Subprogram_Call (RE (RE_To_PolyORB_Wide_String), New_List (N)); end; when K_Wide_String_Type => declare Str_Package_Node : Node_Id; Str_Type : Node_Id; Str_Convert_Subp : Node_Id; begin -- Getting the instantiated package node Str_Package_Node := Defining_Identifier (Instantiation_Node (BE_Node (Orig_Type))); -- Getting the conversion subprogram Str_Type := Make_Selected_Component (Str_Package_Node, Make_Identifier (TN (T_Bounded_Wide_String))); Str_Convert_Subp := Make_Selected_Component (Str_Package_Node, Make_Identifier (SN (S_To_Wide_String))); N := Make_Type_Conversion (Str_Type, N); N := Make_Subprogram_Call (Str_Convert_Subp, New_List (N)); N := Make_Subprogram_Call (RE (RE_To_PolyORB_Wide_String), New_List (N)); end; when K_Sequence_Type => declare Seq_Package_Node : Node_Id; Seq_Type : Node_Id; begin -- Getting the instantiated package node Seq_Package_Node := Expand_Designator (Instantiation_Node (BE_Node (Orig_Type))); -- Sequence type Seq_Type := Make_Selected_Component (Seq_Package_Node, Make_Identifier (TN (T_Sequence))); N := Make_Type_Conversion (Seq_Type, N); end; when K_Any => begin N := Make_Type_Conversion (RE (RE_Any_1), N); end; when others => null; end case; return N; end Cast_Variable_To_PolyORB_Type; ----------- -- Is_In -- ----------- function Is_In (Par_Mode : Mode_Id) return Boolean is begin return Par_Mode = Mode_In or else Par_Mode = Mode_Inout; end Is_In; ------------ -- Is_Out -- ------------ function Is_Out (Par_Mode : Mode_Id) return Boolean is begin return Par_Mode = Mode_Out or else Par_Mode = Mode_Inout; end Is_Out; ---------------------------- -- Contains_In_Parameters -- ---------------------------- function Contains_In_Parameters (E : Node_Id) return Boolean is pragma Assert (FEN.Kind (E) = K_Operation_Declaration); Parameter : Node_Id; Result : Boolean := False; begin Parameter := First_Entity (Parameters (E)); while Present (Parameter) loop if Is_In (FEN.Parameter_Mode (Parameter)) then Result := True; exit; end if; Parameter := Next_Entity (Parameter); end loop; return Result; end Contains_In_Parameters; ----------------------------- -- Contains_Out_Parameters -- ----------------------------- function Contains_Out_Parameters (E : Node_Id) return Boolean is pragma Assert (FEN.Kind (E) = K_Operation_Declaration); Parameter : Node_Id; Result : Boolean := False; begin Parameter := First_Entity (Parameters (E)); while Present (Parameter) loop if Is_Out (FEN.Parameter_Mode (Parameter)) then Result := True; exit; end if; Parameter := Next_Entity (Parameter); end loop; return Result; end Contains_Out_Parameters; -------------------------- -- Make_type_Designator -- -------------------------- function Make_Type_Designator (N : Node_Id; Declarator : Node_Id := No_Node) return Node_Id is Rewinded_Type : Node_Id; M : Node_Id; begin Set_Aligned_Spec; Rewinded_Type := FEU.Get_Original_Type_Specifier (N); if Present (Declarator) and then FEN.Kind (Declarator) = K_Complex_Declarator then declare Designator : Node_Id; Decl_Name : Name_Id; Type_Node : Node_Id; begin Decl_Name := To_Ada_Name (IDL_Name (FEN.Identifier (Declarator))); Designator := Make_Type_Designator (N); Get_Name_String (Decl_Name); Add_Str_To_Name_Buffer ("_Array"); Decl_Name := Name_Find; Type_Node := Make_Full_Type_Declaration (Defining_Identifier => Make_Defining_Identifier (Decl_Name), Type_Definition => Make_Array_Type_Definition (Map_Range_Constraints (FEN.Array_Sizes (Declarator)), Designator)); -- We make a link between the identifier and the type -- declaration. This link is useful for the generation -- of the From_Any and To_Any functions and the TC_XXX -- constant necessary for user defined types. Append_To (Visible_Part (Current_Package), Type_Node); Designator := Make_Selected_Component (Defining_Identifier (Stubs_Package (Current_Entity)), Defining_Identifier (Type_Node)); return Designator; end; end if; case FEN.Kind (Rewinded_Type) is when K_String => return RE (RE_String_10); when K_Sequence_Type => M := Make_Selected_Component (Defining_Identifier (Aligned_Package (Current_Entity)), Make_Identifier (IDL_Name (Identifier (N)))); return M; when K_Long => return RE (RE_Long_10); when K_Short => return RE (RE_Short_10); when K_Boolean => return RE (RE_Boolean_10); when K_Octet => return RE (RE_Octet_10); when K_Char => return RE (RE_Char_10); when K_Wide_Char => return RE (RE_Wchar_10); when K_Unsigned_Short => return RE (RE_Unsigned_Short_10); when K_Unsigned_Long | K_Enumeration_Type => return RE (RE_Unsigned_Long_10); when K_Long_Long => return RE (RE_Long_Long_10); when K_Unsigned_Long_Long => return RE (RE_Unsigned_Long_Long_10); when K_Long_Double => return RE (RE_Long_Double_10); when K_Float => return RE (RE_Float_10); when K_Double => return RE (RE_Double_10); when K_Complex_Declarator => M := Make_Selected_Component (Defining_Identifier (Aligned_Package (Current_Entity)), Make_Identifier (IDL_Name (Identifier (N)))); return M; when K_String_Type | K_Wide_String_Type | K_Structure_Type | K_Union_Type | K_Fixed_Point_Type => M := Make_Selected_Component (Defining_Identifier (Aligned_Package (Current_Entity)), Make_Identifier (IDL_Name (Identifier (N)))); return M; when K_Object => -- XXX is it right ? M := Make_Selected_Component (Defining_Identifier (Aligned_Package (Current_Entity)), Make_Identifier (FEN.Image (Base_Type (Rewinded_Type)))); return M; when K_Interface_Declaration => -- XXX is it right ? M := Make_Selected_Component (Defining_Identifier (Aligned_Package (Current_Entity)), Make_Identifier (IDL_Name (Identifier (Rewinded_Type)))); return M; when others => -- If any problem print the node kind here raise Program_Error; end case; end Make_Type_Designator; ------------------------------------------- -- Cast_Variable_To_PolyORB_Aligned_Type -- ------------------------------------------- function Cast_Variable_To_PolyORB_Aligned_Type (Var_Node : Node_Id; Var_Type : Node_Id) return Node_Id is N : Node_Id; Orig_Type : Node_Id; begin N := Var_Node; Orig_Type := FEU.Get_Original_Type_Specifier (Var_Type); case FEN.Kind (Orig_Type) is when K_Long => begin N := Make_Type_Conversion (RE (RE_Long_10), N); end; when K_Long_Long => begin N := Make_Type_Conversion (RE (RE_Long_Long_10), N); end; when K_Unsigned_Long => begin N := Make_Type_Conversion (RE (RE_Unsigned_Long_10), N); end; when K_Unsigned_Long_Long => begin N := Make_Type_Conversion (RE (RE_Unsigned_Long_Long_10), N); end; when K_Short => begin N := Make_Type_Conversion (RE (RE_Short_10), N); end; when K_Unsigned_Short => begin N := Make_Type_Conversion (RE (RE_Unsigned_Short_10), N); end; when K_Float => begin N := Make_Type_Conversion (RE (RE_Float_10), N); end; when K_Double => begin N := Make_Type_Conversion (RE (RE_Double_10), N); end; when K_Long_Double => begin N := Make_Type_Conversion (RE (RE_Long_Double_10), N); end; when K_Char => begin N := Make_Type_Conversion (RE (RE_Char_10), N); end; when K_Octet => begin N := Make_Type_Conversion (RE (RE_Octet_10), N); end; when K_Boolean => begin N := Make_Type_Conversion (RE (RE_Boolean_10), N); end; when K_Fixed_Point_Type => declare FP_Type_Node : Node_Id; begin -- Getting the fixed point type FP_Type_Node := Expand_Designator (Type_Def_Node (BE_Node (Orig_Type))); N := Make_Type_Conversion (FP_Type_Node, N); end; when K_Enumeration_Type => declare Ada_Enum_Type : constant Node_Id := Expand_Designator (Type_Def_Node (BE_Node (Identifier (Orig_Type)))); M : Node_Id; begin if FEN.Kind (Var_Type) = K_Scoped_Name and then FEN.Kind (Reference (Var_Type)) /= K_Enumeration_Type then N := Make_Type_Conversion (Ada_Enum_Type, N); end if; -- Even if the type is not directly an enumeration and -- is defined basing on an enumeration, we still have -- access to the 'Pos' attribute. So there is no need -- to cast the variable to the original enumeration -- type. M := Make_Attribute_Reference (Ada_Enum_Type, A_Pos); M := Make_Subprogram_Call (M, New_List (N)); N := Make_Type_Conversion (RE (RE_Unsigned_Long_10), M); end; when K_String => begin if FEN.Kind (Var_Type) /= K_String then N := Make_Type_Conversion (RE (RE_String_0), N); end if; N := Make_Subprogram_Call (RE (RE_To_Standard_String), New_List (N)); end; when K_String_Type => declare Str_Package_Node : Node_Id; Str_Type : Node_Id; Str_Convert_Subp : Node_Id; begin -- Getting the instantiated package node Str_Package_Node := Defining_Identifier (Instantiation_Node (BE_Node (Orig_Type))); -- Getting the conversion subprogram Str_Type := Make_Selected_Component (Str_Package_Node, Make_Identifier (TN (T_Bounded_String))); Str_Convert_Subp := Make_Selected_Component (Str_Package_Node, Make_Identifier (SN (S_To_String))); N := Make_Type_Conversion (Str_Type, N); N := Make_Subprogram_Call (Str_Convert_Subp, New_List (N)); N := Make_Subprogram_Call (RE (RE_To_PolyORB_String), New_List (N)); end; when K_Sequence_Type => declare Seq_Package_Node : Node_Id; Seq_Type : Node_Id; begin -- Getting the instantiated package node in aligned -- backend. Seq_Package_Node := Expand_Designator (Instantiation_Node (BE_Node (Orig_Type))); -- Sequence type Seq_Type := Make_Selected_Component (Seq_Package_Node, Make_Identifier (TN (T_Sequence))); N := Make_Type_Conversion (Seq_Type, N); end; when others => null; end case; return N; end Cast_Variable_To_PolyORB_Aligned_Type; ------------------- -- Marshall_Args -- ------------------- procedure Marshall_Args (Stat : List_Id; Var_Type : Node_Id; Var : Node_Id; Var_Exp : Node_Id := No_Node) is Rewinded_Type : Node_Id; C : Node_Id; N : Node_Id; M : Node_Id; begin Rewinded_Type := FEU.Get_Original_Type_Specifier (Var_Type); case FEN.Kind (Rewinded_Type) is when K_Structure_Type => declare Member : Node_Id; begin Member := First_Entity (Members (Rewinded_Type)); while Present (Member) loop C := Make_Selected_Component (Var, Make_Identifier (IDL_Name (Identifier (First_Entity (Declarators (Member)))))); if Var_Exp /= No_Node then M := Make_Selected_Component (Var_Exp, Make_Identifier (IDL_Name (Identifier (First_Entity (Declarators (Member)))))); Marshall_Args (Stat, Type_Spec (Member), C, M); else Marshall_Args (Stat, Type_Spec (Member), C); end if; Member := Next_Entity (Member); end loop; return; end; when K_Union_Type => declare L : List_Id; Literal_Parent : Node_Id := No_Node; Choices : List_Id; Switch_Alternatives : List_Id; Switch_Node : Node_Id; Switch_Case : Node_Id; Has_Default : Boolean := False; begin Switch_Node := Make_Identifier (CN (C_Switch)); if Var_Exp /= No_Node then Switch_Node := Make_Selected_Component (Var_Exp, Switch_Node); else Switch_Node := Make_Selected_Component (Var, Switch_Node); end if; C := FEU.Get_Original_Type_Specifier (Switch_Type_Spec (Rewinded_Type)); if FEN.Kind (C) = K_Enumeration_Type then Literal_Parent := Map_Expanded_Name (Scope_Entity (Identifier (C))); end if; Switch_Alternatives := New_List; Switch_Case := First_Entity (Switch_Type_Body (Rewinded_Type)); while Present (Switch_Case) loop Map_Choice_List (Labels (Switch_Case), Literal_Parent, Choices, Has_Default); L := New_List; C := Make_Selected_Component (Var, Make_Identifier (IDL_Name (Identifier (Declarator (Element (Switch_Case)))))); if Var_Exp /= No_Node then M := Make_Selected_Component (Var_Exp, Make_Identifier (IDL_Name (Identifier (Declarator (Element (Switch_Case)))))); Marshall_Args (L, Type_Spec (Element (Switch_Case)), C, M); else Marshall_Args (L, Type_Spec (Element (Switch_Case)), C); end if; -- Building the switch alternative Append_To (Switch_Alternatives, Make_Case_Statement_Alternative (Choices, L)); Switch_Case := Next_Entity (Switch_Case); end loop; -- Add an empty when others clause to keep the compiler happy if not Has_Default then Append_To (Switch_Alternatives, Make_Case_Statement_Alternative (No_List, No_List)); end if; N := Make_Case_Statement (Switch_Node, Switch_Alternatives); Append_To (Stat, N); return; end; when K_String => if Var_Exp /= No_Node then M := Cast_Variable_To_PolyORB_Aligned_Type (Var_Exp, Var_Type); else M := Cast_Variable_To_PolyORB_Aligned_Type (Var, Var_Type); end if; C := RE (RE_Nul); M := Make_Expression (M, Op_And_Symbol, C); C := Cast_Variable_To_PolyORB_Aligned_Type (Var, Var_Type); N := Make_Selected_Component (PN (P_Content), Fully_Qualified_Name (Var)); if Var_Exp /= No_Node then N := Make_Selected_Component (VN (V_Args_Out), Fully_Qualified_Name (N)); else N := Make_Selected_Component (VN (V_Args_In), Fully_Qualified_Name (N)); end if; N := Make_Assignment_Statement (N, M); Append_To (Stat, N); return; when K_Sequence_Type => declare Range_Constraint : Node_Id; Index_Node : Node_Id; K : Node_Id; begin Set_Str_To_Name_Buffer ("J"); Index_Node := Make_Defining_Identifier (Name_Find); if Var_Exp /= No_Node then N := Make_Subprogram_Call (RE (RE_Length_2), New_List (Var_Exp)); else N := Make_Subprogram_Call (RE (RE_Length_2), New_List (Var)); end if; N := Make_Type_Conversion (RE (RE_Unsigned_Long_10), N); Range_Constraint := Make_Range_Constraint (Make_Literal (Int1_Val), N); N := Make_Selected_Component (PN (P_Content), Fully_Qualified_Name (Var)); if Var_Exp /= No_Node then N := Make_Selected_Component (VN (V_Args_Out), Fully_Qualified_Name (N)); N := Make_Identifier (Fully_Qualified_Name (N)); N := Make_Subprogram_Call (N, New_List (Index_Node)); M := Make_Identifier (Fully_Qualified_Name (Var_Exp)); K := Make_Type_Conversion (RE (RE_Integer), Index_Node); M := Make_Subprogram_Call (RE (RE_Get_Element), New_List (M, K)); M := Cast_Variable_To_PolyORB_Aligned_Type (M, Type_Spec (Type_Spec (Declaration (Reference (Var_Type))))); N := Make_Assignment_Statement (N, M); else N := Make_Selected_Component (VN (V_Args_In), Fully_Qualified_Name (N)); N := Make_Identifier (Fully_Qualified_Name (N)); N := Make_Subprogram_Call (N, New_List (Index_Node)); M := Make_Identifier (Fully_Qualified_Name (Var)); K := Make_Type_Conversion (RE (RE_Integer), Index_Node); M := Make_Subprogram_Call (RE (RE_Get_Element), New_List (M, K)); M := Cast_Variable_To_PolyORB_Aligned_Type (M, Type_Spec (Type_Spec (Declaration (Reference (Var_Type))))); N := Make_Assignment_Statement (N, M); end if; N := Make_For_Statement (Index_Node, Range_Constraint, New_List (N)); Append_To (Stat, N); return; end; when K_Complex_Declarator => M := Make_Selected_Component (Defining_Identifier (Aligned_Package (Current_Entity)), Make_Identifier (IDL_Name (Identifier (Var_Type)))); M := Make_Subprogram_Call (M, New_List (Var)); when others => if Var_Exp /= No_Node then M := Cast_Variable_To_PolyORB_Aligned_Type (Var_Exp, Var_Type); else M := Cast_Variable_To_PolyORB_Aligned_Type (Var, Var_Type); end if; C := Cast_Variable_To_PolyORB_Aligned_Type (Var, Var_Type); end case; N := Make_Identifier (Fully_Qualified_Name (Var)); if Var_Exp /= No_Node then N := Make_Selected_Component (VN (V_Args_Out), Fully_Qualified_Name (Var)); else N := Make_Selected_Component (VN (V_Args_Out), Fully_Qualified_Name (Var)); end if; N := Make_Assignment_Statement (N, M); Append_To (Stat, N); end Marshall_Args; ----------------------------- -- Get_Discriminants_Value -- ----------------------------- procedure Get_Discriminants_Value (P : Node_Id; N : Node_Id; L : List_Id; Ret : Boolean := False) is Rewinded_Type : Node_Id; Var : Node_Id; M : Node_Id; C : Node_Id; begin -- Handle the case of non void operation having OUT parameters if FEN.Kind (P) = K_Parameter_Declaration then Var := Map_Defining_Identifier (Declarator (P)); else Var := Make_Defining_Identifier (PN (P_Returns)); end if; Rewinded_Type := FEU.Get_Original_Type_Specifier (N); case FEN.Kind (Rewinded_Type) is when K_Union_Type => declare Member : Node_Id; begin Member := First_Entity (Switch_Type_Body (Rewinded_Type)); while Present (Member) loop M := Make_Selected_Component (Var, Make_Defining_Identifier (IDL_Name (Identifier (Declarator (Element (Member)))))); Get_Discriminants_Value (M, Type_Spec (Element (Member)), L); Member := Next_Entity (Member); end loop; M := Make_Selected_Component (Var, Make_Identifier (CN (C_Switch))); C := Switch_Type_Spec (Rewinded_Type); M := Cast_Variable_To_PolyORB_Aligned_Type (M, C); Append_To (L, M); end; when K_Structure_Type => declare Member : Node_Id; begin Member := First_Entity (Members (Rewinded_Type)); while Present (Member) loop M := Make_Selected_Component (Var, Make_Identifier (IDL_Name (Identifier (First_Entity (Declarators (Member)))))); Get_Discriminants_Value (M, Type_Spec (Member), L, Ret); Member := Next_Entity (Member); end loop; end; when K_String | K_Wide_String => C := Make_Attribute_Reference (Make_Subprogram_Call (RE (RE_To_Standard_String), New_List (Var)), A_Length); C := Make_Expression (C, Op_Plus, Make_Literal (Values.New_Integer_Value (1, 1, 10))); Append_To (L, C); when K_Sequence_Type => if not Present (Max_Size (Rewinded_Type)) then C := Make_Subprogram_Call (RE (RE_Length_2), New_List (Var)); C := Make_Type_Conversion (RE (RE_Unsigned_Long_10), C); Append_To (L, C); end if; when others => null; end case; end Get_Discriminants_Value; end Backend.BE_CORBA_Ada.Common; polyorb-2.8~20110207.orig/compilers/iac/backend-be_corba_ada-runtime.ads0000644000175000017500000023263711750740337025256 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- B A C K E N D . B E _ C O R B A _ A D A . R U N T I M E -- -- -- -- S p e c -- -- -- -- Copyright (C) 2005-2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ package Backend.BE_CORBA_Ada.Runtime is -- Runtime Units -- Note: there is intentionally no RU_System so that users can have an IDL -- identifier of that name. If an entity in package System needs to be -- referenced in generated code, an appropriate renaming should be declared -- under the PolyORB hierarchy. type RU_Id is (RU_Null, RU_Ada, RU_Ada_Exceptions, RU_Ada_Streams, RU_Ada_Unchecked_Conversion, RU_Ada_Unchecked_Deallocation, RU_CORBA, RU_CORBA_AbstractBase, RU_CORBA_Bounded_Strings, RU_CORBA_Bounded_Wide_Strings, RU_CORBA_Context, RU_CORBA_ExceptionList, RU_CORBA_ExceptionList_Internals, RU_CORBA_Forward, RU_CORBA_Fixed_Point, RU_CORBA_Helper, RU_CORBA_IDL_Sequences, RU_CORBA_IDL_Sequences_IDL_SEQUENCE_Any, RU_CORBA_IDL_Sequences_IDL_SEQUENCE_Boolean, RU_CORBA_IDL_Sequences_IDL_SEQUENCE_Char, RU_CORBA_IDL_Sequences_IDL_SEQUENCE_Wide_Char, RU_CORBA_IDL_Sequences_IDL_SEQUENCE_Octet, RU_CORBA_IDL_Sequences_IDL_SEQUENCE_Short, RU_CORBA_IDL_Sequences_IDL_SEQUENCE_Unsigned_Short, RU_CORBA_IDL_Sequences_IDL_SEQUENCE_Long, RU_CORBA_IDL_Sequences_IDL_SEQUENCE_Unsigned_Long, RU_CORBA_IDL_Sequences_IDL_SEQUENCE_Long_Long, RU_CORBA_IDL_Sequences_IDL_SEQUENCE_Unsigned_Long_Long, RU_CORBA_IDL_Sequences_IDL_SEQUENCE_Float, RU_CORBA_IDL_Sequences_IDL_SEQUENCE_Double, RU_CORBA_IDL_Sequences_IDL_SEQUENCE_Long_Double, RU_CORBA_IDL_Sequences_IDL_SEQUENCE_String, RU_CORBA_IDL_Sequences_IDL_SEQUENCE_Wide_String, RU_CORBA_IDL_Sequences_Helper, RU_CORBA_Internals, RU_CORBA_Local, RU_CORBA_Sequences, RU_CORBA_Sequences_Bounded, RU_CORBA_Sequences_Unbounded, RU_CORBA_NVList, RU_CORBA_NVList_Internals, RU_CORBA_ORB, RU_CORBA_Repository_Root, RU_CORBA_Repository_Root_IRObject, RU_CORBA_Repository_Root_IRObject_Helper, RU_CORBA_Repository_Root_Container, RU_CORBA_Repository_Root_Container_Helper, RU_CORBA_Repository_Root_InterfaceDef, RU_CORBA_Repository_Root_InterfaceDef_Helper, RU_CORBA_Repository_Root_InterfaceDef_Convert_Forward, RU_CORBA_Repository_Root_IDLType, RU_CORBA_Repository_Root_IDLType_Helper, RU_CORBA_Repository_Root_IDLType_Convert_Forward, RU_CORBA_Repository_Root_Repository, RU_CORBA_ServerRequest, RU_CORBA_Object, -- Begin: CORBA predefined entities RU_CORBA_OObject, -- Workaround in orb.idl RU_CORBA_Current, RU_CORBA_Policy, RU_CORBA_DomainManager, RU_CORBA_TypeCode, -- End: CORBA predefined entities RU_CORBA_Current_Impl, RU_CORBA_Policy_Helper, RU_CORBA_Policy_Impl, RU_CORBA_Policy_CDR, RU_CORBA_Object_Impl, RU_CORBA_TypeCode_Impl, RU_CORBA_DomainManager_Impl, RU_CORBA_DomainManager_Helper, RU_CORBA_DomainManager_CDR, RU_CORBA_Object_Internals, RU_CORBA_Object_Helper, RU_CORBA_TypeCode_Internals, RU_PolyORB, RU_PolyORB_Annotations, RU_PolyORB_Any, RU_PolyORB_Any_NVList, RU_PolyORB_Any_TypeCode, RU_PolyORB_Any_TypeCode_Internals, RU_PolyORB_Buffers, RU_PolyORB_Buffers_Optimization, RU_PolyORB_Buffers_Optimization_Fixed_Point, RU_PolyORB_Exceptions, RU_PolyORB_Errors, RU_PolyORB_Initialization, RU_PolyORB_CORBA_P, RU_PolyORB_CORBA_P_Domain_Management, RU_PolyORB_CORBA_P_Interceptors_Hooks, RU_PolyORB_CORBA_P_IR_Hooks, RU_PolyORB_CORBA_P_IR_Tools, RU_PolyORB_CORBA_P_Exceptions, RU_PolyORB_QoS, RU_PolyORB_QoS_Static_Buffers, RU_PolyORB_QoS_Exception_Informations, RU_PolyORB_References, RU_PolyORB_Representations, RU_PolyORB_References_Binding, RU_PolyORB_Setup, RU_PolyORB_Smart_Pointers, RU_PolyORB_Reprsentations, RU_PolyORB_Representations_CDR, RU_PolyORB_Components, RU_PolyORB_Binding_Data, RU_PolyORB_Binding_Objects, RU_PolyORB_Binding_Data_GIOP, RU_PolyORB_Representations_CDR_Common, RU_PolyORB_Representations_CDR_Common_Fixed_Point, RU_PolyORB_Protocols, RU_PolyORB_Protocols_GIOP, RU_PolyORB_Protocols_Iface, RU_PolyORB_Requests, RU_PolyORB_Request_QoS, RU_PolyORB_Sequences, RU_PolyORB_Sequences_Bounded, RU_PolyORB_Sequences_Bounded_CORBA_Helper, RU_PolyORB_Sequences_Unbounded, RU_PolyORB_Sequences_Unbounded_CORBA_Helper, RU_PolyORB_Types, RU_PolyORB_Aligned_Types, RU_PolyORB_Aligned_Types_Bounded_Strings, RU_PolyORB_Aligned_Types_Bounded_Wide_Strings, RU_PolyORB_Aligned_Types_Sequences, RU_PolyORB_Aligned_Types_Sequences_Bounded, RU_PolyORB_Aligned_Types_Sequences_Unbounded, RU_PolyORB_Opaque, RU_PolyORB_Std, RU_PolyORB_Std_ASCII, RU_PolyORB_Utils, RU_PolyORB_Utils_Strings, RU_PolyORB_Utils_Strings_Lists, RU_PortableServer, RU_PortableServer_Internals); -- Runtime Entities type RE_Id is (RE_Null, -- (placeholder for missing RE) RE_Ref_0, -- Ref RE_To_Any_1, -- To_Any RE_Boolean_0, -- Boolean RE_False, -- False RE_True, -- True RE_On, -- On RE_Off, -- Off RE_Discriminant_Check, -- Discriminant_Check RE_Range_Check, -- Range_Check -- WAG:504 (see platform.ads.in) RE_Validity_Check, -- Validity_Check RE_Register_IR_Info, -- Register_IR_Info RE_Convert, -- Convert RE_Convert_Forward, -- Convert_Forward RE_Element_TC, -- Element_TC RE_Marshaller, -- Marshaller RE_Sequence_TC, -- Sequence_TC RE_TC_Bounded_String, -- TC_Bounded_String RE_TC_Bounded_Wide_String, -- TC_Bounded_Wide_String RE_Unmarshaller, -- Unmarshaller RE_Payload_Args, -- Payload_Args RE_Length_2, -- Length RE_Get_Element, -- Get_Element RE_Exception_Occurrence, -- Ada.Exceptions.Exception_Occurrence RE_Stream_Element_Count, -- Ada.Streams.Stream_Element_Count RE_Address, -- PolyORB.Types.Address RE_ARG_IN_0, -- CORBA.ARG_IN RE_ARG_OUT_0, -- CORBA.ARG_OUT RE_ARG_INOUT_0, -- CORBA.ARG_INOUT RE_Default_Sys_Member, -- CORBA.Default_Sys_Member RE_TC_Void, -- CORBA.TC_Void RE_To_Any_0, -- CORBA.To_Any RE_From_Any_0, -- CORBA.From_Any RE_Wrap_2, -- CORBA.Wrap RE_Get_Container_1, -- CORBA.Get_Container RE_Ref_11, -- CORBA.DomainManager.Ref RE_Object_8, -- CORBA.DomainManager.Impl.Object RE_To_Ref_5, -- CORBA.DomainManager.Helper.To_Ref RE_From_Any_5, -- CORBA.DomainManager.Helper.From_Any RE_To_Any_5, -- CORBA.DomainManager.Helper.To_Any RE_TC_DomainManager, -- CORBA.DomainManager.Helper. -- TC_DomainManager RE_Get_Domain_Policy_Args_Type, -- CORBA.DomainManager.CDR. -- get_domain_policy_Args_Type RE_Get_Domain_Policy_Marshaller, -- CORBA.DomainManager.CDR. -- get_domain_policy_Marshaller RE_Get_Domain_Policy_Unmarshaller, -- CORBA.DomainManager.CDR. -- get_domain_policy_Unmarshaller RE_Create_List_1, -- CORBA.ExceptionList.Create_List RE_Add_1, -- CORBA.ExceptionList.Add RE_Ref_5, -- CORBA.ExceptionList.Ref RE_To_PolyORB_Ref_1, -- CORBA.ExceptionList.Internals RE_Get_Aggregate_Element, -- CORBA.Internals.Get_Aggregate_Element RE_Get_Empty_Any, -- CORBA.Internals.Get_Empty_Any -- Begin of the CORBA entities declared in orb.idl that may be invoked -- in user idl files RE_Any, -- CORBA.Any RE_Identifier_0, -- CORBA.Identifier RE_RepositoryId, -- CORBA.RepositoryId RE_ScopedName, -- CORBA.ScopedName RE_Visibility, -- CORBA.Visibility RE_PolicyType, -- CORBA.PolicyType RE_Float, -- CORBA.Float RE_Double, -- CORBA.Double RE_Long_Double, -- CORBA.Long_Double RE_Short, -- CORBA.Short RE_Long, -- CORBA.Long RE_Long_Long, -- CORBA.Long_Long RE_Unsigned_Short, -- CORBA.Unsigned_Short RE_Unsigned_Long, -- CORBA.Unsigned_Long RE_Unsigned_Long_Long, -- CORBA.Unsigned_Long_Long RE_Char, -- CORBA.Char RE_WChar, -- CORBA.WChar RE_String_0, -- CORBA.String RE_Wide_String, -- CORBA.Wide_String RE_Boolean, -- CORBA.Boolean RE_Octet, -- CORBA.Octet RE_Get_Domain_Policy, -- CORBA.DomainManager.Get_Domain_Policy RE_Get_Policy_Type, -- CORBA.Policy.Get_Policy_Type RE_Copy, -- CORBA.Policy.Copy -- Original Sequence types RE_AnySeq_1, -- CORBA.AnySeq RE_FloatSeq_1, -- CORBA.FloatSeq RE_DoubleSeq_1, -- CORBA.DoubleSeq RE_LongDoubleSeq_1, -- CORBA.LongDoubleSeq RE_ShortSeq_1, -- CORBA.ShortSeq RE_LongSeq_1, -- CORBA.LongSeq RE_LongLongSeq_1, -- CORBA.LongLongSeq RE_UShortSeq_1, -- CORBA.UShort RE_ULongSeq_1, -- CORBA.ULongSeq RE_ULongLongSeq_1, -- CORBA.ULongLongSeq RE_CharSeq_1, -- CORBA.CharSeq RE_WCharSeq_1, -- CORBA.WCharSeq RE_StringSeq_1, -- CORBA.StringSeq RE_WStringSeq_1, -- CORBA.WStringSeq RE_BooleanSeq_1, -- CORBA.BooleanSeq RE_OctetSeq_1, -- CORBA.OctetSeq RE_PolicyList_1, -- CORBA.PolicyList -- PolyORB-CORBA Sequence types RE_AnySeq_2, -- CORBA.IDL_Sequences.AnySeq RE_FloatSeq_2, -- CORBA.IDL_Sequences.FloatSeq RE_DoubleSeq_2, -- CORBA.IDL_Sequences.DoubleSeq RE_LongDoubleSeq_2, -- CORBA.IDL_Sequences.LongDoubleSeq RE_ShortSeq_2, -- CORBA.IDL_Sequences.ShortSeq RE_LongSeq_2, -- CORBA.IDL_Sequences.LongSeq RE_LongLongSeq_2, -- CORBA.IDL_Sequences.LongLongSeq RE_UShortSeq_2, -- CORBA.IDL_Sequences.UShort RE_ULongSeq_2, -- CORBA.IDL_Sequences.ULongSeq RE_ULongLongSeq_2, -- CORBA.IDL_Sequences.ULongLongSeq RE_CharSeq_2, -- CORBA.IDL_Sequences.CharSeq RE_WCharSeq_2, -- CORBA.IDL_Sequences.WCharSeq RE_StringSeq_2, -- CORBA.IDL_Sequences.StringSeq RE_WStringSeq_2, -- CORBA.IDL_Sequences.WStringSeq RE_BooleanSeq_2, -- CORBA.IDL_Sequences.BooleanSeq RE_OctetSeq_2, -- CORBA.IDL_Sequences.OctetSeq RE_PolicyList_2, -- CORBA.Policy.PolicyList -- End of the CORBA entities declared in orb.idl that may be -- invoked in user idl files RE_TC_AnySeq, -- CORBA.IDL_Sequences.Helper.TC_AnySeq RE_TC_FloatSeq, -- CORBA.IDL_Sequences.Helper.TC_FloatSeq RE_TC_DoubleSeq, -- CORBA.IDL_Sequences.Helper.TC_DoubleSeq RE_TC_LongDoubleSeq, -- CORBA.IDL_Sequences.Helper. -- TC_LongDoubleSeq RE_TC_ShortSeq, -- CORBA.IDL_Sequences.Helper.TC_ShortSeq RE_TC_LongSeq, -- CORBA.IDL_Sequences.Helper.TC_LongSeq RE_TC_LongLongSeq, -- CORBA.IDL_Sequences.Helper. -- TC_LongLongSeq RE_TC_UShortSeq, -- CORBA.IDL_Sequences.Helper.TC_UShort RE_TC_ULongSeq, -- CORBA.IDL_Sequences.Helper.TC_ULongSeq RE_TC_ULongLongSeq, -- CORBA.IDL_Sequences.Helper. -- TC_ULongLongSeq RE_TC_CharSeq, -- CORBA.IDL_Sequences.Helper.TC_CharSeq RE_TC_WCharSeq, -- CORBA.IDL_Sequences.Helper.TC_WCharSeq RE_TC_StringSeq, -- CORBA.IDL_Sequences.Helper.TC_StringSeq RE_TC_WStringSeq, -- CORBA.IDL_Sequences.Helper. -- TC_WStringSeq RE_TC_BooleanSeq, -- CORBA.IDL_Sequences.Helper. -- TC_BooleanSeq RE_TC_OctetSeq, -- CORBA.IDL_Sequences.Helper.TC_OctetSeq RE_From_Any_4, -- CORBA.IDL_Sequences.Helper.From_Any RE_To_Any_4, -- CORBA.IDL_Sequences.Helper.To_Any RE_Wrap_4, -- CORBA.IDL_Sequences.Helper.Wrap RE_Sequence_201, -- CORBA.IDL_Sequences. -- IDL_SEQUENCE_Any.Sequence RE_Sequence_202, -- CORBA.IDL_Sequences -- IDL_SEQUENCE_Boolean.Sequence RE_Sequence_203, -- CORBA.IDL_Sequences -- IDL_SEQUENCE_Char.Sequence RE_Sequence_204, -- CORBA.IDL_Sequences -- IDL_SEQUENCE_Wide_Char.Sequence RE_Sequence_205, -- CORBA.IDL_Sequences -- IDL_SEQUENCE_Octet.Sequence RE_Sequence_206, -- CORBA.IDL_Sequences -- IDL_SEQUENCE_Short.Sequence RE_Sequence_207, -- CORBA.IDL_Sequences -- IDL_SEQUENCE_Unsigned_Short.Sequence RE_Sequence_208, -- CORBA.IDL_Sequences -- IDL_SEQUENCE_Long.Sequence RE_Sequence_209, -- CORBA.IDL_Sequences -- IDL_SEQUENCE_Unsigned_Long.Sequence RE_Sequence_210, -- CORBA.IDL_Sequences -- IDL_SEQUENCE_Long_Long.Sequence RE_Sequence_211, -- CORBA.IDL_Sequences -- IDL_SEQUENCE_Unsigned_Long_Long -- .Sequence RE_Sequence_212, -- CORBA.IDL_Sequences -- IDL_SEQUENCE_Float.Sequence RE_Sequence_213, -- CORBA.IDL_Sequences -- IDL_SEQUENCE_Double.Sequence RE_Sequence_214, -- CORBA.IDL_Sequences -- IDL_SEQUENCE_Long_Double.Sequence RE_Sequence_215, -- CORBA.IDL_Sequences -- IDL_SEQUENCE_String.Sequence RE_Sequence_216, -- CORBA.IDL_Sequences -- IDL_SEQUENCE_Wide_String.Sequence RE_Is_Equivalent, -- CORBA.Is_Equivalent RE_TC_Any, -- CORBA.TC_Any RE_TC_Float, -- CORBA.TC_Float RE_TC_Double, -- CORBA.TC_Double RE_TC_Long_Double, -- CORBA.TC_Long_Double RE_TC_Short, -- CORBA.TC_Short RE_TC_Long, -- CORBA.TC_Long RE_TC_Long_Long, -- CORBA.TC_Long_Long RE_TC_Unsigned_Short, -- CORBA.TC_Unsigned_Short RE_TC_Unsigned_Long, -- CORBA.TC_Unsigned_Long RE_TC_Unsigned_Long_Long, -- CORBA.TC_Unsigned_Long_Long RE_TC_Char, -- CORBA.TC_Char RE_TC_WChar, -- CORBA.TC_WChar RE_TC_String, -- CORBA.TC_String RE_TC_Wide_String, -- CORBA.TC_Wide_String RE_TC_Boolean, -- CORBA.TC_Boolean RE_TC_Octet, -- CORBA.TC_Octet RE_TC_TypeCode, -- CORBA.TC_TypeCode RE_TC_Null, -- CORBA.TC_Null RE_TC_Buffer, -- PolyORB.Any.TC_Buffer RE_TC_RepositoryId, -- CORBA.Helper.TC_RepositoryId RE_TC_Identifier, -- CORBA.Helper.TC_Identifier RE_TC_ScopedName, -- CORBA.Helper.TC_ScopedName RE_TC_Visibility, -- CORBA.Helper.TC_Visibility RE_TC_PolicyType, -- CORBA.Helper.TC_PolicyType RE_From_Any_2, -- CORBA.Helper.From_Any RE_To_Any_2, -- CORBA.Helper.To_Any RE_To_Standard_String, -- CORBA.To_Standard_String RE_To_Standard_Wide_String, -- CORBA.To_Standard_Wide_String RE_IDL_Exception_Members, -- CORBA.IDL_Exception_Members RE_Object_2, -- CORBA.Local.Object RE_Raise_Inv_Objref, -- CORBA.Raise_Inv_Objref RE_Raise_Bad_Operation, -- CORBA.Raise_Bad_Operation RE_Raise_Bad_Param, -- CORBA.Raise_Bad_Param RE_To_CORBA_String, -- CORBA.To_CORBA_String RE_To_CORBA_Wide_String, -- CORBA.To_CORBA_Wide_String RE_Ref_1, -- CORBA.AbstractBase.Ref RE_Ref_8, -- CORBA.Context.Ref RE_Add_Parameter, -- CORBA.Internals.Add_Parameter RE_Set_Type, -- CORBA.Internals.Set_Type RE_Get_Empty_Any_Aggregate, -- CORBA.Internals.Get_Empty_Any_Agregate RE_Add_Aggregate_Element, -- CORBA.Internals.Add_Aggregate_Element RE_Get_Wrapper_Any, -- CORBA.Internals.Get_Wrapper_Any RE_Buff_Access_To_Ulong, -- Conversion RE_Move_Any_Value, -- CORBA.Internals.Move_Any_Value RE_Add_Item_0, -- CORBA.NVList.Add_Item RE_Ref_4, -- CORBA.NVList.Ref RE_Clone_Out_Args, -- CORBA.NVList.Internals.Clone_Out_Args RE_Is_Nil, -- CORBA.Object.Is_Nil RE_Ref_2, -- CORBA.Object.Ref RE_Object_Of, -- CORBA.Object.Object_Of RE_Is_A, -- CORBA.Object.Is_A RE_From_Any_1, -- CORBA.Object.Helper.From_Any RE_TC_Object_0, -- CORBA.Object.Helper.TC_Object RE_To_Any_3, -- CORBA.Object.Helper.To_Any RE_Wrap_3, -- CORBA.Object.Helper.Wrap RE_To_PolyORB_Ref, -- CORBA.Object.Internals.To_PolyORB_Ref RE_To_CORBA_Ref, -- CORBA.Object.Internals.To_CORBA_Ref RE_Ref_6, -- CORBA.Policy.Ref RE_Object_3, -- CORBA.Policy.Impl.Object RE_TC_Policy, -- CORBA.Policy.Helper.TC_Policy RE_To_Ref_6, -- CORBA.Policy.Helper.To_Ref RE_From_Any_6, -- CORBA.Policy.Helper.From_Any RE_To_Any_6, -- CORBA.Policy.Helper.To_Any RE_Get_Policy_Type_Args_Type, -- CORBA.Policy.CDR. -- Get_Policy_Type_Args_Type RE_Get_Policy_Type_Marshaller, -- CORBA.Policy.CDR. -- Get_Policy_Type_Marshaller RE_Get_Policy_Type_Unmarshaller, -- CORBA.Policy.CDR. -- Get_Policy_Type_Unmarshaller RE_Copy_Args_Type, -- CORBA.Policy.CDR.Copy_Args_Type RE_Copy_Marshaller, -- CORBA.Policy.CDR.Copy_Marshaller RE_Copy_Unmarshaller, -- CORBA.Policy.CDR.Copy_Unmarshaller RE_Local_Ref, -- CORBA.Current.Local_Ref RE_Object_4, -- CORBA.Current.Impl.Object RE_Object_5, -- CORBA.Object.Impl.Object RE_Object_6, -- CORBA.TypeCode.Impl.Object RE_Create_List, -- CORBA.ORB.Create_List, RE_Get_Default_Context, -- CORBA.ORB.Get_Default_Context RE_Object, -- CORBA.TypeCode.Object RE_Build_Alias_TC, -- CORBA.TypeCode. -- Internals.Build_Alias_TC RE_Build_Sequence_TC, -- CORBA.TypeCode. -- -- Internals.Build_Sequence_TC RE_Build_String_TC, -- CORBA.TypeCode. -- Internals.Build_String_TC RE_Build_Wstring_TC, -- CORBA.TypeCode. -- Internals.Build_Wstring_TC RE_To_CORBA_Object, -- CORBA.TypeCode. -- -- Internals.To_CORBA_Object RE_To_PolyORB_Object, -- CORBA.TypeCode. -- -- Internals.To_PolyORB_Object RE_Disable_Reference_Counting, -- CORBA.TypeCode. -- Internals.Disable_Reference_Counting RE_Arguments_1, -- CORBA.ServerRequest.Arguments RE_Object_Ptr, -- CORBA.ServerRequest.Object_ptr RE_Operation, -- CORBA.ServerRequest.Operation RE_Set_Exception, -- CORBA.ServerRequest.Set_Exception RE_Set_Result, -- CORBA.ServerRequest.Set_Result -- Interface repository information entities RE_To_CORBA_String_2, -- CRR.To_CORBA_String RE_InterfaceDefSeq, -- CRR.InterfaceDefSeq RE_Append, -- CRR.Append RE_ATTR_READONLY, -- CRR.ATTR_READONLY RE_ATTR_NORMAL, -- CRR.ATTR_NORMAL RE_pk_void, -- CRR.RE_pk_void RE_pk_short, -- CRR.RE_pk_short RE_pk_long, -- CRR.RE_pk_long RE_pk_longlong, -- CRR.RE_pk_longlong RE_pk_ushort, -- CRR.RE_pk_ushort RE_pk_ulong, -- CRR.RE_pk_ulong RE_pk_ulonglong, -- CRR.RE_pk_ulonglong RE_pk_char, -- CRR.RE_pk_char RE_pk_wchar, -- CRR.RE_pk_wchar RE_pk_boolean, -- CRR.RE_pk_boolean RE_pk_float, -- CRR.RE_pk_float RE_pk_double, -- CRR.RE_pk_double RE_pk_longdouble, -- CRR.RE_pk_longdouble RE_pk_string, -- CRR.RE_pk_string RE_pk_wstring, -- CRR.RE_pk_wstring RE_pk_octet, -- CRR.RE_pk_octet RE_pk_objref, -- CRR.RE_pk_objref RE_pk_any, -- CRR.RE_pk_any RE_ParDescriptionSeq, -- CRR.ParDescriptionSeq RE_PARAM_IN, -- CRR.PARAM_IN RE_PARAM_INOUT, -- CRR.PARAM_INOUT RE_PARAM_OUT, -- CRR.PARAM_OUT RE_ParameterDescription, -- CRR.ParameterDescription RE_ExceptionDefSeq, -- CRR.ExceptionDefSeq RE_ContextIdSeq, -- CRR.ContextIdSeq RE_StructMemberSeq, -- CRR.StructMemberSeq RE_StructMember, -- CRR.StructMember RE_UnionMemberSeq, -- CRR.UnionMemberSeq RE_UnionMember, -- CRR.UnionMember RE_OP_ONEWAY, -- CRR.OP_ONEWAY RE_OP_NORMAL, -- CRR.OP_NORMAL RE_EnumMemberSeq, -- CRR.EnumMemberSeq RE_Ref_12, -- CRR.IRObject.Ref RE_Is_Nil_12, -- CRR.IRObject.Is_Nil RE_To_Ref_12, -- CRR.IRObject.Helper.To_Ref RE_Ref_13, -- CRR.Container.Ref RE_Lookup, -- CRR.Container.Lookup RE_Create_Interface, -- CRR.Container.Create_Interface RE_Create_Module, -- CRR.Container.Create_Module RE_Create_Enum, -- CRR.Container.Create_Enum RE_Create_Alias, -- CRR.Container.Create_Alias RE_Create_Struct, -- CRR.Container.Create_Struct RE_Create_Exception, -- CRR.Container.Create_Exception RE_Create_Union, -- CRR.Container.Create_Union RE_To_Ref_13, -- CRR.Container.Helper.To_Ref RE_To_Ref_14, -- CRR.InterfaceDef.Helper.To_Ref RE_Create_Attribute, -- CRR.InterfaceDef.Create_Attribute RE_Create_Operation, -- CRR.InterfaceDef.Create_Operation RE_To_Forward_2, -- CRR.InterfaceDef.Convert_Forward.To... RE_To_Ref_15, -- CRR.IDLType.Helper.To_Ref RE_To_Forward, -- CRR.IDLType.Convert_Forward.To_Forward RE_Create_Array, -- CRR.Repository.Create_Array RE_Create_Fixed, -- CRR.Repository.Create_Fixed RE_Create_Sequence, -- CRR.Repository.Create_Sequence RE_Get_Primitive, -- CRR.Repository.Get_Primitive -- Begin of the aligned entities (types) used for marshalling RE_Float_10, -- PolyORB.Aligned_Types.Float RE_Double_10, -- PolyORB.Aligned_Types.Double RE_Long_Double_10, -- PolyORB.Aligned_Types.Long_Double RE_Short_10, -- PolyORB.Aligned_Types.Short RE_Long_10, -- PolyORB.Aligned_Types.Long RE_Long_Long_10, -- PolyORB.Aligned_Types.Long_Long RE_Unsigned_Short_10, -- PolyORB.Aligned_Types.Unsigned_Short RE_Unsigned_Long_10, -- PolyORB.Aligned_Types.Unsigned_Long RE_Unsigned_Long_Long_10, -- PolyORB.Aligned_Types. -- Unsigned_Long_Long RE_Char_10, -- PolyORB.Aligned_Types.Char RE_Wchar_10, -- PolyORB.Aligned_Types.Wchar RE_String_10, -- PolyORB.Aligned_Types.String RE_Wide_String_10, -- PolyORB.Aligned_Types.Wide_String RE_Boolean_10, -- PolyORB.Aligned_Types.Boolean RE_Octet_10, -- PolyORB.Aligned_Types.Octet RE_Sequence_10, -- PolyORB.Aligned_Types.Sequence RE_Fixed_Point_10, -- PolyORB.Aligned_Types.Fixed_Point RE_Set_Note, -- PolyORB.Annotations.Set_Note RE_Aggregate_Content, -- PolyORB.Any.Agregate_Content RE_Any_1, -- PolyORB.Any.Any RE_Any_Container, -- PolyORB.Any.Any_Container RE_By_Value, -- PolyORB.Any.By_Value RE_By_Reference, -- PolyORB.Any.By_Reference RE_Copy_Any, -- PolyORB.Any.Copy_Any RE_From_Any_3, -- PolyORB.Any.From_Any RE_Get_Aggregate_Element_2, -- PolyORB.Any.Get_Aggregate_Element RE_Get_Container_2, -- PolyORB.Any.Get_Container RE_Get_Value, -- PolyORB.Any.Get_Value RE_Content, -- PolyORB.Any.Content RE_Content_Ptr, -- PolyORB.Any.Content_Ptr RE_NamedValue, -- PolyORB.Any.NamedValue RE_Is_Empty, -- PolyORB.Any.Is_Empty RE_Mechanism, -- PolyORB.Any.Mechanism RE_ARG_IN_1, -- PolyORB.Any.ARG_IN RE_ARG_OUT_1, -- PolyORB.Any.ARG_OUT RE_ARG_INOUT_1, -- PolyORB.Any.ARG_INOUT RE_TC_Unsigned_Long_1, -- PolyORB.Any.TC_Unsigned_Long RE_Set_Type_1, -- PolyORB.Any.Set_Type RE_Set_Value, -- PolyORB.Any.Set_Type RE_Wrap_1, -- PolyORB.Any.Wrap RE_Ref_3, -- PolyORB.Any.NVList.Ref RE_Create, -- PolyORB.Any.NVList.Create RE_Add_Item_1, -- PolyORB.Any.NVList.Add_Item RE_Local_Ref_1, -- PolyORB.Any.TypeCode.Local_Ref RE_Object_Ptr_2, -- PolyORB.Any.TypeCode.Object_Ptr RE_Object_7, -- PolyORB.Any.TypeCode.Object RE_TC_Object_1, -- PolyORB.Any.TypeCode.TC_Object RE_Object_Of_1, -- PolyORB.Any.TypeCode.Object_Of RE_To_Ref_1, -- PolyORB.Any.TypeCode.To_Ref RE_TC_Alias, -- PolyORB.Any.TypeCode.TC_Alias RE_TC_Enum, -- PolyORB.Any.TypeCode.TC_Enum RE_TC_Except, -- PolyORB.Any.TypeCode.TC_Except RE_TC_Struct, -- PolyORB.Any.TypeCode.TC_Struct RE_TC_Array, -- PolyORB.Any.TypeCode.TC_Array RE_TC_Union, -- PolyORB.Any.TypeCode.TC_Union RE_TC_Fixed, -- PolyORB.Any.TypeCode.TC_Fixed RE_Register_Exception, -- PolyORB.Any.TypeCode.Register_Exception RE_Buffer_Access, -- PolyORB.Buffers.Buffer_Access RE_Buffer_Type, -- PolyORB.Buffers.Buffer_Type RE_Align_Position, -- PolyORB.Buffers.Align_Position RE_Alignment_Type, -- PolyORB.Buffers.Alignment_Type RE_Pad_Align, -- PolyORB.Buffers.Pad_Align RE_CDR_Representation_Access, -- PolyORB.Representation.CDR. -- CDR_Representation_Access RE_Bind, -- PolyORB.Binding_Data.Bind RE_Add_Request_QoS, -- PolyORB.Request_QoS.Add_Request_QoS RE_Get_Request_QoS, -- PolyORB.Request_QoS.Get_Request_QoS RE_Extract_Request_Parameter, -- PolyORB.Request_QoS -- .Extract_Request_Parameter RE_Binding_Object_Access, -- PolyORB_Binding_Object. -- Binding_Object_Access RE_The_ORB, -- PolyORB.Setup.The_ORB RE_Ref_10, -- PolyORB.Smart_Pointers.Ref RE_GIOP_Session, -- PolyORB.Protocols.GIOP.GIOP_Session RE_Get_Component, -- PolyORB.Binding_Object.Get_Component RE_Get_Profile, -- PolyORB.Binding_Object.Get_Profile RE_Entity_Of, -- PolyORB.Smart_Pointers.Entity_Of RE_Message, -- PolyORB_Components.Message RE_Emit_No_Reply, -- PolyORB_Components.Emit_No_Reply RE_Component_Access, -- PolyORB_Components.Component_Access RE_Profile_Access, -- PolyORB.Binding_Data.Profile_Access RE_Get_Representation, -- PolyORB.Protocols.GIOP. -- Get_Representation RE_Get_Buffer, -- PolyORB.Protocols.GIOP. -- Get_Buffer RE_Get_GIOP_Version, -- PolyORB.Binding_Data.GIOP RE_Release, -- PolyORB.Buffers.Release RE_Operation_Payload, -- PolyORB.Protocols.GIOP. -- Operation_Payload RE_Flush, -- PolyORB.Protocols.Iface.Flush RE_CDR_Representation, -- PolyORB.Representations. -- CDR.CDR_Representation RE_Completed_No, -- PolyORB.Errors.Completed_No RE_Error_Container, -- PolyORB.Errors.Error_Container RE_Found, -- PolyORB.Errors.Found RE_Marshal_E, -- PolyORB.Errors.Marshal_E RE_System_Exception_Members, -- PolyORB.Errors.System_Exception_Members RE_Throw, -- PolyORB.Errors.Throw RE_User_Get_Members, -- PolyORB.Exceptions.User_get_Members RE_User_Raise_Exception, -- PolyORB.Exceptions.User_Raise_Exception RE_Module_Info, -- PolyORB.Initialization.Module_Info RE_Register_Module, -- PolyORB.Initialization.Register_Module RE_GIOP_Static_Buffer, -- PolyORB.QoS.GIOP_Static_Buffer RE_QoS_GIOP_Static_Buffer_Parameter_Access, -- PolyORB.QoS.Static_Buffers. -- QoS_GIOP_Static_Buffer_Parameter_Access RE_QoS_GIOP_Static_Buffer_Parameter, -- PolyORB.QoS.Static_Buffers. -- QoS_GIOP_Static_Buffer_Parameter RE_Set_Exception_Information, -- PolyORB.QoS.Exception_Informations RE_Ref_9, -- PolyORB.References.Ref RE_Marshall_1, -- PolyORB.Representations.CDR.Marshall RE_Marshall_2, -- PolyORB.Representations.CDR.Common. -- Marshall RE_Unmarshall_1, -- PolyORB.Representations.CDR.Unmarshall RE_Unmarshall_2, -- PolyORB.Representations.CDR.Common. -- Unmarshall RE_Pad_Compute, -- PolyORB.Buffers.Optimization. -- Pad_Compute RE_Type_Size, -- PolyORB.Buffers.Optimization. -- Type_Size RE_CDR_Position, -- PolyORB.Buffers.CDR_Position RE_Length, -- PolyORB.Buffers.Length RE_Preallocate_Buffer, -- PolyORB.Buffers.Optimization. -- Preallocate_Buffer RE_Extract_Data, -- PolyORB.Buffers.Extract_Data RE_Insert_Raw_Data, -- PolyIRB.buffers.Optimization. -- Insert_Raw_Data RE_Opaque_Pointer, -- PolyORB.Opaque.Opaque_Pointer RE_Arguments_2, -- PolyORB.Requests.Arguments RE_Request, -- PolyORB.Requests.Request RE_Request_Access, -- PolyORB.Requests.Request_Access RE_Request_Args, -- PolyORB.Requests.Request_Args RE_Request_Args_Access, -- PolyORB.Requests.Request_Args_Access RE_Request_Payload, -- PolyORB.Requests.Request_Payload RE_Request_Payload_Access, -- PolyORB.Requests.Request_Payload_Access RE_Setup_Request, -- PolyORB.Requests.Setup_Request RE_Flags, -- PolyORB.Requests.Flags RE_Sync_None, -- PolyORB.Requests.Sync_None RE_Sync_With_Transport, -- PolyORB.Requests.Sync_With_Transport RE_Sync_With_Server, -- PolyORB.Requests.Sync_With_Server RE_Sync_With_Target, -- PolyORB.Requests.Sync_With_Target RE_Sync_Call_Back, -- PolyORB.Requests.Sync_Call_Back RE_CORBA_Helper_1, -- PolyORB.Sequences.Bounded.CORBA_Helper RE_CORBA_Helper_2, -- PolyORB.Sequences.Unbounded. -- CORBA_Helper RE_Boolean_2, -- PolyORB.Std.Boolean RE_Integer, -- PolyORB.Std.Integer RE_Natural, -- PolyORB.Std.Natural RE_Positive, -- PolyORB.Std.Positive RE_String_2, -- PolyORB.Std.String RE_Nul, -- PolyORB.Std.ASCII.NUL RE_Identifier, -- PolyORB.Types.Identifier RE_Long_1, -- PolyORB.Types.Long RE_Long_Long_1, -- PolyORB.Types.Long_Long RE_Short_1, -- PolyORB.Types.Short RE_Unsigned_Long_Long_1, -- PolyORB.Types.Unisigned_Long_Long RE_Unsigned_Short_1, -- PolyORB.Types.Unisigned_Short RE_Float_1, -- PolyORB.Types.Float RE_Double_1, -- PolyORB.Types.Double RE_Long_Double_1, -- PolyORB.Types.Long_Double RE_Char_1, -- PolyORB.Types.Char RE_Wchar_1, -- PolyORB.Types.Wchar RE_Octet_1, -- PolyORB.Types.Octet RE_Boolean_1, -- PolyORB.Types.Boolean RE_Wide_String_1, -- PolyORB.Types.Wide_String RE_String_1, -- PolyORB.Types.String RE_Unsigned_Long_1, -- PolyORB.Types.Unsigned_Long RE_To_PolyORB_String, -- PolyORB.Types.To_PolyORB_String RE_To_PolyORB_Wide_String, -- PolyORB.Types.To_PolyORB_Wide_String RE_To_Standard_String_1, -- PolyORB.Types.To_Standard_String RE_To_Standard_Wide_String_1, -- PolyORB.Types.To_Standard_Wide_String RE_Get_Domain_Managers, -- PolyORB.CORBA_P.Domain_Management. -- Get_Domain_Managers RE_Get_Interface_Definition, -- PolyORB.CORBA_P.IR_Hooks. -- Get_Interface_Definition RE_Get_IR_Root, -- PolyORB.CORBA_P.IR_Tools.Get_IR_Root RE_Client_Invoke, -- PolyORB.CORBA_P. -- Interceptors_Hooks.Client_Invoke RE_Request_Raise_Occurrence, -- PolyORB.CORBA_P. -- Request_Raise_Occurrence RE_System_Exception_To_Any, -- PolyORB.CORBA_P. -- Exceptions.System_Exception_To_Any RE_Raise_From_Any, -- PolyORB.CORBA_P. -- Exceptions.Raise_From_Any RE_Raise_From_Error, -- PolyORB.CORBA_P. -- Exceptions.Raise_From_Error RE_Add, -- PolyORB.Utils.Strings."+" RE_And, -- PolyORB.Utils.Strings.Lists."&" RE_Empty, -- PolyORB.Utils.Strings.Lists.Empty RE_Register_Skeleton, -- PortableServer.Internals. -- Register_Skeleton RE_Servant, -- PortableServer.Servant RE_Servant_Base); -- PortableServer.Servant_Base subtype CORBA_Predefined_RU is RU_Id range RU_CORBA_Object .. RU_CORBA_TypeCode; -- Predefined CORBA interfaces that may be used directly in IDL -- files. subtype CORBA_Predefined_RE is RE_Id range RE_Any .. RE_PolicyList_2; -- Predefined CORBA entities that may be used directly in IDL -- files. CORBA_Predefined_RU_Table : constant array (CORBA_Predefined_RU) of RE_Id := (RU_CORBA_Object => RE_Ref_2, RU_CORBA_OObject => RE_Ref_2, RU_CORBA_Current => RE_Local_Ref, RU_CORBA_Policy => RE_Ref_6, RU_CORBA_DomainManager => RE_Ref_11, RU_CORBA_TypeCode => RE_Object); -- The corresponding reference type for each predefined CORBA -- interface. CORBA_Predefined_RU_Implem_Table : constant array (CORBA_Predefined_RU) of RE_Id := (RU_CORBA_Object => RE_Object_5, RU_CORBA_OObject => RE_Object_5, RU_CORBA_Current => RE_Object_4, RU_CORBA_Policy => RE_Object_3, RU_CORBA_DomainManager => RE_Object_8, RU_CORBA_TypeCode => RE_Object_6); -- The corresponding implementation type for each predefined CORBA -- interface. CORBA_Predefined_RU_Suffix : constant String := "%pred_ru%"; CORBA_Predefined_RE_Suffix : constant String := "%pred_re%"; -- These two suffixes are used to mark CORBA predefined entities -- names and avoid name conflicts with other marked names in IAC. CORBA_Predefined_RE_Table : constant array (CORBA_Predefined_RE) of RE_Id := (RE_Any => RE_Any, RE_Identifier_0 => RE_Identifier_0, RE_RepositoryId => RE_RepositoryId, RE_ScopedName => RE_ScopedName, RE_Visibility => RE_Visibility, RE_PolicyType => RE_PolicyType, RE_Float => RE_Float, RE_Double => RE_Double, RE_Long_Double => RE_Long_Double, RE_Short => RE_Short, RE_Long => RE_Long, RE_Long_Long => RE_Long_Long, RE_Unsigned_Short => RE_Unsigned_Short, RE_Unsigned_Long => RE_Unsigned_Long, RE_Unsigned_Long_Long => RE_Unsigned_Long_Long, RE_Char => RE_Char, RE_WChar => RE_WChar, RE_String_0 => RE_String_0, RE_Wide_String => RE_Wide_String, RE_Boolean => RE_Boolean, RE_Octet => RE_Octet, RE_Get_Domain_Policy => RE_Get_Domain_Policy, RE_Get_Policy_Type => RE_Get_Policy_Type, RE_Copy => RE_Copy, RE_AnySeq_1 => RE_AnySeq_2, RE_FloatSeq_1 => RE_FloatSeq_2, RE_DoubleSeq_1 => RE_DoubleSeq_2, RE_LongDoubleSeq_1 => RE_LongDoubleSeq_2, RE_ShortSeq_1 => RE_ShortSeq_2, RE_LongSeq_1 => RE_LongSeq_2, RE_LongLongSeq_1 => RE_LongLongSeq_2, RE_UShortSeq_1 => RE_UShortSeq_2, RE_ULongSeq_1 => RE_ULongSeq_2, RE_ULongLongSeq_1 => RE_ULongLongSeq_2, RE_CharSeq_1 => RE_CharSeq_2, RE_WCharSeq_1 => RE_WCharSeq_2, RE_StringSeq_1 => RE_StringSeq_2, RE_WStringSeq_1 => RE_WStringSeq_2, RE_BooleanSeq_1 => RE_BooleanSeq_2, RE_OctetSeq_1 => RE_OctetSeq_2, RE_PolicyList_1 => RE_PolicyList_2, RE_AnySeq_2 => RE_AnySeq_2, RE_FloatSeq_2 => RE_FloatSeq_2, RE_DoubleSeq_2 => RE_DoubleSeq_2, RE_LongDoubleSeq_2 => RE_LongDoubleSeq_2, RE_ShortSeq_2 => RE_ShortSeq_2, RE_LongSeq_2 => RE_LongSeq_2, RE_LongLongSeq_2 => RE_LongLongSeq_2, RE_UShortSeq_2 => RE_UShortSeq_2, RE_ULongSeq_2 => RE_ULongSeq_2, RE_ULongLongSeq_2 => RE_ULongLongSeq_2, RE_CharSeq_2 => RE_CharSeq_2, RE_WCharSeq_2 => RE_WCharSeq_2, RE_StringSeq_2 => RE_StringSeq_2, RE_WStringSeq_2 => RE_WStringSeq_2, RE_BooleanSeq_2 => RE_BooleanSeq_2, RE_OctetSeq_2 => RE_OctetSeq_2, RE_PolicyList_2 => RE_PolicyList_2); -- The corresponding relocated type of the CORBA module CORBA_Predefined_RE_Wrap_Table : constant array (CORBA_Predefined_RE) of RE_Id := (RE_Any => RE_Any, RE_Identifier_0 => RE_String_0, RE_RepositoryId => RE_String_0, RE_ScopedName => RE_String_0, RE_Visibility => RE_Short, RE_PolicyType => RE_Unsigned_Long, RE_Float => RE_Float, RE_Double => RE_Double, RE_Long_Double => RE_Long_Double, RE_Short => RE_Short, RE_Long => RE_Long, RE_Long_Long => RE_Long_Long, RE_Unsigned_Short => RE_Unsigned_Short, RE_Unsigned_Long => RE_Unsigned_Long, RE_Unsigned_Long_Long => RE_Unsigned_Long_Long, RE_Char => RE_Char, RE_WChar => RE_WChar, RE_String_0 => RE_String_0, RE_Wide_String => RE_Wide_String, RE_Boolean => RE_Boolean, RE_Octet => RE_Octet, RE_Get_Domain_Policy => RE_Get_Domain_Policy, RE_Get_Policy_Type => RE_Get_Policy_Type, RE_Copy => RE_Copy, RE_AnySeq_1 => RE_Sequence_201, RE_BooleanSeq_1 => RE_Sequence_202, RE_CharSeq_1 => RE_Sequence_203, RE_WCharSeq_1 => RE_Sequence_204, RE_OctetSeq_1 => RE_Sequence_205, RE_ShortSeq_1 => RE_Sequence_206, RE_UShortSeq_1 => RE_Sequence_207, RE_LongSeq_1 => RE_Sequence_208, RE_ULongSeq_1 => RE_Sequence_209, RE_LongLongSeq_1 => RE_Sequence_210, RE_ULongLongSeq_1 => RE_Sequence_211, RE_FloatSeq_1 => RE_Sequence_212, RE_DoubleSeq_1 => RE_Sequence_213, RE_LongDoubleSeq_1 => RE_Sequence_214, RE_StringSeq_1 => RE_Sequence_215, RE_WStringSeq_1 => RE_Sequence_216, -- The CORBA.Policy.PolicyList type is a "subtype" of -- CORBA.IDL_SEQUENCE_Policy.Sequence. So we return -- CORBA.Policy.PolicyList to avoid compiler warnings when -- casting. RE_PolicyList_1 => RE_PolicyList_2, RE_AnySeq_2 => RE_Sequence_201, RE_BooleanSeq_2 => RE_Sequence_202, RE_CharSeq_2 => RE_Sequence_203, RE_WCharSeq_2 => RE_Sequence_204, RE_OctetSeq_2 => RE_Sequence_205, RE_ShortSeq_2 => RE_Sequence_206, RE_UShortSeq_2 => RE_Sequence_207, RE_LongSeq_2 => RE_Sequence_208, RE_ULongSeq_2 => RE_Sequence_209, RE_LongLongSeq_2 => RE_Sequence_210, RE_ULongLongSeq_2 => RE_Sequence_211, RE_FloatSeq_2 => RE_Sequence_212, RE_DoubleSeq_2 => RE_Sequence_213, RE_LongDoubleSeq_2 => RE_Sequence_214, RE_StringSeq_2 => RE_Sequence_215, RE_WStringSeq_2 => RE_Sequence_216, RE_PolicyList_2 => RE_PolicyList_2); -- The corresponding relocated parent type of the CORBA module for -- which a Wrap function has been generated. RE_Unit_Table : constant array (RE_Id) of RU_Id := (RE_Null => RU_Null, RE_Ref_0 => RU_Null, RE_To_Any_1 => RU_Null, RE_Boolean_0 => RU_Null, RE_False => RU_Null, RE_Marshaller => RU_Null, RE_True => RU_Null, RE_On => RU_Null, RE_Off => RU_Null, RE_Discriminant_Check => RU_Null, RE_Range_Check => RU_Null, RE_Validity_Check => RU_Null, RE_Register_IR_Info => RU_Null, RE_Convert => RU_Null, RE_Convert_Forward => RU_Null, RE_Element_TC => RU_Null, RE_Sequence_TC => RU_Null, RE_TC_Bounded_String => RU_Null, RE_TC_Bounded_Wide_String => RU_Null, RE_Unmarshaller => RU_Null, RE_Payload_Args => RU_Null, RE_Length_2 => RU_Null, RE_Get_Element => RU_Null, RE_Exception_Occurrence => RU_Ada_Exceptions, RE_Stream_Element_Count => RU_Ada_Streams, RE_ARG_IN_0 => RU_CORBA, RE_ARG_OUT_0 => RU_CORBA, RE_ARG_INOUT_0 => RU_CORBA, RE_Default_Sys_Member => RU_CORBA, RE_TC_Void => RU_CORBA, RE_To_Any_0 => RU_CORBA, RE_From_Any_0 => RU_CORBA, RE_Wrap_2 => RU_CORBA, RE_Get_Container_1 => RU_CORBA, RE_Get_Aggregate_Element => RU_CORBA_Internals, RE_Get_Empty_Any => RU_CORBA_Internals, RE_Any => RU_CORBA, RE_Identifier_0 => RU_CORBA, RE_RepositoryId => RU_CORBA, RE_ScopedName => RU_CORBA, RE_Visibility => RU_CORBA, RE_PolicyType => RU_CORBA, RE_Float => RU_CORBA, RE_Double => RU_CORBA, RE_Long_Double => RU_CORBA, RE_Short => RU_CORBA, RE_Long => RU_CORBA, RE_Long_Long => RU_CORBA, RE_Unsigned_Short => RU_CORBA, RE_Unsigned_Long => RU_CORBA, RE_Unsigned_Long_Long => RU_CORBA, RE_Char => RU_CORBA, RE_WChar => RU_CORBA, RE_String_0 => RU_CORBA, RE_Wide_String => RU_CORBA, RE_Boolean => RU_CORBA, RE_Octet => RU_CORBA, RE_AnySeq_1 => RU_CORBA, RE_FloatSeq_1 => RU_CORBA, RE_DoubleSeq_1 => RU_CORBA, RE_LongDoubleSeq_1 => RU_CORBA, RE_ShortSeq_1 => RU_CORBA, RE_LongSeq_1 => RU_CORBA, RE_LongLongSeq_1 => RU_CORBA, RE_UShortSeq_1 => RU_CORBA, RE_ULongSeq_1 => RU_CORBA, RE_ULongLongSeq_1 => RU_CORBA, RE_CharSeq_1 => RU_CORBA, RE_WCharSeq_1 => RU_CORBA, RE_StringSeq_1 => RU_CORBA, RE_WStringSeq_1 => RU_CORBA, RE_BooleanSeq_1 => RU_CORBA, RE_OctetSeq_1 => RU_CORBA, RE_PolicyList_1 => RU_CORBA, RE_To_CORBA_String_2 => RU_CORBA_Repository_Root, RE_InterfaceDefSeq => RU_CORBA_Repository_Root, RE_Append => RU_CORBA_Repository_Root, RE_ATTR_READONLY => RU_CORBA_Repository_Root, RE_ATTR_NORMAL => RU_CORBA_Repository_Root, RE_pk_void => RU_CORBA_Repository_Root, RE_pk_short => RU_CORBA_Repository_Root, RE_pk_long => RU_CORBA_Repository_Root, RE_pk_longlong => RU_CORBA_Repository_Root, RE_pk_ushort => RU_CORBA_Repository_Root, RE_pk_ulong => RU_CORBA_Repository_Root, RE_pk_ulonglong => RU_CORBA_Repository_Root, RE_pk_char => RU_CORBA_Repository_Root, RE_pk_wchar => RU_CORBA_Repository_Root, RE_pk_boolean => RU_CORBA_Repository_Root, RE_pk_float => RU_CORBA_Repository_Root, RE_pk_double => RU_CORBA_Repository_Root, RE_pk_longdouble => RU_CORBA_Repository_Root, RE_pk_string => RU_CORBA_Repository_Root, RE_pk_wstring => RU_CORBA_Repository_Root, RE_pk_octet => RU_CORBA_Repository_Root, RE_pk_objref => RU_CORBA_Repository_Root, RE_pk_any => RU_CORBA_Repository_Root, RE_ParDescriptionSeq => RU_CORBA_Repository_Root, RE_PARAM_IN => RU_CORBA_Repository_Root, RE_PARAM_INOUT => RU_CORBA_Repository_Root, RE_PARAM_OUT => RU_CORBA_Repository_Root, RE_ParameterDescription => RU_CORBA_Repository_Root, RE_ExceptionDefSeq => RU_CORBA_Repository_Root, RE_ContextIdSeq => RU_CORBA_Repository_Root, RE_StructMemberSeq => RU_CORBA_Repository_Root, RE_StructMember => RU_CORBA_Repository_Root, RE_UnionMemberSeq => RU_CORBA_Repository_Root, RE_UnionMember => RU_CORBA_Repository_Root, RE_OP_ONEWAY => RU_CORBA_Repository_Root, RE_OP_NORMAL => RU_CORBA_Repository_Root, RE_EnumMemberSeq => RU_CORBA_Repository_Root, RE_Ref_12 => RU_CORBA_Repository_Root_IRObject, RE_Is_Nil_12 => RU_CORBA_Repository_Root_IRObject, RE_To_Ref_12 => RU_CORBA_Repository_Root_IRObject_Helper, RE_Lookup => RU_CORBA_Repository_Root_Container, RE_Ref_13 => RU_CORBA_Repository_Root_Container, RE_Create_Interface => RU_CORBA_Repository_Root_Container, RE_Create_Module => RU_CORBA_Repository_Root_Container, RE_Create_Enum => RU_CORBA_Repository_Root_Container, RE_Create_Alias => RU_CORBA_Repository_Root_Container, RE_Create_Struct => RU_CORBA_Repository_Root_Container, RE_Create_Exception => RU_CORBA_Repository_Root_Container, RE_Create_Union => RU_CORBA_Repository_Root_Container, RE_To_Ref_13 => RU_CORBA_Repository_Root_Container_Helper, RE_To_Ref_14 => RU_CORBA_Repository_Root_InterfaceDef_Helper, RE_Create_Attribute => RU_CORBA_Repository_Root_InterfaceDef, RE_Create_Operation => RU_CORBA_Repository_Root_InterfaceDef, RE_To_Forward_2 => RU_CORBA_Repository_Root_InterfaceDef_Convert_Forward, RE_To_Ref_15 => RU_CORBA_Repository_Root_IDLType_Helper, Re_To_Forward => RU_CORBA_Repository_Root_IDLType_Convert_Forward, RE_Create_Array => RU_CORBA_Repository_Root_Repository, RE_Create_Fixed => RU_CORBA_Repository_Root_Repository, RE_Create_Sequence => RU_CORBA_Repository_Root_Repository, RE_Get_Primitive => RU_CORBA_Repository_Root_Repository, RE_Float_10 => RU_PolyORB_Aligned_Types, RE_Double_10 => RU_PolyORB_Aligned_Types, RE_Long_Double_10 => RU_PolyORB_Aligned_Types, RE_Short_10 => RU_PolyORB_Aligned_Types, RE_Long_10 => RU_PolyORB_Aligned_Types, RE_Long_Long_10 => RU_PolyORB_Aligned_Types, RE_Unsigned_Short_10 => RU_PolyORB_Aligned_Types, RE_Unsigned_Long_10 => RU_PolyORB_Aligned_Types, RE_Unsigned_Long_Long_10 => RU_PolyORB_Aligned_Types, RE_Char_10 => RU_PolyORB_Aligned_Types, RE_Wchar_10 => RU_PolyORB_Aligned_Types, RE_String_10 => RU_PolyORB_Aligned_Types, RE_Wide_String_10 => RU_PolyORB_Aligned_Types, RE_Boolean_10 => RU_PolyORB_Aligned_Types, RE_Octet_10 => RU_PolyORB_Aligned_Types, RE_Sequence_10 => RU_PolyORB_Aligned_Types, RE_Fixed_Point_10 => RU_PolyORB_Aligned_Types, RE_AnySeq_2 => RU_CORBA_IDL_Sequences, RE_FloatSeq_2 => RU_CORBA_IDL_Sequences, RE_DoubleSeq_2 => RU_CORBA_IDL_Sequences, RE_LongDoubleSeq_2 => RU_CORBA_IDL_Sequences, RE_ShortSeq_2 => RU_CORBA_IDL_Sequences, RE_LongSeq_2 => RU_CORBA_IDL_Sequences, RE_LongLongSeq_2 => RU_CORBA_IDL_Sequences, RE_UShortSeq_2 => RU_CORBA_IDL_Sequences, RE_ULongSeq_2 => RU_CORBA_IDL_Sequences, RE_ULongLongSeq_2 => RU_CORBA_IDL_Sequences, RE_CharSeq_2 => RU_CORBA_IDL_Sequences, RE_WCharSeq_2 => RU_CORBA_IDL_Sequences, RE_StringSeq_2 => RU_CORBA_IDL_Sequences, RE_WStringSeq_2 => RU_CORBA_IDL_Sequences, RE_BooleanSeq_2 => RU_CORBA_IDL_Sequences, RE_OctetSeq_2 => RU_CORBA_IDL_Sequences, RE_PolicyList_2 => RU_CORBA_Policy, RE_TC_AnySeq => RU_CORBA_IDL_Sequences_Helper, RE_TC_FloatSeq => RU_CORBA_IDL_Sequences_Helper, RE_TC_DoubleSeq => RU_CORBA_IDL_Sequences_Helper, RE_TC_LongDoubleSeq => RU_CORBA_IDL_Sequences_Helper, RE_TC_ShortSeq => RU_CORBA_IDL_Sequences_Helper, RE_TC_LongSeq => RU_CORBA_IDL_Sequences_Helper, RE_TC_LongLongSeq => RU_CORBA_IDL_Sequences_Helper, RE_TC_UShortSeq => RU_CORBA_IDL_Sequences_Helper, RE_TC_ULongSeq => RU_CORBA_IDL_Sequences_Helper, RE_TC_ULongLongSeq => RU_CORBA_IDL_Sequences_Helper, RE_TC_CharSeq => RU_CORBA_IDL_Sequences_Helper, RE_TC_WCharSeq => RU_CORBA_IDL_Sequences_Helper, RE_TC_StringSeq => RU_CORBA_IDL_Sequences_Helper, RE_TC_WStringSeq => RU_CORBA_IDL_Sequences_Helper, RE_TC_BooleanSeq => RU_CORBA_IDL_Sequences_Helper, RE_TC_OctetSeq => RU_CORBA_IDL_Sequences_Helper, RE_From_Any_4 => RU_CORBA_IDL_Sequences_Helper, RE_To_Any_4 => RU_CORBA_IDL_Sequences_Helper, RE_Wrap_4 => RU_CORBA_IDL_Sequences_Helper, RE_Sequence_201 => RU_CORBA_IDL_Sequences_IDL_SEQUENCE_Any, RE_Sequence_202 => RU_CORBA_IDL_Sequences_IDL_SEQUENCE_Boolean, RE_Sequence_203 => RU_CORBA_IDL_Sequences_IDL_SEQUENCE_Char, RE_Sequence_204 => RU_CORBA_IDL_Sequences_IDL_SEQUENCE_Wide_Char, RE_Sequence_205 => RU_CORBA_IDL_Sequences_IDL_SEQUENCE_Octet, RE_Sequence_206 => RU_CORBA_IDL_Sequences_IDL_SEQUENCE_Short, RE_Sequence_207 => RU_CORBA_IDL_Sequences_IDL_SEQUENCE_Unsigned_Short, RE_Sequence_208 => RU_CORBA_IDL_Sequences_IDL_SEQUENCE_Long, RE_Sequence_209 => RU_CORBA_IDL_Sequences_IDL_SEQUENCE_Unsigned_Long, RE_Sequence_210 => RU_CORBA_IDL_Sequences_IDL_SEQUENCE_Long_Long, RE_Sequence_211 => RU_CORBA_IDL_Sequences_IDL_SEQUENCE_Unsigned_Long_Long, RE_Sequence_212 => RU_CORBA_IDL_Sequences_IDL_SEQUENCE_Float, RE_Sequence_213 => RU_CORBA_IDL_Sequences_IDL_SEQUENCE_Double, RE_Sequence_214 => RU_CORBA_IDL_Sequences_IDL_SEQUENCE_Long_Double, RE_Sequence_215 => RU_CORBA_IDL_Sequences_IDL_SEQUENCE_String, RE_Sequence_216 => RU_CORBA_IDL_Sequences_IDL_SEQUENCE_Wide_String, RE_Is_Equivalent => RU_CORBA, RE_TC_Any => RU_CORBA, RE_TC_Float => RU_CORBA, RE_TC_Double => RU_CORBA, RE_TC_Long_Double => RU_CORBA, RE_TC_Short => RU_CORBA, RE_TC_Long => RU_CORBA, RE_TC_Long_Long => RU_CORBA, RE_TC_Unsigned_Short => RU_CORBA, RE_TC_Unsigned_Long => RU_CORBA, RE_TC_Unsigned_Long_Long => RU_CORBA, RE_TC_Char => RU_CORBA, RE_TC_WChar => RU_CORBA, RE_TC_String => RU_CORBA, RE_TC_Wide_String => RU_CORBA, RE_TC_Boolean => RU_CORBA, RE_TC_Octet => RU_CORBA, RE_TC_TypeCode => RU_CORBA, RE_TC_Null => RU_CORBA, RE_TC_Buffer => RU_PolyORB_Any, RE_TC_RepositoryId => RU_CORBA_Helper, RE_TC_Identifier => RU_CORBA_Helper, RE_TC_ScopedName => RU_CORBA_Helper, RE_TC_Visibility => RU_CORBA_Helper, RE_TC_PolicyType => RU_CORBA_Helper, RE_From_Any_2 => RU_CORBA_Helper, RE_To_Any_2 => RU_CORBA_Helper, RE_To_Standard_String => RU_CORBA, RE_To_Standard_Wide_String => RU_CORBA, RE_IDL_Exception_Members => RU_CORBA, RE_To_CORBA_String => RU_CORBA, RE_To_CORBA_Wide_String => RU_CORBA, RE_Raise_Bad_Operation => RU_CORBA, RE_Raise_Inv_Objref => RU_CORBA, RE_Raise_Bad_Param => RU_CORBA, RE_Ref_11 => RU_CORBA_DomainManager, RE_Get_Domain_Policy => RU_CORBA_DomainManager, RE_Object_8 => RU_CORBA_DomainManager_Impl, RE_To_Ref_5 => RU_CORBA_DomainManager_Helper, RE_From_Any_5 => RU_CORBA_DomainManager_Helper, RE_To_Any_5 => RU_CORBA_DomainManager_Helper, RE_TC_DomainManager => RU_CORBA_DomainManager_Helper, RE_Get_Domain_Policy_Args_Type => RU_CORBA_DomainManager_CDR, RE_Get_Domain_Policy_Marshaller => RU_CORBA_DomainManager_CDR, RE_Get_Domain_Policy_Unmarshaller => RU_CORBA_DomainManager_CDR, RE_Create_List_1 => RU_CORBA_ExceptionList, RE_Add_1 => RU_CORBA_ExceptionList, RE_Ref_5 => RU_CORBA_ExceptionList, RE_To_PolyORB_Ref_1 => RU_CORBA_ExceptionList_Internals, RE_Add_Parameter => RU_CORBA_Internals, RE_Set_Type => RU_CORBA_Internals, RE_Get_Empty_Any_Aggregate => RU_CORBA_Internals, RE_Add_Aggregate_Element => RU_CORBA_Internals, RE_Get_Wrapper_Any => RU_CORBA_Internals, RE_Ref_1 => RU_CORBA_AbstractBase, RE_Ref_8 => RU_CORBA_Context, RE_Buff_Access_To_Ulong => RU_PolyORB_Buffers_Optimization, RE_Move_Any_Value => RU_CORBA_Internals, RE_Object_2 => RU_CORBA_Local, RE_Add_Item_0 => RU_CORBA_NVList, RE_Ref_4 => RU_CORBA_NVList, RE_Clone_Out_Args => RU_CORBA_NVList_Internals, RE_Ref_2 => RU_CORBA_Object, RE_Object_Of => RU_CORBA_Object, RE_Is_A => RU_CORBA_Object, RE_Is_Nil => RU_CORBA_Object, RE_To_PolyORB_Ref => RU_CORBA_Object_Internals, RE_To_CORBA_Ref => RU_CORBA_Object_Internals, RE_From_Any_1 => RU_CORBA_Object_Helper, RE_TC_Object_0 => RU_CORBA_Object_Helper, RE_To_Any_3 => RU_CORBA_Object_Helper, RE_Wrap_3 => RU_CORBA_Object_Helper, RE_Ref_6 => RU_CORBA_Policy, RE_Get_Policy_Type => RU_CORBA_Policy, RE_Copy => RU_CORBA_Policy, RE_TC_Policy => RU_CORBA_Policy_Helper, RE_To_Ref_6 => RU_CORBA_Policy_Helper, RE_From_Any_6 => RU_CORBA_Policy_Helper, RE_To_Any_6 => RU_CORBA_Policy_Helper, RE_Get_Policy_Type_Args_Type => RU_CORBA_Policy_CDR, RE_Get_Policy_Type_Marshaller => RU_CORBA_Policy_CDR, RE_Get_Policy_Type_Unmarshaller => RU_CORBA_Policy_CDR, RE_Copy_Args_Type => RU_CORBA_Policy_CDR, RE_Copy_Marshaller => RU_CORBA_Policy_CDR, RE_Copy_Unmarshaller => RU_CORBA_Policy_CDR, RE_Object_3 => RU_CORBA_Policy_Impl, RE_Local_Ref => RU_CORBA_Current, RE_Object_4 => RU_CORBA_Current_Impl, RE_Object_5 => RU_CORBA_Object_Impl, RE_Object_6 => RU_CORBA_TypeCode_Impl, RE_Create_List => RU_CORBA_ORB, RE_Get_Default_Context => RU_CORBA_ORB, RE_Arguments_1 => RU_CORBA_ServerRequest, RE_Object_Ptr => RU_CORBA_ServerRequest, RE_Operation => RU_CORBA_ServerRequest, RE_Set_Exception => RU_CORBA_ServerRequest, RE_Set_Result => RU_CORBA_ServerRequest, RE_Object => RU_CORBA_TypeCode, RE_Build_Sequence_TC => RU_CORBA_TypeCode_Internals, RE_Build_Alias_TC => RU_CORBA_TypeCode_Internals, RE_Build_String_TC => RU_CORBA_TypeCode_Internals, RE_Build_Wstring_TC => RU_CORBA_TypeCode_Internals, RE_To_CORBA_Object => RU_CORBA_TypeCode_Internals, RE_To_PolyORB_Object => RU_CORBA_TypeCode_Internals, RE_Disable_Reference_Counting => RU_CORBA_TypeCode_Internals, RE_Set_Note => RU_PolyORB_Annotations, RE_Aggregate_Content => RU_PolyORB_Any, RE_Any_1 => RU_PolyORB_Any, RE_Any_Container => RU_PolyORB_Any, RE_By_Value => RU_PolyORB_Any, RE_By_Reference => RU_PolyORB_Any, RE_Copy_Any => RU_PolyORB_Any, RE_Content => RU_PolyORB_Any, RE_Content_Ptr => RU_PolyORB_Any, RE_From_Any_3 => RU_PolyORB_Any, RE_Get_Aggregate_Element_2 => RU_PolyORB_Any, RE_Get_Container_2 => RU_PolyORB_Any, RE_Get_Value => RU_PolyORB_Any, RE_Is_Empty => RU_PolyORB_Any, RE_Mechanism => RU_PolyORB_Any, RE_NamedValue => RU_PolyORB_Any, RE_ARG_IN_1 => RU_PolyORB_Any, RE_ARG_OUT_1 => RU_PolyORB_Any, RE_ARG_INOUT_1 => RU_PolyORB_Any, RE_TC_Unsigned_Long_1 => RU_PolyORB_Any, RE_Set_Type_1 => RU_PolyORB_Any, RE_Set_Value => RU_PolyORB_Any, RE_Wrap_1 => RU_PolyORB_Any, RE_Ref_3 => RU_PolyORB_Any_NVList, RE_Create => RU_PolyORB_Any_NVList, RE_Add_Item_1 => RU_PolyORB_Any_NVList, RE_Local_Ref_1 => RU_PolyORB_Any_TypeCode, RE_Object_Ptr_2 => RU_PolyORB_Any_TypeCode, RE_Object_7 => RU_PolyORB_Any_TypeCode, RE_Object_Of_1 => RU_PolyORB_Any_TypeCode, RE_To_Ref_1 => RU_PolyORB_Any_TypeCode, RE_TC_Alias => RU_PolyORB_Any_TypeCode, RE_TC_Array => RU_PolyORB_Any_TypeCode, RE_TC_Enum => RU_PolyORB_Any_TypeCode, RE_TC_Except => RU_PolyORB_Any_TypeCode, RE_TC_Object_1 => RU_PolyORB_Any_TypeCode, RE_TC_Struct => RU_PolyORB_Any_TypeCode, RE_TC_Union => RU_PolyORB_Any_TypeCode, RE_TC_Fixed => RU_PolyORB_Any_TypeCode, RE_Buffer_Access => RU_PolyORB_Buffers, RE_Buffer_Type => RU_PolyORB_Buffers, RE_Align_Position => RU_PolyORB_Buffers, RE_Alignment_Type => RU_PolyORB_Buffers, RE_Pad_Align => RU_PolyORB_Buffers, RE_Release => RU_PolyORB_Buffers, RE_CDR_Representation_Access => RU_PolyORB_Representations_CDR, RE_Bind => RU_PolyORB_References_Binding, RE_Add_Request_QoS => RU_PolyORB_Request_QoS, RE_Get_Request_QoS => RU_PolyORB_Request_QoS, RE_Extract_Request_Parameter => RU_PolyORB_Request_QoS, RE_Binding_Object_Access => RU_PolyORB_Binding_Objects, RE_The_ORB => RU_PolyORB_Setup, RE_Ref_10 => RU_PolyORB_Smart_Pointers, RE_GIOP_Session => RU_PolyORB_Protocols_GIOP, RE_Get_Component => RU_PolyORB_Binding_Objects, RE_Get_Profile => RU_PolyORB_Binding_Objects, RE_Entity_Of => RU_PolyORB_Smart_Pointers, RE_Get_Representation => RU_PolyORB_Protocols_GIOP, RE_Get_Buffer => RU_PolyORB_Protocols_GIOP, RE_Message => RU_PolyORB_Components, RE_Emit_No_Reply => RU_PolyORB_Components, RE_Component_Access => RU_PolyORB_Components, RE_Profile_Access => RU_PolyORB_Binding_Data, RE_Get_GIOP_Version => RU_PolyORB_Binding_Data_GIOP, RE_Operation_Payload => RU_PolyORB_Protocols_GIOP, RE_Flush => RU_PolyORB_Protocols_Iface, RE_Completed_No => RU_PolyORB_Errors, RE_Error_Container => RU_PolyORB_Errors, RE_Found => RU_PolyORB_Errors, RE_Marshal_E => RU_PolyORB_Errors, RE_System_Exception_Members => RU_PolyORB_Errors, RE_Throw => RU_PolyORB_Errors, RE_Register_Exception => RU_PolyORB_Exceptions, RE_User_Get_Members => RU_PolyORB_Exceptions, RE_User_Raise_Exception => RU_PolyORB_Exceptions, RE_Raise_From_Any => RU_PolyORB_CORBA_P_Exceptions, RE_Request_Raise_Occurrence => RU_PolyORB_CORBA_P_Exceptions, RE_Raise_From_Error => RU_PolyORB_CORBA_P_Exceptions, RE_System_Exception_To_Any => RU_PolyORB_CORBA_P_Exceptions, RE_Get_Domain_Managers => RU_PolyORB_CORBA_P_Domain_Management, RE_Get_Interface_Definition => RU_PolyORB_CORBA_P_IR_Hooks, RE_Get_IR_Root => RU_PolyORB_CORBA_P_IR_Tools, RE_Client_Invoke => RU_PolyORB_CORBA_P_Interceptors_Hooks, RE_Module_Info => RU_PolyORB_Initialization, RE_Register_Module => RU_PolyORB_Initialization, RE_GIOP_Static_Buffer => RU_PolyORB_QoS, RE_QoS_GIOP_Static_Buffer_Parameter => RU_PolyORB_QoS_Static_Buffers, RE_QoS_GIOP_Static_Buffer_Parameter_Access => RU_PolyORB_QoS_Static_Buffers, RE_Set_Exception_Information => RU_PolyORB_QoS_Exception_Informations, RE_Ref_9 => RU_PolyORB_References, RE_CDR_Representation => RU_PolyORB_Representations_CDR, RE_Marshall_1 => RU_PolyORB_Representations_CDR, RE_Marshall_2 => RU_PolyORB_Representations_CDR_Common, RE_Unmarshall_1 => RU_PolyORB_Representations_CDR, RE_Unmarshall_2 => RU_PolyORB_Representations_CDR_Common, RE_Pad_Compute => RU_PolyORB_Buffers_Optimization, RE_Type_Size => RU_PolyORB_Buffers_Optimization, RE_CDR_Position => RU_PolyORB_Buffers, RE_Length => RU_PolyORB_Buffers, RE_Preallocate_Buffer => RU_PolyORB_Buffers_Optimization, RE_Extract_Data => RU_PolyORB_Buffers, RE_Insert_Raw_Data => RU_PolyORB_Buffers_Optimization, RE_Opaque_Pointer => RU_PolyORB_Opaque, RE_Arguments_2 => RU_PolyORB_Requests, RE_Request => RU_PolyORB_Requests, RE_Request_Access => RU_PolyORB_Requests, RE_Request_Args => RU_PolyORB_Requests, RE_Request_Args_Access => RU_PolyORB_Requests, RE_Request_Payload => RU_PolyORB_Requests, RE_Request_Payload_Access => RU_PolyORB_Requests, RE_Setup_Request => RU_PolyORB_Requests, RE_Flags => RU_PolyORB_Requests, RE_Sync_None => RU_PolyORB_Requests, RE_Sync_With_Transport => RU_PolyORB_Requests, RE_Sync_With_Server => RU_PolyORB_Requests, RE_Sync_With_Target => RU_PolyORB_Requests, RE_Sync_Call_Back => RU_PolyORB_Requests, RE_CORBA_Helper_1 => RU_PolyORB_Sequences_Bounded_CORBA_Helper, RE_CORBA_Helper_2 => RU_PolyORB_Sequences_Unbounded_CORBA_Helper, RE_Boolean_2 => RU_PolyORB_Std, RE_Positive => RU_PolyORB_Std, RE_Integer => RU_PolyORB_Std, RE_Natural => RU_PolyORB_Std, RE_String_2 => RU_PolyORB_Std, RE_Nul => RU_PolyORB_Std_ASCII, RE_Address => RU_PolyORB_Types, RE_Identifier => RU_PolyORB_Types, RE_Long_1 => RU_PolyORB_Types, RE_Short_1 => RU_PolyORB_Types, RE_Long_Long_1 => RU_PolyORB_Types, RE_Unsigned_Long_Long_1 => RU_PolyORB_Types, RE_Unsigned_Short_1 => RU_PolyORB_Types, RE_Float_1 => RU_PolyORB_Types, RE_Double_1 => RU_PolyORB_Types, RE_Long_Double_1 => RU_PolyORB_Types, RE_Char_1 => RU_PolyORB_Types, RE_Wchar_1 => RU_PolyORB_Types, RE_Octet_1 => RU_PolyORB_Types, RE_Boolean_1 => RU_PolyORB_Types, RE_Wide_String_1 => RU_PolyORB_Types, RE_String_1 => RU_PolyORB_Types, RE_Unsigned_Long_1 => RU_PolyORB_Types, RE_To_PolyORB_String => RU_PolyORB_Types, RE_To_PolyORB_Wide_String => RU_PolyORB_Types, RE_To_Standard_String_1 => RU_PolyORB_Types, RE_To_Standard_Wide_String_1 => RU_PolyORB_Types, RE_Add => RU_PolyORB_Utils_Strings, RE_And => RU_PolyORB_Utils_Strings_Lists, RE_Empty => RU_PolyORB_Utils_Strings_Lists, RE_Register_Skeleton => RU_PortableServer_Internals, RE_Servant => RU_PortableServer, RE_Servant_Base => RU_PortableServer); procedure Initialize; function RE (Id : RE_Id; Withed : Boolean := True) return Node_Id; -- Return a designator for entity Id function RU (Id : RU_Id; Withed : Boolean := True) return Node_Id; -- Return a node for Unit id end Backend.BE_CORBA_Ada.Runtime; polyorb-2.8~20110207.orig/compilers/iac/frontend.ads0000644000175000017500000000407111750740337021453 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- F R O N T E N D -- -- -- -- S p e c -- -- -- -- Copyright (C) 2005-2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ package Frontend is pragma Pure; end Frontend; polyorb-2.8~20110207.orig/compilers/iac/flags.ads0000644000175000017500000000554311750740337020735 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- F L A G S -- -- -- -- S p e c -- -- -- -- Copyright (C) 2005-2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with Types; use Types; package Flags is Main_Source : Types.Name_Id := Types.No_Name; -- IDL source name Use_Stdout : Boolean := False; -- True when we want to generate sources in the standard output Print_Full_Tree : Boolean := False; -- Output tree Preprocess_Only : Boolean := False; -- True when we only preprocess the IDL source file and output it No_Preprocess : Boolean := False; -- No preprocessing pass, assume input file has already been preprocessed Compile_Only : Boolean := False; -- True when we only compile the IDL source file and exit Output_Directory : String_Ptr := null; -- The output directory Quiet : Boolean := False; -- Quiet mode: no output unless warnings or errors need to be displayed end Flags; polyorb-2.8~20110207.orig/compilers/iac/backend-be_corba_ada.ads0000644000175000017500000001432611750740337023566 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- B A C K E N D . B E _ C O R B A _ A D A -- -- -- -- S p e c -- -- -- -- Copyright (C) 2005-2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- This is the package responsible of generating the CORBA Ada tree -- from the IDL tree according to the CORBA Ada mapping -- specifications. with GNAT.Perfect_Hash_Generators; package Backend.BE_CORBA_Ada is procedure Generate (E : Node_Id); -- Creates the Ada tree, then depending on the user options -- generate the Ada code, dumps the tree... -- The Generate procedure uses Visitor Functions. Visitor_XXX -- stands for visit IDL node XXX. The returned value of this -- function is either a Node_Id or a List_Id, it's related with -- the context of each IDL structure in the IDL tree. -- The source code generation is realized by calling the -- Backend.BE_CORBA_Ada.Generator.Generate (N); (N : the root -- IDL_Unit node as defined in -- Backend.BE_CORBA_Ada.IDL_To_Ada). This procedure uses -- Generate_XXX (stands for Generate the corresponding XXX node -- source). procedure Usage (Indent : Natural); -- Displays a help message that describes the command line options -- of IAC. ----------------------- -- General use flags -- ----------------------- Impl_Packages_Gen : Boolean := False; -- True when we generate implementation templates IR_Info_Packages_Gen : Boolean := False; -- True when we generate interface repository information packages Disable_Pkg_Body_Gen : Boolean := False; Disable_Pkg_Spec_Gen : Boolean := False; -- We can generate only spec or only bodies Generate_Imported : Boolean := False; -- Generate code for the imported IDL units Disable_Client_Code_Gen : Boolean := False; -- Control the client side code generation Disable_Server_Code_Gen : Boolean := False; -- Control the server side code generation --------------------- -- Debugging flags -- --------------------- Print_Ada_Tree : Boolean := False; -- Controls the dumping of the Ada tree Output_Unit_Withing : Boolean := False; -- Outputs the "Withed" units Output_Tree_Warnings : Boolean := False; -- Outputs the warnings encountered while building the Ada tree ----------------------------- -- Code optimization flags -- ----------------------------- -- Skeleton optimization using minimal perfect hash functions -- instead of the big "if .. elsif .. elsif ...". The cascading 'if' -- statements are no longer used. There is no command-line switch to revert -- to that behavior. However, we are keeping the code "just in case", and -- it can be invoked by setting Use_Minimal_Hash_Function to False. Use_Minimal_Hash_Function : constant Boolean := True; Optimization_Mode : GNAT.Perfect_Hash_Generators.Optimization := GNAT.Perfect_Hash_Generators.Memory_Space; Use_SII : Boolean := False; -- The request handling method (Static Implementation Interface or Dynamic -- Implementation Interface). Default is DII. Use_Optimized_Buffers_Allocation : Boolean := False; -- Marshaller optimization using a one time allocation by calculating the -- message body size of a GIOP request (used with SII handling). Use_Compiler_Alignment : Boolean := False; -- Marshalling optimization using Ada representation clauses to create -- the padding between parameters (used with SII handling). -- In some particular cases, some parts of the IDL tree must not be -- generated. The entities below achieve this goal. type Package_Type is (PK_CDR_Spec, PK_CDR_Body, PK_Buffers_Spec, PK_Buffers_Body, PK_Aligned_Spec, PK_Helper_Spec, PK_Helper_Body, PK_Helper_Internals_Spec, PK_Helper_Internals_Body, PK_Impl_Spec, PK_Impl_Body, PK_IR_Info_Spec, PK_IR_Info_Body, PK_Skel_Spec, PK_Skel_Body, PK_Stub_Spec, PK_Stub_Body); function Map_Particular_CORBA_Parts (E : Node_Id; PK : Package_Type) return Boolean; -- The mapping for some predefined CORBA IDL entities (the CORBA module) -- is slightly different from the mapping of standard IDL entities. This -- function maps these entities and return True if the E parameter falls -- into the special cases. end Backend.BE_CORBA_Ada; polyorb-2.8~20110207.orig/compilers/iac/scopes.adb0000644000175000017500000004433411750740337021115 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- S C O P E S -- -- -- -- B o d y -- -- -- -- Copyright (C) 2005-2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with GNAT.Table; with Errors; use Errors; with Locations; use Locations; with Namet; use Namet; with Frontend.Debug; use Frontend.Debug; with Frontend.Nodes; use Frontend.Nodes; with Frontend.Nutils; use Frontend.Nutils; package body Scopes is type Scope_Stack_Entry is record Node : Node_Id; end record; No_Scope_Depth : constant Int := -1; package Scope_Stack is new GNAT.Table (Scope_Stack_Entry, Int, No_Scope_Depth + 1, 10, 10); use Scope_Stack; procedure W_Homonym (N : Node_Id); procedure W_Homonyms (N : Node_Id); procedure W_Scoped_Identifiers (S : Node_Id); procedure Insert_Into_Homonyms (N : Node_Id); -- Insert into homonyms chain if not already there procedure Remove_From_Homonyms (N : Node_Id); -- Remove from homonyms chain when no longer needed procedure Remove_From_Scope (Homonym : Node_Id; Scope : Node_Id); -- Remove from Scope the first entity in Homonym chain ------------------- -- Current_Scope -- ------------------- function Current_Scope return Node_Id is begin if Last = No_Scope_Depth then return No_Node; else return Table (Last).Node; end if; end Current_Scope; ------------------------- -- Enter_Name_In_Scope -- ------------------------- procedure Enter_Name_In_Scope (N : Node_Id) is procedure Display_Conflict (N, C : Node_Id); -- Output that N conflicts with C function Is_Inherited (E : Node_Id) return Boolean; -- To introduce an inherited entity in the scope of an -- interface, we introduce an identifier corresponding to this -- entity. However, the identifier of this entity is different -- from this new identifier. In particular, the original -- identifier refers to the original scope in which the entity -- was defined. To decide whether an entity is inherited or -- not, we check that the scope of the original identifier is -- not null (otherwise, it is a newly-added entity) and that -- this scope is different from the current scope. ---------------------- -- Display_Conflict -- ---------------------- procedure Display_Conflict (N, C : Node_Id) is begin Error_Loc (1) := Loc (N); Error_Loc (2) := Loc (C); Error_Name (1) := IDL_Name (N); if Kind (C) = K_Scoped_Name then DE ("#conflicts with scoped name!"); else DE ("#conflicts with declaration!"); end if; end Display_Conflict; ------------------ -- Is_Inherited -- ------------------ function Is_Inherited (E : Node_Id) return Boolean is S : constant Node_Id := Scope_Entity (Identifier (E)); begin return Present (S) and then S /= Current_Scope; end Is_Inherited; E : constant Node_Id := Corresponding_Entity (N); S : constant Node_Id := Current_Scope; C : Node_Id := Node_In_Current_Scope (N); H : Node_Id; KC : Node_Kind; KE : constant Node_Kind := Kind (E); KS : constant Node_Kind := Kind (S); -- Start of processing for Enter_Name_In_Scope begin if Present (C) then KC := Kind (C); H := Identifier (C); -- This same entity is already in the scope if C = E then return; -- This name is already in the scope and the scoped name has -- not to be introduced. elsif KE = K_Scoped_Name then return; -- The current entity conflicts with the current scope elsif C = S then Display_Conflict (N, S); return; -- This entity is an extension of a module. Reload the -- previous scope. elsif KC = K_Module and then KE = K_Module then Set_Scoped_Identifiers (E, Scoped_Identifiers (C)); -- If the current entity is a scoped name, it has been -- introduced in purpose and cannot be removed. elsif KC = K_Scoped_Name then Display_Conflict (N, C); return; -- If the current entity is a forward entity then we can -- freely override it and enter the new entity. elsif Is_A_Forward_Of (C, E) then -- We do not handle forward structures or unions if KC = K_Forward_Interface_Declaration or else KC = K_Value_Forward_Declaration then Set_Forward (C, E); Remove_From_Scope (H, Scope_Entity (H)); end if; elsif KS = K_Interface_Declaration or else KS = K_Value_Declaration or else KS = K_Abstract_Value_Declaration then -- If the current entity is an attribute or an operation, -- then it cannot be overridden. if KC = K_Attribute_Declaration or else KC = K_Operation_Declaration then Display_Conflict (N, C); return; end if; -- If the current entity is already in this scope, we -- have a conflict and the entity cannot be overridden. if not Is_Inherited (C) then Display_Conflict (N, C); return; end if; -- If the new entity is not inherited, remove all the -- inherited occurrences since they are now overridden. if not Is_Inherited (E) then while Is_Inherited (C) loop Remove_From_Scope (H, S); C := Node_In_Current_Scope (N); exit when No (C); H := Identifier (C); end loop; pragma Assert (No (C)); end if; else Display_Conflict (N, C); return; end if; end if; Insert_Into_Homonyms (N); if No (Scope_Entity (N)) then Set_Scope_Entity (N, S); end if; Set_Potential_Scope (N, S); Set_Visible (N, True); Set_Next_Entity (N, Scoped_Identifiers (S)); Set_Scoped_Identifiers (S, N); end Enter_Name_In_Scope; ---------------- -- Initialize -- ---------------- procedure Initialize is begin Init; Increment_Last; IDL_Spec_Name := No_Name; end Initialize; -------------------------- -- Insert_Into_Homonyms -- -------------------------- procedure Insert_Into_Homonyms (N : Node_Id) is H : Node_Id; begin H := First_Homonym (N); if D_Scopes then W_Str ("insert "); W_Homonym (N); W_Str (" into homonyms ("); Write_Name (Name (N)); W_Str (") = ["); W_Homonyms (N); W_Str ("]"); W_Eol; end if; Set_Homonym (N, H); Set_First_Homonym (N, N); end Insert_Into_Homonyms; ------------------------------ -- Node_Explicitly_In_Scope -- ------------------------------ function Node_Explicitly_In_Scope (N : Node_Id; S : Node_Id) return Node_Id is C : Node_Id := Scoped_Identifiers (S); X : constant Name_Id := Name (N); begin -- Loop through scope S to find N. Entities potentially in the -- scope are present in S but they are not candidates here. As -- the scope can be different from the current scope, N is not -- always present in the homonyms chain. while Present (C) loop if Scope_Entity (C) = S and then Name (C) = X then return Corresponding_Entity (C); end if; C := Next_Entity (C); end loop; return No_Node; end Node_Explicitly_In_Scope; --------------------------- -- Node_In_Current_Scope -- --------------------------- function Node_In_Current_Scope (N : Node_Id) return Node_Id is S : constant Node_Id := Current_Scope; H : Node_Id := First_Homonym (N); X : Node_Id; begin while Present (H) loop X := Corresponding_Entity (H); -- In order to parse the file, we must accept, in an -- operation, that the parameter and its type have the same names -- when the type is an interface or a valuetype. if Kind (X) = K_Scoped_Name and then (Kind (Reference (X)) = K_Interface_Declaration or else Kind (Reference (X)) = K_Forward_Interface_Declaration or else Kind (Reference (X)) = K_Value_Declaration or else Kind (Reference (X)) = K_Value_Forward_Declaration or else Kind (Reference (X)) = K_Type_Declaration or else Kind (Reference (X)) = K_Structure_Type or else Kind (Reference (X)) = K_Union_Type or else Kind (Reference (X)) = K_Enumeration_Type) and then (Kind (S) = K_Operation_Declaration or else Kind (S) = K_Structure_Type or else Kind (S) = K_Union_Type) then null; elsif Potential_Scope (H) = S then return X; elsif X = S then -- The name of an interface, value type, struct, union, -- exception or a module may not be redefined within the -- immediate scope of the interface, value type, struct, -- union, exception, or the module. case Kind (S) is when K_Interface_Declaration | K_Forward_Interface_Declaration | K_Value_Declaration | K_Value_Forward_Declaration | K_Structure_Type | K_Forward_Structure_Type | K_Union_Type | K_Forward_Union_Type | K_Exception_Declaration | K_Module => return X; when others => null; end case; end if; H := Homonym (H); end loop; return No_Node; end Node_In_Current_Scope; --------------- -- Pop_Scope -- --------------- procedure Pop_Scope is S : constant Node_Id := Current_Scope; C : Node_Id; E : Node_Id; N : Node_Id; begin if D_Scopes then W_Str ("pop scope """); if Kind (S) /= K_Specification then Write_Name (Name (Identifier (S))); end if; W_Str (""""); W_Eol; end if; -- Pop scope Decrement_Last; if Last = First then return; end if; -- When the previous scope was a type name that is nested in a -- non-module scope definition, the potential scope extends to -- the enclosing non-module scope. We introduced the scoped -- names in the enclosing scope. declare Export : constant Boolean := Is_Noninterface_Type (S) and then Is_A_Non_Module (Current_Scope); begin C := Scoped_Identifiers (S); while Present (C) loop Set_Visible (C, False); Remove_From_Homonyms (C); if Export then E := Corresponding_Entity (C); if Kind (E) = K_Scoped_Name then N := Identifier (E); N := Make_Identifier (Loc (N), Name (N), Corresponding_Entity (N), Scope_Entity (N)); Set_Potential_Scope (N, S); Enter_Name_In_Scope (N); end if; end if; C := Next_Entity (C); end loop; end; if D_Scopes then W_Str ("show scope """); if Kind (Current_Scope) /= K_Specification then Write_Name (Name (Identifier (Current_Scope))); end if; W_Str (""" "); W_Scoped_Identifiers (Current_Scope); W_Eol; end if; end Pop_Scope; ---------------- -- Push_Scope -- ---------------- procedure Push_Scope (S : Node_Id) is I : Node_Id; begin Increment_Last; Table (Last).Node := S; if D_Scopes then W_Str ("push scope """); if Kind (S) /= K_Specification then Write_Name (Name (Identifier (S))); end if; W_Str (""""); if Present (Identifier (S)) then W_Str (" ["); W_Homonyms (Identifier (S)); W_Str ("]"); end if; W_Eol; end if; I := Scoped_Identifiers (S); while Present (I) loop Insert_Into_Homonyms (I); Set_Visible (I, True); Set_Scope_Entity (I, S); I := Next_Entity (I); end loop; end Push_Scope; -------------------------- -- Remove_From_Homonyms -- -------------------------- procedure Remove_From_Homonyms (N : Node_Id) is H : Node_Id; begin H := First_Homonym (N); if H = N then Set_First_Homonym (N, Homonym (H)); else while Present (H) loop if Homonym (H) = N then Set_Homonym (H, Homonym (N)); exit; end if; H := Homonym (H); end loop; end if; if D_Scopes then W_Str ("remove "); W_Homonym (N); W_Str (" from homonyms ("); Write_Name (Name (N)); W_Str (") = ["); W_Homonyms (N); W_Str ("]"); W_Eol; end if; end Remove_From_Homonyms; ----------------------- -- Remove_From_Scope -- ----------------------- procedure Remove_From_Scope (Homonym : Node_Id; Scope : Node_Id) is Identifier : Node_Id := Scoped_Identifiers (Scope); Parent : Node_Id := Identifier; Entity : constant Node_Id := Corresponding_Entity (Homonym); begin if Entity = Corresponding_Entity (Identifier) then Set_Scoped_Identifiers (Scope, Next_Entity (Identifier)); else loop Identifier := Next_Entity (Parent); exit when Entity = Corresponding_Entity (Identifier); Parent := Identifier; end loop; Set_Next_Entity (Parent, Next_Entity (Identifier)); end if; if D_Scopes then W_Str ("remove "); W_Homonym (Identifier); W_Str (" from scope"); end if; Set_Next_Entity (Identifier, No_Node); Set_Visible (Identifier, False); Remove_From_Homonyms (Identifier); end Remove_From_Scope; ------------------ -- Visible_Node -- ------------------ function Visible_Node (N : Node_Id) return Node_Id is H : constant Node_Id := First_Homonym (N); E : Node_Id; begin if Present (H) then E := Corresponding_Entity (H); -- The current visible entity has already been entered in the scope if Kind (E) = K_Scoped_Name then return Reference (E); end if; if Visible (H) then return Corresponding_Entity (H); end if; end if; Error_Loc (1) := Loc (N); Error_Name (1) := IDL_Name (N); DE ("#is undefined"); return No_Node; end Visible_Node; --------------- -- W_Homonym -- --------------- procedure W_Homonym (N : Node_Id) is begin W_Str (Image (Loc (N))); W_Str ("("); if Kind (Corresponding_Entity (N)) = K_Scoped_Name then W_Str ("S"); elsif Visible (N) then W_Str ("V"); else W_Str ("?"); end if; W_Str (")"); end W_Homonym; ---------------- -- W_Homonyms -- ---------------- procedure W_Homonyms (N : Node_Id) is H : Node_Id := First_Homonym (N); begin if No (H) then return; end if; loop W_Homonym (H); H := Homonym (H); exit when No (H); W_Str (" "); end loop; end W_Homonyms; -------------------------- -- W_Scoped_Identifiers -- -------------------------- procedure W_Scoped_Identifiers (S : Node_Id) is C : Node_Id := Scoped_Identifiers (S); begin if No (C) then return; end if; loop Write_Name (Name (C)); W_Str (" ["); W_Homonyms (C); W_Str ("]"); C := Next_Entity (C); exit when No (C); W_Str (" "); end loop; end W_Scoped_Identifiers; end Scopes; polyorb-2.8~20110207.orig/compilers/iac/iac.adb0000644000175000017500000003762011750740337020355 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- I A C -- -- -- -- B o d y -- -- -- -- Copyright (C) 2005-2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with Ada.Exceptions; with Ada.Command_Line; use Ada.Command_Line; with GNAT.Command_Line; use GNAT.Command_Line; with GNAT.Directory_Operations; use GNAT; with GNAT.OS_Lib; use GNAT.OS_Lib; with GNAT.Perfect_Hash_Generators; use GNAT.Perfect_Hash_Generators; with Analyzer; use Analyzer; with Backend; use Backend; with Errors; use Errors; with Flags; use Flags; with Lexer; use Lexer; with Namet; use Namet; with Output; use Output; with Parser; use Parser; with Scopes; with Types; use Types; with Usage; with Utils; use Utils; with Frontend.Debug; with Backend.Config; with Backend.BE_CORBA_Ada; with Backend.BE_CORBA_Ada.Nutils; with Backend.BE_IDL; with Backend.BE_Types; procedure IAC is procedure Command_Line_Error (Template : Message_Template); procedure Command_Line_Error (Template : Message_Template; S : String); -- Print out the error message and exit the program with non-zero status procedure Scan_Switches; -- Scan command line switches and update Flags accordingly. If the help -- option (-h) is given, this does not return, but calls OS_Exit. ------------------------ -- Command_Line_Error -- ------------------------ procedure Command_Line_Error (Template : Message_Template) is begin DE (Template); DE ("\type ""iac -h"" for help"); OS_Exit (1); end Command_Line_Error; ------------------------ -- Command_Line_Error -- ------------------------ procedure Command_Line_Error (Template : Message_Template; S : String) is begin DE (Template, S); DE ("\type ""iac -h"" for help"); OS_Exit (1); end Command_Line_Error; ------------------- -- Scan_Switches -- ------------------- procedure Scan_Switches is package BEA renames Backend.BE_CORBA_Ada; package BEI renames Backend.BE_IDL; package BET renames Backend.BE_Types; Found_Language : Boolean := False; begin -- Add the current directory to the search path, it will be added -- automatically to the preprocessor search path Add_IAC_Search_Path ("."); -- The command line parsing in IAC is a bit complicated. The -- structure of the command line is as follows : -- %iac [general_switches] [-] [backend_switches] file -- [-cppargs preprocessor_flags] -- Check whether the user specified the Backend to use ... Initialize_Option_Scan; for I in 1 .. Argument_Count loop Set_Str_To_Name_Buffer (Argument (I)); if Name_Buffer (1) = '-' and then Name_Len > 1 and then Backend.Is_Valid_Language (Name_Buffer (2 .. Name_Len)) then if Found_Language then raise Invalid_Switch; end if; Backend.Set_Current_Language (Name_Buffer (2 .. Name_Len)); Found_Language := True; end if; end loop; Initialize_Option_Scan ('-', False, "cppargs"); loop case Getopt ("b: c d da db df di dm ds dt dw " & "E e h hc hm I: i k o: p q r! s " & "ada gnatW8 idl ir noir nocpp types") is when ASCII.NUL => exit; when 'b' => begin BEI.Default_Base := Natural'Value (Parameter); exception when Constraint_Error => raise Invalid_Parameter; end; when 'c' => BEA.Disable_Server_Code_Gen := True; when 'd' => if Full_Switch = "d" then -- XXX should support the generation of delegate package null; elsif Full_Switch = "da" then BEA.Print_Ada_Tree := True; elsif Full_Switch = "db" then BEA.Disable_Pkg_Spec_Gen := True; elsif Full_Switch = "df" then Print_Full_Tree := True; BEI.Print_IDL_Tree := True; elsif Full_Switch = "di" then BEA.Generate_Imported := True; BEI.Generate_Imported := True; elsif Full_Switch = "dm" then Scopes.D_Scopes := True; elsif Full_Switch = "ds" then BEA.Disable_Pkg_Body_Gen := True; elsif Full_Switch = "dt" then BEA.Output_Tree_Warnings := True; elsif Full_Switch = "dw" then BEA.Output_Unit_Withing := True; else raise Invalid_Switch; end if; when 'E' => Preprocess_Only := True; when 'e' => BEI.Expand_Tree := True; when 'g' => if Full_Switch = "gnatW8" then BEA.Nutils.Set_UTF_8_Encoding; else raise Program_Error; end if; when 'I' => -- We add the parameter WITHOUT the ending -- directory separator if Is_Dir_Separator (Parameter (Parameter'Last)) then Add_IAC_Search_Path (Parameter (Parameter'First .. Parameter'Last - 1)); else Add_IAC_Search_Path (Parameter); end if; when 'h' => -- Help switch (-h) prints usage message and exits the program -- without doing anything else. if Full_Switch = "h" then Usage; OS_Exit (0); elsif Full_Switch = "hc" then BEA.Optimization_Mode := CPU_Time; elsif Full_Switch = "hm" then BEA.Optimization_Mode := Memory_Space; else -- Can't get here, because we already processed the '-h' -- switch. raise Program_Error; end if; when 'i' => if Full_Switch = "i" then BEA.Impl_Packages_Gen := True; elsif Full_Switch = "ir" then BEA.IR_Info_Packages_Gen := True; end if; when 'k' => Keep_TMP_Files := True; when 'n' => if Full_Switch = "noir" then BEA.IR_Info_Packages_Gen := False; elsif Full_Switch = "nocpp" then No_Preprocess := True; end if; when 'o' => if GNAT.OS_Lib.Is_Directory (Parameter) then if Is_Dir_Separator (Parameter (Parameter'Last)) then Output_Directory := new String'(Parameter); else Output_Directory := new String' (Parameter & Directory_Operations.Dir_Separator); end if; else Command_Line_Error ("%: directory not found", Parameter); end if; when 'p' => if Backend.Current_Language = "types" then BET.Print_Types := True; end if; Use_Stdout := True; when 'q' => Quiet := True; when 'r' => -- ??? Needs documentation declare S : constant String := Parameter; begin case S (S'First) is when 's' => BEA.Use_SII := True; when 'd' => BEA.Use_SII := False; when 'o' => -- Buffers allocation optimization can be -- used only with SII/SSI invocation BEA.Use_SII := True; BEA.Use_Optimized_Buffers_Allocation := True; when 'a' => -- Marshalling optimization can be -- used only with SII/SSI invocation BEA.Use_Compiler_Alignment := True; BEA.Use_SII := True; BEA.Use_Optimized_Buffers_Allocation := True; when others => raise Invalid_Switch; end case; end; when 's' => BEA.Disable_Client_Code_Gen := True; when others => if Full_Switch /= "ada" and then Full_Switch /= "idl" and then Full_Switch /= "types" then raise Invalid_Switch; end if; end case; end loop; -- When the user gives both "-s" and "-c", we generate the code -- for both client side and server side if BEA.Disable_Client_Code_Gen and then BEA.Disable_Server_Code_Gen then BEA.Disable_Client_Code_Gen := False; BEA.Disable_Server_Code_Gen := False; end if; -- When the user gives both "-db" and "-ds" we generate the -- code for both specs and bodies if BEA.Disable_Pkg_Body_Gen and then BEA.Disable_Pkg_Spec_Gen then BEA.Disable_Pkg_Body_Gen := False; BEA.Disable_Pkg_Spec_Gen := False; end if; Set_Str_To_Name_Buffer (Get_Argument); if Name_Len /= 0 then Main_Source := Name_Find; if Get_Argument /= "" then Command_Line_Error ("only one file name allowed"); end if; end if; -- These exceptions can come from Getopt, or be raised explicitly above exception when Invalid_Switch => Command_Line_Error ("invalid switch: %", Full_Switch); when Invalid_Parameter => Command_Line_Error ("invalid or missing parameter for switch: %", Full_Switch); end Scan_Switches; Preprocessed_File : File_Descriptor; -- Start of processing for IAC begin -- Initialization step Namet.Initialize; Backend.Config.Initialize; Scan_Switches; Scopes.Initialize; if Main_Source = No_Name then Command_Line_Error ("missing .idl input file"); end if; Get_Name_String (Main_Source); if not Is_Regular_File (Name_Buffer (1 .. Name_Len)) then Add_Str_To_Name_Buffer (".idl"); if Is_Regular_File (Name_Buffer (1 .. Name_Len)) then Main_Source := Name_Find; else Error_Name (1) := Main_Source; Command_Line_Error ("%not found"); end if; end if; declare First, Last : Natural; begin Get_Name_String (Main_Source); -- Remove any prefix First := 1; for J in reverse 1 .. Name_Len loop if Name_Buffer (J) = '/' or else Name_Buffer (J) = '\' then First := J + 1; exit; end if; end loop; -- Remove any suffix. -- -- Implementation note: we do not want any '.' character left -- in the specification unit name since this would require to -- define the parent unit as well. Last := Name_Len; for J in First .. Name_Len loop if Name_Buffer (J) = '.' then Last := J - 1; exit; end if; end loop; Set_Str_To_Name_Buffer (Name_Buffer (First .. Last)); Scopes.IDL_Spec_Name := Name_Find; end; -- The "cppargs" section is processed in Lexer.Preprocess -- Preprocessor step Lexer.Preprocess (Main_Source, Preprocessed_File); if Preprocess_Only then Lexer.Output (Preprocessed_File); return; end if; -- Lexer step Lexer.Process (Preprocessed_File, Main_Source); -- Parser step Parser.Process (Scopes.IDL_Spec); -- Analyzer step Analyze (Scopes.IDL_Spec); -- Cleanup temporary files if not Keep_TMP_Files then Lexer.Make_Cleanup; end if; if Print_Full_Tree then Frontend.Debug.W_Full_Tree; end if; if N_Errors > 0 then Error_Int (1) := N_Errors; if N_Warnings > 0 then Error_Int (2) := N_Warnings; DE ("$ error(s) and $ warning(s)"); else DE ("$ error(s)"); end if; OS_Exit (2); elsif N_Warnings > 0 then Error_Int (1) := N_Warnings; DE ("$ warning(s)"); end if; Generate (Scopes.IDL_Spec); exception -- We don't print a bug box on Fatal_Error, because an error message has -- already been issued. We just set the exit status to non-zero. when Fatal_Error => OS_Exit (2); -- Other exceptions are considered bugs. Print a "bug box", and exit with -- non-zero exit status. when E : others => declare Exception_String : constant String := "| Detected exception: " & Ada.Exceptions.Exception_Name (E); Error_String : constant String := "| Error: " & Ada.Exceptions.Exception_Message (E); begin -- To avoid generating the bug box inside a file Set_Standard_Error; Write_Line ("+============================ IAC BUG DETECTED" & " ===========================+"); Write_Str (Exception_String); for J in Exception_String'Length .. 72 loop Write_Str (" "); end loop; Write_Str (" |"); Write_Eol; Write_Str (Error_String); for J in Error_String'Length .. 72 loop Write_Str (" "); end loop; Write_Str (" |"); Write_Eol; Write_Str ("| Please include the files listed below when submitting" & " your report. |"); Write_Eol; Write_Str ("| Please refer to the User's Guide for more details." & " |"); Write_Eol; Write_Line ("+=============================================" & "============================+"); Write_Eol; Write_Name (Main_Source); Write_Eol; OS_Exit (3); end; end IAC; polyorb-2.8~20110207.orig/compilers/iac/values.ads0000644000175000017500000001362111750740337021134 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- V A L U E S -- -- -- -- S p e c -- -- -- -- Copyright (C) 2005-2009, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with Types; use Types; with Frontend.Nodes; use Frontend.Nodes; package Values is type Value_Type (K : Node_Kind := K_Float) is record case K is when K_Short .. K_Unsigned_Long_Long | K_Octet | K_Boolean | K_Fixed_Point_Type => IVal : Unsigned_Long_Long; Sign : Short_Short; case K is when K_Fixed_Point_Type => Total : Unsigned_Short_Short; Scale : Unsigned_Short_Short; when others => Base : Unsigned_Short_Short; end case; when K_Float .. K_Long_Double => FVal : Long_Double; when K_Char .. K_Wide_Char => CVal : Unsigned_Short; when K_String .. K_Wide_String | K_Enumerator => SVal : Name_Id; case K is when K_Enumerator => Pos : Unsigned_Long_Long; when others => null; end case; when K_Void => null; when others => null; end case; end record; Bad_Value : constant Value_Type; No_Value : constant Value_Id; function New_Boolean_Value (Value : Boolean) return Value_Id; function New_Character_Value (Value : Unsigned_Short; Wide : Boolean) return Value_Id; function New_Enumerator (Img : Name_Id; Pos : Unsigned_Long_Long) return Value_Id; function New_Fixed_Point_Value (Value : Unsigned_Long_Long; Sign : Short_Short; Total : Unsigned_Short_Short; Scale : Unsigned_Short_Short) return Value_Id; function New_Floating_Point_Value (Value : Long_Double) return Value_Id; function New_Integer_Value (Value : Unsigned_Long_Long; Sign : Short_Short; Base : Unsigned_Short_Short) return Value_Id; function New_String_Value (Value : Name_Id; Wide : Boolean) return Value_Id; function New_Value (Value : Value_Type) return Value_Id; function Convert (V : Value_Type; K : Node_Kind) return Value_Type; Max_Digits : constant := 31; procedure Normalize_Fixed_Point_Value (Value : in out Value_Id; Total : Unsigned_Short_Short := Max_Digits; Scale : Unsigned_Short_Short := Max_Digits); procedure Normalize_Fixed_Point_Value (Value : in out Value_Type; Total : Unsigned_Short_Short := Max_Digits; Scale : Unsigned_Short_Short := Max_Digits); function Value (V : Value_Id) return Value_Type; procedure Set_Value (V : Value_Id; X : Value_Type); function Image (Value : Value_Id) return String; function Image_Ada (Value : Value_Id) return String; function "not" (R : Value_Type) return Value_Type; function "-" (R : Value_Type) return Value_Type; function "-" (L, R : Value_Type) return Value_Type; function "+" (L, R : Value_Type) return Value_Type; function "mod" (L, R : Value_Type) return Value_Type; function "/" (L, R : Value_Type) return Value_Type; function "*" (L, R : Value_Type) return Value_Type; function "and" (L, R : Value_Type) return Value_Type; function "or" (L, R : Value_Type) return Value_Type; function "xor" (L, R : Value_Type) return Value_Type; function Shift_Left (L, R : Value_Type) return Value_Type; function Shift_Right (L, R : Value_Type) return Value_Type; function "<" (L, R : Value_Type) return Boolean; -- Assume L and R have the same type. function Negative (V : Value_Type) return Boolean; function Negative (V : Value_Id) return Boolean; -- Return True when R is a strictly negative number. Raise an exception if -- if R is not a number. private Bad_Value : constant Value_Type := Value_Type'((K => K_Void)); No_Value : constant Value_Id := 0; end Values; polyorb-2.8~20110207.orig/compilers/iac/analyzer.adb0000644000175000017500000020764411750740337021453 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- A N A L Y Z E R -- -- -- -- B o d y -- -- -- -- Copyright (C) 2005-2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with GNAT.Table; with GNAT.Bubble_Sort; with Errors; use Errors; with Lexer; use Lexer; with Locations; use Locations; with Scopes; use Scopes; with Utils; use Utils; with Values; use Values; with Namet; use Namet; with Parser; with Frontend.Debug; use Frontend.Debug; with Frontend.Nodes; use Frontend.Nodes; with Frontend.Nutils; use Frontend.Nutils; package body Analyzer is procedure Analyze_Attribute_Declaration (E : Node_Id); procedure Analyze_Complex_Declarator (E : Node_Id); procedure Analyze_Constant_Declaration (E : Node_Id); procedure Analyze_Element (E : Node_Id); procedure Analyze_Enumeration_Type (E : Node_Id); procedure Analyze_Exception_Declaration (E : Node_Id); procedure Analyze_Expression (E : Node_Id); procedure Analyze_Fixed_Point_Type (E : Node_Id); procedure Analyze_Forward_Interface_Declaration (E : Node_Id); procedure Analyze_Forward_Structure_Type (E : Node_Id); procedure Analyze_Forward_Union_Type (E : Node_Id); procedure Analyze_Initializer_Declaration (E : Node_Id); procedure Analyze_Interface_Declaration (E : Node_Id); procedure Analyze_Literal (E : Node_Id); procedure Analyze_Member (E : Node_Id); procedure Analyze_Module (E : Node_Id); procedure Analyze_Operation_Declaration (E : Node_Id); procedure Analyze_Native_Type (E : Node_Id); procedure Analyze_Parameter_Declaration (E : Node_Id); procedure Analyze_Pragma (E : Node_Id); procedure Analyze_Scoped_Name (E : Node_Id); procedure Analyze_Simple_Declarator (E : Node_Id); procedure Analyze_Sequence_Type (E : Node_Id); procedure Analyze_State_Member (E : Node_Id); procedure Analyze_String (E : Node_Id); procedure Analyze_Structure_Type (E : Node_Id); procedure Analyze_Type_Declaration (E : Node_Id); procedure Analyze_Type_Id_Declaration (E : Node_Id); procedure Analyze_Type_Prefix_Declaration (E : Node_Id); procedure Analyze_Union_Type (E : Node_Id); procedure Analyze_Value_Declaration (E : Node_Id); procedure Analyze_Value_Box_Declaration (E : Node_Id); procedure Analyze_Value_Forward_Declaration (E : Node_Id); procedure Analyze_And_Resolve_Expr (E : Node_Id; T : Node_Id); -- Analyze the expression, and then resolve it procedure Analyze_And_Resolve_Constant_Declaration_Or_Case_Label_Expr (E : Node_Id; T : Node_Id); -- E must be a Constant_Declaration or a Case_Label_Expr. Analyze and -- resolve the expression of E, and then convert it to type T. Set the -- Value field of E to the converted value. procedure Analyze_Type_Spec (E : Node_Id); -- Analyze E, and give an error if it's not a type spec -- These procedures factorize the analyzing type prefix and type ID code procedure Assign_Type_Id (Scope : Node_Id; Prefix : Node_Id; Unique : Boolean := False); -- To enable redefinition procedure Assign_Type_Prefix (Scope : Node_Id; Prefix : Node_Id); procedure Assign_Type_Version (Scope : Node_Id; Prefix : Node_Id); function Convert (E : Node_Id; T : Node_Id; K : Node_Kind) return Value_Type; -- Convert the value from E into type T in the context K. The conversion -- depends on the context since for instance, an integer value is not -- converted the same way whether it is performed in a constant -- declaration or in an expression. function In_Range (I : Unsigned_Long_Long; S : Short_Short; F : Long_Long; L : Unsigned_Long_Long) return Boolean; -- Check whether S * I (Sign * Val) is in range F .. L procedure Inherit_From (Parent : Node_Id); -- Add into the scope of the child interface all the entities from -- the scope of the parent interfaces. For each entity of a parent -- interface create a new identifier referencing the entity while -- the entity is still bound to its initial identifier. procedure Resolve_Expr (E : Node_Id; T : Node_Id); function Resolve_Type (N : Node_Id) return Node_Id; procedure Display_Incorrect_Value (L : Location; K1 : Node_Kind; K2 : Node_Kind := K_Void); package LT is new GNAT.Table (Node_Id, Natural, 1, 10, 10); -- Label table procedure Exchange (Op1, Op2 : Natural); function Less_Than (Op1, Op2 : Natural) return Boolean; -- Sort the nodes by applying the following rules. A node with a -- wrong value is always the least value. A node representing -- "default" is always the greatest value. Otherwise, compare as -- usual. ------------- -- Analyze -- ------------- procedure Analyze (E : Node_Id) is begin if No (E) then return; end if; if Kind (E) in K_Float .. K_Value_Base then return; end if; case Kind (E) is when K_Abstract_Value_Declaration | K_Value_Declaration => Analyze_Value_Declaration (E); when K_Attribute_Declaration => Analyze_Attribute_Declaration (E); when K_Complex_Declarator => Analyze_Complex_Declarator (E); when K_Constant_Declaration => Analyze_Constant_Declaration (E); when K_Element => Analyze_Element (E); when K_Enumeration_Type => Analyze_Enumeration_Type (E); when K_Exception_Declaration => Analyze_Exception_Declaration (E); when K_Expression => Analyze_Expression (E); when K_Fixed_Point_Type => Analyze_Fixed_Point_Type (E); when K_Forward_Interface_Declaration => Analyze_Forward_Interface_Declaration (E); when K_Forward_Structure_Type => Analyze_Forward_Structure_Type (E); when K_Forward_Union_Type => Analyze_Forward_Union_Type (E); when K_Initializer_Declaration => Analyze_Initializer_Declaration (E); when K_Interface_Declaration => Analyze_Interface_Declaration (E); when K_Literal => Analyze_Literal (E); when K_Member => Analyze_Member (E); when K_Module => Analyze_Module (E); when K_Operation_Declaration => Analyze_Operation_Declaration (E); when K_Native_Type => Analyze_Native_Type (E); when K_Parameter_Declaration => Analyze_Parameter_Declaration (E); when K_Pragma => Analyze_Pragma (E); when K_Scoped_Name => Analyze_Scoped_Name (E); when K_Sequence_Type => Analyze_Sequence_Type (E); when K_Simple_Declarator => Analyze_Simple_Declarator (E); when K_Specification => Analyze_Module (E); when K_State_Member => Analyze_State_Member (E); when K_String_Type | K_Wide_String_Type => Analyze_String (E); when K_Structure_Type => Analyze_Structure_Type (E); when K_Type_Declaration => Analyze_Type_Declaration (E); when K_Type_Id_Declaration => Analyze_Type_Id_Declaration (E); when K_Type_Prefix_Declaration => Analyze_Type_Prefix_Declaration (E); when K_Union_Type => Analyze_Union_Type (E); when K_Value_Box_Declaration => Analyze_Value_Box_Declaration (E); when K_Value_Forward_Declaration => Analyze_Value_Forward_Declaration (E); when K_Float .. K_Value_Base => null; when others => Dummy (E); end case; end Analyze; ----------------------------------------------------------------- -- Analyze_And_Resolve_Constant_Declaration_Or_Case_Label_Expr -- ----------------------------------------------------------------- procedure Analyze_And_Resolve_Constant_Declaration_Or_Case_Label_Expr (E : Node_Id; T : Node_Id) is RE : constant Node_Id := Expression (E); KE : constant Node_Kind := Kind (E); pragma Assert (KE = K_Constant_Declaration or else KE = K_Case_Label); begin -- For constant declarations and case labels, first resolve the -- expression attached to it. Second convert the value into the exact -- type and if the evaluation has been successful, set the value of the -- constant or label to it. Set_Value (E, No_Value); if Present (RE) then Analyze_And_Resolve_Expr (RE, T); declare RV : constant Value_Type := Convert (RE, T, KE); begin if RV /= Bad_Value then Set_Value (E, New_Value (RV)); end if; end; end if; end Analyze_And_Resolve_Constant_Declaration_Or_Case_Label_Expr; ------------------------------ -- Analyze_And_Resolve_Expr -- ------------------------------ procedure Analyze_And_Resolve_Expr (E : Node_Id; T : Node_Id) is begin Analyze (E); Resolve_Expr (E, T); end Analyze_And_Resolve_Expr; ----------------------------------- -- Analyze_Attribute_Declaration -- ----------------------------------- procedure Analyze_Attribute_Declaration (E : Node_Id) is procedure No_Interface_Attribute_Of_Local_Type (T : Node_Id; I : Node_Id); ------------------------------------------ -- No_Interface_Attribute_Of_Local_Type -- ------------------------------------------ procedure No_Interface_Attribute_Of_Local_Type (T : Node_Id; I : Node_Id) is PT : Node_Id := T; TK : Node_Kind; begin if Present (PT) and then Kind (PT) = K_Scoped_Name then PT := Reference (PT); end if; if No (PT) then return; end if; TK := Kind (PT); if (TK = K_Forward_Interface_Declaration or else TK = K_Forward_Interface_Declaration) and then Is_A_Local_Type (PT) then Error_Loc (1) := Loc (T); Error_Name (1) := IDL_Name (Identifier (T)); Error_Name (2) := IDL_Name (Identifier (I)); DE ("local interface#cannot appear as attribute " & "in unconstrained interface#"); end if; end No_Interface_Attribute_Of_Local_Type; Declarator : Node_Id := First_Entity (Declarators (E)); Decl_Type : constant Node_Id := Type_Spec (E); Iface : constant Node_Id := Current_Scope; Attr_Exception : Node_Id; begin Analyze_Type_Spec (Decl_Type); if not Is_A_Local_Type (Iface) then No_Interface_Attribute_Of_Local_Type (Decl_Type, Iface); end if; while Present (Declarator) loop Analyze (Declarator); Declarator := Next_Entity (Declarator); end loop; -- Analyze exceptions if not Is_Empty (Getter_Exceptions (E)) then Attr_Exception := First_Entity (Getter_Exceptions (E)); while Present (Attr_Exception) loop Analyze (Attr_Exception); Attr_Exception := Next_Entity (Attr_Exception); end loop; end if; if not Is_Empty (Setter_Exceptions (E)) then Attr_Exception := First_Entity (Setter_Exceptions (E)); while Present (Attr_Exception) loop Analyze (Attr_Exception); Attr_Exception := Next_Entity (Attr_Exception); end loop; end if; end Analyze_Attribute_Declaration; -------------------------------- -- Analyze_Complex_Declarator -- -------------------------------- procedure Analyze_Complex_Declarator (E : Node_Id) is C : Node_Id; Unsigned_Long_Long_Node : constant Node_Id := Parser.Resolve_Base_Type ((T_Unsigned, T_Long, T_Long), Loc (E)); begin Enter_Name_In_Scope (Identifier (E)); -- The array sizes attribute is never empty C := First_Entity (Array_Sizes (E)); while Present (C) loop Analyze_And_Resolve_Expr (C, Unsigned_Long_Long_Node); C := Next_Entity (C); end loop; end Analyze_Complex_Declarator; ---------------------------------- -- Analyze_Constant_Declaration -- ---------------------------------- procedure Analyze_Constant_Declaration (E : Node_Id) is T : Node_Id; K : Node_Kind; begin T := Type_Spec (E); if No (T) then return; end if; Analyze_Type_Spec (T); -- Resolve base type of T. Types of constant declarations are -- limited to integer types, character types, string types, -- floating point types, fixed point types. T := Resolve_Type (T); if No (T) then return; end if; K := Kind (T); case K is when K_Fixed_Point_Type | K_String_Type | K_Wide_String_Type | K_Enumeration_Type | K_Float .. K_Octet => null; when others => Error_Loc (1) := Loc (Type_Spec (E)); DE ("invalid type for constant"); return; end case; -- Analyze expression, evaluate it and then convert result Enter_Name_In_Scope (Identifier (E)); Analyze_And_Resolve_Constant_Declaration_Or_Case_Label_Expr (E, T); end Analyze_Constant_Declaration; --------------------- -- Analyze_Element -- --------------------- procedure Analyze_Element (E : Node_Id) is begin Analyze_Type_Spec (Type_Spec (E)); Analyze (Declarator (E)); end Analyze_Element; ------------------------------ -- Analyze_Enumeration_Type -- ------------------------------ procedure Analyze_Enumeration_Type (E : Node_Id) is C : Node_Id; N : Node_Id; I : Node_Id; begin Enter_Name_In_Scope (Identifier (E)); C := First_Entity (Enumerators (E)); while Present (C) loop -- Define scoped name referencing enumeration type I := Make_Identifier (Loc (E), IDL_Name (Identifier (E)), No_Node, No_Node); N := Make_Scoped_Name (Loc (E), I, No_Node, E); Bind_Identifier_To_Entity (I, N); -- Define constant aliasing enumerator I := Make_Identifier (Loc (C), IDL_Name (Identifier (C)), No_Node, No_Node); N := Make_Constant_Declaration (Loc (E), N, I, C); Bind_Identifier_To_Entity (I, N); Analyze (N); C := Next_Entity (C); end loop; end Analyze_Enumeration_Type; ----------------------------------- -- Analyze_Exception_Declaration -- ----------------------------------- procedure Analyze_Exception_Declaration (E : Node_Id) is C : Node_Id; L : List_Id; begin Enter_Name_In_Scope (Identifier (E)); L := Members (E); if not Is_Empty (L) then Push_Scope (E); C := First_Entity (L); while Present (C) loop Analyze (C); C := Next_Entity (C); end loop; Pop_Scope; end if; end Analyze_Exception_Declaration; ------------------------ -- Analyze_Expression -- ------------------------ procedure Analyze_Expression (E : Node_Id) is begin Analyze (Left_Expr (E)); Analyze (Right_Expr (E)); end Analyze_Expression; ------------------------------ -- Analyze_Fixed_Point_Type -- ------------------------------ procedure Analyze_Fixed_Point_Type (E : Node_Id) is begin Dummy (E); end Analyze_Fixed_Point_Type; ------------------------------------------- -- Analyze_Forward_Interface_Declaration -- ------------------------------------------- procedure Analyze_Forward_Interface_Declaration (E : Node_Id) is begin Enter_Name_In_Scope (Identifier (E)); end Analyze_Forward_Interface_Declaration; ------------------------------------ -- Analyze_Forward_Structure_Type -- ------------------------------------ procedure Analyze_Forward_Structure_Type (E : Node_Id) is begin Enter_Name_In_Scope (Identifier (E)); end Analyze_Forward_Structure_Type; -------------------------------- -- Analyze_Forward_Union_Type -- -------------------------------- procedure Analyze_Forward_Union_Type (E : Node_Id) is begin Enter_Name_In_Scope (Identifier (E)); end Analyze_Forward_Union_Type; ------------------------------------- -- Analyze_Initializer_Declaration -- ------------------------------------- procedure Analyze_Initializer_Declaration (E : Node_Id) is begin Analyze_Operation_Declaration (E); end Analyze_Initializer_Declaration; ----------------------------------- -- Analyze_Interface_Declaration -- ----------------------------------- procedure Analyze_Interface_Declaration (E : Node_Id) is Parent : Node_Id; Definition : Node_Id; Scoped_Name : Node_Id; Is_Local : constant Boolean := Is_A_Local_Type (E); Is_Abstract : constant Boolean := Is_Abstract_Interface (E); begin Enter_Name_In_Scope (Identifier (E)); -- Analyze interface names in the current scope (before pushing -- a new scope and inheriting from other interfaces). Scoped_Name := First_Entity (Interface_Spec (E)); while Present (Scoped_Name) loop Analyze (Scoped_Name); Parent := Reference (Scoped_Name); if Present (Parent) then if Kind (Parent) /= K_Interface_Declaration then if Kind (Parent) = K_Forward_Interface_Declaration then Error_Loc (1) := Loc (E); DE ("interface cannot inherit " & "from a forward-declared interface"); else Error_Loc (1) := Loc (E); DE ("interface cannot inherit " & "from a non-interface"); end if; -- Do not consider this interface later on. Set_Reference (Scoped_Name, No_Node); elsif not Is_Local then if Is_A_Local_Type (Parent) then Error_Loc (1) := Loc (E); DE ("interface cannot inherit " & "from a local interface"); Set_Reference (Scoped_Name, No_Node); end if; elsif Is_Abstract then if not Is_Abstract_Interface (Parent) then Error_Loc (1) := Loc (E); DE ("abstract interface cannot inherit " & "from a non-abstract interface"); Set_Reference (Scoped_Name, No_Node); end if; end if; end if; Scoped_Name := Next_Entity (Scoped_Name); end loop; -- Push a new scope and then inherit from the parent interfaces. Push_Scope (E); Scoped_Name := First_Entity (Interface_Spec (E)); while Present (Scoped_Name) loop Parent := Reference (Scoped_Name); if Present (Parent) then Inherit_From (Parent); end if; Scoped_Name := Next_Entity (Scoped_Name); end loop; -- Append and analyze the interface entities Definition := First_Entity (Interface_Body (E)); while Present (Definition) loop Analyze (Definition); Definition := Next_Entity (Definition); end loop; Pop_Scope; end Analyze_Interface_Declaration; --------------------- -- Analyze_Literal -- --------------------- procedure Analyze_Literal (E : Node_Id) is begin Dummy (E); end Analyze_Literal; -------------------- -- Analyze_Member -- -------------------- procedure Analyze_Member (E : Node_Id) is D : Node_Id := First_Entity (Declarators (E)); begin Analyze_Type_Spec (Type_Spec (E)); while Present (D) loop Analyze (D); D := Next_Entity (D); end loop; end Analyze_Member; -------------------- -- Analyze_Module -- -------------------- procedure Analyze_Module (E : Node_Id) is pragma Assert (Kind (E) = K_Specification or else Kind (E) = K_Module); C : Node_Id; L : List_Id; begin if Kind (E) = K_Module then Enter_Name_In_Scope (Identifier (E)); end if; L := Definitions (E); if not Is_Empty (L) then Push_Scope (E); C := First_Entity (L); while Present (C) loop Analyze (C); C := Next_Entity (C); end loop; Pop_Scope; end if; -- Now go through the definitions, and merge all modules with the same -- into a single module that includes all the definitions nested in all -- of them. The last one is the one that remains; the others are erased -- from the tree, and from the Homonym chain. This has to happen after -- they have all been analyzed, so that visibility will work properly -- during analysis. L := Definitions (E); C := First_Entity (L); while Present (C) loop if Kind (C) = K_Module then declare H : constant Node_Id := Homonym (Identifier (C)); Prev : Node_Id; New_Defs : List_Id; begin if Present (H) then Prev := Corresponding_Entity (H); New_Defs := Definitions (Prev); Append_To (New_Defs, First_Entity (Definitions (C))); Set_Definitions (C, New_Defs); Remove_Node_From_List (Prev, L); Set_Homonym (Identifier (C), No_Node); end if; end; end if; C := Next_Entity (C); end loop; end Analyze_Module; ------------------------- -- Analyze_Native_Type -- ------------------------- procedure Analyze_Native_Type (E : Node_Id) is begin Analyze (Declarator (E)); end Analyze_Native_Type; ----------------------------------- -- Analyze_Operation_Declaration -- ----------------------------------- procedure Analyze_Operation_Declaration (E : Node_Id) is procedure No_Operation_Parameter_Of_Local_Type (T : Node_Id; I : Node_Id); procedure No_Exception_Member_Of_Local_Type (X : Node_Id; I : Node_Id); --------------------------------------- -- No_Exception_Member_Of_Local_Type -- --------------------------------------- procedure No_Exception_Member_Of_Local_Type (X : Node_Id; I : Node_Id) is EX : Node_Id := X; EM : Node_Id; MT : Node_Id; TK : Node_Kind; begin if Present (EX) and then Kind (EX) = K_Scoped_Name then EX := Reference (EX); end if; if No (EX) then return; end if; EM := First_Entity (Members (EX)); while Present (EM) loop MT := Type_Spec (EM); if Present (MT) and then Kind (MT) = K_Scoped_Name then MT := Reference (MT); end if; if Present (MT) then TK := Kind (MT); if (TK = K_Forward_Interface_Declaration or else TK = K_Forward_Interface_Declaration) and then Is_A_Local_Type (MT) then Error_Loc (1) := Loc (EM); Error_Name (1) := IDL_Name (Identifier (MT)); Error_Name (2) := IDL_Name (Identifier (I)); DE ("local interface#cannot appear " & "as an exception declaration " & "in unconstrained interface#"); end if; end if; EM := Next_Entity (EM); end loop; end No_Exception_Member_Of_Local_Type; ------------------------------------------ -- No_Operation_Parameter_Of_Local_Type -- ------------------------------------------ procedure No_Operation_Parameter_Of_Local_Type (T : Node_Id; I : Node_Id) is PT : Node_Id := T; TK : Node_Kind; begin if Present (PT) and then Kind (PT) = K_Scoped_Name then PT := Reference (PT); end if; if No (PT) then return; end if; TK := Kind (PT); if (TK = K_Forward_Interface_Declaration or else TK = K_Forward_Interface_Declaration) and then Is_A_Local_Type (PT) then Error_Loc (1) := Loc (T); Error_Name (1) := IDL_Name (Identifier (T)); Error_Name (2) := IDL_Name (Identifier (I)); DE ("local interface#cannot appear as parameter " & "in unconstrained interface#"); end if; end No_Operation_Parameter_Of_Local_Type; Iface : constant Node_Id := Current_Scope; Is_Local : constant Boolean := Is_A_Local_Type (Iface); Oneway : Boolean := Is_Oneway (E); Return_Type_Id : Node_Id; Return_Type : Node_Id; Param_Type : Node_Id; Op_Parameter : Node_Id; Op_Exception : Node_Id; Op_Context : Node_Id; begin Enter_Name_In_Scope (Identifier (E)); if Kind (E) /= K_Initializer_Declaration then Return_Type_Id := Type_Spec (E); Analyze_Type_Spec (Return_Type_Id); Return_Type := Return_Type_Id; if Kind (Return_Type) = K_Scoped_Name then Return_Type := Reference (Return_Type); end if; -- When operation is oneway, check return type is void if Oneway and then Kind (Return_Type) /= K_Void then Oneway := False; Error_Loc (1) := Loc (Return_Type); DE ("oneway operation cannot return a non-void result"); end if; -- When the current interface is not local, check that its -- operations do not use local types. if not Is_Local then No_Operation_Parameter_Of_Local_Type (Return_Type, Iface); end if; end if; -- Analyze parameters if not Is_Empty (Parameters (E)) then Push_Scope (E); Op_Parameter := First_Entity (Parameters (E)); while Present (Op_Parameter) loop Analyze (Op_Parameter); -- When operation is oneway, check parameter mode is "in" if Oneway and then Parameter_Mode (Op_Parameter) /= Mode_In then Oneway := False; Error_Loc (1) := Loc (Op_Parameter); DE ("oneway operation can only have ""in"" parameters"); end if; -- When the current interface is not local, check -- operation parameter are not local types. Param_Type := Type_Spec (Op_Parameter); if not Is_Local then No_Operation_Parameter_Of_Local_Type (Param_Type, Iface); end if; Op_Parameter := Next_Entity (Op_Parameter); end loop; Pop_Scope; end if; -- Analyze exceptions if not Is_Empty (Exceptions (E)) then Op_Exception := First_Entity (Exceptions (E)); while Present (Op_Exception) loop Analyze (Op_Exception); -- When operation is oneway, no exception is allowed if Oneway then Oneway := False; Error_Loc (1) := Loc (Op_Exception); DE ("oneway operation may not have raises expression"); end if; -- When the current interface is not local, check -- an exception member is not of local type. if not Is_Local then No_Exception_Member_Of_Local_Type (Op_Exception, Iface); end if; Op_Exception := Next_Entity (Op_Exception); end loop; end if; -- Analyze contexts if not Is_Empty (Contexts (E)) then Op_Context := First_Entity (Contexts (E)); while Present (Op_Context) loop Analyze (Op_Context); Op_Context := Next_Entity (Op_Context); end loop; end if; end Analyze_Operation_Declaration; ----------------------------------- -- Analyze_Parameter_Declaration -- ----------------------------------- procedure Analyze_Parameter_Declaration (E : Node_Id) is begin Analyze_Type_Spec (Type_Spec (E)); Analyze (Declarator (E)); end Analyze_Parameter_Declaration; -------------------- -- Analyze_Pragma -- -------------------- procedure Analyze_Pragma (E : Node_Id) is R : Node_Id; N : Node_Id; begin if Pragma_Kind (E) /= Pragma_Unrecognized then N := Make_Identifier (Loc (E), Data (E), No_Node, No_Node); end if; case Pragma_Kind (E) is when Pragma_Id => Analyze (Target (E)); R := Reference (Target (E)); Assign_Type_Id (R, N); when Pragma_Prefix => Assign_Type_Prefix (Current_Scope, N); when Pragma_Version => Analyze (Target (E)); R := Reference (Target (E)); Assign_Type_Version (R, N); when Pragma_Unrecognized => Error_Loc (1) := Loc (E); DE ("?unknown pragma"); -- ??? error message should include pragma name end case; end Analyze_Pragma; ------------------------- -- Analyze_Scoped_Name -- ------------------------- procedure Analyze_Scoped_Name (E : Node_Id) is P : Node_Id := Parent_Entity (E); N : Node_Id := Identifier (E); C : Node_Id; begin -- This scoped name has already been analyzed. if Present (Reference (E)) then return; end if; -- Analyze single scoped name. First we have to find a possible -- visible entity. If there is one, associate the reference to -- the designated entity and check whether the casing is -- correct. Enter the name in the scope. if No (P) then if Name (N) = No_Name then Set_Reference (E, IDL_Spec); else C := Visible_Node (N); if Present (C) then Set_Reference (E, C); Enter_Name_In_Scope (N); Check_Identifier (N, Identifier (C)); end if; end if; -- Analyze multiple scoped names. Analyze parent of P first and then the -- entity itself. Find the entity in the newly-analyzed parent scope. -- Check whether the scope is a correct scope for a scoped name (not an -- operation for instance). else Analyze_Scoped_Name (P); P := Reference (P); if Present (P) then if Is_A_Scope (P) then C := Node_Explicitly_In_Scope (N, P); if No (C) then Error_Loc (1) := Loc (N); Error_Name (1) := IDL_Name (N); Error_Name (2) := IDL_Name (Identifier (P)); DE ("#not declared in#"); return; end if; Set_Reference (E, C); Check_Identifier (N, Identifier (C)); -- If this scoped name is the full scoped name (and -- not a part of the scoped name), if this designates -- a type name and if the scope is a non-module -- entity, then enter the name in the scope. if Depth (E) = 0 and then Is_Noninterface_Type (C) and then Is_A_Non_Module (Current_Scope) then Enter_Name_In_Scope (N); end if; else N := Identifier (P); Error_Loc (1) := Loc (N); Error_Name (1) := IDL_Name (N); DE ("#does not form a scope"); end if; end if; end if; end Analyze_Scoped_Name; --------------------------- -- Analyze_Sequence_Type -- --------------------------- procedure Analyze_Sequence_Type (E : Node_Id) is Unsigned_Long_Long_Node : constant Node_Id := Parser.Resolve_Base_Type ((T_Unsigned, T_Long, T_Long), Loc (E)); begin Analyze_Type_Spec (Type_Spec (E)); Analyze_And_Resolve_Expr (Max_Size (E), Unsigned_Long_Long_Node); end Analyze_Sequence_Type; ------------------------------- -- Analyze_Simple_Declarator -- ------------------------------- procedure Analyze_Simple_Declarator (E : Node_Id) is begin Enter_Name_In_Scope (Identifier (E)); end Analyze_Simple_Declarator; -------------------------- -- Analyze_State_Member -- -------------------------- procedure Analyze_State_Member (E : Node_Id) is begin Analyze_Member (E); end Analyze_State_Member; -------------------- -- Analyze_String -- -------------------- procedure Analyze_String (E : Node_Id) is Unsigned_Long_Long_Node : constant Node_Id := Parser.Resolve_Base_Type ((T_Unsigned, T_Long, T_Long), Loc (E)); begin Analyze_And_Resolve_Expr (Max_Size (E), Unsigned_Long_Long_Node); end Analyze_String; ---------------------------- -- Analyze_Structure_Type -- ---------------------------- procedure Analyze_Structure_Type (E : Node_Id) is L : List_Id; C : Node_Id; begin Enter_Name_In_Scope (Identifier (E)); L := Members (E); if not Is_Empty (L) then Push_Scope (E); C := First_Entity (L); while Present (C) loop Analyze (C); C := Next_Entity (C); end loop; Pop_Scope; end if; end Analyze_Structure_Type; ------------------------------ -- Analyze_Type_Declaration -- ------------------------------ procedure Analyze_Type_Declaration (E : Node_Id) is D : Node_Id := First_Entity (Declarators (E)); begin Analyze_Type_Spec (Type_Spec (E)); while Present (D) loop Analyze (D); D := Next_Entity (D); end loop; end Analyze_Type_Declaration; --------------------------------- -- Analyze_Type_Id_Declaration -- --------------------------------- procedure Analyze_Type_Id_Declaration (E : Node_Id) is R : Node_Id; N : Node_Id; begin Analyze (Target (E)); R := Reference (Target (E)); N := Make_Identifier (Loc (Target (E)), Data (E), No_Node, No_Node); Assign_Type_Id (R, N, True); end Analyze_Type_Id_Declaration; ------------------------------------- -- Analyze_Type_Prefix_Declaration -- ------------------------------------- procedure Analyze_Type_Prefix_Declaration (E : Node_Id) is R : Node_Id; N : Node_Id; begin Analyze (Target (E)); R := Reference (Target (E)); N := Make_Identifier (Loc (Target (E)), Data (E), No_Node, No_Node); Assign_Type_Prefix (R, N); end Analyze_Type_Prefix_Declaration; ----------------------- -- Analyze_Type_Spec -- ----------------------- procedure Analyze_Type_Spec (E : Node_Id) is begin Analyze (E); -- If it's a scoped name, make sure it denotes a type. Otherwise, it is -- syntactically a type, so nothing to check. if Kind (E) = K_Scoped_Name and then Present (Reference (E)) -- Guard against previous error and then not Is_Type (Reference (E)) then Error_Loc (1) := Loc (E); DE ("type expected"); end if; end Analyze_Type_Spec; ------------------------ -- Analyze_Union_Type -- ------------------------ procedure Analyze_Union_Type (E : Node_Id) is Alternative : Node_Id; Label : Node_Id; Switch_Type : Node_Id := Switch_Type_Spec (E); L : Natural; begin Enter_Name_In_Scope (Identifier (E)); Push_Scope (E); Analyze_Type_Spec (Switch_Type); -- Check that switch type is a discrete type Switch_Type := Resolve_Type (Switch_Type); case Kind (Switch_Type) is when K_Short .. K_Wide_Char | K_Boolean | K_Octet | K_Enumeration_Type => null; when others => Error_Loc (1) := Loc (Switch_Type); DE ("switch must have a discrete type"); return; end case; -- Resolve labels and elements Alternative := First_Entity (Switch_Type_Body (E)); while Present (Alternative) loop Label := First_Entity (Labels (Alternative)); while Present (Label) loop Analyze_And_Resolve_Constant_Declaration_Or_Case_Label_Expr (Label, Switch_Type); Label := Next_Entity (Label); end loop; Analyze (Element (Alternative)); Alternative := Next_Entity (Alternative); end loop; -- Check there is no duplicated choice LT.Init; Alternative := First_Entity (Switch_Type_Body (E)); while Present (Alternative) loop Label := First_Entity (Labels (Alternative)); while Present (Label) loop LT.Append (Label); Label := Next_Entity (Label); end loop; Alternative := Next_Entity (Alternative); end loop; GNAT.Bubble_Sort.Sort (LT.Last, Exchange'Access, Less_Than'Access); for I in 1 .. LT.Last - 1 loop -- If this comparison is false once sorted, it means that -- the two nodes are equal. Take care of duplicated default -- case. Having two incorrect nodes equal is not a problem. if (No (Expression (LT.Table (I))) and then No (Expression (LT.Table (I + 1)))) or else (Value (LT.Table (I)) /= No_Value and then not Less_Than (I, I + 1)) then -- Reorder nodes in order to output the error message on -- the second node in the file. if Loc (LT.Table (I + 1)) < Loc (LT.Table (I)) then Error_Loc (1) := Loc (LT.Table (I)); Error_Loc (2) := Loc (LT.Table (I + 1)); else Error_Loc (1) := Loc (LT.Table (I + 1)); Error_Loc (2) := Loc (LT.Table (I)); end if; DE ("duplication of choice value at line!"); exit; end if; end loop; Pop_Scope; -- Check for useless choices (explicit choices in alternative that -- includes the default label). Alternative := First_Entity (Switch_Type_Body (E)); while Present (Alternative) loop Label := First_Entity (Labels (Alternative)); L := Length (Labels (Alternative)); if L > 1 then while Present (Label) loop if Value (Label) = No_Value then -- Display a warning Error_Loc (1) := Loc (Alternative); DE ("Some labels are useless since one" & " of them is the default clause?"); end if; Label := Next_Entity (Label); end loop; end if; Alternative := Next_Entity (Alternative); end loop; end Analyze_Union_Type; ----------------------------------- -- Analyze_Value_Box_Declaration -- ----------------------------------- procedure Analyze_Value_Box_Declaration (E : Node_Id) is begin Enter_Name_In_Scope (Identifier (E)); Analyze_Type_Spec (Type_Spec (E)); end Analyze_Value_Box_Declaration; ------------------------------- -- Analyze_Value_Declaration -- ------------------------------- procedure Analyze_Value_Declaration (E : Node_Id) is Scoped_Name : Node_Id; Parent : Node_Id; Definition : Node_Id; Scoped_Names : List_Id; Parent_Kind : Node_Kind; Is_Abstract : constant Boolean := Kind (E) = K_Abstract_Value_Declaration; begin Enter_Name_In_Scope (Identifier (E)); -- Analyze value type names in the current scope (before pushing a new -- scope and inheriting from other value types). Scoped_Names := Value_Names (Value_Spec (E)); if not Is_Empty (Scoped_Names) then Scoped_Name := First_Entity (Scoped_Names); while Present (Scoped_Name) loop Analyze (Scoped_Name); Parent := Reference (Scoped_Name); if Present (Parent) then Parent_Kind := Kind (Parent); if Parent_Kind /= K_Value_Declaration and then Parent_Kind /= K_Abstract_Value_Declaration then if Parent_Kind = K_Value_Forward_Declaration then Error_Loc (1) := Loc (E); DE ("value type cannot inherit " & "from a forward-declared value type"); else Error_Loc (1) := Loc (E); DE ("value type cannot inherit " & "from a non-value type"); end if; -- Do not consider this value type later on Set_Reference (Scoped_Name, No_Node); elsif Is_Abstract and then Parent_Kind /= K_Abstract_Value_Declaration then Error_Loc (1) := Loc (E); DE ("abstract value type cannot inherit " & "from a non-abstract value type"); Set_Reference (Scoped_Name, No_Node); end if; end if; Scoped_Name := Next_Entity (Scoped_Name); end loop; end if; -- Analyze interface names in the current scope (before pushing a -- new scope). Scoped_Names := Interface_Names (Value_Spec (E)); if not Is_Empty (Scoped_Names) then Scoped_Name := First_Entity (Scoped_Names); while Present (Scoped_Name) loop Analyze (Scoped_Name); Parent := Reference (Scoped_Name); if Present (Parent) then if Kind (Parent) /= K_Interface_Declaration then if Kind (Parent) = K_Forward_Interface_Declaration then Error_Loc (1) := Loc (E); DE ("interface cannot inherit " & "from a forward-declared interface"); else Error_Loc (1) := Loc (E); DE ("interface cannot inherit " & "from a non-interface"); end if; -- Do not consider this interface later on Set_Reference (Scoped_Name, No_Node); end if; end if; Scoped_Name := Next_Entity (Scoped_Name); end loop; end if; -- Push a new scope, then inherit from the parent value types Push_Scope (E); Scoped_Names := Value_Names (Value_Spec (E)); if not Is_Empty (Scoped_Names) then Scoped_Name := First_Entity (Scoped_Names); while Present (Scoped_Name) loop Parent := Reference (Scoped_Name); if Present (Parent) then Inherit_From (Parent); end if; Scoped_Name := Next_Entity (Scoped_Name); end loop; end if; -- Inherit from the parent interfaces Scoped_Names := Interface_Names (Value_Spec (E)); if not Is_Empty (Scoped_Names) then Scoped_Name := First_Entity (Scoped_Names); while Present (Scoped_Name) loop Parent := Reference (Scoped_Name); if Present (Parent) then Inherit_From (Parent); end if; Scoped_Name := Next_Entity (Scoped_Name); end loop; end if; -- Append and analyze the value entities Definition := First_Entity (Value_Body (E)); while Present (Definition) loop Analyze (Definition); Definition := Next_Entity (Definition); end loop; Pop_Scope; end Analyze_Value_Declaration; --------------------------------------- -- Analyze_Value_Forward_Declaration -- --------------------------------------- procedure Analyze_Value_Forward_Declaration (E : Node_Id) is begin Enter_Name_In_Scope (Identifier (E)); end Analyze_Value_Forward_Declaration; -------------------- -- Assign_Type_Id -- -------------------- procedure Assign_Type_Id (Scope : Node_Id; Prefix : Node_Id; Unique : Boolean := False) is begin case Kind (Scope) is when K_Module | K_Interface_Declaration | K_Forward_Interface_Declaration | K_Value_Declaration | K_Value_Forward_Declaration | K_Value_Box_Declaration | K_Constant_Declaration | K_Type_Declaration | K_Exception_Declaration | K_Attribute_Declaration | K_Operation_Declaration | K_Enumeration_Type => null; when others => Error_Loc (1) := Loc (Prefix); DE ("A type Id should not be defined for this entity"); return; end case; if Present (Type_Id (Scope)) and then (IDL_Name (Type_Id (Scope)) /= IDL_Name (Prefix) or else Unique) then Error_Loc (1) := Loc (Prefix); DE ("type id should not be redefined"); else Set_Type_Id (Scope, Prefix); end if; end Assign_Type_Id; ------------------------ -- Assign_Type_Prefix -- ------------------------ procedure Assign_Type_Prefix (Scope : Node_Id; Prefix : Node_Id) is Prefixes : List_Id; begin -- The Corba Spec 3.0 states that: -- "The specified prefix applies to Repository Ids generated after the -- pragma until the end of the current scope is reached or another -- prefix pragma is encountered. An IDL file forms a scope for this -- purpose, so a prefix resets to the previous prefix at the end of -- the scope of an included file..." -- Each time we encounter a type prefix, we put it in the Type_Prefixes -- list with its location. The locations will help to assign the right -- prefix to a Repository Id constant. if Kind (Scope) = K_Specification or else Kind (Scope) = K_Module or else Kind (Scope) = K_Interface_Declaration or else Kind (Scope) = K_Value_Declaration then Prefixes := Type_Prefixes (Scope); if Is_Empty (Prefixes) then Prefixes := New_List (Loc (Scope)); Set_Type_Prefixes (Scope, Prefixes); end if; Append_To (Prefixes, Prefix); end if; end Assign_Type_Prefix; ------------------------- -- Assign_Type_Version -- ------------------------- procedure Assign_Type_Version (Scope : Node_Id; Prefix : Node_Id) is begin case Kind (Scope) is when K_Module | K_Interface_Declaration | K_Forward_Interface_Declaration | K_Value_Declaration | K_Value_Forward_Declaration | K_Value_Box_Declaration | K_Constant_Declaration | K_Type_Declaration | K_Exception_Declaration | K_Attribute_Declaration | K_Operation_Declaration | K_Enumeration_Type => null; when others => Error_Loc (1) := Loc (Prefix); DE ("A Version Id should not be defined for this entity"); return; end case; if Present (Type_Version (Scope)) and then IDL_Name (Type_Version (Scope)) /= IDL_Name (Prefix) then Error_Loc (1) := Loc (Prefix); DE ("pragma version should not be redefined"); elsif Present (Type_Id (Scope)) then declare Rep_Id : constant String := Get_Name_String (IDL_Name (Type_Id (Scope))); V_Id : constant String := Get_Name_String (IDL_Name (Prefix)); begin -- We assume that the version appears at the end of the -- Repository_ID constant. if V_Id'Length <= Rep_Id'Length and then Rep_Id (Rep_Id'Last - V_Id'Length + 1 .. Rep_Id'Last) /= V_Id then Error_Loc (1) := Loc (Prefix); DE ("Type ID should not be overridden"); else Set_Type_Version (Scope, Prefix); end if; end; else Set_Type_Version (Scope, Prefix); end if; end Assign_Type_Version; ------------- -- Convert -- ------------- function Convert (E : Node_Id; T : Node_Id; K : Node_Kind) return Value_Type is procedure Cannot_Interpret (E : Node_Id; S : Message_Template; T : Node_Kind); -- Output an error message to indicate that a value cannot be cast to -- a given type. E denotes the entity in which the cast occurs, V the -- source type and K the target type. ???There's no V or K. ---------------------- -- Cannot_Interpret -- ---------------------- procedure Cannot_Interpret (E : Node_Id; S : Message_Template; T : Node_Kind) is begin Error_Loc (1) := Loc (E); Error_Name (1) := Quoted (Image (T)); DE ("cannot interpret " & S & " as%"); end Cannot_Interpret; KT : Node_Kind := Kind (T); RE : Node_Id := E; RV : Value_Type; R : Value_Id; KE : Node_Kind := Kind (E); I : Unsigned_Long_Long; S : Short_Short; -- Start of processing for Convert begin -- First resolve a scoped name if KE = K_Scoped_Name then RE := Reference (E); if No (RE) then return Bad_Value; end if; end if; -- Resolve the Result Value RV and the Kind of Type KT R := Value (RE); if R = No_Value then return Bad_Value; end if; RV := Value (R); -- For an enumeration type, check the reference designates either an -- enumerator or a valid constant value. if KT = K_Enumeration_Type then KE := Kind (RE); if KE = K_Enumerator then return RV; end if; if KE /= K_Constant_Declaration then Error_Loc (1) := Loc (E); Error_Name (1) := IDL_Name (Identifier (T)); DE ("expected type#"); return Bad_Value; end if; declare CT : Node_Id := Type_Spec (RE); begin if Kind (CT) = K_Scoped_Name then CT := Reference (CT); end if; if Kind (CT) /= K_Enumeration_Type or else T /= CT then Error_Loc (1) := Loc (E); Error_Name (1) := IDL_Name (Identifier (T)); DE ("expected type#"); return Bad_Value; end if; R := Value (RE); if R = No_Value then return Bad_Value; end if; RV := Value (R); return RV; end; end if; case RV.K is when K_Short .. K_Unsigned_Long_Long | K_Octet => -- When integer value, cast into integer type if KT not in K_Short .. K_Unsigned_Long_Long and then KT /= K_Octet then Cannot_Interpret (E, "integer", KT); return Bad_Value; end if; I := RV.IVal; S := RV.Sign; -- In a constant declaration, subtyping is -- restrictive. In an expression, a literal or a -- scoped name, signed or unsigned integers of 8, 16 -- and 32 bits are handled as signed or unsigned -- integers of 32 bits. Therefore, the cast is -- performed first to signed integers. Then to -- unsigned integers. if K /= K_Constant_Declaration then if KT = K_Unsigned_Long_Long or else KT = K_Long_Long then KT := K_Long_Long; else KT := K_Long; end if; end if; -- When E is not a declaration, cast to signed -- integers or else to unsigned integers. When E is a -- declaration, cast to the exact type. declare Conversion_Succcessful : Boolean := False; begin for B in False .. True loop case KT is when K_Octet => if In_Range (I, S, FO, LO) then RV := Convert (RV, KT); Conversion_Succcessful := True; end if; when K_Short => if In_Range (I, S, FS, LS) then RV := Convert (RV, KT); Conversion_Succcessful := True; end if; when K_Long => if In_Range (I, S, FL, LL) then RV := Convert (RV, KT); Conversion_Succcessful := True; end if; when K_Long_Long => if In_Range (I, S, FLL, LLL) then RV := Convert (RV, KT); Conversion_Succcessful := True; end if; when K_Unsigned_Short => if In_Range (I, S, FUS, LUS) then RV := Convert (RV, KT); Conversion_Succcessful := True; end if; when K_Unsigned_Long => if In_Range (I, S, FUL, LUL) then RV := Convert (RV, KT); Conversion_Succcessful := True; end if; when K_Unsigned_Long_Long => if In_Range (I, S, FULL, LULL) then RV := Convert (RV, KT); Conversion_Succcessful := True; end if; when others => null; end case; exit when K = K_Constant_Declaration or else Conversion_Succcessful; -- Switch to unsigned integers if KT = K_Long_Long then KT := K_Unsigned_Long_Long; elsif KT /= K_Unsigned_Long_Long then KT := K_Unsigned_Long; end if; end loop; end; -- Cast cannot be performed. Output an error message -- according to the performed operation: exact cast, -- 32-bits integer cast, 64-bits integer cast. if RV.K /= KT then if K = K_Constant_Declaration then Display_Incorrect_Value (Loc (E), KT); elsif KT = K_Unsigned_Long then Display_Incorrect_Value (Loc (E), K_Long, K_Unsigned_Long); else Display_Incorrect_Value (Loc (E), K_Long_Long, K_Unsigned_Long_Long); end if; return Bad_Value; end if; when K_String | K_String_Type => if RV.K /= K_String and then RV.K /= K_String_Type then Cannot_Interpret (E, "string", KT); return Bad_Value; end if; RV := Convert (RV, KT); when K_Wide_String | K_Wide_String_Type => if RV.K /= K_Wide_String and then RV.K /= K_Wide_String_Type then Cannot_Interpret (E, "wide string", KT); return Bad_Value; end if; RV := Convert (RV, KT); when K_Char => if RV.K /= KT then Cannot_Interpret (E, "character", KT); return Bad_Value; end if; RV := Convert (RV, KT); when K_Wide_Char => if RV.K /= KT then Cannot_Interpret (E, "wide character", KT); return Bad_Value; end if; RV := Convert (RV, KT); when K_Fixed_Point_Type => if RV.K /= KT then Cannot_Interpret (E, "fixed point", KT); return Bad_Value; end if; -- For constant declaration, subtyping is restrictive. -- The fixed point value must be truncated to the -- appropriate scale. It cannot exceed the appropriate -- total number of digits. declare Total : Unsigned_Short_Short; Scale : Unsigned_Short_Short; begin if K = K_Constant_Declaration then Total := Unsigned_Short_Short (N_Total (T)); Scale := Unsigned_Short_Short (N_Scale (T)); else Total := Max_Digits; Scale := Max_Digits; end if; Normalize_Fixed_Point_Value (RV, Total, Scale); if RV = Bad_Value then Error_Loc (1) := Loc (E); Error_Int (1) := Int (Total); Error_Int (2) := Int (Scale); DE ("too many digits to fit fixed<$,$>"); return RV; end if; RV := Convert (RV, KT); end; when K_Float .. K_Long_Double => if RV.K not in K_Float .. K_Long_Double then Cannot_Interpret (E, "float", KT); return Bad_Value; end if; RV := Convert (RV, KT); when K_Boolean => if RV.K /= KT then Cannot_Interpret (E, "boolean", KT); return Bad_Value; end if; RV := Convert (RV, KT); when others => return Bad_Value; end case; return RV; end Convert; ----------------------------- -- Display_Incorrect_Value -- ----------------------------- procedure Display_Incorrect_Value (L : Location; K1 : Node_Kind; K2 : Node_Kind := K_Void) is begin Error_Loc (1) := L; Error_Name (1) := Quoted (Image (K1)); if K2 = K_Void then DE ("value not in range of type of%"); else Error_Name (2) := Quoted (Image (K2)); DE ("value not in range of type of%or%"); end if; end Display_Incorrect_Value; -------------- -- Exchange -- -------------- procedure Exchange (Op1, Op2 : Natural) is N : constant Node_Id := LT.Table (Op1); begin LT.Table (Op1) := LT.Table (Op2); LT.Table (Op2) := N; end Exchange; -------------- -- In_Range -- -------------- function In_Range (I : Unsigned_Long_Long; S : Short_Short; F : Long_Long; L : Unsigned_Long_Long) return Boolean is Minus_F : Unsigned_Long_Long; begin if S < 0 then if F < 0 then -- If F is equal to FLL (the lowest Long_Long), doing -- directly Unsigned_Long_Long (-F) will cause an -- overflow error because converting FLL to LLL + 1 is -- occured before the type conversion to -- Unsigned_Long_Long. The instructions below -- work-around this problem. Minus_F := Unsigned_Long_Long (-(F + 1)); Minus_F := Minus_F + 1; if I <= Minus_F then return True; end if; end if; return False; end if; return I <= L; end In_Range; ------------------ -- Inherit_From -- ------------------ procedure Inherit_From (Parent : Node_Id) is Entity : Node_Id; Identifier : Node_Id; begin Identifier := Scoped_Identifiers (Parent); while Present (Identifier) loop Entity := Corresponding_Entity (Identifier); -- Do not add to the scope a scoped name that was introduced in a -- parent scope. If the interface inherits from parent entities, this -- is a new scope in which the names introduced for the parents are -- no longer considered. if Present (Entity) and then Kind (Entity) /= K_Scoped_Name then Enter_Name_In_Scope (Make_Identifier (Loc (Entity), IDL_Name (Identifier), Entity, Current_Scope)); end if; Identifier := Next_Entity (Identifier); end loop; end Inherit_From; --------------- -- Less_Than -- --------------- function Less_Than (Op1, Op2 : Natural) return Boolean is N1, N2 : Node_Id; V1, V2 : Value_Id; begin -- N1 is default N1 := LT.Table (Op1); if No (Expression (N1)) then return False; end if; V1 := Value (N1); -- N2 is default N2 := LT.Table (Op2); if No (Expression (N2)) then return True; end if; V2 := Value (N2); -- N1 is an incorrect node if V1 = No_Value then return V2 /= No_Value; elsif V2 = No_Value then return False; end if; return Value (V1) < Value (V2); end Less_Than; ------------------ -- Resolve_Expr -- ------------------ procedure Resolve_Expr (E : Node_Id; T : Node_Id) is KE : Node_Kind; RE, LE : Node_Id; RV, LV : Value_Type; O : Token_Type; begin if No (T) or else No (E) then return; end if; KE := Kind (E); case KE is -- Enumerators and literals have their Value set in the parser, and -- Scoped_Names don't have a Value field, so just return in these -- cases. when K_Enumerator | K_Integer_Literal .. K_Boolean_Literal -- literals | K_Scoped_Name => return; when K_Expression => null; -- Proceed below when others => raise Program_Error; end case; -- For expression, evaluate left part when possible and then -- right part of the expression. Each result is converted into -- type T following the specific rules for sub-expression (see -- function Convert). Then execute operation and check that the -- operation was successful. Do not convert to T at this point. LE := Left_Expr (E); if Present (LE) then -- Resolve and convert a possible left sub-expression Resolve_Expr (LE, T); LV := Convert (LE, T, KE); if LV = Bad_Value then Set_Value (E, No_Value); return; end if; end if; RE := Right_Expr (E); if No (RE) then Set_Value (E, No_Value); return; end if; -- Resolve and convert a right sub-expression Resolve_Expr (RE, T); RV := Convert (RE, T, KE); if RV = Bad_Value then Set_Value (E, No_Value); return; end if; -- For binary operator, check that the two operands have the -- same type. O := Token_Type'Val (Operator (E)); if Present (LE) and then LV.K /= RV.K then Error_Loc (1) := Loc (E); Error_Name (1) := Quoted (Image (O)); DE ("invalid operand types for operator%"); Set_Value (E, No_Value); return; end if; case O is when T_Tilde => RV := not RV; when T_Minus => if No (LE) then RV := -RV; else RV := LV - RV; end if; when T_Plus => if Present (LE) then RV := LV + RV; end if; when T_Percent => RV := LV mod RV; when T_Slash => RV := LV / RV; when T_Star => RV := LV * RV; when T_Ampersand => RV := LV and RV; when T_Bar => RV := LV or RV; when T_Circumflex => RV := LV xor RV; when T_Greater_Greater => RV := Shift_Right (LV, RV); when T_Less_Less => RV := Shift_Left (LV, RV); when others => return; end case; if RV = Bad_Value then Set_Value (E, No_Value); return; end if; -- For integer types, we try to fit the new value in the smallest -- type. if (Kind (T) in K_Short .. K_Unsigned_Long_Long) or else Kind (T) = K_Octet then declare I : constant Unsigned_Long_Long := RV.IVal; S : constant Short_Short := RV.Sign; begin if In_Range (I, S, FO, LO) then RV := Convert (RV, K_Octet); elsif In_Range (I, S, FS, LS) then RV := Convert (RV, K_Short); elsif In_Range (I, S, FUS, LUS) then RV := Convert (RV, K_Unsigned_Short); elsif In_Range (I, S, FL, LL) then RV := Convert (RV, K_Long); elsif In_Range (I, S, FUL, LUL) then RV := Convert (RV, K_Unsigned_Long); elsif In_Range (I, S, FLL, LLL) then RV := Convert (RV, K_Long_Long); elsif In_Range (I, S, FULL, LULL) then RV := Convert (RV, K_Unsigned_Long_Long); end if; end; end if; Set_Value (E, New_Value (RV)); end Resolve_Expr; ------------------ -- Resolve_Type -- ------------------ function Resolve_Type (N : Node_Id) return Node_Id is T : Node_Id := N; begin while Present (T) loop case Kind (T) is when K_Simple_Declarator => T := Type_Spec (Declaration (T)); when K_Scoped_Name => T := Reference (T); when K_Forward_Interface_Declaration | K_Value_Forward_Declaration | K_Forward_Structure_Type | K_Forward_Union_Type => T := Forward (T); when others => exit; end case; end loop; return T; end Resolve_Type; end Analyzer; polyorb-2.8~20110207.orig/compilers/iac/lexer.ads0000644000175000017500000002304611750740337020756 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- L E X E R -- -- -- -- S p e c -- -- -- -- Copyright (C) 2005-2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with GNAT.OS_Lib; use GNAT.OS_Lib; with Locations; use Locations; with Types; use Types; package Lexer is pragma Elaborate_Body (Lexer); type Token_Type is (T_Error, T_Identifier, -- About pragmas T_Pragma, T_Pragma_Id, T_Pragma_Prefix, T_Pragma_Version, T_Pragma_Unrecognized, -- About basic keywords T_Abstract, -- First keyword T_Component, T_Const, T_Consumes, T_Emits, T_Eventtype, T_Exception, T_Finder, T_Home, T_Import, T_Interface, T_Local, T_Module, T_Multiple, T_Native, T_Primary_Key, T_Provides, T_Publishes, T_Typedef, T_Type_Id, T_Type_Prefix, T_Uses, T_Value_Type, -- About attributes T_Readonly, T_Attribute, T_Get_Raises, T_Set_Raises, -- About operations T_Oneway, T_Void, T_In, T_Inout, T_Out, T_Context, T_Raises, -- Basic types T_Float, T_Double, T_Unsigned, T_Short, T_Long, T_Char, T_Wchar, T_Boolean, T_Octet, T_Any, T_Object, T_Value_Base, -- Boolean values T_False, T_True, -- About constructed types T_Enum, T_Struct, T_Union, T_Case, T_Default, T_Switch, -- About template types T_Sequence, T_String, T_Wstring, T_Fixed, -- About value types T_Custom, T_Factory, T_Private, T_Public, T_Supports, T_Truncatable, -- Last keyword -- Graphic characters T_Colon, T_Comma, T_Semi_Colon, T_Left_Brace, T_Left_Bracket, T_Left_Paren, T_Right_Brace, T_Right_Bracket, T_Right_Paren, T_Equal, T_Greater, T_Less, T_Tilde, -- First unary operator T_Minus, -- First binary operator T_Plus, -- Last unary operator T_Percent, T_Slash, T_Star, T_Ampersand, T_Bar, T_Circumflex, -- Double graphic characters T_Greater_Greater, T_Less_Less, -- Last binary operator T_Colon_Colon, -- Literals T_Integer_Literal, T_String_Literal, T_Wide_String_Literal, T_Character_Literal, T_Wide_Character_Literal, T_Fixed_Point_Literal, T_Floating_Point_Literal, T_Boolean_Literal, T_EOF); First_Token_Pos : constant := Token_Type'Pos (Token_Type'First); Last_Token_Pos : constant := Token_Type'Pos (Token_Type'Last); type Token_List_Type is array (Positive range <>) of Token_Type; subtype Keyword_Type is Token_Type range T_Abstract .. T_Truncatable; subtype Literal_Type is Token_Type range T_Integer_Literal .. T_Boolean_Literal; subtype Operator_Type is Token_Type range T_Tilde .. T_Less_Less; subtype Unary_Operator_Type is Token_Type range T_Tilde .. T_Plus; subtype Binary_Operator_Type is Token_Type range T_Minus .. T_Less_Less; subtype Mode_Type is Token_Type range T_In .. T_Out; Token : Token_Type; Token_Name : Name_Id; Token_Location : Location; function Is_Literal (T : Token_Type) return Boolean; function Is_Operator (T : Token_Type) return Boolean; function Is_Scoped_Name (T : Token_Type) return Boolean; function Image (T : Token_Type) return String; -- Return an image of token T. procedure Finalize_Imported; -- Pops the lexer state (when the state stack is not empty) function Handled (File_Name_Id : Name_Id) return Boolean; -- Indicate whether the file was parsed or not in order to avoid cyclic -- imports procedure Set_Handled (File_Name_Id : Name_Id); -- Marks the file as handled procedure Make_Cleanup; -- Cleanup temporary files when needed procedure Scan_Token; -- Scan token and update global variables Token, Token_Name -- (for identifiers and literals) and Token_Location. procedure Scan_Token (T : Token_Type); -- Same as above. When the current token is not the expected token -- T, an error message is output and Token is set to T_Error. As a -- special case, when T_Semi_Colon is expected, we output an error -- location at the end of the line instead of the current token -- location. procedure Scan_Token (L : Token_List_Type); -- Same as above. When the current token is not in the list of the -- expected tokens L, an error message is output. function Next_Token return Token_Type; -- Return next token but do not update the lexer state that is -- Token, Token_Name and Token_Location. procedure Unexpected_Token (T : Token_Type; C : String); -- Output an error message to indicate that T is unexpected. If C -- is not a null string, the message also indicates in which -- construct it is not expected. procedure Save_Lexer (State : out Location); -- Saves the current location in the State variable procedure Restore_Lexer (State : Location); -- Modifies the current location in the IDL specification procedure Push_Lexer_State; -- Pushes the current location in a state stack and deallocates the data -- concerning the handled IDL specification procedure Pop_Lexer_State; -- Pops a location from the state stack and loads the corresponding file procedure Skip_Declaration (Delimiter : Token_Type); -- Skip until we find a potential end of declaration. Delimiter -- indicates the kind of delimiters we are looking for (';', ',', -- ':') or ('{', '(', '[') or ('}', ')', ']'). We ensure that the -- declaration is well embraced. procedure Skip_Line; -- Skip current line -- Various literal values updated when the corresponding token is read Integer_Literal_Value : Unsigned_Long_Long; Integer_Literal_Sign : Short; Integer_Literal_Base : Unsigned_Short_Short; Decimal_Point_Position : Unsigned_Short_Short; Float_Literal_Value : Long_Double; String_Literal_Value : Name_Id; Character_Literal_Value : Unsigned_Short; Is_Wide_Literal_Value : Boolean; -- Since the name id used to designate empty string is No_Name, the -- incorrect string should not be No_Name. Incorrect_String : constant Name_Id := Name_Id'Last; Incorrect_Character : constant Unsigned_Short := LUS; -- Preprocessor and processor related entities CPP_Arg_Values : Argument_List (1 .. 64); CPP_Arg_Count : Natural := 0; -- Preprocessor arguments (including -I...) IAC_Search_Paths : Argument_List (1 .. 64); IAC_Search_Count : Natural := 0; -- IAC search path (for imports and for preprocessor) Keep_TMP_Files : Boolean := False; -- True when we want to keep temporary files generated during the -- compilation process procedure Add_CPP_Flag (S : String); -- Add argument S to the preprocessor flags procedure Add_IAC_Search_Path (S : String); -- Add argument S to the search path procedure Preprocess (Source : Types.Name_Id; Result : out GNAT.OS_Lib.File_Descriptor); -- Return a file descriptor of the preprocessed Source file procedure Output (Source : GNAT.OS_Lib.File_Descriptor); -- Output the preprocessed file Source procedure Process (Source_File : GNAT.OS_Lib.File_Descriptor; Source_Name : Types.Name_Id); -- Load file Source in the lexer procedure Write (T : Token_Type); end Lexer; polyorb-2.8~20110207.orig/compilers/iac/backend-be_corba_ada-nodes.idl0000644000175000017500000005035111750740337024673 0ustar xavierxaviermodule Backend::BE_CORBA_Ada::Nodes { /******************/ /* Internal types */ /******************/ /* These types map to the data types declared in the Types package */ typedef octet Mode_Id; typedef octet Operator_Id; typedef long Name_Id; typedef long Value_Id; /******************/ /* Internal nodes */ /******************/ /* The Root of all nodes in the Ada tree */ interface Node_Id { Node_Id Next_Node; // The next node in a given list. A node belongs to at most one list Node_Id FE_Node; // Used to create links between the Ada tree and the IDL tree }; /* The root node of all Ada entities which have an Identifier (subprograms, package declarations ... */ interface Definition : Node_Id { Node_Id Defining_Identifier; Node_Id Parent; }; /* We traverse a List_Id using the Next_Node field in Node_Id */ interface List_Id { Node_Id First_Node; Node_Id Last_Node; }; interface Identifier : Node_Id { Name_Id Name; // The local name if the identifier }; interface Defining_Identifier : Identifier { Node_Id Declaration_Node; // The Ada declaration the identifier belongs to }; /* The Attribute reference node is used to create Ada entities such as A'Class. A is the prefix, Class is the name of the Attribute designator ATTRIBUTE_REFERENCE ::= PREFIX'ATTRIBUTE_DESIGNATOR RANGE_ATTRIBUTE_REFERENCE ::= PREFIX'RANGE_ATTRIBUTE_DESIGNATOR */ interface Attribute_Reference : Node_Id { Name_Id Name; // Name of the Attribute designator (Class, Range [(...)], etc...) Node_Id Prefix; // Prefix, which is generally a Designator }; /* -- EXPLICIT_DEREFERENCE ::= NAME . all */ interface Explicit_Dereference : Node_Id { Node_Id Prefix; }; /*****************/ /* Package nodes */ /*****************/ /* USE_TYPE_CLAUSE ::= use type The_Used_Entity; */ interface Used_Type : Node_Id { Node_Id The_Used_Entity; }; interface Withed_Package : Definition { // The Defining_Identifier field inherited from Definition is the // package to be with'ed. boolean Used; // If True, generate a USE clause for this unit boolean Elaborated; // If true, generate a pragma Elaborate_All for this unit boolean Unreferenced; // If true, generate a pragma Unreferenced for this unit }; interface Used_Package : Used_Type { // The only difference between Used_Package and Used_Type is the // Key word "type" which is added at code generation time }; /*****************/ /* Package nodes */ /*****************/ /* An IDL unit is the set of Ada packages generated for an IDL interface, module or specification */ interface IDL_Unit : Node_Id { Node_Id Stubs_Package; // Points to the stub package declaration (if any) Node_Id Skeleton_Package; // Points to the skeleton package declaration (if any) Node_Id Implementation_Package; // Points to the user implementation package declaration (if any) Node_Id Ir_Info_Package; // Points to the interface repository information package (if any) Node_Id Helper_Package; // Points to the user Helper package declaration (if any) Node_Id Internals_Package; // Points to the Initialization package declaration (if any) Node_Id CDR_Package; // Points to the CDR package declaration (if any) Node_Id Aligned_Package; // Points to the Aligned package declaration (if any) Node_Id Buffers_Package; // Points to the 'Buffers' package declaration (if any) List_Id Packages; // This list contains all the package declarations of the IDL_Unit // and all the Child IDL_Units. It is traversed when generating the // Ada code. boolean Generate_Code; // False for imported entities }; /* A package declaration consist of a package specification and a package body. */ interface Package_Declaration : Definition { // The full name of the package is stored in the // Defining_Identifier field inherited from Definition. // This is very confusing, in Ada a package consists in a package // declaration and a package body, and a package specification is just // a package declaration minus a semicolon. Node_Id IDL_Unit; // The IDL_Unit the package declaration belongs to Node_Id Package_Specification; // The package specification Node_Id Package_Body; // The package body (if any) }; interface Package_Specification : Node_Id { Node_Id Package_Declaration; // Points to the corresponding package declaration List_Id Context_Clause; // Context clause (WITH clauses and pragmas) // In Ada this is not part of the package declaration??? List_Id Visible_Part; // The visible declaration part (between 'is' and 'private' // or else 'end') List_Id Subunits; // The list of subunits declared in this specification Note: we do // not want subunits to be declared in visible_part to ensure they // are generated after all other elements in the Visible_Part. List_Id Private_Part; // The private declaration part (between 'private' and 'end') boolean Is_Subunit_Package; // True if the package is a subunit boolean Is_Runtime_Package; // True if the package is a runtime package // What is a runtime package??? }; interface Package_Body : Node_Id { Node_Id Package_Declaration; // Points to the corresponding package declaration List_Id Context_Clause; // Context clause (WITH clauses and pragmas) List_Id Statements; // The statements of the package body (between the 'is' and the // 'begin' or else 'end') List_Id Package_Initialization; // The handled list of statements (between the 'begin' and the 'end') }; /********************/ /* Subprogram nodes */ /********************/ /* A subprogram parameter */ interface Parameter_Specification : Definition { // Defining_Identifier field inherited from Definition Mode_Id Parameter_Mode; // Mode of the parameter (Mode_IN, Mode_OUT or Mode_INOUT) Node_Id Parameter_Type; // Type of the parameter (generally a designator) Node_Id Expression; // Default value of a parameter (an expression, a literal...) }; interface Instantiated_Subprogram : Definition { List_Id Parameter_List; // Instantiation parameters }; interface Subprogram_Specification : Definition { // Defining_Identifier field inherited from Definition List_Id Parameter_Profile; // The list of parameters Node_Id Return_Type; // Return Type : if the return type is No_Node then we deal with // a procedure, else we deal with a function Node_Id Renamed_Entity; // Indicates whether the subprogram renames another subprogram // (Generally a designator) Node_Id Instantiated_Subprogram; // Indicates whether the subprogram is an instantiation of a generic // subprogram }; /* Subprogram Body */ interface Subprogram_Body : Node_Id { Node_Id Specification; // The kind of this node is Subprogram_Specification. There is no need // to duplicate the spec List_Id Declarations; // The declarative part of the subprogram List_Id Statements; // The statements of the subprogram }; interface Subprogram_Call : Definition { // Defining_Identifier field inherited from Definition List_Id Actual_Parameter_Part; // The list of parameter passed to a subprogram call may be // different from the parameter list described in the spec of the // subprogram. (May be a list of parameter associations or // whatever could be passed as a parameter) }; /* PARAMETER_ASSOCIATION ::= [formal_parameter_SELECTOR_NAME =>] EXPLICIT_ACTUAL_PARAMETER */ interface Parameter_Association : Node_Id { Node_Id Selector_Name; // The formal parameter selector name Node_Id Actual_Parameter; // The actual parameter }; /* SELECTED_COMPONENT ::= PREFIX . SELECTOR_NAME */ interface Selected_Component : Node_Id { Node_Id Prefix; Node_Id Selector_Name; }; /*********************/ /* Type declarations */ /*********************/ interface Full_Type_Declaration : Definition { // Defining_Identifier field inherited from Definition Node_Id Type_Definition; // May be: // an Enumeration_Type_Definition // a Decimal_Type_Definition // an Access_Type_Definition // a Derived_Type_Definition // a Record_Type_Definition List_Id Discriminant_Spec; // Specifies the discriminant of the type boolean Is_Subtype; // Precise whether the type is a new type or a subtype }; /* Example : type T is (E1, E2, E3); */ interface Enumeration_Type_Definition : Node_Id { List_Id Enumeration_Literals; // A list of defining identifiers }; /* DECIMAL_FIXED_POINT_DEFINITION ::= delta SCALE digits TOTAL Example : type T is delta 0.1 digits 5; */ interface Decimal_Type_Definition : Node_Id { Node_Id Scale; Value_Id Total; }; /* Example : type T is access Obj; */ interface Access_Type_Definition : Node_Id { boolean Is_All; // If True then the "all" modifier is generated boolean Is_Constant; // If True then the "constant" modifier is generated boolean Is_Not_Null; // If True then a "not null" constraint is generated Node_Id Subtype_Indication; // The designated subtype }; /* Example : type T is new R with private; */ interface Derived_Type_Definition : Node_Id { boolean Is_Private_Extension; // If True, then "with private" generated boolean Is_Abstract_Type; // If True then "abstract" generated Node_Id Subtype_Indication; // The derived type Node_Id Record_Extension_Part; // Optional (No_Node for a derivation with no record extension definition) boolean Is_Subtype; // If True then a subtype definition, instead of a derived type definition, // is generated. }; /* Example : Type T is record F : Integer; end record; */ interface Record_Type_Definition : Node_Id{ boolean Is_Abstract_Type; // If True then generate abstract boolean Is_Tagged_Type; // If True then generate tagged boolean Is_Limited_Type; // If true then generate limited Node_Id Record_Definition; // The record definition }; /* Example : F : Integer := 1; (inside a record) */ interface Component_Declaration : Definition { // Defining_Identifier inherited from Definition Node_Id Subtype_Indication; // The component Type Node_Id Expression; // The component default value boolean Aliased_Present; // Whether the component is aliased or not }; interface Record_Definition : Node_Id { List_Id Component_List; // If No_List then "null record" generated }; /* Example: type T is array (1 .. 10, 2 .. 30) of Float; */ interface Array_Type_Definition : Node_Id { List_Id Range_Constraints; // The list of the range constraints Node_Id Component_Definition; // The array element type Node_Id Index_Definition; // The array index type }; interface String_Type_Definition : Definition { Node_Id Range_Constraint; }; /* FIRST .. LAST */ // ??? Should be rewritten in terms of a Range_Expression interface Range_Constraint : Node_Id { Node_Id First; Node_Id Last; }; /* The case of a variant record. The record component list contain only one element of kind Variant_Part */ interface Variant_Part : Node_Id { List_Id Variants; // The list of variants there variant as many as "when" clauses Node_Id Discriminant; // The discriminant of the Type }; interface Variant : Node_Id { List_Id Discrete_Choices; // The choices of the "when" clause Node_Id _Component; // The record component (Component_Declaration) // Why leading underscore??? }; /**************/ /* Aggregates */ /**************/ // 1 - RECORD_AGGREGATE ::= (RECORD_COMPONENT_ASSOCIATION_LIST) // 2 - EXTENSION_AGGREGATE ::= // (ANCESTOR_PART with RECORD_COMPONENT_ASSOCIATION_LIST) /* Example 1: (F1 => 2, F2 => "hello"); */ /* Example 2: (My_Record with F1 => 2, F2 => "hello"); */ interface Record_Aggregate : Node_Id { List_Id Component_Association_List; // A list of component associations Node_Id Ancestor_Part; // If present then we deal with an EXTENSION_AGGREGATE, else we // deal with a RECORD_AGGREGATE. }; interface Component_Association : Definition { // Defining_Identifier inherited from Definition Node_Id Expression; }; /**************/ /* Statements */ /**************/ /* Example : A_Block: Declare I : integer; begin I := I + 1; exception raise; end; */ interface Block_Statement : Definition { // Defining_Identifier inherited from Definition List_Id Declarative_Part; // The declarations between "declare" and "begin" (if any) List_Id Statements; // The statements between "begin" and "exception" or else "end" // (null; if No_List) List_Id Exception_Handler; // The statements between "exception" and "end" (if any) }; interface Elsif_Statement : Node_Id { Node_Id Condition; // The condition of the "elsif" (generally an Expression) List_Id Then_Statements; // (A list of statements) // The statements between "then" and "elsif" or else "else" // or else "end if" }; interface If_Statement : Node_Id { Node_Id Condition; // The condition of the "if" (generally an Expression) List_Id Then_Statements; // (A list of statements) // The statements between the "then" and "elsif" or else "else" // or else "end if" List_Id Elsif_Statements; // (A list of Elsif_Statement) List_Id Else_Statements; // (A list of statements) // The statements between "else" and "end if" (if any) }; /* Example: A := 1; */ interface Assignment_Statement : Definition { Node_Id Expression; }; /* Example: return Result; */ interface Return_Statement : Node_Id { Node_Id Expression; }; interface For_Statement : Definition { // Defining_Identifier inherited from Definition represents the loop index Node_Id Range_Constraint; // The range of the loop List_Id Statements; // The loop statements }; /* Example: when 1 | 3 | 27 => A := A + 2; */ interface Case_Statement_Alternative : Node_Id { List_Id Discret_Choice_List; // The choices of the "when" clause. If No_List then "others" is generated List_Id Statements; // Statements of the "when" clause }; interface Case_Statement : Node_Id { Node_Id Expression; // Switch of the case statement List_Id Case_Statement_Alternatives; // A Case_Statement_Alternative list }; /* Example; pragma Unreferenced (A, B, C); */ interface Pragma : Definition { // Defining_Identifier inherited from Definition List_Id Argument_List; // The Argument list of the pragma (if any) }; interface Null_Statement : Node_Id {}; // null; /***************/ /* Other nodes */ /***************/ interface Package_Instantiation : Definition { // Defining_Identifier inherited from Definition Node_Id Generic_Package; // A designator for the generic instantiated package List_Id Parameter_List; // The parameters of the Instantiation (if any) }; interface Raise_Statement : Node_Id { Node_Id Raised_Error; // The raised exception }; interface Ada_Comment : Node_Id { Name_Id Message; // The comment text boolean Has_Header_Spaces; // If True then do not generate the spaces between the "--" and // the comment. }; /****************/ /* Object nodes */ /****************/ /* Example: A : constant Integer := 2 * 3; */ interface Object_Declaration: Definition { // Defining_Identifier inherited from Definition boolean Constant_Present; // If True then generate "constant" boolean Aliased_Present; // If True then generate "aliased" Node_Id Object_Definition; // The object type Node_Id Expression; // The object default value (if any) Node_Id Renamed_Entity; // The renamed object (if any) }; interface Literal : Node_Id { Value_Id Value; // The Value of the literal }; /* Example : 1 => 3 */ interface Element_Association : Node_Id { Node_Id Index; Node_Id Expression; }; interface Array_Aggregate : Node_Id { List_Id Elements; // A list of literal or element associations }; // INDEXED_COMPONENT ::= PREFIX ( EXPRESSION { , EXPRESSION} ) // Example: Page (10) // Tab (1, 3) interface Indexed_Component : Node_Id { Node_Id Prefix; List_Id Expressions; }; // SLICE ::= PREFIX (DISCRETE_RANGE) interface Slice : Node_Id { Node_Id Prefix; Node_Id Discrete_Range; }; // RANGE ::= // RANGE_ATTRIBUTE_REFERENCE // | SIMPLE_EXPRESSION .. SIMPLE_EXPRESSION // Note: the case of a range given as a range attribute reference // appears directly in the tree as an attribute reference. interface Range : Node_Id { Node_Id Low_Bound; Node_Id High_Bound; }; interface Exception_Declaration : Definition { // Defining_Identifier inherited from Definition Node_Id Renamed_Entity; // The renamed exception (if any) }; /* The Node below is used to link the front end tree to the backend tree. It allows to link one frontend node to more than one backend node without modifying the frontend tree each time we add a new link. */ interface BE_Ada : Node_Id { Node_Id Stub_Node; Node_Id Impl_Node; Node_Id TC_Node; Node_Id From_Any_Container_Node; Node_Id From_Any_Node; Node_Id To_Any_Node; Node_Id Raise_Excp_Node; Node_Id Initialize_Node; Node_Id To_Ref_Node; Node_Id U_To_Ref_Node; Node_Id Type_Def_Node; Node_Id Forward_Node; Node_Id Instantiation_Node; Node_Id Unmarshaller_Node; Node_Id Marshaller_Node; Node_Id Args_In_Node; Node_Id Args_Out_Node; Node_Id Access_Args_Out_Node; Node_Id Buffer_Size_Node; Node_Id Ir_Function_Node; Node_Id Register_Ir_Info_Node; // Nodes useful for the Shadow Any Trees Node_Id Pointer_Type_Node; Node_Id Aggr_Container_Node; Node_Id Wrap_Node; Node_Id Element_Wrap_Node; Node_Id Clone_Node; Node_Id Finalize_Value_Node; Node_Id Get_Aggregate_Count_Node; Node_Id Set_Aggregate_Count_Node; Node_Id Get_Aggregate_Element_Node; Node_Id Set_Aggregate_Element_Node; Node_Id Unchecked_Get_V_Node; }; /* Example: A + B */ interface Expression : Node_Id { Operator_Id Operator; Node_Id Left_Expr; Node_Id Right_Expr; }; /* Qualified_Expression ::= Subtype_Mark'(Expression) | Subtype_Mark'Aggregate */ /* Example: Record_Type'(F1 => 1, F2 => "hello") CORBA.Long'(2) */ interface Qualified_Expression : Node_Id { Node_Id Subtype_Mark; // The type used in the expression Node_Id Operand; // Generally, a Record_Aggregate or and expression }; /* Type Casting */ interface Type_Conversion : Node_Id { Node_Id Subtype_Mark; // The type to which we Cast Node_Id Expression; // The expression being casted }; /* Example: new Record_Type'(F1 => 1, F2 => "hello") */ interface Object_Instantiation : Node_Id { Node_Id Qualified_Expression; // A Qualified_Expression or a designator for the Instantiated type }; /**************/ /* Base types */ /**************/ interface Base_Type { Name_Id Image; // Image of the base type }; interface _Float : Base_Type {}; interface _Double : Base_Type {}; interface Long_Double : Base_Type {}; interface _Short : Base_Type {}; interface _Long : Base_Type {}; interface Long_Long : Base_Type {}; interface Unsigned_Short : Base_Type {}; interface Unsigned_Long : Base_Type {}; interface Unsigned_Long_Long : Base_Type {}; interface _Char : Base_Type {}; interface Wide_Char : Base_Type {}; interface _String : Base_Type {}; interface Wide_String : Base_Type {}; interface _Boolean : Base_Type {}; interface _Octet : Base_Type {}; interface _Object : Base_Type {}; interface _Any : Base_Type {}; }; polyorb-2.8~20110207.orig/compilers/iac/usage.ads0000644000175000017500000000403011750740337020733 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- U S A G E -- -- -- -- S p e c -- -- -- -- Copyright (C) 2005-2007, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ procedure Usage; polyorb-2.8~20110207.orig/compilers/iac/mknodes.adb0000644000175000017500000015040711750740337021260 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- M K N O D E S -- -- -- -- B o d y -- -- -- -- Copyright (C) 2005-2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with Ada.Command_Line; use Ada.Command_Line; with GNAT.Command_Line; use GNAT.Command_Line; with GNAT.Table; with GNAT.OS_Lib; use GNAT.OS_Lib; with GNAT.Directory_Operations; with Errors; use Errors; with Flags; use Flags; with Lexer; use Lexer; with Locations; use Locations; with Namet; use Namet; with Output; use Output; with Outfiles; use Outfiles; with Types; use Types; procedure Mknodes is Debug : Boolean := False; Optimized : Boolean := False; function GNS (N : Name_Id) return String renames Get_Name_String; Module_Name : Name_Id; type Color_Type is new Int; No_Color : constant Color_Type := 0; type Declaration_Type is new Byte; Present : constant Declaration_Type := 0; Missing : constant Declaration_Type := 1; type Color_Array is array (Color_Type range <>) of Boolean; package Nodes is type Node_Kind is (K_Boolean, K_Octet, K_Long, K_Interface_Declaration, K_Typedef, K_Attribute, K_None); function New_Node (Kind : Node_Kind; Loc : Location) return Node_Id; function Kind (N : Node_Id) return Node_Kind; function Loc (N : Node_Id) return Location; function Identifier (N : Node_Id) return Name_Id; procedure Set_Identifier (N : Node_Id; V : Name_Id); function Type_Spec (N : Node_Id) return Node_Id; procedure Set_Type_Spec (N : Node_Id; V : Node_Id); function Scope_Entity (N : Node_Id) return Node_Id; procedure Set_Scope_Entity (N : Node_Id; V : Node_Id); function First_Entity (N : Node_Id) return Node_Id; procedure Set_First_Entity (N : Node_Id; V : Node_Id); function Last_Entity (N : Node_Id) return Node_Id; procedure Set_Last_Entity (N : Node_Id; V : Node_Id); function Next_Entity (N : Node_Id) return Node_Id; procedure Set_Next_Entity (N : Node_Id; V : Node_Id); private type Node_Type is record Kind : Node_Kind; Loc : Location; Identifier : Name_Id; Type_Spec : Node_Id; Scope_Entity : Node_Id; First_Entity : Node_Id; Last_Entity : Node_Id; Next_Entity : Node_Id; end record; Default_Node : constant Node_Type := (K_None, No_Location, No_Name, No_Node, No_Node, No_Node, No_Node, No_Node); package Entries is new GNAT.Table (Node_Type, Node_Id, No_Node + 1, 100, 10); end Nodes; use Nodes; Type_Prefix : constant String := "T "; Attr_Prefix : constant String := "A "; type Node_Array is array (Natural range <>) of Node_Id; Base_Types : array (K_Boolean .. K_Long) of Node_Id; -- Nodes corresponding for the Pseudo-IDL base types First_Attribute : Node_Id := No_Node; Last_Attribute : Node_Id := No_Node; N_Attributes : Natural := 0; First_Interface : Node_Id := No_Node; Last_Interface : Node_Id := No_Node; N_Interfaces : Natural := 0; procedure Add_Attribute_To_Interface (Attribute : Node_Id; Iface : Node_Id); -- Add attribute into interface using First_Entity, Last_Entity of -- Interfaces and Next_Entity of Attributes. function Is_Attribute_In_Interface (Attribute : Node_Id; Iface : Node_Id) return Boolean; -- Look for attribute through a depth exploration of the -- inheritance spec of interface. function Inheritance_Tree (I : Node_Id) return Node_Array; -- Return the inheritance tree. The oldest ancestors are -- first. The interface itself is last. function Has_Attribute (I : Node_Id) return Boolean; -- Return True when interface I has at least on attribute function Base_Kind (T : Node_Id) return Node_Kind; -- As interfaces are represented as Node_Id and as Node_Id is -- represented as a long integer, the base type of an interface is -- K_Long. For defined types, return the kind of T base type. function Color (N : Node_Id) return Color_Type; procedure Set_Color (N : Node_Id; V : Color_Type); -- To allocate a slot for an attribute in a base type array, we -- use classical coloration algorithm. The base types are also -- colored to store the greatest color used for them. function Declaration (N : Node_Id) return Declaration_Type; procedure Set_Declaration (N : Node_Id; V : Declaration_Type); -- To avoid multiple declarations in spec and body. procedure Assign_Color_To_Attribute (Attribute : Node_Id); -- Compute adjacent attributes that is attributes included in the -- same interfaces than Attribute. Then find a color not already -- assigned to these adjacent attributes. procedure Declare_Attribute (A : Node_Id); -- Declare an attribute A procedure Declare_Type (N : Node_Id); -- Declare a type N procedure Mark_As_Incompatible (A : Node_Id; B : Node_Id); -- Mark the attributes A and B as incomatible. Incompatible -- atribues are attributes belonging to a same -- interface. Therefore, they cannot have the same color. The -- order of passed parameters is with no importance for this -- procedure. function Are_Incompatible (A : Node_Id; B : Node_Id) return Boolean; -- Return True if the attribute A and B have been marked as -- incompatible. The order of passed parameters is with no -- importance for this function. function Resolve_Type (N : Name_Id) return Node_Id; -- Return a type of name N function P_Attribute return Node_Id; function P_Definition return Node_Id; function P_Interface return Node_Id; function P_Typedef return Node_Id; -- Parsing routines procedure W_Pragma_Assert (Attribute : Node_Id); procedure W_Attribute_Body (A : String; N : String; T : String); procedure W_Attribute_Spec (A : String; N : String; T : String); procedure W_Attribute_Body (A : Node_Id); procedure W_Attribute_Spec (A : Node_Id); procedure W_Indentation (N : Natural := 1); procedure W_Comment_Message; procedure W_Package_Body; procedure W_Package_Spec; procedure W_Subprogram_Call (I : Natural; F : String; PN1 : String := No_Str; PN2 : String := No_Str; PN3 : String := No_Str; PN4 : String := No_Str; PN5 : String := No_Str); procedure W_Subprogram_Signature (I : Natural; F : String; PN1 : Character; PT1 : String; PN2 : Character := ' '; PT2 : String := No_Str); procedure W_Subprogram_Declaration (I : Natural; F : String; PN1 : Character; PT1 : String; PN2 : Character := ' '; PT2 : String := No_Str); procedure W_Subprogram_Definition (I : Natural; F : String; PN1 : Character; PT1 : String; PN2 : Character := ' '; PT2 : String := No_Str); procedure W_Subprogram_Definition_End (I : Natural; F : String); procedure W_Table_Access (N : Character; A : String); procedure W_Type_Attribute (K : Node_Kind); procedure W_Type_Attribute (A : String; T : String); procedure W_With (P : String); -- Output routines (operating on current output stream) subtype String_3 is String (1 .. 3); function Output_File_Name (Source_File_Name : Name_Id; Extension : String_3) return Name_Id; -- Return Source_File_Name with trailing "idl" extension replaced with -- the indicated new extension. function Quote (S : String) return String; function Set (S : String) return String; function W (S : String) return String; -- Formatting routines package body Nodes is use Entries; ------------------ -- First_Entity -- ------------------ function First_Entity (N : Node_Id) return Node_Id is begin return Table (N).First_Entity; end First_Entity; ---------------- -- Identifier -- ---------------- function Identifier (N : Node_Id) return Name_Id is begin return Table (N).Identifier; end Identifier; ---------- -- Kind -- ---------- function Kind (N : Node_Id) return Node_Kind is begin return Table (N).Kind; end Kind; ----------------- -- Last_Entity -- ----------------- function Last_Entity (N : Node_Id) return Node_Id is begin return Table (N).Last_Entity; end Last_Entity; --------- -- Loc -- --------- function Loc (N : Node_Id) return Location is begin return Table (N).Loc; end Loc; -------------- -- New_Node -- -------------- function New_Node (Kind : Node_Kind; Loc : Location) return Node_Id is Node : Node_Id; begin Increment_Last; Node := Entries.Last; Table (Node) := Default_Node; Table (Node).Kind := Kind; Table (Node).Loc := Loc; return Node; end New_Node; ----------------- -- Next_Entity -- ----------------- function Next_Entity (N : Node_Id) return Node_Id is begin return Table (N).Next_Entity; end Next_Entity; ------------------ -- Scope_Entity -- ------------------ function Scope_Entity (N : Node_Id) return Node_Id is begin return Table (N).Scope_Entity; end Scope_Entity; ---------------------- -- Set_First_Entity -- ---------------------- procedure Set_First_Entity (N : Node_Id; V : Node_Id) is begin Table (N).First_Entity := V; end Set_First_Entity; -------------------- -- Set_Identifier -- -------------------- procedure Set_Identifier (N : Node_Id; V : Name_Id) is begin Table (N).Identifier := V; end Set_Identifier; --------------------- -- Set_Last_Entity -- --------------------- procedure Set_Last_Entity (N : Node_Id; V : Node_Id) is begin Table (N).Last_Entity := V; end Set_Last_Entity; --------------------- -- Set_Next_Entity -- --------------------- procedure Set_Next_Entity (N : Node_Id; V : Node_Id) is begin Table (N).Next_Entity := V; end Set_Next_Entity; ---------------------- -- Set_Scope_Entity -- ---------------------- procedure Set_Scope_Entity (N : Node_Id; V : Node_Id) is begin Table (N).Scope_Entity := V; end Set_Scope_Entity; ------------------- -- Set_Type_Spec -- ------------------- procedure Set_Type_Spec (N : Node_Id; V : Node_Id) is begin Table (N).Type_Spec := V; end Set_Type_Spec; --------------- -- Type_Spec -- --------------- function Type_Spec (N : Node_Id) return Node_Id is begin return Table (N).Type_Spec; end Type_Spec; end Nodes; -------------------------------- -- Add_Attribute_To_Interface -- -------------------------------- procedure Add_Attribute_To_Interface (Attribute : Node_Id; Iface : Node_Id) is begin -- Attribute nodes are contiguous. There is no need to chain them if First_Entity (Iface) = No_Node then Set_First_Entity (Iface, Attribute); end if; Set_Last_Entity (Iface, Attribute); end Add_Attribute_To_Interface; ---------------------- -- Are_Incompatible -- ---------------------- function Are_Incompatible (A : Node_Id; B : Node_Id) return Boolean is Name_A : constant Name_Id := Identifier (A); Name_B : constant Name_Id := Identifier (B); begin Set_Str_To_Name_Buffer (Attr_Prefix); Get_Name_String_And_Append (Name_A); Add_Char_To_Name_Buffer (' '); Get_Name_String_And_Append (Name_B); if Get_Name_Table_Byte (Name_Find) = 1 then return True; end if; Set_Str_To_Name_Buffer (Attr_Prefix); Get_Name_String_And_Append (Name_B); Add_Char_To_Name_Buffer (' '); Get_Name_String_And_Append (Name_A); if Get_Name_Table_Byte (Name_Find) = 1 then return True; end if; return False; end Are_Incompatible; ------------------------------- -- Assign_Color_To_Attribute -- ------------------------------- procedure Assign_Color_To_Attribute (Attribute : Node_Id) is Kind : constant Node_Kind := Base_Kind (Type_Spec (Attribute)); Used : Color_Array (No_Color .. Color_Type (N_Attributes)); Attr : Node_Id; Name : constant Name_Id := Identifier (Attribute); Intf : Node_Id; begin if Debug then Write_Str ("-- Assign color to "); Write_Name (Identifier (Attribute)); Write_Eol; end if; Used := (others => False); Attr := First_Attribute; while Attr /= No_Node loop if Identifier (Attr) = Name then Intf := Scope_Entity (Attr); if Debug then Write_Str ("-- Found attribute in "); Write_Name (Identifier (Intf)); Write_Eol; end if; while Intf /= No_Node loop -- Mark adjacent attributes as incompatible. Attribute -- A2 is adjacent to attribute A1 when A2 and A1 -- belong to a common interface. To do this we must: -- 1 - Traverse the list of the parent interfaces and -- get all the attributes of these parents. -- 2 - Traverse the list of all the child interfaces -- and get all the attributes of these children. -- However this kind of traversal is very complex to -- perform because the child interfaces do not form a -- list but a tree. We use the following workaround -- that has the same effect: each time we find a -- couple of incompatible attributes, we mark this -- couple. if Has_Attribute (Intf) then for Neighbor in First_Entity (Intf) .. Last_Entity (Intf) loop -- Mark the two attributes as incompatible Mark_As_Incompatible (Attribute, Neighbor); end loop; end if; Intf := Type_Spec (Intf); end loop; end if; Attr := Next_Entity (Attr); end loop; -- Second pass to complete the work. We search all the -- attributes that are incompatible with `Attribute' and we set -- their color as used. Note that the number of such attributes -- is *greater than* or eaqual the number of attributes marked -- in the previous phase. It could be greater beacause -- attributes belonging to child interfaces could be handled -- before `Attribute'. Attr := First_Attribute; while Attr /= No_Node loop if Are_Incompatible (Attribute, Attr) then if Debug then Write_Str ("-- Conflict with "); Write_Name (Identifier (Attr)); Write_Str (" from "); Write_Name (Identifier (Scope_Entity (Attr))); Write_Str (" "); Write_Int (Int (Color (Attr))); Write_Eol; end if; Used (Color (Attr)) := True; end if; Attr := Next_Entity (Attr); end loop; -- Find a color not used by adjacent attributes for C in No_Color + 1 .. Used'Last loop if not Used (C) then Set_Color (Attribute, C); if Color (Base_Types (Kind)) < C then Set_Color (Base_Types (Kind), C); end if; if Debug then Write_Str ("-- Decide to assign "); Write_Int (Int (C)); Write_Str (" to "); Write_Name (Identifier (Attribute)); Write_Eol; end if; exit; end if; end loop; end Assign_Color_To_Attribute; --------------- -- Base_Kind -- --------------- function Base_Kind (T : Node_Id) return Node_Kind is begin case Kind (T) is when K_Interface_Declaration => return K_Long; when K_Boolean .. K_Long => return Kind (T); when K_Typedef => return Base_Kind (Type_Spec (T)); when others => raise Program_Error; end case; end Base_Kind; ----------- -- Color -- ----------- function Color (N : Node_Id) return Color_Type is begin return Color_Type (Get_Name_Table_Info (Identifier (N))); end Color; ----------------- -- Declaration -- ----------------- function Declaration (N : Node_Id) return Declaration_Type is begin return Declaration_Type (Get_Name_Table_Byte (Identifier (N))); end Declaration; ----------------------- -- Declare_Attribute -- ----------------------- procedure Declare_Attribute (A : Node_Id) is Type_Name : constant Name_Id := Identifier (Type_Spec (A)); Attr_Name : constant Name_Id := Identifier (A); Attribute : Node_Id; begin Attribute := First_Attribute; while Attribute /= No_Node loop if Identifier (Attribute) = Attr_Name then if Identifier (Type_Spec (Attribute)) /= Type_Name then Error_Loc (1) := Loc (A); DE ("attribute type inconsistency"); return; end if; end if; Attribute := Next_Entity (Attribute); end loop; if First_Attribute = No_Node then First_Attribute := A; end if; if Last_Attribute /= No_Node then Set_Next_Entity (Last_Attribute, A); end if; Last_Attribute := A; N_Attributes := N_Attributes + 1; end Declare_Attribute; ------------------ -- Declare_Type -- ------------------ procedure Declare_Type (N : Node_Id) is begin Set_Str_To_Name_Buffer (Type_Prefix); case Kind (N) is when K_Boolean => Add_Str_To_Name_Buffer (Image (T_Boolean)); when K_Octet => Add_Str_To_Name_Buffer (Image (T_Octet)); when K_Long => Add_Str_To_Name_Buffer (Image (T_Long)); when others => Get_Name_String_And_Append (Identifier (N)); end case; Set_Name_Table_Info (Name_Find, Int (N)); case Kind (N) is when K_Boolean => Set_Str_To_Name_Buffer ("Boolean"); Set_Identifier (N, Name_Find); when K_Octet => Set_Str_To_Name_Buffer ("Byte"); Set_Identifier (N, Name_Find); when K_Long => Set_Str_To_Name_Buffer ("Int"); Set_Identifier (N, Name_Find); when others => null; end case; end Declare_Type; ------------------- -- Has_Attribute -- ------------------- function Has_Attribute (I : Node_Id) return Boolean is begin return First_Entity (I) /= No_Node; end Has_Attribute; ---------------------- -- Inheritance_Tree -- ---------------------- function Inheritance_Tree (I : Node_Id) return Node_Array is Depth : Natural := 0; Parent : Node_Id; begin pragma Assert (Kind (I) = K_Interface_Declaration); Parent := I; while Parent /= No_Node loop Depth := Depth + 1; Parent := Type_Spec (Parent); end loop; declare Tree : Node_Array (1 .. Depth); begin Parent := I; for D in reverse Tree'Range loop Tree (D) := Parent; Parent := Type_Spec (Parent); end loop; return Tree; end; end Inheritance_Tree; ------------------------------- -- Is_Attribute_In_Interface -- ------------------------------- function Is_Attribute_In_Interface (Attribute : Node_Id; Iface : Node_Id) return Boolean is N : constant Name_Id := Identifier (Attribute); I : Node_Id := Iface; begin while I /= No_Node loop if Has_Attribute (I) then for A in First_Entity (I) .. Last_Entity (I) loop if Identifier (A) = N then return True; end if; end loop; end if; I := Type_Spec (I); end loop; return False; end Is_Attribute_In_Interface; -------------------------- -- Mark_As_Incompatible -- -------------------------- procedure Mark_As_Incompatible (A : Node_Id; B : Node_Id) is Name_A : constant Name_Id := Identifier (A); Name_B : constant Name_Id := Identifier (B); begin Set_Str_To_Name_Buffer (Attr_Prefix); Get_Name_String_And_Append (Name_A); Add_Char_To_Name_Buffer (' '); Get_Name_String_And_Append (Name_B); Set_Name_Table_Byte (Name_Find, 1); Set_Str_To_Name_Buffer (Attr_Prefix); Get_Name_String_And_Append (Name_B); Add_Char_To_Name_Buffer (' '); Get_Name_String_And_Append (Name_A); Set_Name_Table_Byte (Name_Find, 1); end Mark_As_Incompatible; ---------------------- -- Output_File_Name -- ---------------------- function Output_File_Name (Source_File_Name : Name_Id; Extension : String_3) return Name_Id is begin Get_Name_String (Source_File_Name); declare Base_Name : constant String := GNAT.Directory_Operations.Base_Name (Path => Name_Buffer (1 .. Name_Len), Suffix => "idl"); begin Name_Len := Base_Name'Length + 3; Name_Buffer (1 .. Base_Name'Length) := Base_Name; Name_Buffer (Base_Name'Length + 1 .. Name_Len) := Extension; end; return Name_Find; end Output_File_Name; ----------------- -- P_Attribute -- ----------------- function P_Attribute return Node_Id is Attribute : Node_Id; Type_Spec : Node_Id; begin -- Parse type specifier Scan_Token; Type_Spec := Resolve_Type (Token_Name); if Type_Spec = No_Node then Error_Loc (1) := Token_Location; DE ("unknown type"); return No_Node; end if; Attribute := New_Node (K_Attribute, Token_Location); Set_Type_Spec (Attribute, Type_Spec); -- Parse identifier Scan_Token (T_Identifier); if Token = T_Error then return No_Node; end if; Set_Identifier (Attribute, Token_Name); Declare_Attribute (Attribute); Scan_Token (T_Semi_Colon); if Token = T_Error then return No_Node; end if; return Attribute; end P_Attribute; ------------------ -- P_Definition -- ------------------ function P_Definition return Node_Id is Definition : Node_Id := No_Node; State : Location; begin Save_Lexer (State); Scan_Token ((T_Typedef, T_Interface)); case Token is when T_Typedef => Restore_Lexer (State); Definition := P_Typedef; when T_Interface => Restore_Lexer (State); Definition := P_Interface; when others => null; end case; if Definition /= No_Node then Save_Lexer (State); Scan_Token (T_Semi_Colon); if Token /= T_Semi_Colon then Definition := No_Node; end if; end if; if Definition = No_Node then Restore_Lexer (State); Skip_Declaration (T_Semi_Colon); end if; return Definition; end P_Definition; ----------------- -- P_Interface -- ----------------- function P_Interface return Node_Id is Iface : Node_Id; Attribute : Node_Id; Type_Spec : Node_Id; begin Scan_Token; -- past "interface" Iface := New_Node (K_Interface_Declaration, Token_Location); -- Parse identifier Scan_Token (T_Identifier); if Token = T_Error then return No_Node; end if; Set_Identifier (Iface, Token_Name); if Resolve_Type (Identifier (Iface)) /= No_Node then Error_Loc (1) := Token_Location; DE ("interface already defined"); return No_Node; end if; if First_Interface = No_Node then First_Interface := Iface; end if; if Last_Interface /= No_Node then Set_Next_Entity (Last_Interface, Iface); end if; Last_Interface := Iface; N_Interfaces := N_Interfaces + 1; Scan_Token ((T_Left_Brace, T_Colon)); if Token = T_Error then return No_Node; end if; if Token = T_Colon then -- Parse interface inheritance spec Scan_Token (T_Identifier); if Token = T_Error then return No_Node; end if; Type_Spec := Resolve_Type (Token_Name); if Type_Spec = No_Node or else Kind (Type_Spec) /= K_Interface_Declaration then Error_Loc (1) := Token_Location; DE ("unknown interface"); return No_Node; end if; Set_Type_Spec (Iface, Type_Spec); Scan_Token (T_Left_Brace); if Token = T_Error then return No_Node; end if; end if; Declare_Type (Iface); loop case Next_Token is when T_Identifier | T_Boolean | T_Octet | T_Long => Attribute := P_Attribute; if Is_Attribute_In_Interface (Attribute, Iface) then Error_Loc (1) := Loc (Attribute); DE ("attribute already defined"); return No_Node; end if; Set_Scope_Entity (Attribute, Iface); Add_Attribute_To_Interface (Attribute, Iface); when T_Right_Brace => Scan_Token; exit; when others => return No_Node; end case; end loop; return Iface; end P_Interface; --------------- -- P_Typedef -- --------------- function P_Typedef return Node_Id is Type_Spec : Node_Id; Type_Decl : Node_Id; begin Scan_Token; -- past "typedef" Type_Decl := New_Node (K_Typedef, Token_Location); -- Parse type spec Scan_Token ((T_Identifier, T_Boolean, T_Octet, T_Long)); if Token = T_Error then return No_Node; end if; Type_Spec := Resolve_Type (Token_Name); if Type_Spec = No_Node then Error_Loc (1) := Token_Location; DE ("unknown type"); return No_Node; end if; Set_Type_Spec (Type_Decl, Type_Spec); -- Parse identifier Scan_Token (T_Identifier); if Token = T_Error then return No_Node; end if; Set_Identifier (Type_Decl, Token_Name); if Resolve_Type (Identifier (Type_Decl)) /= No_Node then Error_Loc (1) := Token_Location; DE ("type already defined"); return No_Node; end if; Declare_Type (Type_Decl); return Type_Decl; end P_Typedef; ----------- -- Quote -- ----------- function Quote (S : String) return String is begin return """" & S & """"; end Quote; ------------------ -- Resolve_Type -- ------------------ function Resolve_Type (N : Name_Id) return Node_Id is Result : Node_Id; begin Set_Str_To_Name_Buffer (Type_Prefix); Get_Name_String_And_Append (N); Result := Node_Id (Get_Name_Table_Info (Name_Find)); if Result = No_Node or else Kind (Result) = K_Attribute then return No_Node; end if; return Result; end Resolve_Type; --------- -- Set -- --------- function Set (S : String) return String is begin return "Set_" & S; end Set; --------------- -- Set_Color -- --------------- procedure Set_Color (N : Node_Id; V : Color_Type) is begin Set_Name_Table_Info (Identifier (N), Int (V)); end Set_Color; --------------------- -- Set_Declaration -- --------------------- procedure Set_Declaration (N : Node_Id; V : Declaration_Type) is begin Set_Name_Table_Byte (Identifier (N), Byte (V)); end Set_Declaration; ------- -- W -- ------- function W (S : String) return String is begin return "W_" & S; end W; ---------------------- -- W_Attribute_Body -- ---------------------- procedure W_Attribute_Body (A : Node_Id) is K : Node_Kind; NS : Node_Id; begin NS := Scope_Entity (A); while Type_Spec (NS) /= No_Node loop NS := Type_Spec (NS); end loop; K := Base_Kind (Type_Spec (A)); W_Subprogram_Definition (1, GNS (Identifier (A)), 'N', GNS (Identifier (NS)), ' ', GNS (Identifier (Type_Spec (A)))); W_Pragma_Assert (A); W_Indentation (2); Write_Str ("return "); Write_Name (Identifier (Type_Spec (A))); Write_Str (" ("); Set_Char_To_Name_Buffer (Node_Kind'Image (K) (3)); Add_Str_To_Name_Buffer (" ("); Add_Nat_To_Name_Buffer (Int (Color (A))); Add_Char_To_Name_Buffer (')'); W_Table_Access ('N', GNS (Name_Find)); Write_Line (");"); W_Subprogram_Definition_End (1, GNS (Identifier (A))); Write_Eol; W_Subprogram_Definition (1, Set (GNS (Identifier (A))), 'N', GNS (Identifier (NS)), 'V', GNS (Identifier (Type_Spec (A)))); W_Pragma_Assert (A); W_Indentation (2); Set_Char_To_Name_Buffer (Node_Kind'Image (K)(3)); Add_Str_To_Name_Buffer (" ("); Add_Nat_To_Name_Buffer (Int (Color (A))); Add_Char_To_Name_Buffer (')'); W_Table_Access ('N', GNS (Name_Find)); Write_Str (" := "); Write_Name (Identifier (Base_Types (K))); Write_Line (" (V);"); W_Subprogram_Definition_End (1, Set (GNS (Identifier (A)))); Write_Eol; end W_Attribute_Body; ---------------------- -- W_Attribute_Body -- ---------------------- procedure W_Attribute_Body (A : String; N : String; T : String) is begin W_Subprogram_Definition (1, A, 'N', N, ' ', T); W_Indentation (2); Write_Str ("return "); W_Table_Access ('N', A); Write_Line (";"); W_Subprogram_Definition_End (1, A); Write_Eol; W_Subprogram_Definition (1, Set (A), 'N', N, 'V', T); W_Indentation (2); W_Table_Access ('N', A); Write_Line (" := V;"); W_Subprogram_Definition_End (1, Set (A)); Write_Eol; end W_Attribute_Body; ---------------------- -- W_Attribute_Spec -- ---------------------- procedure W_Attribute_Spec (A : Node_Id) is NS : Node_Id; begin NS := Scope_Entity (A); while Type_Spec (NS) /= No_Node loop NS := Type_Spec (NS); end loop; W_Attribute_Spec (GNS (Identifier (A)), GNS (Identifier (NS)), GNS (Identifier (Type_Spec (A)))); end W_Attribute_Spec; ---------------------- -- W_Attribute_Spec -- ---------------------- procedure W_Attribute_Spec (A : String; N : String; T : String) is begin W_Subprogram_Declaration (1, A, 'N', N, ' ', T); W_Subprogram_Declaration (1, Set (A), 'N', N, 'V', T); end W_Attribute_Spec; ----------------------- -- W_Comment_Message -- ----------------------- procedure W_Comment_Message is begin Write_Line ("-- This file has been generated automatically" & " by `mknodes'. Do not"); Write_Line ("-- hand modify this file since your changes" & " will be overridden."); Write_Eol; end W_Comment_Message; ------------------- -- W_Indentation -- ------------------- procedure W_Indentation (N : Natural := 1) is begin for I in 1 .. N loop Write_Str (" "); end loop; end W_Indentation; -------------------- -- W_Package_Body -- -------------------- procedure W_Package_Body is Attribute : Node_Id; Iface : Node_Id; Base_Type : Node_Id; begin W_Comment_Message; Get_Name_String (Module_Name); Name_Buffer (Name_Len - 4 .. Name_Len) := "Debug"; W_With (Name_Buffer (1 .. Name_Len)); Write_Eol; Write_Str ("package body "); Write_Name (Module_Name); Write_Line (" is"); Write_Eol; W_Indentation; Write_Line ("pragma Warnings (Off);"); W_Indentation; Write_Line ("use Entries;"); Write_Eol; W_Attribute_Body ("Kind", "Node_Id", "Node_Kind"); W_Attribute_Body ("Loc", "Node_Id", "Location"); Attribute := First_Attribute; while Attribute /= No_Node loop Set_Declaration (Attribute, Missing); Attribute := Next_Entity (Attribute); end loop; Attribute := First_Attribute; while Attribute /= No_Node loop if Declaration (Attribute) = Missing then W_Attribute_Body (Attribute); Set_Declaration (Attribute, Present); end if; Attribute := Next_Entity (Attribute); end loop; W_Subprogram_Definition (1, W ("Node"), 'N', "Node_Id"); W_Indentation (2); if Optimized then Write_Line ("null;"); else Write_Line ("case Kind (N) is"); Iface := First_Interface; while Iface /= No_Node loop if Type_Spec (Iface) /= No_Node then W_Indentation (3); Write_Str ("when K_"); Write_Name (Identifier (Iface)); Write_Line (" =>"); Base_Type := Iface; while Type_Spec (Base_Type) /= No_Node loop Base_Type := Type_Spec (Base_Type); end loop; W_Subprogram_Call (4, W (GNS (Identifier (Iface))), GNS (Identifier (Base_Type)) & " (N)"); end if; Iface := Next_Entity (Iface); end loop; W_Indentation (3); Write_Line ("when others =>"); W_Indentation (4); Write_Line ("null;"); W_Indentation (2); Write_Line ("end case;"); end if; W_Subprogram_Definition_End (1, W ("Node")); Write_Eol; if not Optimized then Iface := First_Interface; while Iface /= No_Node loop if Type_Spec (Iface) /= No_Node then Base_Type := Iface; while Type_Spec (Base_Type) /= No_Node loop Base_Type := Type_Spec (Base_Type); end loop; W_Subprogram_Definition (1, W (GNS (Identifier (Iface))), 'N', GNS (Identifier (Base_Type))); W_Subprogram_Call (2, W ("Node_Header"), "Node_Id (N)"); Attribute := First_Attribute; while Attribute /= No_Node loop Set_Declaration (Attribute, Missing); Attribute := Next_Entity (Attribute); end loop; Attribute := First_Attribute; while Attribute /= No_Node loop if Declaration (Attribute) = Missing and then Is_Attribute_In_Interface (Attribute, Iface) then if Kind (Type_Spec (Attribute)) = K_Interface_Declaration then W_Subprogram_Call (2, W ("Node_Attribute"), Quote (GNS (Identifier (Attribute))), Quote (GNS (Identifier (Type_Spec (Attribute)))), "Image (" & GNS (Identifier (Attribute)) & " (N))", "Int (" & GNS (Identifier (Attribute)) & " (N))"); else W_Subprogram_Call (2, W ("Node_Attribute"), Quote (GNS (Identifier (Attribute))), Quote (GNS (Identifier (Type_Spec (Attribute)))), "Image (" & GNS (Identifier (Attribute)) & " (N))"); end if; Set_Declaration (Attribute, Present); end if; Attribute := Next_Entity (Attribute); end loop; W_Subprogram_Definition_End (1, W (GNS (Identifier (Iface)))); Write_Eol; end if; Iface := Next_Entity (Iface); end loop; end if; Write_Str ("end "); Write_Name (Module_Name); Write_Line (";"); end W_Package_Body; -------------------- -- W_Package_Spec -- -------------------- procedure W_Package_Spec is Iface : Node_Id; Attribute : Node_Id; begin W_Comment_Message; Write_Line ("with GNAT.Table;"); -- The packages Locations and Types may have been included by a -- parent package of the generated package (or may not). We -- disable a warning generated when enabling the GNAT style -- checks. Write_Line ("pragma Warnings (Off);"); Write_Line ("with Locations; use Locations;"); Write_Line ("with Types; use Types;"); Write_Line ("pragma Warnings (On);"); Write_Eol; Write_Str ("package "); Write_Name (Module_Name); Write_Line (" is"); Write_Eol; -- Describe Node_Kind type (all interfaces) W_Indentation; Write_Line ("type Node_Kind is"); W_Indentation; Write_Str (" ("); Iface := First_Interface; while Iface /= No_Node loop Write_Str ("K_"); Write_Name (Identifier (Iface)); if Iface = Last_Interface then Write_Line (");"); else Write_Line (","); W_Indentation (2); end if; Iface := Next_Entity (Iface); end loop; Write_Eol; -- Describe interface attributes Iface := First_Interface; while Iface /= No_Node loop -- Output a description of interface W_Indentation; Write_Line ("--"); W_Indentation; Write_Str ("-- "); Write_Name (Identifier (Iface)); Write_Eol; W_Indentation; Write_Line ("--"); declare Tree : constant Node_Array := Inheritance_Tree (Iface); begin for I in Tree'Range loop if Has_Attribute (Tree (I)) then for A in First_Entity (Tree (I)) .. Last_Entity (Tree (I)) loop W_Indentation; Write_Str ("-- "); Get_Name_String (Identifier (A)); Name_Buffer (Name_Len + 1 .. 25) := (others => ' '); Write_Str (Name_Buffer (1 .. 25)); Write_Str (": "); Write_Name (Identifier (Type_Spec (A))); Write_Eol; end loop; end if; end loop; W_Indentation; Write_Line ("--"); Write_Eol; -- Output signature of interface output when this is not -- a basic interface. if not Optimized then if Tree'Length > 1 then W_Subprogram_Declaration (1, W (GNS (Identifier (Iface))), 'N', GNS (Identifier (Tree (Tree'First)))); Write_Eol; end if; end if; end; Iface := Next_Entity (Iface); end loop; -- Describe attribute accessors W_Attribute_Spec ("Kind", "Node_Id", "Node_Kind"); Write_Eol; W_Attribute_Spec ("Loc", "Node_Id", "Location"); Write_Eol; Attribute := First_Attribute; while Attribute /= No_Node loop Set_Declaration (Attribute, Missing); Attribute := Next_Entity (Attribute); end loop; Attribute := First_Attribute; while Attribute /= No_Node loop if Declaration (Attribute) = Missing then W_Attribute_Spec (Attribute); Write_Eol; Set_Declaration (Attribute, Present); end if; Attribute := Next_Entity (Attribute); end loop; W_Subprogram_Declaration (1, W ("Node"), 'N', "Node_Id"); Write_Eol; -- Describe slot table types for K in K_Boolean .. K_Long loop W_Indentation (1); Write_Str ("type "); Write_Name (Identifier (Base_Types (K))); Write_Str ("_Array is array (1 .. "); Write_Int (Int (Color (Base_Types (K)))); Write_Str (") of "); Write_Name (Identifier (Base_Types (K))); Write_Line (";"); end loop; Write_Eol; -- Describe Node_Entry type and its attributes W_Indentation; Write_Line ("type Node_Entry is record"); W_Type_Attribute ("Kind", "Node_Kind"); for K in K_Boolean .. K_Long loop if Color (Base_Types (K)) > 0 then W_Type_Attribute (K); end if; end loop; W_Type_Attribute ("Loc", "Location"); W_Indentation; Write_Line ("end record;"); Write_Eol; -- Provide a default node W_Indentation; Write_Line ("Default_Node : constant Node_Entry :="); W_Indentation; Write_Line (" (Node_Kind'First,"); for K in K_Boolean .. K_Long loop if Color (Base_Types (K)) > 0 then W_Indentation (2); Write_Str ("(others => "); if K = K_Boolean then Write_Str ("False"); else Write_Int (0); end if; Write_Line ("),"); end if; end loop; W_Indentation (2); Write_Line ("No_Location);"); Write_Eol; -- Provide node table W_Indentation; Write_Line ("package Entries is new GNAT.Table"); W_Indentation; Write_Line (" (Node_Entry, Node_Id, No_Node + 1, 1000, 100);"); Write_Eol; Write_Str ("end "); Write_Name (Module_Name); Write_Line (";"); end W_Package_Spec; --------------------- -- W_Pragma_Assert -- --------------------- procedure W_Pragma_Assert (Attribute : Node_Id) is Iface : Node_Id; begin W_Indentation (2); Write_Str ("pragma Assert (False"); Iface := First_Interface; while Iface /= No_Node loop if Is_Attribute_In_Interface (Attribute, Iface) then Write_Eol; W_Indentation (2); Write_Str (" or else "); W_Table_Access ('N', "Kind"); Write_Str (" = K_"); Write_Name (Identifier (Iface)); end if; Iface := Next_Entity (Iface); end loop; Write_Line (");"); Write_Eol; end W_Pragma_Assert; ----------------------- -- W_Subprogram_Call -- ----------------------- procedure W_Subprogram_Call (I : Natural; F : String; PN1 : String := No_Str; PN2 : String := No_Str; PN3 : String := No_Str; PN4 : String := No_Str; PN5 : String := No_Str) is begin W_Indentation (I); Write_Line (F); if PN1 /= No_Str then W_Indentation (I); Write_Str (" ("); Write_Str (PN1); end if; if PN2 /= No_Str then Write_Line (","); W_Indentation (I + 1); Write_Str (PN2); end if; if PN3 /= No_Str then Write_Line (","); W_Indentation (I + 1); Write_Str (PN3); end if; if PN4 /= No_Str then Write_Line (","); W_Indentation (I + 1); Write_Str (PN4); end if; if PN5 /= No_Str then Write_Line (","); W_Indentation (I + 1); Write_Str (PN5); end if; Write_Line (");"); end W_Subprogram_Call; ------------------------------ -- W_Subprogram_Declaration -- ------------------------------ procedure W_Subprogram_Declaration (I : Natural; F : String; PN1 : Character; PT1 : String; PN2 : Character := ' '; PT2 : String := No_Str) is begin W_Subprogram_Signature (I, F, PN1, PT1, PN2, PT2); Write_Line (";"); end W_Subprogram_Declaration; ----------------------------- -- W_Subprogram_Definition -- ----------------------------- procedure W_Subprogram_Definition (I : Natural; F : String; PN1 : Character; PT1 : String; PN2 : Character := ' '; PT2 : String := No_Str) is begin W_Subprogram_Signature (I, F, PN1, PT1, PN2, PT2); Write_Line (" is"); W_Indentation (I); Write_Line ("begin"); end W_Subprogram_Definition; --------------------------------- -- W_Subprogram_Definition_End -- --------------------------------- procedure W_Subprogram_Definition_End (I : Natural; F : String) is begin W_Indentation (I); Write_Line ("end " & F & ";"); end W_Subprogram_Definition_End; ---------------------------- -- W_Subprogram_Signature -- ---------------------------- procedure W_Subprogram_Signature (I : Natural; F : String; PN1 : Character; PT1 : String; PN2 : Character := ' '; PT2 : String := No_Str) is begin W_Indentation (I); if PN2 = ' ' and then PT2 /= No_Str then Write_Str ("function"); else Write_Str ("procedure"); end if; Write_Str (" "); Write_Str (F); Write_Str (" ("); Write_Char (PN1); Write_Str (" : "); Write_Str (PT1); if PT2 = No_Str then Write_Char (')'); return; end if; if PN2 = ' ' then Write_Str (") return "); Write_Str (PT2); else Write_Str ("; "); Write_Char (PN2); Write_Str (" : "); Write_Str (PT2); Write_Char (')'); end if; end W_Subprogram_Signature; -------------------- -- W_Table_Access -- -------------------- procedure W_Table_Access (N : Character; A : String) is begin Write_Str ("Table (Node_Id ("); Write_Char (N); Write_Str ("))."); Write_Str (A); end W_Table_Access; ---------------------- -- W_Type_Attribute -- ---------------------- procedure W_Type_Attribute (A : String; T : String) is begin W_Indentation (2); Write_Str (A); Write_Str (" : "); Write_Str (T); Write_Line (";"); end W_Type_Attribute; ---------------------- -- W_Type_Attribute -- ---------------------- procedure W_Type_Attribute (K : Node_Kind) is begin W_Indentation (2); Set_Str_To_Name_Buffer (Node_Kind'Image (K)); Write_Char (Name_Buffer (3)); Write_Str (" : "); Write_Name (Identifier (Base_Types (K))); Write_Line ("_Array;"); end W_Type_Attribute; ------------ -- W_With -- ------------ procedure W_With (P : String) is begin Write_Line ("with " & P & "; use " & P & ";"); end W_With; Source_File_Name : Name_Id; Source_File : File_Descriptor; Attribute : Node_Id; Definition : Node_Id; pragma Unreferenced (Definition); -- Because never read begin -- Initialization step Namet.Initialize; loop case Getopt ("d O p") is when 'd' => Debug := True; when 'O' => Optimized := True; when 'p' => Use_Stdout := True; when ASCII.NUL => exit; when others => raise Program_Error; end case; end loop; Set_Str_To_Name_Buffer (Get_Argument); if Name_Len = 0 then DE ("no file name"); return; end if; Source_File_Name := Name_Find; if not Is_Regular_File (Name_Buffer (1 .. Name_Len)) then Add_Str_To_Name_Buffer (".idl"); if Is_Regular_File (Name_Buffer (1 .. Name_Len)) then Source_File_Name := Name_Find; else Error_Name (1) := Source_File_Name; DE ("% not found"); return; end if; end if; Get_Name_String (Source_File_Name); if Name_Len < 4 or else Name_Buffer (Name_Len - 3 .. Name_Len) /= ".idl" then DE ("source file name must end with "".idl"""); return; end if; Name_Buffer (Name_Len + 1) := ASCII.NUL; Source_File := Open_Read (Name_Buffer'Address, Binary); -- Lexer step Lexer.Process (Source_File, Source_File_Name); for T in Base_Types'Range loop Base_Types (T) := New_Node (T, Token_Location); Declare_Type (Base_Types (T)); end loop; Scan_Token (T_Module); if Token = T_Error then return; end if; Scan_Token (T_Identifier); if Token = T_Error then return; end if; Module_Name := Token_Name; while Next_Token = T_Colon_Colon loop Scan_Token; Scan_Token (T_Identifier); Get_Name_String (Module_Name); Add_Char_To_Name_Buffer ('.'); Get_Name_String_And_Append (Token_Name); Module_Name := Name_Find; end loop; Scan_Token (T_Left_Brace); if Token = T_Error then return; end if; loop case Next_Token is when T_Right_Brace => Scan_Token; exit; when T_EOF => exit; when others => Definition := P_Definition; end case; end loop; Scan_Token (T_Semi_Colon); if N_Errors > 0 then Error_Int (1) := N_Errors; Error_Int (2) := N_Warnings; if N_Warnings > 0 then DE ("$ error(s) and $ warning(s)"); else DE ("$ error(s)"); end if; Set_Exit_Status (Failure); return; elsif N_Warnings > 0 then Error_Int (1) := N_Warnings; DE ("$ warning(s)"); end if; Attribute := First_Attribute; while Attribute /= No_Node loop Set_Color (Attribute, No_Color); Attribute := Next_Entity (Attribute); end loop; for K in K_Boolean .. K_Long loop Set_Color (Base_Types (K), No_Color); Attribute := First_Attribute; while Attribute /= No_Node loop if Base_Kind (Type_Spec (Attribute)) = K and then Color (Attribute) = No_Color then Assign_Color_To_Attribute (Attribute); end if; Attribute := Next_Entity (Attribute); end loop; end loop; declare Fd : File_Descriptor; begin Fd := Set_Output (Output_File_Name (Source_File_Name, "ads")); W_Package_Spec; Release_Output (Fd); Fd := Set_Output (Output_File_Name (Source_File_Name, "adb")); W_Package_Body; Release_Output (Fd); end; end Mknodes; polyorb-2.8~20110207.orig/compilers/iac/ChangeLog0000644000175000017500000013656211750740337020730 0ustar xavierxavier2004-09-02 Saber Souli * optimizations/cache02/Makefile (SHELL): Change compilations flags to undo style cheking. * optimizations/cache02/harness-skel.adb: Make constant local variable of Invoke global. 2004-08-30 Saber Souli * backend-be_ada-nutils.ads: Add pragma inline entity in Pragma_Id. * backend-be_ada-stubs.adb: Use direct function to initialize the result_ü variable in stubs code. 2004-08-27 Saber Souli * testsuite/all_types/all_types.idl: Add struct tests. 2004-08-27 Saber Souli * backend-be_ada-idl_to_ada.adb: Link Component_Declaration with its FE_Node. * backend-be_ada-helpers.adb: Generate structure type helper (From Any). Fix structure type To_Any convert function. 2004-08-27 Saber Souli * testsuite/all_types/all_types.idl: Add Attribute test. 2004-08-27 Saber Souli * backend-be_ada-skels.adb: Fixed a bug (consider Scoped_Name in return_type of subprograms). 2004-08-27 Saber Souli * backend-be_ada-stubs.adb: Add underscore to operation name in the operation initialization. * backend-be_ada-helpers.adb: Generate From_Any body to Arrays types, and enumeration type. Add initialization of the arrays helpers in Deferred_Initialization body. * backend-be_ada-generator.adb: Do not generate operators in expression when the operator is Op_None. * backend-be_ada-skels.adb: Correct minor bug in operations invokation (use To_Any convesion in place of From_Any). use the appropriate helper when the returned type is not a base type. * backend-be_ada-nutils.ads: Add Variables Id (V_Index, V_Position) used in enumeration type helper (From_Any). Add Op_None to Operator_Type. * backend-be_ada-nutils.adb: Modify signature of Make_List_Id in to be able to create a list containing tree element. Modify signature of Make_Expression, to make Op_none the default operator_id. 2004-08-26 Saber Souli * backend-be_ada-runtime.ads: Add runtimes entities. * backend-be_ada-helpers.adb: Generate Complex declarator helper. * backend-be_ada-generator.adb: Correct the generation of case statement. * backend-be_ada-skels.adb: Raise Bad_Operation exception when the client try to invoke an unknown operation. * backend-be_ada-stubs.adb: In the stubs subprograms, constant local variables are declared as global to the subprogram. To save the overhead introduced by the allocation and the initialization of these variables. 2004-08-20 Saber Souli * testsuite/echo/echo.idl: Test the generated code with polyorb (the script buid correctely the server and the client, but do no tests the binary. the binary work manually). * backend-be_ada-runtime.ads: Add runtimes entities. * backend-be_ada-helpers.adb: Fix enumeration TypeCode generation. * backend-be_ada.ads: Implementations packages are not generated by default. * backend-be_ada-skels.adb: Consider Scoped_Name in Types references (fixed bug). * backend-be_ada-idl_to_ada.adb: Add converting rule for the missing basetypes in Base_Type_TC. Do not add implementation package in the IDL_Unit packages list. * backend-be_ada-nutils.adb: Add converting rule for the missing basetypes in Convert. 2004-08-19 Saber Souli > * backend-be_ada-stubs.adb: Correct a bug. * backend-be_ada-runtime.ads: Add runtimes entities. * backend-be_ada-skels.adb: Generate Deferred_Initilization, and package initialization. * backend-be_ada-idl_to_ada.adb: Modify Map_Accessor : link the generated node with the frontend. * backend-be_ada-nodes.idl: Add Attribute_Designator. * backend-be_ada-nutils.adb: Add Make_Attribute_Designator. Add entities in Opertion_Id, Parameter_Id, Attribute_Id and Subprogram_Id. 2004-08-18 Saber Souli * backend-be_ada.adb: Generate implementattion specification before skels body, because entities of implementation specs are used in skels body. 2004-08-18 Saber Souli * backend-be_ada-runtime.ads: Add runtimes entities. * backend-be_ada-skels.adb: Generate code for Is_A invokation. * backend-be_ada-nutils.adb: Add_With add Helper, Skel, Impl packages in the current with list if one of theire entities are used. Add K_Octet conversion rule in Convert. * backend-be_ada-skels.adb: Add Helper in with list. 2004-08-17 Saber Souli * backend-be_ada-stubs.adb: Add operations marshaller bodies. * backend-be_ada-runtime.ads: Correct some runtimes entities (Module_Info, Empty). * backend-be_ada-skels.adb: Invoke Is_A function. 2004-08-13 Laurent Pautet * mknodes.adb: Add an optimization flag which allows to remove the tree output. The optimized files are half the size of the normal ones. 2004-08-13 Saber Souli * backend-be_ada-runtime.ads: Correct some runtimes entities (Module_Info, Empty). * backend-be_ada-skels.adb: Invoke Is_A function. 2004-08-13 Saber Souli * backend-be_ada.ads: Generate Implementation package by default. Because skels body use implementations specs. 2004-08-12 Saber Souli * backend-be_ada-runtime.adb: Declare CORRBA.Internals as subunit. * backend-be_ada-nutils.adb: Modify the suffix of variables used in subprograms variables, from "_U" to "_Ü". * backend-be_ada-helpers.adb: Add "_Ü" as suffix to variables in for statements. * backend-be_ada-generator.adb: Delete a useless semicolon in if_statements. 2004-08-11 Saber Souli * backend-be_ada-skels.adb: Remove useless subprogram Add_Underscore, use Add_Suffix_To_Name instead. Use Add_Prefix_To_Name. * backend-be_ada-idl_to_ada.adb: Modify Map_IDL_Unit (do not generate implementation package and skels for abstact interface). 2004-08-10 Saber Souli * backend-be_ada-nutils.ads: Correct selector name from P_Implecit to P_Implicit. 2004-08-10 Saber Souli * backend-be_ada-runtime.ads: Apply gnat style coding. Add runtime entities. * backend-be_ada-generator.adb: Generate Qualified_Expression. * backend-be_ada-nutils.adb: Add Make_Qualified_Expression. Add parameters entities names. * backend-be_ada-helpers.adb: Add Deferred_Initialization body. Add helper package initialization. * optimisation.txt : Optimisation des stub. 2004-08-09 Saber Souli * backend-be_ada-impls.adb: Link the Setter spec node to the Frontend node. * backend-be_ada-stubs.adb: Use the modified runtime entities names. * backend-be_ada-runtime.ads: Add runtime entities used in skels bodies. Modify some entities names. * backend-be_ada-generator.adb: Generate block statements and elsif statements. * backend-be_ada-idl_to_ada.adb: Add Link_BE_To_FE subprogram to just link a Backend node to Frontend one. (Used when multiple backend nodes are linked to one Frontend node). * backend-be_ada-nodes.idl: Add Block_Statements. * backend-be_ada-nutils.adb: Add subprograms to generate a block statements and elsif_statement. * backend-be_ada-skels.adb: Generate invokation parts in invoke body. (Not complete yet. Need to fix a bug). 2004-08-06 Saber Souli * backend-be_ada-generator.adb: Add '.All' to Designators representing an explicit_dereference. * backend-be_ada-runtime.adb: Add casing rules. * backend-be_ada-runtime.ads: Add runtimes entities used in skels body. * backend-be_ada.adb: Call the skels bodies generation. * backend-be_ada-nutils.ad[b,s]: Modify signature of Make_If_Statement, to add an Elsif_Statements list. * backend-be_ada-nodes.idl: Add Elsif_Statement node. Add Is_All to Designator, when Is_All is true it stand's for Designator.All (explicit_dereference). * backend-be_ada-skels.adb: Generate common part of invoke subprogram. 2004-08-05 Laurent Pautet * backend-be_ada-runtime.adb, backend-be_ada-nutils.adb: Declare package Standard as a subunit (even if it is a subunit) in order not to automatically with it. 2004-08-04 Saber Souli * backend-be_ada-nutils.ad[b,s]: Replace Op_Or_Then by Op_Or_Else in Operator_Type (mistake). * backend-be_ada-stubs.adb: Complete stubs body. Generate Is_A body. * backend-be_ada-runtime.ads: Add new runtime-entities used in stub Is_A body. 2004-08-04 Laurent Pautet * backend-be_ada-runtime.adb: Add rules for ARG_IN, ARG_INOUT and ARG_OUT. Change name rules into casing rules. * backend-be_ada-runtime.ads: Alphabetic order. 2004-08-04 Saber Souli * backend-be_ada-helpers.adb: Consider the modification in backend-be_ada-runtime.ads. * backend-be_ada-runtime.ads: Add new runtime-entities used in stub marshaller body. Modify RE_From_Any (CORBA.Object.Helper.From_Any) to RE_From_Any_1, to allow adding RE_From_Any_0 (CORBA.From_Any). * backend-be_ada-stubs.adb: Complete the marshaller body. 2004-08-03 Laurent Pautet * backend-be_ada-nutils.adb, backend-be_ada-nutils.ads: Reimplement Add_With_Package. This takes into account whether the unit to with is a subunit. In this case, it explores the parent list and finds the first non-subunit parent in order to with it. Add Fully_Qualified_Name which takes a designator or a defining identifier and builds the fully qualified name of this entity. Add To_Spec_Name which takes a name and returns another name with %s at the end when needed. This name designates the specification of a unit. The name info is supposed to contain a reference to the corresponding node. * backend-be_ada-runtime.adb, backend-be_ada-runtime.ads: Remove special name mechanism and find special words into identifiers in order to apply special casing. For instance, all identifiers with "corba" in it like "to_corba_object" are output with "CORBA" in it. Define run-time units not only as designator but as package spec as well and set attributes Is_Runtime_Package and Is_Subunit_Package to true when required. Entities and units are supposed to be in alphabetic order (otherwise, we may have serious problems). * backend-be_ada-expand.adb, backend-be_ada-expand.ads, backend-be_ada-idl_to_ada.adb, backend-be_ada-idl_to_ada.ads, backend-be_ada-stubs.adb: Remove parameter Witheded in *_Designator. Use new signatures. * backend-be_ada-nodes.idl: Remove Is_Generated since it is not used (no call to Is_Generated) and add Is_Runtime_Package and Is_Subunit_Package attributes. * backend-be_ada.adb, backend-be_ada.ads, backend-be_ada-generator.adb: Add new options. -ta to print Ada tree (Print_Ada_Tree), -ti to print IDL tree (Print_IDL_Tree ???), -ds to only generate package spec (Disable_Pkg_Impl_Gen), -db to only generate package impl (Disable_Pkg_Spec_Gen), -dt to output tree warnings (Output_Tree_Warnings), -dw to output unit withing (Output_Unit_Withing). Use these new flags. 2004-08-03 Saber Souli * backend-be_ada-nutils.ads: Minor reformatting. 2004-08-03 Saber Souli * backend-be_ada-stubs.adb: Add instructions to the marshaller body. * backend-be_ada-runtime.ads: Add new runtime entities used in stubs body. * backend-be_ada-generator.adb: Modify Generate_Expression to handle the generation of unary operation. * backend-be_ada-nutils.ads: Add Op_Not in Operation_Type. * backend-be_ada-nutils.adb: Add Make_Designator to return a designator from a given name id. Right_Expr field in Make_Expression is now optional (to handle unary operation). 2004-08-03 Saber Souli * backend-be_ada-impls.adb: Complete generation of the implementation body. 2004-08-03 Saber Souli * backend-be_ada-runtime.adb: Moved Convert to backend-be_ada-nutils. 2004-08-03 Saber Souli * backend-be_ada-runtime.ads: Added values to RU_Id and RE_Id to handle new runtime entities used in stub's body generation. * backend-be_ada-idl_to_ada.adb: Added Base_Type_TC functions which returns the TypeCode of a given base type. Removed pragma assert from Map_Designator. * backend-be_ada.adb: Changed -h switch to -s. Removed -b and -h usage. * backend-be_ada-nutils.ads: Added values to Parameter_Type, to handle parameters needed in stubs body generation. * backend-be_ada-expand.adb: Removed pragma Assert. Generate designator to Object_Declaration nodes. * backend-be_ada-nutils.adb: Linked Object_Declaration nodes to its parents. * backend-be_ada-stubs.adb: Generate stubs body (not completed yet). 2004-08-03 Saber Souli * testsuite/Makefile.ada (stubs): Renamed souches to stubs. Minor reformatting. * test.cmd : Idlac output is now static, stored in subdirectory named idlac.out 2004-08-03 Saber Souli * backend-be_ada-idl_to_ada.adb: Applied GNAT coding style. * backend-be_ada-helpers.adb: Applied GNAT coding style. * backend-be_ada-generator.adb: Applied GNAT coding style. * backend-be_ada-expand.adb: Applied GNAT coding style. * backend-be_ada-debug.adb: Applied GNAT coding style. * backend-be_ada.adb: Applied GNAT coding style. 2004-07-30 Saber Souli * backend-be_ada-idl_to_ada.adb: Modified Map_Designator to designate library entities. * Add tests. * backend-be_ada-runtime.adb: Correcte the parent unit of TC_Array designator. 2004-07-30 Saber Souli * backend-be_ada-generator.adb: Generate access type definitions. * backend-be_ada-impls.adb: Finished Implementations specs. * test.sh: Integrate thomas's trick to delete body package that don't have a spec. 2004-07-30 Saber Souli * testsuite/ada000[9,4]/tin.idl: Tests nested entities. * backend-be_ada-skels.adb: New file : generate skeletons (now it generate only skeletons specs). * backend-be_ada-nodes.idl: Add Pragma_Statement node. * backend-be_ada-generator.adb: Generate Pragma_Statement. 2004-07-29 Saber Souli * backend-be_ada-helpers.adb: Link helpers nodes to the corresponding idl entity. * backend-be_ada-nutils.adb: Add_With_Package do not add ancestors packages in the with list. 2004-07-28 Saber Souli * backend-be_ada.adb: Add two flags, '-b' generate only bodies and '-h' generate only specs (headers). * backend-be_ada-stubs.adb: Removing useless withs. Add Is_A specs. * backend-be_ada-helpers.adb: Removing useless withs. * Adding automatique test script. 2004-07-27 Saber Souli * backend-be_ada-nodes.idl: Add case_statement node. * backend-be_ada-generator.adb: Generate case statements. * backend-be_ada-helpers.adb: Generate To_Any body for Enumerate_Type, Structure_Type and Union_Type. 2004-07-26 Saber Souli * backend-be_ada-generator.adb: Add "in" keyword befor range contraint in for statements. 2004-07-26 Saber Souli * backend-be_ada-helpers.adb: Generate To_Any body for complex declarator and simple declarator. * backend-be_ada-generator.adb: Generate for statements. 2004-07-22 Saber Souli * backend-be_ada-helpers.adb: Completed any convesion body for interfaces. 2004-07-22 Saber Souli * backend-be_ada-nodes.idl: Add expression node. * backend-be_ada-generator.adb: Generate Expressions. * backend-be_ada-helpers.adb: Completed narrowing and widening reference body. 2004-07-21 Saber Souli * frontend-nodes.idl: Moved BE_CORBA to backend-be_ada-nodes.idl. 2004-07-20 Saber Souli * backend-be_ada-helpers.adb: Linked Frontend nodes with Helper nodes. * backend-be_ada-idl_to_ada.adb: Add Bind_FE_To_Skel, Bind_FE_To_Impl and Bind_FE_To_Helper to allow linking a frontend node with respective Skeleton, Implementation and helper node. 2004-07-20 Saber Souli * frontend-nodes.idl: Add BE_CORBA node, which contain four nodes : Stub_Node point to the stub, Helper_Node point to the helper, Skel_Node to the Skeleton and finally Impl_node point to the implementation node. 2004-07-19 Saber Souli * backend-be_ada-helpers.adb: Reflecting changes to helper TypeCodes generation introduced by the recent modified API in PolyORB. 2004-07-19 Saber Souli * backend-be_ada-helpers.adb: Generate helpers body. (functions are now empty). 2004-07-19 Saber Souli * backend-be_ada-helpers.adb: Completed helper specification, for interfaces, and types. 2004-07-18 Saber Souli * backend-be_ada.adb: Add -i switch that dump the idl tree with the field BE_Node updated with Ada nodes. * backend-be_ada-helpers.adb: Generate the widening reference function. * backend-be_ada-expand.adb: Expand_Designator modified to take in consideration the new structure. * backend-be_ada-nodes.idl: Add Parent node to Definition and IDL_Unit to Package_Declaration to allow navigations from child nodes to parents. 2004-07-16 Saber Souli * backend-be_ada-debug.adb: Do not dump the referenced nodes. 2004-07-16 Saber Souli * frontend-debug.adb: View BE_Node information in the idl tree dump. * backend-be_ada-stubs.adb: Minor change, relatif to the modification in the frontend-nodes.idl. * frontend-nodes.idl: Removed BE_Node from Node_Id to Definition. 2004-07-15 Saber Souli * backend-be_ada.adb: Reformatting. * backend-be_ada-impls.adb: New file, generate implementations Ada subtree. * backend-be_ada-helpers.adb: New file, generate helpers Ada subtree. * backend-be_ada-stubs.adb: New file, generate client stubs Ada subtree. * backend-be_ada-stubs.adb, backend-be_ada-helpers.adb, backend-be_ada-impls.adb : They contains two sub-packages, Package_Spec generate package specification, and Package_Body generate the correponding body. 2004-07-10 Saber Souli * backend-be_ada.adb: Minor reformatting. * backend-be_ada-nutils.adb: Move Make_Designator to Expand package and change its prefix "Make_" into "Expand_". * backend-be_ada-expand.adb: New file. This package contains routines that expand an Ada node into another Ada node. 2004-07-10 Saber Souli * backend-be_ada-nutils.adb, backend-be_ada.adb: all routines that transform an IDL entity into an Ada node, are moved to the new IDL_To_Ada package. These routines are renamed by replacing prefix "Make_" with "Map_". * backend-be_ada-idl_to_ada.adb: New file. This package contains routines that map an IDL entity into an Ada node according to the IDL to Ada mapping. 2004-07-09 Saber Souli * backend-be_ada-nutils.adb: Add Make_Designator and Qualified_Designator in order to generate a designator for a given Ada entity. Fix Make_Designator in order to generate a fully qualified designator (using scope entity of identifiers reference instead of using Parent_Entity of Scoped_Identifier). * backend-be_ada-runtime.adb: Add RU function that returns a designator to an unit entity. * backend-be_ada.adb: Add functions to generate windening and narrowing subprogram that results in the mapped in the mapped reference type definined in the interface package (Helper_Narrowing_Ref, Helper_Widening_Ref), to generate TypeCode constant and type any conversion functions for the mapped reference type and for all types defined in the interface package. 2004-07-06 Laurent Pautet * backend-be_ada-nutils.adb, backend-be_ada-nutils.ads, backend-be_ada.adb: Add Ref as a defining identifier. Minor reformatting. 2004-07-06 Saber Souli * backend-be_ada-runtime.ads: Add To_Any_0, To_Get_Empty_Any_0, To_Any_1 and To_Get_Empty_Any_1 to RE_Id to handle new runtime entities. * backend-be_ada.adb: Update FE_Node attribute of Type_Spec node. Use type helper functions. 2004-07-05 Laurent Pautet * backend-be_ada-nutils.adb, backend-be_ada-nutils.ads, backend-be_ada-nodes.idl: Define tables for attributes, subprograms and components like those we have for parameters and variables. Add component initialization. Add discriminant in full type declaration. Add Make_Type_Attribute to initialize discriminant. * backend-be_ada.adb: Implement union type and minor reformatting. * analyzer.adb: Minor reformatting and check duplicated default labels. * backend-be_ada-generator.adb: Generate union types. Fix generation of object initialization. * backend-be_idl.adb: Minor reformatting. 2004-07-03 Laurent Pautet * backend-be_ada.adb: Produce exception declaration and members declarations. * backend-be_ada-nodes.idl, backend-be_ada-nutils.adb, backend-be_ada-nutils.ads: Add Make_Exception_Declaration and corresponding node. * backend-be_ada-generator.adb: Generate code for exception declaration. * backend-be_ada-runtime.ads: Add CORBA and Ada exception entities. * backend-be_idl.adb: Generate value declaration and adopt the same organization for IDL backend than the one for Ada backend. Generate boxed value types and abstract value types. Fix wrong output of multidimensional arrays. Generate initializer declaration as a special case of operation declaration. * frontend-nodes.idl: Define initializer declaration as a special case of operation declaration. * frontend-nutils.adb, frontend-nutils.ads: Fix function Is_A_Forward_Of for value declaration. Implement value type inheritance. * scopes.adb: Deal with value forward declaration. Implement value type inheritance. * analyzer.adb: Analyze partially value declarations. Some parts are just cut and pasted from interface analyzis. This will be reorganized later on. Implement value type inheritance. Implement boxed value type. Analyze initializer declaration as a special case of operation declaration. * parser.adb: Parse semi-colon at the end of an initializer declaration. 2004-07-02 Laurent Pautet * frontend-nodes.idl: Remove Base_Interface since it always corresponds to Current_Scope. Add atttribute Is_Local_Interface. * parser.adb: Parse local interface. Do not forget to set sequence size to its value. Parse correctly state members and value declaration. * backend-be_idl.adb: Generate fully qualified name for enumerators. Fix indentation for elements. Generate abstract interfaces. * analyzer.adb: Minor reformatting. Analyze consistency of parent interfaces in regards to local and abstract properties. Check that a local type does not appear as a parameter, attribute, return type or exception declaration of an unconstrained interface. * values.adb: Fix Image for non printable characters (use \xxx representation). * backend-be_ada-generator.adb: Generate sequence size in sequence type when needed. 2004-07-01 Laurent Pautet * frontend-nodes.idl: Remove Explicitely_Visible and Implicitely_Visible attributes and use Visible attribute instead (see below). Add a Depth attribute in Scoped_Name in order to detect whether in a recursive procedure concerning scoped names we analyze the tail of a scoped name (depth = 0) or not. * parser.adb: Always create an inheritance specification even if it appears to be empty. This simplifies the analyzis later on. Compute depth attribute of scoped names. * scopes.adb, scopes.ads: Redesign the inheritance mechanism since inherited entities were made implicitely visible and were not introduced in the scope (using Explicitely_Visible and Implicitely_Visible attributes). This was plain since it is possible to designate an inherited entity by prefixing the entity with the derived interface. In this new scheme, inherited entities are introduced in the scope and removed as soon as they are overriden. An inherited entity E is introduced in the scope of a derived interface as an identifier I which corresponding entity is E. Note that the corresponding identifier of E is its original identifier J and not the newly-created identifier I. In other words, J and I refer to E when E only refers J. Remove Explicitely_Visible and Implicitely_Visible attributes and use only Visible attribute. Fix Remove_From_Homonyms implementation since this was buggy because of the two previous attributes. * analyzer.adb: Improve the way inheritance is handled as said above. Analyze scoped names designating parent interface in the scope of the enclosing entity of the derived interface and not in the scope of the derived interface. Moreover special rules for type names only apply to the tail of the scoped name (and to each sub scoped name as done before). Create a scope when entering a union type. * backend-be_idl.adb: Output scoped names not using the scoped name representation but using the representation of the scoped name reference. For instance, when type T is in interface I1 and when I2 inherits from I1, a scoped name like I2::T in I2 should be output I1::T. 2004-06-30 Laurent Pautet * backend-be_ada-generator.adb: Minor reformatting. 2004-06-30 Saber Souli * backend-be_ada.adb : Generate assignment statement, and record aggregate. * backend-be_ada-runtime.adb : Respect the case sensitiveness of runtime packages name. * backend-be_ada-nodes.idl : Add assignment statement node, and record aggregate node. * backend-be_ada-nutils.ad{b,s} : Add Make_List_Id, Make_Record_Aggregate, Make_Assignment_Statement and Length. 2004-06-30 Laurent Pautet * backend-be_ada-runtime.adb: Remove 6619 as it causes RE_X_Y to be output X_Y instead of X.Y as done previously. 2004-06-29 Saber Souli * backend-be_ada_nutils.adb : In To_Ada, insert "IDL_" string when identifier collides with an Ada reserved word. * backend-be_ada-generator.adb : Define Token_Type and its subprograms. 2004-06-29 Laurent Pautet * scopes.adb: Minor reformating. * backend-be_ada-generator.adb: Add a missing space between defining_identifier and colon. * backend-be_ada-nutils.adb: Add one to Token_Type'Pos in order to have a positive value. Fix an incorrect redirection to backend tree. * iac.adb: Comments. Minor reformating. * lexer.adb: Cleanup on error. * analyzer.adb: Analyze expanded constant declaration coming from enumerator in order to compute its value. Output an error when we cannot resolve a scoped name. * backend-be_ada.adb: Read constant value and not constant expression value. 2004-06-29 Laurent Pautet * backend-be_ada-generator.adb: Remove junk code (Generate_Enumeration_Type and Generate_Type_Spec not used). Establish some generation rules. The enclosing entity decides for the first indentation and the last semi-colon + end-of-line sequence. What is generated in between is the business of the enclosed entity. Use parameter Offset of new Write_Indentation procedure. Allow to fix the longest variable name length in order to align all variables and parameters. * backend-be_ada-debug.ads, frontend-debug.ads: Reformating. * backend-be_ada-generator.ads: Var_Name_Len to set the maximum length of a variable name. Zero means that no trailing space is added during a variable or parameter output. * backend-be_ada.adb: Get Var_Name_Len value. Capitalize variables and parameters. 2004-06-28 Laurent Pautet * backend-be_ada.adb: Use the RTE mechanism for parameters and variables. 2004-06-28 Saber Souli * iac.adb : Fix bug introduced when the path name of the IDL file contain a leading dot. * backend-be_ada.adb : Use Backend.BE_Ada.Runtime and remove all the variables which are now useless. * backend-be_ada-generator.adb : Minor change in the generated code to produce exactly the same output as idlac. 2004-06-28 Saber Souli * backend-be_ada.adb: Declare PolyORB and CORBA objects. Generate marshaller declaration code. Use Copy_Designator in object declaration in order to auto insert packages used in the withed list. Generate Marshaller Body (not Completed yet). Generate If statements. Add Bind_FE_To_BE a subprogram that cross link FE node with the correspanding BE node. * backend-be_ada-nutils.adb, backend-be_ada-nutils.ads: generate functions call. Generate If statement. * backend-be_ada-generator.adb : generate functions call, and subprograms body. generate if statements. 2004-06-28 Laurent Pautet * backend-be_ada-runtime.ads, backend-be_ada-runtime.adb: New files to deal with various API. * scopes.adb, values.adb, backend-be_ada-generator.adb, frontend-nutils.adb, mknodes.adb, lexer.adb : Reordering. * backend-be_ada-nutils.adb, backend-be_ada-nutils.ads: Avoid duplication of withed packages. Use rtsfind-like mechanism from backend-be_ada-runtime. * backend-be_ada.adb: Use rtsfind-like mechanism from backend-be_ada-runtime. In particular concerning Designator creations. Fix implementation of repository_id production since their values were plain wrong. * backend-be_a (all): Removed. * MANIFEST: Updated. * Makefile: Check that subprograms are still sorted. 2004-06-26 Laurent Pautet * backend-be_ada-generator.adb: Generate object declaration and in particular constant declaration. Fix few typos output in subrogram body. * backend-be_ada-nutils.adb, backend-be_ada-nutils.ads: Generate object declaration and in particular constant declaration. Fix automatic "with" for designator (no replication, less bugs). Define a function Copy_Designator which copies a designator like CORBA.Object.Ref and also with the parent unit of designator like CORBA.Object. * backend-be_ada.adb: Generate object declaration and in particular constant declaration. Generate repository_id. Reorganize Getter and Setter subprograms. * backend-be_ada-nodes.idl: Generate object declaration and in particular constant declaration. 2004-06-26 Laurent Pautet * backend-be_ada-nutils.adb: Add Make_Array_Type_Definition and Make_Range_Constraints in order to map complex declarators. * backend-be_ada-generator.adb: Replace Write_Token with Write. Generate array type definition. Fix several missing end of line. * backend-be_ada-nodes.idl: Add Range_Constraints and Range_Constraint to handle complex declarators. * backend-be_ada-debug.adb, backend-be_ada-debug.ads: Output values. * scopes.adb: When re-entering a module, re-introduce all the scoped identifiers in the new scope, in their homonyms chain and make them visible. * backend-be_ada.adb: When visiting a scoped name which designates a constant, output its value instead of the scoped name. Map complex declarators for type definition and structure members. Comment Visit_Operation_Declaration. * backend-be_idl.adb: Remove space between array sizes and declarator in a complex declarator to match omniorb output. Output properly empty exception. Output literals and string types. 2004-06-24 Laurent Pautet * backend-be_ada-generator.adb: Do invoke specific Generate, use dispatching one instead. Remove Generate_Qualified_Identifier since Generate_Defining_Identifier does the job. * backend-be_ada-nutils.adb, backend-be_ada.adb: Fix Make_Fully_Qualified_Identifier in order not to have specification identifier as a prefix. 2004-06-23 Saber Souli * backend-be_ada.adb : Fixed void operation handling bug. Add an empty body for subprograms. Handle nested blocs. * backend-be_ada-generator.adb : Add Token_Type to handle ada keyword and graphic characters. add Generate_Qualified_Name (N : Node_Id) to a full qualified name. Add Generate_Subprogram_Implementation : generate a subprogram body. Add Image function : returns the image of a Token_Type. Add Write_Token : a procedure that print the image of a given Token_Type. 2004-06-24 Laurent Pautet * lexer.adb, lexer.ads: Add CORBA 3.0 keywords. * frontend-nodes.idl, frontend-nutils.ads, frontend-nutils.adb: Add function Length. * Makefile: Invoke run-test right from the Makefile. 2004-06-23 Laurent Pautet * values.adb: Format float image in such a way that we do not have useless zeros. * frontend-debug.adb: Use Parameter_Mode. * backend-be_ada.adb: Handle inout and out parameters in functions. * analyzer.adb: Handle forward entities when resolving types. * backend-be_ada-nutils.adb, backend-be_ada-nutils.ads, backend-be_ada-nodes.idl: Replace subprogram_specification with specification to match GNAT tree. * scopes.adb: Do not reset scope to No_Node for forward entities as they can be visited mater on and need to have a scope anyway. 2004-06-22 Laurent Pautet * frontend-nutils.adb, frontend-nutils.ads, backend-be_idl.adb: Define a new converter function for parameters to fix output bug. * backend-be_ada*: Merge be_a into be_ada. * backend-be_a-generator.adb, backend-be_a-nutils.adb, backend-be_a-nutils.adb, backend-be_a-nutils.ads, backend-be_a-nodes.idl, backend-be_a.adb: Implement designator, structure type, with clause (automatically added but should not be replicated), operation declaration, * analyzer.adb, scopes.adb, scopes.ads, parser.adb, backend-be_ada.adb, backend-be_idl.adb, frontend-nutils.adb, frontend-nodes.idl, frontend-nutils.ads, frontend-debug.adb, backend-be_ada-nutils.adb, backend-be_ada-nutils.ads, mknodes.adb: Clarification between nodes and entities. Clarification of Mode_Id. 2004-06-21 Saber Souli * backend-be_ada.adb : Handle complex declarator. Now the backend map all the list of declarators. Generate library file (IDL). Add append_type_to_package_spec (T:Node_Id ; P : node_id): a function that add the type in the specification part of the package P. 2004-06-21 Laurent Pautet * backend-be_a.adb, backend-be_a-nutils.adb: Clarification between nodes and entities. Start implementing type declaration and designator and module. * backend-be_a-generator.adb: Fix output problem on Record_Extension_Part. * scopes.adb, parser.adb, backend-be_idl.adb, frontend-nodes.idl: Clarification between nodes and entities. 2004-06-15 Saber Souli * output.ads, output.adb Add procedure Set_Space_Increment (Value : Natural); to change the Space_Increment and so enable dealling with different indentations. 2004-06-15 Laurent Pautet * backend-be_ada-nutils.adb, backend-be_ada-generator.adb, backend-be_ada-nutils.adb, backend-be_ada-nodes.idl, backend-be_ada.adb: Rename nodes and atributes for better understanding. 2004-06-13 Laurent Pautet * backend-be_ada.adb, backend-be_ada-nodes.idl, frontend-debug.adb, backend-be_ada-debug.adb: Move Ada_Node into BE_Node. Define FE_Node in Ada tree. 2004-06-12 Laurent Pautet * nodes.idl, nutils.ads, nutils.adb, debug.adb, debug.ads: Remove and replace by child units with Frontend as prefix. * frontend-nodes.idl, frontend-nutils.ads, frontend-nutils.adb, frontend-debug.adb, frontend-debug.ads: See above. * scopes.adb, parser.adb, backend-be_idl.adb, values.ads, backend-be_ada-debug.ads, Makefile, iac.adb, backend-be_ada.adb, analyzer.adb: Replace unit names above. * names.ads, names.adb: Move entities to Frontend.Nutils. * backend-be_ada-debug.adb, backend-be_ada-debug.ads: Duplicate debugs.adb and debugs.ads and then adapt them. Rename wni into wbi (write ada backend info). * backend-be_ada-generator.adb, backend-be_ada-generator.ads, backend-be_ada-nodes.idl: Rename backend-be_ada-files_generation.adb, backend-be_ada-files_generation.ads. Huge clean up. * backend-be_ada-nutils.adb, backend-be_ada-nutils.adb: Rename Mk_ into Make_. Add subprograms to deal with parameter mode. Huge clean up. * debug.adb, debug.ads: Change wni into wfi (write frontend info). * lexer.ads, lexer.adb: Move Write for token from BE_IDL. * backend-be_idl.adb: Move Write for token to Lexer. * backend-be_ada.ads: Remove blank line. * analyzer.adb: Minor reformating. 2004-06-11 Laurent Pautet * analyzer.adb: Check oneway operation rules. 2004-06-10 Laurent Pautet * backend-be_idl.adb: Generate idl code for union type. Fix bug in sequence type generation (most keywords missing). Add Generate procedure for values (used both for constant declaration and case label). * values.adb, values.ads: Add a comparison function between two values. This is used to sort labels in a union type and to detect duplications. Add an enumerator as a value for union type as well. * analyzer.adb: Provide two subprograms Resolve_Type and Resolve_Expr. Resolve_Type returns the root type. A case which is not well handled concerns array type as this info is in the declarator and not in the type spec itself (C syntax). Resolve_Expr is a renaming of the previous Resolve procedure. Analyze union type that is : analyze all the enclosed entities, check labels are in the switch type, check they are not duplicated, heck elements are not duplicated. * parser.adb: Do not represent enumerator with only their position and add their image instead. Handle union type and in particular set the Declaration attributes of all the nodes implied in the union type definition. Improve error handling for union type. * nodes.idl: Add node Case_Label to handle union type. Add also an attribute Declaration for Switch_Alternative and Case_Label in order to retrieve respectively the Union_Type and the Switch_Alternative of these entities. 2004-06-08 Saber Souli * backend-be_ada.adb: Add Visit_Enumeration_Type function and handle Enumeration_Type declaration. Add Visit_Constant_Declaration function. It only ignore constant declaration expanded by iac frontend for enumerators. * backend-be_ada-nutils.adb: Add Mk_Node_Enumeration_Type function in order to create Enumeration_Type node. Add Mk_Node_Type_Declaration function in order to create Type_Declaration node. * backend-be_ada-files_generation.adb: - Add Generate_Enumeration_Type procedure : output the source code for Enumeration_Type declaration. - Add Generate_Identifier procedure : Output Identifier Name. 2004-06-07 Saber Souli * backend-be_ada.adb: Handle interface operations and generate the appropriate Ada function or procedure. Handle the Declarators list in Attribute_Declaration. Handle simple Type_Declaration (function Visite_Type_Declaration). * backend-be_ada-nutils.adb: Add function Mk_Node_Simple_Derived_Type_Def and create a simple derived type declaration. * backend-be_ada-debug.adb: Add procedure W_Small_Indents in order to write a small indentation for making the IAC source code output identical to the output of IDLAC. * backend-be_ada-files_generation.adb: Use W_Small_Indents. * nodes.idl: Add Ada_Node to manage scoped name reference in Type_Declaration. * be-adatree-design.txt : Ada tree production design document. * be-design.txt : Ada Backend Architecture"Draft". 2004-06-01 Laurent Pautet * mknodes.adb: Debug is now a sibling from Nodes. * usage.adb, backend.adb, backend.ads, backend-config.adb: Adapt to new organization that is a usage per backend. * backend-be_idl.adb, backend-be_idl.ads: Provide flag -b to set base to output integer literal. Provide a usage procedure. * backend-be_ada.adb, backend-be_ada.ads: Provide flag -t to dump Ada tree. Provide a usage procedure. * flags.adb: Scan command line in two phases. First, detect the backend language if there is one. Second, use Getopt by setting cpparg and backend language as sections (see GNAT.Command_Line). In command like 'iac -ds tin.idl -idl -b 8', '-ds' is considered as a general flag and '-b 8' is considered as an IDL backend flag. * backend-be_idl.adb, backend-be_idl.ads: Add Configure procedure. Fix generation of members (readonly missing), operations (oneway missing), of values (base to use). Start generating union type. * backend-be_ada.adb, backend-be_ada.ads: Add Configure procedure. * backend.adb, backend.ads: Define Configure procedure for backends and add it as Register parameter. This configure procedure is supposed to read flags specific to backend using GNAT.Command_Line.Getopt. * backend-config.adb: Initialize configure procedure for backends IDL and Ada. 2004-05-31 Saber Souli * backend-be_ada.adb : This package Visit IDL tree nodes, and generate the appropriate Ada node following the Ada Language Specification. Actually I didn't take in consideration specific mapping introduced by using PolyORB, I let this in later stage, after completing all the OMG mappings specification. Here are the actual mapping implemented : Module, Interface (only attribute setter and getter generation is completed), typedef (Not completed yet), Base type mapping. * backend-be_ada-nutils.ads,backend-be_ada-nutils.adb: Contain several routines to simplify the creation of ada tree nodes. * backend-be_ada-nodes.idl: Add Derived_Type_Spec in order to declare derived types. Same for Record_Type_Spec. Add Ada_Function_Spec and Ada_Procedure_Spec to manage subprogram declarations. * backend-be_ada-debug.adb: ease debug of the Ada tree. * backend-be_ada-file_generation: Output ada file source. 2004-05-31 Laurent Pautet * analyzer.adb: Do not try to analyze predefined types. Add location to error message when invalid constant type detected. Expand enumerators as constants and do not cause new errors when enumeration type is incorrect. Re-implement attributes and operations inheritance and other inherited entities visibility as overloading declarations were not properly detected. Skip scoped name analyzis when attribute Reference is already set. * scopes.adb, scopes.ads: Clarify some routines and add comments. Fix bugs in special scoping of type names due to a misunderstanding of the document. Re-implement scoping. * debug.adb: Filter new attributes. * parser.adb: Adapt code to new scoped name and identifier constructors signature. * nutils.adb, nutils.ads: Add a function to detect a non module entity (different from specification or module). Enrich scoped name and identifier constructors with new attributes (needed for expansion). * nodes.idl: Add Potential_Scope to deal with type names. Make nodes Simple_Declarator and Complex_Declarator contiguous. 2004-05-30 Laurent Pautet * debug.adb: Filter some more attributes. * backend-be_idl.adb: Fix output for raises clause in an operation declaration and for no-parameter operation declaration. 2004-05-26 Laurent Pautet * lexer.adb: Scan properly identifier. Do not return a token T_Error when identifier is not well-formed. Display error, accept identifier and proceed in parsing. In case of invalid character, try to rescue lexer and progress up to a possible terminal. 2004-05-24 Laurent Pautet * utils.adb: Protect To_Lower against No_Name. * nodes.idl: Replace immediately with explicitely and potentially with implicitely. Define specification as a definition to follow CORBA 2.6 3.15.1. * backend-be_idl.adb: Inherited interface specification starts with a colon and not colon colon. * nodes.idl: Reorder Scoped_Name attributes from debug readibility. * scopes.ads: Rename functions for readibility. Add comments. Replace immediately with explicitely and potentially with implicitely. * scopes.adb: Same as above. Fix also name resolution bugs. * nutils.adb, nutils.ads: Add expansion routines to build scoped name, identifier and constant declaration. Used to declare enumerator as constant. * backend-be_idl.adb: Fix constant declaration output to take enumeration types into account. Try to reproduce omniORB IDL output for testing purpose. * debug.adb, debug.ads: Simplify debug primitives. * analyzer.adb: Allow enumeration type in constant declaration. Analyze properly enumeration type and create one constant declaration per enumerator. Fix Resolve operation to compute constant expression in case of enumeration type. Analyze union type. * parser.adb: Use Make_Identifier. 2004-05-22 Laurent Pautet * debug.adb, mknodes.adb: Remove parameter I (for number of indentations) in all output procedures. * Makefile: Force backend.be_ada.nodes generation when mknodes updated. 2004-05-21 Laurent Pautet * lexer.adb: Do not adjust base when the integer literal base has already been set to 16 (in particular a leading zero is not meaningful - for instance 0x01). * values.adb: Reorder the normalization steps for fixed point values (reduce precision, remove trailing zero, remove leading zero, recompute total digits). Set result base to the left operand base for shift left and shift right operations. Execute operation "not" as an unsigned long operation "not" for types octet, signed and unsigned short, signed and unsigned long. 2004-05-17 Laurent Pautet * nodes.idl: Remove left and right values in an expression node. Instead define an expression value in order to store the evaluation of the expression in the node. * parser.adb: Remove an useless conversion. * values.adb, values.ads: Use node kind as a discriminant for values (and not token kind anymore). Subtyping is different for constant declaration and expression and operation precision is different for (signed and unsigned) long long and other integer types for instance. Same for floating and fixed point values. * types.ads, lexer.ads: Define CORBA types and use them. * errors.adb, iac.adb: Remove blank after digit in order to output notations and formats like "fixed<$,$>". * analyzer.adb, backend-be_idl.adb: Handle constant declarations, expressions and literals. Handle fixed point types in particular. * MANIFEST: Add values.ads and values.adb. 2004-05-14 Laurent Pautet * parser.adb: Avoid to output twice an error message in P_Type_Spec and in P_Declarator. * lexer.adb: Improve error detection and fixed literal parsing. Fix few bugs (08D was incorrectly interpreted as formatted in octal). * errors.adb: Define '|' as a character to escape a meta-character. This character is not frequently used. 2004-05-13 Laurent Pautet * iac-cpp: read env. variable CPPEXEC to redirect command either to cpp or mico-cpp. Note that cpp (GNU CPP) removes all unnecessary blanks and makes iac to incorrectly locate errors. * lexer.adb, lexer.ads: Scan string literals but on minor errors like having a string which appears to be a wide string, do not produce token T_Error. Instead, produce token T_String with Token_Name or String_Literal_Value set to Incorrect_String. Same for characters. * parser.adb: produce a null node when an incorrect string is parsed in order not to analyze it later on. * values.adb: do not crash when dumping an empty string value. * analyze.adb: properly detect type mismatch for floats, characters, strings. polyorb-2.8~20110207.orig/compilers/iac/backend-be_corba_ada-runtime.adb0000644000175000017500000003566111750740337025233 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- B A C K E N D . B E _ C O R B A _ A D A . R U N T I M E -- -- -- -- B o d y -- -- -- -- Copyright (C) 2005-2008, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with GNAT.OS_Lib; use GNAT.OS_Lib; with GNAT.Case_Util; with Charset; use Charset; with Namet; use Namet; with Utils; use Utils; with Backend.BE_CORBA_Ada.Nodes; use Backend.BE_CORBA_Ada.Nodes; with Backend.BE_CORBA_Ada.Nutils; use Backend.BE_CORBA_Ada.Nutils; package body Backend.BE_CORBA_Ada.Runtime is RUD : array (RU_Id) of Node_Id; RED : array (RE_Id) of Node_Id; -- Arrays of run-time entity and unit designators type Casing_Rule is record Size : Natural; From : String_Access; Into : String_Access; end record; Rules : array (1 .. 128) of Casing_Rule; Rules_Last : Natural := 0; procedure Apply_Casing_Rules (S : in out String); procedure Register_Casing_Rule (S : String); procedure Declare_Subunit (N : Node_Id); ------------------------ -- Apply_Casing_Rules -- ------------------------ procedure Apply_Casing_Rules (S : in out String) is New_Word : Boolean := True; Length : Natural := S'Length; S1 : constant String := To_Lower (S); begin GNAT.Case_Util.To_Mixed (S); for I in S'Range loop if New_Word then New_Word := False; for J in 1 .. Rules_Last loop if Rules (J).Size <= Length and then S1 (I .. I + Rules (J).Size - 1) = Rules (J).From.all then S (I .. I + Rules (J).Size - 1) := Rules (J).Into.all; end if; end loop; end if; if S (I) = '_' then New_Word := True; for J in 1 .. Rules_Last loop if Rules (J).Size <= Length and then S1 (I .. I + Rules (J).Size - 1) = Rules (J).From.all then S (I .. I + Rules (J).Size - 1) := Rules (J).Into.all; end if; end loop; end if; Length := Length - 1; end loop; end Apply_Casing_Rules; --------------------- -- Declare_Subunit -- --------------------- procedure Declare_Subunit (N : Node_Id) is S : Node_Id; begin pragma Assert (Kind (N) = K_Defining_Identifier or else Kind (N) = K_Selected_Component); S := Get_Declaration_Node (N); pragma Assert (Kind (S) = K_Package_Specification); Set_Is_Subunit_Package (S, True); end Declare_Subunit; ---------------- -- Initialize -- ---------------- procedure Initialize is Position : Integer; Name : Name_Id; Length : Natural; Pkg_Spec : Node_Id; begin Register_Casing_Rule ("ASCII"); Register_Casing_Rule ("AbstractBase"); Register_Casing_Rule ("ARG_INOUT"); Register_Casing_Rule ("ARG_IN"); Register_Casing_Rule ("ARG_OUT"); Register_Casing_Rule ("CORBA"); Register_Casing_Rule ("NamedValue"); Register_Casing_Rule ("NVList"); Register_Casing_Rule ("ORB"); Register_Casing_Rule ("PolyORB"); Register_Casing_Rule ("PortableServer"); Register_Casing_Rule ("ServerRequest"); Register_Casing_Rule ("_TC"); Register_Casing_Rule ("TC_"); Register_Casing_Rule ("TypeCode"); Register_Casing_Rule ("ExceptionList"); Register_Casing_Rule ("RepositoryId"); Register_Casing_Rule ("ScopedName"); Register_Casing_Rule ("TypeCode"); Register_Casing_Rule ("PolicyType"); Register_Casing_Rule ("OObject"); Register_Casing_Rule ("GIOP"); Register_Casing_Rule ("CDR"); Register_Casing_Rule ("IDL_Sequences"); Register_Casing_Rule ("IDL_SEQUENCE_"); Register_Casing_Rule ("Request_QoS"); Register_Casing_Rule ("Add_Request_QoS"); -- Casing Rules for Sequence types Register_Casing_Rule ("AnySeq"); Register_Casing_Rule ("FloatSeq"); Register_Casing_Rule ("DoubleSeq"); Register_Casing_Rule ("LongDoubleSeq"); Register_Casing_Rule ("ShortSeq"); Register_Casing_Rule ("UShortSeq"); Register_Casing_Rule ("LongSeq"); Register_Casing_Rule ("ULongSeq"); Register_Casing_Rule ("LongLongSeq"); Register_Casing_Rule ("ULongLongSeq"); Register_Casing_Rule ("CharSeq"); Register_Casing_Rule ("WCharSeq"); Register_Casing_Rule ("StringSeq"); Register_Casing_Rule ("WStringSeq"); Register_Casing_Rule ("BooleanSeq"); Register_Casing_Rule ("OctetSeq"); -- Misc Register_Casing_Rule ("IR_Hooks"); Register_Casing_Rule ("IR_Root"); Register_Casing_Rule ("IR_Tools"); Register_Casing_Rule ("PolicyList"); Register_Casing_Rule ("DomainManager"); Register_Casing_Rule ("IR_Info"); Register_Casing_Rule ("IRObject"); Register_Casing_Rule ("InterfaceDef"); Register_Casing_Rule ("InterfaceDefSeq"); Register_Casing_Rule ("ParDescriptionSeq"); Register_Casing_Rule ("ParameterDescription"); Register_Casing_Rule ("ExceptionDefSeq"); Register_Casing_Rule ("ContextIdSeq"); Register_Casing_Rule ("StructMemberSeq"); Register_Casing_Rule ("StructMember"); Register_Casing_Rule ("UnionMemberSeq"); Register_Casing_Rule ("UnionMember"); Register_Casing_Rule ("IDLType"); Register_Casing_Rule ("ATTR_READONLY"); Register_Casing_Rule ("ATTR_NORMAL"); Register_Casing_Rule ("PARAM_IN"); Register_Casing_Rule ("PARAM_INOUT"); Register_Casing_Rule ("PARAM_OUT"); Register_Casing_Rule ("OP_ONEWAY"); Register_Casing_Rule ("OP_NORMAL"); Register_Casing_Rule ("pk_void"); Register_Casing_Rule ("pk_short"); Register_Casing_Rule ("pk_long"); Register_Casing_Rule ("pk_longlong"); Register_Casing_Rule ("pk_ushort"); Register_Casing_Rule ("pk_ulong"); Register_Casing_Rule ("pk_ulonglong"); Register_Casing_Rule ("pk_char"); Register_Casing_Rule ("pk_wchar"); Register_Casing_Rule ("pk_boolean"); Register_Casing_Rule ("pk_float"); Register_Casing_Rule ("pk_double"); Register_Casing_Rule ("pk_longdouble"); Register_Casing_Rule ("pk_string"); Register_Casing_Rule ("pk_wstring"); Register_Casing_Rule ("pk_octet"); Register_Casing_Rule ("pk_objref"); Register_Casing_Rule ("pk_any"); RUD (RU_Id'First) := No_Node; for U in RU_Id'Succ (RU_Id'First) .. RU_Id'Last loop Set_Str_To_Name_Buffer (RU_Id'Image (U)); Set_Str_To_Name_Buffer (Name_Buffer (4 .. Name_Len)); RUD (U) := New_Node (K_Defining_Identifier); Position := 0; Name := Name_Find; Length := Name_Len; Set_Name_Table_Info (Name, RU_Id'Pos (U)); while Name_Len > 0 loop if Name_Buffer (Name_Len) = '_' then Name_Len := Name_Len - 1; Position := Integer (Get_Name_Table_Info (Name_Find)); exit when Position > 0; else Name_Len := Name_Len - 1; end if; end loop; -- When there is a parent, remove parent unit name from unit -- name to get real identifier. if Position > 0 then Set_Str_To_Name_Buffer (Name_Buffer (Name_Len + 2 .. Length)); Name := Name_Find; end if; Get_Name_String (Name); Apply_Casing_Rules (Name_Buffer (1 .. Name_Len)); Set_Name (RUD (U), Name_Find); Pkg_Spec := New_Node (K_Package_Specification); Set_Is_Runtime_Package (Pkg_Spec, True); Set_Declaration_Node (RUD (U), Pkg_Spec); if Position > 0 then RUD (U) := Make_Selected_Component (RUD (RU_Id'Val (Position)), RUD (U)); end if; Set_Name_Table_Info (To_Spec_Name (Fully_Qualified_Name (RUD (U))), Int (RUD (U))); end loop; Declare_Subunit (RUD (RU_PolyORB_Std_ASCII)); Declare_Subunit (RUD (RU_CORBA_Internals)); Declare_Subunit (RUD (RU_CORBA_TypeCode)); Declare_Subunit (RUD (RU_CORBA_TypeCode_Internals)); Declare_Subunit (RUD (RU_CORBA_NVList_Internals)); Declare_Subunit (RUD (RU_PolyORB_Any_TypeCode)); Declare_Subunit (RUD (RU_PolyORB_Any_TypeCode_Internals)); Declare_Subunit (RUD (RU_CORBA_Object_Internals)); Declare_Subunit (RUD (RU_PortableServer_Internals)); Declare_Subunit (RUD (RU_CORBA_ExceptionList_Internals)); Declare_Subunit (RUD (RU_PolyORB_Representations_CDR_Common_Fixed_Point)); Declare_Subunit (RUD (RU_PolyORB_Buffers_Optimization_Fixed_Point)); Declare_Subunit (RUD (RU_CORBA_IDL_Sequences_IDL_SEQUENCE_Any)); Declare_Subunit (RUD (RU_CORBA_IDL_Sequences_IDL_SEQUENCE_Boolean)); Declare_Subunit (RUD (RU_CORBA_IDL_Sequences_IDL_SEQUENCE_Char)); Declare_Subunit (RUD (RU_CORBA_IDL_Sequences_IDL_SEQUENCE_Wide_Char)); Declare_Subunit (RUD (RU_CORBA_IDL_Sequences_IDL_SEQUENCE_Octet)); Declare_Subunit (RUD (RU_CORBA_IDL_Sequences_IDL_SEQUENCE_Short)); Declare_Subunit (RUD (RU_CORBA_IDL_Sequences_IDL_SEQUENCE_Unsigned_Short)); Declare_Subunit (RUD (RU_CORBA_IDL_Sequences_IDL_SEQUENCE_Long)); Declare_Subunit (RUD (RU_CORBA_IDL_Sequences_IDL_SEQUENCE_Unsigned_Long)); Declare_Subunit (RUD (RU_CORBA_IDL_Sequences_IDL_SEQUENCE_Long_Long)); Declare_Subunit (RUD (RU_CORBA_IDL_Sequences_IDL_SEQUENCE_Unsigned_Long_Long)); Declare_Subunit (RUD (RU_CORBA_IDL_Sequences_IDL_SEQUENCE_Float)); Declare_Subunit (RUD (RU_CORBA_IDL_Sequences_IDL_SEQUENCE_Double)); Declare_Subunit (RUD (RU_CORBA_IDL_Sequences_IDL_SEQUENCE_Long_Double)); Declare_Subunit (RUD (RU_CORBA_IDL_Sequences_IDL_SEQUENCE_String)); Declare_Subunit (RUD (RU_CORBA_IDL_Sequences_IDL_SEQUENCE_Wide_String)); Declare_Subunit (RUD (RU_CORBA_Repository_Root_IDLType_Convert_Forward)); Declare_Subunit (RUD (RU_CORBA_Repository_Root_InterfaceDef_Convert_Forward)); RED (RE_Id'First) := No_Node; for E in RE_Id'Succ (RE_Id'First) .. RE_Id'Last loop case E is when RE_Add => Set_Str_To_Name_Buffer (Quoted ("+")); when RE_And => Set_Str_To_Name_Buffer (Quoted ("&")); when others => declare RE_Id_Img : constant String := RE_Id'Image (E); begin -- Strip "RE_" prefix Set_Str_To_Name_Buffer (RE_Id_Img (RE_Id_Img'First + 3 .. RE_Id_Img'Last)); end; Apply_Casing_Rules (Name_Buffer (1 .. Name_Len)); while Name_Buffer (Name_Len) in '0' .. '9' or else Name_Buffer (Name_Len) = '_' loop Name_Len := Name_Len - 1; end loop; end case; Name := Name_Find; RED (E) := Make_Defining_Identifier (Name); if Present (RUD (RE_Unit_Table (E))) then RED (E) := Make_Selected_Component (RUD (RE_Unit_Table (E)), RED (E)); end if; end loop; -- For CORBA predefined units and CORBA predefined entities, record -- the enumerator position in the Info field of the expanded name id, to -- save time and space when fetching CORBA predefined entities. for U in CORBA_Predefined_RU'Range loop Get_Name_String (To_Lower (Fully_Qualified_Name (RUD (U)))); Add_Str_To_Name_Buffer (CORBA_Predefined_RU_Suffix); Name := Name_Find; Set_Name_Table_Info (Name, CORBA_Predefined_RU'Pos (U)); end loop; for E in CORBA_Predefined_RE'Range loop Get_Name_String (To_Lower (Fully_Qualified_Name (RED (E)))); Add_Str_To_Name_Buffer (CORBA_Predefined_RE_Suffix); Name := Name_Find; Set_Name_Table_Info (Name, CORBA_Predefined_RE'Pos (E)); end loop; end Initialize; -------- -- RE -- -------- function RE (Id : RE_Id; Withed : Boolean := True) return Node_Id is begin return Copy_Expanded_Name (RED (Id), Withed); end RE; -------------------------- -- Register_Casing_Rule -- -------------------------- procedure Register_Casing_Rule (S : String) is begin Rules_Last := Rules_Last + 1; Rules (Rules_Last).Size := S'Length; Rules (Rules_Last).Into := new String'(S); Rules (Rules_Last).From := new String'(S); To_Lower (Rules (Rules_Last).From.all); end Register_Casing_Rule; -------- -- RU -- -------- function RU (Id : RU_Id; Withed : Boolean := True) return Node_Id is Result : Node_Id; begin -- This is a runtime unit and not a runtime entity, so it's -- parent unit does not have to be "withed" Result := Copy_Expanded_Name (RUD (Id), False); if Withed then Add_With_Package (Result); end if; return Result; end RU; end Backend.BE_CORBA_Ada.Runtime; polyorb-2.8~20110207.orig/compilers/iac/parser.ads0000644000175000017500000000464511750740337021137 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P A R S E R -- -- -- -- S p e c -- -- -- -- Copyright (C) 2005-2008, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with Locations; use Locations; with Types; use Types; with Lexer; use Lexer; package Parser is function Resolve_Base_Type (L : Token_List_Type; Loc : Location) return Node_Id; -- Take the sequence of tokens in the parameter list to return a new node -- for the IDL predefined type. procedure Process (IDL_Spec : out Node_Id); -- Process the IDL specification end Parser; polyorb-2.8~20110207.orig/compilers/iac/backend-be_types.adb0000644000175000017500000004321411750740337023014 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- B A C K E N D . B E _ T Y P E S -- -- -- -- B o d y -- -- -- -- Copyright (C) 2005-2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with GNAT.OS_Lib; use GNAT.OS_Lib; with Output; use Output; with Errors; use Errors; with Namet; use Namet; with Locations; use Locations; with Scopes; use Scopes; with Frontend.Nutils; use Frontend.Nutils; with Frontend.Nodes; use Frontend.Nodes; package body Backend.BE_Types is -- Local variables declarations -- Declare a string to represent -- all the types of an idl file. Idl_Void : constant String := "VOID"; Idl_Short : constant String := "SHORT"; Idl_Long : constant String := "LONG"; Idl_Longlong : constant String := "LONGLONG"; Idl_Ushort : constant String := "USHORT"; Idl_Ulong : constant String := "ULONG"; Idl_Ulonglong : constant String := "ULONGLONG"; Idl_LongDouble : constant String := "LONGDOUBLE"; Idl_Float : constant String := "FLOAT"; Idl_Double : constant String := "DOUBLE"; Idl_Boolean : constant String := "BOOLEAN"; Idl_Char : constant String := "CHAR"; Idl_WChar : constant String := "WCHAR"; Idl_String : constant String := "STRING"; Idl_WString : constant String := "WSTRING"; Idl_Octet : constant String := "OCTET"; Idl_Any : constant String := "ANY"; Idl_Object : constant String := "OBJECT"; Idl_Alias : constant String := "ALIAS"; Idl_Struct : constant String := "STRUCT"; Idl_Union : constant String := "UNION"; Idl_Enum : constant String := "ENUM"; Idl_Sequence : constant String := "SEQUENCE"; Idl_Array : constant String := "ARRAY_T"; Idl_Except : constant String := "EXCEPT"; Idl_Fixed : constant String := "FIXED"; Idl_Value : constant String := "VALUE"; Idl_Valuebox : constant String := "VALUEBOX"; Idl_Native : constant String := "NATIVE"; Idl_Typecode : constant String := "TYPECODE"; -- Not yet implemented -- idl_Principal : constant String := "PRINCIPAL"; -- Idl_Typecode : constant String := "TYPECODE"; -- Idl_Abstract_Interface : constant String := "ABS_INTERFACE"; -- Idl_Local_Interface : constant String := "LOC_INTERFACE"; -- Idl_Component : constant String := "COMPONENT"; -- Idl_Home : constant String := "HOME"; -- Idl_Event : constant String := "EVENT"; -- Local operations declarations procedure Generate (E : Node_Id; L : in out List_Id); procedure Generate_Base_Type (E : Node_Id; L : List_Id); procedure Generate_Exception_Declaration (E : Node_Id; L : in out List_Id); procedure Generate_Interface_Declaration (E : Node_Id; L : in out List_Id); procedure Generate_Module (E : Node_Id; L : in out List_Id); procedure Generate_Operation_Declaration (E : Node_Id; L : in out List_Id); procedure Generate_Structure_Type (E : Node_Id; L : in out List_Id); procedure Generate_Switch_Alternative (E : Node_Id; L : in out List_Id); procedure Generate_Type_Declaration (E : Node_Id; L : in out List_Id); procedure Generate_Union_Type (E : Node_Id; L : in out List_Id); procedure Generate_Value_Declaration (E : Node_Id; L : in out List_Id); procedure Insert (S : String; L : List_Id); -- Append the Node_Kind to the list only if the Node_Kind -- is not present yet. -- ??? bogus comment, there is no Node_Kind anywhere in this declaration procedure Print_List (L : List_Id; Output : File_Descriptor := Standout); -- Print the list on a file descriptor. By default that is -- the standard output. procedure Insert_Required_Types (L : List_Id); -- Insert the types always required by PolyORB for a CORBA application. ------------ -- Insert -- ------------ procedure Insert (S : String; L : List_Id) is Node : Node_Id; N : Name_Id; begin Set_Str_To_Name_Buffer (S); N := Name_Find; if Get_Name_Table_Info (N) = 0 then Set_Name_Table_Info (N, 1); Node := New_Node (K_Identifier, No_Location); Set_Name (Node, N); Append_To (L, Node); end if; end Insert; ---------------- -- Print_List -- ---------------- procedure Print_List (L : List_Id; Output : File_Descriptor := Standout) is Node : Node_Id := First_Entity (L); begin Set_Output (Output); while Present (Node) loop Get_Name_String (Name (Node)); if Output /= Standout then Write_Line (Name_Buffer (1 .. Name_Len) & " := True"); else Write_Line (Name_Buffer (1 .. Name_Len)); end if; Node := Next_Entity (Node); end loop; Set_Standard_Output; end Print_List; --------------------------- -- Insert_Required_Types -- --------------------------- procedure Insert_Required_Types (L : List_Id) is begin -- The string type and thus unsigned long are always used -- but they can not appear in the idl file. So we add them into -- the list. Note that if the type string is present in the list, -- this operation has no effect on the type list. Insert (Idl_String, L); Insert (Idl_Ulong, L); -- The any type is always needed when building TypeCode variables. Insert (Idl_Any, L); end Insert_Required_Types; -------------- -- Generate -- -------------- procedure Generate (E : Node_Id) is List_Of_Types : List_Id := New_List (No_Location); Descriptor : File_Descriptor; Output_File : constant String := Get_Name_String (IDL_Spec_Name) & ".typ"; begin Generate (E, List_Of_Types); -- Insert the types always required Insert_Required_Types (List_Of_Types); if Print_Types then Print_List (List_Of_Types); end if; -- Open the temporary file Descriptor := Create_File (Output_File, Text); -- Check the file descriptor if Descriptor = Invalid_FD then DE ("cannot create file: %", Output_File); raise Fatal_Error; end if; -- Write into a temporary file the symbols corresponding -- to the types present in the idl file. -- This file will be passed to the gnat preprocessor -- to eliminate the useless code. Print_List (List_Of_Types, Descriptor); Close (Descriptor); end Generate; -------------- -- Generate -- -------------- procedure Generate (E : Node_Id; L : in out List_Id) is begin case Kind (E) is when K_Attribute_Declaration => Generate (Type_Spec (E), L); when K_Complex_Declarator => Insert (Idl_Array, L); Insert (Idl_Ulong, L); when K_Constant_Declaration => Generate (Type_Spec (E), L); when K_Element => Generate (Type_Spec (E), L); when K_Enumeration_Type => Insert (Idl_Enum, L); Insert (Idl_String, L); Insert (Idl_Ulong, L); when K_Exception_Declaration => Generate_Exception_Declaration (E, L); when K_Fixed_Point_Type => Insert (Idl_Fixed, L); Insert (Idl_Ushort, L); Insert (Idl_Short, L); when K_Interface_Declaration => Generate_Interface_Declaration (E, L); when K_Member | K_State_Member => Generate (Type_Spec (E), L); when K_Module => Generate_Module (E, L); when K_Operation_Declaration | K_Initializer_Declaration => Generate_Operation_Declaration (E, L); when K_Native_Type => Insert (Idl_Native, L); Insert (Idl_String, L); Insert (Idl_Ulong, L); when K_Parameter_Declaration => Generate (Type_Spec (E), L); when K_Simple_Declarator => Insert (Idl_Alias, L); Insert (Idl_String, L); Insert (Idl_Ulong, L); when K_Sequence_Type => Insert (Idl_Sequence, L); Insert (Idl_Ulong, L); Generate (Type_Spec (E), L); when K_Specification => Generate_Module (E, L); when K_String_Type => Insert (Idl_String, L); Insert (Idl_Ulong, L); when K_Wide_String_Type => Insert (Idl_WString, L); Insert (Idl_Ulong, L); when K_Structure_Type => Generate_Structure_Type (E, L); when K_Switch_Alternative => Generate_Switch_Alternative (E, L); when K_Type_Declaration => Generate_Type_Declaration (E, L); when K_Union_Type => Generate_Union_Type (E, L); when K_Value_Declaration | K_Abstract_Value_Declaration => Generate_Value_Declaration (E, L); when K_Value_Box_Declaration => Insert (Idl_Valuebox, L); Insert (Idl_String, L); Insert (Idl_Ulong, L); when K_Float .. K_Value_Base => Generate_Base_Type (E, L); when others => Dummy (E); end case; end Generate; ------------------------ -- Generate_Base_Type -- ------------------------ procedure Generate_Base_Type (E : Node_Id; L : List_Id) is begin case Kind (E) is when K_Float => Insert (Idl_Float, L); when K_Double => Insert (Idl_Double, L); when K_Long_Double => Insert (Idl_LongDouble, L); when K_Short => Insert (Idl_Short, L); when K_Long => Insert (Idl_Long, L); when K_Long_Long => Insert (Idl_Longlong, L); when K_Unsigned_Short => Insert (Idl_Ushort, L); when K_Unsigned_Long => Insert (Idl_Ulong, L); when K_Unsigned_Long_Long => Insert (Idl_Ulonglong, L); when K_Char => Insert (Idl_Char, L); when K_Wide_Char => Insert (Idl_WChar, L); when K_String => Insert (Idl_String, L); Insert (Idl_Ulong, L); when K_Wide_String => Insert (Idl_WString, L); Insert (Idl_Ulong, L); when K_Boolean => Insert (Idl_Boolean, L); when K_Octet => Insert (Idl_Octet, L); when K_Object => Insert (Idl_Object, L); Insert (Idl_String, L); Insert (Idl_Ulong, L); Insert (Idl_Typecode, L); when K_Any => Insert (Idl_Any, L); when K_Void => Insert (Idl_Void, L); when others => raise Program_Error; end case; end Generate_Base_Type; ------------------------------------ -- Generate_Exception_Declaration -- ------------------------------------ procedure Generate_Exception_Declaration (E : Node_Id; L : in out List_Id) is C : Node_Id; LL : List_Id; begin Insert (Idl_Except, L); Insert (Idl_String, L); Insert (Idl_Ulong, L); LL := Members (E); C := First_Entity (LL); while Present (C) loop Generate (C, L); C := Next_Entity (C); end loop; end Generate_Exception_Declaration; ------------------------------------ -- Generate_Interface_Declaration -- ------------------------------------ procedure Generate_Interface_Declaration (E : Node_Id; L : in out List_Id) is F : Node_Id := No_Node; B : List_Id; begin B := Interface_Body (E); if not Is_Empty (B) then F := First_Entity (B); while Present (F) loop Generate (F, L); F := Next_Entity (F); end loop; end if; end Generate_Interface_Declaration; --------------------- -- Generate_Module -- --------------------- procedure Generate_Module (E : Node_Id; L : in out List_Id) is C : Node_Id; LL : List_Id; begin LL := Definitions (E); if not Is_Empty (LL) then C := First_Entity (LL); while Present (C) loop Generate (C, L); C := Next_Entity (C); end loop; end if; end Generate_Module; ------------------------------------ -- Generate_Operation_Declaration -- ------------------------------------ procedure Generate_Operation_Declaration (E : Node_Id; L : in out List_Id) is C : Node_Id; LL : List_Id; begin if Kind (E) /= K_Initializer_Declaration then Generate (Type_Spec (E), L); end if; LL := Parameters (E); if not Is_Empty (LL) then C := First_Entity (LL); loop Generate (C, L); C := Next_Entity (C); exit when No (C); end loop; end if; end Generate_Operation_Declaration; ----------------------------- -- Generate_Structure_Type -- ----------------------------- procedure Generate_Structure_Type (E : Node_Id; L : in out List_Id) is LL : List_Id; C : Node_Id; begin Insert (Idl_Struct, L); Insert (Idl_String, L); Insert (Idl_Ulong, L); LL := Members (E); if not Is_Empty (LL) then C := First_Entity (LL); while Present (C) loop Generate (C, L); C := Next_Entity (C); end loop; end if; end Generate_Structure_Type; --------------------------------- -- Generate_Switch_Alternative -- --------------------------------- procedure Generate_Switch_Alternative (E : Node_Id; L : in out List_Id) is LL : Node_Id := First_Entity (Labels (E)); begin while Present (LL) loop Generate (LL, L); LL := Next_Entity (LL); end loop; Generate (Element (E), L); end Generate_Switch_Alternative; ------------------------------- -- Generate_Type_Declaration -- ------------------------------- procedure Generate_Type_Declaration (E : Node_Id; L : in out List_Id) is D : Node_Id := First_Entity (Declarators (E)); begin Generate (Type_Spec (E), L); loop Generate (D, L); D := Next_Entity (D); exit when No (D); end loop; end Generate_Type_Declaration; ------------------------- -- Generate_Union_Type -- ------------------------- procedure Generate_Union_Type (E : Node_Id; L : in out List_Id) is N : Node_Id := First_Entity (Switch_Type_Body (E)); begin Insert (Idl_Union, L); Insert (Idl_Long, L); Insert (Idl_String, L); Insert (Idl_Ulong, L); Generate (Switch_Type_Spec (E), L); while Present (N) loop Generate (N, L); N := Next_Entity (N); end loop; end Generate_Union_Type; -------------------------------- -- Generate_Value_Declaration -- -------------------------------- procedure Generate_Value_Declaration (E : Node_Id; L : in out List_Id) is N : Node_Id; LL : List_Id; begin Insert (Idl_Value, L); Insert (Idl_String, L); Insert (Idl_Ulong, L); Insert (Idl_Short, L); LL := Value_Body (E); if not Is_Empty (LL) then N := First_Entity (LL); while Present (N) loop Generate (N, L); N := Next_Entity (N); end loop; end if; end Generate_Value_Declaration; procedure Usage (Indent : Natural) is Hdr : constant String (1 .. Indent - 1) := (others => ' '); begin Write_Str (Hdr); Write_Str ("-p Print the list generated"); Write_Eol; end Usage; end Backend.BE_Types; polyorb-2.8~20110207.orig/compilers/iac/backend-be_corba_ada-impls.adb0000644000175000017500000004070111750740337024663 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- B A C K E N D . B E _ C O R B A _ A D A . I M P L S -- -- -- -- B o d y -- -- -- -- Copyright (C) 2005-2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with Namet; use Namet; with Frontend.Nodes; use Frontend.Nodes; with Frontend.Nutils; with Backend.BE_CORBA_Ada.IDL_To_Ada; use Backend.BE_CORBA_Ada.IDL_To_Ada; with Backend.BE_CORBA_Ada.Nodes; use Backend.BE_CORBA_Ada.Nodes; with Backend.BE_CORBA_Ada.Nutils; use Backend.BE_CORBA_Ada.Nutils; with Backend.BE_CORBA_Ada.Runtime; use Backend.BE_CORBA_Ada.Runtime; with Backend.BE_CORBA_Ada.Stubs; package body Backend.BE_CORBA_Ada.Impls is package FEN renames Frontend.Nodes; package BEN renames Backend.BE_CORBA_Ada.Nodes; package FEU renames Frontend.Nutils; function Is_A_Spec return Node_Id; -- Used in the case of local interfaces to override the Is_A -- function of the abstract parent type. package body Package_Spec is procedure Visit_Interface_Declaration (E : Node_Id); procedure Visit_Module (E : Node_Id); procedure Visit_Operation_Declaration (E : Node_Id; Binding : Boolean := True); procedure Visit_Specification (E : Node_Id); ----------- -- Visit -- ----------- procedure Visit (E : Node_Id) is begin case FEN.Kind (E) is when K_Interface_Declaration => Visit_Interface_Declaration (E); when K_Module => Visit_Module (E); when K_Operation_Declaration => Visit_Operation_Declaration (E); when K_Specification => Visit_Specification (E); when others => null; end case; end Visit; --------------------------------- -- Visit_Interface_Declaration -- --------------------------------- procedure Visit_Interface_Declaration (E : Node_Id) is N : Node_Id; I : Node_Id; D : Node_Id; L : List_Id; P : Node_Id; Elaborate_Body_Required : Boolean := True; -- Set False as soon as an operation or attribute is encountered. -- If True after processing all declarations, need to generate a -- pragma Elaborate_Body for this impl. begin -- No Impl package is generated for an abstract interface if FEN.Is_Abstract_Interface (E) then return; end if; N := BEN.Parent (Type_Def_Node (BE_Node (Identifier (E)))); Push_Entity (BEN.IDL_Unit (Package_Declaration (N))); Set_Impl_Spec; -- Handling the case of inherited interfaces. L := Interface_Spec (E); if FEU.Is_Empty (L) then P := Map_Impl_Type_Ancestor (E); else -- We look whether The first parent is CORBA entity P := Map_Predefined_CORBA_Entity (First_Entity (L), Implem => True); if No (P) then P := Expand_Designator (Impl_Node (BE_Node (Identifier (Reference (First_Entity (L)))))); end if; end if; -- The Object (or LocalObject) type -- Always declaring Object, never LocalObject??? -- Note that Skel code relies on this being the case??? I := Make_Defining_Identifier (TN (T_Object)); N := Make_Full_Type_Declaration (I, Make_Derived_Type_Definition (Subtype_Indication => P, Is_Private_Extension => True)); Bind_FE_To_BE (Identifier (E), N, B_Impl); Append_To (Visible_Part (Current_Package), N); -- The Object_Ptr type D := Copy_Node (I); N := Make_Full_Type_Declaration (Make_Defining_Identifier (TN (T_Object_Ptr)), Make_Access_Type_Definition (Make_Attribute_Reference (D, A_Class), Is_All => True)); Append_To (Visible_Part (Current_Package), N); -- The record type definition I := Copy_Node (I); Set_Str_To_Name_Buffer ("Insert components to hold the state" & " of the implementation object."); N := Make_Ada_Comment (Name_Find); N := Make_Full_Type_Declaration (I, Make_Derived_Type_Definition (Subtype_Indication => P, Record_Extension_Part => Make_Record_Definition (New_List (N, New_Node (K_Null_Statement))))); Append_To (Private_Part (Current_Package), N); N := First_Entity (Interface_Body (E)); while Present (N) loop Visit (N); if FEN.Kind (N) = K_Operation_Declaration or else FEN.Kind (N) = K_Attribute_Declaration then Elaborate_Body_Required := False; end if; N := Next_Entity (N); end loop; -- Add a pragma Elaborate_Body if needed if Elaborate_Body_Required then Prepend_To (Visible_Part (Current_Package), Make_Pragma (Pragma_Elaborate_Body)); end if; -- In case of multiple inheritance, generate the mappings -- for the operations and attributes of the parents except -- the first one. Map_Inherited_Entities_Specs (Current_Interface => E, Visit_Operation_Subp => Visit_Operation_Declaration'Access, Impl => True); -- The Is_A spec in the case of local interfaces if Is_Local_Interface (E) then N := Is_A_Spec; Append_To (Visible_Part (Current_Package), N); end if; Pop_Entity; end Visit_Interface_Declaration; ------------------ -- Visit_Module -- ------------------ procedure Visit_Module (E : Node_Id) is D : Node_Id; begin if not Map_Particular_CORBA_Parts (E, PK_Impl_Spec) then Push_Entity (Stub_Node (BE_Node (Identifier (E)))); D := First_Entity (Definitions (E)); while Present (D) loop Visit (D); D := Next_Entity (D); end loop; Pop_Entity; end if; end Visit_Module; --------------------------------- -- Visit_Operation_Declaration -- --------------------------------- procedure Visit_Operation_Declaration (E : Node_Id; Binding : Boolean := True) is Stub : Node_Id; Subp_Spec : Node_Id; Profile : List_Id; Stub_Param : Node_Id; Impl_Param : Node_Id; Returns : Node_Id := No_Node; Type_Designator : Node_Id; begin Stub := Stub_Node (BE_Node (Identifier (E))); Set_Impl_Spec; Profile := New_List; -- Create a dispatching parameter Impl_Param := Make_Parameter_Specification (Make_Defining_Identifier (PN (P_Self)), Make_Access_Type_Definition (Make_Defining_Identifier (TN (T_Object)), Is_Not_Null => True)); Append_To (Profile, Impl_Param); Stub_Param := Next_Node (First_Node (Parameter_Profile (Stub))); while Present (Stub_Param) loop Type_Designator := Copy_Expanded_Name (Parameter_Type (Stub_Param)); Impl_Param := Make_Parameter_Specification (Copy_Node (Defining_Identifier (Stub_Param)), Type_Designator, BEN.Parameter_Mode (Stub_Param)); Append_To (Profile, Impl_Param); Stub_Param := Next_Node (Stub_Param); end loop; if Present (Return_Type (Stub)) then Returns := Copy_Expanded_Name (Return_Type (Stub)); end if; Set_Impl_Spec; Subp_Spec := Make_Subprogram_Specification (Copy_Node (Defining_Identifier (Stub)), Profile, Returns); Append_To (Visible_Part (Current_Package), Subp_Spec); if Binding then Bind_FE_To_BE (Identifier (E), Subp_Spec, B_Impl); end if; end Visit_Operation_Declaration; ------------------------- -- Visit_Specification -- ------------------------- procedure Visit_Specification (E : Node_Id) is Definition : Node_Id; begin Push_Entity (Stub_Node (BE_Node (Identifier (E)))); Definition := First_Entity (Definitions (E)); while Present (Definition) loop Visit (Definition); Definition := Next_Entity (Definition); end loop; Pop_Entity; end Visit_Specification; end Package_Spec; package body Package_Body is procedure Visit_Interface_Declaration (E : Node_Id); procedure Visit_Module (E : Node_Id); procedure Visit_Operation_Declaration (E : Node_Id); procedure Visit_Specification (E : Node_Id); ----------- -- Visit -- ----------- procedure Visit (E : Node_Id) is begin case FEN.Kind (E) is when K_Interface_Declaration => Visit_Interface_Declaration (E); when K_Module => Visit_Module (E); when K_Operation_Declaration => Visit_Operation_Declaration (E); when K_Specification => Visit_Specification (E); when others => null; end case; end Visit; --------------------------------- -- Visit_Interface_Declaration -- --------------------------------- procedure Visit_Interface_Declaration (E : Node_Id) is N : Node_Id; begin -- No Impl package is generated for an abstract interface if FEN.Is_Abstract_Interface (E) then return; end if; N := BEN.Parent (Type_Def_Node (BE_Node (Identifier (E)))); Push_Entity (BEN.IDL_Unit (Package_Declaration (N))); Set_Impl_Body; -- First of all we add a with clause for the Skel package to -- force the skeleton elaboration (only in the case whether -- this package exists). if not FEN.Is_Local_Interface (E) then Add_With_Package (Expand_Designator (Skeleton_Package (Current_Entity)), Unreferenced => True); end if; N := First_Entity (Interface_Body (E)); while Present (N) loop Visit (N); N := Next_Entity (N); end loop; -- In case of multiple inheritance, generate the mappings -- for the operations and attributes of the parents except -- the first one. Map_Inherited_Entities_Bodies (Current_Interface => E, Visit_Operation_Subp => Visit_Operation_Declaration'Access, Impl => True); -- For local interfaces, the body of the Is_A function if Is_Local_Interface (E) then N := Stubs.Local_Is_A_Body (E, Is_A_Spec); Append_To (Statements (Current_Package), N); end if; Pop_Entity; end Visit_Interface_Declaration; ------------------ -- Visit_Module -- ------------------ procedure Visit_Module (E : Node_Id) is D : Node_Id; begin if not Map_Particular_CORBA_Parts (E, PK_Impl_Body) then Push_Entity (Stub_Node (BE_Node (Identifier (E)))); D := First_Entity (Definitions (E)); while Present (D) loop Visit (D); D := Next_Entity (D); end loop; Pop_Entity; end if; end Visit_Module; --------------------------------- -- Visit_Operation_Declaration -- --------------------------------- procedure Visit_Operation_Declaration (E : Node_Id) is Stub : Node_Id; Subp_Spec : Node_Id; Returns : Node_Id := No_Node; D : constant List_Id := New_List; S : constant List_Id := New_List; N : Node_Id; begin Stub := Stub_Node (BE_Node (Identifier (E))); Subp_Spec := Impl_Node (BE_Node (Identifier (E))); if Present (Return_Type (Stub)) then Returns := Copy_Expanded_Name (Return_Type (Stub)); if Kind (Returns) = K_Attribute_Reference then Returns := Prefix (Returns); end if; N := Make_Pragma (Pragma_Warnings, New_List (RE (RE_Off))); Append_To (D, N); N := Make_Object_Declaration (Defining_Identifier => Make_Defining_Identifier (VN (V_Result)), Object_Definition => Returns); Append_To (D, N); N := Make_Subprogram_Call (Make_Defining_Identifier (GN (Pragma_Warnings)), New_List (RE (RE_On))); N := Make_Pragma (Pragma_Warnings, New_List (RE (RE_On))); Append_To (D, N); N := Make_Return_Statement (Make_Defining_Identifier (VN (V_Result))); Append_To (S, N); end if; Set_Impl_Body; N := Make_Subprogram_Body (Subp_Spec, D, S); Append_To (Statements (Current_Package), N); end Visit_Operation_Declaration; ------------------------- -- Visit_Specification -- ------------------------- procedure Visit_Specification (E : Node_Id) is Definition : Node_Id; begin Push_Entity (Stub_Node (BE_Node (Identifier (E)))); Definition := First_Entity (Definitions (E)); while Present (Definition) loop Visit (Definition); Definition := Next_Entity (Definition); end loop; Pop_Entity; end Visit_Specification; end Package_Body; --------------- -- Is_A_Spec -- --------------- function Is_A_Spec return Node_Id is N : Node_Id; Profile : List_Id; Param : Node_Id; begin Profile := New_List; Param := Make_Parameter_Specification (Make_Defining_Identifier (PN (P_Self)), Make_Access_Type_Definition (Make_Defining_Identifier (TN (T_Object)), Is_Not_Null => True)); Append_To (Profile, Param); Param := Make_Parameter_Specification (Make_Defining_Identifier (PN (P_Logical_Type_Id)), RE (RE_String_2)); Append_To (Profile, Param); N := Make_Subprogram_Specification (Make_Defining_Identifier (SN (S_Is_A)), Profile, RE (RE_Boolean_2)); return N; end Is_A_Spec; end Backend.BE_CORBA_Ada.Impls; polyorb-2.8~20110207.orig/compilers/iac/backend-be_corba_ada-nutils.adb0000644000175000017500000023527011750740337025064 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- B A C K E N D . B E _ C O R B A _ A D A . N U T I L S -- -- -- -- B o d y -- -- -- -- Copyright (C) 2005-2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with GNAT.Table; with GNAT.Case_Util; with Charset; use Charset; with Flags; use Flags; with Locations; use Locations; with Namet; use Namet; with Output; use Output; with Utils; use Utils; with Values; use Values; with Frontend.Nutils; with Backend.BE_CORBA_Ada.IDL_To_Ada; use Backend.BE_CORBA_Ada.IDL_To_Ada; with Platform; package body Backend.BE_CORBA_Ada.Nutils is package FEN renames Frontend.Nodes; package FEU renames Frontend.Nutils; package BEN renames Backend.BE_CORBA_Ada.Nodes; type Entity_Stack_Entry is record Current_Package : Node_Id; Current_Entity : Node_Id; end record; Forwarded_Entities : List_Id := No_List; -- This list contains the forwarded entities Ada_Keyword_Prefix : constant String := "%ada_kw%"; -- Prefix used to "mark" ada keywords No_Depth : constant Int := -1; package Entity_Stack is new GNAT.Table (Entity_Stack_Entry, Int, No_Depth + 1, 10, 10); use Entity_Stack; -- The following strings are included in internally generated identifiers -- to create names that are guaranteed never to clash with any legal -- IDL identifier. Latin_1_Unique_String : constant String := (1 => Character'Val (16#DC#)); Latin_1_Unique_Suffix : aliased constant String := "_" & Latin_1_Unique_String; Latin_1_Unique_Infix : aliased constant String := Latin_1_Unique_Suffix & "_"; UTF_8_Unique_String : constant String := (Character'Val (16#C3#), Character'Val (16#9C#)); UTF_8_Unique_Suffix : aliased constant String := "_" & UTF_8_Unique_String; UTF_8_Unique_Infix : aliased constant String := UTF_8_Unique_Suffix & "_"; -- The following are returned by the Unique_Suffix and Unique_Infix -- functions. We initialize them to the default Latin_1 values, and if -- -gnatW8 is given on the command line, they get set to the UTF_8 values. The_Unique_Suffix : access constant String := Latin_1_Unique_Suffix'Access; The_Unique_Infix : access constant String := Latin_1_Unique_Infix'Access; procedure New_Operator (Op : Operator_Type; I : String := ""); function Internal_Name (P : Node_Id; L : GLists) return Name_Id; pragma Inline (Internal_Name); -- Return an unique internal name useful for the binding between P and L ------------------------ -- Add_Prefix_To_Name -- ------------------------ function Add_Prefix_To_Name (Prefix : String; Name : Name_Id) return Name_Id is begin Set_Str_To_Name_Buffer (Prefix); Get_Name_String_And_Append (Name); return Name_Find; end Add_Prefix_To_Name; ------------------------ -- Add_Suffix_To_Name -- ------------------------ function Add_Suffix_To_Name (Suffix : String; Name : Name_Id) return Name_Id is begin Get_Name_String (Name); Add_Str_To_Name_Buffer (Suffix); return Name_Find; end Add_Suffix_To_Name; ----------------------------- -- Remove_Suffix_From_Name -- ----------------------------- function Remove_Suffix_From_Name (Suffix : String; Name : Name_Id) return Name_Id is Length : Natural; Temp_Str : String (1 .. Suffix'Length); begin Set_Str_To_Name_Buffer (Suffix); Length := Name_Len; Get_Name_String (Name); if Name_Len > Length then Temp_Str := Name_Buffer (Name_Len - Length + 1 .. Name_Len); if Suffix = Temp_Str then Set_Str_To_Name_Buffer (Name_Buffer (1 .. Name_Len - Length)); return Name_Find; end if; end if; return Name; end Remove_Suffix_From_Name; ---------------------- -- Add_With_Package -- ---------------------- procedure Add_With_Package (E : Node_Id; Unreferenced : Boolean := False) is function Get_String_Name (The_String : String) return Name_Id; -- Return the Name_Id associated to The_String function To_Library_Unit (E : Node_Id) return Node_Id; -- Return the library unit which E belongs to in order to with -- it. As a special rule, package Standard returns No_Node. --------------------- -- Get_String_Name -- --------------------- function Get_String_Name (The_String : String) return Name_Id is pragma Assert (The_String'Length > 0); Result : Name_Id; begin Set_Str_To_Name_Buffer (The_String); Result := Name_Find; return Result; end Get_String_Name; --------------------- -- To_Library_Unit -- --------------------- function To_Library_Unit (E : Node_Id) return Node_Id is U : Node_Id; begin pragma Assert (Kind (E) = K_Defining_Identifier or else Kind (E) = K_Selected_Component); U := Get_Declaration_Node (E); -- This node is not properly built as the corresponding node -- is not set. if No (U) then if Output_Tree_Warnings then Write_Str ("WARNING: node "); Write_Name (Name (E)); Write_Line (" has a null corresponding node"); end if; return E; end if; if BEN.Kind (U) = K_Package_Declaration then U := Package_Specification (U); end if; pragma Assert (Kind (U) = K_Package_Specification or else Kind (U) = K_Package_Instantiation); -- This is a subunit and we do not need to add a with for -- this unit but for one of its parents. If the kind of the -- parent unit name is a K_Package_Instantiation, we -- consider it as a subunit. if Kind (U) = K_Package_Instantiation or else Is_Subunit_Package (U) then U := Get_Parent_Unit_Name (E); -- This is a special case to handle package Standard if No (U) then return No_Node; end if; return To_Library_Unit (U); end if; return E; end To_Library_Unit; P : constant Node_Id := To_Library_Unit (E); W : Node_Id; N : Name_Id; B : Byte; D : Node_Id; I : Node_Id; Helper_Name : Name_Id; Skel_Name : Name_Id; Impl_Name : Name_Id; CDR_Name : Name_Id; Aligned_Name : Name_Id; Buffers_Name : Name_Id; H_Internals_Name : Name_Id; IR_Info_Name : Name_Id; Force_Elaboration : Boolean := False; -- Set to true to force the addition of elaboration pragma for -- the withed package. begin if No (P) then return; end if; Helper_Name := Get_String_Name ("Helper"); Skel_Name := Get_String_Name ("Skel"); Impl_Name := Get_String_Name ("Impl"); CDR_Name := Get_String_Name ("CDR"); Aligned_Name := Get_String_Name ("Aligned"); Buffers_Name := Get_String_Name ("Buffers"); H_Internals_Name := Get_String_Name ("Internals"); IR_Info_Name := Get_String_Name ("IR_Info"); -- Build a string "%[s,b] " that -- is the current entity name, a character 's' (resp 'b') to -- indicate whether we consider the spec (resp. body) of the -- current entity and the withed entity name. D := FE_Node (P); if Present (D) then if Get_Name (P) /= Helper_Name and then Get_Name (P) /= Skel_Name and then Get_Name (P) /= Impl_Name and then Get_Name (P) /= CDR_Name and then Get_Name (P) /= Aligned_Name and then Get_Name (P) /= Buffers_Name and then Get_Name (P) /= H_Internals_Name and then Get_Name (P) /= IR_Info_Name then -- This is a local entity and there is no need for a with -- clause. if Is_N_Parent_Of_M (D, FE_Node (Current_Entity)) then return; end if; end if; end if; if Get_Declaration_Node (P) = Package_Declaration (Current_Package) then -- This means a package "with"es itself, so exit return; end if; -- Routine that checks whether the package P has already been -- added to the withed packages of the current package. When we -- add a 'with' clause to a package specification, we check -- only if this clause has been added to the current -- spec. However, when we add a 'with' clause to a package -- body, we check that the clause has been added in both the -- spec and the body. -- IMPORTANT: Provided that all specs are generated before all -- bodies, this behaviour is automatically applied. We just -- need to encode the package name *without* precising whether -- it is a spec or a body. -- Encoding the withed package and the current entity N := Fully_Qualified_Name (P); if Is_Subunit_Package (Package_Specification (Package_Declaration (Current_Package))) then -- The package is a subunit of another package, uses its -- parent's name. I := Get_Parent_Unit_Name (Defining_Identifier (Package_Declaration (Current_Package))); if Fully_Qualified_Name (I) = N then -- If true, this means a package "with"es itself, so exit return; end if; else -- else, use its own name I := Defining_Identifier (Package_Declaration (Current_Package)); end if; Get_Name_String (Fully_Qualified_Name (I)); Add_Char_To_Name_Buffer (' '); Get_Name_String_And_Append (N); N := To_Lower (Name_Find); -- Get the byte associated to the name in the hash table and -- check whether it is already set to 1 which means that the -- withed entity is already in the withed package list. B := Get_Name_Table_Byte (N); if B /= 0 then return; end if; Set_Name_Table_Byte (N, 1); if Output_Unit_Withing then Write_Name (N); Write_Eol; end if; if Get_Name (P) = Get_String_Name ("Internals") or else Get_Name (P) = Get_String_Name ("CORBA") or else Get_Name (P) = Get_String_Name ("Forward") or else Get_Name (P) = Get_String_Name ("Bounded_Strings") or else Get_Name (P) = Get_String_Name ("Bounded_Wide_Strings") or else Get_Name (P) = Get_String_Name ("Fixed_Point") or else Get_Name (P) = Get_String_Name ("CORBA_Helper") then -- Ada static elaboration rules require the addition of -- "pragma Elaborate_All" to these package. Force_Elaboration := True; end if; -- Add entity to the withed packages list W := New_Node (K_Withed_Package); Set_Defining_Identifier (W, P); Set_Elaborated (W, Force_Elaboration); if Unreferenced then Set_Unreferenced (W, V => True); end if; Append_To (Context_Clause (Current_Package), W); end Add_With_Package; --------------- -- Append_To -- --------------- procedure Append_To (L : List_Id; E : Node_Id) is Last : Node_Id; begin Last := Last_Node (L); if No (Last) then Set_First_Node (L, E); else Set_Next_Node (Last, E); end if; Last := E; while Present (Next_Node (Last)) loop Last := Next_Node (Last); end loop; Set_Last_Node (L, Last); end Append_To; ---------------- -- Prepend_To -- ---------------- procedure Prepend_To (L : List_Id; E : Node_Id) is begin pragma Assert (No (Next_Node (E))); Set_Next_Node (E, First_Node (L)); Set_First_Node (L, E); if No (Last_Node (L)) then Set_Last_Node (L, E); end if; end Prepend_To; ------------- -- Convert -- ------------- function Convert (K : FEN.Node_Kind) return RE_Id is begin case K is when FEN.K_Float => return RE_Float; when FEN.K_Double => return RE_Double; when FEN.K_Long_Double => return RE_Long_Double; when FEN.K_Short => return RE_Short; when FEN.K_Long => return RE_Long; when FEN.K_Long_Long => return RE_Long_Long; when FEN.K_Unsigned_Short => return RE_Unsigned_Short; when FEN.K_Unsigned_Long => return RE_Unsigned_Long; when FEN.K_Unsigned_Long_Long => return RE_Unsigned_Long_Long; when FEN.K_Char => return RE_Char; when FEN.K_Wide_Char => return RE_WChar; when FEN.K_String => return RE_String_0; when FEN.K_Wide_String => return RE_Wide_String; when FEN.K_Boolean => return RE_Boolean; when FEN.K_Octet => return RE_Octet; when FEN.K_Object => return RE_Ref_2; when FEN.K_Any => return RE_Any; when others => raise Program_Error; end case; end Convert; ------------------------ -- Copy_Expanded_Name -- ------------------------ function Copy_Expanded_Name (N : Node_Id; Withed : Boolean := True) return Node_Id is D : Node_Id; P : Node_Id := Get_Parent_Unit_Name (N); begin D := Copy_Node (N); if Kind (N) = K_Defining_Identifier then P := Get_Parent_Unit_Name (N); elsif Kind (N) = K_Attribute_Reference then P := Get_Parent_Unit_Name (Prefix (N)); elsif Kind (N) = K_Selected_Component then P := Prefix (N); end if; if Present (P) then P := Copy_Expanded_Name (P, False); if Withed then Add_With_Package (P); end if; end if; return D; end Copy_Expanded_Name; --------------- -- Copy_Node -- --------------- function Copy_Node (N : Node_Id) return Node_Id is C : Node_Id; begin case Kind (N) is when K_Identifier => C := New_Node (K_Identifier); Set_Name (C, Name (N)); Set_FE_Node (C, FE_Node (N)); when K_Defining_Identifier => C := New_Node (K_Defining_Identifier); Set_Name (C, Name (N)); Set_Declaration_Node (C, Declaration_Node (N)); Set_FE_Node (C, FE_Node (N)); when K_Attribute_Reference => C := New_Node (K_Attribute_Reference); Set_Name (C, Name (N)); Set_Prefix (C, Copy_Node (Prefix (N))); Set_FE_Node (C, FE_Node (N)); when K_Selected_Component => C := New_Node (K_Selected_Component); Set_Selector_Name (C, Copy_Node (Selector_Name (N))); Set_Prefix (C, Copy_Node (Prefix (N))); Set_FE_Node (C, FE_Node (N)); when K_Literal => C := New_Node (K_Literal); Set_Value (C, Value (N)); Set_FE_Node (C, FE_Node (N)); when others => raise Program_Error; end case; return C; end Copy_Node; ------------------- -- Unique_Suffix -- ------------------- function Unique_Suffix return String is begin return The_Unique_Suffix.all; end Unique_Suffix; ------------------ -- Unique_Infix -- ------------------ function Unique_Infix return String is begin return The_Unique_Infix.all; end Unique_Infix; -------------------------- -- Get_Declaration_Node -- -------------------------- function Get_Declaration_Node (N : Node_Id) return Node_Id is begin case Kind (N) is when K_Defining_Identifier | K_Identifier => return Declaration_Node (N); when K_Selected_Component => if Kind (Selector_Name (N)) = K_Defining_Identifier or else Kind (Selector_Name (N)) = K_Identifier then return Declaration_Node (Selector_Name (N)); else raise Program_Error; end if; when others => raise Program_Error; end case; end Get_Declaration_Node; ------------------------- -- Get_Base_Identifier -- ------------------------- function Get_Base_Identifier (N : Node_Id) return Node_Id is begin case Kind (N) is when K_Defining_Identifier | K_Identifier => return N; when K_Selected_Component => if Kind (Selector_Name (N)) = K_Defining_Identifier or else Kind (Selector_Name (N)) = K_Identifier then return Selector_Name (N); else raise Program_Error; end if; when others => return Get_Base_Identifier (Defining_Identifier (N)); end case; end Get_Base_Identifier; -------------- -- Get_Name -- -------------- function Get_Name (N : Node_Id) return Name_Id is begin case Kind (N) is when K_Defining_Identifier | K_Identifier => return Name (N); when K_Selected_Component => if Kind (Selector_Name (N)) = K_Defining_Identifier or else Kind (Selector_Name (N)) = K_Identifier then return Name (Selector_Name (N)); else raise Program_Error; end if; when others => raise Program_Error; end case; end Get_Name; --------------- -- Get_Value -- --------------- function Get_Value (N : Node_Id) return Value_Id is begin case Kind (N) is when K_Literal => return Value (N); when K_Selected_Component => if Kind (Selector_Name (N)) = K_Literal then return Value (Selector_Name (N)); else raise Program_Error; end if; when others => raise Program_Error; end case; end Get_Value; -------------------------- -- Get_Parent_Unit_Name -- -------------------------- function Get_Parent_Unit_Name (N : Node_Id) return Node_Id is begin case Kind (N) is when K_Selected_Component => return Prefix (N); when others => return No_Node; end case; end Get_Parent_Unit_Name; -------------------- -- Current_Entity -- -------------------- function Current_Entity return Node_Id is begin if Last = No_Depth then return No_Node; else return Table (Last).Current_Entity; end if; end Current_Entity; --------------------- -- Current_Package -- --------------------- function Current_Package return Node_Id is begin if Last = No_Depth then return No_Node; else return Table (Last).Current_Package; end if; end Current_Package; ----------------------- -- Expand_Designator -- ----------------------- function Expand_Designator (N : Node_Id; Add_With_Clause : Boolean := True) return Node_Id is use Frontend.Nodes; P : Node_Id; D : Node_Id := No_Node; X : Node_Id := N; FE : Node_Id; begin case BEN.Kind (N) is when K_Full_Type_Declaration | K_Subprogram_Specification => P := Parent (X); FE := FE_Node (X); when K_Object_Declaration | K_Exception_Declaration => P := Parent (X); FE := FE_Node (X); when K_Package_Specification => X := Package_Declaration (N); P := Parent (X); FE := FE_Node (IDL_Unit (X)); when K_Package_Declaration => P := Parent (N); FE := FE_Node (IDL_Unit (X)); when K_Package_Instantiation => P := Parent (X); FE := FE_Node (X); when K_Selected_Component => -- If N is already expanded, just add the necessary with clause -- and return a copy of N. return Copy_Expanded_Name (N, Add_With_Clause); when others => raise Program_Error; end case; D := Get_Base_Identifier (Defining_Identifier (X)); if Present (FE) then Set_FE_Node (D, FE); -- Handle the case of CORBA particular entities if FEN.Kind (FE) = K_Identifier and then Present (Scope_Entity (FE)) and then FEN.Kind (Scope_Entity (FE)) = K_Module and then FEN.IDL_Name (Identifier (Scope_Entity (FE))) = CORBA_Name then D := Make_Selected_Component (RU (RU_CORBA), D); end if; end if; if No (P) then return D; end if; D := Make_Selected_Component (Expand_Designator (P, False), Get_Base_Identifier (D)); P := Get_Parent_Unit_Name (D); -- Adding the with clause if Add_With_Clause and then Present (P) then Add_With_Package (P); end if; return D; end Expand_Designator; -------------------------- -- Fully_Qualified_Name -- -------------------------- function Fully_Qualified_Name (N : Node_Id) return Name_Id is Parent_Node : Node_Id := No_Node; Parent_Name : Name_Id := No_Name; begin case Kind (N) is when K_Defining_Identifier => Parent_Node := Get_Parent_Unit_Name (N); if Present (Parent_Node) then Parent_Name := Fully_Qualified_Name (Parent_Node); end if; Name_Len := 0; if Present (Parent_Node) then Get_Name_String (Parent_Name); Add_Char_To_Name_Buffer ('.'); end if; Get_Name_String_And_Append (Name (N)); return Name_Find; when K_Attribute_Reference => Get_Name_String (Fully_Qualified_Name (Prefix (N))); Add_Char_To_Name_Buffer ('''); Get_Name_String_And_Append (Name (N)); return Name_Find; when K_Selected_Component => Get_Name_String (Fully_Qualified_Name (Prefix (N))); Add_Char_To_Name_Buffer ('.'); case Kind (Selector_Name (N)) is when K_Identifier | K_Defining_Identifier => Get_Name_String_And_Append (Name (Selector_Name (N))); when K_Literal => declare V : constant Value_Id := Value (Selector_Name (N)); begin case Value (V).K is when FEN.K_Char .. FEN.K_Wide_Char => Add_Str_To_Name_Buffer (Quoted (Image_Ada (V), ''')); when FEN.K_String .. FEN.K_Wide_String => Add_Str_To_Name_Buffer (Quoted (Image_Ada (V), '"')); when FEN.K_Enumerator => Add_Str_To_Name_Buffer (Image_Ada (V)); when others => raise Program_Error; end case; end; when others => raise Program_Error; end case; return Name_Find; when others => raise Program_Error; end case; end Fully_Qualified_Name; ----------- -- Image -- ----------- function Image (T : Token_Type) return String is S : String := Token_Type'Image (T); begin To_Lower (S); return S (5 .. S'Last); end Image; ----------- -- Image -- ----------- function Image (Op : Operator_Type) return String is S : String := Operator_Type'Image (Op); begin To_Lower (S); for I in S'First .. S'Last loop if S (I) = '_' then S (I) := ' '; end if; end loop; return S (4 .. S'Last); end Image; ------------------- -- Is_Class_Wide -- ------------------- function Is_Class_Wide (E : Node_Id) return Boolean is Orig_Type : constant Node_Id := FEU.Get_Original_Type_Specifier (FEN.Type_Spec (E)); Parent_Interface : Node_Id; use FEN; begin case FEN.Kind (E) is when K_Parameter_Declaration => Parent_Interface := Scope_Entity (Identifier (Scope_Entity (Identifier (Declarator (E))))); when K_Operation_Declaration => Parent_Interface := Scope_Entity (Identifier (E)); when others => raise Program_Error; end case; return FEN.Kind (Orig_Type) = FEN.K_Interface_Declaration and then Orig_Type = Parent_Interface; end Is_Class_Wide; ---------------- -- Initialize -- ---------------- procedure Initialize is begin if Initialized then return; else Initialized := True; end if; -- Keywords. for J in Keyword_Type loop New_Token (J); end loop; -- Graphic Characters New_Token (Tok_Double_Asterisk, "**"); New_Token (Tok_Ampersand, "&"); New_Token (Tok_Minus, "-"); New_Token (Tok_Plus, "+"); New_Token (Tok_Asterisk, "*"); New_Token (Tok_Slash, "/"); New_Token (Tok_Dot, "."); New_Token (Tok_Apostrophe, "'"); New_Token (Tok_Left_Paren, "("); New_Token (Tok_Right_Paren, ")"); New_Token (Tok_Comma, ","); New_Token (Tok_Less, "<"); New_Token (Tok_Equal, "="); New_Token (Tok_Greater, ">"); New_Token (Tok_Not_Equal, "/="); New_Token (Tok_Greater_Equal, ">="); New_Token (Tok_Less_Equal, "<="); New_Token (Tok_Box, "<>"); New_Token (Tok_Colon_Equal, ":="); New_Token (Tok_Colon, ":"); New_Token (Tok_Greater_Greater, ">>"); New_Token (Tok_Less_Less, "<<"); New_Token (Tok_Semicolon, ";"); New_Token (Tok_Arrow, "=>"); New_Token (Tok_Vertical_Bar, "|"); New_Token (Tok_Dot_Dot, ".."); New_Token (Tok_Minus_Minus, "--"); -- Keyword Operators for Op in Op_And .. Op_Or_Else loop New_Operator (Op); end loop; -- Other operators New_Operator (Op_And_Symbol, "&"); New_Operator (Op_Double_Asterisk, "**"); New_Operator (Op_Minus, "-"); New_Operator (Op_Plus, "+"); New_Operator (Op_Asterisk, "*"); New_Operator (Op_Slash, "/"); New_Operator (Op_Less, "<"); New_Operator (Op_Equal, "="); New_Operator (Op_Greater, ">"); New_Operator (Op_Not_Equal, "/="); New_Operator (Op_Greater_Equal, ">="); New_Operator (Op_Less_Equal, "<="); New_Operator (Op_Box, "<>"); New_Operator (Op_Colon_Equal, ":="); New_Operator (Op_Colon, "--"); New_Operator (Op_Greater_Greater, ">>"); New_Operator (Op_Less_Less, "<<"); New_Operator (Op_Semicolon, ";"); New_Operator (Op_Arrow, "=>"); New_Operator (Op_Vertical_Bar, "|"); -- Attributes for A in Attribute_Id loop Set_Str_To_Name_Buffer (Attribute_Id'Image (A)); Set_Str_To_Name_Buffer (Name_Buffer (3 .. Name_Len)); GNAT.Case_Util.To_Mixed (Name_Buffer (1 .. Name_Len)); AN (A) := Name_Find; end loop; -- Components for C in Component_Id loop Set_Str_To_Name_Buffer (Component_Id'Image (C)); Set_Str_To_Name_Buffer (Name_Buffer (3 .. Name_Len)); GNAT.Case_Util.To_Mixed (Name_Buffer (1 .. Name_Len)); CN (C) := Name_Find; end loop; -- Parameters for P in Parameter_Id loop Set_Str_To_Name_Buffer (Parameter_Id'Image (P)); Set_Str_To_Name_Buffer (Name_Buffer (3 .. Name_Len)); GNAT.Case_Util.To_Mixed (Name_Buffer (1 .. Name_Len)); PN (P) := Name_Find; end loop; -- Subprograms for S in Subprogram_Id loop case S is when S_Minus => Set_Str_To_Name_Buffer (Quoted ("-")); when others => Set_Str_To_Name_Buffer (Subprogram_Id'Image (S)); Set_Str_To_Name_Buffer (Name_Buffer (3 .. Name_Len)); GNAT.Case_Util.To_Mixed (Name_Buffer (1 .. Name_Len)); end case; SN (S) := Name_Find; end loop; -- Types for T in Type_Id loop Set_Str_To_Name_Buffer (Type_Id'Image (T)); Set_Str_To_Name_Buffer (Name_Buffer (3 .. Name_Len)); GNAT.Case_Util.To_Mixed (Name_Buffer (1 .. Name_Len)); TN (T) := Name_Find; end loop; -- Variables for V in Variable_Id loop Set_Str_To_Name_Buffer (Variable_Id'Image (V)); Set_Str_To_Name_Buffer (Name_Buffer (3 .. Name_Len)); Add_Str_To_Name_Buffer (Unique_Suffix); GNAT.Case_Util.To_Mixed (Name_Buffer (1 .. Name_Len)); VN (V) := Name_Find; end loop; -- Pragmas for G in Pragma_Id loop Set_Str_To_Name_Buffer (Pragma_Id'Image (G)); Set_Str_To_Name_Buffer (Name_Buffer (8 .. Name_Len)); GNAT.Case_Util.To_Mixed (Name_Buffer (1 .. Name_Len)); GN (G) := Name_Find; end loop; -- Exceptions for E in Error_Id loop Set_Str_To_Name_Buffer (Error_Id'Image (E)); Set_Str_To_Name_Buffer (Name_Buffer (3 .. Name_Len)); GNAT.Case_Util.To_Mixed (Name_Buffer (1 .. Name_Len)); EN (E) := Name_Find; end loop; -- Initialize the CORBA module entities names Set_Str_To_Name_Buffer ("CORBA"); CORBA_Name := Name_Find; Set_Str_To_Name_Buffer ("Repository_Root"); Repository_Root_Name := Name_Find; Set_Str_To_Name_Buffer ("IDL_Sequences"); IDL_Sequences_Name := Name_Find; Set_Str_To_Name_Buffer ("DomainManager"); DomainManager_Name := Name_Find; end Initialize; -------------- -- Is_Empty -- -------------- function Is_Empty (L : List_Id) return Boolean is begin return L = No_List or else No (First_Node (L)); end Is_Empty; ------------ -- Length -- ------------ function Length (L : List_Id) return Natural is N : Node_Id; C : Natural := 0; begin if not Is_Empty (L) then N := First_Node (L); while Present (N) loop C := C + 1; N := Next_Node (N); end loop; end if; return C; end Length; --------------------------------- -- Make_Access_Type_Definition -- --------------------------------- function Make_Access_Type_Definition (Subtype_Indication : Node_Id; Is_All : Boolean := False; Is_Constant : Boolean := False; Is_Not_Null : Boolean := False) return Node_Id is N : Node_Id; begin N := New_Node (K_Access_Type_Definition); Set_Subtype_Indication (N, Subtype_Indication); Set_Is_All (N, Is_All); Set_Is_Constant (N, Is_Constant); Set_Is_Not_Null (N, Is_Not_Null); return N; end Make_Access_Type_Definition; ---------------------- -- Make_Ada_Comment -- ---------------------- function Make_Ada_Comment (N : Name_Id; Has_Header_Spaces : Boolean := True) return Node_Id is C : Node_Id; begin C := New_Node (K_Ada_Comment); Set_Message (C, N); Set_Has_Header_Spaces (C, Has_Header_Spaces); return C; end Make_Ada_Comment; -------------------------- -- Make_Array_Aggregate -- -------------------------- function Make_Array_Aggregate (Elements : List_Id) return Node_Id is N : Node_Id; begin pragma Assert (not Is_Empty (Elements)); N := New_Node (K_Array_Aggregate); Set_Elements (N, Elements); return N; end Make_Array_Aggregate; -------------------------------- -- Make_Array_Type_Definition -- -------------------------------- function Make_Array_Type_Definition (Range_Constraints : List_Id; Component_Definition : Node_Id; Index_Definition : Node_Id := No_Node) return Node_Id is N : Node_Id; begin N := New_Node (K_Array_Type_Definition); Set_Range_Constraints (N, Range_Constraints); Set_Component_Definition (N, Component_Definition); Set_Index_Definition (N, Index_Definition); return N; end Make_Array_Type_Definition; --------------------------------- -- Make_String_Type_Definition -- --------------------------------- function Make_String_Type_Definition (Defining_Identifier : Node_Id; Range_Constraint : Node_Id) return Node_Id is N : Node_Id; begin N := New_Node (BEN.K_String_Type_Definition); Set_Defining_Identifier (N, Defining_Identifier); Set_Range_Constraint (N, Range_Constraint); return N; end Make_String_Type_Definition; ------------------------------- -- Make_Assignment_Statement -- ------------------------------- function Make_Assignment_Statement (Variable_Identifier : Node_Id; Expression : Node_Id) return Node_Id is N : Node_Id; begin N := New_Node (K_Assignment_Statement); Set_Defining_Identifier (N, Variable_Identifier); Set_Expression (N, Expression); return N; end Make_Assignment_Statement; ------------------------------ -- Make_Attribute_Reference -- ------------------------------ function Make_Attribute_Reference (Prefix : Node_Id; Attribute : Attribute_Id) return Node_Id is N : Node_Id; begin N := New_Node (K_Attribute_Reference); Set_Prefix (N, Prefix); Set_Name (N, AN (Attribute)); return N; end Make_Attribute_Reference; -------------------------- -- Make_Block_Statement -- -------------------------- function Make_Block_Statement (Statement_Identifier : Node_Id := No_Node; Declarative_Part : List_Id; Statements : List_Id; Exception_Handler : List_Id := No_List) return Node_Id is N : Node_Id; begin N := New_Node (K_Block_Statement); Set_Defining_Identifier (N, Statement_Identifier); if Present (Statement_Identifier) then Set_Declaration_Node (Statement_Identifier, N); end if; Set_Declarative_Part (N, Declarative_Part); Set_Statements (N, Statements); if not Is_Empty (Exception_Handler) then Set_Exception_Handler (N, Exception_Handler); end if; return N; end Make_Block_Statement; ------------------------- -- Make_Case_Statement -- ------------------------- function Make_Case_Statement (Expression : Node_Id; Case_Statement_Alternatives : List_Id) return Node_Id is N : Node_Id; begin N := New_Node (K_Case_Statement); Set_Expression (N, Expression); Set_Case_Statement_Alternatives (N, Case_Statement_Alternatives); return N; end Make_Case_Statement; ------------------------------------- -- Make_Case_Statement_Alternative -- ------------------------------------- function Make_Case_Statement_Alternative (Discret_Choice_List : List_Id; Statements : List_Id) return Node_Id is N : Node_Id; begin N := New_Node (K_Case_Statement_Alternative); Set_Discret_Choice_List (N, Discret_Choice_List); Set_Statements (N, Statements); return N; end Make_Case_Statement_Alternative; -------------------------------- -- Make_Component_Association -- -------------------------------- function Make_Component_Association (Selector_Name : Node_Id; Expression : Node_Id) return Node_Id is N : Node_Id; begin N := New_Node (K_Component_Association); Set_Defining_Identifier (N, Selector_Name); Set_Expression (N, Expression); return N; end Make_Component_Association; -------------------------------- -- Make_Component_Declaration -- -------------------------------- function Make_Component_Declaration (Defining_Identifier : Node_Id; Subtype_Indication : Node_Id; Expression : Node_Id := No_Node; Aliased_Present : Boolean := False) return Node_Id is N : Node_Id; begin N := New_Node (K_Component_Declaration); Set_Defining_Identifier (N, Defining_Identifier); Set_Subtype_Indication (N, Subtype_Indication); Set_Expression (N, Expression); Set_Aliased_Present (N, Aliased_Present); return N; end Make_Component_Declaration; ---------------------------------- -- Make_Decimal_Type_Definition -- ---------------------------------- function Make_Decimal_Type_Definition (Definition : Node_Id) return Node_Id is N : Node_Id; V : Value_Id; Exp : Node_Id; begin N := New_Node (K_Decimal_Type_Definition); V := New_Floating_Point_Value (Long_Double (1.0 / (10 ** (Integer (FEN.N_Scale (Definition)))))); Exp := Make_Literal (V); Set_Scale (N, Exp); V := New_Integer_Value (Unsigned_Long_Long (FEN.N_Total (Definition)), 1, 10); Set_Total (N, V); return N; end Make_Decimal_Type_Definition; --------------------- -- Make_Identifier -- --------------------- function Make_Identifier (Name : Name_Id) return Node_Id is N : Node_Id; begin N := New_Node (K_Identifier); Set_Name (N, To_Ada_Name (Name)); return N; end Make_Identifier; ------------------------------ -- Make_Defining_Identifier -- ------------------------------ function Make_Defining_Identifier (Name : Name_Id) return Node_Id is N : Node_Id; begin N := New_Node (K_Defining_Identifier); Set_Name (N, To_Ada_Name (Name)); return N; end Make_Defining_Identifier; ---------------------------------- -- Make_Derived_Type_Definition -- ---------------------------------- function Make_Derived_Type_Definition (Subtype_Indication : Node_Id; Record_Extension_Part : Node_Id := No_Node; Is_Abstract_Type : Boolean := False; Is_Private_Extension : Boolean := False; Is_Subtype : Boolean := False) return Node_Id is N : Node_Id; begin N := New_Node (K_Derived_Type_Definition); Set_Is_Abstract_Type (N, Is_Abstract_Type); Set_Is_Private_Extension (N, Is_Private_Extension); Set_Subtype_Indication (N, Subtype_Indication); Set_Record_Extension_Part (N, Record_Extension_Part); Set_Is_Subtype (N, Is_Subtype); return N; end Make_Derived_Type_Definition; ------------------------------ -- Make_Element_Association -- ------------------------------ function Make_Element_Association (Index : Node_Id; Expression : Node_Id) return Node_Id is N : Node_Id; begin N := New_Node (K_Element_Association); Set_Index (N, Index); Set_Expression (N, Expression); return N; end Make_Element_Association; -------------------------- -- Make_Elsif_Statement -- -------------------------- function Make_Elsif_Statement (Condition : Node_Id; Then_Statements : List_Id) return Node_Id is N : Node_Id; begin N := New_Node (K_Elsif_Statement); Set_Condition (N, Condition); Set_Then_Statements (N, Then_Statements); return N; end Make_Elsif_Statement; -------------------------------------- -- Make_Enumeration_Type_Definition -- -------------------------------------- function Make_Enumeration_Type_Definition (Enumeration_Literals : List_Id) return Node_Id is N : Node_Id; begin N := New_Node (K_Enumeration_Type_Definition); Set_Enumeration_Literals (N, Enumeration_Literals); return N; end Make_Enumeration_Type_Definition; -------------------------------- -- Make_Exception_Declaration -- -------------------------------- function Make_Exception_Declaration (Defining_Identifier : Node_Id; Renamed_Exception : Node_Id := No_Node; Parent : Node_Id := Current_Package) return Node_Id is N : Node_Id; begin pragma Assert (Kind (Defining_Identifier) = K_Defining_Identifier); N := New_Node (K_Exception_Declaration); Set_Defining_Identifier (N, Defining_Identifier); Set_Renamed_Entity (N, Renamed_Exception); Set_Declaration_Node (Defining_Identifier, N); Set_Parent (N, Parent); return N; end Make_Exception_Declaration; ------------------------------- -- Make_Explicit_Dereference -- ------------------------------- function Make_Explicit_Dereference (Prefix : Node_Id) return Node_Id is N : Node_Id; begin N := New_Node (K_Explicit_Dereference); Set_Prefix (N, Prefix); return N; end Make_Explicit_Dereference; --------------------- -- Make_Expression -- --------------------- function Make_Expression (Left_Expr : Node_Id; Operator : Operator_Type := Op_None; Right_Expr : Node_Id := No_Node) return Node_Id is N : Node_Id; begin N := New_Node (K_Expression); Set_Left_Expr (N, Left_Expr); Set_Operator (N, Operator_Type'Pos (Operator)); Set_Right_Expr (N, Right_Expr); return N; end Make_Expression; ------------------------ -- Make_For_Statement -- ------------------------ function Make_For_Statement (Defining_Identifier : Node_Id; Range_Constraint : Node_Id; Statements : List_Id) return Node_Id is N : Node_Id; begin N := New_Node (K_For_Statement); Set_Defining_Identifier (N, Defining_Identifier); Set_Range_Constraint (N, Range_Constraint); Set_Statements (N, Statements); return N; end Make_For_Statement; -------------------------------- -- Make_Full_Type_Declaration -- -------------------------------- function Make_Full_Type_Declaration (Defining_Identifier : Node_Id; Type_Definition : Node_Id; Discriminant_Spec : List_Id := No_List; Parent : Node_Id := Current_Package; Is_Subtype : Boolean := False) return Node_Id is N : Node_Id; begin pragma Assert (Kind (Defining_Identifier) = K_Defining_Identifier); N := New_Node (K_Full_Type_Declaration); Set_Defining_Identifier (N, Defining_Identifier); Set_Declaration_Node (Defining_Identifier, N); Set_Type_Definition (N, Type_Definition); Set_Discriminant_Spec (N, Discriminant_Spec); Set_Parent (N, Parent); Set_Is_Subtype (N, Is_Subtype); return N; end Make_Full_Type_Declaration; ----------------------- -- Make_If_Statement -- ----------------------- function Make_If_Statement (Condition : Node_Id; Then_Statements : List_Id; Elsif_Statements : List_Id := No_List; Else_Statements : List_Id := No_List) return Node_Id is N : Node_Id; begin N := New_Node (K_If_Statement); Set_Condition (N, Condition); Set_Then_Statements (N, Then_Statements); Set_Elsif_Statements (N, Elsif_Statements); Set_Else_Statements (N, Else_Statements); return N; end Make_If_Statement; ---------------------------- -- Make_Indexed_Component -- ---------------------------- function Make_Indexed_Component (Prefix : Node_Id; Expressions : List_Id) return Node_Id is N : Node_Id; begin N := New_Node (K_Indexed_Component); Set_Prefix (N, Prefix); Set_Expressions (N, Expressions); return N; end Make_Indexed_Component; ---------------------------------- -- Make_Instantiated_Subprogram -- ---------------------------------- function Make_Instantiated_Subprogram (Defining_Identifier : Node_Id; Parameter_List : List_Id) return Node_Id is N : Node_Id; begin N := New_Node (K_Instantiated_Subprogram); Set_Defining_Identifier (N, Defining_Identifier); Set_Parameter_List (N, Parameter_List); return N; end Make_Instantiated_Subprogram; -------------- -- New_List -- -------------- function New_List (N1 : Node_Id := No_Node; N2 : Node_Id := No_Node; N3 : Node_Id := No_Node; N4 : Node_Id := No_Node; N5 : Node_Id := No_Node) return List_Id is N : Node_Id; L : List_Id; begin Entries.Increment_Last; N := Entries.Last; Entries.Table (N) := Default_Node; Set_Kind (N, K_List_Id); L := List_Id (N); if Present (N1) then Append_To (L, N1); end if; if Present (N2) then Append_To (L, N2); end if; if Present (N3) then Append_To (L, N3); end if; if Present (N4) then Append_To (L, N4); end if; if Present (N5) then Append_To (L, N5); end if; return L; end New_List; ------------------ -- Make_Literal -- ------------------ function Make_Literal (Value : Value_Id) return Node_Id is pragma Assert (Value /= No_Value); N : constant Node_Id := New_Node (K_Literal); begin Set_Value (N, Value); return N; end Make_Literal; ------------------------------ -- Make_Literal_With_Parent -- ------------------------------ function Make_Literal_With_Parent (Value : Value_Id; Parent : Node_Id) return Node_Id is N : Node_Id := New_Node (K_Literal); begin Set_Value (N, Value); if Present (Parent) and then Value /= No_Value then N := Make_Selected_Component (Parent, N); end if; return N; end Make_Literal_With_Parent; ------------------------- -- Make_Null_Statement -- ------------------------- function Make_Null_Statement return Node_Id is N : Node_Id; begin N := New_Node (K_Null_Statement); return N; end Make_Null_Statement; ----------------------------- -- Make_Object_Declaration -- ----------------------------- function Make_Object_Declaration (Defining_Identifier : Node_Id; Constant_Present : Boolean := False; Object_Definition : Node_Id; Expression : Node_Id := No_Node; Parent : Node_Id := Current_Package; Renamed_Object : Node_Id := No_Node; Aliased_Present : Boolean := False) return Node_Id is N : Node_Id; begin pragma Assert (Kind (Defining_Identifier) = K_Defining_Identifier); N := New_Node (K_Object_Declaration); Set_Defining_Identifier (N, Defining_Identifier); Set_Declaration_Node (Defining_Identifier, N); Set_Constant_Present (N, Constant_Present); Set_Aliased_Present (N, Aliased_Present); Set_Object_Definition (N, Object_Definition); Set_Expression (N, Expression); Set_Renamed_Entity (N, Renamed_Object); Set_Parent (N, Parent); return N; end Make_Object_Declaration; ------------------------------- -- Make_Object_Instantiation -- ------------------------------- function Make_Object_Instantiation (Qualified_Expression : Node_Id) return Node_Id is N : Node_Id; begin N := New_Node (K_Object_Instantiation); Set_Qualified_Expression (N, Qualified_Expression); return N; end Make_Object_Instantiation; ------------------------------ -- Make_Package_Declaration -- ------------------------------ function Make_Package_Declaration (Identifier : Node_Id) return Node_Id is Pkg : Node_Id; Unit : Node_Id; function Make_Style_Check_Pragma return Node_Id; -- Returns a node for a pragma deactivating style checks ----------------------------- -- Make_Style_Check_Pragma -- ----------------------------- function Make_Style_Check_Pragma return Node_Id is begin -- Note: just using Style_Checks (Off) wouldn't turn off line length -- checks, so we need to define the maximum line length explicitly. -- We set it to the maximum value supported by GNAT: 32766. Set_Str_To_Name_Buffer ("NM32766"); return Make_Pragma (Pragma_Style_Checks, New_List (Make_Literal (New_String_Value (Name_Find, Wide => False)))); end Make_Style_Check_Pragma; -- Start of processing for Make_Package_Declaration begin Unit := New_Node (K_Package_Declaration); Set_Defining_Identifier (Unit, Identifier); if Kind (Identifier) = K_Defining_Identifier then Set_Declaration_Node (Identifier, Unit); elsif Kind (Identifier) = K_Selected_Component then Set_Declaration_Node (Selector_Name (Identifier), Unit); else raise Program_Error; end if; if Present (Current_Entity) and then FEN."/=" (FEN.Kind (FEN.Corresponding_Entity (FE_Node (Current_Entity))), FEN.K_Specification) then Set_Parent (Unit, Stubs_Package (Current_Entity)); end if; -- Building the specification part of the package Pkg := New_Node (K_Package_Specification); Set_Context_Clause (Pkg, New_List); -- Disabling style checks. We put the pragma before the header -- comment because some lines in the header may be very long. Append_To (Context_Clause (Pkg), Make_Style_Check_Pragma); -- Adding a comment header Make_Comment_Header (Context_Clause (Pkg), Identifier); Set_Visible_Part (Pkg, New_List); Set_Subunits (Pkg, New_List); Set_Private_Part (Pkg, New_List); Set_Package_Declaration (Pkg, Unit); Set_Package_Specification (Unit, Pkg); -- Building the implementation part of the package Pkg := New_Node (K_Package_Body); Set_Context_Clause (Pkg, New_List); -- Disabling style checks. We put the pragma before the header -- comment because some lines in the header may be very long. Append_To (Context_Clause (Pkg), Make_Style_Check_Pragma); -- Adding a comment header Make_Comment_Header (Context_Clause (Pkg), Identifier); Set_Statements (Pkg, New_List); Set_Package_Declaration (Pkg, Unit); Set_Package_Body (Unit, Pkg); return Unit; end Make_Package_Declaration; -------------------------------- -- Make_Package_Instantiation -- -------------------------------- function Make_Package_Instantiation (Defining_Identifier : Node_Id; Generic_Package : Node_Id; Parameter_List : List_Id := No_List; Parent : Node_Id := Current_Package) return Node_Id is N : Node_Id; begin pragma Assert (Kind (Defining_Identifier) = K_Defining_Identifier); N := New_Node (K_Package_Instantiation); Set_Defining_Identifier (N, Defining_Identifier); Set_Declaration_Node (Defining_Identifier, N); Set_Generic_Package (N, Generic_Package); Set_Parameter_List (N, Parameter_List); Set_Parent (N, Parent); return N; end Make_Package_Instantiation; -------------------------------- -- Make_Parameter_Association -- -------------------------------- function Make_Parameter_Association (Selector_Name : Node_Id; Actual_Parameter : Node_Id) return Node_Id is N : Node_Id; begin N := New_Node (K_Parameter_Association); Set_Selector_Name (N, Selector_Name); Set_Actual_Parameter (N, Actual_Parameter); return N; end Make_Parameter_Association; ---------------------------------- -- Make_Parameter_Specification -- ---------------------------------- function Make_Parameter_Specification (Defining_Identifier : Node_Id; Subtype_Mark : Node_Id; Parameter_Mode : Mode_Id := Mode_In; Expression : Node_Id := No_Node) return Node_Id is P : Node_Id; begin P := New_Node (K_Parameter_Specification); Set_Defining_Identifier (P, Defining_Identifier); Set_Parameter_Type (P, Subtype_Mark); Set_Parameter_Mode (P, Parameter_Mode); Set_Expression (P, Expression); return P; end Make_Parameter_Specification; ----------------- -- Make_Pragma -- ----------------- function Make_Pragma (The_Pragma : Pragma_Id; Argument_List : List_Id := No_List) return Node_Id is N : Node_Id; begin N := New_Node (K_Pragma); Set_Defining_Identifier (N, Make_Defining_Identifier (GN (The_Pragma))); Set_Argument_List (N, Argument_List); return N; end Make_Pragma; ------------------------------- -- Make_Qualified_Expression -- ------------------------------- function Make_Qualified_Expression (Subtype_Mark : Node_Id; Operand : Node_Id) return Node_Id is N : Node_Id; begin N := New_Node (K_Qualified_Expression); Set_Subtype_Mark (N, Subtype_Mark); Set_Operand (N, Operand); return N; end Make_Qualified_Expression; -------------------------- -- Make_Raise_Statement -- -------------------------- function Make_Raise_Statement (Raised_Error : Node_Id := No_Node) return Node_Id is N : Node_Id; begin N := New_Node (K_Raise_Statement); Set_Raised_Error (N, Raised_Error); return N; end Make_Raise_Statement; ---------------- -- Make_Slice -- ---------------- function Make_Slice (Prefix : Node_Id; Discrete_Range : Node_Id) return Node_Id is N : Node_Id; begin N := New_Node (K_Slice); Set_Prefix (N, Prefix); Set_Discrete_Range (N, Discrete_Range); return N; end Make_Slice; ---------------- -- Make_Range -- ---------------- function Make_Range (Low_Bound : Node_Id; High_Bound : Node_Id) return Node_Id is N : Node_Id; begin N := New_Node (K_Range); Set_Low_Bound (N, Low_Bound); Set_High_Bound (N, High_Bound); return N; end Make_Range; --------------------------- -- Make_Range_Constraint -- --------------------------- function Make_Range_Constraint (First : Node_Id; Last : Node_Id) return Node_Id is N : Node_Id; begin N := New_Node (K_Range_Constraint); Set_First (N, First); Set_Last (N, Last); return N; end Make_Range_Constraint; --------------------------- -- Make_Record_Aggregate -- --------------------------- function Make_Record_Aggregate (L : List_Id; Ancestor_Part : Node_Id := No_Node) return Node_Id is N : Node_Id; begin N := New_Node (K_Record_Aggregate); Set_Component_Association_List (N, L); Set_Ancestor_Part (N, Ancestor_Part); return N; end Make_Record_Aggregate; ---------------------------- -- Make_Record_Definition -- ---------------------------- function Make_Record_Definition (Component_List : List_Id) return Node_Id is N : Node_Id; begin N := New_Node (K_Record_Definition); Set_Component_List (N, Component_List); return N; end Make_Record_Definition; --------------------------------- -- Make_Record_Type_Definition -- --------------------------------- function Make_Record_Type_Definition (Record_Definition : Node_Id; Is_Abstract_Type : Boolean := False; Is_Tagged_Type : Boolean := False; Is_Limited_Type : Boolean := False) return Node_Id is N : Node_Id; begin N := New_Node (K_Record_Type_Definition); Set_Is_Abstract_Type (N, Is_Abstract_Type); Set_Is_Tagged_Type (N, Is_Tagged_Type); Set_Is_Limited_Type (N, Is_Limited_Type); Set_Record_Definition (N, Record_Definition); return N; end Make_Record_Type_Definition; --------------------------- -- Make_Return_Statement -- --------------------------- function Make_Return_Statement (Expression : Node_Id) return Node_Id is N : Node_Id; begin N := New_Node (K_Return_Statement); Set_Expression (N, Expression); return N; end Make_Return_Statement; ----------------------------- -- Make_Selected_Component -- ----------------------------- function Make_Selected_Component (Prefix : Node_Id; Selector_Name : Node_Id) return Node_Id is N : Node_Id; begin pragma Assert (Present (Selector_Name)); pragma Assert (Kind (Selector_Name) /= K_Selected_Component); if Present (Prefix) then pragma Assert (Kind (Prefix) /= K_Package_Declaration and then Kind (Prefix) /= K_Package_Specification and then Kind (Prefix) /= K_Package_Body and then Kind (Prefix) /= K_Subprogram_Specification and then Kind (Prefix) /= K_Subprogram_Body and then Kind (Prefix) /= K_Full_Type_Declaration); N := New_Node (K_Selected_Component); Set_Prefix (N, Prefix); Set_FE_Node (N, FE_Node (Selector_Name)); Set_Selector_Name (N, Selector_Name); return N; else return Selector_Name; end if; end Make_Selected_Component; ----------------------------- -- Make_Selected_Component -- ----------------------------- function Make_Selected_Component (Prefix : Name_Id; Selector_Name : Name_Id) return Node_Id is N : Node_Id; begin pragma Assert (Selector_Name /= No_Name); if Prefix /= No_Name then N := New_Node (K_Selected_Component); Set_Prefix (N, Make_Identifier (Prefix)); Set_Selector_Name (N, Make_Identifier (Selector_Name)); return N; else return Make_Identifier (Selector_Name); end if; end Make_Selected_Component; -------------------------- -- Make_Subprogram_Call -- -------------------------- function Make_Subprogram_Call (Defining_Identifier : Node_Id; Actual_Parameter_Part : List_Id) return Node_Id is N : Node_Id; begin N := New_Node (K_Subprogram_Call); Set_Defining_Identifier (N, Defining_Identifier); Set_Actual_Parameter_Part (N, Actual_Parameter_Part); return N; end Make_Subprogram_Call; -------------------------- -- Make_Subprogram_Body -- -------------------------- function Make_Subprogram_Body (Specification : Node_Id; Declarations : List_Id; Statements : List_Id) return Node_Id is N : Node_Id; begin N := New_Node (K_Subprogram_Body); Set_Specification (N, Specification); Set_Declarations (N, Declarations); Set_Statements (N, Statements); return N; end Make_Subprogram_Body; ----------------------------------- -- Make_Subprogram_Specification -- ----------------------------------- function Make_Subprogram_Specification (Defining_Identifier : Node_Id; Parameter_Profile : List_Id; Return_Type : Node_Id := No_Node; Parent : Node_Id := Current_Package; Renamed_Subprogram : Node_Id := No_Node; Instantiated_Subprogram : Node_Id := No_Node) return Node_Id is N : Node_Id; begin pragma Assert (Kind (Defining_Identifier) = K_Defining_Identifier); N := New_Node (K_Subprogram_Specification); Set_Defining_Identifier (N, Defining_Identifier); Set_Parameter_Profile (N, Parameter_Profile); Set_Return_Type (N, Return_Type); Set_Parent (N, Parent); Set_Renamed_Entity (N, Renamed_Subprogram); Set_Instantiated_Subprogram (N, Instantiated_Subprogram); return N; end Make_Subprogram_Specification; -------------------------- -- Make_Type_Conversion -- -------------------------- function Make_Type_Conversion (Subtype_Mark : Node_Id; Expression : Node_Id) return Node_Id is N : Node_Id; begin N := New_Node (K_Type_Conversion); Set_Subtype_Mark (N, Subtype_Mark); Set_Expression (N, Expression); return N; end Make_Type_Conversion; -------------------- -- Make_Used_Type -- -------------------- function Make_Used_Type (The_Used_Type : Node_Id) return Node_Id is N : Node_Id; begin N := New_Node (K_Used_Type); Set_The_Used_Entity (N, The_Used_Type); return N; end Make_Used_Type; ----------------------- -- Make_Used_Package -- ----------------------- function Make_Used_Package (The_Used_Package : Node_Id) return Node_Id is N : Node_Id; begin N := New_Node (K_Used_Package); Set_The_Used_Entity (N, The_Used_Package); return N; end Make_Used_Package; ----------------------- -- Make_Variant_Part -- ----------------------- function Make_Variant_Part (Discriminant : Node_Id; Variant_List : List_Id) return Node_Id is N : Node_Id; begin N := New_Node (K_Variant_Part); Set_Variants (N, Variant_List); Set_Discriminant (N, Discriminant); return N; end Make_Variant_Part; ------------------------- -- Make_Comment_Header -- ------------------------- procedure Make_Comment_Header (Package_Header : List_Id; Package_Identifier : Node_Id) is Separator : Name_Id; -- A line of hyphens Pkg_Name_Str : constant String := "Impl"; Internal_Str : constant String := "Internals"; Editable : Boolean; Internal : Boolean; N : Node_Id; begin -- Determine whether this package is intended to be edited by the user Editable := (Pkg_Name_Str = Get_Name_String (Get_Name (Package_Identifier))); -- Check whether the package is internal to PolyORB Internal := (Internal_Str = Get_Name_String (Get_Name (Package_Identifier))); -- Prepare separator line for comment box Set_Str_To_Name_Buffer ("-------------------------------------------------"); Separator := Name_Find; -- Append the comment header lines to the package header N := Make_Ada_Comment (Name_Find, False); Append_To (Package_Header, N); Set_Str_To_Name_Buffer ("This file has been generated automatically from"); N := Make_Ada_Comment (Name_Find); Append_To (Package_Header, N); Get_Name_String (Main_Source); N := Make_Ada_Comment (Name_Find); Append_To (Package_Header, N); Set_Str_To_Name_Buffer ("by IAC (IDL to Ada Compiler) " & Platform.Version & "."); N := Make_Ada_Comment (Name_Find); Append_To (Package_Header, N); if not Editable then N := Make_Ada_Comment (Separator, False); Append_To (Package_Header, N); Set_Str_To_Name_Buffer ("Do NOT hand-modify this file, as your"); N := Make_Ada_Comment (Name_Find); Append_To (Package_Header, N); Set_Str_To_Name_Buffer ("changes will be lost when you re-run the"); N := Make_Ada_Comment (Name_Find); Append_To (Package_Header, N); Set_Str_To_Name_Buffer ("IDL to Ada compiler."); N := Make_Ada_Comment (Name_Find); Append_To (Package_Header, N); end if; if Internal then N := Make_Ada_Comment (Separator, False); Append_To (Package_Header, N); Set_Str_To_Name_Buffer ("This package is not part of the standard IDL-to-Ada"); N := Make_Ada_Comment (Name_Find); Append_To (Package_Header, N); Set_Str_To_Name_Buffer ("mapping. It provides supporting routines used"); N := Make_Ada_Comment (Name_Find); Append_To (Package_Header, N); Set_Str_To_Name_Buffer ("internally by PolyORB."); N := Make_Ada_Comment (Name_Find); Append_To (Package_Header, N); end if; N := Make_Ada_Comment (Separator, False); Append_To (Package_Header, N); end Make_Comment_Header; ----------------- -- Next_N_Node -- ----------------- function Next_N_Node (N : Node_Id; Num : Natural) return Node_Id is Result : Node_Id := N; begin for I in 1 .. Num loop Result := Next_Node (Result); end loop; return Result; end Next_N_Node; -------------- -- New_Node -- -------------- function New_Node (Kind : Node_Kind; From : Node_Id := No_Node) return Node_Id is N : Node_Id; begin Entries.Increment_Last; N := Entries.Last; Entries.Table (N) := Default_Node; Set_Kind (N, Kind); if Present (From) then Bind_FE_To_BE (From, N, B_Stub); Set_Loc (N, FEN.Loc (From)); else Set_Loc (N, No_Location); end if; return N; end New_Node; --------------- -- New_Token -- --------------- procedure New_Token (T : Token_Type; I : String := "") is begin if T in Keyword_Type then Set_Str_To_Name_Buffer (Image (T)); else Set_Str_To_Name_Buffer (I); end if; Token_Image (T) := Name_Find; -- Mark Ada keywords if T in Keyword_Type then -- We don't "mark" the keyword name but instead a custom -- string ("%ada_kw%" to avoid clashing with other -- marked names. Set_Str_To_Name_Buffer (Ada_Keyword_Prefix); Get_Name_String_And_Append (Token_Image (T)); Set_Name_Table_Byte (Name_Find, Byte (Token_Type'Pos (T) + 1)); end if; end New_Token; ------------------ -- New_Operator -- ------------------ procedure New_Operator (Op : Operator_Type; I : String := "") is begin if Op in Keyword_Operator then Set_Str_To_Name_Buffer (Image (Op)); else Set_Str_To_Name_Buffer (I); end if; Operator_Image (Operator_Type'Pos (Op)) := Name_Find; end New_Operator; ---------------- -- Pop_Entity -- ---------------- procedure Pop_Entity is begin if Last > No_Depth then Decrement_Last; end if; end Pop_Entity; ----------------- -- Push_Entity -- ----------------- procedure Push_Entity (E : Node_Id) is begin Increment_Last; Table (Last).Current_Entity := E; end Push_Entity; --------------------------- -- Remove_Node_From_List -- --------------------------- procedure Remove_Node_From_List (E : Node_Id; L : List_Id) is C : Node_Id; begin C := First_Node (L); if C = E then Set_First_Node (L, Next_Node (E)); if Last_Node (L) = E then Set_Last_Node (L, No_Node); end if; else while Present (C) loop if Next_Node (C) = E then Set_Next_Node (C, Next_Node (E)); if Last_Node (L) = E then Set_Last_Node (L, C); end if; exit; end if; C := Next_Node (C); end loop; end if; end Remove_Node_From_List; ------------------- -- Set_Forwarded -- ------------------- procedure Set_Forwarded (E : Node_Id) is N : Node_Id; begin -- We cannot directly append the node E to the List of -- forwarded entities because this node may have to be appended -- to other lists. N := New_Node (K_Node_Id); Set_FE_Node (N, E); if Is_Empty (Forwarded_Entities) then Forwarded_Entities := New_List; end if; Append_To (Forwarded_Entities, N); end Set_Forwarded; ------------------ -- Is_Forwarded -- ------------------ function Is_Forwarded (E : Node_Id) return Boolean is Result : Boolean := False; N : Node_Id; begin if Is_Empty (Forwarded_Entities) then Forwarded_Entities := New_List; end if; N := First_Node (Forwarded_Entities); while Present (N) loop if FE_Node (N) = E then Result := True; end if; N := Next_Node (N); end loop; return Result; end Is_Forwarded; ------------------ -- Set_CDR_Body -- ------------------ procedure Set_CDR_Body (N : Node_Id := Current_Entity) is begin Table (Last).Current_Package := Package_Body (CDR_Package (N)); end Set_CDR_Body; ------------------ -- Set_CDR_Spec -- ------------------ procedure Set_CDR_Spec (N : Node_Id := Current_Entity) is begin Table (Last).Current_Package := Package_Specification (CDR_Package (N)); end Set_CDR_Spec; ---------------------- -- Set_Aligned_Spec -- ---------------------- procedure Set_Aligned_Spec (N : Node_Id := Current_Entity) is begin Table (Last).Current_Package := Package_Specification (Aligned_Package (N)); end Set_Aligned_Spec; ---------------------- -- Set_Buffers_Body -- ---------------------- procedure Set_Buffers_Body (N : Node_Id := Current_Entity) is begin Table (Last).Current_Package := Package_Body (Buffers_Package (N)); end Set_Buffers_Body; ---------------------- -- Set_Buffers_Spec -- ---------------------- procedure Set_Buffers_Spec (N : Node_Id := Current_Entity) is begin Table (Last).Current_Package := Package_Specification (Buffers_Package (N)); end Set_Buffers_Spec; --------------------- -- Set_Helper_Body -- --------------------- procedure Set_Helper_Body (N : Node_Id := Current_Entity) is begin Table (Last).Current_Package := Package_Body (Helper_Package (N)); end Set_Helper_Body; --------------------- -- Set_Helper_Spec -- --------------------- procedure Set_Helper_Spec (N : Node_Id := Current_Entity) is begin Table (Last).Current_Package := Package_Specification (Helper_Package (N)); end Set_Helper_Spec; ------------------------ -- Set_Internals_Body -- ------------------------ procedure Set_Internals_Body (N : Node_Id := Current_Entity) is begin Table (Last).Current_Package := Package_Body (Internals_Package (N)); end Set_Internals_Body; ------------------------ -- Set_Internals_Spec -- ------------------------ procedure Set_Internals_Spec (N : Node_Id := Current_Entity) is begin Table (Last).Current_Package := Package_Specification (Internals_Package (N)); end Set_Internals_Spec; ------------------- -- Set_Impl_Body -- ------------------- procedure Set_Impl_Body (N : Node_Id := Current_Entity) is begin Table (Last).Current_Package := Package_Body (Implementation_Package (N)); end Set_Impl_Body; ------------------- -- Set_Impl_Spec -- ------------------- procedure Set_Impl_Spec (N : Node_Id := Current_Entity) is begin Table (Last).Current_Package := Package_Specification (Implementation_Package (N)); end Set_Impl_Spec; ---------------------- -- Set_IR_Info_Body -- ---------------------- procedure Set_IR_Info_Body (N : Node_Id := Current_Entity) is begin Table (Last).Current_Package := Package_Body (Ir_Info_Package (N)); end Set_IR_Info_Body; ---------------------- -- Set_IR_Info_Spec -- ---------------------- procedure Set_IR_Info_Spec (N : Node_Id := Current_Entity) is begin Table (Last).Current_Package := Package_Specification (Ir_Info_Package (N)); end Set_IR_Info_Spec; ------------------- -- Set_Main_Body -- ------------------- procedure Set_Main_Body (N : Node_Id := Current_Entity) is begin Table (Last).Current_Package := Package_Body (Stubs_Package (N)); end Set_Main_Body; ------------------- -- Set_Main_Spec -- ------------------- procedure Set_Main_Spec (N : Node_Id := Current_Entity) is begin Table (Last).Current_Package := Package_Specification (Stubs_Package (N)); end Set_Main_Spec; ----------------------- -- Set_Skeleton_Body -- ----------------------- procedure Set_Skeleton_Body (N : Node_Id := Current_Entity) is begin Table (Last).Current_Package := Package_Body (Skeleton_Package (N)); end Set_Skeleton_Body; ----------------------- -- Set_Skeleton_Spec -- ----------------------- procedure Set_Skeleton_Spec (N : Node_Id := Current_Entity) is begin Table (Last).Current_Package := Package_Specification (Skeleton_Package (N)); end Set_Skeleton_Spec; ----------------- -- To_Ada_Name -- ----------------- function To_Ada_Name (N : Name_Id; Is_Operation_Name : Boolean := False) return Name_Id is First : Natural := 1; Name : Name_Id; Low_Name : Name_Id; Mixed_Name : Name_Id; Is_Keyword : Boolean; begin Get_Name_String (N); -- Remove leading underscores while First <= Name_Len and then Name_Buffer (First) = '_' loop First := First + 1; end loop; -- Escape doubled underscores for I in First .. Name_Len loop if Name_Buffer (I) = '_' and then I < Name_Len and then Name_Buffer (I + 1) = '_' then Name_Buffer (I + 1) := 'U'; end if; end loop; -- Escape trailing underscores if Name_Buffer (Name_Len) = '_' then Add_Char_To_Name_Buffer ('U'); end if; -- Get name in original case Name := Name_Find; -- Get name in lowercase Low_Name := To_Lower (Name); -- Get name in GNAT mixed case, for comparison with SN entries GNAT.Case_Util.To_Mixed (Name_Buffer (1 .. Name_Len)); Mixed_Name := Name_Find; -- If the identifier collides with an Ada reserved word or (for object -- operations) with a primitive operation of Ada.Finalization. -- Controlled, insert "IDL_" string before the identifier. Set_Str_To_Name_Buffer (Ada_Keyword_Prefix); Get_Name_String_And_Append (Low_Name); Is_Keyword := Get_Name_Table_Byte (Name_Find) > 0; if Is_Keyword or else (Is_Operation_Name and then (Mixed_Name = SN (S_Initialize) or else Mixed_Name = SN (S_Adjust) or else Mixed_Name = SN (S_Finalize))) then Set_Str_To_Name_Buffer ("IDL_"); Get_Name_String_And_Append (Name); Name := Name_Find; end if; return Name; end To_Ada_Name; ------------------ -- To_Spec_Name -- ------------------ function To_Spec_Name (N : Name_Id) return Name_Id is begin Get_Name_String (N); To_Lower (Name_Buffer (1 .. Name_Len)); if Name_Len > 2 and then Name_Buffer (Name_Len - 1) = '%' then Name_Buffer (Name_Len) := 's'; else Add_Str_To_Name_Buffer ("%s"); end if; return Name_Find; end To_Spec_Name; ------------------- -- Internal_Name -- ------------------- function Internal_Name (P : Node_Id; L : GLists) return Name_Id is pragma Assert (Kind (P) = K_Package_Declaration); begin -- The internal name is "%" Get_Name_String (Fully_Qualified_Name (Defining_Identifier (P))); Add_Char_To_Name_Buffer ('%'); Add_Str_To_Name_Buffer (GLists'Image (L)); return Name_Find; end Internal_Name; ---------------------- -- Initialize_GList -- ---------------------- procedure Initialize_GList (P : Node_Id; L : GLists) is pragma Assert (Kind (P) = K_Package_Declaration); The_List : constant List_Id := New_List; Binding_Name : constant Name_Id := Internal_Name (P, L); begin if Get_Name_Table_Info (Binding_Name) = 0 then Set_Name_Table_Info (Binding_Name, Nat (The_List)); end if; end Initialize_GList; --------------- -- Get_GList -- --------------- function Get_GList (P : Node_Id; L : GLists) return List_Id is pragma Assert (Kind (P) = K_Package_Declaration); The_List : List_Id; Binding_Name : constant Name_Id := Internal_Name (P, L); begin The_List := List_Id (Get_Name_Table_Info (Binding_Name)); if The_List = No_List then The_List := New_List; Set_Name_Table_Info (Binding_Name, Nat (The_List)); end if; return The_List; end Get_GList; ------------------------ -- Set_UTF_8_Encoding -- ------------------------ procedure Set_UTF_8_Encoding is begin The_Unique_Suffix := UTF_8_Unique_Suffix'Access; The_Unique_Infix := UTF_8_Unique_Infix'Access; end Set_UTF_8_Encoding; end Backend.BE_CORBA_Ada.Nutils; polyorb-2.8~20110207.orig/compilers/iac/frontend-debug.adb0000644000175000017500000001670111750740337022521 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- F R O N T E N D . D E B U G -- -- -- -- B o d y -- -- -- -- Copyright (C) 2005-2009, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with Charset; use Charset; with Locations; use Locations; with Lexer; use Lexer; with Namet; use Namet; with Scopes; use Scopes; with Utils; use Utils; with Values; use Values; with Frontend.Nutils; use Frontend.Nutils; package body Frontend.Debug is ----------- -- Image -- ----------- function Image (N : Node_Kind) return String is S : String := Node_Kind'Image (N); begin To_Lower (S); for I in S'Range loop if S (I) = '_' then S (I) := ' '; end if; end loop; return S (3 .. S'Last); end Image; function Image (N : Name_Id) return String is begin if N = No_Name then return No_Str; else return Get_Name_String (N); end if; end Image; function Image (N : Node_Id) return String is begin return Image (Int (N)); end Image; function Image (N : List_Id) return String is begin return Image (Int (N)); end Image; function Image (N : Mode_Id) return String is begin return Quoted (Image (Parameter_Mode (N))); end Image; function Image (N : Pragma_Type) return String is begin return Quoted (Image (Get_Pragma_Type (N))); end Image; function Image (N : Value_Id) return String is begin return Values.Image (N); end Image; function Image (N : Operator_Id) return String is begin return Quoted (Image (Token_Type'Val (N))); end Image; function Image (N : Boolean) return String is begin return Boolean'Image (N); end Image; function Image (N : Byte) return String is begin return Image (Int (N)); end Image; --------------- -- W_Boolean -- --------------- procedure W_Boolean (N : Boolean) is begin Write_Str (N'Img); end W_Boolean; ------------ -- W_Byte -- ------------ procedure W_Byte (N : Byte) is begin Write_Int (Int (N)); end W_Byte; ----------------- -- W_Full_Tree -- ----------------- procedure W_Full_Tree is D : Node_Id := First_Entity (Definitions (IDL_Spec)); begin N_Indents := 0; while Present (D) loop W_Node_Id (D); D := Next_Entity (D); end loop; end W_Full_Tree; --------------- -- W_Indents -- --------------- procedure W_Indents is begin for I in 1 .. N_Indents loop Write_Str (" "); end loop; end W_Indents; --------------- -- W_List_Id -- --------------- procedure W_List_Id (L : List_Id) is E : Node_Id; begin if L = No_List then return; end if; E := First_Entity (L); while E /= No_Node loop W_Node_Id (E); E := Next_Entity (E); end loop; end W_List_Id; ---------------------- -- W_Node_Attribute -- ---------------------- procedure W_Node_Attribute (A : String; K : String; V : String; N : Int := 0) is C : Node_Id; begin if A = "Next_Entity" or else A = "Homonym" or else A = "Name" or else A = "Visible" or else A = "Implicitly_Visible" or else A = "Scoped_Identifiers" or else A = "Next_Identifier" then return; end if; N_Indents := N_Indents + 1; W_Indents; Write_Str (A); Write_Char (' '); Write_Str (K); Write_Char (' '); C := Node_Id (N); if K = "Name_Id" then Write_Line (Quoted (V)); -- If the attribute name is BE_Node, we don't want to call Kind (the -- front-end one) on it, because it's (conceptually) the wrong type! elsif K = "Node_Id" and then Present (C) and then A /= "BE_Node" then if C > Frontend.Nodes.Entries.Last then Write_Str ("*** invalid Node_Id: "); Write_Line (V); else case Kind (C) is when K_Float .. K_Value_Base => Write_Line ('(' & Image (Kind (Node_Id (N))) & ')'); when others => Write_Line (V); end case; end if; else Write_Line (V); end if; if A /= "Corresponding_Entity" and then A /= "Scope_Entity" and then A /= "Potential_Scope" and then A /= "Reference" and then A /= "Base_Interface" and then A /= "Declaration" and then A /= "BE_Node" and then A /= "Type_Id" and then A /= "Type_Prefix" and then A /= "Type_Version" then if K = "Node_Id" then W_Node_Id (Node_Id (N)); elsif K = "List_Id" then W_List_Id (List_Id (N)); end if; end if; N_Indents := N_Indents - 1; end W_Node_Attribute; ------------------- -- W_Node_Header -- ------------------- procedure W_Node_Header (N : Node_Id) is begin W_Indents; Write_Int (Int (N)); Write_Char (' '); Write_Str (Image (Kind (N))); Write_Char (' '); Write_Line (Image (Loc (N))); end W_Node_Header; --------------- -- W_Node_Id -- --------------- procedure W_Node_Id (N : Node_Id) is begin if N = No_Node then return; end if; W_Node (N); end W_Node_Id; --------- -- wfi -- --------- procedure wfi (N : Node_Id) is I : constant Natural := N_Indents; begin N_Indents := 1; W_Node_Id (N); N_Indents := I; end wfi; end Frontend.Debug; polyorb-2.8~20110207.orig/compilers/iac/backend-be_corba_ada-buffers.adb0000644000175000017500000020341311750740337025174 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- B A C K E N D . B E _ C O R B A _ A D A . B U F F E R S -- -- -- -- B o d y -- -- -- -- Copyright (C) 2006-2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with Namet; use Namet; with Values; with Frontend.Nodes; use Frontend.Nodes; with Frontend.Nutils; with Backend.BE_CORBA_Ada.Nodes; use Backend.BE_CORBA_Ada.Nodes; with Backend.BE_CORBA_Ada.Nutils; use Backend.BE_CORBA_Ada.Nutils; with Backend.BE_CORBA_Ada.IDL_To_Ada; use Backend.BE_CORBA_Ada.IDL_To_Ada; with Backend.BE_CORBA_Ada.Runtime; use Backend.BE_CORBA_Ada.Runtime; with Backend.BE_CORBA_Ada.Common; use Backend.BE_CORBA_Ada.Common; package body Backend.BE_CORBA_Ada.Buffers is package FEN renames Frontend.Nodes; package FEU renames Frontend.Nutils; package BEN renames Backend.BE_CORBA_Ada.Nodes; package BEU renames Backend.BE_CORBA_Ada.Nutils; package body Package_Spec is function Buffer_Size_Spec (E : Node_Id) return Node_Id; -- Builds the spec of the static buffer size subprogram procedure Visit_Attribute_Declaration (E : Node_Id); procedure Visit_Interface_Declaration (E : Node_Id); procedure Visit_Module (E : Node_Id); procedure Visit_Operation_Declaration (E : Node_Id); procedure Visit_Specification (E : Node_Id); ---------------------- -- Buffer_Size_Spec -- ---------------------- function Buffer_Size_Spec (E : Node_Id) return Node_Id is pragma Assert (FEN.Kind (E) = K_Operation_Declaration); Spec : constant Node_Id := Stub_Node (BE_Node (Identifier (E))); Profile : List_Id; Parameter : Node_Id; S : Node_Id; begin Profile := New_List; -- 'Role' parameter Parameter := Make_Parameter_Specification (Defining_Identifier => Make_Defining_Identifier (PN (P_Role)), Subtype_Mark => RE (RE_Boolean_0), Parameter_Mode => Mode_In); Append_To (Profile, Parameter); -- 'Args' parameter Parameter := Make_Parameter_Specification (Defining_Identifier => Make_Defining_Identifier (PN (P_Args)), Subtype_Mark => Make_Access_Type_Definition (Expand_Designator (Type_Def_Node (BE_Node (Identifier (E))))), Parameter_Mode => Mode_In); Append_To (Profile, Parameter); -- 'Buffer' parameter Parameter := Make_Parameter_Specification (Defining_Identifier => Make_Defining_Identifier (PN (P_Buffer)), Subtype_Mark => RE (RE_Buffer_Access), Parameter_Mode => Mode_In); Append_To (Profile, Parameter); -- 'First_Arg_Alignment' parameter Parameter := Make_Parameter_Specification (Defining_Identifier => Make_Defining_Identifier (PN (P_First_Arg_Alignment)), Subtype_Mark => RE (RE_Alignment_Type), Parameter_Mode => Mode_In); Append_To (Profile, Parameter); -- Subprogram Specification S := Make_Subprogram_Specification (Make_Selected_Component (Defining_Identifier (Buffers_Package (Current_Entity)), Map_Buffer_Size_Identifier (Defining_Identifier (Spec))), Profile, No_Node); return S; end Buffer_Size_Spec; ----------- -- Visit -- ----------- procedure Visit (E : Node_Id) is begin case FEN.Kind (E) is when K_Attribute_Declaration => Visit_Attribute_Declaration (E); when K_Interface_Declaration => Visit_Interface_Declaration (E); when K_Module => Visit_Module (E); when K_Operation_Declaration => Visit_Operation_Declaration (E); when K_Specification => Visit_Specification (E); when others => null; end case; end Visit; --------------------------------- -- Visit_Attribute_Declaration -- --------------------------------- procedure Visit_Attribute_Declaration (E : Node_Id) is N : Node_Id; D : Node_Id; begin Set_Buffers_Spec; D := First_Entity (Declarators (E)); while Present (D) loop -- Explaining comment Set_Str_To_Name_Buffer ("Attribute : "); Get_Name_String_And_Append (IDL_Name (Identifier (D))); N := Make_Ada_Comment (Name_Find); Append_To (Visible_Part (Current_Package), N); D := Next_Entity (D); end loop; end Visit_Attribute_Declaration; --------------------------------- -- Visit_Interface_Declaration -- --------------------------------- procedure Visit_Interface_Declaration (E : Node_Id) is N : Node_Id; begin -- No buffers package is generated for a local interface if FEN.Is_Local_Interface (E) then return; end if; N := BEN.Parent (Type_Def_Node (BE_Node (Identifier (E)))); Push_Entity (BEN.IDL_Unit (Package_Declaration (N))); Set_Buffers_Spec; N := First_Entity (Interface_Body (E)); while Present (N) loop Visit (N); N := Next_Entity (N); end loop; Pop_Entity; end Visit_Interface_Declaration; ------------------ -- Visit_Module -- ------------------ procedure Visit_Module (E : Node_Id) is D : Node_Id; begin if not Map_Particular_CORBA_Parts (E, PK_Buffers_Spec) then Push_Entity (Stub_Node (BE_Node (Identifier (E)))); D := First_Entity (Definitions (E)); while Present (D) loop Visit (D); D := Next_Entity (D); end loop; Pop_Entity; end if; end Visit_Module; --------------------------------- -- Visit_Operation_Declaration -- --------------------------------- procedure Visit_Operation_Declaration (E : Node_Id) is N : Node_Id; Attribute_Name : Name_Id; begin Set_Buffers_Spec; -- Explaining comment Set_Str_To_Name_Buffer ("Operation : "); Get_Name_String_And_Append (IDL_Name (Identifier (E))); N := Make_Ada_Comment (Name_Find); Append_To (Visible_Part (Current_Package), N); -- Generating the 'Operation_Name'_Buffer_Size spec N := Buffer_Size_Spec (E); Append_To (Visible_Part (Current_Package), N); Bind_FE_To_BE (Identifier (E), N, B_Buffer_Size); -- Variables to store buffers size Attribute_Name := Add_Suffix_To_Name ("_Client_Size", IDL_Name (Identifier (E))); N := Make_Object_Declaration (Defining_Identifier => Make_Defining_Identifier (Attribute_Name), Object_Definition => RE (RE_Stream_Element_Count), Constant_Present => False, Expression => Make_Literal (Int0_Val)); Append_To (Visible_Part (Current_Package), N); Attribute_Name := Add_Suffix_To_Name ("_Server_Size", IDL_Name (Identifier (E))); N := Make_Object_Declaration (Defining_Identifier => Make_Defining_Identifier (Attribute_Name), Object_Definition => RE (RE_Stream_Element_Count), Constant_Present => False, Expression => Make_Literal (Int0_Val)); Append_To (Visible_Part (Current_Package), N); end Visit_Operation_Declaration; ------------------------- -- Visit_Specification -- ------------------------- procedure Visit_Specification (E : Node_Id) is Definition : Node_Id; begin Push_Entity (Stub_Node (BE_Node (Identifier (E)))); Definition := First_Entity (Definitions (E)); while Present (Definition) loop Visit (Definition); Definition := Next_Entity (Definition); end loop; Pop_Entity; end Visit_Specification; end Package_Spec; package body Package_Body is use Values; Args_Declared : Boolean := False; Fixed_Client_Buffer : Boolean := True; Fixed_Server_Buffer : Boolean := True; Variable_Buffer : Boolean := False; function Buffer_Size_Body (E : Node_Id) return Node_Id; function Get_Index_Name return Name_Id; Index_Number : Nat := 0; procedure Visit_Attribute_Declaration (E : Node_Id); procedure Visit_Interface_Declaration (E : Node_Id); procedure Visit_Module (E : Node_Id); procedure Visit_Operation_Declaration (E : Node_Id); procedure Visit_Specification (E : Node_Id); function Compute_Size (Var_Node : Node_Id; Var_Type : Node_Id; Subp_Dec : List_Id; Subp_Nod : Node_Id) return Node_Id; function Parameter_Size (N : Node_Id) return Value_Id; procedure Declare_Args (Subp_Dec : List_Id; Subp_Nod : Node_Id); ---------------------- -- Buffer_Size_Body -- ---------------------- function Buffer_Size_Body (E : Node_Id) return Node_Id is pragma Assert (FEN.Kind (E) = K_Operation_Declaration); Subp_Spec : Node_Id; Subp_Statements : constant List_Id := New_List; Subp_Declarations : constant List_Id := New_List; P : constant List_Id := Parameters (E); T : constant Node_Id := Type_Spec (E); Client_Case : constant List_Id := New_List (RE (RE_True)); Client_Statements : constant List_Id := New_List; Server_Case : constant List_Id := New_List (RE (RE_False)); Server_Statements : constant List_Id := New_List; Case_Alternatives : constant List_Id := New_List; Alignment_Const : Boolean := True; Args_Id : Node_Id; Parameter : Node_Id; Parameter_Name : Name_Id; Parameter_Mode : Mode_Id; Rewinded_Type : Node_Id; N : Node_Id; M : Node_Id; L : Node_Id; Cl_Buffer_Size : Node_Id; Sr_Buffer_Size : Node_Id; Bool_Exp1 : Node_Id; Bool_Exp2 : Node_Id; begin Args_Declared := False; Fixed_Client_Buffer := True; Fixed_Server_Buffer := True; Variable_Buffer := False; -- generate instructions to allocate the buffer needed to -- marshall the body message. -- The declarative part generation of the subprogram is -- postponed after the handling of the arguments and the -- result because it depends on the result of this handling. -- Subprogram specification Subp_Spec := Buffer_Size_Node (BE_Node (Identifier (E))); Args_Id := Map_Args_Identifier (Defining_Identifier (Stub_Node (BE_Node (Identifier (E))))); -- We do not recompute buffer size if there is no need -- bounded type (client side). if Contains_In_Parameters (E) then Cl_Buffer_Size := Make_Identifier (Add_Suffix_To_Name ("_Client_Size", IDL_Name (Identifier (E)))); Bool_Exp1 := Make_Expression (Cl_Buffer_Size, Op_Greater, Make_Literal (New_Integer_Value (512, 1, 10))); Bool_Exp2 := Make_Expression (Cl_Buffer_Size, Op_Not_Equal, Make_Literal (New_Integer_Value (0, 1, 10))); N := Make_Subprogram_Call (RE (RE_Preallocate_Buffer), New_List (Make_Identifier (PN (P_Buffer)), Cl_Buffer_Size)); M := Make_Return_Statement (No_Node); L := Make_Elsif_Statement (Condition => Bool_Exp2, Then_Statements => New_List (M)); L := Make_If_Statement (Condition => Bool_Exp1, Then_Statements => New_List (N, M), Elsif_Statements => New_List (L)); Append_To (Client_Statements, L); end if; -- We do not recompute buffer size if there is no need -- bounded type (server side). if Contains_Out_Parameters (E) or else (Present (T) and then FEN.Kind (T) /= K_Void) then Sr_Buffer_Size := Make_Identifier (Add_Suffix_To_Name ("_Server_Size", IDL_Name (Identifier (E)))); Bool_Exp1 := Make_Expression (Sr_Buffer_Size, Op_Greater, Make_Literal (New_Integer_Value (512, 1, 10))); Bool_Exp2 := Make_Expression (Sr_Buffer_Size, Op_Not_Equal, Make_Literal (New_Integer_Value (0, 1, 10))); N := Make_Subprogram_Call (RE (RE_Preallocate_Buffer), New_List (Make_Identifier (PN (P_Buffer)), Sr_Buffer_Size)); M := Make_Return_Statement (No_Node); L := Make_Elsif_Statement (Condition => Bool_Exp2, Then_Statements => New_List (M)); L := Make_If_Statement (Condition => Bool_Exp1, Then_Statements => New_List (N, M), Elsif_Statements => New_List (L)); Append_To (Server_Statements, L); end if; -- If the subprogram is a function, we handle the result if Present (T) and then FEN.Kind (T) /= K_Void then Rewinded_Type := FEU.Get_Original_Type_Specifier (T); -- Explaining comment Set_Str_To_Name_Buffer ("padding for Result : "); Get_Name_String_And_Append (PN (P_Returns)); Add_Str_To_Name_Buffer (" => "); Add_Str_To_Name_Buffer (FEN.Node_Kind'Image (FEN.Kind (Rewinded_Type))); N := Make_Ada_Comment (Name_Find); Append_To (Server_Statements, N); -- Body alignment N := Make_Subprogram_Call (RE (RE_Pad_Compute), New_List (Make_Identifier (VN (V_CDR_Position)), Make_Identifier (VN (V_Buffer_Size)), Make_Identifier (PN (P_Data_Alignment)))); Append_To (Server_Statements, N); -- Initialize body alignment to "1" if Contains_Out_Parameters (E) then N := Make_Assignment_Statement (Make_Defining_Identifier (PN (P_Data_Alignment)), Make_Literal (Int1_Val)); Append_To (Server_Statements, N); Alignment_Const := False; end if; -- Compute memory needed for result marshalling N := Make_Selected_Component (Copy_Node (Args_Id), Make_Defining_Identifier (PN (P_Returns))); N := Compute_Size (N, T, Subp_Declarations, E); Append_To (Server_Statements, N); -- If return type is unbounded we must recompute the -- server buffer size each time. if Variable_Buffer then Fixed_Server_Buffer := False; Variable_Buffer := False; end if; end if; -- Handling parameters if not FEU.Is_Empty (P) then -- Body alignment if Contains_Out_Parameters (E) then N := Make_Subprogram_Call (RE (RE_Pad_Compute), New_List (Make_Identifier (VN (V_CDR_Position)), Make_Identifier (VN (V_Buffer_Size)), Make_Identifier (PN (P_Data_Alignment)))); Append_To (Server_Statements, N); end if; if Contains_In_Parameters (E) then N := Make_Subprogram_Call (RE (RE_Pad_Compute), New_List (Make_Identifier (VN (V_CDR_Position)), Make_Identifier (VN (V_Buffer_Size)), Make_Identifier (PN (P_Data_Alignment)))); Append_To (Client_Statements, N); end if; -- Parameters Parameter := First_Entity (P); while Present (Parameter) loop Rewinded_Type := FEU.Get_Original_Type_Specifier (Type_Spec (Parameter)); Parameter_Name := To_Ada_Name (IDL_Name (Identifier (Declarator (Parameter)))); Parameter_Mode := FEN.Parameter_Mode (Parameter); -- The IN parameters are marshalled by client -- The OUT parameters are marshalled by server -- The INOUT parameters are marshalled by client and server -- Explaining comment Set_Str_To_Name_Buffer ("padding for Parameter : "); Get_Name_String_And_Append (Parameter_Name); Add_Str_To_Name_Buffer (" => "); Add_Str_To_Name_Buffer (FEN.Node_Kind'Image (FEN.Kind (FEU.Get_Original_Type_Specifier (Type_Spec (Parameter))))); if Is_In (Parameter_Mode) then N := Make_Ada_Comment (Name_Find); Append_To (Client_Statements, N); end if; if Is_Out (Parameter_Mode) then N := Make_Ada_Comment (Name_Find); Append_To (Server_Statements, N); end if; -- Compute parameter size if Is_In (Parameter_Mode) then N := Make_Selected_Component (Copy_Node (Args_Id), Make_Defining_Identifier (Parameter_Name)); N := Compute_Size (N, Type_Spec (Parameter), Subp_Declarations, E); Append_To (Client_Statements, N); -- If parameter type is unbounded we must recompute -- the client buffer size each time. if Variable_Buffer then Fixed_Client_Buffer := False; Variable_Buffer := False; end if; end if; if Is_Out (Parameter_Mode) then N := Make_Selected_Component (Copy_Node (Args_Id), Make_Defining_Identifier (Parameter_Name)); N := Compute_Size (N, Type_Spec (Parameter), Subp_Declarations, E); Append_To (Server_Statements, N); -- If parameter type is unbounded we must recompute -- the server buffer size each time. if Variable_Buffer then Fixed_Server_Buffer := False; Variable_Buffer := False; end if; end if; Parameter := Next_Entity (Parameter); end loop; end if; -- Allocate Buffer_Size octets if not BEU.Is_Empty (Client_Statements) then if Fixed_Client_Buffer then N := Make_Assignment_Statement (Cl_Buffer_Size, Make_Identifier (VN (V_Buffer_Size))); Append_To (Client_Statements, N); else N := Make_Assignment_Statement (Cl_Buffer_Size, Make_Literal (Int0_Val)); Append_To (Client_Statements, N); end if; N := Make_Subprogram_Call (RE (RE_Preallocate_Buffer), New_List (Make_Identifier (PN (P_Buffer)), Make_Identifier (VN (V_Buffer_Size)))); Append_To (Client_Statements, N); end if; if not BEU.Is_Empty (Server_Statements) then if Fixed_Server_Buffer then N := Make_Assignment_Statement (Sr_Buffer_Size, Make_Identifier (VN (V_Buffer_Size))); Append_To (Server_Statements, N); else N := Make_Assignment_Statement (Sr_Buffer_Size, Make_Literal (Int0_Val)); Append_To (Server_Statements, N); end if; N := Make_Subprogram_Call (RE (RE_Preallocate_Buffer), New_List (Make_Identifier (PN (P_Buffer)), Make_Identifier (VN (V_Buffer_Size)))); Append_To (Server_Statements, N); end if; -- The declarative part of the subprogram: if BEU.Is_Empty (Client_Statements) and then BEU.Is_Empty (Server_Statements) then declare Unref_Entities : constant array (Positive range <>) of Name_Id := (PN (P_Role), PN (P_Args), PN (P_Buffer), PN (P_First_Arg_Alignment)); begin for Index in Unref_Entities'Range loop N := Make_Pragma (Pragma_Unreferenced, New_List (Make_Identifier (Unref_Entities (Index)))); Append_To (Subp_Declarations, N); end loop; end; else -- It's complicated to determine if the parameters 'Args' -- is or isn't referenced (depending) on the types -- handled. So we ignore warnings raised about these -- parameter. N := Make_Pragma (Pragma_Warnings, New_List (RE (RE_Off), Make_Identifier (PN (P_Args)))); Append_To (Subp_Declarations, N); -- Common declarations -- 1/ Data_Alignment : This variable modified when there -- are OUT or INOUT parameters in order to avoid the -- alignment of buffer more than one time. N := Make_Object_Declaration (Defining_Identifier => Make_Defining_Identifier (PN (P_Data_Alignment)), Object_Definition => RE (RE_Alignment_Type), Constant_Present => Alignment_Const, Expression => Make_Identifier (PN (P_First_Arg_Alignment))); Append_To (Subp_Declarations, N); -- Use type instruction for arithmetic operation on -- Buffer_Size and CDR_Position. N := Make_Used_Type (Make_Identifier (Fully_Qualified_Name (RE (RE_Unsigned_Long_1)))); Append_To (Subp_Declarations, N); N := Make_Used_Type (Make_Identifier (Fully_Qualified_Name (RE (RE_Stream_Element_Count)))); Append_To (Subp_Declarations, N); -- Buffer_Size declaration and initialization N := Make_Object_Declaration (Defining_Identifier => Make_Defining_Identifier (VN (V_Buffer_Size)), Object_Definition => RE (RE_Stream_Element_Count), Constant_Present => False, Expression => Make_Expression (Make_Subprogram_Call (RE (RE_CDR_Position), New_List (Make_Identifier (PN (P_Buffer)))), Op_Minus, Make_Subprogram_Call (RE (RE_Length), New_List (Make_Identifier (PN (P_Buffer)))))); Append_To (Subp_Declarations, N); -- CDR_Position declaration and initialization N := Make_Object_Declaration (Defining_Identifier => Make_Defining_Identifier (VN (V_CDR_Position)), Object_Definition => RE (RE_Stream_Element_Count), Constant_Present => False, Expression => Make_Subprogram_Call (RE (RE_CDR_Position), New_List (Make_Identifier (PN (P_Buffer))))); Append_To (Subp_Declarations, N); end if; -- If the subprogram is a procedure without arguments, we -- add a null statement to the subprogram statements, else -- we build a switch case. if BEU.Is_Empty (Client_Statements) and then BEU.Is_Empty (Server_Statements) then Append_To (Subp_Statements, Make_Null_Statement); else -- Building the case statement if BEU.Is_Empty (Client_Statements) then Append_To (Client_Statements, Make_Null_Statement); end if; N := Make_Case_Statement_Alternative (Client_Case, Client_Statements); Append_To (Case_Alternatives, N); if BEU.Is_Empty (Server_Statements) then Append_To (Server_Statements, Make_Null_Statement); end if; N := Make_Case_Statement_Alternative (Server_Case, Server_Statements); Append_To (Case_Alternatives, N); N := Make_Case_Statement (Make_Identifier (PN (P_Role)), Case_Alternatives); Append_To (Subp_Statements, N); end if; -- Building the subprogram implementation N := Make_Subprogram_Body (Specification => Subp_Spec, Declarations => Subp_Declarations, Statements => Subp_Statements); return N; end Buffer_Size_Body; -------------------- -- Get_Index_Name -- -------------------- function Get_Index_Name return Name_Id is Index : Name_Id; begin Set_Str_To_Name_Buffer ("Index_"); Index_Number := Index_Number + 1; Add_Nat_To_Name_Buffer (Index_Number); Index := Name_Find; return Index; end Get_Index_Name; ----------- -- Visit -- ----------- procedure Visit (E : Node_Id) is begin case FEN.Kind (E) is when K_Attribute_Declaration => Visit_Attribute_Declaration (E); when K_Interface_Declaration => Visit_Interface_Declaration (E); when K_Module => Visit_Module (E); when K_Operation_Declaration => Visit_Operation_Declaration (E); when K_Specification => Visit_Specification (E); when others => null; end case; end Visit; --------------------------------- -- Visit_Attribute_Declaration -- --------------------------------- procedure Visit_Attribute_Declaration (E : Node_Id) is N : Node_Id; D : Node_Id; begin Set_Buffers_Body; D := First_Entity (Declarators (E)); while Present (D) loop Set_Str_To_Name_Buffer ("Attribute : "); Get_Name_String_And_Append (IDL_Name (Identifier (D))); N := Make_Ada_Comment (Name_Find); Append_To (Statements (Current_Package), N); D := Next_Entity (D); end loop; end Visit_Attribute_Declaration; --------------------------------- -- Visit_Interface_Declaration -- --------------------------------- procedure Visit_Interface_Declaration (E : Node_Id) is N : Node_Id; begin -- No buffers package is generated for a local interface if FEN.Is_Local_Interface (E) then return; end if; N := BEN.Parent (Type_Def_Node (BE_Node (Identifier (E)))); Push_Entity (BEN.IDL_Unit (Package_Declaration (N))); Set_Buffers_Body; N := First_Entity (Interface_Body (E)); while Present (N) loop Visit (N); N := Next_Entity (N); end loop; Pop_Entity; end Visit_Interface_Declaration; ------------------ -- Visit_Module -- ------------------ procedure Visit_Module (E : Node_Id) is D : Node_Id; begin if not Map_Particular_CORBA_Parts (E, PK_Buffers_Body) then Push_Entity (Stub_Node (BE_Node (Identifier (E)))); D := First_Entity (Definitions (E)); while Present (D) loop Visit (D); D := Next_Entity (D); end loop; Pop_Entity; end if; end Visit_Module; --------------------------------- -- Visit_Operation_Declaration -- --------------------------------- procedure Visit_Operation_Declaration (E : Node_Id) is N : Node_Id; begin Set_Buffers_Body; Set_Str_To_Name_Buffer ("Operation : "); Get_Name_String_And_Append (IDL_Name (Identifier (E))); N := Make_Ada_Comment (Name_Find); Append_To (Statements (Current_Package), N); -- Generating the 'Operation_Name'_Buffer_Size Body N := Buffer_Size_Body (E); Append_To (Statements (Current_Package), N); end Visit_Operation_Declaration; ------------------------- -- Visit_Specification -- ------------------------- procedure Visit_Specification (E : Node_Id) is Definition : Node_Id; begin Push_Entity (Stub_Node (BE_Node (Identifier (E)))); Definition := First_Entity (Definitions (E)); while Present (Definition) loop Visit (Definition); Definition := Next_Entity (Definition); end loop; Pop_Entity; end Visit_Specification; ----------------------- -- Compute_Size -- ----------------------- function Compute_Size (Var_Node : Node_Id; Var_Type : Node_Id; Subp_Dec : List_Id; Subp_Nod : Node_Id) return Node_Id is Block_Dcl : constant List_Id := New_List; Block_St : constant List_Id := New_List; N : Node_Id; Type_Spec_Node : Node_Id; Direct_Type_Node : Node_Id; begin -- Getting the original type Type_Spec_Node := FEU.Get_Original_Type_Specifier (Var_Type); if FEN.Kind (Var_Type) = K_Simple_Declarator or else FEN.Kind (Var_Type) = K_Complex_Declarator then Direct_Type_Node := Type_Spec (Declaration (Var_Type)); else Direct_Type_Node := Var_Type; end if; case FEN.Kind (Type_Spec_Node) is when K_Object | K_Interface_Declaration => declare Padding_Value : Value_Id; begin Padding_Value := Parameter_Size (Type_Spec_Node); -- We send an IOR so we make a padding on 4 octets N := Make_Subprogram_Call (RE (RE_Pad_Compute), New_List (Make_Identifier (VN (V_CDR_Position)), Make_Identifier (VN (V_Buffer_Size)), Make_Literal (New_Integer_Value (4, 1, 10)))); Append_To (Block_St, N); N := Make_Assignment_Statement (Make_Defining_Identifier (VN (V_Buffer_Size)), Make_Expression (Make_Literal (Padding_Value), Op_Plus, Make_Defining_Identifier (VN (V_Buffer_Size)))); Append_To (Block_St, N); N := Make_Assignment_Statement (Make_Defining_Identifier (VN (V_CDR_Position)), Make_Expression (Make_Literal (Padding_Value), Op_Plus, Make_Defining_Identifier (VN (V_CDR_Position)))); Append_To (Block_St, N); end; when K_Wide_Char => declare M : Node_Id; begin -- The padding of Wchar depend on the GIOP version -- and the Code Set so we make a padding for the -- worst case (ex :GIOP 1.1 with ISO 10646 -- UCS-4CS). N := Make_Assignment_Statement (Make_Defining_Identifier (VN (V_Buffer_Size)), Make_Expression (Make_Identifier (VN (V_Buffer_Size)), Op_Plus, Make_Literal (New_Integer_Value (4, 1, 10)))); Append_To (Block_St, N); N := Make_Assignment_Statement (Make_Defining_Identifier (VN (V_CDR_Position)), Make_Expression (Make_Identifier (VN (V_CDR_Position)), Op_Plus, Make_Literal (New_Integer_Value (4, 1, 10)))); Append_To (Block_St, N); -- Wchar size M := Make_Subprogram_Call (RE (RE_Type_Size), New_List (Cast_Variable_To_PolyORB_Type (Var_Node, Direct_Type_Node))); N := Make_Assignment_Statement (Make_Defining_Identifier (VN (V_Buffer_Size)), Make_Expression (Make_Subprogram_Call (RE (RE_Stream_Element_Count), New_List (M)), Op_Plus, Make_Defining_Identifier (VN (V_Buffer_Size)))); Append_To (Block_St, N); N := Make_Assignment_Statement (Make_Defining_Identifier (VN (V_CDR_Position)), Make_Expression (Make_Subprogram_Call (RE (RE_Stream_Element_Count), New_List (M)), Op_Plus, Make_Defining_Identifier (VN (V_CDR_Position)))); Append_To (Block_St, N); if not Args_Declared then Declare_Args (Subp_Dec, Subp_Nod); end if; Variable_Buffer := True; end; when K_Boolean | K_Double | K_Float | K_Long | K_Long_Long | K_Octet | K_Short | K_Unsigned_Long | K_Unsigned_Long_Long | K_Unsigned_Short | K_Enumeration_Type | K_Char => declare Padding_Value : Value_Id; begin -- Getting the parameter size Padding_Value := Parameter_Size (Type_Spec_Node); -- Padding N := Make_Subprogram_Call (RE (RE_Pad_Compute), New_List (Make_Identifier (VN (V_CDR_Position)), Make_Identifier (VN (V_Buffer_Size)), Make_Literal (Padding_Value))); Append_To (Block_St, N); -- Update Buffer_Size and CDR_Position N := Make_Assignment_Statement (Make_Defining_Identifier (VN (V_Buffer_Size)), Make_Expression (Make_Literal (Padding_Value), Op_Plus, Make_Defining_Identifier (VN (V_Buffer_Size)))); Append_To (Block_St, N); N := Make_Assignment_Statement (Make_Defining_Identifier (VN (V_CDR_Position)), Make_Expression (Make_Literal (Padding_Value), Op_Plus, Make_Defining_Identifier (VN (V_CDR_Position)))); Append_To (Block_St, N); end; when K_String_Type | K_Wide_String_Type => declare Padding_Value : Value_Id; begin -- Getting the string length Padding_Value := Parameter_Size (Type_Spec_Node); -- Padding for the string length N := Make_Subprogram_Call (RE (RE_Pad_Compute), New_List (Make_Identifier (VN (V_CDR_Position)), Make_Identifier (VN (V_Buffer_Size)), Make_Literal (New_Integer_Value (4, 1, 10)))); Append_To (Block_St, N); -- Update Buffer_Size and CDR_Position N := Make_Assignment_Statement (Make_Defining_Identifier (VN (V_Buffer_Size)), Make_Expression (Make_Literal (New_Integer_Value (4, 1, 10)), Op_Plus, Make_Identifier (VN (V_Buffer_Size)))); Append_To (Block_St, N); N := Make_Assignment_Statement (Make_Defining_Identifier (VN (V_CDR_Position)), Make_Expression (Make_Literal (New_Integer_Value (4, 1, 10)), Op_Plus, Make_Identifier (VN (V_CDR_Position)))); Append_To (Block_St, N); -- Add the string length to Buffer_Size and -- CDR_Position. N := Make_Assignment_Statement (Make_Defining_Identifier (VN (V_Buffer_Size)), Make_Expression (Make_Literal (Padding_Value), Op_Plus, Make_Defining_Identifier (VN (V_Buffer_Size)))); Append_To (Block_St, N); N := Make_Assignment_Statement (Make_Defining_Identifier (VN (V_CDR_Position)), Make_Expression (Make_Literal (Padding_Value), Op_Plus, Make_Defining_Identifier (VN (V_CDR_Position)))); Append_To (Block_St, N); end; when K_Fixed_Point_Type => declare M : Node_Id; begin -- Getting the fixed_point type N := Expand_Designator (Type_Def_Node (BE_Node (Type_Spec_Node))); -- Instantiate the package: -- PolyORB.Buffers.Optimization.Fixed_Point N := Make_Package_Instantiation (Make_Defining_Identifier (VN (V_FXS)), RU (RU_PolyORB_Buffers_Optimization_Fixed_Point), New_List (N)); Append_To (Block_Dcl, N); N := Make_Selected_Component (VN (V_FXS), SN (S_Type_Size)); M := Make_Subprogram_Call (RE (RE_Stream_Element_Count), (New_List (Make_Subprogram_Call (N, New_List (Cast_Variable_To_PolyORB_Type (Var_Node, Direct_Type_Node)))))); -- Update Buffer_Size and CDR_Position N := Make_Assignment_Statement (Make_Defining_Identifier (VN (V_Buffer_Size)), Make_Expression (M, Op_Plus, Make_Defining_Identifier (VN (V_Buffer_Size)))); Append_To (Block_St, N); N := Make_Assignment_Statement (Make_Defining_Identifier (VN (V_CDR_Position)), Make_Expression (M, Op_Plus, Make_Defining_Identifier (VN (V_CDR_Position)))); Append_To (Block_St, N); -- Indicate the use of method_name_args variable if not Args_Declared then Declare_Args (Subp_Dec, Subp_Nod); end if; Variable_Buffer := True; end; when K_Long_Double => declare Padding_Value : Value_Id; begin -- Alignment for Long Double is not equal to his -- size (/= 16). Padding_Value := Parameter_Size (Type_Spec_Node); N := Make_Subprogram_Call (RE (RE_Pad_Compute), New_List (Make_Identifier (VN (V_CDR_Position)), Make_Identifier (VN (V_Buffer_Size)), Make_Literal (New_Integer_Value (8, 1, 10)))); Append_To (Block_St, N); -- Update Buffer_Size and CDR_Position N := Make_Assignment_Statement (Make_Defining_Identifier (VN (V_Buffer_Size)), Make_Expression (Make_Literal (Padding_Value), Op_Plus, Make_Defining_Identifier (VN (V_Buffer_Size)))); Append_To (Block_St, N); N := Make_Assignment_Statement (Make_Defining_Identifier (VN (V_CDR_Position)), Make_Expression (Make_Literal (Padding_Value), Op_Plus, Make_Defining_Identifier (VN (V_CDR_Position)))); Append_To (Block_St, N); end; when K_String | K_Wide_String => declare M : Node_Id; begin -- Padding for string length N := Make_Subprogram_Call (RE (RE_Pad_Compute), New_List (Make_Identifier (VN (V_CDR_Position)), Make_Identifier (VN (V_Buffer_Size)), Make_Literal (New_Integer_Value (4, 1, 10)))); Append_To (Block_St, N); -- Update Buffer_Size and CDR_Position for the -- marshalling of string length. N := Make_Assignment_Statement (Make_Defining_Identifier (VN (V_Buffer_Size)), Make_Expression (Make_Identifier (VN (V_Buffer_Size)), Op_Plus, Make_Literal (New_Integer_Value (4, 1, 10)))); Append_To (Block_St, N); N := Make_Assignment_Statement (Make_Defining_Identifier (VN (V_CDR_Position)), Make_Expression (Make_Identifier (VN (V_CDR_Position)), Op_Plus, Make_Literal (New_Integer_Value (4, 1, 10)))); Append_To (Block_St, N); -- Call of Type_Size subprogram M := Make_Subprogram_Call (RE (RE_Type_Size), New_List (Cast_Variable_To_PolyORB_Type (Var_Node, Direct_Type_Node))); N := Make_Assignment_Statement (Make_Defining_Identifier (VN (V_Buffer_Size)), Make_Expression (Make_Subprogram_Call (RE (RE_Stream_Element_Count), New_List (M)), Op_Plus, Make_Defining_Identifier (VN (V_Buffer_Size)))); Append_To (Block_St, N); N := Make_Assignment_Statement (Make_Defining_Identifier (VN (V_CDR_Position)), Make_Expression (Make_Subprogram_Call (RE (RE_Stream_Element_Count), New_List (M)), Op_Plus, Make_Defining_Identifier (VN (V_CDR_Position)))); Append_To (Block_St, N); -- Indicate the use of method_name_args variable if not Args_Declared then Declare_Args (Subp_Dec, Subp_Nod); end if; Variable_Buffer := True; end; when K_Sequence_Type => declare Seq_Package_Node : Node_Id; Seq_Element : Node_Id; Index_Node : Node_Id; Range_Constraint : Node_Id; Padding_Value : Value_Id; For_Statements : constant List_Id := New_List; begin -- padding for sequence length N := Make_Subprogram_Call (RE (RE_Pad_Compute), New_List (Make_Identifier (VN (V_CDR_Position)), Make_Identifier (VN (V_Buffer_Size)), Make_Literal (New_Integer_Value (4, 1, 10)))); Append_To (Block_St, N); -- updating Buffer_Size and CDR_Position N := Make_Assignment_Statement (Make_Defining_Identifier (VN (V_Buffer_Size)), Make_Expression (Make_Identifier (VN (V_Buffer_Size)), Op_Plus, Make_Literal (New_Integer_Value (4, 1, 10)))); Append_To (Block_St, N); N := Make_Assignment_Statement (Make_Defining_Identifier (VN (V_CDR_Position)), Make_Expression (Make_Identifier (VN (V_CDR_Position)), Op_Plus, Make_Literal (New_Integer_Value (4, 1, 10)))); Append_To (Block_St, N); -- Getting the instantiated package node Seq_Package_Node := Defining_Identifier (Instantiation_Node (BE_Node (Type_Spec_Node))); -- Getting the sequence length N := Make_Object_Declaration (Defining_Identifier => Make_Defining_Identifier (VN (V_Seq_Len)), Object_Definition => RE (RE_Unsigned_Long_1)); Append_To (Block_Dcl, N); N := Make_Selected_Component (Seq_Package_Node, Make_Identifier (SN (S_Length))); N := Make_Subprogram_Call (N, New_List (Cast_Variable_To_PolyORB_Type (Var_Node, Direct_Type_Node))); N := Make_Subprogram_Call (RE (RE_Unsigned_Long_1), New_List (N)); N := Make_Assignment_Statement (Make_Defining_Identifier (VN (V_Seq_Len)), N); Append_To (Block_St, N); N := Make_Selected_Component (Seq_Package_Node, Get_Base_Identifier (RE (RE_Get_Element))); -- Verify if the element type is complex Padding_Value := Parameter_Size (Type_Spec (Type_Spec_Node)); if Padding_Value = Int0_Val then -- Sequence element type is complex Index_Node := Make_Defining_Identifier (VN (V_Index)); -- Creating the range constraint Range_Constraint := Make_Range_Constraint (Make_Literal (Int1_Val), Make_Defining_Identifier (VN (V_Seq_Len))); -- Getting the sequence element Seq_Element := Make_Subprogram_Call (N, New_List (Cast_Variable_To_PolyORB_Type (Var_Node, Direct_Type_Node), Make_Subprogram_Call (RE (RE_Positive), New_List (Index_Node)))); N := Compute_Size (Var_Node => Seq_Element, Var_Type => Type_Spec (Type_Spec_Node), Subp_Dec => Subp_Dec, Subp_Nod => Subp_Nod); Append_To (For_Statements, N); -- Building the loop N := Make_For_Statement (Index_Node, Range_Constraint, For_Statements); Append_To (Block_St, N); else -- Sequence element type is simple so we can -- compute sequence size without a loop. declare M : Node_Id; begin -- Padding for the first element N := Make_Subprogram_Call (RE (RE_Pad_Compute), New_List (Make_Identifier (VN (V_CDR_Position)), Make_Identifier (VN (V_Buffer_Size)), Make_Literal (Padding_Value))); Append_To (Block_St, N); -- Multiply 'Len' by sequence element size M := Make_Expression (Make_Defining_Identifier (VN (V_Seq_Len)), Op_Asterisk, Make_Literal (Padding_Value)); -- Update buffer_size and CDR_Position N := Make_Assignment_Statement (Make_Defining_Identifier (VN (V_Buffer_Size)), Make_Expression (Make_Subprogram_Call (RE (RE_Stream_Element_Count), New_List (M)), Op_Plus, Make_Defining_Identifier (VN (V_Buffer_Size)))); Append_To (Block_St, N); N := Make_Assignment_Statement (Make_Defining_Identifier (VN (V_CDR_Position)), Make_Expression (Make_Subprogram_Call (RE (RE_Stream_Element_Count), New_List (M)), Op_Plus, Make_Defining_Identifier (VN (V_CDR_Position)))); Append_To (Block_St, N); end; end if; if not Args_Declared then Declare_Args (Subp_Dec, Subp_Nod); end if; Variable_Buffer := True; end; when K_Complex_Declarator => declare I : Nat := 0; Sizes : constant List_Id := Range_Constraints (Type_Definition (Type_Def_Node (BE_Node (Identifier (Type_Spec_Node))))); Dim : Node_Id; Loop_Statements : List_Id := No_List; Enclosing_Statements : List_Id; Index_List : constant List_Id := New_List; Index_Node : Node_Id := No_Node; Index_Name : constant Name_Id := Get_Index_Name; Padding_Value : Value_Id; M : Node_Id; Loop_Range : Value_Id; Type_Param : Node_Id; begin Type_Param := Type_Spec (Declaration (Type_Spec_Node)); Padding_Value := Parameter_Size (Type_Param); -- If element type is simple if Padding_Value /= Int0_Val then -- Compute the number of element of the array Dim := First_Node (Sizes); M := Make_Literal (Padding_Value); loop Loop_Range := New_Integer_Value (Unsigned_Long_Long'Value (Values.Image (Get_Value (Last (Dim)))) + 1, 1, 10); M := Make_Expression (Make_Literal (Loop_Range), Op_Asterisk, M); Dim := Next_Node (Dim); exit when No (Dim); end loop; N := Make_Subprogram_Call (RE (RE_Pad_Compute), New_List (Make_Identifier (VN (V_CDR_Position)), Make_Identifier (VN (V_Buffer_Size)), Make_Literal (Padding_Value))); Append_To (Block_St, N); -- Update Buffer_Size and CDR_Position N := Make_Assignment_Statement (Make_Defining_Identifier (VN (V_Buffer_Size)), Make_Expression (Make_Literal (Padding_Value), Op_Plus, M)); Append_To (Block_St, N); N := Make_Assignment_Statement (Make_Defining_Identifier (VN (V_CDR_Position)), Make_Expression (Make_Literal (Padding_Value), Op_Plus, M)); Append_To (Block_St, N); else -- Element type is complex, Building the nested -- loops Dim := First_Node (Sizes); loop Get_Name_String (Index_Name); Add_Char_To_Name_Buffer ('_'); Add_Nat_To_Name_Buffer (I); Index_Node := Make_Defining_Identifier (Add_Suffix_To_Name (Unique_Suffix, Name_Find)); Append_To (Index_List, Index_Node); Enclosing_Statements := Loop_Statements; Loop_Statements := New_List; N := Make_For_Statement (Index_Node, Dim, Loop_Statements); if I > 0 then Append_To (Enclosing_Statements, N); else Append_To (Block_St, N); end if; I := I + 1; Dim := Next_Node (Dim); exit when No (Dim); end loop; -- Filling the statements of the deepest loop by -- the making padding for the corresponding -- array element. N := Make_Subprogram_Call (Var_Node, Index_List); N := Compute_Size (Var_Node => N, Var_Type => Type_Spec (Declaration (Type_Spec_Node)), Subp_Dec => Subp_Dec, Subp_Nod => Subp_Nod); Append_To (Loop_Statements, N); end if; end; when K_Structure_Type => declare Member : Node_Id; Declarator : Node_Id; Dcl_Ada_Name : Name_Id; Dcl_Ada_Node : Node_Id; begin Member := First_Entity (Members (Type_Spec_Node)); while Present (Member) loop Declarator := First_Entity (FEN.Declarators (Member)); while Present (Declarator) loop -- Getting the record field name Dcl_Ada_Name := To_Ada_Name (IDL_Name (Identifier (Declarator))); Dcl_Ada_Node := Make_Selected_Component (Var_Node, Make_Identifier (Dcl_Ada_Name)); -- Marshalling the record field N := Compute_Size (Var_Node => Dcl_Ada_Node, Var_Type => Declarator, Subp_Dec => Subp_Dec, Subp_Nod => Subp_Nod); Append_To (Block_St, N); Declarator := Next_Entity (Declarator); end loop; Member := Next_Entity (Member); end loop; end; when K_Union_Type => declare Switch_Node : Node_Id; Switch_Alternatives : List_Id; Switch_Case : Node_Id; Has_Default : Boolean := False; Choices : List_Id; Literal_Parent : Node_Id := No_Node; Switch_Statements : List_Id; Switch_Type : Node_Id; Dcl_Ada_Name : Name_Id; Dcl_Ada_Node : Node_Id; Declarator : Node_Id; begin -- 1/ Marshall the union switch Switch_Node := Make_Selected_Component (Var_Node, Make_Identifier (CN (C_Switch))); N := Compute_Size (Var_Node => Switch_Node, Var_Type => Switch_Type_Spec (Type_Spec_Node), Subp_Dec => Subp_Dec, Subp_Nod => Subp_Nod); Append_To (Block_St, N); -- 2/ Depending on the switch value, marshall the -- corresponding flag. Switch_Type := FEU.Get_Original_Type_Specifier (Switch_Type_Spec (Type_Spec_Node)); if FEN.Kind (Switch_Type) = K_Enumeration_Type then Literal_Parent := Map_Expanded_Name (Scope_Entity (Identifier (Switch_Type))); end if; Switch_Alternatives := New_List; Switch_Case := First_Entity (Switch_Type_Body (Type_Spec_Node)); while Present (Switch_Case) loop Map_Choice_List (Labels (Switch_Case), Literal_Parent, Choices, Has_Default); Switch_Statements := New_List; -- Getting the field name Declarator := FEN.Declarator (Element (Switch_Case)); Dcl_Ada_Name := To_Ada_Name (IDL_Name (Identifier (Declarator))); Dcl_Ada_Node := Make_Selected_Component (Var_Node, Make_Identifier (Dcl_Ada_Name)); -- Marshalling the record field N := Compute_Size (Var_Node => Dcl_Ada_Node, Var_Type => Declarator, Subp_Dec => Subp_Dec, Subp_Nod => Subp_Nod); Append_To (Switch_Statements, N); Append_To (Switch_Alternatives, Make_Case_Statement_Alternative (Choices, Switch_Statements)); Switch_Case := Next_Entity (Switch_Case); end loop; -- Add an empty when others clause to keep the compiler -- happy. if not Has_Default then Append_To (Switch_Alternatives, Make_Case_Statement_Alternative (No_List, No_List)); end if; Append_To (Block_St, Make_Case_Statement (Switch_Node, Switch_Alternatives)); if not Args_Declared then Declare_Args (Subp_Dec, Subp_Nod); end if; Variable_Buffer := True; end; when others => Append_To (Block_St, Make_Null_Statement); end case; N := Make_Block_Statement (Declarative_Part => Block_Dcl, Statements => Block_St); return N; end Compute_Size; ---------------------- -- Parameter_Size -- ---------------------- function Parameter_Size (N : Node_Id) return Value_Id is Type_Spec_Node : Node_Id; begin Type_Spec_Node := FEU.Get_Original_Type_Specifier (N); case FEN.Kind (Type_Spec_Node) is when K_Boolean | K_Char => return New_Integer_Value (1, 1, 10); when K_Short | K_Unsigned_Short => return New_Integer_Value (2, 1, 10); when K_Unsigned_Long | K_Float | K_Enumeration_Type | K_Long => return New_Integer_Value (4, 1, 10); when K_Long_Long | K_Unsigned_Long_Long | K_Double => return New_Integer_Value (8, 1, 10); when K_Long_Double => return New_Integer_Value (16, 1, 10); when K_Octet => return New_Integer_Value (1, 1, 10); when K_String_Type | K_Wide_String_Type => declare String_Size : Unsigned_Long_Long; begin String_Size := Unsigned_Long_Long'Value (Values.Image (FEU.Expr_Value (Max_Size (Type_Spec_Node)))); return New_Integer_Value (String_Size, 1, 10); end; when K_Object | K_Interface_Declaration => -- Just an estimation IOR hasn't a fixed length return New_Integer_Value (1024, 1, 10); when others => return Int0_Val; end case; end Parameter_Size; procedure Declare_Args (Subp_Dec : List_Id; Subp_Nod : Node_Id) is Args_Id : Node_Id; M : Node_Id; N : Node_Id; begin Args_Declared := True; N := Expand_Designator (Type_Def_Node (BE_Node (Identifier (Subp_Nod)))); Args_Id := Map_Args_Identifier (Defining_Identifier (Stub_Node (BE_Node (Identifier (Subp_Nod))))); M := Make_Explicit_Dereference (Make_Identifier (PN (P_Args))); N := Make_Object_Declaration (Defining_Identifier => Args_Id, Object_Definition => N, Expression => Make_Subprogram_Call (N, New_List (M))); Append_To (Subp_Dec, N); end Declare_Args; end Package_Body; end Backend.BE_CORBA_Ada.Buffers; polyorb-2.8~20110207.orig/compilers/iac/backend-be_corba_ada-skels.adb0000644000175000017500000030032211750740337024656 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- B A C K E N D . B E _ C O R B A _ A D A . S K E L S -- -- -- -- B o d y -- -- -- -- Copyright (C) 2005-2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with Ada.Directories; with Namet; use Namet; with Values; use Values; with Flags; use Flags; with Output; with Frontend.Nodes; use Frontend.Nodes; with Frontend.Nutils; with Backend.BE_CORBA_Ada.IDL_To_Ada; use Backend.BE_CORBA_Ada.IDL_To_Ada; with Backend.BE_CORBA_Ada.Nodes; use Backend.BE_CORBA_Ada.Nodes; with Backend.BE_CORBA_Ada.Nutils; use Backend.BE_CORBA_Ada.Nutils; with Backend.BE_CORBA_Ada.Runtime; use Backend.BE_CORBA_Ada.Runtime; with Backend.BE_CORBA_Ada.Common; use Backend.BE_CORBA_Ada.Common; with GNAT.OS_Lib; with GNAT.Perfect_Hash_Generators; package body Backend.BE_CORBA_Ada.Skels is package FEN renames Frontend.Nodes; package BEN renames Backend.BE_CORBA_Ada.Nodes; package FEU renames Frontend.Nutils; package PHG renames GNAT.Perfect_Hash_Generators; use type PHG.Optimization; ------------------ -- Package_Spec -- ------------------ package body Package_Spec is procedure Visit_Interface_Declaration (E : Node_Id); procedure Visit_Module (E : Node_Id); procedure Visit_Specification (E : Node_Id); ----------- -- Visit -- ----------- procedure Visit (E : Node_Id) is begin case FEN.Kind (E) is when K_Interface_Declaration => Visit_Interface_Declaration (E); when K_Module => Visit_Module (E); when K_Specification => Visit_Specification (E); when others => null; end case; end Visit; --------------------------------- -- Visit_Interface_Declaration -- --------------------------------- procedure Visit_Interface_Declaration (E : Node_Id) is N : Node_Id; begin -- No Skel package is generated for an abstract or local interface if FEN.Is_Abstract_Interface (E) or else FEN.Is_Local_Interface (E) then return; end if; N := BEN.Parent (Type_Def_Node (BE_Node (Identifier (E)))); Push_Entity (BEN.IDL_Unit (Package_Declaration (N))); Set_Skeleton_Spec; -- Generate declaration of Deferred_Initialization so that a package -- body is required. We do not use a pragma Elaborate_Body here -- because we need to support having one in the Impl (in the case -- of an interface with no operations). Append_To (Visible_Part (Current_Package), Make_Subprogram_Specification (Make_Defining_Identifier (SN (S_Deferred_Initialization)), No_List)); N := First_Entity (Interface_Body (E)); while Present (N) loop Visit (N); N := Next_Entity (N); end loop; Pop_Entity; end Visit_Interface_Declaration; ------------------ -- Visit_Module -- ------------------ procedure Visit_Module (E : Node_Id) is D : Node_Id; begin if not Map_Particular_CORBA_Parts (E, PK_Skel_Spec) then Push_Entity (Stub_Node (BE_Node (Identifier (E)))); D := First_Entity (Definitions (E)); while Present (D) loop Visit (D); D := Next_Entity (D); end loop; Pop_Entity; end if; end Visit_Module; ------------------------- -- Visit_Specification -- ------------------------- procedure Visit_Specification (E : Node_Id) is Definition : Node_Id; begin Push_Entity (Stub_Node (BE_Node (Identifier (E)))); Definition := First_Entity (Definitions (E)); while Present (Definition) loop Visit (Definition); Definition := Next_Entity (Definition); end loop; Pop_Entity; end Visit_Specification; end Package_Spec; ------------------ -- Package_Body -- ------------------ package body Package_Body is Invoke_Then_Statements : List_Id := No_List; Invoke_Elsif_Statements : List_Id := No_List; Invoke_Methods : List_Id := No_List; Package_Initialization : List_Id := No_List; Choice_List : List_Id := No_List; Dependency_List : List_Id := No_List; Has_Operations : Boolean := False; Buffer_Necessary : Boolean := False; function Gen_Invoke_Method (Operation_Name : Name_Id; Declarations : List_Id; Statements : List_Id) return Node_Id; -- Generates and returns a call to the Invoke_ -- procedure. As a side effect, generates the spec and body of that -- procedure, and appends them to Invoke_Methods. There is one such -- procedure for each method, and they are called from the case -- statement in the Dispatch procedure below. function Gen_Dispatch (Case_Statement : Node_Id) return Node_Id; -- Generates and returns a call to the Dispatch procedure. As a side -- effect, generates the spec and body of that procedure, and appends -- them to Invoke_Methods. The Dispatch procedure contains a case -- statement that calls the appropriate Invoke_. function Deferred_Initialization_Body (E : Node_Id) return Node_Id; -- Generate the body of the deferred initialization procedure function Gen_Invoke_Part (E : Node_Id) return Node_Id; -- Generate an 'elsif' or 'when ...' containing the statements related -- to the operation `E' in the Invoke procedure. function Invoke_Body (E : Node_Id; Is_A_Invk_Part : Node_Id) return Node_Id; -- Generate the body of procedure Invoke. This body contains one nested -- procedure Invoke_ for each method, plus a procedure -- Dispatch, which contains a case statement calling all the procedures -- Invoke_. Invoke calls Dispatch and catches -- exceptions. One reason for separating out the nested procedures is to -- make the generated code compile in a reasonable amount of time/memory -- in sjlj mode. Also, it seems a bit more readable. procedure Invoke_Declaration (L : List_Id); function Invoke_Spec return Node_Id; function Is_A_Invoke_Part return Node_Id; function Implicit_CORBA_Methods return List_Id; function Servant_Is_A_Body (Spec : Node_Id) return Node_Id; procedure Skeleton_Initialization (L : List_Id); function Non_User_Exception_Handler return Node_Id; procedure Visit_Interface_Declaration (E : Node_Id); procedure Visit_Module (E : Node_Id); procedure Visit_Operation_Declaration (E : Node_Id); procedure Visit_Specification (E : Node_Id); -- The entities below are used in case of optimization using -- minimal perfect hash functions. N_Subprograms : Unsigned_Long_Long; Register_Procedure_List : List_Id; Invoke_Subp_Bodies : List_Id; function Hash_Package_Name (E : Node_Id) return Name_Id; -- This function generates the name of the package that will -- contain the Hash function. procedure Initialize_Hash_Function_Optimization; -- This procedure initialise the lists above. It initialises -- the GNAT Perfect_Hash generator. procedure Achieve_Hash_Function_Optimization (E : Node_Id); -- This procedure computes the Perfect Hash function generator, -- produces it in an additional package and finally finalizes -- the generator. procedure Insert_And_Register_Statements (Subp_Name : Name_Id); -- This function inserts the name of the subprogram to the -- Perfect hash function generator. It produces also a -- "Register procedure" call statement which will be added to -- the Deferred_Initialization procedure statements. function Register_Procedure_Spec return Node_Id; function Register_Procedure_Body (E : Node_Id) return Node_Id; -- Generation of the Register_Procedure subprogram which is -- called to register a procedure in the hash table. procedure Put_To_Stdout; -- Read the perfect-hash files in the current directory, and send them -- to standard output. Used for the -p switch (see -- Achieve_Hash_Function_Optimization below). ---------------------------------- -- Deferred_Initialization_Body -- ---------------------------------- function Deferred_Initialization_Body (E : Node_Id) return Node_Id is N : Node_Id; Profile : constant List_Id := New_List; Spec : Node_Id; Statements : constant List_Id := New_List; begin Spec := Make_Subprogram_Specification (Make_Defining_Identifier (SN (S_Deferred_Initialization)), No_List); N := Type_Def_Node (BE_Node (Identifier (E))); N := Next_Node (N); N := Expand_Designator (N); Append_To (Profile, N); N := Make_Attribute_Reference (Make_Identifier (SN (S_Servant_Is_A)), A_Access); Append_To (Profile, N); N := Make_Attribute_Reference (Make_Identifier (SN (S_Is_A)), A_Access); Append_To (Profile, N); N := Make_Attribute_Reference (Make_Identifier (SN (S_Invoke)), A_Access); Append_To (Profile, N); N := Make_Subprogram_Call (RE (RE_Register_Skeleton), Profile); Append_To (Statements, N); -- In case of perfect hash function optimization, we register the -- Invoke_XXXX procedures at package initialization. if Use_Minimal_Hash_Function then Append_To (Statements, First_Node (Register_Procedure_List)); end if; N := Make_Subprogram_Body (Spec, No_List, Statements); return N; end Deferred_Initialization_Body; ----------------------- -- Gen_Dispatch -- ----------------------- function Gen_Dispatch (Case_Statement : Node_Id) return Node_Id is Dispatch : constant Node_Id := Make_Defining_Identifier (SN (S_Dispatch)); N : Node_Id; begin N := Make_Subprogram_Specification (Dispatch, No_List); Append_To (Invoke_Methods, N); N := Make_Subprogram_Body (Specification => Make_Subprogram_Specification (Dispatch, No_List), Declarations => No_List, Statements => New_List (Case_Statement)); Append_To (Invoke_Methods, N); N := Make_Subprogram_Call (Dispatch, No_List); return N; end Gen_Dispatch; ----------------------- -- Gen_Invoke_Method -- ----------------------- function Gen_Invoke_Method (Operation_Name : Name_Id; Declarations : List_Id; Statements : List_Id) return Node_Id is Invoke_Method : constant Node_Id := Make_Defining_Identifier (Add_Prefix_To_Name ("Invoke_", Operation_Name)); N : Node_Id; begin N := Make_Subprogram_Specification (Invoke_Method, No_List); Append_To (Invoke_Methods, N); N := Make_Subprogram_Body (Specification => Make_Subprogram_Specification (Invoke_Method, No_List), Declarations => Declarations, Statements => Statements); Append_To (Invoke_Methods, N); N := Make_Subprogram_Call (Invoke_Method, No_List); return N; end Gen_Invoke_Method; --------------------- -- Gen_Invoke_Part -- --------------------- function Gen_Invoke_Part (E : Node_Id) return Node_Id is pragma Assert (FEN.Kind (E) = K_Operation_Declaration); C : Node_Id; N : Node_Id; M : Node_Id; Param : Node_Id; Param_Name : Name_Id; Type_Node : Node_Id; New_Name : Name_Id; Params : List_Id; Impl_Id : Node_Id; Operation_Name : Name_Id := FEN.IDL_Name (Identifier (E)); Arg_Name : Name_Id; Discrete_Choice_Value : Value_Id; Record_Node : Node_Id; Declarative_Part : constant List_Id := New_List; Statements : constant List_Id := New_List; Inv_Profile : constant List_Id := New_List; -- The flags below indicate whether the operation is mapped -- to an Ada function or an Ada procedure. Has_Out_Params : constant Boolean := Contains_Out_Parameters (E); Non_Void : constant Boolean := FEN.Kind (Type_Spec (E)) /= K_Void; Is_Ada_Function : constant Boolean := Non_Void and then not Has_Out_Params; function Exception_Handler_Alternative (E : Node_Id) return Node_Id; -- Generation of an alternative in the exception handler ----------------------------------- -- Exception_Handler_Alternative -- ----------------------------------- function Exception_Handler_Alternative (E : Node_Id) return Node_Id is Result : Node_Id; Selector : Node_Id; Block : Node_Id; N : Node_Id; D : constant List_Id := New_List; S : constant List_Id := New_List; begin -- Getting the Exception name N := Expand_Designator (Stub_Node (BE_Node (Identifier (Reference (E))))); Selector := Make_Object_Declaration (Defining_Identifier => Make_Defining_Identifier (PN (P_E)), Object_Definition => N); -- Declaration of the Members variable Getting the node -- corresponding to the declaration of the -- "Excp_Name"_Members type. N := Get_Type_Definition_Node (E); N := Make_Object_Declaration (Defining_Identifier => Make_Defining_Identifier (PN (P_Members)), Object_Definition => N); Append_To (D, N); -- Getting the node corresponding to the declaration of -- the Get_Members procedure. This procedure is declared -- 2 nodes after the member type definition. N := Type_Def_Node (BE_Node (Identifier (Reference (E)))); N := Next_Node (Next_Node (N)); N := Make_Subprogram_Call (Expand_Designator (N), New_List (Make_Defining_Identifier (PN (P_E)), Make_Defining_Identifier (PN (P_Members)))); Append_To (S, N); -- Getting the node corresponding to the declaration of -- the To_Any procedure in the helper package. N := To_Any_Node (BE_Node (Identifier (Reference (E)))); N := Make_Subprogram_Call (Expand_Designator (N), New_List (Make_Defining_Identifier (PN (P_Members)))); N := Make_Subprogram_Call (RE (RE_Set_Exception), New_List (Make_Defining_Identifier (PN (P_Request)), N)); Append_To (S, N); N := Make_Return_Statement (No_Node); Append_To (S, N); Block := Make_Block_Statement (Declarative_Part => D, Statements => S); Result := Make_Case_Statement_Alternative (New_List (Selector), New_List (Block)); return Result; end Exception_Handler_Alternative; -- Start of processing for Gen_Invoke_Part begin -- The first argument in the implementation call is an -- access to the object implementation. We create here this -- access and append it to the actual profile of the -- implementation call. N := Implementation_Package (Current_Entity); N := Expand_Designator (N); N := Make_Selected_Component (Prefix => N, Selector_Name => Make_Identifier (TN (T_Object))); N := Make_Attribute_Reference (N, A_Class); C := Make_Explicit_Dereference (Make_Identifier (PN (P_Self))); N := Make_Type_Conversion (N, C); N := Make_Attribute_Reference (N, A_Access); Append_To (Inv_Profile, N); -- Generate the code relative to the operation parameters Param := First_Entity (Parameters (E)); while Present (Param) loop -- Get the parameter name Param_Name := To_Ada_Name (IDL_Name (Identifier (Declarator (Param)))); -- Declare a local variable having the same type as the -- parameter. -- Get the Ada type generated from the parameter type spec Type_Node := Get_Type_Definition_Node (Type_Spec (Param)); -- Variable name Arg_Name := Map_Argument_Name (Param_Name); -- Declare the variable N := Make_Object_Declaration (Defining_Identifier => Make_Defining_Identifier (Arg_Name), Object_Definition => Type_Node); Append_To (Declarative_Part, N); -- Adding the variable to the profile of the -- implementation call. Append_To (Inv_Profile, Make_Defining_Identifier (Arg_Name)); -- The declaration below are not generated if the SII is -- used. if not Use_SII then -- Disable warnings on the declared variable N := Make_Pragma (Pragma_Warnings, New_List (RE (RE_Off), Make_Identifier (Arg_Name))); Append_To (Declarative_Part, N); -- Prepare the actual profile of the Add_Item call Params := New_List (Make_Identifier (VN (V_Argument_List))); -- Declare the global variable corresponding to the -- argument name. C := Make_Subprogram_Call (Defining_Identifier => RE (RE_To_CORBA_String), Actual_Parameter_Part => New_List (Make_Literal (New_String_Value (Param_Name, False)))); New_Name := Map_Argument_Identifier_Name (Param_Name, Operation_Name); N := Make_Object_Declaration (Defining_Identifier => Make_Defining_Identifier (New_Name), Constant_Present => True, Object_Definition => RE (RE_Identifier_0), Expression => C); Append_To (BEN.Statements (Current_Package), N); -- Append the argument name to the actual profile of -- the Add_Item call. Append_To (Params, Make_Identifier (New_Name)); -- Declare the `Content' variable relative to the -- argument. C := Get_Wrap_Node (FEU.Get_Original_Type_Declarator (Type_Spec (Param))); N := Make_Identifier (Arg_Name); -- Cast the parameter when necessary Cast_When_Necessary (N, Type_Spec (Param), FEU.Get_Original_Type_Declarator (Type_Spec (Param)), True); C := Make_Subprogram_Call (C, New_List (Make_Attribute_Reference (N, A_Unrestricted_Access))); N := Make_Attribute_Reference (RE (RE_Content), A_Class); N := Make_Object_Declaration (Defining_Identifier => Make_Defining_Identifier (Map_Argument_Content_Name (Param_Name)), Object_Definition => N, Expression => C, Aliased_Present => True); Append_To (Declarative_Part, N); -- Declaration of the `Any' argument variable C := Make_Attribute_Reference (Make_Identifier (Map_Argument_Content_Name (Param_Name)), A_Unchecked_Access); C := Make_Subprogram_Call (RE (RE_Get_Wrapper_Any), New_List (Get_TC_Node (Type_Spec (Param)), C)); N := Make_Object_Declaration (Defining_Identifier => Make_Defining_Identifier (Map_Argument_Any_Name (Param_Name)), Constant_Present => True, Object_Definition => RE (RE_Any), Expression => C); Append_To (Declarative_Part, N); -- Append the Any variable the actual profile of the -- Add_Item call. N := Make_Identifier (Map_Argument_Any_Name (Param_Name)); Append_To (Params, N); -- Append the parameter mode is added to the Add_Item -- profile. if FEN.Parameter_Mode (Param) = Mode_Out then N := RE (RE_ARG_OUT_0); elsif FEN.Parameter_Mode (Param) = Mode_In then N := RE (RE_ARG_IN_0); else N := RE (RE_ARG_INOUT_0); end if; Append_To (Params, N); -- Add_Item call N := Make_Subprogram_Call (RE (RE_Add_Item_0), Params); Append_To (Statements, N); end if; Param := Next_Entity (Param); end loop; -- Handling the case of a non void operation if Non_Void then -- Declare the Result_Ü variable N := Make_Object_Declaration (Defining_Identifier => Make_Defining_Identifier (VN (V_Result)), Object_Definition => Get_Type_Definition_Node (Type_Spec (E))); Append_To (Declarative_Part, N); -- If this is a procedure then we add the result variable -- to the actual profile of the implementation call. if not Is_Ada_Function then Append_To (Inv_Profile, Make_Identifier (VN (V_Result))); end if; -- The following declaration are not for static request -- handling. if not Use_SII then -- Disable warnings on the Result_Ü variable N := Make_Pragma (Pragma_Warnings, New_List (RE (RE_Off), Make_Identifier (VN (V_Result)))); Append_To (Declarative_Part, N); -- Declaration of the `Content' argument variable C := Get_Wrap_Node (FEU.Get_Original_Type_Declarator (Type_Spec (E))); N := Make_Identifier (VN (V_Result)); -- Cast the parameter when necessary Cast_When_Necessary (N, Type_Spec (E), FEU.Get_Original_Type_Declarator (Type_Spec (E)), True); C := Make_Subprogram_Call (C, New_List (Make_Attribute_Reference (N, A_Unrestricted_Access))); N := Make_Attribute_Reference (RE (RE_Content), A_Class); N := Make_Object_Declaration (Defining_Identifier => Make_Defining_Identifier (Map_Argument_Content_Name (VN (V_Result))), Constant_Present => False, Object_Definition => N, Expression => C, Aliased_Present => True); Append_To (Declarative_Part, N); -- Declaration of the `Any' argument variable C := Make_Attribute_Reference (Make_Identifier (Map_Argument_Content_Name (VN (V_Result))), A_Unchecked_Access); C := Make_Subprogram_Call (RE (RE_Get_Wrapper_Any), New_List (Get_TC_Node (Type_Spec (E)), C)); N := Make_Object_Declaration (Defining_Identifier => Make_Defining_Identifier (Map_Argument_Any_Name (VN (V_Result))), Constant_Present => True, Object_Definition => RE (RE_Any), Expression => C); Append_To (Declarative_Part, N); end if; end if; -- In SII mode, the request payload has to be set before the -- request is processed. The Argument procedure is not the -- same as DII. if Use_SII then declare M : Node_Id; begin Params := New_List; -- GIOP_Session is used to get the representation -- attribute (the declarative part the block). M := Make_Explicit_Dereference (Make_Identifier (VN (V_Component))); N := Make_Type_Conversion (RE (RE_GIOP_Session), M); N := Make_Object_Declaration (Defining_Identifier => Make_Defining_Identifier (VN (V_Session)), Object_Definition => RE (RE_GIOP_Session), Renamed_Object => N); Append_To (Declarative_Part, N); N := Make_Subprogram_Call (RE (RE_Get_Representation), New_List (Make_Attribute_Reference (Make_Identifier (VN (V_Session)), A_Unrestricted_Access))); N := Make_Object_Declaration (Defining_Identifier => Make_Defining_Identifier (VN (V_Representation)), Constant_Present => True, Object_Definition => RE (RE_CDR_Representation_Access), Expression => N); Append_To (Declarative_Part, N); if not Use_Compiler_Alignment and then (Non_Void or else Has_Out_Params) then N := Get_Type_Definition_Node (E); N := Make_Object_Declaration (Defining_Identifier => Make_Defining_Identifier (PN (P_Arg_List_Out)), Aliased_Present => True, Object_Definition => N); Append_To (Declarative_Part, N); end if; -- We need an Error Container N := Make_Object_Declaration (Defining_Identifier => Make_Defining_Identifier (PN (P_Error)), Object_Definition => RE (RE_Error_Container)); Append_To (Declarative_Part, N); N := Get_Type_Definition_Node (E); N := Make_Object_Declaration (Defining_Identifier => Make_Defining_Identifier (PN (P_Arg_List_In)), Aliased_Present => True, Object_Definition => N); Append_To (Declarative_Part, N); Set_Str_To_Name_Buffer ("Processing request"); Append_To (Statements, Make_Ada_Comment (Name_Find)); -- Unmarshall arguments C := Get_Unmarshaller_Node (E); Append_To (Params, RE (RE_False)); M := Make_Identifier (PN (P_Arg_List_In)); M := Make_Attribute_Reference (M, A_Access); Append_To (Params, M); M := Make_Subprogram_Call (RE (RE_Get_Buffer), New_List (Make_Attribute_Reference (Make_Identifier (VN (V_Session)), A_Unrestricted_Access))); Append_To (Params, M); M := Make_Explicit_Dereference (Make_Identifier (VN (V_Component))); Append_To (Params, Make_Explicit_Dereference (Make_Identifier (VN (V_Representation)))); Append_To (Params, Make_Literal (New_Integer_Value (8, 1, 10))); Append_To (Params, Make_Defining_Identifier (PN (P_Error))); -- The unmarshaller method call N := Make_Subprogram_Call (C, Params); Append_To (Statements, N); -- Handling error C := Make_Subprogram_Call (RE (RE_Found), New_List (Make_Defining_Identifier (PN (P_Error)))); N := Make_Subprogram_Call (RE (RE_Raise_From_Error), New_List (Make_Defining_Identifier (PN (P_Error)))); N := Make_If_Statement (Condition => C, Then_Statements => New_List (N)); Append_To (Statements, N); -- In case oneway operation, client does not need to -- wait. if Is_Oneway (E) then Set_Str_To_Name_Buffer ("Oneway operation," & " release the client"); Append_To (Statements, Make_Ada_Comment (Name_Find)); N := Make_Assignment_Statement (Make_Selected_Component (VN (V_Request), CN (C_Deferred_Arguments_Session)), Make_Null_Statement); Append_To (Statements, N); N := Make_Qualified_Expression (RE (RE_Flush), Make_Record_Aggregate (No_List, RE (RE_Message))); N := Make_Subprogram_Call (RE (RE_Emit_No_Reply), New_List (Make_Identifier (VN (V_Component)), N)); Append_To (Statements, N); end if; end; else Set_Str_To_Name_Buffer ("Processing request"); Append_To (Statements, Make_Ada_Comment (Name_Find)); N := Make_Subprogram_Call (RE (RE_Arguments_1), New_List (Make_Defining_Identifier (PN (P_Request)), Make_Defining_Identifier (VN (V_Argument_List)))); Append_To (Statements, N); end if; -- The block above implements the generation of: -- * The call of the corresponding method implemented by the -- programmer. -- * The handling of possible exceptions thrown by the -- method. -- If the method could potentially throw an exception, the -- generated code will be put inside a block statement. -- Otherwise, no additional block statements will be used. declare Inner_Statements : List_Id := No_List; Inner : Boolean := False; Exception_Handler : List_Id := No_List; Excp_Node : Node_Id; Predefined_Entity : RE_Id; begin -- Looking whether the operation throws exceptions and -- setting Inner_Statements to the corresponding value. if not FEU.Is_Empty (Exceptions (E)) then Inner_Statements := New_List; Exception_Handler := New_List; Inner := True; -- Creating the exception handler statements Excp_Node := First_Entity (Exceptions (E)); while Present (Excp_Node) loop N := Exception_Handler_Alternative (Excp_Node); Append_To (Exception_Handler, N); Excp_Node := Next_Entity (Excp_Node); end loop; else Inner_Statements := Statements; end if; -- In the case of SII, the parameter are set from the -- Args record. if Use_SII then Record_Node := Make_Identifier (PN (P_Arg_List_In)); Param := First_Entity (Parameters (E)); while Present (Param) loop if FEN.Parameter_Mode (Param) = Mode_In or else FEN.Parameter_Mode (Param) = Mode_Inout then -- Get the parameter name Param_Name := To_Ada_Name (IDL_Name (Identifier (Declarator (Param)))); -- Variable name Arg_Name := Map_Argument_Name (Param_Name); -- Preparing the assigned value -- Getting the record field C := Make_Selected_Component (Record_Node, Make_Defining_Identifier (Param_Name)); N := Make_Assignment_Statement (Make_Defining_Identifier (Arg_Name), C); Append_To (Inner_Statements, N); end if; Param := Next_Entity (Param); end loop; end if; -- Call Implementation Set_Str_To_Name_Buffer ("Call Implementation"); Append_To (Inner_Statements, Make_Ada_Comment (Name_Find)); -- If the subprogram is inherited from a CORBA predefined -- entity, we must fetch this entity instead of the -- automatically generated one. Predefined_Entity := Get_Predefined_CORBA_Entity (E); if Predefined_Entity /= RE_Null then -- Do not add a with clause since the parent unit will -- be modified. C := Selector_Name (RE (Predefined_Entity, False)); else C := Defining_Identifier (Impl_Node (BE_Node (Identifier (E)))); end if; -- Re-adjusting the parent unit name of the operation. This is -- necessary in the case of operations or attributes inherited -- from the second until the last parent (multiple inheritance). Impl_Id := Make_Selected_Component (Defining_Identifier (Implementation_Package (Current_Entity)), Copy_Node (C)); C := Make_Subprogram_Call (Copy_Expanded_Name (Impl_Id), Inv_Profile); if Is_Ada_Function then -- Cast class-wide results if Is_Class_Wide (E) then C := Make_Type_Conversion (Get_Type_Definition_Node (Type_Spec (E)), C); end if; C := Make_Assignment_Statement (Make_Defining_Identifier (VN (V_Result)), C); end if; Append_To (Inner_Statements, C); if Inner then Append_To (Statements, Make_Block_Statement (Declarative_Part => No_List, Statements => Inner_Statements, Exception_Handler => Exception_Handler)); end if; end; -- Set Result if Non_Void then Set_Str_To_Name_Buffer ("Setting the result"); Append_To (Statements, Make_Ada_Comment (Name_Find)); if Use_SII then C := Make_Selected_Component (PN (P_Arg_List_Out), PN (P_Returns)); N := Make_Assignment_Statement (C, Make_Identifier (VN (V_Result))); Append_To (Statements, N); else N := Make_Subprogram_Call (RE (RE_Set_Result), New_List (Make_Identifier (PN (P_Request)), Make_Identifier (Map_Argument_Any_Name (VN (V_Result))))); Append_To (Statements, N); end if; end if; -- Setting out arguments if Use_SII then if Has_Out_Params then -- Out parameters of the Operation Param := First_Entity (Parameters (E)); while Present (Param) loop if FEN.Parameter_Mode (Param) = Mode_Out or else FEN.Parameter_Mode (Param) = Mode_Inout then Set_Str_To_Name_Buffer ("Setting out argument"); Append_To (Statements, Make_Ada_Comment (Name_Find)); Param_Name := To_Ada_Name (IDL_Name (Identifier (Declarator (Param)))); Arg_Name := Map_Argument_Name (Param_Name); C := Make_Defining_Identifier (Param_Name); C := Make_Selected_Component (Make_Identifier (PN (P_Arg_List_Out)), C); N := Make_Assignment_Statement (C, Make_Identifier (Arg_Name)); Append_To (Statements, N); end if; Param := Next_Entity (Param); end loop; end if; else -- Simply call `Clone_Out_Args' in all cases N := Make_Subprogram_Call (RE (RE_Clone_Out_Args), New_List (Make_Identifier (VN (V_Argument_List)))); Append_To (Statements, N); end if; if Use_SII and then (Has_Out_Params or else Non_Void) then -- Tell Invoke_Declaration to declare a buffer local -- variable. Buffer_Necessary := True; if Use_Compiler_Alignment then declare Disc : constant List_Id := New_List; Access_T : Node_Id; Blk_Stat : constant List_Id := New_List; Dec_Stat : constant List_Id := New_List; J : Unsigned_Long_Long; begin if Non_Void then C := Make_Defining_Identifier (PN (P_Returns)); Marshall_Args (Blk_Stat, Type_Spec (E), C, Make_Identifier (VN (V_Result))); Get_Discriminants_Value (E, Type_Spec (E), Disc); end if; Param := First_Entity (Parameters (E)); while Present (Param) loop if FEN.Parameter_Mode (Param) = Mode_Out or else FEN.Parameter_Mode (Param) = Mode_Inout then Param_Name := To_Ada_Name (IDL_Name (Identifier (Declarator (Param)))); Arg_Name := Map_Argument_Name (Param_Name); C := Make_Defining_Identifier (Arg_Name); Marshall_Args (Blk_Stat, Type_Spec (Param), C); Get_Discriminants_Value (Param, Type_Spec (Param), Disc); end if; Param := Next_Entity (Param); end loop; C := Expand_Designator (Args_Out_Node (BE_Node (Identifier (E)))); Access_T := Expand_Designator (Access_Args_Out_Node (BE_Node (Identifier (E)))); N := Make_Subprogram_Call (C, Disc); N := Make_Object_Declaration (Defining_Identifier => Make_Defining_Identifier (VN (V_Args_Out)), Object_Definition => Access_T, Expression => Make_Object_Instantiation (N)); Append_To (Dec_Stat, N); C := Make_Attribute_Reference (Make_Explicit_Dereference (Make_Identifier (VN (V_Args_Out))), A_Address); J := Unsigned_Long_Long (Length (Disc)); N := Make_Subprogram_Call (RE (RE_Insert_Raw_Data), New_List (Make_Identifier (PN (P_Request)), C, Make_Attribute_Reference (Make_Explicit_Dereference (Make_Identifier (VN (V_Args_Out))), A_Size), Make_Literal (New_Integer_Value (J, 1, 10)), Make_Identifier (VN (V_Buffer)))); Append_To (Blk_Stat, N); N := Make_Block_Statement (Declarative_Part => Dec_Stat, Statements => Blk_Stat); Append_To (Statements, N); end; else -- The marshaller method C := Get_Marshaller_Node (E); Params := New_List; Append_To (Params, RE (RE_False)); M := Make_Identifier (PN (P_Arg_List_Out)); M := Make_Attribute_Reference (M, A_Access); Append_To (Params, M); Append_To (Params, Make_Defining_Identifier (VN (V_Buffer))); N := Make_Explicit_Dereference (Make_Identifier (VN (V_Representation))); Append_To (Params, N); Append_To (Params, Make_Literal (Int1_Val)); Append_To (Params, Make_Defining_Identifier (PN (P_Error))); -- The marshaller method call N := Make_Subprogram_Call (C, Params); Append_To (Statements, N); -- If any error we raise a program_error N := Make_Subprogram_Call (RE (RE_Found), New_List (Make_Identifier (PN (P_Error)))); N := Make_If_Statement (Condition => N, Then_Statements => New_List (Make_Raise_Statement (Make_Identifier (EN (E_Program_Error))))); Append_To (Statements, N); -- Add the buffer as a QoS parameter for the request Set_Str_To_Name_Buffer ("Add the buffer to the request QoS parameters"); Append_To (Statements, Make_Ada_Comment (Name_Find)); N := Make_Record_Aggregate (New_List (RE (RE_GIOP_Static_Buffer), Make_Defining_Identifier (VN (V_Buffer)))); N := Make_Object_Instantiation (Make_Qualified_Expression (RE (RE_QoS_GIOP_Static_Buffer_Parameter), N)); N := Make_Subprogram_Call (RE (RE_Add_Request_QoS), New_List (Make_Defining_Identifier (VN (V_Request)), RE (RE_GIOP_Static_Buffer), N)); Append_To (Statements, N); end if; end if; -- Map the operation name Operation_Name := Map_Operation_Name_Literal (E); -- If no optimization is requested by the user, we generate an elsif -- statement. Otherwise, we generate a case statement alternative. N := Gen_Invoke_Method (Operation_Name, Declarative_Part, Statements); if not Use_Minimal_Hash_Function then C := Make_Expression (Make_Defining_Identifier (VN (V_Operation)), Op_Equal, Make_Literal (New_String_Value (Operation_Name, False))); N := Make_Elsif_Statement (C, New_List (N)); else -- Insert the subprogram name into the hash function -- generator and add a call to Register_Procedure Insert_And_Register_Statements (Operation_Name); -- Prepare the case alternative -- * Discrete Choice : value of N_Subprogram minus 1 Discrete_Choice_Value := New_Integer_Value (N_Subprograms - 1, 1, 10); N := Make_Case_Statement_Alternative (New_List (Make_Literal (Discrete_Choice_Value)), New_List (N)); end if; return N; end Gen_Invoke_Part; ----------------- -- Invoke_Body -- ----------------- function Invoke_Body (E : Node_Id; Is_A_Invk_Part : Node_Id) return Node_Id is N : Node_Id; Spec : Node_Id; D : constant List_Id := New_List; C_1 : Node_Id; Else_Statements : constant List_Id := New_List; Invoke_Statements : constant List_Id := New_List; Exception_Handler : Node_Id; Is_A_Lowered_Name : Name_Id; begin Spec := Invoke_Spec; -- The declarative part Invoke_Declaration (D); -- We don't create the request if the SII is used if not Use_SII then N := Make_Subprogram_Call (RE (RE_Create_List), New_List (Make_Literal (Int0_Val), Make_Defining_Identifier (VN (V_Argument_List)))); Append_To (Invoke_Statements, N); end if; if not Use_Minimal_Hash_Function then Append_To (Invoke_Then_Statements, Is_A_Invk_Part); Set_Str_To_Name_Buffer ("_is_a"); Is_A_Lowered_Name := Name_Find; C_1 := Make_Expression (Make_Defining_Identifier (VN (V_Operation)), Op_Equal, Make_Literal (New_String_Value (Is_A_Lowered_Name, False))); else Append_To (Invoke_Subp_Bodies, Is_A_Invk_Part); N := Make_Selected_Component (Make_Defining_Identifier (Hash_Package_Name (E)), Make_Defining_Identifier (SN (S_Hash))); -- Calculate the hash code of the operation N := Make_Subprogram_Call (N, New_List (Make_Defining_Identifier (VN (V_Operation)))); N := Make_Assignment_Statement (Make_Defining_Identifier (VN (V_Index)), N); Append_To (Invoke_Statements, N); -- Get the operation name corresponding to the hash code N := Make_Subprogram_Call (Make_Defining_Identifier (PN (P_Invoke_Db)), New_List (Make_Defining_Identifier (VN (V_Index)))); N := Make_Assignment_Statement (Make_Defining_Identifier (PN (P_Invoke_Name_Access)), N); Append_To (Invoke_Statements, N); -- The condition N := Make_Explicit_Dereference (Make_Identifier (PN (P_Invoke_Name_Access))); C_1 := Make_Expression (Make_Defining_Identifier (VN (V_Operation)), Op_Equal, N); -- Generate the "case" statement after adding a "when -- others" clause. N := Make_Raise_Statement (Make_Identifier (EN (E_Program_Error))); N := Make_Case_Statement_Alternative (No_List, New_List (N)); Append_To (Invoke_Subp_Bodies, N); N := Make_Case_Statement (Make_Identifier (VN (V_Index)), Invoke_Subp_Bodies); N := Gen_Dispatch (N); Append_To (Invoke_Then_Statements, N); end if; N := Make_Subprogram_Call (RE (RE_Raise_Bad_Operation), New_List (RE (RE_Default_Sys_Member))); Append_To (Else_Statements, N); N := Make_If_Statement (C_1, Invoke_Then_Statements, Invoke_Elsif_Statements, Else_Statements); Exception_Handler := Non_User_Exception_Handler; N := Make_Block_Statement (Declarative_Part => No_List, Statements => New_List (N), Exception_Handler => New_List (Exception_Handler)); Append_To (Invoke_Statements, N); -- Generation of the Invoke Procedure. Note that Append_To is -- appending the entire Invoke_Methods list onto D. Append_To (D, First_Node (Invoke_Methods)); N := Make_Subprogram_Body (Spec, D, Invoke_Statements); return N; end Invoke_Body; ------------------------ -- Invoke_Declaration -- ------------------------ procedure Invoke_Declaration (L : List_Id) is N : Node_Id; begin N := Make_Explicit_Dereference (Make_Identifier (PN (P_Request))); N := Make_Subprogram_Call (RE (RE_Operation), New_List (N)); N := Make_Subprogram_Call (RE (RE_To_Standard_String), New_List (N)); N := Make_Object_Declaration (Defining_Identifier => Make_Defining_Identifier (VN (V_Operation)), Constant_Present => True, Object_Definition => RE (RE_String_2), Expression => N); Append_To (L, N); N := Make_Object_Declaration (Defining_Identifier => Make_Defining_Identifier (VN (V_Argument_List)), Object_Definition => RE (RE_Ref_4)); Append_To (L, N); -- Do not declare SII related local variable if the -- interface does not containe (or inherit) any operation. if Use_SII and then Has_Operations then declare C : Node_Id; begin N := Make_Subprogram_Call (RE (RE_Request_Access), New_List (Make_Defining_Identifier (PN (P_Request)))); N := Make_Object_Declaration (Defining_Identifier => Make_Defining_Identifier (VN (V_Request)), Constant_Present => True, Object_Definition => RE (RE_Request_Access), Expression => N); Append_To (L, N); -- Request binding object C := Make_Selected_Component (VN (V_Request), PN (P_Dependent_Binding_Object)); N := Make_Object_Declaration (Defining_Identifier => Make_Defining_Identifier (VN (V_Binding_Object)), Constant_Present => True, Object_Definition => RE (RE_Ref_10), Expression => C); Append_To (L, N); -- The GIOP Session is the Component attribute -- Dependent_Binding_Object. C := Make_Subprogram_Call (RE (RE_Get_Component), New_List (Make_Identifier (VN (V_Binding_Object)))); N := Make_Object_Declaration (Defining_Identifier => Make_Defining_Identifier (VN (V_Component)), Constant_Present => True, Object_Definition => RE (RE_Component_Access), Expression => C); Append_To (L, N); -- Buffer for marshalling the arguments if Buffer_Necessary then C := Make_Object_Instantiation (RE (RE_Buffer_Type)); N := Make_Object_Declaration (Defining_Identifier => Make_Defining_Identifier (VN (V_Buffer)), Constant_Present => True, Object_Definition => RE (RE_Buffer_Access), Expression => C); Append_To (L, N); end if; end; end if; if Use_Minimal_Hash_Function then N := Make_Object_Declaration (Defining_Identifier => Make_Defining_Identifier (VN (V_Index)), Object_Definition => RE (RE_Natural)); Append_To (L, N); N := Make_Object_Declaration (Defining_Identifier => Make_Defining_Identifier (PN (P_Invoke_Name_Access)), Object_Definition => Make_Defining_Identifier (TN (T_String_Ptr))); Append_To (L, N); end if; end Invoke_Declaration; ----------------- -- Invoke_Spec -- ----------------- function Invoke_Spec return Node_Id is N : Node_Id; Param : Node_Id; Profile : List_Id; begin Profile := New_List; Param := Make_Parameter_Specification (Make_Defining_Identifier (PN (P_Self)), RE (RE_Servant)); Append_To (Profile, Param); Param := Make_Parameter_Specification (Make_Defining_Identifier (PN (P_Request)), RE (RE_Object_Ptr)); Append_To (Profile, Param); N := Make_Subprogram_Specification (Make_Defining_Identifier (SN (S_Invoke)), Profile, No_Node); return N; end Invoke_Spec; ---------------------- -- Is_A_Invoke_Part -- ---------------------- function Is_A_Invoke_Part return Node_Id is N : Node_Id; Declarative_Part : constant List_Id := New_List; Statements : constant List_Id := New_List; Discrete_Choice_Value : Value_Id; Profile : List_Id; Operation_Name : Name_Id; begin -- Declarative part N := Make_Object_Declaration (Defining_Identifier => Make_Defining_Identifier (VN (V_Type_Id)), Object_Definition => RE (RE_String_0)); Append_To (Declarative_Part, N); N := Make_Object_Declaration (Defining_Identifier => Make_Defining_Identifier (VN (V_Arg_Name_Type_Id)), Constant_Present => True, Object_Definition => RE (RE_Identifier_0), Expression => Make_Subprogram_Call (RE (RE_To_CORBA_String), New_List (Make_Literal (New_String_Value (VN (V_Type_Id), False))))); Append_To (Declarative_Part, N); N := Make_Object_Declaration (Defining_Identifier => Make_Defining_Identifier (VN (V_Argument_Type_Id)), Constant_Present => True, Object_Definition => RE (RE_Any), Expression => Make_Subprogram_Call (RE (RE_To_Any_0), New_List (Make_Defining_Identifier (VN (V_Type_Id))))); Append_To (Declarative_Part, N); N := Make_Object_Declaration (Defining_Identifier => Make_Defining_Identifier (VN (V_Result)), Object_Definition => RE (RE_Boolean)); Append_To (Declarative_Part, N); -- Statements -- Call to CORBA.NVList.Add_Item Profile := New_List; Append_To (Profile, Make_Identifier (VN (V_Argument_List))); Append_To (Profile, Make_Identifier (VN (V_Arg_Name_Type_Id))); Append_To (Profile, Make_Identifier (VN (V_Argument_Type_Id))); Append_To (Profile, RE (RE_ARG_IN_0)); N := Make_Subprogram_Call (RE (RE_Add_Item_0), Profile); Append_To (Statements, N); -- Call to CORBA.ServerRequest.Arguments Profile := New_List; Append_To (Profile, Make_Identifier (PN (P_Request))); Append_To (Profile, Make_Identifier (VN (V_Argument_List))); N := Make_Subprogram_Call (RE (RE_Arguments_1), Profile); Append_To (Statements, N); -- Assign the Type_Id N := Make_Assignment_Statement (Make_Defining_Identifier (VN (V_Type_Id)), Make_Subprogram_Call (RE (RE_From_Any_0), New_List (Make_Identifier (VN (V_Argument_Type_Id))))); Append_To (Statements, N); -- Call the implementation N := Make_Subprogram_Call (RE (RE_To_Standard_String), New_List (Make_Identifier (VN (V_Type_Id)))); N := Make_Subprogram_Call (Make_Defining_Identifier (SN (S_Is_A)), New_List (N)); N := Make_Assignment_Statement (Make_Defining_Identifier (VN (V_Result)), N); Append_To (Statements, N); -- Set the result Profile := New_List; Append_To (Profile, Make_Identifier (PN (P_Request))); N := Make_Subprogram_Call (RE (RE_To_Any_0), New_List (Make_Identifier (VN (V_Result)))); Append_To (Profile, N); N := Make_Subprogram_Call (RE (RE_Set_Result), Profile); Append_To (Statements, N); -- If no optimization is requested by the user, we generate -- an elsif??? statement. Else, we generate a case alternative -- statement. Set_Str_To_Name_Buffer ("_is_a"); Operation_Name := Name_Find; N := Gen_Invoke_Method (Operation_Name, Declarative_Part, Statements); if not Use_Minimal_Hash_Function then null; -- ???No elsif here. else -- Insert the subprogram name into the hash function -- generator and add a call to Register_Procedure Insert_And_Register_Statements (Operation_Name); -- Prepare the case alternative * Discrete Choice : value -- of N_Subprogram minus 1 Discrete_Choice_Value := New_Integer_Value (N_Subprograms - 1, 1, 10); N := Make_Case_Statement_Alternative (New_List (Make_Literal (Discrete_Choice_Value)), New_List (N)); end if; return N; end Is_A_Invoke_Part; ---------------------------- -- Implicit_CORBA_Methods -- ---------------------------- function Implicit_CORBA_Methods return List_Id is Result_List : constant List_Id := New_List; procedure Add_Implicit_CORBA_Method (Declarations : List_Id; Statements : List_Id; Method_Name_1 : String; Method_Name_2 : String := ""); -- To make the addition (or the removal) of an implicit -- CORBA method easier, we use this subprogram. It takes the -- method name, A declaration list and a statement list. It -- creates a block statement for each implicit method and -- fills a list depending on the optimization mode chosen by -- the user. If two method names correspond to the same -- treatment, the user may use the Method_Name_2 parameter. ------------------------------- -- Add_Implicit_CORBA_Method -- ------------------------------- procedure Add_Implicit_CORBA_Method (Declarations : List_Id; Statements : List_Id; Method_Name_1 : String; Method_Name_2 : String := "") is N : Node_Id; Discrete_Choice : Node_Id; Op_Name_1, Op_Name_2 : Name_Id; C : Node_Id; begin Set_Str_To_Name_Buffer (Method_Name_1); Op_Name_1 := Name_Find; if Method_Name_2 /= "" then Set_Str_To_Name_Buffer (Method_Name_2); Op_Name_2 := Name_Find; end if; N := Gen_Invoke_Method (Op_Name_1, Declarations, Statements); -- If no optimization is requested by the user, we -- generate an elsif statement. Else, we generate a case -- alternative statement if not Use_Minimal_Hash_Function then C := Make_Expression (Make_Defining_Identifier (VN (V_Operation)), Op_Equal, Make_Literal (New_String_Value (Op_Name_1, False))); if Method_Name_2 /= "" then declare C_2 : Node_Id; begin C_2 := Make_Expression (Make_Defining_Identifier (VN (V_Operation)), Op_Equal, Make_Literal (New_String_Value (Op_Name_2, False))); C := Make_Expression (C, Op_Or_Else, C_2); end; end if; N := Make_Elsif_Statement (C, New_List (N)); else -- Insert the subprogram name into the hash function -- generator and add a call to Register_Procedure Insert_And_Register_Statements (Op_Name_1); -- Prepare the case alternative -- * Discrete Choice : value of N_Subprogram minus 1 Discrete_Choice := Make_Literal (New_Integer_Value (N_Subprograms - 1, 1, 10)); if Method_Name_2 /= "" then declare DC_2 : Node_Id; begin Insert_And_Register_Statements (Op_Name_2); DC_2 := Make_Literal (New_Integer_Value (N_Subprograms - 1, 1, 10)); Discrete_Choice := Make_Expression (Discrete_Choice, Op_Vertical_Bar, DC_2); end; end if; N := Make_Case_Statement_Alternative (New_List (Discrete_Choice), New_List (N)); end if; Append_To (Result_List, N); end Add_Implicit_CORBA_Method; N : Node_Id; -- Start of processing for Implicit_CORBA_Methods begin -- For each implicit CORBA Method, add a similar block -- statement -- The "Interface" implicit method declare Profile : List_Id; Statements : constant List_Id := New_List; begin -- Call CORBA.ServerRequest.Arguments Profile := New_List; Append_To (Profile, Make_Identifier (PN (P_Request))); Append_To (Profile, Make_Identifier (VN (V_Argument_List))); N := Make_Subprogram_Call (RE (RE_Arguments_1), Profile); Append_To (Statements, N); -- Call CORBA.ServerRequest.Set_Result Profile := New_List; Append_To (Profile, Make_Identifier (PN (P_Request))); N := Make_Subprogram_Call (RE (RE_To_CORBA_String), New_List (Make_Identifier (PN (P_Repository_Id)))); N := Make_Subprogram_Call (RE (RE_Get_Interface_Definition), New_List (N)); N := Make_Subprogram_Call (RE (RE_Ref_2), New_List (N)); N := Make_Subprogram_Call (RE (RE_To_Any_3), New_List (N)); Append_To (Profile, N); N := Make_Subprogram_Call (RE (RE_Set_Result), Profile); Append_To (Statements, N); -- Add the handler Add_Implicit_CORBA_Method (No_List, Statements, "_interface"); end; -- The Domain_Managers implicit method declare Profile : List_Id; Statements : constant List_Id := New_List; begin -- Call CORBA.ServerRequest.Arguments Profile := New_List; Append_To (Profile, Make_Identifier (PN (P_Request))); Append_To (Profile, Make_Identifier (VN (V_Argument_List))); N := Make_Subprogram_Call (RE (RE_Arguments_1), Profile); Append_To (Statements, N); -- Call CORBA.ServerRequest.Set_Result Profile := New_List; Append_To (Profile, Make_Identifier (PN (P_Request))); N := Make_Subprogram_Call (RE (RE_Get_Domain_Managers), New_List (Make_Identifier (PN (P_Self)))); Append_To (Profile, N); N := Make_Subprogram_Call (RE (RE_Set_Result), Profile); Append_To (Statements, N); -- Add the handler Add_Implicit_CORBA_Method (No_List, Statements, "_domain_managers"); end; -- The Non_Existent implicit method declare Profile : List_Id; Statements : constant List_Id := New_List; begin -- Call CORBA.ServerRequest.Arguments Profile := New_List; Append_To (Profile, Make_Identifier (PN (P_Request))); Append_To (Profile, Make_Identifier (VN (V_Argument_List))); N := Make_Subprogram_Call (RE (RE_Arguments_1), Profile); Append_To (Statements, N); -- Call CORBA.ServerRequest.Set_Result Profile := New_List; Append_To (Profile, Make_Identifier (PN (P_Request))); N := Make_Literal (New_Boolean_Value (False)); N := Make_Qualified_Expression (Subtype_Mark => RE (RE_Boolean), Operand => N); N := Make_Subprogram_Call (RE (RE_To_Any_0), New_List (N)); Append_To (Profile, N); N := Make_Subprogram_Call (RE (RE_Set_Result), Profile); Append_To (Statements, N); -- Add the handler Add_Implicit_CORBA_Method (No_List, Statements, "_non_existent", "_not_existent"); end; return Result_List; end Implicit_CORBA_Methods; ------------------- -- Put_To_Stdout -- ------------------- procedure Put_To_Stdout is use Ada.Directories; procedure Do_One_File (Dir_Entry : Directory_Entry_Type); -- Read the file, and send it to standard output. Called once for -- each file in the current directory. procedure Do_One_File (Dir_Entry : Directory_Entry_Type) is use GNAT.OS_Lib; F_Name : aliased constant String := Simple_Name (Dir_Entry) & ASCII.NUL; FD : constant File_Descriptor := Open_Read (F_Name'Address, Binary); begin Output.Copy_To_Standard_Output (FD); end Do_One_File; Just_Ordinary : constant Filter_Type := (Ordinary_File => True, Directory | Special_File => False); -- Filter out everything but ordinary files. The RM does not specify -- whether "." and ".." are included in the search, so it seems best -- to explicitly skip them. begin -- There are two files, called .ads and .adb. -- We wish to avoid depending on the exact names. The RM does not -- define the order of Search. We wish to print the spec first, then -- the body. Each of the following Searches will iterate just once. Search (Current_Directory, Pattern => "*.ads", Filter => Just_Ordinary, Process => Do_One_File'Access); Search (Current_Directory, Pattern => "*.adb", Filter => Just_Ordinary, Process => Do_One_File'Access); end Put_To_Stdout; ----------------------- -- Servant_Is_A_Body -- ----------------------- function Servant_Is_A_Body (Spec : Node_Id) return Node_Id is Statements : constant List_Id := New_List; N : Node_Id; begin N := Implementation_Package (Current_Entity); N := Expand_Designator (N); N := Make_Selected_Component (Prefix => N, Selector_Name => Make_Identifier (TN (T_Object))); N := Make_Attribute_Reference (N, A_Class); N := Make_Expression (Make_Explicit_Dereference (Make_Defining_Identifier (PN (P_Obj))), Op_In, N); N := Make_Return_Statement (N); Append_To (Statements, N); return Make_Subprogram_Body (Spec, No_List, Statements); end Servant_Is_A_Body; ----------------------------- -- Skeleton_Initialization -- ----------------------------- procedure Skeleton_Initialization (L : List_Id) is N : Node_Id; V : Value_Id; Dep : Node_Id; Aggregates : constant List_Id := New_List; Declarative_Part : constant List_Id := New_List; Statements : constant List_Id := New_List; begin -- Declarative part -- Adding 'use' clauses to make the code more readable N := Make_Used_Package (RU (RU_PolyORB_Utils_Strings)); Append_To (Declarative_Part, N); N := Make_Used_Package (RU (RU_PolyORB_Utils_Strings_Lists)); Append_To (Declarative_Part, N); -- Statements -- The package name N := Defining_Identifier (Package_Declaration (Current_Package)); V := New_String_Value (Fully_Qualified_Name (N), False); N := Make_Expression (Make_Literal (V), Op_Plus); N := Make_Component_Association (Selector_Name => Make_Defining_Identifier (PN (P_Name)), Expression => N); Append_To (Aggregates, N); -- The conflicts N := Make_Component_Association (Selector_Name => Make_Defining_Identifier (PN (P_Conflicts)), Expression => RE (RE_Empty)); Append_To (Aggregates, N); -- The dependencies N := RE (RE_Empty); if not Is_Empty (Dependency_List) then Dep := First_Node (Dependency_List); while Present (Dep) loop N := Make_Expression (N, Op_And_Symbol, Dep); Dep := Next_Node (Dep); end loop; end if; N := Make_Component_Association (Selector_Name => Make_Defining_Identifier (PN (P_Depends)), Expression => N); Append_To (Aggregates, N); -- Provides N := Make_Component_Association (Selector_Name => Make_Defining_Identifier (PN (P_Provides)), Expression => RE (RE_Empty)); Append_To (Aggregates, N); -- Implicit N := Make_Component_Association (Selector_Name => Make_Defining_Identifier (PN (P_Implicit)), Expression => RE (RE_False)); Append_To (Aggregates, N); -- Init procedure N := Make_Component_Association (Selector_Name => Make_Defining_Identifier (PN (P_Init)), Expression => Make_Attribute_Reference (Make_Identifier (SN (S_Deferred_Initialization)), A_Access)); Append_To (Aggregates, N); -- Shutdown procedure N := Make_Component_Association (Selector_Name => Make_Defining_Identifier (PN (P_Shutdown)), Expression => Make_Null_Statement); Append_To (Aggregates, N); -- Registering the module N := Make_Qualified_Expression (Subtype_Mark => RE (RE_Module_Info), Operand => Make_Record_Aggregate (Aggregates)); N := Make_Subprogram_Call (RE (RE_Register_Module), New_List (N)); Append_To (Statements, N); -- Building the initialization block statement N := Make_Block_Statement (Declarative_Part => Declarative_Part, Statements => Statements); Append_To (L, N); end Skeleton_Initialization; -------------------------------- -- Non_User_Exception_Handler -- -------------------------------- function Non_User_Exception_Handler return Node_Id is Result : Node_Id; Selector : Node_Id; N : Node_Id; S : constant List_Id := New_List; begin -- Generation of the "E : others" statement Selector := Make_Object_Declaration (Defining_Identifier => Make_Defining_Identifier (PN (P_E)), Object_Definition => No_Node); -- Body of the exception handler N := Make_Subprogram_Call (RE (RE_System_Exception_To_Any), New_List (Make_Defining_Identifier (PN (P_E)))); -- Set the exception N := Make_Subprogram_Call (RE (RE_Set_Exception), New_List (Make_Defining_Identifier (PN (P_Request)), N)); Append_To (S, N); -- Set the exception informations N := Make_Subprogram_Call (RE (RE_Set_Exception_Information), New_List (Make_Explicit_Dereference (Make_Identifier (PN (P_Request))), Make_Identifier (PN (P_E)))); Append_To (S, N); Result := Make_Case_Statement_Alternative (New_List (Selector), S); return Result; end Non_User_Exception_Handler; ----------------------- -- Hash_Package_Name -- ----------------------- function Hash_Package_Name (E : Node_Id) return Name_Id is pragma Assert (FEN.Kind (E) = K_Interface_Declaration); begin Get_Name_String (Fully_Qualified_Name (Map_Fully_Qualified_Identifier (E))); -- Note: the generated code assumes no user entities hide any -- standard entities, so we can't generate Hash as a child unit -- of the mapped stubs package. for J in 1 .. Name_Len loop if Name_Buffer (J) = '.' then Name_Buffer (J) := '_'; end if; end loop; Add_Str_To_Name_Buffer ("_Hash"); return Name_Find; end Hash_Package_Name; ------------------------------------------- -- Initialize_Hash_Function_Optimization -- ------------------------------------------- procedure Initialize_Hash_Function_Optimization is begin -- Initialize the lists and the number of subprograms N_Subprograms := 0; Register_Procedure_List := New_List; Invoke_Subp_Bodies := New_List; end Initialize_Hash_Function_Optimization; ---------------------------------------- -- Achieve_Hash_Function_Optimization -- ---------------------------------------- procedure Achieve_Hash_Function_Optimization (E : Node_Id) is N : Node_Id; V : Natural; Seed : constant Natural := 4321; -- Needed by the hash algorithm K_2_V : Float; -- The ratio of the algorithm use Ada.Directories; begin -- We add a "with" clause to be able to use the "Hash" -- function Add_With_Package (Make_Defining_Identifier (Hash_Package_Name (E))); -- Declaration of the total number of subprograms N := Make_Literal (New_Integer_Value (N_Subprograms, 1, 10)); N := Make_Object_Declaration (Defining_Identifier => Make_Defining_Identifier (PN (P_N_Operations)), Constant_Present => True, Object_Definition => RE (RE_Natural), Expression => N); Append_To (Statements (Current_Package), N); -- Definition of a string access type N := Make_Full_Type_Declaration (Defining_Identifier => Make_Defining_Identifier (TN (T_String_Ptr)), Type_Definition => Make_Access_Type_Definition (RE (RE_String_2))); Append_To (Statements (Current_Package), N); -- Declaration of the hash table. The hash table size is -- equal to the number of subprograms N := Make_Range_Constraint (Make_Literal (Int0_Val), Make_Expression (Make_Defining_Identifier (PN (P_N_Operations)), Op_Minus, Make_Literal (Int1_Val))); N := Make_Object_Declaration (Defining_Identifier => Make_Defining_Identifier (PN (P_Invoke_Db)), Object_Definition => Make_Array_Type_Definition (New_List (N), Make_Defining_Identifier (TN (T_String_Ptr))), Expression => Make_Record_Aggregate (New_List (Make_Component_Association (Selector_Name => No_Node, -- 'others' Expression => Make_Null_Statement)))); Append_To (Statements (Current_Package), N); -- Insert the spec and the body of the Register_Procedure procedure N := Register_Procedure_Spec; Append_To (Statements (Current_Package), N); N := Register_Procedure_Body (E); Append_To (Statements (Current_Package), N); -- Compute the hash function generator, we use all positions. In the -- case of CPU time optimization, the algorithm should succeed from -- the first iteration. For the Memory space optimization, it may -- initially fail, in which case we increase the graph vertex count -- until it succeeds. We are sure that for V >= 257, the algorithm -- will succeed. V := 2 * Natural (N_Subprograms) + 1; loop K_2_V := Float (V) / Float (N_Subprograms); PHG.Initialize (Seed, K_2_V, Optimization_Mode); begin PHG.Compute; exit; exception when PHG.Too_Many_Tries => if Optimization_Mode = PHG.CPU_Time then raise; end if; V := V + 1; end; end loop; Get_Name_String (Hash_Package_Name (E)); -- Produce the package containing the Hash function; if the user -- specified an output directory, ensure the package is output there. -- If the user specified -p (Use_Stdout), we ignore the -- user-specified output directory (if any), and use a temporary -- directory. -- Note that Produce puts the output in files. It has a Use_Stdout -- parameter, but we want to avoid using that, because it only exists -- on recent versions of GNAT, which we don't want to depend on. So -- instead, we use the temporary directory, then read the files and -- send the data to standard output. In order to avoid depending on -- the file names chosen by Produce, we use wildcards. In the future, -- we should eliminate this kludge, by using the Use_Stdout parameter -- of Produce. if Use_Stdout then declare use GNAT.OS_Lib; Fd : File_Descriptor; Fn : Temp_File_Name; Dummy : Boolean; pragma Unreferenced (Dummy); begin Create_Temp_File (Fd, Fn); Close (Fd); -- Strip trailing NUL from Fn Output_Directory := new String'(Fn (Fn'First .. Fn'Last - 1)); Delete_File (Output_Directory.all, Success => Dummy); Create_Directory (Output_Directory.all); end; end if; if Output_Directory = null then PHG.Produce (Pkg_Name => Name_Buffer (1 .. Name_Len)); else -- Change directory before calling Produce (which always generates -- sources in the current directory). declare Save_Current_Directory : constant String := Current_Directory; procedure Cleanup; -- Put back the current directory, and (if -p) delete the -- temporary directory. ------------- -- Cleanup -- ------------- procedure Cleanup is begin Set_Directory (Save_Current_Directory); if Use_Stdout then Delete_Tree (Output_Directory.all); end if; end Cleanup; begin Set_Directory (Output_Directory.all); PHG.Produce (Pkg_Name => Name_Buffer (1 .. Name_Len)); if Use_Stdout then Put_To_Stdout; end if; Cleanup; exception when others => Cleanup; raise; end; end if; end Achieve_Hash_Function_Optimization; ------------------------------------ -- Insert_And_Register_Statements -- ------------------------------------ procedure Insert_And_Register_Statements (Subp_Name : Name_Id) is Profile : constant List_Id := New_List; N : Node_Id; begin -- First of all, we increment the number of subprograms N_Subprograms := N_Subprograms + 1; -- Insert the subprogram name into the perfect hash table -- generator. Get_Name_String (Subp_Name); PHG.Insert (Name_Buffer (1 .. Name_Len)); -- Generate the call to Register_Procedure, which put an -- access to the Invoke_XXXX in the right place into the -- hash table. N := Make_Literal (New_String_Value (Subp_Name, False)); Append_To (Profile, N); N := Make_Subprogram_Call (Make_Defining_Identifier (SN (S_Register_Procedure)), Profile); Append_To (Register_Procedure_List, N); end Insert_And_Register_Statements; ----------------------------- -- Register_Procedure_Spec -- ----------------------------- function Register_Procedure_Spec return Node_Id is N : Node_Id; Profile : constant List_Id := New_List; begin N := Make_Parameter_Specification (Defining_Identifier => Make_Defining_Identifier (PN (P_Operation_Name)), Subtype_Mark => RE (RE_String_2)); Append_To (Profile, N); N := Make_Subprogram_Specification (Defining_Identifier => Make_Defining_Identifier (SN (S_Register_Procedure)), Parameter_Profile => Profile, Return_Type => No_Node); return N; end Register_Procedure_Spec; ----------------------------- -- Register_Procedure_Body -- ----------------------------- function Register_Procedure_Body (E : Node_Id) return Node_Id is Spec : Node_Id; Declarative_Part : constant List_Id := New_List; Statements : constant List_Id := New_List; N : Node_Id; begin Spec := Register_Procedure_Spec; -- Declarative part N := Make_Object_Declaration (Defining_Identifier => Make_Defining_Identifier (VN (V_Index)), Object_Definition => RE (RE_Natural)); Append_To (Declarative_Part, N); N := Make_Object_Declaration (Defining_Identifier => Make_Defining_Identifier (PN (P_Invoke_Name_Access)), Object_Definition => Make_Defining_Identifier (TN (T_String_Ptr))); Append_To (Declarative_Part, N); -- Statements part N := Make_Selected_Component (Make_Defining_Identifier (Hash_Package_Name (E)), Make_Defining_Identifier (SN (S_Hash))); N := Make_Subprogram_Call (N, New_List (Make_Defining_Identifier (PN (P_Operation_Name)))); N := Make_Assignment_Statement (Make_Defining_Identifier (VN (V_Index)), N); Append_To (Statements, N); -- Test if the hash code was already found in which case -- raise a program error. N := Make_Subprogram_Call (Make_Defining_Identifier (PN (P_Invoke_Db)), New_List (Make_Defining_Identifier (VN (V_Index)))); N := Make_Expression (N, Op_Not_Equal, Make_Null_Statement); N := Make_If_Statement (Condition => N, Then_Statements => New_List (Make_Raise_Statement (Make_Defining_Identifier (EN (E_Program_Error))))); Append_To (Statements, N); -- Assigning the procedure actual name N := Make_Defining_Identifier (PN (P_Invoke_Name_Access)); N := Make_Assignment_Statement (N, Make_Object_Instantiation (Make_Qualified_Expression (Subtype_Mark => RE (RE_String_2), Operand => Make_Defining_Identifier (PN (P_Operation_Name))))); Append_To (Statements, N); -- Update the hash table N := Make_Subprogram_Call (Make_Defining_Identifier (PN (P_Invoke_Db)), New_List (Make_Defining_Identifier (VN (V_Index)))); N := Make_Assignment_Statement (N, Make_Defining_Identifier (PN (P_Invoke_Name_Access))); Append_To (Statements, N); N := Make_Subprogram_Body (Specification => Spec, Declarations => Declarative_Part, Statements => Statements); return N; end Register_Procedure_Body; ----------- -- Visit -- ----------- procedure Visit (E : Node_Id) is begin case FEN.Kind (E) is when K_Interface_Declaration => Visit_Interface_Declaration (E); when K_Module => Visit_Module (E); when K_Operation_Declaration => Visit_Operation_Declaration (E); when K_Specification => Visit_Specification (E); when others => null; end case; end Visit; --------------------------------- -- Visit_Interface_Declaration -- --------------------------------- procedure Visit_Interface_Declaration (E : Node_Id) is N : Node_Id; Param : Node_Id; Profile : constant List_Id := New_List; Invk_Spec : Node_Id; Invk_Body : Node_Id; Is_A_Invk_Part : Node_Id; Implicit_CORBA : List_Id; Parent_Int : Node_Id; function In_Imported (Ent : Node_Id) return Boolean; -- True if Ent, or any of its parent scopes, is imported ----------------- -- In_Imported -- ----------------- function In_Imported (Ent : Node_Id) return Boolean is begin if No (Ent) then return False; elsif Imported (Ent) then return True; else return In_Imported (Scope_Entity (Identifier (Ent))); end if; end In_Imported; -- Start of processing for Visit_Interface_Declaration begin -- No Skel package is generated for an abstract or local interface if FEN.Is_Abstract_Interface (E) or else FEN.Is_Local_Interface (E) then return; end if; N := BEN.Parent (Type_Def_Node (BE_Node (Identifier (E)))); Push_Entity (BEN.IDL_Unit (Package_Declaration (N))); Set_Skeleton_Body; Add_With_Package (Expand_Designator (Implementation_Package (Current_Entity), Add_With_Clause => False)); Invoke_Then_Statements := New_List; Invoke_Methods := New_List; Package_Initialization := New_List; Dependency_List := New_List; Has_Operations := False; Buffer_Necessary := False; -- If the user chose to generate optimised skeletons, we -- initialise the optimization related lists. if Use_Minimal_Hash_Function then Initialize_Hash_Function_Optimization; Choice_List := Invoke_Subp_Bodies; else Invoke_Elsif_Statements := New_List; Choice_List := Invoke_Elsif_Statements; end if; N := First_Entity (Interface_Body (E)); while Present (N) loop Visit (N); N := Next_Entity (N); end loop; -- In case of multiple inheritance, generate the mappings -- for the operations and attributes of the parent interface -- including the first one. Map_Inherited_Entities_Bodies (Current_Interface => E, Visit_Operation_Subp => Visit_Operation_Declaration'Access, Skel => True); -- We make a difference between the Is_A Method and the rest of -- implicit CORBA methods for two reasons: -- * Is_A is not implicit since it is declared in the stub. -- * in case of non-optimisation the _is_a test of the operation is -- always put at the beginning of the if .. elsif .. elsif -- statement to make the code generation of operation code simpler. Is_A_Invk_Part := Is_A_Invoke_Part; -- Here, we assign the list of the implicit CORBA methods. It's -- important to do this before the finalization of the hash function -- generator (in case of optimisation) so that all the hash keys -- can be inserted before the computation phase of the algorithm. Implicit_CORBA := Implicit_CORBA_Methods; -- At this point, all operations and attributes are visited. We -- achieve the perfect hash function generation and the building of -- the conditional structure which handles the request. if Use_Minimal_Hash_Function then if not In_Imported (E) then Achieve_Hash_Function_Optimization (E); end if; PHG.Finalize; end if; -- Here, we append the implicit CORBA methods either to the -- elsif statements or to the case statement depending on -- the optimization mode chosen by the developer. Append_To (Choice_List, First_Node (Implicit_CORBA)); -- Build the Invoke procedure Invk_Spec := Invoke_Spec; Invk_Body := Invoke_Body (E, Is_A_Invk_Part); -- Add the Invoke procedure Spec Append_To (Statements (Current_Package), Invk_Spec); -- Add the Invoke procedure Body Append_To (Statements (Current_Package), Invk_Body); -- Generation of the Servant_Is_A function Param := Make_Parameter_Specification (Make_Defining_Identifier (PN (P_Obj)), RE (RE_Servant)); Append_To (Profile, Param); N := Make_Subprogram_Specification (Make_Defining_Identifier (SN (S_Servant_Is_A)), Profile, RE (RE_Boolean_0)); Append_To (Statements (Current_Package), N); N := Servant_Is_A_Body (N); Append_To (Statements (Current_Package), N); -- Generation of the Deferred_Initialization procedure N := Deferred_Initialization_Body (E); Append_To (Statements (Current_Package), N); -- Make the current skeleton depend upon the skeletons of -- all the interface parent to guarantee their registration -- before the current skeleton. Parent_Int := First_Entity (Interface_Spec (E)); while Present (Parent_Int) loop declare The_Interface : constant Node_Id := Reference (Parent_Int); begin if Present (BE_Node (Identifier (The_Interface))) then Add_Dependency (Expand_Designator (Skeleton_Package (IDL_Unit (Package_Declaration (BEN.Parent (Type_Def_Node (BE_Node (Identifier (The_Interface))))))), False), Dependency_List, D_Skel, True); end if; end; Parent_Int := Next_Entity (Parent_Int); end loop; Skeleton_Initialization (Package_Initialization); Set_Package_Initialization (Current_Package, Package_Initialization); Pop_Entity; end Visit_Interface_Declaration; ------------------ -- Visit_Module -- ------------------ procedure Visit_Module (E : Node_Id) is D : Node_Id; begin if not Map_Particular_CORBA_Parts (E, PK_Skel_Body) then Push_Entity (Stub_Node (BE_Node (Identifier (E)))); D := First_Entity (Definitions (E)); while Present (D) loop Visit (D); D := Next_Entity (D); end loop; Pop_Entity; end if; end Visit_Module; --------------------------------- -- Visit_Operation_Declaration -- --------------------------------- procedure Visit_Operation_Declaration (E : Node_Id) is N : Node_Id; begin Has_Operations := True; N := Gen_Invoke_Part (E); Append_To (Choice_List, N); end Visit_Operation_Declaration; ------------------------- -- Visit_Specification -- ------------------------- procedure Visit_Specification (E : Node_Id) is Definition : Node_Id; begin Push_Entity (Stub_Node (BE_Node (Identifier (E)))); Definition := First_Entity (Definitions (E)); while Present (Definition) loop Visit (Definition); Definition := Next_Entity (Definition); end loop; Pop_Entity; end Visit_Specification; end Package_Body; end Backend.BE_CORBA_Ada.Skels; polyorb-2.8~20110207.orig/compilers/iac/backend-be_corba_ada-helpers.adb0000644000175000017500000032505111750740337025205 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- B A C K E N D . B E _ C O R B A _ A D A . H E L P E R S -- -- -- -- B o d y -- -- -- -- Copyright (C) 2005-2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with Namet; use Namet; with Values; use Values; with Frontend.Nodes; use Frontend.Nodes; with Frontend.Nutils; with Backend.BE_CORBA_Ada.IDL_To_Ada; use Backend.BE_CORBA_Ada.IDL_To_Ada; with Backend.BE_CORBA_Ada.Nodes; use Backend.BE_CORBA_Ada.Nodes; with Backend.BE_CORBA_Ada.Nutils; use Backend.BE_CORBA_Ada.Nutils; with Backend.BE_CORBA_Ada.Runtime; use Backend.BE_CORBA_Ada.Runtime; package body Backend.BE_CORBA_Ada.Helpers is package FEN renames Frontend.Nodes; package FEU renames Frontend.Nutils; package BEN renames Backend.BE_CORBA_Ada.Nodes; package BEU renames Backend.BE_CORBA_Ada.Nutils; package body Package_Spec is function From_Any_Spec (E : Node_Id) return Node_Id; -- Return the `From_Any' function spec corresponding to the IDL -- node E. function To_Any_Spec (E : Node_Id) return Node_Id; -- Return the `To_Any' function spec corresponding to the IDL -- node E. function U_To_Ref_Spec (E : Node_Id) return Node_Id; -- Return the `Unchecked_To_Ref' function spec corresponding to -- the IDL node E. function To_Ref_Spec (E : Node_Id) return Node_Id; -- Return the `To_Ref' function spec corresponding to the IDL -- node E. function Raise_Excp_Spec (Excp_Members : Node_Id; Raise_Node : Node_Id) return Node_Id; -- Return the spec of the Raise_"Exception_Name" procedure function TypeCode_Spec (E : Node_Id) return Node_Id; -- Return a TypeCode variable for a given type (E). function TypeCode_Dimension_Spec (Declarator : Node_Id; Dim : Natural) return Node_Id; -- returns a TypeCode constant for a dimension of an array -- other than the last dimension function TypeCode_Dimension_Declarations (Declarator : Node_Id) return List_Id; -- Multidimensional arrays: when they are converted to the Any -- type, the multidimensional arrays are seen as nested -- arrays. So, for each dimension from the first until the -- before last dimension we declare a type code constant. This -- function returns a list of TC_Dimensions_'N' constant -- declarations procedure Visit_Enumeration_Type (E : Node_Id); procedure Visit_Forward_Interface_Declaration (E : Node_Id); procedure Visit_Interface_Declaration (E : Node_Id); procedure Visit_Module (E : Node_Id); procedure Visit_Specification (E : Node_Id); procedure Visit_Structure_Type (E : Node_Id); procedure Visit_Type_Declaration (E : Node_Id); procedure Visit_Union_Type (E : Node_Id); procedure Visit_Exception_Declaration (E : Node_Id); ------------------- -- From_Any_Spec -- ------------------- function From_Any_Spec (E : Node_Id) return Node_Id is Profile : constant List_Id := New_List; Parameter : Node_Id; N : Node_Id; begin Parameter := Make_Parameter_Specification (Make_Defining_Identifier (PN (P_Item)), RE (RE_Any)); Append_To (Profile, Parameter); N := Make_Subprogram_Specification (Make_Defining_Identifier (SN (S_From_Any)), Profile, Get_Type_Definition_Node (E)); return N; end From_Any_Spec; ------------------- -- U_To_Ref_Spec -- ------------------- function U_To_Ref_Spec (E : Node_Id) return Node_Id is Profile : constant List_Id := New_List; Parameter : Node_Id; N : Node_Id; begin Parameter := Make_Parameter_Specification (Make_Defining_Identifier (PN (P_The_Ref)), Make_Attribute_Reference (Map_Ref_Type_Ancestor (E), A_Class)); Append_To (Profile, Parameter); N := Make_Subprogram_Specification (Map_Narrowing_Designator (E, True), Profile, Expand_Designator (Type_Def_Node (BE_Node (Identifier (E))))); return N; end U_To_Ref_Spec; ----------------- -- To_Any_Spec -- ----------------- function To_Any_Spec (E : Node_Id) return Node_Id is Profile : constant List_Id := New_List; Parameter : Node_Id; N : Node_Id; begin Parameter := Make_Parameter_Specification (Make_Defining_Identifier (PN (P_Item)), Get_Type_Definition_Node (E)); Append_To (Profile, Parameter); N := Make_Subprogram_Specification (Make_Defining_Identifier (SN (S_To_Any)), Profile, RE (RE_Any)); return N; end To_Any_Spec; ----------------- -- To_Ref_Spec -- ----------------- function To_Ref_Spec (E : Node_Id) return Node_Id is Profile : constant List_Id := New_List; Parameter : Node_Id; N : Node_Id; begin Parameter := Make_Parameter_Specification (Make_Defining_Identifier (PN (P_The_Ref)), Make_Attribute_Reference (Map_Ref_Type_Ancestor (E), A_Class)); Append_To (Profile, Parameter); N := Make_Subprogram_Specification (Map_Narrowing_Designator (E, False), Profile, Expand_Designator (Type_Def_Node (BE_Node (Identifier (E))))); return N; end To_Ref_Spec; --------------------- -- Raise_Excp_Spec -- --------------------- function Raise_Excp_Spec (Excp_Members : Node_Id; Raise_Node : Node_Id) return Node_Id is Profile : constant List_Id := New_List; Parameter : Node_Id; N : Node_Id; begin Parameter := Make_Parameter_Specification (Make_Defining_Identifier (PN (P_Members)), Excp_Members); Append_To (Profile, Parameter); N := Make_Subprogram_Specification (Raise_Node, Profile); return N; end Raise_Excp_Spec; ------------------- -- TypeCode_Spec -- ------------------- function TypeCode_Spec (E : Node_Id) return Node_Id is N : Node_Id := E; TC : Name_Id; begin -- The name of the TypeCode variable is generally mapped -- from the name of the Ada type mapped from the IDL -- type. For forward interface, the name is mapped from the -- forwarded interface. For sequences and bounded strings, -- the name is mapped from the pacjahe instantiation name. case FEN.Kind (E) is when K_Enumeration_Type => N := Get_Type_Definition_Node (E); when K_Forward_Interface_Declaration => N := Package_Declaration (BEN.Parent (Type_Def_Node (BE_Node (Identifier (Forward (E)))))); when K_Fixed_Point_Type => N := Get_Type_Definition_Node (E); when K_Interface_Declaration => N := Package_Declaration (BEN.Parent (Type_Def_Node (BE_Node (Identifier (E))))); when K_Sequence_Type | K_String_Type | K_Wide_String_Type => N := Expand_Designator (Instantiation_Node (BE_Node (E))); when K_Simple_Declarator => N := Get_Type_Definition_Node (E); when K_Complex_Declarator => N := Get_Type_Definition_Node (E); when K_Structure_Type => N := Get_Type_Definition_Node (E); when K_Union_Type => N := Get_Type_Definition_Node (E); when K_Exception_Declaration => N := Make_Identifier (To_Ada_Name (IDL_Name (Identifier (E)))); when others => declare Msg : constant String := "Cannot generate TypeCode for the frontend node " & FEN.Node_Kind'Image (FEN.Kind (E)); begin raise Program_Error with Msg; end; end case; TC := Add_Prefix_To_Name ("TC_", Get_Name (Get_Base_Identifier (N))); N := Make_Object_Declaration (Defining_Identifier => Make_Defining_Identifier (TC), Object_Definition => RE (RE_Object)); return N; end TypeCode_Spec; ----------------------------- -- TypeCode_Dimension_Spec -- ----------------------------- function TypeCode_Dimension_Spec (Declarator : Node_Id; Dim : Natural) return Node_Id is N : Node_Id; TC_Name : Name_Id; begin -- The varible name is mapped as follows: -- TC__TC_Dimension_ N := Defining_Identifier (Type_Def_Node (BE_Node (Identifier (Declarator)))); TC_Name := Add_Prefix_To_Name ("TC_", BEN.Name (N)); Get_Name_String (TC_Name); Add_Str_To_Name_Buffer ("_TC_Dimension_"); Add_Nat_To_Name_Buffer (Int (Dim)); TC_Name := Name_Find; -- Declare the variable N := Make_Object_Declaration (Defining_Identifier => Make_Defining_Identifier (TC_Name), Object_Definition => RE (RE_Object)); return N; end TypeCode_Dimension_Spec; ------------------------------------- -- TypeCode_Dimension_Declarations -- ------------------------------------- function TypeCode_Dimension_Declarations (Declarator : Node_Id) return List_Id is pragma Assert (FEN.Kind (Declarator) = K_Complex_Declarator); Dim : constant Natural := FEU.Length (FEN.Array_Sizes (Declarator)); L : List_Id; N : Node_Id; begin pragma Assert (Dim > 1); L := New_List; for I in 1 .. Dim - 1 loop N := TypeCode_Dimension_Spec (Declarator, I); Append_To (L, N); end loop; return L; end TypeCode_Dimension_Declarations; ----------- -- Visit -- ----------- procedure Visit (E : Node_Id) is begin case FEN.Kind (E) is when K_Enumeration_Type => Visit_Enumeration_Type (E); when K_Forward_Interface_Declaration => Visit_Forward_Interface_Declaration (E); when K_Interface_Declaration => Visit_Interface_Declaration (E); when K_Module => Visit_Module (E); when K_Specification => Visit_Specification (E); when K_Structure_Type => Visit_Structure_Type (E); when K_Type_Declaration => Visit_Type_Declaration (E); when K_Union_Type => Visit_Union_Type (E); when K_Exception_Declaration => Visit_Exception_Declaration (E); when others => null; end case; end Visit; ---------------------------- -- Visit_Enumeration_Type -- ---------------------------- procedure Visit_Enumeration_Type (E : Node_Id) is N : Node_Id; begin Set_Helper_Spec; N := TypeCode_Spec (E); Append_To (Visible_Part (Current_Package), N); Bind_FE_To_BE (Identifier (E), N, B_TC); N := From_Any_Spec (E); Append_To (Visible_Part (Current_Package), N); Bind_FE_To_BE (Identifier (E), N, B_From_Any); N := To_Any_Spec (E); Append_To (Visible_Part (Current_Package), N); Bind_FE_To_BE (Identifier (E), N, B_To_Any); end Visit_Enumeration_Type; ----------------------------------------- -- Visit_Forward_Interface_Declaration -- ----------------------------------------- procedure Visit_Forward_Interface_Declaration (E : Node_Id) is N : Node_Id; Is_Local : constant Boolean := Is_Local_Interface (E); begin Set_Helper_Spec; N := TypeCode_Spec (E); Append_To (Visible_Part (Current_Package), N); Bind_FE_To_BE (Identifier (E), N, B_TC); -- Local interfaces don't have Any conversion methods -- because local references cannot be transferred through -- the network. if not Is_Local then N := From_Any_Spec (E); Append_To (Visible_Part (Current_Package), N); Bind_FE_To_BE (Identifier (E), N, B_From_Any); N := To_Any_Spec (E); Append_To (Visible_Part (Current_Package), N); Bind_FE_To_BE (Identifier (E), N, B_To_Any); end if; N := U_To_Ref_Spec (E); Append_To (Visible_Part (Current_Package), N); Bind_FE_To_BE (Identifier (E), N, B_U_To_Ref); N := To_Ref_Spec (E); Append_To (Visible_Part (Current_Package), N); Bind_FE_To_BE (Identifier (E), N, B_To_Ref); end Visit_Forward_Interface_Declaration; --------------------------------- -- Visit_Interface_Declaration -- --------------------------------- procedure Visit_Interface_Declaration (E : Node_Id) is N : Node_Id; Is_Local : constant Boolean := Is_Local_Interface (E); begin N := BEN.Parent (Type_Def_Node (BE_Node (Identifier (E)))); Push_Entity (BEN.IDL_Unit (Package_Declaration (N))); Set_Helper_Spec; N := TypeCode_Spec (E); Append_To (Visible_Part (Current_Package), N); Bind_FE_To_BE (Identifier (E), N, B_TC); -- Local interfaces don't have Any conversion methods -- because local references cannot be transferred through -- the network. if not Is_Local then N := From_Any_Spec (E); Append_To (Visible_Part (Current_Package), N); Bind_FE_To_BE (Identifier (E), N, B_From_Any); N := To_Any_Spec (E); Append_To (Visible_Part (Current_Package), N); Bind_FE_To_BE (Identifier (E), N, B_To_Any); end if; N := U_To_Ref_Spec (E); Append_To (Visible_Part (Current_Package), N); Bind_FE_To_BE (Identifier (E), N, B_U_To_Ref); N := To_Ref_Spec (E); Append_To (Visible_Part (Current_Package), N); Bind_FE_To_BE (Identifier (E), N, B_To_Ref); -- Visit the entities declared inside the interface. N := First_Entity (Interface_Body (E)); while Present (N) loop Visit (N); N := Next_Entity (N); end loop; -- In case of multiple inheritance, generate the mappings -- for the operations and attributes of the parents other -- than the first one. Map_Inherited_Entities_Specs (Current_Interface => E, Visit_Operation_Subp => null, Helper => True); Pop_Entity; end Visit_Interface_Declaration; ------------------ -- Visit_Module -- ------------------ procedure Visit_Module (E : Node_Id) is D : Node_Id; begin if not Map_Particular_CORBA_Parts (E, PK_Helper_Spec) then Push_Entity (Stub_Node (BE_Node (Identifier (E)))); D := First_Entity (Definitions (E)); while Present (D) loop Visit (D); D := Next_Entity (D); end loop; Pop_Entity; end if; end Visit_Module; ------------------------- -- Visit_Specification -- ------------------------- procedure Visit_Specification (E : Node_Id) is Definition : Node_Id; begin Push_Entity (Stub_Node (BE_Node (Identifier (E)))); Definition := First_Entity (Definitions (E)); while Present (Definition) loop Visit (Definition); Definition := Next_Entity (Definition); end loop; Pop_Entity; end Visit_Specification; -------------------------- -- Visit_Structure_Type -- -------------------------- procedure Visit_Structure_Type (E : Node_Id) is N : Node_Id; begin Set_Helper_Spec; N := TypeCode_Spec (E); Append_To (Visible_Part (Current_Package), N); Bind_FE_To_BE (Identifier (E), N, B_TC); -- Do not generate the Any converters in case one of the -- component is a local interface or has a local interface -- component because local references cannot be transferred -- through the network. if not FEU.Has_Local_Component (E) then N := From_Any_Spec (E); Append_To (Visible_Part (Current_Package), N); Bind_FE_To_BE (Identifier (E), N, B_From_Any); N := To_Any_Spec (E); Append_To (Visible_Part (Current_Package), N); Bind_FE_To_BE (Identifier (E), N, B_To_Any); end if; end Visit_Structure_Type; ---------------------------- -- Visit_Type_Declaration -- ---------------------------- procedure Visit_Type_Declaration (E : Node_Id) is L : List_Id; D : Node_Id; N : Node_Id; T : Node_Id; begin Set_Helper_Spec; L := Declarators (E); T := Type_Spec (E); D := First_Entity (L); -- Handling the case of fixed point type definitions, -- sequence type defitions and bounded [wide] string type -- definitions. We create Any conversion routines for the -- extra entities declared in the stub spec. if FEN.Kind (T) = K_Fixed_Point_Type or else FEN.Kind (T) = K_Sequence_Type or else FEN.Kind (T) = K_String_Type or else FEN.Kind (T) = K_Wide_String_Type then begin N := TypeCode_Spec (T); Bind_FE_To_BE (T, N, B_TC); Append_To (Visible_Part (Current_Package), N); -- Do not generate the Any converters in case one of -- the component is a local interface or has a local -- interface component because local references cannot -- be transferred through the network. if not FEU.Has_Local_Component (T) then N := From_Any_Spec (T); Bind_FE_To_BE (T, N, B_From_Any); Append_To (Visible_Part (Current_Package), N); N := To_Any_Spec (T); Bind_FE_To_BE (T, N, B_To_Any); Append_To (Visible_Part (Current_Package), N); end if; end; end if; -- Handling the Ada type mapped from the IDL type (general -- case). while Present (D) loop N := TypeCode_Spec (D); Append_To (Visible_Part (Current_Package), N); Bind_FE_To_BE (Identifier (D), N, B_TC); -- Multi-dimensional array types need extra TypeCode variables -- for each dimension, which are used for the initialization of -- the outermost array typecode. if FEN.Kind (D) = K_Complex_Declarator and then FEU.Length (FEN.Array_Sizes (D)) > 1 then Append_To (Visible_Part (Current_Package), First_Node (TypeCode_Dimension_Declarations (D))); end if; -- If the new type is defined basing on an interface type -- (through Ada SUBtyping), and then if this is not an -- array type, then we don't generate From_Any nor -- To_Any. We use those of the original type. Otherwise, -- the conversion routines whould have exactly the same -- signature and name clashing would occur in the helper -- name space. if Is_Object_Type (T) and then FEN.Kind (D) = K_Simple_Declarator then -- For local interface, we generate nothing because -- local references cannot be transferred through -- network. if not FEU.Has_Local_Component (T) then N := Get_From_Any_Node (T, False); Bind_FE_To_BE (Identifier (D), N, B_From_Any); N := Get_To_Any_Node (T, False); Bind_FE_To_BE (Identifier (D), N, B_To_Any); end if; else -- Do not generate the Any converters in case one of -- the component is a local interface or has a local -- interface component because local references cannot -- be transferred through network. if not FEU.Has_Local_Component (T) then N := From_Any_Spec (D); Append_To (Visible_Part (Current_Package), N); Bind_FE_To_BE (Identifier (D), N, B_From_Any); N := To_Any_Spec (D); Append_To (Visible_Part (Current_Package), N); Bind_FE_To_BE (Identifier (D), N, B_To_Any); end if; end if; D := Next_Entity (D); end loop; end Visit_Type_Declaration; --------------------------------- -- Visit_Exception_Declaration -- --------------------------------- procedure Visit_Exception_Declaration (E : Node_Id) is N : Node_Id; Excp_Members : Node_Id; Excp_Name : Name_Id; Raise_Node : Node_Id; begin Set_Helper_Spec; N := TypeCode_Spec (E); Append_To (Visible_Part (Current_Package), N); Bind_FE_To_BE (Identifier (E), N, B_TC); -- Get the node corresponding to the declaration of the -- "Excp_Name"_Members type. Excp_Members := Get_Type_Definition_Node (E); -- Do not generate the Any converters in case one of the -- component is a local interface or has a local interface -- component because local refernces cannot be transferred -- through network.. if not FEU.Has_Local_Component (E) then N := From_Any_Spec (E); Append_To (Visible_Part (Current_Package), N); Bind_FE_To_BE (Identifier (E), N, B_From_Any); N := To_Any_Spec (E); Append_To (Visible_Part (Current_Package), N); Bind_FE_To_BE (Identifier (E), N, B_To_Any); end if; -- Generation of the Raise_"Exception_Name" spec Excp_Name := To_Ada_Name (IDL_Name (FEN.Identifier (E))); Raise_Node := Make_Defining_Identifier (Add_Prefix_To_Name ("Raise_", Excp_Name)); N := Raise_Excp_Spec (Excp_Members, Raise_Node); Append_To (Visible_Part (Current_Package), N); Bind_FE_To_BE (Identifier (E), N, B_Raise_Excp); -- A call to Raise_ does not return N := Make_Pragma (Pragma_No_Return, New_List (Make_Identifier (BEN.Name (Raise_Node)))); Append_To (Visible_Part (Current_Package), N); end Visit_Exception_Declaration; ---------------------- -- Visit_Union_Type -- ---------------------- procedure Visit_Union_Type (E : Node_Id) is N : Node_Id; begin Set_Helper_Spec; N := TypeCode_Spec (E); Append_To (Visible_Part (Current_Package), N); Bind_FE_To_BE (Identifier (E), N, B_TC); -- Do not generate the Any converters in case one of the -- component is a local interface or has a local interface -- component because local refernces cannot be transferred -- through network.. if not FEU.Has_Local_Component (E) then N := From_Any_Spec (E); Append_To (Visible_Part (Current_Package), N); Bind_FE_To_BE (Identifier (E), N, B_From_Any); N := To_Any_Spec (E); Append_To (Visible_Part (Current_Package), N); Bind_FE_To_BE (Identifier (E), N, B_To_Any); end if; end Visit_Union_Type; end Package_Spec; package body Package_Body is function Deferred_Initialization_Block (E : Node_Id) return Node_Id; -- Returns the Initialize routine corresponding to the IDL -- entity E. function Declare_Any_Array (A_Name : Name_Id; A_First : Natural; A_Last : Natural) return Node_Id; -- Declare an `Any' array declaration procedure Helper_Initialization (L : List_Id); -- Create the initialization block for the Helper package function Nth_Element (A_Name : Name_Id; Nth : Nat) return Node_Id; -- Create an Ada construct to get the Nth element of array -- `A_Name'. function From_Any_Body (E : Node_Id) return Node_Id; -- Create the body of the `From_Any' function relative to the -- IDL entity E. function To_Any_Body (E : Node_Id) return Node_Id; -- Create the body of the `To_Any' function relative to the IDL -- entity E. function U_To_Ref_Body (E : Node_Id) return Node_Id; -- Create the body of the `Unckecked_To_Ref' function relative -- to the IDL entity E. function To_Ref_Body (E : Node_Id) return Node_Id; -- Create the body of the `To_Ref' function relative to the IDL -- entity E. function Raise_Excp_Body (E : Node_Id) return Node_Id; -- Create the body of the `Raise_Exception' function relative -- to the IDL entity E. procedure Visit_Enumeration_Type (E : Node_Id); procedure Visit_Forward_Interface_Declaration (E : Node_Id); procedure Visit_Interface_Declaration (E : Node_Id); procedure Visit_Module (E : Node_Id); procedure Visit_Specification (E : Node_Id); procedure Visit_Structure_Type (E : Node_Id); procedure Visit_Type_Declaration (E : Node_Id); procedure Visit_Union_Type (E : Node_Id); procedure Visit_Exception_Declaration (E : Node_Id); ----------------------------------- -- Deferred_Initialization_Block -- ----------------------------------- function Deferred_Initialization_Block (E : Node_Id) return Node_Id is Frontend_Node : Node_Id := E; N : Node_Id; begin if FEN.Kind (E) /= K_Fixed_Point_Type and then FEN.Kind (E) /= K_Sequence_Type and then FEN.Kind (E) /= K_String_Type and then FEN.Kind (E) /= K_Wide_String_Type then Frontend_Node := Identifier (Frontend_Node); end if; -- We just call the Initialize routine generated in the -- Helper.Internal sub-package. N := Expand_Designator (Initialize_Node (BE_Node (Frontend_Node))); return N; end Deferred_Initialization_Block; ----------------------- -- Declare_Any_Array -- ----------------------- function Declare_Any_Array (A_Name : Name_Id; A_First : Natural; A_Last : Natural) return Node_Id is N : Node_Id; R : Node_Id; L : List_Id; First : Value_Id; Last : Value_Id; begin First := New_Integer_Value (Unsigned_Long_Long (A_First), 1, 10); Last := New_Integer_Value (Unsigned_Long_Long (A_Last), 1, 10); R := Make_Range_Constraint (Make_Literal (First), Make_Literal (Last)); L := New_List; Append_To (L, R); N := Make_Object_Declaration (Defining_Identifier => Make_Defining_Identifier (A_Name), Object_Definition => Make_Array_Type_Definition (L, RE (RE_Any))); return N; end Declare_Any_Array; ----------------- -- Nth_Element -- ----------------- function Nth_Element (A_Name : Name_Id; Nth : Nat) return Node_Id is Nth_Value : Value_Id; N : Node_Id; begin Nth_Value := New_Integer_Value (Unsigned_Long_Long (Nth), 1, 10); N := Make_Indexed_Component (Make_Defining_Identifier (A_Name), New_List (Make_Literal (Nth_Value))); return N; end Nth_Element; ------------------- -- From_Any_Body -- ------------------- function From_Any_Body (E : Node_Id) return Node_Id is N : Node_Id; M : Node_Id; Spec : Node_Id; D : constant List_Id := New_List; S : constant List_Id := New_List; function Complex_Declarator_Body (E : Node_Id) return Node_Id; function Enumeration_Type_Body (E : Node_Id) return Node_Id; function Interface_Declaration_Body (E : Node_Id) return Node_Id; function Simple_Declarator_Body (E : Node_Id) return Node_Id; function Structure_Type_Body (E : Node_Id) return Node_Id; function Union_Type_Body (E : Node_Id) return Node_Id; function Exception_Declaration_Body (E : Node_Id) return Node_Id; ----------------------------- -- Complex_Declarator_Body -- ----------------------------- function Complex_Declarator_Body (E : Node_Id) return Node_Id is I : Nat := 0; Sizes : constant List_Id := Range_Constraints (Type_Definition (Type_Def_Node (BE_Node (Identifier (E))))); Dimension : constant Natural := BEU.Length (Sizes); Dim : Node_Id; Loop_Statements : List_Id := No_List; Enclosing_Statements : List_Id; Index_List : constant List_Id := New_List; Helper : Node_Id; TC : Node_Id; Index_Node : Node_Id := No_Node; Prev_Index_Node : Node_Id; Aux_Node : Node_Id; begin Spec := From_Any_Node (BE_Node (Identifier (E))); N := Make_Object_Declaration (Defining_Identifier => Make_Defining_Identifier (PN (P_Result)), Object_Definition => Copy_Expanded_Name (Return_Type (Spec))); Append_To (D, N); N := Declare_Any_Array (PN (P_Aux), 0, Dimension - 1); Append_To (D, N); Dim := First_Node (Sizes); TC := TC_Node (BE_Node (Identifier (E))); loop Set_Str_To_Name_Buffer ("I"); Add_Nat_To_Name_Buffer (I); Prev_Index_Node := Index_Node; Index_Node := Make_Defining_Identifier (Add_Suffix_To_Name (Unique_Suffix, Name_Find)); Append_To (Index_List, Index_Node); Enclosing_Statements := Loop_Statements; Loop_Statements := New_List; N := Make_For_Statement (Index_Node, Dim, Loop_Statements); if I > 0 then Aux_Node := Nth_Element (PN (P_Aux), I); Aux_Node := Make_Assignment_Statement (Aux_Node, Make_Subprogram_Call (RE (RE_Get_Aggregate_Element), New_List (Nth_Element (PN (P_Aux), I - 1), Expand_Designator (TC), Make_Subprogram_Call (RE (RE_Unsigned_Long), New_List (Copy_Node (Prev_Index_Node)))))); Append_To (Enclosing_Statements, Aux_Node); Append_To (Enclosing_Statements, N); else Aux_Node := Nth_Element (PN (P_Aux), I); Aux_Node := Make_Assignment_Statement (Aux_Node, Make_Defining_Identifier (PN (P_Item))); Append_To (S, Aux_Node); Append_To (S, N); end if; I := I + 1; -- Although we use only TC_XXX_TC_Dimension_N in the enclosing -- loops, the assignment above must be done at the end, and not -- at the beginning, of the loop. This is due to the fact that -- the statements of a For loop are computed in the iteration -- which comes after the one in which the for loop is created. TC := Next_Node (TC); Dim := Next_Node (Dim); exit when No (Dim); end loop; TC := Get_TC_Node (Type_Spec (Declaration (E))); Helper := Get_From_Any_Node (Type_Spec (Declaration (E))); N := Make_Indexed_Component (Make_Defining_Identifier (PN (P_Result)), Index_List); M := Make_Subprogram_Call (RE (RE_Get_Aggregate_Element), New_List (Nth_Element (PN (P_Aux), I - 1), TC, Make_Type_Conversion (RE (RE_Unsigned_Long), Copy_Node (Index_Node)))); M := Make_Subprogram_Call (Helper, New_List (M)); N := Make_Assignment_Statement (N, M); Append_To (Loop_Statements, N); N := Make_Return_Statement (Make_Defining_Identifier (PN (P_Result))); Append_To (S, N); N := Make_Subprogram_Body (Spec, D, S); return N; end Complex_Declarator_Body; --------------------------- -- Enumeration_Type_Body -- --------------------------- function Enumeration_Type_Body (E : Node_Id) return Node_Id is begin Spec := From_Any_Node (BE_Node (Identifier (E))); -- Return statement N := Make_Subprogram_Call (RE (RE_Get_Container_1), New_List (Make_Identifier (PN (P_Item)))); N := Make_Explicit_Dereference (N); N := Make_Subprogram_Call (Get_From_Any_Container_Node (E), New_List (N)); N := Make_Return_Statement (N); Append_To (S, N); -- Build the subprogram body N := Make_Subprogram_Body (Spec, D, S); return N; end Enumeration_Type_Body; -------------------------------- -- Interface_Declaration_Body -- -------------------------------- function Interface_Declaration_Body (E : Node_Id) return Node_Id is begin Spec := From_Any_Node (BE_Node (Identifier (E))); N := Make_Subprogram_Call (Map_Narrowing_Designator (E, False), New_List (Make_Subprogram_Call (RE (RE_From_Any_1), New_List (Make_Defining_Identifier (PN (P_Item)))))); N := Make_Return_Statement (N); Append_To (S, N); N := Make_Subprogram_Body (Spec, D, S); return N; end Interface_Declaration_Body; ---------------------------- -- Simple_Declarator_Body -- ---------------------------- function Simple_Declarator_Body (E : Node_Id) return Node_Id is begin Spec := From_Any_Node (BE_Node (Identifier (E))); -- Get the typespec of the type declaration of the simple -- declarator. N := Get_Type_Definition_Node (Type_Spec (Declaration (E))); -- Get the `From_Any' Spec of typespec of the type -- declaration of the simple declarator. M := Get_From_Any_Node (Type_Spec (Declaration (E))); M := Make_Subprogram_Call (M, New_List (Make_Defining_Identifier (PN (P_Item)))); N := Make_Object_Declaration (Defining_Identifier => Make_Defining_Identifier (PN (P_Result)), Constant_Present => True, Object_Definition => N, Expression => M); Append_To (D, N); N := Make_Subprogram_Call (Return_Type (Spec), New_List (Make_Defining_Identifier (PN (P_Result)))); N := Make_Return_Statement (N); Append_To (S, N); N := Make_Subprogram_Body (Spec, D, S); return N; end Simple_Declarator_Body; ------------------------- -- Structure_Type_Body -- ------------------------- function Structure_Type_Body (E : Node_Id) return Node_Id is Result_Struct_Aggregate : Node_Id; L : constant List_Id := New_List; Member : Node_Id; Declarator : Node_Id; Designator : Node_Id; V : Value_Type := Value (Int0_Val); TC : Node_Id; Helper : Node_Id; begin Spec := From_Any_Node (BE_Node (Identifier (E))); Member := First_Entity (Members (E)); while Present (Member) loop Declarator := First_Entity (Declarators (Member)); while Present (Declarator) loop TC := Get_TC_Node (Type_Spec (Declaration (Declarator))); Helper := Get_From_Any_Node (Type_Spec (Declaration (Declarator))); N := Make_Subprogram_Call (RE (RE_Get_Aggregate_Element), New_List (Make_Defining_Identifier (PN (P_Item)), TC, Make_Literal (New_Value (V)))); N := Make_Subprogram_Call (Helper, New_List (N)); Designator := Map_Expanded_Name (Declarator); N := Make_Component_Association (Designator, N); Append_To (L, N); V.IVal := V.IVal + 1; Declarator := Next_Entity (Declarator); end loop; Member := Next_Entity (Member); end loop; Result_Struct_Aggregate := Make_Record_Aggregate (L); N := Make_Return_Statement (Result_Struct_Aggregate); Append_To (S, N); N := Make_Subprogram_Body (Spec, D, S); return N; end Structure_Type_Body; --------------------- -- Union_Type_Body -- --------------------- function Union_Type_Body (E : Node_Id) return Node_Id is Alternative_Name : Name_Id; Switch_Case : Node_Id; Switch_Alternatives : List_Id; Switch_Alternative : Node_Id; Switch_Statements : List_Id; Has_Default : Boolean := False; Choices : List_Id; From_Any_Helper : Node_Id; TC_Helper : Node_Id; Switch_Type : Node_Id; Literal_Parent : Node_Id := No_Node; Orig_Type : constant Node_Id := FEU.Get_Original_Type_Specifier (Switch_Type_Spec (E)); begin Spec := From_Any_Node (BE_Node (Identifier (E))); -- Declarative Part -- Getting the From_Any function the TC_XXX constant and -- the Ada type nodes corresponding to the discriminant -- type. TC_Helper := Get_TC_Node (Switch_Type_Spec (E)); From_Any_Helper := Get_From_Any_Node (Switch_Type_Spec (E)); if Is_Base_Type (Switch_Type_Spec (E)) then Switch_Type := RE (Convert (FEN.Kind (Switch_Type_Spec (E)))); elsif FEN.Kind (Orig_Type) = K_Enumeration_Type then Switch_Type := Map_Expanded_Name (Switch_Type_Spec (E)); Literal_Parent := Map_Expanded_Name (Scope_Entity (Identifier (Orig_Type))); else Switch_Type := Map_Expanded_Name (Switch_Type_Spec (E)); end if; -- Declaration of the "Label_Any" Variable. N := Make_Subprogram_Call (RE (RE_Get_Aggregate_Element), New_List (Make_Identifier (PN (P_Item)), TC_Helper, Make_Type_Conversion (RE (RE_Unsigned_Long), Make_Literal (Int0_Val)))); N := Make_Object_Declaration (Defining_Identifier => Make_Defining_Identifier (VN (V_Label_Any)), Constant_Present => True, Object_Definition => RE (RE_Any), Expression => N); Append_To (D, N); -- Converting the "Label_Value" to to the discriminant type N := Make_Subprogram_Call (From_Any_Helper, New_List (Make_Defining_Identifier (VN (V_Label_Any)))); N := Make_Object_Declaration (Defining_Identifier => Make_Defining_Identifier (VN (V_Label)), Constant_Present => True, Object_Definition => Switch_Type, Expression => N); Append_To (D, N); -- Declaring the "Result" variable N := Make_Type_Conversion (Copy_Expanded_Name (Return_Type (Spec)), Make_Defining_Identifier (VN (V_Label))); N := Make_Object_Declaration (Defining_Identifier => Make_Defining_Identifier (PN (P_Result)), Object_Definition => N); Append_To (D, N); -- Declaring the "Index" variable N := Make_Object_Declaration (Defining_Identifier => Make_Defining_Identifier (VN (V_Index)), Object_Definition => RE (RE_Any)); Append_To (D, N); -- Statements Switch_Alternatives := New_List; Switch_Case := First_Entity (Switch_Type_Body (E)); while Present (Switch_Case) loop Switch_Statements := New_List; Map_Choice_List (Labels (Switch_Case), Literal_Parent, Choices, Has_Default); -- Getting the field full name Alternative_Name := BEU.To_Ada_Name (FEN.IDL_Name (Identifier (Declarator (Element (Switch_Case))))); Get_Name_String (PN (P_Result)); Add_Char_To_Name_Buffer ('.'); Get_Name_String_And_Append (Alternative_Name); Alternative_Name := Name_Find; -- Getting the From_Any function the TC_XXX constant and the -- Ada type nodes corresponding to the element type. TC_Helper := Get_TC_Node (Type_Spec (Element (Switch_Case))); From_Any_Helper := Get_From_Any_Node (Type_Spec (Element (Switch_Case))); if Is_Base_Type (Type_Spec (Element (Switch_Case))) then Switch_Type := RE (Convert (FEN.Kind (Type_Spec (Element (Switch_Case))))); elsif FEN.Kind (Type_Spec (Element (Switch_Case))) = K_Scoped_Name then Switch_Type := Map_Expanded_Name (Type_Spec (Element (Switch_Case))); else declare Msg : constant String := "Could not fetch From_Any " & "spec and TypeCode of: " & FEN.Node_Kind'Image (Kind (Type_Spec (Element (Switch_Case)))); begin raise Program_Error with Msg; end; end if; -- Assigning the value to the "Index" variable N := Make_Subprogram_Call (RE (RE_Get_Aggregate_Element), New_List (Make_Identifier (PN (P_Item)), TC_Helper, Make_Type_Conversion (RE (RE_Unsigned_Long), Make_Literal (Int1_Val)))); N := Make_Assignment_Statement (Make_Defining_Identifier (VN (V_Index)), N); Append_To (Switch_Statements, N); -- Converting the Any value N := Make_Subprogram_Call (From_Any_Helper, New_List (Make_Defining_Identifier (VN (V_Index)))); N := Make_Assignment_Statement (Make_Defining_Identifier (Alternative_Name), N); Append_To (Switch_Statements, N); Switch_Alternative := Make_Case_Statement_Alternative (Choices, Switch_Statements); Append_To (Switch_Alternatives, Switch_Alternative); Switch_Case := Next_Entity (Switch_Case); end loop; -- Add an empty when others clause to keep the compiler -- happy. if not Has_Default then Append_To (Switch_Alternatives, Make_Case_Statement_Alternative (No_List, No_List)); end if; N := Make_Case_Statement (Make_Defining_Identifier (VN (V_Label)), Switch_Alternatives); Append_To (S, N); N := Make_Return_Statement (Make_Defining_Identifier (PN (P_Result))); Append_To (S, N); N := Make_Subprogram_Body (Spec, D, S); return N; end Union_Type_Body; -------------------------------- -- Exception_Declaration_Body -- -------------------------------- function Exception_Declaration_Body (E : Node_Id) return Node_Id is Members : List_Id; Member : Node_Id; Member_Type : Node_Id; Declarator : Node_Id; Dcl_Name : Name_Id; Index : Unsigned_Long_Long; Param_List : List_Id; Return_List : List_Id; From_Any_Helper : Node_Id; begin -- Get the "From_Any" spec node from the helper spec Spec := From_Any_Node (BE_Node (Identifier (E))); Members := FEN.Members (E); -- The generated code is totally different depending on -- the existence or not of members in the exception. if FEU.Is_Empty (Members) then -- We declare a dummy empty structure corresponding to -- the exception members and we return it. -- Declarations -- Get the node corresponding to the declaration of -- the "Excp_Name"_Members type. N := Get_Type_Definition_Node (E); N := Make_Object_Declaration (Defining_Identifier => Make_Defining_Identifier (VN (V_Result)), Object_Definition => N); Append_To (D, N); -- Adding the necessary pragmas because the parameter -- of the function is unreferenced. N := Make_Pragma (Pragma_Warnings, New_List (RE (RE_Off))); Append_To (D, N); N := Make_Pragma (Pragma_Unreferenced, New_List (Make_Identifier (PN (P_Item)))); Append_To (D, N); N := Make_Pragma (Pragma_Warnings, New_List (RE (RE_On))); Append_To (D, N); -- Statements N := Make_Return_Statement (Make_Identifier (VN (V_Result))); Append_To (S, N); else -- Declarations Return_List := New_List; Member := First_Entity (Members); Index := 0; while Present (Member) loop Declarator := First_Entity (Declarators (Member)); while Present (Declarator) loop Dcl_Name := To_Ada_Name (IDL_Name (FEN.Identifier (Declarator))); Member_Type := Type_Spec (Member); Param_List := New_List ( Make_Identifier (PN (P_Item)), Get_TC_Node (Member_Type), Make_Literal (New_Integer_Value (Index, 1, 10))); From_Any_Helper := Get_From_Any_Node (Member_Type); N := Make_Subprogram_Call (RE (RE_Get_Aggregate_Element), Param_List); N := Make_Subprogram_Call (From_Any_Helper, New_List (N)); -- Adding the element to the return list Append_To (Return_List, Make_Component_Association (Make_Identifier (Dcl_Name), N)); Declarator := Next_Entity (Declarator); Index := Index + 1; end loop; Member := Next_Entity (Member); end loop; N := Make_Return_Statement (Make_Record_Aggregate (Return_List)); Append_To (S, N); end if; N := Make_Subprogram_Body (Spec, D, S); return N; end Exception_Declaration_Body; begin case FEN.Kind (E) is when K_Complex_Declarator => N := Complex_Declarator_Body (E); when K_Enumeration_Type => N := Enumeration_Type_Body (E); when K_Interface_Declaration | K_Forward_Interface_Declaration => N := Interface_Declaration_Body (E); when K_Simple_Declarator => N := Simple_Declarator_Body (E); when K_Structure_Type => N := Structure_Type_Body (E); when K_Union_Type => N := Union_Type_Body (E); when K_Exception_Declaration => N := Exception_Declaration_Body (E); when others => declare Msg : constant String := "Cannot not generate From_Any " & "body for a: " & FEN.Node_Kind'Image (Kind (E)); begin raise Program_Error with Msg; end; end case; return N; end From_Any_Body; --------------------------- -- Helper_Initialization -- --------------------------- procedure Helper_Initialization (L : List_Id) is N : Node_Id; Dep : Node_Id; V : Value_Id; Aggregates : List_Id; Declarative_Part : constant List_Id := New_List; Statements : constant List_Id := New_List; Dependency_List : constant List_Id := Get_GList (Package_Declaration (Current_Package), GL_Dependencies); begin -- Declarative part -- Adding 'use' clauses to make the code more readable N := Make_Used_Package (RU (RU_PolyORB_Utils_Strings)); Append_To (Declarative_Part, N); N := Make_Used_Package (RU (RU_PolyORB_Utils_Strings_Lists)); Append_To (Declarative_Part, N); -- Statements -- The package name Aggregates := New_List; N := Defining_Identifier (Package_Declaration (Current_Package)); V := New_String_Value (Fully_Qualified_Name (N), False); N := Make_Expression (Make_Literal (V), Op_Plus); N := Make_Component_Association (Selector_Name => Make_Defining_Identifier (PN (P_Name)), Expression => N); Append_To (Aggregates, N); -- The conflicts N := Make_Component_Association (Selector_Name => Make_Defining_Identifier (PN (P_Conflicts)), Expression => RE (RE_Empty)); Append_To (Aggregates, N); -- Building the dependency list of the package. By default, -- all Helper packages have to be initialized after the Any -- type initialization. Set_Str_To_Name_Buffer ("any"); N := Make_Expression (Make_Literal (New_String_Value (Name_Find, False)), Op_Plus); -- Dependencies if not Is_Empty (Dependency_List) then Dep := First_Node (Dependency_List); while Present (Dep) loop N := Make_Expression (N, Op_And_Symbol, Dep); Dep := Next_Node (Dep); end loop; end if; N := Make_Component_Association (Selector_Name => Make_Defining_Identifier (PN (P_Depends)), Expression => N); Append_To (Aggregates, N); -- Provides N := Make_Component_Association (Selector_Name => Make_Defining_Identifier (PN (P_Provides)), Expression => RE (RE_Empty)); Append_To (Aggregates, N); -- Implicit N := Make_Component_Association (Selector_Name => Make_Defining_Identifier (PN (P_Implicit)), Expression => RE (RE_False)); Append_To (Aggregates, N); -- Init procedure N := Make_Component_Association (Selector_Name => Make_Defining_Identifier (PN (P_Init)), Expression => Make_Attribute_Reference (Make_Identifier (SN (S_Deferred_Initialization)), A_Access)); Append_To (Aggregates, N); -- Shutdown procedure N := Make_Component_Association (Selector_Name => Make_Defining_Identifier (PN (P_Shutdown)), Expression => Make_Null_Statement); Append_To (Aggregates, N); -- Registering the module N := Make_Qualified_Expression (Subtype_Mark => RE (RE_Module_Info), Operand => Make_Record_Aggregate (Aggregates)); N := Make_Subprogram_Call (RE (RE_Register_Module), New_List (N)); Append_To (Statements, N); -- Building the initialization block statement N := Make_Block_Statement (Declarative_Part => Declarative_Part, Statements => Statements); Append_To (L, N); end Helper_Initialization; ----------------- -- To_Any_Body -- ----------------- function To_Any_Body (E : Node_Id) return Node_Id is Spec : Node_Id; D : constant List_Id := New_List; S : constant List_Id := New_List; N : Node_Id; M : Node_Id; Helper_Name : Name_Id; function Complex_Declarator_Body (E : Node_Id) return Node_Id; function Enumeration_Type_Body (E : Node_Id) return Node_Id; function Forward_Interface_Declaration_Body (E : Node_Id) return Node_Id; function Interface_Declaration_Body (E : Node_Id) return Node_Id; function Simple_Declarator_Body (E : Node_Id) return Node_Id; function Structure_Type_Body (E : Node_Id) return Node_Id; function Union_Type_Body (E : Node_Id) return Node_Id; function Exception_Declaration_Body (E : Node_Id) return Node_Id; ----------------------------- -- Complex_Declarator_Body -- ----------------------------- function Complex_Declarator_Body (E : Node_Id) return Node_Id is I : Nat := 0; L : List_Id; Sizes : constant List_Id := Range_Constraints (Type_Definition (Type_Def_Node (BE_Node (Identifier (E))))); Dimension : constant Natural := BEU.Length (Sizes); Dim : Node_Id; Loop_Statements : List_Id := No_List; Enclosing_Statements : List_Id; Helper : Node_Id; TC : Node_Id; Result_Node : Node_Id; begin Spec := To_Any_Node (BE_Node (Identifier (E))); N := Declare_Any_Array (PN (P_Result), 0, Dimension - 1); Append_To (D, N); L := New_List; TC := TC_Node (BE_Node (Identifier (E))); Dim := First_Node (Sizes); loop Set_Str_To_Name_Buffer ("I"); Add_Nat_To_Name_Buffer (I); M := Make_Defining_Identifier (Add_Suffix_To_Name (Unique_Suffix, Name_Find)); Append_To (L, M); Enclosing_Statements := Loop_Statements; Loop_Statements := New_List; N := Make_For_Statement (M, Dim, Loop_Statements); if I > 0 then Result_Node := Nth_Element (PN (P_Result), I); Result_Node := Make_Assignment_Statement (Result_Node, Make_Subprogram_Call (RE (RE_Get_Empty_Any_Aggregate), New_List (Expand_Designator (TC)))); Append_To (Enclosing_Statements, Result_Node); Append_To (Enclosing_Statements, N); Result_Node := Make_Subprogram_Call (RE (RE_Add_Aggregate_Element), New_List (Nth_Element (PN (P_Result), I - 1), Nth_Element (PN (P_Result), I))); Append_To (Enclosing_Statements, Result_Node); else Result_Node := Nth_Element (PN (P_Result), I); Result_Node := Make_Assignment_Statement (Result_Node, Make_Subprogram_Call (RE (RE_Get_Empty_Any_Aggregate), New_List (Expand_Designator (TC)))); Append_To (S, Result_Node); Append_To (S, N); end if; I := I + 1; TC := Next_Node (TC); Dim := Next_Node (Dim); exit when No (Dim); end loop; Helper := Get_To_Any_Node (Type_Spec (Declaration (E))); N := Make_Indexed_Component (Make_Defining_Identifier (PN (P_Item)), L); N := Make_Subprogram_Call (Helper, New_List (N)); N := Make_Subprogram_Call (RE (RE_Add_Aggregate_Element), New_List (Nth_Element (PN (P_Result), I - 1), N)); Append_To (Loop_Statements, N); N := Make_Return_Statement (Nth_Element (PN (P_Result), 0)); Append_To (S, N); N := Make_Subprogram_Body (Spec, D, S); return N; end Complex_Declarator_Body; --------------------------- -- Enumeration_Type_Body -- --------------------------- function Enumeration_Type_Body (E : Node_Id) return Node_Id is begin Spec := To_Any_Node (BE_Node (Identifier (E))); N := RE (RE_Get_Empty_Any_Aggregate); Helper_Name := BEN.Name (Defining_Identifier (TC_Node (BE_Node (Identifier (E))))); N := Make_Subprogram_Call (N, New_List (Make_Defining_Identifier (Helper_Name))); N := Make_Object_Declaration (Defining_Identifier => Make_Defining_Identifier (PN (P_Result)), Object_Definition => RE (RE_Any), Expression => N); Append_To (D, N); N := Make_Subprogram_Call (Make_Attribute_Reference (Expand_Designator (Type_Def_Node (BE_Node (Identifier (E)))), A_Pos), New_List (Make_Defining_Identifier (PN (P_Item)))); N := Make_Type_Conversion (RE (RE_Unsigned_Long), N); N := Make_Subprogram_Call (RE (RE_To_Any_0), New_List (N)); N := Make_Subprogram_Call (RE (RE_Add_Aggregate_Element), New_List (Make_Defining_Identifier (PN (P_Result)), N)); Append_To (S, N); N := Make_Return_Statement (Make_Defining_Identifier (PN (P_Result))); Append_To (S, N); N := Make_Subprogram_Body (Spec, D, S); return N; end Enumeration_Type_Body; ---------------------------------------- -- Forward_Interface_Declaration_Body -- ---------------------------------------- function Forward_Interface_Declaration_Body (E : Node_Id) return Node_Id is begin Spec := To_Any_Node (BE_Node (Identifier (E))); N := Make_Type_Conversion (RE (RE_Ref_2), Make_Defining_Identifier (PN (P_Item))); N := Make_Subprogram_Call (RE (RE_To_Any_3), New_List (N)); N := Make_Return_Statement (N); Append_To (S, N); N := Make_Subprogram_Body (Spec, No_List, S); return N; end Forward_Interface_Declaration_Body; -------------------------------- -- Interface_Declaration_Body -- -------------------------------- function Interface_Declaration_Body (E : Node_Id) return Node_Id is begin Spec := TC_Node (BE_Node (Identifier (E))); -- Getting the identifier of the TC_"Interface_name" -- variable declared in the Helper spec. Helper_Name := BEN.Name (Defining_Identifier (Spec)); -- Getting the node of the To_Any method spec node Spec := To_Any_Node (BE_Node (Identifier (E))); N := Make_Type_Conversion (RE (RE_Ref_2), Make_Defining_Identifier (PN (P_Item))); N := Make_Object_Declaration (Defining_Identifier => Make_Defining_Identifier (PN (P_A)), Object_Definition => RE (RE_Any), Expression => Make_Subprogram_Call (RE (RE_To_Any_3), New_List (N))); Append_To (D, N); N := Make_Subprogram_Call (RE (RE_Set_Type), New_List (Make_Defining_Identifier (PN (P_A)), Make_Identifier (Helper_Name))); Append_To (S, N); N := Make_Return_Statement (Make_Defining_Identifier (PN (P_A))); Append_To (S, N); N := Make_Subprogram_Body (Spec, D, S); return N; end Interface_Declaration_Body; ---------------------------- -- Simple_Declarator_Body -- ---------------------------- function Simple_Declarator_Body (E : Node_Id) return Node_Id is begin Spec := To_Any_Node (BE_Node (Identifier (E))); -- Get the typespec of the type declaration of the -- simple declarator. N := Get_Type_Definition_Node (Type_Spec (Declaration (E))); -- Get the `To_Any' spec of the typespec of the type -- declaration of the simple declarator. M := Get_To_Any_Node (Type_Spec (Declaration (E))); Helper_Name := BEN.Name (Defining_Identifier (TC_Node (BE_Node (Identifier (E))))); N := Make_Type_Conversion (N, Make_Defining_Identifier (PN (P_Item))); N := Make_Object_Declaration (Defining_Identifier => Make_Defining_Identifier (PN (P_Result)), Object_Definition => RE (RE_Any), Expression => Make_Subprogram_Call (M, New_List (N))); Append_To (D, N); N := Make_Subprogram_Call (RE (RE_Set_Type), New_List (Make_Defining_Identifier (PN (P_Result)), Make_Defining_Identifier (Helper_Name))); Append_To (S, N); N := Make_Return_Statement (Make_Defining_Identifier (PN (P_Result))); Append_To (S, N); N := Make_Subprogram_Body (Spec, D, S); return N; end Simple_Declarator_Body; ------------------------- -- Structure_Type_Body -- ------------------------- function Structure_Type_Body (E : Node_Id) return Node_Id is Member : Node_Id; Declarator : Node_Id; Item_Designator : Node_Id; Designator : Node_Id; To_Any_Helper : Node_Id; begin Spec := To_Any_Node (BE_Node (Identifier (E))); N := RE (RE_Get_Empty_Any_Aggregate); Helper_Name := BEN.Name (Defining_Identifier (TC_Node (BE_Node (Identifier (E))))); N := Make_Subprogram_Call (N, New_List (Make_Defining_Identifier (Helper_Name))); Member := First_Entity (Members (E)); -- If the structure has no members, Result would never be -- modified and may be declared a constant. N := Make_Object_Declaration (Defining_Identifier => Make_Defining_Identifier (PN (P_Result)), Constant_Present => No (Member), Object_Definition => RE (RE_Any), Expression => N); Append_To (D, N); while Present (Member) loop Declarator := First_Entity (Declarators (Member)); Item_Designator := Make_Identifier (PN (P_Item)); while Present (Declarator) loop Designator := Make_Selected_Component (Item_Designator, Map_Expanded_Name (Declarator)); -- Get the declarator type in order to call the -- right To_Any function To_Any_Helper := Get_To_Any_Node (Type_Spec (Declaration (Declarator))); N := Make_Subprogram_Call (To_Any_Helper, New_List (Designator)); N := Make_Subprogram_Call (RE (RE_Add_Aggregate_Element), New_List (Make_Defining_Identifier (PN (P_Result)), N)); Append_To (S, N); Declarator := Next_Entity (Declarator); end loop; Member := Next_Entity (Member); end loop; N := Make_Return_Statement (Make_Defining_Identifier (PN (P_Result))); Append_To (S, N); N := Make_Subprogram_Body (Spec, D, S); return N; end Structure_Type_Body; --------------------- -- Union_Type_Body -- --------------------- function Union_Type_Body (E : Node_Id) return Node_Id is Switch_Item : Node_Id; Alternative_Name : Name_Id; Switch_Case : Node_Id; Switch_Alternatives : List_Id; Switch_Alternative : Node_Id; Switch_Statements : List_Id; Has_Default : Boolean := False; Choices : List_Id; To_Any_Helper : Node_Id; Literal_Parent : Node_Id := No_Node; Orig_Type : constant Node_Id := FEU.Get_Original_Type_Specifier (Switch_Type_Spec (E)); begin Spec := To_Any_Node (BE_Node (Identifier (E))); -- Declarative Part N := RE (RE_Get_Empty_Any_Aggregate); N := Make_Subprogram_Call (N, New_List (Expand_Designator (TC_Node (BE_Node (Identifier (E)))))); N := Make_Object_Declaration (Defining_Identifier => Make_Defining_Identifier (PN (P_Result)), Object_Definition => RE (RE_Any), Expression => N); Append_To (D, N); -- Statements -- Getting the "Item.Switch" name Switch_Item := Make_Selected_Component (PN (P_Item), CN (C_Switch)); -- Getting the To_Any function of the union Switch To_Any_Helper := Get_To_Any_Node (Switch_Type_Spec (E)); if FEN.Kind (Orig_Type) = K_Enumeration_Type then Literal_Parent := Map_Expanded_Name (Scope_Entity (Identifier (Orig_Type))); end if; N := Make_Subprogram_Call (To_Any_Helper, New_List (Switch_Item)); N := Make_Subprogram_Call (RE (RE_Add_Aggregate_Element), New_List (Make_Defining_Identifier (PN (P_Result)), N)); Append_To (S, N); Switch_Alternatives := New_List; Switch_Case := First_Entity (Switch_Type_Body (E)); while Present (Switch_Case) loop Switch_Statements := New_List; Map_Choice_List (Labels (Switch_Case), Literal_Parent, Choices, Has_Default); -- Getting the field full name Alternative_Name := BEU.To_Ada_Name (FEN.IDL_Name (Identifier (Declarator (Element (Switch_Case))))); Get_Name_String (PN (P_Item)); Add_Char_To_Name_Buffer ('.'); Get_Name_String_And_Append (Alternative_Name); Alternative_Name := Name_Find; -- Getting the To_Any function node corresponding to -- the element type. To_Any_Helper := Get_To_Any_Node (Type_Spec (Element (Switch_Case))); N := Make_Subprogram_Call (To_Any_Helper, New_List (Make_Defining_Identifier (Alternative_Name))); N := Make_Subprogram_Call (RE (RE_Add_Aggregate_Element), New_List (Make_Defining_Identifier (PN (P_Result)), N)); Append_To (Switch_Statements, N); Switch_Alternative := Make_Case_Statement_Alternative (Choices, Switch_Statements); Append_To (Switch_Alternatives, Switch_Alternative); Switch_Case := Next_Entity (Switch_Case); end loop; -- Add an empty when others clause to keep the compiler -- happy. if not Has_Default then Append_To (Switch_Alternatives, Make_Case_Statement_Alternative (No_List, No_List)); end if; N := Make_Case_Statement (Switch_Item, Switch_Alternatives); Append_To (S, N); N := Make_Return_Statement (Make_Defining_Identifier (PN (P_Result))); Append_To (S, N); N := Make_Subprogram_Body (Spec, D, S); return N; end Union_Type_Body; -------------------------------- -- Exception_Declaration_Body -- -------------------------------- function Exception_Declaration_Body (E : Node_Id) return Node_Id is Members : List_Id; Member : Node_Id; Declarator : Node_Id; Member_Type : Node_Id; To_Any_Helper : Node_Id; begin Spec := To_Any_Node (BE_Node (Identifier (E))); -- Declarations -- Get the node corresponding to the declaration of the -- TC_"Excp_Name" constant. N := TC_Node (BE_Node (Identifier (E))); N := Expand_Designator (N); N := Make_Subprogram_Call (RE (RE_Get_Empty_Any_Aggregate), New_List (N)); Members := FEN.Members (E); -- If the structure has no members, Result won't ever be modified -- and may be declared a constant. N := Make_Object_Declaration (Defining_Identifier => Make_Defining_Identifier (VN (V_Result)), Constant_Present => FEU.Is_Empty (Members), Object_Definition => RE (RE_Any), Expression => N); Append_To (D, N); -- Also add Unreferenced pragmas in that case, since the Item -- formal is never referenced if there are no members. if FEU.Is_Empty (Members) then N := Make_Pragma (Pragma_Warnings, New_List (RE (RE_Off))); Append_To (D, N); N := Make_Pragma (Pragma_Unreferenced, New_List (Make_Identifier (PN (P_Item)))); Append_To (D, N); N := Make_Pragma (Pragma_Warnings, New_List (RE (RE_On))); Append_To (D, N); else -- Statements Member := First_Entity (Members); while Present (Member) loop Declarator := First_Entity (Declarators (Member)); Member_Type := Type_Spec (Member); while Present (Declarator) loop To_Any_Helper := Get_To_Any_Node (Member_Type); N := Make_Selected_Component (PN (P_Item), To_Ada_Name (IDL_Name (FEN.Identifier (Declarator)))); N := Make_Subprogram_Call (To_Any_Helper, New_List (N)); N := Make_Subprogram_Call (RE (RE_Add_Aggregate_Element), New_List (Make_Defining_Identifier (VN (V_Result)), N)); Append_To (S, N); Declarator := Next_Entity (Declarator); end loop; Member := Next_Entity (Member); end loop; end if; N := Make_Return_Statement (Make_Identifier (VN (V_Result))); Append_To (S, N); N := Make_Subprogram_Body (Spec, D, S); return N; end Exception_Declaration_Body; begin case FEN.Kind (E) is when K_Complex_Declarator => N := Complex_Declarator_Body (E); when K_Enumeration_Type => N := Enumeration_Type_Body (E); when K_Forward_Interface_Declaration => N := Forward_Interface_Declaration_Body (E); when K_Interface_Declaration => N := Interface_Declaration_Body (E); when K_Simple_Declarator => N := Simple_Declarator_Body (E); when K_Structure_Type => N := Structure_Type_Body (E); when K_Union_Type => N := Union_Type_Body (E); when K_Exception_Declaration => N := Exception_Declaration_Body (E); when others => declare Msg : constant String := "Cannot not generate To_Any " & "body for a: " & FEN.Node_Kind'Image (Kind (E)); begin raise Program_Error with Msg; end; end case; return N; end To_Any_Body; ------------------- -- U_To_Ref_Body -- ------------------- function U_To_Ref_Body (E : Node_Id) return Node_Id is Spec : Node_Id; Declarations : List_Id; Statements : List_Id; Param : Node_Id; L : List_Id; S_Set_Node : Node_Id; begin -- The spec of the Unchecked_To_Ref function Spec := U_To_Ref_Node (BE_Node (Identifier (E))); -- Declarative Part Declarations := New_List; Param := Make_Object_Declaration (Defining_Identifier => Make_Defining_Identifier (PN (P_Result)), Object_Definition => Expand_Designator (Type_Def_Node (BE_Node (Identifier (E))))); Append_To (Declarations, Param); -- Statements Part S_Set_Node := Make_Defining_Identifier (SN (S_Set)); -- Depending on the nature of node E: -- * If E is an Interface declaration, we use the Set -- function inherited from CORBA.Object.Ref -- * If E is a forward Interface declaration, we use the Set -- function defined in the instantiated package. if FEN.Kind (E) = K_Forward_Interface_Declaration then S_Set_Node := Make_Selected_Component (Expand_Designator (Instantiation_Node (BE_Node (Identifier (E)))), S_Set_Node); end if; Statements := New_List; L := New_List; Append_To (L, Make_Defining_Identifier (PN (P_Result))); Append_To (L, Make_Subprogram_Call (RE (RE_Object_Of), New_List (Make_Defining_Identifier (PN (P_The_Ref))))); Append_To (Statements, Make_Subprogram_Call (Defining_Identifier => S_Set_Node, Actual_Parameter_Part => L)); Append_To (Statements, Make_Return_Statement (Make_Defining_Identifier (PN (P_Result)))); return Make_Subprogram_Body (Spec, Declarations, Statements); end U_To_Ref_Body; ----------------- -- To_Ref_Body -- ----------------- function To_Ref_Body (E : Node_Id) return Node_Id is Spec : Node_Id; Statements : List_Id; N : Node_Id; M : Node_Id; Rep_Id : Node_Id; begin -- The standard mandates type checking during narrowing -- (4.6.2 Narrowing Object References). -- -- Doing the check properly implies either -- 1. querying the interface repository (not implemented yet); -- or 2. calling Is_A (Repository_Id) on an object reference whose -- type maps the actual (i. e. most derived) interface of -- The_Ref (which is impossible if that type is not -- known on the partition where To_Ref is called); -- or 3. a remote invocation of an Is_A method of the designated -- object. -- -- The most general and correct solution to this problem is 3. When -- a remote call is not desired, the user should use -- Unchecked_To_Ref, whose purpose is precisely that. -- -- This solution is implemented as a dispatching call to Is_A on -- the source object reference. The remote Is_A operation will be -- invoked if necessary. -- The spec of the To_Ref function Spec := To_Ref_Node (BE_Node (Identifier (E))); -- The value of the Rep_Id depends on the nature of E node: -- * K_Interface_Declaration: we use the variable -- Repository_Id declared in the stub. -- * K_Forward_Interface_Declaration: we cannot use the -- Repository_Id variable because it designates another -- entity. So, we build a literal string value that -- designates the forwarded interface. if FEN.Kind (E) = K_Interface_Declaration then Rep_Id := Make_Defining_Identifier (PN (P_Repository_Id)); elsif FEN.Kind (E) = K_Forward_Interface_Declaration then Rep_Id := Make_Literal (Get_Value (BEN.Expression (Next_Node (Type_Def_Node (BE_Node (Identifier (Forward (E)))))))); else declare Msg : constant String := "Could not fetch the Repository_Id of a " & FEN.Node_Kind'Image (Kind (E)); begin raise Program_Error with Msg; end; end if; Statements := New_List; N := Make_Expression (Left_Expr => Make_Subprogram_Call (RE (RE_Is_Nil), New_List (Make_Defining_Identifier (PN (P_The_Ref)))), Operator => Op_Or_Else, Right_Expr => Make_Subprogram_Call (RE (RE_Is_A), New_List (Make_Defining_Identifier (PN (P_The_Ref)), Rep_Id))); M := Make_Subprogram_Call (Map_Narrowing_Designator (E, True), New_List (Make_Defining_Identifier (PN (P_The_Ref)))); M := Make_Return_Statement (M); N := Make_If_Statement (Condition => N, Then_Statements => New_List (M), Else_Statements => No_List); Append_To (Statements, N); N := Make_Subprogram_Call (RE (RE_Raise_Bad_Param), New_List (RE (RE_Default_Sys_Member))); Append_To (Statements, N); N := Make_Subprogram_Body (Spec, No_List, Statements); return N; end To_Ref_Body; --------------------- -- Raise_Excp_Body -- --------------------- function Raise_Excp_Body (E : Node_Id) return Node_Id is Spec : Node_Id; Statements : constant List_Id := New_List; N : Node_Id; begin -- The spec was declared at the forth position in the helper -- spec. Spec := Raise_Excp_Node (BE_Node (Identifier (E))); -- Statements N := Make_Defining_Identifier (To_Ada_Name (IDL_Name (FEN.Identifier (E)))); N := Make_Attribute_Reference (N, A_Identity); N := Make_Subprogram_Call (RE (RE_User_Raise_Exception), New_List (N, Make_Defining_Identifier (PN (P_Members)))); Append_To (Statements, N); N := Make_Subprogram_Body (Spec, No_List, Statements); return N; end Raise_Excp_Body; ----------- -- Visit -- ----------- procedure Visit (E : Node_Id) is begin case FEN.Kind (E) is when K_Enumeration_Type => Visit_Enumeration_Type (E); when K_Forward_Interface_Declaration => Visit_Forward_Interface_Declaration (E); when K_Interface_Declaration => Visit_Interface_Declaration (E); when K_Module => Visit_Module (E); when K_Specification => Visit_Specification (E); when K_Structure_Type => Visit_Structure_Type (E); when K_Type_Declaration => Visit_Type_Declaration (E); when K_Union_Type => Visit_Union_Type (E); when K_Exception_Declaration => Visit_Exception_Declaration (E); when others => null; end case; end Visit; ---------------------------- -- Visit_Enumeration_Type -- ---------------------------- procedure Visit_Enumeration_Type (E : Node_Id) is begin Set_Helper_Body; Append_To (Statements (Current_Package), From_Any_Body (E)); Append_To (Statements (Current_Package), To_Any_Body (E)); Append_To (Get_GList (Package_Declaration (Current_Package), GL_Deferred_Initialization), Deferred_Initialization_Block (E)); end Visit_Enumeration_Type; ----------------------------------------- -- Visit_Forward_Interface_Declaration -- ----------------------------------------- procedure Visit_Forward_Interface_Declaration (E : Node_Id) is Is_Local : constant Boolean := Is_Local_Interface (E); begin Set_Helper_Body; if not Is_Local then Append_To (Statements (Current_Package), From_Any_Body (E)); Append_To (Statements (Current_Package), To_Any_Body (E)); end if; Append_To (Statements (Current_Package), U_To_Ref_Body (E)); Append_To (Statements (Current_Package), To_Ref_Body (E)); Append_To (Get_GList (Package_Declaration (Current_Package), GL_Deferred_Initialization), Deferred_Initialization_Block (E)); end Visit_Forward_Interface_Declaration; --------------------------------- -- Visit_Interface_Declaration -- --------------------------------- procedure Visit_Interface_Declaration (E : Node_Id) is N : Node_Id; Is_Local : constant Boolean := Is_Local_Interface (E); DI_Statements : List_Id; begin N := BEN.Parent (Type_Def_Node (BE_Node (Identifier (E)))); Push_Entity (BEN.IDL_Unit (Package_Declaration (N))); Set_Helper_Body; -- Initialize Global lists Initialize_GList (Package_Declaration (Current_Package), GL_Deferred_Initialization); Initialize_GList (Package_Declaration (Current_Package), GL_Initialization_Block); Initialize_GList (Package_Declaration (Current_Package), GL_Dependencies); if not Is_Local then Append_To (Statements (Current_Package), From_Any_Body (E)); Append_To (Statements (Current_Package), To_Any_Body (E)); end if; Append_To (Statements (Current_Package), U_To_Ref_Body (E)); Append_To (Statements (Current_Package), To_Ref_Body (E)); Append_To (Get_GList (Package_Declaration (Current_Package), GL_Deferred_Initialization), Deferred_Initialization_Block (E)); N := First_Entity (Interface_Body (E)); while Present (N) loop Visit (N); N := Next_Entity (N); end loop; -- In case of multiple inheritance, generate the mappings -- for the operations and attributes of the parents except -- the first one. Map_Inherited_Entities_Bodies (Current_Interface => E, Visit_Operation_Subp => null, Helper => True); -- Get the statament list of the Deferred_Initialization procedure DI_Statements := Get_GList (Package_Declaration (Current_Package), GL_Deferred_Initialization); -- If the statement list of Deferred_Initialization is empty, then -- the Helper package is also empty. So, we do not create the -- Deferred_Initialization to keep the statament list of the Helper -- empty and avoid generating it at the source file creation phase. if not BEU.Is_Empty (DI_Statements) then N := Make_Subprogram_Body (Make_Subprogram_Specification (Make_Defining_Identifier (SN (S_Deferred_Initialization)), No_List), No_List, DI_Statements); Append_To (Statements (Current_Package), N); declare Package_Init_List : constant List_Id := Get_GList (Package_Declaration (Current_Package), GL_Initialization_Block); begin Helper_Initialization (Package_Init_List); Set_Package_Initialization (Current_Package, Package_Init_List); end; end if; Pop_Entity; end Visit_Interface_Declaration; ------------------ -- Visit_Module -- ------------------ procedure Visit_Module (E : Node_Id) is D : Node_Id; N : Node_Id; DI_Statements : List_Id; begin if not Map_Particular_CORBA_Parts (E, PK_Helper_Body) then D := Stub_Node (BE_Node (Identifier (E))); Push_Entity (D); Set_Helper_Body; -- Initialize Global lists Initialize_GList (Package_Declaration (Current_Package), GL_Deferred_Initialization); Initialize_GList (Package_Declaration (Current_Package), GL_Initialization_Block); Initialize_GList (Package_Declaration (Current_Package), GL_Dependencies); D := First_Entity (Definitions (E)); while Present (D) loop Visit (D); D := Next_Entity (D); end loop; -- Get the statament slit of the Deferred_Initialization -- procedure. DI_Statements := Get_GList (Package_Declaration (Current_Package), GL_Deferred_Initialization); -- If the statement list of Deferred_Initialization is -- empty, this means that the Helper package is also -- empty. So, we do not create the -- Deferred_Initialization to keep the statament list of -- the Helper empty and avoid generating it at the source -- file creation phase. -- If no statement have been added to the package before -- the deferred initialization subprogram, the body is -- kept empty and is not generated. if not BEU.Is_Empty (DI_Statements) then N := Make_Subprogram_Body (Make_Subprogram_Specification (Make_Defining_Identifier (SN (S_Deferred_Initialization)), No_List), No_List, DI_Statements); Append_To (Statements (Current_Package), N); declare Package_Init_List : constant List_Id := Get_GList (Package_Declaration (Current_Package), GL_Initialization_Block); begin Helper_Initialization (Package_Init_List); Set_Package_Initialization (Current_Package, Package_Init_List); end; end if; Pop_Entity; end if; end Visit_Module; ------------------------- -- Visit_Specification -- ------------------------- procedure Visit_Specification (E : Node_Id) is Definition : Node_Id; begin Push_Entity (Stub_Node (BE_Node (Identifier (E)))); Set_Helper_Spec; -- Initialize Global lists Initialize_GList (Package_Declaration (Current_Package), GL_Deferred_Initialization); Initialize_GList (Package_Declaration (Current_Package), GL_Initialization_Block); Initialize_GList (Package_Declaration (Current_Package), GL_Dependencies); Definition := First_Entity (Definitions (E)); while Present (Definition) loop Visit (Definition); Definition := Next_Entity (Definition); end loop; Pop_Entity; end Visit_Specification; -------------------------- -- Visit_Structure_Type -- -------------------------- procedure Visit_Structure_Type (E : Node_Id) is begin Set_Helper_Body; -- Do not generate the Any converters in case one of the -- component is a local interface or has a local interface -- component. if not FEU.Has_Local_Component (E) then Append_To (Statements (Current_Package), From_Any_Body (E)); Append_To (Statements (Current_Package), To_Any_Body (E)); end if; Append_To (Get_GList (Package_Declaration (Current_Package), GL_Deferred_Initialization), Deferred_Initialization_Block (E)); end Visit_Structure_Type; ---------------------------- -- Visit_Type_Declaration -- ---------------------------- procedure Visit_Type_Declaration (E : Node_Id) is L : List_Id; D : Node_Id; N : Node_Id; T : Node_Id; -- The three procedures below generate special code for -- fixed point types, sequence types and bounded [wide] -- string types. procedure Visit_Fixed_Type_Declaration (Type_Node : Node_Id); procedure Visit_Sequence_Type_Declaration (Type_Node : Node_Id); procedure Visit_String_Type_Declaration (Type_Node : Node_Id); ---------------------------------- -- Visit_Fixed_Type_Declaration -- ---------------------------------- procedure Visit_Fixed_Type_Declaration (Type_Node : Node_Id) is Package_Node : Node_Id; Spec_Node : Node_Id; Renamed_Subp : Node_Id; begin -- Getting the name of the package instantiation in the -- Internals package. Package_Node := Make_Selected_Component (Defining_Identifier (Internals_Package (Current_Entity)), Make_Defining_Identifier (Map_Fixed_Type_Helper_Name (Type_Node))); -- The From_Any and To_Any functions for the fixed point -- type are homonyms of those of the instantiated -- package. We just create a copy of the corresponding -- spec and we add a renaming field. -- From_Any Spec_Node := From_Any_Node (BE_Node (Type_Node)); -- The renamed subprogram Renamed_Subp := Make_Selected_Component (Package_Node, Make_Defining_Identifier (SN (S_From_Any))); N := Make_Subprogram_Specification (Defining_Identifier => Defining_Identifier (Spec_Node), Parameter_Profile => Parameter_Profile (Spec_Node), Return_Type => Return_Type (Spec_Node), Renamed_Subprogram => Renamed_Subp); Append_To (Statements (Current_Package), N); -- To_Any Spec_Node := To_Any_Node (BE_Node (Type_Node)); -- The renamed subprogram Renamed_Subp := Make_Selected_Component (Package_Node, Make_Defining_Identifier (SN (S_To_Any))); N := Make_Subprogram_Specification (Defining_Identifier => Defining_Identifier (Spec_Node), Parameter_Profile => Parameter_Profile (Spec_Node), Return_Type => Return_Type (Spec_Node), Renamed_Subprogram => Renamed_Subp); Append_To (Statements (Current_Package), N); -- Deferred initialization Append_To (Get_GList (Package_Declaration (Current_Package), GL_Deferred_Initialization), Deferred_Initialization_Block (Type_Node)); end Visit_Fixed_Type_Declaration; ------------------------------------- -- Visit_Sequence_Type_Declaration -- ------------------------------------- procedure Visit_Sequence_Type_Declaration (Type_Node : Node_Id) is Spec_Node : Node_Id; Package_Node : Node_Id; Renamed_Subp : Node_Id; begin -- Do not generate the Any converters in case one of the -- component is a local interface or has a local -- interface component because local references cannot be -- transferred through the network. if not FEU.Has_Local_Component (Type_Node) then -- Getting the name of the package instantiation in -- the Internals package. Package_Node := Make_Selected_Component (Defining_Identifier (Internals_Package (Current_Entity)), Make_Defining_Identifier (Map_Sequence_Pkg_Helper_Name (Type_Node))); -- The From_Any and To_Any functions for the fixed -- point type are homonyms of those of the -- instantiated package. We just create a copy of the -- corresponding spec and we add a renaming field. -- From_Any Spec_Node := From_Any_Node (BE_Node (Type_Node)); -- The renamed subprogram Renamed_Subp := Make_Selected_Component (Package_Node, Make_Defining_Identifier (SN (S_From_Any))); N := Make_Subprogram_Specification (Defining_Identifier => Defining_Identifier (Spec_Node), Parameter_Profile => Parameter_Profile (Spec_Node), Return_Type => Return_Type (Spec_Node), Renamed_Subprogram => Renamed_Subp); Append_To (Statements (Current_Package), N); -- To_Any Spec_Node := To_Any_Node (BE_Node (Type_Node)); -- The renamed subprogram Renamed_Subp := Make_Selected_Component (Package_Node, Make_Defining_Identifier (SN (S_To_Any))); N := Make_Subprogram_Specification (Defining_Identifier => Defining_Identifier (Spec_Node), Parameter_Profile => Parameter_Profile (Spec_Node), Return_Type => Return_Type (Spec_Node), Renamed_Subprogram => Renamed_Subp); Append_To (Statements (Current_Package), N); end if; -- Deferred Initialization Append_To (Get_GList (Package_Declaration (Current_Package), GL_Deferred_Initialization), Deferred_Initialization_Block (Type_Node)); end Visit_Sequence_Type_Declaration; ----------------------------------- -- Visit_String_Type_Declaration -- ----------------------------------- procedure Visit_String_Type_Declaration (Type_Node : Node_Id) is Spec_Node : Node_Id; Package_Node : Node_Id; Renamed_Subp : Node_Id; begin -- Getting the name of the package instantiation in the -- Stub spec. Package_Node := Expand_Designator (Instantiation_Node (BE_Node (Type_Node))); -- The From_Any and To_Any functions for the fixed point -- type are homonyms of those of the instantiated -- package. We just create a copy of the corresponding -- spec and we add a renaming field. -- From_Any Spec_Node := From_Any_Node (BE_Node (Type_Node)); -- The renamed subprogram Renamed_Subp := Make_Selected_Component (Package_Node, Make_Defining_Identifier (SN (S_From_Any))); N := Make_Subprogram_Specification (Defining_Identifier => Defining_Identifier (Spec_Node), Parameter_Profile => Parameter_Profile (Spec_Node), Return_Type => Return_Type (Spec_Node), Renamed_Subprogram => Renamed_Subp); Append_To (Statements (Current_Package), N); -- To_Any Spec_Node := To_Any_Node (BE_Node (Type_Node)); -- The renamed subprogram Renamed_Subp := Make_Selected_Component (Package_Node, Make_Defining_Identifier (SN (S_To_Any))); N := Make_Subprogram_Specification (Defining_Identifier => Defining_Identifier (Spec_Node), Parameter_Profile => Parameter_Profile (Spec_Node), Return_Type => Return_Type (Spec_Node), Renamed_Subprogram => Renamed_Subp); Append_To (Statements (Current_Package), N); -- Deferred Initialization Append_To (Get_GList (Package_Declaration (Current_Package), GL_Deferred_Initialization), Deferred_Initialization_Block (Type_Node)); end Visit_String_Type_Declaration; begin Set_Helper_Body; -- Handling the particular cases such as fixed point types -- definition and sequence types definitions T := Type_Spec (E); case (FEN.Kind (T)) is when K_Fixed_Point_Type => Visit_Fixed_Type_Declaration (T); when K_Sequence_Type => Visit_Sequence_Type_Declaration (T); when K_String_Type | K_Wide_String_Type => Visit_String_Type_Declaration (T); when others => null; end case; L := Declarators (E); D := First_Entity (L); while Present (D) loop -- If the new type is defined basing on an interface -- type, then we don't generate From_Any nor To_Any. We -- use those of the original type. If the type has a -- local interface componenet then we do not generate the -- Any converters because local references cannot be -- transferred through the network. if not ((Is_Object_Type (T) and then FEN.Kind (D) = K_Simple_Declarator) or else FEU.Has_Local_Component (T)) then Append_To (Statements (Current_Package), From_Any_Body (D)); Append_To (Statements (Current_Package), To_Any_Body (D)); end if; Append_To (Get_GList (Package_Declaration (Current_Package), GL_Deferred_Initialization), Deferred_Initialization_Block (D)); D := Next_Entity (D); end loop; end Visit_Type_Declaration; ---------------------- -- Visit_Union_Type -- ---------------------- procedure Visit_Union_Type (E : Node_Id) is begin Set_Helper_Body; -- Do not generate the Any converters in case one of the -- component is a local interface or has a local interface -- component because local references cannot be transferred -- through the network . if not FEU.Has_Local_Component (E) then Append_To (Statements (Current_Package), From_Any_Body (E)); Append_To (Statements (Current_Package), To_Any_Body (E)); end if; Append_To (Get_GList (Package_Declaration (Current_Package), GL_Deferred_Initialization), Deferred_Initialization_Block (E)); end Visit_Union_Type; --------------------------------- -- Visit_Exception_Declaration -- --------------------------------- procedure Visit_Exception_Declaration (E : Node_Id) is Subp_Body_Node : Node_Id; begin Set_Helper_Body; -- Do not generate the Any converters in case one of the -- component is a local interface or has a local interface -- component because local references cannot be transferred -- through the network. if not FEU.Has_Local_Component (E) then Subp_Body_Node := From_Any_Body (E); Append_To (Statements (Current_Package), Subp_Body_Node); Subp_Body_Node := To_Any_Body (E); Append_To (Statements (Current_Package), Subp_Body_Node); end if; -- Generation of the Raise_"Exception_Name" body Subp_Body_Node := Raise_Excp_Body (E); Append_To (Statements (Current_Package), Subp_Body_Node); -- Generation of the corresponding instructions in the -- Deferred_initialisation procedure. Append_To (Get_GList (Package_Declaration (Current_Package), GL_Deferred_Initialization), Deferred_Initialization_Block (E)); end Visit_Exception_Declaration; end Package_Body; end Backend.BE_CORBA_Ada.Helpers; polyorb-2.8~20110207.orig/compilers/iac/backend-be_corba_ada-impls.ads0000644000175000017500000000437211750740337024710 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- B A C K E N D . B E _ C O R B A _ A D A . I M P L S -- -- -- -- S p e c -- -- -- -- Copyright (C) 2005-2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ package Backend.BE_CORBA_Ada.Impls is package Package_Spec is procedure Visit (E : Node_Id); end Package_Spec; package Package_Body is procedure Visit (E : Node_Id); end Package_Body; end Backend.BE_CORBA_Ada.Impls; polyorb-2.8~20110207.orig/compilers/iac/backend-be_idl.ads0000644000175000017500000000446311750740337022444 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- B A C K E N D . B E _ I D L -- -- -- -- S p e c -- -- -- -- Copyright (C) 2005-2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ package Backend.BE_IDL is procedure Generate (E : Node_Id); procedure Usage (Indent : Natural); Default_Base : Natural := 0; Print_IDL_Tree : Boolean := False; Expand_Tree : Boolean := False; Generate_Imported : Boolean := False; end Backend.BE_IDL; polyorb-2.8~20110207.orig/compilers/iac/analyzer.ads0000644000175000017500000000414711750740337021465 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- A N A L Y Z E R -- -- -- -- S p e c -- -- -- -- Copyright (C) 2005-2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with Types; use Types; package Analyzer is procedure Analyze (E : Node_Id); end Analyzer; polyorb-2.8~20110207.orig/compilers/iac/backend-be_corba_ada-generator.adb0000644000175000017500000020310111750740337025520 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- B A C K E N D . B E _ C O R B A _ A D A . G E N E R A T O R -- -- -- -- B o d y -- -- -- -- Copyright (C) 2005-2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with GNAT.OS_Lib; use GNAT.OS_Lib; with Backend.BE_CORBA_Ada; use Backend.BE_CORBA_Ada; with Backend.BE_CORBA_Ada.Nodes; use Backend.BE_CORBA_Ada.Nodes; with Backend.BE_CORBA_Ada.Nutils; use Backend.BE_CORBA_Ada.Nutils; with Backend.BE_CORBA_Ada.Runtime; use Backend.BE_CORBA_Ada.Runtime; with Charset; use Charset; with Namet; use Namet; with Output; use Output; with Outfiles; use Outfiles; with Values; use Values; package body Backend.BE_CORBA_Ada.Generator is procedure Generate_Access_Type_Definition (N : Node_Id); procedure Generate_Ada_Comment (N : Node_Id); procedure Generate_Array_Aggregate (N : Node_Id); procedure Generate_Array_Type_Definition (N : Node_Id); procedure Generate_String_Type_Definition (N : Node_Id); procedure Generate_Assignment_Statement (N : Node_Id); procedure Generate_Attribute_Reference (N : Node_Id); procedure Generate_Block_Statement (N : Node_Id); procedure Generate_Case_Statement (N : Node_Id); procedure Generate_Case_Statement_Alternative (N : Node_Id); procedure Generate_Component_Association (N : Node_Id); procedure Generate_Component_Declaration (N : Node_Id); procedure Generate_Decimal_Type_Definition (N : Node_Id); procedure Generate_Derived_Type_Definition (N : Node_Id); procedure Generate_Elsif_Statement (N : Node_Id); procedure Generate_Element_Association (N : Node_Id); procedure Generate_Enumeration_Type_Definition (N : Node_Id); procedure Generate_Exception_Declaration (N : Node_Id); procedure Generate_Explicit_Dereference (N : Node_Id); procedure Generate_Expression (N : Node_Id); procedure Generate_For_Statement (N : Node_Id); procedure Generate_Full_Type_Declaration (N : Node_Id); procedure Generate_Identifier (N : Node_Id); procedure Generate_IDL_Unit_Packages (N : Node_Id); procedure Generate_If_Statement (N : Node_Id); procedure Generate_Indexed_Component (N : Node_Id); procedure Generate_Instantiated_Subprogram (N : Node_Id); procedure Generate_Literal (N : Node_Id); procedure Generate_Null_Statement; procedure Generate_Object_Declaration (N : Node_Id); procedure Generate_Object_Instantiation (N : Node_Id); procedure Generate_Package_Declaration (N : Node_Id); procedure Generate_Package_Body (N : Node_Id); procedure Generate_Package_Instantiation (N : Node_Id); procedure Generate_Package_Specification (N : Node_Id); procedure Generate_Parameter (N : Node_Id); procedure Generate_Parameter_Association (N : Node_Id); procedure Generate_Parameter_List (L : List_Id); procedure Generate_Pragma (N : Node_Id); procedure Generate_Qualified_Expression (N : Node_Id); procedure Generate_Raise_Statement (N : Node_Id); procedure Generate_Range (N : Node_Id); procedure Generate_Record_Aggregate (N : Node_Id); procedure Generate_Record_Definition (N : Node_Id); procedure Generate_Record_Type_Definition (N : Node_Id); procedure Generate_Return_Statement (N : Node_Id); procedure Generate_Selected_Component (N : Node_Id); procedure Generate_Slice (N : Node_Id); procedure Generate_Subprogram_Call (N : Node_Id); procedure Generate_Subprogram_Body (N : Node_Id); procedure Generate_Subprogram_Specification (N : Node_Id); procedure Generate_Type_Conversion (N : Node_Id); procedure Generate_Used_Type (N : Node_Id); procedure Generate_Used_Package (N : Node_Id); procedure Generate_Variant_Part (N : Node_Id); procedure Generate_Withed_Package (N : Node_Id); procedure Write (T : Token_Type); procedure Write_Line (T : Token_Type); procedure Generate_Statement_Delimiter (N : Node_Id); procedure Generate_Comment_Box (M : Name_Id); -- The entities declared below are related to the package -- generation in different files function Get_File_Name (N : Node_Id) return Name_Id; -- Generate an Ada file name from the package node given as -- parameter function Needs_Begin_End (B : Node_Id) return Boolean; -- Return True if the statement block B needs to be surrounded by -- begin..end. ------------------- -- Get_File_Name -- ------------------- function Get_File_Name (N : Node_Id) return Name_Id is pragma Assert (Kind (N) = K_Package_Specification or else Kind (N) = K_Package_Body); Package_Spec_Suffix : constant String := ".ads"; Package_Body_Suffix : constant String := ".adb"; begin -- The File name corresponding to a package is the lowered filly -- qualified name of the package. All '.' separators are -- replaced by '-'. Get_Name_String (Fully_Qualified_Name (Defining_Identifier (Package_Declaration (N)))); -- Lower and replace all '.' by '-' for Index in 1 .. Name_Len loop if Name_Buffer (Index) = '.' then Name_Buffer (Index) := '-'; else Name_Buffer (Index) := To_Lower (Name_Buffer (Index)); end if; end loop; -- Adding file suffix if Kind (N) = K_Package_Specification then Add_Str_To_Name_Buffer (Package_Spec_Suffix); else Add_Str_To_Name_Buffer (Package_Body_Suffix); end if; return Name_Find; end Get_File_Name; --------------------- -- Needs_Begin_End -- --------------------- function Needs_Begin_End (B : Node_Id) return Boolean is begin pragma Assert (Kind (B) = K_Block_Statement); return not (Is_Empty (Declarative_Part (B)) and then Is_Empty (Exception_Handler (B))); end Needs_Begin_End; -------------- -- Generate -- -------------- procedure Generate (N : Node_Id) is begin case Kind (N) is when K_Access_Type_Definition => Generate_Access_Type_Definition (N); when K_Ada_Comment => Generate_Ada_Comment (N); when K_Array_Aggregate => Generate_Array_Aggregate (N); when K_Array_Type_Definition => Generate_Array_Type_Definition (N); when K_String_Type_Definition => Generate_String_Type_Definition (N); when K_Assignment_Statement => Generate_Assignment_Statement (N); when K_Attribute_Reference => Generate_Attribute_Reference (N); when K_Block_Statement => Generate_Block_Statement (N); when K_Case_Statement => Generate_Case_Statement (N); when K_Case_Statement_Alternative => Generate_Case_Statement_Alternative (N); when K_Component_Association => Generate_Component_Association (N); when K_Component_Declaration => Generate_Component_Declaration (N); when K_Decimal_Type_Definition => Generate_Decimal_Type_Definition (N); when K_Defining_Identifier => Generate_Identifier (N); when K_Derived_Type_Definition => Generate_Derived_Type_Definition (N); when K_Element_Association => Generate_Element_Association (N); when K_Elsif_Statement => Generate_Elsif_Statement (N); when K_Enumeration_Type_Definition => Generate_Enumeration_Type_Definition (N); when K_Exception_Declaration => Generate_Exception_Declaration (N); when K_Explicit_Dereference => Generate_Explicit_Dereference (N); when K_Expression => Generate_Expression (N); when K_For_Statement => Generate_For_Statement (N); when K_Full_Type_Declaration => Generate_Full_Type_Declaration (N); when K_Identifier => Generate_Identifier (N); when K_IDL_Unit => Generate_IDL_Unit_Packages (N); when K_If_Statement => Generate_If_Statement (N); when K_Indexed_Component => Generate_Indexed_Component (N); when K_Instantiated_Subprogram => Generate_Instantiated_Subprogram (N); when K_Literal => Generate_Literal (N); when K_Null_Statement => Generate_Null_Statement; when K_Object_Declaration => Generate_Object_Declaration (N); when K_Object_Instantiation => Generate_Object_Instantiation (N); when K_Package_Declaration => Generate_Package_Declaration (N); when K_Package_Body => Generate_Package_Body (N); when K_Package_Instantiation => Generate_Package_Instantiation (N); when K_Package_Specification => Generate_Package_Specification (N); when K_Parameter_Association => Generate_Parameter_Association (N); when K_Pragma => Generate_Pragma (N); when K_Qualified_Expression => Generate_Qualified_Expression (N); when K_Raise_Statement => Generate_Raise_Statement (N); when K_Range => Generate_Range (N); when K_Record_Aggregate => Generate_Record_Aggregate (N); when K_Record_Definition => Generate_Record_Definition (N); when K_Record_Type_Definition => Generate_Record_Type_Definition (N); when K_Return_Statement => Generate_Return_Statement (N); when K_Selected_Component => Generate_Selected_Component (N); when K_Slice => Generate_Slice (N); when K_Subprogram_Call => Generate_Subprogram_Call (N); when K_Subprogram_Specification => Generate_Subprogram_Specification (N); when K_Subprogram_Body => Generate_Subprogram_Body (N); when K_Type_Conversion => Generate_Type_Conversion (N); when K_Used_Type => Generate_Used_Type (N); when K_Used_Package => Generate_Used_Package (N); when K_Variant_Part => Generate_Variant_Part (N); when K_Withed_Package => Generate_Withed_Package (N); when K_Float .. K_Octet => Write_Name (Image (Base_Type (N))); when others => raise Program_Error with "no code generation defined for " & Kind (N)'Img; end case; end Generate; ------------------------------------- -- Generate_Access_Type_Definition -- ------------------------------------- procedure Generate_Access_Type_Definition (N : Node_Id) is begin if Is_Not_Null (N) then Write (Tok_Not); Write_Space; Write (Tok_Null); Write_Space; end if; Write (Tok_Access); Write_Space; if Is_All (N) then Write (Tok_All); Write_Space; end if; if Is_Constant (N) then Write (Tok_Constant); Write_Space; end if; Generate (Subtype_Indication (N)); end Generate_Access_Type_Definition; -------------------------- -- Generate_Ada_Comment -- -------------------------- procedure Generate_Ada_Comment (N : Node_Id) is -- This procedure does the following : -- * It generates an Ada comment basing on the name of node N -- * If the name it too long, and depending on the location of -- the comment in the source code, the procedure splits the -- comment into more than a line. -- The comment is assumed to be a sequence of characters, -- beginning and ending with a NON-SPACE character. -- A word is a space character, or else a sequence of non space -- characters located between two spaces. Max_Line_Length : constant Natural := 78; -- The maximum length of a line, in columns function Buffer_Empty return Boolean; -- True when the Name_Buffer is empty function Next_Word_Length return Natural; -- Length of next word to be retrieved, or 0 if buffer is empty function Get_Next_Word return String; -- Extract the next word from the buffer ------------------ -- Buffer_Empty -- ------------------ function Buffer_Empty return Boolean is begin return Name_Len = 0; end Buffer_Empty; ---------------------- -- Next_Word_Length -- ---------------------- function Next_Word_Length return Natural is L : Natural; begin if Buffer_Empty then L := 0; elsif Name_Buffer (1) = ' ' then L := 1; else L := 0; while L + 1 <= Name_Len and then Name_Buffer (L + 1) /= ' ' loop L := L + 1; end loop; end if; return L; end Next_Word_Length; ------------------- -- Get_Next_Word -- ------------------- function Get_Next_Word return String is L : constant Natural := Next_Word_Length; begin if L = 0 then return ""; else declare Next_Word : constant String := Name_Buffer (1 .. L); begin if Name_Len = L then Name_Len := 0; else Set_Str_To_Name_Buffer (Name_Buffer (L + 1 .. Name_Len)); end if; return Next_Word; end; end if; end Get_Next_Word; First_Line : Boolean := True; Used_Columns : Natural; begin Get_Name_String (Message (N)); while not Buffer_Empty loop Used_Columns := N_Space; if First_Line then First_Line := False; else Write_Indentation; end if; -- We consume 4 clumsy Used_Columns := Used_Columns + 2; Write_Str ("--"); if Has_Header_Spaces (N) then Used_Columns := Used_Columns + 2; Write_Str (" "); end if; Used_Columns := Used_Columns + Next_Word_Length; Write_Str (Get_Next_Word); while not Buffer_Empty and then (Used_Columns + Next_Word_Length < Max_Line_Length) loop Used_Columns := Used_Columns + Next_Word_Length; Write_Str (Get_Next_Word); end loop; if not Buffer_Empty then Write_Eol; end if; end loop; end Generate_Ada_Comment; ------------------------------ -- Generate_Array_Aggregate -- ------------------------------ procedure Generate_Array_Aggregate (N : Node_Id) is E : Node_Id; begin Write (Tok_Left_Paren); E := First_Node (Elements (N)); loop Generate (E); E := Next_Node (E); exit when No (E); Write (Tok_Comma); Write_Space; end loop; Write (Tok_Right_Paren); end Generate_Array_Aggregate; ------------------------------------ -- Generate_Array_Type_Definition -- ------------------------------------ procedure Generate_Array_Type_Definition (N : Node_Id) is R : Node_Id; begin Write (Tok_Array); Write_Space; Write (Tok_Left_Paren); if Present (Index_Definition (N)) then Generate (Index_Definition (N)); Write_Space; Write (Tok_Range); Write_Space; Write (Tok_Less); Write (Tok_Greater); else R := First_Node (Range_Constraints (N)); loop Generate (First (R)); Write_Space; Write (Tok_Dot); Write (Tok_Dot); Write_Space; Generate (Last (R)); R := Next_Node (R); exit when No (R); Write (Tok_Comma); Write_Space; end loop; end if; Write (Tok_Right_Paren); Write_Space; Write (Tok_Of); Write_Space; Generate (Component_Definition (N)); end Generate_Array_Type_Definition; ------------------------------------- -- Generate_String_Type_Definition -- ------------------------------------- procedure Generate_String_Type_Definition (N : Node_Id) is R : Node_Id; begin Generate (Defining_Identifier (N)); Write_Space; Write (Tok_Left_Paren); R := Range_Constraint (N); Generate (First (R)); Write_Space; Write (Tok_Dot); Write (Tok_Dot); Write_Space; Generate (Last (R)); Write (Tok_Right_Paren); end Generate_String_Type_Definition; ----------------------------------- -- Generate_Assignment_Statement -- ----------------------------------- procedure Generate_Assignment_Statement (N : Node_Id) is begin Generate (Defining_Identifier (N)); Write_Space; Write (Tok_Colon_Equal); Write_Eol; Increment_Indentation; Write_Indentation (-1); Generate (Expression (N)); Decrement_Indentation; end Generate_Assignment_Statement; ---------------------------------- -- Generate_Attribute_Reference -- ---------------------------------- procedure Generate_Attribute_Reference (N : Node_Id) is begin Generate (Prefix (N)); Write (Tok_Apostrophe); Write_Name (Name (N)); end Generate_Attribute_Reference; ------------------------------ -- Generate_Block_Statement -- ------------------------------ procedure Generate_Block_Statement (N : Node_Id) is D : Node_Id; N_Begin_End : Boolean renames Needs_Begin_End (N); begin if Present (Defining_Identifier (N)) then Write_Eol; Decrement_Indentation; Write_Indentation (-1); Increment_Indentation; Generate (Defining_Identifier (N)); Write_Line (Tok_Colon); Write_Indentation; end if; if not Is_Empty (Declarative_Part (N)) then Write (Tok_Declare); Write_Eol; Increment_Indentation; D := First_Node (Declarative_Part (N)); loop Write_Indentation; Generate (D); Generate_Statement_Delimiter (D); D := Next_Node (D); exit when No (D); end loop; Decrement_Indentation; Write_Indentation; end if; if N_Begin_End then Write (Tok_Begin); Write_Eol; Increment_Indentation; Write_Indentation; end if; D := First_Node (Statements (N)); loop Generate (D); Generate_Statement_Delimiter (D); D := Next_Node (D); exit when No (D); Write_Indentation; end loop; if N_Begin_End then Decrement_Indentation; Write_Indentation; end if; if not Is_Empty (Exception_Handler (N)) then declare Excp_Handler_Alternative : Node_Id; begin Write (Tok_Exception); Write_Eol; Increment_Indentation; -- Generation of the exception handler Excp_Handler_Alternative := First_Node (Exception_Handler (N)); while Present (Excp_Handler_Alternative) loop Generate (Excp_Handler_Alternative); Excp_Handler_Alternative := Next_Node (Excp_Handler_Alternative); end loop; Decrement_Indentation; Write_Indentation; end; end if; if N_Begin_End then Write (Tok_End); end if; end Generate_Block_Statement; ----------------------------- -- Generate_Case_Statement -- ----------------------------- procedure Generate_Case_Statement (N : Node_Id) is D : Node_Id; O : Node_Id := No_Node; -- To ensure the `when others' is generated at the end of the -- `case' statement. begin Write (Tok_Case); Write_Space; Generate (Expression (N)); Write_Space; Write_Line (Tok_Is); D := First_Node (Case_Statement_Alternatives (N)); Increment_Indentation; while Present (D) loop if Is_Empty (Discret_Choice_List (D)) then -- Postpone the generation of the `when others' to the -- end of the case statement. O := D; else Generate (D); end if; D := Next_Node (D); end loop; -- Generate the `when others' clause if Present (O) then Generate (O); end if; Decrement_Indentation; Write_Eol; Write_Indentation; Write (Tok_End); Write_Space; Write (Tok_Case); end Generate_Case_Statement; ----------------------------------------- -- Generate_Case_Statement_Alternative -- ----------------------------------------- procedure Generate_Case_Statement_Alternative (N : Node_Id) is M : Node_Id; P : Node_Id; begin -- For an OTHERS choice, generate a pragma Warnings (Off), because -- all choices might be covered by the explicit alternatives. if Is_Empty (Discret_Choice_List (N)) then Write_Indentation; P := Make_Pragma (Pragma_Warnings, New_List (RE (RE_Off))); Generate (P); Generate_Statement_Delimiter (P); end if; -- Generate the choices Write_Indentation; Write (Tok_When); Write_Space; if Is_Empty (Discret_Choice_List (N)) then Write (Tok_Others); else M := First_Node (Discret_Choice_List (N)); loop Generate (M); M := Next_Node (M); exit when No (M); Write_Space; Write (Tok_Vertical_Bar); Write_Space; end loop; end if; Write_Space; Write_Line (Tok_Arrow); -- Generate the statements Increment_Indentation; if Is_Empty (Statements (N)) then Write_Indentation; Write (Tok_Null); Write_Line (Tok_Semicolon); else M := First_Node (Statements (N)); while Present (M) loop Write_Indentation; Generate (M); Generate_Statement_Delimiter (M); M := Next_Node (M); end loop; end if; Decrement_Indentation; -- Re-enable warnings if Is_Empty (Discret_Choice_List (N)) then Write_Indentation; P := Make_Pragma (Pragma_Warnings, New_List (RE (RE_On))); Generate (P); Generate_Statement_Delimiter (P); end if; end Generate_Case_Statement_Alternative; ------------------------------------ -- Generate_Component_Association -- ------------------------------------ procedure Generate_Component_Association (N : Node_Id) is begin -- If the developer gives a defining identifier, we generate -- it, else we assume that the developer wants to generate a -- "others => XXXX" statement. if Present (Defining_Identifier (N)) then Generate (Defining_Identifier (N)); else Write (Tok_Others); end if; Write_Space; Write (Tok_Arrow); Write_Space; Generate (Expression (N)); end Generate_Component_Association; ------------------------------------ -- Generate_Component_Declaration -- ------------------------------------ procedure Generate_Component_Declaration (N : Node_Id) is E : constant Node_Id := Expression (N); begin Generate (Defining_Identifier (N)); Write_Space; Write (Tok_Colon); Write_Space; if Aliased_Present (N) then Write (Tok_Aliased); Write_Space; end if; Generate (Subtype_Indication (N)); if Present (E) then Write_Space; Write (Tok_Colon_Equal); Write_Space; Generate (E); end if; end Generate_Component_Declaration; -------------------------------------- -- Generate_Decimal_Type_Definition -- -------------------------------------- procedure Generate_Decimal_Type_Definition (N : Node_Id) is begin Write (Tok_Delta); Write_Space; Generate (Scale (N)); Write_Space; Write (Tok_Digits); Write_Space; Write_Str (Values.Image_Ada (Total (N))); end Generate_Decimal_Type_Definition; -------------------------------------- -- Generate_Derived_Type_Definition -- -------------------------------------- procedure Generate_Derived_Type_Definition (N : Node_Id) is R : Node_Id; begin if Is_Abstract_Type (N) then Write (Tok_Abstract); Write_Space; end if; if not Is_Subtype (N) then Write (Tok_New); Write_Space; end if; Generate (Subtype_Indication (N)); if Is_Private_Extension (N) then Write_Space; Write (Tok_With); Write_Space; Write (Tok_Private); else R := Record_Extension_Part (N); if Present (R) then Write_Space; Write (Tok_With); Write_Space; Generate (Record_Extension_Part (N)); end if; end if; end Generate_Derived_Type_Definition; ---------------------------------- -- Generate_Element_Association -- ---------------------------------- procedure Generate_Element_Association (N : Node_Id) is begin if Present (Index (N)) then Generate (Index (N)); else Write (Tok_Others); end if; Write_Space; Write (Tok_Arrow); Write_Space; Generate (Expression (N)); end Generate_Element_Association; ------------------------------ -- Generate_Elsif_Statement -- ------------------------------ procedure Generate_Elsif_Statement (N : Node_Id) is D : Node_Id; begin Write (Tok_Elsif); Write_Space; Generate (Condition (N)); Write_Eol; Write_Indentation; Write_Line (Tok_Then); Increment_Indentation; D := First_Node (Then_Statements (N)); while Present (D) loop Write_Indentation; Generate (D); Generate_Statement_Delimiter (D); D := Next_Node (D); end loop; Decrement_Indentation; end Generate_Elsif_Statement; ------------------------------------------ -- Generate_Enumeration_Type_Definition -- ------------------------------------------ procedure Generate_Enumeration_Type_Definition (N : Node_Id) is E : Node_Id; begin Write (Tok_Left_Paren); E := First_Node (Enumeration_Literals (N)); loop Generate (E); E := Next_Node (E); exit when No (E); Write_Line (Tok_Comma); Write_Indentation; end loop; Write (Tok_Right_Paren); end Generate_Enumeration_Type_Definition; ------------------------------------ -- Generate_Exception_Declaration -- ------------------------------------ procedure Generate_Exception_Declaration (N : Node_Id) is begin Write_Name (Name (Defining_Identifier (N))); Write_Space; Write (Tok_Colon); Write_Space; Write (Tok_Exception); if Present (Renamed_Entity (N)) then Write_Eol; Increment_Indentation; Write_Indentation (-1); Write (Tok_Renames); Write_Space; Generate (Renamed_Entity (N)); Decrement_Indentation; end if; end Generate_Exception_Declaration; ----------------------------------- -- Generate_Explicit_Dereference -- ----------------------------------- procedure Generate_Explicit_Dereference (N : Node_Id) is begin Generate (Prefix (N)); Write (Tok_Dot); Write (Tok_All); end Generate_Explicit_Dereference; ------------------------- -- Generate_Expression -- ------------------------- procedure Generate_Expression (N : Node_Id) is L_Expr : constant Node_Id := Left_Expr (N); Op : constant Operator_Id := Operator (N); R_Expr : constant Node_Id := Right_Expr (N); begin -- Each expression having a right part and a left part is -- systematically put between two parentheses. if No (R_Expr) then if Op = Operator_Type'Pos (Op_Not) then Write (Tok_Not); Write_Space; elsif Op /= Operator_Type'Pos (Op_None) then Write_Name (Operator_Image (Standard.Integer (Op))); -- Do not generate space after a unary operator end if; else -- Expressions having "|" as operator (case switches -- alternatives) and expressions having "&" as operator -- (array concatenation) do not require parentheses. if Op /= Operator_Type'Pos (Op_Vertical_Bar) and then Op /= Operator_Type'Pos (Op_And_Symbol) then Write (Tok_Left_Paren); end if; end if; Generate (L_Expr); if Present (R_Expr) then Write_Eol; Increment_Indentation; Write_Indentation; Write_Name (Operator_Image (Standard.Integer (Op))); Write_Space; Generate (R_Expr); if Op /= Operator_Type'Pos (Op_Vertical_Bar) and then Op /= Operator_Type'Pos (Op_And_Symbol) then Write (Tok_Right_Paren); end if; Decrement_Indentation; end if; end Generate_Expression; ---------------------------- -- Generate_For_Statement -- ---------------------------- procedure Generate_For_Statement (N : Node_Id) is D : Node_Id := First_Node (Statements (N)); begin Write (Tok_For); Write_Space; Write_Name (Name (Defining_Identifier (N))); Write_Space; Write (Tok_In); Write_Space; Generate (First (Range_Constraint (N))); Write_Space; Write (Tok_Dot); Write (Tok_Dot); Write_Space; Generate (Last (Range_Constraint (N))); Write_Space; Write (Tok_Loop); Write_Eol; Increment_Indentation; while Present (D) loop Write_Indentation; Generate (D); Generate_Statement_Delimiter (D); D := Next_Node (D); end loop; Decrement_Indentation; Write_Indentation; Write (Tok_End); Write_Space; Write (Tok_Loop); end Generate_For_Statement; ------------------------------------ -- Generate_Full_Type_Declaration -- ------------------------------------ procedure Generate_Full_Type_Declaration (N : Node_Id) is D : constant List_Id := Discriminant_Spec (N); M : Node_Id; begin if Is_Subtype (N) then Write (Tok_Subtype); else Write (Tok_Type); end if; Write_Space; Write_Name (Name (Defining_Identifier (N))); if not Is_Empty (D) then M := First_Node (D); Write_Eol; Increment_Indentation; Write_Indentation (-1); Write (Tok_Left_Paren); while Present (M) loop Generate (M); if Present (Next_Node (M)) then Generate_Statement_Delimiter (M); Write_Space; end if; M := Next_Node (M); end loop; Write (Tok_Right_Paren); Decrement_Indentation; Write_Eol; Write_Indentation; else Write_Space; end if; Write (Tok_Is); Write_Eol; Increment_Indentation; Write_Indentation (-1); Generate (Type_Definition (N)); Decrement_Indentation; end Generate_Full_Type_Declaration; ------------------------- -- Generate_Identifier -- ------------------------- procedure Generate_Identifier (N : Node_Id) is begin Write_Name (Name (N)); end Generate_Identifier; -------------------------------- -- Generate_IDL_Unit_Packages -- -------------------------------- procedure Generate_IDL_Unit_Packages (N : Node_Id) is P : Node_Id := First_Node (Packages (N)); begin if not Generate_Imported and then not Generate_Code (N) then return; end if; while Present (P) loop Generate (P); P := Next_Node (P); end loop; end Generate_IDL_Unit_Packages; --------------------------- -- Generate_If_Statement -- --------------------------- procedure Generate_If_Statement (N : Node_Id) is T : constant List_Id := Then_Statements (N); E : constant List_Id := Else_Statements (N); I : Node_Id; begin -- Enter If_Statement Write (Tok_If); Write_Space; Generate (Condition (N)); Write_Eol; Write_Indentation; Write (Tok_Then); Write_Eol; -- If_Statement cannot be empty. A null statement is always -- there if needed. Increment_Indentation; I := First_Node (T); while Present (I) loop Write_Indentation; Generate (I); Generate_Statement_Delimiter (I); I := Next_Node (I); end loop; Decrement_Indentation; -- Elsif_Statements if not Is_Empty (Elsif_Statements (N)) then I := First_Node (Elsif_Statements (N)); loop Write_Indentation; Generate (I); I := Next_Node (I); exit when No (I); end loop; end if; -- Else_Statement can be empty if not Is_Empty (E) then Write_Indentation; Write (Tok_Else); Write_Eol; Increment_Indentation; I := First_Node (E); while Present (I) loop Write_Indentation; Generate (I); Generate_Statement_Delimiter (I); I := Next_Node (I); end loop; Decrement_Indentation; end if; -- Leave If_Statement Write_Indentation; Write (Tok_End); Write_Space; Write (Tok_If); end Generate_If_Statement; -------------------------------- -- Generate_Indexed_Component -- -------------------------------- procedure Generate_Indexed_Component (N : Node_Id) is Exp : constant List_Id := Expressions (N); E : Node_Id; begin Generate (Prefix (N)); pragma Assert (not Is_Empty (Exp)); Write_Eol; Increment_Indentation; Write_Indentation (-1); Write (Tok_Left_Paren); E := First_Node (Exp); loop Generate (E); E := Next_Node (E); exit when No (E); Write_Line (Tok_Comma); Write_Indentation; end loop; Write (Tok_Right_Paren); Decrement_Indentation; end Generate_Indexed_Component; -------------------------------------- -- Generate_Instantiated_Subprogram -- -------------------------------------- procedure Generate_Instantiated_Subprogram (N : Node_Id) is L : constant List_Id := Parameter_List (N); P : Node_Id; begin Generate (Defining_Identifier (N)); if not Is_Empty (L) then Write_Eol; Increment_Indentation; Write_Indentation (-1); Write (Tok_Left_Paren); P := First_Node (L); loop Generate (P); P := Next_Node (P); exit when No (P); Write_Line (Tok_Comma); Write_Indentation; end loop; Write (Tok_Right_Paren); Decrement_Indentation; end if; end Generate_Instantiated_Subprogram; ---------------------- -- Generate_Literal -- ---------------------- procedure Generate_Literal (N : Node_Id) is begin Write_Str (Values.Image_Ada (Value (N))); end Generate_Literal; ----------------------------- -- Generate_Null_Statement -- ----------------------------- procedure Generate_Null_Statement is begin Write (Tok_Null); end Generate_Null_Statement; --------------------------------- -- Generate_Object_Declaration -- --------------------------------- procedure Generate_Object_Declaration (N : Node_Id) is begin Name_Buffer (1 .. Var_Name_Len) := (others => ' '); Get_Name_String (Name (Defining_Identifier (N))); if Var_Name_Len > Name_Len then Name_Len := Var_Name_Len; end if; Write_Str (Name_Buffer (1 .. Name_Len)); Write_Space; Write (Tok_Colon); if Constant_Present (N) then Write_Space; Write (Tok_Constant); end if; if Aliased_Present (N) then Write_Space; Write (Tok_Aliased); end if; Write_Space; if Present (Object_Definition (N)) then Generate (Object_Definition (N)); else -- This workaround doesn't affect the classic object -- declaration because we must give a type. However it makes -- the generation of case statement and exception handlers -- simpler. Write (Tok_Others); end if; if Present (Renamed_Entity (N)) then Write_Eol; Increment_Indentation; Write_Indentation (-1); Write (Tok_Renames); Write_Space; Generate (Renamed_Entity (N)); Decrement_Indentation; -- If an object renames another object, it cannot be -- initialized, else if Present (Expression (N)) then Write_Space; Write (Tok_Colon_Equal); Write_Eol; Increment_Indentation; Write_Indentation (-1); Generate (Expression (N)); Decrement_Indentation; end if; end if; end Generate_Object_Declaration; ----------------------------------- -- Generate_Object_Instantiation -- ----------------------------------- procedure Generate_Object_Instantiation (N : Node_Id) is begin Write (Tok_New); Write_Space; Generate (Qualified_Expression (N)); end Generate_Object_Instantiation; --------------------------- -- Generate_Package_Body -- --------------------------- procedure Generate_Package_Body (N : Node_Id) is P : Node_Id; Fd : File_Descriptor; Dcl : constant Node_Id := Package_Declaration (N); IDLU : constant Node_Id := IDL_Unit (Dcl); Impl : constant Boolean := Dcl = Implementation_Package (IDLU); begin -- If the user wants to generates only the spec, or if the -- package body is empty, we don't generate it. -- For Helper's packages, they always contain the package -- implementation of their corresponding 'Internals' -- sub-package. We do not generate a file for these Helper's if -- they contain only the 'Internals' package body and if this -- body is empty. if Disable_Pkg_Body_Gen or else (Is_Empty (Statements (N)) and then not Impl) or else (Length (Statements (N)) = 1 and then Kind (First_Node (Statements (N))) = K_Package_Body and then Is_Empty (Statements (First_Node (Statements (N))))) then return; end if; if not Is_Subunit_Package (Package_Specification (Package_Declaration (N))) then Fd := Set_Output (Get_File_Name (N)); P := First_Node (Context_Clause (N)); while Present (P) loop Write_Indentation; Generate (P); Generate_Statement_Delimiter (P); P := Next_Node (P); end loop; else if Fd = Invalid_FD then return; end if; end if; Write_Eol; Write_Indentation; Write (Tok_Package); Write_Space; Write (Tok_Body); Write_Space; if Kind (N) = K_Package_Body and then Is_Subunit_Package (Package_Specification (Package_Declaration (N))) then Write_Name (Get_Name (Get_Base_Identifier (Package_Declaration (N)))); else Generate (Defining_Identifier (Package_Declaration (N))); end if; Write_Space; Write (Tok_Is); Write_Eol (2); Increment_Indentation; P := First_Node (Statements (N)); while Present (P) loop Write_Indentation; Generate (P); if not (Kind (P) = K_Package_Body and then Is_Subunit_Package (Package_Specification (Package_Declaration (P)))) then Generate_Statement_Delimiter (P); end if; Write_Eol; P := Next_Node (P); end loop; Decrement_Indentation; Write_Indentation; if not Is_Empty (Package_Initialization (N)) then Write_Line (Tok_Begin); Increment_Indentation; P := First_Node (Package_Initialization (N)); loop Write_Indentation; Generate (P); Generate_Statement_Delimiter (P); P := Next_Node (P); exit when No (P); end loop; Decrement_Indentation; Write_Indentation; end if; Write (Tok_End); Write_Space; if Kind (N) = K_Package_Body and then Is_Subunit_Package (Package_Specification (Package_Declaration (N))) then Write_Name (Get_Name (Get_Base_Identifier (Package_Declaration (N)))); else Generate (Defining_Identifier (Package_Declaration (N))); end if; Generate_Statement_Delimiter (Defining_Identifier (Package_Declaration (N))); if not Is_Subunit_Package (Package_Specification (Package_Declaration (N))) then Release_Output (Fd); Fd := Invalid_FD; end if; end Generate_Package_Body; ---------------------------------- -- Generate_Package_Declaration -- ---------------------------------- procedure Generate_Package_Declaration (N : Node_Id) is begin Generate (Package_Specification (N)); Generate (Package_Body (N)); end Generate_Package_Declaration; ------------------------------------ -- Generate_Package_Instantiation -- ------------------------------------ procedure Generate_Package_Instantiation (N : Node_Id) is Param : Node_Id; begin Write (Tok_Package); Write_Space; Write_Name (Name (Defining_Identifier (N))); Write_Space; Write (Tok_Is); Write_Eol; Increment_Indentation; Write_Indentation (-1); Write (Tok_New); Write_Space; Generate (Generic_Package (N)); if not Is_Empty (Parameter_List (N)) then Write_Eol; Increment_Indentation; Write_Indentation (-1); Write (Tok_Left_Paren); Param := First_Node (Parameter_List (N)); loop Generate (Param); Param := Next_Node (Param); exit when No (Param); Write_Line (Tok_Comma); Write_Indentation; end loop; Write (Tok_Right_Paren); Decrement_Indentation; end if; Decrement_Indentation; end Generate_Package_Instantiation; ------------------------------------ -- Generate_Package_Specification -- ------------------------------------ procedure Generate_Package_Specification (N : Node_Id) is P : Node_Id; Fd : File_Descriptor; begin -- If the user wants to generates only the body, or if the -- package spec is empty, we don't generate it. if Disable_Pkg_Spec_Gen or else (Is_Empty (Visible_Part (N)) and then Is_Empty (Private_Part (N))) then return; end if; if not Is_Subunit_Package (N) then Fd := Set_Output (Get_File_Name (N)); P := First_Node (Context_Clause (N)); while Present (P) loop Write_Indentation; Generate (P); Generate_Statement_Delimiter (P); P := Next_Node (P); end loop; else if Fd = Invalid_FD then return; end if; end if; Write_Eol; Write_Indentation; Write (Tok_Package); Write_Space; if Is_Subunit_Package (N) then Write_Name (Get_Name (Get_Base_Identifier (Package_Declaration (N)))); else Generate (Defining_Identifier (Package_Declaration (N))); end if; Write_Space; Write (Tok_Is); Write_Eol (2); Increment_Indentation; P := First_Node (Visible_Part (N)); while Present (P) loop Write_Indentation; Generate (P); Generate_Statement_Delimiter (P); Write_Eol; P := Next_Node (P); end loop; P := First_Node (Subunits (N)); while Present (P) loop Write_Indentation; Generate (P); if not (Kind (P) = K_Package_Specification and then Is_Subunit_Package (P)) then Generate_Statement_Delimiter (P); end if; Write_Eol; P := Next_Node (P); end loop; Decrement_Indentation; if not Is_Empty (Private_Part (N)) then Write_Indentation; Write (Tok_Private); Write_Eol; Increment_Indentation; P := First_Node (Private_Part (N)); while Present (P) loop Write_Indentation; Generate (P); Generate_Statement_Delimiter (P); Write_Eol; P := Next_Node (P); end loop; Decrement_Indentation; end if; Write_Indentation; Write (Tok_End); Write_Space; if Is_Subunit_Package (N) then Write_Name (Get_Name (Get_Base_Identifier (Package_Declaration (N)))); else Generate (Defining_Identifier (Package_Declaration (N))); end if; Generate_Statement_Delimiter (Defining_Identifier (Package_Declaration (N))); if not Is_Subunit_Package (N) then Release_Output (Fd); Fd := Invalid_FD; end if; end Generate_Package_Specification; ------------------------ -- Generate_Parameter -- ------------------------ procedure Generate_Parameter (N : Node_Id) is begin Name_Buffer (1 .. Var_Name_Len) := (others => ' '); Get_Name_String (Name (Defining_Identifier (N))); if Var_Name_Len > Name_Len then Name_Len := Var_Name_Len; end if; Write_Str (Name_Buffer (1 .. Name_Len)); Write_Space; Write (Tok_Colon); if Kind (Parameter_Type (N)) /= K_Access_Type_Definition then case Parameter_Mode (N) is when Mode_In => null; when Mode_Out => Write_Space; Write (Tok_Out); when Mode_Inout => Write_Space; Write (Tok_In); Write_Space; Write (Tok_Out); end case; end if; Write_Space; Generate (Parameter_Type (N)); if Present (Expression (N)) then Write_Space; Write (Tok_Colon_Equal); Write_Space; Generate (Expression (N)); end if; end Generate_Parameter; ------------------------------------ -- Generate_Parameter_Association -- ------------------------------------ procedure Generate_Parameter_Association (N : Node_Id) is begin Generate (Selector_Name (N)); Write_Space; Write (Tok_Arrow); Write_Space; Generate (Actual_Parameter (N)); end Generate_Parameter_Association; ----------------------------- -- Generate_Parameter_List -- ----------------------------- procedure Generate_Parameter_List (L : List_Id) is N : Node_Id; begin -- If we got there, then L is not empty. Increment_Indentation; Write_Indentation (-1); Write (Tok_Left_Paren); N := First_Node (L); loop Generate_Parameter (N); exit when No (Next_Node (N)); Generate_Statement_Delimiter (N); Write_Indentation; N := Next_Node (N); end loop; Write (Tok_Right_Paren); Decrement_Indentation; end Generate_Parameter_List; --------------------- -- Generate_Pragma -- --------------------- procedure Generate_Pragma (N : Node_Id) is Args : constant List_Id := Nodes.Argument_List (N); Arg : Node_Id; begin Write (Tok_Pragma); Write_Space; Generate (Defining_Identifier (N)); if not Is_Empty (Args) then Write_Space; Write (Tok_Left_Paren); Arg := First_Node (Args); loop Generate (Arg); Arg := Next_Node (Arg); exit when No (Arg); Write (Tok_Comma); Write_Space; end loop; Write (Tok_Right_Paren); end if; end Generate_Pragma; ----------------------------------- -- Generate_Qualified_Expression -- ----------------------------------- procedure Generate_Qualified_Expression (N : Node_Id) is begin Generate (Subtype_Mark (N)); Write_Line (Tok_Apostrophe); Increment_Indentation; Write_Indentation (-1); -- We generate parentheses only in case the Operand is not an -- aggregate if Kind (Operand (N)) = K_Record_Aggregate or else Kind (Operand (N)) = K_Array_Aggregate then Generate (Operand (N)); else Write (Tok_Left_Paren); Generate (Operand (N)); Write (Tok_Right_Paren); end if; Decrement_Indentation; end Generate_Qualified_Expression; ------------------------------ -- Generate_Raise_Statement -- ------------------------------ procedure Generate_Raise_Statement (N : Node_Id) is E : constant Node_Id := Raised_Error (N); begin Write (Tok_Raise); if Present (E) then Write_Space; Generate (E); end if; end Generate_Raise_Statement; -------------------- -- Generate_Range -- -------------------- procedure Generate_Range (N : Node_Id) is begin Generate (Low_Bound (N)); Write_Str (" .. "); Generate (High_Bound (N)); end Generate_Range; ------------------------------- -- Generate_Record_Aggregate -- ------------------------------- procedure Generate_Record_Aggregate (N : Node_Id) is L : List_Id; M : Node_Id; begin L := Component_Association_List (N); Write (Tok_Left_Paren); if Present (Ancestor_Part (N)) then Generate (Ancestor_Part (N)); Write_Space; Write (Tok_With); Write_Eol; Write_Indentation; end if; if not Is_Empty (L) then M := First_Node (L); loop Generate (M); M := Next_Node (M); exit when No (M); Write_Line (Tok_Comma); Write_Indentation; end loop; else Write (Tok_Null); Write_Space; Write (Tok_Record); end if; Write (Tok_Right_Paren); end Generate_Record_Aggregate; -------------------------------- -- Generate_Record_Definition -- -------------------------------- procedure Generate_Record_Definition (N : Node_Id) is L : constant List_Id := Component_List (N); C : Node_Id; begin if Is_Empty (L) then Write (Tok_Null); Write_Space; Write (Tok_Record); else Write (Tok_Record); Write_Eol; Increment_Indentation; C := First_Node (L); while Present (C) loop Write_Indentation; Generate (C); Generate_Statement_Delimiter (C); C := Next_Node (C); end loop; Decrement_Indentation; Write_Indentation; Write (Tok_End); Write_Space; Write (Tok_Record); end if; end Generate_Record_Definition; ------------------------------------- -- Generate_Record_Type_Definition -- ------------------------------------- procedure Generate_Record_Type_Definition (N : Node_Id) is R : Node_Id; begin if Is_Abstract_Type (N) then Write (Tok_Abstract); Write_Space; end if; if Is_Tagged_Type (N) then Write (Tok_Tagged); Write_Space; end if; if Is_Limited_Type (N) then Write (Tok_Limited); Write_Space; end if; R := Record_Definition (N); if Present (R) then Generate (R); end if; end Generate_Record_Type_Definition; ------------------------------- -- Generate_Return_Statement -- ------------------------------- procedure Generate_Return_Statement (N : Node_Id) is E : constant Node_Id := Expression (N); begin Write (Tok_Return); if Present (E) then Write_Space; Generate (E); end if; end Generate_Return_Statement; --------------------------------- -- Generate_Selected_Component -- --------------------------------- procedure Generate_Selected_Component (N : Node_Id) is begin Generate (Prefix (N)); Write (Tok_Dot); Generate (Selector_Name (N)); end Generate_Selected_Component; -------------------- -- Generate_Slice -- -------------------- procedure Generate_Slice (N : Node_Id) is begin Generate (Prefix (N)); Write_Space; Write (Tok_Left_Paren); Generate (Discrete_Range (N)); Write (Tok_Right_Paren); end Generate_Slice; ------------------------------ -- Generate_Subprogram_Call -- ------------------------------ procedure Generate_Subprogram_Call (N : Node_Id) is L : constant List_Id := Actual_Parameter_Part (N); P : Node_Id; begin Generate (Defining_Identifier (N)); if not Is_Empty (L) then Write_Eol; Increment_Indentation; Write_Indentation (-1); Write (Tok_Left_Paren); P := First_Node (L); loop Generate (P); P := Next_Node (P); exit when No (P); Write_Line (Tok_Comma); Write_Indentation; end loop; Write (Tok_Right_Paren); Decrement_Indentation; end if; end Generate_Subprogram_Call; ------------------------------ -- Generate_Subprogram_Body -- ------------------------------ procedure Generate_Subprogram_Body (N : Node_Id) is D : constant List_Id := Declarations (N); S : constant List_Id := Statements (N); P : constant Node_Id := Specification (N); M : Node_Id; begin Generate_Comment_Box (Name (Defining_Identifier (P))); Write_Eol; Write_Indentation; Generate (P); if not Is_Empty (Parameter_Profile (P)) then Write_Eol; Write_Indentation; else Write_Space; end if; Write (Tok_Is); Write_Eol; if not Is_Empty (D) then Increment_Indentation; M := First_Node (D); while Present (M) loop Write_Indentation; Generate (M); Generate_Statement_Delimiter (M); -- If this is a nested subprogram spec or body, or the next thing -- is one of those, leave an extra blank line. if Kind (M) = K_Subprogram_Specification or else Kind (M) = K_Subprogram_Body then Write_Eol; elsif Present (Next_Node (M)) and then (Kind (Next_Node (M)) = K_Subprogram_Specification or else Kind (Next_Node (M)) = K_Subprogram_Body) then Write_Eol; end if; M := Next_Node (M); end loop; Decrement_Indentation; end if; Write_Indentation; Write (Tok_Begin); Write_Eol; Increment_Indentation; if not Is_Empty (S) then M := First_Node (S); while Present (M) loop Write_Indentation; Generate (M); Generate_Statement_Delimiter (M); M := Next_Node (M); end loop; else Write_Indentation; Write (Tok_Null); Write_Line (Tok_Semicolon); end if; Decrement_Indentation; Write_Indentation; Write (Tok_End); Write_Space; Write_Name (Name (Defining_Identifier (P))); end Generate_Subprogram_Body; --------------------------------------- -- Generate_Subprogram_Specification -- --------------------------------------- procedure Generate_Subprogram_Specification (N : Node_Id) is P : constant List_Id := Parameter_Profile (N); T : constant Node_Id := Return_Type (N); R : constant Node_Id := Renamed_Entity (N); I : constant Node_Id := Instantiated_Subprogram (N); begin if Present (T) then Write (Tok_Function); else Write (Tok_Procedure); end if; -- This work around is used to define access subprogram types if Present (Defining_Identifier (N)) then Write_Space; Write_Name (Name (Defining_Identifier (N))); end if; if not Is_Empty (P) then Write_Eol; Generate_Parameter_List (P); end if; -- Note that for an instance of a generic function, we set the return -- type in order to generate the proper FUNCTION keyword, but we never -- actually output the type. if Present (T) and then No (I) then if not Is_Empty (P) then Write_Eol; Increment_Indentation; Write_Indentation (-1); else Write_Space; end if; Write (Tok_Return); Write_Space; Generate (T); if not Is_Empty (P) then Decrement_Indentation; end if; end if; if Present (R) then Write_Eol; Increment_Indentation; Write_Indentation (-1); Write (Tok_Renames); Write_Space; Generate (R); Decrement_Indentation; end if; if Present (I) then Write_Eol; Increment_Indentation; Write_Indentation (-1); Write (Tok_Is); Write_Space; Write (Tok_New); Write_Space; Generate (I); Decrement_Indentation; end if; end Generate_Subprogram_Specification; ------------------------------ -- Generate_Type_Conversion -- ------------------------------ procedure Generate_Type_Conversion (N : Node_Id) is begin Generate (Subtype_Mark (N)); Write_Eol; Increment_Indentation; Write_Indentation (-1); Write (Tok_Left_Paren); Generate (Expression (N)); Write (Tok_Right_Paren); Decrement_Indentation; end Generate_Type_Conversion; ------------------------ -- Generate_Used_Type -- ------------------------ procedure Generate_Used_Type (N : Node_Id) is begin Write (Tok_Use); Write_Space; Write (Tok_Type); Write_Space; Generate (The_Used_Entity (N)); end Generate_Used_Type; procedure Generate_Used_Package (N : Node_Id) is begin Write (Tok_Use); Write_Space; Generate (The_Used_Entity (N)); end Generate_Used_Package; --------------------------- -- Generate_Variant_Part -- --------------------------- procedure Generate_Variant_Part (N : Node_Id) is V : Node_Id; C : Node_Id; O : Node_Id := No_Node; P : Node_Id; begin Write (Tok_Case); Write_Space; Generate (Discriminant (N)); Write_Space; Write (Tok_Is); Write_Eol; V := First_Node (Variants (N)); Increment_Indentation; while Present (V) loop C := First_Node (Discrete_Choices (V)); if (Kind (C) = K_Literal and then Value (C) /= No_Value) or else Kind (C) /= K_Literal then -- If we have a valued or a casted (for alignment) literal Write_Indentation; Write (Tok_When); Write_Space; Increment_Indentation; loop Generate (C); C := Next_Node (C); if No (C) then Write_Space; Write (Tok_Arrow); Write_Eol; exit; end if; Write_Eol; Write_Indentation (-1); Write (Tok_Vertical_Bar); Write_Space; end loop; Write_Indentation; Generate (Component (V)); Generate_Statement_Delimiter (Component (V)); Decrement_Indentation; else -- An empty switch O := V; end if; V := Next_Node (V); end loop; -- Add a "when others" clause either based on the "default" -- label or a null one. In case of null statement, add two -- pragmas to disable warnings and enable them after the -- addition of the null statement if No (O) then Write_Indentation; P := Make_Pragma (Pragma_Warnings, New_List (RE (RE_Off))); Generate (P); Generate_Statement_Delimiter (P); end if; Write_Indentation; Write (Tok_When); Write_Space; Write (Tok_Others); Write_Space; Write (Tok_Arrow); Write_Eol; Increment_Indentation; Write_Indentation; if Present (O) then Generate (Component (O)); Generate_Statement_Delimiter (Component (O)); else Write (Tok_Null); Generate_Statement_Delimiter (O); end if; Decrement_Indentation; if No (O) then Write_Indentation; P := Make_Pragma (Pragma_Warnings, New_List (RE (RE_On))); Generate (P); Generate_Statement_Delimiter (P); end if; Decrement_Indentation; Write_Indentation; Write (Tok_End); Write_Space; Write (Tok_Case); end Generate_Variant_Part; ----------------------------- -- Generate_Withed_Package -- ----------------------------- procedure Generate_Withed_Package (N : Node_Id) is procedure Add_Pragma (Pragma_Name : String); -- Add a pragma with the given name applying to the WITH'd unit ---------------- -- Add_Pragma -- ---------------- procedure Add_Pragma (Pragma_Name : String) is begin Write (Tok_Semicolon); Write_Eol; Write_Indentation; Write (Tok_Pragma); Write_Space; Write_Str (Pragma_Name); Write_Space; Write (Tok_Left_Paren); Generate (Defining_Identifier (N)); Write (Tok_Right_Paren); end Add_Pragma; begin Write (Tok_With); Write_Space; Generate (Defining_Identifier (N)); if Used (N) then Write (Tok_Semicolon); Write_Eol; Write_Indentation; Write (Tok_Use); Write_Space; Generate (Defining_Identifier (N)); end if; if Elaborated (N) then Add_Pragma ("Elaborate_All"); end if; if Unreferenced (N) then Add_Pragma ("Unreferenced"); end if; end Generate_Withed_Package; ----------- -- Write -- ----------- procedure Write (T : Token_Type) is begin Write_Name (Token_Image (T)); end Write; ---------------- -- Write_Line -- ---------------- procedure Write_Line (T : Token_Type) is begin Write (T); Write_Eol; end Write_Line; ---------------------------------- -- Generate_Statement_Delimiter -- ---------------------------------- procedure Generate_Statement_Delimiter (N : Node_Id) is begin if No (N) or else (Kind (N) = K_Block_Statement and then Needs_Begin_End (N)) or else (Kind (N) /= K_Block_Statement and then Kind (N) /= K_Ada_Comment) then Write_Line (Tok_Semicolon); else Write_Eol; end if; end Generate_Statement_Delimiter; -------------------------- -- Generate_Comment_Box -- -------------------------- procedure Generate_Comment_Box (M : Name_Id) is begin Get_Name_String (M); for I in 1 .. Name_Len + 6 loop Write_Char ('-'); end loop; Write_Eol; Write_Indentation; Write_Str ("-- "); Write_Name (M); Write_Str (" --"); Write_Eol; Write_Indentation; for I in 1 .. Name_Len + 6 loop Write_Char ('-'); end loop; Write_Eol; end Generate_Comment_Box; end Backend.BE_CORBA_Ada.Generator; polyorb-2.8~20110207.orig/compilers/iac/lexer.adb0000644000175000017500000016721211750740337020741 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- L E X E R -- -- -- -- B o d y -- -- -- -- Copyright (C) 2005-2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with GNAT.Command_Line; use GNAT.Command_Line; with Charset; use Charset; with Errors; use Errors; with Flags; use Flags; with Namet; use Namet; with Output; use Output; with Utils; use Utils; with Platform; with GNAT.Table; package body Lexer is use ASCII; Buffer : Text_Buffer_Ptr; -- Once preprocessed, the idl file is loaded in Buffer and -- Token_Location.Scan is used to scan the source file. --------------------- -- Temporary Files -- --------------------- -- We all the temporary file names in order to delete them when needed package TMP_File_Table is new GNAT.Table (Table_Component_Type => Name_Id, Table_Index_Type => Natural, Table_Low_Bound => 1, Table_Initial => 10, Table_Increment => 100); CPP_Tmp_File : Name_Id := No_Name; ------------------- -- Handled Files -- ------------------- package Handled_Files_Table is new GNAT.Table (Table_Component_Type => Name_Id, Table_Index_Type => Natural, Table_Low_Bound => 1, Table_Initial => 10, Table_Increment => 100); ----------------- -- Lexer State -- ----------------- type Lexer_State is record Loc : Location; Preprocessed_File_Name : Name_Id; end record; package Lexer_State_Stack is new GNAT.Table (Table_Component_Type => Lexer_State, Table_Index_Type => Natural, Table_Low_Bound => 1, Table_Initial => 10, Table_Increment => 100); -- During the parsing of a file, we may encounter instructions that -- require the parsing of another file to be handled. The goal of this -- stack is to save the information concerning the current file to be able -- to continue its parsing later. Initialized : Boolean := False; procedure Skip_Identifier; -- Skip a sequence of identifier characters as the current -- identifier or literal is not well-formed. function Quoted_Image (T : Token_Type) return String; -- Return an image of token T. Keywords are output between double -- quotes and characters between single quotes. procedure Scan_Preprocessor_Directive; -- Once a '#' character has been detected, scan past that character and -- process the remaining of the directive. -- It can be either a #pragma directive (in which case a T_Pragma token -- is generated) or a line directive. -- The latter case is handled internally to update Token_Location. procedure Scan_Chars_Literal_Value (Literal : Token_Type; Fatal : Boolean; Adjacent : Boolean := True); -- -- Char Literals : (3.2.5.2) -- A character literal is one or more characters enclosed in -- single quotes, as in 'x'. Non graphic characters must be -- represented using escape sequences as defined in Table -- 3-9. (escape sequences are \n, \t, \v, \b, \r, \f, \a, \\, \?, -- \', \", \ooo, \xhh and \uhhhh) -- -- The escape \ooo consists of the backslash followed by one, two -- or three octal digits that are taken to specify the value of -- the desired character. The escape \xhh consists of the -- backslash followed by x followed by one or two hexadecimal -- digits that are taken to specify the value of the desired -- character. -- -- The escape \uhhhh consist of a backslash followed by the -- character 'u', followed by one, two, three or four hexadecimal -- digits. -- -- String Literals : (3.2.5.1) -- A string literal is a sequence of characters (...) surrounded -- by double quotes, as in "...". -- -- Adjacent string literals are concatenated. (...) Within a -- string, the double quote character " must be preceded by a \. -- A string literal may not contain the character '\0'. -- -- Wide is used to say if the scanner should scan a wide string or -- not. If not and a character looks like '/u...' then an error is -- raised procedure Scan_Numeric_Literal_Value (Fatal : Boolean); -- -- Integers Literals : (3.2.5.1) -- An integer literal consisting of a sequence of digits is taken -- to be decimal (base ten), unless it begins with 0 (digit zero). -- A sequence of digits starting with 0 is taken to be an octal -- integer (base eight). The digits 8 and 9 are not octal digits. -- A sequence of digits preceded by 0x or 0X is taken to be a -- hexadecimal integer (base sixteen). The hexadecimal digits -- include a or A through f or F with decimal values ten to -- through fifteen, respectively. For example, the number twelve -- can be written 12, 014 or 0XC -- -- Floating-point literals : (3.2.5.3) -- A floating-point literal consists of an integer part, a decimal -- point, a fraction part, an e or E, and an optionally signed -- integer exponent. The integer and fraction parts both consists -- of a sequence of decimal (base ten) digits. Either the integer -- part or the fraction part (but not both may be missing; either -- the decimal point or the letter e (or E) and the exponent (but -- not both) may be missing. -- -- Fixed-point literals : (3.2.5.5) -- A fixed-point decimal literal consists of an integer part, a -- decimal point, a fraction part and a d or D. The integer and -- fraction part both consist of a sequence of decimal (base ten) -- digits. Either the integer part or the fraction part (but not -- both) may be missing; the decimal point (but not the letter d -- (or D)) may be missing procedure Scan_Integer_Literal_Value (Base : Unsigned_Short_Short; Fatal : Boolean; Size : Natural := Natural'Last); -- Scan an integer literal in Base with less than Size digits. The -- result is stored in Integer_Literal_Value and Token is set to -- T_Integer_Literal. When the procedure cannot read any digit or -- when a digit is greater than Base, Token is set to T_Error. -- The procedure skips the literal and an error message is output -- when Fatal is true. procedure Scan_Integer_To_Name_Buffer (Base : Unsigned_Short_Short; Fatal : Boolean; Size : Natural := Natural'Last); -- Scan an integer literal in Base with a max of Size digits. The -- result is appended to Name_Buffer. Token is set to -- T_Error on failure and to T_Integer_Literal on success. procedure Eval_Integer_From_Name_Buffer (Base : Unsigned_Short_Short; Fatal : Boolean); -- Evaluate integer literal stored in Name_Buffer. Token is set to -- T_Error on failure and to T_Integer_Literal on success. The -- result is stored in Integer_Literal_Value on success. The -- literal is not always well-formed since a character may not be -- incorrect. When Fatal is true, the primitive outputs an error -- message. procedure Load_File (Source_File : File_Descriptor); -- Loads a file in the buffer and then closes it. procedure Scan_Identifier (Fatal : Boolean; Is_Directive : Boolean := False); -- -- Names : 3.2.3 -- An identifier is an arbitrarily long sequence of ASCII -- alphabetic, digit and underscore characters. The first -- character must be an ASCII alphabetic character. All characters -- are significant. -- -- Keywords : 3.2.4 -- keywords must be written exactly as in the above -- list. Names that collide with keywords (...) are -- illegal. For example, "boolean" is a valid keyword, "Boolean" -- and "BOOLEAN" are illegal identifiers. -- -- Directives : 3.3 -- This procedure is also used to scan directives that remain in source -- code after preprocessing, in which case the current character location -- is the # character that starts the directive. procedure Scan_Token (Fatal : Boolean); -- Scan token but do not report any error and do not fail on minor -- errors like detecting a string which appears to be a wide string. procedure New_Token (Token : Token_Type; Image : String); -- Evaluate token image and store it in Token_Image table. When -- Token is a graphical character, embrace its image between -- single quotes ('<<' and '>>' are considered as graphical -- characters). When Token is a keyword, embrace its image between -- double quotes. Enter the lower-case form of a keyword image -- into the name table and set name table byte to its token -- position in order to resolve it easily. procedure New_Line; -- Increment the line number and save the current position in the -- buffer in order to compute later on the column number. -- Also, if we have CRLF (carriage return followed by line feed), skip -- ahead one character, in order to treat the two characters as a single -- end-of-line. We do the same for LFCR, even though no supported operating -- systems use that sequence, because that's what the GNAT compiler does. procedure Skip_Spaces (Except_Newline : Boolean := False); -- Skip all spaces, except end-of-line markers if Except_Newline is True function To_Token (Name : Name_Id) return Token_Type; -- Return the token matching Name. Otherwise, return T_Error. Token_Image : array (Token_Type) of Name_Id; ------------------ -- Add_CPP_Flag -- ------------------ procedure Add_CPP_Flag (S : String) is begin CPP_Arg_Count := CPP_Arg_Count + 1; CPP_Arg_Values (CPP_Arg_Count) := new String'(S); end Add_CPP_Flag; ------------------------- -- Add_IAC_Search_Path -- ------------------------- procedure Add_IAC_Search_Path (S : String) is begin IAC_Search_Count := IAC_Search_Count + 1; IAC_Search_Paths (IAC_Search_Count) := new String'(S); end Add_IAC_Search_Path; ----------------------------------- -- Eval_Integer_From_Name_Buffer -- ----------------------------------- procedure Eval_Integer_From_Name_Buffer (Base : Unsigned_Short_Short; Fatal : Boolean) is C : Character; D : Natural; begin Integer_Literal_Value := 0; for I in 1 .. Name_Len loop C := Name_Buffer (I); if Integer_Literal_Base = 8 and then C in '8' .. '9' then if Fatal then Error_Loc (1) := Token_Location; Error_Loc (1).Scan := Error_Loc (1).Scan + Text_Ptr (I - 1); DE ("digit >= base"); end if; Skip_Identifier; Token := T_Error; return; end if; if C in '0' .. '9' then D := Character'Pos (C) - Character'Pos ('0'); else D := Character'Pos (C) - Character'Pos ('a') + 10; end if; Integer_Literal_Value := Integer_Literal_Value * Unsigned_Long_Long (Base) + Unsigned_Long_Long (D); end loop; end Eval_Integer_From_Name_Buffer; -------------- -- Finalize -- -------------- procedure Finalize_Imported is begin if Lexer_State_Stack.Last /= 0 then Pop_Lexer_State; end if; end Finalize_Imported; ------------- -- Handled -- ------------- function Handled (File_Name_Id : Name_Id) return Boolean is begin for Index in Handled_Files_Table.First .. Handled_Files_Table.Last loop if Handled_Files_Table.Table (Index) = File_Name_Id then return True; end if; end loop; return False; end Handled; ----------------- -- Set_Handled -- ----------------- procedure Set_Handled (File_Name_Id : Name_Id) is begin if not Handled (File_Name_Id) then Handled_Files_Table.Append (File_Name_Id); end if; end Set_Handled; ----------- -- Image -- ----------- function Image (T : Token_Type) return String is begin return Get_Name_String (Token_Image (T)); end Image; ---------------- -- Is_Literal -- ---------------- function Is_Literal (T : Token_Type) return Boolean is begin return T in Literal_Type; end Is_Literal; ----------------- -- Is_Operator -- ----------------- function Is_Operator (T : Token_Type) return Boolean is begin return T in Operator_Type; end Is_Operator; -------------------- -- Is_Scoped_Name -- -------------------- function Is_Scoped_Name (T : Token_Type) return Boolean is begin return T = T_Identifier or else T = T_Colon_Colon; end Is_Scoped_Name; --------------- -- Load_File -- --------------- procedure Load_File (Source_File : File_Descriptor) is Length : Integer; Result : Integer; begin -- Load source file in a buffer Length := Integer (File_Length (Source_File)); if Buffer /= null then Free (Buffer); end if; Buffer := new Text_Buffer (1 .. Text_Ptr (Length + 1)); -- Force the last character to be EOF Buffer (Text_Ptr (Length + 1)) := EOF; Token_Location.Scan := 1; loop Result := Read (Source_File, Buffer (Token_Location.Scan)'Address, Length); exit when Result = Length; if Result <= 0 then DE ("cannot read preprocessor output"); raise Fatal_Error; end if; Token_Location.Scan := Token_Location.Scan + Text_Ptr (Result); Length := Length - Result; end loop; Close (Source_File); end Load_File; ------------------ -- Make_Ckeanup -- ------------------ procedure Make_Cleanup is Success : Boolean; begin for Index in 1 .. TMP_File_Table.Last loop if TMP_File_Table.Table (Index) /= No_Name then Get_Name_String (TMP_File_Table.Table (Index)); Name_Buffer (Name_Len + 1) := ASCII.NUL; Delete_File (Name_Buffer'Address, Success); end if; end loop; end Make_Cleanup; -------------- -- New_Line -- -------------- procedure New_Line is begin -- If we have CRLF or LFCR, skip ahead one character, so we treat that -- as a single end-of-line case Buffer (Token_Location.Scan) is when LF => if Buffer (Token_Location.Scan + 1) = CR then Token_Location.Scan := Token_Location.Scan + 1; end if; when CR => if Buffer (Token_Location.Scan + 1) = LF then Token_Location.Scan := Token_Location.Scan + 1; end if; when FF | VT => null; when others => raise Program_Error; -- Caller makes sure we're at end-of-line end case; -- Increment line number and save current position Token_Location.Scan := Token_Location.Scan + 1; Token_Location.First := Token_Location.Scan; Token_Location.Last := Token_Location.Scan; Token_Location.Line := Token_Location.Line + 1; end New_Line; --------------- -- New_Token -- --------------- procedure New_Token (Token : Token_Type; Image : String) is begin Set_Str_To_Name_Buffer (Image); Token_Image (Token) := Name_Find; if Token in Keyword_Type or else Token = T_Pragma then To_Lower (Name_Buffer (1 .. Name_Len)); Set_Name_Table_Byte (Name_Find, Byte (Token_Type'Pos (Token))); end if; end New_Token; ---------------- -- Next_Token -- ---------------- function Next_Token return Token_Type is Current_Token_Name : Name_Id; Current_Token : Token_Type; Current_Token_Location : Location; Next_Token_Value : Token_Type; begin Current_Token_Name := Token_Name; Current_Token := Token; Current_Token_Location := Token_Location; Scan_Token (Fatal => False); Next_Token_Value := Token; Token_Name := Current_Token_Name; Token := Current_Token; Token_Location := Current_Token_Location; return Next_Token_Value; end Next_Token; ------------ -- Output -- ------------ procedure Output (Source : File_Descriptor) is begin Copy_To_Standard_Output (Source); Make_Cleanup; end Output; ---------------- -- Preprocess -- ---------------- procedure Preprocess (Source : Name_Id; Result : out File_Descriptor) is Success : Boolean; Tmp_FDesc : File_Descriptor; Tmp_FName : Temp_File_Name; Preprocessor : String_Access; Prep_And_Flags_List : constant Argument_List_Access := Argument_String_To_List (Platform.IDL_Preprocessor); procedure Open_Original_Source; -- Set Result to an open file descriptor for the original source file -- (not preprocessed). -------------------------- -- Open_Original_Source -- -------------------------- procedure Open_Original_Source is begin Get_Name_String (Source); Add_Char_To_Name_Buffer (ASCII.NUL); Result := Open_Read (Name_Buffer'Address, Binary); end Open_Original_Source; begin if Initialized then Push_Lexer_State; end if; if No_Preprocess then Open_Original_Source; return; end if; -- Reinitialize the CPP arguments CPP_Arg_Count := 0; -- Append the preprocessor flags for Index in Prep_And_Flags_List'First + 1 .. Prep_And_Flags_List'Last loop Add_CPP_Flag (Prep_And_Flags_List (Index).all); end loop; -- Pass user options to the preprocessor. Goto_Section ("cppargs"); while Getopt ("*") /= ASCII.NUL loop Add_CPP_Flag (Full_Switch); end loop; -- Add the paths in the IAC search path to the preprocessor search path for Index in 1 .. IAC_Search_Count loop Add_CPP_Flag ("-I"); Add_CPP_Flag (IAC_Search_Paths (Index).all); end loop; -- The temporary file containing the preprocessing result Add_CPP_Flag ("-o"); Create_Temp_File (Tmp_FDesc, Tmp_FName); if Tmp_FDesc = Invalid_FD then DE ("cannot create tmp file"); raise Fatal_Error; end if; Close (Tmp_FDesc); -- Get temporary file name, drop trailing NUL, add required suffix Set_Str_To_Name_Buffer (Tmp_FName); Name_Len := Name_Len - 1; Add_Str_To_Name_Buffer (Platform.IDL_Preprocessor_Suffix); Add_CPP_Flag (Name_Buffer (1 .. Name_Len)); CPP_Tmp_File := Name_Find; TMP_File_Table.Append (CPP_Tmp_File); -- The source file to be preprocessed Add_CPP_Flag (Get_Name_String (Source)); -- Locate preprocessor Preprocessor := Locate_Exec_On_Path (Prep_And_Flags_List (Prep_And_Flags_List'First).all); if Preprocessor = null then DE ("?cannot locate %", Prep_And_Flags_List (Prep_And_Flags_List'First).all); Open_Original_Source; return; end if; Spawn (Preprocessor.all, CPP_Arg_Values (1 .. CPP_Arg_Count), Success); if not Success then Error_Name (1) := Source; DE ("fail to preprocess%"); raise Fatal_Error; end if; Name_Buffer (1 .. Temp_File_Len) := Tmp_FName; Name_Buffer (Temp_File_Len + 1) := ASCII.NUL; Result := Open_Read (Name_Buffer'Address, Binary); if Result = Invalid_FD then DE ("cannot open preprocessor output"); raise Fatal_Error; end if; exception when others => Make_Cleanup; raise; end Preprocess; ------------- -- Process -- ------------- procedure Process (Source_File : File_Descriptor; Source_Name : Name_Id) is begin if not Initialized then Initialized := True; -- Enter all the alphabetic keywords in the name table New_Token (T_Error, ""); New_Token (T_Abstract, "abstract"); New_Token (T_Any, "any"); New_Token (T_Attribute, "attribute"); New_Token (T_Boolean, "boolean"); New_Token (T_Case, "case"); New_Token (T_Char, "char"); New_Token (T_Component, "component"); New_Token (T_Const, "const"); New_Token (T_Consumes, "consumes"); New_Token (T_Context, "context"); New_Token (T_Custom, "custom"); New_Token (T_Default, "default"); New_Token (T_Double, "double"); New_Token (T_Emits, "emits"); New_Token (T_Enum, "enum"); New_Token (T_Eventtype, "eventtype"); New_Token (T_Exception, "exception"); New_Token (T_Factory, "factory"); New_Token (T_False, "FALSE"); New_Token (T_Finder, "finder"); New_Token (T_Fixed, "fixed"); New_Token (T_Float, "float"); New_Token (T_Get_Raises, "getraises"); New_Token (T_Home, "home"); New_Token (T_Import, "import"); New_Token (T_In, "in"); New_Token (T_Inout, "inout"); New_Token (T_Interface, "interface"); New_Token (T_Local, "local"); New_Token (T_Long, "long"); New_Token (T_Module, "module"); New_Token (T_Multiple, "multiple"); New_Token (T_Native, "native"); New_Token (T_Object, "Object"); New_Token (T_Octet, "octet"); New_Token (T_Oneway, "oneway"); New_Token (T_Out, "out"); New_Token (T_Primary_Key, "primarykey"); New_Token (T_Private, "private"); New_Token (T_Provides, "provides"); New_Token (T_Public, "public"); New_Token (T_Publishes, "publishes"); New_Token (T_Raises, "raises"); New_Token (T_Readonly, "readonly"); New_Token (T_Sequence, "sequence"); New_Token (T_Set_Raises, "setraises"); New_Token (T_Short, "short"); New_Token (T_String, "string"); New_Token (T_Struct, "struct"); New_Token (T_Supports, "supports"); New_Token (T_Switch, "switch"); New_Token (T_True, "TRUE"); New_Token (T_Truncatable, "truncatable"); New_Token (T_Typedef, "typedef"); New_Token (T_Type_Id, "typeid"); New_Token (T_Type_Prefix, "typeprefix"); New_Token (T_Unsigned, "unsigned"); New_Token (T_Union, "union"); New_Token (T_Uses, "uses"); New_Token (T_Value_Base, "ValueBase"); New_Token (T_Value_Type, "valuetype"); New_Token (T_Void, "void"); New_Token (T_Wchar, "wchar"); New_Token (T_Wstring, "wstring"); New_Token (T_Semi_Colon, ";"); New_Token (T_Left_Brace, "{"); New_Token (T_Right_Brace, "}"); New_Token (T_Colon, ":"); New_Token (T_Comma, ","); New_Token (T_Colon_Colon, "::"); New_Token (T_Left_Paren, "("); New_Token (T_Right_Paren, ")"); New_Token (T_Equal, "="); New_Token (T_Bar, "|"); New_Token (T_Circumflex, "^"); New_Token (T_Ampersand, "&"); New_Token (T_Greater_Greater, ">>"); New_Token (T_Less_Less, "<<"); New_Token (T_Plus, "+"); New_Token (T_Minus, "-"); New_Token (T_Star, "*"); New_Token (T_Slash, "/"); New_Token (T_Percent, "%"); New_Token (T_Tilde, "~"); New_Token (T_Less, "<"); New_Token (T_Greater, ">"); New_Token (T_Left_Bracket, "["); New_Token (T_Right_Bracket, "]"); New_Token (T_Integer_Literal, ""); New_Token (T_Fixed_Point_Literal, ""); New_Token (T_Floating_Point_Literal, ""); New_Token (T_Character_Literal, ""); New_Token (T_Wide_Character_Literal, ""); New_Token (T_String_Literal, ""); New_Token (T_Wide_String_Literal, ""); New_Token (T_Identifier, ""); New_Token (T_Pragma, "#pragma"); New_Token (T_Pragma_Id, "ID"); New_Token (T_Pragma_Prefix, "prefix"); New_Token (T_Pragma_Version, "version"); New_Token (T_Pragma_Unrecognized, ""); New_Token (T_EOF, ""); end if; -- Load source file in a buffer Load_File (Source_File); -- Reset at the beginning Token_Location.Scan := 1; Token_Location.First := 1; Token_Location.Last := 1; Set_New_Location (Token_Location, Source_Name, 1); exception when others => if not Keep_TMP_Files then Make_Cleanup; end if; raise; end Process; ---------------------- -- Push_Lexer_State -- ---------------------- procedure Push_Lexer_State is begin Lexer_State_Stack.Append ((Loc => Token_Location, Preprocessed_File_Name => CPP_Tmp_File)); end Push_Lexer_State; --------------------- -- Pop_Lexer_State -- --------------------- procedure Pop_Lexer_State is Tmp_FDesc : File_Descriptor; S : constant Lexer_State := Lexer_State_Stack.Table (Lexer_State_Stack.Last); begin Lexer_State_Stack.Set_Last (Lexer_State_Stack.Last - 1); -- Reload source file in a buffer Get_Name_String (S.Preprocessed_File_Name); CPP_Tmp_File := Name_Find; Name_Buffer (Name_Len + 1) := ASCII.NUL; Tmp_FDesc := Open_Read (Name_Buffer'Address, Binary); Load_File (Tmp_FDesc); -- Restore the location Token_Location := S.Loc; end Pop_Lexer_State; ------------------ -- Quoted_Image -- ------------------ function Quoted_Image (T : Token_Type) return String is begin if T in T_Abstract .. T_Wstring then return Quoted (Get_Name_String (Token_Image (T))); elsif T in T_Ampersand .. T_Less_Less then return Quoted (Get_Name_String (Token_Image (T)), '''); end if; return Get_Name_String (Token_Image (T)); end Quoted_Image; ------------------- -- Restore_Lexer -- ------------------- procedure Restore_Lexer (State : Location) is begin Token_Location := State; end Restore_Lexer; ---------------- -- Save_Lexer -- ---------------- procedure Save_Lexer (State : out Location) is begin State := Token_Location; end Save_Lexer; ------------------------------ -- Scan_Chars_Literal_Value -- ------------------------------ procedure Scan_Chars_Literal_Value (Literal : Token_Type; Fatal : Boolean; Adjacent : Boolean := True) is C : Character; Delimiter : Character := '''; Wideness : Boolean := False; Length : Natural := 0; State : Location; Errors : Natural := 0; begin if Literal in T_String_Literal .. T_Wide_String_Literal then Delimiter := '"'; -- " if Literal = T_Wide_String_Literal then Wideness := True; end if; elsif Literal = T_Wide_Character_Literal then Wideness := True; end if; Name_Len := 0; loop Save_Lexer (State); C := Buffer (Token_Location.Scan); Token_Location.Scan := Token_Location.Scan + 1; if C = EOF then Token := T_Error; return; end if; -- Exit when (C = ''') or (C = '"' and not Adjacent) if C = Delimiter then exit when not Adjacent; -- Look for adjacent strings Skip_Spaces; exit when Buffer (Token_Location.Scan) /= Delimiter; C := Buffer (Token_Location.Scan + 1); Token_Location.Scan := Token_Location.Scan + 2; end if; -- Output only once error message for character literal of -- more than one character. if Delimiter = ''' and then Length = 1 then if Fatal then Errors := Errors + 1; Error_Loc (1) := Token_Location; DE ("strings are delimited by double quote character"); end if; end if; Length := Length + 1; -- Read escaped character if C = '\' then case Buffer (Token_Location.Scan) is when '\' | '"' -- " | ''' | '?' => Character_Literal_Value := Character'Pos (Buffer (Token_Location.Scan)); Token_Location.Scan := Token_Location.Scan + 1; when 'n' => Character_Literal_Value := Character'Pos (ASCII.LF); Token_Location.Scan := Token_Location.Scan + 1; when 't' => Character_Literal_Value := Character'Pos (ASCII.HT); Token_Location.Scan := Token_Location.Scan + 1; when 'v' => Character_Literal_Value := Character'Pos (ASCII.VT); Token_Location.Scan := Token_Location.Scan + 1; when 'b' => Character_Literal_Value := Character'Pos (ASCII.BS); Token_Location.Scan := Token_Location.Scan + 1; when 'r' => Character_Literal_Value := Character'Pos (ASCII.CR); Token_Location.Scan := Token_Location.Scan + 1; when 'f' => Character_Literal_Value := Character'Pos (ASCII.FF); Token_Location.Scan := Token_Location.Scan + 1; when 'a' => Character_Literal_Value := Character'Pos (ASCII.BEL); Token_Location.Scan := Token_Location.Scan + 1; -- Read 1, 2 or 3 octal digits when '0' .. '7' => Scan_Integer_Literal_Value (8, Fatal, 3); if Token = T_Error then if Fatal then Errors := Errors + 1; Error_Loc (1) := Token_Location; DE ("cannot parse octal digits"); end if; Integer_Literal_Value := 0; end if; Character_Literal_Value := Unsigned_Short (Integer_Literal_Value); -- Read 1 or 2 hexadecimal digits when 'x' => Token_Location.Scan := Token_Location.Scan + 1; Scan_Integer_Literal_Value (16, Fatal, 2); if Token = T_Error then if Fatal then Errors := Errors + 1; Error_Loc (1) := Token_Location; DE ("cannot parse hexadecimal digits"); end if; Integer_Literal_Value := 0; end if; Character_Literal_Value := Unsigned_Short (Integer_Literal_Value); -- Read 1, 2, 3 or 4 hexadecimal digits when 'u' => if not Wideness then if Fatal then Errors := Errors + 1; Error_Loc (1) := Token_Location; DE ("\u may only be used in wide characters " & "and strings"); end if; end if; Token_Location.Scan := Token_Location.Scan + 1; Scan_Integer_Literal_Value (16, Fatal, 4); if Token = T_Error then if Fatal then Errors := Errors + 1; Error_Loc (1) := Token_Location; DE ("cannot parse hexadecimal digits"); end if; Integer_Literal_Value := 0; end if; Character_Literal_Value := Unsigned_Short (Integer_Literal_Value); when others => if Fatal then Errors := Errors + 1; Error_Loc (1) := Token_Location; DE ("unexcepted escaped character"); end if; Character_Literal_Value := 0; end case; else Character_Literal_Value := Character'Pos (C); end if; if Literal in T_String_Literal .. T_Wide_String_Literal then if Wideness then Add_Char_To_Name_Buffer (Character'Val (Character_Literal_Value / 256)); end if; Add_Char_To_Name_Buffer (Character'Val (Character_Literal_Value and 255)); end if; end loop; Token := Literal; if Literal in T_String_Literal .. T_Wide_String_Literal then -- If the string is empty, we assign Token_Name the No_Name value if Name_Len = 0 then Token_Name := No_Name; else Token_Name := Name_Find; end if; String_Literal_Value := Token_Name; end if; if Errors > 0 then Token_Name := Incorrect_String; String_Literal_Value := Incorrect_String; Character_Literal_Value := Incorrect_Character; end if; end Scan_Chars_Literal_Value; --------------------- -- Scan_Identifier -- --------------------- procedure Scan_Identifier (Fatal : Boolean; Is_Directive : Boolean := False) is Escaped : Boolean := False; begin -- Read escaped identifier if Buffer (Token_Location.Scan) = '_' then Escaped := True; Token_Location.Scan := Token_Location.Scan + 1; end if; -- Read identifier if Is_Directive then -- Scan past '#' Name_Len := 1; Name_Buffer (Name_Len) := '#'; Token_Location.Scan := Token_Location.Scan + 1; else Name_Len := 0; end if; while Is_Identifier_Character (Buffer (Token_Location.Scan)) loop Name_Len := Name_Len + 1; Name_Buffer (Name_Len) := Buffer (Token_Location.Scan); Token_Location.Scan := Token_Location.Scan + 1; end loop; if Name_Len = 0 then if Fatal then Error_Loc (1) := Token_Location; DE ("identifier must start with alphabetic character"); end if; Name_Buffer (1) := ' '; Name_Len := 1; return; end if; Token_Name := Name_Find; Token := T_Identifier; -- Check whether it is a keyword or a pragma if not Escaped then Token := To_Token (Token_Name); -- Check that the case of keywords is correct. -- IDL Syntax and semantics, CORBA V2.3 § 3.2.4 -- -- keywords must be written exactly as in the above list. Identifiers -- that collide with keywords (...) are illegal. if Fatal and then Token in Keyword_Type and then Token_Name /= Token_Image (Token) then Error_Loc (1) := Token_Location; Error_Name (1) := Token_Image (Token); DE ("incorrect case; # expected"); end if; if Token = T_Error then Token := T_Identifier; elsif Token = T_True then Token := T_Boolean_Literal; Integer_Literal_Value := 1; elsif Token = T_False then Token := T_Boolean_Literal; Integer_Literal_Value := 0; end if; end if; -- Check that identifier is well-formed if Token = T_Identifier then if not Is_Alphabetic_Character (Name_Buffer (1)) then if Escaped then if Fatal then Error_Loc (1) := Token_Location; DE ("incorrect escaped identifier"); end if; else if Fatal then Error_Loc (1) := Token_Location; DE ("identifier must start with alphabetic character"); end if; end if; end if; end if; end Scan_Identifier; -------------------------------- -- Scan_Integer_Literal_Value -- -------------------------------- procedure Scan_Integer_Literal_Value (Base : Unsigned_Short_Short; Fatal : Boolean; Size : Natural := Natural'Last) is begin Token := T_Integer_Literal; Name_Len := 0; Scan_Integer_To_Name_Buffer (Base, Fatal, Size); if Token = T_Error then return; end if; Eval_Integer_From_Name_Buffer (Base, Fatal); if Token = T_Error then return; end if; end Scan_Integer_Literal_Value; --------------------------------- -- Scan_Integer_To_Name_Buffer -- --------------------------------- procedure Scan_Integer_To_Name_Buffer (Base : Unsigned_Short_Short; Fatal : Boolean; Size : Natural := Natural'Last) is C : Character; Len : Integer := 0; Loc : Location := Token_Location; begin while Len < Size loop C := To_Lower (Buffer (Loc.Scan)); if C in '0' .. '9' then if Base = 8 and then C in '8' .. '9' then if Fatal then Error_Loc (1) := Loc; DE ("digit >= base"); end if; Skip_Identifier; Token := T_Error; return; end if; elsif Base = 16 and then C in 'a' .. 'f' then null; elsif Base = 10 and then (C = 'e' or else C = 'd') then exit; elsif Is_Identifier_Character (C) then if Fatal then Error_Loc (1) := Loc; DE ("illegal character"); end if; Skip_Identifier; Token := T_Error; return; else exit; end if; Len := Len + 1; Add_Char_To_Name_Buffer (C); Loc.Scan := Loc.Scan + 1; end loop; Token_Location := Loc; end Scan_Integer_To_Name_Buffer; -------------------------------- -- Scan_Numeric_Literal_Value -- -------------------------------- procedure Scan_Numeric_Literal_Value (Fatal : Boolean) is C : Character; L : Location renames Token_Location; begin L := Token_Location; Token := T_Integer_Literal; Name_Len := 0; Integer_Literal_Base := 10; Integer_Literal_Sign := 1; -- Read the sign C := To_Lower (Buffer (L.Scan)); if C = '+' or else C = '-' then if C = '-' then Integer_Literal_Sign := -1; end if; L.Scan := L.Scan + 1; C := To_Lower (Buffer (L.Scan)); end if; -- Case of an hexadecimal literal (C must not be clobbered here if the -- next character turns out to be other than 'x'). if C = '0' and then To_Lower (Buffer (L.Scan + 1)) = 'x' then Integer_Literal_Base := 16; L.Scan := L.Scan + 2; -- Check the next character is a digit C := To_Lower (Buffer (L.Scan)); if C not in '0' .. '9' and then C not in 'a' .. 'f' then if Fatal then Error_Loc (1) := L; DE ("digit excepted"); end if; Skip_Identifier; Token := T_Error; return; end if; end if; -- Read the integer part if C /= '.' then Scan_Integer_To_Name_Buffer (Integer_Literal_Base, Fatal); -- Check whether there is a well-formed integer part if Token = T_Error then return; end if; C := To_Lower (Buffer (L.Scan)); end if; -- Read the fraction part if C = '.' then -- It may be a fixed literal. This will be updated when the -- fixed literal suffix is detected. Token := T_Floating_Point_Literal; -- As there is a decimal point, the base is 10. Having a -- previous base sets to 8 is not a problem since the -- previous digits are in the range '0' .. '7'. But there is -- a problem with base 16 as the literal starts with 0x. if Integer_Literal_Base = 16 then if Fatal then Error_Loc (1) := L; DE ("cannot parse integer literal"); end if; Skip_Identifier; Token := T_Error; return; end if; Integer_Literal_Base := 10; -- Append the decimal point and read the fraction part Add_Char_To_Name_Buffer (C); L.Scan := L.Scan + 1; C := To_Lower (Buffer (L.Scan)); if C in '0' .. '9' then Scan_Integer_To_Name_Buffer (10, Fatal); -- Check that the fraction part is a well-formed literal if Token = T_Error then return; end if; C := To_Lower (Buffer (L.Scan)); end if; end if; -- Read the exponent if C = 'e' then Token := T_Floating_Point_Literal; Add_Char_To_Name_Buffer (C); -- Read the exponent sign. C := Buffer (L.Scan + 1); if C = '-' or else C = '+' then Add_Char_To_Name_Buffer (C); L.Scan := L.Scan + 1; end if; -- Check that the exponent part exists C := Buffer (L.Scan + 1); if C not in '0' .. '9' then if Fatal then Error_Loc (1) := L; DE ("exponent part cannot be missing"); end if; Skip_Identifier; Token := T_Error; return; end if; L.Scan := L.Scan + 1; -- Read the exponent part Scan_Integer_To_Name_Buffer (10, Fatal); -- Check that the exponent part is a well-formed literal if Token = T_Error then return; end if; -- Skip fixed literal suffix elsif C = 'd' then Token := T_Fixed_Point_Literal; L.Scan := L.Scan + 1; end if; if (Name_Len > 0 and then Name_Buffer (1) = '.') and then (Name_Len = 1 or else (Name_Len > 1 and then Name_Buffer (2) not in '0' .. '9')) then if Fatal then Error_Loc (1) := L; DE ("both integer and fraction part cannot be missing"); end if; Skip_Identifier; Token := T_Error; return; end if; if Token = T_Floating_Point_Literal then Float_Literal_Value := Long_Double'Value (Name_Buffer (1 .. Name_Len)); else if Token = T_Fixed_Point_Literal then Decimal_Point_Position := 0; for I in 1 .. Name_Len loop if Name_Buffer (I) = '.' then Decimal_Point_Position := Unsigned_Short_Short (Name_Len - I); end if; if Decimal_Point_Position > 0 then Name_Buffer (I) := Name_Buffer (I + 1); end if; end loop; if Decimal_Point_Position > 0 then Name_Len := Name_Len - 1; end if; elsif Name_Len > 1 and then Name_Buffer (1) = '0' and then Integer_Literal_Base /= 16 then Integer_Literal_Base := 8; end if; Eval_Integer_From_Name_Buffer (Integer_Literal_Base, Fatal); end if; end Scan_Numeric_Literal_Value; --------------------------------- -- Scan_Preprocessor_Directive -- --------------------------------- procedure Scan_Preprocessor_Directive is C : Character; begin if Token_Location.Scan = Buffer'Last then -- Malformed directive: lone # at end of file Token := T_Error; return; end if; -- Peek at next character C := Buffer (Token_Location.Scan + 1); -- Read pragma directive if Is_Alphabetic_Character (C) then Scan_Identifier (False, Is_Directive => True); return; end if; -- Scan past '#' Token_Location.Scan := Token_Location.Scan + 1; Skip_Spaces (Except_Newline => True); C := Buffer (Token_Location.Scan); -- Read line marker: -- # -- # "" -- # "" -- The line marker is terminated by end-of-line if C in '0' .. '9' then declare Line : Natural; begin Scan_Integer_Literal_Value (10, True); Line := Natural (Integer_Literal_Value); Skip_Spaces (Except_Newline => True); -- Scan optional file name if Buffer (Token_Location.Scan) = '"' then Token_Location.Scan := Token_Location.Scan + 1; Token := T_String_Literal; Scan_Chars_Literal_Value (T_String_Literal, True, False); Get_Name_String (String_Literal_Value); -- Remove marker for built-in or command line text if Name_Buffer (1) = '<' and then Name_Buffer (Name_Len) = '>' then Skip_Line; -- Check the suffix is ".idl" elsif Name_Len < 5 or else Name_Buffer (Name_Len - 3 .. Name_Len) /= ".idl" then Error_Loc (1) := Token_Location; DE ("incorrect suffix"); else Skip_Line; Set_New_Location (Token_Location, String_Literal_Value, Int (Line)); end if; else -- No file name Skip_Line; Token_Location.Line := Int (Line); end if; return; end; end if; -- Cannot handle other directives Token := T_Error; Skip_Line; end Scan_Preprocessor_Directive; ---------------- -- Scan_Token -- ---------------- procedure Scan_Token (T : Token_Type) is Loc : Location := Token_Location; begin Scan_Token; if T /= Token then if T = T_Semi_Colon then Loc.Last := Loc.Scan; if Buffer (Loc.Last) = LF or else Buffer (Loc.Last) = FF or else Buffer (Loc.Last) = CR or else Buffer (Loc.Last) = VT then Loc.Last := Loc.Last - 1; end if; else Loc := Token_Location; end if; Error_Loc (1) := Loc; DE ("expected token %", Quoted_Image (T)); Token := T_Error; end if; end Scan_Token; ---------------- -- Scan_Token -- ---------------- procedure Scan_Token (L : Token_List_Type) is begin pragma Assert (L'Length > 1); Scan_Token; for Index in L'Range loop if L (Index) = Token then return; -- All is well end if; end loop; -- Give error message Name_Len := 0; Add_Str_To_Name_Buffer (Quoted_Image (L (L'First))); for Index in L'First + 1 .. L'Last loop Add_Str_To_Name_Buffer (" or "); Add_Str_To_Name_Buffer (Quoted_Image (L (Index))); end loop; Error_Loc (1) := Token_Location; Error_Name (1) := Name_Find; DE ("expected tokens %"); Token := T_Error; end Scan_Token; ---------------- -- Scan_Token -- ---------------- procedure Scan_Token is begin Scan_Token (Fatal => True); end Scan_Token; ---------------- -- Scan_Token -- ---------------- procedure Scan_Token (Fatal : Boolean) is begin if Token = T_EOF then return; end if; Token := T_Error; while Token = T_Error loop Skip_Spaces; Token_Location.Last := Token_Location.Scan; case Buffer (Token_Location.Scan) is when LF | FF | CR | VT => New_Line; when ';' => Token_Location.Scan := Token_Location.Scan + 1; Token := T_Semi_Colon; when '{' => Token_Location.Scan := Token_Location.Scan + 1; Token := T_Left_Brace; -- The line marker is terminated by end-of-line when '}' => Token_Location.Scan := Token_Location.Scan + 1; Token := T_Right_Brace; when ':' => Token_Location.Scan := Token_Location.Scan + 1; if Buffer (Token_Location.Scan) = ':' then Token_Location.Scan := Token_Location.Scan + 1; Token := T_Colon_Colon; else Token := T_Colon; end if; when ',' => Token_Location.Scan := Token_Location.Scan + 1; Token := T_Comma; when '(' => Token_Location.Scan := Token_Location.Scan + 1; Token := T_Left_Paren; when ')' => Token_Location.Scan := Token_Location.Scan + 1; Token := T_Right_Paren; when '=' => Token_Location.Scan := Token_Location.Scan + 1; Token := T_Equal; when '|' => Token_Location.Scan := Token_Location.Scan + 1; Token := T_Bar; when '^' => Token_Location.Scan := Token_Location.Scan + 1; Token := T_Circumflex; when '&' => Token_Location.Scan := Token_Location.Scan + 1; Token := T_Ampersand; when '<' => Token_Location.Scan := Token_Location.Scan + 1; if Buffer (Token_Location.Scan) = '<' then Token_Location.Scan := Token_Location.Scan + 1; Token := T_Less_Less; else Token := T_Less; end if; when '>' => Token_Location.Scan := Token_Location.Scan + 1; if Buffer (Token_Location.Scan) = '>' then Token_Location.Scan := Token_Location.Scan + 1; Token := T_Greater_Greater; else Token := T_Greater; end if; when '+' => Token_Location.Scan := Token_Location.Scan + 1; Token := T_Plus; when '-' => Token_Location.Scan := Token_Location.Scan + 1; Token := T_Minus; when '*' => Token_Location.Scan := Token_Location.Scan + 1; Token := T_Star; when '/' => -- Comment like // if Buffer (Token_Location.Scan + 1) = '/' then Skip_Line; -- Comment like /* ... */ (not nested) elsif Buffer (Token_Location.Scan + 1) = '*' then Token_Location.Scan := Token_Location.Scan + 2; while Buffer (Token_Location.Scan) /= EOF and then (Buffer (Token_Location.Scan) /= '*' or else Buffer (Token_Location.Scan + 1) /= '/') loop Token_Location.Scan := Token_Location.Scan + 1; end loop; if Buffer (Token_Location.Scan) = EOF then Error_Loc (1) := Token_Location; DE ("unterminated comment"); end if; -- Skip char sequence */ Token_Location.Scan := Token_Location.Scan + 2; else Token_Location.Scan := Token_Location.Scan + 1; Token := T_Slash; end if; when '%' => Token_Location.Scan := Token_Location.Scan + 1; Token := T_Percent; when '~' => Token_Location.Scan := Token_Location.Scan + 1; Token := T_Tilde; when '[' => Token_Location.Scan := Token_Location.Scan + 1; Token := T_Left_Bracket; when ']' => Token_Location.Scan := Token_Location.Scan + 1; Token := T_Right_Bracket; when '0' .. '9' => Scan_Numeric_Literal_Value (Fatal); when '.' => Scan_Numeric_Literal_Value (Fatal); when ''' => Token_Location.Scan := Token_Location.Scan + 1; Scan_Chars_Literal_Value (T_Character_Literal, Fatal); when '"' => -- " Token_Location.Scan := Token_Location.Scan + 1; Scan_Chars_Literal_Value (T_String_Literal, Fatal, True); when '#' => Scan_Preprocessor_Directive; -- No real token found. Loop again. if Token /= T_Pragma then Token := T_Error; end if; when '_' => Scan_Identifier (Fatal); when EOF => Token_Location.Scan := Token_Location.Scan + 1; Token := T_EOF; when others => if Is_Alphabetic_Character (Buffer (Token_Location.Scan)) then -- -- Wide Chars : 3.5.2.2 -- Wide characters literals have an L prefix, for example : -- const wchar C1 = L'X'; -- -- Wide Strings : 3.5.2.4 -- Wide string literals have an L prefix, for example : -- const wstring S1 = L"Hello"; if Buffer (Token_Location.Scan) = 'L' then -- Read wide character literal if Buffer (Token_Location.Scan + 1) = ''' then Token_Location.Scan := Token_Location.Scan + 2; Scan_Chars_Literal_Value (T_Wide_Character_Literal, Fatal); return; -- Read wide string literal elsif Buffer (Token_Location.Scan + 1) = '"' then Token_Location.Scan := Token_Location.Scan + 2; Scan_Chars_Literal_Value (T_Wide_String_Literal, Fatal, True); return; end if; end if; Scan_Identifier (Fatal); else Error_Loc (1) := Token_Location; DE ("invalid character"); -- Try to rescue parser and find the beginning of a -- potential token Token_Location.Scan := Token_Location.Scan + 1; while Is_Alphabetic_Character (Buffer (Token_Location.Scan)) or else Buffer (Token_Location.Scan) in '0' .. '9' or else Buffer (Token_Location.Scan) = '_' loop Token_Location.Scan := Token_Location.Scan + 1; end loop; end if; end case; end loop; end Scan_Token; ---------------------- -- Skip_Declaration -- ---------------------- procedure Skip_Declaration (Delimiter : Token_Type) is Braces : Integer := 0; State : Location; begin loop Save_Lexer (State); Scan_Token (Fatal => False); exit when Token = T_EOF; if Token in T_Left_Brace .. T_Left_Paren then Braces := Braces + 1; elsif Token in T_Right_Brace .. T_Right_Paren then exit when Braces <= 0 and then Delimiter in T_Right_Brace .. T_Right_Paren; Braces := Braces - 1; elsif Token in T_Colon .. T_Semi_Colon then exit when Braces <= 0 and then Delimiter in T_Colon .. T_Semi_Colon; end if; end loop; -- When we reach the end of the file without finding a proper -- delimiter, we cannot rescue the lexer. if Token /= T_EOF then Restore_Lexer (State); Scan_Token (Delimiter); end if; end Skip_Declaration; --------------------- -- Skip_Identifier -- --------------------- procedure Skip_Identifier is begin while Is_Identifier_Character (Buffer (Token_Location.Scan)) loop Token_Location.Scan := Token_Location.Scan + 1; end loop; end Skip_Identifier; --------------- -- Skip_Line -- --------------- procedure Skip_Line is begin loop case Buffer (Token_Location.Scan) is when LF | FF | CR | VT => New_Line; exit; when others => null; end case; Token_Location.Scan := Token_Location.Scan + 1; end loop; end Skip_Line; ----------------- -- Skip_Spaces -- ----------------- procedure Skip_Spaces (Except_Newline : Boolean := False) is begin loop case Buffer (Token_Location.Scan) is when ' ' | HT => Token_Location.Scan := Token_Location.Scan + 1; when LF | FF | CR | VT => if Except_Newline then exit; else New_Line; end if; when others => exit; end case; end loop; end Skip_Spaces; -------------- -- To_Token -- -------------- function To_Token (Name : Name_Id) return Token_Type is B : Byte; begin Get_Name_String (Name); To_Lower (Name_Buffer (1 .. Name_Len)); B := Get_Name_Table_Byte (Name_Find); if B <= Last_Token_Pos then return Token_Type'Val (B); end if; return T_Error; end To_Token; ---------------------- -- Unexpected_Token -- ---------------------- procedure Unexpected_Token (T : Token_Type; C : String) is begin Error_Loc (1) := Token_Location; Set_Str_To_Name_Buffer (Quoted_Image (T)); Error_Name (1) := Name_Find; Set_Str_To_Name_Buffer (C); Error_Name (2) := Name_Find; DE ("unexpected % in %"); end Unexpected_Token; ----------- -- Write -- ----------- procedure Write (T : Token_Type) is begin Write_Str (Image (T)); end Write; end Lexer; polyorb-2.8~20110207.orig/compilers/iac/backend-be_corba_ada-debug.adb0000644000175000017500000001556611750740337024640 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- B A C K E N D . B E _ C O R B A _ A D A . D E B U G -- -- -- -- B o d y -- -- -- -- Copyright (C) 2005-2008, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with Charset; use Charset; with Locations; use Locations; with Lexer; use Lexer; with Namet; use Namet; with Scopes; with Utils; use Utils; with Values; use Values; with Frontend.Nodes; package body Backend.BE_CORBA_Ada.Debug is package FEN renames Frontend.Nodes; ----------- -- Image -- ----------- function Image (N : Node_Kind) return String is S : String := Node_Kind'Image (N); begin To_Lower (S); for I in S'Range loop if S (I) = '_' then S (I) := ' '; end if; end loop; return S (3 .. S'Last); end Image; function Image (N : Name_Id) return String is begin if N = No_Name then return No_Str; else return Get_Name_String (N); end if; end Image; function Image (N : Value_Id) return String is begin return Values.Image (N); end Image; function Image (N : Node_Id) return String is begin return Image (Int (N)); end Image; function Image (N : List_Id) return String is begin return Image (Int (N)); end Image; function Image (N : Mode_Id) return String is begin return Quoted (Image (Token_Type'Val (N))); end Image; function Image (N : Operator_Id) return String is begin return Quoted (Image (Operator_Type'Val (N))); end Image; function Image (N : Boolean) return String is begin return Boolean'Image (N); end Image; function Image (N : Byte) return String is begin return Image (Int (N)); end Image; --------------- -- W_Boolean -- --------------- procedure W_Boolean (N : Boolean) is begin Write_Str (N'Img); end W_Boolean; ------------ -- W_Byte -- ------------ procedure W_Byte (N : Byte) is begin Write_Int (Int (N)); end W_Byte; ----------------- -- W_Full_Tree -- ----------------- procedure W_Full_Tree is N : Node_Id := Stub_Node (FEN.BE_Node (Scopes.IDL_Spec)); begin N_Indents := 0; while Present (N) loop W_Node_Id (N); N := Next_Node (N); end loop; end W_Full_Tree; --------------- -- W_Indents -- --------------- procedure W_Indents is begin for I in 1 .. N_Indents loop Write_Str (" "); end loop; end W_Indents; --------------- -- W_List_Id -- --------------- procedure W_List_Id (L : List_Id) is N : Node_Id; begin if L = No_List then return; end if; N := First_Node (L); while Present (N) loop W_Node_Id (N); N := Next_Node (N); end loop; end W_List_Id; ---------------------- -- W_Node_Attribute -- ---------------------- procedure W_Node_Attribute (A : String; K : String; V : String; N : Int := 0) is C : Node_Id; begin -- Some fields must not be printed be cause they constitute -- redundant information. if A = "Next_Entity" or else A = "Next_Node" or else A = "Package_Declaration" then return; end if; N_Indents := N_Indents + 1; W_Indents; Write_Str (A); Write_Char (' '); Write_Str (K); Write_Char (' '); C := Node_Id (N); if K = "Name_Id" then Write_Line (Quoted (V)); elsif K = "Node_Id" and then Present (C) then case Kind (C) is when K_Float .. K_Any => Write_Line ('(' & Image (Kind (Node_Id (N))) & ')'); when others => Write_Line (V); end case; else Write_Line (V); end if; -- Some fields must not be visited to avoid endless recursions if A /= "Node" and then A /= "Declaration_Node" and then A /= "FE_Node" and then A /= "Parent" and then A /= "IDL_Unit" and then A /= "Designated_Node" then if K = "Node_Id" then W_Node_Id (Node_Id (N)); elsif K = "List_Id" then W_List_Id (List_Id (N)); end if; end if; N_Indents := N_Indents - 1; end W_Node_Attribute; ------------------- -- W_Node_Header -- ------------------- procedure W_Node_Header (N : Node_Id) is begin W_Indents; Write_Int (Int (N)); Write_Char (' '); Write_Str (Image (Kind (N))); Write_Char (' '); Write_Line (Image (Loc (N))); end W_Node_Header; --------------- -- W_Node_Id -- --------------- procedure W_Node_Id (N : Node_Id) is begin if N = No_Node then return; end if; W_Node (N); end W_Node_Id; ---------- -- wabi -- ---------- procedure wabi (N : Node_Id) is I : constant Natural := N_Indents; begin N_Indents := 1; W_Node_Id (N); N_Indents := I; end wabi; end Backend.BE_CORBA_Ada.Debug; polyorb-2.8~20110207.orig/compilers/iac/backend-be_corba_ada-stubs.adb0000644000175000017500000027501211750740337024704 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- B A C K E N D . B E _ C O R B A _ A D A . S T U B S -- -- -- -- B o d y -- -- -- -- Copyright (C) 2005-2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with Namet; use Namet; with Values; use Values; with Locations; use Locations; with Frontend.Nutils; with Frontend.Nodes; use Frontend.Nodes; with Backend.BE_CORBA_Ada.IDL_To_Ada; use Backend.BE_CORBA_Ada.IDL_To_Ada; with Backend.BE_CORBA_Ada.Nodes; use Backend.BE_CORBA_Ada.Nodes; with Backend.BE_CORBA_Ada.Nutils; use Backend.BE_CORBA_Ada.Nutils; with Backend.BE_CORBA_Ada.Runtime; use Backend.BE_CORBA_Ada.Runtime; with Backend.BE_CORBA_Ada.Common; use Backend.BE_CORBA_Ada.Common; package body Backend.BE_CORBA_Ada.Stubs is package FEN renames Frontend.Nodes; package BEN renames Backend.BE_CORBA_Ada.Nodes; package FEU renames Frontend.Nutils; function Visible_Is_A_Spec (E : Node_Id) return Node_Id; -- Specification for the Is_A routine which must be present in the -- stub spec as specified by the mapping rules. This routine is -- visible and may be called by any other Ada entity. function Visible_Is_A_Body (E : Node_Id) return Node_Id; function Local_Is_A_Spec return Node_Id; -- This is a private routine and it is called only inside the stub -- and its package hierarchy (Helper, Skel, Impl...). package body Package_Spec is procedure Visit_Attribute_Declaration (E : Node_Id); procedure Visit_Constant_Declaration (E : Node_Id); procedure Visit_Enumeration_Type (E : Node_Id); procedure Visit_Exception_Declaration (E : Node_Id); procedure Visit_Forward_Interface_Declaration (E : Node_Id); procedure Visit_Interface_Declaration (E : Node_Id); procedure Visit_Module (E : Node_Id); procedure Visit_Native_Type (E : Node_Id); procedure Visit_Operation_Declaration (E : Node_Id; Binding : Boolean := True); procedure Visit_Specification (E : Node_Id); procedure Visit_Structure_Type (E : Node_Id); procedure Visit_Type_Declaration (E : Node_Id); procedure Visit_Union_Type (E : Node_Id); ----------- -- Visit -- ----------- procedure Visit (E : Node_Id) is begin case FEN.Kind (E) is when K_Specification => Visit_Specification (E); when K_Constant_Declaration => Visit_Constant_Declaration (E); when K_Enumeration_Type => Visit_Enumeration_Type (E); when K_Exception_Declaration => Visit_Exception_Declaration (E); when K_Forward_Interface_Declaration => Visit_Forward_Interface_Declaration (E); when K_Interface_Declaration => Visit_Interface_Declaration (E); when K_Operation_Declaration => Visit_Operation_Declaration (E); when K_Structure_Type => Visit_Structure_Type (E); when K_Union_Type => Visit_Union_Type (E); when K_Attribute_Declaration => Visit_Attribute_Declaration (E); when K_Type_Declaration => Visit_Type_Declaration (E); when K_Native_Type => Visit_Native_Type (E); when K_Module => Visit_Module (E); when others => null; end case; end Visit; --------------------------------- -- Visit_Attribute_Declaration -- --------------------------------- procedure Visit_Attribute_Declaration (E : Node_Id) is A : Node_Id; begin -- IDL attributes are expanded into a couple of Get/Set IDL -- subprograms. We only generate the Repository ID when -- visiting IDL attribute nodes. A := First_Entity (Declarators (E)); while Present (A) loop Set_Main_Spec; -- Insert repository declaration. We don't add the -- Repository_Id declaration in the case of an Attribute -- inherited from the second until the last parent. These -- attributes are known by the fact that their parent -- interface is different from the current interface. if Scope_Entity (Identifier (A)) = Corresponding_Entity (FE_Node (Current_Entity)) then Append_To (Visible_Part (Current_Package), Map_Repository_Id_Declaration (A)); end if; A := Next_Entity (A); end loop; end Visit_Attribute_Declaration; -------------------------------- -- Visit_Constant_Declaration -- -------------------------------- procedure Visit_Constant_Declaration (E : Node_Id) is N : Node_Id; Expression : Node_Id; Constant_Type : constant Node_Id := Map_Expanded_Name (Type_Spec (E)); K : FEN.Node_Kind; Otyp : constant Node_Id := FEU.Get_Original_Type_Specifier (Type_Spec (E)); begin Set_Main_Spec; case FEU.Expr_Value (E).K is when K_Short .. K_Unsigned_Long_Long | K_Octet | K_Fixed_Point_Type | K_Float .. K_Long_Double => -- If the constant has integer or real type and has negative -- value, use the expanded name for "-" operator because it -- might not be directly visible. declare Minus : Node_Id; begin if Negative (Value_Id'(FEU.Expr_Value (E))) then Minus := Make_Selected_Component (Get_Parent_Unit_Name (Constant_Type), Make_Defining_Identifier (SN (S_Minus))); Expression := Make_Subprogram_Call (Minus, New_List (Make_Literal (New_Value (-FEU.Expr_Value (E))))); else Expression := Make_Literal (FEU.Expr_Value (E)); end if; end; when K_Enumerator => -- If it's an enumeration literal, we need to use an expanded -- name. Expression := Make_Literal_With_Parent (FEU.Expr_Value (E), Parent => Get_Parent_Unit_Name (Constant_Type)); when others => Expression := Make_Literal (FEU.Expr_Value (E)); end case; -- If the constant type is of a string type, it needs to be -- converted using To_CORBA_[Wide_]String (for the unbounded case), -- To_Bounded_[Wide_]String (for the bounded case). -- Determine the expanded name of these subprograms according to -- whether the type is directly CORBA.[Wide_]String, or a derived -- type thereof. K := FEN.Kind (Otyp); case K is when K_String | K_String_Type | K_Wide_String | K_Wide_String_Type => declare S : Node_Id := No_Node; -- Selected_Component denoting a conversion function, for -- the case where the constant's type is not a root -- unbounded string type. Converter : Node_Id; begin case K is when K_String => Converter := RE (RE_To_CORBA_String); when K_Wide_String => Converter := RE (RE_To_CORBA_Wide_String); when K_String_Type | K_Wide_String_Type => declare Str_Instance : constant Node_Id := Defining_Identifier (Instantiation_Node (BE_Node (Otyp))); Id : Node_Id; begin if K = K_String_Type then Id := Make_Identifier (SN ((S_To_Bounded_String))); else Id := Make_Identifier (SN ((S_To_Bounded_Wide_String))); end if; Converter := Make_Selected_Component (Str_Instance, Id); end; when others => raise Program_Error; end case; if Otyp = Type_Spec (E) then Expression := Make_Subprogram_Call (Converter, New_List (Expression)); else S := Make_Selected_Component (Get_Parent_Unit_Name (Get_Type_Definition_Node (Type_Spec (E))), Selector_Name (Converter)); -- The call to Copy_Node ensures the addition of -- necessary WITH clauses. Expression := Make_Subprogram_Call (Copy_Node (S), New_List (Expression)); end if; end; when others => null; end case; N := Make_Object_Declaration (Defining_Identifier => Map_Defining_Identifier (E), Constant_Present => True, Object_Definition => Constant_Type, Expression => Expression); Bind_FE_To_BE (Identifier (E), N, B_Stub); Append_To (Visible_Part (Current_Package), N); end Visit_Constant_Declaration; ---------------------------- -- Visit_Enumeration_Type -- ---------------------------- procedure Visit_Enumeration_Type (E : Node_Id) is Enumerator : Node_Id; Enum_Literals : List_Id; Enum_Literal : Node_Id; Enum_Type_Decl : Node_Id; begin Set_Main_Spec; Enum_Literals := New_List; Enumerator := First_Entity (Enumerators (E)); while Present (Enumerator) loop Enum_Literal := Map_Defining_Identifier (Enumerator); Append_To (Enum_Literals, Enum_Literal); Enumerator := Next_Entity (Enumerator); end loop; Enum_Type_Decl := Make_Full_Type_Declaration (Map_Defining_Identifier (E), Make_Enumeration_Type_Definition (Enum_Literals)); Bind_FE_To_BE (Identifier (E), Enum_Type_Decl, B_Stub); Bind_FE_To_BE (Identifier (E), Enum_Type_Decl, B_Type_Def); Append_To (Visible_Part (Current_Package), Enum_Type_Decl); Append_To (Visible_Part (Current_Package), Map_Repository_Id_Declaration (E)); end Visit_Enumeration_Type; --------------------------------- -- Visit_Exception_Declaration -- --------------------------------- procedure Visit_Exception_Declaration (E : Node_Id) is Identifier : Node_Id; N : Node_Id; begin Set_Main_Spec; -- Declaration of the exception Get_Name_String (To_Ada_Name (IDL_Name (FEN.Identifier (E)))); Identifier := Make_Defining_Identifier (Name_Find); N := Make_Exception_Declaration (Identifier); Append_To (Visible_Part (Current_Package), N); -- Link the frontend node to the backend exception Bind_FE_To_BE (FEN.Identifier (E), N, B_Stub); -- Definition of the "Exception_Name"_Members type Get_Name_String (To_Ada_Name (IDL_Name (FEN.Identifier (E)))); Add_Str_To_Name_Buffer ("_Members"); Identifier := Make_Defining_Identifier (Name_Find); N := Make_Full_Type_Declaration (Defining_Identifier => Identifier, Type_Definition => Make_Derived_Type_Definition (RE (RE_IDL_Exception_Members), Make_Record_Definition (Map_Members_Definition (Members (E))))); Append_To (Visible_Part (Current_Package), N); -- Link the frontend node to the backend type definition Bind_FE_To_BE (FEN.Identifier (E), N, B_Type_Def); -- Insert repository declaration Append_To (Visible_Part (Current_Package), Map_Repository_Id_Declaration (E)); -- Insert the Get_Members procedure specification N := Map_Get_Members_Spec (Make_Selected_Component (Defining_Identifier (Stubs_Package (Current_Entity)), Identifier)); Append_To (Visible_Part (Current_Package), N); end Visit_Exception_Declaration; ----------------------------------------- -- Visit_Forward_Interface_Declaration -- ----------------------------------------- procedure Visit_Forward_Interface_Declaration (E : Node_Id) is Identifier : Node_Id; N : Node_Id; Ref_Type_Node : Node_Id; begin -- The "Interface_Name"_Forward package is instantiated : -- * In the module main package if the interface is -- declared in a module. -- * In the XXXX_IDL_FILE main package if the interface is -- declared outside any module. Set_Main_Spec; -- Setting the interface as forwarded to be able to add the -- additional code related to forwarding. Set_Forwarded (Forward (E)); Get_Name_String (To_Ada_Name (IDL_Name (FEN.Identifier (E)))); Add_Str_To_Name_Buffer ("_Forward"); Identifier := Make_Defining_Identifier (Name_Find); -- Generic Package Instantiation N := Make_Package_Instantiation (Defining_Identifier => Identifier, Generic_Package => RU (RU_CORBA_Forward)); Bind_FE_To_BE (FEN.Identifier (E), N, B_Instantiation); -- Adding the binding between the interface declaration and -- the instantiated package. Bind_FE_To_BE (FEN.Identifier (Forward (E)), N, B_Forward); Append_To (Visible_Part (Current_Package), N); -- This workaround is used to permit the use of the Ref type -- declared in the instantiated package. Identifier := Map_Ref_Type (E); Ref_Type_Node := Make_Full_Type_Declaration (Identifier, Make_Derived_Type_Definition (Subtype_Indication => Map_Ref_Type_Ancestor (E, False), Record_Extension_Part => Make_Record_Type_Definition (Record_Definition => Make_Record_Definition (No_List))), Parent => N); -- We don't add this node! Bind_FE_To_BE (FEN.Identifier (E), Ref_Type_Node, B_Type_Def); end Visit_Forward_Interface_Declaration; --------------------------------- -- Visit_Interface_Declaration -- --------------------------------- procedure Visit_Interface_Declaration (E : Node_Id) is P : Node_Id; N : Node_Id; L : List_Id; I : Node_Id; Is_Local : constant Boolean := Is_Local_Interface (E); begin P := Map_IDL_Unit (E); Append_To (Packages (Current_Entity), P); Push_Entity (P); Set_Main_Spec; L := Interface_Spec (E); -- Checking whether the interface inherits from other -- interfaces or not. -- Extract from the Ada mapping specifications : -- -- "Single inheritance of IDL interface is directly mapped -- to inheritance in the Ada mapping; that is, an interface -- with a parent is mapped to a tagged type that is derived -- from the tagged type mapped from the parent. The -- definitions of types, constants, and exceptions in the -- parent package are renamed or sub-typed so that they are -- also inherited in accordance with the IDL semantics" -- -- "The client side of multiple inheritance in IDL maps to -- single Ref tagged type, as with single inheritance, where -- the parent type is the first interface listed in the IDL -- parent interface list. The IDL compiler must generate -- additional primitive subprograms that correspond to the -- operations inherited from the second and subsequent -- parent interfaces listed in the IDL." if FEU.Is_Empty (L) then -- The reference type ancestor depends on the nature of -- the interface (unconstrained, local or abstract) N := Map_Ref_Type_Ancestor (E); else N := Map_Expanded_Name (First_Entity (L)); end if; -- The designator of the reference type is also dependant of -- the nature of the interface (unconstrained, local or -- abstract). I := Map_Ref_Type (E); N := Make_Full_Type_Declaration (I, Make_Derived_Type_Definition (Subtype_Indication => N, Record_Extension_Part => Make_Record_Type_Definition (Record_Definition => Make_Record_Definition (No_List)))); Append_To (Visible_Part (Current_Package), N); -- An Interface Declaration is also a type definition. So we -- link the type declaration node to the IDL interface node -- to be able to fetch it when needed. Bind_FE_To_BE (Identifier (E), N, B_Type_Def); N := Map_Repository_Id_Declaration (E); Append_To (Visible_Part (Current_Package), N); Set_FE_Node (N, Identifier (E)); N := First_Entity (Interface_Body (E)); while Present (N) loop Visit (N); N := Next_Entity (N); end loop; -- In case of multiple inheritance, generate the mappings -- for the operations and attributes of the parents except -- the first one which is handled by the Ada inheritence -- mechanism. Map_Inherited_Entities_Specs (Current_Interface => E, Visit_Operation_Subp => Visit_Operation_Declaration'Access, Stub => True); -- Local interfaces don't have Is_A function in their stub -- spec. if not Is_Local then N := Visible_Is_A_Spec (E); Append_To (Visible_Part (Current_Package), N); end if; -- If we handle a forwarded interface we must instantiate -- the "Interface_Name"_Forward.Convert package. if Is_Forwarded (E) then declare Pack_Inst : Node_Id; Gen_Pack : Node_Id; begin Pack_Inst := RE (RE_Convert_Forward); Gen_Pack := Make_Selected_Component (Expand_Designator (Forward_Node (BE_Node (Identifier (E)))), RE (RE_Convert)); -- To guarantee that the "with" clause of the generic -- package would be added, we use the Copy_Expanded_Name -- function. N := Make_Package_Instantiation (Defining_Identifier => Pack_Inst, Generic_Package => Copy_Expanded_Name (Gen_Pack), Parameter_List => New_List (Map_Ref_Type (E))); Append_To (Visible_Part (Current_Package), N); end; end if; if not Is_Local then N := Local_Is_A_Spec; Append_To (Private_Part (Current_Package), N); end if; Pop_Entity; end Visit_Interface_Declaration; ------------------ -- Visit_Module -- ------------------ procedure Visit_Module (E : Node_Id) is D : Node_Id; S : Node_Id; begin if not Map_Particular_CORBA_Parts (E, PK_Stub_Spec) then S := Map_IDL_Unit (E); Append_To (Packages (Current_Entity), S); Push_Entity (S); Set_Main_Spec; Append_To (Visible_Part (Current_Package), Map_Repository_Id_Declaration (E)); D := First_Entity (Definitions (E)); while Present (D) loop Visit (D); D := Next_Entity (D); end loop; Pop_Entity; end if; end Visit_Module; --------------------------------- -- Visit_Operation_Declaration -- --------------------------------- procedure Visit_Operation_Declaration (E : Node_Id; Binding : Boolean := True) is Subp_Spec : Node_Id; Profile : List_Id; IDL_Param : Node_Id; Ada_Param : Node_Id; Mode : Mode_Id := Mode_In; Returns : Node_Id := No_Node; Type_Designator : Node_Id; Container : constant Node_Id := Scope_Entity (Identifier (E)); function Map_Parameter_Type_Designator (Entity : Node_Id) return Node_Id; -- Maps Ada type from the entity type specifier ----------------------------------- -- Map_Parameter_Type_Designator -- ----------------------------------- function Map_Parameter_Type_Designator (Entity : Node_Id) return Node_Id is Result : Node_Id; begin Result := Map_Expanded_Name (Type_Spec (Entity)); if Is_Class_Wide (Entity) then Result := Make_Attribute_Reference (Result, A_Class); end if; return Result; end Map_Parameter_Type_Designator; -- Start of processing for Visit_Operation_Declaration begin Profile := New_List; -- Create a dispatching parameter Ada_Param := Make_Parameter_Specification (Make_Defining_Identifier (PN (P_Self)), Map_Ref_Type (Container)); Append_To (Profile, Ada_Param); -- Create an Ada subprogram parameter for each IDL subprogram -- parameter. Check whether there is one inout or out parameter. IDL_Param := First_Entity (Parameters (E)); while Present (IDL_Param) loop Type_Designator := Map_Parameter_Type_Designator (IDL_Param); Set_FE_Node (Type_Designator, Type_Spec (IDL_Param)); Ada_Param := Make_Parameter_Specification (Map_Defining_Identifier (Declarator (IDL_Param)), Type_Designator, FEN.Parameter_Mode (IDL_Param)); if FEN.Parameter_Mode (IDL_Param) /= Mode_In then Mode := Mode_Out; end if; Append_To (Profile, Ada_Param); IDL_Param := Next_Entity (IDL_Param); end loop; -- If the operation has a non-empty context specification, add an -- extra parameter 'In_Context'. -- XXX : The contexts are not completely implemented in PolyORB. Once -- they are implemented a routine which tests the consistency of the -- context must be generated. declare L : constant List_Id := Contexts (E); begin if not FEU.Is_Empty (L) then Ada_Param := Make_Parameter_Specification (Make_Defining_Identifier (PN (P_In_Context)), RE (RE_Ref_8), Mode_In, RE (RE_Get_Default_Context)); Append_To (Profile, Ada_Param); end if; end; -- For a non-void IDL operation, check for parameters of mode out or -- inout parameters, in which case it must be mapped to an Ada -- procedure, instead of an Ada function. if FEN.Kind (Type_Spec (E)) /= K_Void then if Mode = Mode_In then Returns := Map_Parameter_Type_Designator (E); Set_FE_Node (Returns, Type_Spec (E)); -- If the IDL function is mapped to an Ada procedure, add a new -- out parameter Returns to hold the returned value. else Type_Designator := Map_Parameter_Type_Designator (E); Set_FE_Node (Type_Designator, Type_Spec (E)); Ada_Param := Make_Parameter_Specification (Make_Defining_Identifier (PN (P_Returns)), Type_Designator, Mode_Out); Append_To (Profile, Ada_Param); end if; end if; -- Add the subprogram to main specification Set_Main_Spec; Subp_Spec := Make_Subprogram_Specification (Map_Defining_Identifier (E), Profile, Returns); Append_To (Visible_Part (Current_Package), Subp_Spec); -- We don't add the Repository_Id declaration in the case of -- an Operation inherited from the second until the last -- parent. -- We don't add repository declaration in the case of an -- operation expanded from an attribute declaration. -- Operations that are expanded from an attribute -- declaration are known because the identifiers have no -- locations. if Scope_Entity (Identifier (E)) = Corresponding_Entity (FE_Node (Current_Entity)) and then FEN.Loc (Identifier (E)) /= No_Location then Append_To (Visible_Part (Current_Package), Map_Repository_Id_Declaration (E)); end if; if Binding then Bind_FE_To_BE (Identifier (E), Subp_Spec, B_Stub); end if; end Visit_Operation_Declaration; ------------------------- -- Visit_Specification -- ------------------------- procedure Visit_Specification (E : Node_Id) is Definition : Node_Id; begin Push_Entity (Stub_Node (BE_Node (Identifier (E)))); Definition := First_Entity (Definitions (E)); while Present (Definition) loop Visit (Definition); Definition := Next_Entity (Definition); end loop; Pop_Entity; end Visit_Specification; -------------------------- -- Visit_Structure_Type -- -------------------------- procedure Visit_Structure_Type (E : Node_Id) is N : Node_Id; begin Set_Main_Spec; N := Make_Full_Type_Declaration (Map_Defining_Identifier (E), Make_Record_Type_Definition (Make_Record_Definition (Map_Members_Definition (Members (E))))); Bind_FE_To_BE (Identifier (E), N, B_Stub); Bind_FE_To_BE (Identifier (E), N, B_Type_Def); Append_To (Visible_Part (Current_Package), N); Append_To (Visible_Part (Current_Package), Map_Repository_Id_Declaration (E)); end Visit_Structure_Type; ---------------------------- -- Visit_Type_Declaration -- ---------------------------- procedure Visit_Type_Declaration (E : Node_Id) is D : Node_Id; T : Node_Id; N : Node_Id; Is_Subtype : Boolean := False; Type_Spec_Node : Node_Id; begin Set_Main_Spec; Type_Spec_Node := Type_Spec (E); if FEN.Kind (Type_Spec_Node) = K_Fixed_Point_Type then -- The fixed type shall be mapped to an equivalent Ada -- decimal type which will be the original type -- definition of all the declarators of the IDL type -- declaration. declare Fixed_Type_Node : Node_Id; Fixed_Name : constant Name_Id := Map_Fixed_Type_Name (Type_Spec_Node); begin T := Make_Defining_Identifier (Fixed_Name); Fixed_Type_Node := Make_Full_Type_Declaration (Defining_Identifier => T, Type_Definition => Make_Decimal_Type_Definition (Type_Spec_Node)); Append_To (Visible_Part (Current_Package), Fixed_Type_Node); T := Make_Selected_Component (Defining_Identifier (Stubs_Package (Current_Entity)), T); -- Link the front end node to the Ada type definition Bind_FE_To_BE (Type_Spec_Node, Fixed_Type_Node, B_Type_Def); end; elsif FEN.Kind (Type_Spec_Node) = K_Sequence_Type then -- The sequence type is mapped into a generic package -- instantiation. The Sequence type of the instantiated -- package will be the original type of each one of the -- declarators of the type declaration. declare Seq_Package_Inst : Node_Id; Bounded : constant Boolean := Present (Max_Size (Type_Spec_Node)); CORBA_Seq : Node_Id; Seq_Package_Name : Name_Id; Seq_Package_Node : Node_Id; Type_Node : Node_Id; begin -- We create an Instantiation of the generic package -- CORBA.Sequences.Bounded or -- CORBA.Sequences.Unbounded. Then, the sequence type -- is derived from the "Sequence" Type of the -- instantiated package. -- Creating the package name conforming to the Ada -- mapping specification. Seq_Package_Name := Map_Sequence_Pkg_Name (Type_Spec_Node); if Bounded then CORBA_Seq := RU (RU_CORBA_Sequences_Bounded); else CORBA_Seq := RU (RU_CORBA_Sequences_Unbounded); end if; -- Building the sequence package node Type_Node := Map_Expanded_Name (Type_Spec (Type_Spec_Node)); Seq_Package_Node := Make_Defining_Identifier (Seq_Package_Name); if Bounded then Seq_Package_Inst := Make_Package_Instantiation (Defining_Identifier => Seq_Package_Node, Generic_Package => CORBA_Seq, Parameter_List => New_List (Type_Node, Make_Literal (FEU.Expr_Value (Max_Size (Type_Spec_Node))))); else Seq_Package_Inst := Make_Package_Instantiation (Defining_Identifier => Seq_Package_Node, Generic_Package => CORBA_Seq, Parameter_List => New_List (Type_Node)); end if; Append_To (Visible_Part (Current_Package), Seq_Package_Inst); -- Link the frontend node to the package instantiation Bind_FE_To_BE (Type_Spec_Node, Seq_Package_Inst, B_Instantiation); T := Make_Selected_Component (Make_Selected_Component (Defining_Identifier (Stubs_Package (Current_Entity)), Seq_Package_Node), Make_Identifier (TN (T_Sequence))); -- Link the frontend node to the Sequence type designator Bind_FE_To_BE (Type_Spec_Node, T, B_Type_Def); end; elsif FEN.Kind (Type_Spec_Node) = K_String_Type or else FEN.Kind (Type_Spec_Node) = K_Wide_String_Type then -- The IDL bounded string or wide string types are mapped -- into a generic package instantiation. The -- Bounded_String type or Bounded_Wide_String type of the -- instantiated package will be the original type of each -- one of the declarators of the type declaration. declare Str_Package_Inst : Node_Id; Pkg_Name : Name_Id; Pkg_Node : Node_Id; CORBA_String_Pkg : Node_Id; begin -- We create an Instantiation of the generic package -- CORBA.Bounded_Strings (or -- CORBA.Bounded_Wide_Strings). Then, the string type -- is derived from the 'Bounded_String' type (or the -- 'Bounded_Wide_String' type of the instantiated -- package. -- Creating the package name conforming to the Ada -- mapping specification. Pkg_Name := Map_String_Pkg_Name (Type_Spec_Node); if FEN.Kind (Type_Spec_Node) = K_Wide_String_Type then CORBA_String_Pkg := RU (RU_CORBA_Bounded_Wide_Strings); T := Make_Identifier (TN (T_Bounded_Wide_String)); else CORBA_String_Pkg := RU (RU_CORBA_Bounded_Strings); T := Make_Identifier (TN (T_Bounded_String)); end if; -- Building the string package node Pkg_Node := Make_Defining_Identifier (Pkg_Name); Str_Package_Inst := Make_Package_Instantiation (Defining_Identifier => Pkg_Node, Generic_Package => CORBA_String_Pkg, Parameter_List => New_List (Make_Literal (FEU.Expr_Value (Max_Size (Type_Spec_Node))))); Append_To (Visible_Part (Current_Package), Str_Package_Inst); -- Link the frontend node to the package instantiation Bind_FE_To_BE (Type_Spec_Node, Str_Package_Inst, B_Instantiation); -- Setting the correct parent unit name of the -- instantiated type. T := Make_Selected_Component (Make_Selected_Component (Defining_Identifier (Stubs_Package (Current_Entity)), Pkg_Node), T); -- Link the frontend node to the Sequence type designator Bind_FE_To_BE (Type_Spec_Node, T, B_Type_Def); end; else -- General case T := Map_Expanded_Name (Type_Spec_Node); end if; -- According to the Ada mapping specification. Most of the -- type definitions in an IDL file should be mapped to : -- "type ... is new ...;". However, there are exception to -- this rule : "interface Base {...}; typedef Base Root;" -- should be mapped : "subtype Root is Base.Ref;" -- Determining whether we map the type definition to a "type -- ... is new ...;" or a "subtype ... is ...;" statement. Is_Subtype := Is_Object_Type (Type_Spec (E)); D := First_Entity (Declarators (E)); while Present (D) loop if Kind (D) = K_Complex_Declarator then N := Make_Full_Type_Declaration (Defining_Identifier => Map_Defining_Identifier (D), Type_Definition => Make_Array_Type_Definition (Map_Range_Constraints (FEN.Array_Sizes (D)), T)); else N := Make_Full_Type_Declaration (Defining_Identifier => Map_Defining_Identifier (D), Type_Definition => Make_Derived_Type_Definition (Subtype_Indication => T, Record_Extension_Part => No_Node, Is_Subtype => Is_Subtype), Is_Subtype => Is_Subtype); end if; -- Create the bindings between the IDL tree and the Ada -- tree. Bind_FE_To_BE (Identifier (D), N, B_Stub); Bind_FE_To_BE (Identifier (D), N, B_Type_Def); Append_To (Visible_Part (Current_Package), N); Append_To (Visible_Part (Current_Package), Map_Repository_Id_Declaration (D)); D := Next_Entity (D); end loop; end Visit_Type_Declaration; ----------------------- -- Visit_Native_Type -- ----------------------- procedure Visit_Native_Type (E : Node_Id) is -- Extract from the CORBA 3.0.3 spec (§3.11.5) concerning -- native types : -- "This declaration defines a new type with the specified -- name. A native type is similar to an IDL basic type. The -- possible values of a native type are language-mapping -- dependent, as are the means for constructing them and -- manipulating them. Any interface that defines a native -- type requires each language mapping to define how the -- native type is mapped into that programming language." -- So, we put a comment to indicate that. N : Node_Id; Type_Name : constant Name_Id := IDL_Name (Identifier (Declarator (E))); begin Set_Str_To_Name_Buffer ("Type "); Get_Name_String_And_Append (Type_Name); Add_Str_To_Name_Buffer (" is implementation defined"); N := Make_Ada_Comment (Name_Find); Append_To (Visible_Part (Current_Package), N); end Visit_Native_Type; ---------------------- -- Visit_Union_Type -- ---------------------- procedure Visit_Union_Type (E : Node_Id) is N : Node_Id; S : constant Node_Id := Switch_Type_Spec (E); Orig_Type : constant Node_Id := FEU.Get_Original_Type_Specifier (S); T : Node_Id; L : List_Id; Literal_Parent : Node_Id := No_Node; begin Set_Main_Spec; T := Map_Expanded_Name (S); -- If the discriminator is an enumeration type, we must put -- the full names of literals if FEN.Kind (Orig_Type) = K_Enumeration_Type then Literal_Parent := Map_Expanded_Name (Scope_Entity (Identifier (Orig_Type))); end if; L := New_List; Append_To (L, Make_Variant_Part (Make_Defining_Identifier (CN (C_Switch)), Map_Variant_List (Switch_Type_Body (E), Literal_Parent))); N := Make_Full_Type_Declaration (Map_Defining_Identifier (E), Make_Record_Type_Definition (Make_Record_Definition (L)), New_List (Make_Component_Declaration (Make_Defining_Identifier (CN (C_Switch)), T, Make_Attribute_Reference (T, A_First)))); Bind_FE_To_BE (Identifier (E), N, B_Stub); Bind_FE_To_BE (Identifier (E), N, B_Type_Def); Append_To (Visible_Part (Current_Package), N); Append_To (Visible_Part (Current_Package), Map_Repository_Id_Declaration (E)); end Visit_Union_Type; end Package_Spec; package body Package_Body is function Stub_Statements (E : Node_Id) return List_Id; -- Creates the statement list of the stub body function Stub_Declarations (E : Node_Id) return List_Id; -- Creates the declaration list of the stub body procedure Visit_Interface_Declaration (E : Node_Id); procedure Visit_Operation_Declaration (E : Node_Id); procedure Visit_Specification (E : Node_Id); procedure Visit_Exception_Declaration (E : Node_Id); procedure Visit_Module (E : Node_Id); ----------- -- Visit -- ----------- procedure Visit (E : Node_Id) is begin case FEN.Kind (E) is when K_Specification => Visit_Specification (E); when K_Exception_Declaration => Visit_Exception_Declaration (E); when K_Interface_Declaration => Visit_Interface_Declaration (E); when K_Operation_Declaration => Visit_Operation_Declaration (E); when K_Module => Visit_Module (E); when others => null; end case; end Visit; --------------------------------- -- Visit_Exception_Declaration -- --------------------------------- procedure Visit_Exception_Declaration (E : Node_Id) is Spec : Node_Id := No_Node; D : constant List_Id := No_List; S : constant List_Id := New_List; N : Node_Id; Parameters : List_Id; begin Set_Main_Body; Spec := Map_Get_Members_Spec (Expand_Designator (Type_Def_Node (BE_Node (FEN.Identifier (E))))); Parameters := New_List; Append_To (Parameters, Make_Defining_Identifier (PN (P_From))); Append_To (Parameters, Make_Defining_Identifier (PN (P_To))); N := Make_Subprogram_Call (RE (RE_User_Get_Members), Parameters); Append_To (S, N); N := Make_Subprogram_Body (Specification => Spec, Declarations => D, Statements => S); Append_To (Statements (Current_Package), N); end Visit_Exception_Declaration; ------------------ -- Visit_Module -- ------------------ procedure Visit_Module (E : Node_Id) is S : Node_Id; D : Node_Id; begin if not Map_Particular_CORBA_Parts (E, PK_Stub_Body) then S := Stub_Node (BE_Node (Identifier (E))); Push_Entity (S); D := First_Entity (Definitions (E)); while Present (D) loop Visit (D); D := Next_Entity (D); end loop; Pop_Entity; end if; end Visit_Module; --------------------- -- Visit_Interface -- --------------------- procedure Visit_Interface_Declaration (E : Node_Id) is N : Node_Id; Is_Local : constant Boolean := Is_Local_Interface (E); begin N := BEN.Parent (Type_Def_Node (BE_Node (Identifier (E)))); Push_Entity (BEN.IDL_Unit (Package_Declaration (N))); Set_Main_Body; N := First_Entity (Interface_Body (E)); while Present (N) loop Visit (N); N := Next_Entity (N); end loop; -- In case of multiple inheritance, generate the mappings -- for the operations and attributes of the parents except -- the first one. Map_Inherited_Entities_Bodies (Current_Interface => E, Visit_Operation_Subp => Visit_Operation_Declaration'Access, Stub => True); if not Is_Local then N := Visible_Is_A_Body (E); Append_To (Statements (Current_Package), N); N := Local_Is_A_Body (E); Append_To (Statements (Current_Package), N); end if; Pop_Entity; end Visit_Interface_Declaration; --------------------------------- -- Visit_Operation_Declaration -- --------------------------------- procedure Visit_Operation_Declaration (E : Node_Id) is Spec : constant Node_Id := Stub_Node (BE_Node (Identifier (E))); Declarations : List_Id; Statements : List_Id; N : Node_Id; begin Set_Main_Body; -- The declarative part of the subprogram Declarations := Stub_Declarations (E); -- The statements of the subprogram Statements := Stub_Statements (E); N := Make_Subprogram_Body (Spec, Declarations, Statements); Append_To (BEN.Statements (Current_Package), N); end Visit_Operation_Declaration; ------------------------- -- Visit_Specification -- ------------------------- procedure Visit_Specification (E : Node_Id) is Definition : Node_Id; begin Push_Entity (Stub_Node (BE_Node (Identifier (E)))); Definition := First_Entity (Definitions (E)); while Present (Definition) loop Visit (Definition); Definition := Next_Entity (Definition); end loop; Pop_Entity; end Visit_Specification; --------------------- -- Stub_Statements -- --------------------- function Stub_Statements (E : Node_Id) return List_Id is pragma Assert (FEN.Kind (E) = K_Operation_Declaration); Statements : constant List_Id := New_List; N : Node_Id; M : Node_Id; C : Node_Id; P : Node_Id; Profile : List_Id; I : Node_Id; Param : Node_Id; R : Name_Id; Operation_Name : constant Name_Id := FEN.IDL_Name (Identifier (E)); Argument_Name : Name_Id; Container : constant Node_Id := Scope_Entity (Identifier (E)); Local_Interface : constant Boolean := (FEN.Kind (Container) = K_Interface_Declaration and then Is_Local_Interface (Container)); NVList_Name : Name_Id; -- The flags below indicate whether the operation is mapped -- to an Ada function or an Ada procedure. Has_Out_Params : constant Boolean := Contains_Out_Parameters (E); Non_Void : constant Boolean := FEN.Kind (Type_Spec (E)) /= K_Void; Is_Function : constant Boolean := Non_Void and then not Has_Out_Params; begin -- Generate nil reference check for Self -- FIXME: In the case of an abstract interface, we should test -- whether the Object passed is a concrete interface type, in which -- which case we pass it as a reference, or whether it is a value -- type, in which case we pass it as a value. However, since -- ValueTypes are not supported yet, we do only the first test. C := Make_Subprogram_Call (RE (RE_Is_Nil), New_List (Make_Subprogram_Call (RE (RE_Ref_2), New_List (Make_Defining_Identifier (PN (P_Self)))))); N := Make_Subprogram_Call (RE (RE_Raise_Inv_Objref), New_List (RE (RE_Default_Sys_Member))); N := Make_If_Statement (Condition => C, Then_Statements => New_List (N)); Append_To (Statements, N); -- If the interface is local, we just call the -- implementation. if Local_Interface then declare Implem_Node : Node_Id; Impl_Profile : constant List_Id := New_List; Param : Node_Id; begin N := Make_Subprogram_Call (Make_Defining_Identifier (SN (S_Entity_Of)), New_List (Make_Defining_Identifier (PN (P_Self)))); -- Get the Object_Ptr type full name Implem_Node := Expand_Designator (Next_Node (Impl_Node (BE_Node (Identifier (Container))))); N := Make_Subprogram_Call (Implem_Node, New_List (N)); Append_To (Impl_Profile, N); -- Adding the rest of the parameters P := First_Entity (Parameters (E)); while Present (P) loop Param := Map_Defining_Identifier (Declarator (P)); -- If the parameter type is a class-wide type, -- we cast it. if Is_Class_Wide (P) then Param := Make_Type_Conversion (Get_Type_Definition_Node (Type_Spec (P)), Param); end if; Append_To (Impl_Profile, Param); P := Next_Entity (P); end loop; -- If a non void operation has OUT parameters, append -- the returns additional parameter. if Non_Void and then not Is_Function then Append_To (Impl_Profile, Make_Identifier (PN (P_Returns))); end if; Implem_Node := Expand_Designator (Impl_Node (BE_Node (Identifier (E)))); N := Make_Subprogram_Call (Implem_Node, Impl_Profile); if Is_Function then N := Make_Return_Statement (N); end if; Append_To (Statements, N); return Statements; end; end if; -- The argument list nature is different depending on the -- way requests are handled (SII or DII) -- Create argument list if not Use_SII then Set_Str_To_Name_Buffer ("Create the Argument list"); Append_To (Statements, Make_Ada_Comment (Name_Find)); C := Make_Subprogram_Call (RE (RE_Create), New_List (Make_Defining_Identifier (VN (V_Argument_List)))); Append_To (Statements, C); end if; -- Add arguments to argument list P := First_Entity (Parameters (E)); if Present (P) then Set_Str_To_Name_Buffer ("Fill the Argument list"); Append_To (Statements, Make_Ada_Comment (Name_Find)); end if; while Present (P) loop Argument_Name := To_Ada_Name (IDL_Name (Identifier (Declarator (P)))); if Use_Compiler_Alignment then C := Make_Identifier (Argument_Name); Marshall_Args (Statements, Type_Spec (P), C); elsif Use_SII then -- Updating the record field corresponding to the -- parameter When the parameter mode is IN or INOUT if FEN.Parameter_Mode (P) = Mode_In or else FEN.Parameter_Mode (P) = Mode_Inout then -- Record field: N := Make_Selected_Component (PN (P_Arg_List), Argument_Name); -- Parameter: -- If the parameter type is a class-wide type, -- we cast it. M := Map_Defining_Identifier (Declarator (P)); if Is_Class_Wide (P) then M := Make_Type_Conversion (Get_Type_Definition_Node (Type_Spec (P)), M); end if; N := Make_Assignment_Statement (N, M); -- Assignment : Append_To (Statements, N); end if; else -- Preparing the parameter list of the Add_Item call Profile := New_List; -- 1st param N := Make_Identifier (VN (V_Argument_List)); Append_To (Profile, N); -- 2nd param N := Make_Identifier (Map_Argument_Identifier_Name (Argument_Name, Operation_Name)); Append_To (Profile, N); -- 3rd param N := Make_Identifier (Map_Argument_Any_Name (Argument_Name)); N := Make_Type_Conversion (RE (RE_Any_1), N); -- If the operation is oneway, transmit a copy of the "Any" if Is_Oneway (E) then N := Make_Subprogram_Call (RE (RE_Copy_Any), New_List (N)); end if; Append_To (Profile, N); -- 4th param if FEN.Parameter_Mode (P) = Mode_Out then N := RE (RE_ARG_OUT_1); elsif FEN.Parameter_Mode (P) = Mode_In then N := RE (RE_ARG_IN_1); else N := RE (RE_ARG_INOUT_1); end if; Append_To (Profile, N); -- Call the Add_Item procedure N := Make_Subprogram_Call (RE (RE_Add_Item_1), Profile); Append_To (Statements, N); end if; P := Next_Entity (P); end loop; -- If the operation may raise IDL exeptions, we generate the -- the code that initializes the operation exception list. if not FEU.Is_Empty (Exceptions (E)) then declare Excep_FE : Node_Id; Excep_TC : Node_Id; begin Set_Str_To_Name_Buffer ("Create the Exception list"); Append_To (Statements, Make_Ada_Comment (Name_Find)); N := Make_Subprogram_Call (RE (RE_Create_List_1), New_List (Make_Identifier (VN (V_Exception_List)))); Append_To (Statements, N); Excep_FE := First_Entity (Exceptions (E)); while Present (Excep_FE) loop -- Getting the TC_"Exception_Name" identifier. It -- is declared at the first place in the Helper -- spec. Excep_TC := Get_TC_Node (Excep_FE); N := Make_Subprogram_Call (RE (RE_Add_1), New_List (Make_Identifier (VN (V_Exception_List)), Excep_TC)); Append_To (Statements, N); Excep_FE := Next_Entity (Excep_FE); end loop; end; end if; -- The subprogram that sets the operation result is not -- needed when we use SII if not Use_SII then -- Create the inlined subprogram that set the Result name -- value. Profile := New_List; -- Build the record aggregate -- 1st component association N := Make_Component_Association (Selector_Name => Make_Identifier (PN (P_Name)), Expression => Make_Identifier (Map_Result_Identifier_Name (Operation_Name))); Append_To (Profile, N); -- 2nd component association if Non_Void then Param := Get_TC_Node (Type_Spec (E)); else Param := RE (RE_TC_Void); end if; C := Make_Subprogram_Call (Defining_Identifier => RE (RE_Get_Empty_Any), Actual_Parameter_Part => New_List (Param)); N := Make_Component_Association (Selector_Name => Make_Defining_Identifier (PN (P_Argument)), Expression => C); Append_To (Profile, N); -- 3rd component association N := Make_Component_Association (Selector_Name => Make_Defining_Identifier (PN (P_Arg_Modes)), Expression => Make_Literal (Int0_Val)); Append_To (Profile, N); -- Build the record aggregate N := Make_Record_Aggregate (Profile); N := Make_Return_Statement (N); -- Build the subprogram R := Map_Result_Subprogram_Name (Operation_Name); I := Make_Pragma (Pragma_Inline, New_List (Make_Identifier (R))); C := Make_Subprogram_Specification (Make_Defining_Identifier (R), No_List, RE (RE_NamedValue)); N := Make_Subprogram_Body (C, New_List (I), New_List (N)); Append_To (BEN.Statements (Current_Package), N); -- Setting the result Value (if any) if Non_Void then Set_Str_To_Name_Buffer ("Setting the result value"); Append_To (Statements, Make_Ada_Comment (Name_Find)); N := Make_Selected_Component (VN (V_Result_NV), CN (C_Argument)); N := Make_Subprogram_Call (RE (RE_Get_Container_2), New_List (N)); N := Make_Explicit_Dereference (N); C := Make_Attribute_Reference (Make_Identifier (Map_Argument_Content_Name (VN (V_Result))), A_Unrestricted_Access); N := Make_Subprogram_Call (RE (RE_Set_Value), New_List (N, C)); Append_To (Statements, N); end if; end if; -- Creating the request Set_Str_To_Name_Buffer ("Creating the request"); Append_To (Statements, Make_Ada_Comment (Name_Find)); -- Build the parameter associations NVList_Name := VN (V_Argument_List); Profile := New_List; -- Request object N := Make_Parameter_Association (Selector_Name => Make_Defining_Identifier (PN (P_Req)), Actual_Parameter => Make_Defining_Identifier (VN (V_Request))); Append_To (Profile, N); -- Target N := Make_Type_Conversion (RE (RE_Ref_2), Make_Defining_Identifier (PN (P_Self))); N := Make_Subprogram_Call (RE (RE_To_PolyORB_Ref), New_List (N)); N := Make_Parameter_Association (Selector_Name => Make_Defining_Identifier (PN (P_Target)), Actual_Parameter => N); Append_To (Profile, N); -- Operation R := Map_Operation_Name_Literal (E); N := Make_Parameter_Association (Selector_Name => Make_Defining_Identifier (PN (P_Operation)), Actual_Parameter => Make_Literal (New_String_Value (R, False))); Append_To (Profile, N); -- Arguments list N := Make_Parameter_Association (Selector_Name => Make_Defining_Identifier (PN (P_Arg_List)), Actual_Parameter => Make_Defining_Identifier (NVList_Name)); Append_To (Profile, N); -- Result N := Make_Parameter_Association (Selector_Name => Make_Defining_Identifier (PN (P_Result)), Actual_Parameter => Make_Defining_Identifier (VN (V_Result_NV))); Append_To (Profile, N); -- If the operation throws an exception, we add an -- additional parameter to the Create_Request call. if not FEU.Is_Empty (Exceptions (E)) then N := Make_Subprogram_Call (RE (RE_To_PolyORB_Ref_1), New_List (Make_Identifier (VN (V_Exception_List)))); -- Exception list N := Make_Parameter_Association (Selector_Name => Make_Defining_Identifier (PN (P_Exc_List)), Actual_Parameter => N); Append_To (Profile, N); end if; -- Handling the case of Oneway Operations. Extract from The CORBA -- mapping specification : "IDL oneway operations are mapped the same -- as other operation; that is, there is no indication whether an -- operation is oneway or not in the mapped Ada specification". -- The extract above means that the call to a oneway operation is -- performed in the same way as a call to a classic synchronous -- operation. However, the ORB need to know oneway operations. The -- stub precise that by adding an additional parameter to the -- procedure "PolyORB.Requests.Create_Request". This additional -- parameter indicate the calling way of the operation (see the file -- polyorb-requests.ads for more information about different ways of -- calls). if FEN.Is_Oneway (E) then -- Sync scope flag N := Make_Parameter_Association (Selector_Name => Make_Defining_Identifier (PN (P_Req_Flags)), Actual_Parameter => RE (RE_Sync_With_Transport)); Append_To (Profile, N); end if; N := Make_Subprogram_Call (RE (RE_Setup_Request), Profile); Append_To (Statements, N); if Use_SII then -- Get the GIOP session Profile := New_List; M := Make_Subprogram_Call (RE (RE_Ref_2), New_List (Make_Identifier (PN (P_Self)))); N := Make_Subprogram_Call (RE (RE_To_PolyORB_Ref), New_List (M)); Append_To (Profile, N); Append_To (Profile, RE (RE_The_ORB)); N := Make_Subprogram_Call (RE (RE_Get_Request_QoS), New_List (Make_Identifier (VN (V_Request)))); Append_To (Profile, N); Append_To (Profile, Make_Identifier (VN (V_Component))); Append_To (Profile, Make_Identifier (VN (V_Binding_Profile))); Append_To (Profile, RE (RE_False)); Append_To (Profile, Make_Identifier (VN (V_Error))); -- Call to the bind method to get the client Session and -- the binding_profile. N := Make_Subprogram_Call (RE (RE_Bind), Profile); Append_To (Statements, N); -- The session resulting of the bind operation and the -- session representation. N := Make_Type_Conversion (RE (RE_GIOP_Session), (Make_Explicit_Dereference (Make_Identifier (VN (V_Component))))); N := Make_Attribute_Reference (N, A_Unrestricted_Access); N := Make_Subprogram_Call (RE (RE_Get_Representation), New_List (N)); N := Make_Assignment_Statement (Make_Identifier (VN (V_Representation)), N); Append_To (Statements, N); if Use_Compiler_Alignment then declare Par : Node_Id; Disc : constant List_Id := New_List; J : Unsigned_Long_Long; begin Par := First_Entity (Parameters (E)); while Present (Par) loop if FEN.Parameter_Mode (Par) = Mode_In then Get_Discriminants_Value (Par, Type_Spec (Par), Disc); end if; Par := Next_Entity (Par); end loop; J := Unsigned_Long_Long (Length (Disc)); C := Make_Attribute_Reference (Make_Identifier (VN (V_Args_In)), A_Address); N := Make_Subprogram_Call (RE (RE_Insert_Raw_Data), New_List (Make_Identifier (VN (V_Request)), C, Make_Attribute_Reference (Make_Identifier (VN (V_Args_In)), A_Size), Make_Literal (New_Integer_Value (J, 1, 10)), Make_Identifier (VN (V_Buffer)))); Append_To (Statements, N); end; else -- In this context, we use a QoS attribute to store a -- CDR buffer that holds the CDR representation of the -- requests parameters. Profile := New_List; Append_To (Profile, Make_Identifier (VN (V_Binding_Profile))); Append_To (Profile, Make_Identifier (VN (V_Component))); Append_To (Profile, Make_Identifier (VN (V_Error))); -- Get the marshaller C := Get_Marshaller_Node (E); Profile := New_List; Append_To (Profile, RE (RE_True)); -- The arguments list, we use the method_name_Arg_Type -- instead of the Request_Args type N := Make_Identifier (PN (P_Arg_List)); N := Make_Attribute_Reference (N, A_Access); Append_To (Profile, N); Append_To (Profile, Make_Defining_Identifier (VN (V_Buffer))); N := Make_Explicit_Dereference (Make_Identifier (VN (V_Representation))); Append_To (Profile, N); -- There is no alignment it will be done in -- Marshall_Argument_List Append_To (Profile, Make_Literal (Int1_Val)); Append_To (Profile, Make_Defining_Identifier (VN (V_Error))); -- Call of the Marshaller method N := Make_Subprogram_Call (C, Profile); Append_To (Statements, N); -- If any error we raise a program_error N := Make_Subprogram_Call (RE (RE_Found), New_List (Make_Identifier (VN (V_Error)))); N := Make_If_Statement (Condition => N, Then_Statements => New_List (Make_Raise_Statement (Make_Identifier (EN (E_Program_Error))))); Append_To (Statements, N); end if; -- Add the buffer as a QoS parameter for the request Set_Str_To_Name_Buffer ("Add the buffer to the request QoS parameters"); Append_To (Statements, Make_Ada_Comment (Name_Find)); N := Make_Record_Aggregate (New_List (RE (RE_GIOP_Static_Buffer), Make_Defining_Identifier (VN (V_Buffer)))); N := Make_Object_Instantiation (Make_Qualified_Expression (RE (RE_QoS_GIOP_Static_Buffer_Parameter), N)); N := Make_Subprogram_Call (RE (RE_Add_Request_QoS), New_List (Make_Defining_Identifier (VN (V_Request)), RE (RE_GIOP_Static_Buffer), N)); Append_To (Statements, N); end if; -- Invoking the request (synchronously or asynchronously), -- it depends on the type of the operation (oneway or not). Set_Str_To_Name_Buffer ("Invoking the request (synchronously or asynchronously)"); Append_To (Statements, Make_Ada_Comment (Name_Find)); N := Make_Type_Conversion (RE (RE_Flags), Make_Literal (Int0_Val)); N := Make_Subprogram_Call (RE (RE_Client_Invoke), New_List (Make_Attribute_Reference (Make_Defining_Identifier (VN (V_Request)), A_Access), N)); Append_To (Statements, N); if Use_SII and then (Has_Out_Params or else Non_Void) then -- Unmarshall the request using the generated SII -- marshaller. In DII mode the unmarshalling is performed -- transparently. C := Get_Unmarshaller_Node (E); Profile := New_List; Append_To (Profile, RE (RE_True)); N := Make_Identifier (PN (P_Arg_List)); N := Make_Attribute_Reference (N, A_Access); Append_To (Profile, N); N := Make_Subprogram_Call (RE (RE_Extract_Request_Parameter), New_List (RE (RE_GIOP_Static_Buffer), Make_Defining_Identifier (VN (V_Request)))); N := Make_Type_Conversion (RE (RE_QoS_GIOP_Static_Buffer_Parameter_Access), N); N := Make_Selected_Component (N, Make_Identifier (PN (P_Buffer))); Append_To (Profile, N); N := Make_Explicit_Dereference (Make_Identifier (VN (V_Representation))); Append_To (Profile, N); -- There is no alignment it will be done in -- Marshall_Argument_List. Append_To (Profile, Make_Literal (New_Integer_Value (8, 1, 10))); Append_To (Profile, Make_Defining_Identifier (VN (V_Error))); -- Call of the Unmarshaller method N := Make_Subprogram_Call (C, Profile); Append_To (Statements, N); end if; -- Raise exception, if needed Set_Str_To_Name_Buffer ("Raise exception, if needed"); Append_To (Statements, Make_Ada_Comment (Name_Find)); Append_To (Statements, Make_Subprogram_Call (RE (RE_Request_Raise_Occurrence), New_List (Make_Identifier (VN (V_Request))))); -- Retrieve return value if Is_Function then Set_Str_To_Name_Buffer ("Return value"); Append_To (Statements, Make_Ada_Comment (Name_Find)); if Use_SII then N := Make_Selected_Component (PN (P_Arg_List), PN (P_Returns)); N := Make_Return_Statement (N); Append_To (Statements, N); else N := Make_Return_Statement (Make_Identifier (VN (V_Result))); Append_To (Statements, N); end if; else -- Non-void IDL operations with OUT/INOUT parameters are mapped to -- Ada procedures with an extra OUT formal for the return value. if Non_Void and then Use_SII then Set_Str_To_Name_Buffer ("Return value"); Append_To (Statements, Make_Ada_Comment (Name_Find)); N := Make_Selected_Component (PN (P_Arg_List), PN (P_Returns)); -- If the return value is a class-wide type, cast -- the record field. if Is_Class_Wide (E) then N := Make_Type_Conversion (Make_Attribute_Reference (Get_Type_Definition_Node (Type_Spec (E)), A_Class), N); end if; N := Make_Assignment_Statement (Make_Identifier (PN (P_Returns)), N); Append_To (Statements, N); end if; end if; -- In case of SII, retreive the OUT parameter values. In the case -- of DII, this is performed transparently. if Use_SII then P := First_Entity (Parameters (E)); if Present (P) then Set_Str_To_Name_Buffer ("Retrieve out argument values"); Append_To (Statements, Make_Ada_Comment (Name_Find)); end if; while Present (P) loop if FEN.Parameter_Mode (P) = Mode_Out or else FEN.Parameter_Mode (P) = Mode_Inout then Argument_Name := To_Ada_Name (IDL_Name (Identifier (Declarator (P)))); -- Record field: if Use_Compiler_Alignment then N := Make_Selected_Component (VN (V_Args_Out), Argument_Name); else N := Make_Selected_Component (PN (P_Arg_List), Argument_Name); end if; -- Parameter: M := Map_Defining_Identifier (Declarator (P)); -- If the parameter type is a class-wide type, cast -- the record field. if Is_Class_Wide (P) then N := Make_Type_Conversion (Make_Attribute_Reference (Get_Type_Definition_Node (Type_Spec (P)), A_Class), N); end if; N := Make_Assignment_Statement (M, N); -- Assignment: Append_To (Statements, N); end if; P := Next_Entity (P); end loop; end if; return Statements; end Stub_Statements; ----------------------- -- Stub_Declarations -- ----------------------- function Stub_Declarations (E : Node_Id) return List_Id is pragma Assert (FEN.Kind (E) = K_Operation_Declaration); L : constant List_Id := New_List; P : Node_Id; N : Node_Id; V : Value_Id; C : Node_Id; R : Name_Id; Operation_Name : constant Name_Id := FEN.IDL_Name (Identifier (E)); Argument_Name : Name_Id; Container : constant Node_Id := Scope_Entity (Identifier (E)); Local_Interface : constant Boolean := (FEN.Kind (Container) = K_Interface_Declaration and then Is_Local_Interface (Container)); Res_Exp : Node_Id; -- The flags below indicates whether the operation is mapped -- to an Ada function or an Ada procedure. Has_Out_Params : constant Boolean := Contains_Out_Parameters (E); Non_Void : constant Boolean := FEN.Kind (Type_Spec (E)) /= K_Void; Is_Function : constant Boolean := Non_Void and then not Has_Out_Params; begin if not Local_Interface then -- Argument_List_Ü declaration -- In the case of the use of SII, the NVList is not used -- when handling a request. However, it remains necessary -- for the request creation. So we declare it as a global -- variable and we avoid the creation of an NVList each -- time the operation is invoked. if not Use_SII then N := Make_Object_Declaration (Defining_Identifier => Make_Defining_Identifier (VN (V_Argument_List)), Constant_Present => False, Object_Definition => RE (RE_Ref_3), Expression => No_Node); Append_To (L, N); end if; -- In the case of SII, the NVList is not filled by the -- NameValues corresponding to the operation parameters if not Use_SII then -- Non-void return type case if Non_Void then -- Declare the Result_Ü variable if Is_Function then -- No Returns formal in the Ada mapped subprogram N := No_Node; else -- Extra Returns formal present N := Make_Identifier (PN (P_Returns)); end if; N := Make_Object_Declaration (Defining_Identifier => Make_Defining_Identifier (VN (V_Result)), Object_Definition => Get_Type_Definition_Node (Type_Spec (E)), Renamed_Object => N); Append_To (L, N); -- Disable warning on the returned value if Is_Function then -- No Returns formal in the Ada mapped subprogram N := Make_Identifier (VN (V_Result)); else -- Extra Returns formal present N := Make_Identifier (PN (P_Returns)); end if; N := Make_Pragma (Pragma_Warnings, New_List (RE (RE_Off), N)); Append_To (L, N); -- Declaration of the `Content' argument variable C := Get_Wrap_Node (FEU.Get_Original_Type_Declarator (Type_Spec (E))); N := Make_Identifier (VN (V_Result)); -- Cast the parameter when necessary Cast_When_Necessary (N, Type_Spec (E), FEU.Get_Original_Type_Declarator (Type_Spec (E)), True); C := Make_Subprogram_Call (C, New_List (Make_Attribute_Reference (N, A_Unrestricted_Access))); N := Make_Object_Declaration (Defining_Identifier => Make_Defining_Identifier (Map_Argument_Content_Name (VN (V_Result))), Constant_Present => False, Object_Definition => Make_Attribute_Reference (RE (RE_Content), A_Class), Expression => C, Aliased_Present => True); Append_To (L, N); end if; -- Handling the parameters P := First_Entity (Parameters (E)); while Present (P) loop Argument_Name := To_Ada_Name (IDL_Name (Identifier (Declarator (P)))); -- Map the `Identifier' global variable name -- corresponding to the parameter `I'. R := Map_Argument_Identifier_Name (Argument_Name, Operation_Name); -- Expression of the variable C := Make_Subprogram_Call (RE (RE_To_PolyORB_String), New_List (Make_Literal (New_String_Value (Argument_Name, False)))); -- Declare the global variable N := Make_Object_Declaration (Defining_Identifier => Make_Defining_Identifier (R), Constant_Present => True, Object_Definition => RE (RE_Identifier), Expression => C); Append_To (Statements (Current_Package), N); -- Declaration of the `Content' argument variable C := Get_Wrap_Node (FEU.Get_Original_Type_Declarator (Type_Spec (P))); N := Make_Identifier (Argument_Name); -- Cast the parameter when necessary Cast_When_Necessary (N, Type_Spec (P), FEU.Get_Original_Type_Specifier (Type_Spec (P)), True); C := Make_Subprogram_Call (C, New_List (Make_Attribute_Reference (N, A_Unrestricted_Access))); N := Make_Object_Declaration (Defining_Identifier => Make_Defining_Identifier (Map_Argument_Content_Name (Argument_Name)), Constant_Present => False, Object_Definition => Make_Attribute_Reference (RE (RE_Content), A_Class), Expression => C, Aliased_Present => True); Append_To (L, N); -- Declaration of the `Any' argument variable R := Map_Argument_Any_Name (Argument_Name); C := Make_Attribute_Reference (Make_Identifier (Map_Argument_Content_Name (Argument_Name)), A_Unchecked_Access); C := Make_Subprogram_Call (RE (RE_Get_Wrapper_Any), New_List (Get_TC_Node (Type_Spec (P)), C)); N := Make_Object_Declaration (Defining_Identifier => Make_Defining_Identifier (R), Constant_Present => True, Object_Definition => RE (RE_Any), Expression => C); Append_To (L, N); -- If the parameter is OUT, we disable warnings on -- it. if FEN.Parameter_Mode (P) = Mode_Out then N := Make_Pragma (Pragma_Warnings, New_List (RE (RE_Off), Make_Identifier (Argument_Name))); Append_To (L, N); end if; P := Next_Entity (P); end loop; else C := Make_Object_Declaration (Defining_Identifier => Make_Defining_Identifier (VN (V_Representation)), Object_Definition => RE (RE_CDR_Representation_Access), Expression => No_Node); Append_To (L, C); -- SII/SSI invocation C := Make_Object_Instantiation (RE (RE_Buffer_Type)); -- Buffer declaration and instantiation N := Make_Object_Declaration (Defining_Identifier => Make_Defining_Identifier (VN (V_Buffer)), Object_Definition => RE (RE_Buffer_Access), Constant_Present => True, Expression => C); Append_To (L, N); N := Make_Object_Declaration (Defining_Identifier => Make_Defining_Identifier (VN (V_Argument_List)), Object_Definition => RE (RE_Ref_3)); Append_To (L, N); -- Error container N := Make_Object_Declaration (Defining_Identifier => Make_Defining_Identifier (VN (V_Error)), Object_Definition => RE (RE_Error_Container)); Append_To (L, N); -- Binding_Profile and GIOP Session N := Make_Object_Declaration (Defining_Identifier => Make_Defining_Identifier (VN (V_Binding_Profile)), Object_Definition => RE (RE_Profile_Access)); Append_To (L, N); N := Make_Object_Declaration (Defining_Identifier => Make_Defining_Identifier (VN (V_Component)), Object_Definition => RE (RE_Component_Access)); Append_To (L, N); end if; -- Request_Ü declaration N := Make_Object_Declaration (Defining_Identifier => Make_Defining_Identifier (VN (V_Request)), Constant_Present => False, Aliased_Present => True, Object_Definition => RE (RE_Request), Expression => No_Node); Append_To (L, N); -- Exception_List_Ü declaration if not FEU.Is_Empty (Exceptions (E)) then N := Make_Object_Declaration (Defining_Identifier => Make_Defining_Identifier (VN (V_Exception_List)), Constant_Present => False, Object_Definition => RE (RE_Ref_5), Expression => No_Node); Append_To (L, N); end if; -- Result_NV_Ü declaration -- In the case of the SII, the Result_NV_Ü is not -- used. However it remains necessary for the request -- creation. R := Map_Result_Subprogram_Name (Operation_Name); if Use_SII then Res_Exp := No_Node; else Res_Exp := Make_Subprogram_Call (Make_Identifier (R), No_List); end if; N := Make_Object_Declaration (Defining_Identifier => Make_Defining_Identifier (VN (V_Result_NV)), Constant_Present => False, Object_Definition => RE (RE_NamedValue), Expression => Res_Exp); Append_To (L, N); if not Use_SII then -- Result_Name_Ü declaration R := Map_Result_Identifier_Name (Operation_Name); Set_Str_To_Name_Buffer ("Result"); V := New_String_Value (Name_Find, False); C := Make_Subprogram_Call (RE (RE_To_PolyORB_String), New_List (Make_Literal (V))); N := Make_Object_Declaration (Defining_Identifier => Make_Defining_Identifier (R), Constant_Present => True, Object_Definition => RE (RE_Identifier), Expression => C); Append_To (Statements (Current_Package), N); end if; -- In the case of the SII use, the argument list is an -- aliased record variable. if Use_Compiler_Alignment then declare Disc : constant List_Id := New_List; begin C := Expand_Designator (Args_In_Node (BE_Node (Identifier (E)))); P := First_Entity (Parameters (E)); while Present (P) loop if FEN.Parameter_Mode (P) = Mode_In then -- FIXME to be factorized !!!! Get_Discriminants_Value (P, Type_Spec (P), Disc); end if; P := Next_Entity (P); end loop; N := Make_Subprogram_Call (C, Disc); N := Make_Object_Declaration (Defining_Identifier => Make_Defining_Identifier (VN (V_Args_In)), Aliased_Present => True, Object_Definition => N); Append_To (L, N); end; N := Get_Type_Definition_Node (E); N := Make_Object_Declaration (Defining_Identifier => Make_Defining_Identifier (PN (P_Arg_List)), Aliased_Present => True, Object_Definition => N); Append_To (L, N); elsif Use_SII then N := Get_Type_Definition_Node (E); N := Make_Object_Declaration (Defining_Identifier => Make_Defining_Identifier (PN (P_Arg_List)), Aliased_Present => True, Object_Definition => N); Append_To (L, N); end if; end if; return L; end Stub_Declarations; end Package_Body; --------------------- -- Local_Is_A_Body -- --------------------- function Local_Is_A_Body (E : Node_Id; Spec : Node_Id := No_Node) return Node_Id is N : Node_Id; S : constant List_Id := New_List; M : Node_Id; Repository_Id : Node_Id; Rep_Value : Value_Id; Parent_Statement : Node_Id; function Is_Equivalent_Statement (E : Node_Id) return Node_Id; -- This function returns a logical "or else" expression. The -- operands of the expression are calls to CORBA.Is_Equivalent -- function on all the parents (direct parents as well as in -- direct parents) of the interface. It returns a null node in -- the case where the interface does not inherit from another -- interface. ----------------------------- -- Is_Equivalent_Statement -- ----------------------------- function Is_Equivalent_Statement (E : Node_Id) return Node_Id is Result : Node_Id := No_Node; Parent_Statement : Node_Id; Par_Int : Node_Id; L : List_Id; Rep_Id : Node_Id; T : Node_Id; begin pragma Assert (FEN.Kind (E) = K_Interface_Declaration); L := Interface_Spec (E); if not FEU.Is_Empty (L) then Par_Int := First_Entity (L); while Present (Par_Int) loop -- Get the type definition corresponding to the parent -- interface. T := Get_Type_Definition_Node (Par_Int); -- Build the Repository_Id constant corresponding to -- the parent interface. Rep_Id := Make_Selected_Component (Get_Parent_Unit_Name (T), Make_Defining_Identifier (PN (P_Repository_Id))); if Present (Result) then Result := Make_Expression (Result, Op_Or_Else, Make_Subprogram_Call (RE (RE_Is_Equivalent), New_List (Make_Defining_Identifier (PN (P_Logical_Type_Id)), Rep_Id))); else Result := Make_Subprogram_Call (RE (RE_Is_Equivalent), New_List (Make_Defining_Identifier (PN (P_Logical_Type_Id)), Rep_Id)); end if; -- Adding recursively the parents of parents. Parent_Statement := Is_Equivalent_Statement (Reference (Par_Int)); if Present (Parent_Statement) then Result := Make_Expression (Result, Op_Or_Else, Parent_Statement); end if; Par_Int := Next_Entity (Par_Int); end loop; end if; return Result; end Is_Equivalent_Statement; begin -- The Repository_Id constant is declared just after the Ada -- Ref type mapped from the interface. N := Next_Node (Type_Def_Node (BE_Node (Identifier (E)))); Repository_Id := Expand_Designator (N); N := Make_Subprogram_Call (RE (RE_Is_Equivalent), New_List (Make_Defining_Identifier (PN (P_Logical_Type_Id)), Repository_Id)); if FEN.Kind (E) = K_Interface_Declaration then Set_Str_To_Name_Buffer ("IDL:omg.org/CORBA/Object:1.0"); else Set_Str_To_Name_Buffer ("IDL:omg.org/CORBA/ValueBase:1.0"); end if; Rep_Value := New_String_Value (Name_Find, False); M := Make_Subprogram_Call (RE (RE_Is_Equivalent), New_List (Make_Defining_Identifier (PN (P_Logical_Type_Id)), Make_Literal (Rep_Value))); N := Make_Expression (N, Op_Or_Else, M); -- Add the parents (recusively). Parent_Statement := Is_Equivalent_Statement (E); if Present (Parent_Statement) then N := Make_Expression (N, Op_Or_Else, Parent_Statement); end if; N := Make_Expression (N, Op_Or_Else, RE (RE_False)); N := Make_Return_Statement (N); Append_To (S, N); -- Get the spec of the Is_A function if Spec = No_Node then N := Local_Is_A_Spec; else N := Spec; end if; N := Make_Subprogram_Body (N, No_List, S); return N; end Local_Is_A_Body; --------------------- -- Local_Is_A_Spec -- --------------------- function Local_Is_A_Spec return Node_Id is N : Node_Id; Profile : List_Id; Param : Node_Id; begin Param := Make_Parameter_Specification (Make_Defining_Identifier (PN (P_Logical_Type_Id)), RE (RE_String_2)); Profile := New_List; Append_To (Profile, Param); N := Make_Subprogram_Specification (Make_Defining_Identifier (SN (S_Is_A)), Profile, RE (RE_Boolean)); return N; end Local_Is_A_Spec; ----------------------- -- Visible_Is_A_Body -- ----------------------- function Visible_Is_A_Body (E : Node_Id) return Node_Id is N : Node_Id; M : Node_Id; S : constant List_Id := New_List; begin M := Make_Subprogram_Call (RE (RE_Ref_2), New_List (Make_Defining_Identifier (PN (P_Self)))); M := Make_Subprogram_Call (RE (RE_Is_A), New_List (M, Make_Defining_Identifier (PN (P_Logical_Type_Id)))); N := Make_Subprogram_Call (Make_Defining_Identifier (SN (S_Is_A)), New_List (Make_Identifier (PN (P_Logical_Type_Id)))); N := Make_Expression (RE (RE_False), Op_Or_Else, Make_Expression (N, Op_Or_Else, M)); N := Make_Return_Statement (N); Append_To (S, N); N := Make_Subprogram_Body (Visible_Is_A_Spec (E), No_List, S); return N; end Visible_Is_A_Body; ----------------------- -- Visible_Is_A_Spec -- ----------------------- function Visible_Is_A_Spec (E : Node_Id) return Node_Id is N : Node_Id; Profile : List_Id; Param : Node_Id; begin Profile := New_List; Param := Make_Parameter_Specification (Make_Defining_Identifier (PN (P_Self)), Map_Ref_Type (E)); Append_To (Profile, Param); Param := Make_Parameter_Specification (Make_Defining_Identifier (PN (P_Logical_Type_Id)), RE (RE_String_2)); Append_To (Profile, Param); N := Make_Subprogram_Specification (Make_Defining_Identifier (SN (S_Is_A)), Profile, RE (RE_Boolean)); return N; end Visible_Is_A_Spec; end Backend.BE_CORBA_Ada.Stubs; polyorb-2.8~20110207.orig/compilers/iac/scopes.ads0000644000175000017500000001063011750740337021126 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- S C O P E S -- -- -- -- S p e c -- -- -- -- Copyright (C) 2005-2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with Types; use Types; package Scopes is -- Scope_Entity and Visibility: -- ---------------------------- -- -- To handle scope, iac uses two dedicated node attributes: Scope_Entity -- and Potential_Scope. Scope_Entity designates the regular scope of the -- corresponding entity while Potential_Scope designates the scope into -- which the entity has been imported. Imports occur for type names and -- inherited interfaces. -- -- To handle visibility, iac uses two dedicated node attributes: Visible -- and Implicitly_Visible. The normal visibility rules are handled by -- Visible while Implicitly_Visible is used only in the context of -- inherited interfaces. In the scope of an inherited interface, entities -- like attributes and operations are inherited (scoped and explicitly -- visible) while other entities are just made visible (implicitly -- visible). D_Scopes : Boolean := False; -- When true, displays more information when analyzing the scopes procedure Initialize; procedure Push_Scope (S : Node_Id); procedure Pop_Scope; -- Handle special scoping rules for types names (see 3.15.3). The -- potential scope of a type name extends over all its enclosing -- scopes out to the enclosing non-module scope. Remove nodes -- from their homonym chains (used to apply visibility rules). function Current_Scope return Node_Id; -- Return current scope function Node_Explicitly_In_Scope (N : Node_Id; S : Node_Id) return Node_Id; -- Find whether there is a definition for identifier N in scope -- S. This node must be explicitly declared in S and not imported -- because of special scoping rules. function Node_In_Current_Scope (N : Node_Id) return Node_Id; -- Find whether there is a definition for identifier N in current -- scope. This node can be implicitly declared that is explicitly -- or potentially declared because of special scoping rules. function Visible_Node (N : Node_Id) return Node_Id; -- Find the currently visible definition for a given identifier, -- that is to say the first entry in the visibility chain -- (implemented using the homonyms chain). procedure Enter_Name_In_Scope (N : Node_Id); -- Detect naming conflict with N. In case of success, add N to the -- current scope. IDL_Spec : Node_Id; IDL_Spec_Name : Name_Id; end Scopes; polyorb-2.8~20110207.orig/compilers/iac/backend-be_corba_ada-debug.ads0000644000175000017500000000720411750740337024647 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- B A C K E N D . B E _ C O R B A _ A D A . D E B U G -- -- -- -- S p e c -- -- -- -- Copyright (C) 2005-2008, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- This package provides helper routine to debug the CORBA/Ada -- backend of IAC. with Output; use Output; with Utils; with Backend.BE_CORBA_Ada.Nodes; use Backend.BE_CORBA_Ada.Nodes; package Backend.BE_CORBA_Ada.Debug is procedure wabi (N : Node_Id); pragma Export (C, wabi, "wbi"); -- Helper routine to print information on a node. This functions is -- exported so that it can be called from gdb, e.g. -- (gdb) wbi (305452) N_Indents : Natural := 0; procedure W_Eol (N : Natural := 1) renames Output.Write_Eol; procedure W_Int (N : Int) renames Output.Write_Int; procedure W_Line (N : String) renames Output.Write_Line; procedure W_Str (N : String) renames Output.Write_Str; procedure W_Indents; procedure W_Boolean (N : Boolean); procedure W_Byte (N : Byte); procedure W_List_Id (L : List_Id); procedure W_Node_Id (N : Node_Id); procedure W_Node_Header (N : Node_Id); procedure W_Full_Tree; procedure W_Node_Attribute (A : String; K : String; V : String; N : Int := 0); function Image (N : Node_Kind) return String; function Image (N : Name_Id) return String; function Image (N : Node_Id) return String; function Image (N : List_Id) return String; function Image (N : Mode_Id) return String; function Image (N : Value_Id) return String; function Image (N : Operator_Id) return String; function Image (N : Boolean) return String; function Image (N : Byte) return String; function Image (N : Int) return String renames Utils.Image; end Backend.BE_CORBA_Ada.Debug; polyorb-2.8~20110207.orig/compilers/iac/backend-be_corba_ada-helpers_internals.ads0000644000175000017500000000453411750740337027305 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- BACKEND.BE_CORBA_ADA.HELPERS_INTERNALS -- -- -- -- S p e c -- -- -- -- Copyright (C) 2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- This package generates the initialization routines for IDL types package Backend.BE_CORBA_Ada.Helpers_Internals is package Package_Spec is procedure Visit (E : Node_Id); end Package_Spec; package Package_Body is procedure Visit (E : Node_Id); end Package_Body; end Backend.BE_CORBA_Ada.Helpers_Internals; polyorb-2.8~20110207.orig/compilers/iac/backend-be_corba_ada-stubs.ads0000644000175000017500000000512711750740337024723 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- B A C K E N D . B E _ C O R B A _ A D A . S T U B S -- -- -- -- S p e c -- -- -- -- Copyright (C) 2005-2007, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ package Backend.BE_CORBA_Ada.Stubs is function Local_Is_A_Body (E : Node_Id; Spec : Node_Id := No_Node) return Node_Id; -- The function below is used by the Impls package in the case of -- local interfaces the difference between the two functions are -- very tiny and does not justify the creation of a new -- "Is_A_Body" in the Impls package. package Package_Spec is procedure Visit (E : Node_Id); end Package_Spec; package Package_Body is procedure Visit (E : Node_Id); end Package_Body; end Backend.BE_CORBA_Ada.Stubs; polyorb-2.8~20110207.orig/compilers/iac/backend-be_corba_ada-common.ads0000644000175000017500000000727411750740337025060 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- B A C K E N D . B E _ C O R B A _ A D A . C O M M O N -- -- -- -- S p e c -- -- -- -- Copyright (C) 2005-2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ package Backend.BE_CORBA_Ada.Common is function Cast_Variable_From_PolyORB_Type (Var_Name : Name_Id; Var_Type : Node_Id) return Node_Id; -- This function builds a type conversion of a variable from a -- PolyORB type into a CORBA type. function Cast_Variable_To_PolyORB_Type (Var_Node : Node_Id; Var_Type : Node_Id) return Node_Id; -- This function builds a type conversion of a variable to a -- PolyORB type. function Is_In (Par_Mode : Mode_Id) return Boolean; -- This function tests whether the mode is IN or INOUT function Is_Out (Par_Mode : Mode_Id) return Boolean; -- This function tests whether the mode is OUT or INOUT function Contains_In_Parameters (E : Node_Id) return Boolean; -- Returun True if the operation E contains IN or INOUT parameters function Contains_Out_Parameters (E : Node_Id) return Boolean; -- Returun True if the operation E contains OUT or INOUT -- parameters. function Make_Type_Designator (N : Node_Id; Declarator : Node_Id := No_Node) return Node_Id; -- This function builds a type conversion of a variable to a -- PolyORB aligned type (used for compiler alignment). function Cast_Variable_To_PolyORB_Aligned_Type (Var_Node : Node_Id; Var_Type : Node_Id) return Node_Id; procedure Marshall_Args (Stat : List_Id; Var_Type : Node_Id; Var : Node_Id; Var_Exp : Node_Id := No_Node); procedure Get_Discriminants_Value (P : Node_Id; N : Node_Id; L : List_Id; Ret : Boolean := False); private pragma Inline (Is_In); pragma Inline (Is_Out); end Backend.BE_CORBA_Ada.Common; polyorb-2.8~20110207.orig/compilers/iac/backend-be_corba_ada.adb0000644000175000017500000002727511750740337023554 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- B A C K E N D . B E _ C O R B A _ A D A -- -- -- -- B o d y -- -- -- -- Copyright (C) 2005-2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with Output; use Output; with Values; use Values; with Frontend.Nodes; use Frontend.Nodes; with Backend.BE_CORBA_Ada.Debug; use Backend.BE_CORBA_Ada.Debug; with Backend.BE_CORBA_Ada.Expand; with Backend.BE_CORBA_Ada.IDL_To_Ada; use Backend.BE_CORBA_Ada.IDL_To_Ada; with Backend.BE_CORBA_Ada.Generator; use Backend.BE_CORBA_Ada.Generator; with Backend.BE_CORBA_Ada.Nutils; use Backend.BE_CORBA_Ada.Nutils; with Backend.BE_CORBA_Ada.Runtime; use Backend.BE_CORBA_Ada.Runtime; with Backend.BE_CORBA_Ada.Nodes; with Backend.BE_CORBA_Ada.Helpers; with Backend.BE_CORBA_Ada.Helpers_Internals; with Backend.BE_CORBA_Ada.Impls; with Backend.BE_CORBA_Ada.IR_Infos; with Backend.BE_CORBA_Ada.Stubs; with Backend.BE_CORBA_Ada.Skels; with Backend.BE_CORBA_Ada.CDRs; with Backend.BE_CORBA_Ada.Buffers; with Backend.BE_CORBA_Ada.Aligned; package body Backend.BE_CORBA_Ada is package BEN renames Backend.BE_CORBA_Ada.Nodes; package FEN renames Frontend.Nodes; procedure Initialize; procedure Visit (E : Node_Id); procedure Visit_Specification (E : Node_Id); -------------- -- Generate -- -------------- procedure Generate (E : Node_Id) is begin Initialize; Visit_Specification (E); if Print_Ada_Tree then W_Node_Id (BEN.Stub_Node (BE_Node (Identifier (E)))); else Generator.Generate (BEN.Stub_Node (BE_Node (Identifier (E)))); end if; end Generate; ---------------- -- Initialize -- ---------------- procedure Initialize is begin Runtime.Initialize; Set_Space_Increment (3); Int0_Val := New_Integer_Value (0, 1, 10); Int1_Val := New_Integer_Value (1, 1, 10); Int2_Val := New_Integer_Value (2, 1, 10); Nutils.Initialize; end Initialize; ----------- -- Usage -- ----------- procedure Usage (Indent : Natural) is Hdr : constant String (1 .. Indent - 1) := (others => ' '); begin Write_Line (Hdr & "-i Generate implementation packages"); Write_Line (Hdr & "-c Generate code for client side only"); Write_Line (Hdr & "-s Generate code for server side only"); Write_Line (Hdr & "-d Generate delegation package (defunct)"); Write_Line (Hdr & "-ir Generate code for interface repository"); Write_Line (Hdr & "-noir Do not generate code for interface repository " & "(default)"); Write_Line (Hdr & "-hc Minimize CPU time in perfect hash tables in skels"); Write_Line (Hdr & "-hm Minimize memory use in perfect hash tables in skels"); Write_Line (Hdr & " This is the default."); Write_Line (Hdr & "-rs Use the SII/SSI to handle requests"); -- XXX The following is currently not advertised, it requires -- some support in PolyORB that is not currently operational. -- Write_Line -- (Hdr & "-ro Use the SII/SSI and optimize buffer allocation"); -- Write_Line -- (Hdr & "-ra Use the SII/SSI and optimize parameter marshalling"); Write_Line (Hdr & "-rd Use the DII/DSI to handle requests (default)"); Write_Line (Hdr & "-da Dump the Ada tree"); Write_Line (Hdr & "-db Generate only the package bodies"); Write_Line (Hdr & "-ds Generate only the package specs"); Write_Line (Hdr & "-dw Output the withed entities"); Write_Line (Hdr & "-dt Output tree warnings"); Write_Line (Hdr & "-di Generate code for imported entities"); end Usage; ----------- -- Visit -- ----------- procedure Visit (E : Node_Id) is begin -- Generate package specifications -- NB : Even if the user did not request the generation of -- implementation templates, the Ada trees relative to the -- specs of these units have to be created because they are -- used by the skeleton sub-tree. However the spec code is -- generated if and only if the user requested it explicitly -- (see the Map_IDL_Unit in the Backen.BE_CORBA_Ada.IDL_To_Ada -- package for more details). -- Created independently from the command line options Stubs.Package_Spec.Visit (E); Helpers.Package_Spec.Visit (E); Helpers_Internals.Package_Spec.Visit (E); Impls.Package_Spec.Visit (E); if IR_Info_Packages_Gen then IR_Infos.Package_Spec.Visit (E); end if; if not Disable_Server_Code_Gen then Skels.Package_Spec.Visit (E); end if; if Use_SII then CDRs.Package_Spec.Visit (E); end if; if Use_Optimized_Buffers_Allocation then Buffers.Package_Spec.Visit (E); end if; if Use_Compiler_Alignment then Aligned.Package_Spec.Visit (E); end if; -- Generate packages bodies if not Disable_Client_Code_Gen then Stubs.Package_Body.Visit (E); end if; -- The order is important here because the dependencies of the -- Helper package are computed while building the Initialize -- routines. Helpers_Internals.Package_Body.Visit (E); Helpers.Package_Body.Visit (E); if not Disable_Server_Code_Gen then Skels.Package_Body.Visit (E); end if; if Impl_Packages_Gen then Impls.Package_Body.Visit (E); end if; if IR_Info_Packages_Gen then IR_Infos.Package_Body.Visit (E); end if; if Use_SII and then not Disable_Client_Code_Gen then CDRs.Package_Body.Visit (E); end if; if Use_Optimized_Buffers_Allocation and then not Disable_Client_Code_Gen then Buffers.Package_Body.Visit (E); end if; end Visit; ------------------------- -- Visit_Specification -- ------------------------- procedure Visit_Specification (E : Node_Id) is N : Node_Id; begin Backend.BE_CORBA_Ada.Expand.Expand (E); N := Map_IDL_Unit (E); Push_Entity (N); Visit (E); Pop_Entity; end Visit_Specification; -------------------------------- -- Map_Particular_CORBA_Parts -- -------------------------------- function Map_Particular_CORBA_Parts (E : Node_Id; PK : Package_Type) return Boolean is procedure Dispatched_Visit (Entity : Node_Id); -- This procedure calls the right Visit procedure depending on -- the PK parameter (of Map_Particular_CORBA_Parts). This call -- doesn't occur only if a code generation must be done for -- Entity. ---------------------- -- Dispatched_Visit -- ---------------------- procedure Dispatched_Visit (Entity : Node_Id) is E_Name : Name_Id; begin case FEN.Kind (Entity) is when K_Module | K_Interface_Declaration | K_Forward_Interface_Declaration => E_Name := FEN.IDL_Name (Identifier (Entity)); when others => return; end case; if E_Name = Nutils.Repository_Root_Name then -- Uncomment the instruction below if you want to -- generate code for various parts of the CORBA module: -- or else E_Name = Nutils.IDL_Sequences_Name -- or else E_Name = Nutils.DomainManager_Name case PK is when PK_CDR_Spec => CDRs.Package_Spec.Visit (Entity); when PK_CDR_Body => CDRs.Package_Body.Visit (Entity); when PK_Buffers_Spec => Buffers.Package_Spec.Visit (Entity); when PK_Buffers_Body => Buffers.Package_Body.Visit (Entity); when PK_Aligned_Spec => Aligned.Package_Spec.Visit (Entity); when PK_Stub_Spec => Stubs.Package_Spec.Visit (Entity); when PK_Stub_Body => Stubs.Package_Body.Visit (Entity); when PK_Helper_Spec => Helpers.Package_Spec.Visit (Entity); when PK_Helper_Body => Helpers.Package_Body.Visit (Entity); when PK_Helper_Internals_Spec => Helpers_Internals.Package_Spec.Visit (Entity); when PK_Helper_Internals_Body => Helpers_Internals.Package_Body.Visit (Entity); when PK_Skel_Spec => Skels.Package_Spec.Visit (Entity); when PK_Skel_Body => Skels.Package_Body.Visit (Entity); when PK_Impl_Spec => Impls.Package_Spec.Visit (Entity); when PK_Impl_Body => Impls.Package_Body.Visit (Entity); when PK_IR_Info_Spec | PK_IR_Info_Body => -- Ada code generated from particular CORBA -- entities (CORBA.Repository_Root hierarchy) is -- used in the repository information packages -- generated for user IDL models. null; end case; end if; end Dispatched_Visit; Result : Boolean := False; Definition : Node_Id; begin if FEN.Kind (E) = K_Module then if FEN.IDL_Name (Identifier (E)) = Nutils.CORBA_Name then Definition := First_Entity (Definitions (E)); while Present (Definition) loop Dispatched_Visit (Definition); Definition := Next_Entity (Definition); end loop; Result := True; end if; end if; return Result; end Map_Particular_CORBA_Parts; end Backend.BE_CORBA_Ada; polyorb-2.8~20110207.orig/compilers/iac/backend-be_types.ads0000644000175000017500000000436311750740337023037 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- B A C K E N D . B E _ T Y P E S -- -- -- -- S p e c -- -- -- -- Copyright (C) 2005-2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ package Backend.BE_Types is procedure Generate (E : Node_Id); procedure Usage (Indent : Natural); Print_Types : Boolean := False; -- if True print the types list generated on the standard output end Backend.BE_Types; polyorb-2.8~20110207.orig/compilers/iac/backend-be_corba_ada-nutils.ads0000644000175000017500000010401511750740337025075 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- B A C K E N D . B E _ C O R B A _ A D A . N U T I L S -- -- -- -- S p e c -- -- -- -- Copyright (C) 2005-2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with Frontend.Nodes; with Backend.BE_CORBA_Ada.Runtime; use Backend.BE_CORBA_Ada.Runtime; with Backend.BE_CORBA_Ada.Nodes; use Backend.BE_CORBA_Ada.Nodes; package Backend.BE_CORBA_Ada.Nutils is -- Frequently used values Int0_Val : Value_Id; -- 0 Int1_Val : Value_Id; -- 1 Int2_Val : Value_Id; -- 2 CORBA_Name : Name_Id; -- "CORBA" Repository_Root_Name : Name_Id; -- "Repository_Root" IDL_Sequences_Name : Name_Id; -- "IDL_Sequences" DomainManager_Name : Name_Id; -- "DomainManager" Initialized : Boolean := False; -- Ada tokens type Token_Type is ( -- Token name Token type -- Keywords Tok_Mod, -- MOD **** First Keyword Tok_Rem, -- REM Tok_New, -- NEW Tok_Abs, -- ABS Tok_Others, -- OTHERS Tok_Null, -- NULL Tok_Delta, -- DELTA Tok_Digits, -- DIGITS Tok_Range, -- RANGE Tok_And, -- AND Tok_Or, -- OR Tok_Xor, -- XOR Tok_In, -- IN Tok_Not, -- NOT Tok_Abstract, -- ABSTRACT Tok_Access, -- ACCESS Tok_Aliased, -- ALIASED Tok_All, -- ALL Tok_Array, -- ARRAY Tok_At, -- AT Tok_Body, -- BODY Tok_Constant, -- CONSTANT Tok_Do, -- DO Tok_Is, -- IS Tok_Limited, -- LIMITED Tok_Of, -- OF Tok_Out, -- OUT Tok_Record, -- RECORD Tok_Renames, -- RENAMES Tok_Reverse, -- REVERSE Tok_Tagged, -- TAGGED Tok_Then, -- THEN Tok_Abort, -- ABORT Tok_Accept, -- ACCEPT Tok_Case, -- CASE Tok_Delay, -- DELAY Tok_Else, -- ELSE Tok_Elsif, -- ELSIF Tok_End, -- END Tok_Exception, -- EXCEPTION Tok_Exit, -- EXIT Tok_Goto, -- GOTO Tok_If, -- IF Tok_Pragma, -- PRAGMA Tok_Raise, -- RAISE Tok_Requeue, -- REQUEUE Tok_Return, -- RETURN Tok_Select, -- SELECT Tok_Terminate, -- TERMINATE Tok_Until, -- UNTIL Tok_When, -- WHEN Tok_Begin, -- BEGIN Tok_Declare, -- DECLARE Tok_For, -- FOR Tok_Loop, -- LOOP Tok_While, -- WHILE Tok_Entry, -- ENTRY Tok_Protected, -- PROTECTED Tok_Task, -- TASK Tok_Type, -- TYPE Tok_Subtype, -- SUBTYPE Tok_Interface, -- INTERFACE Tok_Overriding, -- OVERRIDING Tok_Synchronized, -- SYNCHRONIZED Tok_Use, -- USE Tok_Function, -- FUNCTION Tok_Generic, -- GENERIC Tok_Package, -- PACKAGE Tok_Procedure, -- PROCEDURE Tok_Private, -- PRIVATE Tok_With, -- WITH Tok_Separate, -- SEPARATE **** Last Keyword -- Graphic Characters Tok_Double_Asterisk, -- ** Tok_Ampersand, -- & Tok_Minus, -- - Tok_Plus, -- + Tok_Asterisk, -- * Tok_Slash, -- / Tok_Dot, -- . Tok_Apostrophe, -- ' Tok_Left_Paren, -- ( Tok_Right_Paren, -- ) Tok_Comma, -- , Tok_Less, -- < Tok_Equal, -- = Tok_Greater, -- > Tok_Not_Equal, -- /= Tok_Greater_Equal, -- >= Tok_Less_Equal, -- <= Tok_Box, -- <> Tok_Colon_Equal, -- := Tok_Colon, -- : Tok_Greater_Greater, -- >> Tok_Less_Less, -- << Tok_Semicolon, -- ; Tok_Arrow, -- => Tok_Vertical_Bar, -- | Tok_Dot_Dot, -- .. Tok_Minus_Minus); -- -- Token_Image : array (Token_Type) of Name_Id; -- A table of the images of the Ada tokens subtype Keyword_Type is Token_Type range Tok_Mod .. Tok_Separate; type Operator_Type is (Op_Not, -- not Op_And, -- and Op_In, -- in Op_Not_In, -- not in Op_And_Then, -- and then Op_Or, -- or Op_Or_Else, -- or else Op_And_Symbol, -- & Op_Double_Asterisk, -- ** Op_Minus, -- - Op_Plus, -- + Op_Asterisk, -- * Op_Slash, -- / Op_Less, -- < Op_Equal, -- = Op_Greater, -- > Op_Not_Equal, -- /= Op_Greater_Equal, -- >= Op_Less_Equal, -- <= Op_Box, -- <> Op_Colon_Equal, -- := Op_Colon, -- : Op_Greater_Greater, -- >> Op_Less_Less, -- << Op_Semicolon, -- ; Op_Arrow, -- => Op_Vertical_Bar, -- | Op_None); -- No operation Operator_Image : array (Operator_Type'Pos (Op_And) .. Operator_Type'Pos (Op_Vertical_Bar)) of Name_Id; subtype Keyword_Operator is Operator_Type range Operator_Type'First .. Op_Or_Else; -- The types XXXX_Id are used to make easier the building of the -- Ada identifiers. The user does not have to manipulate the name -- buffer. He just uses the Name_Id from the proper array type. type Parameter_Id is (P_A, P_ACC, P_Arg_List, P_Arg_List_In, P_Arg_List_Out, P_Arg_Modes, P_Args, P_Argument, P_Aux, P_Base_Ifs, P_Bound, P_Buffer, P_C, P_Conflicts, P_Container_Ref, P_Contexts, P_Count, P_Data_Alignment, P_Depends, P_Discriminator_Type, P_Dummy, P_E, P_El_C, P_El_CC, P_El_M, P_Element_From_Any, P_Element_To_Any, P_Element_Type, P_Element_Wrap, P_Error, P_Exc_List, P_Exception_Info, P_Exceptions, P_First_Arg_Alignment, P_From, P_From_C, P_Id, P_IDL_Digits, P_IDL_Type, P_Implicit, P_In_Context, P_Index, P_Init, P_Into, P_Invoke_Access, P_Invoke_Db, P_Invoke_Name_Access, P_Invoke_Record, P_Item, P_Label, P_Length, P_Logical_Type_Id, P_Mech, P_Members, P_Mode, P_N_Operations, P_Name, P_Name_Access, P_Names_Db, P_New_Switch, P_New_Union, P_Notepad, P_Null_Sequence, P_Obj, P_Operation, P_Operation_Name, P_Original_Type, P_Params, P_Parent, P_Payload, P_Provides, P_R_ACC, P_Repository_Id, P_Representation, P_Req, P_Req_Flags, P_Request, P_Result, P_Returns, P_Role, P_Scale, P_Self, P_Shutdown, P_Target, P_TC, P_The_Ref, P_To, P_Version, P_Message, P_Dependent_Binding_Object, P_X, P_Content, P_QoS); PN : array (Parameter_Id) of Name_Id; -- Array of parameter identifiers type Variable_Id is (V_Argument, V_Argument_List, V_Argument_Name, V_Args_In, V_Args_Out, V_Argument_Type_Id, V_Arg_Name_Type_Id, V_Context, V_Exception_List, V_Fixed_Point, V_Handler, V_Id, V_Impl_Object_Ptr, V_Index, V_Label, V_Label_Any, V_Members, V_Name, V_Operation_Name, V_Operation, V_Position, V_Req_Payload, V_Request, V_Result, V_Result_Name, V_Result_NV, V_Returns, V_Send_Request_Result, V_Seq, V_Seq_Element, V_Seq_Len, V_Type_Id, V_Value_Operation, V_Buffer_Size, V_Buffer, V_Buffer_In, V_Buffer_Out, V_CDR_Position, V_FXS, V_Error, V_Representation, V_Minor, V_Binding_Profile, V_Binding_Object, V_Component, V_Operation_Argument_List, V_Session, V_Pointer); VN : array (Variable_Id) of Name_Id; -- Array of variable identifiers type Subprogram_Id is (S_Adjust, S_Append, S_Clone, S_Deferred_Initialization, S_Dispatch, S_Entity_Of, S_Get_Members, S_Finalize, S_Finalize_Value, S_Free, S_From_Any, S_Get_Aggregate_Count, S_Get_Aggregate_Element, S_Hash, S_Initialize, S_Invoke, S_Is_A, S_Length, S_Marshall, S_Minus, -- "-" S_Register_Procedure, S_Servant_Is_A, S_Set, S_Set_Aggregate_Count, S_Set_Aggregate_Element, S_To_Abstract_Ref, S_To_Address, S_To_Any, S_To_Bounded_String, S_To_Bounded_Wide_String, S_To_CORBA_String, S_To_CORBA_Wide_String, S_To_Local_Ref, S_To_Ref, S_To_String, S_To_Wide_String, S_Unchecked_Get_V, S_Unchecked_To_Abstract_Ref, S_Unchecked_To_Local_Ref, S_Unchecked_To_Ref, S_Unmarshall, S_Wrap, S_Type_Size); SN : array (Subprogram_Id) of Name_Id; -- Array of subprogram identifiers type Component_Id is (C_Argument, C_Completed, C_Deferred_Arguments_Session, C_Dimen, C_Indices, C_Minor, C_Mode, C_Name, C_IDL_Type, C_Repr_Cache, C_Switch, C_Switch_Cache, C_Type_Def, C_V); CN : array (Component_Id) of Name_Id; -- Array of component identifiers type Attribute_Id is (A_Access, A_Class, A_First, A_Last, A_Pos, A_Val, A_Identity, A_Address, A_Repr, A_Size, A_Length, A_Unchecked_Access, A_Unrestricted_Access); AN : array (Attribute_Id) of Name_Id; -- Array of attribute identifiers type Type_Id is (T_Abstract_Ref, T_Bounded_String, T_Bounded_Wide_String, T_Invoke_Record_Type, T_Local_Ref, T_Object, T_Object_Ptr, T_Procedure_Access, T_Ref, T_Sequence, T_String_Ptr); TN : array (Type_Id) of Name_Id; -- Array of type identifiers type Pragma_Id is (Pragma_Assert, Pragma_Elaborate_Body, Pragma_Inline, Pragma_No_Return, Pragma_Style_Checks, Pragma_Suppress, Pragma_Unreferenced, Pragma_Warnings); GN : array (Pragma_Id) of Name_Id; -- Array of pragma identifiers type Error_Id is (E_Program_Error, E_Constraint_Error); EN : array (Error_Id) of Name_Id; -- Array of exception identifiers function Add_Prefix_To_Name (Prefix : String; Name : Name_Id) return Name_Id; -- Add the 'Prefix' string to the beginning of 'Name' and returns -- the corresponding name id. Note that the content of the -- Name_Buffer could be modified after the end of this function. function Add_Suffix_To_Name (Suffix : String; Name : Name_Id) return Name_Id; -- Append the 'Suffix' string to the end of 'Name' and returns the -- corresponding name id. Note that the content of the Name_Buffer -- could be modified after the end of this function. function Remove_Suffix_From_Name (Suffix : String; Name : Name_Id) return Name_Id; -- This function returns a new name id without the Suffix. If the -- suffix does not exist, the returned name id is equal to the -- given name id. procedure Add_With_Package (E : Node_Id; Unreferenced : Boolean := False); -- Append a 'with' clause to the Withed_Package list of the -- current package. E is a Designator of the Withed package. -- If Unreferenced is True, generate a pragma Unreferenced. procedure Append_To (L : List_Id; E : Node_Id); -- Append node E to the end of list L. If E is the head of a list, all -- following nodes are also appended to L. If E is in the middle of a list, -- the list structure will get garbled. ???Perhaps we should distinguish -- appending a node from appending a list. procedure Prepend_To (L : List_Id; E : Node_Id); -- Prepend node E (which must not be on a list) at the head of L function Convert (K : Frontend.Nodes.Node_Kind) return RE_Id; -- If K is an IDL base type, returns the corresponding CORBA type -- (according to the mapping specifications. Otherwise, raises -- Program_Error. procedure Push_Entity (E : Node_Id); -- Push the IDL_Entity E at the Top of the IDL_Entity stack procedure Pop_Entity; -- Remove the current top of the IDL_Entity stack function Current_Entity return Node_Id; -- Return the top of the IDL_Entity stack function Current_Package return Node_Id; -- Return the top of the Ada Package stack function Copy_Node (N : Node_Id) return Node_Id; -- Return a recursive copy of node N and its children. -- Implemented for: -- K_Identifier -- K_Defining_Identifier -- K_Attribute_Reference. -- K_Selected_Component -- K_Literal -- Program_Error is raised for all other kinds. function Get_Declaration_Node (N : Node_Id) return Node_Id; -- If N is of kind K_Defining_Identifier, return the value of its -- Declaration_Node field. If N is of kind K_Selected_Component, -- return the value of its Selector_Name's Declaration_Node -- field. Otherwise, raise Program_Error. function Get_Base_Identifier (N : Node_Id) return Node_Id; -- If N is a K_Identifier or K_Defining_Identifier, return it -- unchanged. If N is a selected subcomponent, return its -- Selector_Name. Otherwise, returns the Defining_Identifier of N. function Get_Name (N : Node_Id) return Name_Id; -- If N is of kind K_Defining_Identifier or K_identifier, return -- the value of its Name field. If N is of kind -- K_Selected_Component, return the value of its Selector_Name's -- Name field. Otherwise, raise Program_Error. function Get_Value (N : Node_Id) return Value_Id; -- If N is a K_Literal, return its Value. If N is a -- K_Selected_Component, return the Value of its -- Selector_Name. Otherwise, raise Program_Error. function Get_Parent_Unit_Name (N : Node_Id) return Node_Id; -- If N is a selected component, return the value of its Prefix -- field. Otherwise, return No_Node. function New_Node (Kind : Node_Kind; From : Node_Id := No_Node) return Node_Id; -- Create a new Ada Node_Id of Kind 'Kind'. If the 'From' node is given, -- set the FE_Node of the newly created node to 'From'. 'From' is -- consequently assumed to designate an IDL Node_Id function Image (T : Token_Type) return String; -- Return the lower case image of token T (used to build the -- Token_Image table) function Image (Op : Operator_Type) return String; -- Return the lower case image of token T. All '_' are replaced by -- spaces (used to build the Operator_Image table) function Is_Class_Wide (E : Node_Id) return Boolean; -- Return True if the type specifier of IDL entity E (an operation -- or a parameter declaration) must be mapped into an Ada -- class-wide type. Extract from the Ada mapping specification -- V. 1.2 concerning the mapping of IDL operations : "The argument -- or return type shall be mapped from the IDL type except in the -- case of an argument or return type that is of the enclosing IDL -- unit type. Arguments or result types of the enclosing unit -- types shall be mapped to the class of the mapped reference type -- (for example, to Ref'Class for an constrained references)." procedure Initialize; -- Initialize the Nutils package by initializing different tables procedure New_Token (T : Token_Type; I : String := ""); -- Create a new Token and set its image to I (if given) function Length (L : List_Id) return Natural; -- Return the number of nodes in the list L procedure Remove_Node_From_List (E : Node_Id; L : List_Id); -- Remove node N to list L. function Is_Empty (L : List_Id) return Boolean; pragma Inline (Is_Empty); -- Return true when L is No_List or when Length (L) is 0 function Copy_Expanded_Name (N : Node_Id; Withed : Boolean := True) return Node_Id; -- Copy the expanded name N. Add the proper 'with' clause (of the parent) -- if the 'Withed' flag is set. function Expand_Designator (N : Node_Id; Add_With_Clause : Boolean := True) return Node_Id; -- This function creates a new designator from the node N which may be: -- * a type declaration -- * a subprogram specification -- * an object declaration -- * a package specification -- * a package declaration -- The newly created node is a designator having the same defining -- identifier as N. The parent unit name of the result is set based on: -- * the Parent_Unit_Name of node N defining identifier, if we are -- handling a forward interface declaration. -- * the "Parent" field of N in all other cases. -- Formal parameter Add_With_Clause is completely undocumented??? --------------------------------- -- Ada Tree Building Functions -- --------------------------------- -- Each Make_ function creates a Node_Id of Kind -- . The parameters of the function usually correspond to the -- fields of the Node (see the file backend-be_corba_ada-nodes.idl for more -- detail on the Ada tree structure). -- ??? The "usually" above is frightening, these factory fuctions should -- be generated automatically, and their signatures should correspond -- EXACTLY to the tree structure! function Make_Access_Type_Definition (Subtype_Indication : Node_Id; Is_All : Boolean := False; Is_Constant : Boolean := False; Is_Not_Null : Boolean := False) return Node_Id; -- Usually used with Make_Full_Type_Declaration function Make_Ada_Comment (N : Name_Id; Has_Header_Spaces : Boolean := True) return Node_Id; -- This function does only the following thing : it creates a node -- whose name is the full text of the comment. It does not split -- the comment into many lines. This is done in the code -- generation phase function Make_Array_Aggregate (Elements : List_Id) return Node_Id; function Make_Array_Type_Definition (Range_Constraints : List_Id; Component_Definition : Node_Id; Index_Definition : Node_Id := No_Node) return Node_Id; -- Usually used with Make_Full_Type_Declaration function Make_String_Type_Definition (Defining_Identifier : Node_Id; Range_Constraint : Node_Id) return Node_Id; -- Usually used with Make_Full_Type_Declaration function Make_Assignment_Statement (Variable_Identifier : Node_Id; Expression : Node_Id) return Node_Id; function Make_Attribute_Reference (Prefix : Node_Id; Attribute : Attribute_Id) return Node_Id; function Make_Block_Statement (Statement_Identifier : Node_Id := No_Node; Declarative_Part : List_Id; Statements : List_Id; Exception_Handler : List_Id := No_List) return Node_Id; function Make_Case_Statement (Expression : Node_Id; Case_Statement_Alternatives : List_Id) return Node_Id; function Make_Case_Statement_Alternative (Discret_Choice_List : List_Id; Statements : List_Id) return Node_Id; function Make_Component_Association (Selector_Name : Node_Id; Expression : Node_Id) return Node_Id; -- If 'Selector_Name' is No_Node, then 'others => ' -- will be generated function Make_Component_Declaration (Defining_Identifier : Node_Id; Subtype_Indication : Node_Id; Expression : Node_Id := No_Node; Aliased_Present : Boolean := False) return Node_Id; function Make_Decimal_Type_Definition (Definition : Node_Id) return Node_Id; -- Creates an Ada Fixed point type definition from the IDL fixed -- point type definition node. Usually used with -- Make_Full_Type_Declaration function Make_Identifier (Name : Name_Id) return Node_Id; function Make_Defining_Identifier (Name : Name_Id) return Node_Id; function Make_Derived_Type_Definition (Subtype_Indication : Node_Id; Record_Extension_Part : Node_Id := No_Node; Is_Abstract_Type : Boolean := False; Is_Private_Extension : Boolean := False; Is_Subtype : Boolean := False) return Node_Id; -- Usually used with Make_Full_Type_Declaration function Make_Elsif_Statement (Condition : Node_Id; Then_Statements : List_Id) return Node_Id; function Make_Element_Association (Index : Node_Id; Expression : Node_Id) return Node_Id; -- If 'Index' is No_Node, then 'others => ' will be -- generated function Make_Enumeration_Type_Definition (Enumeration_Literals : List_Id) return Node_Id; -- Usually used with Make_Full_Type_Declaration function Make_Exception_Declaration (Defining_Identifier : Node_Id; Renamed_Exception : Node_Id := No_Node; Parent : Node_Id := Current_Package) return Node_Id; function Make_Explicit_Dereference (Prefix : Node_Id) return Node_Id; function Make_Expression (Left_Expr : Node_Id; Operator : Operator_Type := Op_None; Right_Expr : Node_Id := No_Node) return Node_Id; function Make_For_Statement (Defining_Identifier : Node_Id; Range_Constraint : Node_Id; Statements : List_Id) return Node_Id; function Make_Full_Type_Declaration (Defining_Identifier : Node_Id; Type_Definition : Node_Id; Discriminant_Spec : List_Id := No_List; Parent : Node_Id := Current_Package; Is_Subtype : Boolean := False) return Node_Id; -- Parent is the package in which the Type declaration will be put -- (useful for further with clauses and for designator expanding) function Make_If_Statement (Condition : Node_Id; Then_Statements : List_Id; Elsif_Statements : List_Id := No_List; Else_Statements : List_Id := No_List) return Node_Id; function Make_Indexed_Component (Prefix : Node_Id; Expressions : List_Id) return Node_Id; function Make_Instantiated_Subprogram (Defining_Identifier : Node_Id; Parameter_List : List_Id) return Node_Id; function New_List (N1 : Node_Id := No_Node; N2 : Node_Id := No_Node; N3 : Node_Id := No_Node; N4 : Node_Id := No_Node; N5 : Node_Id := No_Node) return List_Id; -- Create a list which contains all the given nodes (except No_Nodes are -- ignored). function Make_Literal (Value : Value_Id) return Node_Id; function Make_Literal_With_Parent (Value : Value_Id; Parent : Node_Id) return Node_Id; -- Same as Make_Literal, except that if parent is present and Value is not -- No_Value, creates a selected component whose prefix is the parent and -- whose selector name is the literal. This is needed for enumeration -- literals; we need to refer to Package_Name.Enum_Lit. function Make_Null_Statement return Node_Id; function Make_Object_Declaration (Defining_Identifier : Node_Id; Constant_Present : Boolean := False; Object_Definition : Node_Id; Expression : Node_Id := No_Node; Parent : Node_Id := Current_Package; Renamed_Object : Node_Id := No_Node; Aliased_Present : Boolean := False) return Node_Id; -- Parent is the package in which the Type declaration will be put -- (useful for further with clauses and for designator expansion). function Make_Object_Instantiation (Qualified_Expression : Node_Id) return Node_Id; function Make_Package_Declaration (Identifier : Node_Id) return Node_Id; function Make_Package_Instantiation (Defining_Identifier : Node_Id; Generic_Package : Node_Id; Parameter_List : List_Id := No_List; Parent : Node_Id := Current_Package) return Node_Id; -- Parent is the package in which the Type declaration will be put (useful -- for further with clauses and for designator expansion). function Make_Parameter_Association (Selector_Name : Node_Id; Actual_Parameter : Node_Id) return Node_Id; function Make_Parameter_Specification (Defining_Identifier : Node_Id; Subtype_Mark : Node_Id; Parameter_Mode : Mode_Id := Mode_In; Expression : Node_Id := No_Node) return Node_Id; function Make_Pragma (The_Pragma : Pragma_Id; Argument_List : List_Id := No_List) return Node_Id; function Make_Qualified_Expression (Subtype_Mark : Node_Id; Operand : Node_Id) return Node_Id; function Make_Raise_Statement (Raised_Error : Node_Id := No_Node) return Node_Id; function Make_Range_Constraint (First : Node_Id; Last : Node_Id) return Node_Id; function Make_Record_Aggregate (L : List_Id; Ancestor_Part : Node_Id := No_Node) return Node_Id; function Make_Record_Definition (Component_List : List_Id) return Node_Id; function Make_Record_Type_Definition (Record_Definition : Node_Id; Is_Abstract_Type : Boolean := False; Is_Tagged_Type : Boolean := False; Is_Limited_Type : Boolean := False) return Node_Id; function Make_Return_Statement (Expression : Node_Id) return Node_Id; function Make_Subprogram_Call (Defining_Identifier : Node_Id; Actual_Parameter_Part : List_Id) return Node_Id; function Make_Subprogram_Body (Specification : Node_Id; Declarations : List_Id; Statements : List_Id) return Node_Id; function Make_Selected_Component (Prefix : Node_Id; Selector_Name : Node_Id) return Node_Id; function Make_Selected_Component (Prefix : Name_Id; Selector_Name : Name_Id) return Node_Id; -- If the prefix is No_Node (or No_Name), these functions return a simple -- simple Identifier. function Make_Subprogram_Specification (Defining_Identifier : Node_Id; Parameter_Profile : List_Id; Return_Type : Node_Id := No_Node; Parent : Node_Id := Current_Package; Renamed_Subprogram : Node_Id := No_Node; Instantiated_Subprogram : Node_Id := No_Node) return Node_Id; -- Parent is the package in which the Type declaration will be put -- (useful for further with clauses and for designator expanding) function Make_Type_Conversion (Subtype_Mark : Node_Id; Expression : Node_Id) return Node_Id; function Make_Slice (Prefix : Node_Id; Discrete_Range : Node_Id) return Node_Id; function Make_Range (Low_Bound : Node_Id; High_Bound : Node_Id) return Node_Id; function Make_Used_Package (The_Used_Package : Node_Id) return Node_Id; function Make_Used_Type (The_Used_Type : Node_Id) return Node_Id; function Make_Variant_Part (Discriminant : Node_Id; Variant_List : List_Id) return Node_Id; procedure Make_Comment_Header (Package_Header : List_Id; Package_Identifier : Node_Id); -- This procedure generates a comment header for the generated pacakge. -- The comment text depends on the nature of the package (editable by the -- user or not). function Next_N_Node (N : Node_Id; Num : Natural) return Node_Id; -- This function executes Next_Node 'Num' times procedure Set_Forwarded (E : Node_Id); -- Mark the IDL node E as "Forwarded" function Is_Forwarded (E : Node_Id) return Boolean; -- Return True iff the node E has been marked as "Forwarded" -- The Set_XXXX_(Spec|Body) subprograms modifies the current_package to -- the Package_(Spec|Body) (XXXX_Package (N)) procedure Set_CDR_Body (N : Node_Id := Current_Entity); procedure Set_CDR_Spec (N : Node_Id := Current_Entity); procedure Set_Aligned_Spec (N : Node_Id := Current_Entity); procedure Set_Buffers_Body (N : Node_Id := Current_Entity); procedure Set_Buffers_Spec (N : Node_Id := Current_Entity); procedure Set_Helper_Body (N : Node_Id := Current_Entity); procedure Set_Helper_Spec (N : Node_Id := Current_Entity); procedure Set_Internals_Body (N : Node_Id := Current_Entity); procedure Set_Internals_Spec (N : Node_Id := Current_Entity); procedure Set_Impl_Body (N : Node_Id := Current_Entity); procedure Set_Impl_Spec (N : Node_Id := Current_Entity); procedure Set_IR_Info_Body (N : Node_Id := Current_Entity); procedure Set_IR_Info_Spec (N : Node_Id := Current_Entity); procedure Set_Main_Body (N : Node_Id := Current_Entity); procedure Set_Main_Spec (N : Node_Id := Current_Entity); procedure Set_Skeleton_Body (N : Node_Id := Current_Entity); procedure Set_Skeleton_Spec (N : Node_Id := Current_Entity); function To_Ada_Name (N : Name_Id; Is_Operation_Name : Boolean := False) return Name_Id; -- Converts an IDL name into an Ada name. The IDL name is converted -- according to the Ada mapping specifications. The following modifications -- may be applied to the IDL name to produce the Ada name: -- * Any leading underscores are removed -- * When there are two consecutive '_', replace the second -- underscore with the character 'U'. -- * Where '_' is at the end of an identifier, add the character -- 'U' after the underscore. -- * When an IDL identifier clashes with an Ada reserved word or, -- if Is_Operation_Name is True, with the name of a primitive operation -- of Ada.Finalization.Controlled, insert the string "IDL_" before the -- identifier. function To_Spec_Name (N : Name_Id) return Name_Id; -- Builds an internal name id used when handling runtime entities function Fully_Qualified_Name (N : Node_Id) return Name_Id; -- Returns the full name of an Ada designator or defining -- identifier. The separator is '.' -- The routines below allow the access to some global statement -- lists type GLists is (GL_Deferred_Initialization, GL_Initialization_Block, GL_Dependencies, GL_Register_IR_Info); procedure Initialize_GList (P : Node_Id; L : GLists); -- Creates a new global list for the package declaration P and -- makes a binding between the list and P. If the list has been -- already initialized, this procedure does not do anything. function Get_GList (P : Node_Id; L : GLists) return List_Id; -- Return the List_Id corresponding to the list L of the package -- declaration P. If the list has not been initialized, initialize -- it and return it. function Unique_Suffix return String; pragma Inline (Unique_Suffix); -- Returns a string containing a non-ASCII character, which is appended to -- various identifiers generated by iac in order to prevent collisions with -- identifiers resulting from the mapping of IDL user identifiers. This -- works because non-ASCII characters are not permitted in IDL identifiers. -- The string is encoded in Latin_1 by default; the procedure -- Set_UTF_8_Encoding is used to change the encoding. The character -- currently used is LATIN CAPITAL LETTER U WITH DIAERESIS, so this returns -- "_Ü". function Unique_Infix return String; pragma Inline (Unique_Infix); -- Same as Unique_Suffix, except this is used in the middle of identifiers, -- so it returns "_Ü_". procedure Set_UTF_8_Encoding; -- Causes Unique_Suffix and Unique_Infix to use UTF_8 encoding. Called when -- the -gnatW8 command line switch is given. end Backend.BE_CORBA_Ada.Nutils; polyorb-2.8~20110207.orig/compilers/iac/backend-be_corba_ada-skels.ads0000644000175000017500000000437011750740337024703 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- B A C K E N D . B E _ C O R B A _ A D A . S K E L S -- -- -- -- S p e c -- -- -- -- Copyright (C) 2005-2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ package Backend.BE_CORBA_Ada.Skels is package Package_Spec is procedure Visit (E : Node_Id); end Package_Spec; package Package_Body is procedure Visit (E : Node_Id); end Package_Body; end Backend.BE_CORBA_Ada.Skels; polyorb-2.8~20110207.orig/compilers/iac/backend-be_corba_ada-helpers.ads0000644000175000017500000000440211750740337025220 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- B A C K E N D . B E _ C O R B A _ A D A . H E L P E R S -- -- -- -- S p e c -- -- -- -- Copyright (C) 2005-2007, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ package Backend.BE_CORBA_Ada.Helpers is package Package_Spec is procedure Visit (E : Node_Id); end Package_Spec; package Package_Body is procedure Visit (E : Node_Id); end Package_Body; end Backend.BE_CORBA_Ada.Helpers; polyorb-2.8~20110207.orig/compilers/iac/backend-be_corba_ada-aligned.ads0000644000175000017500000000424611750740337025167 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- B A C K E N D . B E _ C O R B A _ A D A . A L I G N E D -- -- -- -- S p e c -- -- -- -- Copyright (C) 2005-2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ package Backend.BE_CORBA_Ada.Aligned is package Package_Spec is procedure Visit (E : Node_Id); end Package_Spec; end Backend.BE_CORBA_Ada.Aligned; polyorb-2.8~20110207.orig/compilers/iac/outfiles.adb0000644000175000017500000000705511750740337021452 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- O U T F I L E S -- -- -- -- B o d y -- -- -- -- Copyright (C) 2007-2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with Flags; use Flags; with Namet; use Namet; with Output; use Output; with Ada.Containers.Ordered_Sets; package body Outfiles is package Name_Sets is new Ada.Containers.Ordered_Sets (Element_Type => Name_Id); use Name_Sets; File_Names_Seen : Name_Sets.Set := Empty_Set; ---------------- -- Set_Output -- ---------------- function Set_Output (File_Name : Name_Id) return File_Descriptor is Fd : File_Descriptor; begin if not Use_Stdout then -- Assert that we don't try to write the same file twice. Insert will -- raise Constraint_Error if the same name is inserted again. pragma Debug (Insert (File_Names_Seen, File_Name)); if Output_Directory /= null then Set_Str_To_Name_Buffer (Output_Directory.all); else Name_Len := 0; end if; Get_Name_String_And_Append (File_Name); -- Create file, overwriting any pre-existing file by the same name Fd := Create_File (Name_Buffer (1 .. Name_Len), Binary); if Fd = Invalid_FD then raise Program_Error; end if; -- Set output stream Set_Output (Fd); return Fd; end if; return Invalid_FD; end Set_Output; -------------------- -- Release_Output -- -------------------- procedure Release_Output (Fd : File_Descriptor) is begin if not Use_Stdout and then Fd /= Invalid_FD then Close (Fd); Set_Standard_Output; end if; end Release_Output; end Outfiles; polyorb-2.8~20110207.orig/compilers/iac/frontend-nodes.idl0000644000175000017500000003225011750740337022562 0ustar xavierxaviermodule Frontend::Nodes { /******************/ /* Internal types */ /******************/ typedef octet Mode_Id; typedef octet Pragma_Type; typedef octet Operator_Id; typedef long Name_Id; typedef long Value_Id; /******************/ /* Internal nodes */ /******************/ interface Node_Id { Node_Id Next_Entity; boolean Imported; }; /* This node kind is useful to link the nodes of the tree to the ones of another tree */ interface Linkable_Node_Id : Node_Id { Node_Id BE_Node; }; interface Definition : Node_Id { Node_Id Identifier; // Identifier associated to definition Node_Id Type_Id; Node_Id Type_Version; }; interface Forward_Declaration : Definition { Node_Id Forward; }; interface List_Id { Node_Id First_Entity; Node_Id Last_Entity; long Size; }; interface Scope_Definition : Definition { Node_Id Scoped_Identifiers; }; interface Identifier : Linkable_Node_Id { Name_Id IDL_Name; // Name in original source form Name_Id Name; // Name converted to lowercase Node_Id Homonym; Node_Id Corresponding_Entity; Node_Id Scope_Entity; Node_Id Potential_Scope; boolean Visible; boolean Implicitly_Visible; Node_Id Next_Identifier; }; /**********/ /* Pragma */ /**********/ interface _Pragma : Node_Id { Pragma_Type Pragma_Kind; Node_Id Target; Name_Id Data; }; /*************************/ /* Typeprefix and Typeid */ /*************************/ interface Type_Id_Declaration : Node_Id { Node_Id Target; Name_Id Data; }; interface Type_Prefix_Declaration : Type_Id_Declaration {}; /*****************/ /* Literal nodes */ /*****************/ interface Literal : Node_Id { Value_Id Value; }; interface Integer_Literal : Literal {}; interface String_Literal : Literal {}; interface Wide_String_Literal : Literal {}; interface Character_Literal : Literal {}; interface Wide_Character_Literal : Literal {}; interface Fixed_Point_Literal : Literal {}; interface Floating_Point_Literal : Literal {}; interface Boolean_Literal : Literal {}; /********************/ /* Declarator nodes */ /********************/ /* (51) ::= */ interface Simple_Declarator : Definition { Node_Id Declaration; }; /* (52) ::= (83) ::= + (84) ::= "[" "]" */ interface Complex_Declarator : Simple_Declarator { List_Id Array_Sizes; }; /********************/ /* Expression nodes */ /********************/ interface Expression : Node_Id { Operator_Id Operator; Value_Id Value; Node_Id Left_Expr; Node_Id Right_Expr; }; /******************/ /* Constant nodes */ /******************/ /* (27) ::= "const" "=" */ interface Constant_Declaration : Definition { Node_Id Type_Spec; Node_Id Expression; Value_Id Value; }; /****************/ /* Module nodes */ /****************/ /* (3) ::= "module" "{" + "}" */ interface _Module : Scope_Definition { List_Id Definitions; List_Id Type_Prefixes; }; interface _Import : Node_Id { Node_Id Imported_Scope; }; interface Specification : Definition { List_Id Imports; List_Id Definitions; Node_Id Scoped_Identifiers; List_Id Type_Prefixes; }; /*****************/ /* Forward nodes */ /*****************/ /* (6) ::= [ "abstract" | "local" ] "interface" */ interface Forward_Interface_Declaration : Forward_Declaration { boolean Is_Abstract_Interface; boolean Is_Local_Interface; }; /* (14) ::= [ "abstract" ] "valuetype" */ interface Value_Forward_Declaration : Forward_Declaration { boolean Is_Abstract_Value; }; /* (99) ::= "struct" | "union" */ interface Forward_Structure_Type : Forward_Declaration {}; interface Forward_Union_Type : Forward_Declaration {}; /*******************/ /* Interface nodes */ /*******************/ /* (5) ::= "{" "}" (7) ::= [ "abstract" | "local" ] "interface" [ ] */ interface Interface_Declaration : Scope_Definition { boolean Is_Abstract_Interface; boolean Is_Local_Interface; List_Id Interface_Spec; List_Id Interface_Body; List_Id Type_Prefixes; }; /*******************/ /* Attribute nodes */ /*******************/ /* (85) ::= [ "readonly" ] "attribute" { "," }* */ interface Attribute_Declaration : Node_Id { boolean Is_Readonly; Node_Id Type_Spec; List_Id Declarators; List_Id Getter_Exceptions; List_Id Setter_Exceptions; }; /*******************/ /* Parameter nodes */ /*******************/ /* (91) ::= (92) ::= "in" | "out" | "inout" */ interface Parameter_Declaration : Node_Id { Mode_Id Parameter_Mode; Node_Id Type_Spec; Node_Id Declarator; }; /*******************/ /* Operation nodes */ /*******************/ /* (87) ::= [ ] [ ] [ ] */ interface Operation_Declaration : Scope_Definition { boolean Is_Oneway; Node_Id Type_Spec; List_Id Parameters; List_Id Exceptions; List_Id Contexts; }; /*********************/ /* Scoped name nodes */ /*********************/ interface Scoped_Name : Definition { Node_Id Reference; Node_Id Parent_Entity; long Depth; Node_Id Next_Scoped_Name; }; /***************/ /* Value nodes */ /***************/ /* (15) ::= "valuetype" */ interface Value_Box_Declaration : Scope_Definition { Node_Id Type_Spec; }; /* (16) ::= "abstract" "valuetype" [ ] "{" * "}" (17) ::= "{" * "}" (18) ::= [" custom" ] "valuetype" [ ] */ interface Generic_Value_Declaration : Value_Box_Declaration { Node_Id Value_Spec; List_Id Value_Body; }; interface Value_Declaration : Generic_Value_Declaration { boolean Is_Custom; List_Id Type_Prefixes; }; interface Abstract_Value_Declaration : Generic_Value_Declaration {}; /* (19) ::= [ ":" [ "truncatable" ] { "," }* ] [ "supports" { "," }* ] */ interface Value_Spec : Node_Id { boolean Is_Truncatable; Node_Id Identifier; List_Id Value_Names; List_Id Interface_Names; }; /**********************/ /* State member nodes */ /**********************/ /* (22) ::= ( "public" | "private" ) ";" */ interface State_Member : Node_Id { boolean Is_Public; Node_Id Type_Spec; List_Id Declarators; }; /*********************/ /* Initializer nodes */ /*********************/ /* (23) ::= "factory" "(" [ ] ")" ";" (24) ::= { "," }* (25) ::= */ interface Initializer_Declaration : Operation_Declaration {}; /*****************/ /* Typedef nodes */ /*****************/ /* (43) ::= (44) ::= | */ interface Type_Declaration : Node_Id { Node_Id Type_Spec; List_Id Declarators; }; /****************/ /* Member nodes */ /****************/ /* (71) ::= ";" */ interface Member : Node_Id { Node_Id Type_Spec; List_Id Declarators; }; /*******************/ /* Structure nodes */ /*******************/ /* (69) ::= "struct" "{" "}" (70) ::= + */ interface Structure_Type : Scope_Definition { List_Id Members; }; /***************/ /* Union nodes */ /***************/ /* (72) ::= "union" "switch" "(" ")" "{" "}" (73) ::= | | | | (74) ::= + (75) ::= + ";" (76) ::= "case" ":" | "default" ":" */ interface Case_Label : Node_Id { Node_Id Declaration; Node_Id Expression; // No_Node for "default" Value_Id Value; }; interface Switch_Alternative : Node_Id { Node_Id Declaration; List_Id Labels; Node_Id Element; }; /* (77) ::= */ interface Element : Node_Id { Node_Id Type_Spec; Node_Id Declarator; }; interface Union_Type : Scope_Definition { Node_Id Switch_Type_Spec; List_Id Switch_Type_Body; }; /*********************/ /* Enumeration nodes */ /*********************/ /* (78) ::= "enum" "{" { "," } "}" (79) ::= */ interface Enumerator : Definition { Value_Id Value; }; interface Enumeration_Type : Definition { List_Id Enumerators; }; /*******************/ /* Exception nodes */ /*******************/ /* (86) ::= "exception" "{" * "}" */ interface Exception_Declaration : Scope_Definition { List_Id Members; }; /****************/ /* Native nodes */ /****************/ /* (42) ::= "typedef" | [...] | "native" */ interface Native_Type : Node_Id { Node_Id Declarator; }; /******************/ /* Sequence nodes */ /******************/ /* (80) ::= "sequence" "<" "," ">" | "sequence" "<" ">" */ interface Sequence_Type : Linkable_Node_Id { Node_Id Type_Spec; Node_Id Max_Size; }; /****************/ /* String nodes */ /****************/ /* (81) ::= "string" "<" ">" | " string" (82) ::= "wstring" "<" ">" | " wstring" */ interface String_Type : Linkable_Node_Id { Node_Id Max_Size; }; interface Wide_String_Type : String_Type {}; /*********************/ /* Fixed point nodes */ /*********************/ /* (96) ::= "fixed" "<" "," ">" (97) ::= "fixed" */ interface Fixed_Point_Type : Linkable_Node_Id { long N_Total; long N_Scale; }; /*******************/ /* Base type nodes */ /*******************/ interface Base_Type { Name_Id Image; }; interface _Float : Base_Type {}; interface _Double : Base_Type {}; interface Long_Double : Base_Type {}; interface _Short : Base_Type {}; interface _Long : Base_Type {}; interface Long_Long : Base_Type {}; interface Unsigned_Short : Base_Type {}; interface Unsigned_Long : Base_Type {}; interface Unsigned_Long_Long : Base_Type {}; interface _Char : Base_Type {}; interface Wide_Char : Base_Type {}; interface _String : Base_Type {}; interface Wide_String : Base_Type {}; interface _Boolean : Base_Type {}; interface _Octet : Base_Type {}; interface _Object : Base_Type {}; interface _Any : Base_Type {}; interface _Void : Base_Type {}; interface Value_Base : Base_Type {}; }; polyorb-2.8~20110207.orig/compilers/iac/backend-be_corba_ada-idl_to_ada.adb0000644000175000017500000037661111750740337025632 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- B A C K E N D . B E _ C O R B A _ A D A . I D L _ T O _ A D A -- -- -- -- B o d y -- -- -- -- Copyright (C) 2005-2011, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with Namet; use Namet; with Values; use Values; with Locations; use Locations; with Charset; use Charset; with Utils; use Utils; with Frontend.Nodes; use Frontend.Nodes; with Frontend.Nutils; with Backend.BE_CORBA_Ada.Nodes; use Backend.BE_CORBA_Ada.Nodes; with Backend.BE_CORBA_Ada.Nutils; use Backend.BE_CORBA_Ada.Nutils; package body Backend.BE_CORBA_Ada.IDL_To_Ada is package BEN renames Backend.BE_CORBA_Ada.Nodes; package BEU renames Backend.BE_CORBA_Ada.Nutils; package FEU renames Frontend.Nutils; -- The entities below are used to avoid name collision when -- creating instantiated sequence packages function Get_Scope_Internal_Name (E_Name : Name_Id; E : Node_Id) return Name_Id; -- Return an internal name useful for the `New_Index' routine function New_Index (E_Name : Name_Id; E : Node_Id) return Nat; -- Get a new index inside the scope E to resolve clashing on name -- E_Name. -- The 3 subprogram below handle the mapping of entity -- names for Sequence and Bounded String types function Get_Mapped_Entity_Name (T : Node_Id) return Name_Id; -- If the node T has already been mapped, return the mapped -- name procedure Link_Mapped_Entity_Name (E_Name : Name_Id; T : Node_Id); -- Makes a link between E_Name and T function Get_Internal_Name (T : Node_Id) return Name_Id; -- Returns a conventional Name_Id useful for the two subprogram -- above function Map_Declarator_Type_Designator (Type_Decl : Node_Id; Declarator : Node_Id) return Node_Id; -- Map an Ada designator from Type_Decl according to the Ada -- mapping rules. ---------------------------- -- Get_Mapped_Entity_Name -- ---------------------------- function Get_Mapped_Entity_Name (T : Node_Id) return Name_Id is pragma Assert (FEN.Kind (T) = K_Fixed_Point_Type or else FEN.Kind (T) = K_Sequence_Type or else FEN.Kind (T) = K_String_Type or else FEN.Kind (T) = K_Wide_String_Type); Internal_Name : constant Name_Id := Get_Internal_Name (T); Info : constant Nat := Get_Name_Table_Info (Internal_Name); begin if Info /= 0 then return BEN.Name (Node_Id (Info)); end if; return No_Name; end Get_Mapped_Entity_Name; ----------------------------- -- Link_Mapped_Entity_Name -- ----------------------------- procedure Link_Mapped_Entity_Name (E_Name : Name_Id; T : Node_Id) is pragma Assert (FEN.Kind (T) = K_Fixed_Point_Type or else FEN.Kind (T) = K_Sequence_Type or else FEN.Kind (T) = K_String_Type or else FEN.Kind (T) = K_Wide_String_Type); Internal_Name : constant Name_Id := Get_Internal_Name (T); Info : constant Node_Id := Make_Defining_Identifier (E_Name); begin Set_Name_Table_Info (Internal_Name, Int (Info)); end Link_Mapped_Entity_Name; ----------------------- -- Get_Internal_Name -- ----------------------- function Get_Internal_Name (T : Node_Id) return Name_Id is begin Set_Str_To_Name_Buffer ("Mapped_Entity%"); Add_Nat_To_Name_Buffer (Nat (T)); return Name_Find; end Get_Internal_Name; ----------------------------- -- Get_Scope_Internal_Name -- ----------------------------- function Get_Scope_Internal_Name (E_Name : Name_Id; E : Node_Id) return Name_Id is begin Set_Str_To_Name_Buffer ("Scope%"); Get_Name_String_And_Append (E_Name); Add_Char_To_Name_Buffer ('%'); Add_Nat_To_Name_Buffer (Nat (E)); Add_Char_To_Name_Buffer ('%'); return Name_Find; end Get_Scope_Internal_Name; --------------- -- New_Index -- --------------- function New_Index (E_Name : Name_Id; E : Node_Id) return Nat is Internal_Name : constant Name_Id := Get_Scope_Internal_Name (E_Name, E); Index : Nat := Get_Name_Table_Info (Internal_Name); begin Index := Index + 1; Set_Name_Table_Info (Internal_Name, Index); return Index; end New_Index; ------------------ -- Base_Type_TC -- ------------------ function Base_Type_TC (K : FEN.Node_Kind) return Node_Id is begin case K is when FEN.K_Float => return RE (RE_TC_Float); when FEN.K_Double => return RE (RE_TC_Double); when FEN.K_Long_Double => return RE (RE_TC_Long_Double); when FEN.K_Short => return RE (RE_TC_Short); when FEN.K_Long => return RE (RE_TC_Long); when FEN.K_Long_Long => return RE (RE_TC_Long_Long); when FEN.K_Unsigned_Short => return RE (RE_TC_Unsigned_Short); when FEN.K_Unsigned_Long => return RE (RE_TC_Unsigned_Long); when FEN.K_Unsigned_Long_Long => return RE (RE_TC_Unsigned_Long_Long); when FEN.K_Char => return RE (RE_TC_Char); when FEN.K_Wide_Char => return RE (RE_TC_WChar); when FEN.K_String => return RE (RE_TC_String); when FEN.K_Wide_String => return RE (RE_TC_Wide_String); when FEN.K_Boolean => return RE (RE_TC_Boolean); when FEN.K_Octet => return RE (RE_TC_Octet); when FEN.K_Object => return RE (RE_TC_Object_0); when FEN.K_Any => return RE (RE_TC_Any); when others => raise Program_Error with "Not a base type: " & FEN.Node_Kind'Image (K); end case; end Base_Type_TC; ------------------- -- Bind_FE_To_BE -- ------------------- procedure Bind_FE_To_BE (F : Node_Id; B : Node_Id; W : Binding) is N : Node_Id; begin N := BE_Node (F); if No (N) then N := New_Node (BEN.K_BE_Ada); end if; case W is when B_Impl => Set_Impl_Node (N, B); when B_Stub => Set_Stub_Node (N, B); when B_TC => Set_TC_Node (N, B); when B_From_Any_Container => Set_From_Any_Container_Node (N, B); when B_From_Any => Set_From_Any_Node (N, B); when B_To_Any => Set_To_Any_Node (N, B); when B_Raise_Excp => Set_Raise_Excp_Node (N, B); when B_Initialize => Set_Initialize_Node (N, B); when B_To_Ref => Set_To_Ref_Node (N, B); when B_U_To_Ref => Set_U_To_Ref_Node (N, B); when B_Type_Def => Set_Type_Def_Node (N, B); when B_Forward => Set_Forward_Node (N, B); when B_Unmarshaller => Set_Unmarshaller_Node (N, B); when B_Marshaller => Set_Marshaller_Node (N, B); when B_Buffer_Size => Set_Buffer_Size_Node (N, B); when B_Instantiation => Set_Instantiation_Node (N, B); when B_Pointer_Type => Set_Pointer_Type_Node (N, B); when B_Aggr_Container => Set_Aggr_Container_Node (N, B); when B_Clone => Set_Clone_Node (N, B); when B_Finalize_Value => Set_Finalize_Value_Node (N, B); when B_Get_Aggregate_Count => Set_Get_Aggregate_Count_Node (N, B); when B_Set_Aggregate_Count => Set_Set_Aggregate_Count_Node (N, B); when B_Get_Aggregate_Element => Set_Get_Aggregate_Element_Node (N, B); when B_Set_Aggregate_Element => Set_Set_Aggregate_Element_Node (N, B); when B_Unchecked_Get_V => Set_Unchecked_Get_V_Node (N, B); when B_Wrap => Set_Wrap_Node (N, B); when B_Element_Wrap => Set_Element_Wrap_Node (N, B); when B_Args_In => Set_Args_In_Node (N, B); when B_Args_Out => Set_Args_Out_Node (N, B); when B_Access_Args_Out => Set_Access_Args_Out_Node (N, B); when B_IR_Function => Set_Ir_Function_Node (N, B); when B_Register_IR_Info => Set_Register_Ir_Info_Node (N, B); end case; FEN.Set_BE_Node (F, N); BEN.Set_FE_Node (B, F); end Bind_FE_To_BE; ------------------ -- Is_Base_Type -- ------------------ function Is_Base_Type (N : Node_Id) return Boolean is begin return FEN.Kind (N) in FEN.K_Float .. FEN.K_Value_Base; end Is_Base_Type; -------------------- -- Is_Object_Type -- -------------------- function Is_Object_Type (E : Node_Id) return Boolean is begin -- Object types are basically, the CORBA::Object type, -- interface declaration and forward interface declarations. if FEN.Kind (E) = K_Object or else FEN.Kind (E) = K_Interface_Declaration or else FEN.Kind (E) = K_Forward_Interface_Declaration then return True; end if; -- If a type is defined basing on the 3 types listed above, -- then it must be a scoped name. if FEN.Kind (E) /= K_Scoped_Name then return False; end if; if FEN.Kind (Reference (E)) = K_Interface_Declaration or else FEN.Kind (Reference (E)) = K_Forward_Interface_Declaration then return True; end if; -- Handle multi level type definition recursively. Only simple -- declarators are considered as object types. Arrays of -- abjects are NOT objects. if FEN.Kind (Reference (E)) = K_Simple_Declarator then return Is_Object_Type (Type_Spec (Declaration (Reference (E)))); end if; return False; end Is_Object_Type; ---------------------- -- Is_N_Parent_Of_M -- ---------------------- function Is_N_Parent_Of_M (N : Node_Id; M : Node_Id) return Boolean is X : Node_Id := N; Y : Node_Id := M; begin if No (Y) then return False; else if FEN.Kind (X) = K_Identifier then X := Corresponding_Entity (X); end if; if FEN.Kind (Y) = K_Identifier then Y := Corresponding_Entity (Y); end if; if X = Y then return True; elsif FEN.Kind (Y) = K_Specification or else FEN.Kind (Scope_Entity (Identifier (Y))) = K_Specification then return False; else return Is_N_Parent_Of_M (X, Scope_Entity (Identifier (Y))); end if; end if; end Is_N_Parent_Of_M; ------------------------ -- Map_Container_Name -- ------------------------ function Map_Container_Name (E : Node_Id) return Name_Id is The_Name : constant Name_Id := To_Ada_Name (IDL_Name (Identifier (E))); begin Set_Str_To_Name_Buffer ("Content" & Unique_Infix); Get_Name_String_And_Append (The_Name); return Name_Find; end Map_Container_Name; ------------------------------------ -- Map_Declarator_Type_Designator -- ------------------------------------ function Map_Declarator_Type_Designator (Type_Decl : Node_Id; Declarator : Node_Id) return Node_Id is Designator : Node_Id; begin Designator := Map_Expanded_Name (Type_Decl); -- The expansion phase ensures there cannot be complex -- declarators inside structures, exceptions and unions. if Kind (Declarator) = K_Complex_Declarator then raise Program_Error with "Complex declarators in structures, " & "unions and exceptions have to be expanded"; end if; return Designator; end Map_Declarator_Type_Designator; ----------------------------- -- Map_Defining_Identifier -- ----------------------------- function Map_Defining_Identifier (Entity : Node_Id) return Node_Id is I : Node_Id := Entity; Result : Node_Id; begin if FEN.Kind (Entity) /= FEN.K_Identifier then I := FEN.Identifier (Entity); end if; Result := Make_Defining_Identifier (To_Ada_Name (IDL_Name (I), Is_Operation_Name => FEN.Kind (Entity) = FEN.K_Operation_Declaration)); if Present (BE_Node (I)) and then Present (Stub_Node (BE_Node (I))) and then BEN.Kind (Stub_Node (BE_Node (I))) = K_IDL_Unit then Set_Declaration_Node (Result, Stubs_Package (Stub_Node (BE_Node (I)))); end if; return Result; end Map_Defining_Identifier; ----------------------- -- Map_Expanded_Name -- ----------------------- function Map_Expanded_Name (Entity : Node_Id) return Node_Id is P : Node_Id; N : Node_Id; K : FEN.Node_Kind; R : Node_Id; begin K := FEN.Kind (Entity); if K = FEN.K_Scoped_Name then R := Reference (Entity); -- The routine below verifies whether the scoped name -- designs a CORBA Entity declared in orb.idl, in which -- case, it returns the corresponding runtime entity. N := Map_Predefined_CORBA_Entity (Entity); if Present (N) then return N; end if; if Kind (R) = K_Specification then return No_Node; end if; -- Handling the case where R is not a base type nor a user -- defined type but an interface type. In this case we do -- not return the identifier of the interface name but the -- identifier to the Ref type defined in the stub package -- relative to the interface. if Kind (R) = FEN.K_Interface_Declaration then -- Get the node of the Ref type declaration. N := Copy_Node (Defining_Identifier (Type_Def_Node (BE_Node (Identifier (R))))); Set_FE_Node (N, R); P := R; elsif Kind (R) = FEN.K_Forward_Interface_Declaration then -- Get the node of the Ref type declaration. N := Make_Selected_Component (Expand_Designator (Instantiation_Node (BE_Node (Identifier (R)))), Copy_Node (Defining_Identifier (Type_Def_Node (BE_Node (Identifier (R)))))); Set_FE_Node (N, R); P := No_Node; else N := Map_Defining_Identifier (R); Set_FE_Node (N, R); P := Scope_Entity (Identifier (R)); end if; if Present (P) then if Kind (P) = K_Specification then N := Make_Selected_Component (Defining_Identifier (Stubs_Package (Stub_Node (BE_Node (Identifier (P))))), N); else N := Make_Selected_Component (Map_Expanded_Name (P), N); end if; end if; elsif K in FEN.K_Float .. FEN.K_Value_Base then N := RE (Convert (K)); Set_FE_Node (N, Entity); else N := Map_Defining_Identifier (Entity); if K = FEN.K_Interface_Declaration or else K = FEN.K_Module then P := Scope_Entity (Identifier (Entity)); Set_FE_Node (N, Entity); N := Make_Selected_Component (Map_Expanded_Name (P), N); elsif K = FEN.K_Specification then return No_Node; end if; end if; P := Get_Parent_Unit_Name (N); if Present (P) then Add_With_Package (P); end if; return N; end Map_Expanded_Name; ------------------------- -- Map_Fixed_Type_Name -- ------------------------- function Map_Fixed_Type_Name (F : Node_Id) return Name_Id is pragma Assert (FEN.Kind (F) = K_Fixed_Point_Type); F_Name : Name_Id; Info : Nat; Index : Nat; begin -- First of all, see whether we have already mapped the fixed -- point type F. F_Name := Get_Mapped_Entity_Name (F); if F_Name /= No_Name then return F_Name; end if; -- It's the first time we try to map the fixed point type F. Set_Str_To_Name_Buffer ("Fixed_"); Add_Nat_To_Name_Buffer (Nat (N_Total (F))); Add_Char_To_Name_Buffer ('_'); Add_Nat_To_Name_Buffer (Nat (N_Scale (F))); -- Now the sequence type name is almost built... F_Name := Name_Find; -- ... However we must resolve the conflicts that may occur -- with other fixed point type names Info := Get_Name_Table_Info (F_Name); if Info = Int (Stubs_Package (Current_Entity)) then Index := New_Index (F_Name, Stubs_Package (Current_Entity)); Get_Name_String (F_Name); Add_Char_To_Name_Buffer ('_'); Add_Nat_To_Name_Buffer (Index); F_Name := Name_Find; end if; Set_Name_Table_Info (F_Name, Int (Stubs_Package (Current_Entity))); -- Finally, we link F and F_Name Link_Mapped_Entity_Name (F_Name, F); return F_Name; end Map_Fixed_Type_Name; -------------------------------- -- Map_Fixed_Type_Helper_Name -- -------------------------------- function Map_Fixed_Type_Helper_Name (F : Node_Id) return Name_Id is pragma Assert (FEN.Kind (F) = K_Fixed_Point_Type); Type_Name : constant Name_Id := Map_Fixed_Type_Name (F); begin Set_Str_To_Name_Buffer ("Helper" & Unique_Infix); Get_Name_String_And_Append (Type_Name); return Name_Find; end Map_Fixed_Type_Helper_Name; ------------------------------------ -- Map_Fully_Qualified_Identifier -- ------------------------------------ function Map_Fully_Qualified_Identifier (Entity : Node_Id) return Node_Id is N : Node_Id; P : Node_Id; I : Node_Id; begin I := FEN.Identifier (Entity); Get_Name_String (IDL_Name (I)); if Kind (Entity) = K_Specification then Add_Str_To_Name_Buffer ("_IDL_File"); end if; N := Make_Defining_Identifier (Name_Find); P := FEN.Scope_Entity (I); if Present (P) and then FEN.Kind (P) /= FEN.K_Specification then if FEN.Kind (P) = FEN.K_Operation_Declaration then I := FEN.Identifier (P); P := FEN.Scope_Entity (I); end if; N := Make_Selected_Component (Map_Fully_Qualified_Identifier (P), N); end if; return N; end Map_Fully_Qualified_Identifier; -------------------------- -- Map_Get_Members_Spec -- -------------------------- function Map_Get_Members_Spec (Member_Type : Node_Id) return Node_Id is Profile : List_Id; Parameter : Node_Id; N : Node_Id; begin Profile := New_List; Parameter := Make_Parameter_Specification (Make_Defining_Identifier (PN (P_From)), RE (RE_Exception_Occurrence)); Append_To (Profile, Parameter); Parameter := Make_Parameter_Specification (Make_Defining_Identifier (PN (P_To)), Member_Type, Mode_Out); Append_To (Profile, Parameter); N := Make_Subprogram_Specification (Make_Defining_Identifier (SN (S_Get_Members)), Profile, No_Node); return N; end Map_Get_Members_Spec; ------------------ -- Map_IDL_Unit -- ------------------ function Map_IDL_Unit (Entity : Node_Id) return Node_Id is P : Node_Id; N : Node_Id; M : Node_Id; D : Node_Id; L : List_Id; I : Node_Id; Z : Node_Id; F : Node_Id; begin P := New_Node (K_IDL_Unit, Identifier (Entity)); L := New_List; Set_Packages (P, L); I := Map_Fully_Qualified_Identifier (Entity); -- We don't generate code for imported entities Set_Generate_Code (P, not Imported (Entity)); -- Main package M := Make_Package_Declaration (I); Set_IDL_Unit (M, P); Set_Stubs_Package (P, M); -- The main package is appended to the list (in order for the -- code to be generated) only if the user did not request to -- disable it. if not Disable_Client_Code_Gen then Append_To (L, M); end if; -- Helper package Set_Str_To_Name_Buffer ("Helper"); N := Make_Selected_Component (I, Make_Defining_Identifier (Name_Find)); D := Make_Package_Declaration (N); Set_IDL_Unit (D, P); Set_Parent (D, M); Set_Helper_Package (P, D); if not Disable_Client_Code_Gen then Append_To (L, D); end if; -- Internals package Set_Str_To_Name_Buffer ("Internals"); N := Make_Selected_Component (Copy_Node (Defining_Identifier (D)), Make_Defining_Identifier (Name_Find)); Z := Make_Package_Declaration (N); Set_IDL_Unit (Z, P); Set_Parent (Z, D); -- Internals is a subunit of Helper Set_Is_Subunit_Package (Package_Specification (Z), True); Append_To (Subunits (Package_Specification (D)), Package_Specification (Z)); Append_To (Statements (Package_Body (D)), Package_Body (Z)); -- As a subunit of Helper, Interals shares its list of withed -- packages with Helper. Set_Context_Clause (Package_Specification (Z), Context_Clause (Package_Specification (D))); Set_Context_Clause (Package_Body (Z), Context_Clause (Package_Body (D))); Set_Internals_Package (P, Z); -- Interface repository information package if IR_Info_Packages_Gen then Set_Str_To_Name_Buffer ("IR_Info"); N := Make_Selected_Component (I, Make_Defining_Identifier (Name_Find)); F := Make_Package_Declaration (N); Set_IDL_Unit (F, P); Set_Parent (F, M); Set_Ir_Info_Package (P, F); Append_To (L, F); end if; if Kind (Entity) = K_Interface_Declaration then if not FEN.Is_Abstract_Interface (Entity) then -- No CDR, Skel or Impl packages are generated for abstract -- interfaces. if not FEN.Is_Local_Interface (Entity) then -- No CDR or Skel packages are generated for local interfaces -- Skeleton package Set_Str_To_Name_Buffer ("Skel"); N := Make_Selected_Component (I, Make_Defining_Identifier (Name_Find)); D := Make_Package_Declaration (N); Set_IDL_Unit (D, P); Set_Parent (D, M); Set_Skeleton_Package (P, D); Append_To (L, D); -- CDR package Set_Str_To_Name_Buffer ("CDR"); N := Make_Selected_Component (I, Make_Defining_Identifier (Name_Find)); D := Make_Package_Declaration (N); Set_IDL_Unit (D, P); Set_Parent (D, M); Set_CDR_Package (P, D); if not Disable_Client_Code_Gen then Append_To (L, D); end if; -- Aligned package Set_Str_To_Name_Buffer ("Aligned"); N := Make_Selected_Component (I, Make_Defining_Identifier (Name_Find)); D := Make_Package_Declaration (N); Set_IDL_Unit (D, P); Set_Parent (D, M); Set_Aligned_Package (P, D); if not Disable_Client_Code_Gen then Append_To (L, D); end if; -- Buffers package Set_Str_To_Name_Buffer ("Buffers"); N := Make_Selected_Component (I, Make_Defining_Identifier (Name_Find)); D := Make_Package_Declaration (N); Set_IDL_Unit (D, P); Set_Parent (D, M); Set_Buffers_Package (P, D); if not Disable_Client_Code_Gen then Append_To (L, D); end if; end if; -- Implementation package Set_Str_To_Name_Buffer ("Impl"); N := Make_Selected_Component (I, Make_Defining_Identifier (Name_Find)); D := Make_Package_Declaration (N); Set_IDL_Unit (D, P); Set_Parent (D, M); Set_Implementation_Package (P, D); if Impl_Packages_Gen then Append_To (L, D); end if; end if; end if; return P; end Map_IDL_Unit; ---------------------------- -- Map_Impl_Type_Ancestor -- ---------------------------- function Map_Impl_Type_Ancestor (Entity : Node_Id) return Node_Id is pragma Assert (FEN.Kind (Entity) = K_Interface_Declaration or else FEN.Kind (Entity) = K_Forward_Interface_Declaration); Ancestor : Node_Id; begin if Is_Local_Interface (Entity) then Ancestor := RE (RE_Object_2); else Ancestor := RE (RE_Servant_Base); end if; return Ancestor; end Map_Impl_Type_Ancestor; ---------------------- -- Map_Indices_Name -- ---------------------- function Map_Indices_Name (D : Node_Id) return Name_Id is The_Name : constant Name_Id := To_Ada_Name (IDL_Name (Identifier (D))); begin Set_Str_To_Name_Buffer ("Indices" & Unique_Infix); Get_Name_String_And_Append (The_Name); return Name_Find; end Map_Indices_Name; ---------------------- -- Map_Lengths_Name -- ---------------------- function Map_Lengths_Name (D : Node_Id) return Name_Id is The_Name : constant Name_Id := To_Ada_Name (IDL_Name (Identifier (D))); begin Set_Str_To_Name_Buffer ("Lengths" & Unique_Infix); Get_Name_String_And_Append (The_Name); return Name_Find; end Map_Lengths_Name; ---------------------------- -- Map_Members_Definition -- ---------------------------- function Map_Members_Definition (Members : List_Id) return List_Id is Components : List_Id; Member : Node_Id; Declarator : Node_Id; Member_Type : Node_Id; Component_Declaration : Node_Id; begin Components := New_List; Member := First_Entity (Members); while Present (Member) loop Declarator := First_Entity (Declarators (Member)); Member_Type := Type_Spec (Member); while Present (Declarator) loop Component_Declaration := Make_Component_Declaration (Map_Defining_Identifier (FEN.Identifier (Declarator)), Map_Declarator_Type_Designator (Member_Type, Declarator)); Bind_FE_To_BE (Identifier (Declarator), Component_Declaration, B_Stub); Append_To (Components, Component_Declaration); Declarator := Next_Entity (Declarator); end loop; Member := Next_Entity (Member); end loop; return Components; end Map_Members_Definition; ------------------------------ -- Map_Narrowing_Designator -- ------------------------------ function Map_Narrowing_Designator (E : Node_Id; Unchecked : Boolean) return Node_Id is begin case Unchecked is when True => if Is_Abstract_Interface (E) then return Make_Defining_Identifier (SN (S_Unchecked_To_Abstract_Ref)); elsif Is_Local_Interface (E) then return Make_Defining_Identifier (SN (S_Unchecked_To_Local_Ref)); else return Make_Defining_Identifier (SN (S_Unchecked_To_Ref)); end if; when False => if Is_Abstract_Interface (E) then return Make_Defining_Identifier (SN (S_To_Abstract_Ref)); elsif Is_Local_Interface (E) then return Make_Defining_Identifier (SN (S_To_Local_Ref)); else return Make_Defining_Identifier (SN (S_To_Ref)); end if; end case; end Map_Narrowing_Designator; --------------------------- -- Map_Pointer_Type_Name -- --------------------------- function Map_Pointer_Type_Name (E : Node_Id) return Name_Id is Type_Name : constant Name_Id := To_Ada_Name (IDL_Name (Identifier (E))); begin Set_Str_To_Name_Buffer ("Ptr" & Unique_Infix); Get_Name_String_And_Append (Type_Name); return Name_Find; end Map_Pointer_Type_Name; ----------------- -- Map_IR_Name -- ----------------- function Map_IR_Name (E : Node_Id) return Name_Id is Prefix : constant String := "IR_"; Name : constant Name_Id := To_Ada_Name (IDL_Name (Identifier (E))); begin Set_Str_To_Name_Buffer (Prefix); Get_Name_String_And_Append (Name); return Name_Find; end Map_IR_Name; ------------------------ -- Map_Cached_IR_Name -- ------------------------ function Map_Cached_IR_Name (E : Node_Id) return Name_Id is Prefix : constant String := "Cached_"; Name : constant Name_Id := Map_IR_Name (E); begin Set_Str_To_Name_Buffer (Prefix); Get_Name_String_And_Append (Name); return Name_Find; end Map_Cached_IR_Name; --------------------------- -- Map_Range_Constraints -- --------------------------- function Map_Range_Constraints (Array_Sizes : List_Id) return List_Id is L : List_Id; S : Node_Id; R : Node_Id; V : Value_Type; begin L := New_List; S := FEN.First_Entity (Array_Sizes); while Present (S) loop V := FEU.Expr_Value (S); V.IVal := V.IVal - 1; -- Subtract 1 for zero-based arrays R := Make_Range_Constraint (Make_Literal (Int0_Val), Make_Literal (New_Value (V))); Append_To (L, R); S := FEN.Next_Entity (S); end loop; return L; end Map_Range_Constraints; ------------------ -- Map_Ref_Type -- ------------------ function Map_Ref_Type (Entity : Node_Id) return Node_Id is pragma Assert (FEN.Kind (Entity) = K_Interface_Declaration or else FEN.Kind (Entity) = K_Forward_Interface_Declaration); Ref_Type : Node_Id; begin if Is_Abstract_Interface (Entity) then Ref_Type := Make_Defining_Identifier (TN (T_Abstract_Ref)); elsif Is_Local_Interface (Entity) and then FEN.Kind (Entity) = K_Interface_Declaration then Ref_Type := Make_Defining_Identifier (TN (T_Local_Ref)); else Ref_Type := Make_Defining_Identifier (TN (T_Ref)); end if; return Ref_Type; end Map_Ref_Type; --------------------------- -- Map_Ref_Type_Ancestor -- --------------------------- function Map_Ref_Type_Ancestor (Entity : Node_Id; Withed : Boolean := True) return Node_Id is pragma Assert (FEN.Kind (Entity) = K_Interface_Declaration or else FEN.Kind (Entity) = K_Forward_Interface_Declaration); Ancestor : Node_Id; begin if Is_Abstract_Interface (Entity) then -- The abstract interfaces should inherit from -- CORBA.AbstractBase.Ref to allow passing interfaces and -- ValueTypes. -- Since the code generation for ValueType is not performed -- by IAC, it is useless (for now) to make the abstract -- interfaces inherit from CORBA.AbstractBase.Ref and it -- causes problems when compiling current generated code. -- XXX : To be replaced by RE_Ref_1 when the ValueTypes are -- implemented. Ancestor := RE (RE_Ref_2, Withed); else Ancestor := RE (RE_Ref_2, Withed); end if; return Ancestor; end Map_Ref_Type_Ancestor; ----------------------------------- -- Map_Repository_Id_Declaration -- ----------------------------------- function Map_Repository_Id_Declaration (Entity : Node_Id) return Node_Id is procedure Fetch_Prefix (Entity : Node_Id; Parent : Node_Id; Prefix : out Name_Id; Has_Prefix : out Boolean); procedure Get_Repository_Id_String (Entity : Node_Id; First_Recursion_Level : Boolean := True; Found_Prefix : Boolean := False); ------------------ -- Fetch_Prefix -- ------------------ procedure Fetch_Prefix (Entity : Node_Id; Parent : Node_Id; Prefix : out Name_Id; Has_Prefix : out Boolean) is Prefixes : constant List_Id := Type_Prefixes (Parent); P : Node_Id; begin Prefix := No_Name; Has_Prefix := False; if not FEU.Is_Empty (Prefixes) then P := First_Entity (Prefixes); while Present (P) loop -- By this test, we check at the same time that : -- * The Entity and the prefix are declared in the same file -- * The prefix is defined before the declaration of Entity if FEN.Loc (P) < FEN.Loc (Entity) then Prefix := IDL_Name (P); Has_Prefix := True; exit; end if; P := Next_Entity (P); end loop; end if; end Fetch_Prefix; ------------------------------ -- Get_Repository_Id_String -- ------------------------------ procedure Get_Repository_Id_String (Entity : Node_Id; First_Recursion_Level : Boolean := True; Found_Prefix : Boolean := False) is I : Node_Id; S : Node_Id; Prefix : Name_Id; Has_Prefix : Boolean := Found_Prefix; Name : Name_Id; begin -- The explicit definition of a type ID disables the effects -- of the type prefix and the type version explicit -- definitions, the conflicts being checked in the analyze -- phase of the frontend. if First_Recursion_Level and then Present (FEN.Type_Id (Entity)) then Get_Name_String (IDL_Name (FEN.Type_Id (Entity))); return; end if; -- For entity kinds modules, interfaces and valutypes, the -- prefix fetching begins from the entity itself. For the -- rest of kind, the fetching starts from the parent entity. if First_Recursion_Level and then (FEN.Kind (Entity) = K_Module or else FEN.Kind (Entity) = K_Interface_Declaration or else FEN.Kind (Entity) = K_Value_Declaration) and then not FEU.Is_Empty (Type_Prefixes (Entity)) then Has_Prefix := True; Name := Name_Find; -- Backup Prefix := IDL_Name (Last_Entity (Type_Prefixes (Entity))); Prefix := Add_Suffix_To_Name ("/", Prefix); Name := Add_Suffix_To_Name (Get_Name_String (Prefix), Name); Get_Name_String (Name); -- Restore Prefix := No_Name; end if; I := FEN.Identifier (Entity); -- The potential scope is used to determine the entity parent S := Potential_Scope (I); if Present (S) then -- We check if the scope entity S has a prefix whose declaration -- occurs before the Entity. if not Has_Prefix then Name := Name_Find; -- Backup Fetch_Prefix (Entity, S, Prefix, Has_Prefix); if Prefix /= No_Name then Prefix := Add_Suffix_To_Name ("/", Prefix); Name := Add_Suffix_To_Name (Get_Name_String (Prefix), Name); end if; Get_Name_String (Name); -- Restore end if; -- Then we continue building the string for the if FEN.Kind (S) /= FEN.K_Specification then Get_Repository_Id_String (S, False, Has_Prefix); Add_Char_To_Name_Buffer ('/'); end if; end if; Get_Name_String_And_Append (FEN.IDL_Name (I)); end Get_Repository_Id_String; I : Name_Id; V : Value_Id; begin I := Map_Repository_Id_Name (Entity); -- Building the Repository Id string value Set_Str_To_Name_Buffer ("IDL:"); Get_Repository_Id_String (Entity); if No (FEN.Type_Id (Entity)) then Add_Char_To_Name_Buffer (':'); Get_Name_String_And_Append (Map_Type_Version (Entity)); end if; V := New_String_Value (Name_Find, False); return Make_Object_Declaration (Defining_Identifier => Make_Defining_Identifier (I), Constant_Present => True, Object_Definition => RE (RE_String_2), Expression => Make_Literal (V)); end Map_Repository_Id_Declaration; ---------------------------- -- Map_Repository_Id_Name -- ---------------------------- function Map_Repository_Id_Name (Entity : Node_Id) return Name_Id is begin Name_Len := 0; case FEN.Kind (Entity) is when FEN.K_Interface_Declaration | FEN.K_Module => null; when FEN.K_Structure_Type | FEN.K_Simple_Declarator | FEN.K_Complex_Declarator | FEN.K_Enumeration_Type | FEN.K_Exception_Declaration | FEN.K_Operation_Declaration | FEN.K_Union_Type => Get_Name_String (To_Ada_Name (FEN.IDL_Name (FEN.Identifier (Entity)))); Add_Char_To_Name_Buffer ('_'); when others => raise Program_Error; end case; Add_Str_To_Name_Buffer ("Repository_Id"); return Name_Find; end Map_Repository_Id_Name; ---------------------- -- Map_Type_Version -- ---------------------- function Map_Type_Version (Entity : Node_Id) return Name_Id is NB : constant String := Name_Buffer (1 .. Name_Len); Result : Name_Id; begin if Present (Type_Version (Entity)) then Result := FEN.IDL_Name (Type_Version (Entity)); else -- Extract from the CORBA 3.0 spec ($10.7.5.3): -- "If no version pragma is supplied for a definition, version -- 1.0 is assumed" Set_Str_To_Name_Buffer ("1.0"); Result := Name_Find; end if; -- Restore the name buffer Set_Str_To_Name_Buffer (NB); return Result; end Map_Type_Version; ----------------------------- -- Map_Raise_From_Any_Name -- ----------------------------- function Map_Raise_From_Any_Name (Entity : Node_Id) return Name_Id is pragma Assert (FEN.Kind (Entity) = K_Exception_Declaration); Spg_Name : Name_Id := To_Ada_Name (IDL_Name (FEN.Identifier (Entity))); begin Set_Str_To_Name_Buffer ("Raise_"); Get_Name_String_And_Append (Spg_Name); Add_Str_To_Name_Buffer ("_From_Any"); Spg_Name := Name_Find; return Spg_Name; end Map_Raise_From_Any_Name; --------------------------- -- Map_Sequence_Pkg_Name -- --------------------------- function Map_Sequence_Pkg_Name (S : Node_Id) return Name_Id is pragma Assert (FEN.Kind (S) = K_Sequence_Type); Bounded : constant Boolean := Present (Max_Size (S)); Elt_Type : constant Node_Id := Type_Spec (S); ET_Name : Name_Id; S_Name : Name_Id; R : Node_Id; Info : Nat; Index : Nat; begin -- First of all, see whether we have already mapped the -- sequence type S. S_Name := Get_Mapped_Entity_Name (S); if S_Name /= No_Name then return S_Name; end if; -- It's the first time we try to map the sequence type S -- Get the full name of the sequence element type if Is_Base_Type (Elt_Type) then ET_Name := FEN.Image (Base_Type (Elt_Type)); elsif FEN.Kind (Elt_Type) = K_Scoped_Name then R := Reference (Elt_Type); if False or else FEN.Kind (R) = K_Interface_Declaration or else FEN.Kind (R) = K_Forward_Interface_Declaration or else FEN.Kind (R) = K_Simple_Declarator or else FEN.Kind (R) = K_Complex_Declarator or else FEN.Kind (R) = K_Structure_Type or else FEN.Kind (R) = K_Union_Type or else FEN.Kind (R) = K_Enumeration_Type then ET_Name := FEU.Fully_Qualified_Name (FEN.Identifier (R), Separator => "_"); else raise Program_Error; end if; else raise Program_Error; end if; -- If the type name consists of two or more words ("unsigned long"), -- replace spaces by underscores. Get_Name_String (ET_Name); for Index in 1 .. Name_Len loop if Name_Buffer (Index) = ' ' then Name_Buffer (Index) := '_'; end if; end loop; ET_Name := Name_Find; -- A prefix specified by the CORBA Ada mapping specifications Set_Str_To_Name_Buffer ("IDL_SEQUENCE_"); -- If the sequence is bounded, append the maximal length if Bounded then Add_Dnat_To_Name_Buffer (Dnat (FEU.Expr_Value (Max_Size (S)).IVal)); Add_Char_To_Name_Buffer ('_'); end if; -- Append the element type name Get_Name_String_And_Append (ET_Name); -- If the sequence type spec is a forwarded entity we append an -- indication to the package name. if FEN.Kind (Elt_Type) = K_Scoped_Name then R := FEN.Reference (Elt_Type); if False or else FEN.Kind (R) = K_Forward_Interface_Declaration or else FEN.Kind (R) = K_Value_Forward_Declaration or else FEN.Kind (R) = K_Forward_Structure_Type or else FEN.Kind (R) = K_Forward_Union_Type then Add_Str_To_Name_Buffer ("_Forward"); end if; end if; -- Now the sequence type name is almost built... S_Name := Name_Find; -- ... However we must resolve the conflicts that may occur -- with other sequence type names. Info := Get_Name_Table_Info (S_Name); if Info = Int (Stubs_Package (Current_Entity)) then Index := New_Index (S_Name, Stubs_Package (Current_Entity)); Get_Name_String (S_Name); Add_Char_To_Name_Buffer ('_'); Add_Nat_To_Name_Buffer (Index); S_Name := Name_Find; end if; Set_Name_Table_Info (S_Name, Int (Stubs_Package (Current_Entity))); -- Finally, we link S and S_Name Link_Mapped_Entity_Name (S_Name, S); return S_Name; end Map_Sequence_Pkg_Name; ---------------------------------- -- Map_Sequence_Pkg_Helper_Name -- ---------------------------------- function Map_Sequence_Pkg_Helper_Name (S : Node_Id) return Name_Id is pragma Assert (FEN.Kind (S) = K_Sequence_Type); begin Get_Name_String (Map_Sequence_Pkg_Name (S)); Add_Str_To_Name_Buffer ("_Helper"); return Name_Find; end Map_Sequence_Pkg_Helper_Name; ------------------------- -- Map_String_Pkg_Name -- ------------------------- function Map_String_Pkg_Name (S : Node_Id) return Name_Id is S_Name : Name_Id; Info : Nat; Index : Nat; begin pragma Assert (FEN.Kind (S) = K_String_Type or else FEN.Kind (S) = K_Wide_String_Type); -- First of all, see whether we have already mapped the string -- type S S_Name := Get_Mapped_Entity_Name (S); if S_Name /= No_Name then return S_Name; end if; -- It's the first time we try to map the string type S Set_Str_To_Name_Buffer ("Bounded_"); -- Wide string types require additional suffix if FEN.Kind (S) = K_Wide_String_Type then Add_Str_To_Name_Buffer ("Wide_"); end if; Add_Str_To_Name_Buffer ("String_"); Add_Dnat_To_Name_Buffer (Dnat (FEU.Expr_Value (Max_Size (S)).IVal)); -- Now the string type name is almost built... S_Name := Name_Find; -- ... However we must resolve the conflicts that may occur -- with other sequence type names Info := Get_Name_Table_Info (S_Name); if Info = Int (Stubs_Package (Current_Entity)) then Index := New_Index (S_Name, Stubs_Package (Current_Entity)); Get_Name_String (S_Name); Add_Char_To_Name_Buffer ('_'); Add_Nat_To_Name_Buffer (Index); S_Name := Name_Find; end if; Set_Name_Table_Info (S_Name, Int (Stubs_Package (Current_Entity))); -- Finally, we link S and S_Name Link_Mapped_Entity_Name (S_Name, S); return S_Name; end Map_String_Pkg_Name; ---------------------- -- Map_Variant_List -- ---------------------- function Map_Variant_List (Alternatives : List_Id; Literal_Parent : Node_Id) return List_Id is Alternative : Node_Id; Variants : List_Id; Variant : Node_Id; Choices : List_Id; Choice : Node_Id; Label : Node_Id; Element : Node_Id; Identifier : Node_Id; begin Variants := New_List; Alternative := First_Entity (Alternatives); while Present (Alternative) loop Variant := New_Node (K_Variant); Choices := New_List; Set_Discrete_Choices (Variant, Choices); Label := First_Entity (Labels (Alternative)); Element := FEN.Element (Alternative); while Present (Label) loop Choice := Make_Literal_With_Parent (Value => FEU.Expr_Value (Label), Parent => Literal_Parent); Append_To (Choices, Choice); Label := Next_Entity (Label); end loop; Identifier := FEN.Identifier (FEN.Declarator (Element)); Set_Component (Variant, Make_Component_Declaration (Map_Defining_Identifier (Identifier), Map_Declarator_Type_Designator (Type_Spec (Element), FEN.Declarator (Element)))); Append_To (Variants, Variant); Alternative := Next_Entity (Alternative); end loop; return Variants; end Map_Variant_List; --------------------- -- Map_Choice_List -- --------------------- procedure Map_Choice_List (Labels : List_Id; Literal_Parent : Node_Id; Choices : out List_Id; Has_Default : in out Boolean) is Label : Node_Id; Choice : Node_Id; begin Choices := New_List; -- Expansion guarantees that the "default:" case is isolated in -- a standalone alternative. Label := First_Entity (Labels); if FEU.Expr_Value (Label) = No_Value then Has_Default := True; else while Present (Label) loop Choice := Make_Literal_With_Parent (Value => FEU.Expr_Value (Label), Parent => Literal_Parent); Append_To (Choices, Choice); Label := Next_Entity (Label); end loop; end if; end Map_Choice_List; --------------------------------- -- Map_Wrap_Element_Identifier -- --------------------------------- function Map_Wrap_Element_Identifier (E : Node_Id) return Node_Id is pragma Assert (FEN.Kind (E) = K_Sequence_Type); begin Get_Name_String (BEN.Name (Defining_Identifier (Instantiation_Node (BE_Node (E))))); Add_Str_To_Name_Buffer ("_Element_Wrap"); return Make_Defining_Identifier (Name_Find); end Map_Wrap_Element_Identifier; -- Bodies of the CORBA module handling routines --------------------------------- -- Get_Predefined_CORBA_Entity -- --------------------------------- function Get_Predefined_CORBA_Entity (E : Node_Id; Implem : Boolean := False; Wrap : Boolean := False) return RE_Id is Entity : Node_Id; E_Name : Name_Id; Info : Nat; begin if FEN.Kind (E) = K_Scoped_Name then Entity := Reference (E); else Entity := E; end if; Get_Name_String (To_Lower (FEU.Fully_Qualified_Name (FEN.Identifier (Entity), "."))); Add_Str_To_Name_Buffer (CORBA_Predefined_RU_Suffix); E_Name := Name_Find; Info := Get_Name_Table_Info (E_Name); if Info /= 0 then -- We have a match with a CORBA predefined unit if Implem then return CORBA_Predefined_RU_Implem_Table (CORBA_Predefined_RU'Val (Info)); else return CORBA_Predefined_RU_Table (CORBA_Predefined_RU'Val (Info)); end if; end if; Get_Name_String (To_Lower (FEU.Fully_Qualified_Name (FEN.Identifier (Entity), "."))); Add_Str_To_Name_Buffer (CORBA_Predefined_RE_Suffix); E_Name := Name_Find; Info := Get_Name_Table_Info (E_Name); if Info /= 0 then -- We have a match with a CORBA predefined entity -- In the case of IDL sequences, if the Wrap flag has been -- set, we return the corresponding .Sequence type for which -- a Wrap function has been generated. if Wrap then return CORBA_Predefined_RE_Wrap_Table (CORBA_Predefined_RE'Val (Info)); else return CORBA_Predefined_RE_Table (CORBA_Predefined_RE'Val (Info)); end if; end if; return RE_Null; end Get_Predefined_CORBA_Entity; --------------------------------- -- Map_Predefined_CORBA_Entity -- --------------------------------- function Map_Predefined_CORBA_Entity (E : Node_Id; Implem : Boolean := False; Wrap : Boolean := False; Withed : Boolean := True) return Node_Id is R : RE_Id; begin R := Get_Predefined_CORBA_Entity (E, Implem, Wrap); if R /= RE_Null then return RE (R, Withed); else return No_Node; end if; end Map_Predefined_CORBA_Entity; ------------------------------- -- Map_Predefined_CORBA_Type -- ------------------------------- function Map_Predefined_CORBA_Type (E : Node_Id; Wrap : Boolean := False; Withed : Boolean := True) return Node_Id is R : RE_Id; begin R := Get_Predefined_CORBA_Entity (E => E, Wrap => Wrap); case R is when RE_Null => return No_Node; when RE_Get_Domain_Policy => return RE (RE_Get_Domain_Policy_Args_Type, Withed); when RE_Get_Policy_Type => return RE (RE_Get_Policy_Type_Args_Type, Withed); when RE_Copy => return RE (RE_Copy_Args_Type, Withed); when others => return RE (R, Withed); end case; end Map_Predefined_CORBA_Type; ------------------------------------- -- Map_Predefined_CORBA_Initialize -- ------------------------------------- function Map_Predefined_CORBA_Initialize (E : Node_Id) return Node_Id is R : RE_Id; N : Node_Id; begin R := Get_Predefined_CORBA_Entity (E); N := New_Node (K_Node_Id); case R is when RE_Any | RE_Float | RE_Double | RE_Long_Double | RE_Short | RE_Long | RE_Long_Long | RE_Unsigned_Short | RE_Unsigned_Long | RE_Unsigned_Long_Long | RE_Char | RE_WChar | RE_String_0 | RE_Wide_String | RE_Boolean | RE_Octet | RE_Object | RE_Identifier_0 | RE_RepositoryId | RE_ScopedName | RE_Visibility | RE_PolicyType | RE_Ref_2 => -- Return a dummy node and not "No_Node" because No_Nodes -- means that this is not a predefined CORBA type. return N; when RE_AnySeq_2 | RE_FloatSeq_2 | RE_DoubleSeq_2 | RE_LongDoubleSeq_2 | RE_ShortSeq_2 | RE_LongSeq_2 | RE_LongLongSeq_2 | RE_UShortSeq_2 | RE_ULongSeq_2 | RE_ULongLongSeq_2 | RE_CharSeq_2 | RE_WCharSeq_2 | RE_StringSeq_2 | RE_WStringSeq_2 | RE_BooleanSeq_2 | RE_OctetSeq_2 => -- FIXME : For predefined CORBA Sequence type, once the -- CORBA.IDL_Sequence.Helper.Init package is added to the -- PolyORB source, return the corresponding -- Seq_Initialize procedure. For now we return a -- dummy node N. return N; when others => return No_Node; end case; end Map_Predefined_CORBA_Initialize; -------------------------------------- -- Map_Predefined_CORBA_IR_Function -- -------------------------------------- function Map_Predefined_CORBA_IR_Function (E : Node_Id) return Node_Id is R : RE_Id; begin R := Get_Predefined_CORBA_Entity (E); case R is when RE_Any | RE_Float | RE_Double | RE_Long_Double | RE_Short | RE_Long | RE_Long_Long | RE_Unsigned_Short | RE_Unsigned_Long | RE_Unsigned_Long_Long | RE_Char | RE_WChar | RE_String_0 | RE_Wide_String | RE_Boolean | RE_Octet | RE_Object | RE_Identifier_0 | RE_RepositoryId | RE_ScopedName | RE_Visibility | RE_PolicyType | RE_Ref_2 | RE_AnySeq_2 | RE_FloatSeq_2 | RE_DoubleSeq_2 | RE_LongDoubleSeq_2 | RE_ShortSeq_2 | RE_LongSeq_2 | RE_LongLongSeq_2 | RE_UShortSeq_2 | RE_ULongSeq_2 | RE_ULongLongSeq_2 | RE_CharSeq_2 | RE_WCharSeq_2 | RE_StringSeq_2 | RE_WStringSeq_2 | RE_BooleanSeq_2 | RE_OctetSeq_2 => raise Program_Error with "IR info for predefined CORBA entites not implemented yet"; when others => return No_Node; end case; end Map_Predefined_CORBA_IR_Function; ----------------------------- -- Map_Predefined_CORBA_TC -- ----------------------------- function Map_Predefined_CORBA_TC (E : Node_Id; Withed : Boolean := True) return Node_Id is R : RE_Id; begin R := Get_Predefined_CORBA_Entity (E); case R is when RE_Any => return RE (RE_TC_Any, Withed); when RE_Identifier_0 => return RE (RE_TC_Identifier, Withed); when RE_RepositoryId => return RE (RE_TC_RepositoryId, Withed); when RE_ScopedName => return RE (RE_TC_ScopedName, Withed); when RE_PolicyType => return RE (RE_TC_PolicyType, Withed); when RE_Visibility => return RE (RE_TC_Visibility, Withed); when RE_Float => return RE (RE_TC_Float, Withed); when RE_Double => return RE (RE_TC_Double, Withed); when RE_Long_Double => return RE (RE_TC_Long_Double, Withed); when RE_Short => return RE (RE_TC_Short, Withed); when RE_Long => return RE (RE_TC_Long, Withed); when RE_Long_Long => return RE (RE_TC_Long_Long, Withed); when RE_Unsigned_Short => return RE (RE_TC_Unsigned_Short, Withed); when RE_Unsigned_Long => return RE (RE_TC_Unsigned_Long, Withed); when RE_Unsigned_Long_Long => return RE (RE_TC_Unsigned_Long_Long, Withed); when RE_Char => return RE (RE_TC_Char, Withed); when RE_WChar => return RE (RE_TC_WChar, Withed); when RE_String_0 => return RE (RE_TC_String, Withed); when RE_Wide_String => return RE (RE_TC_Wide_String, Withed); when RE_Boolean => return RE (RE_TC_Boolean, Withed); when RE_Octet => return RE (RE_TC_Octet, Withed); when RE_Ref_2 => return RE (RE_TC_Object_0, Withed); when RE_Object => return RE (RE_TC_TypeCode, Withed); when RE_Ref_11 => return RE (RE_TC_DomainManager, Withed); when RE_Ref_6 => return RE (RE_TC_Policy, Withed); when RE_AnySeq_2 => return RE (RE_TC_AnySeq, Withed); when RE_FloatSeq_2 => return RE (RE_TC_FloatSeq, Withed); when RE_DoubleSeq_2 => return RE (RE_TC_DoubleSeq, Withed); when RE_LongDoubleSeq_2 => return RE (RE_TC_LongDoubleSeq, Withed); when RE_ShortSeq_2 => return RE (RE_TC_ShortSeq, Withed); when RE_LongSeq_2 => return RE (RE_TC_LongSeq, Withed); when RE_LongLongSeq_2 => return RE (RE_TC_LongLongSeq, Withed); when RE_UShortSeq_2 => return RE (RE_TC_UShortSeq, Withed); when RE_ULongSeq_2 => return RE (RE_TC_ULongSeq, Withed); when RE_ULongLongSeq_2 => return RE (RE_TC_ULongLongSeq, Withed); when RE_CharSeq_2 => return RE (RE_TC_CharSeq, Withed); when RE_WCharSeq_2 => return RE (RE_TC_WCharSeq, Withed); when RE_StringSeq_2 => return RE (RE_TC_StringSeq, Withed); when RE_WStringSeq_2 => return RE (RE_TC_WStringSeq, Withed); when RE_BooleanSeq_2 => return RE (RE_TC_BooleanSeq, Withed); when RE_OctetSeq_2 => return RE (RE_TC_OctetSeq, Withed); when others => return No_Node; end case; end Map_Predefined_CORBA_TC; ----------------------------------- -- Map_Predefined_CORBA_From_Any -- ----------------------------------- function Map_Predefined_CORBA_From_Any (E : Node_Id; Withed : Boolean := True) return Node_Id is R : RE_Id; begin R := Get_Predefined_CORBA_Entity (E); case R is when RE_Any | RE_Float | RE_Double | RE_Long_Double | RE_Short | RE_Long | RE_Long_Long | RE_Unsigned_Short | RE_Unsigned_Long | RE_Unsigned_Long_Long | RE_Char | RE_WChar | RE_String_0 | RE_Wide_String | RE_Boolean | RE_Octet | RE_Object => return RE (RE_From_Any_0, Withed); when RE_Identifier_0 | RE_RepositoryId | RE_ScopedName | RE_Visibility | RE_PolicyType => return RE (RE_From_Any_2, Withed); when RE_Ref_2 => return RE (RE_From_Any_1, Withed); when RE_Ref_6 => return RE (RE_From_Any_6, Withed); when RE_Ref_11 => return RE (RE_From_Any_5, Withed); when RE_AnySeq_2 | RE_FloatSeq_2 | RE_DoubleSeq_2 | RE_LongDoubleSeq_2 | RE_ShortSeq_2 | RE_LongSeq_2 | RE_LongLongSeq_2 | RE_UShortSeq_2 | RE_ULongSeq_2 | RE_ULongLongSeq_2 | RE_CharSeq_2 | RE_WCharSeq_2 | RE_StringSeq_2 | RE_WStringSeq_2 | RE_BooleanSeq_2 | RE_OctetSeq_2 => return RE (RE_From_Any_4, Withed); when others => return No_Node; end case; end Map_Predefined_CORBA_From_Any; --------------------------------- -- Map_Predefined_CORBA_To_Any -- --------------------------------- function Map_Predefined_CORBA_To_Any (E : Node_Id; Withed : Boolean := True) return Node_Id is R : RE_Id; begin R := Get_Predefined_CORBA_Entity (E); case R is when RE_Any | RE_Float | RE_Double | RE_Long_Double | RE_Short | RE_Long | RE_Long_Long | RE_Unsigned_Short | RE_Unsigned_Long | RE_Unsigned_Long_Long | RE_Char | RE_WChar | RE_String_0 | RE_Wide_String | RE_Boolean | RE_Octet | RE_Object => return RE (RE_To_Any_0, Withed); when RE_Identifier_0 | RE_RepositoryId | RE_ScopedName | RE_Visibility | RE_PolicyType => return RE (RE_To_Any_2, Withed); when RE_Ref_2 => return RE (RE_To_Any_1, Withed); when RE_Ref_6 => return RE (RE_To_Any_6, Withed); when RE_Ref_11 => return RE (RE_To_Any_5, Withed); when RE_AnySeq_2 | RE_FloatSeq_2 | RE_DoubleSeq_2 | RE_LongDoubleSeq_2 | RE_ShortSeq_2 | RE_LongSeq_2 | RE_LongLongSeq_2 | RE_UShortSeq_2 | RE_ULongSeq_2 | RE_ULongLongSeq_2 | RE_CharSeq_2 | RE_WCharSeq_2 | RE_StringSeq_2 | RE_WStringSeq_2 | RE_BooleanSeq_2 | RE_OctetSeq_2 => return RE (RE_To_Any_4, Withed); when others => return No_Node; end case; end Map_Predefined_CORBA_To_Any; --------------------------------- -- Map_Predefined_CORBA_To_Ref -- --------------------------------- function Map_Predefined_CORBA_To_Ref (E : Node_Id; Withed : Boolean := True) return Node_Id is R : RE_Id; begin R := Get_Predefined_CORBA_Entity (E); case R is when RE_Ref_6 => return RE (RE_To_Ref_6, Withed); when RE_Ref_11 => return RE (RE_To_Ref_5, Withed); when others => return No_Node; end case; end Map_Predefined_CORBA_To_Ref; ------------------------------------- -- Map_Predefined_CORBA_Marshaller -- ------------------------------------- function Map_Predefined_CORBA_Marshaller (E : Node_Id; Withed : Boolean := True) return Node_Id is R : RE_Id; begin pragma Assert (FEN.Kind (E) = FEN.K_Operation_Declaration); R := Get_Predefined_CORBA_Entity (E); case R is when RE_Get_Domain_Policy => return RE (RE_Get_Domain_Policy_Marshaller, Withed); when RE_Get_Policy_Type => return RE (RE_Get_Policy_Type_Marshaller, Withed); when RE_Copy => return RE (RE_Copy_Marshaller, Withed); when others => return No_Node; end case; end Map_Predefined_CORBA_Marshaller; --------------------------------------- -- Map_Predefined_CORBA_Unmarshaller -- --------------------------------------- function Map_Predefined_CORBA_Unmarshaller (E : Node_Id; Withed : Boolean := True) return Node_Id is R : RE_Id; begin pragma Assert (FEN.Kind (E) = FEN.K_Operation_Declaration); R := Get_Predefined_CORBA_Entity (E); case R is when RE_Get_Domain_Policy => return RE (RE_Get_Domain_Policy_Unmarshaller, Withed); when RE_Get_Policy_Type => return RE (RE_Get_Policy_Type_Unmarshaller, Withed); when RE_Copy => return RE (RE_Copy_Unmarshaller, Withed); when others => return No_Node; end case; end Map_Predefined_CORBA_Unmarshaller; ------------------------------- -- Map_Predefined_CORBA_Wrap -- ------------------------------- function Map_Predefined_CORBA_Wrap (E : Node_Id; Withed : Boolean := True) return Node_Id is R : RE_Id; begin R := Get_Predefined_CORBA_Entity (E); case R is when RE_Any | RE_Float | RE_Double | RE_Long_Double | RE_Short | RE_Long | RE_Long_Long | RE_Unsigned_Short | RE_Unsigned_Long | RE_Unsigned_Long_Long | RE_Char | RE_WChar | RE_String_0 | RE_Wide_String | RE_Boolean | RE_Octet | RE_Object => return RE (RE_Wrap_2, Withed); when RE_Identifier_0 | RE_RepositoryId | RE_ScopedName | RE_Visibility | RE_PolicyType => -- These types are redefinitions of CORBA.String, -- CORBA.Short and CORBA.Unsigned_Long. In all cases, we -- use CORBA.Wrap. return RE (RE_Wrap_2, Withed); when RE_Ref_2 => return RE (RE_Wrap_3, Withed); when RE_AnySeq_2 | RE_FloatSeq_2 | RE_DoubleSeq_2 | RE_LongDoubleSeq_2 | RE_ShortSeq_2 | RE_LongSeq_2 | RE_LongLongSeq_2 | RE_UShortSeq_2 | RE_ULongSeq_2 | RE_ULongLongSeq_2 | RE_CharSeq_2 | RE_WCharSeq_2 | RE_StringSeq_2 | RE_WStringSeq_2 | RE_BooleanSeq_2 | RE_OctetSeq_2 => return RE (RE_Wrap_4, Withed); when others => return No_Node; end case; end Map_Predefined_CORBA_Wrap; ---------------------------------------------- -- Inheritance related internal subprograms -- ---------------------------------------------- Mark : Int := 1; function Get_New_Int_Value return Int; -- Get a new Int value function View_Old_Int_Value return Int; -- View the current int value without modifying it function Already_Inherited (Name : Name_Id) return Boolean; -- If two entities inherited from two parents have the same name, -- the second should not be added procedure Explaining_Comment (First_Name : Name_Id; Second_Name : Name_Id; Message : String); -- Generate a comment that indicates from which interface the -- entity we deal with is inherited. function Is_Implicit_Parent (Parent : Node_Id; Child : Node_Id) return Boolean; -- Return True if parent is the first parent of Child or if it is -- one of the parents of the first parent of Child procedure Map_Any_Converters (Type_Name : Name_Id; From_Any : out Node_Id; To_Any : out Node_Id); -- Return the From_Any and the To_Any nodes corresponding to type -- 'Type_Name' ----------------------- -- Get_New_Int_Value -- ----------------------- function Get_New_Int_Value return Int is begin Mark := Mark + 1; return Mark; end Get_New_Int_Value; ------------------------ -- View_Old_Int_Value -- ------------------------ function View_Old_Int_Value return Int is begin return Mark; end View_Old_Int_Value; ------------------------ -- Explaining_Comment -- ------------------------ procedure Explaining_Comment (First_Name : Name_Id; Second_Name : Name_Id; Message : String) is Comment : Node_Id; begin Get_Name_String (First_Name); Add_Str_To_Name_Buffer (Message); Get_Name_String_And_Append (Second_Name); Comment := Make_Ada_Comment (Name_Find); Append_To (Visible_Part (Current_Package), Comment); end Explaining_Comment; ------------------------ -- Is_Implicit_Parent -- ------------------------ function Is_Implicit_Parent (Parent : Node_Id; Child : Node_Id) return Boolean is pragma Assert (Kind (Parent) = K_Interface_Declaration and then Kind (Child) = K_Interface_Declaration); begin if not FEU.Is_Empty (Interface_Spec (Child)) then return FEU.Is_Parent (Parent, Child, True) or else FEU.Is_Parent (Parent, Reference (First_Entity (Interface_Spec (Child)))); end if; return False; end Is_Implicit_Parent; ------------------------ -- Map_Any_Converters -- ------------------------ procedure Map_Any_Converters (Type_Name : Name_Id; From_Any : out Node_Id; To_Any : out Node_Id) is New_Type : Node_Id; Profile : List_Id; Parameter : Node_Id; begin New_Type := Make_Selected_Component (Expand_Designator (Stubs_Package (Current_Entity)), Make_Identifier (Type_Name)); -- From_Any Profile := New_List; Parameter := Make_Parameter_Specification (Make_Defining_Identifier (PN (P_Item)), RE (RE_Any)); Append_To (Profile, Parameter); From_Any := Make_Subprogram_Specification (Make_Defining_Identifier (SN (S_From_Any)), Profile, New_Type); -- To_Any Profile := New_List; Parameter := Make_Parameter_Specification (Make_Defining_Identifier (PN (P_Item)), New_Type); Append_To (Profile, Parameter); To_Any := Make_Subprogram_Specification (Make_Defining_Identifier (SN (S_To_Any)), Profile, RE (RE_Any)); end Map_Any_Converters; ---------------------------------- -- Map_Inherited_Entities_Specs -- ---------------------------------- procedure Map_Inherited_Entities_Specs (Current_Interface : Node_Id; First_Recusrion_Level : Boolean := True; Visit_Operation_Subp : Visit_Procedure_Two_Params_Ptr; Stub : Boolean := False; Helper : Boolean := False; Skel : Boolean := False; Impl : Boolean := False) is Par_Int : Node_Id; Par_Name : Name_Id; Do_Visit : Boolean := True; N : Node_Id; Actual_Current_Interface : Node_Id; Mark : Int; L : constant List_Id := Interface_Spec (Current_Interface); begin if FEU.Is_Empty (L) then return; end if; -- We get the node of the current interface (i.e. the interface -- who first called this subprogram). Actual_Current_Interface := FEN.Corresponding_Entity (FE_Node (Current_Entity)); if First_Recusrion_Level then -- It is important to get the new value before any inherited -- entity manipulation. Mark := Get_New_Int_Value; if Stub or else Helper then -- The mapping of type definitions, constant declarations and -- exception declarations is defined in the parents. -- During the different recursion level, we must have -- access to the current interface we are visiting. So we -- don't use the parameter Current_Interface because its -- value changes depending on the recursion level. Map_Additional_Entities_Specs (Reference (First_Entity (L)), Actual_Current_Interface, Stub => Stub, Helper => Helper); end if; Par_Int := Next_Entity (First_Entity (L)); else Mark := View_Old_Int_Value; Par_Int := First_Entity (L); end if; while Present (Par_Int) loop -- We ensure that the interface is not visited twice and is not -- an implicit parent Par_Name := FEU.Fully_Qualified_Name (Identifier (Reference (Par_Int))); if Is_Implicit_Parent (Reference (Par_Int), Actual_Current_Interface) or else Get_Name_Table_Info (Par_Name) = Mark then Do_Visit := False; end if; Set_Name_Table_Info (Par_Name, Mark); if not Do_Visit then Do_Visit := True; else if Stub or else Helper then -- Mapping of type definitions, constant declarations -- and exception declarations defined in the parents -- During the different recursion level, we must have -- access to the current interface we are visiting. So -- we don't use the parameter Current_Interface -- because its value changes depending on the -- recursion level. Map_Additional_Entities_Specs (Reference (Par_Int), Actual_Current_Interface, Stub => Stub, Helper => Helper); end if; if Stub or else Skel or else Impl then N := First_Entity (Interface_Body (Reference (Par_Int))); while Present (N) loop case FEN.Kind (N) is when K_Operation_Declaration => if not Skel then -- Adding an explaining comment Explaining_Comment (FEN.IDL_Name (Identifier (N)), FEU.Fully_Qualified_Name (Identifier (Reference (Par_Int)), Separator => "."), " : inherited from "); end if; Visit_Operation_Subp (N, False); when others => null; end case; N := Next_Entity (N); end loop; end if; -- Get indirectly inherited entities Map_Inherited_Entities_Specs (Current_Interface => Reference (Par_Int), First_Recusrion_Level => False, Visit_Operation_Subp => Visit_Operation_Subp, Stub => Stub, Helper => Helper, Skel => Skel, Impl => Impl); end if; Par_Int := Next_Entity (Par_Int); end loop; end Map_Inherited_Entities_Specs; ----------------------------------- -- Map_Inherited_Entities_Bodies -- ----------------------------------- procedure Map_Inherited_Entities_Bodies (Current_Interface : Node_Id; First_Recusrion_Level : Boolean := True; Visit_Operation_Subp : Visit_Procedure_One_Param_Ptr; Stub : Boolean := False; Helper : Boolean := False; Skel : Boolean := False; Impl : Boolean := False) is Par_Int : Node_Id; Par_Name : Name_Id; Do_Visit : Boolean := True; N : Node_Id; Actual_Current_Interface : Node_Id; Mark : Int; L : constant List_Id := Interface_Spec (Current_Interface); begin if FEU.Is_Empty (L) then return; end if; -- We get the node of the current interface (the interface who -- first called this subprogram. Actual_Current_Interface := FEN.Corresponding_Entity (FE_Node (Current_Entity)); -- In case of first recursion level, we compute a new value to -- tag visited parents (in order to visit them only once), we -- also map the additional entities. if First_Recusrion_Level then -- It is important to get the new value before any inherited -- entity manipulation Mark := Get_New_Int_Value; if Stub or else Helper then -- Mapping of type definitions, constant declarations and -- exception declarations defined in the parents -- During the different recursion level, we must have -- access to the current interface we are visiting. So we -- don't use the parameter Current_Interface because its -- value changes depending on the recursion level. Map_Additional_Entities_Bodies (Reference (First_Entity (L)), Actual_Current_Interface, Stub => Stub, Helper => Helper); end if; else Mark := View_Old_Int_Value; end if; -- In case of first recursion level and not a skel visiting, we -- begin by the second parent, in other cases, we begin by the -- first. if First_Recusrion_Level and then not Skel then Par_Int := Next_Entity (First_Entity (L)); else Par_Int := First_Entity (L); end if; while Present (Par_Int) loop -- We ensure that the interface is not visited twice and is -- not an implicit parent Par_Name := FEU.Fully_Qualified_Name (Identifier (Reference (Par_Int))); if Get_Name_Table_Info (Par_Name) = Mark then Do_Visit := False; else Set_Name_Table_Info (Par_Name, Mark); end if; -- For Stubs, Helpers or Impls, primitives for the first -- parent are inherited by entities: we only add nodes from -- the others parents. Skel should handle all parents. if Is_Implicit_Parent (Reference (Par_Int), Actual_Current_Interface) and then not Skel then Do_Visit := False; end if; if not Do_Visit then Do_Visit := True; else if Stub or else Helper then -- Mapping of type definitions, constant declarations -- and exception declarations defined in the parents. -- During the different recursion level, we must have -- access to the current interface we are visiting. So -- we don't use the parameter Current_Interface -- because its value changes depending on the -- recursion level. Map_Additional_Entities_Bodies (Reference (Par_Int), Actual_Current_Interface, Stub => Stub, Helper => Helper); end if; if Stub or else Skel or else Impl then N := First_Entity (Interface_Body (Reference (Par_Int))); while Present (N) loop case FEN.Kind (N) is when K_Operation_Declaration => Visit_Operation_Subp (N); when others => null; end case; N := Next_Entity (N); end loop; end if; -- Get indirectly inherited entities Map_Inherited_Entities_Bodies (Current_Interface => Reference (Par_Int), First_Recusrion_Level => False, Visit_Operation_Subp => Visit_Operation_Subp, Stub => Stub, Helper => Helper, Skel => Skel, Impl => Impl); end if; Par_Int := Next_Entity (Par_Int); end loop; end Map_Inherited_Entities_Bodies; ----------------------- -- Already_Inherited -- ----------------------- function Already_Inherited (Name : Name_Id) return Boolean is Result : Boolean; begin if Get_Name_Table_Info (Name) = View_Old_Int_Value then Result := True; else Result := False; Set_Name_Table_Info (Name, View_Old_Int_Value); end if; return Result; end Already_Inherited; ----------------------------------- -- Map_Additional_Entities_Specs -- ----------------------------------- procedure Map_Additional_Entities_Specs (Parent_Interface : Node_Id; Child_Interface : Node_Id; Stub : Boolean := False; Helper : Boolean := False) is Entity : Node_Id; From_Any : Node_Id; To_Any : Node_Id; begin -- We do not handle predefined CORBA parents. Here we use -- Get_Predefined_CORBA_Entity to avoid "withing" a useless -- package. if Get_Predefined_CORBA_Entity (Parent_Interface) /= RE_Null then return; end if; Entity := First_Entity (Interface_Body (Parent_Interface)); while Present (Entity) loop case FEN.Kind (Entity) is when K_Type_Declaration => declare D : Node_Id; Original_Type : Node_Id; New_Type : Node_Id; T : Node_Id; begin D := First_Entity (Declarators (Entity)); while Present (D) loop if not FEU.Is_Redefined (D, Child_Interface) and then not Already_Inherited (IDL_Name (Identifier (D))) then -- Add explanatory comment Explaining_Comment (FEN.IDL_Name (Identifier (D)), FEU.Fully_Qualified_Name (Identifier (Parent_Interface), Separator => "."), ": inherited from "); if Stub then -- Subtype declaration Original_Type := Expand_Designator (Type_Def_Node (BE_Node (Identifier (D)))); New_Type := Make_Defining_Identifier (To_Ada_Name (IDL_Name (Identifier (D)))); T := Make_Full_Type_Declaration (Defining_Identifier => New_Type, Type_Definition => Make_Derived_Type_Definition (Subtype_Indication => Original_Type, Record_Extension_Part => No_Node, Is_Subtype => True), Is_Subtype => True); Set_Declaration_Node (New_Type, T); Append_To (Visible_Part (Current_Package), T); end if; if Helper then Map_Any_Converters (To_Ada_Name (IDL_Name (Identifier (D))), From_Any, To_Any); Append_To (Visible_Part (Current_Package), From_Any); Append_To (Visible_Part (Current_Package), To_Any); end if; end if; D := Next_Entity (D); end loop; end; when K_Structure_Type | K_Union_Type | K_Enumeration_Type => if not FEU.Is_Redefined (Entity, Child_Interface) and then not Already_Inherited (IDL_Name (Identifier (Entity))) then declare Original_Type : Node_Id; New_Type : Node_Id; T : Node_Id; begin -- Adding an explaining comment Explaining_Comment (FEN.IDL_Name (Identifier (Entity)), FEU.Fully_Qualified_Name (Identifier (Parent_Interface), Separator => "."), " : inherited from "); if Stub then -- Subtype declaration Original_Type := Expand_Designator (Type_Def_Node (BE_Node (Identifier (Entity)))); New_Type := Make_Defining_Identifier (To_Ada_Name (IDL_Name (Identifier (Entity)))); T := Make_Full_Type_Declaration (Defining_Identifier => New_Type, Type_Definition => Make_Derived_Type_Definition (Subtype_Indication => Original_Type, Record_Extension_Part => No_Node, Is_Subtype => True), Is_Subtype => True); Set_Declaration_Node (New_Type, T); Append_To (Visible_Part (Current_Package), T); end if; if Helper then Map_Any_Converters (To_Ada_Name (IDL_Name (Identifier (Entity))), From_Any, To_Any); Append_To (Visible_Part (Current_Package), From_Any); Append_To (Visible_Part (Current_Package), To_Any); end if; end; end if; when K_Constant_Declaration => if not FEU.Is_Redefined (Entity, Child_Interface) and then not Already_Inherited (IDL_Name (Identifier (Entity))) then declare Original_Constant : Node_Id; New_Constant : Node_Id; C : Node_Id; begin if Stub then -- Adding an explaining comment Explaining_Comment (FEN.IDL_Name (Identifier (Entity)), FEU.Fully_Qualified_Name (Identifier (Parent_Interface), Separator => "."), " : inherited from "); -- Generate a "renamed" variable. Original_Constant := Expand_Designator (Stub_Node (BE_Node (Identifier (Entity)))); New_Constant := Make_Defining_Identifier (To_Ada_Name (FEN.IDL_Name (Identifier (Entity)))); C := Make_Object_Declaration (Defining_Identifier => New_Constant, Constant_Present => False, -- Yes, False Object_Definition => Map_Expanded_Name (Type_Spec (Entity)), Renamed_Object => Original_Constant); Append_To (Visible_Part (Current_Package), C); end if; end; end if; when K_Exception_Declaration => if not FEU.Is_Redefined (Entity, Child_Interface) and then not Already_Inherited (IDL_Name (Identifier (Entity))) then declare Original_Exception : Node_Id; New_Exception : Node_Id; C : Node_Id; Original_Type : Node_Id; New_Type : Node_Id; T : Node_Id; N : Node_Id; begin -- Adding an explaining comment Explaining_Comment (FEN.IDL_Name (Identifier (Entity)), FEU.Fully_Qualified_Name (Identifier (Parent_Interface), Separator => "."), " : inherited from "); if Stub then -- Generate a "renamed" exception Original_Exception := Expand_Designator (Stub_Node (BE_Node (Identifier (Entity)))); New_Exception := Make_Defining_Identifier (To_Ada_Name (FEN.IDL_Name (Identifier (Entity)))); C := Make_Exception_Declaration (Defining_Identifier => New_Exception, Renamed_Exception => Original_Exception); Append_To (Visible_Part (Current_Package), C); -- Generate the "_Members" subtype Original_Type := Expand_Designator (Type_Def_Node (BE_Node (Identifier (Entity)))); New_Type := Make_Defining_Identifier (Get_Name (Get_Base_Identifier (Original_Type))); T := Make_Full_Type_Declaration (Defining_Identifier => New_Type, Type_Definition => Make_Derived_Type_Definition (Subtype_Indication => Original_Type, Record_Extension_Part => No_Node, Is_Subtype => True), Is_Subtype => True); Set_Declaration_Node (New_Type, T); Append_To (Visible_Part (Current_Package), T); -- Generate the Get_Members procedure spec N := Map_Get_Members_Spec (Expand_Designator (T)); Append_To (Visible_Part (Current_Package), N); end if; if Helper then Map_Any_Converters (BEN.Name (Defining_Identifier (Type_Def_Node (BE_Node (Identifier (Entity))))), From_Any, To_Any); Append_To (Visible_Part (Current_Package), From_Any); Append_To (Visible_Part (Current_Package), To_Any); end if; end; end if; when others => null; end case; Entity := Next_Entity (Entity); end loop; end Map_Additional_Entities_Specs; ------------------------------------ -- Map_Additional_Entities_Bodies -- ------------------------------------ procedure Map_Additional_Entities_Bodies (Parent_Interface : Node_Id; Child_Interface : Node_Id; Stub : Boolean := False; Helper : Boolean := False) is Entity : Node_Id; From_Any : Node_Id; To_Any : Node_Id; begin -- We do not handle predefined CORBA parents. Here we use -- Get_Predefined_CORBA_Entity to avoid "withing" a useless -- package. if Get_Predefined_CORBA_Entity (Parent_Interface) /= RE_Null then return; end if; Entity := First_Entity (Interface_Body (Parent_Interface)); while Present (Entity) loop case FEN.Kind (Entity) is when K_Type_Declaration => declare D : Node_Id; begin if Helper then D := First_Entity (Declarators (Entity)); while Present (D) loop if not FEU.Is_Redefined (D, Child_Interface) and then not Already_Inherited (IDL_Name (Identifier (D))) then Map_Any_Converters (To_Ada_Name (IDL_Name (Identifier (D))), From_Any, To_Any); Set_Renamed_Entity (From_Any, Expand_Designator (From_Any_Node (BE_Node (Identifier (D))))); Set_Renamed_Entity (To_Any, Expand_Designator (To_Any_Node (BE_Node (Identifier (D))))); Append_To (Statements (Current_Package), From_Any); Append_To (Statements (Current_Package), To_Any); end if; D := Next_Entity (D); end loop; end if; end; when K_Structure_Type | K_Union_Type | K_Enumeration_Type => if not FEU.Is_Redefined (Entity, Child_Interface) and then not Already_Inherited (IDL_Name (Identifier (Entity))) then begin if Helper then Map_Any_Converters (To_Ada_Name (IDL_Name (Identifier (Entity))), From_Any, To_Any); Set_Renamed_Entity (From_Any, Expand_Designator (From_Any_Node (BE_Node (Identifier (Entity))))); Set_Renamed_Entity (To_Any, Expand_Designator (To_Any_Node (BE_Node (Identifier (Entity))))); Append_To (Statements (Current_Package), From_Any); Append_To (Statements (Current_Package), To_Any); end if; end; end if; when K_Exception_Declaration => if not FEU.Is_Redefined (Entity, Child_Interface) and then not Already_Inherited (IDL_Name (Identifier (Entity))) then declare Original_Get_Members : Node_Id; New_Member_Type : Node_Id; N : Node_Id; begin if Stub then -- Generate the renamed Get_Members New_Member_Type := Make_Selected_Component (Defining_Identifier (Stubs_Package (Current_Entity)), Get_Base_Identifier (Type_Def_Node (BE_Node (Identifier (Entity))))); N := Map_Get_Members_Spec (New_Member_Type); Original_Get_Members := Make_Selected_Component (Expand_Designator (BEN.Parent (Type_Def_Node (BE_Node (Identifier (Parent_Interface))))), Get_Base_Identifier (Defining_Identifier (Map_Get_Members_Spec (Expand_Designator (Type_Def_Node (BE_Node (Identifier (Entity)))))))); Set_Renamed_Entity (N, Original_Get_Members); Append_To (Statements (Current_Package), N); end if; if Helper then Map_Any_Converters (BEN.Name (Defining_Identifier (Type_Def_Node (BE_Node (Identifier (Entity))))), From_Any, To_Any); Set_Renamed_Entity (From_Any, Expand_Designator (From_Any_Node (BE_Node (Identifier (Entity))))); Set_Renamed_Entity (To_Any, Expand_Designator (To_Any_Node (BE_Node (Identifier (Entity))))); Append_To (Statements (Current_Package), From_Any); Append_To (Statements (Current_Package), To_Any); end if; end; end if; when others => null; end case; Entity := Next_Entity (Entity); end loop; end Map_Additional_Entities_Bodies; ------------------------------------------------- -- Static request handling related subprograms -- ------------------------------------------------- ----------------------------- -- Map_Arg_Type_Identifier -- ----------------------------- function Map_Args_Type_Identifier (E : Node_Id) return Node_Id is pragma Assert (BEN.Kind (E) = K_Defining_Identifier); begin Get_Name_String (BEN.Name (E)); Add_Str_To_Name_Buffer ("_Args_Type"); return Make_Defining_Identifier (Name_Find); end Map_Args_Type_Identifier; ------------------------- -- Map_Args_Identifier -- ------------------------- function Map_Args_Identifier (E : Node_Id) return Node_Id is pragma Assert (BEN.Kind (E) = K_Defining_Identifier); begin Get_Name_String (BEN.Name (E)); Add_Str_To_Name_Buffer ("_Args"); return Make_Defining_Identifier (Name_Find); end Map_Args_Identifier; ------------------------------- -- Map_Marshaller_Identifier -- ------------------------------- function Map_Marshaller_Identifier (E : Node_Id) return Node_Id is pragma Assert (BEN.Kind (E) = K_Defining_Identifier); begin Get_Name_String (BEN.Name (E)); Add_Str_To_Name_Buffer ("_Marshaller"); return Make_Defining_Identifier (Name_Find); end Map_Marshaller_Identifier; --------------------------------- -- Map_Unmarshaller_Identifier -- --------------------------------- function Map_Unmarshaller_Identifier (E : Node_Id) return Node_Id is pragma Assert (BEN.Kind (E) = K_Defining_Identifier); begin Get_Name_String (BEN.Name (E)); Add_Str_To_Name_Buffer ("_Unmarshaller"); return Make_Defining_Identifier (Name_Find); end Map_Unmarshaller_Identifier; ----------------------------- -- Map_Set_Args_Identifier -- ----------------------------- function Map_Set_Args_Identifier (E : Node_Id) return Node_Id is pragma Assert (BEN.Kind (E) = K_Defining_Identifier); begin Get_Name_String (BEN.Name (E)); Add_Str_To_Name_Buffer ("_Set_Args"); return Make_Defining_Identifier (Name_Find); end Map_Set_Args_Identifier; -------------------------------- -- Map_Buffer_Size_Identifier -- -------------------------------- function Map_Buffer_Size_Identifier (E : Node_Id) return Node_Id is pragma Assert (BEN.Kind (E) = K_Defining_Identifier); begin Get_Name_String (BEN.Name (E)); Add_Str_To_Name_Buffer ("_Buffer_Size"); return Make_Defining_Identifier (Name_Find); end Map_Buffer_Size_Identifier; ---------------------------------- -- Map_Argument_Identifier_Name -- ---------------------------------- function Map_Argument_Identifier_Name (P : Name_Id; O : Name_Id) return Name_Id is begin Get_Name_String (O); Add_Str_To_Name_Buffer ("_Arg_Name_"); Get_Name_String_And_Append (P); Add_Str_To_Name_Buffer (Unique_Suffix); return Name_Find; end Map_Argument_Identifier_Name; ----------------------- -- Map_Argument_Name -- ----------------------- function Map_Argument_Name (P : Name_Id) return Name_Id is begin Set_Str_To_Name_Buffer ("Argument_"); Get_Name_String_And_Append (P); Add_Str_To_Name_Buffer (Unique_Suffix); return Name_Find; end Map_Argument_Name; ------------------------------- -- Map_Argument_Content_Name -- ------------------------------- function Map_Argument_Content_Name (P : Name_Id) return Name_Id is begin Set_Str_To_Name_Buffer ("Arg_CC_"); Get_Name_String_And_Append (P); Add_Str_To_Name_Buffer (Unique_Suffix); return Name_Find; end Map_Argument_Content_Name; --------------------------- -- Map_Argument_Any_Name -- --------------------------- function Map_Argument_Any_Name (P : Name_Id) return Name_Id is begin Set_Str_To_Name_Buffer ("Arg_Any_"); Get_Name_String_And_Append (P); Add_Str_To_Name_Buffer (Unique_Suffix); return Name_Find; end Map_Argument_Any_Name; -------------------------------- -- Map_Result_Subprogram_Name -- -------------------------------- function Map_Result_Subprogram_Name (O : Name_Id) return Name_Id is begin Get_Name_String (O); Add_Str_To_Name_Buffer ("_Result" & Unique_Suffix); return Name_Find; end Map_Result_Subprogram_Name; -------------------------------- -- Map_Result_Identifier_Name -- -------------------------------- function Map_Result_Identifier_Name (O : Name_Id) return Name_Id is begin Get_Name_String (O); Add_Str_To_Name_Buffer ("_Result_Name" & Unique_Suffix); return Name_Find; end Map_Result_Identifier_Name; -------------------------------- -- Map_Operation_Name_Literal -- -------------------------------- function Map_Operation_Name_Literal (O : Node_Id) return Name_Id is begin -- Literals for attribute accessors must be prefixed by '_' -- (_get_... and _set_...). Attribute accessors are known by -- their null location (they are created at expansion time, so -- they do not have a location in the IDL file). Name_Len := 0; if FEN.Loc (Identifier (O)) = No_Location then Set_Char_To_Name_Buffer ('_'); end if; Get_Name_String_And_Append (IDL_Name (Identifier (O))); return Name_Find; end Map_Operation_Name_Literal; ------------------------- -- Cast_When_Necessary -- ------------------------- procedure Cast_When_Necessary (Ada_Node : in out Node_Id; IDL_Immediate_Type : Node_Id; IDL_Original_Type : Node_Id; Wrap : Boolean := False) is Is_Object : constant Boolean := Is_Object_Type (IDL_Original_Type); begin if Is_Object then -- Handle predefined CORBA objects if FEN.Kind (IDL_Original_Type) = K_Interface_Declaration or else FEN.Kind (IDL_Original_Type) = K_Forward_Interface_Declaration then declare R : constant RE_Id := Get_Predefined_CORBA_Entity (IDL_Original_Type); begin case R is when RE_Object => if FEN.Kind (IDL_Immediate_Type) = K_Scoped_Name and then IDL_Original_Type /= Reference (IDL_Immediate_Type) then Ada_Node := Make_Type_Conversion (RE (RE_Object), Ada_Node); end if; return; -- Important when others => null; end case; end; end if; -- General case if FEN.Kind (IDL_Immediate_Type) = K_Scoped_Name then Ada_Node := Make_Type_Conversion (RE (RE_Ref_2), Ada_Node); end if; else if FEN.Kind (IDL_Immediate_Type) = K_Scoped_Name and then FEN.Kind (Reference (IDL_Immediate_Type)) = K_Simple_Declarator then Ada_Node := Make_Type_Conversion (Get_Type_Definition_Node (IDL_Original_Type, Wrap), Ada_Node); end if; end if; end Cast_When_Necessary; --------------------------------- -- Get_From_Any_Container_Node -- --------------------------------- function Get_From_Any_Container_Node (T : Node_Id) return Node_Id is begin -- Base types case if Is_Base_Type (T) then if FEN.Kind (T) = FEN.K_Object then return RE (RE_From_Any_1); else return RE (RE_From_Any_0); end if; end if; -- User type case case FEN.Kind (T) is when K_Enumeration_Type => return Expand_Designator (From_Any_Container_Node (BE_Node (Identifier (T)))); when K_Scoped_Name => declare Result : constant Node_Id := Map_Predefined_CORBA_From_Any (T); begin -- If result is not null, then we deal with a -- predefined CORBA entity. if Present (Result) then return Result; end if; return Get_From_Any_Container_Node (Reference (T)); end; when others => raise Program_Error with "Cannot get the additional From_Any " & "spec of a " & FEN.Node_Kind'Image (FEN.Kind (T)) & " at position " & Image (FEN.Loc (T)); end case; end Get_From_Any_Container_Node; ----------------------- -- Get_From_Any_Node -- ----------------------- function Get_From_Any_Node (T : Node_Id; Withed : Boolean := True) return Node_Id is begin -- Base types case if Is_Base_Type (T) then if FEN.Kind (T) = FEN.K_Object then return RE (RE_From_Any_1, Withed); else return RE (RE_From_Any_0, Withed); end if; end if; -- User type case case FEN.Kind (T) is when K_Fixed_Point_Type | K_Sequence_Type | K_String_Type | K_Wide_String_Type => return Expand_Designator (From_Any_Node (BE_Node (T)), Withed); when K_Scoped_Name => declare Result : constant Node_Id := Map_Predefined_CORBA_From_Any (T, Withed); begin -- If result is not nul, then we deal with a -- predefined CORBA entity. if Present (Result) then return Result; end if; return Get_From_Any_Node (Reference (T), Withed); end; when others => return Expand_Designator (From_Any_Node (BE_Node (Identifier (T))), Withed); end case; end Get_From_Any_Node; ------------------------- -- Get_Initialize_Node -- ------------------------- function Get_Initialize_Node (T : Node_Id; Resolve_Forward : Boolean := True) return Node_Id is begin -- Base types case if Is_Base_Type (T) then return No_Node; end if; -- General case case FEN.Kind (T) is when K_Fixed_Point_Type | K_Sequence_Type | K_String_Type | K_Wide_String_Type => return Expand_Designator (Initialize_Node (BE_Node (T))); when K_Scoped_Name => declare Result : constant Node_Id := Map_Predefined_CORBA_Initialize (T); begin -- If result is not nul, then we deal with a -- predefined CORBA entity. if Present (Result) then return Result; end if; return Get_Initialize_Node (Reference (T), Resolve_Forward); end; when K_Forward_Interface_Declaration => if Resolve_Forward then return Get_Initialize_Node (Forward (T), Resolve_Forward); else return Expand_Designator (Initialize_Node (BE_Node (Identifier (T)))); end if; when others => return Expand_Designator (Initialize_Node (BE_Node (Identifier (T)))); end case; end Get_Initialize_Node; ----------------- -- Get_TC_Node -- ----------------- function Get_TC_Node (T : Node_Id; Resolve_Forward : Boolean := True) return Node_Id is begin -- Base types case if Is_Base_Type (T) then return Base_Type_TC (FEN.Kind (T)); end if; -- General case case FEN.Kind (T) is when K_Fixed_Point_Type | K_Sequence_Type | K_String_Type | K_Wide_String_Type => return Expand_Designator (TC_Node (BE_Node (T))); when K_Scoped_Name => declare Result : constant Node_Id := Map_Predefined_CORBA_TC (T); begin -- If result is not nul, then we deal with a -- predefined CORBA entity. if Present (Result) then return Result; end if; return Get_TC_Node (Reference (T), Resolve_Forward); end; when K_Forward_Interface_Declaration => if Resolve_Forward then return Get_TC_Node (Forward (T), Resolve_Forward); else return Expand_Designator (TC_Node (BE_Node (Identifier (T)))); end if; when others => return Expand_Designator (TC_Node (BE_Node (Identifier (T)))); end case; end Get_TC_Node; --------------------- -- Get_To_Any_Node -- --------------------- function Get_To_Any_Node (T : Node_Id; Withed : Boolean := True) return Node_Id is begin -- Base types case if Is_Base_Type (T) then if FEN.Kind (T) = FEN.K_Object then return RE (RE_To_Any_3, Withed); else return RE (RE_To_Any_0, Withed); end if; end if; -- General case case FEN.Kind (T) is when K_Fixed_Point_Type | K_Sequence_Type | K_String_Type | K_Wide_String_Type => return Expand_Designator (To_Any_Node (BE_Node (T)), Withed); when K_Scoped_Name => declare Result : constant Node_Id := Map_Predefined_CORBA_To_Any (T, Withed); begin -- If result is not nul, then we deal with a -- predefined CORBA entity. if Present (Result) then return Result; end if; return Get_To_Any_Node (Reference (T), Withed); end; when others => return Expand_Designator (To_Any_Node (BE_Node (Identifier (T))), Withed); end case; end Get_To_Any_Node; --------------------- -- Get_To_Ref_Node -- --------------------- function Get_To_Ref_Node (T : Node_Id; Withed : Boolean := True) return Node_Id is begin case FEN.Kind (T) is when K_Scoped_Name => declare Result : constant Node_Id := Map_Predefined_CORBA_To_Ref (T, Withed); begin -- If result is not nul, then we deal with a -- predefined CORBA entity. if Present (Result) then return Result; end if; return Get_To_Ref_Node (Reference (T), Withed); end; when others => declare Orig_Type_Spec : constant Node_Id := FEU.Get_Original_Type_Specifier (T); begin return Expand_Designator (To_Ref_Node (BE_Node (Identifier (Orig_Type_Spec))), Withed); end; end case; end Get_To_Ref_Node; ------------------------- -- Get_Marshaller_Node -- ------------------------- function Get_Marshaller_Node (O : Node_Id; Withed : Boolean := True) return Node_Id is Result : Node_Id; begin pragma Assert (FEN.Kind (O) = FEN.K_Operation_Declaration); Result := Map_Predefined_CORBA_Marshaller (O, Withed); if No (Result) then Result := Expand_Designator (Marshaller_Node (BE_Node (Identifier (O)))); end if; return Result; end Get_Marshaller_Node; --------------------------- -- Get_Unmarshaller_Node -- --------------------------- function Get_Unmarshaller_Node (O : Node_Id; Withed : Boolean := True) return Node_Id is Result : Node_Id; begin pragma Assert (FEN.Kind (O) = FEN.K_Operation_Declaration); Result := Map_Predefined_CORBA_Unmarshaller (O, Withed); if No (Result) then Result := Expand_Designator (Unmarshaller_Node (BE_Node (Identifier (O)))); end if; return Result; end Get_Unmarshaller_Node; ------------------------------ -- Get_Type_Definition_Node -- ------------------------------ function Get_Type_Definition_Node (T : Node_Id; Wrap : Boolean := False) return Node_Id is begin -- Base types case if Is_Base_Type (T) then return RE (Convert (FEN.Kind (T))); end if; -- General case case FEN.Kind (T) is -- For sequence and bounded [wide] string types, the -- frontend node is linked to a type designator. For the -- remaining types, the frontend node is linked to full type -- definition. when K_Fixed_Point_Type => return Expand_Designator (Type_Def_Node (BE_Node (T))); when K_Structure_Type | K_Union_Type | K_Enumeration_Type | K_Complex_Declarator => return Expand_Designator (Type_Def_Node (BE_Node (Identifier (T)))); when K_Sequence_Type | K_String_Type | K_Wide_String_Type => return Copy_Expanded_Name (Type_Def_Node (BE_Node (T))); when K_Scoped_Name => -- Handle predefined CORBA entities declare Result : constant Node_Id := Map_Predefined_CORBA_Type (T, Wrap => Wrap); begin if Present (Result) then return Result; end if; return Get_Type_Definition_Node (Reference (T)); end; when others => -- Handle predefined CORBA entities declare Result : constant Node_Id := Map_Predefined_CORBA_Type (T, Wrap => Wrap); Orig_Type_Spec : constant Node_Id := FEU.Get_Original_Type_Specifier (T); begin if Present (Result) then return Result; end if; -- If the wrap flag has been set, we return the -- ancestor type of T for which a 'Wrap' function has -- been generated. if Wrap then return Get_Type_Definition_Node (Orig_Type_Spec); else return Expand_Designator (Type_Def_Node (BE_Node (Identifier (T)))); end if; end; end case; end Get_Type_Definition_Node; -------------------------- -- Get_IR_Function_Node -- -------------------------- function Get_IR_Function_Node (T : Node_Id; Withed : Boolean := True) return Node_Id is function Get_Primitive (R : RE_Id) return Node_Id; -- Return a call to Get_Primitive for the named PrimitiveDef -- kind. ------------------- -- Get_Primitive -- ------------------- function Get_Primitive (R : RE_Id) return Node_Id is N : Node_Id; begin N := Make_Subprogram_Call (RE (RE_Get_Primitive), New_List (Make_Subprogram_Call (RE (RE_Get_IR_Root), No_List), RE (R))); return N; end Get_Primitive; begin case FEN.Kind (T) is when K_Void => return Get_Primitive (RE_pk_void); when K_Short => return Get_Primitive (RE_pk_short); when K_Long => return Get_Primitive (RE_pk_long); when K_Long_Long => return Get_Primitive (RE_pk_longlong); when K_Unsigned_Short => return Get_Primitive (RE_pk_ushort); when K_Unsigned_Long => return Get_Primitive (RE_pk_ulong); when K_Unsigned_Long_Long => return Get_Primitive (RE_pk_ulonglong); when K_Char => return Get_Primitive (RE_pk_char); when K_Wide_Char => return Get_Primitive (RE_pk_wchar); when K_Boolean => return Get_Primitive (RE_pk_boolean); when K_Float => return Get_Primitive (RE_pk_float); when K_Double => return Get_Primitive (RE_pk_double); when K_Long_Double => return Get_Primitive (RE_pk_longdouble); when K_String => return Get_Primitive (RE_pk_string); when K_String_Type => return Get_Primitive (RE_pk_string); when K_Wide_String => return Get_Primitive (RE_pk_wstring); when K_Wide_String_Type => return Get_Primitive (RE_pk_wstring); when K_Octet => return Get_Primitive (RE_pk_octet); when K_Object => return Get_Primitive (RE_pk_objref); when K_Any => return Get_Primitive (RE_pk_any); when K_Fixed_Point_Type | K_Sequence_Type => raise Program_Error; when K_Scoped_Name => declare Result : constant Node_Id := Map_Predefined_CORBA_IR_Function (T); begin -- If result is not nul, then we deal with a -- predefined CORBA entity. if Present (Result) then return Result; end if; return Get_IR_Function_Node (Reference (T), Withed); end; when others => return Expand_Designator (Ir_Function_Node (BE_Node (Identifier (T))), Withed); end case; end Get_IR_Function_Node; ------------------- -- Get_Wrap_Node -- ------------------- function Get_Wrap_Node (T : Node_Id; Withed : Boolean := True) return Node_Id is begin -- Base types case if Is_Base_Type (T) then if FEN.Kind (T) = FEN.K_Object then return RE (RE_Wrap_3, Withed); else return RE (RE_Wrap_2, Withed); end if; end if; -- General case case FEN.Kind (T) is when K_Fixed_Point_Type | K_Sequence_Type | K_String_Type | K_Wide_String_Type => return Expand_Designator (Wrap_Node (BE_Node (T)), Withed); when K_Structure_Type | K_Union_Type | K_Enumeration_Type | K_Complex_Declarator => return Expand_Designator (Wrap_Node (BE_Node (Identifier (T))), Withed); when K_Scoped_Name => -- Handle predefined CORBA entities declare Result : constant Node_Id := Map_Predefined_CORBA_Wrap (T, Withed); begin if Present (Result) then return Result; end if; return Get_Wrap_Node (Reference (T), Withed); end; when K_Interface_Declaration | K_Forward_Interface_Declaration => -- Handle predefined CORBA entities declare Result : constant Node_Id := Map_Predefined_CORBA_Wrap (T); begin if Present (Result) then return Result; end if; -- Interfaces are CORBA.Object return RE (RE_Wrap_3, Withed); end; when others => declare Result : constant Node_Id := Map_Predefined_CORBA_Wrap (T, Withed); Orig_Type_Spec : constant Node_Id := FEU.Get_Original_Type_Specifier (T); begin if Present (Result) then return Result; end if; return Get_Wrap_Node (Orig_Type_Spec, Withed); end; end case; end Get_Wrap_Node; -------------------- -- Add_Dependency -- -------------------- procedure Add_Dependency (Dep : Node_Id; Dependency_List : List_Id; Dependency_Kind : Dependent_Entity; Optional : Boolean := False) is function "=" (Name : Name_Id; Node : Node_Id) return Boolean; -- Shortcut to compare `Name' to the full name of `Node' function Is_Internal_Unit (Unit : Node_Id) return Boolean; -- Return True if `Unit' is an internal Ada unit --------- -- "=" -- --------- function "=" (Name : Name_Id; Node : Node_Id) return Boolean is begin return Name = Fully_Qualified_Name (Node); end "="; ---------------------- -- Is_Internal_Unit -- ---------------------- function Is_Internal_Unit (Unit : Node_Id) return Boolean is begin return BEN.Kind (Get_Declaration_Node (Unit)) = K_Package_Instantiation; end Is_Internal_Unit; Dep_Name : Name_Id; V : Value_Id; N : Node_Id; M : Node_Id; Append : Boolean := False; begin if Is_Internal_Unit (Dep) then return; end if; Dep_Name := BEU.Fully_Qualified_Name (Dep); -- Particular case : We don't add dependencies on: -- * The Helper package itself if Dep_Name = Defining_Identifier (Helper_Package (Current_Entity)) then return; -- First case : A dependency on CORBA.Object.Helper -- implies a dependency on CORBA.Object elsif Dep_Name = RU (RU_CORBA_Object_Helper, False) then Add_Dependency (RU (RU_CORBA_Object, False), Dependency_List, Dependency_Kind); return; -- Second case : We lower the case of these entities -- * CORBA -- * CORBA.Helper -- * CORBA.Object elsif Dep_Name = RU (RU_CORBA, False) or else Dep_Name = RU (RU_CORBA_Helper, False) or else Dep_Name = RU (RU_CORBA_Object, False) then Get_Name_String (Dep_Name); To_Lower (Name_Buffer (1 .. Name_Len)); Dep_Name := Name_Find; Append := True; -- Third case: Some PolyORB units have a customized -- initialization name elsif Dep_Name = RU (RU_PolyORB_Exceptions, False) then Set_Str_To_Name_Buffer ("exceptions"); Dep_Name := Name_Find; Append := True; elsif Dependency_Kind /= D_Helper then -- Forth case: general case, we add the dependency for the -- given package except for *generated* Helpers that need -- not to depend upon each others Append := True; end if; -- If the dependency is optional, append a '?' suffix if Optional then Dep_Name := Add_Suffix_To_Name ("?", Dep_Name); end if; -- Check whether the dependency is already added M := First_Node (Dependency_List); while Present (M) loop if Values.Value (BEN.Value (M)).SVal = Dep_Name then Append := False; end if; M := Next_Node (M); end loop; -- Add the dependency if it belongs to the cases above if Append then V := New_String_Value (Dep_Name, False); N := Make_Literal (V); Append_To (Dependency_List, N); end if; end Add_Dependency; end Backend.BE_CORBA_Ada.IDL_To_Ada; polyorb-2.8~20110207.orig/compilers/iac/backend-be_corba_ada-aligned.adb0000644000175000017500000010630511750740337025145 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- B A C K E N D . B E _ C O R B A _ A D A . A L I G N E D -- -- -- -- B o d y -- -- -- -- Copyright (C) 2005-2008, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with Namet; use Namet; with Frontend.Nodes; use Frontend.Nodes; with Frontend.Nutils; with Backend.BE_CORBA_Ada.Nodes; use Backend.BE_CORBA_Ada.Nodes; with Backend.BE_CORBA_Ada.Nutils; use Backend.BE_CORBA_Ada.Nutils; with Backend.BE_CORBA_Ada.IDL_To_Ada; use Backend.BE_CORBA_Ada.IDL_To_Ada; with Backend.BE_CORBA_Ada.Runtime; use Backend.BE_CORBA_Ada.Runtime; with Backend.BE_CORBA_Ada.Common; use Backend.BE_CORBA_Ada.Common; package body Backend.BE_CORBA_Ada.Aligned is package FEN renames Frontend.Nodes; package FEU renames Frontend.Nutils; package BEN renames Backend.BE_CORBA_Ada.Nodes; package body Package_Spec is -- The Args_Type_Out is unusable for the moment, it will be -- used just for bounded type function Args_Type_Record_In (E : Node_Id) return Node_Id; function Args_Type_Record_Out (E : Node_Id) return Node_Id; function Args_Type_Access_Out (E : Node_Id) return Node_Id; procedure Visit_Specification (E : Node_Id); procedure Visit_Module (E : Node_Id); procedure Visit_Operation_Declaration (E : Node_Id); procedure Visit_Interface_Declaration (E : Node_Id); procedure Visit_Structure_Type (E : Node_Id); procedure Visit_Union_Type (E : Node_Id); procedure Visit_Type_Declaration (E : Node_Id); function Make_Variable_Type (N : Node_Id; Type_Spec : Node_Id; Desc : List_Id) return Node_Id; function Is_Unbounded_Type (N : Node_Id) return Boolean; -- Return true if N (type spec) contains an unbounded type procedure Get_Discriminants (N : Node_Id; L : List_Id; Ret : Boolean := False; Struct : Boolean := False); -- Fill 'L' with all discriminants of the type 'N'. Ret -- indicate if the type is used for return argument in this -- case the argument name is 'Return'. Struct indicate if the -- type is a structure member. ------------------------- -- Args_Type_Record_In -- ------------------------- function Args_Type_Record_In (E : Node_Id) return Node_Id is pragma Assert (FEN.Kind (E) = K_Operation_Declaration); Spec : constant Node_Id := Stub_Node (BE_Node (Identifier (E))); Param : constant List_Id := Parameters (E); Discr : constant List_Id := New_List; Components : constant List_Id := New_List; L : List_Id := No_List; Args_Type : Node_Id := No_Node; Component : Node_Id; Par_Type : Node_Id; N : Node_Id; Par : Node_Id; begin -- For each subprogram we generate a record containing the -- In parameters with the aligned type. if not FEU.Is_Empty (Param) then Par := First_Entity (Param); while Present (Par) loop if Is_In (FEN.Parameter_Mode (Par)) then -- If the parameter type is a class-wide type, we -- remove the "'Class" attribute from the type -- name. Par_Type := Type_Spec (Par); if BEN.Kind (Par_Type) = K_Attribute_Reference then Par_Type := Prefix (Par_Type); end if; Par_Type := Make_Type_Designator (Par_Type); if Is_Unbounded_Type (Type_Spec (Par)) then L := New_List; Get_Discriminants (Par, L); end if; Par_Type := Make_Variable_Type (Par_Type, Type_Spec (Par), L); -- Add the discriminants of Par to Discr if not Is_Empty (L) then N := First_Node (L); Append_To (Discr, N); L := No_List; end if; Component := Make_Component_Declaration (Defining_Identifier => Make_Defining_Identifier (IDL_Name (Identifier (Declarator (Par)))), Subtype_Indication => Par_Type); Append_To (Components, Component); end if; Par := Next_Entity (Par); end loop; end if; -- Record name Get_Name_String (BEN.Name (Defining_Identifier (Spec))); Add_Str_To_Name_Buffer ("_Args_Type_In"); N := Make_Selected_Component (Defining_Identifier (Aligned_Package (Current_Entity)), Make_Defining_Identifier (Name_Find)); -- record type Declaration Args_Type := Make_Full_Type_Declaration (Defining_Identifier => N, Type_Definition => Make_Record_Definition (Components), Discriminant_Spec => Discr); return Args_Type; end Args_Type_Record_In; -------------------------- -- Args_Type_Record_Out -- -------------------------- function Args_Type_Record_Out (E : Node_Id) return Node_Id is pragma Assert (FEN.Kind (E) = K_Operation_Declaration); Spec : constant Node_Id := Stub_Node (BE_Node (Identifier (E))); T : constant Node_Id := Type_Spec (E); Param : constant List_Id := Parameters (E); Discr : constant List_Id := New_List; Components : constant List_Id := New_List; L : List_Id := No_List; Args_Type : Node_Id := No_Node; Component : Node_Id; Par_Type : Node_Id; N : Node_Id; Par : Node_Id; begin -- For each subprogram we generate a record containing the -- Out parameters with the aligned type. if not FEU.Is_Empty (Param) then Par := First_Entity (Param); while Present (Par) loop if Is_Out (FEN.Parameter_Mode (Par)) then -- If the parameter type is a class-wide type, we -- remove the "'Class" attribute from the type -- name. Par_Type := Type_Spec (Par); if BEN.Kind (Par_Type) = K_Attribute_Reference then Par_Type := Prefix (Par_Type); end if; Par_Type := Make_Type_Designator (Par_Type); if Is_Unbounded_Type (Type_Spec (Par)) then L := New_List; Get_Discriminants (Par_Type, L); end if; Par_Type := Make_Variable_Type (Par_Type, Type_Spec (Par), L); if not Is_Empty (L) then N := First_Node (L); Append_To (Discr, N); L := No_List; end if; Component := Make_Component_Declaration (Defining_Identifier => Make_Defining_Identifier (IDL_Name (Identifier (Declarator (Par)))), Subtype_Indication => Par_Type); Append_To (Components, Component); end if; Par := Next_Entity (Par); end loop; end if; -- If the subprogram is a function, we add an additional -- member corresponding to the result of the function. if Present (T) and then FEN.Kind (T) /= K_Void then -- If the return type is a class-wide type, we remove the -- "'Class" attribute from the type name. Par_Type := T; if BEN.Kind (Par_Type) = K_Attribute_Reference then Par_Type := Prefix (Par_Type); end if; Par_Type := Make_Type_Designator (Par_Type); if Is_Unbounded_Type (T) then L := New_List; Get_Discriminants (T, L, True, False); end if; Par_Type := Make_Variable_Type (Par_Type, T, L); if not Is_Empty (L) then N := First_Node (L); Append_To (Discr, N); L := No_List; end if; Component := Make_Component_Declaration (Defining_Identifier => Make_Defining_Identifier (PN (P_Returns)), Subtype_Indication => Par_Type); Append_To (Components, Component); end if; -- The record name Get_Name_String (BEN.Name (Defining_Identifier (Spec))); Add_Str_To_Name_Buffer ("_Args_Type_Out"); N := Make_Selected_Component (Defining_Identifier (Aligned_Package (Current_Entity)), Make_Defining_Identifier (Name_Find)); -- Record type Declaration Args_Type := Make_Full_Type_Declaration (Defining_Identifier => N, Type_Definition => Make_Record_Definition (Components), Discriminant_Spec => Discr); return Args_Type; end Args_Type_Record_Out; -------------------------- -- Args_Type_Access_Out -- -------------------------- function Args_Type_Access_Out (E : Node_Id) return Node_Id is pragma Assert (FEN.Kind (E) = K_Operation_Declaration); Spec : constant Node_Id := Stub_Node (BE_Node (Identifier (E))); N : Node_Id; M : Node_Id; begin Get_Name_String (BEN.Name (Defining_Identifier (Spec))); Add_Str_To_Name_Buffer ("_Args_Type_Out"); N := Make_Defining_Identifier (Name_Find); Get_Name_String (BEN.Name (Defining_Identifier (Spec))); Add_Str_To_Name_Buffer ("_Args_Type_Access_Out"); M := Make_Selected_Component (Defining_Identifier (Aligned_Package (Current_Entity)), Make_Defining_Identifier (Name_Find)); M := Make_Full_Type_Declaration (Defining_Identifier => M, Type_Definition => Make_Access_Type_Definition (N)); return M; end Args_Type_Access_Out; ----------- -- Visit -- ----------- procedure Visit (E : Node_Id) is begin case FEN.Kind (E) is when K_Module => Visit_Module (E); when K_Operation_Declaration => Visit_Operation_Declaration (E); when K_Interface_Declaration => Visit_Interface_Declaration (E); when K_Structure_Type => Visit_Structure_Type (E); when K_Union_Type => Visit_Union_Type (E); when K_Type_Declaration => Visit_Type_Declaration (E); when K_Specification => Visit_Specification (E); when others => null; end case; end Visit; ---------------------------- -- Visit_Type_Declaration -- ---------------------------- procedure Visit_Type_Declaration (E : Node_Id) is D : Node_Id; Id : Node_Id; T : Node_Id; N : Node_Id; Type_Spec_Node : Node_Id; Is_Subtype : Boolean := False; begin Set_Aligned_Spec; Type_Spec_Node := Type_Spec (E); -- * The fixed type shall be mapped to an equivalent Ada -- decimal type. -- * For each declarator, a type definition shall be -- generated. if FEN.Kind (Type_Spec_Node) = K_Fixed_Point_Type then declare Fixed_Type_Node : Node_Id; Fixed_Name : constant Name_Id := Map_Fixed_Type_Name (Type_Spec_Node); begin -- XXX it is certainly false. -- TODO: make a package instantiation at the marshalling time T := Make_Selected_Component (Defining_Identifier (Aligned_Package (Current_Entity)), Make_Defining_Identifier (Fixed_Name)); Fixed_Type_Node := Make_Full_Type_Declaration (Defining_Identifier => T, Type_Definition => Make_Decimal_Type_Definition (Type_Spec_Node)); Append_To (Visible_Part (Current_Package), Fixed_Type_Node); end; elsif FEN.Kind (Type_Spec_Node) = K_String_Type or else FEN.Kind (Type_Spec_Node) = K_Wide_String_Type then declare Str_Package_Inst : Node_Id; Pkg_Name : Name_Id; Pkg_Node : Node_Id; String_Pkg : Node_Id; begin -- We create an instantiation of the generic package -- PolyORB.Aligned_Types.Bounded_Strings (or -- PolyORB.Aligned_Types.Bounded_Wide_Strings). Then, -- the string type is derived from the -- 'Bounded_String' type (or the 'Bounded_Wide_String' -- type of the instantiated package. Pkg_Name := Map_String_Pkg_Name (Type_Spec_Node); if FEN.Kind (Type_Spec_Node) = K_Wide_String_Type then String_Pkg := RU (RU_PolyORB_Aligned_Types_Bounded_Wide_Strings, False); T := Make_Defining_Identifier (TN (T_Bounded_Wide_String)); else String_Pkg := RU (RU_PolyORB_Aligned_Types_Bounded_Strings, False); T := Make_Defining_Identifier (TN (T_Bounded_String)); end if; -- Building the string package node Pkg_Node := Make_Selected_Component (Defining_Identifier (Aligned_Package (Current_Entity)), Make_Defining_Identifier (Pkg_Name)); Str_Package_Inst := Make_Package_Instantiation (Defining_Identifier => Pkg_Node, Generic_Package => String_Pkg, Parameter_List => New_List (Make_Literal (FEU.Expr_Value (Max_Size (Type_Spec_Node))))); Append_To (Visible_Part (Current_Package), Str_Package_Inst); T := Make_Selected_Component (Pkg_Node, T); end; elsif FEN.Kind (Type_Spec_Node) /= K_Sequence_Type then -- General case T := Make_Type_Designator (Type_Spec_Node); end if; Is_Subtype := Is_Object_Type (Type_Spec (E)); D := First_Entity (Declarators (E)); while Present (D) loop Id := Make_Selected_Component (Defining_Identifier (Aligned_Package (Current_Entity)), Map_Defining_Identifier (D)); if Kind (D) = K_Complex_Declarator then N := Make_Full_Type_Declaration (Defining_Identifier => Id, Type_Definition => Make_Array_Type_Definition (Map_Range_Constraints (FEN.Array_Sizes (D)) , T)); elsif FEN.Kind (Type_Spec_Node) = K_Sequence_Type then declare M : Node_Id; K : Node_Id; Rang : Node_Id; L : constant List_Id := New_List; Disc : constant List_Id := New_List; begin -- Declaration of array of element type M := Make_Type_Designator (Type_Spec (Type_Spec_Node)); K := RE (RE_Unsigned_Long_10); M := Make_Array_Type_Definition (No_List, M, K); K := Map_Defining_Identifier (D); Set_Str_To_Name_Buffer (Get_Name_String (BEN.Name (K)) & "_Content"); K := Make_Defining_Identifier (Name_Find); M := Make_Full_Type_Declaration (K, M); Append_To (Visible_Part (Current_Package), M); -- Declration of the sequence type if Present (Max_Size (Type_Spec_Node)) then K := Make_Literal (FEU.Expr_Value (Max_Size (Type_Spec_Node))); else M := Map_Defining_Identifier (D); Set_Str_To_Name_Buffer (Get_Name_String (BEN.Name (M)) & "_Length"); K := Make_Defining_Identifier (Name_Find); end if; Rang := Make_Range_Constraint (Make_Literal (Int1_Val), K); M := Map_Defining_Identifier (D); Set_Str_To_Name_Buffer (Get_Name_String (BEN.Name (M)) & "_Content"); M := Make_Defining_Identifier (Name_Find); K := Make_String_Type_Definition (M, Rang); M := Make_Component_Declaration (Make_Defining_Identifier (PN (P_Content)), K); Append_To (L, M); -- Discriminant if not Present (Max_Size (Type_Spec_Node)) then K := Map_Defining_Identifier (D); Set_Str_To_Name_Buffer (Get_Name_String (BEN.Name (K)) & "_Length"); M := Make_Defining_Identifier (Name_Find); M := Make_Component_Declaration (M, RE (RE_Unsigned_Long_10)); Append_To (Disc, M); end if; -- Type declaration N := Make_Full_Type_Declaration (Defining_Identifier => Id, Type_Definition => Make_Record_Definition (L), Discriminant_Spec => Disc); end; else N := Make_Full_Type_Declaration (Defining_Identifier => Id, Type_Definition => Make_Derived_Type_Definition (Subtype_Indication => T, Record_Extension_Part => No_Node, Is_Subtype => Is_Subtype), Is_Subtype => Is_Subtype); end if; Append_To (Visible_Part (Current_Package), N); D := Next_Entity (D); end loop; end Visit_Type_Declaration; --------------------------------- -- Visit_Interface_Declaration -- --------------------------------- procedure Visit_Interface_Declaration (E : Node_Id) is N : Node_Id; begin -- If local interface, nothing to do. if FEN.Is_Local_Interface (E) then return; end if; N := BEN.Parent (Type_Def_Node (BE_Node (Identifier (E)))); Push_Entity (BEN.IDL_Unit (Package_Declaration (N))); Set_Aligned_Spec; N := First_Entity (Interface_Body (E)); while Present (N) loop Visit (N); N := Next_Entity (N); end loop; Pop_Entity; end Visit_Interface_Declaration; -------------------------- -- Visit_Structure_Type -- -------------------------- procedure Visit_Structure_Type (E : Node_Id) is Components : constant List_Id := New_List; Discr : constant List_Id := New_List; L : List_Id := New_List; N : Node_Id; M : Node_Id; C : Node_Id; Member : Node_Id; Unbounded : Boolean; begin Set_Aligned_Spec; Member := First_Entity (Members (E)); while Present (Member) loop N := Map_Defining_Identifier (Identifier (First_Entity (Declarators (Member)))); M := Make_Type_Designator (Type_Spec (Member), First_Entity (Declarators (Member))); Unbounded := Is_Unbounded_Type (Type_Spec (Member)); if Unbounded then Get_Discriminants (Member, L, False, True); M := Make_Variable_Type (M, Type_Spec (Member), L); C := First_Node (L); Append_To (Discr, C); L := New_List; end if; N := Make_Component_Declaration (Defining_Identifier => N, Subtype_Indication => M); Append_To (Components, N); Member := Next_Entity (Member); end loop; N := Make_Selected_Component (Defining_Identifier (Aligned_Package (Current_Entity)), Make_Defining_Identifier (FEN.IDL_Name (FEN.Identifier (E)))); N := Make_Full_Type_Declaration (Defining_Identifier => N, Type_Definition => Make_Record_Definition (Components), Discriminant_Spec => Discr); Append_To (Visible_Part (Current_Package), N); end Visit_Structure_Type; ---------------------- -- Visit_Union_Type -- ---------------------- procedure Visit_Union_Type (E : Node_Id) is N : Node_Id; S : Node_Id := Switch_Type_Spec (E); Orig_Type : constant Node_Id := FEU.Get_Original_Type_Specifier (S); L : List_Id; Discr : List_Id; Components : List_Id; Choices : List_Id; Variants : List_Id; Literal_Parent : Node_Id := No_Node; T : Node_Id; Switch_Case : Node_Id; M : Node_Id; Variant : Node_Id; Label : Node_Id; Choice : Node_Id; begin Set_Aligned_Spec; T := Make_Type_Designator (S); -- If the discriminator is an enumeration type, we must put -- the full names of the literal. if FEN.Kind (Orig_Type) = K_Enumeration_Type then Literal_Parent := Map_Expanded_Name (Scope_Entity (Identifier (Orig_Type))); else S := No_Node; end if; L := New_List; Discr := New_List; Components := New_List; Variants := New_List; Switch_Case := First_Entity (Switch_Type_Body (E)); while Present (Switch_Case) loop Variant := New_Node (K_Variant); Choices := New_List; Set_Discrete_Choices (Variant, Choices); -- Make the switchs -- Expansion guarantees that the "default:" case is -- isolated in a standalone alternative. Label := First_Entity (Labels (Switch_Case)); while Present (Label) loop Choice := Make_Literal_With_Parent (Value => FEU.Expr_Value (Label), Parent => Literal_Parent); if S /= No_Node then Choice := Cast_Variable_To_PolyORB_Aligned_Type (Choice, S); end if; Append_To (Choices, Choice); Label := Next_Entity (Label); end loop; N := Map_Defining_Identifier (Identifier (Declarator (Element (Switch_Case)))); M := Make_Type_Designator (Type_Spec (Element (Switch_Case)), Declarator (Element (Switch_Case))); if Is_Unbounded_Type (Type_Spec (Element (Switch_Case))) then Get_Discriminants (Element (Switch_Case), L); M := Make_Variable_Type (M, Type_Spec (Element (Switch_Case)), L); Append_To (Discr, First_Node (L)); L := New_List; end if; Set_Component (Variant, Make_Component_Declaration (N, M)); Append_To (Variants, Variant); Switch_Case := Next_Entity (Switch_Case); end loop; Append_To (Discr, Make_Component_Declaration (Make_Defining_Identifier (CN (C_Switch)), T, Make_Attribute_Reference (T, A_First))); Append_To (Components, Make_Variant_Part (Make_Defining_Identifier (CN (C_Switch)), Variants)); -- Type declaration N := Make_Full_Type_Declaration (Make_Defining_Identifier (FEN.IDL_Name (FEN.Identifier (E))), Make_Record_Type_Definition (Make_Record_Definition (Components)), Discr); Append_To (Visible_Part (Current_Package), N); end Visit_Union_Type; ------------------ -- Visit_Module -- ------------------ procedure Visit_Module (E : Node_Id) is D : Node_Id; begin if not Map_Particular_CORBA_Parts (E, PK_Aligned_Spec) then Push_Entity (Stub_Node (BE_Node (Identifier (E)))); D := First_Entity (Definitions (E)); while Present (D) loop Visit (D); D := Next_Entity (D); end loop; Pop_Entity; end if; end Visit_Module; --------------------------------- -- Visit_Operation_Declaration -- --------------------------------- procedure Visit_Operation_Declaration (E : Node_Id) is N : Node_Id; begin Set_Aligned_Spec; Set_Str_To_Name_Buffer ("Operation : "); Get_Name_String_And_Append (IDL_Name (Identifier (E))); N := Make_Ada_Comment (Name_Find); Append_To (Visible_Part (Current_Package), N); -- Generating the 'Operation_Name'_Args_Type_In/Out -- declarations. N := Args_Type_Record_In (E); Append_To (Visible_Part (Current_Package), N); Bind_FE_To_BE (Identifier (E), N, B_Args_In); N := Args_Type_Record_Out (E); Append_To (Visible_Part (Current_Package), N); Bind_FE_To_BE (Identifier (E), N, B_Args_Out); N := Args_Type_Access_Out (E); Append_To (Visible_Part (Current_Package), N); Bind_FE_To_BE (Identifier (E), N, B_Access_Args_Out); end Visit_Operation_Declaration; ------------------------- -- Visit_Specification -- ------------------------- procedure Visit_Specification (E : Node_Id) is Definition : Node_Id; begin Push_Entity (Stub_Node (BE_Node (Identifier (E)))); Definition := First_Entity (Definitions (E)); while Present (Definition) loop Visit (Definition); Definition := Next_Entity (Definition); end loop; Pop_Entity; end Visit_Specification; ------------------------ -- Make_Variable_Type -- ------------------------ function Make_Variable_Type (N : Node_Id; Type_Spec : Node_Id; Desc : List_Id) return Node_Id is Rewinded_Type : Node_Id; M : Node_Id; begin if Is_Empty (Desc) then return N; end if; Rewinded_Type := FEU.Get_Original_Type_Specifier (Type_Spec); Set_Aligned_Spec; case FEN.Kind (Rewinded_Type) is when K_String | K_Wide_String => M := Make_Subprogram_Call (N, New_List (Defining_Identifier (First_Node (Desc)))); return M; when K_Sequence_Type => if not Present (Max_Size (Rewinded_Type)) then M := Make_Subprogram_Call (N, New_List (Defining_Identifier (First_Node (Desc)))); return M; else return N; end if; when others => declare K : Node_Id; L : List_Id; begin -- Make Union_Type (Switch, Discriminant1, ..., -- DiscriminantsN); L := New_List; K := First_Node (Desc); while Present (K) loop M := Make_Identifier (Fully_Qualified_Name (Defining_Identifier (K))); Append_To (L, M); K := Next_Node (K); end loop; M := Make_Subprogram_Call (N, L); return M; end; end case; end Make_Variable_Type; ----------------------- -- Is_Unbounded_Type -- ----------------------- function Is_Unbounded_Type (N : Node_Id) return Boolean is Rewinded_Type : Node_Id; begin Rewinded_Type := FEU.Get_Original_Type_Specifier (N); case FEN.Kind (Rewinded_Type) is when K_Long | K_Unsigned_Short | K_Unsigned_Long | K_Long_Long | K_Unsigned_Long_Long | K_Short | K_Float | K_Double | K_Long_Double | K_Boolean | K_Char | K_Wide_Char | K_Octet | K_String_Type | K_Wide_String_Type => return False; when K_String | K_Wide_String | K_Sequence_Type | K_Union_Type => return True; when K_Structure_Type => declare Ret : Boolean := False; Member : Node_Id; begin -- We test if there is an unbounded member Member := First_Entity (Members (Rewinded_Type)); while Present (Member) loop Ret := Is_Unbounded_Type (Type_Spec (Member)); exit when Ret; Member := Next_Entity (Member); end loop; return Ret; end; when others => return False; end case; end Is_Unbounded_Type; ----------------------- -- Get_Discriminants -- ----------------------- procedure Get_Discriminants (N : Node_Id; L : List_Id; Ret : Boolean := False; Struct : Boolean := False) is Rewinded_Type : Node_Id; M : Node_Id; begin -- If we are processing the return value we have directly -- the type. if Ret then Rewinded_Type := FEU.Get_Original_Type_Specifier (N); else Rewinded_Type := FEU.Get_Original_Type_Specifier (Type_Spec (N)); end if; case FEN.Kind (Rewinded_Type) is when K_Union_Type => declare Member : Node_Id; begin Member := First_Entity (Switch_Type_Body (Rewinded_Type)); while Present (Member) loop if Is_Unbounded_Type (Type_Spec (Element (Member))) then Get_Discriminants (Element (Member), L); end if; Member := Next_Entity (Member); end loop; M := Make_Type_Designator (Switch_Type_Spec (Rewinded_Type)); M := Make_Component_Declaration (Make_Defining_Identifier (CN (C_Switch)), M, Make_Attribute_Reference (M, A_First)); Append_To (L, M); end; when K_Structure_Type => declare Member : Node_Id; begin Member := First_Entity (Members (Rewinded_Type)); while Present (Member) loop if Is_Unbounded_Type (Type_Spec (Member)) then Get_Discriminants (Member, L, False, True); end if; Member := Next_Entity (Member); end loop; end; when K_String | K_Wide_String => if Struct then Get_Name_String (IDL_Name (Identifier (First_Entity (Declarators (N))))); elsif Ret then Set_Str_To_Name_Buffer ("Returns"); else Get_Name_String (IDL_Name (Identifier (Declarator (N)))); end if; Add_Str_To_Name_Buffer ("_Size"); M := Make_Defining_Identifier (Name_Find); M := Make_Component_Declaration (M, RE (RE_Natural), Make_Attribute_Reference (RE (RE_Natural), A_First)); Append_To (L, M); when K_Sequence_Type => if Present (Max_Size (Rewinded_Type)) then return; end if; if Struct then Get_Name_String (IDL_Name (Identifier (First_Entity (Declarators (N))))); elsif Ret then Set_Str_To_Name_Buffer ("Returns"); else Get_Name_String (IDL_Name (Identifier (Declarator (N)))); end if; Add_Str_To_Name_Buffer ("_Size"); M := Make_Defining_Identifier (Name_Find); Append_To (L, Make_Component_Declaration (M, RE (RE_Unsigned_Long_10))); when others => null; end case; end Get_Discriminants; end Package_Spec; end Backend.BE_CORBA_Ada.Aligned; polyorb-2.8~20110207.orig/compilers/iac/backend-be_corba_ada-helpers_internals.adb0000644000175000017500000046650211750740337027273 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- BACKEND.BE_CORBA_ADA.HELPERS_INTERNALS -- -- -- -- B o d y -- -- -- -- Copyright (C) 2006-2009, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with Namet; use Namet; with Platform; use Platform; with Values; use Values; with Frontend.Nodes; use Frontend.Nodes; with Frontend.Nutils; with Backend.BE_CORBA_Ada.Nodes; use Backend.BE_CORBA_Ada.Nodes; with Backend.BE_CORBA_Ada.Nutils; use Backend.BE_CORBA_Ada.Nutils; with Backend.BE_CORBA_Ada.IDL_To_Ada; use Backend.BE_CORBA_Ada.IDL_To_Ada; with Backend.BE_CORBA_Ada.Runtime; use Backend.BE_CORBA_Ada.Runtime; package body Backend.BE_CORBA_Ada.Helpers_Internals is package FEN renames Frontend.Nodes; package FEU renames Frontend.Nutils; package BEN renames Backend.BE_CORBA_Ada.Nodes; ------------------ -- Package_Spec -- ------------------ package body Package_Spec is procedure Visit_Enumeration_Type (E : Node_Id); procedure Visit_Forward_Interface_Declaration (E : Node_Id); procedure Visit_Interface_Declaration (E : Node_Id); procedure Visit_Module (E : Node_Id); procedure Visit_Specification (E : Node_Id); procedure Visit_Structure_Type (E : Node_Id); procedure Visit_Type_Declaration (E : Node_Id); procedure Visit_Union_Type (E : Node_Id); procedure Visit_Exception_Declaration (E : Node_Id); function Initialize_Spec (E : Node_Id) return Node_Id; -- Return the spec of the Initialize procedure that builds the -- TypeCode corresponding to the IDL type E. -- The routines below build the type declarations necessary for -- the ``Shadow Any Tree''. function From_Any_Container_Spec (E : Node_Id) return Node_Id; -- Return the additional `From_Any' function spec corresponding -- to the enumeration type `E'. The purpose of this is to -- factorize code between the implementation of the classical -- `From_Any' function of the enumeration types and for the -- unions having an enumeration switch. function Wrap_Spec (E : Node_Id) return Node_Id; -- Build the spec of the Wrap function corresponding to IDL -- type E. function Element_Wrap_Spec (E : Node_Id) return Node_Id; -- Builds the spec of the Element_Wrap function corresponding -- to the type spec of the sequence type E. function Pointer_Declaration (E : Node_Id) return Node_Id; -- Makes a pointer type declaration corresponding to the mapped -- Ada type of the IDL type E. function Content_Declaration (E : Node_Id) return Node_Id; -- Makes a record type declaration correponding to the -- Aggregate container for IDL type E. function Clone_Spec (E : Node_Id) return Node_Id; function Finalize_Value_Spec (E : Node_Id) return Node_Id; function Get_Aggregate_Count_Spec (E : Node_Id) return Node_Id; function Set_Aggregate_Count_Spec (E : Node_Id) return Node_Id; function Get_Aggregate_Element_Spec (E : Node_Id) return Node_Id; function Set_Aggregate_Element_Spec (E : Node_Id) return Node_Id; function Unchecked_Get_V_Spec (E : Node_Id) return Node_Id; -- Specs for the routines that manipulate the aggregate -- container. function Lengths_Constant_Declaration (E : Node_Id) return Node_Id; -- Makes a constant declaration containing the length of the -- several dimensions of an array. procedure Aggregate_Container_Routines (E : Node_Id); -- Used for code factorization. This procedure assumes that the -- current package spec has been properly set. --------------------- -- Initialize_Spec -- --------------------- function Initialize_Spec (E : Node_Id) return Node_Id is N : Node_Id; Spg_Name : Name_Id; begin -- Build the defining identifier for the initialization -- subprogram. case FEN.Kind (E) is when K_Complex_Declarator => Spg_Name := Add_Suffix_To_Name ("_Array", To_Ada_Name (FEN.IDL_Name (Identifier (E)))); when K_Fixed_Point_Type => Spg_Name := BEN.Name (Defining_Identifier (Type_Def_Node (BE_Node (E)))); when K_Sequence_Type | K_String_Type | K_Wide_String_Type => Spg_Name := BEN.Name (Defining_Identifier (Instantiation_Node (BE_Node (E)))); when others => Spg_Name := To_Ada_Name (FEN.IDL_Name (Identifier (E))); end case; -- Add the prefix to the initialization subprogram -- identifier. Spg_Name := Add_Prefix_To_Name ("Initialize_", Spg_Name); -- Make the parameterless subprogram spec N := Make_Subprogram_Specification (Make_Defining_Identifier (Spg_Name), No_List); return N; end Initialize_Spec; ----------------------------- -- From_Any_Container_Spec -- ----------------------------- function From_Any_Container_Spec (E : Node_Id) return Node_Id is pragma Assert (FEN.Kind (E) = K_Enumeration_Type); Profile : constant List_Id := New_List; Parameter : Node_Id; N : Node_Id; begin Parameter := Make_Parameter_Specification (Make_Defining_Identifier (PN (P_C)), Make_Attribute_Reference (RE (RE_Any_Container), A_Class)); Append_To (Profile, Parameter); N := Make_Subprogram_Specification (Make_Defining_Identifier (SN (S_From_Any)), Profile, Get_Type_Definition_Node (E)); return N; end From_Any_Container_Spec; --------------- -- Wrap_Spec -- --------------- function Wrap_Spec (E : Node_Id) return Node_Id is Profile : constant List_Id := New_List; Returns : constant Node_Id := Make_Attribute_Reference (RE (RE_Content), A_Class); N : Node_Id; P_Type : Node_Id; begin -- Get the mapped Ada type corresponding to the IDL entity E case FEN.Kind (E) is when K_String_Type | K_Wide_String_Type | K_Fixed_Point_Type | K_Sequence_Type | K_Enumeration_Type | K_Complex_Declarator | K_Simple_Declarator | K_Union_Type | K_Structure_Type => P_Type := Get_Type_Definition_Node (E); when others => declare Msg : constant String := "Cannot generate Wrap spec for a " & FEN.Node_Kind'Image (FEN.Kind (E)); begin raise Program_Error with Msg; end; end case; -- Build the parameters list N := Make_Parameter_Specification (Defining_Identifier => Make_Defining_Identifier (PN (P_X)), Subtype_Mark => Make_Access_Type_Definition (P_Type), Parameter_Mode => Mode_In); Append_To (Profile, N); -- Create the subprogram spec N := Make_Subprogram_Specification (Defining_Identifier => Make_Defining_Identifier (SN (S_Wrap)), Parameter_Profile => Profile, Return_Type => Returns); return N; end Wrap_Spec; ----------------------- -- Element_Wrap_Spec -- ----------------------- function Element_Wrap_Spec (E : Node_Id) return Node_Id is pragma Assert (FEN.Kind (E) = K_Sequence_Type); Profile : constant List_Id := New_List; Returns : constant Node_Id := Make_Attribute_Reference (RE (RE_Content), A_Class); T : constant Node_Id := Type_Spec (E); P_Type : constant Node_Id := Get_Type_Definition_Node (T); N : Node_Id; begin -- Build the parameters list N := Make_Parameter_Specification (Defining_Identifier => Make_Defining_Identifier (PN (P_X)), Subtype_Mark => Make_Access_Type_Definition (P_Type), Parameter_Mode => Mode_In); Append_To (Profile, N); -- Create the subprogram spec N := Make_Subprogram_Specification (Defining_Identifier => Map_Wrap_Element_Identifier (E), Parameter_Profile => Profile, Return_Type => Returns); return N; end Element_Wrap_Spec; ------------------------- -- Pointer_Declaration -- ------------------------- function Pointer_Declaration (E : Node_Id) return Node_Id is Ptr_Type_Name : constant Name_Id := Map_Pointer_Type_Name (E); N : Node_Id; begin N := Make_Full_Type_Declaration (Defining_Identifier => Make_Defining_Identifier (Ptr_Type_Name), Type_Definition => Make_Access_Type_Definition (Subtype_Indication => Get_Type_Definition_Node (E), Is_All => True)); return N; end Pointer_Declaration; ------------------------- -- Content_Declaration -- ------------------------- function Content_Declaration (E : Node_Id) return Node_Id is N : Node_Id; Components : constant List_Id := New_List; begin -- If E is a complex declarator for a multidimensional array, -- declare indices type holding Dim - 1 stored indices. if FEN.Kind (E) = K_Complex_Declarator and then FEU.Is_Multidimensional_Array (E) then declare Dim : constant Natural := FEU.Length (Array_Sizes (E)); begin N := Make_Full_Type_Declaration (Defining_Identifier => Make_Defining_Identifier (Map_Indices_Name (E)), Type_Definition => Make_Array_Type_Definition (Range_Constraints => New_List (Make_Range_Constraint (Make_Literal (Int1_Val), Make_Literal (New_Integer_Value (Unsigned_Long_Long (Dim - 1), 1, 10)))), Component_Definition => RE (RE_Integer))); Append_To (Visible_Part (Current_Package), N); end; end if; -- The container record declaration -- Building the component list of the container depending on -- the kind f 'E'. -- All the containers contain a component 'V' which is a -- pointer to the Ada type mapped from the IDL type 'E'. N := Make_Component_Declaration (Defining_Identifier => Make_Defining_Identifier (CN (C_V)), Subtype_Indication => Make_Identifier (Map_Pointer_Type_Name (E))); Append_To (Components, N); case FEN.Kind (E) is when K_Enumeration_Type => -- For enumeration type, we add an alised field -- corresponding to an unsigned long variable. N := Make_Component_Declaration (Defining_Identifier => Make_Defining_Identifier (CN (C_Repr_Cache)), Subtype_Indication => RE (RE_Unsigned_Long_1), Aliased_Present => True); Append_To (Components, N); when K_Complex_Declarator => -- If the array type is multidimensional, then we add -- some extra fileds. if FEU.Is_Multidimensional_Array (E) then -- The Dimen field N := Make_Component_Declaration (Defining_Identifier => Make_Defining_Identifier (CN (C_Dimen)), Subtype_Indication => RE (RE_Positive)); Append_To (Components, N); -- The Indices field N := Make_Component_Declaration (Defining_Identifier => Make_Defining_Identifier (CN (C_Indices)), Subtype_Indication => Make_Identifier (Map_Indices_Name (E))); Append_To (Components, N); end if; when K_Union_Type => -- For unions, we add an aliased field that -- corresponds to the union switch. N := Make_Component_Declaration (Defining_Identifier => Make_Defining_Identifier (CN (C_Switch_Cache)), Subtype_Indication => Map_Expanded_Name (Switch_Type_Spec (E)), Aliased_Present => True); Append_To (Components, N); when others => null; end case; N := Make_Full_Type_Declaration (Defining_Identifier => Make_Defining_Identifier (Map_Container_Name (E)), Type_Definition => Make_Derived_Type_Definition (Subtype_Indication => RE (RE_Aggregate_Content), Record_Extension_Part => Make_Record_Type_Definition (Make_Record_Definition (Components)))); return N; end Content_Declaration; ---------------- -- Clone_Spec -- ---------------- function Clone_Spec (E : Node_Id) return Node_Id is Profile : constant List_Id := New_List; Returns : constant Node_Id := RE (RE_Content_Ptr); N : Node_Id; begin -- Build the parameters list N := Make_Parameter_Specification (Defining_Identifier => Make_Defining_Identifier (PN (P_ACC)), Subtype_Mark => Make_Identifier (Map_Container_Name (E)), Parameter_Mode => Mode_In); Append_To (Profile, N); N := Make_Parameter_Specification (Defining_Identifier => Make_Defining_Identifier (PN (P_Into)), Subtype_Mark => RE (RE_Content_Ptr), Parameter_Mode => Mode_In, Expression => Make_Null_Statement); Append_To (Profile, N); -- Create the subprogram spec N := Make_Subprogram_Specification (Defining_Identifier => Make_Defining_Identifier (SN (S_Clone)), Parameter_Profile => Profile, Return_Type => Returns); return N; end Clone_Spec; ------------------------- -- Finalize_Value_Spec -- ------------------------- function Finalize_Value_Spec (E : Node_Id) return Node_Id is Profile : constant List_Id := New_List; Returns : constant Node_Id := No_Node; N : Node_Id; begin -- Build the parameters list N := Make_Parameter_Specification (Defining_Identifier => Make_Defining_Identifier (PN (P_ACC)), Subtype_Mark => Make_Identifier (Map_Container_Name (E)), Parameter_Mode => Mode_Inout); Append_To (Profile, N); -- Create the subprogram spec N := Make_Subprogram_Specification (Defining_Identifier => Make_Defining_Identifier (SN (S_Finalize_Value)), Parameter_Profile => Profile, Return_Type => Returns); return N; end Finalize_Value_Spec; ------------------------------ -- Get_Aggregate_Count_Spec -- ------------------------------ function Get_Aggregate_Count_Spec (E : Node_Id) return Node_Id is Profile : constant List_Id := New_List; Returns : constant Node_Id := RE (RE_Unsigned_Long_1); N : Node_Id; begin -- Build the parameters list N := Make_Parameter_Specification (Defining_Identifier => Make_Defining_Identifier (PN (P_ACC)), Subtype_Mark => Make_Identifier (Map_Container_Name (E)), Parameter_Mode => Mode_In); Append_To (Profile, N); -- Create the subprogram spec N := Make_Subprogram_Specification (Defining_Identifier => Make_Defining_Identifier (SN (S_Get_Aggregate_Count)), Parameter_Profile => Profile, Return_Type => Returns); return N; end Get_Aggregate_Count_Spec; ------------------------------ -- Set_Aggregate_Count_Spec -- ------------------------------ function Set_Aggregate_Count_Spec (E : Node_Id) return Node_Id is Profile : constant List_Id := New_List; Returns : constant Node_Id := No_Node; N : Node_Id; begin -- Build the parameters list N := Make_Parameter_Specification (Defining_Identifier => Make_Defining_Identifier (PN (P_ACC)), Subtype_Mark => Make_Identifier (Map_Container_Name (E)), Parameter_Mode => Mode_Inout); Append_To (Profile, N); N := Make_Parameter_Specification (Defining_Identifier => Make_Defining_Identifier (PN (P_Count)), Subtype_Mark => RE (RE_Unsigned_Long_1), Parameter_Mode => Mode_In); Append_To (Profile, N); -- Create the subprogram spec N := Make_Subprogram_Specification (Defining_Identifier => Make_Defining_Identifier (SN (S_Set_Aggregate_Count)), Parameter_Profile => Profile, Return_Type => Returns); return N; end Set_Aggregate_Count_Spec; -------------------------------- -- Get_Aggregate_Element_Spec -- -------------------------------- function Get_Aggregate_Element_Spec (E : Node_Id) return Node_Id is Profile : constant List_Id := New_List; Returns : constant Node_Id := Make_Attribute_Reference (RE (RE_Content), A_Class); N : Node_Id; begin -- Build the parameters list N := Make_Parameter_Specification (Defining_Identifier => Make_Defining_Identifier (PN (P_ACC)), Subtype_Mark => Make_Access_Type_Definition (Make_Identifier (Map_Container_Name (E)), Is_Not_Null => True), Parameter_Mode => Mode_In); Append_To (Profile, N); N := Make_Parameter_Specification (Defining_Identifier => Make_Defining_Identifier (PN (P_TC)), Subtype_Mark => RE (RE_Object_Ptr_2), Parameter_Mode => Mode_In); Append_To (Profile, N); N := Make_Parameter_Specification (Defining_Identifier => Make_Defining_Identifier (PN (P_Index)), Subtype_Mark => RE (RE_Unsigned_Long_1), Parameter_Mode => Mode_In); Append_To (Profile, N); N := Make_Parameter_Specification (Defining_Identifier => Make_Defining_Identifier (PN (P_Mech)), Subtype_Mark => Make_Access_Type_Definition (RE (RE_Mechanism), Is_Not_Null => True), Parameter_Mode => Mode_In); Append_To (Profile, N); -- Create the subprogram spec N := Make_Subprogram_Specification (Defining_Identifier => Make_Defining_Identifier (SN (S_Get_Aggregate_Element)), Parameter_Profile => Profile, Return_Type => Returns); return N; end Get_Aggregate_Element_Spec; -------------------------------- -- Set_Aggregate_Element_Spec -- -------------------------------- function Set_Aggregate_Element_Spec (E : Node_Id) return Node_Id is Profile : constant List_Id := New_List; Returns : constant Node_Id := No_Node; N : Node_Id; begin -- Build the parameters list N := Make_Parameter_Specification (Defining_Identifier => Make_Defining_Identifier (PN (P_ACC)), Subtype_Mark => Make_Identifier (Map_Container_Name (E)), Parameter_Mode => Mode_Inout); Append_To (Profile, N); N := Make_Parameter_Specification (Defining_Identifier => Make_Defining_Identifier (PN (P_TC)), Subtype_Mark => RE (RE_Object_Ptr_2), Parameter_Mode => Mode_In); Append_To (Profile, N); N := Make_Parameter_Specification (Defining_Identifier => Make_Defining_Identifier (PN (P_Index)), Subtype_Mark => RE (RE_Unsigned_Long_1), Parameter_Mode => Mode_In); Append_To (Profile, N); N := Make_Parameter_Specification (Defining_Identifier => Make_Defining_Identifier (PN (P_From_C)), Subtype_Mark => Make_Attribute_Reference (RE (RE_Any_Container), A_Class), Parameter_Mode => Mode_Inout); Append_To (Profile, N); -- Create the subprogram spec N := Make_Subprogram_Specification (Defining_Identifier => Make_Defining_Identifier (SN (S_Set_Aggregate_Element)), Parameter_Profile => Profile, Return_Type => Returns); return N; end Set_Aggregate_Element_Spec; -------------------------- -- Unchecked_Get_V_Spec -- -------------------------- function Unchecked_Get_V_Spec (E : Node_Id) return Node_Id is Profile : constant List_Id := New_List; N : Node_Id; begin -- Build the parameters list N := Make_Parameter_Specification (Defining_Identifier => Make_Defining_Identifier (PN (P_ACC)), Subtype_Mark => Make_Access_Type_Definition (Subtype_Indication => Make_Identifier (Map_Container_Name (E)), Is_Not_Null => True), Parameter_Mode => Mode_In); Append_To (Profile, N); -- Create the subprogram spec N := Make_Subprogram_Specification (Defining_Identifier => Make_Defining_Identifier (SN (S_Unchecked_Get_V)), Parameter_Profile => Profile, Return_Type => RE (RE_Address)); return N; end Unchecked_Get_V_Spec; ---------------------------------- -- Lengths_Constant_Declaration -- ---------------------------------- function Lengths_Constant_Declaration (E : Node_Id) return Node_Id is pragma Assert (FEN.Kind (E) = K_Complex_Declarator); Elements : constant List_Id := New_List; Dims : Unsigned_Long_Long := 1; N : Node_Id; S : Node_Id; V : Value_Type; begin -- For each dimension, we build an element association : -- Dimension_Index => Dimension_Size S := First_Entity (Array_Sizes (E)); loop V := FEU.Expr_Value (S); N := Make_Element_Association (Index => Make_Literal (New_Integer_Value (Dims, 1, 10)), Expression => Make_Literal (New_Value (V))); Append_To (Elements, N); S := Next_Entity (S); exit when No (S); Dims := Dims + 1; end loop; -- Define the array type N := Make_Array_Type_Definition (Range_Constraints => New_List (Make_Range_Constraint (Make_Literal (Int1_Val), Make_Literal (New_Integer_Value (Dims, 1, 10)))), Component_Definition => RE (RE_Unsigned_Long_1)); N := Make_Object_Declaration (Defining_Identifier => Make_Defining_Identifier (Map_Lengths_Name (E)), Constant_Present => True, Object_Definition => N, Expression => Make_Array_Aggregate (Elements)); return N; end Lengths_Constant_Declaration; ---------------------------------- -- Aggregate_Container_Routines -- ---------------------------------- procedure Aggregate_Container_Routines (E : Node_Id) is N : Node_Id; begin -- The Pointer declaration N := Pointer_Declaration (E); Bind_FE_To_BE (Identifier (E), N, B_Pointer_Type); Append_To (Visible_Part (Current_Package), N); -- The container N := Content_Declaration (E); Bind_FE_To_BE (Identifier (E), N, B_Aggr_Container); Append_To (Visible_Part (Current_Package), N); -- Override the abstract subprograms N := Get_Aggregate_Element_Spec (E); Bind_FE_To_BE (Identifier (E), N, B_Get_Aggregate_Element); Append_To (Visible_Part (Current_Package), N); -- For complex declarator and structure types, we don't -- override the Set_Aggregate_Element procedure if FEN.Kind (E) /= K_Complex_Declarator and then FEN.Kind (E) /= K_Structure_Type then N := Set_Aggregate_Element_Spec (E); Bind_FE_To_BE (Identifier (E), N, B_Set_Aggregate_Element); Append_To (Visible_Part (Current_Package), N); end if; N := Get_Aggregate_Count_Spec (E); Bind_FE_To_BE (Identifier (E), N, B_Get_Aggregate_Count); Append_To (Visible_Part (Current_Package), N); N := Set_Aggregate_Count_Spec (E); Bind_FE_To_BE (Identifier (E), N, B_Set_Aggregate_Count); Append_To (Visible_Part (Current_Package), N); N := Unchecked_Get_V_Spec (E); Bind_FE_To_BE (Identifier (E), N, B_Unchecked_Get_V); Append_To (Visible_Part (Current_Package), N); N := Clone_Spec (E); Bind_FE_To_BE (Identifier (E), N, B_Clone); Append_To (Visible_Part (Current_Package), N); N := Finalize_Value_Spec (E); Bind_FE_To_BE (Identifier (E), N, B_Finalize_Value); Append_To (Visible_Part (Current_Package), N); -- For complex declarators, we declare an additional -- constant. if FEN.Kind (E) = K_Complex_Declarator then N := Lengths_Constant_Declaration (E); Append_To (Visible_Part (Current_Package), N); end if; end Aggregate_Container_Routines; ----------- -- Visit -- ----------- procedure Visit (E : Node_Id) is begin case FEN.Kind (E) is when K_Enumeration_Type => Visit_Enumeration_Type (E); when K_Forward_Interface_Declaration => Visit_Forward_Interface_Declaration (E); when K_Interface_Declaration => Visit_Interface_Declaration (E); when K_Module => Visit_Module (E); when K_Specification => Visit_Specification (E); when K_Structure_Type => Visit_Structure_Type (E); when K_Type_Declaration => Visit_Type_Declaration (E); when K_Union_Type => Visit_Union_Type (E); when K_Exception_Declaration => Visit_Exception_Declaration (E); when others => null; end case; end Visit; ---------------------------- -- Visit_Enumeration_Type -- ---------------------------- procedure Visit_Enumeration_Type (E : Node_Id) is N : Node_Id; begin Set_Internals_Spec; -- The enumeration types are a special case. They require an -- additional `From_Any' function that converts containers -- to a value from the enumeration type. N := From_Any_Container_Spec (E); Append_To (Visible_Part (Current_Package), N); Bind_FE_To_BE (Identifier (E), N, B_From_Any_Container); -- The aggregate container routines Aggregate_Container_Routines (E); -- The wrap function spec N := Wrap_Spec (E); Bind_FE_To_BE (Identifier (E), N, B_Wrap); Append_To (Visible_Part (Current_Package), N); -- The initialize procedure N := Initialize_Spec (E); Bind_FE_To_BE (Identifier (E), N, B_Initialize); Append_To (Visible_Part (Current_Package), N); end Visit_Enumeration_Type; ----------------------------------------- -- Visit_Forward_Interface_Declaration -- ----------------------------------------- procedure Visit_Forward_Interface_Declaration (E : Node_Id) is N : Node_Id; begin Set_Internals_Spec; N := Initialize_Spec (E); Bind_FE_To_BE (Identifier (E), N, B_Initialize); Append_To (Visible_Part (Current_Package), N); end Visit_Forward_Interface_Declaration; --------------------------------- -- Visit_Interface_Declaration -- --------------------------------- procedure Visit_Interface_Declaration (E : Node_Id) is N : Node_Id; begin N := BEN.Parent (Type_Def_Node (BE_Node (Identifier (E)))); Push_Entity (BEN.IDL_Unit (Package_Declaration (N))); Set_Internals_Spec; N := Initialize_Spec (E); Bind_FE_To_BE (Identifier (E), N, B_Initialize); Append_To (Visible_Part (Current_Package), N); N := First_Entity (Interface_Body (E)); while Present (N) loop Visit (N); N := Next_Entity (N); end loop; Pop_Entity; end Visit_Interface_Declaration; ------------------ -- Visit_Module -- ------------------ procedure Visit_Module (E : Node_Id) is D : Node_Id; begin if not Map_Particular_CORBA_Parts (E, PK_Helper_Internals_Spec) then Push_Entity (Stub_Node (BE_Node (Identifier (E)))); D := First_Entity (Definitions (E)); while Present (D) loop Visit (D); D := Next_Entity (D); end loop; Pop_Entity; end if; end Visit_Module; ------------------------- -- Visit_Specification -- ------------------------- procedure Visit_Specification (E : Node_Id) is D : Node_Id; begin Push_Entity (Stub_Node (BE_Node (Identifier (E)))); D := First_Entity (Definitions (E)); while Present (D) loop Visit (D); D := Next_Entity (D); end loop; Pop_Entity; end Visit_Specification; -------------------------- -- Visit_Structure_Type -- -------------------------- procedure Visit_Structure_Type (E : Node_Id) is N : Node_Id; begin Set_Internals_Spec; -- The aggregate container routines Aggregate_Container_Routines (E); -- The wrap function spec N := Wrap_Spec (E); Bind_FE_To_BE (Identifier (E), N, B_Wrap); Append_To (Visible_Part (Current_Package), N); -- The initialize procedure N := Initialize_Spec (E); Bind_FE_To_BE (Identifier (E), N, B_Initialize); Append_To (Visible_Part (Current_Package), N); end Visit_Structure_Type; ---------------------------- -- Visit_Type_Declaration -- ---------------------------- procedure Visit_Type_Declaration (E : Node_Id) is N : Node_Id; D : Node_Id; T : constant Node_Id := Type_Spec (E); begin Set_Internals_Spec; -- Extra code generation for fixed point types, sequence -- types and bounded [wide] string types. case FEN.Kind (T) is when K_Fixed_Point_Type => declare Package_Node : Node_Id; Fixed_Type_Node : Node_Id; begin -- We instantiate the generic helper package here -- because we need it in the Wrap function body. Package_Node := Make_Defining_Identifier (Map_Fixed_Type_Helper_Name (T)); Fixed_Type_Node := Expand_Designator (Type_Def_Node (BE_Node (T))); N := Make_Package_Instantiation (Defining_Identifier => Package_Node, Generic_Package => RU (RU_CORBA_Fixed_Point), Parameter_List => New_List (Fixed_Type_Node)); Append_To (Visible_Part (Current_Package), N); -- The Initialize Spec N := Initialize_Spec (T); Bind_FE_To_BE (T, N, B_Initialize); Append_To (Visible_Part (Current_Package), N); -- The wrap function spec N := Wrap_Spec (T); Bind_FE_To_BE (T, N, B_Wrap); Append_To (Visible_Part (Current_Package), N); end; when K_Sequence_Type => declare S : Node_Id; Package_Node : Node_Id; Elt_From_Any : Node_Id; Elt_To_Any : Node_Id; Elt_Wrap : Node_Id; Profile : constant List_Id := New_List; begin -- Do not generate anything if the sequence element -- type has a local interface component. if not FEU.Has_Local_Component (T) then -- The element wrap function N := Element_Wrap_Spec (T); Bind_FE_To_BE (T, N, B_Element_Wrap); Append_To (Visible_Part (Current_Package), N); -- The wrap function spec N := Wrap_Spec (T); Bind_FE_To_BE (T, N, B_Wrap); Append_To (Visible_Part (Current_Package), N); -- We instantiate the generic helper package here -- because we need it in the initialization routine S := Expand_Designator (Instantiation_Node (BE_Node (T))); Package_Node := Make_Defining_Identifier (Map_Sequence_Pkg_Helper_Name (T)); -- Get the the From_any, the To_Any and the Wrap -- functions nodes corresponding to the elements -- of the sequence. Elt_From_Any := Get_From_Any_Node (Type_Spec (T)); Elt_To_Any := Get_To_Any_Node (Type_Spec (T)); Elt_Wrap := Expand_Designator (Element_Wrap_Node (BE_Node (T))); Append_To (Profile, Make_Parameter_Association (Make_Defining_Identifier (PN (P_Element_From_Any)), Elt_From_Any)); Append_To (Profile, Make_Parameter_Association (Make_Defining_Identifier (PN (P_Element_To_Any)), Elt_To_Any)); Append_To (Profile, Make_Parameter_Association (Make_Defining_Identifier (PN (P_Element_Wrap)), Elt_Wrap)); if Present (Max_Size (T)) then N := RE (RE_CORBA_Helper_1); else N := RE (RE_CORBA_Helper_2); end if; -- Change the parent of the generic package N := Make_Selected_Component (S, Selector_Name (N)); N := Make_Package_Instantiation (Defining_Identifier => Package_Node, Generic_Package => N, Parameter_List => Profile); Append_To (Visible_Part (Current_Package), N); end if; N := Initialize_Spec (T); Bind_FE_To_BE (T, N, B_Initialize); Append_To (Visible_Part (Current_Package), N); end; when K_String_Type | K_Wide_String_Type => -- The Initialize Spec N := Initialize_Spec (T); Bind_FE_To_BE (T, N, B_Initialize); Append_To (Visible_Part (Current_Package), N); -- The wrap function spec N := Wrap_Spec (T); Bind_FE_To_BE (T, N, B_Wrap); Append_To (Visible_Part (Current_Package), N); when others => null; end case; -- General case D := First_Entity (Declarators (E)); while Present (D) loop if FEN.Kind (D) = K_Complex_Declarator then -- The aggregate container routines Aggregate_Container_Routines (D); end if; -- We do not generate the `Wrap' spec if the defined type is: -- 1 - derived from an object type -- 2 - a fixed point type -- 3 - a bounded string type -- 4 - a sequence type if not (((FEN.Kind (T) = K_Scoped_Name or else FEN.Kind (T) = K_Object) and then FEN.Kind (D) = K_Simple_Declarator) or else FEN.Kind (T) = K_String_Type or else FEN.Kind (T) = K_Wide_String_Type or else FEN.Kind (T) = K_Fixed_Point_Type or else FEN.Kind (T) = K_Sequence_Type) then -- The wrap function spec N := Wrap_Spec (D); Bind_FE_To_BE (Identifier (D), N, B_Wrap); Append_To (Visible_Part (Current_Package), N); else -- Bind the wrap function created for the type -- specifier to the declarator. If we handle a -- sequence type, verifies that the wrap function has -- been created before performing the binding. if FEN.Kind (T) /= K_Sequence_Type or else not FEU.Has_Local_Component (T) then N := Get_Wrap_Node (T, False); Bind_FE_To_BE (Identifier (D), N, B_Wrap); end if; end if; -- The initialize procedure N := Initialize_Spec (D); Bind_FE_To_BE (Identifier (D), N, B_Initialize); Append_To (Visible_Part (Current_Package), N); D := Next_Entity (D); end loop; end Visit_Type_Declaration; ---------------------- -- Visit_Union_Type -- ---------------------- procedure Visit_Union_Type (E : Node_Id) is N : Node_Id; begin Set_Internals_Spec; -- The aggregate container routines Aggregate_Container_Routines (E); -- The wrap function spec N := Wrap_Spec (E); Bind_FE_To_BE (Identifier (E), N, B_Wrap); Append_To (Visible_Part (Current_Package), N); -- The initialize procedure N := Initialize_Spec (E); Bind_FE_To_BE (Identifier (E), N, B_Initialize); Append_To (Visible_Part (Current_Package), N); end Visit_Union_Type; --------------------------------- -- Visit_Exception_Declaration -- --------------------------------- procedure Visit_Exception_Declaration (E : Node_Id) is N : Node_Id; begin Set_Internals_Spec; N := Initialize_Spec (E); Bind_FE_To_BE (Identifier (E), N, B_Initialize); Append_To (Visible_Part (Current_Package), N); end Visit_Exception_Declaration; end Package_Spec; ------------------ -- Package_Body -- ------------------ package body Package_Body is procedure Visit_Enumeration_Type (E : Node_Id); procedure Visit_Forward_Interface_Declaration (E : Node_Id); procedure Visit_Interface_Declaration (E : Node_Id); procedure Visit_Module (E : Node_Id); procedure Visit_Specification (E : Node_Id); procedure Visit_Structure_Type (E : Node_Id); procedure Visit_Type_Declaration (E : Node_Id); procedure Visit_Union_Type (E : Node_Id); procedure Visit_Exception_Declaration (E : Node_Id); function Make_Indexed_Component (Typ : Node_Id; Prefix : Node_Id; Indices_Array : Node_Id; Last_Index : Node_Id) return Node_Id; -- Build an indexed component for a prefix of type -- Typ, an N-dimension array, of the form: -- PREFIX (INDICES (1), ..., INDICES (N-1), LAST_INDEX) function Make_Unchecked_Conversion_Instantiation (Name : Name_Id; Source, Target : Node_Id) return Node_Id; -- Generate an instanciation of Ada.Unchecked_Conversion as Nam for the -- Source and Target Ada types. function Raise_Excp_From_Any_Spec (Raise_Node : Node_Id) return Node_Id; -- The spec is located in the body because this function is not -- used outside the helper package. However the spec is -- necessary because of the pragma No_Return. function Raise_Excp_From_Any_Body (E : Node_Id; Raise_Node : Node_Id) return Node_Id; function Initialized_Identifier (E : Node_Id) return Node_Id; -- Return a defining identifier designing the boolean flag that -- controls the IDL type E. function Initialized_Flag_Declaration (E : Node_Id) return Node_Id; -- Declares a Boolean flag useful for the initialization of a -- TypeCode corresponding to the IDL type E. function Initialize_Body (E : Node_Id) return Node_Id; -- Returns the body of the Initialize procedure that builds the -- TypeCode corresponding to the IDL type E. procedure Initialize_Routine (E : Node_Id; Declaration_List : List_Id; Statements : List_Id); -- Fills the lists Declaration_List and Statements with the -- routines initializing the IDL type E. function From_Any_Container_Body (E : Node_Id) return Node_Id; -- Return the additional `From_Any' function body corresponding -- to the enumeration type `E'. procedure Handle_Dependency (N : Node_Id; Statements : List_Id); -- This procedure handles the dependency on the TypeCode -- corresponding to the node N. If the node N is a CORBA type, -- it adds the necessary dependency to the Helper -- initialization. If the node N belongs to the current IDL -- specification, it calls the Initialize_XXX function that -- build its TypeCode. function Wrap_Body (E : Node_Id) return Node_Id; -- Builds the body of the Wrap function corresponding to IDL -- type E. function Element_Wrap_Body (E : Node_Id) return Node_Id; -- Builds the body of the Element_Wrap function corresponding -- to the type spec of the sequence type E. function Clone_Body (E : Node_Id) return Node_Id; function Finalize_Value_Body (E : Node_Id) return Node_Id; function Get_Aggregate_Count_Body (E : Node_Id) return Node_Id; function Set_Aggregate_Count_Body (E : Node_Id) return Node_Id; function Get_Aggregate_Element_Body (E : Node_Id) return Node_Id; function Set_Aggregate_Element_Body (E : Node_Id) return Node_Id; function Unchecked_Get_V_Body (E : Node_Id) return Node_Id; -- Bodies for the routines that manipulate the aggregate -- container. procedure Aggregate_Container_Routines (E : Node_Id); -- Used for code factorization. This procedure assumes that the -- current package body has been properly set. ---------------------------- -- Make_Indexed_Component -- ---------------------------- function Make_Indexed_Component (Typ : Node_Id; Prefix : Node_Id; Indices_Array : Node_Id; Last_Index : Node_Id) return Node_Id is Dimen : constant Integer := FEU.Length (FEN.Array_Sizes (Typ)); Indices : constant List_Id := New_List; begin for J in 1 .. Dimen - 1 loop Append_To (Indices, Make_Indexed_Component ( Prefix => Copy_Node (Indices_Array), Expressions => New_List ( Make_Literal ( New_Integer_Value (Unsigned_Long_Long (J), 1, 10))))); end loop; Append_To (Indices, Last_Index); return Make_Indexed_Component ( Prefix => Prefix, Expressions => Indices); end Make_Indexed_Component; --------------------------------------------- -- Make_Unchecked_Conversion_Instantiation -- --------------------------------------------- function Make_Unchecked_Conversion_Instantiation (Name : Name_Id; Source, Target : Node_Id) return Node_Id is N : Node_Id; begin N := Make_Instantiated_Subprogram (RU (RU_Ada_Unchecked_Conversion), New_List (Source, Target)); return Make_Subprogram_Specification (Defining_Identifier => Make_Defining_Identifier (Name), Parameter_Profile => No_List, Return_Type => RE (RE_Address), Instantiated_Subprogram => N); end Make_Unchecked_Conversion_Instantiation; --------------- -- Wrap_Body -- --------------- function Wrap_Body (E : Node_Id) return Node_Id is function Copy_Subprogram_Spec (S : Node_Id) return Node_Id; -- In some cases, the body of the Wrap spec simply renames -- another subprogram. We cannot set the 'Renamed_Entity' -- field of the original spec. We use this function to make -- a copy of the spec -------------------------- -- Copy_Subprogram_Spec -- -------------------------- function Copy_Subprogram_Spec (S : Node_Id) return Node_Id is pragma Assert (BEN.Kind (S) = K_Subprogram_Specification); begin return Make_Subprogram_Specification (Defining_Identifier (S), Parameter_Profile (S), Return_Type (S), Parent (S)); end Copy_Subprogram_Spec; Spec : Node_Id; N : Node_Id; begin case FEN.Kind (E) is when K_String_Type | K_Wide_String_Type => -- For bounded string types, we simply rename the Wrap -- function of the instantiated generic package. Spec := Copy_Subprogram_Spec (Wrap_Node (BE_Node (E))); N := Make_Selected_Component (Expand_Designator (Instantiation_Node (BE_Node (E))), Make_Identifier (SN (S_Wrap))); Set_Renamed_Entity (Spec, N); N := Spec; when K_Enumeration_Type | K_Complex_Declarator | K_Union_Type | K_Structure_Type => declare Statements : constant List_Id := New_List; Aggr_List : constant List_Id := New_List; begin Spec := Wrap_Node (BE_Node (Identifier (E))); -- The first component N := Make_Type_Conversion (Subtype_Mark => Make_Identifier (Map_Pointer_Type_Name (E)), Expression => Make_Identifier (PN (P_X))); N := Make_Component_Association (Make_Defining_Identifier (CN (C_V)), N); Append_To (Aggr_List, N); -- Inner case statement to add the record aggregate -- depending on the IDL node kind case FEN.Kind (E) is when K_Enumeration_Type => -- The Repr_Cache field N := Make_Component_Association (Make_Defining_Identifier (CN (C_Repr_Cache)), Make_Literal (Int0_Val)); Append_To (Aggr_List, N); when K_Complex_Declarator => if FEU.Is_Multidimensional_Array (E) then -- The Dimen switch ( =1 if the array is -- multidimensional) N := Make_Component_Association (Make_Defining_Identifier (CN (C_Dimen)), Make_Literal (Int1_Val)); Append_To (Aggr_List, N); -- The Indices switch N := Make_Element_Association (No_Node, Make_Literal (Int0_Val)); N := Make_Array_Aggregate (New_List (N)); N := Make_Component_Association (Make_Defining_Identifier (CN (C_Indices)), N); Append_To (Aggr_List, N); end if; when K_Union_Type => -- The Switch_Cache field N := Make_Component_Association (Make_Defining_Identifier (CN (C_Switch_Cache)), Make_Selected_Component (PN (P_X), CN (C_Switch))); Append_To (Aggr_List, N); when K_Structure_Type => null; when others => declare Msg : constant String := "Cannor generate Wrap body for a " & FEN.Node_Kind 'Image (FEN.Kind (E)); begin raise Program_Error with Msg; end; end case; N := Make_Record_Aggregate (Aggr_List, RE (RE_Aggregate_Content)); N := Make_Qualified_Expression (Make_Identifier (Map_Container_Name (E)), N); N := Make_Return_Statement (N); Append_To (Statements, N); N := Make_Subprogram_Body (Spec, No_List, Statements); end; when K_Simple_Declarator => declare O : constant Node_Id := Type_Spec (Declaration (E)); Statements : constant List_Id := New_List; begin Spec := Wrap_Node (BE_Node (Identifier (E))); -- We simply call the wrap function of the -- redefined type N := Make_Type_Conversion (Map_Expanded_Name (O), Make_Explicit_Dereference (Make_Identifier (PN (P_X)))); N := Make_Attribute_Reference (N, A_Unrestricted_Access); N := Make_Subprogram_Call (Get_Wrap_Node (O), New_List (N)); N := Make_Return_Statement (N); Append_To (Statements, N); N := Make_Subprogram_Body (Spec, No_List, Statements); end; when K_Fixed_Point_Type => -- For fixed point types, we simply rename the Wrap -- function of the instantiated helper generic -- package. Spec := Copy_Subprogram_Spec (Wrap_Node (BE_Node (E))); N := Make_Selected_Component (Make_Identifier (Map_Fixed_Type_Helper_Name (E)), Make_Identifier (SN (S_Wrap))); Set_Renamed_Entity (Spec, N); N := Spec; when K_Sequence_Type => -- For sequence types, we simply rename the Wrap -- function of the instantiated helper generic -- package. Spec := Copy_Subprogram_Spec (Wrap_Node (BE_Node (E))); N := Make_Selected_Component (Make_Identifier (Map_Sequence_Pkg_Helper_Name (E)), Make_Identifier (SN (S_Wrap))); Set_Renamed_Entity (Spec, N); N := Spec; when others => raise Program_Error; end case; return N; end Wrap_Body; ----------------------- -- Element_Wrap_Body -- ----------------------- function Element_Wrap_Body (E : Node_Id) return Node_Id is pragma Assert (FEN.Kind (E) = K_Sequence_Type); Spec : constant Node_Id := Element_Wrap_Node (BE_Node (E)); Statements : constant List_Id := New_List; O : constant Node_Id := FEU.Get_Original_Type_Declarator (Type_Spec (E)); -- The original type of the sequence type spec W : constant Node_Id := Get_Wrap_Node (O); N : Node_Id; begin N := Make_Explicit_Dereference (Make_Identifier (PN (P_X))); -- If the type spec of the sequence is a user defined type, -- we have to cast it to the original type. Cast_When_Necessary (N, Type_Spec (E), O, True); -- Get an 'Unrestricted_Access to the parameter N := Make_Attribute_Reference (N, A_Unrestricted_Access); -- Call the original type `Wrap' N := Make_Subprogram_Call (W, New_List (N)); N := Make_Return_Statement (N); Append_To (Statements, N); -- Make the body N := Make_Subprogram_Body (Spec, No_List, Statements); return N; end Element_Wrap_Body; ---------------- -- Clone_Body -- ---------------- function Clone_Body (E : Node_Id) return Node_Id is Spec : constant Node_Id := Clone_Node (BE_Node (Identifier (E))); Dcl_Part : constant List_Id := New_List; Statements : constant List_Id := New_List; N : Node_Id; Expr : Node_Id; Converted : Node_Id; begin -- Common declarative part N := Make_Used_Type (RE (RE_Content_Ptr)); Append_To (Dcl_Part, N); N := Make_Object_Declaration (Defining_Identifier => Make_Defining_Identifier (PN (P_Target)), Object_Definition => RE (RE_Content_Ptr)); Append_To (Dcl_Part, N); -- Common statements -- IF statement declare Then_Statements : constant List_Id := New_List; Else_Statements : constant List_Id := New_List; Condition : Node_Id; begin -- Inner IF statement Condition := Make_Expression (Make_Explicit_Dereference (Make_Identifier (PN (P_Into))), Op_Not_In, Make_Identifier (Map_Container_Name (E))); N := Make_If_Statement (Condition => Condition, Then_Statements => New_List (Make_Return_Statement (Make_Null_Statement))); Append_To (Then_Statements, N); N := Make_Assignment_Statement (Make_Defining_Identifier (PN (P_Target)), Make_Defining_Identifier (PN (P_Into))); Append_To (Then_Statements, N); -- Build a designator to 'ACC.V.all' Expr := Make_Explicit_Dereference (Make_Selected_Component (PN (P_ACC), CN (C_V))); -- Build the type conversion Content_Ü_ -- (Target.all) Converted := Make_Type_Conversion (Make_Identifier (Map_Container_Name (E)), Make_Explicit_Dereference (Make_Identifier (PN (P_Target)))); N := Make_Assignment_Statement (Make_Explicit_Dereference (Make_Selected_Component (Converted, Make_Identifier (CN (C_V)))), Expr); Append_To (Then_Statements, N); -- Else statement N := Make_Assignment_Statement (Make_Defining_Identifier (PN (P_Target)), Make_Object_Instantiation (Make_Identifier (Map_Container_Name (E)))); Append_To (Else_Statements, N); -- For discriminated types (mapped from IDL unions), the -- cloned copy has to be allocated with the proper -- discriminent constraints. This construct is also valid -- for non-discriminated types. N := Make_Qualified_Expression (Subtype_Mark => Expand_Designator (Type_Def_Node (BE_Node (Identifier (E)))), Operand => Expr); Expr := Make_Object_Instantiation (N); N := Make_Assignment_Statement (Make_Selected_Component (Converted, Make_Identifier (CN (C_V))), Expr); Append_To (Else_Statements, N); Condition := Make_Expression (Make_Identifier (PN (P_Into)), Op_Not_Equal, Make_Null_Statement); N := Make_If_Statement (Condition => Condition, Then_Statements => Then_Statements, Else_Statements => Else_Statements); Append_To (Statements, N); end; -- Specific part case FEN.Kind (E) is when K_Enumeration_Type => -- Assign the remaining record fields N := Make_Selected_Component (Converted, Make_Identifier (CN (C_Repr_Cache))); N := Make_Assignment_Statement (N, Make_Selected_Component (PN (P_ACC), CN (C_Repr_Cache))); Append_To (Statements, N); when K_Union_Type => -- Suppress discriminant checks N := Make_Pragma (Pragma_Suppress, New_List (RE (RE_Discriminant_Check))); Append_To (Dcl_Part, N); -- Assign the remaining record fields N := Make_Selected_Component (Converted, Make_Identifier (CN (C_Switch_Cache))); N := Make_Assignment_Statement (N, Make_Selected_Component (PN (P_ACC), CN (C_Switch_Cache))); Append_To (Statements, N); when K_Complex_Declarator => if FEU.Is_Multidimensional_Array (E) then -- Assign the remaining record fields N := Make_Selected_Component (Converted, Make_Identifier (CN (C_Dimen))); N := Make_Assignment_Statement (N, Make_Selected_Component (PN (P_ACC), CN (C_Dimen))); Append_To (Statements, N); N := Make_Selected_Component (Converted, Make_Identifier (CN (C_Indices))); N := Make_Assignment_Statement (N, Make_Selected_Component (PN (P_ACC), CN (C_Indices))); Append_To (Statements, N); end if; when others => null; end case; -- The return statement N := Make_Return_Statement (Make_Identifier (PN (P_Target))); Append_To (Statements, N); N := Make_Subprogram_Body (Spec, Dcl_Part, Statements); return N; end Clone_Body; ------------------------- -- Finalize_Value_Body -- ------------------------- function Finalize_Value_Body (E : Node_Id) return Node_Id is Spec : constant Node_Id := Finalize_Value_Node (BE_Node (Identifier (E))); Dcl_Part : constant List_Id := New_List; Statements : constant List_Id := New_List; N : Node_Id; begin -- The deallocation procedure declaration N := Make_Instantiated_Subprogram (RU (RU_Ada_Unchecked_Deallocation), New_List (Expand_Designator (Type_Def_Node (BE_Node (Identifier (E)))), Make_Identifier (Map_Pointer_Type_Name (E)))); N := Make_Subprogram_Specification (Defining_Identifier => Make_Defining_Identifier (SN (S_Free)), Parameter_Profile => No_List, Instantiated_Subprogram => N); Append_To (Dcl_Part, N); -- The deallocation procedure call N := Make_Subprogram_Call (Make_Identifier (SN (S_Free)), New_List (Make_Selected_Component (PN (P_ACC), CN (C_V)))); Append_To (Statements, N); N := Make_Subprogram_Body (Spec, Dcl_Part, Statements); return N; end Finalize_Value_Body; ------------------------------ -- Get_Aggregate_Count_Body -- ------------------------------ function Get_Aggregate_Count_Body (E : Node_Id) return Node_Id is Spec : constant Node_Id := Get_Aggregate_Count_Node (BE_Node (Identifier (E))); Dcl_Part : constant List_Id := New_List; Statements : constant List_Id := New_List; N : Node_Id; Returns : Node_Id; ACC_Referenced : Boolean := False; begin -- Prepare return expression case FEN.Kind (E) is when K_Enumeration_Type => -- Enumeration types have only one aggregate Returns := Make_Literal (Int1_Val); when K_Union_Type => declare Literal_Parent : Node_Id := No_Node; Switch_Alternatives : constant List_Id := New_List; Switch_Case : Node_Id; Switch_Item : Node_Id; Choices : List_Id; Orig_Type : constant Node_Id := FEU.Get_Original_Type_Specifier (Switch_Type_Spec (E)); Has_Default : Boolean := False; begin if FEN.Kind (Orig_Type) = K_Enumeration_Type then Literal_Parent := Map_Expanded_Name (Scope_Entity (Identifier (Orig_Type))); end if; Switch_Case := First_Entity (Switch_Type_Body (E)); while Present (Switch_Case) loop Map_Choice_List (Labels (Switch_Case), Literal_Parent, Choices, Has_Default); N := Make_Return_Statement (Make_Literal (Int2_Val)); Append_To (Switch_Alternatives, Make_Case_Statement_Alternative (Choices, New_List (N))); Switch_Case := Next_Entity (Switch_Case); end loop; if Has_Default then -- Member with default label is present: there is always -- a data mamber. Returns := Make_Literal (Int2_Val); else -- Add WHEN OTHERS clause in case some values are not -- covered. Append_To (Switch_Alternatives, Make_Case_Statement_Alternative (No_List, New_List (Make_Return_Statement (Make_Literal (Int1_Val))))); -- Build case statement N := Make_Selected_Component (PN (P_ACC), CN (C_V)); Switch_Item := Make_Selected_Component (N, Make_Identifier (CN (C_Switch))); Append_To (Statements, Make_Case_Statement (Switch_Item, Switch_Alternatives)); ACC_Referenced := True; Returns := No_Node; end if; end; when K_Structure_Type => declare Member_Count : Unsigned_Long_Long := 0; Member : Node_Id; D : Node_Id; begin -- Count declarators Member := First_Entity (Members (E)); while Present (Member) loop D := First_Entity (Declarators (Member)); while Present (D) loop Member_Count := Member_Count + 1; D := Next_Entity (D); end loop; Member := Next_Entity (Member); end loop; Returns := Make_Literal (New_Integer_Value (Member_Count, 1, 10)); end; when K_Complex_Declarator => declare Dim : constant Natural := FEU.Length (Array_Sizes (E)); begin if Dim = 1 then Returns := Make_Subprogram_Call (Make_Identifier (Map_Lengths_Name (E)), New_List (Make_Literal (Int1_Val))); else Returns := Make_Subprogram_Call (Make_Identifier (Map_Lengths_Name (E)), New_List (Make_Selected_Component (PN (P_ACC), CN (C_Dimen)))); ACC_Referenced := True; end if; end; when others => raise Program_Error; end case; -- The ACC formal parameter is used only in case of multi-dimensional -- arrays and unions without a default label. if not ACC_Referenced then N := Make_Pragma (Pragma_Unreferenced, New_List (Make_Identifier (PN (P_ACC)))); Append_To (Dcl_Part, N); end if; -- The return statement if Present (Returns) then N := Make_Return_Statement (Returns); Append_To (Statements, N); end if; N := Make_Subprogram_Body (Spec, Dcl_Part, Statements); return N; end Get_Aggregate_Count_Body; ------------------------------ -- Set_Aggregate_Count_Body -- ------------------------------ function Set_Aggregate_Count_Body (E : Node_Id) return Node_Id is Spec : constant Node_Id := Set_Aggregate_Count_Node (BE_Node (Identifier (E))); Dcl_Part : constant List_Id := New_List; Statements : constant List_Id := New_List; begin -- Shadow aggregate contents do not have user-changeable length: -- either they have a fixed size, or in the case of unions, a -- variable size that is controlled by the discriminant value. Append_To (Statements, Make_Null_Statement); return Make_Subprogram_Body (Spec, Dcl_Part, Statements); end Set_Aggregate_Count_Body; -------------------------------- -- Get_Aggregate_Element_Body -- -------------------------------- function Get_Aggregate_Element_Body (E : Node_Id) return Node_Id is Spec : constant Node_Id := Get_Aggregate_Element_Node (BE_Node (Identifier (E))); Dcl_Part : constant List_Id := New_List; Statements : constant List_Id := New_List; Unref_Params : constant List_Id := New_List; N : Node_Id; begin N := Make_Used_Type (RE (RE_Unsigned_Long_1)); Append_To (Dcl_Part, N); N := Make_Used_Type (RE (RE_Mechanism)); Append_To (Dcl_Part, N); -- ACC.V might be uninitialized and have an invalid -- representation (case of Get_Aggregate_Element being -- called from within an unmarshall routine), in which case -- we know that we will overwrite the invalid value without -- using it; we must disable validity checks here so that we -- do not fail a runtime check on the bogus value. N := Make_Pragma (Pragma_Suppress, New_List (RE (RE_Id'Value ("RE_" & Platform.Validity_Check_Name)))); Append_To (Dcl_Part, N); -- The TypeCode formal is of no use here (we always -- statically know the type of each aggregate element). Append_To (Unref_Params, Make_Identifier (PN (P_TC))); -- IDL node kind dependant part case FEN.Kind (E) is when K_Enumeration_Type => begin -- An enum always has exactly one element, so we -- can ignore the provided index. Append_To (Unref_Params, Make_Identifier (PN (P_Index))); -- Statements -- Setting the position of the enumerator N := Make_Assignment_Statement (Make_Selected_Component (PN (P_ACC), CN (C_Repr_Cache)), Make_Subprogram_Call (Make_Attribute_Reference (Expand_Designator (Type_Def_Node (BE_Node (Identifier (E)))), A_Pos), New_List (Make_Explicit_Dereference (Make_Selected_Component (PN (P_ACC), CN (C_V)))))); Append_To (Statements, N); -- Setting the Mechanism N := Make_Assignment_Statement (Make_Explicit_Dereference (Make_Identifier (PN (P_Mech))), RE (RE_By_Value)); Append_To (Statements, N); -- Return value N := Make_Return_Statement (Make_Subprogram_Call (RE (RE_Wrap_1), New_List (Make_Attribute_Reference (Make_Selected_Component (PN (P_ACC), CN (C_Repr_Cache)), A_Unrestricted_Access)))); Append_To (Statements, N); end; when K_Complex_Declarator => declare Element : Node_Id; Orig_Type : Node_Id; T : Node_Id; Wrap_Node : Node_Id; begin -- Setting the Mechanism N := Make_Assignment_Statement (Make_Explicit_Dereference (Make_Identifier (PN (P_Mech))), RE (RE_By_Reference)); Append_To (Statements, N); -- Generated code depends on the nature of the -- array (one dimension or multidimensional). if FEU.Is_Multidimensional_Array (E) then declare If_Sts : constant List_Id := New_List; Else_Sts : constant List_Id := New_List; Dimension : constant Unsigned_Long_Long := Unsigned_Long_Long (FEU.Length (FEN.Array_Sizes (E))); Condition : Node_Id; Dcl_Part : constant List_Id := New_List; Sts_Part : constant List_Id := New_List; begin -- Build the IF statement condition Condition := Make_Expression (Make_Selected_Component (PN (P_ACC), CN (C_Dimen)), Op_Less, Make_Literal (New_Integer_Value (Dimension, 1, 10))); -- The IF statement block -- Declarative part N := Make_Object_Declaration (Defining_Identifier => Make_Defining_Identifier (PN (P_R_ACC)), Object_Definition => Expand_Designator (Aggr_Container_Node (BE_Node (Identifier (E)))), Expression => Make_Explicit_Dereference (Make_Identifier (PN (P_ACC)))); Append_To (Dcl_Part, N); -- Statements N := Make_Selected_Component (PN (P_R_ACC), CN (C_Dimen)); N := Make_Subprogram_Call (Make_Selected_Component (PN (P_R_ACC), CN (C_Indices)), New_List (N)); N := Make_Assignment_Statement (N, Make_Type_Conversion (RE (RE_Integer), Make_Identifier (PN (P_Index)))); Append_To (Sts_Part, N); N := Make_Selected_Component (PN (P_R_ACC), CN (C_Dimen)); N := Make_Expression (N, Op_Plus, Make_Literal (Int1_Val)); N := Make_Assignment_Statement (Make_Selected_Component (PN (P_R_ACC), CN (C_Dimen)), N); Append_To (Sts_Part, N); N := Make_Return_Statement (Make_Identifier (PN (P_R_ACC))); Append_To (Sts_Part, N); -- Building the block statement and appending -- it to the IF statements. N := Make_Block_Statement (Declarative_Part => Dcl_Part, Statements => Sts_Part); Append_To (If_Sts, N); -- ELSE statement -- Selecting the array element N := Make_Indexed_Component ( Typ => E, Prefix => Make_Selected_Component (PN (P_ACC), CN (C_V)), Indices_Array => Make_Selected_Component (PN (P_ACC), CN (C_Indices)), Last_Index => Make_Type_Conversion (RE (RE_Integer), Make_Identifier (PN (P_Index)))); -- Get the original type of the array element T := Type_Spec (Declaration (E)); Orig_Type := FEU.Get_Original_Type_Declarator (T); -- Get the Wrap node of the original element -- type. Wrap_Node := Get_Wrap_Node (Orig_Type); -- Cast the array element when necessary Cast_When_Necessary (N, T, Orig_Type, True); -- Call the Wrap of the array element N := Make_Subprogram_Call (Wrap_Node, New_List (Make_Attribute_Reference (N, A_Unrestricted_Access))); N := Make_Return_Statement (N); Append_To (Else_Sts, N); -- Build the IF statement N := Make_If_Statement (Condition, If_Sts, No_List, Else_Sts); Append_To (Statements, N); end; else -- Accessing the wanted element Element := Make_Subprogram_Call (Make_Selected_Component (PN (P_ACC), CN (C_V)), New_List (Make_Type_Conversion (RE (RE_Integer), Make_Identifier (PN (P_Index))))); -- Get the original type of the array element T := Type_Spec (Declaration (E)); Orig_Type := FEU.Get_Original_Type_Declarator (T); -- Get the Wrap node of the original element -- type. Wrap_Node := Get_Wrap_Node (Orig_Type); -- Cast the array element when necessary Cast_When_Necessary (Element, T, Orig_Type, True); -- Return value N := Make_Return_Statement (Make_Subprogram_Call (Wrap_Node, New_List (Make_Attribute_Reference (Element, A_Unrestricted_Access)))); Append_To (Statements, N); end if; end; when K_Union_Type => declare If_Sts : constant List_Id := New_List; Else_Sts : constant List_Id := New_List; Condition : Node_Id; Switch_Item : Node_Id; Component_Node : Node_Id; Switch_Alternative : Node_Id; Switch_Case : Node_Id; Switch_Alternatives : List_Id; Has_Default : Boolean := False; Choices : List_Id; Wrap_Node : Node_Id; Literal_Parent : Node_Id := No_Node; Orig_Type : constant Node_Id := FEU.Get_Original_Type_Specifier (Switch_Type_Spec (E)); O : Node_Id; T : Node_Id; begin -- Index = 0: discriminant Condition := Make_Expression (Make_Identifier (PN (P_Index)), Op_Equal, Make_Literal (Int0_Val)); -- Setting the Mechanism. -- Discriminant must be managed by value, because changing -- the discriminant value requires a complete record -- aggregate assignment. We provide a distinct component as -- we do not want the current discriminant to be altered -- in place. N := Make_Assignment_Statement (Make_Explicit_Dereference (Make_Identifier (PN (P_Mech))), RE (RE_By_Value)); Append_To (If_Sts, N); -- Switch cache value N := Make_Selected_Component (Make_Selected_Component (PN (P_ACC), CN (C_V)), Make_Identifier (CN (C_Switch))); N := Make_Assignment_Statement (Make_Selected_Component (PN (P_ACC), CN (C_Switch_Cache)), N); Append_To (If_Sts, N); -- Get the Original type of the union switch O := FEU.Get_Original_Type_Declarator (Switch_Type_Spec (E)); -- Get the Wrap fonction corresponding to the -- switch original type. Wrap_Node := Get_Wrap_Node (O); N := Make_Selected_Component (PN (P_ACC), CN (C_Switch_Cache)); -- Cast N if the switch type is an alias type Cast_When_Necessary (N, Switch_Type_Spec (E), O, True); -- Return statement N := Make_Subprogram_Call (Wrap_Node, New_List (Make_Attribute_Reference (N, A_Unrestricted_Access))); N := Make_Return_Statement (N); Append_To (If_Sts, N); -- Index = 1: union member -- The Assert Pragma N := Make_Expression (Make_Identifier (PN (P_Index)), Op_Equal, Make_Literal (Int1_Val)); N := Make_Pragma (Pragma_Assert, New_List (N)); Append_To (Else_Sts, N); -- Setting the Mechanism N := Make_Assignment_Statement (Make_Explicit_Dereference (Make_Identifier (PN (P_Mech))), RE (RE_By_Reference)); Append_To (Else_Sts, N); -- For each component of the union, we call its -- corresponding wrap function. N := Make_Selected_Component (PN (P_ACC), CN (C_V)); Switch_Item := Make_Selected_Component (N, Make_Identifier (CN (C_Switch))); if FEN.Kind (Orig_Type) = K_Enumeration_Type then Literal_Parent := Map_Expanded_Name (Scope_Entity (Identifier (Orig_Type))); end if; Switch_Alternatives := New_List; Switch_Case := First_Entity (Switch_Type_Body (E)); while Present (Switch_Case) loop Map_Choice_List (Labels (Switch_Case), Literal_Parent, Choices, Has_Default); -- Get the type spec of the element T := Type_Spec (Element (Switch_Case)); -- Get the original type declarator of T O := FEU.Get_Original_Type_Declarator (T); -- Get the Wrap fonction corresponding to the -- component original type. Wrap_Node := Get_Wrap_Node (O); -- Get the full name of the component N := Make_Selected_Component (PN (P_ACC), CN (C_V)); Component_Node := Make_Selected_Component (N, Make_Identifier (To_Ada_Name (FEN.IDL_Name (Identifier (Declarator (Element (Switch_Case))))))); -- Cast the component when necessary Cast_When_Necessary (Component_Node, T, O, True); -- Call the Wrap function N := Make_Attribute_Reference (Component_Node, A_Unrestricted_Access); N := Make_Subprogram_Call (Wrap_Node, New_List (N)); -- Return the result N := Make_Return_Statement (N); -- Build the case alternative Switch_Alternative := Make_Case_Statement_Alternative (Choices, New_List (N)); Append_To (Switch_Alternatives, Switch_Alternative); Switch_Case := Next_Entity (Switch_Case); end loop; -- Add an empty when others clause to keep the compiler -- happy. if not Has_Default then Append_To (Switch_Alternatives, Make_Case_Statement_Alternative (No_List, No_List)); end if; -- Build the case statement N := Make_Case_Statement (Switch_Item, Switch_Alternatives); Append_To (Else_Sts, N); -- Build the IF statement N := Make_If_Statement (Condition, If_Sts, No_List, Else_Sts); Append_To (Statements, N); end; when K_Structure_Type => declare Component_Node : Node_Id; Switch_Alternatives : List_Id; Switch_Alternative : Node_Id; Switch_Item : Node_Id; Choices : List_Id; Member : Node_Id; Declarator : Node_Id; Wrap_Node : Node_Id; Count : Unsigned_Long_Long := 0; Orig_Type : Node_Id; T : Node_Id; begin -- Setting the Mechanism N := Make_Assignment_Statement (Make_Explicit_Dereference (Make_Identifier (PN (P_Mech))), RE (RE_By_Reference)); Append_To (Statements, N); Switch_Item := Make_Identifier (PN (P_Index)); -- For each element, we build a case alternative -- that calls the wrap function of the element. Switch_Alternatives := New_List; Member := First_Entity (Members (E)); while Present (Member) loop Declarator := First_Entity (Declarators (Member)); while Present (Declarator) loop -- Create the unique switch choice Choices := New_List (Make_Literal (New_Integer_Value (Count, 1, 10))); -- Get the Wrap fonction corresponding to the -- component type. T := Type_Spec (Declaration (Declarator)); -- Get the original declarator of T Orig_Type := FEU.Get_Original_Type_Declarator (T); Wrap_Node := Get_Wrap_Node (Orig_Type); -- Get the full name of the component N := Make_Selected_Component (PN (P_ACC), CN (C_V)); Component_Node := Make_Selected_Component (N, Make_Identifier (To_Ada_Name (FEN.IDL_Name (Identifier (Declarator))))); -- Cast the component node when necessary Cast_When_Necessary (Component_Node, T, Orig_Type, True); -- Call the Wrap function N := Make_Attribute_Reference (Component_Node, A_Unrestricted_Access); N := Make_Subprogram_Call (Wrap_Node, New_List (N)); -- Return the result N := Make_Return_Statement (N); -- Build the case alternative Switch_Alternative := Make_Case_Statement_Alternative (Choices, New_List (N)); Append_To (Switch_Alternatives, Switch_Alternative); -- Update the counter of the structure fields Count := Count + 1; Declarator := Next_Entity (Declarator); end loop; Member := Next_Entity (Member); end loop; -- Raise an error if the member index does not match N := Make_Raise_Statement (Make_Identifier (EN (E_Constraint_Error))); Append_To (Switch_Alternatives, Make_Case_Statement_Alternative (No_List, New_List (N))); -- Build the switch case N := Make_Case_Statement (Switch_Item, Switch_Alternatives); Append_To (Statements, N); end; when others => declare Msg : constant String := "Cannot generate Get_aggregate_Element for a " & FEN.Node_Kind'Image (FEN.Kind (E)); begin raise Program_Error with Msg; end; end case; -- Adding a pragma Unreferenced statement (if necessary) if not Is_Empty (Unref_Params) then N := Make_Pragma (Pragma_Unreferenced, Unref_Params); Append_To (Dcl_Part, N); end if; N := Make_Subprogram_Body (Spec, Dcl_Part, Statements); return N; end Get_Aggregate_Element_Body; -------------------------------- -- Set_Aggregate_Element_Body -- -------------------------------- function Set_Aggregate_Element_Body (E : Node_Id) return Node_Id is Spec : constant Node_Id := Set_Aggregate_Element_Node (BE_Node (Identifier (E))); Dcl_Part : constant List_Id := New_List; Statements : constant List_Id := New_List; Unref_Params : constant List_Id := New_List; N : Node_Id; begin -- Add a use clause for PolyORB.Types.Unsigned_Long N := Make_Used_Type (RE (RE_Unsigned_Long_1)); Append_To (Dcl_Part, N); -- Generate the rest of the code depending on the node kind. case FEN.Kind (E) is when K_Enumeration_Type => declare Left_Oprand : Node_Id; Right_Operand : Node_Id; begin -- Declarative part -- Add the unreferenced entities Append_To (Unref_Params, Make_Identifier (PN (P_TC))); -- Add a pragma assertion on the Index parameter N := Make_Expression (Make_Identifier (PN (P_Index)), Op_Equal, Make_Literal (Int0_Val)); N := Make_Pragma (Pragma_Assert, New_List (N)); Append_To (Dcl_Part, N); -- Statements -- Left operand of the assignment statement Left_Oprand := Make_Explicit_Dereference (Make_Selected_Component (PN (P_ACC), CN (C_V))); -- Right operand of the assignment statement Right_Operand := Make_Subprogram_Call (RE (RE_From_Any_3), New_List (Make_Identifier (PN (P_From_C)))); Right_Operand := Make_Qualified_Expression (RE (RE_Unsigned_Long_1), Right_Operand); N := Make_Attribute_Reference (Get_Type_Definition_Node (E), A_Val); Right_Operand := Make_Subprogram_Call (N, New_List (Right_Operand)); -- The assignment_statement N := Make_Assignment_Statement (Left_Oprand, Right_Operand); Append_To (Statements, N); end; when K_Union_Type => declare T : constant Node_Id := Switch_Type_Spec (E); O : constant Node_Id := FEU.Get_Original_Type_Specifier (T); begin -- Declarative part -- Add the unreferenced entities Append_To (Unref_Params, Make_Identifier (PN (P_TC))); -- Add a pragma assertion on the Index parameter N := Make_Expression (Make_Identifier (PN (P_Index)), Op_Equal, Make_Literal (Int0_Val)); N := Make_Pragma (Pragma_Assert, New_List (N)); Append_To (Dcl_Part, N); -- Declare the New_Switch constant -- 1 - Get the expression N := Make_Subprogram_Call (Get_From_Any_Container_Node (O), New_List (Make_Identifier (PN (P_From_C)))); -- 2 - Cast the expression when necessary if FEN.Kind (T) = K_Scoped_Name and then FEN.Kind (Reference (T)) = K_Simple_Declarator then N := Make_Qualified_Expression (Get_Type_Definition_Node (O), N); N := Make_Type_Conversion (Get_Type_Definition_Node (T), N); end if; -- 3 - Declare... N := Make_Object_Declaration (Defining_Identifier => Make_Defining_Identifier (PN (P_New_Switch)), Constant_Present => True, Object_Definition => Get_Type_Definition_Node (T), Expression => N); Append_To (Dcl_Part, N); -- Declare the New_Union variable N := Make_Component_Association (Make_Identifier (CN (C_Switch)), Make_Identifier (PN (P_New_Switch))); N := Make_Type_Conversion (Get_Type_Definition_Node (E), N); N := Make_Object_Declaration (Defining_Identifier => Make_Defining_Identifier (PN (P_New_Union)), Object_Definition => N); Append_To (Dcl_Part, N); -- Disable warning on New_Union non-initialization Set_Str_To_Name_Buffer ("Use default initialization"); N := Make_Ada_Comment (Name_Find); Append_To (Dcl_Part, N); N := Make_Pragma (Pragma_Warnings, New_List (RE (RE_Off), Make_Identifier (PN (P_New_Union)))); Append_To (Dcl_Part, N); -- Disable discriminent check N := Make_Pragma (Pragma_Suppress, New_List (RE (RE_Discriminant_Check))); Append_To (Dcl_Part, N); -- Statements -- The assignment statement N := Make_Assignment_Statement (Make_Explicit_Dereference (Make_Selected_Component (PN (P_ACC), CN (C_V))), Make_Identifier (PN (P_New_Union))); Append_To (Statements, N); end; when others => -- FIXME: To be removed once all types are implemented Append_To (Unref_Params, Make_Identifier (PN (P_ACC))); Append_To (Unref_Params, Make_Identifier (PN (P_TC))); Append_To (Unref_Params, Make_Identifier (PN (P_Index))); Append_To (Unref_Params, Make_Identifier (PN (P_From_C))); end case; -- Adding a pragma Unreferenced statement (if necessary) if not Is_Empty (Unref_Params) then N := Make_Pragma (Pragma_Unreferenced, Unref_Params); Append_To (Dcl_Part, N); end if; N := Make_Subprogram_Body (Spec, Dcl_Part, Statements); return N; end Set_Aggregate_Element_Body; -------------------------- -- Unchecked_Get_V_Body -- -------------------------- function Unchecked_Get_V_Body (E : Node_Id) return Node_Id is Spec : constant Node_Id := Unchecked_Get_V_Node (BE_Node (Identifier (E))); Dcl_Part : constant List_Id := New_List; Statements : constant List_Id := New_List; N : Node_Id; begin if FEN.Kind (E) = K_Complex_Declarator and then FEU.Is_Multidimensional_Array (E) then -- I : array (1 .. Ndim - 1) of Integer; N := Make_Object_Declaration (Defining_Identifier => Make_Defining_Identifier (VN (V_Index)), Object_Definition => Make_Identifier (Map_Indices_Name (E))); Append_To (Dcl_Part, N); -- I (1 .. ACC.Dimen - 1) := ACC.Indices (1 .. ACC.Dimen); N := Make_Assignment_Statement (Variable_Identifier => Make_Slice (Prefix => Make_Identifier (VN (V_Index)), Discrete_Range => Make_Range (Low_Bound => Make_Literal (Int1_Val), High_Bound => Make_Expression ( Make_Selected_Component (PN (P_ACC), CN (C_Dimen)), Op_Minus, Make_Literal (Int1_Val)))), Expression => Make_Slice (Prefix => Make_Selected_Component (PN (P_ACC), CN (C_Indices)), Discrete_Range => Make_Range (Low_Bound => Make_Literal (Int1_Val), High_Bound => Make_Expression ( Make_Selected_Component (PN (P_ACC), CN (C_Dimen)), Op_Minus, Make_Literal (Int1_Val))))); Append_To (Statements, N); -- I (ACC.Dimen .. I'Last) := (others => 0); N := Make_Assignment_Statement (Variable_Identifier => Make_Slice (Prefix => Make_Identifier (VN (V_Index)), Discrete_Range => Make_Range ( Low_Bound => Make_Selected_Component ( PN (P_ACC), CN (C_Dimen)), High_Bound => Make_Attribute_Reference ( Make_Identifier ( VN (V_Index)), A_Last))), Expression => Make_Array_Aggregate (New_List (Make_Element_Association (No_Node, Make_Literal (Int0_Val))))); Append_To (Statements, N); -- return ACC.V (I (1), I (2), ..., 0)'Address; N := Make_Return_Statement ( Make_Attribute_Reference ( Prefix => Make_Indexed_Component ( Typ => E, Prefix => Make_Selected_Component (PN (P_ACC), CN (C_V)), Indices_Array => Make_Identifier (VN (V_Index)), Last_Index => Make_Literal (Int0_Val)), Attribute => A_Address)); Append_To (Statements, N); else -- function To_Address is -- new Unchecked_Conversion (Ptr_, System.Address); N := Make_Unchecked_Conversion_Instantiation (Name => SN (S_To_Address), Source => Make_Identifier (Map_Pointer_Type_Name (E)), Target => RE (RE_Address)); Append_To (Dcl_Part, N); -- return To_Address (ACC.V); N := Make_Subprogram_Call (Make_Identifier (SN (S_To_Address)), New_List (Make_Selected_Component (PN (P_ACC), CN (C_V)))); N := Make_Return_Statement (N); Append_To (Statements, N); end if; N := Make_Subprogram_Body (Spec, Dcl_Part, Statements); return N; end Unchecked_Get_V_Body; ---------------------------------- -- Aggregate_Container_Routines -- ---------------------------------- procedure Aggregate_Container_Routines (E : Node_Id) is N : Node_Id; begin -- Bodies of the overridden abstract subprograms N := Get_Aggregate_Element_Body (E); Append_To (Statements (Current_Package), N); -- For complex declarator and structure types, we don't -- override the Set_Aggregate_Element procedure if FEN.Kind (E) /= K_Complex_Declarator and then FEN.Kind (E) /= K_Structure_Type then N := Set_Aggregate_Element_Body (E); Append_To (Statements (Current_Package), N); end if; N := Get_Aggregate_Count_Body (E); Append_To (Statements (Current_Package), N); N := Set_Aggregate_Count_Body (E); Append_To (Statements (Current_Package), N); N := Unchecked_Get_V_Body (E); Append_To (Statements (Current_Package), N); N := Clone_Body (E); Append_To (Statements (Current_Package), N); N := Finalize_Value_Body (E); Append_To (Statements (Current_Package), N); end Aggregate_Container_Routines; ---------------------------- -- Initialized_Identifier -- ---------------------------- function Initialized_Identifier (E : Node_Id) return Node_Id is Flag_Name : Name_Id; begin case FEN.Kind (E) is when K_Fixed_Point_Type => Flag_Name := BEN.Name (Defining_Identifier (Type_Def_Node (BE_Node (E)))); when K_Sequence_Type | K_String_Type | K_Wide_String_Type => Flag_Name := BEN.Name (Defining_Identifier (Instantiation_Node (BE_Node (E)))); when K_Complex_Declarator => Flag_Name := Add_Suffix_To_Name ("_Array", To_Ada_Name (FEN.IDL_Name (Identifier (E)))); when others => Flag_Name := To_Ada_Name (FEN.IDL_Name (Identifier (E))); end case; Flag_Name := Add_Suffix_To_Name ("_Initialized", Flag_Name); return Make_Defining_Identifier (Flag_Name); end Initialized_Identifier; ---------------------------------- -- Initialized_Flag_Declaration -- ---------------------------------- function Initialized_Flag_Declaration (E : Node_Id) return Node_Id is N : Node_Id; begin N := Make_Object_Declaration (Defining_Identifier => Initialized_Identifier (E), Object_Definition => RE (RE_Boolean_2), Expression => RE (RE_False)); return N; end Initialized_Flag_Declaration; --------------------- -- Initialize_Body -- --------------------- function Initialize_Body (E : Node_Id) return Node_Id is N : Node_Id; Spec : Node_Id; Declarative_Part : constant List_Id := New_List; Statements : constant List_Id := New_List; Then_Statements : constant List_Id := New_List; Condition : Node_Id; begin if FEN.Kind (E) = K_Fixed_Point_Type or else FEN.Kind (E) = K_Sequence_Type or else FEN.Kind (E) = K_String_Type or else FEN.Kind (E) = K_Wide_String_Type then Spec := Initialize_Node (BE_Node (E)); else Spec := Initialize_Node (BE_Node (Identifier (E))); end if; -- Declare the boolean flag global variable that indicates -- whether the TypeCode has been initialized or not. There -- is no harm this variable is global, because the -- initialization is done only once at the beginning of the -- application and it is not supposed to be done by more -- than one task. N := Initialized_Flag_Declaration (E); Append_To (BEN.Statements (Current_Package), N); -- Build the IF statement that controls the initialization -- of the TypeCode Condition := Make_Expression (Initialized_Identifier (E), Op_Not); N := Make_Assignment_Statement (Initialized_Identifier (E), RE (RE_True)); Append_To (Then_Statements, N); -- Append the initialization routines Initialize_Routine (E, Declarative_Part, Then_Statements); N := Make_If_Statement (Condition => Condition, Then_Statements => Then_Statements); Append_To (Statements, N); N := Make_Subprogram_Body (Spec, Declarative_Part, Statements); return N; end Initialize_Body; ------------------------ -- Initialize_Routine -- ------------------------ procedure Initialize_Routine (E : Node_Id; Declaration_List : List_Id; Statements : List_Id) is function Add_Parameter (TC_Name : Name_Id; Expr_Node : Node_Id; To_Any : Node_Id := RE (RE_To_Any_0)) return Node_Id; -- Build a call to: -- Add_Parameter (TC_Name, To_Any (Expr_Node)) -- If To_Any is not provided, it defaults to the (overloaded) -- CORBA.To_Any. function Declare_Name (Var_Name : Name_Id; Value : Value_Id) return Node_Id; -- Makes a variable declaration using the given parameters procedure TypeCode_Initialization; -- Initialization for the TypeCode variable declated in the -- Helper spec. ------------------- -- Add_Parameter -- ------------------- function Add_Parameter (TC_Name : Name_Id; Expr_Node : Node_Id; To_Any : Node_Id := RE (RE_To_Any_0)) return Node_Id is N : Node_Id; begin N := Make_Subprogram_Call (To_Any, New_List (Expr_Node)); N := Make_Subprogram_Call (RE (RE_Add_Parameter), New_List (Make_Identifier (TC_Name), N)); return N; end Add_Parameter; ------------------ -- Declare_Name -- ------------------ function Declare_Name (Var_Name : Name_Id; Value : Value_Id) return Node_Id is N : Node_Id; begin N := Make_Object_Declaration (Defining_Identifier => Make_Defining_Identifier (Var_Name), Constant_Present => True, Object_Definition => RE (RE_String_0), Expression => Make_Subprogram_Call (RE (RE_To_CORBA_String), New_List (Make_Literal (Value)))); return N; end Declare_Name; ----------------------------- -- TypeCode_Initialization -- ----------------------------- procedure TypeCode_Initialization is Expr : Node_Id; N : Node_Id; begin case FEN.Kind (E) is when K_Enumeration_Type => Expr := Make_Subprogram_Call (RE (RE_To_CORBA_Object), New_List (RE (RE_TC_Enum))); when K_Forward_Interface_Declaration | K_Interface_Declaration => Expr := Make_Subprogram_Call (RE (RE_To_CORBA_Object), New_List (RE (RE_TC_Object_1))); when K_Fixed_Point_Type => Expr := Make_Subprogram_Call (RE (RE_To_CORBA_Object), New_List (RE (RE_TC_Fixed))); when K_Complex_Declarator => Expr := Make_Subprogram_Call (RE (RE_To_CORBA_Object), New_List (RE (RE_TC_Array))); when K_Structure_Type => Expr := Make_Subprogram_Call (RE (RE_To_CORBA_Object), New_List (RE (RE_TC_Struct))); when K_Union_Type => Expr := Make_Subprogram_Call (RE (RE_To_CORBA_Object), New_List (RE (RE_TC_Union))); when K_Exception_Declaration => Expr := Make_Subprogram_Call (RE (RE_To_CORBA_Object), New_List (RE (RE_TC_Except))); when K_Simple_Declarator => -- Ensure the original type specifier if E is -- initilized before building the current TypeCode. Handle_Dependency (Type_Spec (Declaration (E)), Statements); Expr := Make_Subprogram_Call (RE (RE_Build_Alias_TC), New_List (Make_Parameter_Association (Make_Defining_Identifier (PN (P_Name)), Make_Defining_Identifier (VN (V_Name))), Make_Parameter_Association (Make_Defining_Identifier (PN (P_Id)), Make_Defining_Identifier (VN (V_Id))), Make_Parameter_Association (Make_Defining_Identifier (PN (P_Parent)), Get_TC_Node (Type_Spec (Declaration (E)))))); when K_Sequence_Type => declare Max_Size_Literal : Node_Id; TC_Element : Node_Id; begin -- Ensure the element type specifier is -- initilized before building the current -- TypeCode. Handle_Dependency (Type_Spec (E), Statements); -- Unbounded sequences are identified by a maximum -- length of 0. if Present (Max_Size (E)) then Max_Size_Literal := Make_Literal (FEU.Expr_Value (Max_Size (E))); else Max_Size_Literal := Make_Literal (New_Integer_Value (0, 1, 10)); end if; TC_Element := Get_TC_Node (Type_Spec (E)); Expr := Make_Subprogram_Call (RE (RE_Build_Sequence_TC), New_List (TC_Element, Max_Size_Literal)); end; when K_String_Type | K_Wide_String_Type => declare Build_Spg : Node_Id; begin if FEN.Kind (E) = K_String_Type then Build_Spg := RE (RE_Build_String_TC); else Build_Spg := RE (RE_Build_Wstring_TC); end if; Expr := Make_Subprogram_Call (Build_Spg, New_List (Make_Literal (FEU.Expr_Value (Max_Size (E))))); end; when others => raise Program_Error with "Cannot initialize TypeCode for frontend node " & FEN.Node_Kind'Image (FEN.Kind (E)); end case; N := Make_Assignment_Statement (Get_TC_Node (T => E, Resolve_Forward => False), Expr); Append_To (Statements, N); end TypeCode_Initialization; -- Local variables Stub : Node_Id; N : Node_Id; Entity_TC_Name : Name_Id; Entity_Name_V : Value_Id; Entity_Rep_Id_V : Value_Id; Param1 : Node_Id; Param2 : Node_Id; Helper_Package : constant Node_Id := Parent (Package_Declaration (Current_Package)); Dependencies : constant List_Id := Get_GList (Helper_Package, GL_Dependencies); -- Start of processing for Initialize_Routine begin -- Initialize the TypeCode variable TypeCode_Initialization; -- Extract from polyorb-any.ads concerning the Encoding of -- TypeCodes: -- 9. For string and wide_string, the only parameter will -- be the length of the string. Its value will be 0 for -- unbounded strings or wide strings. -- 10. For sequence and array, the first parameter will -- be the length of the sequence or the array and the second -- the content type. As for strings, an unbounded sequence will -- have a length of 0. -- 11. For fixed, the first parameter will be the digits -- number and the second the scale. -- So, we don't need the definitions below : if FEN.Kind (E) /= K_Complex_Declarator and then FEN.Kind (E) /= K_Sequence_Type and then FEN.Kind (E) /= K_Fixed_Point_Type and then FEN.Kind (E) /= K_String_Type and then FEN.Kind (E) /= K_Wide_String_Type then -- For the forward interfaces, we use the name and the -- Rep_Id of the forwarded interface. The Repository_Id -- is declared just after the type definition if FEN.Kind (E) = K_Forward_Interface_Declaration then Stub := Type_Def_Node (BE_Node (Identifier (Forward (E)))); else Stub := Type_Def_Node (BE_Node (Identifier (E))); end if; Entity_Rep_Id_V := Get_Value (BEN.Expression (Next_Node (Stub))); end if; Entity_TC_Name := Get_Name (Get_Base_Identifier (Get_TC_Node (E, False))); case FEN.Kind (E) is when K_Interface_Declaration | K_Forward_Interface_Declaration => Stub := Package_Declaration (BEN.Parent (Stub)); when K_Complex_Declarator => declare V : Value_Type; TC : Node_Id; TC_Dim : Node_Id := No_Node; TC_Previous_Name : Name_Id := No_Name; TC_Name : Name_Id := No_Name; Sizes : constant List_Id := Range_Constraints (Type_Definition (Type_Def_Node (BE_Node (Identifier (E))))); Sizes_Reverse : constant List_Id := New_List; Constraint : Node_Id; Dimension : constant Natural := Length (Sizes); From_N : Node_Id := No_Node; To_N : Node_Id := No_Node; T : Node_Id; begin if Dimension > 1 then -- Multi-dimension array -- First of all, we create a new list which -- contains the elements of the list Sizes. All -- manipulations on this list will not affect -- the Sizes list because we create new nodes. From_N := First_Node (Sizes); while Present (From_N) loop To_N := Make_Range_Constraint (First (From_N), Last (From_N)); Append_To (Sizes_Reverse, To_N); From_N := Next_Node (From_N); end loop; -- The TC_Dimension_X variables used here are -- the ones declared in the Helper spec TC := TC_Node (BE_Node (Identifier (E))); Constraint := Last_Node (Sizes_Reverse); for Index in 1 .. Dimension - 1 loop TC_Dim := Next_N_Node (TC, Dimension - Index); TC_Previous_Name := TC_Name; TC_Name := BEN.Name (BEN.Defining_Identifier (TC_Dim)); -- Initialize the TC_Dimension variable N := Make_Assignment_Statement (Make_Defining_Identifier (TC_Name), Make_Subprogram_Call (RE (RE_To_CORBA_Object), New_List (RE (RE_TC_Array)))); Append_To (Statements, N); -- For multi-dimensional arrays, we fill each -- TC_Dimention_X TypeCode with the -- TC_Dimension_(X+1). The last TC_Dimension -- is filled withe the array element TypeCode. V := Values.Value (Get_Value (Last (Constraint))); V.IVal := V.IVal + 1; Param1 := Make_Type_Conversion (RE (RE_Unsigned_Long), (Make_Literal (New_Value (V)))); if TC_Previous_Name = No_Name then -- The deepest dimension T := Type_Spec (Declaration (E)); Param2 := Get_TC_Node (T); Handle_Dependency (T, Statements); Add_Dependency (Get_Parent_Unit_Name (Param2), Dependencies, D_Helper); else -- Not the deepest dimension Param2 := Make_Identifier (TC_Previous_Name); end if; N := Add_Parameter (TC_Name, Param1); Append_To (Statements, N); N := Add_Parameter (TC_Name, Param2); Append_To (Statements, N); Remove_Node_From_List (Constraint, Sizes_Reverse); Constraint := Last_Node (Sizes_Reverse); end loop; -- The case of the last TC_ variable which -- represents the whole array is handled apart. V := Values.Value (Get_Value (Last (Constraint))); V.IVal := V.IVal + 1; Param1 := Make_Subprogram_Call (RE (RE_Unsigned_Long), New_List (Make_Literal (New_Value (V)))); Param2 := Make_Identifier (TC_Name); else -- 1 dimension array V := Values.Value (Get_Value (Last (First_Node (Sizes)))); V.IVal := V.IVal + 1; Param1 := Make_Subprogram_Call (RE (RE_Unsigned_Long), New_List (Make_Literal (New_Value (V)))); T := Type_Spec (Declaration (E)); Param2 := Get_TC_Node (T); Handle_Dependency (T, Statements); Add_Dependency (Get_Parent_Unit_Name (Param2), Dependencies, D_Helper); end if; end; when K_Fixed_Point_Type => Param1 := Make_Literal (New_Integer_Value (Unsigned_Long_Long (N_Total (E)), 1, 10)); Param1 := Make_Subprogram_Call (RE (RE_Unsigned_Short), New_List (Param1)); Param2 := Make_Literal (New_Integer_Value (Unsigned_Long_Long (N_Scale (E)), 1, 10)); Param2 := Make_Subprogram_Call (RE (RE_Short), New_List (Param2)); when K_Sequence_Type => declare TC_Sequence : Node_Id; TC_Element : Node_Id; Seq_Package : Node_Id; begin -- Disable the reference counting on the TypeCode -- variable. N := Make_Subprogram_Call (RE (RE_Disable_Reference_Counting), New_List (Get_TC_Node (E))); Append_To (Statements, N); -- If the sequence does not contain local element, -- initialize the instantiated package. if not FEU.Has_Local_Component (E) then TC_Element := Get_TC_Node (Type_Spec (E)); TC_Sequence := Get_TC_Node (E); Seq_Package := Make_Defining_Identifier (Map_Sequence_Pkg_Helper_Name (E)); N := Make_Selected_Component (Seq_Package, Make_Defining_Identifier (SN (S_Initialize))); N := Make_Subprogram_Call (N, New_List (Make_Parameter_Association (RE (RE_Element_TC), TC_Element), Make_Parameter_Association (RE (RE_Sequence_TC), TC_Sequence))); Append_To (Statements, N); end if; end; when K_String_Type | K_Wide_String_Type | K_Simple_Declarator | K_Enumeration_Type | K_Structure_Type | K_Union_Type | K_Exception_Declaration => null; when others => raise Program_Error; end case; if FEN.Kind (E) /= K_Complex_Declarator and then FEN.Kind (E) /= K_Sequence_Type and then FEN.Kind (E) /= K_Fixed_Point_Type and then FEN.Kind (E) /= K_String_Type and then FEN.Kind (E) /= K_Wide_String_Type then Param1 := Make_Identifier (VN (V_Name)); Param2 := Make_Identifier (VN (V_Id)); -- Name_U declaration Entity_Name_V := New_String_Value (Get_Name (Get_Base_Identifier (Stub)), False); N := Declare_Name (VN (V_Name), Entity_Name_V); Append_To (Declaration_List, N); -- Id_U declaration N := Declare_Name (VN (V_Id), Entity_Rep_Id_V); Append_To (Declaration_List, N); end if; -- Add the two parameters if FEN.Kind (E) /= K_Sequence_Type and then FEN.Kind (E) /= K_String_Type and then FEN.Kind (E) /= K_Wide_String_Type and then FEN.Kind (E) /= K_Simple_Declarator then N := Add_Parameter (Entity_TC_Name, Param1); Append_To (Statements, N); N := Add_Parameter (Entity_TC_Name, Param2); Append_To (Statements, N); end if; case FEN.Kind (E) is when K_Enumeration_Type => declare Enumerators : List_Id; Enum_Item : Node_Id; Var_Name : Name_Id; begin Enumerators := Enumeration_Literals (Type_Definition (Stub)); Enum_Item := First_Node (Enumerators); loop Var_Name := Add_Prefix_To_Name (Get_Name_String (BEN.Name (Enum_Item)) & '_', VN (V_Name)); Param1 := Make_Identifier (Var_Name); N := Declare_Name (Var_Name, New_String_Value (BEN.Name (Enum_Item), False)); Append_To (Declaration_List, N); N := Add_Parameter (Entity_TC_Name, Param1); Append_To (Statements, N); Enum_Item := Next_Node (Enum_Item); exit when No (Enum_Item); end loop; end; when K_Union_Type => declare Switch_Case : Node_Id; Choice : Node_Id; Choices : List_Id; Label : Node_Id; Switch_To_Any : Node_Id; TC_Helper : Node_Id; Declarator : Node_Id; Designator : Node_Id; Arg_Name : Name_Id; Switch_Type : Node_Id; Literal_Parent : Node_Id := No_Node; Orig_Type : constant Node_Id := FEU.Get_Original_Type_Specifier (Switch_Type_Spec (E)); Statement_List : constant List_Id := New_List; Default_Index : Value_Id := New_Integer_Value (0, 1, 10); -- (0) -- Index of the default case of the union. It is -- initialized to 0 and incremented each time a -- non-default case is met. It is set to -1 of no -- default case exists in the union. Default_Present : Boolean; T : Node_Id; begin -- Getting the discriminator type and the To_Any -- node corresponding to it TC_Helper := Get_TC_Node (Switch_Type_Spec (E)); Handle_Dependency (Switch_Type_Spec (E), Statements); Add_Dependency (Get_Parent_Unit_Name (TC_Helper), Dependencies, D_Helper); Switch_To_Any := Get_To_Any_Node (Switch_Type_Spec (E)); if Is_Base_Type (Switch_Type_Spec (E)) then Switch_Type := RE (Convert (FEN.Kind (Switch_Type_Spec (E)))); elsif FEN.Kind (Orig_Type) = K_Enumeration_Type then Switch_Type := Map_Expanded_Name (Switch_Type_Spec (E)); Literal_Parent := Map_Expanded_Name (Scope_Entity (Identifier (Orig_Type))); else Switch_Type := Map_Expanded_Name (Switch_Type_Spec (E)); end if; -- The third parameter is the discriminator type N := Add_Parameter (Entity_TC_Name, TC_Helper); Append_To (Statements, N); -- The forth parameter is the index of default case -- as a long. we put the remaining parameter in an -- intermediary list. When we get the default case -- index, we add the intermediary list to the -- statements list. Switch_Case := First_Entity (Switch_Type_Body (E)); Default_Present := False; while Present (Switch_Case) loop Choices := New_List; Label := First_Entity (Labels (Switch_Case)); while Present (Label) loop Choice := Make_Literal_With_Parent (Value => FEU.Expr_Value (Label), Parent => Literal_Parent); -- If this is not a case statement, then we -- increment the default case index. The -- value of Default_Index will be correctly -- set up after the end of the two loops if Get_Value (Choice) /= No_Value then Set_Value (Default_Index, Value (Default_Index) + Value (Int1_Val)); else Default_Present := True; end if; Append_To (Choices, Choice); Label := Next_Entity (Label); end loop; -- Declaring the argument name "Element" string Declarator := FEN.Declarator (Element (Switch_Case)); -- Getting the TC_XXX constant corresponding to -- the element type. T := Type_Spec (Element (Switch_Case)); Handle_Dependency (T, Statements); TC_Helper := Get_TC_Node (T); Add_Dependency (Get_Parent_Unit_Name (TC_Helper), Dependencies, D_Helper); Designator := Map_Expanded_Name (Declarator); Get_Name_String (VN (V_Argument_Name)); Add_Char_To_Name_Buffer ('_'); Get_Name_String_And_Append (Get_Name (Get_Base_Identifier (Designator))); Arg_Name := Name_Find; N := Make_Literal (New_String_Value (Get_Name (Get_Base_Identifier (Designator)), False)); N := Make_Subprogram_Call (RE (RE_To_CORBA_String), New_List (N)); N := Make_Object_Declaration (Defining_Identifier => Make_Defining_Identifier (Arg_Name), Constant_Present => True, Object_Definition => RE (RE_String_0), Expression => N); Append_To (Declaration_List, N); -- For each case statement, 3 parameters are added : -- * member label -- * member type -- * member name -- This implies that the same element may be declared -- more than once but with a different label. Choice := First_Node (Choices); while Present (Choice) loop if Get_Value (Choice) /= No_Value then -- Copy Choice value to avoid adding the next nodes -- of Choice to the argument list. N := Copy_Node (Choice); N := Make_Qualified_Expression (Subtype_Mark => Switch_Type, Operand => N); N := Add_Parameter (Entity_TC_Name, N, To_Any => Switch_To_Any); Append_To (Statement_List, N); N := Add_Parameter (Entity_TC_Name, TC_Helper); Append_To (Statement_List, N); N := Add_Parameter (Entity_TC_Name, Make_Defining_Identifier (Arg_Name)); Append_To (Statement_List, N); else -- Case of a default alternative N := Make_Attribute_Reference (Switch_Type, A_First); N := Add_Parameter (Entity_TC_Name, N, To_Any => Switch_To_Any); Append_To (Statement_List, N); N := Add_Parameter (Entity_TC_Name, TC_Helper); Append_To (Statement_List, N); N := Add_Parameter (Entity_TC_Name, Make_Defining_Identifier (Arg_Name)); Append_To (Statement_List, N); end if; Choice := Next_Node (Choice); end loop; Switch_Case := Next_Entity (Switch_Case); end loop; if not Default_Present then Default_Index := New_Integer_Value (1, -1, 10); -- (-1) end if; -- Fourth parameter: The index of the "default" -- alternative as a CORBA.Long. N := Make_Type_Conversion (RE (RE_Long), Make_Literal (Default_Index)); N := Add_Parameter (Entity_TC_Name, N); Append_To (Statements, N); -- Append the Statement_List list to the end of the -- Statements list (we only append the first node, -- the others are appended automatically). Append_To (Statements, First_Node (Statement_List)); end; when K_Structure_Type => declare Member : Node_Id; Declarator : Node_Id; Designator : Node_Id; Arg_Name : Name_Id; T : Node_Id; begin Member := First_Entity (Members (E)); while Present (Member) loop Declarator := First_Entity (Declarators (Member)); while Present (Declarator) loop Designator := Map_Expanded_Name (Declarator); Get_Name_String (VN (V_Argument_Name)); Add_Char_To_Name_Buffer ('_'); Get_Name_String_And_Append (Get_Name (Get_Base_Identifier (Designator))); Arg_Name := Name_Find; N := Make_Literal (New_String_Value (Get_Name (Get_Base_Identifier (Designator)), False)); N := Make_Subprogram_Call (RE (RE_To_CORBA_String), New_List (N)); N := Make_Object_Declaration (Defining_Identifier => Make_Defining_Identifier (Arg_Name), Constant_Present => True, Object_Definition => RE (RE_String_0), Expression => N); Append_To (Declaration_List, N); T := Type_Spec (Declaration (Declarator)); Handle_Dependency (T, Statements); Param1 := Get_TC_Node (T); Add_Dependency (Get_Parent_Unit_Name (Param1), Dependencies, D_Helper); Param2 := Make_Identifier (Arg_Name); N := Add_Parameter (Entity_TC_Name, Param1); Append_To (Statements, N); N := Add_Parameter (Entity_TC_Name, Param2); Append_To (Statements, N); Declarator := Next_Entity (Declarator); end loop; Member := Next_Entity (Member); end loop; end; when K_Exception_Declaration => declare Raise_From_Any_Access_Node : Node_Id; Member : Node_Id; Declarator : Node_Id; Dcl_Name : Name_Id; Arg_Name_Node : Node_Id; Register_Excp_Node : constant Node_Id := RE (RE_Register_Exception); begin -- In case where the exception has members, we add two -- parameters for each member. Member := First_Entity (Members (E)); while Present (Member) loop Declarator := First_Entity (Declarators (Member)); while Present (Declarator) loop -- Declaring the Arg_Name_"member" variable Dcl_Name := To_Ada_Name (IDL_Name (FEN.Identifier (Declarator))); Set_Str_To_Name_Buffer ("Arg_Name_"); Get_Name_String_And_Append (Dcl_Name); Arg_Name_Node := Make_Defining_Identifier (Name_Find); -- Get a string literal of the member name N := Make_Subprogram_Call (RE (RE_To_CORBA_String), New_List (Make_Literal (New_Value (Value_Type' (K => K_String, SVal => Dcl_Name))))); N := Make_Object_Declaration (Defining_Identifier => Arg_Name_Node, Constant_Present => True, Object_Definition => RE (RE_String_0), Expression => N); Append_To (Declaration_List, N); -- Add the two additional parameters N := Get_TC_Node (Type_Spec (Member)); Handle_Dependency (Type_Spec (Member), Statements); Add_Dependency (Get_Parent_Unit_Name (N), Dependencies, D_Helper); N := Add_Parameter (Entity_TC_Name, N); Append_To (Statements, N); N := Add_Parameter (Entity_TC_Name, Arg_Name_Node); Append_To (Statements, N); Declarator := Next_Entity (Declarator); end loop; Member := Next_Entity (Member); end loop; -- Register the exception (in case of no local -- interface members in the exception). if not FEU.Has_Local_Component (E) then -- Add a dependency to initialize correctly the -- modules. Add_Dependency (Get_Parent_Unit_Name (Register_Excp_Node), Dependencies, D_Helper); Raise_From_Any_Access_Node := Make_Identifier (Map_Raise_From_Any_Name (E)); Raise_From_Any_Access_Node := Make_Attribute_Reference (Raise_From_Any_Access_Node, A_Access); N := Make_Subprogram_Call (RE (RE_To_PolyORB_Object), New_List (Make_Identifier (Entity_TC_Name))); -- Register raiser -- This has to be done in deferred initialization, -- after the TypeCode has been constructed. N := Make_Subprogram_Call (Register_Excp_Node, New_List (N, Raise_From_Any_Access_Node)); Append_To (Statements, N); end if; end; when K_Simple_Declarator => begin -- Generate the dependency upon possible CORBA -- predefined units. N := Get_TC_Node (Type_Spec (Declaration (E))); Add_Dependency (Get_Parent_Unit_Name (N), Dependencies, D_Helper); end; when others => null; end case; -- Disable reference counting on the TypeCode variable for -- types who are different from sequences. For sequences, -- this has been done earlier. if FEN.Kind (E) /= K_Sequence_Type then N := Make_Subprogram_Call (RE (RE_Disable_Reference_Counting), New_List (Get_TC_Node (E))); Append_To (Statements, N); end if; end Initialize_Routine; ----------------------------- -- From_Any_Container_Body -- ----------------------------- function From_Any_Container_Body (E : Node_Id) return Node_Id is pragma Assert (FEN.Kind (E) = K_Enumeration_Type); Spec : constant Node_Id := From_Any_Container_Node (BE_Node (Identifier (E))); D : constant List_Id := New_List; S : constant List_Id := New_List; N : Node_Id; begin N := Make_Subprogram_Call (RE (RE_Get_Aggregate_Element_2), New_List (Make_Identifier (PN (P_C)), Make_Literal (Int0_Val))); N := Make_Qualified_Expression (RE (RE_Unsigned_Long_1), N); N := Make_Subprogram_Call (Make_Attribute_Reference (Get_Type_Definition_Node (E), A_Val), New_List (N)); N := Make_Return_Statement (N); Append_To (S, N); -- Make the subprogram body N := Make_Subprogram_Body (Spec, D, S); return N; end From_Any_Container_Body; ----------------------- -- Handle_Dependency -- ----------------------- procedure Handle_Dependency (N : Node_Id; Statements : List_Id) is Init_Spg : constant Node_Id := Get_Initialize_Node (N); begin if Present (Init_Spg) and then BEN.Kind (Init_Spg) /= K_Node_Id then Append_To (Statements, Make_Subprogram_Call (Init_Spg, No_List)); end if; end Handle_Dependency; ------------------------------ -- Raise_Excp_From_Any_Spec -- ------------------------------ function Raise_Excp_From_Any_Spec (Raise_Node : Node_Id) return Node_Id is Profile : List_Id; Parameter : Node_Id; N : Node_Id; begin Profile := New_List; Parameter := Make_Parameter_Specification (Make_Defining_Identifier (PN (P_Item)), RE (RE_Any_1)); Append_To (Profile, Parameter); Parameter := Make_Parameter_Specification (Make_Defining_Identifier (PN (P_Message)), RE (RE_String_2)); Append_To (Profile, Parameter); N := Make_Subprogram_Specification (Raise_Node, Profile); return N; end Raise_Excp_From_Any_Spec; ------------------------------ -- Raise_Excp_From_Any_Body -- ------------------------------ function Raise_Excp_From_Any_Body (E : Node_Id; Raise_Node : Node_Id) return Node_Id is Spec : constant Node_Id := Raise_Excp_From_Any_Spec (Raise_Node); Declarations : constant List_Id := New_List; Statements : constant List_Id := New_List; N : Node_Id; From_Any_Helper : Node_Id; Excp_Members : Node_Id; begin -- Declarations -- Get the node corresponding to the declaration of the -- "Excp_Name"_Members type. Excp_Members := Get_Type_Definition_Node (E); -- Prepare the call to From_Any N := Make_Type_Conversion (RE (RE_Any), Make_Defining_Identifier (PN (P_Item))); From_Any_Helper := Expand_Designator (From_Any_Node (BE_Node (Identifier (E)))); N := Make_Subprogram_Call (From_Any_Helper, New_List (N)); -- Declaration of the Members variable N := Make_Object_Declaration (Defining_Identifier => Make_Defining_Identifier (PN (P_Members)), Constant_Present => True, Object_Definition => Excp_Members, Expression => N); Append_To (Declarations, N); -- Statements N := Make_Defining_Identifier (To_Ada_Name (IDL_Name (FEN.Identifier (E)))); N := Make_Attribute_Reference (N, A_Identity); N := Make_Subprogram_Call (RE (RE_User_Raise_Exception), New_List (N, Make_Defining_Identifier (PN (P_Members)), Make_Defining_Identifier (PN (P_Message)))); Append_To (Statements, N); N := Make_Subprogram_Body (Spec, Declarations, Statements); return N; end Raise_Excp_From_Any_Body; ----------- -- Visit -- ----------- procedure Visit (E : Node_Id) is begin case FEN.Kind (E) is when K_Enumeration_Type => Visit_Enumeration_Type (E); when K_Forward_Interface_Declaration => Visit_Forward_Interface_Declaration (E); when K_Interface_Declaration => Visit_Interface_Declaration (E); when K_Module => Visit_Module (E); when K_Specification => Visit_Specification (E); when K_Structure_Type => Visit_Structure_Type (E); when K_Type_Declaration => Visit_Type_Declaration (E); when K_Union_Type => Visit_Union_Type (E); when K_Exception_Declaration => Visit_Exception_Declaration (E); when others => null; end case; end Visit; ---------------------------- -- Visit_Enumeration_Type -- ---------------------------- procedure Visit_Enumeration_Type (E : Node_Id) is N : Node_Id; begin Set_Internals_Body; -- The enumeration types are a special case. They require an -- additional `From_Any' function that converts containers -- to a value from the enumeration type. N := From_Any_Container_Body (E); Append_To (Statements (Current_Package), N); -- The aggregate container routines Aggregate_Container_Routines (E); -- The Wrap function body N := Wrap_Body (E); Append_To (Statements (Current_Package), N); -- Initialize N := Initialize_Body (E); Append_To (Statements (Current_Package), N); end Visit_Enumeration_Type; ----------------------------------------- -- Visit_Forward_Interface_Declaration -- ----------------------------------------- procedure Visit_Forward_Interface_Declaration (E : Node_Id) is N : Node_Id; begin Set_Internals_Body; N := Initialize_Body (E); Append_To (Statements (Current_Package), N); end Visit_Forward_Interface_Declaration; --------------------------------- -- Visit_Interface_Declaration -- --------------------------------- procedure Visit_Interface_Declaration (E : Node_Id) is N : Node_Id; begin N := BEN.Parent (Type_Def_Node (BE_Node (Identifier (E)))); Push_Entity (BEN.IDL_Unit (Package_Declaration (N))); Set_Internals_Body; N := Initialize_Body (E); Append_To (Statements (Current_Package), N); N := First_Entity (Interface_Body (E)); while Present (N) loop Visit (N); N := Next_Entity (N); end loop; Pop_Entity; end Visit_Interface_Declaration; ------------------ -- Visit_Module -- ------------------ procedure Visit_Module (E : Node_Id) is D : Node_Id; begin if not Map_Particular_CORBA_Parts (E, PK_Helper_Internals_Body) then Push_Entity (Stub_Node (BE_Node (Identifier (E)))); D := First_Entity (Definitions (E)); while Present (D) loop Visit (D); D := Next_Entity (D); end loop; Pop_Entity; end if; end Visit_Module; ------------------------- -- Visit_Specification -- ------------------------- procedure Visit_Specification (E : Node_Id) is D : Node_Id; begin Push_Entity (Stub_Node (BE_Node (Identifier (E)))); D := First_Entity (Definitions (E)); while Present (D) loop Visit (D); D := Next_Entity (D); end loop; Pop_Entity; end Visit_Specification; -------------------------- -- Visit_Structure_Type -- -------------------------- procedure Visit_Structure_Type (E : Node_Id) is N : Node_Id; begin Set_Internals_Body; -- The aggregate container routines Aggregate_Container_Routines (E); -- The Wrap function body N := Wrap_Body (E); Append_To (Statements (Current_Package), N); -- Initialize N := Initialize_Body (E); Append_To (Statements (Current_Package), N); end Visit_Structure_Type; ---------------------------- -- Visit_Type_Declaration -- ---------------------------- procedure Visit_Type_Declaration (E : Node_Id) is N : Node_Id; D : Node_Id; T : constant Node_Id := Type_Spec (E); begin Set_Internals_Body; case (FEN.Kind (T)) is when K_Fixed_Point_Type => -- The Wrap function body N := Wrap_Body (T); Append_To (Statements (Current_Package), N); -- The Initialize body N := Initialize_Body (T); Append_To (Statements (Current_Package), N); when K_Sequence_Type => if not FEU.Has_Local_Component (T) then -- The element wrap function N := Element_Wrap_Body (T); Append_To (Statements (Current_Package), N); -- The Wrap function body N := Wrap_Body (T); Append_To (Statements (Current_Package), N); end if; -- The Initialize body N := Initialize_Body (T); Append_To (Statements (Current_Package), N); when K_String_Type | K_Wide_String_Type => -- The Wrap function body N := Wrap_Body (T); Append_To (Statements (Current_Package), N); -- The Initialize body N := Initialize_Body (T); Append_To (Statements (Current_Package), N); when others => null; end case; D := First_Entity (Declarators (E)); while Present (D) loop if FEN.Kind (D) = K_Complex_Declarator then -- The aggregate container routines Aggregate_Container_Routines (D); end if; -- We do not generate the `Wrap' spec if the defined type is: -- 1 - derived from an object type -- 2 - a fixed point type -- 3 - a bounded string type -- 4 - a sequence type if not (((FEN.Kind (T) = K_Scoped_Name or else FEN.Kind (T) = K_Object) and then FEN.Kind (D) = K_Simple_Declarator) or else FEN.Kind (T) = K_String_Type or else FEN.Kind (T) = K_Wide_String_Type or else FEN.Kind (T) = K_Fixed_Point_Type or else FEN.Kind (T) = K_Sequence_Type) then -- The Wrap function body N := Wrap_Body (D); Append_To (Statements (Current_Package), N); end if; -- Initialize N := Initialize_Body (D); Append_To (Statements (Current_Package), N); D := Next_Entity (D); end loop; end Visit_Type_Declaration; ---------------------- -- Visit_Union_Type -- ---------------------- procedure Visit_Union_Type (E : Node_Id) is N : Node_Id; begin Set_Internals_Body; -- The aggregate container routines Aggregate_Container_Routines (E); -- The Wrap function body N := Wrap_Body (E); Append_To (Statements (Current_Package), N); -- Initialize N := Initialize_Body (E); Append_To (Statements (Current_Package), N); end Visit_Union_Type; --------------------------------- -- Visit_Exception_Declaration -- --------------------------------- procedure Visit_Exception_Declaration (E : Node_Id) is N : Node_Id; Raise_Node : Node_Id; begin Set_Internals_Body; -- Do not generate the raise exception from any in case the -- exception contains local interface members. if not FEU.Has_Local_Component (E) then -- Generation of the Raise_"Exception_Name"_From_Any spec Raise_Node := Make_Defining_Identifier (Map_Raise_From_Any_Name (E)); N := Raise_Excp_From_Any_Spec (Raise_Node); Append_To (Statements (Current_Package), N); -- Addition of the pragma No_Return. The argument of the -- pragma No_Return must be a local name N := Make_Pragma (Pragma_No_Return, New_List (Make_Identifier (BEN.Name (Raise_Node)))); Append_To (Statements (Current_Package), N); -- Generation of the Raise_"Exception_Name"_From_Any body N := Raise_Excp_From_Any_Body (E, Raise_Node); Append_To (Statements (Current_Package), N); end if; -- The body of the Initialize routine N := Initialize_Body (E); Append_To (Statements (Current_Package), N); end Visit_Exception_Declaration; end Package_Body; end Backend.BE_CORBA_Ada.Helpers_Internals; polyorb-2.8~20110207.orig/compilers/iac/backend-be_idl.adb0000644000175000017500000010515611750740337022424 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- B A C K E N D . B E _ I D L -- -- -- -- B o d y -- -- -- -- Copyright (C) 2005-2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with Lexer; use Lexer; with Namet; use Namet; with Output; use Output; with Values; use Values; with Frontend.Nodes; use Frontend.Nodes; with Frontend.Nutils; use Frontend.Nutils; with Frontend.Debug; with Backend.BE_CORBA_Ada.Expand; package body Backend.BE_IDL is Already_Expanded : Boolean := False; procedure Generate (V : Value_Id); procedure Generate_Abstract_Value_Declaration (E : Node_Id); procedure Generate_Attribute_Declaration (E : Node_Id); procedure Generate_Base_Type (E : Node_Id); procedure Generate_Case_Label (E : Node_Id); procedure Generate_Complex_Declarator (E : Node_Id); procedure Generate_Constant_Declaration (E : Node_Id); procedure Generate_Element (E : Node_Id); procedure Generate_Enumeration_Type (E : Node_Id); procedure Generate_Enumerator (E : Node_Id); procedure Generate_Exception_Declaration (E : Node_Id); procedure Generate_Expression (E : Node_Id); procedure Generate_Fixed_Point_Type (E : Node_Id); procedure Generate_Forward_Interface_Declaration (E : Node_Id); procedure Generate_Forward_Structure_Type (E : Node_Id); procedure Generate_Forward_Union_Type (E : Node_Id); procedure Generate_Identifier (E : Node_Id); procedure Generate_Import (E : Node_Id); procedure Generate_Initializer_Declaration (E : Node_Id); procedure Generate_Interface_Declaration (E : Node_Id); procedure Generate_Literal (E : Node_Id); procedure Generate_Member (E : Node_Id); procedure Generate_Module (E : Node_Id); procedure Generate_Operation_Declaration (E : Node_Id); procedure Generate_Native_Type (E : Node_Id); procedure Generate_Parameter_Declaration (E : Node_Id); procedure Generate_Pragma (E : Node_Id); procedure Generate_Scoped_Name (E : Node_Id); procedure Generate_Simple_Declarator (E : Node_Id); procedure Generate_Sequence_Type (E : Node_Id); procedure Generate_State_Member (E : Node_Id); procedure Generate_String_Type (E : Node_Id); procedure Generate_Structure_Type (E : Node_Id); procedure Generate_Switch_Alternative (E : Node_Id); procedure Generate_Type_Declaration (E : Node_Id); procedure Generate_Type_Id_Declaration (E : Node_Id); procedure Generate_Type_Prefix_Declaration (E : Node_Id); procedure Generate_Union_Type (E : Node_Id); procedure Generate_Value_Declaration (E : Node_Id); procedure Generate_Value_Box_Declaration (E : Node_Id); procedure Generate_Value_Forward_Declaration (E : Node_Id); -- This procedure generates a semi-colon in general cases. After a #pragma -- the semi-colon is not generated procedure Generate_Statement_Delimiter (E : Node_Id); procedure Write_Line (T : Token_Type); -------------- -- Generate -- -------------- procedure Generate (V : Value_Id) is Val : Value_Type := Value (V); Base : Unsigned_Short_Short := 0; begin if Val.K in K_Short .. K_Unsigned_Long_Long or else Val.K = K_Octet then Base := Val.Base; if Default_Base /= 0 then Val.Base := Unsigned_Short_Short (Default_Base); end if; Set_Value (V, Val); end if; Write_Str (Image (V)); if Base /= 0 then Val.Base := Base; Set_Value (V, Val); end if; end Generate; -------------- -- Generate -- -------------- procedure Generate (E : Node_Id) is begin if Expand_Tree and then not Already_Expanded then Backend.BE_CORBA_Ada.Expand.Expand (E); Already_Expanded := True; end if; if Print_IDL_Tree then Frontend.Debug.W_Node_Id (E); else case Kind (E) is when K_Abstract_Value_Declaration => Generate_Abstract_Value_Declaration (E); when K_Attribute_Declaration => Generate_Attribute_Declaration (E); when K_Case_Label => Generate_Case_Label (E); when K_Complex_Declarator => Generate_Complex_Declarator (E); when K_Constant_Declaration => Generate_Constant_Declaration (E); when K_Element => Generate_Element (E); when K_Enumerator => Generate_Enumerator (E); when K_Enumeration_Type => Generate_Enumeration_Type (E); when K_Exception_Declaration => Generate_Exception_Declaration (E); when K_Expression => Generate_Expression (E); when K_Fixed_Point_Type => Generate_Fixed_Point_Type (E); when K_Forward_Interface_Declaration => Generate_Forward_Interface_Declaration (E); when K_Forward_Structure_Type => Generate_Forward_Structure_Type (E); when K_Forward_Union_Type => Generate_Forward_Union_Type (E); when K_Import => Generate_Import (E); when K_Initializer_Declaration => Generate_Initializer_Declaration (E); when K_Interface_Declaration => Generate_Interface_Declaration (E); when K_Integer_Literal .. K_Boolean_Literal => Generate_Literal (E); when K_Member => Generate_Member (E); when K_Module => Generate_Module (E); when K_Operation_Declaration => Generate_Operation_Declaration (E); when K_Native_Type => Generate_Native_Type (E); when K_Parameter_Declaration => Generate_Parameter_Declaration (E); when K_Pragma => Generate_Pragma (E); when K_Scoped_Name => Generate_Scoped_Name (E); when K_Simple_Declarator => Generate_Simple_Declarator (E); when K_Sequence_Type => Generate_Sequence_Type (E); when K_Specification => Generate_Module (E); when K_State_Member => Generate_State_Member (E); when K_String_Type | K_Wide_String_Type => Generate_String_Type (E); when K_Structure_Type => Generate_Structure_Type (E); when K_Switch_Alternative => Generate_Switch_Alternative (E); when K_Type_Declaration => Generate_Type_Declaration (E); when K_Type_Id_Declaration => Generate_Type_Id_Declaration (E); when K_Type_Prefix_Declaration => Generate_Type_Prefix_Declaration (E); when K_Union_Type => Generate_Union_Type (E); when K_Value_Declaration => Generate_Value_Declaration (E); when K_Value_Box_Declaration => Generate_Value_Box_Declaration (E); when K_Value_Forward_Declaration => Generate_Value_Forward_Declaration (E); when K_Float .. K_Value_Base => Generate_Base_Type (E); when K_Identifier => Generate_Identifier (E); when others => Dummy (E); end case; end if; end Generate; ---------------------------------------- -- Generate_Abstract_Value_Declaration -- ---------------------------------------- procedure Generate_Abstract_Value_Declaration (E : Node_Id) is begin Write (T_Abstract); Write_Space; Generate_Value_Declaration (E); end Generate_Abstract_Value_Declaration; ----------------------------------- -- Generate_Attribute_Declaration -- ----------------------------------- procedure Generate_Attribute_Declaration (E : Node_Id) is D : Node_Id := First_Entity (Declarators (E)); L : List_Id; C : Node_Id; begin if Is_Readonly (E) then Write (T_Readonly); Write_Space; end if; Write (T_Attribute); Write_Space; Generate (Type_Spec (E)); Write_Space; loop Generate (Identifier (D)); D := Next_Entity (D); exit when No (D); Write (T_Comma); Write_Space; end loop; L := Getter_Exceptions (E); if not Is_Empty (L) then Write_Space; Write (T_Get_Raises); Write_Space; Write (T_Left_Paren); C := First_Entity (L); loop Generate (C); C := Next_Entity (C); exit when No (C); Write (T_Comma); Write_Space; end loop; Write (T_Right_Paren); end if; L := Setter_Exceptions (E); if not Is_Empty (L) then Write_Space; Write (T_Set_Raises); Write_Space; Write (T_Left_Paren); C := First_Entity (L); loop Generate (C); C := Next_Entity (C); exit when No (C); Write (T_Comma); Write_Space; end loop; Write (T_Right_Paren); end if; end Generate_Attribute_Declaration; ------------------------ -- Generate_Base_Type -- ------------------------ procedure Generate_Base_Type (E : Node_Id) is begin Write_Name (Image (Base_Type (E))); end Generate_Base_Type; ------------------------- -- Generate_Case_Label -- ------------------------- procedure Generate_Case_Label (E : Node_Id) is X : constant Node_Id := Expression (E); begin if No (X) then Write (T_Default); else Write (T_Case); Write_Space; if Kind (X) = K_Scoped_Name then Generate (X); else Generate (Value (E)); end if; end if; Write_Space; Write (T_Colon); end Generate_Case_Label; --------------------------------- -- Generate_Complex_Declarator -- --------------------------------- procedure Generate_Complex_Declarator (E : Node_Id) is C : Node_Id; begin Generate (Identifier (E)); -- The array sizes attribute is never empty Write (T_Left_Bracket); C := First_Entity (Array_Sizes (E)); loop Generate (C); C := Next_Entity (C); exit when No (C); Write (T_Right_Bracket); Write (T_Left_Bracket); end loop; Write (T_Right_Bracket); end Generate_Complex_Declarator; ----------------------------------- -- Generate_Constant_Declaration -- ----------------------------------- procedure Generate_Constant_Declaration (E : Node_Id) is begin Write (T_Const); Write_Space; Generate (Type_Spec (E)); Write_Space; Generate (Identifier (E)); Write_Space; Write (T_Equal); Write_Space; Generate (Value (E)); end Generate_Constant_Declaration; ---------------------- -- Generate_Element -- ---------------------- procedure Generate_Element (E : Node_Id) is begin Generate (Type_Spec (E)); Write_Space; Generate (Declarator (E)); end Generate_Element; ------------------------------- -- Generate_Enumeration_Type -- ------------------------------- procedure Generate_Enumeration_Type (E : Node_Id) is C : Node_Id; begin Write (T_Enum); Write_Space; Generate (Identifier (E)); Write_Space; Write_Line (T_Left_Brace); Increment_Indentation; C := First_Entity (Enumerators (E)); loop Write_Indentation; Generate (C); C := Next_Entity (C); exit when No (C); Write_Line (T_Comma); end loop; Write_Eol; Decrement_Indentation; Write_Indentation; Write (T_Right_Brace); end Generate_Enumeration_Type; ------------------------- -- Generate_Enumerator -- ------------------------- procedure Generate_Enumerator (E : Node_Id) is begin Generate (Identifier (E)); end Generate_Enumerator; ------------------------------------ -- Generate_Exception_Declaration -- ------------------------------------ procedure Generate_Exception_Declaration (E : Node_Id) is C : Node_Id; L : List_Id; begin Write (T_Exception); Write_Space; Generate (Identifier (E)); L := Members (E); Write_Space; Write_Line (T_Left_Brace); Increment_Indentation; C := First_Entity (L); while Present (C) loop Write_Indentation; Generate (C); Generate_Statement_Delimiter (C); C := Next_Entity (C); end loop; Decrement_Indentation; Write_Indentation; Write (T_Right_Brace); end Generate_Exception_Declaration; ------------------------ -- Generate_Expression -- ------------------------ procedure Generate_Expression (E : Node_Id) is C : Node_Id; begin C := Left_Expr (E); if Present (C) then Generate (C); end if; Write_Space; Write (Token_Type'Val (Operator (E))); Write_Space; C := Right_Expr (E); if Present (C) then Generate (C); end if; end Generate_Expression; ------------------------------- -- Generate_Fixed_Point_Type -- ------------------------------- procedure Generate_Fixed_Point_Type (E : Node_Id) is begin Write (T_Fixed); Write (T_Less); Write_Int (N_Total (E)); Write (T_Comma); Write_Int (N_Scale (E)); Write (T_Greater); end Generate_Fixed_Point_Type; -------------------------------------------- -- Generate_Forward_Interface_Declaration -- -------------------------------------------- procedure Generate_Forward_Interface_Declaration (E : Node_Id) is begin Write (T_Interface); Write_Space; Generate (Identifier (E)); end Generate_Forward_Interface_Declaration; ------------------------------------- -- Generate_Forward_Structure_Type -- ------------------------------------- procedure Generate_Forward_Structure_Type (E : Node_Id) is begin Write (T_Struct); Write_Space; Generate (Identifier (E)); end Generate_Forward_Structure_Type; --------------------------------- -- Generate_Forward_Union_Type -- --------------------------------- procedure Generate_Forward_Union_Type (E : Node_Id) is begin Write (T_Union); Write_Space; Generate (Identifier (E)); end Generate_Forward_Union_Type; ------------------------- -- Generate_Identifier -- ------------------------- procedure Generate_Identifier (E : Node_Id) is begin Write_Name (IDL_Name (E)); end Generate_Identifier; --------------------- -- Generate_Import -- --------------------- procedure Generate_Import (E : Node_Id) is procedure Generate_Imported_Scope (Entity : Node_Id); ----------------------------- -- Generate_Imported_Scope -- ----------------------------- procedure Generate_Imported_Scope (Entity : Node_Id) is pragma Assert (Kind (Entity) = K_Scoped_Name); Parent : constant Node_Id := Parent_Entity (Entity); begin if Present (Parent) and then IDL_Name (Identifier (Parent)) /= No_Name then Generate_Imported_Scope (Parent); Write (T_Colon_Colon); end if; Write_Name (IDL_Name (Identifier (Entity))); end Generate_Imported_Scope; S : Node_Id; begin Write (T_Import); Write_Space; S := Imported_Scope (E); Write (T_Colon_Colon); Generate_Imported_Scope (S); end Generate_Import; -------------------------------------- -- Generate_Initializer_Declaration -- -------------------------------------- procedure Generate_Initializer_Declaration (E : Node_Id) is begin Write (T_Factory); Write_Space; Generate_Operation_Declaration (E); end Generate_Initializer_Declaration; ------------------------------------ -- Generate_Interface_Declaration -- ------------------------------------ procedure Generate_Interface_Declaration (E : Node_Id) is F : Node_Id := No_Node; I : Node_Id; S : List_Id; B : List_Id; begin if Is_Abstract_Interface (E) then Write (T_Abstract); Write_Space; end if; if Is_Local_Interface (E) then Write (T_Local); Write_Space; end if; Write (T_Interface); Write_Space; Generate (Identifier (E)); -- Generate interface names, enter them in scope and make them -- visible. S := Interface_Spec (E); if not Is_Empty (S) then Write_Space; Write (T_Colon); Write_Space; I := First_Entity (S); loop Generate (I); I := Next_Entity (I); exit when No (I); Write (T_Comma); Write_Space; end loop; end if; -- Prepare to inherit operations and attributes from parent -- interfaces. Preserve entities from current interface in F. -- Empty body of current interface in order to enter attributes -- and operations of parent interfaces. Write_Space; Write_Line (T_Left_Brace); B := Interface_Body (E); if not Is_Empty (B) then Increment_Indentation; F := First_Entity (B); while Present (F) loop Write_Indentation; Generate (F); Generate_Statement_Delimiter (F); F := Next_Entity (F); end loop; Decrement_Indentation; Write_Indentation; end if; Write (T_Right_Brace); end Generate_Interface_Declaration; ---------------------- -- Generate_Literal -- ---------------------- procedure Generate_Literal (E : Node_Id) is begin Generate (Value (E)); end Generate_Literal; --------------------- -- Generate_Member -- --------------------- procedure Generate_Member (E : Node_Id) is D : Node_Id := First_Entity (Declarators (E)); begin Generate (Type_Spec (E)); Write_Space; loop Generate (D); D := Next_Entity (D); exit when No (D); Write (T_Comma); Write_Space; end loop; end Generate_Member; --------------------- -- Generate_Module -- --------------------- procedure Generate_Module (E : Node_Id) is M : constant Boolean := (Kind (E) = K_Module); C : Node_Id; L : List_Id; I : Node_Id; begin if M then Write (T_Module); Write_Space; Generate (Identifier (E)); elsif Kind (E) = K_Specification then -- Generate the "import" declarations if not Is_Empty (Imports (E)) then I := First_Entity (Imports (E)); while Present (I) loop if not Imported (I) or else Generate_Imported then Generate (I); Generate_Statement_Delimiter (I); end if; I := Next_Entity (I); end loop; end if; end if; L := Definitions (E); if not Is_Empty (L) then if M then Write_Space; Write_Line (T_Left_Brace); Increment_Indentation; end if; C := First_Entity (L); while Present (C) loop if not Imported (C) or else Generate_Imported then Write_Indentation; Generate (C); Generate_Statement_Delimiter (C); end if; C := Next_Entity (C); end loop; if M then Decrement_Indentation; Write_Indentation; Write (T_Right_Brace); end if; end if; end Generate_Module; -------------------------- -- Generate_Native_Type -- -------------------------- procedure Generate_Native_Type (E : Node_Id) is begin Write (T_Native); Write_Space; Generate (Declarator (E)); end Generate_Native_Type; ------------------------------------ -- Generate_Operation_Declaration -- ------------------------------------ procedure Generate_Operation_Declaration (E : Node_Id) is C : Node_Id; L : List_Id; begin if Kind (E) /= K_Initializer_Declaration then if Is_Oneway (E) then Write (T_Oneway); Write_Space; end if; Generate (Type_Spec (E)); Write_Space; end if; Generate (Identifier (E)); Write (T_Left_Paren); L := Parameters (E); if not Is_Empty (L) then C := First_Entity (L); loop Generate (C); C := Next_Entity (C); exit when No (C); Write (T_Comma); Write_Space; end loop; end if; Write (T_Right_Paren); L := Exceptions (E); if not Is_Empty (L) then Write_Space; Write (T_Raises); Write_Space; Write (T_Left_Paren); C := First_Entity (L); loop Generate (C); C := Next_Entity (C); exit when No (C); Write (T_Comma); Write_Space; end loop; Write (T_Right_Paren); end if; L := Contexts (E); if not Is_Empty (L) then Write_Space; Write (T_Context); Write_Space; Write (T_Left_Paren); C := First_Entity (L); loop Write_Str (Image (Value (C))); C := Next_Entity (C); exit when No (C); Write (T_Comma); Write_Space; end loop; Write (T_Right_Paren); end if; end Generate_Operation_Declaration; ------------------------------------ -- Generate_Parameter_Declaration -- ------------------------------------ procedure Generate_Parameter_Declaration (E : Node_Id) is begin Write (Parameter_Mode (Parameter_Mode (E))); Write_Space; Generate (Type_Spec (E)); Write_Space; Generate (Declarator (E)); end Generate_Parameter_Declaration; --------------------- -- Generate_Pragma -- --------------------- procedure Generate_Pragma (E : Node_Id) is begin Write_Str ("#"); Write (T_Pragma); Write_Space; if Pragma_Kind (E) = Pragma_Unrecognized then Write_Eol; return; end if; Write (Get_Pragma_Type (Pragma_Kind (E))); Write_Space; case Pragma_Kind (E) is when Pragma_Id => Generate (Target (E)); Write_Space; Write_Char ('"'); Write_Name (Data (E)); Write_Char ('"'); when Pragma_Prefix => Write_Char ('"'); Write_Name (Data (E)); Write_Char ('"'); when Pragma_Version => Generate (Target (E)); Write_Space; Write_Name (Data (E)); when Pragma_Unrecognized => -- Extract from the CORBA 3.0 ($10.7.5) : -- "Conforming IDL compilers may support additional non-standard -- pragmas, but must not refuse to compile IDL source containing -- non-standard pragmas that are not understood by the compiler" -- So, we just indicate that a non recognized pragma is -- encountered null; end case; Write_Eol; end Generate_Pragma; -------------------------- -- Generate_Scoped_Name -- -------------------------- procedure Generate_Scoped_Name (E : Node_Id) is procedure Generate_Reference_Name (E : Node_Id); ----------------------------- -- Generate_Reference_Name -- ----------------------------- procedure Generate_Reference_Name (E : Node_Id) is S : constant Node_Id := Scope_Entity (E); begin if Kind (S) /= K_Specification then Generate_Reference_Name (Identifier (S)); Write (T_Colon_Colon); end if; Write_Name (IDL_Name (E)); end Generate_Reference_Name; R : constant Node_Id := Reference (E); V : Value_Id; begin if Kind (R) = K_Constant_Declaration then V := Value (R); if Value (V).K = K_Enumerator then Generate_Reference_Name (Identifier (R)); else Generate (V); end if; else Generate_Reference_Name (Identifier (R)); end if; end Generate_Scoped_Name; --------------------------- -- Generate_Sequence_Type -- --------------------------- procedure Generate_Sequence_Type (E : Node_Id) is S : constant Node_Id := Max_Size (E); begin Write (T_Sequence); Write (T_Less); Generate (Type_Spec (E)); if Present (S) then Write (T_Comma); Write_Space; Generate (S); end if; Write (T_Greater); end Generate_Sequence_Type; -------------------------------- -- Generate_Simple_Declarator -- -------------------------------- procedure Generate_Simple_Declarator (E : Node_Id) is begin Generate (Identifier (E)); end Generate_Simple_Declarator; --------------------------- -- Generate_State_Member -- --------------------------- procedure Generate_State_Member (E : Node_Id) is begin if Is_Public (E) then Write (T_Public); else Write (T_Private); end if; Write_Space; Generate_Member (E); end Generate_State_Member; -------------------------- -- Generate_String_Type -- -------------------------- procedure Generate_String_Type (E : Node_Id) is begin if Kind (E) = K_String_Type then Write (T_String); else Write (T_Wstring); end if; Write (T_Less); Generate (Value (Max_Size (E))); Write (T_Greater); end Generate_String_Type; ----------------------------- -- Generate_Structure_Type -- ----------------------------- procedure Generate_Structure_Type (E : Node_Id) is L : List_Id; C : Node_Id; begin Write (T_Struct); Write_Space; Generate (Identifier (E)); Write_Space; Write_Line (T_Left_Brace); L := Members (E); if not Is_Empty (L) then Increment_Indentation; C := First_Entity (L); while Present (C) loop Write_Indentation; Generate (C); Generate_Statement_Delimiter (C); C := Next_Entity (C); end loop; Decrement_Indentation; Write_Indentation; end if; Write (T_Right_Brace); end Generate_Structure_Type; --------------------------------- -- Generate_Switch_Alternative -- --------------------------------- procedure Generate_Switch_Alternative (E : Node_Id) is L : Node_Id := First_Entity (Labels (E)); begin while Present (L) loop Write_Indentation; Generate (L); Write_Eol; L := Next_Entity (L); end loop; Increment_Indentation; Write_Indentation; Generate (Element (E)); Decrement_Indentation; end Generate_Switch_Alternative; ------------------------------- -- Generate_Type_Declaration -- ------------------------------- procedure Generate_Type_Declaration (E : Node_Id) is D : Node_Id := First_Entity (Declarators (E)); begin Write (T_Typedef); Write_Space; Generate (Type_Spec (E)); Write_Space; loop Generate (D); D := Next_Entity (D); exit when No (D); Write (T_Comma); Write_Space; end loop; end Generate_Type_Declaration; ---------------------------------- -- Generate_Type_Id_Declaration -- ---------------------------------- procedure Generate_Type_Id_Declaration (E : Node_Id) is begin Write (T_Type_Id); Write_Space; Generate (Target (E)); Write_Space; Write_Char ('"'); Write_Name (Data (E)); Write_Char ('"'); end Generate_Type_Id_Declaration; -------------------------------------- -- Generate_Type_Prefix_Declaration -- -------------------------------------- procedure Generate_Type_Prefix_Declaration (E : Node_Id) is begin Write (T_Type_Prefix); Write_Space; Generate (Target (E)); Write_Space; Write_Char ('"'); Write_Name (Data (E)); Write_Char ('"'); end Generate_Type_Prefix_Declaration; ------------------------- -- Generate_Union_Type -- ------------------------- procedure Generate_Union_Type (E : Node_Id) is N : Node_Id := First_Entity (Switch_Type_Body (E)); begin Write (T_Union); Write_Space; Generate (Identifier (E)); Write_Space; Write (T_Switch); Write_Space; Write (T_Left_Paren); Generate (Switch_Type_Spec (E)); Write (T_Right_Paren); Write_Space; Write (T_Left_Brace); Write_Eol; Increment_Indentation; while Present (N) loop Write_Indentation; Generate (N); Generate_Statement_Delimiter (N); N := Next_Entity (N); end loop; Decrement_Indentation; Write_Indentation; Write (T_Right_Brace); end Generate_Union_Type; ------------------------------------ -- Generate_Value_Box_Declaration -- ------------------------------------ procedure Generate_Value_Box_Declaration (E : Node_Id) is begin Write (T_Value_Type); Write_Space; Generate (Identifier (E)); Write_Space; Generate (Type_Spec (E)); end Generate_Value_Box_Declaration; -------------------------------- -- Generate_Value_Declaration -- -------------------------------- procedure Generate_Value_Declaration (E : Node_Id) is S : constant Node_Id := Value_Spec (E); N : Node_Id; L : List_Id; begin Write (T_Value_Type); Write_Space; Generate (Identifier (E)); L := Value_Names (S); if not Is_Empty (L) then Write_Space; Write (T_Colon); if Is_Truncatable (S) then Write_Space; Write (T_Truncatable); end if; N := First_Entity (L); loop Write_Space; Generate (N); N := Next_Entity (N); exit when No (N); Write (T_Comma); end loop; end if; L := Interface_Names (S); if not Is_Empty (L) then Write_Space; Write (T_Supports); N := First_Entity (L); loop Write_Space; Generate (N); N := Next_Entity (N); exit when No (N); Write (T_Comma); end loop; end if; Write_Space; Write_Line (T_Left_Brace); L := Value_Body (E); if not Is_Empty (L) then Increment_Indentation; N := First_Entity (L); while Present (N) loop Write_Indentation; Generate (N); Generate_Statement_Delimiter (N); N := Next_Entity (N); end loop; Decrement_Indentation; Write_Indentation; end if; Write (T_Right_Brace); end Generate_Value_Declaration; ---------------------------------------- -- Generate_Value_Forward_Declaration -- ---------------------------------------- procedure Generate_Value_Forward_Declaration (E : Node_Id) is begin if Is_Abstract_Value (E) then Write (T_Abstract); Write_Space; end if; Write (T_Value_Type); Write_Space; Generate (Identifier (E)); end Generate_Value_Forward_Declaration; ----------- -- Usage -- ----------- procedure Usage (Indent : Natural) is Hdr : constant String (1 .. Indent - 1) := (others => ' '); begin Write_Line (Hdr & "-b n Base to output integer literals"); Write_Line (Hdr & " As a default (zero) use base from input"); Write_Line (Hdr & "-e Expand IDL Tree"); Write_Line (Hdr & "-df Dump IDL Tree (may be used in conjunction with -e"); Write_Line (Hdr & " to dump the expanded IDL tree)"); Write_Line (Hdr & "-di Output IDL code of imported entities (may be"); Write_Line (Hdr & " used in conjunction with -e to output the"); Write_Line (Hdr & " expanded IDL code)"); end Usage; ---------------- -- Write_Line -- ---------------- procedure Write_Line (T : Token_Type) is begin Write (T); Write_Eol; end Write_Line; ---------------------------------- -- Generate_Statement_Delimiter -- ---------------------------------- procedure Generate_Statement_Delimiter (E : Node_Id) is begin if Kind (E) /= K_Pragma then Write_Line (T_Semi_Colon); end if; end Generate_Statement_Delimiter; end Backend.BE_IDL; polyorb-2.8~20110207.orig/compilers/iac/frontend-debug.ads0000644000175000017500000000665311750740337022547 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- F R O N T E N D . D E B U G -- -- -- -- S p e c -- -- -- -- Copyright (C) 2005-2008, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with Output; use Output; with Types; use Types; with Utils; with Frontend.Nodes; use Frontend.Nodes; package Frontend.Debug is N_Indents : Natural := 0; procedure W_Eol (N : Natural := 1) renames Output.Write_Eol; procedure W_Int (N : Int) renames Output.Write_Int; procedure W_Line (N : String) renames Output.Write_Line; procedure W_Str (N : String) renames Output.Write_Str; procedure W_Indents; procedure W_Boolean (N : Boolean); procedure W_Byte (N : Byte); procedure W_List_Id (L : List_Id); procedure W_Node_Id (N : Node_Id); procedure W_Node_Header (N : Node_Id); procedure W_Full_Tree; procedure W_Node_Attribute (A : String; K : String; V : String; N : Int := 0); function Image (N : Node_Kind) return String; function Image (N : Name_Id) return String; function Image (N : Node_Id) return String; function Image (N : List_Id) return String; function Image (N : Mode_Id) return String; function Image (N : Pragma_Type) return String; function Image (N : Value_Id) return String; function Image (N : Operator_Id) return String; function Image (N : Boolean) return String; function Image (N : Byte) return String; function Image (N : Int) return String renames Utils.Image; procedure wfi (N : Node_Id); pragma Export (C, wfi, "wfi"); end Frontend.Debug; polyorb-2.8~20110207.orig/compilers/iac/backend-be_corba_ada-expand.ads0000644000175000017500000000631411750740337025041 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- B A C K E N D . B E _ C O R B A _ A D A . E X P A N D -- -- -- -- S p e c -- -- -- -- Copyright (C) 2005-2007, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- This package contains routines to expand the IDL tree and generate -- an intermediate IDL tree. In this tree, will be implemented: -- * The implicit forward declarations (eg. when a type uses an -- interface of the same scope). The implementation of this feature -- directly from the original IDL tree to the Ada tree is very -- complex because we will be obliged to revisit nodes we have -- already visited. -- * The definition of nested structures types : nested structures -- anonymous types are not deprecated. -- * The expansion of IDL attributes into Get_/Set_ IDL subprograms -- This phase of the compilation is located in the Ada backend -- because the problems related to the forwards are Ada specific -- problems. package Backend.BE_CORBA_Ada.Expand is procedure Expand (Entity : Node_Id); -- Note that this procedure modifies the IDL tree but this is not -- very dangerous since we are already in the Ada backend. -- NB: Iac may evolve to execute many backend one after the -- other. In this case the procedure above has to be replaced by a -- function which duplicates the IDL tree and keeps it intact for -- other backends. end Backend.BE_CORBA_Ada.Expand; polyorb-2.8~20110207.orig/compilers/iac/frontend-nutils.adb0000644000175000017500000006233411750740337022754 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- F R O N T E N D . N U T I L S -- -- -- -- B o d y -- -- -- -- Copyright (C) 2005-2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with Errors; use Errors; with Namet; use Namet; with Utils; use Utils; package body Frontend.Nutils is --------------- -- Append_To -- --------------- procedure Append_To (L : List_Id; E : Node_Id) is Last : Node_Id; Count : Int := Size (L); begin Last := Last_Entity (L); if No (Last) then Set_First_Entity (L, E); else Set_Next_Entity (Last, E); end if; Count := Count + 1; Last := E; while Present (Next_Entity (Last)) loop Count := Count + 1; Last := Next_Entity (Last); end loop; Set_Last_Entity (L, Last); Set_Size (L, Count); end Append_To; ------------------------------- -- Bind_Declarator_To_Entity -- ------------------------------- procedure Bind_Declarator_To_Entity (D : Node_Id; E : Node_Id) is begin Set_Declaration (D, E); end Bind_Declarator_To_Entity; -------------------------------- -- Bind_Declarators_To_Entity -- -------------------------------- procedure Bind_Declarators_To_Entity (D : List_Id; E : Node_Id) is N : Node_Id := First_Entity (D); begin while Present (N) loop Set_Declaration (N, E); N := Next_Entity (N); end loop; end Bind_Declarators_To_Entity; ------------------------------- -- Bind_Identifier_To_Entity -- ------------------------------- procedure Bind_Identifier_To_Entity (N : Node_Id; E : Node_Id) is begin Set_Identifier (E, N); Set_Corresponding_Entity (N, E); end Bind_Identifier_To_Entity; ---------------------- -- Check_Identifier -- ---------------------- procedure Check_Identifier (Ref, Def : Node_Id) is begin if Present (Ref) and then Present (Def) and then IDL_Name (Ref) /= IDL_Name (Def) then Error_Loc (1) := Loc (Ref); Error_Name (1) := Name (Def); Error_Loc (2) := Loc (Def); DE ("bad casing of#declared!"); end if; end Check_Identifier; ------------------- -- First_Homonym -- ------------------- function First_Homonym (N : Node_Id) return Node_Id is HN : constant Name_Id := Name (N); begin return Node_Id (Get_Name_Table_Info (HN)); end First_Homonym; ----------------------- -- Insert_After_Node -- ----------------------- procedure Insert_After_Node (E : Node_Id; N : Node_Id) is Next : constant Node_Id := Next_Entity (N); begin Set_Next_Entity (N, E); Set_Next_Entity (E, Next); end Insert_After_Node; ------------------------ -- Insert_Before_Node -- ------------------------ procedure Insert_Before_Node (E : Node_Id; N : Node_Id; L : List_Id; Success : out Boolean) is Entity : Node_Id; begin Success := True; Entity := First_Entity (L); if Entity = N then Set_Next_Entity (E, Entity); Set_First_Entity (L, E); else loop if No (Entity) then Success := False; return; elsif Next_Entity (Entity) = N then Insert_After_Node (E, Entity); return; end if; Entity := Next_Entity (Entity); end loop; end if; end Insert_Before_Node; procedure Insert_Before_Node (E : Node_Id; N : Node_Id; L : List_Id) is Success : Boolean; begin Insert_Before_Node (E, N, L, Success); pragma Assert (Success); end Insert_Before_Node; -------------------------- -- Fully_Qualified_Name -- -------------------------- function Fully_Qualified_Name (E : Node_Id; Separator : String := "::") return Name_Id is P : Node_Id; begin pragma Assert (Kind (E) = K_Identifier); P := Potential_Scope (E); Name_Len := 0; if Present (P) and then Kind (P) /= K_Specification then Get_Name_String (Fully_Qualified_Name (Identifier (P), Separator)); Add_Str_To_Name_Buffer (Separator); end if; Get_Name_String_And_Append (IDL_Name (E)); return Name_Find; end Fully_Qualified_Name; --------------------- -- Is_A_Forward_Of -- --------------------- function Is_A_Forward_Of (X, Y : Node_Id) return Boolean is KX : constant Node_Kind := Kind (X); KY : constant Node_Kind := Kind (Y); begin case KY is when K_Interface_Declaration | K_Forward_Interface_Declaration => return KX = K_Forward_Interface_Declaration; when K_Structure_Type | K_Forward_Structure_Type => return KX = K_Forward_Structure_Type; when K_Union_Type | K_Forward_Union_Type => return KX = K_Forward_Union_Type; when K_Value_Declaration => return KX = K_Value_Forward_Declaration and then not Is_Abstract_Value (X); when K_Value_Forward_Declaration => return KX = K_Value_Forward_Declaration and then (Is_Abstract_Value (X) = Is_Abstract_Value (Y)); when K_Abstract_Value_Declaration => return KX = K_Value_Forward_Declaration and then Is_Abstract_Value (X); when others => return False; end case; end Is_A_Forward_Of; --------------------- -- Is_A_Local_Type -- --------------------- function Is_A_Local_Type (E : Node_Id) return Boolean is begin return Kind (E) = K_Interface_Declaration and then Is_Local_Interface (E); end Is_A_Local_Type; --------------------- -- Is_A_Non_Module -- --------------------- function Is_A_Non_Module (E : Node_Id) return Boolean is K : constant Node_Kind := Kind (E); begin return K /= K_Module and then K /= K_Specification; end Is_A_Non_Module; ---------------- -- Is_A_Scope -- ---------------- function Is_A_Scope (E : Node_Id) return Boolean is begin case Kind (E) is when K_Module | K_Enumeration_Type | K_Specification | K_Structure_Type | K_Union_Type | K_Value_Declaration | K_Abstract_Value_Declaration | K_Exception_Declaration | K_Interface_Declaration => return True; when others => return False; end case; end Is_A_Scope; --------------- -- Is_Type -- --------------- function Is_Type (E : Node_Id) return Boolean is begin if Is_Noninterface_Type (E) then return True; end if; case Kind (E) is when K_Forward_Interface_Declaration | K_Interface_Declaration => return True; when K_Simple_Declarator | K_Complex_Declarator => return Is_Type (Declaration (E)); when others => return False; end case; end Is_Type; -------------------------- -- Is_Noninterface_Type -- -------------------------- function Is_Noninterface_Type (E : Node_Id) return Boolean is begin case Kind (E) is when K_Type_Declaration | K_Forward_Structure_Type | K_Structure_Type | K_Forward_Union_Type | K_Union_Type | K_Enumeration_Type | K_Native_Type | K_Sequence_Type | K_String | K_Wide_String | K_Fixed_Point_Type | K_Float | K_Double | K_Long_Double | K_Short | K_Long | K_Long_Long | K_Unsigned_Short | K_Unsigned_Long | K_Unsigned_Long_Long | K_Char | K_Wide_Char | K_Boolean | K_Octet | K_Object | K_Any | K_Void | K_Value_Base => return True; when others => return False; end case; end Is_Noninterface_Type; ------------------------------- -- Is_Attribute_Or_Operation -- ------------------------------- function Is_Attribute_Or_Operation (E : Node_Id) return Boolean is K : constant Node_Kind := Kind (E); begin return K = K_Attribute_Declaration or else K = K_Operation_Declaration; end Is_Attribute_Or_Operation; -------------- -- Is_Empty -- -------------- function Is_Empty (L : List_Id) return Boolean is begin return L = No_List or else No (First_Entity (L)); end Is_Empty; ------------------------------------- -- Is_Interface_Redefinable_Node -- ------------------------------------- function Is_Interface_Redefinable_Node (E : Node_Id) return Boolean is begin case Kind (E) is when K_Type_Declaration | K_Constant_Declaration | K_Forward_Structure_Type | K_Structure_Type | K_Forward_Union_Type | K_Union_Type | K_Enumeration_Type | K_Native_Type | K_Sequence_Type | K_String | K_Wide_String | K_Fixed_Point_Type => return True; when others => return False; end case; end Is_Interface_Redefinable_Node; --------------- -- Is_Parent -- --------------- function Is_Parent (Parent : Node_Id; Child : Node_Id; First : Boolean := False) return Boolean is pragma Assert (Kind (Parent) = K_Interface_Declaration and then Kind (Child) = K_Interface_Declaration); Result : Boolean := False; N : Node_Id; begin if not Is_Empty (Interface_Spec (Child)) then N := First_Entity (Interface_Spec (Child)); if First then return Parent = Reference (N); else while Present (N) loop if Parent = Reference (N) then Result := True; end if; N := Next_Entity (N); end loop; return Result; end if; end if; return False; end Is_Parent; ------------------ -- Is_Redefined -- ------------------ function Is_Redefined (Entity : Node_Id; In_Interface : Node_Id) return Boolean is E : Node_Id; Name : Name_Id; begin pragma Assert (Kind (In_Interface) = K_Interface_Declaration); -- This function handles only redefinition of Types (enum, struct...), -- constants and exception. The operation redefinition is not allowed -- in IDL. pragma Assert (Kind (Entity) = K_Simple_Declarator or else Kind (Entity) = K_Complex_Declarator or else Kind (Entity) = K_Enumeration_Type or else Kind (Entity) = K_Structure_Type or else Kind (Entity) = K_Union_Type or else Kind (Entity) = K_Constant_Declaration or else Kind (Entity) = K_Exception_Declaration); Name := IDL_Name (Identifier (Entity)); E := First_Entity (Interface_Body (In_Interface)); while Present (E) loop case (Kind (E)) is when K_Type_Declaration => declare D : Node_Id; begin D := First_Entity (Declarators (E)); while Present (D) loop if Name = IDL_Name (Identifier (D)) then return True; end if; D := Next_Entity (D); end loop; end; when K_Enumeration_Type | K_Structure_Type | K_Union_Type | K_Constant_Declaration | K_Exception_Declaration => if Name = IDL_Name (Identifier (E)) then return True; end if; when others => null; end case; E := Next_Entity (E); end loop; return False; end Is_Redefined; ------------------------------- -- Is_Multidimensional_Array -- ------------------------------- function Is_Multidimensional_Array (D : Node_Id) return Boolean is pragma Assert (Kind (D) = K_Complex_Declarator); Dim : constant Natural := Length (Array_Sizes (D)); begin return Dim > 1; end Is_Multidimensional_Array; ---------------------------------- -- Get_Original_Type_Declarator -- ---------------------------------- function Get_Original_Type_Declarator (E : Node_Id) return Node_Id is N : Node_Id; begin case Kind (E) is when K_Simple_Declarator => N := Type_Spec (Declaration (E)); if Kind (N) = K_Scoped_Name then return Get_Original_Type_Declarator (Reference (N)); else return E; end if; when K_Scoped_Name => N := Reference (E); if Kind (N) = K_Simple_Declarator or else Kind (E) = K_Complex_Declarator then return Get_Original_Type_Declarator (N); else return N; end if; when others => return E; end case; end Get_Original_Type_Declarator; ----------------------------------- -- Get_Original_Type_Declaration -- ----------------------------------- function Get_Original_Type_Declaration (E : Node_Id) return Node_Id is N : Node_Id; begin case Kind (E) is when K_Complex_Declarator | K_Simple_Declarator => N := Type_Spec (Declaration (E)); if Kind (N) = K_Scoped_Name then return Get_Original_Type_Declaration (N); else return Declaration (E); end if; when K_Scoped_Name => N := Reference (E); if Kind (N) = K_Simple_Declarator or else Kind (E) = K_Complex_Declarator then return Get_Original_Type_Declaration (N); else return N; end if; when others => return No_Node; end case; end Get_Original_Type_Declaration; --------------------------------- -- Get_Original_Type_Specifier -- --------------------------------- function Get_Original_Type_Specifier (E : Node_Id) return Node_Id is N : Node_Id; begin -- If 'E' is a declarator, we handle it, else, we handle its -- type spec. case Kind (E) is when K_Complex_Declarator => -- We don't resolve the complex declarators at this point return E; when K_Simple_Declarator => -- We resolve the declaration type spec return Get_Original_Type_Specifier (Type_Spec (Declaration (E))); when K_Scoped_Name => -- We rewind type spec -- A scoped name type designates either a declarator or -- an object. N := Reference (E); if Kind (N) = K_Simple_Declarator then -- We resolve the declaration type spec if Kind (Declaration (N)) = K_Native_Type then return N; else return Get_Original_Type_Specifier (Type_Spec (Declaration (N))); end if; else return N; end if; when others => return E; end case; end Get_Original_Type_Specifier; ------------------------- -- Has_Local_Component -- ------------------------- function Has_Local_Component (E : Node_Id) return Boolean is -- Get the original type Orig_Type : constant Node_Id := Get_Original_Type_Specifier (E); begin case Kind (Orig_Type) is when K_Interface_Declaration | K_Forward_Interface_Declaration => -- For interface type, simply verify that they are local -- interfaces. return Is_Local_Interface (Orig_Type); when K_Complex_Declarator => -- For arrays, we see whether the element type has local -- components. return Has_Local_Component (Type_Spec (Declaration (Orig_Type))); when K_Structure_Type | K_Exception_Declaration => -- For structures and exceptions, we see whether an -- element of the sequence has local components. declare Result : Boolean := False; M : Node_Id := First_Entity (Members (Orig_Type)); begin while Present (M) loop Result := Result or else Has_Local_Component (Type_Spec (M)); M := Next_Entity (M); end loop; return Result; end; when K_Union_Type => -- For unions, we see whether an element of the sequence -- has local components. declare Result : Boolean := False; S : Node_Id := First_Entity (Switch_Type_Body (Orig_Type)); begin while Present (S) loop Result := Result or else Has_Local_Component (Type_Spec (Element (S))); S := Next_Entity (S); end loop; return Result; end; when K_Sequence_Type => -- For sequences, we see whether the element type has -- local components. return Has_Local_Component (Type_Spec (Orig_Type)); when others => return False; end case; end Has_Local_Component; ------------ -- Length -- ------------ function Length (L : List_Id) return Natural is begin return Natural (Size (L)); end Length; ------------------------------- -- Make_Constant_Declaration -- ------------------------------- function Make_Constant_Declaration (Loc : Location; Type_Spec : Node_Id; Identifier : Node_Id; Expression : Node_Id) return Node_Id is N : constant Node_Id := New_Node (K_Constant_Declaration, Loc); begin Set_Type_Spec (N, Type_Spec); Set_Identifier (N, Identifier); Set_Expression (N, Expression); return N; end Make_Constant_Declaration; --------------------- -- Make_Identifier -- --------------------- function Make_Identifier (Loc : Location; IDL_Name : Name_Id; Node : Node_Id; Scope_Entity : Node_Id) return Node_Id is N : constant Node_Id := New_Node (K_Identifier, Loc); begin Set_Name (N, To_Lower (IDL_Name)); Set_IDL_Name (N, IDL_Name); Set_Corresponding_Entity (N, Node); Set_Scope_Entity (N, Scope_Entity); Set_Potential_Scope (N, Scope_Entity); return N; end Make_Identifier; ---------------------- -- Make_Scoped_Name -- ---------------------- function Make_Scoped_Name (Loc : Location; Identifier : Node_Id; Parent : Node_Id; Reference : Node_Id) return Node_Id is N : constant Node_Id := New_Node (K_Scoped_Name, Loc); begin pragma Assert (Kind (Identifier) = K_Identifier); Set_Identifier (N, Identifier); pragma Assert (Kind (Identifier) = K_Identifier); Set_Parent_Entity (N, Parent); Set_Reference (N, Reference); return N; end Make_Scoped_Name; -------------- -- New_Copy -- -------------- function New_Copy (N : Node_Id) return Node_Id is L : Node_Id; begin Entries.Increment_Last; L := Entries.Last; Entries.Table (L) := Entries.Table (N); Set_Loc (L, No_Location); Set_Next_Entity (L, No_Node); if Kind (L) = K_Identifier then Set_Homonym (L, No_Node); end if; return L; end New_Copy; -------------- -- New_List -- -------------- function New_List (Loc : Location) return List_Id is begin return List_Id (New_Node (K_List_Id, Loc)); end New_List; -------------- -- New_Node -- -------------- function New_Node (Kind : Node_Kind; Loc : Location) return Node_Id is N : Node_Id; begin Entries.Increment_Last; N := Entries.Last; Entries.Table (N) := Default_Node; Set_Kind (N, Kind); Set_Loc (N, Loc); return N; end New_Node; -------------- -- Operator -- -------------- function Operator (E : Node_Id) return Operator_Type is O : Operator_Id; begin O := Nodes.Operator (E); return Operator_Type'Val (O); end Operator; -------------------- -- Parameter_Mode -- -------------------- function Parameter_Mode (T : Token_Type) return Mode_Id is begin return Token_Type'Pos (T) - Token_Type'Pos (T_In); end Parameter_Mode; -------------------- -- Parameter_Mode -- -------------------- function Parameter_Mode (M : Mode_Id) return Token_Type is begin return Token_Type'Val (M + Token_Type'Pos (T_In)); end Parameter_Mode; --------------------- -- Get_Pragma_Type -- --------------------- function Get_Pragma_Type (T : Token_Type) return Pragma_Type is begin return Token_Type'Pos (T) - Token_Type'Pos (T_Pragma_Id); end Get_Pragma_Type; --------------------- -- Get_Pragma_Type -- --------------------- function Get_Pragma_Type (P : Pragma_Type) return Token_Type is begin return Token_Type'Val (P + Token_Type'Pos (T_Pragma_Id)); end Get_Pragma_Type; --------------------------- -- Remove_Node_From_List -- --------------------------- procedure Remove_Node_From_List (E : Node_Id; L : List_Id) is C : Node_Id; begin C := First_Entity (L); if C = E then Set_First_Entity (L, Next_Entity (E)); if Last_Entity (L) = E then Set_Last_Entity (L, No_Node); end if; else while Present (C) loop if Next_Entity (C) = E then Set_Next_Entity (C, Next_Entity (E)); if Last_Entity (L) = E then Set_Last_Entity (L, C); end if; exit; end if; C := Next_Entity (C); end loop; end if; end Remove_Node_From_List; ----------------------- -- Set_First_Homonym -- ----------------------- procedure Set_First_Homonym (N : Node_Id; V : Node_Id) is begin Set_Name_Table_Info (Name (N), Int (V)); end Set_First_Homonym; ------------------ -- Set_Operator -- ------------------ procedure Set_Operator (E : Node_Id; O : Operator_Type) is B : Byte; begin B := Operator_Type'Pos (O); Set_Operator (E, Operator_Id (B)); end Set_Operator; ---------------- -- Expr_Value -- ---------------- function Expr_Value (N : Node_Id) return Value_Id is begin -- If N refers to a previously declared constant (concretely, it's a -- scoped name), then use the value of that constant. if Kind (N) = K_Scoped_Name then return Value (Reference (N)); -- Otherwise, it's some other constant expression; use the -- expression's value. else return Value (N); end if; end Expr_Value; function Expr_Value (N : Node_Id) return Values.Value_Type is begin return Values.Value (Expr_Value (N)); end Expr_Value; end Frontend.Nutils; polyorb-2.8~20110207.orig/compilers/iac/backend-be_corba_ada-cdrs.ads0000644000175000017500000000705511750740337024520 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- B A C K E N D . B E _ C O R B A _ A D A . C D R S -- -- -- -- S p e c -- -- -- -- Copyright (C) 2005-2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ -- This package contains routines related to the use of the SII instead of the -- DII in the distributed application. For each operation (or attribute -- accessor), four entities are generated : -- 1/ A record type whose fields corresponds to the operation parameters and -- return type -- 2/ A custom subprogram that marshalls the parameters to a Buffer -- without using the NVList -- 3/ A custom subprogram that unmarshalls the parameters from a Buffer -- without using the NVList -- 4/ A subprogram that adds a note to the request notepad. This note contains -- accesses to the marshalling and unmarshalling subprograms -- The goal of the routines in this package is to avoid the use of the NVList -- when the parameter types are known at compile time. This would -- considerably increase the distributed application performances since the -- NVList are used at 4 times during a request invocation : -- 1/ When the client marshalls the in/inout parameters before sending the -- server -- 2/ When the server unmarshalls the in/inout parameters received from the -- client -- 3/ When the server marshalls the result and the out/inout parameters -- before sending them to the client -- 4/ When the client unmarshalls the result and the out/inout parameters -- received from the server. package Backend.BE_CORBA_Ada.CDRs is package Package_Spec is procedure Visit (E : Node_Id); end Package_Spec; package Package_Body is procedure Visit (E : Node_Id); end Package_Body; end Backend.BE_CORBA_Ada.CDRs; polyorb-2.8~20110207.orig/compilers/iac/parser.adb0000644000175000017500000031656211750740337021122 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- P A R S E R -- -- -- -- B o d y -- -- -- -- Copyright (C) 2005-2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with GNAT.Directory_Operations; with GNAT.Table; with GNAT.OS_Lib; use GNAT.OS_Lib; with Errors; use Errors; with Namet; use Namet; with Scopes; with Values; use Values; with Frontend.Nodes; use Frontend.Nodes; with Frontend.Nutils; use Frontend.Nutils; package body Parser is package FEN renames Frontend.Nodes; Specification : Node_Id; procedure Declare_Base_Type (L : Token_List_Type; K : Node_Kind); -- L denotes a token list used to name an IDL base type. Allocate -- a node for it and associate it to the concatenated names. function Is_Param_Type_Spec (E : Node_Id) return Boolean; -- Return true when the type specifier N belongs to the restricted -- parameter type specifier set. function Locate_Imported_File (Scoped_Name : Node_Id) return Name_Id; -- Locate the IDL file corresponding to the imported scope. Sequencing_Level : Natural := 0; function P_No_Such_Node return Node_Id; pragma Unreferenced (P_No_Such_Node); procedure P_Specification (Imported : Boolean := False); function P_Attribute_Declaration return Node_Id; function P_Constant_Declaration return Node_Id; function P_Constant_Expression return Node_Id; function P_Constant_Type return Node_Id; function P_Declarator return Node_Id; function P_Declarator_List return List_Id; function P_Definition return Node_Id; function P_Enumeration_Type return Node_Id; function P_Exception_Declaration return Node_Id; function P_Exception_List return List_Id; function P_Export return Node_Id; function P_Fixed_Point_Type return Node_Id; function P_Identifier return Node_Id; function P_Import return Node_Id; function P_Initializer_Declaration return Node_Id; function P_Interface return Node_Id; function P_Interface_Declaration return Node_Id; function P_Interface_Name return Node_Id; function P_Member return Node_Id; function P_Module return Node_Id; function P_Operation_Declaration return Node_Id; function P_Parameter_Declaration return Node_Id; function P_Pragma return Node_Id; function P_Scoped_Name return Node_Id; function P_Sequence_Type return Node_Id; function P_Simple_Declarator return Node_Id; function P_Simple_Type_Spec return Node_Id; function P_State_Member return Node_Id; function P_Structure_Type return Node_Id; function P_String_Type return Node_Id; function P_Type_Declaration return Node_Id; function P_Type_Id_Declaration return Node_Id; function P_Type_Prefix_Declaration return Node_Id; function P_Type_Spec return Node_Id; function P_Union_Type return Node_Id; function P_Value return Node_Id; function P_Value_Abstract_Declaration return Node_Id; function P_Value_Box_Declaration return Node_Id; function P_Value_Declaration return Node_Id; function P_Value_Forward_Declaration return Node_Id; function P_Value_Spec return Node_Id; package Expressions is new GNAT.Table (Node_Id, Natural, 1, 100, 10); Preferences : constant array (T_Tilde .. T_Less_Less) of Natural := (T_Tilde => 0, T_Percent => 1, T_Slash => 2, T_Star => 3, T_Minus => 4, T_Plus => 5, T_Less_Less => 6, T_Greater_Greater => 7, T_Ampersand => 8, T_Circumflex => 9, T_Bar => 10); ----------------------- -- Declare_Base_Type -- ----------------------- procedure Declare_Base_Type (L : Token_List_Type; K : Node_Kind) is E : Node_Id; N : Name_Id; begin -- Create a fake node located at the beginning of the -- specification (current token location). E := New_Node (K, No_Location); -- Accumulate token names and store node id as table info Set_Str_To_Name_Buffer (Image (L (L'First))); for I in L'First + 1 .. L'Last loop Add_Char_To_Name_Buffer (' '); Add_Str_To_Name_Buffer (Image (L (I))); end loop; N := Name_Find; Set_Name_Table_Info (N, Int (E)); Set_Image (Base_Type (E), N); end Declare_Base_Type; ------------------------ -- Is_Param_Type_Spec -- ------------------------ -- (95) ::= -- | -- | -- | function Is_Param_Type_Spec (E : Node_Id) return Boolean is begin case Kind (E) is when K_Float | K_Double | K_Long_Double | K_Short | K_Long | K_Long_Long | K_Unsigned_Short | K_Unsigned_Long | K_Unsigned_Long_Long | K_Char | K_Wide_Char | K_Boolean | K_Any | K_Object | K_Octet | K_Value_Base | K_String | K_Wide_String | K_String_Type | K_Wide_String_Type | K_Scoped_Name => return True; when others => return False; end case; end Is_Param_Type_Spec; -------------------------- -- Locate_Imported_File -- -------------------------- function Locate_Imported_File (Scoped_Name : Node_Id) return Name_Id is pragma Assert (Kind (Scoped_Name) = K_Scoped_Name); -- Whatever the nature of the scoped name is (::X, ::X::Y::Z, X::Y...), -- the file name is deduced from the deepest parent entity Parent : Node_Id := Parent_Entity (Scoped_Name); Parent_Enity_Name : Name_Id := IDL_Name (Identifier (Scoped_Name)); begin while Present (Parent) loop if IDL_Name (Identifier (Parent)) /= No_Name then Parent_Enity_Name := IDL_Name (Identifier (Parent)); end if; Parent := Parent_Entity (Parent); end loop; Get_Name_String (Parent_Enity_Name); -- Handling the particular cases : -- CORBA module is declared in the orb.idl file if Name_Buffer (1 .. Name_Len) = "CORBA" then Set_Str_To_Name_Buffer ("orb"); end if; -- Adding the file suffix Add_Str_To_Name_Buffer (".idl"); -- Locating the file in the IAC_Search_Paths set declare File_Name_Str : constant String := Name_Buffer (1 .. Name_Len); begin for Index in 1 .. IAC_Search_Count loop declare Full_Path : constant String := IAC_Search_Paths (Index).all & GNAT.Directory_Operations.Dir_Separator & File_Name_Str; begin if Is_Regular_File (Full_Path) then Set_Str_To_Name_Buffer (Full_Path); return Name_Find; end if; end; end loop; end; return No_Name; end Locate_Imported_File; ----------------------------- -- P_Attribute_Declaration -- ----------------------------- -- (85) ::= -- | -- (104) ::= "readonly" "attribute" -- -- (105) ::= -- | -- { "," }* -- (106) ::= "attribute" -- -- (107) ::= -- | -- { "," }* -- (108) ::= [ ] -- | function P_Attribute_Declaration return Node_Id is Attribute_Decl : Node_Id; Attr_Type_Spec : Node_Id; Is_Readonly : Boolean := False; Declarators : List_Id; Declarator : Node_Id; Getter_Excps : List_Id := No_List; Setter_Excps : List_Id := No_List; begin Scan_Token; -- past "readonly" or "attribute" if Token = T_Readonly then Is_Readonly := True; Scan_Token (T_Attribute); if Token = T_Error then return No_Node; end if; end if; -- Read general type specifier Attr_Type_Spec := P_Type_Spec; if No (Attr_Type_Spec) then return No_Node; end if; -- Check that the type specifier follows the restriction of the -- parameter type specifier. if not Is_Param_Type_Spec (Attr_Type_Spec) then Error_Loc (1) := Loc (Attr_Type_Spec); DE ("incorrect attribute type spec"); return No_Node; end if; Declarators := P_Declarator_List; if Is_Empty (Declarators) then return No_Node; end if; -- Parsing the exception list of the attribute : -- According to the CORBA 3.0 IDL grammar (rules 105 and 107), only -- attributes that have one single declarator can throw exceptions. -- This limitation is not justifyed in the CORBA Spec. -- In IAC, we accept that attributes that have more than one declarator -- throw exceptions -- Case of a readonly attribute : if Next_Token = T_Raises then if not Is_Readonly then Error_Loc (1) := Token_Location; DE ("Key word 'raises' not allowed for read-write attributes"); return No_Node; end if; Getter_Excps := P_Exception_List; if Getter_Excps = No_List then return No_Node; end if; end if; -- Case of read-write attributes if Next_Token = T_Get_Raises then if Is_Readonly then Error_Loc (1) := Token_Location; DE ("Key word 'getraises' not allowed for readonly attributes"); return No_Node; end if; Getter_Excps := P_Exception_List; if Getter_Excps = No_List then return No_Node; end if; end if; if Next_Token = T_Set_Raises then if Is_Readonly then Error_Loc (1) := Token_Location; DE ("Key word 'setraises' not allowed for readonly attributes"); return No_Node; end if; Setter_Excps := P_Exception_List; if Setter_Excps = No_List then return No_Node; end if; end if; Attribute_Decl := New_Node (K_Attribute_Declaration, Loc (Attr_Type_Spec)); Set_Is_Readonly (Attribute_Decl, Is_Readonly); Set_Type_Spec (Attribute_Decl, Attr_Type_Spec); Set_Declarators (Attribute_Decl, Declarators); Bind_Declarators_To_Entity (Declarators, Attribute_Decl); Set_Getter_Exceptions (Attribute_Decl, Getter_Excps); Set_Setter_Exceptions (Attribute_Decl, Setter_Excps); Declarator := First_Entity (Declarators); while Present (Declarator) loop if Kind (Declarator) /= K_Simple_Declarator then Error_Loc (1) := Loc (Declarator); DE ("incorrect attribute declarator"); return No_Node; end if; Declarator := Next_Entity (Declarator); end loop; return Attribute_Decl; end P_Attribute_Declaration; ---------------------------- -- P_Constant_Declaration -- ---------------------------- -- (27) ::= "const" "=" function P_Constant_Declaration return Node_Id is Constant_Decl : Node_Id; Const_Type_Spec : Node_Id; Const_Expr : Node_Id; begin Scan_Token; -- past "const" Const_Type_Spec := P_Constant_Type; if No (Const_Type_Spec) then return No_Node; end if; Constant_Decl := P_Simple_Declarator; if No (Constant_Decl) then return No_Node; end if; Set_Kind (Constant_Decl, K_Constant_Declaration); Set_Type_Spec (Constant_Decl, Const_Type_Spec); Scan_Token (T_Equal); if Token = T_Error then return No_Node; end if; Const_Expr := P_Constant_Expression; if No (Const_Expr) then return No_Node; end if; Set_Expression (Constant_Decl, Const_Expr); return Constant_Decl; end P_Constant_Declaration; --------------------------- -- P_Constant_Expression -- --------------------------- -- (29) ::= -- (30) ::= -- | "|" -- (31) ::= -- | "^" -- (32) ::= -- | "&" -- (33) ::= -- | ">>" -- | "<<" -- (34) ::= -- | "+" -- | "-" -- (35) ::= -- | "*" -- | "/" -- | "%" -- (36) ::= -- | -- (37) ::= "-" -- | "+" -- | "~" -- (38) ::= -- | -- | "(" ")" function P_Constant_Expression return Node_Id is use Expressions; -- There are two kinds of expressions. A binary operator has -- two inner expressions (left and right). When the right -- expression is assigned and not the left one, the operator is -- an unary operator and this expression is considered as an -- expression value. When both inner expressions are assigned, -- this is also an expression value. An operator is a binary -- operator when at least the right expression is not -- assigned. An expression value can be an operator with at -- least a right expression assigned or a literal or a scoped -- name. function Is_Expression_Completed return Boolean; -- Return True when there are no more token to read to complete -- the current expression. function P_Expression_Part return Node_Id; -- XXX LP: Cannot parse comment -- Return a node describing an expression. It is either a -- binary operator (an operator with no right expression -- assigned) or an expression value (a scoped name, a literal -- or an expression with an unary operator - that is a binary -- operator with a right inner expression and no left inner -- expression - or an expression with both inner expressions -- assigned). Note that whether an operator is a binary or -- unary operator is resolved in this routine. For a unary -- operator, we check that the previous token was a binary -- operator. function Is_Binary_Operator (E : Node_Id) return Boolean; -- Return True when N is an operator with the right expression -- still not assigned. Otherwise, an operator with a right -- expression is a value expression. function Is_Expression_Value (E : Node_Id) return Boolean; -- Return True when N is not an operator (literal or scoped -- name) or else when its right expression is assigned (unary -- operator). function Precede (L, R : Node_Id) return Boolean; -- Does operator L precedes operator R procedure Exp_Err_Msg; -- Standard error message procedure Exp_Err_Msg is begin DE ("cannot parse expression"); end Exp_Err_Msg; ----------------------------- -- Is_Expression_Completed -- ----------------------------- function Is_Expression_Completed return Boolean is T : constant Token_Type := Next_Token; begin return T not in Literal_Type and then T /= T_Identifier and then T /= T_Colon_Colon and then T /= T_Left_Paren and then T not in Operator_Type; end Is_Expression_Completed; ------------------------- -- Is_Expression_Value -- ------------------------- function Is_Expression_Value (E : Node_Id) return Boolean is begin return Kind (E) in K_Integer_Literal .. K_Boolean_Literal or else Kind (E) = K_Scoped_Name or else (Operator (E) in Unary_Operator_Type and then Present (Right_Expr (E))) or else (Operator (E) in Binary_Operator_Type and then Present (Left_Expr (E)) and then Present (Right_Expr (E))); end Is_Expression_Value; ------------------------ -- Is_Binary_Operator -- ------------------------ function Is_Binary_Operator (E : Node_Id) return Boolean is begin return Kind (E) = K_Expression and then Operator (E) in Binary_Operator_Type and then No (Right_Expr (E)); end Is_Binary_Operator; ----------------------- -- P_Expression_Part -- ----------------------- function P_Expression_Part return Node_Id is Expression : Node_Id := No_Node; Right_Expr : Node_Id; Previous_Token : Token_Type; begin case Next_Token is when T_Identifier | T_Colon_Colon => -- Look for a scoped name Expression := P_Scoped_Name; if No (Expression) then return No_Node; end if; when T_Left_Paren => -- Look for a parenthesized expression value Scan_Token; -- past '(' Expression := P_Constant_Expression; Scan_Token (T_Right_Paren); if Token = T_Error then return No_Node; end if; when T_Integer_Literal => Scan_Token; -- past literal Expression := New_Node (K_Integer_Literal, Token_Location); Set_Value (Expression, New_Integer_Value (Value => Integer_Literal_Value, Sign => 1, Base => Integer_Literal_Base)); when T_Fixed_Point_Literal => Scan_Token; -- past literal Expression := New_Node (K_Fixed_Point_Literal, Token_Location); Set_Value (Expression, New_Fixed_Point_Value (Value => Integer_Literal_Value, Sign => 1, Total => Unsigned_Short_Short (Name_Len), Scale => Decimal_Point_Position)); when T_Boolean_Literal => Scan_Token; -- past literal Expression := New_Node (K_Boolean_Literal, Token_Location); Set_Value (Expression, New_Boolean_Value (Value => (Integer_Literal_Value = 1))); when T_Floating_Point_Literal => Scan_Token; -- past literal Expression := New_Node (K_Floating_Point_Literal, Token_Location); Set_Value (Expression, New_Floating_Point_Value (Float_Literal_Value)); when T_Character_Literal | T_Wide_Character_Literal => Scan_Token; -- past literal if Character_Literal_Value /= Incorrect_Character then Expression := New_Node (K_Character_Literal, Token_Location); Set_Value (Expression, New_Character_Value (Character_Literal_Value, (Token /= T_Character_Literal))); end if; when T_String_Literal | T_Wide_String_Literal => Scan_Token; -- past literal if String_Literal_Value /= Incorrect_String then Expression := New_Node (K_String_Literal, Token_Location); Set_Value (Expression, New_String_Value (String_Literal_Value, (Token /= T_String_Literal))); end if; when T_Tilde .. T_Less_Less => -- Look for a binary/unary operator Previous_Token := Token; Scan_Token; -- past binary/unary operator Expression := New_Node (K_Expression, Token_Location); Set_Operator (Expression, Token); -- Token is a real unary operator if Token = T_Tilde or else (Token in T_Minus .. T_Plus and then not Is_Literal (Previous_Token) and then not Is_Scoped_Name (Previous_Token) and then Previous_Token /= T_Right_Paren) then case Next_Token is when T_Identifier | T_Colon_Colon | T_Left_Paren | Literal_Type => -- Look for an expression value (a scoped -- name, a literal or a parenthesized -- expression). Right_Expr := P_Constant_Expression; if No (Right_Expr) then Error_Loc (1) := Loc (Expression); Exp_Err_Msg; return No_Node; end if; Set_Right_Expr (Expression, Right_Expr); when others => Unexpected_Token (Token, "expression"); return No_Node; end case; -- Cannot have two following operators except in the -- special case above. elsif Is_Operator (Previous_Token) then Unexpected_Token (Token, "expression"); return No_Node; end if; when others => Error_Loc (1) := Token_Location; Exp_Err_Msg; return No_Node; end case; return Expression; end P_Expression_Part; ------------- -- Precede -- ------------- function Precede (L, R : Node_Id) return Boolean is Op_L : constant Token_Type := Operator (L); Op_R : constant Token_Type := Operator (R); begin return Preferences (Op_L) <= Preferences (Op_R); end Precede; Expr : Node_Id; First : Natural; begin -- Read enough expressions to push as first expression a binary -- operator with no right expression Expr := P_Expression_Part; if No (Expr) then return No_Node; end if; -- We must have first an expression value if Is_Binary_Operator (Expr) then Error_Loc (1) := Loc (Expr); Exp_Err_Msg; return No_Node; end if; -- We have only one expression value if Is_Expression_Completed then return Expr; end if; Increment_Last; Table (Last) := Expr; First := Last; Expr := P_Expression_Part; if No (Expr) then Set_Last (First - 1); return No_Node; end if; -- We must have a binary operator as the first expression is an -- expression value. if not Is_Binary_Operator (Expr) then Error_Loc (1) := Loc (Expr); Exp_Err_Msg; Set_Last (First - 1); return No_Node; end if; Set_Left_Expr (Expr, Table (Last)); Table (Last) := Expr; -- Push expressions in stack and check that the top of the -- stack consists in one or more binary operators with no -- right expr and zero or one expression value. while not Is_Expression_Completed loop Expr := P_Expression_Part; if No (Expr) then return No_Node; end if; Increment_Last; Table (Last) := Expr; -- Check that this new expression is not a binary operator -- when the previous one is a binary operator with no right -- expression. if First < Last and then Is_Binary_Operator (Expr) and then No (Left_Expr (Expr)) and then Is_Binary_Operator (Table (Last - 1)) then Error_Loc (1) := Loc (Expr); Exp_Err_Msg; Set_Last (First - 1); return No_Node; end if; -- Check whether we have a sequence of a binary operator -- (left operator), an expression value and another binary -- operator (right operator). In this case, if the left -- operator has a better precedence than the right one, we -- can reduce the global expression by assigning the -- expression value to the right expression of the left -- operator. Then as the left operator has already a left -- expression, it becomes an expression value which can be -- assign to the left expression of the right operation. -- Recompute the size of the expression stack. while First + 1 < Last and then Is_Expression_Value (Table (Last - 1)) and then Precede (Table (Last - 2), Expr) loop Set_Right_Expr (Table (Last - 2), Table (Last - 1)); Table (Last - 1) := Table (Last); Set_Last (Last - 1); if No (Left_Expr (Table (Last - 1))) then Set_Left_Expr (Table (Last - 1), Table (Last - 2)); Table (Last - 2) := Table (Last - 1); Table (Last - 1) := Table (Last); Set_Last (Last - 1); end if; end loop; end loop; -- The last expression is not a value. We cannot reduce the -- global expression if Is_Binary_Operator (Table (Last)) then Error_Loc (1) := Loc (Table (Last)); Exp_Err_Msg; Set_Last (First - 1); return No_Node; end if; -- Reduce the global expression while First < Last loop Set_Right_Expr (Table (Last - 1), Table (Last)); Set_Last (Last - 1); if No (Left_Expr (Table (Last))) then Set_Left_Expr (Table (Last), Table (Last - 1)); Table (Last - 1) := Table (Last); Set_Last (Last - 1); end if; end loop; Expr := Table (First); Set_Last (First - 1); return Expr; end P_Constant_Expression; --------------------- -- P_Constant_Type -- --------------------- -- (28) ::= -- | -- | -- | -- | -- | -- | -- | -- | -- | function P_Constant_Type return Node_Id is Const_Type : Node_Id; State : Location; begin -- Use P_Simple_Type_Spec and reject incorrect type specifiers. Save_Lexer (State); Const_Type := P_Simple_Type_Spec; if Present (Const_Type) then case Kind (Const_Type) is when K_Any | K_Object | K_Value_Base | K_Sequence_Type | K_Fixed_Point_Type => Restore_Lexer (State); Unexpected_Token (Next_Token, "type specifier"); return No_Node; when others => return Const_Type; end case; else return No_Node; end if; end P_Constant_Type; ------------------ -- P_Declarator -- ------------------ -- (50) ::= -- | -- (51) ::= -- (52) ::= -- -- (83) ::= + -- (84) ::= "[" "]" function P_Declarator return Node_Id is Identifier : Node_Id; Array_Sizes : List_Id; Array_Size : Node_Id; Node : Node_Id; begin Identifier := P_Identifier; if No (Identifier) then return No_Node; end if; if Next_Token /= T_Left_Bracket then Node := New_Node (K_Simple_Declarator, Loc (Identifier)); Bind_Identifier_To_Entity (Identifier, Node); return Node; end if; Node := New_Node (K_Complex_Declarator, Loc (Identifier)); Bind_Identifier_To_Entity (Identifier, Node); Array_Sizes := New_List (Token_Location); Set_Array_Sizes (Node, Array_Sizes); loop Scan_Token; -- past '[' Array_Size := P_Constant_Expression; if No (Array_Size) then return No_Node; end if; Append_To (Array_Sizes, Array_Size); Scan_Token (T_Right_Bracket); if Token = T_Error then return No_Node; end if; exit when Next_Token /= T_Left_Bracket; end loop; return Node; end P_Declarator; ----------------------- -- P_Declarator_List -- ----------------------- -- (49) ::= { "," } function P_Declarator_List return List_Id is List : List_Id; Node : Node_Id; begin List := New_List (Token_Location); loop Node := P_Declarator; if No (Node) then return List; end if; Append_To (List, Node); exit when Next_Token /= T_Comma; Scan_Token; -- past ',' end loop; return List; end P_Declarator_List; ------------------ -- P_Definition -- ------------------ -- (2) ::= ";" -- | ";" -- | ";" -- | ";" -- | ";" -- | ";" -- | ";" -- | ";" function P_Definition return Node_Id is Definition : Node_Id := No_Node; State : Location; Token_Backup : Token_Type; begin Save_Lexer (State); Scan_Token; Token_Backup := Token; case Token is when T_Typedef | T_Struct | T_Union | T_Enum | T_Native => Restore_Lexer (State); Definition := P_Type_Declaration; when T_Const => Restore_Lexer (State); Definition := P_Constant_Declaration; when T_Exception => Restore_Lexer (State); Definition := P_Exception_Declaration; when T_Abstract | T_Local => Scan_Token ((T_Interface, T_Value_Type)); if Token = T_Interface then Restore_Lexer (State); Definition := P_Interface; elsif Token = T_Value_Type then Restore_Lexer (State); Definition := P_Value; end if; when T_Interface => Restore_Lexer (State); Definition := P_Interface; when T_Module => Restore_Lexer (State); Definition := P_Module; when T_Value_Type | T_Custom => Restore_Lexer (State); Definition := P_Value; when T_Pragma => Restore_Lexer (State); Definition := P_Pragma; when T_Type_Id => Restore_Lexer (State); Definition := P_Type_Id_Declaration; when T_Type_Prefix => Restore_Lexer (State); Definition := P_Type_Prefix_Declaration; when others => Unexpected_Token (Token, "definition"); end case; -- The definition is successfully parsed -- Particular case when parsing a typeprefix or a typeid statement: -- The IDL grammar is clear: -- (2) ::= ";" -- | ";" -- | ";" -- | ";" -- | ";" -- | ";" -- | ";" -- | ";" -- The last two lines show that a semi-colon is required after a -- and . -- However, in some OMG idl files (including orb.idl), there is no -- semi-colon after typeprefix statement. This issue has been discussed -- in OMG issue 3299: http://www.omg.org/issues/issue3299.txt -- but no solution has been accepted, and the issue is still pending. -- We therefore support a relaxed IDL syntax for the purpose of parsing -- standard OMG idl files, accepting specifications lacking the -- semicolon. When OMG standard IDLs are fixed, this work-around can -- be removed. -- The same situation is encountered when parsing an import statement. if Present (Definition) and then Kind (Definition) /= K_Pragma then Save_Lexer (State); Scan_Token; if Token /= T_Semi_Colon then Error_Loc (1) := Token_Location; if Token_Backup = T_Type_Id or else Token_Backup = T_Type_Prefix then DE ("?semicolon expected"); else DE ("semicolon expected"); Definition := No_Node; end if; Restore_Lexer (State); end if; elsif No (Definition) then Restore_Lexer (State); Skip_Declaration (T_Semi_Colon); end if; return Definition; end P_Definition; ------------------------ -- P_Enumeration_Type -- ------------------------ -- (78) ::= "enum" -- "{" { "," } "}" -- -- (79) ::= function P_Enumeration_Type return Node_Id is Identifier : Node_Id; Node : Node_Id; Enumerator : Node_Id; Enumerators : List_Id; State : Location; Position : Unsigned_Long_Long := 0; begin Scan_Token; -- past "enum" Node := New_Node (K_Enumeration_Type, Token_Location); Identifier := P_Identifier; if No (Identifier) then return No_Node; end if; Bind_Identifier_To_Entity (Identifier, Node); Scan_Token (T_Left_Brace); if Token = T_Error then return No_Node; end if; Enumerators := New_List (Token_Location); Set_Enumerators (Node, Enumerators); loop -- Save lexer state in order to skip the enumerator list on error Save_Lexer (State); Identifier := P_Identifier; if No (Identifier) then Restore_Lexer (State); Skip_Declaration (T_Right_Brace); exit; end if; Enumerator := New_Node (K_Enumerator, Loc (Identifier)); Bind_Identifier_To_Entity (Identifier, Enumerator); Append_To (Enumerators, Enumerator); Position := Position + 1; Set_Value (Enumerator, New_Enumerator (IDL_Name (Identifier), Position)); Save_Lexer (State); Scan_Token ((T_Comma, T_Right_Brace)); if Token /= T_Comma then if Token = T_Error then Restore_Lexer (State); Skip_Declaration (T_Right_Brace); end if; exit; end if; end loop; return Node; end P_Enumeration_Type; ----------------------------- -- P_Exception_Declaration -- ----------------------------- -- (86) ::= "exception" "{" * "}" function P_Exception_Declaration return Node_Id is Identifier : Node_Id; Node : Node_Id; Member : Node_Id; Members : List_Id; State : Location; begin Scan_Token; -- past "exception" Node := New_Node (K_Exception_Declaration, Token_Location); Identifier := P_Identifier; if No (Identifier) then return No_Node; end if; Bind_Identifier_To_Entity (Identifier, Node); Scan_Token (T_Left_Brace); if Token = T_Error then return No_Node; end if; Members := New_List (Token_Location); Set_Members (Node, Members); loop if Next_Token = T_Right_Brace then Scan_Token; -- past '}' exit; end if; -- Save lexer state to skip exception member list on error Save_Lexer (State); Member := P_Member; if No (Member) then Restore_Lexer (State); Skip_Declaration (T_Right_Brace); exit; end if; Append_To (Members, Member); end loop; return Node; end P_Exception_Declaration; ---------------------- -- P_Exception_List -- ---------------------- -- (93) ::= "raises" "(" -- { "," } ")" -- (109) ::= "getraises" -- (110) ::= "setraises" -- (111) ::= "(" -- { "," } * ")" function P_Exception_List return List_Id is Exception_List : List_Id; Scoped_Name : Node_Id; State : Location; begin Scan_Token; -- past "raises", "getraises" or "setraises" Scan_Token (T_Left_Paren); if Token = T_Error then return No_List; end if; Exception_List := New_List (Token_Location); loop Save_Lexer (State); Scoped_Name := P_Scoped_Name; if No (Scoped_Name) then Restore_Lexer (State); Skip_Declaration (T_Right_Paren); exit; end if; Append_To (Exception_List, Scoped_Name); Save_Lexer (State); Scan_Token ((T_Comma, T_Right_Paren)); if Token /= T_Comma then if Token = T_Error then Restore_Lexer (State); Skip_Declaration (T_Right_Paren); end if; exit; end if; end loop; return Exception_List; end P_Exception_List; -------------- -- P_Export -- -------------- -- (9) ::= ";" -- | ";" -- | ";" -- | ";" -- | ";" function P_Export return Node_Id is State : Location; Export : Node_Id; begin -- Save lexer state to skip declaration on error Save_Lexer (State); Scan_Token; case Token is when T_Const => Restore_Lexer (State); Export := P_Constant_Declaration; when T_Exception => Restore_Lexer (State); Export := P_Exception_Declaration; when T_Attribute | T_Readonly => Restore_Lexer (State); Export := P_Attribute_Declaration; when T_Typedef | T_Struct | T_Union | T_Enum | T_Native => Restore_Lexer (State); Export := P_Type_Declaration; when T_Pragma => Restore_Lexer (State); Export := P_Pragma; when T_Type_Id => Restore_Lexer (State); Export := P_Type_Id_Declaration; when T_Type_Prefix => Restore_Lexer (State); Export := P_Type_Prefix_Declaration; when others => Restore_Lexer (State); Export := P_Operation_Declaration; end case; if Present (Export) and then Kind (Export) /= K_Pragma then Scan_Token (T_Semi_Colon); end if; if Token = T_Error then Export := No_Node; end if; if No (Export) then Restore_Lexer (State); Skip_Declaration (T_Semi_Colon); return No_Node; end if; return Export; end P_Export; ------------------------ -- P_Fixed_Point_Type -- ------------------------ -- (96) ::= "fixed" "<" "," -- ">" -- -- (97) ::= "fixed" function P_Fixed_Point_Type return Node_Id is Node : Node_Id; begin Scan_Token; -- past "fixed" Node := New_Node (K_Fixed_Point_Type, Token_Location); if Next_Token = T_Less then Scan_Token; -- past '<' Scan_Token (T_Integer_Literal); if Token = T_Error then return No_Node; end if; if Integer_Literal_Sign < 0 or else Integer_Literal_Value > 31 then Error_Loc (1) := Token_Location; DE ("fixed point values must have between 0 and 31 digits"); return No_Node; end if; Set_N_Total (Node, Int (Integer_Literal_Value)); Scan_Token (T_Comma); if Token = T_Error then return No_Node; end if; Scan_Token (T_Integer_Literal); if Token = T_Error then return No_Node; end if; if Integer_Literal_Sign < 0 or else Integer_Literal_Value > 31 then Error_Loc (1) := Token_Location; DE ("fixed point values must have between 0 and 31 digits"); return No_Node; end if; if N_Total (Node) < Int (Integer_Literal_Value) then Error_Loc (1) := Token_Location; DE ("fixed point scale factor is greater than number of digits"); return No_Node; end if; Set_N_Scale (Node, Int (Integer_Literal_Value)); Scan_Token (T_Greater); if Token = T_Error then return No_Node; end if; end if; return Node; end P_Fixed_Point_Type; ------------------ -- P_Identifier -- ------------------ function P_Identifier return Node_Id is begin Scan_Token (T_Identifier); if Token = T_Error then return No_Node; end if; return Make_Identifier (Token_Location, Token_Name, No_Node, No_Node); end P_Identifier; -------------- -- P_Import -- -------------- -- (100) ::= "import" ";" -- (101) ::= | -- The string literal is an interface repository ID of an IDL scoped name -- The import of interface repository ID is not supported by IAC function P_Import return Node_Id is State : Location; Import_Node : Node_Id; Import_Location : Location; Imported_Scope : Node_Id; begin Scan_Token; -- past import Import_Location := Token_Location; Save_Lexer (State); Scan_Token; -- past "::" if Token /= T_Colon_Colon then Error_Loc (1) := Token_Location; DE ("Only identifier relative global scope now allowed " & "(IAC restriction)"); return No_Node; end if; Restore_Lexer (State); Imported_Scope := P_Scoped_Name; Import_Node := New_Node (K_Import, Import_Location); Set_Imported_Scope (Import_Node, Imported_Scope); -- The import is successfully parsed -- See discussion in P_Definition for relaxed syntax exception (we -- accept an import declaration without a terminating semicolon). if Present (Imported_Scope) then Save_Lexer (State); Scan_Token; if Token /= T_Semi_Colon then Restore_Lexer (State); Error_Loc (1) := Token_Location; DE ("?semicolon expected"); end if; end if; -- Now, we parse the file corresponding to the imported scope -- FIXME: Note that even if the imported scope covers only a part -- of a file and not a whole file, all the entities in this file -- will be visible declare Imported_File : File_Descriptor; Imported_File_Name : Name_Id; begin Imported_File_Name := Locate_Imported_File (Imported_Scope); if Imported_File_Name = No_Name then Error_Loc (1) := Loc (Imported_Scope); Error_Name (1) := IDL_Name (Identifier (Imported_Scope)); DE ("declaration of imported scope# not found"); return No_Node; end if; if not Handled (Imported_File_Name) then Set_Handled (Imported_File_Name); Lexer.Preprocess (Imported_File_Name, Imported_File); Lexer.Process (Imported_File, Imported_File_Name); P_Specification (Imported => True); Finalize_Imported; end if; end; return Import_Node; end P_Import; ------------------------------- -- P_Initializer_Declaration -- ------------------------------- -- (23) ::= "factory" -- "(" [ ] ")" ";" -- (24) ::= -- { "," }* -- (25) ::= -- function P_Initializer_Declaration return Node_Id is Identifier : Node_Id; Node : Node_Id; Parameters : List_Id; Parameter : Node_Id; State : Location; begin Scan_Token; -- past "factory" Node := New_Node (K_Initializer_Declaration, Token_Location); Identifier := P_Identifier; if No (Identifier) then return No_Node; end if; Bind_Identifier_To_Entity (Identifier, Node); Scan_Token (T_Left_Paren); if Token = T_Error then return No_Node; end if; Parameters := New_List (Token_Location); Set_Parameters (Node, Parameters); loop -- Check the parameter mode is "in". Then parse a general -- parameter declaration. Save_Lexer (State); if Next_Token = T_In then Parameter := P_Parameter_Declaration; if No (Parameter) then Restore_Lexer (State); Skip_Declaration (T_Right_Paren); exit; end if; Append_To (Parameters, Parameter); end if; Save_Lexer (State); Scan_Token ((T_Right_Paren, T_Comma)); if Token /= T_Comma then if Token = T_Error then Restore_Lexer (State); Skip_Declaration (T_Right_Paren); end if; exit; end if; end loop; Scan_Token (T_Semi_Colon); if Token = T_Error then Restore_Lexer (State); Skip_Declaration (T_Semi_Colon); Node := No_Node; end if; return Node; end P_Initializer_Declaration; ----------------- -- P_Interface -- ----------------- -- (4) ::= -- | function P_Interface return Node_Id is Identifier : Node_Id; Node : Node_Id; Is_Abstract : Boolean := False; Is_Local : Boolean := False; State : Location; Fwd_Loc : Location; begin Save_Lexer (State); Scan_Token; -- past "abstract", "local" or "interface" Fwd_Loc := Token_Location; if Token = T_Abstract then Is_Abstract := True; Scan_Token; -- past "interface" elsif Token = T_Local then Is_Local := True; Scan_Token; -- past "interface" end if; Identifier := P_Identifier; if No (Identifier) then return No_Node; end if; case Next_Token is when T_Semi_Colon => Node := New_Node (K_Forward_Interface_Declaration, Fwd_Loc); Bind_Identifier_To_Entity (Identifier, Node); Set_Is_Abstract_Interface (Node, Is_Abstract); Set_Is_Local_Interface (Node, Is_Local); when T_Left_Brace | T_Colon => Restore_Lexer (State); return P_Interface_Declaration; when others => return No_Node; end case; return Node; end P_Interface; ----------------------------- -- P_Interface_Declaration -- ----------------------------- -- (5) ::= "{" "}" -- (7) ::= -- [ "abstract" | "local" ] "interface" -- [ ] -- (8) ::= * -- (10) ::= ":" -- { "," } * function P_Interface_Declaration return Node_Id is Identifier : Node_Id; Node : Node_Id; Interface_Body : List_Id; Export : Node_Id; Interface_Spec : List_Id; Interface_Name : Node_Id; State : Location; begin Scan_Token; -- past "abstract" or "interface" Node := New_Node (K_Interface_Declaration, Token_Location); if Token = T_Abstract then Set_Is_Abstract_Interface (Node, True); Scan_Token; -- past "interface" elsif Token = T_Local then Set_Is_Local_Interface (Node, True); Scan_Token; -- past "interface" end if; Identifier := P_Identifier; Bind_Identifier_To_Entity (Identifier, Node); -- Always create an interface inheritance specifier even if it -- is left empty. Interface_Spec := New_List (Token_Location); Set_Interface_Spec (Node, Interface_Spec); -- Parse interface inheritance specifier if Next_Token = T_Colon then Scan_Token; -- past ':' loop Interface_Name := P_Interface_Name; if No (Interface_Name) then return No_Node; end if; Append_To (Interface_Spec, Interface_Name); exit when Next_Token /= T_Comma; Scan_Token; -- past ',' end loop; end if; -- Parse interface body Scan_Token (T_Left_Brace); if Token = T_Error then return No_Node; end if; Interface_Body := New_List (Token_Location); Set_Interface_Body (Node, Interface_Body); loop if Next_Token = T_Right_Brace then Scan_Token; -- past '}' exit; end if; -- Parse export. Save lexer state to skip interface body on -- error. Save_Lexer (State); Export := P_Export; if No (Export) then Restore_Lexer (State); Skip_Declaration (T_Right_Brace); exit; end if; Append_To (Interface_Body, Export); end loop; return Node; end P_Interface_Declaration; ---------------------- -- P_Interface_Name -- ---------------------- -- (11) ::= function P_Interface_Name return Node_Id is begin return P_Scoped_Name; end P_Interface_Name; -------------- -- P_Member -- -------------- -- (71) ::= ";" -- (49) ::= { "," } function P_Member return Node_Id is Member : Node_Id; Declarators : List_Id; Type_Spec : Node_Id; State : Location; begin -- Parse type specifier. Save lexer state to skip declaration -- on error. Save_Lexer (State); Type_Spec := P_Type_Spec; if No (Type_Spec) then Restore_Lexer (State); Skip_Declaration (T_Semi_Colon); return No_Node; end if; -- Parse declarators. Save lexer state to skip declarators on -- error. Save_Lexer (State); Declarators := P_Declarator_List; if No (Declarators) then Restore_Lexer (State); Skip_Declaration (T_Semi_Colon); return No_Node; end if; Member := New_Node (K_Member, Loc (Type_Spec)); Set_Type_Spec (Member, Type_Spec); Set_Declarators (Member, Declarators); Bind_Declarators_To_Entity (Declarators, Member); Scan_Token (T_Semi_Colon); if Token = T_Error then return No_Node; end if; return Member; end P_Member; -------------- -- P_Module -- -------------- -- (3) ::= "module" "{" + "}" function P_Module return Node_Id is Identifier : Node_Id; Node : Node_Id; Definitions : List_Id; Definition : Node_Id; begin Scan_Token; -- past "module" Node := New_Node (K_Module, Token_Location); -- Save module declaration location since we may have to reopen -- a previous declaration. Identifier := P_Identifier; if No (Identifier) then return No_Node; end if; Bind_Identifier_To_Entity (Identifier, Node); Scan_Token (T_Left_Brace); if Token = T_Error then return No_Node; end if; Definitions := New_List (Token_Location); Set_Definitions (Node, Definitions); loop Definition := P_Definition; if Present (Definition) then Append_To (Definitions, Definition); end if; case Next_Token is when T_Right_Brace => Scan_Token; -- past '}' exit; when T_EOF => exit; when others => null; end case; end loop; return Node; end P_Module; -------------------- -- P_No_Such_Node -- -------------------- function P_No_Such_Node return Node_Id is begin Scan_Token; Error_Loc (1) := Token_Location; DE ("not implemented"); return No_Node; end P_No_Such_Node; ----------------------------- -- P_Operation_Declaration -- ----------------------------- -- (87) ::= [ ] -- -- [ ] [ ] -- -- (88) ::= "oneway" -- (89) ::= -- | "void" -- -- (90) ::= "(" { "," } ")" -- | "(" ")" -- -- (91) ::= -- -- -- (92) ::= "in" -- | "out" -- | "inout" -- -- (93) ::= "raises" "(" -- { "," } ")" -- -- (94) ::= "context" "(" -- { "," } ")" function P_Operation_Declaration return Node_Id is function P_Context_List return List_Id; -------------------- -- P_Context_List -- -------------------- -- (94) ::= "context" "(" -- { "," } ")" function P_Context_List return List_Id is Context_List : List_Id; String_Literal : Node_Id; State : Location; begin Scan_Token; -- past "context" Scan_Token (T_Left_Paren); if Token = T_Error then return No_List; end if; Context_List := New_List (Token_Location); loop -- Parse string literal. Save lexer state to skip -- literals on error. Save_Lexer (State); Scan_Token ((T_String_Literal, T_Wide_String_Literal)); if Token = T_Error then Restore_Lexer (State); Skip_Declaration (T_Right_Paren); exit; end if; String_Literal := New_Node (K_Literal, Token_Location); Set_Value (String_Literal, New_String_Value (Value => String_Literal_Value, Wide => Is_Wide_Literal_Value)); Append_To (Context_List, String_Literal); Save_Lexer (State); Scan_Token ((T_Right_Paren, T_Comma)); if Token /= T_Comma then if Token = T_Error then Restore_Lexer (State); Skip_Declaration (T_Right_Paren); end if; exit; end if; end loop; return Context_List; end P_Context_List; Identifier : Node_Id; Node : Node_Id; Parameter : Node_Id; Parameters : List_Id; Param_Type_Spec : Node_Id; Contexts : List_Id; Exceptions : List_Id; State : Location; begin Save_Lexer (State); Scan_Token; Node := New_Node (K_Operation_Declaration, Token_Location); if Token = T_Oneway then Set_Is_Oneway (Node, True); Save_Lexer (State); Scan_Token; end if; if Token = T_Void then Param_Type_Spec := Resolve_Base_Type ((1 => T_Void), Token_Location); else Restore_Lexer (State); Param_Type_Spec := P_Simple_Type_Spec; -- Guard against previously detected error if No (Param_Type_Spec) then return No_Node; end if; if not Is_Param_Type_Spec (Param_Type_Spec) then Error_Loc (1) := Loc (Param_Type_Spec); DE ("incorrect param type spec"); return No_Node; end if; end if; Set_Type_Spec (Node, Param_Type_Spec); Identifier := P_Identifier; if No (Identifier) then return No_Node; end if; Bind_Identifier_To_Entity (Identifier, Node); Scan_Token (T_Left_Paren); if Token = T_Error then return No_Node; end if; Parameters := New_List (Token_Location); Set_Parameters (Node, Parameters); if Next_Token = T_Right_Paren then Scan_Token; -- past ')' else Save_Lexer (State); loop Parameter := P_Parameter_Declaration; if No (Parameter) then Restore_Lexer (State); Skip_Declaration (T_Right_Paren); exit; end if; Append_To (Parameters, Parameter); Save_Lexer (State); Scan_Token ((T_Right_Paren, T_Comma)); if Token /= T_Comma then if Token = T_Error then Restore_Lexer (State); Skip_Declaration (T_Right_Paren); end if; exit; end if; end loop; end if; if Next_Token = T_Raises then Exceptions := P_Exception_List; if Exceptions = No_List then return No_Node; end if; Set_Exceptions (Node, Exceptions); end if; if Next_Token = T_Context then Contexts := P_Context_List; if Contexts = No_List then return No_Node; end if; Set_Contexts (Node, Contexts); end if; return Node; end P_Operation_Declaration; ----------------------------- -- P_Parameter_Declaration -- ----------------------------- -- (91) ::= -- -- -- (92) ::= "in" -- | "out" -- | "inout" function P_Parameter_Declaration return Node_Id is Param_Declaration : Node_Id; Param_Declarator : Node_Id; Param_Type_Spec : Node_Id; Param_Mode : Mode_Id; Param_Location : Location; begin Scan_Token ((T_In, T_Inout, T_Out)); Param_Location := Token_Location; if Token = T_Error then return No_Node; end if; Param_Mode := Parameter_Mode (Token); Param_Type_Spec := P_Simple_Type_Spec; -- Guard against previously detected error if No (Param_Type_Spec) then return No_Node; end if; if not Is_Param_Type_Spec (Param_Type_Spec) then Error_Loc (1) := Loc (Param_Type_Spec); DE ("incorrect param type spec"); return No_Node; end if; Param_Declarator := P_Simple_Declarator; if No (Param_Declarator) then return No_Node; end if; Param_Declaration := New_Node (K_Parameter_Declaration, Param_Location); Set_Parameter_Mode (Param_Declaration, Param_Mode); Set_Type_Spec (Param_Declaration, Param_Type_Spec); Set_Declarator (Param_Declaration, Param_Declarator); Bind_Declarator_To_Entity (Param_Declarator, Param_Declaration); return Param_Declaration; end P_Parameter_Declaration; -------------- -- P_Pragma -- -------------- -- There three standard IDL pragmas : -- #pragma ID "" -- #pragma prefix "" -- #pragma version . -- However an IDL compiler "must not refuse to compile IDL source -- containing non-standard pragmas that are not understood by the -- compiler" CORBA, v3.0 $10.7.5 -- Not understood pragmas will be ignored function P_Pragma return Node_Id is Pragma_Kind : Pragma_Type; Pragma_Node : Node_Id; Scoped_Name : Node_Id := No_Node; begin Scan_Token; -- Past #pragma Pragma_Node := New_Node (K_Pragma, Token_Location); -- We scan an identifier, then we convert it into a pragma related token -- because pragma kinds (id, prefix, version) can be used as legal -- identifiers in other locations Scan_Token (T_Identifier); if Token = T_Error then return Pragma_Node; end if; -- Converting the identifier into a pragma related token declare Pragma_Image : constant String := Get_Name_String (Token_Name); begin if Pragma_Image = Image (T_Pragma_Id) then Token := T_Pragma_Id; elsif Pragma_Image = Image (T_Pragma_Prefix) then Token := T_Pragma_Prefix; elsif Pragma_Image = Image (T_Pragma_Version) then Token := T_Pragma_Version; end if; end; -- Unrecognized pragma if Token = T_Identifier then Token := T_Pragma_Unrecognized; end if; Pragma_Kind := Get_Pragma_Type (Token); case Pragma_Kind is when Pragma_Id => Set_Pragma_Kind (Pragma_Node, Pragma_Kind); Scoped_Name := P_Scoped_Name; if No (Scoped_Name) then Error_Loc (1) := Token_Location; DE ("incorrect #pragma ID syntax"); end if; Set_Target (Pragma_Node, Scoped_Name); -- Getting the "" Scan_Token (T_String_Literal); Set_Data (Pragma_Node, Name_Find); when Pragma_Prefix => Set_Pragma_Kind (Pragma_Node, Pragma_Kind); -- Getting the "" Scan_Token (T_String_Literal); Set_Data (Pragma_Node, Name_Find); when Pragma_Version => Set_Pragma_Kind (Pragma_Node, Pragma_Kind); Scoped_Name := P_Scoped_Name; if No (Scoped_Name) then Error_Loc (1) := Token_Location; DE ("incorrect #pragma version syntax"); end if; Set_Target (Pragma_Node, Scoped_Name); -- Getting the . -- We don't want to get a floating point value, so we take the -- value from the Name_Buffer Scan_Token (T_Floating_Point_Literal); Set_Data (Pragma_Node, Name_Find); when Pragma_Unrecognized => Set_Pragma_Kind (Pragma_Node, Pragma_Kind); -- We ignore unrecognized pragmas Skip_Line; end case; return Pragma_Node; end P_Pragma; ------------------- -- P_Scoped_Name -- ------------------- -- (12) ::= -- | "::" -- | "::" function P_Scoped_Name return Node_Id is Scoped_Name : Node_Id := No_Node; Parent : Node_Id := No_Node; Identifier : Node_Id; Scope_Depth : Int; begin -- Scoped name starts with a '::' if Next_Token = T_Colon_Colon then Scan_Token; -- past '::' Identifier := Make_Identifier (Token_Location, No_Name, No_Node, No_Node); Scoped_Name := New_Node (K_Scoped_Name, Token_Location); Bind_Identifier_To_Entity (Identifier, Scoped_Name); end if; -- start loop with an identifier loop Identifier := P_Identifier; if No (Identifier) then return No_Node; end if; Parent := Scoped_Name; Scoped_Name := New_Node (K_Scoped_Name, Token_Location); Bind_Identifier_To_Entity (Identifier, Scoped_Name); Set_Parent_Entity (Scoped_Name, Parent); exit when Next_Token /= T_Colon_Colon; Scan_Token; -- past '::' end loop; Parent := Parent_Entity (Scoped_Name); Scope_Depth := Depth (Scoped_Name); while Present (Parent) loop Scope_Depth := Scope_Depth + 1; Set_Depth (Parent, Scope_Depth); Parent := Parent_Entity (Parent); end loop; return Scoped_Name; end P_Scoped_Name; --------------------- -- P_Sequence_Type -- --------------------- -- (80) ::= "sequence" "<" "," -- ">" -- | "sequence" "<" ">" function P_Sequence_Type return Node_Id is Node : Node_Id; Seq_Type_Spec : Node_Id; Seq_Level : Natural; Size : Node_Id; begin Scan_Token; -- past "sequence" Node := New_Node (K_Sequence_Type, Token_Location); Scan_Token (T_Less); if Token = T_Error then return No_Node; end if; Sequencing_Level := Sequencing_Level + 1; Seq_Level := Sequencing_Level; Seq_Type_Spec := P_Type_Spec; if No (Seq_Type_Spec) then return No_Node; end if; Set_Type_Spec (Node, Seq_Type_Spec); if Seq_Level > Sequencing_Level then return Node; end if; if Sequencing_Level > 1 then Scan_Token ((T_Comma, T_Greater, T_Greater_Greater)); else Scan_Token ((T_Comma, T_Greater)); end if; if Token = T_Error then return No_Node; end if; if Token = T_Comma then Size := P_Constant_Expression; if Sequencing_Level > 1 then Scan_Token ((T_Greater, T_Greater_Greater)); else Scan_Token (T_Greater); end if; if Token = T_Error then return No_Node; end if; -- No max size means no size else Size := No_Node; end if; Set_Max_Size (Node, Size); if Token = T_Greater_Greater then Sequencing_Level := Sequencing_Level - 2; else Sequencing_Level := Sequencing_Level - 1; end if; return Node; end P_Sequence_Type; ------------------------- -- P_Simple_Declarator -- ------------------------- -- (51) ::= function P_Simple_Declarator return Node_Id is Identifier : Node_Id; Node : Node_Id; begin Identifier := P_Identifier; if No (Identifier) then return No_Node; end if; Node := New_Node (K_Simple_Declarator, Loc (Identifier)); Bind_Identifier_To_Entity (Identifier, Node); return Node; end P_Simple_Declarator; ------------------------ -- P_Simple_Type_Spec -- ------------------------ -- (45) ::= -- | -- | -- -- (46) ::= -- | -- | -- | -- | -- | -- | -- | -- | -- -- (47) ::= -- | -- | -- | function P_Simple_Type_Spec return Node_Id is List : Token_List_Type (1 .. 3) := (others => T_Error); Size : Natural := 0; Next : Token_Type; Loc : Location; procedure Push_Base_Type_Token (T : Token_Type); -- Push token in the list above. This token is either T_Float, -- T_Double, T_Short, T_Long, T_Unsigned, T_Char, T_Wchar or T_Octet. function Resolve_Base_Type return Node_Id; -------------------------- -- Push_Base_Type_Token -- -------------------------- procedure Push_Base_Type_Token (T : Token_Type) is begin Size := Size + 1; List (Size) := T; end Push_Base_Type_Token; ----------------------- -- Resolve_Base_Type -- ----------------------- function Resolve_Base_Type return Node_Id is begin return Resolve_Base_Type (List (1 .. Size), Loc); end Resolve_Base_Type; begin Size := 0; Next := Next_Token; Push_Base_Type_Token (Next); case Next is when T_Long => Scan_Token; -- skip long Loc := Token_Location; Next := Next_Token; if Next = T_Double or else Next = T_Long then Scan_Token; Push_Base_Type_Token (Next); end if; return Resolve_Base_Type; when T_Short | T_Float | T_Double | T_Char | T_Wchar | T_Boolean | T_Octet | T_Any | T_Object | T_Value_Base => Scan_Token; Loc := Token_Location; return Resolve_Base_Type; when T_Unsigned => Scan_Token; -- skip unsigned Loc := Token_Location; Scan_Token ((T_Short, T_Long)); Push_Base_Type_Token (Token); if Token = T_Error then return No_Node; elsif Token = T_Long then Next := Next_Token; if Next = T_Long then Scan_Token; -- skip long Push_Base_Type_Token (Next); end if; end if; return Resolve_Base_Type; when T_String | T_Wstring => return P_String_Type; when T_Fixed => return P_Fixed_Point_Type; when T_Identifier | T_Colon_Colon => return P_Scoped_Name; when T_Sequence => return P_Sequence_Type; when others => Scan_Token; Unexpected_Token (Token, "type specifier"); return No_Node; end case; end P_Simple_Type_Spec; --------------------- -- P_Specification -- --------------------- -- (1) ::= * + procedure P_Specification (Imported : Boolean := False) is Definitions : List_Id; Imports : List_Id; Definition : Node_Id; Import : Node_Id; Identifier : Node_Id; Next : Token_Type; begin -- If we parse an imported specification, we don't create a new node -- K_Specification, we append the imported entities to the original -- specification if Imported then Definitions := FEN.Definitions (Specification); Imports := FEN.Imports (Specification); else Identifier := Make_Identifier (Token_Location, Scopes.IDL_Spec_Name, No_Node, No_Node); Specification := New_Node (K_Specification, Token_Location); Bind_Identifier_To_Entity (Identifier, Specification); Definitions := New_List (Token_Location); Set_Definitions (Specification, Definitions); Imports := New_List (Token_Location); Set_Imports (Specification, Imports); end if; -- Scanning the imported scopes to the current global scope Next := Next_Token; while Next = T_Import loop Import := P_Import; if Present (Import) then Set_Imported (Import, Imported); Append_To (Imports, Import); end if; Next := Next_Token; end loop; loop Definition := P_Definition; if Present (Definition) then Set_Imported (Definition, Imported); Append_To (Definitions, Definition); end if; exit when Next_Token = T_EOF; end loop; end P_Specification; -------------------- -- P_State_Member -- -------------------- -- (22) ::= ( "public" | "private" ) -- ";" -- (49) ::= { "," } function P_State_Member return Node_Id is Declarators : List_Id; Type_Spec : Node_Id; State_Member : Node_Id := No_Node; Is_Public : Boolean := False; State : Location; begin State := Token_Location; Scan_Token; -- past "public" or "private" if Token = T_Public then Is_Public := True; end if; Type_Spec := P_Type_Spec; if No (Type_Spec) then return No_Node; end if; Declarators := P_Declarator_List; if Is_Empty (Declarators) then return No_Node; end if; Scan_Token (T_Semi_Colon); if Token = T_Error then Restore_Lexer (State); Skip_Declaration (T_Semi_Colon); return No_Node; end if; State_Member := New_Node (K_State_Member, State); Set_Type_Spec (State_Member, Type_Spec); Set_Is_Public (State_Member, Is_Public); Set_Declarators (State_Member, Declarators); return State_Member; end P_State_Member; ------------------- -- P_String_Type -- ------------------- -- (81) ::= "string" "<" ">" -- | "string" -- -- (82) ::= "wstring" "<" ">" -- | "wstring" function P_String_Type return Node_Id is Node : Node_Id; Size : Node_Id; subtype Any_String is Token_Type range T_String .. T_Wstring; begin Scan_Token; case Any_String'(Token) is when T_String => Node := New_Node (K_String_Type, Token_Location); when T_Wstring => Node := New_Node (K_Wide_String_Type, Token_Location); end case; if Next_Token /= T_Less then return Resolve_Base_Type ((1 => Token), Token_Location); end if; Scan_Token; -- past '<' Size := P_Constant_Expression; Set_Max_Size (Node, Size); Scan_Token (T_Greater); if Token = T_Error then return No_Node; end if; return Node; end P_String_Type; ---------------------- -- P_Structure_Type -- ---------------------- -- (69) ::= "struct" "{" "}" -- (70) ::= + function P_Structure_Type return Node_Id is Identifier : Node_Id; Node : Node_Id; Members : List_Id; Member : Node_Id; State : Location; begin Scan_Token; -- past "struct"; Node := New_Node (K_Structure_Type, Token_Location); Identifier := P_Identifier; if No (Identifier) then return No_Node; end if; Bind_Identifier_To_Entity (Identifier, Node); Members := New_List (Token_Location); Set_Members (Node, Members); Scan_Token; -- past '{' loop Save_Lexer (State); Member := P_Member; if No (Member) then Restore_Lexer (State); Skip_Declaration (T_Right_Brace); exit; end if; Append_To (Members, Member); if Next_Token = T_Right_Brace then Scan_Token; exit; end if; end loop; return Node; end P_Structure_Type; ------------------------ -- P_Type_Declaration -- ------------------------ -- (42) ::= "typedef" -- | -- | -- | -- | "native" -- | -- (43) ::= function P_Type_Declaration return Node_Id is Identifier : Node_Id; Node : Node_Id := No_Node; Type_Spec : Node_Id; Declarator : Node_Id; Declarators : List_Id; State : Location; begin Save_Lexer (State); Scan_Token; case Token is when T_Typedef => Type_Spec := P_Type_Spec; if No (Type_Spec) then return No_Node; end if; Declarators := P_Declarator_List; if Is_Empty (Declarators) then return No_Node; end if; Node := New_Node (K_Type_Declaration, State); Set_Type_Spec (Node, Type_Spec); Set_Declarators (Node, Declarators); Bind_Declarators_To_Entity (Declarators, Node); when T_Native => Declarator := P_Simple_Declarator; if No (Declarator) then return No_Node; end if; Node := New_Node (K_Native_Type, State); Set_Declarator (Node, Declarator); Bind_Declarator_To_Entity (Declarator, Node); when T_Struct => Identifier := P_Identifier; if No (Identifier) then return No_Node; end if; if Next_Token = T_Semi_Colon then Node := New_Node (K_Forward_Structure_Type, State); Bind_Identifier_To_Entity (Identifier, Node); else Restore_Lexer (State); return P_Structure_Type; end if; when T_Union => Identifier := P_Identifier; if No (Identifier) then return No_Node; end if; if Next_Token = T_Semi_Colon then Node := New_Node (K_Forward_Union_Type, State); Bind_Identifier_To_Entity (Identifier, Node); else Restore_Lexer (State); return P_Union_Type; end if; when T_Enum => Restore_Lexer (State); return P_Enumeration_Type; when others => return No_Node; end case; return Node; end P_Type_Declaration; --------------- -- P_Type_Id -- --------------- -- (102) ::= "typeid" function P_Type_Id_Declaration return Node_Id is Node : Node_Id; Scoped_Name : Node_Id; begin Scan_Token; -- past "typeid"; Node := New_Node (K_Type_Id_Declaration, Token_Location); Scoped_Name := P_Scoped_Name; if No (Scoped_Name) then Error_Loc (1) := Token_Location; DE ("Scoped name expected after typeid"); end if; Set_Target (Node, Scoped_Name); -- Getting the "" Scan_Token (T_String_Literal); Set_Data (Node, Name_Find); return Node; end P_Type_Id_Declaration; ------------------- -- P_Type_Prefix -- ------------------- -- (103) ::= "typeprefix" function P_Type_Prefix_Declaration return Node_Id is Node : Node_Id; Scoped_Name : Node_Id; begin Scan_Token; -- past "typeprefix"; Node := New_Node (K_Type_Prefix_Declaration, Token_Location); Scoped_Name := P_Scoped_Name; if No (Scoped_Name) then Error_Loc (1) := Token_Location; DE ("Scoped name expected after typeprefix"); end if; Set_Target (Node, Scoped_Name); -- Getting the "" Scan_Token (T_String_Literal); Set_Data (Node, Name_Find); return Node; end P_Type_Prefix_Declaration; ----------------- -- P_Type_Spec -- ----------------- -- (44) ::= -- | -- -- (45) ::= -- | -- | -- -- (46) ::= -- | -- | -- | -- | -- | -- | -- | -- | -- -- (47) ::= -- | -- | -- | -- -- (48) ::= -- | -- | function P_Type_Spec return Node_Id is begin case Next_Token is when T_Struct => return P_Structure_Type; when T_Enum => return P_Enumeration_Type; when T_Union => return P_Union_Type; when others => return P_Simple_Type_Spec; end case; end P_Type_Spec; ------------------ -- P_Union_Type -- ------------------ -- (72) ::= "union" "switch" -- "(" ")" -- "{" "}" -- -- (73) ::= -- | -- | -- | -- | -- -- (74) ::= + -- (75) ::= + ";" -- (76) ::= "case" ":" -- | "default" ":" -- -- (77) ::= function P_Union_Type return Node_Id is function Is_Switch_Type_Spec (K : Node_Kind) return Boolean; -------------------- -- Is_Switch_Spec -- -------------------- -- (73) ::= -- | -- | -- | -- | function Is_Switch_Type_Spec (K : Node_Kind) return Boolean is begin case K is when K_Short | K_Long | K_Long_Long | K_Unsigned_Short | K_Unsigned_Long | K_Unsigned_Long_Long | K_Char | K_Boolean | K_Enumeration_Type | K_Scoped_Name => return True; when others => return False; end case; end Is_Switch_Type_Spec; Identifier : Node_Id; Node : Node_Id; Switch_Type_Spec : Node_Id; Switch_Type_Body : List_Id; Switch_Alt_Decl : Node_Id; Element_Type_Spec : Node_Id; Element_Declarator : Node_Id; Element : Node_Id; Case_Labels : List_Id; Case_Label : Node_Id; Expression : Node_Id; State : Location; begin -- (72) ::= "union" "switch" -- "(" ")" -- "{" "}" Scan_Token; -- past "union" Node := New_Node (K_Union_Type, Token_Location); Identifier := P_Identifier; if No (Identifier) then return No_Node; end if; Bind_Identifier_To_Entity (Identifier, Node); Scan_Token (T_Switch); if Token = T_Error then return No_Node; end if; Scan_Token (T_Left_Paren); if Token = T_Error then return No_Node; end if; -- (73) ::= -- | -- | -- | -- | Save_Lexer (State); Switch_Type_Spec := P_Type_Spec; if Present (Switch_Type_Spec) and then not Is_Switch_Type_Spec (Kind (Switch_Type_Spec)) then Error_Loc (1) := Loc (Switch_Type_Spec); DE ("unexpected switch type spec"); Switch_Type_Spec := No_Node; end if; if No (Switch_Type_Spec) then Restore_Lexer (State); Skip_Declaration (T_Right_Paren); else Save_Lexer (State); Scan_Token (T_Right_Paren); if Token = T_Error then Restore_Lexer (State); Skip_Declaration (T_Right_Paren); end if; end if; Set_Switch_Type_Spec (Node, Switch_Type_Spec); Scan_Token (T_Left_Brace); if Token = T_Error then return No_Node; end if; Switch_Type_Body := New_List (Token_Location); Set_Switch_Type_Body (Node, Switch_Type_Body); Switch_Alternative_Declaration : loop Save_Lexer (State); Scan_Token ((T_Default, T_Case)); if Token = T_Error then Restore_Lexer (State); Skip_Declaration (T_Right_Brace); exit Switch_Alternative_Declaration; end if; Switch_Alt_Decl := New_Node (K_Switch_Alternative, Token_Location); Case_Labels := New_List (Token_Location); Set_Labels (Switch_Alt_Decl, Case_Labels); -- (74) ::= + Case_Label_List : loop Save_Lexer (State); Case_Label := New_Node (K_Case_Label, Token_Location); Set_Declaration (Case_Label, Switch_Alt_Decl); -- (75) ::= + ";" Expression := No_Node; if Token = T_Case then Expression := P_Constant_Expression; if No (Expression) then Restore_Lexer (State); Skip_Declaration (T_Right_Brace); exit Switch_Alternative_Declaration; end if; end if; Scan_Token (T_Colon); if Token = T_Error then Restore_Lexer (State); Skip_Declaration (T_Right_Brace); exit Switch_Alternative_Declaration; end if; Set_Expression (Case_Label, Expression); Append_To (Case_Labels, Case_Label); -- (76) ::= "case" ":" -- | "default" ":" case Next_Token is when T_Case | T_Default => Scan_Token; when others => exit Case_Label_List; end case; end loop Case_Label_List; -- (77) ::= Save_Lexer (State); Element_Type_Spec := P_Type_Spec; if No (Element_Type_Spec) then Restore_Lexer (State); Skip_Declaration (T_Right_Brace); exit Switch_Alternative_Declaration; end if; Save_Lexer (State); Element_Declarator := P_Declarator; if No (Element_Declarator) then Restore_Lexer (State); Skip_Declaration (T_Right_Brace); exit Switch_Alternative_Declaration; end if; -- Assemble Element and append it to Switch Alternative Element := New_Node (K_Element, Loc (Element_Type_Spec)); Set_Type_Spec (Element, Element_Type_Spec); Set_Declarator (Element, Element_Declarator); Bind_Declarator_To_Entity (Element_Declarator, Element); Set_Element (Switch_Alt_Decl, Element); Set_Declaration (Switch_Alt_Decl, Node); Append_To (Switch_Type_Body, Switch_Alt_Decl); Save_Lexer (State); Scan_Token (T_Semi_Colon); if Token = T_Error then Restore_Lexer (State); Skip_Declaration (T_Right_Brace); exit Switch_Alternative_Declaration; end if; if Next_Token = T_Right_Brace then Scan_Token; -- past '}' exit Switch_Alternative_Declaration; end if; end loop Switch_Alternative_Declaration; return Node; end P_Union_Type; ------------- -- P_Value -- ------------- -- (13) ::= -- | -- | -- | ) function P_Value return Node_Id is State : Location; Value_Abs : Boolean := False; begin Save_Lexer (State); Scan_Token; -- past "abstract" or "custom" or "valuetype" if Token = T_Abstract then Value_Abs := True; Scan_Token; -- past "valuetype" elsif Token = T_Custom then Scan_Token; -- past "valuetype" end if; if No (P_Identifier) then return No_Node; end if; Scan_Token; case Token is when T_Semi_Colon => Restore_Lexer (State); return P_Value_Forward_Declaration; when T_Custom => Restore_Lexer (State); return P_Value_Declaration; when T_Colon | T_Left_Brace | T_Supports => Restore_Lexer (State); if Value_Abs then return P_Value_Abstract_Declaration; else return P_Value_Declaration; end if; when others => Restore_Lexer (State); return P_Value_Box_Declaration; end case; end P_Value; ---------------------------------- -- P_Value_Abstract_Declaration -- ---------------------------------- -- (16) ::= "abstract" "valuetype" -- [ ] "{" * "}" function P_Value_Abstract_Declaration return Node_Id is Identifier : Node_Id; Node : Node_Id; Value_Spec : Node_Id; Value_Body : List_Id; Export : Node_Id; State : Location; begin Scan_Token; -- past "abstract" Node := New_Node (K_Abstract_Value_Declaration, Token_Location); Scan_Token; -- past "valuetype" Identifier := P_Identifier; if No (Identifier) then return No_Node; end if; Bind_Identifier_To_Entity (Identifier, Node); Value_Spec := P_Value_Spec; Set_Value_Spec (Node, Value_Spec); Scan_Token (T_Left_Brace); if Token = T_Error then return No_Node; end if; Value_Body := New_List (Token_Location); Set_Value_Body (Node, Value_Body); if Next_Token = T_Right_Brace then Scan_Token; else loop Save_Lexer (State); Export := P_Export; if No (Export) then Restore_Lexer (State); Skip_Declaration (T_Right_Brace); exit; end if; Append_To (Value_Body, Export); if Next_Token = T_Right_Brace then Scan_Token; exit; end if; end loop; end if; return Node; end P_Value_Abstract_Declaration; ----------------------------- -- P_Value_Box_Declaration -- ----------------------------- -- (15) ::= "valuetype" function P_Value_Box_Declaration return Node_Id is Identifier : Node_Id; Node : Node_Id; Type_Spec : Node_Id; begin Scan_Token; -- past "valuetype" Node := New_Node (K_Value_Box_Declaration, Token_Location); Identifier := P_Identifier; if No (Identifier) then return No_Node; end if; Bind_Identifier_To_Entity (Identifier, Node); Type_Spec := P_Type_Spec; if No (Type_Spec) then return No_Node; end if; Set_Type_Spec (Node, Type_Spec); return Node; end P_Value_Box_Declaration; ------------------------- -- P_Value_Declaration -- ------------------------- -- (17) ::= "{" * "}" -- (18) ::= [" custom" ] "valuetype" -- [ ] -- -- (20) ::= -- (21) ::= | | function P_Value_Declaration return Node_Id is Identifier : Node_Id; Node : Node_Id; Value_Spec : Node_Id; Value_Body : List_Id; Value_Element : Node_Id; State : Location; begin Scan_Token; -- past "custom" or "valuetype" Node := New_Node (K_Value_Declaration, Token_Location); if Token = T_Custom then Set_Is_Custom (Node, True); Scan_Token (T_Value_Type); if Token = T_Error then return No_Node; end if; end if; Identifier := P_Identifier; if No (Identifier) then return No_Node; end if; Bind_Identifier_To_Entity (Identifier, Node); Value_Spec := P_Value_Spec; Set_Value_Spec (Node, Value_Spec); Scan_Token (T_Left_Brace); if Token = T_Error then return No_Node; end if; Value_Body := New_List (Token_Location); Set_Value_Body (Node, Value_Body); loop Save_Lexer (State); case Next_Token is when T_Factory => Value_Element := P_Initializer_Declaration; when T_Public | T_Private => Value_Element := P_State_Member; when T_Right_Brace => Scan_Token; -- past "}" exit; when others => Value_Element := P_Export; end case; if No (Value_Element) then Restore_Lexer (State); Skip_Declaration (T_Right_Brace); exit; end if; Append_To (Value_Body, Value_Element); end loop; return Node; end P_Value_Declaration; --------------------------------- -- P_Value_Forward_Declaration -- --------------------------------- -- (14) ::= [ "abstract" ] "valuetype" function P_Value_Forward_Declaration return Node_Id is Identifier : Node_Id; Node : Node_Id; begin Scan_Token; -- past "valuetype" or "abstract" Node := New_Node (K_Value_Forward_Declaration, Token_Location); if Token = T_Abstract then Set_Is_Abstract_Value (Node, True); Scan_Token (T_Value_Type); end if; Identifier := P_Identifier; if No (Identifier) then return No_Node; end if; Bind_Identifier_To_Entity (Identifier, Node); return Node; end P_Value_Forward_Declaration; ------------------ -- P_Value_Spec -- ------------------ -- (19) ::= -- [ ":" [ "truncatable" ] -- { "," }* ] -- [ "supports" -- { "," }* ] function P_Value_Spec return Node_Id is Value_Spec : Node_Id := No_Node; Value_Names : List_Id; Interface_Names : List_Id; Scoped_Name : Node_Id; Interface_Name : Node_Id; begin Value_Spec := New_Node (K_Value_Spec, Token_Location); if Next_Token = T_Colon then Scan_Token; -- past ":" if Next_Token = T_Truncatable then Scan_Token; -- past "truncatable" Set_Is_Truncatable (Value_Spec, True); end if; Value_Names := New_List (Token_Location); Set_Value_Names (Value_Spec, Value_Names); loop Scoped_Name := P_Scoped_Name; if No (Scoped_Name) then return No_Node; end if; Append_To (Value_Names, Scoped_Name); exit when Next_Token /= T_Comma; Scan_Token; -- past ',' end loop; end if; if Next_Token = T_Supports then Scan_Token; -- past "supports" Interface_Names := New_List (Token_Location); Set_Interface_Names (Value_Spec, Interface_Names); loop Interface_Name := P_Interface_Name; if No (Interface_Name) then return No_Node; end if; Append_To (Interface_Names, Interface_Name); exit when Next_Token /= T_Comma; Scan_Token; -- past ',' end loop; end if; return Value_Spec; end P_Value_Spec; ------------- -- Process -- ------------- procedure Process (IDL_Spec : out Node_Id) is begin -- (53) ::= "float" -- | "double" -- | "long" "double" Declare_Base_Type ((1 => T_Float), K_Float); Declare_Base_Type ((1 => T_Double), K_Double); Declare_Base_Type ((T_Long, T_Double), K_Long_Double); -- (54) ::= -- | -- -- (55) ::= -- | -- | -- -- (56) ::= "short" -- (57) ::= "long" -- (58) ::= "long" "long" -- (59) ::= -- | -- | -- -- (60) ::= "unsigned" "short" -- (61) ::= "unsigned" "long" -- (62) ::= "unsigned" "long" "long" Declare_Base_Type ((1 => T_Short), K_Short); Declare_Base_Type ((1 => T_Long), K_Long); Declare_Base_Type ((T_Long, T_Long), K_Long_Long); Declare_Base_Type ((T_Unsigned, T_Short), K_Unsigned_Short); Declare_Base_Type ((T_Unsigned, T_Long), K_Unsigned_Long); Declare_Base_Type ((T_Unsigned, T_Long, T_Long), K_Unsigned_Long_Long); -- (63) ::= "char" -- (64) ::= "wchar" Declare_Base_Type ((1 => T_Char), K_Char); Declare_Base_Type ((1 => T_Wchar), K_Wide_Char); Declare_Base_Type ((1 => T_String), K_String); Declare_Base_Type ((1 => T_Wstring), K_Wide_String); -- (65) ::= "boolean" -- (66) ::= "octet" -- (67) ::= "any" -- (68) ::= "Object" Declare_Base_Type ((1 => T_Boolean), K_Boolean); Declare_Base_Type ((1 => T_Octet), K_Octet); Declare_Base_Type ((1 => T_Any), K_Any); Declare_Base_Type ((1 => T_Object), K_Object); Declare_Base_Type ((1 => T_Value_Base), K_Value_Base); -- 89) ::= -- | "void" Declare_Base_Type ((1 => T_Void), K_Void); P_Specification; IDL_Spec := Specification; end Process; ----------------------- -- Resolve_Base_Type -- ----------------------- function Resolve_Base_Type (L : Token_List_Type; Loc : Location) return Node_Id is Info : Nat; Result : Node_Id; begin Set_Str_To_Name_Buffer (Image (L (L'First))); for I in L'First + 1 .. L'Last loop Add_Char_To_Name_Buffer (' '); Add_Str_To_Name_Buffer (Image (L (I))); end loop; Info := Get_Name_Table_Info (Name_Find); if Info = 0 then return No_Node; else Result := New_Node (Kind (Node_Id (Info)), Loc); Set_Image (Base_Type (Result), Image (Base_Type (Info))); return Result; end if; end Resolve_Base_Type; end Parser; polyorb-2.8~20110207.orig/compilers/iac/backend-be_corba_ada-expand.adb0000644000175000017500000017615511750740337025033 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- B A C K E N D . B E _ C O R B A _ A D A . E X P A N D -- -- -- -- B o d y -- -- -- -- Copyright (C) 2005-2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with Namet; use Namet; with Locations; use Locations; with Values; use Values; with Backend.BE_CORBA_Ada.Nutils; use Backend.BE_CORBA_Ada.Nutils; with Backend.BE_CORBA_Ada.IDL_To_Ada; use Backend.BE_CORBA_Ada.IDL_To_Ada; with Frontend.Nodes; use Frontend.Nodes; with Frontend.Nutils; with Parser; with Lexer; package body Backend.BE_CORBA_Ada.Expand is package FEN renames Frontend.Nodes; package FEU renames Frontend.Nutils; procedure Expand_Attribute_Declaration (Entity : Node_Id); procedure Expand_Exception_Declaration (Entity : Node_Id); procedure Expand_Forward_Interface_Declaration (Entity : Node_Id); procedure Expand_Interface_Declaration (Entity : Node_Id); procedure Expand_Module (Entity : Node_Id); procedure Expand_Specification (Entity : Node_Id); procedure Expand_Structure_Type (Entity : Node_Id); procedure Expand_Type_Declaration (Entity : Node_Id); procedure Expand_Union_Type (Entity : Node_Id); procedure Expand_Constant_Declaration (Entity : Node_Id); procedure Expand_Operation_Declaration (Entity : Node_Id); procedure Expand_Element (Entity : Node_Id); procedure Expand_Member (Entity : Node_Id); procedure Expand_Parameter_Declaration (Entity : Node_Id) renames Expand_Element; procedure Forward_Current_Interface_Designing_Components (Interface_Node : Node_Id; Type_Spec_Node : Node_Id); -- For Sequence types, the item parameter cannot: -- * denote the current interface -- * have a component whose type is the current interface -- The instantiation of the sequences generic package would -- otherwise cause freezing. function Is_Forward_Necessary (Entity : Node_Id; Type_Spec : Node_Id) return Boolean; -- Return True if the type spec is an interface based type and -- then if the scope entity of this interface is the same as -- Entity's scope entity. procedure Insert_Definition (E, Before, In_Container : Node_Id); -- Inserts E in the container's definition list immediately before -- Before. The container must be a module, specification, or interface -- declaration, and Before must be in its list of definitions. procedure Define_Array_Type_Outside (Member : Node_Id; Entity : Node_Id; Before : Node_Id); -- This procedure does the following : -- * Insert a definition of the array type corresponding to -- the "Member" type spec outside the enclosing entity "Entity". -- * Replaces the type spec of "Member" by a scoped name which -- represents the new defined type. procedure Define_Structure_Type_Outside (Member : Node_Id; Entity : Node_Id; Before : Node_Id); -- This procedure does the following : -- * Insert a definition of the structure type corresponding to -- the "Member" type spec outside the enclosing entity "Entity". -- * Replaces the type spec of "Member" by a scoped name which -- represents the new defined type. function Add_Forward_Declaration (Iface : Node_Id) return Node_Id; -- This function : -- * Adds a forward declaration fro the interface to the IDL tree -- if it is not already forwarded -- * Sets the interface as forwarded -- * Returns the new or the already existing node. function Is_CORBA_IR_Entity (Entity : Node_Id) return Boolean; -- This function returns True if the entity passed as parameter -- should be generated in the CORBA.Repository_Root package. function Is_CORBA_Sequence (Entity : Node_Id) return Boolean; -- This function returns True if the entity passed as parameter -- should be generated in the CORBA.IDL_Sequences package. procedure Handle_Anonymous_Type (Entity : Node_Id; Parent : Node_Id; Before : Node_Id); -- This procedure looks whether the type spec of the entity is an -- anonymous type and adds a type definition before the 'Before' -- entity declaration in the 'Parent' node. Anonymous_Type_Index_Value : Nat := 0; function New_Anonymous_Type_Index return Nat; -- The two entities below are used to avoid name collision when -- handling anonymous types. function Has_Complex_Declarators (Entity : Node_Id) return Boolean; -- This function returns True when the type declaration has one or -- more complex declarators. ---------------------------------------------------- -- Forward_Current_Interface_Designing_Components -- ---------------------------------------------------- procedure Forward_Current_Interface_Designing_Components (Interface_Node : Node_Id; Type_Spec_Node : Node_Id) is Members : List_Id; Member : Node_Id; Alternatives : List_Id; Alternative : Node_Id; Type_Spec : Node_Id; begin -- The anonymous nested types are deprecated in CORBA 3.0.3, so -- the only case in which we can find a interface type -- component is the case of a Scoped_Name type spec. if FEN.Kind (Type_Spec_Node) = K_Scoped_Name then if FEN.Reference (Type_Spec_Node) = Interface_Node then Set_Reference (Type_Spec_Node, Add_Forward_Declaration (FEN.Reference (Type_Spec_Node))); elsif FEN.Kind (FEN.Reference (Type_Spec_Node)) = K_Simple_Declarator or else FEN.Kind (FEN.Reference (Type_Spec_Node)) = K_Complex_Declarator then Type_Spec := FEN.Type_Spec (Declaration (Reference (Type_Spec_Node))); Forward_Current_Interface_Designing_Components (Interface_Node, Type_Spec); elsif FEN.Kind (FEN.Reference (Type_Spec_Node)) = K_Structure_Type or else FEN.Kind (FEN.Reference (Type_Spec_Node)) = K_Exception_Declaration then Members := FEN.Members (FEN.Reference (Type_Spec_Node)); Member := First_Entity (Members); while Present (Member) loop Type_Spec := FEN.Type_Spec (Member); Forward_Current_Interface_Designing_Components (Interface_Node, Type_Spec); Member := Next_Entity (Member); end loop; elsif FEN.Kind (FEN.Reference (Type_Spec_Node)) = K_Union_Type then Alternatives := Switch_Type_Body (FEN.Reference (Type_Spec_Node)); Alternative := First_Entity (Alternatives); while Present (Alternative) loop Type_Spec := FEN.Type_Spec (FEN.Element (Alternative)); Forward_Current_Interface_Designing_Components (Interface_Node, Type_Spec); Alternative := Next_Entity (Alternative); end loop; end if; end if; end Forward_Current_Interface_Designing_Components; -------------------------- -- Is_Forward_Necessary -- -------------------------- function Is_Forward_Necessary (Entity : Node_Id; Type_Spec : Node_Id) return Boolean is Result : Boolean := False; S_Entity : Node_Id; S_Type_Spec : Node_Id; begin pragma Assert (FEN.Kind (Entity) = K_Simple_Declarator or else FEN.Kind (Entity) = K_Complex_Declarator or else FEN.Kind (Entity) = K_Structure_Type or else FEN.Kind (Entity) = K_Union_Type or else FEN.Kind (Entity) = K_Exception_Declaration); S_Entity := FEN.Scope_Entity (FEN.Identifier (Entity)); if FEN.Kind (Type_Spec) = K_Scoped_Name and then FEN.Kind (FEN.Reference (Type_Spec)) = K_Interface_Declaration then S_Type_Spec := FEN.Scope_Entity (FEN.Identifier (FEN.Reference (Type_Spec))); if S_Type_Spec = S_Entity then Result := True; end if; end if; return Result; end Is_Forward_Necessary; ----------------------------- -- Add_Forward_Declaration -- ----------------------------- function Add_Forward_Declaration (Iface : Node_Id) return Node_Id is Forward_Node : Node_Id; F_Identifier : Node_Id; Definitions : List_Id; Definition : Node_Id; begin pragma Assert (FEN.Kind (Iface) = K_Interface_Declaration); Definitions := FEN.Definitions (Scope_Entity (Identifier (Iface))); if Is_Forwarded (Iface) then -- Looking for the forward declaration Definition := First_Entity (Definitions); while Present (Definition) loop if FEN.Kind (Definition) = K_Forward_Interface_Declaration and then Forward (Definition) = Iface then return Definition; end if; Definition := Next_Entity (Definition); end loop; -- We cannot reach this code unless a serious problem -- occured during the parsing. raise Program_Error; else Set_Forwarded (Iface); Forward_Node := FEU.New_Node (K_Forward_Interface_Declaration, FEN.Loc (Iface)); Set_Forward (Forward_Node, Iface); F_Identifier := FEU.Make_Identifier (Loc => FEN.Loc (Identifier (Iface)), IDL_Name => IDL_Name (Identifier (Iface)), Node => No_Node, Scope_Entity => Scope_Entity (Identifier (Iface))); FEU.Bind_Identifier_To_Entity (F_Identifier, Forward_Node); Set_Is_Abstract_Interface (Forward_Node, Is_Abstract_Interface (Iface)); Set_Is_Local_Interface (Forward_Node, Is_Local_Interface (Iface)); -- Insert the forward declaration immediately before the interface -- declaration Definition := First_Entity (Definitions); if Definition = Iface then Set_Next_Entity (Forward_Node, Definition); Set_First_Entity (Definitions, Forward_Node); return Forward_Node; end if; while Present (Definition) loop exit when Next_Entity (Definition) = Iface; Definition := Next_Entity (Definition); end loop; FEU.Insert_After_Node (Forward_Node, Definition); return Forward_Node; end if; end Add_Forward_Declaration; ------------------------------- -- Define_Array_Type_Outside -- ------------------------------- procedure Define_Array_Type_Outside (Member : Node_Id; Entity : Node_Id; Before : Node_Id) is Declarator : Node_Id; Type_Spec : Node_Id; Array_Id : Node_Id; Container : Node_Id; Old_Declarator_Id : Node_Id; New_Type_Def : Node_Id; New_Scoped_Name : Node_Id; New_Simple_Declarator : Node_Id; begin -- The given member has to be created by the expander case FEN.Kind (Entity) is when K_Structure_Type | K_Exception_Declaration => pragma Assert (FEU.Length (Declarators (Member)) = 1); Declarator := First_Entity (Declarators (Member)); pragma Assert (FEN.Kind (Declarator) = K_Complex_Declarator); when K_Union_Type => Declarator := FEN.Declarator (Member); pragma Assert (FEN.Kind (Declarator) = K_Complex_Declarator); when others => declare Msg : constant String := "Cannot expand complex member in a " & FEN.Node_Kind'Image (FEN.Kind (Entity)); begin raise Program_Error with Msg; end; end case; -- Get the type spec of the member Type_Spec := FEN.Type_Spec (Member); -- Get the old identifier of the declarator Old_Declarator_Id := Identifier (Declarator); -- Get the declaration list depending on Container kind Container := FEN.Scope_Entity (FEN.Identifier (Entity)); -- Create the identifier of the new array type Array_Id := FEU.Make_Identifier (Loc => FEN.Loc (Type_Spec), IDL_Name => Add_Suffix_To_Name ("_Array", FEN.IDL_Name (FEN.Identifier (Declarator))), Node => No_Node, Scope_Entity => Container); -- Adjust the scope entity of the complex declarator identifier FEN.Set_Scope_Entity (Array_Id, Scope_Entity (Identifier (Entity))); FEN.Set_Potential_Scope (Array_Id, Potential_Scope (Identifier (Entity))); FEU.Bind_Identifier_To_Entity (Array_Id, Declarator); -- Create the new type definition New_Type_Def := FEU.New_Node (K_Type_Declaration, FEN.Loc (Entity)); Set_Type_Spec (New_Type_Def, Type_Spec); Set_Declarators (New_Type_Def, FEU.New_List (FEN.Loc (Entity))); FEU.Append_To (Declarators (New_Type_Def), Declarator); Set_Declaration (Declarator, New_Type_Def); -- Insert the new type declaration Insert_Definition (New_Type_Def, Before, In_Container => Container); -- Re-Create the identifier of the new array type Array_Id := FEU.Make_Identifier (Loc => FEN.Loc (Type_Spec), IDL_Name => Add_Suffix_To_Name ("_Array", FEN.IDL_Name (FEN.Identifier (Declarator))), Node => No_Node, Scope_Entity => Entity); -- Create a scoped name to designate the new defined type New_Scoped_Name := FEU.Make_Scoped_Name (Loc => FEN.Loc (Array_Id), Identifier => Array_Id, Parent => No_Node, Reference => Declarator); FEU.Bind_Identifier_To_Entity (Array_Id, New_Scoped_Name); -- Create a new simple declarator New_Simple_Declarator := FEU.New_Node (K_Simple_Declarator, FEN.Loc (Member)); Set_Declaration (New_Simple_Declarator, Member); Set_Identifier (New_Simple_Declarator, Old_Declarator_Id); -- Modify the member declaration Set_Type_Spec (Member, New_Scoped_Name); case FEN.Kind (Entity) is when K_Structure_Type | K_Exception_Declaration => Set_Declarators (Member, FEU.New_List (FEN.Loc (Member))); FEU.Append_To (Declarators (Member), New_Simple_Declarator); when K_Union_Type => Set_Declarator (Member, New_Simple_Declarator); when others => null; end case; end Define_Array_Type_Outside; ----------------------------------- -- Define_Structure_Type_Outside -- ----------------------------------- procedure Define_Structure_Type_Outside (Member : Node_Id; Entity : Node_Id; Before : Node_Id) is Type_Spec : Node_Id; New_Identifier : Node_Id; New_Scoped_Name : Node_Id; Container : Node_Id; begin Type_Spec := FEN.Type_Spec (Member); pragma Assert (FEN.Kind (Type_Spec) = K_Structure_Type); -- The new type spec scoped name New_Identifier := FEU.Make_Identifier (Loc => FEN.Loc (Identifier (Type_Spec)), IDL_Name => IDL_Name (Identifier (Type_Spec)), Node => No_Node, Scope_Entity => Type_Spec); New_Scoped_Name := FEU.Make_Scoped_Name (Loc => FEN.Loc (New_Identifier), Identifier => New_Identifier, Parent => No_Node, Reference => Type_Spec); -- Modifying the type spec of the member Set_Type_Spec (Member, New_Scoped_Name); -- Move the Type_Spec declaration immediately before the -- declaration of entity. Container := FEN.Scope_Entity (FEN.Identifier (Entity)); Insert_Definition (Type_Spec, Before, In_Container => Container); -- Modify the Scope_Entity and the Potential_Scope of the Type_Spec FEN.Set_Scope_Entity (FEN.Identifier (Type_Spec), Scope_Entity (Identifier (Entity))); FEN.Set_Potential_Scope (FEN.Identifier (Type_Spec), Potential_Scope (Identifier (Entity))); -- Expand the new created type to detect any nested anonymous -- types, implicit forwards or complex declarators. Expand_Structure_Type (Type_Spec); end Define_Structure_Type_Outside; --------------------------- -- Handle_Anonymous_Type -- --------------------------- procedure Handle_Anonymous_Type (Entity : Node_Id; Parent : Node_Id; Before : Node_Id) is Anon_Type_Prefix : constant String := "IDL_AT_"; Anon_Type_Name : Name_Id; B : Int; New_Identifier : Node_Id; New_Scoped_Name : Node_Id; Declarator : Node_Id; Node : Node_Id; List : List_Id; Entity_Type_Spec : Node_Id; begin -- The name of the type spec fields is different for union type -- nodes. if FEN.Kind (Entity) = K_Union_Type then Entity_Type_Spec := Switch_Type_Spec (Entity); else Entity_Type_Spec := Type_Spec (Entity); end if; case FEN.Kind (Entity_Type_Spec) is when K_Sequence_Type => declare Max_S : Value_Type; Type_Spec_Name : Name_Id; begin -- First of all, handle the type spec of the sequence Handle_Anonymous_Type (Entity_Type_Spec, Parent, Before); -- Begin the handling of the sequence type Set_Str_To_Name_Buffer (Anon_Type_Prefix); -- For type declaration, the expansion of the type -- does not occur only when there are complex -- declarators. if FEN.Kind (Entity) /= K_Type_Declaration or else Has_Complex_Declarators (Entity) then Add_Str_To_Name_Buffer ("Sequence_"); if Present (Max_Size (Entity_Type_Spec)) then Max_S := FEU.Expr_Value (Max_Size (Entity_Type_Spec)); Add_Dnat_To_Name_Buffer (Dnat (Max_S.IVal)); Add_Char_To_Name_Buffer ('_'); end if; Anon_Type_Name := Name_Find; if Is_Base_Type (Type_Spec (Entity_Type_Spec)) then Type_Spec_Name := (FEN.Image (Base_Type (Type_Spec (Entity_Type_Spec)))); elsif FEN.Kind (Type_Spec (Entity_Type_Spec)) = K_Scoped_Name then Type_Spec_Name := FEU.Fully_Qualified_Name (FEN.Identifier (FEN.Reference (Type_Spec (Entity_Type_Spec))), Separator => "_"); else raise Program_Error; end if; Anon_Type_Name := Add_Suffix_To_Name (Get_Name_String (Type_Spec_Name), Anon_Type_Name); -- If the type name consists of two or more words, -- replace spaces by underscores. Get_Name_String (Anon_Type_Name); for Index in 1 .. Name_Len loop if Name_Buffer (Index) = ' ' then Name_Buffer (Index) := '_'; end if; end loop; Anon_Type_Name := Name_Find; else -- Do not expand anything return; end if; end; when K_String_Type | K_Wide_String_Type => declare Max_S : Value_Type; begin Set_Str_To_Name_Buffer (Anon_Type_Prefix); -- For type declarations, the expansion of the type -- occurs only when there are complex declarators. if FEN.Kind (Entity) = K_Type_Declaration and then not Has_Complex_Declarators (Entity) then return; else if FEN.Kind (Entity_Type_Spec) = K_Wide_String_Type then Add_Str_To_Name_Buffer ("Wide_"); end if; Add_Str_To_Name_Buffer ("String_"); Max_S := FEU.Expr_Value (Max_Size (Entity_Type_Spec)); Add_Dnat_To_Name_Buffer (Dnat (Max_S.IVal)); Anon_Type_Name := Name_Find; end if; end; when K_Fixed_Point_Type => begin Set_Str_To_Name_Buffer (Anon_Type_Prefix); -- For type declaration, the expansion of the type -- does not occur only when there are complex -- declarators. if FEN.Kind (Entity) /= K_Type_Declaration or else Has_Complex_Declarators (Entity) then Add_Str_To_Name_Buffer ("Fixed_"); Add_Nat_To_Name_Buffer (Nat (N_Total (Entity_Type_Spec))); Add_Char_To_Name_Buffer ('_'); Add_Nat_To_Name_Buffer (Nat (N_Scale (Entity_Type_Spec))); Anon_Type_Name := Name_Find; else -- We do not expand anything return; end if; end; when K_Enumeration_Type => begin Get_Name_String (IDL_Name (Identifier (Entity_Type_Spec))); Anon_Type_Name := Name_Find; end; when others => return; end case; -- Verify that there is no other handled anonymous type with -- the same name in the 'Parent' scope. B := Get_Name_Table_Info (Anon_Type_Name); if B = Int (Parent) then Get_Name_String (Anon_Type_Name); Add_Char_To_Name_Buffer ('_'); Add_Nat_To_Name_Buffer (New_Anonymous_Type_Index); Anon_Type_Name := Name_Find; end if; Set_Name_Table_Info (Anon_Type_Name, Int (Parent)); -- Create the type declaration if FEN.Kind (Entity_Type_Spec) = K_Enumeration_Type then declare Enumerator : Node_Id; begin -- Readjusting the scope entity of elements Set_Scope_Entity (Identifier (Entity_Type_Spec), Parent); Set_Potential_Scope (Identifier (Entity_Type_Spec), Parent); Enumerator := First_Entity (Enumerators (Entity_Type_Spec)); while Present (Enumerator) loop Set_Scope_Entity (Identifier (Enumerator), Parent); Set_Potential_Scope (Identifier (Enumerator), Parent); Enumerator := Next_Entity (Enumerator); end loop; if FEN.Kind (Entity) = K_Union_Type then -- Readjusting the scope entity of labels declare Alternatives : List_Id; Alternative : Node_Id; Labels : List_Id; Label : Node_Id; X : Node_Id; begin Alternatives := Switch_Type_Body (Entity); Alternative := First_Entity (Alternatives); while Present (Alternative) loop Labels := FEN.Labels (Alternative); Label := First_Entity (Labels); while Present (Label) loop X := FEN.Expression (Label); if Present (X) and then FEN.Kind (X) = K_Scoped_Name then Set_Scope_Entity (Identifier (Reference (X)), Parent); Set_Potential_Scope (Identifier (Reference (X)), Parent); end if; Label := Next_Entity (Label); end loop; Alternative := Next_Entity (Alternative); end loop; end; end if; Node := Entity_Type_Spec; Declarator := Entity_Type_Spec; end; else New_Identifier := FEU.Make_Identifier (Loc => FEN.Loc (Entity), IDL_Name => Anon_Type_Name, Node => No_Node, Scope_Entity => Parent); Declarator := FEU.New_Node (K_Simple_Declarator, FEN.Loc (Entity)); FEU.Bind_Identifier_To_Entity (New_Identifier, Declarator); List := FEU.New_List (FEN.Loc (Entity)); FEU.Append_To (List, Declarator); Node := FEU.New_Node (K_Type_Declaration, FEN.Loc (Entity)); Set_Type_Spec (Node, Type_Spec (Entity)); Set_Declarators (Node, List); FEU.Bind_Declarators_To_Entity (List, Node); end if; -- Insert the new declaration Insert_Definition (Node, Before, In_Container => Parent); -- The type spec has to be modified using the new defined type -- declaration. New_Identifier := FEU.Make_Identifier (Loc => FEN.Loc (Entity), IDL_Name => Anon_Type_Name, Node => No_Node, Scope_Entity => Node); New_Scoped_Name := FEU.Make_Scoped_Name (Loc => FEN.Loc (Entity), Identifier => New_Identifier, Parent => No_Node, Reference => Declarator); FEU.Bind_Identifier_To_Entity (New_Identifier, New_Scoped_Name); if FEN.Kind (Entity) = K_Union_Type then Set_Switch_Type_Spec (Entity, New_Scoped_Name); else Set_Type_Spec (Entity, New_Scoped_Name); end if; end Handle_Anonymous_Type; ------------------------------ -- New_Anonymous_Type_Index -- ------------------------------ function New_Anonymous_Type_Index return Nat is begin Anonymous_Type_Index_Value := Anonymous_Type_Index_Value + 1; return Anonymous_Type_Index_Value; end New_Anonymous_Type_Index; ----------------------------- -- Has_Complex_Declarators -- ----------------------------- function Has_Complex_Declarators (Entity : Node_Id) return Boolean is pragma Assert (FEN.Kind (Entity) = K_Type_Declaration); Declarator : Node_Id := First_Entity (Declarators (Entity)); begin while Present (Declarator) loop if FEN.Kind (Declarator) = K_Complex_Declarator then return True; end if; Declarator := Next_Entity (Declarator); end loop; return False; end Has_Complex_Declarators; ------------ -- Expand -- ------------ procedure Expand (Entity : Node_Id) is begin case FEN.Kind (Entity) is when K_Specification => Expand_Specification (Entity); when K_Exception_Declaration => Expand_Exception_Declaration (Entity); when K_Forward_Interface_Declaration => Expand_Forward_Interface_Declaration (Entity); when K_Interface_Declaration => Expand_Interface_Declaration (Entity); when K_Structure_Type => Expand_Structure_Type (Entity); when K_Union_Type => Expand_Union_Type (Entity); when K_Type_Declaration => Expand_Type_Declaration (Entity); when K_Module => Expand_Module (Entity); when K_Attribute_Declaration => Expand_Attribute_Declaration (Entity); when K_Constant_Declaration => Expand_Constant_Declaration (Entity); when K_Operation_Declaration => Expand_Operation_Declaration (Entity); when K_Parameter_Declaration => Expand_Parameter_Declaration (Entity); when K_Element => Expand_Element (Entity); when K_Member => Expand_Member (Entity); when others => null; end case; end Expand; ---------------------------------- -- Expand_Attribute_Declaration -- ---------------------------------- procedure Expand_Attribute_Declaration (Entity : Node_Id) is Getter_Prefix : constant String := "get_"; Setter_Prefix : constant String := "set_"; Parent_Interface : Node_Id; D : Node_Id; Accessor : Node_Id; Accessor_Name : Name_Id; Accessor_Id : Node_Id; Node : Node_Id; Param_Declaration : Node_Id; Parameters : List_Id; begin D := First_Entity (Declarators (Entity)); while Present (D) loop Parent_Interface := Scope_Entity (Identifier (D)); if not Is_Readonly (Entity) then -- Building the Set_ operation Accessor := FEU.New_Node (K_Operation_Declaration, FEN.Loc (D)); -- Set_ identifier Accessor_Name := Add_Prefix_To_Name (Setter_Prefix, FEN.IDL_Name (Identifier (D))); Accessor_Id := FEU.Make_Identifier (No_Location, Accessor_Name, No_Node, Parent_Interface); FEU.Bind_Identifier_To_Entity (Accessor_Id, Accessor); -- Profile and type spec Set_Type_Spec (Accessor, Parser.Resolve_Base_Type ((1 => Lexer.T_Void), FEN.Loc (D))); Parameters := FEU.New_List (FEN.Loc (D)); Set_Parameters (Accessor, Parameters); -- Adding the 'To' parameter Set_Str_To_Name_Buffer ("To"); Accessor_Id := FEU.Make_Identifier (No_Location, Name_Find, No_Node, Accessor); Node := FEU.New_Node (K_Simple_Declarator, No_Location); FEU.Bind_Identifier_To_Entity (Accessor_Id, Node); Param_Declaration := FEU.New_Node (K_Parameter_Declaration, FEN.Loc (D)); FEN.Set_Parameter_Mode (Param_Declaration, Mode_In); Set_Type_Spec (Param_Declaration, Type_Spec (Entity)); Set_Declarator (Param_Declaration, Node); FEU.Bind_Declarator_To_Entity (Node, Param_Declaration); FEU.Append_To (Parameters, Param_Declaration); -- Exceptions Set_Exceptions (Accessor, Setter_Exceptions (Entity)); -- Inserting the new operation FEU.Insert_After_Node (Accessor, Entity); end if; -- Building the Get_ operation Accessor := FEU.New_Node (K_Operation_Declaration, FEN.Loc (D)); -- Get_ identifier Accessor_Name := Add_Prefix_To_Name (Getter_Prefix, FEN.IDL_Name (Identifier (D))); Accessor_Id := FEU.Make_Identifier (No_Location, Accessor_Name, No_Node, Parent_Interface); FEU.Bind_Identifier_To_Entity (Accessor_Id, Accessor); -- Profile and type spec Set_Type_Spec (Accessor, Type_Spec (Entity)); Parameters := FEU.New_List (FEN.Loc (D)); Set_Parameters (Accessor, Parameters); -- Exceptions Set_Exceptions (Accessor, Getter_Exceptions (Entity)); -- Inserting the new operation FEU.Insert_After_Node (Accessor, Entity); D := Next_Entity (D); end loop; end Expand_Attribute_Declaration; ---------------------------------- -- Expand_Exception_Declaration -- ---------------------------------- procedure Expand_Exception_Declaration (Entity : Node_Id) is Members : List_Id; Member : Node_Id; Declarator : Node_Id; Member_Type : Node_Id; begin Members := FEN.Members (Entity); Member := First_Entity (Members); -- 1st pass to handle anonymous types in members Main_Loop : while Present (Member) loop Declarator := First_Entity (Declarators (Member)); Member_Type := Type_Spec (Member); while Present (Declarator) loop if Is_Forward_Necessary (Entity, Member_Type) then Set_Reference (Member_Type, Add_Forward_Declaration (FEN.Reference (Member_Type))); exit Main_Loop; end if; Declarator := Next_Entity (Declarator); end loop; -- If the member type is a structure type, extract the -- nested structure definition outside. if FEN.Kind (Member_Type) = FEN.K_Structure_Type then Define_Structure_Type_Outside (Member => Member, Entity => Entity, Before => Entity); end if; Member := Next_Entity (Member); end loop Main_Loop; -- 2nd pass to expand complex declarators into array type -- definitions. Member := First_Entity (Members); while Present (Member) loop Member_Type := Type_Spec (Member); Declarator := First_Entity (Declarators (Member)); while Present (Declarator) loop if FEN.Kind (Declarator) = FEN.K_Complex_Declarator then declare New_Member : Node_Id; New_Declarator : Node_Id; begin -- Remove the declarator from the declarators list -- of the member. FEU.Remove_Node_From_List (Declarator, Declarators (Member)); -- Remove the member from the member list if it has -- no more declarators. if FEU.Is_Empty (Declarators (Member)) then FEU.Remove_Node_From_List (Member, Members); end if; -- Add a new member after the current one New_Member := FEU.New_Node (K_Member, FEN.Loc (Member)); -- Set the declarator of the member Set_Declarators (New_Member, FEU.New_List (FEN.Loc (Declarator))); New_Declarator := FEU.New_Node (K_Complex_Declarator, FEN.Loc (Declarator)); Set_Identifier (New_Declarator, Identifier (Declarator)); Set_Declaration (New_Declarator, New_Member); Set_Array_Sizes (New_Declarator, Array_Sizes (Declarator)); FEU.Append_To (Declarators (New_Member), New_Declarator); -- Set the type spec of the new member as eqaul to -- the type spec of the current member. Set_Type_Spec (New_Member, Member_Type); -- Declare the array type before the structure type -- and modify the new member. Define_Array_Type_Outside (New_Member, Entity, Entity); -- Insert the new member in the structure type FEU.Insert_Before_Node (New_Member, Next_Entity (Member), Members); end; end if; Declarator := Next_Entity (Declarator); end loop; Member := Next_Entity (Member); end loop; end Expand_Exception_Declaration; ------------------------------------------ -- Expand_Forward_Interface_Declaration -- ------------------------------------------ procedure Expand_Forward_Interface_Declaration (Entity : Node_Id) is begin Set_Forwarded (Forward (Entity)); end Expand_Forward_Interface_Declaration; ---------------------------------- -- Expand_Interface_Declaration -- ---------------------------------- procedure Expand_Interface_Declaration (Entity : Node_Id) is N : Node_Id; begin N := First_Entity (Interface_Body (Entity)); while Present (N) loop Expand (N); N := Next_Entity (N); end loop; end Expand_Interface_Declaration; ------------------- -- Expand_Module -- ------------------- procedure Expand_Module (Entity : Node_Id) is D : Node_Id; New_CORBA_Contents : List_Id; Definition : Node_Id; CORBA_IR_Root_Node : Node_Id; CORBA_Sequences_Node : Node_Id; L : Location; procedure Relocate (Parent : Node_Id; Child : Node_Id); -- Reparent Node and its named subnodes to the new Parent. This -- procedure is useful when generating code related to the -- CORBA Module. -------------- -- Relocate -- -------------- procedure Relocate (Parent : Node_Id; Child : Node_Id) is pragma Assert (FEN.Kind (Parent) = K_Module); Definitions : constant List_Id := FEN.Definitions (Parent); Dcl_Or_Enum_List : List_Id; Dcl_Or_Enum : Node_Id; Has_Named_Subnodes : Boolean := False; begin -- We must be very careful, because Append_To -- does not add only the node but all the Next_Entities (for -- details, see the calls to this procedure). FEU.Append_To (Definitions, Child); if FEN.Kind (Child) = K_Type_Declaration then Has_Named_Subnodes := True; Dcl_Or_Enum_List := Declarators (Child); else -- Changing the parent. We change only the scope entity -- which is used for Ada code generation. The potential -- scope is kept unchanged in order to generate correct -- repository ids. if Present (Identifier (Child)) then Set_Scope_Entity (Identifier (Child), Parent); end if; if FEN.Kind (Child) = K_Enumeration_Type then Has_Named_Subnodes := True; Dcl_Or_Enum_List := Enumerators (Child); end if; end if; if Has_Named_Subnodes then Dcl_Or_Enum := First_Entity (Dcl_Or_Enum_List); while Present (Dcl_Or_Enum) loop -- Changing the parent if Present (Identifier (Dcl_Or_Enum)) then Set_Scope_Entity (Identifier (Dcl_Or_Enum), Parent); end if; Dcl_Or_Enum := Next_Entity (Dcl_Or_Enum); end loop; end if; end Relocate; begin -- The parsing of the CORBA module is a very particular case if FEN.IDL_Name (Identifier (Entity)) = CORBA_Name then -- This workaround is done to be able to take in account the -- prefix "omg.org". This is due to the fact that the -- created modules do not exist in reality. L := FEN.Loc (Entity); L.Scan := Text_Ptr'Last; New_CORBA_Contents := FEU.New_List (No_Location); -- Creating the CORBA.Repository_Root module declare Identifier : Node_Id; Module_Name : Name_Id; begin CORBA_IR_Root_Node := FEU.New_Node (K_Module, L); Set_Imported (CORBA_IR_Root_Node, Imported (Entity)); Module_Name := Repository_Root_Name; Identifier := FEU.Make_Identifier (Loc => No_Location, IDL_Name => Module_Name, Node => No_Node, Scope_Entity => Entity); FEU.Bind_Identifier_To_Entity (Identifier, CORBA_IR_Root_Node); Set_Definitions (CORBA_IR_Root_Node, FEU.New_List (No_Location)); FEU.Append_To (Definitions (Entity), CORBA_IR_Root_Node); end; -- Creating the CORBA.IDL_Sequences module declare Identifier : Node_Id; Module_Name : Name_Id; begin CORBA_Sequences_Node := FEU.New_Node (K_Module, L); Set_Imported (CORBA_Sequences_Node, Imported (Entity)); Module_Name := IDL_Sequences_Name; Identifier := FEU.Make_Identifier (Loc => No_Location, IDL_Name => Module_Name, Node => No_Node, Scope_Entity => Entity); FEU.Bind_Identifier_To_Entity (Identifier, CORBA_Sequences_Node); Set_Definitions (CORBA_Sequences_Node, FEU.New_List (No_Location)); FEU.Append_To (Definitions (Entity), CORBA_Sequences_Node); end; -- Relocating the CORBA Module entities D := First_Entity (Definitions (Entity)); while Present (D) loop Definition := D; D := Next_Entity (D); -- We must alterate the list because we don't want to -- append all the elements after "Definition". Set_Next_Entity (Definition, No_Node); if Is_CORBA_IR_Entity (Definition) then Relocate (CORBA_IR_Root_Node, Definition); elsif Is_CORBA_Sequence (Definition) then Relocate (CORBA_Sequences_Node, Definition); else FEU.Append_To (New_CORBA_Contents, Definition); end if; end loop; Set_Definitions (Entity, New_CORBA_Contents); end if; -- End of the CORBA Module special handling D := First_Entity (Definitions (Entity)); while Present (D) loop Expand (D); D := Next_Entity (D); end loop; end Expand_Module; -------------------------- -- Expand_Specification -- -------------------------- procedure Expand_Specification (Entity : Node_Id) is Definition : Node_Id; begin Backend.BE_CORBA_Ada.Nutils.Initialize; Definition := First_Entity (Definitions (Entity)); while Present (Definition) loop Expand (Definition); Definition := Next_Entity (Definition); end loop; end Expand_Specification; --------------------------- -- Expand_Structure_Type -- --------------------------- procedure Expand_Structure_Type (Entity : Node_Id) is Members : List_Id; Member : Node_Id; Declarator : Node_Id; Member_Type : Node_Id; Parent : constant Node_Id := Scope_Entity (Identifier (Entity)); begin Members := FEN.Members (Entity); -- 1st pass to handle anonymous types in members Member := First_Entity (Members); while Present (Member) loop -- Handling anonymous types Handle_Anonymous_Type (Member, Parent, Entity); -- Handling implicit forward declarations Member_Type := Type_Spec (Member); Declarator := First_Entity (Declarators (Member)); while Present (Declarator) loop if Is_Forward_Necessary (Entity, Member_Type) then Set_Reference (Member_Type, Add_Forward_Declaration (FEN.Reference (Member_Type))); end if; Declarator := Next_Entity (Declarator); end loop; -- If the member type is a structure type, extract the -- nested structure definition outside. if FEN.Kind (Member_Type) = FEN.K_Structure_Type then Define_Structure_Type_Outside (Member => Member, Entity => Entity, Before => Entity); end if; Member := Next_Entity (Member); end loop; -- 2nd pass to expand complex declarators into array type -- definitions. Member := First_Entity (Members); while Present (Member) loop Member_Type := Type_Spec (Member); Declarator := First_Entity (Declarators (Member)); while Present (Declarator) loop if FEN.Kind (Declarator) = FEN.K_Complex_Declarator then declare New_Member : Node_Id; New_Declarator : Node_Id; begin -- Remove the declarator from the declarators list -- of the member. FEU.Remove_Node_From_List (Declarator, Declarators (Member)); -- Remove the member from the member list if it has -- no more declarators. if FEU.Is_Empty (Declarators (Member)) then FEU.Remove_Node_From_List (Member, Members); end if; -- Add a new member after the current one New_Member := FEU.New_Node (K_Member, FEN.Loc (Member)); -- Set the declarator of the member Set_Declarators (New_Member, FEU.New_List (FEN.Loc (Declarator))); New_Declarator := FEU.New_Node (K_Complex_Declarator, FEN.Loc (Declarator)); Set_Identifier (New_Declarator, Identifier (Declarator)); Set_Declaration (New_Declarator, New_Member); Set_Array_Sizes (New_Declarator, Array_Sizes (Declarator)); FEU.Append_To (Declarators (New_Member), New_Declarator); -- Set the type spec of the new member as eqaul to -- the type spec of the current member. Set_Type_Spec (New_Member, Member_Type); -- Declare the array type before the structure type -- and modify the new member. Define_Array_Type_Outside (New_Member, Entity, Entity); -- Insert the new member in the structure type FEU.Insert_Before_Node (New_Member, Next_Entity (Member), Members); end; end if; Declarator := Next_Entity (Declarator); end loop; Member := Next_Entity (Member); end loop; end Expand_Structure_Type; ----------------------------- -- Expand_Type_Declaration -- ----------------------------- procedure Expand_Type_Declaration (Entity : Node_Id) is D : Node_Id; Type_Spec_Node : Node_Id; Is_Seq_Type : Boolean := False; Parent : constant Node_Id := Scope_Entity (Identifier (First_Entity (Declarators (Entity)))); begin -- Handling anonymous types Handle_Anonymous_Type (Entity, Parent, Entity); -- Handling Implicit Forward declarations Type_Spec_Node := Type_Spec (Entity); -- For the particular case of sequences, we change the type -- spec of the sequence. if FEN.Kind (Type_Spec_Node) = K_Sequence_Type then Type_Spec_Node := Type_Spec (Type_Spec_Node); Is_Seq_Type := True; elsif FEN.Kind (Type_Spec_Node) = FEN.K_Structure_Type then -- If the type spec is a structure type, extract the nested -- structure definition outside. Define_Structure_Type_Outside (Member => Entity, Entity => Type_Spec_Node, Before => Entity); end if; D := First_Entity (Declarators (Entity)); while Present (D) loop if Is_Forward_Necessary (D, Type_Spec_Node) then Set_Reference (Type_Spec_Node, Add_Forward_Declaration (FEN.Reference (Type_Spec_Node))); exit; elsif Is_Seq_Type then Forward_Current_Interface_Designing_Components (FEN.Scope_Entity (FEN.Identifier (D)), Type_Spec_Node); exit; end if; D := Next_Entity (D); end loop; end Expand_Type_Declaration; ----------------------- -- Expand_Union_Type -- ----------------------- procedure Expand_Union_Type (Entity : Node_Id) is Alternatives : List_Id; Alternative : Node_Id; Element : Node_Id; Type_Spec : Node_Id; Label : Node_Id; Case_Labels : List_Id; Parent : constant Node_Id := Scope_Entity (Identifier (Entity)); begin -- Expanding the switch type spec Handle_Anonymous_Type (Entity, Parent, Entity); -- 1st pass to handle anonymous types in elements -- Expanding switch alternatives Alternatives := Switch_Type_Body (Entity); Alternative := First_Entity (Alternatives); while Present (Alternative) loop Element := FEN.Element (Alternative); -- Handling anonymous types Handle_Anonymous_Type (Element, Parent, Entity); -- Handling implicit forward declarations Type_Spec := FEN.Type_Spec (Element); if Is_Forward_Necessary (Entity, Type_Spec) then Set_Reference (Type_Spec, Add_Forward_Declaration (FEN.Reference (Type_Spec))); end if; if FEN.Kind (Type_Spec) = FEN.K_Structure_Type then Define_Structure_Type_Outside (Member => Element, Entity => Entity, Before => Entity); end if; Alternative := Next_Entity (Alternative); end loop; -- 2nd pass to expand complex declarators into array type -- definitions. Alternative := First_Entity (Alternatives); while Present (Alternative) loop Element := FEN.Element (Alternative); if FEN.Kind (Declarator (Element)) = FEN.K_Complex_Declarator then -- Declare the array type before the structure type -- and modify the new member. Define_Array_Type_Outside (Element, Entity, Entity); end if; Alternative := Next_Entity (Alternative); end loop; -- 3rd pass to reduce any label choice list containing -- "default:" and other cases to the simple "default:" case Alternative := First_Entity (Alternatives); External_Loop : while Present (Alternative) loop if FEU.Length (Labels (Alternative)) > 1 then Label := First_Entity (Labels (Alternative)); while Present (Label) loop if Value (Label) = No_Value then FEU.Remove_Node_From_List (Label, Labels (Alternative)); Set_Next_Entity (Label, No_Node); Case_Labels := FEU.New_List (Loc (Alternative)); FEU.Append_To (Case_Labels, Label); Set_Labels (Alternative, Case_Labels); exit External_Loop; end if; Label := Next_Entity (Label); end loop; end if; Alternative := Next_Entity (Alternative); end loop External_Loop; end Expand_Union_Type; --------------------------------- -- Expand_Constant_Declaration -- --------------------------------- procedure Expand_Constant_Declaration (Entity : Node_Id) is Parent : constant Node_Id := Scope_Entity (Identifier (Entity)); begin Handle_Anonymous_Type (Entity, Parent, Entity); end Expand_Constant_Declaration; ---------------------------------- -- Expand_Operation_Declaration -- ---------------------------------- procedure Expand_Operation_Declaration (Entity : Node_Id) is Parent : constant Node_Id := Scope_Entity (Identifier (Entity)); N : Node_Id; begin Handle_Anonymous_Type (Entity, Parent, Entity); N := First_Entity (Parameters (Entity)); while Present (N) loop Expand (N); N := Next_Entity (N); end loop; end Expand_Operation_Declaration; -------------------- -- Expand_Element -- -------------------- procedure Expand_Element (Entity : Node_Id) is Before : constant Node_Id := Scope_Entity (Identifier (Declarator (Entity))); Parent : constant Node_Id := Scope_Entity (Identifier (Before)); begin Handle_Anonymous_Type (Entity, Parent, Before); end Expand_Element; ------------------- -- Expand_Member -- ------------------- procedure Expand_Member (Entity : Node_Id) is Before : constant Node_Id := Scope_Entity (Identifier (First_Entity (Declarators (Entity)))); Parent : constant Node_Id := Scope_Entity (Identifier (Before)); begin Handle_Anonymous_Type (Entity, Parent, Before); end Expand_Member; ----------------------- -- Insert_Definition -- ----------------------- procedure Insert_Definition (E, Before, In_Container : Node_Id) is Definitions : List_Id; begin if FEN.Kind (In_Container) = K_Module or else FEN.Kind (In_Container) = K_Specification then Definitions := FEN.Definitions (In_Container); elsif FEN.Kind (In_Container) = K_Interface_Declaration then Definitions := FEN.Interface_Body (In_Container); else raise Program_Error with "Bad container"; end if; FEU.Insert_Before_Node (E, Before, Definitions); end Insert_Definition; ------------------------ -- Is_CORBA_IR_Entity -- ------------------------ -- CORBA 3.0 Interface Repository entities CORBA_IR_Names : constant array (Positive range <>) of String_Ptr := (new String'("CORBA::AbstractInterfaceDef"), -- interface new String'("CORBA::AbstractInterfaceDefSeq"), -- typedef/sequence new String'("CORBA::AliasDef"), -- interface new String'("CORBA::ArrayDef"), -- interface new String'("CORBA::AttrDescriptionSeq"), -- typedef/sequence new String'("CORBA::AttributeDef"), -- interface new String'("CORBA::AttributeDescription"), -- struct new String'("CORBA::AttributeMode"), -- enum new String'("CORBA::ComponentIR"), -- module new String'("CORBA::ConstantDef"), -- interface new String'("CORBA::ConstantDescription"), -- struct new String'("CORBA::Contained"), -- interface new String'("CORBA::ContainedSeq"), -- typedef/sequence new String'("CORBA::Container"), -- interface new String'("CORBA::ContextIdentifier"), -- typedef new String'("CORBA::ContextIdSeq"), -- typedef/sequence new String'("CORBA::DefinitionKind"), -- enum new String'("CORBA::EnumDef"), -- interface new String'("CORBA::EnumMemberSeq"), -- typedef/sequence new String'("CORBA::ExcDescriptionSeq"), -- typedef/sequence new String'("CORBA::ExceptionDef"), -- interface new String'("CORBA::ExceptionDefSeq"), -- typedef/sequence new String'("CORBA::ExceptionDescription"), -- struct new String'("CORBA::ExtAttrDescriptionSeq"), -- typedef/sequence new String'("CORBA::ExtAttributeDef"), -- interface new String'("CORBA::ExtAttributeDescription"), -- struct new String'("CORBA::ExtAbstractInterfaceDef"), -- interface new String'("CORBA::ExtAbstractInterfaceDefSeq"), -- typedef/sequence new String'("CORBA::ExtInterfaceDef"), -- interface new String'("CORBA::ExtInterfaceDefSeq"), -- typedef/sequence new String'("CORBA::ExtInitializer"), -- struct new String'("CORBA::ExtInitializerSeq"), -- typedef/sequence new String'("CORBA::ExtLocalInterfaceDef"), -- interface new String'("CORBA::ExtLocalInterfaceDefSeq"), -- typedef/sequence new String'("CORBA::ExtValueDef"), -- interface new String'("CORBA::ExtValueDefSeq"), -- typedef/sequence new String'("CORBA::FixedDef"), -- interface new String'("CORBA::IDLType"), -- interface new String'("CORBA::InterfaceAttrExtension"), -- interface new String'("CORBA::InterfaceDef"), -- interface new String'("CORBA::InterfaceDefSeq"), -- typedef/sequence new String'("CORBA::InterfaceDescription"), -- struct new String'("CORBA::Initializer"), -- struct new String'("CORBA::InitializerSeq"), -- typedef/sequence new String'("CORBA::IRObject"), -- interface new String'("CORBA::LocalInterfaceDef"), -- interface new String'("CORBA::LocalInterfaceDefSeq"), -- typedef/sequence new String'("CORBA::ModuleDef"), -- interface new String'("CORBA::ModuleDescription"), -- struct new String'("CORBA::NativeDef"), -- interface new String'("CORBA::OpDescriptionSeq"), -- typedef/sequence new String'("CORBA::OperationDef"), -- interface new String'("CORBA::OperationDescription"), -- struct new String'("CORBA::OperationMode"), -- enum new String'("CORBA::ParameterDescription"), -- struct new String'("CORBA::ParameterMode"), -- enum new String'("CORBA::ParDescriptionSeq"), -- typedef/sequence new String'("CORBA::PrimitiveDef"), -- interface new String'("CORBA::PrimitiveKind"), -- enum new String'("CORBA::Repository"), -- interface new String'("CORBA::RepositoryIdSeq"), -- typedef/sequence new String'("CORBA::SequenceDef"), -- interface new String'("CORBA::StringDef"), -- interface new String'("CORBA::StructDef"), -- interface new String'("CORBA::StructMember"), -- struct new String'("CORBA::StructMemberSeq"), -- typedef/sequence new String'("CORBA::TypedefDef"), -- interface new String'("CORBA::TypeDescription"), -- struct new String'("CORBA::UnionDef"), -- interface new String'("CORBA::UnionMember"), -- struct new String'("CORBA::UnionMemberSeq"), -- typedef/sequence new String'("CORBA::ValueBoxDef"), -- interface new String'("CORBA::ValueDef"), -- interface new String'("CORBA::ValueDefSeq"), -- typedef/sequence new String'("CORBA::ValueDescription"), -- struct new String'("CORBA::ValueMember"), -- struct new String'("CORBA::ValueMemberSeq"), -- typedef/sequence new String'("CORBA::ValueMemberDef"), -- interface new String'("CORBA::VersionSpec"), -- typedef new String'("CORBA::WstringDef")); function Is_CORBA_IR_Entity (Entity : Node_Id) return Boolean is NK : constant FEN.Node_Kind := FEN.Kind (Entity); N : Node_Id := Entity; begin if NK /= K_Interface_Declaration and then NK /= K_Forward_Interface_Declaration and then NK /= K_Simple_Declarator and then NK /= K_Complex_Declarator and then NK /= K_Type_Declaration and then NK /= K_Structure_Type and then NK /= K_Enumeration_Type then return False; end if; if NK = K_Type_Declaration then N := First_Entity (Declarators (Entity)); end if; declare Name : constant Name_Id := FEU.Fully_Qualified_Name (Identifier (N), Separator => "::"); begin for J in CORBA_IR_Names'Range loop if CORBA_IR_Names (J).all = Get_Name_String (Name) then return True; end if; end loop; end; return False; end Is_CORBA_IR_Entity; ----------------------- -- Is_CORBA_Sequence -- ----------------------- -- CORBA 3.0 sequences relocated to CORBA.IDL_Sequences package CORBA_Sequences_Names : constant array (Positive range <>) of String_Ptr := (new String'("CORBA::AnySeq"), new String'("CORBA::BooleanSeq"), new String'("CORBA::CharSeq"), new String'("CORBA::WCharSeq"), new String'("CORBA::OctetSeq"), new String'("CORBA::ShortSeq"), new String'("CORBA::UShortSeq"), new String'("CORBA::LongSeq"), new String'("CORBA::ULongSeq"), new String'("CORBA::LongLongSeq"), new String'("CORBA::ULongLongSeq"), new String'("CORBA::FloatSeq"), new String'("CORBA::DoubleSeq"), new String'("CORBA::LongDoubleSeq"), new String'("CORBA::StringSeq"), new String'("CORBA::WStringSeq")); function Is_CORBA_Sequence (Entity : Node_Id) return Boolean is NK : constant FEN.Node_Kind := FEN.Kind (Entity); N : Node_Id := Entity; begin if NK /= K_Type_Declaration then return False; end if; N := First_Entity (Declarators (Entity)); declare Name : constant Name_Id := FEU.Fully_Qualified_Name (Identifier (N), Separator => "::"); begin for J in CORBA_Sequences_Names'Range loop if CORBA_Sequences_Names (J).all = Get_Name_String (Name) then return True; end if; end loop; end; return False; end Is_CORBA_Sequence; end Backend.BE_CORBA_Ada.Expand; polyorb-2.8~20110207.orig/compilers/iac/backend-be_corba_ada-generator.ads0000644000175000017500000000423511750740337025550 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- B A C K E N D . B E _ C O R B A _ A D A . G E N E R A T O R -- -- -- -- S p e c -- -- -- -- Copyright (C) 2005-2006, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ package Backend.BE_CORBA_Ada.Generator is Var_Name_Len : Natural := 0; procedure Generate (N : Node_Id); end Backend.BE_CORBA_Ada.Generator; polyorb-2.8~20110207.orig/compilers/iac/values.adb0000644000175000017500000007125711750740337021124 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- V A L U E S -- -- -- -- B o d y -- -- -- -- Copyright (C) 2005-2007, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with Namet; use Namet; with GNAT.Table; package body Values is Hex : constant String := "0123456789ABCDEF"; package VT is new GNAT.Table (Value_Type, Value_Id, No_Value + 1, 10, 10); subtype ULL is Unsigned_Long_Long; procedure Add_ULL_To_Name_Buffer (U : ULL; B : ULL; S : Integer := 1); LULL_Div_10 : constant Unsigned_Long_Long := LULL / 10; --------- -- "*" -- --------- function "*" (L, R : Value_Type) return Value_Type is V : Value_Type := L; begin case V.K is when K_Short .. K_Unsigned_Long_Long | K_Octet => if L.Base = R.Base then V.Base := 10; end if; V.Sign := L.Sign * R.Sign; V.IVal := L.IVal * R.IVal; when K_Fixed_Point_Type => V.Sign := L.Sign * R.Sign; V.IVal := L.IVal * R.IVal; V.Total := L.Total + R.Total; V.Scale := L.Scale + R.Scale; Normalize_Fixed_Point_Value (V); when K_Float .. K_Long_Double => V.FVal := L.FVal * R.FVal; when others => return Bad_Value; end case; return V; end "*"; --------- -- "+" -- --------- function "+" (L, R : Value_Type) return Value_Type is V : Value_Type := R; NL : Value_Type := L; NR : Value_Type := R; begin case R.K is when K_Short .. K_Unsigned_Long_Long | K_Octet => if L.Base /= R.Base then V.Base := 10; end if; if L.Sign = R.Sign then V.IVal := L.IVal + R.IVal; elsif R.IVal <= L.IVal then V.Sign := L.Sign; V.IVal := L.IVal - R.IVal; else V.Sign := -L.Sign; V.IVal := R.IVal - L.IVal; end if; when K_Fixed_Point_Type => if NL.Scale > NR.Scale then NR.IVal := NR.IVal * 10 ** Integer (L.Scale - R.Scale); V.Scale := NL.Scale; else NL.IVal := L.IVal * 10 ** Integer (R.Scale - L.Scale); V.Scale := NR.Scale; end if; if NL.Sign = NR.Sign then V.IVal := NL.IVal + NR.IVal; elsif NR.IVal <= NL.IVal then V.Sign := NL.Sign; V.IVal := NL.IVal - NR.IVal; else V.Sign := -NL.Sign; V.IVal := NR.IVal - NL.IVal; end if; Normalize_Fixed_Point_Value (V); when K_Float .. K_Long_Double => V.FVal := L.FVal + R.FVal; when others => return Bad_Value; end case; return V; end "+"; --------- -- "-" -- --------- function "-" (R : Value_Type) return Value_Type is V : Value_Type := R; begin case R.K is when K_Short .. K_Unsigned_Long_Long | K_Octet | K_Fixed_Point_Type => V.Sign := -V.Sign; when K_Float .. K_Long_Double => V.FVal := -V.FVal; when others => return Bad_Value; end case; return V; end "-"; --------- -- "-" -- --------- function "-" (L, R : Value_Type) return Value_Type is V : Value_Type := R; begin case R.K is when K_Short .. K_Unsigned_Long_Long | K_Octet | K_Fixed_Point_Type => V.Sign := -V.Sign; when K_Float .. K_Long_Double => V.FVal := -V.FVal; when others => return Bad_Value; end case; return L + V; end "-"; --------- -- "/" -- --------- function "/" (L, R : Value_Type) return Value_Type is V : Value_Type := L; NL : Value_Type := L; begin case V.K is when K_Short .. K_Unsigned_Long_Long | K_Octet => if L.Base = R.Base then V.Base := 10; end if; V.Sign := L.Sign * R.Sign; V.IVal := L.IVal / R.IVal; when K_Float .. K_Long_Double => V.FVal := L.FVal / R.FVal; when K_Fixed_Point_Type => while NL.IVal < LULL_Div_10 loop NL.IVal := NL.IVal * 10; NL.Total := NL.Total + 1; NL.Scale := NL.Scale + 1; end loop; V.Sign := L.Sign * R.Sign; V.IVal := NL.IVal / R.IVal; V.Scale := NL.Scale - R.Scale; Normalize_Fixed_Point_Value (V); when others => return Bad_Value; end case; return V; end "/"; --------- -- "<" -- --------- function "<" (L, R : Value_Type) return Boolean is begin case R.K is when K_Short .. K_Unsigned_Long_Long | K_Octet | K_Boolean => if L.Sign > 0 then if R.Sign > 0 then return L.IVal < R.IVal; else return False; end if; elsif R.Sign > 0 then return True; else return L.IVal > R.IVal; end if; when K_Enumerator => return L.Pos < R.Pos; when K_Fixed_Point_Type => raise Program_Error; when K_Float .. K_Long_Double => raise Program_Error; when K_Char .. K_Wide_Char => return L.CVal < R.CVal; when others => return False; end case; end "<"; ----------- -- "and" -- ----------- function "and" (L, R : Value_Type) return Value_Type is LV : Value_Type := L; RV : Value_Type := R; begin case L.K is when K_Short .. K_Unsigned_Long_Long | K_Octet => if LV.Base /= RV.Base then LV.Base := 10; end if; if LV.Sign < 0 then LV.IVal := LULL - LV.IVal; end if; if RV.Sign < 0 then RV.IVal := LULL - RV.IVal; end if; LV.IVal := LV.IVal and RV.IVal; LV.Sign := 1; when K_Boolean => LV.IVal := LV.IVal and RV.IVal; when others => return Bad_Value; end case; return LV; end "and"; ----------- -- "mod" -- ----------- function "mod" (L, R : Value_Type) return Value_Type is V : Value_Type := L; begin case L.K is when K_Short .. K_Unsigned_Long_Long | K_Octet => if L.Base /= R.Base then V.Base := 10; end if; V.Sign := L.Sign * R.Sign; V.IVal := L.IVal mod R.IVal; when others => return Bad_Value; end case; return V; end "mod"; ----------- -- "not" -- ----------- function "not" (R : Value_Type) return Value_Type is V : Value_Type := R; begin case V.K is when K_Octet | K_Short | K_Unsigned_Short | K_Long | K_Unsigned_Long => V.IVal := Unsigned_Long_Long (not Unsigned_Long (V.IVal)); when K_Long_Long | K_Unsigned_Long_Long => V.IVal := not V.IVal; when K_Boolean => V.IVal := 1 - V.IVal; when others => return Bad_Value; end case; return V; end "not"; ---------- -- "or" -- ---------- function "or" (L, R : Value_Type) return Value_Type is LV : Value_Type := L; RV : Value_Type := R; begin case L.K is when K_Short .. K_Unsigned_Long_Long | K_Octet => if LV.Base /= RV.Base then LV.Base := 10; end if; if LV.Sign < 0 then LV.IVal := LULL - LV.IVal; end if; if RV.Sign < 0 then RV.IVal := LULL - RV.IVal; end if; LV.IVal := LV.IVal or RV.IVal; LV.Sign := 1; when K_Boolean => LV.IVal := LV.IVal or RV.IVal; when others => return Bad_Value; end case; return LV; end "or"; ----------- -- "xor" -- ----------- function "xor" (L, R : Value_Type) return Value_Type is LV : Value_Type := L; RV : Value_Type := R; begin case LV.K is when K_Short .. K_Unsigned_Long_Long | K_Octet => if LV.Base /= RV.Base then LV.Base := 10; end if; if LV.Sign < 0 then LV.IVal := LULL - LV.IVal; end if; if RV.Sign < 0 then RV.IVal := LULL - RV.IVal; end if; LV.IVal := LV.IVal xor RV.IVal; LV.Sign := 1; when K_Boolean => LV.IVal := LV.IVal xor RV.IVal; when others => return Bad_Value; end case; return LV; end "xor"; ---------------------------- -- Add_ULL_To_Name_Buffer -- ---------------------------- procedure Add_ULL_To_Name_Buffer (U : ULL; B : ULL; S : Integer := 1) is Q : constant ULL := U / B; R : constant ULL := U mod B; begin if Q /= 0 or else S > 1 then Add_ULL_To_Name_Buffer (Q, B, S - 1); end if; Add_Char_To_Name_Buffer (Hex (Hex'First + Natural (R))); end Add_ULL_To_Name_Buffer; ------------- -- Convert -- ------------- function Convert (V : Value_Type; K : Node_Kind) return Value_Type is R : Value_Type (K); begin case K is when K_Short .. K_Unsigned_Long_Long | K_Octet => R.IVal := V.IVal; R.Sign := V.Sign; R.Base := V.Base; when K_Fixed_Point_Type => R.IVal := V.IVal; R.Sign := V.Sign; R.Total := V.Total; R.Scale := V.Scale; when K_Float .. K_Long_Double => R.FVal := V.FVal; when K_Char .. K_Wide_Char => R.CVal := V.CVal; when K_String .. K_Wide_String => R.SVal := V.SVal; when K_Boolean => R.IVal := V.IVal; when others => return V; end case; return R; end Convert; ----------- -- Image -- ----------- function Image (Value : Value_Id) return String is V : Value_Type; begin if Value = No_Value then return "<>"; end if; V := VT.Table (Value); Name_Len := 0; case V.K is when K_Boolean => if V.IVal = 1 then return "TRUE"; else return "FALSE"; end if; when K_Short .. K_Unsigned_Long_Long | K_Octet => if V.Sign < 0 then Add_Char_To_Name_Buffer ('-'); elsif V.Base = 16 then Add_Str_To_Name_Buffer ("0X"); elsif V.Base = 8 then Add_Char_To_Name_Buffer ('0'); end if; Add_ULL_To_Name_Buffer (V.IVal, ULL (V.Base)); when K_Fixed_Point_Type => if V.Sign < 0 then Add_Char_To_Name_Buffer ('-'); end if; Add_ULL_To_Name_Buffer (V.IVal / 10 ** Natural (V.Scale), 10); if V.Scale > 0 then Add_Char_To_Name_Buffer ('.'); Add_ULL_To_Name_Buffer (V.IVal mod 10 ** Natural (V.Scale), 10); end if; Add_Char_To_Name_Buffer ('D'); when K_Float .. K_Long_Double => Add_Str_To_Name_Buffer (Long_Double'Image (V.FVal)); declare Index : Natural := Name_Len; begin -- Find exponent if any while Index > 0 and then Name_Buffer (Index) /= 'E' loop Index := Index - 1; end loop; -- Remove leading zero in exponent part. if Index > 0 then Index := Index + 2; while Index <= Name_Len and then Name_Buffer (Index) = '0' loop Name_Buffer (Index .. Name_Len - 1) := Name_Buffer (Index + 1 .. Name_Len); Name_Len := Name_Len - 1; end loop; -- Remove exponent if Index > Name_Len then Name_Len := Name_Len - 2; Index := Name_Len; else Index := Name_Len; while Name_Buffer (Index) /= 'E' loop Index := Index - 1; end loop; Index := Index - 1; end if; end if; -- Remove trailing zero in fraction part. while Name_Buffer (Index) = '0' loop exit when Name_Buffer (Index - 1) = '.'; Name_Buffer (Index .. Name_Len - 1) := Name_Buffer (Index + 1 .. Name_Len); Name_Len := Name_Len - 1; Index := Index - 1; end loop; end; when K_Char | K_Wide_Char => if V.K = K_Wide_Char then Add_Char_To_Name_Buffer ('L'); end if; Add_Char_To_Name_Buffer ('''); if V.CVal <= 127 then declare C : constant Character := Character'Val (Natural (V.CVal)); begin if C in '!' .. '~' then Add_Char_To_Name_Buffer (C); else Add_Char_To_Name_Buffer ('\'); Add_ULL_To_Name_Buffer (ULL (V.CVal), 8, 3); end if; end; else Add_Str_To_Name_Buffer ("\u"); Add_ULL_To_Name_Buffer (ULL (V.CVal), 16); end if; Add_Char_To_Name_Buffer ('''); when K_String | K_Wide_String | K_String_Type | K_Wide_String_Type => if V.SVal = No_Name then return '"' & '"'; end if; if V.K = K_Wide_String or else V.K = K_Wide_String_Type then Add_Char_To_Name_Buffer ('L'); Add_Char_To_Name_Buffer ('"'); -- " declare S : constant String := Get_Name_String (V.SVal); I : Natural := 0; L : constant Natural := S'Last; C : Natural; begin while I < L loop I := I + 1; if S (I) = ASCII.NUL then I := I + 1; Add_Char_To_Name_Buffer (S (I)); else Add_Str_To_Name_Buffer ("""""\u"); C := Character'Pos (S (I)); Add_Char_To_Name_Buffer (Hex (C / 16 + 1)); Add_Char_To_Name_Buffer (Hex (C mod 16 + 1)); I := I + 1; C := Character'Pos (S (I)); Add_Char_To_Name_Buffer (Hex (C / 16 + 1)); Add_Char_To_Name_Buffer (Hex (C mod 16 + 1)); Add_Str_To_Name_Buffer (""""""); end if; end loop; end; Add_Char_To_Name_Buffer ('"'); -- " else Add_Char_To_Name_Buffer ('"'); -- " Get_Name_String_And_Append (V.SVal); Add_Char_To_Name_Buffer ('"'); -- " end if; when K_Enumerator => Get_Name_String (V.SVal); when others => raise Program_Error; end case; return Name_Buffer (1 .. Name_Len); end Image; --------------- -- Image_Ada -- --------------- function Image_Ada (Value : Value_Id) return String is V : Value_Type; begin if Value = No_Value then return "<>"; end if; V := VT.Table (Value); Name_Len := 0; case V.K is when K_Boolean => if V.IVal = 1 then return "True"; else return "False"; end if; when K_Short .. K_Unsigned_Long_Long | K_Octet => if V.Sign < 0 then Add_Char_To_Name_Buffer ('-'); elsif V.Base = 16 then Add_Str_To_Name_Buffer ("16#"); elsif V.Base = 8 then Add_Str_To_Name_Buffer ("8#"); end if; Add_ULL_To_Name_Buffer (V.IVal, ULL (V.Base)); if V.Base = 16 or else V.Base = 8 then Add_Char_To_Name_Buffer ('#'); end if; when K_Fixed_Point_Type => if V.Sign < 0 then Add_Char_To_Name_Buffer ('-'); end if; Add_ULL_To_Name_Buffer (V.IVal / 10 ** Natural (V.Scale), 10); if V.Scale > 0 then Add_Char_To_Name_Buffer ('.'); Add_ULL_To_Name_Buffer (V.IVal mod 10 ** Natural (V.Scale), 10); end if; when K_Float .. K_Long_Double => Add_Str_To_Name_Buffer (Long_Double'Image (V.FVal)); if Name_Buffer (Name_Buffer'First) = ' ' then Set_Str_To_Name_Buffer (Name_Buffer (Name_Buffer'First .. Name_Len)); end if; declare Index : Natural := Name_Len; begin -- Find exponent if any while Index > 0 and then Name_Buffer (Index) /= 'E' loop Index := Index - 1; end loop; -- Remove leading zero in exponent part. if Index > 0 then Index := Index + 2; while Index <= Name_Len and then Name_Buffer (Index) = '0' loop Name_Buffer (Index .. Name_Len - 1) := Name_Buffer (Index + 1 .. Name_Len); Name_Len := Name_Len - 1; end loop; -- Remove exponent if Index > Name_Len then Name_Len := Name_Len - 2; Index := Name_Len; else Index := Name_Len; while Name_Buffer (Index) /= 'E' loop Index := Index - 1; end loop; Index := Index - 1; end if; end if; -- Remove trailing zero in fraction part. while Name_Buffer (Index) = '0' loop exit when Name_Buffer (Index - 1) = '.'; Name_Buffer (Index .. Name_Len - 1) := Name_Buffer (Index + 1 .. Name_Len); Name_Len := Name_Len - 1; Index := Index - 1; end loop; end; when K_Char | K_Wide_Char => if V.CVal <= 127 then declare C : constant Character := Character'Val (Natural (V.CVal)); begin if C in '!' .. '~' then Add_Char_To_Name_Buffer ('''); Add_Char_To_Name_Buffer (C); Add_Char_To_Name_Buffer ('''); else if V.K = K_Wide_Char then Add_Str_To_Name_Buffer ("Wide_"); end if; Add_Str_To_Name_Buffer ("Character'Val ("); Add_ULL_To_Name_Buffer (ULL (V.CVal), 10); Add_Char_To_Name_Buffer (')'); end if; end; else Add_Str_To_Name_Buffer ("Wide_Character'Val ("); Add_ULL_To_Name_Buffer (ULL (V.CVal), 10); Add_Char_To_Name_Buffer (')'); end if; when K_String | K_Wide_String | K_String_Type | K_Wide_String_Type => if V.SVal = No_Name then return '"' & '"'; end if; Add_Char_To_Name_Buffer ('"'); -- " Get_Name_String_And_Append (V.SVal); Add_Char_To_Name_Buffer ('"'); -- " when K_Enumerator => Get_Name_String (V.SVal); when others => raise Program_Error; end case; return Name_Buffer (1 .. Name_Len); end Image_Ada; -------------- -- Negative -- -------------- function Negative (V : Value_Type) return Boolean is begin case V.K is when K_Short .. K_Unsigned_Long_Long | K_Octet | K_Fixed_Point_Type => return V.Sign < 0; when K_Float .. K_Long_Double => return V.FVal < 0.0; when others => raise Program_Error; end case; end Negative; -------------- -- Negative -- -------------- function Negative (V : Value_Id) return Boolean is begin if V = No_Value then raise Program_Error; end if; return Negative (Value (V)); end Negative; ----------------------- -- New_Boolean_Value -- ----------------------- function New_Boolean_Value (Value : Boolean) return Value_Id is begin return New_Value (Value_Type'(K_Boolean, Boolean'Pos (Value), 1, 10)); end New_Boolean_Value; ------------------------- -- New_Character_Value -- ------------------------- function New_Character_Value (Value : Unsigned_Short; Wide : Boolean) return Value_Id is begin if Wide then return New_Value (Value_Type'(K_Wide_Char, Value)); else return New_Value (Value_Type'(K_Char, Value)); end if; end New_Character_Value; -------------------- -- New_Enumerator -- -------------------- function New_Enumerator (Img : Name_Id; Pos : Unsigned_Long_Long) return Value_Id is begin return New_Value (Value_Type'(K_Enumerator, Img, Pos)); end New_Enumerator; --------------------------- -- New_Fixed_Point_Value -- --------------------------- function New_Fixed_Point_Value (Value : Unsigned_Long_Long; Sign : Short_Short; Total : Unsigned_Short_Short; Scale : Unsigned_Short_Short) return Value_Id is V : Value_Id; begin V := New_Value (Value_Type'(K_Fixed_Point_Type, Value, Sign, Total, Scale)); Normalize_Fixed_Point_Value (V, Total, Scale); return V; end New_Fixed_Point_Value; ------------------------------ -- New_Floating_Point_Value -- ------------------------------ function New_Floating_Point_Value (Value : Long_Double) return Value_Id is begin return New_Value (Value_Type'(K_Long_Double, Value)); end New_Floating_Point_Value; ----------------------- -- New_Integer_Value -- ----------------------- function New_Integer_Value (Value : Unsigned_Long_Long; Sign : Short_Short; Base : Unsigned_Short_Short) return Value_Id is begin return New_Value (Value_Type'(K_Unsigned_Long_Long, Value, Sign, Base)); end New_Integer_Value; ---------------------- -- New_String_Value -- ---------------------- function New_String_Value (Value : Name_Id; Wide : Boolean) return Value_Id is begin if Wide then return New_Value (Value_Type'(K_Wide_String, Value)); else return New_Value (Value_Type'(K_String, Value)); end if; end New_String_Value; --------------- -- New_Value -- --------------- function New_Value (Value : Value_Type) return Value_Id is V : Value_Id; begin VT.Increment_Last; V := VT.Last; VT.Table (V) := Value; return V; end New_Value; --------------------------------- -- Normalize_Fixed_Point_Value -- --------------------------------- procedure Normalize_Fixed_Point_Value (Value : in out Value_Id; Total : Unsigned_Short_Short := Max_Digits; Scale : Unsigned_Short_Short := Max_Digits) is V : Value_Type := Values.Value (Value); begin Normalize_Fixed_Point_Value (V, Total, Scale); if V = Bad_Value then Value := No_Value; else Set_Value (Value, V); end if; end Normalize_Fixed_Point_Value; --------------------------------- -- Normalize_Fixed_Point_Value -- --------------------------------- procedure Normalize_Fixed_Point_Value (Value : in out Value_Type; Total : Unsigned_Short_Short := Max_Digits; Scale : Unsigned_Short_Short := Max_Digits) is Quotient : Unsigned_Long_Long; begin -- Reduce the precision when it exceeds what is required while Value.Scale > Scale loop Value.IVal := Value.IVal / 10; Value.Scale := Value.Scale - 1; Value.Total := Value.Total - 1; end loop; -- Remove any trailing zero while Value.Scale > 0 and then Value.IVal mod 10 = 0 loop Value.IVal := Value.IVal / 10; Value.Scale := Value.Scale - 1; Value.Total := Value.Total - 1; end loop; -- Remove any leading zero and recompute total digits Quotient := Value.IVal / 10; Value.Total := 1; while Quotient /= 0 loop Quotient := Quotient / 10; Value.Total := Value.Total + 1; end loop; -- Value overflows maximum value supported by fixed point type if Value.Total > Total then Value := Bad_Value; end if; end Normalize_Fixed_Point_Value; --------------- -- Set_Value -- --------------- procedure Set_Value (V : Value_Id; X : Value_Type) is begin VT.Table (V) := X; end Set_Value; ---------------- -- Shift_Left -- ---------------- function Shift_Left (L, R : Value_Type) return Value_Type is LV : Value_Type := L; RV : Value_Type := R; begin case RV.K is when K_Short .. K_Unsigned_Long_Long | K_Octet => if RV.Sign < 0 then RV.Sign := 1; return Shift_Right (LV, RV); end if; -- Keep working with left operand base LV.IVal := Shift_Left (LV.IVal, Natural (RV.IVal)); return LV; when others => return Bad_Value; end case; end Shift_Left; ----------------- -- Shift_Right -- ----------------- function Shift_Right (L, R : Value_Type) return Value_Type is LV : Value_Type := L; RV : Value_Type := R; begin case RV.K is when K_Short .. K_Unsigned_Long_Long | K_Octet => if RV.Sign < 0 then RV.Sign := 1; return Shift_Left (LV, RV); end if; -- Keep working with left operand base LV.IVal := Shift_Right (LV.IVal, Natural (RV.IVal)); return LV; when others => return Bad_Value; end case; end Shift_Right; ----------- -- Value -- ----------- function Value (V : Value_Id) return Value_Type is begin return VT.Table (V); end Value; end Values; polyorb-2.8~20110207.orig/compilers/iac/usage.adb0000644000175000017500000000714211750740337020721 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- U S A G E -- -- -- -- B o d y -- -- -- -- Copyright (C) 2005-2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with Ada.Command_Line; use Ada.Command_Line; with Backend; use Backend; with Output; use Output; with Platform; procedure Usage is begin -- Note: The following text needs to be kept in sync with the documentation -- in polyorb_ug.texi. Set_Standard_Error; Write_Line ("IAC from PolyORB " & Platform.Version); Write_Str ("Usage: "); Write_Str (Command_Name); Write_Line (" [options] file [-cppargs args...]"); Write_Eol; Write_Line (" -h Print this help message, and do nothing else"); Write_Eol; Write_Line (" file is the name of the .idl file (.idl suffix optional)"); Write_Eol; Write_Line (" -E Preprocess only"); Write_Line (" -k Keep temporary files"); Write_Line (" -o DIR Output directory (DIR must exist)"); Write_Line (" -p Produce source on standard output"); Write_Line (" -q Quiet mode"); Write_Eol; Write_Line (" -dm Generate debug messages when analyzing scopes"); Write_Eol; Write_Line (" -df Dump the frontend tree (the IDL tree)"); Write_Eol; Write_Line (" -cppargs Pass arguments to the C++ preprocessor"); Write_Line (" -I Shortcut -cppargs -I directory. Use this flag"); Write_Line (" for the imported entities"); Write_Line (" -nocpp Do not preprocess input"); Write_Eol; Write_Line (" -gnatW8 Use UTF-8 character encoding in Ada output."); Write_Line (" (Default is Latin-1.)"); Write_Eol; Write_Line (" - Generate code for one of the following languages:"); Write_Eol; Write_Languages (4, 12); end Usage; polyorb-2.8~20110207.orig/compilers/iac/backend-be_corba_ada-ir_infos.ads0000644000175000017500000000440411750740337025370 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- B A C K E N D . B E _ C O R B A _ A D A . I R _ I N F O S -- -- -- -- S p e c -- -- -- -- Copyright (C) 2007, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ package Backend.BE_CORBA_Ada.IR_Infos is package Package_Spec is procedure Visit (E : Node_Id); end Package_Spec; package Package_Body is procedure Visit (E : Node_Id); end Package_Body; end Backend.BE_CORBA_Ada.IR_Infos; polyorb-2.8~20110207.orig/compilers/iac/backend-be_corba_ada-cdrs.adb0000644000175000017500000030230011750740337024466 0ustar xavierxavier------------------------------------------------------------------------------ -- -- -- POLYORB COMPONENTS -- -- -- -- B A C K E N D . B E _ C O R B A _ A D A . C D R S -- -- -- -- B o d y -- -- -- -- Copyright (C) 2005-2010, Free Software Foundation, Inc. -- -- -- -- PolyORB is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. PolyORB is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with PolyORB; see file COPYING. If -- -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- -- -- PolyORB is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with Namet; use Namet; with Values; use Values; with Frontend.Nodes; use Frontend.Nodes; with Frontend.Nutils; with Backend.BE_CORBA_Ada.Nodes; use Backend.BE_CORBA_Ada.Nodes; with Backend.BE_CORBA_Ada.Nutils; use Backend.BE_CORBA_Ada.Nutils; with Backend.BE_CORBA_Ada.IDL_To_Ada; use Backend.BE_CORBA_Ada.IDL_To_Ada; with Backend.BE_CORBA_Ada.Runtime; use Backend.BE_CORBA_Ada.Runtime; with Backend.BE_CORBA_Ada.Common; use Backend.BE_CORBA_Ada.Common; package body Backend.BE_CORBA_Ada.CDRs is package FEN renames Frontend.Nodes; package FEU renames Frontend.Nutils; package BEN renames Backend.BE_CORBA_Ada.Nodes; package BEU renames Backend.BE_CORBA_Ada.Nutils; package BEA renames Backend.BE_CORBA_Ada; package body Package_Spec is function Args_Type_Record (E : Node_Id) return Node_Id; -- Builds a record type declaration. The members of the record -- type are the operation arguments and result. function Marshaller_Spec (E : Node_Id) return Node_Id; -- Builds the spec of the static marshaller subprogram function Unmarshaller_Spec (E : Node_Id) return Node_Id; -- Builds the spec of the static unmarshaller subprogram procedure Visit_Attribute_Declaration (E : Node_Id); procedure Visit_Interface_Declaration (E : Node_Id); procedure Visit_Module (E : Node_Id); procedure Visit_Operation_Declaration (E : Node_Id); procedure Visit_Specification (E : Node_Id); ---------------------- -- Args_Type_Record -- ---------------------- function Args_Type_Record (E : Node_Id) return Node_Id is pragma Assert (FEN.Kind (E) = K_Operation_Declaration); Spec : constant Node_Id := Stub_Node (BE_Node (Identifier (E))); P : constant List_Id := Parameter_Profile (Spec); T : constant Node_Id := Return_Type (Spec); Components : List_Id; Component : Node_Id; Parameter : Node_Id; Args_Type : Node_Id := No_Node; Par_Type : Node_Id; begin Components := New_List; -- For each parameter in the subprogram profile, a member -- with the same name and the same type is generated in the -- record if not BEU.Is_Empty (P) then -- Skip the first parameter corresponding to 'Self' Parameter := Next_Node (First_Node (P)); while Present (Parameter) loop -- If the parameter type is a class-wide type, we -- remove the "'Class" attribute from the type name. Par_Type := Parameter_Type (Parameter); if BEN.Kind (Par_Type) = K_Attribute_Reference then Par_Type := Prefix (Par_Type); end if; Component := Make_Component_Declaration (Defining_Identifier => Defining_Identifier (Parameter), Subtype_Indication => Par_Type); Append_To (Components, Component); Parameter := Next_Node (Parameter); end loop; end if; -- If the subprogram is a function, we add an additional -- member corresponding to the result of the function. if Present (T) then -- If the return type is a class-wide type, we remove the -- "'Class" attribute from the type name Par_Type := T; if BEN.Kind (Par_Type) = K_Attribute_Reference then Par_Type := Prefix (Par_Type); end if; Component := Make_Component_Declaration (Defining_Identifier => Make_Defining_Identifier (PN (P_Returns)), Subtype_Indication => Par_Type); Append_To (Components, Component); end if; -- Type Declaration Args_Type := Make_Full_Type_Declaration (Defining_Identifier => Map_Args_Type_Identifier (Defining_Identifier (Spec)), Type_Definition => Make_Record_Definition (Components)); return Args_Type; end Args_Type_Record; --------------------- -- Marshaller_Spec -- --------------------- function Marshaller_Spec (E : Node_Id) return Node_Id is pragma Assert (FEN.Kind (E) = K_Operation_Declaration); Spec : constant Node_Id := Stub_Node (BE_Node (Identifier (E))); Profile : List_Id; Parameter : Node_Id; S : Node_Id; begin Profile := New_List; -- 'Role' parameter Parameter := Make_Parameter_Specification (Defining_Identifier => Make_Defining_Identifier (PN (P_Role)), Subtype_Mark => RE (RE_Boolean_0), Parameter_Mode => Mode_In); Append_To (Profile, Parameter); -- 'Args' parameter Parameter := Make_Parameter_Specification (Defining_Identifier => Make_Defining_Identifier (PN (P_Args)), Subtype_Mark => Make_Access_Type_Definition (Expand_Designator (Type_Def_Node (BE_Node (Identifier (E))))), Parameter_Mode => Mode_In); Append_To (Profile, Parameter); -- 'Buffer' parameter Parameter := Make_Parameter_Specification (Defining_Identifier => Make_Defining_Identifier (PN (P_Buffer)), Subtype_Mark => RE (RE_Buffer_Access), Parameter_Mode => Mode_In); Append_To (Profile, Parameter); -- 'Representation' parameter Parameter := Make_Parameter_Specification (Defining_Identifier => Make_Defining_Identifier (PN (P_Representation)), Subtype_Mark => Make_Attribute_Reference (RE (RE_CDR_Representation), A_Class), Parameter_Mode => Mode_In); Append_To (Profile, Parameter); -- 'First_Arg_Alignment' parameter Parameter := Make_Parameter_Specification (Defining_Identifier => Make_Defining_Identifier (PN (P_First_Arg_Alignment)), Subtype_Mark => RE (RE_Alignment_Type), Parameter_Mode => Mode_In); Append_To (Profile, Parameter); -- 'Error' parameter Parameter := Make_Parameter_Specification (Defining_Identifier => Make_Defining_Identifier (PN (P_Error)), Subtype_Mark => RE (RE_Error_Container), Parameter_Mode => Mode_Inout); Append_To (Profile, Parameter); -- Subprogram Specification S := Make_Subprogram_Specification (Map_Marshaller_Identifier (Defining_Identifier (Spec)), Profile, No_Node); return S; end Marshaller_Spec; ----------------------- -- Unmarshaller_Spec -- ----------------------- function Unmarshaller_Spec (E : Node_Id) return Node_Id is pragma Assert (FEN.Kind (E) = K_Operation_Declaration); Spec : constant Node_Id := Stub_Node (BE_Node (Identifier (E))); Profile : List_Id; Parameter : Node_Id; S : Node_Id; begin Profile := New_List; -- 'Role' parameter Parameter := Make_Parameter_Specification (Defining_Identifier => Make_Defining_Identifier (PN (P_Role)), Subtype_Mark => RE (RE_Boolean_0), Parameter_Mode => Mode_In); Append_To (Profile, Parameter); -- 'Args' parameter Parameter := Make_Parameter_Specification (Defining_Identifier => Make_Defining_Identifier (PN (P_Args)), Subtype_Mark => Make_Access_Type_Definition (Expand_Designator (Type_Def_Node (BE_Node (Identifier (E))))), Parameter_Mode => Mode_In); Append_To (Profile, Parameter); -- 'Buffer' parameter Parameter := Make_Parameter_Specification (Defining_Identifier => Make_Defining_Identifier (PN (P_Buffer)), Subtype_Mark => RE (RE_Buffer_Access), Parameter_Mode => Mode_In); Append_To (Profile, Parameter); -- 'Representation' parameter Parameter := Make_Parameter_Specification (Defining_Identifier => Make_Defining_Identifier (PN (P_Representation)), Subtype_Mark => Make_Attribute_Reference (RE (RE_CDR_Representation), A_Class), Parameter_Mode => Mode_In); Append_To (Profile, Parameter); -- 'First_Arg_Alignment' parameter Parameter := Make_Parameter_Specification (Defining_Identifier => Make_Defining_Identifier (PN (P_First_Arg_Alignment)), Subtype_Mark => RE (RE_Alignment_Type), Parameter_Mode => Mode_In); Append_To (Profile, Parameter); -- 'Error' parameter Parameter := Make_Parameter_Specification (Defining_Identifier => Make_Defining_Identifier (PN (P_Error)), Subtype_Mark => RE (RE_Error_Container), Parameter_Mode => Mode_Inout); Append_To (Profile, Parameter); -- Subprogram Specification S := Make_Subprogram_Specification (Map_Unmarshaller_Identifier (Defining_Identifier (Spec)), Profile, No_Node); return S; end Unmarshaller_Spec; ----------- -- Visit -- ----------- procedure Visit (E : Node_Id) is begin case FEN.Kind (E) is when K_Attribute_Declaration => Visit_Attribute_Declaration (E); when K_Interface_Declaration => Visit_Interface_Declaration (E); when K_Module => Visit_Module (E); when K_Operation_Declaration => Visit_Operation_Declaration (E); when K_Specification => Visit_Specification (E); when others => null; end case; end Visit; --------------------------------- -- Visit_Attribute_Declaration -- --------------------------------- procedure Visit_Attribute_Declaration (E : Node_Id) is N : Node_Id; D : Node_Id; begin Set_CDR_Spec; D := First_Entity (Declarators (E)); while Present (D) loop -- Explaining comment Set_Str_To_Name_Buffer ("Attribute : "); Get_Name_String_And_Append (IDL_Name (Identifier (D))); N := Make_Ada_Comment (Name_Find); Append_To (Visible_Part (Current_Package), N); D := Next_Entity (D); end loop; end Visit_Attribute_Declaration; --------------------------------- -- Visit_Interface_Declaration -- --------------------------------- procedure Visit_Interface_Declaration (E : Node_Id) is N : Node_Id; begin -- No CDR package is generated for a local interface if FEN.Is_Local_Interface (E) then return; end if; N := BEN.Parent (Type_Def_Node (BE_Node (Identifier (E)))); Push_Entity (BEN.IDL_Unit (Package_Declaration (N))); Set_CDR_Spec; N := First_Entity (Interface_Body (E)); while Present (N) loop Visit (N); N := Next_Entity (N); end loop; Pop_Entity; end Visit_Interface_Declaration; ------------------ -- Visit_Module -- ------------------ procedure Visit_Module (E : Node_Id) is D : Node_Id; begin if not Map_Particular_CORBA_Parts (E, PK_CDR_Spec) then Push_Entity (Stub_Node (BE_Node (Identifier (E)))); D := First_Entity (Definitions (E)); while Present (D) loop Visit (D); D := Next_Entity (D); end loop; Pop_Entity; end if; end Visit_Module; --------------------------------- -- Visit_Operation_Declaration -- --------------------------------- procedure Visit_Operation_Declaration (E : Node_Id) is N : Node_Id; begin Set_CDR_Spec; -- Explaining comment Set_Str_To_Name_Buffer ("Operation : "); Get_Name_String_And_Append (IDL_Name (Identifier (E))); N := Make_Ada_Comment (Name_Find); Append_To (Visible_Part (Current_Package), N); -- Generating the 'Operation_Name'_Args_Type declaration N := Args_Type_Record (E); Append_To (Visible_Part (Current_Package), N); Bind_FE_To_BE (Identifier (E), N, B_Type_Def); -- Generating the 'Operation_Name'_Marshaller spec N := Marshaller_Spec (E); Append_To (Visible_Part (Current_Package), N); Bind_FE_To_BE (Identifier (E), N, B_Marshaller); -- Generating the 'Operation_Name'_Unmarshaller spec N := Unmarshaller_Spec (E); Append_To (Visible_Part (Current_Package), N); Bind_FE_To_BE (Identifier (E), N, B_Unmarshaller); end Visit_Operation_Declaration; ------------------------- -- Visit_Specification -- ------------------------- procedure Visit_Specification (E : Node_Id) is Definition : Node_Id; begin Push_Entity (Stub_Node (BE_Node (Identifier (E)))); Definition := First_Entity (Definitions (E)); while Present (Definition) loop Visit (Definition); Definition := Next_Entity (Definition); end loop; Pop_Entity; end Visit_Specification; end Package_Spec; package body Package_Body is function Marshaller_Body (E : Node_Id) return Node_Id; function Unmarshaller_Body (E : Node_Id) return Node_Id; -- The functions Get_... and the variables ..._Number return -- new variable names. They are used to avoid conflicts. function Get_Element_Name return Name_Id; function Get_Index_Name return Name_Id; function Get_Length_Name return Name_Id; function Get_Union_Name return Name_Id; Element_Number : Nat := 0; Index_Number : Nat := 0; Length_Number : Nat := 0; Union_Number : Nat := 0; function Storage_Variable_Declaration (Var_Name : Name_Id; Var_Type : Node_Id) return Node_Id; -- This function builds a variable declaration. The variable -- corresponds to an operation parameter or an operation -- result. The variable type is the PolyORB type corresponding -- to the Var_Node node function Do_Marshall (Var_Node : Node_Id; Var_Type : Node_Id; Buff : Name_Id) return Node_Id; -- This function builds the marshalling statements to the -- buffer from the variable Var_Node function Do_Unmarshall (Var_Node : Node_Id; Var_Type : Node_Id; Buff : Name_Id) return Node_Id; -- This function builds the unmarshalling statements from the -- buffer into the variable Var_Node procedure Visit_Attribute_Declaration (E : Node_Id); procedure Visit_Interface_Declaration (E : Node_Id); procedure Visit_Module (E : Node_Id); procedure Visit_Operation_Declaration (E : Node_Id); procedure Visit_Specification (E : Node_Id); --------------------- -- Marshaller_Body -- --------------------- function Marshaller_Body (E : Node_Id) return Node_Id is pragma Assert (FEN.Kind (E) = K_Operation_Declaration); Subp_Spec : Node_Id; Subp_Statements : constant List_Id := New_List; Subp_Declarations : constant List_Id := New_List; P : constant List_Id := Parameters (E); T : constant Node_Id := Type_Spec (E); Client_Case : constant List_Id := New_List (RE (RE_True)); Client_Statements : constant List_Id := New_List; Server_Case : constant List_Id := New_List (RE (RE_False)); Server_Statements : constant List_Id := New_List; Case_Alternatives : constant List_Id := New_List; Alignment_Const : Boolean := True; Args_Id : Node_Id; Parameter : Node_Id; Parameter_Name : Name_Id; Parameter_Mode : Mode_Id; Rewinded_Type : Node_Id; N : Node_Id; M : Node_Id; -- The global structure of the generated XXXX_Marshaller -- function is: -- case Role is -- when Client_Entity => -- (if any) -- when Server_Entity => -- (if any) -- (if any) -- end case; begin Subp_Spec := Marshaller_Node (BE_Node (Identifier (E))); Args_Id := Map_Args_Identifier (Defining_Identifier (Stub_Node (BE_Node (Identifier (E))))); -- If buffers pre-allocation option is enabled if BEA.Use_Optimized_Buffers_Allocation then declare Method_Buffer_Size : Node_Id; M : Node_Id; begin Method_Buffer_Size := Expand_Designator (Buffer_Size_Node (BE_Node (FE_Node (Subp_Spec)))); -- Call of the method_name_buffer_size method M := Make_Subprogram_Call (Method_Buffer_Size, New_List (Make_Defining_Identifier (PN (P_Role)), Make_Defining_Identifier (PN (P_Args)), Make_Defining_Identifier (PN (P_Buffer)), Make_Defining_Identifier (PN (P_Data_Alignment)))); if (Present (T) and then FEN.Kind (T) /= K_Void) or else Contains_Out_Parameters (E) then Append_To (Server_Statements, M); end if; M := Make_Subprogram_Call (Method_Buffer_Size, New_List (Make_Defining_Identifier (PN (P_Role)), Make_Defining_Identifier (PN (P_Args)), Make_Defining_Identifier (PN (P_Buffer)), Make_Defining_Identifier (PN (P_Data_Alignment)))); if not FEU.Is_Empty (P) and then Contains_In_Parameters (E) then Append_To (Client_Statements, M); end if; end; end if; if Present (T) and then FEN.Kind (T) /= K_Void then Rewinded_Type := FEU.Get_Original_Type_Specifier (T); -- Explaining comment Set_Str_To_Name_Buffer ("Marshalling Result : "); Get_Name_String_And_Append (PN (P_Returns)); Add_Str_To_Name_Buffer (" => "); Add_Str_To_Name_Buffer (FEN.Node_Kind'Image (FEN.Kind (Rewinded_Type))); N := Make_Ada_Comment (Name_Find); Append_To (Server_Statements, N); -- Aligning CDR position in Buffer N := Make_Subprogram_Call (RE (RE_Pad_Align), New_List (Make_Identifier (PN (P_Buffer)), Make_Identifier (PN (P_Data_Alignment)))); Append_To (Server_Statements, N); -- the operation does not have OUT or INOUT parameters, -- there is no need to this if Contains_Out_Parameters (E) then N := Make_Assignment_Statement (Make_Defining_Identifier (PN (P_Data_Alignment)), Make_Literal (Int1_Val)); Append_To (Server_Statements, N); Alignment_Const := False; end if; -- Marshalling the result and handling the error N := Make_Selected_Component (Copy_Node (Args_Id), Make_Defining_Identifier (PN (P_Returns))); N := Do_Marshall (N, T, PN (P_Buffer)); Append_To (Server_Statements, N); end if; -- Handling parameters if not FEU.Is_Empty (P) then -- Aligning CDR position in Buffer in client and server -- parts. if Contains_Out_Parameters (E) then N := Make_Subprogram_Call (RE (RE_Pad_Align), New_List (Make_Identifier (PN (P_Buffer)), Make_Identifier (PN (P_Data_Alignment)))); Append_To (Server_Statements, N); end if; if Contains_In_Parameters (E) then N := Make_Subprogram_Call (RE (RE_Pad_Align), New_List (Make_Identifier (PN (P_Buffer)), Make_Identifier (PN (P_Data_Alignment)))); Append_To (Client_Statements, N); end if; Parameter := First_Entity (P); while Present (Parameter) loop Rewinded_Type := FEU.Get_Original_Type_Specifier (Type_Spec (Parameter)); Parameter_Name := To_Ada_Name (IDL_Name (Identifier (Declarator (Parameter)))); Parameter_Mode := FEN.Parameter_Mode (Parameter); -- The IN parameters are marshalled by client -- The OUT parameters are marshalled by server -- The INOUT parameters are marshalled by client and server -- Explaining comment Set_Str_To_Name_Buffer ("Marshall Parameter : "); Get_Name_String_And_Append (Parameter_Name); Add_Str_To_Name_Buffer (" => "); Add_Str_To_Name_Buffer (FEN.Node_Kind'Image (FEN.Kind (FEU.Get_Original_Type_Specifier (Type_Spec (Parameter))))); if Is_In (Parameter_Mode) then N := Make_Ada_Comment (Name_Find); Append_To (Client_Statements, N); end if; if Is_Out (Parameter_Mode) then N := Make_Ada_Comment (Name_Find); Append_To (Server_Statements, N); end if; -- Marshalling the parameter and handling the error if Is_In (Parameter_Mode) then N := Make_Selected_Component (Copy_Node (Args_Id), Make_Defining_Identifier (Parameter_Name)); N := Do_Marshall (N, Type_Spec (Parameter), PN (P_Buffer)); Append_To (Client_Statements, N); end if; if Is_Out (Parameter_Mode) then N := Make_Selected_Component (Copy_Node (Args_Id), Make_Defining_Identifier (Parameter_Name)); N := Do_Marshall (N, Type_Spec (Parameter), PN (P_Buffer)); Append_To (Server_Statements, N); end if; Parameter := Next_Entity (Parameter); end loop; end if; -- The declarative part of the subprogram : if BEU.Is_Empty (Client_Statements) and then BEU.Is_Empty (Server_Statements) then declare Unref_Entities : constant array (Positive range <>) of Name_Id := (PN (P_Role), PN (P_Args), PN (P_Buffer), PN (P_Representation), PN (P_First_Arg_Alignment), PN (P_Error)); begin for Index in Unref_Entities'Range loop N := Make_Pragma (Pragma_Unreferenced, New_List (Make_Identifier (Unref_Entities (Index)))); Append_To (Subp_Declarations, N); end loop; end; else declare -- It's complicated to determine whether the -- parameters 'Error' and 'Representation' are or -- aren't referenced (depending) on the types -- handled. So we ignore warnings raised about these -- two parameters W_Off_Entities : constant array (Positive range <>) of Name_Id := (PN (P_Representation), PN (P_Error)); begin for Index in W_Off_Entities'Range loop N := Make_Pragma (Pragma_Warnings, New_List (RE (RE_Off), Make_Identifier (W_Off_Entities (Index)))); Append_To (Subp_Declarations, N); end loop; -- Common declarations -- 1/ Data_Alignment : This variable modified when there are -- OUT or INOUT parameters in order to avoid the alignment -- of buffer more than one time. N := Make_Object_Declaration (Defining_Identifier => Make_Defining_Identifier (PN (P_Data_Alignment)), Object_Definition => RE (RE_Alignment_Type), Constant_Present => Alignment_Const, Expression => Make_Identifier (PN (P_First_Arg_Alignment))); Append_To (Subp_Declarations, N); -- 2/ This is the record that contains the operation -- parameters. N := Expand_Designator (Type_Def_Node (BE_Node (Identifier (E)))); M := Make_Explicit_Dereference (Make_Identifier (PN (P_Args))); N := Make_Object_Declaration (Defining_Identifier => Args_Id, Object_Definition => N, Constant_Present => True, Expression => M); Append_To (Subp_Declarations, N); end; end if; -- If the subprogram is a procedure without arguments, we -- add a null statement to the subprogram statements, else -- we build a switch case. if BEU.Is_Empty (Client_Statements) and then BEU.Is_Empty (Server_Statements) then Append_To (Subp_Statements, Make_Null_Statement); else -- Building the case statement if BEU.Is_Empty (Client_Statements) then Append_To (Client_Statements, Make_Null_Statement); end if; N := Make_Case_Statement_Alternative (Client_Case, Client_Statements); Append_To (Case_Alternatives, N); if BEU.Is_Empty (Server_Statements) then Append_To (Server_Statements, Make_Null_Statement); end if; N := Make_Case_Statement_Alternative (Server_Case, Server_Statements); Append_To (Case_Alternatives, N); N := Make_Case_Statement (Make_Identifier (PN (P_Role)), Case_Alternatives); Append_To (Subp_Statements, N); end if; -- Building the subprogram implementation N := Make_Subprogram_Body (Specification => Subp_Spec, Declarations => Subp_Declarations, Statements => Subp_Statements); return N; end Marshaller_Body; ----------------------- -- Unmarshaller_Body -- ----------------------- function Unmarshaller_Body (E : Node_Id) return Node_Id is pragma Assert (FEN.Kind (E) = K_Operation_Declaration); Subp_Spec : Node_Id; Subp_Statements : constant List_Id := New_List; Subp_Declarations : constant List_Id := New_List; P : constant List_Id := Parameters (E); T : constant Node_Id := Type_Spec (E); Client_Case : constant List_Id := New_List (RE (RE_True)); Client_Statements : constant List_Id := New_List; Server_Case : constant List_Id := New_List (RE (RE_False)); Server_Statements : constant List_Id := New_List; Case_Alternatives : constant List_Id := New_List; Alignment_Const : Boolean := True; Args_Id : Node_Id; Parameter : Node_Id; Parameter_Name : Name_Id; Parameter_Mode : Mode_Id; Rewinded_Type : Node_Id; N : Node_Id; M : Node_Id; -- The global structure of the generated XXXX_Unmarshaller -- function is: -- case Role is -- when Client_Entity => -- (if any) -- (if any) -- when Server_Entity => -- (if any) -- end case; begin Subp_Spec := Unmarshaller_Node (BE_Node (Identifier (E))); Args_Id := Map_Args_Identifier (Defining_Identifier (Stub_Node (BE_Node (Identifier (E))))); -- We reset the variable index used to avoid name conflicts -- between arrays. Element_Number := 0; Index_Number := 0; Union_Number := 0; -- The declarative part generation of the subprogram is -- postponed after the handling of the arguments and the -- result because it depends on the result of this handling. -- If the subprogram is a function, we handle the result if Present (T) and then FEN.Kind (T) /= K_Void then Rewinded_Type := FEU.Get_Original_Type_Specifier (T); -- Explaining comment Set_Str_To_Name_Buffer ("Unmarshalling Result : "); Get_Name_String_And_Append (PN (P_Returns)); Add_Str_To_Name_Buffer (" => "); Add_Str_To_Name_Buffer (FEN.Node_Kind'Image (FEN.Kind (Rewinded_Type))); N := Make_Ada_Comment (Name_Find); Append_To (Client_Statements, N); -- Aligning CDR position in Buffer N := Make_Subprogram_Call (RE (RE_Align_Position), New_List (Make_Identifier (PN (P_Buffer)), Make_Identifier (PN (P_Data_Alignment)))); Append_To (Client_Statements, N); -- the operation does not have out or INOUT parameters, -- there is no need to this if Contains_Out_Parameters (E) then N := Make_Assignment_Statement (Make_Defining_Identifier (PN (P_Data_Alignment)), Make_Literal (Int1_Val)); Append_To (Client_Statements, N); Alignment_Const := False; end if; -- Declaring the storage variable N := Storage_Variable_Declaration (PN (P_Returns), T); Append_To (Subp_Declarations, N); -- Unmarshalling the result and handling the error N := Do_Unmarshall (Make_Identifier (PN (P_Returns)), T, PN (P_Buffer)); Append_To (Client_Statements, N); -- Updating the record field N := Make_Selected_Component (Copy_Node (Args_Id), Make_Defining_Identifier (PN (P_Returns))); N := Make_Assignment_Statement (N, Cast_Variable_From_PolyORB_Type (PN (P_Returns), T)); Append_To (Client_Statements, N); end if; -- Handling parameters if not FEU.Is_Empty (P) then -- Aligning CDR position in Buffer in client and server parts if Contains_Out_Parameters (E) then N := Make_Subprogram_Call (RE (RE_Align_Position), New_List (Make_Identifier (PN (P_Buffer)), Make_Identifier (PN (P_Data_Alignment)))); Append_To (Client_Statements, N); end if; if Contains_In_Parameters (E) then N := Make_Subprogram_Call (RE (RE_Align_Position), New_List (Make_Identifier (PN (P_Buffer)), Make_Identifier (PN (P_Data_Alignment)))); Append_To (Server_Statements, N); end if; Parameter := First_Entity (P); while Present (Parameter) loop Rewinded_Type := FEU.Get_Original_Type_Specifier (Type_Spec (Parameter)); Parameter_Name := To_Ada_Name (IDL_Name (Identifier (Declarator (Parameter)))); Parameter_Mode := FEN.Parameter_Mode (Parameter); -- The IN parameters are unmarshalled by server -- The OUT parameters are unmarshalled by client -- The INOUT parameters are unmarshalled by client and server -- Explaining comment Set_Str_To_Name_Buffer ("Unmarshall Parameter : "); Get_Name_String_And_Append (Parameter_Name); Add_Str_To_Name_Buffer (" => "); Add_Str_To_Name_Buffer (FEN.Node_Kind'Image (FEN.Kind (FEU.Get_Original_Type_Specifier (Type_Spec (Parameter))))); if Is_In (Parameter_Mode) then N := Make_Ada_Comment (Name_Find); Append_To (Server_Statements, N); end if; if Is_Out (Parameter_Mode) then N := Make_Ada_Comment (Name_Find); Append_To (Client_Statements, N); end if; -- Declaring the storage variable N := Storage_Variable_Declaration (Parameter_Name, Type_Spec (Parameter)); Append_To (Subp_Declarations, N); -- Unmarshalling the parameter and handling the error if Is_In (Parameter_Mode) then N := Do_Unmarshall (Make_Identifier (Parameter_Name), Type_Spec (Parameter), PN (P_Buffer)); Append_To (Server_Statements, N); end if; if Is_Out (Parameter_Mode) then N := Do_Unmarshall (Make_Identifier (Parameter_Name), Type_Spec (Parameter), PN (P_Buffer)); Append_To (Client_Statements, N); end if; -- Updating the record field if Is_In (Parameter_Mode) then N := Make_Selected_Component (Copy_Node (Args_Id), Make_Defining_Identifier (Parameter_Name)); N := Make_Assignment_Statement (N, Cast_Variable_From_PolyORB_Type (Parameter_Name, Type_Spec (Parameter))); Append_To (Server_Statements, N); end if; if Is_Out (Parameter_Mode) then N := Make_Selected_Component (Copy_Node (Args_Id), Make_Defining_Identifier (Parameter_Name)); N := Make_Assignment_Statement (N, Cast_Variable_From_PolyORB_Type (Parameter_Name, Type_Spec (Parameter))); Append_To (Client_Statements, N); end if; Parameter := Next_Entity (Parameter); end loop; end if; -- The declarative part of the subprogram : if BEU.Is_Empty (Client_Statements) and then BEU.Is_Empty (Server_Statements) then declare Unref_Entities : constant array (Positive range <>) of Name_Id := (PN (P_Role), PN (P_Args), PN (P_Buffer), PN (P_Representation), PN (P_First_Arg_Alignment)); begin for Index in Unref_Entities'Range loop N := Make_Pragma (Pragma_Unreferenced, New_List (Make_Identifier (Unref_Entities (Index)))); Append_To (Subp_Declarations, N); end loop; end; else declare -- It's complicated to determine whether the -- parameters 'Error' and 'Representation' are or -- aren't referenced (depending) on the types -- handled. So we ignore warnings raised about these -- two parameters W_Off_Entities : constant array (Positive range <>) of Name_Id := (PN (P_Representation), PN (P_Error)); begin for Index in W_Off_Entities'Range loop N := Make_Pragma (Pragma_Warnings, New_List (RE (RE_Off), Make_Identifier (W_Off_Entities (Index)))); Append_To (Subp_Declarations, N); end loop; -- Common declarations -- 1/ Data_Alignment : This variable modified when -- there are OUT or INOUT parameters in order to avoid -- the alignment of buffer more than one time. N := Make_Object_Declaration (Defining_Identifier => Make_Defining_Identifier (PN (P_Data_Alignment)), Object_Definition => RE (RE_Alignment_Type), Constant_Present => Alignment_Const, Expression => Make_Identifier (PN (P_First_Arg_Alignment))); Append_To (Subp_Declarations, N); -- 2/ This is the record that contains the operation -- parameters. N := Expand_Designator (Type_Def_Node (BE_Node (Identifier (E)))); M := Make_Explicit_Dereference (Make_Identifier (PN (P_Args))); N := Make_Object_Declaration (Defining_Identifier => Args_Id, Object_Definition => N, Expression => Make_Subprogram_Call (N, New_List (M))); Append_To (Subp_Declarations, N); end; end if; -- If the subprogram is a procedure without arguments, we -- add a null statement to the subprogram statements, else -- we build a switch case. if BEU.Is_Empty (Client_Statements) and then BEU.Is_Empty (Server_Statements) then Append_To (Subp_Statements, Make_Null_Statement); else -- Building the case statement if BEU.Is_Empty (Client_Statements) then Append_To (Client_Statements, Make_Null_Statement); end if; N := Make_Case_Statement_Alternative (Client_Case, Client_Statements); Append_To (Case_Alternatives, N); if BEU.Is_Empty (Server_Statements) then Append_To (Server_Statements, Make_Null_Statement); end if; N := Make_Case_Statement_Alternative (Server_Case, Server_Statements); Append_To (Case_Alternatives, N); N := Make_Case_Statement (Make_Identifier (PN (P_Role)), Case_Alternatives); Append_To (Subp_Statements, N); -- Updating the argument list when needed Set_Str_To_Name_Buffer ("Update the argument list"); N := Make_Ada_Comment (Name_Find); Append_To (Subp_Statements, N); M := Make_Explicit_Dereference (Make_Identifier (PN (P_Args))); N := Make_Assignment_Statement (M, Copy_Node (Args_Id)); Append_To (Subp_Statements, N); end if; -- Add an exception handler to the unmarshalling functions -- in case something wrong happens, e.g. a Constraint_Error -- exception is raised. declare Result : Node_Id; M : Node_Id; S : constant List_Id := New_List; Excep_St : List_Id := New_List; Profile : constant List_Id := New_List; begin -- Body of the exception handler -- Set the exception informations M := Make_Identifier (PN (P_Error)); Append_To (Profile, M); M := RE (RE_Marshal_E); Append_To (Profile, M); M := Make_Qualified_Expression (RE (RE_System_Exception_Members), Make_Record_Aggregate (New_List (Make_Component_Association (Make_Identifier (CN (C_Minor)), Make_Literal (Values.New_Integer_Value (4, 1, 10))), Make_Component_Association (Make_Identifier (CN (C_Completed)), RE (RE_Completed_No))))); Append_To (Profile, M); M := Make_Subprogram_Call (RE (RE_Throw), Profile); Append_To (S, M); Result := Make_Case_Statement_Alternative (No_List, S); Excep_St := New_List (Result); N := Make_Block_Statement (Declarative_Part => No_List, Statements => Subp_Statements, Exception_Handler => Excep_St); end; -- Building the subprogram implementation N := Make_Subprogram_Body (Specification => Subp_Spec, Declarations => Subp_Declarations, Statements => New_List (N)); return N; end Unmarshaller_Body; ---------------------------------- -- Storage_Variable_Declaration -- ---------------------------------- function Storage_Variable_Declaration (Var_Name : Name_Id; Var_Type : Node_Id) return Node_Id is N : Node_Id; Orig_Type : Node_Id; begin Orig_Type := FEU.Get_Original_Type_Specifier (Var_Type); case FEN.Kind (Orig_Type) is when K_Long => N := Make_Object_Declaration (Defining_Identifier => Make_Defining_Identifier (Var_Name), Object_Definition => RE (RE_Long_1)); when K_Unsigned_Long | K_Enumeration_Type => N := Make_Object_Declaration (Defining_Identifier => Make_Defining_Identifier (Var_Name), Object_Definition => RE (RE_Unsigned_Long_1)); when K_Long_Long => N := Make_Object_Declaration (Defining_Identifier => Make_Defining_Identifier (Var_Name), Object_Definition => RE (RE_Long_Long_1)); when K_Unsigned_Long_Long => N := Make_Object_Declaration (Defining_Identifier => Make_Defining_Identifier (Var_Name), Object_Definition => RE (RE_Unsigned_Long_Long_1)); when K_Short => N := Make_Object_Declaration (Defining_Identifier => Make_Defining_Identifier (Var_Name), Object_Definition => RE (RE_Short_1)); when K_Unsigned_Short => N := Make_Object_Declaration (Defining_Identifier => Make_Defining_Identifier (Var_Name), Object_Definition => RE (RE_Unsigned_Short_1)); when K_Float => N := Make_Object_Declaration (Defining_Identifier => Make_Defining_Identifier (Var_Name), Object_Definition => RE (RE_Float_1)); when K_Double => N := Make_Object_Declaration (Defining_Identifier => Make_Defining_Identifier (Var_Name), Object_Definition => RE (RE_Double_1)); when K_Long_Double => N := Make_Object_Declaration (Defining_Identifier => Make_Defining_Identifier (Var_Name), Object_Definition => RE (RE_Long_Double_1)); when K_Char => N := Make_Object_Declaration (Defining_Identifier => Make_Defining_Identifier (Var_Name), Object_Definition => RE (RE_Char_1)); when K_Wide_Char => N := Make_Object_Declaration (Defining_Identifier => Make_Defining_Identifier (Var_Name), Object_Definition => RE (RE_Wchar_1)); when K_String | K_String_Type => N := Make_Object_Declaration (Defining_Identifier => Make_Defining_Identifier (Var_Name), Object_Definition => RE (RE_String_1)); when K_Wide_String | K_Wide_String_Type => N := Make_Object_Declaration (Defining_Identifier => Make_Defining_Identifier (Var_Name), Object_Definition => RE (RE_Wide_String_1)); when K_Octet => N := Make_Object_Declaration (Defining_Identifier => Make_Defining_Identifier (Var_Name), Object_Definition => RE (RE_Octet_1)); when K_Boolean => N := Make_Object_Declaration (Defining_Identifier => Make_Defining_Identifier (Var_Name), Object_Definition => RE (RE_Boolean_1)); when K_Object => N := Make_Object_Declaration (Defining_Identifier => Make_Defining_Identifier (Var_Name), Object_Definition => RE (RE_Ref_9)); when K_Interface_Declaration | K_Forward_Interface_Declaration => -- Check whether we are dealing with a TypeCode if Get_Predefined_CORBA_Entity (Orig_Type) = RE_Object then N := Make_Object_Declaration (Defining_Identifier => Make_Defining_Identifier (Var_Name), Object_Definition => RE (RE_Local_Ref_1)); else N := Make_Object_Declaration (Defining_Identifier => Make_Defining_Identifier (Var_Name), Object_Definition => RE (RE_Ref_9)); end if; when K_Fixed_Point_Type => declare FP_Type_Node : Node_Id; begin -- Getting the fixed point type FP_Type_Node := Expand_Designator (Type_Def_Node (BE_Node (Orig_Type))); N := Make_Object_Declaration (Defining_Identifier => Make_Defining_Identifier (Var_Name), Object_Definition => FP_Type_Node); end; when K_Complex_Declarator | K_Structure_Type | K_Union_Type => declare Direct_Type : constant Node_Id := Expand_Designator (Type_Def_Node (BE_Node (Identifier (Orig_Type)))); begin N := Make_Object_Declaration (Defining_Identifier => Make_Defining_Identifier (Var_Name), Object_Definition => Direct_Type); end; when K_Sequence_Type => declare Seq_Package_Node : Node_Id; Seq_Exp : Node_Id; begin -- Getting the instantiated package node Seq_Package_Node := Expand_Designator (Instantiation_Node (BE_Node (Orig_Type))); -- Sequence type N := Make_Selected_Component (Seq_Package_Node, Make_Identifier (TN (T_Sequence))); -- null sequence Seq_Exp := Make_Selected_Component (Seq_Package_Node, Make_Identifier (PN (P_Null_Sequence))); -- Variable declaration N := Make_Object_Declaration (Defining_Identifier => Make_Defining_Identifier (Var_Name), Object_Definition => N, Expression => Seq_Exp); end; when K_Any => N := Make_Object_Declaration (Defining_Identifier => Make_Defining_Identifier (Var_Name), Object_Definition => RE (RE_Any_1)); when others => raise Program_Error with "Storage_Variable_Declaration: " & FEN.Node_Kind'Image (FEN.Kind (Orig_Type)) & ": Not Yet Implemented!"; end case; return N; end Storage_Variable_Declaration; ----------------- -- Do_Marshall -- ----------------- function Do_Marshall (Var_Node : Node_Id; Var_Type : Node_Id; Buff : Name_Id) return Node_Id is Block_Dcl : constant List_Id := New_List; Block_St : constant List_Id := New_List; N : Node_Id; Type_Spec_Node : Node_Id; Direct_Type_Node : Node_Id; begin -- Getting the original type Type_Spec_Node := FEU.Get_Original_Type_Specifier (Var_Type); if FEN.Kind (Var_Type) = K_Simple_Declarator or else FEN.Kind (Var_Type) = K_Complex_Declarator then Direct_Type_Node := Type_Spec (Declaration (Var_Type)); else Direct_Type_Node := Var_Type; end if; case FEN.Kind (Type_Spec_Node) is when K_Boolean | K_Double | K_Float | K_Long | K_Long_Double | K_Long_Long | K_Octet | K_Short | K_Unsigned_Long | K_Unsigned_Long_Long | K_Unsigned_Short | K_Enumeration_Type | K_Object => N := Make_Subprogram_Call (RE (RE_Marshall_2), New_List (Make_Identifier (Buff), Cast_Variable_To_PolyORB_Type (Var_Node, Direct_Type_Node))); Append_To (Block_St, N); when K_Fixed_Point_Type => declare FP_Type_Node : Node_Id; begin -- Getting the fixed point type FP_Type_Node := Expand_Designator (Type_Def_Node (BE_Node (Type_Spec_Node))); -- Instantiate the package: -- PolyORB.Representations.CDR.Common.Fixed_Point. N := Make_Package_Instantiation (Make_Defining_Identifier (VN (V_Fixed_Point)), RU (RU_PolyORB_Representations_CDR_Common_Fixed_Point), New_List (FP_Type_Node)); Append_To (Block_Dcl, N); -- Marshall N := Make_Selected_Component (VN (V_Fixed_Point), SN (S_Marshall)); N := Make_Subprogram_Call (N, New_List (Make_Identifier (Buff), Cast_Variable_To_PolyORB_Type (Var_Node, Direct_Type_Node))); Append_To (Block_St, N); end; when K_Char | K_String | K_String_Type | K_Wide_Char | K_Wide_String | K_Wide_String_Type => declare Profile : constant List_Id := New_List; begin N := Make_Identifier (PN (P_Representation)); Append_To (Profile, N); N := Make_Identifier (Buff); Append_To (Profile, N); Append_To (Profile, Cast_Variable_To_PolyORB_Type (Var_Node, Direct_Type_Node)); N := Make_Identifier (PN (P_Error)); Append_To (Profile, N); N := Make_Subprogram_Call (RE (RE_Marshall_1), Profile); Append_To (Block_St, N); -- Handling the error N := Make_Subprogram_Call (RE (RE_Found), New_List (Make_Identifier (PN (P_Error)))); N := Make_If_Statement (Condition => N, Then_Statements => New_List (Make_Return_Statement (No_Node))); Append_To (Block_St, N); end; when K_Interface_Declaration | K_Forward_Interface_Declaration => -- Check whether we are dealing with a TypeCode if Get_Predefined_CORBA_Entity (Type_Spec_Node) = RE_Object then declare Profile : constant List_Id := New_List; begin N := Make_Identifier (Buff); Append_To (Profile, N); N := Make_Attribute_Reference (Make_Type_Conversion (Make_Attribute_Reference (RE (RE_CDR_Representation), A_Class), Make_Identifier (PN (P_Representation))), A_Unrestricted_Access); Append_To (Profile, N); Append_To (Profile, Cast_Variable_To_PolyORB_Type (Var_Node, Direct_Type_Node)); N := Make_Identifier (PN (P_Error)); Append_To (Profile, N); N := Make_Subprogram_Call (RE (RE_Marshall_1), Profile); Append_To (Block_St, N); -- Handling the error N := Make_Subprogram_Call (RE (RE_Found), New_List (Make_Identifier (PN (P_Error)))); N := Make_If_Statement (Condition => N, Then_Statements => New_List (Make_Return_Statement (No_Node))); Append_To (Block_St, N); end; else N := Make_Subprogram_Call (RE (RE_Marshall_2), New_List (Make_Identifier (Buff), Cast_Variable_To_PolyORB_Type (Var_Node, Direct_Type_Node))); Append_To (Block_St, N); end if; when K_Sequence_Type => declare Seq_Package_Node : Node_Id; Seq_Element : Node_Id; Index_Node : Node_Id; Range_Constraint : Node_Id; Index_Name : constant Name_Id := Get_Index_Name; Seq_Length : constant Name_Id := Get_Length_Name; For_Statements : constant List_Id := New_List; begin -- Getting the instantiated package node Seq_Package_Node := Expand_Designator (Instantiation_Node (BE_Node (Type_Spec_Node))); -- Getting the sequence length N := Make_Object_Declaration (Defining_Identifier => Make_Defining_Identifier (Seq_Length), Object_Definition => RE (RE_Unsigned_Long_1)); Append_To (Block_Dcl, N); N := Make_Selected_Component (Seq_Package_Node, Make_Identifier (SN (S_Length))); N := Make_Subprogram_Call (N, New_List (Cast_Variable_To_PolyORB_Type (Var_Node, Direct_Type_Node))); N := Make_Subprogram_Call (RE (RE_Unsigned_Long_1), New_List (N)); N := Make_Assignment_Statement (Make_Defining_Identifier (Seq_Length), N); Append_To (Block_St, N); -- Marshalling the sequence length (Unsigned_Long) N := Make_Subprogram_Call (RE (RE_Marshall_2), New_List (Make_Identifier (Buff), Make_Defining_Identifier (Seq_Length))); Append_To (Block_St, N); -- Marshalling the sequence elements Index_Node := Make_Defining_Identifier (Index_Name); -- Creating the range constraint Range_Constraint := Make_Range_Constraint (Make_Literal (Int1_Val), Make_Defining_Identifier (Seq_Length)); -- Getting the sequence element N := Make_Selected_Component (Seq_Package_Node, Get_Base_Identifier (RE (RE_Get_Element))); Seq_Element := Make_Subprogram_Call (N, New_List (Cast_Variable_To_PolyORB_Type (Var_Node, Direct_Type_Node), Make_Subprogram_Call (RE (RE_Positive), New_List (Index_Node)))); -- Marshalling the sequence element N := Do_Marshall (Var_Node => Seq_Element, Var_Type => Type_Spec (Type_Spec_Node), Buff => Buff); Append_To (For_Statements, N); -- Building the loop N := Make_For_Statement (Index_Node, Range_Constraint, For_Statements); Append_To (Block_St, N); end; when K_Complex_Declarator => declare I : Nat := 0; Sizes : constant List_Id := Range_Constraints (Type_Definition (Type_Def_Node (BE_Node (Identifier (Type_Spec_Node))))); Dim : Node_Id; Loop_Statements : List_Id := No_List; Enclosing_Statements : List_Id; Index_List : constant List_Id := New_List; Index_Node : Node_Id := No_Node; Index_Name : constant Name_Id := Get_Index_Name; begin -- Building the nested loops Dim := First_Node (Sizes); loop Get_Name_String (Index_Name); Add_Char_To_Name_Buffer ('_'); Add_Nat_To_Name_Buffer (I); Index_Node := Make_Defining_Identifier (Add_Suffix_To_Name (Unique_Suffix, Name_Find)); Append_To (Index_List, Index_Node); Enclosing_Statements := Loop_Statements; Loop_Statements := New_List; N := Make_For_Statement (Index_Node, Dim, Loop_Statements); if I > 0 then Append_To (Enclosing_Statements, N); else Append_To (Block_St, N); end if; I := I + 1; Dim := Next_Node (Dim); exit when No (Dim); end loop; -- Filling the statements of the deepest loop by -- the marshalling of the corresponding array -- element. N := Make_Subprogram_Call (Var_Node, Index_List); N := Do_Marshall (Var_Node => N, Var_Type => Type_Spec (Declaration (Type_Spec_Node)), Buff => Buff); Append_To (Loop_Statements, N); end; when K_Structure_Type => declare Member : Node_Id; Declarator : Node_Id; Dcl_Ada_Name : Name_Id; Dcl_Ada_Node : Node_Id; begin Member := First_Entity (Members (Type_Spec_Node)); while Present (Member) loop Declarator := First_Entity (FEN.Declarators (Member)); while Present (Declarator) loop -- Getting the record field name Dcl_Ada_Name := To_Ada_Name (IDL_Name (Identifier (Declarator))); Dcl_Ada_Node := Make_Selected_Component (Var_Node, Make_Identifier (Dcl_Ada_Name)); -- Marshalling the record field N := Do_Marshall (Var_Node => Dcl_Ada_Node, Var_Type => Declarator, Buff => Buff); Append_To (Block_St, N); Declarator := Next_Entity (Declarator); end loop; Member := Next_Entity (Member); end loop; end; when K_Union_Type => declare Switch_Node : Node_Id; Switch_Alternatives : List_Id; Switch_Case : Node_Id; Has_Default : Boolean := False; Choices : List_Id; Literal_Parent : Node_Id := No_Node; Switch_Statements : List_Id; Switch_Type : Node_Id; Dcl_Ada_Name : Name_Id; Dcl_Ada_Node : Node_Id; Declarator : Node_Id; begin -- 1/ Marshall the union switch Switch_Node := Make_Selected_Component (Var_Node, Make_Identifier (CN (C_Switch))); N := Do_Marshall (Var_Node => Switch_Node, Var_Type => Switch_Type_Spec (Type_Spec_Node), Buff => Buff); Append_To (Block_St, N); -- 2/ Depending on the switch value, marshall the -- corresponding flag. Switch_Type := FEU.Get_Original_Type_Specifier (Switch_Type_Spec (Type_Spec_Node)); if FEN.Kind (Switch_Type) = K_Enumeration_Type then Literal_Parent := Map_Expanded_Name (Scope_Entity (Identifier (Switch_Type))); end if; Switch_Alternatives := New_List; Switch_Case := First_Entity (Switch_Type_Body (Type_Spec_Node)); while Present (Switch_Case) loop Map_Choice_List (Labels (Switch_Case), Literal_Parent, Choices, Has_Default); Switch_Statements := New_List; -- Getting the field name Declarator := FEN.Declarator (Element (Switch_Case)); Dcl_Ada_Name := To_Ada_Name (IDL_Name (Identifier (Declarator))); Dcl_Ada_Node := Make_Selected_Component (Var_Node, Make_Identifier (Dcl_Ada_Name)); -- Marshalling the record field N := Do_Marshall (Var_Node => Dcl_Ada_Node, Var_Type => Declarator, Buff => Buff); Append_To (Switch_Statements, N); -- Building the switch alternative Append_To (Switch_Alternatives, Make_Case_Statement_Alternative (Choices, Switch_Statements)); Switch_Case := Next_Entity (Switch_Case); end loop; -- Add an empty when others clause to keep the compiler -- happy. if not Has_Default then Append_To (Switch_Alternatives, Make_Case_Statement_Alternative (No_List, No_List)); end if; N := Make_Case_Statement (Switch_Node, Switch_Alternatives); Append_To (Block_St, N); end; when K_Any => declare Profile : constant List_Id := New_List; begin N := Make_Identifier (Buff); Append_To (Profile, N); N := Make_Attribute_Reference (Make_Type_Conversion (Make_Attribute_Reference (RE (RE_CDR_Representation), A_Class), Make_Identifier (PN (P_Representation))), A_Unrestricted_Access); Append_To (Profile, N); Append_To (Profile, Cast_Variable_To_PolyORB_Type (Var_Node, Direct_Type_Node)); N := Make_Subprogram_Call (RE (RE_Marshall_1), Profile); Append_To (Block_St, N); end; when others => raise Program_Error with "Do_Marshall: " & FEN.Node_Kind'Image (FEN.Kind (Type_Spec_Node)) & ": Not Yet Implemented!"; end case; N := Make_Block_Statement (Declarative_Part => Block_Dcl, Statements => Block_St); return N; end Do_Marshall; ------------------- -- Do_Unmarshall -- ------------------- function Do_Unmarshall (Var_Node : Node_Id; Var_Type : Node_Id; Buff : Name_Id) return Node_Id is Block_Dcl : constant List_Id := New_List; Block_St : constant List_Id := New_List; N : Node_Id; Type_Spec_Node : Node_Id; Direct_Type_Node : Node_Id; begin -- Getting the original type Type_Spec_Node := FEU.Get_Original_Type_Specifier (Var_Type); if FEN.Kind (Var_Type) = K_Simple_Declarator or else FEN.Kind (Var_Type) = K_Complex_Declarator then Direct_Type_Node := Type_Spec (Declaration (Var_Type)); else Direct_Type_Node := Var_Type; end if; case FEN.Kind (Type_Spec_Node) is when K_Boolean | K_Double | K_Float | K_Long | K_Long_Double | K_Long_Long | K_Octet | K_Short | K_Unsigned_Long | K_Unsigned_Long_Long | K_Unsigned_Short | K_Enumeration_Type | K_Object => begin N := Make_Subprogram_Call (RE (RE_Unmarshall_2), New_List (Make_Identifier (Buff))); N := Make_Assignment_Statement (Var_Node, N); Append_To (Block_St, N); end; when K_Fixed_Point_Type => declare FP_Type_Node : Node_Id; begin -- Getting the fixed point type FP_Type_Node := Expand_Designator (Type_Def_Node (BE_Node (Type_Spec_Node))); -- Instantiate the package : -- PolyORB.Representations.CDR.Common.Fixed_Point. N := Make_Package_Instantiation (Make_Defining_Identifier (VN (V_Fixed_Point)), RU (RU_PolyORB_Representations_CDR_Common_Fixed_Point), New_List (FP_Type_Node)); Append_To (Block_Dcl, N); -- Unmarshall N := Make_Selected_Component (VN (V_Fixed_Point), SN (S_Unmarshall)); N := Make_Subprogram_Call (N, New_List (Make_Identifier (Buff))); N := Make_Assignment_Statement (Var_Node, N); Append_To (Block_St, N); end; when K_Char | K_String | K_String_Type | K_Wide_Char | K_Wide_String | K_Wide_String_Type => declare Profile : constant List_Id := New_List; begin N := Make_Identifier (PN (P_Representation)); Append_To (Profile, N); N := Make_Identifier (Buff); Append_To (Profile, N); Append_To (Profile, Var_Node); N := Make_Identifier (PN (P_Error)); Append_To (Profile, N); N := Make_Subprogram_Call (RE (RE_Unmarshall_1), Profile); Append_To (Block_St, N); -- Handling the error N := Make_Subprogram_Call (RE (RE_Found), New_List (Make_Identifier (PN (P_Error)))); N := Make_If_Statement (Condition => N, Then_Statements => New_List (Make_Return_Statement (No_Node))); Append_To (Block_St, N); end; when K_Interface_Declaration | K_Forward_Interface_Declaration => -- Check whether we are dealing with a TypeCode if Get_Predefined_CORBA_Entity (Type_Spec_Node) = RE_Object then declare Profile : constant List_Id := New_List; begin N := Make_Identifier (Buff); Append_To (Profile, N); N := Make_Attribute_Reference (Make_Type_Conversion (Make_Attribute_Reference (RE (RE_CDR_Representation), A_Class), Make_Identifier (PN (P_Representation))), A_Unrestricted_Access); Append_To (Profile, N); Append_To (Profile, Var_Node); N := Make_Identifier (PN (P_Error)); Append_To (Profile, N); N := Make_Subprogram_Call (RE (RE_Unmarshall_1), Profile); Append_To (Block_St, N); -- Handling the error N := Make_Subprogram_Call (RE (RE_Found), New_List (Make_Identifier (PN (P_Error)))); N := Make_If_Statement (Condition => N, Then_Statements => New_List (Make_Return_Statement (No_Node))); Append_To (Block_St, N); end; else N := Make_Subprogram_Call (RE (RE_Unmarshall_2), New_List (Make_Identifier (Buff))); N := Make_Assignment_Statement (Var_Node, N); Append_To (Block_St, N); end if; when K_Sequence_Type => declare Seq_Package_Node : Node_Id; Index_Node : Node_Id; Range_Constraint : Node_Id; Element_Dcl : Node_Id; Index_Name : constant Name_Id := Get_Index_Name; Seq_Element_Name : constant Name_Id := Get_Element_Name; Seq_Length : constant Name_Id := Get_Length_Name; For_Statements : constant List_Id := New_List; begin -- Getting the instantiated package node Seq_Package_Node := Expand_Designator (Instantiation_Node (BE_Node (Type_Spec_Node))); -- Getting the sequence length N := Make_Object_Declaration (Defining_Identifier => Make_Defining_Identifier (Seq_Length), Object_Definition => RE (RE_Unsigned_Long_1)); Append_To (Block_Dcl, N); -- Unmarshalling the sequence length N := Make_Subprogram_Call (RE (RE_Unmarshall_2), New_List (Make_Identifier (Buff))); N := Make_Assignment_Statement (Make_Identifier (Seq_Length), N); Append_To (Block_St, N); -- Unmarshalling the sequence elements Index_Node := Make_Defining_Identifier (Index_Name); -- Creating the range constraint Range_Constraint := Make_Range_Constraint (Make_Literal (Int1_Val), Make_Defining_Identifier (Seq_Length)); -- Declaring the element variable Element_Dcl := Storage_Variable_Declaration (Seq_Element_Name, Type_Spec (Type_Spec_Node)); Append_To (Block_Dcl, Element_Dcl); -- Unmarshalling the sequence element N := Do_Unmarshall (Var_Node => Make_Identifier (Seq_Element_Name), Var_Type => Type_Spec (Type_Spec_Node), Buff => Buff); Append_To (For_Statements, N); -- Appending the sequence element N := Make_Selected_Component (Seq_Package_Node, Make_Identifier (SN (S_Append))); N := Make_Subprogram_Call (N, New_List (Var_Node, Cast_Variable_From_PolyORB_Type (Seq_Element_Name, Type_Spec (Type_Spec_Node)))); Append_To (For_Statements, N); -- If we deal with nested sequences, we must -- purge the sequence element for the next -- unmarshalling iteration. if FEN.Kind (FEU.Get_Original_Type_Specifier (Type_Spec (Type_Spec_Node))) = K_Sequence_Type then N := Make_Assignment_Statement (Make_Identifier (Seq_Element_Name), Copy_Expanded_Name (BEN.Expression (Element_Dcl))); Append_To (For_Statements, N); end if; -- Building the loop N := Make_For_Statement (Index_Node, Range_Constraint, For_Statements); Append_To (Block_St, N); end; when K_Complex_Declarator => declare I : Nat := 0; Sizes : constant List_Id := Range_Constraints (Type_Definition (Type_Def_Node (BE_Node (Identifier (Type_Spec_Node))))); Dim : Node_Id; Loop_Statements : List_Id := No_List; Enclosing_Statements : List_Id; Index_List : constant List_Id := New_List; Index_Node : Node_Id := No_Node; Array_Element : constant Name_Id := Get_Element_Name; Index_Name : constant Name_Id := Get_Index_Name; begin -- Building the nested loops Dim := First_Node (Sizes); loop Get_Name_String (Index_Name); Add_Char_To_Name_Buffer ('_'); Add_Nat_To_Name_Buffer (I); Index_Node := Make_Defining_Identifier (Add_Suffix_To_Name (Unique_Suffix, Name_Find)); Append_To (Index_List, Index_Node); Enclosing_Statements := Loop_Statements; Loop_Statements := New_List; N := Make_For_Statement (Index_Node, Dim, Loop_Statements); if I > 0 then Append_To (Enclosing_Statements, N); else Append_To (Block_St, N); end if; I := I + 1; Dim := Next_Node (Dim); exit when No (Dim); end loop; -- Filling the statements of the deepest loop by -- the marshalling of the corresponding array -- element. -- Declaring the element variable N := Storage_Variable_Declaration (Array_Element, Type_Spec (Declaration (Type_Spec_Node))); Append_To (Block_Dcl, N); -- Unmarshalling the element and handling the error N := Do_Unmarshall (Var_Node => Make_Identifier (Array_Element), Var_Type => Type_Spec (Declaration (Type_Spec_Node)), Buff => Buff); Append_To (Loop_Statements, N); -- Updating the array element N := Make_Subprogram_Call (Var_Node, Index_List); N := Make_Assignment_Statement (N, Cast_Variable_From_PolyORB_Type (Array_Element, Type_Spec (Declaration (Type_Spec_Node)))); Append_To (Loop_Statements, N); end; when K_Structure_Type => declare Member : Node_Id; Declarator : Node_Id; Dcl_Ada_Name : Name_Id; Dcl_Ada_Node : Node_Id; Struct_Element : Name_Id; begin Member := First_Entity (Members (Type_Spec_Node)); while Present (Member) loop Declarator := First_Entity (FEN.Declarators (Member)); while Present (Declarator) loop -- Getting an element name Struct_Element := Get_Element_Name; -- Declaring the element variable N := Storage_Variable_Declaration (Struct_Element, Declarator); Append_To (Block_Dcl, N); -- Unmarshalling the element N := Do_Unmarshall (Var_Node => Make_Identifier (Struct_Element), Var_Type => Declarator, Buff => Buff); Append_To (Block_St, N); -- Getting the record field name Dcl_Ada_Name := To_Ada_Name (IDL_Name (Identifier (Declarator))); Dcl_Ada_Node := Make_Selected_Component (Var_Node, Make_Identifier (Dcl_Ada_Name)); -- Updating the struct field N := Make_Assignment_Statement (Dcl_Ada_Node, Cast_Variable_From_PolyORB_Type (Struct_Element, Declarator)); Append_To (Block_St, N); Declarator := Next_Entity (Declarator); end loop; Member := Next_Entity (Member); end loop; end; when K_Union_Type => declare Switch_Alternatives : List_Id; Switch_Case : Node_Id; Has_Default : Boolean := False; Choices : List_Id; Literal_Parent : Node_Id := No_Node; Switch_Statements : List_Id; Switch_Type : Node_Id; Dcl_Ada_Name : Name_Id; Dcl_Ada_Node : Node_Id; Declarator : Node_Id; Switch_Element : Name_Id; Union_Element : Name_Id; begin -- 1/ Unmarshall the union switch -- Getting an element name Switch_Element := Get_Element_Name; -- Declaring the switch variable N := Storage_Variable_Declaration (Switch_Element, Switch_Type_Spec (Type_Spec_Node)); Append_To (Block_Dcl, N); -- Unmarshall the switch N := Do_Unmarshall (Var_Node => Make_Identifier (Switch_Element), Var_Type => Switch_Type_Spec (Type_Spec_Node), Buff => Buff); Append_To (Block_St, N); -- 2/ Build the union: we cannot build the union by -- the means of a record aggregate. The solution is -- to declare an intermediary variable with the -- correct union type and then to assign the union -- this variable by means of a qualified -- expression. declare Inner_Dcl : constant List_Id := New_List; Inner_St : constant List_Id := New_List; Intermed_Name : constant Name_Id := Get_Union_Name; begin -- Intermediary variable with the correct type N := Make_Subprogram_Call (Map_Expanded_Name (Direct_Type_Node), New_List (Cast_Variable_From_PolyORB_Type (Switch_Element, Switch_Type_Spec (Type_Spec_Node)))); N := Make_Object_Declaration (Defining_Identifier => Make_Defining_Identifier (Intermed_Name), Object_Definition => N); Append_To (Inner_Dcl, N); -- Disable warning because the variable is not -- assigned. N := Make_Pragma (Pragma_Warnings, New_List (RE (RE_Off), Make_Defining_Identifier (Intermed_Name))); Append_To (Inner_Dcl, N); -- Qualified expression N := Make_Qualified_Expression (Subtype_Mark => Map_Expanded_Name (Direct_Type_Node), Operand => Make_Identifier (Intermed_Name)); N := Make_Assignment_Statement (Var_Node, N); Append_To (Inner_St, N); -- Add the new block statements N := Make_Block_Statement (Declarative_Part => Inner_Dcl, Statements => Inner_St); Append_To (Block_St, N); end; -- 3/ Depending on the switch value, unmarshall the -- corresponding flag. Switch_Type := FEU.Get_Original_Type_Specifier (Switch_Type_Spec (Type_Spec_Node)); if FEN.Kind (Switch_Type) = K_Enumeration_Type then Literal_Parent := Map_Expanded_Name (Scope_Entity (Identifier (Switch_Type))); end if; Switch_Alternatives := New_List; Switch_Case := First_Entity (Switch_Type_Body (Type_Spec_Node)); while Present (Switch_Case) loop Map_Choice_List (Labels (Switch_Case), Literal_Parent, Choices, Has_Default); Switch_Statements := New_List; Declarator := FEN.Declarator (Element (Switch_Case)); -- Getting an element name Union_Element := Get_Element_Name; -- Declaring the element variable N := Storage_Variable_Declaration (Union_Element, Declarator); Append_To (Block_Dcl, N); -- Unmarshalling the element N := Do_Unmarshall (Var_Node => Make_Identifier (Union_Element), Var_Type => Declarator, Buff => Buff); Append_To (Switch_Statements, N); -- Getting the field name Dcl_Ada_Name := To_Ada_Name (IDL_Name (Identifier (Declarator))); Dcl_Ada_Node := Make_Selected_Component (Var_Node, Make_Identifier (Dcl_Ada_Name)); N := Make_Assignment_Statement (Dcl_Ada_Node, Cast_Variable_From_PolyORB_Type (Union_Element, Declarator)); Append_To (Switch_Statements, N); -- Building the switch alternative Append_To (Switch_Alternatives, Make_Case_Statement_Alternative (Choices, Switch_Statements)); Switch_Case := Next_Entity (Switch_Case); end loop; -- Add an empty when others clause to keep the compiler -- happy. if not Has_Default then Append_To (Switch_Alternatives, Make_Case_Statement_Alternative (No_List, No_List)); end if; N := Make_Case_Statement (Cast_Variable_From_PolyORB_Type (Switch_Element, Switch_Type_Spec (Type_Spec_Node)), Switch_Alternatives); Append_To (Block_St, N); end; when K_Any => declare Profile : constant List_Id := New_List; begin N := Make_Identifier (Buff); Append_To (Profile, N); N := Make_Attribute_Reference (Make_Type_Conversion (Make_Attribute_Reference (RE (RE_CDR_Representation), A_Class), Make_Identifier (PN (P_Representation))), A_Unrestricted_Access); Append_To (Profile, N); N := Make_Subprogram_Call (RE (RE_Unmarshall_1), Profile); N := Make_Assignment_Statement (Var_Node, N); Append_To (Block_St, N); end; when others => raise Program_Error with "Do_Unmarshall: " & FEN.Node_Kind'Image (FEN.Kind (Type_Spec_Node)) & ": Not Yet Implemented!"; end case; N := Make_Block_Statement (Declarative_Part => Block_Dcl, Statements => Block_St); return N; end Do_Unmarshall; ---------------------- -- Get_Element_Name -- ---------------------- function Get_Element_Name return Name_Id is Element : Name_Id; begin Set_Str_To_Name_Buffer ("Element_"); Element_Number := Element_Number + 1; Add_Nat_To_Name_Buffer (Element_Number); Element := Add_Suffix_To_Name (Unique_Suffix, Name_Find); return Element; end Get_Element_Name; -------------------- -- Get_Index_Name -- -------------------- function Get_Index_Name return Name_Id is Index : Name_Id; begin Set_Str_To_Name_Buffer ("Index_"); Index_Number := Index_Number + 1; Add_Nat_To_Name_Buffer (Index_Number); Index := Name_Find; return Index; end Get_Index_Name; --------------------- -- Get_Length_Name -- --------------------- function Get_Length_Name return Name_Id is Length : Name_Id; begin Set_Str_To_Name_Buffer ("Length_"); Length_Number := Length_Number + 1; Add_Nat_To_Name_Buffer (Length_Number); Length := Name_Find; return Length; end Get_Length_Name; -------------------- -- Get_Union_Name -- -------------------- function Get_Union_Name return Name_Id is U : Name_Id; begin Set_Str_To_Name_Buffer ("Union_"); Union_Number := Union_Number + 1; Add_Nat_To_Name_Buffer (Union_Number); U := Name_Find; return U; end Get_Union_Name; ----------- -- Visit -- ----------- procedure Visit (E : Node_Id) is begin case FEN.Kind (E) is when K_Attribute_Declaration => Visit_Attribute_Declaration (E); when K_Interface_Declaration => Visit_Interface_Declaration (E); when K_Module => Visit_Module (E); when K_Operation_Declaration => Visit_Operation_Declaration (E); when K_Specification => Visit_Specification (E); when others => null; end case; end Visit; --------------------------------- -- Visit_Attribute_Declaration -- --------------------------------- procedure Visit_Attribute_Declaration (E : Node_Id) is N : Node_Id; D : Node_Id; begin Set_CDR_Body; D := First_Entity (Declarators (E)); while Present (D) loop Set_Str_To_Name_Buffer ("Attribute : "); Get_Name_String_And_Append (IDL_Name (Identifier (D))); N := Make_Ada_Comment (Name_Find); Append_To (Statements (Current_Package), N); D := Next_Entity (D); end loop; end Visit_Attribute_Declaration; --------------------------------- -- Visit_Interface_Declaration -- --------------------------------- procedure Visit_Interface_Declaration (E : Node_Id) is N : Node_Id; begin -- No CDR package is generated for a local interface if FEN.Is_Local_Interface (E) then return; end if; N := BEN.Parent (Type_Def_Node (BE_Node (Identifier (E)))); Push_Entity (BEN.IDL_Unit (Package_Declaration (N))); Set_CDR_Body; N := First_Entity (Interface_Body (E)); while Present (N) loop Visit (N); N := Next_Entity (N); end loop; Pop_Entity; end Visit_Interface_Declaration; ------------------ -- Visit_Module -- ------------------ procedure Visit_Module (E : Node_Id) is D : Node_Id; begin if not Map_Particular_CORBA_Parts (E, PK_CDR_Body) then Push_Entity (Stub_Node (BE_Node (Identifier (E)))); D := First_Entity (Definitions (E)); while Present (D) loop Visit (D); D := Next_Entity (D); end loop; Pop_Entity; end if; end Visit_Module; --------------------------------- -- Visit_Operation_Declaration -- --------------------------------- procedure Visit_Operation_Declaration (E : Node_Id) is N : Node_Id; begin Set_CDR_Body; -- Explaining comment Set_Str_To_Name_Buffer ("Operation : "); Get_Name_String_And_Append (IDL_Name (Identifier (E))); N := Make_Ada_Comment (Name_Find); Append_To (Statements (Current_Package), N); -- Generating the 'Operation_Name'_Marshaller Body N := Marshaller_Body (E); Append_To (Statements (Current_Package), N); -- Generating the 'Operation_Name'_Unmarshaller Body N := Unmarshaller_Body (E); Append_To (Statements (Current_Package), N); end Visit_Operation_Declaration; ------------------------- -- Visit_Specification -- ------------------------- procedure Visit_Specification (E : Node_Id) is Definition : Node_Id; begin Push_Entity (Stub_Node (BE_Node (Identifier (E)))); Definition := First_Entity (Definitions (E)); while Present (Definition) loop Visit (Definition); Definition := Next_Entity (Definition); end loop; Pop_Entity; end Visit_Specification; end Package_Body; end Backend.BE_CORBA_Ada.CDRs;